From 7dfcc480ba1e19bd3232349fc733caef94034292 Mon Sep 17 00:00:00 2001 From: stainer_t Date: Mon, 8 Sep 2025 13:48:49 +0200 Subject: Initial commit from Polytechnique Montreal --- Dragon/src/AEXCPC.f | 40 + Dragon/src/AEXDIR.f | 90 + Dragon/src/AEXGNV.f | 51 + Dragon/src/AEXTPA.f | 66 + Dragon/src/AEXTRT.f | 195 ++ Dragon/src/APX.f | 556 +++++ Dragon/src/APXCA2.f | 405 ++++ Dragon/src/APXCAL.f | 176 ++ Dragon/src/APXCAT.f | 258 +++ Dragon/src/APXGEM.f | 188 ++ Dragon/src/APXGEP.f | 234 +++ Dragon/src/APXGEY.f | 205 ++ Dragon/src/APXIDF.f | 146 ++ Dragon/src/APXPAV.f | 164 ++ Dragon/src/APXSX2.f | 529 +++++ Dragon/src/APXTOC.f | 251 +++ Dragon/src/ASM.f | 335 +++ Dragon/src/ASMDRV.f | 361 ++++ Dragon/src/AUTDRV.f | 455 ++++ Dragon/src/AUTFLU.f | 379 ++++ Dragon/src/AUTIT1.f | 224 ++ Dragon/src/AUTIT2.f | 241 +++ Dragon/src/AUTO.f | 383 ++++ Dragon/src/AUTONE.f | 509 +++++ Dragon/src/AUTPRD.f | 55 + Dragon/src/AUTSPH.f | 329 +++ Dragon/src/AUTTAB.f | 160 ++ Dragon/src/AXGDIA.f | 205 ++ Dragon/src/AXGGEO.f | 148 ++ Dragon/src/AXGSYM.f | 298 +++ Dragon/src/AXGTRN.f | 53 + Dragon/src/AXGTRS.f | 78 + Dragon/src/AXGXCW.f | 152 ++ Dragon/src/AXGXEL.f | 203 ++ Dragon/src/B1BETA.f | 73 + Dragon/src/B1DIF.f | 381 ++++ Dragon/src/B1GAMA.f | 74 + Dragon/src/B1HOM.f | 221 ++ Dragon/src/B1HXS1.f | 447 ++++ Dragon/src/B1SOL.f | 65 + Dragon/src/BIVAA.f | 149 ++ Dragon/src/BIVAF.f | 164 ++ Dragon/src/BIVFIS.f | 186 ++ Dragon/src/BIVS01.f | 117 ++ Dragon/src/BIVS02.f | 106 + Dragon/src/BIVS03.f | 145 ++ Dragon/src/BIVS04.f | 108 + Dragon/src/BIVS05.f | 112 + Dragon/src/BIVSOU.f | 277 +++ Dragon/src/BREANM.f | 340 +++ Dragon/src/BREDRV.f | 307 +++ Dragon/src/BREERA.f | 443 ++++ Dragon/src/BREERM.f | 523 +++++ Dragon/src/BREF.f | 260 +++ Dragon/src/BREKOE.f | 206 ++ Dragon/src/BRELLB.f | 157 ++ Dragon/src/BREMAC.f | 369 ++++ Dragon/src/BRENEM.f | 352 ++++ Dragon/src/BRERT.f | 414 ++++ Dragon/src/BRERTD.f90 | 180 ++ Dragon/src/BRERTS.f90 | 267 +++ Dragon/src/BRESS1.f | 71 + Dragon/src/BRESS2.f | 52 + Dragon/src/BRESS3.f | 77 + Dragon/src/BRESS4.f | 53 + Dragon/src/CFC.f | 329 +++ Dragon/src/CFCDRV.f | 1117 ++++++++++ Dragon/src/CFCFBM.f | 1227 +++++++++++ Dragon/src/CFCGET.f | 210 ++ Dragon/src/CHAB.f | 247 +++ Dragon/src/CHAB01.f | 297 +++ Dragon/src/CHAB02.f | 84 + Dragon/src/CHAB03.f | 115 ++ Dragon/src/CHAB04.f | 151 ++ Dragon/src/CLM.f | 229 +++ Dragon/src/CLMGET.f | 200 ++ Dragon/src/COMACR.f | 276 +++ Dragon/src/COMARB.f | 165 ++ Dragon/src/COMBIB.f | 102 + Dragon/src/COMCAL.f | 165 ++ Dragon/src/COMCAT.f | 383 ++++ Dragon/src/COMDEP.f | 135 ++ Dragon/src/COMGEM.f | 188 ++ Dragon/src/COMGEN.f | 176 ++ Dragon/src/COMGEP.f | 383 ++++ Dragon/src/COMGFF.f | 118 ++ Dragon/src/COMISO.f | 103 + Dragon/src/COMMIC.f | 478 +++++ Dragon/src/COMPAV.f | 147 ++ Dragon/src/COMPO.f | 711 +++++++ Dragon/src/COMRES.f | 337 +++ Dragon/src/COMSDB.f | 200 ++ Dragon/src/COMTRE.f | 76 + Dragon/src/CPO.f | 439 ++++ Dragon/src/CPODRV.f | 366 ++++ Dragon/src/CPOISO.f | 188 ++ Dragon/src/CPOLGX.f | 192 ++ Dragon/src/CPOMAR.f | 288 +++ Dragon/src/CPOMAW.f | 205 ++ Dragon/src/CPOMIC.f | 260 +++ Dragon/src/CPONED.f | 113 + Dragon/src/CPOREM.f | 79 + Dragon/src/DEPLIT.f | 437 ++++ Dragon/src/DMA.f | 169 ++ Dragon/src/DMAGET.f | 203 ++ Dragon/src/DMASOU.f | 555 +++++ Dragon/src/DOORAB.f | 196 ++ Dragon/src/DOORAV.f | 329 +++ Dragon/src/DOORFB2.f | 160 ++ Dragon/src/DOORFB3.f | 147 ++ Dragon/src/DOORFV.f | 336 +++ Dragon/src/DOORPV.f | 342 ++++ Dragon/src/DOORS_BIV.f90 | 626 ++++++ Dragon/src/DOORS_MOD.f90 | 162 ++ Dragon/src/DOORS_SN.f90 | 175 ++ Dragon/src/DOORS_TRI.f90 | 252 +++ Dragon/src/DRAGON.f90 | 98 + Dragon/src/DUO.f | 121 ++ Dragon/src/DUO001.f | 174 ++ Dragon/src/DUO002.f | 158 ++ Dragon/src/DUO003.f | 225 ++ Dragon/src/DUO004.f | 179 ++ Dragon/src/DUO005.f | 88 + Dragon/src/DUO006.f | 206 ++ Dragon/src/DUO007.f | 125 ++ Dragon/src/DUODRV.f | 207 ++ Dragon/src/DUTURN.f | 506 +++++ Dragon/src/EDI.f | 667 ++++++ Dragon/src/EDIACT.f | 455 ++++ Dragon/src/EDIALB.f | 315 +++ Dragon/src/EDIBAL.f | 388 ++++ Dragon/src/EDIBHX.f | 73 + Dragon/src/EDIDEL.f | 72 + Dragon/src/EDIDEP.f | 138 ++ Dragon/src/EDIDRV.f | 773 +++++++ Dragon/src/EDIDST.f | 431 ++++ Dragon/src/EDIDTX.f | 945 +++++++++ Dragon/src/EDIENE.f | 105 + Dragon/src/EDIG2S.f90 | 251 +++ Dragon/src/EDIGAP.f | 79 + Dragon/src/EDIGEO.f | 478 +++++ Dragon/src/EDIGET.f | 724 +++++++ Dragon/src/EDIHFC.f | 295 +++ Dragon/src/EDIHFD.f | 233 +++ Dragon/src/EDIHMX.f | 77 + Dragon/src/EDIJO1.f | 172 ++ Dragon/src/EDIJO2.f | 113 + Dragon/src/EDIJO3.f | 160 ++ Dragon/src/EDILUM.f | 433 ++++ Dragon/src/EDIMAX.f | 105 + Dragon/src/EDIMCN.f | 282 +++ Dragon/src/EDIMIC.f | 1096 ++++++++++ Dragon/src/EDIMRC.f | 91 + Dragon/src/EDIMRG.f | 235 +++ Dragon/src/EDIPRR.f | 192 ++ Dragon/src/EDIPXS.f | 571 ++++++ Dragon/src/EDIRAT.f | 136 ++ Dragon/src/EDIRES.f | 520 +++++ Dragon/src/EDISTA.f | 127 ++ Dragon/src/EDITXS.f | 601 ++++++ Dragon/src/EDIUNF.f | 239 +++ Dragon/src/EDIWCU.f | 141 ++ Dragon/src/EDIWP1.f | 233 +++ Dragon/src/EPC.f | 238 +++ Dragon/src/EPCRMA.f | 279 +++ Dragon/src/EPCRMD.f | 234 +++ Dragon/src/EPCRMI.f | 131 ++ Dragon/src/EPCRMS.f | 171 ++ Dragon/src/EPCRMU.f | 201 ++ Dragon/src/EPCRMV.f | 197 ++ Dragon/src/EPCRPD.f | 133 ++ Dragon/src/EVO.f | 422 ++++ Dragon/src/EVOBLD.f | 501 +++++ Dragon/src/EVODPL.f | 425 ++++ Dragon/src/EVODRV.f | 1034 ++++++++++ Dragon/src/EVOGET.f | 401 ++++ Dragon/src/EVOKAP.f | 224 ++ Dragon/src/EVOMU1.f | 241 +++ Dragon/src/EVOODE.f | 114 ++ Dragon/src/EVORK.f | 193 ++ Dragon/src/EVOSAT.f | 380 ++++ Dragon/src/EVOSIG.f | 327 +++ Dragon/src/EVOSOL.f | 229 +++ Dragon/src/EXCELP.f | 624 ++++++ Dragon/src/EXCELT.f | 350 ++++ Dragon/src/FLU.f | 452 ++++ Dragon/src/FLU2AC.f | 84 + Dragon/src/FLU2DR.f | 1284 ++++++++++++ Dragon/src/FLUALB.f | 102 + Dragon/src/FLUBAL.f | 209 ++ Dragon/src/FLUBLN.f | 143 ++ Dragon/src/FLUDBV.f | 509 +++++ Dragon/src/FLUDRV.f | 345 ++++ Dragon/src/FLUGPI.f | 439 ++++ Dragon/src/FLUGPT.f | 361 ++++ Dragon/src/FLUKEF.f | 194 ++ Dragon/src/FLULPN.f | 227 ++ Dragon/src/FLUSOU.f90 | 202 ++ Dragon/src/FMAC.f | 259 +++ Dragon/src/FMAC01.f | 381 ++++ Dragon/src/FMAC02.f | 63 + Dragon/src/FMAC03.f | 145 ++ Dragon/src/FMAC04.f | 55 + Dragon/src/FMT.f | 125 ++ Dragon/src/FMTBRN.f | 250 +++ Dragon/src/FMTDFD.f | 170 ++ Dragon/src/FMTDFL.f | 157 ++ Dragon/src/FMTGET.f | 125 ++ Dragon/src/FMTGIS.f | 134 ++ Dragon/src/FMTSUD.f | 421 ++++ Dragon/src/FMTSUS.f | 208 ++ Dragon/src/FSDF.f90 | 190 ++ Dragon/src/GEO.f | 84 + Dragon/src/GEOIN1.f | 1375 +++++++++++++ Dragon/src/GEOMIX.f | 246 +++ Dragon/src/HEADRV.f | 233 +++ Dragon/src/HEAT.f | 260 +++ Dragon/src/INF.f | 397 ++++ Dragon/src/INFAPL.f | 110 + Dragon/src/INFDRA.f | 96 + Dragon/src/INFNDA.f | 97 + Dragon/src/INFPSA.f | 80 + Dragon/src/INFTR1.f | 163 ++ Dragon/src/INFTR2.f | 129 ++ Dragon/src/INFWAN.f | 62 + Dragon/src/INFWAT.f | 111 + Dragon/src/INFWD4.f | 199 ++ Dragon/src/INFWIM.f | 120 ++ Dragon/src/KDRDRV.F | 164 ++ Dragon/src/KELMRG.f | 69 + Dragon/src/KELRNG.f | 282 +++ Dragon/src/KELSYM.f | 96 + Dragon/src/LDRASS.f | 467 +++++ Dragon/src/LDRCEL.f | 370 ++++ Dragon/src/LDRGEO.f | 179 ++ Dragon/src/LELCHK.f | 140 ++ Dragon/src/LELCRN.f | 75 + Dragon/src/LELCSY.f | 785 +++++++ Dragon/src/LHXUNH.f | 1502 ++++++++++++++ Dragon/src/LIB.f | 562 +++++ Dragon/src/LIBA20.f | 1346 ++++++++++++ Dragon/src/LIBA21.f | 91 + Dragon/src/LIBA22.f | 117 ++ Dragon/src/LIBA23.f | 179 ++ Dragon/src/LIBA24.f | 423 ++++ Dragon/src/LIBA25.f | 244 +++ Dragon/src/LIBA26.f | 159 ++ Dragon/src/LIBA27.f | 248 +++ Dragon/src/LIBA28.f | 117 ++ Dragon/src/LIBA2G.f | 137 ++ Dragon/src/LIBA30.f | 533 +++++ Dragon/src/LIBA33.f | 151 ++ Dragon/src/LIBA34.f | 423 ++++ Dragon/src/LIBADD.f | 181 ++ Dragon/src/LIBADJ.f | 161 ++ Dragon/src/LIBAPL.f | 1000 +++++++++ Dragon/src/LIBBAS.f | 138 ++ Dragon/src/LIBCAT.f | 149 ++ Dragon/src/LIBCMB.f | 222 ++ Dragon/src/LIBCOM.f | 93 + Dragon/src/LIBCON.f | 118 ++ Dragon/src/LIBCOR.f | 177 ++ Dragon/src/LIBCOV.f | 57 + Dragon/src/LIBCTL.f | 475 +++++ Dragon/src/LIBD10.F | 62 + Dragon/src/LIBDEN.f | 1150 +++++++++++ Dragon/src/LIBDEP.F | 313 +++ Dragon/src/LIBDI1.f | 52 + Dragon/src/LIBDI2.f | 168 ++ Dragon/src/LIBDI3.f | 167 ++ Dragon/src/LIBDI4.f | 123 ++ Dragon/src/LIBDI5.f | 149 ++ Dragon/src/LIBDI6.f | 213 ++ Dragon/src/LIBDI8.f | 198 ++ Dragon/src/LIBDI9.f | 198 ++ Dragon/src/LIBDRA.f | 418 ++++ Dragon/src/LIBDRB.f | 773 +++++++ Dragon/src/LIBE3R.f | 298 +++ Dragon/src/LIBEAD.f | 224 ++ Dragon/src/LIBEAI.f | 124 ++ Dragon/src/LIBEAR.f | 580 ++++++ Dragon/src/LIBECT.f | 114 ++ Dragon/src/LIBEED.f90 | 166 ++ Dragon/src/LIBEIR.f | 224 ++ Dragon/src/LIBENI.f | 62 + Dragon/src/LIBENR.f | 204 ++ Dragon/src/LIBEPR.f | 349 ++++ Dragon/src/LIBEST.f | 265 +++ Dragon/src/LIBEWI.f | 84 + Dragon/src/LIBEWR.f | 221 ++ Dragon/src/LIBEXT.f | 211 ++ Dragon/src/LIBFQD.f | 957 +++++++++ Dragon/src/LIBINF.f | 221 ++ Dragon/src/LIBINP.f | 855 ++++++++ Dragon/src/LIBIPS.f | 64 + Dragon/src/LIBLAG.f | 107 + Dragon/src/LIBLEX.f | 99 + Dragon/src/LIBLIB.f | 180 ++ Dragon/src/LIBLIC.F | 253 +++ Dragon/src/LIBMAC.f | 460 +++++ Dragon/src/LIBMIC.f | 171 ++ Dragon/src/LIBMIX.f | 152 ++ Dragon/src/LIBMOM.f | 142 ++ Dragon/src/LIBMPA.f | 73 + Dragon/src/LIBND0.f | 55 + Dragon/src/LIBND1.f | 516 +++++ Dragon/src/LIBND3.f | 185 ++ Dragon/src/LIBND5.f | 57 + Dragon/src/LIBND6.f | 165 ++ Dragon/src/LIBND7.f | 91 + Dragon/src/LIBNFI.f | 194 ++ Dragon/src/LIBNOT.f | 140 ++ Dragon/src/LIBNRG.F | 406 ++++ Dragon/src/LIBOMG.f | 119 ++ Dragon/src/LIBPRI.f | 257 +++ Dragon/src/LIBPTT.f | 381 ++++ Dragon/src/LIBPTW.f | 243 +++ Dragon/src/LIBRSC.f | 350 ++++ Dragon/src/LIBRSE.f | 573 ++++++ Dragon/src/LIBSDC.f | 203 ++ Dragon/src/LIBSEC.f | 246 +++ Dragon/src/LIBSUB.f | 517 +++++ Dragon/src/LIBTAB.f | 187 ++ Dragon/src/LIBTE2.f | 173 ++ Dragon/src/LIBTER.f | 124 ++ Dragon/src/LIBTR1.f | 793 +++++++ Dragon/src/LIBTR2.f | 894 ++++++++ Dragon/src/LIBWD4.f | 788 +++++++ Dragon/src/LIBWE.f | 789 +++++++ Dragon/src/LIBWED.f | 181 ++ Dragon/src/LIBWET.f | 312 +++ Dragon/src/LIBWID.f | 51 + Dragon/src/LIBWIM.f | 776 +++++++ Dragon/src/LIBWRE.f | 270 +++ Dragon/src/LIBWRG.f | 148 ++ Dragon/src/LIBWRI.f | 91 + Dragon/src/LIBWRP.f | 111 + Dragon/src/LIBWSC.f | 73 + Dragon/src/LIBWTE.f | 132 ++ Dragon/src/LIBWTF.f | 61 + Dragon/src/LIBXS1.f | 44 + Dragon/src/LIBXS2.f | 292 +++ Dragon/src/LIBXS3.f | 50 + Dragon/src/LIBXS4.f | 958 +++++++++ Dragon/src/LIBXS5.f | 146 ++ Dragon/src/LIBXS6.f | 92 + Dragon/src/M2T.f | 156 ++ Dragon/src/M2TDRV.f | 294 +++ Dragon/src/MAC.f | 281 +++ Dragon/src/MACDRV.f | 356 ++++ Dragon/src/MACIXS.f | 295 +++ Dragon/src/MACNFI.f | 220 ++ Dragon/src/MACNXS.f | 141 ++ Dragon/src/MACOPT.f | 196 ++ Dragon/src/MACPRM.f | 178 ++ Dragon/src/MACPXS.f | 258 +++ Dragon/src/MACRDM.f | 267 +++ Dragon/src/MACUPD.f | 295 +++ Dragon/src/MACUPG.f | 125 ++ Dragon/src/MACWXS.f | 388 ++++ Dragon/src/MACXSR.f | 690 +++++++ Dragon/src/MCCGA.f | 324 +++ Dragon/src/MCCGF.f | 536 +++++ Dragon/src/MCCGT.f | 1050 ++++++++++ Dragon/src/MCGABG.f | 210 ++ Dragon/src/MCGABGR.f | 294 +++ Dragon/src/MCGACA.f | 149 ++ Dragon/src/MCGASM.f | 675 ++++++ Dragon/src/MCGBIC.f | 373 ++++ Dragon/src/MCGCAL.f | 75 + Dragon/src/MCGCDD.f | 176 ++ Dragon/src/MCGCOEF.f | 106 + Dragon/src/MCGDDDF.f | 129 ++ Dragon/src/MCGDDF.f | 59 + Dragon/src/MCGDDFL.f | 69 + Dragon/src/MCGDDFS.f | 61 + Dragon/src/MCGDDFT.f | 59 + Dragon/src/MCGDS1.f | 116 ++ Dragon/src/MCGDS2.f | 232 +++ Dragon/src/MCGDS2A.f | 83 + Dragon/src/MCGDS2E.f | 74 + Dragon/src/MCGDS3.f | 111 + Dragon/src/MCGDS4.f | 108 + Dragon/src/MCGDS6.f | 55 + Dragon/src/MCGDSCA.f | 158 ++ Dragon/src/MCGDSCB.f | 187 ++ Dragon/src/MCGDSCE.f | 152 ++ Dragon/src/MCGDSD.f | 139 ++ Dragon/src/MCGDSP.f | 117 ++ Dragon/src/MCGDTV.f | 131 ++ Dragon/src/MCGDYA.f | 74 + Dragon/src/MCGFCA.f | 535 +++++ Dragon/src/MCGFCF.f | 496 +++++ Dragon/src/MCGFCR.f | 136 ++ Dragon/src/MCGFCS.f | 112 + Dragon/src/MCGFFAL.f | 138 ++ Dragon/src/MCGFFAR.f | 110 + Dragon/src/MCGFFAS.f | 110 + Dragon/src/MCGFFAT.f | 108 + Dragon/src/MCGFFIR.f | 131 ++ Dragon/src/MCGFFIS.f | 136 ++ Dragon/src/MCGFFIT.f | 124 ++ Dragon/src/MCGFL1.f | 342 ++++ Dragon/src/MCGFLS.f | 134 ++ Dragon/src/MCGFLX.f | 214 ++ Dragon/src/MCGFMC.f | 73 + Dragon/src/MCGFST.f | 135 ++ Dragon/src/MCGMRE.f | 316 +++ Dragon/src/MCGPJJ.f | 109 + Dragon/src/MCGPRA.f | 159 ++ Dragon/src/MCGPT1.f | 154 ++ Dragon/src/MCGPT2.f | 112 + Dragon/src/MCGPTA.f | 402 ++++ Dragon/src/MCGPTF.f | 663 ++++++ Dragon/src/MCGPTN.f | 177 ++ Dragon/src/MCGPTS.f | 332 +++ Dragon/src/MCGPTV.f | 332 +++ Dragon/src/MCGREC.f | 61 + Dragon/src/MCGSCA.f | 74 + Dragon/src/MCGSCAL.f | 103 + Dragon/src/MCGSCAS.f | 84 + Dragon/src/MCGSCAT.f | 65 + Dragon/src/MCGSCE.f | 71 + Dragon/src/MCGSCEL.f | 85 + Dragon/src/MCGSCES.f | 78 + Dragon/src/MCGSCET.f | 59 + Dragon/src/MCGSCR.f | 338 +++ Dragon/src/MCGSCS.f | 102 + Dragon/src/MCGSIG.f | 77 + Dragon/src/MCGTMT.f | 97 + Dragon/src/MCGTRK.f | 72 + Dragon/src/MCT.f | 202 ++ Dragon/src/MCTALLY.f | 131 ++ Dragon/src/MCTCCC.f | 125 ++ Dragon/src/MCTCTR.f | 233 +++ Dragon/src/MCTFLX.f | 437 ++++ Dragon/src/MCTGET.f | 234 +++ Dragon/src/MCTLDC.f | 126 ++ Dragon/src/MCTLDP.f | 86 + Dragon/src/MCTLIB.f | 204 ++ Dragon/src/MCTOUT.f | 244 +++ Dragon/src/MCTPIR.f | 148 ++ Dragon/src/MCTPSP.f | 64 + Dragon/src/MCTPTR.f | 178 ++ Dragon/src/MCTRK.f | 399 ++++ Dragon/src/MESHST.f | 1924 +++++++++++++++++ Dragon/src/MOCCAL.f | 71 + Dragon/src/MOCCHR.f | 158 ++ Dragon/src/MOCDDF.f | 84 + Dragon/src/MOCDDFL.f | 99 + Dragon/src/MOCDDFS.f | 85 + Dragon/src/MOCDDFT.f | 79 + Dragon/src/MOCDS2.f | 207 ++ Dragon/src/MOCDSP.f | 121 ++ Dragon/src/MOCFCF.f | 412 ++++ Dragon/src/MOCFFAL.f | 190 ++ Dragon/src/MOCFFAR.f | 158 ++ Dragon/src/MOCFFAS.f | 160 ++ Dragon/src/MOCFFAT.f | 140 ++ Dragon/src/MOCFFIR.f | 150 ++ Dragon/src/MOCFFIS.f | 149 ++ Dragon/src/MOCFFIT.f | 129 ++ Dragon/src/MOCIK3.f | 111 + Dragon/src/MOCSCA.f | 98 + Dragon/src/MOCSCAL.f | 133 ++ Dragon/src/MOCSCAS.f | 111 + Dragon/src/MOCSCAT.f | 85 + Dragon/src/MOCSCE.f | 98 + Dragon/src/MOCSCEL.f | 116 ++ Dragon/src/MOCSCES.f | 107 + Dragon/src/MOCSCET.f | 79 + Dragon/src/MPO.f | 700 +++++++ Dragon/src/MPOCA2.f | 1012 +++++++++ Dragon/src/MPOCAL.f | 180 ++ Dragon/src/MPOCAT.f | 218 ++ Dragon/src/MPOGEP.f | 256 +++ Dragon/src/MPOGEY.f | 216 ++ Dragon/src/MPOIDF.f | 179 ++ Dragon/src/MPOPAV.f | 192 ++ Dragon/src/MPOTOC.f | 215 ++ Dragon/src/MRG.f | 380 ++++ Dragon/src/MRGGET.f | 248 +++ Dragon/src/MRGLIN.f | 142 ++ Dragon/src/MRGVOL.f | 199 ++ Dragon/src/MRGVON.f | 208 ++ Dragon/src/MRGVST.f | 227 ++ Dragon/src/MRGXTC.f | 170 ++ Dragon/src/MUSA.f90 | 287 +++ Dragon/src/MUSACG.f90 | 723 +++++++ Dragon/src/MUSF.f90 | 155 ++ Dragon/src/MUSJJ2.f90 | 372 ++++ Dragon/src/MUSP.f90 | 457 +++++ Dragon/src/Makefile | 237 +++ Dragon/src/NUMER3.f | 745 +++++++ Dragon/src/NUMERH.f | 535 +++++ Dragon/src/NXT.f | 299 +++ Dragon/src/NXT3T2.f | 310 +++ Dragon/src/NXTACG.f | 409 ++++ Dragon/src/NXTAGM.f | 157 ++ Dragon/src/NXTAVS.f | 165 ++ Dragon/src/NXTBCG.f | 386 ++++ Dragon/src/NXTBRT.f | 369 ++++ Dragon/src/NXTCUA.f | 875 ++++++++ Dragon/src/NXTCVM.f | 154 ++ Dragon/src/NXTCVS.f | 255 +++ Dragon/src/NXTEGI.f | 600 ++++++ Dragon/src/NXTETH.f | 198 ++ Dragon/src/NXTETS.f | 209 ++ Dragon/src/NXTFID.f | 93 + Dragon/src/NXTGET.f | 422 ++++ Dragon/src/NXTGMD.f | 556 +++++ Dragon/src/NXTHCL.f | 136 ++ Dragon/src/NXTHRS.f | 81 + Dragon/src/NXTHUA.f | 443 ++++ Dragon/src/NXTIAA.f | 188 ++ Dragon/src/NXTIHA.f | 193 ++ Dragon/src/NXTIND.f | 161 ++ Dragon/src/NXTIRA.f | 213 ++ Dragon/src/NXTIRR.f | 132 ++ Dragon/src/NXTITA.f | 308 +++ Dragon/src/NXTLCA.f | 809 ++++++++ Dragon/src/NXTLCU.f | 619 ++++++ Dragon/src/NXTLCY.f | 784 +++++++ Dragon/src/NXTLDC.f | 104 + Dragon/src/NXTLDP.f | 80 + Dragon/src/NXTLHA.f | 691 +++++++ Dragon/src/NXTLHT.f | 415 ++++ Dragon/src/NXTLRH.f | 377 ++++ Dragon/src/NXTLRS.f | 692 +++++++ Dragon/src/NXTLSN.f | 200 ++ Dragon/src/NXTMCA.f | 90 + Dragon/src/NXTMCB.f | 112 + Dragon/src/NXTMCC.f | 123 ++ Dragon/src/NXTMCD.f | 667 ++++++ Dragon/src/NXTPCA.f | 399 ++++ Dragon/src/NXTPCC.f | 609 ++++++ Dragon/src/NXTPHC.f | 484 +++++ Dragon/src/NXTPHT.f | 326 +++ Dragon/src/NXTPR3.f | 292 +++ Dragon/src/NXTPRA.f | 789 +++++++ Dragon/src/NXTPRI.f | 294 +++ Dragon/src/NXTPRR.f | 81 + Dragon/src/NXTQAC.f | 249 +++ Dragon/src/NXTQAS.f | 150 ++ Dragon/src/NXTQEW.f | 168 ++ Dragon/src/NXTQLC.f | 388 ++++ Dragon/src/NXTQLT.f | 560 +++++ Dragon/src/NXTQPS.f | 108 + Dragon/src/NXTQRN.f | 976 +++++++++ Dragon/src/NXTQSC.f | 134 ++ Dragon/src/NXTQSS.f | 173 ++ Dragon/src/NXTRCS.f | 155 ++ Dragon/src/NXTRIS.f | 740 +++++++ Dragon/src/NXTRPS.f | 190 ++ Dragon/src/NXTRTL.f | 176 ++ Dragon/src/NXTRTS.f | 314 +++ Dragon/src/NXTSGI.f | 885 ++++++++ Dragon/src/NXTSGT.f | 636 ++++++ Dragon/src/NXTSQD.f | 109 + Dragon/src/NXTTCG.f | 614 ++++++ Dragon/src/NXTTCR.f | 513 +++++ Dragon/src/NXTTGC.f | 457 +++++ Dragon/src/NXTTGS.f | 510 +++++ Dragon/src/NXTTLC.f | 1046 ++++++++++ Dragon/src/NXTTLO.f | 147 ++ Dragon/src/NXTTLS.f | 901 ++++++++ Dragon/src/NXTTNS.f | 214 ++ Dragon/src/NXTTPO.f | 315 +++ Dragon/src/NXTTPS.f | 218 ++ Dragon/src/NXTTRM.f | 93 + Dragon/src/NXTTRS.f | 83 + Dragon/src/NXTVCA.f | 277 +++ Dragon/src/NXTVCC.f | 467 +++++ Dragon/src/NXTVHC.f | 310 +++ Dragon/src/NXTVHT.f | 449 ++++ Dragon/src/NXTVOL.f | 333 +++ Dragon/src/NXTXYZ.f | 169 ++ Dragon/src/PIJAAA.f | 74 + Dragon/src/PIJABC.f | 122 ++ Dragon/src/PIJCMP.f | 121 ++ Dragon/src/PIJD2R.f | 57 + Dragon/src/PIJD2S.f | 53 + Dragon/src/PIJI2D.f | 271 +++ Dragon/src/PIJI3D.f | 277 +++ Dragon/src/PIJKST.f | 90 + Dragon/src/PIJRDG.f | 91 + Dragon/src/PIJRGL.f | 151 ++ Dragon/src/PIJRHL.f | 194 ++ Dragon/src/PIJRNL.f | 285 +++ Dragon/src/PIJS2D.f | 222 ++ Dragon/src/PIJS3D.f | 188 ++ Dragon/src/PIJSMD.f | 152 ++ Dragon/src/PIJWIJ.f | 330 +++ Dragon/src/PIJWPR.f | 222 ++ Dragon/src/PIJXL3.f | 449 ++++ Dragon/src/PNFLV.f | 207 ++ Dragon/src/PNSH.f90 | 149 ++ Dragon/src/PRECISION_AND_KINDS.f90 | 20 + Dragon/src/PSOISO.f | 295 +++ Dragon/src/PSOMON.f | 523 +++++ Dragon/src/PSOUR.f | 706 +++++++ Dragon/src/PSOUSN.f | 241 +++ Dragon/src/PSP.f | 292 +++ Dragon/src/PSPCOL.f | 156 ++ Dragon/src/PSPFCD.f | 69 + Dragon/src/PSPFIL.f | 89 + Dragon/src/PSPGET.f | 237 +++ Dragon/src/PSPLEG.f | 311 +++ Dragon/src/PSPMCP.f | 139 ++ Dragon/src/PSPNXT.f | 276 +++ Dragon/src/PSPRAI.f | 185 ++ Dragon/src/PSPTCR.f | 331 +++ Dragon/src/PSPTHR.f | 503 +++++ Dragon/src/PSPTRK.f | 283 +++ Dragon/src/PSPXCG.f | 295 +++ Dragon/src/PSPXEL.f | 200 ++ Dragon/src/QIJCMP.f | 115 ++ Dragon/src/QIJI3D.f | 188 ++ Dragon/src/READBH.f | 220 ++ Dragon/src/READEU.f | 693 +++++++ Dragon/src/READMT.f | 220 ++ Dragon/src/RECT1.f | 195 ++ Dragon/src/RECT2.f | 371 ++++ Dragon/src/S2M.f | 191 ++ Dragon/src/S2MGET.f | 67 + Dragon/src/SALACG.f90 | 309 +++ Dragon/src/SALEND.f90 | 47 + Dragon/src/SALGET_FUNS_MOD.f90 | 373 ++++ Dragon/src/SALMUS.f90 | 282 +++ Dragon/src/SALT.f90 | 292 +++ Dragon/src/SALTCG.f | 606 ++++++ Dragon/src/SALTLC.f90 | 360 ++++ Dragon/src/SALTLS.f90 | 299 +++ Dragon/src/SAL_AUX_MOD.f90 | 496 +++++ Dragon/src/SAL_GEOMETRY_MOD.f90 | 3756 ++++++++++++++++++++++++++++++++++ Dragon/src/SAL_GEOMETRY_TYPES.f90 | 227 ++ Dragon/src/SAL_NUMERIC_MOD.f90 | 151 ++ Dragon/src/SAL_TRACKING_TYPES.f90 | 113 + Dragon/src/SAL_TRAJECTORY_MOD.f90 | 1141 +++++++++++ Dragon/src/SAP.f | 838 ++++++++ Dragon/src/SAPCA2.f | 956 +++++++++ Dragon/src/SAPCAL.f | 213 ++ Dragon/src/SAPCAT.f | 295 +++ Dragon/src/SAPFLU.f | 88 + Dragon/src/SAPFWC.f | 93 + Dragon/src/SAPGEP.f | 378 ++++ Dragon/src/SAPGEY.f | 219 ++ Dragon/src/SAPIDF.f | 104 + Dragon/src/SAPPAV.f | 152 ++ Dragon/src/SAPSPH.f | 82 + Dragon/src/SEN.f | 206 ++ Dragon/src/SENCAL.f | 620 ++++++ Dragon/src/SENCNT.f | 148 ++ Dragon/src/SENDRV.f | 302 +++ Dragon/src/SENGET.f | 89 + Dragon/src/SHI.f | 285 +++ Dragon/src/SHIDIL.f | 235 +++ Dragon/src/SHIDRV.f | 443 ++++ Dragon/src/SHIDST.f | 199 ++ Dragon/src/SHIEQU.f | 244 +++ Dragon/src/SHIRAT.f | 222 ++ Dragon/src/SHISN2.f | 435 ++++ Dragon/src/SHISN3.f | 464 +++++ Dragon/src/SNADPT.f | 90 + Dragon/src/SNDSA.f | 936 +++++++++ Dragon/src/SNEST.f | 169 ++ Dragon/src/SNF.f | 257 +++ Dragon/src/SNFBC1.f | 304 +++ Dragon/src/SNFBC2.F | 512 +++++ Dragon/src/SNFBC3.F | 679 ++++++ Dragon/src/SNFBH2.F | 598 ++++++ Dragon/src/SNFBH3.F | 793 +++++++ Dragon/src/SNFC12.f | 178 ++ Dragon/src/SNFE1D.f | 431 ++++ Dragon/src/SNFE2D.F | 610 ++++++ Dragon/src/SNFE3D.F | 778 +++++++ Dragon/src/SNFG2D.F | 512 +++++ Dragon/src/SNFG3D.F | 682 ++++++ Dragon/src/SNFKC2.F | 562 +++++ Dragon/src/SNFKC3.F | 755 +++++++ Dragon/src/SNFKH2.F | 614 ++++++ Dragon/src/SNFKH3.F | 857 ++++++++ Dragon/src/SNFLUX.f | 1129 ++++++++++ Dragon/src/SNFT12.F | 506 +++++ Dragon/src/SNFT1C.f | 211 ++ Dragon/src/SNFT1S.f | 185 ++ Dragon/src/SNGMRE.f | 229 +++ Dragon/src/SNQU01.f | 143 ++ Dragon/src/SNQU02.f | 158 ++ Dragon/src/SNQU03.f | 121 ++ Dragon/src/SNQU04.f | 76 + Dragon/src/SNQU05.f | 367 ++++ Dragon/src/SNQU06.f | 949 +++++++++ Dragon/src/SNQU07.f | 73 + Dragon/src/SNQU10.f | 74 + Dragon/src/SNSBFP.f | 190 ++ Dragon/src/SNSOUR.f | 188 ++ Dragon/src/SNT.f | 395 ++++ Dragon/src/SNT1DC.f | 184 ++ Dragon/src/SNT1DP.f | 241 +++ Dragon/src/SNT1DS.f | 135 ++ Dragon/src/SNTRK.f | 686 +++++++ Dragon/src/SNTSFH.f | 253 +++ Dragon/src/SNTT2D.f | 572 ++++++ Dragon/src/SNTT3D.f | 609 ++++++ Dragon/src/SPH.F | 900 ++++++++ Dragon/src/SPHAPX.f | 621 ++++++ Dragon/src/SPHCMA.f | 385 ++++ Dragon/src/SPHCMI.f | 276 +++ Dragon/src/SPHCPO.f | 431 ++++ Dragon/src/SPHDRV.f | 215 ++ Dragon/src/SPHEMB.f | 137 ++ Dragon/src/SPHEQU.f | 757 +++++++ Dragon/src/SPHGAP.f | 297 +++ Dragon/src/SPHMAC.f | 336 +++ Dragon/src/SPHMOL.f | 101 + Dragon/src/SPHMPO.f | 716 +++++++ Dragon/src/SPHSAP.f | 732 +++++++ Dragon/src/SPHSCO.f | 83 + Dragon/src/SPHSTM.f | 119 ++ Dragon/src/SPHSTO.f | 141 ++ Dragon/src/SPHSX5.f | 132 ++ Dragon/src/SPHSXS.f | 145 ++ Dragon/src/SPHTRA.f | 181 ++ Dragon/src/SYB001.f | 171 ++ Dragon/src/SYB002.f | 243 +++ Dragon/src/SYB003.f | 304 +++ Dragon/src/SYB004.f | 241 +++ Dragon/src/SYB005.f | 243 +++ Dragon/src/SYB31C.f | 141 ++ Dragon/src/SYB32C.f | 55 + Dragon/src/SYB33C.f | 44 + Dragon/src/SYB41C.f | 72 + Dragon/src/SYB43C.f | 42 + Dragon/src/SYB4QG.f | 277 +++ Dragon/src/SYB4T1.f | 65 + Dragon/src/SYB4T2.f | 72 + Dragon/src/SYB4T3.f | 71 + Dragon/src/SYB4T4.f | 66 + Dragon/src/SYB4TC.f | 235 +++ Dragon/src/SYB4TH.f | 375 ++++ Dragon/src/SYB4TI.f | 123 ++ Dragon/src/SYB4TN.f | 99 + Dragon/src/SYB4TR.f | 333 +++ Dragon/src/SYB4TS.f | 242 +++ Dragon/src/SYB4VO.f | 142 ++ Dragon/src/SYB7QG.f | 302 +++ Dragon/src/SYB7T0.f | 387 ++++ Dragon/src/SYB7TC.f | 132 ++ Dragon/src/SYB7TE.f | 78 + Dragon/src/SYB7TN.f | 108 + Dragon/src/SYB7TR.f | 150 ++ Dragon/src/SYB7TS.f | 222 ++ Dragon/src/SYB7TW.f | 111 + Dragon/src/SYB7VO.f | 119 ++ Dragon/src/SYBALC.f | 212 ++ Dragon/src/SYBALP.f | 217 ++ Dragon/src/SYBALS.f | 171 ++ Dragon/src/SYBCP1.f | 192 ++ Dragon/src/SYBEUR.f | 506 +++++ Dragon/src/SYBHN2.f | 398 ++++ Dragon/src/SYBHTK.f | 512 +++++ Dragon/src/SYBILA.f | 234 +++ Dragon/src/SYBILF.f | 227 ++ Dragon/src/SYBILP.f | 128 ++ Dragon/src/SYBILT.f | 286 +++ Dragon/src/SYBJJ0.f | 275 +++ Dragon/src/SYBJJ1.f | 370 ++++ Dragon/src/SYBJJ2.f | 343 ++++ Dragon/src/SYBPRX.f | 72 + Dragon/src/SYBRHL.f | 181 ++ Dragon/src/SYBRII.f | 39 + Dragon/src/SYBRIJ.f | 54 + Dragon/src/SYBRN2.f | 429 ++++ Dragon/src/SYBRTK.f | 517 +++++ Dragon/src/SYBRX2.f | 191 ++ Dragon/src/SYBRX3.f | 216 ++ Dragon/src/SYBRXE.f | 126 ++ Dragon/src/SYBT1D.f | 93 + Dragon/src/SYBTRK.f | 290 +++ Dragon/src/SYBUP0.f | 206 ++ Dragon/src/SYBUP1.f | 227 ++ Dragon/src/SYBUQ0.f | 409 ++++ Dragon/src/SYBUQV.f | 243 +++ Dragon/src/SYBWIJ.f | 57 + Dragon/src/TLM.f | 425 ++++ Dragon/src/TLMDIR.f | 407 ++++ Dragon/src/TLMGEO.f | 206 ++ Dragon/src/TLMGET.f | 283 +++ Dragon/src/TLMPLA.f | 254 +++ Dragon/src/TLMPLP.f | 271 +++ Dragon/src/TLMPNT.f | 222 ++ Dragon/src/TLMREG.f | 246 +++ Dragon/src/TLMVPL.f | 359 ++++ Dragon/src/TONCMI.f | 239 +++ Dragon/src/TONDRV.f | 471 +++++ Dragon/src/TONDST.f | 205 ++ Dragon/src/TONE.f | 276 +++ Dragon/src/TONSN3.f | 267 +++ Dragon/src/TONSPH.f | 351 ++++ Dragon/src/TRA.f | 94 + Dragon/src/TRAGRO.f | 209 ++ Dragon/src/TRAXS.f | 96 + Dragon/src/TRFICF.f | 123 ++ Dragon/src/TRIFIS.f | 178 ++ Dragon/src/TRIFLV.f | 158 ++ Dragon/src/TRIVA.f | 156 ++ Dragon/src/TRIVSO.f | 248 +++ Dragon/src/TRKHEX.f | 2954 ++++++++++++++++++++++++++ Dragon/src/USS.f | 346 ++++ Dragon/src/USSCOR.f | 232 +++ Dragon/src/USSDRV.f | 492 +++++ Dragon/src/USSEXC.f | 383 ++++ Dragon/src/USSEXD.f | 377 ++++ Dragon/src/USSFLU.f | 499 +++++ Dragon/src/USSIN1.f | 296 +++ Dragon/src/USSIST.f | 509 +++++ Dragon/src/USSIT0.f | 670 ++++++ Dragon/src/USSIT1.f | 441 ++++ Dragon/src/USSIT2.f | 277 +++ Dragon/src/USSIT3.f | 466 +++++ Dragon/src/USSIT4.f | 187 ++ Dragon/src/USSONE.f | 190 ++ Dragon/src/USSRSE.f | 458 +++++ Dragon/src/USSSEK.f | 117 ++ Dragon/src/USSSPH.f | 386 ++++ Dragon/src/VDG.f | 420 ++++ Dragon/src/XCGBCM.f | 54 + Dragon/src/XCGDIM.f | 210 ++ Dragon/src/XCGGEO.f | 801 ++++++++ Dragon/src/XCGROD.f | 234 +++ Dragon/src/XCWHEX.f | 229 +++ Dragon/src/XCWICL.f | 347 ++++ Dragon/src/XCWREC.f | 229 +++ Dragon/src/XCWROD.f | 195 ++ Dragon/src/XCWSCL.f | 580 ++++++ Dragon/src/XCWSRT.f | 154 ++ Dragon/src/XCWTRK.f | 318 +++ Dragon/src/XDDCOM.f | 46 + Dragon/src/XDRCRE.f | 222 ++ Dragon/src/XDREXP.f | 106 + Dragon/src/XDRH11.f | 228 +++ Dragon/src/XDRH12.f | 211 ++ Dragon/src/XDRH13.f | 205 ++ Dragon/src/XDRH20.f | 182 ++ Dragon/src/XDRH23.f | 116 ++ Dragon/src/XDRH30.f | 212 ++ Dragon/src/XDRH33.f | 117 ++ Dragon/src/XDRKIN.f | 135 ++ Dragon/src/XDRLGS.f | 300 +++ Dragon/src/XDRLXS.f | 119 ++ Dragon/src/XDRNRM.f | 75 + Dragon/src/XDRTA2.f | 98 + Dragon/src/XDRTBH.f | 165 ++ Dragon/src/XEL3T2.f | 372 ++++ Dragon/src/XELBIN.f | 457 +++++ Dragon/src/XELCMP.f | 131 ++ Dragon/src/XELCOP.f | 118 ++ Dragon/src/XELCOR.f | 183 ++ Dragon/src/XELCRN.f | 251 +++ Dragon/src/XELCTR.f | 154 ++ Dragon/src/XELDCL.f | 603 ++++++ Dragon/src/XELDRV.f | 620 ++++++ Dragon/src/XELEDC.f | 172 ++ Dragon/src/XELEQN.f | 262 +++ Dragon/src/XELETR.f | 458 +++++ Dragon/src/XELGPR.f | 303 +++ Dragon/src/XELGRD.f | 288 +++ Dragon/src/XELLIN.f | 211 ++ Dragon/src/XELLSR.f | 187 ++ Dragon/src/XELMRG.f | 502 +++++ Dragon/src/XELNTR.f | 609 ++++++ Dragon/src/XELPR3.f | 164 ++ Dragon/src/XELPRC.f | 233 +++ Dragon/src/XELPRP.f | 364 ++++ Dragon/src/XELPSC.f | 49 + Dragon/src/XELPSI.f | 93 + Dragon/src/XELTCW.f | 63 + Dragon/src/XELTI2.f | 350 ++++ Dragon/src/XELTI3.f | 433 ++++ Dragon/src/XELTRK.f | 541 +++++ Dragon/src/XELTRP.f | 171 ++ Dragon/src/XELTS2.f | 575 ++++++ Dragon/src/XELTSA.f | 89 + Dragon/src/XELTSW.f | 130 ++ Dragon/src/XELVOL.f | 228 +++ Dragon/src/XHX2D0.f | 207 ++ Dragon/src/XHX2D1.f | 322 +++ Dragon/src/XHXTRK.f | 646 ++++++ Dragon/src/XL3NTR.f | 216 ++ Dragon/src/XL3SIG.f | 82 + Dragon/src/XL3TI3.f | 464 +++++ Dragon/src/dramod.f90 | 90 + Dragon/src/g2s_boundCond.f90 | 1738 ++++++++++++++++ Dragon/src/g2s_cast.f90 | 63 + Dragon/src/g2s_celluleBase.f90 | 679 ++++++ Dragon/src/g2s_cellulePlaced.f90 | 300 +++ Dragon/src/g2s_constType.f90 | 91 + Dragon/src/g2s_constUtil.f90 | 292 +++ Dragon/src/g2s_construire.f90 | 1144 +++++++++++ Dragon/src/g2s_convert.f90 | 530 +++++ Dragon/src/g2s_g2mc.f90 | 225 ++ Dragon/src/g2s_g2s.f90 | 299 +++ Dragon/src/g2s_generateTabSegArc.f90 | 145 ++ Dragon/src/g2s_generatingMC.f90 | 825 ++++++++ Dragon/src/g2s_generatingPS.f90 | 920 +++++++++ Dragon/src/g2s_generatingSAL.f90 | 317 +++ Dragon/src/g2s_generatingTrack.f90 | 150 ++ Dragon/src/g2s_nodes.f90 | 1204 +++++++++++ Dragon/src/g2s_pretraitement.f90 | 2243 ++++++++++++++++++++ Dragon/src/g2s_segArc.f90 | 2310 +++++++++++++++++++++ Dragon/src/g2s_unfold.f90 | 65 + Dragon/src/sdbm.c | 482 +++++ Dragon/src/sdbm.h | 80 + Dragon/src/xsdb-defs.h | 46 + Dragon/src/xsdbops-sdbm.c | 184 ++ Dragon/src/xsdbops.h | 84 + Dragon/src/xsdf.c | 1026 ++++++++++ 918 files changed, 271869 insertions(+) create mode 100644 Dragon/src/AEXCPC.f create mode 100644 Dragon/src/AEXDIR.f create mode 100644 Dragon/src/AEXGNV.f create mode 100644 Dragon/src/AEXTPA.f create mode 100644 Dragon/src/AEXTRT.f create mode 100644 Dragon/src/APX.f create mode 100644 Dragon/src/APXCA2.f create mode 100644 Dragon/src/APXCAL.f create mode 100644 Dragon/src/APXCAT.f create mode 100644 Dragon/src/APXGEM.f create mode 100644 Dragon/src/APXGEP.f create mode 100644 Dragon/src/APXGEY.f create mode 100644 Dragon/src/APXIDF.f create mode 100644 Dragon/src/APXPAV.f create mode 100644 Dragon/src/APXSX2.f create mode 100644 Dragon/src/APXTOC.f create mode 100644 Dragon/src/ASM.f create mode 100644 Dragon/src/ASMDRV.f create mode 100644 Dragon/src/AUTDRV.f create mode 100644 Dragon/src/AUTFLU.f create mode 100644 Dragon/src/AUTIT1.f create mode 100644 Dragon/src/AUTIT2.f create mode 100644 Dragon/src/AUTO.f create mode 100644 Dragon/src/AUTONE.f create mode 100644 Dragon/src/AUTPRD.f create mode 100644 Dragon/src/AUTSPH.f create mode 100644 Dragon/src/AUTTAB.f create mode 100644 Dragon/src/AXGDIA.f create mode 100644 Dragon/src/AXGGEO.f create mode 100644 Dragon/src/AXGSYM.f create mode 100644 Dragon/src/AXGTRN.f create mode 100644 Dragon/src/AXGTRS.f create mode 100644 Dragon/src/AXGXCW.f create mode 100644 Dragon/src/AXGXEL.f create mode 100644 Dragon/src/B1BETA.f create mode 100644 Dragon/src/B1DIF.f create mode 100644 Dragon/src/B1GAMA.f create mode 100644 Dragon/src/B1HOM.f create mode 100644 Dragon/src/B1HXS1.f create mode 100644 Dragon/src/B1SOL.f create mode 100644 Dragon/src/BIVAA.f create mode 100644 Dragon/src/BIVAF.f create mode 100644 Dragon/src/BIVFIS.f create mode 100644 Dragon/src/BIVS01.f create mode 100644 Dragon/src/BIVS02.f create mode 100644 Dragon/src/BIVS03.f create mode 100644 Dragon/src/BIVS04.f create mode 100644 Dragon/src/BIVS05.f create mode 100644 Dragon/src/BIVSOU.f create mode 100644 Dragon/src/BREANM.f create mode 100644 Dragon/src/BREDRV.f create mode 100644 Dragon/src/BREERA.f create mode 100644 Dragon/src/BREERM.f create mode 100644 Dragon/src/BREF.f create mode 100644 Dragon/src/BREKOE.f create mode 100644 Dragon/src/BRELLB.f create mode 100644 Dragon/src/BREMAC.f create mode 100644 Dragon/src/BRENEM.f create mode 100644 Dragon/src/BRERT.f create mode 100644 Dragon/src/BRERTD.f90 create mode 100644 Dragon/src/BRERTS.f90 create mode 100644 Dragon/src/BRESS1.f create mode 100644 Dragon/src/BRESS2.f create mode 100644 Dragon/src/BRESS3.f create mode 100644 Dragon/src/BRESS4.f create mode 100644 Dragon/src/CFC.f create mode 100644 Dragon/src/CFCDRV.f create mode 100644 Dragon/src/CFCFBM.f create mode 100644 Dragon/src/CFCGET.f create mode 100644 Dragon/src/CHAB.f create mode 100644 Dragon/src/CHAB01.f create mode 100644 Dragon/src/CHAB02.f create mode 100644 Dragon/src/CHAB03.f create mode 100644 Dragon/src/CHAB04.f create mode 100644 Dragon/src/CLM.f create mode 100644 Dragon/src/CLMGET.f create mode 100644 Dragon/src/COMACR.f create mode 100644 Dragon/src/COMARB.f create mode 100644 Dragon/src/COMBIB.f create mode 100644 Dragon/src/COMCAL.f create mode 100644 Dragon/src/COMCAT.f create mode 100644 Dragon/src/COMDEP.f create mode 100644 Dragon/src/COMGEM.f create mode 100644 Dragon/src/COMGEN.f create mode 100644 Dragon/src/COMGEP.f create mode 100644 Dragon/src/COMGFF.f create mode 100644 Dragon/src/COMISO.f create mode 100644 Dragon/src/COMMIC.f create mode 100644 Dragon/src/COMPAV.f create mode 100644 Dragon/src/COMPO.f create mode 100644 Dragon/src/COMRES.f create mode 100644 Dragon/src/COMSDB.f create mode 100644 Dragon/src/COMTRE.f create mode 100644 Dragon/src/CPO.f create mode 100644 Dragon/src/CPODRV.f create mode 100644 Dragon/src/CPOISO.f create mode 100644 Dragon/src/CPOLGX.f create mode 100644 Dragon/src/CPOMAR.f create mode 100644 Dragon/src/CPOMAW.f create mode 100644 Dragon/src/CPOMIC.f create mode 100644 Dragon/src/CPONED.f create mode 100644 Dragon/src/CPOREM.f create mode 100644 Dragon/src/DEPLIT.f create mode 100644 Dragon/src/DMA.f create mode 100644 Dragon/src/DMAGET.f create mode 100644 Dragon/src/DMASOU.f create mode 100644 Dragon/src/DOORAB.f create mode 100644 Dragon/src/DOORAV.f create mode 100644 Dragon/src/DOORFB2.f create mode 100644 Dragon/src/DOORFB3.f create mode 100644 Dragon/src/DOORFV.f create mode 100644 Dragon/src/DOORPV.f create mode 100644 Dragon/src/DOORS_BIV.f90 create mode 100644 Dragon/src/DOORS_MOD.f90 create mode 100644 Dragon/src/DOORS_SN.f90 create mode 100644 Dragon/src/DOORS_TRI.f90 create mode 100644 Dragon/src/DRAGON.f90 create mode 100644 Dragon/src/DUO.f create mode 100644 Dragon/src/DUO001.f create mode 100644 Dragon/src/DUO002.f create mode 100644 Dragon/src/DUO003.f create mode 100644 Dragon/src/DUO004.f create mode 100644 Dragon/src/DUO005.f create mode 100644 Dragon/src/DUO006.f create mode 100644 Dragon/src/DUO007.f create mode 100644 Dragon/src/DUODRV.f create mode 100644 Dragon/src/DUTURN.f create mode 100644 Dragon/src/EDI.f create mode 100644 Dragon/src/EDIACT.f create mode 100644 Dragon/src/EDIALB.f create mode 100644 Dragon/src/EDIBAL.f create mode 100644 Dragon/src/EDIBHX.f create mode 100644 Dragon/src/EDIDEL.f create mode 100644 Dragon/src/EDIDEP.f create mode 100644 Dragon/src/EDIDRV.f create mode 100644 Dragon/src/EDIDST.f create mode 100644 Dragon/src/EDIDTX.f create mode 100644 Dragon/src/EDIENE.f create mode 100644 Dragon/src/EDIG2S.f90 create mode 100644 Dragon/src/EDIGAP.f create mode 100644 Dragon/src/EDIGEO.f create mode 100644 Dragon/src/EDIGET.f create mode 100644 Dragon/src/EDIHFC.f create mode 100644 Dragon/src/EDIHFD.f create mode 100644 Dragon/src/EDIHMX.f create mode 100644 Dragon/src/EDIJO1.f create mode 100644 Dragon/src/EDIJO2.f create mode 100644 Dragon/src/EDIJO3.f create mode 100644 Dragon/src/EDILUM.f create mode 100644 Dragon/src/EDIMAX.f create mode 100644 Dragon/src/EDIMCN.f create mode 100644 Dragon/src/EDIMIC.f create mode 100644 Dragon/src/EDIMRC.f create mode 100644 Dragon/src/EDIMRG.f create mode 100644 Dragon/src/EDIPRR.f create mode 100644 Dragon/src/EDIPXS.f create mode 100644 Dragon/src/EDIRAT.f create mode 100644 Dragon/src/EDIRES.f create mode 100644 Dragon/src/EDISTA.f create mode 100644 Dragon/src/EDITXS.f create mode 100644 Dragon/src/EDIUNF.f create mode 100644 Dragon/src/EDIWCU.f create mode 100644 Dragon/src/EDIWP1.f create mode 100644 Dragon/src/EPC.f create mode 100644 Dragon/src/EPCRMA.f create mode 100644 Dragon/src/EPCRMD.f create mode 100644 Dragon/src/EPCRMI.f create mode 100644 Dragon/src/EPCRMS.f create mode 100644 Dragon/src/EPCRMU.f create mode 100644 Dragon/src/EPCRMV.f create mode 100644 Dragon/src/EPCRPD.f create mode 100644 Dragon/src/EVO.f create mode 100644 Dragon/src/EVOBLD.f create mode 100644 Dragon/src/EVODPL.f create mode 100644 Dragon/src/EVODRV.f create mode 100644 Dragon/src/EVOGET.f create mode 100644 Dragon/src/EVOKAP.f create mode 100644 Dragon/src/EVOMU1.f create mode 100644 Dragon/src/EVOODE.f create mode 100644 Dragon/src/EVORK.f create mode 100644 Dragon/src/EVOSAT.f create mode 100644 Dragon/src/EVOSIG.f create mode 100644 Dragon/src/EVOSOL.f create mode 100644 Dragon/src/EXCELP.f create mode 100644 Dragon/src/EXCELT.f create mode 100644 Dragon/src/FLU.f create mode 100644 Dragon/src/FLU2AC.f create mode 100644 Dragon/src/FLU2DR.f create mode 100644 Dragon/src/FLUALB.f create mode 100644 Dragon/src/FLUBAL.f create mode 100644 Dragon/src/FLUBLN.f create mode 100644 Dragon/src/FLUDBV.f create mode 100644 Dragon/src/FLUDRV.f create mode 100644 Dragon/src/FLUGPI.f create mode 100644 Dragon/src/FLUGPT.f create mode 100644 Dragon/src/FLUKEF.f create mode 100644 Dragon/src/FLULPN.f create mode 100644 Dragon/src/FLUSOU.f90 create mode 100644 Dragon/src/FMAC.f create mode 100644 Dragon/src/FMAC01.f create mode 100644 Dragon/src/FMAC02.f create mode 100644 Dragon/src/FMAC03.f create mode 100644 Dragon/src/FMAC04.f create mode 100644 Dragon/src/FMT.f create mode 100644 Dragon/src/FMTBRN.f create mode 100644 Dragon/src/FMTDFD.f create mode 100644 Dragon/src/FMTDFL.f create mode 100644 Dragon/src/FMTGET.f create mode 100644 Dragon/src/FMTGIS.f create mode 100644 Dragon/src/FMTSUD.f create mode 100644 Dragon/src/FMTSUS.f create mode 100644 Dragon/src/FSDF.f90 create mode 100644 Dragon/src/GEO.f create mode 100644 Dragon/src/GEOIN1.f create mode 100644 Dragon/src/GEOMIX.f create mode 100644 Dragon/src/HEADRV.f create mode 100644 Dragon/src/HEAT.f create mode 100644 Dragon/src/INF.f create mode 100644 Dragon/src/INFAPL.f create mode 100644 Dragon/src/INFDRA.f create mode 100644 Dragon/src/INFNDA.f create mode 100644 Dragon/src/INFPSA.f create mode 100644 Dragon/src/INFTR1.f create mode 100644 Dragon/src/INFTR2.f create mode 100644 Dragon/src/INFWAN.f create mode 100644 Dragon/src/INFWAT.f create mode 100644 Dragon/src/INFWD4.f create mode 100644 Dragon/src/INFWIM.f create mode 100644 Dragon/src/KDRDRV.F create mode 100644 Dragon/src/KELMRG.f create mode 100644 Dragon/src/KELRNG.f create mode 100644 Dragon/src/KELSYM.f create mode 100644 Dragon/src/LDRASS.f create mode 100644 Dragon/src/LDRCEL.f create mode 100644 Dragon/src/LDRGEO.f create mode 100644 Dragon/src/LELCHK.f create mode 100644 Dragon/src/LELCRN.f create mode 100644 Dragon/src/LELCSY.f create mode 100644 Dragon/src/LHXUNH.f create mode 100644 Dragon/src/LIB.f create mode 100644 Dragon/src/LIBA20.f create mode 100644 Dragon/src/LIBA21.f create mode 100644 Dragon/src/LIBA22.f create mode 100644 Dragon/src/LIBA23.f create mode 100644 Dragon/src/LIBA24.f create mode 100644 Dragon/src/LIBA25.f create mode 100644 Dragon/src/LIBA26.f create mode 100644 Dragon/src/LIBA27.f create mode 100644 Dragon/src/LIBA28.f create mode 100644 Dragon/src/LIBA2G.f create mode 100644 Dragon/src/LIBA30.f create mode 100644 Dragon/src/LIBA33.f create mode 100644 Dragon/src/LIBA34.f create mode 100644 Dragon/src/LIBADD.f create mode 100644 Dragon/src/LIBADJ.f create mode 100644 Dragon/src/LIBAPL.f create mode 100644 Dragon/src/LIBBAS.f create mode 100644 Dragon/src/LIBCAT.f create mode 100644 Dragon/src/LIBCMB.f create mode 100644 Dragon/src/LIBCOM.f create mode 100644 Dragon/src/LIBCON.f create mode 100644 Dragon/src/LIBCOR.f create mode 100644 Dragon/src/LIBCOV.f create mode 100644 Dragon/src/LIBCTL.f create mode 100644 Dragon/src/LIBD10.F create mode 100644 Dragon/src/LIBDEN.f create mode 100644 Dragon/src/LIBDEP.F create mode 100644 Dragon/src/LIBDI1.f create mode 100644 Dragon/src/LIBDI2.f create mode 100644 Dragon/src/LIBDI3.f create mode 100644 Dragon/src/LIBDI4.f create mode 100644 Dragon/src/LIBDI5.f create mode 100644 Dragon/src/LIBDI6.f create mode 100644 Dragon/src/LIBDI8.f create mode 100644 Dragon/src/LIBDI9.f create mode 100644 Dragon/src/LIBDRA.f create mode 100644 Dragon/src/LIBDRB.f create mode 100644 Dragon/src/LIBE3R.f create mode 100644 Dragon/src/LIBEAD.f create mode 100644 Dragon/src/LIBEAI.f create mode 100644 Dragon/src/LIBEAR.f create mode 100644 Dragon/src/LIBECT.f create mode 100644 Dragon/src/LIBEED.f90 create mode 100644 Dragon/src/LIBEIR.f create mode 100644 Dragon/src/LIBENI.f create mode 100644 Dragon/src/LIBENR.f create mode 100644 Dragon/src/LIBEPR.f create mode 100644 Dragon/src/LIBEST.f create mode 100644 Dragon/src/LIBEWI.f create mode 100644 Dragon/src/LIBEWR.f create mode 100644 Dragon/src/LIBEXT.f create mode 100644 Dragon/src/LIBFQD.f create mode 100644 Dragon/src/LIBINF.f create mode 100644 Dragon/src/LIBINP.f create mode 100644 Dragon/src/LIBIPS.f create mode 100644 Dragon/src/LIBLAG.f create mode 100644 Dragon/src/LIBLEX.f create mode 100644 Dragon/src/LIBLIB.f create mode 100644 Dragon/src/LIBLIC.F create mode 100644 Dragon/src/LIBMAC.f create mode 100644 Dragon/src/LIBMIC.f create mode 100644 Dragon/src/LIBMIX.f create mode 100644 Dragon/src/LIBMOM.f create mode 100644 Dragon/src/LIBMPA.f create mode 100644 Dragon/src/LIBND0.f create mode 100644 Dragon/src/LIBND1.f create mode 100644 Dragon/src/LIBND3.f create mode 100644 Dragon/src/LIBND5.f create mode 100644 Dragon/src/LIBND6.f create mode 100644 Dragon/src/LIBND7.f create mode 100644 Dragon/src/LIBNFI.f create mode 100644 Dragon/src/LIBNOT.f create mode 100644 Dragon/src/LIBNRG.F create mode 100644 Dragon/src/LIBOMG.f create mode 100644 Dragon/src/LIBPRI.f create mode 100644 Dragon/src/LIBPTT.f create mode 100644 Dragon/src/LIBPTW.f create mode 100644 Dragon/src/LIBRSC.f create mode 100644 Dragon/src/LIBRSE.f create mode 100644 Dragon/src/LIBSDC.f create mode 100644 Dragon/src/LIBSEC.f create mode 100644 Dragon/src/LIBSUB.f create mode 100644 Dragon/src/LIBTAB.f create mode 100644 Dragon/src/LIBTE2.f create mode 100644 Dragon/src/LIBTER.f create mode 100644 Dragon/src/LIBTR1.f create mode 100644 Dragon/src/LIBTR2.f create mode 100644 Dragon/src/LIBWD4.f create mode 100644 Dragon/src/LIBWE.f create mode 100644 Dragon/src/LIBWED.f create mode 100644 Dragon/src/LIBWET.f create mode 100644 Dragon/src/LIBWID.f create mode 100644 Dragon/src/LIBWIM.f create mode 100644 Dragon/src/LIBWRE.f create mode 100644 Dragon/src/LIBWRG.f create mode 100644 Dragon/src/LIBWRI.f create mode 100644 Dragon/src/LIBWRP.f create mode 100644 Dragon/src/LIBWSC.f create mode 100644 Dragon/src/LIBWTE.f create mode 100644 Dragon/src/LIBWTF.f create mode 100644 Dragon/src/LIBXS1.f create mode 100644 Dragon/src/LIBXS2.f create mode 100644 Dragon/src/LIBXS3.f create mode 100644 Dragon/src/LIBXS4.f create mode 100644 Dragon/src/LIBXS5.f create mode 100644 Dragon/src/LIBXS6.f create mode 100644 Dragon/src/M2T.f create mode 100644 Dragon/src/M2TDRV.f create mode 100644 Dragon/src/MAC.f create mode 100644 Dragon/src/MACDRV.f create mode 100644 Dragon/src/MACIXS.f create mode 100644 Dragon/src/MACNFI.f create mode 100644 Dragon/src/MACNXS.f create mode 100644 Dragon/src/MACOPT.f create mode 100644 Dragon/src/MACPRM.f create mode 100644 Dragon/src/MACPXS.f create mode 100644 Dragon/src/MACRDM.f create mode 100644 Dragon/src/MACUPD.f create mode 100644 Dragon/src/MACUPG.f create mode 100644 Dragon/src/MACWXS.f create mode 100644 Dragon/src/MACXSR.f create mode 100644 Dragon/src/MCCGA.f create mode 100644 Dragon/src/MCCGF.f create mode 100644 Dragon/src/MCCGT.f create mode 100644 Dragon/src/MCGABG.f create mode 100644 Dragon/src/MCGABGR.f create mode 100644 Dragon/src/MCGACA.f create mode 100644 Dragon/src/MCGASM.f create mode 100644 Dragon/src/MCGBIC.f create mode 100644 Dragon/src/MCGCAL.f create mode 100644 Dragon/src/MCGCDD.f create mode 100644 Dragon/src/MCGCOEF.f create mode 100644 Dragon/src/MCGDDDF.f create mode 100644 Dragon/src/MCGDDF.f create mode 100644 Dragon/src/MCGDDFL.f create mode 100644 Dragon/src/MCGDDFS.f create mode 100644 Dragon/src/MCGDDFT.f create mode 100644 Dragon/src/MCGDS1.f create mode 100644 Dragon/src/MCGDS2.f create mode 100644 Dragon/src/MCGDS2A.f create mode 100644 Dragon/src/MCGDS2E.f create mode 100644 Dragon/src/MCGDS3.f create mode 100644 Dragon/src/MCGDS4.f create mode 100644 Dragon/src/MCGDS6.f create mode 100644 Dragon/src/MCGDSCA.f create mode 100644 Dragon/src/MCGDSCB.f create mode 100644 Dragon/src/MCGDSCE.f create mode 100644 Dragon/src/MCGDSD.f create mode 100644 Dragon/src/MCGDSP.f create mode 100644 Dragon/src/MCGDTV.f create mode 100644 Dragon/src/MCGDYA.f create mode 100644 Dragon/src/MCGFCA.f create mode 100644 Dragon/src/MCGFCF.f create mode 100644 Dragon/src/MCGFCR.f create mode 100644 Dragon/src/MCGFCS.f create mode 100644 Dragon/src/MCGFFAL.f create mode 100644 Dragon/src/MCGFFAR.f create mode 100644 Dragon/src/MCGFFAS.f create mode 100644 Dragon/src/MCGFFAT.f create mode 100644 Dragon/src/MCGFFIR.f create mode 100644 Dragon/src/MCGFFIS.f create mode 100644 Dragon/src/MCGFFIT.f create mode 100644 Dragon/src/MCGFL1.f create mode 100644 Dragon/src/MCGFLS.f create mode 100644 Dragon/src/MCGFLX.f create mode 100644 Dragon/src/MCGFMC.f create mode 100644 Dragon/src/MCGFST.f create mode 100644 Dragon/src/MCGMRE.f create mode 100644 Dragon/src/MCGPJJ.f create mode 100644 Dragon/src/MCGPRA.f create mode 100644 Dragon/src/MCGPT1.f create mode 100644 Dragon/src/MCGPT2.f create mode 100644 Dragon/src/MCGPTA.f create mode 100644 Dragon/src/MCGPTF.f create mode 100644 Dragon/src/MCGPTN.f create mode 100644 Dragon/src/MCGPTS.f create mode 100644 Dragon/src/MCGPTV.f create mode 100644 Dragon/src/MCGREC.f create mode 100644 Dragon/src/MCGSCA.f create mode 100644 Dragon/src/MCGSCAL.f create mode 100644 Dragon/src/MCGSCAS.f create mode 100644 Dragon/src/MCGSCAT.f create mode 100644 Dragon/src/MCGSCE.f create mode 100644 Dragon/src/MCGSCEL.f create mode 100644 Dragon/src/MCGSCES.f create mode 100644 Dragon/src/MCGSCET.f create mode 100644 Dragon/src/MCGSCR.f create mode 100644 Dragon/src/MCGSCS.f create mode 100644 Dragon/src/MCGSIG.f create mode 100644 Dragon/src/MCGTMT.f create mode 100644 Dragon/src/MCGTRK.f create mode 100644 Dragon/src/MCT.f create mode 100644 Dragon/src/MCTALLY.f create mode 100644 Dragon/src/MCTCCC.f create mode 100644 Dragon/src/MCTCTR.f create mode 100644 Dragon/src/MCTFLX.f create mode 100644 Dragon/src/MCTGET.f create mode 100644 Dragon/src/MCTLDC.f create mode 100644 Dragon/src/MCTLDP.f create mode 100644 Dragon/src/MCTLIB.f create mode 100644 Dragon/src/MCTOUT.f create mode 100644 Dragon/src/MCTPIR.f create mode 100644 Dragon/src/MCTPSP.f create mode 100644 Dragon/src/MCTPTR.f create mode 100644 Dragon/src/MCTRK.f create mode 100644 Dragon/src/MESHST.f create mode 100644 Dragon/src/MOCCAL.f create mode 100644 Dragon/src/MOCCHR.f create mode 100644 Dragon/src/MOCDDF.f create mode 100644 Dragon/src/MOCDDFL.f create mode 100644 Dragon/src/MOCDDFS.f create mode 100644 Dragon/src/MOCDDFT.f create mode 100644 Dragon/src/MOCDS2.f create mode 100644 Dragon/src/MOCDSP.f create mode 100644 Dragon/src/MOCFCF.f create mode 100644 Dragon/src/MOCFFAL.f create mode 100644 Dragon/src/MOCFFAR.f create mode 100644 Dragon/src/MOCFFAS.f create mode 100644 Dragon/src/MOCFFAT.f create mode 100644 Dragon/src/MOCFFIR.f create mode 100644 Dragon/src/MOCFFIS.f create mode 100644 Dragon/src/MOCFFIT.f create mode 100644 Dragon/src/MOCIK3.f create mode 100644 Dragon/src/MOCSCA.f create mode 100644 Dragon/src/MOCSCAL.f create mode 100644 Dragon/src/MOCSCAS.f create mode 100644 Dragon/src/MOCSCAT.f create mode 100644 Dragon/src/MOCSCE.f create mode 100644 Dragon/src/MOCSCEL.f create mode 100644 Dragon/src/MOCSCES.f create mode 100644 Dragon/src/MOCSCET.f create mode 100644 Dragon/src/MPO.f create mode 100644 Dragon/src/MPOCA2.f create mode 100644 Dragon/src/MPOCAL.f create mode 100644 Dragon/src/MPOCAT.f create mode 100644 Dragon/src/MPOGEP.f create mode 100644 Dragon/src/MPOGEY.f create mode 100644 Dragon/src/MPOIDF.f create mode 100644 Dragon/src/MPOPAV.f create mode 100644 Dragon/src/MPOTOC.f create mode 100644 Dragon/src/MRG.f create mode 100644 Dragon/src/MRGGET.f create mode 100644 Dragon/src/MRGLIN.f create mode 100644 Dragon/src/MRGVOL.f create mode 100644 Dragon/src/MRGVON.f create mode 100644 Dragon/src/MRGVST.f create mode 100644 Dragon/src/MRGXTC.f create mode 100644 Dragon/src/MUSA.f90 create mode 100644 Dragon/src/MUSACG.f90 create mode 100644 Dragon/src/MUSF.f90 create mode 100644 Dragon/src/MUSJJ2.f90 create mode 100644 Dragon/src/MUSP.f90 create mode 100644 Dragon/src/Makefile create mode 100644 Dragon/src/NUMER3.f create mode 100644 Dragon/src/NUMERH.f create mode 100644 Dragon/src/NXT.f create mode 100644 Dragon/src/NXT3T2.f create mode 100644 Dragon/src/NXTACG.f create mode 100644 Dragon/src/NXTAGM.f create mode 100644 Dragon/src/NXTAVS.f create mode 100644 Dragon/src/NXTBCG.f create mode 100644 Dragon/src/NXTBRT.f create mode 100644 Dragon/src/NXTCUA.f create mode 100644 Dragon/src/NXTCVM.f create mode 100644 Dragon/src/NXTCVS.f create mode 100644 Dragon/src/NXTEGI.f create mode 100644 Dragon/src/NXTETH.f create mode 100644 Dragon/src/NXTETS.f create mode 100644 Dragon/src/NXTFID.f create mode 100644 Dragon/src/NXTGET.f create mode 100644 Dragon/src/NXTGMD.f create mode 100644 Dragon/src/NXTHCL.f create mode 100644 Dragon/src/NXTHRS.f create mode 100644 Dragon/src/NXTHUA.f create mode 100644 Dragon/src/NXTIAA.f create mode 100644 Dragon/src/NXTIHA.f create mode 100644 Dragon/src/NXTIND.f create mode 100644 Dragon/src/NXTIRA.f create mode 100644 Dragon/src/NXTIRR.f create mode 100644 Dragon/src/NXTITA.f create mode 100644 Dragon/src/NXTLCA.f create mode 100644 Dragon/src/NXTLCU.f create mode 100644 Dragon/src/NXTLCY.f create mode 100644 Dragon/src/NXTLDC.f create mode 100644 Dragon/src/NXTLDP.f create mode 100644 Dragon/src/NXTLHA.f create mode 100644 Dragon/src/NXTLHT.f create mode 100644 Dragon/src/NXTLRH.f create mode 100644 Dragon/src/NXTLRS.f create mode 100644 Dragon/src/NXTLSN.f create mode 100644 Dragon/src/NXTMCA.f create mode 100644 Dragon/src/NXTMCB.f create mode 100644 Dragon/src/NXTMCC.f create mode 100644 Dragon/src/NXTMCD.f create mode 100644 Dragon/src/NXTPCA.f create mode 100644 Dragon/src/NXTPCC.f create mode 100644 Dragon/src/NXTPHC.f create mode 100644 Dragon/src/NXTPHT.f create mode 100644 Dragon/src/NXTPR3.f create mode 100644 Dragon/src/NXTPRA.f create mode 100644 Dragon/src/NXTPRI.f create mode 100644 Dragon/src/NXTPRR.f create mode 100644 Dragon/src/NXTQAC.f create mode 100644 Dragon/src/NXTQAS.f create mode 100644 Dragon/src/NXTQEW.f create mode 100644 Dragon/src/NXTQLC.f create mode 100644 Dragon/src/NXTQLT.f create mode 100644 Dragon/src/NXTQPS.f create mode 100644 Dragon/src/NXTQRN.f create mode 100644 Dragon/src/NXTQSC.f create mode 100644 Dragon/src/NXTQSS.f create mode 100644 Dragon/src/NXTRCS.f create mode 100644 Dragon/src/NXTRIS.f create mode 100644 Dragon/src/NXTRPS.f create mode 100644 Dragon/src/NXTRTL.f create mode 100644 Dragon/src/NXTRTS.f create mode 100644 Dragon/src/NXTSGI.f create mode 100644 Dragon/src/NXTSGT.f create mode 100644 Dragon/src/NXTSQD.f create mode 100644 Dragon/src/NXTTCG.f create mode 100644 Dragon/src/NXTTCR.f create mode 100644 Dragon/src/NXTTGC.f create mode 100644 Dragon/src/NXTTGS.f create mode 100644 Dragon/src/NXTTLC.f create mode 100644 Dragon/src/NXTTLO.f create mode 100644 Dragon/src/NXTTLS.f create mode 100644 Dragon/src/NXTTNS.f create mode 100644 Dragon/src/NXTTPO.f create mode 100644 Dragon/src/NXTTPS.f create mode 100644 Dragon/src/NXTTRM.f create mode 100644 Dragon/src/NXTTRS.f create mode 100644 Dragon/src/NXTVCA.f create mode 100644 Dragon/src/NXTVCC.f create mode 100644 Dragon/src/NXTVHC.f create mode 100644 Dragon/src/NXTVHT.f create mode 100644 Dragon/src/NXTVOL.f create mode 100644 Dragon/src/NXTXYZ.f create mode 100644 Dragon/src/PIJAAA.f create mode 100644 Dragon/src/PIJABC.f create mode 100644 Dragon/src/PIJCMP.f create mode 100644 Dragon/src/PIJD2R.f create mode 100644 Dragon/src/PIJD2S.f create mode 100644 Dragon/src/PIJI2D.f create mode 100644 Dragon/src/PIJI3D.f create mode 100644 Dragon/src/PIJKST.f create mode 100644 Dragon/src/PIJRDG.f create mode 100644 Dragon/src/PIJRGL.f create mode 100644 Dragon/src/PIJRHL.f create mode 100644 Dragon/src/PIJRNL.f create mode 100644 Dragon/src/PIJS2D.f create mode 100644 Dragon/src/PIJS3D.f create mode 100644 Dragon/src/PIJSMD.f create mode 100644 Dragon/src/PIJWIJ.f create mode 100644 Dragon/src/PIJWPR.f create mode 100644 Dragon/src/PIJXL3.f create mode 100644 Dragon/src/PNFLV.f create mode 100644 Dragon/src/PNSH.f90 create mode 100644 Dragon/src/PRECISION_AND_KINDS.f90 create mode 100644 Dragon/src/PSOISO.f create mode 100644 Dragon/src/PSOMON.f create mode 100644 Dragon/src/PSOUR.f create mode 100644 Dragon/src/PSOUSN.f create mode 100644 Dragon/src/PSP.f create mode 100644 Dragon/src/PSPCOL.f create mode 100644 Dragon/src/PSPFCD.f create mode 100644 Dragon/src/PSPFIL.f create mode 100644 Dragon/src/PSPGET.f create mode 100644 Dragon/src/PSPLEG.f create mode 100644 Dragon/src/PSPMCP.f create mode 100644 Dragon/src/PSPNXT.f create mode 100644 Dragon/src/PSPRAI.f create mode 100644 Dragon/src/PSPTCR.f create mode 100644 Dragon/src/PSPTHR.f create mode 100644 Dragon/src/PSPTRK.f create mode 100644 Dragon/src/PSPXCG.f create mode 100644 Dragon/src/PSPXEL.f create mode 100644 Dragon/src/QIJCMP.f create mode 100644 Dragon/src/QIJI3D.f create mode 100644 Dragon/src/READBH.f create mode 100644 Dragon/src/READEU.f create mode 100644 Dragon/src/READMT.f create mode 100644 Dragon/src/RECT1.f create mode 100644 Dragon/src/RECT2.f create mode 100644 Dragon/src/S2M.f create mode 100644 Dragon/src/S2MGET.f create mode 100644 Dragon/src/SALACG.f90 create mode 100644 Dragon/src/SALEND.f90 create mode 100644 Dragon/src/SALGET_FUNS_MOD.f90 create mode 100644 Dragon/src/SALMUS.f90 create mode 100644 Dragon/src/SALT.f90 create mode 100644 Dragon/src/SALTCG.f create mode 100644 Dragon/src/SALTLC.f90 create mode 100644 Dragon/src/SALTLS.f90 create mode 100644 Dragon/src/SAL_AUX_MOD.f90 create mode 100644 Dragon/src/SAL_GEOMETRY_MOD.f90 create mode 100644 Dragon/src/SAL_GEOMETRY_TYPES.f90 create mode 100644 Dragon/src/SAL_NUMERIC_MOD.f90 create mode 100644 Dragon/src/SAL_TRACKING_TYPES.f90 create mode 100644 Dragon/src/SAL_TRAJECTORY_MOD.f90 create mode 100644 Dragon/src/SAP.f create mode 100644 Dragon/src/SAPCA2.f create mode 100644 Dragon/src/SAPCAL.f create mode 100644 Dragon/src/SAPCAT.f create mode 100644 Dragon/src/SAPFLU.f create mode 100644 Dragon/src/SAPFWC.f create mode 100644 Dragon/src/SAPGEP.f create mode 100644 Dragon/src/SAPGEY.f create mode 100644 Dragon/src/SAPIDF.f create mode 100644 Dragon/src/SAPPAV.f create mode 100644 Dragon/src/SAPSPH.f create mode 100644 Dragon/src/SEN.f create mode 100644 Dragon/src/SENCAL.f create mode 100644 Dragon/src/SENCNT.f create mode 100644 Dragon/src/SENDRV.f create mode 100644 Dragon/src/SENGET.f create mode 100644 Dragon/src/SHI.f create mode 100644 Dragon/src/SHIDIL.f create mode 100644 Dragon/src/SHIDRV.f create mode 100644 Dragon/src/SHIDST.f create mode 100644 Dragon/src/SHIEQU.f create mode 100644 Dragon/src/SHIRAT.f create mode 100644 Dragon/src/SHISN2.f create mode 100644 Dragon/src/SHISN3.f create mode 100644 Dragon/src/SNADPT.f create mode 100644 Dragon/src/SNDSA.f create mode 100644 Dragon/src/SNEST.f create mode 100644 Dragon/src/SNF.f create mode 100644 Dragon/src/SNFBC1.f create mode 100644 Dragon/src/SNFBC2.F create mode 100644 Dragon/src/SNFBC3.F create mode 100644 Dragon/src/SNFBH2.F create mode 100644 Dragon/src/SNFBH3.F create mode 100644 Dragon/src/SNFC12.f create mode 100644 Dragon/src/SNFE1D.f create mode 100644 Dragon/src/SNFE2D.F create mode 100644 Dragon/src/SNFE3D.F create mode 100644 Dragon/src/SNFG2D.F create mode 100644 Dragon/src/SNFG3D.F create mode 100644 Dragon/src/SNFKC2.F create mode 100644 Dragon/src/SNFKC3.F create mode 100644 Dragon/src/SNFKH2.F create mode 100644 Dragon/src/SNFKH3.F create mode 100644 Dragon/src/SNFLUX.f create mode 100644 Dragon/src/SNFT12.F create mode 100644 Dragon/src/SNFT1C.f create mode 100644 Dragon/src/SNFT1S.f create mode 100644 Dragon/src/SNGMRE.f create mode 100644 Dragon/src/SNQU01.f create mode 100644 Dragon/src/SNQU02.f create mode 100644 Dragon/src/SNQU03.f create mode 100644 Dragon/src/SNQU04.f create mode 100644 Dragon/src/SNQU05.f create mode 100644 Dragon/src/SNQU06.f create mode 100644 Dragon/src/SNQU07.f create mode 100644 Dragon/src/SNQU10.f create mode 100644 Dragon/src/SNSBFP.f create mode 100644 Dragon/src/SNSOUR.f create mode 100644 Dragon/src/SNT.f create mode 100644 Dragon/src/SNT1DC.f create mode 100644 Dragon/src/SNT1DP.f create mode 100644 Dragon/src/SNT1DS.f create mode 100644 Dragon/src/SNTRK.f create mode 100644 Dragon/src/SNTSFH.f create mode 100644 Dragon/src/SNTT2D.f create mode 100644 Dragon/src/SNTT3D.f create mode 100644 Dragon/src/SPH.F create mode 100644 Dragon/src/SPHAPX.f create mode 100644 Dragon/src/SPHCMA.f create mode 100644 Dragon/src/SPHCMI.f create mode 100644 Dragon/src/SPHCPO.f create mode 100644 Dragon/src/SPHDRV.f create mode 100644 Dragon/src/SPHEMB.f create mode 100644 Dragon/src/SPHEQU.f create mode 100644 Dragon/src/SPHGAP.f create mode 100644 Dragon/src/SPHMAC.f create mode 100644 Dragon/src/SPHMOL.f create mode 100644 Dragon/src/SPHMPO.f create mode 100644 Dragon/src/SPHSAP.f create mode 100644 Dragon/src/SPHSCO.f create mode 100644 Dragon/src/SPHSTM.f create mode 100644 Dragon/src/SPHSTO.f create mode 100644 Dragon/src/SPHSX5.f create mode 100644 Dragon/src/SPHSXS.f create mode 100644 Dragon/src/SPHTRA.f create mode 100644 Dragon/src/SYB001.f create mode 100644 Dragon/src/SYB002.f create mode 100644 Dragon/src/SYB003.f create mode 100644 Dragon/src/SYB004.f create mode 100644 Dragon/src/SYB005.f create mode 100644 Dragon/src/SYB31C.f create mode 100644 Dragon/src/SYB32C.f create mode 100644 Dragon/src/SYB33C.f create mode 100644 Dragon/src/SYB41C.f create mode 100644 Dragon/src/SYB43C.f create mode 100644 Dragon/src/SYB4QG.f create mode 100644 Dragon/src/SYB4T1.f create mode 100644 Dragon/src/SYB4T2.f create mode 100644 Dragon/src/SYB4T3.f create mode 100644 Dragon/src/SYB4T4.f create mode 100644 Dragon/src/SYB4TC.f create mode 100644 Dragon/src/SYB4TH.f create mode 100644 Dragon/src/SYB4TI.f create mode 100644 Dragon/src/SYB4TN.f create mode 100644 Dragon/src/SYB4TR.f create mode 100644 Dragon/src/SYB4TS.f create mode 100644 Dragon/src/SYB4VO.f create mode 100644 Dragon/src/SYB7QG.f create mode 100644 Dragon/src/SYB7T0.f create mode 100644 Dragon/src/SYB7TC.f create mode 100644 Dragon/src/SYB7TE.f create mode 100644 Dragon/src/SYB7TN.f create mode 100644 Dragon/src/SYB7TR.f create mode 100644 Dragon/src/SYB7TS.f create mode 100644 Dragon/src/SYB7TW.f create mode 100644 Dragon/src/SYB7VO.f create mode 100644 Dragon/src/SYBALC.f create mode 100644 Dragon/src/SYBALP.f create mode 100644 Dragon/src/SYBALS.f create mode 100644 Dragon/src/SYBCP1.f create mode 100644 Dragon/src/SYBEUR.f create mode 100644 Dragon/src/SYBHN2.f create mode 100644 Dragon/src/SYBHTK.f create mode 100644 Dragon/src/SYBILA.f create mode 100644 Dragon/src/SYBILF.f create mode 100644 Dragon/src/SYBILP.f create mode 100644 Dragon/src/SYBILT.f create mode 100644 Dragon/src/SYBJJ0.f create mode 100644 Dragon/src/SYBJJ1.f create mode 100644 Dragon/src/SYBJJ2.f create mode 100644 Dragon/src/SYBPRX.f create mode 100644 Dragon/src/SYBRHL.f create mode 100644 Dragon/src/SYBRII.f create mode 100644 Dragon/src/SYBRIJ.f create mode 100644 Dragon/src/SYBRN2.f create mode 100644 Dragon/src/SYBRTK.f create mode 100644 Dragon/src/SYBRX2.f create mode 100644 Dragon/src/SYBRX3.f create mode 100644 Dragon/src/SYBRXE.f create mode 100644 Dragon/src/SYBT1D.f create mode 100644 Dragon/src/SYBTRK.f create mode 100644 Dragon/src/SYBUP0.f create mode 100644 Dragon/src/SYBUP1.f create mode 100644 Dragon/src/SYBUQ0.f create mode 100644 Dragon/src/SYBUQV.f create mode 100644 Dragon/src/SYBWIJ.f create mode 100644 Dragon/src/TLM.f create mode 100644 Dragon/src/TLMDIR.f create mode 100644 Dragon/src/TLMGEO.f create mode 100644 Dragon/src/TLMGET.f create mode 100644 Dragon/src/TLMPLA.f create mode 100644 Dragon/src/TLMPLP.f create mode 100644 Dragon/src/TLMPNT.f create mode 100644 Dragon/src/TLMREG.f create mode 100644 Dragon/src/TLMVPL.f create mode 100644 Dragon/src/TONCMI.f create mode 100644 Dragon/src/TONDRV.f create mode 100644 Dragon/src/TONDST.f create mode 100644 Dragon/src/TONE.f create mode 100644 Dragon/src/TONSN3.f create mode 100644 Dragon/src/TONSPH.f create mode 100644 Dragon/src/TRA.f create mode 100644 Dragon/src/TRAGRO.f create mode 100644 Dragon/src/TRAXS.f create mode 100644 Dragon/src/TRFICF.f create mode 100644 Dragon/src/TRIFIS.f create mode 100644 Dragon/src/TRIFLV.f create mode 100644 Dragon/src/TRIVA.f create mode 100644 Dragon/src/TRIVSO.f create mode 100644 Dragon/src/TRKHEX.f create mode 100644 Dragon/src/USS.f create mode 100644 Dragon/src/USSCOR.f create mode 100644 Dragon/src/USSDRV.f create mode 100644 Dragon/src/USSEXC.f create mode 100644 Dragon/src/USSEXD.f create mode 100644 Dragon/src/USSFLU.f create mode 100644 Dragon/src/USSIN1.f create mode 100644 Dragon/src/USSIST.f create mode 100644 Dragon/src/USSIT0.f create mode 100644 Dragon/src/USSIT1.f create mode 100644 Dragon/src/USSIT2.f create mode 100644 Dragon/src/USSIT3.f create mode 100644 Dragon/src/USSIT4.f create mode 100644 Dragon/src/USSONE.f create mode 100644 Dragon/src/USSRSE.f create mode 100644 Dragon/src/USSSEK.f create mode 100644 Dragon/src/USSSPH.f create mode 100644 Dragon/src/VDG.f create mode 100644 Dragon/src/XCGBCM.f create mode 100644 Dragon/src/XCGDIM.f create mode 100644 Dragon/src/XCGGEO.f create mode 100644 Dragon/src/XCGROD.f create mode 100644 Dragon/src/XCWHEX.f create mode 100644 Dragon/src/XCWICL.f create mode 100644 Dragon/src/XCWREC.f create mode 100644 Dragon/src/XCWROD.f create mode 100644 Dragon/src/XCWSCL.f create mode 100644 Dragon/src/XCWSRT.f create mode 100644 Dragon/src/XCWTRK.f create mode 100644 Dragon/src/XDDCOM.f create mode 100644 Dragon/src/XDRCRE.f create mode 100644 Dragon/src/XDREXP.f create mode 100644 Dragon/src/XDRH11.f create mode 100644 Dragon/src/XDRH12.f create mode 100644 Dragon/src/XDRH13.f create mode 100644 Dragon/src/XDRH20.f create mode 100644 Dragon/src/XDRH23.f create mode 100644 Dragon/src/XDRH30.f create mode 100644 Dragon/src/XDRH33.f create mode 100644 Dragon/src/XDRKIN.f create mode 100644 Dragon/src/XDRLGS.f create mode 100644 Dragon/src/XDRLXS.f create mode 100644 Dragon/src/XDRNRM.f create mode 100644 Dragon/src/XDRTA2.f create mode 100644 Dragon/src/XDRTBH.f create mode 100644 Dragon/src/XEL3T2.f create mode 100644 Dragon/src/XELBIN.f create mode 100644 Dragon/src/XELCMP.f create mode 100644 Dragon/src/XELCOP.f create mode 100644 Dragon/src/XELCOR.f create mode 100644 Dragon/src/XELCRN.f create mode 100644 Dragon/src/XELCTR.f create mode 100644 Dragon/src/XELDCL.f create mode 100644 Dragon/src/XELDRV.f create mode 100644 Dragon/src/XELEDC.f create mode 100644 Dragon/src/XELEQN.f create mode 100644 Dragon/src/XELETR.f create mode 100644 Dragon/src/XELGPR.f create mode 100644 Dragon/src/XELGRD.f create mode 100644 Dragon/src/XELLIN.f create mode 100644 Dragon/src/XELLSR.f create mode 100644 Dragon/src/XELMRG.f create mode 100644 Dragon/src/XELNTR.f create mode 100644 Dragon/src/XELPR3.f create mode 100644 Dragon/src/XELPRC.f create mode 100644 Dragon/src/XELPRP.f create mode 100644 Dragon/src/XELPSC.f create mode 100644 Dragon/src/XELPSI.f create mode 100644 Dragon/src/XELTCW.f create mode 100644 Dragon/src/XELTI2.f create mode 100644 Dragon/src/XELTI3.f create mode 100644 Dragon/src/XELTRK.f create mode 100644 Dragon/src/XELTRP.f create mode 100644 Dragon/src/XELTS2.f create mode 100644 Dragon/src/XELTSA.f create mode 100644 Dragon/src/XELTSW.f create mode 100644 Dragon/src/XELVOL.f create mode 100644 Dragon/src/XHX2D0.f create mode 100644 Dragon/src/XHX2D1.f create mode 100644 Dragon/src/XHXTRK.f create mode 100644 Dragon/src/XL3NTR.f create mode 100644 Dragon/src/XL3SIG.f create mode 100644 Dragon/src/XL3TI3.f create mode 100644 Dragon/src/dramod.f90 create mode 100644 Dragon/src/g2s_boundCond.f90 create mode 100644 Dragon/src/g2s_cast.f90 create mode 100644 Dragon/src/g2s_celluleBase.f90 create mode 100644 Dragon/src/g2s_cellulePlaced.f90 create mode 100644 Dragon/src/g2s_constType.f90 create mode 100644 Dragon/src/g2s_constUtil.f90 create mode 100644 Dragon/src/g2s_construire.f90 create mode 100644 Dragon/src/g2s_convert.f90 create mode 100644 Dragon/src/g2s_g2mc.f90 create mode 100644 Dragon/src/g2s_g2s.f90 create mode 100644 Dragon/src/g2s_generateTabSegArc.f90 create mode 100644 Dragon/src/g2s_generatingMC.f90 create mode 100644 Dragon/src/g2s_generatingPS.f90 create mode 100644 Dragon/src/g2s_generatingSAL.f90 create mode 100644 Dragon/src/g2s_generatingTrack.f90 create mode 100644 Dragon/src/g2s_nodes.f90 create mode 100644 Dragon/src/g2s_pretraitement.f90 create mode 100644 Dragon/src/g2s_segArc.f90 create mode 100644 Dragon/src/g2s_unfold.f90 create mode 100644 Dragon/src/sdbm.c create mode 100644 Dragon/src/sdbm.h create mode 100644 Dragon/src/xsdb-defs.h create mode 100644 Dragon/src/xsdbops-sdbm.c create mode 100644 Dragon/src/xsdbops.h create mode 100644 Dragon/src/xsdf.c (limited to 'Dragon/src') diff --git a/Dragon/src/AEXCPC.f b/Dragon/src/AEXCPC.f new file mode 100644 index 0000000..d09ca32 --- /dev/null +++ b/Dragon/src/AEXCPC.f @@ -0,0 +1,40 @@ +*DECK AEXCPC + SUBROUTINE AEXCPC(IDKSGT,LNGTAB,TABSGT,TABLUE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Extraction of character information from an integer segment. Component +* of a FORTRAN-77 emulator of the SAPHYR archive system. +* +*Copyright: +* Copyright (C) 1999 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IDKSGT position (in byte) of information in segment. +* LNGTAB number of characters in the information. +* TABSGT integer segment. +* +*Parameters: output +* TABLUE CHARACTER*(LNGTAB) information. +* +*----------------------------------------------------------------------- +* + INTEGER IDKSGT,LNGTAB,TABSGT(*) + CHARACTER TABLUE*(*),TEXT4*4 +* + IDK=(IDKSGT+3)/4 + IOF=1 + DO 100 I=1,(LNGTAB+3)/4 + WRITE(TEXT4,'(A4)') TABSGT(IDK+I) + TABLUE(IOF:IOF+3)=TEXT4 + IOF=IOF+4 + 100 CONTINUE + RETURN + END diff --git a/Dragon/src/AEXDIR.f b/Dragon/src/AEXDIR.f new file mode 100644 index 0000000..d8f6897 --- /dev/null +++ b/Dragon/src/AEXDIR.f @@ -0,0 +1,90 @@ +*DECK AEXDIR + SUBROUTINE AEXDIR (NFICH,LBLOC,DATA,IADRES,LGSEG) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read infomation from a direct access file. Component of a FORTRAN-77 +* emulator of the SAPHYR archive system. +* +*Copyright: +* Copyright (C) 1999 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NFICH unit number of the direct access file. +* LBLOC direct access buffer length. +* IADRES offset, from start of file where data is extracted from +* or where data is to be stored. +* LGSEG number of words to read from or write into file. +* +*Parameters: output +* DATA address in memory where data is to be moved or extracted. +* +*----------------------------------------------------------------------- +* + IMPLICIT INTEGER(A-Z) + INTEGER DATA(LGSEG),LNEWAD(2) + INTEGER, ALLOCATABLE, DIMENSION(:) :: WRK +* + ALLOCATE(WRK(LBLOC)) + INDEX=IADRES + ID=0 + NROLD=0 + 10 NREC=1+INDEX/LBLOC + N=MOD(INDEX,LBLOC) + LMIN=1 + 20 IF(NREC.NE.NROLD) THEN +* -------------------------------------------------------- + READ(NFICH,REC=NREC,ERR=90,IOSTAT=IR) (WRK(I),I=1,LBLOC) +* -------------------------------------------------------- + NROLD=NREC + ENDIF + NGRO=MIN(LBLOC+LMIN-N-1,2) + DO 30 L=LMIN,NGRO + N=N+1 + LNEWAD(L)=WRK(N) + 30 CONTINUE + IF(NGRO.EQ.2) GO TO 40 + NREC=NREC+1 + N=0 + LMIN=NGRO+1 + GO TO 20 + 40 LINFO=LNEWAD(2) + IF(ID+LINFO.GT.LGSEG) CALL XABORT('AEXDIR: DIRECT ACCESS READ FA' + 1 //'ILURE(1).') + NREC=1+(INDEX+2)/LBLOC + N=MOD(INDEX+2,LBLOC) + LMIN=1 + 50 IF(NREC.NE.NROLD) THEN +* -------------------------------------------------------- + READ(NFICH,REC=NREC,ERR=90,IOSTAT=IR) (WRK(I),I=1,LBLOC) +* -------------------------------------------------------- + NROLD=NREC + ENDIF + NGRO=MIN(LBLOC+LMIN-N-1,LINFO) + DO 60 L=LMIN,NGRO + N=N+1 + DATA(ID+L)=WRK(N) + 60 CONTINUE + IF(NGRO.EQ.LINFO) GO TO 70 + NREC=NREC+1 + N=0 + LMIN=NGRO+1 + GO TO 50 +* + 70 INDEX=LNEWAD(1) + ID=ID+LNEWAD(2) + IF(ID.EQ.LGSEG) GO TO 80 + GO TO 10 + 80 DEALLOCATE(WRK) + IF(LNEWAD(1).NE.-1) CALL XABORT('AEXDIR: DIRECT ACCESS READ FAIL' + 1 //'URE(3).') + RETURN + 90 CALL XABORT('AEXDIR: DIRECT ACCESS READ FAILURE(2).') + END diff --git a/Dragon/src/AEXGNV.f b/Dragon/src/AEXGNV.f new file mode 100644 index 0000000..a3ab55a --- /dev/null +++ b/Dragon/src/AEXGNV.f @@ -0,0 +1,51 @@ +*DECK AEXGNV + SUBROUTINE AEXGNV(ICHAMP,SEGMEN,TCHDIM,TCHTYP,TCHDKL,IDK,NV) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Localization of a specific segment component in a SAPHYR archive. +* Component of a FORTRAN-77 emulator of the SAPHYR archive system. +* +*Copyright: +* Copyright (C) 1999 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ICHAMP component index in segment (low integer value). +* SEGMEN integer segment. +* TCHDIM dimension of segment components. +* TCHTYP character type of segment components. +* TCHDKL position of segment components. +* +*Parameters: output +* IDK position of segment component with index ichamp. +* NV length of segment component with index ichamp. +* +*----------------------------------------------------------------------- +* + INTEGER SEGMEN(*),TCHDIM(*),TCHTYP(*),TCHDKL(*) + CHARACTER TEXT4*4 +* + LONMOT=4 + CALL LCMCAR(TEXT4,.FALSE.,TCHTYP(ICHAMP)) + ND=TCHDIM(ICHAMP) + IDK=TCHDKL(ICHAMP+1) + NV=1 + DO 100 ID=1,ND + NV=NV*SEGMEN(IDK+ID) + 100 CONTINUE + IDKE=TCHDKL(ICHAMP) + IF(IDKE.LT.0) THEN + IDK=SEGMEN(1-IDKE)+1 + ELSE + IDK=IDKE+1 + ENDIF + IF(TEXT4(1:1).EQ.'C') IDK=(IDK-1)/LONMOT+1 + RETURN + END diff --git a/Dragon/src/AEXTPA.f b/Dragon/src/AEXTPA.f new file mode 100644 index 0000000..deb6ece --- /dev/null +++ b/Dragon/src/AEXTPA.f @@ -0,0 +1,66 @@ +*DECK AEXTPA + SUBROUTINE AEXTPA(NOMFIC,ISFICH) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Determination of a SAPHYR archive file characteristics. +* Component of a FORTRAN-77 emulator of the SAPHYR archive system. +* +*Copyright: +* Copyright (C) 1999 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NOMFIC name of SAPHYR archive file. +* +*Parameters: output +* ISFICH file characteristics with: +* ISFICH(1) is the address of the table of content; +* ISFICH(2) is the number of archive objects on file; +* ISFICH(3) is the direct access record length in words. +* +*----------------------------------------------------------------------- +* + INTEGER ISFICH(3) + CHARACTER NOMFIC*(*),HSMG*131 +* + IULFIC = KDROPN(NOMFIC,2,4,1) + IF(IULFIC.LE.0) THEN + WRITE(HSMG,'(33HAEXTPA: KDROPN FAILURE WITH CODE=,I3)') IULFIC + CALL XABORT(HSMG) + ENDIF + ISTATE = 5 + I2 = 3 +* + 40 READ(IULFIC,REC=I2,ERR=50,IOSTAT=IOS) MOTLU + IF(IOS.NE.0) GO TO 50 +* + ISTATE = ISTATE + 1 + IF(ISTATE .EQ. 8) THEN + ISFICH(3) = MOTLU + I2 = 4 + GO TO 40 + ELSEIF(ISTATE .EQ. 9) THEN + ISFICH(2) = MOTLU + ELSEIF(ISTATE .EQ. 7) THEN + I2 = MOTLU + 7 + GO TO 40 + ELSEIF(ISTATE .EQ. 6) THEN + ISFICH(1) = MOTLU + I2 = MOTLU + 3 + GO TO 40 + ENDIF +* + 50 IER = KDRCLS(IULFIC,1) + IF(IER.LT.0) THEN + WRITE(HSMG,'(33HAEXTPA: KDRCLS FAILURE WITH CODE=,I3)') IER + CALL XABORT(HSMG) + ENDIF + RETURN + END diff --git a/Dragon/src/AEXTRT.f b/Dragon/src/AEXTRT.f new file mode 100644 index 0000000..3b79d9f --- /dev/null +++ b/Dragon/src/AEXTRT.f @@ -0,0 +1,195 @@ +*DECK AEXTRT + SUBROUTINE AEXTRT(AEXFAP,TYPSEG,NBRTYP,IPCHDIM,IPCHTYP, + 1 IPCHDKL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Extraction of component information for a segment of type typseg. +* Component of a FORTRAN-77 emulator of the SAPHYR archive system. +* +*Copyright: +* Copyright (C) 1999 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* AEXFAP external subroutine providing segment type information. +* TYPSEG character type of segment. +* +*Parameters: output +* NBRTYP number of components in segment. +* IPCHDIM pointer of vector tchdim containing the +* dimensions of segment components. +* IPCHTYP pointer of vector tchtyp containing the +* character types of segment components. +* IPCHDKL pointer of vector tchdkl containing the +* positions of segment components. +* +*Comments: +* The setara pointers ichdim, ichtyp and ichdkl should be +* deallocated at completion of work. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT INTEGER(A-Z) + EXTERNAL AEXFAP + CHARACTER TYPSEG*(*),TEXT4*4,CHAIN*80,HSMG*131 + TYPE(C_PTR) IPCHDIM,IPCHTYP,IPCHDKL + INTEGER, POINTER, DIMENSION(:) :: ICHDIM,ICHTYP,ICHDKL + +* + LONMOT=4 + CHAIN=' ' + IRETOU=1 + IF(TYPSEG(1:1) .EQ. '.') THEN + CHAIN = TYPSEG(2:) + ELSE + CALL AEXFAP(TYPSEG,CHAIN) + ENDIF +* +* DECODING THE COMPONENT FIELDS. + MMOT = INDEX(CHAIN, ' ') - 1 + IF(MMOT .GT. 0) THEN + IRETOU = 0 + NBRTYP = 0 + IP = 0 + DO 10 I = 1, MMOT + II = INDEX('0123456789', CHAIN(I:I)) + IF(II .NE. 0) THEN + IP = IP * 10 + II + IP = IP - 1 + ELSE IF(CHAIN(I:I) .EQ. 'C') THEN + NBRTYP = NBRTYP + IP + 2 + IP = 0 + ELSE + NBRTYP = NBRTYP + IP + 1 + IP = 0 + ENDIF + 10 CONTINUE + NBRTYP = NBRTYP + IP + MMOTC = MMOT + IPCHDIM=LCMARA(NBRTYP) + IPCHTYP=LCMARA(NBRTYP) + IPCHDKL=LCMARA(NBRTYP) + CALL C_F_POINTER(IPCHDIM,ICHDIM,(/ NBRTYP /)) + CALL C_F_POINTER(IPCHTYP,ICHTYP,(/ NBRTYP /)) + CALL C_F_POINTER(IPCHDKL,ICHDKL,(/ NBRTYP /)) + IRETOU = 0 + NM = 0 + NN = 0 + NU = 0 + + IC = 0 + IDIM = 0 + IP = 0 + JC = 0 + KC = -1 + + DO 20 I = 1, MMOTC + 1 + IF(I .LE. MMOTC) THEN + II = INDEX('1234567890RICLD', CHAIN(I:I)) + ELSE + II = 1024 + ENDIF + IF(II .EQ. 0) THEN + IRETOU = I + GO TO 30 + ELSE IF(II .LE. 10) THEN + IP = IP * 10 + II + ELSE + IF(JC .NE. 0) THEN + IF(CHAIN(JC:JC) .EQ. 'C') THEN + IP = IP + 1 + ENDIF + IC = IC + 1 + KC = KC + 1 + TEXT4 = CHAIN(JC:JC) + CALL LCMCAR(TEXT4,.TRUE.,ICHTYP(IC)) + ICHDIM(IC) = IP + IF(IP .EQ. 0) THEN + IF(CHAIN(JC:JC) .EQ. 'D') THEN + IF(LONMOT .EQ. 8) THEN + ICHDKL(IC) = KC + ELSE + IF(MOD (KC, 2) .EQ. 0) THEN + ICHDKL(IC) = KC / 2 + KC = KC + 1 + ELSE + ICHDKL(IC) = (KC + 1) / 2 + KC = KC + 2 + ENDIF + ENDIF + ELSE + ICHDKL(IC) = KC + ENDIF + ELSE + IF(NM .EQ. 0) THEN + KC = KC - 1 + ENDIF + ICHDKL(IC) = - KC + DO JC = 1, IP + IC = IC + 1 + KC = KC + 1 + TEXT4 = 'I' + CALL LCMCAR(TEXT4,.TRUE.,ICHTYP(IC)) + ICHDIM(IC) = 0 + ICHDKL(IC) = KC + ENDDO + ENDIF + + NN = NN + IP + 1 + IF(IP .GT. 0) THEN + NM = NM + 1 + ELSE IF(NM .GT. 0) THEN + IRETOU = I + GO TO 30 + ELSE + NU = NU + 1 + ENDIF + IP = 0 + ELSE IF(IP .NE. 0) THEN + IRETOU = I + GO TO 30 + ENDIF + + JC = I + ENDIF + 20 CONTINUE + IF(NM .GT. 0) THEN + CALL LCMCAR(TEXT4,.FALSE.,ICHTYP(NU+1)) + IF(TEXT4(1:1) .EQ. 'C') THEN + ICHDKL(NU+1) = (NN - 1) * LONMOT + ELSE IF(TEXT4(1:1) .EQ. 'D') THEN + IF(LONMOT .EQ. 8) THEN + ICHDKL(NU+1) = NN - 1 + ELSE + IF(MOD (NN, 2) .EQ. 0) THEN + ICHDKL(NU+1) = NN / 2 + ELSE + ICHDKL(NU+1) = (NN - 1) / 2 + ENDIF + ENDIF + ELSE + ICHDKL(NU+1) = NN - 1 + ENDIF + ENDIF + + IF(IC .NE. NBRTYP) THEN + IRETOU = NBRTYP + IC + GO TO 30 + ENDIF + ENDIF +* + 30 IF(IRETOU.NE.0) THEN + WRITE(HSMG,'(22HAEXTRT: FAILURE NUMBER,I5,18H FOR SEGMENT TYPE , + 1 A)') IRETOU,TYPSEG + CALL XABORT(HSMG) + ENDIF + RETURN + END diff --git a/Dragon/src/APX.f b/Dragon/src/APX.f new file mode 100644 index 0000000..e900aa4 --- /dev/null +++ b/Dragon/src/APX.f @@ -0,0 +1,556 @@ +*DECK APX + SUBROUTINE APX(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Creation and construction of an APEX database object. +* +*Copyright: +* Copyright (C) 2025 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1) APEX database object; +* HENTRY(I) I>1 read-only type(L_BURNUP, L_LIBRARY or L_EDIT). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40,MAXPAR=50,MAXISO=800,NKEYS=6,NREAK=20, + 1 MAXLIN=50,MAXMAC=2) + INTEGER RANK,TYPE,NBYTE,DIMSR(5) + TYPE(C_PTR) IPAPX,IPLB1,IPDEPL,IPEDIT + CHARACTER TEXT4*4,TEXT8*8,TEXT12*12,TEXT20*20,HAPXX*80,HSIGN*12, + 1 KEYWRD(NKEYS)*4,NOMISO(MAXISO)*8,NOMEVO(MAXISO)*12, + 2 NOMREA(NREAK)*4,HSMG*131,NOMMAC(MAXMAC)*8 + DOUBLE PRECISION DFLOTT + LOGICAL LINIT,LWARN,LGNEW(MAXPAR) + INTEGER IDATA(NSTATE),NVALUE(MAXPAR),TYPISO(MAXISO),MUPLET(MAXPAR) + CHARACTER REV*48,DATE*64,HEQUI*80 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, POINTER, DIMENSION(:) :: HMIX + INTEGER, ALLOCATABLE, TARGET, DIMENSION(:) :: HMIX2 + REAL, ALLOCATABLE, DIMENSION(:) :: TIMES,ENRGA + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPRHS + INTEGER, ALLOCATABLE, DIMENSION(:) :: DIMS_APX + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: PARFMT + CHARACTER(LEN=80), ALLOCATABLE, DIMENSION(:) :: PARNAM + CHARACTER(LEN=4), ALLOCATABLE, DIMENSION(:) :: TEXT4V1 + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: TEXT8V1 +*---- +* DATA STATEMENTS +*---- + DATA KEYWRD/'NOML','PARA','ISOT','MACR','REAC','; '/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IPRHS(NENTRY)) +*---- +* PARAMETER VALIDATION. +*---- + LINIT=.FALSE. + IF(NENTRY.EQ.0) CALL XABORT('APX: PARAMETERS EXPECTED.') + IF((IENTRY(1).EQ.6).AND.(JENTRY(1).EQ.0)) THEN + IPAPX=KENTRY(1) + LINIT=.TRUE. + HAPXX='DRAGON5_OUTPUT' + CALL hdf5_write_data(IPAPX,"/structure_type",TRIM(HAPXX)) + CALL KDRVER(REV,DATE) + WRITE(6,400) REV + CALL hdf5_write_data(IPAPX,"/structure_version",TRIM(REV)) + CALL hdf5_create_group(IPAPX,'explicit') + ELSE IF(IENTRY(1).EQ.6) THEN + IPAPX=KENTRY(1) + CALL hdf5_info(IPAPX,"/structure_type",RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.EQ.99) THEN + TEXT12=HENTRY(1) + CALL XABORT('APX: HDF FILE '//TEXT12//' CANNOT BE READ.') + ENDIF + LINIT=.FALSE. + ELSE + CALL XABORT('APX: APEX HDF5 OBJECT EXPECTED.') + ENDIF + TYPISO(:MAXISO)=0 + IPLB1=C_NULL_PTR + IPDEPL=C_NULL_PTR + IPEDIT=C_NULL_PTR + IPRHS(:NENTRY)=C_NULL_PTR + DO 10 I=2,NENTRY + IF(IENTRY(I).LE.2) THEN + IF(JENTRY(I).NE.2) CALL XABORT('APX: READ-ONLY RHS EXPECTE' + 1 //'D.') + CALL LCMGTC(KENTRY(I),'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_LIBRARY') THEN + IPLB1=KENTRY(I) + ELSE IF(HSIGN.EQ.'L_BURNUP') THEN + IPDEPL=KENTRY(I) + ELSE IF(HSIGN.EQ.'L_EDIT') THEN + IPEDIT=KENTRY(I) + ENDIF + ELSE IF(IENTRY(I).EQ.6) THEN + IPRHS(I)=KENTRY(I) + ELSE + CALL XABORT('APX: LCM OR HDF5 OBJECTS EXPECTED AT RHS.') + ENDIF + 10 CONTINUE +*---- +* READ THE INPUT DATA. +*---- +* DEFAULT OPTIONS: + IMPX=1 + IF(LINIT) THEN + NCOMLI=0 + NPAR=0 + NPCHR=0 + NPPNT=0 + NLOC=0 + NPPNTL=0 + NPCHRL=0 + NISO=0 + NMAC=0 + NMIL=0 + NREA=0 + NISOF=0 + NISOP=0 + ELSE + GO TO 300 + ENDIF + ALLOCATE(PARNAM(MAXPAR),PARFMT(MAXPAR)) + 20 CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('APX: CHARACTER DATA EXPECTED(1).') + + 30 IF(TEXT8.EQ.'EDIT') THEN +* READ THE PRINT INDEX. + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('APX: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT8.EQ.'NOML') THEN + HAPXX=' ' + CALL REDGET(INDIC,NITMA,FLOTT,HAPXX(:72),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('APX: CHARACTER DATA EXPECTED' + 1 //'(2).') + CALL hdf5_write_data(IPAPX,"/LIBNAME",TRIM(HAPXX)) + ELSE IF(TEXT8.EQ.'PARA') THEN + NPAR=NPAR+1 + IF(NPAR.GT.MAXPAR) CALL XABORT('APX: TOO MANY PARAMETERS.') + PARNAM(NPAR)=' ' + CALL REDGET(INDIC,NITMA,FLOTT,PARNAM(NPAR),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('APX: CHARACTER DATA EXPECTED' + 1 //'(3).') + DO 40 I=1,NPAR-1 + IF(PARNAM(NPAR).EQ.PARNAM(I)) CALL XABORT('APX: PARNAM '// + 1 PARNAM(NPAR)//' ALREADY DEFINED(1).') + 40 CONTINUE + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('APX: CHARACTER DATA EXPECTED' + 1 //'(4).') + IF(TEXT4.EQ.'BURN') THEN + IF((PARNAM(NPAR).NE.'Burnup').AND.(PARNAM(NPAR).NE.'Time') + 1 .AND.(PARNAM(NPAR).NE.'Power').AND. + 2 (PARNAM(NPAR).NE.'Exposure').AND.(PARNAM(NPAR).NE.'Flux') + 3 .AND.(PARNAM(NPAR).NE.'Heavy')) THEN + WRITE(HSMG,'(15HAPX: PARAMETER ,A,19H CANNOT BE RECOVERE, + 1 21HD FROM BURNUP OBJECT.)') TRIM(PARNAM(NPAR)) + CALL XABORT(HSMG) + ENDIF + PARFMT(NPAR)='FLOTTANT' + ELSE IF(TEXT4.EQ.'VALE') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('APX: CHARACTER DATA EXPECTED' + 1 //'(5).') + IF(TEXT8.EQ.'FLOT')THEN + PARFMT(NPAR)='FLOTTANT' + ELSEIF(TEXT8.EQ.'CHAI')THEN + PARFMT(NPAR)='CHAINE' + ELSEIF(TEXT8.EQ.'ENTI')THEN + PARFMT(NPAR)='ENTIER' + ELSE + CALL XABORT('APX: INVALID KEYWORD='//TEXT4//'(1).') + ENDIF + ELSE + CALL XABORT('APX: INVALID KEYWORD='//TEXT4//'(2).') + ENDIF + NVALUE(NPAR)=0 + ELSE IF(TEXT8.EQ.'ISOT') THEN + 80 CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('APX: CHARACTER DATA EXPECTED' + 1 //'(6).') + IF(.NOT.C_ASSOCIATED(IPLB1)) THEN + CALL XABORT('APX: MISSING HMIX OBJECT(1).') + ENDIF + DO 90 IKEY=1,NKEYS + IF(TEXT8.EQ.KEYWRD(IKEY)) GO TO 30 + 90 CONTINUE + IF(TEXT8.EQ.'TOUT') THEN + CALL COMISO(-1,MAXISO,IPLB1,NISO,NOMISO,NOMEVO,TYPISO) + GO TO 20 + ELSE IF(TEXT8.EQ.'FISS') THEN + CALL COMISO(-2,MAXISO,IPLB1,NISO,NOMISO,NOMEVO,TYPISO) + ELSE IF(TEXT8.EQ.'PF') THEN + CALL COMISO(-3,MAXISO,IPLB1,NISO,NOMISO,NOMEVO,TYPISO) + ELSE IF(TEXT8.EQ.'MILI') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('APX: INTEGER DATA EXPECTE'// + 1 'D(4).') + CALL COMISO(NITMA,MAXISO,IPLB1,NISO,NOMISO,NOMEVO,TYPISO) + ELSE + DO 100 IKEY=1,NKEYS + IF(TEXT8.EQ.KEYWRD(IKEY)) GO TO 30 + 100 CONTINUE + NISO=NISO+1 + IF(NISO.GT.MAXISO) CALL XABORT('APX: TOO MANY ISOTOPES.') + NOMISO(NISO)=TEXT8 + TYPISO(NISO)=0 + ENDIF + GO TO 80 + ELSE IF(TEXT8.EQ.'MACR') THEN + NMAC=0 + CALL hdf5_info(IPAPX,"/explicit/MACNAME",RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.NE.99) THEN + CALL hdf5_read_data(IPAPX,"/explicit/MACNAME",TEXT8V1) + NMAC=SIZE(TEXT8V1) + NOMMAC(:NMAC)=TEXT8V1(:NMAC) + DEALLOCATE(TEXT8V1) + ENDIF + NMAC=NMAC+1 + IF(NMAC.GT.MAXMAC) CALL XABORT('APX: MAXMAC OVERFLOW.') + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('APX: CHARACTER DATA EXPECTED' + 1 //'(7).') + IF(TEXT4.EQ.'TOUT') THEN + NOMMAC(NMAC)='TOTAL' + ELSE IF(TEXT4.EQ.'REST') THEN + NOMMAC(NMAC)='RESIDUAL' + ELSE + CALL XABORT('APX: INVALID KEYWORD='//TEXT4//'(3).') + ENDIF + CALL hdf5_write_data(IPAPX,"/explicit/MACNAME",NOMMAC(:NMAC)) + ELSE IF(TEXT8.EQ.'REAC') THEN + 110 CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('APX: CHARACTER DATA EXPECTED' + 1 //'(8).') + DO 120 IKEY=1,NKEYS + IF(TEXT8.EQ.KEYWRD(IKEY)) GO TO 30 + 120 CONTINUE + DO 130 IKEY=1,NREA + IF(TEXT8.EQ.NOMREA(IKEY)) GO TO 110 + 130 CONTINUE + NREA=NREA+1 + IF(NREA.GT.NREAK) CALL XABORT('APX: TOO MANY REACTIONS.') + NOMREA(NREA)=TEXT8(:4) + GO TO 110 + ELSE IF(TEXT8.EQ.'NAME') THEN +* READ MIXTURE NAMES. + MAXMIL=30 + ALLOCATE(HMIX(5*MAXMIL)) + 140 CALL REDGET(INDIC,NITMA,FLOTT,TEXT20,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('APX: CHARACTER DATA EXPECTED'// + 1 '(9).') + IF(TEXT20.EQ.';') GO TO 160 + NMIL=NMIL+1 + IF(NMIL.GT.MAXMIL) THEN + ALLOCATE(HMIX2(5*(MAXMIL+30))) + DO 150 I=1,5*MAXMIL + HMIX2(I)=HMIX(I) + 150 CONTINUE + DEALLOCATE(HMIX) + MAXMIL=MAXMIL+30 + HMIX=>HMIX2 + ENDIF + READ(TEXT20,'(5A4)') (HMIX((NMIL-1)*5+I0),I0=1,5) + GO TO 140 + ELSE IF(TEXT8.EQ.';') THEN + GO TO 160 + ELSE + CALL XABORT('APX: INVALID KEYWORD='//TEXT8//'(4).') + ENDIF + GO TO 20 +* +* ADD THE TIME PARAMETER. + 160 DO 170 I=1,NPAR + IF((PARNAM(I).EQ.'Burnup').OR.(PARNAM(I).EQ.'Exposure')) GO TO 180 + 170 CONTINUE + GO TO 220 + 180 DO 210 I=1,NPAR + IF(PARNAM(I).EQ.'Time') GO TO 220 + 210 CONTINUE + NPAR=NPAR+1 + IF(NPAR.GT.MAXPAR) CALL XABORT('APX: TOO MANY PARAMETERS.') + PARNAM(NPAR)='Time' + PARFMT(NPAR)='FLOTTANT' + NVALUE(NPAR)=0 +*---- +* STORE THE APEX INITIALIZATION INFORMATION. +*---- + 220 CALL hdf5_create_group(IPAPX,'physconst') + IF(NISO.GT.0) THEN + IF(.NOT.C_ASSOCIATED(IPLB1)) THEN + CALL XABORT('APX: MISSING HMIX OBJECT(2).') + ENDIF + CALL COMISO(0,MAXISO,IPLB1,NISO,NOMISO,NOMEVO,TYPISO) + CALL hdf5_write_data(IPAPX,"/explicit/ISONAME",NOMISO(:NISO)) + ALLOCATE(TEXT4V1(NISO)) + DO 230 I=1,NISO + IF(TYPISO(I).EQ.1) THEN + TEXT4V1(I)='OTHE' + ELSE IF(TYPISO(I).EQ.2) THEN + NISOF=NISOF+1 + TEXT4V1(I)='FISS' + ELSE IF(TYPISO(I).EQ.3) THEN + NISOP=NISOP+1 + TEXT4V1(I)='F.P.' + ENDIF + 230 CONTINUE + CALL hdf5_write_data(IPAPX,"/physconst/ISOTYP",TEXT4V1) + CALL hdf5_write_data(IPAPX,"/physconst/ISOTA",NOMISO(:NISO)) + DEALLOCATE(TEXT4V1) + ENDIF + IF(NREA.GT.0) THEN + CALL hdf5_write_data(IPAPX,"/explicit/REANAME",NOMREA(:NREA)) + ENDIF + IF(NPAR.GT.0) THEN + CALL hdf5_write_data(IPAPX,"/Calculation_Content",PARNAM(:NPAR)) + CALL hdf5_create_group(IPAPX,'paramvalues') + CALL hdf5_create_group(IPAPX,'paramdescrip') + CALL hdf5_write_data(IPAPX,"/paramdescrip/NVALUE",NVALUE(:NPAR)) + CALL hdf5_write_data(IPAPX,"/paramdescrip/PARFMT",PARFMT(:NPAR)) + CALL hdf5_write_data(IPAPX,"/paramdescrip/PARNAM",PARNAM(:NPAR)) + ENDIF + DEALLOCATE(PARFMT,PARNAM) +*---- +* FILL THE 'physconst' GROUP. +*---- + IF(C_ASSOCIATED(IPLB1)) THEN + CALL LCMGET(IPLB1,'STATE-VECTOR',IDATA) + NBISO=IDATA(2) + NGA=IDATA(3) + ALLOCATE(ENRGA(NGA+1)) + CALL LCMGET(IPLB1,'ENERGY',ENRGA) + DO 240 I=1,NGA+1 + ENRGA(I)=ENRGA(I)*1.0E-6 + 240 CONTINUE + CALL hdf5_write_data(IPAPX,"/physconst/ENRGA",ENRGA) + DEALLOCATE(ENRGA) + ELSE + NBISO=0 + NGA=0 + NISOTA=0 + ENDIF + NCALS=0 + CALL hdf5_write_data(IPAPX,"/NCALS",NCALS) + GO TO 390 +* END OF APEX FILE INITIALIZATION. ******************************** +*---- +* INPUT AN ELEMENTARY CALCULATION. ******************************* +*---- + 300 CALL hdf5_read_data(IPAPX,"NCALS",NCALS) + NORIG=NCALS + IF(hdf5_group_exists(IPAPX,"/paramdescrip")) THEN + CALL hdf5_get_shape(IPAPX,"/paramdescrip/NVALUE",DIMS_APX) + NPAR=DIMS_APX(1) + DEALLOCATE(DIMS_APX) + ELSE + NPAR=0 + ENDIF + IF(NPAR.GT.0) THEN + CALL hdf5_read_data(IPAPX,"/paramdescrip/PARNAM",PARNAM) + CALL hdf5_read_data(IPAPX,"/paramdescrip/PARFMT",PARFMT) + ENDIF +* + ITIM=0 + LWARN=.FALSE. + IMPX=1 + HEQUI=' ' + IPICK=0 + 310 CALL REDGET(INDIC,NITMA,FLOTT,TEXT20,DFLOTT) + IF(INDIC.EQ.10) GO TO 350 + IF(INDIC.NE.3) CALL XABORT('APX: CHARACTER DATA EXPECTED(10).') + IF(TEXT20.EQ.'EDIT') THEN +* READ THE PRINT INDEX. + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('APX: INTEGER DATA EXPECTED(5).') + ELSE IF(TEXT20.EQ.'SET') THEN + CALL REDGET(INDIC,NITMA,XT,TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('APX: REAL DATA EXPECTED(1).') + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('APX: CHARACTER DATA EXPECTED' + 1 //'(11).') + IF(TEXT4.EQ.'S') THEN + XT=XT*1.0E-8 + ELSE IF(TEXT4.EQ.'DAY') THEN + XT=XT*8.64E-4 + ELSE IF(TEXT4.EQ.'YEAR') THEN + XT=XT*3.1536E-1 + ELSE + CALL XABORT('APX: S, DAY OR YEAR EXPECTED.') + ENDIF + IF(.NOT.C_ASSOCIATED(IPDEPL)) CALL XABORT('APX: DEPLETION OBJ' + 1 //'ECT EXPECTED AT RHS.') + CALL LCMLEN(IPDEPL,'DEPL-TIMES',NTIM,ITYLCM) + IF(NTIM.EQ.0) CALL XABORT('APX: NO DEPLETION TIME STEPS.') + ALLOCATE(TIMES(NTIM)) + CALL LCMGET(IPDEPL,'DEPL-TIMES',TIMES) + DO 320 I=1,NTIM + IF(ABS(TIMES(I)-XT).LE.1.0E-4*XT) ITIM=I + 320 CONTINUE + IF(ITIM.EQ.0) THEN + WRITE(HSMG,'(39HAPX: UNABLE TO FIND A DEPLETION DIRECTO, + 1 12HRY AT TIME =,1P,E12.4,5H DAY.)') XT/8.64E-4 + CALL XABORT(HSMG) + ENDIF + DEALLOCATE(TIMES) + IF(IMPX.GT.0) THEN + WRITE(TEXT12,'(8HDEPL-DAT,I4.4)') ITIM + WRITE(6,430) XT,XT/8.64E-4,TEXT12 + ENDIF + ELSE IF(TEXT20.EQ.'ORIG') THEN + CALL REDGET(INDIC,NORIG,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('APX: INTEGER DATA EXPECTED(6).') + ELSE IF(TEXT20.EQ.'EQUI') THEN + CALL REDGET(INDIC,NORIG,FLOTT,HEQUI,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('APX: CHARACTER DATA EXPECTED(12).') + ELSE IF(TEXT20.EQ.';') THEN + GO TO 350 + ELSE IF(TEXT20.EQ.'ICAL') THEN + IPICK=1 + GO TO 350 + ELSE IF(TEXT20.EQ.'WARN') THEN + LWARN=.TRUE. + ELSE + IPAR=0 + DO 330 IKEY=1,NPAR + IF(TEXT20.EQ.PARNAM(IKEY)) THEN + IPAR=IKEY + GO TO 340 + ENDIF + 330 CONTINUE + CALL XABORT('APX: INVALID KEYWORD='//TEXT20//'(5).') + 340 CALL REDGET(INDIC,NITMA,FLOTT,TEXT20,DFLOTT) + IF(PARFMT(IPAR).EQ.'ENTIER') THEN + IF(INDIC.NE.1) CALL XABORT('APX: INTEGER DATA EXPECTE'// + 1 'D(7).') + IF(IMPX.GT.0) WRITE(6,450) TRIM(PARNAM(IPAR)),NITMA + ELSE IF(PARFMT(IPAR).EQ.'FLOTTANT') THEN + IF(INDIC.NE.2) CALL XABORT('APX: REAL DATA EXPECTED(2).') + IF(IMPX.GT.0) WRITE(6,440) TRIM(PARNAM(IPAR)),FLOTT + ELSE IF(PARFMT(IPAR).EQ.'CHAINE') THEN + IF(INDIC.NE.3) CALL XABORT('APX: CHARACTER DATA EXPEC'// + 1 'TED(13).') + IF(IMPX.GT.0) WRITE(6,460) TRIM(PARNAM(IPAR)),TEXT20 + ENDIF + CALL APXPAV(IPAPX,IPAR,NPAR,PARFMT(IPAR),FLOTT,NITMA,TEXT20, + 1 MUPLET(IPAR),LGNEW(IPAR)) + ENDIF + GO TO 310 +*---- +* RECOVER AN ELEMENTARY CALCULATION FROM EDITION. +*---- + 350 IF(NPAR.GT.0) DEALLOCATE(PARFMT,PARNAM) + NCALS=0 + CALL hdf5_info(IPAPX,"/NCALS",RANK,TYPE,NBYTE,DIMSR) + IF(RANK.NE.99) CALL hdf5_read_data(IPAPX,"/NCALS",NCALS) + IF(NENTRY.GE.2) THEN + IF(C_ASSOCIATED(IPRHS(2))) GO TO 360 + ENDIF + IF(IMPX.GT.0) WRITE(6,420) NCALS+1 + IF(ITIM.GT.0) THEN + WRITE(TEXT12,'(8HDEPL-DAT,I4.4)') ITIM + CALL LCMSIX(IPDEPL,TEXT12,1) + ENDIF +* ------------------------------------------- + CALL APXCAL(IMPX,IPAPX,IPDEPL,IPEDIT,HEQUI) +* ------------------------------------------- + IF(ITIM.GT.0) CALL LCMSIX(IPDEPL,' ',2) +*---- +* RECOVER REMAINING GLOBAL PARAMETER AND LOCAL VALUES. +*---- + CALL APXGEP(IPAPX,IPDEPL,IMPX,ITIM,NORIG,NPAR,MUPLET,LGNEW,NVPNEW, + 1 NCALS) + IF(IMPX.GT.0) THEN + CALL APXTOC(IPAPX,IMPX,NLAM,NREA,NBISO,NBMAC,NMIL,NPARR,NVP, + 1 NISOF,NISOP,NISOS,NCALR,NG,NISOTS,NSURFD,NPRC) + ENDIF +*---- +* RECOVER THE CALCULATION INDEX AND SAVE IT IN A CLE-2000 VARIABLE +*---- + IF(IPICK.EQ.1) THEN + CALL REDGET(ITYP,NITMA,FLOTT,TEXT20,DFLOTT) + IF(ITYP.NE.-1) CALL XABORT('APX: OUTPUT INTEGER EXPECTED.') + ITYP=1 + CALL hdf5_read_data(IPAPX,"NCALS",NITMA) + CALL REDPUT(ITYP,NITMA,FLOTT,TEXT20,DFLOTT) + CALL REDGET(ITYP,NITMA,FLOTT,TEXT20,DFLOTT) + IF((ITYP.NE.3).OR.(TEXT20.NE.';')) THEN + CALL XABORT('APX: ; CHARACTER EXPECTED.') + ENDIF + ENDIF + GO TO 390 +*---- +* APEX CONCATENATION. +*---- + 360 DO 370 I=2,NENTRY + IF(.NOT.C_ASSOCIATED(IPRHS(I))) GO TO 370 + NG=0 + CALL APXTOC(IPRHS(I),IMPX,NLAM,NREA,NBISO,NBMAC,NMIL,NPARR,NVP, + 1 NISOF,NISOP,NISOS,NCALR,NG,NISOTS,NSURFD,NPRC) + IF(IMPX.GT.0) WRITE(6,470) NCALS+1,NCALS+NCALR +* --------------------------------------------------------------- + CALL APXCAT(IPAPX,IPRHS(I),NORIG,NPAR,NCALS,MUPLET,LGNEW,LWARN) +* --------------------------------------------------------------- + NCALS=NCALS+NCALR + 370 CONTINUE + CALL hdf5_write_data(IPAPX,"/NCALS",NCALS) + IF(IMPX.GT.0) THEN + CALL APXTOC(IPAPX,IMPX,NLAM,NREA,NBISO,NBMAC,NMIL,NPAR,NVP, + 1 NISOF,NISOP,NISOS,NCALS,NG,NISOTS,NSURFD,NPRC) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 390 DEALLOCATE(IPRHS) + IF(IMPX.GT.3) THEN + WRITE(6,'(/25H APX: APEX FILE CONTENTS:)') + FLUSH(6) + CALL hdf5_list(IPAPX,'') + WRITE(6,'()') + ENDIF + RETURN +* + 400 FORMAT(/14H APX: VERSION=,A) + 420 FORMAT(/1X,43(1H*)/34H * APX: ELEMENTARY CALCULATION NB.,I8, + 1 2H */1X,43(1H*)) + 430 FORMAT(/41H APX: RECOVER INFORMATION RELATED TO TIME,1P,E12.4, + 1 8H E+8 S (,E12.4,32H DAY) FROM LCM DIRECTORY NAMED ',A12,2H'.) + 440 FORMAT(28H APX: SET GLOBAL PARAMETER ',A,3H' =,1P,E12.4) + 450 FORMAT(28H APX: SET GLOBAL PARAMETER ',A,3H' =,I10) + 460 FORMAT(28H APX: SET GLOBAL PARAMETER ',A,5H' = ',A12,1H') + 470 FORMAT(/1X,55(1H*)/35H * APX: ELEMENTARY CALCULATIONS NB.,I8, + 1 3H TO,I8,2H */1X,55(1H*)) + END diff --git a/Dragon/src/APXCA2.f b/Dragon/src/APXCA2.f new file mode 100644 index 0000000..e541cc8 --- /dev/null +++ b/Dragon/src/APXCA2.f @@ -0,0 +1,405 @@ +*DECK APXCA2 + SUBROUTINE APXCA2(IPAPX,IPEDIT,NREA,NISO,NMAC,NED,NPRC,NG,NL, + 1 ITRANC,NALBP,IMC,NMIL,NBISO,ICAL,IMPX,FNORM,NMILNR,NISFS,NISPS, + 2 VOLMIL,FLXMIL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover the cross sections of an elementary calculation in the Apex +* file. +* +*Copyright: +* Copyright (C) 2025 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPAPX pointer to the Apex file. +* IPEDIT pointer to the edition object (L_EDIT signature). +* NREA number of requested reactions. +* NISO number of particularized isotopes. +* NMAC number of macros. +* NED number of additional edition cross sections. +* NPRC number of delayed neutron precursors. +* NG number of condensed energy groups. +* NL number of Legendre orders. +* ITRANC type of transport correction. +* NALBP number of physical albedos per energy group. +* IMC type of macro-calculation (1 for diffusion or SPN; +* 2 other method). +* NMIL number of mixtures in the Apex file. +* NBISO number of isotopes in the condensed microlib of the edition +* object. A given isotope may appear in many mixtures. +* ICAL index of the current elementary calculation. +* FNORM flux normalization factor. +* IMPX print parameter. +* +*Parameters: output +* NMILNR number of mixtures with delayed neutron data. +* NISFS number of particularized fissile isotopes. +* NISPS number of particularized fission products. +* VOLMIL mixture volumes. +* FLXMIL averaged flux of mixtures. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPAPX,IPEDIT + INTEGER NREA,NISO,NMAC,NED,NPRC,NG,NL,ITRANC,NALBP,IMC,NMIL,NBISO, + 1 ICAL,IMPX,NMILNR,NISFS,NISPS + REAL FNORM,VOLMIL(NMIL),FLXMIL(NMIL,NG) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPEDIT,KPEDIT,IPTEMP + CHARACTER RECNAM*80,RECNAM2*80,TEXT8*8,TEXT12*12,HSMG*131 + LOGICAL EXIST,LSPH + DOUBLE PRECISION CONV +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MIX,ITYPE + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISONAM + REAL, ALLOCATABLE, DIMENSION(:) :: OVERV,WORKD,WORK1,WORK2,DEN, + 1 DENISO,ENRGS,VOLMIX,WORK1D + REAL, ALLOCATABLE, DIMENSION(:,:) :: DNUSIG,DCHI,SPH,CONCES,DECAYC + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:,:) :: IPERM + CHARACTER(LEN=4), ALLOCATABLE, DIMENSION(:) :: TYPISO + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: NOMISO,NOMMAC + CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: NOMREA +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(ISONAM(3,NBISO),MIX(NBISO),ITYPE(NBISO)) + ALLOCATE(OVERV(NG),DNUSIG(NG,NPRC+1),DCHI(NG,NPRC),WORKD(NPRC), + 1 WORK1(NG*NMIL+1),WORK2(NG),DEN(NBISO),DENISO(NISO), + 2 CONCES(NISO,NMIL),IPERM(NISO,NMIL),VOLMIX(NMIL)) +* + CONV=1.0D6 ! convert MeV to eV in H-FACTOR +*---- +* RECOVER INFORMATION FROM THE 'explicit' GROUP. +*---- + IF(NREA.GT.0) CALL hdf5_read_data(IPAPX,"/explicit/REANAME", + 1 NOMREA) + IF(NMAC.GT.0) CALL hdf5_read_data(IPAPX,"/explicit/MACNAME", + 1 NOMMAC) + IF(NISO.GT.0) THEN + CALL hdf5_read_data(IPAPX,"/physconst/ISOTA",NOMISO) + CALL hdf5_read_data(IPAPX,"/physconst/ISOTYP",TYPISO) + ENDIF +*---- +* SAVE INFORMATION TO THE 'physconst' GROUP. +*---- + IF(ICAL.EQ.1) THEN + ALLOCATE(ENRGS(NG+1)) + CALL LCMLEN(IPEDIT,'ENERGY',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + CALL LCMSIX(IPEDIT,'MACROLIB',1) + CALL LCMLEN(IPEDIT,'ENERGY',ILONG,ITYLCM) + IF(ILONG.NE.NG+1) CALL XABORT('APXCA2: BAD VALUE OF NG(1).') + CALL LCMGET(IPEDIT,'ENERGY',ENRGS) + CALL LCMSIX(IPEDIT,' ',2) + ELSE + IF(ILONG.NE.NG+1) CALL XABORT('APXCA2: BAD VALUE OF NG(2).') + CALL LCMGET(IPEDIT,'ENERGY',ENRGS) + ENDIF + ENRGS(:NG+1)=ENRGS(:NG+1)*1.0E-6 + CALL hdf5_write_data(IPAPX,"/physconst/ENRGS",ENRGS) + DEALLOCATE(ENRGS) + CALL LCMSIX(IPEDIT,'MACROLIB',1) + CALL LCMLEN(IPEDIT,'VOLUME',ILONG,ITYLCM) + IF(ILONG.NE.NMIL) CALL XABORT('APXCA2: INCORRECT VOLUME.') + CALL LCMGET(IPEDIT,'VOLUME',VOLMIL) + CALL LCMSIX(IPEDIT,' ',2) + ENDIF +*---- +* RECOVER INVERSE OF SPH EQUIVALENCE FACTORS. +*---- + CALL LCMSIX(IPEDIT,'MACROLIB',1) + CALL LCMGET(IPEDIT,'VOLUME',VOLMIX) + JPEDIT=LCMGID(IPEDIT,'GROUP') + LSPH=.FALSE. + ALLOCATE(SPH(NMIL,NG)) + DO 80 IGR=1,NG + KPEDIT=LCMGIL(JPEDIT,IGR) + CALL LCMLEN(KPEDIT,'NSPH',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + LSPH=.TRUE. + CALL LCMGET(KPEDIT,'NSPH',WORK1) + DO 70 IMIL=1,NMIL + SPH(IMIL,IGR)=1.0/WORK1(IMIL) + 70 CONTINUE + ELSE + SPH(:NMIL,IGR)=1.0 + ENDIF + 80 CONTINUE + CALL LCMSIX(IPEDIT,' ',2) +*---- +* CREATE A SPH-UNCORRECTED MICROLIB. +*---- + CALL LCMOP(IPTEMP,'*TEMPORARY*',0,1,0) + CALL LCMEQU(IPEDIT,IPTEMP) + IF(LSPH) THEN + IF(IMC.EQ.0) CALL XABORT('APXCA2: UNDEFINED TYPE OF SPH.') + NW=1 ! NTOT1 cross section present + CALL SPHCMI(IPTEMP,0,IMC,NMIL,NBISO,NG,NL,NW,NED,NPRC,NALBP,SPH) + ENDIF + DEALLOCATE(SPH) +*---- +* FIND THE NUMBER AND NAMES OF THE ISOTOPES IN THE OUTPUT TABLES. +*---- + IF(NISO.GT.0) THEN + IPERM(:NISO,:NMIL)=C_NULL_PTR + CONCES(:NISO,:NMIL)=0.0 + IF(NBISO.GT.0) THEN + ALLOCATE(IPISO(NBISO)) + CALL LCMGET(IPTEMP,'ISOTOPESUSED',ISONAM) + CALL LCMGET(IPTEMP,'ISOTOPESMIX',MIX) + CALL LCMGET(IPTEMP,'ISOTOPESDENS',DEN) + CALL LCMGET(IPEDIT,'ISOTOPESTYPE',ITYPE) + CALL LIBIPS(IPTEMP,NBISO,IPISO) + DO IBISO=1,NBISO + IMIL=MIX(IBISO) + IF(IMIL.EQ.0) CYCLE + WRITE(TEXT12,'(3A4)') (ISONAM(I0,IBISO),I0=1,3) + DO ISO=1,NISO + IF(NOMISO(ISO).EQ.TEXT12(:8)) THEN + IPERM(ISO,IMIL)=IPISO(IBISO) + CONCES(ISO,IMIL)=DEN(IBISO) + CYCLE + ENDIF + ENDDO + ENDDO + DEALLOCATE(IPISO) + ENDIF + DO ISO=1,NISO + DO IMIL=1,NMIL + IF(C_ASSOCIATED(IPERM(ISO,IMIL))) GO TO 10 + ENDDO + WRITE(HSMG,'(17HAPXCA2: ISOTOPE '',A8,7H'' (ISO=,I8,3H) I, + 1 32HS NOT AVAILABLE IN THE MICROLIB.)') NOMISO(ISO),ISO + CALL XABORT(HSMG) + 10 CONTINUE + ENDDO +*---- +* RECOVER RADIOACTIVE DECAY CONSTANTS. +*---- + IF(ICAL.EQ.1) THEN + ALLOCATE(DECAYC(1,NISO),IPISO(NBISO)) + CALL LIBIPS(IPTEMP,NBISO,IPISO) + DECAYC(1,:NISO)=0.0 + DO 40 ISO=1,NISO + IISOTS=0 + DO 20 IBISO=1,NBISO + IISOTS=ISO + IF(MIX(IBISO).EQ.0) GO TO 20 + WRITE(TEXT12,'(3A4)') (ISONAM(I0,IBISO),I0=1,3) + IF(TEXT12(:8).EQ.NOMISO(ISO)) GO TO 30 + 20 CONTINUE + CALL XABORT('APXCA2: CANNOT FIND ISOTOPE '//NOMISO(ISO)//'.') + 30 JPEDIT=IPISO(IISOTS) + IF(.NOT.C_ASSOCIATED(JPEDIT)) GO TO 40 + CALL LCMLEN(JPEDIT,'DECAY',ILONG,ITYLCM) + IF(ILONG.EQ.1) CALL LCMGET(JPEDIT,'DECAY',DECAYC(1,ISO)) + 40 CONTINUE + DECAYC(1,:NISO)=DECAYC(1,:NISO)*1.0E-8 + CALL hdf5_write_data(IPAPX,"/physconst/DECAYC",DECAYC) + DEALLOCATE(IPISO,DECAYC) + ENDIF + ENDIF +*---- +* FILL miscellaneous GROUP +*---- + WRITE(RECNAM,'(4Hcalc,I8,15H/miscellaneous/)') ICAL + CALL LCMSIX(IPTEMP,'MACROLIB',1) + NVDIV=0 + CALL LCMLEN(IPTEMP,'K-EFFECTIVE',ILONG,ITYLCM) + IF(ILONG.EQ.1) THEN + CALL LCMGET(IPTEMP,'K-EFFECTIVE',FLOTT) + CALL hdf5_write_data(IPAPX,TRIM(RECNAM)//"KEFF",FLOTT) + ENDIF + CALL LCMLEN(IPTEMP,'K-INFINITY',ILONG,ITYLCM) + IF(ILONG.EQ.1) THEN + CALL LCMGET(IPTEMP,'K-INFINITY',FLOTT) + CALL hdf5_write_data(IPAPX,TRIM(RECNAM)//"KINF",FLOTT) + ENDIF + CALL LCMLEN(IPTEMP,'B2 B1HOM',ILONG,ITYLCM) + IF(ILONG.EQ.1) THEN + CALL LCMGET(IPTEMP,'B2 B1HOM',B2) + ELSE + B2=0.0 + ENDIF + IF(B2.EQ.0.0) B2=1.0E-10 + CALL hdf5_write_data(IPAPX,TRIM(RECNAM)//"B2",B2) + CALL LCMSIX(IPTEMP,' ',2) +*---- +* LOOP OVER APEX MIXTURES. +*---- + NMILNR=0 + DO 500 IMIL=1,NMIL + IF(NMIL.EQ.1) THEN + WRITE(RECNAM,'(4Hcalc,I8,4H/xs/)') ICAL + ELSE + WRITE(RECNAM,'(4Hcalc,I8,3H/xs,I8,1H/)') ICAL,IMIL + ENDIF + CALL hdf5_create_group(IPAPX,RECNAM) +*---- +* RECOVER APEX VOLUMES AND INTEGRATED FLUXES. +*---- + CALL hdf5_write_data(IPAPX,TRIM(RECNAM)//"MEDIA_VOLUME", + 1 VOLMIX(IMIL)) + WORK2(:NG)=0.0 + CALL LCMSIX(IPTEMP,'MACROLIB',1) + JPEDIT=LCMGID(IPTEMP,'GROUP') + DO IGR=1,NG + KPEDIT=LCMGIL(JPEDIT,IGR) + CALL LCMLEN(KPEDIT,'FLUX-INTG',ILONG,ITYLCM) + IF(ILONG.EQ.0) CYCLE + ALLOCATE(WORK1D(NMIL)) + CALL LCMGET(KPEDIT,'FLUX-INTG',WORK1D) + WORK2(IGR)=WORK1D(IMIL) + DEALLOCATE(WORK1D) + ENDDO + CALL hdf5_write_data(IPAPX,TRIM(RECNAM)//"FLUX",WORK2) + CALL LCMSIX(IPTEMP,' ',2) +*---- +* RECOVER APEX CROSS SECTIONS +*---- + IF(NISO.GT.0) THEN + CALL hdf5_create_group(IPAPX,TRIM(RECNAM)//"mic") + RECNAM2=TRIM(RECNAM)//"mic/CONC" + CALL hdf5_write_data(IPAPX,TRIM(RECNAM2),CONCES(:NISO,IMIL)) + ENDIF + CALL hdf5_create_group(IPAPX,TRIM(RECNAM)//"mac") + DO IREA=1,NREA + CALL APXSX2(IPAPX,IPTEMP,NG,NL,NMAC,NISO,NMIL,IMIL,ITRANC, + 1 RECNAM,NOMMAC,TYPISO,NOMREA(IREA),IPERM(1,IMIL),CONCES(1,IMIL), + 2 B2) + ENDDO + IF(IMPX.GT.0) THEN + CALL hdf5_list(IPAPX,TRIM(RECNAM)) + IF(NISO.GT.0) CALL hdf5_list(IPAPX,TRIM(RECNAM)//"mic") + CALL hdf5_list(IPAPX,TRIM(RECNAM)//"mac") + ENDIF + IOR=0 + IOI=0 + IIS=0 + NISMAX=NMAC +* + CALL LCMSIX(IPTEMP,'MACROLIB',1) + JPEDIT=LCMGID(IPTEMP,'GROUP') + DO 150 IGR=1,NG + KPEDIT=LCMGIL(JPEDIT,IGR) +*---- +* RECOVER THE NEUTRON FLUX. +*---- + CALL LCMGET(KPEDIT,'FLUX-INTG',WORK1) + IF(FNORM.NE.1.0) THEN + FLXMIL(IMIL,IGR)=WORK1(IMIL)*FNORM*1.0E13 + ELSE + FLXMIL(IMIL,IGR)=WORK1(IMIL) + ENDIF +*---- +* RECOVER DELAYED NEUTRON INFORMATION. +*---- + CALL LCMLEN(KPEDIT,'NUSIGF',ILONG,ITYLCM) + IF((NPRC.GT.0).AND.(ILONG.NE.0)) THEN + CALL LCMGET(KPEDIT,'NUSIGF',WORK1) + DNUSIG(IGR,NPRC+1)=WORK1(IMIL) + CALL LCMGET(KPEDIT,'OVERV',WORK1) + OVERV(IGR)=WORK1(IMIL) + DO 90 IPRC=1,NPRC + WRITE(TEXT12,'(6HNUSIGF,I2.2)') IPRC + CALL LCMGET(KPEDIT,TEXT12,WORK1) + DNUSIG(IGR,IPRC)=WORK1(IMIL) + WRITE(TEXT12,'(3HCHI,I2.2)') IPRC + CALL LCMGET(KPEDIT,TEXT12,WORK1) + DCHI(IGR,IPRC)=WORK1(IMIL) + 90 CONTINUE + ELSE + DNUSIG(IGR,:NPRC+1)=0.0 + ENDIF + 150 CONTINUE + CALL LCMSIX(IPTEMP,' ',2) +*---- +* STORE INFORMATION IN THE calc_id/kinetics GROUP. +*---- + IF(NPRC.GT.0) THEN + EXIST=.FALSE. + DO 455 IPRC=1,NPRC + DO 450 IGR=1,NG + EXIST=EXIST.OR.(DNUSIG(IGR,IPRC).NE.0.0) + 450 CONTINUE + 455 CONTINUE + IF(EXIST) THEN + NMILNR=NMILNR+1 + RECNAM2=TRIM(RECNAM)//"kinetics/" + CALL hdf5_create_group(IPAPX,TRIM(RECNAM2)) + CALL hdf5_write_data(IPAPX,TRIM(RECNAM2)//"NBGRD",NPRC) + CALL hdf5_write_data(IPAPX,TRIM(RECNAM2)//"CHIDA",DCHI) + CALL hdf5_write_data(IPAPX,TRIM(RECNAM2)//"INVELA",OVERV) + CALL LCMSIX(IPTEMP,'MACROLIB',1) + CALL LCMGET(IPTEMP,'LAMBDA-D',WORKD) + CALL LCMSIX(IPTEMP,' ',2) + CALL hdf5_write_data(IPAPX,TRIM(RECNAM2)//"LAMBDA",WORKD) + TGENRS=0.0 + DENOM=0.0 + DO 460 IGR=1,NG + TGENRS=TGENRS+OVERV(IGR)*FLXMIL(IMIL,IGR) + DENOM=DENOM+DNUSIG(IGR,NPRC+1)*FLXMIL(IMIL,IGR) + 460 CONTINUE + TGENRS=TGENRS/DENOM + DO 480 IPRC=1,NPRC + WORKD(IPRC)=0.0 + DO 470 IGR=1,NG + WORKD(IPRC)=WORKD(IPRC)+DNUSIG(IGR,IPRC)*FLXMIL(IMIL,IGR) + 470 CONTINUE + WORKD(IPRC)=WORKD(IPRC)/DENOM + 480 CONTINUE + CALL hdf5_write_data(IPAPX,TRIM(RECNAM2)//"BETADA",WORKD) + CALL hdf5_write_data(IPAPX,TRIM(RECNAM2)//"NGENT",TGENRS) + IF(IMPX.GT.0) CALL hdf5_list(IPAPX,TRIM(RECNAM2)) + ENDIF + ENDIF + 500 CONTINUE +*---- +* COMPUTE NISFS AND NISPS +*---- + NISFS=0 + NISPS=0 + DO 530 ISO=1,NISO + DO 510 IBISO=1,NBISO + WRITE(TEXT8,'(2A4)') (ISONAM(I0,IBISO),I0=1,2) + IF(NOMISO(ISO).EQ.TEXT8) THEN + ITY=ITYPE(IBISO) + GO TO 520 + ENDIF + 510 CONTINUE + GO TO 530 + 520 IF(ITY.EQ.2) THEN + NISFS=NISFS+1 + ELSE IF(ITY.EQ.3) THEN + NISPS=NISPS+1 + ENDIF + 530 CONTINUE + CALL LCMCL(IPTEMP,2) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + IF(NISO.GT.0) DEALLOCATE(TYPISO,NOMISO) + IF(NMAC.GT.0) DEALLOCATE(NOMMAC) + IF(NREA.GT.0) DEALLOCATE(NOMREA) + DEALLOCATE(VOLMIX,IPERM,CONCES,DENISO,DEN,WORK2,WORK1,WORKD,DCHI, + 1 DNUSIG,OVERV,ITYPE,MIX,ISONAM) + RETURN + END diff --git a/Dragon/src/APXCAL.f b/Dragon/src/APXCAL.f new file mode 100644 index 0000000..eb6f994 --- /dev/null +++ b/Dragon/src/APXCAL.f @@ -0,0 +1,176 @@ +*DECK APXCAL + SUBROUTINE APXCAL(IMPX,IPAPX,IPDEPL,IPEDIT,HEQUI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Store the results of an elementary calculation in the Apex file +* +*Copyright: +* Copyright (C) 2025 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IMPX print parameter. +* IPAPX pointer to the Apex file. +* IPDEPL pointer to the burnup object (L_BURNUP signature). +* IPEDIT pointer to the edition object (L_EDIT signature). +* HEQUI keyword of SPH-factor set in the Apex file. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPAPX,IPDEPL,IPEDIT,IPSPH + INTEGER IMPX + CHARACTER(LEN=80) HEQUI +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + INTEGER IPAR(NSTATE) + REAL BIRRAD(2) + INTEGER RANK,TYPE,NBYTE,DIMSR(5) + CHARACTER RECNAM*80,RECNAM2*80,CDIRO*12,HSMG*131 +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: VOLMIL,WORK1 + REAL, ALLOCATABLE, DIMENSION(:,:) :: FLXMIL,RVAL0 +* + CALL LCMGTC(IPEDIT,'LAST-EDIT',12,CDIRO) + CALL LCMSIX(IPEDIT,CDIRO,1) + CALL LCMLEN(IPEDIT,'STATE-VECTOR',ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + CALL LCMGET(IPEDIT,'STATE-VECTOR',IPAR) + NBISO=IPAR(2) + NED=IPAR(13) + NPRC=IPAR(19) + NDFI=IPAR(20) + ELSE + NBISO=0 + NDFI=0 + ENDIF + CALL LCMSIX(IPEDIT,'MACROLIB',1) + CALL LCMGET(IPEDIT,'STATE-VECTOR',IPAR) + NG=IPAR(1) + NMIL=IPAR(2) + NL=IPAR(3) + IF(IPAR(4).GT.1) CALL XABORT('APXCAL: CANNOT PROCESS MULTIPLE FI' + 1 //'SSION SPECTRA.') + NED=IPAR(5) + ITRANC=IPAR(6) + NPRC=IPAR(7) + NALBP=IPAR(8) + IDF=IPAR(12) + CALL LCMLEN(IPEDIT,'SPH',ILEN,ITYLCM) + IF(ILEN.NE.0) THEN + IPSPH=LCMGID(IPEDIT,'SPH') + CALL LCMGET(IPSPH,'STATE-VECTOR',IPAR) + IMC=IPAR(6) + ELSE + IMC=0 + ENDIF + CALL hdf5_info(IPAPX,"/NCALS",RANK,TYPE,NBYTE,DIMSR) + IF(RANK.EQ.99) THEN + NCALS=0 + ELSE + CALL hdf5_read_data(IPAPX,"/NCALS",NCALS) + ENDIF + ICAL=NCALS+1 + CALL hdf5_write_data(IPAPX,"/NCALS",ICAL) + CALL LCMSIX(IPEDIT,' ',2) + WRITE(RECNAM,'(4Hcalc,I8,1H/)') ICAL + IF(IMPX.GT.0) WRITE(6,'(/19H APXCAL: NEW GROUP ,A)') TRIM(RECNAM) + CALL hdf5_create_group(IPAPX,RECNAM) + CALL hdf5_create_group(IPAPX,TRIM(RECNAM)//"miscellaneous/") +*---- +* RECOVER THE FLUX NORMALIZATION FACTOR. +*---- + IF(C_ASSOCIATED(IPDEPL)) THEN + CALL LCMGET(IPDEPL,'BURNUP-IRRAD',BIRRAD) + BURN=BIRRAD(1) + CALL LCMLEN(IPDEPL,'FLUX-NORM',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + WRITE(HSMG,'(40HAPXCAL: THE ''FLUX-NORM'' RECORD IS NOT SE, + 1 20HT FOR BURNUP STEP AT,E12.5,14H MW-DAY/TONNE.)') BURN + CALL XABORT(HSMG) + ENDIF + CALL LCMGET(IPDEPL,'FLUX-NORM',FNORM) + IF(IMPX.GT.0) WRITE(6,100) FNORM,BURN + ELSE + FNORM=1.0 + IF(IMPX.GT.0) WRITE(6,110) + ENDIF +*---- +* RECOVER THE CROSS SECTIONS. +*---- + NISO=0 + CALL hdf5_info(IPAPX,"/explicit/ISONAME",RANK,TYPE,NBYTE,DIMSR) + IF(RANK.NE.99) NISO=DIMSR(1) + NMAC=0 + CALL hdf5_info(IPAPX,"/explicit/MACNAME",RANK,TYPE,NBYTE,DIMSR) + IF(RANK.NE.99) NMAC=DIMSR(1) + NREA=0 + CALL hdf5_info(IPAPX,"/explicit/REANAME",RANK,TYPE,NBYTE,DIMSR) + IF(RANK.NE.99) NREA=DIMSR(1) + ALLOCATE(VOLMIL(NMIL),FLXMIL(NMIL,NG)) + CALL APXCA2(IPAPX,IPEDIT,NREA,NISO,NMAC,NED,NPRC,NG,NL,ITRANC, + 1 NALBP,IMC,NMIL,NBISO,ICAL,IMPX,FNORM,NMILNR,NISFS,NISPS,VOLMIL, + 2 FLXMIL) +*---- +* RECOVER DISCONTINUITY FACTOR INFORMATION. +*---- + IF((IDF.EQ.2).OR.(IDF.EQ.3).OR.(NALBP.GT.0)) THEN + CALL APXIDF(IPAPX,IPEDIT,NG,NMIL,ICAL,IDF,NALBP,FNORM,VOLMIL, + 1 FLXMIL) + ENDIF +*---- +* RECOVER THE FISSION YIELDS. +*---- + IF((ICAL.EQ.1).AND.(NISFS*NISPS.GT.0)) THEN + CALL APXGEY(IPAPX,IPEDIT,NISO,NG,NMIL,NBISO,NDFI,NISFS,NISPS) + ENDIF +*---- +* RECOVER SPH FACTOR INFORMATION. +*---- + CALL LCMSIX(IPEDIT,'MACROLIB',1) + CALL LCMLEN(IPEDIT,'SPH',ILEN,ITYLCM) + CALL LCMSIX(IPEDIT,' ',2) + CALL LCMSIX(IPEDIT,' ',2) + IF(ILEN.NE.0) THEN + IF(HEQUI.EQ.' ') HEQUI='default' + ALLOCATE(WORK1(NG),RVAL0(NG,NMIL)) + CALL SAPSPH(IPEDIT,NG,NMIL,1,NG,RVAL0) + IF(NMIL.EQ.1) THEN + WORK1(:NG)=RVAL0(:NG,1) + WRITE(RECNAM,'(4Hcalc,I8,14H/xs/MEDIA_SPH/)') ICAL + CALL hdf5_create_group(IPAPX,TRIM(RECNAM)) + WRITE(RECNAM2,'(A,A)') TRIM(RECNAM),TRIM(HEQUI) + CALL hdf5_write_data(IPAPX,TRIM(RECNAM2),WORK1) + ELSE + DO IBM=1,NMIL + WORK1(:NG)=RVAL0(:NG,IBM) + WRITE(RECNAM,'(4Hcalc,I8,3H/xs,I8,11H/MEDIA_SPH/)') ICAL,IBM + CALL hdf5_create_group(IPAPX,TRIM(RECNAM)) + WRITE(RECNAM2,'(A,A)') TRIM(RECNAM),TRIM(HEQUI) + CALL hdf5_write_data(IPAPX,TRIM(RECNAM2),WORK1) + ENDDO + ENDIF + DEALLOCATE(RVAL0,WORK1) + ENDIF + DEALLOCATE(FLXMIL,VOLMIL) + RETURN +* + 100 FORMAT(45H APXCAL: NORMALIZE THE FLUX WITH THE FACTOR =,1P,E12.5, + 1 26H TAKEN FROM BURNUP STEP AT,E12.5,14H MW-DAY/TONNE.) + 110 FORMAT(36H APXCAL: THE FLUX IS NOT NORMALIZED.) + END diff --git a/Dragon/src/APXCAT.f b/Dragon/src/APXCAT.f new file mode 100644 index 0000000..78ae390 --- /dev/null +++ b/Dragon/src/APXCAT.f @@ -0,0 +1,258 @@ +*DECK APXCAT + SUBROUTINE APXCAT(IPAPX,IPRHS,NORIG,NPAR,NCAL,MUPCPO,LGNCPO,LWARN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To catenate a RHS Apex file into the output Apex file. +* +*Copyright: +* Copyright (C) 2025 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPAPX pointer to the output Apex file. +* IPRHS pointer to the rhs Apex file (contains the new calculations). +* NORIG index of the elementary calculation associated to the +* father node in the parameter tree. +* NPAR number of global parameters in the output Apex file. +* NCAL initial number of calculations in LHS Apex file. +* MUPCPO tuple of the new global parameters in the output Apex file. +* LGNCPO LGNEW value of the new global parameters in the output +* Apex file. +* LWARN logical used in case if an elementary calculation in the RHS +* is already present in Apex file. If LWARN=.true. a warning is +* send and the Apex file values are kept otherwise XABORT is +* called (default). +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPAPX,IPRHS + INTEGER NORIG,NPAR,NCAL,MUPCPO(NPAR) + LOGICAL LGNCPO(NPAR),LWARN +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MAXPAR=50) + INTEGER RANK,TYPE,NBYTE,DIMSR(5) + INTEGER MUPLET(2*MAXPAR),MUPRHS(2*MAXPAR) + CHARACTER HSMG*131,RECNAM*80,RECNA2*80,TEXT4*4,TEXT12*12 + LOGICAL COMTRE,LGERR,LGNEW(MAXPAR) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IORRHS,JDEBAR,JARBVA,VINTE, + 1 IDEBAR,IARBVA,IORIGI + REAL, ALLOCATABLE, DIMENSION(:) :: VREAL + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: PARFMT_RHS + CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: VCHAR + CHARACTER(LEN=80), ALLOCATABLE, DIMENSION(:) :: PARNAM_RHS, + 1 PARNAM_LHS +* + IF(NPAR.GT.MAXPAR) CALL XABORT('APXCAT: MAXPAR OVERFLOW.') + NGR=0 + CALL APXTOC(IPRHS,IMPX,NLAM,NREA,NBISO,NBMAC,NMILR,NPARR,NVPR, + 1 NISOF,NISOP,NISOS,NCALR,NGR,NISOTS,NSURFD,NPRC) + IF(NCALR.EQ.0) THEN + CALL XABORT('APXCAT: NO CALCULATION IN RHS APEX FILE.') + ELSE IF(NPARR.GT.NPAR) THEN + WRITE(HSMG,'(42HAPXCAT: ELEMENTARY CALCULATION WITH AN INV, + 1 31HALIB NB. OF GLOBAL PARAMETERS =,I7,3H GT,I7,1H.)') NPARR, + 2 NPAR + CALL XABORT(HSMG) + ENDIF + NVPO=0 ! initial number of nodes in LHS Apex file + CALL hdf5_read_data(IPAPX,"NCALS",NCAL) + IF(NCAL.GT.0) THEN + NG=0 + CALL APXTOC(IPAPX,0,NLAM,NREA,NBISO,NBMAC,NMIL,NPAR1,NVPO, + 1 NISOF,NISOP,NISOS,NCAL,NG,NISOTS,NSURFD,NPRC) + IF(NGR.NE.NG) THEN + WRITE(HSMG,'(42HAPXCAT: ELEMENTARY CALCULATION WITH AN INV, + 1 20HALIB NB. OF GROUPS =,I7,3H NE,I7,1H.)') NGR,NG + CALL XABORT(HSMG) + ELSE IF(NMILR.NE.NMIL) THEN + WRITE(HSMG,'(42HAPXCAT: ELEMENTARY CALCULATION WITH AN INV, + 1 22HALIB NB. OF MIXTURES =,I7,3H NE,I7,1H.)') NMILR,NMIL + CALL XABORT(HSMG) + ELSE IF(NPAR1.NE.NPAR) THEN + WRITE(HSMG,'(42HAPXCAT: ELEMENTARY CALCULATION WITH AN INV, + 1 31HALIB NB. OF GLOBAL PARAMETERS =,I7,3H NE,I7,1H.)') NPAR1, + 2 NPAR + CALL XABORT(HSMG) + ENDIF + ENDIF +*---- +* MAIN LOOP OVER THE NCALR ELEMENTARY CALCULATIONS OF THE RHS APEX FILE +*---- + IDEM=0 + NCALS=NCAL + DO 170 ICAL=1,NCALR +*---- +* COMPUTE THE MUPLET VECTOR FROM THE RHS APEX FILE +*---- + CALL hdf5_read_data(IPRHS,"/paramtree/DEBTREE",JDEBAR) + CALL hdf5_read_data(IPRHS,"/paramtree/TREEVAL",JARBVA) + CALL hdf5_read_data(IPRHS,"/paramtree/ORIGIN",IORRHS) + DO 30 I=NVPR-NCALR+1,NVPR + IF(JDEBAR(I+1).EQ.ICAL) THEN + I0=I + GO TO 40 + ENDIF + 30 CONTINUE + CALL XABORT('APXCAT: MUPLET ALGORITHM FAILURE 1.') + 40 MUPRHS(NPAR)=JARBVA(I0) + DO 65 IPAR=NPAR-1,1,-1 + DO 50 I=1,NVPR-NCALR + IF(JDEBAR(I+1).GT.I0) THEN + I0=I + GO TO 60 + ENDIF + 50 ENDDO + CALL XABORT('APXCAT: MUPLET ALGORITHM FAILURE 2.') + 60 MUPRHS(IPAR)=JARBVA(I0) + 65 CONTINUE + DEALLOCATE(JARBVA,JDEBAR) +*---- +* RECOVER THE GLOBAL PARAMETERS +*---- + DO 70 I=1,NPAR + MUPLET(I)=MUPCPO(I) + LGNEW(I)=LGNCPO(I) + 70 CONTINUE + CALL hdf5_read_data(IPAPX,"/paramdescrip/PARNAM",PARNAM_LHS) + CALL hdf5_read_data(IPRHS,"/paramdescrip/PARFMT",PARFMT_RHS) + CALL hdf5_read_data(IPRHS,"/paramdescrip/PARNAM",PARNAM_RHS) + DO 100 IPAR=1,NPARR + DO 80 I0=1,NPAR + IF(PARNAM_RHS(IPAR).EQ.PARNAM_LHS(I0)) THEN + IPARN=I0 + GO TO 90 + ENDIF + 80 CONTINUE + CALL XABORT('APXCAT: UNABLE TO FIND '//PARNAM_RHS(IPAR)//'.') + 90 WRITE(RECNAM,'(17H/paramvalues/PVAL,I8)') IPAR + IVAL=MUPRHS(IPAR) + IF(PARFMT_RHS(IPAR).EQ.'FLOTTANT') THEN + CALL hdf5_read_data(IPRHS,TRIM(RECNAM),VREAL) + FLOTT=VREAL(IVAL) + DEALLOCATE(VREAL) + ELSE IF(PARFMT_RHS(IPAR).EQ.'ENTIER') THEN + CALL hdf5_read_data(IPRHS,TRIM(RECNAM),VINTE) + NITMA=VINTE(IVAL) + DEALLOCATE(VINTE) + ELSE IF(PARFMT_RHS(IPAR).EQ.'CHAINE') THEN + CALL hdf5_read_data(IPRHS,TRIM(RECNAM),VCHAR) + TEXT12=VCHAR(IVAL) + DEALLOCATE(VCHAR) + ENDIF + CALL APXPAV(IPAPX,IPARN,NPAR,PARFMT_RHS(IPAR),FLOTT,NITMA, + 1 TEXT12,MUPLET(IPARN),LGNEW(IPARN)) + 100 CONTINUE + DEALLOCATE(PARNAM_RHS,PARFMT_RHS,PARNAM_LHS) +*---- +* UPDATE THE PARAMETER TREE IN THE OUTPUT APEX FILE +*---- + IF(NVPO.EQ.0) THEN + MAXNVP=20*(NPAR+1) + ALLOCATE(IDEBAR(MAXNVP+1),IARBVA(MAXNVP)) + IDEBAR(:MAXNVP+1)=0 + IARBVA(:MAXNVP)=0 + IARBVA=0 + DO 140 I=1,NPAR + IDEBAR(I)=I+1 + IARBVA(I+1)=1 + 140 CONTINUE + IDEBAR(NPAR+1)=NPAR+2 + IDEBAR(NPAR+2)=1 + NCALS=1 + NVPNEW=NPAR+1 + ELSE + CALL hdf5_read_data(IPAPX,"/paramtree/DEBTREE",JDEBAR) + CALL hdf5_read_data(IPAPX,"/paramtree/TREEVAL",JARBVA) + DO 150 IPAR=1,NPAR + IF(LGNEW(IPAR)) THEN + II=IPAR + GO TO 160 + ENDIF + 150 CONTINUE + II=NPAR+1 + 160 LGERR=COMTRE(NPAR,NVPO,JARBVA,JDEBAR,MUPLET,KK,I0,IORD,JJ, + 1 LAST) + IF((II.GT.NPAR).AND.LGERR) THEN + WRITE(TEXT4,'(I4)') IORD + IF(LWARN) THEN + WRITE(6,*)'APXCAT: ELEMENTARY CALCULATION HAS THE ', + 1 'SAME PARAMETERS AS ELEMENTARY CALCULATION NB ',TEXT4 + DEALLOCATE(JARBVA,JDEBAR,IORRHS) + IDEM=IDEM+1 + GOTO 170 + ELSE + CALL XABORT('APXCAT: ELEMENTARY CALCULATION HAS THE '// + 1 'SAME PARAMETERS AS ELEMENTARY CALCULATION NB '//TEXT4) + ENDIF + ENDIF +* +* Size of the new tree. +* + NVPNEW=NVPO+NPAR+1-MIN(II,KK) + MAXNVP=NVPR + IF(NVPNEW.GT.MAXNVP) MAXNVP=NVPNEW+MAXNVP + ALLOCATE(IDEBAR(MAXNVP+1),IARBVA(MAXNVP)) + IDEBAR(NVPNEW+2:MAXNVP+1)=0 + IARBVA(NVPNEW+1:MAXNVP)=0 +* +* Update values and suppress old PARBRE. +* + CALL COMARB(NPAR,NVPO,NVPNEW,JDEBAR,JARBVA,LGNEW,MUPLET,NCALS, + 1 IDEBAR,IARBVA) + DEALLOCATE(JARBVA,JDEBAR) + ENDIF + IF(NCALS.NE.NCAL+ICAL-IDEM) CALL XABORT('APXCAT: INVALID NCALS.') + NVPO=NVPNEW + CALL hdf5_write_data(IPAPX,"/NCALS",NCALS) + CALL hdf5_write_data(IPAPX,"/paramtree/DEBTREE",IDEBAR(:NVPNEW+1)) + CALL hdf5_write_data(IPAPX,"/paramtree/TREEVAL",IARBVA(:NVPNEW)) + DEALLOCATE(IARBVA,IDEBAR) + IF(NCALS.EQ.1) THEN + MAXNCA=1000 + ALLOCATE(IORIGI(MAXNCA)) + IORIGI(:MAXNCA)=0 + ELSE + CALL hdf5_info(IPAPX,"/paramtree/ORIGIN",RANK,TYPE,NBYTE,DIMSR) + MAXNCA=DIMSR(1) + IF(NCALS.GT.MAXNCA) MAXNCA=NCALS+MAXNCA + ALLOCATE(IORIGI(MAXNCA)) + IORIGI(:MAXNCA)=0 + CALL hdf5_read_data(IPAPX,"/paramtree/ORIGIN",VINTE) + IORIGI(:DIMSR(1))=VINTE(:DIMSR(1)) + DEALLOCATE(VINTE) + ENDIF + IF(IORRHS(ICAL).EQ.0) THEN + IORIGI(NCALS)=NORIG + ELSE + IORIGI(NCALS)=NCAL+IORRHS(ICAL) + ENDIF + CALL hdf5_write_data(IPAPX,"/paramtree/ORIGIN",IORIGI(:NCALS)) + DEALLOCATE(IORIGI,IORRHS) + IF(NCALS.NE.NCAL+ICAL-IDEM) CALL XABORT('APXCAT: INVALID NCALS.') +*---- +* RECOVER THE ELEMENTARY CALCULATION +*---- + WRITE(RECNAM,'(4Hcalc,I8)') NCALS + WRITE(RECNA2,'(4Hcalc,I8)') ICAL + call hdf5_copy(IPRHS,RECNA2,IPAPX,RECNAM) ! IPRHS -> IPAPX + 170 CONTINUE +* END OF LOOP ON ELEMENTARY CALCULATIONS. ******************** + RETURN + END diff --git a/Dragon/src/APXGEM.f b/Dragon/src/APXGEM.f new file mode 100644 index 0000000..eb63192 --- /dev/null +++ b/Dragon/src/APXGEM.f @@ -0,0 +1,188 @@ +*DECK APXGEM + SUBROUTINE APXGEM(IPDEPL,ITIM,TYPE,IMILI,NBURN,NBMIX,NBISO,NREAC, + 1 NVAR,VALUE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover a global parameter from the burnup object. +* +*Copyright: +* Copyright (C) 2025 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPDEPL pointer to the burnup object. +* ITIM index of the current burnup step. +* TYPE type of parameter (='Flux', 'Burnup', 'Time', 'Power', +* 'Exposure' or 'Heavy'). +* IMILI position of parameter (=0: global averaged value; >0: value +* in mixture IMILI). +* NBURN number of burnup steps in the burnup object. +* NBMIX number of depleting mixtures. +* NBISO number of isotopes. +* NREAC number of depleting reactions. +* NVAR number of depleting isotopes. +* +*Parameters: output +* VALUE global parameter or local variable. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPDEPL + INTEGER ITIM,IMILI,NBURN,NBMIX,NBISO,NREAC,NVAR + REAL VALUE + CHARACTER TYPE*(*) +*---- +* LOCAL VARIABLES +*---- + REAL BUIR(2) + CHARACTER CDIRO*12 + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: JM + REAL, ALLOCATABLE, DIMENSION(:) :: DEN,TIME,VX,WORK + REAL, ALLOCATABLE, DIMENSION(:,:) :: PARAM,VPHV + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SIG +*---- +* SCRATCH STORAGE ALLOCATION +* PARAM parameters (PARAM(*,1): fluence; PARAM(*,2): burnup or +* energy). +*---- + ALLOCATE(JM(NBMIX,NVAR)) + ALLOCATE(DEN(NBISO),TIME(NBURN),PARAM(NBMIX,2),VPHV(NBMIX,2), + 1 VX(NBMIX),WORK(NBMIX),SIG(NVAR+1,NREAC+1,NBMIX)) +* + CALL LCMGET(IPDEPL,'DEPL-TIMES',TIME) + CALL LCMGET(IPDEPL,'VOLUME-MIX',VX) + CALL LCMGET(IPDEPL,'DEPLETE-MIX',JM) +*---- +* COMPUTE THE EXPOSURE AND BURNUP +*---- + IF(IMILI.NE.0) THEN + NB0=1 + WRITE(CDIRO,'(8HDEPL-DAT,I4.4)') NB0 + CALL LCMSIX(IPDEPL,CDIRO,1) + CALL LCMGET(IPDEPL,'INT-FLUX',VPHV(1,1)) + CALL LCMSIX(IPDEPL,' ',2) + DO 10 IBM=1,NBMIX + PARAM(IBM,1)=0.0 + PARAM(IBM,2)=0.0 + 10 CONTINUE + DO 25 NB=NB0+1,ITIM + WRITE(CDIRO,'(8HDEPL-DAT,I4.4)') NB + CALL LCMSIX(IPDEPL,CDIRO,1) + CALL LCMGET(IPDEPL,'INT-FLUX',VPHV(1,2)) + CALL LCMGET(IPDEPL,'ENERG-MIX',WORK) + CALL LCMSIX(IPDEPL,' ',2) + DO 20 IBM=1,NBMIX + PHIAV=0.5*(VPHV(IBM,1)+VPHV(IBM,2))/VX(IBM) + PARAM(IBM,1)=PARAM(IBM,1)+PHIAV*(TIME(NB)-TIME(NB-1)) + PARAM(IBM,2)=PARAM(IBM,2)+WORK(IBM)/8.64E-4 + VPHV(IBM,1)=VPHV(IBM,2) + 20 CONTINUE + 25 CONTINUE + ENDIF +* + IF(TYPE.EQ.'Exposure') THEN + IF(IMILI.EQ.0) THEN + WRITE(CDIRO,'(8HDEPL-DAT,I4.4)') ITIM + CALL LCMSIX(IPDEPL,CDIRO,1) + CALL LCMGET(IPDEPL,'BURNUP-IRRAD',BUIR) + CALL LCMSIX(IPDEPL,' ',2) + VALUE=BUIR(2) + ELSE + VALUE=PARAM(IMILI,1) + ENDIF + ELSE IF(TYPE.EQ.'Burnup') THEN + IF(IMILI.EQ.0) THEN + WRITE(CDIRO,'(8HDEPL-DAT,I4.4)') ITIM + CALL LCMSIX(IPDEPL,CDIRO,1) + CALL LCMGET(IPDEPL,'BURNUP-IRRAD',BUIR) + CALL LCMSIX(IPDEPL,' ',2) + VALUE=BUIR(1) + ELSE + CALL LCMGET(IPDEPL,'FUELDEN-MIX',WORK) + IF(WORK(IMILI).EQ.0.0) THEN + VALUE=0.0 + ELSE + VALUE=PARAM(IMILI,2)/WORK(IMILI) + ENDIF + ENDIF + ELSE IF(TYPE.EQ.'Time') THEN + VALUE=(TIME(ITIM)-TIME(1))*1.0E8 + ELSE IF(TYPE.EQ.'Flux') THEN + WRITE(CDIRO,'(8HDEPL-DAT,I4.4)') ITIM + CALL LCMSIX(IPDEPL,CDIRO,1) + CALL LCMGET(IPDEPL,'INT-FLUX',PARAM(1,1)) + CALL LCMSIX(IPDEPL,' ',2) + IF(IMILI.EQ.0) THEN + VTOT=0.0 + VALUE=0.0 + DO 30 IBM=1,NBMIX + VTOT=VTOT+VX(IBM) + VALUE=VALUE+1.0E-11*PARAM(IBM,1) + 30 CONTINUE + VALUE=VALUE/VTOT + ELSE + VALUE=1.0E-11*PARAM(IMILI,1)/VX(IMILI) + ENDIF + ELSE IF(TYPE.EQ.'Power') THEN + WRITE(CDIRO,'(8HDEPL-DAT,I4.4)') ITIM + CALL LCMSIX(IPDEPL,CDIRO,1) + CALL LCMGET(IPDEPL,'MICRO-RATES',SIG) + CALL LCMGET(IPDEPL,'ISOTOPESDENS',DEN) + CALL LCMSIX(IPDEPL,' ',2) + IF(IMILI.EQ.0) THEN + VTOT=0.0 + VALUE=0.0 + DO 50 IBM=1,NBMIX + VTOT=VTOT+VX(IBM) + GAR=SIG(NVAR+1,NREAC,IBM)+SIG(NVAR+1,NREAC+1,IBM) + DO 40 IS=1,NVAR + IF(JM(IBM,IS).GT.0) THEN + GAR=GAR+VX(IBM)*DEN(JM(IBM,IS))*(SIG(IS,NREAC,IBM)+ + & SIG(IS,NREAC+1,IBM)) + ENDIF + 40 CONTINUE + VALUE=VALUE+1.0E-8*GAR + 50 CONTINUE + VALUE=VALUE/VTOT + ELSE + GAR=SIG(NVAR+1,NREAC,IMILI)+SIG(NVAR+1,NREAC+1,IMILI) + DO 60 IS=1,NVAR + IF(JM(IMILI,IS).GT.0) THEN + GAR=GAR+VX(IMILI)*DEN(JM(IMILI,IS))*(SIG(IS,NREAC,IMILI)+ + & SIG(IS,NREAC+1,IMILI)) + ENDIF + 60 CONTINUE + VALUE=1.0E-8*GAR/VX(IMILI) + ENDIF + ELSE IF(TYPE.EQ.'Heavy') THEN + CALL LCMGET(IPDEPL,'FUELDEN-MIX',WORK) + IF(IMILI.EQ.0) THEN + VTOT=0.0 + VALUE=0.0 + DO 70 IBM=1,NBMIX + VTOT=VTOT+VX(IBM) + VALUE=VALUE+WORK(IBM) + 70 CONTINUE + VALUE=VALUE/VTOT + ELSE + VALUE=WORK(IMILI)/VX(IMILI) + ENDIF + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SIG,WORK,VX,VPHV,PARAM,TIME,DEN) + DEALLOCATE(JM) + RETURN + END diff --git a/Dragon/src/APXGEP.f b/Dragon/src/APXGEP.f new file mode 100644 index 0000000..3716c05 --- /dev/null +++ b/Dragon/src/APXGEP.f @@ -0,0 +1,234 @@ +*DECK APXGEP + SUBROUTINE APXGEP(IPAPX,IPDEPL,IMPX,ITIM,NORIG,NPAR,MUPLET,LGNEW, + 1 NVPNEW,NCALAR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To recover remaining global parameters. Update the parameter tree +* for a new elementary calculation in the Apex file. +* +*Copyright: +* Copyright (C) 2025 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPAPX pointer to the Apex file. +* IPDEPL pointer to the burnup object. +* IMPX print parameter. +* ITIM index of the current burnup step. +* NORIG index of the elementary calculation associated to the +* father node in the parameter tree. +* NPAR number of global parameters. +* MUPLET tuple of indices associated to each global parameter of the +* elementary calculation. +* LGNEW parameter modification flag (.TRUE. only if the I-th global +* parameter has changed in the new elementary calculation). +* NCALAR index of the old elementary calculation. +* +*Parameters: output +* NVPNEW number of nodes in the global parameter tree. +* NCALAR index of the new elementary calculation. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPAPX,IPDEPL + INTEGER IMPX,ITIM,NORIG,NPAR,MUPLET(NPAR),NVPNEW,NCALAR + LOGICAL LGNEW(NPAR) +*---- +* LOCAL VARIABLES +*---- + INTEGER RANK,TYPE,NBYTE,DIMSR(5) + PARAMETER (NSTATE=40,MAXPAR=50) + INTEGER IDATA(NSTATE) + CHARACTER TEXT4*4,TEXT12*12,HSMG*131 + LOGICAL LGERR,COMTRE,LAST +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDEBAR,IARBVA,IORIGI,IVAL0, + 1 DIMS_APX + INTEGER, ALLOCATABLE, DIMENSION(:) :: JDEBAR,JARBVA + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: PARFMT + CHARACTER(LEN=80), ALLOCATABLE, DIMENSION(:) :: PARNAM +*---- +* RECOVER INFORMATION FROM THE 'DIMSAP' PARAMETER LIST. +*---- + NVPNEW=0 + NVPO=0 + IF(hdf5_group_exists(IPAPX,"/paramtree")) THEN + CALL hdf5_info(IPAPX,"/paramtree/TREEVAL",RANK,TYPE,NBYTE,DIMSR) + IF(RANK.NE.99) NVPO=DIMSR(1) + ENDIF +*---- +* RECOVER INFORMATION FROM THE 'paramdescrip' DIRECTORY. +*---- + IF(NPAR.EQ.0) RETURN + CALL hdf5_read_data(IPAPX,"/paramdescrip/PARNAM",PARNAM) + CALL hdf5_read_data(IPAPX,"/paramdescrip/PARFMT",PARFMT) +*---- +* RECOVER REMAINING GLOBAL PARAMETERS. +*---- + DO 10 IPAR=1,NPAR + IF((PARNAM(IPAR).EQ.'Burnup').OR.(PARNAM(IPAR).EQ.'Time').OR. + 1 (PARNAM(IPAR).EQ.'Power').OR.(PARNAM(IPAR).EQ.'Exposure').OR. + 2 (PARNAM(IPAR).EQ.'Flux').OR.(PARNAM(IPAR).EQ.'Heavy')) THEN +* +* RECOVER GLOBAL PARAMETER VALUES FROM THE DEPLETION OBJECT. + IF(.NOT.C_ASSOCIATED(IPDEPL)) CALL XABORT('APXGEP: NO DEPLETI' + 1 //'ON OBJECT AVAILABLE AMONG THE RHS LCM OBJECTS.') + CALL LCMGET(IPDEPL,'STATE-VECTOR',IDATA) + NBURN=IDATA(3) + NBISO=IDATA(4) + NREAC=IDATA(6) + NVAR=IDATA(7) + NBMIX=IDATA(8) + CALL APXGEM(IPDEPL,ITIM,PARNAM(IPAR),0,NBURN,NBMIX,NBISO, + 1 NREAC,NVAR,VALPAR) + ELSE + GO TO 10 + ENDIF + IF(IMPX.GT.0) WRITE(6,100) TRIM(PARNAM(IPAR)),VALPAR +* + CALL APXPAV(IPAPX,IPAR,NPAR,'FLOTTANT',VALPAR,NITMA,TEXT12, + 1 MUPLET(IPAR),LGNEW(IPAR)) + 10 CONTINUE + IF(IMPX.GT.2) THEN + WRITE(6,110) (MUPLET(I),I=1,NPAR) + WRITE(6,'(/)') + ENDIF + DO 15 I=1,NPAR + IF(MUPLET(I).EQ.0) THEN + WRITE(HSMG,'(33HAPXGEP: UNDEFINED MUPLET ELEMENT=,I6)') I + CALL XABORT(HSMG) + ENDIF + 15 CONTINUE +*---- +* INTRODUCE VALUES INTO GLOBAL PARAMETER TREE. +*---- +** +** Parameter tree: this tree has a number of stages equal to the +** number of parameters. For each value of the i-th parameter, we +** find the position in the tree corresponding to the value of the +** (i+1)-th parameter. +** NCALAR Number of elementary calculations stored in the tree. +** NVP Number of nodes in the parameter tree, including the root. +** The value corresponding to the root is not used. +** DEBTREE - If the node does not correspond to the last parameter: +** index in DEBTREE of the first daughter of the node. +** - If the node correspond to the last parameter: index in +** DEBTREE where we recover the index of an elementary +** calculation. +** TREVAL Index of the corresponding parameter in the 'pval'//n +** record. +* +** EXEMPLE: dn = value in DEBTREE, (m) = value in TREVAL +** +** Root *(0) +** ! +** Param. Nb 1 d2(1) +** ------------------- +** ! ! +** Param. Nb 2 d3(1) 4(2) +** --------- --------- +** ! ! ! ! ! +** Param. Nb 3 d5(1) 6(3) d7(1) 8(2) 9(3) d10 +** +** Calculation Nb: 4 5 1 2 3 +** +** DEBTREE: 2 3 5 7 10 4 5 1 2 3 +** TREVAL: 0 1 1 2 1 3 1 2 3 +* + IF(.NOT.hdf5_group_exists(IPAPX,"/paramtree/")) THEN + MAXNVP=100*(NPAR+1) + ALLOCATE(IDEBAR(MAXNVP+1),IARBVA(MAXNVP)) + IDEBAR(:MAXNVP+1)=0 + IARBVA(:MAXNVP)=0 + IARBVA=0 + DO 20 I=1,NPAR + IDEBAR(I)=I+1 + IARBVA(I+1)=1 + 20 CONTINUE + IDEBAR(NPAR+1)=NPAR+2 + IDEBAR(NPAR+2)=1 + NCALAR=1 + NVPNEW=NPAR+1 + CALL hdf5_create_group(IPAPX,'paramtree') + ELSE + CALL hdf5_info(IPAPX,"/paramtree/TREEVAL",RANK,TYPE,NBYTE,DIMSR) + MAXNVP=DIMSR(1) +* +* Find position of the new point and create new PARBRE. +* +* "II" is the order number of first parameter which recives a +* "brand new" value. +* COMTRE returns .TRUE. if the sweep throught the tree reaches +* its bottom, otherwise it returns "KK" value: level of the +* first new node to be introduced. +* + CALL hdf5_read_data(IPAPX,"/paramtree/DEBTREE",JDEBAR) + CALL hdf5_read_data(IPAPX,"/paramtree/TREEVAL",JARBVA) + DO 30 IPAR=1,NPAR + IF(LGNEW(IPAR)) THEN + II=IPAR + GO TO 40 + ENDIF + 30 CONTINUE + II=NPAR+1 + 40 LGERR=COMTRE(NPAR,NVPO,JARBVA,JDEBAR,MUPLET,KK,I0,IORD,JJ,LAST) + IF((II.GT.NPAR).AND.LGERR) THEN + WRITE(TEXT4,'(I4)') IORD + CALL XABORT('APXGEP: ELEMENTARY CALCULATION HAS THE SAME'// + 1 ' GLOBAL PARAMETERS AS ELEMENTARY CALCULATION NB '//TEXT4) + ENDIF +* +* Size of the new tree. +* + NVPNEW=NVPO+NPAR+1-MIN(II,KK) + IF(NVPNEW.GT.MAXNVP) MAXNVP=NVPNEW+MAXNVP + ALLOCATE(IDEBAR(MAXNVP+1),IARBVA(MAXNVP)) + IDEBAR(NVPNEW+2:MAXNVP+1)=0 + IARBVA(NVPNEW+1:MAXNVP)=0 +* +* Update values and suppress old PARBRE. +* + CALL COMARB(NPAR,NVPO,NVPNEW,JDEBAR,JARBVA,LGNEW,MUPLET,NCALAR, + 1 IDEBAR,IARBVA) + DEALLOCATE(JARBVA,JDEBAR) + ENDIF + CALL hdf5_write_data(IPAPX,"/paramtree/DEBTREE",IDEBAR(:NVPNEW+1)) + CALL hdf5_write_data(IPAPX,"/paramtree/TREEVAL",IARBVA(:NVPNEW)) + DEALLOCATE(IARBVA,IDEBAR) + IF(NCALAR.EQ.1) THEN + MAXNCA=1000 + ALLOCATE(IORIGI(MAXNCA)) + IORIGI(:MAXNCA)=0 + ELSE + CALL hdf5_get_shape(IPAPX,"/paramtree/ORIGIN",DIMS_APX) + MAXNCA=DIMS_APX(1) + DEALLOCATE(DIMS_APX) + IF(NCALAR.GT.MAXNCA) MAXNCA=NCALAR+MAXNCA + ALLOCATE(IORIGI(MAXNCA)) + IORIGI(:MAXNCA)=0 + CALL hdf5_read_data(IPAPX,"/paramtree/ORIGIN",IVAL0) + IORIGI(:MAXNCA)=IVAL0(:MAXNCA) + DEALLOCATE(IVAL0) + ENDIF + IORIGI(NCALAR)=NORIG + CALL hdf5_write_data(IPAPX,"/paramtree/ORIGIN",IORIGI(:NCALAR)) + DEALLOCATE(IORIGI,PARFMT,PARNAM) + RETURN +* + 100 FORMAT(31H APXGEP: SET GLOBAL PARAMETER ',A,3H' =,1P,E12.4) + 110 FORMAT(/16H APXGEP: MUPLET=,10I6:/(16X,10I6)) + END diff --git a/Dragon/src/APXGEY.f b/Dragon/src/APXGEY.f new file mode 100644 index 0000000..d6974a0 --- /dev/null +++ b/Dragon/src/APXGEY.f @@ -0,0 +1,205 @@ +*DECK APXGEY + SUBROUTINE APXGEY(IPAPX,IPEDIT,NISO,NG,NMIL,NBISO,NDFI,NISFS, + 1 NISPS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To recover the fission yields of an elementary calculation. +* +*Copyright: +* Copyright (C) 2025 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPAPX pointer to the Apex file. +* IPEDIT pointer to the edition object (L_EDIT signature). +* NISO number of particularized isotopes. +* NG number of condensed energy groups. +* NMIL number of mixtures in the MPO file. +* NBISO number of isotopes in the condensed microlib of the edition +* object. A given isotope may appear in many mixtures. +* NDFI number of fissile isotopes producing fission products in +* the edition object. +* NISFS number of particularized fissile isotopes. +* NISPS number of particularized fission products. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPAPX,IPEDIT + INTEGER NISO,NG,NMIL,NBISO,NDFI,NISFS,NISPS +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MAXISO=800) + TYPE(C_PTR) JPEDIT,KPEDIT + CHARACTER TEXT8*8,TEXT12*12,RECNAM*80 + LOGICAL LGIMF +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MIX,PIFI,ADRY + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISONAM + REAL, ALLOCATABLE, DIMENSION(:) :: DEN,PYIELD,SIG,PFIRA + REAL, ALLOCATABLE, DIMENSION(:,:) :: FLUXES + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: YLDS + CHARACTER(LEN=4), ALLOCATABLE, DIMENSION(:) :: TYPISO + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: NOMISO + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO +*---- +* SCRATCH STORAGE ALLOCATION +* PFIRA fission rate. +* ADRY offset in YLDS array for fissile isotopes (positive) and +* fission products (negative). +*---- + ALLOCATE(ISONAM(3,NBISO),MIX(NBISO),PIFI(NDFI)) + ALLOCATE(YLDS(NISFS,NISPS,1),DEN(NBISO),PYIELD(NDFI), + 1 FLUXES(NMIL,NG),SIG(NG),PFIRA(NBISO),ADRY(NISO)) + ALLOCATE(IPISO(NBISO)) +*---- +* RECOVER INFORMATION FROM THE /contents/isotopes GROUP. +*---- + IF(NISO.GT.0) THEN + CALL hdf5_read_data(IPAPX,"/physconst/ISOTA",NOMISO) + CALL hdf5_read_data(IPAPX,"/physconst/ISOTYP",TYPISO) + ENDIF +* + CALL LCMGET(IPEDIT,'ISOTOPESUSED',ISONAM) + CALL LCMGET(IPEDIT,'ISOTOPESMIX',MIX) + CALL LCMGET(IPEDIT,'ISOTOPESDENS',DEN) + CALL LIBIPS(IPEDIT,NBISO,IPISO) +*---- +* COMPUTE ARRAY ADRY. +*---- + ISF=0 + ISP=0 + ADRY(:NISO)=0 + DO 30 ISO=1,NISO + DO 10 IBISO=1,NBISO + WRITE(TEXT8,'(2A4)') (ISONAM(I0,IBISO),I0=1,2) + IF(NOMISO(ISO).EQ.TEXT8) GO TO 20 + 10 CONTINUE + GO TO 30 + 20 IF(TYPISO(ISO).EQ.'FISS') THEN + ISF=ISF+1 + ADRY(ISO)=ISF + ELSEIF(TYPISO(ISO).EQ.'F.P.') THEN + ISP=ISP+1 + ADRY(ISO)=-ISP + ENDIF + 30 CONTINUE + LGIMF=NISFS.GT.0 + IMF=0 + IF(LGIMF) IMF=ADRY(NISO) +*---- +* RECOVER THE NEUTRON FLUX. +*---- + CALL LCMSIX(IPEDIT,'MACROLIB',1) + JPEDIT=LCMGID(IPEDIT,'GROUP') + DO 40 IGR=1,NG + KPEDIT=LCMGIL(JPEDIT,IGR) + CALL LCMGET(KPEDIT,'FLUX-INTG',FLUXES(1,IGR)) + 40 CONTINUE + CALL LCMSIX(IPEDIT,' ',2) +*---- +* RECOVER THE FISSION RATES. +*---- + DO 65 IBISO=1,NBISO + GAR=0.0 + IF(MIX(IBISO).EQ.0) GO TO 60 + KPEDIT=IPISO(IBISO) + CALL LCMLEN(KPEDIT,'NFTOT',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,'NFTOT',SIG) + DO 50 IGR=1,NG + GAR=GAR+FLUXES(MIX(IBISO),IGR)*DEN(IBISO)*SIG(IGR) + 50 CONTINUE + ENDIF + 60 PFIRA(IBISO)=GAR + 65 CONTINUE +*---- +* LOOP OVER MPO MIXTURES TO RECOVER THE FISSION YIELDS. +*---- + DO 140 IMIL=1,NMIL + YLDS(:NISFS,:NISPS,1)=0.0 + DO 130 IBISO=1,NBISO + IF(MIX(IBISO).EQ.IMIL) THEN + WRITE(TEXT12,'(3A4)') (ISONAM(I0,IBISO),I0=1,3) + DO 80 ISO=1,NISO + IISO=ISO + IF(NOMISO(ISO).EQ.TEXT12(:8)) GO TO 90 + 80 CONTINUE + GO TO 130 + 90 KPEDIT=IPISO(IBISO) +* +* RECOVER THE FISSION YIELDS. + CALL LCMLEN(KPEDIT,'PYIELD',ILONG,ITYLCM) + IF((ILONG.GT.0).AND.(ILONG.EQ.NDFI)) THEN + CALL LCMGET(KPEDIT,'PIFI',PIFI) + CALL LCMGET(KPEDIT,'PYIELD',PYIELD) + ELSE + GO TO 130 + ENDIF + IFP=-ADRY(IISO) + IF(IFP.GT.0) THEN +* Particular fission product found. +* If exists in medium, find position in microlib +* and search all fissiles. + YLDW=0.0 + DO 120 IDFI=1,NDFI + JBISO=PIFI(IDFI) + IF(JBISO.GT.NBISO) CALL XABORT('APXGEY: MIX OVERFLOW.') + IF(JBISO.EQ.0) GO TO 120 + IF(MIX(JBISO).NE.IMIL) GO TO 120 + WRITE(TEXT8,'(3A4)') (ISONAM(I0,JBISO),I0=1,2) + DO 100 JSO=1,NISO + JISO=JSO + IF(NOMISO(JSO).EQ.TEXT8) GO TO 110 + 100 CONTINUE +* Mother isotope is in residual macro. + YLDW=YLDW+PFIRA(JBISO) + IF(IMF.EQ.0) CALL XABORT('APXGEY: LGIMF IS FALSE.') + YLDS(IMF,IFP,1)=YLDS(IMF,IFP,1)+PYIELD(IDFI)*PFIRA(JBISO) + GO TO 120 +* +* Yield for selected isotopes. + 110 IFI=ADRY(JISO) + IF(IFI.LE.0) CALL XABORT('APXGEY: BAD ADRY.') + YLDS(IFI,IFP,1)=PYIELD(IDFI) + 120 CONTINUE + IF(LGIMF) THEN + IF(YLDW.NE.0.0) YLDS(IMF,IFP,1)=YLDS(IMF,IFP,1)/YLDW + ENDIF + ENDIF + ENDIF + 130 CONTINUE + IF(NISO.GT.0) DEALLOCATE(NOMISO,TYPISO) +*---- +* STORE INFORMATION IN THE physconst GROUP. +*---- + IF(NMIL.EQ.1) THEN + CALL hdf5_write_data(IPAPX,"/physconst/FYIELDS",YLDS) + ELSE + WRITE(RECNAM,'(18H/physconst/FYIELDS,I8)') IMIL + CALL hdf5_write_data(IPAPX,TRIM(RECNAM),YLDS) + ENDIF + 140 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IPISO) + DEALLOCATE(ADRY) + DEALLOCATE(PFIRA,SIG,FLUXES,PYIELD,DEN,YLDS) + DEALLOCATE(PIFI,MIX,ISONAM) + RETURN + END diff --git a/Dragon/src/APXIDF.f b/Dragon/src/APXIDF.f new file mode 100644 index 0000000..84ecc91 --- /dev/null +++ b/Dragon/src/APXIDF.f @@ -0,0 +1,146 @@ +*DECK APXIDF + SUBROUTINE APXIDF(IPAPX,IPEDIT,NG,NMIL,ICAL,IDF,NALBP,FNORM, + 1 VOLMIL,FLXMIL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To store discontinuity factor and albedo information in the Apex file. +* +*Copyright: +* Copyright (C) 2025 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPAPX pointer to the Apex file. +* IPEDIT pointer to the edition object (L_EDIT signature). +* NG number of condensed energy groups. +* NMIL number of mixtures. +* ICAL index of the current elementary calculation. +* IDF type of surfacic information (2/3: boundary flux/DF). +* NALBP number of physical albedos per energy group. +* FNORM flux normalization factor. +* VOLMIL mixture volumes. +* FLXMIL averaged flux of mixtures. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPAPX,IPEDIT + INTEGER NG,NMIL,ICAL,IDF,NALBP + REAL FNORM,VOLMIL(NMIL),FLXMIL(NMIL,NG) +*---- +* LOCAL VARIABLES +*---- + CHARACTER HSMG*131,RECNAM*80,RECNAM2*80 +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: SURF + REAL, ALLOCATABLE, DIMENSION(:,:) :: VREAL,ALBP + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: DISFAC + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HADF +*---- +* RECOVER DISCONTINUITY FACTOR INFORMATION FROM MACROLIB +*---- + CALL LCMSIX(IPEDIT,'MACROLIB',1) + CALL LCMLEN(IPEDIT,'ADF',ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + CALL LCMSIX(IPEDIT,'ADF',1) + CALL LCMGET(IPEDIT,'NTYPE',NSURFD) + NGG=0 + IF((IDF.EQ.2).OR.(IDF.EQ.3)) THEN + NGG=NG + ELSE + CALL XABORT('APXIDF: INVALID ADF OPTION.') + ENDIF + ALLOCATE(DISFAC(NSURFD,NGG,NMIL),SURF(NMIL*NGG),HADF(NSURFD)) + CALL LCMGTC(IPEDIT,'HADF',8,NSURFD,HADF) + DO I=1,NSURFD + CALL LCMLEN(IPEDIT,HADF(I),ILONG,ITYLCM) + IF(IDF.EQ.2) THEN +* boundary flux information + IF(ILONG.NE.NMIL*NG) THEN + WRITE(HSMG,'(16HAPXIDF: INVALID ,A,8H LENGTH=,I5, + 1 10H EXPECTED=,I5,4H.(1))') HADF(I),ILONG,NMIL*NG + CALL XABORT(HSMG) + ENDIF + CALL LCMGET(IPEDIT,HADF(I),SURF) + DO IMIL=1,NMIL + DO IGR=1,NG + IF(FNORM.NE.1.0) THEN + DISFAC(I,IGR,IMIL)=SURF((IGR-1)*NMIL+IMIL)* + 1 FNORM*1.0E13*VOLMIL(IMIL)/FLXMIL(IMIL,IGR) + ELSE + DISFAC(I,IGR,IMIL)=SURF((IGR-1)*NMIL+IMIL)* + 1 VOLMIL(IMIL)/FLXMIL(IMIL,IGR) + ENDIF + ENDDO + ENDDO + ELSE IF(IDF.EQ.3) THEN +* discontinuity factor information + IF(ILONG.NE.NMIL*NG) THEN + WRITE(HSMG,'(16HAPXIDF: INVALID ,A,8H LENGTH=,I5, + 1 10H EXPECTED=,I5,4H.(2))') HADF(I),ILONG,NMIL*NG + CALL XABORT(HSMG) + ENDIF + CALL LCMGET(IPEDIT,HADF(I),SURF) + DO IMIL=1,NMIL + DO IGR=1,NG + IOF=(IGR-1)*NMIL+IMIL + DISFAC(I,IGR,IMIL)=SURF(IOF) + ENDDO + ENDDO + ENDIF + ENDDO + DEALLOCATE(HADF,SURF) + CALL LCMSIX(IPEDIT,' ',2) +*---- +* MOVE TO THE /calc_id/miscellaneous/ GROUP. +*---- + WRITE(RECNAM,'(4Hcalc,I8,15H/miscellaneous/)') ICAL + IF((IDF.EQ.2).OR.(IDF.EQ.3)) THEN + IF(NMIL.EQ.1) THEN + ALLOCATE(VREAL(NSURFD,NG)) + VREAL(:NSURFD,:NG)=DISFAC(:NSURFD,:NG,1) + CALL hdf5_write_data(IPAPX,TRIM(RECNAM)//"ADF",VREAL) + DEALLOCATE(VREAL) + ELSE + DO IMIL=1,NMIL + WRITE(RECNAM2,'(A,3HADF,I8)') TRIM(RECNAM),IMIL + ALLOCATE(VREAL(NSURFD,NG)) + VREAL(:NSURFD,:NG)=DISFAC(:NSURFD,:NG,IMIL) + CALL hdf5_write_data(IPAPX,TRIM(RECNAM2),VREAL) + DEALLOCATE(VREAL) + ENDDO + ENDIF + ENDIF + DEALLOCATE(DISFAC) + ENDIF +*---- +* RECOVER AND SAVE ALBEDO INFORMATION +*---- + IF(NALBP.NE.0) THEN + WRITE(RECNAM,'(4Hcalc,I8,15H/miscellaneous/)') ICAL + CALL LCMLEN(IPEDIT,'ALBEDO',ILONG,ITYLCM) + IF(ILONG.EQ.NALBP*NG) THEN + ALLOCATE(ALBP(NALBP,NG)) + CALL LCMGET(IPEDIT,'ALBEDO',ALBP) + CALL hdf5_write_data(IPAPX,TRIM(RECNAM)//"ALBEDO",ALBP) + DEALLOCATE(ALBP) + ELSE + CALL XABORT('APXIDF: INCONSISTENT ALBEDO INFORMATION.') + ENDIF + ENDIF + CALL LCMSIX(IPEDIT,' ',2) + RETURN + END diff --git a/Dragon/src/APXPAV.f b/Dragon/src/APXPAV.f new file mode 100644 index 0000000..1f5bb2c --- /dev/null +++ b/Dragon/src/APXPAV.f @@ -0,0 +1,164 @@ +*DECK APXPAV + SUBROUTINE APXPAV(IPAPX,IPAR,NPAR,TYPE,RVAL,IVAL,CVAL,IV,LGNEW) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To return the index of a global parameter value in the Apex file. +* Reorganize the 'paramvalues' group if required. +* +*Copyright: +* Copyright (C) 2025 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPAPX pointer to the Apex file. +* IPAR index of the global parameter. +* NPAR total number of global parameters. +* TYPE type of the global parameter value. +* RVAL global parameter value if TYPE='FLOTTANT'. +* IVAL global parameter value if TYPE='ENTIER'. +* CVAL global parameter value if TYPE='CHAINE'. +* +*Parameters: output +* IV index of the global parameter value. +* LGNEW new parameter flag (=.true. if the parameter value is new). +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPAPX + INTEGER IPAR,NPAR,IV,IVAL + REAL RVAL + LOGICAL LGNEW + CHARACTER TYPE*8,CVAL*(*) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (REPS=1.0E-5) + CHARACTER RECNAM*80 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NVALUE,VINTE,VINTE_V1, + 1 DIMS_APX + REAL, ALLOCATABLE, DIMENSION(:) :: VREAL,VREAL_V1 + CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: VCHAR,VCHAR_V1 +* + CALL hdf5_read_data(IPAPX,"/paramdescrip/NVALUE",NVALUE) + WRITE(RECNAM,'(17H/paramvalues/PVAL,I8)') IPAR +* + LGNEW=.TRUE. + IF(TYPE.EQ.'FLOTTANT') THEN + ALLOCATE(VREAL(NVALUE(IPAR)+1)) + IF(NVALUE(IPAR).EQ.0) THEN + IV=1 + VREAL(IV)=RVAL + NVALUE(IPAR)=1 + ELSE + CALL hdf5_get_shape(IPAPX,RECNAM,DIMS_APX) + ILONG=DIMS_APX(1) + IF(ILONG.GT.NVALUE(IPAR)) CALL XABORT('APXPAV: NVALUE OVER' + 1 //'FLOW(1).') + CALL hdf5_read_data(IPAPX,RECNAM,VREAL_V1) + VREAL(:ILONG)=VREAL_V1(:ILONG) + DEALLOCATE(VREAL_V1) + DO 10 I=1,NVALUE(IPAR) + IF(RVAL.LE.VREAL(I)*(1.+REPS))THEN + IV=I + LGNEW=RVAL.LT.VREAL(IV)*(1.-REPS) + GO TO 20 + ENDIF + 10 CONTINUE + IV=NVALUE(IPAR)+1 + 20 IF(LGNEW) THEN + NVALUE(IPAR)=NVALUE(IPAR)+1 + DO 30 J=NVALUE(IPAR)-1,IV,-1 + VREAL(J+1)=VREAL(J) + 30 CONTINUE + VREAL(IV)=RVAL + ENDIF + ENDIF + IF(LGNEW) CALL hdf5_write_data(IPAPX,TRIM(RECNAM), + 1 VREAL(:NVALUE(IPAR))) + DEALLOCATE(VREAL) + ELSE IF(TYPE.EQ.'ENTIER') THEN + ALLOCATE(VINTE(NVALUE(IPAR)+1)) + IF(NVALUE(IPAR).EQ.0) THEN + IV=1 + VINTE(IV)=IVAL + NVALUE(IPAR)=1 + ELSE + CALL hdf5_get_shape(IPAPX,RECNAM,DIMS_APX) + ILONG=DIMS_APX(1) + IF(ILONG.GT.NVALUE(IPAR)) CALL XABORT('APXPAV: NVALUE OVER' + 1 //'FLOW(2).') + CALL hdf5_read_data(IPAPX,RECNAM,VINTE_V1) + VINTE(:ILONG)=VINTE_V1(:ILONG) + DEALLOCATE(VINTE_V1) + DO 40 I=1,NVALUE(IPAR) + IF(IVAL.LE.VINTE(I))THEN + IV=I + LGNEW=IVAL.LT.VINTE(IV) + GO TO 50 + ENDIF + 40 CONTINUE + IV=NVALUE(IPAR)+1 + 50 IF(LGNEW) THEN + NVALUE(IPAR)=NVALUE(IPAR)+1 + DO 60 J=NVALUE(IPAR)-1,IV,-1 + VINTE(J+1)=VINTE(J) + 60 CONTINUE + VINTE(IV)=IVAL + ENDIF + ENDIF + IF(LGNEW) CALL hdf5_write_data(IPAPX,TRIM(RECNAM), + 1 VINTE(:NVALUE(IPAR))) + DEALLOCATE(VINTE) + ELSE IF(TYPE.EQ.'CHAINE') THEN + ALLOCATE(VCHAR(NVALUE(IPAR)+1)) + IF(NVALUE(IPAR).EQ.0) THEN + IV=1 + VCHAR(IV)=CVAL + NVALUE(IPAR)=1 + ELSE + CALL hdf5_get_shape(IPAPX,RECNAM,DIMS_APX) + ILONG=DIMS_APX(1) + IF(ILONG.GT.NVALUE(IPAR)) CALL XABORT('APXPAV: NVALUE OVER' + 1 //'FLOW(3).') + CALL hdf5_read_data(IPAPX,RECNAM,VCHAR_V1) + VCHAR(:ILONG)=VCHAR_V1(:ILONG) + DEALLOCATE(VCHAR_V1) + DO 70 I=1,NVALUE(IPAR) + IF(CVAL.EQ.VCHAR(I))THEN + IV=I + LGNEW=.FALSE. + GO TO 80 + ENDIF + 70 CONTINUE + IV=NVALUE(IPAR)+1 + 80 IF(LGNEW) THEN + NVALUE(IPAR)=NVALUE(IPAR)+1 + VCHAR(IV)=CVAL + ENDIF + ENDIF + IF(LGNEW) CALL hdf5_write_data(IPAPX,TRIM(RECNAM), + 1 VCHAR(:NVALUE(IPAR))) + DEALLOCATE(VCHAR) + ENDIF +* + IF(LGNEW) THEN + CALL hdf5_write_data(IPAPX,"/paramdescrip/NVALUE",NVALUE(:NPAR)) + ENDIF + DEALLOCATE(NVALUE) + RETURN + END diff --git a/Dragon/src/APXSX2.f b/Dragon/src/APXSX2.f new file mode 100644 index 0000000..cbbbde5 --- /dev/null +++ b/Dragon/src/APXSX2.f @@ -0,0 +1,529 @@ +*DECK APXSX2 + SUBROUTINE APXSX2(IPAPX,IPTEMP,NGRP,NL,NMAC,NISO,NMIL,IMIL,ITRANC, + 1 RECNAM,NOMMAC,TYPISO,NOMREA,IPERM,CONCES,B2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover the cross sections of an elementary calculation and single +* mixture in the edit structure and copy them in the Apex file. +* +*Copyright: +* Copyright (C) 2025 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPAPX pointer to the Apex file. +* IPTEMP pointer to the edit structure. +* NGRP number of energy groups in the Apex file. +* NL number of Legendre orders. +* NMAC number of macroscopic sets in the Apex file. +* NISO number of particularized isotopes in the Apex file. +* NMIL number of mixtures in the Apex file. +* ITRANC +* IMIL mixture index. +* RECNAM character identification of calculation. +* NOMMAC names of the macroscopic sets. +* TYPISO types of the particularized isotopes. +* NOMREA name of the Apex reaction. +* IPERM pointer to the particularized isotopes in the edit structure. +* CONCES number densities of particularized isotopes. +* B2 buckling. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPAPX,IPTEMP,IPERM(NISO) + CHARACTER*80 RECNAM + CHARACTER*4 TYPISO(NISO) + CHARACTER*8 NOMMAC(NMAC) + CHARACTER*12 NOMREA + INTEGER NGRP,NL,NMAC,NISO,IMIL,ITRANC + REAL B2,CONCES(NISO) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPEDIT,KPEDIT + INTEGER RANK,TYPE,NBYTE,DIMSR(5) + CHARACTER RECNAM2*80,CM*2,TEXT12*12 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: JSO,ITYPR,IPOS,NJJ,IJJ + REAL, ALLOCATABLE, DIMENSION(:) :: WORK1D,WO1D + REAL, ALLOCATABLE, DIMENSION(:,:) :: WORK2D,WP2D,WF2D,WO2D + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: WORK3D,WP3D,WF3D,WO3D + REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: WP4D,WF4D,WO4D +*---- +* FIND NISOP, NISOF AND NISOO +*---- + NISOF=0 + NISOP=0 + NISOO=0 + IF(NISO.EQ.0) GO TO 10 + ALLOCATE(JSO(NISO)) + DO ISO=1,NISO + IF(TYPISO(ISO).EQ.'FISS') THEN + NISOF=NISOF+1 + JSO(ISO)=NISOF + ELSE IF(TYPISO(ISO).EQ.'F.P.') THEN + NISOP=NISOP+1 + JSO(ISO)=NISOP + ELSE IF(TYPISO(ISO).EQ.'OTHE') THEN + NISOO=NISOO+1 + JSO(ISO)=NISOO + ENDIF + ENDDO + IF(NISOF.GT.0) THEN + CALL hdf5_create_group(IPAPX,TRIM(RECNAM)//"mic/fiss/") + ENDIF + IF(NISOP.GT.0) THEN + CALL hdf5_create_group(IPAPX,TRIM(RECNAM)//"mic/f.p. /") + ENDIF + IF(NISOO.GT.0) THEN + CALL hdf5_create_group(IPAPX,TRIM(RECNAM)//"mic/othe/") + ENDIF +*---- +* RECOVER DIFF AND SCAT OF PARTICULARIZED ISOTOPES +*---- + IF((NOMREA.EQ.'DIFF').OR.(NOMREA.EQ.'SCAT')) THEN + ALLOCATE(WF3D(NGRP,NL,NISOF),WP3D(NGRP,NL,NISOP), + 1 WO3D(NGRP,NL,NISOO),WF4D(NGRP,NGRP,NL,NISOF), + 2 WP4D(NGRP,NGRP,NL,NISOP),WO4D(NGRP,NGRP,NL,NISOO)) + WF3D(:NGRP,:NL,:NISOF)=0.0 + WP3D(:NGRP,:NL,:NISOP)=0.0 + WO3D(:NGRP,:NL,:NISOO)=0.0 + WF4D(:NGRP,:NGRP,:NL,:NISOF)=0.0 + WP4D(:NGRP,:NGRP,:NL,:NISOP)=0.0 + WO4D(:NGRP,:NGRP,:NL,:NISOO)=0.0 + DO ISO=1,NISO + IF(.NOT.C_ASSOCIATED(IPERM(ISO))) CYCLE + DO IL=1,NL + WRITE(CM,'(I2.2)') IL-1 + CALL LCMLEN(IPERM(ISO),'SCAT'//CM,ILONG,ITYLCM) + IF(ILONG.EQ.0) CYCLE + FACT=2.0*REAL(IL)-1.0 + ALLOCATE(WORK2D(NGRP,NL),WORK3D(NGRP,NGRP,NL),ITYPR(NL)) + CALL XDRLGS(IPERM(ISO),-1,0,0,NL-1,1,NGRP,WORK2D,WORK3D, + 1 ITYPR) + IF(TYPISO(ISO).EQ.'FISS') THEN + WF3D(:,:,JSO(ISO))=WORK2D(:,:) + WF4D(:,:,:,JSO(ISO))=WORK3D(:,:,:)*FACT + ELSE IF(TYPISO(ISO).EQ.'F.P.') THEN + WP3D(:,:,JSO(ISO))=WORK2D(:,:) + WP4D(:,:,:,JSO(ISO))=WORK3D(:,:,:)*FACT + ELSE IF(TYPISO(ISO).EQ.'OTHE') THEN + WO3D(:,:,JSO(ISO))=WORK2D(:,:) + WO4D(:,:,:,JSO(ISO))=WORK3D(:,:,:)*FACT + ENDIF + DEALLOCATE(ITYPR,WORK3D,WORK2D) + ENDDO + ENDDO + ! remove (n,2n) from 'DIFF' + DO ISO=1,NISO + IF(.NOT.C_ASSOCIATED(IPERM(ISO))) CYCLE + CALL LCMLEN(IPERM(ISO),'N2N',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + ALLOCATE(WORK1D(NGRP)) + CALL LCMGET(IPERM(ISO),'N2N',WORK1D) + IF(TYPISO(ISO).EQ.'FISS') THEN + WF3D(:,1,JSO(ISO))=WF3D(:,1,JSO(ISO))-WORK1D(:) + ELSE IF(TYPISO(ISO).EQ.'F.P.') THEN + WP3D(:,1,JSO(ISO))=WF3D(:,1,JSO(ISO))-WORK1D(:) + ELSE IF(TYPISO(ISO).EQ.'OTHE') THEN + WO3D(:,1,JSO(ISO))=WF3D(:,1,JSO(ISO))-WORK1D(:) + ENDIF + DEALLOCATE(WORK1D) + ENDIF + ENDDO + ! remove (n,3n) from 'DIFF' + DO ISO=1,NISO + IF(.NOT.C_ASSOCIATED(IPERM(ISO))) CYCLE + CALL LCMLEN(IPERM(ISO),'N3N',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + ALLOCATE(WORK1D(NGRP)) + CALL LCMGET(IPERM(ISO),'N3N',WORK1D) + IF(TYPISO(ISO).EQ.'FISS') THEN + WF3D(:,1,JSO(ISO))=WF3D(:,1,JSO(ISO))-2.0*WORK1D(:) + ELSE IF(TYPISO(ISO).EQ.'F.P.') THEN + WP3D(:,1,JSO(ISO))=WF3D(:,1,JSO(ISO))-2.0*WORK1D(:) + ELSE IF(TYPISO(ISO).EQ.'OTHE') THEN + WO3D(:,1,JSO(ISO))=WF3D(:,1,JSO(ISO))-2.0*WORK1D(:) + ENDIF + DEALLOCATE(WORK1D) + ENDIF + ENDDO + IF(NOMREA.EQ.'DIFF') THEN + IF(NISOF.GT.0) THEN + WRITE(RECNAM2,'(A,9Hmic/fiss/,A)') TRIM(RECNAM),'DIFF' + CALL hdf5_write_data(IPAPX,RECNAM2,WF3D) + ENDIF + IF(NISOP.GT.0) THEN + WRITE(RECNAM2,'(A,10Hmic/f.p. /,A)') TRIM(RECNAM),'DIFF' + CALL hdf5_write_data(IPAPX,RECNAM2,WP3D) + ENDIF + IF(NISOO.GT.0) THEN + WRITE(RECNAM2,'(A,9Hmic/othe/,A)') TRIM(RECNAM),'DIFF' + CALL hdf5_write_data(IPAPX,RECNAM2,WO3D) + ENDIF + ELSE IF(NOMREA.EQ.'SCAT') THEN + IF(NISOF.GT.0) THEN + WRITE(RECNAM2,'(A,9Hmic/fiss/,A)') TRIM(RECNAM),'SCAT' + CALL hdf5_write_data(IPAPX,RECNAM2,WF4D) + ENDIF + IF(NISOP.GT.0) THEN + WRITE(RECNAM2,'(A,10Hmic/f.p. /,A)') TRIM(RECNAM),'SCAT' + CALL hdf5_write_data(IPAPX,RECNAM2,WP4D) + ENDIF + IF(NISOO.GT.0) THEN + WRITE(RECNAM2,'(A,9Hmic/othe/,A)') TRIM(RECNAM),'SCAT' + CALL hdf5_write_data(IPAPX,RECNAM2,WO4D) + ENDIF + ENDIF + DEALLOCATE(WO4D,WP4D,WF4D,WO3D,WP3D,WF3D) + GO TO 10 + ENDIF +*---- +* RECOVER OTHER REACTIONS OF PARTICULARIZED ISOTOPES +*---- + ALLOCATE(WF2D(NGRP,NISOF),WP2D(NGRP,NISOP),WO2D(NGRP,NISOO)) + WF2D(:NGRP,:NISOF)=0.0 + WP2D(:NGRP,:NISOP)=0.0 + WO2D(:NGRP,:NISOO)=0.0 + IF(NOMREA.EQ.'ABSO') THEN + DO ISO=1,NISO + IF(.NOT.C_ASSOCIATED(IPERM(ISO))) CYCLE + CALL LCMLEN(IPERM(ISO),'NTOT0',ILONG,ITYLCM) + IF(ILONG.EQ.0) CYCLE + ALLOCATE(WORK1D(NGRP)) + CALL LCMGET(IPERM(ISO),'NTOT0',WORK1D) + IF(TYPISO(ISO).EQ.'FISS') THEN + WF2D(:,JSO(ISO))=WORK1D(:) + ELSE IF(TYPISO(ISO).EQ.'F.P.') THEN + WP2D(:,JSO(ISO))=WORK1D(:) + ELSE IF(TYPISO(ISO).EQ.'OTHE') THEN + WO2D(:,JSO(ISO))=WORK1D(:) + ENDIF + DEALLOCATE(WORK1D) + ENDDO + ! remove 'DIFF' from 'TOTA' + DO ISO=1,NISO + IF(.NOT.C_ASSOCIATED(IPERM(ISO))) CYCLE + IF(TYPISO(ISO).EQ.'FISS') THEN + WRITE(RECNAM2,'(A,9Hmic/fiss/,A)') TRIM(RECNAM),'DIFF' + CALL hdf5_info(IPAPX,RECNAM2,RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.EQ.99) CALL XABORT('APXSX2: MISSING DIFF INFO(1).') + CALL hdf5_read_data(IPAPX,RECNAM2,WF3D) + WF2D(:,JSO(ISO))=WF2D(:,JSO(ISO))-WF3D(:,1,JSO(ISO)) + DEALLOCATE(WF3D) + ELSE IF(TYPISO(ISO).EQ.'F.P.') THEN + WRITE(RECNAM2,'(A,10Hmic/f.p. /,A)') TRIM(RECNAM),'DIFF' + CALL hdf5_info(IPAPX,RECNAM2,RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.EQ.99) CALL XABORT('APXSX2: MISSING DIFF INFO(2).') + CALL hdf5_read_data(IPAPX,RECNAM2,WP3D) + WP2D(:,JSO(ISO))=WP2D(:,JSO(ISO))-WP3D(:,1,JSO(ISO)) + DEALLOCATE(WP3D) + ELSE IF(TYPISO(ISO).EQ.'OTHE') THEN + WRITE(RECNAM2,'(A,9Hmic/othe/,A)') TRIM(RECNAM),'DIFF' + CALL hdf5_info(IPAPX,RECNAM2,RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.EQ.99) CALL XABORT('APXSX2: MISSING DIFF INFO(3).') + CALL hdf5_read_data(IPAPX,RECNAM2,WO3D) + WO2D(:,JSO(ISO))=WO2D(:,JSO(ISO))-WO3D(:,1,JSO(ISO)) + DEALLOCATE(WO3D) + ENDIF + ENDDO + ELSE + IF(NOMREA.EQ.'TOTA') THEN + TEXT12='NTOT0' + ELSE IF(NOMREA.EQ.'TOT1') THEN + TEXT12='NTOT1' + ELSE IF(NOMREA.EQ.'NUFI') THEN + TEXT12='NUSIGF' + ELSE IF(NOMREA.EQ.'FISS') THEN + TEXT12='NFTOT' + ELSE IF(NOMREA.EQ.'ENER') THEN + TEXT12='H-FACTOR' + ELSE IF((NOMREA.EQ.'CORR').AND.(ITRANC.EQ.1).AND.(NL.GE.2)) THEN + TEXT12='SIGS01' + ELSE IF((NOMREA.EQ.'CORR').AND.(ITRANC.EQ.2)) THEN + TEXT12='TRANC' + ELSE + TEXT12=NOMREA + ENDIF + DO ISO=1,NISO + IF(.NOT.C_ASSOCIATED(IPERM(ISO))) CYCLE + CALL LCMLEN(IPERM(ISO),TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) CYCLE + ALLOCATE(WORK1D(NGRP)) + CALL LCMGET(IPERM(ISO),TEXT12,WORK1D) + IF(TYPISO(ISO).EQ.'FISS') THEN + WF2D(:,JSO(ISO))=WORK1D(:) + ELSE IF(TYPISO(ISO).EQ.'F.P.') THEN + WP2D(:,JSO(ISO))=WORK1D(:) + ELSE IF(TYPISO(ISO).EQ.'OTHE') THEN + WO2D(:,JSO(ISO))=WORK1D(:) + ENDIF + DEALLOCATE(WORK1D) + ENDDO + IF(NOMREA.EQ.'ENER') THEN + WF2D(:,:)=WF2D(:,:)*1.0E-6 + WP2D(:,:)=WP2D(:,:)*1.0E-6 + WO2D(:,:)=WO2D(:,:)*1.0E-6 + ELSE IF(NOMREA.EQ.'LEAK') THEN + WF2D(:,:)=WF2D(:,:)*B2 + WP2D(:,:)=WP2D(:,:)*B2 + WO2D(:,:)=WO2D(:,:)*B2 + ENDIF + ENDIF + IF(NISOF.GT.0) THEN + WRITE(RECNAM2,'(A,9Hmic/fiss/,A)') TRIM(RECNAM),TRIM(NOMREA) + CALL hdf5_write_data(IPAPX,RECNAM2,WF2D) + ENDIF + IF(NISOP.GT.0) THEN + WRITE(RECNAM2,'(A,10Hmic/f.p. /,A)') TRIM(RECNAM),TRIM(NOMREA) + CALL hdf5_write_data(IPAPX,RECNAM2,WP2D) + ENDIF + IF(NISOO.GT.0) THEN + WRITE(RECNAM2,'(A,9Hmic/othe/,A)') TRIM(RECNAM),TRIM(NOMREA) + CALL hdf5_write_data(IPAPX,RECNAM2,WO2D) + ENDIF + DEALLOCATE(WO2D,WP2D,WF2D) +*---- +* RECOVER DIFF AND SCAT OF MACROSCOPIC SETS +*---- + 10 CALL LCMSIX(IPTEMP,'MACROLIB',1) + JPEDIT=LCMGID(IPTEMP,'GROUP') + IF(NMAC.GT.0) THEN + CALL hdf5_create_group(IPAPX,TRIM(RECNAM)//"mac/TOTAL/") + ENDIF + DO IMAC=1,NMAC + IF(NOMMAC(IMAC).EQ.'TOTAL') THEN + IF((NOMREA.EQ.'DIFF').OR.(NOMREA.EQ.'SCAT')) THEN + ALLOCATE(WO2D(NGRP,NL),WO3D(NGRP,NGRP,NL)) + WO2D(:NGRP,:NL)=0.0 + WO3D(:NGRP,:NGRP,:NL)=0.0 + DO IGR=1,NGRP + KPEDIT=LCMGIL(JPEDIT,IGR) + ALLOCATE(IJJ(NMIL),NJJ(NMIL),IPOS(NMIL),WORK1D(NGRP*NMIL)) + DO IL=1,NL + WRITE(CM,'(I2.2)') IL-1 + CALL LCMLEN(KPEDIT,'SCAT'//CM,ILONG,ITYLCM) + IF(ILONG.EQ.0) CYCLE + CALL LCMGET(KPEDIT,'IJJS'//CM,IJJ) + CALL LCMGET(KPEDIT,'NJJS'//CM,NJJ) + CALL LCMGET(KPEDIT,'IPOS'//CM,IPOS) + CALL LCMGET(KPEDIT,'SCAT'//CM,WORK1D) + IPO=IPOS(IMIL) + J2=IJJ(IMIL) + J1=IJJ(IMIL)-NJJ(IMIL)+1 + DO JGR=J2,J1,-1 + WO2D(JGR,IL)=WO2D(JGR,IL)+WORK1D(IPO) + WO3D(IGR,JGR,IL)=WORK1D(IPO)*REAL(2*IL-1) + IPO=IPO+1 + ENDDO + ENDDO ! IL + DEALLOCATE(WORK1D,IPOS,NJJ,IJJ) + ! remove (n,2n) from 'DIFF' + CALL LCMLEN(KPEDIT,'N2N',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + ALLOCATE(WORK1D(NMIL)) + CALL LCMGET(KPEDIT,'N2N',WORK1D) + WO2D(IGR,1)=WO2D(IGR,1)-WORK1D(IMIL) + DEALLOCATE(WORK1D) + ENDIF + ! remove (n,2n) from 'DIFF' + CALL LCMLEN(KPEDIT,'N2N',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + ALLOCATE(WORK1D(NMIL)) + CALL LCMGET(KPEDIT,'N2N',WORK1D) + WO2D(IGR,1)=WO2D(IGR,1)-2.0*WORK1D(IMIL) + DEALLOCATE(WORK1D) + ENDIF + ENDDO ! IGR + IF(NOMREA.EQ.'DIFF') THEN + WRITE(RECNAM2,'(A,10Hmac/TOTAL/,A)') TRIM(RECNAM),'DIFF' + CALL hdf5_write_data(IPAPX,RECNAM2,WO2D) + ELSE IF(NOMREA.EQ.'SCAT') THEN + WRITE(RECNAM2,'(A,10Hmac/TOTAL/,A)') TRIM(RECNAM),'SCAT' + CALL hdf5_write_data(IPAPX,RECNAM2,WO3D) + ENDIF + DEALLOCATE(WO3D,WO2D) +*---- +* RECOVER OTHER REACTIONS OF MACROSCOPIC SETS +*---- + ELSE IF(NOMREA.EQ.'ABSO') THEN + ALLOCATE(WO1D(NGRP)) + WO1D(:NGRP)=0.0 + DO IGR=1,NGRP + KPEDIT=LCMGIL(JPEDIT,IGR) + CALL LCMLEN(KPEDIT,'NTOT0',ILONG,ITYLCM) + IF(ILONG.EQ.0) CYCLE + ALLOCATE(WORK1D(NMIL)) + CALL LCMGET(KPEDIT,'NTOT0',WORK1D) + WO1D(IGR)=WORK1D(IMIL) + DEALLOCATE(WORK1D) + ENDDO + ! remove 'DIFF' from 'TOTA' + WRITE(RECNAM2,'(A,10Hmac/TOTAL/,A)') TRIM(RECNAM),'DIFF' + CALL hdf5_info(IPAPX,RECNAM2,RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.EQ.99) CALL XABORT('APXSX2: MISSING DIFF INFO(4).') + CALL hdf5_read_data(IPAPX,RECNAM2,WO2D) + WO1D(:)=WO1D(:)-WO2D(:,1) + DEALLOCATE(WO2D) + WRITE(RECNAM2,'(A,10Hmac/TOTAL/,A)') TRIM(RECNAM),'ABSO' + CALL hdf5_write_data(IPAPX,RECNAM2,WO1D) + DEALLOCATE(WO1D) + ELSE + IF(NOMREA.EQ.'TOTA') THEN + TEXT12='NTOT0' + ELSE IF(NOMREA.EQ.'TOT1') THEN + TEXT12='NTOT1' + ELSE IF(NOMREA.EQ.'NUFI') THEN + TEXT12='NUSIGF' + ELSE IF(NOMREA.EQ.'FISS') THEN + TEXT12='NFTOT' + ELSE IF(NOMREA.EQ.'ENER') THEN + TEXT12='H-FACTOR' + ELSE IF(NOMREA.EQ.'LEAK') THEN + TEXT12='DIFF' + ELSE + TEXT12=NOMREA + ENDIF + ALLOCATE(WO1D(NGRP)) + WO1D(:NGRP)=0.0 + DO IGR=1,NGRP + KPEDIT=LCMGIL(JPEDIT,IGR) + CALL LCMLEN(KPEDIT,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) CYCLE + ALLOCATE(WORK1D(NMIL)) + CALL LCMGET(KPEDIT,TEXT12,WORK1D) + WO1D(IGR)=WORK1D(IMIL) + DEALLOCATE(WORK1D) + ENDDO + IF(NOMREA.EQ.'ENER') THEN + WO1D(:)=WO1D(:)*1.0E-6 + ELSE IF(NOMREA.EQ.'LEAK') THEN + WO1D(:)=WO1D(:)*B2 + ENDIF + WRITE(RECNAM2,'(A,10Hmac/TOTAL/,A)') TRIM(RECNAM), + 1 TRIM(NOMREA) + CALL hdf5_write_data(IPAPX,RECNAM2,WO1D) + DEALLOCATE(WO1D) + ENDIF + ELSE IF(NOMMAC(IMAC).EQ.'RESIDUAL') THEN + ! substract particularized contributions + CALL hdf5_create_group(IPAPX,TRIM(RECNAM)//"mac/RESIDUAL/") + IF(NOMREA.EQ.'DIFF') THEN + WRITE(RECNAM2,'(A,10Hmac/TOTAL/,A)') TRIM(RECNAM),'DIFF' + CALL hdf5_read_data(IPAPX,RECNAM2,WORK2D) + IF(NISOF.GT.0) THEN + WRITE(RECNAM2,'(A,9Hmic/fiss/,A)') TRIM(RECNAM),'DIFF' + CALL hdf5_read_data(IPAPX,RECNAM2,WF3D) + ENDIF + IF(NISOP.GT.0) THEN + WRITE(RECNAM2,'(A,10Hmic/f.p. /,A)') TRIM(RECNAM),'DIFF' + CALL hdf5_read_data(IPAPX,RECNAM2,WP3D) + ENDIF + IF(NISOO.GT.0) THEN + WRITE(RECNAM2,'(A,9Hmic/othe/,A)') TRIM(RECNAM),'DIFF' + CALL hdf5_read_data(IPAPX,RECNAM2,WO3D) + ENDIF + DO ISO=1,NISO + CONC=CONCES(ISO) + IF(TYPISO(ISO).EQ.'FISS') THEN + WORK2D(:,:)=WORK2D(:,:)-CONC*WF3D(:,:,JSO(ISO)) + ELSE IF(TYPISO(ISO).EQ.'F.P.') THEN + WORK2D(:,:)=WORK2D(:,:)-CONC*WP3D(:,:,JSO(ISO)) + ELSE IF(TYPISO(ISO).EQ.'OTHE') THEN + WORK2D(:,:)=WORK2D(:,:)-CONC*WO3D(:,:,JSO(ISO)) + ENDIF + ENDDO + IF(NISOF.GT.0) DEALLOCATE(WF3D) + IF(NISOP.GT.0) DEALLOCATE(WP3D) + IF(NISOO.GT.0) DEALLOCATE(WO3D) + WRITE(RECNAM2,'(A,13Hmac/RESIDUAL/,A)') TRIM(RECNAM),'DIFF' + CALL hdf5_write_data(IPAPX,RECNAM2,WORK2D) + DEALLOCATE(WORK2D) + ELSE IF(NOMREA.EQ.'SCAT') THEN + WRITE(RECNAM2,'(A,10Hmac/TOTAL/,A)') TRIM(RECNAM),'SCAT' + CALL hdf5_read_data(IPAPX,RECNAM2,WORK3D) + IF(NISOF.GT.0) THEN + WRITE(RECNAM2,'(A,9Hmic/fiss/,A)') TRIM(RECNAM),'SCAT' + CALL hdf5_read_data(IPAPX,RECNAM2,WF4D) + ENDIF + IF(NISOP.GT.0) THEN + WRITE(RECNAM2,'(A,10Hmic/f.p. /,A)') TRIM(RECNAM),'SCAT' + CALL hdf5_read_data(IPAPX,RECNAM2,WP4D) + ENDIF + IF(NISOO.GT.0) THEN + WRITE(RECNAM2,'(A,9Hmic/othe/,A)') TRIM(RECNAM),'SCAT' + CALL hdf5_read_data(IPAPX,RECNAM2,WO4D) + ENDIF + DO ISO=1,NISO + CONC=CONCES(ISO) + IF(TYPISO(ISO).EQ.'FISS') THEN + WORK3D(:,:,:)=WORK3D(:,:,:)-CONC*WF4D(:,:,:,JSO(ISO)) + ELSE IF(TYPISO(ISO).EQ.'F.P.') THEN + WORK3D(:,:,:)=WORK3D(:,:,:)-CONC*WP4D(:,:,:,JSO(ISO)) + ELSE IF(TYPISO(ISO).EQ.'OTHE') THEN + WORK3D(:,:,:)=WORK3D(:,:,:)-CONC*WO4D(:,:,:,JSO(ISO)) + ENDIF + ENDDO + IF(NISOF.GT.0) DEALLOCATE(WF4D) + IF(NISOP.GT.0) DEALLOCATE(WP4D) + IF(NISOO.GT.0) DEALLOCATE(WO4D) + WRITE(RECNAM2,'(A,13Hmac/RESIDUAL/,A)') TRIM(RECNAM),'SCAT' + CALL hdf5_write_data(IPAPX,RECNAM2,WORK3D) + DEALLOCATE(WORK3D) + ELSE + WRITE(RECNAM2,'(A,10Hmac/TOTAL/,A)') TRIM(RECNAM), + 1 TRIM(NOMREA) + CALL hdf5_read_data(IPAPX,RECNAM2,WORK1D) + IF(NISOF.GT.0) THEN + WRITE(RECNAM2,'(A,9Hmic/fiss/,A)') TRIM(RECNAM), + 1 TRIM(NOMREA) + CALL hdf5_read_data(IPAPX,RECNAM2,WF2D) + ENDIF + IF(NISOP.GT.0) THEN + WRITE(RECNAM2,'(A,10Hmic/f.p. /,A)') TRIM(RECNAM), + 1 TRIM(NOMREA) + CALL hdf5_read_data(IPAPX,RECNAM2,WP2D) + ENDIF + IF(NISOO.GT.0) THEN + WRITE(RECNAM2,'(A,9Hmic/othe/,A)') TRIM(RECNAM), + 1 TRIM(NOMREA) + CALL hdf5_read_data(IPAPX,RECNAM2,WO2D) + ENDIF + DO ISO=1,NISO + CONC=CONCES(ISO) + IF(TYPISO(ISO).EQ.'FISS') THEN + WORK1D(:)=WORK1D(:)-CONC*WF2D(:,JSO(ISO)) + ELSE IF(TYPISO(ISO).EQ.'F.P.') THEN + WORK1D(:)=WORK1D(:)-CONC*WP2D(:,JSO(ISO)) + ELSE IF(TYPISO(ISO).EQ.'OTHE') THEN + WORK1D(:)=WORK1D(:)-CONC*WO2D(:,JSO(ISO)) + ENDIF + ENDDO + IF(NISOF.GT.0) DEALLOCATE(WF2D) + IF(NISOP.GT.0) DEALLOCATE(WP2D) + IF(NISOO.GT.0) DEALLOCATE(WO2D) + WRITE(RECNAM2,'(A,13Hmac/RESIDUAL/,A)') TRIM(RECNAM), + 1 TRIM(NOMREA) + CALL hdf5_write_data(IPAPX,RECNAM2,WORK1D) + DEALLOCATE(WORK1D) + ENDIF + ENDIF + ENDDO + CALL LCMSIX(IPTEMP,' ',2) + IF(NISO.GT.0) DEALLOCATE(JSO) + RETURN + END diff --git a/Dragon/src/APXTOC.f b/Dragon/src/APXTOC.f new file mode 100644 index 0000000..8829d5e --- /dev/null +++ b/Dragon/src/APXTOC.f @@ -0,0 +1,251 @@ +*DECK APXTOC + SUBROUTINE APXTOC(IPAPX,IMPX,NLAM,NREA,NBISO,NBMAC,NMIL,NPAR, + 1 NVP,NISOF,NISOP,NISOS,NCAL,NGRP,NISOTS,NSURFD,NPRC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover the table of content of an Apex file. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* +*Author(s): +* A. Hebert +* +*Parameters: input +* IPAPX address of the Apex file. +* IMPX print parameter (equal to zero for no print). +* +*Parameters: output +* NLAM number of types of radioactive decay reactions +* NREA number of neutron-induced reaction +* NBISO number of particularized isotopes +* NBMAC number of macroscopic sets +* NMIL number of mixtures in the APEX +* NPAR number of parameters +* NVP number of nodes in the global parameter tree +* NISOF number of particularized fissile isotopes +* NISOP number of particularized fission products +* NISOS number of particularized stable isotopes +* NCAL number of elementary calculations +* NGRP number of energy groups +* NISOTS maximum number of isotopes in output tables +* NSURFD number of discontinuity factors values in the Apex file +* NPRC number of precursors +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPAPX + INTEGER IMPX,NLAM,NREA,NBISO,NBMAC,NMIL,NPAR,NVP,NISOF,NISOP, + 1 NISOS,NCAL,NGRP,NISOTS,NSURFD,NPRC +*---- +* LOCAL VARIABLES +*---- + INTEGER, PARAMETER::IOUT=6 + INTEGER I,II,RANK,TYPE,NBYTE,DIMSR(5) + CHARACTER HSMG*131,RECNAM*80 + CHARACTER(LEN=100), ALLOCATABLE, DIMENSION(:) :: LIST + INTEGER, ALLOCATABLE, DIMENSION(:) :: DIMS_APX + CHARACTER(LEN=4), ALLOCATABLE, DIMENSION(:) :: TYPISO +*---- +* LIST GROUPS AND DATASETS ON THE ROOT FILE +*---- + IF(IMPX.GT.0) THEN + CALL hdf5_list_groups(IPAPX, '/', LIST) + WRITE(*,*) + WRITE(*,*) 'APXTOC: GROUP TABLE OF CONTENTS' + DO I=1,SIZE(LIST) + WRITE(*,*) TRIM(LIST(I)) + ENDDO + DEALLOCATE(LIST) + CALL hdf5_list_datasets(IPAPX, '/', LIST) + WRITE(*,*) + WRITE(*,*) 'APXTOC: DATASET TABLE OF CONTENTS' + DO I=1,SIZE(LIST) + WRITE(*,*) TRIM(LIST(I)) + ENDDO + DEALLOCATE(LIST) + ENDIF +*---- +* RECOVER APEX PARAMETERS +*---- + NMIL=1 + NGRP=0 + CALL hdf5_read_data(IPAPX,"NCALS",NCAL) + IF(hdf5_group_exists(IPAPX,"/physconst/")) THEN + CALL hdf5_info(IPAPX,"/physconst/ENRGS",RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.NE.99) THEN + CALL hdf5_get_shape(IPAPX,"/physconst/ENRGS",DIMS_APX) + ELSE + GO TO 10 + ENDIF + ELSE IF(hdf5_group_exists(IPAPX,"/physco001/")) THEN + CALL hdf5_info(IPAPX,"/physc001/ENRGS",RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.NE.99) THEN + CALL hdf5_get_shape(IPAPX,"/physc001/ENRGS",DIMS_APX) + ELSE + GO TO 10 + ENDIF + ELSE + CALL XABORT('APXTOC: GROUP physconst NOT FOUND IN HDF5 FILE.') + ENDIF + IF(NGRP.EQ.0) THEN + NGRP=DIMS_APX(1)-1 + ELSE IF(NGRP.NE.DIMS_APX(1)-1) THEN + WRITE(HSMG,'(46H APXTOC: THE APEX FILE HAS AN INVALID NUMBER O, + 1 17HF ENERGY GROUPS (,I4,3H VS,I5,2H).)') NGRP,DIMS_APX(1)-1 + CALL XABORT(HSMG) + ENDIF + DEALLOCATE(DIMS_APX) + 10 NBMAC=0 + NREA=0 + IF(hdf5_group_exists(IPAPX,"/explicit/")) THEN + NBISO=0 + CALL hdf5_info(IPAPX,"/explicit/ISONAME",RANK,TYPE,NBYTE,DIMSR) + IF(RANK.NE.99) NBISO=DIMSR(1) + NBMAC=0 + CALL hdf5_info(IPAPX,"/explicit/MACNAME",RANK,TYPE,NBYTE,DIMSR) + IF(RANK.NE.99) NBMAC=DIMSR(1) + NREA=0 + CALL hdf5_info(IPAPX,"/explicit/REANAME",RANK,TYPE,NBYTE,DIMSR) + IF(RANK.NE.99) NREA=DIMSR(1) + ELSE IF(hdf5_group_exists(IPAPX,"/expli001/")) THEN + NBISO=0 + CALL hdf5_info(IPAPX,"/expli001/ISONAME",RANK,TYPE,NBYTE,DIMSR) + IF(RANK.NE.99) NBISO=DIMSR(1) + NBMAC=0 + CALL hdf5_info(IPAPX,"/expli001/MACNAME",RANK,TYPE,NBYTE,DIMSR) + IF(RANK.NE.99) NBMAC=DIMSR(1) + NREA=0 + CALL hdf5_info(IPAPX,"/expli001/REANAME",RANK,TYPE,NBYTE,DIMSR) + IF(RANK.NE.99) NREA=DIMSR(1) + ELSE + CALL XABORT('APXTOC: GROUP explicit NOT FOUND IN APEX FILE.') + ENDIF +*---- +* SET NISOF AND NISOP +*---- + NISOF=0 + NISOP=0 + NISOS=0 + NSURFD=0 + IF(NBISO.GT.0) THEN + IF(hdf5_group_exists(IPAPX,"/physconst/")) THEN + CALL hdf5_get_shape(IPAPX,"/physconst/ISOTA",DIMS_APX) + ELSE IF(hdf5_group_exists(IPAPX,"/physco001/")) THEN + CALL hdf5_get_shape(IPAPX,"/physc001/ISOTA",DIMS_APX) + ENDIF + IF(DIMS_APX(1).NE.NBISO) THEN + WRITE(HSMG,'(44H APXTOC: INCONSISTENT number of ISOTOPES IN , + 1 31Hexplicit AND physconst GROUPS (,I4,3H VS,I5,2H).)') NBISO, + 2 DIMS_APX(1) + CALL XABORT(HSMG) + ENDIF + DEALLOCATE(DIMS_APX) + IF(hdf5_group_exists(IPAPX,"/physconst/")) THEN + CALL hdf5_read_data(IPAPX,"/physconst/ISOTYP",TYPISO) + ELSE IF(hdf5_group_exists(IPAPX,"/physco001/")) THEN + CALL hdf5_read_data(IPAPX,"/physc001/ISOTYP",TYPISO) + ENDIF + DO I=1,NBISO + IF(TYPISO(I).EQ.'FISS') NISOF=NISOF+1 + IF(TYPISO(I).EQ.'F.P.') NISOP=NISOP+1 + IF(TYPISO(I).EQ.'OTHE') NISOS=NISOS+1 + ENDDO + DEALLOCATE(TYPISO) + ENDIF + IF(NCAL.EQ.0) GO TO 20 +*---- +* SET DECAYC, NVALUE AND TREEVAL +*---- + NLAM=0 + NISOTS=0 + IF(hdf5_group_exists(IPAPX,"/physconst/")) THEN + CALL hdf5_info(IPAPX,"/physconst/DECAYC",RANK,TYPE,NBYTE,DIMSR) + ELSE IF(hdf5_group_exists(IPAPX,"/physco001/")) THEN + CALL hdf5_info(IPAPX,"/physc001/DECAYC",RANK,TYPE,NBYTE,DIMSR) + ENDIF + IF(RANK.NE.99) THEN + NLAM=DIMSR(1) + NISOTS=DIMSR(2) + ENDIF + NPAR=0 + CALL hdf5_info(IPAPX,"/paramdescrip/NVALUE",RANK,TYPE,NBYTE,DIMSR) + IF(RANK.NE.99) NPAR=DIMSR(1) + NVP=0 + IF(hdf5_group_exists(IPAPX,"/paramtree")) THEN + CALL hdf5_info(IPAPX,"/paramtree/TREEVAL",RANK,TYPE,NBYTE,DIMSR) + IF(RANK.NE.99) NVP=DIMSR(1) + ENDIF +*---- +* SET NSURFD +*---- + RECNAM='calc 1/miscellaneous/' + CALL hdf5_info(IPAPX,TRIM(RECNAM)//"ADF",RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.NE.99) NSURFD=NSURFD+DIMSR(1) + CALL hdf5_info(IPAPX,TRIM(RECNAM)//"CPDF",RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.NE.99) NSURFD=NSURFD+DIMSR(1) + CALL hdf5_info(IPAPX,TRIM(RECNAM)//"INTERNAL_ADF",RANK,TYPE,NBYTE, + 1 DIMSR) + IF(TYPE.NE.99) NSURFD=NSURFD+DIMSR(1) + CALL hdf5_info(IPAPX,TRIM(RECNAM)//"INTERNAL_CPDF",RANK,TYPE, + 1 NBYTE,DIMSR) + IF(TYPE.NE.99) NSURFD=NSURFD+DIMSR(1) +*---- +* SET NPRC +*---- + NPRC=0 + CALL hdf5_list_groups(IPAPX, "calc 1", LIST) + DO I=1,SIZE(LIST) + IF(TRIM(LIST(I)).EQ.'kinetics') THEN + RECNAM='calc 1/kinetics/LAMBDA' + CALL hdf5_info(IPAPX,TRIM(RECNAM)//"INTERNAL_ADF",RANK,TYPE, + 1 NBYTE,DIMSR) + IF(TYPE.NE.99) NPRC=DIMSR(1) + EXIT + ENDIF +*---- +* SET NMIL +*---- + IF(LIST(I)(:2).EQ.'xs') THEN + IF(LEN(LIST(I)).EQ.2) CYCLE + READ(LIST(I),'(2X,I8)') II + NMIL=MAX(II,NMIL) + ENDIF + ENDDO + DEALLOCATE(LIST) +*---- +* PRINT APEX PARAMETERS +*---- + 20 IF(IMPX.GT.0) THEN + WRITE(IOUT,'(/38H APXTOC: table of content information:)') + WRITE(IOUT,'(32H nb of radioactive reactions =,I3)') NLAM + WRITE(IOUT,'(36H nb of neutron-induced reactions =,I3)') NREA + WRITE(IOUT,'(34H nb of particularized isotopes =,I4)') NBISO + WRITE(IOUT,'(27H nb of macroscopic sets =,I2)') NBMAC + WRITE(IOUT,'(19H nb of mixtures =,I5)') NMIL + WRITE(IOUT,'(28H nb of global parameters =,I4)') NPAR + WRITE(IOUT,'(38H nb of nodes in the parameter tree =,I4)') NVP + WRITE(IOUT,'(42H nb of particularized fissile isotopes =,I4)') + 1 NISOF + WRITE(IOUT,'(42H nb of particularized fission products =,I4)') + 1 NISOP + WRITE(IOUT,'(41H nb of particularized stable isotopes =,I4)') + 1 NISOS + WRITE(IOUT,'(23H nb of calculations =,I9)') NCAL + WRITE(IOUT,'(24H nb of energy groups =,I4)') NGRP + WRITE(IOUT,'(44H maximum nb of isotopes in output tables =, + 1 I4)') NISOTS + WRITE(IOUT,'(39H nb of discontinuity factors values =,I4)') + 1 NSURFD + WRITE(IOUT,'(21H nb of precursors =,I4/)') NPRC + ENDIF + RETURN + END diff --git a/Dragon/src/ASM.f b/Dragon/src/ASM.f new file mode 100644 index 0000000..1e3b68c --- /dev/null +++ b/Dragon/src/ASM.f @@ -0,0 +1,335 @@ +*DECK ASM + SUBROUTINE ASM(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Multigroup assembly operator for system matrices. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): create or modification type(L_PIJ); +* HENTRY(2): read-only type(L_MACROLIB or L_LIBRARY); +* HENTRY(3): read-only type(L_TRACK); +* HENTRY(4): optional read-only sequential binary tracking file. +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40,IOUT=6) + CHARACTER TEXT4*4,HSIGN*12,TEXT12*12,HSMG*131,CDOOR*12, + 1 TITRE*72 + DOUBLE PRECISION DFLOTT + LOGICAL LEAKSW,LNORM,LALBS,LDIFF,LADJ + INTEGER IGP(NSTATE),IPAR(NSTATE),IPP(NSTATE),NALBP + TYPE(C_PTR) IPSYS,IPTRK,IPMACR + INTEGER, ALLOCATABLE, DIMENSION(:) :: MAT,IDL + REAL, ALLOCATABLE, DIMENSION(:) :: VOL +*---- +* PARAMETER VALIDATION +*---- + IF(NENTRY.LE.2) CALL XABORT('ASM: THREE PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('ASM: LC' + 1 //'M OBJECT EXPECTED AT LHS.') + IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) CALL XABORT('ASM: EN' + 1 //'TRY IN CREATE OR MODIFICATION MODE EXPECTED.') + IF((JENTRY(2).NE.2).OR.((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2))) + 1 CALL XABORT('ASM: LCM OBJECT IN READ-ONLY MODE EXPECTED AT FI' + 2 //'RST RHS.') + IF((JENTRY(3).NE.2).OR.((IENTRY(3).NE.1).AND.(IENTRY(3).NE.2))) + 1 CALL XABORT('ASM: LCM OBJECT IN READ-ONLY MODE EXPECTED AT SE' + 2 //'COND RHS.') + CALL LCMGTC(KENTRY(3),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_TRACK') THEN + TEXT12=HENTRY(3) + CALL XABORT('ASM: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_TRACK EXPECTED.') + ENDIF + CALL LCMGTC(KENTRY(3),'TRACK-TYPE',12,CDOOR) + HSIGN='L_PIJ' + IPSYS=KENTRY(1) + IPMACR=KENTRY(2) + IPTRK=KENTRY(3) + CALL LCMPTC(IPSYS,'SIGNATURE',12,HSIGN) + TEXT12=HENTRY(2) + CALL LCMPTC(IPSYS,'LINK.MACRO',12,TEXT12) + TEXT12=HENTRY(3) + CALL LCMPTC(IPSYS,'LINK.TRACK',12,TEXT12) + CALL LCMPTC(IPSYS,'TRACK-TYPE',12,CDOOR) +*---- +* RECOVER TABULATED FUNCTIONS +*---- + CALL XDRTA2 +*---- +* RECOVER TRACKING FILE INFORMATION +*---- + IF(NENTRY.LT.4) THEN + IFTRAK=0 + ELSE + TEXT12=HENTRY(4) + IF(IENTRY(4).EQ.3) THEN + IF(JENTRY(4).NE.2) CALL XABORT('ASM: BINARY TRACKING FILE NA' + 1 //'MED '//TEXT12//' IS NOT IN REAL-ONLY MODE.') + IFTRAK=FILUNIT(KENTRY(4)) + ENDIF + ENDIF +*---- +* RECOVER GENERAL TRACKING INFORMATION +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',IGP) + NREG=IGP(1) + NUN=IGP(2) + LEAKSW=IGP(3).EQ.0 + IBFP=0 + IF(CDOOR.EQ.'MCCG') THEN +* SET ANISOTROPY LEVEL FOR WITHIN-GROUP SCATTERING XS. + NANI=IGP(6) + ELSE IF((CDOOR.EQ.'BIVAC').OR.(CDOOR.EQ.'SN')) THEN +* SET ANISOTROPY LEVEL FOR TOTAL AND WITHIN-GROUP SCATTERING XS. + NANI=MAX(1,IGP(16)) + IF(CDOOR.EQ.'SN') IBFP=IGP(31) + ELSE IF(CDOOR.EQ.'TRIVAC') THEN +* SET ANISOTROPY LEVEL FOR TOTAL AND WITHIN-GROUP SCATTERING XS. + NANI=MAX(1,IGP(32)) + ELSE + NANI=1 + ENDIF + IF(CDOOR.EQ.'MCCG') THEN + CALL LCMLEN(IPTRK,'KEYFLX',LKFL,ITYLCM) + NFUNL=LKFL/NREG + ELSE + NFUNL=1 + ENDIF + ALLOCATE(MAT(NREG),VOL(NREG),IDL(NREG*NFUNL)) + CALL LCMLEN(IPTRK,'MATCOD',ILNLCM,ITYLCM) + IF(ILNLCM.NE.NREG) THEN + CALL XABORT( 'ASM: INCOMPATIBLE NUMBER OF REGIONS') + ENDIF + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'VOLUME',VOL) + CALL LCMGET(IPTRK,'KEYFLX',IDL) + CALL LCMLEN(IPTRK,'TITLE',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGTC(IPTRK,'TITLE',72,TITRE) + ELSE + TITRE='*** NO TITLE PROVIDED ***' + ENDIF +*---- +* RECOVER MACROLIB PARAMETERS +*---- + CALL LCMGTC(IPMACR,'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_LIBRARY') THEN + CALL LCMSIX(IPMACR,'MACROLIB',1) + ELSE IF(HSIGN.NE.'L_MACROLIB') THEN + TEXT12=HENTRY(2) + CALL XABORT('ASM: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_MACROLIB EXPECTED.') + ENDIF + CALL LCMGET(IPMACR,'STATE-VECTOR',IPAR) + NGRP=IPAR(1) + MAXMIX=IPAR(2) + ITRANC=IPAR(6) + NALBP=IPAR(8) + LDIFF=IPAR(9).EQ.1 + NW=IPAR(10) + LADJ=IPAR(13).EQ.1 + IF(IGP(4).GT.MAXMIX) THEN + WRITE(HSMG,'(45HASM: THE NUMBER OF MIXTURES IN THE TRACKING (, + 1 I5,55H) IS GREATER THAN THE NUMBER OF MIXTURES IN THE MACROLI, + 2 3HB (,I5,2H).)') IGP(4),MAXMIX + CALL XABORT(HSMG) + ENDIF +* + ITPIJ=1 + LNORM=.FALSE. + LALBS=.FALSE. + IPHASE=2 + ISTRM=1 + KNORM=4 + IF(JENTRY(1).EQ.1) THEN + CALL LCMGTC(KENTRY(1),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_PIJ') THEN + TEXT12=HENTRY(1) + CALL XABORT('ASM: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_PIJ EXPECTED.') + ENDIF + CALL LCMGET(KENTRY(1),'STATE-VECTOR',IPP) + IF((IPP(8).NE.NGRP).OR.(IPP(9).NE.NUN)) THEN + WRITE(HSMG,'(36HASM: INCONSISTENT NUMBER OF GROUPS (,I3, + 1 3H VS,I4,15H) OR UNKNOWNS (,I5,3H VS,I8,2H).)') IPP(8), + 2 NGRP,IPP(9),NUN + CALL XABORT(HSMG) + ENDIF + ITPIJ=IPP(1) + LNORM=IPP(2).EQ.0 + LALBS=IPP(3).EQ.0 + IPHASE=IPP(5) + ISTRM=IPP(6) + KNORM=IPP(7) + ELSE IF(JENTRY(1).NE.0) THEN + CALL XABORT('ASM: NO LHS OBJECT.') + ENDIF + IMPX=1 + NANIST=NANI + 15 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.10) GO TO 40 + 20 IF(INDIC.NE.3) CALL XABORT('ASM: CHARACTER DATA EXPECTED(1).') + IF(TEXT4.EQ.'EDIT') THEN + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('ASM: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT4.EQ.'PNOR') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('ASM: CHARACTER DATA EXPECTED(2).') + IF(TEXT4.EQ.'NONE') THEN + KNORM=0 + ELSE IF(TEXT4.EQ.'GELB') THEN + KNORM=1 + ELSE IF(TEXT4.EQ.'DIAG') THEN + KNORM=2 + ELSE IF(TEXT4.EQ.'NONL') THEN + KNORM=3 + ELSE IF(TEXT4.EQ.'HELI') THEN + KNORM=4 + ELSE + GO TO 20 + ENDIF + ELSE IF(TEXT4.EQ.'ARM') THEN + IPHASE=1 + ELSE IF(TEXT4(1:3).EQ.'PIJ') THEN + IPHASE=2 + IF(TEXT4(4:4).EQ.'K') THEN + IF(CDOOR.EQ.'EXCELL') THEN + ISTRM=3 + ITPIJ=ITPIJ+2 + NANI=MAX(2,NANI) + NANIST=NANI + ELSE + WRITE(IOUT,6300) CDOOR + ENDIF + ENDIF + 30 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('ASM: CHARACTER DATA EXPECTED(3).') + IF(TEXT4.EQ.'NORM') THEN + LNORM=.TRUE. + ELSE IF(TEXT4.EQ.'ALBS') THEN + LALBS=.TRUE. + IF(.NOT.LEAKSW) THEN + CALL XABORT('ASM: INVALID BOUNDARY CONDITIONS. THE ALBS ' + 1 //'OPTION REQUIRES SOME BOUNDARY LEAKAGE.') + ENDIF + ELSE + GO TO 20 + ENDIF + GO TO 30 + ELSE IF(TEXT4.EQ.'SKIP') THEN + ITPIJ=ITPIJ+1 + ELSE IF(TEXT4.EQ.'ECCO') THEN + ISTRM=2 + NANI=MAX(2,NANI) + NANIST=NANI + ELSE IF(TEXT4.EQ.'HETE') THEN + ISTRM=3 + NANIST=MAX(2,NANI) + ELSE IF(TEXT4.EQ.';') THEN + GO TO 40 + ELSE + CALL XABORT('ASM: '//TEXT4//' IS AN INVALID KEY WORD.') + ENDIF + GO TO 15 +*---- +* CHECK FOR THE ANISOTROPY SETTINGS COHERENCE +*---- + 40 IF((ITRANC.NE.0).AND.(NANI.GT.1).AND.(ISTRM.EQ.1)) THEN + WRITE(IOUT,6400) CDOOR,NANI + ITRANC=0 + ENDIF + IF((IMPX.GE.1).AND.(NW.GT.0)) THEN + WRITE (IOUT,'(/44H ASM: A LEAKAGE CORRECTION IS PERFORMED (NW=, + 1 I2,2H).)') NW + ENDIF +*---- +* STORE PIJ PARAMETERS +*---- + IPP(:NSTATE)=0 + IPP(1)=ITPIJ + IPP(2)=1 + IF(LNORM) IPP(2)=0 + IPP(3)=1 + IF(LALBS) IPP(3)=0 + IPP(5)=IPHASE + IPP(6)=ISTRM + IPP(7)=KNORM + IPP(8)=NGRP + IPP(9)=NUN + IPP(10)=MAXMIX + IPP(11)=NANI + IF(LDIFF) IPP(12)=1 + IPP(13)=IBFP + CALL LCMPUT(IPSYS,'STATE-VECTOR',NSTATE,1,IPP) +*---- +* BUILD COLLISION PROBABILITIES +*---- + CALL ASMDRV(IPSYS,IPTRK,IPMACR,IFTRAK,CDOOR,IMPX,NGRP,MAXMIX, + 1 NREG,NANI,NANIST,NW,MAT,VOL,LEAKSW,ITRANC,LDIFF,IBFP,TITRE, + 2 ITPIJ,LNORM.OR.LALBS,IPHASE,ISTRM,KNORM,NALBP) +* + IF(IMPX.GE.5) CALL LCMLIB(IPSYS) +*---- +* RELEASE GENERAL TRACKING INFORMATION +*---- + DEALLOCATE(IDL,VOL,MAT) + CALL LCMSIX(IPMACR,' ',0) + IF(IMPX.GE.1) THEN + WRITE (IOUT,6040)IMPX,(IPP(I),I=1,3),(IPP(I),I=5,13) + WRITE (IOUT,'(5H DOOR,13X,1H(,A,1H))') CDOOR + ENDIF + RETURN +* + 6300 FORMAT(//' *** WARNING: OPTION PIJK IS INVALID FOR DOOR = ', + > A12/' OPTION PIJ USED INSTEAD') + 6400 FORMAT(//' *** WARNING: DOOR ',A12,'IS USED WITH AN ANISOTROPY', + > ' LEVEL FROM L_TRACK =',I2,' AND WITH A TRANSPORT CORRECTION S', + > 'ET IN LIB:.'/15X,'--> THE TRANSPORT CORRECTION IS DISABLED.'/) + 6040 FORMAT(/8H OPTIONS/8H -------/ + 1 7H IMPX ,I8,30H (0=NO PRINT/1=SHORT/2=MORE)/ + 2 7H ITPIJ ,I8,30H (1=WIJ/2=PIJ/3=WIJK/4=PIJK)/ + 3 7H LNORM ,I8,34H (0=NORMALIZE PIJ TO 1/1=DO NOT)/ + 4 7H LALBS ,I8,36H (0=RECOVER AND SAVE WIS/1=DO NOT)/ + 5 7H IPHASE,I8,43H (1=GENERAL FLUX SOLUTION/2=PIJ APPROACH)/ + 6 7H ISTRM ,I8,44H (1=HOMO BN OR NO LEAKAGE/2=ECCO/3=TIBERE)/ + 7 7H KNORM ,I8,46H (0=NO/1=GELBARD/2=DIAGONAL/3=NON-LINEAR/4=H, + 8 6HELIOS)/ + 9 7H NGRP ,I8,21H (NUMBER OF GROUPS)/ + 1 7H NUN ,I8,23H (NUMBER OF UNKNOWNS)/ + 2 7H NBMIX ,I8,23H (NUMBER OF MIXTURES)/ + 3 7H NANI ,I8,44H (NUMBER OF LEGENDRE ORDERS SCATTERING XS)/ + 4 7H IDIFF ,I8,47H (0/1: DIFFUSION COEFFICIENTS ABSENT/PRESENT)/ + 5 7H IBFP ,I8,44H (0/1/2: FOKKER-PLANCK SOLUTION OFF/ON/ON)) + END diff --git a/Dragon/src/ASMDRV.f b/Dragon/src/ASMDRV.f new file mode 100644 index 0000000..27e7296 --- /dev/null +++ b/Dragon/src/ASMDRV.f @@ -0,0 +1,361 @@ +*DECK ASMDRV + SUBROUTINE ASMDRV(IPSYS,IPTRK,IPMACR,IFTRAK,CDOOR,IPRNTP,NGROUP, + > NBMIX,NREGIO,NANI,NANIST,NW,MATCOD,VOLUME, + > LEAKSW,ITRANC,LDIFF,IBFP,TITRE,ITPIJ,LNORM, + > IPHASE,ISTRM,KNORM,NALBP) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Dragon assembly and pij phases. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPSYS pointer to the pij LCM object. +* IPTRK pointer to the tracking LCM object. +* IPMACR pointer to the macrolib LCM object. +* IFTRAK file unit number for tracks. +* CDOOR name of the pij calculation door. +* IPRNTP print option for pij calculations. +* NGROUP number of groups treated. +* NBMIX number of mixtures considered. +* NREGIO number of regions considered . +* NANI number of Legendre orders for scattering cross sections. +* NANIST number of Legendre orders for scattering cross sections +* if streaming leakage is present. +* NW type of weighting for P1 cross section info (=0: P0; =1: P1). +* MATCOD mixture code in each region. +* VOLUME volume of each region. +* LEAKSW leakage switch. +* ITRANC type of transport correction. +* LDIFF diffusion coefficient switch. +* IBFP Fokker-Planck solution (=0: off; =1/2: on). +* TITRE execution title. +* ITPIJ type of collision probability available: +* =1 scatt mod pij (wij); +* =2 stand. pij; +* =3 scatt mod pij+pijk (wij,wijk); +* =4 stand. pij+pijk. +* LNORM switch for removing leakage from collision probabilities and +* keeping the pis information. +* IPHASE type of assembly (=1 for ass and 2 for pij). +* ISTRM type of streaming effect: +* =1 no streaming effect; +* =2 isotropic streaming effect; +* =3 anisotropic streaming effect. +* KNORM type of pij normalization. +* NALBP number of physical albedos. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER CDOOR*12,TITRE*72,TEXT12*12 + LOGICAL LEAKSW,LDIFF,LNORM + TYPE(C_PTR) IPSYS,IPTRK,IPMACR + INTEGER IFTRAK,IPRNTP,NGROUP,NBMIX,NREGIO,NANI,NANIST,NW, + > MATCOD(NREGIO),ITRANC,IBFP,ITPIJ,IPHASE,ISTRM,KNORM, + > NALBP + REAL VOLUME(NREGIO) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6,ILCMUP=1,ILCMDN=2) + LOGICAL LTRANC + CHARACTER HSMG*130,CM*2 + INTEGER, ALLOCATABLE, DIMENSION(:) :: NPSYS + TYPE(C_PTR) JPSYS,KPSYS,JPMACR,KPMACR + REAL, ALLOCATABLE, DIMENSION(:) :: TEMP,ENERGY + REAL, ALLOCATABLE, DIMENSION(:,:) :: XSSCOR,XSDIFF,ALBP,EMOMTR + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: XSSIGT,XSSIGW,ESTOPW +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NPSYS(NGROUP)) + ALLOCATE(XSSIGT(0:NBMIX,NGROUP,NW+1),XSSCOR(NBMIX,NGROUP), + > XSSIGW(0:NBMIX,NANIST,NGROUP),XSDIFF(0:NBMIX,NGROUP), + > ESTOPW(0:NBMIX,2,NGROUP),ENERGY(NGROUP+1), + > EMOMTR(0:NBMIX,NGROUP)) + ALLOCATE(ALBP(NALBP,NGROUP)) +*---- +* CHECK MIXTURE INDICES. +*---- + DO 10 I=1,NREGIO + IF(MATCOD(I).GT.NBMIX) THEN + WRITE (HSMG,5090) NBMIX + CALL XABORT(HSMG) + ENDIF + 10 CONTINUE +*---- +* RECOVER PHYSICAL ALBEDOS. +*---- + IF(NALBP.GT.0) THEN + CALL LCMLEN(IPMACR,'ALBEDO',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.NALBP*NGROUP) THEN + CALL LCMGET(IPMACR,'ALBEDO',ALBP) + ELSE + CALL LCMLIB(IPMACR) + CALL XABORT('ASMDRV: READ ERROR ON LCM RECORD= ALBEDO') + ENDIF + ENDIF +*---- +* RECOVER ENERGY MESH VALUES. +*---- + IF(IBFP.GT.0) CALL LCMGET(IPMACR,'ENERGY',ENERGY) +*---- +* READ X-SECTIONS AND COMPUTE TRANSPORT CORRECTED X-SECTIONS. +*---- + IF(IPRNTP.GE.1) THEN + IF(IPHASE.EQ.1) THEN + WRITE(IUNOUT,6200) CDOOR + ELSE + WRITE(IUNOUT,6201) CDOOR + ENDIF + IF(ITRANC.NE.0) WRITE(IUNOUT,6101) ITRANC + ENDIF + IF(IPRNTP.GE.2) THEN + WRITE(IUNOUT,6000) + WRITE(IUNOUT,6001) (IREGIO,VOLUME(IREGIO),MATCOD(IREGIO), + > IREGIO=1,NREGIO) + ENDIF + CALL LCMLEN(IPMACR,'GROUP',ILON,ITYLCM) + IF(ILON.NE.NGROUP) CALL XABORT('ASMDRV: INVALID MACROLIB.') + JPMACR=LCMGID(IPMACR,'GROUP') + JPSYS=LCMLID(IPSYS,'GROUP',NGROUP) + ITRAN2=0 + DO 60 IGR=1,NGROUP + KPMACR=LCMGIL(JPMACR,IGR) + DO 20 IW=1,MIN(NW+1,10) + WRITE(TEXT12,'(4HNTOT,I1)') IW-1 + CALL LCMLEN(KPMACR,TEXT12,ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,TEXT12,XSSIGT(1,IGR,IW)) + XSSIGT(0,IGR,IW)=0.0 + ELSE IF(IW.EQ.1) THEN + CALL LCMLIB(KPMACR) + CALL XABORT('ASMDRV: READ ERROR ON LCM RECORD= TOTAL') + ELSE + CALL LCMGET(KPMACR,'NTOT0',XSSIGT(1,IGR,IW)) + XSSIGT(0,IGR,IW)=0.0 + ENDIF + 20 CONTINUE + DO 30 IL=1,NANIST + WRITE(CM,'(I2.2)') IL-1 + CALL LCMLEN(KPMACR,'SIGW'//CM,ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'SIGW'//CM,XSSIGW(1,IL,IGR)) + XSSIGW(0,IL,IGR)=0.0 + ELSE IF(IL.EQ.1) THEN + CALL LCMLIB(KPMACR) + CALL XABORT('ASMDRV: READ ERROR ON LCM RECORD= SIGW'//CM) + ELSE + XSSIGW(0:NBMIX,IL,IGR)=0.0 + ENDIF + 30 CONTINUE + CALL LCMLEN(KPMACR,'TRANC',ILCMLN,ITYLCM) + LTRANC=ILCMLN.GT.0 + IF((ITRANC.NE.0).AND.LTRANC) THEN +* TRANSPORT CORRECTION (INCLUDE THE LEAKAGE CORRECTION). + ITRAN2=ITRANC + CALL LCMGET(KPMACR,'TRANC',XSSCOR(1,IGR)) + ELSE + ITRAN2=0 + XSSCOR(:NBMIX,IGR)=0.0 + ENDIF + IF(ITRAN2.NE.0) THEN +* INCLUDE TRANSPORT CORRECTION. + DO 40 IMAT=1,NBMIX + DELTA=XSSIGT(IMAT,IGR,1)-XSSIGW(IMAT,1,IGR) + XSSIGT(IMAT,IGR,1)=XSSIGT(IMAT,IGR,1)-XSSCOR(IMAT,IGR) + XSSIGW(IMAT,1,IGR)=XSSIGT(IMAT,IGR,1)-DELTA +* Tibere is using transport-corrected XS for the second +* equation. Scattering reduction must be performed with +* transport-corrected SIGS1 values. + IF(ISTRM.EQ.3) THEN + XSSIGW(IMAT,2,IGR)=XSSIGW(IMAT,2,IGR)-XSSCOR(IMAT,IGR) + ENDIF + 40 CONTINUE + ENDIF +* + IF(NW.GT.0) THEN +* PERFORM A P0_TOTAL LEAKAGE CORRECTION. + DO 55 IW=2,MIN(NANIST,NW+1) + DO 50 IMAT=1,NBMIX + DELTA=XSSIGT(IMAT,IGR,1)-XSSIGT(IMAT,IGR,IW) + IF((ITRAN2.NE.0).AND.(DELTA.NE.0.0)) THEN + CALL XABORT('ASMDRV: CANNOT PERFORM BOTH TRANSPORT AND LEA' + > //'KAGE CORRECTIONS.') + ENDIF + XSSIGT(IMAT,IGR,IW)=XSSIGT(IMAT,IGR,1) + XSSIGW(IMAT,IW,IGR)=XSSIGW(IMAT,IW,IGR)+DELTA + 50 CONTINUE + 55 CONTINUE + ENDIF +* + IF(IPRNTP.GE.3) THEN + WRITE(IUNOUT,6002) IGR + WRITE(IUNOUT,6003) (IMIX,XSSIGT(IMIX,IGR,1),XSSIGW(IMIX,1,IGR) + > ,IMIX=1,NBMIX) + ENDIF + IF(LDIFF) THEN +* INCLUDE DIFFUSION COEFFICIENTS. + CALL LCMGET(KPMACR,'DIFF',XSDIFF(1,IGR)) + XSDIFF(0,IGR)=1.0E10 + ENDIF + IF(IBFP.GT.0) THEN +* INCLUDE RESTRICTED STOPPING POWER. + ALLOCATE(TEMP(2*NBMIX)) + CALL LCMGET(KPMACR,'ESTOPW',TEMP) + ESTOPW(0,:2,IGR)=0.0 + ESTOPW(1:NBMIX,1,IGR)=TEMP(:NBMIX) + ESTOPW(1:NBMIX,2,IGR)=TEMP(NBMIX+1:) + DEALLOCATE(TEMP) +* INCLUDE RESTRICTED MOMENTUM TRANSFER. + EMOMTR(0,IGR)=0.0 + CALL LCMLEN(KPMACR,'EMOMTR',ILCMLN,ITYLCM) + IF(ILCMLN.NE.0) THEN + ALLOCATE(TEMP(NBMIX)) + CALL LCMGET(KPMACR,'EMOMTR',TEMP) + EMOMTR(1:NBMIX,IGR)=TEMP(:NBMIX) + DEALLOCATE(TEMP) + ELSE + EMOMTR(1:NBMIX,IGR)=0.0 + ENDIF + ENDIF + 60 CONTINUE +*---- +* COMPUTE THE CP OR RESPONSE MATRIX INFORMATION FOR THE SOLUTION OF +* THE BALANCE EQUATION. +*---- + IPIJK=1 + IF(ISTRM.EQ.3) IPIJK=4 + DO 70 IGR=1,NGROUP + NPSYS(IGR)=IGR + KPSYS=LCMDIL(JPSYS,IGR) + CALL LCMPUT(KPSYS,'DRAGON-TXSC',NBMIX+1,2,XSSIGT(0,IGR,1)) + IF(NW.GT.0) THEN + CALL LCMPUT(KPSYS,'DRAGON-T1XSC',NBMIX+1,2,XSSIGT(0,IGR,2)) + ENDIF + CALL LCMPUT(KPSYS,'DRAGON-S0XSC',(NBMIX+1)*NANI,2,XSSIGW(0,1,IGR)) + IF(LDIFF) CALL LCMPUT(KPSYS,'DRAGON-DIFF',NBMIX+1,2,XSDIFF(0,IGR)) + IF(IBFP.GT.0) THEN + CALL LCMPUT(KPSYS,'DRAGON-ESTOP',(NBMIX+1)*2,2,ESTOPW(0,1,IGR)) + CALL LCMPUT(KPSYS,'DRAGON-EMOMT',NBMIX+1,2,EMOMTR(0,IGR)) + DELTAE=(ENERGY(IGR)-ENERGY(IGR+1))/1.0E6 + CALL LCMPUT(KPSYS,'DRAGON-DELTE',1,2,DELTAE) + IF(IGR.EQ.NGROUP) THEN + CALL LCMPUT(KPSYS,'DRAGON-ISLG',1,1,1) + ELSE + CALL LCMPUT(KPSYS,'DRAGON-ISLG',1,1,0) + ENDIF + ENDIF + IF(NALBP.GT.0) CALL LCMPUT(KPSYS,'ALBEDO',NALBP,2,ALBP(1,IGR)) + 70 CONTINUE + IF(IBFP.GT.0) THEN + CALL LCMPUT(IPSYS,'ECUTOFF',1,2,ENERGY(NGROUP+1)/1.0E6) + ENDIF + IF(IPHASE.EQ.2) THEN + CALL DOORPV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IPRNTP,NGROUP, + > NREGIO,NBMIX,NANI,MATCOD,VOLUME,KNORM,IPIJK,LEAKSW,ITPIJ, + > LNORM,TITRE,NALBP) + ELSE + CALL DOORAV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IPRNTP,NGROUP, + > NREGIO,NBMIX,NANI,NW,MATCOD,VOLUME,KNORM,LEAKSW,TITRE,NALBP, + > ISTRM) + ENDIF +*---- +* COMPUTE THE P1 CP OR RESPONSE MATRIX INFORMATION FOR THE ECCO +* ISOTROPIC STREAMING MODEL. +*---- + IF(ISTRM.EQ.2) THEN + CALL LCMSIX(IPSYS,'STREAMING',ILCMUP) + JPSYS=LCMLID(IPSYS,'GROUP',NGROUP) + IF(ITRAN2.NE.0) THEN +* REMOVE TRANSPORT CORRECTION. + DO 85 IGR=1,NGROUP + DO 80 IMAT=1,NBMIX + XSSIGT(IMAT,IGR,1)=XSSIGT(IMAT,IGR,1)+XSSCOR(IMAT,IGR) + XSSIGW(IMAT,1,IGR)=XSSIGW(IMAT,1,IGR)+XSSCOR(IMAT,IGR) + 80 CONTINUE + 85 CONTINUE + ENDIF + IF(NANIST.LE.1) CALL XABORT('ASMDRV: MISSING P1 XS INFO.') + DO 90 IGR=1,NGROUP + NPSYS(IGR)=IGR + KPSYS=LCMDIL(JPSYS,IGR) + CALL LCMPUT(KPSYS,'DRAGON-TXSC',NBMIX+1,2,XSSIGT(0,IGR,1)) + CALL LCMPUT(KPSYS,'DRAGON-S0XSC',(NBMIX+1)*(NANIST-1),2, + > XSSIGW(0,2,IGR)) + IF(LDIFF) CALL LCMPUT(KPSYS,'DRAGON-DIFF',NBMIX+1,2, + > XSDIFF(0,IGR)) + 90 CONTINUE + IPIJK=1 + IF(IPHASE.EQ.2) THEN + CALL DOORPV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IPRNTP,NGROUP, + > NREGIO,NBMIX,NANIST-1,MATCOD,VOLUME,KNORM,IPIJK,LEAKSW, + > ITPIJ,LNORM,TITRE,NALBP) + ELSE + CALL DOORAV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IPRNTP,NGROUP, + > NREGIO,NBMIX,NANIST-1,NW,MATCOD,VOLUME,KNORM,LEAKSW,TITRE, + > NALBP,ISTRM) + ENDIF + CALL LCMSIX(IPSYS,' ',ILCMDN) + ENDIF +*---- +* COMPUTE RESPONSE MATRIX INFORMATION FOR THE TIBERE +* ANISOTROPIC STREAMING MODEL. +*---- + IF((ISTRM.EQ.3).AND.(IPHASE.EQ.1)) THEN + CALL LCMSIX(IPSYS,'STREAMING',ILCMUP) + JPSYS=LCMLID(IPSYS,'GROUP',NGROUP) + IF(NANIST.LE.1) CALL XABORT('ASMDRV: MISSING P1 XS INFO.') + DO 100 IGR=1,NGROUP + NPSYS(IGR)=IGR + KPSYS=LCMDIL(JPSYS,IGR) + CALL LCMPUT(KPSYS,'DRAGON-TXSC',NBMIX+1,2,XSSIGT(0,IGR,1)) + CALL LCMPUT(KPSYS,'DRAGON-S0XSC',(NBMIX+1)*(NANIST-1),2, + > XSSIGW(0,2,IGR)) + IF(LDIFF) CALL LCMPUT(KPSYS,'DRAGON-DIFF',NBMIX+1,2, + > XSDIFF(0,IGR)) + 100 CONTINUE + CALL DOORAV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IPRNTP,NGROUP, + > NREGIO,NBMIX,NANIST-1,NW,MATCOD,VOLUME,KNORM,LEAKSW,TITRE, + > NALBP,ISTRM) + CALL LCMSIX(IPSYS,' ',ILCMDN) + ENDIF + IF(LNORM) LEAKSW=.FALSE. +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(ALBP) + DEALLOCATE(ENERGY,ESTOPW,EMOMTR,XSDIFF,XSSCOR,XSSIGW,XSSIGT) + DEALLOCATE(NPSYS) + RETURN +*---- +* FORMATS +*---- + 5090 FORMAT(32HASMDRV: INVALID VALUE OF NBMIX (,I5,2H).) + 6000 FORMAT(//30X,' EDITION REGION/VOLUME/MIXTURE '// + >3(5X,'REGION',5X,'VOLUME ',5X,'MIXTURE')/) + 6001 FORMAT(1P,3(5X,I4,4X,E12.5,4X,I4,4X)) + 6002 FORMAT(//30X,' G R O U P : ',I5//31X, + >'TOTAL AND WITHIN-GROUP MACROSCOPIC CROSS SECTIONS PER MIXTURE '/) + 6003 FORMAT(3(1X,'MIXTURE',4X,'NTOT0',11X,'SIGW',3X)/ + >1P,3(1X,I4,3X,E12.5,3X,E12.5)) + 6101 FORMAT(//' USE TRANSPORT CORRECTED CROSS-SECTIONS (ITRANC=',I4, + >' )') + 6200 FORMAT(//' COMPUTATION OF DRAGON RESPONSE MATRICES BY DOOR =', + >3X,A12) + 6201 FORMAT(//' COMPUTATION OF DRAGON COMPLETE CP BY DOOR =', + >3X,A12) + END diff --git a/Dragon/src/AUTDRV.f b/Dragon/src/AUTDRV.f new file mode 100644 index 0000000..b8900a0 --- /dev/null +++ b/Dragon/src/AUTDRV.f @@ -0,0 +1,455 @@ +*DECK AUTDRV + SUBROUTINE AUTDRV(IPLI0,IPTRK,IPLIB,IFTRAK,INDREC,CDOOR,IMPX, + 1 IGRMIN,IGRMAX,NGRP,NBMIX,NREG,NUN,NBISO,NL,NED,NDEL,LEAKSW, + 2 ITRANC,IPHASE,TITR,KSPH,NRES,NPASS,ICALC,IALTER,MAXTRA,ISEED, + 3 DIL,DELI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Driver for a resonance self-shielding calculation with the Autosecol +* method. +* +*Copyright: +* Copyright (C) 2023 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLI0 pointer to the internal microscopic cross section library +* builded by the self-shielding module (L_LIBRARY signature). +* IPTRK pointer to the tracking (L_TRACK signature). +* IPLIB pointer to the internal microscopic cross section library +* with subgroups (L_LIBRARY signature). +* IFTRAK unit number of the sequential binary tracking file. +* INDREC access flag for the internal microscopic cross section library +* builded by the self-shielding module (=1 IPLI0 access in +* creation mode; =2 in modification mode). +* CDOOR name of the geometry/solution operator. +* IMPX print flag (equal to zero for no print). +* IGRMIN first group where the self-shielding is applied. +* IGRMAX most thermal group where the self-shielding is applied. +* NGRP number of energy groups. +* NBMIX number of mixtures in the internal library. +* NREG number of regions. +* NUN number of unknowns per energy group. +* NBISO number of isotopes specifications in the internal library. +* NL number of Legendre orders required in the calculation +* (NL=1 or higher). +* NED number of extra vector edits. +* NDEL number of delayed neutron precursor groups. +* LEAKSW leakage flag (LEAKSW=.TRUE. if neutron leakage through +* external boundary is present). +* ITRANC type of transport correction. +* IPHASE type of flux solution (=1 use a native flux solution door; +* =2 use collision probabilities). +* TITR title. +* KSPH SPH equivalence flag (=0 no SPH correction; =1 SPH correction +* in the fuel). +* NRES number of self-shielding zones, as given by LIB:. +* NPASS number of outer iterations. +* ICALC simplified self-shielding flag (=1 IPLI0 is containing ICALC +* data. =0 no ICALC data). +* IALTER type of elastic slowing-down kernel (=0: use exact kernel; +* =1: use an approximate kernel for the resonant isotopes). +* MAXTRA maximum number of down-scattering terms. +* ISEED the seed for the generation of random numbers in the +* unresolved energy domain. +* DIL microscopic dilution cross section of each isotope. +* +*Parameters: output +* DELI elementary lethargy width used by the elastic kernel. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLI0,IPTRK,IPLIB + INTEGER IFTRAK,INDREC,IMPX,IGRMIN,IGRMAX,NGRP,NBMIX,NREG,NUN, + 1 NBISO,NL,NED,NDEL,ITRANC,IPHASE,KSPH,NRES,NPASS,ICALC,IALTER, + 2 MAXTRA,ISEED + REAL DIL(NBISO),DELI + CHARACTER CDOOR*12,TITR*72 + LOGICAL LEAKSW +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40,MAXRSS=300,MAXESP=4) + TYPE(C_PTR) JPLI0,KPLI0,JPLIB,KPLIB + CHARACTER HSMG*131,TEXT4*4,NAM1*4,FNAM1*4,NAM2*12,FNAM2*12, + 1 TEXT8*8 + INTEGER IPAR(NSTATE),IRSS(MAXRSS),IESP(MAXESP+1) + REAL TMPDAY(3),EESP(MAXESP+1) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MAT,KEYFLX,MIX,IEVOL,ITYPE, + 1 LSHI,IHSUF,ILLIB,JCEDM,NBIN,NBIN_AU + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISONAM,IHLIB + REAL, ALLOCATABLE, DIMENSION(:) :: VOL,TN,DEN,ENER,DELTAU,EBIN,GS, + 1 VOLMIX + LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASK,MASKL + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO1 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(MAT(NREG),KEYFLX(NREG),ISONAM(3,NBISO),MIX(NBISO), + 1 IEVOL(NBISO),ITYPE(NBISO),LSHI(NBISO),IHSUF(NBISO), + 2 IHLIB(2,NBISO),ILLIB(NBISO),IPISO1(NBISO)) + ALLOCATE(VOL(NREG),TN(NBISO),DEN(NBISO),ENER(NGRP+1)) +*---- +* RECOVER USEFUL INFORMATION FROM TRACKING OBJECT. +*---- + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'VOLUME',VOL) + CALL LCMGET(IPTRK,'KEYFLX',KEYFLX) +*---- +* RECOVER USEFUL INFORMATION FROM LIBRARY OBJECTS. +*---- + CALL LCMGET(IPLIB,'ISOTOPESUSED',ISONAM) + CALL LCMGET(IPLIB,'ISOTOPESMIX',MIX) + CALL LCMGET(IPLIB,'ISOTOPESTODO',IEVOL) + CALL LCMGET(IPLIB,'ISOTOPESTYPE',ITYPE) + CALL LCMGET(IPLIB,'ISOTOPESTEMP',TN) +* + CALL LCMPUT(IPLI0,'ISOTOPESMIX',NBISO,1,MIX) + CALL LCMPUT(IPLI0,'ISOTOPESTODO',NBISO,1,IEVOL) + CALL LCMPUT(IPLI0,'ISOTOPESTYPE',NBISO,1,ITYPE) + CALL LCMPUT(IPLI0,'ISOTOPESTEMP',NBISO,2,TN) + IF(INDREC.EQ.1) THEN + CALL LCMGET(IPLIB,'ISOTOPESDENS',DEN) + CALL LCMPUT(IPLI0,'ISOTOPESDENS',NBISO,2,DEN) + ELSE IF(INDREC.EQ.2) THEN + CALL LCMGET(IPLI0,'ISOTOPESDENS',DEN) + ENDIF + CALL LCMGET(IPLIB,'ISOTOPESSHI',LSHI) + CALL LCMLEN(IPLIB,'ISOTOPESDSN',NELSN,ITYLCM) + IF(NELSN.GT.0) THEN + NGIS=NGRP*NBISO + ALLOCATE(GS(NGIS)) + CALL LCMGET(IPLIB,'ISOTOPESDSN',GS) + CALL LCMPUT(IPLI0,'ISOTOPESDSN',NGIS,2,GS) + CALL LCMGET(IPLIB,'ISOTOPESDSB',GS) + CALL LCMPUT(IPLI0,'ISOTOPESDSB',NGIS,2,GS) + DEALLOCATE(GS) + ENDIF + CALL LCMGET(IPLIB,'DELTAU',ENER) + CALL LCMPUT(IPLI0,'DELTAU',NGRP,2,ENER) + CALL LCMGET(IPLIB,'ENERGY',ENER) + CALL LCMPUT(IPLI0,'ENERGY',NGRP+1,2,ENER) + CALL LCMLEN(IPLIB,'CHI-LIMITS',NBESP,ITYLCM) + IF(NBESP.GT.0) THEN + NBESP=NBESP-1 + IF(NBESP.GT.MAXESP) CALL XABORT('AUTDRV: MAXESP OVERFLOW.') + CALL LCMGET(IPLIB,'CHI-LIMITS',IESP) + CALL LCMPUT(IPLI0,'CHI-LIMITS',NBESP+1,1,IESP) + CALL LCMGET(IPLIB,'CHI-ENERGY',EESP) + CALL LCMPUT(IPLI0,'CHI-ENERGY',NBESP+1,2,EESP) + ENDIF +*---- +* COMPUTE MIXTURESVOL. +*---- + ALLOCATE(VOLMIX(NBMIX)) + VOLMIX(:NBMIX)=0.0 + DO I=1,NREG + IBM=MAT(I) + IF(IBM.GT.0) VOLMIX(IBM)=VOLMIX(IBM)+VOL(I) + CALL LCMPUT(IPLI0,'MIXTURESVOL',NBMIX,2,VOLMIX) + ENDDO + DEALLOCATE(VOLMIX) +*---- +* RECOVER BIN TYPE INFORMATION (IF AVAILABLE). +* ASSUME THAT THE ELEMENTARY LETHARGY WIDTH DELI IS A RATIONAL FRACTION +* OF THE LETHARGY UNIT. CHECK THIS ASSUMPTION. +*---- + CALL LIBIPS(IPLIB,NBISO,IPISO1) + ALLOCATE(NBIN(NGRP),NBIN_AU(NGRP)) + NBIN(:NGRP)=-1 + DO ISO=1,NBISO + KPLIB=IPISO1(ISO) ! set ISO-th isotope + IF(.NOT.C_ASSOCIATED(KPLIB)) THEN + WRITE(HSMG,'(17HAUTDRV: ISOTOPE '',3A4,17H'' IS NOT ASSOCIAT, + 1 3HED.)') ISONAM(:3,ISO) + CALL XABORT(HSMG) + ENDIF + CALL LCMLEN(KPLIB,'BIN-NFS',LENGT,ITYLCM) + IF(LENGT.EQ.0) CYCLE + CALL LCMGET(KPLIB,'BIN-NFS',NBIN_AU) + DO 10 IGRP=NGRP,1,-1 + IF(NBIN(IGRP).EQ.-1) THEN + NBIN(IGRP)=NBIN_AU(IGRP) + ELSE IF(NBIN(IGRP).NE.NBIN_AU(IGRP)) THEN + WRITE(HSMG,'(38HAUTDRV: INCONSISTENT BIN DATA IN GROUP,I4, + 1 13H OF ISOTOPE '',3A4,2H''.)') IGRP,ISONAM(:3,ISO) + CALL XABORT(HSMG) + ENDIF + 10 CONTINUE + ENDDO + DEALLOCATE(NBIN_AU) + IGRRES=IGRMIN + DO 20 IGRP=IGRMIN,IGRMAX + IGRRES=IGRP + IF(NBIN(IGRP).GT.0) GO TO 30 + 20 CONTINUE + 30 DO 40 IGRP=1,NGRP + IF(NBIN(IGRP).EQ.-1) CALL XABORT('AUTDRV: NBIN SETTING FAILURE.') + 40 CONTINUE + LBIN=SUM(NBIN(:NGRP)) + IF(LBIN.EQ.0) CALL XABORT('AUTDRV: NO AUTOLIB DATA.') + ALLOCATE(DELTAU(LBIN),EBIN(LBIN+1)) + DO ISO=1,NBISO + KPLIB=IPISO1(ISO) ! set ISO-th isotope + CALL LCMLEN(KPLIB,'BIN-NFS',LENGT,ITYLCM) + IF(LENGT.EQ.0) CYCLE + CALL LCMGET(KPLIB,'BIN-ENERGY',EBIN) + EXIT + ENDDO + DELMIN=1.0E10 + IBIN=0 + DO 60 IGRP=1,NGRP + DO 50 IGF=1,NBIN(IGRP) + DELM=LOG(EBIN(IBIN+IGF)/EBIN(IBIN+IGF+1)) + DELMIN=MIN(DELMIN,DELM) + DELTAU(IBIN+IGF)=DELM + 50 CONTINUE + IBIN=IBIN+NBIN(IGRP) + 60 CONTINUE + CALL LCMLEN(KPLIB,'BIN-DELI',LENGT,ITYLCM) + IF((LENGT.EQ.1).AND.(ITYLCM.EQ.2)) THEN + CALL LCMGET(KPLIB,'BIN-DELI',DELI) + ELSE + DELI=1.0/REAL(INT(1.00001/DELMIN)) + ENDIF + IBIN=0 + ERR=0.0 + DO 80 IGRP=1,NGRP + DO 70 IGF=1,NBIN(IGRP) + LARGH=INT(DELTAU(IBIN+IGF)/DELI+0.1) + ERR=MAX(ERR,ABS(DELTAU(IBIN+IGF)/DELI-REAL(LARGH))) + 70 CONTINUE + IBIN=IBIN+NBIN(IGRP) + 80 CONTINUE + IF(ERR.GT.0.05) THEN + WRITE(HSMG,'(45HAUTDRV: UNABLE TO SET THE ELEMENTARY LETHARGY, + 1 7H WIDTH.)') + WRITE(6,'(A)') HSMG + ENDIF + DEALLOCATE(EBIN,DELTAU) +*---- +* RECOMPUTE THE AUTOLIB ENERGY MESH BETWEEN IGRMIN AND IGRMAX. +*---- + DO 90 IGRP=IGRMIN,IGRRES-1 + IF(NBIN(IGRP).EQ.0) THEN + DELM=LOG(ENER(IGRP)/ENER(IGRP+1)) + NBIN(IGRP)=INT(DELM/DELI+0.1) + ENDIF + 90 CONTINUE + LBIN=SUM(NBIN(IGRMIN:NGRP)) + IF(IMPX.GT.0) THEN + WRITE(6,'(/32H AUTDRV: NUMBER OF AUTOLIB BINS=,I9)') LBIN + WRITE(6,'(35H AUTDRV: FIRST SELF-SHIELDED GROUP=,I6)') IGRMIN + WRITE(6,'(30H AUTDRV: FIRST RESOLVED GROUP=,I11)') IGRRES + WRITE(6,'(34H AUTDRV: LAST SELF-SHIELDED GROUP=,I7)') IGRMAX + WRITE(6,'(35H AUTDRV: ELEMENTARY LETHARGY WIDTH=,1P,E9.2)') DELI + WRITE(6,'(33H AUTDRV: ERROR ON LETHARGY WIDTH=,1P,E11.2)') ERR + ENDIF + ALLOCATE(EBIN(LBIN+1)) + EBIN(:LBIN+1)=0.0 + LLL=0 + DO IGRP=1,IGRRES-1 + DUUU=0.0D0 + EBIN(LLL+1)=ENER(IGRP) + DO IBIN=LLL+1,LLL+NBIN(IGRP) + DUUU=DUUU+DELI + EBIN(IBIN+1)=REAL(ENER(IGRP)*EXP(-DUUU)) + ENDDO + LLL=LLL+NBIN(IGRP) + ENDDO + DO ISO=1,NBISO + KPLIB=IPISO1(ISO) ! set ISO-th isotope + CALL LCMLEN(KPLIB,'BIN-ENERGY',LENGT,ITYLCM) + IF(LENGT.EQ.0) CYCLE + IF(LLL+LENGT.GT.LBIN+1) CALL XABORT('AUTDRV: EBIN OVERFLOW.') + CALL LCMGET(KPLIB,'BIN-ENERGY',EBIN(LLL+1)) + IF(EBIN(LBIN+1).EQ.0.0) EBIN(LBIN+1)=1.0E-5 + EXIT + ENDDO +* + DO 100 ISO=1,NBISO + TEXT8='MICROLIB' + READ(TEXT8,'(2A4)') IHLIB(1,ISO),IHLIB(2,ISO) + ILLIB(ISO)=1 + 100 CONTINUE +* + JPLIB=LCMGID(IPLIB,'ISOTOPESLIST') + JPLI0=LCMLID(IPLI0,'ISOTOPESLIST',NBISO) + IF(INDREC.EQ.1) THEN +* COPY THE NON RESONANT ISOTOPES. + CALL KDRCPU(TK1) + DO 130 ISO=1,NBISO + IF((LSHI(ISO).EQ.0).OR.(DEN(ISO).EQ.0.0)) THEN + CALL LCMLEL(JPLIB,ISO,ILEN,ITYLCM) + IF(ILEN.EQ.0) THEN + DO JSO=1,ISO-1 + CALL LCMLEL(JPLIB,JSO,ILEN,ITYLCM) + IF(ILEN.EQ.0) CYCLE + IF((ISONAM(1,ISO).EQ.ISONAM(1,JSO)).AND.(ISONAM(2,ISO) + 1 .EQ.ISONAM(2,JSO)).AND.(ISONAM(3,ISO).EQ.ISONAM(3,JSO))) + 2 THEN + IF(LSHI(JSO).GT.0) THEN + KPLIB=LCMGIL(JPLIB,JSO) ! set JSO-th isotope + GO TO 120 + ELSE + GO TO 130 + ENDIF + ENDIF + ENDDO + ELSE + KPLIB=LCMGIL(JPLIB,ISO) ! set ISO-th isotope + GO TO 120 + ENDIF + GO TO 130 + 120 CALL LCMLEL(JPLI0,ISO,ILEN,ITYLCM) + IF(ILEN.NE.0) GO TO 130 + KPLI0=LCMDIL(JPLI0,ISO) ! set ISO-th isotope + CALL LCMEQU(KPLIB,KPLI0) + ENDIF + 130 CONTINUE + CALL KDRCPU(TK2) + IF(IMPX.GT.1) WRITE(6,'(/33H AUTDRV: CPU TIME SPENT TO COPY T, + 1 26HHE NON-RESONANT ISOTOPES =,F8.1,8H SECOND.)') TK2-TK1 +* +* WRITE THE OUTPUT INTERNAL LIBRARY PARAMETERS. + CALL LCMGET(IPLIB,'STATE-VECTOR',IPAR) + IPAR(8)=0 + IPAR(17)=0 + CALL LCMPUT(IPLI0,'STATE-VECTOR',NSTATE,1,IPAR) + IF(NED.GT.0) THEN + ALLOCATE(JCEDM(2*NED)) + CALL LCMGET(IPLIB,'ADDXSNAME-P0',JCEDM) + CALL LCMPUT(IPLI0,'ADDXSNAME-P0',2*NED,3,JCEDM) + DEALLOCATE(JCEDM) + ENDIF + CALL LCMLEN(IPLIB,'DEPL-CHAIN',ILENG,ITYLCM) + IF(ILENG.NE.0) THEN + CALL LCMSIX(IPLIB,'DEPL-CHAIN',1) + CALL LCMSIX(IPLI0,'DEPL-CHAIN',1) + CALL LCMEQU(IPLIB,IPLI0) + CALL LCMSIX(IPLI0,' ',2) + CALL LCMSIX(IPLIB,' ',2) + ENDIF + ENDIF + IF(NRES.EQ.0) THEN + CALL LCMEQU(IPLIB,IPLI0) + GO TO 310 + ENDIF +*---- +* FIND THE ISOTOPE-NAME SUFFIX VALUES. +*---- + TEXT4=' ' + READ(TEXT4,'(A4)') IHBLK + DO 140 ISO=1,NBISO + IF((LSHI(ISO).NE.0).AND.(DEN(ISO).NE.0.0)) THEN + WRITE(TEXT4,'(I4.4)') MIX(ISO) + READ(TEXT4,'(A4)') IHSUF(ISO) + ELSE + IHSUF(ISO)=IHBLK + ENDIF + 140 CONTINUE + IF(ICALC.EQ.1) THEN + CALL LCMSIX(IPLI0,'SHIBA_SG',1) + CALL LCMSIX(IPLI0,'-DATA-CALC-',1) + NAM1=' ' + CALL LCMNXT(IPLI0,NAM1) + FNAM1=NAM1 + 150 CALL LCMSIX(IPLI0,NAM1,1) + NAM2=' ' + CALL LCMNXT(IPLI0,NAM2) + FNAM2=NAM2 + 160 CALL LCMLEN(IPLI0,NAM2,NRSS,ITYLCM) + CALL LCMGET(IPLI0,NAM2,IRSS) + READ(NAM2,'(2A4)') IN1,IN2 + DO 180 ISO=1,NBISO + IF((ISONAM(1,ISO).EQ.IN1).AND.(ISONAM(2,ISO).EQ.IN2).AND. + 1 (LSHI(ISO).NE.0)) THEN + IF((NRSS.EQ.1).AND.(IRSS(1).EQ.-999)) THEN + READ(NAM1,'(A4)') IHSUF(ISO) + ELSE + DO 170 I=1,NRSS + IF(IRSS(I).EQ.MIX(ISO)) READ(NAM1,'(A4)') IHSUF(ISO) + 170 CONTINUE + ENDIF + ENDIF + 180 CONTINUE + CALL LCMNXT(IPLI0,NAM2) + IF(NAM2.EQ.FNAM2) GO TO 190 + GO TO 160 + 190 CALL LCMSIX(IPLI0,' ',2) + CALL LCMNXT(IPLI0,NAM1) + IF(NAM1.EQ.FNAM1) THEN + CALL LCMSIX(IPLI0,' ',2) + CALL LCMSIX(IPLI0,' ',2) + GO TO 200 + ENDIF + GO TO 150 + ENDIF +* + 200 NPASS2=NPASS + DO 300 IPASS=1,NPASS + IF((IMPX.GT.0).AND.(NPASS2.GT.1)) WRITE (6,'(/15H AUTDRV: SELF S, + 1 25HHIELDING ITERATION NUMBER,I4,7H NRES=,I4,1H.)') IPASS,NRES + DO 290 INRS=1,NRES +*---- +* PERFORM A SELF-SHIELDING CALCULATION IN RESONANT REGION INRS. +*---- + CALL AUTONE(IPLI0,IPTRK,IPLIB,IFTRAK,CDOOR,IMPX,INRS,IGRMIN, + 1 IGRRES,IGRMAX,NGRP,NBMIX,NREG,NUN,NBISO,NL,NED,NDEL,ISONAM, + 2 IHSUF,DEN,LSHI,DIL,MIX,MAT,VOL,KEYFLX,LEAKSW,ITRANC,IPHASE, + 3 TITR,KSPH,IALTER,DELI,LBIN,NBIN,EBIN,MAXTRA,ISEED) + 290 CONTINUE + 300 CONTINUE + 310 IF(IMPX.GE.3) CALL LCMLIB(IPLI0) +*---- +* BUILD THE MACROLIB IN THE OUTPUT INTERNAL LIBRARY. +*---- + ALLOCATE(MASK(NBMIX)) + DO 330 IBM=1,NBMIX + MASK(IBM)=.TRUE. + DO 320 I=1,NREG + IF(MAT(I).EQ.IBM) GO TO 330 + 320 CONTINUE + MASK(IBM)=.FALSE. + 330 CONTINUE + ALLOCATE(MASKL(NGRP)) + DO 340 I=1,NGRP + MASKL(I)=.TRUE. + 340 CONTINUE +* + ITSTMP=0 + TMPDAY(1)=0.0 + TMPDAY(2)=0.0 + TMPDAY(3)=0.0 + CALL KDRCPU(TK1) + CALL LCMLEN(IPLI0,'ISOTOPESUSED',ILENG,ITYLCM) + IF(ILENG.EQ.0) CALL XABORT('AUTDRV: MISSING ISOTOPESUSED RECORD.') + CALL LCMGET(IPLI0,'ISOTOPESUSED',ISONAM) + CALL LIBMIX(IPLI0,NBMIX,NGRP,NBISO,ISONAM,MIX,DEN,MASK,MASKL, + 1 ITSTMP,TMPDAY) + CALL KDRCPU(TK2) + IF(IMPX.GT.1) WRITE(6,'(/37H AUTDRV: CPU TIME SPENT TO BUILD THE , + 1 19HEMBEDDED MACROLIB =,F8.1,8H SECOND.)') TK2-TK1 + DEALLOCATE(MASKL,MASK) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(NBIN,EBIN,ENER,DEN,TN,VOL) + DEALLOCATE(IPISO1,ILLIB,IHLIB,IHSUF,LSHI,ITYPE,IEVOL,MIX,ISONAM, + 1 KEYFLX,MAT) + RETURN + END diff --git a/Dragon/src/AUTFLU.f b/Dragon/src/AUTFLU.f new file mode 100644 index 0000000..47fdeed --- /dev/null +++ b/Dragon/src/AUTFLU.f @@ -0,0 +1,379 @@ +*DECK AUTFLU + SUBROUTINE AUTFLU(IPTRK,IPLIB,IPLI0,IFTRAK,NREG,NUN,NBMIX,NBISO, + 1 NIRES,MAT,VOL,KEYFLX,CDOOR,LEAKSW,IMPX,DEN,MIX,IAPT,IPHASE,NGRP, + 2 IGRMIN,IGRRES,IGRMAX,DIL,TITR,IALTER,DELI,LBIN,NBIN,EBIN,MAXTRA, + 3 ISEED,ITRANC,UUU,FUNKNO,SIGT,SIGS,SIGS1,SIGF,SIGGAR,MASKG) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the flux in the Autolib fine groups using the Autosecol +* method. +* +*Copyright: +* Copyright (C) 2023 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK pointer to the tracking (L_TRACK signature). +* IPLIB pointer to the internal microscopic cross section library +* with subgroups (L_LIBRARY signature). +* IPLI0 pointer to the internal microscopic cross section library +* builded by the self-shielding module. +* IFTRAK file unit number used to store the tracks. +* NREG number of regions. +* NUN number of unknowns per energy group and band. +* NBMIX number of mixtures in the internal library. +* NBISO number of isotopes. +* NIRES number of correlated resonant isotopes. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX pointers of fluxes in unknown vector. +* CDOOR name of the geometry/solution operator. +* LEAKSW leakage flag (LEAKSW=.true. if neutron leakage through +* external boundary is present). +* IMPX print flag (equal to zero for no print). +* DEN density of each isotope. +* MIX mix number of each isotope (can be zero). +* IAPT resonant isotope index associated with isotope I. Mixed +* moderator if IAPT(I)=NIRES+1. Out-of-fuel isotope if +* IAPT(I)=0. +* IPHASE type of flux solution (=1 use a native flux solution door; +* =2 use collision probabilities). +* NGRP number of energy groups. +* IGRMIN first group where the self-shielding is applied. +* IGRRES first resolved energy group. +* IGRMAX most thermal group where the self-shielding is applied. +* DIL microscopic dilution cross section of each isotope. +* TITR title. +* IALTER type of elastic slowing-down kernel (=0: use exact kernel; +* =1: use an approximate kernel for the resonant isotopes). +* DELI elementary lethargy width used by the elastic kernel. +* LBIN total number of fine energy groups in the Autolib. +* NBIN number of fine energy groups in each coarse energy group. +* EBIN energy limits of the Autolib fine groups. +* MAXTRA maximum number of down-scattering terms. +* ISEED the seed for the generation of random numbers in the +* unresolved energy domain. +* ITRANC type of transport correction. +* +*Parameters: output +* UUU lethargy limits of the Autolib fine groups. +* FUNKNO flux in the Autolib fine groups. +* SIGT total microscopic x-s. +* SIGS P0 scattering microscopic x-s. +* SIGS1 P1 scattering microscopic x-s. +* SIGF nu*fission microscopic x-s. +* SIGGAR macroscopic x-s of the non-resonant isotopes in each mixture: +* (*,*,*,1) total; (*,*,*,2) transport correction; +* (*,*,*,3) P0 scattering. +* MASKG energy group mask pointing on self-shielded groups. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPLIB,IPLI0 + INTEGER IFTRAK,NREG,NUN,NBMIX,NBISO,NIRES,MAT(NREG),KEYFLX(NREG), + 1 IMPX,MIX(NBISO),IAPT(NBISO),IPHASE,NGRP,IGRMIN,IGRRES,IGRMAX, + 2 IALTER,LBIN,NBIN(NGRP),MAXTRA,ISEED,ITRANC + REAL VOL(NREG),DEN(NBISO),DIL(NBISO),DELI,EBIN(LBIN+1), + 1 UUU(LBIN+1),FUNKNO(NUN,LBIN),SIGT(LBIN,NBISO),SIGS(LBIN,NBISO), + 2 SIGS1(LBIN,NBISO),SIGF(LBIN,NBISO),SIGGAR(NBMIX,0:NIRES,NGRP,3) + LOGICAL LEAKSW,MASKG(NGRP) + CHARACTER CDOOR*12,TITR*72 +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPP,KPLIB,KPLI0,IPSYS + LOGICAL LLIB + DOUBLE PRECISION DUUU + CHARACTER HNAMIS*12,HNABIS*12,HSMG*131 +*---- +* ALLOCATABLE ARRAYS +*---- + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO1,IPISO2 + INTEGER, ALLOCATABLE, DIMENSION(:) :: NJJ,IJJ,NEXT,III + REAL, ALLOCATABLE, DIMENSION(:) :: GA1,DELTAU,SGAR,PRI + REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGINF,SCAT,GA2,CONC + LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASKH +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(GA1(NGRP),GA2(NGRP,NGRP),CONC(NBMIX,NBISO),DELTAU(NGRP), + 1 MASKH(NGRP),SIGINF(NGRP,3)) + ALLOCATE(IPISO1(NBISO),IPISO2(NBISO)) + ALLOCATE(NJJ(NGRP),IJJ(NGRP),SGAR(NGRP**2),SCAT(NGRP,NGRP)) + ALLOCATE(PRI(MAXTRA),NEXT(NBISO),III(NBISO+1)) + NEXT(:NBISO)=0 +* + CALL KDRCPU(TK1) + SIGGAR(:NBMIX,0:NIRES,:NGRP,:3)=0.0 + CALL LIBIPS(IPLIB,NBISO,IPISO1) + CALL LIBIPS(IPLI0,NBISO,IPISO2) + CALL LCMGET(IPLI0,'DELTAU',DELTAU) + III(1)=1 + DO 120 ISO=1,NBISO + SIGT(:LBIN,ISO)=0.0 + SIGS(:LBIN,ISO)=0.0 + SIGS1(:LBIN,ISO)=0.0 + SIGF(:LBIN,ISO)=0.0 + IF(IMPX.GT.1) WRITE(6,'(/32H AUTFLU: RECOVER XS FOR ISOTOPE=,I5)') + 1 ISO + IBM=MIX(ISO) + DO 10 NRE=1,NREG + IF(MAT(NRE).EQ.IBM) GO TO 20 + 10 CONTINUE + III(ISO+1)=III(ISO) + GO TO 120 + 20 KPLIB=IPISO1(ISO) ! infinite dilution isotope + KPLI0=IPISO2(ISO) ! self-shielded isotope + CALL LCMGTC(KPLIB,'ALIAS',12,HNAMIS) + IRES=IAPT(ISO) + JRES=IRES + IF(IRES.EQ.NIRES+1) JRES=0 + DENN=DEN(ISO) + CALL LCMGET(KPLIB,'AWR',AWR) + CALL LCMLEN(KPLIB,'BIN-NFS',LENGT,ITYLCM) + IF((IRES.GT.0).AND.(IRES.LE.NIRES).AND.(LENGT.GT.0)) THEN + ! resonant isotope + IF(IMPX.GT.2) WRITE(6,'(26H AUTFLU: PROCESS AUTOLIB '',A12, + 1 1H'')') HNAMIS + IF(LBIN.EQ.0) CALL XABORT('AUTFLU: MISSING AUTOLIB DATA.') + DUUU=0.0D0 + UUU(1)=0.0 + DO 40 IGR=1,LBIN + DUUU=DUUU+LOG(EBIN(IGR)/EBIN(IGR+1)) + UUU(IGR+1)=REAL(DUUU) + 40 CONTINUE + ! recover unresolved xs values + LLL=0 + IF(IGRRES.GT.IGRMIN) THEN + CALL LCMLEN(KPLIB,'NUSIGF',N10,ITYLCM) + CALL LCMLEN(KPLIB,'SIGS00',N12,ITYLCM) + SIGINF(:NGRP,:3)=0.0 + CALL LCMGET(KPLIB,'NTOT0',SIGINF(1,1)) + IF(N10.GT.0) CALL LCMGET(KPLIB,'NUSIGF',SIGINF(1,2)) + IF(N12.GT.0) CALL LCMGET(KPLIB,'SIGS00',SIGINF(1,3)) + CALL AUTTAB(KPLIB,HNAMIS,IGRMIN,IGRRES,NGRP,LBIN,NBIN,UUU, + 1 ISEED,SIGINF,LLL,SIGT(1,ISO),SIGS(1,ISO),SIGF(1,ISO)) + ENDIF + ! recover resolved xs values + IF(LLL.LT.LBIN) THEN + CALL LCMLEN(KPLIB,'BIN-NTOT0',LENG,ITYLCM) + IF(LENG.GT.LBIN) CALL XABORT('AUTFLU: LBIN OVERFLOW.') + CALL LCMGET(KPLIB,'BIN-NTOT0',SIGT(LLL+1,ISO)) + CALL LCMGET(KPLIB,'BIN-SIGS00',SIGS(LLL+1,ISO)) + CALL LCMLEN(KPLIB,'BIN-NUSIGF',ILEN,ITYLCM) + IF(ILEN.GT.0) CALL LCMGET(KPLIB,'BIN-NUSIGF',SIGF(LLL+1,ISO)) + ENDIF +*---- +* ELASTIC SCATTERING INFORMATION. +*---- + MAXIII=MAXTRA-III(ISO)+1 + CALL LIBPRI(MAXIII,DELI,AWR,IALTER,0,NEXT(ISO),PRI(III(ISO))) + ELSE + ! infinite dilution isotope + IF(C_ASSOCIATED(KPLI0)) THEN + CALL LCMLEN(KPLI0,'NTOT0',ILEN0,ITYLCM) + IF(ILEN0.NE.0) THEN + LLIB=.FALSE. + IPP=KPLI0 + ELSE + LLIB=.TRUE. + IPP=IPISO1(ISO) ! set ISO-th isotope + ENDIF + ELSE + LLIB=.TRUE. + IPP=IPISO1(ISO) ! set ISO-th isotope + ENDIF + IF(LLIB.AND.(.NOT.C_ASSOCIATED(IPP))) THEN + WRITE(HSMG,'(18H AUTFLU: ISOTOPE '',A12,7H'' (ISO=,I8,5H) IS , + 1 39HNOT AVAILABLE IN THE ORIGINAL MICROLIB.)') HNAMIS,ISO + CALL XABORT(HSMG) + ENDIF + IF((.NOT.LLIB).AND.(IMPX.GT.2)) THEN + CALL LCMGTC(KPLI0,'ALIAS',12,HNABIS) + WRITE(6,'(26H AUTFLU: RECOVER ISOTOPE '',A12,11H'' FROM THE , + 1 12HNEW LIBRARY.)') HNABIS + ELSE IF(LLIB.AND.(IMPX.GT.2)) THEN + WRITE(6,'(26H AUTFLU: RECOVER ISOTOPE '',A12,11H'' FROM THE , + 1 12HOLD LIBRARY.)') HNAMIS + ENDIF + NSCAR=0 + SCAT(:NGRP,:NGRP)=0.0 + CALL LCMLEN(IPP,'NTOT0',N13,ITYLCM) + IF(N13.EQ.0) THEN + CALL LCMLIB(IPP) + CALL XABORT('AUTFLU: NO INFINITE-DILUTION TOTAL XS.') + ELSE IF(N13.GT.LBIN) THEN + CALL XABORT('AUTFLU: LBIN OVERFLOW.') + ELSE IF(N13.NE.NGRP) THEN + CALL XABORT('AUTFLU: INVALID X-SECTIONS.') + ENDIF + CALL LCMGET(IPP,'NTOT0',SIGT(1,ISO)) + CALL LCMLEN(IPP,'NUSIGF',N10,ITYLCM) + IF(N10.GT.0) CALL LCMGET(IPP,'NUSIGF',SIGF(1,ISO)) + CALL LCMLEN(IPP,'SIGS00',N12,ITYLCM) + IF(N12.GT.0) THEN + CALL LCMGET(IPP,'SIGS00',SIGS(1,ISO)) + CALL LCMLEN(IPP,'SIGS01',N14,ITYLCM) + IF(N14.GT.0) THEN + CALL LCMGET(IPP,'SIGS01',SIGS1(1,ISO)) + ELSE + SIGS1(:NGRP,ISO)=0.0 + ENDIF + ELSE + CALL LCMGET(IPP,'SCAT00',SGAR) + CALL LCMGET(IPP,'NJJS00',NJJ) + CALL LCMGET(IPP,'IJJS00',IJJ) + IGAR1=0 + DO IG2=1,NGRP + DO IG1=IJJ(IG2),IJJ(IG2)-NJJ(IG2)+1,-1 + IGAR1=IGAR1+1 + SCAT(IG1,IG2)=SGAR(IGAR1) + ENDDO + ENDDO + DO IG1=1,NGRP + SUMSC=0.0D0 + DO IG2=1,NGRP + SUMSC=SUMSC+SCAT(IG1,IG2) + ENDDO + SIGS(IG1,ISO)=REAL(SUMSC) + ENDDO + CALL LCMLEN(IPP,'SCAT01',N87,ITYLCM) + IF(N87.GT.0) THEN + CALL LCMGET(IPP,'SCAT01',SGAR) + CALL LCMGET(IPP,'NJJS01',NJJ) + CALL LCMGET(IPP,'IJJS01',IJJ) + IGAR1=0 + DO IG2=1,NGRP + DO IG1=IJJ(IG2),IJJ(IG2)-NJJ(IG2)+1,-1 + IGAR1=IGAR1+1 + SCAT(IG1,IG2)=SGAR(IGAR1) + ENDDO + ENDDO + DO IG1=1,NGRP + SUMSC=0.0D0 + DO IG2=1,NGRP + SUMSC=SUMSC+SCAT(IG1,IG2) + ENDDO + SIGS1(IG1,ISO)=REAL(SUMSC) + ENDDO + ENDIF + ENDIF + ! compute SIGGAR used by SPH equivalence + IF((DENN.NE.0.0).AND.(IBM.NE.0).AND.(JRES.EQ.0)) THEN + DO 70 IG1=1,NGRP + SIGGAR(IBM,JRES,IG1,1)=SIGGAR(IBM,JRES,IG1,1)+DENN* + 1 SIGT(IG1,ISO) + SIGGAR(IBM,JRES,IG1,3)=SIGGAR(IBM,JRES,IG1,3)+DENN* + 1 SIGS(IG1,ISO) + 70 CONTINUE + CALL LCMLEN(IPP,'TRANC',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGET(IPP,'TRANC',GA1) + DO 80 IG1=1,NGRP + SIGGAR(IBM,JRES,IG1,2)=SIGGAR(IBM,JRES,IG1,2)+DENN*GA1(IG1) + 80 CONTINUE + ENDIF + ENDIF + ! expand xs of non-resonant isotopes + CALL AUTPRD(NGRP,LBIN,NBIN,SIGS(1,ISO)) + CALL AUTPRD(NGRP,LBIN,NBIN,SIGT(1,ISO)) + CALL AUTPRD(NGRP,LBIN,NBIN,SIGF(1,ISO)) + CALL AUTPRD(NGRP,LBIN,NBIN,SIGS1(1,ISO)) + ENDIF + III(ISO+1)=III(ISO)+NEXT(ISO) +*---- +* CROSS SECTION EDITION. +*---- + IF(IMPX.GT.7) THEN + CALL LCMGTC(KPLIB,'ALIAS',12,HNAMIS) + WRITE(6,540) HNAMIS,(K,SIGS(K,ISO),SIGT(K,ISO),SIGF(K,ISO), + 1 SIGS1(K,ISO),K=1,LBIN) + I2=III(ISO+1)-1 + WRITE(6,550) III(ISO),I2,(PRI(K),K=III(ISO),I2) + ENDIF + 120 CONTINUE + CALL KDRCPU(TK2) + IF(IMPX.GT.1) WRITE(6,'(/36H AUTFLU: CPU TIME SPENT TO RECOVER A, + 1 33HUTOLIB AND INFINITE-DILUTION XS =,F8.1,8H SECOND./)') TK2-TK1 +* + CALL KDRCPU(TK1) + TK4=0.0 + TK5=0.0 + ICPIJ=0 +*---- +* SET THE NUMBER DENSITIES. +*---- + CONC(:NBMIX,:NBISO)=0.0 + DO 130 ISO=1,NBISO + IBM=MIX(ISO) + IF(IBM.LE.0) CYCLE + CONC(IBM,ISO)=DEN(ISO) + 130 CONTINUE +*---- +* DETERMINE WHICH GROUPS ARE SELF-SHIELDED. +*---- + MASKG(:NGRP)=.FALSE. + MASKG(IGRMIN:IGRMAX)=.TRUE. +*---- +* COMPUTE THE NEUTRON FLUX. +*---- + CALL KDRCPU(TKA) + CALL KDRCPU(TKA) + DO 330 IG1=1,NGRP + ICPIJ=ICPIJ+NBIN(IG1) + 330 CONTINUE + CALL LCMOP(IPSYS,'**SYSTEM**',0,1,0) + KNORM=1 + IMPY=MAX(0,IMPX-3) + IF(IPHASE.EQ.1) THEN +* USE A NATIVE DOOR. + CALL AUTIT2(IPTRK,IFTRAK,IPSYS,MAXTRA,KNORM,NUN,LBIN,NREG, + 1 NBMIX,NBISO,MAT,VOL,KEYFLX,NIRES,IAPT,CDOOR,LEAKSW,TITR,IMPY, + 2 CONC,SIGS,SIGT,SIGS1,DIL,PRI,UUU,DELI,ITRANC,NEXT,III,FUNKNO) + ELSE IF(IPHASE.EQ.2) THEN +* USE A COLLISION PROBABILITY DOOR. + CALL AUTIT1(IPTRK,IFTRAK,IPSYS,MAXTRA,KNORM,LBIN,NREG, + 1 NBMIX,NBISO,MAT,VOL,NIRES,IAPT,CDOOR,LEAKSW,TITR,IMPY,CONC, + 2 SIGS,SIGT,SIGS1,DIL,PRI,UUU,DELI,ITRANC,NEXT,III,FUNKNO) + ENDIF + CALL LCMCL(IPSYS,2) + CALL KDRCPU(TKB) + TK4=TK4+(TKB-TKA) +* *************************************************************** + CALL LCMVAL(IPLI0,' ') +*---- +* RESET MASKG FOR SPH CALCULATION IN SMALL LETHARGY WIDTH GROUPS. +*---- + DO 380 IG1=1,NGRP + IF(MASKG(IG1)) THEN + IF(DELTAU(IG1).GT.0.1) MASKG(IG1)=.TRUE. + ENDIF + 380 CONTINUE + CALL KDRCPU(TK2) + IF(IMPX.GT.1) WRITE(6,'(/34H AUTFLU: CPU TIME SPENT TO COMPUTE, + 1 31H SELF-SHIELDED REACTION RATES =,F8.1,19H SECOND, INCLUDING: + 2 /9X,F8.1,36H SECOND TO SOLVE FOR AUTOSECOL FLUX;/9X,7HNUMBER , + 3 25HOF ASSEMBLY DOORS CALLS =,I5,1H.)') TK2-TK1,TK4,ICPIJ +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(III,NEXT,PRI) + DEALLOCATE(SCAT,SGAR,IJJ,NJJ) + DEALLOCATE(IPISO2,IPISO1) + DEALLOCATE(SIGINF,MASKH,DELTAU,CONC,GA2,GA1) + RETURN + 540 FORMAT(/18H AUTFLU: ISOTOPE ',A12,1H'/12X,4HSIGS,16X,4HSIGT, + 1 16X,4HSIGF,16X,5HSIGS1/(I5,1P,4E20.7)) + 550 FORMAT(/29H AUTFLU: SCATTERING ELEMENTS:,2I10/(1P,10E13.5)) + END diff --git a/Dragon/src/AUTIT1.f b/Dragon/src/AUTIT1.f new file mode 100644 index 0000000..3e404c6 --- /dev/null +++ b/Dragon/src/AUTIT1.f @@ -0,0 +1,224 @@ +*DECK AUTIT1 + SUBROUTINE AUTIT1(IPTRK,IFTRAK,IPSYS,MAXTRA,KNORM,LBIN,NREG, + 1 NBMIX,NBISO,MAT,VOL,NIRES,IAPT,CDOOR,LEAKSW,TITR,IMPX,CONC, + 2 SIGS,SIGT,SIGS1,DIL,PRI,UUU,DELI,ITRANC,NEXT,III,FUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of the multigroup neutron flux for a pij method. +* +*Copyright: +* Copyright (C) 2023 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK file unit number used to store the tracks. +* IPSYS pointer to the system LCM object. +* MAXTRA maximum number of elements in vector PRI. +* KNORM type of cp normalization. +* LBIN number of energy groups. +* NREG number of regions. +* NBMIX number of mixtures in the internal library. +* NBISO number of distinct isotopes. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* NIRES number of correlated resonant isotopes. +* IAPT resonant isotope index associated with isotope I. Mixed +* moderator if IAPT(I)=NIRES+1. Out-of-fuel isotope if +* IAPT(I)=0. +* CDOOR name of the geometry/solution operator. +* LEAKSW leakage flag (LEAKSW=.true. if neutron leakage through +* external boundary is present). +* TITR title. +* IMPX print flag (equal to zero for no print). +* CONC number densities of each isotope in each mixture. +* SIGS P0 scattering microscopic x-s. +* SIGT total microscopic x-s. +* SIGS1 P1 scattering microscopic x-s. +* DIL microscopic dilution cross section of each isotope. +* PRI info to rebuild the SCAT matrix. +* UUU lethargy limits of the groups. +* DELI elementary lethargy width. +* ITRANC type of transport correction. +* NEXT used in subroutine LIBECT. +* III offset in PRI array. +* +*Parameters: output +* FUNKNO neutron flux per unit lethargy. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS + INTEGER IFTRAK,MAXTRA,KNORM,LBIN,NREG,NBMIX,NBISO,MAT(NREG), + 1 NIRES,IAPT(NBISO),IMPX,ITRANC,NEXT(NBISO),III(NBISO+1) + REAL VOL(NREG),CONC(NBMIX,NBISO),SIGS(LBIN,NBISO), + 1 SIGT(LBIN,NBISO),SIGS1(LBIN,NBISO),DIL(NBISO),PRI(MAXTRA), + 2 UUU(LBIN+1),DELI,FUNKNO(NREG,LBIN) + LOGICAL LEAKSW + CHARACTER CDOOR*12,TITR*72 +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION SSUM + TYPE(C_PTR) JPSYS,KPSYS +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NLET,NPSYS + REAL, ALLOCATABLE, DIMENSION(:) :: DEL,SOURCE,SIGTOT,SIGWIN,STIS + REAL, ALLOCATABLE, DIMENSION(:,:) :: STR,PIJ + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: Q +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NLET(NBMIX),NPSYS(LBIN)) + ALLOCATE(DEL(LBIN),SOURCE(NREG),SIGTOT(0:NBMIX),SIGWIN(0:NBMIX), + 1 STR(LBIN,NBMIX),STIS(LBIN),PIJ(NREG,NREG)) + ALLOCATE(Q(NREG)) +* + JPSYS=LCMLID(IPSYS,'GROUP',LBIN) + DO 10 LLL=1,LBIN + DEL(LLL)=UUU(LLL+1)-UUU(LLL) + 10 CONTINUE + DO 60 LLL=1,LBIN + NPSYS(LLL)=LLL +*---- +* COMPUTE THE TOTAL SCATTERING CROSS SECTIONS. +*---- + SIGTOT(0)=0.0 + DO 20 M=1,NBMIX + SIGTOT(M)=0.0 + DO 15 K=1,NBISO + IF(ITRANC.NE.0) SIGTOT(M)=SIGTOT(M)-CONC(M,K)*SIGS1(LLL,K) + SIGTOT(M)=SIGTOT(M)+CONC(M,K)*(DIL(K)+SIGT(LLL,K)) + 15 CONTINUE + 20 CONTINUE + IF(IMPX.GE.9) THEN + WRITE (6,'(//45H AUTIT1: TOTAL MACROSCOPIC CROSS SECTIONS IN , + 1 5HGROUP,I8,1H:/)') LLL + WRITE (6,'(1X,1P,10E13.5)') (SIGTOT(MAT(NRE)),NRE=1,NREG) + ENDIF +*---- +* COMPUTE THE P0 WITHIN-GROUP SCATTERING CROSS SECTIONS. +*---- + SIGWIN(0:NBMIX)=0.0 + DO 50 K=1,NBISO + IF((IAPT(K).GT.0).AND.(IAPT(K).LE.NIRES)) THEN + CALL LIBECT(MAXTRA,LLL,PRI,UUU(2),DELI,DEL,NEXT(K),III(K),MML, + 1 STIS) + DO 30 M=1,NBMIX + SIGWIN(M)=SIGWIN(M)+CONC(M,K)*STIS(1)*SIGS(LLL,K) + 30 CONTINUE + ENDIF + IF(ITRANC.NE.0) THEN + DO 40 M=1,NBMIX + SIGWIN(M)=SIGWIN(M)-CONC(M,K)*SIGS1(LLL,K) + 40 CONTINUE + ENDIF + 50 CONTINUE + IF(IMPX.GE.10) THEN + WRITE (6,'(//45H P0 WITHIN-GROUP SCATTERING MACROSCOPIC CROSS, + 1 18H SECTIONS IN GROUP,I8,1H:/)') LLL + WRITE (6,'(1X,1P,10E13.5)') (SIGWIN(MAT(NRE)),NRE=1,NREG) + ENDIF +* + KPSYS=LCMDIL(JPSYS,LLL) + CALL LCMPUT(KPSYS,'DRAGON-TXSC',NBMIX+1,2,SIGTOT(0)) + CALL LCMPUT(KPSYS,'DRAGON-S0XSC',NBMIX+1,2,SIGWIN(0)) + 60 CONTINUE +*---- +* COMPUTE THE GROUPWISE COLLISION PROBABILITIES. +*---- + NANI=1 + IPIJK=1 + ITPIJ=1 + NALBP=0 + CALL DOORPV (CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IMPX,LBIN,NREG, + 1 NBMIX,NANI,MAT,VOL,KNORM,IPIJK,LEAKSW,ITPIJ,.FALSE.,TITR, + 2 NALBP) +*---- +* COMPUTE THE ELASTIC SLOWING-DOWN SOURCES. +*---- + DO 160 LLL=1,LBIN + DO M=1,NBMIX + NLET(M)=1 + STR(:LBIN,M)=0.0 + ENDDO + DO 90 K=1,NBISO + IF((IAPT(K).GT.0).AND.(IAPT(K).LE.NIRES)) THEN + CALL LIBECT(MAXTRA,LLL,PRI,UUU(2),DELI,DEL,NEXT(K),III(K),MML, + 1 STIS) + DO 80 M=1,NBMIX + AUX=CONC(M,K) + IF(AUX.EQ.0.) GOTO 80 + NLET(M)=MAX(NLET(M),MML) + DO 70 MM=1,MML + LLJ=LLL-MM+1 + STR(MM,M)=STR(MM,M)+AUX*STIS(MM)*SIGS(LLJ,K)*DEL(LLJ)/DEL(LLL) + 70 CONTINUE + 80 CONTINUE + ENDIF + 90 CONTINUE +*---- +* DILUTION SOURCE. +*---- + SOURCE(:NREG)=0.0 + DO 110 NRE=1,NREG + IBM=MAT(NRE) + IF(IBM.GT.0) THEN + DO 100 K=1,NBISO + IF((IAPT(K).EQ.0).OR.(IAPT(K).EQ.NIRES+1)) THEN + SOURCE(NRE)=SOURCE(NRE)+CONC(IBM,K)*SIGS(LLL,K) + ELSE + SOURCE(NRE)=SOURCE(NRE)+CONC(IBM,K)*DIL(K) + ENDIF + 100 CONTINUE + ENDIF + 110 CONTINUE +*---- +* SCATTERING SOURCE. +*---- + DO 130 NRE=1,NREG + Q(NRE)=SOURCE(NRE) + M=MAT(NRE) + IF(M.GT.0) THEN + DO 120 MM=2,MIN(LLL,NLET(M)) + Q(NRE)=Q(NRE)+STR(MM,M)*FUNKNO(NRE,LLL-MM+1) + 120 CONTINUE + ENDIF + 130 CONTINUE + IF(IMPX.GE.8) WRITE(6,'(7H GROUP=,I8,7H S=,2X,1P,9D12.4/ + 1 (21X,9D12.4))') LLL,(Q(NRE),NRE=1,NREG) +*---- +* FLUX SOLUTION. +*---- + KPSYS=LCMGIL(JPSYS,LLL) + CALL LCMGET(KPSYS,'DRAGON-PCSCT',PIJ) + DO 150 NRE=1,NREG + SSUM=0.0D0 + DO 140 NNRE=1,NREG + SSUM=SSUM+PIJ(NRE,NNRE)*Q(NNRE) + 140 CONTINUE + FUNKNO(NRE,LLL)=REAL(SSUM) + 150 CONTINUE + IF(IMPX.GE.8) WRITE(6,'(7H GROUP=,I8,7H FLUX=,2X,1P,9E12.4/ + 1 (21X,9E12.4))') LLL,(FUNKNO(NRE,LLL),NRE=1,NREG) + 160 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(Q,PIJ,STIS,STR,SIGWIN,SIGTOT,SOURCE,DEL) + DEALLOCATE(NPSYS,NLET) + RETURN + END diff --git a/Dragon/src/AUTIT2.f b/Dragon/src/AUTIT2.f new file mode 100644 index 0000000..f8a45cc --- /dev/null +++ b/Dragon/src/AUTIT2.f @@ -0,0 +1,241 @@ +*DECK AUTIT2 + SUBROUTINE AUTIT2(IPTRK,IFTRAK,IPSYS,MAXTRA,KNORM,NUN,LBIN,NREG, + 1 NBMIX,NBISO,MAT,VOL,KEYFLX,NIRES,IAPT,CDOOR,LEAKSW,TITR,IMPX, + 2 CONC,SIGS,SIGT,SIGS1,DIL,PRI,UUU,DELI,ITRANC,NEXT,III,FUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of the multigroup neutron flux for a non-pij method. +* +*Copyright: +* Copyright (C) 2023 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK file unit number used to store the tracks. +* IPSYS pointer to the system LCM object. +* MAXTRA maximum number of elements in vector PRI. +* KNORM type of cp normalization. +* NUN number of unknowns in a single energy group. +* LBIN number of energy groups. +* NREG number of regions. +* NBMIX number of mixtures in the internal library. +* NBISO number of distinct isotopes. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX position of average fluxes in the unknown vector. +* NIRES number of correlated resonant isotopes. +* IAPT resonant isotope index associated with isotope I. Mixed +* moderator if IAPT(I)=NIRES+1. Out-of-fuel isotope if +* IAPT(I)=0. +* CDOOR name of the geometry/solution operator. +* LEAKSW leakage flag (LEAKSW=.true. if neutron leakage through +* external boundary is present). +* TITR title. +* IMPX print flag (equal to zero for no print). +* CONC number densities of each isotope in each mixture. +* SIGS P0 scattering microscopic x-s. +* SIGT total microscopic x-s. +* SIGS1 P1 scattering microscopic x-s. +* DIL microscopic dilution cross section of each isotope. +* PRI info to rebuild the SCAT matrix. +* UUU lethargy limits of the groups. +* DELI elementary lethargy width. +* ITRANC type of transport correction. +* NEXT used in subroutine LIBECT. +* III offset in PRI array. +* +*Parameters: output +* FUNKNO neutron flux per unit lethargy. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE DOORS_MOD +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS + INTEGER IFTRAK,MAXTRA,KNORM,NUN,LBIN,NREG,NBMIX,NBISO,MAT(NREG), + 1 NIRES,IAPT(NBISO),KEYFLX(NREG),IMPX,ITRANC,NEXT(NBISO), + 2 III(NBISO+1) + REAL VOL(NREG),CONC(NBMIX,NBISO),SIGS(LBIN,NBISO), + 1 SIGT(LBIN,NBISO),SIGS1(LBIN,NBISO),DIL(NBISO),PRI(MAXTRA), + 2 UUU(LBIN+1),DELI,FUNKNO(NUN,LBIN) + LOGICAL LEAKSW + CHARACTER CDOOR*12,TITR*72 +*---- +* LOCAL VARIABLES +*---- + INTEGER, PARAMETER :: NGEFF=1 + TYPE(C_PTR) JPSYS,KPSYS,KPSOU1(NGEFF),KPSOU2(NGEFF) + INTEGER NGIND(NGEFF),NBS2(NGEFF) + CHARACTER HSMG*131 + LOGICAL LSOUR +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NLET,NPSYS + REAL, ALLOCATABLE, DIMENSION(:) :: DEL,SIGG,SIGTOT,SIGWIN,STIS, + 1 SUNKNO + REAL, ALLOCATABLE, DIMENSION(:,:) :: STR +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NLET(NBMIX),NPSYS(LBIN)) + ALLOCATE(DEL(LBIN),SIGG(0:NBMIX),SIGTOT(0:NBMIX),SIGWIN(0:NBMIX), + 1 STR(LBIN,NBMIX),STIS(LBIN),SUNKNO(NUN)) +* + JPSYS=LCMLID(IPSYS,'GROUP',LBIN) + DO 10 LLL=1,LBIN + DEL(LLL)=UUU(LLL+1)-UUU(LLL) + 10 CONTINUE + DO 60 LLL=1,LBIN + NPSYS(LLL)=LLL +*---- +* COMPUTE THE TOTAL SCATTERING CROSS SECTIONS. +*---- + SIGTOT(0)=0.0 + DO 20 M=1,NBMIX + SIGTOT(M)=0.0 + DO 15 K=1,NBISO + IF(ITRANC.NE.0) SIGTOT(M)=SIGTOT(M)-CONC(M,K)*SIGS1(LLL,K) + SIGTOT(M)=SIGTOT(M)+CONC(M,K)*(DIL(K)+SIGT(LLL,K)) + 15 CONTINUE + 20 CONTINUE + IF(IMPX.GE.9) THEN + WRITE (6,'(//45H AUTIT2: TOTAL MACROSCOPIC CROSS SECTIONS IN , + 1 5HGROUP,I5,1H:/)') LLL + WRITE (6,'(1X,1P,10E13.5)') (SIGTOT(MAT(NRE)),NRE=1,NREG) + ENDIF +*---- +* COMPUTE THE P0 WITHIN-GROUP SCATTERING CROSS SECTIONS. +*---- + SIGWIN(0:NBMIX)=0.0 + DO 50 K=1,NBISO + IF((IAPT(K).GT.0).AND.(IAPT(K).LE.NIRES)) THEN + CALL LIBECT(MAXTRA,LLL,PRI,UUU(2),DELI,DEL,NEXT(K),III(K),MML, + 1 STIS) + DO 30 M=1,NBMIX + SIGWIN(M)=SIGWIN(M)+CONC(M,K)*STIS(1)*SIGS(LLL,K) + 30 CONTINUE + ENDIF + IF(ITRANC.NE.0) THEN + DO 40 M=1,NBMIX + SIGWIN(M)=SIGWIN(M)-CONC(M,K)*SIGS1(LLL,K) + 40 CONTINUE + ENDIF + 50 CONTINUE + IF(IMPX.GE.10) THEN + WRITE (6,'(//45H P0 WITHIN-GROUP SCATTERING MACROSCOPIC CROSS, + 1 18H SECTIONS IN GROUP,I5,1H:/)') LLL + WRITE (6,'(1X,1P,10E13.5)') (SIGWIN(MAT(NRE)),NRE=1,NREG) + ENDIF +* + KPSYS=LCMDIL(JPSYS,LLL) + CALL LCMPUT(KPSYS,'DRAGON-TXSC',NBMIX+1,2,SIGTOT(0)) + CALL LCMPUT(KPSYS,'DRAGON-S0XSC',NBMIX+1,2,SIGWIN(0)) + 60 CONTINUE +*---- +* COMPUTE THE GROUPWISE RESPONSE MATRICES. +*---- + NANI=1 + NW=0 + NALBP=0 + ISTRM=1 + CALL DOORAV (CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IMPX,LBIN,NREG, + > NBMIX,NANI,NW,MAT,VOL,KNORM,LEAKSW,TITR,NALBP,ISTRM) +*---- +* COMPUTE THE ELASTIC SLOWING-DOWN SOURCE. +*---- + DO 160 LLL=1,LBIN + DO M=1,NBMIX + NLET(M)=1 + STR(:LBIN,M)=0.0 + ENDDO + DO 90 K=1,NBISO + IF((IAPT(K).GT.0).AND.(IAPT(K).LE.NIRES)) THEN + CALL LIBECT(MAXTRA,LLL,PRI,UUU(2),DELI,DEL,NEXT(K),III(K),MML, + 1 STIS) + DO 80 M=1,NBMIX + AUX=CONC(M,K) + IF(AUX.EQ.0.) GOTO 80 + NLET(M)=MAX(NLET(M),MML) + DO 70 MM=1,MML + LLJ=LLL-MM+1 + STR(MM,M)=STR(MM,M)+AUX*STIS(MM)*SIGS(LLJ,K)*DEL(LLJ)/DEL(LLL) + 70 CONTINUE + 80 CONTINUE + ENDIF + 90 CONTINUE +*---- +* DILUTION SOURCE. +*---- + SIGG(0:NBMIX)=0.0 + DO 110 IBM=1,NBMIX + DO 100 K=1,NBISO + IF((IAPT(K).EQ.0).OR.(IAPT(K).EQ.NIRES+1)) THEN + SIGG(IBM)=SIGG(IBM)+CONC(IBM,K)*SIGS(LLL,K) + ELSE + SIGG(IBM)=SIGG(IBM)+CONC(IBM,K)*DIL(K) + ENDIF + 100 CONTINUE + 110 CONTINUE + SUNKNO(:NUN)=0.0 + CALL DOORS(CDOOR,IPTRK,NBMIX,0,NUN,SIGG,SUNKNO) +*---- +* SCATTERING SOURCE. +*---- + DO 130 MM=2,LLL + SIGG(0:NBMIX)=0.0 + LSOUR=.FALSE. + DO 120 IBM=1,NBMIX + IF(MM.LE.NLET(IBM)) THEN + LSOUR=.TRUE. + SIGG(IBM)=STR(MM,IBM) + ENDIF + 120 CONTINUE + IF(LSOUR) CALL DOORS(CDOOR,IPTRK,NBMIX,0,NUN,SIGG,SUNKNO, + > FUNKNO(1,LLL-MM+1)) + 130 CONTINUE + IF(IMPX.GE.8) WRITE(6,'(7H GROUP=,I5,7H S=,2X,1P,9D12.4/ + 1 (21X,9D12.4))') LLL,(SUNKNO(KEYFLX(NRE)),NRE=1,NREG) +*---- +* FLUX SOLUTION. +*---- + IDIR=0 + NGIND(1)=LLL + NBS2(1)=0 + KPSOU1(1)=C_NULL_PTR + KPSOU2(1)=C_NULL_PTR + IMPX2=MAX(0,IMPX-5) + KPSYS=LCMDIL(JPSYS,LLL) + IF(CDOOR.EQ.'SYBIL') THEN + CALL SYBILF(KPSYS,IPTRK,IFTRAK,IMPX2,NGEFF,NGIND,IDIR,NREG, + 1 NUN,MAT,VOL,FUNKNO(1,LLL),SUNKNO,TITR) + ELSE IF(CDOOR.EQ.'SN') THEN + CALL SNF(KPSYS,IPTRK,IFTRAK,IMPX2,NGEFF,NGIND,IDIR,NREG, + 1 NBMIX,NUN,MAT,VOL,KEYFLX,FUNKNO(1,LLL),SUNKNO,TITR, + 2 NBS2,KPSOU1,KPSOU2) + ELSE + WRITE(HSMG,'(13HAUTIT2: DOOR ,A,20H IS NOT IMPLEMENTED.)') + 1 TRIM(CDOOR) + CALL XABORT(HSMG) + ENDIF + IF(IMPX.GE.8) WRITE(6,'(7H GROUP=,I5,7H FLUX=,2X,1P,9E12.4/ + 1 (21X,9E12.4))') LLL,(FUNKNO(KEYFLX(NRE),LLL),NRE=1,NREG) + 160 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SUNKNO,STIS,STR,SIGWIN,SIGTOT,SIGG,DEL) + DEALLOCATE(NPSYS,NLET) + RETURN + END diff --git a/Dragon/src/AUTO.f b/Dragon/src/AUTO.f new file mode 100644 index 0000000..37f7f98 --- /dev/null +++ b/Dragon/src/AUTO.f @@ -0,0 +1,383 @@ +*DECK AUTO + SUBROUTINE AUTO(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* UAutosecol self-shielding operator. +* +*Copyright: +* Copyright (C) 2023 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1) creation or modification type(L_LIBRARY) (no +* subgroups); +* HENTRY(2) read-only type(L_LIBRARY) (with subgroups); +* HENTRY(3) read-only type(L_TRACK); +* HENTRY(4) optional read-only sequential binary tracking file. +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40,MAXRSS=300,IOUT=6) + TYPE(C_PTR) IPLI0,IPLIB,IPTRK + CHARACTER TEXT4*4,HSIGN*12,TEXT8*8,TEXT12*12,HSMG*131,CDOOR*12, + 1 TITR*72,HISOT*12 + DOUBLE PRECISION DFLOTT + LOGICAL LEAKSW,LDIL + INTEGER IGP(NSTATE),IPAR(NSTATE),IPAS(NSTATE),IRSS(MAXRSS) +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: DIL + CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: HUSED +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.LE.2) CALL XABORT('AUTO: THREE PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('AUTO: LI' + 1 //'NKED LIST OR XSM FILE EXPECTED AT LHS.') + IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) CALL XABORT('AUTO: EN' + 1 //'TRY IN CREATE OR MODIFICATION MODE EXPECTED.') + IF((JENTRY(2).NE.2).OR.((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2))) + 1 CALL XABORT('AUTO: LINKED LIST OR XSM FILE IN READ-ONLY MODE E' + 2 //'XPECTED AT FIRST RHS.') + IF((JENTRY(3).NE.2).OR.((IENTRY(3).NE.1).AND.(IENTRY(3).NE.2))) + 1 CALL XABORT('AUTO: LINKED LIST OR XSM FILE IN READ-ONLY MODE E' + 2 //'XPECTED AT SECOND RHS.') + CALL LCMGTC(KENTRY(3),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_TRACK') THEN + TEXT12=HENTRY(3) + CALL XABORT('AUTO: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_TRACK EXPECTED.') + ENDIF + CALL LCMGTC(KENTRY(3),'TRACK-TYPE',12,CDOOR) + IPLI0=KENTRY(1) + IPLIB=KENTRY(2) + IPTRK=KENTRY(3) + INDREC=0 + IF(JENTRY(1).EQ.0) THEN + INDREC=1 + HSIGN='L_LIBRARY' + CALL LCMPTC(IPLI0,'SIGNATURE',12,HSIGN) + ELSE IF(JENTRY(1).EQ.1) THEN + CALL LCMGTC(IPLI0,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_LIBRARY') THEN + TEXT12=HENTRY(1) + CALL XABORT('AUTO: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_LIBRARY EXPECTED.') + ENDIF + INDREC=2 + ENDIF +*---- +* RECOVER TABULATED FUNCTIONS. +*---- + CALL XDRTA2 +*---- +* RECOVER TRACKING FILE INFORMATION. +*---- + IFTRAK=0 + IF(NENTRY.GE.4) THEN + IF(IENTRY(4).EQ.3) THEN + IF(JENTRY(4).NE.2) CALL XABORT('AUTO: BINARY TRACKING FILE NA' + 1 //'MED '//TEXT12//' IS NOT IN REAL-ONLY MODE.') + IFTRAK=FILUNIT(KENTRY(4)) + ENDIF + ENDIF +*---- +* RECOVER GENERAL TRACKING INFORMATION. +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',IGP) + NREG=IGP(1) + NUN=IGP(2) + LEAKSW=IGP(3).EQ.0 + CALL LCMLEN(IPTRK,'TITLE',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGTC(IPTRK,'TITLE',72,TITR) + ELSE + TITR='*** NO TITLE PROVIDED ***' + ENDIF +*---- +* RECOVER INTERNAL LIBRARY PARAMETERS. +*---- + CALL LCMGTC(IPLIB,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_LIBRARY') THEN + TEXT12=HENTRY(2) + CALL XABORT('AUTO: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_LIBRARY EXPECTED.') + ENDIF + CALL LCMGET(IPLIB,'STATE-VECTOR',IPAR) + NBISO=IPAR(2) + NGRP=IPAR(3) + NL=IPAR(4) + ITRANC=IPAR(5) + IGRMIN=IPAR(9)+1 + IGRMAX=IPAR(10) + NED=IPAR(13) + NBMIX=IPAR(14) + NRES=IPAR(15) + NDEL=IPAR(19) + IF(IGP(4).GT.NBMIX) THEN + WRITE(HSMG,'(45HAUTO: THE NUMBER OF MIXTURES IN THE TRACKING , + 1 1H(,I5,51H) IS GREATER THAN THE NUMBER OF MIXTURES IN THE INT, + 2 15HERNAL LIBRARY (,I5,2H).)') IGP(4),NBMIX + CALL XABORT(HSMG) + ENDIF + IF(INDREC.EQ.2) THEN + CALL LCMGET(IPLI0,'STATE-VECTOR',IPAR) + IF(IPAR(2).NE.NBISO) CALL XABORT('AUTO: INVALID LIBRARY.') + ENDIF + ALLOCATE(DIL(NBISO),HUSED(NBISO)) + DIL(:NBISO)=0.0 + CALL LCMGTC(IPLIB,'ISOTOPESUSED',12,NBISO,HUSED) +* + IMPX=1 + LDIL=.FALSE. + CALL LCMLEN(IPLI0,'SHIBA_SG',LENLCM,ITYLCM) + IF(LENLCM.NE.0) THEN + CALL LCMSIX(IPLI0,'SHIBA_SG',1) + CALL LCMGET(IPLI0,'STATE-VECTOR',IPAS) + CALL LCMSIX(IPLI0,' ',2) + IGRMIN=IPAS(1) + IGRMAX=IPAS(2) + KSPH=IPAS(3) + ITRANZ=IPAS(4) + NPASS=IPAS(5) + IPHASE=IPAS(6) + ICALC=IPAS(8) + IALTER=IPAS(11) + MAXTRA=IPAS(12) + ISEED=IPAS(14) + ELSE + KSPH=1 + ITRANZ=ITRANC + NPASS=1 + IF(CDOOR.EQ.'SYBIL') THEN + IPHASE=2 + ELSE IF(CDOOR.EQ.'EXCELL') THEN + IPHASE=2 + ELSE + IPHASE=1 + ENDIF + ICALC=0 + IALTER=0 + MAXTRA=10000 + ISEED=0 + ENDIF +* + 10 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.10) GO TO 70 + IF(INDIC.NE.3) CALL XABORT('AUTO: CHARACTER DATA EXPECTED(1).') + IF(TEXT4.EQ.'EDIT') THEN + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('AUTO: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT4.EQ.'GRMI') THEN + CALL REDGET(ITYPLU,IGRMIN,FLOTT,TEXT4,DFLOTT) + IF(ITYPLU.NE.1) CALL XABORT('AUTO: INTEGER DATA EXPECTED(2).') + ELSE IF(TEXT4.EQ.'GRMA') THEN + CALL REDGET(ITYPLU,IGRMAX,FLOTT,TEXT4,DFLOTT) + IF(ITYPLU.NE.1) CALL XABORT('AUTO: INTEGER DATA EXPECTED(3).') + IF(IGRMAX.GT.NGRP) THEN + CALL XABORT('AUTO: ILLEGAL NUMBER OF GROUP IN LIBRARY.') + ENDIF + ELSE IF(TEXT4.EQ.'NOSP') THEN + KSPH=0 + ELSE IF(TEXT4.EQ.'SPH') THEN + KSPH=1 + ELSE IF(TEXT4.EQ.'NOTR') THEN + ITRANZ=0 + ELSE IF(TEXT4.EQ.'TRAN') THEN + ITRANZ=1 + ELSE IF(TEXT4.EQ.'PASS') THEN + CALL REDGET(ITYPLU,NPASS,FLOTT,TEXT4,DFLOTT) + IF(ITYPLU.NE.1) CALL XABORT('AUTO: INTEGER DATA EXPECTED(5).') + IF(NPASS.LE.0) CALL XABORT('AUTO: POSITIVE PASS EXPECTED.') + ELSE IF(TEXT4.EQ.'ARM') THEN + IPHASE=1 + ELSE IF(TEXT4.EQ.'PIJ') THEN + IPHASE=2 + ELSE IF(TEXT4.EQ.'CALC') THEN + ICALC=1 + CALL LCMSIX(IPLI0,'SHIBA_SG',1) + CALL LCMSIX(IPLI0,'-DATA-CALC-',1) + CALL REDGET(ITYPLU,NITMA,FLOTT,TEXT12,DFLOTT) + IF(ITYPLU.NE.3) CALL XABORT('AUTO: CHARACTER DATA EXPECTED.') + 40 IF(TEXT12.EQ.'ENDC') THEN + CALL LCMSIX(IPLI0,' ',2) + CALL LCMSIX(IPLI0,' ',2) + GO TO 10 + ENDIF + IF(TEXT12.NE.'REGI') CALL XABORT('AUTO: REGI KWORD EXPECTED.') + CALL REDGET(ITYPLU,NITMA,FLOTT,TEXT12,DFLOTT) + IF(ITYPLU.NE.3) CALL XABORT('AUTO: CHARACTER DATA EXPECTED.') + IF(TEXT12(5:).NE.' ') CALL XABORT('AUTO: 4-CHARACTER NAME EXPE' + 1 //'CTED.') + CALL LCMSIX(IPLI0,TEXT12(:4),1) + CALL REDGET(ITYPLU,NITMA,FLOTT,TEXT12,DFLOTT) + IF(ITYPLU.NE.3) CALL XABORT('AUTO: CHARACTER DATA EXPECTED.') + 50 IF((TEXT12.EQ.'ENDC').OR.(TEXT12.EQ.'REGI')) THEN + CALL LCMSIX(IPLI0,' ',2) + GO TO 40 + ENDIF + HISOT=TEXT12 + NRSS=0 + 60 CALL REDGET(ITYPLU,NITMA,FLOTT,TEXT12,DFLOTT) + IF(ITYPLU.EQ.3) THEN + IF(TEXT12.EQ.'ALL') THEN + NRSS=1 + IRSS(1)=-999 + GO TO 60 + ENDIF + IF(NRSS.EQ.0) CALL XABORT('AUTO: INTEGER ARRAY EXPECTED.') + CALL LCMPUT(IPLI0,HISOT,NRSS,1,IRSS) + GO TO 50 + ENDIF + IF(ITYPLU.NE.1) CALL XABORT('AUTO: INTEGER DATA EXPECTED(6).') + NRSS=NRSS+1 + IF(NRSS.GT.MAXRSS) CALL XABORT('AUTO: MAXRSS OVERFLOW.') + IF((NITMA.LE.0).OR.(NITMA.GT.NBMIX)) THEN + WRITE(HSMG,'(42HAUTO: REGI KEYWORD -- INVALID MIXTURE INDE, + 1 2HX=,I5,1H.)') NITMA + CALL XABORT(HSMG) + ENDIF + IRSS(NRSS)=NITMA + GO TO 60 + ELSE IF(TEXT4.EQ.'DILU') THEN + CALL REDGET(ITYPLU,NITMA,FLOTT,TEXT8,DFLOTT) + IF(ITYPLU.NE.3) CALL XABORT('AUTO: CHARACTER DATA EXPECTED.') + LDIL=.FALSE. + DO ISO=1,NBISO + IF(TEXT8.EQ.HUSED(ISO)(:8)) THEN + LDIL=.TRUE. + CALL REDGET(ITYPLU,NITMA,DIL(ISO),TEXT12,DFLOTT) + IF(ITYPLU.NE.2) CALL XABORT('AUTO: REAL DATA EXPECTED.') + ENDIF + ENDDO + IF(.NOT.LDIL) THEN + WRITE(HSMG,'(29HAUTO: CANNOT FIND ALIAS NAME=,A8,1H.)') TEXT8 + CALL XABORT(HSMG) + ENDIF + ELSE IF(TEXT4.EQ.'KERN') THEN + CALL REDGET(INDIC,IALTER,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('AUTO: INTEGER DATA EXPECTED(7).') + ELSE IF(TEXT4.EQ.'MAXT') THEN + CALL REDGET(INDIC,MAXTRA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('AUTO: INTEGER DATA EXPECTED(9).') + ELSE IF(TEXT4.EQ.'SEED') THEN +* INPUT A SEED INTEGER FOR THE UNRESOLVED ENERGY DOMAIN + CALL REDGET(INDIC,ISEED,FLOTT,TEXT4,DFLOTT) + IF (INDIC.NE.1) CALL XABORT('AUTO: INTEGER DATA EXPECTED(10).') + ELSE IF(TEXT4.EQ.';') THEN + GO TO 70 + ELSE + CALL XABORT('AUTO: '//TEXT4//' IS AN INVALID KEY WORD.') + ENDIF + GO TO 10 +*---- +* THE NUMBER OF UNKNOWNS OF A CURRENT-BASED MULTICELL ITERATION IS +* INCREASED TO HOLD INTERFACE CURRENT COMPONENTS. +*---- + 70 IF(IPHASE.EQ.1) THEN + IF(CDOOR.EQ.'SYBIL') NUN=NUN+IGP(9) + IF((CDOOR.EQ.'EXCELL').AND.(IGP(7).EQ.5)) NUN=NUN+IGP(28) + ENDIF +*---- +* CALL AUTO: DRIVER. +*---- + IF(IMPX.GT.0) THEN + IF(INDREC.EQ.1) WRITE(IOUT,100) + WRITE(IOUT,110) TITR,CDOOR(:9),IGRMIN,IGRMAX,KSPH,ITRANZ,NPASS, + 1 IPHASE,ICALC,IALTER,MAXTRA,ISEED + ENDIF + IF(LDIL.AND.(IMPX.GT.0)) THEN + DO ISO=1,NBISO + IF(DIL(ISO).NE.0.0) THEN + WRITE(6,'(/20H AUTO: SET DILUTION(,A12,2H)=,1P,E12.4,2h b)') + 1 HUSED(ISO),DIL(ISO) + ENDIF + ENDDO + ENDIF +*---- +* PERFORM SELF-SHIELDING. +*---- + IF(CDOOR.EQ.'MCCG') THEN + CALL LCMLEN(IPTRK,'KEYFLX',LKFL,ITYLCM) + NFUNL=LKFL/NREG + ELSE + NFUNL=1 + ENDIF + CALL AUTDRV(IPLI0,IPTRK,IPLIB,IFTRAK,INDREC,CDOOR,IMPX,IGRMIN, + 1 IGRMAX,NGRP,NBMIX,NREG,NUN,NBISO,NL,NED,NDEL,LEAKSW,ITRANZ, + 2 IPHASE,TITR,KSPH,NRES,NPASS,ICALC,IALTER,MAXTRA,ISEED,DIL, + 3 DELI) + IF(DELI.EQ.0.0) CALL XABORT('AUTO: LETHARGY WIDTH UNDEFINED.') + DEALLOCATE(HUSED,DIL) +*---- +* STORE THE GENERAL SHELF-SHIELDING PARAMETERS. +*---- + IPAS(:NSTATE)=0 + IPAS(1)=IGRMIN + IPAS(2)=IGRMAX + IPAS(3)=KSPH + IPAS(4)=ITRANZ + IPAS(5)=NPASS + IPAS(6)=IPHASE + IPAS(8)=ICALC + IPAS(11)=IALTER + IPAS(12)=MAXTRA + IPAS(14)=ISEED + CALL LCMSIX(IPLI0,'SHIBA_SG',1) + CALL LCMPUT(IPLI0,'STATE-VECTOR',NSTATE,1,IPAS) + CALL LCMSIX(IPLI0,' ',2) + RETURN +* + 100 FORMAT(1H1,32H A UU UU TTTTTTTT OOOOO ,107(1H*)/ + 1 34H AAA UU UU TTTTTTTT OOOOOOO ,63(1H*), + 2 43H AUTOSECOL SELF-SHIELDING MODEL. A. HEBERT/ + 3 33H AA AA UU UU TT OO OO/ + 4 33H AA AA UU UU TT OO OO/ + 5 33H AAAAAAA UU UU TT OO OO/ + 6 33H AAAAAAA UU UU TT OO OO/ + 7 33H AA AA UUUUUUU TT OOOOOOO/ + 8 32H AA AA UUUUU TT OOOOO/) + 110 FORMAT(/1X,A72//8H OPTIONS/8H -------/ + 1 7H CDOOR ,A9,30H (NAME OF THE SOLUTION DOOR)/ + 2 7H IGRMIN,I9,27H (FIRST GROUP TO PROCESS)/ + 3 7H IGRMAX,I9,34H (MOST THERMAL GROUP TO PROCESS)/ + 4 7H KSPH ,I9,47H (=0: NO SPH CORRECTION; =1: SPH CORRECTION I, + 5 19HN RESONANT REGIONS)/ + 6 7H ITRANZ,I9,45H (0=NO TRANSPORT CORRECTION/1=APOLLO TYPE/2, + 7 57H=RECOVER FROM LIBRARY/3=WIMS-D TYPE/4=LEAKAGE CORRECTION)/ + 8 7H NPASS ,I9,31H (NUMBER OF OUTER ITERATIONS)/ + 9 7H IPHASE,I9,37H (=1: NATIVE ASSEMBLY; =2: USE PIJ)/ + 1 7H ICALC ,I9,48H (=0: NO &CALC DATA; =1: &CALC DATA AVAILABLE)/ + 2 7H IALTER,I9,47H (=0: USE EXACT KERNEL; =1: USE APPROXIMATE K, + 3 6HERNEL)/ + 4 7H MAXTRA,I9,44H (MAXIMUM NUMBER OF DOWN-SCATTERING TERMS)/ + 5 6H ISEED,I10,45H (INITIAL SEED FOR RANDOM NUMBER GENERATOR)) + END diff --git a/Dragon/src/AUTONE.f b/Dragon/src/AUTONE.f new file mode 100644 index 0000000..3a95006 --- /dev/null +++ b/Dragon/src/AUTONE.f @@ -0,0 +1,509 @@ +*DECK AUTONE + SUBROUTINE AUTONE(IPLI0,IPTRK,IPLIB,IFTRAK,CDOOR,IMPX,INRS, + 1 IGRMIN,IGRRES,IGRMAX,NGRP,NBMIX,NREG,NUN,NBISO,NL,NED,NDEL, + 2 ISONAM,IHSUF,DEN,LSHI,DIL,MIX,MAT,VOL,KEYFLX,LEAKSW,ITRANC, + 3 IPHASE,TITR,KSPH,IALTER,DELI,LBIN,NBIN,EBIN,MAXTRA,ISEED) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform a resonance self-shielding calculation in resonant region +* INRS and build a corresponding internal library for the Autosecol +* method. +* +*Copyright: +* Copyright (C) 2023 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLI0 pointer to the internal microscopic cross section library +* builded by the self-shielding module (L_LIBRARY signature). +* IPTRK pointer to the tracking. (L_TRACK signature). +* IPLIB pointer to the internal microscopic cross section library +* with subgroups (L_LIBRARY signature). +* IFTRAK unit number of the sequential binary tracking file. +* CDOOR name of the geometry/solution operator. +* IMPX print flag (equal to zero for no print). +* INRS resonant region index. +* IGRMIN first group where the self-shielding is applied. +* IGRRES first resolved energy group. +* IGRMAX most thermal group where the self-shielding is applied. +* NGRP number of energy groups. +* NBMIX number of mixtures in the internal library. +* NREG number of regions. +* NUN number of unknowns per energy group. +* NBISO number of isotopes specifications in the internal library. +* NL number of Legendre orders required in the calculation +* (NL=1 or higher). +* NED number of extra vector edits. +* NDEL number of delayed neutron precursor groups. +* ISONAM alias name of isotopes. +* IHSUF suffix name of isotopes. +* DEN density of each isotope. +* LSHI resonant region index assigned to each isotope. +* DIL microscopic dilution cross section of each isotope. +* MIX mix number of each isotope (can be zero). +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX pointers of fluxes in unknown vector. +* LEAKSW leakage flag (LEAKSW=.TRUE. if neutron leakage through +* external boundary is present). +* ITRANC type of transport correction. +* IPHASE type of flux solution (=1 use a native flux solution door; +* =2 use collision probabilities). +* TITR title. +* KSPH SPH equivalence flag (=0 no SPH correction; =1 SPH correction +* in the fuel). +* IALTER type of elastic slowing-down kernel (=0: use exact kernel; +* =1: use an approximate kernel for the resonant isotopes). +* DELI elementary lethargy width used by the elastic kernel. +* LBIN total number of fine energy groups in the Autolib. +* NBIN number of fine energy groups in each coarse energy group. +* EBIN energy limits of the Autolib fine groups. +* MAXTRA maximum number of down-scattering terms. +* ISEED the seed for the generation of random numbers in the +* unresolved energy domain. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLI0,IPTRK,IPLIB + INTEGER IFTRAK,IMPX,INRS,IGRMIN,IGRRES,IGRMAX,NGRP,NBMIX,NREG, + 1 NUN,NBISO,NL,NED,NDEL,ISONAM(3,NBISO),IHSUF(NBISO),LSHI(NBISO), + 2 MIX(NBISO),MAT(NREG),KEYFLX(NREG),ITRANC,IPHASE,KSPH,IALTER, + 3 LBIN,NBIN(NGRP),MAXTRA,ISEED + REAL DEN(NBISO),DIL(NBISO),VOL(NREG),DELI,EBIN(LBIN+1) + LOGICAL LEAKSW + CHARACTER CDOOR*12,TITR*72 +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION VOLTOT,GAR0,GAR1,GAR2,GAR3,GAR4 + CHARACTER TEXT4*4,HCAL*12,NAME*12,TEXT12*12,HSMG*131 + LOGICAL LABS + TYPE(C_PTR) KPLIB +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IREX,IAPT + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISOBIS + REAL, ALLOCATABLE, DIMENSION(:) :: STIS,GAS,UUU,DELBIN,DELTAU + REAL, ALLOCATABLE, DIMENSION(:,:) :: GA2,PRI,SPH,FIXE,PHGAR,STGAR, + 1 SFGAR,FUNKNO,SIGT,SIGS,SIGS1,SIGF,UNGAR + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SSGAR,SAGAR,SDGAR + REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: SIGGAR,S0GAR + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: WSIG + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: WSCAT + LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASKI + LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: MASKG + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HVECT + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO1 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(ISOBIS(3,NBISO),IREX(NBMIX),IAPT(NBISO)) + ALLOCATE(MASKI(NBISO),HVECT(NED)) +*---- +* FIND THE NEW ISOTOPE NAMES IN IPLI0. +*---- + CALL LCMLEN(IPLI0,'ISOTOPESUSED',ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + CALL LCMGET(IPLI0,'ISOTOPESUSED',ISOBIS) + ELSE + CALL LCMGET(IPLIB,'ISOTOPESUSED',ISOBIS) + ENDIF + CALL LCMGTC(IPLIB,'ADDXSNAME-P0',8,NED,HVECT) + DO 10 ISO=1,NBISO + WRITE(TEXT4,'(A4)') IHSUF(ISO) + IF(TEXT4.NE.' ') ISOBIS(3,ISO)=IHSUF(ISO) + 10 CONTINUE + CALL LCMPUT(IPLI0,'ISOTOPESUSED',3*NBISO,3,ISOBIS) +*---- +* COMPUTE THE NUMBER OF RESONANT ISOTOPES IN REGION INRS AND THE +* RESONANT ISOTOPE INDEX ASSOCIATED TO EACH ISOTOPE SPECIFICATION. +*---- + NIRES=0 + DO 50 ISO=1,NBISO + IAPT(ISO)=0 + IF((LSHI(ISO).EQ.INRS).AND.(DEN(ISO).NE.0.0)) THEN + DO 20 NRE=1,NREG + IF(MAT(NRE).EQ.MIX(ISO)) GO TO 30 + 20 CONTINUE + GO TO 50 + 30 DO 40 JSO=1,ISO-1 + IF((ISOBIS(1,ISO).EQ.ISOBIS(1,JSO)).AND. + 1 (ISOBIS(2,ISO).EQ.ISOBIS(2,JSO)).AND. + 2 (ISOBIS(3,ISO).EQ.ISOBIS(3,JSO)).AND. + 3 (LSHI(JSO).EQ.INRS).AND. + 4 (DEN(JSO).NE.0.0).AND.(IAPT(JSO).NE.0)) THEN + IAPT(ISO)=IAPT(JSO) + GO TO 50 + ENDIF + 40 CONTINUE + NIRES=NIRES+1 + IAPT(ISO)=NIRES + ENDIF + 50 CONTINUE + WRITE(HCAL,'(1HC,I5.5)') INRS + IF(NIRES.EQ.0) THEN + WRITE(HSMG,'(45HAUTONE: NO RESONANT ISOTOPES IN RESONANT REGI, + 1 9HON NUMBER,I4,7H (HCAL=,A12,2H).)') INRS,HCAL + CALL XABORT(HSMG) + ENDIF + IF(IMPX.GT.0) WRITE(6,'(/35H AUTONE: PERFORMING SELF-SHIELDING , + 1 18HCALCULATION NAMED ,A12,1H.)') HCAL +*---- +* FIND THE NUMBER OF FUEL REGIONS AND THE FUEL REGION INDICES ASSIGNED +* TO EACH RESONANT MIXTURE. +*---- + ALLOCATE(MASKG(NGRP,NIRES)) + IREX(:NBMIX)=0 + DO 60 ISO=1,NBISO + IBM=MIX(ISO) + IF((IBM.GT.0).AND.(IAPT(ISO).NE.0)) IREX(IBM)=1 + 60 CONTINUE + NBNRS=MAXVAL(IREX(:NBMIX)) + IF(NBNRS.NE.1) CALL XABORT('AUTONE: NBNRS=1 EXPECTED.') + IF(IMPX.GE.1) WRITE(6,410) NIRES,NBNRS,INRS +*---- +* DETERMINE WHICH MODERATOR ISOTOPES ARE MIXED WITH RESONANT ONES. +*---- + DO 70 ISO=1,NBISO + IF((IAPT(ISO).EQ.0).AND.(IREX(MIX(ISO)).GT.0)) IAPT(ISO)=NIRES+1 + 70 CONTINUE + IF(IMPX.GT.1) THEN + WRITE(6,'(/48H AUTONE: IDENTIFICATION OF SELF-SHIELDED ISOTOPE, + 1 14HS (0 < IAPT <=,I4,20H) IN RESONANT REGION,I4,1H:)') NIRES, + 2 INRS + WRITE(6,'(33H ISOTOPE IAPT USED NAME...)') + DO ISO=1,NBISO + WRITE(NAME,'(3A4)') ISOBIS(:3,ISO) + WRITE(6,'(1X,I7,5X,I4,2X,A14)') ISO,IAPT(ISO),NAME + ENDDO + ENDIF +* + ALLOCATE(SPH(NIRES,NGRP),FIXE(NIRES,NGRP),PHGAR(NIRES,NGRP), + 1 STGAR(NIRES,NGRP),SFGAR(NIRES,NGRP),SSGAR(NIRES,NL,NGRP), + 2 S0GAR(NIRES,NL,NGRP,NGRP),SAGAR(NIRES,NED,NGRP), + 3 SDGAR(NIRES,NDEL,NGRP),DELTAU(NGRP)) + ALLOCATE(SIGGAR(NBMIX,0:NIRES,NGRP,3),UNGAR(NUN,NGRP)) + ALLOCATE(UUU(LBIN+1),DELBIN(LBIN),STAT=IER_OK) + IF(IER_OK /= 0) CALL XABORT('AUTONE: ALLOCATION PROBLEM(1).') + ALLOCATE(FUNKNO(NUN,LBIN),STAT=IER_OK) + IF(IER_OK /= 0) CALL XABORT('AUTONE: ALLOCATION PROBLEM(2).') + ALLOCATE(SIGT(LBIN,NBISO),STAT=IER_OK) + IF(IER_OK /= 0) CALL XABORT('AUTONE: ALLOCATION PROBLEM(3).') + ALLOCATE(SIGS(LBIN,NBISO),STAT=IER_OK) + IF(IER_OK /= 0) CALL XABORT('AUTONE: ALLOCATION PROBLEM(4).') + ALLOCATE(SIGS1(LBIN,NBISO),STAT=IER_OK) + IF(IER_OK /= 0) CALL XABORT('AUTONE: ALLOCATION PROBLEM(5).') + ALLOCATE(SIGF(LBIN,NBISO),STAT=IER_OK) + IF(IER_OK /= 0) CALL XABORT('AUTONE: ALLOCATION PROBLEM(6).') +*---- +* COMPUTE THE NEUTRON FLUX. +*---- + CALL AUTFLU(IPTRK,IPLIB,IPLI0,IFTRAK,NREG,NUN,NBMIX,NBISO,NIRES, + 1 MAT,VOL,KEYFLX,CDOOR,LEAKSW,IMPX,DEN,MIX,IAPT,IPHASE,NGRP,IGRMIN, + 2 IGRRES,IGRMAX,DIL,TITR,IALTER,DELI,LBIN,NBIN,EBIN,MAXTRA,ISEED, + 3 ITRANC,UUU,FUNKNO,SIGT,SIGS,SIGS1,SIGF,SIGGAR,MASKG) +*---- +* COMPUTE UNGAR. +*---- + UNGAR(:NUN,:NGRP)=0.0 + LLL=0 + DO 110 IG=1,NGRP + GAR0=0.0D0 + DO 90 LI=1,NBIN(IG) + LLL=LLL+1 + IF(LLL.GT.LBIN) CALL XABORT('AUTONE: LBIN OVERFLOW.') + DELBIN(LLL)=UUU(LLL+1)-UUU(LLL) + GAR0=GAR0+DELBIN(LLL) + DO 80 IUN=1,NUN + UNGAR(IUN,IG)=UNGAR(IUN,IG)+FUNKNO(IUN,LLL)*DELBIN(LLL) + 80 CONTINUE + 90 CONTINUE + DO 100 IUN=1,NUN + UNGAR(IUN,IG)=UNGAR(IUN,IG)/REAL(GAR0) + 100 CONTINUE + 110 CONTINUE +*---- +* CONDENSATION OF AUTOLIB FLUX AND OF RESONANT REACTION RATES. +*---- + ALLOCATE(IPISO1(NBISO),GAS(NGRP),GA2(NGRP,NGRP),PRI(MAXTRA,NL)) + CALL LIBIPS(IPLIB,NBISO,IPISO1) + DELTAU(:NGRP)=0.0 + FIXE(:NIRES,:NGRP)=0.0 + PHGAR(:NIRES,:NGRP)=0.0 + STGAR(:NIRES,:NGRP)=0.0 + SFGAR(:NIRES,:NGRP)=0.0 + SSGAR(:NIRES,:NL,:NGRP)=0.0 + S0GAR(:NIRES,:NL,:NGRP,:NGRP)=0.0 + SAGAR(:NIRES,:NED,:NGRP)=0.0 + SDGAR(:NIRES,:NDEL,:NGRP)=0.0 + DO 260 ISO=1,NBISO + IBM=MIX(ISO) + IF(IBM.LE.0) GO TO 260 + IRES=IAPT(ISO) + IF((IRES.GT.0).AND.(IRES.LE.NIRES)) THEN + ! recover infinite dilution values + KPLIB=IPISO1(ISO) ! set ISO-th isotope + CALL LCMGET(KPLIB,'AWR',AWR) + CALL LCMGET(KPLIB,'NTOT0',GAS) + STGAR(IRES,:NGRP)=GAS(:NGRP) + CALL LCMLEN(KPLIB,'NUSIGF',ILENGT,ITYLCM) + IF(ILENGT.GT.0) THEN + CALL LCMGET(KPLIB,'NUSIGF',GAS) + SFGAR(IRES,:NGRP)=GAS(:NGRP) + ENDIF + DO 120 IL=1,NL + CALL XDRLGS(KPLIB,-1,IMPX,IL-1,IL-1,1,NGRP,GAS,GA2,ITYPRO) + S0GAR(IRES,IL,:NGRP,:NGRP)=GA2(:NGRP,:NGRP) + SSGAR(IRES,IL,:NGRP)=GAS(:NGRP) + 120 CONTINUE + DO 125 IED=1,NED + CALL LCMLEN(KPLIB,HVECT(IED),ILENGT,ITYLCM) + IF(ILENGT.GT.0) THEN + CALL LCMGET(KPLIB,HVECT(IED),GAS) + SAGAR(IRES,IED,:NGRP)=GAS(:NGRP) + ENDIF + 125 CONTINUE + DO 130 IDEL=1,NDEL + WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL + CALL LCMLEN(KPLIB,TEXT12,ILENGT,ITYLCM) + IF(ILENGT.GT.0) THEN + CALL LCMGET(KPLIB,TEXT12,GAS) + SDGAR(IRES,IDEL,:NGRP)=GAS(:NGRP) + ENDIF + 130 CONTINUE + ! set elastic scattering information. + DO 135 IL=1,NL + CALL LIBPRI(MAXTRA,DELI,AWR,IALTER,IL-1,NEXT0,PRI(1,IL)) + 135 ENDDO + ! include self-shielded values + LLL=0 + DO 140 IG=1,IGRMIN-1 + LLL=LLL+NBIN(IG) + 140 CONTINUE + ALLOCATE(STIS(LBIN),WSCAT(NGRP,NGRP,NL),WSIG(NGRP,NL)) + WSCAT(:NGRP,:NGRP,:NL)=0.0D0 + WSIG(:NGRP,:NL)=0.0D0 + DO 210 IG=IGRMIN,IGRMAX + SSGAR1=SSGAR(IRES,1,IG) + ABGAR1=STGAR(IRES,IG)-SSGAR(IRES,1,IG) + SFGAR1=SFGAR(IRES,IG) + LABS=ABS(ABGAR1).GT.1.0E-5*ABS(STGAR(IRES,IG)) + VOLTOT=0.0D0 + GAR0=0.0D0 + GAR1=0.0D0 + GAR2=0.0D0 + GAR3=0.0D0 + GAR4=0.0D0 + DO 150 NRE=1,NREG + IF(MAT(NRE).EQ.IBM) VOLTOT=VOLTOT+VOL(NRE) + 150 CONTINUE + DO 190 LI=1,NBIN(IG) + LLL=LLL+1 + IF(LLL.GT.LBIN) CALL XABORT('AUTONE: LBIN OVERFLOW.') + GAR0=GAR0+DELBIN(LLL) + DO 180 NRE=1,NREG + IF(MAT(NRE).NE.IBM) GO TO 180 + IUN=KEYFLX(NRE) + IF(IUN.EQ.0) GO TO 180 + FLUXL=FUNKNO(IUN,LLL)*VOL(NRE)*DELBIN(LLL) + GAR1=GAR1+FLUXL + GAR2=GAR2+SIGT(LLL,ISO)*FLUXL + GAR3=GAR3+SIGS(LLL,ISO)*FLUXL + GAR4=GAR4+SIGF(LLL,ISO)*FLUXL + DO 175 IL=1,NL + STIS(:LBIN)=0.0 + CALL LIBECT(MAXTRA,LLL,PRI(1,IL),UUU(2),DELI,DELBIN,NEXT0,1,MML, + 1 STIS) + LLJ=0 + DO 170 JG=1,NGRP + DO 160 LJ=1,NBIN(JG) + I=LLL-LLJ + IF(I.LE.0) GO TO 175 + LLJ=LLJ+1 + WSCAT(JG,IG,IL)=WSCAT(JG,IG,IL)+SIGS(LLJ,ISO)*STIS(I)* + 1 FUNKNO(IUN,LLJ)*VOL(NRE)*DELBIN(LLJ) ! JG --> IG + 160 CONTINUE + 170 CONTINUE + 175 CONTINUE + 180 CONTINUE + 190 CONTINUE + DELTAU(IG)=REAL(GAR0) + STGAR(IRES,IG)=REAL(GAR2/GAR1) + SSGAR(IRES,1,IG)=REAL(GAR3/GAR1) + SFGAR(IRES,IG)=REAL(GAR4/GAR1) + FIXE(IRES,IG)=DIL(ISO)*DELTAU(IG) + PHGAR(IRES,IG)=REAL(GAR1/(VOLTOT*GAR0)) + DO 205 IL=1,NL + DO 200 JG=1,IG + IF(NBIN(JG).GT.0) THEN + IF(PHGAR(IRES,JG).NE.0.0) THEN + WSCAT(JG,IG,IL)=WSCAT(JG,IG,IL)/(PHGAR(IRES,JG)*VOLTOT* + 1 DELTAU(JG)) + WSIG(JG,IL)=WSIG(JG,IL)+WSCAT(JG,IG,IL) + ELSE + WSCAT(JG,IG,IL)=0.0D0 + ENDIF + ENDIF + 200 CONTINUE + 205 CONTINUE + SSGAR2=SSGAR(IRES,1,IG) + ABGAR2=STGAR(IRES,IG)-SSGAR(IRES,1,IG) + SFGAR2=SFGAR(IRES,IG) + DO IED=1,NED + IF((HVECT(IED).EQ.'NINEL').OR.(HVECT(IED).EQ.'NELAS').OR. + 1 (HVECT(IED).EQ.'N2N').OR.(HVECT(IED).EQ.'N3N').OR. + 2 (HVECT(IED).EQ.'N4N').OR.(HVECT(IED).EQ.'NX').OR. + 3 (HVECT(IED).EQ.'STRD')) THEN + SAGAR(IRES,IED,IG)=SAGAR(IRES,IED,IG)*SSGAR2/SSGAR1 + ELSE + IF(LABS) SAGAR(IRES,IED,IG)=SAGAR(IRES,IED,IG)*ABGAR2/ABGAR1 + ENDIF + ENDDO + DO IDEL=1,NDEL + SDGAR(IRES,IDEL,IG)=SDGAR(IRES,IDEL,IG)*SFGAR2/SFGAR1 + ENDDO + 210 CONTINUE + DO 240 IL=1,NL + DO 230 IG=IGRMIN,IGRMAX + IF(IL.GT.1) SSGAR(IRES,IL,IG)=REAL(WSIG(IG,IL)) + DO 220 JG=IGRMIN,IGRMAX + S0GAR(IRES,IL,JG,IG)=REAL(WSCAT(IG,JG,IL)) + 220 CONTINUE + 230 CONTINUE + 240 CONTINUE + IF(IMPX.GT.3) THEN + WRITE(6,'(//18H AUTONE: ISOTOPE='',3A4,1H''/9X,10HMICROSCOPI, + 1 28HC XS BEFORE SELF-SHIELDING (,I5,9H <= IG <=,I5,1H))') + 2 ISOBIS(:3,ISO),IGRMIN,IGRMAX + WRITE(6,'(/27H CONDENSED LETHARGY WIDTHS:/(1X,1P,10E12.4))') + 1 (DELTAU(IG),IG=1,NGRP) + WRITE(6,'(/25H CONDENSED FIXED SOURCES:/(1X,1P,10E12.4))') + 1 (FIXE(IRES,IG),IG=1,NGRP) + WRITE(6,'(/24H CONDENSED NEUTRON FLUX:/(1X,1P,10E12.4))') + 1 (PHGAR(IRES,IG),IG=1,NGRP) + WRITE(6,'(/46H CONDENSED P0 MICROSCOPIC DIFFUSION CROSS-SECT, + 1 5HIONS:/(1X,1P,10E12.4))') (SSGAR(IRES,1,IG),IG=1,NGRP) + WRITE(6,'(/46H CONDENSED P0 MICROSCOPIC DIFFUSION CROSS-SECT, + 1 13HIONS (CHECK):/(1X,1P,10E12.4))') (WSIG(IG,1),IG=1,NGRP) + WRITE(6,'(/44H CONDENSED MICROSCOPIC TOTAL CROSS-SECTIONS:/ + 1 (1X,1P,10E12.4))') (STGAR(IRES,IG),IG=1,NGRP) + WRITE(6,'(/46H CONDENSED MICROSCOPIC FISSION CROSS-SECTIONS:/ + 1 (1X,1P,10E12.4))') (SFGAR(IRES,IG),IG=1,NGRP) + ENDIF + DEALLOCATE(WSIG,WSCAT,STIS) + ENDIF + 260 CONTINUE + DEALLOCATE(PRI,GA2,GAS,IPISO1) +*---- +* COMPUTE THE SPH FACTORS. +*---- + SPH(:NIRES,:NGRP)=1.0 + IF(KSPH.GT.0) THEN + CALL LCMGET(IPLI0,'DELTAU',DELTAU) + CALL AUTSPH(IPLI0,IPTRK,IFTRAK,NREG,NUN,NBMIX,NBISO,NIRES,NL, + 1 NED,NDEL,HCAL,MAT,VOL,KEYFLX,CDOOR,LEAKSW,IMPX,DEN,MIX,IAPT, + 2 ITRANC,IPHASE,NGRP,MASKG,IREX,TITR,SIGGAR,UNGAR,PHGAR,STGAR, + 3 SFGAR,SSGAR,S0GAR,SAGAR,SDGAR,DELTAU,SPH) + ENDIF +*---- +* PRINT SELF-SHIELDED MICROSCOPIC CROSS SECTIONS. +*---- + IF(IMPX.GT.1) THEN + DO 300 ISO=1,NBISO + IBM=MIX(ISO) + IF(IBM.LE.0) GO TO 300 + IRES=IAPT(ISO) + IF((IRES.GT.0).AND.(IRES.LE.NIRES)) THEN + WRITE(6,'(//18H AUTONE: ISOTOPE='',3A4,1H''/9X,10HMICROSCOPI, + 1 20HC SELF-SHIELDED XS (,I5,9H <= IG <=,I5,1H))') + 2 ISOBIS(:3,ISO),IGRMIN,IGRMAX + IF(KSPH.GT.0) THEN + WRITE(6,'(/13H SPH FACTORS:/(1X,1P,10E12.4))') + 1 (SPH(IRES,IG),IG=IGRMIN,IGRMAX) + ENDIF + WRITE(6,'(/27H CONDENSED FINE STRUCTURES:/(1X,1P,10E12.4))') + 1 (PHGAR(IRES,IG),IG=IGRMIN,IGRMAX) + WRITE(6,'(/46H CONDENSED P0 MICROSCOPIC DIFFUSION CROSS-SECT, + 1 5HIONS:/(1X,1P,10E12.4))') (SSGAR(IRES,1,IG),IG=IGRMIN,IGRMAX) + WRITE(6,'(/44H CONDENSED MICROSCOPIC TOTAL CROSS-SECTIONS:/ + 1 (1X,1P,10E12.4))') (STGAR(IRES,IG),IG=IGRMIN,IGRMAX) + WRITE(6,'(/46H CONDENSED MICROSCOPIC FISSION CROSS-SECTIONS:/ + 1 (1X,1P,10E12.4))') (SFGAR(IRES,IG),IG=IGRMIN,IGRMAX) + IF(NL.GT.1) THEN + WRITE(6,'(/44H CONDENSED P1 MICROSCOPIC DIFFUSION CROSS-SE, + 1 7HCTIONS:/(1X,1P,10E12.4))') (SSGAR(IRES,2,IG),IG=IGRMIN, + 2 IGRMAX) + ENDIF + IF(IMPX.GT.2) THEN + DO 290 IL=1,NL + WRITE(6,'(/12H CONDENSED P,I2.2,23H MICROSCOPIC TRANSFER C, + 1 14HROSS-SECTIONS:)') IL-1 + DO 280 IG=IGRMIN,IGRMAX + JGRMIN=NGRP+1 + JGRMAX=0 + DO 270 JG=1,NGRP + IF(S0GAR(IRES,IL,JG,IG).NE.0.0) THEN + JGRMIN=MIN(JGRMIN,JG) + JGRMAX=MAX(JGRMAX,JG) + ENDIF + 270 CONTINUE + WRITE(6,420) (IG,JG,S0GAR(IRES,IL,JG,IG),JG=JGRMIN,JGRMAX) + 280 CONTINUE + 290 CONTINUE + ENDIF + ENDIF + 300 CONTINUE + ENDIF + DEALLOCATE(SIGF,SIGS1,SIGS,SIGT,FUNKNO,DELBIN,UUU) + DEALLOCATE(UNGAR,SIGGAR) +*---- +* CREATE THE SELF-SHIELDED INTERNAL LIBRARY USING A SIMPLE +* TRANSCRIPTION OF THE SELF-SHIELDED CROSS SECTIONS. +*---- + CALL KDRCPU(TK1) +* SIMPLE TRANSCRIPTION OF THE SELF-SHIELDED CROSS SECTIONS. + DO 310 ISO=1,NBISO + MASKI(ISO)=(IAPT(ISO).GT.0).AND.(IAPT(ISO).LE.NIRES) + 310 CONTINUE + DO 330 ISO=1,NBISO + IF(MASKI(ISO)) THEN + DO 320 JSO=ISO+1,NBISO + IF((ISOBIS(1,ISO).EQ.ISOBIS(1,JSO)).AND. + 1 (ISOBIS(2,ISO).EQ.ISOBIS(2,JSO)).AND. + 2 (ISOBIS(3,ISO).EQ.ISOBIS(3,JSO))) MASKI(JSO)=.FALSE. + 320 CONTINUE + ENDIF + 330 CONTINUE + CALL USSIN1(IPLI0,IPLIB,NGRP,NBMIX,NBISO,NIRES,NBNRS,NL,NED,NDEL, + 1 IREX,IMPX,ISONAM,ISOBIS,MIX,IAPT,MASKI,SPH,PHGAR,STGAR,SFGAR, + 2 SSGAR,S0GAR,SAGAR,SDGAR) + CALL KDRCPU(TK2) + IF(IMPX.GT.1) WRITE(6,'(/36H AUTONE: CPU TIME SPENT TO BUILD THE, + 1 33H SELF-SHIELDED INTERNAL LIBRARY =,F8.1,8H SECOND.)') TK2-TK1 +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(DELTAU,SDGAR,SAGAR,S0GAR,SSGAR,SFGAR,STGAR,PHGAR,SPH) + DEALLOCATE(MASKG,HVECT,MASKI) + DEALLOCATE(IAPT,IREX,ISOBIS) + RETURN +* + 410 FORMAT(/48H AUTONE: NUMBER OF CORRELATED RESONANT ISOTOPES=,I4/9X, + 1 35HNUMBER OF CORRELATED FUEL MIXTURES=,I4,19H IN RESONANT REGION, + 2 I3) + 420 FORMAT(1P,3X,I4,4H -->,I4,2H :,E12.4,3X,I4,4H -->,I4,2H :,E12.4, + 1 3X,I4,4H -->,I4,2H :,E12.4,3X,I4,4H -->,I4,2H :,E12.4, + 2 3X,I4,4H -->,I4,2H :,E12.4,3X,I4,4H -->,I4,2H :,E12.4) + END diff --git a/Dragon/src/AUTPRD.f b/Dragon/src/AUTPRD.f new file mode 100644 index 0000000..5061a7a --- /dev/null +++ b/Dragon/src/AUTPRD.f @@ -0,0 +1,55 @@ +*DECK AUTPRD + SUBROUTINE AUTPRD(NGRP,LBIN,NFS,SIGT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Cross section or source spreading. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NGRP number of macro energy groups. +* LBIN number of fine energy groups. +* NFS number of fine energy groups in each coarse energy group. +* SIGT cross section or source before spreading. +* +*Parameters: output +* SIGT cross section or source after spreading. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NGRP,LBIN,NFS(NGRP) + REAL SIGT(LBIN) +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: GAR +* + ALLOCATE(GAR(NGRP)) + GAR(:NGRP)=SIGT(:NGRP) + SIGT(:LBIN)=0.0 + IPO=LBIN + DO J=NGRP,1,-1 + ND=ABS(NFS(J)) + SS=GAR(J) + DO L=1,ND + K=IPO-L+1 + SIGT(K)=SS + ENDDO + IPO=IPO-ND + ENDDO + DEALLOCATE(GAR) + IF(IPO.NE.0) CALL XABORT('AUTPRD: SPREAD FAILURE.') + RETURN + END diff --git a/Dragon/src/AUTSPH.f b/Dragon/src/AUTSPH.f new file mode 100644 index 0000000..65bfe26 --- /dev/null +++ b/Dragon/src/AUTSPH.f @@ -0,0 +1,329 @@ +*DECK AUTSPH + SUBROUTINE AUTSPH(IPLI0,IPTRK,IFTRAK,NREG,NUN,NBMIX,NBISO,NIRES, + 1 NL,NED,NDEL,HCAL,MAT,VOL,KEYFLX,CDOOR,LEAKSW,IMPX,DEN,MIX,IAPT, + 2 ITRANC,IPHASE,NGRP,MASKG,IREX,TITR,SIGGAR,UNGAR,PHGAR,STGAR, + 3 SFGAR,SSGAR,S0GAR,SAGAR,SDGAR,DELTAU,SPH) +* +*----------------------------------------------------------------------- +* +*Purpose: +* SPH equivalence procedure over the self-shielded cross sections. Use +* all the standard solution doors of Dragon. Autosecol specific version. +* +*Copyright: +* Copyright (C) 2023 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLI0 pointer to the LCM object containing subgroup-related +* information. +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK file unit number used to store the tracks. +* NREG number of regions. +* NUN number of unknowns per energy group. +* NBMIX number of mixtures in the internal library. +* NBISO number of isotopes. +* NIRES number of correlated resonant isotopes. +* NL number of Legendre orders required in the calculation +* (NL=1 or higher). +* NED number of extra vector edits. +* NDEL number of delayed neutron precursor groups. +* HCAL name of the self-shielding calculation. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX pointers of fluxes in unknown vector. +* CDOOR name of the geometry/solution operator. +* LEAKSW leakage flag (LEAKSW=.TRUE. if neutron leakage through +* external boundary is present). +* IMPX print flag (equal to zero for no print). +* DEN density of each isotope. +* MIX mix number of each isotope (can be zero). +* IAPT resonant isotope index associated with isotope I. Mixed +* moderator if IAPT(I)=NIRES+1. Out-of-fuel isotope if +* IAPT(I)=0. +* ITRANC type of transport correction. +* IPHASE type of flux solution (=1 use a native flux solution door; +* =2 use collision probabilities). +* NGRP number of energy groups. +* MASKG energy group mask pointing on self-shielded groups. +* IREX fuel region index assigned to each mixture. Equal to zero +* in non-resonant mixtures or in mixtures not used. +* TITR title. +* SIGGAR macroscopic x-s of the non-resonant isotopes in each mixture: +* (*,*,*,1) total; (*,*,*,2) transport correction; +* (*,*,*,3) P0 scattering. +* UNGAR averaged fluxes. +* STGAR microscopic self-shielded total x-s. +* +*Parameters: input/output +* PHGAR uncorrected and SPH-corrected averaged fluxes. +* SFGAR uncorrected and SPH-corrected microscopic self-shielded +* fission x-s. +* SSGAR uncorrected and SPH-corrected microscopic +* self-shielded scattering x-s. +* S0GAR uncorrected and SPH-corrected microscopic +* transfer scattering x-s +* (isotope,secondary,primary). +* SAGAR uncorrected and SPH-corrected microscopic +* additional x-s. +* SDGAR uncorrected and SPH-corrected microscopic +* self-shielded delayed nu-sigf x-s. +* DELTAU lethargy width of each energy group. +* +*Parameters: output +* SPH SPH factors. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE DOORS_MOD +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLI0,IPTRK + INTEGER IFTRAK,NREG,NUN,NBMIX,NBISO,NIRES,NL,NED,NDEL,MAT(NREG), + 1 KEYFLX(NREG),IMPX,MIX(NBISO),IAPT(NBISO),ITRANC,IPHASE,NGRP, + 2 IREX(NBMIX) + REAL VOL(NREG),DEN(NBISO),SIGGAR(NBMIX,0:NIRES,NGRP,3), + 1 UNGAR(NUN,NGRP),PHGAR(NIRES,NGRP),STGAR(NIRES,NGRP), + 2 SFGAR(NIRES,NGRP),SSGAR(NIRES,NL,NGRP),S0GAR(NIRES,NL,NGRP,NGRP), + 3 SAGAR(NIRES,NED,NGRP),SDGAR(NIRES,NDEL,NGRP),DELTAU(NGRP), + 4 SPH(NIRES,NGRP) + LOGICAL LEAKSW,MASKG(NGRP) + CHARACTER CDOOR*12,HCAL*12,TITR*72 +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPLI0,KPLI0,IPMACR,IPSOU + LOGICAL LHOMOG,LPROB,LTIT,LEXAC,REBFLG + INTEGER NALBP +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NPSYS + REAL, ALLOCATABLE, DIMENSION(:) :: SIGTXS,SIGS0X,SIGG + REAL, ALLOCATABLE, DIMENSION(:,:) :: SUNKNO,FUNKNO,SIGTI + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LVOL +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NPSYS(NGRP)) + ALLOCATE(SIGTI(NBMIX,5),SIGTXS(0:NBMIX),SIGS0X(0:NBMIX), + 1 SIGG(0:NBMIX),SUNKNO(NUN,NGRP),FUNKNO(NUN,NGRP),LVOL(NREG)) +*---- +* SET LHOMOG. +*---- + NALBP=0 + LHOMOG=.TRUE. + DO 10 I=1,NREG + IBM=MAT(I) + IF(IBM.EQ.0) GO TO 10 + IF(IREX(IBM).EQ.0) LHOMOG=.FALSE. + 10 CONTINUE + IF(LHOMOG) GO TO 260 +*---- +* SET MACRO CALCULATION +*---- + ICPIJ=0 + CALL KDRCPU(TK1) + CALL LCMSIX(IPLI0,'SHIBA_SG',1) + CALL LCMSIX(IPLI0,HCAL,1) + LTIT=.TRUE. + JPLI0=LCMLID(IPLI0,'GROUP',NGRP) +*---- +* LOOP OVER SELF-SHIELDED ENERGY GROUPS. +*---- + FUNKNO(:NUN,:NGRP)=0.0 + SUNKNO(:NUN,:NGRP)=0.0 + NPSYS(:NGRP)=0 + DO 80 IGRP=1,NGRP + IF(.NOT.MASKG(IGRP)) GO TO 80 + NPSYS(IGRP)=IGRP +*---- +* SET THE MIXTURE-DEPENDENT MACROSCOPIC XS. +*---- + SIGTI(:NBMIX,:5)=0.0 + DO 50 IBM=1,NBMIX + DO 40 IRES=0,NIRES + IF(IRES.EQ.0) THEN + SIGTI(IBM,1)=SIGTI(IBM,1)+SIGGAR(IBM,0,IGRP,1) + SIGTI(IBM,3)=SIGTI(IBM,3)+SIGGAR(IBM,0,IGRP,3) + IF(ITRANC.NE.0) SIGTI(IBM,2)=SIGTI(IBM,2)+ + 1 SIGGAR(IBM,0,IGRP,2) + ELSE IF((IRES.GT.0).AND.(IREX(IBM).NE.0)) THEN + DENN=0.0 + DO 20 ISO=1,NBISO + IF((IAPT(ISO).EQ.IRES).AND.(MIX(ISO).EQ.IBM)) DENN=DEN(ISO) + 20 CONTINUE + SIGTI(IBM,5)=SIGTI(IBM,5)+DENN*STGAR(IRES,IGRP) + DO 30 JGRP=1,NGRP + SIGTI(IBM,4)=SIGTI(IBM,4)+PHGAR(IRES,JGRP)*DENN* + 1 S0GAR(IRES,1,IGRP,JGRP)*DELTAU(JGRP)/DELTAU(IGRP) + 30 CONTINUE + ENDIF + 40 CONTINUE + 50 CONTINUE +*---- +* COMPUTE THE SOURCES. +*---- + SIGG(0)=0.0 + DO 55 IBM=1,NBMIX + SIGG(IBM)=SIGTI(IBM,3) + IF(IREX(IBM).GT.0) SIGG(IBM)=SIGG(IBM)+SIGTI(IBM,4) + 55 CONTINUE + CALL DOORS(CDOOR,IPTRK,NBMIX,0,NUN,SIGG,SUNKNO(1,IGRP)) + SIGG(0:NBMIX)=0.0 + DO 60 IBM=1,NBMIX + IF(IREX(IBM).GT.0) THEN + SIGG(IBM)=SIGG(IBM)-SIGTI(IBM,5) + IF(.NOT.LHOMOG) SIGG(IBM)=SIGG(IBM)-SIGTI(IBM,1) + ENDIF + 60 CONTINUE + CALL DOORS(CDOOR,IPTRK,NBMIX,0,NUN,SIGG,SUNKNO(1,IGRP), + 1 UNGAR(1,IGRP)) +* + IF(NPSYS(IGRP).NE.0) THEN + ICPIJ=ICPIJ+1 + SIGTXS(0:)=0.0 + SIGS0X(0:)=0.0 + DO 70 IBM=1,NBMIX + SIGTXS(IBM)=SIGTI(IBM,1)-SIGTI(IBM,2) + IND=IREX(IBM) + IF(IND.EQ.0) THEN +* REMOVE TRANSPORT CORRECTION. + SIGS0X(IBM)=-SIGTI(IBM,2) + ELSE IF(IND.GT.0) THEN +* BELL ACCELERATION. + SIGTXS(IBM)=SIGTXS(IBM)+SIGTI(IBM,5) + SIGS0X(IBM)=SIGTXS(IBM) + IF(LHOMOG) SIGS0X(IBM)=SIGS0X(IBM)-SIGTI(IBM,1) + ENDIF + 70 CONTINUE + KPLI0=LCMDIL(JPLI0,IGRP) + CALL LCMPUT(KPLI0,'DRAGON-TXSC',NBMIX+1,2,SIGTXS) + CALL LCMPUT(KPLI0,'DRAGON-S0XSC',NBMIX+1,2,SIGS0X) + ENDIF + 80 CONTINUE +*---- +* SOLVE FOR THE FLUX USING DIRECT SELF-SHIELDED CROSS SECTIONS +*---- + ISTRM=1 + NANI=1 + KNORM=1 + IMPY=MAX(0,IMPX-3) + IF(IPHASE.EQ.1) THEN +* USE A NATIVE DOOR. + NW=0 + CALL DOORAV(CDOOR,JPLI0,NPSYS,IPTRK,IFTRAK,IMPY,NGRP,NREG, + 1 NBMIX,NANI,NW,MAT,VOL,KNORM,LEAKSW,TITR,NALBP,ISTRM) + ELSE IF(IPHASE.EQ.2) THEN +* USE A COLLISION PROBABILITY DOOR. + IPIJK=1 + ITPIJ=1 + CALL DOORPV(CDOOR,JPLI0,NPSYS,IPTRK,IFTRAK,IMPY,NGRP,NREG, + 1 NBMIX,NANI,MAT,VOL,KNORM,IPIJK,LEAKSW,ITPIJ,.FALSE.,TITR, + 2 NALBP) + ENDIF + IDIR=0 + LEXAC=.FALSE. + IPMACR=C_NULL_PTR + IPSOU=C_NULL_PTR + REBFLG=.FALSE. + CALL DOORFV(CDOOR,JPLI0,NPSYS,IPTRK,IFTRAK,IMPX,NGRP,NBMIX,IDIR, + 1 NREG,NUN,IPHASE,LEXAC,MAT,VOL,KEYFLX,TITR,SUNKNO,FUNKNO,IPMACR, + 2 IPSOU,REBFLG) +*---- +* LOOP OVER THE RESONANT ISOTOPES. +*---- + LVOL(:NREG)=.FALSE. + SPH(:NGRP,:NIRES)=1.0 + DO 240 IRES=1,NIRES +*---- +* HOMOGENIZE THE FLUX +*---- + VOLMER=0.0 + DO 100 I=1,NREG + IBM=MAT(I) + IF(IBM.EQ.0) GO TO 100 + DO 90 ISO=1,NBISO + IF((IAPT(ISO).EQ.IRES).AND.(MIX(ISO).EQ.IBM)) LVOL(I)=.TRUE. + 90 CONTINUE + IF(LVOL(I)) VOLMER=VOLMER+VOL(I) + 100 CONTINUE + DO 230 IGRP=1,NGRP + IF(NPSYS(IGRP).NE.0) THEN + FLNEW=0.0 + DO 110 I=1,NREG + IF(LVOL(I)) FLNEW=FLNEW+FUNKNO(KEYFLX(I),IGRP)*VOL(I) + 110 CONTINUE + FLNEW=FLNEW/VOLMER +*---- +* SPH FACTOR CONTROL. +*---- + SPHNEW=PHGAR(IRES,IGRP)/FLNEW + LPROB=(SPHNEW.LE.0.0).OR.(SPHNEW.GT.1.0).OR.(FLNEW.LT.0.05) + IF(LPROB) SPHNEW=1.0 + SPH(IRES,IGRP)=SPHNEW + ENDIF + IF(MASKG(IGRP)) THEN + SPHNEW=SPH(IRES,IGRP) + PHGAR(IRES,IGRP)=PHGAR(IRES,IGRP)/SPHNEW + SFGAR(IRES,IGRP)=SFGAR(IRES,IGRP)*SPHNEW + DO 170 IL=1,NL + IF(MOD(IL-1,2).EQ.0) THEN + SSGAR(IRES,IL,IGRP)=SSGAR(IRES,IL,IGRP)*SPHNEW+ + 1 STGAR(IRES,IGRP)*(1.0-SPHNEW) + ELSE + SSGAR(IRES,IL,IGRP)=0.0 + ENDIF + DO 160 JGRP=1,NGRP + IF(MOD(IL-1,2).EQ.0) THEN + IF(IGRP.EQ.JGRP) THEN + S0GAR(IRES,IL,IGRP,IGRP)=S0GAR(IRES,IL,IGRP,IGRP)* + 1 SPHNEW+STGAR(IRES,IGRP)*(1.0-SPHNEW) + ELSE + S0GAR(IRES,IL,JGRP,IGRP)=S0GAR(IRES,IL,JGRP,IGRP)*SPHNEW + ENDIF + ELSE + IF(IGRP.EQ.JGRP) THEN + S0GAR(IRES,IL,IGRP,IGRP)=S0GAR(IRES,IL,IGRP,IGRP)/ + 1 SPHNEW+STGAR(IRES,IGRP)*(1.0-1.0/SPHNEW) + ELSE + S0GAR(IRES,IL,JGRP,IGRP)=S0GAR(IRES,IL,JGRP,IGRP)/ + 1 SPH(IRES,JGRP) + ENDIF + ENDIF + IF(MOD(IL-1,2).EQ.1) THEN + SSGAR(IRES,IL,IGRP)=SSGAR(IRES,IL,IGRP)+ + 1 S0GAR(IRES,IL,JGRP,IGRP) + ENDIF + 160 CONTINUE + 170 CONTINUE + DO 180 IED=1,NED + SAGAR(IRES,IED,IGRP)=SAGAR(IRES,IED,IGRP)*SPHNEW + 180 CONTINUE + DO 190 IDEL=1,NDEL + SDGAR(IRES,IDEL,IGRP)=SDGAR(IRES,IDEL,IGRP)*SPHNEW + 190 CONTINUE + ENDIF + 230 CONTINUE + 240 CONTINUE +* *************************************************************** + CALL LCMSIX(IPLI0,' ',2) + CALL LCMSIX(IPLI0,' ',2) + CALL KDRCPU(TK2) + IF(IMPX.GT.1) WRITE(6,'(/34H AUTSPH: CPU TIME SPENT TO COMPUTE, + 1 18H THE SPH FACTORS =,F8.1,8H SECOND./9X,17HNUMBER OF ASSEMBL, + 2 15HY DOORS CALLS =,I5,1H.)') TK2-TK1,ICPIJ +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 260 DEALLOCATE(LVOL,FUNKNO,SUNKNO,SIGG,SIGS0X,SIGTXS,SIGTI) + DEALLOCATE(NPSYS) + RETURN + END diff --git a/Dragon/src/AUTTAB.f b/Dragon/src/AUTTAB.f new file mode 100644 index 0000000..5418c1a --- /dev/null +++ b/Dragon/src/AUTTAB.f @@ -0,0 +1,160 @@ +*DECK AUTTAB + SUBROUTINE AUTTAB(KPLIB,HNAMIS,IGRMIN,IGRRES,NGRP,LBIN,NBIN,UUU, + 1 ISEED,SIGINF,LLL,SIGT,SIGS,SIGF) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover resonant Autolib data in the unresolved energy domain. +* +*Copyright: +* Copyright (C) 2023 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* KPLIB isotope subdirectory in the internal microscopic cross-section +* library with subgroups. +* HNAMIS character*12 name of the resonant isotope. +* IGRMIN first group where the self-shielding is applied. +* IGRRES first resolved group where the self-shielding is applied. +* NGRP number of energy groups. +* LBIN total number of fine energy groups in the Autolib. +* NBIN number of fine energy groups in each coarse energy group. +* UUU lethargy limits of the groups. +* ISEED the seed for the generation of random numbers in the +* unresolved energy domain. +* SIGINF infinite dilution x-s values. +* +*Parameters: output +* LLL number of fine energy groups in the unresolved domain. +* SIGT total microscopic x-s. +* SIGS P0 scattering microscopic x-s. +* SIGF nu*fission microscopic x-s. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) KPLIB + CHARACTER HNAMIS*12 + INTEGER IGRMIN,IGRRES,NGRP,LBIN,NBIN(NGRP),ISEED,LLL + REAL UUU(LBIN+1),SIGINF(NGRP,3),SIGT(LBIN),SIGS(LBIN),SIGF(LBIN) + DOUBLE PRECISION DIT +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) LPLIB,MPLIB + PARAMETER(MAXNOR=12) + CHARACTER HSMG*131 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NOR + REAL, ALLOCATABLE, DIMENSION(:) :: SIGP +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NOR(NGRP)) +*---- +* SET THE RANDOM NUMBER GENERATOR +*---- + IFIRST=1 + IF(ISEED.EQ.0) THEN + CALL CLETIM(DIT) + ISEED=INT(DIT) + DO 10 JJ=0,MOD(ISEED,10) + CALL RANDF(ISEED,IFIRST,RAND) + 10 CONTINUE + ENDIF +* + CALL LCMLEN(KPLIB,'PT-TABLE',LENG,ITYLCM) + IF(LENG.EQ.0) THEN + WRITE(HSMG,'(38HAUTTAB: NO PT-TABLE DATA FOR ISOTOPE '',A12, + 1 23H'' FOR UNRESOLVED GROUPS,2I5,1H.)') HNAMIS,IGRMIN,IGRRES-1 + CALL XABORT(HSMG) + ENDIF + CALL LCMSIX(KPLIB,'PT-TABLE',1) + CALL LCMGET(KPLIB,'NOR',NOR) + LLL=0 + DO 20 IGRP=1,IGRMIN-1 + LLL=LLL+NBIN(IGRP) + 20 CONTINUE + LPLIB=LCMGID(KPLIB,'GROUP-PT') + DO 80 IGRP=IGRMIN,IGRRES-1 + IF(NOR(IGRP).LE.0) THEN + WRITE(HSMG,'(42HAUTTAB: NO PROBABILITY TABLE DATA IN GROUP,I5, + 1 13H OF ISOTOPE '',A12,2H''.)') IGRP,HNAMIS + CALL XABORT(HSMG) + ELSE IF(NBIN(IGRP).LE.0) THEN + WRITE(HSMG,'(32HAUTTAB: NO AUTOLIB MESH IN GROUP,I5,1H.)') IGRP + CALL XABORT(HSMG) + ENDIF + IF(NOR(IGRP).EQ.1) THEN + DO 30 IBIN=LLL+1,LLL+NBIN(IGRP) + SIGT(IBIN)=SIGINF(IGRP,1) + SIGF(IBIN)=SIGINF(IGRP,2) + SIGS(IBIN)=SIGINF(IGRP,3) + 30 CONTINUE + ELSE + MPLIB=LCMGIL(LPLIB,IGRP) + CALL LCMLEN(MPLIB,'PROB-TABLE',LENG,ITYLCM) + NPART=LENG/MAXNOR + IF(NPART.LT.2) THEN + CALL LCMLIB(MPLIB) + CALL XABORT('AUTTAB: SCATTERING INFO MISSING.') + ENDIF + DELG=UUU(LLL+NBIN(IGRP)+1)-UUU(LLL+1) + ALLOCATE(SIGP(MAXNOR*NPART)) + CALL LCMGET(MPLIB,'PROB-TABLE',SIGP) + ADSIGT=0.0 + ADSIGF=0.0 + ADSIGS=0.0 + DO 60 IBIN=LLL+1,LLL+NBIN(IGRP) + CALL RANDF(ISEED,IFIRST,RAND) + WW=0.0 + DO 40 INOR=1,NOR(IGRP) + WW=WW+SIGP(INOR) + IF(RAND.LE.WW+1.0E-6) THEN + SIGT(IBIN)=SIGP(MAXNOR+INOR) + SIGF(IBIN)=SIGP(2*MAXNOR+INOR) + SIGS(IBIN)=SIGP(3*MAXNOR+INOR) + GO TO 50 + ENDIF + 40 CONTINUE + WRITE(HSMG,'(43HAUTTAB: WEIGHT NORMALIZATION ISSUE IN GROUP,I5, + 1 1H.)') IGRP + CALL XABORT(HSMG) + 50 ADSIGT=ADSIGT+SIGT(IBIN)*(UUU(IBIN+1)-UUU(IBIN))/DELG + ADSIGF=ADSIGF+SIGF(IBIN)*(UUU(IBIN+1)-UUU(IBIN))/DELG + ADSIGS=ADSIGS+SIGS(IBIN)*(UUU(IBIN+1)-UUU(IBIN))/DELG + 60 CONTINUE + FACTT=SIGINF(IGRP,1)/ADSIGT + IF(ADSIGF.NE.0.0) THEN + FACTF=SIGINF(IGRP,2)/ADSIGF + ELSE + FACTF=0.0 + ENDIF + FACTS=SIGINF(IGRP,3)/ADSIGS + DO 70 IBIN=LLL+1,LLL+NBIN(IGRP) + SIGT(IBIN)=SIGT(IBIN)*FACTT + SIGF(IBIN)=SIGF(IBIN)*FACTF + SIGS(IBIN)=SIGS(IBIN)*FACTS + 70 CONTINUE + DEALLOCATE(SIGP) + ENDIF + LLL=LLL+NBIN(IGRP) + 80 CONTINUE + CALL LCMSIX(KPLIB,' ',2) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(NOR) + RETURN + END diff --git a/Dragon/src/AXGDIA.f b/Dragon/src/AXGDIA.f new file mode 100644 index 0000000..2385f35 --- /dev/null +++ b/Dragon/src/AXGDIA.f @@ -0,0 +1,205 @@ +*DECK AXGDIA + SUBROUTINE AXGDIA( IPGEOM, IPRT, NBLOCK, NTYPO, NXYZ, KMESH, + > GEONAM, LL1, LL2, MINGRI, CELLT, KEYTYP, + > ITGEOM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Unfold assembly or cell according to diagonal $x-y$ symmetry +* and verify if the symmetry is valid. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy and G. Marleau +* +*Parameters: input +* IPGEOM pointer to the reference geometry data structure. +* IPRT intermediate printing level for output. +* NBLOCK number of block in geometry. +* NTYPO number of types in geometry. +* NXYZ maximum mesh size in directions $x$, $y$ and $z$. +* KMESH number of mesh intervals in the geometry. +* GEONAM name of the reference geometry. +* LL1 flag that is .TRUE. when the diagonal symmetry +* is applied to surfaces X+ and Y- +* (upper diagonal symmetry). +* LL2 flag that is .TRUE. when the diagonal symmetry +* is applied to surfaces X- and Y+ +* (lower diagonal symmetry). +* MINGRI minimum grid cell in $x$, $y$ and $z$ directions. +* CELLT cell type name. +* +*Parameters: input/output +* KEYTYP type key for each block. +* ITGEOM turn key associated with each cell type. +* +*External functions +* LELCSY to verify if a geometry possesses the required internal +* symmetry. +* AXGTRS to modify current turn according to required internal +* symmetry. +* AXGTRN to associate a DRAGON turn name to a specific turn key. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPGEOM + INTEGER IPRT,NBLOCK,NTYPO,NXYZ,KMESH + CHARACTER GEONAM*12 + LOGICAL LL1,LL2 + INTEGER MINGRI(3),CELLT(3*NTYPO) + INTEGER KEYTYP(NBLOCK),ITGEOM(NBLOCK) +*---- +* EXTERNAL FUNCTIONS +*---- + LOGICAL LELCSY + INTEGER AXGTRS + CHARACTER AXGTRN*2 +*---- +* LOCAL VARIABLES +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='AXGDIA') +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ISPLT,ISPLT1 + REAL, ALLOCATABLE, DIMENSION(:) :: MESH,MESH1 +*---- +* LOCAL PARAMETERS +*---- + INTEGER KML,IX,IY,IZ,IOFF,IOF1,IOF2 + INTEGER IKG,IKT(2) + LOGICAL VALSYM + CHARACTER GEOCV*12 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(ISPLT(NXYZ),ISPLT1(3*3*NXYZ)) + ALLOCATE(MESH(NXYZ+1),MESH1(2*3*3*(NXYZ+1))) +*---- +* ANALYSE LL1 SYMMETRY (UPPER DIAGONAL SYMMETRY) +*---- + KML=KMESH + IF( LL1 )THEN + DO 100 IZ=MINGRI(3),1,-1 + IOFF=(IZ-1)*MINGRI(1)*MINGRI(2) + DO 110 IY=MINGRI(2),1,-1 + DO 120 IX=MINGRI(1),IY+1,-1 + KEYTYP(IOFF+(IY-1)*MINGRI(1)+IX)= + > KEYTYP(IOFF+(IX-1)*MINGRI(2)+IY) + ITGEOM(IOFF+(IY-1)*MINGRI(1)+IX)= + > AXGTRS(ITGEOM(IOFF+(IX-1)*MINGRI(2)+IY),3) + 120 CONTINUE + DO 130 IX=IY,1,-1 + KEYTYP(IOFF+(IY-1)*MINGRI(1)+IX)=KEYTYP(KML) + ITGEOM(IOFF+(IY-1)*MINGRI(1)+IX)=ITGEOM(KML) + IOF1=KML + IOF2=IOFF+(IY-1)*MINGRI(1)+IX + IF(IX .EQ. IY) THEN + IKG=KEYTYP(IOF1) + IKT(1)=ITGEOM(IOF1) + IKT(2)=AXGTRS(IKT(1),3) + WRITE(GEOCV,'(3A4)') + > CELLT(3*IKG-2),CELLT(3*IKG-1),CELLT(3*IKG) + IF(GEOCV .EQ. ' ') THEN + IF(IPRT .GT. 10) + > WRITE(IOUT,8000) NAMSBR,'X-Y', + > GEONAM,AXGTRN(IKT(1)),AXGTRN(IKT(2)) + ELSE + IF(IPRT .GT. 10) + > WRITE(IOUT,8000) NAMSBR,'X-Y', + > GEOCV,AXGTRN(IKT(1)),AXGTRN(IKT(2)) + ENDIF + VALSYM=LELCSY(IPGEOM,IPRT,GEONAM,GEOCV,NXYZ,IKT, + > MESH,ISPLT,MESH1,ISPLT1) + IF(.NOT. VALSYM) THEN + WRITE(IOUT,8001) 'X-Y',GEOCV, + > AXGTRN(IKT(1)),AXGTRN(IKT(2)) + CALL XABORT(NAMSBR//': INVALID SYMMETRY FOR CELL') + ENDIF + ENDIF + KML=KML-1 + 130 CONTINUE + 110 CONTINUE + 100 CONTINUE + ELSE IF( LL2 )THEN +*---- +* ANALYSE LL2 SYMMETRY (LOWER DIAGONAL SYMMETRY) +*---- + DO 200 IZ=MINGRI(3),1,-1 + IOFF=(IZ-1)*MINGRI(1)*MINGRI(2) + DO 210 IY=MINGRI(2),1,-1 + DO 220 IX=MINGRI(1),IY,-1 + KEYTYP(IOFF+(IY-1)*MINGRI(1)+IX)=KEYTYP(KML) + ITGEOM(IOFF+(IY-1)*MINGRI(1)+IX)=ITGEOM(KML) + IOF1=KML + IOF2=IOFF+(IY-1)*MINGRI(1)+IX + IF(IX .EQ. IY) THEN + IKG=KEYTYP(IOF1) + IKT(1)=ITGEOM(IOF1) + IKT(2)=AXGTRS(IKT(1),3) + WRITE(GEOCV,'(3A4)') + > CELLT(3*IKG-2),CELLT(3*IKG-1),CELLT(3*IKG) + IF(GEOCV .EQ. ' ') THEN + IF(IPRT .GT. 10) + > WRITE(IOUT,8000) NAMSBR,'X-Y', + > GEONAM,AXGTRN(IKT(1)),AXGTRN(IKT(2)) + ELSE + IF(IPRT .GT. 10) + > WRITE(IOUT,8000) NAMSBR,'X-Y', + > GEOCV,AXGTRN(IKT(1)),AXGTRN(IKT(2)) + ENDIF + VALSYM=LELCSY(IPGEOM,IPRT,GEONAM,GEOCV,NXYZ,IKT, + > MESH,ISPLT,MESH1,ISPLT1) + IF(.NOT. VALSYM) THEN + WRITE(IOUT,8001) 'X-Y',GEOCV, + > AXGTRN(IKT(1)),AXGTRN(IKT(2)) + CALL XABORT(NAMSBR//': INVALID SYMMETRY FOR CELL') + ENDIF + ENDIF + KML=KML-1 + 220 CONTINUE + 210 CONTINUE + 200 CONTINUE + DO 230 IZ=1,MINGRI(3) + IOFF=(IZ-1)*MINGRI(1)*MINGRI(2) + DO 240 IY=1,MINGRI(2) + DO 250 IX=1,IY-1 + KEYTYP(IOFF+(IY-1)*MINGRI(1)+IX)= + > KEYTYP(IOFF+(IX-1)*MINGRI(2)+IY) + ITGEOM(IOFF+(IY-1)*MINGRI(1)+IX)= + > AXGTRS(ITGEOM(IOFF+(IX-1)*MINGRI(2)+IY),3) + 250 CONTINUE + 240 CONTINUE + 230 CONTINUE + ENDIF + IF(KML .NE. 0) CALL XABORT(NAMSBR//': DATA ERROR') +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(MESH1,MESH) + DEALLOCATE(ISPLT1,ISPLT) +*---- +* RETURN +*---- + RETURN +*---- +* FORMAT +*---- + 8000 FORMAT(1X,A6,' NOW TESTING SYMMETRY ',A3,' FOR ', + > A12,1X,'WITH ROTATION',1X,A2,' AND ',A2) + 8001 FORMAT(' INVALID SYMMETRY ',A3,' FOR ', + > A12,1X,'WITH ROTATION',1X,A2,' AND ',A2) + END diff --git a/Dragon/src/AXGGEO.f b/Dragon/src/AXGGEO.f new file mode 100644 index 0000000..77aaefd --- /dev/null +++ b/Dragon/src/AXGGEO.f @@ -0,0 +1,148 @@ +*DECK AXGGEO + SUBROUTINE AXGGEO(IPGEOM,IPTRKM,IPRINT,GEONAM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Generate temporary tracking file to be used by PSPTRK. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy and G. Marleau +* +*Parameters: input +* IPGEOM geometry data structures pointer +* IPTRKM tracking data structures pointer +* IPRINT print level +* GEONAM geometry name +* +*---- +* + USE GANLIB + IMPLICIT NONE + INTEGER IOUT,NSTATE + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NSTATE=40, + > NAMSBR='AXGGEO') +*---- +* ROUTINE PARAMETERS +*---- + TYPE(C_PTR) IPGEOM,IPTRKM + INTEGER IPRINT + CHARACTER GEONAM*12 +*---- +* LOCAL PARAMETERS +*---- + INTEGER ISTATE(NSTATE) + INTEGER ITYPEG,ITGEO + CHARACTER HSIGN*12 + INTEGER NV,NS,NSOUT,NREG,NUNK,ICODE(6) + REAL EXTKOP(NSTATE) + INTEGER ITROP,MAXMIX,IREG,ISYMM + INTEGER IUEXP,KDROPN,KDRCLS,IRC +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KEYMRG,MATALB,MATMRG + REAL, ALLOCATABLE, DIMENSION(:) :: VOLSUR,VOLMRG +*---- +* STORE SIGNATURE AND TRACK TYPE ON IPTRKM +*---- + HSIGN='L_TRACK ' + CALL LCMPTC(IPTRKM,'SIGNATURE',12,HSIGN) + HSIGN='EXCELL ' + CALL LCMPTC(IPTRKM,'TRACK-TYPE',12,HSIGN) +*---- +* ANALYZE GEOMETRY +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) + ITYPEG= ISTATE(1) + ITROP = 0 + IF(ITYPEG .EQ. 3 .OR. ITYPEG .EQ. 6 ) THEN + ITGEO= 1 + ELSE IF(ITYPEG .EQ. 8 .OR. ITYPEG .EQ. 9 .OR. + > ITYPEG .EQ. 24 .OR. ITYPEG .EQ. 25 ) THEN + ITGEO= 2 + ELSE IF(ITYPEG .EQ. 5 .OR. ITYPEG .EQ. 7 .OR. + > ITYPEG .EQ. 20 .OR. ITYPEG .EQ. 21 .OR. + > ITYPEG .EQ. 22 .OR. ITYPEG .EQ. 23 ) THEN + ITGEO= 3 + ELSE + ITGEO= 0 + ENDIF + IF(ISTATE(13) .GE. 1) THEN +*---- +* CLUSTER GEOMETRY +*---- + ISYMM=1 + CALL AXGXCW(IPGEOM ,IPTRKM,IPRINT,GEONAM,ISYMM ) + ITROP=3 + ELSE IF(ITGEO .EQ. 2 ) THEN +*---- +* HEXAGONAL 2D GEOMETRIES +*---- +* CALL AXGXHX(IPGEOM ,IPTRKM,IPRINT,GEONAM) + ITROP=2 + ELSE IF(ITGEO .EQ. 3 ) THEN +*---- +* CARTESIAN 2D/3D ASSEMBLIES +* CALL XELPRP TO GET GEOMETRY DIMENSIONING INFORMATION +*---- + CALL AXGXEL(IPGEOM ,IPTRKM,IPRINT,GEONAM) + ITROP=1 + ELSE + CALL XABORT(NAMSBR//': INVALID TYPE OF GEOMETRY') + ENDIF + CALL LCMGET(IPTRKM,'ICODE ',ICODE) + CALL LCMSIX(IPTRKM,'EXCELL ',1) + ISTATE(:NSTATE)=0 + CALL LCMGET(IPTRKM,'STATE-VECTOR',ISTATE) + NV=ISTATE(3) + NS=ISTATE(2) + NUNK=NV+NS+1 + ALLOCATE(KEYMRG(NUNK),MATALB(NUNK),VOLSUR(NUNK)) + CALL LCMGET(IPTRKM,'KEYMRG ',KEYMRG) + CALL LCMGET(IPTRKM,'MATALB ',MATALB) + CALL LCMGET(IPTRKM,'VOLSUR ',VOLSUR) + CALL LCMSIX(IPTRKM,'EXCELL ',2) + ALLOCATE(MATMRG(NUNK),VOLMRG(NUNK)) + CALL XELCMP(NS ,NV , + > VOLSUR,MATALB,KEYMRG, + > NSOUT ,NREG ,VOLMRG,MATMRG, + > ITGEO ,ICODE ) + MAXMIX=0 + DO 100 IREG=1,NREG + KEYMRG(IREG+NSOUT+1)= IREG + MAXMIX=MAX(MAXMIX,MATMRG(IREG+NSOUT+1)) + 100 CONTINUE + CALL LCMPUT(IPTRKM,'MATCOD',NREG,1,MATMRG(NSOUT+2)) + CALL LCMPUT(IPTRKM,'VOLUME',NREG,2,VOLMRG(NSOUT+2)) + CALL LCMPUT(IPTRKM,'KEYFLX',NREG,1,KEYMRG(NSOUT+2)) + EXTKOP(:NSTATE)=0.0 + CALL LCMPUT(IPTRKM,'EXCELTRACKOP',NSTATE,2,EXTKOP) + ISTATE(:NSTATE)=0 + ISTATE(1)=NREG + ISTATE(2)=NREG + ISTATE(4)=MAXMIX + ISTATE(5)=NSOUT + ISTATE(7)=ITROP + ISTATE(8)=-1 + CALL LCMPUT(IPTRKM,'STATE-VECTOR',NSTATE,1,ISTATE) + DEALLOCATE(VOLMRG,MATMRG,VOLSUR,MATALB,KEYMRG) +*---- +* IF IPRINT >= 20 +* EXPORT TEMPORARY TRACKING FILE +*---- + IF(IPRINT .GE. 10) THEN + IUEXP=KDROPN('AXGGEOEXPTRK',0,3,0,0) + CALL LCMEXP(IPTRKM,IPRINT,IUEXP,2,1) + IRC=KDRCLS(IUEXP,1) + ENDIF + RETURN + END diff --git a/Dragon/src/AXGSYM.f b/Dragon/src/AXGSYM.f new file mode 100644 index 0000000..3c82225 --- /dev/null +++ b/Dragon/src/AXGSYM.f @@ -0,0 +1,298 @@ +*DECK AXGSYM + SUBROUTINE AXGSYM( IPGEOM, IPRT, NBLOCK, NTYPO, NXYZ, + > GEONAM, LCLSYM, MINGRI, MAXGRI, CELLT, + > KEYTYP, ITGEOM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Unfold assembly or cell according to center cell symmetry in +* $x$, $y$ or $z$ and verify if the symmetry is valid. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPGEOM pointer to the reference geometry data structure. +* IPRT intermediate printing level for output. +* NBLOCK number of block in geometry. +* NTYPO number of types in geometry. +* NXYZ maximum mesh size in directions $x$, $y$ and $z$. +* GEONAM name of the reference geometry. +* LCLSYM flag that is set to 1 when the $x$ (LCLSYM(1)), +* $y$ (LCLSYM(2)) and/or $z$ (LCLSYM(3)) +* symmetries are required. +* MINGRI minimum grid cell in $x$, $y$ and $z$ directions. +* MAXGRI maximum grid cell in $x$, $y$ and $z$ directions. +* CELLT cell type name. +* +*Parameters: input/output +* KEYTYP type key for each block. +* ITGEOM turn key associated with each cell type. +* +*External functions +* LELCSY to verify if a geometry possesses the required internal +* symmetry. +* AXGTRS to modify current turn according to required internal +* symmetry. +* AXGTRN to associate a DRAGON turn name to a specific turn key. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPGEOM + INTEGER IPRT,NBLOCK,NTYPO,NXYZ + CHARACTER GEONAM*12 + INTEGER LCLSYM(3) + INTEGER MINGRI(3),MAXGRI(3),CELLT(3*NTYPO) + INTEGER KEYTYP(NBLOCK),ITGEOM(NBLOCK) +*---- +* EXTERNAL FUNCTIONS +*---- + LOGICAL LELCSY + INTEGER AXGTRS + CHARACTER AXGTRN*2 +*---- +* LOCAL VARIABLES +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='AXGSYM') +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ISPLT,ISPLT1 + REAL, ALLOCATABLE, DIMENSION(:) :: MESH,MESH1 +*---- +* LOCAL PARAMETERS +*---- + INTEGER IX,IY,IZ,IOF1,IOF2 + INTEGER IKOF1,IKOF2,ITOF1,ITOF2 + INTEGER IKG,IKT(2) + LOGICAL VALSYM + CHARACTER GEOCV*12 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(ISPLT(NXYZ),ISPLT1(3*3*NXYZ)) + ALLOCATE(MESH(NXYZ+1),MESH1(2*3*3*(NXYZ+1))) +*---- +* APPLY SYMMETRY IN Z +*---- + IF( LCLSYM(3) .NE. 0) THEN + IF(IPRT .GT. 10) THEN + WRITE(IOUT,8000) NAMSBR,'Z-Z' + ENDIF + DO 200 IZ=1,MINGRI(3) + DO 210 IY=1,MAXGRI(2) + DO 220 IX=1,MAXGRI(1) + IOF1=((IZ-1)*MAXGRI(2)+(IY-1))*MAXGRI(1)+IX + IOF2=((MAXGRI(3)-IZ)*MAXGRI(2)+(IY-1))*MAXGRI(1)+IX + IKOF1=KEYTYP(IOF1) + IKOF2=KEYTYP(IOF2) + ITOF1=ITGEOM(IOF1) + ITOF2=ITGEOM(IOF2) + IF(IPRT .GT. 10) THEN + WRITE(IOUT,8010) IZ,IY,IX, + > IOF1,IOF2,IKOF1,IKOF2,ITOF1,ITOF2 + ENDIF + IF( IKOF1 .NE. IKOF2) THEN + IF( IKOF1 .GT. IKOF2) THEN + IKOF2= IKOF1 + ITOF2= AXGTRS(ITOF1,4) + KEYTYP(IOF2)= IKOF2 + ITGEOM(IOF2)= ITOF2 + ELSE + IKOF1= IKOF2 + ITOF1= AXGTRS(ITOF2,4) + KEYTYP(IOF1)= IKOF1 + ITGEOM(IOF1)= ITOF1 + ENDIF + ENDIF + IF(IKOF1 .GT. 0) THEN + IF(IZ .EQ. (MAXGRI(3)+1-IZ)) THEN + IKG=IKOF1 + IKT(1)=ITOF1 + IKT(2)=AXGTRS(IKT(1),4) + IF(IKG .GT. 0) THEN + WRITE(GEOCV,'(3A4)') + > CELLT(3*IKG-2),CELLT(3*IKG-1),CELLT(3*IKG) + IF(GEOCV .EQ. ' ') THEN + IF(IPRT .GT. 10) WRITE(IOUT,8001) + > GEONAM,AXGTRN(IKT(1)),AXGTRN(IKT(2)) + ELSE + IF(IPRT .GT. 10) WRITE(IOUT,8001) + > GEOCV,AXGTRN(IKT(1)),AXGTRN(IKT(2)) + ENDIF + VALSYM=LELCSY(IPGEOM,IPRT,GEONAM,GEOCV,NXYZ,IKT, + > MESH,ISPLT,MESH1,ISPLT1) + IF(.NOT. VALSYM) THEN + WRITE(IOUT,8002) 'Z-Z',GEOCV, + > AXGTRN(IKT(1)),AXGTRN(IKT(2)) + CALL XABORT(NAMSBR// + > ': INVALID Z SYMMETRY FOR CELL') + ENDIF + ENDIF + ENDIF + ENDIF + 220 CONTINUE + 210 CONTINUE + 200 CONTINUE + ENDIF +*---- +* APPLY SYMMETRY IN Y +*---- + IF( LCLSYM(2).NE.0)THEN + IF(IPRT .GT. 10) THEN + WRITE(IOUT,8000) NAMSBR,'Y-Y' + ENDIF + DO 300 IZ=1,MAXGRI(3) + DO 310 IY=1,MINGRI(2) + DO 320 IX=1,MAXGRI(1) + IOF1=((IZ-1)*MAXGRI(2)+(IY-1))*MAXGRI(1)+IX + IOF2=((IZ-1)*MAXGRI(2)+(MAXGRI(2)-IY))*MAXGRI(1)+IX + IKOF1=KEYTYP(IOF1) + IKOF2=KEYTYP(IOF2) + ITOF1=ITGEOM(IOF1) + ITOF2=ITGEOM(IOF2) + IF(IPRT .GT. 10) THEN + WRITE(IOUT,8010) IZ,IY,IX, + > IOF1,IOF2,IKOF1,IKOF2,ITOF1,ITOF2 + ENDIF + IF( IKOF1 .NE. IKOF2) THEN + IF( IKOF1 .GT. IKOF2) THEN + IKOF2= IKOF1 + ITOF2= AXGTRS(ITOF1,2) + KEYTYP(IOF2)= IKOF2 + ITGEOM(IOF2)= ITOF2 + ELSE + IKOF1= IKOF2 + ITOF1= AXGTRS(ITOF2,2) + KEYTYP(IOF1)= IKOF1 + ITGEOM(IOF1)= ITOF1 + ENDIF + ENDIF + IF(IKOF1 .GT. 0) THEN + IF(IY .EQ. (MAXGRI(2)+1-IY) ) THEN + IKG=IKOF1 + IKT(1)=ITOF1 + IKT(2)=AXGTRS(IKT(1),2) + IF(IKG .GT. 0) THEN + WRITE(GEOCV,'(3A4)') + > CELLT(3*IKG-2),CELLT(3*IKG-1),CELLT(3*IKG) + IF(GEOCV .EQ. ' ') THEN + IF(IPRT .GT. 10) WRITE(IOUT,8001) + > GEONAM,AXGTRN(IKT(1)),AXGTRN(IKT(2)) + ELSE + IF(IPRT .GT. 10) WRITE(IOUT,8001) + > GEOCV,AXGTRN(IKT(1)),AXGTRN(IKT(2)) + ENDIF + VALSYM=LELCSY(IPGEOM,IPRT,GEONAM,GEOCV,NXYZ,IKT, + > MESH,ISPLT,MESH1,ISPLT1) + IF(.NOT. VALSYM) THEN + WRITE(IOUT,8002) 'Y-Y',GEOCV, + > AXGTRN(IKT(1)),AXGTRN(IKT(2)) + CALL XABORT(NAMSBR// + > ': INVALID Y SYMMETRY FOR CELL') + ENDIF + ENDIF + ENDIF + ENDIF + 320 CONTINUE + 310 CONTINUE + 300 CONTINUE + ENDIF +*---- +* APPLY SYMMETRY IN X +*---- + IF( LCLSYM(1).NE.0)THEN + IF(IPRT .GT. 10) THEN + WRITE(IOUT,8000) NAMSBR,'X-X' + ENDIF + DO 400 IZ=1,MAXGRI(3) + DO 410 IY=1,MAXGRI(2) + DO 420 IX=1,MINGRI(1) + IOF1=((IZ-1)*MAXGRI(2)+(IY-1))*MAXGRI(1)+IX + IOF2=((IZ-1)*MAXGRI(2)+(IY-1))*MAXGRI(1)+MAXGRI(1)+1-IX + IKOF1=KEYTYP(IOF1) + IKOF2=KEYTYP(IOF2) + ITOF1=ITGEOM(IOF1) + ITOF2=ITGEOM(IOF2) + IF(IPRT .GT. 10) THEN + WRITE(IOUT,8010) IZ,IY,IX, + > IOF1,IOF2,IKOF1,IKOF2,ITOF1,ITOF2 + ENDIF + IF( IKOF1 .NE. IKOF2) THEN + IF( IKOF1 .GT. IKOF2) THEN + IKOF2= IKOF1 + ITOF2= AXGTRS(ITOF1,1) + KEYTYP(IOF2)= IKOF2 + ITGEOM(IOF2)= ITOF2 + ELSE + IKOF1= IKOF2 + ITOF1= AXGTRS(ITOF2,1) + KEYTYP(IOF1)= IKOF1 + ITGEOM(IOF1)= ITOF1 + ENDIF + ENDIF + IF(IKOF1 .GT. 0) THEN + IF(IX .EQ. (MAXGRI(1)+1-IX)) THEN + IKG=IKOF1 + IKT(1)=ITOF1 + IKT(2)=AXGTRS(IKT(1),1) + IF(IKG .GT. 0) THEN + WRITE(GEOCV,'(3A4)') + > CELLT(3*IKG-2),CELLT(3*IKG-1),CELLT(3*IKG) + IF(GEOCV .EQ. ' ') THEN + IF(IPRT .GT. 10) WRITE(IOUT,8001) + > GEONAM,AXGTRN(IKT(1)),AXGTRN(IKT(2)) + ELSE + IF(IPRT .GT. 10) WRITE(IOUT,8001) + > GEOCV,AXGTRN(IKT(1)),AXGTRN(IKT(2)) + ENDIF + VALSYM=LELCSY(IPGEOM,IPRT,GEONAM,GEOCV,NXYZ,IKT, + > MESH,ISPLT,MESH1,ISPLT1) + IF(.NOT. VALSYM) THEN + WRITE(IOUT,8002) 'X-X',GEOCV, + > AXGTRN(IKT(1)),AXGTRN(IKT(2)) + CALL XABORT(NAMSBR// + > ': INVALID X SYMMETRY FOR CELL') + ENDIF + ENDIF + ENDIF + ENDIF + 420 CONTINUE + 410 CONTINUE + 400 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(MESH1,MESH) + DEALLOCATE(ISPLT1,ISPLT) +*---- +* RETURN +*---- + RETURN +*---- +* FORMAT +*---- + 8000 FORMAT(1X,A6,' NOW TESTING SYMMETRY ',A3) + 8001 FORMAT(7X,A12,1X,'WITH ROTATION',1X,A2,' AND ',A2) + 8002 FORMAT(' INVALID SYMMETRY ',A3,' FOR ', + > A12,1X,'WITH ROTATION',1X,A2,' AND ',A2) + 8010 FORMAT(1X,'IZ=',I6,1X,'IY=',I6,1X,'IX=',I6/ + > 1X,'IOF1 =',I6,1X,'IOF2 =',I6, + > 1X,'KOF1 =',I6,1X,'KOF2 =',I6, + > 1X,'TOF1 =',I6,1X,'TOF2 =',I6) + END diff --git a/Dragon/src/AXGTRN.f b/Dragon/src/AXGTRN.f new file mode 100644 index 0000000..1498069 --- /dev/null +++ b/Dragon/src/AXGTRN.f @@ -0,0 +1,53 @@ + FUNCTION AXGTRN(ITRCUR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Associate to TURN number a DRAGON name. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* ITRCUR turn number. +* +*Parameters: output +* AXGTRN DRAGON turn name. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* Local parameters +*---- + INTEGER MAXTUR + CHARACTER NAMSBR*6 + PARAMETER (MAXTUR=12,NAMSBR='AXGTRN') +*---- +* Routine input and output variables +*---- + INTEGER ITRCUR + CHARACTER AXGTRN*(*) +*---- +* local variables +*---- + CHARACTER*2 CTURN(2*MAXTUR) + SAVE CTURN +*---- +* DEFINITION OF TURNS +*---- + DATA CTURN /' A',' B',' C',' D',' E',' F',' G',' H', + > ' I',' J',' K',' L', + > '-A','-B','-C','-D','-E','-F','-G','-H', + > '-I','-J','-K','-L'/ + IF(ITRCUR .LE. 0 .OR. ITRCUR .GT. 2*MAXTUR) CALL XABORT(NAMSBR// + > ': INVALID TURN NUMBER') + AXGTRN=CTURN(ITRCUR) + RETURN + END diff --git a/Dragon/src/AXGTRS.f b/Dragon/src/AXGTRS.f new file mode 100644 index 0000000..2566190 --- /dev/null +++ b/Dragon/src/AXGTRS.f @@ -0,0 +1,78 @@ + FUNCTION AXGTRS(ITRCUR,ISYM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transform turn according to symmetry. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* ITRCUR turn number. +* ISYM symmetry option. +* +*Parameters: output +* AXGTRS turn after symmetry is applied. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* Local parameters +*---- + INTEGER MAXTUR,MAXS + CHARACTER NAMSBR*6 + PARAMETER (MAXTUR=12,MAXS=3,NAMSBR='AXGTRS') +*---- +* Routine input and output variables +*---- + INTEGER ITRCUR,ISYM + INTEGER AXGTRS +*---- +* Local variables +*---- + INTEGER ITURN(2*MAXTUR,MAXS) + SAVE ITURN +*---- +* Definition of turns +*---- + DATA ITURN / +*---- +* SYMMETRY IN *X* +*---- + > 5 , 8 , 7 , 6 , 1 , 4 , 3 , 2 , + > 0 , 0 , 0 , 0 , + > 17 , 20 , 19 , 18 , 13 , 16 , 15 , 14 , + > 0 , 0 , 0 , 0 , +*---- +* SYMMETRY IN *Y* +*---- + > 7 , 6 , 5 , 8 , 3 , 2 , 1 , 4 , + > 0 , 0 , 0 , 0 , + > 19 , 18 , 17 , 20 , 15 , 14 , 13 , 16 , + > 0 , 0 , 0 , 0 , +*---- +* TSYMMETRY IN *X-Y* +*---- + > 6 , 5 , 8 , 7 , 2 , 1 , 4 , 3 , + > 0 , 0 , 0 , 0 , + > 18 , 17 , 20 , 19 , 14 , 13 , 16 , 15 , + > 0 , 0 , 0 , 0 / + IF(ITRCUR .LE. 0 .OR. ITRCUR .GT. 2*MAXTUR) CALL XABORT(NAMSBR// + > ': INVALID TURN NUMBER') + IF(ISYM .LE. 0 .OR. ISYM .GT. MAXS+1 ) CALL XABORT(NAMSBR// + > ': INVALID SYMMETRY') + IF(ISYM .LE. MAXS) THEN + AXGTRS=ITURN(ITRCUR,ISYM) + ELSE + AXGTRS=MOD(MAXTUR+ITRCUR,2*MAXTUR) + ENDIF + RETURN + END diff --git a/Dragon/src/AXGXCW.f b/Dragon/src/AXGXCW.f new file mode 100644 index 0000000..c2ac9c4 --- /dev/null +++ b/Dragon/src/AXGXCW.f @@ -0,0 +1,152 @@ +*DECK AXGXCW + SUBROUTINE AXGXCW(IPGEOM,IPTRKM,IPRINT,GEONAM,ISYMM ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Analyze XEL geometry WIMS-AECL type tracking with XCWTRK module. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPGEOM geometry data structure pointer. +* IPTRKM tracking data structure pointer. +* IPRINT print level. +* GEONAM geometry name. +* ISYMM geometry symmetry. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE + INTEGER IOUT,NALB,MREGIO,NSTATE + PARAMETER (IOUT=6,NALB=6,MREGIO=100000,NSTATE=40) +*---- +* ROUTINE PARAMETERS +*---- + TYPE(C_PTR) IPGEOM,IPTRKM + INTEGER IPRINT,ISYMM + CHARACTER*12 GEONAM +*---- +* INTEGER ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KEYMRG,MATALB,NRINFO,NRODS, + > NRODR,NXRS,NXRI,MATRT +*---- +* REAL ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: VOLSUR,RAN,RODS,RODR +*---- +* LOCAL VARIABLES +*---- + LOGICAL ILK + INTEGER NCODE(NALB),ICODE(NALB) + REAL ZCODE(NALB),ALBEDO(NALB) + INTEGER ISTATE(NSTATE) + INTEGER NDIM ,NSUR ,NVOL ,MAXJ ,IROT ,NBAN , + > MNAN ,NRT ,MSROD ,MAROD ,NSURF ,NSURX , + > NMAT ,NUNK + REAL RADMIN,COTE +*---- +* SET POSITION VECTOR AND READ ISTATE +*---- + IF(IPRINT.GT.0) THEN + WRITE(6,'(/26H AXGXCW: PROCESS GEOMETRY ,A12)') GEONAM + ENDIF + ISTATE(:NSTATE)=0 + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) + NDIM=2 + IF(ISTATE(1).EQ.3) THEN + NSUR=1 + ELSE IF(ISTATE(1).EQ.20) THEN + NSUR=4 + ELSE IF(ISTATE(1).EQ.24) THEN + NSUR=6 + ENDIF + MAXJ=1 + IROT=0 + CALL XCGDIM(IPGEOM,MREGIO,NSUR ,IROT ,ISYMM ,MAXJ , + > NVOL ,NBAN ,MNAN ,NRT ,MSROD ,MAROD , + > NSURF ) +*---- +* CHECK FOR SYMMETRY +*---- + NSURX=NSUR + IF(ISYMM.GT.1) THEN + IF(NSURX.EQ.4) THEN + IROT=-ISYMM-400 + ELSE IF(NSURX.EQ.6) THEN + IROT=-ISYMM-600 + ELSE + IROT=-ISYMM-100 + ENDIF + NSUR=1 + ENDIF +*---- +* ALLOCATE MEMORY FOR PROCESSING GEOMETRY INFORMATION +*---- + ALLOCATE(KEYMRG(NSUR+NVOL+1),MATALB(NSUR+NVOL+1),NRINFO(2*MNAN), + > NRODS(3*NRT),NRODR(NRT),NXRS(NRT),NXRI(NRT*NBAN)) + ALLOCATE(VOLSUR(NSUR+NVOL+1),RAN(NBAN),RODS(2*NRT), + > RODR(MSROD*NRT)) +* + CALL XCGGEO(IPGEOM,IROT ,NSUR ,NVOL ,NBAN ,MNAN , + > NRT ,MSROD ,IPRINT,ILK ,NMAT ,RAN , + > NRODS ,RODS ,NRODR ,RODR ,NRINFO,MATALB, + > VOLSUR,COTE ,RADMIN,NCODE ,ICODE ,ZCODE , + > ALBEDO,KEYMRG,NXRS ,NXRI) +*---- +* BUILD BOUNDARY CONDITION MATRIX FOR REFLECTION AND TRANSMISSION +*---- + ALLOCATE(MATRT(NSUR)) + CALL XCGBCM(IPTRKM,NSUR ,NCODE ,MATRT ) +*---- +* SAVE TRACKING FOR CLUSTER GEOMETRY +*---- + ISTATE(:NSTATE)=0 + NUNK=NVOL+NSUR+1 + ISTATE(1)=NDIM + ISTATE(2)=NSUR + ISTATE(3)=NVOL + ISTATE(4)=NSURX + ISTATE(5)=NBAN + ISTATE(6)=NUNK + ISTATE(7)=NRT + ISTATE(8)=MSROD + ISTATE(9)=MAROD + ISTATE(10)=MNAN + CALL LCMSIX(IPTRKM,'EXCELL ',1) + CALL LCMPUT(IPTRKM,'STATE-VECTOR',NSTATE ,1,ISTATE) + CALL LCMPUT(IPTRKM,'RAN ',NBAN ,2,RAN ) + IF(NSURX .EQ. 4) + >CALL LCMPUT(IPTRKM,'COTE ',1 ,2,COTE ) + CALL LCMPUT(IPTRKM,'RADMIN ',1 ,2,RADMIN) + CALL LCMPUT(IPTRKM,'NRODS ',3*NRT ,1,NRODS ) + CALL LCMPUT(IPTRKM,'RODS ',2*NRT ,2,RODS ) + CALL LCMPUT(IPTRKM,'NRODR ',NRT ,1,NRODR ) + CALL LCMPUT(IPTRKM,'RODR ',MSROD*NRT,2,RODR ) + CALL LCMPUT(IPTRKM,'NRINFO ',2*NBAN ,1,NRINFO) + CALL LCMPUT(IPTRKM,'NXRI ',NRT*NBAN ,1,NXRI ) + CALL LCMPUT(IPTRKM,'NXRS ',NRT ,1,NXRS ) + CALL LCMPUT(IPTRKM,'KEYMRG ',NUNK ,1,KEYMRG) + CALL LCMPUT(IPTRKM,'MATALB ',NUNK ,1,MATALB) + CALL LCMPUT(IPTRKM,'VOLSUR ',NUNK ,2,VOLSUR) + CALL LCMSIX(IPTRKM,'EXCELL ',2) + CALL LCMPUT(IPTRKM,'ALBEDO ',6 ,2,ALBEDO) + CALL LCMPUT(IPTRKM,'ICODE ',6 ,1,ICODE ) + CALL LCMPUT(IPTRKM,'NCODE ',6 ,1,NCODE ) +*---- +* RELEASE BLOCKS FOR GEOMETRY +*---- + DEALLOCATE(MATRT) + DEALLOCATE(RODR,RODS,RAN,VOLSUR) + DEALLOCATE(NXRI,NXRS,NRODR,NRODS,NRINFO,MATALB,KEYMRG) + RETURN + END diff --git a/Dragon/src/AXGXEL.f b/Dragon/src/AXGXEL.f new file mode 100644 index 0000000..c1a5a67 --- /dev/null +++ b/Dragon/src/AXGXEL.f @@ -0,0 +1,203 @@ +*DECK AXGXEL + SUBROUTINE AXGXEL(IPGEOM,IPTRKM,IPRINT,GEONAM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Analyze XEL geometry for original Excell tracking with XELTRK module. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPGEOM geometry data structure pointer. +* IPTRKM tracking data structure pointer. +* IPRINT print level. +* GEONAM geometry name. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE + INTEGER IOUT,NALB,MREGIO,MXDIM,NSTATE + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NALB=6,MREGIO=100000,MXDIM=3,NSTATE=40, + > NAMSBR='AXGXEL') +*---- +* ROUTINE PARAMETERS +*---- + TYPE(C_PTR) IPGEOM + TYPE(C_PTR) IPTRKM + INTEGER IPRINT + CHARACTER*12 GEONAM +*---- +* LOCAL VARIABLES +*---- + INTEGER NCODE(NALB),ICODE(NALB) + REAL ALBEDO(NALB) + INTEGER MAXGRI(MXDIM),LCLSYM(MXDIM),LCLTRA(MXDIM), + > MRGSUR(-NALB:-1) + INTEGER ISTATE(NSTATE) + LOGICAL LEAKSW,LL1,LL2,L1CELL + INTEGER NDIM,NTYPO,NBLOCK,NBMIX,NEXTGE,IFCSYM + INTEGER NTOTCO,MAXRO,NGEOME,NGIDL,NTIDL,NUNKO + INTEGER NTYP,NTOTCL,MAXR + INTEGER NSUR,NSURC,NVOL,NVOLC,NUNK,NSBC +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MRGCEL, NSURO, NVOLO,IDLGEO, + > IDLDIM,KEYGEO,IDLTYP,KEYTYP,IDLBLK,KCELLG,KEYTRN,IDLREM, MINDO, + > MAXDO,ICORDO,MATGEO,INDEXO,MATTYP,KEYINT,KEYCYL,KEYMRG,MATALB, + > MINDIM,MAXDIM, ICORD,INCELL, MATRT, INDEX + REAL, ALLOCATABLE, DIMENSION(:) :: REMSHO,VOLSRO,VOLSUR,REMESH +*---- +* GET DIMENSIONING INFORMATION +*---- + CALL XELPRP( IPGEOM, GEONAM, NDIM, NTYPO , NBLOCK, NBMIX, + > MAXGRI, ALBEDO, ICODE, NCODE, LCLSYM, LCLTRA, + > MRGSUR, LEAKSW, LL1, LL2, L1CELL, NEXTGE, + > IFCSYM, IPRINT) +*---- +* ALLOCATE MEMORY - 1 +*---- + ALLOCATE(MRGCEL(NBLOCK),NSURO(NBLOCK),NVOLO(NBLOCK), + > IDLGEO(NBLOCK),IDLDIM(NBLOCK),KEYGEO(NBLOCK),IDLTYP(NBLOCK), + > KEYTYP(NBLOCK),IDLBLK(NBLOCK),KCELLG(3*NBLOCK),KEYTRN(NBLOCK)) +*---- +* READ GEOMETRY BLOCK DESCRIPTION +*---- + CALL XELDCL(IPGEOM,GEONAM,NDIM ,MAXGRI,LCLSYM,NBLOCK,NTYPO , + > LL1 ,LL2 ,IPRINT,NTOTCO,MAXRO ,NGEOME,NTYP , + > NGIDL ,NTIDL ,NUNKO ,KCELLG,NSURO ,NVOLO ,IDLDIM, + > IDLGEO,KEYTRN,KEYGEO,IDLTYP,KEYTYP,MRGCEL,IDLBLK) +*---- +* ALLOCATE MEMORY - 2 +*---- + ALLOCATE(IDLREM(NGEOME),MINDO(NTOTCO),MAXDO(NTOTCO), + > ICORDO(NTOTCO),MATGEO(NGIDL),INDEXO(4*NGIDL)) + ALLOCATE(REMSHO(MAXRO),VOLSRO(NGIDL)) +*---- +* PRODUCE REGION NUMBERING AND VOLUME EVALUATION +*---- + CALL XELTRP(IPGEOM,NGIDL ,NDIM ,NGEOME,L1CELL,NTOTCO,NEXTGE, + > MAXRO ,IPRINT,KCELLG,NSURO ,NVOLO ,IDLDIM,IDLGEO, + > KEYTRN,MAXDO ,MINDO ,ICORDO,REMSHO,IDLREM,INDEXO, + > VOLSRO,MATGEO) +*---- +* RELEASE SOME MEMORY +*---- + DEALLOCATE(KEYTRN) +*---- +* ALLOCATE MEMORY - 3 +*---- + ALLOCATE(MATTYP(NTIDL),KEYINT(NUNKO)) +*---- +* INTERFACE ALL CELLS IN THE GEOMETRY +*---- + CALL XELBIN(IPGEOM,NDIM ,NGEOME,L1CELL, NTYP, NGIDL,NTIDL , + > NBLOCK,MAXGRI,NUNKO ,IPRINT,KCELLG, NSURO,NVOLO , + > IDLGEO,MATGEO,KEYGEO,IDLTYP,IDLBLK,KEYTYP,MATTYP, + > KEYINT) +*---- +* ALLOCATE MEMORY - 4 +*---- + ALLOCATE(KEYCYL(NBLOCK)) +*---- +* COMPUTE ALLOCATION IN EXACT GEOMETRY. +*---- + CALL XELEDC(NDIM ,MAXGRI,NGEOME,NTOTCO,NTYP ,NBLOCK,NUNKO , + > NSURO ,NVOLO ,MINDO ,MAXDO ,ICORDO,IDLDIM,KEYGEO, + > KEYTYP,IDLBLK,KEYINT,NTOTCL,MAXR ,NSUR ,NVOL , + > KEYCYL) + NUNK= NVOL + 1 - NSUR +*---- +* ALLOCATE MEMORY - 5 +*---- + ALLOCATE(KEYMRG(NUNK),MATALB(NUNK),MINDIM(NTOTCL),MAXDIM(NTOTCL), + > ICORD(NTOTCL),INDEX(4*NUNK),INCELL(NUNK)) + ALLOCATE(VOLSUR(NUNK),REMESH(MAXR)) +*---- +* TO RECONSTRUCT THE MESH IN EXACT GEOMETRY. +*---- + CALL XELETR(IPRINT,NDIM ,MAXGRI,NGEOME,NTOTCO,NTYP ,NTIDL , + > NBLOCK,NSUR ,NVOL ,NTOTCL,NUNKO ,NSURO ,NVOLO , + > MINDO, MAXDO ,ICORDO,IDLDIM,IDLGEO,KEYGEO,IDLTYP, + > KEYTYP,IDLBLK,KEYCYL,REMSHO,IDLREM,INDEXO,VOLSRO, + > MATGEO,KEYINT,MATTYP,REMESH,MINDIM,MAXDIM,ICORD , + > VOLSUR,KEYMRG,INDEX ,INCELL,MATALB,NSURC ,NVOLC ) + NSUR=NSURC + NVOL=NVOLC + NUNK= NVOL + 1 - NSUR + DEALLOCATE(KEYCYL,KEYINT,MATTYP,INDEXO,MATGEO,ICORDO,MAXDO,MINDO, + > IDLBLK,KEYTYP,IDLTYP,KEYGEO,IDLDIM,IDLREM,KCELLG,IDLGEO,NVOLO, + > NSURO) + DEALLOCATE(VOLSRO,REMSHO) +*---- +* ALLOCATE MEMORY - 6 +*---- + ALLOCATE(MATRT(-NSUR*2)) +*---- +* PREPARE MERGING OF ZONES AND SURFACES USING BOUNDARY CONDITIONS. +* SET UP REFLECTION-TRANSMISSION MATRIX +*---- + CALL XELMRG(IPRINT,NSUR ,NVOL ,NSBC ,NTOTCL,INDEX ,MINDIM, + > MAXDIM,LCLSYM,LCLTRA,LL1 ,LL2 ,MRGCEL,MATALB, + > KEYMRG,INCELL,MATRT ) +*---- +* SAVE EXCELL TRACKING FOR CARTESIAN GEOMETRY +*---- + CALL LCMSIX(IPTRKM,'EXCELL ',1) + ISTATE(:NSTATE)=0 + ISTATE(1)=NDIM + ISTATE(2)=-NSUR + ISTATE(3)=NVOL + ISTATE(4)=NTOTCL + ISTATE(5)=MAXR + ISTATE(6)=NUNK + ISTATE(7)=NEXTGE + ISTATE(8)=LCLSYM(1) + ISTATE(9)=LCLSYM(2) + IF(NDIM .EQ. 3) ISTATE(10)=LCLSYM(3) +*---- +* LL1 is for diagonal symmetry +* with region Pi/4 to Pi/2 defined in x-y plane +* LL2 is for diagonal symmetry +* with region 0 to Pi/4 defined in x-y plane +*---- + IF(LL1) THEN + ISTATE(11)=-1 + ELSE IF(LL2) THEN + ISTATE(11)=1 + ENDIF + CALL LCMPUT(IPTRKM,'MINDIM ',NTOTCL,1,MINDIM) + CALL LCMPUT(IPTRKM,'MAXDIM ',NTOTCL,1,MAXDIM) + CALL LCMPUT(IPTRKM,'ICORD ',NTOTCL,1,ICORD ) + CALL LCMPUT(IPTRKM,'INDEX ',4*NUNK,1,INDEX ) + CALL LCMPUT(IPTRKM,'REMESH ',MAXR ,2,REMESH) + CALL LCMPUT(IPTRKM,'KEYMRG ',NUNK ,1,KEYMRG) + CALL LCMPUT(IPTRKM,'MATALB ',NUNK ,1,MATALB) + CALL LCMPUT(IPTRKM,'VOLSUR ',NUNK ,2,VOLSUR) + CALL LCMPUT(IPTRKM,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMSIX(IPTRKM,'EXCELL ',2) +*---- +* SAVE REFLECTION-TRANSMISSION MATRIX +*---- + CALL LCMPUT(IPTRKM,'BC-REFL+TRAN',NSBC,1,MATRT) + CALL LCMPUT(IPTRKM,'ALBEDO ',6 ,2,ALBEDO ) + CALL LCMPUT(IPTRKM,'ICODE ',6 ,1,ICODE ) + CALL LCMPUT(IPTRKM,'NCODE ',6 ,1,NCODE ) + DEALLOCATE(MATRT) +*---- +* RELEASE REMAINING MEMORY +*---- + DEALLOCATE(INCELL,INDEX,ICORD,MAXDIM,MINDIM,MATALB,KEYMRG,MRGCEL) + DEALLOCATE(REMESH,VOLSUR) + RETURN + END diff --git a/Dragon/src/B1BETA.f b/Dragon/src/B1BETA.f new file mode 100644 index 0000000..5d8ebd6 --- /dev/null +++ b/Dragon/src/B1BETA.f @@ -0,0 +1,73 @@ +*DECK B1BETA + DOUBLE PRECISION FUNCTION B1BETA(IAPROX,B2,SIG,DHOM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the beta function for a P1 or B1 calculation. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IAPROX type of beta function calculation: +* =0: LKRD or RHS; =1: P0 or P1; =2: B0 or B1. +* B2 buckling. +* SIG total macroscopic cross section. +* DHOM homogeneous leakage coefficient (used if IAPROX=0). +* +*Parameters: output +* B1BETA value of the beta function. +* +*----------------------------------------------------------------------- +* + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IAPROX + DOUBLE PRECISION B2,SIG,DHOM + PARAMETER(B2LIM=0.5D0) +* + SIG2=SIG*SIG + B1BETA=0.0D0 + IF ((SIG.EQ.0.0).AND.(B2.EQ.0.0)) THEN + B1BETA=1.0E10 + ELSE IF (IAPROX.EQ.0) THEN +* LKRD APPROXIMATION (IMPOSED DIFFUSION COEFFICIENT). + B1BETA=DHOM/(SIG+DHOM*B2) + ELSE IF (IAPROX.EQ.1) THEN +* P0 OR P1 APPROXIMATION + B1BETA=1.0D0/(3.0D0*SIG2+B2) + ELSE IF (IAPROX.EQ.2) THEN +* B0 OR B1 APPROXIMATION + IF (B2.GT.0.05D0*SIG2) THEN + TMP=SQRT(B2)/SIG + B1BETA=(1.0D0-ATAN(TMP)/TMP)/B2 + ELSE IF((B2.LE.0.05D0*SIG2).AND.(B2.GE.-0.05D0*SIG2)) THEN + TMP=B2/SIG2 + B1BETA=(1.0D0-3.0D0*TMP*(0.2D0-TMP/7.0D0+TMP*TMP/9.0D0-TMP + 1 *TMP*TMP/11.0D0))/(3.0D0*SIG2) + ELSE IF ((B2.LT.-0.05D0*SIG2).AND.(B2.GE.-B2LIM*SIG2)) THEN + TMP=SQRT(-B2) + B1BETA=(1.0D0-0.5D0*SIG*LOG((SIG+TMP)/(SIG-TMP))/TMP)/B2 + ELSE IF(B2.LT.-B2LIM*SIG2) THEN +* Pn-type fundamental mode extension for extreme subcritical +* cases + TMP2=SQRT(B2LIM*SIG2) + ALPHA1=0.5D0*LOG((SIG+TMP2)/(SIG-TMP2))/TMP2 + ALPHA2=3.0D0*SIG/(3.0D0*SIG2-B2LIM*SIG2) + ALPHA3=3.0D0*SIG/(3.0D0*SIG2+B2) + B1BETA=(1.0D0-(ALPHA1-ALPHA2+ALPHA3)*SIG)/B2 + ENDIF + ELSE + CALL XABORT('B1BETA: INVALID VALUE OF IAPROX.') + ENDIF + RETURN + END diff --git a/Dragon/src/B1DIF.f b/Dragon/src/B1DIF.f new file mode 100644 index 0000000..8739ccc --- /dev/null +++ b/Dragon/src/B1DIF.f @@ -0,0 +1,381 @@ +*DECK B1DIF + SUBROUTINE B1DIF(OPTION,TYPE,NGRO,ST,SFNU,XHI,IJJ0,IJJ1,NJJ0,NJJ1, + 1 SCAT0,SCAT1,REFKEF,LFISSI,IMPX,DHOM,GAMMA,B2,ALAM1,CAET,A2,PHI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solve the B-n equations and perform a buckling search if required. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* OPTION type of leakage coefficient. Can be 'LKRD', 'RHS', 'B0', 'P0', +* 'B1', 'P1', 'B0TR' or 'P0TR'. 'LKRD' and 'RHS' are used to +* impose a leakage coefficient. +* TYPE type of buckling search. Can be 'DIFF', 'K', 'B' or 'L'. +* NGRO number of energy groups. +* ST macroscopic total cross sections. +* SFNU nu*macroscopic fission cross sections. +* XHI fission spectrum normalized to one. +* IJJ0 most thermal group in band for P0 scattering. +* NJJ0 number of groups in band for P0 scattering. +* IJJ1 most thermal group in band for P1 scattering. +* NJJ1 number of groups in band for P1 scattering. +* SCAT0 packed diffusion P0 macroscopic cross sections. +* SCAT1 packed diffusion P1 macroscopic cross sections. +* REFKEF target K-effective for type B or type L calculations. +* LFISSI fissile isotope flag (=.TRUE. if present). +* IMPX print flag. +* +*Parameters: input/output +* PHI homogeneous flux from heterogeneous calculation on input and +* fundamental flux at output. +* +*Parameters: output +* DHOM homogeneous leakage coefficients. +* GAMMA gamma factors. +* B2 buckling. +* ALAM1 effective multiplication factor. +* CAET infinite multiplication factor. +* A2 migration area. +* +*----------------------------------------------------------------------- +* + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER OPTION*4,TYPE*4 + INTEGER NGRO,IJJ0(NGRO),IJJ1(NGRO),NJJ0(NGRO),NJJ1(NGRO),IMPX + REAL ST(NGRO),SFNU(NGRO),XHI(NGRO),SCAT0(*),SCAT1(*),DHOM(NGRO), + > GAMMA(NGRO) + DOUBLE PRECISION B2,ALAM1,CAET,A2,PHI(NGRO),REFKEF + LOGICAL LFISSI +*---- +* LOCAL VARIABLES +*---- + PARAMETER (EPS=1.0D-6,MAXIT=50) + DOUBLE PRECISION FFITX(MAXIT),B2ITX(MAXIT) + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: CSTOC,SA + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: ASTOC,BSTOC +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(ASTOC(NGRO,NGRO+1),BSTOC(NGRO,NGRO),CSTOC(NGRO),SA(NGRO)) +* + IF((IMPX.GT.0).AND.(TYPE.EQ.'DIFF')) THEN + WRITE (6,400) + ELSE IF(IMPX.GT.0) THEN + WRITE (6,410) OPTION,TYPE + ENDIF + IAPROX=2 + IF((OPTION.EQ.'P0').OR.(OPTION.EQ.'P1').OR.(OPTION.EQ.'P0TR')) + > IAPROX=1 + IF((OPTION.EQ.'LKRD').OR.(OPTION.EQ.'RHS')) IAPROX=0 + BIL1=0.0D0 + DO 5 I=1,NGRO + BIL1=BIL1+XHI(I) + SA(I)=ST(I) + 5 CONTINUE + IF((BIL1.GT.0.9D0).AND.(ABS(BIL1-1.0D0).GT.EPS)) THEN + IF(IMPX.GT.0) + > WRITE(6,'(46H B1DIF: WARNING INCONSISTENT FISSION SPECTRUM.)') + ENDIF + IGAR=0 + DO 11 I=1,NGRO + DO 10 J=IJJ0(I),IJJ0(I)-NJJ0(I)+1,-1 + IGAR=IGAR+1 + SA(J)=SA(J)-SCAT0(IGAR) + 10 CONTINUE + 11 CONTINUE + IF(TYPE.EQ.'DIFF') THEN + DO 15 I=1,NGRO + ST2=DBLE(ST(I)) + GAMMA(I)=REAL(B1GAMA(IAPROX,B2,ST2)) + IF(IAPROX.NE.0) DHOM(I)=REAL(1.0D0/(3.0D0*GAMMA(I)*ST2)) + 15 CONTINUE + RETURN + ELSE IF((TYPE.EQ.'B').OR.(TYPE.EQ.'L')) THEN +* COMPUTE THE INITIAL BUCKLING. + BIL1=0.0D0 + BIL2=0.0D0 + IF(LFISSI) THEN + DO 20 I=1,NGRO + BIL1=BIL1+(SFNU(I)/REFKEF)*PHI(I) + 20 CONTINUE + ENDIF + DO 21 I=1,NGRO + BIL1=BIL1-SA(I)*PHI(I) + BIL2=BIL2+DHOM(I)*PHI(I) + 21 CONTINUE + B2=BIL1/BIL2 + DO 25 I=1,NGRO + ST2=-0.7D0*(ST(I)**2) + IF(B2.LT.ST2) THEN + IF(IMPX.GT.0) WRITE (6,415) B2,ST2 + B2=ST2 + ENDIF + PHI(I)=1.0D0 + 25 CONTINUE + ENDIF + IF(IMPX.GT.1) WRITE(6,420) B2 + IF(TYPE.EQ.'L') GO TO 160 +*---- +* COMPUTE THE FUNDAMENTAL FLUX WITH TYPE K OR TYPE B +*---- + ITEX=0 + 30 ITEX=ITEX+1 + IF(ITEX.GT.MAXIT) CALL XABORT('B1DIF: UNABLE TO CONVERGE(1).') + IGAR=0 + DO 55 I=1,NGRO + ST2=DBLE(ST(I)) + DD=DBLE(DHOM(I)) + BETA=B1BETA(IAPROX,B2,ST2,DD) + DO 40 J=1,NGRO + ASTOC(I,J)=0.0D0 + BSTOC(I,J)=0.0D0 + 40 CONTINUE + ASTOC(I,I)=ST2 + ASTOC(I,NGRO+1)=(1.0D0-B2*BETA)*XHI(I) + DO 50 J=IJJ0(I),IJJ0(I)-NJJ0(I)+1,-1 + IGAR=IGAR+1 + ASTOC(I,J)=ASTOC(I,J)-(1.0D0-B2*BETA)*SCAT0(IGAR) + BSTOC(I,J)=SCAT0(IGAR) + 50 CONTINUE + 55 CONTINUE + IF((OPTION.EQ.'P1').OR.(OPTION.EQ.'B1')) THEN + DO 72 J=1,NGRO + DO 60 K=1,NGRO + CSTOC(K)=BSTOC(K,J) + BSTOC(K,J)=0.0D0 + 60 CONTINUE + IGAR=0 + DO 71 I=1,NGRO + DO 70 K=IJJ1(I),IJJ1(I)-NJJ1(I)+1,-1 + IGAR=IGAR+1 + BSTOC(I,J)=BSTOC(I,J)+3.0D0*SCAT1(IGAR)*CSTOC(K) + 70 CONTINUE + 71 CONTINUE + 72 CONTINUE + IGAR=0 + DO 95 I=1,NGRO + ST2=DBLE(ST(I)) + DD=DBLE(DHOM(I)) + BETA=B1BETA(IAPROX,B2,ST2,DD)*ST2 + DO 80 J=1,NGRO + ASTOC(I,J)=ASTOC(I,J)+BETA*BSTOC(I,J) + 80 CONTINUE + DO 90 J=IJJ1(I),IJJ1(I)-NJJ1(I)+1,-1 + IGAR=IGAR+1 + ASTOC(I,NGRO+1)=ASTOC(I,NGRO+1)-3.0D0*BETA*SCAT1(IGAR)*XHI(J) + ASTOC(I,J)=ASTOC(I,J)-3.0D0*BETA*SCAT1(IGAR)*ST(J) + 90 CONTINUE + 95 CONTINUE + ENDIF + CALL B1SOL(NGRO,ASTOC,IER) + IF(IER.NE.0) CALL XABORT('B1DIF: SINGULAR MATRIX(1).') + ALAM1=0.0D0 + CAET=0.0D0 + DO 130 I=1,NGRO + ALAM1=ALAM1+SFNU(I)*ASTOC(I,NGRO+1) + CAET=CAET+SA(I)*ASTOC(I,NGRO+1) + 130 CONTINUE + IF(IMPX.GT.1) WRITE (6,430) ITEX,ALAM1,B2 + B2ITX(ITEX)=B2 + FFITX(ITEX)=REFKEF-ALAM1 + IF(TYPE.EQ.'K') THEN + DO 140 I=1,NGRO + PHI(I)=ASTOC(I,NGRO+1)/ALAM1 + 140 CONTINUE + ELSE IF(TYPE.EQ.'B') THEN +* COMPUTE THE EXTRAPOLATED BUCKLING. + IF(ITEX.LE.5) THEN +* USE A BALANCE RELATION. + B2=B2*(ALAM1/REFKEF-CAET)/(1.0D0-CAET) + ELSE + IF(ITEX.EQ.6) THEN +* SORT THE ROOT CONVERGENCE HISTORY. + DO I=2,ITEX-1 + WORKF=FFITX(ITEX-I) + WORKB=B2ITX(ITEX-I) + J=I + DO WHILE((J.GT.0).AND. + > (ABS(FFITX(ITEX-J+1)).GT.ABS(WORKF))) + FFITX(ITEX-J)=FFITX(ITEX-J+1) + B2ITX(ITEX-J)=B2ITX(ITEX-J+1) + J=J-1 + ENDDO + FFITX(ITEX-J)=WORKF + B2ITX(ITEX-J)=WORKB + ENDDO + ENDIF + J=0 + DO I=ITEX-1,2,-1 + IF(FFITX(I)*FFITX(ITEX).LT.0.0) THEN + J=I + EXIT + ENDIF + ENDDO + IF(J.NE.0) THEN +* USE A BISSECTION METHOD. + B2=0.5D0*(B2ITX(J)+B2ITX(ITEX)) + ELSE +* USE THE SECANT METHOD. + AA=FFITX(ITEX)-FFITX(ITEX-1) + B2=(B2ITX(ITEX-1)*FFITX(ITEX)-B2ITX(ITEX)*FFITX(ITEX-1))/AA + ENDIF + ENDIF +* CHECK THE CONVERGENCE. + BIL1=0.0D0 + BIL2=0.0D0 + DO 150 I=1,NGRO + ST2=ST(I)**2 + BIL1=MAX(BIL1,ABS(ASTOC(I,NGRO+1)/ALAM1)) + BIL2=MAX(BIL2,ABS(PHI(I)-ASTOC(I,NGRO+1)/ALAM1)) + PHI(I)=ASTOC(I,NGRO+1)/ALAM1 + 150 CONTINUE + ERR3=ABS(REFKEF-ALAM1) + IF((BIL2.GE.10*EPS*BIL1).OR.(ERR3.GE.EPS)) GO TO 30 + ENDIF + GO TO 300 +*---- +* COMPUTE THE FUNDAMENTAL FLUX WITH TYPE L +*---- + 160 ITEX=0 + 170 ITEX=ITEX+1 + IF(ITEX.GT.MAXIT) CALL XABORT('B1DIF: UNABLE TO CONVERGE(2).') + IF((OPTION.EQ.'P1').OR.(OPTION.EQ.'B1')) THEN + IGAR=0 + DO 200 I=1,NGRO + ST2=DBLE(ST(I)) + DD=DBLE(DHOM(I)) + BETA=B1BETA(IAPROX,B2,ST2,DD) + BETA=BETA*ST2/(1.0D0-B2*BETA) + DO 180 J=1,NGRO + ASTOC(I,J)=0.0D0 + 180 CONTINUE + ASTOC(I,I)=1.0D0 + ASTOC(I,NGRO+1)=BETA + DO 190 J=IJJ1(I),IJJ1(I)-NJJ1(I)+1,-1 + IGAR=IGAR+1 + ASTOC(I,J)=ASTOC(I,J)-3.0D0*BETA*SCAT1(IGAR)*PHI(J)/PHI(I) + 190 CONTINUE + 200 CONTINUE + CALL B1SOL(NGRO,ASTOC,IER) + IF(IER.NE.0) CALL XABORT('B1DIF: SINGULAR MATRIX(2).') + DO 210 I=1,NGRO + DHOM(I)=REAL(ASTOC(I,NGRO+1)) + 210 CONTINUE + ELSE IF((OPTION.NE.'LKRD').AND.(OPTION.NE.'RHS')) THEN + DO 220 I=1,NGRO + ST2=ST(I) + GAMMA(I)=REAL(B1GAMA(IAPROX,B2,ST2)) + IF(IAPROX.NE.0) DHOM(I)=REAL(1.0D0/(3.0D0*GAMMA(I)*ST2)) + 220 CONTINUE + ENDIF + ASTOC(:NGRO,:NGRO)=0.0D0 + BSTOC(:NGRO,:NGRO)=0.0D0 + ASTOC(:NGRO,NGRO+1)=PHI(:NGRO) + IGAR=0 + DO 250 I=1,NGRO + ASTOC(I,I)=ASTOC(I,I)+ST(I) + BSTOC(I,I)=BSTOC(I,I)-DHOM(I) + DO 230 J=IJJ0(I),IJJ0(I)-NJJ0(I)+1,-1 + IGAR=IGAR+1 + ASTOC(I,J)=ASTOC(I,J)-SCAT0(IGAR) + 230 CONTINUE + IF(LFISSI) THEN + DO 240 J=1,NGRO + ASTOC(I,J)=ASTOC(I,J)-XHI(I)*SFNU(J)/REFKEF + 240 CONTINUE + ENDIF + 250 CONTINUE + B2OLD=B2 + CALL ALEIGD(ASTOC,BSTOC,NGRO,B2,ASTOC(1,NGRO+1),EPS,IT) + IF(IMPX.GT.1) WRITE (6,440) ITEX,IT,B2 + BIL1=SQRT(DOT_PRODUCT(ASTOC(:NGRO,NGRO+1),ASTOC(:NGRO,NGRO+1))) + BIL2=0.0D0 + DO 260 I=1,NGRO + BIL2=MAX(BIL2,ABS(PHI(I)-ASTOC(I,NGRO+1)/BIL1)) + PHI(I)=0.5*(PHI(I)+ASTOC(I,NGRO+1)/BIL1) + 260 CONTINUE + ERR3=ABS(B2-B2OLD) + IF((BIL2.GE.10.0*EPS*BIL1).OR.(ERR3.GE.EPS)) GO TO 170 +*---- +* COMPUTE THE LEAKAGE COEFFICIENTS +*---- + 300 IF((OPTION.EQ.'P1').OR.(OPTION.EQ.'B1')) THEN + IGAR=0 + DO 325 I=1,NGRO + ST2=DBLE(ST(I)) + DD=DBLE(DHOM(I)) + BETA=B1BETA(IAPROX,B2,ST2,DD) + BETA=BETA*ST2/(1.0D0-B2*BETA) + DO 310 J=1,NGRO + ASTOC(I,J)=0.0D0 + 310 CONTINUE + ASTOC(I,I)=1.0D0 + ASTOC(I,NGRO+1)=BETA + DO 320 J=IJJ1(I),IJJ1(I)-NJJ1(I)+1,-1 + IGAR=IGAR+1 + ASTOC(I,J)=ASTOC(I,J)-3.0D0*BETA*SCAT1(IGAR)*PHI(J)/PHI(I) + 320 CONTINUE + 325 CONTINUE + CALL B1SOL(NGRO,ASTOC,IER) + IF(IER.NE.0) CALL XABORT('B1DIF: SINGULAR MATRIX(2).') + DO 330 I=1,NGRO + DHOM(I)=REAL(ASTOC(I,NGRO+1)) + 330 CONTINUE + ELSE IF((OPTION.NE.'LKRD').AND.(OPTION.NE.'RHS')) THEN + DO 340 I=1,NGRO + ST2=ST(I) + GAMMA(I)=REAL(B1GAMA(IAPROX,B2,ST2)) + IF(IAPROX.NE.0) DHOM(I)=REAL(1.0D0/(3.0D0*GAMMA(I)*ST2)) + 340 CONTINUE + ENDIF + A2=0.0D0 + CAET=0.0D0 + ZXC=0.0D0 + DO 350 I=1,NGRO + A2=A2+DHOM(I)*PHI(I) + CAET=CAET+SA(I)*PHI(I) + IF(LFISSI) ZXC=ZXC+SFNU(I)*PHI(I)/REFKEF + ST2=DBLE(ST(I)) + GAMMA(I)=REAL(B1GAMA(IAPROX,B2,ST2)) + 350 CONTINUE + A2=A2/CAET + CAET=REFKEF*ZXC/CAET + IF(CAET.EQ.0.0) THEN + ALAM2=0.0 + ELSE + ALAM2=CAET/(1.0D0+A2*B2) + ENDIF + IF(TYPE.EQ.'L') ALAM1=ALAM2 + IF(IMPX.GT.0) WRITE (6,450) ITEX,B2,ALAM1,ALAM2,CAET,A2 +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SA,CSTOC,BSTOC,ASTOC) + RETURN +* + 400 FORMAT(/42H B1DIF: DIFFUSION COEFFICIENT CALCULATION.) + 410 FORMAT(/20H B1DIF: SOLUTION OF ,A4,21H EQUATIONS WITH TYPE ,A4) + 415 FORMAT(47H B1DIF: THE INITIAL BUCKLING WAS INCREASED FROM,1P, + 1 E13.5,3H TO,E13.5) + 420 FORMAT(26H B1DIF: INITIAL BUCKLING =,1P,E13.5) + 430 FORMAT(33H B1DIF: K-EFFECTIVE ITERATION NO.,I3,13H. K-EFFECTIVE, + 1 2H =,F10.6,11H BUCKLING =,1P,E13.5) + 440 FORMAT(30H B1DIF: BUCKLING ITERATION NO.,I3,13H CONVERGED IN,I5, + 1 29H INNER ITERATIONS. BUCKLING =,1P,E13.5) + 450 FORMAT(8X,22HNUMBER OF ITERATIONS =,I3/8X,10HBUCKLING =,1P,E13.5, + 1 0P/8X,13HK-EFFECTIVE =,F10.6,3H (,F10.6,2H )/8X,12HK-INFINITE =, + 2 F10.6/8X,16HMIGRATION AREA =,1P,E13.5/) + END diff --git a/Dragon/src/B1GAMA.f b/Dragon/src/B1GAMA.f new file mode 100644 index 0000000..5453f42 --- /dev/null +++ b/Dragon/src/B1GAMA.f @@ -0,0 +1,74 @@ +*DECK B1GAMA + DOUBLE PRECISION FUNCTION B1GAMA(IAPROX,B2,SIG) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the gamma function for a P1 or B1 calculation. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IAPROX type of beta function calculation: +* =0: LKRD or RHS; =1: P0 or P1; =2: B0 or B1. +* B2 buckling. +* SIG total macroscopic cross section. +* +*Parameters: output +* B1GAMA value of the gamma function. +* +*----------------------------------------------------------------------- +* + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IAPROX + DOUBLE PRECISION B2,SIG + PARAMETER(B2LIM=0.5D0) +* + SIG2=SIG*SIG + B1GAMA=0.0D0 + IF(IAPROX.LE.1) THEN +* P0 OR P1 APPROXIMATION + B1GAMA=1.0D0 + ELSE IF(IAPROX.EQ.2) THEN +* B0 OR B1 APPROXIMATION + IF(B2.EQ.0.0) THEN + B1GAMA=1.0D0 + ELSE IF(B2.GT.0.05D0*SIG2) THEN + TMP=SQRT(B2)/SIG + BBS=SIG/SQRT(B2) + ATG=ATAN(TMP) + B1GAMA=ATG/(3.0D0*BBS*(1.0D0-BBS*ATG)) + ELSE IF((B2.LE.0.05D0*SIG2).AND.(B2.GE.-0.05D0*SIG2)) THEN + TMP=B2/SIG2 + B1GAMA=1.0D0+TMP*(4.0D0/15.0D0-12.0D0*TMP/175.0D0 + 1 +92.0D0*TMP*TMP/2625.0D0) + ELSE IF((B2.LT.-0.05D0*SIG2).AND.(B2.GE.-B2LIM*SIG2)) THEN + TMP=SQRT(-B2) + SB=SIG/TMP + BLN=0.5D0*LOG((SIG+TMP)/(SIG-TMP)) + B1GAMA=BLN/(3.0D0*SB*(SB*BLN-1.0D0)) + ELSE IF(B2.LT.-B2LIM*SIG2) THEN +* Pn-type fundamental mode extension for extreme subcritical +* cases + TMP2=SQRT(B2LIM*SIG2) + ALPHA1=0.5D0*LOG((SIG+TMP2)/(SIG-TMP2))/TMP2 + ALPHA2=3.0D0*SIG/(3.0D0*SIG2-B2LIM*SIG2) + ALPHA3=3.0D0*SIG/(3.0D0*SIG2+B2) + B1BETA=(1.0D0-(ALPHA1-ALPHA2+ALPHA3)*SIG)/B2 + B1GAMA=(ALPHA1-ALPHA2+ALPHA3)/(3.0D0*SIG*B1BETA) + ENDIF + ELSE + CALL XABORT('B1GAMA: INVALID VALUE OF IAPROX.') + ENDIF + RETURN + END diff --git a/Dragon/src/B1HOM.f b/Dragon/src/B1HOM.f new file mode 100644 index 0000000..b17afaf --- /dev/null +++ b/Dragon/src/B1HOM.f @@ -0,0 +1,221 @@ +*DECK B1HOM + SUBROUTINE B1HOM (IPMACR,LEAKSW,NUNKNO,OPTION,TYPE,NGRO,IPAS,NBM, + 1 NFISSI,VOL,MAT,KEYFLX,FLUX,REFKEF,IMPX,DHOM, + 2 GAMMA,ALAM1,INORM,B2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Homogenization of the unit cell and solution of the B-n equations in +* fundamental mode condition. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMACR pointer to the macrolib LCM object (L_MACROLIB signature). +* LEAKSW leakage flag (=.TRUE. if leakage is present on the outer +* surface). +* NUNKNO number of flux/current unknowns. +* OPTION type of leakage coefficients; can be 'LKRD' (recover leakage +* coefficients in Macrolib), 'RHS' (recover leakage coefficients +* in RHS flux object), 'B0' (B-0), 'P0' (P-0), 'B1' (B-1), +* 'P1' (P-1), 'B0TR' (B-0 with transport correction) or 'P0TR' +* (P-0 with transport correction). +* TYPE type of buckling iteration. +* Can be 'DIFF' (do a B-0 calculation of DHOM(NGRO) and exit); +* 'K' (do a B-n calculation with keff search); +* 'B' (do a B-n calculation with buckling search); +* 'L' (do a B-n calculation with buckling search +* for a problem with few or no fission). +* NGRO number of groups. +* IPAS number of volumes. +* NBM number of mixtures. +* NFISSI maximum number of fission spectrum assigned to a mixture. +* VOL volumes. +* MAT mixture number of each volume. +* KEYFLX position of each flux in the unknown vector. +* FLUX direct unknown vector. +* REFKEF target K-effective for type B or type L calculations. +* IMPX print flag. +* INORM type of leakage model: +* =1: Diffon; =2: Ecco; =3: Tibere. +* B2 original direction dependant buckling. +* +*Parameters: output +* DHOM homogeneous leakage coefficients. +* GAMMA gamma factors. +* ALAM1 effective multiplication factor. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER*4 OPTION,TYPE + TYPE(C_PTR) IPMACR + LOGICAL LEAKSW + INTEGER NUNKNO,NGRO,IPAS,NBM,NFISSI,MAT(IPAS),KEYFLX(IPAS),IMPX, + 1 INORM + REAL VOL(IPAS),FLUX(NUNKNO,NGRO,2),DHOM(NGRO),GAMMA(NGRO),B2(4) + DOUBLE PRECISION REFKEF,ALAM1 +*---- +* LOCAL VARIABLES +*---- + INTEGER IDEL(2) + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ0,IJJ1,NJJ0,NJJ1 + REAL, ALLOCATABLE, DIMENSION(:) :: ST,SA,SFNU,XHI,SCAT0,SCAT1,FL2 + DOUBLE PRECISION B2HOM,CAET,A2,CURN,B2T(3) + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: PHI +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(PHI(NGRO)) +* + IF(LEAKSW) CALL XABORT('B1HOM: FUNDAMENTAL MODE EXPECTED.') + IAN=0 + IF ((OPTION.EQ.'B0').OR.(OPTION.EQ.'P0')) THEN + IAN=0 + ELSE IF ((OPTION.EQ.'B1').OR.(OPTION.EQ.'P1')) THEN + IAN=1 + ELSE IF ((OPTION.EQ.'B0TR').OR.(OPTION.EQ.'P0TR')) THEN + IAN=-1 + ENDIF + ALLOCATE(IJJ0(NGRO),IJJ1(NGRO),NJJ0(NGRO),NJJ1(NGRO)) + CALL B1HXS1(IPMACR,NGRO,NBM,IAN,NFISSI,IJJ0,IJJ1,NJJ0,NJJ1,IDEL) +* + ALLOCATE(ST(NGRO),SA(NGRO),SFNU(NGRO),XHI(NGRO),SCAT0(IDEL(1)), + 1 SCAT1(IDEL(2))) + IF(INORM.EQ.2) THEN +* ECCO-TYPE ISOTROPIC STREAMING. + CALL B1HXS3(NUNKNO,IPMACR,IPAS,NGRO,NBM,IAN,VOL,MAT,KEYFLX, + 1 FLUX(1,1,1),IJJ0,IJJ1,NJJ0,NJJ1,IDEL,PHI,ST,SCAT0,SCAT1,NGROIN) + ELSE IF(INORM.EQ.3) THEN +* TIBERE-TYPE ANISOTROPIC STREAMING. + IF(B2(4).EQ.0.0) THEN + B2T(1)=0.33333333333333D0 + B2T(2)=B2T(1) + B2T(3)=B2T(1) + ELSE + B2T(1)=DBLE(B2(1))/DBLE(B2(4)) + B2T(2)=DBLE(B2(2))/DBLE(B2(4)) + B2T(3)=DBLE(B2(3))/DBLE(B2(4)) + ENDIF + ALLOCATE(FL2(2*NUNKNO*NGRO)) + IOF=0 + DO 30 IGRO=1,NGRO + DO 10 IUNK=1,NUNKNO/4 + IOF=IOF+1 + FL2(IOF)=FLUX(IUNK,IGRO,1) + 10 CONTINUE + DO 20 IUNK=1,NUNKNO/4 + IOF=IOF+1 + CURN=0.0D0 + DO 15 IDIR=1,3 + CURN=CURN+B2T(IDIR)*FLUX(NUNKNO/4*IDIR+IUNK,IGRO,1) + 15 CONTINUE + FL2(IOF)=REAL(CURN) + 20 CONTINUE + 30 CONTINUE + CALL B1HXS3(NUNKNO/2,IPMACR,IPAS,NGRO,NBM,IAN,VOL,MAT,KEYFLX, + 1 FL2(1),IJJ0,IJJ1,NJJ0,NJJ1,IDEL,PHI,ST,SCAT0,SCAT1,NGROIN) + DEALLOCATE(FL2) + ENDIF + CALL B1HXS2(NUNKNO,IPMACR,IPAS,NGRO,NBM,IAN,NFISSI,VOL,MAT, + 1 KEYFLX,FLUX,LFISSI,IJJ0,IJJ1,NJJ0,NJJ1,IDEL,PHI,SA,ST,SFNU, + 2 XHI,SCAT0,SCAT1,NGROIN,INORM) +* + B2OLD=B2(4) + B2HOM=DBLE(B2OLD) + CALL B1DIF(OPTION,TYPE,NGRO,ST,SFNU,XHI,IJJ0,IJJ1,NJJ0,NJJ1,SCAT0, + 1 SCAT1,REFKEF,LFISSI,IMPX,DHOM,GAMMA,B2HOM,ALAM1,CAET,A2,PHI) + B2(4)=REAL(B2HOM) +* + IF (TYPE.EQ.'DIFF') GO TO 130 +*---- +* CORRECT THE SOURCES WITH THE NEW BUCKLING +*---- + DO 35 L=1,NUNKNO + DO 34 I=1,NGRO + FLUX(L,I,2)=FLUX(L,I,2)+(B2(4)-B2OLD)*DHOM(I)*FLUX(L,I,1) + 34 CONTINUE + 35 CONTINUE +*---- +* NORMALIZE THE DRAGON FLUX USING THE FUNDAMENTAL B1 SOLUTION +*---- + IF(INORM.EQ.1) THEN + DO 60 I=1,NGRO + CAET=0.0D0 + DO 40 L=1,IPAS + CAET=CAET+VOL(L)*FLUX(KEYFLX(L),I,1) + 40 CONTINUE + CAET=PHI(I)/CAET + DO 50 L=1,NUNKNO + FLUX(L,I,:2)=FLUX(L,I,:2)*REAL(CAET) + 50 CONTINUE + 60 CONTINUE + ELSE IF(INORM.EQ.2) THEN + DO 90 I=1,NGRO + CAET=0.0D0 + CURN=0.0D0 + DO 70 L=1,IPAS + CAET=CAET+VOL(L)*FLUX(KEYFLX(L),I,1) + CURN=CURN+VOL(L)*FLUX(KEYFLX(L)+NUNKNO/2,I,1) + 70 CONTINUE + CAET=PHI(I)/CAET + CURN=PHI(I)*DHOM(I)/CURN + DO 80 L=1,NUNKNO/2 + FLUX(L,I,:2)=FLUX(L,I,:2)*REAL(CAET) + FLUX(L+NUNKNO/2,I,:2)=FLUX(L+NUNKNO/2,I,:2)*REAL(CURN) + 80 CONTINUE + 90 CONTINUE + ELSE IF(INORM.EQ.3) THEN + IF(B2(4).EQ.0.0.OR. + > (B2(1).EQ.0.0.AND.B2(2).EQ.0.0.AND.B2(3).EQ.0.0)) THEN + B2T(1)=0.33333333333333D0 + B2T(2)=B2T(1) + B2T(3)=B2T(1) + ELSE + B2HOM=1.0D0/(DBLE(B2(1))+DBLE(B2(2))+DBLE(B2(3))) + B2T(1)=B2HOM*DBLE(B2(1)) + B2T(2)=B2HOM*DBLE(B2(2)) + B2T(3)=B2HOM*DBLE(B2(3)) + ENDIF + DO 120 I=1,NGRO + CAET=0.0D0 + CURN=0.0D0 + DO 100 L=1,IPAS + CAET=CAET+VOL(L)*FLUX(KEYFLX(L),I,1) + CURN=CURN+B2T(1)*FLUX(KEYFLX(L)+NUNKNO/4,I,1)*VOL(L) + > +B2T(2)*FLUX(KEYFLX(L)+NUNKNO/2,I,1)*VOL(L) + > +B2T(3)*FLUX(KEYFLX(L)+3*NUNKNO/4,I,1)*VOL(L) + 100 CONTINUE + CAET=PHI(I)/CAET + CURN=PHI(I)*DHOM(I)/CURN + DO 110 L=1,IPAS + FLUX(KEYFLX(L),I,:2)=FLUX(KEYFLX(L),I,:2)*REAL(CAET) + FLUX(KEYFLX(L)+NUNKNO/4,I,:2)= + 1 FLUX(KEYFLX(L)+NUNKNO/4,I,:2)*REAL(CURN) + FLUX(KEYFLX(L)+NUNKNO/2,I,:2)= + 1 FLUX(KEYFLX(L)+NUNKNO/2,I,:2)*REAL(CURN) + FLUX(KEYFLX(L)+3*NUNKNO/4,I,:2)= + 1 FLUX(KEYFLX(L)+3*NUNKNO/4,I,:2)*REAL(CURN) + 110 CONTINUE + 120 CONTINUE + ENDIF +* + 130 DEALLOCATE(SCAT1,SCAT0,XHI,SFNU,SA,ST) + DEALLOCATE(NJJ1,NJJ0,IJJ1,IJJ0) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(PHI) + RETURN + END diff --git a/Dragon/src/B1HXS1.f b/Dragon/src/B1HXS1.f new file mode 100644 index 0000000..3658cba --- /dev/null +++ b/Dragon/src/B1HXS1.f @@ -0,0 +1,447 @@ +*DECK B1HXS1 + SUBROUTINE B1HXS1(IPMACR,NGRO,NBM,IAN,NFISSI,IJJ0,IJJ1,NJJ0,NJJ1, + 1 IDEL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Homogenization of the lattice cell nuclear properties before a B-n +* calculation. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMACR pointer to the macrolib LCM object (L_MACROLIB signature). +* NGRO number of groups. +* NBM number of mixtures. +* IAN type of homogenization: +* =-1: transport corrected P0; =0: P0; =1: P1. +* NFISSI maximum number of fission spectrum assigned to a mixture. +* NUNKNO number of flux/current unknowns. +* IPAS number of volumes. +* VOL volumes. +* MAT mixture number of each volume. +* KEYFLX position of each flux in the unknown vector. +* FLUX direct unknown vector. +* INORM type of leakage model: +* =1: Diffon; =2: Ecco; =3: Tibere. +* +*Parameters: output +* IJJ0 most thermal group in band for P0 scattering. +* NJJ0 number of groups in band for P0 scattering. +* IJJ1 most thermal group in band for P1 scattering. +* NJJ1 number of groups in band for P1 scattering. +* IDEL dimension of matrices SCAT0 and SCAT1. +* FLXIN integrated fluxes. +* SA absorption macroscopic cross sections. +* ST total macroscopic cross sections. +* SFNU nu * macroscopic fission cross-sections. +* XHI fission spectrum. +* SCAT0 packed diffusion P0 macroscopic cross sections. +* SCAT1 packed diffusion P1 macroscopic cross sections. +* NGROIN number of groups without up-scattering. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMACR + INTEGER NGRO,NBM,IAN,NFISSI,IJJ0(NGRO),IJJ1(NGRO),NJJ0(NGRO), + 1 NJJ1(NGRO),IDEL(2) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + TYPE(C_PTR) JPMACR,KPMACR + LOGICAL LOGIC + CHARACTER CM*2 + INTEGER IDATA(NSTATE) + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ +*---- +* SCRATCH STORAGE ALLOCATION +* IJJ last scattering group (IJJ(0) = 0). +* NJJ number of scattering group (NJJ(0)=-NGROUP). +*---- + ALLOCATE(IJJ(0:NBM),NJJ(0:NBM)) +* + CALL LCMGET(IPMACR,'STATE-VECTOR',IDATA) + LOGIC=(NGRO.EQ.IDATA(1)).AND.(NBM.EQ.IDATA(2)).AND.(NFISSI.EQ. + 1 IDATA(4)).AND.(IDATA(3).GE.1) + IF(.NOT.LOGIC) CALL XABORT('B1HXS1: INCONSISTENT LCM FILE.') + IANN=IAN + IF(IAN.LT.0) IANN=-(IAN+1) + IDEL(1)=0 + IDEL(2)=0 + JPMACR=LCMGID(IPMACR,'GROUP') + DO 30 LLL=1,NGRO + KPMACR=LCMGIL(JPMACR,LLL) + DO 20 M=0,IANN + WRITE (CM,'(I2.2)') M + CALL LCMLEN(KPMACR,'NJJS'//CM,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 20 + CALL LCMGET(KPMACR,'NJJS'//CM,NJJ(1)) + CALL LCMGET(KPMACR,'IJJS'//CM,IJJ(1)) + IMAX=1 + IMIN=NGRO + DO 10 I=1,NBM + IMAX=MAX(IJJ(I),IMAX) + IMIN=MIN(IJJ(I)-NJJ(I)+1,IMIN) + 10 CONTINUE + IF(M.EQ.0) THEN + IJJ0(LLL)=IMAX + NJJ0(LLL)=IMAX-IMIN+1 + ELSE IF(M.EQ.1) THEN + IJJ1(LLL)=IMAX + NJJ1(LLL)=IMAX-IMIN+1 + ENDIF + IDEL(M+1)=IDEL(M+1)+IMAX-IMIN+1 + 20 CONTINUE + 30 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(NJJ,IJJ) + RETURN + END +* + SUBROUTINE B1HXS2(NUNKNO,IPMACR,IPAS,NGRO,NBM,IAN,NFISSI,VOL,MAT, + 1 KEYFLX,FLUX,LFISSI,IJJ0,IJJ1,NJJ0,NJJ1,IDEL,FLXIN,SA,ST,SFNU,XHI, + 2 SCAT0,SCAT1,NGROIN,INORM) +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMACR + INTEGER NUNKNO,IPAS,NGRO,NBM,IAN,NFISSI,MAT(IPAS),KEYFLX(IPAS), + 1 IJJ0(NGRO),IJJ1(NGRO),NJJ0(NGRO),NJJ1(NGRO),IDEL(2),NGROIN,INORM + REAL VOL(IPAS),FLUX(NUNKNO,NGRO),SA(NGRO),ST(NGRO),SFNU(NGRO), + 1 XHI(NGRO),SCAT0(IDEL(1)),SCAT1(IDEL(2)) + DOUBLE PRECISION FLXIN(NGRO) + LOGICAL LFISSI +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPMACR,KPMACR + LOGICAL LOGIC + CHARACTER CM*2 + DOUBLE PRECISION SUM,A11,A13 + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) :: XSCAT,GAR,GARFI + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: GAF + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: A14 +*---- +* SCRATCH STORAGE ALLOCATION +* XSCAT scattering vector (XSCAT(0)=0.0). +* IJJ last scattering group (IJJ(0) = 0). +* NJJ number of scattering group (NJJ(0)=-NGROUP). +* IPOS position self scattering in XSCAT (IPOS(0)=NGROUP+1). +*---- + ALLOCATE(IJJ(0:NBM),NJJ(0:NBM),IPOS(0:NBM)) + ALLOCATE(XSCAT(0:NBM*NGRO),GAR(0:NBM),GARFI(0:NBM*NFISSI)) + ALLOCATE(A14(NFISSI,0:NBM),GAF(NGRO)) +* + IANN=IAN + IF(IAN.LT.0) IANN=-(IAN+1) + NGROIN=0 + SUM=0.0D0 + A13=0.0D0 + DO 45 NF=1,NFISSI + DO 40 IBM=1,NBM + A14(NF,IBM)=0.0D0 + 40 CONTINUE + 45 CONTINUE + JPMACR=LCMGID(IPMACR,'GROUP') + LFISSI=.FALSE. + IF(NFISSI.GT.0) THEN + DO 62 LLL=1,NGRO + KPMACR=LCMGIL(JPMACR,LLL) + A13=0.0D0 + CALL LCMGET(KPMACR,'NUSIGF',GARFI(1)) + DO 61 NF=1,NFISSI + DO 60 I=1,IPAS + IBM=MAT(I) + IF(IBM.GT.0) THEN + IF(GARFI((NF-1)*NBM+IBM).NE.0.0) LFISSI=.TRUE. + A14(NF,IBM)=A14(NF,IBM)+FLUX(KEYFLX(I),LLL)*VOL(I)* + 1 GARFI((NF-1)*NBM+IBM) + ENDIF + 60 CONTINUE + 61 CONTINUE + 62 CONTINUE + DO 75 NF=1,NFISSI + DO 70 IBM=1,NBM + A13=A13+A14(NF,IBM) + 70 CONTINUE + 75 CONTINUE + ENDIF +* + IF(INORM.EQ.1) THEN + DO 85 LLL=1,NGRO + A11=0.0D0 + DO 80 I=1,IPAS + A11=A11+FLUX(KEYFLX(I),LLL)*VOL(I) + 80 CONTINUE + FLXIN(LLL)=A11 + 85 CONTINUE + IDEL(1)=0 + IDEL(2)=0 + ENDIF +* + DO 200 LLL=1,NGRO + KPMACR=LCMGIL(JPMACR,LLL) + IF(LFISSI) THEN + A11=0.0D0 + CALL LCMGET(KPMACR,'NUSIGF',GARFI(1)) + DO 95 NF=1,NFISSI + DO 90 I=1,IPAS + IBM=MAT(I) + IF(IBM.GT.0) A11=A11+FLUX(KEYFLX(I),LLL)*VOL(I)* + 1 GARFI((NF-1)*NBM+IBM) + 90 CONTINUE + 95 CONTINUE + SFNU(LLL)=REAL(A11/FLXIN(LLL)) + ELSE + SFNU(LLL)=0.0 + ENDIF +* + GAR(0)=0.0 + IF(INORM.EQ.1) THEN + CALL LCMGET(KPMACR,'NTOT0',GAR(1)) + A11=0.0D0 + DO 100 I=1,IPAS + A11=A11+FLUX(KEYFLX(I),LLL)*VOL(I)*GAR(MAT(I)) + 100 CONTINUE + ST(LLL)=REAL(A11/FLXIN(LLL)) + ELSE + A11=ST(LLL)*FLXIN(LLL) + ENDIF +* + CALL LCMGET(KPMACR,'SIGS00',GAR(1)) + DO 110 I=1,IPAS + A11=A11-FLUX(KEYFLX(I),LLL)*VOL(I)*GAR(MAT(I)) + 110 CONTINUE + SA(LLL)=REAL(A11/FLXIN(LLL)) +* + IF(LFISSI) THEN + A11=0.0D0 + CALL LCMGET(KPMACR,'CHI',GARFI(1)) + DO 125 NF=1,NFISSI + DO 120 IBM=1,NBM + A11=A11+A14(NF,IBM)*GARFI((NF-1)*NBM+IBM) + 120 CONTINUE + 125 CONTINUE + XHI(LLL)=REAL(A11/A13) + SUM=SUM+XHI(LLL) + ELSE + XHI(LLL)=0.0 + ENDIF + IF(INORM.EQ.1) THEN +*---- +* TRANSPORT CORRECTION +*---- + A11=0.0D0 + IF(IAN.EQ.-1) THEN + GAR(0)=0.0 + CALL LCMGET(KPMACR,'SIGS01',GAR(1)) + DO 130 I=1,IPAS + A11=A11+FLUX(KEYFLX(I),LLL)*VOL(I)*GAR(MAT(I)) + 130 CONTINUE + ST(LLL)=ST(LLL)-REAL(A11/FLXIN(LLL)) + ENDIF +* + DO 190 M=0,IANN + WRITE (CM,'(I2.2)') M + DO 140 IG=1,NGRO + GAF(IG)=0.0D0 + 140 CONTINUE + CALL LCMLEN(KPMACR,'NJJS'//CM,ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPMACR,'NJJS'//CM,NJJ(1)) + CALL LCMGET(KPMACR,'IJJS'//CM,IJJ(1)) + CALL LCMGET(KPMACR,'IPOS'//CM,IPOS(1)) + CALL LCMGET(KPMACR,'SCAT'//CM,XSCAT(1)) + DO 160 I=1,IPAS + IBM=MAT(I) + IF(IBM.EQ.0) GO TO 160 + DO 150 IG=IJJ(IBM)-NJJ(IBM)+1,IJJ(IBM) + IGAR=IPOS(IBM)+IJJ(IBM)-IG + GAF(IG)=GAF(IG)+FLUX(KEYFLX(I),IG)*VOL(I)*XSCAT(IGAR) + 150 CONTINUE + IF(IAN.EQ.-1) THEN + IGAR=IPOS(IBM)+IJJ(IBM)-LLL + GAF(LLL)=GAF(LLL)-FLUX(KEYFLX(I),LLL)*VOL(I)*GAR(IBM) + ENDIF + 160 CONTINUE + ENDIF + IF(M.EQ.0) THEN + DO 170 IG=IJJ0(LLL)-NJJ0(LLL)+1,IJJ0(LLL) + IGAR=IDEL(1)+1+IJJ0(LLL)-IG + SCAT0(IGAR)=REAL(GAF(IG)/FLXIN(IG)) + 170 CONTINUE + IDEL(1)=IDEL(1)+NJJ0(LLL) + ELSE IF(M.EQ.1) THEN + DO 180 IG=IJJ1(LLL)-NJJ1(LLL)+1,IJJ1(LLL) + IGAR=IDEL(2)+1+IJJ1(LLL)-IG + SCAT1(IGAR)=REAL(GAF(IG)/FLXIN(IG)) + 180 CONTINUE + IDEL(2)=IDEL(2)+NJJ1(LLL) + ENDIF + 190 CONTINUE + LOGIC=(IJJ0(LLL).LE.LLL).AND.(NGROIN.EQ.LLL-1) + IF(IANN.GE.1) LOGIC=LOGIC.AND.(IJJ1(LLL).LE.LLL) + IF(LOGIC) NGROIN=LLL + ENDIF + 200 CONTINUE + IF((ABS(1.0D0-SUM).GT.1.0D-3).AND.LFISSI) THEN + CALL XABORT('B1HXS2: INCONSISTENT FISSION SPECTRUM.') + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GAF,A14) + DEALLOCATE(GARFI,GAR,XSCAT) + DEALLOCATE(IPOS,NJJ,IJJ) + RETURN + END +* + SUBROUTINE B1HXS3(NUNKNO,IPMACR,IPAS,NGRO,NBM,IAN,VOL,MAT, + 1 KEYFLX,FLUX,IJJ0,IJJ1,NJJ0,NJJ1,IDEL,FLXIN,ST,SCAT0,SCAT1, + 2 NGROIN) +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMACR + INTEGER NUNKNO,IPAS,NGRO,NBM,IAN,MAT(IPAS),KEYFLX(IPAS), + 1 IJJ0(NGRO),IJJ1(NGRO),NJJ0(NGRO),NJJ1(NGRO),IDEL(2),NGROIN + REAL VOL(IPAS),FLUX(NUNKNO,NGRO),ST(NGRO),SCAT0(IDEL(1)), + 1 SCAT1(IDEL(2)) + DOUBLE PRECISION FLXIN(NGRO) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPMACR,KPMACR + LOGICAL LOGIC + CHARACTER CM*2 + DOUBLE PRECISION A11,A13 + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) :: XSCAT,GAR + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: GAF,CUR +*---- +* SCRATCH STORAGE ALLOCATION +* XSCAT scattering vector (XSCAT(0)=0.0). +* IJJ last scattering group (IJJ(0) = 0). +* NJJ number of scattering group (NJJ(0)=-NGROUP). +* IPOS position self scattering in XSCAT (IPOS(0)=NGROUP+1). +*---- + ALLOCATE(IJJ(0:NBM),NJJ(0:NBM),IPOS(0:NBM)) + ALLOCATE(XSCAT(0:NBM*NGRO),GAR(0:NBM)) + ALLOCATE(GAF(NGRO),CUR(NGRO)) +* + IANN=IAN + IF(IAN.LT.0) IANN=-(IAN+1) + NGROIN=0 +*---- +* FIND HOMOGENISED FLUX AND CURRENTS +*---- + DO 305 LLL=1,NGRO + FLXIN(LLL)=0.0D0 + DO 300 I=1,IPAS + FLXIN(LLL)=FLXIN(LLL)+FLUX(KEYFLX(I),LLL)*VOL(I) + 300 CONTINUE + 305 CONTINUE + DO 320 LLL=1,NGRO + CUR(LLL)=0.0D0 + A13=0.0D0 + DO 310 I=1,IPAS + A13=A13+FLUX(NUNKNO/2+KEYFLX(I),LLL)*VOL(I) + 310 CONTINUE + CUR(LLL)=CUR(LLL)+A13 + 320 CONTINUE +* + IDEL(1)=0 + IDEL(2)=0 + JPMACR=LCMGID(IPMACR,'GROUP') + DO 410 LLL=1,NGRO + KPMACR=LCMGIL(JPMACR,LLL) + GAR(0)=0.0 + CALL LCMGET(KPMACR,'NTOT0',GAR(1)) + A11=0.0D0 + DO 330 I=1,IPAS + A11=A11+FLUX(KEYFLX(I),LLL)*VOL(I)*GAR(MAT(I)) + 330 CONTINUE + ST(LLL)=REAL(A11/FLXIN(LLL)) + A11=ST(LLL)*CUR(LLL) + DO 340 I=1,IPAS + A11=A11-VOL(I)*GAR(MAT(I))*FLUX(NUNKNO/2+KEYFLX(I),LLL) + 340 CONTINUE +* + DO 400 M=0,IANN + WRITE (CM,'(I2.2)') M + DO 350 IG=1,NGRO + GAF(IG)=0.0D0 + 350 CONTINUE + CALL LCMLEN(KPMACR,'NJJS'//CM,ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPMACR,'NJJS'//CM,NJJ(1)) + CALL LCMGET(KPMACR,'IJJS'//CM,IJJ(1)) + CALL LCMGET(KPMACR,'IPOS'//CM,IPOS(1)) + CALL LCMGET(KPMACR,'SCAT'//CM,XSCAT(1)) + IF(M.EQ.0) THEN + DO 365 I=1,IPAS + IBM=MAT(I) + IF(IBM.EQ.0) GO TO 365 + DO 360 IG=IJJ(IBM)-NJJ(IBM)+1,IJJ(IBM) + IGAR=IPOS(IBM)+IJJ(IBM)-IG + GAF(IG)=GAF(IG)+FLUX(KEYFLX(I),IG)*VOL(I)*XSCAT(IGAR) + 360 CONTINUE + 365 CONTINUE + ELSE IF(M.EQ.1) THEN + DO 375 I=1,IPAS + IBM=MAT(I) + IF(IBM.EQ.0) GO TO 375 + DO 370 IG=IJJ(IBM)-NJJ(IBM)+1,IJJ(IBM) + IGAR=IPOS(IBM)+IJJ(IBM)-IG + GAF(IG)=GAF(IG)+VOL(I)*XSCAT(IGAR)*FLUX(NUNKNO/2+KEYFLX(I),IG) + 370 CONTINUE + 375 CONTINUE + GAF(LLL)=GAF(LLL)+A11 + ENDIF + ENDIF + IF(M.EQ.0) THEN + DO 380 IG=IJJ0(LLL)-NJJ0(LLL)+1,IJJ0(LLL) + IGAR=IDEL(1)+1+IJJ0(LLL)-IG + SCAT0(IGAR)=REAL(GAF(IG)/FLXIN(IG)) + 380 CONTINUE + IDEL(1)=IDEL(1)+NJJ0(LLL) + ELSE IF(M.EQ.1) THEN + DO 390 IG=IJJ1(LLL)-NJJ1(LLL)+1,IJJ1(LLL) + IGAR=IDEL(2)+1+IJJ1(LLL)-IG + SCAT1(IGAR)=REAL(GAF(IG)/CUR(IG)) + 390 CONTINUE + IDEL(2)=IDEL(2)+NJJ1(LLL) + ENDIF + 400 CONTINUE + LOGIC=(IJJ0(LLL).LE.LLL).AND.(NGROIN.EQ.LLL-1) + IF(IANN.GE.1) LOGIC=LOGIC.AND.(IJJ1(LLL).LE.LLL) + IF(LOGIC) NGROIN=LLL + 410 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(CUR,GAF) + DEALLOCATE(GAR,XSCAT) + DEALLOCATE(IPOS,NJJ,IJJ) + RETURN + END diff --git a/Dragon/src/B1SOL.f b/Dragon/src/B1SOL.f new file mode 100644 index 0000000..00598bd --- /dev/null +++ b/Dragon/src/B1SOL.f @@ -0,0 +1,65 @@ +*DECK B1SOL + SUBROUTINE B1SOL(NGRO,B,IER) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of a system of linear equations that appear in a B1 method. +* Use ALSBD.f for solution in thermal groups. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NGRO order of the coefficient matrix. +* +*Parameters: input/output +* B coefficient matrix augmented with the right hand vector on +* input and solution vector, starting at B(1,NGRO+1) at output. +* +*Parameters: output +* IER error flag (execution failure if IER.ne.0). +* +*----------------------------------------------------------------------- +* + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NGRO,IER + DOUBLE PRECISION B(NGRO,NGRO+1) +* + IER=0 + NGROIN=0 + DO 30 I=1,NGRO + DO 10 J=I+1,NGRO + IF(B(I,J).NE.0.0D0) GO TO 40 + 10 CONTINUE + NGROIN=I + IF(B(I,I).EQ.0.0D0) THEN + IER=-1 + RETURN + ENDIF + ZGAR=B(I,NGRO+1) + DO 20 J=1,I-1 + ZGAR=ZGAR-B(I,J)*B(J,NGRO+1) + 20 CONTINUE + B(I,NGRO+1)=ZGAR/B(I,I) + 30 CONTINUE + 40 IF(NGROIN.EQ.NGRO) RETURN + DO 60 I=NGROIN+1,NGRO + ZGAR=B(I,NGRO+1) + DO 50 J=1,NGROIN + ZGAR=ZGAR-B(I,J)*B(J,NGRO+1) + 50 CONTINUE + B(I,NGRO+1)=ZGAR + 60 CONTINUE + CALL ALSBD(NGRO-NGROIN,1,B(NGROIN+1,NGROIN+1),IER,NGRO) + RETURN + END diff --git a/Dragon/src/BIVAA.f b/Dragon/src/BIVAA.f new file mode 100644 index 0000000..bc80653 --- /dev/null +++ b/Dragon/src/BIVAA.f @@ -0,0 +1,149 @@ +*DECK BIVAA + SUBROUTINE BIVAA(IPSYS,IPTRK,IMPX,NREG,NBMIX,NANI,NW,MAT,VOL, + 1 SIGT0,SIGW0,DIFF) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of one-speed finite-difference or finite-element matrices +* for a discretization of the 2D diffusion equation. +* +*Copyright: +* Copyright (C) 2004 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPSYS pointer to the system matrices. +* IPTRK pointer to the tracking (L_TRACK signature). +* IMPX print flag (equal to zero for no print). +* NREG total number of merged regions for which specific values +* of the neutron flux and reaction rates are required. +* NBMIX number of mixtures. +* NANI number of Legendre orders for the scattering cross sections. +* NW type of weighting for P1 cross section info (=0: P0 ; =1: P1). +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* SIGT0 P0 and P1 total macroscopic cross sections ordered by mixture. +* SIGW0 within-group scattering macroscopic cross section ordered +* by mixture. +* DIFF diffusion coefficients ordered by mixture. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSYS,IPTRK + INTEGER IMPX,NREG,NBMIX,NANI,NW,MAT(NREG) + REAL VOL(NREG),SIGT0(0:NBMIX,NW+1),SIGW0(0:NBMIX,NANI), + 1 DIFF(0:NBMIX) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + INTEGER JPAR(NSTATE),IGB(8) + LOGICAL LBIHET + CHARACTER NAMP*12,TEXT10*10 + REAL, ALLOCATABLE, DIMENSION(:) :: GAMMA + REAL, ALLOCATABLE, DIMENSION(:,:) :: SGD + PARAMETER(TEXT10='A001001') +*---- +* RECOVER BIVAC SPECIFIC TRACKING PARAMETERS. +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',JPAR) + LBIHET=JPAR(40).NE.0 + IF(LBIHET) THEN + CALL LCMSIX(IPTRK,'BIHET',1) + CALL LCMGET(IPTRK,'PARAM',IGB) + IF(NREG.NE.IGB(3)) CALL XABORT('BIVAA: INVALID VALUE OF NREG(' + 1 //'1).') + CALL LCMSIX(IPTRK,' ',2) + ELSE + IF(NREG.NE.JPAR(1)) CALL XABORT('BIVAA: INVALID VALUE OF NREG' + 1 //'(2).') + ENDIF + NLF=JPAR(14) + ISCAT=ABS(JPAR(16)) +*---- +* RECOVER PHYSICAL ALBEDO FUNCTIONS. +*---- + CALL LCMLEN(IPSYS,'ALBEDO-FU',NALBP,ITYLCM) + IF(NALBP.GT.0) THEN + ALLOCATE(GAMMA(NALBP)) + CALL LCMGET(IPSYS,'ALBEDO-FU',GAMMA) + ENDIF +*---- +* COMPUTE THE WITHIN-GROUP SYSTEM MATRICES (LEAKAGE AND REMOVAL). +*---- + IF(NLF.EQ.0) THEN +*---- +* ++++ DIFFUSION THEORY ++++ +*---- + IF(NANI.GT.1) THEN + CALL XABORT('BIVAA: SPN MACRO-CALCULATION EXPECTED(1).') + ENDIF + ALLOCATE(SGD(NBMIX,3)) + DO 10 IBM=1,NBMIX + SGD(IBM,1)=DIFF(IBM) + SGD(IBM,2)=DIFF(IBM) + SGD(IBM,3)=SIGT0(IBM,1)-SIGW0(IBM,1) + 10 CONTINUE +*---- +* ASSEMBLING OF A SINGLE-GROUP SYSTEM MATRIX FOR BIVAC. +*---- + CALL BIVASM(TEXT10,0,IPTRK,IPSYS,IMPX,NBMIX,NREG,NLF,3,NALBP, + 1 MAT,VOL,GAMMA,SGD) + DEALLOCATE(SGD) + ELSE +*---- +* ++++ PN OR SPN THEORY ++++ +*---- + IF(NLF.LT.2) THEN + CALL XABORT('BIVAA: PN OR SPN KEYWORD EXPECTED.') + ENDIF + NAN=MIN(ISCAT,NANI)+1 + ALLOCATE(SGD(NBMIX,2*NAN)) + DO 30 IL=0,NAN-1 + DO 20 IBM=1,NBMIX + IF(IL.LE.NW) THEN + GARS=SIGT0(IBM,IL+1) + ELSE IF((NW.GE.1).AND.(MOD(IL,2).EQ.1)) THEN + GARS=SIGT0(IBM,2) + ELSE + GARS=SIGT0(IBM,1) + ENDIF + IF(IL.LE.NAN-2) GARS=GARS-SIGW0(IBM,IL+1) + SGD(IBM,IL+1)=GARS + IF(GARS.NE.0.0) THEN + SGD(IBM,NAN+IL+1)=1.0/GARS + ELSE + SGD(IBM,NAN+IL+1)=1.0E10 + ENDIF + 20 CONTINUE + WRITE(NAMP,'(4HSCAR,I2.2,6H001001)') IL + CALL LCMPUT(IPSYS,NAMP,NBMIX,2,SGD(1,NAN+IL+1)) + WRITE(NAMP,'(4HSCAI,I2.2,6H001001)') IL + CALL LCMPUT(IPSYS,NAMP,NBMIX,2,SGD(1,NAN+IL+1)) + 30 CONTINUE + JPAR(:NSTATE)=0 + JPAR(7)=NBMIX + JPAR(8)=NAN + CALL LCMPUT(IPSYS,'STATE-VECTOR',NSTATE,1,JPAR) +*---- +* ASSEMBLING OF A SINGLE-GROUP SYSTEM MATRIX FOR BIVAC. +*---- + CALL BIVASM(TEXT10,0,IPTRK,IPSYS,IMPX,NBMIX,NREG,NLF,2*NAN, + 1 NALBP,MAT,VOL,GAMMA,SGD) + DEALLOCATE(SGD) + ENDIF + IF(NALBP.GT.0) DEALLOCATE(GAMMA) + IF(IMPX.GT.2) CALL LCMLIB(IPSYS) + IF(IMPX.GT.10) CALL LCMVAL(IPSYS,' ') + RETURN + END diff --git a/Dragon/src/BIVAF.f b/Dragon/src/BIVAF.f new file mode 100644 index 0000000..1fdd09c --- /dev/null +++ b/Dragon/src/BIVAF.f @@ -0,0 +1,164 @@ +*DECK BIVAF + SUBROUTINE BIVAF(KPSYS,IPTRK,IFTRAK,IMPX,NGEFF,NGIND,IDIR,NREG, + 1 NUN,MAT,VOL,KEYFLX,FUNKNO,SUNKNO,TITR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solve N-group transport equation for fluxes using the diffusion +* approximation. +* +*Copyright: +* Copyright (C) 2004 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* KPSYS pointer to the assembly LCM object (L_PIJ signature). KPSYS is +* an array of directories. +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK not used. +* IMPX print flag (equal to zero for no print). +* NGEFF number of energy groups processed in parallel. +* NGIND energy group indices assign to the NGEFF set. +* IDIR not used. +* NREG total number of regions for which specific values of the +* neutron flux and reactions rates are required. +* NUN total number of unknowns in vectors SUNKNO and FUNKNO. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX position of averaged flux elements in FUNKNO vector. +* SUNKNO input source vector. +* TITR title. +* +*Parameters: input/output +* FUNKNO unknown vector. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER TITR*72 + TYPE(C_PTR) KPSYS(NGEFF),IPTRK + INTEGER NGEFF,NGIND(NGEFF),IFTRAK,IMPX,IDIR,NREG,NUN, + 1 MAT(NREG),KEYFLX(NREG) + REAL VOL(NREG),FUNKNO(NUN,NGEFF),SUNKNO(NUN,NGEFF) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6,NSTATE=40) + INTEGER IPAR(NSTATE) + LOGICAL CYLIND +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MU,KN + REAL, ALLOCATABLE, DIMENSION(:) :: XX,YY,DD,QFR,BFR,SYS,T,TS,RH, + 1 RT,IPERT +*---- +* RECOVER BIVAC SPECIFIC PARAMETERS. +*---- + IF(IMPX.GT.2) WRITE(IUNOUT,'(//8H BIVAF: ,A72)') TITR + IF(IDIR.NE.0) CALL XABORT('BIVAF: EXPECTING IDIR=0') + IF(IFTRAK.NE.0) CALL XABORT('BIVAF: EXPECTING IFTRAK=0') + CALL LCMGET(IPTRK,'STATE-VECTOR',IPAR) + IF(NREG.NE.IPAR(1)) CALL XABORT('BIVAF: INVALID VALUE OF NREG.') + IF(NUN.NE.IPAR(2)) CALL XABORT('BIVAF: INVALID VALUE OF NUN.') + ITYPE=IPAR(6) + CYLIND=(ITYPE.EQ.3).OR.(ITYPE.EQ.6) + IELEM=IPAR(8) + ICOL=IPAR(9) + ISPLH=IPAR(10) + LL4=IPAR(11) + LX=IPAR(12) + LY=IPAR(13) + NLF=IPAR(14) + ISPN=IPAR(15) + ISCAT=IPAR(16) + IF(NLF.GT.0) CALL XABORT('BIVAF: LIMITED TO DIFFUSION THEORY.') + IF(IDIR.NE.0) CALL XABORT('BIVAF: EXPECTING IDIR=0') + IF(IFTRAK.NE.0) CALL XABORT('BIVAF: EXPECTING IFTRAK=0') +*---- +* RECOVER TRACKING INFORMATION. +*---- + ALLOCATE(XX(LX*LY),YY(LX*LY),DD(LX*LY)) + IF(ITYPE.EQ.8) THEN + CALL LCMGET(IPTRK,'SIDE',SIDE) + ELSE + CALL LCMGET(IPTRK,'XX',XX) + CALL LCMGET(IPTRK,'YY',YY) + CALL LCMGET(IPTRK,'DD',DD) + ENDIF + ALLOCATE(MU(LL4)) + CALL LCMGET(IPTRK,'MU',MU) + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + CALL LCMLEN(IPTRK,'QFR',MAXQF,ITYLCM) + ALLOCATE(KN(MAXKN),QFR(MAXQF),BFR(MAXQF)) + CALL LCMGET(IPTRK,'KN',KN) + CALL LCMGET(IPTRK,'QFR',QFR) + CALL LCMGET(IPTRK,'BFR',BFR) + IIMAX=MU(LL4) + ALLOCATE(SYS(IIMAX)) +*---- +* MAIN LOOP OVER ENERGY GROUPS. +*---- + DO 40 II=1,NGEFF + IF(IMPX.GT.1) WRITE(IUNOUT,'(/24H BIVAF: PROCESSING GROUP,I5, + 1 6H WITH ,A,1H.)') NGIND(II),'BIVAC/DIFFUSION' +*---- +* COMPUTE THE NEUTRON FLUX +*---- + CALL LCMGET(KPSYS(II),'IA001001',SYS) + IF((IELEM.LT.0).AND.(ITYPE.NE.8)) THEN + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMLEN(IPTRK,'T',LC,ITYLCM) + ALLOCATE(T(LC),TS(LC)) + CALL LCMGET(IPTRK,'T',T) + CALL LCMGET(IPTRK,'TS',TS) + CALL LCMSIX(IPTRK,' ',2) + CALL BIVS01(MAXKN,CYLIND,NREG,NUN,LL4,IIMAX,XX,DD,MAT,KN,BFR, + 1 VOL,KEYFLX,MU,SUNKNO(1,II),LC,T,TS,SYS,FUNKNO(1,II)) + DEALLOCATE(TS,T) + ELSE IF((IELEM.GT.0).AND.(ITYPE.NE.8)) THEN + CALL BIVS02(CYLIND,IELEM,ICOL,NREG,NUN,LL4,IIMAX,MAT,KN,BFR, + 1 VOL,MU,SUNKNO(1,II),SYS,FUNKNO(1,II)) + ELSE IF((IELEM.LT.0).AND.(ITYPE.EQ.8)) THEN + CALL LCMSIX(IPTRK,'BIVCOL',1) + ALLOCATE(RH(36),RT(9)) + CALL LCMGET(IPTRK,'RH',RH) + CALL LCMGET(IPTRK,'RT',RT) + CALL LCMSIX(IPTRK,' ',2) + IF(ISPLH.EQ.1) THEN + NELEM=MAXKN/7 + ELSE + NELEM=MAXKN/4 + ENDIF + CALL BIVS03(MAXKN,MAXQF,NREG,NUN,LL4,ISPLH,NELEM,IIMAX,SIDE, + 1 KN,QFR,BFR,VOL,KEYFLX,MU,SUNKNO(1,II),RH,RT,SYS,FUNKNO(1,II)) + DEALLOCATE(RT,RH) + ELSE IF((IELEM.GT.0).AND.(ITYPE.EQ.8).AND.(ICOL.EQ.4)) THEN + CALL BIVS04(MAXKN,MAXQF,NREG,NUN,LL4,ISPLH,IIMAX,SIDE,KN,QFR, + 1 BFR,VOL,KEYFLX,MU,SUNKNO(1,II),SYS,FUNKNO(1,II)) + ELSE IF((IELEM.GT.0).AND.(ITYPE.EQ.8)) THEN + NBLOS=LX/3 + ALLOCATE(IPERT(LX*ISPLH**2)) + CALL LCMGET(IPTRK,'IPERT',IPERT) + CALL BIVS05(IELEM,NBLOS,NUN,LL4,IIMAX,IPERT,KN,BFR,MU, + 1 SUNKNO(1,II),SYS,FUNKNO(1,II)) + DEALLOCATE(IPERT) + ELSE + CALL XABORT('BIVAF: UNKNOWN TYPE OF GEOMETRY.') + ENDIF +*---- +* END OF LOOP OVER ENERGY GROUPS. +*---- + 40 CONTINUE + DEALLOCATE(SYS,BFR,QFR,KN,MU,DD,YY,XX) + RETURN + END diff --git a/Dragon/src/BIVFIS.f b/Dragon/src/BIVFIS.f new file mode 100644 index 0000000..49fe6da --- /dev/null +++ b/Dragon/src/BIVFIS.f @@ -0,0 +1,186 @@ +*DECK BIVFIS + SUBROUTINE BIVFIS(IPTRK,NREG,NMAT,NIFIS,NUNKNO,NGRP,MATCOD,VOL, + > XSCHI,XSNUF,FUNKNO,SUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the fission source for a BIVAC tracking. +* +*Copyright: +* Copyright (C) 2025 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK pointer to the tracking LCM object. +* NANIS maximum cross section Legendre order. +* NREG number of regions. +* NMAT number of mixtures. +* NIFIS number of fissile isotopes. +* NUNKNO number of unknowns per energy group. +* NGRP number of energy groups. +* MATCOD mixture indices. +* VOL volumes. +* XSCHI fission spectra. +* XSNUP nu times the fission cross sections. +* FUNKNO fluxes. +* +*Parameters: output +* SUNKNO sources. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE DOORS_MOD +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER NREG,NMAT,NIFIS,NUNKNO,NGRP,MATCOD(NREG) + REAL VOL(NREG),XSCHI(0:NMAT,NIFIS,NGRP),XSNUF(0:NMAT,NIFIS,NGRP), + 1 FUNKNO(NUNKNO,NGRP),SUNKNO(NUNKNO,NGRP) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + INTEGER JPAR(NSTATE),IJ1(25),IJ2(25) + LOGICAL CYLIND + CHARACTER*12 CXDOOR +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KN,IDL + REAL, ALLOCATABLE, DIMENSION(:) :: XX,DD,FXSOR + REAL, ALLOCATABLE, DIMENSION(:,:) :: RR,RS +*---- +* RECOVER BIVAC SPECIFIC PARAMETERS. +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',JPAR) + IF(JPAR(1).NE.NREG) CALL XABORT('BIVFIS: INCONSISTENT NREG.') + IF(JPAR(2).NE.NUNKNO) CALL XABORT('BIVFIS: INCONSISTENT NUNKNO.') + ITYPE=JPAR(6) + IELEM=JPAR(8) + ICOL=JPAR(9) + ISPLH=JPAR(10) + L4=JPAR(11) + LX=JPAR(12) + NLF=JPAR(14) + ISCAT=JPAR(16) + CYLIND=(ITYPE.EQ.3).OR.(ITYPE.EQ.6) + IF(ICOL.EQ.4) THEN + CALL XABORT('BIVFIS: COLLOCATION NODAL NOT IMPLEMENTED.') + ELSE IF((ITYPE.NE.2).AND.(ITYPE.NE.5)) THEN + CALL XABORT('BIVFIS: CARTESIAN 1D OR 2D GEOMETRY EXPECTED.') + ENDIF + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + ALLOCATE(XX(NREG),DD(NREG),KN(MAXKN),IDL(NREG)) + CALL LCMGET(IPTRK,'XX',XX) + CALL LCMGET(IPTRK,'DD',DD) + CALL LCMGET(IPTRK,'KN',KN) + CALL LCMGET(IPTRK,'KEYFLX',IDL) + IF(IELEM.LT.0) THEN + ! Lagrangian finite element method +*---- +* RECOVER THE FINITE ELEMENT UNIT STIFFNESS MATRIX. +*---- + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMLEN(IPTRK,'T',LC,ITYLCM) + ALLOCATE(RR(LC,LC),RS(LC,LC)) + CALL LCMGET(IPTRK,'R',RR) + CALL LCMGET(IPTRK,'RS',RS) + CALL LCMSIX(IPTRK,' ',2) +*---- +* COMPUTE VECTORS IJ1 AND IJ2 +*---- + LL=LC*LC + DO I=1,LL + IJ1(I)=1+MOD(I-1,LC) + IJ2(I)=1+(I-IJ1(I))/LC + ENDDO +*---- +* COMPUTE THE SOURCE +*---- + NUM1=0 + DO IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) CYCLE + IF(VOL(IR).EQ.0.0) GO TO 10 + DO I=1,LL + IND1=KN(NUM1+I) + IF(IND1.EQ.0) CYCLE + I1=IJ1(I) + I2=IJ2(I) + DO J=1,LL + IND2=KN(NUM1+J) + IF(IND2.EQ.0) CYCLE + IF(CYLIND) THEN + AUXX=(RR(I1,IJ1(J))+RS(I1,IJ1(J))*XX(IR)/DD(IR))* + > RR(I2,IJ2(J))*VOL(IR) + ELSE + AUXX=RR(I1,IJ1(J))*RR(I2,IJ2(J))*VOL(IR) + ENDIF + DO IG=1,NGRP + DO JG=1,NGRP + DO IS=1,NIFIS + SIGG=XSCHI(IBM,IS,IG)*XSNUF(IBM,IS,JG) + SUNKNO(IND1,IG)=SUNKNO(IND1,IG)+AUXX*SIGG* + > FUNKNO(IND2,JG) + ENDDO ! IS + ENDDO ! JG + ENDDO ! IG + ENDDO ! J + ENDDO ! I + 10 NUM1=NUM1+LL + ENDDO ! IR + DEALLOCATE(RS,RR) + ! append the integrated volumic sources + ALLOCATE(FXSOR(NUNKNO)) + DO IS=1,NIFIS + FXSOR(:NUNKNO)=0.0 + DO IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) CYCLE + DO IG=1,NGRP + FXSOR(IDL(IR))=FXSOR(IDL(IR))+VOL(IR)*XSNUF(IBM,IS,IG)* + > FUNKNO(IDL(IR),IG) + ENDDO ! IG + DO IG=1,NGRP + SUNKNO(IDL(IR),IG)=SUNKNO(IDL(IR),IG)+XSCHI(IBM,IS,IG)* + > FXSOR(IDL(IR)) + ENDDO ! IG + ENDDO ! IR + ENDDO ! IS + DEALLOCATE(FXSOR) + ELSE + ! Raviart-Thomas finite element method + CXDOOR='BIVAC' + ALLOCATE(FXSOR(NUNKNO)) + DO IS=1,NIFIS + FXSOR(:NUNKNO)=0.0 + DO IG=1,NGRP + CALL DOORS(CXDOOR,IPTRK,NMAT,0,NUNKNO,XSNUF(0,IS,IG), + > FXSOR,FUNKNO(1,IG)) + ENDDO + DO IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.EQ.0) CYCLE + DO IE=1,IELEM**2 + IND=IDL(IR)+IE-1 + IF(IND.EQ.0) CYCLE + DO IG=1,NGRP + SUNKNO(IND,IG)=SUNKNO(IND,IG)+XSCHI(IBM,IS,IG)* + > FXSOR(IND) + ENDDO + ENDDO + ENDDO + ENDDO ! IS + DEALLOCATE(FXSOR) + ENDIF + DEALLOCATE(IDL,KN,DD,XX) + RETURN + END diff --git a/Dragon/src/BIVS01.f b/Dragon/src/BIVS01.f new file mode 100644 index 0000000..50848ea --- /dev/null +++ b/Dragon/src/BIVS01.f @@ -0,0 +1,117 @@ +*DECK BIVS01 + SUBROUTINE BIVS01(MAXKN,CYLIND,NREG,NUN,LL4,IIMAX,XX,DD,MAT,KN, + 1 BFR,VOL,IDL,MU,SOURCE,LC,T,TS,SYS,FUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* One-speed flux calculation in mesh corner finite difference or finite +* element approximation (Cartesian geometry). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXKN dimension of array KN. +* CYLIND cylinderization flag (=.TRUE. for cylindrical geometry). +* NREG number of elements in BIVAC. +* NUN dimension of vector FUNKNO. +* LL4 order of matrix SYS. +* IIMAX allocated dimension of array SYS. +* XX X-directed mesh spacings. +* DD value used with a cylindrical geometry. +* MAT mixture index per region. +* KN element-ordered unknown list. +* BFR element-ordered surface fractions. +* VOL volume of regions. +* IDL position of integrated fluxes into unknown vector. +* MU indices used with compressed diagonal storage mode matrix SYS. +* SOURCE fission and diffusion sources. +* LC number of polynomials in a complete 1-D basis. +* T Cartesian linear product vector. +* TS cylindrical linear product vector. +* SYS factorized system matrix. +* +*Parameters: output +* FUNKNO unknown array. The first LL4 values contains the finite +* element unknowns; the next NREG values contains element +* averaged fluxes. The surface-averaged flux is located in +* position FUNKNO(NUN). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXKN,NREG,NUN,LL4,IIMAX,MAT(NREG),KN(MAXKN),IDL(NREG), + 1 MU(LL4),LC + REAL XX(NREG),DD(NREG),BFR(4*NREG),SOURCE(LL4),VOL(NREG),T(LC), + 1 TS(LC),SYS(IIMAX),FUNKNO(NUN) + LOGICAL CYLIND +*---- +* LOCAL VARIABLES +*---- + INTEGER IJ1(25),IJ2(25),ISR(4,5) +*---- +* COMPUTE VECTORS IJ1, IJ2 AND MATRIX ISR. +*---- + LL=LC*LC + DO 10 I=1,LL + IJ1(I)=1+MOD(I-1,LC) + IJ2(I)=1+(I-IJ1(I))/LC + 10 CONTINUE + DO 20 I=1,LC + ISR(1,I)=(I-1)*LC+1 + ISR(2,I)=I*LC + ISR(3,I)=I + ISR(4,I)=LL-LC+I + 20 CONTINUE +*---- +* RESOLUTION. +*---- + DO 30 I=1,LL4 + FUNKNO(I)=SOURCE(I) + 30 CONTINUE + CALL ALLDLS(LL4,MU,SYS,FUNKNO) +*---- +* CALCULATION OF ELEMENT-AVERAGED AND SURFACE-AVERAGED FLUXES. +*---- + FUNKNO(NUN)=0.0 + NUM1=0 + NUM2=0 + DO 170 K=1,NREG + IF(MAT(K).EQ.0) GO TO 170 + FUNKNO(IDL(K))=0.0 + IF(VOL(K).EQ.0.0) GO TO 160 +* + DO 130 I=1,LL + IND1=KN(NUM1+I) + IF(IND1.EQ.0) GO TO 130 + IF(CYLIND) THEN + SS=(T(IJ1(I))+TS(IJ1(I))*XX(K)/DD(K))*T(IJ2(I)) + ELSE + SS=T(IJ1(I))*T(IJ2(I)) + ENDIF + FUNKNO(IDL(K))=FUNKNO(IDL(K))+SS*FUNKNO(IND1) + 130 CONTINUE +* + DO 150 IC=1,4 + BFR1=BFR(NUM2+IC) + IF(BFR1.EQ.0.0) GO TO 150 + DO 140 I1=1,LC + IND1=KN(NUM1+ISR(IC,I1)) + IF(IND1.GT.0) FUNKNO(NUN)=FUNKNO(NUN)+T(I1)*FUNKNO(IND1)*BFR1 + 140 CONTINUE + 150 CONTINUE +* + 160 NUM1=NUM1+LL + NUM2=NUM2+4 + 170 CONTINUE + RETURN + END diff --git a/Dragon/src/BIVS02.f b/Dragon/src/BIVS02.f new file mode 100644 index 0000000..6f7abd1 --- /dev/null +++ b/Dragon/src/BIVS02.f @@ -0,0 +1,106 @@ +*DECK BIVS02 + SUBROUTINE BIVS02(CYLIND,IELEM,ICOL,NREG,NUN,LL4,IIMAX,MAT,KN,BFR, + 1 VOL,MU,SOURCE,SYS,FUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* One-speed flux calculation in mixed-dual finite element approximation +* (Cartesian geometry). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* CYLIND cylinderization flag (=.TRUE. for cylindrical geometry). +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic); =4 (quartic). +* ICOL type of quadrature: =1 (analytical integration); +* =2 (Gauss-Lobatto); =3 (Gauss-Legendre). +* NREG number of elements in BIVAC. +* NUN dimension of array FUNKNO. +* LL4 number of unknowns per group in BIVAC. +* IIMAX allocated dimension of array SYS. +* MAT mixture index per region. +* KN element-ordered unknown list. +* BFR element-ordered surface fractions. +* VOL volume of regions. +* MU indices used with compressed diagonal storage mode matrix SYS. +* SOURCE fission and diffusion sources. +* SYS factorized system matrix. +* +*Parameters: output +* FUNKNO neutron fluxes (surface-averaged flux are in position +* FUNKNO(NUN)). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IELEM,ICOL,NREG,NUN,LL4,IIMAX,MAT(NREG),KN(5*NREG), + 1 MU(LL4) + REAL BFR(4*NREG),VOL(NREG),SOURCE(LL4),SYS(IIMAX),FUNKNO(NUN) + LOGICAL CYLIND +* + IF((CYLIND).AND.((IELEM.GT.1).OR.(ICOL.NE.2))) + 1 CALL XABORT('BIVS02: TYPE OF DISCRETIZATION NOT IMPLEMENTED.') +*---- +* RESOLUTION. +*---- + DO 90 I=1,LL4 + FUNKNO(I)=SOURCE(I) + 90 CONTINUE + CALL ALLDLS (LL4,MU,SYS,FUNKNO) +*---- +* CALCULATION OF THE SURFACE-AVERAGED FLUX. +*---- + FUNKNO(NUN)=0.0 + NUM1=0 + NUM2=0 + DO 160 K=1,NREG + IF(MAT(K).EQ.0) GO TO 160 + IF(VOL(K).EQ.0.0) GO TO 150 + IF(BFR(NUM2+1).GT.0.0) THEN + SG=1.0 + DO 110 I0=1,IELEM + IND1=KN(NUM1+1)+I0-1 + FUNKNO(NUN)=FUNKNO(NUN)+SG*SQRT(REAL(2*I0-1))*FUNKNO(IND1)* + 1 BFR(NUM2+1) + SG=-SG + 110 CONTINUE + ENDIF + IF(BFR(NUM2+2).GT.0.0) THEN + DO 120 I0=1,IELEM + IND1=KN(NUM1+1)+I0-1 + FUNKNO(NUN)=FUNKNO(NUN)+SQRT(REAL(2*I0-1))*FUNKNO(IND1)* + 1 BFR(NUM2+2) + 120 CONTINUE + ENDIF + IF(BFR(NUM2+3).GT.0.0) THEN + SG=1.0 + DO 130 I0=1,IELEM + IND1=KN(NUM1+1)+(I0-1)*IELEM + FUNKNO(NUN)=FUNKNO(NUN)+SG*SQRT(REAL(2*I0-1))*FUNKNO(IND1)* + 1 BFR(NUM2+3) + SG=-SG + 130 CONTINUE + ENDIF + IF(BFR(NUM2+4).GT.0.0) THEN + DO 140 I0=1,IELEM + IND1=KN(NUM1+1)+(I0-1)*IELEM + FUNKNO(NUN)=FUNKNO(NUN)+SQRT(REAL(2*I0-1))*FUNKNO(IND1)* + 1 BFR(NUM2+4) + 140 CONTINUE + ENDIF + 150 NUM1=NUM1+5 + NUM2=NUM2+4 + 160 CONTINUE + RETURN + END diff --git a/Dragon/src/BIVS03.f b/Dragon/src/BIVS03.f new file mode 100644 index 0000000..e196765 --- /dev/null +++ b/Dragon/src/BIVS03.f @@ -0,0 +1,145 @@ +*DECK BIVS03 + SUBROUTINE BIVS03(MAXKN,MAXQF,NREG,NUN,LL4,ISPLH,NELEM,IIMAX,SIDE, + 1 KN,QFR,BFR,VOL,IDL,MU,SOURCE,RH,RT,SYS,FUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* One-speed flux calculation in mesh corner finite difference or finite +* element approximation (hexagonal geometry). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXKN dimension of array KN. +* MAXQF dimension of arrays QFR and BFR. +* NREG number of hexagons in BIVAC. +* NUN dimension of vector FUNKNO. +* LL4 order of the matrix SYS. +* ISPLH hexagonal geometry flag: +* =1: hexagonal elements; >1: triangular elements. +* NELEM number of finite elements (hexagons or triangles) excluding +* the virtual elements. +* IIMAX allocated dimension of array SYS. +* SIDE side of the hexagons. +* KN element-ordered unknown list (dimensionned to KN((LH+1)*NELEM) +* where LH=6 (hexagons) or 3 (triangles)). +* QFR element-ordered information. +* BFR element-ordered surface fractions. +* VOL volume of the hexagons. +* IDL position of the average flux component associated with each +* hexagon. +* MU indices used with the compressed diagonal storage mode matrix +* SYS. +* SOURCE fission and diffusion sources. +* RH unit matrix. +* RT unit matrix. +* SYS factorized system matrix. +* +*Parameters: output +* FUNKNO unknown array. The first LL4 values contains the finite +* element unknowns; the next NREG values contains element +* averaged fluxes. The surface-averaged flux is located in +* position FUNKNO(NUN). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXKN,MAXQF,NREG,NUN,LL4,ISPLH,NELEM,IIMAX,KN(MAXKN), + 1 IDL(NREG),MU(LL4) + REAL SIDE,QFR(MAXQF),BFR(MAXQF),VOL(NREG),SOURCE(LL4),RH(6,6), + 1 RT(3,3),SYS(IIMAX),FUNKNO(NUN) +*---- +* LOCAL VARIABLES +*---- + INTEGER ISR(6,2),ISRH(6,2),ISRT(3,2) + REAL TH(6) + DATA ISRH/2,1,4,5,6,3,1,4,5,6,3,2/ + DATA ISRT/1,2,3,2,3,1/ +*---- +* RECOVER THE HEXAGONAL SVALAR PRODUCT (TH) VECTOR. +*---- + IF(ISPLH.EQ.1) THEN +* HEXAGONAL BASIS. + LH=6 + DO 15 I=1,6 + DO 10 J=1,2 + ISR(I,J)=ISRH(I,J) + 10 CONTINUE + 15 CONTINUE + DO 25 I=1,6 + TH(I)=0.0 + DO 20 J=1,6 + TH(I)=TH(I)+RH(I,J) + 20 CONTINUE + 25 CONTINUE + CONST=1.5*SQRT(3.0) + CONSB=2.0*SQRT(3.0)/3.0 + AA=SIDE + ELSE +* TRIANGULAR BASIS. + LH=3 + DO 35 I=1,3 + DO 30 J=1,2 + ISR(I,J)=ISRT(I,J) + 30 CONTINUE + 35 CONTINUE + DO 45 I=1,3 + TH(I)=0.0 + DO 40 J=1,3 + TH(I)=TH(I)+RT(I,J) + 40 CONTINUE + 45 CONTINUE + CONST=0.25*SQRT(3.0) + CONSB=2.0*SQRT(3.0) + AA=SIDE/REAL(ISPLH-1) + ENDIF +*---- +* RESOLUTION. +*---- + DO 120 I=1,LL4 + FUNKNO(I)=SOURCE(I) + 120 CONTINUE + CALL ALLDLS(LL4,MU,SYS,FUNKNO) +*---- +* VOLUME-AVERAGED FLUXES. +*---- + DO 130 KHEX=1,NREG + IF(IDL(KHEX).NE.0) FUNKNO(IDL(KHEX))=0.0 + 130 CONTINUE + FUNKNO(NUN)=0.0 + NUM1=0 + DO 180 K=1,NELEM + KHEX=KN(NUM1+LH+1) + IF(VOL(KHEX).EQ.0.0) GO TO 170 + DO 140 I=1,LH + IND1=KN(NUM1+I) + IF(IND1.EQ.0) GO TO 140 + SS=TH(I)*QFR(NUM1+LH+1)/(CONST*VOL(KHEX)) + FUNKNO(IDL(KHEX))=FUNKNO(IDL(KHEX))+SS*FUNKNO(IND1) + 140 CONTINUE +*---- +* SURFACE-AVERAGED FLUX. +*---- + DO 160 IC=1,LH + BFR1=BFR(NUM1+IC)*CONSB + IF(BFR1.EQ.0.0) GO TO 160 + DO 150 I1=1,2 + IND1=KN(NUM1+ISR(IC,I1)) + IF(IND1.GT.0) FUNKNO(NUN)=FUNKNO(NUN)+TH(I1)*FUNKNO(IND1)*BFR1 + 150 CONTINUE + 160 CONTINUE +* + 170 NUM1=NUM1+LH+1 + 180 CONTINUE + RETURN + END diff --git a/Dragon/src/BIVS04.f b/Dragon/src/BIVS04.f new file mode 100644 index 0000000..6db43ca --- /dev/null +++ b/Dragon/src/BIVS04.f @@ -0,0 +1,108 @@ +*DECK BIVS04 + SUBROUTINE BIVS04(MAXKN,MAXQF,NREG,NUN,LL4,ISPLH,IIMAX,SIDE,KN, + 1 QFR,BFR,VOL,IDL,MU,SOURCE,SYS,FUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* One-speed flux calculation in mixed-dual finite element approximation +* (hexagonal geometry). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXKN dimension of array KN. +* MAXQF dimension of arrays QFR and BFR. +* NREG number of hexagons in BIVAC. +* NUN dimension of array FUNKNO. +* LL4 number of unknowns per group in BIVAC. Equal to the number +* of finite elements (hexagons or triangles) excluding the +* virtual elements. +* ISPLH type of hexagonal mesh-splitting: +* =1: hexagonal elements; >1: triangular elements. +* IIMAX allocated dimension of array SYS. +* SIDE side of the hexagons. +* KN element-ordered unknown list. +* QFR element-ordered information. +* BFR element-ordered surface fractions. +* VOL volume of hexagons. +* IDL position of the average flux component associated with +* each volume. +* MU indices used with the compressed diagonal storage mode matrix +* SYS. +* SOURCE fission and diffusion sources. +* SYS factorized system matrix. +* +*Parameters: output +* FUNKNO neutron fluxes (surface-averaged flux are in position +* FUNKNO(NUN)). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXKN,MAXQF,NREG,NUN,LL4,ISPLH,IIMAX,KN(MAXKN),IDL(NREG), + 1 MU(LL4) + REAL SIDE,QFR(MAXQF),BFR(MAXQF),VOL(NREG),SOURCE(LL4),SYS(IIMAX), + 1 FUNKNO(NUN) +* + IF(ISPLH.EQ.1) THEN + DS=SQRT(3.0)*SIDE + FACT=2.0/(3.0*DS) + NSURF=6 + ELSE + DS=SIDE/(SQRT(3.0)*REAL(ISPLH-1)) + FACT=4.0/(3.0*DS) + NSURF=3 + ENDIF +*---- +* RESOLUTION. +*---- + DO 10 I=1,LL4 + FUNKNO(I)=SOURCE(I) + 10 CONTINUE + CALL ALLDLS (LL4,MU,SYS,FUNKNO) +*---- +* CALCULATION OF ELEMENT-AVERAGED FLUXES. +*---- + IF(ISPLH.GT.1) THEN + NSURF=3 + DO 20 K=1,NREG + IF(IDL(K).NE.0) FUNKNO(IDL(K))=0.0 + 20 CONTINUE + NUM1=0 + DO 40 IND1=1,LL4 + K=KN(NUM1+NSURF+1) + IF(VOL(K).EQ.0.0) GO TO 30 + FUNKNO(IDL(K))=FUNKNO(IDL(K))+QFR(NUM1+NSURF+1)*FUNKNO(IND1)/ + 1 VOL(K) + 30 NUM1=NUM1+NSURF+1 + 40 CONTINUE + ELSE + NSURF=6 + ENDIF +*---- +* CALCULATION OF SURFACE-AVERAGED FLUX. +*---- + FUNKNO(NUN)=0.0 + NUM1=0 + DO 70 IND1=1,LL4 + K=KN(NUM1+NSURF+1) + IF(VOL(K).EQ.0.0) GO TO 60 + DO 50 IC=1,NSURF + IF(BFR(NUM1+IC).GT.0.0) THEN + FUNKNO(NUN)=FUNKNO(NUN)+FUNKNO(IND1)*BFR(NUM1+IC) + ENDIF + 50 CONTINUE + 60 NUM1=NUM1+NSURF+1 + 70 CONTINUE + RETURN + END diff --git a/Dragon/src/BIVS05.f b/Dragon/src/BIVS05.f new file mode 100644 index 0000000..a465179 --- /dev/null +++ b/Dragon/src/BIVS05.f @@ -0,0 +1,112 @@ +*DECK BIVS05 + SUBROUTINE BIVS05(IELEM,NBLOS,NUN,LL4,IIMAX,IPERT,KN,BFR,MU, + 1 SOURCE,SYS,FUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* One-speed flux calculation in a Thomas-Raviart-Schneider (dual) finite +* element diffusion approximation (hexagonal geometry). +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic). +* NBLOS number of lozenges per direction, taking into account +* mesh-splitting. +* NUN dimension of array FUNKNO. +* LL4 number of unknowns per group in BIVAC. +* IIMAX allocated dimension of array SYS. +* IPERT mixture permutation index. +* KN element-ordered unknown list. +* BFR element-ordered surface fractions. +* MU indices used with compressed diagonal storage mode matrix SYS. +* SOURCE fission and diffusion sources. +* SYS factorized system matrix. +* +*Parameters: output +* FUNKNO neutron fluxes (surface-averaged flux are in position +* FUNKNO(NUN)). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IELEM,NBLOS,NUN,LL4,IIMAX,IPERT(NBLOS), + 1 KN(NBLOS,4+6*IELEM*(IELEM+1)),MU(LL4) + REAL BFR(NBLOS,6),SOURCE(LL4),SYS(IIMAX),FUNKNO(NUN) +*---- +* RESOLUTION. +*---- + DO 10 I=1,LL4 + FUNKNO(I)=SOURCE(I) + 10 CONTINUE + CALL ALLDLS (LL4,MU,SYS,FUNKNO) +*---- +* CALCULATION OF THE SURFACE-AVERAGED FLUX. +*---- + FUNKNO(NUN)=0.0 + NUM=0 + DO 100 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 100 + NUM=NUM+1 + IF(BFR(NUM,1).GT.0.0) THEN + SG=1.0 + DO 40 I0=1,IELEM + IND1=KN(NUM,1)+I0-1 + FUNKNO(NUN)=FUNKNO(NUN)+SG*SQRT(REAL(2*I0-1))*FUNKNO(IND1)* + 1 BFR(NUM,1) + SG=-SG + 40 CONTINUE + ENDIF + IF(BFR(NUM,2).GT.0.0) THEN + DO 50 I0=1,IELEM + IND1=KN(NUM,2)+(I0-1)*IELEM + FUNKNO(NUN)=FUNKNO(NUN)+SQRT(REAL(2*I0-1))*FUNKNO(IND1)* + 1 BFR(NUM,2) + 50 CONTINUE + ENDIF + IF(BFR(NUM,3).GT.0.0) THEN + SG=1.0 + DO 60 I0=1,IELEM + IND1=KN(NUM,2)+I0-1 + FUNKNO(NUN)=FUNKNO(NUN)+SG*SQRT(REAL(2*I0-1))*FUNKNO(IND1)* + 1 BFR(NUM,3) + SG=-SG + 60 CONTINUE + ENDIF + IF(BFR(NUM,4).GT.0.0) THEN + DO 70 I0=1,IELEM + IND1=KN(NUM,3)+(I0-1)*IELEM + FUNKNO(NUN)=FUNKNO(NUN)+SQRT(REAL(2*I0-1))*FUNKNO(IND1)* + 1 BFR(NUM,4) + 70 CONTINUE + ENDIF + IF(BFR(NUM,5).GT.0.0) THEN + SG=1.0 + DO 80 I0=1,IELEM + IND1=KN(NUM,3)+I0-1 + FUNKNO(NUN)=FUNKNO(NUN)+SG*SQRT(REAL(2*I0-1))*FUNKNO(IND1)* + 1 BFR(NUM,5) + SG=-SG + 80 CONTINUE + ENDIF + IF(BFR(NUM,6).GT.0.0) THEN + DO 90 I0=1,IELEM + IND1=KN(NUM,4)+(I0-1)*IELEM + FUNKNO(NUN)=FUNKNO(NUN)+SQRT(REAL(2*I0-1))*FUNKNO(IND1)* + 1 BFR(NUM,6) + 90 CONTINUE + ENDIF + 100 CONTINUE + RETURN + END diff --git a/Dragon/src/BIVSOU.f b/Dragon/src/BIVSOU.f new file mode 100644 index 0000000..32c9f2e --- /dev/null +++ b/Dragon/src/BIVSOU.f @@ -0,0 +1,277 @@ +*DECK BIVSOU + SUBROUTINE BIVSOU(MAX1,IG,IPTRK,KPMACR,NANIS,NREG,NMAT,NUNKNO, + > NGRP,MATCOD,VOL,FUNKNO,SUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the source for the solution of diffusion or PN equations. +* BIVAC-specific version. +* +*Copyright: +* Copyright (C) 2004 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAX1 first dimension of FUNKNO and SUNKNO arrays. +* IG secondary group. +* IPTRK pointer to the tracking LCM object. +* KPMACR pointer to the secondary-group related macrolib information. +* NANIS maximum cross section Legendre order. +* NREG number of regions. +* NMAT number of mixtures. +* NUNKNO number of unknowns per energy group including spherical +* harmonic terms, interface currents and fundamental +* currents. +* NGRP number of energy groups. +* MATCOD mixture indices. +* VOL volumes. +* FUNKNO fluxes. +* +*Parameters: output +* SUNKNO sources. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,KPMACR + INTEGER MAX1,IG,NANIS,NREG,NMAT,NUNKNO,NGRP,MATCOD(NREG) + REAL VOL(NREG),FUNKNO(MAX1,NGRP),SUNKNO(MAX1,NGRP) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + INTEGER JPAR(NSTATE),IJ1(25),IJ2(25) + CHARACTER CAN(0:9)*2 + LOGICAL CYLIND +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS,KN,IDL + REAL, ALLOCATABLE, DIMENSION(:) :: XSCAT,XX,DD + REAL, ALLOCATABLE, DIMENSION(:,:) :: RR,RS +*---- +* DATA STATEMENTS +*---- + DATA CAN /'00','01','02','03','04','05','06','07','08','09'/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IJJ(0:NMAT),NJJ(0:NMAT),IPOS(0:NMAT)) + ALLOCATE(XSCAT(0:NMAT*NGRP)) +*---- +* RECOVER BIVAC SPECIFIC PARAMETERS. +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',JPAR) + IF(JPAR(1).NE.NREG) CALL XABORT('BIVSOU: INCONSISTENT NREG.') + IF(JPAR(2).NE.NUNKNO) CALL XABORT('BIVSOU: INCONSISTENT NUNKNO.') + ITYPE=JPAR(6) + IELEM=JPAR(8) + ICOL=JPAR(9) + L4=JPAR(11) + LX=JPAR(12) + NLF=JPAR(14) + ISCAT=JPAR(16) + CYLIND=(ITYPE.EQ.3).OR.(ITYPE.EQ.6) + IF(ICOL.EQ.4) THEN + CALL XABORT('BIVSOU: COLLOCATION NODAL NOT IMPLEMENTED.') + ELSE IF((ITYPE.NE.2).AND.(ITYPE.NE.5)) THEN + CALL XABORT('BIVSOU: CARTESIAN 1D OR 2D GEOMETRY EXPECTED.') + ENDIF + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + ALLOCATE(XX(NREG),DD(NREG),KN(MAXKN),IDL(NREG)) + CALL LCMGET(IPTRK,'XX',XX) + CALL LCMGET(IPTRK,'DD',DD) + CALL LCMGET(IPTRK,'KN',KN) + CALL LCMGET(IPTRK,'KEYFLX',IDL) +*---- +* RECOVER THE FINITE ELEMENT UNIT STIFFNESS MATRIX. +*---- + LL=0 + IF((NLF.GT.0).OR.(IELEM.LT.0)) THEN + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMLEN(IPTRK,'T',LC,ITYLCM) + ALLOCATE(RR(LC,LC),RS(LC,LC)) + CALL LCMGET(IPTRK,'R',RR) + CALL LCMGET(IPTRK,'RS',RS) + CALL LCMSIX(IPTRK,' ',2) +*---- +* COMPUTE VECTORS IJ1 AND IJ2 +*---- + LL=LC*LC + DO 10 I=1,LL + IJ1(I)=1+MOD(I-1,LC) + IJ2(I)=1+(I-IJ1(I))/LC + 10 CONTINUE + ENDIF +*---- +* COMPUTE THE SOURCE +*---- + IF(NLF.EQ.0) THEN +*---- +* ++++ DIFFUSION THEORY ++++ +*---- + CALL LCMGET(KPMACR,'NJJS00',NJJ(1)) + CALL LCMGET(KPMACR,'IJJS00',IJJ(1)) + CALL LCMGET(KPMACR,'IPOS00',IPOS(1)) + CALL LCMGET(KPMACR,'SCAT00',XSCAT(1)) + IF(IELEM.GT.0) THEN +*---- +* CARTESIAN 2D DUAL (RAVIART-THOMAS) CASE. +*---- + NUM1=0 + DO 30 IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) GO TO 30 + IF(VOL(IR).EQ.0.0) GO TO 26 + DO 25 I0=1,IELEM*IELEM + IND=KN(NUM1+1)+I0-1 + JG=IJJ(IBM) + DO 20 JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + SUNKNO(IND,IG)=SUNKNO(IND,IG)+FUNKNO(IND,JG)*VOL(IR)* + > XSCAT(IPOS(IBM)+JND-1) + ENDIF + JG=JG-1 + 20 CONTINUE + 25 CONTINUE + 26 NUM1=NUM1+5 + 30 CONTINUE + ELSE IF(IELEM.LT.0) THEN +*---- +* CARTESIAN 2D PRIM (LAGRANGE) CASE. +*---- + NUM1=0 + DO 170 IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) GO TO 170 + IF(VOL(IR).EQ.0.0) GO TO 160 + DO 140 I=1,LL + IND1=KN(NUM1+I) + IF(IND1.EQ.0) GO TO 140 + I1=IJ1(I) + I2=IJ2(I) + DO 130 J=1,LL + IND2=KN(NUM1+J) + IF(IND2.EQ.0) GO TO 130 + IF(CYLIND) THEN + AUXX=(RR(I1,IJ1(J))+RS(I1,IJ1(J))*XX(IR)/DD(IR))* + > RR(I2,IJ2(J))*VOL(IR) + ELSE + AUXX=RR(I1,IJ1(J))*RR(I2,IJ2(J))*VOL(IR) + ENDIF + JG=IJJ(IBM) + DO 120 JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + SUNKNO(IND1,IG)=SUNKNO(IND1,IG)+AUXX*FUNKNO(IND2,JG)* + > XSCAT(IPOS(IBM)+JND-1) + ENDIF + JG=JG-1 + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + ! append the integrated volumic sources + JG=IJJ(IBM) + DO 150 JND=1,NJJ(IBM) + SUNKNO(IDL(IR),IG)=SUNKNO(IDL(IR),IG)+FUNKNO(IDL(IR),JG)* + > VOL(IR)*XSCAT(IPOS(IBM)+JND-1) + JG=JG-1 + 150 CONTINUE + ! + 160 NUM1=NUM1+LL + 170 CONTINUE + ENDIF + ELSE +*---- +* ++++ SPN THEORY ++++ +*---- + DO 330 IL=0,MIN(ABS(ISCAT)-1,NANIS) + FACT=REAL(2*IL+1) + CALL LCMGET(KPMACR,'NJJS'//CAN(IL),NJJ(1)) + CALL LCMGET(KPMACR,'IJJS'//CAN(IL),IJJ(1)) + CALL LCMGET(KPMACR,'IPOS'//CAN(IL),IPOS(1)) + CALL LCMGET(KPMACR,'SCAT'//CAN(IL),XSCAT(1)) + NUM1=0 + DO 320 IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) GO TO 320 + IF(VOL(IR).EQ.0.0) GO TO 310 + IF(MOD(IL,2).EQ.0) THEN + DO 255 I0=1,IELEM*IELEM + IND=(IL/2)*L4+KN(NUM1+1)+I0-1 + JG=IJJ(IBM) + DO 250 JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + SUNKNO(IND,IG)=SUNKNO(IND,IG)+FACT*FUNKNO(IND,JG)* + > VOL(IR)*XSCAT(IPOS(IBM)+JND-1) + ENDIF + JG=JG-1 + 250 CONTINUE + 255 CONTINUE + ELSE + DO 305 I0=1,IELEM + DO 275 IC=1,2 + IIC=1+(IC-1)*IELEM + IND1=(IL/2)*L4+ABS(KN(NUM1+1+IC))+I0-1 + S1=REAL(SIGN(1,KN(NUM1+1+IC))) + DO 270 JC=1,2 + JJC=1+(JC-1)*IELEM + IND2=(IL/2)*L4+ABS(KN(NUM1+1+JC))+I0-1 + IF((KN(NUM1+1+IC).NE.0).AND.(KN(NUM1+1+JC).NE.0)) THEN + S2=REAL(SIGN(1,KN(NUM1+1+JC))) + AUXX=S1*S2*FACT*RR(IIC,JJC)*VOL(IR) + JG=IJJ(IBM) + DO 260 JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + SUNKNO(IND1,IG)=SUNKNO(IND1,IG)-AUXX*FUNKNO(IND2,JG)* + 1 XSCAT(IPOS(IBM)+JND-1) + ENDIF + JG=JG-1 + 260 CONTINUE + ENDIF + 270 CONTINUE + 275 CONTINUE + DO 300 IC=3,4 + IIC=1+(IC-3)*IELEM + IND1=(IL/2)*L4+ABS(KN(NUM1+1+IC))+I0-1 + S1=REAL(SIGN(1,KN(NUM1+1+IC))) + DO 290 JC=3,4 + JJC=1+(JC-3)*IELEM + IND2=(IL/2)*L4+ABS(KN(NUM1+1+JC))+I0-1 + IF((KN(NUM1+1+IC).NE.0).AND.(KN(NUM1+1+JC).NE.0)) THEN + S2=REAL(SIGN(1,KN(NUM1+1+JC))) + AUXX=S1*S2*FACT*RR(IIC,JJC)*VOL(IR) + JG=IJJ(IBM) + DO 280 JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + SUNKNO(IND1,IG)=SUNKNO(IND1,IG)-AUXX*FUNKNO(IND2,JG)* + 1 XSCAT(IPOS(IBM)+JND-1) + ENDIF + JG=JG-1 + 280 CONTINUE + ENDIF + 290 CONTINUE + 300 CONTINUE + 305 CONTINUE + ENDIF + 310 NUM1=NUM1+5 + 320 CONTINUE + 330 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + IF((NLF.GT.0).OR.(IELEM.LT.0)) DEALLOCATE(RS,RR) + DEALLOCATE(IDL,KN,DD,XX) + DEALLOCATE(XSCAT) + DEALLOCATE(IPOS,NJJ,IJJ) + RETURN + END diff --git a/Dragon/src/BREANM.f b/Dragon/src/BREANM.f new file mode 100644 index 0000000..99287ef --- /dev/null +++ b/Dragon/src/BREANM.f @@ -0,0 +1,340 @@ +*DECK BREANM + SUBROUTINE BREANM(IPMAC1,NG,LX1,NMIX1,IMIX,ICODE,ISPH,ZKEFF,B2, + 1 ENER,XXX1,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1,JXM,JXP,FHETXM, + 2 FHETXP,ADF1,NGET,ADFREF,IPRINT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Implement the 1D DF-ANM reflector model. +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMAC1 nodal macrolib. +* NG number of energy groups. +* LX1 number of nodes in the reflector model. +* NMIX1 number of mixtures in the nodal calculation. +* IMIX mix index of each node. +* ICODE physical albedo index on each side of the domain. +* ISPH SPH flag (=0: use discontinuity factors; =1: use SPH factors). +* ZKEFF effective multiplication factor. +* B2 buckling. +* ENER energy limits. +* XXX1 spatial mesh. +* VOL1 volumes. +* FLX1 averaged fluxes +* DC1 diffusion coefficients. +* TOT1 total cross sections. +* CHI1 fission spectra. +* SIGF1 nu*fission cross sections. +* SCAT1 scattering P0 cross sections. +* JXM left boundary currents. +* JXP right boundary currents. +* FHETXM left boundary fluxes. +* FHETXP right boundary fluxes. +* ADF1 assembly discontinuity factors from macrolib. +* NGET type of NGET normalization if discontinuity factors +* (=0: simple; =1: imposed ADF on fuel assembly; =2: recover +* fuel assembly ADF from input macrolib). +* ADFREF imposed ADF values on fuel assembly side. +* IPRINT edition flag. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMAC1 + INTEGER NG,LX1,NMIX1,IMIX(LX1),ICODE(2),ISPH,NGET,IPRINT + REAL ZKEFF,B2,ENER(NG+1),XXX1(LX1+1),VOL1(NMIX1),FLX1(NMIX1,NG), + 1 DC1(NMIX1,NG),TOT1(NMIX1,NG),CHI1(NMIX1,NG),SIGF1(NMIX1,NG), + 2 SCAT1(NMIX1,NG,NG),JXM(NMIX1,NG),JXP(NMIX1,NG),FHETXM(NMIX1,NG), + 3 FHETXP(NMIX1,NG),ADF1(NMIX1,NG),ADFREF(NG) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + INTEGER ISTATE(NSTATE) + CHARACTER HADF*8 + TYPE(C_PTR) JPMAC1,KPMAC1 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) :: WORK,AFACTOR,BETA,WORK1,WORK2, + 1 WORK4,WORK5,VOLTOT + REAL, ALLOCATABLE, DIMENSION(:,:) :: FDXM,FDXP,FHOMM,FHOMP,WORK3 + REAL(KIND=8), ALLOCATABLE, DIMENSION(:,:,:) :: L,R +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(L(NG,2*NG,LX1),R(NG,2*NG,LX1)) + ALLOCATE(FHOMM(NMIX1,NG),FHOMP(NMIX1,NG),FDXM(NMIX1,NG), + 1 FDXP(NMIX1,NG),AFACTOR(NG),BETA(NG),WORK1(NG),WORK2(NG), + 2 WORK3(NG,NG),WORK4(NG),WORK5(NG),VOLTOT(NMIX1)) +*---- +* COMPUTE BOUNDARY FLUXES +*---- + FDXM(:NMIX1,:NG)=0.0 + FDXP(:NMIX1,:NG)=0.0 + FHOMM(:NMIX1,:NG)=0.0 + FHOMP(:NMIX1,:NG)=0.0 + VOLTOT(:NMIX1)=0.0 + J_FUEL=0 + DO I=1,LX1 + IBM=IMIX(I) + IF(IBM.EQ.0) CYCLE + WORK1(:NG)=DC1(IBM,:NG) + WORK3(:NG,:NG)=SCAT1(IBM,:NG,:NG) + WORK4(:NG)=CHI1(IBM,:NG) + WORK5(:NG)=SIGF1(IBM,:NG) + DO IGR=1,NG + IF(SIGF1(IBM,IGR).GT.0.0) J_FUEL=I + WORK2(IGR)=TOT1(IBM,IGR)+B2*DC1(IBM,IGR)-SCAT1(IBM,IGR,IGR) + ENDDO + VOL=XXX1(I+1)-XXX1(I) + CALL NSSLR1(ZKEFF,NG,VOL,WORK1,WORK2,WORK3,WORK4,WORK5, + 1 L(1,1,I),R(1,1,I)) + ! + VOLTOT(IBM)=VOLTOT(IBM)+VOL + FHOMM(IBM,:NG)=FHOMM(IBM,:NG)+REAL(MATMUL(L(:NG,:NG,I), + 1 FLX1(IBM,:NG))+MATMUL(L(:NG,NG+1:2*NG,I),JXM(IBM,:NG)),4)*VOL + FHOMP(IBM,:NG)=FHOMP(IBM,:NG)+REAL(MATMUL(R(:NG,:NG,I), + 1 FLX1(IBM,:NG))+MATMUL(R(:NG,NG+1:2*NG,I),JXP(IBM,:NG)),4)*VOL + ENDDO + IF(IPRINT.GT.0) THEN + WRITE(6,'(/23H BREANM: SURFACE FLUXES)') + DO I=1,LX1 + IBM=IMIX(I) + IF(IBM.EQ.0) CYCLE + WRITE(6,'(/8H REGION=,I5)') I + WRITE(6,20) 'fluxm',REAL(MATMUL(L(:NG,:NG,I), + 1 FLX1(IBM,:NG))+MATMUL(L(:NG,NG+1:2*NG,I),JXM(IBM,:NG)),4) + WRITE(6,20) 'fluxp',REAL(MATMUL(R(:NG,:NG,I), + 1 FLX1(IBM,:NG))+MATMUL(R(:NG,NG+1:2*NG,I),JXP(IBM,:NG)),4) + ENDDO + ENDIF + DO IBM=1,NMIX1 + DO IGR=1,NG + FDXM(IBM,IGR)=VOLTOT(IBM)*FHETXM(IBM,IGR)/FHOMM(IBM,IGR) + FDXP(IBM,IGR)=VOLTOT(IBM)*FHETXP(IBM,IGR)/FHOMP(IBM,IGR) + ENDDO + ENDDO + IF(IPRINT.GT.0) THEN + WRITE(6,'(/48H BREANM: DISCONTINUITY FACTORS BEFORE NORMALIZAT, + 1 3HION)') + DO IBM=1,NMIX1 + WRITE(6,'(/9H MIXTURE=,I5)') IBM + WRITE(6,20) 'FDXM',FDXM(IBM,:NG) + WRITE(6,20) 'FDXP',FDXP(IBM,:NG) + ENDDO + ENDIF +*---- +* COMPUTE ALBEDOS +*---- + IF(ICODE(2).NE.0) THEN + BETA(:)=0.0 + IBM=IMIX(LX1) + DO IGR=1,NG + IF(IBM.EQ.0) CYCLE + AFACTOR(IGR)=FDXP(IBM,IGR)*JXP(IBM,IGR)/FHETXP(IBM,IGR) + BETA(IGR)=(1.0-2.0*AFACTOR(IGR))/(1.0+2.0*AFACTOR(IGR)) + ENDDO + IF(IPRINT.GT.0) THEN + WRITE(6,'(/16H BREANM: ALBEDOS)') + WRITE(6,20) 'BETA',BETA(:NG) + ENDIF + ENDIF +*---- +* NGET NORMALIZATION OF THE DISCONTINUITY FACTORS +*---- + IF(J_FUEL.GT.0) THEN + IF(NGET.GT.0) THEN + IBM=IMIX(J_FUEL) + DO IGR=1,NG + ! impose the adf on the fuel assembly side + IF(IBM.EQ.0) CYCLE + IF(NGET.EQ.1) THEN + FNORM=ADFREF(IGR)/FDXP(IBM,IGR) + ELSE + FNORM=ADF1(IBM,IGR)/FDXP(IBM,IGR) + ENDIF + FDXP(IBM,IGR)=FDXP(IBM,IGR)*FNORM + IF(J_FUEL1) THEN + IBMM=IMIX(J-1) + IF(IBMM.GT.0) FDXP(IBMM,IGR)=FDXP(IBMM,IGR)*FDXP(IBM,IGR)/ + 1 FDXM(IBM,IGR) + ENDIF + FDXM(IBM,IGR)=FDXP(IBM,IGR) + ENDDO + ENDDO + ENDIF + DO J=J_FUEL+1,LX1 + IBM=IMIX(J) + IF(IBM.EQ.0) CYCLE + DO IGR=1,NG + IF(J LX1,NMIX1,NMIX2,ITRIAL,IDIFF,NLF,IMIX1,IGAP,HMREFL,ISPH,LALB, + > NGET,ADFREF,IPRINT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Driver for the 1D reflector calculation. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NC number of sn macrolibs (=1: DF-NEM or DF-ANM; =2:Lefebvre- +* Lebigot or Koebke method; >=2 ERM-NEM). +* IPGEO1 nodal geometry. +* IPMAC1 nodal macrolib. +* IPGEO2 sn geometry. +* IPEDI2 sn edition. +* IELEM Raviart-Thomas polynomial order. +* ICOL Raviart-Thomas polynomial integration type. +* NG number of energy groups. +* LX1 number of nodes in the nodal calculation. +* NMIX1 number of mixtures in the nodal calculation. +* NMIX2 number of mixtures in the sn calculation after edition. +* ITRIAL type of expansion functions in the nodal calculation. +* (=1: polynomial; =2: hyperbolic). +* IDIFF PN calculation option (=0: diffusion theory; =1: SPN theory +* with NTOT1; =2: SPN theory with 1/(3*D)). +* NLF (NLF-1) is the SPN order (-1: diffusion theory; even integer: +* SPN theory). +* IMIX1 mix index of node (equal to zero if the node is not used). +* IGAP mix index of the right gap where the surface flux is +* recovered (equal to zero if no gap is defined). +* HMREFL type of reflector model. +* ISPH SPH flag (=0: use discontinuity factors; =1: use SPH factors). +* LALB albedo flag (=.TRUE.: compute an equivalent albedo with FD-NEM +* and ERM-NEM methods). +* NGET type of NGET normalization if discontinuity factors +* (=0: simple; =1: imposed ADF on fuel assembly; =2: recover +* fuel assembly ADF from input macrolib). +* ADFREF imposed ADF values on fuel assembly side. +* IPRINT edition flag. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NC + TYPE(C_PTR) IPGEO1,IPMAC1,IPGEO2,IPEDI2(NC) + INTEGER IELEM,ICOL,NG,LX1,NMIX1,NMIX2,ITRIAL(NG),IDIFF,NLF, + 1 IMIX1(LX1),IGAP(LX1),ISPH,NGET,IPRINT + REAL ADFREF(NG) + CHARACTER HMREFL*12 + LOGICAL LALB +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + INTEGER ISTATE(NSTATE),NCODE(6),ICODE(6) + REAL ZCODE(6) + CHARACTER HSMG*131,HCASE*12 + LOGICAL LREFL +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IHOM,IMIX,IMIXS,ISPLTX, + 1 ISTOP + REAL, ALLOCATABLE, DIMENSION(:) :: XXX,XXXS,XXX1,ENER,ZKEFF,B2 + REAL, ALLOCATABLE, DIMENSION(:,:) :: VOL1 + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: FLX1,DC1,CHI1,SIGF1,JXM, + 1 JXP,ADF1 + REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: TOT1,FHETXM,FHETXP + REAL, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: SCAT1 + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPMAC2 +*---- +* RECOVER SN MACROLIBS +*---- + ALLOCATE(IPMAC2(NC)) + ILEAKS=0 + IDF=0 + DO IC=1,NC + CALL LCMGET(IPEDI2(IC),'STATE-VECTOR',ISTATE) + IF(IC.EQ.1) THEN + LXMS=ISTATE(17) + ALLOCATE(IHOM(LXMS),ENER(NG+1)) + ELSE + IF(ISTATE(17).NE.LXMS) CALL XABORT('BREDRV: INVALID LXMS.') + ENDIF + CALL LCMGET(IPEDI2(IC),'REF:MATCOD',IHOM) + NMIX_SN=MAXVAL(IHOM) + CALL LCMGET(IPEDI2(IC),'REF:IMERGE',IHOM) + CALL LCMGTC(IPEDI2(IC),'LAST-EDIT',12,HCASE) + IPMAC2(IC)=LCMGID(IPEDI2(IC),HCASE) + IPMAC2(IC)=LCMGID(IPMAC2(IC),'MACROLIB') + CALL LCMGET(IPMAC2(IC),'STATE-VECTOR',ISTATE) + IF(ISTATE(1).NE.NG) THEN + CALL XABORT('BREDRV: INVALID NUMBER OF CONDENSED GROUPS.') + ELSE IF(ISTATE(2).NE.NMIX2) THEN + CALL XABORT('BREDRV: INVALID NUMBER OF SN MIXTURES.') + ELSE IF(ISTATE(4).NE.1) THEN + CALL XABORT('BREDRV: ONE FISSILE ISOTOPE EXPECTED.') + ENDIF + IF(IC.EQ.1) THEN + ILEAKS=ISTATE(9) + IDF=ISTATE(12) + CALL LCMGET(IPMAC2(1),'ENERGY',ENER) + ENDIF + ENDDO + IF((NGET.EQ.2).AND.(IDF.NE.3)) THEN + CALL XABORT('BREDRV: MISSING ADF INFO IN INPUT MACROLIB.') + ENDIF +*---- +* RECOVER AND PROCESS GEOMETRY INFORMATION +*---- + CALL LCMGET(IPGEO2,'STATE-VECTOR',ISTATE) + CALL LCMGET(IPGEO2,'NCODE',NCODE) + CALL LCMGET(IPGEO2,'ICODE',ICODE) + CALL LCMGET(IPGEO2,'ZCODE',ZCODE) + LREFL=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.6).AND.(ZCODE(1).EQ.1.0)) + IF(ISTATE(1).NE.2) THEN + CALL XABORT('BREDRV: 1D SLAB GEOMETRY EXPECTED.') + ELSE IF(ISTATE(8).NE.0) THEN + CALL XABORT('BREDRV: CELL OPTION IS FORBIDDEN.') + ELSE IF(ISTATE(7).NE.NMIX_SN) THEN + WRITE(HSMG,'(40H BREDRV: INVALID NUMBER OF SN MIX (GEOM=,I5, + 1 7H MACRO=,I5,2H).)') ISTATE(7),NMIX_SN + CALL XABORT(HSMG) + ELSE IF(.NOT.LREFL) THEN + CALL XABORT('BREDRV: REFLEXION MANDATORY AT LEFT BOUNDARY.') + ENDIF + LX=ISTATE(3) + ALLOCATE(IMIX(LX),XXX(LX+1),ISPLTX(LX)) + CALL LCMGET(IPGEO2,'MIX',IMIX) + CALL LCMGET(IPGEO2,'MESHX',XXX) + CALL LCMLEN(IPGEO2,'SPLITX',ILEN2,ITYLCM) + IF(ILEN2.GT.0) THEN + CALL LCMGET(IPGEO2,'SPLITX',ISPLTX) + ELSE + ISPLTX(:LX)=1 + ENDIF + LXS=0 + DO I=1,LX + LXS=LXS+ABS(ISPLTX(I)) + ENDDO + IF(LXS.NE.LXMS) THEN + WRITE(HSMG,'(41H BREDRV: INVALID NUMBER OF REGIONS (GEOM=,I5, + 1 9H EDITION=,I5,2H).)') LXS,LXMS + CALL XABORT(HSMG) + ENDIF + ALLOCATE(IMIXS(LXS),XXXS(LXS+1)) + IF(NCODE(2).EQ.5) THEN + DEL=XXX(LX+1)-XXX(LX) + IF(MOD(ISPLTX(LX),2).EQ.0) THEN + ISPLTX(LX)=ISPLTX(LX)/2 + NCODE(2)=2 + XXX(LX+1)=XXX(LX)+REAL(0.5*DEL) + ELSE + IGAR=ISPLTX(LX) + ISPLTX(LX)=(ISPLTX(LX)+1)/2 + XXX(LX+1)=XXX(LX)+REAL(DEL*(DBLE(ISPLTX(LX))/DBLE(IGAR))) + ENDIF + ENDIF + K=LXS+1 + GAR=XXX(LX+1) + DO IOLD=LX,1,-1 + ISP=ISPLTX(IOLD) + DEL=(GAR-XXX(IOLD))/REAL(ISP) + GAR=XXX(IOLD) + DO I=ABS(ISP),1,-1 + XXXS(K)=REAL(GAR+DEL*DBLE(I)) + K=K-1 + IMIXS(K)=IMIX(IOLD) + ENDDO + ENDDO + XXXS(1)=XXX(1) + DEALLOCATE(ISPLTX,XXX,IMIX) + ALLOCATE(XXX1(LX1+1),ISTOP(LX1)) + ISTOP(:LX1)=0 + DO I=1,LXS + DO J=1,LX1 + IF(IHOM(I).EQ.IGAP(J)) THEN + IF((ISTOP(J).NE.0).AND.(IGAP(J).NE.0)) THEN + WRITE(HSMG,'(23H BREDRV: GAP WITH INDEX,I5,10H IS DEFINE, + 1 8HD TWICE.)') IGAP(J) + CALL XABORT(HSMG) + ENDIF + ISTOP(J)=I + ENDIF + ENDDO + ENDDO + IF(IPRINT.GE.0) THEN + WRITE(6,'(/20H BREDRV: SN GEOMETRY)') + WRITE(6,'(1P,10E12.4)') XXXS(:LXS+1) + ENDIF + XXX1(1)=XXXS(1) + XXX1(LX1+1)=XXXS(LXS+1) + IOF=0 + DO J=1,LX1 + IOF=IOF+1 + IF((IMIX1(J).NE.0) .AND.(IMIX1(J).NE.IOF)) THEN + CALL XABORT('BREDRV: INCONSISTENT MIX VALUE.') + ENDIF + IF(ISTOP(J).GT.0) THEN + IOF=IOF+1 + XXX1(J+1)=XXXS(ISTOP(J)) + ENDIF + ENDDO + NCODE(1)=2 + ICODE(:2)=0 + IF(LALB.AND.(IGAP(LX1).NE.0)) THEN + NCODE(2)=6 + ICODE(2)=1 + ENDIF + DEALLOCATE(ISTOP) + ISTATE(:)=0 + ISTATE(1)=2 + ISTATE(3)=LX1 + ISTATE(6)=LX1 + ISTATE(7)=NMIX1 + CALL LCMPUT(IPGEO1,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMPUT(IPGEO1,'NCODE',6,1,NCODE) + CALL LCMPUT(IPGEO1,'ICODE',6,1,ICODE) + CALL LCMPUT(IPGEO1,'ZCODE',6,2,ZCODE) + ALLOCATE(IMIX(LX1)) + IMIX(:)=0 + IOF=0 + DO J=1,LX1 + IF(IMIX1(J).NE.0) THEN + IOF=IOF+1 + IMIX(J)=IOF + ENDIF + ENDDO + CALL LCMPUT(IPGEO1,'MIX',LX1,1,IMIX) + CALL LCMPUT(IPGEO1,'MESHX',LX1+1,2,XXX1) + IF(IPRINT.GE.0) THEN + WRITE(6,'(/23H BREDRV: NODAL GEOMETRY)') + WRITE(6,'(1P,10E12.4)') XXX1(:LX1+1) + ENDIF +*---- +* COMPUTE MACROSCOPIC CROSS SECTIONS AND SURFACIC DATA +*---- + NL=NLF + ALLOCATE(VOL1(NMIX1,NC),FLX1(NMIX1,NG,NC),DC1(NMIX1,NG,NC), + 1 TOT1(NMIX1,NG,NL,NC),CHI1(NMIX1,NG,NC),SIGF1(NMIX1,NG,NC), + 2 SCAT1(NMIX1,NG,NG,NL,NC),JXM(NMIX1,NG,NC),JXP(NMIX1,NG,NC), + 3 FHETXM(NMIX1,NG,NL,NC),FHETXP(NMIX1,NG,NL,NC),ADF1(NMIX1,NG,NC), + 4 ZKEFF(NC),B2(NC)) + CALL BREMAC(NC,IPMAC2,NG,NL,LX1,NMIX1,NMIX2,IMIX,IMIX1,IGAP, + 1 ILEAKS,IDF,IPRINT,ZKEFF,B2,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1, + 2 JXM,JXP,FHETXM,FHETXP,ADF1) +*---- +* SELECT A REFLECTOR MODEL +*---- + IF(HMREFL.EQ."DF-NEM") THEN + IF(NC.NE.1) CALL XABORT('BREDRV: NC=1 EXPECTED.') + CALL BRENEM(IPMAC1,NG,LX1,NMIX1,ITRIAL,IMIX,ICODE,ISPH,ZKEFF, + 1 B2,ENER,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1,JXM,JXP,FHETXM, + 2 FHETXP,ADF1,NGET,ADFREF,IPRINT) + ELSE IF(HMREFL.EQ."DF-ANM") THEN + IF(NC.NE.1) CALL XABORT('BREDRV: NC=1 EXPECTED.') + CALL BREANM(IPMAC1,NG,LX1,NMIX1,IMIX,ICODE,ISPH,ZKEFF,B2,ENER, + 1 XXX1,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1,JXM,JXP,FHETXM,FHETXP, + 2 ADF1,NGET,ADFREF,IPRINT) + ELSE IF(HMREFL.EQ."DF-RT") THEN + IF(NC.NE.1) CALL XABORT('BREDRV: NC=1 EXPECTED.') + CALL BRERT(IPMAC1,IELEM,ICOL,NG,NL,LX1,NMIX1,IMIX,ICODE,ISPH, + 1 IDIFF,ZKEFF,B2,ENER,XXX1,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1, + 2 JXM,JXP,FHETXM,FHETXP,ADF1,NGET,ADFREF,IPRINT) + ELSE IF(HMREFL.EQ."ERM-NEM") THEN + CALL BREERM(IPMAC1,NC,NG,NL,LX1,NMIX1,ITRIAL,IMIX,ICODE,ISPH, + 1 ZKEFF,B2,ENER,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1,JXM,JXP, + 2 FHETXM,FHETXP,ADF1,NGET,ADFREF,IPRINT) + ELSE IF(HMREFL.EQ."ERM-ANM") THEN + CALL BREERA(IPMAC1,NC,NG,NL,LX1,NMIX1,IMIX,ICODE,ISPH,ZKEFF,B2, + 1 ENER,XXX1,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1,JXM,JXP,FHETXM, + 2 FHETXP,ADF1,NGET,ADFREF,IPRINT) + ELSE IF(HMREFL.EQ."LEFEBVRE-LEB") THEN + IF(NC.NE.2) CALL XABORT('BREDRV: NC=2 EXPECTED.') + CALL BRELLB(IPMAC1,NC,NG,NL,NMIX1,ENER,JXM,FHETXM,IPRINT) + ELSE IF(HMREFL.EQ."KOEBKE") THEN + IF(NC.NE.2) CALL XABORT('BREDRV: NC=2 EXPECTED.') + CALL BREKOE(IPMAC1,NC,NG,NL,NMIX1,ISPH,B2,ENER,DC1,TOT1,SCAT1, + 1 JXM,FHETXM,IPRINT) + ELSE + WRITE(HSMG,'(25H BREDRV: REFLECTOR MODEL ,A,12H IS UNKNOWN.)') + 1 HMREFL + CALL XABORT(HSMG) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IMIX,B2,ZKEFF,ADF1,FHETXP,FHETXM,JXP,JXM,SCAT1,SIGF1, + 1 CHI1,TOT1,DC1,FLX1,VOL1) + DEALLOCATE(XXX1,XXXS,IMIXS,ENER,IHOM) + DEALLOCATE(IPMAC2) + RETURN + END diff --git a/Dragon/src/BREERA.f b/Dragon/src/BREERA.f new file mode 100644 index 0000000..336032f --- /dev/null +++ b/Dragon/src/BREERA.f @@ -0,0 +1,443 @@ +*DECK BREERA + SUBROUTINE BREERA(IPMAC1,NC,NG,NL,LX1,NMIX1,IMIX,ICODE,ISPH,ZKEFF, + 1 B2,ENER,XXX1,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1,JXM,JXP,FHETXM, + 2 FHETXP,ADF1,NGET,ADFREF,IPRINT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Implement the 1D ERM-ANM reflector model. +* +*Copyright: +* Copyright (C) 2023 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMAC1 nodal macrolib. +* NC number of sn macrolibs. +* NG number of energy groups. +* NL Legendre order of TOT1 and SCAT1 arrays (=1 for isotropic +* scattering in LAB). +* LX1 number of nodes in the reflector model. +* NMIX1 number of mixtures in the nodal calculation. +* IMIX mix index of each node. +* ICODE physical albedo index on each side of the domain. +* ISPH SPH flag (=0: use discontinuity factors; =1: use SPH factors). +* ZKEFF effective multiplication factor. +* B2 buckling. +* ENER energy limits. +* XXX1 spatial mesh. +* VOL1 volumes. +* FLX1 averaged fluxes +* DC1 diffusion coefficients. +* TOT1 total cross sections. +* CHI1 fission spectra. +* SIGF1 nu*fission cross sections. +* SCAT1 scattering P0 cross sections. +* JXM left boundary currents. +* JXP right boundary currents. +* FHETXM left boundary fluxes. +* FHETXP right boundary fluxes. +* ADF1 assembly discontinuity factors from macrolib. +* NGET type of NGET normalization if discontinuity factors +* (=0: simple; =1: imposed ADF on fuel assembly; =2: recover +* fuel assembly ADF from input macrolib). +* ADFREF imposed ADF values on fuel assembly side. +* IPRINT edition flag. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMAC1 + INTEGER NC,NG,NL,LX1,NMIX1,IMIX(LX1),ICODE(2),ISPH,NGET,IPRINT + REAL ZKEFF(NC),B2(NC),ENER(NG+1),XXX1(LX1+1),VOL1(NMIX1,NC), + 1 FLX1(NMIX1,NG,NC),DC1(NMIX1,NG,NC),TOT1(NMIX1,NG,NL,NC), + 2 CHI1(NMIX1,NG,NC),SIGF1(NMIX1,NG,NC),SCAT1(NMIX1,NG,NG,NL,NC), + 3 JXM(NMIX1,NG,NC),JXP(NMIX1,NG,NC),FHETXM(NMIX1,NG,NL,NC), + 4 FHETXP(NMIX1,NG,NL,NC),ADF1(NMIX1,NG,NC),ADFREF(NG) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + INTEGER ISTATE(NSTATE) + CHARACTER(LEN=8) HADF(2) + TYPE(C_PTR) JPMAC1,KPMAC1 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) :: WORK1D,WORK1,WORK2,WORK4,WORK5, + 1 VOLTOT + REAL, ALLOCATABLE, DIMENSION(:,:) :: FLX,DC,TOT,CHI,SIGF, + 1 ADF,AFACTOR,BETA,WORK3 + REAL, ALLOCATABLE, DIMENSION(:,:,:) ::FDXM,FDXP,SCAT + REAL(KIND=8), ALLOCATABLE, DIMENSION(:) :: TAU,B,X + REAL(KIND=8), ALLOCATABLE, DIMENSION(:,:) :: WORK2D + REAL(KIND=8), ALLOCATABLE, DIMENSION(:,:,:) :: FHOMM,FHOMP,L,R +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(WORK1(NG),WORK2(NG),WORK4(NG),WORK5(NG),VOLTOT(NMIX1), + 1 FLX(NMIX1,NG),DC(NMIX1,NG),TOT(NMIX1,NG),CHI(NMIX1,NG), + 1 SIGF(NMIX1,NG),ADF(NMIX1,NG),AFACTOR(NG,NG),BETA(NG,NG)) + ALLOCATE(FDXM(NMIX1,NG,NG),FDXP(NMIX1,NG,NG),SCAT(NMIX1,NG,NG), + 1 WORK3(NG,NG)) + ALLOCATE(FHOMM(NC,NG,NMIX1),FHOMP(NC,NG,NMIX1),L(NG,2*NG,LX1), + 1 R(NG,2*NG,LX1)) +*---- +* AVERAGE THE OUTPUT NODAL MACROLIB +*---- + VOLTOT(:)=0.0 + FLX(:,:)=0.0 + DC(:,:)=0.0 + TOT(:,:)=0.0 + CHI(:,:)=0.0 + SIGF(:,:)=0.0 + SCAT(:,:,:)=0.0 + ADF(:,:)=0.0 + FHOMM(:NC,:NG,:NMIX1)=0.0D0 + FHOMP(:NC,:NG,:NMIX1)=0.0D0 + DO IC=1,NC + DO IBM=1,NMIX1 + VOLTOT(IBM)=VOLTOT(IBM)+VOL1(IBM,IC) + DO IGR=1,NG + FLX(IBM,IGR)=FLX(IBM,IGR)+FLX1(IBM,IGR,IC) + DC(IBM,IGR)=DC(IBM,IGR)+DC1(IBM,IGR,IC) + TOT(IBM,IGR)=TOT(IBM,IGR)+TOT1(IBM,IGR,1,IC) + CHI(IBM,IGR)=CHI(IBM,IGR)+CHI1(IBM,IGR,IC) + SIGF(IBM,IGR)=SIGF(IBM,IGR)+SIGF1(IBM,IGR,IC) + DO JGR=1,NG + SCAT(IBM,IGR,JGR)=SCAT(IBM,IGR,JGR)+SCAT1(IBM,IGR,JGR,1,IC) + ENDDO + ADF(IBM,IGR)=ADF(IBM,IGR)+ADF1(IBM,IGR,IC) + ENDDO + ENDDO + ENDDO + VOLTOT(:)=VOLTOT(:)/REAL(NC) + FLX(:,:)=FLX(:,:)/REAL(NC) + DC(:,:)=DC(:,:)/REAL(NC) + TOT(:,:)=TOT(:,:)/REAL(NC) + CHI(:,:)=CHI(:,:)/REAL(NC) + SIGF(:,:)=SIGF(:,:)/REAL(NC) + SCAT(:,:,:)=SCAT(:,:,:)/REAL(NC) + ADF(:,:)=ADF(:,:)/REAL(NC) +*---- +* LOOP OVER CASES +*---- + IF(ISPH.EQ.1) CALL XABORT('BREERA: SPH OPTION NOT IMPLEMENTED.') + J_FUEL=0 + DO IC=1,NC +*---- +* SET AND SOLVE ANALYTIC NODAL SYSTEM +*---- + DO I=1,LX1 + IBM=IMIX(I) + IF(IBM.EQ.0) CYCLE + WORK1(:NG)=DC1(IBM,:NG,IC) + WORK3(:NG,:NG)=SCAT1(IBM,:NG,:NG,1,IC) + WORK4(:NG)=CHI1(IBM,:NG,IC) + WORK5(:NG)=SIGF1(IBM,:NG,IC) + DO IGR=1,NG + IF(SIGF1(IBM,IGR,IC).GT.0.0) J_FUEL=I + WORK2(IGR)=TOT1(IBM,IGR,1,IC)+B2(IC)*DC1(IBM,IGR,IC)- + 1 SCAT1(IBM,IGR,IGR,1,IC) + ENDDO + VOL=XXX1(I+1)-XXX1(I) + CALL NSSLR1(ZKEFF(IC),NG,VOL,WORK1,WORK2,WORK3,WORK4,WORK5, + 1 L(1,1,I),R(1,1,I)) + ! + FHOMM(IC,:NG,IBM)=FHOMM(IC,:NG,IBM)+REAL(MATMUL(L(:NG,:NG,I), + 1 FLX1(IBM,:NG,IC))+ + 2 MATMUL(L(:NG,NG+1:2*NG,I),JXM(IBM,:NG,IC)),4)*VOL + FHOMP(IC,:NG,IBM)=FHOMP(IC,:NG,IBM)+REAL(MATMUL(R(:NG,:NG,I), + 1 FLX1(IBM,:NG,IC))+ + 2 MATMUL(R(:NG,NG+1:2*NG,I),JXP(IBM,:NG,IC)),4)*VOL + ENDDO + DO IBM=1,NMIX1 + FHOMM(IC,:NG,IBM)=FHOMM(IC,:NG,IBM)/VOLTOT(IBM) + FHOMP(IC,:NG,IBM)=FHOMP(IC,:NG,IBM)/VOLTOT(IBM) + ENDDO + IF(IPRINT.GT.0) THEN + WRITE(6,'(/39H BREERA: NODAL SURFACE FLUXES FOR CASE=,I5)') IC + DO IBM=1,NMIX1 + WRITE(6,'(/9H MIXTURE=,I5)') IBM + WRITE(6,20) 'FHOMM',FHOMM(IC,:NG,IBM) + WRITE(6,20) 'FHOMP',FHOMP(IC,:NG,IBM) + ENDDO + ENDIF +*---- +* END OF LOOP OVER CASES +*---- + ENDDO +*---- +* COMPUTE DISCONTINUITY AND ALBEDO FACTORS +*---- + AFACTOR(:,:)=0.0 + DO IBM=1,NMIX1 + IF(NC.EQ.1) THEN + ! DF-NEM approach + FDXM(IBM,:,:)=0.0 + FDXP(IBM,:,:)=0.0 + DO IGR=1,NG + FDXM(IBM,IGR,IGR)=FHETXM(IBM,IGR,1,1)/REAL(FHOMM(1,IGR,IBM)) + FDXP(IBM,IGR,IGR)=FHETXP(IBM,IGR,1,1)/REAL(FHOMP(1,IGR,IBM)) + ENDDO + IF(IBM.EQ.NMIX1) THEN + DO IGR=1,NG + AFACTOR(IGR,IGR)=JXP(IBM,IGR,1)/REAL(FHOMP(1,IGR,IBM)) + ENDDO + ENDIF + ELSE IF(NC.LT.NG) THEN + CALL XABORT('BREERA: DEGENERATE SYSTEM') + ELSE IF(NC.EQ.NG) THEN + ! ERM-ANM approach: linear system resolution + ALLOCATE(WORK2D(NC,2*NG)) + DO IGR=1,NG + DO IC=1,NC + WORK2D(IC,IGR)=FHOMM(IC,IGR,IBM) + WORK2D(IC,NG+IGR)=FHETXM(IBM,IGR,1,IC) + ENDDO + ENDDO + CALL ALSBD(NC,NG,WORK2D,IER,NC) + IF(IER.NE.0) CALL XABORT('BREERA: SINGULAR MATRIX(1).') + DO IGR=1,NG + DO IC=1,NC + FDXM(IBM,IGR,IC)=REAL(WORK2D(IC,NG+IGR)) + ENDDO + ENDDO + DO IGR=1,NG + DO IC=1,NC + WORK2D(IC,IGR)=FHOMP(IC,IGR,IBM) + WORK2D(IC,NG+IGR)=FHETXP(IBM,IGR,1,IC) + ENDDO + ENDDO + CALL ALSBD(NC,NG,WORK2D,IER,NC) + IF(IER.NE.0) CALL XABORT('BREERA: SINGULAR MATRIX(2).') + DO IGR=1,NG + DO IC=1,NC + FDXP(IBM,IGR,IC)=REAL(WORK2D(IC,NG+IGR)) + ENDDO + ENDDO + IF(IBM.EQ.NMIX1) THEN + DO IGR=1,NG + DO IC=1,NC + WORK2D(IC,IGR)=FHOMP(IC,IGR,IBM) + WORK2D(IC,NG+IGR)=JXP(IBM,IGR,IC) + ENDDO + ENDDO + CALL ALSBD(NC,NG,WORK2D,IER,NC) + IF(IER.NE.0) CALL XABORT('BREERA: SINGULAR MATRIX(3).') + DO IGR=1,NG + DO JGR=1,NG + AFACTOR(IGR,JGR)=REAL(WORK2D(JGR,NG+IGR)) + ENDDO + ENDDO + ENDIF + DEALLOCATE(WORK2D) + ELSE IF(NC.GE.NG) THEN + ! ERM-ANM approach: pseudo inversion + ALLOCATE(TAU(NG),B(NC),X(NG)) + CALL ALST2F(NC,NC,NG,FHOMM(1,1,IBM),TAU) + DO IGR=1,NG + B(:)=FHETXM(IBM,IGR,1,:) + CALL ALST2S(NC,NC,NG,FHOMM(1,1,IBM),TAU,B,X) + FDXM(IBM,IGR,:)=REAL(X(:)) + ENDDO + CALL ALST2F(NC,NC,NG,FHOMP(1,1,IBM),TAU) + DO IGR=1,NG + B(:)=FHETXP(IBM,IGR,1,:) + CALL ALST2S(NC,NC,NG,FHOMP(1,1,IBM),TAU,B,X) + FDXP(IBM,IGR,:)=REAL(X(:)) + ENDDO + IF(IBM.EQ.NMIX1) THEN + DO IGR=1,NG + B(:)=JXP(IBM,IGR,:) + CALL ALST2S(NC,NC,NG,FHOMP(1,1,IBM),TAU,B,X) + AFACTOR(IGR,:)=REAL(X(:)) + ENDDO + ENDIF + DEALLOCATE(X,B,TAU) + ENDIF + ENDDO + IF(IPRINT.GT.0) THEN + WRITE(6,'(/48H BREERA: DISCONTINUITY FACTORS BEFORE NORMALIZAT, + 1 3HION)') + DO IBM=1,NMIX1 + WRITE(6,'(/9H MIXTURE=,I5)') IBM + WRITE(6,20) 'FDXM',FDXM(IBM,:NG,:NG) + WRITE(6,20) 'FDXP',FDXP(IBM,:NG,:NG) + ENDDO + ENDIF +*---- +* COMPUTE ALBEDOS +*---- + IF(ICODE(2).NE.0) THEN + BETA(:,:)=0.0 + DO IGR=1,NG + DO JGR=1,NG + BETA(IGR,JGR)=(1.0-2.0*AFACTOR(IGR,JGR))/(1.0+2.0* + 1 AFACTOR(IGR,JGR)) + ENDDO + ENDDO + IF(IPRINT.GT.0) THEN + WRITE(6,'(/16H BREERA: ALBEDOS)') + WRITE(6,20) 'BETA',BETA(:NG,:NG) + ENDIF + ENDIF +*---- +* NGET NORMALIZATION OF THE DISCONTINUITY FACTORS +*---- + ALLOCATE(WORK2D(NG,2*NG)) + DO J=1,LX1-1 + IBM=IMIX(J) + IBMP=IMIX(J+1) + IF((IBM.EQ.0).OR.(IBMP.EQ.0)) CYCLE + DO IGR=1,NG + DO JGR=1,NG + WORK2D(IGR,JGR)=FDXP(IBM,IGR,JGR) + WORK2D(IGR,NG+JGR)=FDXM(IBMP,IGR,JGR) + ENDDO + ENDDO + CALL ALSBD(NG,NG,WORK2D,IER,NG) + IF(IER.NE.0) CALL XABORT('BREERA: SINGULAR MATRIX(3).') + DO IGR=1,NG + ! impose the adf on the fuel assembly side + IF((J.EQ.J_FUEL).AND.(NGET.EQ.1)) THEN + FNORM=ADFREF(IGR) + ELSE IF((J.EQ.J_FUEL).AND.(NGET.EQ.2)) THEN + FNORM=ADF(IBM,IGR) + ELSE + FNORM=FDXP(IBM,IGR,IGR) + ENDIF + FDXP(IBM,IGR,:)=0.0 + FDXP(IBM,IGR,IGR)=FNORM + DO JGR=1,NG + FDXM(IBMP,IGR,JGR)=REAL(WORK2D(IGR,NG+JGR))*FNORM + ENDDO + ENDDO + ENDDO + DEALLOCATE(WORK2D) + IF(J_FUEL.GT.0) THEN + DO J=J_FUEL,1,-1 + IBM=IMIX(J) + IF(IBM.EQ.0) CYCLE + DO IGR=1,NG + FNORM=FDXP(IBM,IGR,IGR)/FDXM(IBM,IGR,IGR) + DO JGR=1,NG + IF(J>1) THEN + IBMM=IMIX(J-1) + IF(IBMM.GT.0) FDXP(IBMM,IGR,JGR)=FDXP(IBMM,IGR,JGR)*FNORM + ENDIF + FDXM(IBM,IGR,JGR)=FDXM(IBM,IGR,JGR)*FNORM + ENDDO + ENDDO + ENDDO + ENDIF + DO J=J_FUEL+1,LX1 + IBM=IMIX(J) + IF(IBM.EQ.0) CYCLE + DO IGR=1,NG + FNORM=FDXM(IBM,IGR,IGR)/FDXP(IBM,IGR,IGR) + DO JGR=1,NG + IF(J1) THEN + IBMM=IMIX(J-1) + IF(IBMM.GT.0) FDXP(IBMM,IGR,JGR)=FDXP(IBMM,IGR,JGR)*FNORM + ENDIF + FDXM(IBM,IGR,JGR)=FDXM(IBM,IGR,JGR)*FNORM + ENDDO + ENDDO + ENDDO + ENDIF + DO J=J_FUEL+1,LX1 + IBM=IMIX(J) + IF(IBM.EQ.0) CYCLE + DO IGR=1,NG + FNORM=FDXM(IBM,IGR,IGR)/FDXP(IBM,IGR,IGR) + DO JGR=1,NG + IF(J=4 PARAMETERS EXPECTED.') + NC=NENTRY-3 + ALLOCATE(IPEDI2(NC)) + DO IEN=1,2 + IF((IENTRY(IEN).NE.1).AND.(IENTRY(IEN).NE.2)) CALL XABORT('BREF' + 1 //': LCM OBJECT EXPECTED AT LHS.') + IF(JENTRY(IEN).NE.0) CALL XABORT('BREF: ENTRY IN CREATE MODE EX' + 1 //'PECTED.') + IF(IEN.EQ.1) THEN + HSIGN='L_GEOM' + IPGEO1=KENTRY(1) + ELSE IF(IEN.EQ.2) THEN + HSIGN='L_MACROLIB' + IPMAC1=KENTRY(2) + ENDIF + CALL LCMPTC(KENTRY(IEN),'SIGNATURE',12,HSIGN) + ENDDO + DO IEN=3,NENTRY + IF((IENTRY(IEN).NE.1).AND.(IENTRY(IEN).NE.2)) CALL XABORT('BREF' + 1 //': LCM OBJECT EXPECTED AT LHS.') + IF(JENTRY(IEN).NE.2) CALL XABORT('BREF: ENTRY IN READ-ONLY MODE' + 1 //' EXPECTED.') + CALL LCMGTC(KENTRY(IEN),'SIGNATURE',12,HSIGN) + TEXT12=HENTRY(IEN) + IF(IEN.EQ.3) THEN + IF(HSIGN.NE.'L_GEOM') THEN + CALL XABORT('BREF: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_GEOM EXPECTED.') + ENDIF + IPGEO2=KENTRY(3) + ELSE IF(IEN.GE.4) THEN + IF(HSIGN.NE.'L_EDIT') THEN + CALL XABORT('BREF: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_EDIT EXPECTED.') + ENDIF + IPEDI2(IEN-3)=KENTRY(IEN) + ENDIF + ENDDO + CALL LCMGET(IPEDI2(1),'STATE-VECTOR',ISTATE) + NMIX2=ISTATE(1) + NG=ISTATE(2) +*--- +* READ DATA +*--- + ALLOCATE(ITRIAL(NG),ADFREF(NG)) + IPRINT=1 + ITRIAL(:)=1 + HMREFL=' ' + ISPH=0 + LX1=0 + LALB=.TRUE. + NGET=0 + IELEM=0 + ICOL=0 + IDIFF=0 + NLF=1 + 10 CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT4,DBLLIR) + IF(ITYPLU.EQ.10) CALL XABORT('BREF: MISSING USER DATA.') + IF(ITYPLU.NE.3) CALL XABORT('BREF: READ ERROR - CHARACTER VARIAB' + > //'LE EXPECTED') + 20 IF(TEXT4.EQ.';') THEN + GO TO 100 + ELSE IF(TEXT4.EQ.'EDIT') THEN + CALL REDGET(ITYPLU,IPRINT,REALIR,TEXT4,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('BREF: READ ERROR - INTEGER VARIAB' + > //'LE EXPECTED(1)') + ELSE IF(TEXT4.EQ.'HYPE') THEN + CALL REDGET(ITYPLU,IGMAX,REALIR,TEXT4,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('BREF: READ ERROR - INTEGER VARIAB' + > //'LE EXPECTED(2)') + IF(IGMAX.LE.0) CALL XABORT('BREF: IGMAX<=0.') + IF(IGMAX.GT.NG) THEN + WRITE(HSMG,'(12HBREF: (HYPE=,I3,8H) > (NG=,I3,2H).)') IGMAX,NG + CALL XABORT(HSMG) + ENDIF + ITRIAL(IGMAX:NG)=2 + ELSE IF(TEXT4.EQ.'MIX') THEN + ALLOCATE(IMIX1(NMIX2)) + 30 CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT4,DBLLIR) + IF(ITYPLU.EQ.1) THEN + LX1=LX1+1 + IF(LX1.GT.NMIX2) CALL XABORT('BREF: LX1 OVERFLOW.') + IF(INTLIR.GT.NMIX2) THEN + WRITE(HSMG,'(12HBREF: IMIX1=,I5,9H > NMIX2=,I5,1H.)') + > INTLIR,NMIX2 + CALL XABORT(HSMG) + ENDIF + IMIX1(LX1)=INTLIR + GO TO 30 + ELSE IF(ITYPLU.EQ.3) THEN + GO TO 20 + ELSE + CALL XABORT('BREF: READ ERROR - INTEGER OR CHARACTER VARIABL' + > //'E EXPECTED') + ENDIF + ELSE IF(TEXT4.EQ.'GAP') THEN + ALLOCATE(IGAP(LX1)) + DO IBM1=1,LX1 + CALL REDGET(ITYPLU,IGAP(IBM1),REALIR,TEXT4,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('BREF: READ ERROR - INTEGER VARI' + > //'ABLE EXPECTED(3)') + IF(IGAP(IBM1).GT.NMIX2) THEN + WRITE(HSMG,'(11HBREF: IGAP=,I5,9H > NMIX2=,I5,1H.)') + > IGAP(IBM1),NMIX2 + CALL XABORT(HSMG) + ENDIF + ENDDO + ELSE IF(TEXT4.EQ.'MODE') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,HMREFL,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('BREF: READ ERROR - CHARACTER VARI' + > //'ABLE EXPECTED') + IF(HMREFL.EQ.'DF-RT') THEN + ! Raviart-Thomas equivalence. + CALL REDGET(ITYPLU,IELEM,REALIR,TEXT4,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('BREF: READ ERROR - INTEGER VARI' + > //'ABLE EXPECTED(4)') + CALL REDGET(ITYPLU,ICOL,REALIR,TEXT4,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('BREF: READ ERROR - INTEGER VARI' + > //'ABLE EXPECTED(5)') + ISPH=1 + CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT4,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('BREF: READ ERROR - CHARACTER VA' + > //'RIABLE EXPECTED') + IF(TEXT4.EQ.'SPN') THEN + IDIFF=1 + CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT4,DBLLIR) + IF(ITYPLU.EQ.1) THEN + NLF=INTLIR+1 + ELSE IF((ITYPLU.EQ.3).AND.(TEXT4.EQ.'DIFF')) THEN + IDIFF=2 + CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT4,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('BREF: READ ERROR - INTEGER ' + > //'VARIABLE EXPECTED(6)') + NLF=INTLIR+1 + ELSE + CALL XABORT('BREF: READ ERROR - INTEGER OR DIFF KEYWORD ' + > //'EXPECTED') + ENDIF + IF(MOD(NLF,2).NE.0) CALL XABORT('BREF: ODD VALUE EXPECTED.') + ELSE + GO TO 20 + ENDIF + ENDIF + ELSE IF(TEXT4.EQ.'NOSP') THEN + ISPH=0 + ELSE IF(TEXT4.EQ.'SPH') THEN + ISPH=1 + ELSE IF(TEXT4.EQ.'ALBE') THEN + LALB=.TRUE. + ELSE IF(TEXT4.EQ.'NOAL') THEN + LALB=.FALSE. + ELSE IF(TEXT4.EQ.'NGET') THEN + NGET=1 + DO IGR=1,NG + CALL REDGET(ITYPLU,INTLIR,ADFREF(IGR),TEXT4,DBLLIR) + IF(ITYPLU.EQ.2) THEN + CYCLE + ELSE IF(ITYPLU.EQ.3) THEN + NGET=2 + GO TO 20 + ELSE + CALL XABORT('BREF: READ ERROR - REAL OR CHARACTER VARIABLE' + > //' EXPECTED') + ENDIF + ENDDO + ELSE + CALL XABORT('BREF: ILLEGAL KEYWORD '//TEXT4) + ENDIF + GO TO 10 + 100 NMIX1=0 + DO IBM1=1,LX1 + IF(IMIX1(IBM1).NE.0) NMIX1=NMIX1+1 + ENDDO + CALL BREDRV(NC,IPGEO1,IPMAC1,IPGEO2,IPEDI2,IELEM,ICOL,NG,LX1, + > NMIX1,NMIX2,ITRIAL,IDIFF,NLF,IMIX1,IGAP,HMREFL,ISPH,LALB,NGET, + > ADFREF,IPRINT) + DEALLOCATE(IMIX1,IGAP,ADFREF,ITRIAL,IPEDI2) + IF(IPRINT.GT.0) THEN + CALL LCMGET(IPMAC1,'STATE-VECTOR',ISTATE) + WRITE(6,110) IPRINT,(ISTATE(I),I=1,9),ISTATE(12),ISTATE(14) + ENDIF + RETURN +* + 110 FORMAT(/17H MACROLIB OPTIONS/17H ----------------/ + 1 7H IMPX ,I6,30H (0=NO PRINT/1=SHORT/2=MORE)/ + 2 7H NGROUP,I6,28H (NUMBER OF ENERGY GROUPS)/ + 3 7H NBMIX ,I6,39H (NUMBER OF MIXTURES IN THE MACROLIB)/ + 4 7H NANISO,I6,34H (MAXIMUM SCATTERING ANISOTROPY)/ + 5 7H NIFISS,I6,45H (MAXIMUM NUMBER OF FISSILE ISOTOPES IN A M, + 6 7HIXTURE)/ + 7 7H NEDMAC,I6,34H (NUMBER OF CROSS SECTION EDITS)/ + 8 7H ITRANC,I6,45H (0=NO TRANSPORT CORRECTION/1=APOLLO TYPE/2, + 9 43H=RECOVER FROM LIBRARY/4=LEAKAGE CORRECTION)/ + 1 7H NLG ,I6,39H (NUMBER OF DELAYED PRECURSOR GROUPS)/ + 2 7H NALB ,I6,31H (NUMBER OF PHYSICAL ALBEDOS)/ + 3 7H ILEAK ,I6,40H (1=DIFF AVAILABLE; 2=DIFFX AVAILABLE)/ + 4 7H IDF ,I6,44H (=0/2/3/4 ADF INFORMATION ABSENT/PRESENT)/ + 5 7H ISPH ,I6,36H (=0/1 SPH FACTORS ABSENT/PRESENT)) + END diff --git a/Dragon/src/BREKOE.f b/Dragon/src/BREKOE.f new file mode 100644 index 0000000..d98ca1f --- /dev/null +++ b/Dragon/src/BREKOE.f @@ -0,0 +1,206 @@ +*DECK BREKOE + SUBROUTINE BREKOE(IPMAC1,NC,NG,NL,NMIX1,ISPH,B2,ENER,DC1,TOT1, + 1 SCAT1,JXM,FHETXM,IPRINT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Implement the 1D Koebke reflector model. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert and V. Salino +* +*Parameters: input +* IPMAC1 nodal macrolib. +* NC number of sn macrolibs (=2: Koebke method). +* NG number of energy groups. +* NL Legendre order of TOT1 and SCAT1 arrays (=1 for isotropic +* scattering in LAB). +* NMIX1 number of mixtures in the nodal calculation. +* ISPH SPH flag (=0: use discontinuity factors; =1: use SPH factors). +* B2 buckling. +* ENER energy limits. +* TOT1 total cross sections. +* SCAT1 scattering P0 cross sections. +* JXM left boundary currents. +* FHETXM left boundary fluxes. +* IPRINT edition flag. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMAC1 + INTEGER NC,NG,NL,NMIX1,ISPH,IPRINT + REAL B2(NC),ENER(NG+1),DC1(NMIX1,NG,NC),TOT1(NMIX1,NG,NL,NC), + 1 SCAT1(NMIX1,NG,NG,NL,NC),JXM(NMIX1,NG,NC),FHETXM(NMIX1,NG,NL,NC) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + INTEGER ISTATE(NSTATE) + CHARACTER HADF*8 + DOUBLE PRECISION R11,R21,R22,SIGR1,SIGR2,SIG21,D1,D2,A,B,C,F2 + TYPE(C_PTR) JPMAC1,KPMAC1 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) :: WORK,FDX,DIF +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IJJ(NMIX1),NJJ(NMIX1),IPOS(NMIX1),WORK(NG*NMIX1)) +*---- +* RECOVER FLUX, MACROSCOPIC CROSS SECTIONS AND DIFFUSION COEFFICIENTS +*---- + IF(NC.NE.2) CALL XABORT('BREKOE: NC=2 EXPECTED.') + IF(NG.NE.2) CALL XABORT('BREKOE: NG=2 EXPECTED.') + IF(NMIX1.NE.1) CALL XABORT('BREKOE: NMIX1=1 EXPECTED.') +*---- +* COMPUTE EQUIVALENT REFLECTOR +*---- + ALLOCATE(FDX(NG),DIF(NG)) + IBM=1 + R11=.5*(FHETXM(IBM,1,1,1)/JXM(IBM,1,1)+FHETXM(IBM,1,1,2)/ + 1 JXM(IBM,1,2)) + R21=(FHETXM(IBM,2,1,1)*JXM(IBM,2,2)-FHETXM(IBM,2,1,2)* + 1 JXM(IBM,2,1))/(JXM(IBM,1,1)*JXM(IBM,2,2)-JXM(IBM,1,2)*J + 2 XM(IBM,2,1)) + R22=(FHETXM(IBM,2,1,2)*JXM(IBM,1,1)-FHETXM(IBM,2,1,1)* + 1 JXM(IBM,1,2))/(JXM(IBM,1,1)*JXM(IBM,2,2)-JXM(IBM,1,2)* + 2 JXM(IBM,2,1)) + IF(IPRINT.GT.0) WRITE(6,10) R11,R21,R22 + SIGR1=.5*(TOT1(IBM,1,1,1)+TOT1(IBM,1,1,2)-SCAT1(IBM,1,1,1,1)- + 1 SCAT1(IBM,1,1,1,2)+B2(1)*DC1(IBM,1,1)+B2(2)*DC1(IBM,1,2)) + SIGR2=.5*(TOT1(IBM,2,1,1)+TOT1(IBM,2,1,2)-SCAT1(IBM,2,2,1,1)- + 1 SCAT1(IBM,2,2,1,2)+B2(1)*DC1(IBM,2,1)+B2(2)*DC1(IBM,2,2)) + SIG21=.5*(SCAT1(IBM,2,1,1,1)+SCAT1(IBM,2,1,1,2)) + IF(IPRINT.GT.0) WRITE(6,20) SIGR1,SIGR2,SIG21 + D1=1.0/(R11*R11*SIGR1) + A=(R21*SIGR1-R22*SIG21)*SQRT(SIGR1/SIGR2)/(R22*R22) + B=SIG21*SQRT(D1*SIGR2) + C=-R21*D1*SIGR2*SQRT(SIGR1*SIGR2) + F2=(-B+SQRT(B*B-4.0*A*C))/(2.0*A) + D2=F2*F2/(R22*R22*SIGR2) + IF(IPRINT.GT.0) WRITE(6,30) D1,D2,F2 + FDX(1)=1.0 + FDX(2)=REAL(F2) + DIF(1)=REAL(D1) + DIF(2)=REAL(D2) + IF(IPRINT.GT.0) THEN + WRITE(6,'(/37H BREKOE: KOEBKE DISCONTINUITY FACTORS)') + WRITE(6,'(/12H MIXTURE= 1)') + WRITE(6,'(6H FDX=,1P,10E13.5,/(6X,10E13.5))') FDX(:NG) + ENDIF +*---- +* APPLY SPH FACTORS +*---- + IF(ISPH.EQ.1) THEN + DO IGR=1,NG + TOT1(IBM,IGR,1,:2)=TOT1(IBM,IGR,1,:2)/FDX(IGR) + DIF(IGR)=DIF(IGR)/FDX(IGR) + DO JGR=1,NG + SCAT1(IBM,IGR,JGR,1,:2)=SCAT1(IBM,IGR,JGR,1,:2)/FDX(JGR) + ENDDO + ENDDO + ENDIF + IF(IPRINT.GT.0) THEN + WRITE(6,'(/38H BREKOE: KOEBKE DIFFUSION COEFFICIENTS)') + WRITE(6,'(/12H MIXTURE= 1)') + WRITE(6,'(6H DIFF=,1P,10E13.5,/(6X,10E13.5))') DIF(:NG) + ENDIF +*---- +* SAVE THE OUTPUT NODAL MACROLIB +*---- + IBM=1 + ISTATE(:)=0 + ISTATE(1)=NG + ISTATE(2)=NMIX1 + ISTATE(3)=1 + ISTATE(9)=1 ! diffusion coefficient information + IF(ISPH.EQ.0) ISTATE(12)=3 ! discontinuity factor information + IF(ISPH.EQ.1) ISTATE(14)=1 ! SPH factor information + CALL LCMPUT(IPMAC1,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMPUT(IPMAC1,'ENERGY',NG+1,2,ENER) + WORK(1)=1.0 + CALL LCMPUT(IPMAC1,'VOLUME',NMIX1,2,WORK) + CALL LCMPUT(IPMAC1,'B2 B1HOM',1,2,B2) + IF(ISPH.EQ.0) THEN + CALL LCMSIX(IPMAC1,'ADF',1) + NTYPE=1 + HADF='FD_B' + CALL LCMPUT(IPMAC1,'NTYPE',1,1,NTYPE) + CALL LCMPTC(IPMAC1,'HADF',8,HADF) + CALL LCMPUT(IPMAC1,HADF,NG,2,FDX) + CALL LCMSIX(IPMAC1,' ',2) + ELSE IF(ISPH.EQ.1) THEN + CALL LCMSIX(IPMAC1,'SPH',1) + ISTATE(:)=0 + ISTATE(1)=4 + ISTATE(2)=1 + ISTATE(6)=1 + ISTATE(7)=1 + ISTATE(8)=NG + CALL LCMPUT(IPMAC1,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMSIX(IPMAC1,' ',2) + ENDIF + JPMAC1=LCMLID(IPMAC1,'GROUP',NG) + DO IGR=1,NG + KPMAC1=LCMDIL(JPMAC1,IGR) + WORK(1)=1.0 + CALL LCMPUT(KPMAC1,'FLUX-INTG',NMIX1,2,WORK) + WORK(1)=0.5*(TOT1(IBM,IGR,1,1)+TOT1(IBM,IGR,1,2)) + CALL LCMPUT(KPMAC1,'NTOT0',NMIX1,2,WORK) + WORK(1)=0.0 + CALL LCMPUT(KPMAC1,'SIGW00',NMIX1,2,WORK) + CALL LCMPUT(KPMAC1,'DIFF',NMIX1,2,DIF(IGR)) + IF(ISPH.EQ.1) THEN + WORK(1)=1.0/FDX(IGR) + CALL LCMPUT(KPMAC1,'NSPH',NMIX1,2,WORK) + ENDIF + IPOSDE=0 + DO J=1,NMIX1 + IBM=1 + J2=IGR + J1=IGR + DO JGR=1,NG + IF(SCAT1(IBM,IGR,JGR,1,1)+SCAT1(IBM,IGR,JGR,1,2).NE.0.0) THEN + J2=MAX(J2,JGR) + J1=MIN(J1,JGR) + ENDIF + ENDDO + NJJ(J)=J2-J1+1 + IJJ(J)=J2 + IPOS(J)=IPOSDE+1 + DO JGR=J2,J1,-1 + IPOSDE=IPOSDE+1 + IF(IPOSDE.GT.NG*NMIX1) CALL XABORT('BREKOE: SCAT OVERFLOW.') + WORK(IPOSDE)=0.5*(SCAT1(IBM,IGR,JGR,1,1)+ + 1 SCAT1(IBM,IGR,JGR,1,2)) + ENDDO + ENDDO + CALL LCMPUT(KPMAC1,'SCAT00',IPOSDE,2,WORK) + CALL LCMPUT(KPMAC1,'NJJS00',NMIX1,1,NJJ) + CALL LCMPUT(KPMAC1,'IJJS00',NMIX1,1,IJJ) + CALL LCMPUT(KPMAC1,'IPOS00',NMIX1,1,IPOS) + ENDDO +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(DIF,FDX,WORK,IPOS,NJJ,IJJ) + RETURN +* + 10 FORMAT(13H BREKOE: R11=,1P,E12.4,5H R21=,E12.4,5H R22=,E12.4) + 20 FORMAT(15H BREKOE: SIGR1=,1P,E12.4,7H SIGR2=,E12.4,7H SIG21=, + 1 E12.4) + 30 FORMAT(12H BREKOE: D1=,1P,E12.4,4H D2=,E12.4,4H F2=,E12.4) + END diff --git a/Dragon/src/BRELLB.f b/Dragon/src/BRELLB.f new file mode 100644 index 0000000..205a994 --- /dev/null +++ b/Dragon/src/BRELLB.f @@ -0,0 +1,157 @@ +*DECK BRELLB + SUBROUTINE BRELLB(IPMAC1,NC,NG,NL,NMIX1,ENER,JXM,FHETXM,IPRINT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Implement the 1D Lefebvre-Lebigot reflector model. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert and V. Salino +* +*Parameters: input +* IPMAC1 nodal macrolib. +* NC number of sn macrolibs (=2: Lefebvre-Lebigot method). +* NG number of energy groups. +* NL Legendre order of TOT1 and SCAT1 arrays (=1 for isotropic +* scattering in LAB). +* NMIX1 number of mixtures in the nodal calculation. +* ENER energy limits. +* JXM left boundary currents. +* FHETXM left boundary fluxes. +* IPRINT edition flag. +* +*Reference: +* Edwige Richebois, 'Calculs de coeur REP en transport 3D', PhD, +* Universite Aix-Marseille, 1999 (p.193). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMAC1 + INTEGER NC,NG,NL,NMIX1,IPRINT + REAL ENER(NG+1),JXM(NMIX1,NG,NC),FHETXM(NMIX1,NG,NL,NC) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + INTEGER ISTATE(NSTATE) + REAL BF1BF2(2),CUR1BF1(2),CUR2BF1(2),SIGT(2),DIF(2) + TYPE(C_PTR) JPMAC1,KPMAC1 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) :: WORK + REAL, ALLOCATABLE, DIMENSION(:,:) :: SCAT +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IJJ(NMIX1),NJJ(NMIX1),IPOS(NMIX1),WORK(NG*NMIX1), + 1 SCAT(NG,NG)) +*---- +* RECOVER FLUX, MACROSCOPIC CROSS SECTIONS AND DIFFUSION COEFFICIENTS +*---- + IF(NC.NE.2) CALL XABORT('BRELLB: NC=2 EXPECTED.') + IF(NG.NE.2) CALL XABORT('BRELLB: NG=2 EXPECTED.') + IF(NMIX1.NE.1) CALL XABORT('BRELLB: NMIX1=1 EXPECTED.') +*---- +* COMPUTE EQUIVALENT REFLECTOR +*---- + IBM=1 + DO IC=1,NC + BF1BF2(IC)=FHETXM(IBM,2,1,IC)/FHETXM(IBM,1,1,IC) + CUR1BF1(IC)=JXM(IBM,1,IC)/FHETXM(IBM,1,1,IC) + CUR2BF1(IC)=JXM(IBM,2,IC)/FHETXM(IBM,1,1,IC) + ENDDO + DIF(1)=1.3 + DIF(2)=0.4 + PENTE=(CUR2BF1(1)-CUR2BF1(2))/(BF1BF2(1)-BF1BF2(2)) + ORDORI=CUR2BF1(1)-PENTE*BF1BF2(1) + R1=CUR1BF1(1) + R2=PENTE + R3=-ORDORI + IF(IPRINT.GT.0) WRITE(6,10) R1,R2,R3 + SIGT(2)=R2*R2/DIF(2) + SIGSLW=(SQRT(DIF(2)/DIF(1))*R1+SQRT(DIF(1)*SIGT(2)))*R3/ + 1 SQRT(DIF(1)*DIF(2)) + SIGT(1)=R1*R1/DIF(1) + IF(SIGSLW.LT.0.0) THEN + CALL XABORT('BRELLB: Negative fast SIGS00 XS.') + ELSE IF(SIGT(1)-SIGSLW.LT.0.0) THEN + CALL XABORT('BRELLB: Negative fast absorption XS.') + ENDIF ; + SCAT(:,:)=0.0 + SCAT(2,1)=SIGSLW + IF(IPRINT.GT.0) THEN + WRITE(6,'(/40H BRELLB: LEFEBVRE-LEBIGOT CROSS SECTIONS)') + WRITE(6,'(/12H MIXTURE= 1)') + WRITE(6,20) 'DIFF',DIF(:NG) + WRITE(6,20) 'SIGT',SIGT(:NG) + WRITE(6,20) 'SCAT',SCAT(:NG,:NG) + ENDIF +*---- +* SAVE THE OUTPUT NODAL MACROLIB +*---- + IBM=1 + ISTATE(:)=0 + ISTATE(1)=NG + ISTATE(2)=NMIX1 + ISTATE(3)=1 + ISTATE(9)=1 ! diffusion coefficient information + CALL LCMPUT(IPMAC1,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMPUT(IPMAC1,'ENERGY',NG+1,2,ENER) + WORK(1)=1.0 + CALL LCMPUT(IPMAC1,'VOLUME',NMIX1,2,WORK) + JPMAC1=LCMLID(IPMAC1,'GROUP',NG) + DO IGR=1,NG + KPMAC1=LCMDIL(JPMAC1,IGR) + WORK(1)=1.0 + CALL LCMPUT(KPMAC1,'FLUX-INTG',NMIX1,2,WORK) + CALL LCMPUT(KPMAC1,'NTOT0',NMIX1,2,SIGT(IGR)) + WORK(1)=0.0 + CALL LCMPUT(KPMAC1,'SIGW00',NMIX1,2,WORK) + CALL LCMPUT(KPMAC1,'DIFF',NMIX1,2,DIF(IGR)) + IPOSDE=0 + DO J=1,NMIX1 + IBM=1 + J2=IGR + J1=IGR + DO JGR=1,NG + IF(SCAT(IGR,JGR).NE.0.0) THEN + J2=MAX(J2,JGR) + J1=MIN(J1,JGR) + ENDIF + ENDDO + NJJ(J)=J2-J1+1 + IJJ(J)=J2 + IPOS(J)=IPOSDE+1 + DO JGR=J2,J1,-1 + IPOSDE=IPOSDE+1 + IF(IPOSDE.GT.NG*NMIX1) CALL XABORT('BRELLB: SCAT OVERFLOW.') + WORK(IPOSDE)=SCAT(IGR,JGR) + ENDDO + ENDDO + CALL LCMPUT(KPMAC1,'SCAT00',IPOSDE,2,WORK) + CALL LCMPUT(KPMAC1,'NJJS00',NMIX1,1,NJJ) + CALL LCMPUT(KPMAC1,'IJJS00',NMIX1,1,IJJ) + CALL LCMPUT(KPMAC1,'IPOS00',NMIX1,1,IPOS) + ENDDO +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SCAT,WORK,IPOS,NJJ,IJJ) + RETURN +* + 10 FORMAT(12H BRELLB: R1=,1P,E12.4,4H R2=,E12.4,4H R3=,E12.4) + 20 FORMAT(1X,A9,1P,10E12.4,/(10X,10E12.4)) + END diff --git a/Dragon/src/BREMAC.f b/Dragon/src/BREMAC.f new file mode 100644 index 0000000..eaba3e9 --- /dev/null +++ b/Dragon/src/BREMAC.f @@ -0,0 +1,369 @@ +*DECK BREMAC + SUBROUTINE BREMAC(NC,IPMAC2,NG,NL,LX1,NMIX1,NMIX2,IMIX,IMIX1, + 1 IGAP,ILEAKS,IDF,IPRINT,ZKEFF,B2,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1, + 2 SCAT1,JXM,JXP,FHETXM,FHETXP,ADF1) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover macroscopic cross sections. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NC number of sn macrolibs. +* IPMAC2 pointer to the sn macrolib. +* NG number of energy groups. +* NL Legendre order of TOT1 and SCAT1 arrays (=1 for isotropic +* scattering in LAB). +* LX1 number of nodes in the reflector model. +* NMIX1 number of mixtures in the nodal calculation. +* NMIX2 number of mixtures in the sn calculation after edition. +* IMIX mix index of each node in output data. +* IMIX1 mix index of each node in sn editions. +* IGAP mix index of the right gap where the surface flux is +* recovered. +* ILEAKS type of leakage calculation (=0: no; =1: isotropic; +* =2: anisotropic). +* IDF discontinuity factor flag (=0: not used; =3: recovered). +* IPRINT print parameter +* +*Parameters: output +* ZKEFF effective multiplication factor. +* B2 buckling. +* VOL1 volumes. +* FLX1 averaged fluxes +* DC1 diffusion coefficients. +* TOT1 total cross sections. +* CHI1 fission spectra. +* SIGF1 nu*fission cross sections. +* SCAT1 scattering cross sections. +* JXM left boundary currents. +* JXP right boundary currents. +* FHETXM left boundary fluxes. +* FHETXP right boundary fluxes. +* ADF1 assembly discontinuity factors. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NC + TYPE(C_PTR) IPMAC2(NC) + INTEGER NG,NL,LX1,NMIX1,NMIX2,IMIX(LX1),IMIX1(LX1),IGAP(LX1), + 1 ILEAKS,IDF,IPRINT + REAL ZKEFF(NC),B2(NC),VOL1(NMIX1,NC),FLX1(NMIX1,NG,NC), + 1 DC1(NMIX1,NG,NC),TOT1(NMIX1,NG,NL,NC),CHI1(NMIX1,NG,NC), + 2 SIGF1(NMIX1,NG,NC),SCAT1(NMIX1,NG,NG,NL,NC),JXM(NMIX1,NG,NC), + 3 JXP(NMIX1,NG,NC),FHETXM(NMIX1,NG,NL,NC),FHETXP(NMIX1,NG,NL,NC), + 4 ADF1(NMIX1,NG,NC) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPMAC2,KPMAC2 + DOUBLE PRECISION DSFIS + CHARACTER CM*2,HADF*8,TEXT12*12 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS,IMIX2 + REAL, ALLOCATABLE, DIMENSION(:) :: VOL,WORK,SFIS,SFIS1 + REAL, ALLOCATABLE, DIMENSION(:,:) :: DC,CHI,SIGF + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: FLX,TOT + REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: SCAT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: DCOU +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(VOL(NMIX2),FLX(NMIX2,NG,NL),TOT(NMIX2,NG,NL), + 1 DC(NMIX2,NG),CHI(NMIX2,NG),SIGF(NMIX2,NG),SCAT(NMIX2,NG,NG,NL), + 2 IMIX2(NMIX2),SFIS(NMIX2),SFIS1(NMIX1),DCOU(NMIX2+1,NG)) + ALLOCATE(IJJ(NMIX2),NJJ(NMIX2),IPOS(NMIX2),WORK(NG*NMIX2)) +*---- +* SET IMIX2 +*---- + IMIX2(:)=0 + DO J=1,LX1 + IBM=IMIX1(J) + IBG=IGAP(J) + IF(IBM.GT.NMIX2) CALL XABORT('BREMAC: NMIX2 OVERFLOW(1).') + IF(IBG.GT.NMIX2) CALL XABORT('BREMAC: NMIX2 OVERFLOW(2).') + IF(IBM.GT.0) IMIX2(IBM)=IMIX(J) + IF((IBG.GT.0).AND.(J.LT.LX1)) IMIX2(IBG)=IMIX(J+1) + ENDDO +*---- +* LOOP OVER SN MACROLIBS +*---- + DO IC=1,NC +*---- +* RECOVER FLUX, MACROSCOPIC CROSS SECTIONS AND DIFFUSION COEFFICIENTS +*---- + CALL LCMGET(IPMAC2(IC),'VOLUME',VOL) + CALL LCMGET(IPMAC2(IC),'K-EFFECTIVE',ZKEFF(IC)) + B2(IC)=0.0 + IF(ILEAKS.GT.0) THEN + CALL LCMLEN(IPMAC2(IC),'B2 B1HOM',ILONG,ITYLCM) + IF(ILONG.EQ.1) CALL LCMGET(IPMAC2(IC),'B2 B1HOM',B2(IC)) + ENDIF + JPMAC2=LCMGID(IPMAC2(IC),'GROUP') + SCAT(:,:,:,:)=0.0 + DO IGR=1,NG + KPMAC2=LCMGIL(JPMAC2,IGR) + CALL LCMGET(KPMAC2,'FLUX-INTG',FLX(1,IGR,1)) + CALL LCMGET(KPMAC2,'NTOT0',TOT(1,IGR,1)) + IF(NL.GE.2) THEN + CALL LCMLEN(KPMAC2,'FLUX-INTG-P1',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMAC2,'FLUX-INTG-P1',FLX(1,IGR,2)) + ELSE + FLX(:NMIX2,IGR,2)=FLX(:NMIX2,IGR,1) + ENDIF + CALL LCMLEN(KPMAC2,'NTOT1',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMAC2,'NTOT1',TOT(1,IGR,2)) + ELSE + TOT(:NMIX2,IGR,2)=TOT(:NMIX2,IGR,1) + ENDIF + DO IL=3,NL + WRITE(TEXT12,'(11HFLUX-INTG-P,I1)') IL-1 + CALL LCMLEN(KPMAC2,TEXT12,ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMAC2,TEXT12,FLX(1,IGR,IL)) + ELSE + FLX(:NMIX2,IGR,IL)=FLX(:NMIX2,IGR,IL-2) + ENDIF + WRITE(TEXT12,'(4HNTOT,I1)') IL-1 + CALL LCMLEN(KPMAC2,TEXT12,ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMAC2,TEXT12,TOT(1,IGR,IL)) + ELSE + TOT(:NMIX2,IGR,IL)=TOT(:NMIX2,IGR,IL-2) + ENDIF + ENDDO + ENDIF + CALL LCMGET(KPMAC2,'DIFF',DC(1,IGR)) + CALL LCMGET(KPMAC2,'CHI',CHI(1,IGR)) + CALL LCMGET(KPMAC2,'NUSIGF',SIGF(1,IGR)) + DO IL=1,NL + WRITE(CM,'(I2.2)') IL-1 + CALL LCMLEN(KPMAC2,'IJJS'//CM,ILONG,ITYLCM) + IF(ILONG.EQ.0) CYCLE + CALL LCMGET(KPMAC2,'IJJS'//CM,IJJ) + CALL LCMGET(KPMAC2,'NJJS'//CM,NJJ) + CALL LCMGET(KPMAC2,'IPOS'//CM,IPOS) + CALL LCMGET(KPMAC2,'SCAT'//CM,WORK) + DO IBM=1,NMIX2 + IPOSDE=IPOS(IBM)-1 + DO JGR=IJJ(IBM),IJJ(IBM)-NJJ(IBM)+1,-1 + IPOSDE=IPOSDE+1 + SCAT(IBM,IGR,JGR,IL)=WORK(IPOSDE) ! IGR <-- JGR + ENDDO + ENDDO + ENDDO + DO IBM=1,NMIX2 + FLX(IBM,IGR,:NL)=FLX(IBM,IGR,:NL)/VOL(IBM) + ENDDO + ENDDO +*---- +* COMPUTE NET CURRENTS BETWEEN NODES USING A BALANCE RELATION +*---- + DCOU(:NMIX2+1,:NG)=0.0D0 + DO IBM=1,NMIX2 + DSFIS=0.0D0 + DO IGR=1,NG + DSFIS=DSFIS+SIGF(IBM,IGR)*FLX(IBM,IGR,1) + ENDDO + DSFIS=DSFIS/ZKEFF(IC) + DO IGR=1,NG + DCOU(IBM+1,IGR)=DCOU(IBM,IGR)+VOL(IBM)*(CHI(IBM,IGR)*DSFIS- + 1 (TOT(IBM,IGR,1)+B2(IC)*DC(IBM,IGR))*FLX(IBM,IGR,1)) + DO JGR=1,NG + DCOU(IBM+1,IGR)=DCOU(IBM+1,IGR)+VOL(IBM)* + 1 SCAT(IBM,IGR,JGR,1)*FLX(IBM,JGR,1) + ENDDO + ENDDO + ENDDO +*---- +* NORMALIZE THE ODD FLUX UNKNOWNS BETWEEN NODES +*---- + IF(NL.GT.1) THEN + DO J=1,LX1 + IBM=IMIX1(J) + IBG=IGAP(J) + IF((IBM.GT.0).AND.(IBG.GT.0)) THEN + DO IGR=1,NG + FACT=REAL(DCOU(IBM+1,IGR))/FLX(IBG,IGR,2) + DO IL=2,NL,2 + FLX(IBG,IGR,IL)=FLX(IBG,IGR,IL)*FACT + ENDDO + ENDDO + ENDIF + ENDDO + ENDIF +*---- +* HOMOGENIZATION OVER THE GAPS AND NODES +*---- + VOL1(:,IC)=0.0 + SFIS1(:)=0.0 + FLX1(:,:,IC)=0.0 + TOT1(:,:,:,IC)=0.0 + DC1(:,:,IC)=0.0 + SIGF1(:,:,IC)=0.0 + CHI1(:,:,IC)=0.0 + SCAT1(:,:,:,:,IC)=0.0 + DO IL=1,NL,2 + FHETXM(:,:,IL,IC)=1.0 + FHETXP(:,:,IL,IC)=1.0 + ENDDO + DO IL=2,NL,2 + FHETXM(:,:,IL,IC)=0.0 + FHETXP(:,:,IL,IC)=0.0 + ENDDO + JXM(:,:,IC)=0.0 + JXP(:,:,IC)=0.0 + ADF1(:,:,IC)=0.0 + DO J=1,LX1 + IBM=IMIX1(J) + IBG=IGAP(J) + IF(IBG.GT.0) THEN + DO IL=1,NL + IF(IMIX(J).GT.0) FHETXP(IMIX(J),:,IL,IC)=FLX(IBG,:,IL) + IF(J.LT.LX1) THEN + IF(IMIX(J+1).GT.0) THEN + FHETXM(IMIX(J+1),:,IL,IC)=FLX(IBG,:,IL) + ENDIF + ENDIF + ENDDO + ENDIF + IF(IBM.GT.0) THEN + IF(IMIX(J).GT.0) THEN + JXM(IMIX(J),:NG,IC)=REAL(DCOU(MAX(1,IBM-1),:NG)) + JXP(IMIX(J),:NG,IC)=REAL(DCOU(IBM+1,:NG)) + ENDIF + ENDIF + ENDDO + DO IBM2=1,NMIX2 + IBM=IMIX2(IBM2) + IF(IBM.EQ.0) CYCLE + VOL1(IBM,IC)=VOL1(IBM,IC)+VOL(IBM2) + SFIS(IBM2)=0.0 + DO IGR=1,NG + SFIS(IBM2)=SFIS(IBM2)+VOL(IBM2)*FLX(IBM2,IGR,1)* + 1 SIGF(IBM2,IGR) + ENDDO + SFIS1(IBM)=SFIS1(IBM)+SFIS(IBM2) + DO IGR=1,NG + FLX1(IBM,IGR,IC)=FLX1(IBM,IGR,IC)+VOL(IBM2)*FLX(IBM2,IGR,1) + DO IL=1,NL + TOT1(IBM,IGR,IL,IC)=TOT1(IBM,IGR,IL,IC)+VOL(IBM2)* + 1 FLX(IBM2,IGR,1)*TOT(IBM2,IGR,IL) + ENDDO + DC1(IBM,IGR,IC)=DC1(IBM,IGR,IC)+VOL(IBM2)*FLX(IBM2,IGR,1)* + 1 DC(IBM2,IGR) + SIGF1(IBM,IGR,IC)=SIGF1(IBM,IGR,IC)+VOL(IBM2)* + 1 FLX(IBM2,IGR,1)*SIGF(IBM2,IGR) + CHI1(IBM,IGR,IC)=CHI1(IBM,IGR,IC)+SFIS(IBM2)*CHI(IBM2,IGR) + DO IL=1,NL + DO JGR=1,NG + SCAT1(IBM,IGR,JGR,IL,IC)=SCAT1(IBM,IGR,JGR,IL,IC)+ + 1 VOL(IBM2)*FLX(IBM2,JGR,1)*SCAT(IBM2,IGR,JGR,IL) + ENDDO + ENDDO + ENDDO + ENDDO + DO IBM=1,NMIX1 + DO IGR=1,NG + DO IL=1,NL + TOT1(IBM,IGR,IL,IC)=TOT1(IBM,IGR,IL,IC)/FLX1(IBM,IGR,IC) + ENDDO + DC1(IBM,IGR,IC)=DC1(IBM,IGR,IC)/FLX1(IBM,IGR,IC) + IF(SFIS1(IBM).NE.0.0) CHI1(IBM,IGR,IC)=CHI1(IBM,IGR,IC)/ + 1 SFIS1(IBM) + SIGF1(IBM,IGR,IC)=SIGF1(IBM,IGR,IC)/FLX1(IBM,IGR,IC) + DO JGR=1,NG + DO IL=1,NL + SCAT1(IBM,IGR,JGR,IL,IC)=SCAT1(IBM,IGR,JGR,IL,IC)/ + 1 FLX1(IBM,JGR,IC) + ENDDO + ENDDO + ENDDO + DO IGR=1,NG + FLX1(IBM,IGR,IC)=FLX1(IBM,IGR,IC)/VOL1(IBM,IC) + ENDDO + ENDDO +*---- +* RECOVER ADF +*---- + IF(IDF.EQ.3) THEN + CALL LCMSIX(IPMAC2(IC),'ADF',1) + IF(IPRINT.GT.5) CALL LCMLIB(IPMAC2(IC)) + CALL LCMLEN(IPMAC2(IC),'HADF',NTYPE,ITYLCM) + IF(NTYPE/2.NE.1) CALL XABORT('BREMAC: NTYPE=1 EXPECTED.') + CALL LCMGTC(IPMAC2(IC),'HADF',8,HADF) + CALL LCMLEN(IPMAC2(IC),HADF,ILONG,ITYLCM) + IF(ILONG.NE.NMIX1*NG) CALL XABORT('BREMAC: ADF OVERFLOW.') + CALL LCMGET(IPMAC2(IC),HADF,ADF1(1,1,IC)) + ENDIF +*---- +* PRINT CROSS SECTIONS +*---- + IF(IPRINT.GT.1) THEN + WRITE(6,'(/36H BREMAC: CROSS SECTION FOR MACROLIB=,I5)') IC + WRITE(6,'(31H BREMAC: SCATTERING ANISOTROPY=,I5)') NL-1 + WRITE(6,'(/6H KEFF=,1P E13.5,4H B2=,E13.5/)') ZKEFF(IC),B2(IC) + WRITE(6,10) 'IMIX',IMIX(:) + WRITE(6,20) 'VOL1',VOL1(:,IC) + WRITE(6,20) 'SFIS1',SFIS1(:) + DO IGR=1,NG + WRITE(6,'(/29H BREMAC: PROCESS ENERGY GROUP,I5)') IGR + WRITE(6,20) 'FLX1',FLX1(:,IGR,IC) + WRITE(6,20) 'TOT1-P0',TOT1(:,IGR,1,IC) + IF(NL.GE.2) WRITE(6,20) 'TOT1-P1',TOT1(:,IGR,2,IC) + WRITE(6,20) 'SIGR',TOT1(:,IGR,1,IC)-SCAT1(:,IGR,IGR,1,IC) + WRITE(6,20) 'DC1',DC1(:,IGR,IC) + WRITE(6,20) 'CHI1',CHI1(:,IGR,IC) + WRITE(6,20) 'SIGF1',SIGF1(:,IGR,IC) + DO JGR=1,NG + IF(IGR.EQ.JGR) THEN + WRITE(6,20) 'INSCAT1-P0',SCAT1(:,IGR,IGR,1,IC) + IF(NL.EQ.2) THEN + WRITE(6,20) 'INSCAT1-P1',SCAT1(:,IGR,IGR,2,IC) + ENDIF + ELSE + WRITE(6,20) 'OUTSCAT1-P0',SCAT1(:,JGR,IGR,1,IC) + IF(NL.GE.2) THEN + WRITE(6,20) 'OUTSCAT1-P1',SCAT1(:,JGR,IGR,2,IC) + ENDIF + ENDIF + ENDDO + WRITE(6,20) 'JXM',JXM(:,IGR,IC) + WRITE(6,20) 'JXP',JXP(:,IGR,IC) + DO IL=1,NL + WRITE(TEXT12,'(8HFHETXM-P,I1)') IL-1 + WRITE(6,20) TEXT12(:9),FHETXM(:,IGR,IL,IC) + WRITE(TEXT12,'(8HFHETXP-P,I1)') IL-1 + WRITE(6,20) TEXT12(:9),FHETXP(:,IGR,IL,IC) + ENDDO + IF(IDF.EQ.3) WRITE(6,20) 'ADF1',ADF1(:,IGR,IC) + ENDDO + ENDIF + ENDDO +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(WORK,IPOS,NJJ,IJJ,DCOU,SFIS1,SFIS,IMIX2,SCAT,SIGF,CHI, + 1 DC,TOT,FLX,VOL) + RETURN +* + 10 FORMAT(1X,A12,10I13/(12X,10I13)) + 20 FORMAT(1X,A12,1P,10E13.5/(12X,10E13.5)) + END diff --git a/Dragon/src/BRENEM.f b/Dragon/src/BRENEM.f new file mode 100644 index 0000000..3e0a281 --- /dev/null +++ b/Dragon/src/BRENEM.f @@ -0,0 +1,352 @@ +*DECK BRENEM + SUBROUTINE BRENEM(IPMAC1,NG,LX1,NMIX1,ITRIAL,IMIX,ICODE,ISPH, + 1 ZKEFF,B2,ENER,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1,JXM,JXP,FHETXM, + 2 FHETXP,ADF1,NGET,ADFREF,IPRINT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Implement the 1D DF-NEM reflector model. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMAC1 nodal macrolib. +* NG number of energy groups. +* LX1 number of nodes in the reflector model. +* NMIX1 number of mixtures in the nodal calculation. +* ITRIAL type of expansion functions in the nodal calculation. +* (=1: polynomial; =2: hyperbolic). +* IMIX mix index of each node. +* ICODE physical albedo index on each side of the domain. +* ISPH SPH flag (=0: use discontinuity factors; =1: use SPH factors). +* ZKEFF effective multiplication factor. +* B2 buckling. +* ENER energy limits. +* VOL1 volumes. +* FLX1 averaged fluxes +* DC1 diffusion coefficients. +* TOT1 total cross sections. +* CHI1 fission spectra. +* SIGF1 nu*fission cross sections. +* SCAT1 scattering P0 cross sections. +* JXM left boundary currents. +* JXP right boundary currents. +* FHETXM left boundary fluxes. +* FHETXP right boundary fluxes. +* ADF1 assembly discontinuity factors from macrolib. +* NGET type of NGET normalization if discontinuity factors +* (=0: simple; =1: imposed ADF on fuel assembly; =2: recover +* fuel assembly ADF from input macrolib). +* ADFREF imposed ADF values on fuel assembly side. +* IPRINT edition flag. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMAC1 + INTEGER NG,LX1,NMIX1,ITRIAL(NG),IMIX(LX1),ICODE(2),ISPH,NGET, + 1 IPRINT + REAL ZKEFF,B2,ENER(NG+1),VOL1(NMIX1),FLX1(NMIX1,NG),DC1(NMIX1,NG), + 1 TOT1(NMIX1,NG),CHI1(NMIX1,NG),SIGF1(NMIX1,NG), + 2 SCAT1(NMIX1,NG,NG),JXM(NMIX1,NG),JXP(NMIX1,NG),FHETXM(NMIX1,NG), + 3 FHETXP(NMIX1,NG),ADF1(NMIX1,NG),ADFREF(NG) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + INTEGER ISTATE(NSTATE) + REAL SX(4),A11(4,4),Q(5) + CHARACTER HADF*8 + TYPE(C_PTR) JPMAC1,KPMAC1 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) :: WORK,ETA,AFACTOR,BETA + REAL, ALLOCATABLE, DIMENSION(:,:) :: AB,ALPHA,FDXM,FDXP +*---- +* LOOP OVER EQUIVALENT REFLECTOR NODES +*---- + ALLOCATE(ETA(NG),AB(4*NG,4*NG+1),ALPHA(4,NG),FDXM(NMIX1,NG), + 1 FDXP(NMIX1,NG),AFACTOR(NG),BETA(NG)) +*---- +* SET AND SOLVE NODAL SYSTEM +*---- + J_FUEL=0 + DO J=1,LX1 + IBM=IMIX(J) + IF(IBM.EQ.0) CYCLE + DO IGR=1,NG + IF(SIGF1(IBM,IGR).GT.0.0) J_FUEL=J + DIFF=DC1(IBM,IGR) + SIGR=TOT1(IBM,IGR)+B2*DIFF-SCAT1(IBM,IGR,IGR) + ETA(IGR)=VOL1(IBM)*SQRT(SIGR/DIFF) + DO JGR=1,NG + IF(JGR.EQ.IGR) THEN + SIGT=SIGR-CHI1(IBM,IGR)*SIGF1(IBM,IGR)/ZKEFF + CALL BRESS1(ITRIAL(IGR),VOL1(IBM),DIFF,SIGR,SIGT,A11) + ELSE + SIGT=-SCAT1(IBM,JGR,IGR)-CHI1(IBM,JGR)*SIGF1(IBM,IGR)/ZKEFF + CALL BRESS2(ITRIAL(IGR),VOL1(IBM),DIFF,SIGR,SIGT,A11) + ENDIF + DO K1=1,4 + DO K2=1,4 + AB((JGR-1)*4+K1,(IGR-1)*4+K2)=A11(K1,K2) + ENDDO + ENDDO + ENDDO + SX = (/0.0,0.0,JXM(IBM,IGR),JXP(IBM,IGR)/) + DO K1 =1,4 + AB((IGR-1)*4+K1,4*NG+1)=SX(K1) + ENDDO + ENDDO + CALL ALSB(4*NG,1,AB,IER,4*NG) + IF (IER.NE.0) CALL XABORT('BRENEM: ALBS FAILURE') + DO IGR=1,NG + DO I=1,4 + ALPHA(I,IGR)=AB((IGR-1)*4+I,4*NG+1) + ENDDO + ENDDO + IF(IPRINT.GT.1) THEN + WRITE(6,'(/9H MIXTURE=,I5)') J + WRITE(6,20) 'ALPHA',ALPHA(:4,:NG) + ENDIF +*---- +* COMPUTE DISCONTINUITY FACTORS +*---- + DO IGR=1,NG + IF (ITRIAL(IGR) == 1) THEN + Q(1) = ALPHA(2,IGR)/2. + FHOMM=-ALPHA(1,IGR)/2.+FLX1(IBM,IGR)+Q(1) + FHOMP=ALPHA(1,IGR)/2.+FLX1(IBM,IGR)+Q(1) + ELSE + Q(1) = ETA(IGR)/2. + Q(2) = SINH(Q(1)) + Q(3) = ALPHA(2,IGR)/2. + Q(4) = ALPHA(3,IGR)*Q(2) + Q(5) = ALPHA(4,IGR)*(COSH(Q(1)) - (2*Q(2))/ETA(IGR)) + FHOMM=-ALPHA(1,IGR)/2.+FLX1(IBM,IGR)+Q(3)-Q(4)+Q(5) + FHOMP=ALPHA(1,IGR)/2.+FLX1(IBM,IGR)+Q(3)+Q(4)+Q(5) + ENDIF + FDXM(IBM,IGR)=FHETXM(IBM,IGR)/FHOMM + FDXP(IBM,IGR)=FHETXP(IBM,IGR)/FHOMP + ENDDO + ENDDO + IF(IPRINT.GT.0) THEN + WRITE(6,'(/48H BRENEM: DISCONTINUITY FACTORS BEFORE NORMALIZAT, + 1 3HION)') + DO IBM=1,NMIX1 + WRITE(6,'(/9H MIXTURE=,I5)') IBM + WRITE(6,20) 'FDXM',FDXM(IBM,:NG) + WRITE(6,20) 'FDXP',FDXP(IBM,:NG) + ENDDO + ENDIF +*---- +* COMPUTE ALBEDOS +*---- + IF(ICODE(2).NE.0) THEN + BETA(:)=0.0 + IBM=IMIX(LX1) + DO IGR=1,NG + IF(IBM.EQ.0) CYCLE + AFACTOR(IGR)=FDXP(IBM,IGR)*JXP(IBM,IGR)/FHETXP(IBM,IGR) + BETA(IGR)=(1.0-2.0*AFACTOR(IGR))/(1.0+2.0*AFACTOR(IGR)) + ENDDO + IF(IPRINT.GT.0) THEN + WRITE(6,'(/16H BRENEM: ALBEDOS)') + WRITE(6,20) 'BETA',BETA(:NG) + ENDIF + ENDIF +*---- +* NGET NORMALIZATION OF THE DISCONTINUITY FACTORS +*---- + IF(J_FUEL.GT.0) THEN + IF(NGET.GT.0) THEN + IBM=IMIX(J_FUEL) + DO IGR=1,NG + ! impose the adf on the fuel assembly side + IF(IBM.EQ.0) CYCLE + IF(NGET.EQ.1) THEN + FNORM=ADFREF(IGR)/FDXP(IBM,IGR) + ELSE + FNORM=ADF1(IBM,IGR)/FDXP(IBM,IGR) + ENDIF + FDXP(IBM,IGR)=FDXP(IBM,IGR)*FNORM + IF(J_FUEL1) THEN + IBMM=IMIX(J-1) + IF(IBMM.GT.0) FDXP(IBMM,IGR)=FDXP(IBMM,IGR)*FDXP(IBM,IGR)/ + 1 FDXM(IBM,IGR) + ENDIF + FDXM(IBM,IGR)=FDXP(IBM,IGR) + ENDDO + ENDDO + ENDIF + DO J=J_FUEL+1,LX1 + IBM=IMIX(J) + IF(IBM.EQ.0) CYCLE + DO IGR=1,NG + IF(J1, +* NL is an even integer). +* LX1 number of nodes in the reflector model. +* NMIX1 number of mixtures in the nodal calculation. +* IMIX mix index of each node. +* ICODE physical albedo index on each side of the domain. +* ISPH SPH flag (=0: use discontinuity factors; =1: use SPH factors). +* IDIFF PN calculation option (=0: diffusion theory; =1: SPN theory +* with 'NTOT1'; =2: SPN theory with 1/(3*D)). +* ZKEFF effective multiplication factor. +* B2 buckling. +* ENER energy limits. +* XXX1 spatial mesh. +* VOL1 volumes. +* FLX1 averaged fluxes +* DC1 diffusion coefficients. +* TOT1 total cross sections. +* CHI1 fission spectra. +* SIGF1 nu*fission cross sections. +* SCAT1 scattering P0 cross sections. +* JXM left boundary currents. +* JXP right boundary currents. +* FHETXM left boundary fluxes. +* FHETXP right boundary fluxes. +* ADF1 assembly discontinuity factors from macrolib. +* NGET type of NGET normalization if discontinuity factors +* (=0: simple; =1: imposed ADF on fuel assembly; =2: recover +* fuel assembly ADF from input macrolib). +* ADFREF imposed ADF values on fuel assembly side. +* IMPX edition flag. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMAC1 + INTEGER IELEM,ICOL,NG,NL,LX1,NMIX1,IMIX(LX1),ICODE(2),ISPH,IDIFF, + 1 NGET,IMPX + REAL ZKEFF,B2,ENER(NG+1),XXX1(LX1+1),VOL1(NMIX1),FLX1(NMIX1,NG), + 1 DC1(NMIX1,NG),TOT1(NMIX1,NG,NL),CHI1(NMIX1,NG),SIGF1(NMIX1,NG), + 2 SCAT1(NMIX1,NG,NG,NL),JXM(NMIX1,NG),JXP(NMIX1,NG), + 3 FHETXM(NMIX1,NG,NL),FHETXP(NMIX1,NG,NL),ADF1(NMIX1,NG),ADFREF(NG) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + INTEGER ISTATE(NSTATE) + CHARACTER CM*2,HADF*8,TEXT12*12 + TYPE(C_PTR) JPMAC1,KPMAC1 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) :: WORK,AFACTOR,BETA,WORK1,WORK2, + 1 VOLTOT + REAL, ALLOCATABLE, DIMENSION(:,:) :: FDXM,FDXP,WORK3,WORK4,WORK5, + 1 WORK6,WORK7 + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: FHOMM,FHOMP + REAL(KIND=8), ALLOCATABLE, DIMENSION(:,:,:) :: RCAT +*---- +* SCRATCH STORAGE ALLOCATION +*---- + J_FUEL=0 + NLMAX=1 + IF(IDIFF.GT.0) THEN + IF(NL.LT.2) CALL XABORT('BRERT: EVEN NL>=2 EXPECTED WITH SPN.') + NLMAX=NL/2 + ENDIF + ALLOCATE(FHOMM(NMIX1,NG,NLMAX),FHOMP(NMIX1,NG,NLMAX), + 1 FDXM(NMIX1,NG),FDXP(NMIX1,NG),AFACTOR(NG),BETA(NG),VOLTOT(NMIX1), + 2 WORK1(NG),WORK2(NG),WORK3(NG,NG),WORK6(NG,NLMAX),WORK7(NG,NLMAX)) +*---- +* COMPUTE BOUNDARY FLUXES +*---- + FDXM(:NMIX1,:NG)=0.0 + FDXP(:NMIX1,:NG)=0.0 + FHOMM(:NMIX1,:NG,:NLMAX)=0.0 + FHOMP(:NMIX1,:NG,:NLMAX)=0.0 + VOLTOT(:NMIX1)=0.0 + DO I=1,LX1 + IBM=IMIX(I) + IF(IBM.EQ.0) CYCLE + WORK6(:NG,:NLMAX)=0.0 + WORK7(:NG,:NLMAX)=0.0 + DELX=XXX1(I+1)-XXX1(I) + IF(IMPX.GT.0) WRITE(6,'(/15H BRERT: REGION=,I5)') I + IF(IDIFF.EQ.0) THEN +* diffusion theory + ALLOCATE(WORK4(NG,1),WORK5(NG,1)) + WORK1(:NG)=DC1(IBM,:NG) + WORK4(:NG,1)=JXM(IBM,:NG) + WORK5(:NG,1)=JXP(IBM,:NG) + DO IG=1,NG + IF(SIGF1(IBM,IG).GT.0.0) J_FUEL=I + WORK2(IG)=TOT1(IBM,IG,1)+B2*DC1(IBM,IG)-SCAT1(IBM,IG,IG,1) + DO JG=1,NG + WORK3(IG,JG)=CHI1(IBM,IG)*SIGF1(IBM,JG)/ZKEFF + IF(JG.NE.IG) WORK3(IG,JG)=WORK3(IG,JG)+SCAT1(IBM,IG,JG,1) + ENDDO + ENDDO + CALL BRERTD(IELEM,ICOL,NG,DELX,WORK1,WORK2,WORK3,WORK4,WORK5, + 1 IMPX,WORK6,WORK7) + DEALLOCATE(WORK5,WORK4) + ELSE +* SPN theory + ALLOCATE(WORK4(NG,NL/2),WORK5(NG,NL/2),RCAT(NG,NG,NL)) + DO IL=1,NL/2 + WORK4(:NG,IL)=FHETXM(IBM,:NG,2*IL) + WORK5(:NG,IL)=FHETXP(IBM,:NG,2*IL) + ENDDO + RCAT(:NG,:NG,:NL)=0.0 + DO IG=1,NG + IF(SIGF1(IBM,IG).GT.0.0) J_FUEL=I + DO JG=1,NG + RCAT(IG,JG,1)=-CHI1(IBM,IG)*SIGF1(IBM,JG)/ZKEFF + ENDDO + RCAT(IG,IG,1)=RCAT(IG,IG,1)+B2*DC1(IBM,IG) + DO IL=1,NL,2 + RCAT(IG,IG,IL)=RCAT(IG,IG,IL)+TOT1(IBM,IG,IL) + DO JG=1,NG + RCAT(IG,JG,IL)=RCAT(IG,JG,IL)-SCAT1(IBM,IG,JG,IL) + ENDDO + ENDDO + DO IL=2,NL,2 + IF(IDIFF.EQ.1) THEN + DO JG=1,NG + RCAT(IG,JG,IL)=RCAT(IG,JG,IL)-SCAT1(IBM,IG,JG,IL) + ENDDO + ELSE + TOT1(IBM,IG,IL)=1.0/(3.0*DC1(IBM,IG)) + SCAT1(IBM,IG,:NG,IL)=0.0 + ENDIF + RCAT(IG,IG,IL)=RCAT(IG,IG,IL)+TOT1(IBM,IG,IL) + ENDDO + ENDDO + DO IL=1,NL + RCAT(:NG,:NG,IL)=RCAT(:NG,:NG,IL)*REAL(2*IL-1) + ENDDO + CALL BRERTS(IELEM,ICOL,NG,NL,DELX,RCAT,WORK4,WORK5,IMPX, + 1 WORK6,WORK7) + DEALLOCATE(RCAT,WORK5,WORK4) + ENDIF + FHOMM(IBM,:NG,:NLMAX)=FHOMM(IBM,:NG,:NLMAX)+WORK6(:NG,:NLMAX)* + 1 DELX + FHOMP(IBM,:NG,:NLMAX)=FHOMP(IBM,:NG,:NLMAX)+WORK7(:NG,:NLMAX)* + 1 DELX + VOLTOT(IBM)=VOLTOT(IBM)+DELX + ENDDO + DEALLOCATE(WORK7,WORK6,WORK3,WORK2,WORK1) + DO IBM=1,NMIX1 + DO IGR=1,NG + IF(NL.LE.2) THEN + FDXM(IBM,IGR)=VOLTOT(IBM)*FHETXM(IBM,IGR,1)/FHOMM(IBM,IGR,1) + FDXP(IBM,IGR)=VOLTOT(IBM)*FHETXP(IBM,IGR,1)/FHOMP(IBM,IGR,1) + ELSE + ! Yamamoto formula + FDXM(IBM,IGR)=VOLTOT(IBM)*(FHETXM(IBM,IGR,1)+2.0* + 1 FHETXM(IBM,IGR,2))/(FHOMM(IBM,IGR,1)+2.0*FHOMM(IBM,IGR,2)) + FDXP(IBM,IGR)=VOLTOT(IBM)*(FHETXP(IBM,IGR,1)+2.0* + 1 FHETXP(IBM,IGR,2))/(FHOMP(IBM,IGR,1)+2.0*FHOMP(IBM,IGR,2)) + ENDIF + ENDDO + ENDDO + IF(IMPX.GT.0) THEN + WRITE(6,'(/48H BRERT: DISCONTINUITY FACTORS BEFORE NORMALIZATI, + 1 2HON)') + DO IBM=1,NMIX1 + WRITE(6,'(/9H MIXTURE=,I5)') IBM + WRITE(6,20) 'FDXM',FDXM(IBM,:NG) + WRITE(6,20) 'FDXP',FDXP(IBM,:NG) + ENDDO + ENDIF +*---- +* COMPUTE ALBEDOS +*---- + IF(ICODE(2).NE.0) THEN + BETA(:)=0.0 + IBM=IMIX(LX1) + DO IGR=1,NG + IF(IBM.EQ.0) CYCLE + AFACTOR(IGR)=FDXP(IBM,IGR)*JXP(IBM,IGR)/FHETXP(IBM,IGR,1) + BETA(IGR)=(1.0-2.0*AFACTOR(IGR))/(1.0+2.0*AFACTOR(IGR)) + ENDDO + IF(IMPX.GT.0) THEN + WRITE(6,'(/15H BRERT: ALBEDOS)') + WRITE(6,20) 'BETA',BETA(:NG) + ENDIF + ENDIF +*---- +* NGET NORMALIZATION OF THE DISCONTINUITY FACTORS +*---- + IF(J_FUEL.GT.0) THEN + IF(NGET.GT.0) THEN + IBM=IMIX(J_FUEL) + DO IGR=1,NG + ! impose the adf on the fuel assembly side + IF(IBM.EQ.0) CYCLE + IF(NGET.EQ.1) THEN + FNORM=ADFREF(IGR)/FDXP(IBM,IGR) + ELSE + FNORM=ADF1(IBM,IGR)/FDXP(IBM,IGR) + ENDIF + FDXP(IBM,IGR)=FDXP(IBM,IGR)*FNORM + IF(J_FUEL1) THEN + IBMM=IMIX(J-1) + IF(IBMM.GT.0) FDXP(IBMM,IGR)=FDXP(IBMM,IGR)*FDXP(IBM,IGR)/ + 1 FDXM(IBM,IGR) + ENDIF + FDXM(IBM,IGR)=FDXP(IBM,IGR) + ENDDO + ENDDO + ENDIF + DO J=J_FUEL+1,LX1 + IBM=IMIX(J) + IF(IBM.EQ.0) CYCLE + DO IGR=1,NG + IF(J HSIGN*12,DBNAME*9,CTITRE*72 + INTEGER ISTATE(NSTATE) + INTEGER IPRINT + INTEGER NBPARA + PARAMETER (NBPARA=18) + REAL DBPARA(NBPARA) +*----- +* PARAMETER VALIDATION. +*----- + IF(NENTRY.LE.28) CALL XABORT('CFC: 29 PARAMETER EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('CFC:' + 1 //' MACROLIB LINKED LIST OR XSM FILE EXPECTED AT LHS.') + IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) CALL XABORT('CFC: ' + 1 //' MACROLIB IN CREATE OR MODIFICATION MODE EXPECTED.') +*----- +* INDIVIDUAL LOCAL PARAMETER. +*----- + IF((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2)) CALL XABORT('CFC:' + 1 //' COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(2).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY ' + 1 //'MODE EXPECTED AT RHS.') + IF((IENTRY(3).NE.1).AND.(IENTRY(3).NE.2)) CALL XABORT('CFC: ' + 1 //'COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(3).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY ' + 1 //' MODE EXPECTED AT RHS.') + IF((IENTRY(4).NE.1).AND.(IENTRY(4).NE.2)) CALL XABORT('CFC: ' + 1 //'COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(4).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY ' + 1 //'MODE EXPECTED AT RHS.') + IF((IENTRY(5).NE.1).AND.(IENTRY(5).NE.2)) CALL XABORT('CFC: ' + 1 //'COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(5).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY ' + 1 //'MODE EXPECTED AT RHS.') + IF((IENTRY(6).NE.1).AND.(IENTRY(6).NE.2)) CALL XABORT('CFC: ' + 1 //'COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(6).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY ' + 1 //'MODE EXPECTED AT RHS.') + IF((IENTRY(7).NE.1).AND.(IENTRY(7).NE.2)) CALL XABORT('CFC: ' + 1 //'COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(7).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY' + 1 //' MODE EXPECTED AT RHS.') + IF((IENTRY(8).NE.1).AND.(IENTRY(8).NE.2)) CALL XABORT('CFC: ' + 1 //'COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(8).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY ' + 1 //'MODE EXPECTED AT RHS.') + IF((IENTRY(9).NE.1).AND.(IENTRY(9).NE.2)) CALL XABORT('CFC: ' + 1 //'COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(9).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY ' + 1 //'MODE EXPECTED AT RHS.') + IF((IENTRY(10).NE.1).AND.(IENTRY(10).NE.2)) CALL XABORT('CFC: ' + 1 //'COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(10).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY ' + 1 //'MODE EXPECTED AT RHS.') + IF((IENTRY(11).NE.1).AND.(IENTRY(11).NE.2)) CALL XABORT('CFC: ' + 1 //'COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(11).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY ' + 1 //'MODE EXPECTED AT RHS.') + IF((IENTRY(12).NE.1).AND.(IENTRY(12).NE.2)) CALL XABORT('CFC: ' + 1 //'COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(12).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY' + 1 //' MODE EXPECTED AT RHS.') + IF((IENTRY(13).NE.1).AND.(IENTRY(13).NE.2)) CALL XABORT('CFC: ' + 1 //'COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(13).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY ' + 1 //'MODE EXPECTED AT RHS.') + IF((IENTRY(14).NE.1).AND.(IENTRY(14).NE.2)) CALL XABORT('CFC: ' + 1 //'COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(14).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY ' + 1 //'MODE EXPECTED AT RHS.') +*----- +* STURATING ISOTOPES +*----- + IF((IENTRY(15).NE.1).AND.(IENTRY(15).NE.2)) CALL XABORT('CFC:' + 1 //' COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(15).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY ' + 1 //'MODE EXPECTED AT RHS.') + IF((IENTRY(16).NE.1).AND.(IENTRY(16).NE.2)) CALL XABORT('CFC: ' + 1 //'COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(16).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY ' + 1 //' MODE EXPECTED AT RHS.') +*----- +* MIXED PARAMETERS +*----- + IF((IENTRY(17).NE.1).AND.(IENTRY(17).NE.2)) CALL XABORT('CFC: ' + 1 //'COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(17).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY ' + 1 //' MODE EXPECTED AT RHS.') + IF((IENTRY(18).NE.1).AND.(IENTRY(18).NE.2)) CALL XABORT('CFC: ' + 1 //'COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(18).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY ' + 1 //' MODE EXPECTED AT RHS.') + IF((IENTRY(19).NE.1).AND.(IENTRY(19).NE.2)) CALL XABORT('CFC: ' + 1 //'COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(19).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY ' + 1 //' MODE EXPECTED AT RHS.') +*----- +* HISTORY PARAMETERS (FISSILE ISOTOPES) +*----- + IF((IENTRY(20).NE.1).AND.(IENTRY(20).NE.2)) CALL XABORT('CFC: ' + 1 //'COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(20).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY ' + 1 //' MODE EXPECTED AT RHS.') + IF((IENTRY(21).NE.1).AND.(IENTRY(21).NE.2)) CALL XABORT('CFC: ' + 1 //'COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(21).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY ' + 1 //' MODE EXPECTED AT RHS.') + IF((IENTRY(22).NE.1).AND.(IENTRY(22).NE.2)) CALL XABORT('CFC: ' + 1 //'COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(22).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY ' + 1 //' MODE EXPECTED AT RHS.') +*----- +* MODERATOR PROPERTIES +*----- + IF((IENTRY(23).NE.1).AND.(IENTRY(23).NE.2)) CALL XABORT('CFC: ' + 1 //'COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(23).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY ' + 1 //' MODE EXPECTED AT RHS.') + IF((IENTRY(24).NE.1).AND.(IENTRY(24).NE.2)) CALL XABORT('CFC: ' + 1 //'COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(24).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY ' + 1 //' MODE EXPECTED AT RHS.') + IF((IENTRY(25).NE.1).AND.(IENTRY(25).NE.2)) CALL XABORT('CFC: ' + 1 //'COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(25).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY ' + 1 //' MODE EXPECTED AT RHS.') + IF((IENTRY(26).NE.1).AND.(IENTRY(26).NE.2)) CALL XABORT('CFC: ' + 1 //'COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(26).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY ' + 1 //' MODE EXPECTED AT RHS.') + IF((IENTRY(27).NE.1).AND.(IENTRY(27).NE.2)) CALL XABORT('CFC: ' + 1 //'COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(27).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY ' + 1 //' MODE EXPECTED AT RHS.') + IF((IENTRY(28).NE.1).AND.(IENTRY(28).NE.2)) CALL XABORT('CFC: ' + 1 //'COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(28).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY ' + 1 //' MODE EXPECTED AT RHS.') + IF((IENTRY(29).NE.1).AND.(IENTRY(29).NE.2)) CALL XABORT('CFC: ' + 1 //'COMPO LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(29).NE.2) CALL XABORT('CFC: COMPO IN READ-ONLY ' + 1 //' MODE EXPECTED AT RHS.') +*----- +* END OF L_COMPO FILES REQUIRED +*----- + ITYPE=JENTRY(1) + IPLIST=KENTRY(1) + IPRINT=1 +*----- +* CHECK THE SIGNTURE OF THE LCM OBJECT +*----- + DO 200 I=2,29 + CALL LCMGTC(KENTRY(I),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_COMPO') THEN + TEXT12=HENTRY(I) + CALL XABORT('CFC: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_COMPO EXPECTED.') + ENDIF + 200 CONTINUE +*---- +* READ THE INPUT FILE +*---- + CALL CFCGET(TINFO,DBNAME,IPRINT,NBPARA,DBPARA) +*----- +* CREATED OR MODIFIED LCM OBJECT TYPE(L_COMPO) +*----- + IF(JENTRY(1).EQ.0) THEN + HSIGN='REACTOR_XSDB' + CALL LCMPTC(KENTRY(1),'SIGNATURE',12,HSIGN) +*----- +* STORE THE INFORMATION TITLE +*----- + CALL LCMPTC(KENTRY(1),'INFORMATION',72,TINFO) + ELSE + CALL LCMGTC(KENTRY(1),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'REACTOR_XSDB') THEN + TEXT12=HENTRY(1) + CALL XABORT('CFC: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. REACTOR_XSDB EXPECTED.') + ENDIF +*----- +* RECOVER THE INFORMATION TITLE +*----- + CALL LCMGTC(KENTRY(1),'INFORMATION',72,CTITRE) + IF(TINFO.NE.CTITRE) THEN + CALL XABORT('CFC: '//CTITRE//' INFOR TITLE EXPECTED.') + ENDIF + ENDIF +*----- +* RECOVER SOME INFORMATIONS FROM THE FIRST COMPO (NOMINAL). +*----- + TEXT12='SIGNATURE' + CALL LCMNXT(KENTRY(2),TEXT12) + IF(TEXT12.EQ.'SIGNATURE') CALL XABORT('CFC: INVALID INPUT COMPO.') + CALL LCMSIX(KENTRY(2),TEXT12,1) +*----- +* RECOVER THE CPO TITLE. +*----- + CALL LCMLEN(KENTRY(2),'TITLE',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGTC(KENTRY(2),'TITLE',72,CTITRE) + ELSE + CTITRE='*** NO TITLE PROVIDED ***' + ENDIF + CALL LCMSIX(KENTRY(2),' ',2) +*----- +* READ PARAMETERS +*----- + ISTATE(:NSTATE)=0 + CALL LCMGET(KENTRY(2),'STATE-VECTOR',ISTATE) + IF(ISTATE(1).GT.1) THEN + WRITE(HSMG,'(28HNUMBER OF MIXUTRE SAVED IS =,I5, + 1 28H ONLY ONE REGION IS REQUIRED)') ISTATE(1) + CALL XABORT(HSMG) + ENDIF + NGRP=ISTATE(2) + NISO=ISTATE(3) + NL=ISTATE(4) + NBURN=ISTATE(5) + NXS=21+NL +*----- +* CHECK OTHERS CPO INFORMATIONS. +*----- + DO 100 I=3,29 + TEXT12='SIGNATURE' + CALL LCMNXT(KENTRY(I),TEXT12) + IF(TEXT12.EQ.'SIGNATURE') CALL XABORT('CFC: INVALID ' + 1 //'INPUT COMPO.') + ISTATE(:NSTATE)=0 + CALL LCMGET(KENTRY(I),'STATE-VECTOR',ISTATE) +* +* ENERGY GROUP AND ORDER OF SCATTERING ANISOTROPY. +* + IF(ISTATE(2).NE.NGRP) THEN + WRITE(HSMG,'(7HNGRP = ,I5,13H IN REF NGRP=,I5)') + 1 ISTATE(2),NGRP + CALL XABORT('CFC: INCONSISTENT NB OF GROUPS ' + 1 //TEXT12//' IS '//HSMG//' ') + ELSE IF(ISTATE(4).LT.NL) THEN + WRITE(HSMG,'(5HNL = ,I5,11H IN REF NL=,I5)') + 1 ISTATE(4),NL + CALL XABORT('CFC: INCONSISTENT NB OF LEGENDRE ORDERS.' + 1 //TEXT12//'IS '//HSMG//' ') + ENDIF + 100 CONTINUE +*----- +* CALL CFC DRIVER. +*----- + CALL CFCDRV(IPRINT,NENTRY,KENTRY,HENTRY,NBURN,NGRP,NISO,NL, + 1 CTITRE,DBNAME,NXS,NBPARA,DBPARA) + RETURN + END diff --git a/Dragon/src/CFCDRV.f b/Dragon/src/CFCDRV.f new file mode 100644 index 0000000..32491f2 --- /dev/null +++ b/Dragon/src/CFCDRV.f @@ -0,0 +1,1117 @@ +*DECK CFCDRV + SUBROUTINE CFCDRV (IPRINT,NENTRY,KENTRY,HENTRY,NBURN,NGRP,NISO, + 1 NL,CTITRE,TEX,NXS,NBPARA,DBPARA) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Driver for the construction of a feedback database. +* +*Copyright: +* Copyright (C) 1996 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): M. T. Sissaoui +* +*Parameters: input +* IPRINT print level. +* NENTRY number of LCM objects. +* KENTRY address of the LCM objects. +* HENTRY name of the LCM objects. +* NBURN number of burnup steps. +* NGRP number of energy groups. +* NISO 1+number of extracted isotopes. +* NL number of Legendre orders. +* CTITRE execution title. +* TEX database name. +* NXS number of reactions (equal to 21+NL). +* NBPARA number of parameters for FBM. +* DBPARA values of parameters for FBM. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) KENTRY(NENTRY) + INTEGER IPRINT,NENTRY,NBURN,NGRP,NISO,NL,NXS,NBPARA + CHARACTER HENTRY(NENTRY)*12,TEX*9 + REAL DBPARA(NBPARA) +*---- +* LOCAL PARAMETERS +*---- + TYPE(C_PTR) IPLISU,IPLISD,IPFBM,IPLIST,IPHISU,IPHISD,IPHIST + INTEGER IOUT,NSTATE + PARAMETER (IOUT=6,NSTATE=40) + CHARACTER TEXT1*8,CM*2,TEXT2*8,HMICRO*12, + 1 TEXTB*12,TEXT(2)*12,TEXTR*12,TEXT12*12,CTITRE*72 + INTEGER ISTATE(NSTATE),IPAR(5),HTITLE(18) + REAL XP(7) +*---- +* ALLOCATABLE STATEMENTS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,MIJ,MNJ,HISO,JTAB, + 1 IXS + REAL, ALLOCATABLE, DIMENSION(:) :: WORK3,DENSIT,EFJ,KBUR,KB + REAL, ALLOCATABLE, DIMENSION(:) :: TOT2,ZN2,DXF2,DYF2,DZF2,HF2, + 1 SCA2,MIRCT2,MIRCS2,MICDX2,MICDY2,MICDZ2,V2,MIRCF2,MIRCH2 + REAL, ALLOCATABLE, DIMENSION(:) :: FLUI3,FLDIS3,OV3,DIFD3,NF3, + 1 CHI3,MCHI3 + REAL, ALLOCATABLE, DIMENSION(:,:) :: TOTAL,ZNUG,DIFFX,DIFFY,DIFFZ, + 1 H,REFC,DELTA + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: TMREF,DMRFX,DMRFY,DMRFZ, + 1 FMREF,HMREF + REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: SCAT + REAL, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: SMREF +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IJJ(NL*NGRP),NJJ(NL*NGRP),MIJ(NL*NGRP),MNJ(NL*NGRP), + 1 HISO(3*NISO),JTAB(NISO),IXS(NXS)) + ALLOCATE(TOTAL(NGRP,NBURN),ZNUG(NGRP,NBURN),DIFFX(NGRP,NBURN), + 1 DIFFY(NGRP,NBURN),DIFFZ(NGRP,NBURN),H(NGRP,NBURN), + 2 SCAT(NBURN,NL,NGRP,NGRP),WORK3(NGRP*(NGRP+1)),DENSIT(NISO), + 3 EFJ(NISO),TMREF(NGRP,NBURN,NISO),SMREF(NISO,NBURN,NL,NGRP,NGRP), + 4 DMRFX(NGRP,NBURN,NISO),DMRFY(NGRP,NBURN,NISO), + 5 DMRFZ(NGRP,NBURN,NISO),REFC(NBURN,NISO),FMREF(NGRP,NBURN,NISO), + 6 HMREF(NGRP,NBURN,NISO),DELTA(NBURN,2)) +*----- +* REFERENCE(NOMINAL) LOCAL PARAMETER +*----- + PWR=DBPARA(1) + TCR=DBPARA(2) + TMR=DBPARA(3) + TFR=DBPARA(4) + RHOM=DBPARA(5) + RHOC=DBPARA(6) + XIR=DBPARA(7) + TFU=DBPARA(8) + TCU=DBPARA(9) + PWUL=DBPARA(10) + PWDL=DBPARA(11) + PWU=DBPARA(12) + PWD=DBPARA(13) + XI=DBPARA(14) +C +C FLAG FOR COLLISION PROBABILITY CALCULATION +C IXYZ=0 PIJ CALCULATION +C IXYZ=1 PIJK CALCULATION +C + IXYZ=0 +C----- +C CHECK NGRP AND NBURN +C----- + IF(NBURN.EQ.0) CALL XABORT('CFCDRV: ZERO NUMBER OF MIXTURES.') + IF(NGRP.EQ.0) CALL XABORT('CFCDRV: ZERO NUMBER OF GROUPS.') +C +C ONLY THE FIRST ORDER IS CONSIDERED IN FBM +C +C----------------------------------------------------------------------C +C----- +C DYNAMIC MEMORY ALLOCATION +C----- + ALLOCATE(TOT2(2*NBURN*NGRP),ZN2(2*NBURN*NGRP),DXF2(2*NBURN*NGRP), + 1 DYF2(2*NBURN*NGRP),DZF2(2*NBURN*NGRP),HF2(2*NBURN*NGRP), + 2 SCA2(2*NBURN*NL*NGRP*NGRP),MIRCT2(2*NBURN*NISO*NGRP), + 3 MIRCS2(2*NBURN*NL*NGRP*NGRP*NISO),MICDX2(2*NBURN*NISO*NGRP), + 4 MICDY2(2*NBURN*NISO*NGRP),MICDZ2(2*NBURN*NISO*NGRP),V2(16*NBURN), + 5 MIRCF2(2*NBURN*NISO*NGRP),MIRCH2(2*NBURN*NISO*NGRP)) +C +C----- +C DATABASE FILE UNIT NUMBER +C----- + IPFBM=KENTRY(1) +C----- +C STOTRE THE NOMINAL LOCAL PARAMETER IN THE DATABASE +C IP=1 FOR THE FUEL +C IP=2 FOR THE REFLECTOR +C----- + DO 801 IP=1,2 +C +C INITIALIZATION OF THE MATRICES. +C + JTAB(:NISO)=0 + TOTAL(:NGRP,:NBURN)=0.0 + ZNUG(:NGRP,:NBURN)=0.0 + DIFFX(:NGRP,:NBURN)=0.0 + DIFFY(:NGRP,:NBURN)=0.0 + DIFFZ(:NGRP,:NBURN)=0.0 + H(:NGRP,:NBURN)=0.0 + TMREF(:NGRP,:NBURN,:NISO)=0.0 + DMRFX(:NGRP,:NBURN,:NISO)=0.0 + DMRFY(:NGRP,:NBURN,:NISO)=0.0 + DMRFZ(:NGRP,:NBURN,:NISO)=0.0 + FMREF(:NGRP,:NBURN,:NISO)=0.0 + HMREF(:NGRP,:NBURN,:NISO)=0.0 + SCAT(:NBURN,:NL,:NGRP,:NGRP)=0.0 + SMREF(:NISO,:NBURN,:NL,:NGRP,:NGRP)=0.0 + DO 10 IGR=1,NGRP + IJJ(IGR)=IGR + NJJ(IGR)=1 + MIJ(IGR)=IGR + MNJ(IGR)=1 + 10 CONTINUE +C + DO 44 ILOC=1,7 + IF(ILOC.EQ.1) THEN + HMICRO='PW' + XP(ILOC)=PWR + ELSE IF(ILOC.EQ.2) THEN + HMICRO='TCOOL' + XP(ILOC)=TCR + ELSE IF(ILOC.EQ.3) THEN + HMICRO='TMOD' + XP(ILOC)=TMR + ELSE IF(ILOC.EQ.4) THEN + HMICRO='TFUEL' + XP(ILOC)=TFR + ELSE IF(ILOC.EQ.5) THEN + HMICRO='RHOC' + XP(ILOC)=RHOC + ELSE IF(ILOC.EQ.6) THEN + HMICRO='RHOM' + XP(ILOC)=RHOM + ELSE IF(ILOC.EQ.7) THEN + HMICRO='PUR' + XP(ILOC)=XIR + ENDIF + READ(HMICRO,'(3A4)') (HISO((ILOC-1)*3+IH),IH=1,3) + 44 CONTINUE +C----- +C TYPE OF PROPERTIES +C----- + IF(IP.EQ.1) THEN + IPLIST=KENTRY(2) + TEXTR='FUL'//TEX + ELSE + IPLIST=KENTRY(23) + TEXTR='MOD'//TEX + ENDIF +C----------------------------------------------------------------------C +C----- +C RECOVER AND STORE NEUTRONICS PARAMETRES +C----- + IF(IP.EQ.1) THEN + CALL LCMSIX(IPFBM,TEXTR,1) + CALL LCMSIX(IPFBM,'INFO-NOMINA',1) + CALL LCMPUT(IPFBM,'NOMINALN',3*7,3,HISO) + CALL LCMPUT(IPFBM,'NOMINALP',7,2,XP) + CALL LCMSIX(IPFBM,' ',2) + READ(CTITRE,'(18A4)') (HTITLE(I),I=1,18) + CALL LCMPUT(IPFBM,'TITLE',18,3,HTITLE) + IPAR(1)=NGRP + IPAR(2)=NISO + IPAR(3)=NL + IPAR(4)=NBURN + NBUM=NBURN + NISM=NISO + CALL LCMPUT(IPFBM,'PARAM',4,1,IPAR) + CALL LCMSIX(IPFBM,' ',2) + ELSE + TEXT12='SIGNATURE' + CALL LCMNXT(IPLIST,TEXT12) +C + IF(TEXT12.EQ.'SIGNATURE') CALL XABORT('CFCDRV: ' + 1 //'INVALID INPUT COMPO.') + CALL LCMGET(IPLIST,'STATE-VECTOR',ISTATE) + CALL LCMSIX(IPLIST,TEXT12,1) + CALL LCMSIX(IPLIST,' ',2) + NGRP=ISTATE(2) + NISO=ISTATE(3) + NL=ISTATE(4) + NBURN=ISTATE(5) +C + CALL LCMSIX(IPFBM,TEXTR,1) + CALL LCMSIX(IPFBM,'INFO-NOMINA',1) + CALL LCMPUT(IPFBM,'NOMINALN',3*7,3,HISO) + CALL LCMPUT(IPFBM,'NOMINALP',7,2,XP) + CALL LCMSIX(IPFBM,' ',2) + READ(CTITRE,'(18A4)') (HTITLE(I),I=1,18) + CALL LCMPUT(IPFBM,'TITLE',18,3,HTITLE) + CALL LCMSIX(IPFBM,' ',2) + ENDIF +C +C RECOVER INFORMATION FROM CPO FILE(NOMINAL) +C + ALLOCATE(KB(NBURN),KBUR(NBURN)) + IF(IP.EQ.1) THEN + CALL LCMSIX(IPLIST,'REF 1',1) + ELSE + CALL LCMSIX(IPLIST,'MODREF 1',1) + ENDIF + CALL LCMGET(IPLIST,'ISOTOPESNAME',HISO) + CALL LCMGET(IPLIST,'VOLUME',VOL) + CALL LCMGET(IPLIST,'ENERGY',WORK3) + CALL LCMGET(IPLIST,'BURNUP',KBUR) + CALL LCMGET(IPLIST,'N/KB',KB) + CALL LCMSIX(IPLIST,' ',2) +C +C STORE INFORMATION IN THE DATABASE +C + CALL LCMSIX(IPFBM,TEXTR,1) + CALL LCMPUT(IPFBM,'HITAB',3*NISO,3,HISO) + CALL LCMPUT(IPFBM,'VOLUME',1,2,VOL) + CALL LCMPUT(IPFBM,'ENERGY',NGRP+1,2,WORK3) + CALL LCMPUT(IPFBM,'BURNUP',NBURN,2,KBUR) + CALL LCMPUT(IPFBM,'N/KB',NBURN,2,KB) + CALL LCMSIX(IPFBM,' ',2) +C + DEALLOCATE(KBUR,KB) +C----- +C GOING DOWN TO THE MACR AND MICR SUB-DIRECTORIES +C----- +C +C DYNAMIC ALLOCATION MEMORY +C + ALLOCATE(FLUI3(NGRP),FLDIS3(NGRP),OV3(NGRP),DIFD3(3*NGRP), + 1 NF3(NGRP),CHI3(NGRP),MCHI3(NGRP)) +C + DO 20 I=1,NBURN + WRITE(TEXTB,'(4HBURN,4X,I4)') I + IF(IP.EQ.1) THEN + CALL LCMSIX(IPLIST,'REF 1',1) + ELSE + CALL LCMSIX(IPLIST,'MODREF 1',1) + ENDIF + CALL LCMSIX(IPLIST,TEXTB,1) + CALL LCMGET(IPLIST,'ISOTOPESDENS',DENSIT) + CALL LCMGET(IPLIST,'ISOTOPES-EFJ',EFJ) + IF(DENSIT(1).NE.1.0) CALL XABORT('FBM: DENSIT(1).NE.1.') + CALL LCMGET(IPLIST,'FLUX-INTG',FLUI3) + CALL LCMGET(IPLIST,'FLUXDISAFACT',FLDIS3) + CALL LCMGET(IPLIST,'OVERV',OV3) +C----- +C RECOVER MACROSCOPIC X-SECTIONS. +C----- + CALL LCMSIX(IPLIST,'MACR',1) + IXS(:NXS)=0 + CALL LCMGET(IPLIST,'XS-SAVED',IXS) + CALL LCMGET(IPLIST,'SCAT-SAVED',IXS(21)) + IF(IXS(18).EQ.1) IXYZ=1 + IF(IXS(3).EQ.1) JTAB(1)=1 +C + IF(IXS(1).EQ.1) CALL LCMGET(IPLIST,'TOTAL',TOTAL(1,I)) + IF(IXS(3).EQ.1) CALL LCMGET(IPLIST,'NUSIGF',ZNUG(1,I)) + IF(IXS(4).EQ.1) THEN + CALL LCMGET(IPLIST,'NFTOT',NF3) + CALL LCMGET(IPLIST,'NFTOT',H(1,I)) + DO 11 IGR=1,NGRP + H(IGR,I)=H(IGR,I)*EFJ(1) + 11 CONTINUE + ENDIF + IF(IXS(5).EQ.1) CALL LCMGET(IPLIST,'CHI',CHI3) + IF(IXS(17).EQ.1) CALL LCMGET(IPLIST,'STRD ',DIFFX(1,I)) + IF(IXS(18).EQ.1) CALL LCMGET(IPLIST,'STRD X',DIFFX(1,I)) + IF(IXS(19).EQ.1) CALL LCMGET(IPLIST,'STRD Y',DIFFY(1,I)) + IF(IXS(20).EQ.1) CALL LCMGET(IPLIST,'STRD Z',DIFFZ(1,I)) + CALL LCMLEN(IPLIST,'NUSIGF',ILENGF,ITYLCM) +C +C RECOVER SCATTERING X-SECTIONS. +C + IL=1 + WRITE (CM,'(I2.2)') IL-1 + IF(IXS(20+IL).EQ.1) THEN + CALL LCMGET(IPLIST,'SIGS'//CM,WORK3) + DO 110 IGR=1,NGRP + TOTAL(IGR,I)= TOTAL(IGR,I)-WORK3(IGR) + 110 CONTINUE +C + CALL LCMLEN(IPLIST,'SCAT'//CM,LENGT,ITYLCM) + CALL LCMGET(IPLIST,'SCAT'//CM,WORK3) + CALL LCMGET(IPLIST,'NJJS'//CM,NJJ) + CALL LCMGET(IPLIST,'IJJS'//CM,IJJ) + IGAR=0 + DO 125 JGR=1,NGRP + DO 120 IGR=IJJ(JGR),IJJ(JGR)-NJJ(JGR)+1,-1 + IGAR=IGAR+1 + SCAT(I,IL,IGR,JGR)=WORK3(IGAR) + 120 CONTINUE + 125 CONTINUE + ENDIF +C + CALL LCMSIX(IPLIST,' ',2) +C----- +C RECOVER MICROSCOPIC X-SECTIONS. +C----- + DO 40 ISO=2,NISO + IF(DENSIT(ISO).EQ.0.0) GO TO 40 + WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+IH),IH=1,3) + REFC(I,ISO)=DENSIT(ISO) + CALL LCMSIX(IPLIST,HMICRO,1) + CALL LCMGET(IPLIST,'XS-SAVED',IXS) + CALL LCMGET(IPLIST,'SCAT-SAVED',IXS(21)) + IF(IXS(3).EQ.1) JTAB(ISO)=1 + IF(IXS(1).EQ.1) CALL LCMGET(IPLIST,'TOTAL',TMREF(1,I,ISO)) +C +C COMPUTE THE ABSORPTION XS +C + IL=1 + WRITE (CM,'(I2.2)') IL-1 + IF(IXS(20+IL).EQ.1) THEN + CALL LCMGET(IPLIST,'SIGS'//CM,WORK3) + DO 231 IGR=1,NGRP + TMREF(IGR,I,ISO)= TMREF(IGR,I,ISO)-WORK3(IGR) + 231 CONTINUE + ENDIF +C + IF(IXS(17).EQ.1) CALL LCMGET(IPLIST,'STRD ',DMRFX(1,I,ISO)) + IF(IXS(18).EQ.1) CALL LCMGET(IPLIST,'STRD X',DMRFX(1,I,ISO)) + IF(IXS(19).EQ.1) CALL LCMGET(IPLIST,'STRD Y',DMRFY(1,I,ISO)) + IF(IXS(20).EQ.1) CALL LCMGET(IPLIST,'STRD Z',DMRFZ(1,I,ISO)) +C +C ADD THE CONTRIBURTION OF THE MICR. X-SECTIONS +C + DO 721 IGR=1,NGRP + TOTAL(IGR,I)=TOTAL(IGR,I) + DENSIT(ISO)*TMREF(IGR,I,ISO) + DIFFX(IGR,I)=DIFFX(IGR,I) + DENSIT(ISO)*DMRFX(IGR,I,ISO) + DIFFY(IGR,I)=DIFFY(IGR,I) + DENSIT(ISO)*DMRFY(IGR,I,ISO) + DIFFZ(IGR,I)=DIFFZ(IGR,I) + DENSIT(ISO)*DMRFZ(IGR,I,ISO) + 721 CONTINUE +C + IF(IXS(3).EQ.1) THEN + CALL LCMGET(IPLIST,'NUSIGF',FMREF(1,I,ISO)) + DO 30 IGR=1,NGRP + ZNUG(IGR,I)=ZNUG(IGR,I) + DENSIT(ISO)*FMREF(IGR,I,ISO) + 30 CONTINUE + ENDIF + IF(IXS(4).EQ.1) THEN + CALL LCMGET(IPLIST,'NFTOT',WORK3) + CALL LCMGET(IPLIST,'NFTOT',HMREF(1,I,ISO)) + DO 31 IGR=1,NGRP + HMREF(IGR,I,ISO)=HMREF(IGR,I,ISO)*EFJ(ISO) + NF3(IGR)=NF3(IGR)+DENSIT(ISO)*WORK3(IGR) + H(IGR,I)=H(IGR,I) + DENSIT(ISO)*HMREF(IGR,I,ISO) + 31 CONTINUE + ENDIF + IF(IXS(5).EQ.1) CALL LCMGET(IPLIST,'CHI',MCHI3) + CALL LCMSIX(IPLIST,' ',2) + 40 CONTINUE + CALL LCMSIX(IPLIST,' ',2) + CALL LCMSIX(IPLIST,' ',2) +C----------------------------------------------------------------------C +C----- +C STORE PROPERTIES +C----- + CALL LCMSIX(IPFBM,TEXTR,1) +C + CALL LCMPUT(IPFBM,'JTAB',NISO,1,JTAB) +C + CALL LCMSIX(IPFBM,TEXTB,1) + CALL LCMPUT(IPFBM,'ISOTOPESDENS',NISO,2,DENSIT) + CALL LCMPUT(IPFBM,'FLUX-INTG',NGRP,2,FLUI3) + CALL LCMPUT(IPFBM,'OVERV',NGRP,2,OV3) + CALL LCMPUT(IPFBM,'FLUXDISAFACT',NGRP,2,FLDIS3) +C +C STORE MACROSCOPIC X-SECTIONS +C + CALL LCMSIX(IPFBM,'MACR',1) + CALL LCMSIX(IPFBM,'ABS',1) + CALL LCMPUT(IPFBM,'REF',NGRP,2,TOTAL(1,I)) + CALL LCMSIX(IPFBM,' ',2) + IF(IXYZ.EQ.0) THEN + CALL LCMSIX(IPFBM,'STRD',1) + CALL LCMPUT(IPFBM,'REF',NGRP,2,DIFFX(1,I)) + CALL LCMSIX(IPFBM,' ',2) + ELSE IF(IXYZ.EQ.1) THEN + CALL LCMSIX(IPFBM,'STRD X',1) + CALL LCMPUT(IPFBM,'REF',NGRP,2,DIFFX(1,I)) + CALL LCMSIX(IPFBM,' ',2) + CALL LCMSIX(IPFBM,'STRD Y',1) + CALL LCMPUT(IPFBM,'REF',NGRP,2,DIFFY(1,I)) + CALL LCMSIX(IPFBM,' ',2) + CALL LCMSIX(IPFBM,'STRD Z',1) + CALL LCMPUT(IPFBM,'REF',NGRP,2,DIFFZ(1,I)) + CALL LCMSIX(IPFBM,' ',2) + ENDIF + IF(JTAB(1).EQ.1) THEN + CALL LCMSIX(IPFBM,'NUSIGF',1) + CALL LCMPUT(IPFBM,'REF',NGRP,2,ZNUG(1,I)) + CALL LCMSIX(IPFBM,' ',2) + CALL LCMSIX(IPFBM,'H-FACTORS',1) + CALL LCMPUT(IPFBM,'REF',NGRP,2,H(1,I)) + CALL LCMSIX(IPFBM,' ',2) + CALL LCMPUT(IPFBM,'CHI',NGRP,2,CHI3) + CALL LCMPUT(IPFBM,'NFTOT',NGRP,2,NF3) + ENDIF + CALL LCMSIX(IPFBM,' ',2) +C +C STORE MICROSCOPIC X-SECTIONS +C + DO 49 ISO=2,NISO + IF(DENSIT(ISO).EQ.0.0) GO TO 49 + WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+IH),IH=1,3) + CALL LCMSIX(IPFBM,HMICRO,1) + CALL LCMSIX(IPFBM,'ABS',1) + CALL LCMPUT(IPFBM,'REF',NGRP,2,TMREF(1,I,ISO)) + CALL LCMSIX(IPFBM,' ',2) + IF(IXYZ.EQ.0) THEN + CALL LCMSIX(IPFBM,'STRD',1) + CALL LCMPUT(IPFBM,'REF',NGRP,2,DMRFX(1,I,ISO)) + CALL LCMSIX(IPFBM,' ',2) + ELSE IF(IXYZ.EQ.1) THEN + CALL LCMSIX(IPFBM,'STRD X',1) + CALL LCMPUT(IPFBM,'REF',NGRP,2,DMRFX(1,I,ISO)) + CALL LCMSIX(IPFBM,' ',2) + CALL LCMSIX(IPFBM,'STRD Y',1) + CALL LCMPUT(IPFBM,'REF',NGRP,2,DMRFY(1,I,ISO)) + CALL LCMSIX(IPFBM,' ',2) + CALL LCMSIX(IPFBM,'STRD Z',1) + CALL LCMPUT(IPFBM,'REF',NGRP,2,DMRFZ(1,I,ISO)) + CALL LCMSIX(IPFBM,' ',2) + ENDIF + IF(JTAB(ISO).EQ.1) THEN + CALL LCMSIX(IPFBM,'NUSIGF',1) + CALL LCMPUT(IPFBM,'REF',NGRP,2,FMREF(1,I,ISO)) + CALL LCMSIX(IPFBM,' ',2) + CALL LCMSIX(IPFBM,'H-FACTORS',1) + CALL LCMPUT(IPFBM,'REF',NGRP,2,HMREF(1,I,ISO)) + CALL LCMSIX(IPFBM,' ',2) + CALL LCMPUT(IPFBM,'CHI',NGRP,2,MCHI3) + ENDIF + CALL LCMSIX(IPFBM,' ',2) + 49 CONTINUE + CALL LCMSIX(IPFBM,' ',2) + CALL LCMSIX(IPFBM,' ',2) +C----- +C RECOVER MICROSCOPIC CONTRIBUTIONS OF SCATTERING X-SECTIONS. +C----- + DO 160 ISO=2,NISO + IF(DENSIT(ISO).EQ.0.0) GO TO 160 + WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+IH),IH=1,3) + IF(IP.EQ.1) THEN + CALL LCMSIX(IPLIST,'REF 1',1) + ELSE + CALL LCMSIX(IPLIST,'MODREF 1',1) + ENDIF + CALL LCMSIX(IPLIST,TEXTB,1) + CALL LCMLEN(IPLIST,HMICRO,ILENG,ITYLCM) + IF(ILENG.NE.0) THEN + CALL LCMSIX(IPLIST,HMICRO,1) + CALL LCMGET(IPLIST,'XS-SAVED',IXS) + CALL LCMGET(IPLIST,'SCAT-SAVED',IXS(21)) +C + IL=1 + WRITE (CM,'(I2.2)') IL-1 + IF(IXS(20+IL).EQ.1) THEN + CALL LCMGET(IPLIST,'SCAT'//CM,WORK3) + CALL LCMGET(IPLIST,'NJJS'//CM,NJJ) + CALL LCMGET(IPLIST,'IJJS'//CM,IJJ) + IGAR=0 + DO 150 JGR=1,NGRP + DO 140 IGR=IJJ(JGR),IJJ(JGR)-NJJ(JGR)+1,-1 + IGAR=IGAR+1 + SMREF(ISO,I,IL,IGR,JGR)=WORK3(IGAR) + SCAT(I,IL,IGR,JGR)=SCAT(I,IL,IGR,JGR)+DENSIT(ISO)*WORK3(IGAR) + 140 CONTINUE + 150 CONTINUE + ENDIF +C + CALL LCMSIX(IPLIST,' ',2) + ENDIF + CALL LCMSIX(IPLIST,' ',2) + CALL LCMSIX(IPLIST,' ',2) + 160 CONTINUE +C----------------------------------------------------------------------C +C +C STORE MACROSCOPIC SCATTERING X-SECTIONS +C + CALL LCMSIX(IPFBM,TEXTR,1) + CALL LCMSIX(IPFBM,TEXTB,1) +C + CALL LCMSIX(IPFBM,'MACR',1) + IL=1 + WRITE (CM,'(I2)') IL-1 + CALL LCMSIX(IPFBM,'SCAT'//CM,1) + IGARM=0 + DO 799 JGR=1,NGRP + IGRMIN=JGR + IGRMAX=JGR + DO 899 IGR=1,NGRP + IF(SCAT(I,IL,IGR,JGR).NE.0.0) THEN + IGRMIN=MIN(IGRMIN,IGR) + IGRMAX=MAX(IGRMAX,IGR) + ENDIF + 899 CONTINUE + MIJ(JGR)=IGRMAX + MNJ(JGR)=IGRMAX-IGRMIN+1 + DO 795 IGR=MIJ(JGR),MIJ(JGR)-MNJ(JGR)+1,-1 + IGARM=IGARM+1 + WORK3(IGARM)=SCAT(I,IL,IGR,JGR) + 795 CONTINUE + 799 CONTINUE + CALL LCMPUT(IPFBM,'NJJ',NGRP,1,MNJ) + CALL LCMPUT(IPFBM,'IJJ',NGRP,1,MIJ) + CALL LCMPUT(IPFBM,'REF',IGARM,2,WORK3) + CALL LCMSIX(IPFBM,' ',2) +C +C + CALL LCMSIX(IPFBM,' ',2) +C +C +C STORE THE SCATTERING X-SECTIONS +C + DO 860 ISO=2,NISO + IF(DENSIT(ISO).EQ.0.0) GO TO 860 + WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+IH),IH=1,3) + CALL LCMSIX(IPFBM,HMICRO,1) + IL=1 + WRITE (CM,'(I2)') IL-1 + CALL LCMSIX(IPFBM,'SCAT'//CM,1) + IGARM=0 + DO 105 JGR=1,NGRP + DO 100 IGR=MIJ(JGR),MIJ(JGR)-MNJ(JGR)+1,-1 + IGARM=IGARM+1 + WORK3(IGARM)=SMREF(ISO,I,IL,IGR,JGR) + 100 CONTINUE + 105 CONTINUE + CALL LCMPUT(IPFBM,'REF',IGARM,2,WORK3) + CALL LCMPUT(IPFBM,'NJJ',NGRP,1,MNJ) + CALL LCMPUT(IPFBM,'IJJ',NGRP,1,MIJ) + CALL LCMSIX(IPFBM,' ',2) +C + CALL LCMSIX(IPFBM,' ',2) + 860 CONTINUE + CALL LCMSIX(IPFBM,' ',2) + CALL LCMSIX(IPFBM,' ',2) + 20 CONTINUE +C + DEALLOCATE(MCHI3,CHI3,NF3,DIFD3,OV3,FLDIS3,FLUI3) + WRITE(IOUT,9000) +C----------------------------------------------------------------------C +C C +C FUEL COEFFICIENTS CALCULATIONS C +C C +C----------------------------------------------------------------------C +C MIXP =0 : INDIVIDUAL LOCAL PARAMETER C +C MIXP =1 : MIXDED LOCAL PARAMETER C +C NB =1 : THE COEFFICIENTS CALCULATION REQUIRE ONE L_COMPO C +C NB =2 : THE COEFFICIENTS CALCULATION REQUIRE TWO L_COMPO C +C TEXT1 : FIRST RECORD ON WHICH THE COEFF. ARE STORED (NB=1) C +C TEXT2 : SECOND RECORD ON WHICH THE COEFF. ARE STORED (NB=2) C +C----------------------------------------------------------------------C +C + IF(IP.EQ.1) THEN + DO 111 J=1,5 + JJU=2*J+1 + JJD=2*J+2 + IPLISU=KENTRY(JJU) + IPLISD=KENTRY(JJD) + IF(ABS(IPRINT) .GT. 5) THEN + WRITE(IOUT,6000) JJU,HENTRY(JJU),JJD,HENTRY(JJD) + ENDIF + NB=2 + MIXP=0 +C----- +C COMPUTE FUEL TEMPERATURE COEFFICIENTS (TWO L_COMPO) +C----- + IF(J.EQ.1) THEN + TEXT(1)='SIGNATURE' + CALL LCMNXT(IPLISU,TEXT(1)) + IF(TEXT(1).NE.'FTEMP-UP 1') THEN + CALL XABORT('CFCDRV: FTEMP-UP COMPO EXPECTED.') + ENDIF + TEXT(2)='SIGNATURE' + CALL LCMNXT(IPLISD,TEXT(2)) + IF(TEXT(2).NE.'FTEMP-D 1') CALL XABORT('CFCDRV: ' + 1 //' FTEMP-D COMPO EXPECTED.') + TEXT1='T1F' + TEXT2='T2F' +C----- +C COMPUTE COOLANT TEMPERATURE COEFFICIENTS (TWO L_COMPO) +C----- + ELSE IF(J.EQ.2) THEN + TEXT(1)='SIGNATURE' + CALL LCMNXT(IPLISU,TEXT(1)) + IF(TEXT(1).NE.'CTEMP-UP 1') THEN + CALL XABORT('CFCDRV: CTEMP-UP COMPO EXPECTED.') + ENDIF + TEXT(2)='SIGNATURE' + CALL LCMNXT(IPLISD,TEXT(2)) + IF(TEXT(2).NE.'CTEMP-D 1') CALL XABORT('CFCDRV:' + 1 //' CTEMP-D COMPO EXPECTED.') + TEXT1='T1C' + TEXT2='T2C' +C----- +C COMPUTE MODERATOR TEMPERATURE COEFFICIENTS (TWO L_COMPO) +C----- + ELSE IF(J.EQ.3) THEN + TEXT(1)='SIGNATURE' + CALL LCMNXT(IPLISU,TEXT(1)) + IF(TEXT(1).NE.'MTEMP-UP 1') THEN + CALL XABORT('CFCDRV: MTEMP-UP COMPO EXPECTED.') + ENDIF + TEXT(2)='SIGNATURE' + CALL LCMNXT(IPLISD,TEXT(2)) + IF(TEXT(2).NE.'MTEMP-D 1') CALL XABORT('CFCDRV:' + 1 //' MTEMP-D COMPO EXPECTED.') + TEXT1='T1M' + TEXT2='T2M' +C----- +C COMPUTE COOLANT DENSITY COEFFICIENTS (TWO L_COMPO) +C----- + ELSE IF(J.EQ.4) THEN + TEXT(1)='SIGNATURE' + CALL LCMNXT(IPLISU,TEXT(1)) + IF(TEXT(1).NE.'CDEN-UP 1') THEN + CALL XABORT('CFCDRV: CDEN-UP COMPO EXPECTED.') + ENDIF + TEXT(2)='SIGNATURE' + CALL LCMNXT(IPLISD,TEXT(2)) + IF(TEXT(2).NE.'CDEN-D 1') CALL XABORT('CFCDRV:' + 1 //' CDEN-D COMPO EXPECTED.') + TEXT1='D1C' + TEXT2='D2C' +C----- +C COMPUTE MODERATOR DENSITY COEFFICIENTS (TWO L_COMPO) +C----- + ELSE IF(J.EQ.5) THEN + TEXT(1)='SIGNATURE' + CALL LCMNXT(IPLISU,TEXT(1)) + IF(TEXT(1).NE.'MDEN-UP 1') THEN + CALL XABORT('CFCDRV: MDEN-UP COMPO EXPECTED.') + ENDIF + TEXT(2)='SIGNATURE' + CALL LCMNXT(IPLISD,TEXT(2)) + IF(TEXT(2).NE.'MDEN-D 1') CALL XABORT('CFCDRV:' + 1//' MDEN-D COMPO EXPECTED.') + TEXT1='D1M' + TEXT2='D2M' + ENDIF +C + CALL CFCFBM(TEXT1,TEXT2,IPLISU,IPLISD,IPFBM,NGRP,NBUM,NISM, + 1 NBURN,NISO,HISO,NL,IPRINT,TOTAL,ZNUG,DIFFX,DIFFY,DIFFZ, + 1 H,SCAT,MIJ,MNJ,TMREF,SMREF,DMRFX,DMRFY,DMRFZ,TOT2,ZN2,DXF2, + 1 DYF2,DZF2,HF2,SCA2,WORK3,REFC,MIRCT2,MIRCS2,MICDX2,MICDY2, + 1 MICDZ2,DELTA,DENSIT,TFR,TCR,TMR,XIR,TEXT,TEXTR,NB,MIRCF2, + 1 MIRCH2,FMREF,HMREF,JTAB,MIXP,V2,EFJ,NXS,IXYZ,NBPARA,DBPARA) + 111 CONTINUE + WRITE(IOUT,9001) +C----------------------------------------------------------------------C +C C +C C +C----------------------------------------------------------------------C + DO 112 J=13,21 + IPLISU=KENTRY(J) + IPLISD=IPLISU + NB=1 + MIXP=0 + IF(ABS(IPRINT) .GT. 5) THEN + WRITE(IOUT,6001) J,HENTRY(J) + ENDIF +C----- +C COMPUTE BORON COEFFICIENTS (ONE L_COMPO) +C----- + IF(J.EQ.13) THEN + TEXT(1)='SIGNATURE' + CALL LCMNXT(IPLISU,TEXT(1)) + IF(TEXT(1).NE.'BORON 1') THEN + CALL XABORT('CFCDRV: BORON COMPO EXPECTED.') + ENDIF + TEXT1='BOR' + TEXT2='BOR' + TEXT(2)=TEXT(1) +C----- +C COMPUTE PURITY COEFFICIENTS (ONE L_COMPO) +C----- + ELSE IF(J.EQ.14) THEN + TEXT(1)='SIGNATURE' + CALL LCMNXT(IPLISU,TEXT(1)) + IF(TEXT(1).NE.'PURITY 1') THEN + CALL XABORT('CFCDRV: BORON COMPO EXPECTED.') + ENDIF + TEXT1='PUR' + TEXT2='PUR' + TEXT(2)=TEXT(1) +C----- +C COMPUTE XENON COEFFICIENTS (ONE L_COMPO) +C----- + ELSE IF(J.EQ.15) THEN + TEXT(1)='SIGNATURE' + CALL LCMNXT(IPLISU,TEXT(1)) + IF(TEXT(1).NE.'XENON 1') THEN + CALL XABORT('CFCDRV: XENON COMPO EXPECTED.') + ENDIF + TEXT1='XEN' + TEXT2='XEN' + TEXT(2)=TEXT(1) +C----- +C COMPUTE SAMARIUM COEFFICIENTS (ONE L_COMPO) +C----- + ELSE IF(J.EQ.16) THEN + TEXT(1)='SIGNATURE' + CALL LCMNXT(IPLISU,TEXT(1)) + IF(TEXT(1).NE.'SM149 1') THEN + CALL XABORT('CFCDRV: SM149 COMPO EXPECTED.') + ENDIF + TEXT1='SM149' + TEXT2='SM149' + TEXT(2)=TEXT(1) +C----- +C COMPUTE NP239 COEFFICIENTS (ONE L_COMPO) +C----- + ELSE IF(J.EQ.17) THEN + TEXT(1)='SIGNATURE' + CALL LCMNXT(IPLISU,TEXT(1)) + IF(TEXT(1).NE.'NP239 1') THEN + CALL XABORT('CFCDRV: NP239 COMPO EXPECTED.') + ENDIF + TEXT1='NP239' + TEXT2='NP239' + TEXT(2)=TEXT(1) +C----- +C COMPUTE MIXED FUEL AND DENSITY COEFFICIENTS (ONE L_COMPO) +C----- + ELSE IF(J.EQ.18) THEN + TEXT(1)='SIGNATURE' + CALL LCMNXT(IPLISU,TEXT(1)) + IF(TEXT(1).NE.'MIXFD 1') THEN + CALL XABORT('CFCDRV: MIXFD COMPO EXPECTED.') + ENDIF + MIXP=1 + TEXT1='MIXFD' + TEXT2='MIXFD' + TEXT(2)=TEXT(1) +C----- +C COMPUTE MIXED COLLANT AND DENSITY COEFFICIENTS (ONE L_COMPO) +C----- + ELSE IF(J.EQ.19) THEN + TEXT(1)='SIGNATURE' + CALL LCMNXT(IPLISU,TEXT(1)) + IF(TEXT(1).NE.'MIXMD 1') THEN + CALL XABORT('CFCDRV: MIXMD COMPO EXPECTED.') + ENDIF + MIXP=1 + TEXT1='MIXMD' + TEXT2='MIXMD' + TEXT(2)=TEXT(1) +C----- +C COMPUTE (HIGH)FISSION ISOTOPES COEFFICIENTS (TWO L_COMPO) +C----- + ELSE IF(J.EQ.20) THEN + TEXT(1)='SIGNATURE' + CALL LCMNXT(IPLISU,TEXT(1)) + IF(TEXT(1).NE.'POWER-UP 1') THEN + CALL XABORT('CFCDRV: POWER-UP COMPO EXPECTED.') + ENDIF + IPLISD=KENTRY(J+1) + TEXT(2)='SIGNATURE' + CALL LCMNXT(IPLISD,TEXT(2)) + IF(TEXT(2).NE.'POWER-IN 1') CALL XABORT('CFCDRV:' + 1 //' POWER-D COMPO EXPECTED.') + MIXP=1 + NB=2 + TEXT1='FPCH1' + TEXT2='FPCH2' +C----- +C COMPUTE LOW FISSION ISOTOPES COEFFICIENTS (TWO L_COMPO) +C----- + ELSE IF(J.EQ.21) THEN + TEXT(1)='SIGNATURE' + CALL LCMNXT(IPLISU,TEXT(1)) + IF(TEXT(1).NE.'POWER-IN 1') THEN + CALL XABORT('CFCDRV: POWER-UP COMPO EXPECTED.') + ENDIF + IPLISD=KENTRY(J+1) + TEXT(2)='SIGNATURE' + CALL LCMNXT(IPLISD,TEXT(2)) + IF(TEXT(2).NE.'POWER-D 1') CALL XABORT('CFCDRV:' + 1 //' POWER-D COMPO EXPECTED.') + MIXP=1 + NB=2 + TEXT1='FPCL1' + TEXT2='FPCL2' + ENDIF + IF(ABS(IPRINT) .GT. 5) THEN + WRITE(IOUT,6002) TEXT1,TEXT2 + ENDIF +C + CALL CFCFBM(TEXT1,TEXT2,IPLISU,IPLISD,IPFBM,NGRP,NBUM,NISM, + 1 NBURN,NISO,HISO,NL,IPRINT,TOTAL,ZNUG,DIFFX,DIFFY,DIFFZ, + 1 H,SCAT,MIJ,MNJ,TMREF,SMREF,DMRFX,DMRFY,DMRFZ,TOT2,ZN2, + 1 DXF2, DYF2,DZF2,HF2,SCA2,WORK3,REFC,MIRCT2,MIRCS2,MICDX2, + 1 MICDY2,MICDZ2,DELTA,DENSIT,TFR,TCR,TMR,XIR,TEXT,TEXTR,NB, + 1 MIRCF2,MIRCH2,FMREF,HMREF,JTAB,MIXP,V2,EFJ,NXS,IXYZ,NBPARA, + 1 DBPARA) + 112 CONTINUE + WRITE(IOUT,9002) +C----------------------------------------------------------------------C +C C +C C +C----------------------------------------------------------------------C +C----- +C COMPUTE THE HISTORY CONCENTRATION +C----- + DO 650 JJ=1,2 + IF(JJ.EQ.1) THEN + IPHISU=KENTRY(21) + IPHISD=KENTRY(22) + TEXT(1)='SIGNATURE' + CALL LCMNXT(IPHISU,TEXT(1)) + IF(TEXT(1).NE.'POWER-IN 1') THEN + CALL XABORT('CFCDRV: POWER-IN COMPO EXPECTED.') + ENDIF + TEXT(2)='SIGNATURE' + CALL LCMNXT(IPHISD,TEXT(2)) + IF(TEXT(2).NE.'POWER-D 1') CALL XABORT('CFCDRV:' + 1 //' POWER-D COMPO EXPECTED.') + NB=2 +C TEXT1='PHIS1' +C TEXT2='PHIS2' + ELSE IF(JJ.EQ.2) THEN + IPHISU=KENTRY(20) + IPHISD=KENTRY(21) + TEXT(1)='SIGNATURE' + CALL LCMNXT(IPHISU,TEXT(1)) + IF(TEXT(1).NE.'POWER-UP 1') THEN + CALL XABORT('CFCDRV: POWER-UP COMPO EXPECTED.') + ENDIF + TEXT(2)='SIGNATURE' + CALL LCMNXT(IPHISD,TEXT(2)) + IF(TEXT(2).NE.'POWER-IN 1') CALL XABORT('CFCDRV:' + 1 //' POWER-D COMPO EXPECTED.') + NB=2 +C TEXT1='PHIL1' +C TEXT2='PHIL2' + ENDIF +C----- +C STORE THE HISTORY COEFFICIENTS +C----- + DO 730 JP=1,4 + IF(JP.EQ.1) THEN + TEXT12='FPC' + IF(JJ.EQ.1) THEN + TEXT1='PHIS1' + TEXT2='PHIS2' + ELSE + TEXT1='PHIL1' + TEXT2='PHIL2' + ENDIF + ELSE IF(JP.EQ.2) THEN + TEXT12='XE135' + IF(JJ.EQ.1) THEN + TEXT1='PHISX1' + TEXT2='PHISX2' + ELSE + TEXT1='PHILX1' + TEXT2='PHILX2' + ENDIF + ELSE IF(JP.EQ.3) THEN + TEXT12='SM149' + IF(JJ.EQ.1) THEN + TEXT1='PHISS1' + TEXT2='PHISS2' + ELSE + TEXT1='PHILS1' + TEXT2='PHILS2' + ENDIF + ELSE IF(JP.EQ.4) THEN + TEXT12='NP239' + IF(JJ.EQ.1) THEN + TEXT1='PHISN1' + TEXT2='PHISN2' + ELSE + TEXT1='PHILN1' + TEXT2='PHILN2' + ENDIF + ENDIF + DO 630 JB=1,NB + IF(JB.EQ.1) IPHIST=IPHISU + IF(JB.EQ.2) IPHIST=IPHISD + CALL LCMSIX(IPHIST,TEXT(JB),1) + CALL LCMGET(IPHIST,'ISOTOPESNAME',HISO) + DO 621 I=1,NBURN + WRITE(TEXTB,'(4HBURN,4X,I4)') I + CALL LCMSIX(IPHIST,TEXTB,1) + CALL LCMGET(IPHIST,'ISOTOPESDENS',DENSIT) + IF(DENSIT(1).NE.1.0) CALL XABORT('FBM: DENSIT(1).NE.1.') + DO 649 ISO=2,NISO + WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+IH),IH=1,3) + IF(HMICRO.EQ.TEXT12) DELTA(I,JB)=DENSIT(ISO)- REFC(I,ISO) + 649 CONTINUE + CALL LCMSIX(IPHIST,' ',2) + 621 CONTINUE + CALL LCMSIX(IPHIST,' ',2) + 630 CONTINUE + DO 622 I=1,NBURN + IF(NB.EQ.2) THEN + PV1U=0.0 + PV2U=0.0 + PV1D=0.0 + PV2D=0.0 + IF(JJ.EQ.1) THEN + PV1U=PWU-PWR + PV2U=PV1U*PV1U + PV1D=PWD-PWR + PV2D=PV1D*PV1D + ELSE IF(JJ.EQ.2) THEN + PV1U=ALOG(PWUL/PWR) + PV2U=1.0/PWUL - 1.0/PWR + PV1D=ALOG(PWDL/PWR) + PV2D=1.0/PWDL - 1.0/PWR + ENDIF + TX=PV2U*PV1D - PV2D*PV1U + DELTA(I,2)=(DELTA(I,1)*PV1D-DELTA(I,2)*PV1U)/TX + DELTA(I,1)=(DELTA(I,1) - DELTA(I,2)*PV2U)/PV1U +C + ENDIF +C + CALL LCMSIX(IPFBM,TEXTR,1) + WRITE(TEXTB,'(4HBURN,4X,I4)') I + CALL LCMSIX(IPFBM,TEXTB,1) + CALL LCMSIX(IPFBM,'HISTORY',1) + CALL LCMPUT(IPFBM,TEXT1,1,2,DELTA(I,1)) + IF(NB.EQ.2) THEN + CALL LCMPUT(IPFBM,TEXT2,1,2,DELTA(I,2)) + ENDIF + CALL LCMSIX(IPFBM,' ',2) + CALL LCMSIX(IPFBM,' ',2) + CALL LCMSIX(IPFBM,' ',2) + 622 CONTINUE + 730 CONTINUE + 650 CONTINUE + WRITE(IOUT,9003) + ELSE +C----------------------------------------------------------------------C +C C +C MODERATOR CALCULATIONS C +C C +C----------------------------------------------------------------------C + DO 811 J=1,4 + NB=2 + MIXP=0 +C----- +C COMPUTE MODERATOR TEMPERATURE COEFFICIENTS +C----- + IF(J.EQ.1) THEN + IPLISU=KENTRY(24) + IPLISD=KENTRY(25) + TEXT(1)='SIGNATURE' + CALL LCMNXT(IPLISU,TEXT(1)) + IF(TEXT(1).NE.'MODTP-UP 1') THEN + CALL XABORT('CFCDRV: MTEMP-UP COMPO EXPECTED.') + ENDIF + TEXT(2)='SIGNATURE' + CALL LCMNXT(IPLISD,TEXT(2)) + IF(TEXT(2).NE.'MODTP-D 1') CALL XABORT('CFCDRV:' + 1 //' MTEMP-D COMPO EXPECTED.') + TEXT1='T1M' + TEXT2='T2M' +C----- +C COMPUTE MODERATOR DENSITY COEFFICIENTS +C----- + ELSE IF(J.EQ.2) THEN + IPLISU=KENTRY(26) + IPLISD=KENTRY(27) + TEXT(1)='SIGNATURE' + CALL LCMNXT(IPLISU,TEXT(1)) + IF(TEXT(1).NE.'MODDEN-U 1') THEN + CALL XABORT('CFCDRV: MDEN-UP COMPO EXPECTED.') + ENDIF + TEXT(2)='SIGNATURE' + CALL LCMNXT(IPLISD,TEXT(2)) + IF(TEXT(2).NE.'MODDEN-D 1') CALL XABORT('CFCDRV:' + 1 //' MDEN-D COMPO EXPECTED.') + TEXT1='D1M' + TEXT2='D2M' +C----- +C COMPUTE BORON COEFFICIENTS +C----- + ELSE IF(J.EQ.3) THEN + NB=1 + MIXP=0 + IPLISU=KENTRY(28) + TEXT(1)='SIGNATURE' + CALL LCMNXT(IPLISU,TEXT(1)) + IF(TEXT(1).NE.'MODBOR 1') THEN + CALL XABORT('CFCDRV: BORON COMPO EXPECTED.') + ENDIF + TEXT1='BOR' + TEXT2='BOR' + TEXT(2)=TEXT(1) +C----- +C COMPUTE PURITY COEFFICIENTS +C----- + ELSE IF(J.EQ.4) THEN + NB=1 + MIXP=0 + IPLISU=KENTRY(29) + TEXT(1)='SIGNATURE' + CALL LCMNXT(IPLISU,TEXT(1)) + IF(TEXT(1).NE.'MODPUR 1') THEN + CALL XABORT('CFCDRV: BORON COMPO EXPECTED.') + ENDIF + TEXT1='PUR' + TEXT2='PUR' + TEXT(2)=TEXT(1) + ENDIF +C + CALL CFCFBM(TEXT1,TEXT2,IPLISU,IPLISD,IPFBM,NGRP,NBUM,NISM, + 1 NBURN,NISO,HISO,NL,IPRINT,TOTAL,ZNUG,DIFFX,DIFFY,DIFFZ, + 1 H,SCAT,MIJ,MNJ,TMREF,SMREF,DMRFX,DMRFY,DMRFZ,TOT2,ZN2, + 1 DXF2, DYF2,DZF2,HF2,SCA2,WORK3,REFC,MIRCT2,MIRCS2,MICDX2, + 1 MICDY2,MICDZ2,DELTA,DENSIT,TFR,TCR,TMR,XIR,TEXT,TEXTR,NB, + 1 MIRCF2,MIRCH2,FMREF,HMREF,JTAB,MIXP,V2,EFJ,NXS,IXYZ,NBPARA, + 1 DBPARA) +C + 811 CONTINUE + WRITE(IOUT,9004) + ENDIF +C----- +C STORE PARAM INFORMATION +C----- + CALL LCMSIX(IPFBM,TEXTR,1) + IPAR(1)=NGRP + IPAR(2)=NISO + IPAR(3)=NL + IPAR(4)=NBURN + IPAR(5)=IXYZ + CALL LCMPUT(IPFBM,'PARAM',5,1,IPAR) + CALL LCMSIX(IPFBM,' ',2) + 801 CONTINUE +C----------------------------------------------------------------------C +C RELEASE MEMORY C +C----------------------------------------------------------------------C + DEALLOCATE(MIRCH2,MIRCF2,V2,MICDZ2,MICDY2,MICDX2,MIRCS2, + > MIRCT2,SCA2,HF2,DZF2,DYF2,DXF2,ZN2,TOT2) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(DELTA,HMREF,FMREF,REFC,DMRFZ,DMRFY,DMRFX,SMREF,TMREF, + > EFJ,DENSIT,WORK3,SCAT,H,DIFFZ,DIFFY,DIFFX,ZNUG,TOTAL) + DEALLOCATE(IXS,JTAB,HISO,MNJ,MIJ,NJJ,IJJ) +* + RETURN + 6000 FORMAT(' CPO ',I4,' for up parameter named = ',A12/ + > ' CPO ',I4,' for down parameter named = ',A12) + 6001 FORMAT(' CPO ',I4,' with name ',A12) + 6002 FORMAT(' Records ',2(A8,4X)) + 9000 FORMAT(' CELL REFERENCE (NOMINAL) PARAMETER ARE STORED') + 9001 FORMAT(' CELL FEEDBACK COEFFICIENTS CORRESPONDING TO:'/ + > ' FUEL TEMPERATURE,'/ + > ' COOLANT TEMPERATURE,'/ + > ' MODERATOR TEMPERATURE,'/ + > ' COOLANT DENSITY ,'/ + > ' MODERATOR DENSITY ,') + 9002 FORMAT(' CELL FEEDBACK COEFFICIENTS CORRESPONDING TO:'/ + > ' BORON CONCENTRATION,'/ + > ' MODERATOR PURITY ,'/ + > ' XENON CONCENTRATION,'/ + > ' SAMARIUM CONCENTRATION,'/ + > ' NEPTUNIUM CONCENTRATION,'/ + > ' ************************,'/ + > ' MIXED FUEL TEMPERATURE AND COOLANT DENSITY,'/ + > ' MIXED COOLANT TEMPERATURE AND COOLANT DENSITY,'/ + > ' *********************************************,'/ + > ' THE POWER HISTORY,'/) + 9003 FORMAT(' POWER HISTORY COEFFICIENTS FOR THE CONCENTRATION '/ + > ' ARE STORED') + 9004 FORMAT(' REFLECTOR FEEDBACK COEFFICIENTS CORRESPONDING TO:'/ + > ' MODERATOR TEMPERATURE ,'/ + > ' MODERATOR DENSITY ,'/ + > ' BORON CONCENTRATION,'/ + > ' MODERATOR PURITY ,'/) + END diff --git a/Dragon/src/CFCFBM.f b/Dragon/src/CFCFBM.f new file mode 100644 index 0000000..f1fed9c --- /dev/null +++ b/Dragon/src/CFCFBM.f @@ -0,0 +1,1227 @@ +*DECK CFCFBM + SUBROUTINE CFCFBM (TEXT1,TEXT2,IPLISU,IPLISD,IPFBM,NGRP,NBUM,NISM, + 1 NBURN,NISO,HISO,NL,IPRINT,TOTAL,ZNUG,DIFFX,DIFFY,DIFFZ,H,SCAT, + 1 MIJ,MNJ,TMREF,SMREF,DMREFX,DMREFY,DMREFZ,TOTAF,ZNUF,DXF,DYF,DZF, + 1 HF,SCATF,WORK3,REFC,TMICR,SMICR,DMICRX,DMICRY,DMICRZ,DELTA, + 1 DENSIT,TFR,TCR,TMR,XIR,TEXT,TEXTR,NB,FMICR,HMICR,FMREF,HMREF, + 1 JTAB,MIXP,V,EFJ,NXS,IXYZ,NBPARA,DBPARA) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute and store FBM coefficients. +* +*Copyright: +* Copyright (C) 1996 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): M. T. Sissaoui +* +*Parameters: input +* IPLISU address of the Compo object. +* IPLISD address of the Compo object. +* IPFBM address of the feedback data dase. +* NISO 1+number of extracted isotopes. +* TEXT1 name of the first feedback coefficient. +* TEXT2 name of the second feedback coefficient. +* TEXTR name of the record. +* TFR reference fuel temperature. +* TCR reference coolant temperature. +* TMR reference moderator temperature. +* NGRP number of energy groups. +* NBUM number of materials. +* NISM number of isotopes in materials. +* NBURN number of burnup steps. +* NB number of feedback coefficient per parameter. +* NL number of Legendre orders (=1 for isotropic scattering). +* IPRINT print parameter. Equal to zero for no print. +* HISO Hollerith name information for extracted isotopes. +* DENSIT number densities. +* REFC reference number densities of the parameter. +* TOTAL reference total macroscopic x-sections. +* ZNUG reference nu * fission macroscopic x-sections. +* DIFFX reference X-directed diffusion coefficients. +* DIFFY reference Y-directed diffusion coefficients. +* DIFFZ reference Z-directed diffusion coefficients. +* H reference H-FACTORS (kappa * fission mac. x-sect.). +* SCAT reference scattering macroscopic x-sections. +* MIJ I pointer to decompress scattering matrix. +* MNJ N pointer to decompress scattering matrix. +* TMREF reference total microscopic x-sections. +* DMREFX reference mic. X-directed diffusion coefficients. +* DMREFY reference mic. Y-directed diffusion coefficients. +* DMREFZ reference mic. Z-directed diffusion coefficients. +* SMREF reference scattering microscopic x-sections. +* FMREF reference nu * fission microscopic x-sections. +* HMREF reference microscopic H-FACTORS. +* TOTAF feedback total macroscopic x-sections. +* ZNUF feedback nu * fission macroscopic x-sections. +* DXF feedback X-directed diffusion coefficients. +* DYF feedback Y-directed diffusion coefficients. +* DZF feedback Z-directed diffusion coefficients. +* HF feedback H-FACTORS (kappa * fission mac. x-sect.). +* SCATF feedback scattering macroscopic x-sections. +* TMICR feedback total microscopic x-sections. +* DMICRX feedback microscipic X-directed diffusion coefficients. +* DMICRY feedback microscipic Y-directed diffusion coefficients. +* DMICRZ feedback microscipic Z-directed diffusion coefficients. +* SMICR feedback scattering microscopic x-sections. +* NBPARA Number of parameters for FBM. +* DBPARA Values of parameters for FBM. +* +*Parameters: scratch +* WORK3 undefined. +* DELTA undefined. +* XIR undefined. +* TEXT undefined. +* FMICR undefined. +* HMICR undefined. +* JTAB undefined. +* MIXP undefined. +* V undefined. +* EFJ undefined. +* NXS undefined. +* IXYZ undefined. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER TEXT1*8,TEXT2*8,TEXT(2)*12,TEXTR*12 + TYPE(C_PTR) IPLISU,IPLISD,IPFBM + INTEGER NGRP,NBUM,NISM,NBURN,NISO,HISO(3*NISO),NL,IPRINT, + 1 MIJ(NGRP),MNJ(NGRP),NB,JTAB(NISO),MIXP,NXS,IXYZ,NBPARA + REAL TOTAL(NGRP,NBURN),ZNUG(NGRP,NBURN),DIFFX(NGRP,NBURN), + 1 DIFFY(NGRP,NBURN),DIFFZ(NGRP,NBURN),H(NGRP,NBURN), + 2 SCAT(NBURN,NL,NGRP,NGRP),TMREF(NGRP,NBUM,NISO), + 3 SMREF(NISM,NBUM,NL,NGRP,NGRP),DMREFX(NGRP,NBUM,NISO), + 4 DMREFY(NGRP,NBUM,NISO),DMREFZ(NGRP,NBUM,NISO), + 5 TOTAF(NGRP,NBUM,NB),ZNUF(NGRP,NBUM,NB),DXF(NGRP,NBUM,NB), + 6 DYF(NGRP,NBUM,NB),DZF(NGRP,NBUM,NB),HF(NGRP,NBUM,NB), + 7 SCATF(NB,NBUM,NL,NGRP,NGRP),WORK3(NGRP*NGRP),REFC(NBUM,NISO), + 8 TMICR(NGRP,NISM,NBUM,NB),SMICR(NB,NISM,NBUM,NL,NGRP,NGRP), + 9 DMICRX(NGRP,NISM,NBUM,NB),DMICRY(NGRP,NISM,NBUM,NB), + 1 DMICRZ(NGRP,NISM,NBUM,NB),DELTA(NBUM,2),DENSIT(NISO), + 2 TFR,TCR,TMR,XIR,FMICR(NGRP,NISM,NBUM,NB), + 3 HMICR(NGRP,NISM,NBUM,NB),FMREF(NGRP,NBUM,NISO), + 4 HMREF(NGRP,NBUM,NISO),V(NBUM,8,NB),EFJ(NISO),DBPARA(NBPARA) +*---- +* LOCAL PARAMETERS +*---- + TYPE(C_PTR) IPLIST + INTEGER IOUT + PARAMETER (IOUT=6) + CHARACTER HMICRO*12,CM*2,TEXTB*12,TMIX(8)*8,HSMG*131 + LOGICAL LOGI,LOHIS + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IXS + SAVE TMIX +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IJJ(NGRP),NJJ(NGRP),IXS(NXS)) +C----- +C PARAMETER VALUES ( TEMPERETURES, POWER AND PURITY ) +C----- + TFU=DBPARA(8) + TCU=DBPARA(9) + TMU=DBPARA(15) + TFD=DBPARA(16) + TCD=DBPARA(17) + TMD=DBPARA(18) + PWU=DBPARA(10) + PWD=DBPARA(13) + XI=DBPARA(14) +C----- +C SET ALL THE VARIABLES TO ZERO +C----- +C +C REAL VARIABLE +C + DEL=0.0 + PV1U=0.0 + PV2U=0.0 + PV2UB=0.0 + PV1D=0.0 + PV2D=0.0 + PV2DB=0.0 +C + DO 10 III=1,8 + TMIX(III)=' ' + 10 CONTINUE + V(:NBUM,:8,:NB)=0.0 + DELTA(:NBUM,:2)=0.0 + TOTAF(:NGRP,:NBUM,:NB)=0.0 + ZNUF(:NGRP,:NBUM,:NB)=0.0 + HF(:NGRP,:NBUM,:NB)=0.0 + DXF(:NGRP,:NBUM,:NB)=0.0 + DYF(:NGRP,:NBUM,:NB)=0.0 + DZF(:NGRP,:NBUM,:NB)=0.0 + TMICR(:NGRP,:NISO,:NBUM,:NB)=0.0 + FMICR(:NGRP,:NISO,:NBUM,:NB)=0.0 + HMICR(:NGRP,:NISO,:NBUM,:NB)=0.0 + DMICRX(:NGRP,:NISO,:NBUM,:NB)=0.0 + DMICRY(:NGRP,:NISO,:NBUM,:NB)=0.0 + DMICRZ(:NGRP,:NISO,:NBUM,:NB)=0.0 + SCATF(:NB,:NBUM,:NL,:NGRP,:NGRP)=0.0 + SMICR(:NB,:NISO,:NBUM,:NL,:NGRP,:NGRP)=0.0 +C + DO 20 IGR=1,NGRP + IJJ(IGR)=IGR + NJJ(IGR)=1 + 20 CONTINUE +C +C LOGICAL VARIABLE +C + LOHIS=.FALSE. +C +C INITIAL UNIT NUMBER +C + IPLIST=IPLISU +C----------------------------------------------------------------------C +C----- +C RECOVER NEUTRONICS PARAMETRES +C----- + DO 180 J=1,NB + IF(J.EQ.2) IPLIST=IPLISD + CALL LCMSIX(IPLIST,TEXT(J),1) + CALL LCMGET(IPLIST,'ISOTOPESNAME',HISO) +C + I=1 + WRITE(TEXTB,'(4HBURN,4X,I4)') I + CALL LCMSIX(IPLIST,TEXTB,1) + IXYZF=0 + DO 30 ISO=1,NISO + WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+IH),IH=1,3) + CALL LCMSIX(IPLIST,HMICRO,1) + CALL LCMGET(IPLIST,'XS-SAVED',IXS) + CALL LCMGET(IPLIST,'SCAT-SAVED',IXS(21)) + IF(IXS(18).EQ.1) IXYZF=1 + CALL LCMSIX(IPLIST,' ',2) + 30 CONTINUE + IF(IXYZF.NE.IXYZ) THEN + WRITE(HSMG, + > '(15HXS_SAVED(18) = ,I5,17HREF XS_SAVED(18)=,I5)') + > IXS(18),IXYZ + CALL XABORT('CFCFBM: INCONSISTENT NB OF FLAGS ' + 1 //TEXT(J)//' IS '//HSMG//' ') + ENDIF + CALL LCMSIX(IPLIST,' ',2) +C + DO 170 I=1,NBURN + WRITE(TEXTB,'(4HBURN,4X,I4)') I + CALL LCMSIX(IPLIST,TEXTB,1) + CALL LCMGET(IPLIST,'ISOTOPESDENS',DENSIT) + CALL LCMGET(IPLIST,'ISOTOPES-EFJ',EFJ) + IF(DENSIT(1).NE.1.0) CALL XABORT('CFCFBM: DENSIT(1).NE.1.') +C +C RECOVER FEEDBACK MACROSCOPIC X-SECTIONS. +C + CALL LCMSIX(IPLIST,'MACR',1) + CALL LCMGET(IPLIST,'XS-SAVED',IXS) + CALL LCMGET(IPLIST,'SCAT-SAVED',IXS(21)) + IF(IXS(1).EQ.1) CALL LCMGET(IPLIST,'TOTAL',TOTAF(1,I,J)) + IF(IXS(3).EQ.1) CALL LCMGET(IPLIST,'NUSIGF',ZNUF(1,I,J)) + IF(IXS(4).EQ.1) THEN + CALL LCMGET(IPLIST,'NFTOT',HF(1,I,J)) + DO 40 IGR=1,NGRP + HF(IGR,I,J)=HF(IGR,I,J)*EFJ(1) + 40 CONTINUE + ENDIF + IL=1 + WRITE (CM,'(I2.2)') IL-1 + IF(IXS(20+IL).EQ.1) THEN + CALL LCMGET(IPLIST,'SIGS'//CM,WORK3) + DO 50 IGR=1,NGRP + TOTAF(IGR,I,J)= TOTAF(IGR,I,J)-WORK3(IGR) + 50 CONTINUE + ENDIF +C + IF(IXS(17).EQ.1) CALL LCMGET(IPLIST,'STRD ',DXF(1,I,J)) + IF(IXS(18).EQ.1) CALL LCMGET(IPLIST,'STRD X',DXF(1,I,J)) + IF(IXS(19).EQ.1) CALL LCMGET(IPLIST,'STRD Y',DYF(1,I,J)) + IF(IXS(20).EQ.1) CALL LCMGET(IPLIST,'STRD Z',DZF(1,I,J)) +C + CALL LCMSIX(IPLIST,' ',2) +C +C RECOVER FEEDBACK DENSITIES. +C + DO 100 ISO=2,NISO + WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+IH),IH=1,3) + IF(HMICRO.EQ.'BMOD') THEN + IF(TEXT1.EQ.'BOR') THEN + DELTA(I,1)=DENSIT(ISO)- REFC(I,ISO) + DELTA(I,2)=0.0 + ENDIF + ELSE IF(HMICRO.EQ.'XE135') THEN + IF(TEXT1.EQ.'XEN') THEN + DELTA(I,1)=DENSIT(ISO)- REFC(I,ISO) + DELTA(I,2)=0.0 + IF(I.EQ.1) DELTA(I,1)=0.0 + ELSE IF(TEXT1.EQ.'FPCH1'.OR.TEXT1.EQ.'FPCL1') THEN + V(I,1,J)=DENSIT(ISO)- REFC(I,ISO) + TMIX(1)='XEN' + ENDIF + ELSE IF(HMICRO.EQ.'SM149') THEN + IF(TEXT1.EQ.'SM149') THEN + DELTA(I,1)=DENSIT(ISO)- REFC(I,ISO) + DELTA(I,2)=0.0 + IF(I.EQ.1) DELTA(I,1)=0.0 + ELSE IF(TEXT1.EQ.'FPCH1'.OR.TEXT1.EQ.'FPCL1') THEN + V(I,2,J)=DENSIT(ISO)- REFC(I,ISO) + TMIX(2)='SM149' + ENDIF + ELSE IF(HMICRO.EQ.'NP239') THEN + IF(TEXT1.EQ.'NP239') THEN + DELTA(I,1)=DENSIT(ISO)- REFC(I,ISO) + DELTA(I,2)=0.0 + IF(I.EQ.1) DELTA(I,1)=0.0 + ELSE IF(TEXT1.EQ.'FPCH1'.OR.TEXT1.EQ.'FPCL1') THEN + V(I,3,J)=DENSIT(ISO)- REFC(I,ISO) + TMIX(3)='NP239' + ENDIF + ELSE IF(HMICRO.EQ.'FPC') THEN + IF(TEXT1.EQ.'FPCH1'.OR.TEXT1.EQ.'FPCL1') THEN + DELTA(I,J)=DENSIT(ISO)- REFC(I,ISO) + ENDIF + ELSE IF(HMICRO.EQ.'CWAT') THEN + IF(TEXT1.EQ.'D1C') THEN + IF(J.EQ.1) THEN + PV1U=DENSIT(ISO)- REFC(I,ISO) + PV2U=PV1U*PV1U + PV2UB=PV1U*PV1U + DELTA(I,J)=PV1U + ELSE + PV1D=DENSIT(ISO)- REFC(I,ISO) + PV2D=PV1D*PV1D + PV2DB=PV1D*PV1D + DELTA(I,J)=PV1D + ENDIF + ENDIF + IF(TEXT1.EQ.'MIXFD'.OR.TEXT1.EQ.'MIXMD') THEN + DELTA(I,1)=DENSIT(ISO)- REFC(I,ISO) + DELTA(I,2)=0.0 + V(I,1,J)=DENSIT(ISO)- REFC(I,ISO) + V(I,2,J)=V(I,1,J)*V(I,1,J) + TMIX(1)='D1C' + TMIX(2)='D2C' + ENDIF + ELSE IF(HMICRO.EQ.'MWAT') THEN + IF(TEXT1.EQ.'D1M') THEN + IF(J.EQ.1) THEN + PV1U=ALOG(DENSIT(ISO)/REFC(I,ISO)) + PV2U=1.0/DENSIT(ISO) - 1.0/REFC(I,ISO) + PV2UB=DENSIT(ISO)- REFC(I,ISO) + DELTA(I,J)=PV2UB + ELSE + PV1D=ALOG(DENSIT(ISO)/REFC(I,ISO)) + PV2D=1.0/DENSIT(ISO) - 1.0/REFC(I,ISO) + PV2DB=DENSIT(ISO)- REFC(I,ISO) + DELTA(I,J)=PV2DB + ENDIF + ELSE IF(TEXT1.EQ.'PUR') THEN + DELTA(I,1)=(XI-XIR)*REFC(I,ISO) + DELTA(I,2)=0.0 + ENDIF + ENDIF +C +C RECOVER FEEDBACK MICROSCOPIC X-SECTIONS. +C + CALL LCMSIX(IPLIST,HMICRO,1) + CALL LCMGET(IPLIST,'XS-SAVED',IXS) + CALL LCMGET(IPLIST,'SCAT-SAVED',IXS(21)) + IF(IXS(1).EQ.1) CALL LCMGET(IPLIST,'TOTAL',TMICR(1,ISO,I,J)) + IF(IXS(3).EQ.1) CALL LCMGET(IPLIST,'NUSIGF',FMICR(1,ISO,I,J)) + IF(IXS(4).EQ.1) THEN + CALL LCMGET(IPLIST,'NFTOT',HMICR(1,ISO,I,J)) + DO 60 IGR=1,NGRP + HMICR(IGR,ISO,I,J)=HMICR(IGR,ISO,I,J)*EFJ(ISO) + 60 CONTINUE + ENDIF + IL=1 + WRITE (CM,'(I2.2)') IL-1 + IF(IXS(20+IL).EQ.1) THEN + CALL LCMGET(IPLIST,'SIGS'//CM,WORK3) + DO 70 IGR=1,NGRP + TMICR(IGR,ISO,I,J)= TMICR(IGR,ISO,I,J)-WORK3(IGR) + 70 CONTINUE + ENDIF +C + IF(IXS(17).EQ.1) CALL LCMGET(IPLIST,'STRD ',DMICRX(1,ISO,I,J)) + IF(IXS(18).EQ.1) CALL LCMGET(IPLIST,'STRD X',DMICRX(1,ISO,I,J)) + IF(IXS(19).EQ.1) CALL LCMGET(IPLIST,'STRD Y',DMICRY(1,ISO,I,J)) + IF(IXS(20).EQ.1) CALL LCMGET(IPLIST,'STRD Z',DMICRZ(1,ISO,I,J)) +C +C ADD THE CONTRIBUTION OF MIC. X-SECT. IN MAC. X-S +C + DO 80 IGR=1,NGRP + TOTAF(IGR,I,J)=TOTAF(IGR,I,J)+DENSIT(ISO)*TMICR(IGR,ISO,I,J) + DXF(IGR,I,J) =DXF(IGR,I,J) +DENSIT(ISO)*DMICRX(IGR,ISO,I,J) + DYF(IGR,I,J) =DYF(IGR,I,J) +DENSIT(ISO)*DMICRY(IGR,ISO,I,J) + DZF(IGR,I,J) =DZF(IGR,I,J) +DENSIT(ISO)*DMICRZ(IGR,ISO,I,J) + 80 CONTINUE + IF(JTAB(ISO).EQ.1) THEN + DO 90 IGR=1,NGRP + ZNUF(IGR,I,J)=ZNUF(IGR,I,J)+DENSIT(ISO)*FMICR(IGR,ISO,I,J) + HF(IGR,I,J) =HF(IGR,I,J) +DENSIT(ISO)*HMICR(IGR,ISO,I,J) + 90 CONTINUE + ENDIF + CALL LCMSIX(IPLIST,' ',2) + 100 CONTINUE +C +C RECOVER MACROSCOPIC SCATTERING X-SECTIONS. +C + CALL LCMSIX(IPLIST,'MACR',1) + CALL LCMGET(IPLIST,'XS-SAVED',IXS) + CALL LCMGET(IPLIST,'SCAT-SAVED',IXS(21)) + IL=1 + WRITE (CM,'(I2.2)') IL-1 + IF(IXS(20+IL).EQ.1) THEN + CALL LCMGET(IPLIST,'SCAT'//CM,WORK3) + CALL LCMGET(IPLIST,'NJJS'//CM,NJJ) + CALL LCMGET(IPLIST,'IJJS'//CM,IJJ) + IGAR=0 + DO 120 JGR=1,NGRP + DO 110 IGR=IJJ(JGR),IJJ(JGR)-NJJ(JGR)+1,-1 + IGAR=IGAR+1 + SCATF(J,I,IL,IGR,JGR)=WORK3(IGAR) + 110 CONTINUE + 120 CONTINUE + ENDIF +C + CALL LCMSIX(IPLIST,' ',2) +C +C RECOVER MICROSCOPIC CONTRIBUTIONS OF SCATTERING X-SECTIONS. +C + DO 160 ISO=2,NISO + WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+IH),IH=1,3) + CALL LCMSIX(IPLIST,HMICRO,1) + CALL LCMGET(IPLIST,'XS-SAVED',IXS) + CALL LCMGET(IPLIST,'SCAT-SAVED',IXS(21)) + IL=1 + WRITE (CM,'(I2.2)') IL-1 + IF(IXS(20+IL).EQ.1) THEN + CALL LCMGET(IPLIST,'SCAT'//CM,WORK3) + CALL LCMGET(IPLIST,'NJJS'//CM,NJJ) + CALL LCMGET(IPLIST,'IJJS'//CM,IJJ) + IGAR=0 + DO 140 JGR=1,NGRP + DO 130 IGR=IJJ(JGR),IJJ(JGR)-NJJ(JGR)+1,-1 + IGAR=IGAR+1 + SMICR(J,ISO,I,IL,IGR,JGR)=WORK3(IGAR) + SCATF(J,I,IL,IGR,JGR)=SCATF(J,I,IL,IGR,JGR)+ + 1 DENSIT(ISO)*WORK3(IGAR) + 130 CONTINUE + 140 CONTINUE + ENDIF + CALL LCMSIX(IPLIST,' ',2) + 160 CONTINUE +C GOING UP FOR BURN + CALL LCMSIX(IPLIST,' ',2) + 170 CONTINUE + CALL LCMSIX(IPLIST,' ',2) + 180 CONTINUE +C----------------------------------------------------------------------C +C C +C BEGIN THE COEFFICIENTS CALCULATION C +C C +C----------------------------------------------------------------------C + DT=0.0 + IF(TEXT1.EQ.'T1F') THEN + PV1U=SQRT(TFU)-SQRT(TFR) + PV2U=TFU-TFR + PV2UB=PV2U + PV1D=SQRT(TFD)-SQRT(TFR) + PV2D=TFD-TFR + PV2DB=PV2D + ELSE IF(TEXT1.EQ.'T1C') THEN + PV1U=ALOG(TCU/TCR) + PV2U=1.0/TCU - 1.0/TCR + PV2UB=PV2U + PV1D=ALOG(TCD/TCR) + PV2D=1.0/TCD - 1.0/TCR + PV2DB=PV2D + ELSE IF(TEXT1.EQ.'T1M') THEN + PV1U=ALOG(TMU/TMR) + PV2U=1.0/TMU - 1.0/TMR + PV2UB=PV2U + PV1D=ALOG(TMD/TMR) + PV2D=1.0/TMD - 1.0/TMR + PV2DB=PV2D + ELSE IF(TEXT1.EQ.'MIXMD') THEN + DT=ALOG(TCU/TCR) + DO 190 I=1,NBURN + V(I,3,1)=ALOG(TCU/TCR) + V(I,4,1)=1.0/TCU - 1.0/TCR + 190 CONTINUE + TMIX(1)='D1C' + TMIX(2)='D2C' + TMIX(3)='T1C' + TMIX(4)='T2C' + ELSE IF(TEXT1.EQ.'MIXFD') THEN + DT=SQRT(TFU)-SQRT(TFR) + DO 200 I=1,NBURN + V(I,3,1)=SQRT(TFU)-SQRT(TFR) + V(I,4,1)=TFU-TFR + 200 CONTINUE + TMIX(1)='D1C' + TMIX(2)='D2C' + TMIX(3)='T1F' + TMIX(4)='T2F' + ENDIF +C +C----------------------------------------------------------------------C +C +C COMPUTE DELTA SIGMA +C + DO 290 I=1,NBURN + DO 280 J=1,NB + DO 240 IGR=1,NGRP + TOTAF(IGR,I,J)=TOTAF(IGR,I,J)-TOTAL(IGR,I) + DXF(IGR,I,J)=DXF(IGR,I,J)-DIFFX(IGR,I) + DYF(IGR,I,J)=DYF(IGR,I,J)-DIFFY(IGR,I) + DZF(IGR,I,J)=DZF(IGR,I,J)-DIFFZ(IGR,I) + ZNUF(IGR,I,J)=ZNUF(IGR,I,J)-ZNUG(IGR,I) + HF(IGR,I,J)=HF(IGR,I,J)-H(IGR,I) + DO 210 ISO=2,NISO + TMICR(IGR,ISO,I,J) =TMICR(IGR,ISO,I,J) - TMREF(IGR,I,ISO) + DMICRX(IGR,ISO,I,J)=DMICRX(IGR,ISO,I,J)- DMREFX(IGR,I,ISO) + DMICRY(IGR,ISO,I,J)=DMICRY(IGR,ISO,I,J)- DMREFY(IGR,I,ISO) + DMICRZ(IGR,ISO,I,J)=DMICRZ(IGR,ISO,I,J)- DMREFZ(IGR,I,ISO) + IF(JTAB(ISO).EQ.1) THEN + FMICR(IGR,ISO,I,J)=FMICR(IGR,ISO,I,J)- FMREF(IGR,I,ISO) + HMICR(IGR,ISO,I,J)=HMICR(IGR,ISO,I,J)- HMREF(IGR,I,ISO) + ENDIF + 210 CONTINUE + IL=1 + DO 230 JGR=1,NGRP + SCATF(J,I,IL,IGR,JGR)=SCATF(J,I,IL,IGR,JGR)- + 1 SCAT(I,IL,IGR,JGR) + DO 220 ISO=2,NISO + SMICR(J,ISO,I,IL,IGR,JGR)=SMICR(J,ISO,I,IL,IGR,JGR)- + 1 SMREF(ISO,I,IL,IGR,JGR) + 220 CONTINUE + 230 CONTINUE + 240 CONTINUE +C +C CORRECTION OF MACRO. X-SECTIONS +C + LOGI=.FALSE. + DO 270 ISO=2,NISO + WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+IH),IH=1,3) + IF(HMICRO.EQ.'BMOD'.AND.TEXT1.EQ.'BOR') THEN + LOGI =.TRUE. + DELC=DELTA(I,J) + ELSE IF(HMICRO.EQ.'XE135'.AND.TEXT1.EQ.'XEN') THEN + LOGI =.TRUE. + DELC=DELTA(I,J) + ELSE IF(HMICRO.EQ.'SM149'.AND.TEXT1.EQ.'SM149') THEN + LOGI =.TRUE. + DELC=DELTA(I,J) + ELSE IF(HMICRO.EQ.'NP239'.AND.TEXT1.EQ.'NP239') THEN + LOGI =.TRUE. + DELC=DELTA(I,J) + ELSE IF(HMICRO.EQ.'CWAT'.AND.TEXT1.EQ.'D1C') THEN + LOGI =.TRUE. + DELC=DELTA(I,J) + ELSE IF(HMICRO.EQ.'MWAT'.AND.TEXT1.EQ.'D1M') THEN + LOGI =.TRUE. + DELC=DELTA(I,J) + ELSE IF(HMICRO.EQ.'CWAT'.AND.TEXT1.EQ.'MIXFD') THEN + LOGI =.TRUE. + DELC=DELTA(I,J) + ELSE IF(HMICRO.EQ.'CWAT'.AND.TEXT1.EQ.'MIXMD') THEN + LOGI =.TRUE. + DELC=DELTA(I,J) + ELSE IF(HMICRO.EQ.'XE135'.AND.TEXT1.EQ.'FPCH1') THEN + LOGI =.TRUE. + DELC=V(I,1,J) + ELSE IF(HMICRO.EQ.'XE135'.AND.TEXT1.EQ.'FPCL1') THEN + LOGI =.TRUE. + DELC=V(I,1,J) + ELSE IF(HMICRO.EQ.'SM149'.AND.TEXT1.EQ.'FPCH1') THEN + LOGI =.TRUE. + DELC=V(I,2,J) + ELSE IF(HMICRO.EQ.'SM149'.AND.TEXT1.EQ.'FPCL1') THEN + LOGI =.TRUE. + DELC=V(I,2,J) + ELSE IF(HMICRO.EQ.'NP239'.AND.TEXT1.EQ.'FPCH1') THEN + LOGI =.TRUE. + DELC=V(I,3,J) + ELSE IF(HMICRO.EQ.'NP239'.AND.TEXT1.EQ.'FPCL1') THEN + LOGI =.TRUE. + DELC=V(I,3,J) + ELSE IF(HMICRO.EQ.'FPC'.AND.TEXT1.EQ.'FPCH1') THEN + LOGI =.TRUE. + DELC=DELTA(I,J) + ELSE IF(HMICRO.EQ.'FPC'.AND.TEXT1.EQ.'FPCL1') THEN + LOGI =.TRUE. + DELC=DELTA(I,J) + ENDIF +C + IF(LOGI) THEN + DO 260 IGR=1,NGRP + TOTAF(IGR,I,J)=TOTAF(IGR,I,J)-TMICR(IGR,ISO,I,J)*DELC + DXF(IGR,I,J)=DXF(IGR,I,J)-DMICRX(IGR,ISO,I,J)*DELC + DYF(IGR,I,J)=DYF(IGR,I,J)-DMICRY(IGR,ISO,I,J)*DELC + DZF(IGR,I,J)=DZF(IGR,I,J)-DMICRZ(IGR,ISO,I,J)*DELC + IF(JTAB(ISO).EQ.1) THEN + ZNUF(IGR,I,J)= ZNUF(IGR,I,J)-FMICR(IGR,ISO,I,J)*DELC + HF(IGR,I,J)=HF(IGR,I,J)-HMICR(IGR,ISO,I,J)*DELC + ENDIF + IL=1 + DO 250 JGR=1,NGRP + SCATF(J,I,IL,IGR,JGR)=SCATF(J,I,IL,IGR,JGR)- + 1 SMICR(J,ISO,I,IL,IGR,JGR)*DELC + 250 CONTINUE + 260 CONTINUE + ENDIF + LOGI=.FALSE. + 270 CONTINUE + 280 CONTINUE + 290 CONTINUE +C----------------------------------------------------------------------C +C 'MIXMD' AND 'MIXFD' +C TAKE OFF THE INDIVIDUAL VARIATION CONTRIBUTION OF: +C FUEL TEMPERATURE +C COOLANT TEMPERATURE +C COOLANT DENSITY +C---------------------------- +C 'FPCH1' AND 'FPCL1' +C XENON CONCENTRATION +C SAMARIUM CONCENTRATION +C NEPTUNIUM CONCENTRATION +C + IF(MIXP.EQ.1) THEN + IF(TEXT1.EQ.'MIXMD'.OR.TEXT1.EQ.'MIXFD') NCOR=4 + IF(TEXT1.EQ.'FPCH1'.OR.TEXT1.EQ.'FPCL1') NCOR=3 + IF(ABS(IPRINT) .GT. 5) THEN + WRITE(IOUT,6000) TEXT1,NCOR,(TMIX(II),II=1,NCOR) + ENDIF + CALL LCMSIX(IPFBM,TEXTR,1) + DO 820 I=1,NBURN + WRITE(TEXTB,'(4HBURN,4X,I4)') I + CALL LCMSIX(IPFBM,TEXTB,1) + CALL LCMSIX(IPFBM,'MACR',1) + CALL LCMSIX(IPFBM,'ABS',1) + DO 320 II=1,NCOR + DO 310 J=1,NB + CALL LCMGET(IPFBM,TMIX(II),WORK3) + DO 300 IGR=1,NGRP + TOTAF(IGR,I,J)= TOTAF(IGR,I,J)-WORK3(IGR)*V(I,II,J) + 300 CONTINUE + 310 CONTINUE + 320 CONTINUE + CALL LCMSIX(IPFBM,' ',2) +C + IF(IXYZ.EQ.0) THEN + CALL LCMSIX(IPFBM,'STRD ',1) + DO 350 II=1,NCOR + DO 340 J=1,NB + CALL LCMGET(IPFBM,TMIX(II),WORK3) + DO 330 IGR=1,NGRP + DXF(IGR,I,J)= DXF(IGR,I,J)-WORK3(IGR)*V(I,II,J) + 330 CONTINUE + 340 CONTINUE + 350 CONTINUE + CALL LCMSIX(IPFBM,' ',2) +C + ELSE IF(IXYZ.EQ.1) THEN + CALL LCMSIX(IPFBM,'STRD X',1) + DO 380 II=1,NCOR + DO 370 J=1,NB + CALL LCMGET(IPFBM,TMIX(II),WORK3) + DO 360 IGR=1,NGRP + DXF(IGR,I,J)= DXF(IGR,I,J)-WORK3(IGR)*V(I,II,J) + 360 CONTINUE + 370 CONTINUE + 380 CONTINUE + CALL LCMSIX(IPFBM,' ',2) +C + CALL LCMSIX(IPFBM,'STRD Y',1) + DO 410 II=1,NCOR + DO 400 J=1,NB + CALL LCMGET(IPFBM,TMIX(II),WORK3) + DO 390 IGR=1,NGRP + DYF(IGR,I,J)= DYF(IGR,I,J)-WORK3(IGR)*V(I,II,J) + 390 CONTINUE + 400 CONTINUE + 410 CONTINUE + CALL LCMSIX(IPFBM,' ',2) +C + CALL LCMSIX(IPFBM,'STRD Z',1) + DO 440 II=1,NCOR + DO 430 J=1,NB + CALL LCMGET(IPFBM,TMIX(II),WORK3) + DO 420 IGR=1,NGRP + DZF(IGR,I,J)= DZF(IGR,I,J)-WORK3(IGR)*V(I,II,J) + 420 CONTINUE + 430 CONTINUE + 440 CONTINUE + CALL LCMSIX(IPFBM,' ',2) + ENDIF +C + IF(JTAB(1).EQ.1) THEN + CALL LCMSIX(IPFBM,'NUSIGF',1) + DO 470 II=1,NCOR + DO 460 J=1,NB + CALL LCMGET(IPFBM,TMIX(II),WORK3) + DO 450 IGR=1,NGRP + ZNUF(IGR,I,J)= ZNUF(IGR,I,J)-WORK3(IGR)*V(I,II,J) + 450 CONTINUE + 460 CONTINUE + 470 CONTINUE + CALL LCMSIX(IPFBM,' ',2) +C + CALL LCMSIX(IPFBM,'H-FACTORS',1) + DO 500 II=1,NCOR + DO 490 J=1,NB + CALL LCMGET(IPFBM,TMIX(II),WORK3) + DO 480 IGR=1,NGRP + HF(IGR,I,J)= HF(IGR,I,J)-WORK3(IGR)*V(I,II,J) + 480 CONTINUE + 490 CONTINUE + 500 CONTINUE + CALL LCMSIX(IPFBM,' ',2) + ENDIF +C + IL=1 + WRITE (CM,'(I2)') IL-1 + CALL LCMSIX(IPFBM,'SCAT'//CM,1) + CALL LCMGET(IPFBM,'NJJ',NJJ) + CALL LCMGET(IPFBM,'IJJ',IJJ) + DO 540 II=1,NCOR + DO 530 J=1,NB + CALL LCMGET(IPFBM,TMIX(II),WORK3) + IGAR=0 + DO 520 JGR=1,NGRP + DO 510 IGR=IJJ(JGR),IJJ(JGR)-NJJ(JGR)+1,-1 + IGAR=IGAR+1 + SCATF(J,I,IL,IGR,JGR)=SCATF(J,I,IL,IGR,JGR)- + 1 WORK3(IGAR)*V(I,II,J) + 510 CONTINUE + 520 CONTINUE + 530 CONTINUE + 540 CONTINUE + CALL LCMSIX(IPFBM,' ',2) +C +C GO UP FOR MACR + CALL LCMSIX(IPFBM,' ',2) +C +C MICROSCOPIC X-SECTION CORRECTION +C + DO 810 ISO=2,NISO + WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+IH),IH=1,3) + CALL LCMSIX(IPFBM,HMICRO,1) +C + CALL LCMSIX(IPFBM,'ABS',1) + DO 580 II=1,NCOR + DO 570 J=1,NB + CALL LCMGET(IPFBM,TMIX(II),WORK3) + DO 560 IGR=1,NGRP + TMICR(IGR,ISO,I,J)=TMICR(IGR,ISO,I,J)-WORK3(IGR)*V(I,II,J) + 560 CONTINUE + 570 CONTINUE + 580 CONTINUE + CALL LCMSIX(IPFBM,' ',2) +C + IF(IXYZ.EQ.0) THEN + CALL LCMSIX(IPFBM,'STRD ',1) + DO 610 II=1,NCOR + DO 600 J=1,NB + CALL LCMGET(IPFBM,TMIX(II),WORK3) + DO 590 IGR=1,NGRP + DMICRX(IGR,ISO,I,J)=DMICRX(IGR,ISO,I,J)-WORK3(IGR)*V(I,II,J) + 590 CONTINUE + 600 CONTINUE + 610 CONTINUE + CALL LCMSIX(IPFBM,' ',2) +C + ELSE IF(IXYZ.EQ.1) THEN + CALL LCMSIX(IPFBM,'STRD X',1) + DO 640 II=1,NCOR + DO 630 J=1,NB + CALL LCMGET(IPFBM,TMIX(II),WORK3) + DO 620 IGR=1,NGRP + DMICRX(IGR,ISO,I,J)=DMICRX(IGR,ISO,I,J)-WORK3(IGR)*V(I,II,J) + 620 CONTINUE + 630 CONTINUE + 640 CONTINUE + CALL LCMSIX(IPFBM,' ',2) +C + CALL LCMSIX(IPFBM,'STRD Y',1) + DO 670 II=1,NCOR + DO 660 J=1,NB + CALL LCMGET(IPFBM,TMIX(II),WORK3) + DO 650 IGR=1,NGRP + DMICRY(IGR,ISO,I,J)=DMICRY(IGR,ISO,I,J)-WORK3(IGR)*V(I,II,J) + 650 CONTINUE + 660 CONTINUE + 670 CONTINUE + CALL LCMSIX(IPFBM,' ',2) +C + CALL LCMSIX(IPFBM,'STRD Z',1) + DO 700 II=1,NCOR + DO 690 J=1,NB + CALL LCMGET(IPFBM,TMIX(II),WORK3) + DO 680 IGR=1,NGRP + DMICRZ(IGR,ISO,I,J)=DMICRZ(IGR,ISO,I,J)-WORK3(IGR)*V(I,II,J) + 680 CONTINUE + 690 CONTINUE + 700 CONTINUE + CALL LCMSIX(IPFBM,' ',2) + ENDIF +C + IF(JTAB(ISO).EQ.1) THEN + CALL LCMSIX(IPFBM,'NUSIGF',1) + DO 730 II=1,NCOR + DO 720 J=1,NB + CALL LCMGET(IPFBM,TMIX(II),WORK3) + DO 710 IGR=1,NGRP + FMICR(IGR,ISO,I,J)=FMICR(IGR,ISO,I,J)-WORK3(IGR)*V(I,II,J) + 710 CONTINUE + 720 CONTINUE + 730 CONTINUE + CALL LCMSIX(IPFBM,' ',2) +C + CALL LCMSIX(IPFBM,'H-FACTORS',1) + DO 760 II=1,NCOR + DO 750 J=1,NB + CALL LCMGET(IPFBM,TMIX(II),WORK3) + DO 740 IGR=1,NGRP + HMICR(IGR,ISO,I,J)= HMICR(IGR,ISO,I,J)-WORK3(IGR)*V(I,II,J) + 740 CONTINUE + 750 CONTINUE + 760 CONTINUE + CALL LCMSIX(IPFBM,' ',2) + ENDIF +C + IL=1 + WRITE (CM,'(I2)') IL-1 + CALL LCMSIX(IPFBM,'SCAT'//CM,1) + DO 800 II=1,NCOR + DO 790 J=1,NB + CALL LCMGET(IPFBM,TMIX(II),WORK3) + IGAR=0 + DO 780 JGR=1,NGRP + DO 770 IGR=MIJ(JGR),MIJ(JGR)-MNJ(JGR)+1,-1 + IGAR=IGAR+1 + SMICR(J,ISO,I,IL,IGR,JGR)=SMICR(J,ISO,I,IL,IGR,JGR)- + 1 WORK3(IGAR)*V(I,II,J) + 770 CONTINUE + 780 CONTINUE + 790 CONTINUE + 800 CONTINUE + CALL LCMSIX(IPFBM,' ',2) +C + CALL LCMSIX(IPFBM,' ',2) + 810 CONTINUE +C GO UP FOR BURNUP + CALL LCMSIX(IPFBM,' ',2) + 820 CONTINUE + CALL LCMSIX(IPFBM,' ',2) + ENDIF +C +C END OF INDIVIDUAL CORRECTION +C----------------------------------------------------------------------C +C----- +C INVERT THE FEEDBACK FORMULAS +C----- + DO 945 I=1,NBURN + DO 940 IGR=1,NGRP + IF(NB.EQ.1) THEN +C +C ONLY ONE COEFFICIENT IS REQUIRED (NB=1) FOR: +C BORON CONCENTRATION +C XENON CONCENTRATION +C SAMARIUM CONCENTRATION +C NEPTUNIUM CONCENTRATION +C MODERATOR PURITY +C + IF(TEXT1.EQ.'MIXMD'.AND.IGR.EQ.1) DELTA(I,1)=DELTA(I,1)*DT + IF(TEXT1.EQ.'MIXFD'.AND.IGR.EQ.1) DELTA(I,1)=DELTA(I,1)*DT + IF(DELTA(I,1).NE.0.0) THEN + TOTAF(IGR,I,1)=TOTAF(IGR,I,1)/DELTA(I,1) + DXF(IGR,I,1)=DXF(IGR,I,1)/DELTA(I,1) + DYF(IGR,I,1)=DYF(IGR,I,1)/DELTA(I,1) + DZF(IGR,I,1)=DZF(IGR,I,1)/DELTA(I,1) + ZNUF(IGR,I,1)=ZNUF(IGR,I,1)/DELTA(I,1) + HF(IGR,I,1)=HF(IGR,I,1)/DELTA(I,1) + DO 830 ISO=2,NISO + TMICR(IGR,ISO,I,1)=TMICR(IGR,ISO,I,1)/DELTA(I,1) + DMICRX(IGR,ISO,I,1)=DMICRX(IGR,ISO,I,1)/DELTA(I,1) + DMICRY(IGR,ISO,I,1)=DMICRY(IGR,ISO,I,1)/DELTA(I,1) + DMICRZ(IGR,ISO,I,1)=DMICRZ(IGR,ISO,I,1)/DELTA(I,1) + IF(JTAB(ISO).EQ.1) THEN + FMICR(IGR,ISO,I,1)=FMICR(IGR,ISO,I,1)/DELTA(I,1) + HMICR(IGR,ISO,I,1)=HMICR(IGR,ISO,I,1)/DELTA(I,1) + ENDIF + 830 CONTINUE + IL=1 + DO 850 JGR=1,NGRP + SCATF(1,I,IL,IGR,JGR)=SCATF(1,I,IL,IGR,JGR)/DELTA(I,1) + DO 840 ISO=2,NISO + SMICR(1,ISO,I,IL,IGR,JGR)=SMICR(1,ISO,I,IL,IGR,JGR)/DELTA(I,1) + 840 CONTINUE + 850 CONTINUE + ELSE + TOTAF(IGR,I,1)=0.0 + DXF(IGR,I,1) =0.0 + DYF(IGR,I,1) =0.0 + DZF(IGR,I,1) =0.0 +C + ZNUF(IGR,I,1) =0.0 + HF(IGR,I,1) =0.0 + DO 860 ISO=2,NISO + TMICR(IGR,ISO,I,1) =0.0 + DMICRX(IGR,ISO,I,1)=0.0 + DMICRY(IGR,ISO,I,1)=0.0 + DMICRZ(IGR,ISO,I,1)=0.0 + IF(JTAB(ISO).EQ.1) THEN + FMICR(IGR,ISO,I,1)=0.0 + HMICR(IGR,ISO,I,1)=0.0 + ENDIF + 860 CONTINUE + DO 872 IL=1,NL + DO 871 JGR=1,NGRP + SCATF(1,I,IL,IGR,JGR)=0.0 + DO 870 ISO=2,NISO + SMICR(1,ISO,I,IL,IGR,JGR)=0.0 + 870 CONTINUE + 871 CONTINUE + 872 CONTINUE + ENDIF +C + ELSE IF(NB.EQ.2) THEN +C +C INVERT THE FEEDBACK FORMULAS +C TWO FBM COEFFICIENTS ARE COMPUTED +C TEMPERATURES +C DENSITIES +C POWER LEVEL +C + IF(TEXT1.EQ.'FPCH1'.OR.TEXT1.EQ.'FPCL1') THEN + PV1U=DELTA(I,1) + PV2U=PV1U*PV1U + PV2UB=PV2U + PV1D=DELTA(I,2) + PV2D=PV1D*PV1D + PV2DB=PV2D + ENDIF +C + TX=PV2U*PV1D - PV2D*PV1U + TXB=PV2UB*PV1D - PV2DB*PV1U +C + IF(TX.NE.0.0.AND.TXB.NE.0.0) THEN + TOTAF(IGR,I,2)=(TOTAF(IGR,I,1)*PV1D-TOTAF(IGR,I,2)*PV1U)/TX + TOTAF(IGR,I,1)=(TOTAF(IGR,I,1) - TOTAF(IGR,I,2)*PV2U)/PV1U +C + DXF(IGR,I,2)=(DXF(IGR,I,1)*PV1D -DXF(IGR,I,2)*PV1U)/TXB + DXF(IGR,I,1)=(DXF(IGR,I,1) - DXF(IGR,I,2)*PV2UB)/PV1U + DYF(IGR,I,2)=(DYF(IGR,I,1)*PV1D -DYF(IGR,I,2)*PV1U)/TXB + DYF(IGR,I,1)=(DYF(IGR,I,1) - DYF(IGR,I,2)*PV2UB)/PV1U + DZF(IGR,I,2)=(DZF(IGR,I,1)*PV1D -DZF(IGR,I,2)*PV1U)/TXB + DZF(IGR,I,1)=(DZF(IGR,I,1) - DZF(IGR,I,2)*PV2UB)/PV1U +C + ZNUF(IGR,I,2)=(ZNUF(IGR,I,1)*PV1D - ZNUF(IGR,I,2)*PV1U)/TX + ZNUF(IGR,I,1)=(ZNUF(IGR,I,1) - ZNUF(IGR,I,2)*PV2U)/PV1U +C + HF(IGR,I,2)=(HF(IGR,I,1)*PV1D - HF(IGR,I,2)*PV1U)/TX + HF(IGR,I,1)=(HF(IGR,I,1) - HF(IGR,I,2)*PV2U)/PV1U +C + DO 880 ISO=2,NISO + TMICR(IGR,ISO,I,2)=(TMICR(IGR,ISO,I,1)*PV1D - + 1 TMICR(IGR,ISO,I,2)*PV1U)/TX + TMICR(IGR,ISO,I,1)=(TMICR(IGR,ISO,I,1) - + 1 TMICR(IGR,ISO,I,2)*PV2U)/PV1U +C + DMICRX(IGR,ISO,I,2)=(DMICRX(IGR,ISO,I,1)*PV1D - + 1 DMICRX(IGR,ISO,I,2)*PV1U)/TX + DMICRX(IGR,ISO,I,1)=(DMICRX(IGR,ISO,I,1) - + 1 DMICRX(IGR,ISO,I,2)*PV2U)/PV1U + DMICRY(IGR,ISO,I,2)=(DMICRY(IGR,ISO,I,1)*PV1D - + 1 DMICRY(IGR,ISO,I,2)*PV1U)/TX + DMICRY(IGR,ISO,I,1)=(DMICRY(IGR,ISO,I,1) - + 1 DMICRY(IGR,ISO,I,2)*PV2U)/PV1U + DMICRZ(IGR,ISO,I,2)=(DMICRZ(IGR,ISO,I,1)*PV1D - + 1 DMICRZ(IGR,ISO,I,2)*PV1U)/TX + DMICRZ(IGR,ISO,I,1)=(DMICRZ(IGR,ISO,I,1) - + 1 DMICRZ(IGR,ISO,I,2)*PV2U)/PV1U +C + IF(JTAB(ISO).EQ.1) THEN + FMICR(IGR,ISO,I,2)=(FMICR(IGR,ISO,I,1)*PV1D - + 1 FMICR(IGR,ISO,I,2)*PV1U)/TX + FMICR(IGR,ISO,I,1)=(FMICR(IGR,ISO,I,1) - + 1 FMICR(IGR,ISO,I,2)*PV2U)/PV1U +C + HMICR(IGR,ISO,I,2)=(HMICR(IGR,ISO,I,1)*PV1D - + 1 HMICR(IGR,ISO,I,2)*PV1U)/TX + HMICR(IGR,ISO,I,1)=(HMICR(IGR,ISO,I,1) - + 1 HMICR(IGR,ISO,I,2)*PV2U)/PV1U + ENDIF + 880 CONTINUE +C + IL=1 + DO 895 JGR=1,NGRP + SCATF(2,I,IL,IGR,JGR)=(SCATF(1,I,IL,IGR,JGR)*PV1D- + 1 SCATF(2,I,IL,IGR,JGR)*PV1U)/TXB + SCATF(1,I,IL,IGR,JGR)=(SCATF(1,I,IL,IGR,JGR) - + 1 SCATF(2,I,IL,IGR,JGR)*PV2UB)/PV1U + DO 890 ISO=2,NISO + SMICR(2,ISO,I,IL,IGR,JGR)=(SMICR(1,ISO,I,IL,IGR,JGR)*PV1D- + 1 SMICR(2,ISO,I,IL,IGR,JGR)*PV1U)/TX + SMICR(1,ISO,I,IL,IGR,JGR)=(SMICR(1,ISO,I,IL,IGR,JGR) - + 1 SMICR(2,ISO,I,IL,IGR,JGR)*PV2U)/PV1U + 890 CONTINUE + 895 CONTINUE + ELSE + DO 930 J=1,NB + TOTAF(IGR,I,J)=0.0 + DXF(IGR,I,J) =0.0 + DYF(IGR,I,J) =0.0 + DZF(IGR,I,J) =0.0 + ZNUF(IGR,I,J)=0.0 + HF(IGR,I,J)=0.0 + DO 900 ISO=2,NISO + TMICR(IGR,ISO,I,J) =0.0 + DMICRX(IGR,ISO,I,J)=0.0 + DMICRY(IGR,ISO,I,J)=0.0 + DMICRZ(IGR,ISO,I,J)=0.0 + IF(JTAB(ISO).EQ.1) THEN + FMICR(IGR,ISO,I,J)=0.0 + HMICR(IGR,ISO,I,J)=0.0 + ENDIF + 900 CONTINUE + DO 922 IL=1,NL + DO 921 JGR=1,NGRP + SCATF(J,I,IL,IGR,JGR)=0.0 + DO 920 ISO=2,NISO + SMICR(J,ISO,I,IL,IGR,JGR)=0.0 + 920 CONTINUE + 921 CONTINUE + 922 CONTINUE + 930 CONTINUE + ENDIF + ENDIF + 940 CONTINUE + 945 CONTINUE +C +C ALL NOMINAL NEUTRONICS CONSTANTS ARE ALREDY STORED +C----- +C STORING PROGRAM FOR THE FEEDBACK COEFFICIENTS. +C----- + CALL LCMSIX(IPFBM,TEXTR,1) + DO 1000 I=1,NBURN + WRITE(TEXTB,'(4HBURN,4X,I4)') I + CALL LCMSIX(IPFBM,TEXTB,1) + CALL LCMSIX(IPFBM,'MACR',1) + CALL LCMSIX(IPFBM,'ABS',1) + CALL LCMPUT(IPFBM,TEXT1,NGRP,2,TOTAF(1,I,1)) + CALL LCMSIX(IPFBM,' ',2) +C + IF(IXYZ.EQ.0) THEN + CALL LCMSIX(IPFBM,'STRD ',1) + CALL LCMPUT(IPFBM,TEXT1,NGRP,2,DXF(1,I,1)) + CALL LCMSIX(IPFBM,' ',2) +C + ELSE IF(IXYZ.EQ.1) THEN + CALL LCMSIX(IPFBM,'STRD X',1) + CALL LCMPUT(IPFBM,TEXT1,NGRP,2,DXF(1,I,1)) + CALL LCMSIX(IPFBM,' ',2) + CALL LCMSIX(IPFBM,'STRD Y',1) + CALL LCMPUT(IPFBM,TEXT1,NGRP,2,DYF(1,I,1)) + CALL LCMSIX(IPFBM,' ',2) + CALL LCMSIX(IPFBM,'STRD Z',1) + CALL LCMPUT(IPFBM,TEXT1,NGRP,2,DZF(1,I,1)) + CALL LCMSIX(IPFBM,' ',2) + ENDIF +C + IF(JTAB(1).EQ.1) THEN + CALL LCMSIX(IPFBM,'NUSIGF',1) + CALL LCMPUT(IPFBM,TEXT1,NGRP,2,ZNUF(1,I,1)) + CALL LCMSIX(IPFBM,' ',2) +C + CALL LCMSIX(IPFBM,'H-FACTORS',1) + CALL LCMPUT(IPFBM,TEXT1,NGRP,2,HF(1,I,1)) + CALL LCMSIX(IPFBM,' ',2) + ENDIF +C + IF(NB.EQ.2) THEN + CALL LCMSIX(IPFBM,'ABS',1) + CALL LCMPUT(IPFBM,TEXT2,NGRP,2,TOTAF(1,I,2)) + CALL LCMSIX(IPFBM,' ',2) +C + IF(IXYZ.EQ.0) THEN + CALL LCMSIX(IPFBM,'STRD ',1) + CALL LCMPUT(IPFBM,TEXT2,NGRP,2,DXF(1,I,2)) + CALL LCMSIX(IPFBM,' ',2) +C + ELSE IF(IXYZ.EQ.1) THEN + CALL LCMSIX(IPFBM,'STRD X',1) + CALL LCMPUT(IPFBM,TEXT2,NGRP,2,DXF(1,I,2)) + CALL LCMSIX(IPFBM,' ',2) + CALL LCMSIX(IPFBM,'STRD Y',1) + CALL LCMPUT(IPFBM,TEXT2,NGRP,2,DYF(1,I,2)) + CALL LCMSIX(IPFBM,' ',2) + CALL LCMSIX(IPFBM,'STRD Z',1) + CALL LCMPUT(IPFBM,TEXT2,NGRP,2,DZF(1,I,2)) + CALL LCMSIX(IPFBM,' ',2) + ENDIF +C + IF(JTAB(1).EQ.1) THEN + CALL LCMSIX(IPFBM,'NUSIGF',1) + CALL LCMPUT(IPFBM,TEXT2,NGRP,2,ZNUF(1,I,2)) + CALL LCMSIX(IPFBM,' ',2) +C + CALL LCMSIX(IPFBM,'H-FACTORS',1) + CALL LCMPUT(IPFBM,TEXT2,NGRP,2,HF(1,I,2)) + CALL LCMSIX(IPFBM,' ',2) + ENDIF + ENDIF +C + IL=1 + WRITE (CM,'(I2)') IL-1 + CALL LCMSIX(IPFBM,'SCAT'//CM,1) + CALL LCMLEN(IPFBM,'REF',ILENG,ITYXSM) + IF(ILENG.GT.0) THEN + IGAR=0 + DO 955 JGR=1,NGRP + DO 950 IGR=MIJ(JGR),MIJ(JGR)-MNJ(JGR)+1,-1 + IGAR=IGAR+1 + WORK3(IGAR)=SCATF(1,I,IL,IGR,JGR) + 950 CONTINUE + 955 CONTINUE + CALL LCMPUT(IPFBM,TEXT1,IGAR,2,WORK3) + IF(NB.EQ.2) THEN + IGAR=0 + DO 965 JGR=1,NGRP + DO 960 IGR=MIJ(JGR),MIJ(JGR)-MNJ(JGR)+1,-1 + IGAR=IGAR+1 + WORK3(IGAR)=SCATF(2,I,IL,IGR,JGR) + 960 CONTINUE + 965 CONTINUE + CALL LCMPUT(IPFBM,TEXT2,IGAR,2,WORK3) + ENDIF + ENDIF + CALL LCMSIX(IPFBM,' ',2) +C +C GO UP FOR MACR + CALL LCMSIX(IPFBM,' ',2) +C----- +C STORE MICROSCOPIC INFONFORMATION +C----- + DO 990 ISO=2,NISO + WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+IH),IH=1,3) + CALL LCMLEN(IPFBM,HMICRO,ILENG,ITYLCM) + CALL LCMSIX(IPFBM,HMICRO,1) +C + CALL LCMSIX(IPFBM,'ABS',1) + CALL LCMPUT(IPFBM,TEXT1,NGRP,2,TMICR(1,ISO,I,1)) + CALL LCMSIX(IPFBM,' ',2) +C + IF(IXYZ.EQ.0) THEN + CALL LCMSIX(IPFBM,'STRD ',1) + CALL LCMPUT(IPFBM,TEXT1,NGRP,2,DMICRX(1,ISO,I,1)) + CALL LCMSIX(IPFBM,' ',2) +C + ELSE IF(IXYZ.EQ.1) THEN + CALL LCMSIX(IPFBM,'STRD X',1) + CALL LCMPUT(IPFBM,TEXT1,NGRP,2,DMICRX(1,ISO,I,1)) + CALL LCMSIX(IPFBM,' ',2) + CALL LCMSIX(IPFBM,'STRD Y',1) + CALL LCMPUT(IPFBM,TEXT1,NGRP,2,DMICRY(1,ISO,I,1)) + CALL LCMSIX(IPFBM,' ',2) + CALL LCMSIX(IPFBM,'STRD Z',1) + CALL LCMPUT(IPFBM,TEXT1,NGRP,2,DMICRZ(1,ISO,I,1)) + CALL LCMSIX(IPFBM,' ',2) + ENDIF +C + IF(JTAB(ISO).EQ.1) THEN + CALL LCMSIX(IPFBM,'NUSIGF',1) + CALL LCMPUT(IPFBM,TEXT1,NGRP,2,FMICR(1,ISO,I,1)) + CALL LCMSIX(IPFBM,' ',2) +C + CALL LCMSIX(IPFBM,'H-FACTORS',1) + CALL LCMPUT(IPFBM,TEXT1,NGRP,2,HMICR(1,ISO,I,1)) + CALL LCMSIX(IPFBM,' ',2) + ENDIF +C + IF(NB.EQ.2) THEN + CALL LCMSIX(IPFBM,'ABS',1) + CALL LCMPUT(IPFBM,TEXT2,NGRP,2,TMICR(1,ISO,I,2)) + CALL LCMSIX(IPFBM,' ',2) +C + IF(IXYZ.EQ.0) THEN + CALL LCMSIX(IPFBM,'STRD ',1) + CALL LCMPUT(IPFBM,TEXT2,NGRP,2,DMICRX(1,ISO,I,2)) + CALL LCMSIX(IPFBM,' ',2) +C + ELSE IF(IXYZ.EQ.1) THEN + CALL LCMSIX(IPFBM,'STRD X',1) + CALL LCMPUT(IPFBM,TEXT2,NGRP,2,DMICRX(1,ISO,I,2)) + CALL LCMSIX(IPFBM,' ',2) + CALL LCMSIX(IPFBM,'STRD Y',1) + CALL LCMPUT(IPFBM,TEXT2,NGRP,2,DMICRY(1,ISO,I,2)) + CALL LCMSIX(IPFBM,' ',2) + CALL LCMSIX(IPFBM,'STRD Z',1) + CALL LCMPUT(IPFBM,TEXT2,NGRP,2,DMICRZ(1,ISO,I,2)) + CALL LCMSIX(IPFBM,' ',2) + ENDIF +C + IF(JTAB(ISO).EQ.1) THEN + CALL LCMSIX(IPFBM,'NUSIGF',1) + CALL LCMPUT(IPFBM,TEXT2,NGRP,2,FMICR(1,ISO,I,2)) + CALL LCMSIX(IPFBM,' ',2) +C + CALL LCMSIX(IPFBM,'H-FACTORS',1) + CALL LCMPUT(IPFBM,TEXT2,NGRP,2,HMICR(1,ISO,I,2)) + CALL LCMSIX(IPFBM,' ',2) + ENDIF + ENDIF +C + IL=1 + WRITE (CM,'(I2)') IL-1 + CALL LCMSIX(IPFBM,'SCAT'//CM,1) + CALL LCMLEN(IPFBM,'REF',ILENG,ITYXSM) + IF(ILENG.GT.0) THEN + IGAR=0 + DO 975 JGR=1,NGRP + DO 970 IGR=MIJ(JGR),MIJ(JGR)-MNJ(JGR)+1,-1 + IGAR=IGAR+1 + WORK3(IGAR)=SMICR(1,ISO,I,IL,IGR,JGR) + 970 CONTINUE + 975 CONTINUE + CALL LCMPUT(IPFBM,TEXT1,IGAR,2,WORK3) + IF(NB.EQ.2) THEN + IGAR=0 + DO 985 JGR=1,NGRP + DO 980 IGR=MIJ(JGR),MIJ(JGR)-MNJ(JGR)+1,-1 + IGAR=IGAR+1 + WORK3(IGAR)=SMICR(2,ISO,I,IL,IGR,JGR) + 980 CONTINUE + 985 CONTINUE + CALL LCMPUT(IPFBM,TEXT2,IGAR,2,WORK3) + ENDIF + ENDIF + CALL LCMSIX(IPFBM,' ',2) +C +C GO UP FOR MICR + CALL LCMSIX(IPFBM,' ',2) + 990 CONTINUE +C GO UP FOR BURN + CALL LCMSIX(IPFBM,' ',2) + 1000 CONTINUE +C + CALL LCMSIX(IPFBM,' ',2) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IXS,NJJ,IJJ) +C + RETURN + 6000 FORMAT(' Keyword =',A8,' ncor =',i4,' Param =',8(2X,A8)) + END diff --git a/Dragon/src/CFCGET.f b/Dragon/src/CFCGET.f new file mode 100644 index 0000000..5037029 --- /dev/null +++ b/Dragon/src/CFCGET.f @@ -0,0 +1,210 @@ +*DECK CFCGET + SUBROUTINE CFCGET(TINFO,DBNAME,IPRINT,NBPARA,DBPARA) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read CFC options. +* +*Copyright: +* Copyright (C) 2009 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau +* +*Parameters: input +* TINFO title of database. +* DBNAME database name. +* IPRINT print level. +* NBPARA number of parameters. +* DBPARA database parameters: +* DBPARA( 1) = Nominal power level (PWR); +* DBPARA( 2) = Nominal T cool (TCR); +* DBPARA( 3) = Nominal T mode (TMR); +* DBPARA( 4) = Nominal T fuel (TFR); +* DBPARA( 5) = Nominal Density cool; +* DBPARA( 6) = Nominal Density mode; +* DBPARA( 7) = Nominal purity mode (XIR); +* DBPARA( 8) = Perturbed T fuel 1 (TFU); +* DBPARA( 9) = Perturbed T cool 1 (TCU); +* DBPARA(10) = Perturbed P1 (PWUL); +* DBPARA(11) = Perturbed P2 (PWDL); +* DBPARA(12) = Perturbed P3 (PWU); +* DBPARA(13) = Perturbed P4 (PWD); +* DBPARA(14) = Perturbed P mode (XI). +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER TINFO*72,DBNAME*9 + INTEGER IPRINT,NBPARA + REAL DBPARA(NBPARA) +*---- +* LOCAL PARAMETERS +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='CFCGET') +*---- +* INPUT PARAMETERS +*---- + INTEGER ITYPLU,INTLIR + CHARACTER CARLIR*12 + REAL REALIR + DOUBLE PRECISION DBLLIR +*---- +* INITIALIZE PARAMETERS +*---- + IPRINT=1 + DBPARA(:NBPARA)=0.0 + DBPARA(1)=615.0 + DBPARA(2)=560.66 + DBPARA(3)=345.66 + DBPARA(4)=941.29 + DBPARA(5)=1.08288 + DBPARA(6)=0.81212 + DBPARA(7)=0.99911 + DBPARA(8)=1241.29 + DBPARA(9)=660.66 + DBPARA(10)=878.57143 + DBPARA(11)=307.5 + DBPARA(12)=307.5 + DBPARA(13)=100.0 + DBPARA(14)=0.985 + DBPARA(15)=375.66 + DBPARA(16)=541.29 + DBPARA(17)=300.66 + DBPARA(18)=295.66 +*---- +* READ TITLE +*---- + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + >': CHARACTER DATA EXPECTED.') + IF(CARLIR .EQ. 'EDIT') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .EQ. 1) THEN + IPRINT=INTLIR + ELSE + CALL XABORT(NAMSBR//': EDIT LEVEL EXPECTED.') + ENDIF + CALL REDGET (ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + >': CHARACTER DATA EXPECTED.') + ENDIF + IF(CARLIR .EQ. 'INFOR') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,TINFO,DBLLIR) + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + > ': CHARACTER DATA EXPECTED.') + ELSE + CALL XABORT(NAMSBR//': INFOR KEY WORD EXPECTED.') + ENDIF +*----- +* READ THE RECORD NAME FOR THE DATABASE +*----- + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + >': CHARACTER DATA EXPECTED.') + IF(CARLIR .EQ. 'DNAME') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + > ': CHARACTER DATA EXPECTED.') + DBNAME=CARLIR(1:9) + ENDIF +*---- +* LOOP OVER PARAMETERS TO READ +*---- + 100 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + >': CHARACTER DATA EXPECTED.') + IF(CARLIR .EQ. ';') THEN + GO TO 105 + ELSE IF(CARLIR .EQ. 'PWR') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': Nominal power EXPECTED.') + DBPARA(1)=REALIR + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': Power UP EXPECTED.') + DBPARA(10)=REALIR + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': Power DOWN 1 EXPECTED.') + DBPARA(11)=REALIR + DBPARA(12)=REALIR + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': Power DOWN 2 EXPECTED.') + DBPARA(13)=REALIR + ELSE IF(CARLIR .EQ. 'TCOOL') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': Nominal coolant temperature expected.') + DBPARA(2)=REALIR + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': Perturbed up coolant temperature expected.') + DBPARA(9)=REALIR + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': Perturbed down coolant temperature expected.') + DBPARA(17)=REALIR + ELSE IF(CARLIR .EQ. 'TMODE') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': Nominal moderator temperature expected.') + DBPARA(3)=REALIR + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': Perturbed up moderator temperature expected.') + DBPARA(15)=REALIR + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': Perturbed down moderator temperature expected.') + DBPARA(18)=REALIR + ELSE IF(CARLIR .EQ. 'TFUEL') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': Nominal fuel temperature expected.') + DBPARA(4)=REALIR + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': Perturbed up fuel temperature expected.') + DBPARA(8)=REALIR + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': Perturbed down fuel temperature expected.') + DBPARA(16)=REALIR + ELSE IF(CARLIR .EQ. 'RHOM') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': Nominal moderator density expected.') + DBPARA(5)=REALIR + ELSE IF(CARLIR .EQ. 'RHOC') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': Nominal coolant density expected.') + DBPARA(6)=REALIR + ELSE IF(CARLIR .EQ. 'XIR') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': Nominal Xenon.') + DBPARA(7)=REALIR + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': Perturbed Xenon.') + DBPARA(14)=REALIR + ENDIF + GO TO 100 + 105 CONTINUE + RETURN + END diff --git a/Dragon/src/CHAB.f b/Dragon/src/CHAB.f new file mode 100644 index 0000000..fbb7c48 --- /dev/null +++ b/Dragon/src/CHAB.f @@ -0,0 +1,247 @@ +*DECK CHAB + SUBROUTINE CHAB(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Modify data contained in the microlib and renormalize the fission +* and scattering information. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): create or modification type(L_MICROLIB); +* HENTRY(2): optional read-only type(L_MICROLIB or L_DRAGLIB). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40,IOUT=6) + TYPE(C_PTR) IPLIB,KPLIB + CHARACTER TEXT4*4,TYPSEC*8,HISOT*12,HSIGN*12,NAM1*12,CD*4,HSMG*131 + DOUBLE PRECISION DFLOTT + INTEGER ISTATE(NSTATE),IMOD +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NFS + REAL, ALLOCATABLE, DIMENSION(:) :: VAL + CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: HNAMIS + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO +*---- +* PARAMETER VALIDATION +*---- + IF(NENTRY.LT.1) CALL XABORT('CHAB: MIN OF 1 OBJECT EXPECTED.') + IF(NENTRY.GT.2) CALL XABORT('CHAB: MAX OF 2 OBJECTS EXPECTED.') + IPLIB=KENTRY(1) + IF(NENTRY.EQ.1) THEN + IF(JENTRY(1).NE.1) CALL XABORT('CHAB: OBJECT IN MODIFICATION ' + 1 //'MODE EXPECTED NAME=.'//HENTRY(1)) + CALL LCMGTC(IPLIB,'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_LIBRARY') THEN + IRHS=1 + ELSE IF(HSIGN.EQ.'L_DRAGLIB') THEN + CALL XABORT('CHAB: WE DO NOT ALLOW THE IN-PLACE MODIFICATI' + 1 //'ON OF A DRAGLIB. USE A DIFFERENT LHS.') + ELSE + CALL XABORT('CHAB: MICROLIB OBJECT EXPECTED AT RHS.') + ENDIF + ELSE IF(NENTRY.EQ.2) THEN + IF(JENTRY(1).NE.0) CALL XABORT('CHAB: OBJECT IN CREATE MODE E' + 1 //'XPECTED.') + IF((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2)) CALL XABORT('CHAB: ' + 1 //'LCM OBJECT EXPECTED AT RHS.') + IF(JENTRY(2).NE.2) CALL XABORT('CHAB: LCM OBJECT IN READ-ONLY' + 1 //'MODE EXPECTED AT RHS.') + CALL LCMGTC(KENTRY(2),'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_LIBRARY') THEN + IRHS=1 + ELSE IF(HSIGN.EQ.'L_DRAGLIB') THEN + IRHS=2 + ELSE + CALL XABORT('CHAB: MICROLIB OR DRAGLIB OBJECT EXPECTED AT ' + 1 //'RHS.') + ENDIF + CALL LCMEQU(KENTRY(2),IPLIB) + ENDIF + IF(IRHS.EQ.1) THEN + CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) + NBISO=ISTATE(2) + NGRP=ISTATE(3) + NLEG=ISTATE(4) + ELSE IF(IRHS.EQ.2) THEN + CALL LCMLEN(IPLIB,'ENERGY',NGRP,ITYLCM) + NGRP=NGRP-1 + NLEG=100 + ENDIF + ALLOCATE(VAL(NGRP)) +*---- +* READ THE INPUT DATA +*---- + VAL(:NGRP)=0.0 + IMPX=1 + 10 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('CHAB: CHARACTER DATA EXPECTED(1).') + IF(TEXT4.EQ.'EDIT') THEN +* READ THE PRINT INDEX. + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('CHAB: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT4.EQ.'MODI') THEN +* MODIFY/ADD AN ENTRY (CROSS SECTION, SPECTRA, ETC). + CALL REDGET(INDIC,NITMA,FLOTT,TYPSEC,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('CHAB: CHARACTER DATA EXPECTED(2).') + CALL REDGET(INDIC,IGM,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('CHAB: INTEGER DATA EXPECTED(2).') + IF((IGM.LT.1).OR.(IGM.GT.NGRP)) CALL XABORT('CHAB: WRONG IGM.') + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('CHAB: CHARACTER DATA EXPECTED(3).') + IF(TEXT4.NE.'TO') CALL XABORT('CHAB: TO KEYWORD EXPECTED.') + CALL REDGET(INDIC,IGP,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('CHAB: INTEGER DATA EXPECTED(3).') + IF((IGP.LT.1).OR.(IGP.GT.NGRP)) CALL XABORT('CHAB: WRONG IGP.') + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('CHAB: CHARACTER DATA EXPECTED(4).') + IF(TEXT4.EQ.'VALE') THEN + DO 20 IGR=IGM,IGP + CALL REDGET(INDIC,NITMA,VAL(IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('CHAB: REAL DATA EXPECTED(1).') + 20 CONTINUE + IMOD=1 + ELSE IF(TEXT4.EQ.'CONS') THEN + CALL REDGET(INDIC,NITMA,VALUE,TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('CHAB: REAL DATA EXPECTED(2).') + IMOD=2 + ELSE IF(TEXT4.EQ.'PLUS') THEN + CALL REDGET(INDIC,NITMA,VALUE,TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('CHAB: REAL DATA EXPECTED(3).') + IMOD=3 + ELSE IF(TEXT4.EQ.'MULT') THEN + CALL REDGET(INDIC,NITMA,VALUE,TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('CHAB: REAL DATA EXPECTED(4).') + IMOD=4 + ELSE + CALL XABORT('CHAB: VALE/CONS/PLUS/MULT KEYWORD EXPECTED.') + ENDIF + CALL REDGET(INDIC,NITMA,FLOTT,HISOT,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('CHAB: CHARACTER DATA EXPECTED(5).') + IF((IRHS.EQ.1).AND.(HISOT(9:).EQ.' ')) THEN +* MODIFY MANY INSTANCES OF AN ISOTOPE IN A MICROLIB + ALLOCATE(HNAMIS(NBISO),IPISO(NBISO)) + CALL LCMGTC(IPLIB,'ISOTOPESUSED',12,NBISO,HNAMIS) + CALL LIBIPS(IPLIB,NBISO,IPISO) + DO 30 ISO=1,NBISO + NAM1=HNAMIS(ISO) + IF(NAM1(:8).EQ.HISOT) THEN + KPLIB=IPISO(ISO) ! set ISO-th isotope + IF(.NOT.C_ASSOCIATED(KPLIB)) THEN + WRITE(HSMG,'(15HCHAB: ISOTOPE '',A12,7H'' (ISO=,I8, + 1 34H IS NOT AVAILABLE IN THE MICROLIB.)') NAM1,ISO + CALL XABORT(HSMG) + ENDIF + CALL CHAB01(KPLIB,IMPX,IRHS,NGRP,NLEG,IMOD,TYPSEC,NAM1, + 1 VALUE,IGM,IGP,VAL) + ENDIF + 30 CONTINUE + DEALLOCATE(IPISO,HNAMIS) + ELSE IF(IRHS.EQ.1) THEN +* MODIFY A UNIQUE INSTANCE OF AN ISOTOPE IN A MICROLIB + ALLOCATE(HNAMIS(NBISO),IPISO(NBISO)) + CALL LCMGTC(IPLIB,'ISOTOPESUSED',12,NBISO,HNAMIS) + CALL LIBIPS(IPLIB,NBISO,IPISO) + DO 35 ISO=1,NBISO + IF(HNAMIS(ISO).EQ.HISOT) THEN + KPLIB=IPISO(ISO) ! set ISO-th isotope + IF(.NOT.C_ASSOCIATED(KPLIB)) THEN + WRITE(HSMG,'(15HCHAB: ISOTOPE '',A12,7H'' (ISO=,I8, + 1 34H IS NOT AVAILABLE IN THE MICROLIB.)') HISOT,ISO + CALL XABORT(HSMG) + ENDIF + CALL CHAB01(KPLIB,IMPX,IRHS,NGRP,NLEG,IMOD,TYPSEC,HISOT, + 1 VALUE,IGM,IGP,VAL) + ENDIF + 35 CONTINUE + DEALLOCATE(IPISO,HNAMIS) + ELSE IF(IRHS.EQ.2) THEN +* MODIFY AN ISOTOPE IN A DRAGLIB + CALL LCMLEN(IPLIB,HISOT,ILONG,ITYLCM) + IF(ILONG.EQ.0) CALL XABORT('CHAB: MISSING ISOTOPE '// + 1 HISOT//'.') + ALLOCATE(NFS(NGRP)) + CALL LCMSIX(IPLIB,HISOT,1) + CALL LCMLEN(IPLIB,'TEMPERATURE',NTMP,ITYLCM) + CALL LCMLEN(IPLIB,'BIN-NFS',ILONG,ITYLCM) + NBIN=0 + IF(ILONG.EQ.NGRP) THEN + CALL LCMGET(IPLIB,'BIN-NFS',NFS) + DO 40 IG=1,NGRP + NBIN=NBIN+NFS(IG) + 40 CONTINUE + IF(NBIN.EQ.0) CALL XABORT('CHAB: INVALID NBIN') + ENDIF + DO 60 ITMP=1,NTMP + WRITE (CD,'(I4.4)') ITMP + IF(IMPX.GT.0) WRITE(IOUT,'(/23H CHAB: PROCESS ISOTOPE ,A, + 1 22H AT TEMPERATURE SUBTMP,A4,1H.)') HISOT,CD + CALL LCMSIX (IPLIB,'SUBTMP'//CD,1) + CALL CHAB01(IPLIB,IMPX,IRHS,NGRP,NLEG,IMOD,TYPSEC, + 1 HISOT,VALUE,IGM,IGP,VAL) + IF(NBIN.GT.0) THEN + CALL CHAB03(IPLIB,IMPX,NGRP,NBIN,IMOD,TYPSEC,HISOT, + 1 VALUE,IGM,IGP,NFS,VAL) + ENDIF + IF(TYPSEC.NE.'CHI') THEN + CALL LCMLEN(IPLIB,'DILUTION',NDIL,ITYLCM) + DO 50 IDIL=1,NDIL + WRITE (CD,'(I4.4)') IDIL + IF(IMPX.GT.0) WRITE(IOUT,'(/23H CHAB: PROCESS ISOTOPE ,A, + 1 19H AT DILUTION SUBMAT,A4,1H.)') HISOT,CD + CALL LCMSIX(IPLIB,'SUBMAT'//CD,1) + IF(IMOD.LE.2) THEN + CALL CHAB01(IPLIB,IMPX,IRHS,NGRP,NLEG,1,TYPSEC,HISOT, + 1 0.0,IGM,IGP,VAL) + ELSE IF(IMOD.EQ.4) THEN + CALL CHAB01(IPLIB,IMPX,IRHS,NGRP,NLEG,IMOD,TYPSEC, + 1 HISOT,VALUE,IGM,IGP,VAL) + ENDIF + CALL LCMSIX (IPLIB,' ',2) + 50 CONTINUE + ENDIF + CALL LCMSIX (IPLIB,' ',2) + 60 CONTINUE + IF(NBIN.GT.0) DEALLOCATE(NFS) + CALL LCMSIX(IPLIB,' ',2) + ENDIF + ELSE IF(TEXT4.EQ.';') THEN + GO TO 70 + ELSE + CALL XABORT('CHAB: '//TEXT4//' IS AN INVALID KEYWORD.') + ENDIF + GO TO 10 +*---- +* RECOVER INFORMATION +*---- + 70 DEALLOCATE(VAL) + RETURN + END diff --git a/Dragon/src/CHAB01.f b/Dragon/src/CHAB01.f new file mode 100644 index 0000000..59a3810 --- /dev/null +++ b/Dragon/src/CHAB01.f @@ -0,0 +1,297 @@ +*DECK CHAB01 + SUBROUTINE CHAB01(IPLIB,IMPX,IRHS,NGRP,NLEG,IMOD,TYPSEC,HISOT, + 1 VALUE,IGM,IGP,VAL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Modify a specific isotope and reaction in a microlib. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB LCM pointer to the Microlib or Draglib. +* IMPX print index. +* IRHS type of IPLIB: =1: Microlib; =2: Draglib. +* NGRP number of energy groups. +* NLEG max Legendre order of scattering anisotropy (1=isotropic, +* etc.). +* IMOD type of modification: =1: complete replacement; =2: replace +* specific values by VALUE; =3: increase by VALUE; =4: multiply +* by VALUE. +* TYPSEC name of reaction to modify. +* HISOT name of isotope to modify. +* VALUE value used in modification operation. +* IGM first energy group to modify. +* IGP last energy group to modify. +* VAL array of values used if IMOD=1. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + INTEGER IMPX,IRHS,NGRP,NLEG,IMOD,IGM,IGP + CHARACTER TYPSEC*8,HISOT*12 + REAL VALUE,VAL(NGRP) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IOUT=6,NCAPT=5) + CHARACTER AJUS(4)*4,HCAPT(NCAPT)*8,CM*2 + REAL, ALLOCATABLE, DIMENSION(:) :: XSECT,DELTA,FMULT,GAR1 +*---- +* DATA STATEMENTS +*---- + DATA AJUS/'VALE','CONS','PLUS','MULT'/ + DATA HCAPT/'NG','NP','NA','ND','NT'/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(XSECT(NGRP),DELTA(NGRP),FMULT(NGRP),GAR1(NGRP)) +* + IF(IMPX.GT.0) WRITE(IOUT,'(/17H CHAB01: MODIFY (,A,11H) REACTION , + 1 A,12H OF ISOTOPE ,A,1H.)') AJUS(IMOD),TYPSEC,HISOT + CALL LCMLEN(IPLIB,TYPSEC,ILONG,ITYLCM) + IF((ILONG.EQ.0.).AND.(TYPSEC(:4).NE.'CAPT') + 1 .AND.(TYPSEC(:2).NE.'NU')) THEN + CALL XABORT('CHAB01: MISSING REACTION '//TYPSEC//'.') + ENDIF +*---- +* MODIFY CROSS SECTION +*---- + XSECT(:NGRP)=0.0 + GAR1(:NGRP)=0.0 + IF(TYPSEC.EQ.'NTOT0') THEN + CALL LCMGET(IPLIB,TYPSEC,XSECT) + CALL CHAB02(NGRP,IMOD,VALUE,IGM,IGP,VAL,XSECT,DELTA,FMULT) + CALL LCMPUT(IPLIB,TYPSEC,NGRP,2,XSECT) + ELSE IF(TYPSEC.EQ.'NG'.OR.TYPSEC.EQ.'NP'.OR.TYPSEC.EQ.'NA'.OR. + 1 TYPSEC.EQ.'ND'.OR.TYPSEC.EQ.'NT') THEN + +* application of the perturbation + + CALL LCMGET(IPLIB,TYPSEC,XSECT) + CALL CHAB02(NGRP,IMOD,VALUE,IGM,IGP,VAL,XSECT,DELTA,FMULT) + CALL LCMPUT(IPLIB,TYPSEC,NGRP,2,XSECT) + XSECT(:NGRP)=0.0 + CALL LCMGET(IPLIB,'NTOT0',XSECT) + DO 10 IG1=1,NGRP + XSECT(IG1)=XSECT(IG1)+DELTA(IG1) + 10 CONTINUE + CALL LCMPUT(IPLIB,'NTOT0',NGRP,2,XSECT) + ELSE IF(TYPSEC.EQ.'CAPT') THEN + IF(IMOD.NE.4) CALL XABORT('CHAB01: ONLY MULT ALLOWED.') + DO 320 ICAPT=1,NCAPT + TYPSEC=HCAPT(ICAPT) + CALL LCMLEN(IPLIB,TYPSEC,ILONG,ITYLCM) + IF(ILONG.NE.0.0) THEN +* application of the perturbation + WRITE(IOUT,*) 'CHAB01: REACTION CAPTURE INCLUDES ',TYPSEC + XSECT(:NGRP)=0.0 + CALL LCMGET(IPLIB,TYPSEC,XSECT) + CALL CHAB02(NGRP,IMOD,VALUE,IGM,IGP,VAL,XSECT,DELTA,FMULT) + CALL LCMPUT(IPLIB,TYPSEC,NGRP,2,XSECT) + XSECT(:NGRP)=0.0 + CALL LCMGET(IPLIB,'NTOT0',XSECT) + DO 310 IG1=1,NGRP + XSECT(IG1)=XSECT(IG1)+DELTA(IG1) + 310 CONTINUE + CALL LCMPUT(IPLIB,'NTOT0',NGRP,2,XSECT) + ENDIF + 320 CONTINUE + TYPSEC='CAPT' + ELSE IF(TYPSEC.EQ.'NELAS'.OR.TYPSEC.EQ.'NINEL') THEN + CALL LCMGET(IPLIB,TYPSEC,XSECT) + CALL CHAB02(NGRP,IMOD,VALUE,IGM,IGP,VAL,XSECT,DELTA,FMULT) + CALL LCMPUT(IPLIB,TYPSEC,NGRP,2,XSECT) +* +* additive modification of P0 scattering information + JMOD=3 + CALL CHAB04(IPLIB,IMPX,IRHS,NGRP,NLEG,JMOD,0,IGM,IGP,DELTA, + 1 DELTA,FMULT) +* +* multiplicative modification of transport correction + CALL LCMLEN(IPLIB,'TRANC',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + XSECT(:NGRP)=0.0 + CALL LCMGET(IPLIB,'TRANC',XSECT) + DO 20 IG1=1,NGRP + XSECT(IG1)=XSECT(IG1)*FMULT(IG1) + 20 CONTINUE + CALL LCMPUT(IPLIB,'TRANC',NGRP,2,XSECT) + ENDIF +* +* multiplicative modification of Pn scattering information with +* n>0 + DO 30 JL=1,NLEG-1 + WRITE(CM,'(I2.2)') JL + CALL LCMLEN(IPLIB,'SCAT'//CM,ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + JMOD=4 + CALL CHAB04(IPLIB,IMPX,IRHS,NGRP,NLEG,JMOD,JL,IGM,IGP, + 1 FMULT,DELTA,FMULT) + ENDIF + 30 CONTINUE +* +* additive modification of total cross section + XSECT(:NGRP)=0.0 + CALL LCMGET(IPLIB,'NTOT0',XSECT) + DO 40 IG1=1,NGRP + XSECT(IG1)=XSECT(IG1)+DELTA(IG1) + 40 CONTINUE + CALL LCMPUT(IPLIB,'NTOT0',NGRP,2,XSECT) + ELSE IF((TYPSEC.EQ.'N2N').OR.(TYPSEC.EQ.'N3N').OR. + 1 (TYPSEC.EQ.'N4N')) THEN + + CALL LCMGET(IPLIB,TYPSEC,GAR1) + CALL CHAB02(NGRP,IMOD,VALUE,IGM,IGP,VAL,GAR1,DELTA,FMULT) + CALL LCMPUT(IPLIB,TYPSEC,NGRP,2,GAR1) +* +* additive modification of total cross section + CALL LCMGET(IPLIB,'NTOT0',XSECT) + DO 50 IG1=1,NGRP + XSECT(IG1)=XSECT(IG1)+DELTA(IG1) + 50 CONTINUE + CALL LCMPUT(IPLIB,'NTOT0',NGRP,2,XSECT) +* +* additive modification of P0 scattering information + IF (TYPSEC.EQ.'N2N') THEN + DO 60 IG1=1,NGRP + DELTA(IG1)=2.0*DELTA(IG1) + 60 CONTINUE + ELSE IF (TYPSEC.EQ.'N3N') THEN + DO 70 IG1=1,NGRP + DELTA(IG1)=3.0*DELTA(IG1) + 70 CONTINUE + ELSE IF (TYPSEC.EQ.'N4N') THEN + DO 80 IG1=1,NGRP + DELTA(IG1)=4.0*DELTA(IG1) + 80 CONTINUE + ENDIF + JMOD=3 + CALL CHAB04(IPLIB,IMPX,IRHS,NGRP,NLEG,JMOD,0,IGM,IGP,DELTA, + 1 DELTA,FMULT) +* +* multiplicative modification of Pn scattering information with +* n>0 + DO 90 JL=1,NLEG-1 + WRITE(CM,'(I2.2)') JL + CALL LCMLEN(IPLIB,'SCAT'//CM,ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + JMOD=4 + CALL CHAB04(IPLIB,IMPX,IRHS,NGRP,NLEG,JMOD,JL,IGM,IGP, + 1 FMULT,DELTA,FMULT) + ENDIF + 90 CONTINUE + ELSE IF((TYPSEC(:4).EQ.'SIGS').OR.(TYPSEC(:4).EQ.'SCAT')) THEN + READ(TYPSEC(5:6),'(I2)') IL +* additive or multiplicative modification of Pn scattering +* information + XSECT(:NGRP)=0.0 + IF(IMOD.EQ.1) THEN + DO 100 IG=IGM,IGP + XSECT(IG)=VAL(IG) + 100 CONTINUE + ELSE + DO 110 IG=IGM,IGP + XSECT(IG)=VALUE + 110 CONTINUE + ENDIF + CALL CHAB04(IPLIB,IMPX,IRHS,NGRP,NLEG,IMOD,IL,IGM,IGP,XSECT, + 1 DELTA,FMULT) +* +* multiplicative modification of transport correction + CALL LCMLEN(IPLIB,'TRANC',ILONG,ITYLCM) + IF((IL.LE.1).AND.(ILONG.GT.0)) THEN + XSECT(:NGRP)=0.0 + CALL LCMGET(IPLIB,'TRANC',XSECT) + DO 120 IG1=1,NGRP + XSECT(IG1)=XSECT(IG1)*FMULT(IG1) + 120 CONTINUE + CALL LCMPUT(IPLIB,'TRANC',NGRP,2,XSECT) + ENDIF +* +* additive modification of total cross-section + IF(IL.EQ.0) THEN + XSECT(:NGRP)=0.0 + CALL LCMGET(IPLIB,'NTOT0',XSECT) + DO 130 IG1=1,NGRP + XSECT(IG1)=XSECT(IG1)+DELTA(IG1) + 130 CONTINUE + CALL LCMPUT(IPLIB,'NTOT0',NGRP,2,XSECT) + ENDIF +* +* multiplicative modification of Pn scattering information with +* n>IL + DO 140 JL=IL+1,NLEG-1 + WRITE(CM,'(I2.2)') JL + CALL LCMLEN(IPLIB,'SCAT'//CM,ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + JMOD=4 + CALL CHAB04(IPLIB,IMPX,IRHS,NGRP,NLEG,JMOD,JL,IGM,IGP, + 1 FMULT,DELTA,FMULT) + ENDIF + 140 CONTINUE + ELSE IF((TYPSEC.EQ.'NFTOT').OR.(TYPSEC.EQ.'NUSIGF')) THEN + CALL LCMGET(IPLIB,'NFTOT',GAR1) + CALL LCMGET(IPLIB,'NUSIGF',XSECT) + DO 180 IG1=1,NGRP + IF(GAR1(IG1).NE.0.0) THEN + XSECT(IG1)=XSECT(IG1)/GAR1(IG1) + ENDIF + 180 CONTINUE + CALL CHAB02(NGRP,IMOD,VALUE,IGM,IGP,VAL,GAR1,DELTA,FMULT) + DO 190 IG1=1,NGRP + XSECT(IG1)=GAR1(IG1)*XSECT(IG1) + 190 CONTINUE + CALL LCMPUT(IPLIB,'NFTOT',NGRP,2,GAR1) + CALL LCMPUT(IPLIB,'NUSIGF',NGRP,2,XSECT) + XSECT(:NGRP)=0.0 + CALL LCMGET(IPLIB,'NTOT0',XSECT) + DO 200 IG1=1,NGRP + XSECT(IG1)=XSECT(IG1)+DELTA(IG1) + 200 CONTINUE + CALL LCMPUT(IPLIB,'NTOT0',NGRP,2,XSECT) + ELSE IF(TYPSEC.EQ.'NU') THEN + CALL LCMGET(IPLIB,'NFTOT',GAR1) + CALL LCMGET(IPLIB,'NUSIGF',XSECT) + DO 210 IG1=1,NGRP + IF(GAR1(IG1).NE.0.0) THEN + XSECT(IG1)=XSECT(IG1)/GAR1(IG1) + ENDIF + 210 CONTINUE + CALL CHAB02(NGRP,IMOD,VALUE,IGM,IGP,VAL,XSECT,DELTA,FMULT) + DO 220 IG1=1,NGRP + XSECT(IG1)=GAR1(IG1)*XSECT(IG1) + 220 CONTINUE + CALL LCMPUT(IPLIB,'NUSIGF',NGRP,2,XSECT) + ELSE IF(TYPSEC.EQ.'CHI') THEN + CALL LCMGET(IPLIB,TYPSEC,GAR1) + CALL CHAB02(NGRP,IMOD,VALUE,IGM,IGP,VAL,GAR1,DELTA,FMULT) + SUM=0.0 + DO 230 IG1=1,NGRP + SUM=SUM+GAR1(IG1) + 230 CONTINUE + DO 240 IG1=1,NGRP + GAR1(IG1)=GAR1(IG1)/SUM + 240 CONTINUE + CALL LCMPUT(IPLIB,TYPSEC,NGRP,2,GAR1) + ELSE + CALL XABORT('CHAB01: UNKNOWN REACTION '//TYPSEC//'.') + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GAR1,FMULT,DELTA,XSECT) + RETURN + END diff --git a/Dragon/src/CHAB02.f b/Dragon/src/CHAB02.f new file mode 100644 index 0000000..579c86c --- /dev/null +++ b/Dragon/src/CHAB02.f @@ -0,0 +1,84 @@ +*DECK CHAB02 + SUBROUTINE CHAB02(NGRP,IMOD,VALUE,IGM,IGP,VAL,GAR1,DELTA,FMULT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Modify an array of cross section values. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NGRP number of energy groups. +* IMOD type of modification: =1: complete replacement; =2: replace +* specific values by VALUE; =3: increase by VALUE; =4: multiply +* by VALUE. +* VALUE value used in modification operation. +* IGM first energy group to modify. +* IGP last energy group to modify. +* VAL array of values used if IMOD=1. +* +*Parameters: input/output +* GAR1 cross section array to modify on input and +* mofified cross section array at output. +* +*Parameters: output +* DELTA difference in cross section value. +* FMULT modification factors. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NGRP,IMOD,IGM,IGP + REAL VALUE,VAL(NGRP),GAR1(NGRP),DELTA(NGRP),FMULT(NGRP) +* + DELTA(:NGRP)=0.0 + FMULT(:NGRP)=1.0 + IF(IMOD.EQ.1) THEN + DO 10 IG=IGM,IGP + IF(GAR1(IG).EQ.0.0) THEN + FMULT(IG)=1.0 + ELSE + FMULT(IG)=VAL(IG)/GAR1(IG) + ENDIF + DELTA(IG)=VAL(IG)-GAR1(IG) + GAR1(IG)=VAL(IG) + 10 CONTINUE + ELSE IF(IMOD.EQ.2) THEN + DO 20 IG=IGM,IGP + IF(GAR1(IG).EQ.0.0) THEN + FMULT(IG)=1.0 + ELSE + FMULT(IG)=VALUE/GAR1(IG) + ENDIF + DELTA(IG)=VALUE-GAR1(IG) + GAR1(IG)=VALUE + 20 CONTINUE + ELSE IF(IMOD.EQ.3) THEN + DO 30 IG=IGM,IGP + IF(GAR1(IG).EQ.0.0) THEN + FMULT(IG)=1.0 + ELSE + FMULT(IG)=1.0+VALUE/GAR1(IG) + ENDIF + DELTA(IG)=VALUE + GAR1(IG)=GAR1(IG)+VALUE + 30 CONTINUE + ELSE IF(IMOD.EQ.4) THEN + DO 40 IG=IGM,IGP + FMULT(IG)=VALUE + DELTA(IG)=GAR1(IG)*(VALUE-1.0) + GAR1(IG)=GAR1(IG)*VALUE + 40 CONTINUE + ENDIF + RETURN + END diff --git a/Dragon/src/CHAB03.f b/Dragon/src/CHAB03.f new file mode 100644 index 0000000..e26368e --- /dev/null +++ b/Dragon/src/CHAB03.f @@ -0,0 +1,115 @@ +*DECK CHAB03 + SUBROUTINE CHAB03(IPLIB,IMPX,NGRP,NBIN,IMOD,TYPSEC,HISOT,VALUE, + 1 IGM,IGP,NFS,VAL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Modify a specific isotope and Autolib reaction in a Draglib. +* +*Copyright: +* Copyright (C) 2011 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB LCM pointer to the Draglib. +* IMPX print index. +* NGRP number of coarse energy groups. +* NBIN number of fine energy groups. +* IMOD type of modification: =1: complete replacement; =2: replace +* specific values by VALUE; =3: increase by VALUE; =4: multiply +* by VALUE. +* TYPSEC name of reaction to modify. +* HISOT name of isotope to modify. +* VALUE value used in modification operation. +* IGM first energy group to modify. +* IGP last energy group to modify. +* NFS number of fine groups per coarse group. +* VAL array of values used if IMOD=1. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + INTEGER IMPX,NGRP,NBIN,IMOD,IGM,IGP,NFS(NGRP) + CHARACTER TYPSEC*8,HISOT*12 + REAL VALUE,VAL(NGRP) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IOUT=6) + CHARACTER AJUS(4)*4 + REAL, ALLOCATABLE, DIMENSION(:) :: GAR1,DELTA,FMULT,VALB +*---- +* DATA STATEMENTS +*---- + DATA AJUS/'VALE','CONS','PLUS','MULT'/ +*---- +* CORRESPONDENCE BETWEEN BIN AND COARSE ENERGT GROUPS +*---- + IGMBIN=NBIN+1 + IGPBIN=0 + IBIN=0 + DO 10 IG=1,NGRP + IF(IG.EQ.IGM) IGMBIN=IBIN+1 + IBIN=IBIN+NFS(IG) + IF(IG.EQ.IGP) IGPBIN=IBIN + 10 CONTINUE + IF(IGPBIN.LT.IGMBIN) RETURN +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(GAR1(NBIN),DELTA(NBIN),FMULT(NBIN),VALB(NBIN)) +* + IF(IMOD.EQ.1) THEN + IBIN=0 + DO 25 IG=1,NGRP + DO 20 J=1,NFS(IG) + IBIN=IBIN+1 + VALB(IBIN)=VAL(IG) + 20 CONTINUE + 25 CONTINUE + ENDIF +*---- +* APPLY CORRECTION +*---- + IF(TYPSEC.EQ.'NTOT0') THEN + CALL LCMLEN(IPLIB,'BIN-NTOT0',ILONG,ITYLCM) + IF(ILONG.EQ.NBIN) THEN + IF(IMPX.GT.0) WRITE(IOUT,'(/17H CHAB03: MODIFY (,A,5H) BIN, + 1 27H-NTOT0 REACTION OF ISOTOPE ,A,1H.)') AJUS(IMOD),HISOT + CALL LCMGET(IPLIB,'BIN-NTOT0',GAR1) + CALL CHAB02(NBIN,IMOD,VALUE,IGMBIN,IGPBIN,VALB,GAR1,DELTA, + 1 FMULT) + CALL LCMPUT(IPLIB,'BIN-NTOT0',NBIN,2,GAR1) + ENDIF + ELSE IF((TYPSEC(:4).EQ.'SIGS').OR.(TYPSEC(:4).EQ.'SCAT')) THEN + CALL LCMLEN(IPLIB,'BIN-SIGS00',ILONG,ITYLCM) + IF(ILONG.EQ.NBIN) THEN + IF(IMPX.GT.0) WRITE(IOUT,'(/17H CHAB03: MODIFY (,A,5H) BIN, + 1 28H-SIGS00 REACTION OF ISOTOPE ,A,1H.)') AJUS(IMOD),HISOT + CALL LCMGET(IPLIB,'BIN-SIGS00',GAR1) + CALL CHAB02(NBIN,IMOD,VALUE,IGMBIN,IGPBIN,VALB,GAR1,DELTA, + 1 FMULT) + CALL LCMPUT(IPLIB,'BIN-SIGS00',NBIN,2,GAR1) + CALL LCMGET(IPLIB,'BIN-NTOT0',GAR1) + DO 30 IBIN=1,NBIN + GAR1(IBIN)=GAR1(IBIN)+DELTA(IBIN) + 30 CONTINUE + CALL LCMPUT(IPLIB,'BIN-NTOT0',NBIN,2,GAR1) + ENDIF + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(VALB,FMULT,DELTA,GAR1) + RETURN + END diff --git a/Dragon/src/CHAB04.f b/Dragon/src/CHAB04.f new file mode 100644 index 0000000..1d85bb5 --- /dev/null +++ b/Dragon/src/CHAB04.f @@ -0,0 +1,151 @@ +*DECK CHAB04 + SUBROUTINE CHAB04(IPLIB,IMPX,IRHS,NGRP,NLEG,IMOD,IL,IGM,IGP, + 1 VALUE,DELTA,FMULT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Modify scattering information in a Microlib or in a Draglib. +* +*Copyright: +* Copyright (C) 2011 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB LCM pointer to the Microlib or Draglib. +* IMPX print index. +* IRHS type of IPLIB: =1: Microlib; =2: Draglib. +* NGRP number of energy groups. +* NLEG max Legendre order of scattering anisotropy (1=isotropic, +* etc.). +* IMOD type of modification: =1,2: replace the value; =3: increase by +* VALUE; =4: multiply by VALUE. +* IL Legendre order under consideration. +* IGM first energy group to modify. +* IGP last energy group to modify. +* VALUE value array used in scattering modification operation. +* +*Parameters: output +* DELTA difference in scattering cross section value. +* FMULT multiplicative modification factors. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + INTEGER IMPX,IRHS,NGRP,NLEG,IMOD,IL,IGM,IGP + REAL VALUE(NGRP),DELTA(NGRP),FMULT(NGRP) +*---- +* LOCAL VARIABLES +*---- + CHARACTER CM*2 + INTEGER, ALLOCATABLE, DIMENSION(:) :: NJJ,IJJ,ITYPRO + REAL, ALLOCATABLE, DIMENSION(:) :: GAR1,XSSCM + REAL, ALLOCATABLE, DIMENSION(:,:) :: GAR2 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NJJ(NGRP),IJJ(NGRP)) + ALLOCATE(GAR1(NGRP),GAR2(NGRP,NGRP)) +* + DELTA(:NGRP)=0.0 + FMULT(:NGRP)=1.0 +*---- +* RECOVER SCATTERING INFORMATION +*---- + IF(IL.GE.NLEG) CALL XABORT('CHAB04: LEGENDRE INDEX OVERFLOW.') + IF(IRHS.EQ.1) THEN + ALLOCATE(ITYPRO(NLEG)) + CALL XDRLGS(IPLIB,-1,IMPX,IL,IL,1,NGRP,GAR1,GAR2,ITYPRO) + DEALLOCATE(ITYPRO) + ELSE IF(IRHS.EQ.2) THEN + ALLOCATE(XSSCM(NGRP*NGRP)) + WRITE (CM,'(I2.2)') IL + GAR1(:NGRP)=0.0 + GAR2(:NGRP,:NGRP)=0.0 + CALL LCMGET(IPLIB,'NJJS'//CM,NJJ) + CALL LCMGET(IPLIB,'IJJS'//CM,IJJ) + LENGT=0 + DO 10 I=1,NGRP + LENGT=LENGT+NJJ(I) + 10 CONTINUE + XSSCM(:LENGT)=0.0 + CALL LCMGET(IPLIB,'SCAT'//CM,XSSCM) + IGAR=0 + DO 25 IG2=1,NGRP + DO 20 IG1=IJJ(IG2),IJJ(IG2)-NJJ(IG2)+1,-1 + IGAR=IGAR+1 + GAR2(IG2,IG1)=XSSCM(IGAR) + GAR1(IG1)=GAR1(IG1)+GAR2(IG2,IG1) + 20 CONTINUE + 25 CONTINUE + DEALLOCATE(XSSCM) + ENDIF +*---- +* MODIFY SCATTERING INFORMATION +*---- + DO 45 IG2=IGM,IGP + IF(GAR1(IG2).NE.0.0) THEN + DO 30 IG1=1,NGRP + GAR2(IG1,IG2)=GAR2(IG1,IG2)/GAR1(IG2) + 30 CONTINUE + ENDIF + IF((IMOD.EQ.1).OR.(IMOD.EQ.2)) THEN + IF(GAR1(IG2).EQ.0.0) THEN + FMULT(IG2)=1.0 + ELSE + FMULT(IG2)=VALUE(IG2)/GAR1(IG2) + ENDIF + DELTA(IG2)=VALUE(IG2)-GAR1(IG2) + GAR1(IG2)=VALUE(IG2) + ELSE IF(IMOD.EQ.3) THEN + IF(GAR1(IG2).EQ.0.0) THEN + FMULT(IG2)=1.0 + ELSE + FMULT(IG2)=1.0+VALUE(IG2)/GAR1(IG2) + ENDIF + DELTA(IG2)=VALUE(IG2) + GAR1(IG2)=GAR1(IG2)+VALUE(IG2) + ELSE IF(IMOD.EQ.4) THEN + FMULT(IG2)=VALUE(IG2) + DELTA(IG2)=GAR1(IG2)*(VALUE(IG2)-1.0) + GAR1(IG2)=GAR1(IG2)*VALUE(IG2) + ENDIF + DO 40 IG1=1,NGRP + GAR2(IG1,IG2)=GAR2(IG1,IG2)*GAR1(IG2) + 40 CONTINUE + 45 CONTINUE +*---- +* SAVE SCATTERING INFORMATION +*---- + IF(IRHS.EQ.1) THEN + ALLOCATE(ITYPRO(NLEG)) + CALL XDRLGS(IPLIB,1,IMPX,IL,IL,1,NGRP,GAR1,GAR2,ITYPRO) + DEALLOCATE(ITYPRO) + ELSE IF(IRHS.EQ.2) THEN + ALLOCATE(XSSCM(NGRP*NGRP)) + IGAR=0 + DO 55 IG2=1,NGRP + DO 50 IG1=IJJ(IG2),IJJ(IG2)-NJJ(IG2)+1,-1 + IGAR=IGAR+1 + XSSCM(IGAR)=GAR2(IG2,IG1) + 50 CONTINUE + 55 CONTINUE + CALL LCMPUT(IPLIB,'SCAT'//CM,IGAR,2,XSSCM) + DEALLOCATE(XSSCM) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GAR2,GAR1) + DEALLOCATE(IJJ,NJJ) + RETURN + END diff --git a/Dragon/src/CLM.f b/Dragon/src/CLM.f new file mode 100644 index 0000000..704baae --- /dev/null +++ b/Dragon/src/CLM.f @@ -0,0 +1,229 @@ +*DECK CLM + SUBROUTINE CLM(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Combine liquid fuel mixtures from different fuel channels +* and redistribute in channels. +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): create or modification type(L_LIBRARY) +* HENTRY(2): optional read-only type(L_MACROLIB) used to +* initialize a new lattice code library. +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +* Comment: +* All the mixture must contain the same isotopes with possibly +* different concentrations. +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPLIB,IPTRK + INTEGER IOUT,NSTATE,ILCMUP,ILCMDN + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NSTATE=40,ILCMUP=1,ILCMDN=2,NAMSBR='CLM ') +*---- +* LOCAL PARAMETERS +*---- + INTEGER NBSL,NBST,IEN,ISTATE(NSTATE),NBMIX,NBISO,NBREG,IREG, + > IPRINT,NCLM,ICLM,ISO,JSO,NGRO,ITSTMP + INTEGER MIXI,MIXJ + REAL VOLTOT,TMPDAY(3) + CHARACTER HSIGN*12 + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDCLM,ISOMIX,MATCOD + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISONRF,IACT + REAL, ALLOCATABLE, DIMENSION(:) :: VOLUME,DENISO,VOLMIX, + > DENRD + LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASK,MASKL +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY .LT. 2) CALL XABORT(NAMSBR// + >': At least 2 parameters expected.') + IF(IENTRY(1) .NE. 1 .AND. + > IENTRY(1) .NE. 2) CALL XABORT(NAMSBR// + >': LCM OBJECT OR XSM FILE EXPECTED AT LHS.') + IF(JENTRY(1) .NE. 1) CALL XABORT(NAMSBR//': ENTRY' + 1 //' IN MODIFICATION MODE EXPECTED.') + IPLIB=KENTRY(1) +*---- +* Find IPLIB and IPTRK structures +*---- + IPRINT=1 + NBSL=0 + NBST=0 + DO IEN=1,NENTRY + HSIGN=' ' + IF(NBSL .EQ. 0) THEN +*---- +* Find Library to modify +*---- + IF(IENTRY(IEN) .LE. 2 .AND. JENTRY(IEN) .EQ. 1) THEN + CALL LCMGTC(KENTRY(IEN),'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_LIBRARY') THEN + IPLIB=KENTRY(IEN) + WRITE(IOUT,6000) HENTRY(IEN) + NBSL=1 + GO TO 100 + ENDIF + ENDIF + ENDIF + IF(NBST .EQ. 0) THEN +*---- +* Find Tracking for volume of mixtures to combine +*---- + IF(IENTRY(IEN) .LE. 2 .AND. JENTRY(IEN) .EQ. 2) THEN + CALL LCMGTC(KENTRY(IEN),'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_TRACK') THEN + IPTRK=KENTRY(IEN) + WRITE(IOUT,6001) HENTRY(IEN) + NBST=1 + GO TO 100 + ENDIF + ENDIF + ENDIF + 100 CONTINUE + IF(NBSL+NBST.EQ.2) GO TO 105 + ENDDO + 105 CONTINUE +*---- +* Get information about mixtures on IPLIB +*---- + CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) + NBMIX=ISTATE(1) + NBISO=ISTATE(2) + NGRO=ISTATE(3) + ALLOCATE(ISONRF(3,NBISO),ISOMIX(NBISO),DENISO(NBISO)) + CALL LCMGET(IPLIB,'ISOTOPERNAME',ISONRF) + CALL LCMGET(IPLIB,'ISOTOPESMIX ',ISOMIX) + CALL LCMGET(IPLIB,'ISOTOPESDENS',DENISO) + ALLOCATE(IDCLM(NBMIX)) + ALLOCATE(IACT(3,NBISO),DENRD(NBISO)) +*---- +* Read proceessing option +*---- + CALL CLMGET(IPRINT,NBMIX,NBISO,ISONRF,ISOMIX, + > NCLM,IDCLM,IACT,DENRD) +*---- +* Get information about volumes for mixtures on IPTRK +*---- + ALLOCATE(VOLMIX(NCLM)) + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + NBREG=ISTATE(1) + ALLOCATE(MATCOD(NBREG),VOLUME(NBREG)) + CALL LCMGET(IPTRK,'MATCOD ',MATCOD) + CALL LCMGET(IPTRK,'VOLUME ',VOLUME) +*---- +* Find volume of each mixtures to combine and total volume +*---- + VOLTOT=0.0 + DO ICLM=1,NCLM + VOLMIX(ICLM)=0.0 + DO IREG=1,NBREG + IF(IDCLM(ICLM) .EQ. MATCOD(IREG)) + > VOLMIX(ICLM)=VOLMIX(ICLM)+VOLUME(IREG) + ENDDO + VOLTOT=VOLTOT+VOLMIX(ICLM) + ENDDO + DEALLOCATE(MATCOD,VOLUME) +*---- +* Find isotopes associated with first mixture to combine +* with wame isotope from other mixtures +*---- + DO ISO=1,NBISO + MIXI=IACT(1,ISO) + IF(MIXI.EQ.1) THEN + DENISO(ISO)=DENISO(ISO)*VOLMIX(MIXI) + DO JSO=1,NBISO + MIXJ=IACT(1,JSO) + IF(MIXJ.GT.1 .AND. IACT(2,JSO).EQ.ISO) THEN + DENISO(ISO)=DENISO(ISO)+DENISO(JSO)*VOLMIX(MIXJ) + ENDIF + ENDDO + DENISO(ISO)=DENISO(ISO)/VOLTOT + ENDIF + ENDDO + DEALLOCATE(VOLMIX) +*---- +* correct mixture according to SETI or ADDI +*---- + DO ISO=1,NBISO + MIXI=IACT(1,ISO) + IF(MIXI.EQ.1) THEN + IF(IACT(3,ISO).EQ. -2) THEN + DENISO(ISO)=DENRD(ISO) + ELSE IF(IACT(3,ISO).EQ. -1) THEN + DENISO(ISO)=DENISO(ISO)+DENRD(ISO) + ELSE IF(IACT(3,ISO).EQ. 1) THEN + DENISO(ISO)=DENISO(ISO)*(1.0+DENRD(ISO)) + ELSE IF(IACT(3,ISO).EQ. 2) THEN + DENISO(ISO)=DENISO(ISO)*DENRD(ISO) + ENDIF + DO JSO=1,NBISO + MIXJ=IACT(1,JSO) + IF(MIXJ.GT.1 .AND. IACT(2,JSO).EQ.ISO) THEN + DENISO(JSO)=DENISO(ISO) + ENDIF + ENDDO + ENDIF + ENDDO + DEALLOCATE(DENRD,IACT) +*---- +* Replace new densities in adequate location in DESISO vector +*---- + ALLOCATE(MASK(NBMIX),MASKL(NGRO)) + MASKL(:NBMIX)=.FALSE. + MASKL(:NGRO)=.TRUE. + DO ICLM=1,NCLM + MASK(IDCLM(ICLM))=.TRUE. + ENDDO + DEALLOCATE(IDCLM) + CALL LCMPUT(IPLIB,'ISOTOPESDENS',NBISO,2,DENISO) +*---- +* Reset macrolib +*---- + ITSTMP=0 + TMPDAY(1)=0.0 + TMPDAY(2)=0.0 + TMPDAY(3)=0.0 + CALL LCMGET(IPLIB,'ISOTOPESUSED',ISONRF) + CALL LIBMIX(IPLIB,NBMIX,NGRO,NBISO,ISONRF,ISOMIX,DENISO,MASK, + > MASKL,ITSTMP,TMPDAY) + DEALLOCATE(MASKL,MASK) + DEALLOCATE(ISONRF,ISOMIX,DENISO) + RETURN +*---- +* FORMATS +*---- + 6000 FORMAT('LIBRARY is identified as : ',A12) + 6001 FORMAT('TRACKING is identified as : ',A12) + END diff --git a/Dragon/src/CLMGET.f b/Dragon/src/CLMGET.f new file mode 100644 index 0000000..237400e --- /dev/null +++ b/Dragon/src/CLMGET.f @@ -0,0 +1,200 @@ +*DECK CLMGET + SUBROUTINE CLMGET(IPRINT,NBMIX,NBISO,ISONRF,ISOMIX, + > NCLM ,IDCLM,IACT ,DENRD ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read CLM module options. +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPRINT print index, +* NBMIX maximum number of mixtures. +* NBISO maximum number of isotopes. +* ISONRF reference names of isotopes. +* ISOMIX mixture associated with each isotope. +* +*Parameters: output +* NCLM number of liquid mixtures to combine. +* IDCLM liquid mixtures indices to combine. +* IACT isotope identifier (IACT(1,ISO)) for mixture considered, +* reference isotope (IACT(2,ISO)) +* and action on each isotope for which concentration +* is modified with: IACT(3,ISO)=0 no change; +* IACT(3,ISO)=-1 for ADDI ABS; IACT(3,ISO)=1 for ADDI REL; +* IACT(3,ISO)=-2 for SETI ABS; IACT(3,ISO)=2 for SETI REL. +* DENRD isotope concentration or relative concentration. +* +*Comments: +* Input data is of the form: +* [ EDIT iprint ] +* MIXCLM (IDCLM(ii),ii=1,NCLM) +* [ { ADDI | SETI } { ABS | REL } (isot(ii) dens(ii),ii=1,niso)] +*----------------------------------------------------------------------- +* + IMPLICIT NONE + INTEGER IPRINT,NBMIX,NBISO,ISONRF(3,NBISO),ISOMIX(NBISO), + > NCLM,IDCLM(NBMIX),IACT(3,NBISO) + REAL DENRD(NBISO) + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='CLMGET') +*---- +* REDGET variables +*---- + INTEGER ITYPLU,INTLIR + CHARACTER CARLIR*8 + REAL REALIR + DOUBLE PRECISION DBLLIR +*---- +* LOCAL variables +*---- + INTEGER IMIX,ISO,JSO,JACT,KSO,INAM(2) +*---- +* INITIALIZE MIXMER +*---- + IDCLM(:NBMIX)=0 + IACT(:3,:NBISO)=0 + DENRD(:NBISO)=0.0 +*---- +* READ OPTION NAME +*---- + 10 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + 20 IF(ITYPLU.EQ.10) GO TO 100 + IF(ITYPLU.NE.3) CALL XABORT(NAMSBR//': READ ERROR - '// + >'Character variable expacted') + IF(CARLIR.EQ.';') GO TO 100 + IF(CARLIR.EQ.'EDIT') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT(NAMSBR//': READ ERROR -'// + > 'Integer variable expacted') + IPRINT=INTLIR + ELSE IF(CARLIR.EQ.'MIXCLM') THEN + NCLM=0 + DO IMIX=1,NBMIX + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) THEN + DO ISO=1,NBISO + WRITE(IOUT,'(2A4,2(5X,I10))') ISONRF(1,ISO),ISONRF(2,ISO), + > IACT(1,ISO),IACT(2,ISO) + ENDDO + GO TO 20 + ENDIF + NCLM=NCLM+1 + IF(INTLIR .LE. 0 .OR. INTLIR .GT. NBMIX) CALL XABORT(NAMSBR// + > ': READ ERROR - Mixture < 0 or > NBMIX') + IDCLM(NCLM)=INTLIR +*---- +* Associate isotopes mixture number to first mixture to process +*---- + IF(NCLM.EQ.1) THEN + DO ISO=1,NBISO + IF(ISOMIX(ISO).EQ.INTLIR) THEN + IACT(1,ISO)=NCLM + ENDIF + ENDDO + ELSE +*---- +* Test additional mixture number for coherent isotopic contents +*---- + DO ISO=1,NBISO + IF(ISOMIX(ISO).EQ.INTLIR) THEN + DO JSO=1,NBISO + IF(IACT(1,JSO).EQ.1) THEN + IF(ISONRF(1,ISO).EQ.ISONRF(1,JSO) .AND. + > ISONRF(2,ISO).EQ.ISONRF(2,JSO)) THEN + IACT(1,ISO)=NCLM + IACT(2,ISO)=JSO + GO TO 110 + ENDIF + ENDIF + ENDDO + CALL XABORT(NAMSBR// + > ': Mixtures do not have the same isotopic contents') + 110 CONTINUE + ENDIF + ENDDO + ENDIF + ENDDO + ELSE IF(CARLIR.EQ.'ADDI' .OR. CARLIR.EQ.'SETI') THEN + JACT=1 + IF(CARLIR.EQ.'SETI') JACT=2 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.3) THEN + IF(CARLIR.EQ.'ABS') THEN + JACT=-JACT + ELSE IF (CARLIR.NE.'REL') THEN + CALL XABORT(NAMSBR// + > ': READ ERROR - Invalid ADDI or SETI option.'// + > ' Only REL or ABS valid') + ENDIF + ELSE + CALL XABORT(NAMSBR// + > ': READ ERROR - No ADDI or SETI option provided') + ENDIF +*---- +* Read all isotopes for SETI and ADDI. +*---- + DO ISO=1,NBISO + KSO=0 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.3) THEN +*---- +* Test if valid isotopes associated to MIXCLM +*---- + READ(CARLIR,'(2A4)') INAM(1),INAM(2) + DO JSO=1,NBISO +*---- +* Only need to check first mixture +*---- + IF(IACT(1,JSO).EQ.1) THEN + IF(INAM(1).EQ.ISONRF(1,JSO) .AND. + > INAM(2).EQ.ISONRF(2,JSO)) THEN + IACT(3,JSO)=JACT + KSO=JSO + GO TO 120 + ENDIF + ENDIF + ENDDO + GO TO 20 + ELSE + CALL XABORT(NAMSBR// + > ': READ ERROR - Invalid isotope name') + ENDIF + 120 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.2) THEN + DENRD(KSO)=REALIR + ELSE + CALL XABORT(NAMSBR// + > ': READ ERROR - Invalid isotopic density (REL or ABS)') + ENDIF + ENDDO + ELSE + CALL XABORT(NAMSBR//': READ ERROR - '// + > 'Illegal keyword') + ENDIF + GO TO 10 + 100 CONTINUE +*---- +* RETURN +*---- +*---- +* Print if required +*---- + DO ISO=1,NBISO + WRITE(IOUT,'(2A4,3(5X,I5),1P,E20.9)') + > ISONRF(1,ISO),ISONRF(2,ISO), + > IACT(1,ISO),IACT(2,ISO),IACT(3,ISO),DENRD(ISO) + ENDDO + RETURN + END diff --git a/Dragon/src/COMACR.f b/Dragon/src/COMACR.f new file mode 100644 index 0000000..bc5791b --- /dev/null +++ b/Dragon/src/COMACR.f @@ -0,0 +1,276 @@ +*DECK COMACR + SUBROUTINE COMACR(IPEDIT,IMPX,IPCPO,NG,NMIL,NED,NL,NF,NDEL,NW, + 1 IMIL,FNORM,NSPH,EIGENK,EIGINF,B2,VOLUME,ENER,DELT,HVECT,ZLAMB) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transform a Macrolib in IPEDIT format into a Microlib with IPCPO +* format. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPEDIT pointer to the edition object (L_EDIT signature). +* IMPX print parameter. +* IPCPO pointer to the multicompo isotope directory. +* NG number of energy groups. +* NMIL number of homogenized mixtures. +* NED number of extra edits. +* NL number of Legendre orders. +* NF number of fissile isotopes. +* NDEL number of precursor groups. +* NW type of weighting for P1 cross section info (=0: P0 ; =1: P1). +* IMIL homogenized mixture index we want to recover. +* FNORM flux normalization factor. +* NSPH flag for SPH content (=0 no SPH, =1 NSPH included in COMPO). +* +*Parameters: output +* EIGENK effective multiplication factor. +* EIGINF infinite multiplication factor. +* B2 buckling. +* VOLUME volume of homogenized mixture IMIL. +* ENER energy limits. +* DELT lethargy increments. +* HVECT additional edit names. +* ZLAMB delayed precursor decay constants. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPEDIT,IPCPO + INTEGER IMPX,NG,NMIL,NED,NL,NDEL,NW,IMIL,NSPH,HVECT(2,NED+1),NF + REAL FNORM,EIGENK,EIGINF,B2,VOLUME,ENER(NG+1),DELT(NG), + 1 ZLAMB(NDEL) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + TYPE(C_PTR) JPEDIT,KPEDIT + INTEGER IPAR(NSTATE) + CHARACTER TEXT8*8,TEXT12*12,CM*2 + LOGICAL LHF + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS,ITYPR + REAL, ALLOCATABLE, DIMENSION(:) :: GAR3 + REAL, ALLOCATABLE, DIMENSION(:,:) :: GAR1 + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: GAR2 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IJJ(NMIL),NJJ(NMIL),IPOS(NMIL),ITYPR(NL)) + ALLOCATE(GAR1(NG,10+2*NW+2*NDEL+NED+NL),GAR2(NG,NG,NL), + 1 GAR3(NMIL*NG)) +* + CALL LCMGET(IPEDIT,'STATE-VECTOR',IPAR) + IF(NG.NE.IPAR(1)) THEN + CALL XABORT('COMACR: INVALID NUMBER OF GROUPS IN MACROLIB.') + ELSE IF(NMIL.NE.IPAR(2)) THEN + CALL XABORT('COMACR: INVALID NUMBER OF MIXTURES IN MACROLIB.') + ELSE IF(NL.NE.IPAR(3)) THEN + CALL XABORT('COMACR: INVALID NUMBER OF MIXTURES IN MACROLIB.') + ELSE IF(NF.GT.1) THEN + CALL XABORT('COMACR: MULTIPLE FISSION SPECTRA NOT SUPPORTED.') + ELSE IF(NED.NE.IPAR(5)) THEN + CALL XABORT('COMACR: INVALID NUMBER OF EDITS IN MACROLIB.') + ELSE IF(NDEL.NE.IPAR(7)) THEN + CALL XABORT('COMACR: INVALID NUMBER OF PRECURSOR GROUPS IN MA' + 1 //'CROLIB.') + ELSE IF(NW.NE.IPAR(10)) THEN + CALL XABORT('COMACR: INVALID P1 WEIGHTING IN MACROLIB.') + ENDIF + NLEAK=IPAR(9) + LHF=.FALSE. + CALL LCMLEN(IPEDIT,'K-EFFECTIVE',LENGT,ITYLCM) + IF((NF.GT.0).AND.(LENGT.EQ.1)) THEN + CALL LCMGET(IPEDIT,'K-EFFECTIVE',EIGENK) + ELSE + EIGENK=0.0 + ENDIF + CALL LCMLEN(IPEDIT,'K-INFINITY',LENGT,ITYLCM) + IF(LENGT.EQ.1) THEN + CALL LCMGET(IPEDIT,'K-INFINITY',EIGINF) + ELSE + EIGINF=EIGENK + ENDIF + CALL LCMLEN(IPEDIT,'B2 B1HOM',LENGT,ITYLCM) + IF(LENGT.EQ.1) THEN + CALL LCMGET(IPEDIT,'B2 B1HOM',B2) + ELSE + B2=0.0 + ENDIF + CALL LCMGET(IPEDIT,'ENERGY',ENER) + CALL LCMLEN(IPEDIT,'DELTAU',LENGT,ITYLCM) + IF(LENGT.EQ.NG) THEN + CALL LCMGET(IPEDIT,'DELTAU',DELT) + ELSE IF(LENGT.EQ.0) THEN + IF(ENER(NG+1).EQ.0.0) ENER(NG+1)=1.0E-5 + DO 10 J=1,NG + DELT(J)=LOG(ENER(J)/ENER(J+1)) + 10 CONTINUE + ENDIF + IF(NED.GT.0) CALL LCMGET(IPEDIT,'ADDXSNAME-P0',HVECT) + IF(NDEL.GT.0) CALL LCMGET(IPEDIT,'LAMBDA-D',ZLAMB) + IF(NSPH.EQ.1) THEN + TEXT8='NSPH ' + READ(TEXT8,'(2A4)') HVECT(1,NED+1),HVECT(2,NED+1) + ENDIF + CALL LCMLEN(IPEDIT,'VOLUME',LEVOL,ITYLCM) + IF(LEVOL.GT.0) THEN + CALL LCMGET(IPEDIT,'VOLUME',GAR3) + VOLUME=GAR3(IMIL) + ENDIF + JPEDIT=LCMGID(IPEDIT,'GROUP') + GAR2(:NG,:NG,:NL)=0.0 + DO 125 IG=1,NG + KPEDIT=LCMGIL(JPEDIT,IG) + IF(LEVOL.GT.0) THEN + CALL LCMGET(KPEDIT,'FLUX-INTG',GAR3) + GAR1(IG,1)=FNORM*GAR3(IMIL)/VOLUME + DO 20 IW=2,MIN(NW+1,10) + WRITE(TEXT12,'(11HFLUX-INTG-P,I1)') IW-1 + CALL LCMLEN(KPEDIT,TEXT12,LENGTH,ITYLCM) + IF(LENGTH.EQ.NMIL) THEN + CALL LCMGET(KPEDIT,TEXT12,GAR3) + ELSE + CALL LCMGET(KPEDIT,'FLUX-INTG',GAR3) + ENDIF + GAR1(IG,IW)=FNORM*GAR3(IMIL)/VOLUME + 20 CONTINUE + ENDIF + DO 30 IW=1,MIN(NW+1,10) + WRITE(TEXT12,'(4HNTOT,I1)') IW-1 + CALL LCMLEN(KPEDIT,TEXT12,LENGTH,ITYLCM) + IF(LENGTH.EQ.NMIL) THEN + CALL LCMGET(KPEDIT,TEXT12,GAR3) + ELSE + CALL LCMGET(KPEDIT,'NTOT0',GAR3) + ENDIF + GAR1(IG,1+NW+IW)=GAR3(IMIL) + 30 CONTINUE + CALL LCMLEN(IPEDIT,'OVERV',LEOVER,ITYLCM) + IF(LEOVER.GT.0) THEN + CALL LCMGET(KPEDIT,'OVERV',GAR3) + GAR1(IG,3+2*NW)=GAR3(IMIL) + ENDIF + IF(NLEAK.EQ.1) THEN + CALL LCMGET(KPEDIT,'DIFF',GAR3) + GAR1(IG,4+2*NW)=1.0/(3.0*GAR3(IMIL)) + ELSE IF(NLEAK.EQ.2) THEN + CALL LCMGET(KPEDIT,'DIFFX',GAR3) + GAR1(IG,4+2*NW)=1.0/(3.0*GAR3(IMIL)) + CALL LCMGET(KPEDIT,'DIFFY',GAR3) + GAR1(IG,5+2*NW)=1.0/(3.0*GAR3(IMIL)) + CALL LCMGET(KPEDIT,'DIFFZ',GAR3) + GAR1(IG,6+2*NW)=1.0/(3.0*GAR3(IMIL)) + ENDIF + IF(NF.EQ.1) THEN + CALL LCMGET(KPEDIT,'NUSIGF',GAR3) + GAR1(IG,7+2*NW)=GAR3(IMIL) + CALL LCMGET(KPEDIT,'CHI',GAR3) + GAR1(IG,8+2*NW)=GAR3(IMIL) + ENDIF + CALL LCMLEN(KPEDIT,'H-FACTOR',LENGTH,ITYLCM) + IF(LENGTH.EQ.NMIL) THEN + LHF=.TRUE. + CALL LCMGET(KPEDIT,'H-FACTOR',GAR3) + GAR1(IG,9+2*NW)=GAR3(IMIL) + ELSE + GAR1(IG,9+2*NW)=0.0 + ENDIF + DO 90 IDEL=1,NDEL + IF(NF.EQ.1) THEN + WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL + CALL LCMGET(KPEDIT,TEXT12,GAR3) + GAR1(IG,9+2*NW+2*(IDEL-1)+1)=GAR3(IMIL) + WRITE(TEXT12,'(3HCHI,I2.2)') IDEL + CALL LCMGET(KPEDIT,TEXT12,GAR3) + GAR1(IG,9+2*NW+2*(IDEL-1)+2)=GAR3(IMIL) + ENDIF + 90 CONTINUE + DO 100 IED=1,NED + WRITE(TEXT8,'(2A4)') HVECT(1,IED),HVECT(2,IED) + CALL LCMLEN(KPEDIT,TEXT8,LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGET(KPEDIT,TEXT8,GAR3) + GAR1(IG,9+2*NW+2*NDEL+IED)=GAR3(IMIL) + ENDIF + 100 CONTINUE + DO 120 IL=1,NL + WRITE(CM,'(I2.2)') IL-1 + LENGTH=1 + IF(IL.GT.1) CALL LCMLEN(KPEDIT,'SCAT'//CM,LENGTH,ITYLCM) + IF(LENGTH.GT.0) THEN + CALL LCMLEN(IPEDIT,'SIGS'//CM,LESIGS,ITYLCM) + IF(LESIGS.GT.0) THEN + CALL LCMGET(KPEDIT,'SIGS'//CM,GAR3) + GAR1(IG,9+2*NW+2*NDEL+NED+IL)=GAR3(IMIL) + ENDIF + CALL LCMGET(KPEDIT,'SCAT'//CM,GAR3) + CALL LCMGET(KPEDIT,'NJJS'//CM,NJJ) + CALL LCMGET(KPEDIT,'IJJS'//CM,IJJ) + CALL LCMGET(KPEDIT,'IPOS'//CM,IPOS) + IPOSDE=IPOS(IMIL) + DO 110 JG=IJJ(IMIL),IJJ(IMIL)-NJJ(IMIL)+1,-1 + GAR2(IG,JG,IL)=GAR3(IPOSDE) + IPOSDE=IPOSDE+1 + 110 CONTINUE + ENDIF + IF(NSPH.EQ.1) THEN + CALL LCMGET(KPEDIT,'NSPH',GAR3) + GAR1(IG,9+2*NW+2*NDEL+NED+NL+1)=GAR3(IMIL) + ENDIF + 120 CONTINUE + 125 CONTINUE + DO 130 IW=1,MIN(NW+1,10) + WRITE(TEXT12,'(3HNWT,I1)') IW-1 + CALL LCMPUT(IPCPO,TEXT12,NG,2,GAR1(1,IW)) + WRITE(TEXT12,'(4HNTOT,I1)') IW-1 + CALL LCMPUT(IPCPO,TEXT12,NG,2,GAR1(1,1+NW+IW)) + 130 CONTINUE + CALL LCMPUT(IPCPO,'OVERV',NG,2,GAR1(1,3+2*NW)) + IF(NLEAK.EQ.1) THEN + CALL LCMPUT(IPCPO,'STRD',NG,2,GAR1(1,4+2*NW)) + ELSE IF(NLEAK.EQ.2) THEN + CALL LCMPUT(IPCPO,'STRD-X',NG,2,GAR1(1,4+2*NW)) + CALL LCMPUT(IPCPO,'STRD-Y',NG,2,GAR1(1,5+2*NW)) + CALL LCMPUT(IPCPO,'STRD-Z',NG,2,GAR1(1,6+2*NW)) + ENDIF + IF(NF.EQ.1) THEN + CALL LCMPUT(IPCPO,'NUSIGF',NG,2,GAR1(1,7+2*NW)) + CALL LCMPUT(IPCPO,'CHI',NG,2,GAR1(1,8+2*NW)) + ENDIF + IF(LHF) CALL LCMPUT(IPCPO,'H-FACTOR',NG,2,GAR1(1,9+2*NW)) + DO 140 IDEL=1,NDEL + IF(NF.EQ.1) THEN + WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL + CALL LCMPUT(IPCPO,TEXT12,NG,2,GAR1(1,9+2*NW+2*(IDEL-1)+1)) + WRITE(TEXT12,'(3HCHI,I2.2)') IDEL + CALL LCMPUT(IPCPO,TEXT12,NG,2,GAR1(1,9+2*NW+2*(IDEL-1)+2)) + ENDIF + 140 CONTINUE + DO 150 IED=1,NED + WRITE(TEXT8,'(2A4)') HVECT(1,IED),HVECT(2,IED) + CALL LCMPUT(IPCPO,TEXT8,NG,2,GAR1(1,9+2*NW+2*NDEL+IED)) + 150 CONTINUE + IF(NSPH.EQ.1) THEN + CALL LCMPUT(IPCPO,'NSPH',NG,2,GAR1(1,9+2*NW+2*NDEL+NED+NL+1)) + ENDIF + CALL XDRLGS(IPCPO,1,IMPX,0,NL-1,1,NG,GAR1(1,10+2*NW+2*NDEL+NED), + 1 GAR2,ITYPR) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GAR3,GAR2,GAR1) + DEALLOCATE(ITYPR,IPOS,NJJ,IJJ) + RETURN + END diff --git a/Dragon/src/COMARB.f b/Dragon/src/COMARB.f new file mode 100644 index 0000000..70ad2e8 --- /dev/null +++ b/Dragon/src/COMARB.f @@ -0,0 +1,165 @@ +*DECK COMARB + SUBROUTINE COMARB(NPAR,NVPO,NVPN,OLDDEB,OLDARB,LGNEW,MUPLET,NCAL, + 1 NEWDEB,NEWARB) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Add a node to the parameter tree. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NPAR number of parameters. +* NVPO original number of nodes in the parameter tree. +* NVPN new number of nodes in the parameter tree. +* OLDDEB original array DEBARB of the parameters tree. +* OLDARB original array ARBVAL of the parameters tree. +* LGNEW new parameter flag (=.true. if the I-th parameter has changed +* in the new elementary calculation). +* MUPLET tuple of indices associated to each parameter of the +* elementary calculation. +* +*Parameters: input/output +* NCAL index of the last elementary calculation on input and +* index of the new elementary calculation at output (value +* is incremented by 1). +* +*Parameters: output +* NEWDEB new array DEBARB of the parameters tree. +* NEWARB new array ARBVAL of the parameters tree. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + LOGICAL LGNEW(NPAR) + INTEGER NPAR,NVPO,NVPN,OLDDEB(NVPO+1),OLDARB(NVPO),MUPLET(NPAR), + 1 NCAL,NEWDEB(NVPN+1),NEWARB(NVPN) +*---- +* LOCAL VARIABLES +*---- + LOGICAL LAST,DUMMY,COMTRE +*---- +* Change addresses of parameter values if new value added. +*---- + I0=1 + DO 10 IPAR=1,NPAR + I0=OLDDEB(I0) + I1=OLDDEB(I0)-1 + IF(LGNEW(IPAR))THEN + DO 5 I=I0,I1 + IF(OLDARB(I).GE.MUPLET(IPAR))OLDARB(I)=OLDARB(I)+1 + 5 CONTINUE + ENDIF + 10 CONTINUE +*---- +* Find point where new branch is to be added and copy the +* unchanged part. +*---- + DUMMY=COMTRE(NPAR,NVPO,OLDARB,OLDDEB,MUPLET,ISTART,I0,II,JJ,LAST) +* + I1=OLDDEB(I0)-1 + J0=II + JX=JJ-OLDDEB(J0)+1 +* + DO 15 I=1,J0 + NEWDEB(I)=OLDDEB(I) + 15 CONTINUE + DO 20 I=1,I0-1 + NEWARB(I)=OLDARB(I) + 20 CONTINUE +*---- +* Modified addresses, shifted in the array, and those of +* inserted branch. +* Computation of the address where the part of array with calc. +* identifiers starts. +*---- + INCR=0 + DO 35 I=J0+1,NVPO-NCAL + IF(I.EQ.JJ)THEN + NEWDEB(I+INCR)=OLDDEB(I)+INCR+1 + INCR=INCR+1 + JX=JJ + JJ=OLDDEB(JJ) + ENDIF + NEWDEB(I+INCR)=OLDDEB(I)+INCR+1 + 35 CONTINUE +*---- +* Especial treatement if new added point is the rightmost point +* in the tree. +*---- + IF(LAST)THEN + IF(ISTART.LT.NPAR)THEN + NEWDEB(NVPO+1-NCAL+INCR)=OLDDEB(NVPO+1-NCAL)+INCR+1 + INCR=INCR+1 + ENDIF + JJ=NVPO+2 + ELSE + IF(ISTART.EQ.NPAR)THEN + JJ=OLDDEB(J0)+JX + ELSE + JJ=OLDDEB(JX)+1 + ENDIF + ENDIF +*---- +* Address of next nonexisting point used do get dimension at the end +*---- + NEWDEB(NVPO+1-NCAL+INCR)=OLDDEB(NVPO+1-NCAL)+INCR+1 +*---- +* Part of the NEWDEB array containing calculation numbers. +*---- + DO 37 I=NVPO+2-NCAL,JJ-1 + NEWDEB(I+INCR)=OLDDEB(I) + 37 CONTINUE + NCAL=NCAL+1 + NEWDEB(JJ+INCR)=NCAL + INCR=INCR+1 + DO 39 I=JJ,NVPO+1 + NEWDEB(I+INCR)=OLDDEB(I) + 39 CONTINUE +*---- +* Shifted copy for parameter values. +* Computing the address for new added value. +*---- + DO 45 I=OLDDEB(II),OLDDEB(II+1)-1 + IF(MUPLET(ISTART).LT.OLDARB(I))THEN + II=I + GO TO 46 + ENDIF + 45 CONTINUE + II=OLDDEB(II+1) + 46 CONTINUE +* + INCR=0 + DO 70 IPAR=ISTART,NPAR +* + DO 55 I=I0,II-1 + NEWARB(I+INCR)=OLDARB(I) + 55 CONTINUE +* + NEWARB(II+INCR)=MUPLET(IPAR) + INCR=INCR+1 +* + DO 65 I=II,I1 + NEWARB(I+INCR)=OLDARB(I) + 65 CONTINUE +* + IF(IPAR.NE.NPAR)THEN + II=OLDDEB(II) + I0=OLDDEB(I0) + I1=OLDDEB(I0)-1 + ENDIF +* + 70 CONTINUE +* + RETURN + END diff --git a/Dragon/src/COMBIB.f b/Dragon/src/COMBIB.f new file mode 100644 index 0000000..dd36335 --- /dev/null +++ b/Dragon/src/COMBIB.f @@ -0,0 +1,102 @@ +*DECK COMBIB + SUBROUTINE COMBIB(IPLB1,IPLB2,TYPE,IMILI,HBIB,HISO,MAXISO,VALPAR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover a global parameter or a local variable from a microlib object. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLB1 pointer to the first microlib object. +* IPLB2 pointer to the second (optional) microlib object. +* TYPE ='TEMP' or 'CONC'. +* IMILI get the value in mixture imili. +* HBIB character*12 name of the microlib. +* HISO character*8 name of the isotope. +* MAXISO allocated storage for isotopes. +* +*Parameters: output +* VALPAR global parameter or local variable. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLB1,IPLB2 + INTEGER IMILI,MAXISO + REAL VALPAR + CHARACTER TYPE*(*),HBIB*(*),HISO*(*) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + TYPE(C_PTR) IPLIB + CHARACTER NAMLCM*12,NAMMY*12,TEXT8*8 + INTEGER ISTATE(NSTATE) + LOGICAL EMPTY,LCM + INTEGER, ALLOCATABLE, DIMENSION(:) :: MIX + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISONAM + REAL, ALLOCATABLE, DIMENSION(:) :: DEN,TN +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(ISONAM(3,MAXISO),MIX(MAXISO)) + ALLOCATE(DEN(MAXISO),TN(MAXISO)) +* + IPLIB=C_NULL_PTR + CALL LCMINF(IPLB1,NAMLCM,NAMMY,EMPTY,ILONG,LCM) + IF(NAMLCM.EQ.HBIB) THEN + IPLIB=IPLB1 + ELSE IF(C_ASSOCIATED(IPLB2)) THEN + CALL LCMINF(IPLB2,NAMLCM,NAMMY,EMPTY,ILONG,LCM) + IF(NAMLCM.EQ.HBIB) IPLIB=IPLB2 + ENDIF + IF(.NOT.C_ASSOCIATED(IPLIB)) THEN + NAMLCM=HBIB + CALL XABORT('COMBIB: UNABLE TO FIND A MICROLIB NAMED '// + 1 NAMLCM//'.') + ENDIF + CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) + NBISOT=ISTATE(2) + IF(NBISOT.GT.MAXISO) CALL XABORT('COMBIB: MAXISO OVERFLOW.') + CALL LCMGET(IPLIB,'ISOTOPESUSED',ISONAM) + CALL LCMGET(IPLIB,'ISOTOPESMIX',MIX) + CALL LCMGET(IPLIB,'ISOTOPESDENS',DEN) + CALL LCMGET(IPLIB,'ISOTOPESTEMP',TN) + IF(TYPE.EQ.'TEMP') THEN + VALPAR=99999.0 + DO 10 I=1,NBISOT + IF(MIX(I).EQ.IMILI) VALPAR=MIN(VALPAR,TN(I)) + 10 CONTINUE + IF(VALPAR.EQ.99999.0) CALL XABORT('COMBIB: UNABLE TO FIND A'// + 1 ' TEMP-TYPE PARAMETER OR LOCAL VARIABLE.') + ELSE IF(TYPE.EQ.'CONC') THEN + DO 20 I=1,NBISOT + IF(MIX(I).EQ.IMILI) THEN + WRITE(TEXT8,'(2A4)') (ISONAM(I0,I),I0=1,2) + IF(TEXT8.EQ.HISO) THEN + VALPAR=DEN(I) + GO TO 30 + ENDIF + ENDIF + 20 CONTINUE + VALPAR=0.0 + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 30 DEALLOCATE(TN,DEN) + DEALLOCATE(MIX,ISONAM) + RETURN + END diff --git a/Dragon/src/COMCAL.f b/Dragon/src/COMCAL.f new file mode 100644 index 0000000..821fa79 --- /dev/null +++ b/Dragon/src/COMCAL.f @@ -0,0 +1,165 @@ +*DECK COMCAL + SUBROUTINE COMCAL(IMPX,IPCPO,IPDEPL,IPEDIT,IPEDI2,LMACRO,LISO, + 1 ITRES) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Store the results of an elementary calculation in the multicompo. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IMPX print parameter. +* IPCPO pointer to the multicompo. +* IPDEPL pointer to the burnup object (L_BURNUP signature). +* IPEDIT pointer to the edition object (L_EDIT signature). +* IPEDI2 pointer to the edition object containing group form factor +* information (L_EDIT signature). +* LMACRO flag set to .TRUE. to recover cross sections from the +* macrolib. +* LISO =.true. if we want to register the region number of the +* isotopes. +* +*Parameters: output +* ITRES creation index for the macroscopic residual (=0: not created; +* =1: not a FP precursor; =2: is a FP precursor). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IMPX,ITRES + TYPE(C_PTR) IPCPO,IPDEPL,IPEDIT,IPEDI2 + LOGICAL LMACRO,LISO +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40,MAXISO=100) + TYPE(C_PTR) JPCPO,KPCPO,LPCPO + INTEGER ISTATE(NSTATE),IPAR(NSTATE) + REAL BIRRAD(2) + CHARACTER CDIRO*12,HSMG*131,NOMISP(MAXISO)*8 +* + CALL LCMGTC(IPEDIT,'LAST-EDIT',12,CDIRO) + CALL LCMSIX(IPEDIT,CDIRO,1) + IF(LMACRO) THEN + CALL LCMSIX(IPEDIT,'MACROLIB',1) + CALL LCMGET(IPEDIT,'STATE-VECTOR',IPAR) + NMIL=IPAR(2) + NISOTS=1 + NG=IPAR(1) + NED=IPAR(5) + NW=IPAR(10) + CALL LCMSIX(IPEDIT,' ',2) + ELSE + CALL LCMGET(IPEDIT,'STATE-VECTOR',IPAR) + NMIL=IPAR(1) + NISOTS=IPAR(2) + NG=IPAR(3) + NED=IPAR(13) + NW=IPAR(25) + ENDIF + CALL LCMSIX(IPEDIT,' ',2) +* + CALL LCMGET(IPCPO,'STATE-VECTOR',ISTATE) + IF(ISTATE(3).EQ.0) THEN +* COMPLETE STATE-VECTOR. + IF(ISTATE(1).EQ.0) THEN + ISTATE(1)=NMIL + ELSE IF(NMIL.NE.ISTATE(1)) THEN + WRITE(HSMG,'(42HCOMCAL: ELEMENTARY CALCULATION WITH AN INV, + 1 22HALIB NB. OF MIXTURES =,I7,3H NE,I7,1H.)') NMIL,ISTATE(1) + CALL XABORT(HSMG) + ENDIF + ISTATE(2)=NG + ELSE + IF(NMIL.NE.ISTATE(1)) THEN + WRITE(HSMG,'(42HCOMCAL: ELEMENTARY CALCULATION WITH AN INV, + 1 22HALIB NB. OF MIXTURES =,I7,3H NE,I7,1H.)') NMIL,ISTATE(1) + CALL XABORT(HSMG) + ELSE IF(NG.NE.ISTATE(2)) THEN + WRITE(HSMG,'(42HCOMCAL: ELEMENTARY CALCULATION WITH AN INV, + 1 20HALIB NB. OF GROUPS =,I7,3H NE,I7,1H.)') NG,ISTATE(2) + CALL XABORT(HSMG) + ENDIF + ENDIF + ISTATE(3)=ISTATE(3)+1 + IF(ISTATE(3).GT.ISTATE(4)) THEN + ISTATE(4)=ISTATE(4)+10 + JPCPO=LCMLID(IPCPO,'MIXTURES',NMIL) + DO 10 IMIL=1,NMIL + KPCPO=LCMDIL(JPCPO,IMIL) + LPCPO=LCMLID(KPCPO,'CALCULATIONS',ISTATE(4)) + 10 CONTINUE + ENDIF + ICAL=ISTATE(3) + MAXCAL=ISTATE(4) + NISOP=ISTATE(13) + NGFF=ISTATE(14) + NALBP=ISTATE(15) +*---- +* RECOVER THE USER-REQUESTED PARTICULARIZED ISOTOPES +*---- + IF(NISOP.GT.MAXISO) CALL XABORT('COMCAL: MAXISO OVERFLOW.') + IF(NISOP.GT.0) CALL LCMGTC(IPCPO,'NOMISP',8,NISOP,NOMISP) +*---- +* RECOVER THE MACRO-GEOMETRY +*---- + CALL LCMLEN(IPEDIT,'MACRO-GEOM',ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + JPCPO=LCMLID(IPCPO,'GEOMETRIES',MAXCAL) + KPCPO=LCMDIL(JPCPO,ICAL) + CALL LCMSIX(IPEDIT,'MACRO-GEOM',1) + CALL LCMEQU(IPEDIT,KPCPO) + CALL LCMSIX(IPEDIT,' ',2) + ISTATE(11)=1 + ENDIF +*---- +* RECOVER THE FLUX NORMALIZATION FACTOR +*---- + IF(C_ASSOCIATED(IPDEPL)) THEN + CALL LCMGET(IPDEPL,'BURNUP-IRRAD',BIRRAD) + BURN=BIRRAD(1) + CALL LCMLEN(IPDEPL,'FLUX-NORM',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + CALL LCMLIB(IPDEPL) + WRITE(HSMG,'(40HCOMCAL: THE ''FLUX-NORM'' RECORD IS NOT SE, + 1 20HT FOR BURNUP STEP AT,E12.5,14H MW-DAY/TONNE.)') BURN + CALL XABORT(HSMG) + ENDIF + CALL LCMGET(IPDEPL,'FLUX-NORM',FNORM) + IF(IMPX.GT.0) WRITE(6,100) FNORM,BURN + ELSE + FNORM=1.0 + IF(IMPX.GT.0) WRITE(6,110) + ENDIF +*---- +* RECOVER THE CROSS SECTIONS AND NORMALIZE THE FLUX +*---- + CALL LCMSIX(IPEDIT,CDIRO,1) + CALL COMMIC(IMPX,IPCPO,IPEDIT,IPEDI2,LMACRO,ICAL,MAXCAL,NMIL, + 1 NISOTS,NG,NED,NW,FNORM,LISO,NISOP,NOMISP,NGFF,NALBP,IDF,ITRES) + ISTATE(14)=NGFF + ISTATE(15)=NALBP + ISTATE(16)=IDF + CALL LCMSIX(IPEDIT,' ',2) +*---- +* UPDATE THE STATE-VECTOR +*---- + CALL LCMPUT(IPCPO,'STATE-VECTOR',NSTATE,1,ISTATE) + RETURN +* + 100 FORMAT(45H COMCAL: NORMALIZE THE FLUX WITH THE FACTOR =,1P,E12.5, + 1 26H TAKEN FROM BURNUP STEP AT,E12.5,14H MW-DAY/TONNE.) + 110 FORMAT(36H COMCAL: THE FLUX IS NOT NORMALIZED.) + END diff --git a/Dragon/src/COMCAT.f b/Dragon/src/COMCAT.f new file mode 100644 index 0000000..e885642 --- /dev/null +++ b/Dragon/src/COMCAT.f @@ -0,0 +1,383 @@ +*DECK COMCAT + SUBROUTINE COMCAT(IPCPO,IPRHS,NORIG,NPARN,MUPCPO,LGNCPO,LWARN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Catenate a RHS compo into the output multicompo. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPCPO pointer to the output multicompo. +* IPRHS pointer to the rhs multicompo (contains the new calculations). +* NORIG index of the elementary calculation associated to the +* father node in the parameter tree. +* NPARN number of global parameters in the output multicompo. +* MUPCPO tuple of the new global parameters in the output multicompo. +* LGNCPO LGNEW value of the new global parameters in the output +* multicompo. +* LWARN logical used in case if an elementary calculation in the RHS +* is already present in CPO. If LWARN=.true. a warning is send +* and the CPO values are kept, otherwise XABORT is called +* (default). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPCPO,IPRHS + INTEGER NORIG,NPARN,MUPCPO(NPARN) + LOGICAL LGNCPO(NPARN),LWARN +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPCPO,KPCPO,JPRHS,KPRHS,LPCPO,LPRHS,MPCPO,MPRHS + PARAMETER (NSTATE=40,MAXPAR=50,MAXVAL=1000) + INTEGER ISTATE(NSTATE),NVPO(2),NVALUE(2*MAXPAR),MUPLET(2*MAXPAR), + 1 MUPRHS(2*MAXPAR) + CHARACTER HSMG*131,RECNAM*12,TEXT4*4,TEXT12*12,PARFMT(MAXPAR)*8, + 1 VCHAR(MAXVAL)*12,PARKEY(MAXPAR)*12,PARCPO(MAXPAR)*12 + LOGICAL COMTRE,LGERR,LGNEW(MAXPAR) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ILCALR,MUOLD,IORRHS,IDEBAR, + 1 IARBVA,JDEBAR,JARBVA,IORIGI,VINTE + REAL, ALLOCATABLE, DIMENSION(:) :: VREAL + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LGOLD +* + NIDEM=0 + CALL LCMGET(IPRHS,'STATE-VECTOR',ISTATE) + NMIL=ISTATE(1) + NG=ISTATE(2) + NCALR=ISTATE(3) + NPAR=ISTATE(5) + NLOC=ISTATE(6) + IF(NCALR.EQ.0) CALL XABORT('COMCAT: NO CALCULATION IN RHS COMPO.') + ALLOCATE(ILCALR(NCALR)) +* + CALL LCMGET(IPCPO,'STATE-VECTOR',ISTATE) + NCAL=ISTATE(3) + IF(NPARN+NLOC.GT.2*MAXPAR) CALL XABORT('COMCAT: MAXPAR OVERFLOW.') + IF(NCAL.EQ.0) THEN +* COMPLETE STATE-VECTOR. + IF(ISTATE(1).EQ.0) THEN + ISTATE(1)=NMIL + ELSE IF(NMIL.NE.ISTATE(1)) THEN + WRITE(HSMG,'(42HCOMCAT: ELEMENTARY CALCULATION WITH AN INV, + 1 22HALIB NB. OF MIXTURES =,I7,3H NE,I7,1H.)') NMIL,ISTATE(1) + CALL XABORT(HSMG) + ENDIF + ISTATE(2)=NG + ELSE + IF(NMIL.NE.ISTATE(1)) THEN + WRITE(HSMG,'(42HCOMCAT: ELEMENTARY CALCULATION WITH AN INV, + 1 22HALIB NB. OF MIXTURES =,I7,3H NE,I7,1H.)') NMIL,ISTATE(1) + CALL XABORT(HSMG) + ELSE IF(NG.NE.ISTATE(2)) THEN + WRITE(HSMG,'(42HCOMCAT: ELEMENTARY CALCULATION WITH AN INV, + 1 20HALIB NB. OF GROUPS =,I7,3H NE,I7,1H.)') NG,ISTATE(2) + CALL XABORT(HSMG) + ENDIF + ENDIF + IF(NPAR.GT.NPARN) THEN + WRITE(HSMG,'(42HCOMCAT: ELEMENTARY CALCULATION WITH AN INV, + 1 31HALIB NB. OF GLOBAL PARAMETERS =,I7,3H NE,I7,1H.)') NPAR, + 2 NPARN + CALL XABORT(HSMG) + ELSE IF(NLOC.NE.ISTATE(6)) THEN + WRITE(HSMG,'(42HCOMCAT: ELEMENTARY CALCULATION WITH AN INV, + 1 30HALIB NB. OF LOCAL PARAMETERS =,I7,3H NE,I7,1H.)') NLOC, + 2 ISTATE(6) + CALL XABORT(HSMG) + ENDIF +*---- +* ADJUST THE SIZE OF THE OUTPUT COMPO +*---- + ISTATE(3)=ISTATE(3)+NCALR + IF(ISTATE(3).GT.ISTATE(4)) THEN + ISTATE(4)=ISTATE(4)+NCALR+9 + JPCPO=LCMLID(IPCPO,'MIXTURES',NMIL) + DO 10 IBM=1,NMIL + KPCPO=LCMDIL(JPCPO,IBM) + LPCPO=LCMLID(KPCPO,'CALCULATIONS',ISTATE(4)) + 10 CONTINUE + ENDIF + MAXCAL=ISTATE(4) +*---- +* UPDATE THE STATE-VECTOR +*---- + CALL LCMPUT(IPCPO,'STATE-VECTOR',NSTATE,1,ISTATE) +*---- +* MAIN LOOP OVER THE HOMOGENEOUS MIXTURES ********************* +*---- + JPCPO=LCMLID(IPCPO,'MIXTURES',NMIL) + JPRHS=LCMGID(IPRHS,'MIXTURES') + ALLOCATE(MUOLD(NCALR*NPARN),LGOLD(NCALR*NPARN)) + DO 190 IBM=1,NMIL + KPCPO=LCMDIL(JPCPO,IBM) + KPRHS=LCMGIL(JPRHS,IBM) +*---- +* MAIN LOOP OVER THE NCALR ELEMENTARY CALCULATIONS OF THE RHS COMPO +*---- + ILCALR(:NCALR)=1 + NIDEM=0 + DO 170 ICAL=1,NCALR +*---- +* COMPUTE THE MUPLET VECTOR FROM THE RHS COMPO +*---- + CALL LCMSIX(KPRHS,'TREE',1) + CALL LCMLEN(KPRHS,'ARBVAL',MAXNVP,ITYLCM) + CALL LCMLEN(KPRHS,'ORIGIN',MAXNCA,ITYLCM) + ALLOCATE(IORRHS(MAXNCA)) + CALL LCMGET(KPRHS,'ORIGIN',IORRHS) + ALLOCATE(JDEBAR(MAXNVP+1),JARBVA(MAXNVP)) + CALL LCMGET(KPRHS,'NCALS',NCALS) + CALL LCMGET(KPRHS,'DEBARB',JDEBAR) + CALL LCMGET(KPRHS,'ARBVAL',JARBVA) + CALL LCMGET(KPRHS,'NVP',NVPO) + DO 30 I=NVPO(1)-NCALS+1,NVPO(1) + IF(JDEBAR(I+1).EQ.ICAL) THEN + I0=I + GO TO 40 + ENDIF + 30 CONTINUE + CALL XABORT('COMCAT: MUPLET ALGORITHM FAILURE 1.') + 40 MUPRHS(NPAR+NLOC)=JARBVA(I0) + DO 65 IPAR=NPAR+NLOC-1,1,-1 + DO 50 I=1,NVPO(1)-NCALS + IF(JDEBAR(I+1).GT.I0) THEN + I0=I + GO TO 60 + ENDIF + 50 CONTINUE + CALL XABORT('COMCAT: MUPLET ALGORITHM FAILURE 2.') + 60 MUPRHS(IPAR)=JARBVA(I0) + 65 CONTINUE + DEALLOCATE(JARBVA,JDEBAR) +*---- +* RECOVER THE GLOBAL PARAMETERS +*---- + IF(IBM.EQ.1) THEN + DO 70 I=1,NPARN + MUPLET(I)=MUPCPO(I) + LGNEW(I)=LGNCPO(I) + 70 CONTINUE + CALL LCMSIX(IPCPO,'GLOBAL',1) + CALL LCMSIX(IPRHS,'GLOBAL',1) + CALL LCMGTC(IPCPO,'PARKEY',12,NPARN,PARCPO) + CALL LCMGTC(IPRHS,'PARKEY',12,NPAR,PARKEY) + CALL LCMGTC(IPRHS,'PARFMT',8,NPAR,PARFMT) + CALL LCMGET(IPRHS,'NVALUE',NVALUE) + DO 100 IPAR=1,NPAR + DO 80 I0=1,NPARN + IF(PARKEY(IPAR).EQ.PARCPO(I0)) THEN + IPARN=I0 + GO TO 90 + ENDIF + 80 CONTINUE + CALL XABORT('COMCAT: UNABLE TO FIND '//PARKEY(IPAR)//'.') + 90 WRITE(RECNAM,'(''pval'',I8.8)') IPAR + IVAL=MUPRHS(IPAR) + IF(PARFMT(IPAR).EQ.'REAL') THEN + ALLOCATE(VREAL(NVALUE(IPAR))) + CALL LCMGET(IPRHS,RECNAM,VREAL) + FLOTT=VREAL(IVAL) + DEALLOCATE(VREAL) + ELSE IF(PARFMT(IPAR).EQ.'INTEGER') THEN + ALLOCATE(VINTE(NVALUE(IPAR))) + CALL LCMGET(IPRHS,RECNAM,VINTE) + NITMA=VINTE(IVAL) + DEALLOCATE(VINTE) + ELSE IF(PARFMT(IPAR).EQ.'STRING') THEN + IF(NVALUE(IPAR).GT.MAXVAL) CALL XABORT('COMCAT: MAXVAL ' + 1 //'OVERFLOW.') + CALL LCMGTC(IPRHS,RECNAM,12,NVALUE(IPAR),VCHAR) + TEXT12=VCHAR(IVAL) + ENDIF + CALL COMPAV(IPCPO,IPARN,NPARN,PARFMT(IPAR),FLOTT,NITMA, + 1 TEXT12,MUPLET(IPARN),LGNEW(IPARN)) + 100 CONTINUE + DO 110 IPARN=1,NPARN + MUOLD((ICAL-1)*NPARN+IPARN)=MUPLET(IPARN) + LGOLD((ICAL-1)*NPARN+IPARN)=LGNEW(IPARN) + 110 CONTINUE + CALL LCMSIX(IPRHS,' ',2) + CALL LCMSIX(IPCPO,' ',2) + ELSE + DO 120 IPARN=1,NPARN + MUPLET(IPARN)=MUOLD((ICAL-1)*NPARN+IPARN) + LGNEW(IPARN)=LGOLD((ICAL-1)*NPARN+IPARN) + 120 CONTINUE + ENDIF +*---- +* RECOVER THE LOCAL PARAMETERS +*---- + CALL LCMSIX(KPCPO,'TREE',1) + DO 130 ILOC=1,NLOC + WRITE(RECNAM,'(''pval'',I8.8)') ILOC + IVAL=MUPRHS(NPAR+ILOC) + CALL LCMLEN(KPRHS,RECNAM,ILONG,ITYLCM) + ALLOCATE(VREAL(ILONG)) + CALL LCMGET(KPRHS,RECNAM,VREAL) + FLOTT=VREAL(IVAL) + DEALLOCATE(VREAL) + CALL COMPAV(KPCPO,ILOC,NLOC,PARFMT(ILOC),FLOTT,NITMA,TEXT12, + 1 MUPLET(NPARN+ILOC),LGNEW(NPARN+ILOC)) + 130 CONTINUE + CALL LCMSIX(KPRHS,' ',2) +*---- +* UPDATE THE PARAMETER TREE IN THE OUTPUT COMPO +*---- + CALL LCMLEN(KPCPO,'NVP',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + MAXNVP=20*(NPARN+NLOC+1) + ALLOCATE(IDEBAR(MAXNVP+1),IARBVA(MAXNVP)) + IDEBAR(:MAXNVP+1)=0 + IARBVA(:MAXNVP)=0 + IARBVA=0 + DO 140 I=1,NPARN+NLOC + IDEBAR(I)=I+1 + IARBVA(I+1)=1 + 140 CONTINUE + IDEBAR(NPARN+NLOC+1)=NPARN+NLOC+2 + IDEBAR(NPARN+NLOC+2)=1 + NCALS=1 + NVPNEW=NPARN+NLOC+1 + ELSE + CALL LCMLEN(KPCPO,'ARBVAL',JLONG,ITYLCM) + ALLOCATE(JDEBAR(JLONG+1),JARBVA(JLONG)) + CALL LCMGET(KPCPO,'NCALS',NCALS) + CALL LCMGET(KPCPO,'DEBARB',JDEBAR) + CALL LCMGET(KPCPO,'ARBVAL',JARBVA) + CALL LCMGET(KPCPO,'NVP',NVPO) + DO 150 IPAR=1,NPARN+NLOC + IF(LGNEW(IPAR)) THEN + II=IPAR + GO TO 160 + ENDIF + 150 CONTINUE + II=NPARN+NLOC+1 + 160 LGERR=COMTRE(NPARN+NLOC,NVPO(1),JARBVA,JDEBAR,MUPLET,KK,I0, + 1 IORD,JJ,LAST) + IF((II.GT.NPARN+NLOC).AND.LGERR) THEN + WRITE(TEXT4,'(I4)') IORD + IF(LWARN) THEN + WRITE(6,*)'COMCAT: ELEMENTARY CALCULATION HAS THE ', + 1 'SAME PARAMETERS AS ELEMENTARY CALCULATION NB ',TEXT4 + DEALLOCATE(JARBVA,JDEBAR,IORRHS) + CALL LCMSIX(KPCPO,' ',2) + ILCALR(ICAL)=0 + NIDEM=NIDEM+1 + GOTO 170 + ELSE + CALL XABORT('COMCAT: ELEMENTARY CALCULATION HAS THE '// + 1 'SAME PARAMETERS AS ELEMENTARY CALCULATION NB '//TEXT4) + ENDIF + ENDIF +* +* Size of the new tree. +* + NVPNEW=NVPO(1)+NPARN+NLOC+1-MIN(II,KK) + IF(NVPNEW.GT.MAXNVP) MAXNVP=NVPNEW+MAXNVP + ALLOCATE(IDEBAR(MAXNVP+1),IARBVA(MAXNVP)) + IDEBAR(NVPNEW+2:MAXNVP+1)=0 + IARBVA(NVPNEW+1:MAXNVP)=0 +* +* Update values and suppress old PARBRE. +* + CALL COMARB(NPARN+NLOC,NVPO(1),NVPNEW,JDEBAR,JARBVA,LGNEW, + 1 MUPLET,NCALS,IDEBAR,IARBVA) + DEALLOCATE(JARBVA,JDEBAR) + ENDIF + IF(NCALS.NE.NCAL+ICAL-NIDEM) CALL XABORT('COMCAT: INVALID NCALS.') + NVPO(1)=NVPNEW + NVPO(2)=MAXNVP + CALL LCMPUT(KPCPO,'NVP',2,1,NVPO) + CALL LCMPUT(KPCPO,'NCALS',1,1,NCALS) + CALL LCMPUT(KPCPO,'DEBARB',NVPO(1)+1,1,IDEBAR) + CALL LCMPUT(KPCPO,'ARBVAL',NVPO(1),1,IARBVA) + DEALLOCATE(IARBVA,IDEBAR) + IF(NCALS.EQ.1) THEN + ALLOCATE(IORIGI(MAXCAL)) + IORIGI(:MAXCAL)=0 + ELSE + CALL LCMLEN(KPCPO,'ORIGIN',MAXOLD,ITYLCM) + IF(MAXOLD.GT.MAXCAL) CALL XABORT('COMCAT: ORIGIN OVERFLOW(1).') + ALLOCATE(IORIGI(MAXCAL)) + IORIGI(:MAXCAL)=0 + CALL LCMGET(KPCPO,'ORIGIN',IORIGI) + ENDIF + IF(NCALS.GT.MAXCAL) CALL XABORT('COMCAT: ORIGIN OVERFLOW(2).') + IF(IORRHS(ICAL).EQ.0) THEN + IORIGI(NCALS)=NORIG + ELSE + IORIGI(NCALS)=NCAL+IORRHS(ICAL) + ENDIF + CALL LCMPUT(KPCPO,'ORIGIN',NCALS,1,IORIGI) + DEALLOCATE(IORIGI) + CALL LCMSIX(KPCPO,' ',2) + DEALLOCATE(IORRHS) + 170 CONTINUE +* END OF LOOP ON MIXTURES. *********************************** +*---- +* RECOVER THE MICROLIBS +*---- + LPCPO=LCMLID(KPCPO,'CALCULATIONS',ISTATE(4)) + LPRHS=LCMGID(KPRHS,'CALCULATIONS') + NIDEM=0 + DO 180 ICAL=1,NCALR + IF(ILCALR(ICAL).EQ.1)THEN + MPCPO=LCMDIL(LPCPO,NCAL+ICAL-NIDEM) + MPRHS=LCMGIL(LPRHS,ICAL) + CALL LCMEQU(MPRHS,MPCPO) + ELSE + NIDEM=NIDEM+1 + ENDIF + 180 CONTINUE + 190 CONTINUE + DEALLOCATE(LGOLD,MUOLD) +*---- +* RECOVER THE DEPLETION CHAIN +*---- + CALL LCMLEN(IPRHS,'DEPL-CHAIN',ILONG,ITYLCM) + IF(ILONG.EQ.-1) THEN + CALL LCMSIX(IPCPO,'DEPL-CHAIN',1) + CALL LCMSIX(IPRHS,'DEPL-CHAIN',1) + CALL LCMEQU(IPRHS,IPCPO) + CALL LCMSIX(IPRHS,' ',2) + CALL LCMSIX(IPCPO,' ',2) + ENDIF +*---- +* RECOVER THE MACRO-GEOMETRIES +*---- + CALL LCMLEN(IPRHS,'GEOMETRIES',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + JPCPO=LCMLID(IPCPO,'GEOMETRIES',MAXCAL) + JPRHS=LCMGID(IPRHS,'GEOMETRIES') + DO 200 ICAL=1,NCALR + IF(ILCALR(ICAL).EQ.1)THEN + KPCPO=LCMDIL(JPCPO,NCAL+ICAL) + KPRHS=LCMGIL(JPRHS,ICAL) + CALL LCMEQU(KPRHS,KPCPO) + ENDIF + 200 CONTINUE + ISTATE(11)=1 + ENDIF + DEALLOCATE(ILCALR) + ISTATE(3)=ISTATE(3)-NIDEM + IF(ISTATE(15).EQ.-1) ISTATE(15)=0 + CALL LCMPUT(IPCPO,'STATE-VECTOR',NSTATE,1,ISTATE) +* END OF LOOP ON ELEMENTARY CALCULATIONS. ******************** + RETURN + END diff --git a/Dragon/src/COMDEP.f b/Dragon/src/COMDEP.f new file mode 100644 index 0000000..26cc19c --- /dev/null +++ b/Dragon/src/COMDEP.f @@ -0,0 +1,135 @@ +*DECK COMDEP + SUBROUTINE COMDEP(IPRINT,IPEDIT,IPWORK,ITRES,NISOP,NOMEVO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Creation of a lumped depletion chain in the multicompo. +* +*Copyright: +* Copyright (C) 2015 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input/output +* IPRINT print parameter. +* IPEDIT pointer to the edition object (L_EDIT signature). +* IPWORK pointer to the LCM object where the lumped depletion chain is +* written. +* ITRES creation index for the macroscopic residual (=0: not created; +* =1: not a FP precursor; =2: is a FP precursor). +* NISOP number of user-requested particularized isotopes. Equal to +* zero if all EDI: isotopes are particularized. +* NOMEVO library names of user-requested particularized isotopes. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IPRINT,ITRES,NISOP + TYPE(C_PTR) IPEDIT,IPWORK + CHARACTER NOMEVO(NISOP)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40,MAXBCH=500) + INTEGER ISTATE(NSTATE),IHICH(3,MAXBCH) + LOGICAL LISO + CHARACTER TEXT12*12 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MYLIS,IHREAC + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IHISO,IDREA,IPREA + REAL, ALLOCATABLE, DIMENSION(:) :: DDECA + REAL, ALLOCATABLE, DIMENSION(:,:) :: DENER,PRATE,YIELD +*---- +* RECOVER DEPLETION INFORMATION FROM EDITION OBJECT +*---- + CALL LCMSIX(IPEDIT,'DEPL-CHAIN',1) + IF(NISOP.GT.0) THEN + CALL LCMGET(IPEDIT,'STATE-VECTOR',ISTATE) + NBISO=ISTATE(1) + IF(ITRES.EQ.2) NBISO=NBISO+1 + NBFISS=ISTATE(2) + NBDPF=ISTATE(3) + NSUPS=ISTATE(7) + NREAC=ISTATE(8) + NFATH=ISTATE(9) + MAXFP=NBDPF+30 ! reserve 30 location for lumped fp daughters + ALLOCATE(IHISO(3,NBISO),MYLIS(NBISO),IHREAC(2*NREAC), + 1 IDREA(NREAC,NBISO),DENER(NREAC,NBISO),DDECA(NBISO), + 2 IPREA(NFATH,NBISO),PRATE(NFATH,NBISO),YIELD(NBFISS,MAXFP)) + CALL LCMGET(IPEDIT,'ISOTOPESDEPL',IHISO) + CALL LCMGET(IPEDIT,'CHARGEWEIGHT',MYLIS) + CALL LCMGET(IPEDIT,'DEPLETE-IDEN',IHREAC) + CALL LCMGET(IPEDIT,'DEPLETE-REAC',IDREA) + CALL LCMGET(IPEDIT,'DEPLETE-ENER',DENER) + CALL LCMGET(IPEDIT,'DEPLETE-DECA',DDECA) + CALL LCMGET(IPEDIT,'PRODUCE-REAC',IPREA) + CALL LCMGET(IPEDIT,'PRODUCE-RATE',PRATE) + IF(NBFISS*NBDPF.GT.0) THEN + CALL LCMGET(IPEDIT,'FISSIONYIELD',YIELD) + ENDIF +*---- +* DESCRIBE FISSILE ISOTOPE *MAC*RES +*---- + IF(ITRES.EQ.2) THEN + IF(IPRINT.GT.1) THEN + WRITE(6,'(/42H COMDEP: ADD *MAC*RES RESIDUAL ISOTOPE TO , + 1 17HDEPLETION CHAINS.)') + ENDIF + TEXT12='*MAC*RES' + READ(TEXT12,'(3A4)') (IHISO(I0,NBISO),I0=1,3) + MYLIS(NBISO)=0 + IDREA(:,NBISO)=0 + DENER(:,NBISO)=0.0 + IDREA(1,NBISO)=4 + DDECA(NBISO)=0.0 + IPREA(:,NBISO)=0 + PRATE(:,NBISO)=0.0 + ENDIF +*---- +* CREATE LUMPED DEPLETION CHAIN +*---- + CALL LCMSIX(IPWORK,'DEPL-CHAIN',1) + LISO=.FALSE. + NBCH=0 + DO 20 ISO=1,NBISO + WRITE(TEXT12,'(3A4)') (IHISO(I0,ISO),I0=1,3) + DO JSO=1,NISOP + IF((TEXT12.EQ.NOMEVO(JSO)).AND.(TEXT12.NE.'*MAC*RES')) THEN + NBCH=NBCH+1 + IF(NBCH.GT.MAXBCH) CALL XABORT('COMDEP: MAXBCH OVERFLOW.') + READ(TEXT12,'(3A4)') (IHICH(I0,NBCH),I0=1,3) + GO TO 20 + ENDIF + ENDDO + IF((TEXT12.EQ.'*MAC*RES').AND.(ITRES.EQ.2)) THEN + NBCH=NBCH+1 + IF(NBCH.GT.MAXBCH) CALL XABORT('COMDEP: MAXBCH OVERFLOW.') + READ(TEXT12,'(3A4)') (IHICH(I0,NBCH),I0=1,3) + ENDIF + 20 CONTINUE + CALL EDILUM(IPRINT,IPWORK,MAXFP,NBISO,NBFISS,NBDPF,NSUPS, + 1 NREAC,NFATH,NBCH,IHICH,IHISO,MYLIS,IHREAC,IDREA,DENER,DDECA, + 2 IPREA,PRATE,YIELD,LISO,NBFISS,NBCH) + DEALLOCATE(YIELD,PRATE,IPREA,DDECA,DENER,IDREA,IHREAC,MYLIS, + 1 IHISO) + ELSE +*---- +* RECOVER THE DEPLETION CHAIN WITHOUT LUMPING +*---- + CALL LCMSIX(IPWORK,'DEPL-CHAIN',1) + CALL LCMEQU(IPEDIT,IPWORK) + ENDIF + CALL LCMSIX(IPWORK,' ',2) + CALL LCMSIX(IPEDIT,' ',2) + RETURN + END diff --git a/Dragon/src/COMGEM.f b/Dragon/src/COMGEM.f new file mode 100644 index 0000000..dd7f0e4 --- /dev/null +++ b/Dragon/src/COMGEM.f @@ -0,0 +1,188 @@ +*DECK COMGEM + SUBROUTINE COMGEM(IPDEPL,ITIM,TYPE,IMILI,NBURN,NBMIX,NBISO,NREAC, + 1 NVAR,VALUE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover a global parameter or a local variable from the burnup object. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPDEPL pointer to the burnup object. +* ITIM index of the current burnup step. +* TYPE type of parameter (='FLUX', 'IRRA', 'TIME', 'PUIS', 'FLUB' or +* 'MASL'). +* IMILI position of parameter (=0: global averaged value; >0: value +* in mixture IMILI). +* NBURN number of burnup steps in the burnup object. +* NBMIX number of depleting mixtures. +* NBISO number of isotopes. +* NREAC number of depleting reactions. +* NVAR number of depleting isotopes. +* +*Parameters: output +* VALUE global parameter or local variable. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPDEPL + INTEGER ITIM,IMILI,NBURN,NBMIX,NBISO,NREAC,NVAR + REAL VALUE + CHARACTER TYPE*(*) +*---- +* LOCAL VARIABLES +*---- + REAL BUIR(2) + CHARACTER CDIRO*12 + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: JM + REAL, ALLOCATABLE, DIMENSION(:) :: DEN,TIME,VX,WORK + REAL, ALLOCATABLE, DIMENSION(:,:) :: PARAM,VPHV + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SIG +*---- +* SCRATCH STORAGE ALLOCATION +* PARAM parameters (PARAM(*,1): fluence; PARAM(*,2): burnup or +* energy). +*---- + ALLOCATE(JM(NBMIX,NVAR)) + ALLOCATE(DEN(NBISO),TIME(NBURN),PARAM(NBMIX,2),VPHV(NBMIX,2), + 1 VX(NBMIX),WORK(NBMIX),SIG(NVAR+1,NREAC+1,NBMIX)) +* + CALL LCMGET(IPDEPL,'DEPL-TIMES',TIME) + CALL LCMGET(IPDEPL,'VOLUME-MIX',VX) + CALL LCMGET(IPDEPL,'DEPLETE-MIX',JM) +*---- +* COMPUTE THE EXPOSURE AND BURNUP +*---- + IF(IMILI.NE.0) THEN + NB0=1 + WRITE(CDIRO,'(8HDEPL-DAT,I4.4)') NB0 + CALL LCMSIX(IPDEPL,CDIRO,1) + CALL LCMGET(IPDEPL,'INT-FLUX',VPHV(1,1)) + CALL LCMSIX(IPDEPL,' ',2) + DO 10 IBM=1,NBMIX + PARAM(IBM,1)=0.0 + PARAM(IBM,2)=0.0 + 10 CONTINUE + DO 25 NB=NB0+1,ITIM + WRITE(CDIRO,'(8HDEPL-DAT,I4.4)') NB + CALL LCMSIX(IPDEPL,CDIRO,1) + CALL LCMGET(IPDEPL,'INT-FLUX',VPHV(1,2)) + CALL LCMGET(IPDEPL,'ENERG-MIX',WORK) + CALL LCMSIX(IPDEPL,' ',2) + DO 20 IBM=1,NBMIX + PHIAV=0.5*(VPHV(IBM,1)+VPHV(IBM,2))/VX(IBM) + PARAM(IBM,1)=PARAM(IBM,1)+PHIAV*(TIME(NB)-TIME(NB-1)) + PARAM(IBM,2)=PARAM(IBM,2)+WORK(IBM)/8.64E-4 + VPHV(IBM,1)=VPHV(IBM,2) + 20 CONTINUE + 25 CONTINUE + ENDIF +* + IF(TYPE.EQ.'FLUB') THEN + IF(IMILI.EQ.0) THEN + WRITE(CDIRO,'(8HDEPL-DAT,I4.4)') ITIM + CALL LCMSIX(IPDEPL,CDIRO,1) + CALL LCMGET(IPDEPL,'BURNUP-IRRAD',BUIR) + CALL LCMSIX(IPDEPL,' ',2) + VALUE=BUIR(2) + ELSE + VALUE=PARAM(IMILI,1) + ENDIF + ELSE IF((TYPE.EQ.'IRRA').OR.(TYPE.EQ.'BURNUP')) THEN + IF(IMILI.EQ.0) THEN + WRITE(CDIRO,'(8HDEPL-DAT,I4.4)') ITIM + CALL LCMSIX(IPDEPL,CDIRO,1) + CALL LCMGET(IPDEPL,'BURNUP-IRRAD',BUIR) + CALL LCMSIX(IPDEPL,' ',2) + VALUE=BUIR(1) + ELSE + CALL LCMGET(IPDEPL,'FUELDEN-MIX',WORK) + IF(WORK(IMILI).EQ.0.0) THEN + VALUE=0.0 + ELSE + VALUE=PARAM(IMILI,2)/WORK(IMILI) + ENDIF + ENDIF + ELSE IF(TYPE.EQ.'TIME') THEN + VALUE=(TIME(ITIM)-TIME(1))*1.0E8 + ELSE IF(TYPE.EQ.'FLUX') THEN + WRITE(CDIRO,'(8HDEPL-DAT,I4.4)') ITIM + CALL LCMSIX(IPDEPL,CDIRO,1) + CALL LCMGET(IPDEPL,'INT-FLUX',PARAM(1,1)) + CALL LCMSIX(IPDEPL,' ',2) + IF(IMILI.EQ.0) THEN + VTOT=0.0 + VALUE=0.0 + DO 30 IBM=1,NBMIX + VTOT=VTOT+VX(IBM) + VALUE=VALUE+1.0E-11*PARAM(IBM,1) + 30 CONTINUE + VALUE=VALUE/VTOT + ELSE + VALUE=1.0E-11*PARAM(IMILI,1)/VX(IMILI) + ENDIF + ELSE IF(TYPE.EQ.'PUIS') THEN + WRITE(CDIRO,'(8HDEPL-DAT,I4.4)') ITIM + CALL LCMSIX(IPDEPL,CDIRO,1) + CALL LCMGET(IPDEPL,'MICRO-RATES',SIG) + CALL LCMGET(IPDEPL,'ISOTOPESDENS',DEN) + CALL LCMSIX(IPDEPL,' ',2) + IF(IMILI.EQ.0) THEN + VTOT=0.0 + VALUE=0.0 + DO 50 IBM=1,NBMIX + VTOT=VTOT+VX(IBM) + GAR=SIG(NVAR+1,NREAC,IBM)+SIG(NVAR+1,NREAC+1,IBM) + DO 40 IS=1,NVAR + IF(JM(IBM,IS).GT.0) THEN + GAR=GAR+VX(IBM)*DEN(JM(IBM,IS))*(SIG(IS,NREAC,IBM)+ + & SIG(IS,NREAC+1,IBM)) + ENDIF + 40 CONTINUE + VALUE=VALUE+1.0E-8*GAR + 50 CONTINUE + VALUE=VALUE/VTOT + ELSE + GAR=SIG(NVAR+1,NREAC,IMILI)+SIG(NVAR+1,NREAC+1,IMILI) + DO 60 IS=1,NVAR + IF(JM(IMILI,IS).GT.0) THEN + GAR=GAR+VX(IMILI)*DEN(JM(IMILI,IS))*(SIG(IS,NREAC,IMILI)+ + & SIG(IS,NREAC+1,IMILI)) + ENDIF + 60 CONTINUE + VALUE=1.0E-8*GAR/VX(IMILI) + ENDIF + ELSE IF(TYPE.EQ.'MASL') THEN + CALL LCMGET(IPDEPL,'FUELDEN-MIX',WORK) + IF(IMILI.EQ.0) THEN + VTOT=0.0 + VALUE=0.0 + DO 70 IBM=1,NBMIX + VTOT=VTOT+VX(IBM) + VALUE=VALUE+WORK(IBM) + 70 CONTINUE + VALUE=VALUE/VTOT + ELSE + VALUE=WORK(IMILI)/VX(IMILI) + ENDIF + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SIG,WORK,VX,VPHV,PARAM,TIME,DEN) + DEALLOCATE(JM) + RETURN + END diff --git a/Dragon/src/COMGEN.f b/Dragon/src/COMGEN.f new file mode 100644 index 0000000..453f343 --- /dev/null +++ b/Dragon/src/COMGEN.f @@ -0,0 +1,176 @@ +*DECK COMGEN + SUBROUTINE COMGEN(IPDEPL,IPEDIT,NREG,NMIL,ITIM,TYPE,NBURN,NBMIX, + 1 NBISO,NREAC,NVAR,ILOC,NLOC,RVALOC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover a local variables from the burnup object and homogenize them +* on the output mixtures. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPDEPL pointer to the burnup object. +* IPEDIT pointer to the edition object. +* NREG number of volumes in the depleting geometry. +* NMIL number of homogenized output mixtures. +* ITIM index of the current burnup step. +* TYPE type of parameter (='FLUX', 'IRRA', 'PUIS', 'FLUG', 'FLUB' or +* 'MASL'). +* NBURN number of burnup steps in the burnup object. +* NBMIX number of depleting mixtures. +* NBISO number of isotopes. +* NREAC number of depleting reactions. +* NVAR number of depleting isotopes. +* ILOC position of local parameter in RVALOC. +* NLOC first dimension of matrix RVALOC. +* +*Parameters: output +* RVALOC local variable values in homogeneous mixtures. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPDEPL,IPEDIT + INTEGER NREG,NMIL,ITIM,NBURN,NBMIX,NBISO,NREAC,NVAR,ILOC,NLOC + REAL RVALOC(NLOC,NMIL) + CHARACTER TYPE*(*) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER CDIRO*12 + INTEGER IPAR(NSTATE) + INTEGER, ALLOCATABLE, DIMENSION(:) :: MATR,MERG + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: JM + REAL, ALLOCATABLE, DIMENSION(:) :: DEN,TIME,VX,WORK,VOLR,VOLIBM + REAL, ALLOCATABLE, DIMENSION(:,:) :: PARAM,VPHV + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SIG +*---- +* SCRATCH STORAGE ALLOCATION +* PARAM parameters (PARAM(*,1): fluence; PARAM(*,2): burnup or +* energy). +*---- + ALLOCATE(JM(NBMIX,NVAR),MATR(NREG),MERG(NREG)) + ALLOCATE(DEN(NBISO),TIME(NBURN),PARAM(NBMIX,2),VPHV(NBMIX,2), + 1 VX(NBMIX),WORK(NBMIX),SIG(NVAR+1,NREAC+1,NBMIX),VOLR(NREG), + 2 VOLIBM(NMIL)) +* + CALL LCMGET(IPDEPL,'DEPL-TIMES',TIME) + CALL LCMGET(IPDEPL,'VOLUME-MIX',VX) + CALL LCMGET(IPDEPL,'DEPLETE-MIX',JM) +*---- +* COMPUTE THE EXPOSURE AND BURNUP +*---- + NB0=1 + WRITE(CDIRO,'(8HDEPL-DAT,I4.4)') NB0 + CALL LCMSIX(IPDEPL,CDIRO,1) + CALL LCMGET(IPDEPL,'INT-FLUX',VPHV(1,1)) + CALL LCMSIX(IPDEPL,' ',2) + DO 10 IBM=1,NBMIX + PARAM(IBM,1)=0.0 + PARAM(IBM,2)=0.0 + 10 CONTINUE + DO 25 NB=NB0+1,ITIM + WRITE(CDIRO,'(8HDEPL-DAT,I4.4)') NB + CALL LCMSIX(IPDEPL,CDIRO,1) + CALL LCMGET(IPDEPL,'INT-FLUX',VPHV(1,2)) + CALL LCMGET(IPDEPL,'ENERG-MIX',WORK) + CALL LCMSIX(IPDEPL,' ',2) + DO 20 IBM=1,NBMIX + PHIAV=0.5*(VPHV(IBM,1)+VPHV(IBM,2))/VX(IBM) + PARAM(IBM,1)=PARAM(IBM,1)+PHIAV*(TIME(NB)-TIME(NB-1)) + PARAM(IBM,2)=PARAM(IBM,2)+WORK(IBM)/8.64E-4 + VPHV(IBM,1)=VPHV(IBM,2) + 20 CONTINUE + 25 CONTINUE +*---- +* RECOVER HOMOGENIZATION INFORMATION FROM THE EDITION OBJECT +*---- + CALL LCMGET(IPEDIT,'STATE-VECTOR',IPAR) + IF(NMIL.NE.IPAR(1)) CALL XABORT('COMGEN: INVALID NMIL.') + CALL LCMGET(IPEDIT,'REF:VOLUME',VOLR) + CALL LCMGET(IPEDIT,'REF:MATCOD',MATR) + CALL LCMGET(IPEDIT,'REF:IMERGE',MERG) +* + DO 30 IBM=1,NMIL + VOLIBM(IBM)=0.0 + RVALOC(ILOC,IBM)=0.0 + 30 CONTINUE + DO 50 IREG=1,NREG + IBM=MERG(IREG) + IMILI=MATR(IREG) + VV=VOLR(IREG) + IF(TYPE.EQ.'FLUG') THEN +* N/KB IN GLOBAL HOMOGENIZED MIXTURE + RVALOC(ILOC,IBM)=RVALOC(ILOC,IBM)+VV*PARAM(IMILI,1) + VOLIBM(IBM)=VOLIBM(IBM)+VV + ELSE IF(TYPE.EQ.'FLUB') THEN +* N/KB IN FUEL ONLY + DO 35 IS=1,NVAR + IF(JM(IMILI,IS).GT.0) THEN + RVALOC(ILOC,IBM)=RVALOC(ILOC,IBM)+VV*PARAM(IMILI,1) + VOLIBM(IBM)=VOLIBM(IBM)+VV + GO TO 50 + ENDIF + 35 CONTINUE + ELSE IF((TYPE.EQ.'IRRA').OR.(TYPE.EQ.'BURNUP')) THEN +* MWD/TONNE + CALL LCMGET(IPDEPL,'FUELDEN-MIX',WORK) + IF(WORK(IMILI).NE.0.0) THEN + RVALOC(ILOC,IBM)=RVALOC(ILOC,IBM)+PARAM(IMILI,2) + VOLIBM(IBM)=VOLIBM(IBM)+WORK(IMILI) + ENDIF + ELSE IF(TYPE.EQ.'FLUX') THEN + WRITE(CDIRO,'(8HDEPL-DAT,I4.4)') ITIM + CALL LCMSIX(IPDEPL,CDIRO,1) + CALL LCMGET(IPDEPL,'INT-FLUX',PARAM(1,1)) + CALL LCMSIX(IPDEPL,' ',2) + RVALOC(ILOC,IBM)=RVALOC(ILOC,IBM)+VV*1.0E-11*PARAM(IMILI,1)/ + 1 VX(IMILI) + VOLIBM(IBM)=VOLIBM(IBM)+VV + ELSE IF(TYPE.EQ.'PUIS') THEN + WRITE(CDIRO,'(8HDEPL-DAT,I4.4)') ITIM + CALL LCMSIX(IPDEPL,CDIRO,1) + CALL LCMGET(IPDEPL,'MICRO-RATES',SIG) + CALL LCMGET(IPDEPL,'ISOTOPESDENS',DEN) + CALL LCMSIX(IPDEPL,' ',2) + GAR=SIG(NVAR+1,NREAC,IMILI)+SIG(NVAR+1,NREAC+1,IMILI) + DO 40 IS=1,NVAR + IF(JM(IMILI,IS).GT.0) THEN + GAR=GAR+VX(IMILI)*DEN(JM(IMILI,IS))*(SIG(IS,NREAC,IMILI)+ + & SIG(IS,NREAC+1,IMILI)) + ENDIF + 40 CONTINUE + RVALOC(ILOC,IBM)=RVALOC(ILOC,IBM)+VV*1.0E-8*GAR/VX(IMILI) + VOLIBM(IBM)=VOLIBM(IBM)+VV + ELSE IF(TYPE.EQ.'MASL') THEN + CALL LCMGET(IPDEPL,'FUELDEN-MIX',WORK) + IF(WORK(IMILI).GT.0.0) RVALOC(ILOC,IBM)=RVALOC(ILOC,IBM)+ + 1 VV*WORK(IMILI)/VX(IMILI) + VOLIBM(IBM)=VOLIBM(IBM)+VV + ENDIF + 50 CONTINUE + DO 60 IBM=1,NMIL + IF(VOLIBM(IBM).NE.0.0) THEN + RVALOC(ILOC,IBM)=RVALOC(ILOC,IBM)/VOLIBM(IBM) + ENDIF + 60 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(VOLIBM,VOLR,SIG,WORK,VX,VPHV,PARAM,TIME,DEN) + DEALLOCATE(MERG,MATR,JM) + RETURN + END diff --git a/Dragon/src/COMGEP.f b/Dragon/src/COMGEP.f new file mode 100644 index 0000000..7a0cb81 --- /dev/null +++ b/Dragon/src/COMGEP.f @@ -0,0 +1,383 @@ +*DECK COMGEP + SUBROUTINE COMGEP(IPCPO,IPDEPL,IPLB1,IPLB2,IPEDIT,IMPX,ITIM,NORIG, + 1 NPAR,NLOC,NMIL,MUPLET,LGNEW) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover remaining global and local parameters. Update the parameter +* tree (in each mixture) for a new elementary calculation. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPCPO pointer to the multicompo. +* IPDEPL pointer to the burnup object. +* IPLB1 pointer to the first microlib object. +* IPLB2 pointer to the second (optional) microlib object. +* IPEDIT pointer to the edition object. +* IMPX print parameter. +* ITIM index of the current burnup step. +* NORIG index of the elementary calculation associated to the +* father node in the parameter tree. +* NPAR number of global parameters. +* NLOC number of local parameters. +* NMIL number of homogenized mixtures. +* MUPLET tuple of indices associated to each global parameter of the +* elementary calculation. +* LGNEW parameter modification flag (=.true. if the I-th global +* parameter has changed in the new elementary calculation). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPCPO,IPDEPL,IPLB1,IPLB2,IPEDIT + INTEGER IMPX,ITIM,NORIG,NPAR,NLOC,NMIL,MUPLET(NPAR) + LOGICAL LGNEW(NPAR) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40,MAXPAR=50) + TYPE(C_PTR) JPCPO,KPCPO,IPLB3 + INTEGER ISTATE(NSTATE),PARMIL(MAXPAR),PARCAD(MAXPAR+1), + 1 PARPAD(MAXPAR+1),NVPO(2) + CHARACTER PARKEY(MAXPAR)*12,PARCHR(MAXPAR)*8,PARTYP(MAXPAR)*4, + 1 PARBIB(MAXPAR)*12,TEXT4*4,TEXT8*8,TEXT12*12,NAMLCM*12,NAMMY*12 + LOGICAL LGERR,EMPTY,LCM,COMTRE,LAST +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDEBAR,IARBVA,JDEBAR,JARBVA, + 1 IORIGI + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: MUPL2 + REAL, ALLOCATABLE, DIMENSION(:,:) :: RVALO + LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: LGNE2 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(MUPL2(NPAR+NLOC,NMIL),LGNE2(NPAR+NLOC,NMIL)) +*---- +* RECOVER INFORMATION FROM THE 'STATE-VECTOR' PARAMETER LIST +*---- + CALL LCMGET(IPCPO,'STATE-VECTOR',ISTATE) + IF(NPAR.NE.ISTATE(5)) CALL XABORT('COMGEP: WRONG VALUE OF NPAR.') + IF(NLOC.NE.ISTATE(6)) CALL XABORT('COMGEP: WRONG VALUE OF NLOC.') + NMIL=ISTATE(1) + NG=ISTATE(2) + NCAL=ISTATE(3) + MAXCAL=ISTATE(4) + NPCHR=ISTATE(7) + NPPNT=ISTATE(8) + NPCHRL=ISTATE(9) +*---- +* RECOVER INFORMATION FROM THE 'GLOBAL' DIRECTORY +*---- + CALL LCMSIX(IPCPO,'GLOBAL',1) + IF(NPAR.GT.0) CALL LCMGTC(IPCPO,'PARKEY',12,NPAR,PARKEY) + IF(NPAR.GT.0) CALL LCMGTC(IPCPO,'PARTYP',4,NPAR,PARTYP) + CALL LCMGET(IPCPO,'PARCAD',PARCAD) + CALL LCMGET(IPCPO,'PARPAD',PARPAD) + IF(NPCHR.GT.0) CALL LCMGTC(IPCPO,'PARCHR',8,NPCHR,PARCHR) + IF(NPPNT.GT.0) CALL LCMGET(IPCPO,'PARMIL',PARMIL) + IF(NPPNT.GT.0) CALL LCMGTC(IPCPO,'PARBIB',12,NPPNT,PARBIB) + CALL LCMSIX(IPCPO,' ',2) +*---- +* RECOVER REMAINING GLOBAL PARAMETERS +*---- + DO 10 IPAR=1,NPAR + IF(PARTYP(IPAR).EQ.'VALU') THEN + GO TO 10 + ELSE IF(LGNEW(IPAR)) THEN + CALL XABORT('COMGEP: PARAMETER '//PARTYP(IPAR)//' IS ALREADY D' + 1 //'EFINED (REMOVE THE '//PARKEY(IPAR)//' KEYWORD).') + ELSE IF((PARTYP(IPAR).EQ.'IRRA').OR.(PARTYP(IPAR).EQ.'TIME').OR. + 1 (PARTYP(IPAR).EQ.'POWR').OR.(PARTYP(IPAR).EQ.'FLUB').OR. + 2 (PARTYP(IPAR).EQ.'FLUX').OR.(PARTYP(IPAR).EQ.'MASL')) THEN +* +* RECOVER GLOBAL PARAMETER VALUES FROM THE BURNUP OBJECT. + IF(.NOT.C_ASSOCIATED(IPDEPL)) THEN + CALL XABORT('COMGEP: NO DEPLETION OBJECT AVAILABLE AMONG T' + 1 //'HE RHS LCM OBJECTS.') + ENDIF + CALL LCMGET(IPDEPL,'STATE-VECTOR',ISTATE) + NBURN=ISTATE(3) + NBISO=ISTATE(4) + NREAC=ISTATE(6) + NVAR=ISTATE(7) + NBMIX=ISTATE(8) + CALL COMGEM(IPDEPL,ITIM,PARTYP(IPAR),0,NBURN,NBMIX,NBISO, + 1 NREAC,NVAR,VALPAR) + ELSE IF((PARTYP(IPAR).EQ.'TEMP').OR.(PARTYP(IPAR).EQ.'CONC')) + 1 THEN +* +* RECOVER GLOBAL PARAMETER VALUES FROM A MICROLIB OBJECT. + IF(.NOT.C_ASSOCIATED(IPLB1)) THEN + CALL XABORT('COMGEP: MICROLIB EXPECTED AT RHS.') + ENDIF + IPCAD=PARCAD(IPAR+1)-PARCAD(IPAR) + IPPAD=PARPAD(IPAR+1)-PARPAD(IPAR) + IF(IPCAD.EQ.1) IPCAD=PARCAD(IPAR+1)-PARCAD(1) + IF(IPPAD.EQ.1) IPPAD=PARPAD(IPAR+1)-PARPAD(1) + TEXT8=' ' + TEXT12=' ' + IMILI=0 + IF(IPCAD.GT.0) TEXT8=PARCHR(IPCAD) + IF(IPPAD.GT.0) TEXT12=PARBIB(IPPAD) + IF(IPPAD.GT.0) IMILI=PARMIL(IPPAD) + CALL LCMGET(IPLB1,'STATE-VECTOR',ISTATE) + MAXNBI=ISTATE(2) + IF(C_ASSOCIATED(IPLB2)) THEN + CALL LCMGET(IPLB2,'STATE-VECTOR',ISTATE) + MAXNBI=MAX(MAXNBI,ISTATE(2)) + ENDIF + CALL COMBIB(IPLB1,IPLB2,PARTYP(IPAR),IMILI,TEXT12,TEXT8,MAXNBI, + 1 VALPAR) + ELSE + CALL XABORT('COMGEP: '//PARTYP(IPAR)//' IS AN UNKNOWN PARAM'// + 1 'ETER TYPE.') + ENDIF + IF(IMPX.GT.0) WRITE(6,100) PARKEY(IPAR),VALPAR +* + CALL LCMSIX(IPCPO,'GLOBAL',1) + TEXT8='REAL' + CALL COMPAV(IPCPO,IPAR,NPAR,TEXT8,VALPAR,NITMA,TEXT12, + 1 MUPLET(IPAR),LGNEW(IPAR)) + CALL LCMSIX(IPCPO,' ',2) + 10 CONTINUE + DO 25 IBM=1,NMIL + DO 20 IPAR=1,NPAR + MUPL2(IPAR,IBM)=MUPLET(IPAR) + LGNE2(IPAR,IBM)=LGNEW(IPAR) + 20 CONTINUE + 25 CONTINUE + IF(NLOC.EQ.0) GO TO 50 +*---- +* RECOVER INFORMATION FROM THE 'LOCAL' DIRECTORY +*---- + CALL LCMSIX(IPCPO,'LOCAL',1) + CALL LCMGTC(IPCPO,'PARKEY',12,NLOC,PARKEY) + CALL LCMGTC(IPCPO,'PARTYP',4,NLOC,PARTYP) + CALL LCMGET(IPCPO,'PARCAD',PARCAD) + IF(NPCHRL.GT.0) CALL LCMGTC(IPCPO,'PARCHR',8,NPCHRL,PARCHR) + CALL LCMSIX(IPCPO,' ',2) +*---- +* RECOVER LOCAL PARAMETERS +*---- + CALL LCMGTC(IPEDIT,'LAST-EDIT',12,TEXT12) + ALLOCATE(RVALO(NLOC,NMIL)) + DO 45 IPAR=1,NLOC + IF((PARTYP(IPAR).EQ.'IRRA').OR.(PARTYP(IPAR).EQ.'TIME').OR. + 1 (PARTYP(IPAR).EQ.'POWR').OR.(PARTYP(IPAR).EQ.'FLUG').OR. + 2 (PARTYP(IPAR).EQ.'FLUB').OR.(PARTYP(IPAR).EQ.'FLUX').OR. + 3 (PARTYP(IPAR).EQ.'MASL')) THEN +* +* RECOVER LOCAL PARAMETERS FROM THE BURNUP OBJECT. + CALL LCMGET(IPDEPL,'STATE-VECTOR',ISTATE) + NBURN=ISTATE(3) + NBISO=ISTATE(4) + NREAC=ISTATE(6) + NVAR=ISTATE(7) + NBMIX=ISTATE(8) + IF(.NOT.C_ASSOCIATED(IPDEPL)) THEN + CALL XABORT('COMGEP: NO DEPLETION OBJECT AVAILABLE AMONG T' + 1 //'HE RHS LCM OBJECTS.') + ENDIF + CALL LCMGET(IPEDIT,'STATE-VECTOR',ISTATE) + NREG=ISTATE(17) + CALL COMGEN(IPDEPL,IPEDIT,NREG,NMIL,ITIM,PARTYP(IPAR),NBURN, + 1 NBMIX,NBISO,NREAC,NVAR,IPAR,NLOC,RVALO) + ELSE IF((PARTYP(IPAR).EQ.'TEMP').OR.(PARTYP(IPAR).EQ.'CONC')) + 1 THEN +* +* RECOVER LOCAL PARAMETERS FROM THE MICROLIB IN EDIT OBJECT. + IPCAD=PARCAD(IPAR+1)-PARCAD(IPAR) + IF(IPCAD.EQ.1) IPCAD=PARCAD(IPAR+1)-PARCAD(1) + TEXT8=' ' + IF(IPCAD.GT.0) TEXT8=PARCHR(IPCAD) + CALL LCMSIX(IPEDIT,TEXT12,1) + CALL LCMGET(IPEDIT,'STATE-VECTOR',ISTATE) + MAXNBI=ISTATE(2) + CALL LCMINF(IPEDIT,NAMLCM,NAMMY,EMPTY,ILONG,LCM) + IPLB3=C_NULL_PTR + DO 30 IBM=1,NMIL + CALL COMBIB(IPEDIT,IPLB3,PARTYP(IPAR),IBM,NAMLCM,TEXT8,MAXNBI, + 1 VALPAR) + RVALO(IPAR,IBM)=VALPAR + 30 CONTINUE + CALL LCMSIX(IPEDIT,' ',2) + ELSE + CALL XABORT('COMGEP: '//PARTYP(IPAR)//' IS AN UNKNOWN LOCAL'// + 1 ' PARAMETER TYPE.') + ENDIF + IF(IMPX.GT.1) THEN + WRITE(6,120) PARKEY(IPAR),(RVALO(IPAR,IBM),IBM=1,NMIL) + ENDIF + JPCPO=LCMLID(IPCPO,'MIXTURES',NMIL) + DO 40 IBM=1,NMIL + KPCPO=LCMDIL(JPCPO,IBM) + CALL LCMSIX(KPCPO,'TREE',1) + FLOTT=RVALO(IPAR,IBM) + TEXT8='REAL' + CALL COMPAV(KPCPO,IPAR,NLOC,TEXT8,FLOTT,NITMA,TEXT12, + 1 MUPL2(NPAR+IPAR,IBM),LGNE2(NPAR+IPAR,IBM)) + CALL LCMSIX(KPCPO,' ',2) + 40 CONTINUE + 45 CONTINUE + DEALLOCATE(RVALO) +*---- +* UPDATE THE PARAMETER TREE IN EACH MIXTURE COMPONENT +*---- + 50 JPCPO=LCMLID(IPCPO,'MIXTURES',NMIL) + DO 90 IBM=1,NMIL + IF(IMPX.GT.4) THEN + WRITE(6,'(/17H COMGEP: MIXTURE=,I6)') IBM + WRITE(6,110) (MUPL2(I,IBM),I=1,NPAR+NLOC) + WRITE(6,'(/)') + ENDIF + DO 55 I=1,NPAR+NLOC + IF(MUPL2(I,IBM).EQ.0) THEN + WRITE(6,'(/17H COMGEP: MIXTURE=,I6,23H, UNDEFINED MUPLET ELEM, + 1 4HENT=,I6)') IBM,I + CALL XABORT('COMGEP: A MUPLET ELEMENT IS NOT ASSIGNED.') + ENDIF + 55 CONTINUE + KPCPO=LCMDIL(JPCPO,IBM) +** +** Parameter tree: this tree has a number of stages equal to the +** number of parameters. For each value of the i-th parameter, we +** find the position in the tree corresponding to the value of the +** (i+1)-th parameter. +** NCALAR Number of elementary calculations stored in the tree. +** NVPO(1) Number of nodes in the parameter tree, including the root. +** The value corresponding to the root is not used. +** DEBARB - If the node does not correspond to the last parameter: +** index in DEBARB of the first daughter of the node. +** - If the node correspond to the last parameter: index in +** DEBARB where we recover the index of an elementary +** calculation. +** ARBVAL Index of the corresponding parameter in the 'pval'//n +** record. +* +** EXEMPLE: dn = value in DEBARB, (m) = value in ARBVAL +** +** Root *(0) +** ! +** Param. Nb 1 d2(1) +** ------------------- +** ! ! +** Param. Nb 2 d3(1) 4(2) +** --------- --------- +** ! ! ! ! ! +** Param. Nb 3 d5(1) 6(3) d7(1) 8(2) 9(3) d10 +** +** Calculation Nb: 4 5 1 2 3 +** +** DEBARB: 2 3 5 7 10 4 5 1 2 3 +** ARBVAL: 0 1 1 2 1 3 1 2 3 +* + CALL LCMSIX(KPCPO,'TREE',1) + CALL LCMLEN(KPCPO,'NVP',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + MAXNVP=20*(NPAR+NLOC+1) + ALLOCATE(IDEBAR(MAXNVP+1),IARBVA(MAXNVP)) + IDEBAR(:MAXNVP+1)=0 + IARBVA(:MAXNVP)=0 + IARBVA=0 + DO 60 I=1,NPAR+NLOC + IDEBAR(I)=I+1 + IARBVA(I+1)=1 + 60 CONTINUE + IDEBAR(NPAR+NLOC+1)=NPAR+NLOC+2 + IDEBAR(NPAR+NLOC+2)=1 + NCALAR=1 + NVPNEW=NPAR+NLOC+1 + ELSE +* +* Find position of the new point and create new PARBRE. +* +* "II" is the order number of first parameter which recives a +* "brand new" value. +* COMTRE returns .TRUE. if the sweep throught the tree reaches +* its bottom, otherwise it returns "KK" value: level of the +* first new node to be introduced. +* + CALL LCMGET(KPCPO,'NVP',NVPO) + MAXNVP=NVPO(2) + ALLOCATE(JDEBAR(NVPO(1)+1),JARBVA(NVPO(1))) + CALL LCMGET(KPCPO,'NCALS',NCALAR) + CALL LCMGET(KPCPO,'DEBARB',JDEBAR) + CALL LCMGET(KPCPO,'ARBVAL',JARBVA) + DO 70 IPAR=1,NPAR+NLOC + IF(LGNE2(IPAR,IBM)) THEN + II=IPAR + GO TO 80 + ENDIF + 70 CONTINUE + II=NPAR+NLOC+1 + 80 LGERR=COMTRE(NPAR+NLOC,NVPO(1),JARBVA,JDEBAR, + 1 MUPL2(1,IBM),KK,I0,IORD,JJ,LAST) + IF((II.GT.NPAR+NLOC).AND.LGERR) THEN + WRITE(TEXT4,'(I4)') IORD + CALL XABORT('COMGEP: ELEMENTARY CALCULATION HAS THE SAME'// + 1 ' PARAMETERS AS ELEMENTARY CALCULATION NB '//TEXT4) + ENDIF +* +* Size of the new tree. +* + NVPNEW=NVPO(1)+NPAR+NLOC+1-MIN(II,KK) + IF(NVPNEW.GT.MAXNVP) MAXNVP=NVPNEW+MAXNVP + ALLOCATE(IDEBAR(MAXNVP+1),IARBVA(MAXNVP)) + IDEBAR(:MAXNVP+1)=0 + IARBVA(:MAXNVP)=0 +* +* Update values and suppress old PARBRE. +* + CALL COMARB(NPAR+NLOC,NVPO(1),NVPNEW,JDEBAR,JARBVA, + 1 LGNE2(1,IBM),MUPL2(1,IBM),NCALAR,IDEBAR,IARBVA) + DEALLOCATE(JARBVA,JDEBAR) + ENDIF + IF(NCALAR.NE.NCAL) CALL XABORT('COMGEP: INVALID NCALAR.') + NVPO(1)=NVPNEW + NVPO(2)=MAXNVP + CALL LCMPUT(KPCPO,'NVP',2,1,NVPO) + CALL LCMPUT(KPCPO,'NCALS',1,1,NCALAR) + CALL LCMPUT(KPCPO,'DEBARB',NVPNEW+1,1,IDEBAR) + CALL LCMPUT(KPCPO,'ARBVAL',NVPNEW,1,IARBVA) + DEALLOCATE(IARBVA,IDEBAR) + IF(NCALAR.EQ.1) THEN + ALLOCATE(IORIGI(MAXCAL)) + IORIGI(:MAXCAL)=0 + ELSE + CALL LCMLEN(KPCPO,'ORIGIN',MAXOLD,ITYLCM) + IF(MAXOLD.GT.MAXCAL) CALL XABORT('COMGEP: ORIGIN OVERFLOW(1).') + ALLOCATE(IORIGI(MAXCAL)) + IORIGI(:MAXCAL)=0 + CALL LCMGET(KPCPO,'ORIGIN',IORIGI) + ENDIF + IF(NCALAR.GT.MAXCAL) CALL XABORT('COMGEP: ORIGIN OVERFLOW(2).') + IORIGI(NCALAR)=NORIG + CALL LCMPUT(KPCPO,'ORIGIN',NCALAR,1,IORIGI) + DEALLOCATE(IORIGI) + CALL LCMSIX(KPCPO,' ',2) + 90 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(LGNE2,MUPL2) + RETURN +* + 100 FORMAT(31H COMGEP: SET GLOBAL PARAMETER ',A,3H' =,1P,E12.4) + 110 FORMAT(17H COMGEP: MUPLET =,10I6:/(17X,10I6)) + 120 FORMAT(30H COMGEP: SET LOCAL PARAMETER ',A,3H' =,1P,5E12.4/(37X, + 1 5E12.4)) + END diff --git a/Dragon/src/COMGFF.f b/Dragon/src/COMGFF.f new file mode 100644 index 0000000..4a946d1 --- /dev/null +++ b/Dragon/src/COMGFF.f @@ -0,0 +1,118 @@ +*DECK COMGFF + SUBROUTINE COMGFF(MPCPO,IPEDI2,FNORM,NGFF) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover the group form factor information from an edition object. +* +*Copyright: +* Copyright (C) 2015 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* MPCPO pointer to a microlib directory of the multicompo. +* IPEDI2 pointer to the edition object containing group form factor +* information (L_EDIT signature). +* FNORM flux normalization factor. +* NGFF number of form factors per energy group (set to -1 if not +* initialized). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) MPCPO,IPEDI2 + REAL FNORM + INTEGER NGFF +*---- +* LOCAL PARAMETERS +*---- + TYPE(C_PTR) JPEDI2,KPEDI2 + PARAMETER (NSTATE=40) + INTEGER ISTATE(NSTATE) + CHARACTER TEXT12*12 +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: VOLUME + REAL, ALLOCATABLE, DIMENSION(:,:) :: FLUX,HFACT,SIGF +*---- +* RECOVER GFF INFO FROM THE ROOT OF THE EDITION OBJECT +*---- + CALL LCMGTC(IPEDI2,'SIGNATURE',12,TEXT12) + IF(TEXT12.NE.'L_EDIT') THEN + CALL XABORT('COMGFF: SIGNATURE OF OBJECT IS '//TEXT12// + 1 '. L_EDIT EXPECTED.') + ENDIF + CALL LCMGET(IPEDI2,'STATE-VECTOR',ISTATE) + IF(NGFF.EQ.-1) THEN + NGFF=ISTATE(1) + ELSE IF(NGFF.NE.ISTATE(1)) THEN + CALL XABORT('COMGFF: INVALID NUMBER OF FORM FACTORS IN EDITIO' + 1 //'N OBJECT.') + ENDIF + IF(ISTATE(20).EQ.0) CALL XABORT('COMGFF: MISSING MACRO-GEOMETRY ' + 1 //'IN EDITION OBJECT.') + CALL LCMSIX(MPCPO,'MACROLIB',1) + CALL LCMSIX(MPCPO,'GFF',1) +*---- +* RECOVER THE MACRO-GEOMETRY +*---- + CALL LCMSIX(IPEDI2,'MACRO-GEOM',1) + CALL LCMSIX(MPCPO,'GFF-GEOM',1) + CALL LCMEQU(IPEDI2,MPCPO) + CALL LCMSIX(MPCPO,' ',2) + CALL LCMSIX(IPEDI2,' ',2) +*---- +* RECOVER GFF INFO FROM THE LAST-EDIT DIRECTORY IN THE EDITION OBJECT +*---- + CALL LCMGTC(IPEDI2,'LAST-EDIT',12,TEXT12) + CALL LCMSIX(IPEDI2,TEXT12,1) + CALL LCMSIX(IPEDI2,'MACROLIB',1) + CALL LCMGET(IPEDI2,'STATE-VECTOR',ISTATE) + NG=ISTATE(1) + ALLOCATE(VOLUME(NGFF),FLUX(NGFF,NG),HFACT(NGFF,NG), + 1 SIGF(NGFF,NG)) + IF(NGFF.NE.ISTATE(2)) THEN + CALL XABORT('COMGFF: INVALID NUMBER OF FORM FACTORS IN MAC' + 1 //'ROLIB OF THE EDTION OBJECT.') + ENDIF + CALL LCMGET(IPEDI2,'VOLUME',VOLUME) + JPEDI2=LCMGID(IPEDI2,'GROUP') + DO IG=1,NG + KPEDI2=LCMGIL(JPEDI2,IG) + CALL LCMGET(KPEDI2,'FLUX-INTG',FLUX(1,IG)) + DO IBM=1,NGFF + FLUX(IBM,IG)=FNORM*FLUX(IBM,IG)/VOLUME(IBM) + ENDDO + CALL LCMGET(KPEDI2,'H-FACTOR',HFACT(1,IG)) + CALL LCMGET(KPEDI2,'NFTOT',SIGF(1,IG)) + ENDDO + CALL LCMPUT(MPCPO,'VOLUME',NGFF,2,VOLUME) + CALL LCMPUT(MPCPO,'NWT0',NGFF*NG,2,FLUX) + CALL LCMPUT(MPCPO,'H-FACTOR',NGFF*NG,2,HFACT) + CALL LCMPUT(MPCPO,'NFTOT',NGFF*NG,2,SIGF) + DEALLOCATE(SIGF,HFACT,FLUX,VOLUME) + CALL LCMSIX(IPEDI2,' ',2) + CALL LCMSIX(IPEDI2,' ',2) + CALL LCMSIX(MPCPO,' ',2) +*---- +* SET STATE-VECTOR INDEX FOR MICROLIB IN MULTICOMPO +*---- + CALL LCMLEN(MPCPO,'STATE-VECTOR',ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + CALL LCMGET(MPCPO,'STATE-VECTOR',ISTATE) + ISTATE(16)=NGFF + CALL LCMPUT(MPCPO,'STATE-VECTOR',NSTATE,1,ISTATE) + ENDIF + CALL LCMSIX(MPCPO,' ',2) + RETURN + END diff --git a/Dragon/src/COMISO.f b/Dragon/src/COMISO.f new file mode 100644 index 0000000..b308b4c --- /dev/null +++ b/Dragon/src/COMISO.f @@ -0,0 +1,103 @@ +*DECK COMISO + SUBROUTINE COMISO(ITYP,MAXISO,IPLIB,NISO,NOMISO,NOMEVO,TYPISO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover the names of the isotopes stored in a microlib. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ITYP type of operation: +* =0: check the values of the isotope names and types; +* =-1: recover all isotopes; +* =-2: recover fissiles isotopes; +* =-3: recover fission products; +* >0: recover all isotopes in mixture ITYP. +* MAXISO dimension of arrays NOMISO and TYPISO. +* IPLIB pointer to the microlib (L_LIBRARY signature). +* +*Parameters: input/output +* NISO number of particularized isotopes. +* NOMISO alias names of the particularized isotopes. +* +*Parameters: output +* NOMEVO library names of the particularized isotopes. +* TYPISO type of each isotope: +* =1: the isotope is not fissile and not a fission product; +* =2: the isotope is fissile; +* =3: the isotope is a fission product. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + INTEGER ITYP,MAXISO,NISO,TYPISO(MAXISO) + CHARACTER NOMISO(MAXISO)*(*),NOMEVO(MAXISO)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER HNAME*20 + INTEGER ISTATE(NSTATE) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ISUSED,ISNEVO,ISMIX,ISTYP +* + IF(.NOT.C_ASSOCIATED(IPLIB)) RETURN + CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) + NBISOT=ISTATE(2) + ALLOCATE(ISUSED(3*NBISOT),ISNEVO(3*NBISOT),ISMIX(NBISOT), + 1 ISTYP(NBISOT)) + CALL LCMGET(IPLIB,'ISOTOPESUSED',ISUSED) + CALL LCMGET(IPLIB,'ISOTOPERNAME',ISNEVO) + CALL LCMGET(IPLIB,'ISOTOPESMIX',ISMIX) + CALL LCMGET(IPLIB,'ISOTOPESTYPE',ISTYP) + IF(ITYP.EQ.0) THEN + DO 15 ISOT=1,NBISOT + WRITE(HNAME,'(2A4)') (ISUSED((ISOT-1)*3+I0),I0=1,2) + DO 10 I=1,NISO + IF(NOMISO(I).EQ.HNAME) THEN + TYPISO(I)=MAX(TYPISO(I),ISTYP(ISOT)) + WRITE(NOMEVO(I),'(3A4)') (ISNEVO((ISOT-1)*3+I0),I0=1,3) + ENDIF + 10 CONTINUE + 15 CONTINUE + DO 20 I=1,NISO + IF(TYPISO(I).EQ.0) THEN + HNAME=NOMISO(I) + CALL XABORT('COMISO: UNABLE TO FIND ISOTOPE '//TRIM(HNAME)// + 1 ' IN THE MICROLIB.') + ENDIF + 20 CONTINUE + ELSE + DO 40 ISOT=1,NBISOT + WRITE(HNAME,'(2A4)') (ISUSED((ISOT-1)*3+I0),I0=1,2) + DO 30 I=1,NISO + IF(NOMISO(I).EQ.HNAME) GO TO 40 + 30 CONTINUE + IMIX=ISMIX(ISOT) + JTYP=ISTYP(ISOT) + IF((ITYP.EQ.-1).OR.(ITYP.EQ.-JTYP).OR.(ITYP.EQ.IMIX)) THEN + NISO=NISO+1 + NOMISO(NISO)=HNAME + WRITE(NOMEVO(NISO),'(3A4)') (ISNEVO((ISOT-1)*3+I0),I0=1,3) + TYPISO(NISO)=0 + ENDIF + 40 CONTINUE + ENDIF + DEALLOCATE(ISTYP,ISMIX,ISNEVO,ISUSED) + RETURN + END diff --git a/Dragon/src/COMMIC.f b/Dragon/src/COMMIC.f new file mode 100644 index 0000000..746de08 --- /dev/null +++ b/Dragon/src/COMMIC.f @@ -0,0 +1,478 @@ +*DECK COMMIC + SUBROUTINE COMMIC(IMPX,IPCPO,IPEDIT,IPEDI2,LMACRO,ICAL,MAXCAL, + 1 NMIL,NISOTS,NG,NED,NW,FNORM,LISO,NISOP,NOMISP,NGFF,NALBP,IDF, + 2 ITRES) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover a microlib corresponding to a set of homogenized mixtures. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IMPX print parameter. +* IPCPO pointer to the multicompo. +* IPEDIT pointer to the edition object (L_EDIT signature). +* IPEDI2 pointer to the edition object containing group form factor +* information (L_EDIT signature). +* LMACRO flag set to .TRUE. to recover cross sections from the +* macrolib. +* ICAL index of the elementary calculation. +* MAXCAL maximum number of elementary calculations in the multicompo. +* NMIL number of homogenized mixtures. +* NISOTS number of isotopes in the microlib pointed by IPEDIT. +* NG number of energy groups. +* NED number of additional edits. +* NW type of weighting for P1 cross section info (=0: P0 ; =1: P1). +* FNORM flux normalization factor. +* LISO =.true. if we want to register the region number of the +* isotopes. +* NISOP number of user-requested particularized isotopes. Equal to +* zero if all EDI: isotopes are particularized. +* NOMISP names of user-requested particularized isotopes. +* NGFF number of form factors per energy group. +* NALBP number of physical albedos per energy group. +* IDF flag for ADF info (-1/0/1/2: candidate/absent/present). +* +*Parameters: output +* ITRES creation index for the macroscopic residual (=0: not created; +* =1: not a FP precursor; =2: is a FP precursor). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPCPO,IPEDIT,IPEDI2 + INTEGER IMPX,ICAL,MAXCAL,NMIL,NISOTS,NG,NED,NW,NISOP,NGFF,NALBP, + 1 IDF,ITRES + CHARACTER NOMISP(NISOP)*8 + REAL FNORM + LOGICAL LMACRO,LISO +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + TYPE(C_PTR) JPCPO,KPCPO,LPCPO,MPCPO,NPCPO,OPCPO,IPWORK,JPEDIT, + 1 KPEDIT + CHARACTER TEXT4*4,TEXT8*8,TEXT12*12 + INTEGER IPAR(NSTATE),ISTATE(NSTATE) + LOGICAL LRES +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IMIX1,ITYP1,ITOD1,ITYP2, + 1 ITOD2,IPIFI,IPIFI2,ISW + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: HUSE1,HNAM1,HUSE2,HNAM2, + 1 HVECT + REAL, ALLOCATABLE, DIMENSION(:) :: DENS1,TEMP1,VOL1,DENS2,TEMP2, + 1 VOL2,WORK,ENER,ZLAMB,DELT,VOLMIX,PYIELD,PYIEL2,PYRES,ADF2 + REAL, ALLOCATABLE, DIMENSION(:,:) :: ALBP,ADF,ADFM2 + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: ALBP2,ADFM + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HADF +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(HUSE1(3,NISOTS),HNAM1(3,NISOTS),IMIX1(NISOTS), + 1 ITYP1(NISOTS),ITOD1(NISOTS),HUSE2(3,NISOTS),HNAM2(3,NISOTS), + 2 ITYP2(NISOTS),ITOD2(NISOTS),ISW(NISOTS),HVECT(2,NED+1)) + ALLOCATE(DENS1(NISOTS),TEMP1(NISOTS),VOL1(NISOTS),DENS2(NISOTS), + 1 TEMP2(NISOTS),VOL2(NISOTS),WORK(NG),ENER(NG+1),DELT(NG), + 2 VOLMIX(NMIL)) +*---- +* RECOVER THE TOC RECORDS +*---- + IF(.NOT.LMACRO) THEN + CALL LCMGET(IPEDIT,'STATE-VECTOR',IPAR) + CALL LCMGET(IPEDIT,'ISOTOPESUSED',HUSE1) + CALL LCMGET(IPEDIT,'ISOTOPERNAME',HNAM1) + CALL LCMGET(IPEDIT,'ISOTOPESDENS',DENS1) + CALL LCMGET(IPEDIT,'ISOTOPESMIX',IMIX1) + CALL LCMGET(IPEDIT,'ISOTOPESTYPE',ITYP1) + CALL LCMGET(IPEDIT,'ISOTOPESTODO',ITOD1) + CALL LCMGET(IPEDIT,'ISOTOPESVOL',VOL1) + CALL LCMGET(IPEDIT,'ISOTOPESTEMP',TEMP1) + CALL LCMGET(IPEDIT,'MIXTURESVOL',VOLMIX) + CALL LCMLEN(IPEDIT,'K-EFFECTIVE',ILONG,ITYLCM) + IF(ILONG.EQ.1) THEN + CALL LCMGET(IPEDIT,'K-EFFECTIVE',EIGENK) + ELSE + EIGENK=0.0 + ENDIF + CALL LCMLEN(IPEDIT,'K-INFINITY',ILONG,ITYLCM) + IF(ILONG.EQ.1) THEN + CALL LCMGET(IPEDIT,'K-INFINITY',EIGINF) + ELSE + EIGINF=EIGENK + ENDIF + CALL LCMLEN(IPEDIT,'B2 B1HOM',ILONG,ITYLCM) + IF(ILONG.EQ.1) THEN + CALL LCMGET(IPEDIT,'B2 B1HOM',B2) + ELSE + B2=0.0 + ENDIF + IF(NED.GT.0) CALL LCMGET(IPEDIT,'ADDXSNAME-P0',HVECT) + CALL LCMGET(IPEDIT,'ENERGY',ENER) + CALL LCMGET(IPEDIT,'DELTAU',DELT) + NDEL=IPAR(19) + IF(IDF.NE.0) IDF=IPAR(24) + ENDIF +*---- +* LOOP OVER HOMOGENIZED MIXTURES +*---- + TEXT4=' ' + NSPH=0 + READ(TEXT4,'(A4)') ITEXT + JPCPO=LCMLID(IPCPO,'MIXTURES',NMIL) + DO 130 IMIL=1,NMIL + KPCPO=LCMDIL(JPCPO,IMIL) + LPCPO=LCMLID(KPCPO,'CALCULATIONS',MAXCAL) + MPCPO=LCMDIL(LPCPO,ICAL) + ISO3=0 + MAXIS2=1 + IF(.NOT.LMACRO) THEN + ISW(:NISOTS)=0 + DO 30 ISO1=1,NISOTS + IF(IMIX1(ISO1).EQ.IMIL) THEN + IF(NISOP.GT.0) THEN + WRITE(TEXT8,'(2A4)') (HUSE1(I0,ISO1),I0=1,2) + DO 10 JSO=1,NISOP + IF(NOMISP(JSO).EQ.TEXT8) GO TO 20 + 10 CONTINUE + GO TO 30 + ENDIF + 20 MAXIS2=MAXIS2+1 + ENDIF + 30 CONTINUE + ENDIF + NPCPO=LCMLID(MPCPO,'ISOTOPESLIST',MAXIS2) + IF(LMACRO) THEN +* RECOVER CROSS SECTIONS FROM THE MACROLIB. + CALL LCMSIX(IPEDIT,'MACROLIB',1) + CALL LCMGET(IPEDIT,'STATE-VECTOR',IPAR) + NL=IPAR(3) + NF=IPAR(4) + NDEL=IPAR(7) + IF(IDF.NE.0) IDF=IPAR(12) + NSPH=IPAR(14) + ALLOCATE(ZLAMB(NDEL)) + OPCPO=LCMDIL(NPCPO,1) ! set first isotope + CALL COMACR(IPEDIT,IMPX,OPCPO,NG,NMIL,NED,NL,NF,NDEL,NW,IMIL, + 1 FNORM,NSPH,EIGENK,EIGINF,B2,VOLUME,ENER,DELT,HVECT,ZLAMB) + CALL LCMSIX(IPEDIT,' ',2) + NISO2=1 + DENS2(NISO2)=1.0 + ITYP2(NISO2)=1 + IF(NF.GT.0) ITYP2(NISO2)=2 + ITOD2(NISO2)=1 + VOL2(NISO2)=VOLUME + VOLMIX(IMIL)=VOLUME + TEMP2(NISO2)=0.0 + TEXT12='*MAC*RES' + CALL LCMPTC(OPCPO,'ALIAS',12,TEXT12) + READ(TEXT12,'(3A4)') (HUSE2(I0,NISO2),I0=1,3) + READ(TEXT12,'(3A4)') (HNAM2(I0,NISO2),I0=1,3) + IPAR(:NSTATE)=0 + IPAR(3)=NG + IPAR(4)=NL + IPAR(13)=NED+NSPH + IPAR(19)=NDEL + IPAR(24)=IDF + ELSE +* RECOVER CROSS SECTIONS FROM THE MICROLIB. + JPEDIT=LCMGID(IPEDIT,'ISOTOPESLIST') + NISO2=0 + ISW(:NISOTS)=0 + DO 100 ISO1=1,NISOTS + IF(IMIX1(ISO1).EQ.IMIL) THEN + IF(NISOP.GT.0) THEN + WRITE(TEXT8,'(2A4)') (HUSE1(I0,ISO1),I0=1,2) + DO 40 JSO=1,NISOP + IF(NOMISP(JSO).EQ.TEXT8) GO TO 50 + 40 CONTINUE + ISO3=ISO3+1 + ISW(ISO1)=-ISO3 + GO TO 100 + ENDIF + 50 NISO2=NISO2+1 + IF(NISO2.GT.MAXIS2) CALL XABORT('COMMIC: MAXIS2 OVERFLOW.') + ISW(ISO1)=NISO2 + DO 60 I0=1,2 + HUSE2(I0,NISO2)=HUSE1(I0,ISO1) + 60 CONTINUE + HUSE2(3,NISO2)=ITEXT + IF(LISO) HUSE2(3,NISO2)=HUSE1(3,ISO1) + DO 70 I0=1,3 + HNAM2(I0,NISO2)=HNAM1(I0,ISO1) + 70 CONTINUE + DENS2(NISO2)=DENS1(ISO1) + ITYP2(NISO2)=ITYP1(ISO1) + ITOD2(NISO2)=ITOD1(ISO1) + VOL2(NISO2)=VOL1(ISO1) + TEMP2(NISO2)=TEMP1(ISO1) + KPEDIT=LCMGIL(JPEDIT,ISO1) ! set ISO1-th isotope + OPCPO=LCMDIL(NPCPO,NISO2) ! set NISO2-th isotope + CALL LCMEQU(KPEDIT,OPCPO) +* +* FLUX NORMALIZATION: + DO 90 IW=1,MIN(NW+1,10) + WRITE(TEXT12,'(3HNWT,I1)') IW-1 + CALL LCMLEN(OPCPO,TEXT12,ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(OPCPO,TEXT12,WORK) + DO 80 IG=1,NG + WORK(IG)=WORK(IG)*FNORM + 80 CONTINUE + CALL LCMPUT(OPCPO,TEXT12,NG,2,WORK) + ENDIF + 90 CONTINUE + ENDIF + 100 CONTINUE + ENDIF +*---- +* CREATE A NEW MACROSCOPIC RESIDUAL ISOTOPE +*---- + ITRES=0 + ALLOCATE(PYRES(NISO2+1)) + IF(ISO3.GT.0) THEN + NISO2=NISO2+1 + IF(NISO2.GT.MAXIS2) CALL XABORT('COMMIC: MAXIS2 OVERFLOW(2).') + CALL LCMOP(IPWORK,'*TEMPORARY*',0,1,0) + CALL COMRES(IMPX,IPWORK,IPEDIT,NISOTS,NISO2,ISW,FNORM,ITRES, + 1 PYRES) + OPCPO=LCMDIL(NPCPO,NISO2) ! set NISO2-th isotope + CALL LCMEQU(IPWORK,OPCPO) + CALL LCMCL(IPWORK,2) + TEXT12='*MAC*RES' + READ(TEXT12,'(3A4)') (HUSE2(I0,NISO2),I0=1,3) + READ(TEXT12,'(3A4)') (HNAM2(I0,NISO2),I0=1,3) + DENS2(NISO2)=1.0 + ITYP2(NISO2)=ITRES + ITOD2(NISO2)=1 + VOL2(NISO2)=VOL2(NISO2-1) + TEMP2(NISO2)=TEMP2(NISO2-1) + ENDIF + IF(NISO2.EQ.0) GO TO 125 +*---- +* COPY DISCONTINUITY FACTOR INFORMATION AND PERFORM NORMALIZATION +* NOTE: THE NUMBER OF MIXTURES IS ALWAYS EQUAL TO 1 IN THE MULTICOMPO. +*---- + IF(IDF.NE.0) THEN + CALL LCMSIX(IPEDIT,'MACROLIB',1) + CALL LCMLEN(IPEDIT,'ADF',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + CALL LCMLIB(IPEDIT) + CALL XABORT('COMMIC: MISSING ADF INFO IN EDITION OBJECT.') + ENDIF + CALL LCMSIX(IPEDIT,'ADF',1) + CALL LCMSIX(MPCPO,'MACROLIB',1) + CALL LCMSIX(MPCPO,'ADF',1) + IF(IDF.EQ.1)THEN + CALL LCMEQU(IPEDIT,MPCPO) + ALLOCATE(ADF(NG,2)) + CALL LCMGET(MPCPO,'ALBS00',ADF) + DO IG=1,NG + ADF(IG,:2)=ADF(IG,:2)*FNORM + ENDDO + CALL LCMPUT(MPCPO,'ALBS00',NG*2,2,ADF) + DEALLOCATE(ADF) + ELSE IF((IDF.EQ.2).OR.(IDF.EQ.3)) THEN + CALL LCMLEN(IPEDIT,'HADF',NTYPE,ITYLCM) + NTYPE=NTYPE/2 + IF(NTYPE.GT.0) THEN + ALLOCATE(ADF(NMIL,NG),ADF2(NG),HADF(NTYPE)) + CALL LCMPUT(MPCPO,'NTYPE',1,1,NTYPE) + CALL LCMGTC(IPEDIT,'HADF',8,NTYPE,HADF) + CALL LCMPTC(MPCPO,'HADF',8,NTYPE,HADF) + DO ITYPE=1,NTYPE + CALL LCMLEN(IPEDIT,HADF(ITYPE),ILONG,ITYLCM) + IF(ILONG.NE.NMIL*NG) CALL XABORT('COMMIC: INVALID HADF ' + 1 //'LENGTH(1).') + CALL LCMGET(IPEDIT,HADF(ITYPE),ADF) + DO IG=1,NG + ADF2(IG)=ADF(IMIL,IG) + ENDDO + IF(IDF.EQ.2) ADF2(:)=ADF2(:)*FNORM + CALL LCMPUT(MPCPO,HADF(ITYPE),NG,2,ADF2) + ENDDO + CALL LCMLEN(IPEDIT,'AVG_FLUX',ILONG,ITYLCM) + IF(ILONG.EQ.NMIL*NG) THEN + CALL LCMGET(IPEDIT,'AVG_FLUX',ADF) + DO IG=1,NG + ADF2(IG)=ADF(IMIL,IG) + ENDDO + IF(IDF.EQ.2) ADF2(:)=ADF2(:)*FNORM + CALL LCMPUT(MPCPO,'AVG_FLUX',NG,2,ADF2) + ENDIF + DEALLOCATE(HADF,ADF2,ADF) + ENDIF + ELSE IF(IDF.EQ.4) THEN + CALL LCMLEN(IPEDIT,'HADF',NTYPE,ITYLCM) + NTYPE=NTYPE/2 + IF(NTYPE.GT.0) THEN + ALLOCATE(ADFM(NMIL,NG,NG),ADFM2(NG,NG),HADF(NTYPE)) + CALL LCMPUT(MPCPO,'NTYPE',1,1,NTYPE) + CALL LCMGTC(IPEDIT,'HADF',8,NTYPE,HADF) + CALL LCMPTC(MPCPO,'HADF',8,NTYPE,HADF) + DO ITYPE=1,NTYPE + CALL LCMLEN(IPEDIT,HADF(ITYPE),ILONG,ITYLCM) + IF(ILONG.NE.NMIL*NG*NG) CALL XABORT('COMMIC: INVALID HA' + 1 //'DF LENGTH(2).') + CALL LCMGET(IPEDIT,HADF(ITYPE),ADFM) + DO JG=1,NG + DO IG=1,NG + ADFM2(IG,JG)=ADFM(IMIL,IG,JG) + ENDDO + ENDDO + CALL LCMPUT(MPCPO,HADF(ITYPE),NG*NG,2,ADFM2) + ENDDO + DEALLOCATE(HADF,ADFM2,ADFM) + ENDIF + ENDIF + CALL LCMSIX(MPCPO,' ',2) + CALL LCMSIX(MPCPO,' ',2) + CALL LCMSIX(IPEDIT,' ',2) + CALL LCMSIX(IPEDIT,' ',2) + ENDIF +*---- +* RECOVER GROUP FORM FACTOR INFORMATION +*---- + IF(NGFF.NE.0) THEN + IF(.NOT.C_ASSOCIATED(IPEDI2)) THEN + CALL XABORT('COMMIC: MISSING EDITION OBJECT WITH GFF INFO.') + ENDIF + CALL COMGFF(MPCPO,IPEDI2,FNORM,NGFF) + ENDIF +*---- +* RECOVER PHYSICAL ALBEDO INFORMATION +*---- + IF(NALBP.NE.0) THEN + CALL LCMSIX(IPEDIT,'MACROLIB',1) + CALL LCMGET(IPEDIT,'STATE-VECTOR',ISTATE) + IF(NG.NE.ISTATE(1)) CALL XABORT('COMMIC: INVALID NUMBER OF EN' + 1 //'ERGY GROUPS IN EDITION OBJECT.') + IF(NALBP.EQ.-1) THEN + NALBP=ISTATE(8) + ELSE IF(NALBP.NE.ISTATE(8)) THEN + CALL XABORT('COMMIC: INVALID NUMBER OF PHYSICAL ALBEDOS IN' + 1 //' EDITION OBJECT.') + ENDIF + IF(NALBP.NE.0) THEN + CALL LCMLEN(IPEDIT,'ALBEDO',ILONG,ITYLCM) + IF(ILONG.EQ.NALBP*NG) THEN +* diagonal physical albedos + ALLOCATE(ALBP(NALBP,NG)) + CALL LCMGET(IPEDIT,'ALBEDO',ALBP) + CALL LCMSIX(MPCPO,'MACROLIB',1) + CALL LCMPUT(MPCPO,'ALBEDO',NALBP*NG,2,ALBP) + CALL LCMSIX(MPCPO,' ',2) + DEALLOCATE(ALBP) + ELSE IF(ILONG.EQ.NALBP*NG*NG) THEN +* matrix physical albedos + ALLOCATE(ALBP2(NALBP,NG,NG)) + CALL LCMGET(IPEDIT,'ALBEDO',ALBP2) + CALL LCMSIX(MPCPO,'MACROLIB',1) + CALL LCMPUT(MPCPO,'ALBEDO',NALBP*NG*NG,2,ALBP2) + CALL LCMSIX(MPCPO,' ',2) + DEALLOCATE(ALBP2) + ELSE + CALL XABORT('COMMIC: INCONSISTENT ALBEDO INFORMATION.') + ENDIF + ENDIF + CALL LCMSIX(IPEDIT,' ',2) + ENDIF +*---- +* RESET INFORMATION IN LAMBDA-D, PIFI AND PYIELD +*---- + NDFI2=0 + DO 120 ISO=1,NISO2 + IF(LMACRO.AND.(NDEL.GT.0).AND.(ITYP2(ISO).EQ.2)) THEN + OPCPO=LCMGIL(NPCPO,ISO) ! set ISO-th isotope + CALL LCMPUT (OPCPO,'LAMBDA-D',NDEL,2,ZLAMB) + ELSE IF(ITYP2(ISO).EQ.3) THEN + OPCPO=LCMGIL(NPCPO,ISO) ! set ISO-th isotope + CALL LCMLEN(OPCPO,'PIFI',NDFI,ITYLCM) + IF(NDFI.GT.0) THEN + ALLOCATE(IPIFI(NDFI),PYIELD(NDFI),IPIFI2(NDFI+1), + 1 PYIEL2(NDFI+1)) + CALL LCMGET(OPCPO,'PIFI',IPIFI) + CALL LCMGET(OPCPO,'PYIELD',PYIELD) + NDFI2=0 + LRES=.FALSE. + DO 110 I=1,NDFI + IFI=IPIFI(I) + IF(IFI.GT.NISOTS) CALL XABORT('COMMIC: NISOTS OVERFLOW.') + IF(ISW(IFI).GT.0) THEN + NDFI2=NDFI2+1 + IPIFI2(NDFI2)=ISW(IFI) + PYIEL2(NDFI2)=PYIELD(I) + ELSE IF(ISW(IFI).LT.0) THEN + LRES=.TRUE. + ENDIF + 110 ENDDO + IF(LRES) THEN + NDFI2=NDFI2+1 + IPIFI2(NDFI2)=NISO2 + PYIEL2(NDFI2)=PYRES(ISO) + ENDIF + IF(NDFI2.GT.0) THEN + CALL LCMPUT(OPCPO,'PIFI',NDFI2,1,IPIFI2) + CALL LCMPUT(OPCPO,'PYIELD',NDFI2,2,PYIEL2) + ENDIF + DEALLOCATE(PYIEL2,IPIFI2,PYIELD,IPIFI) + ENDIF + ENDIF + 120 CONTINUE +* + IPAR(1)=1 + IPAR(2)=NISO2 + IPAR(11)=0 + IPAR(14)=1 + IPAR(20)=NDFI2 + IPAR(25)=NW + TEXT12='L_LIBRARY' + CALL LCMPTC(MPCPO,'SIGNATURE',12,TEXT12) + CALL LCMPUT(MPCPO,'STATE-VECTOR',NSTATE,1,IPAR) + ISW(:NISO2)=1 + CALL LCMPUT(MPCPO,'ISOTOPESMIX',NISO2,1,ISW) + CALL LCMPUT(MPCPO,'ISOTOPESUSED',3*NISO2,3,HUSE2) + CALL LCMPUT(MPCPO,'ISOTOPERNAME',3*NISO2,3,HNAM2) + CALL LCMPUT(MPCPO,'ISOTOPESDENS',NISO2,2,DENS2) + CALL LCMPUT(MPCPO,'ISOTOPESTYPE',NISO2,1,ITYP2) + CALL LCMPUT(MPCPO,'ISOTOPESTODO',NISO2,1,ITOD2) + CALL LCMPUT(MPCPO,'ISOTOPESVOL',NISO2,2,VOL2) + CALL LCMPUT(MPCPO,'ISOTOPESTEMP',NISO2,2,TEMP2) + CALL LCMPUT(MPCPO,'MIXTURESVOL',1,2,VOLMIX(IMIL)) + IF(EIGENK.NE.0.0) CALL LCMPUT(MPCPO,'K-EFFECTIVE',1,2,EIGENK) + IF(EIGINF.NE.0.0) CALL LCMPUT(MPCPO,'K-INFINITY',1,2,EIGINF) + IF(B2.NE.0.0) CALL LCMPUT(MPCPO,'B2 B1HOM',1,2,B2) + IF((NED+NSPH).GT.0) CALL LCMPUT(MPCPO,'ADDXSNAME-P0',2*(NED+NSPH), + 1 3,HVECT) + CALL LCMPUT(MPCPO,'ENERGY',NG+1,2,ENER) + CALL LCMPUT(MPCPO,'DELTAU',NG,2,DELT) + IF(IMPX.GT.2) WRITE(6,140) IMIL,NISO2 + IF(IMPX.GT.5) CALL LCMLIB(MPCPO) + IF(LMACRO) DEALLOCATE(ZLAMB) + 125 DEALLOCATE(PYRES) + 130 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(VOLMIX,DELT,ENER,WORK,VOL2,TEMP2,DENS2,VOL1,TEMP1, + 1 DENS1) + DEALLOCATE(HVECT,ISW,ITOD2,ITYP2,HNAM2,HUSE2,ITOD1,ITYP1,IMIX1, + 1 HNAM1,HUSE1) + RETURN +* + 140 FORMAT(39H COMMIC: PROCESSING HOMOGENIZED MIXTURE,I4,9H CONTAINI, + 1 2HNG,I5,10H ISOTOPES.) + END diff --git a/Dragon/src/COMPAV.f b/Dragon/src/COMPAV.f new file mode 100644 index 0000000..dc6b3dd --- /dev/null +++ b/Dragon/src/COMPAV.f @@ -0,0 +1,147 @@ +*DECK COMPAV + SUBROUTINE COMPAV(IPCPO,IPAR,NPAR,TYPE,RVAL,IVAL,CVAL,IV,LGNEW) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Return the index of a global or local parameter value. Reorganize the +* 'GLOBAL' or 'LOCAL' directory if required. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPCPO pointer to the 'GLOBAL' or 'LOCAL' directory of the +* multicompo. +* IPAR index of the parameter. +* NPAR total number of parameters. +* TYPE type of the parameter value. +* RVAL parameter value if TYPE='REAL'. +* IVAL parameter value if TYPE='INTEGER'. +* CVAL parameter value if TYPE='STRING'. +* +*Parameters: output +* IV index of the global or local parameter value. +* LGNEW new parameter flag (=.true. if the parameter value is new). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPCPO + INTEGER IPAR,NPAR,IV,IVAL + REAL RVAL + LOGICAL LGNEW + CHARACTER TYPE*8,CVAL*(*) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (REPS=1.0E-4,MAXPAR=50,MAXVAL=1000) + CHARACTER RECNAM*12,VCHAR(MAXVAL)*12 + INTEGER NVALUE(MAXPAR) + INTEGER, ALLOCATABLE, DIMENSION(:) :: VINTE + REAL, ALLOCATABLE, DIMENSION(:) :: VREAL +* + CALL LCMLEN(IPCPO,'NVALUE',ILONG,ITYLCM) + IF(ILONG.EQ.NPAR) THEN + CALL LCMGET(IPCPO,'NVALUE',NVALUE) + ELSE + NVALUE(:NPAR)=0 + ENDIF + WRITE(RECNAM,'(''pval'',I8.8)') IPAR +* + LGNEW=.TRUE. + IF(TYPE.EQ.'REAL') THEN + ALLOCATE(VREAL(NVALUE(IPAR)+1)) + IF(NVALUE(IPAR).EQ.0) THEN + IV=1 + VREAL(IV)=RVAL + NVALUE(IPAR)=1 + ELSE + CALL LCMLEN(IPCPO,RECNAM,ILONG,ITYLCM) + IF(ILONG.GT.NVALUE(IPAR)) CALL XABORT('COMPAV: NVALUE OVER' + 1 //'FLOW(1).') + CALL LCMGET(IPCPO,RECNAM,VREAL) + DO 20 I=1,NVALUE(IPAR) + IF(RVAL.LE.VREAL(I)*(1.+REPS))THEN + IV=I + LGNEW=RVAL.LT.VREAL(IV)*(1.-REPS) + GO TO 30 + ENDIF + 20 CONTINUE + IV=NVALUE(IPAR)+1 + 30 IF(LGNEW) THEN + NVALUE(IPAR)=NVALUE(IPAR)+1 + DO 40 J=NVALUE(IPAR)-1,IV,-1 + VREAL(J+1)=VREAL(J) + 40 CONTINUE + VREAL(IV)=RVAL + ENDIF + ENDIF + IF(LGNEW) CALL LCMPUT(IPCPO,RECNAM,NVALUE(IPAR),2,VREAL) + DEALLOCATE(VREAL) + ELSE IF(TYPE.EQ.'INTEGER') THEN + ALLOCATE(VINTE(NVALUE(IPAR)+1)) + IF(NVALUE(IPAR).EQ.0) THEN + IV=1 + VINTE(IV)=IVAL + NVALUE(IPAR)=1 + ELSE + CALL LCMLEN(IPCPO,RECNAM,ILONG,ITYLCM) + IF(ILONG.GT.NVALUE(IPAR)) CALL XABORT('COMPAV: NVALUE OVER' + 1 //'FLOW(2).') + CALL LCMGET(IPCPO,RECNAM,VINTE) + DO 50 I=1,NVALUE(IPAR) + IF(IVAL.LE.VINTE(I))THEN + IV=I + LGNEW=IVAL.LT.VINTE(IV) + GO TO 60 + ENDIF + 50 CONTINUE + IV=NVALUE(IPAR)+1 + 60 IF(LGNEW) THEN + NVALUE(IPAR)=NVALUE(IPAR)+1 + DO 70 J=NVALUE(IPAR)-1,IV,-1 + VINTE(J+1)=VINTE(J) + 70 CONTINUE + VINTE(IV)=IVAL + ENDIF + ENDIF + IF(LGNEW) CALL LCMPUT(IPCPO,RECNAM,NVALUE(IPAR),1,VINTE) + DEALLOCATE(VINTE) + ELSE IF(TYPE.EQ.'STRING') THEN + IF(NVALUE(IPAR).EQ.0) THEN + IV=1 + VCHAR(IV)=CVAL + NVALUE(IPAR)=1 + ELSE + CALL LCMGTC(IPCPO,RECNAM,12,NVALUE(IPAR),VCHAR) + DO 80 I=1,NVALUE(IPAR) + IF(CVAL.EQ.VCHAR(I))THEN + IV=I + LGNEW=.FALSE. + GO TO 90 + ENDIF + 80 CONTINUE + IV=NVALUE(IPAR)+1 + 90 IF(LGNEW) THEN + NVALUE(IPAR)=NVALUE(IPAR)+1 + IF(NVALUE(IPAR).GT.MAXVAL) CALL XABORT('COMPAV: MAXVAL ' + 1 //'OVERFLOW.') + VCHAR(IV)=CVAL + ENDIF + ENDIF + IF(LGNEW) CALL LCMPTC(IPCPO,RECNAM,12,NVALUE(IPAR),VCHAR) + ENDIF +* + IF(LGNEW) CALL LCMPUT(IPCPO,'NVALUE',NPAR,1,NVALUE) + RETURN + END diff --git a/Dragon/src/COMPO.f b/Dragon/src/COMPO.f new file mode 100644 index 0000000..b8f8fcc --- /dev/null +++ b/Dragon/src/COMPO.f @@ -0,0 +1,711 @@ +*DECK COMPO + SUBROUTINE COMPO(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Creation and construction of a Multicompo database object. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert, R. Chambon +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): multicompo database object; +* HENTRY(I): I>1 read-only type(L_BURNUP, L_LIBRARY, L_EDIT +* or L_FLUX). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40,MAXPAR=50,MAXLIN=50,MAXISO=100,IOUT=6) + TYPE(C_PTR) ICPOLD,IPLB1,IPLB2,IPDEPL,IPEDIT,IPEDI2,IPCPO,IPWORK + CHARACTER TEXT4*4,TEXT8*8,TEXT12*12,TEXT80*80,HPDEPL*12,NAMDIR*12, + 1 HSIGN*12,PARKEY(MAXPAR)*12,PARCHR(MAXPAR)*8,PARTYP(MAXPAR)*4, + 2 PARFMT(MAXPAR)*8,PARBIB(MAXPAR)*12,PARKEL(MAXPAR)*12, + 3 PARCHL(MAXPAR)*8,PARTYL(MAXPAR)*4,HSMG*131,COMMEN(MAXLIN)*80, + 4 NOMISP(MAXISO)*8,NOMEVO(MAXISO)*12 + DOUBLE PRECISION DFLOTT + LOGICAL LINIT,LGNEW(MAXPAR),LMACRO,LWARN,LISO,LCRED + INTEGER ISTATE(NSTATE),MUPLET(MAXPAR),PARMIL(MAXPAR),IST1(NSTATE), + 1 IST2(NSTATE),PARCAD(MAXPAR+1),PARPAD(MAXPAR+1),PARCAL(MAXPAR+1), + 2 TYPISO(MAXISO) +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: TIMES + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPRHS +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IPRHS(NENTRY)) +*---- +* PARAMETER VALIDATION +*---- + LINIT=.FALSE. + IF(NENTRY.EQ.0) CALL XABORT('COMPO: PARAMETERS EXPECTED.') + IF((IENTRY(1).LE.2).AND.(JENTRY(1).EQ.0)) THEN + ICPOLD=KENTRY(1) + LINIT=.TRUE. + HSIGN='L_MULTICOMPO' + CALL LCMPTC(ICPOLD,'SIGNATURE',12,HSIGN) + ELSE IF(IENTRY(1).LE.2) THEN + ICPOLD=KENTRY(1) + LINIT=(NENTRY.EQ.1) + CALL LCMGTC(ICPOLD,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_MULTICOMPO') THEN + TEXT12=HENTRY(1) + CALL XABORT('COMPO: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_MULTICOMPO EXPECTED.') + ENDIF + ELSE + CALL XABORT('COMPO: COMPO LCM OBJECT EXPECTED.') + ENDIF + TYPISO(:MAXISO)=0 + IPLB1=C_NULL_PTR + IPLB2=C_NULL_PTR + IPDEPL=C_NULL_PTR + IPEDIT=C_NULL_PTR + IPEDI2=C_NULL_PTR + IPRHS(:NENTRY)=C_NULL_PTR + HPDEPL=' ' + LCRED=.FALSE. + DO 10 I=2,NENTRY + IF(IENTRY(I).LE.2) THEN + IF(JENTRY(I).NE.2) CALL XABORT('COMPO: READ-ONLY RHS EXPECTE' + 1 //'D.') + CALL LCMGTC(KENTRY(I),'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_LIBRARY') THEN + IF(.NOT.C_ASSOCIATED(IPLB1)) THEN + IPLB1=KENTRY(I) + ELSE + IF(.NOT.C_ASSOCIATED(IPLB2)) IPLB2=KENTRY(I) + ENDIF + ELSE IF(HSIGN.EQ.'L_BURNUP') THEN + IPDEPL=KENTRY(I) + HPDEPL=HENTRY(I) + ELSE IF(HSIGN.EQ.'L_EDIT') THEN + IF(.NOT.C_ASSOCIATED(IPEDIT)) THEN + IPEDIT=KENTRY(I) + ELSE + IF(.NOT.C_ASSOCIATED(IPEDI2)) IPEDI2=KENTRY(I) + ENDIF + ELSE IF(HSIGN.EQ.'L_MACROLIB') THEN + CALL LCMOP(IPEDIT,'*EDITION*',0,1,0) + LCRED=.TRUE. + HSIGN='L_EDIT' + CALL LCMPTC(IPEDIT,'SIGNATURE',12,HSIGN) + NAMDIR='REF-CASE001' + CALL LCMPTC(IPEDIT,'LAST-EDIT',12,NAMDIR) + CALL LCMSIX(IPEDIT,NAMDIR,1) + CALL LCMSIX(IPEDIT,'MACROLIB',1) + CALL LCMEQU(KENTRY(I),IPEDIT) + CALL LCMSIX(IPEDIT,' ',2) + CALL LCMSIX(IPEDIT,' ',2) + ELSE IF(HSIGN.EQ.'L_MULTICOMPO') THEN + IPRHS(I)=KENTRY(I) + ENDIF + ELSE + CALL XABORT('COMPO: LCM OBJECT EXPECTED AT RHS.') + ENDIF + 10 CONTINUE +*---- +* READ THE INPUT DATA +*---- +* DEFAULT OPTIONS: + IMPX=1 + NAMDIR='default' + IPCPO=C_NULL_PTR + LWARN=.FALSE. + LISO=.FALSE. + IF(LINIT) THEN + MAXCAL=10 + NCOMLI=0 + NPAR=0 + NPCHR=0 + NPPNT=0 + NLOC=0 + NPCHRL=0 + NISOP=0 + NMIL=0 + NGFF=0 + NALBP=-1 + IDF=-1 + PARCAD(1)=1 + PARPAD(1)=1 + PARCAL(1)=1 + ELSE + IPICK=0 + GO TO 110 + ENDIF + 20 CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED(1).') + IF(TEXT8.EQ.'EDIT') THEN +* READ THE PRINT INDEX. + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('COMPO: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT8.EQ.'STEP') THEN +* CHANGE THE HIERARCHICAL LEVEL ON THE COMPO. + IF(LINIT) THEN + MAXCAL=10 + NCOMLI=0 + NPAR=0 + NPCHR=0 + NPPNT=0 + NLOC=0 + NPCHRL=0 + NISOP=0 + NMIL=0 + NGFF=0 + NALBP=-1 + PARCAD(1)=1 + PARPAD(1)=1 + PARCAL(1)=1 + ENDIF + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF((INDIC.NE.3).OR.(TEXT4.NE.'UP')) CALL XABORT('COMPO: *UP* ' + 1 //'EXPECTED.') + CALL REDGET(INDIC,NITMA,FLOTT,NAMDIR,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('COMPO: DIR-NAME EXPECTED.') + IF(IMPX.GT.0) WRITE(IOUT,'(/30H COMPO: CREATE A DIRECTORY NAM, + 1 4HED '',A12,36H'' TO STORE THE MULTICOMPO STRUCTURE.)') NAMDIR + ELSE IF(TEXT8.EQ.'MAXCAL') THEN + CALL REDGET(INDIC,MAXCAL,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('COMPO: INTEGER DATA EXPECTED(2).') + ELSE IF(TEXT8.EQ.'COMM') THEN + 40 CALL REDGET(INDIC,NITMA,FLOTT,TEXT80(:72),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('COMPO: COMMENTS EXPECTED.') + IF(TEXT80(:4).EQ.'ENDC') THEN + IPCPO=LCMDID(ICPOLD,NAMDIR) + CALL LCMPTC(IPCPO,'COMMENT',80,NCOMLI,COMMEN) + IPCPO=C_NULL_PTR + GO TO 20 + ENDIF + NCOMLI=NCOMLI+1 + IF(NCOMLI.GT.MAXLIN) CALL XABORT('COMPO: TITLE OVERFLOW.') + COMMEN(NCOMLI)=TEXT80(:72) + GO TO 40 + ELSE IF(TEXT8.EQ.'PARA') THEN + NPAR=NPAR+1 + IF(NPAR.GT.MAXPAR) CALL XABORT('COMPO: TOO MANY GLOBAL PARAME' + 1 //'TERS(1).') + CALL REDGET(INDIC,NITMA,FLOTT,PARKEY(NPAR),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED' + 1 //'(2).') + DO 50 I=1,NPAR-1 + IF(PARKEY(NPAR).EQ.PARKEY(I)) CALL XABORT('COMPO: PARKEY '// + 1 PARKEY(NPAR)//' ALREADY DEFINED(1).') + 50 CONTINUE + DO 60 I=1,NLOC + IF(PARKEY(NPAR).EQ.PARKEL(I)) CALL XABORT('COMPO: PARKEY '// + 1 PARKEY(NPAR)//' ALREADY DEFINED(2).') + 60 CONTINUE + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED' + 1 //'(3).') + IF(TEXT4.EQ.'TEMP') THEN + NPPNT=NPPNT+1 + CALL REDGET(INDIC,NITMA,FLOTT,PARBIB(NPPNT),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED' + 1 //'(4).') + CALL REDGET(INDIC,PARMIL(NPPNT),FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('COMPO: INTEGER DATA EXPECTE'// + 1 'D(3).') + PARFMT(NPAR)='REAL' + ELSE IF(TEXT4.EQ.'CONC') THEN + NPCHR=NPCHR+1 + CALL REDGET(INDIC,NITMA,FLOTT,PARCHR(NPCHR),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED' + 1 //'(5).') + NPPNT=NPPNT+1 + CALL REDGET(INDIC,NITMA,FLOTT,PARBIB(NPPNT),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED' + 1 //'(6).') + CALL REDGET(INDIC,PARMIL(NPPNT),FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('COMPO: INTEGER DATA EXPECTE'// + 1 'D(4).') + PARFMT(NPAR)='REAL' + ELSE IF(TEXT4.EQ.'IRRA') THEN + PARFMT(NPAR)='REAL' + ELSE IF(TEXT4.EQ.'FLUE') THEN + PARFMT(NPAR)='REAL' + ELSE IF(TEXT4.EQ.'FLUB') THEN + PARFMT(NPAR)='REAL' + ELSE IF(TEXT4.EQ.'POWR') THEN + PARFMT(NPAR)='REAL' + ELSE IF(TEXT4.EQ.'TIME') THEN + PARFMT(NPAR)='REAL' + ELSE IF(TEXT4.EQ.'VALU') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED' + 1 //'(7).') + IF(TEXT8.EQ.'REAL')THEN + PARFMT(NPAR)='REAL' + ELSEIF(TEXT8.EQ.'CHAR')THEN + PARFMT(NPAR)='STRING' + ELSEIF(TEXT8.EQ.'INTE')THEN + PARFMT(NPAR)='INTEGER' + ELSE + CALL XABORT('COMPO: INVALID KEYWORD='//TEXT8//' (1).') + ENDIF + ELSE + CALL XABORT('COMPO: INVALID KEYWORD='//TEXT4//' (2).') + ENDIF + PARTYP(NPAR)=TEXT4 + PARCAD(NPAR+1)=NPCHR+1 + PARPAD(NPAR+1)=NPPNT+1 + ELSE IF(TEXT8.EQ.'LOCA') THEN + NLOC=NLOC+1 + IF(NLOC.GT.MAXPAR) CALL XABORT('COMPO: TOO MANY LOCAL PARAM'// + 1 'ETERS(1).') + CALL REDGET(INDIC,NITMA,FLOTT,PARKEL(NLOC),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED' + 1 //'(8).') + DO 70 I=1,NLOC-1 + IF(PARKEL(NLOC).EQ.PARKEL(I)) CALL XABORT('COMPO: PARKEY '// + 1 PARKEL(NLOC)//' ALREADY DEFINED(3).') + 70 CONTINUE + DO 80 I=1,NPAR + IF(PARKEL(NLOC).EQ.PARKEY(I)) CALL XABORT('COMPO: PARKEY '// + 1 PARKEL(NLOC)//' ALREADY DEFINED(4).') + 80 CONTINUE + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED' + 1 //'(9).') + IF(TEXT4.EQ.'CONC') THEN + NPCHRL=NPCHRL+1 + CALL REDGET(INDIC,NITMA,FLOTT,PARCHL(NPCHRL),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED' + 1 //'(10).') + ELSE IF((TEXT4.NE.'IRRA').AND.(TEXT4.NE.'FLUG').AND. + 1 (TEXT4.NE.'FLUB').AND.(TEXT4.NE.'POWR').AND. + 2 (TEXT4.NE.'MASL').AND.(TEXT4.NE.'FLUX').AND. + 3 (TEXT4.NE.'TEMP')) THEN + CALL XABORT('COMPO: INVALID KEYWORD='//TEXT4//' (3).') + ENDIF + PARTYL(NLOC)=TEXT4 + PARCAL(NLOC+1)=NPCHRL+1 + ELSE IF(TEXT8.EQ.'ISOT') THEN + CALL REDGET(INDIC,NISOP,FLOTT,TEXT8,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('COMPO: INTEGER DATA EXPECTED(5).') + IF(NISOP.GT.MAXISO) CALL XABORT('COMPO: MAXISO OVERFLOW.') + DO 100 ISO=1,NISOP + CALL REDGET(INDIC,NITMA,FLOTT,NOMISP(ISO),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED(11' + 1 //').') + IF(NOMISP(ISO).EQ.'*MAC*RES') CALL XABORT('COMPO: *MAC*RES CA' + 1 //'NNOT BE SELECTED.') + 100 CONTINUE + ELSE IF(TEXT8.EQ.'GFF') THEN + NGFF=-1 + ELSE IF(TEXT8.EQ.'NOALBP') THEN + NALBP=0 + ELSE IF(TEXT8.EQ.'ALBP') THEN + NALBP=-1 + ELSE IF(TEXT8.EQ.'NOJSURF') THEN + IDF=0 + ELSE IF(TEXT8.EQ.'JSURF') THEN + IDF=-1 + ELSE IF(TEXT8.EQ.'INIT') THEN + IPCPO=LCMDID(ICPOLD,NAMDIR) + CALL LCMSIX(IPCPO,'GLOBAL',1) + IF(NPAR.GT.0) THEN + CALL LCMPTC(IPCPO,'PARKEY',12,NPAR,PARKEY) + CALL LCMPTC(IPCPO,'PARTYP',4,NPAR,PARTYP) + CALL LCMPTC(IPCPO,'PARFMT',8,NPAR,PARFMT) + ENDIF + IF(NPCHR.GT.0) CALL LCMPTC(IPCPO,'PARCHR',8,NPCHR,PARCHR) + CALL LCMPUT(IPCPO,'PARCAD',NPAR+1,1,PARCAD) + CALL LCMPUT(IPCPO,'PARPAD',NPAR+1,1,PARPAD) + IF(NPPNT.GT.0) CALL LCMPUT(IPCPO,'PARMIL',NPPNT,1,PARMIL) + IF(NPPNT.GT.0) CALL LCMPTC(IPCPO,'PARBIB',12,NPPNT,PARBIB) + CALL LCMSIX(IPCPO,' ',2) +* + IF(NLOC.GT.0) THEN + CALL LCMSIX(IPCPO,'LOCAL',1) + CALL LCMPTC(IPCPO,'PARKEY',12,NLOC,PARKEL) + CALL LCMPTC(IPCPO,'PARTYP',4,NLOC,PARTYL) + IF(NPCHRL.GT.0) CALL LCMPTC(IPCPO,'PARCHR',8,NPCHRL,PARCHL) + CALL LCMPUT(IPCPO,'PARCAD',NLOC+1,1,PARCAL) + CALL LCMSIX(IPCPO,' ',2) + ENDIF +* + IF(NISOP.GT.0) CALL LCMPTC(IPCPO,'NOMISP',8,NISOP,NOMISP) + ISTATE(:NSTATE)=0 + ISTATE(1)=NMIL + ISTATE(4)=MAXCAL + ISTATE(5)=NPAR + ISTATE(6)=NLOC + ISTATE(7)=NPCHR + ISTATE(8)=NPPNT + ISTATE(9)=NPCHRL + ISTATE(10)=NCOMLI + ISTATE(12)=2006 + ISTATE(13)=NISOP + ISTATE(14)=NGFF + ISTATE(15)=NALBP + ISTATE(16)=IDF + CALL LCMPUT(IPCPO,'STATE-VECTOR',NSTATE,1,ISTATE) + IF(IMPX.GT.0) WRITE(IOUT,400) NAMDIR,IMPX,(ISTATE(I),I=1,16) + IF(IMPX.GT.4) CALL LCMLIB(IPCPO) + ELSE IF(TEXT8.EQ.'DB-STRUC') THEN + GO TO 300 + ELSE IF(TEXT8.EQ.';') THEN + IF(.NOT.C_ASSOCIATED(IPCPO)) CALL XABORT('COMPO: INIT NOT SET') + GO TO 390 + ELSE + CALL XABORT('COMPO: INVALID KEYWORD='//TEXT8//' (4).') + ENDIF + GO TO 20 +* END OF COMPO INITIALIZATION. ********************************** +* + 110 CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF((INDIC.EQ.10).AND.(NENTRY.GE.2)) THEN + IF(C_ASSOCIATED(IPRHS(2))) GO TO 230 + ENDIF + IF(INDIC.EQ.10) GO TO 180 + IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED(12).') + IF(TEXT12.EQ.'EDIT') THEN +* READ THE PRINT INDEX. + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('COMPO: INTEGER DATA EXPECTED(6).') + ELSE IF (TEXT12.EQ.'ALLX') THEN + LISO=.TRUE. + ELSE IF(TEXT12.EQ.'STEP') THEN +* CHANGE THE HIERARCHICAL LEVEL ON THE COMPO. + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF((INDIC.NE.3).OR.(TEXT4.NE.'UP')) CALL XABORT('COMPO: *UP* ' + 1 //'EXPECTED.') + CALL REDGET(INDIC,NITMA,FLOTT,NAMDIR,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('COMPO: DIR-NAME EXPECTED.') + IF(NAMDIR.EQ.'*') THEN + IF(.NOT.C_ASSOCIATED(IPEDIT)) CALL XABORT('COMPO: * NOT AL' + 1 //'LOWED.') + CALL LCMGTC(IPEDIT,'LAST-EDIT',12,NAMDIR) + ENDIF + CALL LCMLEN(ICPOLD,NAMDIR,ILENG,ITYLCM) + IF((ILENG.EQ.0).OR.(ITYLCM.NE.0)) THEN + CALL LCMLIB(ICPOLD) + CALL XABORT('COMPO: NO '//NAMDIR//' DIRECTORY TO STEP.') + ENDIF + IF(IMPX.GT.0) WRITE(IOUT,'(/30H COMPO: ACCESS A DIRECTORY NAM, + 1 4HED '',A12,36H'' TO STORE THE MULTICOMPO STRUCTURE.)') NAMDIR + ELSE IF(TEXT12.EQ.'ORIG') THEN + CALL REDGET(INDIC,NORIG,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('COMPO: INTEGER DATA EXPECTED(7).') + ELSE + GO TO 120 + ENDIF + GO TO 110 +* + 120 ITIM=0 + IPCPO=LCMGID(ICPOLD,NAMDIR) + CALL LCMGET(IPCPO,'STATE-VECTOR',ISTATE) + NCALS=ISTATE(3) + NPAR=ISTATE(5) + IF(NPAR.GT.MAXPAR) CALL XABORT('COMPO: TOO MANY GLOBAL PARAMETER' + 1 //'S(2).') + NLOC=ISTATE(6) + IF(NLOC.GT.MAXPAR) CALL XABORT('COMPO: TOO MANY LOCAL PARAMETERS' + 1 //'(2).') + NORIG=ISTATE(3) + IF(NPAR.GT.0) THEN + CALL LCMSIX(IPCPO,'GLOBAL',1) + CALL LCMGTC(IPCPO,'PARKEY',12,NPAR,PARKEY) + CALL LCMGTC(IPCPO,'PARTYP',4,NPAR,PARTYP) + CALL LCMGTC(IPCPO,'PARFMT',8,NPAR,PARFMT) + CALL LCMSIX(IPCPO,' ',2) + ENDIF + DO 130 I=1,NPAR + MUPLET(I)=0 + LGNEW(I)=.FALSE. + 130 CONTINUE + IF(NENTRY.EQ.1) THEN + CALL XABORT('COMPO: NO COMPO OR EDITION OBJECTS AT RHS(1).') + ELSE IF(C_ASSOCIATED(IPRHS(2))) THEN + GO TO 200 + ELSE IF(.NOT.C_ASSOCIATED(IPEDIT)) THEN + CALL XABORT('COMPO: NO COMPO OR EDITION OBJECTS AT RHS(2).') + ENDIF +*---- +* INPUT AN ELEMENTARY CALCULATION FROM AN EDITION OBJECT ******** +*---- + LMACRO=.FALSE. + IF(LCRED) LMACRO=.TRUE. + NCALS=NCALS+1 + IF(IMPX.GT.0) WRITE(IOUT,420) NCALS,NAMDIR +* + 140 IF(TEXT12.EQ.'SET') THEN + CALL REDGET(INDIC,NITMA,XT,TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('COMPO: REAL DATA EXPECTED(1).') + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED' + 1 //'(13).') + IF(TEXT4.EQ.'S') THEN + XT=XT*1.0E-8 + ELSE IF(TEXT4.EQ.'DAY') THEN + XT=XT*8.64E-4 + ELSE IF(TEXT4.EQ.'YEAR') THEN + XT=XT*3.1536E-1 + ELSE + CALL XABORT('COMPO: S, DAY OR YEAR EXPECTED.') + ENDIF + IF(.NOT.C_ASSOCIATED(IPDEPL)) CALL XABORT('COMPO: DEPLETION O' + 1 //'BJECT EXPECTED AT RHS.') + CALL LCMLEN(IPDEPL,'DEPL-TIMES',NTIM,ITYLCM) + IF(NTIM.EQ.0) CALL XABORT('COMPO: NO DEPLETION TIME STEPS.') + ALLOCATE(TIMES(NTIM)) + CALL LCMGET(IPDEPL,'DEPL-TIMES',TIMES) + DO 150 I=1,NTIM + IF(ABS(TIMES(I)-XT).LE.1.0E-4*XT) ITIM=I + 150 CONTINUE + IF(ITIM.EQ.0) THEN + WRITE(HSMG,'(41HCOMPO: UNABLE TO FIND A DEPLETION DIRECTO, + 1 12HRY AT TIME =,1P,E12.4,5H DAY.)') XT/8.64E-4 + CALL XABORT(HSMG) + ENDIF + DEALLOCATE(TIMES) + IF(IMPX.GT.0) THEN + WRITE(TEXT12,'(8HDEPL-DAT,I4.4)') ITIM + WRITE(IOUT,430) XT,XT/8.64E-4,TEXT12 + ENDIF + ELSE IF(TEXT12.EQ.'MACRO') THEN + LMACRO=.TRUE. + ELSE IF(TEXT12.EQ.';') THEN + GO TO 180 + ELSE IF(TEXT12.EQ.'ICAL') THEN + IPICK=1 + GO TO 180 + ELSE + DO 160 IKEY=1,NPAR + IF(TEXT12.EQ.PARKEY(IKEY)) THEN + IPAR=IKEY + GO TO 170 + ENDIF + 160 CONTINUE + CALL XABORT('COMPO: INVALID KEYWORD='//TEXT12//' (5).') + 170 CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(PARFMT(IPAR).EQ.'INTEGER') THEN + IF(INDIC.NE.1) CALL XABORT('COMPO: INTEGER DATA EXPECTE'// + 1 'D(8).') + IF(IMPX.GT.0) WRITE(IOUT,450) PARKEY(IPAR),NITMA + ELSE IF(PARFMT(IPAR).EQ.'REAL') THEN + IF(INDIC.NE.2) CALL XABORT('COMPO: REAL DATA EXPECTED(2).') + IF(IMPX.GT.0) WRITE(IOUT,440) PARKEY(IPAR),FLOTT + ELSE IF(PARFMT(IPAR).EQ.'STRING') THEN + IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPEC'// + 1 'TED(14).') + IF(IMPX.GT.0) WRITE(IOUT,460) PARKEY(IPAR),TEXT12 + ENDIF + CALL LCMSIX(IPCPO,'GLOBAL',1) + CALL COMPAV(IPCPO,IPAR,NPAR,PARFMT(IPAR),FLOTT,NITMA,TEXT12, + 1 MUPLET(IPAR),LGNEW(IPAR)) + CALL LCMSIX(IPCPO,' ',2) + ENDIF + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED(15).') + GO TO 140 +*---- +* RECOVER AN ELEMENTARY CALCULATION +*---- + 180 IF(IMPX.GT.0) THEN + WRITE(IOUT,'(24H COMPO: PROCESS DEPL-DAT,I4.4,11H DIRECTORY.)') + 1 ITIM + ENDIF + IF(ITIM.GT.0) THEN + WRITE(TEXT12,'(8HDEPL-DAT,I4.4)') ITIM + CALL LCMSIX(IPDEPL,TEXT12,1) + ENDIF + CALL LCMGTC(IPEDIT,'LAST-EDIT',12,TEXT12) + CALL LCMSIX(IPEDIT,TEXT12,1) + CALL LCMLEN(IPEDIT,'SIGNATURE',ILENG,ITYLCM) + IF(ILENG.EQ.0) LMACRO=.TRUE. + CALL LCMSIX(IPEDIT,' ',2) +* -------------------------------------------------------------- + CALL COMCAL(IMPX,IPCPO,IPDEPL,IPEDIT,IPEDI2,LMACRO,LISO,ITRES) +* -------------------------------------------------------------- + IF(ITIM.GT.0) CALL LCMSIX(IPDEPL,' ',2) +*---- +* RECOVER THE DEPLETION CHAIN +*---- + CALL LCMGTC(IPEDIT,'LAST-EDIT',12,TEXT12) + CALL LCMSIX(IPEDIT,TEXT12,1) + CALL LCMLEN(IPEDIT,'DEPL-CHAIN',ILENG1,ITYLCM) + IF(ILENG1.NE.0) THEN + CALL LCMGET(IPCPO,'STATE-VECTOR',ISTATE) + NISOP=ISTATE(13) + IF(NISOP.GT.0) THEN + CALL LCMGTC(IPCPO,'NOMISP',8,NISOP,NOMISP) + CALL COMISO(0,MAXISO,IPEDIT,NISOP,NOMISP,NOMEVO,TYPISO) + ENDIF + CALL LCMOP(IPWORK,'*TEMPORARY*',0,1,0) + CALL COMDEP(IMPX,IPEDIT,IPWORK,ITRES,NISOP,NOMEVO) + CALL LCMLEN(IPCPO,'DEPL-CHAIN',ILENG2,ITYLCM) + IF(ILENG2.NE.0) THEN + CALL LCMSIX(IPWORK,'DEPL-CHAIN',1) + CALL LCMGET(IPWORK,'STATE-VECTOR',IST1) + CALL LCMSIX(IPWORK,' ',2) + CALL LCMSIX(IPCPO,'DEPL-CHAIN',1) + CALL LCMGET(IPCPO,'STATE-VECTOR',IST2) + CALL LCMSIX(IPCPO,' ',2) + DO 190 I=1,NSTATE + IF(IST1(I).NE.IST2(I)) THEN + WRITE(HSMG,'(39HCOMPO: INVALID STATE-VECTOR COMPONENT (, + 1 I2,40H) FOR DEPL-CHAIN DATA IN EDITION OBJECT.)') I + CALL XABORT(HSMG) + ENDIF + 190 CONTINUE + ELSE + CALL LCMEQU(IPWORK,IPCPO) + ENDIF + CALL LCMCL(IPWORK,2) + ENDIF + CALL LCMSIX(IPEDIT,' ',2) +*---- +* RECOVER REMAINING GLOBAL AND LOCAL PARAMETERS +*---- + CALL LCMGET(IPCPO,'STATE-VECTOR',ISTATE) + NMIL=ISTATE(1) + CALL COMGEP(IPCPO,IPDEPL,IPLB1,IPLB2,IPEDIT,IMPX,ITIM,NORIG,NPAR, + 1 NLOC,NMIL,MUPLET,LGNEW) +* + IF(IMPX.GT.0) WRITE(IOUT,400) NAMDIR,IMPX,(ISTATE(I),I=1,16) + IF(IMPX.GT.4) CALL LCMLIB(IPCPO) + IF(LCRED) CALL LCMCL(IPEDIT,2) +*---- +* RECOVER THE CALCULATION INDEX AND SAVE IT IN A CLE-2000 VARIABLE +*---- + IF(IPICK.EQ.1) THEN + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF(ITYP.NE.-1) CALL XABORT('COMPO: OUTPUT INTEGER EXPECTED.') + ITYP=1 + NITMA=ISTATE(3) + CALL REDPUT(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF((ITYP.NE.3).OR.(TEXT12.NE.';')) THEN + CALL XABORT('COMPO: ; CHARACTER EXPECTED.') + ENDIF + ENDIF + GO TO 390 +*---- +* INPUT A SET OF ELEMENTARY CALCULATIONS FROM A COMPO ********** +*---- + 200 IF(TEXT12.EQ.';') THEN + GO TO 230 + ELSE IF(TEXT12.EQ.'WARNING-ONLY') THEN + LWARN=.TRUE. + ELSE + DO 210 IKEY=1,NPAR + IF(TEXT12.EQ.PARKEY(IKEY)) THEN + IPAR=IKEY + GO TO 220 + ENDIF + 210 CONTINUE + CALL XABORT('COMPO: INVALID KEYWORD='//TEXT12//' (6).') + 220 IF(PARTYP(IPAR).NE.'VALU') CALL XABORT('COMPO: '//TEXT12// + 1 ' IS NOT OF VALU TYPE.') + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(PARFMT(IPAR).EQ.'INTEGER') THEN + IF(INDIC.NE.1) CALL XABORT('COMPO: INTEGER DATA EXPECTE'// + 1 'D(9).') + IF(IMPX.GT.0) WRITE(IOUT,450) PARKEY(IPAR),NITMA + ELSE IF(PARFMT(IPAR).EQ.'REAL') THEN + IF(INDIC.NE.2) CALL XABORT('COMPO: REAL DATA EXPECTED(3).') + IF(IMPX.GT.0) WRITE(IOUT,440) PARKEY(IPAR),FLOTT + ELSE IF(PARFMT(IPAR).EQ.'STRING') THEN + IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPEC'// + 1 'TED(16).') + IF(IMPX.GT.0) WRITE(IOUT,460) PARKEY(IPAR),TEXT12 + ENDIF + CALL LCMSIX(IPCPO,'GLOBAL',1) + CALL COMPAV(IPCPO,IPAR,NPAR,PARFMT(IPAR),FLOTT,NITMA,TEXT12, + 1 MUPLET(IPAR),LGNEW(IPAR)) + CALL LCMSIX(IPCPO,' ',2) + ENDIF + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED(17).') + GO TO 200 + 230 DO 240 I=2,NENTRY + IF(.NOT.C_ASSOCIATED(IPRHS(I))) GO TO 240 + IPRHS(I)=LCMGID(IPRHS(I),NAMDIR) + CALL LCMGET(IPRHS(I),'STATE-VECTOR',ISTATE) + IF(IMPX.GT.0) WRITE(IOUT,470) NCALS+1,NCALS+ISTATE(3),NAMDIR +* --------------------------------------------------------- + CALL COMCAT(IPCPO,IPRHS(I),NORIG,NPAR,MUPLET,LGNEW,LWARN) +* --------------------------------------------------------- + NCALS=NCALS+ISTATE(3) + 240 CONTINUE +* + IF(IMPX.GT.0) THEN + CALL LCMGET(IPCPO,'STATE-VECTOR',ISTATE) + WRITE(IOUT,400) NAMDIR,IMPX,(ISTATE(I),I=1,15) + ENDIF + IF(IMPX.GT.4) CALL LCMLIB(IPCPO) + GO TO 390 +*---- +* Display the COMPO structure********** +*---- + 300 IPCPO=LCMGID(ICPOLD,NAMDIR) + CALL COMSDB(IMPX,IPCPO) + CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) + IF(TEXT8.NE.';') CALL XABORT('COMPO: ";" expected.') +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 390 DEALLOCATE(IPRHS) + RETURN + +* + 400 FORMAT(/29H COMPO: STATE-VECTOR VALUES (,A12,1H)/1X,26(1H-)/ + 1 7H IMPX ,I7,22H (0=NO PRINT/1=SHORT)/ + 2 7H NMIL ,I7,28H (NB. OF MIXTURES IN COMPO)/ + 3 7H NG ,I7,33H (NB. OF ENERGY GROUPS IN COMPO)/ + 4 7H NCALS ,I7,34H (NB. OF ELEMENTARY CALCULATIONS)/ + 5 7H MAXCAL,I7,42H (MAXIMUM NB. OF ELEMENTARY CALCULATIONS)/ + 6 7H NPAR ,I7,28H (NB. OF GLOBAL PARAMETERS)/ + 7 7H NLOC ,I7,27H (NB. OF LOCAL PARAMETERS)/ + 8 7H NPCHR ,I7,47H (NB. OF GLOBAL PARAMETERS LINKED TO ISOTOPES)/ + 9 7H NPPNT ,I7,48H (NB. OF GLOBAL PARAMETERS LINKED TO LIBRARIES)/ + 1 7H NPCHRL,I7,46H (NB. OF LOCAL PARAMETERS LINKED TO ISOTOPES)/ + 2 7H NCOMLI,I7,27H (NB. OF LINES OF COMMENT)/ + 3 7H LGEOM ,I7,34H (0/1: GEOMETRIES ABSENT/PRESENT)/ + 4 7H LSPEC ,I7,34H (COMPO SPECIFICATION IDENTIFIER)/ + 5 7H NISOP ,I7,47H (NB. OF USER-REQUESTED PARTICULARIZED ISOTOPE, + 6 2HS)/ + 7 7H NGFF ,I7,38H (0: NO GENERALIZED FORM FACTOR INFO)/ + 8 7H NALBP ,I7,30H (0: NO PHYSICAL ALBEDO INFO)/ + 9 7H IDF ,I7,35H (0: NO DISCONTINUITY FACTOR INFO)) + 420 FORMAT(/1X,63(1H*)/36H * COMPO: ELEMENTARY CALCULATION NB.,I8, + 1 4X,1H(,A12,3H) */1X,63(1H*)) + 430 FORMAT(/43H COMPO: RECOVER INFORMATION RELATED TO TIME,1P,E12.4, + 1 8H E+8 S (,E12.4,32H DAY) FROM LCM DIRECTORY NAMED ',A12,2H'.) + 440 FORMAT(30H COMPO: SET GLOBAL PARAMETER ',A,3H' =,1P,E12.4) + 450 FORMAT(30H COMPO: SET GLOBAL PARAMETER ',A,3H' =,I10) + 460 FORMAT(30H COMPO: SET GLOBAL PARAMETER ',A,5H' = ',A12,1H') + 470 FORMAT(/1X,75(1H*)/37H * COMPO: ELEMENTARY CALCULATIONS NB.,I8, + 1 3H TO,I8,4X,1H(,A12,3H) */1X,75(1H*)) + END diff --git a/Dragon/src/COMRES.f b/Dragon/src/COMRES.f new file mode 100644 index 0000000..1e5d0ab --- /dev/null +++ b/Dragon/src/COMRES.f @@ -0,0 +1,337 @@ +*DECK COMRES + SUBROUTINE COMRES(IMPX,IPISO,IPEDIT,NISOTS,NISO2,ISW,FNORM,ITRES, + 1 PYRES) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute a non-depleting macroscopic residual isotope. +* +*Copyright: +* Copyright (C) 2015 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IMPX print parameter. +* IPISO pointer to the isotope directory containing the residual +* isotope. +* IPEDIT pointer to the edition object (L_EDIT signature). +* NISOTS number of isotopes in the microlib pointed by IPEDIT. +* NISO2 number of particularized isotopes. +* ISW selection flag for isotopes in IPEDIT (>0: particularized; +* <0: included in the macroscopic residual). +* FNORM flux normalization factor. +* +*Parameters: output +* ITRES type of the residual isotope (=1: not fissile; =2: fissile). +* PYRES fission yields of the residual isotope (if ITRES=2). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPISO,IPEDIT + INTEGER IMPX,NISOTS,NISO2,ISW(NISOTS),ITRES + REAL FNORM,PYRES(NISO2) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + TYPE(C_PTR) JPEDIT,KPEDIT + INTEGER ISTATE(NSTATE) + CHARACTER CM*2,TEXT12*12 +*---- +* ALLOCATABLE ARRAYS +*---- + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HVECT + CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: HMAKE,HNISO + INTEGER, ALLOCATABLE, DIMENSION(:) :: IPIFI,ITYPRO + REAL, ALLOCATABLE, DIMENSION(:) :: SDEN,PNFTOT,PYIELD,PYDEN,WORK + REAL, ALLOCATABLE, DIMENSION(:,:) :: GAS,SIGS + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: WSCAT,PNFIRA,WORK2 +* + CALL LCMGET(IPEDIT,'STATE-VECTOR',ISTATE) + IF(ISTATE(2).NE.NISOTS) CALL XABORT('COMRES: INVALID EDITION OBJ' + 1 //'ECT.') + NG=ISTATE(3) + NL=ISTATE(4) + NED=ISTATE(13) + NBESP=ISTATE(16) + NDEL=ISTATE(19) + NW=ISTATE(25) + MAXH=9+3*NW+NL+NED+2*NDEL+NBESP + ALLOCATE(GAS(NG,MAXH),HMAKE(MAXH+NL),HNISO(NISOTS),SDEN(NISOTS), + 1 WSCAT(NG,NG,NL),PNFIRA(NG,0:NDEL,2),PNFTOT(NISOTS),ITYPRO(NL), + 2 HVECT(NED),WORK(NG+1),WORK2(NG,NG,NL)) + CALL LCMGTC(IPEDIT,'ISOTOPESUSED',12,NISOTS,HNISO) + CALL LCMGET(IPEDIT,'ISOTOPESDENS',SDEN) + CALL LCMGTC(IPEDIT,'ADDXSNAME-P0',8,NED,HVECT) + HMAKE(:MAXH+NL)=' ' + GAS(:NG,:MAXH)=0.0 + WSCAT(:NG,:NG,:NL)=0.0 + PNFIRA(:NG,0:NDEL,:2)=0.0 + PNFTOT(:NISOTS)=0.0 + DENTOT=0.0 + DAWR=0.0 + DECISO=0.0 + ITRES=1 +*---- +* SUMMATION OVER NON-PARTICULARIZED ISOTOPES +*---- + IF(NISOTS.GT.0) JPEDIT=LCMGID(IPEDIT,'ISOTOPESLIST') + DO 170 ISO=1,NISOTS + IF(ISW(ISO).LT.0) THEN + ISO3=-ISW(ISO) + IF(ISO3.GT.NISOTS) CALL XABORT('COMRES: NISOTS OVERFLOW(1).') + DDEN=SDEN(ISO) + KPEDIT=LCMGIL(JPEDIT,ISO) ! set ISO-th isotope + CALL LCMLEN(KPEDIT,'AWR',LENGTH,ITYLCM) + IF(LENGTH.EQ.1) THEN +* Compute only heavy-element AWR content + CALL LCMGET(KPEDIT,'AWR',FLOTT) + IF(FLOTT.GT.210.0) DAWR=DAWR+DDEN*FLOTT + ENDIF + DENTOT=DENTOT+DDEN + CALL LCMLEN(KPEDIT,'DECAY',LENGTH,ITYLCM) + IF(LENGTH.EQ.1) THEN + CALL LCMGET(KPEDIT,'DECAY',FLOTT) + DECISO=DECISO+FLOTT*DDEN + ENDIF +* +* COMPUTE FISSION RATES. + CALL LCMLEN(KPEDIT,'NFTOT',LENGTH,ITYLCM) + IF(LENGTH.EQ.NG) THEN + CALL LCMGET(KPEDIT,'NWT0',GAS(1,1)) + CALL LCMGET(KPEDIT,'NFTOT',WORK) + DO 30 IGR=1,NG + DEL=WORK(IGR)*GAS(IGR,1)*DDEN + PNFTOT(ISO3)=PNFTOT(ISO3)+DEL + 30 CONTINUE + ENDIF +* +* SET ARRAY HMAKE. + DO 40 IW=1,MIN(NW+1,10) + WRITE(TEXT12,'(3HNWT,I1)') IW-1 + CALL LCMLEN(KPEDIT,TEXT12,LENGTH,ITYLCM) + IF(LENGTH.EQ.NG) HMAKE(IW)=TEXT12 + WRITE(TEXT12,'(4HNWAT,I1)') IW-1 + CALL LCMLEN(KPEDIT,TEXT12,LENGTH,ITYLCM) + IF(LENGTH.EQ.NG) HMAKE(1+NW+IW)=TEXT12 + WRITE(TEXT12,'(4HNTOT,I1)') IW-1 + CALL LCMLEN(KPEDIT,TEXT12,LENGTH,ITYLCM) + IF(LENGTH.EQ.NG) HMAKE(2+2*NW+IW)=TEXT12 + 40 CONTINUE + IOF=3+3*NW + DO 50 IL=0,NL-1 + IOF=IOF+1 + WRITE (CM,'(I2.2)') IL + CALL LCMLEN(KPEDIT,'SIGS'//CM,ILONG,ITYLCM) + IF(ILONG.EQ.NG) HMAKE(IOF)='SIGS'//CM + 50 CONTINUE + IOF=IOF+1 + CALL LCMLEN(KPEDIT,'NUSIGF',ILONG,ITYLCM) + IF(ILONG.EQ.NG) HMAKE(IOF)='NUSIGF' + DO 60 IED=1,NED + IOF=IOF+1 + CALL LCMLEN(KPEDIT,HVECT(IED),ILONG,ITYLCM) + IF(ILONG.EQ.NG) HMAKE(IOF)=HVECT(IED) + 60 CONTINUE + CALL LCMLEN(KPEDIT,'H-FACTOR',ILONG,ITYLCM) + IF(ILONG.EQ.NG) HMAKE(IOF+1)='H-FACTOR' + CALL LCMLEN(KPEDIT,'OVERV',ILONG,ITYLCM) + IF(ILONG.EQ.NG) HMAKE(IOF+2)='OVERV' + CALL LCMLEN(KPEDIT,'TRANC',ILONG,ITYLCM) + IF(ILONG.EQ.NG) HMAKE(IOF+3)='TRANC' + IOF=IOF+3 + DO 70 IDEL=1,NDEL + IOF=IOF+1 + WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL + CALL LCMLEN(KPEDIT,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.NG) HMAKE(IOF)=TEXT12 + 70 CONTINUE + IOF=IOF+1 + CALL LCMLEN(KPEDIT,'CHI',ILONG,ITYLCM) + IF(ILONG.EQ.NG) HMAKE(IOF)='CHI' + DO 80 IDEL=1,NDEL + IOF=IOF+1 + WRITE(TEXT12,'(3HCHI,I2.2)') IDEL + CALL LCMLEN(KPEDIT,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.NG) HMAKE(IOF)=TEXT12 + 80 CONTINUE + DO 85 ISP=1,NBESP + IOF=IOF+1 + WRITE(TEXT12,'(5HCHI--,I2.2)') ISP + CALL LCMLEN(KPEDIT,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.NG) HMAKE(IOF)=TEXT12 + 85 ENDDO + IOF=IOF+1 + CALL LCMLEN(KPEDIT,'STRD',ILONG,ITYLCM) + IF(ILONG.EQ.NG) HMAKE(IOF)='STRD' + IF(IOF.NE.MAXH) CALL XABORT('COMRES: WRONG OFFSET.') +* + DO 150 J=1,MAXH + IF(HMAKE(J).NE.' ') THEN + CALL LCMLEN(KPEDIT,HMAKE(J),ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,HMAKE(J),WORK) + IF(HMAKE(J).EQ.'NUSIGF') THEN + DO 90 IGR=1,NG + DEL=WORK(IGR)*GAS(IGR,1)*DDEN + PNFIRA(IGR,0,1)=DEL + PNFIRA(IGR,0,2)=PNFIRA(IGR,0,2)+DEL + GAS(IGR,J)=GAS(IGR,J)+WORK(IGR)*DDEN + 90 CONTINUE + ELSE IF(HMAKE(J)(:3).EQ.'NUS') THEN + IDEL=J-(7+3*NW+NL+NED) + DO 100 IGR=1,NG + DEL=WORK(IGR)*GAS(IGR,1)*DDEN + PNFIRA(IGR,IDEL,1)=DEL + PNFIRA(IGR,IDEL,2)=PNFIRA(IGR,IDEL,2)+DEL + GAS(IGR,J)=GAS(IGR,J)+WORK(IGR)*DDEN + 100 CONTINUE + ELSE IF(HMAKE(J)(:3).EQ.'NWT') THEN + DO 110 IGR=1,NG + GAS(IGR,J)=WORK(IGR)*FNORM + 110 CONTINUE + ELSE IF((HMAKE(J).EQ.'CHI').OR. + 1 (HMAKE(J)(:5).EQ.'CHI--')) THEN + DO 120 IGR=1,NG + GAS(IGR,J)=GAS(IGR,J)+WORK(IGR)*PNFIRA(IGR,0,1) + 120 CONTINUE + ELSE IF(HMAKE(J)(:3).EQ.'CHI') THEN + IDEL=J-(8+3*NW+NL+NED+NDEL) + DO 130 IGR=1,NG + GAS(IGR,J)=GAS(IGR,J)+WORK(IGR)*PNFIRA(IGR,IDEL,1) + 130 CONTINUE + ELSE + DO 140 IGR=1,NG + GAS(IGR,J)=GAS(IGR,J)+WORK(IGR)*DDEN + 140 CONTINUE + ENDIF + ENDIF + ENDIF + 150 CONTINUE + CALL LCMLEN(KPEDIT,'SCAT-SAVED',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + ALLOCATE(SIGS(NG,NL)) + CALL XDRLGS(KPEDIT,-1,IMPX,0,NL-1,1,NG,SIGS(1,1),WORK2, + 1 ITYPRO) + DEALLOCATE(SIGS) + DO 162 IL=1,NL + WRITE (CM,'(I2.2)') IL-1 + IF(ITYPRO(IL).NE.0) HMAKE(MAXH+IL)='SCAT'//CM + DO 161 JGR=1,NG + DO 160 IGR=1,NG + WSCAT(IGR,JGR,IL)=WSCAT(IGR,JGR,IL)+WORK2(IGR,JGR,IL)*DDEN + 160 CONTINUE + 161 CONTINUE + 162 CONTINUE + ENDIF + ENDIF + 170 CONTINUE +*---- +* SUMMATION OF FISSION YIELDS OVER PARTICULARIZED ISOTOPES +*---- + ALLOCATE(PYDEN(NISO2)) + PYRES(:NISO2)=0.0 + PYDEN(:NISO2)=0.0 + DO 190 ISO=1,NISOTS + IF(ISW(ISO).GT.0) THEN + ISO2=ISW(ISO) + IF(ISO2.GT.NISO2) CALL XABORT('COMRES: NISO2 OVERFLOW.') + KPEDIT=LCMGIL(JPEDIT,ISO) ! set ISO-th isotope + CALL LCMLEN(KPEDIT,'PIFI',NDFI,ITYLCM) + IF(NDFI.GT.0) THEN + ALLOCATE(IPIFI(NDFI),PYIELD(NDFI)) + CALL LCMGET(KPEDIT,'PIFI',IPIFI) + CALL LCMGET(KPEDIT,'PYIELD',PYIELD) + DO 180 I=1,NDFI + IFI=IPIFI(I) + IF(IFI.GT.NISOTS) CALL XABORT('COMRES: NISOTS OVERFLOW(2).') + IF(ISW(IFI).LT.0) THEN +* fissile isotope included in the macroscopic residual + PYRES(ISO2)=PYRES(ISO2)+PYIELD(I)*PNFTOT(-ISW(IFI)) + PYDEN(ISO2)=PYDEN(ISO2)+PNFTOT(-ISW(IFI)) + ENDIF + 180 CONTINUE + DEALLOCATE(PYIELD,IPIFI) + ENDIF + ENDIF + 190 CONTINUE + DO 200 ISO2=1,NISO2 + IF(PYDEN(ISO2).NE.0.0) PYRES(ISO2)=PYRES(ISO2)/PYDEN(ISO2) + 200 CONTINUE + DEALLOCATE(PYDEN) +*---- +* SAVE THE RESIDUAL ISOTOPE IN IPISO ISOTOPE OBJECT +*---- + IF(DENTOT.GT.0.0) THEN + IF(IMPX.GT.0) WRITE (6,600) + TEXT12='*MAC*RES0001' + CALL LCMPTC(IPISO,'ALIAS',12,TEXT12) + CALL LCMPUT(IPISO,'AWR',1,2,DAWR) + DECISO=DECISO/DENTOT + IF(DECISO.GT.0.0) CALL LCMPUT(IPISO,'DECAY',1,2,DECISO) + DO 240 J=1,MAXH + IF(HMAKE(J).EQ.'NUSIGF') ITRES=2 + IF(HMAKE(J).EQ.'OVERV') THEN + DO 210 IGR=1,NG + GAS(IGR,J)=GAS(IGR,J)/DENTOT + 210 CONTINUE + ELSE IF((HMAKE(J).EQ.'CHI').OR.(HMAKE(J)(:5).EQ.'CHI--')) THEN + DO 220 IGR=1,NG + IF(GAS(IGR,J).NE.0.0) THEN + GAS(IGR,J)=GAS(IGR,J)/PNFIRA(IGR,0,2) + ENDIF + 220 CONTINUE + ELSE IF(HMAKE(J)(:3).EQ.'CHI') THEN + IDEL=J-(8+3*NW+NL+NED+NDEL) + DO 230 IGR=1,NG + IF(GAS(IGR,J).NE.0.0) THEN + GAS(IGR,J)=GAS(IGR,J)/PNFIRA(IGR,IDEL,2) + ENDIF + 230 CONTINUE + ENDIF + IF((HMAKE(J).NE.' ').AND.(HMAKE(J)(:4).NE.'SIGS')) THEN + CALL LCMPUT(IPISO,HMAKE(J),NG,2,GAS(1,J)) + ENDIF + 240 CONTINUE + IF(ITYPRO(1).NE.0) THEN + DO 250 IL=1,NL + ITYPRO(IL)=0 + IF(HMAKE(MAXH+IL).NE.' ') ITYPRO(IL)=1 + 250 CONTINUE + CALL XDRLGS(IPISO,1,IMPX,0,NL-1,1,NG,GAS(1,4+3*NW),WSCAT, + 1 ITYPRO) + ENDIF +* + IF(IMPX.GT.3) THEN + WRITE(6,'(/17H NUMBER DENSITY =,1P,E12.4)') 1.0 + WRITE(6,'(23H WEIGHTED ATOMIC MASS =,1P,E13.5)') DAWR + DO 260 J=1,MAXH + IF(HMAKE(J).NE.' ') THEN + WRITE (6,610) HMAKE(J),(GAS(I,J),I=1,NG) + ENDIF + 260 CONTINUE + WRITE (6,610) 'SIGA ',(GAS(I,3+2*NW)-GAS(I,4+3*NW),I=1,NG) + WRITE (6,610) 'SIGW00 ',(WSCAT(I,I,1),I=1,NG) + IF(NL.GT.1) THEN + WRITE (6,610) 'SIGW01 ',(WSCAT(I,I,2),I=1,NG) + ENDIF + ENDIF + ENDIF + DEALLOCATE(WORK2,WORK,HVECT,ITYPRO,PNFTOT,PNFIRA,WSCAT,SDEN,HNISO, + 1 HMAKE,GAS) + RETURN +* + 600 FORMAT (//49H COMRES: CROSS SECTION OF MACRO RESIDUAL ISOTOPE , + 1 8H*MAC*RES) + 610 FORMAT (/11H REACTION ',A12,2H':/(1X,1P,10E12.4)) + END diff --git a/Dragon/src/COMSDB.f b/Dragon/src/COMSDB.f new file mode 100644 index 0000000..27e10f6 --- /dev/null +++ b/Dragon/src/COMSDB.f @@ -0,0 +1,200 @@ +*DECK COMSDB + SUBROUTINE COMSDB(IMPX,IPCPO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Show the structure of a multicompo file. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Chambon +* +*Parameters: input +* IMPX print parameter. +* IPCPO pointer to the multicompo. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IMPX + TYPE(C_PTR) IPCPO +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40,MAXPAR=50,MAXVAL=1000) + TYPE(C_PTR) JPCPO,KPCPO + INTEGER ISTATE(NSTATE),NVPO(2),NVALUE(2*MAXPAR) + CHARACTER RECNAM*12,TEXT12*12,PARFMT(MAXPAR)*8, + 1 VCHAR(MAXVAL)*12,PARKEY(MAXPAR)*12,PARCPO(MAXPAR)*12 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MUPCPO,JDEBAR,JARBVA,VINTE + REAL, ALLOCATABLE, DIMENSION(:) :: VREAL +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(MUPCPO(2*MAXPAR)) +* + CALL LCMGET(IPCPO,'STATE-VECTOR',ISTATE) + NMIL=ISTATE(1) + NCAL=ISTATE(3) + MAXCAL=ISTATE(4) + NPAR=ISTATE(5) + NLOC=ISTATE(6) + IF(NPAR+NLOC.GT.2*MAXPAR) CALL XABORT('COMSDB: MAXPAR OVERFLOW.') + IF(NCAL.EQ.0) WRITE(6,*) 'The multi-compo DB is empty.' +*---- +* MAIN LOOP OVER THE HOMOGENEOUS MIXTURES ********************* +*---- + JPCPO=LCMGID(IPCPO,'MIXTURES') + DO 190 IBM=1,NMIL + KPCPO=LCMDIL(JPCPO,IBM) +*---- +* MAIN LOOP OVER THE NCALR ELEMENTARY CALCULATIONS OF THE COMPO +*---- + WRITE(6,*) 'LIST OF "MUPLET" included in the COMPO' + DO 170 ICAL=1,NCAL +*---- +* COMPUTE THE MUPLET VECTOR FROM THE COMPO +*---- + CALL LCMSIX(KPCPO,'TREE',1) + CALL LCMGET(KPCPO,'NVP',NVPO) + MAXNVP=NVPO(2) + ALLOCATE(JDEBAR(MAXNVP+1),JARBVA(MAXNVP)) + CALL LCMGET(KPCPO,'NCALS',NCALS) + CALL LCMGET(KPCPO,'DEBARB',JDEBAR) + CALL LCMGET(KPCPO,'ARBVAL',JARBVA) + I0=0 + DO 30 I=NVPO(1)-NCALS+1,NVPO(1) + IF(JDEBAR(I+1).EQ.ICAL) THEN + I0=I + GO TO 40 + ENDIF + 30 CONTINUE + CALL XABORT('COMSDB: MUPLET ALGORITHM FAILURE 1.') + 40 MUPCPO(NPAR+NLOC)=JARBVA(I0) + DO 65 IPAR=NPAR+NLOC-1,1,-1 + I0=0 + DO 50 I=1,NVPO(1)-NCALS + IF(JDEBAR(I+1).GT.I0) THEN + I0=I + GO TO 60 + ENDIF + 50 CONTINUE + CALL XABORT('COMSDB: MUPLET ALGORITHM FAILURE 2.') + 60 MUPCPO(IPAR)=JARBVA(I0) + 65 CONTINUE + DEALLOCATE(JARBVA,JDEBAR) + CALL LCMSIX(KPCPO,' ',2) + WRITE(6,*)'ICAL #',ICAL,': ',(MUPCPO(JM),JM=1,NPAR+NLOC) + IF(IMPX.LE.1) GOTO 170 +*---- +* RECOVER THE GLOBAL PARAMETERS +*---- + CALL LCMSIX(IPCPO,'GLOBAL',1) + CALL LCMGTC(IPCPO,'PARKEY',12,NPAR,PARCPO) + CALL LCMGTC(IPCPO,'PARFMT',8,NPAR,PARFMT) + CALL LCMGET(IPCPO,'NVALUE',NVALUE) + DO 100 IPAR=1,NPAR + WRITE(RECNAM,'(''pval'',I8.8)') IPAR + IVAL=MUPCPO(IPAR) + IF(PARFMT(IPAR).EQ.'REAL') THEN + ALLOCATE(VREAL(NVALUE(IPAR))) + CALL LCMGET(IPCPO,RECNAM,VREAL) + FLOTT=VREAL(IVAL) + DEALLOCATE(VREAL) + write(6,*)'IPAR ',IPAR,'->',PARCPO(IPAR),FLOTT + ELSE IF(PARFMT(IPAR).EQ.'INTEGER') THEN + ALLOCATE(VINTE(NVALUE(IPAR))) + CALL LCMGET(IPCPO,RECNAM,VINTE) + NITMA=VINTE(IVAL) + DEALLOCATE(VINTE) + write(6,*)'IPAR ',IPAR,'->',PARCPO(IPAR),NITMA + ELSE IF(PARFMT(IPAR).EQ.'STRING') THEN + IF(NVALUE(IPAR).GT.MAXVAL) CALL XABORT('COMSDB: MAXVAL ' + 1 //'OVERFLOW.') + CALL LCMGTC(IPCPO,RECNAM,12,NVALUE(IPAR),VCHAR) + TEXT12=VCHAR(IVAL) + write(6,*)'IPAR ',IPAR,'->',PARCPO(IPAR),TEXT12 + ENDIF + 100 CONTINUE + CALL LCMSIX(IPCPO,' ',2) +*---- +* RECOVER THE LOCAL PARAMETERS +*---- + CALL LCMSIX(KPCPO,'TREE',1) + DO 130 ILOC=1,NLOC + WRITE(RECNAM,'(''pval'',I8.8)') ILOC + IVAL=MUPCPO(NPAR+ILOC) + CALL LCMLEN(KPCPO,RECNAM,ILONG,ITYLCM) + ALLOCATE(VREAL(ILONG)) + CALL LCMGET(KPCPO,RECNAM,VREAL) + FLOTT=VREAL(IVAL) + DEALLOCATE(VREAL) + WRITE(6,*)'ILOC ',ILOC,'->',PARKEY(IPAR),FLOTT + 130 CONTINUE + CALL LCMSIX(KPCPO,' ',2) + 170 CONTINUE +* END OF LOOP ON CALCULATIONS. ******************************* + IF (IMPX.EQ.0) GOTO 190 + WRITE(6,*) 'Summary of the parameter included in the COMPO' + CALL LCMSIX(IPCPO,'GLOBAL',1) + CALL LCMGTC(IPCPO,'PARKEY',12,NPAR,PARCPO) + CALL LCMGTC(IPCPO,'PARFMT',8,NPAR,PARFMT) + CALL LCMGET(IPCPO,'NVALUE',NVALUE) + DO 180 IPAR=1,NPAR + WRITE(RECNAM,'(''pval'',I8.8)') IPAR + IF(PARFMT(IPAR).EQ.'REAL') THEN + ALLOCATE(VREAL(NVALUE(IPAR))) + CALL LCMGET(IPCPO,RECNAM,VREAL) + WRITE(6,*)'IPAR ',IPAR,'->',PARKEY(IPAR), + 1 (VREAL(JM),JM=1,NVALUE(IPAR)) + DEALLOCATE(VREAL) + ELSE IF(PARFMT(IPAR).EQ.'INTEGER') THEN + ALLOCATE(VINTE(NVALUE(IPAR))) + CALL LCMGET(IPCPO,RECNAM,VINTE) + WRITE(6,*)'IPAR ',IPAR,'->',PARKEY(IPAR), + 1 (VINTE(JM),JM=1,NVALUE(IPAR)) + DEALLOCATE(VINTE) + ELSE IF(PARFMT(IPAR).EQ.'STRING') THEN + IF(NVALUE(IPAR).GT.MAXVAL) CALL XABORT('COMSDB: MAXVAL ' + 1 //'OVERFLOW.') + CALL LCMGTC(IPCPO,RECNAM,12,NVALUE(IPAR),VCHAR) + WRITE(6,*)'IPAR ',IPAR,'->',PARKEY(IPAR), + 1 (VCHAR(JM),JM=1,NVALUE(IPAR)) + ENDIF + 180 CONTINUE + CALL LCMSIX(IPCPO,' ',2) + CALL LCMSIX(KPCPO,'TREE',1) + DO 185 ILOC=1,NLOC + CALL LCMGTC(IPCPO,'PARKEL',12,NLOC,PARCPO) + CALL LCMGET(IPCPO,'NVALUE',NVALUE) + WRITE(RECNAM,'(''pval'',I8.8)') ILOC + CALL LCMLEN(KPCPO,RECNAM,ILONG,ITYLCM) + ALLOCATE(VREAL(ILONG)) + CALL LCMGET(KPCPO,RECNAM,VREAL) + WRITE(6,*)'ILOC ',ILOC,'->',PARCPO(ILOC), + 1 (VREAL(JM),JM=1,NVALUE(ILOC)) + DEALLOCATE(VREAL) + 185 CONTINUE + CALL LCMSIX(KPCPO,' ',2) + + 190 CONTINUE +* END OF LOOP ON MIXTURES. *********************************** +* +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(MUPCPO) + RETURN + END diff --git a/Dragon/src/COMTRE.f b/Dragon/src/COMTRE.f new file mode 100644 index 0000000..a6351b6 --- /dev/null +++ b/Dragon/src/COMTRE.f @@ -0,0 +1,76 @@ +*DECK COMTRE + LOGICAL FUNCTION COMTRE(NPAR,NVP,ARB,DEB,MUPLET,IPARM,I0,II,JJ, + 1 LAST) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find the index of the corresponding elementary calculation in the +* global parameter tree for a value of the tuple MUPLET. If the +* elementary calculation exists, set COMTRE=.true. otherwise, set the +* indices in the tree where the new calculation must be introduced. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NPAR number of global parameters. +* NVP number of nodes in the global parameter tree. +* ARB array arbval of the global parameters tree. +* DEB array debarb of the global parameters tree. +* MUPLET tuple of indices associated to each global parameter of the +* elementary calculation. +* +*Parameters: output +* IPARM index of the parameter not corresponding to a node. +* I0 index in DEB of the first element corresponding to +* parameter iparm. +* II index of the elementary calculation corresponding to the +* tuple muplet (if exists). Otherwise, index in DEB of the +* element that will contain the new elementary calculation. +* JJ if the node has not been found, index in DEB of the +* element corresponding to the next node. +* LAST completion flag (=.true. if the node has not been found). +* If LAST=.true., a node will be added at the end of the tree. +* COMTRE If COMTRE=.true., node already exists. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NPAR,NVP,ARB(NVP),DEB(NVP+1),MUPLET(NPAR),IPARM,I0,II,JJ + LOGICAL LAST +* + IPARM=NPAR + II=1 + I0=1 + DO 30 IPAR=1,NPAR + I0=DEB(I0) + DO 10 I=DEB(II),DEB(II+1)-1 + IF(MUPLET(IPAR).EQ.ARB(I))THEN + II=I + GO TO 30 + ELSEIF(MUPLET(IPAR).LT.ARB(I))THEN + JJ=I + LAST=.FALSE. + GO TO 20 + ENDIF + 10 CONTINUE + JJ=DEB(II+1) + LAST=JJ.EQ.DEB(I0) + 20 IPARM=IPAR + COMTRE=.FALSE. + RETURN + 30 CONTINUE + II=DEB(II+1) + COMTRE=.TRUE. +* + RETURN + END diff --git a/Dragon/src/CPO.f b/Dragon/src/CPO.f new file mode 100644 index 0000000..a09d01a --- /dev/null +++ b/Dragon/src/CPO.f @@ -0,0 +1,439 @@ +*DECK CPO + SUBROUTINE CPO(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Creation and construction of a Compo database object. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): Create or modification L_COMPO database object; +* HENTRY(2): Read-only type(L_EDIT); +* HENTRY(3): Read-only type(L_BURNUP). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + INTEGER IOUT,NSTATE,NDPROC,MAXNED,IBURN + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NSTATE=40,NDPROC=20,MAXNED=50, + > NAMSBR='CPO ') +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDBS,ISOCPO,ISOEXT,ISOORD, + > NBIMRG,IDIMIX,ICOMIX,ISOTMP,IMXTMP + REAL, ALLOCATABLE, DIMENSION(:) :: VOLME,ENERG,TIME,BURN,WIR +*---- +* INPUT DATA +*---- + INTEGER ITYPLU,INTLIR + CHARACTER CARLIR*12 + REAL REALIR + DOUBLE PRECISION DBLLIR +*---- +* LOCAL PARAMETERS +*---- + TYPE(C_PTR) IPLIB,IPCPO,IPEDIT,IPDEPL + CHARACTER HVECT(MAXNED)*8,CURNAM*12,CDIRO*12,TEXT12*12, + > TEXT4*4,HSIGN*12,NAMCPO*8 + LOGICAL LB2,LBURN + INTEGER CTITRE(18),ISTATE(NSTATE),ISTATM(NSTATE) + INTEGER NBMICR,NXXXZ,NL,NIFISS,NGCOND,NMERGE,NEDMAC,IST, + > NPROC,IEN,IKLIB,MXBURN,LENGT,MAXMRG,ITYLCM,ITEXT4, + > ILOCAL,I,IKDEPL,IKEDIT,MAXISM,ILEAKS,ITRANC,NOLD, + > ILCMLN,IBR,IPBR,MAXISO,IPRINT,NISCPO,NSBS,IEXTRC, + > NISEXT +*---- +* PARAMETER VALIDATION. +*---- + TEXT4=' ' + READ(TEXT4,'(A4)') ITEXT4 + IF(NENTRY.LT.2) CALL XABORT(NAMSBR// + >': AT LEAST TWO DATA STRUCTURES EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT(NAMSBR// + >': LINKED LIST OR XSM FILE EXPECTED AT LHS.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT(NAMSBR// + >': LINKED LIST OR XSM FILE EXPECTED AT LHS.') + IPCPO=KENTRY(1) + IF(JENTRY(1).EQ.0) THEN + HSIGN='L_COMPO' + CALL LCMPTC(IPCPO,'SIGNATURE',12,HSIGN) + ELSE + CALL LCMGTC(IPCPO,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_COMPO') THEN + TEXT12=HENTRY(1) + CALL XABORT(NAMSBR// + > ': SIGNATURE OF '//TEXT12//' IS '//HSIGN//' L_COMPO EXPECTED') + ENDIF + ENDIF +*---- +* SCAN ENTRY FOR EDIT, BURNUP AND LIB +*---- + IPEDIT=C_NULL_PTR + IKEDIT=0 + IPDEPL=C_NULL_PTR + IKDEPL=0 + IPLIB=C_NULL_PTR + IKLIB=0 + DO 100 IEN=2,NENTRY + TEXT12=HENTRY(IEN) + IF(JENTRY(IEN).NE.2) CALL XABORT(NAMSBR// + > ': DATA STRUCTURE '//TEXT12//' NOT IN READ-ONLY MODE') + IF(IENTRY(IEN).EQ.1.OR.IENTRY(IEN).EQ.2) THEN + CALL LCMGTC(KENTRY(IEN),'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_EDIT'.AND.IKEDIT.EQ.0) THEN + IPEDIT=KENTRY(IEN) + IKEDIT=IEN + ELSE IF(HSIGN.EQ.'L_BURNUP'.AND.IKDEPL.EQ.0) THEN + IPDEPL=KENTRY(IEN) + IKDEPL=IEN + ENDIF + ENDIF + 100 CONTINUE + IF(IKEDIT.EQ.0) CALL XABORT(NAMSBR// + >': NO DATA STRUCTURE WITH SIGNATURE L_EDIT FOUND.') + IF(IKDEPL.EQ.0) THEN + MXBURN=1 + ELSE + CALL LCMLEN(IPDEPL,'DEPL-TIMES',MXBURN,ITYLCM) + IF(MXBURN.EQ.0) CALL XABORT(NAMSBR// + > ': NO DEPL-TIMES DIRECTORY ON BURNUP DATA STRUCTURE') + ENDIF + ALLOCATE(IDBS(MXBURN)) +*---- +* RECOVER THE TITLE. +*---- + CALL LCMLEN(IPEDIT,'TITLE',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGET(IPEDIT,'TITLE',CTITRE) + ELSE + DO 101 I=1,18 + CTITRE(I)=ITEXT4 + 101 CONTINUE + ENDIF +*---- +* GET EDIT INFORMATION FOR MEMORY ALLOCATION OF +* NUMBER OF ISOTOPES +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(IPEDIT,'STATE-VECTOR',ISTATE) + MAXMRG=ISTATE(1) + MAXISM=ISTATE(13) + MAXISO=MAXMRG*MAXISM + ALLOCATE(ISOCPO(3*MAXISO),ISOEXT(3*MAXISO),ISOORD(MAXISO)) + ISOCPO(:3*MAXISO)=0 + ISOEXT(:3*MAXISO)=0 + ISOORD(:MAXISO)=0 +*---- +* READ CPO DATA. +*---- + IPRINT=1 + IEXTRC=0 + NISEXT=0 + NISCPO=0 + NSBS=-1 + LBURN=.FALSE. + LB2=.FALSE. + ILEAKS=0 + ITRANC=1 + CURNAM='REF-CASE0001' + NAMCPO='COMPO' + ILOCAL=0 + 110 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.10) GO TO 115 + 120 CONTINUE + IF(ITYPLU.NE.3) CALL XABORT(NAMSBR// + >': KEYWORD EXPECTED') + IF(CARLIR.EQ.';') THEN + GO TO 115 + ELSE IF(CARLIR.EQ.'EDIT') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT(NAMSBR// + > ': EDIT LEVEL EXPECTED') + IPRINT=INTLIR + ELSE IF(CARLIR.EQ.'B2') THEN + LB2=.TRUE. + ELSE IF(CARLIR.EQ.'STEP') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT(NAMSBR// + > ': STEP NAME EXPECTED') + CURNAM=CARLIR + NSBS=0 + ELSE IF(CARLIR.EQ.'NOTR') THEN + ITRANC=0 + ELSE IF(CARLIR.EQ.'GLOB') THEN + ILOCAL=0 + ELSE IF(CARLIR.EQ.'LOCA') THEN + ILOCAL=1 + ELSE IF(CARLIR.EQ.'BURNUP') THEN + IF(IKDEPL.EQ.0) CALL XABORT(NAMSBR// + > ': A BURNUP DATA STRUCTURE IS REQUIRED ') + LBURN=.TRUE. + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT(NAMSBR// + > ': BURNUP NAME EXPECTED') + CURNAM=CARLIR + NSBS=MXBURN + DO 111 IBR=1,NSBS + IDBS(IBR)=IBR + 111 CONTINUE + ELSE IF(CARLIR.EQ.'EXTRACT') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT(NAMSBR// + > ': ISOTOPE EXTRACTION NAME EXPECTED') + IF(CARLIR.EQ.'ALL') THEN +*---- +* FOR EXTRACT ALL, RECOVER ISOTOPE NAMES FROM EDIT STRUCTURE +*---- + IEXTRC=2 + NISEXT=MAXISO + NISCPO=MAXISO + ELSE + IEXTRC=1 + NISCPO=NISCPO+1 + IF(NISCPO.GT.MAXISO) CALL XABORT(NAMSBR// + > ': TOO MANY EXTRACTION ISOTOPES') + READ(CARLIR,'(3A4)') (ISOCPO(I),I=3*(NISCPO-1)+1,3*NISCPO) + 130 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT(NAMSBR// + > ': ISOTOPE NAME TO EXTRACT EXPECTED') + IF((CARLIR.EQ.'EXTRACT').OR.(CARLIR.EQ.'EXPORT').OR. + > (CARLIR.EQ.'NAME') .OR.(CARLIR.EQ.'ESBS') .OR. + > (CARLIR.EQ.';')) GO TO 120 + NISEXT=NISEXT+1 + IF(NISEXT.GT.MAXISO) CALL XABORT(NAMSBR// + > ': TOO MANY ISOTOPES TO EXTRACT') + READ(CARLIR,'(3A4)') (ISOEXT(I),I=3*(NISEXT-1)+1,3*NISEXT) + ISOORD(NISEXT)=NISCPO + GO TO 130 + ENDIF + ELSE IF(CARLIR.EQ.'ESBS') THEN + IF(.NOT.LBURN) CALL XABORT(NAMSBR// + > ': OPTION ESBS VALID ONLY WITH BURNUP OPTION.') + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT(NAMSBR// + > ': KEYWORD FOLLOWING ESBS MISSING') + IF(CARLIR.EQ.'NBUR') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT(NAMSBR// + > ': INTEGER EXPECTED(2).') + NSBS=INTLIR + IPBR=0 + NOLD=0 + DO 112 IBR=1,NSBS + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT(NAMSBR// + > ': INTEGER EXPECTED(3).') + IF(INTLIR.GT.MXBURN.OR.INTLIR.LT.1) THEN + WRITE(IOUT,7000) NAMSBR,INTLIR,MXBURN + ELSE IF(INTLIR.LE.NOLD) THEN + WRITE(IOUT,7001) NAMSBR,NOLD,INTLIR + ELSE + IDBS(IPBR+1)=INTLIR + NOLD=INTLIR + IPBR=IPBR+1 + ENDIF + 112 CONTINUE + NSBS=IPBR + ELSE + CALL XABORT(NAMSBR//': NBUR KEY WORD EXPECTED.') + ENDIF + ELSE IF(CARLIR.EQ.'NAME') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT(NAMSBR// + > ': CPO NAME EXPECTED') + NAMCPO=CARLIR(:8) + ELSE + CALL XABORT(NAMSBR// + > ': '//CARLIR//' IS AN INVALID KEY WORD.') + ENDIF + GO TO 110 +*---- +* CREATE THE COMPO +*---- + 115 CONTINUE + IF(LBURN) THEN + WRITE(CDIRO,'(A8,I4.4)') CURNAM(1:8),IDBS(1) + ELSE + CDIRO=CURNAM + ENDIF + CALL LCMLEN(IPEDIT,CDIRO,ILCMLN,ITYLCM) + IF(ILCMLN.EQ.0) THEN + CALL LCMLIB(IPEDIT) + CALL XABORT(NAMSBR//': MISSING '//CDIRO//' DIRECTORY') + ENDIF + CALL LCMSIX(IPEDIT,CDIRO,1) + CALL LCMSIX(IPEDIT,'MACROLIB',1) + ISTATE(:NSTATE)=0 + CALL LCMGET(IPEDIT,'STATE-VECTOR',ISTATE) + NGCOND=ISTATE(1) + NMERGE=ISTATE(2) + NL=ISTATE(3) + NIFISS=ISTATE(4) + NEDMAC=ISTATE(5) + IF(ITRANC.EQ.1) THEN + ITRANC=ISTATE(6) + ENDIF + IF((ITRANC.EQ.1).AND.(IPRINT.GT.0)) THEN + WRITE(IOUT,6020) + ENDIF + ILEAKS=ISTATE(9) + IF(LB2.AND.ILEAKS.EQ.0) CALL XABORT(NAMSBR// + >': MISSING B2 INFO.') + ALLOCATE(VOLME(NMERGE),ENERG(NGCOND+1)) + CALL LCMGET(IPEDIT,'ENERGY',ENERG) + CALL LCMGET(IPEDIT,'VOLUME',VOLME) + IF(NEDMAC.GT.0) THEN + CALL LCMGTC(IPEDIT,'ADDXSNAME-P0',8,NEDMAC,HVECT) + ENDIF + CALL LCMSIX(IPEDIT,' ',2) + IF(IPRINT.GE.1) THEN + IF(ILEAKS.EQ.1) THEN + WRITE(IOUT,6000) NAMSBR,CURNAM,NGCOND,NMERGE,NSBS, + > NL,ILEAKS + ELSE IF(ILEAKS.EQ.2) THEN + WRITE(IOUT,6000) NAMSBR,CURNAM,NGCOND,NMERGE,NSBS, + > NL,ILEAKS + ELSE + WRITE(IOUT,6000) NAMSBR,CURNAM,NGCOND,NMERGE,NSBS, + > NL,ILEAKS + ENDIF + ENDIF +*---- +* PREPARE ISOTOPES +*---- + CALL LCMLEN(IPEDIT,'ISOTOPESMIX',NBMICR,ITYLCM) + ALLOCATE(NBIMRG(NMERGE)) + IF(IEXTRC.GE.1.AND.NBMICR.GT.0) THEN + NXXXZ=MAX(NBMICR,1) + ALLOCATE(IDIMIX(NMERGE*NXXXZ),ICOMIX(NMERGE*MAXISM), + > ISOTMP(3*NXXXZ),IMXTMP(NXXXZ)) + CALL LCMGET(IPEDIT,'ISOTOPESUSED',ISOTMP) + CALL LCMGET(IPEDIT,'ISOTOPESMIX',IMXTMP) + IDIMIX(:NMERGE*NXXXZ)=0 + CALL CPOISO(IPRINT,IEXTRC,NMERGE,MAXISO,MAXISM,NBMICR, + > NISCPO,NISEXT,ISOCPO,ISOEXT,ISOORD,ISOTMP, + > IMXTMP,IDIMIX,NBIMRG,ICOMIX) + ELSE + NXXXZ=MAX(NBMICR,1) + NBIMRG(:NMERGE)=0 + ALLOCATE(IDIMIX(NMERGE*NXXXZ),ICOMIX(NMERGE*NXXXZ), + > ISOTMP(3*NXXXZ),IMXTMP(NXXXZ)) + NISCPO=0 + ENDIF + DEALLOCATE(ISOORD,ISOEXT) + CALL LCMSIX(IPEDIT,' ',2) +*---- +* TEST IF OTHER BURNUP STEP CONSISTENT WITH FIRST BURNUP STEP +*---- + DO 160 IBURN=2,NSBS + WRITE(CDIRO,'(A8,I4.4)') CURNAM(1:8),IDBS(IBURN) + CALL LCMLEN(IPEDIT,CDIRO,ILCMLN,ITYLCM) + IF(ILCMLN.EQ.0) THEN + WRITE(IOUT,7002) NAMSBR,CDIRO + IDBS(IBURN)=0 + ELSE + CALL LCMSIX(IPEDIT,CDIRO,1) + CALL LCMSIX(IPEDIT,'MACROLIB',1) + ISTATM(:NSTATE)=0 + CALL LCMGET(IPEDIT,'STATE-VECTOR',ISTATM) + CALL LCMSIX(IPEDIT,'MACROLIB',2) + CALL LCMSIX(IPEDIT,CDIRO,2) + DO 170 IST=1,NSTATE + IF(ISTATE(IST).NE.ISTATM(IST)) THEN + WRITE(IOUT,7003) NAMSBR,CURNAM(1:8),IDBS,CDIRO + IDBS(IBURN)=0 + GO TO 175 + ENDIF + 170 CONTINUE + 175 CONTINUE + ENDIF + 160 CONTINUE + ALLOCATE(TIME(MXBURN),BURN(MXBURN),WIR(MXBURN)) + IF(LBURN) THEN + CALL LCMGET(IPDEPL,'DEPL-TIMES',TIME) + ELSE + TIME=0.0 + ENDIF +*---- +* CALL CPODRV +*---- + NPROC=NDPROC+NL+1 + CALL CPODRV(IPCPO ,IPEDIT,IPDEPL,IPRINT,CURNAM,CTITRE, + > NAMCPO,NGCOND,NMERGE,NBMICR,NIFISS,MXBURN, + > NL ,NISCPO,NPROC ,ILEAKS,NXXXZ ,NEDMAC, + > HVECT ,NSBS ,ILOCAL,ISOCPO,ISOTMP,IDIMIX, + > NBIMRG,ICOMIX,VOLME, ENERG ,TIME ,BURN , + > WIR ,IDBS ) +*---- +* RELEASE MAIN MEMORY +*---- + DEALLOCATE(WIR,BURN,TIME,IMXTMP,ISOTMP,ICOMIX,NBIMRG,IDIMIX, + > ENERG,VOLME,ISOCPO,IDBS) + RETURN +*---- +* PRINT FORMAT +*---- + 6000 FORMAT(1X,A6, + > ': RECOVER INFORMATION FROM DIRECTORY = ',A12/ + > 10X,' NUMBER OF GROUPS =',I5/ + > 10X,' NUMBER OF COMPOS =',I5/ + > 10X,' NUMBER OF BURNUPS =',I5/ + > 10X,' LEGENDRE ORDERS =',I5/ + > 10X,' LEAKAGE OPTION =',I5) + 6020 FORMAT(' TRANSPORT CORRECTED CROSS SECTIONS') +*---- +* WARNING FORMAT +*---- + 7000 FORMAT(1X,A6,': ****** WARNING ******'/ + > ' ILLEGAL BURNUP STEP NUMBER'/ + > ' CURRENT BURNUP STEP - SKIPPED = ',I10/ + > ' NUMBER OF BURNUP STEP AVAILABLE = ',I10/ + > ' **************************') + 7001 FORMAT(1X,A6,': ****** WARNING ******'/ + > ' BURNUP STEPS MUST BE ORDERED INCREASINGLY '/ + > ' PREVIOUS BURNUP STEP REQUESTED = ',I10/ + > ' CURRENT BURNUP STEP - SKIPPED = ',I10/ + > ' **************************') + 7002 FORMAT(1X,A6,': ****** WARNING ******'/ + > ' BURNUP STEP DOES NOT EXISTS '/ + > ' CURRENT BURNUP STEP - SKIPPED = ',A12/ + > ' **************************') + 7003 FORMAT(1X,A6,': ****** WARNING ******'/ + > ' INCONSISTENT BURNUP STEP '/ + > ' REFERENCE BURNUP STEP = ',A8,I4.4/ + > ' CURRENT BURNUP STEP - SKIPPED = ',A12/ + > ' **************************') + END diff --git a/Dragon/src/CPODRV.f b/Dragon/src/CPODRV.f new file mode 100644 index 0000000..ccf2ce2 --- /dev/null +++ b/Dragon/src/CPODRV.f @@ -0,0 +1,366 @@ +*DECK CPODRV + SUBROUTINE CPODRV(IPCPO ,IPEDIT,IPDEPL,IPRINT,CURNAM,CTITRE, + > NAMCPO,NGROUP,NMERGE,NBMICR,NIFISS,MXBURN, + > NL ,NISCPO,NPROC ,ILEAKS,NXXXZ ,NEDMAC, + > HVECT ,NSBS ,ILOCAL,ISOCPO,ISOTMP,IDIMIX, + > NBIMRG,ICOMIX,VOLMER,ENERGY,TIME ,BURN , + > WIRRAD,IBSTEP) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover cross section information located on directory CURNAM or on +* directory family with prefix CURNAM. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau +* +*Parameters: input +* IPCPO pointer to the compo (L_COMPO signature). +* IPEDIT pointer to edit information (L_EDIT signature). +* IPDEPL pointer to depletion information (L_BURNUP signature). +* IPRINT print parameter. Equal to zero for no print. +* CURNAM name of the output directory (or prefix of output +* directory in burnup cases). +* CTITRE character*72 title. +* NAMCPO character*8 name of the material mixture sub-directory. +* NGROUP number of energy groups in output data. +* NMERGE number of output regions. +* NBMICR maximum number of isotopes. +* NIFISS number of fissile isotopes. +* MXBURN maximum number of output burnup sets. +* NL number of Legendre orders (=1 for isotropic scattering). +* NISCPO number of Compo isotopes treated. +* NPROC number of microscopic xs to process. +* ILEAKS leak option: 0 no leakage ; 1 homogeneous leakage ; +* 2 heterogeneous leakage. +* NXXXZ maximum dimension of ISO dependent vector = max(nbmicr,1). +* NEDMAC number of edit xs. +* HVECT name of edit xs. +* NSBS number of sub-burnup step considered. +* ILOCAL local parameter flag (0: global; 1:local). +* ISOCPO Compo name of isotopes. +* ISOTMP name of isotopes in EDIT. +* IDIMIX isotopes identifier in each Compo material. +* NBIMRG final number of isotope per region. +* ICOMIX pointer to Compo isotope for region. +* VOLMER merge volume. +* ENERGY energy. +* TIME time steps. +* BURN burnup. +* WIRRAD irradiation. +* IBSTEP sub-burnup step considered. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPCPO,IPEDIT,IPDEPL + INTEGER IPRINT,NGROUP,NMERGE,CTITRE(18),NBMICR,NIFISS, + > MXBURN,NL,NISCPO,NPROC ,ILEAKS,NXXXZ,NEDMAC, + > NSBS ,ILOCAL,ISOCPO(3,NXXXZ),ISOTMP(3,NXXXZ), + > IDIMIX(NMERGE,NXXXZ),NBIMRG(NMERGE), + > ICOMIX(NMERGE,NXXXZ),IBSTEP(MXBURN) + CHARACTER CURNAM*12,NAMCPO*8,HVECT(NEDMAC)*8 + REAL VOLMER(NMERGE),ENERGY(NGROUP+1), + > TIME(MXBURN),BURN(MXBURN),WIRRAD(MXBURN) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: INDPRO,ITYPRO,NAMI + REAL, ALLOCATABLE, DIMENSION(:) :: DENTMP,EMJMAC,VECT,XSREC,XSCAT, + 1 DISFC,DENSI,EMJI + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: RVALOC + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DENCPO,XSREM,SCREM + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: DXSMIC,DMJCPO + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: DSCMIC,DXSMAC, + 1 DISFAC + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:) :: DSCMAC +*---- +* LOCAL PARAMETERS +*---- + INTEGER IOUT,NSTATE,NDPROC,NPARAM + REAL CUTOFF + PARAMETER (IOUT=6,NSTATE=40,NDPROC=20,NPARAM=4, + > CUTOFF=1.0E5) + INTEGER NEFBRN,IBR,IBR2,IBURN,NDUM1,NDUM2,MAXDM, + > IMRG,ISOC,ISOR,ITC,IDFLU, + > ISTATE(NSTATE),IPARAM(NPARAM),MXISOS, + > NBISO,NREAC,NVAR,NBMIX,NREG,NLOC + CHARACTER NAMMIX*12,NAMBRN*12,NAMISO*12,NAMMAC*12 + REAL DELTA(2),TMPDAY(3),DELERR(3) + DOUBLE PRECISION DMJMAC + INTEGER IFCDIS +*---- +* SCRATCH STORAGE ALLOCATION +* DENTMP density of EDI isotopes. +* EMJMAC fission energy for macroscopic data. +* DENCPO density of Compo isotopes. +* DMJCPO fission energy for macroscopic data. +* INDPRO identifier for xs processing. +* ITYPRO identifier for xs processed. +* DXSMIC micro vector xs. +* DSCMIC micro scattering matrix xs. +* DXSMAC macro vector xs. +* DSCMAC macro scattering matrix xs. +* DISFAC discontinuity factors. +* RVALOC local burnup and irradiation values. +*---- + ALLOCATE(INDPRO(NPROC),ITYPRO(NPROC)) + ALLOCATE(DENTMP(NXXXZ),EMJMAC(NMERGE),RVALOC(2,NMERGE,MXBURN)) + ALLOCATE(DENCPO(NXXXZ),DXSMIC(NGROUP,NPROC), + > DSCMIC(NGROUP,NGROUP,NL),DXSMAC(NGROUP,NPROC,NMERGE), + > DSCMAC(NGROUP,NGROUP,NL,NMERGE),DMJCPO(2,NXXXZ), + > DISFAC(2,NGROUP,3)) +*---- +* GET GLOBAL BURNUP AND IRRADIATION +*---- + IFCDIS=1 + NAMMAC='MACR ' + IF(NSBS.EQ.0) THEN + BURN(1)=0.0 + WIRRAD(1)=0.0 + NEFBRN=1 + IBSTEP(NEFBRN)=0 + ELSE + DO 100 IBR=1,NSBS + IBURN=IBSTEP(IBR) + IF(IBURN.GT.0.AND. IBURN.LE.MXBURN) THEN + WRITE(NAMBRN,'(8HDEPL-DAT,I4.4)') IBURN + CALL LCMSIX(IPDEPL,NAMBRN,1) + CALL LCMGET(IPDEPL,'BURNUP-IRRAD',DELTA) + BURN(IBR)=DELTA(1) + WIRRAD(IBR)=DELTA(2) + TIME(IBR)=TIME(IBURN) + CALL LCMSIX(IPDEPL,NAMBRN,2) + ENDIF + 100 CONTINUE + NEFBRN=NSBS + ENDIF +*---- +* GET LOCAL BURNUP AND IRRADIATION +*---- + IF((NSBS.EQ.0).OR.(ILOCAL.EQ.0).OR.(.NOT.C_ASSOCIATED(IPDEPL))) + 1 THEN + RVALOC(:2,:NMERGE,:NEFBRN)=0.0 + ELSE + NLOC=2 + CALL LCMGET(IPDEPL,'STATE-VECTOR',ISTATE) + IF(ISTATE(3).NE.MXBURN) CALL XABORT('CPODRV: INVALID STATE-VE' + 1 //'CTOR.') + NBISO=ISTATE(4) + NREAC=ISTATE(6) + NVAR=ISTATE(7) + NBMIX=ISTATE(8) + CALL LCMGET(IPEDIT,'STATE-VECTOR',ISTATE) + NREG=ISTATE(17) + DO 105 IBR=1,NSBS + IBURN=IBSTEP(IBR) + CALL COMGEN(IPDEPL,IPEDIT,NREG,NMERGE,IBURN,'FLUB',MXBURN, + 1 NBMIX,NBISO,NREAC,NVAR,1,NLOC,RVALOC(1,1,IBR)) + CALL COMGEN(IPDEPL,IPEDIT,NREG,NMERGE,IBURN,'IRRA',MXBURN, + 1 NBMIX,NBISO,NREAC,NVAR,2,NLOC,RVALOC(1,1,IBR)) + 105 CONTINUE + ENDIF +*---- +* INITIALIZE INDPRO FOR MICROSCOPIC XS TO PROCESS +*---- + ALLOCATE(VECT(NEDMAC)) + VECT(:NEDMAC)=0.0 + CALL CPONED(NPROC ,0,NL-1,MAX(1,ILEAKS),NEDMAC,HVECT,VECT,INDPRO) + INDPRO(6)=0 + INDPRO(16)=0 + ALLOCATE(XSREC(NGROUP*NPROC),XSCAT(NGROUP*NGROUP*NL)) +*---- +* LOOP OVER BURNUP STEPS +*---- + NDUM1=NMERGE*MAX(NIFISS,NGROUP) + NDUM2=NGROUP*NGROUP + MAXDM=MAX(NDUM1,NDUM2) + ALLOCATE(DISFC(NGROUP)) + ALLOCATE(XSREM(NGROUP*NPROC),SCREM(NGROUP*NGROUP*NL)) + IDFLU=16 + MXISOS=0 + DO 110 IBR=1,NEFBRN + WRITE(NAMBRN,'(A8,I4)') 'BURN ',IBR + IBURN=IBSTEP(IBR) + IF(IBURN.GT.0) WRITE(CURNAM(9:12),'(I4.4)') IBURN + CALL LCMSIX(IPEDIT,CURNAM,1) + IF(NISCPO.GT.0) CALL LCMGET(IPEDIT,'ISOTOPESDENS',DENTMP) + IF(IPRINT.GE.10) WRITE(IOUT,6000) CURNAM + CALL LCMSIX(IPEDIT,'MACROLIB',1) + CALL LCMGET(IPEDIT,'TIMESTAMP',TMPDAY) + DELERR(1)=CUTOFF*ABS(TMPDAY(1)-TIME(IBR)/8.64E-4) + DELERR(2)=CUTOFF*ABS(TMPDAY(2)-BURN(IBR)) + DELERR(3)=CUTOFF*ABS(TMPDAY(3)-WIRRAD(IBR)) + IF( (DELERR(1).GT.TMPDAY(1)) .OR. + > (DELERR(2).GT.TMPDAY(2)) .OR. + > (DELERR(3).GT.TMPDAY(3)) ) THEN + IF(TIME(IBR) .EQ. 0.0 .AND. + > BURN(IBR) .EQ. 0.0 .AND. + > WIRRAD(IBR) .EQ. 0.0) THEN + WRITE(IOUT,7001) + ELSE + WRITE(IOUT,7000) + > TMPDAY(1),TIME(IBR)/8.64E-4,DELERR(1)/CUTOFF, + > TMPDAY(2),BURN(IBR),DELERR(2)/CUTOFF, + > TMPDAY(3),WIRRAD(IBR) ,DELERR(3)/CUTOFF + ENDIF + TIME(IBR)=TMPDAY(1)*8.64E-4 + BURN(IBR)=TMPDAY(2) + WIRRAD(IBR)=TMPDAY(3) + ENDIF +*---- +* READ MACROSCOPIC XS FOR ALL GROUP AND ALL REGIONS +*---- + CALL CPOMAR(IPEDIT,NGROUP,NMERGE,NL ,NIFISS,NEDMAC, + > HVECT ,VECT ,NPROC ,ILEAKS,DXSMAC, + > DSCMAC,EMJMAC,DISFC,IFCDIS,DISFAC) + CALL LCMSIX(IPEDIT,'MACROLIB',2) + DENCPO(:NISCPO)=0.0D0 + DO 120 IMRG=1,NMERGE + DMJMAC=DBLE(EMJMAC(IMRG)) + WRITE(NAMMIX,'(A8,I4)') NAMCPO,IMRG + CALL LCMSIX(IPCPO,NAMMIX,1) + CALL LCMSIX(IPCPO,NAMBRN,1) + IF(IPRINT.GE.10) WRITE(IOUT,6001) NAMMIX + DMJCPO(:2,:NBMICR)=0.0D0 + XSREM(:NGROUP*NPROC)=0.0D0 + SCREM(:NGROUP*NGROUP*NL)=0.0D0 + DO 130 ISOC=1,NBIMRG(IMRG) + ISOR=ICOMIX(IMRG,ISOC) + WRITE(NAMISO,'(3A4)') (ISOCPO(ITC,ISOR),ITC=1,3) + IF(IPRINT.GE.10) WRITE(IOUT,6002) NAMISO +*---- +* CREATE AND SAVE XS FOR A CPO ISOTOPE IN CURRENT REGION +*---- + CALL LCMSIX(IPCPO,NAMISO,1) + DXSMIC(:NGROUP,:NPROC)=0.0D0 + DSCMIC(:NGROUP,:NGROUP,:NL)=0.0D0 + CALL CPOMIC(IPCPO ,IPEDIT,IPRINT,NGROUP,NMERGE,NBMICR, + > NL ,IMRG ,ISOR ,NPROC ,ISOTMP,IDIMIX, + > INDPRO,ITYPRO,DENCPO,DENTMP,DXSMIC,DSCMIC, + > DMJCPO,DXSMAC(1,IDFLU,IMRG)) + CALL LCMSIX(IPCPO,NAMISO,2) +*---- +* REMOVE CONTRIBUTION OF CPO ISOTOPE FROM MACROSCOPIC. +*---- + IF(DENCPO(ISOR).GT.0.0D0) THEN + CALL CPOREM(NGROUP,NL ,NPROC ,INDPRO,DENCPO(ISOR), + > DXSMIC,DSCMIC,XSREM ,SCREM ) + ENDIF + DMJMAC=DMJMAC-DMJCPO(1,ISOR) + 130 CONTINUE +*---- +* WRITE MACROSCOPIC XS FOR ALL GROUP IN THIS REGION REGIONS +*---- + CALL CPOMAW(IPCPO ,IPRINT,NGROUP,NL ,NPROC ,INDPRO, + > ITYPRO,DXSMAC(1,1,IMRG),DSCMAC(1,1,1,IMRG), + > XSREM,SCREM,DISFC,DMJMAC,IFCDIS,DISFAC) + ALLOCATE(DENSI(NBIMRG(IMRG)+1),EMJI(NBIMRG(IMRG)+1)) + DENSI(1)=1.0 + EMJI=REAL(DMJMAC)*1.0E-18 + DO 140 ISOC=1,NBIMRG(IMRG) + ISOR=ICOMIX(IMRG,ISOC) + DENSI(ISOC+1)=REAL(DENCPO(ISOR)) + IF(DMJCPO(2,ISOR).GT.0.0D0) THEN + EMJI(ISOC+1)=1.0E-18*REAL(DMJCPO(1,ISOR)/DMJCPO(2,ISOR)) + ELSE + EMJI(ISOC+1)=0.0 + ENDIF + 140 CONTINUE + CALL LCMPUT(IPCPO,'ISOTOPESDENS',(NBIMRG(IMRG)+1),2,DENSI) + CALL LCMPUT(IPCPO,'ISOTOPES-EFJ',(NBIMRG(IMRG)+1),2,EMJI) + DEALLOCATE(EMJI,DENSI) + CALL LCMSIX(IPCPO,NAMBRN,2) +*---- +* PUT REMAINING INFORMATION ON CPO FOR THIS MIXTURE +*---- + CALL LCMPUT(IPCPO,'TITLE',18,3,CTITRE) + CALL LCMPUT(IPCPO,'VOLUME',1,2,VOLMER(IMRG)) + CALL LCMPUT(IPCPO,'ENERGY',NGROUP+1,2,ENERGY) + IF(IBR.EQ.NEFBRN) THEN + IF(ILOCAL.EQ.1) THEN + DO 145 IBR2=1,NEFBRN + WIRRAD(IBR2)=RVALOC(1,IMRG,IBR2) + BURN(IBR2)=RVALOC(2,IMRG,IBR2) + 145 CONTINUE + ENDIF + IF(IPRINT.GT.1) THEN + WRITE(IOUT,7002) IMRG,'IRRA',(WIRRAD(IBR2),IBR2=1,NEFBRN) + WRITE(IOUT,7002) IMRG,'BURN',(BURN(IBR2),IBR2=1,NEFBRN) + ENDIF + CALL LCMPUT(IPCPO,'N/KB ',NEFBRN,2,WIRRAD) + CALL LCMPUT(IPCPO,'BURNUP',NEFBRN,2,BURN) + ALLOCATE(NAMI(3*(NBIMRG(IMRG)+1))) + READ(NAMMAC,'(3A4)') (NAMI(ITC+1),ITC=0,2) + ITC=3 + DO 150 ISOC=1,NBIMRG(IMRG) + ISOR=ICOMIX(IMRG,ISOC) + NAMI(ITC+1)=ISOCPO(1,ISOR) + NAMI(ITC+2)=ISOCPO(2,ISOR) + NAMI(ITC+3)=ISOCPO(3,ISOR) + ITC=ITC+3 + 150 CONTINUE + CALL LCMPUT(IPCPO,'ISOTOPESNAME',3*(NBIMRG(IMRG)+1),3,NAMI) + NAMI(:NBIMRG(IMRG)+1)=0 + CALL LCMPUT(IPCPO,'JTAB',(NBIMRG(IMRG)+1),1,NAMI) + DEALLOCATE(NAMI) + IPARAM(:NPARAM)=0 + IPARAM(1)=NGROUP + IPARAM(2)=NBIMRG(IMRG)+1 + IPARAM(3)=NL + IPARAM(4)=NEFBRN + MXISOS=MAX(MXISOS,NBIMRG(IMRG)+1) + CALL LCMPUT(IPCPO,'PARAM',NPARAM,1,IPARAM) + ENDIF + CALL LCMSIX(IPCPO,NAMMIX,2) + 120 CONTINUE + CALL LCMSIX(IPEDIT,CURNAM,2) + 110 CONTINUE + ISTATE(:NSTATE)=0 + ISTATE(1)=NMERGE + ISTATE(2)=NGROUP + ISTATE(3)=MXISOS + ISTATE(4)=NL + ISTATE(5)=NEFBRN + ISTATE(6)=NPARAM + ISTATE(7)=IFCDIS + CALL LCMPUT(IPCPO,'STATE-VECTOR',NSTATE,1,ISTATE) + DEALLOCATE(SCREM,XSREM,DISFC) + IF(NISCPO.GT.0) DEALLOCATE(XSCAT,XSREC,VECT) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(DISFAC,DMJCPO,DSCMAC,DXSMAC,DSCMIC,DXSMIC,DENCPO) + DEALLOCATE(RVALOC,EMJMAC,DENTMP) + DEALLOCATE(ITYPRO,INDPRO) + RETURN +*---- +* PRINT FORMAT +*---- + 6000 FORMAT(' CPODRV: STEPPING UP ON DIRECTORY = ',A12) + 6001 FORMAT(' CPODRV: CREATING MIXTURE = ',A12) + 6002 FORMAT(' CPODRV: CREATING ISOTOPE = ',A12) +*---- +* WARNING FORMAT +*---- + 7000 FORMAT( + > ' CPODRV: WARNING -> BURNUP AND EDIT DATA DIFFER',1P/ + > ' TIME: EDIT=',E15.7,5X,' BURNUP=',E15.7,' DIFF=',E15.7/ + > ' BURN: EDIT=',E15.7,5X,' BURNUP=',E15.7,' DIFF=',E15.7/ + > ' WIRR: EDIT=',E15.7,5X,' BURNUP=',E15.7,' DIFF=',E15.7/ + > ' USE EDIT DATA ') + 7001 FORMAT( + > ' CPODRV: WARNING -> 0 BURNUP STEP, USE EDIT DATA') + 7002 FORMAT(/13H CPODRV: MIX=,I4,3X,A,1H=,1P,6E12.4/(25X,6E12.4)) + END diff --git a/Dragon/src/CPOISO.f b/Dragon/src/CPOISO.f new file mode 100644 index 0000000..bac04a9 --- /dev/null +++ b/Dragon/src/CPOISO.f @@ -0,0 +1,188 @@ +*DECK CPOISO + SUBROUTINE CPOISO(IPRINT,IEXTRC,NMERGE,MAXISO,MAXISM,NBMICR, + > NISCPO,NISEXT,ISOCPO,ISOEXT,ISOORD,ISOTMP, + > IMXTMP,IDIMIX,NBIMRG,ICOMIX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Identify isotopes to be extracted from macroscopic xs and isotopes +* included in new combined isotopes. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau +* +*Parameters: input +* IPRINT print parameter. Equal to zero for no print. +* IEXTRC type of extraction: 1 for part 2 for all. +* NMERGE number of region. +* MAXISO maximum nunber of isotopes permitted. +* MAXISM maximum nunber of isotopes per region. +* NBMICR maximum number of isotopes in EDIT. +* NISCPO number of Compo isotopes treated. +* NISEXT number of extracted isotopes treated. +* ISOCPO Compo name of isotopes. +* ISOEXT name of extracted isotopes. +* ISOORD order of extracted isotopes. +* ISOTMP name of isotopes in EDIT. +* IMXTMP mixture of isotopes in EDIT. +* +*Parameters: output +* IDIMIX isotopes identifier in each Compo material. +* NBIMRG final number of isotope per region. +* ICOMIX pointer to Compo isotope for region. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IPRINT,IEXTRC,NMERGE,MAXISO,MAXISM,NBMICR,NISCPO, + > NISEXT,ISOCPO(3,MAXISO), + > ISOEXT(3,MAXISO),ISOORD(MAXISO),ISOTMP(3,NBMICR), + > IMXTMP(NBMICR),IDIMIX(NMERGE,NBMICR), + > NBIMRG(NMERGE),ICOMIX(NMERGE,MAXISM) +*---- +* LOCAL PARAMETERS +*---- + INTEGER IOUT + CHARACTER TEXT4*4 + PARAMETER (IOUT=6) + INTEGER ISOM,ISOE,ISOC,IMRG,ITEXT4,ITC + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDETMP +*---- +* SCRATCH STORAGE ALLOCATION +* IDETMP extracted isotopes number associated with EDIT isotope. +*---- + ALLOCATE(IDETMP(NBMICR)) + IDETMP(:NBMICR)=0 +*---- +* STORE IN ITEXT4 BLANCK STRING +*---- + TEXT4=' ' + READ(TEXT4,'(A4)') ITEXT4 +*---- +* IF EXTRACT ALL USED (IEXTRC=2) +* GENERATE ISOCPO, ISOEXT AND ISOORD +* ASSOCIATE WITH ALL ISOTOPES EXTRACTED ISOTOPE NUMBER +* NAMELY IDETMP(ISOM)=ISOEXT(ISOE) +*---- + IF(IEXTRC.EQ.2) THEN + NISEXT=0 + DO 100 ISOM=1,NBMICR + DO 110 ISOE=1,NISEXT + IF(ISOEXT(1,ISOE).EQ.ISOTMP(1,ISOM).AND. + > ISOEXT(2,ISOE).EQ.ISOTMP(2,ISOM)) GO TO 115 + 110 CONTINUE + IF(NISEXT.EQ.MAXISO) THEN + WRITE(IOUT,7000) MAXISO,ISOTMP(1,ISOM),ISOTMP(2,ISOM) + ELSE + NISEXT=NISEXT+1 + ISOEXT(1,NISEXT)=ISOTMP(1,ISOM) + ISOEXT(2,NISEXT)=ISOTMP(2,ISOM) + ISOEXT(3,NISEXT)=ITEXT4 + ISOCPO(1,NISEXT)=ISOTMP(1,ISOM) + ISOCPO(2,NISEXT)=ISOTMP(2,ISOM) + ISOCPO(3,NISEXT)=ITEXT4 + ISOORD(NISEXT)=NISEXT + IDETMP(ISOM)=NISEXT + ENDIF + 115 CONTINUE + 100 CONTINUE + NISCPO=NISEXT + ELSE +*---- +* IF SPECIFIC ISOTOPES EXTRACTED (IEXTRC=1) +* FOR GENERIC EXTRACTED NAME (ISOEXT(3,ISOE)=' ') +* ASSOCIATE WITH SET OF ISOTOPE EXTRACTED ISOTOPE NUMBER +* NAMELY IDETMP(ISOM)=ISOEXT(ISOE) +* FOR EXPLICIT EXTRACTED NAMES +* ASSOCIATE WITH SPECIFIC ISOTOPE EXTRACTED ISOTOPE NUMBER +* NAMELY IDETMP(ISOM)=ISOEXT(ISOE) +*---- + DO 120 ISOE=1,NISEXT + IF(ISOEXT(3,ISOE).EQ.ITEXT4) THEN + DO 130 ISOM=1,NBMICR + IF(ISOEXT(1,ISOE).EQ.ISOTMP(1,ISOM).AND. + > ISOEXT(2,ISOE).EQ.ISOTMP(2,ISOM)) THEN + IDETMP(ISOM)=ISOE + ENDIF + 130 CONTINUE + ELSE + DO 140 ISOM=1,NBMICR + IF(ISOEXT(1,ISOE).EQ.ISOTMP(1,ISOM).AND. + > ISOEXT(2,ISOE).EQ.ISOTMP(2,ISOM).AND. + > ISOEXT(3,ISOE).EQ.ISOTMP(3,ISOM)) THEN + IDETMP(ISOM)=ISOE + ENDIF + 140 CONTINUE + ENDIF + 120 CONTINUE + ENDIF +*---- +* IDENTIFY EXTRACTED ISOTOPES +*---- + DO 150 ISOM=1,NBMICR + IMRG=IMXTMP(ISOM) + ISOE=IDETMP(ISOM) + IF(IMRG.NE.0.AND.ISOE.NE.0) THEN + IDIMIX(IMRG,ISOM)=ISOORD(ISOE) + ENDIF + 150 CONTINUE +*---- +* COMPUTED NUMBER OF ISOTOPES PER MIXTURE +*---- + DO 160 IMRG=1,NMERGE + NBIMRG(IMRG)=0 + DO 170 ISOM=1,NBMICR + ISOC=IDIMIX(IMRG,ISOM) + IF(ISOC.NE.0) THEN + DO 180 ISOE=1,NBIMRG(IMRG) + IF(ISOC.EQ.ICOMIX(IMRG,ISOE)) GO TO 185 + 180 CONTINUE + NBIMRG(IMRG)=NBIMRG(IMRG)+1 + ICOMIX(IMRG,NBIMRG(IMRG))=ISOC + 185 CONTINUE + ENDIF + 170 CONTINUE + 160 CONTINUE + IF(IPRINT.GE.1) THEN + WRITE(IOUT,6000) + DO 190 IMRG=1,NMERGE + IF(NBIMRG(IMRG).GT.0) THEN + DO 191 ISOM=1,NBMICR + ISOC=IDIMIX(IMRG,ISOM) + IF(ISOC.NE.0) THEN + WRITE(IOUT,6001) IMRG,(ISOCPO(ITC,ISOC),ITC=1,3), + > (ISOTMP(ITC,ISOM),ITC=1,3) + ENDIF + 191 CONTINUE + ENDIF + 190 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IDETMP) + RETURN +*---- +* PRINT FORMAT +*---- + 6000 FORMAT(' CPO: LIST OF EXTRACTED ISOTOPES:'/ + > 10X,'REGION',10X,'CPO NAME ',10X,'EDIT NAME ') + 6001 FORMAT(10X,I6,10X,3A4,' CONTAINS ',3A4) +*---- +* WARNING FORMAT +*---- + 7000 FORMAT(' CPOISO: ****** WARNING ******'/ + > ' MAXIMUM NUMBER OF ISOTOPE REACHED = ',I8/ + > ' SKIP GENERIC ISOTOPE NAME = ',2A4/ + > ' *****************************') + END diff --git a/Dragon/src/CPOLGX.f b/Dragon/src/CPOLGX.f new file mode 100644 index 0000000..ac5e44b --- /dev/null +++ b/Dragon/src/CPOLGX.f @@ -0,0 +1,192 @@ +*DECK CPOLGX + SUBROUTINE CPOLGX(IPLIB ,IGS ,IPRINT,IORD ,NGROUP,INDPRO, + > XSREC ,ITYPRO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Get/save standard vectorial cross section data from/on IPLIB. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau +* +*Parameters: input +* IPLIB pointer to the internal library. +* IGS get or save flag: +* >0 save; +* <0 get. +* IPRINT Print level (cross sections printed if IPRINT>99). +* IORD cross section order: +* =1 constant; +* =2 linear; +* =3 quadratic. +* NGROUP number of energy groups. +* INDPRO vector for cross section to process: +* =0 do not process; +* >0 process. +* +*Parameters: input/output +* XSREC cross section table. +* +*Parameters: output +* ITYPRO vector for cross section processed indices: +* =0 absent (not processed); +* >0 present (processed). +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NDPROC + PARAMETER (NDPROC=20) + TYPE(C_PTR) IPLIB + INTEGER IGS,IPRINT,IORD,NGROUP,INDPRO(NDPROC), + > ITYPRO(NDPROC) + REAL XSREC(NGROUP,NDPROC) +*---- +* LOCAL PARAMETERS +* NDPROC = NUMBER OF DEFAULT CROSS SECTIONS = 20 +* NAMDXS = NAME OF NDPROC DEFAULT XS +*---- + INTEGER IOUT + PARAMETER (IOUT=6) + CHARACTER NAMDXS(NDPROC)*6,NORD*6,TEXT6*6,TEXT12*12,NAMT*12 + INTEGER IODIV,LONG,ITYP,IXSR,IXSTN,IG,JG + SAVE NAMDXS + DATA NAMDXS /'NTOT0 ','TRANC ','NUSIGF','NFTOT ','CHI ', + > 'NU ','NG ','NHEAT ','N2N ','N3N ', + > 'N4N ','NP ','NA ','GOLD ','ABS ', + > 'NWT0 ','STRD ','STRD X','STRD Y','STRD Z'/ + IODIV=0 + IF(IORD.EQ.1) THEN + NORD=' ' + IODIV=1 + ELSE IF(IORD.EQ.2) THEN + NORD=' LIN' + IODIV=2 + ELSE IF(IORD.EQ.3) THEN + NORD=' QUA' + IODIV=4 + ENDIF +*---- +* READ/INITIALIZE STATE VECTOR +*---- + CALL LCMLEN(IPLIB,'XS-SAVED',LONG,ITYP) + IF(LONG.EQ.NDPROC) THEN + CALL LCMGET(IPLIB,'XS-SAVED',ITYPRO) + ELSE IF(LONG.EQ.0) THEN + ITYPRO(:NDPROC)=0 + NAMT=' ' + CALL LCMNXT(IPLIB,NAMT) + TEXT12=NAMT + 80 CALL LCMLEN(IPLIB,NAMT,LONG,ITYP) + IF(ITYP.EQ.2) THEN + DO 90 IXSR=1,NDPROC + IF(NAMT(:6).EQ.NAMDXS(IXSR)) ITYPRO(IXSR)=1 + 90 CONTINUE + ENDIF + CALL LCMNXT(IPLIB,NAMT) + IF(NAMT.NE.TEXT12) GO TO 80 + ELSE + WRITE(IOUT,9000) NDPROC,LONG + CALL XABORT('CPOLGX: INVALID VALUE FOR NDPROC') + ENDIF + IF(IGS.GT.0) THEN +*---- +* SAVE LOCAL DEFAULT XS IF REQUIRED +*---- + IF(IGS.EQ.1) THEN + DO 100 IXSR=1,NDPROC + TEXT6=NAMDXS(IXSR) + IF(IXSR.EQ.1) TEXT6='TOTAL' + IF(INDPRO(IXSR).EQ.1) THEN + IXSTN=MOD(ITYPRO(IXSR)/IODIV,2) +*---- +* FIND IF XS NOT ALL 0.0 +*---- + DO 110 IG=1,NGROUP + IF(XSREC(IG,IXSR).NE.0.0) THEN + IF(IXSTN.EQ.0) THEN + ITYPRO(IXSR)=ITYPRO(IXSR)+IODIV + IXSTN=1 + ENDIF + GO TO 115 + ENDIF + 110 CONTINUE + 115 CONTINUE + IF((IXSTN.NE.0).OR.(IXSR.EQ.2)) THEN + CALL LCMPUT(IPLIB,TEXT6//NORD,NGROUP,2,XSREC(1,IXSR)) + ENDIF + ENDIF + 100 CONTINUE + ENDIF + CALL LCMPUT(IPLIB,'XS-SAVED',NDPROC,1,ITYPRO) + ELSE +*---- +* GET LOCAL DEFAULT XS IF REQUIRED +*---- + IF(IGS.EQ.-1) THEN + DO 200 IXSR=1,NDPROC + TEXT6=NAMDXS(IXSR) + IF(IXSR.EQ.1) TEXT6='NTOT0' + IF(INDPRO(IXSR).EQ.1) THEN + IXSTN=MOD(ITYPRO(IXSR)/IODIV,2) +*---- +* READ IF IXSTN = 1 +* INITIALIZE TO 0.0 IF IXSTN = 0 +*---- + IF(IXSTN.EQ.1) THEN + CALL LCMLEN(IPLIB,TEXT6//NORD,LONG,ITYP) + IF(LONG .EQ. 0) THEN + XSREC(:NGROUP,IXSR)=0.0 + ELSE + CALL LCMGET(IPLIB,TEXT6//NORD,XSREC(1,IXSR)) + ENDIF + ELSE + XSREC(:NGROUP,IXSR)=0.0 + ENDIF + ENDIF + 200 CONTINUE + ENDIF + ENDIF + IF(IPRINT .GE. 100) THEN +*---- +* Print XS +*---- + DO IXSR=1,NDPROC + IF(INDPRO(IXSR).EQ.1) THEN + IXSTN=MOD(ITYPRO(IXSR)/IODIV,2) + IF(IXSTN.NE.0) THEN + DO IG=1,NGROUP + IF(XSREC(IG,IXSR).NE.0.0) THEN + WRITE(IOUT,6000) NAMDXS(IXSR)//NORD + WRITE(IOUT,6010) (XSREC(JG,IXSR),JG=1,NGROUP) + GO TO 210 + ENDIF + ENDDO + ENDIF + 210 CONTINUE + ENDIF + ENDDO + ENDIF + RETURN +*---- +* ABORT FORMAT +*---- + 9000 FORMAT(' CPOLGX: ****** ABORT ******'/ + > ' INVALID LENGTH OF RECORD XS-SAVED '/ + > ' STORAGE SPACE NDPROC = ',I10/ + > ' LENGTH OF RECORD LONG = ',I10/ + > ' ***************************') + 6000 FORMAT(/' CROSS SECTION TYPE = ',A12) + 6010 FORMAT(1P,5E16.7) + END diff --git a/Dragon/src/CPOMAR.f b/Dragon/src/CPOMAR.f new file mode 100644 index 0000000..fa21356 --- /dev/null +++ b/Dragon/src/CPOMAR.f @@ -0,0 +1,288 @@ +*DECK CPOMAR + SUBROUTINE CPOMAR(IPEDIT,NGROUP,NMERGE,NL ,NIFISS,NEDMAC, + > HVECT ,IVECT ,NPROC ,ILEAKS,DXSMAC,DSCMAC, + > EMJMAC,DISFC ,IFCDIS,DISFAC ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Get macroscopic cross section from IPEDIT. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau +* +*Parameters: input +* IPEDIT pointer to the edit. +* NGROUP number of groups condensed. +* NMERGE number of regions merged. +* NL number of Legendre orders. +* NIFISS number of fissile isotopes. +* NEDMAC number of extra edit vectors. +* HVECT name of additional xs. +* IVECT location of additional xs. +* NPROC number of microscopic xs to process. +* ILEAKS leak calculation: +* = 0 no leakage; +* = 1 homogeneous leakage coefficients; +* = 2 directional leakage coefficients. +* +*Parameters: output +* DXSMAC averaged region/group x-s. +* DSCMAC scattering rates. +* DISFC disadvantage factor. +* EMJMAC energy per fission. +* IFCDIS discontinuity factor present (1) or absent. +* DISFAC discontinuity factors. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPEDIT + INTEGER NGROUP,NMERGE,NL,NIFISS,NEDMAC,IVECT(NEDMAC), + > NPROC,ILEAKS + CHARACTER HVECT(NEDMAC)*8 + REAL DISFC(NGROUP), + > EMJMAC(NMERGE) + DOUBLE PRECISION DXSMAC(NGROUP,NPROC,NMERGE), + > DSCMAC(NGROUP,NGROUP,NL,NMERGE) + INTEGER IFCDIS + DOUBLE PRECISION DISFAC(2,NGROUP,3) +*---- +* LOCAL PARAMETERS +*---- + TYPE(C_PTR) JPEDIT,KPEDIT + INTEGER NDPROC + PARAMETER (NDPROC=20) + INTEGER IGR,IED,IXSR,JXSR,KXSR,IMRG,IFIS,ILOCED, + > IL,IPOSIT,JGR1,JGR2,JGR,ILCMLN,ITYLCM + CHARACTER CM*2 + INTEGER IDIR,IPL,IEL + REAL TEMP(6) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ + REAL, ALLOCATABLE, DIMENSION(:) :: SCATC + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: DNUFI +*---- +* SCRATCH STORAGE ALLOCATION +* SCATC compress scattering data. +* IJJ position of first diffusion group. +* NJJ number of diffusion group. +* DNUFI fission source. +*---- + ALLOCATE(IJJ(NMERGE),NJJ(NMERGE)) + ALLOCATE(SCATC(NMERGE*NGROUP)) + ALLOCATE(DNUFI(NMERGE,NIFISS+1)) +*---- +* INITIALIZE REACTION RATE VECTOR +*---- + DXSMAC(:NGROUP,:NPROC,:NMERGE)=0.0D0 + DSCMAC(:NGROUP,:NGROUP,:NL,:NMERGE)=0.0D0 + DNUFI(:NMERGE,:NIFISS+1)=0.0D0 +*---- +* READ ALL CROSS SECTION FROM IPEDIT EXCEPT CHI +*---- + CALL LCMLEN(IPEDIT,'FLUXDISAFACT',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.NGROUP) THEN + CALL LCMGET(IPEDIT,'FLUXDISAFACT',DISFC) + ELSE + DISFC(:NGROUP)=0.0 + ENDIF + JPEDIT=LCMGID(IPEDIT,'GROUP') + DO 100 IGR=1,NGROUP + KPEDIT=LCMGIL(JPEDIT,IGR) + IF(NEDMAC.GT.0) THEN + DO 110 IED=1,NEDMAC + IXSR=IVECT(IED) + IF(IXSR.GT.0) THEN + CALL LCMGET(KPEDIT,HVECT(IED),SCATC) + DO 111 IMRG=1,NMERGE + DXSMAC(IGR,IXSR,IMRG)=DBLE(SCATC(IMRG)) + 111 CONTINUE + ENDIF + 110 CONTINUE + ENDIF + IXSR=NDPROC+NL+1 + CALL LCMLEN(KPEDIT,'OVERV',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.NMERGE) THEN + CALL LCMGET(KPEDIT,'OVERV',SCATC) + DO 120 IMRG=1,NMERGE + DXSMAC(IGR,IXSR,IMRG)=DBLE(SCATC(IMRG)) + 120 CONTINUE + ENDIF + IXSR=1 + CALL LCMGET(KPEDIT,'NTOT0',SCATC) + DO 130 IMRG=1,NMERGE + DXSMAC(IGR,IXSR,IMRG)=DBLE(SCATC(IMRG)) + 130 CONTINUE + IXSR=2 + CALL LCMGET(KPEDIT,'TRANC',SCATC) + DO 170 IMRG=1,NMERGE + DXSMAC(IGR,IXSR,IMRG)=DBLE(SCATC(IMRG)) + 170 CONTINUE + IF(IFCDIS .EQ. 1) THEN + CALL LCMLEN(KPEDIT,'ADFGENERAL',ILCMLN,ITYLCM) + IF(ILCMLN .EQ. 6) THEN + CALL LCMGET(KPEDIT,'ADFGENERAL',TEMP) + IEL=0 + DO IDIR=1,3 + DO IPL=1,2 + IEL=IEL+1 + DISFAC(IPL,IGR,IDIR)=DBLE(TEMP(IEL)) + ENDDO + ENDDO + ELSE + IFCDIS=0 + ENDIF + ENDIF + IXSR=16 + CALL LCMGET(KPEDIT,'FLUX-INTG',SCATC) + DO 190 IMRG=1,NMERGE + DXSMAC(IGR,IXSR,IMRG)=DBLE(SCATC(IMRG)) + 190 CONTINUE + IF(NIFISS.GT.0) THEN + IXSR=3 + JXSR=16 + CALL LCMGET(KPEDIT,'NUSIGF',SCATC) + ILOCED=1 + DO 150 IFIS=1,NIFISS + DO 151 IMRG=1,NMERGE + DXSMAC(IGR,IXSR,IMRG)=DXSMAC(IGR,IXSR,IMRG) + > +DBLE(SCATC(ILOCED)) + DNUFI(IMRG,IFIS)=DNUFI(IMRG,IFIS) + > +DBLE(SCATC(ILOCED))*DXSMAC(IGR,JXSR,IMRG) + ILOCED=ILOCED+1 + 151 CONTINUE + 150 CONTINUE + IXSR=4 + CALL LCMGET(KPEDIT,'NFTOT',SCATC) + DO 153 IMRG=1,NMERGE + DXSMAC(IGR,IXSR,IMRG)=DXSMAC(IGR,IXSR,IMRG) + > +DBLE(SCATC(IMRG)) + 153 CONTINUE + ENDIF + IXSR=NDPROC + DO 200 IL=1,NL + IXSR=IXSR+1 + WRITE (CM,'(I2.2)') IL-1 + CALL LCMGET(KPEDIT,'SCAT'//CM,SCATC) + CALL LCMGET(KPEDIT,'NJJS'//CM,NJJ) + CALL LCMGET(KPEDIT,'IJJS'//CM,IJJ) + IPOSIT=0 + DO 210 IMRG=1,NMERGE + JGR2=IJJ(IMRG) + JGR1=JGR2-NJJ(IMRG)+1 + DO 211 JGR=JGR2,JGR1,-1 + IPOSIT=IPOSIT+1 + DSCMAC(IGR,JGR,IL,IMRG)=DBLE(SCATC(IPOSIT)) + DXSMAC(JGR,IXSR,IMRG)=DXSMAC(JGR,IXSR,IMRG) + > +DSCMAC(IGR,JGR,IL,IMRG) + 211 CONTINUE + 210 CONTINUE + 200 CONTINUE + IF(ILEAKS.EQ.1) THEN + IXSR=17 + CALL LCMGET(KPEDIT,'DIFF',SCATC) + DO 180 IMRG=1,NMERGE + IF(SCATC(IMRG).GT.0.0) THEN + DXSMAC(IGR,IXSR,IMRG)=1.0D0/(3.0D0*DBLE(SCATC(IMRG))) + ENDIF + 180 CONTINUE + ELSE IF(ILEAKS.EQ.2) THEN + IXSR=17 + CALL LCMGET(KPEDIT,'DIFF',SCATC) + DO 181 IMRG=1,NMERGE + IF(SCATC(IMRG).GT.0.0) THEN + DXSMAC(IGR,IXSR,IMRG)=1.0D0/(3.0D0*DBLE(SCATC(IMRG))) + ENDIF + 181 CONTINUE + IXSR=18 + CALL LCMGET(KPEDIT,'DIFFX',SCATC) + DO 182 IMRG=1,NMERGE + IF(SCATC(IMRG).GT.0.0) THEN + DXSMAC(IGR,IXSR,IMRG)=1.0D0/(3.0D0*DBLE(SCATC(IMRG))) + ENDIF + 182 CONTINUE + IXSR=19 + CALL LCMGET(KPEDIT,'DIFFY',SCATC) + DO 183 IMRG=1,NMERGE + IF(SCATC(IMRG).GT.0.0) THEN + DXSMAC(IGR,IXSR,IMRG)=1.0D0/(3.0D0*DBLE(SCATC(IMRG))) + ENDIF + 183 CONTINUE + IXSR=20 + CALL LCMGET(KPEDIT,'DIFFZ',SCATC) + DO 184 IMRG=1,NMERGE + IF(SCATC(IMRG).GT.0.0) THEN + DXSMAC(IGR,IXSR,IMRG)=1.0D0/(3.0D0*DBLE(SCATC(IMRG))) + ENDIF + 184 CONTINUE + ELSE + IXSR=17 + JXSR=1 + IF(NL.GE.2) THEN + KXSR=NDPROC+2 + DO 185 IMRG=1,NMERGE + DXSMAC(IGR,IXSR,IMRG)=DXSMAC(IGR,JXSR,IMRG) + > -DXSMAC(IGR,KXSR,IMRG) + 185 CONTINUE + ELSE + DO 186 IMRG=1,NMERGE + DXSMAC(IGR,IXSR,IMRG)=DXSMAC(IGR,JXSR,IMRG) + 186 CONTINUE + ENDIF + ENDIF + 100 CONTINUE +*---- +* PROCESS CHI IF REQUIRED +*---- + IF(NIFISS.GT.0) THEN + DO 160 IGR=1,NGROUP + KPEDIT=LCMGIL(JPEDIT,IGR) + IXSR=5 + CALL LCMGET(KPEDIT,'CHI',SCATC) + ILOCED=1 + DO 161 IFIS=1,NIFISS + DO 162 IMRG=1,NMERGE + DXSMAC(IGR,IXSR,IMRG)=DXSMAC(IGR,IXSR,IMRG) + > +DBLE(SCATC(ILOCED))*DNUFI(IMRG,IFIS) + ILOCED=ILOCED+1 + 162 CONTINUE + 161 CONTINUE + 160 CONTINUE + ENDIF +*---- +* FIND TOTAL ENERGY PRODUCTION +*---- + JXSR=16 + EMJMAC(:NMERGE)=0.0 + DO 251 IGR=1,NGROUP + KPEDIT=LCMGIL(JPEDIT,IGR) + CALL LCMLEN(KPEDIT,'H-FACTOR',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.NMERGE) THEN + CALL LCMGET(KPEDIT,'H-FACTOR',SCATC) + DO 250 IMRG=1,NMERGE + EMJMAC(IMRG)=EMJMAC(IMRG)+REAL(DXSMAC(IGR,JXSR,IMRG))* + > SCATC(IMRG)*1.0E18 + 250 CONTINUE + ENDIF + 251 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(DNUFI) + DEALLOCATE(SCATC) + DEALLOCATE(NJJ,IJJ) + RETURN + END diff --git a/Dragon/src/CPOMAW.f b/Dragon/src/CPOMAW.f new file mode 100644 index 0000000..bc2980e --- /dev/null +++ b/Dragon/src/CPOMAW.f @@ -0,0 +1,205 @@ +*DECK CPOMAW + SUBROUTINE CPOMAW(IPCPO ,IPRINT,NGROUP,NL ,NPROC ,INDPRO, + > ITYPRO,DXSMAC,DSCMAC,DXSREM,DSCREM,DISFC , + > DMJMAC,IFCDIS,DISFAC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Put macroscopic cross section on Compo. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau +* +*Parameters: input +* IPCPO pointer to the Compo. +* IPRINT print parameter. Equal to zero for no print. +* NGROUP number of groups condensed. +* NL number of Legendre orders. +* NPROC number of microscopic xs to process. +* INDPRO identifier for xs processing. +* ITYPRO identifier for xs processed . +* DXSMAC macroscopic averaged region/group x-s. +* DSCMAC macroscopic scattering. +* DXSREM removed averaged region/group x-s. +* DSCREM removed scattering rates. +* DISFC disadvantage factor. +* DMJMAC energy. +* IFCDIS discontinuity factor present (1) or absent. +* DISFAC discontinuity factors. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPCPO + INTEGER IPRINT,NGROUP,NL,NPROC,INDPRO(NPROC), + > ITYPRO(NPROC) + REAL DISFC(NGROUP) + DOUBLE PRECISION DXSMAC(NGROUP,NPROC), + > DSCMAC(NGROUP,NGROUP,NL), + > DXSREM(NGROUP,NPROC), + > DSCREM(NGROUP,NGROUP,NL), + > DMJMAC + INTEGER IFCDIS + DOUBLE PRECISION DISFAC(2,NGROUP,3) +*---- +* LOCAL PARAMETERS +*---- + INTEGER NDPROC + REAL CUTOFF + PARAMETER (NDPROC=20,CUTOFF=1.0E-7) + INTEGER IXSR,JXSR,KXSR,IL,IGR,JGR,IORD + REAL CUTLIM + DOUBLE PRECISION DNUFI,DNUFT +*---- +* ALLOCATABLE ARRAYS +* XSREC micro vector xs +* XSCAT compress scattering data +* DISTMP temporary storage for discontinuity factors +*---- + REAL, ALLOCATABLE, DIMENSION(:,:) :: XSREC,DISTMP + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: XSCAT +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(XSREC(NGROUP,NPROC),XSCAT(NGROUP,NGROUP,NL), + > DISTMP(2,NGROUP)) +*---- +* SAVE AVERAGE XS +*---- + ITYPRO(:NPROC)=1 + CALL LCMSIX(IPCPO,'MACR',1) + XSREC(:NGROUP,:NPROC)=0.0 + XSCAT(:NGROUP,:NGROUP,:NL)=0.0 + DO 100 IXSR=1,4 + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + DO 101 IGR=1,NGROUP + XSREC(IGR,IXSR)=REAL(DXSMAC(IGR,IXSR)-DXSREM(IGR,IXSR)) + CUTLIM=ABS(REAL(DXSMAC(IGR,IXSR))*CUTOFF) + IF(XSREC(IGR,IXSR).LT.CUTLIM) XSREC(IGR,IXSR)=0.0 + 101 CONTINUE + ENDIF + 100 CONTINUE + IXSR=5 + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + JXSR=3 + KXSR=16 + DNUFI=0.0D0 + DNUFT=0.0D0 + DO 120 IGR=1,NGROUP + DNUFT=DNUFT+DXSMAC(IGR,KXSR)*DXSMAC(IGR,JXSR) + DNUFI=DNUFI+(DXSMAC(IGR,KXSR)-DXSREM(IGR,KXSR)) + > *(DXSMAC(IGR,JXSR)-DXSREM(IGR,JXSR)) + 120 CONTINUE + CUTLIM=ABS(REAL(DNUFT)*CUTOFF) + IF(REAL(DNUFI).GT.CUTLIM) THEN + DNUFI=1.0D0/DNUFI + DNUFT=1.0D0/DNUFT + DO 130 IGR=1,NGROUP + XSREC(IGR,IXSR)=REAL(DNUFI*(DXSMAC(IGR,IXSR) + > -DXSREM(IGR,IXSR))) + 130 CONTINUE + ENDIF + ENDIF + IXSR=6 + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + JXSR=4 + KXSR=3 + DO 140 IGR=1,NGROUP + DNUFI=DXSMAC(IGR,JXSR)-DXSREM(IGR,JXSR) + CUTLIM=ABS(REAL(DXSMAC(IGR,JXSR))*CUTOFF) + IF(REAL(DNUFI).GT.CUTLIM) THEN + XSREC(IGR,IXSR)=REAL((DXSMAC(IGR,KXSR) + > -DXSREM(IGR,KXSR))/DNUFI) + ENDIF + 140 CONTINUE + ENDIF + DO 150 IXSR=7,NDPROC + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + DO 160 IGR=1,NGROUP + XSREC(IGR,IXSR)=REAL(DXSMAC(IGR,IXSR)-DXSREM(IGR,IXSR)) + CUTLIM=ABS(REAL(DXSMAC(IGR,IXSR))*CUTOFF) + IF(XSREC(IGR,IXSR).LT.CUTLIM) XSREC(IGR,IXSR)=0.0 + 160 CONTINUE + ENDIF + 150 CONTINUE + IL=0 + DO 170 IXSR=NDPROC+1,NDPROC+NL + IL=IL+1 + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + DO 180 IGR=1,NGROUP + XSREC(IGR,IXSR)=REAL(DXSMAC(IGR,IXSR)-DXSREM(IGR,IXSR)) + CUTLIM=ABS(REAL(DXSMAC(IGR,IXSR))*CUTOFF) + IF(ABS(XSREC(IGR,IXSR)).LT.CUTLIM) + > XSREC(IGR,IXSR)=0.0 + DO 190 JGR=1,NGROUP + XSCAT(IGR,JGR,IL)=REAL(DSCMAC(IGR,JGR,IL) + > -DSCREM(IGR,JGR,IL)) + CUTLIM=ABS(REAL(DSCMAC(IGR,JGR,IL))*CUTOFF) + IF(ABS(XSCAT(IGR,JGR,IL)).LT.CUTLIM) + > XSCAT(IGR,JGR,IL)=0.0 + 190 CONTINUE + 180 CONTINUE + ENDIF + 170 CONTINUE +*---- +* COMPUTE AVERAGED ENERGY PER FISSION +*---- + JXSR=4 + KXSR=16 + DNUFI=0.0D0 + DNUFT=0.0D0 + DO 200 IGR=1,NGROUP + DNUFT=DNUFT+DXSMAC(IGR,KXSR)*DXSMAC(IGR,JXSR) + DNUFI=DNUFI+(DXSMAC(IGR,KXSR)-DXSREM(IGR,KXSR)) + > *(DXSMAC(IGR,JXSR)-DXSREM(IGR,JXSR)) + 200 CONTINUE + CUTLIM=ABS(REAL(DNUFT)*CUTOFF) + IF(REAL(DNUFI).GT.CUTLIM) THEN + DMJMAC=DMJMAC/DNUFI + ELSE + DMJMAC=0.0D0 + ENDIF +*---- +* SAVE CPO MICRO +*---- + IORD=1 + CALL XDRLGS(IPCPO,1,IPRINT,0,NL-1,IORD,NGROUP,XSREC(1,NDPROC+1), + > XSCAT,ITYPRO(NDPROC+1)) + CALL CPOLGX(IPCPO,1,IPRINT,IORD,NGROUP,INDPRO,XSREC(1,1),ITYPRO) + CALL LCMSIX(IPCPO,'MACR',2) + IXSR=NDPROC+NL+1 + DO 210 IGR=1,NGROUP + XSREC(IGR,1)=REAL(DXSMAC(IGR,IXSR)) + 210 CONTINUE + CALL LCMPUT(IPCPO,'OVERV',NGROUP,2,XSREC) + IXSR=16 + DO 220 IGR=1,NGROUP + XSREC(IGR,1)=REAL(DXSMAC(IGR,IXSR)) + 220 CONTINUE + CALL LCMPUT(IPCPO,'FLUX-INTG',NGROUP,2,XSREC) + CALL LCMPUT(IPCPO,'FLUXDISAFACT',NGROUP,2,DISFC) + IF(IFCDIS .EQ. 1) THEN + CALL XDRSDB(2*NGROUP,DISTMP,DISFAC(1,1,1),1) + CALL LCMPUT(IPCPO,'DISFACX',2*NGROUP,2,DISTMP) + CALL XDRSDB(2*NGROUP,DISTMP,DISFAC(1,1,2),1) + CALL LCMPUT(IPCPO,'DISFACY',2*NGROUP,2,DISTMP) + CALL XDRSDB(2*NGROUP,DISTMP,DISFAC(1,1,3),1) + CALL LCMPUT(IPCPO,'DISFACZ',2*NGROUP,2,DISTMP) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(DISTMP,XSCAT,XSREC) + RETURN + END diff --git a/Dragon/src/CPOMIC.f b/Dragon/src/CPOMIC.f new file mode 100644 index 0000000..9bd25b6 --- /dev/null +++ b/Dragon/src/CPOMIC.f @@ -0,0 +1,260 @@ +*DECK CPOMIC + SUBROUTINE CPOMIC(IPCPO ,IPEDIT,IPRINT,NGROUP,NMERGE,NBMICR, + > NL ,IMRG ,ISOR ,NPROC ,ISOTMP,IDIMIX, + > INDPRO,ITYPRO,DENCPO,DENTMP,DXSMIC,DSCMIC, + > DMJCPO,DFLUX ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute microscopic cross sections for the Compo file. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau +* +*Parameters: input +* IPCPO pointer to the compo (L_COMPO signature). +* IPEDIT pointer to edit information (L_EDIT signature). +* IPRINT print parameter. Equal to zero for no print. +* NGROUP number of groups condensed . +* NMERGE number of regions merged. +* NBMICR maximum number of isotopes. +* NL number of Legendre orders. +* IMRG merge region indices. +* ISOR Compo isotope number. +* NPROC number of isotopes. +* ISOTMP name of isotopes in EDIT. +* IDIMIX isotopes identifier in each Compo material. +* INDPRO identifier for xs processing. +* ITYPRO identifier for xs processed. +* DENCPO Compo isotopes concentration. +* DENTMP Dragon isotopes concentration. +* +*Parameters: input/output +* DXSMIC micro vector xs. +* DSCMIC micro scat matrix xs. +* DFLUX flux. +* DMJCPO fission energy for macro. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPCPO,IPEDIT + INTEGER IPRINT,NGROUP,NMERGE,NBMICR,NL,IMRG,ISOR,NPROC, + > ISOTMP(3,NBMICR),IDIMIX(NMERGE,NBMICR), + > INDPRO(NPROC),ITYPRO(NPROC) + REAL DENTMP(NBMICR) + DOUBLE PRECISION DENCPO(NBMICR),DXSMIC(NGROUP,NPROC), + > DSCMIC(NGROUP,NGROUP,NL),DMJCPO(2,NBMICR), + > DFLUX(NGROUP) +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: HFACT + REAL, ALLOCATABLE, DIMENSION(:,:) :: XSREC + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: XSCAT + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO +*---- +* LOCAL PARAMETERS +*---- + INTEGER IOUT,NDPROC,IORD + PARAMETER (IOUT=6,NDPROC=20) + TYPE(C_PTR) KPEDIT + INTEGER NBISOE,ISOE,IADDXS,ITC,IXSR,JXSR,KXSR,IL, + > IGR,JGR,ILCMLN,ITYLCM + CHARACTER NAMISO*12 + DOUBLE PRECISION DSCPO,DNUFI,FACDEN,FACAXS +*---- +* SCRATCH STORAGE ALLOCATION +* XSREC fission energy for macro. +* XSCAT compress scattering. +*---- + ALLOCATE(XSREC(NGROUP,NPROC),XSCAT(NGROUP,NGROUP,NL), + > IPISO(NBMICR)) +*---- +* FIND ISOTOPE POINTERS IN INPUT MICROLIB +*---- + CALL LIBIPS(IPEDIT,NBMICR,IPISO) +*---- +* COMPUTE FINAL DENSITY OF ISOTOPE ISOR IN MIXTURE IMRG +*---- + NBISOE=0 + DO 100 ISOE=1,NBMICR + IF(IDIMIX(IMRG,ISOE).EQ.ISOR) THEN + NBISOE=NBISOE+1 + DENCPO(ISOR)=DENCPO(ISOR)+DENTMP(ISOE) + ENDIF + 100 CONTINUE + IF(DENCPO(ISOR).EQ.0.0D0) THEN + FACDEN=1.0D0/DBLE(NBISOE) + IADDXS=0 + ELSE + FACDEN=1.0D0/DENCPO(ISOR) + IADDXS=1 + ENDIF +*---- +* SCAN ALL ISOTOPES FOR THIS MERGE REGION AND +* LOCATE ADD XS FOR THOSE ASSOCIATED WITH ISOR +*---- + DSCPO=0.0D0 + DO 110 ISOE=1,NBMICR + IF(IDIMIX(IMRG,ISOE).EQ.ISOR) THEN + IF(IADDXS.EQ.0) THEN + FACAXS=FACDEN + ELSE + FACAXS=FACDEN*DBLE(DENTMP(ISOE)) + ENDIF +*---- +* READ MICRO XS +*---- + WRITE(NAMISO,'(3A4)') (ISOTMP(ITC,ISOE),ITC=1,3) + IF(IPRINT.GE.10) WRITE(IOUT,6000) NAMISO + KPEDIT=IPISO(ISOE) ! set ISOE-th isotope + IORD=1 + CALL XDRLGS(KPEDIT,-1,IPRINT,0,NL-1,IORD,NGROUP, + > XSREC(1,NDPROC+1),XSCAT,ITYPRO(NDPROC+1)) + CALL CPOLGX(KPEDIT,-1,IPRINT,IORD,NGROUP,INDPRO,XSREC(1,1), + > ITYPRO) +*---- +* ADD MICRO XS TO CPO ISOTOPE +*---- + DO 120 IXSR=1,4 + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + DO 121 IGR=1,NGROUP + DXSMIC(IGR,IXSR)=DXSMIC(IGR,IXSR) + > +FACAXS*DBLE(XSREC(IGR,IXSR)) + 121 CONTINUE + ENDIF + 120 CONTINUE + IXSR=4 + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN +*---- +* COMPUTE TOTAL NEUTRON PRODUCED AND TOTAL ENERGY GENERATED +*---- + CALL LCMLEN(KPEDIT,'H-FACTOR',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.NGROUP) THEN + ALLOCATE(HFACT(NGROUP)) + CALL LCMGET(KPEDIT,'H-FACTOR',HFACT) + DO 122 IGR=1,NGROUP + DMJCPO(1,ISOR)=DMJCPO(1,ISOR)+DENTMP(ISOE) + > *DFLUX(IGR)*DBLE(HFACT(IGR))*1.0E18 + DMJCPO(2,ISOR)=DMJCPO(2,ISOR)+DENTMP(ISOE) + > *DFLUX(IGR)*DBLE(XSREC(IGR,IXSR)) + 122 CONTINUE + DEALLOCATE(HFACT) + ENDIF + ENDIF + IXSR=5 + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + JXSR=3 + DNUFI=0.0D0 + DO 130 IGR=1,NGROUP + DNUFI=DNUFI+DFLUX(IGR)*DBLE(XSREC(IGR,JXSR)) + 130 CONTINUE + DNUFI=DNUFI*FACAXS + DSCPO=DSCPO+DNUFI + DO 140 IGR=1,NGROUP + DXSMIC(IGR,IXSR)=DXSMIC(IGR,IXSR) + > +DNUFI*DBLE(XSREC(IGR,IXSR)) + 140 CONTINUE + ENDIF + DO 150 IXSR=7,NDPROC + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + DO 151 IGR=1,NGROUP + DXSMIC(IGR,IXSR)=DXSMIC(IGR,IXSR) + > +FACAXS*DBLE(XSREC(IGR,IXSR)) + 151 CONTINUE + ENDIF + 150 CONTINUE + IL=0 + DO 160 IXSR=NDPROC+1,NDPROC+NL + IL=IL+1 + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + DO 170 IGR=1,NGROUP + DXSMIC(IGR,IXSR)=DXSMIC(IGR,IXSR) + > +FACAXS*DBLE(XSREC(IGR,IXSR)) + DO 171 JGR=1,NGROUP + DSCMIC(IGR,JGR,IL)=DSCMIC(IGR,JGR,IL) + > +FACAXS*DBLE(XSCAT(IGR,JGR,IL)) + 171 CONTINUE + 170 CONTINUE + ENDIF + 160 CONTINUE + ENDIF + 110 CONTINUE +*---- +* SAVE AVERAGE XS +*---- + XSREC(:NGROUP,:NPROC)=0.0 + XSCAT(:NGROUP,:NGROUP,:NL)=0.0 + DO 180 IXSR=1,4 + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + DO 181 IGR=1,NGROUP + XSREC(IGR,IXSR)=REAL(DXSMIC(IGR,IXSR)) + 181 CONTINUE + ENDIF + 180 CONTINUE + IXSR=5 + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + IF(DSCPO.NE.0.0D0) THEN + DO 190 IGR=1,NGROUP + XSREC(IGR,IXSR)=REAL(DXSMIC(IGR,IXSR)/DSCPO) + 190 CONTINUE + ENDIF + ENDIF + IXSR=6 + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + JXSR=4 + KXSR=3 + DO 191 IGR=1,NGROUP + IF(DXSMIC(IGR,JXSR).GT.0.0) THEN + XSREC(IGR,IXSR)=REAL(DXSMIC(IGR,KXSR)/DXSMIC(IGR,JXSR)) + ENDIF + 191 CONTINUE + ENDIF + DO 200 IXSR=7,NDPROC + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + DO 201 IGR=1,NGROUP + XSREC(IGR,IXSR)=REAL(DXSMIC(IGR,IXSR)) + 201 CONTINUE + ENDIF + 200 CONTINUE + IL=0 + DO 210 IXSR=NDPROC+1,NDPROC+NL + IL=IL+1 + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + DO 220 IGR=1,NGROUP + XSREC(IGR,IXSR)=REAL(DXSMIC(IGR,IXSR)) + DO 221 JGR=1,NGROUP + XSCAT(IGR,JGR,IL)=REAL(DSCMIC(IGR,JGR,IL)) + 221 CONTINUE + 220 CONTINUE + ENDIF + 210 CONTINUE +*---- +* SAVE CPO MICRO +*---- + IORD=1 + CALL XDRLGS(IPCPO,1,IPRINT,0,NL-1,IORD,NGROUP,XSREC(1,NDPROC+1), + > XSCAT,ITYPRO(NDPROC+1)) + CALL CPOLGX(IPCPO,1,IPRINT,IORD,NGROUP,INDPRO,XSREC(1,1),ITYPRO) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IPISO,XSCAT,XSREC) + RETURN +*---- +* PRINT FORMAT +*---- + 6000 FORMAT(' CPOMIC: INCLUDE ISOTOPE = ',A12) + END diff --git a/Dragon/src/CPONED.f b/Dragon/src/CPONED.f new file mode 100644 index 0000000..e1b2db3 --- /dev/null +++ b/Dragon/src/CPONED.f @@ -0,0 +1,113 @@ +*DECK CPONED + SUBROUTINE CPONED(NPROC ,MINLEG,MAXLEG,ILEAKS ,NED ,HVECT , + > IVECT ,INDPRO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Set up INDPRO for cross section to read on IPLIB. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau +* +*Parameters: input +* NPROC number of terms to process. +* MINLEG mimimum Legendre order to process for scattering. +* MAXLEG maximum Legendre order to process for scattering. +* ILEAKS leakage calculation: = 1 STRD; = 2 STRDX, STRDY and STRDZ. +* NED number of extra vector edits. +* HVECT names of the extra vector edits. +* +*Parameters: output +* IVECT pointer to additional xs possible. +* INDPRO vector for cross section to process: +* = 0 do not process; +* > 0 process. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NPROC ,MINLEG,MAXLEG,ILEAKS,NED,IVECT(NED), + > INDPRO(NPROC) + CHARACTER HVECT(NED)*8 +*---- +* LOCAL PARAMETERS +* NDPROC = NUMBER OF DEFAULT CROSS SECTIONS = 20 +* NAMDXS = NAME OF NDPROC DEFAULT XS +* SCATTERING CROSS SECTIONS START AT NDPROC+1 WITH +* NAME NAMSCT='SIGS'//NAMLEG AND NAMSCT='SCAT'//NAMLEG +* WITH NAMLEG DEFINED BY +* WRITE(NAMLEG ,'(I2.2)') ILEG +* FOR ILEG=0 TO NDPROC-NPROC-1 +*---- + INTEGER NDPROC,IOUT,NEDOTH,IED,IXSR + PARAMETER (NDPROC=20,IOUT=6) + CHARACTER NAMDXS(NDPROC)*6 + SAVE NAMDXS + DATA NAMDXS /'NTOT0 ','TRANC ','NUSIGF','NFTOT ','CHI ', + > 'NU ','NG ','NHEAT ','N2N ','N3N ', + > 'N4N ','NP ','NA ','GOLD ','ABS ', + > 'NWT0 ','STRD ','STRD X','STRD Y','STRD Z'/ +*---- +* SCAN FOR ADDITIONAL AND STANDARD CROSS SECTIONS TO BE SAVED +*---- + IVECT(:NED)=0 + INDPRO(:NPROC)=0 + NEDOTH=NED + DO 100 IED=1,NED + IF(HVECT(IED).EQ.' ') THEN + NEDOTH=NEDOTH-1 + ELSE + DO 110 IXSR=1,NDPROC + IF(HVECT(IED)(:6).EQ.NAMDXS(IXSR)) THEN + NEDOTH=NEDOTH-1 + INDPRO(IXSR)=1 + IF(HVECT(IED).EQ.'NFTOT') GO TO 115 + IVECT(IED)=IXSR + GO TO 115 + ENDIF + 110 CONTINUE + 115 CONTINUE + ENDIF + 100 CONTINUE + IF(NEDOTH.GE.1) THEN + WRITE(IOUT,9000) + DO 120 IED=1,NED + IF(IVECT(IED).EQ.0.AND. + > HVECT(IED).NE.'NFTOT'.AND.HVECT(IED).NE.' ') THEN + WRITE(IOUT,9001) HVECT(IED) + ENDIF + 120 CONTINUE + WRITE(IOUT,9002) + ENDIF + DO 130 IXSR=1,7 + INDPRO(IXSR)=1 + 130 CONTINUE + INDPRO(16)=1 + IF(ILEAKS.EQ.1) THEN + INDPRO(17)=1 + ELSE IF(ILEAKS.EQ.2) THEN + INDPRO(18)=1 + INDPRO(19)=1 + INDPRO(20)=1 + ENDIF + DO 140 IXSR=NDPROC+MINLEG+1,NDPROC+MAXLEG+1 + INDPRO(IXSR)=1 + 140 CONTINUE + RETURN +*---- +* FORMAT +*---- + 9000 FORMAT(' CPONED: ************ WARNING ************') + 9001 FORMAT(' CROSS-SECTION TYPE NOT RECOVERED : ',A8) + 9002 FORMAT(' *****************************************') + END diff --git a/Dragon/src/CPOREM.f b/Dragon/src/CPOREM.f new file mode 100644 index 0000000..d5d93d6 --- /dev/null +++ b/Dragon/src/CPOREM.f @@ -0,0 +1,79 @@ +*DECK CPOREM + SUBROUTINE CPOREM(NGROUP,NL ,NPROC ,INDPRO,DENCPO, + > DXSMIC,DSCMIC,DXSREM,DSCREM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Remove Compo isotope xs from macroscopic xs. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau +* +*Parameters: input +* NGROUP number of groups condensed. +* NL number of Legendre orders. +* NPROC number of microscopic xs to process. +* INDPRO identifier for xs processing. +* DENCPO Compo isotopes concentration. +* DXSMIC microscopic vector xs. +* DSCMIC microscopic scat matrix xs. +* +*Parameters: input/output +* DXSREM averaged region/group x-s. +* DSCREM scattering rates. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NGROUP,NL,NPROC,INDPRO(NPROC) + DOUBLE PRECISION DENCPO, + > DXSMIC(NGROUP,NPROC), + > DSCMIC(NGROUP,NGROUP,NL), + > DXSREM(NGROUP,NPROC), + > DSCREM(NGROUP,NGROUP,NL) +*---- +* LOCAL PARAMETERS +*---- + INTEGER NDPROC + PARAMETER (NDPROC=20) + INTEGER IGR,JGR,IXSR,IL +*---- +* REMOVE STANDARD XS +*---- + DO 100 IXSR=1,NDPROC + IF(IXSR.NE.16.AND.INDPRO(IXSR).GT.0) THEN + DO 110 IGR=1,NGROUP + DXSREM(IGR,IXSR)=DXSREM(IGR,IXSR) + > +DENCPO*DXSMIC(IGR,IXSR) + 110 CONTINUE + ENDIF + 100 CONTINUE +*---- +* REMOVE SCATTERING XS +*---- + IL=0 + DO 120 IXSR=NDPROC+1,NDPROC+NL + IL=IL+1 + IF(INDPRO(IXSR).GT.0) THEN + DO 130 IGR=1,NGROUP + DXSREM(IGR,IXSR)=DXSREM(IGR,IXSR) + > +DENCPO*DXSMIC(IGR,IXSR) + DO 131 JGR=1,NGROUP + DSCREM(IGR,JGR,IL)=DSCREM(IGR,JGR,IL) + > +DENCPO*DSCMIC(IGR,JGR,IL) + 131 CONTINUE + 130 CONTINUE + ENDIF + 120 CONTINUE + RETURN + END diff --git a/Dragon/src/DEPLIT.f b/Dragon/src/DEPLIT.f new file mode 100644 index 0000000..5cd4642 --- /dev/null +++ b/Dragon/src/DEPLIT.f @@ -0,0 +1,437 @@ +*DECK DEPLIT + SUBROUTINE DEPLIT (IHEX,NH,NTH,ITAB) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the index table relation subgeometries +* to a complete geometry. +* +*Copyright: +* Copyright (C) 1991 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Benaboud +* +*Parameters: input +* IHEX type of symetry: +* =1 : s30 =2 : sa60 =3 : sb60 =4 : s90 =5 : r120 +* =6 : r180 =7 : sa180 =8 : sb180 =9 : complete. +* NH total number of hexagons in each subgeometry. +* +*Parameters: output +* NTH total number of hexagons in unfolded geometry. +* ITAB Association table for subgeometry in unfolded geometry. +* +*----------------------------------------------------------------------- +* + LOGICAL LPAIR + INTEGER NP(7),ITAB(*) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: J1,J2,J3,K1,K2,K3,K4 +* + NC=0 + IF (IHEX.EQ.1) THEN + VI = 2.* SQRT(REAL(NH)) - 1. + VP = SQRT(REAL(4*NH+1)) - 1. + IF (AINT(VI).EQ.VI) THEN + NC = INT(VI) + ELSE IF (AINT(VP).EQ.VP) THEN + NC = INT(VP) + ELSE + CALL XABORT('DEPLIT: INVALID NUMBER OF HEXAGONS (1).') + ENDIF + ELSE IF (IHEX.EQ.2) THEN + VA = (SQRT(REAL(8*NH+1)) - 1.)/2. + IF (AINT(VA).EQ.VA) THEN + NC = INT(VA) + ELSE + CALL XABORT('DEPLIT: INVALID NUMBER OF HEXAGONS (2).') + ENDIF + ELSE IF (IHEX.EQ.3) THEN + VI = SQRT(REAL(2*NH-1)) + VP = SQRT(REAL(2*NH)) + IF (AINT(VI).EQ.VI) THEN + NC = INT(VI) + ELSE IF (AINT(VP).EQ.VP) THEN + NC = INT(VP) + ELSE + CALL XABORT('DEPLIT: INVALID NUMBER OF HEXAGONS (3).') + ENDIF + ELSE IF (IHEX.EQ.4) THEN + VI = SQRT(REAL((4*NH-1)/3)) + VP = SQRT(REAL(4*NH/3)) + IF (AINT(VI).EQ.VI) THEN + NC = INT(VI) + ELSE IF (AINT(VP).EQ.VP) THEN + NC = INT(VP) + ELSE + CALL XABORT('DEPLIT: INVALID NUMBER OF HEXAGONS (4).') + ENDIF + ELSE IF (IHEX.EQ.5) THEN + VA = (SQRT(REAL(4*(NH-1)+1)) + 1.)/2. + IF (AINT(VA).EQ.VA) THEN + NC = INT(VA) + ELSE + CALL XABORT('DEPLIT: INVALID NUMBER OF HEXAGONS (5).') + ENDIF + ELSE IF (IHEX.EQ.6) THEN + VA = (SQRT(REAL(8*(NH-1)/3+1)) + 1)/2 + IF (AINT(VA).EQ.VA) THEN + NC = INT(VA) + ELSE + CALL XABORT('DEPLIT: INVALID NUMBER OF HEXAGONS (6).') + ENDIF + ELSE IF (IHEX.EQ.7) THEN + VA = (SQRT(REAL(24*NH+1)) + 1.)/6. + IF (AINT(VA).EQ.VA) THEN + NC = INT(VA) + ELSE + CALL XABORT('DEPLIT: INVALID NUMBER OF HEXAGONS (7).') + ENDIF + ELSE IF (IHEX.EQ.8) THEN + VI = (1.+SQRT(REAL(3*(2*NH-1)+1)))/3. + VP = (1.+SQRT(REAL(6*NH+1)))/3. + IF (AINT(VI).EQ.VI) THEN + NC = INT(VI) + ELSE IF (AINT(VP).EQ.VP) THEN + NC = INT(VP) + ELSE + CALL XABORT('DEPLIT: INVALID NUMBER OF HEXAGONS (8).') + ENDIF + ELSE IF (IHEX.EQ.9) THEN + VA = (SQRT(REAL((4*NH-1)/3)) + 1.)/2. + IF (AINT(VA).EQ.VA) THEN + NC = INT(VA) + ELSE + CALL XABORT('DEPLIT: INVALID NUMBER OF HEXAGONS (9).') + ENDIF + ELSE + CALL XABORT('DEPLIT: INVALID TYPE OF SYMMETRY.') + ENDIF + NTH = 1 + 3 * NC * (NC - 1) + ITAB(1) = 1 + ALLOCATE(J1(NC+2),J2(NC+2),J3(NC+2),K1(NC+2),K2(NC+2),K3(NC+2), + > K4(NC+2)) + J1(1) = 1 + J2(1) = 1 + J3(1) = 1 + K1(1) = 1 + K2(1) = 1 + K3(1) = 1 + DO 10 L = 2,NC+1 + J1(L) = (L-1)*6 + J3(L) = 1+3*L*(L-1) + J2(L) = 1+J3(L-1) + 10 CONTINUE +* + IF (IHEX.EQ.1) THEN + IL=0 + DO 20 L = 1,NC+1,2 + K1(L) = 1 + IL + K1(L+1) = 1 + IL + IL = IL+1 + 20 CONTINUE + DO 30 L = 2,NC+1 + K2(L) = K2(L-1) + K1(L-1) + 30 CONTINUE + IL=0 + DO 40 L = 1,NC+1,2 + K3(L) = K2(L) + IL + K3(L+1) = K2(L+1) + IL + IL = IL+1 + 40 CONTINUE + ELSE IF (IHEX.EQ.2) THEN + K1(2) = 2 + DO 50 L = 2,NC+1 + K2(L) = K2(L-1) + L + K1(L+1) = K1(L) + L + 50 CONTINUE + ELSE IF (IHEX.EQ.3) THEN + K1(2) = 2 + DO 60 L = 1,NC+1 + K1(L+1) = K1(L) + L + 60 CONTINUE + IL=0 + DO 70 L = 1,NC+1,2 + K4(L) = 1 + IL + K4(L+1) = 1 + IL + IL = IL + 2 + 70 CONTINUE + DO 80 L = 2,NC+1 + K2(L) = K2(L-1) + K4(L-1) + K3(L) = K3(L-1) + K4(L) + 80 CONTINUE + ELSE IF (IHEX.EQ.4) THEN + IL=0 + DO 90 L = 1,NC+1,2 + K4(L) = L + IL + K4(L+1) = L + IL + 1 + IL = IL + 1 + 90 CONTINUE + DO 100 L = 2,NC+1 + K1(L) = K1(L-1) + K4(L-1) + K3(L) = K3(L-1) + K4(L) +100 CONTINUE + IL=0 + DO 110 L = 1,NC+1,2 + K2(L) = K1(L) + IL + K2(L+1) = K1(L+1) + IL + IL = IL+1 +110 CONTINUE + ELSE IF (IHEX.EQ.5) THEN + DO 120 L = 2,NC+1 + K2(L) = 2 * (L-1) + K1(L) = K1(L-1) + K2(L) +120 CONTINUE + ELSE IF (IHEX.EQ.6) THEN + DO 130 L = 2,NC+1 + K2(L) = 3 * (L-1) + K1(L) = K1(L-1) + K2(L) +130 CONTINUE + ELSE IF (IHEX.EQ.7) THEN + DO 140 L = 2,NC+1 + K2(L) = 3 + K2(L-1) + K1(L) = K1(L-1) + K2(L) +140 CONTINUE + ELSE IF (IHEX.EQ.8) THEN + IL = 1 + IF = 1 + DO 150 L = 2,NC+1,2 + K2(L) = 3 * (L-1) + K2(L+1) = 3 * L + 1 +150 CONTINUE + DO 160 L = 2,NC+1 + IL = IL + K2(L) + IF = IF + K2(L-1) + K1(L) = (IF + IL) / 2 +160 CONTINUE + ENDIF +* + DO 300 N = 2,NTH +* + I=0 + J=0 + DO 170 I0 = 2,NC + IF ((N.GE.J2(I0)).AND.(N.LE.J3(I0))) THEN + I=I0 + GO TO 180 + ENDIF +170 CONTINUE + IF (I.EQ.0) CALL XABORT('DEPLIT: ALGORITHM FAILURE.') +* +180 DO 190 K = 1,6 + NP(K) = J2(I) + (K - 1) * (I - 1) +190 CONTINUE + NP(7) = J3(I) + COURS2 = REAL(I)/2. + LPAIR = (AINT(COURS2).EQ.COURS2) +* + IF (IHEX.EQ.1) THEN +* + IF (N.LE.7) THEN + ITAB(N) = 2 + GO TO 300 + ENDIF + DO 200 L = 1,6 + IF ((N.GE.NP(L)).AND.(N.LT.NP(L+1))) J = L +200 CONTINUE + IF (N.EQ.NP(7)) J = 6 + IF (J.EQ.0) CALL XABORT('DEPLIT: ALGORITHM FAILURE.') + IC = 0 + IF (J.EQ.6) IC = 1 + N12 = (NP(J) + NP(J+1)+IC)/2 + N13 = N12 + 1 +* + IF (N.EQ.NP(J)) THEN + ITAB(N) = K3(I) + ELSE IF (N.EQ.NP(7)) THEN + ITAB(N) = K3(I) - 1 + ELSE IF ((N.GT.NP(J)).AND.(N.LT.N12)) THEN + ITAB(N) = K3(I) - (N - NP(J)) + ELSE IF ((N.EQ.N12).OR.((N.EQ.N13).AND.LPAIR)) THEN + ITAB(N) = K2(I) + ELSE IF ((N.EQ.N13).AND.(.NOT.LPAIR)) THEN + ITAB(N) = K3(I) - (NP(J+1) + IC - N) + ELSE IF ((N.GT.N13).AND.(N.LT.NP(J+1))) THEN + ITAB(N) = K3(I) - (NP(J+1) + IC - N) + ENDIF +* + ELSE IF (IHEX.EQ.2) THEN +* + DO 210 L = 1,6,2 + IF ((N.GE.NP(L)).AND.(N.LT.NP(L+2))) J = L +210 CONTINUE + IF (N.EQ.NP(7)) J = 5 + IF (J.EQ.0) CALL XABORT('DEPLIT: ALGORITHM FAILURE.') +* + IF (N.EQ.NP(J)) THEN + ITAB(N) = K2(I) + ELSE IF (N.EQ.NP(7)) THEN + ITAB(N) = K2(I) - 1 + ELSE IF ((N.GT.NP(J)).AND.(N.LT.NP(J+1))) THEN + ITAB(N) = K2(I) - (N - NP(J)) + ELSE IF (N.EQ.NP(J+1)) THEN + ITAB(N) = K1(I) + ELSE IF ((N.GT.NP(J+1)).AND.(N.LT.NP(J+2))) THEN + ITAB(N) = K1(I) + (N - NP(J+1)) + ENDIF +* + ELSE IF (IHEX.EQ.3) THEN +* + IF (N.LE.7) THEN + ITAB(N) = 2 + GO TO 300 + ENDIF + DO 220 L = 1,6,2 + IF ((N.GE.NP(L)).AND.(N.LT.NP(L+2))) J = L +220 CONTINUE + IF (N.EQ.NP(7)) J = 5 + IF (J.EQ.0) CALL XABORT('DEPLIT: ALGORITHM FAILURE.') + IC = 0 + IF (J.EQ.5) IC = 1 + N12 = (NP(J) + NP(J+1))/2 + N13 = N12 + 1 + N14 = (NP(J+1) + NP(J+2)+IC)/2 + N15 = N14 + 1 +* + IF ((N.EQ.NP(J)).OR.(N.EQ.NP(J+1))) THEN + ITAB(N) = K1(I) + ELSE IF (N.EQ.NP(7)) THEN + ITAB(N) = K1(I) - 1 + ELSE IF ((N.GT.NP(J)).AND.(N.LT.N12)) THEN + ITAB(N) = K1(I) + (N - NP(J)) + ELSE IF ((N.EQ.N12).OR.((N.EQ.N13).AND.LPAIR)) THEN + ITAB(N) = K3(I) + ELSE IF ((N.EQ.N13).AND.(.NOT.LPAIR)) THEN + ITAB(N) = K3(I) - 1 + ELSE IF ((N.GT.N13).AND.(N.LT.NP(J+1))) THEN + ITAB(N) = K1(I) + (NP(J+1) - N) + ELSE IF ((N.GT.NP(J+1)).AND.(N.LT.N14)) THEN + ITAB(N) = K1(I) - (N - NP(J+1)) + ELSE IF ((N.EQ.N14).OR.((N.EQ.N15).AND.LPAIR)) THEN + ITAB(N) = K2(I) + ELSE IF ((N.EQ.N15).AND.(.NOT.LPAIR)) THEN + ITAB(N) = K2(I) + 1 + ELSE IF ((N.GT.N15).AND.(N.LT.NP(J+2))) THEN + ITAB(N) = K1(I) - (NP(J+2) + IC - N) + ENDIF +* + ELSE IF (IHEX.EQ.4) THEN +* + IF (N.EQ.7) THEN + ITAB(N) = 2 + GO TO 300 + ENDIF + DO 230 L = 1,6,3 + IF ((N.GE.NP(L)).AND.(N.LT.NP(L+3))) J = L +230 CONTINUE + IF (N.EQ.NP(7)) J = 4 + IF (J.EQ.0) CALL XABORT('DEPLIT: ALGORITHM FAILURE.') + IC = 0 + IF (J.EQ.4) IC = 1 + N12 = (NP(J+2) + NP(J+3)+IC)/2 + N13 = N12 + 1 +* + IF ((N.EQ.NP(J)).OR.(N.EQ.NP(J+2))) THEN + ITAB(N) = K2(I) + ELSE IF (N.EQ.NP(7)) THEN + ITAB(N) = K2(I) - 1 + ELSE IF ((N.GT.NP(J)).AND.(N.LT.NP(J+1))) THEN + ITAB(N) = K2(I) + (N - NP(J)) + ELSE IF (N.EQ.NP(J+1)) THEN + ITAB(N) = K3(I) + ELSE IF ((N.GT.NP(J+1)).AND.(N.LE.N12).AND.(N.NE.NP(J+2))) THEN + ITAB(N) = K2(I) - (N - NP(J+2)) + ELSE IF ((N.EQ.N13).AND.(.NOT.LPAIR)) THEN + ITAB(N) = K2(I) - (NP(J+3) + IC - N) + ELSE IF ((N.EQ.N13).AND.LPAIR) THEN + ITAB(N) = K1(I) + ELSE IF ((N.GT.N13).AND.(N.LT.NP(J+3))) THEN + ITAB(N) = K2(I) - (NP(J+3) + IC - N) + ENDIF +* + ELSE IF (IHEX.EQ.5) THEN +* + IF (N.EQ.7) THEN + ITAB(N) = 3 + GO TO 300 + ELSE IF ((N.EQ.11).OR.(N.EQ.15).OR.(N.EQ.19)) THEN + ITAB(N) = 4 + GO TO 300 + ENDIF + DO 240 L = 1,6,2 + IF ((N.GE.NP(L)).AND.(N.LT.NP(L+2))) J = L +240 CONTINUE + IF (N.EQ.NP(7)) J = 5 + IF (J.EQ.0) CALL XABORT('DEPLIT: ALGORITHM FAILURE.') + IC = 0 + IF (J.EQ.5) IC = 1 +* + IF ((N.GE.NP(J)).AND.(N.LE.NP(J+1))) THEN + ITAB(N) = K1(I) - (NP(J+1) - N) + ELSE IF ((N.GT.NP(J+1)).AND.(N.LE.NP(J+2)+IC)) THEN + ITAB(N) = K1(I) -(2*(NP(J+2)+IC)-NP(J+1)- N) + ENDIF +* + ELSE IF (IHEX.EQ.6) THEN +* + DO 250 L = 1,6,3 + IF ((N.GE.NP(L)).AND.(N.LT.NP(L+3))) J = L +250 CONTINUE + IF (N.EQ.NP(7)) J = 4 + IF (J.EQ.0) CALL XABORT('DEPLIT: ALGORITHM FAILURE.') + IC = 0 + IF (J.EQ.4) IC = 1 +* + IF ((N.GE.NP(J)).AND.(N.LE.NP(J+1))) THEN + ITAB(N) = K1(I) - (NP(J+1) - N) + ELSE IF ((N.GT.NP(J+1)).AND.(N.LE.NP(J+2))) THEN + ITAB(N) = K1(I) - 2*(NP(J+2)-NP(J+1))-(NP(J+2)-N) + ELSE IF ((N.GT.NP(J+2)).AND.(N.LE.NP(J+3)+IC)) THEN + ITAB(N) = K1(I)-(2*(NP(J+3)+IC)-NP(J+2)-N) + ENDIF +* + ELSE IF (IHEX.EQ.7) THEN +* + IF ((N.GE.NP(1)).AND.(N.LE.NP(2))) THEN + ITAB(N) = K1(I) - (NP(2) - N) + ELSE IF ((N.GT.NP(2)).AND.(N.LE.NP(3))) THEN + ITAB(N) = K1(I) - (NP(3) - NP(2)) + (NP(3) - N) + ELSE IF ((N.GT.NP(3)).AND.(N.LE.NP(4))) THEN + ITAB(N) = K1(I) - (NP(4) - NP(2)) + (NP(4) - N) + ELSE IF ((N.GT.NP(4)).AND.(N.LE.NP(5))) THEN + ITAB(N) = K1(I) - (NP(5) - NP(2)) + (NP(5) - N) + ELSE IF ((N.GT.NP(5)).AND.(N.LE.NP(6))) THEN + ITAB(N) = K1(I) - (NP(4) - NP(2)) - (NP(6) - N) + ELSE IF ((N.GT.NP(6)).AND.(N.LE.NP(7)+1)) THEN + ITAB(N) = K1(I) - (NP(3) - NP(2)) - (NP(7) + 1 - N) + ENDIF +* + ELSE IF (IHEX.EQ.8) THEN +* + N12 = (NP(3) + NP(4)) / 2 + N13 = (NP(6) + NP(7) + 1) / 2 +* + IF ((N.GE.NP(1)).AND.(N.LE.N12)) THEN + ITAB(N) = K1(I) - (NP(2) - N) + ELSE IF ((N.GT.N12).AND.(N.LE.N13)) THEN + ITAB(N) = K1(I) + (NP(5) - N) + ELSE IF ((N.GT.N13).AND.(N.LE.NP(7)+1)) THEN + ITAB(N) = K1(I) - (NP(6) - NP(5)) - (NP(7) + 1 - N) + ENDIF +* + ELSE IF (IHEX.EQ.9) THEN +* + ITAB(N) = N +* + ENDIF +300 CONTINUE + DEALLOCATE(K4,K3,K2,K1,J3,J2,J1) + RETURN + END diff --git a/Dragon/src/DMA.f b/Dragon/src/DMA.f new file mode 100644 index 0000000..2212b24 --- /dev/null +++ b/Dragon/src/DMA.f @@ -0,0 +1,169 @@ +*DECK DMA + SUBROUTINE DMA(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Set the source of an adjoint fixed source eigenvalue problem. The +* source is the gradient of a macrolib. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): creation type(L_SOURCE); +* HENTRY(2): read-only type(L_FLUX); +* HENTRY(3): read-only type(L_MACROLIB); +* HENTRY(4): read-only type(L_TRACKING). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + TYPE(C_PTR) IPDMA,IPFLX,IPMAC,IPTRK + CHARACTER HSIGN*12,TEXT12*12 + INTEGER ISTATE(NSTATE) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NAMEAD,NMIX,NDGRP,IMERGE, + 1 IGCR,MAT,KEY + REAL, ALLOCATABLE, DIMENSION(:) :: VOL +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.NE.4) CALL XABORT('DMA: FOUR PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('DMA: LI' + 1 //'NKED LIST OR XSM FILE EXPECTED AT LHS.') + IF(JENTRY(1).NE.0) CALL XABORT('DMA: ENTRY IN CREATE MODE EXPE' + 1 //'CTED.') + DO I=2,4 + IF((JENTRY(I).NE.2).OR.((IENTRY(I).NE.1).AND.(IENTRY(I).NE.2))) + 1 CALL XABORT('DMA: LINKED LIST OR XSM FILE IN READ-ONLY MODE E' + 2 //'XPECTED AT RHS.') + ENDDO + IPDMA=KENTRY(1) + CALL LCMGTC(KENTRY(2),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_FLUX') THEN + TEXT12=HENTRY(2) + CALL XABORT('DMA: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_FLUX EXPECTED.') + ENDIF + IPFLX=KENTRY(2) + CALL LCMGTC(KENTRY(3),'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_MACROLIB') THEN + IPMAC=KENTRY(3) + ELSE IF(HSIGN.EQ.'L_LIBRARY') THEN + IPMAC=LCMGID(KENTRY(3),'MACROLIB') + ELSE + TEXT12=HENTRY(3) + CALL XABORT('DMA: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_MACROLIB OR L_LIBRARY EXPECTED.') + ENDIF + CALL LCMGTC(KENTRY(4),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_TRACK') THEN + TEXT12=HENTRY(4) + CALL XABORT('DMA: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_TRACK EXPECTED.') + ENDIF + IPTRK=KENTRY(4) +*---- +* RECOVER STATE VECTOR INFORMATION +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + NREG=ISTATE(1) + NBMIX=ISTATE(4) + CALL LCMGET(IPFLX,'STATE-VECTOR',ISTATE) + NG=ISTATE(1) + NUN=ISTATE(2) + CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE) + IF(ISTATE(1).NE.NG) CALL XABORT('DMA: INVALID NUMBER OF GROUPS.') + NMIL=ISTATE(2) + NL=ISTATE(3) + NFM=ISTATE(4) + NED=ISTATE(5) + NDEL=ISTATE(7) + ALLOCATE(NAMEAD(2*NED)) + IF(NED.GT.0) CALL LCMGET(IPMAC,'ADDXSNAME-P0',NAMEAD) +*---- +* READ INPUT PARAMETERS +*---- + ALLOCATE(NMIX(NREG)) + CALL LCMGET(IPTRK,'MATCOD',NMIX) + CALL DMAGET(IPDMA,NG,NREG,NBMIX,NMIX,IPRINT,NMERGE,NGCOND) + DEALLOCATE(NMIX) + NCST=(5+NGCOND*NL+2*NFM*(1+NDEL)+NED)*NMERGE*NGCOND +*---- +* COMPUTE THE GPT SOURCE +*---- + ALLOCATE(NDGRP(NG)) + NDGRP(:NG)=0 + ALLOCATE(IMERGE(NREG),IGCR(NG),MAT(NREG),KEY(NREG),VOL(NREG)) + CALL LCMGET(IPDMA,'REF:IMERGE',IMERGE) + CALL LCMGET(IPDMA,'REF:IGCOND',IGCR) + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'KEYFLX',KEY) + CALL LCMGET(IPTRK,'VOLUME',VOL) + IOF=1 + JJ=IGCR(1) + DO IND=1,NG + IF(IND.GT.JJ) THEN + IOF=IOF+1 + IF(IOF.GT.NGCOND) CALL XABORT('DMA: NGCOND OVERFLOW.') + JJ=IGCR(IOF) + ENDIF + NDGRP(IND)=IOF + ENDDO + CALL DMASOU(IPRINT,IPDMA,IPMAC,IPFLX,NG,NREG,NMIL,NL,NDEL, + 1 NED,NAMEAD,NUN,NMERGE,NGCOND,NCST,IMERGE,NDGRP,MAT,KEY,VOL) + DEALLOCATE(VOL,KEY,MAT,IGCR,IMERGE) + DEALLOCATE(NDGRP,NAMEAD) +*---- +* SAVE THE SIGNATURE AND STATE VECTOR +*---- + HSIGN='L_SOURCE' + CALL LCMPTC(IPDMA,'SIGNATURE',12,HSIGN) + ISTATE(:NSTATE)=0 + ISTATE(1)=NG + ISTATE(2)=NUN + ISTATE(3)=0 + ISTATE(4)=NCST + ISTATE(5)=NMERGE + ISTATE(6)=NGCOND + IF(IPRINT.GT.0) WRITE(6,100) (ISTATE(I),I=1,6) + CALL LCMPUT(IPDMA,'STATE-VECTOR',NSTATE,1,ISTATE) + RETURN +* + 100 FORMAT(/8H OPTIONS/8H -------/ + 1 7H NG ,I8,28H (NUMBER OF ENERGY GROUPS)/ + 2 7H NUN ,I8,40H (NUMBER OF UNKNOWNS PER ENERGY GROUP)/ + 3 7H NDIR ,I8,35H (NUMBER OF DIRECT FIXED SOURCES)/ + 4 7H NCST ,I8,36H (NUMBER OF ADJOINT FIXED SOURCES)/ + 5 7H NMERGE,I8,34H (NUMBER OF HOMOGENIZED REGIONS)/ + 6 7H NGCOND,I8,38H (NUMBER OF CONDENSED ENERGY GROUPS)) + END diff --git a/Dragon/src/DMAGET.f b/Dragon/src/DMAGET.f new file mode 100644 index 0000000..aa2182a --- /dev/null +++ b/Dragon/src/DMAGET.f @@ -0,0 +1,203 @@ +*DECK DMAGET + SUBROUTINE DMAGET(IPDMA,NGRP,NFREG,NBMIX,MATCOD,IPRINT,NMERGE, + 1 NGCOND) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read from the input file the DMAC: module input options. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPDMA pointer to the DMA data structure. +* NGRP number of energy groups. +* NFREG number of regions. +* NBMIX maximum number of mixtures. +* MATCOD region material. +* +*Parameters: input/output +* IPRINT print parameter. +* NMERGE number of merged regions. +* NGCOND number of condensed energy groups. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPDMA + INTEGER NGRP,NFREG,NBMIX,MATCOD(NFREG),IPRINT,NMERGE,NGCOND +*---- +* LOCAL VARIABLES +*---- + INTEGER INDIC,NITMA,IREGIO,IMATER,IGROUP,JGROUP + REAL FLOTT + CHARACTER TEXT*12 + DOUBLE PRECISION DFLOTT + INTEGER, ALLOCATABLE, DIMENSION(:) :: IMERGE,MIXMER,IGCR +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IMERGE(NFREG),MIXMER(0:NBMIX),IGCR(NGRP)) +*---- +* READ INPUT +*---- + IPRINT=1 + 10 CALL REDGET(INDIC,NITMA,FLOTT,TEXT,DFLOTT) + IF(INDIC.EQ.10) GO TO 200 + IF(INDIC.NE.3) CALL XABORT('DMAGET: CHARACTER DATA EXPECTED(1)') + IF(TEXT(1:4).EQ.'EDIT') THEN + CALL REDGET(INDIC,IPRINT,FLOTT,TEXT,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DMAGET: INTEGER DATA EXPECTED FOR' + < //' IPRINT') + ELSE IF(TEXT(1:5).EQ.'RATE') THEN +* DEFINE A TALLY + NMERGE=0 + NGCOND=0 + 20 CALL REDGET(INDIC,NITMA,FLOTT,TEXT,DFLOTT) + 30 IF(INDIC.NE.3) CALL XABORT('DMAGET: CHARACTER DATA EXPECTED(2)') + IF(TEXT(:4).EQ.'MERG') THEN +*---- +* MERGING DIRECTIVE ANALYSIS +*---- + CALL REDGET(INDIC,NITMA,FLOTT,TEXT,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DMAGET: CHARACTER DATA EXPECTED' + < //'(3)') + IF(TEXT.EQ.'COMP') THEN +*---- +* COMPLETE MERGE +*---- + IMERGE(:NFREG)=1 + NMERGE=1 + GO TO 20 + ELSE IF(TEXT.EQ.'MIX') THEN +*---- +* MERGE BY MIXTURES +*---- + DO 40 IMATER=0,NBMIX + MIXMER(IMATER)=IMATER + 40 CONTINUE + DO 50 IREGIO=1,NFREG + NMERGE=MAX(NMERGE,MATCOD(IREGIO)) + IMERGE(IREGIO)=MIXMER(MATCOD(IREGIO)) + 50 CONTINUE + NMERGE=NBMIX + CALL REDGET(INDIC,NITMA,FLOTT,TEXT,DFLOTT) + IF(INDIC.EQ.1) THEN +*---- +* SPECIFY MIXTURES TO BE MERGED +*---- + NMERGE=MAX(0,NITMA) + MIXMER(1)=NITMA + DO 60 IMATER=2,NBMIX + CALL REDGET(INDIC,NITMA,FLOTT,TEXT,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DMAGET: INTEGER DATA EXPEC' + < //'TED FOR IMIXM') + NMERGE=MAX(NMERGE,NITMA) + MIXMER(IMATER)=NITMA + 60 CONTINUE + DO 70 IREGIO=1,NFREG + IMERGE(IREGIO)=MIXMER(MATCOD(IREGIO)) + 70 CONTINUE + ELSE IF(INDIC.EQ.3) THEN +*---- +* ASSOCIATE ONE REGION BY MIXTURE +*---- + GO TO 30 + ELSE + CALL XABORT('DMAGET: READ ERROR - INVALID TYPE READ') + ENDIF + ELSE IF(TEXT.EQ.'REGI') THEN +*---- +* MERGE BY REGIONS +*---- + CALL REDGET(INDIC,NITMA,FLOTT,TEXT,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DMAGET: INTEGER DATA EXPEC' + < //'TED FOR IREGM') + NMERGE=MAX(0,NITMA) + IMERGE(1)=NITMA + DO 80 IREGIO=2,NFREG + CALL REDGET(INDIC,NITMA,FLOTT,TEXT,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DMAGET: INTEGER DATA EXPECTE' + < //'D FOR IREGM') + NMERGE=MAX(NMERGE,NITMA) + IMERGE(IREGIO)=NITMA + 80 CONTINUE + ELSE IF(TEXT.EQ.'NONE') THEN +*---- +* NO MERGING +*---- + NMERGE=NFREG + DO 90 IREGIO=1,NFREG + IMERGE(IREGIO)=IREGIO + 90 CONTINUE + ELSE + CALL XABORT('DMAGET: '//TEXT//' IS AN INVALID KEYWORD(1)') + ENDIF + ELSE IF(TEXT(:4).EQ.'COND') THEN +*---- +* GROUP CONDENSATION DIRECTIVE ANALYSIS +*---- + DO 110 IGROUP=1,NGRP+1 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT,DFLOTT) + IF(INDIC.EQ.3) THEN + IF(IGROUP.EQ.1) THEN + IF(TEXT.EQ.'NONE') THEN + NGCOND=NGRP + DO 100 JGROUP=1,NGRP + IGCR(JGROUP)=JGROUP + 100 CONTINUE + GO TO 20 + ELSE + NGCOND=1 + IGCR(NGCOND)=NGRP + ENDIF + ENDIF + IF(IGCR(NGCOND).NE.NGRP) THEN + NGCOND=NGCOND+1 + IGCR(NGCOND)=NGRP + ENDIF + GO TO 30 + ELSE IF(INDIC.EQ.1) THEN + IF(NITMA.GT.NGRP) NITMA=NGRP + IF(NGCOND.GT.0) THEN + IF(NITMA.GT.IGCR(NGCOND)) THEN + NGCOND=NGCOND+1 + IGCR(NGCOND)=NITMA + ENDIF + ELSE + NGCOND=NGCOND+1 + IGCR(NGCOND)=NITMA + ENDIF + ENDIF + 110 CONTINUE + ELSE IF(TEXT(:4).EQ.'ENDR') THEN + GO TO 120 + ELSE + CALL XABORT('DMAGET: '//TEXT//' IS AN INVALID KEYWORD(2)') + ENDIF + GO TO 20 + 120 CALL LCMPUT(IPDMA,'REF:IMERGE',NFREG,1,IMERGE) + CALL LCMPUT(IPDMA,'REF:IGCOND',NGCOND,1,IGCR) + ELSE IF(TEXT(1:1).EQ.';') THEN + GO TO 200 + ELSE + CALL XABORT('DMAGET: '//TEXT//' IS AN INVALID KEYWORD(3)') + ENDIF + GO TO 10 +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 200 DEALLOCATE(IGCR,MIXMER,IMERGE) + RETURN + END diff --git a/Dragon/src/DMASOU.f b/Dragon/src/DMASOU.f new file mode 100644 index 0000000..495d32d --- /dev/null +++ b/Dragon/src/DMASOU.f @@ -0,0 +1,555 @@ +*DECK DMASOU + SUBROUTINE DMASOU(IPRINT,IPDMA,IPMAC,IPFLX,NG,NREG,NMIL,NL, + 1 NDEL,NED,NAMEAD,NUN,NMERGE,NGCOND,NCST,IMERGE,INDGRP,MATCOD, + 2 KEYFLX,VOL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the GPT sources corresponding to the gradient of a macrolib. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPRINT print parameter +* IPDMA pointer to the DMA data structure. +* IPMAC pointer to the macrolib structure. +* IPFLX pointer to the multigroup flux. +* NG number of energy groups. +* NREG number of regions. +* NMIL number of material mixtures. +* NL number of Legendre orders. +* NDEL number of delayed precursors. +* NED number of extra edit vectors. +* NAMEAD names of these extra edits. +* NUN number of unknowns per energy group. +* NMERGE number of merged regions. +* NGCOND number of condensed energy groups. +* NCST number of DMA fixed sources. +* IMERGE merging indices. +* INDGRP condensation indices. +* MATCOD material mixture indices per region. +* KEYFLX position of averaged fluxes in unknown vector. +* VOL volumes. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPDMA,IPMAC,IPFLX + INTEGER IPRINT,NG,NREG,NMIL,NL,NDEL,NED,NAMEAD(2,NED),NMERGE, + 1 NGCOND,NCST,IMERGE(NREG),INDGRP(NG),MATCOD(NREG),KEYFLX(NREG) + REAL VOL(NREG) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSECT=4,EPSMAX=1.0E-7) + TYPE(C_PTR) JPFLX,JPDMA,KPDMA,JPMAC,KPMAC + CHARACTER TEXT12*12,TEXB12*12,HSECT(NSECT)*12,CM*2 + DOUBLE PRECISION WW,SUM,FUNC,ZN +*---- +* DATA STATEMENTS +*---- + DATA HSECT/'NTOT0','SIGS00','N2N','N3N'/ +*---- +* ALLOCATABLE ARRAYS +*---- + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) ::IKEP + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJS00,NJJS00,IPOS00 + REAL, ALLOCATABLE, DIMENSION(:) :: FLUX,SIGT,CHI,EPS,SCAT + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: XSSNN + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: GAR1,GAR2 + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) ::GAR3 + REAL, POINTER, DIMENSION(:) :: SUNK +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IKEP(NG)) + ALLOCATE(FLUX(NUN),SIGT(NMIL),CHI(NMIL),XSSNN(NMIL,NG,NG), + 1 EPS(NCST)) + ALLOCATE(GAR1(NMERGE,NGCOND),GAR2(NMERGE,NGCOND), + 1 GAR3(NMERGE,NGCOND,NGCOND)) +* + IOF=0 + EPS(:NCST)=0.0 + JPFLX=LCMGID(IPFLX,'FLUX') + JPDMA=LCMLID(IPDMA,'ASOUR',NCST) +*---- +* NWT0 INFORMATION +*---- + SUM=0.0D0 + GAR2(:NMERGE,:NGCOND)=0.0D0 + DO IG=1,NG + IGCND=INDGRP(IG) + CALL LCMGDL(JPFLX,IG,FLUX) + DO IR=1,NREG + IF(KEYFLX(IR).EQ.0) CYCLE + IMERG=IMERGE(IR) + WW=FLUX(KEYFLX(IR))*VOL(IR) + SUM=SUM+WW + IF((IGCND.NE.0).AND.(IMERG.NE.0)) THEN + GAR2(IMERG,IGCND)=GAR2(IMERG,IGCND)+WW + ENDIF + ENDDO + ENDDO + DO IGCND=1,NGCOND + DO IMERG=1,NMERGE + IOF=IOF+1 + IF(IOF.GT.NCST) CALL XABORT('DMASOU: NCST OVERFLOW(1).') + DO IG=1,NG + IKEP(IG)=LCMARA(NUN) + CALL C_F_POINTER(IKEP(IG),SUNK,(/ NUN /)) + SUNK(:NUN)=0.0 + DO IR=1,NREG + IF(KEYFLX(IR).EQ.0) CYCLE + IUNK=KEYFLX(IR) + FUNC=VOL(IR)*GAR2(IMERG,IGCND)/SUM + IF((IMERGE(IR).EQ.IMERG).AND.(INDGRP(IG).EQ.IGCND)) + 1 THEN + SUNK(IUNK)=REAL(FUNC/GAR2(IMERG,IGCND)) + ENDIF + SUNK(IUNK)=REAL(SUNK(IUNK)-FUNC/SUM) + ZN=SUM/FUNC + EPS(IOF)=MAX(EPS(IOF),ABS(SUNK(IUNK)*REAL(ZN))) + ENDDO + ENDDO + IF(EPS(IOF).GT.EPSMAX) THEN + KPDMA=LCMLIL(JPDMA,IOF,NG) + DO IG=1,NG + CALL LCMPPL(KPDMA,IG,NUN,2,IKEP(IG)) + ENDDO + ELSE + DO IG=1,NG + CALL LCMDRD(IKEP(IG)) + ENDDO + ENDIF + ENDDO + ENDDO +*---- +* SET OF NSECT BASIC CROSS SECTIONS +*---- + JPMAC=LCMGID(IPMAC,'GROUP') + DO ISECT=1,NSECT + TEXT12=HSECT(ISECT) + GAR1(:NMERGE,:NGCOND)=0.0D0 + GAR2(:NMERGE,:NGCOND)=0.0D0 + DO IG=1,NG + KPMAC=LCMGIL(JPMAC,IG) + CALL LCMLEN(KPMAC,TEXT12,ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPMAC,TEXT12,SIGT) + IGCND=INDGRP(IG) + CALL LCMGDL(JPFLX,IG,FLUX) + DO IR=1,NREG + IF(KEYFLX(IR).EQ.0) CYCLE + IMERG=IMERGE(IR) + WW=FLUX(KEYFLX(IR))*VOL(IR) + IF((IGCND.NE.0).AND.(IMERG.NE.0)) THEN + IBM=MATCOD(IR) + GAR1(IMERG,IGCND)=GAR1(IMERG,IGCND)+WW + IF(IBM.GT.0) THEN + GAR2(IMERG,IGCND)=GAR2(IMERG,IGCND)+SIGT(IBM)*WW + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + DO IGCND=1,NGCOND + DO IMERG=1,NMERGE + IOF=IOF+1 + IF(IOF.GT.NCST) CALL XABORT('DMASOU: NCST OVERFLOW(2).') + IF(GAR2(IMERG,IGCND).NE.0.0) THEN + DO IG=1,NG + KPMAC=LCMGIL(JPMAC,IG) + CALL LCMLEN(KPMAC,TEXT12,ILONG,ITYLCM) + IKEP(IG)=LCMARA(NUN) + CALL C_F_POINTER(IKEP(IG),SUNK,(/ NUN /)) + SUNK(:NUN)=0.0 + IF(ILONG.GT.0) THEN + CALL LCMGET(KPMAC,TEXT12,SIGT) + DO IR=1,NREG + IF(KEYFLX(IR).EQ.0) CYCLE + IF((IMERGE(IR).EQ.IMERG).AND.(INDGRP(IG).EQ.IGCND)) + 1 THEN + IUNK=KEYFLX(IR) + IBM=MATCOD(IR) + FUNC=VOL(IR)*GAR2(IMERG,IGCND)/GAR1(IMERG,IGCND) + IF(IBM.EQ.0) THEN + SUNK(IUNK)=REAL(-FUNC/GAR1(IMERG,IGCND)) + ELSE + SUNK(IUNK)=REAL(FUNC*(SIGT(IBM)/ + 1 GAR2(IMERG,IGCND)-1.0D0/GAR1(IMERG,IGCND))) + ENDIF + ZN=SUM/FUNC + EPS(IOF)=MAX(EPS(IOF),ABS(SUNK(IUNK)*REAL(ZN))) + ENDIF + ENDDO + ENDIF + ENDDO + IF(EPS(IOF).GT.EPSMAX) THEN + KPDMA=LCMLIL(JPDMA,IOF,NG) + DO IG=1,NG + CALL LCMPPL(KPDMA,IG,NUN,2,IKEP(IG)) + ENDDO + ELSE + DO IG=1,NG + CALL LCMDRD(IKEP(IG)) + ENDDO + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO +*---- +* SCATTERING CROSS SECTION INFORMATION +*---- + ALLOCATE(IJJS00(NMIL),NJJS00(NMIL),IPOS00(NMIL)) + DO IL=1,NL + WRITE(CM,'(I2.2)') IL-1 + XSSNN(:NMIL,:NG,:NG)=0.0 + DO JG=1,NG + KPMAC=LCMGIL(JPMAC,JG) + CALL LCMGET(KPMAC,'IJJS'//CM,IJJS00) + CALL LCMGET(KPMAC,'NJJS'//CM,NJJS00) + CALL LCMGET(KPMAC,'IPOS'//CM,IPOS00) + IMAX=0 + DO IBM=1,NMIL + IMAX=IMAX+NJJS00(IBM) + ENDDO + ALLOCATE(SCAT(IMAX)) + CALL LCMGET(KPMAC,'SCAT'//CM,SCAT) + DO IBM=1,NMIL + IPOS=IPOS00(IBM) + IG=IJJS00(IBM) + IENBR=NJJS00(IBM) + DO WHILE (IENBR.GE.1) + XSSNN(IBM,JG,IG)=SCAT(IPOS) ! JG <-- IG + IPOS=IPOS+1 + IENBR=IENBR-1 + IG=IG-1 + ENDDO + ENDDO + DEALLOCATE(SCAT) + ENDDO + GAR1(:NMERGE,:NGCOND)=0.0D0 + GAR3(:NMERGE,:NGCOND,:NGCOND)=0.0D0 + DO IG=1,NG + IGCND=INDGRP(IG) + CALL LCMGDL(JPFLX,IG,FLUX) + DO IR=1,NREG + IF(KEYFLX(IR).EQ.0) CYCLE + IMERG=IMERGE(IR) + WW=FLUX(KEYFLX(IR))*VOL(IR) + IF((IGCND.NE.0).AND.(IMERG.NE.0)) THEN + IBM=MATCOD(IR) + GAR1(IMERG,IGCND)=GAR1(IMERG,IGCND)+WW + IF(IBM.GT.0) THEN + DO JG=1,NG + JGCND=INDGRP(JG) + GAR3(IMERG,JGCND,IGCND)=GAR3(IMERG,JGCND,IGCND) + 1 +XSSNN(IBM,JG,IG)*WW + ENDDO + ENDIF + ENDIF + ENDDO + ENDDO + DO JGCND=1,NGCOND + DO IGCND=1,NGCOND + DO IMERG=1,NMERGE + IOF=IOF+1 + IF(IOF.GT.NCST) CALL XABORT('DMASOU: NCST OVERFLOW(3).') + IF(GAR3(IMERG,JGCND,IGCND).NE.0.0) THEN + DO IG=1,NG + IKEP(IG)=LCMARA(NUN) + CALL C_F_POINTER(IKEP(IG),SUNK,(/ NUN /)) + SUNK(:NUN)=0.0 + DO JG=1,NG + DO IR=1,NREG + IF(KEYFLX(IR).EQ.0) CYCLE + IF((IMERGE(IR).EQ.IMERG).AND.(INDGRP(IG).EQ.IGCND) + 1 .AND.(INDGRP(JG).EQ.JGCND)) THEN + IBM=MATCOD(IR) + IF(IBM.NE.0) THEN + IUNK=KEYFLX(IR) + FUNC=VOL(IR)*GAR3(IMERG,JGCND,IGCND)/ + 1 GAR1(IMERG,IGCND) + SUNK(IUNK)=REAL(SUNK(IUNK)+FUNC* + 1 XSSNN(IBM,JG,IG)/GAR3(IMERG,JGCND,IGCND)) + ENDIF + ENDIF + ENDDO + ENDDO + DO IR=1,NREG + IF(KEYFLX(IR).EQ.0) CYCLE + IF((IMERGE(IR).EQ.IMERG).AND.(INDGRP(IG).EQ.IGCND)) + 1 THEN + IUNK=KEYFLX(IR) + FUNC=VOL(IR)*GAR3(IMERG,JGCND,IGCND)/ + 1 GAR1(IMERG,IGCND) + SUNK(IUNK)=SUNK(IUNK)-REAL(FUNC/GAR1(IMERG,IGCND)) + ZN=SUM/FUNC + EPS(IOF)=MAX(EPS(IOF),ABS(SUNK(IUNK)*REAL(ZN))) + ENDIF + ENDDO + ENDDO + IF(EPS(IOF).GT.EPSMAX) THEN + KPDMA=LCMLIL(JPDMA,IOF,NG) + DO IG=1,NG + CALL LCMPPL(KPDMA,IG,NUN,2,IKEP(IG)) + ENDDO + ELSE + DO IG=1,NG + CALL LCMDRD(IKEP(IG)) + ENDDO + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + DEALLOCATE(IPOS00,NJJS00,IJJS00) +*---- +* FISSION INFORMATION +*---- + DO IDEL=1,1+NDEL + IF(IDEL.EQ.1) THEN + TEXT12='NUSIGF' + TEXB12='CHI' + ELSE + WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL-1 + WRITE(TEXB12,'(3HCHI,I2.2)') IDEL-1 + ENDIF + GAR1(:NMERGE,:NGCOND)=0.0D0 + GAR2(:NMERGE,:NGCOND)=0.0D0 + GAR3(:NMERGE,:NGCOND,1)=0.0D0 + DO IG=1,NG + KPMAC=LCMGIL(JPMAC,IG) + CALL LCMLEN(KPMAC,TEXT12,ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPMAC,TEXT12,SIGT) + CALL LCMGET(KPMAC,TEXB12,CHI) + IGCND=INDGRP(IG) + CALL LCMGDL(JPFLX,IG,FLUX) + DO IR=1,NREG + IF(KEYFLX(IR).EQ.0) CYCLE + IMERG=IMERGE(IR) + WW=FLUX(KEYFLX(IR))*VOL(IR) + IF((IGCND.NE.0).AND.(IMERG.NE.0)) THEN + IBM=MATCOD(IR) + GAR1(IMERG,IGCND)=GAR1(IMERG,IGCND)+WW + IF(IBM.GT.0) THEN + GAR2(IMERG,IGCND)=GAR2(IMERG,IGCND)+SIGT(IBM)*WW + GAR3(IMERG,IGCND,1)=GAR3(IMERG,IGCND,1)+CHI(IBM)* + 1 SIGT(IBM)*WW + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + DO IGCND=1,NGCOND + DO IMERG=1,NMERGE + IOF=IOF+1 + IF(IOF.GT.NCST) CALL XABORT('DMASOU: NCST OVERFLOW(4).') + IF(GAR2(IMERG,IGCND).NE.0.0) THEN + DO IG=1,NG + KPMAC=LCMGIL(JPMAC,IG) + CALL LCMLEN(KPMAC,TEXT12,ILONG,ITYLCM) + IKEP(IG)=LCMARA(NUN) + CALL C_F_POINTER(IKEP(IG),SUNK,(/ NUN /)) + SUNK(:NUN)=0.0 + IF(ILONG.GT.0) THEN + CALL LCMGET(KPMAC,TEXT12,SIGT) + DO IR=1,NREG + IF(KEYFLX(IR).EQ.0) CYCLE + IF((IMERGE(IR).EQ.IMERG).AND.(INDGRP(IG).EQ.IGCND)) + 1 THEN + IUNK=KEYFLX(IR) + IBM=MATCOD(IR) + FUNC=VOL(IR)*GAR2(IMERG,IGCND)/GAR1(IMERG,IGCND) + IF(IBM.EQ.0) THEN + SUNK(IUNK)=REAL(-FUNC/GAR1(IMERG,IGCND)) + ELSE + SUNK(IUNK)=REAL(FUNC*(SIGT(IBM)/ + 1 GAR2(IMERG,IGCND)-1.0D0/GAR1(IMERG,IGCND))) + ENDIF + ZN=SUM/FUNC + EPS(IOF)=MAX(EPS(IOF),ABS(SUNK(IUNK)*REAL(ZN))) + ENDIF + ENDDO + ENDIF + ENDDO + IF(EPS(IOF).GT.EPSMAX) THEN + KPDMA=LCMLIL(JPDMA,IOF,NG) + DO IG=1,NG + CALL LCMPPL(KPDMA,IG,NUN,2,IKEP(IG)) + ENDDO + ELSE + DO IG=1,NG + CALL LCMDRD(IKEP(IG)) + ENDDO + ENDIF + ENDIF + IOF=IOF+1 + IF(IOF.GT.NCST) CALL XABORT('DMASOU: NCST OVERFLOW(5).') + IF(GAR3(IMERG,IGCND,1).NE.0.0) THEN + DO IG=1,NG + KPMAC=LCMGIL(JPMAC,IG) + CALL LCMLEN(KPMAC,TEXT12,ILONG,ITYLCM) + IKEP(IG)=LCMARA(NUN) + CALL C_F_POINTER(IKEP(IG),SUNK,(/ NUN /)) + SUNK(:NUN)=0.0 + IF(ILONG.GT.0) THEN + CALL LCMGET(KPMAC,TEXT12,SIGT) + CALL LCMGET(KPMAC,TEXB12,CHI) + DO IR=1,NREG + IF(KEYFLX(IR).EQ.0) CYCLE + IF((IMERGE(IR).EQ.IMERG).AND.(INDGRP(IG).EQ.IGCND)) + 1 THEN + IBM=MATCOD(IR) + IF(IBM.NE.0) THEN + IUNK=KEYFLX(IR) + FUNC=VOL(IR)*SIGT(IBM)*GAR3(IMERG,IGCND,1)/ + 1 GAR2(IMERG,IGCND) + SUNK(IUNK)=REAL(FUNC*(CHI(IBM)/ + 1 GAR3(IMERG,IGCND,1)-1.0D0/GAR2(IMERG,IGCND))) + ZN=SUM/FUNC + EPS(IOF)=MAX(EPS(IOF),ABS(SUNK(IUNK)*REAL(ZN))) + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + IF(EPS(IOF).GT.EPSMAX) THEN + KPDMA=LCMLIL(JPDMA,IOF,NG) + DO IG=1,NG + CALL LCMPPL(KPDMA,IG,NUN,2,IKEP(IG)) + ENDDO + ELSE + DO IG=1,NG + CALL LCMDRD(IKEP(IG)) + ENDDO + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO +*---- +* ADDITIONAL CROSS SECTION INFORMATION +*---- + DO IED=1,NED + WRITE(TEXT12,'(2A4)') NAMEAD(1,IED),NAMEAD(2,IED) + GAR1(:NMERGE,:NGCOND)=0.0D0 + GAR2(:NMERGE,:NGCOND)=0.0D0 + DO IG=1,NG + KPMAC=LCMGIL(JPMAC,IG) + CALL LCMLEN(KPMAC,TEXT12,ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPMAC,TEXT12,SIGT) + IGCND=INDGRP(IG) + CALL LCMGDL(JPFLX,IG,FLUX) + DO IR=1,NREG + IF(KEYFLX(IR).EQ.0) CYCLE + IMERG=IMERGE(IR) + WW=FLUX(KEYFLX(IR))*VOL(IR) + IF((IGCND.NE.0).AND.(IMERG.NE.0)) THEN + IBM=MATCOD(IR) + GAR1(IMERG,IGCND)=GAR1(IMERG,IGCND)+WW + IF(IBM.GT.0) THEN + GAR2(IMERG,IGCND)=GAR2(IMERG,IGCND)+SIGT(IBM)*WW + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + DO IGCND=1,NGCOND + DO IMERG=1,NMERGE + IOF=IOF+1 + IF(IOF.GT.NCST) CALL XABORT('DMASOU: NCST OVERFLOW(6).') + IF(GAR2(IMERG,IGCND).NE.0.0) THEN + DO IG=1,NG + KPMAC=LCMGIL(JPMAC,IG) + CALL LCMLEN(KPMAC,TEXT12,ILONG,ITYLCM) + IKEP(IG)=LCMARA(NUN) + CALL C_F_POINTER(IKEP(IG),SUNK,(/ NUN /)) + SUNK(:NUN)=0.0 + IF(ILONG.GT.0) THEN + CALL LCMGET(KPMAC,TEXT12,SIGT) + DO IR=1,NREG + IF(KEYFLX(IR).EQ.0) CYCLE + IF((IMERGE(IR).EQ.IMERG).AND.(INDGRP(IG).EQ.IGCND)) + 1 THEN + IUNK=KEYFLX(IR) + IBM=MATCOD(IR) + FUNC=VOL(IR)*GAR2(IMERG,IGCND)/GAR1(IMERG,IGCND) + IF(IBM.EQ.0) THEN + SUNK(IUNK)=REAL(-FUNC/GAR1(IMERG,IGCND)) + ELSE + SUNK(IUNK)=REAL(FUNC*(SIGT(IBM)/ + 1 GAR2(IMERG,IGCND)-1.0D0/GAR1(IMERG,IGCND))) + ENDIF + ZN=SUM/FUNC + EPS(IOF)=MAX(EPS(IOF),ABS(SUNK(IUNK)*REAL(ZN))) + ENDIF + ENDDO + ENDIF + ENDDO + IF(EPS(IOF).GT.EPSMAX) THEN + KPDMA=LCMLIL(JPDMA,IOF,NG) + DO IG=1,NG + CALL LCMPPL(KPDMA,IG,NUN,2,IKEP(IG)) + ENDDO + ELSE + DO IG=1,NG + CALL LCMDRD(IKEP(IG)) + ENDDO + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO +*---- +* CHECK SOURCE ORTHOGONALITY +*---- + ALLOCATE(SUNK(NUN)) + DO IOF=1,NCST + CALL LCMLEL(JPDMA,IOF,ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + KPDMA=LCMGIL(JPDMA,IOF) + SUM=0.0D0 + DO IG=1,NG + CALL LCMGDL(KPDMA,IG,SUNK) + CALL LCMGDL(JPFLX,IG,FLUX) + DO IR=1,NREG + IUNK=KEYFLX(IR) + IF(IUNK.GT.0) SUM=SUM+SUNK(IUNK)*FLUX(IUNK) + ENDDO + ENDDO + IF(IPRINT.GT.0) THEN + WRITE(6,'(14H SOURCE INDEX=,I10,14H DOT PRODUCT=,1P,E11.4, + 1 19H SOURCE INTENSITY=,E11.4)') IOF,ABS(SUM),EPS(IOF) + ENDIF + IF(ABS(SUM).GT.1.0E-5) THEN + WRITE(TEXT12,'(I10,2X)') IOF + CALL XABORT('DMASOU: NON ORTHOGONAL SOURCE (IOF='// + 1 TEXT12(:10)//').') + ENDIF + ENDIF + ENDDO + DEALLOCATE(SUNK) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GAR3,GAR2,GAR1) + DEALLOCATE(EPS,XSSNN,CHI,SIGT,FLUX) + DEALLOCATE(IKEP) + RETURN + END diff --git a/Dragon/src/DOORAB.f b/Dragon/src/DOORAB.f new file mode 100644 index 0000000..940cef1 --- /dev/null +++ b/Dragon/src/DOORAB.f @@ -0,0 +1,196 @@ +*DECK DOORAB + SUBROUTINE DOORAB (CDOOR,JPSYS,NPSYS,IPTRK,IMPX,NGRP,NREG,NBMIX, + 1 NANI,MAT,VOL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Double heterogeneity treatment (part 1). Vectorial version. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* CDOOR name of the geometry/solution operator. +* JPSYS pointer to the PIJ LCM object (L_PIJ signature). JPSYS is a +* list of NGRP directories. +* NPSYS index array pointing to the JPSYS list component corresponding +* to each energy group. Set to zero if a group is not to be +* processed. Usually, NPSYS(I)=I. +* IPTRK pointer to the tracking (L_TRACK signature). +* IMPX print flag (equal to zero for no print). +* NGRP number of energy groups. +* NBMIX number of mixtures (NBMIX=max(MAT(i))). +* NANI number of Legendre orders (usually equal to one). +* +*Parameters: input/output +* NREG total number of regions for which specific values of the +* neutron flux and reaction rates are required on input and +* number of regions in the macro-geometry at output. +* MAT index-number of the mixture type assigned to each volume +* on input and index-number of the mixture type assigned +* to each macro-volume at output. +* VOL volume on input and macro-volumes at output. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER CDOOR*12 + TYPE(C_PTR) JPSYS,IPTRK + INTEGER NPSYS(NGRP) + INTEGER IMPX,NGRP,NREG,NBMIX,NANI,MAT(NREG) + REAL VOL(NREG) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(IOUT=6) + INTEGER IPAR(8) + TYPE(C_PTR) KPSYS,KPBIH +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NS,IDIL,MIXGR,IBI,NCO + REAL, ALLOCATABLE, DIMENSION(:) :: RS,FRACT,VOLK,VOL2,SGAR,SGAS, + > RRRR,QKDEL,QKOLD,PKL,P1I,P1DI,P1KI,SIGA1 + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: COEF +*--- +* RECOVER DOUBLE HETEROGENEITY DATA +*---- + CALL LCMSIX(IPTRK,'BIHET',1) + CALL LCMGET(IPTRK,'PARAM',IPAR) + IR1=IPAR(1) + IR2=IPAR(2) + NREG2=IPAR(3) + NG=IPAR(4) + NSMAX=IPAR(5) + IBIHET=IPAR(6) + MICRO=IPAR(7) + IQUA10=IPAR(8) + IF(IR1.NE.NBMIX) CALL XABORT('DOORAB: INVALID DATA IN TRACKING.') + IF(IBIHET.EQ.0) CALL XABORT('DOORAB: BIHET MODEL NOT SET.') + NMILG=IR2-IR1 + ALLOCATE(NS(NG),IDIL(NMILG),MIXGR(NSMAX*NG*NMILG),IBI(NREG2)) + ALLOCATE(RS(NG*(1+NSMAX)),FRACT(NG*IR2),VOLK(NG*NSMAX), + 1 VOL2(NREG2)) + CALL LCMGET(IPTRK,'NS',NS) + CALL LCMGET(IPTRK,'RS',RS) + CALL LCMGET(IPTRK,'FRACT',FRACT) + CALL LCMGET(IPTRK,'VOLK',VOLK) + CALL LCMGET(IPTRK,'IDIL',IDIL) + CALL LCMGET(IPTRK,'MIXGR',MIXGR) + CALL LCMGET(IPTRK,'VOLUME',VOL2) + CALL LCMGET(IPTRK,'IBI',IBI) + CALL LCMGET(IPTRK,'FRTM',FRTM) + CALL LCMSIX(IPTRK,' ',2) + IF(IMPX.GT.1) THEN + WRITE(IOUT,'(/43H DOORAB: RECOVER DOUBLE-HETEROGENEITY DATA.)') + WRITE(IOUT,'(35H NUMBER OF ORDINARY MIXTURES ,I4)') IR1 + WRITE(IOUT,'(35H NUMBER OF COMPOSITE MIXTURES ,I4)') NMILG + WRITE(IOUT,'(35H NUMBER OF KIND OF GRAINS ,I4)') NG + WRITE(IOUT,'(35H NUMBER OF ORDINARY VOLUMES ,I4)') NREG2 + WRITE(IOUT,'(35H NUMBER OF COMPOSITE VOLUMES ,I4)') NREG + WRITE(IOUT,'(35H TYPE OF MICRO VOLUMES (3 OR 4) ,I4)') MICRO + WRITE(IOUT,'(35H MAX. NUMBER OF VOLUMES PER GRAIN,I4)') NSMAX + WRITE(IOUT,'(35H QUADRATURE PARAMETER FOR GRAINS ,I4)') IQUA10 + WRITE(IOUT,'(35H DOUBLE HETEROGENEITY MODEL ,I4)') IBIHET + IF(IBIHET.EQ.3.OR.IBIHET.EQ.4) THEN + WRITE(IOUT,'(35H MINIMUM GRAINS FRACTION ,F8.4)') + > FRTM + ENDIF + ENDIF +*---- +* COMPUTE THE EQUIVALENT CROSS SECTIONS IN COMPOSITE REGIONS +*---- + NB1=NBMIX+1 + ALLOCATE(SGAR((NB1+NMILG)),SGAS((NB1+NMILG)*NANI)) + SGAS(:(NB1+NMILG)*NANI)=0.0 + DO 100 IGR=1,NGRP + IOFSET=NPSYS(IGR) + IF(IOFSET.NE.0) THEN + IF(IMPX.GT.10) WRITE(IOUT,'(/25H DOORAB: PROCESSING GROUP,I5, + > 6H WITH ,A,1H.)') IGR,CDOOR + KPSYS=LCMGIL(JPSYS,IOFSET) + CALL LCMGET(KPSYS,'DRAGON-TXSC',SGAR) + CALL LCMGET(KPSYS,'DRAGON-S0XSC',SGAS) +*---- +* MORE MEMORY ALLOCATION +*---- + IF((IBIHET.EQ.1).OR.(IBIHET.EQ.2)) THEN + ALLOCATE(NCO(NMILG)) + ALLOCATE(RRRR(NMILG),QKDEL(NG*NSMAX*NMILG), + > QKOLD(NG*NSMAX*NMILG),PKL(NG*NSMAX*NSMAX*NMILG)) + ALLOCATE(COEF(NMILG*(1+NG*NSMAX)**2)) + ELSEIF ((IBIHET.EQ.3).OR.(IBIHET.EQ.4)) THEN + ALLOCATE(P1I(NG*NMILG),P1KI(NSMAX*NG*NMILG), + > P1DI(NG*NMILG),SIGA1(NG*NMILG)) + P1I(:)=0 + P1DI(:)=0 + P1KI(:)=0 + SIGA1(:)=0 + ENDIF +*---- +* DOUBLE HETEROGENEITY TREATMENT -- PART 1 +*---- + IF(IBIHET.EQ.1) THEN +* SANCHEZ-POMRANING MODEL. + CALL XDRH11(NBMIX,NMILG,NG,NSMAX,MICRO,IQUA10,NS,IDIL, + > MIXGR,RS,FRACT,VOLK,SGAR,SGAS,NCO,RRRR,QKOLD,QKDEL,PKL, + > COEF) + ELSEIF(IBIHET.EQ.2) THEN +* HEBERT MODEL. + CALL XDRH12(NBMIX,NMILG,NG,NSMAX,MICRO,IQUA10,NS,IDIL, + > MIXGR,RS,FRACT,VOLK,SGAR,SGAS,NCO,RRRR,QKDEL,PKL,COEF) + ELSEIF((IBIHET.EQ.3).OR.(IBIHET.EQ.4)) THEN +* SHE-LIU-SHI MODEL. + CALL XDRH13(NBMIX,NMILG,NG,NSMAX,IQUA10,FRTM,NS,IDIL, + > MIXGR,RS,FRACT,SGAR,SGAS,P1I,P1DI,P1KI,SIGA1) + ELSE + CALL XABORT('DOORAB: INVALID DOUBLE HETEROGENEITY MODEL.') + ENDIF +* + KPBIH=LCMDID(KPSYS,'BIHET') + CALL LCMPUT(KPBIH,'DRAGON-TXSC',1+IR2,2,SGAR) + CALL LCMPUT(KPBIH,'DRAGON-S0XSC',(1+IR2)*NANI,2,SGAS) +* + IF((IBIHET.EQ.1).OR.(IBIHET.EQ.2)) THEN + CALL LCMPUT(KPSYS,'NCO',NMILG,1,NCO) + CALL LCMPUT(KPSYS,'RRRR',NMILG,2,RRRR) + CALL LCMPUT(KPSYS,'QKOLD',NG*NSMAX*NMILG,2,QKOLD) + CALL LCMPUT(KPSYS,'QKDEL',NG*NSMAX*NMILG,2,QKDEL) + CALL LCMPUT(KPSYS,'PKL',NG*NSMAX*NSMAX*NMILG,2,PKL) + CALL LCMPUT(KPSYS,'COEF',NMILG*(1+NG*NSMAX)**2,4,COEF) + DEALLOCATE(NCO) + DEALLOCATE(COEF) + DEALLOCATE(PKL,QKOLD,QKDEL,RRRR) + ELSEIF((IBIHET.EQ.3).OR.(IBIHET.EQ.4)) THEN + CALL LCMPUT(KPSYS,'P1I',NG*NMILG,2,P1I) + CALL LCMPUT(KPSYS,'P1DI',NG*NMILG,2,P1DI) + CALL LCMPUT(KPSYS,'P1KI',NG*NSMAX*NMILG,2,P1KI) + CALL LCMPUT(KPSYS,'SIGA1',NG*NMILG,2,SIGA1) + DEALLOCATE(P1I,P1DI,P1KI,SIGA1) + ENDIF + ENDIF + 100 CONTINUE + DEALLOCATE(SGAS,SGAR) +*---- +* SET MACRO-GEOMETRY. +*---- + NREG=NREG2 + NBMIX=NBMIX+NMILG + DO I=1,NREG2 + MAT(I)=IBI(I) + VOL(I)=VOL2(I) + ENDDO + DEALLOCATE(RS,FRACT,VOLK,VOL2) + DEALLOCATE(NS,IDIL,MIXGR,IBI) + RETURN + END diff --git a/Dragon/src/DOORAV.f b/Dragon/src/DOORAV.f new file mode 100644 index 0000000..6750624 --- /dev/null +++ b/Dragon/src/DOORAV.f @@ -0,0 +1,329 @@ +*DECK DOORAV + SUBROUTINE DOORAV (CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IMPX,NGRP,NREG, + 1 NBMIX,NANI,NW,MAT,VOL,KNORM,LEAKSW,TITR,NALBP,ISTRM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of system matrices. Vectorial version. +* +*Copyright: +* Copyright (C) 2004 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* CDOOR name of the geometry/solution operator. +* JPSYS pointer to the PIJ LCM object (L_PIJ signature). JPSYS is +* a list of directories. +* NPSYS index array pointing to the JPSYS list component corresponding +* to each energy group. Set to zero if a group is not to be +* processed. Usually, NPSYS(I)=I. +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK unit of the sequential binary tracking file. +* IMPX print flag (equal to zero for no print). +* NGRP number of energy groups. +* NREG total number of merged blocks for which specific values +* of the neutron flux and reactions rates are required. +* NBMIX number of mixtures (NBMIX=max(MAT(i))). +* NANI number of Legendre orders. +* NW type of weighting for P1 cross section info (=0: P0 ; =1: P1). +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KNORM normalization scheme. +* LEAKSW leakage flag (=.true. if neutron leakage through external +* boundary is present). +* TITR title. +* NALBP number of physical albedos. +* ISTRM type of streaming effect: +* =1 no streaming effect; +* =2 isotropic streaming effect; +* =3 anisotropic streaming effect. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER CDOOR*12,TITR*72 + LOGICAL LEAKSW + TYPE(C_PTR) JPSYS,IPTRK + INTEGER NPSYS(NGRP),IFTRAK,IMPX,NGRP,NREG,NBMIX,NANI,NW,MAT(NREG), + > KNORM,NALBP,ISTRM + REAL VOL(NREG) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + INTEGER ISTATE(NSTATE) + LOGICAL LBIHET + CHARACTER TEXT12*12 + INTEGER, ALLOCATABLE, DIMENSION(:) :: MAT2 + REAL, ALLOCATABLE, DIMENSION(:) :: VOL2,SGAR,SGAS,SGAD,ALBP,GAMMA + TYPE(C_PTR) KPSYS +* + ALB(X)=0.5*(1.0-X)/(1.0+X) +* + IF(IMPX.GT.5) THEN + WRITE(6,'(/36H DOORAV: ASSEMBLY OF SYSTEM MATRICES//9X,A72)') + 1 TITR + WRITE(6,'(/30H DOORAV: NORMALIZATION SCHEME=,I2,9H LEAKAGE , + 1 7HSWITCH=,L2)') KNORM,LEAKSW + ENDIF +*---- +* DOUBLE HETEROGENEITY TREATMENT +*---- + NREGAR=0 + NBMIXG=0 + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + LBIHET=ISTATE(40).NE.0 + IF(LBIHET) THEN + ALLOCATE(MAT2(NREG),VOL2(NREG)) + DO I=1,NREG + MAT2(I)=MAT(I) + VOL2(I)=VOL(I) + ENDDO + NREGAR=NREG + NBMIXG=NBMIX + CALL DOORAB(CDOOR,JPSYS,NPSYS,IPTRK,IMPX,NGRP,NREG,NBMIX,NANI, + 1 MAT,VOL) + ENDIF +* + IF ((CDOOR.EQ.'EXCELL').AND.(ISTATE(7).EQ.5)) THEN + ! MULTICELL SURFACIC APPROXIMATION + IF(ISTATE(10).NE.0) CALL XABORT('DOORAV: TISO EXPECTED.') +* recover the number of tracks dispached in eack OpenMP core + NBATCH=ISTATE(27) + IF(NBATCH.EQ.0) NBATCH=1 + ALLOCATE(SGAR(NBMIX+1),SGAS((NBMIX+1)*NANI)) + DO 90 IGR=1,NGRP + IOFSET=NPSYS(IGR) + IF(IOFSET.NE.0) THEN + KPSYS=LCMGIL(JPSYS,IOFSET) + IF(LBIHET) CALL LCMSIX(KPSYS,'BIHET',1) + CALL LCMLEN(KPSYS,'DRAGON-TXSC',ILONG,ITYLCM) + IF(ILONG.NE.NBMIX+1) CALL XABORT('DOORAV: INVALID TXSC ' + 1 //'LENGTH(1).') + CALL LCMGET(KPSYS,'DRAGON-TXSC',SGAR) + CALL LCMGET(KPSYS,'DRAGON-S0XSC',SGAS) + CALL MUSA(KPSYS,IPTRK,IFTRAK,IMPX,NREG,NBMIX,SGAR,SGAS, + 1 NBATCH,TITR,NALBP,ALBP) + IF(LBIHET) CALL LCMSIX(KPSYS,' ',2) + ENDIF + 90 CONTINUE + DEALLOCATE(SGAS,SGAR) + ELSE IF (CDOOR.EQ.'SYBIL') THEN + ALLOCATE(SGAR(NBMIX+1),SGAS((NBMIX+1)*NANI)) + DO 100 IGR=1,NGRP + IOFSET=NPSYS(IGR) + IF(IOFSET.NE.0) THEN + KPSYS=LCMGIL(JPSYS,IOFSET) + IF(LBIHET) CALL LCMSIX(KPSYS,'BIHET',1) + CALL LCMLEN(KPSYS,'DRAGON-TXSC',ILONG,ITYLCM) + IF(ILONG.NE.NBMIX+1) CALL XABORT('DOORAV: INVALID TXSC ' + 1 //'LENGTH(1).') + CALL LCMGET(KPSYS,'DRAGON-TXSC',SGAR) + CALL LCMGET(KPSYS,'DRAGON-S0XSC',SGAS) + CALL SYBILA(KPSYS,IPTRK,IMPX,NREG,NBMIX,MAT,SGAR,SGAS) + IF(LBIHET) CALL LCMSIX(KPSYS,' ',2) + ENDIF + 100 CONTINUE + DEALLOCATE(SGAS,SGAR) + ELSE IF (CDOOR.EQ.'SN') THEN + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + ITYPE=ISTATE(6) + ISOLVSA=ISTATE(33) + IF(ISTATE(19).EQ.1) THEN +* SYNTHETIC ACCELERATION. + IF(IMPX.GT.0) WRITE (6,'(/29H DOORAV: SYNTHETIC ACCELERATI, + 1 20HON ASSEMBLY FOLLOWS:)') + CALL LCMSIX(IPTRK,'DSA',1) + ALLOCATE(SGAR((NBMIX+1)*(NW+1)),SGAS((NBMIX+1)*NANI), + 1 SGAD(NBMIX+1)) + DO 150 IGR=1,NGRP + IOFSET=NPSYS(IGR) + IF(IOFSET.NE.0) THEN + KPSYS=LCMGIL(JPSYS,IOFSET) + ISTATE(:NSTATE)=0 + CALL LCMPUT(KPSYS,'STATE-VECTOR',NSTATE,1,ISTATE) + IF(LBIHET) CALL LCMSIX(KPSYS,'BIHET',1) + CALL LCMLEN(KPSYS,'DRAGON-TXSC',ILONG,ITYLCM) + IF(ILONG.NE.NBMIX+1) CALL XABORT('DOORAV: INVALID TX' + 1 //'SC LENGTH(2).') + CALL LCMGET(KPSYS,'DRAGON-TXSC',SGAR) + DO 110 IW=2,MIN(NW+1,10) + IOF=(NBMIX+1)*(IW-1)+1 + WRITE(TEXT12,'(8HDRAGON-T,I1,3HXSC)') IW-1 + CALL LCMLEN(KPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.NBMIX+1) THEN + CALL LCMGET(KPSYS,TEXT12,SGAR(IOF)) + ELSE + CALL LCMGET(KPSYS,'DRAGON-TXSC',SGAR(IOF)) + ENDIF + 110 CONTINUE + CALL LCMGET(KPSYS,'DRAGON-S0XSC',SGAS) + IF((ITYPE.EQ.7).OR.(ITYPE.EQ.9)) THEN + CALL TRIVA(KPSYS,IPTRK,IMPX,NREG,NBMIX,NANI,NW,MAT, + 1 VOL,SGAR,SGAS,SGAD) + ELSE + IF(ISOLVSA.EQ.1)THEN + CALL BIVAA(KPSYS,IPTRK,IMPX,NREG,NBMIX,NANI, + 1 NW,MAT,VOL,SGAR,SGAS,SGAD) + ELSEIF(ISOLVSA.EQ.2)THEN + CALL TRIVA(KPSYS,IPTRK,IMPX,NREG,NBMIX,NANI, + 1 NW,MAT,VOL,SGAR,SGAS,SGAD) + ENDIF + ENDIF + IF(LBIHET) CALL LCMSIX(KPSYS,' ',2) + ENDIF + 150 CONTINUE + DEALLOCATE(SGAD,SGAS,SGAR) + CALL LCMSIX(IPTRK,' ',2) + ENDIF + ELSE IF (CDOOR.EQ.'BIVAC') THEN + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + IELEM=ISTATE(8) + ICOL=ISTATE(9) + NLF=ISTATE(14) + ISCAT=ISTATE(16) + ALLOCATE(SGAR((NBMIX+1)*(NW+1)),SGAS((NBMIX+1)*NANI), + 1 SGAD(NBMIX+1)) + DO 190 IGR=1,NGRP + IOFSET=NPSYS(IGR) + IF(IOFSET.NE.0) THEN + KPSYS=LCMGIL(JPSYS,IOFSET) +* SAVE ALBEDO FUNCTIONS ON KPSYS + IF(NALBP.GT.0) THEN + ALLOCATE(ALBP(NALBP),GAMMA(NALBP)) + CALL LCMGET(KPSYS,'ALBEDO',ALBP) + DO IALB=1,NALBP + IF((IELEM.LT.0).OR.(ICOL.EQ.4)) THEN + GAMMA(IALB)=ALB(ALBP(IALB)) + ELSE IF(ALBP(IALB).NE.1.0) THEN + GAMMA(IALB)=1.0/ALB(ALBP(IALB)) + ELSE + GAMMA(IALB)=1.0E20 + ENDIF + ENDDO + CALL LCMPUT(KPSYS,'ALBEDO-FU',NALBP,2,GAMMA) + DEALLOCATE(GAMMA,ALBP) + ENDIF +* + IF(LBIHET) CALL LCMSIX(KPSYS,'BIHET',1) + CALL LCMLEN(KPSYS,'DRAGON-TXSC',ILONG,ITYLCM) + IF(ILONG.NE.NBMIX+1) CALL XABORT('DOORAV: INVALID TXSC ' + 1 //'LENGTH(3).') + CALL LCMGET(KPSYS,'DRAGON-TXSC',SGAR) + IF(NLF.EQ.0) THEN + CALL LCMGET(KPSYS,'DRAGON-DIFF',SGAD) + ELSE IF(ISCAT.LT.0) THEN + CALL LCMGET(KPSYS,'DRAGON-DIFF',SGAD) + SGAR(NBMIX+2)=1.0E10 + DO 180 IMIX=1,NBMIX + SGAR(NBMIX+2+IMIX)=1.0/(3.0*SGAD(IMIX+1)) + 180 CONTINUE + ELSE IF(ISCAT.GT.0) THEN + DO 185 IW=2,MIN(NW+1,10) + IOF=(NBMIX+1)*(IW-1)+1 + WRITE(TEXT12,'(8HDRAGON-T,I1,3HXSC)') IW-1 + CALL LCMLEN(KPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + CALL LCMGET(KPSYS,'DRAGON-T1XSC',SGAR(IOF)) + ELSE + CALL LCMGET(KPSYS,'DRAGON-TXSC',SGAR(IOF)) + ENDIF + 185 CONTINUE + ENDIF + CALL LCMGET(KPSYS,'DRAGON-S0XSC',SGAS) + CALL BIVAA(KPSYS,IPTRK,IMPX,NREG,NBMIX,NANI,NW,MAT,VOL, + 1 SGAR,SGAS,SGAD) + IF(LBIHET) CALL LCMSIX(KPSYS,' ',2) + ENDIF + 190 CONTINUE + DEALLOCATE(SGAD,SGAS,SGAR) + ELSE IF (CDOOR.EQ.'TRIVAC') THEN + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + ICHX=ISTATE(12) + NLF=ISTATE(30) + ISCAT=ISTATE(32) + ALLOCATE(SGAR((NBMIX+1)*2),SGAS((NBMIX+1)*NANI),SGAD(NBMIX+1)) + DO 210 IGR=1,NGRP + IOFSET=NPSYS(IGR) + IF(IOFSET.NE.0) THEN + KPSYS=LCMGIL(JPSYS,IOFSET) +* SAVE ALBEDO FUNCTIONS ON KPSYS + IF(NALBP.GT.0) THEN + ALLOCATE(ALBP(NALBP),GAMMA(NALBP)) + CALL LCMGET(KPSYS,'ALBEDO',ALBP) + DO IALB=1,NALBP + IF(ICHX.NE.2) THEN + GAMMA(IALB)=ALB(ALBP(IALB)) + ELSE IF(ALBP(IALB).NE.1.0) THEN + GAMMA(IALB)=1.0/ALB(ALBP(IALB)) + ELSE + GAMMA(IALB)=1.0E20 + ENDIF + ENDDO + CALL LCMPUT(KPSYS,'ALBEDO-FU',NALBP,2,GAMMA) + DEALLOCATE(GAMMA,ALBP) + ENDIF +* + ISTATE(:NSTATE)=0 + CALL LCMPUT(KPSYS,'STATE-VECTOR',NSTATE,1,ISTATE) + IF(LBIHET) CALL LCMSIX(KPSYS,'BIHET',1) + CALL LCMLEN(KPSYS,'DRAGON-TXSC',ILONG,ITYLCM) + IF(ILONG.NE.NBMIX+1) CALL XABORT('DOORAV: INVALID TXSC ' + 1 //'LENGTH(4).') + CALL LCMGET(KPSYS,'DRAGON-TXSC',SGAR) + IF(NLF.EQ.0) THEN + CALL LCMGET(KPSYS,'DRAGON-DIFF',SGAD) + ELSE IF(ISCAT.LT.0) THEN + CALL LCMGET(KPSYS,'DRAGON-DIFF',SGAD) + SGAR(NBMIX+2)=1.0E10 + DO 200 IMIX=1,NBMIX + SGAR(NBMIX+2+IMIX)=1.0/(3.0*SGAD(IMIX+1)) + 200 CONTINUE + ELSE IF(ISCAT.GT.0) THEN + DO 205 IW=2,MIN(NW+1,10) + IOF=(NBMIX+1)*(IW-1)+1 + WRITE(TEXT12,'(8HDRAGON-T,I1,3HXSC)') IW-1 + CALL LCMLEN(KPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + CALL LCMGET(KPSYS,'DRAGON-T1XSC',SGAR(IOF)) + ELSE + CALL LCMGET(KPSYS,'DRAGON-TXSC',SGAR(IOF)) + ENDIF + 205 CONTINUE + ENDIF + CALL LCMGET(KPSYS,'DRAGON-S0XSC',SGAS) + CALL TRIVA(KPSYS,IPTRK,IMPX,NREG,NBMIX,NANI,NW,MAT,VOL, + 1 SGAR,SGAS,SGAD) + IF(LBIHET) CALL LCMSIX(KPSYS,' ',2) + ENDIF + 210 CONTINUE + DEALLOCATE(SGAD,SGAS,SGAR) + ELSE IF ((CDOOR.EQ.'MCCG').OR.(CDOOR.EQ.'EXCELL')) THEN + CALL MCCGA(JPSYS,NPSYS,IPTRK,IFTRAK,IMPX,NGRP,NBMIX,NANI, + 1 NALBP,ISTRM) + ELSE + CALL XABORT('DOORAV: UNKNOWN DOOR:'//CDOOR//'.') + ENDIF +*---- +* DOUBLE HETEROGENEITY TREATMENT +*---- + IF(LBIHET) THEN + NREG=NREGAR + NBMIX=NBMIXG + DO I=1,NREG + MAT(I)=MAT2(I) + VOL(I)=VOL2(I) + ENDDO + DEALLOCATE(MAT2,VOL2) + ENDIF + RETURN + END diff --git a/Dragon/src/DOORFB2.f b/Dragon/src/DOORFB2.f new file mode 100644 index 0000000..3659fbe --- /dev/null +++ b/Dragon/src/DOORFB2.f @@ -0,0 +1,160 @@ +*DECK DOORFB2 + SUBROUTINE DOORFB2(IPSYS,IPTRK,IMPX,NBMIX,NREG,NUN,KEYFLX,NBMIX2, + 1 NREG2,SUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Double heterogeneity treatment (part 2). One-group version. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPSYS pointer to the assembly LCM object (L_PIJ signature). IPSYS is +* a list of directories. +* IPTRK pointer to the tracking (L_TRACK signature). +* IMPX print flag (equal to zero for no print). +* NBMIX number of composite mixtures in the domain. Equal to the +* number of mixtures in the internal library. +* NREG number of volumes in the composite geometry. +* NUN total number of unknowns in vector SUNKNO. +* KEYFLX index of flux components in unknown vector. +* +*Parameters: input/output +* SUNKNO sources defined in the composite geometry on input and +* equivalent macro-sources at output. +* +*Parameters: output +* NBMIX2 number of mixtures in the internal library, including +* double-heterogeneity mixtures. +* NREG2 number of volumes in the macro geometry. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSYS,IPTRK + INTEGER IMPX,NBMIX,NREG,NUN,KEYFLX(NREG),NBMIX2,NREG2 + REAL SUNKNO(NUN) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(IOUT=6) + INTEGER IPAR(8) +*---- +* ALLOCATABLE ARRAYS +*---- + TYPE(C_PTR) NS_PTR,IBI_PTR,FRACT_PTR,VOLK_PTR,IDIL_PTR,MIXGR_PTR, + > NCO_PTR,RRRR_PTR,QKOLD_PTR,QKDEL_PTR,PKL_PTR,COEF_PTR,P1I_PTR, + > P1DI_PTR,P1KI_PTR,SIGA1_PTR + INTEGER, DIMENSION(:), POINTER :: NS,IBI,IDIL,MIXGR,NCO + REAL, DIMENSION(:), POINTER :: FRACT,VOLK,SGAR,RRRR,QKOLD, + > QKDEL,PKL,P1I,P1DI,P1KI,SIGA1 + REAL, DIMENSION(:), ALLOCATABLE :: FLUAS + DOUBLE PRECISION, DIMENSION(:), POINTER :: COEF +*---- +* RECOVER DOUBLE HETEROGENEITY DATA +*---- + IF(IMPX.GT.50) THEN + WRITE(6,'(/38H DOORFB2: DOUBLE HETEROGENEITY OPTION.)') + ENDIF + CALL LCMSIX(IPTRK,'BIHET',1) + CALL LCMGET(IPTRK,'PARAM',IPAR) + IR1=IPAR(1) + IR2=IPAR(2) + NREG2=IPAR(3) + NG=IPAR(4) + NSMAX=IPAR(5) + IBIHET=IPAR(6) + IF(IR1.NE.NBMIX) THEN + WRITE(6,'(/13HDOORFB2: IR1=,I6,7H NBMIX=,I6)') IR1,NBMIX + CALL XABORT('DOORFB2: INVALID DATA IN TRACKING.') + ENDIF + IF(NREG2.GT.NUN) CALL XABORT('DOORFB2: NUN OVERFLOW.') + NMILG=IR2-IR1 + CALL LCMGPD(IPTRK,'NS',NS_PTR) + CALL LCMGPD(IPTRK,'IBI',IBI_PTR) + CALL LCMGPD(IPTRK,'FRACT',FRACT_PTR) + CALL LCMGPD(IPTRK,'VOLK',VOLK_PTR) + CALL LCMGPD(IPTRK,'IDIL',IDIL_PTR) + CALL LCMGPD(IPTRK,'MIXGR',MIXGR_PTR) + CALL LCMSIX(IPTRK,' ',2) +* + CALL C_F_POINTER(NS_PTR,NS,(/ NG /)) + CALL C_F_POINTER(IBI_PTR,IBI,(/ NREG2 /)) + CALL C_F_POINTER(FRACT_PTR,FRACT,(/ NG*(NBMIX+NMILG) /)) + CALL C_F_POINTER(VOLK_PTR,VOLK,(/ NG*NSMAX /)) + CALL C_F_POINTER(IDIL_PTR,IDIL,(/ NMILG /)) + CALL C_F_POINTER(MIXGR_PTR,MIXGR,(/ NSMAX*NG*NMILG /)) +*---- +* RECOVER GROUP-DEPENDENT BIHET INFORMATION +*---- + IF((IBIHET.EQ.1) .OR. (IBIHET.EQ.2)) THEN + CALL LCMGPD(IPSYS,'NCO',NCO_PTR) + CALL LCMGPD(IPSYS,'RRRR',RRRR_PTR) + CALL LCMGPD(IPSYS,'QKOLD',QKOLD_PTR) + CALL LCMGPD(IPSYS,'QKDEL',QKDEL_PTR) + CALL LCMGPD(IPSYS,'PKL',PKL_PTR) + CALL LCMGPD(IPSYS,'COEF',COEF_PTR) +* + CALL C_F_POINTER(NCO_PTR,NCO,(/ NMILG /)) + CALL C_F_POINTER(RRRR_PTR,RRRR,(/ NMILG /)) + CALL C_F_POINTER(QKOLD_PTR,QKOLD,(/ NG*NSMAX*NMILG /)) + CALL C_F_POINTER(QKDEL_PTR,QKDEL,(/ NG*NSMAX*NMILG /)) + CALL C_F_POINTER(PKL_PTR,PKL,(/ NG*NSMAX*NSMAX*NMILG /)) + CALL C_F_POINTER(COEF_PTR,COEF,(/ NMILG*(1+NG*NSMAX)**2 /)) + ELSE IF((IBIHET.EQ.3) .OR. (IBIHET.EQ.4)) THEN + CALL LCMGPD(IPSYS,'P1I',P1I_PTR) + CALL LCMGPD(IPSYS,'P1DI',P1DI_PTR) + CALL LCMGPD(IPSYS,'P1KI',P1KI_PTR) + CALL LCMGPD(IPSYS,'SIGA1',SIGA1_PTR) +* + CALL C_F_POINTER(P1I_PTR,P1I,(/ NG*NMILG /)) + CALL C_F_POINTER(P1DI_PTR,P1DI,(/ NG*NMILG /)) + CALL C_F_POINTER(P1KI_PTR,P1KI,(/ NSMAX*NG*NMILG /)) + CALL C_F_POINTER(SIGA1_PTR,SIGA1,(/ NG*NMILG /)) + ENDIF +*---- +* COMPUTE THE EQUIVALENT CROSS SECTIONS IN COMPOSITE REGIONS +*---- + CALL LCMSIX(IPSYS,'BIHET',1) + NB1=NBMIX+1 + ALLOCATE(SGAR(NB1+NMILG)) + CALL LCMGET(IPSYS,'DRAGON-TXSC',SGAR) + CALL LCMSIX(IPSYS,' ',2) +*---- +* DOUBLE HETEROGENEITY TREATMENT -- PART 2 +*---- + ALLOCATE(FLUAS(NREG2)) + IF((IBIHET.EQ.1) .OR. (IBIHET.EQ.2)) THEN + CALL XDRH20(IBIHET,NUN,NBMIX,NMILG,NREG,NREG2,NG,NSMAX,KEYFLX, + > NS,IDIL,MIXGR,IBI,FRACT,VOLK,SGAR,NCO,RRRR,QKOLD,QKDEL,PKL, + > COEF,SUNKNO,FLUAS) + ELSE IF((IBIHET.EQ.3) .OR. (IBIHET.EQ.4)) THEN + CALL XDRH23(IBIHET,NUN,NBMIX,NMILG,NREG,NREG2,NG,NSMAX,KEYFLX, + > NS,IDIL,MIXGR,IBI,FRACT,SGAR,P1I,P1DI,P1KI,SIGA1,SUNKNO,FLUAS) + ENDIF +*---- +* SET MACRO-INFORMATION +*---- + SUNKNO(:NUN)=0.0 + DO 10 I=1,NREG2 + SUNKNO(KEYFLX(I))=FLUAS(I) + 10 CONTINUE + DEALLOCATE(FLUAS) + NBMIX2=NBMIX+NMILG +*---- +* MEMORY RELEASE +*---- + DEALLOCATE(SGAR) + RETURN + END diff --git a/Dragon/src/DOORFB3.f b/Dragon/src/DOORFB3.f new file mode 100644 index 0000000..0ded44f --- /dev/null +++ b/Dragon/src/DOORFB3.f @@ -0,0 +1,147 @@ +*DECK DOORFB3 + SUBROUTINE DOORFB3(IPSYS,IPTRK,IMPX,NBMIX,NREG,NUN,KEYFLX,SUNKNO, + 1 FUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Double heterogeneity treatment (part 3). One-group version. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPSYS pointer to the assembly LCM object (L_PIJ signature). IPSYS is +* a list of directories. +* IPTRK pointer to the tracking (L_TRACK signature). +* IMPX print flag (equal to zero for no print). +* NBMIX number of composite mixtures in the domain. Equal to the +* number of mixtures in the internal library. +* NREG number of volumes in the composite geometry. +* NUN total number of unknowns in vector SUNKNO. +* KEYFLX index of flux components in unknown vector. +* SUNKNO equivalent macro-sources. +* +*Parameters: input/output +* FUNKNO equivalent macro-fluxes on input and +* composite fluxes on output. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSYS,IPTRK + INTEGER IMPX,NBMIX,NREG,NUN,KEYFLX(NREG) + REAL SUNKNO(NUN) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(IOUT=6) + INTEGER IPAR(8) +*---- +* ALLOCATABLE ARRAYS +*---- + TYPE(C_PTR) NS_PTR,IBI_PTR,FRACT_PTR,VOLK_PTR,IDIL_PTR,MIXGR_PTR, + > NCO_PTR,RRRR_PTR,QKOLD_PTR,QKDEL_PTR,PKL_PTR,COEF_PTR,P1I_PTR, + > P1DI_PTR,P1KI_PTR,SIGA1_PTR + INTEGER, DIMENSION(:), POINTER :: NS,IBI,IDIL,MIXGR,NCO + REAL, DIMENSION(:), POINTER :: FRACT,VOLK,RRRR,QKOLD,QKDEL,PKL, + > P1I,P1DI,P1KI,SIGA1 + REAL, DIMENSION(:), ALLOCATABLE :: SGAR,SGAS + DOUBLE PRECISION, DIMENSION(:), POINTER :: COEF +*---- +* RECOVER DOUBLE HETEROGENEITY DATA +*---- + IF(IMPX.GT.50) THEN + WRITE(6,'(/38H DOORFB3: DOUBLE HETEROGENEITY OPTION.)') + ENDIF + CALL LCMSIX(IPTRK,'BIHET',1) + CALL LCMGET(IPTRK,'PARAM',IPAR) + IR1=IPAR(1) + IR2=IPAR(2) + NREG2=IPAR(3) + NG=IPAR(4) + NSMAX=IPAR(5) + IBIHET=IPAR(6) + IF(IR1.NE.NBMIX) CALL XABORT('DOORFB3: INVALID DATA IN TRACKING.') + IF(NREG2.GT.NUN) CALL XABORT('DOORFB3: NUN OVERFLOW.') + NMILG=IR2-IR1 + CALL LCMGPD(IPTRK,'NS',NS_PTR) + CALL LCMGPD(IPTRK,'IBI',IBI_PTR) + CALL LCMGPD(IPTRK,'FRACT',FRACT_PTR) + CALL LCMGPD(IPTRK,'VOLK',VOLK_PTR) + CALL LCMGPD(IPTRK,'IDIL',IDIL_PTR) + CALL LCMGPD(IPTRK,'MIXGR',MIXGR_PTR) + CALL LCMSIX(IPTRK,' ',2) +* + CALL C_F_POINTER(NS_PTR,NS,(/ NG /)) + CALL C_F_POINTER(IBI_PTR,IBI,(/ NREG2 /)) + CALL C_F_POINTER(FRACT_PTR,FRACT,(/ NG*(NBMIX+NMILG) /)) + CALL C_F_POINTER(VOLK_PTR,VOLK,(/ NG*NSMAX /)) + CALL C_F_POINTER(IDIL_PTR,IDIL,(/ NMILG /)) + CALL C_F_POINTER(MIXGR_PTR,MIXGR,(/ NSMAX*NG*NMILG /)) +*---- +* RECOVER GROUP-DEPENDENT BIHET INFORMATION +*---- + IF((IBIHET.EQ.1) .OR. (IBIHET.EQ.2)) THEN + CALL LCMGPD(IPSYS,'NCO',NCO_PTR) + CALL LCMGPD(IPSYS,'RRRR',RRRR_PTR) + CALL LCMGPD(IPSYS,'QKOLD',QKOLD_PTR) + CALL LCMGPD(IPSYS,'QKDEL',QKDEL_PTR) + CALL LCMGPD(IPSYS,'PKL',PKL_PTR) + CALL LCMGPD(IPSYS,'COEF',COEF_PTR) +* + CALL C_F_POINTER(NCO_PTR,NCO,(/ NMILG /)) + CALL C_F_POINTER(RRRR_PTR,RRRR,(/ NMILG /)) + CALL C_F_POINTER(QKOLD_PTR,QKOLD,(/ NG*NSMAX*NMILG /)) + CALL C_F_POINTER(QKDEL_PTR,QKDEL,(/ NG*NSMAX*NMILG /)) + CALL C_F_POINTER(PKL_PTR,PKL,(/ NG*NSMAX*NSMAX*NMILG /)) + CALL C_F_POINTER(COEF_PTR,COEF,(/ NMILG*(1+NG*NSMAX)**2 /)) + ELSE IF((IBIHET.EQ.3) .OR. (IBIHET.EQ.4)) THEN + CALL LCMGPD(IPSYS,'P1I',P1I_PTR) + CALL LCMGPD(IPSYS,'P1DI',P1DI_PTR) + CALL LCMGPD(IPSYS,'P1KI',P1KI_PTR) + CALL LCMGPD(IPSYS,'SIGA1',SIGA1_PTR) +* + CALL C_F_POINTER(P1I_PTR,P1I,(/ NG*NMILG /)) + CALL C_F_POINTER(P1DI_PTR,P1DI,(/ NG*NMILG /)) + CALL C_F_POINTER(P1KI_PTR,P1KI,(/ NSMAX*NG*NMILG /)) + CALL C_F_POINTER(SIGA1_PTR,SIGA1,(/ NG*NMILG /)) + ENDIF +*---- +* COMPUTE THE EQUIVALENT CROSS SECTIONS IN COMPOSITE REGIONS +*---- + CALL LCMSIX(IPSYS,'BIHET',1) + NB1=NBMIX+1 + CALL LCMLEN(IPSYS,'DRAGON-S0XSC',ILONG,ITYLCM) + NANI=ILONG/(NB1+NMILG) + ALLOCATE(SGAR(NB1+NMILG),SGAS((NB1+NMILG)*NANI)) + SGAS(:(NB1+NMILG)*NANI)=0.0 + CALL LCMGET(IPSYS,'DRAGON-TXSC',SGAR) + CALL LCMGET(IPSYS,'DRAGON-S0XSC',SGAS) + CALL LCMSIX(IPSYS,' ',2) +*---- +* DOUBLE HETEROGENEITY TREATMENT -- PART 2 +*---- + IF((IBIHET.EQ.1) .OR. (IBIHET.EQ.2)) THEN + CALL XDRH30(IBIHET,NUN,NBMIX,NMILG,NREG,NREG2,NG,NSMAX,KEYFLX, + > NS,IDIL,MIXGR,IBI,FRACT,VOLK,SGAR,SGAS,NCO,RRRR,QKOLD,QKDEL, + > PKL,COEF,SUNKNO,FUNKNO) + ELSE IF((IBIHET.EQ.3) .OR. (IBIHET.EQ.4)) THEN + CALL XDRH33(IBIHET,NUN,NBMIX,NMILG,NREG,NREG2,NG,NSMAX,KEYFLX, + > NS,IDIL,MIXGR,IBI,FRACT,VOLK,SGAR,P1I,P1DI,P1KI,SIGA1,FUNKNO) + ENDIF +*---- +* MEMORY RELEASE +*---- + DEALLOCATE(SGAS,SGAR) + RETURN + END diff --git a/Dragon/src/DOORFV.f b/Dragon/src/DOORFV.f new file mode 100644 index 0000000..eaa1098 --- /dev/null +++ b/Dragon/src/DOORFV.f @@ -0,0 +1,336 @@ +*DECK DOORFV + SUBROUTINE DOORFV(CDOOR,IPSYS,NPSYS,IPTRK,IFTRAK,IMPX,NGRP,NMAT, + 1 IDIR,NREG,NUN,IPHASE,LEXAC,MAT,VOL,KEYFLX,TITR,SUNKNO,FUNKNO, + 2 IPMACR,IPSOU,REBFLG,FLUXC,EVALRHO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the flux. Vectorial version. Multigroup rebalancing +* option. +* +*Copyright: +* Copyright (C) 2004 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* CDOOR name of the geometry/solution operator. +* IPSYS pointer to the assembly LCM object (L_PIJ signature). IPSYS is +* a list of directories. +* NPSYS index array pointing to the IPSYS list component corresponding +* to each energy group. Set to zero if a group is not to be +* processed. Usually, NPSYS(I)=I. +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK unit of the sequential binary tracking file. +* IMPX print flag (equal to zero for no print). +* NGRP number of energy groups. +* NMAT number of mixtures in the internal library. +* IDIR directional collision probability flag: +* =0 for pij or wij; +* =k for pijk or wijk k=1,2,3. +* direction of fundamental current for TIBERE with MoC +* (=0,1,2,3). +* NREG total number of merged blocks for which specific values +* of the neutron flux and reactions rates are required. +* NUN total number of unknowns in vectors SUNKNO and FUNKNO. +* IPHASE type of flux solution (=1: use a native flux solution door; +* =2: use collision probabilities). +* LEXAC type of exponential function calculation (=.false. to compute +* exponential functions using tables). +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX index of L-th order flux components in unknown vector. +* TITR title. +* SUNKNO input source vector. Depending on the solution technique +* used, sources may oy may not include volumes. +* FUNKNO unknown vector. +* IPMACR pointer to the macrolib LCM object. +* IPSOU pointer to the fixed source LCM object. +* REBFLG ACA or SCR rebalancing flag. +* FLUXC flux at the cutoff energy. +* EVALRHO dominance ratio. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSYS,IPTRK,IPMACR,IPSOU + CHARACTER CDOOR*12,TITR*72 + INTEGER NPSYS(NGRP),IFTRAK,IMPX,NGRP,NMAT,IDIR,NREG,NUN,IPHASE, + > MAT(NREG),KEYFLX(NREG) + REAL VOL(NREG) + REAL, TARGET, INTENT(IN) :: SUNKNO(NUN,NGRP) + REAL, TARGET, INTENT(INOUT) :: FUNKNO(NUN,NGRP) + LOGICAL LEXAC,REBFLG + REAL,OPTIONAL :: FLUXC(NREG) + REAL,OPTIONAL :: EVALRHO +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6,NSTATE=40) + INTEGER IPAR(NSTATE) + LOGICAL LBIHET + CHARACTER CNFDIR(0:3)*9 + TYPE(C_PTR) JPSOU,JPSOU1,JPSOU2 + SAVE CNFDIR +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NGIND,NBS,NBS2 + LOGICAL, ALLOCATABLE, DIMENSION(:) :: INCONV + REAL, ALLOCATABLE, DIMENSION(:) :: FGAR + REAL, POINTER, DIMENSION(:,:) :: SUNKN,SUNKNO2,FUNKNO2 + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: JPSYS,KPSYS,KPSOU1, + 1 KPSOU2 +*---- +* DATA STATEMENTS +*---- + DATA CNFDIR /'F L U X ','C U R - X','C U R - Y','C U R - Z'/ +*---- +* RECOVER FIXED SOURCES FROM IPSOU LCM OBJECT +*---- + ALLOCATE(NBS(NGRP)) + ISBS=0 + NBS(:)=0 + JPSOU1=C_NULL_PTR + JPSOU2=C_NULL_PTR + IF(C_ASSOCIATED(IPSOU)) THEN + CALL LCMLEN(IPSOU,'NBS',ILEN,ITYLCM) + IF(ILEN.GT.0) THEN + ISBS=1 + CALL LCMGET(IPSOU,'NBS',NBS) + JPSOU=LCMGID(IPSOU,'BS') + JPSOU1=JPSOU + JPSOU=LCMGID(IPSOU,'BSINFO') + JPSOU2=JPSOU + IF(.NOT.C_ASSOCIATED(JPSOU1)) THEN + CALL LCMLIB(IPSOU) + CALL XABORT('DOORFV: BS DIRECTORY IS MISSING.') + ELSE IF(.NOT.C_ASSOCIATED(JPSOU2)) THEN + CALL LCMLIB(IPSOU) + CALL XABORT('DOORFV: BSINFO DIRECTORY IS MISSING.') + ENDIF + ENDIF + ENDIF +*---- +* GATHER INITIAL FLUXES AND SOURCES FOR PARALLEL PROCESSING +*---- + NGEFF=0 + JJ=0 + IIG=0 + DO IG=1,NGRP + IF(NPSYS(IG).NE.0) THEN + NGEFF=NGEFF+1 + IIG=IG + ENDIF + ENDDO + IF(NGEFF.EQ.0) RETURN + ALLOCATE(NGIND(NGEFF),JPSYS(NGEFF),NBS2(NGEFF),KPSOU1(NGEFF), + 1 KPSOU2(NGEFF)) + NBS2(:)=0 + KPSOU1(:)=C_NULL_PTR + KPSOU2(:)=C_NULL_PTR + IF(NGEFF.EQ.1) THEN + NGIND(1)=IIG + SUNKNO2=>SUNKNO(1:NUN,IIG:IIG) + FUNKNO2=>FUNKNO(1:NUN,IIG:IIG) + IF(ISBS.EQ.1) NBS2(1)=NBS(IIG) + JPSYS(1)=LCMGIL(IPSYS,NPSYS(IIG)) + IF(NBS2(1).NE.0) THEN + KPSOU1(1)=LCMGIL(JPSOU1,IIG) + KPSOU2(1)=LCMGIL(JPSOU2,IIG) + ENDIF + ELSE IF(NGEFF.EQ.NGRP) THEN + SUNKNO2=>SUNKNO + FUNKNO2=>FUNKNO + IF(ISBS.EQ.1) NBS2(:)=NBS(:) + DO IG=1,NGRP + NGIND(IG)=IG + JPSYS(IG)=LCMGIL(IPSYS,NPSYS(IG)) + IF(NBS2(IG).NE.0) THEN + KPSOU1(IG)=LCMGIL(JPSOU1,IG) + KPSOU2(IG)=LCMGIL(JPSOU2,IG) + ENDIF + ENDDO + ELSE + ALLOCATE(SUNKNO2(NUN,NGEFF),FUNKNO2(NUN,NGEFF)) + JJ=0 + DO IG=1,NGRP + IF(NPSYS(IG).NE.0) THEN + JJ=JJ+1 + NGIND(JJ)=IG + SUNKNO2(:NUN,JJ)=SUNKNO(:NUN,IG) + FUNKNO2(:NUN,JJ)=FUNKNO(:NUN,IG) + IF(ISBS.EQ.1) NBS2(JJ)=NBS(IG) + JPSYS(JJ)=LCMGIL(IPSYS,NPSYS(IG)) + IF(NBS2(JJ).NE.0) THEN + KPSOU1(JJ)=LCMGIL(JPSOU1,IG) + KPSOU2(JJ)=LCMGIL(JPSOU2,IG) + ENDIF + ENDIF + ENDDO + ENDIF +* + IF(IMPX.GT.3) THEN + WRITE(IUNOUT,'(//11H DOORFV: **,A,3H** ,A72)') CDOOR,TITR + ALLOCATE(FGAR(NREG)) + DO II=1,NGEFF + FGAR(:NREG)=0.0 + DO I=1,NREG + IF(KEYFLX(I).NE.0) FGAR(I)=SUNKNO(KEYFLX(I),II) + ENDDO + WRITE(IUNOUT,'(/33H N E U T R O N S O U R C E S (,I5, + 1 3H ):,4X,A9)') NGIND(II),CNFDIR(IDIR) + WRITE(IUNOUT,'(1P,6(5X,E15.7))') (FGAR(I),I=1,NREG) + ENDDO + DEALLOCATE(FGAR) + ENDIF +*--- +* RECOVER FLUXES FROM A PREVIOUS SELF-SHIELDING CALCULATION IF AVAILABLE +*--- + DO JJ=1,NGEFF + CALL LCMLEN(JPSYS(JJ),'FUNKNO$USS',ILENG,ITYLCM) + IF(ILENG.EQ.NUN) THEN + CALL LCMGET(JPSYS(JJ),'FUNKNO$USS',FUNKNO2(1,JJ)) + ENDIF + ENDDO +*---- +* RECOVER STATE VECTOR INFORMATION +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',IPAR) + LBIHET=IPAR(40).NE.0 + IF(NREG.NE.IPAR(1)) CALL XABORT('DOORFV: INVALID NREG ON LCM.') +*---- +* DOUBLE HETEROGENEITY TREATMENT. REDEFINE THE SOURCE. +*---- + NMATG=0 + NREGG=0 + IF(LBIHET) THEN + ALLOCATE(SUNKN(NUN,NGEFF)) + NMATG=NMAT + NREGG=NREG + DO II=1,NGEFF + SUNKN(:NUN,II)=SUNKNO2(:NUN,II) + IF(CDOOR.EQ.'MCCG') THEN + CALL DOORFB2(JPSYS(II),IPTRK,IMPX,NMAT,NREG,NUN,KEYFLX, + 1 NMAT2,NREG2,SUNKNO2(1,II)) + ELSE + CALL DOORFB2(JPSYS(II),IPTRK,IMPX,NMAT,NREG,NUN,KEYFLX, + 1 NMAT2,NREG2,SUNKNO2(1,II)) + ENDIF + ENDDO + NMAT=NMAT2 + NREG=NREG2 + ELSE + ALLOCATE(SUNKN(1,1)) + ENDIF +*--- +* RECOVER POINTERS TO EACH GROUP PROPERTIES +*--- + ALLOCATE(KPSYS(NGEFF)) + DO II=1,NGEFF + IF(LBIHET) THEN + KPSYS(II)=LCMGID(JPSYS(II),'BIHET') + ELSE + KPSYS(II)=JPSYS(II) + ENDIF + ENDDO +*---- +* COMPUTE NEW FLUXES +*---- + IF(IPHASE.EQ.1) THEN +* USE A NATIVE DOOR + IF ((CDOOR.EQ.'EXCELL').AND.(IPAR(7).EQ.5)) THEN + CALL MUSF(KPSYS,IPTRK,IMPX,NGEFF,NGIND,IDIR,NREG,NUN,MAT, + > VOL,FUNKNO2,SUNKNO2,TITR) + ELSE IF(CDOOR.EQ.'SYBIL') THEN + CALL SYBILF(KPSYS,IPTRK,IFTRAK,IMPX,NGEFF,NGIND,IDIR,NREG, + > NUN,MAT,VOL,FUNKNO2,SUNKNO2,TITR) + ELSE IF(CDOOR.EQ.'BIVAC') THEN + NLF=IPAR(14) + IF(NLF.EQ.0) THEN + CALL BIVAF(KPSYS,IPTRK,IFTRAK,IMPX,NGEFF,NGIND,IDIR,NREG, + > NUN,MAT,VOL,KEYFLX,FUNKNO2,SUNKNO2,TITR) + ELSE + IF(IDIR.NE.0) CALL XABORT('DOORFV: EXPECTING IDIR=0') + IF(IFTRAK.NE.0) CALL XABORT('DOORFV: EXPECTING IFTRAK=0') + ALLOCATE(INCONV(NGEFF)) + INCONV(:NGEFF)=.TRUE. + MAXIT=20 + CALL PNFLV(KPSYS,INCONV,NGIND,IPTRK,IMPX,MAXIT,NGEFF, + > NREG,NMAT,NUN,MAT,VOL,KEYFLX,FUNKNO2,SUNKNO2) + DEALLOCATE(INCONV) + ENDIF + ELSE IF(CDOOR.EQ.'TRIVAC') THEN + IF(IDIR.NE.0) CALL XABORT('DOORFV: EXPECTING IDIR=0') + IF(IFTRAK.NE.0) CALL XABORT('DOORFV: EXPECTING IFTRAK=0') + ALLOCATE(INCONV(NGEFF)) + INCONV(:NGEFF)=.TRUE. + MAXIT=20 + CALL TRIFLV(KPSYS,INCONV,NGIND,IPTRK,IMPX,MAXIT,NGEFF,NREG, + > NUN,KEYFLX,FUNKNO2,SUNKNO2) + DEALLOCATE(INCONV) + ELSE IF(CDOOR.EQ.'SN') THEN + CALL SNF(KPSYS,IPTRK,IFTRAK,IMPX,NGEFF,NGIND,IDIR,NREG, + > NMAT,NUN,MAT,VOL,KEYFLX,FUNKNO2,SUNKNO2,TITR,NBS2, + > KPSOU1,KPSOU2,FLUXC,EVALRHO) + ELSE IF(CDOOR.EQ.'MCCG') THEN + CALL MCCGF(KPSYS,IPTRK,IFTRAK,IPMACR,IMPX,NGRP,NGEFF,NGIND, + > IDIR,NREG,NMAT,NUN,LEXAC,MAT,VOL,KEYFLX,FUNKNO2, + > SUNKNO2,TITR,REBFLG) + ENDIF + ELSE IF(IPHASE.EQ.2) THEN + CALL TRFICF(KPSYS,IFTRAK,IMPX,NGEFF,NGIND,IDIR,NREG,NUN,MAT, + > VOL,KEYFLX,FUNKNO2,SUNKNO2,TITR) + ENDIF +*---- +* DOUBLE HETEROGENEITY TREATMENT +*---- + IF(LBIHET) THEN + NMAT=NMATG + NREG=NREGG + DO II=1,NGEFF + SUNKNO2(:NUN,II)=SUNKN(:NUN,II) + CALL DOORFB3(JPSYS(II),IPTRK,IMPX,NMAT,NREG,NUN,KEYFLX, + 1 SUNKNO2(1,II),FUNKNO2(1,II)) + ENDDO + ENDIF + DEALLOCATE(SUNKN) +* + IF(IMPX.GT.3) THEN + ALLOCATE(FGAR(NREG)) + DO II=1,NGEFF + FGAR(:NREG)=0.0 + DO I=1,NREG + IF(KEYFLX(I).NE.0) FGAR(I)=FUNKNO(KEYFLX(I),II) + ENDDO + IF(IMPX.GT.4) THEN + WRITE(IUNOUT,'(/31H U N K N O W N F L U X E S (,I5, + 1 3H ):,6X,A9)') NGIND(II),CNFDIR(IDIR) + WRITE(IUNOUT,300) (FUNKNO2(I,II),I=1,NUN) + ELSE + WRITE(IUNOUT,'(/31H N E U T R O N F L U X E S (,I5, + 1 3H ):,6X,A9)') NGIND(II),CNFDIR(IDIR) + WRITE(IUNOUT,300) (FGAR(I),I=1,NREG) + ENDIF + ENDDO + DEALLOCATE(FGAR) + ENDIF +*---- +* SCATTER NEW FLUXES +*---- + DO JJ=1,NGEFF + FUNKNO(:NUN,NGIND(JJ))=FUNKNO2(:NUN,JJ) + ENDDO + IF((NGEFF.GT.1).AND.(NGEFF.LT.NGRP)) DEALLOCATE(FUNKNO2,SUNKNO2) + DEALLOCATE(KPSYS,JPSYS,NGIND,NBS) + RETURN + 300 FORMAT(1P,6(5X,E15.7)) + END diff --git a/Dragon/src/DOORPV.f b/Dragon/src/DOORPV.f new file mode 100644 index 0000000..b44360f --- /dev/null +++ b/Dragon/src/DOORPV.f @@ -0,0 +1,342 @@ +*DECK DOORPV + SUBROUTINE DOORPV (CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IMPX,NGRP,NREG, + 1 NBMIX,NANI,MAT,VOL,KNORM,IPIJK,LEAKSW,ITPIJ,LNORM,TITR,NALBP) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the collision probabilities. Vectorial version. +* +*Copyright: +* Copyright (C) 2004 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* CDOOR name of the geometry/solution operator. +* JPSYS pointer to the PIJ LCM object (L_PIJ signature). JPSYS is +* a list of directories. +* NPSYS index array pointing to the JPSYS list component corresponding +* to each energy group. Set to zero if a group is not to be +* processed. Usually, NPSYS(I)=I. +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK unit of the sequential binary tracking file. +* IMPX print flag (equal to zero for no print). +* NGRP number of energy groups. +* NREG total number of merged blocks for which specific values +* of the neutron flux and reactions rates are required. +* NBMIX number of mixtures (NBMIX=max(MAT(i))). +* NANI number of Legendre orders (usually equal to one). +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KNORM normalization scheme for PIJ matrices. +* IPIJK pij option (=1 pij, =4 pijk). +* LEAKSW leakage flag (=.true. if neutron leakage through external +* boundary is present). +* ITPIJ type of collision probability information available: +* =1 scattering modified pij (wij); +* =2 standard pij; +* =3 scattering modified pij+pijk (wij,wijk); +* =4 standard pij+pijk. +* LNORM logical switch for removing leakage from collision +* probabilities and keeping the PIS information. +* TITR title. +* NALBP number of physical albedos. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER CDOOR*12,TITR*72 + LOGICAL LEAKSW,LNORM + TYPE(C_PTR) JPSYS,IPTRK + INTEGER NPSYS(NGRP),IFTRAK,IMPX,NGRP,NREG,NBMIX,NANI,MAT(NREG), + > KNORM,IPIJK,ITPIJ,NALBP + REAL VOL(NREG) + INTEGER NNPSYS(1) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40,IOUT=6) + CHARACTER CMS(3)*1 + INTEGER ISTATE(NSTATE) + LOGICAL LBIHET + TYPE(C_PTR) KPSYS + INTEGER, ALLOCATABLE, DIMENSION(:) :: MAT2 + TYPE(C_PTR) :: PREG_PTR +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MATALB + REAL, ALLOCATABLE, DIMENSION(:) :: VOL2,PGAR,SGAR,SGAS,PROBKS, + > PIS + REAL, ALLOCATABLE, DIMENSION(:,:) :: PGARG,ALBP + REAL, POINTER, DIMENSION(:,:) :: PREG + REAL, ALLOCATABLE, DIMENSION(:,:) :: VOLSUR + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: DPROB,DPROBX +*---- +* DATA STATEMENT AND INLINE FUNCTION +*---- + SAVE CMS + DATA CMS/'1','2','3'/ + INDPOS(I,J)=MAX(I,J)*(MAX(I,J)-1)/2+MIN(I,J) +*---- +* DOUBLE HETEROGENEITY TREATMENT +*---- + NNPSYS(1)=1 + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + IF(ISTATE(1).NE.NREG) CALL XABORT('DOORPV: WRONG VALUE OF NREG.') + NSOUT=ISTATE(5) + LBIHET=ISTATE(40).NE.0 + NREGAR=0 + NBMIXG=0 + IF(LBIHET) THEN + ALLOCATE(MAT2(NREG),VOL2(NREG)) + DO I=1,NREG + MAT2(I)=MAT(I) + VOL2(I)=VOL(I) + ENDDO + NREGAR=NREG + NBMIXG=NBMIX + CALL DOORAB(CDOOR,JPSYS,NPSYS,IPTRK,IMPX,NGRP,NREG,NBMIX,NANI, + 1 MAT,VOL) + ENDIF +* + NELPIJ=NREG*(NREG+1)/2 + NB1=NBMIX+1 + IF(CDOOR.EQ.'EXCELL') THEN + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + INSB=ISTATE(22) +* recover the number of tracks dispached in eack OpenMP core + NBATCH=ISTATE(27) + IF(NBATCH.EQ.0) NBATCH=1 + IF((INSB.GE.1).AND.(ISTATE(7).NE.5)) GO TO 110 + ELSE + NBATCH=1 + ENDIF +*---- +* COMPUTE THE REDUCED PIJ MATRIX -- NON-VECTORIAL ALGORITHM. +*---- + ALLOCATE(PGAR(IPIJK*NELPIJ),SGAR(NB1),SGAS(NB1*NANI)) + ALLOCATE(ALBP(NALBP,1)) + DO 100 IGR=1,NGRP + IOFSET=NPSYS(IGR) + IF(IOFSET.NE.0) THEN + IF(IMPX.GT.10) WRITE(IOUT,'(/25H DOORPV: PROCESSING GROUP,I5, + > 6H WITH ,A,1H.)') IGR,CDOOR + KPSYS=LCMGIL(JPSYS,IOFSET) + IF(LBIHET) CALL LCMSIX(KPSYS,'BIHET',1) + CALL LCMGET(KPSYS,'DRAGON-TXSC',SGAR) + CALL LCMLEN(KPSYS,'DRAGON-S0XSC',ILONG,ITYLCM) + IF(ILONG.GT.NB1*NANI) CALL XABORT('DOORPV: S0XSC OVERFLOW(1).') + IF(MOD(ITPIJ,2).EQ.1) THEN + CALL LCMGET(KPSYS,'DRAGON-S0XSC',SGAS) + ELSE + ! avoid scattering reduction + SGAS(:NB1*NANI)=0.0 + ENDIF + IF(NALBP.GT.0) CALL LCMGET(KPSYS,'ALBEDO',ALBP) + IF((CDOOR.EQ.'EXCELL').AND.(ISTATE(7).EQ.5)) THEN + ! MULTICELL SURFACIC APPROXIMATION + IF(ISTATE(10).NE.0) CALL XABORT('DOORPV: TISO EXPECTED.') + CALL MUSP(IPTRK,IFTRAK,IMPX,NREG,NBMIX,MAT,VOL,SGAR,SGAS, + > NELPIJ,LEAKSW,NBATCH,TITR,NALBP,ALBP,PGAR) + ELSE IF(CDOOR.EQ.'EXCELL') THEN + IF(IPIJK.EQ.4) THEN + NNREG=NREG*NREG + NPST=3*NNREG + ALLOCATE(PROBKS(NPST)) + ELSE + NPST=1 + ENDIF + IF(IFTRAK .NE. 0) REWIND IFTRAK + N2PRO= (NREG+NSOUT+1)**2 + ALLOCATE(MATALB(-NSOUT:NREG),VOLSUR(-NSOUT:NREG,1), + > DPROB(N2PRO,1),DPROBX(N2PRO,1)) + CALL EXCELP(IPTRK,IFTRAK,IMPX,NSOUT,NREG,NBMIX,MAT,KNORM,SGAR, + > IPIJK,N2PRO,1,NNPSYS(1),NBATCH,TITR,NALBP,ALBP,MATALB,VOLSUR, + > DPROB,DPROBX) + CALL PIJWIJ(IPTRK,IMPX,NSOUT,NREG,NBMIX,NANI,MAT,VOL,SGAR, + > SGAS,NELPIJ,IPIJK,LEAKSW,N2PRO,1,NNPSYS(1),NPST,NALBP,ALBP, + > MATALB,VOLSUR,DPROB,DPROBX,PGAR(1),PROBKS) + DEALLOCATE(DPROBX,DPROB,VOLSUR,MATALB) + IF(IPIJK.EQ.4) THEN + CALL LCMPUT(KPSYS,'DRAGON1P*SCT',NNREG,2,PROBKS) + CALL LCMPUT(KPSYS,'DRAGON2P*SCT',NNREG,2,PROBKS(NNREG+1)) + CALL LCMPUT(KPSYS,'DRAGON3P*SCT',NNREG,2,PROBKS(2*NNREG+1)) + DEALLOCATE(PROBKS) + ENDIF + ELSE IF(CDOOR(:5).EQ.'SYBIL') THEN + CALL SYBILP(IPTRK,IMPX,NREG,NBMIX,MAT,VOL,SGAR,SGAS,NELPIJ, + > PGAR,LEAKSW) + ELSE + CALL XABORT('DOORPV: UNKNOWN PIJ DOOR NAMED '//CDOOR//'.') + ENDIF +*---- +* REMOVE LEAKAGE FROM THE SCATTERING-REDUCED CP MATRIX. +*---- + IF(LNORM) THEN + ALLOCATE(PIS(NREG)) + CALL XDRNRM(NREG,NBMIX,MAT,VOL,SGAR(2),SGAS(2),PGAR(1),PIS) + IF(LEAKSW) CALL LCMPUT(KPSYS,'DRAGON-WIS',NREG,2,PIS) + DEALLOCATE(PIS) + ENDIF +*---- +* FORMAT THE REDUCED PIJ MATRIX AS A SQUARE MATRIX. +*---- + PREG_PTR=LCMARA(NREG*NREG) + CALL C_F_POINTER(PREG_PTR,PREG,(/ NREG,NREG /)) + DO 15 I=1,NREG + FACT=1.0/VOL(I) + DO 10 J=1,NREG + PREG(I,J)=PGAR(INDPOS(I,J))*FACT + 10 CONTINUE + 15 CONTINUE + CALL LCMPPD(KPSYS,'DRAGON-PCSCT',NREG*NREG,2,PREG_PTR) + IF(IPIJK.EQ.4) THEN + DO 30 IJKS=1,3 + PREG_PTR=LCMARA(NREG*NREG) + CALL C_F_POINTER(PREG_PTR,PREG,(/ NREG,NREG /)) + DO 25 I=1,NREG + FACT=1.0/VOL(I) + DO 20 J=1,NREG + KS=NELPIJ*IJKS+INDPOS(I,J) + PREG(I,J)=PGAR(KS)*FACT + 20 CONTINUE + 25 CONTINUE + CALL LCMPPD(KPSYS,'DRAGON'//CMS(IJKS)//'PCSCT',NREG*NREG,2, + > PREG_PTR) + 30 CONTINUE + ENDIF + IF(LBIHET) CALL LCMSIX(KPSYS,' ',2) + ENDIF + 100 CONTINUE + DEALLOCATE(ALBP,SGAS,SGAR,PGAR) + GO TO 210 +*---- +* COMPUTE THE REDUCED PIJ MATRIX -- VECTORIAL ALGORITHM FOR EXCELP. +*---- + 110 ALLOCATE(SGAR(NB1*NGRP),SGAS(NB1*NANI*NGRP)) + ALLOCATE(ALBP(NALBP,NGRP)) + DO 120 IGR=1,NGRP + IOFSET=NPSYS(IGR) + IF(IOFSET.NE.0) THEN + KPSYS=LCMGIL(JPSYS,IOFSET) + IF(LBIHET) CALL LCMSIX(KPSYS,'BIHET',1) + CALL LCMGET(KPSYS,'DRAGON-TXSC',SGAR((IGR-1)*NB1+1)) + CALL LCMLEN(KPSYS,'DRAGON-S0XSC',ILONG,ITYLCM) + IF(ILONG.GT.NB1*NANI) CALL XABORT('DOORPV: S0XSC OVERFLOW(2).') + IF(MOD(ITPIJ,2).EQ.1) THEN + CALL LCMGET(KPSYS,'DRAGON-S0XSC',SGAS((IGR-1)*NB1*NANI+1)) + ELSE + ! avoid scattering reduction + SGAS((IGR-1)*NB1*NANI+1:IGR*NB1*NANI)=0.0 + ENDIF + IF(NALBP.GT.0) CALL LCMGET(KPSYS,'ALBEDO',ALBP(1,IGR)) + IF(LBIHET) CALL LCMSIX(KPSYS,' ',2) + ENDIF + 120 CONTINUE + ALLOCATE(PGARG(IPIJK*NELPIJ,NGRP)) + IF((ISTATE(7).EQ.4).OR.(INSB.EQ.1)) THEN +* --- ALLG VECTORIZATION + IF(IPIJK.EQ.4) THEN + NNREG=NREG*NREG + NPST=3*NNREG + ALLOCATE(PROBKS(NPST*NGRP)) + ELSE + NPST=1 + ENDIF + IF(IFTRAK .NE. 0) REWIND IFTRAK + N2PRO= (NREG+NSOUT+1)**2 + ALLOCATE(MATALB(-NSOUT:NREG),VOLSUR(-NSOUT:NREG,NGRP), + > DPROB(N2PRO,NGRP),DPROBX(N2PRO,NGRP)) + CALL EXCELP(IPTRK,IFTRAK,IMPX,NSOUT,NREG,NBMIX,MAT,KNORM,SGAR, + > IPIJK,N2PRO,NGRP,NPSYS(1),NBATCH,TITR,NALBP,ALBP,MATALB,VOLSUR, + > DPROB,DPROBX) + CALL PIJWIJ(IPTRK,IMPX,NSOUT,NREG,NBMIX,NANI,MAT,VOL,SGAR,SGAS, + > NELPIJ,IPIJK,LEAKSW,N2PRO,NGRP,NPSYS(1),NPST,NALBP,ALBP,MATALB, + > VOLSUR,DPROB,DPROBX,PGARG(1,1),PROBKS) + DEALLOCATE(DPROBX,DPROB,VOLSUR,MATALB) + ELSE IF(INSB.EQ.2) THEN +* --- XCLL VECTORIZATION + IF(IPIJK.NE.1) CALL XABORT('DOORPV: INVALID VALUE OF IPIJK') + CALL PIJXL3(IPTRK,IMPX,NGRP,NANI,NBMIX,NPSYS,KNORM,LEAKSW, + > SGAR,SGAS,NELPIJ,PGARG) + ELSE + CALL XABORT('DOORPV: INVALID VALUE OF INSB') + ENDIF + KPST=0 + DO 200 IGR=1,NGRP + IOFSET=NPSYS(IGR) + IF(IOFSET.NE.0) THEN + KPSYS=LCMGIL(JPSYS,IOFSET) + IF(LBIHET) CALL LCMSIX(KPSYS,'BIHET',1) + IF(IPIJK.EQ.4) THEN + CALL LCMPUT(KPSYS,'DRAGON1P*SCT',NNREG,2,PROBKS(KPST+1)) + CALL LCMPUT(KPSYS,'DRAGON2P*SCT',NNREG,2,PROBKS(KPST+NNREG+1)) + CALL LCMPUT(KPSYS,'DRAGON3P*SCT',NNREG,2, + > PROBKS(KPST+2*NNREG+1)) + ENDIF +*---- +* REMOVE LEAKAGE FROM THE SCATTERING-REDUCED CP MATRIX. +*---- + IF(LNORM) THEN + ALLOCATE(PIS(NREG)) + CALL XDRNRM(NREG,NBMIX,MAT,VOL,SGAR((IGR-1)*NB1+2), + > SGAS((IGR-1)*NB1*NANI+2),PGARG(1,IGR),PIS) + IF(LEAKSW) CALL LCMPUT(KPSYS,'DRAGON-WIS',NREG,2,PIS) + DEALLOCATE(PIS) + ENDIF +*---- +* FORMAT THE REDUCED PIJ MATRIX AS A SQUARE MATRIX. +*---- + PREG_PTR=LCMARA(NREG*NREG) + CALL C_F_POINTER(PREG_PTR,PREG,(/ NREG,NREG /)) + DO 135 I=1,NREG + FACT=1.0/VOL(I) + DO 130 J=1,NREG + PREG(I,J)=PGARG(INDPOS(I,J),IGR)*FACT + 130 CONTINUE + 135 CONTINUE + CALL LCMPPD(KPSYS,'DRAGON-PCSCT',NREG*NREG,2,PREG_PTR) + IF(IPIJK.EQ.4) THEN + DO 150 IJKS=1,3 + PREG_PTR=LCMARA(NREG*NREG) + CALL C_F_POINTER(PREG_PTR,PREG,(/ NREG,NREG /)) + DO 145 I=1,NREG + FACT=1.0/VOL(I) + DO 140 J=1,NREG + KS=NELPIJ*IJKS+INDPOS(I,J) + PREG(I,J)=PGARG(KS,IGR)*FACT + 140 CONTINUE + 145 CONTINUE + CALL LCMPPD(KPSYS,'DRAGON'//CMS(IJKS)//'PCSCT',NREG*NREG,2, + > PREG_PTR) + 150 CONTINUE + ENDIF + IF(LBIHET) CALL LCMSIX(KPSYS,' ',2) + ENDIF + KPST=KPST+NPST + 200 CONTINUE + IF(IPIJK.EQ.4) DEALLOCATE(PROBKS) + DEALLOCATE(ALBP,SGAS,SGAR,PGARG) +*---- +* DOUBLE HETEROGENEITY TREATMENT +*---- + 210 IF(LBIHET) THEN + NREG=NREGAR + NBMIX=NBMIXG + DO I=1,NREG + MAT(I)=MAT2(I) + VOL(I)=VOL2(I) + ENDDO + DEALLOCATE(MAT2,VOL2) + ENDIF + RETURN + END diff --git a/Dragon/src/DOORS_BIV.f90 b/Dragon/src/DOORS_BIV.f90 new file mode 100644 index 0000000..de7c050 --- /dev/null +++ b/Dragon/src/DOORS_BIV.f90 @@ -0,0 +1,626 @@ +SUBROUTINE DOORS_BIV(IPTRK,NANIS,NREG,NMAT,NUN,MATCOD,VOL,SIGG,SUNKNO,FUNKNO) + ! + !----------------------------------------------------------------------- + ! + !Purpose: + ! Compute the source for the solution of diffusion or PN equations. + ! Use a BIVAC tracking. + ! + !Copyright: + ! Copyright (C) 2025 Ecole Polytechnique de Montreal + ! This library is free software; you can redistribute it and/or + ! modify it under the terms of the GNU Lesser General Public + ! License as published by the Free Software Foundation; either + ! version 2.1 of the License, or (at your option) any later version + ! + !Author(s): A. Hebert + ! + !Parameters: input + ! IPTRK pointer to the tracking LCM object. + ! NANIS maximum cross section Legendre order (=0: isotropic). + ! NREG number of regions. + ! NMAT number of mixtures. + ! NUN number of unknowns per energy group including net current. + ! MATCOD mixture indices. + ! VOL volumes. Volumes are included in SUNKNO. + ! SIGG cross section. + ! FUNKNO optional unknown vector. If not present, a flat flux + ! approximation is assumed. + ! + !Parameters: input/output + ! SUNKNO integrated sources. + ! + !----------------------------------------------------------------------- + ! + USE GANLIB + !---- + ! SUBROUTINE ARGUMENTS + !---- + TYPE(C_PTR) IPTRK + INTEGER NANIS,NREG,NMAT,NUN,MATCOD(NREG) + REAL VOL(NREG),SIGG(0:NMAT,NANIS+1),SUNKNO(NUN) + REAL, OPTIONAL :: FUNKNO(NUN) + !---- + ! LOCAL VARIABLES + !---- + PARAMETER(NSTATE=40) + INTEGER JPAR(NSTATE) + !---- + ! RECOVER BIVAC SPECIFIC PARAMETERS. + !---- + CALL LCMGET(IPTRK,'STATE-VECTOR',JPAR) + IF(JPAR(1).NE.NREG) CALL XABORT('DOORS_BIV: INCONSISTENT NREG.') + IF(JPAR(2).NE.NUN) CALL XABORT('DOORS_BIV: INCONSISTENT NUN.') + ITYPE=JPAR(6) + IELEM=JPAR(8) + ICOL=JPAR(9) + NLF=JPAR(14) + IF((ITYPE.EQ.2).OR.(ITYPE.EQ.5)) THEN + ! Cartesian 1D or 2D geometry + IF((IELEM.GT.0).AND.(ICOL.LE.3)) THEN + ! Raviart-Thomas / diffusion or SPN + CALL DOORS_BIVGSO(IPTRK,NANIS,NREG,NMAT,NUN,MATCOD,VOL,SIGG,SUNKNO,FUNKNO) + ELSE IF((IELEM.LT.0).AND.(NLF.EQ.0)) THEN + ! Lagrange / diffusion + CALL DOORS_BIVFSO(IPTRK,NREG,NMAT,NUN,MATCOD,VOL,SIGG,SUNKNO,FUNKNO) + ELSE + CALL XABORT('DOORS_BIV: DISCRETIZATION TYPE NOT AVAILABLE(1).') + ENDIF + ELSE IF(ITYPE.EQ.8) THEN + ! Hexagonal 2D geometry + IF((IELEM.GT.0).AND.(ICOL.LE.3)) THEN + ! Raviart-Thomas / diffusion or SPN + CALL DOORS_BIVGSO(IPTRK,NANIS,NREG,NMAT,NUN,MATCOD,VOL,SIGG,SUNKNO,FUNKNO) + ELSE IF((IELEM.LT.0).AND.(NLF.EQ.0)) THEN + ! Lagrange / diffusion + CALL DOORS_BIVFSH(IPTRK,NREG,NMAT,NUN,MATCOD,VOL,SIGG,SUNKNO,FUNKNO) + ELSE + CALL XABORT('DOORS_BIV: DISCRETIZATION TYPE NOT AVAILABLE(2).') + ENDIF + ELSE + CALL XABORT('DOORS_BIV: GEOMETRY TYPE NOT AVAILABLE.') + ENDIF + RETURN +CONTAINS + SUBROUTINE DOORS_BIVFSO(IPTRK,NREG,NMAT,NUN,MATCOD,VOL,SIGG,SUNKNO,FUNKNO) + ! + !----------------------------------------------------------------------- + ! + !Purpose: + ! Source term calculation for finite element or mesh corner finite + ! differences in Cartesian geometry. + ! + !----------------------------------------------------------------------- + ! + USE GANLIB + !---- + ! SUBROUTINE ARGUMENTS + !---- + TYPE(C_PTR) IPTRK + INTEGER NREG,NMAT,NUN,MATCOD(NREG) + REAL VOL(NREG),SIGG(0:NMAT),SUNKNO(NUN) + REAL, OPTIONAL :: FUNKNO(NUN) + !---- + ! LOCAL VARIABLES + !---- + PARAMETER(NSTATE=40) + INTEGER JPAR(NSTATE),IJ1(25),IJ2(25) + LOGICAL CYLIND + !---- + ! ALLOCATABLE ARRAYS + !---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KN,IDL + REAL, ALLOCATABLE, DIMENSION(:) :: XX,DD,T,TS + REAL, ALLOCATABLE, DIMENSION(:,:) :: R,RS + !---- + ! RECOVER BIVAC SPECIFIC PARAMETERS. + !---- + CALL LCMGET(IPTRK,'STATE-VECTOR',JPAR) + ITYPE=JPAR(6) + IELEM=JPAR(8) + ICOL=JPAR(9) + L4=JPAR(11) + LX=JPAR(12) + NLF=JPAR(14) + ISPN=JPAR(15) + ISCAT=JPAR(16) + CYLIND=(ITYPE.EQ.3).OR.(ITYPE.EQ.6) + IF(IELEM.GT.0) CALL XABORT('DOORS_BIVFSO: LAGRANGE METHOD EXPECTED.') + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMLEN(IPTRK,'T',LC,ITYLCM) + ALLOCATE(R(LC,LC),RS(LC,LC),T(LC),TS(LC)) + CALL LCMGET(IPTRK,'R',R) + CALL LCMGET(IPTRK,'RS',RS) + CALL LCMGET(IPTRK,'T',T) + CALL LCMGET(IPTRK,'TS',TS) + CALL LCMSIX(IPTRK,' ',2) + ! + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + ALLOCATE(XX(NREG),DD(NREG),KN(MAXKN),IDL(NREG)) + CALL LCMGET(IPTRK,'XX',XX) + CALL LCMGET(IPTRK,'DD',DD) + CALL LCMGET(IPTRK,'KN',KN) + CALL LCMGET(IPTRK,'KEYFLX',IDL) + !---- + ! COMPUTE VECTORS IJ1 AND IJ2 + !---- + LL=LC*LC + DO I=1,LL + IJ1(I)=1+MOD(I-1,LC) + IJ2(I)=1+(I-IJ1(I))/LC + ENDDO + !---- + ! COMPUTE THE SOURCE + !---- + IF(PRESENT(FUNKNO)) THEN + NUM1=0 + DO K=1,NREG + IBM=MATCOD(K) + IF(IBM.LE.0) CYCLE + IF(VOL(K).EQ.0.0) GO TO 10 + DO I=1,LL + IND1=KN(NUM1+I) + IF(IND1.EQ.0) CYCLE + I1=IJ1(I) + I2=IJ2(I) + DO J=1,LL + IND2=KN(NUM1+J) + IF(IND2.EQ.0) CYCLE + IF(CYLIND) THEN + RR=(R(I1,IJ1(J))+RS(I1,IJ1(J))*XX(K)/DD(K))*R(I2,IJ2(J))*VOL(K) + ELSE + RR=R(I1,IJ1(J))*R(I2,IJ2(J))*VOL(K) + ENDIF + SUNKNO(IND1)=SUNKNO(IND1)+RR*FUNKNO(IND2)*SIGG(IBM) + ENDDO ! J + ENDDO ! I + 10 NUM1=NUM1+LL + ENDDO ! K + ELSE + ! Assume a flat flux + NUM1=0 + DO K=1,NREG + IBM=MATCOD(K) + IF(IBM.LE.0) CYCLE + IF(VOL(K).EQ.0.0) GO TO 20 + DO I=1,LL + IND1=KN(NUM1+I) + IF(IND1.EQ.0) CYCLE + IF(CYLIND) THEN + SS=(T(IJ1(I))+TS(IJ1(I))*XX(K)/DD(K))*T(IJ2(I))*VOL(K) + ELSE + SS=T(IJ1(I))*T(IJ2(I))*VOL(K) + ENDIF + SUNKNO(IND1)=SUNKNO(IND1)+SS*SIGG(IBM) + ENDDO ! I + 20 NUM1=NUM1+LL + ENDDO ! K + ENDIF + !---- + ! APPEND THE INTEGRATED VOLUMIC SOURCES + !---- + IF(PRESENT(FUNKNO)) THEN + NUM1=0 + DO K=1,NREG + IBM=MATCOD(K) + IF(IBM.LE.0) CYCLE + SUNKNO(IDL(K))=SUNKNO(IDL(K))+FUNKNO(IDL(K))*VOL(K)*SIGG(IBM) + ENDDO + ELSE + ! Assume a flat flux + NUM1=0 + DO K=1,NREG + IBM=MATCOD(K) + IF(IBM.LE.0) CYCLE + SUNKNO(IDL(K))=SUNKNO(IDL(K))+VOL(K)*SIGG(IBM) + ENDDO + ENDIF + DEALLOCATE(IDL,KN,DD,XX) + DEALLOCATE(TS,T,RS,R) + RETURN + END SUBROUTINE DOORS_BIVFSO + ! + SUBROUTINE DOORS_BIVGSO(IPTRK,NANIS,NREG,NMAT,NUN,MATCOD,VOL,SIGG,SUNKNO,FUNKNO) + ! + !----------------------------------------------------------------------- + ! + !Purpose: + ! Source term calculation for a mixed-dual formulation of the finite + ! element technique in a 2-D Cartesian geometry. + ! + !----------------------------------------------------------------------- + ! + USE GANLIB + !---- + ! SUBROUTINE ARGUMENTS + !---- + TYPE(C_PTR) IPTRK + INTEGER NANIS,NREG,NMAT,NUN,MATCOD(NREG) + REAL VOL(NREG),SIGG(0:NMAT,NANIS+1),SUNKNO(NUN) + REAL, OPTIONAL :: FUNKNO(NUN) + !---- + ! LOCAL VARIABLES + !---- + PARAMETER(NSTATE=40) + INTEGER JPAR(NSTATE) + LOGICAL LHEX + !---- + ! ALLOCATABLE ARRAYS + !---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KN,IPERT + REAL, ALLOCATABLE, DIMENSION(:,:) :: RR + !---- + ! RECOVER BIVAC SPECIFIC PARAMETERS. + !---- + CALL LCMGET(IPTRK,'STATE-VECTOR',JPAR) + ITYPE=JPAR(6) + IELEM=JPAR(8) + ICOL=JPAR(9) + L4=JPAR(11) + LX=JPAR(12) + NLF=JPAR(14) + ISPN=JPAR(15) + ISCAT=JPAR(16) + LHEX=(ITYPE.EQ.8) + IF((IELEM.LT.0).OR.(ICOL.GT.3)) CALL XABORT('DOORS_BIVGSO: RAVIA' & + & //'RT-THOMAS METHOD EXPECTED.') + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + ALLOCATE(KN(MAXKN)) + CALL LCMGET(IPTRK,'KN',KN) + NBLOS=0 + SIDE=0.0 + IF(LHEX) THEN + ! Raviart-Thomas-Schneider method + NBLOS=LX/3 + ALLOCATE(IPERT(NBLOS)) + CALL LCMGET(IPTRK,'IPERT',IPERT) + CALL LCMGET(IPTRK,'SIDE',SIDE) + ENDIF + !---- + ! RECOVER THE FINITE ELEMENT UNIT STIFFNESS MATRIX. + !---- + IF(NLF.GT.0) THEN + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMLEN(IPTRK,'T',LC,ITYLCM) + ALLOCATE(RR(LC,LC)) + CALL LCMGET(IPTRK,'R',RR) + CALL LCMSIX(IPTRK,' ',2) + ENDIF + !---- + ! COMPUTE THE SOURCE + !---- + IF(NLF.EQ.0) THEN + !---- + ! CARTESIAN 2D DUAL (RAVIART-THOMAS) CASE. + !---- + IF(PRESENT(FUNKNO).AND.(.NOT.LHEX)) THEN + NUM1=0 + DO IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) CYCLE + IF(VOL(IR).EQ.0.0) GO TO 10 + DO I0=1,IELEM*IELEM + IND=KN(NUM1+1)+I0-1 + SUNKNO(IND)=SUNKNO(IND)+FUNKNO(IND)*VOL(IR)*SIGG(IBM,1) + ENDDO ! I0 + 10 NUM1=NUM1+5 + ENDDO ! IR + ELSE IF(PRESENT(FUNKNO).AND.LHEX) THEN + TTTT=0.5*SQRT(3.0)*SIDE*SIDE + NUM1=0 + DO KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) CYCLE + NUM1=NUM1+1 + IBM=MATCOD((IPERT(KEL)*3-1)+1) + IF(IBM.LE.0) CYCLE + GARS=SIGG(IBM,1) + DO K2=0,IELEM-1 + DO K1=0,IELEM-1 + JND1=KN(NUM1)+K2*IELEM+K1 + JND2=KN(NBLOS+NUM1)+K2*IELEM+K1 + JND3=KN(2*NBLOS+NUM1)+K2*IELEM+K1 + SUNKNO(JND1)=SUNKNO(JND1)+FUNKNO(JND1)*TTTT*GARS + SUNKNO(JND2)=SUNKNO(JND2)+FUNKNO(JND2)*TTTT*GARS + SUNKNO(JND3)=SUNKNO(JND3)+FUNKNO(JND3)*TTTT*GARS + ENDDO ! K1 + ENDDO ! K2 + ENDDO ! KEL + ELSE IF((.NOT.PRESENT(FUNKNO)).AND.(.NOT.LHEX)) THEN + ! a flat flux is assumed + NUM1=0 + DO IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) CYCLE + IF(VOL(IR).EQ.0.0) GO TO 20 + IND=KN(NUM1+1) + SUNKNO(IND)=SUNKNO(IND)+VOL(IR)*SIGG(IBM,1) + 20 NUM1=NUM1+5 + ENDDO ! IR + ELSE IF((.NOT.PRESENT(FUNKNO)).AND.LHEX) THEN + ! a flat flux is assumed + TTTT=0.5*SQRT(3.0)*SIDE*SIDE + NUM1=0 + DO KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) CYCLE + NUM1=NUM1+1 + IBM=MATCOD((IPERT(KEL)*3-1)+1) + IF(IBM.LE.0) CYCLE + JND1=KN(NUM1) + JND2=KN(NBLOS+NUM1) + JND3=KN(2*NBLOS+NUM1) + SUNKNO(JND1)=SUNKNO(JND1)+TTTT*SIGG(IBM,1) + SUNKNO(JND2)=SUNKNO(JND2)+TTTT*SIGG(IBM,1) + SUNKNO(JND3)=SUNKNO(JND3)+TTTT*SIGG(IBM,1) + ENDDO ! KEL + ENDIF + ELSE + !---- + ! CARTESIAN 2D SPN CASE. + !---- + DO IL=0,MIN(ABS(ISCAT)-1,NANIS) + FACT=REAL(2*IL+1) + IF(PRESENT(FUNKNO)) THEN + NUM1=0 + DO IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) CYCLE + IF(VOL(IR).EQ.0.0) GO TO 70 + IF(MOD(IL,2).EQ.0) THEN + DO I0=1,IELEM*IELEM + IND=(IL/2)*L4+KN(NUM1+1)+I0-1 + SUNKNO(IND)=SUNKNO(IND)+FACT*FUNKNO(IND)*VOL(IR)*SIGG(IBM,IL+1) + ENDDO ! I0 + ELSE + DO I0=1,IELEM + DO 40 IC=1,2 + IIC=1+(IC-1)*IELEM + IND1=(IL/2)*L4+ABS(KN(NUM1+1+IC))+I0-1 + S1=REAL(SIGN(1,KN(NUM1+1+IC))) + DO 30 JC=1,2 + JJC=1+(JC-1)*IELEM + IND2=(IL/2)*L4+ABS(KN(NUM1+1+JC))+I0-1 + IF((KN(NUM1+1+IC).NE.0).AND.(KN(NUM1+1+JC).NE.0)) THEN + S2=REAL(SIGN(1,KN(NUM1+1+JC))) + AUXX=S1*S2*FACT*RR(IIC,JJC)*VOL(IR) + SUNKNO(IND1)=SUNKNO(IND1)-AUXX*FUNKNO(IND2)*SIGG(IBM,IL+1) + ENDIF + 30 CONTINUE + 40 CONTINUE + DO 60 IC=3,4 + IIC=1+(IC-3)*IELEM + IND1=(IL/2)*L4+ABS(KN(NUM1+1+IC))+I0-1 + S1=REAL(SIGN(1,KN(NUM1+1+IC))) + DO 50 JC=3,4 + JJC=1+(JC-3)*IELEM + IND2=(IL/2)*L4+ABS(KN(NUM1+1+JC))+I0-1 + IF((KN(NUM1+1+IC).NE.0).AND.(KN(NUM1+1+JC).NE.0)) THEN + S2=REAL(SIGN(1,KN(NUM1+1+JC))) + AUXX=S1*S2*FACT*RR(IIC,JJC)*VOL(IR) + SUNKNO(IND1)=SUNKNO(IND1)-AUXX*FUNKNO(IND2)*SIGG(IBM,IL+1) + ENDIF + 50 CONTINUE + 60 CONTINUE + ENDDO ! I0 + ENDIF + 70 NUM1=NUM1+5 + ENDDO ! IR + ELSE + ! a flat flux is assumed + NUM1=0 + DO IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) CYCLE + IF(VOL(IR).EQ.0.0) GO TO 120 + IF(MOD(IL,2).EQ.0) THEN + IND=(IL/2)*L4+KN(NUM1+1) + SUNKNO(IND)=SUNKNO(IND)+FACT*VOL(IR)*SIGG(IBM,IL+1) + ELSE + DO 90 IC=1,2 + IIC=1+(IC-1)*IELEM + IND1=(IL/2)*L4+ABS(KN(NUM1+1+IC)) + S1=REAL(SIGN(1,KN(NUM1+1+IC))) + DO 80 JC=1,2 + JJC=1+(JC-1)*IELEM + IND2=(IL/2)*L4+ABS(KN(NUM1+1+JC)) + IF((KN(NUM1+1+IC).NE.0).AND.(KN(NUM1+1+JC).NE.0)) THEN + S2=REAL(SIGN(1,KN(NUM1+1+JC))) + AUXX=S1*S2*FACT*RR(IIC,JJC)*VOL(IR) + SUNKNO(IND1)=SUNKNO(IND1)-AUXX*SIGG(IBM,IL+1) + ENDIF + 80 CONTINUE + 90 CONTINUE + DO 110 IC=3,4 + IIC=1+(IC-3)*IELEM + IND1=(IL/2)*L4+ABS(KN(NUM1+1+IC)) + S1=REAL(SIGN(1,KN(NUM1+1+IC))) + DO 100 JC=3,4 + JJC=1+(JC-3)*IELEM + IND2=(IL/2)*L4+ABS(KN(NUM1+1+JC)) + IF((KN(NUM1+1+IC).NE.0).AND.(KN(NUM1+1+JC).NE.0)) THEN + S2=REAL(SIGN(1,KN(NUM1+1+JC))) + AUXX=S1*S2*FACT*RR(IIC,JJC)*VOL(IR) + SUNKNO(IND1)=SUNKNO(IND1)-AUXX*SIGG(IBM,IL+1) + ENDIF + 100 CONTINUE + 110 CONTINUE + ENDIF + 120 NUM1=NUM1+5 + ENDDO ! IR + ENDIF + ENDDO ! IL + ENDIF + IF(LHEX) DEALLOCATE(IPERT) + IF(NLF.GT.0) DEALLOCATE(RR) + DEALLOCATE(KN) + RETURN + END SUBROUTINE DOORS_BIVGSO + ! + SUBROUTINE DOORS_BIVFSH(IPTRK,NREG,NMAT,NUN,MATCOD,VOL,SIGG,SUNKNO,FUNKNO) + ! + !----------------------------------------------------------------------- + ! + !Purpose: + ! Source term calculation for finite element or mesh corner finite + ! differences in hexagonal geometry. + ! + !----------------------------------------------------------------------- + ! + USE GANLIB + !---- + ! SUBROUTINE ARGUMENTS + !---- + TYPE(C_PTR) IPTRK + INTEGER NREG,NMAT,NUN,MATCOD(NREG) + REAL VOL(NREG),SIGG(0:NMAT),SUNKNO(NUN) + REAL, OPTIONAL :: FUNKNO(NUN) + !---- + ! LOCAL VARIABLES + !---- + PARAMETER(NSTATE=40) + INTEGER JPAR(NSTATE) + INTEGER ISR(6,2),ISRH(6,2),ISRT(3,2) + REAL TH(6),RH2(6,6),RH(6,6),RT(3,3) + !---- + ! ALLOCATABLE ARRAYS + !---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KN,IDL + REAL, ALLOCATABLE, DIMENSION(:) :: QFR + !---- + ! DATA STATEMENTS + !---- + DATA ISRH/2,1,4,5,6,3,1,4,5,6,3,2/ + DATA ISRT/1,2,3,2,3,1/ + !---- + ! RECOVER BIVAC SPECIFIC PARAMETERS. + !---- + CALL LCMGET(IPTRK,'STATE-VECTOR',JPAR) + ITYPE=JPAR(6) + IELEM=JPAR(8) + ISPLH=JPAR(10) + L4=JPAR(11) + LX=JPAR(12) + NLF=JPAR(14) + ISPN=JPAR(15) + ISCAT=JPAR(16) + IF(ISPLH.EQ.1) THEN + NELEM=MAXKN/7 + ELSE + NELEM=MAXKN/4 + ENDIF + IF(IELEM.GT.0) CALL XABORT('DOORS_BIVFSH: LAGRANGE METHOD EXPECTED.') + IF(NLF.GT.0) CALL XABORT('DOORS_BIVFSH: SPN NOT IMPLEMENTED.') + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMGET(IPTRK,'RH',RH) + CALL LCMGET(IPTRK,'RT',RT) + CALL LCMSIX(IPTRK,' ',2) + ! + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + CALL LCMLEN(IPTRK,'QFR',MAXQF,ITYLCM) + ALLOCATE(KN(MAXKN),QFR(MAXQF),IDL(NREG)) + CALL LCMGET(IPTRK,'KN',KN) + CALL LCMGET(IPTRK,'QFR',QFR) + CALL LCMGET(IPTRK,'KEYFLX',IDL) + CALL LCMGET(IPTRK,'SIDE',SIDE) + IF(ISPLH.EQ.1) THEN + NELEM=MAXKN/7 + ELSE + NELEM=MAXKN/4 + ENDIF + !---- + ! RECOVER THE HEXAGONAL MASS (RH2) MATRICES. + !---- + IF(ISPLH.EQ.1) THEN + ! hexagonal basis + LH=6 + DO I=1,6 + DO J=1,2 + ISR(I,J)=ISRH(I,J) + ENDDO ! J + ENDDO ! I + DO I=1,6 + TH(I)=0.0 + DO J=1,6 + RH2(I,J)=RH(I,J) + TH(I)=TH(I)+RH(I,J) + ENDDO ! J + ENDDO ! I + CONST=1.5*SQRT(3.0) + AA=SIDE + ELSE + ! triangular basis + LH=3 + DO I=1,3 + DO J=1,2 + ISR(I,J)=ISRT(I,J) + ENDDO ! J + ENDDO ! I + DO I=1,3 + TH(I)=0.0 + DO J=1,3 + RH2(I,J)=RT(I,J) + TH(I)=TH(I)+RT(I,J) + ENDDO ! J + ENDDO ! I + CONST=0.25*SQRT(3.0) + AA=SIDE/REAL(ISPLH-1) + ENDIF + !---- + ! COMPUTE THE SOURCE + !---- + IF(PRESENT(FUNKNO)) THEN + NUM1=0 + DO K=1,NELEM + KHEX=KN(NUM1+LH+1) + IF(VOL(KHEX).EQ.0.0) GO TO 10 + IBM=MATCOD(KHEX) + VOL0=QFR(NUM1+LH+1) + GARS=SIGG(IBM) + DO I=1,LH + IND1=KN(NUM1+I) + IF(IND1.EQ.0) CYCLE + DO J=1,LH + IND2=KN(NUM1+J) + IF(IND2.EQ.0) CYCLE + SUNKNO(IND1)=SUNKNO(IND1)+RH2(I,J)*FUNKNO(IND2)*VOL0*GARS + ENDDO ! J + ENDDO ! I + 10 NUM1=NUM1+LH+1 + ENDDO ! K + ELSE + ! Assume a flat flux + NUM1=0 + DO K=1,NELEM + KHEX=KN(NUM1+LH+1) + IF(VOL(KHEX).EQ.0.0) GO TO 20 + IBM=MATCOD(KHEX) + VOL0=QFR(NUM1+LH+1) + DO I=1,LH + IND1=KN(NUM1+I) + IF(IND1.NE.0) SUNKNO(IND1)=SUNKNO(IND1)+TH(I)*VOL0*SIGG(IBM) + ENDDO ! I + 20 NUM1=NUM1+LH+1 + ENDDO ! K + ENDIF + !---- + ! APPEND THE INTEGRATED VOLUMIC SOURCES + !---- + IF(PRESENT(FUNKNO)) THEN + NUM1=0 + DO K=1,NREG + IBM=MATCOD(K) + IF(IBM.LE.0) CYCLE + SUNKNO(IDL(K))=SUNKNO(IDL(K))+FUNKNO(IDL(K))*VOL(K)*SIGG(IBM) + ENDDO + ELSE + ! Assume a flat flux + NUM1=0 + DO K=1,NREG + IBM=MATCOD(K) + IF(IBM.LE.0) CYCLE + SUNKNO(IDL(K))=SUNKNO(IDL(K))+VOL(K)*SIGG(IBM) + ENDDO + ENDIF + DEALLOCATE(IDL,QFR,KN) + RETURN + END SUBROUTINE DOORS_BIVFSH +END SUBROUTINE DOORS_BIV diff --git a/Dragon/src/DOORS_MOD.f90 b/Dragon/src/DOORS_MOD.f90 new file mode 100644 index 0000000..9538892 --- /dev/null +++ b/Dragon/src/DOORS_MOD.f90 @@ -0,0 +1,162 @@ +MODULE DOORS_MOD + USE GANLIB +CONTAINS + SUBROUTINE DOORS(CDOOR,IPTRK,NMAT,NANIS,NUN,SIGG,SUNKNO,FUNKNO) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! compute the product of a cross section times a flux unknow vector. + ! + !Copyright: + ! Copyright (C) 2025 Ecole Polytechnique de Montreal + ! This library is free software; you can redistribute it and/or + ! modify it under the terms of the GNU Lesser General Public + ! License as published by the Free Software Foundation; either + ! version 2.1 of the License, or (at your option) any later version + ! + !Author(s): A. Hebert + ! + !Parameters: input + ! CDOOR name of the geometry/solution operator. + ! IPTRK pointer to the tracking (L_TRACK signature). + ! NMAT number of mixtures in the macrolib. + ! NANIS number of Legendre components in the macrolib (=0: isotropic). + ! NUN total number of unknowns in vectors SUNKNO and FUNKNO. + ! SIGG cross section. + ! FUNKNO optional unknown vector. If not present, a flat flux + ! approximation is assumed. + ! + !Parameters: output + ! SUNKNO source vector. Volumes are included with BIVAC and TRIVAC + ! trackings. + ! + !--------------------------------------------------------------------- + ! + !---- + ! SUBROUTINE ARGUMENTS + !---- + CHARACTER(LEN=12), INTENT(IN) :: CDOOR + TYPE(C_PTR), INTENT(IN) :: IPTRK + INTEGER, INTENT(IN) :: NMAT,NANIS,NUN + REAL, DIMENSION(0:NMAT,NANIS+1), INTENT(IN) :: SIGG + REAL, DIMENSION(NUN), INTENT(IN), OPTIONAL :: FUNKNO + REAL, DIMENSION(NUN), INTENT(INOUT) :: SUNKNO + !---- + ! LOCAL VARIABLES + !---- + INTEGER, PARAMETER :: NSTATE=40 + INTEGER, DIMENSION(NSTATE) :: ISTATE + !---- + ! ALLOCATABLE ARRAYS + !---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MATCOD + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: KEYFLX + REAL, ALLOCATABLE, DIMENSION(:) :: VOL + !---- + ! RECOVER TRACKING PARAMETERS + ! NFUNL: number of spherical harmonics components used to expand the + ! flux and the sources. + ! NANIS_TRK: number of components in the angular expansion of the flux + !---- + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + NREG=ISTATE(1) + IF(ISTATE(2).GT.NUN) CALL XABORT('DOORS: WRONG NUN.') + IF(ISTATE(4).GT.NMAT) CALL XABORT('DOORS: WRONG NMAT.') + NDIM=0 + NLIN=1 + NFUNL=1 + NANIS_TRK=1 + IF(CDOOR.EQ.'MCCG') THEN + NANIS_TRK=ISTATE(6) + NDIM=ISTATE(16) + CALL LCMGET(IPTRK,'MCCG-STATE',ISTATE) + NFUNL=ISTATE(19) + NLIN=ISTATE(20) + ELSE IF(CDOOR.EQ.'SN') THEN + NFUNL=ISTATE(7) + NLIN=ISTATE(8) + NDIM=ISTATE(9) + NLIN=NLIN**NDIM + NLIN=NLIN*ISTATE(35) + NANIS_TRK=ISTATE(16) + ELSE IF(CDOOR.EQ.'BIVAC') THEN + NLIN=ABS(ISTATE(8)) ! order of finite elements + NFUNL=MAX(1,ISTATE(14)) + NANIS_TRK=ABS(ISTATE(16)) + ELSE IF(CDOOR.EQ.'TRIVAC') THEN + NLIN=ABS(ISTATE(9)) ! order of finite elements + NLFUNL=MAX(1,ISTATE(30)) + NANIS_TRK=ABS(ISTATE(32)) + ENDIF + ALLOCATE(MATCOD(NREG),VOL(NREG),KEYFLX(NREG,NLIN,NFUNL)) + KEYFLX(:NREG,:NLIN,:NFUNL)=0 + CALL LCMLEN(IPTRK,'MATCOD',ILNLCM,ITYLCM) + IF(ILNLCM.NE.NREG) CALL XABORT('DOORS: INCOMPATIBLE NUMBER OF REGIONS.') + CALL LCMGET(IPTRK,'MATCOD',MATCOD) + CALL LCMGET(IPTRK,'VOLUME',VOL) + IF((CDOOR.EQ.'MCCG').OR.(CDOOR.EQ.'SN')) THEN + CALL LCMGET(IPTRK,'KEYFLX$ANIS',KEYFLX) + ELSE + CALL LCMGET(IPTRK,'KEYFLX',KEYFLX) + ENDIF + !---- + ! PERFORM SIGG*FUNKNO MULTIPLICATION + !---- + IF(CDOOR.EQ.'SN') THEN + CALL DOORS_SN(IPTRK,NANIS,NREG,NMAT,NUN,MATCOD,SIGG,SUNKNO,FUNKNO) + ELSE IF(CDOOR.EQ.'BIVAC') THEN + CALL DOORS_BIV(IPTRK,NANIS,NREG,NMAT,NUN,MATCOD,VOL,SIGG,SUNKNO,FUNKNO) + ELSE IF(CDOOR.EQ.'TRIVAC') THEN + CALL DOORS_TRI(IPTRK,NANIS,NREG,NMAT,NUN,MATCOD,VOL,SIGG,SUNKNO,FUNKNO) + ELSE IF(PRESENT(FUNKNO)) THEN + ! general case + IF((NANIS.EQ.0).OR.(NFUNL.EQ.1).OR.(NANIS_TRK.EQ.1)) THEN + ! LAB isotropy or transport correction + DO IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) CYCLE + DO IE=1,NLIN + IND=KEYFLX(IR,IE,1) + SUNKNO(IND)=SUNKNO(IND)+SIGG(IBM,1)*FUNKNO(IND) + ENDDO + ENDDO ! IR + ELSE + ! spherical harmonics expansion of the flux and source + DO IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) CYCLE + DO IAL=0,MIN(NFUNL-1,NANIS,NANIS_TRK-1) + FACT=REAL(2*IAL+1) + DO IAM=0,MIN(NFUNL-1,NANIS,NANIS_TRK-1) + DO IE=1,NLIN + IND=0 + IF(NDIM.EQ.3) THEN + IND=KEYFLX(IR,IE,1+IAL*NANIS_TRK+IAM) + ELSE IF((NDIM.EQ.2).AND.(IAM.LE.IAL)) THEN + IND=KEYFLX(IR,IE,1+IAL*(IAL+1)/2+IAM) + ELSE IF(IAM.EQ.IAL) THEN + IND=KEYFLX(IR,IE,1+IAL) + ENDIF + IF(IND.EQ.0) THEN + CYCLE + ELSE IF(IND.GT.NUN) THEN + CALL XABORT('DOORS: NUN OVERFLOW.') + ENDIF + SUNKNO(IND)=SUNKNO(IND)+FACT*SIGG(IBM,IAL+1)*FUNKNO(IND) + ENDDO ! IE + ENDDO ! IAM + ENDDO ! IAL + ENDDO ! IR + ENDIF + ELSE + ! general case (flat flux) + DO IR=1,NREG + IND=KEYFLX(IR,1,1) + SUNKNO(IND)=SUNKNO(IND)+SIGG(MATCOD(IR),1) + ENDDO + ENDIF + DEALLOCATE(KEYFLX,VOL,MATCOD) + END SUBROUTINE DOORS +END MODULE DOORS_MOD + diff --git a/Dragon/src/DOORS_SN.f90 b/Dragon/src/DOORS_SN.f90 new file mode 100644 index 0000000..666094b --- /dev/null +++ b/Dragon/src/DOORS_SN.f90 @@ -0,0 +1,175 @@ +SUBROUTINE DOORS_SN(IPTRK,NANIS,NREG,NMAT,NUN,MATCOD,SIGG,SUNKNO,FUNKNO) + ! + !----------------------------------------------------------------------- + ! + !Purpose: + ! Compute the source for the solution of SN equations. + ! + !Copyright: + ! Copyright (C) 2025 Ecole Polytechnique de Montreal + ! This library is free software; you can redistribute it and/or + ! modify it under the terms of the GNU Lesser General Public + ! License as published by the Free Software Foundation; either + ! version 2.1 of the License, or (at your option) any later version + ! + !Author(s): A. Hebert and C. Bienvenue + ! + !Parameters: input + ! IPTRK pointer to the tracking LCM object. + ! NANIS maximum cross section Legendre order (=0: isotropic). + ! NREG number of regions. + ! NMAT number of mixtures. + ! NUN number of unknowns per energy group including spherical + ! harmonic terms and boundary SN fluxes. + ! MATCOD mixture indices. + ! SIGG cross section. + ! FUNKNO optional unknown vector. If not present, a flat flux + ! approximation is assumed. + ! + !Parameters: output + ! SUNKNO sources. + ! + !----------------------------------------------------------------------- + ! + USE GANLIB + !---- + ! SUBROUTINE ARGUMENTS + !---- + TYPE(C_PTR) IPTRK + INTEGER NANIS,NREG,NMAT,NUN,MATCOD(NREG) + REAL SIGG(0:NMAT,NANIS+1),SUNKNO(NUN) + REAL, OPTIONAL :: FUNKNO(NUN) + !---- + ! LOCAL VARIABLES + !---- + PARAMETER(NSTATE=40) + INTEGER JPAR(NSTATE),P,P2,ILP + !---- + ! ALLOCATABLE ARRAYS + !---- + TYPE(C_PTR) IL_PTR,IM_PTR + INTEGER, POINTER, DIMENSION(:) :: IL,IM + !---- + ! RECOVER SNT SPECIFIC PARAMETERS. + !---- + CALL LCMGET(IPTRK,'STATE-VECTOR',JPAR) + IF(JPAR(1).NE.NREG) CALL XABORT('DOORS_SN: INCONSISTENT NREG.') + IF(JPAR(2).NE.NUN) CALL XABORT('DOORS_SN: INCONSISTENT NUN.') + ITYPE=JPAR(6) + NSCT=JPAR(7) + IELEM=JPAR(8) + ISCAT=JPAR(16) + CALL LCMGPD(IPTRK,'IL',IL_PTR) + CALL LCMGPD(IPTRK,'IM',IM_PTR) + CALL C_F_POINTER(IL_PTR,IL,(/ NSCT /)) + CALL C_F_POINTER(IM_PTR,IM,(/ NSCT /)) + !---- + ! CONSTRUCT THE SOURCE. LOOP OVER LEGENDRE ORDERS. + !---- + IOF0=0 + DO P=1,NSCT + ILP=IL(P) + IF(ILP.GT.MIN(ISCAT-1,NANIS)) CYCLE + IF((ITYPE.EQ.2).OR.(ITYPE.EQ.4)) THEN + !---- + ! SLAB OR SPHERICAL 1D CASE. + !---- + IF(PRESENT(FUNKNO)) THEN + DO IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) CYCLE + DO IEL=1,IELEM + IND=(IR-1)*NSCT*IELEM+IELEM*(P-1)+IEL + SUNKNO(IND)=SUNKNO(IND)+FUNKNO(IND)*SIGG(IBM,ILP+1) + ENDDO ! IEL + ENDDO ! IR + ELSE + ! a flat flux is assumed + DO IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) CYCLE + IND=(IR-1)*NSCT*IELEM+IELEM*(P-1)+1 + SUNKNO(IND)=SUNKNO(IND)+SIGG(IBM,ILP+1) + ENDDO ! IR + ENDIF + ELSE IF(ITYPE.EQ.3) THEN + !---- + ! CYLINDRICAL 1D CASE. + !---- + IF(PRESENT(FUNKNO)) THEN + DO P2=0,P-1 + IF(MOD((P-1)+P2,2).EQ.1) CYCLE + IOF0=IOF0+1 + DO IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) CYCLE + IND=(IR-1)*NSCT+IOF0 + SUNKNO(IND)=SUNKNO(IND)+FUNKNO(IND)*SIGG(IBM,ILP+1) + ENDDO ! IR + ENDDO ! P2 + ELSE + ! a flat flux is assumed + DO P2=0,P-1 + IF(MOD((P-1)+P2,2).EQ.1) CYCLE + IOF0=IOF0+1 + DO IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) CYCLE + IND=(IR-1)*NSCT+IOF0 + SUNKNO(IND)=SUNKNO(IND)+SIGG(IBM,ILP+1) + ENDDO ! IR + ENDDO ! P2 + ENDIF + ELSE IF((ITYPE.EQ.5).OR.(ITYPE.EQ.6).OR.(ITYPE.EQ.8)) THEN + !---- + ! 2D CASES (CARTESIAN OR R-Z). + !---- + NM=IELEM**2 + IF(PRESENT(FUNKNO)) THEN + DO IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) CYCLE + DO IEL=1,NM + IND=(IR-1)*NSCT*NM+(P-1)*NM+IEL + SUNKNO(IND)=SUNKNO(IND)+FUNKNO(IND)*SIGG(IBM,ILP+1) + ENDDO ! IEL + ENDDO ! IR + ELSE + ! a flat flux is assumed + DO IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) CYCLE + IND=(IR-1)*NSCT*NM+(P-1)*NM+1 + SUNKNO(IND)=SUNKNO(IND)+SIGG(IBM,ILP+1) + ENDDO ! IR + ENDIF + ! a flat flux is assumed + ELSE IF((ITYPE.EQ.7).OR.(ITYPE.EQ.9)) THEN + !---- + ! 3D CARTESIAN CASE + !---- + NM=IELEM**3 + IF(PRESENT(FUNKNO)) THEN + DO IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) CYCLE + DO IEL=1,NM + IND=(IR-1)*NSCT*NM+(P-1)*NM+IEL + SUNKNO(IND)=SUNKNO(IND)+FUNKNO(IND)*SIGG(IBM,ILP+1) + ENDDO ! IEL + ENDDO ! IR + ELSE + ! a flat flux is assumed + DO IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) CYCLE + IND=(IR-1)*NSCT*NM+(P-1)*NM+1 + SUNKNO(IND)=SUNKNO(IND)+SIGG(IBM,ILP+1) + ENDDO ! IR + ENDIF + ELSE + CALL XABORT('DOORS_SN: TYPE OF DISCRETIZATION NOT IMPLEMENTED.') + ENDIF + ENDDO ! P + RETURN +END SUBROUTINE DOORS_SN diff --git a/Dragon/src/DOORS_TRI.f90 b/Dragon/src/DOORS_TRI.f90 new file mode 100644 index 0000000..4c17ebd --- /dev/null +++ b/Dragon/src/DOORS_TRI.f90 @@ -0,0 +1,252 @@ +SUBROUTINE DOORS_TRI(IPTRK,NANIS,NREG,NMAT,NUN,MATCOD,VOL,SIGG,SUNKNO,FUNKNO) + ! + !----------------------------------------------------------------------- + ! + !Purpose: + ! Compute the source for the solution of diffusion or PN equations. + ! Use a TRIVAC tracking. + ! + !Copyright: + ! Copyright (C) 2025 Ecole Polytechnique de Montreal + ! This library is free software; you can redistribute it and/or + ! modify it under the terms of the GNU Lesser General Public + ! License as published by the Free Software Foundation; either + ! version 2.1 of the License, or (at your option) any later version + ! + !Author(s): A. Hebert + ! + !Parameters: input + ! IPTRK pointer to the tracking LCM object. + ! NANIS maximum cross section Legendre order (=0: isotropic). + ! NREG number of regions. + ! NMAT number of mixtures. + ! NUN number of unknowns per energy group including net current. + ! MATCOD mixture indices. + ! VOL volumes. Volumes are included in SUNKNO. + ! SIGG cross section. + ! FUNKNO optional unknown vector. If not present, a flat flux + ! approximation is assumed. + ! + !Parameters: input/output + ! SUNKNO integrated sources. + ! + !----------------------------------------------------------------------- + ! + USE GANLIB + !---- + ! SUBROUTINE ARGUMENTS + !---- + TYPE(C_PTR) IPTRK + INTEGER NANIS,NREG,NMAT,NUN,MATCOD(NREG) + REAL VOL(NREG),SIGG(0:NMAT,NANIS+1),SUNKNO(NUN) + REAL, OPTIONAL :: FUNKNO(NUN) + !---- + ! LOCAL VARIABLES + !---- + PARAMETER(NSTATE=40) + INTEGER JPAR(NSTATE) + !---- + ! RECOVER BIVAC SPECIFIC PARAMETERS. + !---- + CALL LCMGET(IPTRK,'STATE-VECTOR',JPAR) + IF(JPAR(1).NE.NREG) CALL XABORT('DOORS_TRI: INCONSISTENT NREG.') + IF(JPAR(2).NE.NUN) CALL XABORT('DOORS_TRI: INCONSISTENT NUN.') + IF(NANIS.NE.0) CALL XABORT('DOORS_TRI: SPN NOT IMPLEMENTED.') + ITYPE=JPAR(6) + IF((ITYPE.EQ.2).OR.(ITYPE.EQ.5).OR.(ITYPE.EQ.7)) THEN + ! Cartesian 1D, 2D or 3D geometry + CALL DOORS_TRIGSO(IPTRK,NREG,NMAT,NUN,MATCOD,VOL,SIGG,SUNKNO,FUNKNO) + ELSE IF((ITYPE.EQ.8).OR.(ITYPE.EQ.9)) THEN + ! Hexagonal 2D or 3D geometry + CALL DOORS_TRIGSR(IPTRK,NREG,NMAT,NUN,MATCOD,SIGG,SUNKNO,FUNKNO) + ELSE + CALL XABORT('DOORS_TRI: GEOMETRY TYPE NOT AVAILABLE.') + ENDIF + RETURN +CONTAINS + SUBROUTINE DOORS_TRIGSO(IPTRK,NREG,NMAT,NUN,MATCOD,VOL,SIGG,SUNKNO,FUNKNO) + ! + !----------------------------------------------------------------------- + ! + !Purpose: + ! Source term calculation for a mixed-dual formulation of the finite + ! element technique in a 3-D Cartesian geometry. + ! + !----------------------------------------------------------------------- + ! + USE GANLIB + !---- + ! SUBROUTINE ARGUMENTS + !---- + TYPE(C_PTR) IPTRK + INTEGER NREG,NMAT,NUN,MATCOD(NREG) + REAL VOL(NREG),SIGG(0:NMAT),SUNKNO(NUN) + REAL, OPTIONAL :: FUNKNO(NUN) + !---- + ! LOCAL VARIABLES + !---- + PARAMETER(NSTATE=40) + INTEGER IPAR(NSTATE) + CHARACTER HSMG*131 + !---- + ! ALLOCATABLE ARRAYS + !---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KN + !---- + ! RECOVER TRIVAC SPECIFIC PARAMETERS. + !---- + CALL LCMGET(IPTRK,'STATE-VECTOR',IPAR) + ITYPE=IPAR(6) + IELEM=IPAR(9) + ICOL=IPAR(10) + LX=IPAR(14) + LY=IPAR(15) + LZ=IPAR(16) + ISCAT=IPAR(32) + IF((ITYPE.NE.2).AND.(ITYPE.NE.5).AND.(ITYPE.NE.7)) THEN + CALL XABORT('DOORS_TRIGSO: INVALID CARTESIAN GEOMETRY.') + ELSE IF((IELEM.LT.0).OR.(ICOL.GT.3)) THEN + CALL XABORT('DOORS_TRIGSO: RAVIART-THOMAS METHOD EXPECTED.') + ELSE IF(ISCAT.GT.1) THEN + WRITE(HSMG,'(56HDOORS_TRIGSO: MACRO-CALCULATION WITH ANISOTROPIC SCATTER, & + & 66HING CURRENTLY NOT IMPLEMENTED; USE SCAT 1 KEYWORD IN TRIVAT: DATA.)') + CALL XABORT(HSMG) + ELSE IF(LX*LY*LZ.NE.NREG) THEN + CALL XABORT('DOORS_TRIGSO: INVALID NREG.') + ENDIF + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + ALLOCATE(KN(MAXKN)) + CALL LCMGET(IPTRK,'KN',KN) + IF(PRESENT(FUNKNO)) THEN + NUM1=0 + DO K=1,NREG + L=MATCOD(K) + IF(L.LE.0) CYCLE + IF(VOL(K).EQ.0.0) GO TO 10 + GARS=SIGG(L) + DO I0=1,IELEM**3 + IND1=KN(NUM1+1)+I0-1 + SUNKNO(IND1)=SUNKNO(IND1)+FUNKNO(IND1)*VOL(K)*GARS + ENDDO ! I0 + 10 NUM1=NUM1+1+6*IELEM**2 + ENDDO ! K + ELSE + ! a flat flux is assumed + NUM1=0 + DO K=1,NREG + L=MATCOD(K) + IF(L.LE.0) CYCLE + IF(VOL(K).EQ.0.0) GO TO 20 + IND1=KN(NUM1+1) + SUNKNO(IND1)=SUNKNO(IND1)+VOL(K)*SIGG(L) + 20 NUM1=NUM1+1+6*IELEM**2 + ENDDO ! K + ENDIF + DEALLOCATE(KN) + RETURN + END SUBROUTINE DOORS_TRIGSO + ! + SUBROUTINE DOORS_TRIGSR(IPTRK,NREG,NMAT,NUN,MATCOD,SIGG,SUNKNO,FUNKNO) + ! + !----------------------------------------------------------------------- + ! + !Purpose: + ! Source term calculation for a Thomas-Raviart-Schneider formulation of + ! the finite element technique in a 3-D hexagonal geometry. + ! + !----------------------------------------------------------------------- + ! + USE GANLIB + !---- + ! SUBROUTINE ARGUMENTS + !---- + TYPE(C_PTR) IPTRK + INTEGER NREG,NMAT,NUN,MATCOD(3,NREG/3) + REAL SIGG(0:NMAT),SUNKNO(NUN) + REAL, OPTIONAL :: FUNKNO(NUN) + !---- + ! LOCAL VARIABLES + !---- + PARAMETER(NSTATE=40) + INTEGER IPAR(NSTATE) + CHARACTER HSMG*131 + !---- + ! ALLOCATABLE ARRAYS + !---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IPERT + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: KN + REAL, ALLOCATABLE, DIMENSION(:) :: FRZ + REAL, ALLOCATABLE, DIMENSION(:,:) :: ZZ + !---- + ! RECOVER TRIVAC SPECIFIC PARAMETERS. + !---- + CALL LCMGET(IPTRK,'STATE-VECTOR',IPAR) + ITYPE=IPAR(6) + IELEM=IPAR(9) + ICOL=IPAR(10) + LX=IPAR(14) + LZ=IPAR(16) + ISCAT=IPAR(32) + NBLOS=LX*LZ/3 + IF((ITYPE.NE.8).AND.(ITYPE.NE.9)) THEN + CALL XABORT('DOORS_TRIGSR: INVALID HEXAGONAL GEOMETRY.') + ELSE IF((IELEM.LT.0).OR.(ICOL.GT.3)) THEN + CALL XABORT('DOORS_TRIGSR: RAVIART-THOMAS METHOD EXPECTED.') + ELSE IF(ISCAT.GT.1) THEN + WRITE(HSMG,'(56HDOORS_TRIGSR: MACRO-CALCULATION WITH ANISOTROPIC SCATTER, & + & 66HING CURRENTLY NOT IMPLEMENTED; USE SCAT 1 KEYWORD IN TRIVAT: DATA.)') + CALL XABORT(HSMG) + ELSE IF(3*NBLOS.NE.NREG) THEN + CALL XABORT('DOORS_TRIGSR: INVALID NREG.') + ENDIF + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + ALLOCATE(ZZ(3,NBLOS),KN(NBLOS,MAXKN/NBLOS),IPERT(NBLOS),FRZ(NBLOS)) + CALL LCMGET(IPTRK,'SIDE',SIDE) + CALL LCMGET(IPTRK,'ZZ',ZZ) + CALL LCMGET(IPTRK,'KN',KN) + CALL LCMGET(IPTRK,'IPERT',IPERT) + CALL LCMGET(IPTRK,'FRZ',FRZ) + NELEM=IELEM*(IELEM+1) + TTTT=0.5*SQRT(3.0)*SIDE*SIDE + IF(PRESENT(FUNKNO)) THEN + NUM=0 + DO KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) CYCLE + NUM=NUM+1 + L=MATCOD(1,IPERT(KEL)) + IF(L.EQ.0) CYCLE + VOL0=TTTT*ZZ(1,IPERT(KEL))*FRZ(KEL) + GARS=SIGG(L) + DO K3=0,IELEM-1 + DO K2=0,IELEM-1 + DO K1=0,IELEM-1 + JND1=(NUM-1)*IELEM**3+K3*IELEM**2+K2*IELEM+K1+1 + JND2=(KN(NUM,1)-1)*IELEM**3+K3*IELEM**2+K2*IELEM+K1+1 + JND3=(KN(NUM,2)-1)*IELEM**3+K3*IELEM**2+K2*IELEM+K1+1 + SUNKNO(JND1)=SUNKNO(JND1)+FUNKNO(JND1)*VOL0*GARS + SUNKNO(JND2)=SUNKNO(JND2)+FUNKNO(JND2)*VOL0*GARS + SUNKNO(JND3)=SUNKNO(JND3)+FUNKNO(JND3)*VOL0*GARS + ENDDO ! K1 + ENDDO ! K2 + ENDDO ! K3 + ENDDO ! KEL + ELSE + ! a flat flux is assumed + NUM=0 + DO KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) CYCLE + NUM=NUM+1 + L=MATCOD(1,IPERT(KEL)) + IF(L.EQ.0) CYCLE + VOL0=TTTT*ZZ(1,IPERT(KEL))*FRZ(KEL) + JND1=(NUM-1)*IELEM**3+1 + JND2=(KN(NUM,1)-1)*IELEM**3+1 + JND3=(KN(NUM,2)-1)*IELEM**3+1 + SUNKNO(JND1)=SUNKNO(JND1)+VOL0*SIGG(L) + SUNKNO(JND2)=SUNKNO(JND2)+VOL0*SIGG(L) + SUNKNO(JND3)=SUNKNO(JND3)+VOL0*SIGG(L) + ENDDO ! KEL + ENDIF + DEALLOCATE(FRZ,IPERT,KN,ZZ) + END SUBROUTINE DOORS_TRIGSR +END SUBROUTINE DOORS_TRI diff --git a/Dragon/src/DRAGON.f90 b/Dragon/src/DRAGON.f90 new file mode 100644 index 0000000..cfcda22 --- /dev/null +++ b/Dragon/src/DRAGON.f90 @@ -0,0 +1,98 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! DRAGON main program. +! +!Copyright: +! Copyright (C) 2009 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): A. Hebert +! +!----------------------------------------------------------------------- +! +program DRAGON + use GANLIB + implicit none + integer, parameter :: iout=6 + character(len=131) :: hsmg +!---- +! local storage +!---- + integer :: iprint,ier +!---- +! gan-2000 external functions +!---- + integer, external :: KERNEL + interface + integer(c_int) function dramod(cmodul, nentry, hentry, ientry, jentry, & + kentry, hparam_c) bind(c) + use, intrinsic :: iso_c_binding + character(kind=c_char), dimension(*) :: cmodul + integer(c_int), value :: nentry + character(kind=c_char), dimension(13,*) :: hentry + integer(c_int), dimension(nentry) :: ientry, jentry + type(c_ptr), dimension(nentry) :: kentry + character(kind=c_char), dimension(73,*) :: hparam_c + end function dramod + end interface +!---- +! variables for DRAGON version +!---- + integer :: imvers + character(len=64) :: date + character(len=48) :: rev + character(len=6), parameter :: namsbr='dragon' +!---- +! version information recovered from cvs +!---- + imvers=5 + call KDRVER(rev,date) + write(iout,6000) namsbr,imvers,rev,date + write(iout,6010) namsbr +!---- +! execute the cle-2000 driver +!---- + iprint=0 + ier=KERNEL(dramod,iprint) + if( ier /= 0 )then + write(hsmg,'(27hDRAGON: kernel error (code=,I5,2h).)') ier + call XABORT(hsmg) + endif +!---- +! all modules processed +!---- + write(iout,6030) namsbr,imvers,rev + stop +!---- +! formats +!---- + 6000 FORMAT( & + ' DDDDDD RRRRRR AAA GGGGG OOOOO NN NN'/ & + ' DDDDDDD RRRRRRR AAAAA GGGGGGG OOOOOOO NNN NN'/ & + ' DD DD RR RR AA AA GG OO OO NNNN NN'/ & + ' DD DD RRRRRR AA AA GG GGG OO OO NN NN NN'/ & + ' DD DD RRRR AAAAAAA GG GGG OO OO NN NN NN'/ & + ' DD DD RR RR AAAAAAA GG GG OO OO NN NNNN'/ & + ' DDDDDDD RR RR AA AA GGGGGGG OOOOOOO NN NNN'/ & + ' DDDDDD RR RR AA AA GGGGG OOOOO NN NN'// & + ' VERSION ',A6,I2,2X,A,4X,A/ & + ' GROUPE D''ANALYSE NUCLEAIRE'/ & + ' ECOLE POLYTECHNIQUE DE MONTREAL'///) + 6010 FORMAT( & + ' COPYRIGHT NOTICE FOR THIS VERSION OF ',A6,':'/ & + ' --------------------------------------------'/ & + ' Copyright (C) 2002 Ecole Polytechnique de Montreal '/ & + ' This library is free software; you can redistribute it' / & + ' and/or modify it under the terms of the GNU Lesser General' / & + ' Public License as published by the Free Software Foundation;' / & + ' either version 2.1 of the License, or (at your option) any' / & + ' later version '////) + 6030 FORMAT(/1x,'normal end of execution for ',a6,i2,2x,a/ & + 1x,'check for warning in listing'/ & + 1x,'before assuming your run was successful') +end program DRAGON diff --git a/Dragon/src/DUO.f b/Dragon/src/DUO.f new file mode 100644 index 0000000..41a3d5e --- /dev/null +++ b/Dragon/src/DUO.f @@ -0,0 +1,121 @@ +*DECK DUO + SUBROUTINE DUO(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perturbative analysis of two systems and determination of the origins +* of Keff discrepancies. +* +*Copyright: +* Copyright (C) 2013 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): read-only type(L_LIBRARY) first system; +* HENTRY(2): read-only type(L_LIBRARY) second system. +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + TYPE(C_PTR) IPLIB1,IPLIB2 + CHARACTER HSIGN*12,CARLIR*12 + INTEGER ISTATE(NSTATE) + REAL REALIR + DOUBLE PRECISION DBLLIR + LOGICAL LENER,LISOT,LMIXT,LREAC +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.NE.2) CALL XABORT('DUO: TWO PARAMETERS EXPECTED.') + DO IEN=1,2 + IF((IENTRY(IEN).NE.1).AND.(IENTRY(IEN).NE.2)) CALL XABORT('DUO' + 1 //': LCM OBJECT EXPECTED AT LHS.') + IF(JENTRY(IEN).NE.2) CALL XABORT('DUO: ENTRY IN READ-ONLY MODE' + 1 //' EXPECTED.') + CALL LCMGTC(KENTRY(IEN),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_LIBRARY') THEN + CARLIR=HENTRY(IEN) + CALL XABORT('DUO: SIGNATURE OF '//CARLIR//' IS '//HSIGN// + 1 '. L_LIBRARY EXPECTED.') + ENDIF + ENDDO + IPLIB1=KENTRY(1) + IPLIB2=KENTRY(2) + CALL LCMGET(IPLIB1,'STATE-VECTOR',ISTATE) + NG=ISTATE(3) + CALL LCMGET(IPLIB2,'STATE-VECTOR',ISTATE) + IF(ISTATE(3).NE.NG) CALL XABORT('DUO: INVALID NUMBER OF ENERGY G' + 1 //'ROUPS.') +*--- +* READ DATA +*--- + IPRINT=1 + LENER=.FALSE. + LISOT=.FALSE. + LMIXT=.FALSE. + LREAC=.FALSE. + 10 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.10) GO TO 100 + IF(ITYPLU.NE.3) CALL XABORT('DUO: READ ERROR - CHARACTER VARI' + > //'ABLE EXPECTED') + IF(CARLIR.EQ.';') THEN + GO TO 100 + ELSE IF(CARLIR.EQ.'EDIT') THEN + CALL REDGET(ITYPLU,IPRINT,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('DUO: READ ERROR - INTEGER VARI' + > //'ABLE EXPECTED') + ELSE IF(CARLIR.EQ.'ENERGY') THEN + LENER=.TRUE. + ELSE IF(CARLIR.EQ.'ISOTOPE') THEN + LISOT=.TRUE. + ELSE IF(CARLIR.EQ.'MIXTURE') THEN + LMIXT=.TRUE. + ELSE IF(CARLIR.EQ.'REAC') THEN + LREAC=.TRUE. + GO TO 100 + ELSE + CALL XABORT('DUO: ILLEGAL KEYWORD '//CARLIR) + ENDIF + GO TO 10 + 100 CALL LCMGET(IPLIB1,'STATE-VECTOR',ISTATE) + NMIX=ISTATE(1) + NISOT=ISTATE(2) + NGRP=ISTATE(3) + CALL LCMGET(IPLIB2,'STATE-VECTOR',ISTATE) + IF(ISTATE(1).NE.NMIX) CALL XABORT('DUO: THE TWO MICROLIBS HAVE A' + > //' DIFFERENT NUMBER OF MIXTURES.') + IF(ISTATE(2).NE.NISOT) CALL XABORT('DUO: THE TWO MICROLIBS HAVE ' + > //'A DIFFERENT NUMBER OF ISOTOPES.') + IF(ISTATE(3).NE.NGRP) CALL XABORT('DUO: THE TWO MICROLIBS HAVE A' + > //' DIFFERENT NUMBER OF GROUPS.') +* + CALL DUODRV(IPLIB1,IPLIB2,IPRINT,LENER,LISOT,LMIXT,LREAC,NMIX, + > NISOT,NGRP) + RETURN + END diff --git a/Dragon/src/DUO001.f b/Dragon/src/DUO001.f new file mode 100644 index 0000000..a85c393 --- /dev/null +++ b/Dragon/src/DUO001.f @@ -0,0 +1,174 @@ +*DECK DUO001 + SUBROUTINE DUO001(IPMAC,IPRINT,NMIX,NGRP,NFIS,IDIV,ZKEFF,RHS,LHS, + > FLUX,AFLUX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Processing one of the two macrolibs and return mixture-dependent +* RHS and LHS matrices. +* +*Copyright: +* Copyright (C) 2013 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMAC macrolib. +* IPRINT print parameter. +* NMIX number of mixtures. +* NGRP number of energy groups. +* NFIS number of fissile isotopes. +* IDIV type of divergence term processing (=0: no processing; +* =1: direct processing; =2: adjoint processing; +* =3: direct-adjoint processing). +* +*Parameters: output +* ZKEFF effective multiplication factor. +* RHS absorption macroscopic cross-section matrix. +* LHS production macroscopic cross-section matrix. +* FLUX integrated direct flux. +* AFLUX integrated adjoint flux. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMAC + INTEGER IPRINT,NMIX,NGRP,NFIS,IDIV + REAL ZKEFF,RHS(NGRP,NGRP,NMIX),LHS(NGRP,NGRP,NMIX), + > FLUX(NGRP,NMIX),AFLUX(NGRP,NMIX) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPMAC,KPMAC + DOUBLE PRECISION SUM +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) :: VOL,GAR,GAR2,DLK,ALK,V,W + REAL, ALLOCATABLE, DIMENSION(:,:) :: NUF + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: CHI +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IJJ(NMIX),NJJ(NMIX),IPOS(NMIX)) + ALLOCATE(VOL(NMIX),GAR(NMIX),CHI(NMIX,NFIS,NGRP),NUF(NMIX,NFIS), + > GAR2(NMIX*NGRP)) +*---- +* COMPUTE THE RHS AND LHS MATRICES +*---- + RHS(:NGRP,:NGRP,:NMIX)=0.0 + LHS(:NGRP,:NGRP,:NMIX)=0.0 + CALL LCMGET(IPMAC,'K-EFFECTIVE',ZKEFF) + IF(IPRINT.GT.1) WRITE(6,'(35H DUO001: EFFECTIVE MULTIPLICATION F, + > 6HACTOR=,1P,E12.5)') ZKEFF + CALL LCMGET(IPMAC,'VOLUME',VOL) + JPMAC=LCMGID(IPMAC,'GROUP') + DO IGR=1,NGRP + KPMAC=LCMGIL(JPMAC,IGR) + CALL LCMGET(KPMAC,'CHI',CHI(1,1,IGR)) + ENDDO + DO IGR=1,NGRP + KPMAC=LCMGIL(JPMAC,IGR) + CALL LCMGET(KPMAC,'FLUX-INTG',GAR) + DO IBM=1,NMIX + FLUX(IGR,IBM)=GAR(IBM)/VOL(IBM) + ENDDO + CALL LCMLEN(KPMAC,'NWAT0',ILONG,ITYLCM) + IF(ILONG.EQ.NMIX) THEN + CALL LCMGET(KPMAC,'NWAT0',GAR) + DO IBM=1,NMIX + AFLUX(IGR,IBM)=GAR(IBM) + ENDDO + ELSE + AFLUX(:NMIX,IBM)=1.0 + ENDIF + CALL LCMGET(KPMAC,'NTOT0',GAR) + CALL LCMGET(KPMAC,'SCAT00',GAR2) + CALL LCMGET(KPMAC,'NJJS00',NJJ) + CALL LCMGET(KPMAC,'IJJS00',IJJ) + CALL LCMGET(KPMAC,'IPOS00',IPOS) + DO IBM=1,NMIX + IPOSDE=IPOS(IBM) + DO JGR=IJJ(IBM),IJJ(IBM)-NJJ(IBM)+1,-1 + RHS(IGR,JGR,IBM)=RHS(IGR,JGR,IBM)-GAR2(IPOSDE) ! IGR <-- JGR + IPOSDE=IPOSDE+1 + ENDDO + RHS(IGR,IGR,IBM)=RHS(IGR,IGR,IBM)+GAR(IBM) + ENDDO + CALL LCMGET(KPMAC,'NUSIGF',NUF) + DO IBM=1,NMIX + DO IFIS=1,NFIS + DO JGR=1,NGRP + LHS(JGR,IGR,IBM)=LHS(JGR,IGR,IBM)+CHI(IBM,IFIS,JGR)* + > NUF(IBM,IFIS) + ENDDO + ENDDO + ENDDO + ENDDO +*---- +* INTRODUCE THE DIRECT OR ADJOINT DIVERGENCE COMPONENT IN THE RHS +* MATRIX +*---- + DO IBM=1,NMIX + IF(IDIV.EQ.1) THEN + DO JGR=1,NGRP + SUM=0.0D0 + DO IGR=1,NGRP + SUM=SUM+(RHS(JGR,IGR,IBM)-LHS(JGR,IGR,IBM)/ZKEFF)* + > FLUX(IGR,IBM) + ENDDO + RHS(JGR,JGR,IBM)=RHS(JGR,JGR,IBM)-REAL(SUM)/FLUX(JGR,IBM) + ENDDO + ELSE IF(IDIV.EQ.2) THEN + DO IGR=1,NGRP + SUM=0.0D0 + DO JGR=1,NGRP + SUM=SUM+(RHS(JGR,IGR,IBM)-LHS(JGR,IGR,IBM)/ZKEFF)* + > AFLUX(JGR,IBM) + ENDDO + RHS(IGR,IGR,IBM)=RHS(IGR,IGR,IBM)-REAL(SUM)/AFLUX(IGR,IBM) + ENDDO + ELSE IF(IDIV.EQ.3) THEN + ALLOCATE(DLK(NGRP),ALK(NGRP)) + DO JGR=1,NGRP + SUM=0.0D0 + DO IGR=1,NGRP + SUM=SUM+(RHS(JGR,IGR,IBM)-LHS(JGR,IGR,IBM)/ZKEFF)* + > FLUX(IGR,IBM) + ENDDO + DLK(JGR)=REAL(SUM) + ENDDO + DO IGR=1,NGRP + SUM=0.0D0 + DO JGR=1,NGRP + SUM=SUM+(RHS(JGR,IGR,IBM)-LHS(JGR,IGR,IBM)/ZKEFF)* + > AFLUX(JGR,IBM) + ENDDO + ALK(IGR)=REAL(SUM) + ENDDO + ALLOCATE(V(NGRP),W(NGRP)) + CALL DUO005(NGRP,DLK,ALK,FLUX(1,IBM),AFLUX(1,IBM),V,W) + DO IGR=1,NGRP + DO JGR=1,NGRP + RHS(IGR,JGR,IBM)=RHS(IGR,JGR,IBM)-V(IGR)-W(JGR) + ENDDO + ENDDO + DEALLOCATE(W,V,ALK,DLK) + ENDIF + ENDDO +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GAR2,NUF,CHI,GAR,VOL) + DEALLOCATE(IPOS,NJJ,IJJ) + RETURN + END diff --git a/Dragon/src/DUO002.f b/Dragon/src/DUO002.f new file mode 100644 index 0000000..91e6a97 --- /dev/null +++ b/Dragon/src/DUO002.f @@ -0,0 +1,158 @@ +*DECK DUO002 + SUBROUTINE DUO002(IPRINT,NMIX,NGRP,LENER,ZKEFF1,ZKEFF2,RHS1,RHS2, + > LHS1,LHS2,FLUX2,AFLUX1) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Print the detail of mixture delta-rho discrepancies between two +* calculations +* +*Copyright: +* Copyright (C) 2013 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPRINT print parameter. +* NMIX number of mixtures. +* NGRP number of energy groups. +* LENER energy group analysis flag. +* ZKEFF1 effective multiplication factor of the first calculation. +* ZKEFF2 effective multiplication factor of the second calculation. +* RHS1 absorption macroscopic cross-section matrix for the first +* calculation. +* RHS2 absorption macroscopic cross-section matrix for the second +* calculation. +* LHS1 production macroscopic cross-section matrix for the first +* calculation. +* LHS2 production macroscopic cross-section matrix for the second +* calculation. +* FLUX2 flux for the second calculation. +* AFLUX1 adjoint flux for the first calculation. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IPRINT,NMIX,NGRP + LOGICAL LENER + REAL ZKEFF1,ZKEFF2,RHS1(NGRP,NGRP,NMIX),RHS2(NGRP,NGRP,NMIX), + > LHS1(NGRP,NGRP,NMIX),LHS2(NGRP,NGRP,NMIX),FLUX2(NGRP,NMIX), + > AFLUX1(NGRP,NMIX) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION ZNUM,ZDEN,RHO12 + CHARACTER TEXT12*12 +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: RHO1,RHO2 + REAL, ALLOCATABLE, DIMENSION(:,:) :: RHO +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(RHO(NGRP,NMIX),RHO1(NGRP),RHO2(NMIX)) +*---- +* RAYLEIGH RATIO FOR THE FIRST SYSTEM +*---- + IF(IPRINT.GT.1) THEN + ZNUM=0.0D0 + ZDEN=0.0D0 + DO IBM=1,NMIX + DO IGR=1,NGRP + DO JGR=1,NGRP + ZNUM=ZNUM+LHS1(JGR,IGR,IBM)*AFLUX1(JGR,IBM)*FLUX2(IGR,IBM) + ZDEN=ZDEN+RHS1(JGR,IGR,IBM)*AFLUX1(JGR,IBM)*FLUX2(IGR,IBM) + ENDDO + ENDDO + ENDDO + WRITE(6,100) 1,ZNUM/ZDEN,ZKEFF1 + ENDIF +*---- +* RAYLEIGH RATIO FOR THE SECOND SYSTEM +*---- + IF(IPRINT.GT.1) THEN + ZNUM=0.0D0 + ZDEN=0.0D0 + DO IBM=1,NMIX + DO IGR=1,NGRP + DO JGR=1,NGRP + ZNUM=ZNUM+LHS2(JGR,IGR,IBM)*AFLUX1(JGR,IBM)*FLUX2(IGR,IBM) + ZDEN=ZDEN+RHS2(JGR,IGR,IBM)*AFLUX1(JGR,IBM)*FLUX2(IGR,IBM) + ENDDO + ENDDO + ENDDO + WRITE(6,100) 2,ZNUM/ZDEN,ZKEFF2 + ENDIF +*---- +* PERTURBATIVE ANALYSIS WITH THE CLIO FORMULA +*---- + RHO(:NGRP,:NMIX)=0.0 + RHO1(:NGRP)=0.0 + RHO2(:NMIX)=0.0 + ZDEN=0.0D0 + DO IBM=1,NMIX + DO IGR=1,NGRP + DO JGR=1,NGRP + DRHS=(RHS2(JGR,IGR,IBM)-RHS1(JGR,IGR,IBM)) + DLHS=(LHS2(JGR,IGR,IBM)-LHS1(JGR,IGR,IBM)) + RHO(IGR,IBM)=RHO(IGR,IBM)+(DRHS-DLHS/ZKEFF1)* + > AFLUX1(JGR,IBM)*FLUX2(IGR,IBM) + ZDEN=ZDEN+LHS2(JGR,IGR,IBM)*AFLUX1(JGR,IBM)* + > FLUX2(IGR,IBM) + ENDDO + ENDDO + ENDDO + RHO12=0.0D0 + DO IBM=1,NMIX + DO IGR=1,NGRP + RHO(IGR,IBM)=RHO(IGR,IBM)*1.0E5/REAL(ZDEN) + RHO1(IGR)=RHO1(IGR)+RHO(IGR,IBM) + RHO2(IBM)=RHO2(IBM)+RHO(IGR,IBM) + RHO12=RHO12+RHO(IGR,IBM) + ENDDO + ENDDO + DELLAM=((1./ZKEFF2)-(1./ZKEFF1))*1.0E5 + DELTA=ABS(DELLAM-REAL(RHO12)) + IF(DELTA.GT.2.0) CALL XABORT('DUO002: FAILURE OF DUO: MODULE TO ' + > //'ANALYSE THE DELTA-RHO DISCREPANCY WITHIN 2 PCM.') +*---- +* PRINT DELTA-RHO +*---- + IF(LENER) THEN + WRITE(6,'(/47H DUO002: DELTA-RHO MIXTURE-MULTIGROUP DISCREPAN, + > 12HCIES IN PCM:)') + WRITE(6,'(14X,9I12)') (IGR,IGR=1,NGRP) + IF(IPRINT.GT.0) THEN + DO IBM=1,NMIX + WRITE(TEXT12,'(4HMIXT,I6.6)') IBM + WRITE(6,110) TEXT12,(RHO(IGR,IBM),IGR=1,NGRP) + ENDDO + ENDIF + WRITE(6,120) (RHO1(IGR),IGR=1,NGRP) + ENDIF + WRITE(6,'(/48H DUO002: DELTA-RHO MIXTURE-DISCREPANCIES IN PCM:)') + DO IBM=1,NMIX + WRITE(TEXT12,'(4HMIXT,I6.6)') IBM + WRITE(6,110) TEXT12,RHO2(IBM) + ENDDO + WRITE(6,120) RHO12 + WRITE(6,'(14H *** SUM *** ,F12.2,8H (EXACT))') DELLAM +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(RHO2,RHO1,RHO) + RETURN +* + 100 FORMAT(16H DUO002: SYSTEM=,I2,21H DIRECT-ADJOINT KEFF=,1P,E13.5, + > 13H EXACT VALUE=,E13.5) + 110 FORMAT(1X,A12,1X,9F12.2/(14X,9F12.2)) + 120 FORMAT(/14H *** SUM *** ,9F12.2/(14X,9F12.2)) + END diff --git a/Dragon/src/DUO003.f b/Dragon/src/DUO003.f new file mode 100644 index 0000000..1722739 --- /dev/null +++ b/Dragon/src/DUO003.f @@ -0,0 +1,225 @@ +*DECK DUO003 + SUBROUTINE DUO003(IPLIB,IPRINT,NMIX,NISOT,NGRP,IDIV,ZKEFF,RHS,LHS, + > FLUX,AFLUX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Processing one of the two microlibs and return isotope-dependent +* RHS and LHS matrices. +* +*Copyright: +* Copyright (C) 2013 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB microlib. +* IPRINT print parameter. +* NMIX number of mixtures. +* NISOT number of isotopes. +* NGRP number of energy groups. +* IDIV type of divergence term processing (=0: no processing; +* =1: direct processing; =2: adjoint processing; +* =3: direct-adjoint processing). +* +*Parameters: output +* ZKEFF effective multiplication factor. +* RHS absorption macroscopic cross-section matrix. +* LHS production macroscopic cross-section matrix. +* FLUX integrated direct flux. +* AFLUX integrated adjoint flux. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + INTEGER IPRINT,NMIX,NISOT,NGRP,IDIV + REAL ZKEFF,RHS(NGRP,NGRP,NISOT+NMIX),LHS(NGRP,NGRP,NISOT+NMIX), + > FLUX(NGRP,NISOT+NMIX),AFLUX(NGRP,NISOT+NMIX) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) KPLIB + CHARACTER HSMG*131 + DOUBLE PRECISION SUM +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IMIX + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IHUSED + REAL, ALLOCATABLE, DIMENSION(:) :: DENS,VOL,TOTAL,ZNUSF,CHI,SIGS, + > DLK,ALK,V,W + REAL, ALLOCATABLE, DIMENSION(:,:) :: SCAT + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IHUSED(3,NISOT),IMIX(NISOT)) + ALLOCATE(DENS(NISOT),VOL(NISOT),TOTAL(NGRP),ZNUSF(NGRP), + > CHI(NGRP),SCAT(NGRP,NGRP)) + ALLOCATE(IPISO(NISOT)) +*---- +* FIND ISOTOPE POINTERS IN INPUT MICROLIB +*---- + CALL LIBIPS(IPLIB,NISOT,IPISO) +*---- +* COMPUTE THE RHS AND LHS MATRICES +*---- + CALL LCMGET(IPLIB,'ISOTOPESUSED',IHUSED) + CALL LCMGET(IPLIB,'ISOTOPESMIX',IMIX) + CALL LCMGET(IPLIB,'ISOTOPESDENS',DENS) + CALL LCMGET(IPLIB,'ISOTOPESVOL',VOL) + CALL LCMGET(IPLIB,'K-EFFECTIVE',ZKEFF) + IF(IPRINT.GT.1) WRITE(6,'(35H DUO003: EFFECTIVE MULTIPLICATION F, + > 6HACTOR=,1P,E12.5)') ZKEFF + RHS(:NGRP,:NGRP,:NISOT+NMIX)=0.0 + LHS(:NGRP,:NGRP,:NISOT+NMIX)=0.0 + DO ISOT=1,NISOT + IF(IPRINT.GT.4) WRITE(6,'(29H DUO003: PROCESSING ISOTOPE '', + > 3A4,2H''.)') (IHUSED(I0,ISOT),I0=1,3) + KPLIB=IPISO(ISOT) ! set ISOT-th isotope + IF(.NOT.C_ASSOCIATED(KPLIB)) THEN + WRITE(HSMG,'(18H DUO003: ISOTOPE '',3A4,7H'' (ISO=,I8,4H) IS, + > 31H NOT AVAILABLE IN THE MICROLIB.)') (IHUSED(I0,ISOT), + > I0=1,3),ISOT + CALL XABORT(HSMG) + ENDIF + CALL LCMGET(KPLIB,'NWT0',FLUX(1,ISOT)) + CALL LCMLEN(KPLIB,'NWAT0',ILON,ITYLCM) + IF(ILON.NE.0) THEN + CALL LCMGET(KPLIB,'NWAT0',AFLUX(1,ISOT)) + ELSE + AFLUX(:NGRP,ISOT)=1.0 + ENDIF + DO IGR=1,NGRP + FLUX(IGR,ISOT)=FLUX(IGR,ISOT)*VOL(ISOT) + AFLUX(IGR,ISOT)=AFLUX(IGR,ISOT)*VOL(ISOT) + ENDDO + CALL LCMGET(KPLIB,'NTOT0',TOTAL) + CALL LCMLEN(KPLIB,'NUSIGF',ILON,ITYLCM) + IF(ILON.GT.0) THEN + CALL LCMGET(KPLIB,'NUSIGF',ZNUSF) + CALL LCMGET(KPLIB,'CHI',CHI) + DO IGR=1,NGRP + DO JGR=1,NGRP + LHS(JGR,IGR,ISOT)=LHS(JGR,IGR,ISOT)+DENS(ISOT)*CHI(JGR)* + > ZNUSF(IGR) + ENDDO + ENDDO + ENDIF + ALLOCATE(SIGS(NGRP)) + CALL XDRLGS(KPLIB,-1,IPRINT,0,0,1,NGRP,SIGS,SCAT,ITYPRO) + DEALLOCATE(SIGS) + DO IGR=1,NGRP + DO JGR=1,NGRP + RHS(JGR,IGR,ISOT)=RHS(JGR,IGR,ISOT)-DENS(ISOT)*SCAT(JGR,IGR) + ENDDO + RHS(IGR,IGR,ISOT)=RHS(IGR,IGR,ISOT)+DENS(ISOT)*TOTAL(IGR) + ENDDO + ENDDO +*---- +* INTRODUCE THE DIRECT OR ADJOINT DIVERGENCE COMPONENT IN THE RHS +* MATRIX +*---- + DO IBM=1,NMIX + IF(IDIV.EQ.1) THEN + DO JGR=1,NGRP + SUM=0.0D0 + FLUMIX=0.0 + AFLUMI=0.0 + DO ISOT=1,NISOT + IF(IMIX(ISOT).EQ.IBM) THEN + FLUMIX=FLUX(JGR,ISOT) + AFLUMI=AFLUX(JGR,ISOT) + DO IGR=1,NGRP + SUM=SUM+(RHS(JGR,IGR,ISOT)-LHS(JGR,IGR,ISOT)/ZKEFF)* + > FLUX(IGR,ISOT) + ENDDO + ENDIF + ENDDO + RHS(JGR,JGR,NISOT+IBM)=-REAL(SUM)/FLUMIX + FLUX(JGR,NISOT+IBM)=FLUMIX + AFLUX(JGR,NISOT+IBM)=AFLUMI + ENDDO + ELSE IF(IDIV.EQ.2) THEN + DO IGR=1,NGRP + SUM=0.0D0 + FLUMIX=0.0 + AFLUMI=0.0 + DO ISOT=1,NISOT + IF(IMIX(ISOT).EQ.IBM) THEN + FLUMIX=FLUX(IGR,ISOT) + AFLUMI=AFLUX(IGR,ISOT) + DO JGR=1,NGRP + SUM=SUM+(RHS(JGR,IGR,ISOT)-LHS(JGR,IGR,ISOT)/ZKEFF)* + > AFLUX(JGR,ISOT) + ENDDO + ENDIF + ENDDO + RHS(IGR,IGR,NISOT+IBM)=-REAL(SUM)/AFLUMI + FLUX(IGR,NISOT+IBM)=FLUMIX + AFLUX(IGR,NISOT+IBM)=AFLUMI + ENDDO + ELSE IF(IDIV.EQ.3) THEN + ALLOCATE(DLK(NGRP),ALK(NGRP)) + DO JGR=1,NGRP + SUM=0.0D0 + FLUMIX=0.0 + AFLUMI=0.0 + DO ISOT=1,NISOT + IF(IMIX(ISOT).EQ.IBM) THEN + FLUMIX=FLUX(JGR,ISOT) + AFLUMI=AFLUX(JGR,ISOT) + DO IGR=1,NGRP + SUM=SUM+(RHS(JGR,IGR,ISOT)-LHS(JGR,IGR,ISOT)/ZKEFF)* + > FLUX(IGR,ISOT) + ENDDO + ENDIF + ENDDO + DLK(JGR)=REAL(SUM) + FLUX(JGR,NISOT+IBM)=FLUMIX + ENDDO + DO IGR=1,NGRP + SUM=0.0D0 + FLUMIX=0.0 + AFLUMI=0.0 + DO ISOT=1,NISOT + IF(IMIX(ISOT).EQ.IBM) THEN + FLUMIX=FLUX(IGR,ISOT) + AFLUMI=AFLUX(IGR,ISOT) + DO JGR=1,NGRP + SUM=SUM+(RHS(JGR,IGR,ISOT)-LHS(JGR,IGR,ISOT)/ZKEFF)* + > AFLUX(JGR,ISOT) + ENDDO + ENDIF + ENDDO + ALK(IGR)=REAL(SUM) + AFLUX(IGR,NISOT+IBM)=AFLUMI + ENDDO + ALLOCATE(V(NGRP),W(NGRP)) + CALL DUO005(NGRP,DLK,ALK,FLUX(1,NISOT+IBM), + > AFLUX(1,NISOT+IBM),V,W) + DO IGR=1,NGRP + DO JGR=1,NGRP + RHS(IGR,JGR,NISOT+IBM)=RHS(IGR,JGR,NISOT+IBM)- + > V(IGR)-W(JGR) + ENDDO + ENDDO + DEALLOCATE(W,V,ALK,DLK) + ENDIF + ENDDO +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SCAT,CHI,ZNUSF,TOTAL,VOL,DENS) + DEALLOCATE(IMIX,IHUSED) + RETURN + END diff --git a/Dragon/src/DUO004.f b/Dragon/src/DUO004.f new file mode 100644 index 0000000..1a74a61 --- /dev/null +++ b/Dragon/src/DUO004.f @@ -0,0 +1,179 @@ +*DECK DUO004 + SUBROUTINE DUO004(IPLIB,IPRINT,NMIX,NISOT,NGRP,LENER,ZKEFF1, + > ZKEFF2,RHSI1,RHSI2,LHSI1,LHSI2,FLUXI2,AFLUXI1) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Print the detail of isotopic delta-rho discrepancies between two +* calculations +* +*Copyright: +* Copyright (C) 2013 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB microlib. +* IPRINT print parameter. +* NMIX number of mixtures. +* NISOT number of isotopes. +* NGRP number of energy groups. +* LENER energy group analysis flag. +* ZKEFF1 effective multiplication factor of the first calculation. +* ZKEFF2 effective multiplication factor of the second calculation. +* RHSI1 absorption macroscopic cross-section matrix for the first +* calculation. +* RHSI2 absorption macroscopic cross-section matrix for the second +* calculation. +* LHSI1 production macroscopic cross-section matrix for the first +* calculation. +* LHSI2 production macroscopic cross-section matrix for the second +* calculation. +* FLUXI2 flux for the second calculation. +* AFLUXI1 adjoint flux for the first calculation. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + INTEGER IPRINT,NMIX,NISOT,NGRP + LOGICAL LENER + REAL ZKEFF1,ZKEFF2,RHSI1(NGRP,NGRP,NISOT+NMIX), + > RHSI2(NGRP,NGRP,NISOT+NMIX),LHSI1(NGRP,NGRP,NISOT+NMIX), + > LHSI2(NGRP,NGRP,NISOT+NMIX),FLUXI2(NGRP,NISOT+NMIX), + > AFLUXI1(NGRP,NISOT+NMIX) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION ZNUM,ZDEN,RHO12 + CHARACTER TEXT12*12 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IHUSED + REAL, ALLOCATABLE, DIMENSION(:) :: RHO1,RHO2 + REAL, ALLOCATABLE, DIMENSION(:,:) :: RHO +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IHUSED(3,NISOT)) + ALLOCATE(RHO(NGRP,NISOT+NMIX),RHO1(NGRP),RHO2(NISOT+NMIX)) +*---- +* RAYLEIGH RATIO FOR THE FIRST SYSTEM +*---- + IF(IPRINT.GT.1) THEN + ZNUM=0.0D0 + ZDEN=0.0D0 + DO ISOT=1,NISOT+NMIX + DO IGR=1,NGRP + DO JGR=1,NGRP + ZNUM=ZNUM+LHSI1(JGR,IGR,ISOT)*AFLUXI1(JGR,ISOT)* + > FLUXI2(IGR,ISOT) + ZDEN=ZDEN+RHSI1(JGR,IGR,ISOT)*AFLUXI1(JGR,ISOT)* + > FLUXI2(IGR,ISOT) + ENDDO + ENDDO + ENDDO + WRITE(6,100) 1,ZNUM/ZDEN,ZKEFF1 + ENDIF +*---- +* RAYLEIGH RATIO FOR THE SECOND SYSTEM +*---- + IF(IPRINT.GT.1) THEN + ZNUM=0.0D0 + ZDEN=0.0D0 + DO ISOT=1,NISOT+NMIX + DO IGR=1,NGRP + DO JGR=1,NGRP + ZNUM=ZNUM+LHSI2(JGR,IGR,ISOT)*AFLUXI1(JGR,ISOT)* + > FLUXI2(IGR,ISOT) + ZDEN=ZDEN+RHSI2(JGR,IGR,ISOT)*AFLUXI1(JGR,ISOT)* + > FLUXI2(IGR,ISOT) + ENDDO + ENDDO + ENDDO + WRITE(6,100) 2,ZNUM/ZDEN,ZKEFF2 + ENDIF +*---- +* PERTURBATIVE ANALYSIS WITH THE CLIO FORMULA +*---- + CALL LCMGET(IPLIB,'ISOTOPESUSED',IHUSED) + RHO(:NGRP,:NISOT+NMIX)=0.0 + RHO1(:NGRP)=0.0 + RHO2(:NISOT+NMIX)=0.0 + ZDEN=0.0D0 + DO ISOT=1,NISOT+NMIX + DO IGR=1,NGRP + DO JGR=1,NGRP + DRHS=(RHSI2(JGR,IGR,ISOT)-RHSI1(JGR,IGR,ISOT)) + DLHS=(LHSI2(JGR,IGR,ISOT)-LHSI1(JGR,IGR,ISOT)) + RHO(IGR,ISOT)=RHO(IGR,ISOT)+(DRHS-DLHS/ZKEFF1)* + > AFLUXI1(JGR,ISOT)*FLUXI2(IGR,ISOT) + ZDEN=ZDEN+LHSI2(JGR,IGR,ISOT)*AFLUXI1(JGR,ISOT)* + > FLUXI2(IGR,ISOT) + ENDDO + ENDDO + ENDDO + RHO12=0.0D0 + DO ISOT=1,NISOT+NMIX + DO IGR=1,NGRP + RHO(IGR,ISOT)=RHO(IGR,ISOT)*1.0E5/REAL(ZDEN) + RHO1(IGR)=RHO1(IGR)+RHO(IGR,ISOT) + RHO2(ISOT)=RHO2(ISOT)+RHO(IGR,ISOT) + RHO12=RHO12+RHO(IGR,ISOT) + ENDDO + ENDDO + DELLAM=((1./ZKEFF2)-(1./ZKEFF1))*1.0E5 + DELTA=ABS(DELLAM-REAL(RHO12)) + IF(DELTA.GT.2.0) CALL XABORT('DUO004: FAILURE OF DUO: MODULE TO ' + > //'ANALYSE THE DELTA-RHO DISCREPANCY WITHIN 2 PCM.') +*---- +* PRINT DELTA-RHO +*---- + IF(LENER) THEN + WRITE(6,'(/48H DUO004: DELTA-RHO ISOTOPIC-MULTIGROUP DISCREPAN, + > 12HCIES IN PCM:)') + WRITE(6,'(14X,9I12)') (IGR,IGR=1,NGRP) + IF(IPRINT.GT.0) THEN + DO ISOT=1,NISOT + WRITE(TEXT12,'(3A4)') (IHUSED(I0,ISOT),I0=1,3) + WRITE(6,110) TEXT12,(RHO(IGR,ISOT),IGR=1,NGRP) + ENDDO + DO IBM=1,NMIX + WRITE(TEXT12,'(4HLEAK,I6.6)') IBM + WRITE(6,110) TEXT12,(RHO(IGR,NISOT+IBM),IGR=1,NGRP) + ENDDO + ENDIF + WRITE(6,120) (RHO1(IGR),IGR=1,NGRP) + ENDIF + WRITE(6,'(/49H DUO004: DELTA-RHO ISOTOPIC DISCREPANCIES IN PCM:)') + DO ISOT=1,NISOT + WRITE(TEXT12,'(3A4)') (IHUSED(I0,ISOT),I0=1,3) + WRITE(6,110) TEXT12,RHO2(ISOT) + ENDDO + DO IBM=1,NMIX + WRITE(TEXT12,'(4HLEAK,I6.6)') IBM + WRITE(6,110) TEXT12,RHO2(NISOT+IBM) + ENDDO + WRITE(6,120) RHO12 + WRITE(6,'(14H *** SUM *** ,F12.2,8H (EXACT))') DELLAM +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(RHO2,RHO1,RHO) + DEALLOCATE(IHUSED) + RETURN +* + 100 FORMAT(16H DUO004: SYSTEM=,I2,21H DIRECT-ADJOINT KEFF=,1P,E13.5, + > 13H EXACT VALUE=,E13.5) + 110 FORMAT(1X,A12,1X,9F12.2/(14X,9F12.2)) + 120 FORMAT(/14H *** SUM *** ,9F12.2/(14X,9F12.2)) + END diff --git a/Dragon/src/DUO005.f b/Dragon/src/DUO005.f new file mode 100644 index 0000000..62dcac4 --- /dev/null +++ b/Dragon/src/DUO005.f @@ -0,0 +1,88 @@ +*DECK DUO005 + SUBROUTINE DUO005(NGRP,DLK,ALK,FLUX,AFLUX,V,W) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute a consistent direct-adjoint leakage multigroup term using +* the Villarino-Stamm'ler normalization method. +* +*Copyright: +* Copyright (C) 2013 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NGRP number of energy groups. +* DLK leakage rates for the direct balance equation. +* ALK leakage rates for the adjoint balance equation. +* FLUX integrated direct flux. +* AFLUX integrated adjoint flux. +* +*Parameters: output +* V first Villarino-Stamm'ler normalization vector. +* W second Villarino-Stamm'ler normalization vector. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NGRP + REAL DLK(NGRP),ALK(NGRP),FLUX(NGRP),AFLUX(NGRP),V(NGRP),W(NGRP) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION ZNUMD,ZNUMA,GAR + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: DFF,DFF2 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(DFF(2*NGRP+1,2*NGRP),DFF2(2*NGRP,2*NGRP+1)) +* + ZNUMD=0.0D0 + ZNUMA=0.0D0 + DO IGR=1,NGRP + ZNUMD=ZNUMD+FLUX(IGR) + ZNUMA=ZNUMA+AFLUX(IGR) + ENDDO + DFF(:2*NGRP+1,:2*NGRP)=0.0D0 + DO IGR=1,NGRP + DFF(IGR,IGR)=ZNUMD + DFF(NGRP+IGR,NGRP+IGR)=ZNUMA + DO JGR=1,NGRP + DFF(IGR,NGRP+JGR)=FLUX(JGR) + DFF(NGRP+IGR,JGR)=AFLUX(JGR) + ENDDO + DFF(2*NGRP+1,IGR)=AFLUX(IGR) + DFF(2*NGRP+1,NGRP+IGR)=FLUX(IGR) + ENDDO + DFF2(:2*NGRP,:2*NGRP+1)=0.0D0 + DO IGR=1,2*NGRP + GAR=0.0D0 + DO JGR=1,NGRP + GAR=GAR+DFF(JGR,IGR)*DLK(JGR)+DFF(NGRP+JGR,IGR)*ALK(JGR) + ENDDO + DFF2(IGR,2*NGRP+1)=GAR + DO JGR=1,2*NGRP + DO KGR=1,2*NGRP+1 + DFF2(IGR,JGR)=DFF2(IGR,JGR)+DFF(KGR,IGR)*DFF(KGR,JGR) + ENDDO + ENDDO + ENDDO + CALL ALSBD(2*NGRP,1,DFF2,IER,2*NGRP) + IF(IER.NE.0) CALL XABORT('DUO005: SINGULAR MATRIX.') + DO IGR=1,NGRP + V(IGR)=REAL(DFF2(IGR,2*NGRP+1)) + W(IGR)=REAL(DFF2(NGRP+IGR,2*NGRP+1)) + ENDDO +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(DFF2,DFF) + RETURN + END diff --git a/Dragon/src/DUO006.f b/Dragon/src/DUO006.f new file mode 100644 index 0000000..c9ace05 --- /dev/null +++ b/Dragon/src/DUO006.f @@ -0,0 +1,206 @@ +*DECK DUO006 + SUBROUTINE DUO006(IPLIB,IPRINT,NISOT,NGRP,HREAC,IDIV,RHS, + > FLUX,AFLUX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Processing one of the two microlibs and return the RHS matrix for +* the single reaction HREAC. +* +*Copyright: +* Copyright (C) 2013 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB microlib. +* IPRINT print parameter. +* NISOT number of isotopes. +* NGRP number of energy groups. +* HREAC character*8 reaction name of the reaction to process. +* IDIV type of divergence term processing (=0: no processing; +* =1: direct processing; =2: adjoint processing; +* =3: direct-adjoint processing). +* +*Parameters: output +* RHS macroscopic cross-section matrix. +* FLUX integrated direct flux. +* AFLUX integrated adjoint flux. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + INTEGER IPRINT,NISOT,NGRP,IDIV + CHARACTER HREAC*8 + REAL RHS(NGRP,NGRP,NISOT),FLUX(NGRP,NISOT),AFLUX(NGRP,NISOT) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) KPLIB + CHARACTER HSMG*131 + DOUBLE PRECISION SUM +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IHUSED + REAL, ALLOCATABLE, DIMENSION(:) :: DENS,VOL,VECTOR,CHI,SIGS,DLK, + > ALK,V,W + REAL, ALLOCATABLE, DIMENSION(:,:) :: SCAT,RATE + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IHUSED(3,NISOT)) + ALLOCATE(DENS(NISOT),VOL(NISOT),VECTOR(NGRP),SCAT(NGRP,NGRP), + > CHI(NGRP)) + ALLOCATE(IPISO(NISOT)) +*---- +* FIND ISOTOPE POINTERS IN INPUT MICROLIB +*---- + CALL LIBIPS(IPLIB,NISOT,IPISO) +*---- +* COMPUTE THE RHS AND LHS MATRICES +*---- + CALL LCMGET(IPLIB,'ISOTOPESUSED',IHUSED) + CALL LCMGET(IPLIB,'ISOTOPESDENS',DENS) + CALL LCMGET(IPLIB,'ISOTOPESVOL',VOL) + CALL LCMGET(IPLIB,'K-EFFECTIVE',ZKEFF) + IF(IPRINT.GT.4) WRITE(6,'(35H DUO006: EFFECTIVE MULTIPLICATION F, + > 6HACTOR=,1P,E12.5)') ZKEFF + RHS(:NGRP,:NGRP,:NISOT)=0.0 + DO ISOT=1,NISOT + IF(IPRINT.GT.4) WRITE(6,'(29H DUO006: PROCESSING ISOTOPE '', + > 3A4,2H''.)') (IHUSED(I0,ISOT),I0=1,3) + KPLIB=IPISO(ISOT) ! set ISOT-th isotope + IF(.NOT.C_ASSOCIATED(KPLIB)) THEN + WRITE(HSMG,'(18H DUO006: ISOTOPE '',3A4,7H'' (ISO=,I8,4H) IS, + > 31H NOT AVAILABLE IN THE MICROLIB.)') (IHUSED(I0,ISOT), + > I0=1,3),ISOT + CALL XABORT(HSMG) + ENDIF + CALL LCMGET(KPLIB,'NWT0',FLUX(1,ISOT)) + CALL LCMLEN(KPLIB,'NWAT0',ILON,ITYLCM) + IF(ILON.NE.0) THEN + CALL LCMGET(KPLIB,'NWAT0',AFLUX(1,ISOT)) + ELSE + AFLUX(:NGRP,ISOT)=1.0 + ENDIF + DO IGR=1,NGRP + FLUX(IGR,ISOT)=FLUX(IGR,ISOT)*VOL(ISOT) + AFLUX(IGR,ISOT)=AFLUX(IGR,ISOT)*VOL(ISOT) + ENDDO + CALL LCMLEN(KPLIB,HREAC,ILONG,ITYLCM) + IF((ILONG.EQ.0).AND.(HREAC.NE.'LEAK')) CYCLE + IF(HREAC.EQ.'SCAT00') THEN + ALLOCATE(SIGS(NGRP)) + CALL XDRLGS(KPLIB,-1,IPRINT,0,0,1,NGRP,SIGS,SCAT,ITYPRO) + DEALLOCATE(SIGS) + DO IGR=1,NGRP + DO JGR=1,NGRP + RHS(JGR,IGR,ISOT)=RHS(JGR,IGR,ISOT)+DENS(ISOT)* + > SCAT(JGR,IGR) + ENDDO + ENDDO + ELSE IF((HREAC.EQ.'NUSIGF').OR.(HREAC.EQ.'CHI')) THEN + CALL LCMGET(KPLIB,'NUSIGF',VECTOR) + CALL LCMGET(KPLIB,'CHI',CHI) + DO IGR=1,NGRP + DO JGR=1,NGRP + RHS(JGR,IGR,ISOT)=RHS(JGR,IGR,ISOT)+DENS(ISOT)*CHI(JGR)* + > VECTOR(IGR) + ENDDO + ENDDO + ELSE IF(HREAC(:3).EQ.'NWT') THEN + WRITE(HSMG,'(8HDUO006: ,A8,25H IS A FORBIDDEN REACTION.)') + > HREAC + CALL XABORT(HSMG) + ELSE IF(HREAC.EQ.'LEAK') THEN + ALLOCATE(RATE(NGRP,NGRP)) + RATE(:NGRP,:NGRP)=0.0 + CALL LCMLEN(KPLIB,'NUSIGF',ILON,ITYLCM) + IF(ILON.GT.0) THEN + CALL LCMGET(KPLIB,'NUSIGF',VECTOR) + CALL LCMGET(KPLIB,'CHI',CHI) + DO IGR=1,NGRP + DO JGR=1,NGRP + RATE(JGR,IGR)=RATE(JGR,IGR)-DENS(ISOT)*CHI(JGR)* + > VECTOR(IGR)/ZKEFF + ENDDO + ENDDO + ENDIF + ALLOCATE(SIGS(NGRP)) + CALL XDRLGS(KPLIB,-1,IPRINT,0,0,1,NGRP,SIGS,SCAT,ITYPRO) + DEALLOCATE(SIGS) + CALL LCMGET(KPLIB,'NTOT0',VECTOR) + DO IGR=1,NGRP + DO JGR=1,NGRP + RATE(JGR,IGR)=RATE(JGR,IGR)-DENS(ISOT)*SCAT(JGR,IGR) + ENDDO + RATE(IGR,IGR)=RATE(IGR,IGR)+DENS(ISOT)*VECTOR(IGR) + ENDDO + IF(IDIV.EQ.1) THEN + DO JGR=1,NGRP + SUM=0.0D0 + DO IGR=1,NGRP + SUM=SUM+RATE(JGR,IGR)*FLUX(IGR,ISOT) + ENDDO + RHS(JGR,JGR,ISOT)=-REAL(SUM)/FLUX(JGR,ISOT) + ENDDO + ELSE IF(IDIV.EQ.2) THEN + DO IGR=1,NGRP + SUM=0.0D0 + DO JGR=1,NGRP + SUM=SUM+RATE(JGR,IGR)*AFLUX(JGR,ISOT) + ENDDO + RHS(IGR,IGR,ISOT)=-REAL(SUM)/AFLUX(IGR,ISOT) + ENDDO + ELSE IF(IDIV.EQ.3) THEN + ALLOCATE(DLK(NGRP),ALK(NGRP)) + DO JGR=1,NGRP + SUM=0.0D0 + DO IGR=1,NGRP + SUM=SUM+RATE(JGR,IGR)*FLUX(IGR,ISOT) + ENDDO + DLK(JGR)=REAL(SUM) + ENDDO + DO IGR=1,NGRP + SUM=0.0D0 + DO JGR=1,NGRP + SUM=SUM+RATE(JGR,IGR)*AFLUX(JGR,ISOT) + ENDDO + ALK(IGR)=REAL(SUM) + ENDDO + ALLOCATE(V(NGRP),W(NGRP)) + CALL DUO005(NGRP,DLK,ALK,FLUX(1,ISOT),AFLUX(1,ISOT),V,W) + DO IGR=1,NGRP + DO JGR=1,NGRP + RHS(IGR,JGR,ISOT)=RHS(IGR,JGR,ISOT)-V(IGR)-W(JGR) + ENDDO + ENDDO + DEALLOCATE(W,V,ALK,DLK) + ENDIF + DEALLOCATE(RATE) + ELSE + CALL LCMGET(KPLIB,HREAC,VECTOR) + DO IGR=1,NGRP + RHS(IGR,IGR,ISOT)=RHS(IGR,IGR,ISOT)+DENS(ISOT)*VECTOR(IGR) + ENDDO + ENDIF + ENDDO +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IPISO) + DEALLOCATE(CHI,SCAT,VECTOR,VOL,DENS) + DEALLOCATE(IHUSED) + RETURN + END diff --git a/Dragon/src/DUO007.f b/Dragon/src/DUO007.f new file mode 100644 index 0000000..21c2f62 --- /dev/null +++ b/Dragon/src/DUO007.f @@ -0,0 +1,125 @@ +*DECK DUO007 + SUBROUTINE DUO007(IPLIB,IPRINT,NISOT,NGRP,LENER,RHSI1,RHSI2, + > LHSI2,FLUXI2,AFLUXI1,RHOREA) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Print the detail of isotopic delta-rho discrepancies between two +* calculations for a single reaction +* +*Copyright: +* Copyright (C) 2013 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB microlib. +* IPRINT print parameter. +* NISOT number of isotopes. +* NGRP number of energy groups. +* LENER energy group analysis flag. +* RHSI1 absorption macroscopic cross-section matrix for the first +* calculation. +* RHSI2 absorption macroscopic cross-section matrix for the second +* calculation. +* LHSI2 production macroscopic cross-section matrix for the second +* calculation. +* FLUXI2 flux for the second calculation. +* AFLUXI1 adjoint flux for the first calculation. +* +*Parameters: output +* RHOREA total delta-rho for the reaction. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + INTEGER IPRINT,NISOT,NGRP + LOGICAL LENER + REAL RHSI1(NGRP,NGRP,NISOT),RHSI2(NGRP,NGRP,NISOT), + > LHSI2(NGRP,NGRP,NISOT),FLUXI2(NGRP,NISOT),AFLUXI1(NGRP,NISOT), + > RHOREA +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION ZDEN,RHO12 + CHARACTER TEXT12*12 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IHUSED + REAL, ALLOCATABLE, DIMENSION(:) :: RHO1,RHO2 + REAL, ALLOCATABLE, DIMENSION(:,:) :: RHO +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IHUSED(3,NISOT)) + ALLOCATE(RHO(NGRP,NISOT),RHO1(NGRP),RHO2(NISOT)) +*---- +* PERTURBATIVE ANALYSIS WITH THE CLIO FORMULA +*---- + CALL LCMGET(IPLIB,'ISOTOPESUSED',IHUSED) + RHO(:NGRP,:NISOT)=0.0 + RHO1(:NGRP)=0.0 + RHO2(:NISOT)=0.0 + ZDEN=0.0D0 + DO ISOT=1,NISOT + DO IGR=1,NGRP + DO JGR=1,NGRP + DRHS=(RHSI2(JGR,IGR,ISOT)-RHSI1(JGR,IGR,ISOT)) + RHO(IGR,ISOT)=RHO(IGR,ISOT)+DRHS*AFLUXI1(JGR,ISOT)* + > FLUXI2(IGR,ISOT) + ZDEN=ZDEN+LHSI2(JGR,IGR,ISOT)*AFLUXI1(JGR,ISOT)* + > FLUXI2(IGR,ISOT) + ENDDO + ENDDO + ENDDO + RHO12=0.0D0 + DO ISOT=1,NISOT + DO IGR=1,NGRP + RHO(IGR,ISOT)=RHO(IGR,ISOT)*1.0E5/REAL(ZDEN) + RHO1(IGR)=RHO1(IGR)+RHO(IGR,ISOT) + RHO2(ISOT)=RHO2(ISOT)+RHO(IGR,ISOT) + RHO12=RHO12+RHO(IGR,ISOT) + ENDDO + ENDDO +*---- +* PRINT DELTA-RHO +*---- + IF(LENER) THEN + WRITE(6,'(/48H DUO007: DELTA-RHO ISOTOPIC-MULTIGROUP DISCREPAN, + > 12HCIES IN PCM:)') + WRITE(6,'(14X,9I12)') (IGR,IGR=1,NGRP) + IF(IPRINT.GT.0) THEN + DO ISOT=1,NISOT + WRITE(TEXT12,'(3A4)') (IHUSED(I0,ISOT),I0=1,3) + WRITE(6,110) TEXT12,(RHO(IGR,ISOT),IGR=1,NGRP) + ENDDO + ENDIF + WRITE(6,120) (RHO1(IGR),IGR=1,NGRP) + ENDIF + WRITE(6,'(/49H DUO007: DELTA-RHO ISOTOPIC DISCREPANCIES IN PCM:)') + DO ISOT=1,NISOT + WRITE(TEXT12,'(3A4)') (IHUSED(I0,ISOT),I0=1,3) + WRITE(6,110) TEXT12,RHO2(ISOT) + ENDDO + WRITE(6,120) RHO12 + RHOREA=REAL(RHO12) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(RHO2,RHO1,RHO) + DEALLOCATE(IHUSED) + RETURN +* + 110 FORMAT(1X,A12,1X,9F12.2/(14X,9F12.2)) + 120 FORMAT(/14H *** SUM *** ,9F12.2/(14X,9F12.2)) + END diff --git a/Dragon/src/DUODRV.f b/Dragon/src/DUODRV.f new file mode 100644 index 0000000..6e12abe --- /dev/null +++ b/Dragon/src/DUODRV.f @@ -0,0 +1,207 @@ +*DECK DUODRV + SUBROUTINE DUODRV(IPLIB1,IPLIB2,IPRINT,LENER,LISOT,LMIXT,LREAC, + > NMIX,NISOT,NGRP) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compare two microlibs and analyse the discrepancies using the Keff +* Clio perturbation formula. +* +*Copyright: +* Copyright (C) 2013 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB1 first microlib. +* IPLIB2 second microlib. +* IPRINT print parameter. +* LENER energy group analysis flag. +* LISOT isotope analysis flag. +* LMIXT mixture analysis flag. +* LREAC nuclear reaction analysis flag. +* NMIX number of mixtures. +* NISOT number of isotopes. +* NGRP number of energy groups. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB1,IPLIB2 + INTEGER IPRINT,NMIX,NISOT,NGRP + LOGICAL LENER,LISOT,LMIXT,LREAC +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + INTEGER ISTATE(NSTATE) + DOUBLE PRECISION DBLLIR + CHARACTER HREAC*8,CARLIR*12 +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:,:) :: FLUX1,AFLUX1,FLUX2,AFLUX2, + > FLUXI1,AFLUXI1,FLUXI2,AFLUXI2 + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: RHS1,LHS1,RHS2,LHS2,RHSI1, + > LHSI1,RHSI2,LHSI2 +*---- +* SCRATCH STORAGE ALLOCATION +* RHS1 absorption macroscopic cross-section matrix +* LHS1 production macroscopic cross-section matrix +* FLUX1 direct flux +* AFLUX1 adjoint flux flux +* RHS2 absorption macroscopic cross-section matrix +* LHS2 production macroscopic cross-section matrix +* FLUX2 direct flux +* AFLUX2 adjoint flux flux +* RHSI1 absorption macroscopic cross-section matrix +* LHSI1 production macroscopic cross-section matrix +* FLUXI1 direct flux +* AFLUXI1 adjoint flux flux +* RHSI2 absorption macroscopic cross-section matrix +* LHSI2 production macroscopic cross-section matrix +* FLUXI2 direct flux +* AFLUXI2 adjoint flux flux +*---- + ALLOCATE(RHS1(NGRP,NGRP,NMIX),LHS1(NGRP,NGRP,NMIX), + > FLUX1(NGRP,NMIX),AFLUX1(NGRP,NMIX),RHS2(NGRP,NGRP,NMIX), + > LHS2(NGRP,NGRP,NMIX),FLUX2(NGRP,NMIX),AFLUX2(NGRP,NMIX), + > RHSI1(NGRP,NGRP,NISOT+NMIX),LHSI1(NGRP,NGRP,NISOT+NMIX), + > FLUXI1(NGRP,NISOT+NMIX),AFLUXI1(NGRP,NISOT+NMIX), + > RHSI2(NGRP,NGRP,NISOT+NMIX),LHSI2(NGRP,NGRP,NISOT+NMIX), + > FLUXI2(NGRP,NISOT+NMIX),AFLUXI2(NGRP,NISOT+NMIX)) +*---- +* -- MIXTURE KEYWORD -- +* CONSTRUCT THE RHS AND LHS MATRICES FOR THE FIRST SYSTEM +*---- + IF(.NOT.LMIXT) GO TO 100 + IF(IPRINT.GT.1) THEN + WRITE(6,'(/48H DUODRV: ANALYSIS OF THE FIRST SYSTEM -- MIXTURE, + > 8H KEYWORD)') + ENDIF + CALL LCMSIX(IPLIB1,'MACROLIB',1) + CALL LCMGET(IPLIB1,'STATE-VECTOR',ISTATE) + NFIS=ISTATE(4) + CALL DUO001(IPLIB1,IPRINT,NMIX,NGRP,NFIS,3,ZKEFF1,RHS1,LHS1,FLUX1, + > AFLUX1) + CALL LCMSIX(IPLIB1,' ',2) +*---- +* CONSTRUCT THE RHS AND LHS MATRICES FOR THE SECOND SYSTEM +*---- + IF(IPRINT.GT.1) THEN + WRITE(6,'(/48H DUODRV: ANALYSIS OF THE SECOND SYSTEM -- MIXTUR, + > 9HE KEYWORD)') + ENDIF + CALL LCMSIX(IPLIB2,'MACROLIB',1) + CALL LCMGET(IPLIB2,'STATE-VECTOR',ISTATE) + NFIS=ISTATE(4) + CALL DUO001(IPLIB2,IPRINT,NMIX,NGRP,NFIS,3,ZKEFF2,RHS2,LHS2,FLUX2, + > AFLUX2) + CALL LCMSIX(IPLIB2,' ',2) +*---- +* PRINT THE DETAILED DELTA-RHO USING THE CLIO FORMULA +*---- + IF(IPRINT.GT.1) THEN + WRITE(6,'(/33H DUODRV: PERFORMING CLIO ANALYSIS)') + ENDIF + CALL DUO002(IPRINT,NMIX,NGRP,LENER,ZKEFF1,ZKEFF2,RHS1,RHS2, + > LHS1,LHS2,FLUX2,AFLUX1) +*---- +* -- ISOTOPE KEYWORD -- +* CONSTRUCT THE RHS AND LHS MATRICES FOR THE FIRST SYSTEM +*---- + 100 IF(.NOT.LISOT) GO TO 200 + IF(IPRINT.GT.1) THEN + WRITE(6,'(/48H DUODRV: ANALYSIS OF THE FIRST SYSTEM -- ISOTOPE, + > 8H KEYWORD)') + ENDIF + CALL DUO003(IPLIB1,IPRINT,NMIX,NISOT,NGRP,3,ZKEFF1,RHSI1, + > LHSI1,FLUXI1,AFLUXI1) +*---- +* CONSTRUCT THE RHS AND LHS MATRICES FOR THE SECOND SYSTEM +*---- + IF(IPRINT.GT.1) THEN + WRITE(6,'(/48H DUODRV: ANALYSIS OF THE SECOND SYSTEM -- ISOTOP, + > 9HE KEYWORD)') + ENDIF + CALL DUO003(IPLIB2,IPRINT,NMIX,NISOT,NGRP,3,ZKEFF2,RHSI2, + > LHSI2,FLUXI2,AFLUXI2) +*---- +* PRINT THE DETAILED DELTA-RHO USING THE CLIO FORMULA +*---- + IF(IPRINT.GT.1) THEN + WRITE(6,'(/33H DUODRV: PERFORMING CLIO ANALYSIS)') + ENDIF + CALL DUO004(IPLIB1,IPRINT,NMIX,NISOT,NGRP,LENER,ZKEFF1,ZKEFF2, + > RHSI1,RHSI2,LHSI1,LHSI2,FLUXI2,AFLUXI1) +*---- +* -- REAC KEYWORD -- +*---- + 200 IF(.NOT.LREAC) GO TO 230 + CALL DUO003(IPLIB2,0,NMIX,NISOT,NGRP,3,ZKEFF2,RHSI2,LHSI2, + > FLUXI2,AFLUXI2) +* + 210 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('DUODRV: READ ERROR - CHARACTER VA' + > //'RIABLE EXPECTED') + 220 IF(CARLIR.EQ.'ENDREAC') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('DUODRV: READ ERROR - CHARACTER ' + > //'VARIABLE EXPECTED') + IF(CARLIR.NE.';') CALL XABORT('DUODRV: ; KEYWORD EXPECTED') + GO TO 230 + ENDIF + HREAC=CARLIR(:8) +*---- +* CONSTRUCT THE RHS MATRIX FOR THE FIRST SYSTEM +*---- + IF(IPRINT.GT.1) THEN + WRITE(6,'(/49H DUODRV: ANALYSIS OF THE FIRST SYSTEM -- REACTION, + > 1X,A8,1H.)') HREAC + ENDIF + CALL DUO006(IPLIB1,IPRINT,NISOT,NGRP,HREAC,3,RHSI1,FLUXI1,AFLUXI1) +*---- +* CONSTRUCT THE RHS MATRIX FOR THE SECOND SYSTEM +*---- + IF(IPRINT.GT.1) THEN + WRITE(6,'(/48H DUODRV: ANALYSIS OF THE SECOND SYSTEM -- REACTI, + > 2HON,1X,A8,1H.)') HREAC + ENDIF + CALL DUO006(IPLIB2,IPRINT,NISOT,NGRP,HREAC,3,RHSI2,FLUXI2,AFLUXI2) +*---- +* PRINT THE DETAILED DELTA-RHO USING THE CLIO FORMULA +*---- + IF(IPRINT.GT.1) THEN + WRITE(6,'(/47H DUODRV: PERFORMING CLIO ANALYSIS FOR REACTION , + > A8,1H.)') HREAC + ENDIF + CALL DUO007(IPLIB1,IPRINT,NISOT,NGRP,LENER,RHSI1,RHSI2,LHSI2, + > FLUXI2,AFLUXI1,RHOREA) +* + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('DUODRV: READ ERROR - CHARACTER VA' + > //'RIABLE EXPECTED') + IF(CARLIR.EQ.'PICK') THEN + CALL REDGET(ITYPLU,INTLIR,RHOREA,CARLIR,DBLLIR) + IF(ITYPLU.NE.-2) CALL XABORT('DUODRV: OUTPUT REAL EXPECTED') + ITYPLU=2 + CALL REDPUT(ITYPLU,INTLIR,RHOREA,CARLIR,DBLLIR) + ELSE + GO TO 220 + ENDIF + GO TO 210 +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 230 DEALLOCATE(AFLUXI2,FLUXI2,LHSI2,RHSI2,AFLUXI1,FLUXI1,LHSI1,RHSI1, + > AFLUX2,FLUX2,LHS2,RHS2,AFLUX1,FLUX1,LHS1,RHS1) + RETURN + END diff --git a/Dragon/src/DUTURN.f b/Dragon/src/DUTURN.f new file mode 100644 index 0000000..8257be0 --- /dev/null +++ b/Dragon/src/DUTURN.f @@ -0,0 +1,506 @@ +*DECK DUTURN + SUBROUTINE DUTURN(IHEX,TURN,NCEL,TURND,NCELA,CELL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Provide orientation of cell in an assembly with symetry IHEX. +* +*Copyright: +* Copyright (C) 1991 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): M. Ouisloumen +* +*Parameters: input +* IHEX symmetry type. +* NCEL number of cells in symmetric assembly. +* NCELA number of cells in unfolded assembly. +* CELL cell index in symmetric assembly. +* TURN cell orientation in symmetric assembly. +* +*Parameters: output +* TURND cell orientation in unfolded assembly. +* +*----------------------------------------------------------------------- +* + INTEGER TAB(6),CELL(NCELA),TAB6(6),TAB9(6),TURN(NCEL), + + TURND(NCELA),TAB12(6),TABR8(6), + + TABA8(6),TABB8(6) + LOGICAL LGR8,LGSA,LGSB,LGSA6 + INTEGER, ALLOCATABLE, DIMENSION(:) :: NUM,NTURN,ITAB + SAVE TAB,TAB6,TAB9,TAB12,TABR8,TABA8,TABB8 + DATA TAB,TAB6,TAB9,TAB12,TABR8,TABA8,TABB8 + + /1,6,5,4,3,2,2,1,6,5,4,3,3,2,1,6,5,4,3,4,5,6,1,2,4,5,6,1,2,3 + + ,3,2,1,6,5,4,6,5,4,3,2,1/ +* + IFONC(N,L)= 2+(N-1)*(L+3*(N-2)) + IFCOUR(N)=NINT( (4.+SQRT(1.+4.*FLOAT(N-1)/3.) + + +SQRT(1.+4.*FLOAT(N-2)/3.))*.25) +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NUM(NCEL),NTURN(NCEL),ITAB(NCEL)) +* + DO 10 I=2,NCEL + IF(TURN(I).EQ.1.OR.TURN(I).EQ.9) THEN + ITAB(I)=2 + ELSEIF(TURN(I).EQ.2.OR.TURN(I).EQ.10) THEN + ITAB(I)=3 + ELSEIF(TURN(I).EQ.3.OR.TURN(I).EQ.11) THEN + ITAB(I)=4 + ELSEIF(TURN(I).EQ.4.OR.TURN(I).EQ.12) THEN + ITAB(I)=5 + ELSEIF(TURN(I).EQ.5.OR.TURN(I).EQ.7) THEN + ITAB(I)=6 + ELSEIF(TURN(I).EQ.6.OR.TURN(I).EQ.8) THEN + ITAB(I)=1 + ELSE + CALL XABORT('DUTURN : INVALID ORIENTATION ') + ENDIF +10 CONTINUE +* + NCOUR=IFCOUR(NCELA) + IF(IHEX.EQ.1) THEN + GOTO 20 + ELSEIF(IHEX.EQ.2.OR.IHEX.EQ.3) THEN + GOTO 40 + ELSEIF(IHEX.EQ.4) THEN + GOTO 60 + ELSEIF(IHEX.EQ.5) THEN + GOTO 80 + ELSEIF(IHEX.GT.5.AND.IHEX.LT.9) THEN + GOTO 100 + ELSE + CALL XABORT('DUTURN : INVALID TYPE OF GEOMETRY ') + ENDIF +* + 20 CONTINUE +* +* DUPLICATION DE L'ORIENTATION DANS LA SYMETRIE S30 +* + TURND(1)=TURN(1) +* +* DUPLICATION DE LA 2EME COURONE +* + ITURN=ITAB(2) + TURND(2)=TURN(2) + DO 25 I=3,7 + ITURN=ITURN+1 + IF(ITURN.GT.6)ITURN=ITURN-6 + IF(ITURN.EQ.1) THEN + TURND(I)=8 + IF(TURN(CELL(I)).LE.6)TURND(I)=6 + ELSEIF(ITURN.EQ.2) THEN + TURND(I)=1 + IF(TURN(CELL(I)).GT.6)TURND(I)=9 + ELSEIF(ITURN.EQ.3) THEN + TURND(I)=2 + IF(TURN(CELL(I)).GT.6)TURND(I)=10 + ELSEIF(ITURN.EQ.4) THEN + TURND(I)=3 + IF(TURN(CELL(I)).GT.6)TURND(I)=11 + ELSEIF(ITURN.EQ.5) THEN + TURND(I)=4 + IF(TURN(CELL(I)).GT.6)TURND(I)=12 + ELSEIF(ITURN.EQ.6) THEN + TURND(I)=5 + IF(TURN(CELL(I)).GT.6)TURND(I)=7 + ELSE + CALL XABORT('DUTURN : TURN DUPLICATION ALGORITHME ERROR ') + ENDIF + 25 CONTINUE +* +* DUPLICATON DES AUTRES COURONES +* + JCEL=3 + DO 30 IC=3,NCOUR + NCS=INT(AINT((REAL(IC)+1.)/2.)) + NCEL1=IFONC(IC,0) + KCEL=JCEL+NCS-1 + DO 32 IN=JCEL,KCEL + NTURN(IN)=TURN(IN) + NUM(IN)=ITAB(IN) + 32 CONTINUE + LAUX=1 + TURND(NCEL1)=TURN(KCEL) + DO 35 JROT=0,11 + NCEL2=NCEL1+NCS-1 + IF(MOD(IC,2).EQ.0) THEN + IF(LAUX.EQ.0) THEN + NCEL2=NCEL2+1 + LAUX=1 + ELSE + LAUX=0 + ENDIF + ENDIF + IF(JROT.EQ.11)NCEL2=NCEL2-1 + DO 33 J=NCEL1+1,NCEL2 + ITURN=NUM(CELL(J)) + KTURN=JROT+TAB(ITURN) + IF(KTURN.GT.12) KTURN=KTURN-12 + IF(KTURN.GT.6) KTURN=KTURN-6 + NUM(CELL(J))=KTURN + IF(KTURN.EQ.1) THEN + TURND(J)=6 + IF(NTURN(CELL(J)).LE.6)TURND(J)=8 + ELSEIF(KTURN.EQ.2) THEN + TURND(J)=1 + IF(NTURN(CELL(J)).LE.6)TURND(J)=9 + ELSEIF(KTURN.EQ.3) THEN + TURND(J)=2 + IF(NTURN(CELL(J)).LE.6)TURND(J)=10 + ELSEIF(KTURN.EQ.4) THEN + TURND(J)=3 + IF(NTURN(CELL(J)).LE.6)TURND(J)=11 + ELSEIF(KTURN.EQ.5) THEN + TURND(J)=4 + IF(NTURN(CELL(J)).LE.6)TURND(J)=12 + ELSEIF(KTURN.EQ.6) THEN + TURND(J)=5 + IF(NTURN(CELL(J)).LE.6)TURND(J)=7 + ELSE + CALL XABORT('DUTURN : INVALID ORIENTATION 2 ') + ENDIF + NTURN(CELL(J))=TURND(J) + 33 CONTINUE + NCEL1=NCEL2 + 35 CONTINUE + JCEL=KCEL+1 + 30 CONTINUE + GO TO 200 +* + 40 CONTINUE +* +* DUPLICATION DE L'ORIENTATION DES GEOMETRIES SA60 ET SB60 +* + TURND(1)=TURN(1) + JCEL=2 + LGSA6=IHEX.EQ.2 + DO 55 IC=2,NCOUR + NCS=IC + NCEL1=IFONC(IC,0) + NCEL10=0 + IF(.NOT.LGSA6) THEN + NCS=2*NINT(REAL(IC)/2.)-1 + NCEL10=NCEL1 + NCEL1=NCEL1+NINT(REAL(IC+1)/2.)-1 + ENDIF + KCEL=JCEL+NCS-1 + DO 50 IN=JCEL,KCEL + NTURN(IN)=TURN(IN) + NUM(IN)=ITAB(IN) + 50 CONTINUE + IF(LGSA6) THEN + TURND(NCEL1)=TURN(KCEL) + ELSE + KKK=KCEL-NCEL1+NCEL10-1 + NCFIN=NCEL1 + IF(MOD(IC,2).EQ.0)NCFIN=NCEL1-1 + DO 555 IK=NCEL10,NCFIN + KKK=KKK+1 + TURND(IK)=TURN(KKK) + 555 CONTINUE + ENDIF + DO 54 JROT=0,5 + NCEL2=NCEL1+NCS-1 + IF(JROT.EQ.5) THEN +* NCEL2=NCEL2-1 + IF(.NOT.LGSA6) THEN + NCEL2=NCEL2-NINT(REAL(NCS)/2.) + ELSE + NCEL2=NCEL2-1 + ENDIF + ENDIF + DO 52 J=NCEL1,NCEL2 + ITURN=NUM(CELL(J)) + KTURN=0 + IF(LGSA6) THEN + KTURN=TAB(ITURN)+4*JROT + ELSE + KTURN=TAB6(ITURN)+2*JROT + ENDIF + IF(KTURN.GT.24)KTURN=KTURN-24 + IF(KTURN.GT.12)KTURN=KTURN-12 + IF(KTURN.GT.6) KTURN=KTURN-6 + IF(.NOT.LGSA6) NUM(CELL(J))=KTURN + ITTD=0 + IF(KTURN.EQ.1) THEN + ITTD=6 + IF(NTURN(CELL(J)).LE.6)ITTD=8 + ELSEIF(KTURN.EQ.2) THEN + ITTD=1 + IF(NTURN(CELL(J)).LE.6)ITTD=9 + ELSEIF(KTURN.EQ.3) THEN + ITTD=2 + IF(NTURN(CELL(J)).LE.6)ITTD=10 + ELSEIF(KTURN.EQ.4) THEN + ITTD=3 + IF(NTURN(CELL(J)).LE.6)ITTD=11 + ELSEIF(KTURN.EQ.5) THEN + ITTD=4 + IF(NTURN(CELL(J)).LE.6)ITTD=12 + ELSEIF(KTURN.EQ.6) THEN + ITTD=5 + IF(NTURN(CELL(J)).LE.6)ITTD=7 + ELSE + CALL XABORT('DUTURN : INVALID ORIENTATION 3 ') + ENDIF + IF(J.EQ.NCEL1) THEN + IF(LGSA6)GOTO 51 + IF(MOD(IC,2).NE.0) GOTO 51 + ENDIF + TURND(J)=ITTD + 51 NTURN(CELL(J))=ITTD + 52 CONTINUE + NCEL1=NCEL2 + IF(.NOT.LGSA6) THEN + IF(MOD(IC,2).EQ.0)NCEL1=NCEL1+1 + ENDIF + 54 CONTINUE + JCEL=KCEL+1 + 55 CONTINUE + GO TO 200 +* + 60 CONTINUE +* +* DUPLICATION DE L'ORIENTATION DE LA GEOMETRIE S90 +* + TURND(1)=TURN(1) + JCEL=2 + DO 75 IC=2,NCOUR + NCS=IC+INT(AINT(REAL((IC+1)/2)))-1 + NCEL1=IFONC(IC,1) + KCEL=JCEL+NCS-1 + DO 70 IN=JCEL,KCEL + NTURN(IN)=TURN(IN) + NUM(IN)=ITAB(IN) + 70 CONTINUE + NCEL0=IFONC(IC,0) + KKK=KCEL-NCEL1+NCEL0 + DO 71 IK=NCEL0,NCEL1 + KKK=KKK+1 + TURND(IK)=TURN(KKK) + 71 CONTINUE + DO 74 JROT=0,3 + NCEL2=NCEL1+NCS-1 + IF(JROT.EQ.3) NCEL2=NCEL1+INT(AINT(REAL((IC+1)/2)))-2 + DO 72 J=NCEL1,NCEL2 + ITURN=NUM(CELL(J)) + KTURN=TAB9(ITURN)+3*JROT + IF(KTURN.GT.12)KTURN=KTURN-12 + IF(KTURN.GT.6) KTURN=KTURN-6 + NUM(CELL(J))=KTURN + IF(KTURN.EQ.1) THEN + TURND(J)=6 + IF(NTURN(CELL(J)).LE.6)TURND(J)=8 + ELSEIF(KTURN.EQ.2) THEN + TURND(J)=1 + IF(NTURN(CELL(J)).LE.6)TURND(J)=9 + ELSEIF(KTURN.EQ.3) THEN + TURND(J)=2 + IF(NTURN(CELL(J)).LE.6)TURND(J)=10 + ELSEIF(KTURN.EQ.4) THEN + TURND(J)=3 + IF(NTURN(CELL(J)).LE.6)TURND(J)=11 + ELSEIF(KTURN.EQ.5) THEN + TURND(J)=4 + IF(NTURN(CELL(J)).LE.6)TURND(J)=12 + ELSEIF(KTURN.EQ.6) THEN + TURND(J)=5 + IF(NTURN(CELL(J)).LE.6)TURND(J)=7 + ELSE + CALL XABORT('DUTURN : INVALID ORIENTATION 4 ') + ENDIF + NTURN(CELL(J))=TURND(J) + 72 CONTINUE + NCEL1=NCEL2 + IF(MOD(IC,2).EQ.0) THEN + IF(JROT.EQ.0.OR.JROT.EQ.2) NCEL1=NCEL1+1 + ENDIF + 74 CONTINUE + JCEL=KCEL+1 + 75 CONTINUE +* + GO TO 200 +* + 80 CONTINUE +* +* DUPLICATION DE L'ORIENTATION DE LA SYMETRIE R120 +* + TURND(1)=TURN(1) + JCEL=2 + DO 95 IC=2,NCOUR + NCS=2*(IC-1) + NCEL1=IFONC(IC,1) + NCEL0=IFONC(IC,0) + KCEL=JCEL+NCS-1 + DO 90 IN=JCEL,KCEL + NTURN(IN)=TURN(IN) + NUM(IN)=ITAB(IN) + 90 CONTINUE + KK=KCEL + DO 91 I=NCEL1,NCEL0,-1 + TURND(I)=TURN(KK) + KK=KK-1 + 91 CONTINUE + NCEL1=NCEL1+1 + DO 94 JROT=0,1 + NCEL2=NCEL1+NCS-1 + DO 92 J=NCEL1,NCEL2 + ITURN=NUM(CELL(J)) + KTURN=TAB12(ITURN) + NUM(CELL(J))=KTURN + IF(KTURN.EQ.1) THEN + TURND(J)=6 + IF(NTURN(CELL(J)).GT.6)TURND(J)=8 + ELSEIF(KTURN.EQ.2) THEN + TURND(J)=1 + IF(NTURN(CELL(J)).GT.6)TURND(J)=9 + ELSEIF(KTURN.EQ.3) THEN + TURND(J)=2 + IF(NTURN(CELL(J)).GT.6)TURND(J)=10 + ELSEIF(KTURN.EQ.4) THEN + TURND(J)=3 + IF(NTURN(CELL(J)).GT.6)TURND(J)=11 + ELSEIF(KTURN.EQ.5) THEN + TURND(J)=4 + IF(NTURN(CELL(J)).GT.6)TURND(J)=12 + ELSEIF(KTURN.EQ.6) THEN + TURND(J)=5 + IF(NTURN(CELL(J)).GT.6)TURND(J)=7 + ELSE + CALL XABORT('DUTURN : INVALID ORIENTATION 5 ') + ENDIF + NTURN(CELL(J))=TURND(J) + 92 CONTINUE + NCEL1=NCEL2+1 + 94 CONTINUE + NCC=NCEL2+1 + DO 93 L=KK,JCEL,-1 + TURND(NCC)=TURN(L) + NCC=NCC+1 + 93 CONTINUE + JCEL=KCEL+1 + 95 CONTINUE +* + GO TO 200 +* + 100 CONTINUE +* +* DUPLICATION DE L'ORIENTATION DES SYMETRIES R180,SA180 ET SB180 +* + TURND(1)=TURN(1) + LGR8=.FALSE. + LGSA=.FALSE. + LGSB=.FALSE. + IF(IHEX.EQ.6) THEN + LGR8=.TRUE. + ELSEIF(IHEX.EQ.7) THEN + LGSA=.TRUE. + ELSEIF(IHEX.EQ.8) THEN + LGSB=.TRUE. + ENDIF + JCEL=2 + DO 115 IC=2,NCOUR + NCEL1=IFONC(IC,1) + NCEL10=NCEL1 + NCEL0=IFONC(IC,0) + NCS=0 + IF(LGR8) THEN + NCS=3*(IC-1) + NCEL1=NCEL1+1 + ELSEIF(LGSA) THEN + NCS=3*IC-2 + ELSEIF(LGSB) THEN + NCC=INT(AINT(REAL(IC+1)/2.))-1 + NCS=2*IC-1+2*NCC + NCEL1=NCEL1+IC+NCC + NCEL10=NCEL1-1 + ENDIF + KCEL=JCEL+NCS-1 + DO 110 IN=JCEL,KCEL + NTURN(IN)=TURN(IN) + NUM(IN)=ITAB(IN) + 110 CONTINUE + NCEL2=NCEL1+NCS-1 + IF(LGSB) THEN + IF(MOD(IC,2).NE.0)NCEL2=NCEL2-2 + ENDIF + KK=KCEL + DO 111 IZ=NCEL10,NCEL0,-1 + TURND(IZ)=TURN(KK) + KK=KK-1 + 111 CONTINUE + LL=NCEL2 + DO 112 IZ=JCEL,KK + LL=LL+1 + TURND(LL)=TURN(IZ) + 112 CONTINUE + DO 102 J=NCEL1,NCEL2 + ITURN=NUM(CELL(J)) + KTURN=0 + IF(LGR8) THEN + KTURN=TABR8(ITURN) + ELSEIF(LGSA) THEN + KTURN=TABA8(ITURN) + ELSEIF(LGSB) THEN + KTURN=TABB8(ITURN) + ENDIF + IF(KTURN.EQ.1) THEN + TURND(J)=6 + IF(LGR8) THEN + IF(NTURN(CELL(J)).GT.6) TURND(J)=8 + ELSE + IF(NTURN(CELL(J)).LE.6) TURND(J)=8 + ENDIF + ELSEIF(KTURN.EQ.2) THEN + TURND(J)=1 + IF(LGR8) THEN + IF(NTURN(CELL(J)).GT.6) TURND(J)=9 + ELSE + IF(NTURN(CELL(J)).LE.6) TURND(J)=9 + ENDIF + ELSEIF(KTURN.EQ.3) THEN + TURND(J)=2 + IF(LGR8) THEN + IF(NTURN(CELL(J)).GT.6) TURND(J)=10 + ELSE + IF(NTURN(CELL(J)).LE.6) TURND(J)=10 + ENDIF + ELSEIF(KTURN.EQ.4) THEN + TURND(J)=3 + IF(LGR8) THEN + IF(NTURN(CELL(J)).GT.6) TURND(J)=11 + ELSE + IF(NTURN(CELL(J)).LE.6) TURND(J)=11 + ENDIF + ELSEIF(KTURN.EQ.5) THEN + TURND(J)=4 + IF(LGR8) THEN + IF(NTURN(CELL(J)).GT.6) TURND(J)=12 + ELSE + IF(NTURN(CELL(J)).LE.6) TURND(J)=12 + ENDIF + ELSEIF(KTURN.EQ.6) THEN + TURND(J)=5 + IF(LGR8) THEN + IF(NTURN(CELL(J)).GT.6) TURND(J)=7 + ELSE + IF(NTURN(CELL(J)).LE.6) TURND(J)=7 + ENDIF + ELSE + CALL XABORT('DUTURN : INVALID ORIENTATION 6 ') + ENDIF + 102 CONTINUE + JCEL=KCEL+1 + 115 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 200 DEALLOCATE(ITAB,NTURN,NUM) + RETURN + END diff --git a/Dragon/src/EDI.f b/Dragon/src/EDI.f new file mode 100644 index 0000000..cb9ed74 --- /dev/null +++ b/Dragon/src/EDI.f @@ -0,0 +1,667 @@ +*DECK EDI + SUBROUTINE EDI(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Edition operator for Dragon. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert and G. Marleau +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file (order is arbitrary for +* objects 2,3,4): +* HENTRY(1): create or modification type(L_EDIT); +* HENTRY(2): read-only type(L_FLUX); +* HENTRY(3): read-only type(L_MACROLIB OR L_LIBRARY); +* HENTRY(4): read-only type(L_TRACK); +* The object 5 is required if the "MERG CELL" option is used. +* HENTRY(5): optional read-only type(L_GEOM) containing the +* original geometry; +* HENTRY(6): optional read-only type(L_GEOM) containing the +* macrogeometry; +* HENTRY(7): optional read-only type(L_SYS) containing the +* L_PIJ object of the original geometry in cases where a +* Selengut normalization is required. +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40,IOUT=6,MAXED=100,MAXOUT=100) + TYPE(C_PTR) IPEDIT,IPFLUX,IPTRK1,IPLIB,JPMAC,KPMAC,IPGEO1,IPGEO2, + > JPFLUX,IPSYS,IPMRG + CHARACTER*12 TEXT12,CDOOR,OLDGEO,MACGEO,CURNAM,OLDNAM,HSIGN, + > CARISO(MAXED) + CHARACTER TITLE*72,HSMG*131,HVOUT(MAXOUT)*8 + INTEGER IGP(NSTATE),IDATA(NSTATE),ISTATE(NSTATE) + LOGICAL LNEWGE,LISO,LDEPL,LMACR,LREMIX + INTEGER, ALLOCATABLE, DIMENSION(:) :: KEYFL,MAT,IDL,IGCOND,IMERGE, + > IACTI,IGCR,IREMIX + REAL, ALLOCATABLE, DIMENSION(:) :: VOL,FLINT,ENERG,ENERV,ECR +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.LT.2) CALL XABORT('EDI: MORE RHS LCM OBJECTS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('EDI: LC' + > //'M OBJECT EXPECTED AT LHS.') + + IPEDIT=KENTRY(1) + IF(JENTRY(1) .EQ. 0) THEN + HSIGN='L_EDIT' + CALL LCMPTC(IPEDIT,'SIGNATURE',12,HSIGN) + ELSE IF(JENTRY(1) .EQ. 1) THEN + CALL LCMGTC(IPEDIT,'SIGNATURE',12,HSIGN) + IF(HSIGN .NE. 'L_EDIT') THEN + TEXT12=HENTRY(1) + CALL XABORT('EDI: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + > '. L_EDIT EXPECTED.') + ENDIF + ELSE + CALL XABORT('EDI: EDITING LCM OBJECT IN CREATE OR MODIFY MODE ' + > //'EXPECTED.') + ENDIF +*---- +* SCAN READ-ONLY MODE DATA STRUCTURE ENTRY(2) TO ENTRY(4) +* FOR FLUX, TRACK AND LIB +*---- + IF(JENTRY(2).NE.2) CALL XABORT('EDI: LCM OBJECT IN READ-ONLY MOD' + > //'E EXPECTED AT RHS.') + IPFLUX=C_NULL_PTR + IKFLUX=0 + IPTRK1=C_NULL_PTR + IKTRK1=0 + IPLIB=C_NULL_PTR + IKLIB=0 + DO 10 IEN=2,MIN(4,NENTRY) + IF((IENTRY(IEN).EQ.1).OR.(IENTRY(IEN).EQ.2)) THEN + CALL LCMGTC(KENTRY(IEN),'SIGNATURE',12,HSIGN) + IF((HSIGN.EQ.'L_FLUX').AND.(IKFLUX.EQ.0)) THEN + IPFLUX=KENTRY(IEN) + IKFLUX=IEN + ELSE IF((HSIGN.EQ.'L_TRACK').AND.(IKTRK1.EQ.0)) THEN + IPTRK1=KENTRY(IEN) + IKTRK1=IEN + ELSE IF((HSIGN.EQ.'L_LIBRARY').AND.(IKLIB.EQ.0)) THEN + IPLIB=KENTRY(IEN) + IKLIB=IEN + ELSE IF((HSIGN.EQ.'L_MACROLIB').AND.(IKLIB.EQ.0)) THEN + IPLIB=KENTRY(IEN) + IKLIB=-IEN + ENDIF + ENDIF + 10 CONTINUE +*---- +* READ MACROLIB INFORMATION +*---- + IF(IKLIB.EQ.0) CALL XABORT('EDI: NO MACROLIB OR MICROLIB LCM OBJ' + > //'ECT FOUND.') + IF(IKLIB.GT.0) THEN + CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) + MAXISM=ISTATE(22) + CALL LCMSIX(IPLIB,'MACROLIB',1) + ELSE + MAXISM=1 + ENDIF + CALL LCMGET(IPLIB,'STATE-VECTOR',IDATA) + NGRP=IDATA(1) + NBMIX=IDATA(2) + NL=IDATA(3) + NIFISS=IDATA(4) + NEDMAC=IDATA(5) + ITRANC=IDATA(6) + NDEL=IDATA(7) + NALBP=IDATA(8) + IDFM=IDATA(12) +*---- +* BUILD L_TRACK AND L_FLUX OBJECTS FROM EXTENDED MACROLIB +*---- + IF((IKTRK1.EQ.0).AND.(IKFLUX.EQ.0)) THEN + CALL LCMOP(IPTRK1,'PSEUDO_TRACK',0,1,0) + CALL LCMOP(IPFLUX,'PSEUDO_FLUX',0,1,0) + HSIGN='L_TRACK' + CALL LCMPTC(IPTRK1,'SIGNATURE',12,HSIGN) + HSIGN='L_FLUX' + CALL LCMPTC(IPFLUX,'SIGNATURE',12,HSIGN) + TEXT12='DUMMY' + CALL LCMPTC(IPTRK1,'TRACK-TYPE',12,TEXT12) + ALLOCATE(KEYFL(NBMIX)) + DO 20 IBM=1,NBMIX + KEYFL(IBM)=IBM + 20 CONTINUE + CALL LCMPUT(IPTRK1,'MATCOD',NBMIX,1,KEYFL) + CALL LCMPUT(IPTRK1,'KEYFLX',NBMIX,1,KEYFL) + DEALLOCATE(KEYFL) + ALLOCATE(VOL(NBMIX)) + CALL LCMLEN(IPLIB,'VOLUME',ILONG,ITYLCM) + IF(ILONG.EQ.0) CALL XABORT('EDI: NO VOLUME IN MACROLIB.') + CALL LCMGET(IPLIB,'VOLUME',VOL) + CALL LCMPUT(IPTRK1,'VOLUME',NBMIX,2,VOL) + ISTATE(:NSTATE)=0 + ISTATE(1)=NBMIX + ISTATE(2)=NBMIX + ISTATE(4)=NBMIX + CALL LCMPUT(IPTRK1,'STATE-VECTOR',NSTATE,1,ISTATE) + ALLOCATE(FLINT(NBMIX)) + JPMAC=LCMGID(IPLIB,'GROUP') + JPFLUX=LCMLID(IPFLUX,'FLUX',NGRP) + DO 40 IGR=1,NGRP + KPMAC=LCMGIL(JPMAC,IGR) + CALL LCMLEN(KPMAC,'FLUX-INTG',ILONG,ITYLCM) + IF(ILONG.EQ.0) CALL XABORT('EDI: NO FLUX-INTG IN MACROLIB.') + CALL LCMGET(KPMAC,'FLUX-INTG',FLINT) + DO 30 IBM=1,NBMIX + FLINT(IBM)=FLINT(IBM)/VOL(IBM) + 30 CONTINUE + CALL LCMPDL(JPFLUX,IGR,NBMIX,2,FLINT) + 40 CONTINUE + DEALLOCATE(FLINT,VOL) + CALL LCMLEN(IPLIB,'K-EFFECTIVE',ILONG,ITYLCM) + IF(ILONG.EQ.1) THEN + CALL LCMGET(IPLIB,'K-EFFECTIVE',FLOAT) + CALL LCMPUT(IPFLUX,'K-EFFECTIVE',1,2,FLOAT) + ENDIF + CALL LCMLEN(IPLIB,'K-INFINITY',ILONG,ITYLCM) + IF(ILONG.EQ.1) THEN + CALL LCMGET(IPLIB,'K-INFINITY',FLOAT) + CALL LCMPUT(IPFLUX,'K-INFINITY',1,2,FLOAT) + ENDIF + ISTATE(:NSTATE)=0 + ISTATE(1)=NGRP + ISTATE(2)=NBMIX + CALL LCMPUT(IPFLUX,'STATE-VECTOR',NSTATE,1,ISTATE) + ENDIF + IF(IKLIB.GT.0) CALL LCMSIX(IPLIB,' ',2) + IF(.NOT.C_ASSOCIATED(IPFLUX)) THEN + CALL XABORT('EDI: NO REFERENCE FLUX AVAILABLE.') + ENDIF + CALL LCMGET(IPFLUX,'STATE-VECTOR',ISTATE) + ILEAKC=ISTATE(7) +*---- +* READ GEOMETRIES AND SYSTEM +*---- + IPGEO1=C_NULL_PTR + IKGEO1=0 + IPGEO2=C_NULL_PTR + IKGEO2=0 + IPSYS=C_NULL_PTR + IKSYS=0 + OLDGEO=' ' + IFGEO=0 + IF(NENTRY.GT.4) THEN + DO 70 IEN=5,NENTRY + IF((IENTRY(IEN).EQ.1).OR.(IENTRY(IEN).EQ.2)) THEN + CALL LCMGTC(KENTRY(IEN),'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_GEOM') THEN + IF(IKGEO1.EQ.0) THEN + IPGEO1=KENTRY(IEN) + OLDGEO=HENTRY(IEN) + IKGEO1=IEN + ELSE IF(IKGEO2.EQ.0) THEN + IPGEO2=KENTRY(IEN) + IKGEO2=IEN + ENDIF + ELSE IF((HSIGN.EQ.'L_PIJ').AND.(IKSYS.EQ.0)) THEN + IPSYS=KENTRY(IEN) + IKSYS=IEN + ENDIF + ELSE IF((IENTRY(IEN).EQ.4).AND.(JENTRY(IEN).EQ.2)) THEN + IFGEO=FILUNIT(KENTRY(IEN)) + ELSE + CALL XABORT('EDI: INVALID TYPE AT RHS.') + ENDIF + 70 CONTINUE + ENDIF +*---- +* RECOVER GENERAL TRACKING INFORMATION +*---- + IF(.NOT.C_ASSOCIATED(IPTRK1)) THEN + CALL XABORT('EDI: NO REFERENCE TRACKING AVAILABLE.') + ENDIF + CALL LCMGET(IPTRK1,'STATE-VECTOR',IGP) + NREG=IGP(1) + CALL LCMGTC(IPTRK1,'TRACK-TYPE',12,CDOOR) + IF(CDOOR.EQ.'MCCG') THEN + CALL LCMLEN(IPTRK1,'KEYFLX',LKFL,ITYLCM) + NFUNL=LKFL/NREG + ELSE + NFUNL=1 + ENDIF + ALLOCATE(MAT(NREG),VOL(NREG),IDL(NREG*NFUNL)) + CALL LCMGET(IPTRK1,'MATCOD',MAT) + CALL LCMGET(IPTRK1,'VOLUME',VOL) + CALL LCMGET(IPTRK1,'KEYFLX',IDL) + CALL LCMLEN(IPTRK1,'TITLE',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGTC(IPTRK1,'TITLE',72,TITLE) + CALL LCMPTC(IPEDIT,'TITLE',72,TITLE) + ELSE + TITLE='*** NO TITLE PROVIDED FOR THE REFERENCE CASE ***' + ENDIF +*---- +* READ GROUP STRUCTURE +*---- + ALLOCATE(ENERG(2*NGRP+1),ENERV(NGRP)) + CALL LCMLEN(IPLIB,'ENERGY',NTENER,ITYLCM) + IF(NTENER.EQ.NGRP+1) THEN + CALL LCMGET(IPLIB,'ENERGY',ENERG) + ELSE IF(NTENER.NE.0) THEN + CALL XABORT('EDI: INVALID NUMBER OF GROUP ON MACROLIB.') + ENDIF +*---- +* READ EDITION OPTIONS PARAMETERS +*---- + ALLOCATE(IGCOND(NGRP),IMERGE(NREG),IACTI(NBMIX)) + ICALL=0 + CURNAM=' ' + MAXCND=0 + MAXISK=0 + MAXMRG=0 + ITMERG=-4 + BB2=0.0 + IF(JENTRY(1).EQ.0) THEN + HSIGN='L_EDIT' + CALL LCMPTC(IPEDIT,'SIGNATURE',12,HSIGN) + OLDNAM=' ' + MACGEO=' ' + NMERGE=NREG + NGCOND=NGRP + IHF=1 + IFFAC=0 + ILUPS=0 + NACTI=0 + NSTATS=0 + IADF=0 + NBMICR=0 + IPRINT=1 + NSAVES=0 + NW=0 + IF(ILEAKC.GE.6) NW=1 + ICURR=NW + IXEDI=0 + IADJ=0 + IEUR=0 + NOUT=0 + IEDCUR=0 + IGOVE=0 + MAXPTS=NREG + DO 90 IGROUP=1,NGRP + IGCOND(IGROUP)=IGROUP + 90 CONTINUE + DO 100 IREGIO=1,NREG + IMERGE(IREGIO)=IREGIO + 100 CONTINUE + ELSE IF(JENTRY(1).EQ.1) THEN + CALL LCMGTC(IPEDIT,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_EDIT') THEN + TEXT12=HENTRY(1) + CALL XABORT('EDI: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + > '. L_EDIT EXPECTED.') + ENDIF + CALL LCMGET(IPEDIT,'STATE-VECTOR',ISTATE) + NMERGE=ISTATE(1) + NGCOND=ISTATE(2) + IFFAC=ISTATE(3) + ILUPS=ISTATE(4) + NACTI=ISTATE(5) + NSTATS=ISTATE(6) + IADF=ISTATE(7) + IEUR=ISTATE(8) + NBMICR=ISTATE(9) + IPRINT=ISTATE(10) + NSAVES=ISTATE(11) + NW=ISTATE(12) + MAXISK=ISTATE(13) + MAXCND=ISTATE(14) + MAXMRG=ISTATE(15) + IXEDI=ISTATE(16) + MAXPTS=ISTATE(17) + IHF=ISTATE(18) + IF(ISTATE(19).NE.NDEL) CALL XABORT('EDI: BAD VALUE OF NDEL') + IADJ=ISTATE(21) + ICURR=ISTATE(22) + NOUT=ISTATE(23) + IEDCUR=ISTATE(24) + IGOVE=ISTATE(25) + IF(NOUT.GT.MAXOUT) CALL XABORT('EDI: MAXOUT OVERFLOW') + CALL LCMLEN(IPEDIT,'LAST-EDIT',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGTC(IPEDIT,'LAST-EDIT',12,OLDNAM) + INTLIR=0 + READ(OLDNAM,'(8X,I4)',ERR=105) INTLIR + 105 ICALL=MAX(ICALL,INTLIR) + ENDIF + CALL LCMLEN(IPEDIT,'REF:IMERGE',LENGT,ITYLCM) + IF(LENGT.EQ.NREG) THEN + CALL LCMGET(IPEDIT,'REF:IMERGE',IMERGE) + ELSE + DO 106 IREGIO=1,NREG + IMERGE(IREGIO)=IREGIO + 106 CONTINUE + ENDIF + CALL LCMLEN(IPEDIT,'REF:IGCOND',LENGT,ITYLCM) + IF(LENGT.EQ.NGCOND) THEN + CALL LCMGET(IPEDIT,'REF:IGCOND',IGCOND) + ELSE + DO 107 IGROUP=1,NGRP + IGCOND(IGROUP)=IGROUP + 107 CONTINUE + ENDIF + CALL LCMLEN(IPEDIT,'LINK.MACGEOM',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGTC(IPEDIT,'LINK.MACGEOM',12,MACGEO) + ELSE + MACGEO=' ' + ENDIF + IF(NBMICR.GT.0) THEN + IF(NBMICR.GT.MAXED) CALL XABORT('EDI: CARISO OVERFLOW.') + CALL LCMGTC(IPEDIT,'CARISO',12,NBMICR,CARISO) + ENDIF + IF(NACTI.GT.0) CALL LCMGET(IPEDIT,'IACTI',IACTI) + IF(NOUT.GT.0) CALL LCMGTC(IPEDIT,'REF:HVOUT',8,NOUT,HVOUT) + ENDIF + NGCR=0 + LISO=.FALSE. + LDEPL=.TRUE. + LMACR=.TRUE. + MAXISK=MAX(MAXISK,MAXISM) + ALLOCATE(IGCR(NGRP+1),ECR(NGRP+1)) + IGCR(:NGRP+1)=NGRP + ECR(:NGRP+1)=0.0 + CALL EDIGET(IPEDIT,IFGEO,NGRP,NGCR,NREG,NBMIX,MAT,ITMERG,NMERGE, + 1 IHF,IFFAC,ILUPS,NSAVES,NSTATS,IGCR,ECR,IMERGE,CURNAM,OLDNAM,IADF, + 2 NW,ICURR,NBMICR,CARISO,NACTI,IACTI,IPRINT,MAXPTS,ICALL,ISOTXS, + 3 LISO,LDEPL,LMACR,IADJ,MACGEO,IEUR,NOUT,HVOUT,BB2,IEDCUR,IGOVE) + IF((IGOVE.EQ.1).AND.(ILEAKC.GE.6)) THEN + CALL XABORT('EDI: OPTION NOIN IS FORBIDDEN.') + ENDIF +*---- +* CALL EDIMRG TO FIND MERGE INDEX ASSOCIATED WITH THE SECOND GEOMETRY +* OR TRACK FILE (EQUIGEOM CAPABILITIES) +*---- + TEXT12=' ' + LNEWGE=.FALSE. + IF(ITMERG.EQ.-1) THEN + IF(IKGEO2.GT.0) THEN + ITM=-1 + IPMRG=IPGEO2 + TEXT12=HENTRY(IKGEO2) + ELSE IF(IKGEO1.GT.0) THEN + ITM=-1 + IPMRG=IPGEO1 + TEXT12=HENTRY(IKGEO1) + ELSE + ITM=0 + IPMRG=IPTRK1 + ENDIF + CALL EDIMRG(IPTRK1,IPMRG,IPRINT,TEXT12,ITM,NREG,NMERGE,IMERGE) +*---- +* BUILD A MACRO-GEOMETRY FROM REFERENCE GEOMETRY OLDGEO (CELL OPTION) +*---- + ELSE IF(ITMERG.EQ.-2) THEN + LREMIX=(NMERGE.NE.0) + IF(LREMIX) THEN +* REMIX option. + NMEOLD=NMERGE + NMERGE=0 + ALLOCATE(IREMIX(NMEOLD)) + IREMIX(:NMEOLD)=IMERGE(:NMEOLD) + ENDIF + IF(((CDOOR.EQ.'EXCELL').OR.(CDOOR.EQ.'MCCG')).AND. + > (IGP(7).EQ.4)) THEN + CALL EDIMRC(IPTRK1,IPRINT,NREG,NMERGE,IMERGE) + ELSE + IF(.NOT.C_ASSOCIATED(IPGEO1)) THEN + CALL XABORT('EDI: NO REFERENCE GEOMETRY AVAILABLE.') + ELSE IF(C_ASSOCIATED(IPGEO2)) THEN + CALL XABORT('EDI: INPUT MACRO-GEOMETRY NOT EXPECTED WITH ' + > //'CELL OPTION.') + ENDIF + IF(IPRINT.GT.0) WRITE(IOUT,190) OLDGEO,CDOOR + CALL LCMGET(IPGEO1,'STATE-VECTOR',ISTATE) + MAXGEO=MAX(MAXPTS,ISTATE(6)) + IF(IEUR.EQ.4) MAXGEO=8*MAXGEO + LNEWGE=.TRUE. + MACGEO='MACRO$GEO' + CALL LCMOP(IPGEO2,'MACRO$GEO',0,1,9) + MAXMER=MIN(NREG,MAXGEO) + CALL EDIGEO(MAXGEO,MAXMER,IPGEO1,IPGEO2,IPRINT,NREG,IEUR, + > NMERGE,IMERGE) +* +* COPY THE MACRO-GEOMETRY INTO THE EDITION OBJECT. + CALL LCMSIX(IPEDIT,'MACRO-GEOM',1) + CALL LCMEQU(IPGEO2,IPEDIT) + CALL LCMSIX(IPEDIT,' ',2) + ENDIF + IF(LREMIX) THEN +* REMIX option. + IF(NMERGE.NE.NMEOLD) THEN + WRITE(HSMG,'(37HEDI: INVALID NUMBER OF REMIX INDICES:, + > I5,11H ARE GIVEN;,I5,14H ARE EXPECTED.)') NMEOLD,NMERGE + CALL XABORT(HSMG) + ENDIF + NMERGE=0 + DO IREG=1,NREG + IF(IMERGE(IREG).GT.NMEOLD) CALL XABORT('EDI: NMERGE OVERF' + > //'LOW IN REMIX.') + IF(IMERGE(IREG).NE.0) IMERGE(IREG)=IREMIX(IMERGE(IREG)) + NMERGE=MAX(NMERGE,IMERGE(IREG)) + ENDDO + DEALLOCATE(IREMIX) + ENDIF + ELSE IF(ITMERG.EQ.-3) THEN +*---- +* CALL EDIMRG TO FIND MERGE INDEX ASSOCIATED WITH HMIX +*---- + IPMRG=IPTRK1 + CALL EDIHMX(IPTRK1,NREG,NMERGE,IMERGE) + ENDIF +*---- +* SET THE ANISOTROPY OF WEIGHTING FLUXES +*---- + IF((NW.GT.0).AND.(ICURR.EQ.4)) THEN + CALL LCMGTC(IPTRK1,'TRACK-TYPE',12,TEXT12) + NANIS=1 + IF(TEXT12.EQ.'MCCG') THEN + CALL LCMGET(IPTRK1,'STATE-VECTOR',ISTATE) + NANIS=ISTATE(6) + ELSE IF(TEXT12.EQ.'SN') THEN + CALL LCMGET(IPTRK1,'STATE-VECTOR',ISTATE) + NANIS=ISTATE(16) + ELSE + CALL XABORT('EDI: MCCG OR SN TRACKING EXPECTED WITH P1W_SP ' + > //'OPTION') + ENDIF + NW=NANIS-1 + IF(IPRINT.GT.0) WRITE(IOUT,'(/15H EDI: NW SET TO,I3,1H.)') + > NW + IF(NW.EQ.0) CALL XABORT('EDI: NW>0 EXPECTED.') + ENDIF +*---- +* TEST ENERGY CONDENSATION INPUT +*---- + CALL EDIENE(NGRP,NGCR,NGCOND,NTENER,IGCR,ECR,IGCOND,ENERG,ENERV) +* + CALL LCMLEN(IPEDIT,'MACRO-GEOM',ILONG,ITYLCM) + LGEO=0 + IF((ILONG.NE.0).OR.(MACGEO.NE.' ')) LGEO=1 + IF(IPRINT.GT.0) THEN + WRITE(IOUT,200) NMERGE,NGCOND,IFFAC,ILUPS,NACTI,NSTATS,IADF, + > IEUR,NBMICR,IPRINT + WRITE(IOUT,210) NSAVES,NW,MAXPTS,IHF,NDEL,LGEO,IADJ,ICURR, + > NOUT,IEDCUR,IGOVE + WRITE(IOUT,'(//15H MERGING INDEX:/(1X,14I5))') + > (IMERGE(I),I=1,NREG) + IF(CURNAM.NE.' ') WRITE(IOUT,'(/27H EDI: SAVE MICROLIB INFO ON, + > 12H DIRECTORY '',A12,2H''.)') CURNAM + ENDIF + DEALLOCATE(ECR,IGCR) + ISTATE(:NSTATE)=0 + ISTATE(1)=NMERGE + ISTATE(2)=NGCOND + ISTATE(3)=IFFAC + ISTATE(4)=ILUPS + ISTATE(5)=NACTI + ISTATE(6)=NSTATS + ISTATE(7)=IADF + ISTATE(8)=IEUR + ISTATE(9)=NBMICR + ISTATE(10)=IPRINT + ISTATE(11)=NSAVES + ISTATE(12)=NW + ISTATE(13)=MAXISK + ISTATE(14)=MAX(NGCOND,MAXCND) + ISTATE(15)=MAX(NMERGE,MAXMRG) + ISTATE(16)=IXEDI+ISOTXS*NMERGE + ISTATE(17)=MAXPTS + ISTATE(18)=IHF + ISTATE(19)=NDEL + ISTATE(20)=LGEO + ISTATE(21)=IADJ + ISTATE(22)=ICURR + ISTATE(23)=NOUT + ISTATE(24)=IEDCUR + ISTATE(25)=IGOVE + CALL LCMPUT(IPEDIT,'STATE-VECTOR',NSTATE,1,ISTATE) + IF(OLDGEO.NE.' ') THEN + CALL LCMPTC(IPEDIT,'LINK.GEOM',12,OLDGEO) + ENDIF + IF(NSAVES.GE.2) THEN + CALL LCMPTC(IPEDIT,'LAST-EDIT',12,CURNAM) + ENDIF + IF(NBMICR.GT.0) THEN + CALL LCMPTC(IPEDIT,'CARISO',12,NBMICR,CARISO) + ENDIF + IF(NACTI.GT.0) CALL LCMPUT(IPEDIT,'IACTI',NACTI,1,IACTI) + IF(MACGEO.NE.' ') THEN + IF(HENTRY(IKGEO1).EQ.MACGEO) THEN + IPGEO2=IPGEO1 + IKGEO2=IKGEO1 + ENDIF + IF(.NOT.C_ASSOCIATED(IPGEO2)) THEN + CALL XABORT('EDI: MISSING LCM OBJECT FOR THE MACRO-GEOMETR' + > //'Y.') + ENDIF + IF(IKGEO2.NE.0) THEN + IF(HENTRY(IKGEO2).NE.MACGEO) THEN + WRITE(HSMG,'(33HEDI: WRONG MACRO-GEOMETRY NAMED '', + > A12,17H'' FOUND ON RHS. '',A12,11H'' EXPECTED.)') + > HENTRY(IKGEO2),MACGEO + CALL XABORT(HSMG) + ENDIF + ENDIF + CALL LCMGTC(IPGEO2,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_GEOM') THEN + CALL XABORT('EDI: SIGNATURE OF '//MACGEO//' IS '//HSIGN// + > '. L_GEOM EXPECTED.') + ENDIF +* +* COPY THE MACRO-GEOMETRY INTO THE EDITION OBJECT. + CALL LCMSIX(IPEDIT,'MACRO-GEOM',1) + CALL LCMEQU(IPGEO2,IPEDIT) + CALL LCMSIX(IPEDIT,' ',2) + ENDIF +*---- +* EDITION +*---- + IF(NREG.EQ.0) CALL XABORT('EDI: NREG = 0.') + IF(NGRP.EQ.0) CALL XABORT('EDI: NGRP = 0.') + CALL EDIDRV(IPEDIT,IPTRK1,IPFLUX,IPLIB,IPSYS,NGRP,NBMIX,NREG,MAT, + 1 VOL,IDL,NIFISS,NEDMAC,NL,NDEL,NALBP,ITRANC,NGCOND,NMERGE,IADF, + 2 IDFM,NW,ICURR,IHF,IFFAC,ILUPS,NSAVES,NSTATS,IXEDI,ISOTXS,IGCOND, + 3 IMERGE,CURNAM,OLDNAM,NBMICR,CARISO,NACTI,IACTI,IPRINT,LISO,LDEPL, + 4 LMACR,IADJ,NOUT,HVOUT,BB2,IEDCUR,IGOVE) +*---- +* DESTROY THE TEMPORARY MACRO-GEOMETRY +*---- + IF(LNEWGE) THEN + CALL LCMCL(IPGEO2,1) + TEXT12='MACRO$GEO' + CALL LCMOP(IPGEO2,TEXT12,1,1,0) + CALL LCMCL(IPGEO2,2) + ENDIF +*---- +* COMPLETE THE EDITION LCM OBJECT +*---- + CALL LCMPUT(IPEDIT,'REF:IMERGE',NREG,1,IMERGE) + CALL LCMPUT(IPEDIT,'REF:MATCOD',NREG,1,MAT) + CALL LCMPUT(IPEDIT,'REF:VOLUME',NREG,2,VOL) + CALL LCMPUT(IPEDIT,'REF:IGCOND',NGCOND,1,IGCOND) + IF(NOUT.GT.0) CALL LCMPTC(IPEDIT,'REF:HVOUT',8,NOUT,HVOUT) +* + DEALLOCATE(IACTI,IMERGE,IGCOND) +*---- +* RELEASE GENERAL TRACKING INFORMATION +*---- + DEALLOCATE(IDL,VOL,MAT,ENERV,ENERG) + IF(IPRINT.GT.2) CALL LCMLIB(IPEDIT) +*---- +* RELEASE TEMPORARY L_TRACK AND L_FLUX OBJECTS +*---- + IF((IKTRK1.EQ.0).AND.(IKFLUX.EQ.0)) THEN + CALL LCMCL(IPFLUX,2) + CALL LCMCL(IPTRK1,2) + ENDIF + RETURN +* + 190 FORMAT (/16H EDI: GEOMETRY ',A12,28H' WAS PREVIOUSLY TRACKED BY , + > 7HMODULE ,A12,1H.) + 200 FORMAT(/24H EDITION-RELATED OPTIONS/1X,23(1H-)/ + 1 7H NMERGE,I8,29H (NUMBER OF MERGED REGIONS)/ + 2 7H NGCOND,I8,38H (NUMBER OF CONDENSED ENERGY GROUPS)/ + 3 7H IFFAC ,I8,40H (=1: 4 FACTORS CALCULATION REQUESTED)/ + 4 7H ILUPS ,I8,43H (=1: REMOVE UP-SCATTERING CONTRIBUTIONS)/ + 5 7H NACTI ,I8,45H (NUMBER OF MIXTURES WITH ACTIVATION EDITS)/ + 6 7H NSTATS,I8,35H (TYPE OF STATISTIC CALCULATIONS)/ + 7 7H IADF ,I8,47H (=0: DO NOT COMPUTE ADF; =1: USE ALBS INFO; , + 8 60H=-2/2: USE BOUNDARY FLUX INFO; =3: USE EURYDICE INFO; =4: US, + 9 16HE MACROLIB INFO)/ + 1 7H IEUR ,I8,47H (=1/2/3: SYBIL OR EXCELL MACRO-TRACKING/NXT , + 2 20HMACRO-TRACKING/ELSE)/ + 3 7H NBMICR,I8,47H (=-1: PROCESS ALL ISOTOPES; >1: NUMBER OF IS, + 4 18HOTOPES TO PROCESS)/ + 5 7H IPRINT,I8,16H (PRINT LEVEL)) + 210 FORMAT( + 1 7H NSAVES,I8,47H (=0: NO COMPUTE/NO SAVE; =1: COMPUTE/NO SAVE, + 2 19H; =2: COMPUTE/SAVE)/ + 3 7H NW ,I8,47H (=0: FLUX WEIGHTING FOR P1 INFO; =1: CURRENT, + 4 23H WEIGHTING FOR P1 INFO)/ + 5 7H MAXPTS,I8,47H (ALLOCATED STORAGE LENGTH FOR REGION-DEPENDE, + 6 10HNT ARRAYS)/ + 7 7H IHF ,I8,39H (=1: H-FACTOR CALCULATION REQUESTED)/ + 8 7H NDEL ,I8,39H (NUMBER OF DELAYED PRECURSOR GROUPS)/ + 9 7H LGEO ,I8,47H (=0: MACRO-GEOMETRY NOT AVAILABLE; =1: IS AV, + 1 8HAILABLE)/ + 2 7H IADJ ,I8,47H (=0: DIRECT FLUX; =1: DIRECT-ADJOINT WEIGHTI, + 3 3HNG)/ + 4 7H ICURR ,I8,47H (=1: HETEROGENEOUS BN WEIGHTING; =2: TODOROV, + 5 58HA OUTSCATTER WEIGHTING; =4: SPHERICAL HARMONICS WEIGHTING)/ + 6 7H NOUT ,I8,47H (=0: OUTPUT ALL REACTIONS; >0: NUMBER OF OUT, + 7 14HPUT REACTIONS)/ + 8 7H IEDCUR,I8,40H (=0/1: FLUX/FLUX AND CURRENT EDITION)/ + 9 7H GOLVER,I8,38H (=0/1: GOLFIER-VERGAIN FLAG OFF/ON)) + END diff --git a/Dragon/src/EDIACT.f b/Dragon/src/EDIACT.f new file mode 100644 index 0000000..f45201a --- /dev/null +++ b/Dragon/src/EDIACT.f @@ -0,0 +1,455 @@ +*DECK EDIACT + SUBROUTINE EDIACT(IPEDIT,IPRINT,NGROUP,NGCOND,NREGIO,NMERGE,NL, + > NBISO,NED,VOLUME,MIX,IGCOND,IMERGE,FLUXES, + > ITRANC,ISONAM,IPISO,HVECT,CURNAM,NACTI,IACTI, + > EMEVF2,EMEVG2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Homogenization and condensation of activation cross sections. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPEDIT pointer to the edition LCM object. +* IPRINT print index. +* NGROUP number of energy groups. +* NGCOND number of condensed groups. +* NREGIO number of volumes. +* NMERGE number of merged regions. +* NL number of legendre orders required in the calculation +* (NL=1 or higher). +* NBISO number of isotopes. +* NED number of extra vector edits. +* VOLUME volumes. +* MIX mixture number associated with each isotope. +* IGCOND limits of condensed groups. +* IMERGE index of merged regions. +* FLUXES fluxes. +* ITRANC transport correction type (0 -> no transport correction). +* ISONAM names of the isotopes to be treated. +* IPISO pointer array towards microlib isotopes. +* HVECT names of the extra vector edits. +* CURNAM name of the lcm directory where the microscopic cross +* sections are stored (blank name implies no save). +* NACTI number of mixture with WIMS activation edit. +* IACTI mixtures with activation edits. +* EMEVF2 fission production energy. +* EMEVG2 capture production energy. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPEDIT,IPISO(NBISO) + CHARACTER HVECT(*)*8,CURNAM*(*) + INTEGER IPRINT,NGROUP,NGCOND,NREGIO,NMERGE,NL,NBISO,NED, + > MIX(NBISO),IGCOND(NGCOND),IMERGE(NREGIO),ITRANC, + > ISONAM(3,NBISO),NACTI,IACTI(NACTI) + REAL VOLUME(NREGIO),FLUXES(NREGIO,NGROUP), + > EMEVF2(NBISO),EMEVG2(NBISO) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IOUT=6,NSTATE=40) + TYPE(C_PTR) KPLIB + INTEGER IPAR(NSTATE) + CHARACTER CACTI*12,CM*2,HMAKE(100)*8,HNEW*12,TEXT12*12,HSMG*131 + LOGICAL LMEVF,LMEVG,LLCM + DOUBLE PRECISION DVOL,DFLI,DTMP,QEN,ERR + INTEGER, ALLOCATABLE, DIMENSION(:) :: ISOMIX + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: KCJJ,HNISO + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: KFJJ + REAL, ALLOCATABLE, DIMENSION(:) :: CXSV,CSCAT + REAL, ALLOCATABLE, DIMENSION(:,:) :: RXSV,RSCAT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: DFLX,DXSV + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: DSCAT +*---- +* SCRATCH STORAGE ALLOCATION +* RXSV real microscopic cross section/flux (vector- full group +* structure): +* RXSV(ig,1->NL) = total scattering order 0 to NL-1; +* RXSV(ig,1+NL) = total xs; +* RXSV(ig,2+NL) = nusigf; +* RXSV(ig,3+NL->2+NL+NED) = additional xs; +* RXSV(ig,3+NL+NED)= tranc; +* RXSV(ig,4+NL+NED)= chi. +* KFJJ scattering vector index (vector- full group structure). +* RSCAT real microscopic scattering x-s (vector- full group +* structure): +* DFLX double flux. +* DXSV double microscopic reaction rates (vector- condensed group +* structure). +* DSCAT microscopic scattering rate (vector- condensed group +* structure). +* CXSV real microscopic cross section/flux (vector- condensed +* group structure). +* KCJJ scattering vector index (vector- condensed group structure). +* CSCAT real microscopic scattering rate (vector- condensed group +* structure). +* HNISO isotope name vector. +* ISOMIX mixture number associated with new isotope. +*---- + ALLOCATE(ISOMIX(NACTI*NMERGE*NBISO),KFJJ(NGROUP,3,NL), + > KCJJ(NGCOND,2),HNISO(3,NACTI*NMERGE*NBISO)) + ALLOCATE(RXSV(NGROUP,NL+NED+4),RSCAT(NGROUP*NGROUP,NL), + > CXSV(NGCOND),CSCAT(NGCOND*NGCOND)) + ALLOCATE(DFLX(NGCOND,NMERGE),DXSV(NGCOND,NL+NED+4), + > DSCAT(NGCOND,NGCOND,NL)) +*---- +* EVALUATE INTEGRATED FLUX +*---- + DO 10 INM=1,NMERGE + DO 11 IGRCND=1,NGCOND + DFLX(IGRCND,INM)=0.0D0 + 11 CONTINUE + DO 20 IREGIO=1,NREGIO + IF(IMERGE(IREGIO).EQ.INM) THEN + IGRFIN=0 + DO 21 IGRCND=1,NGCOND + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGRCND) + DTMP=0.0D0 + DO 22 IGR=IGRDEB,IGRFIN + DTMP=DTMP+DBLE(FLUXES(IREGIO,IGR)) + 22 CONTINUE + DFLX(IGRCND,INM)=DFLX(IGRCND,INM)+ + > DTMP*DBLE(VOLUME(IREGIO)) + 21 CONTINUE + ENDIF + 20 CONTINUE + 10 CONTINUE +*---- +* LOOP OVER EACH MIXTURE WITH ACTIVATION EDIT +* FIND ISOTOPES ASSOCIATED WITH THIS MIXTURE +*---- + LLCM=CURNAM.NE.' ' + MAXH=4+NL+NED + DO 100 IRE=1,NACTI + IMIXR=IACTI(IRE) + WRITE(CACTI,'(8HACTIVITY,I4)') IRE + IF(IPRINT.GT.0) WRITE(IOUT,300) IMIXR,CACTI + JJISO=0 + DO 110 ISO=1,NBISO + IF(MIX(ISO).EQ.IMIXR) THEN + IF(IPRINT.GT.0) WRITE(IOUT,310) (ISONAM(I0,ISO),I0=1,2) +*---- +* THIS ISOTOPE IS ASSOCIATED WITH AN ACTIVATION MIXTURE +* READ MICROSCOPIC CROSS SECTIONS 'SIGS'//CM, 'SCAT'//CM, 'NTOT0', +* 'NUSIGF', 'CHI', HVECT. +*---- + DO 114 INAM=1,MAXH+NL + HMAKE(INAM)=' ' + 114 CONTINUE + KPLIB=IPISO(ISO) ! set ISO-th isotope + IF(.NOT.C_ASSOCIATED(KPLIB)) THEN + WRITE(HSMG,'(17HEDIACT: ISOTOPE '',3A4,16H'' IS NOT AVAILAB, + > 19HLE IN THE MICROLIB.)') (ISONAM(I0,ISO),I0=1,3) + CALL XABORT(HSMG) + ENDIF + CALL LCMGET(KPLIB,'AWR',AWR) + IF(EMEVF2(ISO).GT.0.0) EVF=EMEVF2(ISO) + CALL LCMLEN(KPLIB,'MEVF',LENGTH,ITYLCM) + IF(LENGTH.EQ.1) CALL LCMGET(KPLIB,'MEVF',EVF) + LMEVF=(LENGTH.EQ.1).OR.(EMEVF2(ISO).GT.0.0) + IF(EMEVG2(ISO).GT.0.0) EVG=EMEVG2(ISO) + CALL LCMLEN(KPLIB,'MEVG',LENGTH,ITYLCM) + IF(LENGTH.EQ.1) CALL LCMGET(KPLIB,'MEVG',EVG) + LMEVG=(LENGTH.EQ.1).OR.(EMEVG2(ISO).GT.0.0) + DO 111 IL=1,NL + WRITE (CM,'(I2.2)') IL-1 + CALL LCMLEN(KPLIB,'SIGS'//CM,LENGTH,ITYLCM) + IF(LENGTH.EQ.NGROUP) THEN + CALL LCMGET(KPLIB,'SIGS'//CM,RXSV(1,IL)) + HMAKE(IL)='SIGS'//CM + ELSE + HMAKE(IL)=' ' + ENDIF + CALL LCMLEN(KPLIB,'NJJS'//CM,LENGTH,ITYLCM) + IF(LENGTH.EQ.NGROUP) THEN + CALL LCMGET(KPLIB,'NJJS'//CM,KFJJ(1,1,IL)) + CALL LCMGET(KPLIB,'IJJS'//CM,KFJJ(1,2,IL)) + CALL LCMGET(KPLIB,'SCAT'//CM,RSCAT(1,IL)) + HMAKE(MAXH+IL)=CM + IPO=0 + DO 112 IGR=1,NGROUP + KFJJ(IGR,3,IL)=IPO+1 + IPO=IPO+KFJJ(IGR,1,IL) + 112 CONTINUE + ELSE + HMAKE(MAXH+IL)=' ' + ENDIF + 111 CONTINUE + CALL LCMGET(KPLIB,'NTOT0',RXSV(1,1+NL)) + HMAKE(1+NL)='NTOT0' + CALL LCMLEN(KPLIB,'NUSIGF',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGROUP) THEN + CALL LCMGET(KPLIB,'NUSIGF',RXSV(1,2+NL)) + HMAKE(2+NL)='NUSIGF' + ELSE + HMAKE(2+NL)=' ' + ENDIF + CALL LCMLEN(KPLIB,'CHI',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGROUP) THEN + CALL LCMGET(KPLIB,'CHI',RXSV(1,MAXH)) + HMAKE(MAXH)='CHI' + ELSE + HMAKE(MAXH)=' ' + ENDIF + DO 113 IED=1,NED + CALL LCMLEN(KPLIB,HVECT(IED),LENGTH,ITYLCM) + IF(LENGTH.GT.0) THEN + CALL LCMGET(KPLIB,HVECT(IED),RXSV(1,2+NL+IED)) + HMAKE(2+NL+IED)=HVECT(IED) + ELSE + HMAKE(2+NL+IED)=' ' + ENDIF + 113 CONTINUE + IF(LLCM) THEN + CALL LCMSIX(IPEDIT,CURNAM,1) + CALL LCMSIX(IPEDIT,CACTI,1) + ENDIF + DO 120 INM=1,NMERGE + DVOL=0.0D0 + JJISO=JJISO+1 + DO 121 J=1,MAXH + DO 122 I=1,NGCOND + DXSV(I,J)=0.0D0 + 122 CONTINUE + 121 CONTINUE + DO 123 K=1,NL + DO 124 J=1,NGCOND + DO 125 I=1,NGCOND + DSCAT(I,J,K)=0.0D0 + 125 CONTINUE + 124 CONTINUE + 123 CONTINUE +*---- +* MERGE/CONDENSE REACTIONS 'SIGS'//CM, 'SCAT'//CM, 'NTOT0', +* 'NUSIGF', 'CHI', AND HVECT. +*---- + DO 130 IREGIO=1,NREGIO + VOL=VOLUME(IREGIO) + IF(IMERGE(IREGIO).EQ.INM) THEN + DVOL=DVOL+DBLE(VOL) + IGRFIN=0 + DO 150 IGRCND=1,NGCOND + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGRCND) + DO 151 IGR=IGRDEB,IGRFIN + DFLI=DBLE(FLUXES(IREGIO,IGR)*VOL) + DO 160 J=1,MAXH-2 + IF(HMAKE(J).NE.' ') THEN + DXSV(IGRCND,J)=DXSV(IGRCND,J) + > +DBLE(RXSV(IGR,J))*DFLI + ENDIF + 160 CONTINUE + DO 152 IL=1,NL + IF(HMAKE(MAXH+IL).NE.' ') THEN +*---- +* IGRCND IS THE SECONDARY GROUP. +*---- + NGSCAT=KFJJ(IGR,1,IL) + IGSCAT=KFJJ(IGR,2,IL) + JGRFIN=0 + DO 170 JGRCND=1,NGCOND +*---- +* JGRCND IS THE PRIMARY GROUP. +*---- + JGRDEB=JGRFIN+1 + JGRFIN=IGCOND(JGRCND) + J2=MIN(JGRFIN,IGSCAT) + J1=MAX(JGRDEB,IGSCAT-NGSCAT+1) + DTMP=0.0D0 + IPO=KFJJ(IGR,3,IL)+IGSCAT-J2 + DO 171 JGR=J2,J1,-1 + DTMP=DTMP+DBLE(RSCAT(IPO,IL)* + > FLUXES(IREGIO,JGR)*VOL) + IPO=IPO+1 + 171 CONTINUE + DSCAT(JGRCND,IGRCND,IL)= + > DSCAT(JGRCND,IGRCND,IL)+DTMP + 170 CONTINUE + IF((ITRANC.NE.0).AND.(IL.EQ.2)) THEN +*---- +* INFO USED BY WIMS TYPE TRANSPORT CORRECTION. +*---- + HMAKE(MAXH-1)='TRANC' + DTMP=DBLE(RXSV(IGR,IL)) + DXSV(IGRCND,MAXH-1)=DXSV(IGRCND,MAXH-1) + > +DTMP*DFLI + ENDIF + ENDIF + 152 CONTINUE + 151 CONTINUE + 150 CONTINUE + ENDIF + 130 CONTINUE + WRITE(HNEW,'(2A4,I4.4)') (ISONAM(I0,ISO),I0=1,2),INM + READ(HNEW,'(3A4)') (HNISO(I1,JJISO),I1=1,3) + ISOMIX(JJISO)=INM + IF(IPRINT.GT.0) WRITE(IOUT,320) INM,HNEW +*---- +* EVALUATE FEWGROUPS CHI +*---- + IF(HMAKE(MAXH).NE.' ') THEN + IGRFIN=0 + DO 191 IGRCND=1,NGCOND + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGRCND) + DO 192 IGR=IGRDEB,IGRFIN + DXSV(IGRCND,MAXH)=DXSV(IGRCND,MAXH) + > +DBLE(RXSV(IGR,MAXH)) + 192 CONTINUE + 191 CONTINUE + ENDIF +*---- +* EVALUATE FEWGROUPS MICROSCOPIC XS FOR ACTIVATION ISOTOPES +*---- + DO 200 IGRCND=1,NGCOND + DO 210 IL=1,NL + DTMP=DXSV(IGRCND,IL) + DO 211 JGRCND=1,NGCOND + IF(JGRCND.NE.IGRCND) THEN + DTMP=DTMP-DSCAT(IGRCND,JGRCND,IL) + ENDIF + 211 CONTINUE + QEN=MAX(ABS(DTMP),ABS(DSCAT(IGRCND,IGRCND,IL))) + IF(QEN.GT.0.0D0) THEN + ERR=ABS(DTMP-DSCAT(IGRCND,IGRCND,IL))/QEN + IF(ERR.GT.1.0D-3) THEN + WRITE(IOUT,340) IGRCND,IL-1,100.0*ERR + ENDIF + DSCAT(IGRCND,IGRCND,IL)=DTMP + ENDIF + DO 212 JGRCND=1,NGCOND + IF(DFLX(IGRCND,INM).GT.0.0D0) THEN + DSCAT(IGRCND,JGRCND,IL)= + > DSCAT(IGRCND,JGRCND,IL)/DFLX(IGRCND,INM) + ELSE + DSCAT(IGRCND,JGRCND,IL)=0.0D0 + ENDIF + 212 CONTINUE + 210 CONTINUE + DO 213 J=1,MAXH-1 + IF(DFLX(IGRCND,INM).GT.0.0D0) THEN + DXSV(IGRCND,J)=DXSV(IGRCND,J)/DFLX(IGRCND,INM) + ELSE + DXSV(IGRCND,J)=0.0D0 + ENDIF + 213 CONTINUE + 200 CONTINUE + IF(LLCM) THEN + CALL LCMSIX(IPEDIT,HNEW,1) + CALL LCMPUT(IPEDIT,'AWR',1,2,AWR) + IF(LMEVF) CALL LCMPUT(IPEDIT,'MEVF',1,2,EVF) + IF(LMEVG) CALL LCMPUT(IPEDIT,'MEVG',1,2,EVG) + DO 220 J=1,MAXH + IF(HMAKE(J).NE.' ') THEN + DO 221 IGCD=1,NGCOND + CXSV(IGCD)=REAL(DXSV(IGCD,J)) + 221 CONTINUE + CALL LCMPUT(IPEDIT,HMAKE(J),NGCOND,2,CXSV) + ENDIF + 220 CONTINUE + DO 230 IL=1,NL + IF(HMAKE(MAXH+IL).NE.' ') THEN + KGAR=0 + DO 231 IG2=1,NGCOND + IGMIN=IG2 + IGMAX=IG2 + DO 232 IG1=NGCOND,1,-1 + IF(DSCAT(IG1,IG2,IL).NE.0.0D0) THEN + IGMIN=MIN(IGMIN,IG1) + IGMAX=MAX(IGMAX,IG1) + ENDIF + 232 CONTINUE + KCJJ(IG2,1)=IGMAX-IGMIN+1 + KCJJ(IG2,2)=IGMAX + DO 233 IG1=IGMAX,IGMIN,-1 + KGAR=KGAR+1 + CSCAT(KGAR)=REAL(DSCAT(IG1,IG2,IL)) + 233 CONTINUE + 231 CONTINUE + CM=HMAKE(MAXH+IL)(:2) + CALL LCMPUT(IPEDIT,'NJJS'//CM,NGCOND,1,KCJJ(1,1)) + CALL LCMPUT(IPEDIT,'IJJS'//CM,NGCOND,1,KCJJ(1,2)) + CALL LCMPUT(IPEDIT,'SCAT'//CM,KGAR,2,CSCAT) + ENDIF + 230 CONTINUE + CALL LCMSIX(IPEDIT,' ',2) + ENDIF + IF(IPRINT.GT.3) THEN + WRITE(IOUT,330) 'FLXAVG',(DFLX(I,INM)/DVOL,I=1,NGCOND) + DO 240 J=1,MAXH + IF(HMAKE(J).NE.' ') THEN + WRITE(IOUT,330) HMAKE(J),(DXSV(I,J),I=1,NGCOND) + ENDIF + 240 CONTINUE + WRITE(IOUT,330) 'SIGA', + > (DXSV(I,1+NL)-DXSV(I,1),I=1,NGCOND) + WRITE(IOUT,330) 'SIGW00',(DSCAT(I,I,1),I=1,NGCOND) + IF(NL.GT.1) THEN + IF(HMAKE(MAXH+2).NE.' ') + > WRITE (6,330) 'SIGW01',(DSCAT(I,I,2),I=1,NGCOND) + ENDIF + ENDIF + 120 CONTINUE + IF(LLCM) THEN + CALL LCMSIX(IPEDIT,' ',2) + CALL LCMSIX(IPEDIT,' ',2) + ENDIF + ENDIF + 110 CONTINUE + IF(JJISO.GT.0.AND.LLCM) THEN + CALL LCMSIX(IPEDIT,CURNAM,1) + CALL LCMSIX(IPEDIT,CACTI,1) + TEXT12='L_LIBRARY' + CALL LCMPTC(IPEDIT,'SIGNATURE',12,TEXT12) + DO 105 I=1,NSTATE + IPAR(I)=0 + 105 CONTINUE + IPAR(1)=NMERGE + IPAR(2)=JJISO + IPAR(3)=NGCOND + IPAR(4)=NL + IPAR(5)=ITRANC + IF(ITRANC.NE.0) IPAR(5)=2 + IPAR(7)=1 + IPAR(13)=NED + IPAR(14)=NACTI + CALL LCMPUT(IPEDIT,'STATE-VECTOR',NSTATE,1,IPAR) + IF(NED.GT.0) CALL LCMPTC(IPEDIT,'ADDXSNAME-P0',8,NED,HVECT) + CALL LCMPUT(IPEDIT,'ISOTOPESUSED',3*JJISO,3,HNISO) + CALL LCMPUT(IPEDIT,'ISOTOPESMIX',JJISO,1,ISOMIX) + CALL LCMSIX(IPEDIT,' ',2) + CALL LCMSIX(IPEDIT,' ',2) + ENDIF + 100 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(DSCAT,DXSV,DFLX) + DEALLOCATE(CSCAT,CXSV,RSCAT,RXSV) + DEALLOCATE(HNISO,KCJJ,KFJJ,ISOMIX) + RETURN +* + 300 FORMAT(//' MICROSCOPIC ACTIVITY XS FOR MATERIAL NUMBER : ',I5/ + > ' STORED ON SUB-DIRECTORY : ',A12) + 310 FORMAT(/24X,'ISOTOPE NAME PREFIX : ',2A4) + 320 FORMAT(31X,'REGION NUMBER : ',I5,5X,'FINAL ISOTOPE NAME : ',A12) + 330 FORMAT(' XS TYPE ',A8/(1X,1P,10E12.4)) + 340 FORMAT(' EDIACT: *** WARNING *** NORMALIZATION OF THE WITHIN-', + > 'GROUP SCATTERING TRANSFER IN GROUP',I4,' AND ORDER',I3,' BY', + > F6.2,' %.') + END diff --git a/Dragon/src/EDIALB.f b/Dragon/src/EDIALB.f new file mode 100644 index 0000000..b481ef9 --- /dev/null +++ b/Dragon/src/EDIALB.f @@ -0,0 +1,315 @@ +*DECK EDIALB + SUBROUTINE EDIALB(IPMAC2,IPFLUX,IPMACR,IPSYS,IPRINT,NBMIX, + 1 NW,B2,NGROUP,NIFISS,NGCOND,ITRANC,ILEAKS,NREGIO,MATCOD, + 2 VOLUME,KEYFLX,IGCOND,FLUXES,NMLEAK) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute boundary current from ALBS information for use with SPH +* equivalence techniques. +* +*Copyright: +* Copyright (C) 2011 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMAC2 pointer to condensed macrolib information (L_MACROLIB +* signature) built by EDI:. +* IPFLUX pointer to the reference solution (L_FLUX signature). +* IPMACR pointer to the reference macrolib (L_MACROLIB signature). +* IPSYS pointer to the reference pij LCM object (L_PIJ signature). +* IPRINT print index. +* NBMIX number of mixtures in the reference geometry. +* NW type of weighting for P1 cross section information: +* = 0 P0; = 1 P1. +* B2 square buckling array. +* For ILEAKS = 1 or 2, B2(4) is the homogeneous square buckling; +* for ILEAKS = 3, B2(1),B2(2),B2(3) are the directional +* heterogeneous and B2(4) is the homogeneous square buckling. +* NGROUP number of energy groups in the reference calculation. +* NIFISS number of fissile isotopes. +* NGCOND number of condensed groups. +* ITRANC type of transport correction. +* ILEAKS type of leakage calculation: =0: no leakage; =1: homogeneous +* leakage (Diffon); =2: isotropic streaming (Ecco); +* =3: anisotropic streaming (Tibere). +* NREGIO number of regions in the reference geometry. +* MATCOD mixture index in region. +* VOLUME volume of region. +* KEYFLX position of average fluxes. +* IGCOND limit of condensed groups. +* FLUXES fluxes. +* NMLEAK number of leakage zones. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMAC2,IPFLUX,IPMACR,IPSYS + INTEGER IPRINT,NBMIX,NW,NGROUP,NIFISS,NGCOND,ITRANC,ILEAKS, + 1 NREGIO,MATCOD(NREGIO),KEYFLX(NREGIO),IGCOND(NGCOND),NMLEAK + REAL B2(4),VOLUME(NREGIO),FLUXES(NREGIO,NGROUP,NW+1) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPSYS,KPSYS,IPSYS2,JPMACR,KPMACR,JPFLUX + CHARACTER TEXT5*5,SUFF(2)*2 + DOUBLE PRECISION SUM,SUD + INTEGER, ALLOCATABLE, DIMENSION(:) :: NJJ,IJJ,IPOS,IMERGL + REAL, ALLOCATABLE, DIMENSION(:) :: SIGMA,XSCAT,GAMMA,SIG1,WORKD + REAL, ALLOCATABLE, DIMENSION(:,:) :: DIFHET,COURIN,WORK + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: PRODUC + DATA SUFF/'00','01'/ +*---- +* SCRATCH STORAGE ALLOCATION +* COURIN ingoing currents (4*J-/S). PIS information must be available +* on LCM. +*---- + ALLOCATE(NJJ(NBMIX),IJJ(NBMIX),IPOS(NBMIX)) + ALLOCATE(COURIN(NGCOND,2),PRODUC(NREGIO,NGCOND,NIFISS)) + ALLOCATE(WORK(NREGIO,2),SIGMA(0:NBMIX*NIFISS),XSCAT(NBMIX*NGROUP)) + ALLOCATE(DIFHET(NMLEAK,NGROUP),IMERGL(NBMIX),GAMMA(NGROUP)) +*---- +* CONSISTENCY TESTS +*---- + IF(.NOT.C_ASSOCIATED(IPSYS)) THEN + CALL XABORT('EDIALB: THE L_PIJ INFO IS NOT AVAILABLE.') + ENDIF + JPSYS=LCMGID(IPSYS,'GROUP') + KPSYS=LCMGIL(JPSYS,1) + CALL LCMLEN(KPSYS,'DRAGON-WIS',IXSLEN,ITYLCM) + IF(IXSLEN.NE.NREGIO) THEN + CALL LCMLIB(KPSYS) + WRITE(TEXT5,'(I5)') NREGIO + CALL XABORT('EDIALB: THE ALBS OPTION OF THE ASM: MODULE HAS NO' + > //'T BEEN ACTIVATED. NREGIO='//TEXT5) + ENDIF +*---- +* COMPUTE THE FISSION RATE INFORMATION +*---- + SIGMA(0)=0.0 + PRODUC(:NREGIO,:NGCOND,:NIFISS)=0.0 + IGRFIN=0 + JPMACR=LCMGID(IPMACR,'GROUP') + DO 45 IGRCD=1,NGCOND + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGRCD) + DO 40 IGR=IGRDEB,IGRFIN + KPMACR=LCMGIL(JPMACR,IGR) + CALL LCMLEN(KPMACR,'NUSIGF',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'NUSIGF',SIGMA(1)) + DO 35 IFIS=1,NIFISS + DO 30 IREG=1,NREGIO + IBM=MATCOD(IREG) + IF(IBM.GT.0) THEN + SS=FLUXES(IREG,IGR,1)*SIGMA((IFIS-1)*NBMIX+IBM) + PRODUC(IREG,IGRCD,IFIS)=PRODUC(IREG,IGRCD,IFIS)+SS + ENDIF + 30 CONTINUE + 35 CONTINUE + ENDIF + 40 CONTINUE + 45 CONTINUE + CALL LCMLEN(IPFLUX,'K-EFFECTIVE',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.1) THEN + CALL LCMGET(IPFLUX,'K-EFFECTIVE',EIGENK) + ELSE + EIGENK=1.0 + ENDIF + IF(IPRINT.GT.5) WRITE(6,'(/16H EDIALB: EIGENK=,1P,E12.4)') EIGENK +*---- +* COMPUTE MERGED/CONDENSED CROSS SECTIONS +*---- + IF(ILEAKS.EQ.1) THEN + CALL LCMLEN(IPFLUX,'DIFFHET',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.0) THEN + CALL XABORT('EDIALB: UNABLE TO RECOVER THE DIFFHET RECORD IN' + > //' THE FLUX OBJECT.') + ENDIF + CALL LCMGET(IPFLUX,'IMERGE-LEAK',IMERGL) + CALL LCMGET(IPFLUX,'DIFFHET',DIFHET) + ENDIF + IF(NW.EQ.1) CALL LCMGET(IPFLUX,'GAMMA',GAMMA) + CALL LCMSIX(IPMAC2,'ADF',1) + DO 180 INL=1,NW+1 + IGRFIN=0 + DO 175 IGRCD=1,NGCOND + COURIN(IGRCD,:2)=0.0 + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGRCD) + IF((ILEAKS.EQ.2).OR.(ILEAKS.EQ.3)) THEN + CALL LCMLEN(IPFLUX,'FLUX',ILON,ITYLCM) + IF(ILON.EQ.0) CALL XABORT('EDIALB: MISSING FLUX INFO.') + JPFLUX=LCMGID(IPFLUX,'FLUX') + ENDIF + DO 170 IGR=IGRDEB,IGRFIN + KPMACR=LCMGIL(JPMACR,IGR) + CALL LCMLEN(KPMACR,'NTOT0',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'NTOT0',SIGMA(1)) + ELSE + CALL XABORT('EDIALB: READ ERROR ON LCM RECORD= TOTAL.') + ENDIF + IF((ITRANC.NE.0).AND.(INL.EQ.1)) THEN +* TRANSPORT CORRECTION. + ALLOCATE(SIG1(NBMIX)) + CALL LCMGET(KPMACR,'TRANC',SIG1) + DO 50 IMAT=1,NBMIX + SIGMA(IMAT)=SIGMA(IMAT)-SIG1(IMAT) + 50 CONTINUE + DEALLOCATE(SIG1) + ENDIF + IF((ILEAKS.EQ.2).OR.(ILEAKS.EQ.3)) THEN + CALL LCMLEL(JPFLUX,IGR,ILCMLN,ITYLCM) + IF(ILCMLN.EQ.0) CALL XABORT('EDIALB: MISSING FLUX INFO.') + ALLOCATE(WORKD(ILCMLN)) + CALL LCMGDL(JPFLUX,IGR,WORKD) + ENDIF + ZNUM=0.0 + IF((NW.EQ.1).AND.(INL.EQ.2)) THEN +* USE WITH THE FUNDAMENTAL CURRENT EQUATION OF THE ECCO MODEL. + ZDEN=0.0 + DO 55 IREG=1,NREGIO + IBM=MATCOD(IREG) + ZNUM=ZNUM+SIGMA(IBM)*FLUXES(IREG,IGR,1)*VOLUME(IREG) + ZDEN=ZDEN+FLUXES(IREG,IGR,1)*VOLUME(IREG) + 55 CONTINUE + ZNUM=ZNUM/ZDEN + ENDIF + DO 60 IREG=1,NREGIO + IBM=MATCOD(IREG) + ZLEAK=0.0 + IF((NW.EQ.1).AND.(INL.EQ.1)) THEN + ZLEAK=B2(4)*FLUXES(IREG,IGR,2) + ELSE IF((NW.EQ.1).AND.(INL.EQ.2)) THEN + ZLEAK=(-(1.0-GAMMA(IGR))*(ZNUM-SIGMA(IBM))*FLUXES(IREG,IGR,2) + > -FLUXES(IREG,IGR,1)/3.0)/GAMMA(IGR) + ELSE IF(ILEAKS.EQ.1) THEN + IME=IMERGL(IBM) + IF(IME.GT.0) ZLEAK=DIFHET(IME,IGR)*B2(4)*FLUXES(IREG,IGR,1) + ELSE IF(ILEAKS.EQ.2) THEN + ZLEAK=B2(4)*WORKD(KEYFLX(IREG)+ILCMLN/2) + ELSE IF(ILEAKS.EQ.3) THEN + ZLEAK=B2(1)*WORKD(KEYFLX(IREG)+ILCMLN/4)+ + > B2(2)*WORKD(KEYFLX(IREG)+ILCMLN/2)+ + > B2(3)*WORKD(KEYFLX(IREG)+3*ILCMLN/4) + ENDIF + WORK(IREG,1)=-ZLEAK + 60 CONTINUE + IF((ILEAKS.EQ.2).OR.(ILEAKS.EQ.3)) DEALLOCATE(WORKD) +* + CALL LCMLEN(KPMACR,'CHI',ILCMLN,ITYLCM) + IF((ILCMLN.GT.0).AND.(INL.EQ.1)) THEN + DO 85 IFIS=1,NIFISS + CALL LCMGET(KPMACR,'CHI',SIGMA(1)) + DO 80 IREG=1,NREGIO + IBM=MATCOD(IREG) + IF(IBM.GT.0) THEN + DO 70 JGRCD=1,NGCOND + SS=SIGMA((IFIS-1)*NBMIX+IBM)*PRODUC(IREG,JGRCD,IFIS)/EIGENK + WORK(IREG,1)=WORK(IREG,1)+SS + 70 CONTINUE + ENDIF + 80 CONTINUE + 85 CONTINUE + ENDIF +* + CALL LCMLEN(KPMACR,'SIGW'//SUFF(INL),ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'SIGW'//SUFF(INL),SIGMA(1)) + ELSE + SIGMA(:NBMIX)=0.0 + ENDIF + IF((ITRANC.NE.0).AND.(INL.EQ.1)) THEN +* TRANSPORT CORRECTION. + ALLOCATE(SIG1(NBMIX)) + CALL LCMGET(KPMACR,'TRANC',SIG1) + DO 120 IMAT=1,NBMIX + SIGMA(IMAT)=SIGMA(IMAT)-SIG1(IMAT) + 120 CONTINUE + DEALLOCATE(SIG1) + ENDIF + CALL LCMLEN(KPMACR,'NJJS'//SUFF(INL),ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'NJJS'//SUFF(INL),NJJ) + CALL LCMGET(KPMACR,'IJJS'//SUFF(INL),IJJ) + CALL LCMGET(KPMACR,'IPOS'//SUFF(INL),IPOS) + CALL LCMGET(KPMACR,'SCAT'//SUFF(INL),XSCAT) + DO 150 IREG=1,NREGIO + IBM=MATCOD(IREG) + IF(IBM.GT.0) THEN + JGRFIN=0 + DO 140 JGRCD=1,NGCOND + SS=0.0D0 + JGRDEB=JGRFIN+1 + JGRFIN=IGCOND(JGRCD) + J2=MIN(JGRFIN,IJJ(IBM)) + J1=MAX(JGRDEB,IJJ(IBM)-NJJ(IBM)+1) + IPO=IPOS(IBM)+IJJ(IBM)-J2 + DO 130 JGR=J2,J1,-1 + IF(IGR.EQ.JGR) THEN + SS=SS+SIGMA(IBM)*FLUXES(IREG,JGR,INL) + ELSE + SS=SS+XSCAT(IPO)*FLUXES(IREG,JGR,INL) + ENDIF + IPO=IPO+1 + 130 CONTINUE + IF(INL.EQ.2) SS=SS/GAMMA(IGR) + WORK(IREG,1)=WORK(IREG,1)+SS + 140 CONTINUE + ENDIF + 150 CONTINUE + ENDIF +*---- +* COMPUTE BOUNDARY CURRENTS +*---- + IF(INL.EQ.1) THEN + JPSYS=LCMGID(IPSYS,'GROUP') + ELSE IF(INL.EQ.2) THEN + IPSYS2=LCMGID(IPSYS,'STREAMING') + JPSYS=LCMGID(IPSYS2,'GROUP') + ENDIF + KPSYS=LCMGIL(JPSYS,IGR) + CALL LCMLEN(KPSYS,'DRAGON-WIS',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.NREGIO) THEN + CALL LCMGET(KPSYS,'DRAGON-WIS',WORK(1,2)) + CALL LCMGET(KPSYS,'DRAGON-TXSC',SIGMA(0)) + SUM=0.0D0 + SUD=0.0D0 + DO 160 IREG=1,NREGIO + FACTOR=VOLUME(IREG) + IBM=MATCOD(IREG) + SUM=SUM+SIGMA(IBM)*FACTOR*FLUXES(IREG,IGR,1) + > -WORK(IREG,1)*FACTOR*(1.0-WORK(IREG,2)) + SUD=SUD+SIGMA(IBM)*FACTOR*WORK(IREG,2) + 160 CONTINUE + COURIN(IGRCD,:2)=COURIN(IGRCD,:2)+REAL(SUM/SUD) + ENDIF + 170 CONTINUE + 175 CONTINUE + CALL LCMPUT(IPMAC2,'ALBS'//SUFF(INL),NGCOND*2,2,COURIN) + IF(IPRINT.GT.3) THEN + WRITE(6,900) SUFF(INL),(COURIN(IGR,1),IGR=1,NGCOND) + WRITE(6,'(/)') + ENDIF + 180 CONTINUE + CALL LCMSIX(IPMAC2,' ',2) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GAMMA,IMERGL,DIFHET,XSCAT,SIGMA,WORK,PRODUC,COURIN) + DEALLOCATE(IPOS,IJJ,NJJ) + RETURN +* + 900 FORMAT(/10H EDIALB: P,A2,36H IN-CURRENTS (4J-/S) PER MACRO-GROUP, + > 5HS ARE/(1X,1P,10E13.5)) + END diff --git a/Dragon/src/EDIBAL.f b/Dragon/src/EDIBAL.f new file mode 100644 index 0000000..2888a39 --- /dev/null +++ b/Dragon/src/EDIBAL.f @@ -0,0 +1,388 @@ +*DECK EDIBAL + SUBROUTINE EDIBAL(IPEDIT,IPFLUX,IPRINT,NL,IFFAC,NGCOND,NMERGE, + > EIGENK,RATECM,FLUXCM,SCATTS,ILEAKS,B2,NW, + > NTAUXT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Four factor calculation. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPEDIT pointer to the edition LCM object. +* IPFLUX pointer to the flux LCM object. +* IPRINT print level: +* =1 neutron balance or four factor; +* =2 material analysis (if available). +* NL number of Legendre orders. +* IFFAC number of neutrons for neutron balance. +* NGCOND number of condensed groups. +* NMERGE number of merge regions. +* EIGENK problem eigenvalue. +* RATECM averaged region/group cross sections: +* = RATECM(*,1) = total P0; +* = RATECM(*,2) = total P1; +* = RATECM(*,NW+2) = absorption; +* = RATECM(*,NW+3) = fission; +* = RATECM(*,NW+4) = fixed sources / productions; +* = RATECM(*,NW+5) = leakage; +* = RATECM(*,NW+6) = total out of group scattering; +* = RATECM(*,NW+7) = diagonal scattering x-s; +* = RATECM(*,NW+8) = chi; +* = RATECM(*,NW+9) = wims type transport correction; +* = RATECM(*,NW+10) = x-directed leakage; +* = RATECM(*,NW+11) = y-directed leakage; +* = RATECM(*,NW+12) = z-directed leakage. +* FLUXCM integrated region/group fluxes: +* = FLUXCM(*,1) = fluxes P0; +* = FLUXCM(*,2) = fluxes P1. +* SCATTS scattering matrix. +* ILEAKS leakage calculation flag: +* = 0 no leakage; +* = 1 homogeneous leakage (Diffon); +* = 2 isotropic streaming (Ecco); +* = 3 anisotropic streaming (Tibere). +* B2 square buckling: +* for ILEAKS=1,2: B2(4) is homogeneous; +* for ILEAKS=3: B2(1),B2(2),B2(3) are directional heterogeneous +* and B2(4) is homogeneous. +* NW type of weighting for PN cross section info (=0 P0; =1 P1). +* NTAUXT number of reaction rate edits (=12+NW+2*NDEL). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPEDIT,IPFLUX + INTEGER IPRINT,NL,IFFAC,NGCOND,NMERGE,ILEAKS,NW,NTAUXT + REAL EIGENK,RATECM(NMERGE,NGCOND,NTAUXT), + > FLUXCM(NMERGE,NGCOND,NW+1), + > SCATTS(NMERGE,NGCOND,NGCOND,NL),B2(4) +*---- +* LOCAL VARIABLES +*---- + SAVE CNAMAT + PARAMETER (IUNOUT=6,INAMAT=2) + CHARACTER CNAMAT(INAMAT)*15 + REAL XN(8) + DOUBLE PRECISION DACCK,BUCKL2,XNF(3),XKINF,XN1,XN2,XN3,XN4,XN5, + > XN6,XKEFF,XA,XLAMF,XLAMTH,XNORMF,XAUX + INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPER + REAL, ALLOCATABLE, DIMENSION(:,:) :: FLXINT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: DLEAK + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: DRATE + DATA (CNAMAT(JJ),JJ=1,INAMAT) + > /' FUEL ','NON-FUEL '/ +*---- +* SCRATCH STORAGE ALLOCATION +* ITYPER region type. +* FLXINT integrated flux. +* DRATE group reaction rates: +* DRATE(1,*,*) for fuel; +* DRATE(2,*,*) for non-fuel; +* DRATE(*,1,*) production; +* DRATE(*,2,*) absorption; +* DRATE(*,*,ngcond+1) group total. +* DLEAK group leak rates: +* DLEAK(1,*) leakage; +* DLEAK(2,*) leakage + absorption; +* DLEAK(*,ngcond+1) group total. +*---- + ALLOCATE(ITYPER(NMERGE)) + ALLOCATE(FLXINT(NMERGE,NGCOND)) + ALLOCATE(DRATE(2,2,NGCOND+1),DLEAK(2,NGCOND+1)) +*---- +* LOCALIZE FUEL AND NON-FUEL REGION +*---- + NGC1=NGCOND+1 + DO 100 IGR=1,NGC1 + DO 110 IRAT=1,2 + DRATE(1,IRAT,IGR)=0.0D0 + DRATE(2,IRAT,IGR)=0.0D0 + 110 CONTINUE + DLEAK(1,IGR)=0.0D0 + DLEAK(2,IGR)=0.0D0 + 100 CONTINUE + DO 120 IREG=1,NMERGE + ITYPER(IREG)=2 + 120 CONTINUE + DO 130 IGR=1,NGCOND + DO 140 IREG=1,NMERGE + IF(RATECM(IREG,IGR,NW+3).GT.0.0) ITYPER(IREG)=1 + 140 CONTINUE + 130 CONTINUE +*---- +* GET BUCKL2 +*---- + CALL LCMLEN(IPFLUX,'B2 B1HOM',ILCMLN,ILCMTY) + IF(ILCMLN.EQ.1) THEN + CALL LCMGET(IPFLUX,'B2 B1HOM',BL2) + BUCKL2=DBLE(BL2) + ELSE + BUCKL2=0.0D0 + ENDIF + IF(EIGENK.EQ.0.0) THEN + WRITE(IUNOUT,7000) + FLXRGE=1.0 + FLXREN=1.0 + DACCK=1.0D0 + WRITE(IUNOUT,6000) + ELSE + FLXRGE=REAL(IFFAC) + FLXREN=REAL(IFFAC)*EIGENK + DACCK=DBLE(EIGENK) + IF(NGCOND.NE.3) THEN + WRITE(IUNOUT,7001) NGCOND + WRITE(IUNOUT,6001) + ELSE + WRITE(IUNOUT,6002) + ENDIF + ENDIF + IF(IPRINT.EQ.1) THEN + WRITE(IUNOUT,6100) + WRITE(IUNOUT,6101)(IREG,CNAMAT(ITYPER(IREG)),IREG=1,NMERGE) + ENDIF +*---- +* FIND INTEGRATED FLUX DIVIDED BY SPH FACTOR +*---- + DO 150 IGR=1,NGCOND + DO 160 IREG=1,NMERGE + FLXINT(IREG,IGR)=FLUXCM(IREG,IGR,1) + 160 CONTINUE + 150 CONTINUE + IF(IPRINT.GE.1) THEN + WRITE(IUNOUT,6200) + ENDIF + DO 170 IGR=1,NGCOND +*---- +* REACTION RATES PER GROUP AND MATERIAL TYPE +*---- + IF(IPRINT.GE.1) THEN + WRITE(IUNOUT,6201) IGR,NGCOND + ENDIF + DO 180 IREG=1,NMERGE +*---- +* ADD PRODUCTION AND ABSORPTION IN MATERIAL TYPE +*---- + IF(ITYPER(IREG).EQ.1) THEN + DRATE(1,1,IGR)=DRATE(1,1,IGR)+DBLE(RATECM(IREG,IGR,NW+4)) + > *DBLE(FLXINT(IREG,IGR)) + DRATE(1,2,IGR)=DRATE(1,2,IGR)+DBLE(RATECM(IREG,IGR,NW+2)) + > *DBLE(FLXINT(IREG,IGR)) + ELSE + DRATE(2,1,IGR)=DRATE(2,1,IGR)+DBLE(RATECM(IREG,IGR,NW+4)) + > *DBLE(FLXINT(IREG,IGR)) + DRATE(2,2,IGR)=DRATE(2,2,IGR)+DBLE(RATECM(IREG,IGR,NW+2)) + > *DBLE(FLXINT(IREG,IGR)) + ENDIF +*---- +* PRINT PRODUCTION AND ABSORPTION PER REGION +*---- + IF(IPRINT.GE.2) THEN + IF(IFFAC.EQ.1000) THEN + WRITE(IUNOUT,6300) IREG,CNAMAT(ITYPER(IREG)), + > FLXRGE*RATECM(IREG,IGR,NW+4)*FLXINT(IREG,IGR), + > FLXREN*RATECM(IREG,IGR,NW+2)*FLXINT(IREG,IGR) + ELSE + WRITE(IUNOUT,6301) IREG,CNAMAT(ITYPER(IREG)), + > FLXRGE*RATECM(IREG,IGR,NW+4)*FLXINT(IREG,IGR), + > FLXREN*RATECM(IREG,IGR,NW+2)*FLXINT(IREG,IGR) + ENDIF + ENDIF +*---- +* ADD GROUP LEAKAGE +*---- + IF((ILEAKS.EQ.1).OR.(ILEAKS.EQ.2)) THEN + DLEAK(1,IGR)=DLEAK(1,IGR)+DBLE(RATECM(IREG,IGR,NW+5)) + > *B2(4)*DBLE(FLXINT(IREG,IGR)) + ELSE IF(ILEAKS.EQ.3) THEN + DLEAK(1,IGR)=DLEAK(1,IGR)+DBLE(FLXINT(IREG,IGR)) + > *(DBLE(RATECM(IREG,IGR,NW+10))*B2(1) + > +DBLE(RATECM(IREG,IGR,NW+11))*B2(2) + > +DBLE(RATECM(IREG,IGR,NW+12))*B2(3)) + ELSE + DO 190 JGR=1,NGCOND + IF(JGR.NE.IGR) + > DLEAK(2,IGR)=DLEAK(2,IGR)+DBLE(SCATTS(IREG,IGR,JGR,1)) + > *DBLE(FLXINT(IREG,JGR)) + 190 CONTINUE + DLEAK(2,IGR)=DLEAK(2,IGR)+DBLE(FLXINT(IREG,IGR))* + > ( DBLE(RATECM(IREG,IGR,NW+4))/DACCK + > -DBLE(RATECM(IREG,IGR,1)) + > +DBLE(RATECM(IREG,IGR,NW+2)) + > +DBLE(SCATTS(IREG,IGR,IGR,1)) ) + ENDIF + 180 CONTINUE + IF((ILEAKS.EQ.1).OR.(ILEAKS.EQ.2)) THEN + DLEAK(2,IGR)=DLEAK(1,IGR)+DRATE(1,2,IGR)+DRATE(2,2,IGR) + ELSE + DLEAK(1,IGR)=DLEAK(2,IGR)-DRATE(1,2,IGR)-DRATE(2,2,IGR) + ENDIF +*---- +* PRINT PRODUCTION AND ABSORPTION PER MATERIAL TYPE AND TOTAL +* PRODUCTION, ABSORPTION, LEAKAGE AND LEAKAGE+ABSORPTION +*---- + IF(IPRINT.GE.1) THEN + IF(IFFAC.EQ.1000) THEN + WRITE(IUNOUT,6302) 'TOTAL FUEL ', + > FLXRGE*DRATE(1,1,IGR), + > FLXREN*DRATE(1,2,IGR) + WRITE(IUNOUT,6302) 'TOTAL NON-FUEL ', + > FLXRGE*DRATE(2,1,IGR), + > FLXREN*DRATE(2,2,IGR) + WRITE(IUNOUT,6302) 'FUEL + NON-FUEL', + > FLXRGE*(DRATE(1,1,IGR)+DRATE(2,1,IGR)), + > FLXREN*(DRATE(1,2,IGR)+DRATE(2,2,IGR)), + > FLXREN*DLEAK(1,IGR),FLXREN*DLEAK(2,IGR) + ELSE + WRITE(IUNOUT,6303) 'TOTAL FUEL ', + > FLXRGE*DRATE(1,1,IGR), + > FLXREN*DRATE(1,2,IGR) + WRITE(IUNOUT,6303) 'TOTAL NON-FUEL ', + > FLXRGE*DRATE(2,1,IGR), + > FLXREN*DRATE(2,2,IGR) + WRITE(IUNOUT,6303) 'FUEL + NON-FUEL', + > FLXRGE*(DRATE(1,1,IGR)+DRATE(2,1,IGR)), + > FLXREN*(DRATE(1,2,IGR)+DRATE(2,2,IGR)), + > FLXREN*DLEAK(1,IGR),FLXREN*DLEAK(2,IGR) + ENDIF + ENDIF +*---- +* GROUP SUM +*---- + DRATE(1,1,NGC1)=DRATE(1,1,NGC1)+DRATE(1,1,IGR) + DRATE(2,1,NGC1)=DRATE(2,1,NGC1)+DRATE(2,1,IGR) + DRATE(1,2,NGC1)=DRATE(1,2,NGC1)+DRATE(1,2,IGR) + DRATE(2,2,NGC1)=DRATE(2,2,NGC1)+DRATE(2,2,IGR) + DLEAK(1,NGC1)=DLEAK(1,NGC1)+DLEAK(1,IGR) + DLEAK(2,NGC1)=DLEAK(2,NGC1)+DLEAK(2,IGR) + 170 CONTINUE + IF(NGCOND.GT.1) THEN + WRITE(IUNOUT,6202) + IF(IFFAC.EQ.1000) THEN + WRITE(IUNOUT,6302) 'TOTAL FUEL ', + > FLXRGE*DRATE(1,1,NGC1), + > FLXREN*DRATE(1,2,NGC1) + WRITE(IUNOUT,6302) 'TOTAL NON-FUEL ', + > FLXRGE*DRATE(2,1,NGC1), + > FLXREN*DRATE(2,2,NGC1) + WRITE(IUNOUT,6302) 'FUEL + NON-FUEL', + > FLXRGE*(DRATE(1,1,NGC1)+DRATE(2,1,NGC1)), + > FLXREN*(DRATE(1,2,NGC1)+DRATE(2,2,NGC1)), + > FLXREN*DLEAK(1,NGC1),FLXREN*DLEAK(2,NGC1) + ELSE + WRITE(IUNOUT,6303) 'TOTAL FUEL ', + > FLXRGE*DRATE(1,1,NGC1), + > FLXREN*DRATE(1,2,NGC1) + WRITE(IUNOUT,6303) 'TOTAL NON-FUEL ', + > FLXRGE*DRATE(2,1,NGC1), + > FLXREN*DRATE(2,2,NGC1) + WRITE(IUNOUT,6303) 'FUEL + NON-FUEL', + > FLXRGE*(DRATE(1,1,NGC1)+DRATE(2,1,NGC1)), + > FLXREN*(DRATE(1,2,NGC1)+DRATE(2,2,NGC1)), + > FLXREN*DLEAK(1,NGC1),FLXREN*DLEAK(2,NGC1) + ENDIF + ENDIF + IF( (EIGENK.GT.0.0) .AND. (NGCOND.EQ.3) ) THEN +*---- +* FOUR FACTOR CALCULATION +*---- + XNF(1)=0.0D0 + XNF(2)=0.0D0 + XNF(3)=0.0D0 + DO 200 IREG=1,NMERGE +*---- +* ADD NUSIGF AND TOTAL RATES IN FUEL +*---- + IF(ITYPER(IREG).EQ.1) THEN + XNF(3)=XNF(3)+DBLE(RATECM(IREG,3,NW+3))*DBLE(FLXINT(IREG,3)) + XNF(2)=XNF(2)+DBLE(RATECM(IREG,2,NW+3))*DBLE(FLXINT(IREG,2)) + XNF(1)=XNF(1)+DBLE(RATECM(IREG,1,NW+3))*DBLE(FLXINT(IREG,1)) + ENDIF + 200 CONTINUE + XKINF=DRATE(1,1,4)/(DRATE(1,2,4)+DRATE(2,2,4)) + XKEFF=DRATE(1,1,4)/DLEAK(2,4) + XN1=(DRATE(1,1,4)/XKEFF)-DLEAK(1,4) + XN2=XN1-(DRATE(1,2,1)+DRATE(2,2,1)) + XN3=XN2-(DRATE(1,2,2)+DRATE(2,2,2)) + XN4=XN3-DRATE(2,2,3) + XN5=XNF(2)+XNF(3) + XN6=XN5+XNF(1) +*---- +* COMPUTATION OF EPSILON, F, ETA, P, LAMBDAF, LAMBDATH, KINF, KEFF +*---- + XN(1)=REAL((XN6-DRATE(1,2,1)-DRATE(2,2,1))/XN5) + XN(5)=REAL(XN4/XN3) + XN(6)=REAL(XN5/XN4) + XN(3)=REAL(XKINF)/(XN(1)*XN(5)*XN(6)) + XA=DRATE(1,2,4)+DRATE(2,2,4) + XLAMF=1/(1+((DLEAK(1,1)+DLEAK(1,2))/XA)) + XLAMTH=1/(1+(DLEAK(1,3)/XA)) + XAUX=XLAMF*XLAMTH + XNORMF=XKEFF/(XKINF*XAUX) + XN(2)=REAL(XLAMF*SQRT(XNORMF)) + XN(4)=REAL(XLAMTH*SQRT(XNORMF)) + XN(7)=XN(1)*XN(3)*XN(5)*XN(6) + XN(8)=XN(7)*XN(2)*XN(4) + IF(IPRINT.GE.1) THEN + WRITE(IUNOUT,6400) (XN(JJ),JJ=1,8) + ENDIF + CALL LCMPUT(IPEDIT,'FOUR-FACTOR ',8,2,XN) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(DLEAK,DRATE) + DEALLOCATE(FLXINT) + DEALLOCATE(ITYPER) + RETURN +*---- +* PRINT FORMATS +*---- + 6000 FORMAT(/20X,'F I X E D S O U R C E', + >' N E U T R O N B A L A N C E') + 6001 FORMAT(/20X,'S I M P L E N E U T R O N B A L A N C E') + 6002 FORMAT(/20X,'F O U R F A C T O R C A L C U L A T I O N') + 6100 FORMAT(4(4X,'REGION',5X,'MATERIAL TYPE ')) + 6101 FORMAT(4(5X,I5,5X,A15)) + 6200 FORMAT(15X,' REGION',3X,'MATERIAL TYPE ',3X,'NEUTRON PRODUCTION', + > 3X,'NEUTRON ABSORPTION',3X,'NEUTRON LEAKAGE ', + > 3X,'ABSORPTION+LEAKAGE') + 6201 FORMAT(' GROUP :',I3,'/',I3) + 6202 FORMAT(' SUM OVER GROUPS') + 6300 FORMAT(17X,I5,3X,A15,3X,F12.1,8X,F12.1) + 6301 FORMAT(17X,I5,3X,A15,3X,1P,E15.7,5X,E15.7) + 6302 FORMAT(25X,A15,3X,F12.1,8X,F12.1,8X,F12.1,8X,F12.1) + 6303 FORMAT(25X,A15,3X,1P,E15.7,5X,E15.7,5X,E15.7,5X,E15.7) + 6400 FORMAT(/' FOUR FACTORS'/1P, + > ' EPSILON (FAST FISSION FACTOR) =',E15.7/ + > ' LAMBDAF (FAST NON-LEAKAGE) =',E15.7/ + > ' P (ANTITRAP FACTOR) =',E15.7/ + > ' LAMBDAT (THERMAL NON-LEAKAGE) =',E15.7/ + > ' F (THERMAL UTILIZATION FACTOR) =',E15.7/ + > ' ETA (THERMAL REPRODUCTION) =',E15.7/ + > ' INFINITE MULTIPLICATION (4F) =',E15.7/ + > ' EFFECTIVE MULTIPLICATION =',E15.7) +*---- +* WARNING FORMATS +*---- + 7000 FORMAT(' * * * W A R N I N G * * * ',/ + > ' NO FOUR FACTOR CALCULATION PERMITTED FOR FIXED SOURCE', + > ' PROBLEM',/' A SIMPLE GROUP BY GROUP NEUTRON', + > ' BALANCE PERFORMED HERE') + 7001 FORMAT(' * * * W A R N I N G * * * ',/ + > ' FOUR FACTOR CALCULATION REQUIRES 3 GROUPS, NUMBER OF', + > ' GROUPS HERE IS =',I10/' A SIMPLE GROUP BY GROUP NEUTRON', + > ' BALANCE PERFORMED HERE') + END diff --git a/Dragon/src/EDIBHX.f b/Dragon/src/EDIBHX.f new file mode 100644 index 0000000..ea3430b --- /dev/null +++ b/Dragon/src/EDIBHX.f @@ -0,0 +1,73 @@ +*DECK EDIBHX + SUBROUTINE EDIBHX (MAXPTS,IPTRK,NREG,IMERGE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Reset merging indices for the double heterogeneity option (Bihet). +* +*Copyright: +* Copyright (C) 2014 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXPTS allocated storage for arrays of dimension NREG. +* IPTRK pointer to the tracking LCM object (L_TRACK signature). +* +*Parameters: input/output +* NREG number of volumes in the macro geometry on input and +* number of volumes in the composite geometry at output. +* IMERGE merging indices in the macro geometry on input and +* merging indices in the composite geometry at output. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER MAXPTS,NREG,IMERGE(MAXPTS) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + INTEGER ISTATE(NSTATE) + INTEGER, ALLOCATABLE, DIMENSION(:) :: IBI,NS + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: MIXGR +* + CALL LCMSIX(IPTRK,'BIHET',1) + CALL LCMGET(IPTRK,'PARAM',ISTATE) + IR1=ISTATE(1) + IR2=ISTATE(2) + NREG2=ISTATE(3) + NG=ISTATE(4) + NSMAX=ISTATE(5) + ALLOCATE(IBI(NREG2),NS(NG),MIXGR(NSMAX,NG,IR2-IR1)) + CALL LCMGET(IPTRK,'IBI',IBI) + CALL LCMGET(IPTRK,'NS',NS) + CALL LCMGET(IPTRK,'MIXGR',MIXGR) + CALL LCMSIX(IPTRK,' ',2) + NREG=NREG2 + DO 20 IKK=1,NREG2 + IF(IBI(IKK).GT.IR1) THEN + I=IBI(IKK)-IR1 + DO 15 J=1,NG + DO 10 K=1,NS(J) + IF(MIXGR(K,J,I).NE.0) THEN + NREG=NREG+1 + IMERGE(NREG)=IMERGE(IKK) + ENDIF + 10 CONTINUE + 15 CONTINUE + ENDIF + 20 CONTINUE + DEALLOCATE(MIXGR,NS,IBI) + IF(NREG.GT.MAXPTS) CALL XABORT('EDIBHX: MAXPTS IS TOO SMALL.') + RETURN + END diff --git a/Dragon/src/EDIDEL.f b/Dragon/src/EDIDEL.f new file mode 100644 index 0000000..8296fe1 --- /dev/null +++ b/Dragon/src/EDIDEL.f @@ -0,0 +1,72 @@ +*DECK EDIDEL + SUBROUTINE EDIDEL(IPRINT,NGCOND,NMERGE,IGR,SCATTS,INGSCT,IFGSCT, + > IPOSCT,XSCAT,DELSCT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Scattering delta sigma calculation. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPRINT print level (=1 to print delta sigmas). +* NGCOND number of condensed groups. +* NMERGE number of merged regions. +* IGR current group treated. +* SCATTS new scattering matrix. +* +*Parameters: scratch +* INGSCT number of scattering groups (old). +* IFGSCT first old scattering group. +* IPOSCT position of region in scattering matrix. +* XSCAT new scattering matrix. +* DELSCT scattering delta sigma. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IPRINT,NGCOND,NMERGE,IGR,INGSCT(NMERGE), + > IFGSCT(NMERGE),IPOSCT(NMERGE) + REAL SCATTS(NMERGE,NGCOND,NGCOND),XSCAT(NMERGE*NGCOND), + > DELSCT(NGCOND) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6) +*---- +* COMPUTE DELTA SIGMA BY MATERIAL FOR ALL GROUPS +*---- + DO 100 IREG=1,NMERGE + JLASTG=IFGSCT(IREG) + JFRSTG=JLASTG-INGSCT(IREG)+1 + JPOSCT=IPOSCT(IREG)+INGSCT(IREG) + IF(IPRINT.GE.1) THEN + WRITE(IUNOUT,6000) IREG,NGCOND + ENDIF + DO 110 JGR=1,NGCOND + IF( (JGR.LT.JFRSTG) .OR. (JGR.GT.JLASTG) ) THEN + DELSCT(JGR)=SCATTS(IREG,IGR,JGR) + ELSE + JPOSCT=JPOSCT-1 + DELSCT(JGR)=SCATTS(IREG,IGR,JGR)-XSCAT(JPOSCT) + ENDIF + 110 CONTINUE + 100 CONTINUE + WRITE(IUNOUT,6001) (DELSCT(JGR),JGR=1,NGCOND) +*---- +* FORMAT +*---- + 6000 FORMAT(/' REGION=',I5,10X,'NUMBER OF GROUPS ',I10) + 6001 FORMAT(1P,7(3X,E15.7)) + RETURN + END diff --git a/Dragon/src/EDIDEP.f b/Dragon/src/EDIDEP.f new file mode 100644 index 0000000..610a4e3 --- /dev/null +++ b/Dragon/src/EDIDEP.f @@ -0,0 +1,138 @@ +*DECK EDIDEP + SUBROUTINE EDIDEP(IPRINT,IPLIB,IPEDIT,NBNISO,HNNRF,ILNRF,IEVOL, + 1 LISO,KERMA,NBCH) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Create the 'DEPL-CHAIN' directory on the edition LCM object. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPRINT print parameter. +* IPLIB pointer to the internal library LCM object. +* IPEDIT pointer to the edition LCM object. +* NBNISO number of available isotopes in the edition LCM object. +* HNNRF reference names of the available isotopes in the edition +* LCM object. +* ILNRF selection flag of the available isotopes in the edition +* LCM object (=1 if selected). +* IEVOL flag making an isotope non-depleting: +* =1 to force an isotope to be non-depleting. +* LISO =.true. if we want to register each isotope after merging. +* KERMA kerma availability (=1 if 'H-FACTOR' is available). +* +*Parameters: output +* NBCH number of depleting nuclides after lumping +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB,IPEDIT + INTEGER IPRINT,NBNISO,HNNRF(3,NBNISO),ILNRF(NBNISO),IEVOL(NBNISO), + & KERMA(NBNISO),NBCH + LOGICAL LISO +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40,MAXBCH=500) + INTEGER ISTATE(NSTATE),HICH(3,MAXBCH) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MYLIS,IHREAC,IDREA,IPREA + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IHISO + REAL, ALLOCATABLE, DIMENSION(:) :: DDECA + REAL, ALLOCATABLE, DIMENSION(:,:) :: DENER,PRATE,YIELD +*---- +* FIND THE DEPLETING ISOTOPES IN THE EDITION MICROLIB +*---- + CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) + NBISO=ISTATE(1) + NBFISS=ISTATE(2) + NBDPF=ISTATE(3) + NSUPS=ISTATE(7) + NREAC=ISTATE(8) + NFATH=ISTATE(9) + ALLOCATE(IHISO(3,NBISO)) + CALL LCMGET(IPLIB,'ISOTOPESDEPL',IHISO) +* WE HAVE TO REGISTER SEVERAL TIMES THE SAME ISOTOPE IN THE NEW +* DEPL-CHAIN IF WE WANT IT TO DEPLETE + NBCH=0 + DO 20 ISO=1,NBISO + DO JSO=1,NBNISO + IF((ILNRF(JSO).EQ.0).OR.(IEVOL(JSO).EQ.1)) CYCLE + IF((IHISO(1,ISO).EQ.HNNRF(1,JSO)).AND. + & (IHISO(2,ISO).EQ.HNNRF(2,JSO))) THEN + IF(LISO) THEN + NBCH=NBCH+1 + IF(NBCH.GT.MAXBCH) CALL XABORT('EDIDEP: MAXBCH OVERFLOW(1)') + HICH(1,NBCH)=IHISO(1,ISO) + HICH(2,NBCH)=IHISO(2,ISO) + ELSE + GO TO 10 + ENDIF + ENDIF + ENDDO + GO TO 20 + 10 IF(.NOT.LISO) THEN + NBCH=NBCH+1 + IF(NBCH.GT.MAXBCH) CALL XABORT('EDIDEP: MAXBCH OVERFLOW(2)') + HICH(1,NBCH)=IHISO(1,ISO) + HICH(2,NBCH)=IHISO(2,ISO) + ENDIF + 20 CONTINUE +*---- +* GENERATE THE DEPLETION INFORMATION CORRESPONDING TO THE AVAILABLE +* ISOTOPES +*---- + IF(NBCH.GT.0) THEN + MAXFP=NBDPF+30 ! reserve 30 location for lumped fp daughters + NBFPCH=NBCH + ALLOCATE(MYLIS(NBISO),IHREAC(2*NREAC),IDREA(NREAC*NBISO), + 1 DENER(NREAC,NBISO),DDECA(NBISO),IPREA(NFATH*NBISO), + 2 PRATE(NFATH,NBISO),YIELD(NBFISS,MAXFP)) + CALL LCMGET(IPLIB,'CHARGEWEIGHT',MYLIS) + CALL LCMGET(IPLIB,'DEPLETE-IDEN',IHREAC) + CALL LCMGET(IPLIB,'DEPLETE-REAC',IDREA) + CALL LCMGET(IPLIB,'DEPLETE-ENER',DENER) + DO ISO=1,NBISO + ! set DENER=0.0 if H-FACTOR is defined. + IF(KERMA(ISO).EQ.1) DENER(2:NREAC,ISO)=0.0 + ENDDO + CALL LCMGET(IPLIB,'DEPLETE-DECA',DDECA) + CALL LCMGET(IPLIB,'PRODUCE-REAC',IPREA) + CALL LCMGET(IPLIB,'PRODUCE-RATE',PRATE) + IF(NBFISS*NBDPF.GT.0) THEN + CALL LCMGET(IPLIB,'FISSIONYIELD',YIELD) + ENDIF +* + CALL LCMSIX(IPEDIT,'DEPL-CHAIN',1) + IF(LISO) THEN + NBFISS2=NBFPCH + NBFPCH2=NBFPCH + ELSE + NBFISS2=NBFISS + NBFPCH2=NBFPCH + ENDIF + CALL EDILUM(IPRINT,IPEDIT,MAXFP,NBISO,NBFISS,NBDPF,NSUPS, + & NREAC,NFATH,NBCH,HICH,IHISO,MYLIS,IHREAC,IDREA,DENER,DDECA, + & IPREA,PRATE,YIELD,LISO,NBFISS2,NBFPCH2) + CALL LCMSIX(IPEDIT,' ',2) +* + DEALLOCATE(YIELD,PRATE,IPREA,DDECA,DENER,IDREA,IHREAC,MYLIS) + ENDIF + DEALLOCATE(IHISO) + RETURN + END diff --git a/Dragon/src/EDIDRV.f b/Dragon/src/EDIDRV.f new file mode 100644 index 0000000..53ddd67 --- /dev/null +++ b/Dragon/src/EDIDRV.f @@ -0,0 +1,773 @@ +*DECK EDIDRV + SUBROUTINE EDIDRV(IPEDIT,IPTRK1,IPFLUX,IPLIB,IPSYS,NGROUP,NBMIX, + > NREGIO,MATCOD,VOLUME,KEYFLX,NIFISS,NEDMAC,NL, + > NDEL,NALBP,ITRANC,NGCOND,NMERGE,IADF,IDFM,NW, + > ICURR,IHF,IFFAC,ILUPS,NSAVES,NSTATS,IXEDI, + > ISOTXS,IGCOND,IMERGE,CURNAM,OLDNAM,NBMICR, + > CARISO,NACTI,IACTI,IPRINT,LISO,LDEPL,LMACR, + > IADJ,NOUT,HVOUT,BB2,IEDCUR,IGOVE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Driver for edition operations. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPEDIT pointer to the edition LCM object. +* IPTRK1 pointer to the reference tracking object. +* IPFLUX pointer to the flux LCM object. +* IPLIB pointer to the internal library or macrolib LCM object. +* IPSYS pointer to the pij LCM object (only used with Selengut +* normalization). +* NGROUP number of energy groups. +* NBMIX number of mixtures. +* NREGIO number of regions. +* MATCOD mixture index in region. +* VOLUME volume of region. +* KEYFLX average flux position per region. +* NIFISS number of fissile isotopes. +* NEDMAC number of extra macroscopic cross section types. +* NL number of Legendre orders of the scattering cross sections. +* NDEL number of delayed precursor groups. +* NALBP number of physical albedos. +* ITRANC type of transport correction. +* NGCOND number of condensed groups. +* NMERGE number of regions merged. +* IADF flag for assembly discontinuity factors (ADF) information: +* = 0 do not compute them; +* = 1 compute them using ALBS information; +* = 2 compute them using averaged fluxes in boundary regions; +* = 3 compute them using SYBIL/ARM interface currents. +* IDFM flag for ADF info in input macrolib (0/1/2: absent/present). +* NW type of weighting for P1 cross section information: +* = 0 P0; = 1 P1. +* ICURR type of current approximation if NW=1: +* =1: heterogeneous leakage; +* =2: Todorova outscatter approximation; +* =4: use higher spherical harmonic moments of flux. +* IHF H-factor calculation flag: +* = 0 no; = 1 yes. +* IFFAC four factor calculation flag: +* = 0 no four factors (defaut); +* = 1 four factor evaluation. +* ILUPS flag to remove up-scattering from output. +* NSAVES homogenized cross section computation and saving: +* = 0 no compute no save; +* = 1 compute, no save; +* = 2 compute, save. +* NSTATS statistics level: +* = 0 no stats; +* = 1 statistics on fluxes +* = 2 statistics on reaction rates; +* = 3 statistics on fluxes and reaction rates; +* =-1 delta sigma ('MERG COMP' only). +* IXEDI first ISOTX mixture record number. +* ISOTXS ISOTX file enabling flag (0: off; 1: binary; 2: ascii). +* IGCOND condensed group limits. +* IMERGE merged region positions. +* CURNAM name of LCM directory where the current rates are to be +* stored. +* OLDNAM name of LCM directory where old rates were stored. +* NBMICR type of microlib edition: +* =-2: process only macroscopic residue; +* =-1: process each isotope; +* =0: process no isotope; +* >0 number of isotopes to process. +* CARISO names of the isotopes to process. +* NACTI number of activation editions. +* IACTI activation mixtures. +* IPRINT print index. +* LISO =.TRUE. if we want to keep all the isotopes after +* homogeneization. +* LDEPL =.TRUE. if we want to recover depletion information. +* LMACR =.TRUE. if we want to compute a residual isotope. +* IADJ type of flux weighting: +* =0: direct flux weighting; +* =1: direct-adjoint flux weighting. +* NOUT number of output cross section types (set to zero to recover +* all cross section types). +* HVOUT MATXS names of the output cross section types. +* BB2 imposed leakege used in non-regression tests. +* IEDCUR current edition flag with MOC and SN methods: +* =0: flux edition only; +* =1: flux and current edition. +* IGOVE Golfier-Vergain flag (=0/1: don't/use Golfier-Vergain equ'n). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + LOGICAL LISO,LDEPL,LMACR + TYPE(C_PTR) IPEDIT,IPTRK1,IPFLUX,IPLIB,IPSYS + INTEGER NGROUP,NBMIX,NREGIO,MATCOD(NREGIO),KEYFLX(NREGIO), + > NIFISS,NEDMAC,NL,NDEL,NALBP,ITRANC,NGCOND,NMERGE, + > IADF,IDFM,NW,ICURR,IHF,IFFAC,ILUPS,NSAVES,NSTATS, + > IXEDI,ISOTXS,IGCOND(NGCOND),IMERGE(NREGIO),NBMICR, + > NACTI,IACTI(NBMIX),IPRINT,IADJ,NOUT,IEDCUR,IGOVE + REAL VOLUME(NREGIO),BB2 + CHARACTER CURNAM*12,OLDNAM*12,CARISO(NBMICR)*12,HVOUT(NOUT)*8 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6,MAXED=100,NSTATE=40,IOUT=6) + TYPE(C_PTR) JPFLUX,JPFLUA,IPMIC2,IPMAC2,IPADF,JPLIB,KPLIB, + > KPEDIT,JPMAC2,KPMAC2 + CHARACTER HSIGN*12,TEXT8*8,HVECT(MAXED)*8,NISEXT*6,NISOTX*12, + > CTITLE*72,NAMSBR*12,HTYPE*8,TEXT12*12,HSMG*131 + INTEGER IFPAR(NSTATE),IPAR(NSTATE),IDIM(NSTATE) + REAL B2(4),B2T(3),TIMEF(3) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPE,MIX,IDEPL,ISONA, + > ISONR,LSISO,INADPL,KDRI,INNAM,INNRF,NMIX,KERMA + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: FIPI,FIFP + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: KEYANI + REAL, ALLOCATABLE, DIMENSION(:) :: WORKF,WORKA,VOLME,WLETY,WE, + > COURI,TAUXT,SIGT,SIGS,SCATS,FLINT,SCATD,DEN,TN,EMEVF,EMEVG,RER, + > DECAY,RRD,FIYI,ENERG,NAWR,NDEN,NTMP,NVOL,SNEJ,WORK1,WORK2 + REAL, ALLOCATABLE, DIMENSION(:,:) :: ADF + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: FLUXC,FADJC,FLUXES,AFLUXE, + > COUWP1,YIELD,PYIELD + CHARACTER*8, ALLOCATABLE, DIMENSION(:) :: HADF + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO,JPISO +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(FLUXES(NREGIO,NGROUP,NW+1), + > AFLUXE(NREGIO,NGROUP,NW+1)) +*---- +* FIND THE SIGNATURE OF IPLIB +*---- + CALL LCMGTC(IPLIB,'SIGNATURE',12,HSIGN) +*---- +* RECOVER NEUTRON FLUXES AND CURRENTS (IF ILEAKC.GE.6) +*---- + CALL LCMGET(IPFLUX,'STATE-VECTOR',IFPAR) + IF(IFPAR(1).NE.NGROUP) CALL XABORT('EDIDRV: INVALID VALUE OF NGR' + > //'OUP.') + ITYPEC=IFPAR(6) + ILEAKC=IFPAR(7) + NMLEAK=IFPAR(18) + IF(ILEAKC.EQ.0) THEN +* NO LEAKAGE + ILEAKS=0 + ELSE IF(ILEAKC.LE.5) THEN +* DIFFON-TYPE LEAKAGE + ILEAKS=1 + ELSE IF(ILEAKC.EQ.6) THEN +* ECCO-TYPE LEAKAGE (WITH ISOTROPIC STREAMING EFFECTS) + ILEAKS=2 + ELSE IF(ILEAKC.GE.7) THEN +* TIBERE-TYPE LEAKAGE (WITH ANISOTROPIC STREAMING EFFECTS) + ILEAKS=3 + ENDIF + CUREIN=0.0 + IF(ITYPEC.GT.0) CALL LCMGET(IPFLUX,'K-INFINITY',CUREIN) + B2(:4)=0.0 + IF(ITYPEC.GT.2) THEN + CALL LCMGET(IPFLUX,'B2 B1HOM',B2(4)) + IF(ILEAKS.EQ.3) THEN + CALL LCMGET(IPFLUX,'B2 HETE',B2) + IF(B2(4).EQ.0.0) THEN + B2T(1)=1.0/3.0 + B2T(2)=B2T(1) + B2T(3)=B2T(1) + ELSE + B2T(1)=B2(1)/B2(4) + B2T(2)=B2(2)/B2(4) + B2T(3)=B2(3)/B2(4) + ENDIF + ENDIF + ENDIF + IF((NW.GE.1).AND.(ILEAKC.LE.5).AND.(ICURR.EQ.1)) THEN + CALL XABORT('EDIDRV: CURRENT WEIHTING OF P1 XS INFO (NW=1) ' + > //'IS ONLY AVAILABLE WITH A STREAMING-ENABLED LEAKAGE MODEL.') + ENDIF + IF(ILEAKC.EQ.4) THEN + B2(:4)=0.0 + B2T(:3)=0.0 + ENDIF + IF(IADJ.EQ.0) THEN + CALL LCMLEN(IPFLUX,'FLUX',ILON,ITYLCM) + IF(ILON.EQ.0) CALL XABORT('EDIDRV: MISSING FLUX INFO.') + JPFLUX=LCMGID(IPFLUX,'FLUX') + CALL LCMLEL(JPFLUX,1,NUN,ITYLCM) + ELSE IF(IADJ.EQ.1) THEN + CALL LCMLEN(IPFLUX,'FLUX',ILON,ITYLCM) + IF(ILON.EQ.0) CALL XABORT('EDIDRV: MISSING FLUX INFO.') + JPFLUX=LCMGID(IPFLUX,'FLUX') + CALL LCMLEN(IPFLUX,'AFLUX',ILON,ITYLCM) + IF(ILON.EQ.0) CALL XABORT('EDIDRV: MISSING ADJOINT FLUX INFO.') + JPFLUA=LCMGID(IPFLUX,'AFLUX') + CALL LCMLEL(JPFLUX,1,NUN,ITYLCM) + ALLOCATE(WORKA(NUN)) + ELSE + CALL XABORT('EDIDRV: INVALID VALUE OF IADJ.') + ENDIF + ALLOCATE(WORKF(NUN)) + DO IGR=1,NGROUP + IF(IADJ.EQ.0) THEN + CALL LCMGDL(JPFLUX,IGR,WORKF) + DO IREG=1,NREGIO + FLUXES(IREG,IGR,1)=WORKF(KEYFLX(IREG)) + AFLUXE(IREG,IGR,1)=1.0 + ENDDO + ELSE IF(IADJ.EQ.1) THEN + CALL LCMGDL(JPFLUX,IGR,WORKF) + CALL LCMGDL(JPFLUA,IGR,WORKA) + DO IREG=1,NREGIO + FLUXES(IREG,IGR,1)=WORKF(KEYFLX(IREG)) + AFLUXE(IREG,IGR,1)=WORKA(KEYFLX(IREG)) + ENDDO + ENDIF + IF((ICURR.EQ.1).AND.(ILEAKS.EQ.2)) THEN +* ISOTROPIC STREAMING (ECCO) + IF(NW.NE.1) CALL XABORT('EDIDRV: NW=1 EXPECTED(1).') + DO IREG=1,NREGIO + FLUXES(IREG,IGR,2)=WORKF(NUN/2+KEYFLX(IREG)) + ENDDO + ELSE IF((ICURR.EQ.1).AND.(ILEAKS.EQ.3)) THEN +* ANISOTROPIC STREAMING + IF(NW.NE.1) CALL XABORT('EDIDRV: NW=1 EXPECTED(2).') + DO IREG=1,NREGIO + CURN=0.0 + DO IDIR=1,3 + CURN=CURN+B2T(IDIR)*WORKF(IDIR*NUN/4+KEYFLX(IREG)) + ENDDO + FLUXES(IREG,IGR,2)=CURN + ENDDO + ENDIF + ENDDO + DEALLOCATE(WORKF) + IF(IADJ.EQ.1) DEALLOCATE(WORKA) +*---- +* COMPUTE HIGHER MOMENT FLUXES IF NW=1 +*---- + IF(ICURR.EQ.2) THEN +* Outscatter Todorova approximation + IF(NW.NE.1) CALL XABORT('EDIDRV: NW=1 EXPECTED(3).') + IF(HSIGN.EQ.'L_LIBRARY') CALL LCMSIX(IPLIB,'MACROLIB',1) + JPLIB=LCMGID(IPLIB,'GROUP') + ALLOCATE(SIGT(0:NBMIX),SIGS(0:NBMIX)) + DO IGR=1,NGROUP + KPLIB=LCMGIL(JPLIB,IGR) + SIGT(0)=0.0 + SIGS(0)=0.0 + CALL LCMGET(KPLIB,'NTOT0',SIGT(1)) + CALL LCMGET(KPLIB,'SIGS01',SIGS(1)) + DO IREG=1,NREGIO + IBM=MATCOD(IREG) + IF(IBM.GT.0) THEN + FACT=3.0*(SIGT(IBM)-SIGS(IBM)) + IF(FACT.EQ.0.0) CALL XABORT('EDIDRV: DIVIDE CHECK.') + FLUXES(IREG,IGR,2)=FLUXES(IREG,IGR,1)/FACT + IF(IADJ.EQ.1) AFLUXE(IREG,IGR,2)=AFLUXE(IREG,IGR,1)/FACT + ELSE + FLUXES(IREG,IGR,2)=FLUXES(IREG,IGR,1) + IF(IADJ.EQ.1) AFLUXE(IREG,IGR,2)=AFLUXE(IREG,IGR,1) + ENDIF + ENDDO + ENDDO + DEALLOCATE(SIGS,SIGT) + IF(HSIGN.EQ.'L_LIBRARY') CALL LCMSIX(IPLIB,' ',2) + ELSE IF(ICURR.EQ.4) THEN +* Use higher spherical harmonic moments + IF(NW.EQ.0) CALL XABORT('EDIDRV: NW>0 EXPECTED(5).') + CALL LCMGTC(IPTRK1,'TRACK-TYPE',12,TEXT12) + IF(TEXT12.EQ.'MCCG') THEN + CALL LCMGET(IPTRK1,'STATE-VECTOR',IPAR) + NDIM=IPAR(16) + CALL LCMGET(IPTRK1,'MCCG-STATE',IPAR) + NFUNL=IPAR(19) + NLIN=IPAR(20) + ELSE IF(TEXT12.EQ.'SN') THEN + CALL LCMGET(IPTRK1,'STATE-VECTOR',IPAR) + NFUNL=IPAR(7) + NLIN=IPAR(8) + NDIM=IPAR(9) + NLIN=NLIN**NDIM + ELSE + CALL XABORT('EDIDRV: MCCG OR SN TRACKING EXPECTED WITH ' + > //'P1W_SP OPTION') + ENDIF + ALLOCATE(KEYANI(NREGIO,NLIN,NFUNL)) + CALL LCMGET(IPTRK1,'KEYFLX$ANIS',KEYANI) + CALL EDIWP1(IPFLUX,NW,NGROUP,NUN,NREGIO,NDIM,IADJ,NLIN, + > NFUNL,NGCOND,NMERGE,KEYANI,VOLUME,IGCOND,IMERGE,FLUXES(1,1,2), + > AFLUXE(1,1,2)) + DEALLOCATE(KEYANI) + ENDIF +*---- +* CURRENT EDITION +*---- + IF(IEDCUR.EQ.1) THEN +* Use higher spherical harmonic moments + CALL LCMGTC(IPTRK1,'TRACK-TYPE',12,TEXT12) + IF(TEXT12.EQ.'MCCG') THEN + CALL LCMGET(IPTRK1,'STATE-VECTOR',IPAR) + NDIM=IPAR(16) + CALL LCMGET(IPTRK1,'MCCG-STATE',IPAR) + NFUNL=IPAR(19) + NLIN=IPAR(20) + ELSE IF(TEXT12.EQ.'SN') THEN + CALL LCMGET(IPTRK1,'STATE-VECTOR',IPAR) + NFUNL=IPAR(7) + NLIN=IPAR(8) + NDIM=IPAR(9) + NLIN=NLIN**NDIM + ELSE + CALL XABORT('EDIDRV: MCCG OR SN TRACKING EXPECTED WITH ' + > //'EDI_CURR OPTION') + ENDIF + ALLOCATE(COUWP1(NMERGE,NGCOND,NDIM),KEYANI(NREGIO,NLIN,NFUNL)) + CALL LCMGET(IPTRK1,'KEYFLX$ANIS',KEYANI) + CALL EDIWCU(IPFLUX,IPRINT,NGROUP,NUN,NREGIO,NDIM,NLIN,NFUNL, + > NGCOND,NMERGE,KEYANI,VOLUME,IGCOND,IMERGE,COUWP1) + DEALLOCATE(KEYANI) + IPMIC2=LCMDID(IPEDIT,CURNAM) + IPMAC2=LCMDID(IPMIC2,'MACROLIB') + JPMAC2=LCMLID(IPMAC2,'GROUP',NGCOND) + DO IGR=1,NGCOND + KPMAC2=LCMDIL(JPMAC2,IGR) + CALL LCMPUT(KPMAC2,'COURX-INTG',NMERGE,2,COUWP1(1,IGR,1)) + IF(NDIM.GE.2) CALL LCMPUT(KPMAC2,'COURY-INTG',NMERGE,2, + > COUWP1(1,IGR,2)) + IF(NDIM.EQ.3) CALL LCMPUT(KPMAC2,'COURZ-INTG',NMERGE,2, + > COUWP1(1,IGR,3)) + ENDDO + DEALLOCATE(COUWP1) + ENDIF +*---- +* ALLOCATE MEMORY FOR GROUP CONDENSATION AND MERGE +*---- + ALLOCATE(VOLME(NMERGE),WLETY(NGCOND),WE(NGCOND+1)) + NELEMT=NMERGE*NGCOND +*---- +* COMPUTE REACTION RATES FOR THE EDITION MACROLIB +*---- + NTAUXT=12+NW+2*NDEL + ALLOCATE(FLUXC(NMERGE,NGCOND,NW+1),FADJC(NMERGE,NGCOND,NW+1), + > TAUXT(NTAUXT*NELEMT),SIGS(NL*NELEMT),SCATS(NELEMT*NGCOND*NL), + > FLINT(NREGIO*NGROUP*(NW+1)),SCATD(2*NELEMT*NGCOND*NL)) + NBISO=0 + CALL LCMLEN(IPFLUX,'K-EFFECTIVE',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.1) THEN + CALL LCMGET(IPFLUX,'K-EFFECTIVE',EIGENK) + ELSE + EIGENK=0.0 + ENDIF + CALL LCMLEN(IPFLUX,'K-INFINITY',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.1) THEN + CALL LCMGET(IPFLUX,'K-INFINITY',EIGINF) + ELSE + EIGINF=EIGENK + ENDIF + TIMEF(1)=0.0 + TIMEF(2)=0.0 + TIMEF(3)=0.0 + IF(HSIGN.EQ.'L_LIBRARY') THEN + CALL LCMSIX(IPLIB,'MACROLIB',1) + CALL LCMLEN(IPLIB,'TIMESTAMP',ILCMLN,ILCMTY) + IF((ILCMLN.GE.1).AND.(ILCMLN.LE.3)) THEN + CALL LCMGET(IPLIB,'TIMESTAMP',TIMEF) + ENDIF + ENDIF + CALL EDIDTX(IPEDIT,IPFLUX,IPLIB,IADJ,IPRINT,NL,NDEL,NALBP,ITRANC, + > NGROUP,NGCOND,NBMIX,NREGIO,NMERGE,ILEAKS,ILUPS,NW, + > MATCOD,VOLUME,KEYFLX,IGCOND,IMERGE,FLUXES,AFLUXE, + > EIGENK,VOLME,WLETY,WE,TAUXT,FLUXC,FADJC,FLINT,SCATD, + > SCATS,NIFISS,NSAVES,CURNAM,NEDMAC,SIGS,B2,IGOVE, + > CUREIN,TIMEF,NTAUXT,NMLEAK) + IF(HSIGN.EQ.'L_LIBRARY') CALL LCMSIX(IPLIB,' ',2) + DEALLOCATE(SCATD,FLINT) +*---- +* COMPUTE BOUNDARY EDITIONS FOR ADF OR SPH WITH SELENGUT +*---- + IF(CURNAM.NE.' ') THEN + IF(IPRINT.GT.0) WRITE(IOUT,'(30H EDIDRV: EDITION DIRECTORY IS , + > A)') CURNAM + IF(HSIGN.EQ.'L_LIBRARY') CALL LCMSIX(IPLIB,'MACROLIB',1) + IPMAC2=LCMDID(IPEDIT,CURNAM) + IPMAC2=LCMDID(IPMAC2,'MACROLIB') + IF(IADF.EQ.1) THEN +* recover outgoing current from escape probabilities + CALL EDIALB(IPMAC2,IPFLUX,IPLIB,IPSYS,IPRINT,NBMIX,NW, + > B2,NGROUP,NIFISS,NGCOND,ITRANC,ILEAKS,NREGIO,MATCOD, + > VOLUME,KEYFLX,IGCOND,FLUXES,NMLEAK) + ELSE IF((IADF.EQ.2).OR.(IADF.EQ.-2)) THEN + ALLOCATE(WORKF(NGCOND)) + IF(IADF.EQ.-2) THEN +* recover averaged fluxes used to compute ADF + DO IGR=1,NGCOND + WORKF(IGR)=SUM(FLUXC(:,IGR,1))/SUM(VOLME(:)) + ENDDO + ELSE + WORKF(:NGCOND)=1.0 + ENDIF +* use averaged fluxes obtained over boundary regions + IPADF=LCMGID(IPEDIT,'REF:ADF') + CALL LCMGET(IPADF,'NTYPE',NTYPE) + IF(NTYPE.EQ.0) CALL XABORT('EDIADF: NTYPE=0.') + CALL LCMSIX(IPMAC2,'ADF',1) + ALLOCATE(HADF(NTYPE),COURI(NGCOND)) + CALL LCMGTC(IPADF,'HADF',8,NTYPE,HADF) + DO IT=1,NTYPE + HTYPE=HADF(IT) + CALL EDIGAP(IPADF,HTYPE,NGROUP,NGCOND,NREGIO,VOLUME, + > IGCOND,FLUXES,WORKF,IPRINT,COURI) + ALLOCATE(ADF(NMERGE,NGCOND)) + DO IGR=1,NGCOND + ADF(:NMERGE,IGR)=COURI(IGR) + ENDDO + CALL LCMPUT(IPMAC2,HTYPE,NMERGE*NGCOND,2,ADF) + DEALLOCATE(ADF) + ENDDO + DEALLOCATE(WORKF) + CALL LCMPUT(IPMAC2,'NTYPE',1,1,NTYPE) + CALL LCMPTC(IPMAC2,'HADF',8,NTYPE,HADF) + DEALLOCATE(COURI,HADF) + CALL LCMSIX(IPMAC2,' ',2) + ELSE IF(IADF.EQ.3) THEN +* recover outgoing current from interface currents + CALL LCMGTC(IPTRK1,'TRACK-TYPE',12,TEXT12) + IF(TEXT12.EQ.'SYBIL') THEN + CALL EDIJO1(IPMAC2,IPTRK1,IPFLUX,IPRINT,NGCOND,IGCOND) + ELSE IF(TEXT12.EQ.'MCCG') THEN + CALL EDIJO2(IPMAC2,IPTRK1,IPFLUX,IPRINT,NGCOND,IGCOND) + ELSE IF(TEXT12.EQ.'EXCELL') THEN + CALL EDIJO3(IPMAC2,IPTRK1,IPFLUX,IPRINT,NGCOND,IGCOND) + ELSE + WRITE(HSMG,'(40HEDIDRV: INCOMPATIBLE SOLUTION TYPE. SYBI, + > 28HL, EXCELL OR MCCG EXPECTED. ,A12,6HFOUND.)') TEXT12 + CALL XABORT(HSMG) + ENDIF + ELSE IF(IADF.EQ.4) THEN +* recover ADF information from input macrolib + CALL LCMLEN(IPLIB,'GROUP',ILCMLN,ITYLCM) + IF(ILCMLN.NE.NGCOND) CALL XABORT('EDIDRV: UNABLE TO RECOVE' + > //'R ADF INFORMATION FROM INPUT MACROLIB.') + CALL LCMLEN(IPLIB,'ADF',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.0) CALL XABORT('EDIDRV: NO ADF INFORMATION IN' + > //' INPUT MACROLIB (REMOVE KEYWORD ADFM).') + CALL LCMSIX(IPMAC2,'ADF',1) + CALL LCMSIX(IPLIB,'ADF',1) + CALL LCMEQU(IPLIB,IPMAC2) + CALL LCMSIX(IPLIB,' ',2) + CALL LCMSIX(IPMAC2,' ',2) + ENDIF + IF(HSIGN.EQ.'L_LIBRARY') CALL LCMSIX(IPLIB,' ',2) + ENDIF +*---- +* RECOVER ISOTOPIC INFORMATION FROM THE MICROLIB +*---- + IF(HSIGN.EQ.'L_LIBRARY') THEN + CALL LCMGET(IPLIB,'STATE-VECTOR',IPAR) + NBISO=IPAR(2) + NED=IPAR(13) + NBESP=IPAR(16) + IF(NBISO.EQ.0) CALL XABORT('EDIDRV: NO ISOTOPES FOUND.') + ALLOCATE(DEN(NBISO),ITYPE(NBISO),MIX(NBISO),TN(NBISO), + > IDEPL(NBISO),ISONA(3*NBISO),ISONR(3*NBISO),LSISO(NBISO), + > IPISO(NBISO)) + CALL LCMGET(IPLIB,'ISOTOPESDENS',DEN) + CALL LCMGET(IPLIB,'ISOTOPESTYPE',ITYPE) + CALL LCMGET(IPLIB,'ISOTOPESMIX',MIX) + CALL LCMGET(IPLIB,'ISOTOPESTEMP',TN) + CALL LCMGET(IPLIB,'ISOTOPESTODO',IDEPL) + IF(NED.GT.0) CALL LCMGTC(IPLIB,'ADDXSNAME-P0',8,NED,HVECT) + CALL LCMGET(IPLIB,'ISOTOPESUSED',ISONA) + CALL LCMGET(IPLIB,'ISOTOPERNAME',ISONR) + LSISO(:NBISO)=0 + IF(NBMICR.EQ.-2) THEN + LSISO(:NBISO)=0 + ELSE IF(NBMICR.EQ.-1) THEN + LSISO(:NBISO)=1 + ELSE IF(NBMICR.GT.0) THEN + DO IISO=1,NBISO + WRITE(TEXT8,'(2A4)') (ISONA((IISO-1)*3+I0),I0=1,2) + DO IIII=1,NBMICR + IF(CARISO(IIII)(1:8).EQ.TEXT8) LSISO(IISO)=1 + ENDDO + ENDDO + ENDIF +*---- +* SET THE LCM MICROLIB ISOTOPEWISE DIRECTORIES. +*---- + CALL LIBIPS(IPLIB,NBISO,IPISO) + ENDIF +*---- +* EVALUATE H-FACTOR IF REQUIRED FOR THE EDITION MACROLIB +*---- + ALLOCATE(EMEVF(NBISO),EMEVG(NBISO)) + EMEVF(:NBISO)=0.0 + EMEVG(:NBISO)=0.0 + IF((NSAVES.GE.2).AND.(IHF.NE.0)) THEN + CALL LCMLEN(IPLIB,'DEPL-CHAIN',ILLCM,ITLCM) + IF(ILLCM.NE.0) THEN + CALL LCMSIX(IPEDIT,CURNAM,1) + CALL LCMSIX(IPLIB,'DEPL-CHAIN',1) + CALL LCMGET(IPLIB,'STATE-VECTOR',IDIM) + NDEPL=IDIM(1) + NREAC=IDIM(8) +* + ALLOCATE(INADPL(3*NDEPL),RER(NREAC*NDEPL)) + CALL LCMGET(IPLIB,'ISOTOPESDEPL',INADPL) + CALL LCMGET(IPLIB,'DEPLETE-ENER',RER) + CALL LCMSIX(IPLIB,' ',2) +* + CALL EDIHFC(IPEDIT,NGROUP,NGCOND,NREGIO,NMERGE,NBISO,NDEPL, + > NREAC,MATCOD,VOLUME,INADPL,ISONA,ISONR,IPISO, + > MIX,FLUXES(1,1,1),DEN,IGCOND,IMERGE,RER,EMEVF, + > EMEVG,VOLME,IPRINT) +* + DEALLOCATE(RER,INADPL) + CALL LCMSIX(IPEDIT,' ',2) + ENDIF + ENDIF +*---- +* LUMP THE DEPLETION CHAIN +*---- + ALLOCATE(DECAY(NBISO)) + DECAY(:NBISO)=0.0 + NDEPL=0 + NDFI=0 + IF((NBMICR.NE.0).AND.(NBISO.NE.0)) THEN + IF(LDEPL) THEN + ALLOCATE(KERMA(NBISO)) + KERMA(:NBISO)=1 + CALL LCMSIX(IPEDIT,CURNAM,1) + CALL LCMLEN(IPLIB,'DEPL-CHAIN',ILCMLN,ITYLCM) + IF((ILCMLN.NE.0).AND.(CURNAM.NE.' ')) THEN + CALL LCMSIX(IPLIB,'DEPL-CHAIN',1) + CALL EDIDEP(IPRINT,IPLIB,IPEDIT,NBISO,ISONR,LSISO,IDEPL, + > LISO,KERMA,NBCH) + CALL LCMSIX(IPLIB,' ',2) + ENDIF + DEALLOCATE(KERMA) +*---- +* RECOVER DEPLETION INFORMATION FROM THE INTERNAL LIBRARY +*---- + CALL LCMLEN(IPEDIT,'DEPL-CHAIN',ILLCM,ITLCM) + IF(ILLCM.NE.0) THEN + CALL LCMSIX(IPEDIT,'DEPL-CHAIN',1) + CALL LCMGET(IPEDIT,'STATE-VECTOR',IDIM) + NDEPL=IDIM(1) + NDFI=IDIM(2) + NDFP=IDIM(3) + NREAC=IDIM(8) + ALLOCATE(FIPI(NBISO,NMERGE),FIFP(NBISO,NMERGE), + > YIELD(NGCOND+1,NDFP,NMERGE),PYIELD(NDFI,NDFP,NMERGE)) +* + ALLOCATE(INADPL(3*NDEPL),KDRI(NREAC*NDEPL),RRD(NDEPL), + > FIYI(NDFI*NDFP)) + CALL LCMGET(IPEDIT,'ISOTOPESDEPL',INADPL) + CALL LCMGET(IPEDIT,'DEPLETE-REAC',KDRI) + CALL LCMGET(IPEDIT,'DEPLETE-DECA',RRD) + IF(NDFI*NDFP.GT.0) THEN + CALL LCMGET(IPEDIT,'FISSIONYIELD',FIYI) + ENDIF + CALL LCMSIX(IPEDIT,' ',2) +* + CALL EDIHFD(IPRINT,NGROUP,NGCOND,NREGIO,NMERGE,NBISO,NDEPL, + > NDFI,NDFP,NREAC,MATCOD,VOLUME,INADPL,ISONA, + > ISONR,IPISO,MIX,FLUXES(1,1,1),DEN,IDEPL,IGCOND, + > IMERGE,KDRI,RRD,FIYI,DECAY,YIELD,FIPI,FIFP, + > PYIELD) +* + DEALLOCATE(FIYI,RRD,KDRI,INADPL) + ENDIF + CALL LCMSIX(IPEDIT,' ',2) + ENDIF +*---- +* COMPUTE MICROSCOPIC CROSS SECTIONS +*---- + CALL EDIMIC(IPEDIT,IPFLUX,IPLIB,IADJ,NL,NDEL,NBESP,NBISO,NDEPL, + > ISONA,ISONR,IPISO,MIX,TN,NED,HVECT,NOUT,HVOUT, + > IPRINT,NGROUP,NGCOND,NBMIX,NREGIO,NMERGE,NDFI, + > NDFP,ILEAKS,ILUPS,NW,MATCOD,VOLUME,KEYFLX,CURNAM, + > IGCOND,IMERGE,FLUXES,AFLUXE,EIGENK,EIGINF,B2,DEN, + > ITYPE,IDEPL,LSISO,EMEVF,EMEVG,DECAY,YIELD,FIPI, + > FIFP,PYIELD,ITRANC,LISO,NMLEAK) +*---- +* ISOTX FILE PROCESSING +*---- + IF(ISOTXS.GE.1) THEN + CALL LCMSIX(IPEDIT,CURNAM,1) + CALL LCMGET(IPEDIT,'STATE-VECTOR',IPAR) + NBNISO=IPAR(2) + NAMSBR='EDIDRV' + IF(IPRINT.GE.1) WRITE(IOUT,6000) NAMSBR + ALLOCATE(INNAM(3*NBNISO),INNRF(3*NBNISO),NMIX(NBNISO)) + ALLOCATE(ENERG(NGCOND+1),NAWR(NBNISO),NDEN(NBNISO), + > NTMP(NBNISO),NVOL(NBNISO),SNEJ(NBNISO),JPISO(NBNISO)) + CALL LCMGET(IPEDIT,'ENERGY',ENERG) + CALL LCMGET(IPEDIT,'ISOTOPESUSED',INNAM) + CALL LCMGET(IPEDIT,'ISOTOPERNAME',INNRF) + CALL LCMGET(IPEDIT,'ISOTOPESMIX',NMIX) + CALL LCMGET(IPEDIT,'ISOTOPESDENS',NDEN) + CALL LCMGET(IPEDIT,'ISOTOPESTEMP',NTMP) + CALL LCMGET(IPEDIT,'ISOTOPESVOL',NVOL) + CALL LIBIPS(IPEDIT,NBNISO,JPISO) + DO ISO=1,NBNISO + KPEDIT=JPISO(ISO) + CALL LCMGET(KPEDIT,'AWR',AWR) + EMEVF2=0.0 + EMEVG2=0.0 + CALL LCMLEN(KPEDIT,'MEVF',ILENF,ITYLCM) + CALL LCMLEN(KPEDIT,'MEVG',ILENG,ITYLCM) + IF(ILENF.EQ.1) CALL LCMGET(KPEDIT,'MEVF',EMEVF2) + IF(ILENG.EQ.1) CALL LCMGET(KPEDIT,'MEVG',EMEVG2) + NAWR(ISO)=AWR + SNEJ(ISO)=EMEVF2+EMEVG2 + ENDDO +* + NBIXS=IXEDI + DO IMRG=1,NMERGE + NBIXS=NBIXS+1 + WRITE(NISEXT,'(I6)') NBIXS + DO ICAR=1,6 + IF(NISEXT(ICAR:ICAR) .EQ. ' ' .OR. + > NISEXT(ICAR:ICAR) .EQ. '*') THEN + NISEXT(ICAR:ICAR)='0' + ENDIF + ENDDO + NISOTX='ISOTXS'//NISEXT +*---- +* GENERATE ONE ISOTXS FILE FOR EACH MERGED REGION IN EACH MIXTURE +*---- + WRITE(CTITLE,9000) NAMSBR,CURNAM, + > 'MICR ','MIX',IMRG,NISOTX + IF(IPRINT.GE.1) WRITE(IOUT,6002) IMRG,NISOTX + IUTYPE=ISOTXS+1 + IWGOXS=KDROPN(NISOTX,0,IUTYPE,0) + CALL EDITXS(IWGOXS,IUTYPE,IPRINT,NGCOND,NL,NBNISO,CTITLE, + > IMRG,ENERG,INNAM,INNRF,JPISO,NMIX,NAWR,NDEN, + > NTMP,SNEJ) + IRETRN=KDRCLS(IWGOXS,1) + ENDDO +* + DEALLOCATE(JPISO,SNEJ,NVOL,NTMP,NDEN,NAWR,ENERG) + DEALLOCATE(NMIX,INNRF,INNAM) + CALL LCMSIX(IPEDIT,' ',2) + ENDIF + ENDIF +*---- +* COMPUTE MACROSCOPIC RESIDUAL CROSS SECTIONS +*---- + IF(LMACR.AND.(NBMICR.NE.0).AND.(NBMICR.NE.-1).AND.(NBISO.NE.0) + > .AND.(CURNAM.NE.' ')) THEN + IPRIN2=IPRINT-1 + CALL EDIRES(IPEDIT,IPFLUX,IPLIB,IADJ,NL,NDEL,NBESP,NBISO,NDEPL, + > ISONA,ISONR,IPISO,MIX,TN,NED,HVECT,NOUT,HVOUT,IPRIN2, + > NGROUP,NGCOND,NBMIX,NREGIO,NMERGE,NDFI,NDFP,ILEAKS, + > ILUPS,NW,MATCOD,VOLUME,KEYFLX,CURNAM,IGCOND,IMERGE, + > FLUXES,AFLUXE,EIGENK,EIGINF,B2,DEN,ITYPE,LSISO,EMEVF, + > EMEVG,DECAY,YIELD,FIPI,FIFP,PYIELD,ITRANC,LISO, + > NMLEAK) + ENDIF +*---- +* EDIT MICROSCOPIC ACTIVATION XS +*---- + IF(NACTI.GT.0) THEN + CALL EDIACT(IPEDIT,IPRINT,NGROUP,NGCOND,NREGIO,NMERGE,NL,NBISO, + > NED,VOLUME,MIX,IGCOND,IMERGE,FLUXES(1,1,1),ITRANC, + > ISONA,IPISO,HVECT,CURNAM,NACTI,IACTI,EMEVF,EMEVG) + ENDIF +*---- +* STATISTICS AND DELTA SIGMAS +*---- + IF(NSTATS.NE.0) THEN + CALL EDIDST(IPEDIT,IPRINT,NL,NGCOND,NMERGE,NSTATS,ILEAKS, + > EIGENK,B2,VOLME,WLETY,TAUXT,FLUXC,SCATS,OLDNAM, + > NW,NTAUXT) + ENDIF +*---- +* FOUR FACTORS +*---- + IF(IFFAC.NE.0) THEN + CALL EDIBAL(IPEDIT,IPFLUX,IPRINT,NL,IFFAC,NGCOND,NMERGE,EIGENK, + > TAUXT,FLUXC,SCATS,ILEAKS,B2,NW,NTAUXT) + ENDIF +* + IF(ALLOCATED(PYIELD)) DEALLOCATE(PYIELD,YIELD,FIFP,FIPI) + DEALLOCATE(DECAY) + DEALLOCATE(EMEVG,EMEVF) + DEALLOCATE(SCATS,SIGS,FADJC,FLUXC,TAUXT) + DEALLOCATE(WE,WLETY,VOLME) + IF(HSIGN.EQ.'L_LIBRARY') THEN + DEALLOCATE(IPISO,ISONR,ISONA,IDEPL,TN,MIX,ITYPE,DEN,LSISO) + ENDIF +*---- +* SET IADF IN MACROLIB AND MICROLIB STATE VECTORS +*---- + IF((CURNAM.NE.' ').AND.(IADF.NE.0)) THEN + IPMIC2=LCMDID(IPEDIT,CURNAM) + IPMAC2=LCMDID(IPMIC2,'MACROLIB') + CALL LCMLEN(IPMAC2,'ADF',ILCMLN,ITYLCM) + IF(ILCMLN.NE.0) THEN + IF(IADF.EQ.4) THEN + JADF=IDFM + ELSE + JADF=0 + CALL LCMSIX(IPMAC2,'ADF',1) + CALL LCMLEN(IPMAC2,'ALBS00',ILCMLN,ITYLCM) + IF(ILCMLN.NE.0) JADF=1 + CALL LCMLEN(IPMAC2,'HADF',ILCMLN,ITYLCM) + IF((IADF.EQ.2).AND.(ILCMLN.NE.0)) JADF=2 + IF((IADF.EQ.-2).AND.(ILCMLN.NE.0)) JADF=3 + CALL LCMSIX(IPMAC2,' ',2) + ENDIF + CALL LCMGET(IPMAC2,'STATE-VECTOR',IPAR) + IPAR(12)=JADF + CALL LCMPUT(IPMAC2,'STATE-VECTOR',NSTATE,1,IPAR) + IF((NBMICR.NE.0).AND.(HSIGN.EQ.'L_LIBRARY')) THEN + CALL LCMGET(IPMIC2,'STATE-VECTOR',IPAR) + IPAR(24)=JADF + CALL LCMPUT(IPMIC2,'STATE-VECTOR',NSTATE,1,IPAR) + ENDIF + ENDIF + ENDIF +*---- +* INCLUDE LEAKAGE IN THE MACROLIB (USED ONLY FOR NON-REGRESSION TESTS) +*---- + IF(BB2.NE.0.0) THEN + IF(IPRINT.GT.0) WRITE(6,'(/32H EDIDRV: INCLUDE LEAKAGE IN THE , + > 13HMACROLIB (B2=,1P,E12.5,2H).)') BB2 + IPMIC2=LCMGID(IPEDIT,CURNAM) + IPMAC2=LCMGID(IPMIC2,'MACROLIB') + JPMAC2=LCMGID(IPMAC2,'GROUP') + ALLOCATE(WORK1(NMERGE),WORK2(NMERGE)) + DO IGR=1,NGCOND + KPMAC2=LCMGIL(JPMAC2,IGR) + CALL LCMGET(KPMAC2,'DIFF',WORK1) + CALL LCMGET(KPMAC2,'NTOT0',WORK2) + WORK2(:NMERGE)=WORK2(:NMERGE)+BB2*WORK1(:NMERGE) + CALL LCMPUT(KPMAC2,'NTOT0',NMERGE,2,WORK2) + ENDDO + DEALLOCATE(WORK2,WORK1) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(AFLUXE,FLUXES) + RETURN +*---- +* FORMAT +*---- + 6000 FORMAT(1X,A6,': GENERATING ISOTXS FILE ') + 6002 FORMAT(8X,' FOR EDITING MIXTURE = ',I6, + > ' INFORMATION STORED ON FILE = ',A12) + 9000 FORMAT(1X,A6,3X,A12,3X,A12,3X,A4,I6,5X,A12) + END diff --git a/Dragon/src/EDIDST.f b/Dragon/src/EDIDST.f new file mode 100644 index 0000000..5f015f4 --- /dev/null +++ b/Dragon/src/EDIDST.f @@ -0,0 +1,431 @@ +*DECK EDIDST + SUBROUTINE EDIDST(IPEDIT,IPRINT,NL,NGCOND,NMERGE,NSTATS,ILEAKS, + > EIGENK,B2,VOLMER,WLETYC,RATECM,FLUXCM,SCATTS, + > OLDNAM,NW,NTAUXT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Reaction rates and fluxes statistics. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPEDIT pointer to the edition LCM object. +* IPRINT print level; +* = 0 no print; +* = 1 print fluxes; +* = 2 1+print reaction rates; +* = 3 2+print homogenized cross sections. +* NL number of legendre orders. +* NGCOND number of groups. +* NMERGE number of regions. +* NSTATS statistics options: +* = 1 flux stats; +* = 2 reaction rates stats; +* = 3 flux+reaction rates stats; +* =-1 delta sigma calculations. +* ILEAKS type of leakage calculation: +* = 0 no leakage; +* = 1 homogeneous leakage (Diffon); +* = 2 isotropic streaming (Ecco); +* = 3 anisotropic streaming (Tibere). +* EIGENK New eigenvalue. +* B2 New buckling. +* VOLMER volume of merged regions. +* WLETYC lethargy width. +* RATECM averaged region/group cross sections: +* = RATECM(*,1) = total P0; +* = RATECM(*,2) = total P1; +* = RATECM(*,NW+2) = absorption; +* = RATECM(*,NW+3) = fission; +* = RATECM(*,NW+4) = fixed sources / productions; +* = RATECM(*,NW+5) = leakage; +* = RATECM(*,NW+6) = total out of group scattering; +* = RATECM(*,NW+7) = diagonal scattering x-s; +* = RATECM(*,NW+8) = chi; +* = RATECM(*,NW+9) = wims type transport correction; +* = RATECM(*,NW+10) = x-directed leakage; +* = RATECM(*,NW+11) = y-directed leakage; +* = RATECM(*,NW+12) = z-directed leakage; +* = RATECM(*,NW+13) = nu-sigf for delayed neutrons; +* = RATECM(*,NW+13+NDEL) = fission spectra for delayed neutrons. +* FLUXCM integrated region/group fluxes: +* = FLUXCM(*,1) = fluxes P0; +* = FLUXCM(*,2) = fluxes P1. +* SCATTS new scattering matrix. +* OLDNAM name of reference calculation directory. +* NW type of weighting for PN cross section info (=0 P0; =1 P1). +* NTAUXT number of reaction rate edits. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPEDIT + INTEGER IPRINT,NL,NGCOND,NMERGE,NSTATS,ILEAKS,NW,NTAUXT + REAL EIGENK,B2,VOLMER(NMERGE),WLETYC(NGCOND), + > RATECM(NMERGE,NGCOND,NTAUXT), + > FLUXCM(NMERGE,NGCOND,NW+1), + > SCATTS(NMERGE,NGCOND,NGCOND,NL) + CHARACTER OLDNAM*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6,ILCMUP=1,ILCMDN=2,TRONCE=0.001,NSTATE=40) + TYPE(C_PTR) JPEDIT,KPEDIT + CHARACTER CXSNAM*12,CM*2 + INTEGER IDATA(NSTATE) + DOUBLE PRECISION SOUOLD,SOUNEW + REAL EIGOLD,B2OLD(4) + INTEGER IEGC,IB2C + INTEGER, ALLOCATABLE, DIMENSION(:) :: INGSCT,IFGSCT,IPOSCT + REAL, ALLOCATABLE, DIMENSION(:) :: FLXNEW,FLXOLD,OLDRAT,XSCAT, + > DELSC +*---- +* SCRATCH STORAGE ALLOCATION +* FLXNEW new fluxes. +* FLXOLD old fluxes. +* OLDRAT old rates. +*---- + ALLOCATE(FLXNEW(NMERGE),FLXOLD(NMERGE),OLDRAT(NMERGE+NGCOND)) +*---- + CALL LCMLEN(IPEDIT,OLDNAM,ILCMLN,ILCMTY) + IF(ILCMLN.GE.0) THEN + WRITE(IUNOUT,7000) OLDNAM + CALL LCMLIB(IPEDIT) + RETURN + ENDIF + CALL LCMSIX(IPEDIT,OLDNAM,ILCMUP) + CALL LCMLEN(IPEDIT,'DELTAU',ILCMLN,ILCMTY) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(IPEDIT,'DELTAU',OLDRAT) + ERRREL=0.0 + DO 80 IGR=1,NGCOND + ERRREL=ERRREL+ABS(WLETYC(IGR)-OLDRAT(IGR)) + 80 CONTINUE + ERRREL=ERRREL/NGCOND + IF(ERRREL.GT.TRONCE) THEN + WRITE(IUNOUT,7004) ERRREL,TRONCE + CALL LCMSIX(IPEDIT,' ',ILCMDN) + RETURN + ENDIF + ENDIF + CALL LCMSIX(IPEDIT,'MACROLIB',ILCMUP) + CALL LCMGET(IPEDIT,'STATE-VECTOR',IDATA) + NGOLD=IDATA(1) + NROLD=IDATA(2) + CALL LCMLEN(IPEDIT,'K-EFFECTIVE',ILCMLN,ILCMTY) + IEGC=0 + IF(ILCMLN .EQ. 1) THEN + CALL LCMGET(IPEDIT,'K-EFFECTIVE',EIGOLD) + IEGC=1 + ELSE + EIGOLD=1.0 + ENDIF + IB2C=0 + B2OLD(:4)=0.0 + CALL LCMLEN(IPEDIT,'B2 HETE',ILCMLN,ILCMTY) + IF(ILCMLN .EQ. 1) THEN + CALL LCMGET(IPEDIT,'B2 HETE',B2OLD) + IB2C=2 + ELSE + CALL LCMLEN(IPEDIT,'B2 B1HOM',ILCMLN,ILCMTY) + IF(ILCMLN .EQ. 1) THEN + CALL LCMGET(IPEDIT,'B2 B1HOM',B2(4)) + IB2C=1 + ENDIF + ENDIF + IF( (NROLD.NE.NMERGE).OR.(NGOLD.NE.NGCOND)) THEN + WRITE(IUNOUT,7001) NMERGE,NROLD,NGCOND,NGOLD + CALL LCMSIX(IPEDIT,' ',ILCMDN) + CALL LCMSIX(IPEDIT,' ',ILCMDN) + RETURN + ENDIF +*---- +* COMPUTE TOTAL SOURCES FOR RELATIVE FLUX NORMALIZATION +*---- + SOUOLD=0.0D0 + SOUNEW=0.0D0 + JPEDIT=LCMGID(IPEDIT,'GROUP') + DO 300 IGR=1,NGCOND + KPEDIT=LCMGIL(JPEDIT,IGR) + CALL LCMGET(KPEDIT,'FLUX-INTG',FLXOLD) + DO 310 IREG=1,NMERGE + FLXNEW(IREG)=FLUXCM(IREG,IGR,1) + 310 CONTINUE + CALL LCMGET(KPEDIT,'PRODUCTION',OLDRAT) + DO 320 IREG=1,NMERGE + SOUOLD=SOUOLD+DBLE(FLXOLD(IREG))*DBLE(OLDRAT(IREG)) + SOUNEW=SOUNEW+DBLE(FLXNEW(IREG))*DBLE(RATECM(IREG,IGR,NW+4)) + 320 CONTINUE + 300 CONTINUE +*---- +* CHECK FOR VOLUME CONSISTENCE +*---- + VOLTOT=0.0 + VOLT2=0.0 + CALL LCMGET(IPEDIT,'VOLUME',OLDRAT) + DO 100 IREG=1,NMERGE + VOLTOT=VOLTOT+VOLMER(IREG) + VOLT2=VOLT2+OLDRAT(IREG) + 100 CONTINUE + VOLREL=VOLT2 /VOLTOT + DO 101 IREG=1,NMERGE + VREL1=VOLMER(IREG)/VOLTOT + VREL2=OLDRAT(IREG)/VOLT2 + ERRREL=ABS(VREL1-VREL2)/VREL2 + IF(ERRREL.GT.TRONCE) THEN + WRITE(IUNOUT,7002) VOLREL,IREG,ERRREL,TRONCE + CALL LCMSIX(IPEDIT,' ',ILCMDN) + CALL LCMSIX(IPEDIT,' ',ILCMDN) + RETURN + ENDIF + 101 CONTINUE + IF((SOUOLD.EQ.0.0D0).OR.(SOUNEW.EQ.0.0D0)) THEN + WRITE(IUNOUT,7005) + SOUREL=1.0 + ELSE + SOUREL=REAL(SOUOLD/SOUNEW) + ENDIF + WRITE(IUNOUT,6000) OLDNAM,NGCOND,NMERGE,VOLREL,SOUREL + IF(IEGC .EQ. 1) THEN + WRITE(IUNOUT,6010) EIGOLD,EIGENK,1000.*(EIGENK-EIGOLD) + ENDIF + IF(IB2C .GE. 1) THEN + WRITE(IUNOUT,6011) B2OLD(4),B2(4),B2(4)-B2OLD(4) + ENDIF + IF(NSTATS.EQ.-1) THEN + ALLOCATE(INGSCT(NMERGE),IFGSCT(NMERGE),IPOSCT(NMERGE)) + ALLOCATE(XSCAT(NMERGE*NGCOND),DELSC(NGCOND)) + ENDIF + DO 210 IGR=1,NGCOND + KPEDIT=LCMGIL(JPEDIT,IGR) + WRITE(IUNOUT,6001) IGR + CXSNAM='FLUX-INTG' + CALL LCMGET(KPEDIT,CXSNAM,FLXOLD) + IF(NSTATS.GE.1) THEN + IF(NSTATS.NE.2) THEN + WRITE(IUNOUT,6002) CXSNAM + ITYPE=1 + CALL EDISTA(IPRINT,NMERGE,ITYPE,VOLMER,SOUREL,VOLT2, + > FLUXCM(1,IGR,1),FLXOLD,RATECM(1,IGR,1),OLDRAT) + ENDIF + IF(NSTATS.GE.2) THEN + DO 102 IREG=1,NMERGE + FLXNEW(IREG)=FLUXCM(IREG,IGR,1) + 102 CONTINUE + ITYPE=2 + CXSNAM='NTOT0' + CALL LCMGET(KPEDIT,CXSNAM,OLDRAT) + WRITE(IUNOUT,6002) CXSNAM + CALL EDISTA(IPRINT,NMERGE,ITYPE,VOLMER,SOUREL,VOLT2, + > FLXNEW(1),FLXOLD,RATECM(1,IGR,1),OLDRAT) + CXSNAM='ABS' + CALL LCMGET(KPEDIT,CXSNAM,OLDRAT) + WRITE(IUNOUT,6002) CXSNAM + CALL EDISTA(IPRINT,NMERGE,ITYPE,VOLMER,SOUREL,VOLT2, + > FLXNEW(1),FLXOLD,RATECM(1,IGR,NW+2),OLDRAT) + CXSNAM='PRODUCTION' + CALL LCMGET(KPEDIT,CXSNAM,OLDRAT) + WRITE(IUNOUT,6002) CXSNAM + CALL EDISTA(IPRINT,NMERGE,ITYPE,VOLMER,SOUREL,VOLT2, + > FLXNEW(1),FLXOLD,RATECM(1,IGR,NW+4),OLDRAT) + IF(IDATA(4).EQ.1) THEN + CXSNAM='NUSIGF' + CALL LCMGET(KPEDIT,CXSNAM,OLDRAT) + WRITE(IUNOUT,6002) CXSNAM + CALL EDISTA(IPRINT,NMERGE,ITYPE,VOLMER,SOUREL,VOLT2, + > FLXNEW(1),FLXOLD,RATECM(1,IGR,NW+3),OLDRAT) + ENDIF + DO 134 IL=1,NL + WRITE (CM,'(I2.2)') IL-1 + CXSNAM='SIGW'//CM + CALL LCMLEN(KPEDIT,CXSNAM,ILCMLN,ILCMTY) + IF(ILCMLN.EQ.NMERGE) THEN + CALL LCMGET(KPEDIT,CXSNAM,OLDRAT) + WRITE(IUNOUT,6002) CXSNAM + CALL EDISTA(IPRINT,NMERGE,ITYPE,VOLMER,SOUREL,VOLT2, + > FLXNEW(1),FLXOLD,SCATTS(1,IGR,IGR,IL), + > OLDRAT) + ENDIF + 134 CONTINUE + IF(ILEAKS.EQ.3) THEN + CXSNAM='DIFFX' + CALL LCMLEN(KPEDIT,CXSNAM,ILCMLN,ILCMTY) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPEDIT,CXSNAM,OLDRAT) + WRITE(IUNOUT,6003) CXSNAM + CALL EDISTA(IPRINT,NMERGE,ITYPE,VOLMER,SOUREL,VOLT2, + > FLXNEW(1),FLXOLD,RATECM(1,IGR,NW+10),OLDRAT) + ENDIF + CXSNAM='DIFFY' + CALL LCMLEN(KPEDIT,CXSNAM,ILCMLN,ILCMTY) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPEDIT,CXSNAM,OLDRAT) + WRITE(IUNOUT,6003) CXSNAM + CALL EDISTA(IPRINT,NMERGE,ITYPE,VOLMER,SOUREL,VOLT2, + > FLXNEW(1),FLXOLD,RATECM(1,IGR,NW+11),OLDRAT) + ENDIF + CXSNAM='DIFFZ' + CALL LCMLEN(KPEDIT,CXSNAM,ILCMLN,ILCMTY) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPEDIT,CXSNAM,OLDRAT) + WRITE(IUNOUT,6003) CXSNAM + CALL EDISTA(IPRINT,NMERGE,ITYPE,VOLMER,SOUREL,VOLT2, + > FLXNEW(1),FLXOLD,RATECM(1,IGR,NW+12),OLDRAT) + ENDIF + ENDIF + CXSNAM='DIFF' + CALL LCMLEN(KPEDIT,CXSNAM,ILCMLN,ILCMTY) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPEDIT,CXSNAM,OLDRAT) + WRITE(IUNOUT,6003) CXSNAM + CALL EDISTA(IPRINT,NMERGE,ITYPE,VOLMER,SOUREL,VOLT2, + > FLXNEW(1),FLXOLD,RATECM(1,IGR,NW+5),OLDRAT) + ENDIF + ENDIF + ELSE IF(NSTATS.EQ.-1) THEN + ITYPE=3 + CXSNAM='NTOT0' + CALL LCMGET(KPEDIT,CXSNAM,OLDRAT) + WRITE(IUNOUT,6003) CXSNAM + CALL EDISTA(IPRINT,NMERGE,ITYPE,VOLMER,SOUREL,VOLT2, + > FLXNEW(1),FLXOLD,RATECM(1,IGR,1),OLDRAT) + CXSNAM='ABS' + CALL LCMGET(KPEDIT,CXSNAM,OLDRAT) + WRITE(IUNOUT,6003) CXSNAM + CALL EDISTA(IPRINT,NMERGE,ITYPE,VOLMER,SOUREL,VOLT2, + > FLXNEW(1),FLXOLD,RATECM(1,IGR,NW+2),OLDRAT) + IF(IDATA(4).EQ.1) THEN + CXSNAM='NUSIGF' + CALL LCMGET(KPEDIT,CXSNAM,OLDRAT) + WRITE(IUNOUT,6003) CXSNAM + CALL EDISTA(IPRINT,NMERGE,ITYPE,VOLMER,SOUREL,VOLT2, + > FLXNEW(1),FLXOLD,RATECM(1,IGR,NW+3),OLDRAT) + ENDIF + IF(ILEAKS.EQ.3) THEN + CXSNAM='DIFFX' + CALL LCMLEN(KPEDIT,CXSNAM,ILCMLN,ILCMTY) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPEDIT,CXSNAM,OLDRAT) + WRITE(IUNOUT,6003) CXSNAM + CALL EDISTA(IPRINT,NMERGE,ITYPE,VOLMER,SOUREL,VOLT2, + > FLXNEW(1),FLXOLD,RATECM(1,IGR,NW+10),OLDRAT) + ENDIF + CXSNAM='DIFFY' + CALL LCMLEN(KPEDIT,CXSNAM,ILCMLN,ILCMTY) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPEDIT,CXSNAM,OLDRAT) + WRITE(IUNOUT,6003) CXSNAM + CALL EDISTA(IPRINT,NMERGE,ITYPE,VOLMER,SOUREL,VOLT2, + > FLXNEW(1),FLXOLD,RATECM(1,IGR,14),OLDRAT) + ENDIF + CXSNAM='DIFFZ' + CALL LCMLEN(KPEDIT,CXSNAM,ILCMLN,ILCMTY) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPEDIT,CXSNAM,OLDRAT) + WRITE(IUNOUT,6003) CXSNAM + CALL EDISTA(IPRINT,NMERGE,ITYPE,VOLMER,SOUREL,VOLT2, + > FLXNEW(1),FLXOLD,RATECM(1,IGR,15),OLDRAT) + ENDIF + ENDIF + CXSNAM='DIFF' + CALL LCMLEN(KPEDIT,CXSNAM,ILCMLN,ILCMTY) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPEDIT,CXSNAM,OLDRAT) + WRITE(IUNOUT,6003) CXSNAM + CALL EDISTA(IPRINT,NMERGE,ITYPE,VOLMER,SOUREL,VOLT2, + > FLXNEW(1),FLXOLD,RATECM(1,IGR,NW+5),OLDRAT) + ENDIF + CXSNAM='TRANC' + CALL LCMLEN(KPEDIT,CXSNAM,ILCMLN,ILCMTY) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPEDIT,CXSNAM,OLDRAT) + WRITE(IUNOUT,6003) CXSNAM + CALL EDISTA(IPRINT,NMERGE,ITYPE,VOLMER,SOUREL,VOLT2, + > FLXNEW(1),FLXOLD,RATECM(1,IGR,NW+9),OLDRAT) + ENDIF + DO 135 IL=1,NL + WRITE (CM,'(I2.2)') IL-1 + CALL LCMLEN(KPEDIT,'NJJS'//CM,ILCMLN,ILCMTY) + CXSNAM='SCATTERING'//CM + IF(ILCMLN.EQ.NMERGE) THEN + WRITE(IUNOUT,6003) CXSNAM + CALL LCMGET(KPEDIT,'NJJS'//CM,INGSCT) + CALL LCMGET(KPEDIT,'IJJS'//CM,IFGSCT) + CALL LCMGET(KPEDIT,'IPOS'//CM,IPOSCT) + CALL LCMGET(KPEDIT,'SCAT'//CM,XSCAT) + CALL EDIDEL(IPRINT,NGCOND,NMERGE,IGR,SCATTS(1,1,1,IL), + > INGSCT,IFGSCT,IPOSCT,XSCAT,DELSC) + ENDIF + 135 CONTINUE + ENDIF + 210 CONTINUE + CALL LCMSIX(IPEDIT,' ',ILCMDN) + CALL LCMSIX(IPEDIT,' ',ILCMDN) + IF(NSTATS.EQ.-1) THEN + DEALLOCATE(DELSC,XSCAT) + DEALLOCATE(IPOSCT,IFGSCT,INGSCT) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(OLDRAT,FLXOLD,FLXNEW) + RETURN +*---- +* FORMAT +*---- + 7000 FORMAT(' ****** EDIDST WARNING ', + >'ROUTINE ******'/' ****** ',A12,' REFERENCE EXECUTION', + >' DIRECTORY NOT ON LCM ******'/'************************', + >'**********************************************') + 7001 FORMAT(' ****** EDIDST WARNING ', + >'ROUTINE ******'/' ****** NUMBER OF REGION OR NUMBER OF ', + >'GROUP INCONSISTENT ******'/ + >6X,I10,' CURRENT REGIONS'/6X,I10,' OLD REGIONS'/6X,I10,' CURRENT', + >' GROUPS'/6X,I10,' OLD GROUPS'/'************************', + >'**********************************************') + 7002 FORMAT(' ****** EDIDST WARNING ', + >'ROUTINE ******'/' ****** RELATIVE ERROR IN VOLUME: CURRENT ', + >'TO REFERENCE TOO LARGE ******'/ + >6X,' CURRENT VOLUME/REFERENCE VOLUME =',1P,E12.4/ + >6X,' REGION NUMERO =',I10/6X,' RELATIVE ERROR =',E12.4/ + >6X,' ERROR ALLOWED =',E12.4/'************************', + >'**********************************************') + 7004 FORMAT(' ****** EDIDST WARNING ', + >'ROUTINE ******'/' ****** AVERAGE ABSOLUTE ERROR ON LETHARGY', + >' WIDTH TOO LARGE ******'/6X,' RELATIVE ERROR =',E12.4/ + >6X,' ERROR ALLOWED =',E12.4/'************************', + >'**********************************************') + 7005 FORMAT(' ************** EDIDST WARNING **************',/ + > ' TOTAL NEW AND/OR OLD SOURCE IS 0.0 ',/ + > ' RELATIVE SOURCE NORMALIZATION FACTOR SET TO 1.0',/ + > '************************************************') + 6000 FORMAT(///20X,'D R A G O N S T A T I S T I C S'/ + >10X,'LCM REFERENCE CASE NAME : ',A12/ + >10X,'NUMBER OF GROUPS : ',I10/ + >10X,'NUMBER OF REGIONS : ',I10/ + >10X,'RELATIVE VOLUMES : ',1P,E12.4/ + >10X,'RELATIVE SOURCES : ',1P,E12.4) + 6001 FORMAT(/' ANALYSIS OF GROUP : ',I5) + 6002 FORMAT(/' STATISTICS FOR : ',A12) + 6003 FORMAT(/' DELTA SIGMA FOR : ',A12) + 6010 FORMAT(/ + >10X,'REFERENCE Keff : ',F15.5/ + >10X,'CURRENT Keff : ',F15.5/ + >10X,'CHANGE IN Keff : ',3X,F12.2,' mk') + 6011 FORMAT(1P/ + >10X,'REFERENCE B2 : ',E15.3/ + >10X,'CURRENT B2 : ',E15.3/ + >10X,'CHANGE IN B2 : ',E15.3) + END diff --git a/Dragon/src/EDIDTX.f b/Dragon/src/EDIDTX.f new file mode 100644 index 0000000..28c4b21 --- /dev/null +++ b/Dragon/src/EDIDTX.f @@ -0,0 +1,945 @@ +*DECK EDIDTX + SUBROUTINE EDIDTX(IPEDIT,IPFLUX,IPMACR,IADJ,IPRINT,NL,NDEL,NALBP, + > ITRANC,NGROUP,NGCOND,NBMIX,NREGIO,NMERGE,ILEAKS, + > ILUPS,NW,MATCOD,VOLUME,KEYFLX,IGCOND,IMERGE, + > FLUXES,AFLUXE,EIGENK,VOLMER,WLETYC,WENERG, + > RATECM,FLUXCM,FADJCM,FLXINT,SCATTD,SCATTS, + > NIFISS,NSAVES,CURNAM,NEDMAC,SIGS,B2,IGOVE, + > CUREIN,TIMEF,NTAUXT,NMLEAK) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Evaluate and print macroscopic reaction rates. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPEDIT pointer to the edition LCM object. +* IPFLUX pointer to the solution LCM object. +* IPMACR pointer to the macrolib LCM object. +* IADJ type of flux weighting: +* = 0 direct flux weighting; +* = 1 direct-adjoint flux weighting. +* IPRINT print level; +* = 0 no print; +* = 1 print fluxes; +* = 2 1+print reaction rates; +* = 3 2+print homogenized cross sections. +* NL number of Legendre orders. +* NDEL number of delayed precursor groups. +* NALBP number of physical albedos. +* ITRANC type of transport corrections. +* NGROUP number of groups. +* NGCOND number of groups condensed. +* NBMIX number of mixtures. +* NREGIO number of regions. +* NMERGE number of merged regions. +* ILEAKS type of leakage calculation: +* = 0 no leakage; +* = 1 homogeneous leakage (Diffon); +* = 2 isotropic streaming (Ecco); +* = 3 anisotropic streaming (Tibere). +* ILUPS flag to remove up-scattering from output. +* NW type of weighting for P1 cross section info (=0 P0; =1 P1). +* MATCOD material per region. +* VOLUME volume of region. +* KEYFLX average flux position per region. +* IGCOND limit condensed groups. +* IMERGE index of merged regions. +* FLUXES fluxes. +* AFLUXE adjoint fluxes. +* EIGENK eigenvalue for problem. +* B2 square buckling: +* for ILEAKS=1,2: B2(4) is homogeneous; +* for ILEAKS=3: B2(1),B2(2),B2(3) are directional heterogeneous +* and B2(4) is homogeneous. +* IGOVE Golfier-Vergain flag (=0/1: don't/use Golfier-Vergain equ'n). +* CUREIN infinite multiplication factor. +* NTAUXT number of reaction rate edits (=15+2*NDEL). +* TIMEF time stamp in day/burnup/irradiation. +* NMLEAK number of leakage zones. +* +*Parameters: output +* VOLMER volume of region merged. +* WLETYC lethargy width condensed. +* WENERG energy group limits. +* RATECM averaged region/group cross sections: +* = RATECM(*,1) = total P0; +* = RATECM(*,2) = total P1; +* = RATECM(*,NW+2) = absorption; +* = RATECM(*,NW+3) = fission; +* = RATECM(*,NW+4) = fixed sources / productions; +* = RATECM(*,NW+5) = leakage; +* = RATECM(*,NW+6) = total out of group scattering; +* = RATECM(*,NW+7) = diagonal scattering x-s; +* = RATECM(*,NW+8) = chi; +* = RATECM(*,NW+9) = wims type transport correction; +* = RATECM(*,NW+10) = x-directed leakage; +* = RATECM(*,NW+11) = y-directed leakage; +* = RATECM(*,NW+12) = z-directed leakage; +* = RATECM(*,NW+13) = nu-sigf for delayed neutrons; +* = RATECM(*,NW+13+NDEL) = fission spectra for delayed neutrons. +* FLUXCM integrated region/group fluxes: +* = FLUXCM(*,1) = fluxes P0; +* = FLUXCM(*,2) = fluxes P1. +* FADJCM averaged region/group adjoint fluxes: +* = FADJCM(*,1) = adjoint fluxes P0; +* = FADJCM(*,2) = adjoint fluxes P1. +* FLXINT integrated flux. +* SCATTD scattering rates. +* SCATTS homogenized scattering cross sections. +* NIFISS number of fissile isotopes. +* NSAVES homogenized x-s compute/save flag: +* = 0 no compute, no save; +* = 1 compute, no save; +* = 2 compute and save. +* CURNAM name of LCM directory where the merged/condensed x-s are +* stored. +* NEDMAC number of extra edit vectors. +* SIGS Legendre dependent scattering cross sections. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPEDIT,IPFLUX,IPMACR + INTEGER IADJ,IPRINT,NL,NDEL,NALBP,ITRANC,NGROUP,NGCOND,NBMIX, + > NREGIO,NMERGE,ILEAKS,ILUPS,NW,MATCOD(NREGIO), + > KEYFLX(NREGIO),IGCOND(NGCOND),IMERGE(NREGIO), + > NIFISS,NSAVES,NEDMAC,NTAUXT,IGOVE,NMLEAK + REAL VOLUME(NREGIO),FLUXES(NREGIO,NGROUP,NW+1), + > AFLUXE(NREGIO,NGROUP,NW+1),EIGENK,VOLMER(NMERGE), + > WENERG(NGCOND+1),RATECM(NMERGE,NGCOND,NTAUXT), + > FLUXCM(NMERGE,NGCOND,NW+1),FADJCM(NMERGE,NGCOND,NW+1), + > FLXINT(NREGIO,NGROUP,NW+1),WLETYC(NGCOND), + > SCATTS(NMERGE,NGCOND,NGCOND,NL), + > SIGS(NMERGE,NGCOND,NL),B2(4),CUREIN,TIMEF(3) + CHARACTER CURNAM*12 + DOUBLE PRECISION SCATTD(NMERGE,NGCOND,NGCOND,NL) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPFLUX,JPMACR,KPMACR + CHARACTER APG*3 + PARAMETER (IUNOUT=6,APG=' > ',ILCMUP=1,ILCMDN=2) + CHARACTER TEXT12*12,CM*2,OPTION*4 + LOGICAL LH,LSPH + DOUBLE PRECISION SCATW,CSCAT,TOTFIS,FXSOUR,FLFUEL,FCELL + INTEGER IFSKP,ISKP(3) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IFUELR,INGSCT,IFGSCT,IPOSCT, + > IMERGL + REAL, ALLOCATABLE, DIMENSION(:) :: DISFCT,SIGMA,XSCAT,WORKF, + > ENERG,SIGMAF + REAL, ALLOCATABLE, DIMENSION(:,:) :: FFUEL,FLDMC,OVERV,HFACT,HSPH, + > DECAY,ALBPGR,DIFHET + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: TAUXE,ALBP,ALBPGR2 + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HVECT +*---- +* SCRATCH STORAGE ALLOCATION +* HVECT extra edit names. +* IFUELR fuel region location. +* DISFCT disadvantage factor. +* TAUXE extra edit rates. +* FFUEL flux in fuel. +* FLDMC fission rate condensed. +* OVERV 1/v merge condensed. +* HFACT H-factors. +* HSPH SPH factors. +* DECAY precursor decay constants. +* ALBP physical albedos. +*---- + ALLOCATE(HVECT(NEDMAC),IFUELR(NREGIO)) + ALLOCATE(DISFCT(NGCOND),TAUXE(NMERGE,NGCOND,NEDMAC), + > FFUEL(NREGIO,NIFISS),FLDMC(NMERGE,NGCOND),OVERV(NMERGE,NGCOND), + > HFACT(NMERGE,NGCOND),HSPH(NMERGE,NGCOND),DECAY(NDEL,NIFISS), + > ALBP(NALBP,NGCOND,NGCOND)) +*---- +* ALLOCATE WORK VECTOR AND INITIALIZE REQUIRED VECTORS +*---- + ILEAK2=ILEAKS + ALLOCATE(INGSCT(NBMIX),IFGSCT(NBMIX),IPOSCT(NBMIX)) + ALLOCATE(SIGMA(0:NBMIX*MAX(NIFISS,1)),XSCAT(NBMIX*NGROUP)) + RATECM(:NMERGE,:NGCOND,:NTAUXT)=0.0 + FLUXCM(:NMERGE,:NGCOND,:NW+1)=0.0 + FADJCM(:NMERGE,:NGCOND,:NW+1)=0.0 + SIGS(:NMERGE,:NGCOND,:NL)=0.0 + OVERV(:NMERGE,:NGCOND)=0.0 + HFACT(:NMERGE,:NGCOND)=0.0 + HSPH(:NMERGE,:NGCOND)=0.0 + TAUXE(:NMERGE,:NGCOND,:NEDMAC)=0.0 + VOLMER(:NMERGE)=0.0 + FFUEL(:NREGIO,:NIFISS)=0.0 + IFUELR(:NREGIO)=0 + SIGMA(0)=0.0 + IF(IADJ.EQ.0) THEN + IOP=1 + ELSE IF(IADJ.EQ.1) THEN + IOP=11 + ENDIF +*---- +* FIND EDIT XS +*---- + IF(NEDMAC.GT.0) CALL LCMGTC(IPMACR,'ADDXSNAME-P0',8,NEDMAC,HVECT) +*---- +* ENERGY AND LETHARGY CONDENSATION +*---- + CALL LCMLEN(IPMACR,'ENERGY',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.0) THEN + NENER=0 + WLETYC(:NGCOND)=0.0 + WENERG(:NGCOND+1)=0.0 + ELSE IF(ILCMLN.EQ.NGROUP+1) THEN + NENER=NGCOND+1 + ALLOCATE(ENERG(NGROUP+1)) + CALL LCMGET(IPMACR,'ENERGY',ENERG) + WENERG(1)=ENERG(1) + DO 30 IGC=1,NGCOND + WENERG(IGC+1)=ENERG(IGCOND(IGC)+1) + WLETYC(IGC)=LOG(WENERG(IGC)/WENERG(IGC+1)) + 30 CONTINUE + IF(ENERG(NGROUP+1).EQ.0.0) ENERG(NGROUP+1)=1.0E-5 + DEALLOCATE(ENERG) + ELSE + CALL XABORT('EDIDTX: READ ERROR INVALID NUMBER OF GROUPS') + ENDIF +*---- +* COMPUTE MERGED VOLUME +*---- + DO 50 IREGIO=1,NREGIO + IKK=IMERGE(IREGIO) + IF(IKK.GT.0) THEN + VOLMER(IKK)=VOLMER(IKK)+VOLUME(IREGIO) + ENDIF + 50 CONTINUE +*---- +* COMPUTE INTEGRATED/CONDENSED FUNDAMENTAL CURRENTS (ILEAKS=2,3) +*---- + IF(ILEAKS.EQ.2) THEN + IF(IADJ.EQ.1) CALL XABORT('EDIDTX: DIRECT-ADJOINT WEIGTING NOT' + > //' IMPLEMENTED.') + CALL LCMLEN(IPFLUX,'FLUX',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.0) CALL XABORT('EDIDTX: MISSING FLUX INFO.') + JPFLUX=LCMGID(IPFLUX,'FLUX') + CALL LCMLEL(JPFLUX,1,ILCMLN,ITYLCM) + ALLOCATE(WORKF(ILCMLN)) + DO 70 IGR=1,NGROUP + CALL LCMGDL(JPFLUX,IGR,WORKF) + DO 60 IREG=1,NREGIO + FLXINT(IREG,IGR,1)=WORKF(KEYFLX(IREG)+ILCMLN/2)*VOLUME(IREG) + 60 CONTINUE + 70 CONTINUE + IGRFIN=0 + DO 90 IGRC=1,NGCOND + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGRC) + DO 80 IGR=IGRDEB,IGRFIN +*---- +* COMPUTE MERGED INTEGRATED CURRENTS +*---- + CALL EDIRAT(0,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1), + > VOLUME(1),RATECM(1,IGRC,NW+5),SIGMA(0),IMERGE,NMERGE) + 80 CONTINUE + 90 CONTINUE + DEALLOCATE(WORKF) + ELSE IF(ILEAKS.EQ.3) THEN + IF(IADJ.EQ.1) CALL XABORT('EDIDTX: DIRECT-ADJOINT WEIGTING NOT' + > //' IMPLEMENTED.') + CALL LCMLEN(IPFLUX,'FLUX',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.0) CALL XABORT('EDIDTX: MISSING FLUX INFO.') + JPFLUX=LCMGID(IPFLUX,'FLUX') + CALL LCMLEL(JPFLUX,1,ILCMLN,ITYLCM) +*---- +* CALCULATIONS FOR TIBERE PIJ +*---- + IF(ILCMLN.EQ.12*NREGIO) THEN + IFSKP=3*NREGIO + ALLOCATE(WORKF(ILCMLN)) + DO 140 IDIR=1,3 + DO 110 IGR=1,NGROUP + CALL LCMGDL(JPFLUX,IGR,WORKF) + DO 100 IREG=1,NREGIO + FLXINT(IREG,IGR,1)=WORKF(KEYFLX(IREG)+IDIR*IFSKP) + > *VOLUME(IREG) + 100 CONTINUE + 110 CONTINUE + IGRFIN=0 + DO 130 IGRC=1,NGCOND + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGRC) + DO 120 IGR=IGRDEB,IGRFIN +*---- +* COMPUTE MERGED INTEGRATED CURRENTS FOR TIBERE PIJ +*---- + CALL EDIRAT(0,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1), + > VOLUME(1),RATECM(1,IGRC,NW+9+IDIR),SIGMA(0), + > IMERGE,NMERGE) + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + DEALLOCATE(WORKF) +*---- +* CALCULATIONS FOR TIBERE MoC +*---- + ELSE IF(ILCMLN.NE.0) THEN + ALLOCATE(WORKF(ILCMLN)) + DO 141 IDIR=1,3 + DO 111 IGR=1,NGROUP + CALL LCMGDL(JPFLUX,IGR,WORKF) + DO 101 IREG=1,NREGIO + ISKP(1)=ILCMLN/4+KEYFLX(IREG) + ISKP(2)=ILCMLN/2+KEYFLX(IREG) + ISKP(3)=3*ILCMLN/4+KEYFLX(IREG) + FLXINT(IREG,IGR,1)=WORKF(ISKP(IDIR))*VOLUME(IREG) + 101 CONTINUE + 111 CONTINUE + IGRFIN=0 + DO 131 IGRC=1,NGCOND + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGRC) + DO 121 IGR=IGRDEB,IGRFIN +*---- +* COMPUTE MERGED INTEGRATED CURRENTS FOR TIBERE MOC +*---- + CALL EDIRAT(0,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1), + > VOLUME(1),RATECM(1,IGRC,NW+9+IDIR),SIGMA(0), + > IMERGE,NMERGE) + 121 CONTINUE + 131 CONTINUE + 141 CONTINUE + DEALLOCATE(WORKF) + ENDIF + ENDIF +*---- +* COMPUTE INTEGRATED FLUX +*---- + DO 170 IW=1,NW+1 + DO 160 IGR=1,NGROUP + DO 150 IREGIO=1,NREGIO + FLXINT(IREGIO,IGR,IW)=FLUXES(IREGIO,IGR,IW)*VOLUME(IREGIO) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE +*---- +* COMPUTE INTEGRATED/CONDENSED FUNDAMENTAL CURRENTS (ILEAKS=1) +* (OBTAINED AS THE PRODUCT OF THE FUNDAMENTAL FLUX BY THE LEAKAGE +* COEFFICIENT) +*---- + JPMACR=LCMGID(IPMACR,'GROUP') + IF(ILEAKS.EQ.1) THEN + CALL LCMLEN(IPFLUX,'DIFFHET',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.0) THEN + CALL XABORT('EDIDTX: UNABLE TO RECOVER THE DIFFHET RECORD IN' + > //' THE FLUX OBJECT.') + ENDIF + ALLOCATE(DIFHET(NMLEAK,NGROUP),IMERGL(NBMIX)) + CALL LCMLEN(IPFLUX,'IMERGE-LEAK',ILCMLN,ITYLCM) + IF(ILCMLN.NE.NBMIX) THEN + CALL XABORT('EDIDTX: IMERGE-LEAK OVERFLOW.') + ENDIF + CALL LCMGET(IPFLUX,'IMERGE-LEAK',IMERGL) + CALL LCMGET(IPFLUX,'DIFFHET',DIFHET) + CALL LCMGTC(IPFLUX,'OPTION',4,OPTION) + IGRFIN=0 + DO 200 IGRC=1,NGCOND + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGRC) + DO 190 IGR=IGRDEB,IGRFIN + IF(OPTION.EQ.'LKRD') THEN + KPMACR=LCMGIL(JPMACR,IGR) + CALL LCMGET(KPMACR,'DIFF',SIGMA(1)) + ELSE + IF(NMLEAK.EQ.0) CALL XABORT('EDIDTX: NO LEAKAGE ZONE.') + SIGMA(0)=0.0 + DO 180 IMIX=1,NBMIX + IME=IMERGL(IMIX) + IF(IME.GT.0) SIGMA(IMIX)=DIFHET(IME,IGR) + 180 CONTINUE + ENDIF + CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1), + > AFLUXE(1,IGR,1),RATECM(1,IGRC,NW+5),SIGMA(0),IMERGE,NMERGE) + 190 CONTINUE + 200 CONTINUE + DEALLOCATE(IMERGL,DIFHET) + ENDIF +*---- +* READ FIXE SOURCES/COMPUTE FIXE PRODUCTION RATE AND TOTAL SOURCE +*---- + IGRFIN=0 + TOTFIS=0.0D0 + FXSOUR=0.0D0 + DO 250 IGRC=1,NGCOND + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGRC) + DO 240 IGR=IGRDEB,IGRFIN + KPMACR=LCMGIL(JPMACR,IGR) + CALL LCMLEN(KPMACR,'FIXE',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'FIXE',SIGMA(1)) + CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,VOLUME(1), + > AFLUXE(1,IGR,1),RATECM(1,IGRC,NW+4),SIGMA(0),IMERGE, + > NMERGE) + DO 210 IKK=1,NMERGE + FXSOUR=FXSOUR+DBLE(RATECM(IKK,IGRC,NW+4)) + 210 CONTINUE + ENDIF + DO 215 IW=1,NW+1 + CALL EDIRAT(0,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,IW), + > VOLUME(1),FLUXCM(1,IGRC,IW),SIGMA(0),IMERGE, + > NMERGE) + IF(IADJ.EQ.1) THEN + CALL EDIRAT(10,NREGIO,NBMIX,MATCOD,AFLUXE(1,IGR,IW), + > FLXINT(1,IGR,IW),FADJCM(1,IGRC,IW),SIGMA(0),IMERGE,NMERGE) + DO IKK=1,NMERGE + FADJCM(IKK,IGRC,IW)=FADJCM(IKK,IGRC,IW)/ + > FLUXCM(IKK,IGRC,IW) + ENDDO + ENDIF + 215 CONTINUE +*---- +* READ FISSION X-S/ COMPUTE FISSION RATES +*---- + CALL LCMLEN(KPMACR,'NUSIGF',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'NUSIGF',SIGMA(1)) + DO 230 IFIS=1,NIFISS + DO 220 IREGIO=1,NREGIO + IBM=MATCOD(IREGIO) + IF(IBM.GT.0) THEN + IF(SIGMA((IFIS-1)*NBMIX+IBM).GT.0.0) THEN + FLXFIS=FLXINT(IREGIO,IGR,1)*SIGMA((IFIS-1)*NBMIX+IBM) + FFUEL(IREGIO,IFIS)=FFUEL(IREGIO,IFIS)+FLXFIS + TOTFIS=TOTFIS+DBLE(FLXFIS) + IFUELR(IREGIO)=1 + ENDIF + ENDIF + 220 CONTINUE + 230 CONTINUE + ENDIF +*---- + 240 CONTINUE + 250 CONTINUE +*---- +* RECOVER THE PRECURSOR RADIOACTIVE DECAY CONSTANTS. USE THE VALUES +* OF THE FISSILE ISOTOPE WITH MAXIMUM FISSION RATE +*---- + IF(CURNAM.NE.' ') THEN + CALL LCMLEN(IPMACR,'LAMBDA-D',ILCMLN,ITYLCM) + IF((NDEL.GT.0).AND.(ILCMLN.GT.0)) THEN + ZMAX=0.0 + KFIS=0 + DO 340 IFIS=1,NIFISS + ZTOT=0.0 + DO 330 IREGIO=1,NREGIO + ZTOT=ZTOT+FFUEL(IREGIO,IFIS) + 330 CONTINUE + IF(ZTOT.GE.ZMAX) THEN + KFIS=IFIS + ZMAX=ZTOT + ENDIF + 340 CONTINUE + CALL LCMGET(IPMACR,'LAMBDA-D',DECAY) + CALL LCMSIX(IPEDIT,CURNAM,ILCMUP) + CALL LCMSIX(IPEDIT,'MACROLIB',ILCMUP) + CALL LCMPUT(IPEDIT,'LAMBDA-D',NDEL,2,DECAY(1,KFIS)) + CALL LCMSIX(IPEDIT,' ',ILCMDN) + CALL LCMSIX(IPEDIT,' ',ILCMDN) + ENDIF + ENDIF +*---- +* FIND FUEL VOLUME FOR DISADVANTAGE FACTOR +*---- + VFUEL=0.0 + VCELL=0.0 + DO 350 IREGIO=1,NREGIO + IF(IFUELR(IREGIO).EQ.1) THEN + VFUEL=VFUEL+VOLUME(IREGIO) + ENDIF + VCELL=VCELL+VOLUME(IREGIO) + 350 CONTINUE + LH=.FALSE. + LSPH=.FALSE. + IGRFIN=0 + DO 510 IGRC=1,NGCOND + FCELL=0.0D0 + FLFUEL=0.0D0 + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGRC) + DO 380 JGRC=1,NGCOND + DO 370 I=1,NMERGE + DO 360 IL=1,NL + SCATTD(I,IGRC,JGRC,IL)=0.0D0 + 360 CONTINUE + 370 CONTINUE + 380 CONTINUE + DO 500 IGR=IGRDEB,IGRFIN + KPMACR=LCMGIL(JPMACR,IGR) +*---- +* INTEGRATED 1/V +*---- + CALL LCMLEN(KPMACR,'OVERV',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'OVERV',SIGMA(1)) + CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1), + > AFLUXE(1,IGR,1),OVERV(1,IGRC),SIGMA(0), + > IMERGE,NMERGE) + ENDIF +*---- +* INTEGRATED H-FACTORS +*---- + CALL LCMLEN(KPMACR,'H-FACTOR',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + LH=.TRUE. + CALL LCMGET(KPMACR,'H-FACTOR',SIGMA(1)) + CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1), + > AFLUXE(1,IGR,1),HFACT(1,IGRC),SIGMA(0), + > IMERGE,NMERGE) + ENDIF +*---- +* SPH FACTORS +*---- + CALL LCMLEN(KPMACR,'NSPH',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + LSPH=.TRUE. + CALL LCMGET(KPMACR,'NSPH',SIGMA(1)) + CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1), + > AFLUXE(1,IGR,1),HSPH(1,IGRC),SIGMA(0), + > IMERGE,NMERGE) + ENDIF +*---- +* TOTAL, ABSROPTION, ETC. RATES +*---- + CALL LCMLEN(KPMACR,'NTOT0',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.0) CALL XABORT('EDIDTX: READ ERROR ON LCM REC'// + > 'ORD= TOTAL') + CALL LCMGET(KPMACR,'NTOT0',SIGMA(1)) + CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1), + > AFLUXE(1,IGR,1),RATECM(1,IGRC,NW+2),SIGMA(0),IMERGE,NMERGE) + DO 385 IW=1,NW+1 + WRITE(TEXT12,'(4HNTOT,I1)') IW-1 + CALL LCMLEN(KPMACR,TEXT12,ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) CALL LCMGET(KPMACR,TEXT12,SIGMA(1)) + CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,IW), + > AFLUXE(1,IGR,IW),RATECM(1,IGRC,IW),SIGMA(0),IMERGE, + > NMERGE) + 385 CONTINUE + CALL LCMLEN(KPMACR,'SIGS00',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'SIGS00',SIGMA(1)) + CALL EDIRAT(-IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1), + > AFLUXE(1,IGR,1),RATECM(1,IGRC,NW+2),SIGMA(0),IMERGE,NMERGE) + ENDIF + IF(ILEAKS.EQ.0) THEN + CALL LCMLEN(KPMACR,'DIFF',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'DIFF',SIGMA(1)) + CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1), + > AFLUXE(1,IGR,1),RATECM(1,IGRC,NW+5),SIGMA(0),IMERGE, + > NMERGE) + ILEAK2=10 + ENDIF + CALL LCMLEN(KPMACR,'DIFFX',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'DIFFX',SIGMA(1)) + CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1), + > AFLUXE(1,IGR,1),RATECM(1,IGRC,NW+10),SIGMA(0),IMERGE, + > NMERGE) + ILEAK2=11 + ENDIF + CALL LCMLEN(KPMACR,'DIFFY',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'DIFFY',SIGMA(1)) + CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1), + > AFLUXE(1,IGR,1),RATECM(1,IGRC,NW+11),SIGMA(0),IMERGE, + > NMERGE) + ILEAK2=11 + ENDIF + CALL LCMLEN(KPMACR,'DIFFZ',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'DIFFZ',SIGMA(1)) + CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1), + > AFLUXE(1,IGR,1),RATECM(1,IGRC,NW+12),SIGMA(0),IMERGE, + > NMERGE) + ILEAK2=11 + ENDIF + ENDIF +*---- +* READ ADDITIONAL X-SECTIONS +*---- + DO 390 IED=1,NEDMAC + IF(HVECT(IED)(:2).EQ.'NW') GO TO 390 + CALL LCMLEN(KPMACR,HVECT(IED),ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPMACR,HVECT(IED),SIGMA(1)) + CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1), + > AFLUXE(1,IGR,1),TAUXE(1,IGRC,IED),SIGMA(0), + > IMERGE,NMERGE) + ENDIF + 390 CONTINUE +*---- +* FISSION SPECTRUM AND NU*SIGF +*---- + CALL LCMLEN(KPMACR,'NUSIGF',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + ALLOCATE(SIGMAF(0:NBMIX)) + SIGMAF(0)=0.0 + CALL LCMGET(KPMACR,'NUSIGF',SIGMA(1)) + DO 400 IFIS=1,NIFISS + DO 395 IBM=1,NBMIX + SIGMAF(IBM)=SIGMA((IFIS-1)*NBMIX+IBM) + 395 CONTINUE + CALL EDIRAT(1,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1), + > AFLUXE(1,IGR,1),RATECM(1,IGRC,NW+3),SIGMAF(0),IMERGE, + > NMERGE) + 400 CONTINUE + DEALLOCATE(SIGMAF) + ENDIF + CALL LCMLEN(KPMACR,'CHI',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + ALLOCATE(SIGMAF(0:NBMIX)) + SIGMAF(0)=0.0 + CALL LCMGET(KPMACR,'CHI',SIGMA(1)) + DO 410 IFIS=1,NIFISS + DO 405 IBM=1,NBMIX + SIGMAF(IBM)=SIGMA((IFIS-1)*NBMIX+IBM) + 405 CONTINUE + CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FFUEL(1,IFIS), + > AFLUXE(1,IGR,1),RATECM(1,IGRC,NW+4),SIGMAF(0),IMERGE, + > NMERGE) + 410 CONTINUE + DEALLOCATE(SIGMAF) + ENDIF +*---- +* DELAYED FISSION SPECTRUM AND NU*SIGF +*---- + DO 440 IDEL=1,NDEL + WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL + CALL LCMLEN(KPMACR,TEXT12,ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + ALLOCATE(SIGMAF(0:NBMIX)) + SIGMAF(0)=0.0 + CALL LCMGET(KPMACR,TEXT12,SIGMA(1)) + DO 420 IFIS=1,NIFISS + DO 415 IBM=1,NBMIX + SIGMAF(IBM)=SIGMA((IFIS-1)*NBMIX+IBM) + 415 CONTINUE + CALL EDIRAT(1,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1), + > VOLUME(1),RATECM(1,IGRC,12+NW+IDEL),SIGMAF(0),IMERGE, + > NMERGE) + 420 CONTINUE + DEALLOCATE(SIGMAF) + ENDIF + WRITE(TEXT12,'(3HCHI,I2.2)') IDEL + CALL LCMLEN(KPMACR,TEXT12,ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + ALLOCATE(SIGMAF(0:NBMIX)) + SIGMAF(0)=0.0 + CALL LCMGET(KPMACR,TEXT12,SIGMA(1)) + DO 430 IFIS=1,NIFISS + DO 425 IBM=1,NBMIX + SIGMAF(IBM)=SIGMA((IFIS-1)*NBMIX+IBM) + 425 CONTINUE + CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FFUEL(1,IFIS), + > AFLUXE(1,IGR,1),RATECM(1,IGRC,12+NW+NDEL+IDEL), + > SIGMAF(0),IMERGE,NMERGE) + 430 CONTINUE + DEALLOCATE(SIGMAF) + ENDIF + 440 CONTINUE +*---- +* INTEGRATED FLUX AND FORM FACTOR +*---- + DO 450 IREGIO=1,NREGIO + IF(IFUELR(IREGIO).EQ.1) THEN + FLFUEL=FLFUEL+DBLE(FLXINT(IREGIO,IGR,1)) + ENDIF + FCELL=FCELL+DBLE(FLXINT(IREGIO,IGR,1)) + 450 CONTINUE +*---- +* TRANSPORT CORRECTION +*---- + IF(ITRANC.NE.0) THEN + CALL LCMLEN(KPMACR,'TRANC',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'TRANC',SIGMA(1)) + CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1), + > AFLUXE(1,IGR,1),RATECM(1,IGRC,NW+9),SIGMA(0),IMERGE, + > NMERGE) + ENDIF + ENDIF +*---- +* SCATTERING NEUTRONS +*---- + DO 490 IL=1,NL + IW=MIN(IL,NW+1) + WRITE (CM,'(I2.2)') IL-1 + CALL LCMLEN(KPMACR,'SIGS'//CM,ILCSCA,ITYLCM) + IF(ILCSCA.GT.0) THEN + CALL LCMGET(KPMACR,'SIGS'//CM,SIGMA(1)) + CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,IW), + > AFLUXE(1,IGR,IW),SIGS(1,IGRC,IL),SIGMA(0),IMERGE,NMERGE) + ENDIF + CALL LCMLEN(KPMACR,'NJJS'//CM,ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'SIGW'//CM,SIGMA(1)) + CALL LCMGET(KPMACR,'NJJS'//CM,INGSCT) + CALL LCMGET(KPMACR,'IJJS'//CM,IFGSCT) + CALL LCMGET(KPMACR,'IPOS'//CM,IPOSCT) + CALL LCMGET(KPMACR,'SCAT'//CM,XSCAT) + DO 480 IREGIO=1,NREGIO + MATNUM=MATCOD(IREGIO) + IKK=IMERGE(IREGIO) + IF((IKK.GT.0).AND.(MATNUM.GT.0)) THEN + NGSCAT=INGSCT(MATNUM) + IGSCAT=IFGSCT(MATNUM) + IPOSIT=IPOSCT(MATNUM) + JGRFIN=0 + FAD=1.0 + IF(IADJ.EQ.1) FAD=AFLUXE(IREGIO,IGR,IW) + DO 470 JGRC=1,NGCOND + JGRDEB=JGRFIN+1 + JGRFIN=IGCOND(JGRC) + J2=MIN(JGRFIN,IGSCAT) + J1=MAX(JGRDEB,IGSCAT-NGSCAT+1) + IPO=IPOSIT+IGSCAT-J2 + DO 460 JGR=J2,J1,-1 + IF(IGR.EQ.JGR) THEN + SCATTD(IKK,IGRC,JGRC,IL)=SCATTD(IKK,IGRC,JGRC,IL) + > +SIGMA(MATNUM)*FLXINT(IREGIO,JGR,IW)*FAD + ELSE + SCATTD(IKK,IGRC,JGRC,IL)=SCATTD(IKK,IGRC,JGRC,IL) + > +XSCAT(IPO)*FLXINT(IREGIO,JGR,IW)*FAD + ENDIF + IPO=IPO+1 + 460 CONTINUE + 470 CONTINUE + ENDIF + 480 CONTINUE + ENDIF + 490 CONTINUE + 500 CONTINUE + IF(VFUEL*FCELL.GT.0.0) THEN + DISFCT(IGRC)=REAL(FLFUEL*VCELL/(VFUEL*FCELL)) + ELSE + DISFCT(IGRC)=0.0 + ENDIF + 510 CONTINUE +*---- +* UP-SCATTERING CORRECTIONS +*---- + IF(ILUPS.EQ.1) THEN + DO 523 IKK=1,NMERGE + DO 522 IGRC=2,NGCOND + DO 521 JGRC=1,IGRC-1 + CSCAT=SCATTD(IKK,JGRC,IGRC,1) ! JGRC < IGRC + RATECM(IKK,IGRC,1)=RATECM(IKK,IGRC,1)-REAL(CSCAT) + RATECM(IKK,JGRC,1)=RATECM(IKK,JGRC,1)-REAL(CSCAT) + IF((NW.GE.1).AND.(NL.GE.1)) THEN + CSCAT=SCATTD(IKK,JGRC,IGRC,2) + RATECM(IKK,IGRC,2)=RATECM(IKK,IGRC,2)-REAL(CSCAT) + RATECM(IKK,JGRC,2)=RATECM(IKK,JGRC,2)-REAL(CSCAT) + ENDIF + DO 520 IL=1,NL + CSCAT=SCATTD(IKK,JGRC,IGRC,IL) + SIGS(IKK,IGRC,IL)=SIGS(IKK,IGRC,IL)-REAL(CSCAT) + SIGS(IKK,JGRC,IL)=SIGS(IKK,JGRC,IL)-REAL(CSCAT) + SCATTD(IKK,IGRC,JGRC,IL)=SCATTD(IKK,IGRC,JGRC,IL)-CSCAT + SCATTD(IKK,JGRC,IGRC,IL)=0.0D0 + 520 CONTINUE + 521 CONTINUE + 522 CONTINUE + 523 CONTINUE + ENDIF +*---- +* SCATTERING NORMALIZATION +*---- + IF(IADJ.EQ.0) THEN + DO 560 IGRC=1,NGCOND + DO 550 IKK=1,NMERGE + DO 540 IL=1,NL + IF(ILCSCA.GT.0) THEN + SCATW=SIGS(IKK,IGRC,IL) + DO 530 JGRC=1,NGCOND + IF(JGRC.NE.IGRC) SCATW=SCATW-SCATTD(IKK,JGRC,IGRC,IL) + 530 CONTINUE + DEN=REAL(MAX(ABS(SCATW),ABS(SCATTD(IKK,IGRC,IGRC,IL)))) + IF(DEN.GT.0.0) THEN + ERR=ABS(REAL(SCATW-SCATTD(IKK,IGRC,IGRC,IL)))/DEN + IF(ERR.GT.1.0E-3) THEN + WRITE(IUNOUT,6000) IL,IGRC,IKK,100.0*ERR + ENDIF + SCATTD(IKK,IGRC,IGRC,IL)=SCATW + ENDIF + ELSE + SCATW=0.0D0 + DO 535 JGRC=1,NGCOND + SCATW=SCATW+SCATTD(IKK,JGRC,IGRC,IL) + 535 CONTINUE + SIGS(IKK,IGRC,IL)=REAL(SCATW) + ENDIF + 540 CONTINUE + 550 CONTINUE + 560 CONTINUE + ENDIF +*---- +* FISSION SPECTRUM NORMALIZATION +*---- + IF((FXSOUR.EQ.0.0D0).AND.(TOTFIS.GT.0.0D0)) THEN + FLDMC(:NMERGE,:NGCOND)=0.0 + DO 580 IGRC=1,NGCOND + DO 570 IFIS=1,NIFISS + CALL EDIRAT(0,NREGIO,NBMIX,MATCOD,FFUEL(1,IFIS),VOLUME(1), + > FLDMC(1,IGRC),SIGMA(0),IMERGE,NMERGE) + 570 CONTINUE + 580 CONTINUE + DO 640 IKK=1,NMERGE + TOTAL1=0.0 + DO 590 IGRC=1,NGCOND + IF(RATECM(IKK,IGRC,NW+4).NE.0.0) THEN + RATECM(IKK,IGRC,NW+8)=RATECM(IKK,IGRC,NW+4)/FLDMC(IKK,IGRC) + TOTAL1=TOTAL1+RATECM(IKK,IGRC,NW+8) + ELSE + RATECM(IKK,IGRC,NW+8)=0.0 + ENDIF + 590 CONTINUE + IF((IADJ.EQ.0).AND.(TOTAL1.NE.0.0)) THEN + DO 600 IGRC=1,NGCOND + RATECM(IKK,IGRC,NW+8)=RATECM(IKK,IGRC,NW+8)/TOTAL1 + 600 CONTINUE + ELSE IF(IADJ.EQ.1) THEN + DO 601 IGRC=1,NGCOND + RATECM(IKK,IGRC,NW+8)=RATECM(IKK,IGRC,NW+8)/ + > FADJCM(IKK,IGRC,1) + 601 CONTINUE + ENDIF + DO 630 IDEL=1,NDEL + K=12+NW+NDEL+IDEL + TOTAL1=0.0 + DO 610 IGRC=1,NGCOND + IF(RATECM(IKK,IGRC,K).NE.0.0) THEN + RATECM(IKK,IGRC,K)=RATECM(IKK,IGRC,K)/FLDMC(IKK,IGRC) + TOTAL1=TOTAL1+RATECM(IKK,IGRC,K) + ELSE + RATECM(IKK,IGRC,K)=0.0 + ENDIF + 610 CONTINUE + IF((IADJ.EQ.0).AND.(TOTAL1.NE.0.0)) THEN + DO 620 IGRC=1,NGCOND + RATECM(IKK,IGRC,K)=RATECM(IKK,IGRC,K)/TOTAL1 + 620 CONTINUE + ELSE IF(IADJ.EQ.1) THEN + DO 621 IGRC=1,NGCOND + RATECM(IKK,IGRC,K)=RATECM(IKK,IGRC,K)/FADJCM(IKK,IGRC,1) + 621 CONTINUE + ENDIF + 630 CONTINUE + 640 CONTINUE + ENDIF + DEALLOCATE(XSCAT,SIGMA) + DEALLOCATE(IPOSCT,IFGSCT,INGSCT) +*---- +* CONDENSATION OF PHYSICAL ALBEDOS +*---- + IF(NALBP.GT.0) THEN + ALBP(:NALBP,:NGCOND,:NGCOND)=0.0 + CALL LCMLEN(IPMACR,'ALBEDO',ILONG,ITYLCM) + IF(ILONG.EQ.NALBP*NGROUP) THEN +* diagonal physical albedos + ALLOCATE(ALBPGR(NALBP,NGROUP)) + CALL LCMGET(IPMACR,'ALBEDO',ALBPGR) + IGRFIN=0 + DO 663 IGRC=1,NGCOND + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGRC) + DENOM=0.0 + DO 655 IGR=IGRDEB,IGRFIN + DO 650 IREGIO=1,NREGIO + DENOM=DENOM+FLXINT(IREGIO,IGR,1) + 650 CONTINUE + 655 CONTINUE + DO 662 IAL=1,NALBP + DO 661 IGR=IGRDEB,IGRFIN + DO 660 IREGIO=1,NREGIO + ALBP(IAL,IGRC,IGRC)=ALBP(IAL,IGRC,IGRC)+ALBPGR(IAL,IGR)* + 1 FLXINT(IREGIO,IGR,1)/DENOM + 660 CONTINUE + 661 CONTINUE + 662 CONTINUE + 663 CONTINUE + DEALLOCATE(ALBPGR) + ELSE IF(ILONG.EQ.NALBP*NGROUP*NGROUP) THEN +* matrix physical albedos + ALLOCATE(ALBPGR2(NALBP,NGROUP,NGROUP)) + CALL LCMGET(IPMACR,'ALBEDO',ALBPGR2) + IGRFIN=0 + DO 765 IGRC=1,NGCOND + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGRC) + DENOM=0.0 + DO 755 IGR=IGRDEB,IGRFIN + DO 750 IREGIO=1,NREGIO + DENOM=DENOM+FLXINT(IREGIO,IGR,1) + 750 CONTINUE + 755 CONTINUE + DO 764 IAL=1,NALBP + DO 763 IGR=IGRDEB,IGRFIN + JGRFIN=0 + DO 762 JGRC=1,NGCOND + JGRDEB=JGRFIN+1 + JGRFIN=IGCOND(JGRC) + DO 761 JGR=JGRDEB,JGRFIN + DO 760 IREGIO=1,NREGIO + ALBP(IAL,JGRC,IGRC)=ALBP(IAL,JGRC,IGRC)+ALBPGR2(IAL,JGR,IGR)* + 1 FLXINT(IREGIO,IGR,1)/DENOM + 760 CONTINUE + 761 CONTINUE + 762 CONTINUE + 763 CONTINUE + 764 CONTINUE + 765 CONTINUE + DEALLOCATE(ALBPGR2) + ELSE + CALL XABORT('EDIDTX: INCONSISTENT ALBEDO INFORMATION.') + ENDIF + ENDIF +*---- +* PRINT REACTION RATES +*---- + ILEAKS=ILEAK2 + IF(IPRINT.GE.1) THEN + CALL EDIPRR(IPRINT,NL,ITRANC,NGCOND,NMERGE,ILEAKS,NW,NTAUXT, + > B2,VOLMER,NENER,WENERG,RATECM,FLUXCM,SCATTD) + ENDIF +*---- +* COMPUTE MERGED/CONDENSED X-S +*---- + CALL EDIPXS(IPEDIT,IADJ,IPRINT,NL,NDEL,NALBP,ITRANC,NSAVES,NGCOND, + > NMERGE,ILEAKS,NW,NTAUXT,EIGENK,B2,IGOVE,CUREIN,NIFISS, + > CURNAM,NEDMAC,VOLMER,WLETYC,WENERG,SCATTD,RATECM, + > FLUXCM,FADJCM,SIGS,SCATTS,DISFCT,ALBP,TAUXE,HVECT, + > OVERV,HFACT,HSPH,NENER,TIMEF,LH,LSPH) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(ALBP,DECAY,HSPH,HFACT,OVERV,FLDMC,FFUEL,TAUXE,DISFCT) + DEALLOCATE(IFUELR,HVECT) + RETURN +*---- +* FORMAT +*---- + 6000 FORMAT(/53H EDIDTX: *** WARNING *** NORMALIZATION OF THE WITHIN-, + > 34HGROUP SCATTERING TRANSFER OF ORDER,I3,9H IN GROUP,I4,5H AND , + > 6HREGION,I5,3H BY,F6.2,3H %.) + END diff --git a/Dragon/src/EDIENE.f b/Dragon/src/EDIENE.f new file mode 100644 index 0000000..b0bf359 --- /dev/null +++ b/Dragon/src/EDIENE.f @@ -0,0 +1,105 @@ +*DECK EDIENE + SUBROUTINE EDIENE(NGROUP,NGCR ,NGCOND,NTENER, + > IGCR ,EGCR ,IGCOND,ENERGY,ENERV ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Evaluate energy limits for condensation. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input/output +* NGROUP number of energy groups. +* NGCR number of condensed groups read on input. +* NGCOND number of condensed groups read on EDI. +* NTENER number of energy found on library. +* IGCR new group limits. +* EGCR new energy limits. +* IGCOND old group limits. +* ENERGY energy/lethargy/average energy. +* ENERV average group energy. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NGROUP,NGCR,NGCOND,NTENER + INTEGER IGCR(NGROUP+1),IGCOND(NGROUP+1) + REAL EGCR(NGROUP+1),ENERGY(2*NGROUP+1),ENERV(NGROUP) +*---- +* LOCAL VARIABLES +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='EDIENE') + INTEGER IGC,KDGRP,IGRP,JGRP,IGLIM +*---- +* FIND IF NEW ENERGY OR GROUP SPECIFICATIONS FROM INPUT +*---- + IF(NGCR .GT. 0) THEN + IGC=0 + IF(EGCR(1) .NE. 0.0) THEN + IF(NTENER .EQ. 0) CALL XABORT(NAMSBR// + > ': CONDENSATION NOT PERMITTED - NO GROUP STRUCTURE') + KDGRP=1 + DO 100 IGRP=1,NGROUP+1 + IF(EGCR(IGRP) .LT. ENERGY(NGROUP+1)) THEN + KDGRP=NGROUP + IGC=IGC+1 + IGCOND(IGC)=KDGRP + ELSE IF(EGCR(IGRP) .LT. ENERGY(KDGRP)) THEN + DO 110 JGRP=KDGRP,NGROUP + IF(EGCR(IGRP) .GE. ENERGY(JGRP+1)) THEN + KDGRP=JGRP + IGC=IGC+1 + IGCOND(IGC)=KDGRP + GO TO 115 + ENDIF + 110 CONTINUE + 115 CONTINUE + ENDIF + IF(KDGRP .EQ. NGROUP) GO TO 105 + 100 CONTINUE + 105 CONTINUE + ELSE + DO 120 IGRP=1,NGROUP+1 + IGCOND(IGRP)=IGCR(IGRP) + IF(IGCR(IGRP) .EQ. NGROUP) THEN + IGC=IGRP + GO TO 125 + ENDIF + 120 CONTINUE + 125 CONTINUE + ENDIF + NGCOND=IGC + ENDIF + IF(NTENER .GT. 0) THEN +*---- +* FIND ENERGY LIMITS, LETHARGY AND AVERAGE ENERGY +*---- + DO 130 IGRP=1,NGROUP + ENERV(IGRP)=SQRT(ENERGY(IGRP)*ENERGY(IGRP+1)) + 130 CONTINUE + DO 140 IGC=1,NGCOND + IGLIM=IGCOND(IGC)+1 + ENERGY(IGC+1)=ENERGY(IGLIM) + 140 CONTINUE + IGLIM=NGCOND+1 + IF(ENERGY(IGLIM) .EQ. 0.0) ENERGY(IGLIM)=1.0E-5 + DO 150 IGC=1,NGCOND + IGLIM=IGLIM+1 + ENERGY(IGLIM)=LOG(ENERGY(IGC)/ENERGY(IGC+1)) + 150 CONTINUE + ENDIF + RETURN + END diff --git a/Dragon/src/EDIG2S.f90 b/Dragon/src/EDIG2S.f90 new file mode 100644 index 0000000..24ef2e7 --- /dev/null +++ b/Dragon/src/EDIG2S.f90 @@ -0,0 +1,251 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Perform an homogenization based on a surfacic file. +! +!Copyright: +! Copyright (C) 2017 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version +! +!Author(s): A. Hebert +! +!----------------------------------------------------------------------- +! +MODULE EDIG2S_MOD + + USE PRECISION_AND_KINDS, ONLY : PDB + +CONTAINS + ! + FUNCTION EDIBAR(NODE,CX,CY) RESULT(TLAMB) + !---- + ! Compute the barycentric coordinates of point (CX,CY) in a triangle + !---- + REAL(PDB) :: NODE(6),CX,CY,TLAMB(3) + ! + TLAMB(1) = ((NODE(4) - NODE(6))*(CX - NODE(5)) + (NODE(5) - NODE(3))*(CY - NODE(6))) / & + ((NODE(4) - NODE(6))*(NODE(1) - NODE(5)) + (NODE(5) - NODE(3))*(NODE(2) - NODE(6))) + TLAMB(2) = ((NODE(6) - NODE(2))*(CX - NODE(5)) + (NODE(1) - NODE(5))*(CY - NODE(6))) / & + ((NODE(4) - NODE(6))*(NODE(1) - NODE(5)) + (NODE(5) - NODE(3))*(NODE(2) - NODE(6))) + TLAMB(3) = 1.0D0 - TLAMB(1) - TLAMB(2) + END FUNCTION EDIBAR + ! + SUBROUTINE EDIG2S(IPRINT,IFGEO,NREG,NMERGE,IMERGE) + !---- + ! Process RECT and TRIA data options + ! + !Parameters: input + ! IPRINT print flag. + ! IFGEO unit file number of the surfacic file. + ! NREG number of regions. + ! + !Parameters: input + ! NMERGE number of merged indices in array IMERGE. + ! IMERGE merged regions position. + ! + !---- + USE SALGET_FUNS_MOD + !---- + ! Subroutine arguments + !---- + INTEGER IPRINT,IFGEO,NREG,NMERGE,IMERGE(NREG) + !---- + ! Local variables + !---- + INTEGER PREC,DATAIN(25),IPAR(5) + REAL DATARE(25) + REAL(PDB) CX,CY,DX,DY,SAA,SAB,ANGL,RPAR(5),TLAMB1(3),TLAMB2(3) + REAL(PDB) NODX1,NODX2,NODY1,NODY2 + REAL(PDB), PARAMETER :: CONV=3.141592654_PDB/180.0_PDB + PARAMETER(IFOUT0=0) + CHARACTER NAME_GEOM*12,CARLIR*8,HSMG*131 + DOUBLE PRECISION DBLLIR + !---- + ! Allocatable arrays + !---- + INTEGER, DIMENSION(:), ALLOCATABLE :: NUM_MERGE,IFLUX,ITNODE + INTEGER, DIMENSION(:,:), ALLOCATABLE :: ICOUNT + REAL(PDB), DIMENSION(:,:), ALLOCATABLE :: NODE + !---- + ! Read homogeneous node definitions + !---- + CALL REDGET(ITYPLU,NMERGE,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('EDIG2S: INTEGER VARIABLE EXPECTED.') + IF(NMERGE.LE.0) CALL XABORT('EDIG2S: INVALID VALUE OF NMERGE.') + ALLOCATE(NODE(6,NMERGE),ITNODE(NMERGE)) + DO IM=1,NMERGE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('EDIG2S: CHARACTER VARIABLE EXPECTED.') + IF(CARLIR.EQ.'RECT') THEN + ITNODE(IM)=1 + DO I=1,4 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.2) CALL XABORT('EDIG2S: REAL VARIABLE EXPECTED(1).') + NODE(I,IM)=REALIR + ENDDO + NODE(5:6,IM)=0.0D0 + ELSE IF(CARLIR.EQ.'TRIA') THEN + ITNODE(IM)=2 + DO I=1,6 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.2) CALL XABORT('EDIG2S: REAL VARIABLE EXPECTED(2).') + NODE(I,IM)=REALIR + ENDDO + ELSE + CALL XABORT('EDIG2S: *RECT* OR *TRIA* KEYWORD EXPECTED.') + ENDIF + ENDDO + !---- + ! Determine homogenization indices + !---- + IF(IFGEO.EQ.0) CALL XABORT('EDIG2S: surfacic file not defined.') + CALL SALGET(DATAIN,6,IFGEO,IFOUT0,'dimensions for geometry') + NBNODE=DATAIN(3) + NBELEM=DATAIN(4) + NBFLUX=DATAIN(6) + CALL SALGET(DATAIN,3,IFGEO,IFOUT0,'index kndex prec') + INDEX=DATAIN(1) + KNDEX=DATAIN(2) + PREC=DATAIN(3) + CALL SALGET(DATARE,1,IFGEO,IFOUT0,'eps') + EPS=DATARE(1) + ALLOCATE(NUM_MERGE(NBNODE)) + CALL SALGET(NUM_MERGE,NBNODE,IFGEO,IFOUT0,'FLUX INDEX PER NODE') + IF(MAXVAL(NUM_MERGE).NE.NBFLUX) CALL XABORT('EDIG2S: inconsistent NBFLUX.') + CALL SALGET(NAME_GEOM,IFGEO,IFOUT0,'NAMES OF MACROS') + ALLOCATE(IFLUX(NBFLUX)) + CALL SALGET(IFLUX,NBFLUX,IFGEO,IFOUT0,'macro order number per flux region.') + DEALLOCATE(IFLUX) + ALLOCATE(ICOUNT(NBNODE,NMERGE)) + ICOUNT(:NBNODE,:NMERGE)=0 + DO IELEM=1,NBELEM + IPAR(:)=0 + RPAR(:)=0.0 + CALL SALGET(IPAR,3,IFGEO,IFOUT0,'integer descriptors') + ITYPE=IPAR(1) + SELECT CASE (ITYPE) + CASE (1) + NBER=4 + CASE (2) + NBER=3 + CASE (3) + NBER=5 + CASE DEFAULT + WRITE(6,'(1X,''==> SAL126: unknown type '',I3)') ITYPE + CALL XABORT('EDIG2S: unknown element type.') + END SELECT + CALL SALGET(RPAR,NBER,IFGEO,IFOUT0,PREC,'real descriptors') + IF(ITYPE.EQ.1) THEN + CX=RPAR(1) ; CY=RPAR(2) + DX=CX+RPAR(3) ; DY=CY+RPAR(4) + DO IM=1,NMERGE + IF(ITNODE(IM).EQ.1) THEN + NODX1=NODE(1,IM) ; NODX2=NODE(2,IM) + NODY1=NODE(3,IM) ; NODY2=NODE(4,IM) + IF((CX.GE.NODX1-EPS).AND.(DX.LE.NODX2+EPS).AND. & + (CY.GE.NODY1-EPS).AND.(DY.LE.NODY2+EPS)) THEN + IF((ABS(CX-DX).LE.EPS).AND.(ABS(CX-NODX1).LE.EPS)) THEN ! left vertical side + IF(IPAR(2).GT.0) ICOUNT(IPAR(2),IM)=ICOUNT(IPAR(2),IM)+1 + ELSE IF((ABS(CX-DX).LE.EPS).AND.(ABS(CX-NODX2).LE.EPS)) THEN ! right vertical side + IF(IPAR(3).GT.0) ICOUNT(IPAR(3),IM)=ICOUNT(IPAR(3),IM)+1 + ELSE IF((ABS(CY-DY).LE.EPS).AND.(ABS(CY-NODY1).LE.EPS)) THEN ! lower horizontal side + IF(IPAR(3).GT.0) ICOUNT(IPAR(3),IM)=ICOUNT(IPAR(3),IM)+1 + ELSE IF((ABS(CY-DY).LE.EPS).AND.(ABS(CY-NODY2).LE.EPS)) THEN ! upper horizontal side + IF(IPAR(2).GT.0) ICOUNT(IPAR(2),IM)=ICOUNT(IPAR(2),IM)+1 + ELSE IF((ABS(CX-DX).LE.EPS).OR.(ABS(CY-DY).LE.EPS)) THEN + IF(IPAR(2).GT.0) ICOUNT(IPAR(2),IM)=ICOUNT(IPAR(2),IM)+1 + IF(IPAR(3).GT.0) ICOUNT(IPAR(3),IM)=ICOUNT(IPAR(3),IM)+1 + ENDIF + ENDIF + ELSE IF(ITNODE(IM).EQ.2) THEN + TLAMB1=EDIBAR(NODE(1,IM),CX,CY) + TLAMB2=EDIBAR(NODE(1,IM),DX,DY) + IF((TLAMB1(1).GE.-EPS).AND.(TLAMB1(2).GE.-EPS).AND.(TLAMB1(3).GE.-EPS).AND. & + (TLAMB2(1).GE.-EPS).AND.(TLAMB2(2).GE.-EPS).AND.(TLAMB2(3).GE.-EPS)) THEN + IF((ABS(TLAMB1(1)).LE.EPS).AND.(ABS(TLAMB2(1)).LE.EPS)) THEN + IF(IPAR(3).GT.0) ICOUNT(IPAR(3),IM)=ICOUNT(IPAR(3),IM)+1 + ELSE IF((ABS(TLAMB1(2)).LE.EPS).AND.(ABS(TLAMB2(2)).LE.EPS)) THEN + IF(IPAR(3).GT.0) ICOUNT(IPAR(3),IM)=ICOUNT(IPAR(3),IM)+1 + ELSE IF((ABS(TLAMB1(3)).LE.EPS).AND.(ABS(TLAMB2(3)).LE.EPS)) THEN + IF(IPAR(3).GT.0) ICOUNT(IPAR(3),IM)=ICOUNT(IPAR(3),IM)+1 + ELSE + IF(IPAR(2).GT.0) ICOUNT(IPAR(2),IM)=ICOUNT(IPAR(2),IM)+1 + IF(IPAR(3).GT.0) ICOUNT(IPAR(3),IM)=ICOUNT(IPAR(3),IM)+1 + ENDIF + ENDIF + ENDIF + ENDDO + ELSE IF(ITYPE.EQ.2) THEN + CX=RPAR(1) ; CY=RPAR(2) + DO IM=1,NMERGE + IF(ITNODE(IM).EQ.1) THEN + NODX1=NODE(1,IM) ; NODX2=NODE(2,IM) + NODY1=NODE(3,IM) ; NODY2=NODE(4,IM) + IF((CX.GE.NODX1-EPS).AND.(CX.LE.NODX2+EPS).AND. & + (CY.GE.NODY1-EPS).AND.(CY.LE.NODY2+EPS)) THEN + IF(IPAR(2).GT.0) ICOUNT(IPAR(2),IM)=ICOUNT(IPAR(2),IM)+1 + IF(IPAR(3).GT.0) ICOUNT(IPAR(3),IM)=ICOUNT(IPAR(3),IM)+1 + ENDIF + ELSE IF(ITNODE(IM).EQ.2) THEN + TLAMB1=EDIBAR(NODE(1,IM),CX,CY) + IF((TLAMB1(1).GE.-EPS).AND.(TLAMB1(2).GE.-EPS).AND.(TLAMB1(3).GE.-EPS)) THEN + IF(IPAR(2).GT.0) ICOUNT(IPAR(2),IM)=ICOUNT(IPAR(2),IM)+1 + IF(IPAR(3).GT.0) ICOUNT(IPAR(3),IM)=ICOUNT(IPAR(3),IM)+1 + ENDIF + ENDIF + ENDDO + ELSE IF(ITYPE.EQ.3) THEN + SAA=RPAR(4) ; SAB=SAA+RPAR(5) + IF(SAB>SAA) THEN + ANGL=(SAB+SAA)*0.5 + ELSE + ANGL=(SAB+SAA)*0.5+180.0 + ENDIF + CX=RPAR(1)+COS(ANGL*CONV)*RPAR(3) ; CY=RPAR(2)+SIN(ANGL*CONV)*RPAR(3) + DO IM=1,NMERGE + IF(ITNODE(IM).EQ.1) THEN + NODX1=NODE(1,IM) ; NODX2=NODE(2,IM) + NODY1=NODE(3,IM) ; NODY2=NODE(4,IM) + IF((CX.GE.NODX1-EPS).AND.(CX.LE.NODX2+EPS).AND. & + (CY.GE.NODY1-EPS).AND.(CY.LE.NODY2+EPS)) THEN + IF(IPAR(2).GT.0) ICOUNT(IPAR(2),IM)=ICOUNT(IPAR(2),IM)+1 + IF(IPAR(3).GT.0) ICOUNT(IPAR(3),IM)=ICOUNT(IPAR(3),IM)+1 + ENDIF + ELSE IF(ITNODE(IM).EQ.2) THEN + TLAMB1=EDIBAR(NODE(1,IM),CX,CY) + IF((TLAMB1(1).GE.-EPS).AND.(TLAMB1(2).GE.-EPS).AND.(TLAMB1(3).GE.-EPS)) THEN + IF(IPAR(2).GT.0) ICOUNT(IPAR(2),IM)=ICOUNT(IPAR(2),IM)+1 + IF(IPAR(3).GT.0) ICOUNT(IPAR(3),IM)=ICOUNT(IPAR(3),IM)+1 + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + IMERGE(:NREG)=0 + ITEST=0 + DO IM=1,NMERGE + DO INODE=1,NBNODE + IF(ICOUNT(INODE,IM).GT.0) THEN + IF(IMERGE(NUM_MERGE(INODE)).NE.0) THEN + WRITE(HSMG,'(46HEDIG2S: inconsistent homogenization in mixture,I8, & + & 11h, g2s node=,I8,1h.)') IM,INODE + CALL XABORT(HSMG) + ENDIF + IMERGE(NUM_MERGE(INODE))=IM + ITEST=ITEST+1 + ENDIF + ENDDO + ENDDO + DEALLOCATE(NUM_MERGE,ICOUNT,ITNODE,NODE) + IF(IPRINT.GT.0) THEN + WRITE(6,'(53H EDIG2S: NUMBER OF NODES PROCESSED BY HOMOGENIZATION=,I8/ & + & 9X,32HNUMBER OF NODES IN THE GEOMETRY=,12X,I8/ & + & 9X,31HNUMBER OF HOMOGENEOUS MIXTURES=,13X,I8)') ITEST,NBNODE,NMERGE + ENDIF + RETURN + END SUBROUTINE EDIG2S +END MODULE EDIG2S_MOD diff --git a/Dragon/src/EDIGAP.f b/Dragon/src/EDIGAP.f new file mode 100644 index 0000000..487478c --- /dev/null +++ b/Dragon/src/EDIGAP.f @@ -0,0 +1,79 @@ +*DECK EDIGAP + SUBROUTINE EDIGAP(IPADF,TEXT8,NGROUP,NGCOND,NREGIO,VOLUME,IGCOND, + 1 FLUXES,FLUHOM,IPRINT,COURIN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the averaged boundary fluxes. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPADF pointer to the LCM directory containing ADF-related options. +* TEXT8 name of the boundary fluxes used to compute ADF ('FD_B', +* 'FD_C' or 'FD_H'). +* NGROUP number of energy groups in the reference calculation. +* NGCOND number of condensed groups. +* NREGIO number of regions in the reference calculation. +* VOLUME volume of regions. +* IGCOND limit of condensed groups. +* FLUXES heterogeneous gap fluxes. +* FLUHOM homogeneous fluxes. +* IPRINT print flag. +* +*Parameters: output +* COURIN averaged boundary fluxes. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPADF + INTEGER NGROUP,NGCOND,NREGIO,IGCOND(NGCOND),IPRINT + CHARACTER TEXT8*(*) + REAL VOLUME(NREGIO),FLUXES(NREGIO,NGROUP),FLUHOM(NGROUP), + 1 COURIN(NGCOND) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION SUM,SUD + INTEGER, ALLOCATABLE, DIMENSION(:) :: IFGAP +* + CALL LCMLEN(IPADF,TEXT8,NGAP,ITYLCM) + ALLOCATE(IFGAP(NGAP)) + CALL LCMGET(IPADF,TEXT8,IFGAP) + IGRFIN=0 + DO 25 IGRCD=1,NGCOND + COURIN(IGRCD)=0.0 + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGRCD) + DO 20 IGR=IGRDEB,IGRFIN + SUM=0.0D0 + SUD=0.0D0 + DO 10 IGAP=1,NGAP + IREG=IFGAP(IGAP) + SUM=SUM+FLUXES(IREG,IGR)*VOLUME(IREG) + SUD=SUD+VOLUME(IREG) + 10 CONTINUE + COURIN(IGRCD)=COURIN(IGRCD)+REAL(SUM/SUD) + 20 CONTINUE + COURIN(IGRCD)=COURIN(IGRCD)/FLUHOM(IGRCD) + 25 CONTINUE + DEALLOCATE(IFGAP) + IF(IPRINT.GT.3) THEN + WRITE(6,'(/19H EDIGAP: VALUES OF ,A,22H FLUXES OR ADF PER MAC, + 1 13HRO-GROUPS ARE)') TEXT8 + WRITE(6,'(1X,1P,10E13.5)') (COURIN(IGRCD),IGRCD=1,NGCOND) + ENDIF + RETURN + END diff --git a/Dragon/src/EDIGEO.f b/Dragon/src/EDIGEO.f new file mode 100644 index 0000000..a91923e --- /dev/null +++ b/Dragon/src/EDIGEO.f @@ -0,0 +1,478 @@ +*DECK EDIGEO + SUBROUTINE EDIGEO(MAXPTS,MAXMER,IPGEO1,IPGEO2,IPRINT,NREGIO,IEUR, + 1 NMERGE,IMERGE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover the geometry information from LCM (stored by operator GEO) and +* compute a corresponding macro-geometry (i.e. a pure geometry that can +* be treated by Bivac or Trivac or a two-level Eurydice geometry) +* together with NMERGE and array IMERGE. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXPTS allocated storage for arrays of dimension NMCEL. +* MAXMER allocated storage for arrays of dimension NMERGE. +* IPGEO1 pointer to the original geometry (L_GEOM signature). +* IPGEO2 pointer to the macro-geometry (L_GEOM signature). +* IPRINT print flag (equal to 0 for no print). +* NREGIO number of regions. +* IEUR type of tracking operator for the macro-geometry: +* =1: 2-level macro-geometry with MERGE; +* =2: 2-level NXT-type macro-geometry without MERGE; +* =3: 1-level TRIVAC-type macro-geometry without MERGE; +* =4: 2-level macro-geometry with MERGE and unfolding. +* +*Parameters: input/output +* NMERGE macro-calculation merging flag (=1 to indicate a homogeneous +* macro-calculation) on input and. +* number of merged regions (equal to the number of physical +* cells in Eurydice) at output. +* +*Parameters: output +* IMERGE index of merged regions. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR), TARGET :: IPGEO1 + TYPE(C_PTR) IPGEO2 + INTEGER MAXPTS,MAXMER,IPRINT,NREGIO,IEUR,NMERGE, + > IMERGE(NREGIO) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER HSMG*131,TYPE(0:9)*16,HSIGN*12,TEXT12*12 + LOGICAL ILK,LL1,LL2,LHOM,LBIHET + INTEGER NCODE(6),ICODE(6),ISTATE(NSTATE),JSTATE(NSTATE) + REAL ZCODE(6),ALBEDO(6),XXX(2),YYY(2) + LOGICAL LDIAG,LSYMX,LSYMY +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: INUM,IGEN,IORI,IMAT,NMC,IBI, + 1 LSECT,NMCR,NRINFO,NRODS,KEYMRG,MATALB,NRODR,NXRS,NXRI,NS,IMILIE, + 2 IHCEL + REAL, ALLOCATABLE, DIMENSION(:) :: XX,YY,RAYRE,RAN,VS,RODS,RODR, + 1 MESHX,MESHY + REAL, ALLOCATABLE, DIMENSION(:,:) :: FRACT + TYPE(C_PTR), POINTER :: IPGEOD,IPGEOX,IPGEOY +*---- +* DATA STATEMENTS +*---- + DATA TYPE/'VIRTUAL','HOMOGENEOUS','CARTESIAN 1-D','TUBE 1-D', + 1 'SPHERE 1-D','CARTESIAN 2-D','TUBE 2-D','CARTESIAN 3-D', + 2 'HEXAGONAL 2-D','HEXAGONAL 3-D'/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(INUM(2*MAXPTS),IGEN(MAXPTS),IORI(2*MAXPTS), + 1 IMAT(2*MAXPTS),NMC(MAXPTS+1),IBI(NREGIO)) + ALLOCATE(XX(MAXPTS),YY(MAXPTS)) +*---- +* RECOVER STATE VECTOR +*---- + ICLS=-99 + LR=-99 + LHOM=(NMERGE.EQ.1) + CALL LCMGET(IPGEO1,'STATE-VECTOR',ISTATE) + LBIHET=(ISTATE(12).EQ.1) +*---- +* UNFOLD GEOMETRY +*---- + IF(IEUR.EQ.4) THEN + IF((ISTATE(1).NE.5).OR.(ISTATE(8).NE.1)) THEN + CALL XABORT('EDIGEO: UNFOLDING NOT IMPLEMENTED FOR THIS TY' + 1 //'PE OF GEOMETRY.') + ENDIF + CALL LCMGET(IPGEO1,'NCODE',NCODE) + LDIAG=(NCODE(1).EQ.3).AND.(NCODE(4).EQ.3) + IF(LDIAG) THEN + ALLOCATE(IPGEOD) + CALL LCMOP(IPGEOD,'GEOM_DIAG',0,1,0) + CALL EDIUNF(IPGEO1,IPGEOD,'DIAG') + ELSE + IPGEOD=>IPGEO1 + ENDIF + CALL LCMGET(IPGEOD,'NCODE',NCODE) + LSYMX=(NCODE(3).EQ.5).AND.(NCODE(1).NE.3) + IF(LSYMX) THEN + ALLOCATE(IPGEOX) + CALL LCMOP(IPGEOX,'GEOM_SYMX',0,1,0) + CALL EDIUNF(IPGEOD,IPGEOX,'SYMX') + ELSE + IPGEOX=>IPGEOD + ENDIF + CALL LCMGET(IPGEOX,'NCODE',NCODE) + LSYMY=(NCODE(1).EQ.5).AND.(NCODE(4).NE.3) + IF(LSYMY) THEN + ALLOCATE(IPGEOY) + CALL LCMOP(IPGEOY,'GEOM_SYMY',0,1,0) + CALL EDIUNF(IPGEOX,IPGEOY,'SYMY') + ELSE + IPGEOY=>IPGEOX + ENDIF + ICLS=0 + LR=0 + ALLOCATE(RAYRE(MAXPTS),LSECT(MAXPTS),NMCR(MAXPTS)) + CALL READEU(MAXPTS,MAXPTS,IPGEOY,IR2,IBI,ILK,NMCEL,NMERGE, + 1 NGEN,INUM,IGEN,IPAS,LX,LY,XX,YY,LSECT,RAYRE,NMC,NMCR,IORI, + 2 NCODE,ZCODE,IHEX,IPRINT-5) + DEALLOCATE(RAYRE,LSECT,NMCR) + IF(LDIAG) THEN + CALL LCMCL(IPGEOD,2) + DEALLOCATE(IPGEOD) + ENDIF + IF(LSYMX) THEN + CALL LCMCL(IPGEOX,2) + DEALLOCATE(IPGEOX) + ENDIF + IF(LSYMY) THEN + CALL LCMCL(IPGEOY,2) + DEALLOCATE(IPGEOY) + ENDIF + IEUR=3 + GO TO 25 + ENDIF +*---- +* RECOVER ASSEMBLY INFORMATION FROM THE ORIGINAL GEOMETRY +*---- + IF( ((ISTATE(1).EQ.5).AND.(ISTATE(8).EQ.1)).OR. + 1 ((ISTATE(1).EQ.8).AND.(ISTATE(8).EQ.1)).OR. + 2 ((ISTATE(1).EQ.20).AND.(ISTATE(13).EQ.0)).OR. + 3 ((ISTATE(1).EQ.24).AND.(ISTATE(13).EQ.0)) ) THEN + ICLS=0 + LR=0 + ALLOCATE(RAYRE(MAXPTS),LSECT(MAXPTS),NMCR(MAXPTS)) + CALL READEU(MAXPTS,MAXPTS,IPGEO1,IR2,IBI,ILK,NMCEL,NMERGE, + 1 NGEN,INUM,IGEN,IPAS,LX,LY,XX,YY,LSECT,RAYRE,NMC,NMCR,IORI, + 2 NCODE,ZCODE,IHEX,IPRINT-5) + DEALLOCATE(RAYRE,LSECT,NMCR) + ELSE IF( ((ISTATE(1).EQ.3).OR.(ISTATE(1).EQ.20).OR. + 1 (ISTATE(1).EQ.24)).AND.(ISTATE(13).GE.1)) THEN + IROT=3 + LX=0 + LY=0 + IF(ISTATE(1).EQ.3) THEN + NSURW=1 + ICLS=1 + ELSE IF(ISTATE(1).EQ.20) THEN + NSURW=4 + ICLS=2 + LX=1 + LY=1 + ELSE IF(ISTATE(1).EQ.24) THEN + NSURW=6 + ICLS=3 + ENDIF + IAPP=1 + MAXJ=1 + CALL XCGDIM(IPGEO1,MAXPTS,NSURW,IROT,IAPP,MAXJ,NVOLW, + 1 NANW,MNANW,NRTW,MSRODW,MARODW,NSURFW) +*---- +* ALLOCATE BLOCK FOR READING GEOMETRY INFORMATION +*---- + ALLOCATE(NRINFO(2*NANW),NRODS(3*NRTW),KEYMRG(NSURW+NVOLW+1), + 1 MATALB(NSURW+NVOLW+1),NRODR(NRTW),NXRS(NRTW),NXRI(NRTW*NANW)) + ALLOCATE(RAN(NANW),VS(NSURW+NVOLW+1),RODS(2*NRTW), + 1 RODR(MSRODW*NRTW)) +* + CALL XCGGEO(IPGEO1,IROT,NSURW,NVOLW,NANW,MNANW,NRTW,MSRODW, + 1 IPRINT,ILK,NMATW,RAN,NRODS,RODS,NRODR,RODR,NRINFO,MATALB,VS, + 2 COTE,RADMIN,NCODE,ICODE,ZCODE,ALBEDO,KEYMRG,NXRS,NXRI) +* + IR2=0 + DO 10 I=1,NVOLW + IBI(I)=MATALB((NSURW+1)+I) + IR2=MAX(IR2,IBI(I)) + 10 CONTINUE + DEALLOCATE(RODR,RODS,VS) + DEALLOCATE(NXRI,NXRS,NRODR,MATALB,KEYMRG,NRODS) +*---- +* STORE INFORMATION FOR NEW GEOMETRY +*---- + IPAS=NVOLW + NMCEL=NANW + NMERGE=NANW + IHEX=0 + XX(1)=0.0 + NMC(1)=0 + DO 20 II=1,NANW + XX(II+1)=RAN(II) + INUM(II)=II + IGEN(II)=II + NMC(II+1)=NRINFO(2*(II-1)+1) + 20 CONTINUE + IF(NSURW.EQ.1) THEN + LR=NANW + ELSE IF(NSURW.EQ.4) THEN + LR=NANW-1 + XXX(1)=0.0 + XXX(2)=XX(NANW+1) + YYY(1)=0.0 + YYY(2)=COTE + ELSE + LR=NANW-1 + SIDE=XX(NANW+1) + ENDIF +* + DEALLOCATE(RAN,NRINFO) + ELSE + CALL XABORT('EDIGEO: INVALID TYPE OF INPUT GEOMETRY.') + ENDIF +*---- +* COMPUTE IMERGE ARRAY +*---- + 25 IF(LHOM) THEN +* HOMOGENEOUS MACRO-CALCULATION. + DO 30 I=1,NREGIO + IMERGE(I)=1 + 30 CONTINUE + NMERGE=1 + DO 40 I=1,NMCEL + IMAT(I)=1 + 40 CONTINUE + ELSE +* CELL-WISE HETEROGENEOUS MACRO-CALCULATION. + IPAS2=0 + DO 60 IKK=1,NMERGE + IKG=IGEN(IKK) + I2=NMC(IKG+1)-NMC(IKG) + DO 50 I=1,I2 + IMERGE(IPAS2+I)=IKK + 50 CONTINUE + IPAS2=IPAS2+I2 + 60 CONTINUE + IF(IPAS2.NE.IPAS) THEN + CALL XABORT('EDIGEO: INCONSISTENT ARRAY NMC.') + ENDIF + DO 70 I=1,NMCEL + IMAT(I)=INUM(I) + 70 CONTINUE + ENDIF +*---- +* IF DOUBLE HETEROGENEITY IS PRESENT IN THE REFERENCE GEOMETRY +*---- + IF(LBIHET) THEN + CALL LCMSIX(IPGEO1,'BIHET',1) + CALL LCMGET(IPGEO1,'STATE-VECTOR',ISTATE) + NG=ISTATE(1) + NMILG=ISTATE(3) + ALLOCATE(NS(NG),IMILIE(NMILG),FRACT(NG,NMILG)) + CALL LCMGET(IPGEO1,'NS',NS) + CALL LCMGET(IPGEO1,'MILIE',IMILIE) + CALL LCMGET(IPGEO1,'FRACT',FRACT) + CALL LCMSIX(IPGEO1,' ',2) + IND1=IR2 + DO 75 I=1,NMILG + IF(IMILIE(I).GT.IR2) THEN + WRITE (HSMG,500) IMILIE(I),IR2 + CALL XABORT(HSMG) + ENDIF + IND1=MIN(IND1,IMILIE(I)) + 75 CONTINUE + IPAS2=IPAS + DO 110 IKK=1,IPAS2 + IF(IBI(IKK).GE.IND1) THEN + IND=0 + DO 80 I=1,NMILG + IF(IMILIE(I).EQ.IBI(IKK)) IND=I + 80 CONTINUE + IF(IND.EQ.0) THEN + WRITE(HSMG,'(29HEDIGEO: A COMPOSITE MIXTURE (,I5,4H) IS, + 1 13H NOT DEFINED.)') IBI(IKK) + CALL XABORT(HSMG) + ENDIF + DO 100 J=1,NG + IF(FRACT(J,IND).GT.0.00001) THEN + DO 90 K=1,NS(J) + IPAS=IPAS+1 + IMERGE(IPAS)=IMERGE(IKK) + 90 CONTINUE + ENDIF + 100 CONTINUE + ENDIF + 110 CONTINUE + DEALLOCATE(FRACT,IMILIE,NS) + ENDIF + IF(IPAS.NE.NREGIO) THEN + WRITE(HSMG,'(45HEDIGEO: INCONSISTENT NUMBER OF REGIONS. IPAS=, + 1 I6,8H NREGIO=,I6)') IPAS,NREGIO + CALL XABORT(HSMG) + ELSE IF(NMERGE.GT.MAXMER) THEN + WRITE(HSMG,'(37HEDIGEO: INSUFFICIENT STORAGE (MAXMER=,I5, + 1 47H). THE MERGE OPTION SHOULD NOT BE USED IN EDI:.)') MAXMER + CALL XABORT(HSMG) + ENDIF + IF(IPRINT.GT.0) THEN + WRITE (6,'(/23H EDIGEO: MERGING INDEX:/(1X,14I5))') (IMERGE(I), + 1 I=1,NREGIO) + ENDIF +*---- +* COMPUTE THE MACRO-GEOMETRY +*---- + ISTATE(:NSTATE)=0 + ICODE(:6)=0 + CALL LCMPUT(IPGEO2,'NCODE',6,1,NCODE) + CALL LCMPUT(IPGEO2,'ZCODE',6,2,ZCODE) + CALL LCMPUT(IPGEO2,'ICODE',6,1,ICODE) + IF((ICLS.EQ.0).AND.(IEUR.LE.2)) THEN +* TWO-LEVEL MACRO-GEOMETRY. + ALLOCATE(IHCEL(3*NMERGE)) + JSTATE(:NSTATE)=0 + JSTATE(6)=1 + HSIGN='L_GEOM' + CALL LCMPTC(IPGEO2,'SIGNATURE',12,HSIGN) + IF(IHEX.EQ.0) THEN + ISTATE(1)=5 + JSTATE(1)=20 + JSTATE(3)=1 + JSTATE(4)=1 + DO 120 IKK=1,NMERGE + WRITE(TEXT12,'(4HCELL,I8.8)') IKK + READ(TEXT12,'(3A4)') (IHCEL((IKK-1)*3+I0),I0=1,3) + CALL LCMSIX(IPGEO2,TEXT12,1) + CALL LCMPUT(IPGEO2,'MIX',1,1,IKK) + XXX(1)=0.0 + XXX(2)=XX(IGEN(IKK)) + YYY(1)=0.0 + YYY(2)=YY(IGEN(IKK)) + CALL LCMPUT(IPGEO2,'MESHX',2,2,XXX) + CALL LCMPUT(IPGEO2,'MESHY',2,2,YYY) + JSTATE(7)=IKK + CALL LCMPUT(IPGEO2,'STATE-VECTOR',NSTATE,1,JSTATE) + CALL LCMSIX(IPGEO2,' ',2) + 120 CONTINUE + ELSE + ISTATE(1)=8 + JSTATE(1)=24 + JSTATE(3)=1 + DO 130 IKK=1,NMERGE + WRITE(TEXT12,'(4HCELL,I8.8)') IKK + READ(TEXT12,'(3A4)') (IHCEL((IKK-1)*3+I0),I0=1,3) + CALL LCMSIX(IPGEO2,TEXT12,1) + CALL LCMPUT(IPGEO2,'MIX',1,1,IKK) + CALL LCMPUT(IPGEO2,'SIDE',1,2,XX(1)) + JSTATE(7)=IKK + CALL LCMPUT(IPGEO2,'STATE-VECTOR',NSTATE,1,JSTATE) + CALL LCMSIX(IPGEO2,' ',2) + 130 CONTINUE + CALL LCMPUT(IPGEO2,'IHEX',1,1,IHEX) + ENDIF + CALL LCMPUT(IPGEO2,'CELL',3*NMERGE,3,IHCEL) + IF(IEUR.EQ.1) CALL LCMPUT(IPGEO2,'MERGE',NMCEL,1,INUM) + CALL LCMPUT(IPGEO2,'TURN',NMCEL,1,IORI) + DO 140 IBLK=1,NMCEL + INUM(IBLK)=-INUM(IBLK) + 140 CONTINUE + CALL LCMPUT(IPGEO2,'MIX',NMCEL,1,INUM) + DEALLOCATE(IHCEL) + ISTATE(8)=1 + ISTATE(9)=NMERGE + ISTATE(10)=1 + ELSE IF(ICLS.EQ.0) THEN +* ONE-LEVEL (TRIVAC-TYPE) MACRO-GEOMETRY. + CALL LCMPUT(IPGEO2,'MIX',NMCEL,1,IMAT) + IF(IHEX.EQ.0) THEN + ISTATE(1)=5 + ALLOCATE(MESHX(LX+1),MESHY(LY+1)) + MESHX(1)=0.0 + MESHY(1)=0.0 + LL1=((NCODE(2).EQ.3).AND.(NCODE(3).EQ.3)) + LL2=((NCODE(1).EQ.3).AND.(NCODE(4).EQ.3)) + IBLK=0 + DO 155 K1=1,LY + LXM=1 + LXP=LX + IF(LL1) LXP=K1 + IF(LL2) LXM=K1 + DO 150 K2=LXM,LXP + IBLK=IBLK+1 + IKK=INUM(IBLK) + IF(IKK.EQ.0) GO TO 150 + IF(MOD(IORI(IBLK)-1,2).EQ.0) THEN + MESHX(K2+1)=MESHX(K2)+XX(IGEN(IKK)) + MESHY(K1+1)=MESHY(K1)+YY(IGEN(IKK)) + ELSE + MESHX(K2+1)=MESHX(K2)+YY(IGEN(IKK)) + MESHY(K1+1)=MESHY(K1)+XX(IGEN(IKK)) + ENDIF + 150 CONTINUE + 155 CONTINUE + CALL LCMPUT(IPGEO2,'MESHX',LX+1,2,MESHX) + CALL LCMPUT(IPGEO2,'MESHY',LY+1,2,MESHY) + DEALLOCATE(MESHY,MESHX) + ELSE + ISTATE(1)=8 + IF(IHEX.EQ.10) THEN + IHEX=1 + ELSE IF(IHEX.EQ.11) THEN + IHEX=2 + ENDIF + CALL LCMPUT(IPGEO2,'IHEX',1,1,IHEX) + CALL LCMPUT(IPGEO2,'SIDE',1,2,XX(1)) + ENDIF + ELSE + CALL LCMPUT(IPGEO2,'MIX',NMCEL,1,IMAT) + CALL LCMPUT(IPGEO2,'RADIUS',LR+1,2,XX) + IF(ICLS.EQ.1) THEN + ISTATE(1)=3 + ELSE IF(ICLS.EQ.2) THEN + ISTATE(1)=20 + CALL LCMPUT(IPGEO2,'MESHX',LX+1,2,XXX) + CALL LCMPUT(IPGEO2,'MESHY',LY+1,2,YYY) + ELSE + ISTATE(1)=24 + IHEX=9 + CALL LCMPUT(IPGEO2,'IHEX',1,1,IHEX) + CALL LCMPUT(IPGEO2,'SIDE',1,2,SIDE) + ENDIF + ENDIF + ISTATE(2)=LR + ISTATE(3)=LX + ISTATE(4)=LY + ISTATE(6)=NMCEL + ISTATE(7)=NMERGE + CALL LCMPUT(IPGEO2,'STATE-VECTOR',NSTATE,1,ISTATE) + HSIGN='L_GEOM' + CALL LCMPTC(IPGEO2,'SIGNATURE',12,HSIGN) + IF(IPRINT.GT.0) THEN + HSIGN='MACRO$GEO' + WRITE (6,510) HSIGN,1,TYPE(ISTATE(1)) + IF(IPRINT.GT.1) THEN + WRITE (6,520) ISTATE(1),TYPE(ISTATE(1)),(ISTATE(I),I=2,7) + ENDIF + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(YY,XX) + DEALLOCATE(IBI,NMC,IMAT,IORI,IGEN,INUM) + RETURN +* + 500 FORMAT (34HEDIGEO: THE INPUT MIXTURE NUMBER (,I4,12H) IS GREATER, + 1 10H THAN IR (,I4,2H )) + 510 FORMAT(/39H EDIGEO: CREATION OF A GEOMETRY NAMED ',A12,7H' ON LE, + 1 3HVEL,I3,11H WITH TYPE ,A16,1H.) + 520 FORMAT(/31H STATE VECTOR (MACRO GEOMETRY):/ + 1 7H ITYPE ,I6, 4H (,A16,1H)/ + 2 7H LR ,I6,20H (NUMBER OF TUBES)/ + 3 7H LX ,I6,22H (X-DIMENSION INDEX)/ + 4 7H LY ,I6,22H (Y-DIMENSION INDEX)/ + 5 7H LZ ,I6,22H (Z-DIMENSION INDEX)/ + 6 7H LREG ,I6,22H (NUMBER OF REGIONS)/ + 7 7H MAXMIX,I6,25H (MAX. NB. OF MIXTURES)/1X,60(1H-)/) + END diff --git a/Dragon/src/EDIGET.f b/Dragon/src/EDIGET.f new file mode 100644 index 0000000..175e7bd --- /dev/null +++ b/Dragon/src/EDIGET.f @@ -0,0 +1,724 @@ +*DECK EDIGET + SUBROUTINE EDIGET(IPEDIT,IFGEO,NGROUP,NGCOND,NREG,NBMIX,MATCOD, + > ITMERG,NMERGE,IHF,IFFAC,ILUPS,NSAVES,NSTATS, + > IGCR,EGCR,IMERGE,CURNAM,OLDNAM,IADF,NW,ICURR, + > NBMICR,CARISO,NACTI,IACTI,IPRINT,MAXPTS,ICALL, + > ISOTXS,LISO,LDEPL,LMACR,IADJ,MACGEO,IEUR,NOUT, + > HVOUT,BB2,IEDCUR,IGOVE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read edition option parameters. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPEDIT pointer to the edition LCM object. +* IFGEO unit file number of the surfacic file. +* NGROUP number of groups. +* NREG number of regions. +* NBMIX maximum number of mixtures. +* MATCOD mixture index in region. +* +*Parameters: output +* NGCOND number of groups condensed. +* ITMERG type of technique to compute merge indices: +* = 0 no merge; +* =-1 merge by geometry (equigeom); +* =-2 merge by cell; +* =-3 merge by HMIX defined in GEO:; +* =-4 merge using IMERGE array directly. +* NMERGE number of merged indices in array IMERGE. +* IHF H-factor calculation (= 0 no; =1 yes). +* IFFAC four factor calculation flag: +* = 0 no four factors (default); +* = 1 four factor evaluation. +* ILUPS remove up-scattering from output. +* NSAVES homogenized x-s computation+save: +* = 0 no compute no save; +* = 1 compute, no save; +* = 2 compute and save. +* NSTATS statistics level: +* = 0 no statistics; +* = 1 statistics on fluxes; +* = 2 statistics on reaction rates; +* = 3 statistics on fluxes and reaction rates; +* =-1 delta sigma (MERG COMP only). +* IGCR condensed group limits. +* EGCR condensed energy limits. +* IMERGE merged region positions. +* CURNAM name of LCM directory where the current rates are to be +* stored. +* OLDNAM name of LCM directory where old reaction rates were stored. +* IADF flag for computing boundary or ADF information: +* = 0 do not compute them; +* = 1 compute boundary currents using ALBS information; +* = 2 recover averaged fluxes in boundary regions; +* = -2 compute ADF using averaged fluxes in boundary regions; +* = 3 compute boundary information using SYBIL/ARM or MOC +* interface currents; +* = 4 recover ADF information from input macrolib. +* NW type of weighting for P1 cross section info: +* =0 use flux to merge/condense P1 matrices; +* =1 use current to merge/condense P1 matrices. +* ICURR type of current approximation if NW=1: +* =1: heterogeneous leakage; +* =2: Todorova outscatter approximation; +* =4: use spherical harmonic moments of the flux. +* NBMICR type of microlib edition: +* =-2: process only macroscopic residue; +* =-1: process each isotope; +* =0: process no isotope; +* >0 number of isotopes to process. +* CARISO names of the isotopes to process. +* NACTI number of activation edit. +* IACTI activation mixtures. +* IPRINT print index. +* MAXPTS maximum number of macro-regions. +* ICALL maximum directory index in IPEDIT. +* ISOTXS ISOTX file enabling flag (0: off; 1: binary; 2: ascii). +* LISO =.TRUE. if we want to keep all the isotopes after +* homogeneization. +* LDEPL =.TRUE. if we want to recover depletion information. +* LMACR =.TRUE. if we want to compute a residual isotope. +* IADJ type of flux weighting: +* =0: direct flux weighting; +* =1: direct-adjoint flux weighting. +* MACGEO name of the macro-geometry. +* IEUR type of tracking tone on the macro-geometry: +* =1: SYBIL or EXCELL; +* =2: NXT; +* =3: else. +* NOUT number of output cross section types (set to zero to recover +* all cross section types). +* HVOUT MATXS names of the output cross section types. +* BB2 imposed leakage used in non-regression tests. +* IEDCUR current edition flag with MOC and SN methods: +* =0: flux edition only; +* =1: flux and current edition. +* IGOVE Golfier-Vergain flag (=0/1: don't/use Golfier-Vergain equ'n). +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE EDIG2S_MOD +*---- +* SUBROUTINE ARGUMENTS +*---- + PARAMETER (MAXED=100,MAXOUT=100) + TYPE(C_PTR) IPEDIT + INTEGER IFGEO,NGROUP,NGCOND,NREG,NBMIX,MATCOD(NREG),ITMERG, + > NMERGE,IHF,IFFAC,ILUPS,NSAVES,NSTATS,IGCR(NGROUP), + > IMERGE(NREG),IADF,NW,ICURR,NBMICR,NACTI, + > IACTI(NBMIX),IPRINT,MAXPTS,ICALL,ISOTXS,IADJ, + > IEUR,NOUT,IEDCUR,IGOVE + REAL EGCR(NGROUP),BB2 + LOGICAL LISO,LDEPL,LMACR + CHARACTER CURNAM*12,OLDNAM*12,CARISO(MAXED)*12,MACGEO*12, + > HVOUT(MAXOUT)*8,HSMG*131 +*---- +* LOCAL VARIABLES +*---- + CHARACTER CARLIR*8,HTYPE*8 + REAL REALIR + DOUBLE PRECISION DBLLIR + INTEGER, ALLOCATABLE, DIMENSION(:) :: MIXMER,INADF,IOFGAP,IREMIX + CHARACTER*8, ALLOCATABLE, DIMENSION(:) :: HADF +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(MIXMER(0:NBMIX)) +*---- +* INITIALIZE MIXMER +*---- + DO 10 IMATER=0,NBMIX + MIXMER(IMATER)=IMATER + 10 CONTINUE +*---- +* READ OPTION NAME +*---- + ISOTXS=0 + 20 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + 30 IF(ITYPLU.EQ.10) GO TO 250 + IF(ITYPLU.NE.3) CALL XABORT('EDIGET: READ ERROR - CHARACTER VARI' + > //'ABLE EXPECTED') + 40 IF(CARLIR.EQ.';') THEN + GO TO 250 + ELSE IF(CARLIR.EQ.'EDIT') THEN + CALL REDGET(ITYPLU,IPRINT,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('EDIGET: READ ERROR - INTEGER VARI' + > //'ABLE EXPECTED(1)') + ELSE IF(CARLIR.EQ.'NADF') THEN + IADF=0 + ELSE IF(CARLIR.EQ.'ALBS') THEN + IADF=1 + ELSE IF(CARLIR.EQ.'ADF') THEN + IADF=2 + CALL REDGET(ITYPLU,INTLIR,REALIR,HTYPE,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('EDIGET: READ ERROR - CHARACTER*8 ' + > //'TYPE EXPECTED(1)') + IF(HTYPE.EQ.'*') THEN + IADF=-2 + CALL REDGET(ITYPLU,INTLIR,REALIR,HTYPE,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('EDIGET: READ ERROR - CHARACTER*' + > //'8 TYPE EXPECTED(2)') + ENDIF + CALL LCMSIX(IPEDIT,'REF:ADF',1) + CALL LCMLEN(IPEDIT,'NTYPE',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + NTYPE=0 + ELSE + CALL LCMGET(IPEDIT,'NTYPE',NTYPE) + ENDIF + ALLOCATE(INADF(NTYPE+1),HADF(NTYPE+1),IOFGAP(NREG)) + IF(NTYPE.GT.0) THEN + CALL LCMGET(IPEDIT,'NADF',INADF) + CALL LCMGTC(IPEDIT,'HADF',8,NTYPE,HADF) + ENDIF + IOFGAP(:NREG)=0 + IGAP=0 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('EDIGET: READ ERROR - CHARACTER*4 ' + > //'TYPE EXPECTED') + IF(CARLIR(:4).EQ.'REGI') THEN + 50 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.1) THEN + IGAP=IGAP+1 + IF(IGAP.GT.NREG) THEN + CALL XABORT('EDIGET: BOUNDARY REGI OVERFLOW(1)') + ELSE IF(INTLIR.GT.NREG) THEN + CALL XABORT('EDIGET: BOUNDARY REGO OVERFLOW(2)') + ELSE IF(IOFGAP(IGAP).NE.0) THEN + CALL XABORT('EDIGET: REGI ALREADY DEFINED') + ENDIF + IOFGAP(IGAP)=INTLIR + ELSE IF((ITYPLU.EQ.3).AND.(CARLIR.EQ.'ENDR')) THEN + GO TO 80 + ELSE + CALL XABORT('EDIGET: INTEGER OR ENDR KEYWORD EXPECTED') + ENDIF + GO TO 50 + ELSE IF(CARLIR.EQ.'MIX') THEN + 60 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.1) THEN + DO 70 IREG=1,NREG + IF(MATCOD(IREG).EQ.INTLIR) THEN + IGAP=IGAP+1 + IF(IGAP.GT.NREG) THEN + CALL XABORT('EDIGET: BOUNDARY MIX OVERFLOW(1)') + ELSE IF(INTLIR.GT.NBMIX) THEN + CALL XABORT('EDIGET: BOUNDARY MIX OVERFLOW(2)') + ELSE IF(IOFGAP(IGAP).NE.0) THEN + CALL XABORT('EDIGET: MIX ALREADY DEFINED') + ENDIF + IOFGAP(IGAP)=IREG + ENDIF + 70 CONTINUE + IF(IGAP.EQ.0) THEN + WRITE(HSMG,'(16HEDIGET: ADF MIX=,I5,9H MISSING.)') INTLIR + CALL XABORT(HSMG) + ENDIF + ELSE IF((ITYPLU.EQ.3).AND.(CARLIR.EQ.'ENDM')) THEN + GO TO 80 + ELSE + CALL XABORT('EDIGET: INTEGER OR ENDM KEYWORD EXPECTED') + ENDIF + GO TO 60 + ELSE + CALL XABORT('EDIGET: REGI OR MIX KEYWORD EXPECTED(1)') + ENDIF + 80 NTYPE=NTYPE+1 + INADF(NTYPE)=IGAP + HADF(NTYPE)=HTYPE +* + CALL LCMPUT(IPEDIT,'NTYPE',1,1,NTYPE) + CALL LCMPUT(IPEDIT,'NADF',NTYPE,1,INADF) + CALL LCMPTC(IPEDIT,'HADF',8,NTYPE,HADF) + CALL LCMPUT(IPEDIT,HTYPE,IGAP,1,IOFGAP) + CALL LCMSIX(IPEDIT,' ',2) +* + DEALLOCATE(IOFGAP,HADF,INADF) + ELSE IF(CARLIR.EQ.'JOUT') THEN + IADF=3 + ELSE IF(CARLIR.EQ.'ADFM') THEN + IADF=4 + ELSE IF(CARLIR(:4).EQ.'MGEO') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,MACGEO,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('EDIGET: READ ERROR - CHARACTER' + > //' VARIABLE EXPECTED') + ELSE IF(CARLIR.EQ.'UPS') THEN + ILUPS=1 + ELSE IF(CARLIR.EQ.'P0W') THEN +* FLUX WEIGHTING OF THE PN MATRICES. + NW=0 + ICURR=0 + ELSE IF(CARLIR.EQ.'P1W_L') THEN +* FUNDAMENTAL CURRENT WEIGHTING OF THE PN MATRICES. + NW=1 + ICURR=1 + ELSE IF(CARLIR.EQ.'P1W_TO') THEN +* TODOROVA OUTSCATTER CURRENT WEIGHTING OF THE PN MATRICES. + NW=1 + ICURR=2 + ELSE IF(CARLIR.EQ.'PNW_SP') THEN +* SPHERICAL HARMONICS WEIGHTING OF THE PN MATRICES. + NW=1 + ICURR=4 + ELSE IF(CARLIR.EQ.'EDI_CURR') THEN +* CURRENT EDITION WITH MOC AND SN METHODS. + IEDCUR=1 + ELSE IF(CARLIR(:4).EQ.'MICR') THEN + CALL REDGET(ITYPLU,NBMICR,REALIR,CARLIR,DBLLIR) + IF((ITYPLU.EQ.3).AND.(CARLIR(:4).EQ.'ALLX')) THEN +* TO REGISTER ALL ISOTOPES CROSS SECTION IN THE MERGED REGIONS + LISO=.TRUE. + CALL REDGET(ITYPLU,NBMICR,REALIR,CARLIR,DBLLIR) + ENDIF + IF((ITYPLU.EQ.3).AND.(CARLIR(:6).EQ.'NODEPL')) THEN +* TO SUPPRESS RECOVERY OF DEPLETION INFORMATION + LDEPL=.FALSE. + CALL REDGET(ITYPLU,NBMICR,REALIR,CARLIR,DBLLIR) + ENDIF + IF((ITYPLU.EQ.3).AND.(CARLIR(:6).EQ.'NOMACR')) THEN +* TO SUPPRESS THE CANCULATION OF A RESIDUAL ISOTOPE + LMACR=.FALSE. + CALL REDGET(ITYPLU,NBMICR,REALIR,CARLIR,DBLLIR) + ENDIF + IF((ITYPLU.EQ.3).AND.(CARLIR(:4).EQ.'ISOT')) THEN + ISOTXS=1 + CALL REDGET(ITYPLU,NBMICR,REALIR,CARLIR,DBLLIR) + IF((ITYPLU.EQ.3).AND.(CARLIR(:4).EQ.'ASCI')) THEN + ISOTXS=2 + CALL REDGET(ITYPLU,NBMICR,REALIR,CARLIR,DBLLIR) + ENDIF + ENDIF + IF((ITYPLU.EQ.3).AND.(CARLIR.EQ.'RES')) THEN + NBMICR=-2 + ELSE IF((ITYPLU.EQ.3).AND.(CARLIR.EQ.'ALL')) THEN + NBMICR=-1 + ELSE IF(ITYPLU.EQ.1) THEN + IF(NBMICR.GT.MAXED) CALL XABORT('EDIGET: TOO MANY MICR') + DO 90 IIII=1,NBMICR + CALL REDGET(ITYPLU,INTLIR,REALIR,CARISO(IIII),DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('EDIGET: READ ERROR - CHARACTE' + > //'R VARIABLE EXPECTED') + 90 CONTINUE + ELSE + CALL XABORT('EDIGET: READ ERROR - KEY ISOTXS, ALL, NONE OR I' + > //'NTEGER VARIABLE EXPECTED AFTER MICR') + ENDIF + ELSE IF(CARLIR(:4).EQ.'REAC') THEN + CALL REDGET(ITYPLU,NOUT,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('EDIGET: READ ERROR - INTEGER' + > //' VARIABLE EXPECTED(2)') + IF(NOUT.GT.MAXOUT) CALL XABORT('EDIGET: MAXOUT OVERFLOW') + DO 100 IOT=1,NOUT + CALL REDGET(ITYPLU,INTLIR,REALIR,HVOUT(IOT),DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('EDIGET: READ ERROR - CHARACTER' + > //' VARIABLE EXPECTED') + 100 CONTINUE + ELSE IF(CARLIR(:4).EQ.'ACTI') THEN + IF((ITYPLU.EQ.3).AND.(CARLIR(:4).EQ.'ISOT')) THEN + ISOTXS=1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF((ITYPLU.EQ.3).AND.(CARLIR(:4).EQ.'ASCI')) THEN + ISOTXS=2 + CALL REDGET(ITYPLU,NBMICR,REALIR,CARLIR,DBLLIR) + ENDIF + ENDIF + IF((ITYPLU.EQ.3).AND.(CARLIR.EQ.'NONE')) THEN + NACTI=0 + ELSE + DO 211 IREG=1,NBMIX + IF(ITYPLU.EQ.1) THEN + IF(INTLIR.GT.NBMIX) CALL XABORT('EDIGET: INVALID ACTIVAT' + > //'ION INDEX') + NACTI=NACTI+1 + IACTI(NACTI)=INTLIR + ELSE + GO TO 30 + ENDIF + IF(IREG.LT.NBMIX) THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + ENDIF + 211 CONTINUE + ENDIF + ELSE IF(CARLIR(:4).EQ.'COND') THEN +*---- +* GROUP CONDENSATION DIRECTIVE ANALYSIS +*---- + DO 108 IGROUP=1,NGROUP+1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.3) THEN + IF(IGROUP.EQ.1) THEN + IF(CARLIR.EQ.'NONE') THEN + NGCOND=NGROUP + DO 107 JGROUP=1,NGROUP + IGCR(JGROUP)=JGROUP + 107 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + GO TO 30 + ELSE + NGCOND=1 + IGCR(NGCOND)=NGROUP + ENDIF + ENDIF + GO TO 30 + ELSE IF(ITYPLU.EQ.1) THEN + IF(INTLIR.GT.NGROUP) INTLIR=NGROUP + IF(NGCOND.GT.0) THEN + IF(INTLIR.GT.IGCR(NGCOND)) THEN + NGCOND=NGCOND+1 + IGCR(NGCOND)=INTLIR + ENDIF + ELSE + NGCOND=NGCOND+1 + IGCR(NGCOND)=INTLIR + ENDIF + ELSE + IF(NGCOND.GT.0) THEN + IF(REALIR.LT.EGCR(NGCOND)) THEN + NGCOND=NGCOND+1 + EGCR(NGCOND)=REALIR + ENDIF + ELSE + NGCOND=NGCOND+1 + EGCR(NGCOND)=REALIR + ENDIF + ENDIF + 108 CONTINUE + ELSE IF(CARLIR(:4).EQ.'MERG') THEN +*---- +* MERGING DIRECTIVE ANALYSIS +*---- + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('EDIGET: READ ERROR - CHARACTER VA' + > //'RIABLE EXPECTED') + IF(CARLIR.EQ.'COMP') THEN +*---- +* COMPLETE MERGE +*---- + IMERGE(:NREG)=1 + ITMERG=-4 + NMERGE=1 + GO TO 20 + ELSE IF(CARLIR.EQ.'GEO') THEN +*---- +* MERGE BY GEOMETRY +*---- + ITMERG=-1 + NMERGE=0 + GO TO 20 + ELSE IF(CARLIR.EQ.'CELL') THEN +*---- +* CELL-BY-CELL MERGE +*---- + ITMERG=-2 + NMERGE=0 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('EDIGET: READ ERROR - CHARACTER ' + > //'VARIABLE EXPECTED') + IF((CARLIR.EQ.'SYBIL').OR.(CARLIR.EQ.'EXCELL')) THEN + IEUR=1 + ELSE IF(CARLIR.EQ.'NXT') THEN + IEUR=2 + ELSE IF(CARLIR.EQ.'DEFAULT') THEN + IEUR=3 + ELSE IF(CARLIR.EQ.'UNFOLD') THEN + IEUR=4 + ELSE IF(CARLIR.EQ.'REMIX') THEN + GO TO 105 + ELSE + IEUR=3 + GO TO 40 + ENDIF + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('EDIGET: READ ERROR - CHARACTER ' + > //'VARIABLE EXPECTED') + 105 IF(CARLIR.EQ.'REMIX') THEN +* Data to further homogenize a cell-by-cell homogenization. + 110 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.1) THEN + NMERGE=NMERGE+1 + IF(NMERGE.GT.NREG) CALL XABORT('EDIGET: IMERGE(NREG) OVE' + > //'RFLOW') + IMERGE(NMERGE)=INTLIR + GO TO 110 + ELSE + GO TO 40 + ENDIF + ENDIF + GO TO 40 + ELSE IF(CARLIR.EQ.'HMIX') THEN +*---- +* MERGE BY HOMOGENIZATION MIXTURES +*---- + ITMERG=-3 + NMERGE=0 + GO TO 20 + ELSE IF(CARLIR.EQ.'MIX') THEN +*---- +* MERGE BY MIXTURES +*---- + ITMERG=-4 + NMIXME=0 + DO 114 IREG=1,NREG + IBM=MATCOD(IREG) + IF(IBM.GT.NBMIX) CALL XABORT('EDIGET: NBMIX OVERFLOW.') + NMIXME=MAX(NMIXME,IBM) + IMERGE(IREG)=MIXMER(IBM) + 114 CONTINUE + NMERGE=NMIXME + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.1) THEN +*---- +* SPECIFY MIXTURES TO BE MERGED +*---- + NMERGE=MAX(0,INTLIR) + MIXMER(1)=INTLIR + DO 115 IMATER=2,NMIXME + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('EDIGET: READ ERROR - INTEGE' + > //'R VARIABLE EXPECTED(3)') + NMERGE=MAX(NMERGE,INTLIR) + MIXMER(IMATER)=INTLIR + 115 CONTINUE + DO 116 IREG=1,NREG + IMERGE(IREG)=MIXMER(MATCOD(IREG)) + 116 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) THEN + WRITE(HSMG,'(40HEDIGET: READ ERROR - CHARACTER VARIABLE , + > 10H EXPECTED.,I5,26H MIXTURE INDICES EXPECTED.)') NMIXME + CALL XABORT(HSMG) + ENDIF + GO TO 40 + ELSE IF(ITYPLU.EQ.3) THEN +*---- +* ASSOCIATE ONE REGION BY MIXTURE +*---- + GO TO 40 + ELSE + CALL XABORT('EDIGET: READ ERROR - INVALID TYPE READ') + ENDIF + ELSE IF(CARLIR(:4).EQ.'REGI') THEN +*---- +* MERGE BY REGIONS +*---- + ITMERG=-4 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('EDIGET: READ ERROR - INTEGE' + > //'R VARIABLE EXPECTED(4)') + NMERGE=MAX(0,INTLIR) + IMERGE(1)=INTLIR + DO 118 IREG=2,NREG + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) THEN + WRITE(CARLIR,'(I4)') NREG + CALL XABORT('EDIGET: READ ERROR - INTEGER VARIABLE EXPE' + > //'CTED NREG='//CARLIR) + ENDIF + NMERGE=MAX(NMERGE,INTLIR) + IMERGE(IREG)=INTLIR + 118 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) THEN + WRITE(HSMG,'(40HEDIGET: READ ERROR - CHARACTER VARIABLE , + > 10H EXPECTED.,I5,25H REGION INDICES EXPECTED.)') NREG + CALL XABORT(HSMG) + ENDIF + GO TO 40 + ELSE IF(CARLIR.EQ.'G2S') THEN + CALL EDIG2S(IPRINT,IFGEO,NREG,NMERGE,IMERGE) + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('EDIGET: READ ERROR - CHARACTER ' + > //'VARIABLE EXPECTED') + IF(CARLIR.EQ.'REMIX') THEN +* REMIX option. + NMEOLD=NMERGE + NMERGE=0 + ALLOCATE(IREMIX(NMEOLD)) + DO II=1,NMEOLD + CALL REDGET(ITYPLU,IREMIX(II),REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('EDIGET: READ ERROR - INTEGE' + > //'R VARIABLE EXPECTED(5)') + ENDDO + DO IREG=1,NREG + IM=IMERGE(IREG) + IF(IM.GT.0) THEN + IF(IM.GT.NMEOLD) CALL XABORT('EDIGET: IMERGE OVERFLOW') + IMERGE(IREG)=IREMIX(IM) + NMERGE=MAX(NMERGE,IMERGE(IREG)) + ENDIF + ENDDO + DEALLOCATE(IREMIX) + ELSE + GO TO 40 + ENDIF + ELSE IF(CARLIR.EQ.'NONE') THEN +*---- +* NO MERGING +*---- + ITMERG=-4 + NMERGE=NREG + DO 106 IREG=1,NREG + IMERGE(IREG)=IREG + 106 CONTINUE + ELSE + CALL XABORT('EDIGET: READ ERROR - ILLEGAL KEYWORD '// + > 'FOLLOWING MERG -- ALLOWED : COMP, MIX REGI, READ : '// + > CARLIR) + ENDIF + ELSE IF(CARLIR.EQ.'TAKE') THEN +*---- +* TAKE DIRECTIVE ANALYSIS +*---- + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('EDIGET: READ ERROR - CHARACTER VA' + > //'RIABLE EXPECTED') + IF(CARLIR.EQ.'MIX') THEN +*---- +* TAKE PER MIXTURE +*---- + NMIXME=0 + DO 120 IREG=1,NREG + NMIXME=MAX(NMIXME,MATCOD(IREG)) + 120 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.1) THEN + MIXMER(:NMIXME)=0 +*---- +* SPECIFY MIXTURES TO BE SELECTED +*---- + IF(INTLIR.LE.NMIXME.AND.INTLIR.GT.0) MIXMER(INTLIR)=1 + NMERGE=1 + DO 122 IMATER=2,NBMIX + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) GO TO 123 + IF(INTLIR.LE.NMIXME.AND.INTLIR.GT.0) MIXMER(INTLIR)=IMATER + NMERGE=NMERGE+1 + 122 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + ENDIF + 123 CONTINUE + WRITE(6,'(1X,A6,2X,2I10)') 'MIXMER',NMIXME,NMERGE + WRITE(6,'(5I10)') (MIXMER(JJJ),JJJ=1,NMIXME) + DO 124 IREG=1,NREG + IMERGE(IREG)=MIXMER(MATCOD(IREG)) + 124 CONTINUE + GO TO 30 + ELSE IF(CARLIR(:4).EQ.'REGI') THEN +*---- +* TAKE PER REGIONS +*---- + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('EDIGET: AT LEAST ONE REGION' + > //' MUST BE SELECTED') + DO 125 IREG=1,NREG + IMERGE(IREG)=0 + 125 CONTINUE + NMERGE=1 + IMERGE(INTLIR)=1 + DO 126 IREG=2,NREG + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) GO TO 30 + NMERGE=NMERGE+1 + IMERGE(INTLIR)=IREG + 126 CONTINUE + ELSE + CALL XABORT('EDIGET: READ ERROR - ILLEGAL KEYWORD '// + > 'FOLLOWING TAKE -- ALLOWED : MIX REGI, READ : '// CARLIR) + ENDIF + ELSE IF(CARLIR.EQ.'SAVE') THEN +*---- +* SAVE DIRECTIVE ANALYSIS +*---- + NSAVES=2 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('EDIGET: READ ERROR - CHARACTER VA' + > //'RIABLE EXPECTED') + IF(CARLIR.EQ.'ON') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CURNAM,DBLLIR) + IF(ITYPLU.EQ.2) CALL XABORT('EDIGET: READ ERROR - REAL VARIA' + > //'BLE FORBIDDEN') + IF(ITYPLU.EQ.1) THEN + WRITE(CURNAM,'(8HREF-CASE,I4.4)') INTLIR + ICALL=MAX(ICALL,INTLIR) + ENDIF + ELSE + GO TO 40 + ENDIF + ELSE IF(CARLIR.EQ.'STAT') THEN +*---- +* STAT DIRECTIVE ANALYSIS +*---- + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('EDIGET: READ ERROR - CHARACTER VA' + > //'RIABLE EXPECTED') + IF(CARLIR.EQ.'FLUX') THEN + NSTATS=1 + ELSE IF(CARLIR.EQ.'RATE') THEN + NSTATS=2 + ELSE IF(CARLIR.EQ.'ALL ') THEN + NSTATS=3 + ELSE IF(CARLIR.EQ.'DELS') THEN + NSTATS=-1 + ELSE + CALL XABORT('EDIGET: READ ERROR - ILLEGAL KEYWORD '// + > CARLIR) + ENDIF + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('EDIGET: READ ERROR - CHARACTER VA' + > //'RIABLE EXPECTED') + IF(CARLIR(:4).EQ.'REFE') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,OLDNAM,DBLLIR) + IF(ITYPLU.EQ.2) CALL XABORT('EDIGET: READ ERROR - REAL VARIA' + > //'BLE FORBIDDEN') + IF(ITYPLU.EQ.1) WRITE(OLDNAM,'(8HREF-CASE,I4.4)') INTLIR + ELSE + GO TO 40 + ENDIF + ELSE IF(CARLIR.EQ.'NOHF') THEN + IHF=0 + ELSE IF(CARLIR.EQ.'NBAL') THEN + IFFAC=1000 + ELSE IF(CARLIR.EQ.'MAXR') THEN + CALL REDGET(ITYPLU,MAXPTS,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('EDIGET: READ ERROR - INTEGER VARI' + > //'ABLE EXPECTED(6)') + ELSE IF(CARLIR(:4).EQ.'DIRE') THEN + IADJ=0 + ELSE IF(CARLIR(:4).EQ.'PROD') THEN + IADJ=1 + ELSE IF(CARLIR(:4).EQ.'LEAK') THEN + CALL REDGET(ITYPLU,INTLIR,BB2,CARLIR,DBLLIR) + IF(ITYPLU.NE.2) CALL XABORT('EDIGET: REAL DATA EXPECTED.') + ELSE IF(CARLIR(:6).EQ.'GOLVER') THEN + IGOVE=1 + ELSE + CALL XABORT('EDIGET:ILLEGAL KEYWORD '//CARLIR) + ENDIF + GO TO 20 +*---- +* RETURN +*---- + 250 IF(IPRINT.GE.2) NSAVES=MAX(1,NSAVES) + IF((NSAVES.EQ.0).AND.((NSTATS.NE.0).OR.(IFFAC.NE.0))) NSAVES=1 + IF((NSAVES.GE.2).AND.(CURNAM.EQ.' ')) THEN + ICALL=ICALL+1 + WRITE(CURNAM,'(8HREF-CASE,I4.4)') ICALL + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(MIXMER) + RETURN + END diff --git a/Dragon/src/EDIHFC.f b/Dragon/src/EDIHFC.f new file mode 100644 index 0000000..7cdc561 --- /dev/null +++ b/Dragon/src/EDIHFC.f @@ -0,0 +1,295 @@ +*DECK EDIHFC + SUBROUTINE EDIHFC(IPEDIT,NGROUP,NGCOND,NREGIO,NMERGE,NBISO, + > NDEPL,NREAC,MATCOD,VOLUME,INADPL,ISONAM,ISONRF, + > IPISO,MIX,FLUXES,DEN,IGCOND,IMERGE,RER,EMEVF2, + > EMEVG2,VOLME,IPRINT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Evaluate H-factors using information recovered from the reference +* internal library and store them in the edition macrolib. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPEDIT pointer to the edition LCM object. +* NGROUP number of groups. +* NGCOND number of condensed groups. +* NREGIO number of regions. +* NMERGE number of merged regions. +* NBISO number of isotopes. +* NDEPL number of depleting isotopes. +* NREAC number of depletion reactions. +* MATCOD material per region. +* VOLUME volume of region. +* INADPL name of depleting isotopes. +* ISONAM isotopes names. +* ISONRF library name of isotopes. +* IPISO pointer array towards microlib isotopes. +* MIX mixture associated with isotopes. +* FLUXES multigroup fluxes. +* DEN isotope density. +* IGCOND limits of condensed groups. +* IMERGE index of merged region. +* RER fission and capture production energy (MeV/reaction). +* VOLME merged volume. +* IPRINT print level. +* +*Parameters: output +* EMEVF2 fission production energy by isotope. +* EMEVG2 capture production energy by isotope. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPEDIT,IPISO(NBISO) + INTEGER IUNOUT + INTEGER NGROUP,NGCOND,NREGIO,NMERGE,NBISO,NDEPL,NREAC, + > MATCOD(NREGIO),INADPL(3,NDEPL),ISONAM(3,NBISO), + > ISONRF(3,NBISO),MIX(NBISO),IGCOND(NGCOND), + > IMERGE(NREGIO) + REAL VOLUME(NREGIO),FLUXES(NREGIO,NGROUP),DEN(NBISO), + > RER(NREAC,NDEPL),EMEVF2(NBISO),EMEVG2(NBISO) + REAL VOLME(NMERGE) + INTEGER IPRINT + DOUBLE PRECISION TOTPOW,POWF,POWC,POWT + INTEGER, ALLOCATABLE, DIMENSION(:) :: INDX + REAL, ALLOCATABLE, DIMENSION(:) :: SIG,HFACT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: FLXMER + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: WORK +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPEDIT,KPEDIT,KPLIB + PARAMETER (IUNOUT=6) + INTEGER IGAR(3) + CHARACTER HNISOR*12,TEXT12*12,HSMG*131 + LOGICAL L1,L2 + DOUBLE PRECISION GAR,CONV,XDRCST +*---- +* SCRATCH STORAGE ALLOCATION +* SIG fission/capture cross sections. +* HFACT H-factor in a macrogroup. +* FLXMER merged and condensed flux. +* WORK H-factors. +* INDX depleting isotope index. +*---- + ALLOCATE(INDX(NBISO)) + ALLOCATE(SIG(NGROUP),HFACT(NMERGE)) + ALLOCATE(FLXMER(NMERGE,NGCOND),WORK(NMERGE,NGCOND,3)) +*---- +* COMPUTE THE DEPLETING ISOTOPE INDEX +*---- + DO 20 ISO=1,NBISO + WRITE(HNISOR,'(3A4)') (ISONRF(I0,ISO),I0=1,3) + I1=INDEX(HNISOR,'_') + IF(I1.EQ.0) THEN + TEXT12=HNISOR + ELSE + TEXT12=HNISOR(:I1-1) + ENDIF + READ(TEXT12,'(3A4)') (IGAR(I0),I0=1,3) + DO 10 IDP=1,NDEPL + L1=((ISONRF(1,ISO).EQ.INADPL(1,IDP)).AND. + 1 (ISONRF(2,ISO).EQ.INADPL(2,IDP)).AND. + 2 (ISONRF(3,ISO).EQ.INADPL(3,IDP))) + L2=((IGAR(1).EQ.INADPL(1,IDP)).AND. + 1 (IGAR(2).EQ.INADPL(2,IDP)).AND. + 2 (IGAR(3).EQ.INADPL(3,IDP))) + IF(L1.OR.L2) THEN + INDX(ISO)=IDP + GO TO 20 + ENDIF + 10 CONTINUE + INDX(ISO)=0 + 20 CONTINUE +*---- +* COMPUTE H-FACTOR +*---- + CONV=1.0D6 ! convert MeV to eV + IZFISS=0 + FLXMER(:NMERGE,:NGCOND)=0.0D0 + WORK(:NMERGE,:NGCOND,:3)=0.0D0 + DO 160 ISO=1,NBISO + IDPL=INDX(ISO) + IF(IDPL.EQ.0) GO TO 160 + KPLIB=IPISO(ISO) ! set ISO-th isotope + IF(.NOT.C_ASSOCIATED(KPLIB)) THEN + WRITE(HSMG,'(17HEDIHFC: ISOTOPE '',3A4,16H'' IS NOT AVAILAB, + > 19HLE IN THE MICROLIB.)') (ISONAM(I0,ISO),I0=1,3) + CALL XABORT(HSMG) + ENDIF +*---- +* RECOVER H-FACTOR INFORMATION IF AVAILABLE +*---- + CALL LCMLEN(KPLIB,'H-FACTOR',ILLCM,ITLCM) + IF(ILLCM.EQ.NGROUP) THEN + IZFISS=IZFISS+1 + CALL LCMGET(KPLIB,'H-FACTOR',SIG) + DO 90 IREG=1,NREGIO + IMR=IMERGE(IREG) + IF((IMR.GT.0).AND.(MATCOD(IREG).EQ.MIX(ISO))) THEN + IGRFIN=0 + DO 80 IGC=1,NGCOND + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGC) + GAR=0.0D0 + DO 70 IGR=IGRDEB,IGRFIN + GAR=GAR+FLUXES(IREG,IGR)*DEN(ISO)*VOLUME(IREG)* + > SIG(IGR) + 70 CONTINUE + WORK(IMR,IGC,1)=WORK(IMR,IGC,1)+GAR + 80 CONTINUE + ENDIF + 90 CONTINUE + GO TO 165 + ENDIF +*---- +* COMPUTE FISSION ENERGY +*---- + CALL LCMLEN(KPLIB,'NFTOT',ILLCM,ITLCM) + IF(ILLCM.EQ.NGROUP) THEN + IZFISS=IZFISS+1 + EMEVF2(ISO)=RER(2,IDPL) + CALL LCMGET(KPLIB,'NFTOT',SIG) + DO 120 IREG=1,NREGIO + IMR=IMERGE(IREG) + IF((IMR.GT.0).AND.(MATCOD(IREG).EQ.MIX(ISO))) THEN + IGRFIN=0 + DO 110 IGC=1,NGCOND + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGC) + GAR=0.0D0 + DO 100 IGR=IGRDEB,IGRFIN + GAR=GAR+FLUXES(IREG,IGR)*DEN(ISO)*VOLUME(IREG)* + > SIG(IGR) + 100 CONTINUE + WORK(IMR,IGC,1)=WORK(IMR,IGC,1)+GAR*RER(2,IDPL)*CONV + 110 CONTINUE + ENDIF + 120 CONTINUE + ENDIF +*---- +* COMPUTE CAPTURE ENERGY +*---- + CALL LCMLEN(KPLIB,'NG',ILLCM,ITLCM) + IF(ILLCM.EQ.NGROUP) THEN + IZFISS=IZFISS+1 + EMEVG2(ISO)=RER(3,IDPL) + CALL LCMGET(KPLIB,'NG',SIG) + DO 150 IREG=1,NREGIO + IMR=IMERGE(IREG) + IF((IMR.GT.0).AND.(MATCOD(IREG).EQ.MIX(ISO))) THEN + IGRFIN=0 + DO 140 IGC=1,NGCOND + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGC) + GAR=0.0D0 + DO 130 IGR=IGRDEB,IGRFIN + GAR=GAR+FLUXES(IREG,IGR)*DEN(ISO)*VOLUME(IREG)* + > SIG(IGR) + 130 CONTINUE + WORK(IMR,IGC,2)=WORK(IMR,IGC,2)+GAR*RER(3,IDPL)*CONV + 140 CONTINUE + ENDIF + 150 CONTINUE + ENDIF + 160 CONTINUE +*---- +* Normalize total power to 1 W +* Print fission, capture and total power density +*---- + 165 TOTPOW=0.0D0 + DO IGC=1,NGCOND + DO IMR=1,NMERGE + WORK(IMR,IGC,3)=WORK(IMR,IGC,1)+WORK(IMR,IGC,2) + TOTPOW=TOTPOW+WORK(IMR,IGC,3)*XDRCST('eV','J') + ENDDO + ENDDO + IF(TOTPOW.GT.0.0D0) THEN + IF(ABS(IPRINT).GE.2) THEN + WRITE(IUNOUT,6000) + DO IMR=1,NMERGE + POWF=0.0D0 + POWC=0.0D0 + POWT=0.0D0 + DO IGC=1,NGCOND + POWF=POWF+WORK(IMR,IGC,1) + POWC=POWC+WORK(IMR,IGC,2) + POWT=POWT+WORK(IMR,IGC,3) + ENDDO + IF(VOLME(IMR).NE.0.0) THEN + POWF=POWF/(TOTPOW*VOLME(IMR)) + POWC=POWC/(TOTPOW*VOLME(IMR)) + POWT=POWT/(TOTPOW*VOLME(IMR)) + WRITE(IUNOUT,6001) IMR,VOLME(IMR),POWF,POWC,POWT + ENDIF + ENDDO + ENDIF + ENDIF +*---- +* COMPUTE THE HOMOGENIZED/CONDENSED FLUX +*---- + IF(IZFISS.NE.0) THEN + DO 190 IREG=1,NREGIO + IMR=IMERGE(IREG) + IF(IMR.GT.0) THEN + IGRFIN=0 + DO 180 IGC=1,NGCOND + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGC) + GAR=0.0D0 + DO 170 IGR=IGRDEB,IGRFIN + GAR=GAR+FLUXES(IREG,IGR)*VOLUME(IREG) + 170 CONTINUE + FLXMER(IMR,IGC)=FLXMER(IMR,IGC)+GAR + 180 CONTINUE + ENDIF + 190 CONTINUE + DO 210 IGC=1,NGCOND + DO 200 IMR=1,NMERGE + IF(FLXMER(IMR,IGC).GT.0.0) THEN + WORK(IMR,IGC,3)=WORK(IMR,IGC,3)/FLXMER(IMR,IGC) + ENDIF + 200 CONTINUE + 210 CONTINUE + ENDIF +*---- +* SAVE ON LCM +*---- + CALL LCMSIX(IPEDIT,'MACROLIB',1) + JPEDIT=LCMLID(IPEDIT,'GROUP',NGCOND) + DO 230 IGC=1,NGCOND + DO 220 IMR=1,NMERGE + HFACT(IMR)=REAL(WORK(IMR,IGC,3)) + 220 CONTINUE + KPEDIT=LCMDIL(JPEDIT,IGC) + CALL LCMPUT(KPEDIT,'H-FACTOR',NMERGE,2,HFACT) + 230 CONTINUE + CALL LCMSIX(IPEDIT,' ',2) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(WORK,FLXMER) + DEALLOCATE(HFACT,SIG) + DEALLOCATE(INDX) + RETURN +*---- +* FORMAT +*---- + 6000 FORMAT(/' EDIHFC: POWER DENSITY (W/cc) NORMALIZED TO 1 W TOTAL ', + > 'POWER '/' REGION',6X,'VOLUME',7X,'FISSION',7X,'CAPTURE',9X, + > 'TOTAL') + 6001 FORMAT(1X,I4,1P,4E14.5) + END diff --git a/Dragon/src/EDIHFD.f b/Dragon/src/EDIHFD.f new file mode 100644 index 0000000..eb29d91 --- /dev/null +++ b/Dragon/src/EDIHFD.f @@ -0,0 +1,233 @@ +*DECK EDIHFD + SUBROUTINE EDIHFD(IPRINT,NGROUP,NGCOND,NREGIO,NMERGE,NBISO,NDEPL, + > NDFI,NDFP,NREAC,MATCOD,VOLUME,INADPL,ISONAM, + > ISONRF,IPISO,MIX,FLUXES,DEN,IDEPL,IGCOND,IMERGE, + > KDRI,RRD,FIYI,DECAY,YIELD,FIPI,FIFP,PYIELD) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover depletion information from the reference internal library. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPRINT print index. +* NGROUP number of groups. +* NGCOND number of condensed groups. +* NREGIO number of regions. +* NMERGE number of merged regions. +* NBISO number of isotopes in the microlib. +* NDEPL number of depleting isotopes. +* NDFI number of direct fissile isotopes. +* NDFP number of direct fission products. +* NREAC number of depletion reactions. +* MATCOD material per region. +* VOLUME volume of region. +* INADPL name of depleting isotopes. +* ISONAM isotopes names. +* ISONRF library name of isotopes. +* IPISO pointer array towards microlib isotopes. +* MIX mixture associated with isotopes. +* FLUXES multigroup fluxes. +* DEN isotope density. +* IDEPL non depleting flag (=1 to stop depletion). +* IGCOND limits of condensed groups. +* IMERGE index of merged region. +* KDRI depletion identifiers. +* RRD radioactive decay constants. +* FIYI fission yields. +* +*Parameters: output +* DECAY radioactive decay constants for saves isotopes. +* YIELD condensed fission product yield (group ordered). +* FIPI fissile isotope index assigned to each microlib isotope. +* FIFP fission product index assigned to each microlib isotope. +* PYIELD condensed fission product yield (fissile isotope ordered). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPISO(NBISO) + INTEGER IPRINT,NGROUP,NGCOND,NREGIO,NMERGE,NBISO,NDEPL, + > NDFI,NDFP,NREAC,MATCOD(NREGIO),INADPL(3,NDEPL), + > ISONAM(3,NBISO),ISONRF(3,NBISO),MIX(NBISO), + > IDEPL(NBISO),IGCOND(NGCOND),IMERGE(NREGIO), + > KDRI(NREAC,NDEPL),FIPI(NBISO,NMERGE), + > FIFP(NBISO,NMERGE) + REAL VOLUME(NREGIO),FLUXES(NREGIO,NGROUP),DEN(NBISO), + > RRD(NDEPL),FIYI(NDFI,NDFP),DECAY(NBISO), + > YIELD(NGCOND+1,NDFP,NMERGE),PYIELD(NDFI,NDFP,NMERGE) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) KPLIB + INTEGER IGAR(3) + CHARACTER HNISOR*12,TEXT12*12,HSMG*131 + LOGICAL L1,L2 + DOUBLE PRECISION GAR +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: INDX + REAL, ALLOCATABLE, DIMENSION(:) :: SIG + REAL, ALLOCATABLE, DIMENSION(:,:) :: FIRA + CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: HDFI,HDFP +*---- +* SCRATCH STORAGE ALLOCATION +* SIG fission cross sections. +* FIRA fission rates. +* INDX depleting isotope index. +*---- + ALLOCATE(INDX(NBISO)) + ALLOCATE(SIG(NGROUP),FIRA(NGCOND+1,NMERGE)) +*---- +* COMPUTE THE DEPLETING ISOTOPE INDEX +*---- + DO 20 ISO=1,NBISO + IF(IDEPL(ISO).NE.1) THEN + WRITE(HNISOR,'(3A4)') (ISONRF(I0,ISO),I0=1,3) + I1=INDEX(HNISOR,'_') + IF(I1.EQ.0) THEN + TEXT12=HNISOR + ELSE + TEXT12=HNISOR(:I1-1) + ENDIF + READ(TEXT12,'(3A4)') (IGAR(I0),I0=1,3) + DO 10 IDP=1,NDEPL + L1=((ISONRF(1,ISO).EQ.INADPL(1,IDP)).AND. + 1 (ISONRF(2,ISO).EQ.INADPL(2,IDP)).AND. + 2 (ISONRF(3,ISO).EQ.INADPL(3,IDP))) + L2=((IGAR(1).EQ.INADPL(1,IDP)).AND. + 1 (IGAR(2).EQ.INADPL(2,IDP)).AND. + 2 (IGAR(3).EQ.INADPL(3,IDP))) + IF(L1.OR.L2) THEN + INDX(ISO)=IDP + GO TO 20 + ENDIF + 10 CONTINUE + ENDIF + INDX(ISO)=0 + 20 CONTINUE +*---- +* MAIN ISOTOPIC LOOP +*---- + FIPI(:NBISO,:NMERGE)=0 + FIFP(:NBISO,:NMERGE)=0 + PYIELD(:NDFI,:NDFP,:NMERGE)=0.0 + YIELD(:NGCOND+1,:NDFP,:NMERGE)=0.0 + FIRA(:NGCOND+1,:NMERGE)=0.0 + DO 100 ISO=1,NBISO + IDPL=INDX(ISO) + IF(IDPL.EQ.0) GO TO 100 + KPLIB=IPISO(ISO) ! set ISO-th isotope + IF(.NOT.C_ASSOCIATED(KPLIB)) THEN + WRITE(HSMG,'(17HEDIHFD: ISOTOPE '',3A4,16H'' IS NOT AVAILAB, + > 19HLE IN THE MICROLIB.)') (ISONAM(I0,ISO),I0=1,3) + CALL XABORT(HSMG) + ENDIF +*---- +* SET RADIOACTIVE DECAY CONSTANT +*---- + DECAY(ISO)=RRD(IDPL) +*---- +* COMPUTE CONDENSED FISSION RATES. +*---- + IF(MOD(KDRI(2,IDPL),100).EQ.4) THEN + IFI=KDRI(2,IDPL)/100 + CALL LCMGET(KPLIB,'NUSIGF',SIG) + DO 90 IREG=1,NREGIO + IMR=IMERGE(IREG) + IF((IMR.GT.0).AND.(MATCOD(IREG).EQ.MIX(ISO))) THEN + FIPI(ISO,IMR)=IFI + IGRFIN=0 + DO 80 IGC=1,NGCOND + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGC) + GAR=0.0D0 + DO 60 IGR=IGRDEB,IGRFIN + GAR=GAR+FLUXES(IREG,IGR)*DEN(ISO)*VOLUME(IREG)* + > SIG(IGR) + 60 CONTINUE + DO 70 JSO=1,NBISO + JDPL=INDX(JSO) + IF(JDPL.EQ.0) GO TO 70 + IF(MOD(KDRI(2,JDPL),100).EQ.5) THEN + ISOFP=KDRI(2,JDPL)/100 + IF(ISOFP.EQ.0) CALL XABORT('EDIHFD: ISOFP.EQ.0.') + IF(ISOFP.GT.NDFP) CALL XABORT('EDIHFD: YIELD OVERF' + > //'LOW.') + FIFP(JSO,IMR)=ISOFP + DELTA=REAL(GAR)*FIYI(IFI,ISOFP) + YIELD(1,ISOFP,IMR)=YIELD(1,ISOFP,IMR)+DELTA + YIELD(IGC+1,ISOFP,IMR)=YIELD(IGC+1,ISOFP,IMR)+DELTA + PYIELD(IFI,ISOFP,IMR)=FIYI(IFI,ISOFP) + ENDIF + 70 CONTINUE + FIRA(1,IMR)=FIRA(1,IMR)+REAL(GAR) + FIRA(IGC+1,IMR)=FIRA(IGC+1,IMR)+REAL(GAR) + 80 CONTINUE + ENDIF + 90 CONTINUE + ENDIF + 100 CONTINUE + IF(IPRINT.GT.2) THEN + ALLOCATE(HDFI(NDFI),HDFP(NDFP)) + HDFI(:NDFI)=' ' + HDFP(:NDFP)=' ' + DO IFI=1,NDFI + DO ISO=1,NBISO + IF(FIPI(ISO,IMR).EQ.IFI) THEN + WRITE(HDFI(IFI),'(3A4)') ISONRF(:3,ISO) + EXIT + ENDIF + ENDDO + ENDDO + DO ISOFP=1,NDFP + DO ISO=1,NBISO + IF(FIFP(ISO,IMR).EQ.ISOFP) THEN + WRITE(HDFP(ISOFP),'(3A4)') ISONRF(:3,ISO) + EXIT + ENDIF + ENDDO + ENDDO + DO IMR=1,NMERGE + WRITE(6,'(41H EDIHFD: FISSION YIELDS IN MERGED MIXTURE,I5, + > 1H:/1X,12HFISSILE-----,3X,16HYIELDS----------)') IMR + WRITE(6,'(16X,10A13)') HDFP(:NDFP) + DO IFI=1,NDFI + WRITE(6,'(1X,A13,1P,10E13.4/(14X,10E13.4))') HDFI(IFI), + > (PYIELD(IFI,ISOFP,IMR),ISOFP=1,NDFP) + ENDDO + ENDDO + DEALLOCATE(HDFP,HDFI) + ENDIF +*---- +* COMPUTE THE YIELDS +*---- + DO 130 IMR=1,NMERGE + DO 120 IGC=1,NGCOND+1 + IF(FIRA(IGC,IMR).NE.0.0) THEN + DO 110 ISOFP=1,NDFP + YIELD(IGC,ISOFP,IMR)=YIELD(IGC,ISOFP,IMR)/FIRA(IGC,IMR) + 110 CONTINUE + ENDIF + 120 CONTINUE + 130 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(FIRA,SIG) + DEALLOCATE(INDX) + RETURN + END diff --git a/Dragon/src/EDIHMX.f b/Dragon/src/EDIHMX.f new file mode 100644 index 0000000..4685b6c --- /dev/null +++ b/Dragon/src/EDIHMX.f @@ -0,0 +1,77 @@ +*DECK EDIHMX + SUBROUTINE EDIHMX(IPTRK,NREGIO,NMERGE,IMERGE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find merge vector for merge by HMIX. +* +*Copyright: +* Copyright (C) 2001 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPTRK calculation tracking data structure. +* NREGIO number of regions. +* +*Parameters: output +* NMERGE final number of merged regions. +* IMERGE merged region positions. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE + INTEGER IOUT,NSTATE + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NSTATE=40,NAMSBR='EDIHMX') +*---- +* ROUTINE PARAMETERS +*---- + TYPE(C_PTR) IPTRK + INTEGER NREGIO + INTEGER NMERGE + INTEGER IMERGE(NREGIO) +*---- +* LOCAL PARAMETERS +*---- + INTEGER IMRGLN,IMRGTY,IREG + INTEGER ISTATE(NSTATE) +*---- +* IMERGE is HOMMATCOD or MATCOD +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + CALL LCMLEN(IPTRK,'HOMMATCOD ',IMRGLN,IMRGTY) + IF(IMRGLN .EQ. 0) THEN + WRITE(IOUT,8000) NAMSBR + CALL LCMGET(IPTRK,'MATCOD ',IMERGE) + ELSE + CALL LCMGET(IPTRK,'HOMMATCOD ',IMERGE) + ENDIF +*---- +* Check for double heterogeneity +*---- + IF(ISTATE(40).EQ.1) THEN + CALL EDIBHX (NREGIO,IPTRK,IMRGLN,IMERGE) + ENDIF + IF(IMRGLN.NE.NREGIO) CALL XABORT('EDIHMX: bad nb of regions') +*---- +* Compute number of merged regions +*---- + NMERGE=0 + DO IREG=1,NREGIO + NMERGE=MAX(NMERGE,IMERGE(IREG)) + ENDDO + RETURN +*---- +* WARNING FORMAT +*---- + 8000 FORMAT('***** Warning in routine - ',A6,' - *****'/ + >'No HMIX data in GEO: for NXT tracking file'/ + >'Homogenize using MIX instead of HMIX') + END diff --git a/Dragon/src/EDIJO1.f b/Dragon/src/EDIJO1.f new file mode 100644 index 0000000..f941c9d --- /dev/null +++ b/Dragon/src/EDIJO1.f @@ -0,0 +1,172 @@ +*DECK EDIJO1 + SUBROUTINE EDIJO1(IPMAC2,IPTRK1,IPFLUX,IPRINT,NGCOND,IGCOND) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover ALBS information from last component of unknown array for use +* with SPH equivalence techniques. SYBILF compatible version. SYBILF is +* activated with ARM keyword in ASM: module. +* +*Copyright: +* Copyright (C) 2015 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMAC2 pointer to condensed macrolib information (L_MACROLIB +* signature) built by EDI:. +* IPTRK1 pointer to the reference tracking object. +* IPFLUX pointer to the reference solution (L_FLUX signature). +* IPRINT print index. +* NGCOND number of condensed groups. +* IGCOND limit of condensed groups. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMAC2,IPTRK1,IPFLUX + INTEGER IPRINT,NGCOND,IGCOND(NGCOND) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + TYPE(C_PTR) JPFLUX + INTEGER ISTATE(NSTATE),IPAR(16) + CHARACTER CDOOR*12 +*---- +* ALLOCATABLE ARRAYS +*---- + TYPE(C_PTR) IFR_PTR,ALB_PTR,SUR_PTR,INUM_PTR,MIX_PTR + INTEGER, POINTER, DIMENSION(:) :: IFR,INUM,MIX + REAL, POINTER, DIMENSION(:) :: ALB,SUR + REAL, ALLOCATABLE, DIMENSION(:) :: WORKD + REAL, ALLOCATABLE, DIMENSION(:,:) :: OUTG +*---- +* RECOVER FLUX OBJECT INFORMATION +*---- + CALL LCMGET(IPFLUX,'STATE-VECTOR',ISTATE) + NUNKNO=ISTATE(2) + ILEAK=ISTATE(7) +*---- +* RECOVER TRACKING INFORMATION +*---- + CALL LCMGTC(IPTRK1,'TRACK-TYPE',12,CDOOR) + IF(CDOOR.NE.'SYBIL') CALL XABORT('EDIJO1: SYBIL TRACKING EXPECTE' + > //'D.') + CALL LCMGET(IPTRK1,'STATE-VECTOR',ISTATE) + NREG=ISTATE(1) + ITG=ISTATE(6) + IF(ITG.NE.4) CALL XABORT('EDIJO1: JOUT OPTION FORBIDDEN.') + NUNKNO=ISTATE(2)+ISTATE(9) + CALL LCMSIX(IPTRK1,'EURYDICE',1) + CALL LCMGET(IPTRK1,'PARAM',IPAR) + IHEX=IPAR(1) + MULTC=IPAR(2) + NMCEL=IPAR(4) + NMERGE=IPAR(5) + NCOUR=4 + IF(IHEX.NE.0) NCOUR=6 + IF(MULTC.EQ.4) NCOUR=3*NCOUR + CALL LCMGPD(IPTRK1,'IFR',IFR_PTR) + CALL LCMGPD(IPTRK1,'ALB',ALB_PTR) + CALL LCMGPD(IPTRK1,'SUR',SUR_PTR) + CALL LCMGPD(IPTRK1,'INUM',INUM_PTR) + CALL LCMGPD(IPTRK1,'MIX',MIX_PTR) + CALL LCMSIX(IPTRK1,' ',2) +* + CALL C_F_POINTER(IFR_PTR,IFR,(/ NCOUR*NMCEL /)) + CALL C_F_POINTER(ALB_PTR,ALB,(/ NCOUR*NMCEL /)) + CALL C_F_POINTER(SUR_PTR,SUR,(/ NCOUR*NMCEL /)) + CALL C_F_POINTER(INUM_PTR,INUM,(/ NMCEL /)) + CALL C_F_POINTER(MIX_PTR,MIX,(/ NCOUR*NMERGE /)) +*---- +* COMPUTE THE OUTGOING CURRENT +*---- + ALLOCATE(OUTG(NGCOND,2)) + IGRFIN=0 + CALL LCMSIX(IPMAC2,'ADF',1) + DO 70 IGRCD=1,NGCOND + OUTG(IGRCD,:2)=0.0 + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGRCD) + CALL LCMLEN(IPFLUX,'FLUX',ILON,ITYLCM) + IF(ILON.EQ.0) CALL XABORT('EDIJO1: MISSING FLUX INFO(1).') + JPFLUX=LCMGID(IPFLUX,'FLUX') + DO 60 IGR=IGRDEB,IGRFIN + CALL LCMLEL(JPFLUX,IGR,ILCMLN,ITYLCM) + IF(ILCMLN.EQ.0) CALL XABORT('EDIJO1: MISSING FLUX INFO(2).') + IF(ILEAK.LE.5) THEN + IF(ILCMLN.NE.NUNKNO) CALL XABORT('EDIJO1: ARM KEYWORD MUST B' + 1 //'E SET IN ASM: MODULE(1).') + ALLOCATE(WORKD(NUNKNO)) + ELSE IF(ILEAK.EQ.6) THEN + IF(ILCMLN.NE.2*NUNKNO) CALL XABORT('EDIJO1: ARM KEYWORD MUST' + 1 //' BE SET IN ASM: MODULE(2).') + ALLOCATE(WORKD(2*NUNKNO)) + ELSE + CALL XABORT('EDIJO1: INVALID TYPE OF LEAKAGE.') + ENDIF + CALL LCMGDL(JPFLUX,IGR,WORKD) + OUTC1=0.0 + OUTC2=0.0 + SURT=0.0 + IF(MULTC.EQ.1) THEN + DO 20 ICEL=1,NMCEL + IKK=INUM(ICEL) + IF(IKK.EQ.0) GO TO 20 + IT0=NCOUR*(ICEL-1) + DO 10 JC=1,NCOUR + IF((IKK.EQ.IFR(IT0+JC)).AND.(SUR(IT0+JC).NE.0.0)) THEN + J1=IFR(IT0+JC) + OUTC1=OUTC1+WORKD(NREG+J1)*SUR(IT0+JC) + OUTC2=OUTC2+WORKD(NREG+J1)*SUR(IT0+JC)*ALB(IT0+JC) + SURT=SURT+SUR(IT0+JC) + ENDIF + 10 CONTINUE + 20 CONTINUE + ELSE + ISTR=1 + IF((NCOUR.EQ.12).OR.(NCOUR.EQ.18)) ISTR=3 + DO 50 ICEL=1,NMCEL + IKK=INUM(ICEL) + IF(IKK.EQ.0) GO TO 50 + IT0=NCOUR*(ICEL-1) + IT1=NCOUR*(IKK-1) + DO 40 JC=1,NCOUR,ISTR + IF((MIX(IT1+JC).EQ.IFR(IT0+JC)).AND.(SUR(IT0+JC).NE.0.0)) THEN + J1=IFR(IT0+JC) + OUTC1=OUTC1+WORKD(NREG+J1)*SUR(IT0+JC) + OUTC2=OUTC2+WORKD(NREG+J1)*SUR(IT0+JC)*ALB(IT0+JC) + SURT=SURT+SUR(IT0+JC) + ENDIF + 40 CONTINUE + 50 CONTINUE + ENDIF + OUTG(IGRCD,1)=OUTG(IGRCD,1)+OUTC1/SURT + OUTG(IGRCD,2)=OUTG(IGRCD,2)+OUTC2/SURT + DEALLOCATE(WORKD) + 60 CONTINUE + 70 CONTINUE + CALL LCMPUT(IPMAC2,'ALBS00',NGCOND*2,2,OUTG) + IF(IPRINT.GT.3) THEN + WRITE(6,900) (OUTG(IGR,1),IGR=1,NGCOND) + WRITE(6,910) (OUTG(IGR,2),IGR=1,NGCOND) + WRITE(6,'(/)') + ENDIF + CALL LCMSIX(IPMAC2,' ',2) + DEALLOCATE(OUTG) + RETURN +* + 900 FORMAT(/49H EDIJO1: OUT-CURRENTS (4J-/S) PER MACRO-GROUP ARE/ + > (1X,1P,10E13.5)) + 910 FORMAT(/49H EDIJO1: IN-CURRENTS (4J+/S) PER MACRO-GROUP ARE/ + > (1X,1P,10E13.5)) + END diff --git a/Dragon/src/EDIJO2.f b/Dragon/src/EDIJO2.f new file mode 100644 index 0000000..81b52da --- /dev/null +++ b/Dragon/src/EDIJO2.f @@ -0,0 +1,113 @@ +*DECK EDIJO2 + SUBROUTINE EDIJO2(IPMAC2,IPTRK1,IPFLUX,IPRINT,NGCOND,IGCOND) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover ALBS information from last component of unknown array for use +* with SPH equivalence techniques. MCCG compatible version. +* +*Copyright: +* Copyright (C) 2019 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMAC2 pointer to condensed macrolib information (L_MACROLIB +* signature) built by EDI:. +* IPTRK1 pointer to the reference tracking object. +* IPFLUX pointer to the reference solution (L_FLUX signature). +* IPRINT print index. +* NGCOND number of condensed groups. +* IGCOND limit of condensed groups. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMAC2,IPTRK1,IPFLUX + INTEGER IPRINT,NGCOND,IGCOND(NGCOND) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + TYPE(C_PTR) JPFLUX + INTEGER ISTATE(NSTATE) + REAL ALBEDO(6) + CHARACTER CDOOR*12 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NZON,KEYSUR + REAL, ALLOCATABLE, DIMENSION(:) :: WORKD,VOLSUR + REAL, ALLOCATABLE, DIMENSION(:,:) :: OUTG +*---- +* RECOVER FLUX OBJECT INFORMATION +*---- + CALL LCMGET(IPFLUX,'STATE-VECTOR',ISTATE) + NUNKNO=ISTATE(2) +*---- +* RECOVER TRACKING INFORMATION +*---- + CALL LCMGTC(IPTRK1,'TRACK-TYPE',12,CDOOR) + CALL LCMGET(IPTRK1,'STATE-VECTOR',ISTATE) + IF(CDOOR.NE.'MCCG') CALL XABORT('EDIJO2: MCCG TRACKING EXPECTED.') + NBVOL=ISTATE(1) + NBSUR=ISTATE(5) + IF(NBSUR.EQ.0) CALL XABORT('EDIJO2: NO BOUNDARY LEAKAGE.') + ALLOCATE(VOLSUR(NBVOL+NBSUR),NZON(NBVOL+NBSUR),KEYSUR(NBSUR)) + CALL LCMGET(IPTRK1,'V$MCCG',VOLSUR) + CALL LCMGET(IPTRK1,'NZON$MCCG',NZON) + CALL LCMGET(IPTRK1,'KEYCUR$MCCG',KEYSUR) + CALL LCMGET(IPTRK1,'ALBEDO',ALBEDO) +*---- +* COMPUTE THE OUTGOING CURRENT +*---- + ALLOCATE(OUTG(NGCOND,2)) + IGRFIN=0 + CALL LCMSIX(IPMAC2,'ADF',1) + ALLOCATE(WORKD(NUNKNO)) + DO 30 IGRCD=1,NGCOND + OUTG(IGRCD,:2)=0.0 + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGRCD) + CALL LCMLEN(IPFLUX,'FLUX',ILON,ITYLCM) + IF(ILON.EQ.0) CALL XABORT('EDIJO2: MISSING FLUX INFO(1).') + JPFLUX=LCMGID(IPFLUX,'FLUX') + DO 20 IGR=IGRDEB,IGRFIN + CALL LCMLEL(JPFLUX,IGR,ILONG,ITYLCM) + IF(ILONG.NE.NUNKNO) CALL XABORT('EDIJO2: MISSING FLUX INFO(2).') + CALL LCMGDL(JPFLUX,IGR,WORKD) + DO 10 IS=1,NBSUR + IUN=KEYSUR(IS) + IF(IUN.EQ.0) GO TO 10 + IAL=-NZON(NBVOL+IS) + OUTG(IGRCD,1)=OUTG(IGRCD,1)+WORKD(IUN)*VOLSUR(NBVOL+IS) + OUTG(IGRCD,2)=OUTG(IGRCD,2)+WORKD(IUN)*VOLSUR(NBVOL+IS)* + > ALBEDO(IAL) + 10 CONTINUE + 20 CONTINUE + 30 CONTINUE + DEALLOCATE(WORKD) + CALL LCMPUT(IPMAC2,'ALBS00',NGCOND*2,2,OUTG) + IF(IPRINT.GT.3) THEN + WRITE(6,900) (OUTG(IGR,1),IGR=1,NGCOND) + WRITE(6,910) (OUTG(IGR,2),IGR=1,NGCOND) + WRITE(6,'(/)') + ENDIF + CALL LCMSIX(IPMAC2,' ',2) + DEALLOCATE(KEYSUR,NZON,VOLSUR) + DEALLOCATE(OUTG) + RETURN +* + 900 FORMAT(/49H EDIJO2: OUT-CURRENTS (4J-/S) PER MACRO-GROUP ARE/ + > (1X,1P,10E13.5)) + 910 FORMAT(/49H EDIJO2: IN-CURRENTS (4J+/S) PER MACRO-GROUP ARE/ + > (1X,1P,10E13.5)) + END diff --git a/Dragon/src/EDIJO3.f b/Dragon/src/EDIJO3.f new file mode 100644 index 0000000..d5faa8c --- /dev/null +++ b/Dragon/src/EDIJO3.f @@ -0,0 +1,160 @@ +*DECK EDIJO3 + SUBROUTINE EDIJO3(IPMAC2,IPTRK1,IPFLUX,IPRINT,NGCOND,IGCOND) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover ALBS information from last component of unknown array for use +* with SPH equivalence techniques. Multicell surfacic compatible +* version. It is activated with ARM keyword in ASM: module. +* +*Copyright: +* Copyright (C) 2025 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMAC2 pointer to condensed macrolib information (L_MACROLIB +* signature) built by EDI:. +* IPTRK1 pointer to the reference tracking object. +* IPFLUX pointer to the reference solution (L_FLUX signature). +* IPRINT print index. +* NGCOND number of condensed groups. +* IGCOND limit of condensed groups. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMAC2,IPTRK1,IPFLUX + INTEGER IPRINT,NGCOND,IGCOND(NGCOND) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + TYPE(C_PTR) JPFLUX + INTEGER ISTATE(NSTATE) + CHARACTER CDOOR*12 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NMC_SURF,IFR,MIX,INUM,IGEN + REAL, ALLOCATABLE, DIMENSION(:) :: ALB,SUR,WORKD + REAL, ALLOCATABLE, DIMENSION(:,:) :: OUTG +*---- +* RECOVER FLUX OBJECT INFORMATION +*---- + CALL LCMGET(IPFLUX,'STATE-VECTOR',ISTATE) + NUNKNO=ISTATE(2) + ILEAK=ISTATE(7) +*---- +* RECOVER TRACKING INFORMATION +*---- + CALL LCMGTC(IPTRK1,'TRACK-TYPE',12,CDOOR) + CALL LCMGET(IPTRK1,'STATE-VECTOR',ISTATE) + IF((CDOOR.NE.'EXCELL').OR.(ISTATE(7).NE.5)) THEN + CALL XABORT('EDIJO3: MULTICELL SURFACIC OPTION NOT ACTIVATED.') + ENDIF + NREG=ISTATE(1) + NUNKNO=ISTATE(2)+ISTATE(28) + NMACRO=ISTATE(24) + IF(NMACRO.EQ.0) CALL XABORT('EDIJO3: NO MACRO GEOMETRIES.') + NMCEL=NMACRO + NMERGE=NMACRO + ALLOCATE(IGEN(NMERGE),INUM(NMCEL),NMC_SURF(NMACRO+1)) + DO IK=1,NMERGE + IGEN(IK)=IK + ENDDO + DO IK=1,NMCEL + INUM(IK)=IK + ENDDO + IF(NMACRO.EQ.0) CALL XABORT('EDIJO3: MACRO OPTION IS MANDATORY.') + CALL LCMGET(IPTRK1,'NMC_SURF',NMC_SURF) + NMIX=NMC_SURF(NMACRO+1) + NIFR=NMC_SURF(NMACRO+1) + ALLOCATE(IFR(NIFR),ALB(NIFR),MIX(NMIX),SUR(NMIX)) + CALL LCMGET(IPTRK1,'IFR',IFR) + CALL LCMGET(IPTRK1,'ALB',ALB) + CALL LCMGET(IPTRK1,'MIX',MIX) + CALL LCMGET(IPTRK1,'SUR',SUR) +*---- +* COMPUTE THE OUTGOING CURRENT +*---- + ALLOCATE(OUTG(NGCOND,2)) + IGRFIN=0 + CALL LCMSIX(IPMAC2,'ADF',1) + DO 70 IGRCD=1,NGCOND + OUTG(IGRCD,:2)=0.0 + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGRCD) + CALL LCMLEN(IPFLUX,'FLUX',ILON,ITYLCM) + IF(ILON.EQ.0) CALL XABORT('EDIJO3: MISSING FLUX INFO(1).') + JPFLUX=LCMGID(IPFLUX,'FLUX') + DO 60 IGR=IGRDEB,IGRFIN + CALL LCMLEL(JPFLUX,IGR,ILCMLN,ITYLCM) + IF(ILCMLN.EQ.0) CALL XABORT('EDIJO3: MISSING FLUX INFO(2).') + IF(ILEAK.LE.5) THEN + IF(ILCMLN.NE.NUNKNO) CALL XABORT('EDIJO3: ARM KEYWORD MUST B' + 1 //'E SET IN ASM: MODULE(1).') + ALLOCATE(WORKD(NUNKNO)) + ELSE IF(ILEAK.EQ.6) THEN + IF(ILCMLN.NE.2*NUNKNO) CALL XABORT('EDIJO3: ARM KEYWORD MUST' + 1 //' BE SET IN ASM: MODULE(2).') + ALLOCATE(WORKD(2*NUNKNO)) + ELSE + CALL XABORT('EDIJO3: INVALID TYPE OF LEAKAGE.') + ENDIF + CALL LCMGDL(JPFLUX,IGR,WORKD) + OUTC1=0.0 + OUTC2=0.0 + SURT=0.0 + DO 50 ICEL=1,NMCEL + IKK=INUM(ICEL) + IKG=IGEN(IKK) + IF(IKK.EQ.0) GO TO 50 + J3=NMC_SURF(IKG+1)-NMC_SURF(IKG) + IT=0 + DO IK=1,IKK-1 + IT=IT+(NMC_SURF(IGEN(IK)+1)-NMC_SURF(IGEN(IK))) + ENDDO + IS=0 + DO IK=1,ICEL-1 + IS=IS+(NMC_SURF(IGEN(INUM(IK))+1)-NMC_SURF(IGEN(INUM(IK)))) + ENDDO + DO 40 JC=1,J3 + IF((MIX(IT+JC).EQ.IFR(IS+JC)).AND.(SUR(IS).NE.0.0)) THEN + J1=IFR(IS+JC) + OUTC1=OUTC1+WORKD(NREG+J1)*SUR(IS+JC) + OUTC2=OUTC2+WORKD(NREG+J1)*SUR(IS+JC)*ALB(IS+JC) + SURT=SURT+SUR(IS+JC) + ENDIF + 40 CONTINUE + 50 CONTINUE + DEALLOCATE(NMC_SURF,INUM,IGEN) + DEALLOCATE(SUR,MIX,ALB,IFR) + OUTG(IGRCD,1)=OUTG(IGRCD,1)+OUTC1/SURT + OUTG(IGRCD,2)=OUTG(IGRCD,2)+OUTC2/SURT + DEALLOCATE(WORKD) + 60 CONTINUE + 70 CONTINUE + CALL LCMPUT(IPMAC2,'ALBS00',NGCOND*2,2,OUTG) + IF(IPRINT.GT.3) THEN + WRITE(6,900) (OUTG(IGR,1),IGR=1,NGCOND) + WRITE(6,910) (OUTG(IGR,2),IGR=1,NGCOND) + WRITE(6,'(/)') + ENDIF + CALL LCMSIX(IPMAC2,' ',2) + DEALLOCATE(OUTG) + RETURN +* + 900 FORMAT(/49H EDIJO3: OUT-CURRENTS (4J-/S) PER MACRO-GROUP ARE/ + > (1X,1P,10E13.5)) + 910 FORMAT(/49H EDIJO3: IN-CURRENTS (4J+/S) PER MACRO-GROUP ARE/ + > (1X,1P,10E13.5)) + END diff --git a/Dragon/src/EDILUM.f b/Dragon/src/EDILUM.f new file mode 100644 index 0000000..bbf8c36 --- /dev/null +++ b/Dragon/src/EDILUM.f @@ -0,0 +1,433 @@ +*DECK EDILUM + SUBROUTINE EDILUM(IPRINT,IPEDIT,MAXFP,NBISO,NBFISS,NBDPF,NSUPS, + & NREAC,NFATH,NBCH,HICH,HISO,MYLIST,HREAC,IDREAC,DENER,DDECA, + & IPREAC,PRATE,YIELD,LISO,NBFISS2,NBFPCH2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Complete and lump the burnup chain from NBISO to NBCH isotopes. +* Write the lumped chain on the LCM object. Based on subroutine +* dralum.f in dragr module. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPRINT print parameter. +* IPEDIT pointer to the edition LCM object. +* MAXFP second dimension of array 'YIELD'. +* NBISO number of depleting nuclides before lumping. +* NBFISS number of fissile isotopes with fission yields. +* NBDPF number of fission products before lumping. +* NSUPS number of stable isotopes producing energy. +* NREAC number of depleting reactions including radioactive decay +* NFATH maximum number of parent isotopes leading to the production of +* an isotope in the depletion chain before lumping. +* NBCH number of depleting nuclides after lumping. +* HICH names of remaining isotopes after lumping. +* HISO 'ISOTOPESDEPL' record before lumping. +* MYLIST 'CHARGEWEIGHT' record before lumping. +* HREAC 'DEPLETE-IDEN' record before lumping. +* IDREAC 'DEPLETE-REAC' record before lumping. +* DENER 'DEPLETE-ENER' record before lumping. +* DDECA 'DEPLETE-DECA' record before lumping. +* IPREAC 'PRODUCE-REAC' record before lumping. +* PRATE 'PRODUCE-RATE' record before lumping. +* YIELD 'FISSIONYIELD' record before lumping. +* LISO =.true. when all isotopes are kept separately during +* the merging. +* NBFISS2 new number of fissile isotopes with fission yields. +* NBFPCH2 new maximum number of fission products after lumping. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPEDIT + INTEGER IPRINT,MAXFP,NBISO,NBFISS,NBDPF,NSUPS,NREAC,NFATH, + & MYLIST(NBISO),HICH(3,NBCH),HISO(3,NBISO),NBCH,HREAC(2,NREAC), + & IDREAC(NREAC,NBISO),IPREAC(NFATH,NBISO),NBFISS2,NBFPCH2 + REAL DENER(NREAC,NBISO),DDECA(NBISO),PRATE(NFATH,NBISO), + & YIELD(NBFISS,MAXFP) + LOGICAL LISO +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40,MAXIT=20,NSYSO=6) + CHARACTER HNAME*8,TEXT4*4 + INTEGER ISTATE(NSTATE),MIX(NBCH),IMIX + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: JPREAC,JDREAC,IPOS,HHHH + REAL, ALLOCATABLE, DIMENSION(:) :: EYIEL,DDDD + REAL, ALLOCATABLE, DIMENSION(:,:) :: RRATE,EENER +*---- +* SCRATCH STORAGE ALLOCATION +*---- + PARAMETER (MAXFAT=25) + ALLOCATE(JPREAC(MAXFAT,NBCH),JDREAC(NREAC,NBCH),IPOS(NBCH,3), + & HHHH(3,NBCH)) + ALLOCATE(RRATE(MAXFAT,NBCH),EENER(NREAC,NBCH), + & EYIEL(NBFISS2*NBFPCH2),DDDD(NBCH)) +*---- +* FIND THE POSITION OF THE LUMPED ISOTOPES IN THE COMPLETE CHAIN +*---- + J0OLD=0 + J0=0 + DO ISO=1,NBCH + DO JSO=1,NBISO + J0=JSO + IF((HICH(1,ISO).EQ.HISO(1,JSO)).AND. + & (HICH(2,ISO).EQ.HISO(2,JSO))) GO TO 10 + ENDDO + WRITE(NSYSO,'(/35H EDILUM: LIST OF AVAILABLE ISOTOPES)') + DO JSO=1,NBISO + WRITE(NSYSO,'(2X,I5,5H --> ,2A4)') JSO,HISO(1,JSO),HISO(2,JSO) + ENDDO + WRITE(HNAME,'(2A4)') HICH(1,ISO),HICH(2,ISO) + CALL XABORT('EDILUM: UNABLE TO FIND '//HNAME) + 10 IF(.NOT.LISO) THEN + IF(J0.LE.J0OLD) THEN + WRITE(HNAME,'(2A4)') HISO(1,J0),HISO(2,J0) + CALL XABORT('EDILUM: ISOTOPIC DATA NOT SORTED:'//HNAME) + ENDIF + ENDIF + J0OLD=J0 + IPOS(ISO,1)=J0 + ENDDO + DO I=1,NBCH + IMIX=1 + IF(I.EQ.1) GOTO 15 + DO J=1,I-1 + IF(IPOS(I,1).EQ.IPOS(J,1)) IMIX=IMIX+1 + ENDDO + 15 MIX(I)=IMIX + ENDDO +*---- +* REMOVE THE LUMPED FATHERS THAT ARE NEUTRON INDUCED REACTIONS. +*---- + DO ISO=1,NBISO + DO IFATH=1,NFATH + IF(IPREAC(IFATH,ISO).EQ.0) GO TO 20 + IF(MOD(IPREAC(IFATH,ISO),100).EQ.1) GO TO 20 + JND=IPREAC(IFATH,ISO)/100 + DO J=1,NBCH + IF(IPOS(J,1).EQ.JND) GO TO 20 + ENDDO + IPREAC(IFATH,ISO)=0 + PRATE(IFATH,ISO)=0.0 + 20 CONTINUE + ENDDO + ENDDO +*---- +* LUMP IDREAC, DENER, IPREAC AND PRATE. +*---- + ITER=0 + 40 ITER=ITER+1 + IF(ITER.GT.MAXIT) CALL XABORT('EDILUM: TOO MANY ITERATIONS.') + NLUMP=0 + DO ISO=1,NBCH + IND=IPOS(ISO,1) + DO IFATH=1,NFATH + IF(IPREAC(IFATH,IND).EQ.0) GO TO 50 + IF(MOD(IPREAC(IFATH,IND),100).NE.1) GO TO 50 + JND=IPREAC(IFATH,IND)/100 + IF(MYLIST(JND).EQ.0) GO TO 50 + DO J=1,NBCH + IF(IPOS(J,1).EQ.JND) GO TO 50 + ENDDO + NLUMP=NLUMP+1 ! ISOTOPE JND IS LUMPED + DO IDA=1,NBISO + DO IFA=1,NFATH + IPGAR=IPREAC(IFA,IDA) + IF((IPGAR/100.EQ.JND).AND.(MOD(IPGAR,100).EQ.1)) THEN + IF(MYLIST(IDA).EQ.0) GO TO 50 + ENDIF + ENDDO + ENDDO + DO IDA=1,NBISO + DO IFA=1,NFATH + IPGAR=IPREAC(IFA,IDA) + IF((IPGAR/100.EQ.JND).AND.(MOD(IPGAR,100).EQ.1)) THEN + IF(IDA.EQ.JND) CALL XABORT('EDILUM: BUG.') + PRGAR=PRATE(IFA,IDA) + DO IM=IFA,NFATH-1 + IPREAC(IM,IDA)=IPREAC(IM+1,IDA) + PRATE(IM,IDA)=PRATE(IM+1,IDA) + ENDDO + IPREAC(NFATH,IDA)=0 + PRATE(NFATH,IDA)=0.0 + DO JFATH=1,NFATH + IF(IPREAC(JFATH,JND).EQ.0) GO TO 45 + IM=NFATH+1 + DO K=NFATH,1,-1 + IF(IPREAC(K,IDA).EQ.IPREAC(JFATH,JND)) THEN + PRATE(K,IDA)=PRATE(K,IDA)+PRGAR*PRATE(JFATH,JND) + GO TO 44 + ENDIF + IF(IPREAC(K,IDA).EQ.0) IM=K + ENDDO + IF(IM.GT.NFATH) CALL XABORT('EDILUM: NFATH OVERFLOW.') + IPREAC(IM,IDA)=IPREAC(JFATH,JND) + PRATE(IM,IDA)=PRGAR*PRATE(JFATH,JND) + 44 CONTINUE + ENDDO + 45 IF(MOD(IDREAC(2,JND),100).EQ.5) THEN + JFP=IDREAC(2,JND)/100 + IF(MOD(IDREAC(2,IDA),100).EQ.5) THEN + IFP=IDREAC(2,IDA)/100 + ELSE + NBDPF=NBDPF+1 + IF(NBDPF.GT.MAXFP) THEN + CALL XABORT('EDILUM: MAXFP OVERFLOW.') + ENDIF + IFP=NBDPF + YIELD(:NBFISS,IFP)=0.0 + ENDIF + DO IFI=1,NBFISS + YIELD(IFI,IFP)=YIELD(IFI,IFP)+YIELD(IFI,JFP)*PRGAR + ENDDO + IDREAC(2,IDA)=IFP*100+5 + ENDIF + ENDIF + ENDDO + ENDDO + DO JFATH=1,NFATH + IF(IPREAC(JFATH,JND).GT.0) THEN + KT=MOD(IPREAC(JFATH,JND),100) + KND=IPREAC(JFATH,JND)/100 + DENER(KT,KND)=DENER(KT,KND)+PRATE(JFATH,JND)*DENER(1,JND) + ENDIF + IPREAC(JFATH,JND)=0 + PRATE(JFATH,JND)=0.0 + ENDDO + YMAX=0.0 + IF(MOD(IDREAC(2,JND),100).EQ.5) THEN + JFP=IDREAC(2,JND)/100 + DO KSO=1,NBISO + IF(MOD(IDREAC(2,KSO),100).EQ.4) THEN + IFI=IDREAC(2,KSO)/100 + DENER(2,KSO)=DENER(2,KSO)+YIELD(IFI,JFP)*DENER(1,JND) + ENDIF + ENDDO + DO IFI=1,NBFISS + YMAX=MAX(YMAX,ABS(YIELD(IFI,JFP))) + YIELD(IFI,JFP)=0.0 + ENDDO + DENER(2,JND)=0.0 + IDREAC(2,JND)=0 + ENDIF + DENER(1,JND)=0.0 + IDREAC(1,JND)=0 + HALF=1.0E8*LOG(2.0)/DDECA(JND)/86400.0 + IF(DDECA(JND).EQ.0.0) THEN + WRITE(HNAME,'(2A4)') HISO(1,JND),HISO(2,JND) + IF(YMAX.GT.1.0E-2) THEN + WRITE(NSYSO,6020) TRIM(HNAME),HALF,YMAX*100.0 + CALL XABORT('EDILUM: ISOTOPE '//HNAME//' SHOULD NOT BE L' + & //'UMPED.(1)') + ENDIF + IF(IPRINT.GT.2) WRITE(NSYSO,6020) HNAME,HALF,YMAX*100.0 + ELSE IF((HALF.GT.30.0).AND.(HALF.LT.999999.99)) THEN + WRITE(HNAME,'(2A4)') HISO(1,JND),HISO(2,JND) + IF(YMAX.GT.1.0E-2) THEN + WRITE(NSYSO,6020) TRIM(HNAME),HALF,YMAX*100.0 + CALL XABORT('EDILUM: ISOTOPE '//HNAME//' SHOULD NOT BE L' + & //'UMPED.(2)') + ENDIF + IF(IPRINT.GT.2) WRITE(NSYSO,6020) HNAME,HALF,YMAX*100.0 + ELSE IF(HALF.GT.30.0) THEN + WRITE(HNAME,'(2A4)') HISO(1,JND),HISO(2,JND) + IF(YMAX.GT.1.0E-2) THEN + WRITE(NSYSO,6020) TRIM(HNAME),HALF,YMAX*100.0 + CALL XABORT('EDILUM: ISOTOPE '//HNAME//' SHOULD NOT BE L' + & //'UMPED.(3)') + ENDIF + IF(IPRINT.GT.2) WRITE(NSYSO,6020) HNAME,HALF,YMAX*100.0 + ENDIF + DDECA(JND)=0.0 + MYLIST(JND)=0 + 50 CONTINUE + ENDDO + ENDDO + IF(IPRINT.GT.2) WRITE(NSYSO,'('' ......... NLUMP='',I5)') NLUMP + IF(NLUMP.GT.0) GO TO 40 +*---- +* WRITE VECTORS 'PRODUCE-REAC' AND 'PRODUCE-RATE' TO THE LCM OBJECT +*---- + DO ISO=1,NBCH + DO IFATH=1,MAXFAT + JPREAC(IFATH,ISO)=0 + RRATE(IFATH,ISO)=0.0 + ENDDO + IND=IPOS(ISO,1) + NN=0 + DO IFATH=1,NFATH + IF(IPREAC(IFATH,IND).NE.0) THEN + DO J=1,IFATH-1 + IF(IPREAC(IFATH,IND).EQ.IPREAC(J,IND)) THEN + JND1=IPREAC(IFATH,IND)/100 + JND2=IPREAC(J,IND)/100 + WRITE(NSYSO,'(/27H EDILUM: DUPLICATE FATHERS:,2A4, + & 1X,2A4)') HISO(1,JND1),HISO(2,JND1),HISO(1,JND2), + & HISO(2,JND2) + WRITE(HNAME,'(2A4)') HISO(1,IND),HISO(2,IND) + CALL XABORT('EDILUM: DUPLICATE FATHERS FOR '//HNAME) + ENDIF + ENDDO + DO I=1,NBCH + JSO=I + IF((IPOS(I,1).EQ.IPREAC(IFATH,IND)/100).AND. + & (MIX(I).EQ.MIX(ISO)))GO TO 70 + ENDDO + JSO=-1 + 70 IF(JSO.EQ.-1) THEN + JND=IPREAC(IFATH,IND)/100 + IF(IPRINT.GT.2) THEN + WRITE(NSYSO,'(/24H EDILUM: UNKNOWN FATHER ,2A4,5H FOR , + & 2A4)') HISO(1,JND),HISO(2,JND),HISO(1,IND),HISO(2,IND) + ENDIF + ELSE + NN=NN+1 + IF(NN.GT.MAXFAT) THEN + WRITE(TEXT4,'(I4)') NN + CALL XABORT('EDILUM: MAXFAT OVERFLOW NN='//TEXT4) + ENDIF + JPREAC(NN,ISO)=100*JSO+MOD(IPREAC(IFATH,IND),100) + RRATE(NN,ISO)=PRATE(IFATH,IND) + ENDIF + ENDIF + ENDDO + ENDDO + CALL LCMPUT(IPEDIT,'PRODUCE-REAC',MAXFAT*NBCH,1,JPREAC) + CALL LCMPUT(IPEDIT,'PRODUCE-RATE',MAXFAT*NBCH,2,RRATE) +*---- +* WRITE THE ISOTOPE ASCII NAMES ON LCM OBJECT +*---- + CALL LCMPUT(IPEDIT,'DEPLETE-IDEN',2*NREAC,3,HREAC(1,1)) +*---- +* WRITE THE LUMPED FISSION YIELD MATRIX TO THE LCM OBJECT +*---- + IBFI=0 + IBFP=0 + DO ISO=1,NBCH + IND=IPOS(ISO,1) + IPOS(ISO,2)=0 + IPOS(ISO,3)=0 + IF(MOD(IDREAC(2,IND),100).EQ.4) THEN + IBFI=IBFI+1 + IF(IBFI.GT.NBFISS2) CALL XABORT('EDILUM: NBFISS OVERFLOW.') + IPOS(ISO,2)=IBFI + ELSE IF(MOD(IDREAC(2,IND),100).EQ.5) THEN + IBFP=IBFP+1 + IF(IBFP.GT.NBFPCH2) CALL XABORT('EDILUM: NBFPCH2 OVERFLOW.') + IPOS(ISO,3)=IBFP + ENDIF + ENDDO + DO ISO=1,NBCH + IFI=IPOS(ISO,2) + IF(IFI.GT.0) THEN + DO JSO=1,NBCH + IFP=IPOS(JSO,3) + IF(IFP.GT.0) THEN + IND=IPOS(ISO,1) + JND=IPOS(JSO,1) + IF(MIX(ISO).NE.MIX(JSO)) THEN + EYIEL((IFP-1)*IBFI+IFI)=0.0 + ELSE + EYIEL((IFP-1)*IBFI+IFI)=YIELD(IDREAC(2,IND)/100, + & IDREAC(2,JND)/100) + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + IF(IBFI*IBFP.GT.0) CALL LCMPUT(IPEDIT,'FISSIONYIELD',IBFI*IBFP,2, + & EYIEL) +*---- +* WRITE VECTORS 'DEPLETE-REAC' AND 'DEPLETE-ENER' TO THE LCM OBJECT +*---- + DO ISO=1,NBCH + IND=IPOS(ISO,1) + DO I=1,NREAC + IF(IDREAC(I,IND)/100.GT.0) THEN + KREAC=MOD(IDREAC(I,IND),100) + IF((KREAC.LE.0).OR.(KREAC.GT.5)) THEN + CALL XABORT('EDILUM: INVALID REACTION.') + ENDIF + ENDIF + IF((I.EQ.2).AND.(MOD(IDREAC(I,IND),100).EQ.4)) THEN + IF(IPOS(ISO,2).EQ.0) CALL XABORT('EDILUM: FAILURE 1.') + JDREAC(I,ISO)=IPOS(ISO,2)*100+4 + IF(IPRINT.GT.2) THEN + WRITE(NSYSO,6010) (HISO(I0,IPOS(ISO,1)),I0=1,3) + ENDIF + ELSE IF((I.EQ.2).AND.(MOD(IDREAC(I,IND),100).EQ.5)) THEN + IF(IPOS(ISO,3).EQ.0) CALL XABORT('EDILUM: FAILURE 2.') + JDREAC(I,ISO)=IPOS(ISO,3)*100+5 + ELSE + JDREAC(I,ISO)=IDREAC(I,IND) + ENDIF + EENER(I,ISO)=DENER(I,IND) + ENDDO + ENDDO + CALL LCMPUT(IPEDIT,'DEPLETE-REAC',NREAC*NBCH,1,JDREAC) + CALL LCMPUT(IPEDIT,'DEPLETE-ENER',NREAC*NBCH,2,EENER) +*---- +* WRITE VECTORS 'CHARGEWEIGHT', 'DEPLETE-DECA', 'ISOTOPESDEPL' AND +* 'STATE-VECTOR' TO THE LCM OBJECT +*---- + NBHEAV=0 + NSUPS2=0 + DO ISO=1,NBCH + IF(IPOS(ISO,1).GT.NBISO-NSUPS) NSUPS2=NSUPS2+1 + HHHH(1,ISO)=HISO(1,IPOS(ISO,1)) + HHHH(2,ISO)=HISO(2,IPOS(ISO,1)) + HHHH(3,ISO)=HISO(3,IPOS(ISO,1)) + DDDD(ISO)=DDECA(IPOS(ISO,1)) + IPOS(ISO,1)=MYLIST(IPOS(ISO,1)) + ENDDO + CALL LCMPUT(IPEDIT,'ISOTOPESDEPL',3*NBCH,3,HHHH) + CALL LCMPUT(IPEDIT,'CHARGEWEIGHT',NBCH,1,IPOS(1,1)) + CALL LCMPUT(IPEDIT,'DEPLETE-DECA',NBCH,2,DDDD) + ISTATE(:NSTATE)=0 + ISTATE(1)=NBCH + ISTATE(2)=IBFI + ISTATE(3)=IBFP + ISTATE(4)=NBHEAV + ISTATE(5)=NBCH-NBHEAV + ISTATE(7)=NSUPS2 + ISTATE(8)=NREAC + ISTATE(9)=MAXFAT + CALL LCMPUT(IPEDIT,'STATE-VECTOR',NSTATE,1,ISTATE) + IF(IPRINT.GT.2) WRITE(NSYSO,6000) (ISTATE(ISTA),ISTA=1,9) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(DDDD,EYIEL,EENER,RRATE) + DEALLOCATE(HHHH,IPOS,JDREAC,JPREAC) + RETURN +*---- +* FORMAT +*---- + 6000 FORMAT(/' STATE-VECTOR FOR LUMPED DEPLETION CHAIN'/' -------'/ + > ' NDEPL ',I6,' (NUMBER OF DEPLETING ISOTOPES)'/ + > ' NDFI ',I6,' (NUMBER OF DIRECT FISSILE ISOTOPES)'/ + > ' NDFP ',I6,' (NUMBER OF DIRECT FISSION PRODUCT)'/ + > ' NHEAVY ',I6,' (NUMBER OF HEAVY ISOTOPES)'/ + > ' NLIGHT ',I6,' (NUMBER OF FISSION PRODUCTS)'/ + > ' NOTHER ',I6,' (NUMBER OF OTHER ISOTOPES)'/ + > ' NSTABL ',I6,' (NUMBER OF STABLE ISOTOPES PRODUCING ENERGY)'/ + > ' NREAC ',I6,' (MAXIMUM NUMBER OF DEPLETION REACTIONS)'/ + > ' NPAR ',I6,' (MAXIMUM NUMBER OF PARENT REACTIONS)'/) + 6010 FORMAT(45H EDILUM: FISSILE ISOTOPE WITH FISSION YIELD: ,3A4) + 6020 FORMAT(18H EDILUM: ISOTOPE ',A,30H' IS LUMPED AND HAS A HALF-LIF, + > 4HE OF,1P,E12.4,25H DAYS. MAX FISSION YIELD=,1P,E8.1,2H%.) + END diff --git a/Dragon/src/EDIMAX.f b/Dragon/src/EDIMAX.f new file mode 100644 index 0000000..b9d8436 --- /dev/null +++ b/Dragon/src/EDIMAX.f @@ -0,0 +1,105 @@ +*DECK EDIMAX + SUBROUTINE EDIMAX(NBISO,ISONAM,MIX,IPRINT,NREGIO,NMERGE,MATCOD, + 1 IMERGE,LSISO,LISO,MAXISO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the number of homogenized/condensed isotopes in the output +* microlib. +* +*Copyright: +* Copyright (C) 2017 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NBISO number of isotopes in the input microlib. +* ISONAM local names of NBISO isotopes: +* chars 1 to 8 is the local isotope name; +* chars 9 to 12 is a suffix function of the mix number. +* MIX mixture number associated with each isotope. +* IPRINT print index. +* NREGIO number of volumes. +* NMERGE number of merged regions. +* MATCOD mixture index per volume. +* IMERGE index of merged regions. +* LSISO flag for isotopes saved. +* LISO =.TRUE. if we want to keep all the isotopes after +* homogeneization. +* +*Parameters: output +* MAXISO number of homogenized/condensed isotopes in the output +* microlib. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NBISO,ISONAM(3,NBISO),MIX(NBISO),IPRINT,NREGIO,NMERGE, + 1 MATCOD(NREGIO),IMERGE(NREGIO),LSISO(NBISO),MAXISO + LOGICAL LISO +*---- +* LOCAL VARIABLES +*---- + LOGICAL LOGIC +*---- +* ALLOCATABLE ARRAYS +*---- + LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASK +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(MASK(NBISO)) +* + JJISO=0 + IF(IPRINT.GT.5) THEN + WRITE(6,'(/34H EDIMAX: MERGING FLAG PER ISOTOPE:/(1X,20I6))') + 1 (LSISO(I),I=1,NBISO) + ENDIF + DO 70 INM=1,NMERGE + MASK(:NBISO)=.FALSE. + DO 60 ISO=1,NBISO + IF(MASK(ISO).OR.(LSISO(ISO).EQ.0)) GO TO 60 + DO 10 IREGIO=1,NREGIO + IF((IMERGE(IREGIO).EQ.INM).AND.(MATCOD(IREGIO).EQ.MIX(ISO))) + 1 GO TO 20 + 10 CONTINUE + GO TO 60 + 20 LOGIC=.FALSE. + DO 50 IREGIO=1,NREGIO + MATNUM=MATCOD(IREGIO) + IF(IMERGE(IREGIO).EQ.INM) THEN + DO 40 JSO=ISO,NBISO + IF((ISONAM(1,ISO).EQ.ISONAM(1,JSO)).AND. + 1 (ISONAM(2,ISO).EQ.ISONAM(2,JSO)).AND. + 2 (MATNUM.EQ.MIX(JSO)).AND.(LSISO(JSO).NE.0)) THEN + IF(LISO) THEN + IF(ISONAM(3,ISO).EQ.ISONAM(3,JSO)) GOTO 30 + GOTO 40 + ENDIF + 30 LOGIC=.TRUE. + MASK(JSO)=.TRUE. + GO TO 40 + ENDIF + 40 CONTINUE + ENDIF + 50 CONTINUE + IF(LOGIC) JJISO=JJISO+1 + 60 CONTINUE + 70 CONTINUE + MAXISO=JJISO + IF(IPRINT.GT.1) WRITE(6,100) MAXISO +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(MASK) + RETURN + 100 FORMAT(/53H EDIMAX: NUMBER OF HOMOGENIZED/CONDENSED ISOTOPES IN , + 1 20HTHE OUTPUT MICROLIB=,I8) + END diff --git a/Dragon/src/EDIMCN.f b/Dragon/src/EDIMCN.f new file mode 100644 index 0000000..9e894be --- /dev/null +++ b/Dragon/src/EDIMCN.f @@ -0,0 +1,282 @@ +*DECK EDIMCN + SUBROUTINE EDIMCN(IPTRK ,IPRINT,NDIM ,NUCELL,NBUCEL,MAXREG, + > NFREG ,NFSUR ,NNC ,NREGIO,NMERGE,IMERGE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read NXT geometry and generate merging index. +* +*Copyright: +* Copyright (C) 2011 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure in +* update or creation mode. +* IPRINT print level. +* NDIM dimension of the problem. +* NUCELL number of cell after unfolding in +* $X$, $Y$ and $Z$ directions. +* NBUCEL number of cells in unfolded geometry. +* MAXREG maximum number of region for any geometry. +* NFREG final number of regions. +* NFSUR final number of surfaces. +* NNC number of saved cells. +* NREGIO number of regions. +* +*Parameters: output +* NMERGE final number of merged regions. +* IMERGE merged region index. +* +*---------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPTRK + INTEGER IPRINT,NDIM,NUCELL(3),NBUCEL,MAXREG,NFREG,NFSUR, + > NNC,NREGIO,NMERGE,IMERGE(NREGIO) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='EDIMCN') + INTEGER NSTATE + PARAMETER (NSTATE=40) +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KEYMRG,ICMRG,IDREG + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ICIS,IUNFLD +*---- +* Local variables +*---- + INTEGER IEDIMC(NSTATE) + CHARACTER NAMREC*12,NAMCEL*9,NAMPIN*9 + INTEGER NX,NY,NZ,NXY,IX,IY,IZ,ICELL,ICELT,ITRN,ILEV, + > NREGC,IFPIN,ILPIN,IR,IREG,IREGM,IPIN,NBRP,KCIS, + > ICS,ITYLCM +*---- +* Data +*---- + CHARACTER CLEV(2)*1 + SAVE CLEV + DATA CLEV /'C','P'/ +*---- +* Scratch storage allocation +* KEYMRG merge region array +* ICIS internal cell symmetry +* IUNFLD description of unfolded geometry +* IDREG region identification array +* ICMRG cell material array +*---- + ALLOCATE(KEYMRG(-NFSUR:NFREG),ICMRG(NBUCEL),ICIS(4,NNC), + > IUNFLD(2,NBUCEL),IDREG(MAXREG)) +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF +*---- +* Initialise some arrays +*---- + CALL LCMGET(IPTRK,'KEYMRG ',KEYMRG) + ICMRG(:NBUCEL)=0 + IMERGE(:NREGIO)=0 + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,*) 'MAXREG =',MAXREG + WRITE(IOUT,*) 'KEYMRG=',-NFSUR,NFREG + WRITE(IOUT,'(17I6)') (KEYMRG(IR),IR=-NFSUR,NFREG) + ENDIF +*---- +* Read global mesh for geometry +* and determine graphics size +*---- + CALL LCMGET(IPTRK,'G00000001CIS',ICIS) + CALL LCMGET(IPTRK,'G00000001CUF',IUNFLD) + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,*) 'IUNFLD=',NBUCEL + WRITE(IOUT,'(2I6)') (IUNFLD(1,IR),IUNFLD(2,IR),IR=1,NBUCEL) + ENDIF + NX=NUCELL(1) + NY=NUCELL(2) + NZ=MAX(NUCELL(3),1) + NXY=NX*NY + NMERGE=0 +*---- +* Scan over $Z$ directions +*---- + DO IZ=1,NZ +*---- +* Scan over $Y$ directions +*---- + DO IY=1,NY +*---- +* Scan over $X$ directions +*---- + DO IX=1,NX + ICELL=NXY*(IZ-1)+NX*(IY-1)+IX + ICELT=IUNFLD(1,ICELL) + ITRN=IUNFLD(2,ICELL) +*---- +* If cell not already merged create new merged mixture +* and associate cell regions to this mixture +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,'(A6,6(1X,I8))') 'CELL ', + > IX,IY,IZ,ICELL,ICELT,ITRN + ENDIF + IF(ITRN .EQ.1) THEN + IF(ICMRG(ICELT) .NE. 0) GO TO 100 + NMERGE=NMERGE+1 + ICMRG(ICELT)=NMERGE +*---- +* Read cell info +*---- + ILEV=1 + WRITE(NAMCEL,'(A1,I8.8)') CLEV(ILEV),ICELT + NAMREC=NAMCEL//'DIM' + IEDIMC(:NSTATE)=0 + CALL LCMGET(IPTRK,NAMREC,IEDIMC) + NREGC=IEDIMC(8) + IF(NREGC .GT. MAXREG) CALL XABORT(NAMSBR//': MAXREG for ' + > //'main geometry not coherent with NREGC for cells') + IFPIN=IEDIMC(17) + ILPIN=IFPIN+IEDIMC(16)-1 + NAMREC=NAMCEL//'RID' + CALL LCMGET(IPTRK,NAMREC,IDREG) + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,*) NAMREC//'=',NREGC,IFPIN,ILPIN + WRITE(IOUT,'(17I6)') (IDREG(IR),IR=1,NREGC) + ENDIF + KCIS=0 + DO ICS=1,4 + IF(ICIS(ICS,ICELT) .NE. 0) KCIS=1 + ENDDO + DO IR=1,NREGC + IREG=IDREG(IR) + IF(IREG .GT. 0) THEN + IREGM=KEYMRG(IREG) + IF(IMERGE(IREGM) .EQ. 0) THEN + IMERGE(IREGM)=NMERGE + ELSE IF(IMERGE(IREGM) .NE. NMERGE) THEN + WRITE(IOUT,9000) NAMSBR,ICELL,ICELT, + > IREG,IREGM,IMERGE(IREGM) + CALL XABORT(NAMSBR// + > ': Problem in cells for merge by cell') + ENDIF + ELSE IF(IREG .LT. 0) THEN + IF(KCIS .NE. 1) THEN + WRITE(IOUT,9002) NAMSBR,ICELL,ICELT,IREG,IREGM + CALL XABORT(NAMSBR// + > ': Negative region number for cell without symmetry') + ENDIF + ENDIF + ENDDO +*---- +* Read pin info +*---- + ILEV=2 + DO IPIN=IFPIN,ILPIN + WRITE(NAMPIN,'(A1,I8.8)') CLEV(ILEV),IPIN + NAMREC=NAMPIN//'RID' + CALL LCMLEN(IPTRK,NAMREC,NBRP,ITYLCM) + IF(NBRP .GT. MAXREG) CALL XABORT(NAMSBR//': MAXREG for' + > //' main geometry not coherent with NBRP for pins') + CALL LCMGET(IPTRK,NAMREC,IDREG) + DO IR=1,NBRP + IREG=ABS(IDREG(IR)) + IF(IREG .NE. 0) THEN + IREGM=KEYMRG(IREG) + IF(IMERGE(IREGM) .EQ. 0) THEN + IMERGE(IREGM)=NMERGE + ELSE IF(IMERGE(IREGM) .NE. NMERGE) THEN + WRITE(IOUT,9001) NAMSBR,IPIN,ICELL,ICELT, + > IREG,IREGM,IMERGE(IREGM) + CALL XABORT(NAMSBR// + > ': Problem in pins for merge by cell') + ENDIF + ENDIF + ENDDO + ENDDO + 100 CONTINUE + ENDIF + ENDDO + ENDDO + ENDDO +*---- +* Verify if all cells analysed +*---- + DO ICELL=1,NX*NY*NZ + ICELT=IUNFLD(1,ICELL) + IF(ICMRG(ICELT) .EQ. 0) THEN + WRITE(IOUT,*) 'Merge Error',ICELL,ICELT + CALL XABORT(NAMSBR//': Some cells not merged') + ENDIF + ENDDO +*---- +* print routine closing header if required +*---- + IF(IPRINT .GE. 10) THEN + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6010) + DO IZ=1,NZ +*---- +* Scan over $Y$ directions +*---- + IF(NDIM .EQ. 3) THEN + WRITE(IOUT,6011) IZ + ENDIF + WRITE(IOUT,6012) (IX,IX=1,NX) + WRITE(IOUT,6013) ('------',IX=1,NX) + DO IY=NY,1,-1 +*---- +* Scan over $X$ directions +*---- + WRITE(IOUT,6014) IY,(ICMRG(IUNFLD(1,ICELL)), + > ICELL=NXY*(IZ-1)+NX*(IY-1)+1,NXY*(IZ-1)+NX*IY) + ENDDO + ENDDO + WRITE(IOUT,6020) + WRITE(IOUT,6021) (IMERGE(IREGM),IREGM=1,NREGIO) + ENDIF + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(IDREG,IUNFLD,ICIS,ICMRG,KEYMRG) + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT('Material homogenisation indices for cells'// + > ' -- Unfolded geometry') + 6011 FORMAT('Plan Z =',5x,I5) + 6012 FORMAT(' Y | X=',100(1X,I5)) + 6013 FORMAT('-----------',100(A6)) + 6014 FORMAT(I6,' |',100(1X,I5)) + 6020 FORMAT('Merging Index :') + 6021 FORMAT(12(1X,I5)) + 9000 FORMAT(' Error in ',A6,' virtual cell ',I5, + > ' (real cell=',I5,') analysis'/3I10) + 9001 FORMAT(' Error in ',A6,' pin ',I5,' virtual cell ',I5, + > ' (real cell=',I5,') analysis'/3I10) + 9002 FORMAT(' Internal symmetries problem in ',A6,' virtual cell ',I5, + > ' (real cell=',I5,') analysis'/3I10) + END diff --git a/Dragon/src/EDIMIC.f b/Dragon/src/EDIMIC.f new file mode 100644 index 0000000..323d864 --- /dev/null +++ b/Dragon/src/EDIMIC.f @@ -0,0 +1,1096 @@ +*DECK EDIMIC + SUBROUTINE EDIMIC(IPEDIT,IPFLUX,IPLIB,IADJ,NL,NDEL,NBESP,NBISO, + 1 NDEPL,ISONAM,ISONRF,IPISO,MIX,TN,NED,HVECT,NOUT,HVOUT,IPRINT, + 2 NGROUP,NGCOND,NBMIX,NREGIO,NMERGE,NDFI,NDFP,ILEAKS,ILUPS,NW, + 3 MATCOD,VOLUME,KEYFLX,CURNAM,IGCOND,IMERGE,FLUXES,AFLUXE,EIGENK, + 4 EIGINF,B2,DEN,ITYPE,IEVOL,LSISO,EMEVF,EMEVG,DECAY,YIELD,FIPI, + 5 FIFP,PYIELD,ITRANC,LISO,NMLEAK) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Homogenization and condensation of microscopic cross sections. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPEDIT pointer to the edition LCM object (L_EDIT signature). +* IPFLUX pointer to the solution LCM object (L_FLUX signature). +* IPLIB pointer to the reference microscopic cross section library +* LCM object (L_LIBRARY signature). +* IADJ type of flux weighting: +* =0: direct flux weighting; +* =1: direct-adjoint flux weighting. +* NL number of Legendre orders required in the calculation +* (NL=1 or higher). +* NDEL number of delayed precursor groups. +* NBESP number of energy-dependent fission spectra. +* NBISO number of isotopes. +* NDEPL number of depleting isotopes. +* ISONAM local names of NBISO isotopes: +* chars 1 to 8 is the local isotope name; +* chars 9 to 12 is a suffix function of the mix number. +* ISONRF library name of isotopes. +* IPISO pointer array towards microlib isotopes. +* MIX mixture number associated with each isotope. +* TN absolute temperature associated with each isotope. +* NED number of extra vector edits from MATXS. +* HVECT MATXS names of the extra vector edits. +* NOUT number of output cross section types (set to zero to recover +* all cross section types). +* HVOUT MATXS names of the output cross section types. +* IPRINT print index. +* NGROUP number of energy groups. +* NGCOND number of condensed groups. +* NBMIX number of mixtures. +* NREGIO number of volumes. +* NMERGE number of merged regions. +* NDFI number of fissile isotopes. +* NDFP number of fission products. +* ILEAKS leakage calculation type: =0: no leakage; =1: homogeneous +* leakage (Diffon); =2: isotropic streaming (Ecco); +* =3: anisotropic streaming (Tibere). +* ILUPS up-scattering removing flag (=1 to remove up-scattering from +* output cross-sections). +* NW type of weighting for P1 cross section info (=0: P0 ; =1: P1). +* MATCOD mixture index per volume. +* VOLUME volumes. +* KEYFLX position of average fluxes. +* CURNAM name of the LCM directory where the microscopic cross sections +* are stored (a blank value means no save). +* IGCOND limits of condensed groups. +* IMERGE index of merged regions. +* FLUXES fluxes. +* AFLUXE adjoint fluxes. +* EIGENK effective multiplication factor. +* EIGINF infinite multiplication factor. +* B2 bucklings. +* DEN number density of each isotope. +* ITYPE type of each isotope. +* IEVOL flag making an isotope non-depleting. A value of +* 1 is used to force an isotope to be non-depleting. +* LSISO flag for isotopes saved. +* EMEVF fission production energy. +* EMEVG capture production energy. +* DECAY radioactive decay constant. +* YIELD group-ordered condensed fission product yield. +* FIPI fissile isotope index assigned to each microlib isotope. +* FIFP fission product index assigned to each microlib isotope. +* PYIELD fissile isotope ordered condensed fission product yield. +* ITRANC type of transport correction (=0: no correction). +* LISO =.TRUE. if we want to keep all the isotopes after +* homogeneization. +* NMLEAK number of leakage zones. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPEDIT,IPFLUX,IPLIB,IPISO(NBISO) + INTEGER IADJ,NL,NDEL,NBESP,NBISO,NDEPL,ISONAM(3,NBISO), + 1 ISONRF(3,NBISO),MIX(NBISO),NED,NOUT,IPRINT,NGROUP, + 2 NGCOND,NBMIX,NREGIO,NMERGE,NDFI,NDFP,ILEAKS,ILUPS,NW, + 3 MATCOD(NREGIO),KEYFLX(NREGIO),IGCOND(NGCOND), + 4 IMERGE(NREGIO),ITYPE(NBISO),IEVOL(NBISO),LSISO(NBISO), + 5 FIPI(NBISO,NMERGE),FIFP(NBISO,NMERGE),ITRANC,NMLEAK + REAL TN(NBISO),VOLUME(NREGIO),FLUXES(NREGIO,NGROUP,NW+1), + 1 AFLUXE(NREGIO,NGROUP,NW+1),EIGENK,EIGINF,B2(4), + 2 DEN(NBISO),EMEVF(NBISO),EMEVG(NBISO),DECAY(NBISO), + 3 YIELD(NGCOND+1,NDFP,NMERGE),PYIELD(NDFI,NDFP,NMERGE) + CHARACTER HVECT(NED)*8,HVOUT(NOUT)*8,CURNAM*12 + LOGICAL LISO +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40,MAXESP=4) + TYPE(C_PTR) JPLIB,KPLIB,JPFLUX,JPEDIT,KPEDIT + LOGICAL LOGIC,LSTRD,LAWR,LMEVF,LMEVG,LDECA,LWD,LONE + CHARACTER CM*2,HNEW*12,TEXT8*8,TEXT12*12,HSMG*131,HNAMIS*12 + INTEGER IPAR(NSTATE),IESP2(MAXESP+1) + REAL B2T(3),EESP(MAXESP+1),EESP2(MAXESP+1) + DOUBLE PRECISION TMP,PARM0,PARM3,PARM4,VOLMER,DDEN,DDENZ,SQFMAS, + 1 XDRCST,NMASS,EVJ,CONV,ZNU,ZDEN,ZFL1,ZFL2,DENVOL +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ISMIX,ISTYP,ISTOD,ITYPRO, + 1 JPIFI,MILVO,ITYPS,IMERGL + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IHNISO + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: IGAR + LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASK + REAL, ALLOCATABLE, DIMENSION(:) :: XSECT,WSTRD,SDEN,VOLISO,TNISO, + 1 TMPXS,WDLA,WORK,WORKF,ENR,GA1,GA2,VOLM,YPIFI + REAL, ALLOCATABLE, DIMENSION(:,:) :: GAR,WGAR,DIFHET + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: PARM12,PHIAV,AHIAV + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: GAS + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: WSCAT + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HMAKE +*---- +* SCRATCH STORAGE ALLOCATION +*---- +* +* GAR/GAS CONTENTS: +* 1 : 'NWT0' | P0 direct flux +* 2 : 'NWT1' | P1 direct flux / NW values +* ... | +* 2+NW : 'NWAT0' | P0 adjoint flux +* 3+NW : 'NWAT1' | P1 adjoint flux / NW values +* ... | +* 3+2*NW : 'NTOT0' | P0 total cross section +* 4+2*NW : 'NTOT1' | P1 total cross section / NW values +* ... | +* 4+3*NW : 'SIGS00' | +* 5+3*NW : 'SIGS01' | NL VALUES +* ... | +* 4+NL+3*NW : 'NUSIGF' +* 5+NL+3*NW : HVECT(1) | +* 6+NL+3*NW : HVECT(2) | NED VALUES +* ... | +* 5+NED+NL+3*NW : 'H-FACTOR' +* 6+NED+NL+3*NW : 'OVERV' +* 7+NED+NL+3*NW : 'TRANC' +* 8+NED+NL+3*NW : 'STRD' +* IOF0H+1 : 'NUSIGF01' | +* IOF0H+2 : 'NUSIGF02' | NDEL VALUES +* ... | +* IOF1H+NDEL+1 : 'CHI' +* IOF1H+NDEL+2 : 'CHI01' | +* IOF1H+NDEL+3 : 'CHI02' | NDEL VALUES +* ... | +* IOF1H+2*NDEL+2 : 'CHI--01' | +* IOF1H+2*NDEL+3 : 'CHI--02' | NBESP VALUES +* ... | +* + MAXH=9+NBESP+2*NDEL+NED+NL+3*NW + CALL EDIMAX(NBISO,ISONAM,MIX,IPRINT,NREGIO,NMERGE,MATCOD,IMERGE, + 1 LSISO,LISO,MAXISO) + + ALLOCATE(IGAR(NGROUP,3,NL),IHNISO(3,MAXISO),ISMIX(MAXISO), + 1 ISTYP(MAXISO),ISTOD(MAXISO),ITYPRO(NL),MILVO(NMERGE), + 2 ITYPS(NBISO),IMERGL(NBMIX)) + ALLOCATE(MASK(NBISO)) + ALLOCATE(GAR(NGROUP,MAXH),WGAR(NGROUP**2,NL),XSECT(0:NBMIX), + 1 DIFHET(NMLEAK,NGROUP),WSTRD(NGCOND),SDEN(MAXISO),VOLISO(MAXISO), + 2 TNISO(MAXISO),TMPXS(NGCOND),WDLA(NDEL),WORK(NGROUP)) + ALLOCATE(WSCAT(NGCOND,NGCOND,NL),GAS(NGCOND,MAXH)) + ALLOCATE(HMAKE(MAXH+NL)) + ALLOCATE(JPIFI(MAXISO),YPIFI(MAXISO)) +*---- +* FOR AVERAGED NEUTRON VELOCITY +* V=SQRT(2*ENER/M)=SQRT(2/M)*SQRT(ENER) +* SQFMAS=SQRT(2/M) IN CM/S/SQRT(EV) FOR V IN CM/S AND E IN EV +* =SQRT(2*1.602189E-19(J/EV)* 1.0E4(CM2/M2) /1.67495E-27 (KG)) +* =1383155.30602 CM/S/SQRT(EV) +*---- + EVJ=XDRCST('eV','J') + NMASS=XDRCST('Neutron mass','kg') + SQFMAS=SQRT(2.0D4*EVJ/NMASS) +* + JPEDIT=C_NULL_PTR + IF(CURNAM.NE.' ') THEN + CALL LCMSIX(IPEDIT,CURNAM,1) + IF(MAXISO.GT.0) JPEDIT=LCMLID(IPEDIT,'ISOTOPESLIST',MAXISO) + ENDIF +* + DO 10 ISO=1,MAXISO + SDEN(ISO)=0.0 + VOLISO(ISO)=0.0 + JPIFI(ISO)=0 + 10 CONTINUE + IOF0H=8+NED+NL+3*NW + IOF1H=8+NED+NL+3*NW+NDEL + IOF2H=8+NED+NL+3*NW+2*NDEL + JJISO=0 + JJNDFI=0 + CONV=1.0E6 ! convert MeV to eV + DO 430 INM=1,NMERGE +*---- +* PRELIMINARY CALCULATIONS FOR STRD CROSS SECTIONS +*---- + LSTRD=ILEAKS.GE.1 + IF(LSTRD) THEN + IF(ILEAKS.EQ.1) THEN + CALL LCMLEN(IPFLUX,'DIFFHET',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.0) THEN + CALL XABORT('EDIMIC: UNABLE TO RECOVER THE DIFFHET RECO' + 1 //'RD IN THE FLUX OBJECT.') + ENDIF + CALL LCMGET(IPFLUX,'IMERGE-LEAK',IMERGL) + CALL LCMGET(IPFLUX,'DIFFHET',DIFHET) + ELSE IF(ILEAKS.EQ.3) THEN + CALL LCMGET(IPFLUX,'B2 HETE',B2T) + B2ALL=B2T(1)+B2T(2)+B2T(3) + IF(B2ALL.EQ.0.0) THEN + B2T(1)=1.0/3.0 + B2T(2)=B2T(1) + B2T(3)=B2T(1) + ELSE + B2T(1)=B2T(1)/B2ALL + B2T(2)=B2T(2)/B2ALL + B2T(3)=B2T(3)/B2ALL + ENDIF + ENDIF + IGRFIN=0 + XSECT(0)=0.0 + DO 50 IGRCND=1,NGCOND + ZNU=0.0D0 + ZDEN=0.0D0 + ZFL1=0.0D0 + ZFL2=0.0D0 + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGRCND) + CALL LCMSIX(IPLIB,'MACROLIB',1) + JPLIB=LCMGID(IPLIB,'GROUP') + JPFLUX=LCMGID(IPFLUX,'FLUX') + DO 40 IGR=IGRDEB,IGRFIN + KPLIB=LCMGIL(JPLIB,IGR) + CALL LCMGET(KPLIB,'NTOT0',XSECT(1)) + IF((ILEAKS.EQ.2).OR.(ILEAKS.EQ.3)) THEN + CALL LCMLEL(JPFLUX,IGR,ILCMLN,ITYLCM) + IF(ILCMLN.EQ.0) CALL XABORT('EDIMIC: MISSING FLUX INFO.') + ALLOCATE(WORKF(ILCMLN)) + CALL LCMGDL(JPFLUX,IGR,WORKF) + ENDIF + FL1=0.0 + FL2=0.0 + DO 20 IREGIO=1,NREGIO + MATNUM=MATCOD(IREGIO) + IF(IMERGE(IREGIO).EQ.INM) THEN + VOLREG=VOLUME(IREGIO) + IF(IADJ.EQ.0) THEN + FL1=FLUXES(IREGIO,IGR,1) + IF(NW.GE.1) FL2=FLUXES(IREGIO,IGR,2) + ELSE IF(IADJ.EQ.1) THEN + IF(ILEAKS.NE.1) CALL XABORT('EDIMIC: DIRECT-ADJOINT WEIG' + 1 //'HTING NOT IMPLEMENTED.') + FL1=FLUXES(IREGIO,IGR,1)*AFLUXE(IREGIO,IGR,1) + IF(NW.GE.1) FL2=FLUXES(IREGIO,IGR,2)* + 1 AFLUXE(IREGIO,IGR,2) + ENDIF + IF(NW.EQ.0) THEN + ZLEAK=0.0 + IF(ILEAKS.EQ.1) THEN + IME=IMERGL(MATNUM) + IF(IME.GT.0) ZLEAK=DIFHET(IME,IGR)*FLUXES(IREGIO,IGR,1) + ELSE IF(ILEAKS.EQ.2) THEN + ZLEAK=WORKF(KEYFLX(IREGIO)+ILCMLN/2) + ELSE IF(ILEAKS.EQ.3) THEN + ZLEAK=B2T(1)*WORKF(KEYFLX(IREGIO)+NREGIO)+ + 1 B2T(2)*WORKF(KEYFLX(IREGIO)+2*NREGIO)+ + 2 B2T(3)*WORKF(KEYFLX(IREGIO)+3*NREGIO) + ENDIF + ZNU=ZNU+ZLEAK*VOLREG + ZDEN=ZDEN+XSECT(MATNUM)*FL1*VOLREG + ZFL1=ZFL1+FL1*VOLREG + ZFL2=ZFL2+FL1*VOLREG + ELSE + ZNU=ZNU+FL2*VOLREG + ZDEN=ZDEN+XSECT(MATNUM)*FL2*VOLREG + ZFL1=ZFL1+FL1*VOLREG + ZFL2=ZFL2+FL2*VOLREG + ENDIF + ENDIF + 20 CONTINUE + IF((ILEAKS.EQ.2).OR.(ILEAKS.EQ.3)) DEALLOCATE(WORKF) + CALL LCMLEN(KPLIB,'SIGS01',LENGTH,ITYLCM) + IF((LENGTH.EQ.NBMIX).AND.(NL.GE.2)) THEN + CALL LCMGET(KPLIB,'SIGS01',XSECT(1)) + DO 30 IREGIO=1,NREGIO + MATNUM=MATCOD(IREGIO) + IF(IMERGE(IREGIO).EQ.INM) THEN + VOLREG=VOLUME(IREGIO) + IF(IADJ.EQ.0) THEN + FL1=FLUXES(IREGIO,IGR,1) + IF(NW.GE.1) FL2=FLUXES(IREGIO,IGR,2) + ELSE IF(IADJ.EQ.1) THEN + FL1=FLUXES(IREGIO,IGR,1)*AFLUXE(IREGIO,IGR,1) + IF(NW.GE.1) FL2=FLUXES(IREGIO,IGR,2)* + 1 AFLUXE(IREGIO,IGR,2) + ENDIF + IF(NW.EQ.0) THEN + ZDEN=ZDEN-XSECT(MATNUM)*FL1*VOLREG + ELSE + ZDEN=ZDEN-XSECT(MATNUM)*FL2*VOLREG + ENDIF + ENDIF + 30 CONTINUE + ENDIF + 40 CONTINUE + CALL LCMSIX(IPLIB,' ',2) + WSTRD(IGRCND)=REAL((ZFL1/(3.0*ZNU))*ZFL2/ZDEN) + 50 CONTINUE + ENDIF +* + VOLMER=0.0D0 + DO 60 IREGIO=1,NREGIO + IF(IMERGE(IREGIO).EQ.INM) VOLMER=VOLMER+VOLUME(IREGIO) + 60 CONTINUE + MASK(:NBISO)=.FALSE. + DO 420 ISO=1,NBISO + ITYPS(ISO)=ITYPE(ISO) + IF(MASK(ISO).OR.(LSISO(ISO).EQ.0)) GO TO 420 + DO 90 IREGIO=1,NREGIO + IF((IMERGE(IREGIO).EQ.INM).AND.(MATCOD(IREGIO).EQ.MIX(ISO))) + 1 GO TO 100 + 90 CONTINUE + GO TO 420 + 100 LOGIC=.FALSE. + DDEN=0.0D0 + DDENZ=0.0D0 +*---- +* MERGE/CONDENSE REACTIONS 'NWT0','NWT1','NWAT0','NWAT1','SIGS'//CM, +* 'SCAT'//CM, 'NTOT0', 'NUSIGF', 'CHI', 'CHIxx', 'STRD' AND HVECT +*---- + DO 110 J=1,MAXH+NL + HMAKE(J)=' ' + 110 CONTINUE + DO 121 J=1,MAXH + DO 120 I=1,NGCOND + GAS(I,J)=0.0D0 + 120 CONTINUE + 121 CONTINUE + DO 132 K=1,NL + DO 131 J=1,NGCOND + DO 130 I=1,NGCOND + WSCAT(I,J,K)=0.0D0 + 130 CONTINUE + 131 CONTINUE + 132 CONTINUE + DO 140 I=1,NDEL + WDLA(I)=0.0 + 140 CONTINUE +*---- +* RECOVER THE RADIOACTIVE DECAY CONSTANTS OF DELAYED NEUTRON +* GROUPS FROM THE MACROLIB IF THEY EXIST +*---- + LWD=.FALSE. + IF(CURNAM.NE.' ') THEN + CALL LCMSIX(IPEDIT,'MACROLIB',1) + CALL LCMLEN(IPEDIT,'LAMBDA-D',ILONG,ITYLCM) + LWD=(ILONG.EQ.NDEL).AND.(NDEL.GT.0) + IF(LWD) CALL LCMGET(IPEDIT,'LAMBDA-D',WDLA) + CALL LCMSIX(IPEDIT,' ',2) + ENDIF +* + HMAKE(1)='NWT0' + LAWR=.FALSE. + LDECA=.FALSE. + LMEVF=.FALSE. + LMEVG=.FALSE. + DO 145 IW=1,MIN(NW+1,10) + WRITE(HMAKE(IW),'(3HNWT,I1)') IW-1 + IF(IADJ.EQ.1) WRITE(HMAKE(1+NW+IW),'(4HNWAT,I1)') IW-1 + 145 CONTINUE + ALLOCATE(PARM12(NW+1)) + DO 260 IREGIO=1,NREGIO + MATNUM=MATCOD(IREGIO) + VOL=VOLUME(IREGIO) + IF(IMERGE(IREGIO).EQ.INM) THEN + IGRFIN=0 + DO 154 IGRCND=1,NGCOND + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGRCND) + DO 151 IGR=IGRDEB,IGRFIN + DO 150 IW=1,NW+1 + GAS(IGRCND,IW)=GAS(IGRCND,IW)+DBLE(FLUXES(IREGIO,IGR,IW)*VOL) + IF(IADJ.EQ.1) GAS(IGRCND,1+NW+IW)=GAS(IGRCND,1+NW+IW)+ + > DBLE(FLUXES(IREGIO,IGR,IW)*AFLUXE(IREGIO,IGR,IW)*VOL) + 150 CONTINUE + 151 CONTINUE + IF(IADJ.EQ.1) THEN + DO 153 IW=1,NW+1 + GAS(IGRCND,1+NW+IW)=GAS(IGRCND,1+NW+IW)*VOLMER/GAS(IGRCND,IW) + 153 CONTINUE + ENDIF + 154 CONTINUE + LONE=.TRUE. + DO 250 JSO=ISO,NBISO + IF((ISONAM(1,ISO).EQ.ISONAM(1,JSO)).AND. + 1 (ISONAM(2,ISO).EQ.ISONAM(2,JSO)).AND. + 2 (MATNUM.EQ.MIX(JSO)).AND.(LSISO(JSO).NE.0)) THEN + IF(LISO) THEN + IF(ISONAM(3,ISO).EQ.ISONAM(3,JSO)) GOTO 155 + GOTO 250 + ENDIF + 155 LOGIC=.TRUE. + ITYPS(ISO)=MAX(ITYPS(ISO),ITYPE(JSO)) + DENVOL=MAX(DEN(JSO),1.0E-20)*VOL + DDEN=DDEN+DENVOL + DDENZ=DDENZ+DEN(JSO)*VOL + KPLIB=IPISO(JSO) ! set JSO-th isotope + IF(LONE) THEN + CALL LCMLEN(KPLIB,'AWR',LENGTH,ITYLCM) + LAWR=(LENGTH.EQ.1) + IF(LAWR) CALL LCMGET(KPLIB,'AWR',AWR) + CALL LCMLEN(KPLIB,'MEVF',LENGTH,ITYLCM) + IF(LENGTH.EQ.1) CALL LCMGET(KPLIB,'MEVF',EMEVF(ISO)) + LMEVF=(LENGTH.EQ.1).OR.(EMEVF(ISO).GT.0.0) + CALL LCMLEN(KPLIB,'MEVG',LENGTH,ITYLCM) + IF(LENGTH.EQ.1) CALL LCMGET(KPLIB,'MEVG',EMEVG(ISO)) + LMEVG=(LENGTH.EQ.1).OR.(EMEVG(ISO).GT.0.0) + CALL LCMLEN(KPLIB,'DECAY',LENGTH,ITYLCM) + IF(LENGTH.EQ.1) CALL LCMGET(KPLIB,'DECAY',DECAY(ISO)) + LDECA=(LENGTH.EQ.1).OR.(DECAY(ISO).GT.0.0) + LONE=.FALSE. + ENDIF + DO 170 IL=0,NL-1 + WRITE (CM,'(I2.2)') IL + CALL LCMLEN(KPLIB,'SIGS'//CM,LENGTH,ITYLCM) + IF(LENGTH.EQ.NGROUP) THEN + CALL LCMGET(KPLIB,'SIGS'//CM,GAR(1,4+3*NW+IL)) + HMAKE(4+3*NW+IL)='SIGS'//CM + ENDIF + CALL LCMLEN(KPLIB,'NJJS'//CM,LENGTH,ITYLCM) + IF(LENGTH.EQ.NGROUP) THEN + CALL LCMGET(KPLIB,'NJJS'//CM,IGAR(1,1,1+IL)) + CALL LCMGET(KPLIB,'IJJS'//CM,IGAR(1,2,1+IL)) + CALL LCMGET(KPLIB,'SCAT'//CM,WGAR(1,1+IL)) + HMAKE(MAXH+1+IL)='SCAT'//CM + IPO=0 + DO 160 IGR=1,NGROUP + IGAR(IGR,3,1+IL)=IPO+1 + IPO=IPO+IGAR(IGR,1,1+IL) + 160 CONTINUE + ENDIF + 170 CONTINUE + DO IW=0,MIN(NW,9) + WRITE(HMAKE(3+2*NW+IW),'(4HNTOT,I1)') IW + CALL LCMLEN(KPLIB,HMAKE(3+2*NW+IW),ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + CALL LCMGET(KPLIB,HMAKE(3+2*NW+IW),GAR(1,3+2*NW+IW)) + ELSE + CALL LCMGET(KPLIB,'NTOT0',GAR(1,3+2*NW+IW)) + ENDIF + ENDDO + CALL LCMLEN(KPLIB,'NUSIGF',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGROUP) THEN + CALL LCMGET(KPLIB,'NUSIGF',GAR(1,4+NL+3*NW)) + HMAKE(4+NL+3*NW)='NUSIGF' + ENDIF + CALL LCMLEN(KPLIB,'CHI',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGROUP) THEN + CALL LCMGET(KPLIB,'CHI',GAR(1,1+IOF1H)) + HMAKE(1+IOF1H)='CHI' + ENDIF + IF(NDEL.GT.0) THEN + WRITE(TEXT8,'(6HNUSIGF,I2.2)') NDEL + CALL LCMLEN(KPLIB,TEXT8,LENGTH,ITYLCM) + IF(LENGTH.EQ.NGROUP) THEN + DO 180 IDEL=1,NDEL + WRITE(TEXT8,'(6HNUSIGF,I2.2)') IDEL + CALL LCMGET(KPLIB,TEXT8,GAR(1,IOF0H+IDEL)) + HMAKE(IOF0H+IDEL)=TEXT8 + 180 CONTINUE + ENDIF + WRITE(TEXT8,'(3HCHI,I2.2)') NDEL + CALL LCMLEN(KPLIB,TEXT8,LENGTH,ITYLCM) + IF(LENGTH.EQ.NGROUP) THEN + DO 184 IDEL=1,NDEL + WRITE(TEXT8,'(3HCHI,I2.2)') IDEL + CALL LCMGET(KPLIB,TEXT8,GAR(1,1+IOF1H+IDEL)) + HMAKE(1+IOF1H+IDEL)=TEXT8 + 184 CONTINUE + ENDIF + ENDIF + DO 185 ISP=1,NBESP + WRITE(TEXT8,'(5HCHI--,I2.2)') ISP + CALL LCMLEN(KPLIB,TEXT8,LENGTH,ITYLCM) + IF(LENGTH.EQ.NGROUP) THEN + CALL LCMGET(KPLIB,TEXT8,GAR(1,1+IOF2H+ISP)) + HMAKE(1+IOF2H+ISP)=TEXT8 + ENDIF + 185 CONTINUE + IF(ITRANC.NE.0) THEN + CALL LCMGET(KPLIB,'TRANC',GAR(1,7+NED+NL+3*NW)) + HMAKE(7+NED+NL+3*NW)='TRANC' + ENDIF + DO 186 IGR=1,NGROUP + GAR(IGR,5+NED+NL+3*NW)=0.0 + 186 CONTINUE + CALL LCMLEN(KPLIB,'H-FACTOR',LENGTH,ITYLCM) + IF(LENGTH.GT.0) THEN + CALL LCMGET(KPLIB,'H-FACTOR',GAR(1,5+NED+NL+3*NW)) + HMAKE(5+NED+NL+3*NW)='H-FACTOR' + ELSE + IF(LMEVF) THEN + CALL LCMGET(KPLIB,'NFTOT',WORK) + HMAKE(5+NED+NL+3*NW)='H-FACTOR' + DO 190 IGR=1,NGROUP + GAR(IGR,5+NED+NL+3*NW)=GAR(IGR,5+NED+NL+3*NW)+ + 1 WORK(IGR)*EMEVF(ISO)*REAL(CONV) + 190 CONTINUE + ENDIF + IF(LMEVG) THEN + CALL LCMGET(KPLIB,'NG',WORK) + HMAKE(5+NED+NL+3*NW)='H-FACTOR' + DO 195 IGR=1,NGROUP + GAR(IGR,5+NED+NL+3*NW)=GAR(IGR,5+NED+NL+3*NW)+ + 1 WORK(IGR)*EMEVG(ISO)*REAL(CONV) + 195 CONTINUE + ENDIF + ENDIF + DO 200 IED=1,NED + IF(HVECT(IED).EQ.'H-FACTOR') GO TO 200 + CALL LCMLEN(KPLIB,HVECT(IED),LENGTH,ITYLCM) + IF((LENGTH.GT.0).AND.(HVECT(IED).NE.'TRANC')) THEN + CALL LCMGET(KPLIB,HVECT(IED),GAR(1,4+NL+3*NW+IED)) + HMAKE(4+NL+3*NW+IED)=HVECT(IED) + ENDIF + 200 CONTINUE + CALL LCMLEN(KPLIB,'OVERV',LENGTH,ITYLCM) + IF(LENGTH.GT.0) THEN + CALL LCMGET(KPLIB,'OVERV',GAR(1,6+NED+NL+3*NW)) + ELSE + ALLOCATE(ENR(NGROUP+1)) + CALL LCMGET(IPLIB,'ENERGY',ENR) + IF(ENR(NGROUP+1).EQ.0.0) ENR(NGROUP+1)=1.0E-5 + DO 205 IGR=1,NGROUP + ENEAVG=SQRT(ENR(IGR)*ENR(IGR+1)) + GAR(IGR,6+NED+NL+3*NW)=1.0/(REAL(SQFMAS)*SQRT(ENEAVG)) + 205 CONTINUE + DEALLOCATE(ENR) + ENDIF + HMAKE(6+NED+NL+3*NW)='OVERV' +* + IGRFIN=0 + DO 242 IGRCND=1,NGCOND + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGRCND) + DO 241 IGR=IGRDEB,IGRFIN + PARM0=FLUXES(IREGIO,IGR,1)*DENVOL + PARM3=0.0D0 + PARM4=0.0D0 + PARM12(:NW+1)=0.0D0 + IF(IADJ.EQ.0) THEN + DO 206 IW=1,NW+1 + PARM12(IW)=FLUXES(IREGIO,IGR,IW)*DENVOL + 206 CONTINUE + PARM3=0.0D0 + DO 210 JREGIO=1,NREGIO + IF(IMERGE(JREGIO).EQ.INM) THEN + PARM3=PARM3+FLUXES(JREGIO,IGR,1)*VOLUME(JREGIO) + ENDIF + 210 CONTINUE + PARM3=DENVOL*PARM3/VOLMER + PARM4=DENVOL + ELSE IF(IADJ.EQ.1) THEN + DO 211 IW=1,NW+1 + PARM12(IW)=FLUXES(IREGIO,IGR,IW)*AFLUXE(IREGIO,IGR,IW)* + > DENVOL + 211 CONTINUE + PARM3=0.0D0 + DO 212 JREGIO=1,NREGIO + IF(IMERGE(JREGIO).EQ.INM) THEN + PARM3=PARM3+FLUXES(JREGIO,IGR,1)*AFLUXE(JREGIO,IGR,1)* + > VOLUME(JREGIO) + ENDIF + 212 CONTINUE + PARM3=DENVOL*PARM3/VOLMER + PARM4=AFLUXE(IREGIO,IGR,1)*DENVOL + ENDIF + DO 215 J=3+2*NW,MAXH + IF(HMAKE(J).NE.' ') THEN + IF(J.EQ.6+NED+NL+3*NW) THEN + GAS(IGRCND,J)=GAS(IGRCND,J)+DBLE(GAR(IGR,J))*PARM3 ! OVERV + ELSE IF((J.EQ.4+NL+3*NW).OR. + > ((J.GE.1+IOF0H).AND.(J.LE.NDEL+IOF0H))) THEN + GAS(IGRCND,J)=GAS(IGRCND,J)+DBLE(GAR(IGR,J))*PARM0 ! nu*fission cross sections + ELSE IF((J.GE.1+IOF1H).AND.(J.LE.MAXH)) THEN + GAS(IGRCND,J)=GAS(IGRCND,J)+DBLE(GAR(IGR,J))*PARM4 ! fission spectrum + ELSE IF((J.GE.4+2*NW).AND.(J.LE.3+3*NW)) THEN + IW=J-2-2*NW ! NTOT1 cross sections + GAS(IGRCND,J)=GAS(IGRCND,J)+DBLE(GAR(IGR,J))*PARM12(IW) + ELSE IF((J.GE.5+3*NW).AND.(J.LE.3+NL+3*NW)) THEN + IW=MIN(J-3-3*NW,NW+1) ! SOGS01 cross sections + GAS(IGRCND,J)=GAS(IGRCND,J)+DBLE(GAR(IGR,J))*PARM12(IW) + ELSE IF(J.EQ.8+NED+NL+3*NW) THEN + GO TO 215 ! STRD case + ELSE IF(J.LE.IOF1H) THEN + GAS(IGRCND,J)=GAS(IGRCND,J)+DBLE(GAR(IGR,J))*PARM12(1) ! P0 cross sections + ENDIF + ENDIF + 215 CONTINUE + DO 240 IL=0,NL-1 + IF(HMAKE(MAXH+1+IL).NE.' ') THEN +* IGRCND IS THE SECONDARY GROUP. + IW=MIN(IL,NW)+1 + NGSCAT=IGAR(IGR,1,1+IL) + IGSCAT=IGAR(IGR,2,1+IL) + JGRFIN=0 + DO 230 JGRCND=1,NGCOND + JGRDEB=JGRFIN+1 + JGRFIN=IGCOND(JGRCND) + J2=MIN(JGRFIN,IGSCAT) + J1=MAX(JGRDEB,IGSCAT-NGSCAT+1) + TMP=0.0D0 + IPO=IGAR(IGR,3,1+IL)+IGSCAT-J2 + DO 220 JGR=J2,J1,-1 + IF(IADJ.EQ.0) THEN + TMP=TMP+WGAR(IPO,1+IL)*FLUXES(IREGIO,JGR,IW)*DENVOL + ELSE IF(IADJ.EQ.1) THEN + TMP=TMP+WGAR(IPO,1+IL)*AFLUXE(IREGIO,IGR,IW)* + > FLUXES(IREGIO,JGR,IW)*DENVOL + ENDIF + IPO=IPO+1 + 220 CONTINUE + WSCAT(IGRCND,JGRCND,1+IL)=WSCAT(IGRCND,JGRCND,1+IL)+TMP + 230 CONTINUE + ENDIF + 240 CONTINUE + 241 CONTINUE + 242 CONTINUE + MASK(JSO)=.TRUE. + GO TO 250 + ENDIF + 250 CONTINUE + ENDIF + 260 CONTINUE + DEALLOCATE(PARM12) + IF(LOGIC) THEN + JJISO=JJISO+1 + IF(JJISO.GT.MAXISO) CALL XABORT('EDIMIC: INSUFFICIENT ALLOCAT' + 1 //'ED SPACE FOR ISMIX, ISTYP, SDEN, VOLISO AND IHNISO.') + IF(LISO) THEN + WRITE(HNEW,'(3A4)') (ISONAM(I0,ISO),I0=1,3) + ELSE + WRITE(HNEW,'(2A4,I4.4)') (ISONAM(I0,ISO),I0=1,2),INM + ENDIF + READ(HNEW,'(3A4)') (IHNISO(I0,JJISO),I0=1,3) + ISMIX(JJISO)=INM + ISTYP(JJISO)=ISO + SDEN(JJISO)=REAL(DDENZ/VOLMER) + VOLISO(JJISO)=REAL(VOLMER) + TNISO(JJISO)=TN(ISO) + IF(IPRINT.GT.1) THEN + WRITE (6,600) HNEW,JJISO + WRITE(6,'(/17H NUMBER DENSITY =,1P,E12.4)') DDEN/VOLMER + ENDIF + IF(NDFI.GT.0) THEN + IFI=FIPI(ISO,INM) + IF(IFI.GT.0) THEN + JJNDFI=JJNDFI+1 + IF(JJNDFI.GT.MAXISO) CALL XABORT('EDIMIC: JPIFI OVERFLOW.') + JPIFI(JJNDFI)=JJISO + IF(IPRINT.GT.1) WRITE(6,'(24H FISSILE ISOTOPE INDEX =,I5)') + 1 JJNDFI + ENDIF + ENDIF +* +* UP-SCATTERING CORRECTIONS. + IF(ILUPS.EQ.1) THEN + DO 282 JGR=2,NGCOND + DO 281 IGR=1,JGR-1 ! IGR < JGR + GAS(3+2*NW,IGR)=GAS(3+2*NW,IGR)-WSCAT(IGR,JGR,1) + GAS(3+2*NW,JGR)=GAS(3+2*NW,JGR)-WSCAT(IGR,JGR,1) + IF((NW.GE.1).AND.(NL.GE.1)) THEN + GAS(4+2*NW,IGR)=GAS(4+2*NW,IGR)-WSCAT(IGR,JGR,2) + GAS(4+2*NW,JGR)=GAS(4+2*NW,JGR)-WSCAT(IGR,JGR,2) + ENDIF + DO 280 IL=0,NL-1 + GAS(4+3*NW+IL,IGR)=GAS(4+3*NW+IL,IGR)-WSCAT(IGR,JGR,1+IL) + GAS(4+3*NW+IL,JGR)=GAS(4+3*NW+IL,JGR)-WSCAT(IGR,JGR,1+IL) + WSCAT(JGR,IGR,1+IL)=WSCAT(JGR,IGR,1+IL)-WSCAT(IGR,JGR,1+IL) + WSCAT(IGR,JGR,1+IL)=0.0D0 + 280 CONTINUE + 281 CONTINUE + 282 CONTINUE + ENDIF +* + ALLOCATE(PHIAV(NW+1),AHIAV(NW+1)) + DO 360 IGRCND=1,NGCOND +* +* DIVIDE MATRIX XS BY INTEGRATED FLUX + DO 341 IL=0,NL-1 + IW=MIN(IL,NW)+1 + PHIAV(IW)=GAS(IGRCND,IW)/VOLMER + TMP=GAS(IGRCND,4+3*NW+IL) + DO 330 JGRCND=1,NGCOND + IF(JGRCND.NE.IGRCND) TMP=TMP-WSCAT(JGRCND,IGRCND,1+IL) + 330 CONTINUE + QEN=REAL(MAX(ABS(TMP),ABS(WSCAT(IGRCND,IGRCND,1+IL)))) + IF((QEN.GT.0.0).AND.(IADJ.EQ.0)) THEN + ERR=ABS(REAL(TMP-WSCAT(IGRCND,IGRCND,1+IL)))/QEN + IF(ERR.GT.1.0E-3) WRITE(6,620) IGRCND,IL,100.0*ERR,HNEW + WSCAT(IGRCND,IGRCND,1+IL)=TMP + ENDIF + DO 340 JGRCND=1,NGCOND + AHIAV(IW)=1.0D0 + IF(IADJ.EQ.1) AHIAV(IW)=GAS(JGRCND,1+NW+IW)/VOLMER + IF(PHIAV(IW).GT.0.0D0) THEN + WSCAT(JGRCND,IGRCND,1+IL)=WSCAT(JGRCND,IGRCND,1+IL) + 1 /(DDEN*AHIAV(IW)*PHIAV(IW)) + ELSE + WSCAT(JGRCND,IGRCND,1+IL)=0.0D0 + ENDIF + 340 CONTINUE + 341 CONTINUE +* +* DIVIDE VECTORIAL XS BY INTEGRATED FLUX + DO 345 IW=1,NW+1 + PHIAV(IW)=GAS(IGRCND,IW)/VOLMER + AHIAV(IW)=1.0 + IF(IADJ.EQ.1) AHIAV(IW)=GAS(IGRCND,1+NW+IW)/VOLMER + 345 CONTINUE + DO 350 J=3+2*NW,MAXH + IF((J.EQ.4+NL+3*NW).OR. + > ((J.GE.1+IOF0H).AND.(J.LE.NDEL+IOF0H))) THEN + IF(PHIAV(1).GT.0.0D0) THEN + GAS(IGRCND,J)=GAS(IGRCND,J)/(DDEN*PHIAV(1)) ! nu*fission cross sections + ELSE + GAS(IGRCND,J)=0.0D0 + ENDIF + ELSE IF((J.GE.1+IOF1H).AND.(J.LE.MAXH)) THEN + GAS(IGRCND,J)=GAS(IGRCND,J)/(DDEN*AHIAV(1)) ! fission spectrum + ELSE IF((J.GE.4+2*NW).AND.(J.LE.3+3*NW)) THEN + IW=J-2-2*NW + IF(PHIAV(IW).NE.0.0) THEN + GAS(IGRCND,J)=GAS(IGRCND,J)/(DDEN*AHIAV(IW)*PHIAV(IW)) ! NTOT1 cross sections + ELSE + GAS(IGRCND,J)=0.0D0 + ENDIF + ELSE IF((J.GE.5+3*NW).AND.(J.LE.3+NL+3*NW)) THEN + IW=MIN(J-3-3*NW,NW+1) + IF(PHIAV(IW).NE.0.0) THEN + GAS(IGRCND,J)=GAS(IGRCND,J)/(DDEN*AHIAV(IW)*PHIAV(IW)) ! SIGS01 cross sections + ELSE + GAS(IGRCND,J)=0.0D0 + ENDIF + ELSE IF(J.EQ.8+NED+NL+3*NW) THEN + GO TO 350 ! STRD case + ELSE IF(PHIAV(1).GT.0.0D0) THEN + GAS(IGRCND,J)=GAS(IGRCND,J)/(DDEN*AHIAV(1)*PHIAV(1)) ! P0 cross sections + ELSE + GAS(IGRCND,J)=0.0D0 + ENDIF + 350 CONTINUE +* + IF(LSTRD) THEN + J=8+NED+NL+3*NW + HMAKE(J)='STRD' + IF(NW.GE.1) THEN + GAS(IGRCND,J)=GAS(IGRCND,4+2*NW) + ELSE + GAS(IGRCND,J)=GAS(IGRCND,3+2*NW) + ENDIF + IF((HMAKE(5+3*NW).NE.' ').AND.(NL.GE.2)) THEN + GAS(IGRCND,J)=GAS(IGRCND,J)-GAS(IGRCND,5+3*NW) + ENDIF + GAS(IGRCND,J)=GAS(IGRCND,J)*WSTRD(IGRCND) + ENDIF + 360 CONTINUE + DEALLOCATE(AHIAV,PHIAV) +* +* DIVIDE INTEGRATED FLUXES BY VOLUMES + DO 366 IW=1,NW+1 + DO 365 IGRCND=1,NGCOND + GAS(IGRCND,IW)=GAS(IGRCND,IW)/VOLMER + IF(IADJ.EQ.1) GAS(IGRCND,NW+IW)=GAS(IGRCND,NW+IW)/VOLMER + 365 CONTINUE + 366 CONTINUE +* + IF(CURNAM.NE.' ') THEN + IF(NOUT.GT.0) THEN + DO J=1,MAXH+NL + DO IOUT=1,NOUT + IF(HMAKE(J).EQ.HVOUT(IOUT)) GO TO 370 + ENDDO + HMAKE(J)=' ' + 370 CONTINUE + ENDDO + ENDIF + KPEDIT=LCMDIL(JPEDIT,JJISO) ! set JJISO-th isotope + CALL LCMPTC(KPEDIT,'ALIAS',12,HNEW) + IF(LAWR) CALL LCMPUT(KPEDIT,'AWR',1,2,AWR) + IF(LMEVF) CALL LCMPUT(KPEDIT,'MEVF',1,2,EMEVF(ISO)) + IF(LMEVG) CALL LCMPUT(KPEDIT,'MEVG',1,2,EMEVG(ISO)) + IF(LDECA) CALL LCMPUT(KPEDIT,'DECAY',1,2,DECAY(ISO)) + DO 380 J=1,MAXH + IF(HMAKE(J).NE.' ') THEN + DO 375 IGCD=1,NGCOND + TMPXS(IGCD)=REAL(GAS(IGCD,J)) + 375 CONTINUE + CALL LCMPUT(KPEDIT,HMAKE(J),NGCOND,2,TMPXS) + ENDIF + 380 CONTINUE + DO 390 IL=1,NL + ITYPRO(IL)=0 + IF(HMAKE(MAXH+IL).NE.' ') ITYPRO(IL)=1 + 390 CONTINUE + IF(ITYPRO(1).EQ.0) GO TO 405 + ALLOCATE(GA1(NL*NGCOND),GA2(NL*NGCOND*NGCOND)) + IOF1=0 + IOF2=0 + DO 402 IL=1,NL + DO 401 IG2=1,NGCOND + IOF1=IOF1+1 + GA1(IOF1)=REAL(GAS(IG2,3+3*NW+IL)) + DO 400 IG1=1,NGCOND + IOF2=IOF2+1 + GA2(IOF2)=REAL(WSCAT(IG1,IG2,IL)) + 400 CONTINUE + 401 CONTINUE + 402 CONTINUE + CALL XDRLGS(KPEDIT,1,IPRINT,0,NL-1,1,NGCOND,GA1,GA2,ITYPRO) + DEALLOCATE(GA2,GA1) + 405 IF(NDEL.NE.0) THEN + IF(HMAKE(IOF0H+1).NE.' ') THEN + CALL LCMPUT(KPEDIT,'LAMBDA-D',NDEL,2,WDLA) + ENDIF + ENDIF + ENDIF + IF(IPRINT.GT.3) THEN + DO 410 J=1,MAXH + IF(HMAKE(J).NE.' ') THEN + WRITE (6,610) HMAKE(J),(GAS(I,J),I=1,NGCOND) + ENDIF + 410 CONTINUE + WRITE (6,610) 'SIGA ',(GAS(I,3+2*NW)-GAS(I,4+3*NW), + > I=1,NGCOND) + WRITE (6,610) 'SIGW00 ',(WSCAT(I,I,1),I=1,NGCOND) + IF(NL.GT.1) THEN + WRITE (6,610) 'SIGW01 ',(WSCAT(I,I,2),I=1,NGCOND) + ENDIF + IF(LWD) WRITE (6,610) 'LAMBDA-D',(WDLA(I),I=1,NDEL) + ENDIF + IF(IPRINT.GT.4) CALL LCMLIB(KPEDIT) + ENDIF + 420 CONTINUE + 430 CONTINUE + IF(CURNAM.NE.' ') CALL LCMSIX(IPEDIT,' ',2) +*---- +* VALIDATE FISSION YIELD DATA +*---- + IF((NDFI.GT.0).AND.(JJISO.GT.0)) THEN + DO 470 INM=1,NMERGE + DO 460 ISO=1,NBISO + IF((DEN(ISO).EQ.0.0).OR.(IEVOL(ISO).EQ.1)) GO TO 460 + IF(ITYPE(ISO).EQ.2) THEN + IF(FIPI(ISO,INM).NE.0) THEN + ! microlib isotope ISO is a fissile isotope + DO 450 J=1,JJNDFI + JJSO=JPIFI(J) ! condensed isotope JJSO is a fissile isotope + IF(JJSO.EQ.0) GO TO 450 + JSO=ISTYP(JJSO) + IF((ISMIX(JJSO).EQ.INM).AND.(ISONAM(1,ISO).EQ.ISONAM(1,JSO)) + 1 .AND.(ISONAM(2,ISO).EQ.ISONAM(2,JSO))) GO TO 460 + 450 CONTINUE + WRITE(HNAMIS,'(3A4)') (ISONAM(I0,ISO),I0=1,3) + WRITE(HSMG,'(29HEDIMIC: THE FISSILE ISOTOPE '',A8, + 1 34H'' MUST BE SELECTED IN MICR OPTION.)') HNAMIS(:8) + CALL XABORT(HSMG) + ENDIF + ENDIF + 460 CONTINUE + 470 CONTINUE + ENDIF +* + IF(CURNAM.NE.' ') THEN + CALL LCMSIX(IPEDIT,CURNAM,1) + TEXT12='L_LIBRARY' + CALL LCMPTC(IPEDIT,'SIGNATURE',12,TEXT12) +*---- +* FIND THE MAXIMUM NUMBER OF ISOTOPES PER MIXTURE +*---- + MAXISM=0 + DO 490 INM=1,NMERGE + MAX0=0 + DO 480 IISO=1,JJISO + IF(ISMIX(IISO).EQ.INM) MAX0=MAX0+1 + 480 CONTINUE + MAXISM=MAX(MAXISM,MAX0) + 490 CONTINUE +*---- +* SAVE FISSION YIELD DATA +*---- + IF(NDFI.GT.0) THEN + DO 520 INM=1,NMERGE + DO 510 IISO=1,JJISO + IF(ISMIX(IISO).EQ.INM) THEN + ISO=ISTYP(IISO) + ISOFP=FIFP(ISO,INM) + IF(ISOFP.GT.0) THEN + ! condensed isotope IISO is a fission fragment + IF(ISOFP.GT.NDFP) CALL XABORT('EDIMIC: YIELD OVERFLOW.') + KPEDIT=LCMGIL(JPEDIT,IISO) ! set IISO-th isotope + YPIFI(:JJNDFI)=0.0 + DO 500 J=1,JJNDFI + JJSO=JPIFI(J) ! condensed isotope JJSO is fissile + JSO=ISTYP(JJSO) + IFI=FIPI(JSO,INM) + IF(IFI.GT.0) YPIFI(J)=PYIELD(IFI,ISOFP,INM) + 500 CONTINUE + CALL LCMPUT(KPEDIT,'YIELD',NGCOND+1,2,YIELD(1,ISOFP,INM)) + IF(JJNDFI.GT.0) THEN + CALL LCMPUT(KPEDIT,'PYIELD',JJNDFI,2,YPIFI) + CALL LCMPUT(KPEDIT,'PIFI',JJNDFI,1,JPIFI) + ENDIF + ENDIF + ENDIF + 510 CONTINUE + 520 CONTINUE + ENDIF +*---- +* SAVE EDITION MICROLIB +*---- + IF(NED.GT.0) CALL LCMPTC(IPEDIT,'ADDXSNAME-P0',8,NED,HVECT) + NCOMB=0 + IF(JJISO.GT.0) THEN + CALL LCMPUT(IPEDIT,'ISOTOPESUSED',3*JJISO,3,IHNISO) + CALL LCMPUT(IPEDIT,'ISOTOPESMIX',JJISO,1,ISMIX) + CALL LCMPUT(IPEDIT,'ISOTOPESVOL',JJISO,2,VOLISO) + CALL LCMPUT(IPEDIT,'ISOTOPESTEMP',JJISO,2,TNISO) + CALL LCMPUT(IPEDIT,'ISOTOPESDENS',JJISO,2,SDEN) + DO 550 IISO=1,JJISO + DO 530 I0=1,3 + IHNISO(I0,IISO)=ISONRF(I0,ISTYP(IISO)) + 530 CONTINUE + ISTOD(IISO)=IEVOL(ISTYP(IISO)) + ISTYP(IISO)=ITYPS(ISTYP(IISO)) + IF((ISTOD(IISO).NE.1).AND.(ISTYP(IISO).GE.1)) THEN + INM=ISMIX(IISO) + IF(INM.EQ.0) GO TO 550 + DO 540 J=1,NCOMB + IF(INM.EQ.MILVO(J)) GO TO 550 + 540 CONTINUE + NCOMB=NCOMB+1 + IF(NCOMB.GT.NMERGE) CALL XABORT('EDIMIC: MILVO OVERFLOW.') + MILVO(NCOMB)=INM + ENDIF + 550 CONTINUE + CALL LCMPUT(IPEDIT,'ISOTOPERNAME',3*JJISO,3,IHNISO) + CALL LCMPUT(IPEDIT,'ISOTOPESTODO',JJISO,1,ISTOD) + CALL LCMPUT(IPEDIT,'ISOTOPESTYPE',JJISO,1,ISTYP) + ENDIF + ALLOCATE(VOLM(NMERGE)) + VOLM(:NMERGE)=0.0 + DO 560 IREGIO=1,NREGIO + INM=IMERGE(IREGIO) + IF(INM.GT.0) VOLM(INM)=VOLM(INM)+VOLUME(IREGIO) + 560 CONTINUE + CALL LCMPUT(IPEDIT,'MIXTURESVOL',NMERGE,2,VOLM) + CALL LCMPUT(IPEDIT,'K-EFFECTIVE',1,2,EIGENK) + CALL LCMPUT(IPEDIT,'K-INFINITY',1,2,EIGINF) + IF(ILEAKS.GT.0) CALL LCMPUT(IPEDIT,'B2 B1HOM',1,2,B2(4)) + DEALLOCATE(VOLM) + ALLOCATE(ENR(NGROUP+1)) + CALL LCMGET(IPLIB,'ENERGY',ENR) + DO 570 IGRCND=1,NGCOND + ENR(IGRCND+1)=ENR(IGCOND(IGRCND)+1) + 570 CONTINUE + IF(ENR(NGCOND+1).EQ.0.0) ENR(NGCOND+1)=1.0E-5 + CALL LCMPUT(IPEDIT,'ENERGY',NGCOND+1,2,ENR) + DO 580 IGRCND=1,NGCOND + ENR(IGRCND)=LOG(ENR(IGRCND)/ENR(IGRCND+1)) + 580 CONTINUE + CALL LCMPUT(IPEDIT,'DELTAU',NGCOND,2,ENR) + NBESP2=0 + IF(NBESP.GT.0) THEN + IF(NBESP.GT.MAXESP) CALL XABORT('EDIMIC: MAXESP OVERFLOW.') + CALL LCMGET(IPLIB,'CHI-ENERGY',EESP) + EESP2(1)=ENR(1) + IESP2(1)=0 + IIG=0 + DO IG=1,NGCOND+1 + IF(IIG.GT.NBESP) CALL XABORT('EDIMIC: BAD LIMITS FOR ENERG' + 1 //'Y-DEPENDENT FISSION SPECTRA.') + IF(EESP(IIG+1).GE.0.999*ENR(IG)) THEN + IIG=IIG+1 + EESP2(IIG)=ENR(IG) + IESP2(IIG)=IG-1 + ENDIF + ENDDO + NBESP2=IIG-1 + IF(IPRINT.GT.3) THEN + WRITE(6,'(/42H EDIMIC: ENERGY-DEPENDENT FISSION SPECTRA:)') + WRITE(6,'(5X,5I12)') IESP2(:NBESP2+1) + WRITE(6,'(5X,1P,5E12.4)') EESP2(:NBESP2+1) + ENDIF + CALL LCMPUT(IPEDIT,'CHI-ENERGY',NBESP2+1,2,EESP2) + CALL LCMPUT(IPEDIT,'CHI-LIMITS',NBESP2+1,1,IESP2) + ENDIF + DEALLOCATE(ENR) + IPAR(:NSTATE)=0 + IPAR(1)=NMERGE + IPAR(2)=JJISO + IPAR(3)=NGCOND + IPAR(4)=NL + IPAR(5)=ITRANC + IF(ITRANC.NE.0) IPAR(5)=2 + IPAR(7)=1 + IPAR(11)=NDEPL + IPAR(12)=NCOMB + IPAR(13)=NED + IPAR(14)=NMERGE + IPAR(16)=NBESP2 + IPAR(18)=1 + IPAR(19)=NDEL + IPAR(20)=JJNDFI + IPAR(22)=MAXISM + IPAR(25)=NW + CALL LCMPUT(IPEDIT,'STATE-VECTOR',NSTATE,1,IPAR) + IF(IPRINT.GT.3) THEN + WRITE(6,630) IPRINT,(IPAR(I),I=1,13) + WRITE(6,640) (IPAR(I),I=14,25) + ENDIF + CALL LCMSIX(IPEDIT,' ',2) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(YPIFI,JPIFI) + DEALLOCATE(HMAKE) + DEALLOCATE(GAS,WSCAT) + DEALLOCATE(WORK,WDLA,TMPXS,TNISO,VOLISO,SDEN,WSTRD,DIFHET,XSECT, + 1 WGAR,GAR) + DEALLOCATE(MASK) + DEALLOCATE(IMERGL,ITYPS,MILVO,ITYPRO,ISTOD,ISTYP,ISMIX,IHNISO, + 1 IGAR) + RETURN +* + 600 FORMAT (//44H CROSS SECTION OF MERGED/CONDENSED ISOTOPE ',A12, + 1 7H' (ISO=,I8,2H):) + 610 FORMAT (/11H REACTION ',A12,2H':/(1X,1P,10E12.4)) + 620 FORMAT(/53H EDIMIC: *** WARNING *** NORMALIZATION OF THE WITHIN-, + 1 34HGROUP SCATTERING TRANSFER IN GROUP,I4,10H AND ORDER,I3,3H BY, + 2 F6.2,9H% ISOTOPE,2H=',A12,2H'.) + 630 FORMAT(/8H OPTIONS/8H -------/ + 1 7H IPRINT,I6,30H (0=NO PRINT/1=SHORT/2=MORE)/ + 2 7H MAXMIX,I6,31H (MAXIMUM NUMBER OF MIXTURES)/ + 3 7H NBISO ,I6,36H (NUMBER OF ISOTOPES OR MATERIALS)/ + 4 7H NGRP ,I6,28H (NUMBER OF ENERGY GROUPS)/ + 5 7H NL ,I6,30H (NUMBER OF LEGENDRE ORDERS)/ + 6 7H ITRANC,I6,45H (0=NO TRANSPORT CORRECTION/1=APOLLO TYPE/2, + 7 57H=RECOVER FROM LIBRARY/3=WIMS-D TYPE/4=LEAKAGE CORRECTION)/ + 8 7H IPROB ,I6,23H (0=DIRECT/1=ADJOINT)/ + 9 7H ITIME ,I6,28H (1=STEADY-STATE/2=PROMPT)/ + 1 7H NLIB ,I6,32H (NUMBER OF SETS OF LIBRARIES)/ + 2 7H NGF ,I6,48H (NUMBER OF FAST GROUP WITHOUT SELF-SHIELDING)/ + 3 7H IGRMAX,I6,41H (LAST GROUP INDEX WITH SELF-SHIELDING)/ + 4 7H NDEPL ,I6,33H (NUMBER OF DEPLETING ISOTOPES)/ + 5 7H NCOMB ,I6,33H (NUMBER OF DEPLETING MIXTURES)/ + 6 7H NEDMAC,I6,34H (NUMBER OF CROSS SECTION EDITS)) + 640 FORMAT(7H NBMIX ,I6,23H (NUMBER OF MIXTURES)/ + 1 7H NRES ,I6,40H (NUMBER OF SETS OF RESONANT MIXTURES)/ + 2 7H NBESP ,I6,47H (NUMBER OF ENERGY-DEPENDENT FISSION SPECTRA)/ + 3 7H IPROC ,I6,48H (-1=SKIP LIBRARY PROCESSING/0=DILUTION INTERP, + 4 48HOLATION/1=USE PHYSICAL TABLES/2=BUILD A DRAGLIB/, + 5 55H3=COMPUTE CALENDF TABLES/4=COMPUTE SLOWING-DOWN TABLES)/ + 6 7H IMAC ,I6,45H (0=DO NOT/1=DO BUILD AN EMBEDDED MACROLIB)/ + 7 7H NDEL ,I6,31H (NUMBER OF PRECURSOR GROUPS)/ + 8 7H NFISS ,I6,43H (NUMBER OF FISSILE ISOTOPES IN MICROLIB)/ + 9 7H ISOADD,I6,37H (0=COMPLETE BURNUP CHAIN/1=DO NOT)/ + 1 7H MAXISM,I6,40H (MAX. NUMBER OF ISOTOPES PER MIXTURE)/ + 2 7H IPRECI,I6,34H (CALENDF ACCURACY FLAG:1/2/3/4)/ + 3 7H IADF ,I6,19H (ADF FLAG:0/1/2)/ + 4 7H NW ,I6,47H (=0: FLUX WEIGHTING FOR P1 INFO; =1: CURRENT, + 5 23H WEIGHTING FOR P1 INFO)) + END diff --git a/Dragon/src/EDIMRC.f b/Dragon/src/EDIMRC.f new file mode 100644 index 0000000..a337f14 --- /dev/null +++ b/Dragon/src/EDIMRC.f @@ -0,0 +1,91 @@ +*DECK EDIMRC + SUBROUTINE EDIMRC(IPTRK ,IPRINT ,NREGIO, NMERGE, IMERGE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To generate the region merging index for homogenisation +* per CELL for NXT treated geometry +* +*Copyright: +* Copyright (C) 2011 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau. +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure. +* IPRINT print level. +* NREGIO number of regions. +* +*Parameters: output +* NMERGE final number of merged regions. +* IMERGE merged region index. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPTRK + INTEGER IPRINT + INTEGER NREGIO + INTEGER NMERGE + INTEGER IMERGE(NREGIO) +*---- +* Local parameters +*---- + CHARACTER NAMSBR*6 + PARAMETER (NAMSBR='EDIMRC') + INTEGER NSTATE + PARAMETER (NSTATE=40) + INTEGER ILCMUP,ILCMDN + PARAMETER (ILCMUP=1,ILCMDN=2) +*---- +* Local variables +*---- + INTEGER ISTATE(NSTATE),IEDIMG(NSTATE) + CHARACTER HSIGN*12 + INTEGER NDIM,NFREG,NFSUR,NNC,NBUCEL,NUCELL(3),MAXREG +*---- +* Test if valid tracking data structure +* EXCELL with type 4 tracking +*---- + CALL LCMGTC(IPTRK,'SIGNATURE',12,HSIGN) +*---- +* TEST IF GEOMETRY OR EXCELL TRACK DATA STRUCTURE +*---- + IF(HSIGN .NE. 'L_TRACK ') CALL XABORT(NAMSBR// + >': Invalid data structure for merge by cell') + CALL LCMGTC(IPTRK,'TRACK-TYPE',12,HSIGN) + IF((HSIGN .NE. 'EXCELL') .AND. (HSIGN .NE. 'MCCG')) THEN + CALL XABORT(NAMSBR//': Invalid tracking for merge by cell') + ENDIF + ISTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + IF(ISTATE(7) .NE. 4) CALL XABORT(NAMSBR// + >': Only NXT tracking permitted for merge by cell') + IF(ISTATE(40) .EQ. 1) CALL XABORT(NAMSBR// + >': Double heterogeneity (Bihet) not implemented') + CALL LCMSIX(IPTRK,'NXTRecords ',ILCMUP) + CALL LCMGET(IPTRK,'G00000001DIM',IEDIMG) + NDIM =IEDIMG( 1) + NNC =IEDIMG( 4) + NBUCEL =IEDIMG( 5) + NUCELL(1)=IEDIMG(13) + NUCELL(2)=IEDIMG(14) + NUCELL(3)=IEDIMG(15) + NFSUR =IEDIMG(22) + NFREG =IEDIMG(23) + MAXREG =IEDIMG(25) + CALL EDIMCN(IPTRK ,IPRINT,NDIM ,NUCELL,NBUCEL,MAXREG, + > NFREG,NFSUR,NNC,NREGIO,NMERGE,IMERGE) + CALL LCMSIX(IPTRK,'NXTRecords ',ILCMDN) + RETURN + END diff --git a/Dragon/src/EDIMRG.f b/Dragon/src/EDIMRG.f new file mode 100644 index 0000000..6929109 --- /dev/null +++ b/Dragon/src/EDIMRG.f @@ -0,0 +1,235 @@ +*DECK EDIMRG + SUBROUTINE EDIMRG(IPTRK ,IPMRG ,IPRINT,GEONAM,ITM ,NREGIO, + > NMERGE,IMERGE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find merge vector by mixtures. +* +*Copyright: +* Copyright (C) 2001 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau. +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure. +* IPMRG merge geometry (ITM=-1) or +* tracking (ITM=1) data structure. +* IPRINT print level. +* GEONAM geometry name. +* ITM type of merge: +* =-1 merge from second geometry; +* = 0 merge from calculation tracking; +* = 1 merge from second tracking. +* NREGIO number of regions. +* +*Parameters: output +* NMERGE final number of merged regions. +* IMERGE merged region index. +* +*----------------------------------------------------------------------- +* +* +*--------------------------- EDIMRG --------------------------------- +* +* 1- PROGRAMME STATISTICS: +* NAME : EDIMRG +* USE : FIND MERGE VECTOR BY MIXTURES IN IPMRG +* WITH IPTRK +* MODIFIED : 2001/10/30 (G.M) +* AUTHOR : G.MARLEAU +* +* 2- ROUTINE PARAMETERS: +* IPTRK : CALCULATION TRACKING DATA STRUCTURE +* ***> INTEGER IPTRKI +* IPMRG : MERGE GEOMETRY (ITM=-1) OR +* TRACKING (ITM=1) DATA STRUCTURE I +* ***> INTEGER IPMRG +* IPRINT : PRINT LEVEL +* ***> INTEGER IPRINT +* GEONAM : GEOMETRY NAME +* ***> CHARACTER*12 GEONAM +* ITM : TYPE OF MERGE I +* ITM = -1 -> FROM SECOND GEOMETRY +* ITM = 0 -> FROM CALCULATION TRACKING +* ITM = 1 -> FROM SECOND TRACKING +* ***> INTEGER ITM +* NREGIO : NUMBER OF REGIONS +* ***> INTEGER NREGIO +* NMERGE : FINAL NUMBER OF MERGED REGIONS +* ***> INTEGER NMERGE +* IMERGE : MERGED REGIONS POSITION +* ***> INTEGER IMERGE(NREGIO) +* +*--------------------------- EDIMRG -------------------------------- +* + USE GANLIB + IMPLICIT NONE + INTEGER IOUT,NSTATE + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NSTATE=40,NAMSBR='EDIMRG') +*---- +* ROUTINE PARAMETERS +*---- + TYPE(C_PTR) IPTRK + TYPE(C_PTR) IPMRG + INTEGER IPRINT + CHARACTER GEONAM*12 + INTEGER ITM + INTEGER NREGIO + INTEGER NMERGE + INTEGER IMERGE(NREGIO) +*---- +* LOCAL PARAMETERS +*---- + INTEGER ISTATE(NSTATE) + TYPE(C_PTR) IPTRK2 + INTEGER IMODT2,IMEDT2,ICLST2,IPRIN2 + INTEGER ITYPEG,ITGEO + CHARACTER NAMTR2*12 + CHARACTER HSIGN*12 + INTEGER NV,NS,NSOUT,NREG,NUNK,ICODE(6) + REAL EXTKOP(NSTATE) + INTEGER ITROP,MAXMIX,IREG,ISYMM + INTEGER IUEXP,KDROPN,KDRCLS,IRC + INTEGER ITYPM + LOGICAL LASS,LDRASS +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KEYMRG,MATALB,MATMRG,MERT + REAL, ALLOCATABLE, DIMENSION(:) :: VOLSUR,VOLMRG +*---- +* LOCAL NAME OF TEMPORARY TRACKING FILE +* WHEN IPGEO IS PROVIDED +*---- + NAMTR2='EDIMRGIPTRK2' + IMODT2=0 + IMEDT2=1 + IPRIN2=0 + ICLST2=2 + ITYPM=1 + ITROP=0 + IF(ITM .EQ. -1) THEN + LASS=LDRASS(IPMRG,IPRINT) + CALL LCMOP(IPTRK2,NAMTR2,IMODT2,IMEDT2,IPRIN2) + HSIGN='L_TRACK ' + CALL LCMPTC(IPTRK2,'SIGNATURE',12,HSIGN) + HSIGN='EXCELL ' + CALL LCMPTC(IPTRK2,'TRACK-TYPE',12,HSIGN) +*---- +* ANALYZE GEOMETRY +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(IPMRG,'STATE-VECTOR',ISTATE) + ITYPEG= ISTATE(1) + IF(ITYPEG .EQ. 3 .OR. ITYPEG .EQ. 6 ) THEN + ITGEO= 1 + ELSE IF(ITYPEG .EQ. 8 .OR. ITYPEG .EQ. 9 .OR. + > ITYPEG .EQ. 24 .OR. ITYPEG .EQ. 25 ) THEN + ITGEO= 2 + ELSE IF(ITYPEG .EQ. 5 .OR. ITYPEG .EQ. 7 .OR. + > ITYPEG .EQ. 20 .OR. ITYPEG .EQ. 21 .OR. + > ITYPEG .EQ. 22 .OR. ITYPEG .EQ. 23 ) THEN + ITGEO= 3 + ELSE + ITGEO= 0 + ENDIF + IF(ISTATE(13) .GE. 1) THEN +*---- +* CLUSTER GEOMETRY +*---- + ISYMM=1 +*c CALL AXGXCW(IPMRG ,IPTRK2,IPRINT,GEONAM,ISYMM ) + CALL XABORT('EDIMRG: NOT IMPLEMENTED(1):'//GEONAM) + ITROP=3 + ELSE IF(ITGEO .EQ. 2 ) THEN +*---- +* HEXAGONAL 2D GEOMETRIES +*---- +* CALL AXGXHX(IPMRG ,IPTRK2,IPRINT,GEONAM) + ITROP=2 + ELSE IF(ITGEO .EQ. 3 ) THEN +*---- +* CARTESIAN 2D/3D ASSEMBLIES +* CALL XELPRP TO GET GEOMETRY DIMENSIONING INFORMATION +*---- +*c CALL AXGXEL(IPMRG ,IPTRK2,IPRINT,GEONAM) + CALL XABORT('EDIMRG: NOT IMPLEMENTED(2):'//GEONAM) + ITROP=1 + ELSE + CALL XABORT(NAMSBR//': INVALID TYPE OF GEOMETRY') + ENDIF + CALL LCMGET(IPTRK2,'ICODE ',ICODE) + CALL LCMSIX(IPTRK2,'EXCELL ',1) + ISTATE(:NSTATE)=0 + CALL LCMGET(IPTRK2,'STATE-VECTOR',ISTATE) + NV=ISTATE(3) + NS=ISTATE(2) + NUNK=NV+NS+1 + ALLOCATE(KEYMRG(NUNK),MATALB(NUNK),VOLSUR(NUNK)) + CALL LCMGET(IPTRK2,'KEYMRG ',KEYMRG) + CALL LCMGET(IPTRK2,'MATALB ',MATALB) + CALL LCMGET(IPTRK2,'VOLSUR ',VOLSUR) + CALL LCMSIX(IPTRK2,'EXCELL ',2) + ALLOCATE(MATMRG(NUNK),VOLMRG(NUNK)) + CALL XELCMP(NS ,NV ,VOLSUR,MATALB,KEYMRG,NSOUT , + > NREG ,VOLMRG,MATMRG,ITGEO ,ICODE ) + MAXMIX=0 + DO 100 IREG=1,NREG + KEYMRG(IREG+NSOUT+1)= IREG + MAXMIX=MAX(MAXMIX,MATMRG(IREG+NSOUT+1)) + 100 CONTINUE + CALL LCMPUT(IPTRK2,'MATCOD',NREG,1,MATMRG(NSOUT+2)) + CALL LCMPUT(IPTRK2,'VOLUME',NREG,2,VOLMRG(NSOUT+2)) + CALL LCMPUT(IPTRK2,'KEYFLX',NREG,1,KEYMRG(NSOUT+2)) + EXTKOP(:NSTATE)=0.0 + CALL LCMPUT(IPTRK2,'EXCELTRACKOP',NSTATE,2,EXTKOP) + ISTATE(:NSTATE)=0 + ISTATE(1)=NREG + ISTATE(2)=NREG + ISTATE(4)=MAXMIX + ISTATE(5)=NSOUT + ISTATE(7)=ITROP + ISTATE(8)=-1 + CALL LCMPUT(IPTRK2,'STATE-VECTOR',NSTATE,1,ISTATE) + DEALLOCATE(VOLSUR,MATALB,KEYMRG) + DEALLOCATE(VOLMRG,MATMRG) +*---- +* IF IPRINT >= 10 +* EXPORT TEMPORARY TRACKING FILE +*---- + IF(IPRINT .GE. 10) THEN + IUEXP=KDROPN('EDIMRGEXP',0,3,0) + CALL LCMEXP(IPTRK2,IPRINT,IUEXP,2,1) + IRC=KDRCLS(IUEXP,1) + ENDIF + ELSE + IPTRK2=IPMRG + ENDIF +*---- +* DESTROY TEMPORARY TRACKING FILE +* WHEN IPGEO IS PROVIDED +*---- + ALLOCATE(MERT(NREGIO+1)) + MERT(:NREGIO+1)=1 +*C CALL MRGTRK(IPTRK ,IPTRK2,IPRINT,ITYPM ,NREGIO, MERT) + CALL LCMLIB(IPTRK) + CALL XABORT('EDIMRG: NOT IMPLEMENTED(3)') + NMERGE=0 + DO 110 IREG=1,NREGIO + IMERGE(IREG)=MERT(IREG+1) + NMERGE=MAX(NMERGE,IMERGE(IREG)) + 110 CONTINUE + DEALLOCATE(MERT) + IF(ITM .EQ. -1) THEN + CALL LCMCL(IPTRK2,ICLST2) + ENDIF + RETURN + END diff --git a/Dragon/src/EDIPRR.f b/Dragon/src/EDIPRR.f new file mode 100644 index 0000000..40c5fea --- /dev/null +++ b/Dragon/src/EDIPRR.f @@ -0,0 +1,192 @@ +*DECK EDIPRR + SUBROUTINE EDIPRR(IPRINT,NL,ITRANC,NGCOND,NMERGE,ILEAKS,NW,NTAUXT, + > B2,VOLMER,NENER,WENERG,RATECM,FLUXCM,SCATTD) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Print reaction rates. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPRINT print level; +* = 0 no print; +* = 1 print fluxes; +* = 2 1+print reaction rates; +* = 3 2+print homogenized cross sections. +* NL number of Legendre orders. +* ITRANC type of transport correction. +* NGCOND number of condensed groups. +* NMERGE number of merged regions. +* ILEAKS type of leakage calculation: +* = 0 no leakage; +* = 1 homogeneous leakage (Diffon); +* = 2 isotropic streaming (Ecco); +* = 3 anisotropic streaming (Tibere); +* = 10 isotropic diffusion coefficients recovered from input +* macrolib; +* = 11 anisotropic diffusion coefficients recovered from input +* macrolib. +* NW type of weighting for PN cross section info (=0 P0; =1 P1). +* NTAUXT number of reaction rate edits. +* B2 square buckling: +* for ILEAKS=1,2: B2(4) is homogeneous; +* for ILEAKS=3: B2(1),B2(2),B2(3) are directional heterogeneous +* and B2(4) is homogeneous. +* VOLMER volume of region merged. +* NENER number of energy groups limits. +* WENERG energy group limits. +* RATECM averaged region/group cross sections: +* = RATECM(*,1) = total P0; +* = RATECM(*,2) = total P1; +* = RATECM(*,NW+2) = absorption; +* = RATECM(*,NW+3) = fission; +* = RATECM(*,NW+4) = fixed sources / productions; +* = RATECM(*,NW+5) = leakage; +* = RATECM(*,NW+6) = total out of group scattering; +* = RATECM(*,NW+7) = diagonal scattering x-s; +* = RATECM(*,NW+8) = chi; +* = RATECM(*,NW+9) = wims type transport correction; +* = RATECM(*,NW+10) = x-directed leakage; +* = RATECM(*,NW+11) = y-directed leakage; +* = RATECM(*,NW+12) = z-directed leakage; +* = RATECM(*,NW+13) = nu-sigf for delayed neutrons; +* = RATECM(*,NW+13+NDEL) = fission spectra for delayed neutrons. +* FLUXCM integrated region/group fluxes: +* = FLUXCM(*,1) = fluxes P0; +* = FLUXCM(*,2) = fluxes P1. +* SCATTD scattering rates. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IPRINT,NL,ITRANC,NGCOND,NMERGE,ILEAKS,NW,NTAUXT,NENER + REAL B2(4),VOLMER(NMERGE),WENERG(NGCOND+1), + > RATECM(NMERGE,NGCOND,NTAUXT),FLUXCM(NMERGE,NGCOND,NW+1) + DOUBLE PRECISION SCATTD(NMERGE,NGCOND,NGCOND,NL) +*---- +* LOCAL VARIABLES +*---- + CHARACTER APG*3 + PARAMETER (IUNOUT=6,APG=' > ') + DOUBLE PRECISION SCATWG,SCATTN + REAL, ALLOCATABLE, DIMENSION(:,:) :: FLDMC +*---- +* SCRATCH STORAGE ALLOCATION +* FLDMC flux merged and condensed. +*---- + ALLOCATE(FLDMC(NMERGE,NGCOND)) +*---- +* COMPUTE AVERAGE FLUX +*---- + DO 224 IGRC=1,NGCOND + DO 225 IKK=1,NMERGE + FLDMC(IKK,IGRC)=FLUXCM(IKK,IGRC,1)/VOLMER(IKK) + 225 CONTINUE + 224 CONTINUE +*---- +* PRINT REACTION RATES +*---- + WRITE(IUNOUT,6000) + WRITE(IUNOUT,6001) (JJ,VOLMER(JJ),JJ=1,NMERGE) + IF( (NENER.GT.0) .AND. (IPRINT.GT.1) ) THEN + WRITE(IUNOUT,6002) (WENERG(IG),APG,IG,APG,IG=1,NGCOND), + > WENERG(NGCOND+1) + ENDIF + WRITE(IUNOUT,6003) + DO 154 IGR=1,NGCOND + IF(IPRINT.EQ.1) THEN + WRITE(IUNOUT,6010) IGR + WRITE(IUNOUT,6012) (FLUXCM(IKK,IGR,1),IKK=1,NMERGE) + WRITE(IUNOUT,6011) + WRITE(IUNOUT,6012) (FLDMC(IKK,IGR),IKK=1,NMERGE) + GO TO 154 + ENDIF + IF((ILEAKS.EQ.1).OR.(ILEAKS.EQ.2).OR.(ILEAKS.EQ.10)) THEN + WRITE(IUNOUT,6013) IGR + ELSE + WRITE(IUNOUT,6014) IGR + ENDIF + DO 155 IKK=1,NMERGE + IF(VOLMER(IKK).EQ.0.0) GO TO 155 +*---- +* UNCOMMENT THE 2 LINES TO PERFORM TRANSPORT CORRECTION +*---- + TOTAL=RATECM(IKK,IGR,1) + SCATWG=SCATTD(IKK,IGR,IGR,1) + IF(ITRANC.NE.0) THEN +* TOTAL=TOTAL-RATECM(IKK,IGR,NW+9) +* SCATWG=SCATWG-RATECM(IKK,IGR,NW+9) + ENDIF +* + SCATTN=0.0D0 + DO 153 JGR=1,NGCOND + IF(JGR.NE.IGR) SCATTN=SCATTN+SCATTD(IKK,JGR,IGR,1) + 153 CONTINUE + IF((ILEAKS.EQ.1).OR.(ILEAKS.EQ.2).OR.(ILEAKS.EQ.10)) THEN + WRITE(IUNOUT,6020) IKK,FLDMC(IKK,IGR),FLUXCM(IKK,IGR,1), + > TOTAL,RATECM(IKK,IGR,NW+2),RATECM(IKK,IGR,NW+3), + > RATECM(IKK,IGR,NW+5)*B2(4),RATECM(IKK,IGR,NW+4),SCATWG, + > SCATTN + ELSE + WRITE(IUNOUT,6021) IKK, FLDMC(IKK,IGR),FLUXCM(IKK,IGR,1), + > TOTAL,RATECM(IKK,IGR,NW+2),RATECM(IKK,IGR,NW+3), + > RATECM(IKK,IGR,NW+4),SCATWG,SCATTN + ENDIF + 155 CONTINUE + IF((ILEAKS.EQ.3).OR.(ILEAKS.EQ.11)) THEN + WRITE(IUNOUT,6022) + DO 156 IKK=1,NMERGE + IF(VOLMER(IKK).EQ.0.0) GO TO 156 + WRITE(IUNOUT,6023) IKK,RATECM(IKK,IGR,NW+10)*B2(1)+ + > RATECM(IKK,IGR,NW+11)*B2(2)+RATECM(IKK,IGR,NW+12)*B2(3), + > RATECM(IKK,IGR,NW+10)*B2(1),RATECM(IKK,IGR,NW+11)*B2(2), + > RATECM(IKK,IGR,NW+12)*B2(3),RATECM(IKK,IGR,NW+5)*B2(4) + 156 CONTINUE + ENDIF + 154 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(FLDMC) + RETURN +*---- +* FORMAT +*---- + 6000 FORMAT(////5(5X,'REGION',6X,'VOLUME ')) + 6001 FORMAT(1P,5(5X,I4,4X,E12.5)) + 6002 FORMAT(/' E N E R G Y L I M I T S (EV)'/1P, + >6(E12.4,A3,I3,A3)) + 6003 FORMAT(/' F L U X E S A N D R E A C T I O N R A T E S'/ + >1X,51(1H-)) + 6010 FORMAT(/' G R O U P :',I4/' REGION INTEGRATED FLUX') + 6011 FORMAT(' AVERAGED REGIONAL FLUX') + 6012 FORMAT(1P,7(3X,E15.7)) + 6013 FORMAT(/14H G R O U P :,I4/7H REGION,3X,7HAVERAGE,5X,3HINT, + > 7HEGRATED,5X,9HCOLLISION,4X,10HABSORPTION,4X,10HNU*FISSION,6X, + > 7HLEAKAGE,5X,10HPRODUCTION,8X,16HSCATTERING RATES/11X,4HFLUX, + > 10X,4HFLUX,10X,4HRATE,10X,4HRATE,10X,4HRATE,10X,4HRATE,10X, + > 4HRATE,6X,26HWITHIN GROUP OUT OF GROUP) + 6014 FORMAT(/14H G R O U P :,I4/7H REGION,3X,7HAVERAGE,5X,3HINT, + > 7HEGRATED,5X,9HCOLLISION,4X,10HABSORPTION,4X,10HNU*FISSION, + > 4X,10HPRODUCTION,8X,16HSCATTERING RATES/11X,4HFLUX, + > 10X,4HFLUX,10X,4HRATE,10X,4HRATE,10X,4HRATE,10X, + > 4HRATE,6X,26HWITHIN GROUP OUT OF GROUP) + 6020 FORMAT(1X,I4,1P,9E14.5) + 6021 FORMAT(1X,I4,1P,8E14.5,3E14.5) + 6022 FORMAT(/' REGION TOTAL LEAKAGE X-LEAKAGE', + > ' Y-LEAKAGE Z-LEAKAGE HOMOGENEOUS'/ + > ' RATE RATE ', + > ' RATE RATE LEAKAGE RATE') + 6023 FORMAT(1X,I6,1X,1P,5E14.5) + END diff --git a/Dragon/src/EDIPXS.f b/Dragon/src/EDIPXS.f new file mode 100644 index 0000000..7e81b8b --- /dev/null +++ b/Dragon/src/EDIPXS.f @@ -0,0 +1,571 @@ +*DECK EDIPXS + SUBROUTINE EDIPXS(IPEDIT,IADJ,IPRINT,NL,NDEL,NALBP,ITRANC,NSAVES, + > NGCOND,NMERGE,ILEAKS,NW,NTAUXT,EIGENK,B2,IGOVE, + > CUREIN,NIFISS,CURNAM,NEDMAC,VOLMER,WLETYC, + > WENERG,SCATTD,RATECM,FLUXCM,FADJCM,SIGS,SCATTS, + > DISFCT,ALBP,TAUXE,HVECT,OVERV,HFACT,HSPH,NENER, + > TIMEF,LH,LSPH) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Save homogenized/condensed macroscopic cross sections. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPEDIT pointer to the edition LCM object. +* IADJ type of flux weighting: +* = 0 direct flux weighting; +* = 1 direct-adjoint flux weighting. +* IPRINT print level; +* = 0 no print; +* = 1 print fluxes; +* = 2 1+print reaction rates; +* = 3 2+print homogenized cross sections. +* NL number of Legendre orders. +* NDEL number of delayed precursor groups. +* NALBP number of physical albedos. +* ITRANC type of transport correction. +* NSAVES homogenized cross section compute/save flag: +* = 0 no compute, no save; +* = 1 compute, no save; +* = 2 compute and save. +* NGCOND number of groups condensed. +* NMERGE number of regions merged. +* ILEAKS type of leakage calculation: +* = 0 no leakage; +* = 1 homogeneous leakage (Diffon); +* = 2 isotropic streaming (Ecco); +* = 3 anisotropic streaming (Tibere); +* = 4 inconsistent model (1/3*strd); +* = 10 isotropic diffusion coefficients recovered from input +* macrolib; +* = 11 anisotropic diffusion coefficients recovered from input +* macrolib. +* NW type of weighting for PN cross section info (=0 P0; =1 P1). +* NTAUXT number of reaction rate edits (=15+2*NDEL). +* EIGENK eigenvalue for problem. +* B2 square buckling: +* for ILEAKS=1,2,4: B2(4) is homogeneous; +* for ILEAKS=3: B2(1),B2(2),B2(3) are directional heterogeneous +* and B2(4) is homogeneous. +* IGOVE Golfier-Vergain flag (=0/1: don't/use Golfier-Vergain equ'n). +* CUREIN infinite multiplication factor. +* NIFISS number of fissile isotopes. +* CURNAM name of LCM directory where the merged/condensed cross +* sections are stored. +* NEDMAC number of extra edit vectors. +* VOLMER volume of region merged. +* WLETYC lethargy width condensed. +* WENERG energy group limits. +* SCATTD double precision scattering rates. +* NENER number of energy groups limits. +* TIMEF time stamp in day/burnup/irradiation. +* LH flag set to true if H-factors are set. +* LSPH flag set to true if SPH factors are set. +* +*Parameters: output +* RATECM averaged region/group cross sections: +* = RATECM(*,1) = total P0; +* = RATECM(*,2) = total P1; +* = RATECM(*,NW+2) = absorption; +* = RATECM(*,NW+3) = fission; +* = RATECM(*,NW+4) = fixed sources / productions; +* = RATECM(*,NW+5) = leakage; +* = RATECM(*,NW+6) = total out of group scattering; +* = RATECM(*,NW+7) = diagonal scattering x-s; +* = RATECM(*,NW+8) = chi; +* = RATECM(*,NW+9) = wims type transport correction; +* = RATECM(*,NW+10) = x-directed leakage; +* = RATECM(*,NW+11) = y-directed leakage; +* = RATECM(*,NW+12) = z-directed leakage; +* = RATECM(*,NW+13) = nu-sigf for delayed neutrons; +* = RATECM(*,NW+13+NDEL) = fission spectra for delayed neutrons. +* FLUXCM integrated region/group fluxes: +* = FLUXCM(*,1) = fluxes P0; +* = FLUXCM(*,2) = fluxes P1. +* FADJCM averaged region/group afjoint fluxes: +* = FADJCM(*,1) = adjoint fluxes P0; +* = FADJCM(*,2) = adjoint fluxes P1. +* SIGS Legendre dependent scattering cross sections. +* SCATTS homogenized scattering cross sections. +* DISFCT disadvantage factor. +* ALBP physical albedos. +* TAUXE extra edit rates. +* HVECT extra edit names. +* OVERV 1/v merge condensed. +* HFACT H-factors condensed. +* HSPH SPH factors condensed. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPEDIT + INTEGER IADJ,IPRINT,NL,NDEL,NALBP,ITRANC,NSAVES,NGCOND,NMERGE, + > ILEAKS,NW,NTAUXT,NIFISS,NEDMAC,NENER,IGOVE + REAL EIGENK,B2(4),CUREIN,VOLMER(NMERGE),WLETYC(NGCOND), + > WENERG(NGCOND+1),RATECM(NMERGE,NGCOND,NTAUXT), + > FLUXCM(NMERGE,NGCOND,NW+1),FADJCM(NMERGE,NGCOND,NW+1), + > SIGS(NMERGE,NGCOND,NL), + > SCATTS(NMERGE,NGCOND,NGCOND,NL),DISFCT(NGCOND), + > ALBP(NALBP,NGCOND,NGCOND),TAUXE(NMERGE,NGCOND,NEDMAC), + > OVERV(NMERGE,NGCOND),HFACT(NMERGE,NGCOND), + > HSPH(NMERGE,NGCOND),TIMEF(3) + LOGICAL LH,LSPH + CHARACTER CURNAM*12,HVECT(NEDMAC)*8 + DOUBLE PRECISION SCATTD(NMERGE,NGCOND,NGCOND,NL) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPEDIT,KPEDIT + CHARACTER APG*3 + PARAMETER (IUNOUT=6,APG=' > ',ILCMUP=1,ILCMDN=2,NSTATE=40) + CHARACTER CEDNAM*12,HSIGN*12,CM*2 + INTEGER IDATA(NSTATE),ISTATE(NSTATE) + DOUBLE PRECISION SCATWG,SCATTN,FAC1,FAC2 + LOGICAL LAL1D +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) ::IJJ,NJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) ::SCATC,ALPHA + REAL, ALLOCATABLE, DIMENSION(:,:) :: FACT,ALB1 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IJJ(NMERGE),NJJ(NMERGE),IPOS(NMERGE)) + ALLOCATE(SCATC(NMERGE*NGCOND),FACT(NMERGE,NW+1),ALPHA(NGCOND)) +*---- +* COMPUTE MERGED/CONDENSED X-S +*---- + IF(NSAVES.GE.1) THEN + IDATA(4)=0 + DO 200 IGR=1,NGCOND + DO 40 IKK=1,NMERGE + DO 5 IL=1,NW+1 + IF(FLUXCM(IKK,IGR,1).EQ.0.0) THEN + FACT(IKK,IL)=0.0 + ELSE + FACT(IKK,IL)=1.0/FLUXCM(IKK,IGR,IL) + ENDIF + 5 CONTINUE + RATECM(IKK,IGR,NW+3)=RATECM(IKK,IGR,NW+3)*FACT(IKK,1) + IF((RATECM(IKK,IGR,NW+3).NE.0.0).OR. + > (RATECM(IKK,IGR,NW+8).NE.0.0)) IDATA(4)=1 + IF(IADJ.EQ.0) THEN + DO IW=1,NW+1 + RATECM(IKK,IGR,IW)=RATECM(IKK,IGR,IW)*FACT(IKK,IW) + ENDDO + RATECM(IKK,IGR,NW+2)=RATECM(IKK,IGR,NW+2)*FACT(IKK,1) + RATECM(IKK,IGR,NW+4)=RATECM(IKK,IGR,NW+4)*FACT(IKK,1) + IF(NENER.GT.0) OVERV(IKK,IGR)=OVERV(IKK,IGR)*FACT(IKK,1) + IF(LH) HFACT(IKK,IGR)=HFACT(IKK,IGR)*FACT(IKK,1) + IF(LSPH) HSPH(IKK,IGR)=HSPH(IKK,IGR)*FACT(IKK,1) + IF(ITRANC.NE.0) RATECM(IKK,IGR,NW+9)=RATECM(IKK,IGR,NW+9) + > *FACT(IKK,1) + DO 10 IL=1,NL + IW=MIN(IL,NW+1,2) + SIGS(IKK,IGR,IL)=SIGS(IKK,IGR,IL)*FACT(IKK,IW) + 10 CONTINUE + ELSE IF(IADJ.EQ.1) THEN + DO IL=1,NW+1 + FAD1=FADJCM(IKK,IGR,IL) + RATECM(IKK,IGR,IL)=RATECM(IKK,IGR,IL)*FACT(IKK,IL)/FAD1 + ENDDO + FAD1=FADJCM(IKK,IGR,1) + RATECM(IKK,IGR,NW+2)=RATECM(IKK,IGR,NW+2)*FACT(IKK,1)/FAD1 + RATECM(IKK,IGR,NW+4)=RATECM(IKK,IGR,NW+4)*FACT(IKK,1)/FAD1 + IF(NENER.GT.0) OVERV(IKK,IGR)=OVERV(IKK,IGR)*FACT(IKK,1) + > /FAD1 + IF(LH) HFACT(IKK,IGR)=HFACT(IKK,IGR)*FACT(IKK,1)/FAD1 + IF(LSPH) HSPH(IKK,IGR)=HSPH(IKK,IGR)*FACT(IKK,1)/FAD1 + IF(ITRANC.NE.0) RATECM(IKK,IGR,NW+9)=RATECM(IKK,IGR,NW+9) + > *FACT(IKK,1)/FAD1 + DO 20 IL=1,NL + IW=MIN(IL,NW+1,2) + SIGS(IKK,IGR,IL)=SIGS(IKK,IGR,IL)*FACT(IKK,IW)/ + > FADJCM(IKK,IGR,IW) + 20 CONTINUE + ENDIF + DO 30 IDEL=1,NDEL + K=NW+12+IDEL + RATECM(IKK,IGR,K)=RATECM(IKK,IGR,K)*FACT(IKK,1) + 30 CONTINUE + 40 CONTINUE + IF((ILEAKS.EQ.1).OR.(ILEAKS.EQ.2).OR.(ILEAKS.EQ.4)) THEN + IF(IADJ.EQ.0) THEN + DO 50 IKK=1,NMERGE + RATECM(IKK,IGR,NW+5)=RATECM(IKK,IGR,NW+5)*FACT(IKK,1) + 50 CONTINUE + ELSE IF(IADJ.EQ.1) THEN + DEN2=0.0 + DO 60 IKK=1,NMERGE + DEN2=DEN2+FADJCM(IKK,IGR,1) + RATECM(IKK,IGR,NW+5)=RATECM(IKK,IGR,NW+5)*FACT(IKK,1)/ + > FADJCM(IKK,IGR,1) + 60 CONTINUE + ENDIF + ELSE IF(ILEAKS.GT.0) THEN + DO 70 IKK=1,NMERGE + RATECM(IKK,IGR,NW+5)=RATECM(IKK,IGR,NW+5)*FACT(IKK,1) + RATECM(IKK,IGR,NW+10)=RATECM(IKK,IGR,NW+10)*FACT(IKK,1) + RATECM(IKK,IGR,NW+11)=RATECM(IKK,IGR,NW+11)*FACT(IKK,1) + RATECM(IKK,IGR,NW+12)=RATECM(IKK,IGR,NW+12)*FACT(IKK,1) + 70 CONTINUE + ENDIF + DO 100 JGR=1,NGCOND + DO 90 IKK=1,NMERGE + DO 80 IL=1,NL + IW=MIN(IL,NW+1) + IF(IADJ.EQ.0) THEN + SCATTS(IKK,JGR,IGR,IL)=REAL(SCATTD(IKK,JGR,IGR,IL) + > *FACT(IKK,IW)) + ELSE IF(IADJ.EQ.1) THEN + SCATTS(IKK,JGR,IGR,IL)=REAL(SCATTD(IKK,JGR,IGR,IL) + > *FACT(IKK,IW)/FADJCM(IKK,JGR,IW)) + ENDIF + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + DO 110 IKK=1,NMERGE + RATECM(IKK,IGR,NW+7)=SCATTS(IKK,IGR,IGR,1) + 110 CONTINUE + DO 130 IED=1,NEDMAC + DO 120 IKK=1,NMERGE + IF(IADJ.EQ.0) THEN + TAUXE(IKK,IGR,IED)=TAUXE(IKK,IGR,IED)*FACT(IKK,1) + ELSE IF(IADJ.EQ.1) THEN + TAUXE(IKK,IGR,IED)=TAUXE(IKK,IGR,IED)*FACT(IKK,1)/ + > FADJCM(IKK,IGR,1) + ENDIF + 120 CONTINUE + 130 CONTINUE + 200 CONTINUE + IF(NSAVES.EQ.2) THEN +*---- +* COMPUTE THE GOLFIER-VERGAIN FACTORS +*---- + IF(IGOVE.EQ.1) THEN + DO 205 IGR=1,NGCOND + FAC1=0.0D0 + FAC2=0.0D0 + DO 204 IKK=1,NMERGE + FAC1=FAC1+RATECM(IKK,IGR,NW+5)*FLUXCM(IKK,IGR,1) + FAC2=FAC2+FLUXCM(IKK,IGR,1)/(3.0*(RATECM(IKK,IGR,1)- + > SIGS(IKK,IGR,2))) + 204 CONTINUE + ALPHA(IGR)=REAL(FAC1/FAC2) + 205 CONTINUE + IF(IPRINT.GE.3) WRITE(IUNOUT,6000) ALPHA(:) + ENDIF +*---- +* SAVE MERGED/CONDENSED X-S ON LCM +*---- + CALL LCMSIX(IPEDIT,CURNAM,ILCMUP) + CALL LCMSIX(IPEDIT,'MACROLIB',ILCMUP) + CALL LCMPUT(IPEDIT,'TIMESTAMP',3,2,TIMEF) + IDATA(1)=NGCOND + IDATA(2)=NMERGE + IDATA(3)=NL + IDATA(5)=NEDMAC + IDATA(6)=ITRANC + IDATA(7)=NDEL + IDATA(15)=IADJ + IF(NEDMAC.GT.0) THEN + CALL LCMPTC(IPEDIT,'ADDXSNAME-P0',8,NEDMAC,HVECT) + ENDIF + JPEDIT=LCMLID(IPEDIT,'GROUP',NGCOND) + DO 210 IGR=1,NGCOND + KPEDIT=LCMDIL(JPEDIT,IGR) + IF(NEDMAC.GT.0) THEN + DO 211 IED=1,NEDMAC + CEDNAM=HVECT(IED) + IF((CEDNAM(:2).EQ.'NW').OR. + > (CEDNAM.EQ.'H-FACTOR')) GO TO 211 + CALL LCMPUT(KPEDIT,CEDNAM,NMERGE,2,TAUXE(1,IGR,IED)) + 211 CONTINUE + ENDIF + IF(NENER.GT.0) CALL LCMPUT(KPEDIT,'OVERV',NMERGE,2, + > OVERV(1,IGR)) + IF(LH) CALL LCMPUT(KPEDIT,'H-FACTOR',NMERGE,2,HFACT(1,IGR)) + IF(LSPH) CALL LCMPUT(KPEDIT,'NSPH',NMERGE,2,HSPH(1,IGR)) + DO IW=1,MIN(NW+1,10) + WRITE(CEDNAM,'(4HNTOT,I1)') IW-1 + CALL LCMPUT(KPEDIT,CEDNAM,NMERGE,2,RATECM(1,IGR,IW)) + ENDDO + CALL LCMPUT(KPEDIT,'ABS',NMERGE,2,RATECM(1,IGR,NW+2)) + CALL LCMPUT(KPEDIT,'PRODUCTION',NMERGE,2,RATECM(1,IGR,NW+4)) + DO 212 IKK=1,NMERGE + RATECM(IKK,IGR,NW+6)=RATECM(IKK,IGR,1)-RATECM(IKK,IGR,NW+2) + 212 CONTINUE + IF(IDATA(4).EQ.1) THEN + CALL LCMPUT(KPEDIT,'NUSIGF',NMERGE,2,RATECM(1,IGR,NW+3)) + CALL LCMPUT(KPEDIT,'CHI',NMERGE,2,RATECM(1,IGR,NW+8)) + DO 901 IDEL=1,NDEL + K=NW+12+IDEL + WRITE(CEDNAM,'(6HNUSIGF,I2.2)') IDEL + CALL LCMPUT(KPEDIT,CEDNAM,NMERGE,2,RATECM(1,IGR,K)) + WRITE(CEDNAM,'(3HCHI,I2.2)') IDEL + CALL LCMPUT(KPEDIT,CEDNAM,NMERGE,2,RATECM(1,IGR,NDEL+K)) + 901 CONTINUE + ENDIF + IF(ITRANC.NE.0) THEN + CALL LCMPUT(KPEDIT,'TRANC',NMERGE,2,RATECM(1,IGR,NW+9)) + ENDIF + IF(IGOVE.EQ.1) THEN + ! use the Golfier-Vergain formula + SCATC(:NMERGE)=ALPHA(IGR)/(3.0*(RATECM(:NMERGE,IGR,1) + > -SIGS(:NMERGE,IGR,2))) + CALL LCMPUT(KPEDIT,'DIFF',NMERGE,2,SCATC) + ELSE IF((ILEAKS.EQ.1).OR.(ILEAKS.EQ.2).OR.(ILEAKS.EQ.10)) + > THEN + CALL LCMPUT(KPEDIT,'DIFF',NMERGE,2,RATECM(1,IGR,NW+5)) + ELSE IF(ILEAKS.EQ.3) THEN + CALL LCMPUT(KPEDIT,'DIFF',NMERGE,2,RATECM(1,IGR,NW+5)) + CALL LCMPUT(KPEDIT,'DIFFX',NMERGE,2,RATECM(1,IGR,NW+10)) + CALL LCMPUT(KPEDIT,'DIFFY',NMERGE,2,RATECM(1,IGR,NW+11)) + CALL LCMPUT(KPEDIT,'DIFFZ',NMERGE,2,RATECM(1,IGR,NW+12)) + ELSE IF(ILEAKS.EQ.11) THEN + CALL LCMPUT(KPEDIT,'DIFFX',NMERGE,2,RATECM(1,IGR,NW+10)) + CALL LCMPUT(KPEDIT,'DIFFY',NMERGE,2,RATECM(1,IGR,NW+11)) + CALL LCMPUT(KPEDIT,'DIFFZ',NMERGE,2,RATECM(1,IGR,NW+12)) + ENDIF + CALL LCMPUT(KPEDIT,'FLUX-INTG',NMERGE,2,FLUXCM(1,IGR,1)) + DO IL=2,MIN(NW+1,10) + WRITE(CEDNAM,'(11HFLUX-INTG-P,I1)') IL-1 + CALL LCMPUT(KPEDIT,CEDNAM,NMERGE,2,FLUXCM(1,IGR,IL)) + ENDDO + IF(IADJ.EQ.1) THEN + DO IL=1,MIN(NW+1,10) + WRITE(CEDNAM,'(4HNWAT,I1)') IL-1 + CALL LCMPUT(KPEDIT,CEDNAM,NMERGE,2,FADJCM(1,IGR,IL)) + ENDDO + ENDIF + DO 350 IL=1,NL + WRITE (CM,'(I2.2)') IL-1 + IPOSIT=0 + DO 214 IKK=1,NMERGE + J2=IGR + J1=IGR + DO 215 JGR=1,NGCOND + IF(SCATTS(IKK,IGR,JGR,IL).NE.0.0) THEN + J2=MAX(J2,JGR) + J1=MIN(J1,JGR) + ENDIF + 215 CONTINUE + NJJ(IKK)=J2-J1+1 + IJJ(IKK)=J2 + IPOS(IKK)=IPOSIT+1 + DO 216 JGR=J2,J1,-1 + IPOSIT=IPOSIT+1 + SCATC(IPOSIT)=SCATTS(IKK,IGR,JGR,IL) + 216 CONTINUE + 214 CONTINUE + CALL LCMPUT(KPEDIT,'SIGS'//CM,NMERGE,2,SIGS(1,IGR,IL)) + CALL LCMPUT(KPEDIT,'SIGW'//CM,NMERGE,2,SCATTS(1,IGR,IGR,IL)) + CALL LCMPUT(KPEDIT,'SCAT'//CM,IPOSIT,2,SCATC) + CALL LCMPUT(KPEDIT,'NJJS'//CM,NMERGE,1,NJJ) + CALL LCMPUT(KPEDIT,'IJJS'//CM,NMERGE,1,IJJ) + CALL LCMPUT(KPEDIT,'IPOS'//CM,NMERGE,1,IPOS) + 350 CONTINUE + IF(IPRINT.GE.4) THEN + WRITE(IUNOUT,'(/14H G R O U P :,I4)') IGR + CALL LCMLIB(KPEDIT) + ENDIF + 210 CONTINUE + IF((ILEAKS.EQ.1).OR.(ILEAKS.EQ.2).OR.(ILEAKS.EQ.10)) THEN + CALL LCMPUT(IPEDIT,'B2 B1HOM',1,2,B2(4)) + ELSE IF((ILEAKS.EQ.3).OR.(ILEAKS.EQ.11)) THEN + CALL LCMPUT(IPEDIT,'B2 B1HOM',1,2,B2(4)) + CALL LCMPUT(IPEDIT,'B2 HETE',3,2,B2) + ENDIF + IDATA(8)=NALBP + DO 217 I=9,NSTATE + IDATA(I)=0 + 217 CONTINUE + IF((ILEAKS.EQ.1).OR.(ILEAKS.EQ.2).OR.(ILEAKS.EQ.4).OR. + > (ILEAKS.EQ.10)) THEN + IDATA(9)=1 + ELSE IF((ILEAKS.EQ.3).OR.(ILEAKS.EQ.11)) THEN + IDATA(9)=2 + ENDIF + IDATA(10)=NW + IF(LSPH) THEN + IDATA(14)=1 + CALL LCMSIX(IPEDIT,'SPH',1) + ISTATE(:)=0 + ISTATE(1)=4 + ISTATE(2)=1 + ISTATE(6)=1 + ISTATE(7)=1 + ISTATE(8)=NGCOND + CALL LCMPUT(IPEDIT,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMSIX(IPEDIT,' ',2) + ENDIF + CALL LCMPUT(IPEDIT,'STATE-VECTOR',NSTATE,1,IDATA) + HSIGN='L_MACROLIB' + CALL LCMPTC(IPEDIT,'SIGNATURE',12,HSIGN) + IF(NENER.GT.0) THEN + CALL LCMPUT(IPEDIT,'ENERGY',NGCOND+1,2,WENERG) + CALL LCMPUT(IPEDIT,'DELTAU',NGCOND,2,WLETYC) + ENDIF + CALL LCMPUT(IPEDIT,'VOLUME',NMERGE,2,VOLMER) + IF((EIGENK.NE.0.0).AND.(NIFISS.GT.0)) THEN + CALL LCMPUT(IPEDIT,'K-EFFECTIVE',1,2,EIGENK) + ENDIF + IF((CUREIN.NE.0.0).AND.(NIFISS.GT.0)) THEN + CALL LCMPUT(IPEDIT,'K-INFINITY',1,2,CUREIN) + ENDIF + CALL LCMPUT(IPEDIT,'FLUXDISAFACT',NGCOND,2,DISFCT) + IF(NALBP.GT.0) THEN + LAL1D=.TRUE. + DO IAL=1,NALBP + DO IGR=1,NGCOND + DO JGR=1,NGCOND + IF((IGR.NE.JGR).AND.(ALBP(IAL,IGR,JGR).NE.0.0)) THEN + LAL1D=.FALSE. + GO TO 218 + ENDIF + ENDDO + ENDDO + ENDDO + 218 IF(LAL1D) THEN +* diagonal physical albedos + ALLOCATE(ALB1(NALBP,NGCOND)) + DO IAL=1,NALBP + DO IGR=1,NGCOND + ALB1(IAL,IGR)=ALBP(IAL,IGR,IGR) + ENDDO + ENDDO + CALL LCMPUT(IPEDIT,'ALBEDO',NALBP*NGCOND,2,ALB1) + DEALLOCATE(ALB1) + ELSE +* matrix physical albedos + CALL LCMPUT(IPEDIT,'ALBEDO',NALBP*NGCOND*NGCOND,2,ALBP) + ENDIF + ENDIF + CALL LCMSIX(IPEDIT,' ',ILCMDN) + CALL LCMSIX(IPEDIT,' ',ILCMDN) + IF(IPRINT.GT.0) WRITE(IUNOUT,6031) CURNAM + ENDIF + ENDIF +*---- +* PRINT X-S +*---- + IF(IPRINT.GE.3) THEN + IF(IGOVE.EQ.1) THEN + WRITE(IUNOUT,'(/41H EDIPXS: USE THE GOLFIER-VERGAIN APPROXIM, + > 43HATION FOR DIFFUSION COEFFICIENT CALCULATION)') + ENDIF + WRITE(IUNOUT,6010) + DO 170 IGR=1,NGCOND + IF((ILEAKS.EQ.1).OR.(ILEAKS.EQ.2).OR.(ILEAKS.EQ.4).OR. + > (ILEAKS.EQ.10)) THEN + WRITE(IUNOUT,6020) IGR + ELSE + WRITE(IUNOUT,6021) IGR + ENDIF + DO 171 IKK=1,NMERGE +*---- +* UNCOMMENT THE 4 LINES TO PERFORM TRANSPORT CORRECTION +*---- + TOTAL=RATECM(IKK,IGR,1) + SCATWG=SCATTS(IKK,IGR,IGR,1) +* IF(ITRANC.NE.0) THEN +* TOTAL=TOTAL-RATECM(IKK,IGR,NW+9) +* SCATWG=SCATWG-RATECM(IKK,IGR,NW+9) +* ENDIF +* + IF (FLUXCM(IKK,IGR,1).NE.0.0) THEN + FLXAVG=FLUXCM(IKK,IGR,1)/VOLMER(IKK) + SCATTN=0.0D0 + DO 172 JGR=1,NGCOND + IF(JGR.NE.IGR) SCATTN=SCATTN+SCATTS(IKK,JGR,IGR,1) + 172 CONTINUE + IF((ILEAKS.EQ.1).OR.(ILEAKS.EQ.2).OR.(ILEAKS.EQ.4).OR. + > (ILEAKS.EQ.10)) THEN + WRITE(IUNOUT,6022) IKK,FLXAVG,TOTAL, + > RATECM(IKK,IGR,NW+5),RATECM(IKK,IGR,NW+2), + > RATECM(IKK,IGR,NW+3),RATECM(IKK,IGR,NW+8),SCATWG,SCATTN + ELSE + WRITE(IUNOUT,6022) IKK,FLXAVG,TOTAL, + > RATECM(IKK,IGR,NW+2),RATECM(IKK,IGR,NW+3), + > RATECM(IKK,IGR,NW+8),SCATWG,SCATTN + ENDIF + ENDIF + 171 CONTINUE + IF((ILEAKS.EQ.3).OR.(ILEAKS.EQ.11)) THEN + WRITE(IUNOUT,6024) + DO 173 IKK=1,NMERGE + WRITE(IUNOUT,6025) IKK,RATECM(IKK,IGR,NW+10), + > RATECM(IKK,IGR,NW+11),RATECM(IKK,IGR,NW+12), + > RATECM(IKK,IGR,NW+5) + 173 CONTINUE + ENDIF + WRITE(IUNOUT,6026) DISFCT(IGR) + 170 CONTINUE + ENDIF + IF(IPRINT.GE.4) THEN + DO 190 IKK=1,NMERGE + WRITE(IUNOUT,6027) IKK,(JGR,JGR=1,NGCOND) + DO 180 IGR=1,NGCOND +*---- +* UNCOMMENT THE FOLLOWING LINE TO PERFORM TRANSPORT CORRECTION +*---- + SCATWG=SCATTS(IKK,IGR,IGR,1) +* IF(ITRANC.NE.0) SCATWG=SCATWG-RATECM(IKK,IGR,NW+9) +* + WRITE(IUNOUT,6028) IGR,(SCATTS(IKK,JGR,IGR,1),JGR=1,IGR-1), + > SCATWG,(SCATTS(IKK,JGR,IGR,1),JGR=IGR+1,NGCOND) + 180 CONTINUE + WRITE (IUNOUT,'(//)') + 190 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(ALPHA,FACT,SCATC) + DEALLOCATE(IPOS,NJJ,IJJ) + RETURN +*---- +* FORMAT +*---- + 6000 FORMAT(/33H EDIPXS: Golfier-Vergain factors=,1P,10E12.4/(33X, + > 10E12.4)) + 6010 FORMAT(/' F L U X E S A N D H O M O G E N I Z E D X - S'/ + > 1X,51(1H-)) + 6020 FORMAT(/' G R O U P :',I4/ + >1X,'REGION',3X,'AVERAGE',9X,'NTOT0',7X,'DIFFUSION',5X, + >'ABSORPTION',5X,'NUSIGF',8X,'FISSION',10X,'SCATTERING X-S'/11X, + >'FLUX',12X,'X-S',7X,'COEFFICIENT',7X,'X-S',10X,'X-S',10X, + >'SPECTRUM',2X,'WITHIN GROUP',2X,'OUT OF GROUP') + 6021 FORMAT(/' G R O U P :',I4/ + >1X,'REGION',3X,'AVERAGE',9X,'NTOT0',7X, + >'ABSORPTION',5X,'NUSIGF',8X,'FISSION',10X,'SCATTERING X-S'/11X, + >'FLUX',12X,'X-S',11X,'X-S',10X,'X-S',10X,'SPECTRUM',2X, + >'WITHIN GROUP',2X,'OUT OF GROUP') + 6022 FORMAT(1X,I4,1P,8E14.5) + 6024 FORMAT(/' REGION X-LEAKAGE Y-LEAKAGE Z-LEAKAGE', + >' HOM-LEAKAGE'/' COEFFICIENT COEFFICIENT ', + >'COEFFICIENT COEFFICIENT') + 6025 FORMAT(1X,I6,1X,1P,5E14.5) + 6026 FORMAT(/' FLUX DISADVANTAGE FACTOR =',1P,E14.5) + 6027 FORMAT(/47H SCATTERING TRANSFER X-S (I TOWARD J) IN REGION,I5,1H: + > //(11X,2HJ=,I4,:,6X,2HJ=,I4,:,6X,2HJ=,I4,:,6X,2HJ=,I4,:,6X,2HJ=, + > I4,:,6X,2HJ=,I4,:,6X,2HJ=,I4,:,6X,2HJ=,I4,:,6X,2HJ=,I4,:,6X, + > 2HJ=,I4)) + 6028 FORMAT(3H I=,I4,2H: ,1P,10E12.4/(9X,10E12.4)) + 6031 FORMAT(/53H MERGED/CONDENSED SET OF X-S SAVED IN LCM DIRECTORY ', + > A12,2H'./) + END diff --git a/Dragon/src/EDIRAT.f b/Dragon/src/EDIRAT.f new file mode 100644 index 0000000..b96cd22 --- /dev/null +++ b/Dragon/src/EDIRAT.f @@ -0,0 +1,136 @@ +*DECK EDIRAT + SUBROUTINE EDIRAT(IOPERA,NREGIO,NBMIX,MATCOD,FLXINT,AFLUX,RATES, + > SIGMAX,IMERGE,NMERGE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Evaluate reaction rates from cross sections. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IOPERA type of action taken: +* = 2 add cross section (no flux); +* = 1 add reaction rates; +* = 0 evaluate integrated flux; +* =-1 subtract reaction rates. +* NREGIO number of regions. +* NBMIX number of mixtures. +* MATCOD material per region. +* FLXINT integrated fluxes. +* AFLUX adjoint fluxes. +* SIGMAX cross section array. +* IMERGE region merging matrix. +* NMERGE number of merged regions. +* +*Parameters: input/output +* RATES initial and final reaction rates. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IOPERA,NREGIO,NBMIX,MATCOD(NREGIO),IMERGE(NREGIO), + > NMERGE + REAL FLXINT(NREGIO),AFLUX(NREGIO),RATES(NMERGE), + > SIGMAX(0:NBMIX) + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DBRAT +*---- +* SCRATCH STORAGE ALLOCATION +* DBRAT double-precision reaction rates. +*---- + ALLOCATE(DBRAT(0:NMERGE)) +*---- +* INITIALIZE DOUBLE PRECISION REACTION RATES +*---- + DO 90 IREG=0,NMERGE + DBRAT(IREG)=0.0D0 + 90 CONTINUE + IF(IOPERA.EQ.0) THEN +*---- +* INTEGRATED FLUXES +*---- + DO 100 IREG=1,NREGIO + IRATME=IMERGE(IREG) + DBRAT(IRATME)=DBRAT(IRATME)+DBLE(FLXINT(IREG)) + 100 CONTINUE + ELSE IF(IOPERA.EQ.1) THEN +*---- +* SUM REACTION RATES +*---- + DO 110 IREG=1,NREGIO + IRATME=IMERGE(IREG) + MATNUM=MATCOD(IREG) + DBRAT(IRATME)=DBRAT(IRATME)+DBLE(FLXINT(IREG)) + > *DBLE(SIGMAX(MATNUM)) + 110 CONTINUE + ELSE IF(IOPERA.EQ.-1) THEN +*---- +* SUBSTRACT REACTION RATES +*---- + DO 120 IREG=1,NREGIO + IRATME=IMERGE(IREG) + MATNUM=MATCOD(IREG) + DBRAT(IRATME)=DBRAT(IRATME)-DBLE(FLXINT(IREG)) + > *DBLE(SIGMAX(MATNUM)) + 120 CONTINUE + ELSE IF(IOPERA.EQ.2) THEN +*---- +* ADD CROSS SECTIONS +*---- + DO 130 IREG=1,NREGIO + IRATME=IMERGE(IREG) + MATNUM=MATCOD(IREG) + DBRAT(IRATME)=DBRAT(IRATME)+DBLE(SIGMAX(MATNUM)) + 130 CONTINUE + ELSE IF(IOPERA.EQ.10) THEN +*---- +* INTEGRATED ADJOINT FLUXES +*---- + DO 140 IREG=1,NREGIO + IRATME=IMERGE(IREG) + DBRAT(IRATME)=DBRAT(IRATME)+DBLE(FLXINT(IREG)) + > *DBLE(AFLUX(IREG)) + 140 CONTINUE + ELSE IF(IOPERA.EQ.11) THEN +*---- +* SUM ADJOINT-WEIGHTED REACTION RATES +*---- + DO 150 IREG=1,NREGIO + IRATME=IMERGE(IREG) + MATNUM=MATCOD(IREG) + DBRAT(IRATME)=DBRAT(IRATME)+DBLE(FLXINT(IREG)) + > *DBLE(AFLUX(IREG))*DBLE(SIGMAX(MATNUM)) + 150 CONTINUE + ELSE IF(IOPERA.EQ.-11) THEN +*---- +* SUBSTRACT ADJOINT-WEIGHTED REACTION RATES +*---- + DO 160 IREG=1,NREGIO + IRATME=IMERGE(IREG) + MATNUM=MATCOD(IREG) + DBRAT(IRATME)=DBRAT(IRATME)-DBLE(FLXINT(IREG)) + > *DBLE(AFLUX(IREG))*DBLE(SIGMAX(MATNUM)) + 160 CONTINUE + ENDIF +*---- +* STORE DOUBLE PRECISION REACTION RATES IN SINGLE PRECISION VECTOR +*---- + DO 170 IREG=1,NMERGE + RATES(IREG)=RATES(IREG)+REAL(DBRAT(IREG)) + 170 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(DBRAT) + RETURN + END diff --git a/Dragon/src/EDIRES.f b/Dragon/src/EDIRES.f new file mode 100644 index 0000000..b49cf83 --- /dev/null +++ b/Dragon/src/EDIRES.f @@ -0,0 +1,520 @@ +*DECK EDIRES + SUBROUTINE EDIRES(IPEDIT,IPFLUX,IPLIB,IADJ,NL,NDEL,NBESP,NBISO, + 1 NDEPL,ISONAM,ISONRF,IPISO,MIX,TN,NED,HVECT,NOUT,HVOUT,IPRINT, + 2 NGROUP,NGCOND,NBMIX,NREGIO,NMERGE,NDFI,NDFP,ILEAKS,ILUPS,NW, + 3 MATCOD,VOLUME,KEYFLX,CURNAM,IGCOND,IMERGE,FLUXES,AFLUXE,EIGENK, + 4 EIGINF,B2,DEN,ITYPE,LSISO,EMEVF,EMEVG,DECAY,YIELD,FIPI,FIFP, + 5 PYIELD,ITRANC,LISO,NMLEAK) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of residual macroscopic cross sections. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPEDIT pointer to the edition LCM object (L_EDIT signature). +* IPFLUX pointer to the solution LCM object (L_FLUX signature). +* IPLIB pointer to the reference microscopic cross section library +* LCM object (L_LIBRARY signature). +* IADJ type of flux weighting: +* =0: direct flux weighting; +* =1: direct-adjoint flux weighting. +* NL number of Legendre orders required in the calculation +* (NL=1 or higher). +* NDEL number of delayed precursor groups. +* NBESP number of energy-dependent fission spectra. +* NBISO number of isotopes. +* NDEPL number of depleting isotopes. +* ISONAM local names of NBISO isotopes: +* chars 1 to 8 is the local isotope name; +* chars 9 to 12 is a suffix function of the mix number. +* ISONRF library name of isotopes. +* IPISO pointer array towards microlib isotopes. +* MIX mixture number associated with each isotope. +* TN absolute temperature associated with each isotope. +* NED number of extra vector edits from MATXS. +* HVECT MATXS names of the extra vector edits. +* NOUT number of output cross section types (set to zero to recover +* all cross section types). +* HVOUT MATXS names of the output cross section types. +* IPRINT print index. +* NGROUP number of energy groups. +* NGCOND number of condensed groups. +* NBMIX number of mixtures. +* NREGIO number of volumes. +* NMERGE number of merged regions. +* NDFI number of fissile isotopes. +* NDFP number of fission products. +* ILEAKS leakage calculation type: =0: no leakage; =1: homogeneous +* leakage (Diffon); =2: isotropic streaming (Ecco); +* =3: anisotropic streaming (Tibere). +* ILUPS up-scattering removing flag (=1 to remove up-scattering from +* output cross-sections). +* NW type of weighting for P1 cross section info (=0: P0 ; =1: P1). +* MATCOD mixture index per volume. +* VOLUME volumes. +* KEYFLX position of average fluxes. +* CURNAM name of the LCM directory where the microscopic cross sections +* are stored (blank name means no save). +* IGCOND limits of condensed groups. +* IMERGE index of merged regions. +* FLUXES fluxes. +* AFLUXE adjoint fluxes. +* EIGENK effective multiplication factor. +* EIGINF infinite multiplication factor. +* B2 bucklings. +* DEN number density of each isotope. +* ITYPE type of each isotope. +* LSISO flag for isotopes saved. +* EMEVF fission production energy. +* EMEVG capture production energy. +* DECAY radioactive decay constant. +* YIELD group-ordered condensed fission product yield. +* FIPI fissile isotope index assigned to each microlib isotope. +* FIFP fission product index assigned to each microlib isotope. +* PYIELD fissile isotope ordered condensed fission product yield. +* ITRANC type of transport correction (=0: no correction). +* LISO =.TRUE. if we want to keep all the isotopes after +* homogeneization. +* NMLEAK number of leakage zones. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPEDIT,IPFLUX,IPLIB,IPISO(NBISO) + INTEGER NL,NDEL,NBESP,NBISO,NDEPL,ISONAM(3,NBISO),ISONRF(3,NBISO), + 1 MIX(NBISO),NED,NOUT,IPRINT,NGROUP,NGCOND,NBMIX,NREGIO,NMERGE, + 2 NDFI,NDFP,ILEAKS,ILUPS,NW,MATCOD(NREGIO),KEYFLX(NREGIO), + 3 IGCOND(NGCOND),IMERGE(NREGIO),ITYPE(NBISO),LSISO(NBISO), + 4 FIPI(NBISO,NMERGE),FIFP(NBISO,NMERGE),ITRANC,NMLEAK + REAL TN(NBISO),VOLUME(NREGIO),FLUXES(NREGIO,NGROUP,NW+1), + 1 EIGENK,EIGINF,B2(4),DEN(NBISO),EMEVF(NBISO),EMEVG(NBISO), + 2 DECAY(NBISO),YIELD(NGCOND+1,NDFP,NMERGE),PYIELD(NDFI,NDFP,NMERGE) + CHARACTER HVECT(NED)*8,HVOUT(NOUT)*8,CURNAM*12 + LOGICAL LISO +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + TYPE(C_PTR) JPEDIT,KPEDIT,IPWORK,JPWORK,KPWORK + CHARACTER TEXT8*8,TEXT12*12,CM*2 + LOGICAL LWD,LYIEL,LFISS + INTEGER IPAR(NSTATE) + INTEGER, ALLOCATABLE, DIMENSION(:) :: LSIS2,IEVOL2,ISMIX,ISTYP, + 1 ISTOD,ITYPRO,JPIFI + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IHNISO,IHNIRF + REAL, ALLOCATABLE, DIMENSION(:) :: WDLA,SDEN,VOLISO,TNISO,WORK, + 1 WPY,DENTOT,DAWR,TNTOT,YIELD2,PYIELD2 + REAL, ALLOCATABLE, DIMENSION(:,:) :: GAS,SIGS,PNFIRA + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: WSCAT,WORK2 + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HMAKE +*---- +* SCRATCH STORAGE ALLOCATION (PART 1) +*---- + MAXH=9+NBESP+2*NDEL+NED+NL+3*NW + ALLOCATE(LSIS2(NBISO),IEVOL2(NBISO),JPIFI(NDFI),ITYPRO(NL)) + ALLOCATE(WDLA(NDEL),WSCAT(NGCOND,NGCOND,NL),GAS(NGCOND,MAXH), + 1 WORK(NGCOND+1),WPY(NDFI),PNFIRA(0:NDEL,2), + 2 WORK2(NGCOND,NGCOND,NL),DENTOT(NMERGE),DAWR(NMERGE), + 3 TNTOT(NMERGE),YIELD2(1+NGCOND),PYIELD2(NDFI)) + ALLOCATE(HMAKE(MAXH+NL)) +*---- +* RECOVER THE RADIOACTIVE DECAY CONSTANTS OF DELAYED NEUTRON GROUPS +* FROM THE MACROLIB IF THEY EXIST. +*---- + IOF0H=8+NED+NL+3*NW + IOF1H=8+NED+NL+3*NW+NDEL + IF(IPRINT.GT.3) THEN + WRITE(6,'(/36H EDIRES: COMPUTE A RESIDUAL ISOTOPE.)') + ENDIF + CALL LCMOP(IPWORK,'*TEMPORARY*',0,1,0) + LWD=.FALSE. + IF(CURNAM.EQ.' ') CALL XABORT('EDIRES: NO CURNAM DIRECTORY.') + CALL LCMSIX(IPEDIT,CURNAM,1) ! step up CURNAM + CALL LCMSIX(IPEDIT,'MACROLIB',1) + CALL LCMLEN(IPEDIT,'LAMBDA-D',ILONG,ITYLCM) + LWD=(ILONG.EQ.NDEL).AND.(NDEL.GT.0) + IF(LWD) CALL LCMGET(IPEDIT,'LAMBDA-D',WDLA) + CALL LCMSIX(IPEDIT,' ',2) + CALL LCMSIX(IPEDIT,' ',2) +* + IF(LWD) THEN + CALL LCMSIX(IPWORK,'DEFAULT',1) + CALL LCMSIX(IPWORK,'MACROLIB',1) + CALL LCMPUT(IPWORK,'LAMBDA-D',NDEL,2,WDLA) + CALL LCMSIX(IPWORK,' ',2) + CALL LCMSIX(IPWORK,' ',2) + ENDIF +*---- +* COMPUTE MICROSCOPIC CROSS SECTIONS OF REMAINING ISOTOPES. WE SET +* NDFI=0 TO GET RID OF PPF YIELDS. +*---- + DO 10 ISO=1,NBISO + LSIS2(ISO)=0 + IEVOL2(ISO)=1 + IF(LSISO(ISO).EQ.0) LSIS2(ISO)=1 + 10 CONTINUE + IPRIN2=MAX(0,IPRINT-2) + TEXT12='DEFAULT' + CALL EDIMIC(IPWORK,IPFLUX,IPLIB,IADJ,NL,NDEL,NBESP,NBISO,NDEPL, + 1 ISONAM,ISONRF,IPISO,MIX,TN,NED,HVECT,NOUT,HVOUT,IPRIN2,NGROUP, + 2 NGCOND,NBMIX,NREGIO,NMERGE,0,0,ILEAKS,ILUPS,NW,MATCOD,VOLUME, + 3 KEYFLX,TEXT12,IGCOND,IMERGE,FLUXES,AFLUXE,EIGENK,EIGINF,B2,DEN, + 4 ITYPE,IEVOL2,LSIS2,EMEVF,EMEVG,DECAY,YIELD,FIPI,FIFP,PYIELD, + 5 ITRANC,LISO,NMLEAK) +* + CALL LCMSIX(IPEDIT,CURNAM,1) + CALL LCMGET(IPEDIT,'STATE-VECTOR',IPAR) + JJISO=IPAR(2) + JPEDIT=LCMLID(IPEDIT,'ISOTOPESLIST',JJISO+NMERGE) + CALL LCMSIX(IPWORK,'DEFAULT',1) + CALL LCMGET(IPWORK,'STATE-VECTOR',IPAR) + JJWRK=IPAR(2) +*---- +* SCRATCH STORAGE ALLOCATION (PART 2) +*---- + MAXISO=MAX(JJISO+NMERGE,JJWRK) + ALLOCATE(IHNISO(3,MAXISO),SDEN(MAXISO),IHNIRF(3,MAXISO), + 1 ISMIX(MAXISO),ISTYP(MAXISO),ISTOD(MAXISO),VOLISO(MAXISO), + 2 TNISO(MAXISO)) +*---- +* RECOVER INFORMATION FROM EDIMIC +*---- + IF(JJWRK.GT.0) THEN + CALL LCMGET(IPWORK,'ISOTOPESUSED',IHNISO) + CALL LCMGET(IPWORK,'ISOTOPESDENS',SDEN) + CALL LCMGET(IPWORK,'ISOTOPESMIX',ISMIX) + CALL LCMGET(IPWORK,'ISOTOPESTEMP',TNISO) + JPWORK=LCMGID(IPWORK,'ISOTOPESLIST') + ENDIF +*---- +* LOOP OVER HOMOGENEOUS MIXTURES. +*---- + DO 240 INM=1,NMERGE + DO 20 J=1,MAXH+NL + HMAKE(J)=' ' + 20 CONTINUE + GAS(:NGCOND,:MAXH)=0.0 + WSCAT(:NGCOND,:NGCOND,:NL)=0.0 + PNFIRA(0:NDEL,2)=0.0 + YIELD2(:1+NGCOND)=0.0 + PYIELD2(:NDFI)=0.0 + DENTOT(INM)=0.0 + DAWR(INM)=0.0 + DECISO=0.0 + LFISS=.FALSE. + DO 170 ISO=1,JJWRK + IF(ISMIX(ISO).EQ.INM) THEN + WRITE(TEXT12,'(3A4)') (IHNISO(I0,ISO),I0=1,3) + DDEN=SDEN(ISO) + DENTOT(INM)=DENTOT(INM)+DDEN + KPWORK=LCMGIL(JPWORK,ISO) ! set ISO-th isotope + CALL LCMLEN(KPWORK,'AWR',LENGTH,ITYLCM) + IF(LENGTH.EQ.1) THEN + CALL LCMGET(KPWORK,'AWR',FLOTT) + DAWR(INM)=DAWR(INM)+DDEN*FLOTT + ENDIF + TNTOT(INM)=TNISO(ISO) + CALL LCMLEN(KPWORK,'DECAY',LENGTH,ITYLCM) + IF(LENGTH.EQ.1) THEN + CALL LCMGET(KPWORK,'DECAY',FLOTT) + DECISO=DECISO+FLOTT*DDEN + ENDIF + IF(NDFI.GT.0) THEN + CALL LCMLEN(KPWORK,'YIELD',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGCOND+1) THEN + CALL LCMGET(KPWORK,'YIELD',WORK) + DO 30 IGR=1,NGCOND+1 + YIELD2(IGR)=YIELD2(IGR)+WORK(IGR) + 30 CONTINUE + ENDIF + CALL LCMLEN(KPWORK,'PYIELD',LENGTH,ITYLCM) + IF((LENGTH.GT.0).AND.(LENGTH.EQ.NDFI)) THEN + CALL LCMGET(KPWORK,'PIFI',JPIFI) + CALL LCMGET(KPWORK,'PYIELD',WPY) + DO 40 I=1,NDFI + PYIELD2(I)=PYIELD2(I)+WPY(I) + 40 CONTINUE + ENDIF + ENDIF +* +* SET ARRAY HMAKE. + DO 45 IW=1,MIN(NW+1,10) + WRITE(TEXT8,'(3HNWT,I1)') IW-1 + CALL LCMLEN(KPWORK,TEXT8,ILONG,ITYLCM) + IF(ILONG.EQ.NGCOND) HMAKE(IW)=TEXT8 + WRITE(TEXT8,'(4HNWAT,I1)') IW-1 + CALL LCMLEN(KPWORK,TEXT8,ILONG,ITYLCM) + IF(ILONG.EQ.NGCOND) HMAKE(1+NW+IW)=TEXT8 + WRITE(TEXT8,'(4HNTOT,I1)') IW-1 + CALL LCMLEN(KPWORK,TEXT8,ILONG,ITYLCM) + IF(ILONG.EQ.NGCOND) HMAKE(2+2*NW+IW)=TEXT8 + 45 CONTINUE + IOF=3+3*NW + DO 50 IL=0,NL-1 + IOF=IOF+1 + WRITE (CM,'(I2.2)') IL + CALL LCMLEN(KPWORK,'SIGS'//CM,ILONG,ITYLCM) + IF(ILONG.EQ.NGCOND) HMAKE(IOF)='SIGS'//CM + 50 CONTINUE + IOF=IOF+1 + CALL LCMLEN(KPWORK,'NUSIGF',ILONG,ITYLCM) + IF(ILONG.EQ.NGCOND) THEN + LFISS=.TRUE. + HMAKE(IOF)='NUSIGF' + ENDIF + DO 60 IED=1,NED + IOF=IOF+1 + CALL LCMLEN(KPWORK,HVECT(IED),ILONG,ITYLCM) + IF(ILONG.EQ.NGCOND) HMAKE(IOF)=HVECT(IED) + 60 CONTINUE + CALL LCMLEN(KPWORK,'H-FACTOR',ILONG,ITYLCM) + IF(ILONG.EQ.NGCOND) HMAKE(IOF+1)='H-FACTOR' + CALL LCMLEN(KPWORK,'OVERV',ILONG,ITYLCM) + IF(ILONG.EQ.NGCOND) HMAKE(IOF+2)='OVERV' + CALL LCMLEN(KPWORK,'TRANC',ILONG,ITYLCM) + IF(ILONG.EQ.NGCOND) HMAKE(IOF+3)='TRANC' + CALL LCMLEN(KPWORK,'STRD',ILONG,ITYLCM) + IF(ILONG.EQ.NGCOND) HMAKE(IOF+4)='STRD' + IOF=IOF+4 + DO 70 IDEL=1,NDEL + IOF=IOF+1 + WRITE(TEXT8,'(6HNUSIGF,I2.2)') IDEL + CALL LCMLEN(KPWORK,TEXT8,ILONG,ITYLCM) + IF(ILONG.EQ.NGCOND) HMAKE(IOF)=TEXT8 + 70 CONTINUE + IOF=IOF+1 + CALL LCMLEN(KPWORK,'CHI',ILONG,ITYLCM) + IF(ILONG.EQ.NGCOND) HMAKE(IOF)='CHI' + DO 80 IDEL=1,NDEL + IOF=IOF+1 + WRITE(TEXT8,'(3HCHI,I2.2)') IDEL + CALL LCMLEN(KPWORK,TEXT8,ILONG,ITYLCM) + IF(ILONG.EQ.NGCOND) HMAKE(IOF)=TEXT8 + 80 CONTINUE + DO 85 ISP=1,NBESP + IOF=IOF+1 + WRITE(TEXT8,'(5HCHI--,I2.2)') ISP + CALL LCMLEN(KPWORK,TEXT8,ILONG,ITYLCM) + IF(ILONG.EQ.NGCOND) HMAKE(IOF)=TEXT8 + 85 CONTINUE + IF(IOF.NE.MAXH) CALL XABORT('EDIRES: WRONG OFFSET.') +* + PNFIRA(0:NDEL,1)=0.0 + DO 150 J=1,MAXH + IF(HMAKE(J).NE.' ') THEN + CALL LCMLEN(KPWORK,HMAKE(J),ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPWORK,HMAKE(J),WORK) + IF(HMAKE(J).EQ.'NUSIGF') THEN + DO 90 IGR=1,NGCOND + DEL=WORK(IGR)*GAS(IGR,1)*MAX(DDEN,1.0E-30) + PNFIRA(0,1)=PNFIRA(0,1)+DEL + PNFIRA(0,2)=PNFIRA(0,2)+DEL + GAS(IGR,J)=GAS(IGR,J)+WORK(IGR)*DDEN + 90 CONTINUE + ELSE IF(HMAKE(J)(:3).EQ.'NUS') THEN + IDEL=J-IOF0H + DO 100 IGR=1,NGCOND + DEL=WORK(IGR)*GAS(IGR,1)*MAX(DDEN,1.0E-30) + PNFIRA(IDEL,1)=PNFIRA(IDEL,1)+DEL + PNFIRA(IDEL,2)=PNFIRA(IDEL,2)+DEL + GAS(IGR,J)=GAS(IGR,J)+WORK(IGR)*DDEN + 100 CONTINUE + ELSE IF(HMAKE(J)(:3).EQ.'NWT') THEN + DO 110 IGR=1,NGCOND + GAS(IGR,J)=WORK(IGR) + 110 CONTINUE + ELSE IF((HMAKE(J).EQ.'CHI').OR. + 1 (HMAKE(J)(:5).EQ.'CHI--')) THEN + DO 120 IGR=1,NGCOND + GAS(IGR,J)=GAS(IGR,J)+WORK(IGR)*PNFIRA(0,1) + 120 CONTINUE + ELSE IF(HMAKE(J)(:3).EQ.'CHI') THEN + IDEL=J-IOF1H-1 + DO 130 IGR=1,NGCOND + GAS(IGR,J)=GAS(IGR,J)+WORK(IGR)*PNFIRA(IDEL,1) + 130 CONTINUE + ELSE + DO 140 IGR=1,NGCOND + GAS(IGR,J)=GAS(IGR,J)+WORK(IGR)*DDEN + 140 CONTINUE + ENDIF + ENDIF + ENDIF + 150 CONTINUE + CALL LCMLEN(KPWORK,'SCAT-SAVED',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + ALLOCATE(SIGS(NGCOND,NL)) + CALL XDRLGS(KPWORK,-1,IPRINT,0,NL-1,1,NGCOND,SIGS(1,1), + 1 WORK2,ITYPRO) + DEALLOCATE(SIGS) + DO 162 IL=1,NL + WRITE (CM,'(I2.2)') IL-1 + IF(ITYPRO(IL).NE.0) HMAKE(MAXH+IL)='SCAT'//CM + DO 161 JGR=1,NGCOND + DO 160 IGR=1,NGCOND + WSCAT(IGR,JGR,IL)=WSCAT(IGR,JGR,IL)+WORK2(IGR,JGR,IL)*DDEN + 160 CONTINUE + 161 CONTINUE + 162 CONTINUE + ENDIF + ENDIF + 170 CONTINUE + IF((DENTOT(INM).GT.0.0).OR.LFISS) THEN + JJISO=JJISO+1 + IF(JJISO.GT.MAXISO) CALL XABORT('EDIRES: MAXISO OVERFLOW(1).') + WRITE(TEXT12,'(A8,I4.4)') '*MAC*RES',INM + IF(IPRINT.GT.0) WRITE (6,600) TEXT12,JJISO + KPEDIT=LCMDIL(JPEDIT,JJISO) ! set JJISO-th isotope + CALL LCMPTC(KPEDIT,'ALIAS',12,TEXT12) + CALL LCMPUT(KPEDIT,'AWR',1,2,DAWR(INM)) + DECISO=DECISO/DENTOT(INM) + IF(DECISO.GT.0.0) CALL LCMPUT(KPEDIT,'DECAY',1,2,DECISO) + IF(NDFI.GT.0) THEN + LYIEL=.FALSE. + DO 175 IGR=1,NGCOND+1 + LYIEL=LYIEL.OR.(YIELD2(IGR).GT.0.0) + 175 CONTINUE + IF(LYIEL) THEN + CALL LCMPUT(KPEDIT,'YIELD',NGCOND+1,2,YIELD2) + CALL LCMPUT(KPEDIT,'PYIELD',NDFI,2,PYIELD2) + CALL LCMPUT(KPEDIT,'PIFI',NDFI,1,JPIFI) + ENDIF + ENDIF + IF(NOUT.GT.0) THEN + DO J=1,MAXH+NL + DO IOUT=1,NOUT + IF(HMAKE(J).EQ.HVOUT(IOUT)) GO TO 180 + ENDDO + HMAKE(J)=' ' + 180 CONTINUE + ENDDO + ENDIF + DO 210 J=1,MAXH + IF(HMAKE(J).EQ.'OVERV') THEN + DO 185 IGR=1,NGCOND + GAS(IGR,J)=GAS(IGR,J)/DENTOT(INM) + 185 CONTINUE + ELSE IF((HMAKE(J).EQ.'CHI').OR.(HMAKE(J)(:5).EQ.'CHI--')) THEN + DO 190 IGR=1,NGCOND + IF(GAS(IGR,J).NE.0.0) THEN + GAS(IGR,J)=GAS(IGR,J)/PNFIRA(0,2) + ENDIF + 190 CONTINUE + ELSE IF(HMAKE(J)(:3).EQ.'CHI') THEN + IDEL=J-IOF1H-1 + DO 200 IGR=1,NGCOND + IF(GAS(IGR,J).NE.0.0) THEN + GAS(IGR,J)=GAS(IGR,J)/PNFIRA(IDEL,2) + ENDIF + 200 CONTINUE + ENDIF + IF((HMAKE(J).NE.' ').AND.(HMAKE(J)(:4).NE.'SIGS')) THEN + CALL LCMPUT(KPEDIT,HMAKE(J),NGCOND,2,GAS(1,J)) + ENDIF + 210 CONTINUE + DO 220 IL=1,NL + ITYPRO(IL)=0 + IF(HMAKE(MAXH+IL).NE.' ') ITYPRO(IL)=1 + 220 CONTINUE + IF(ITYPRO(1).GT.0) THEN + CALL XDRLGS(KPEDIT,1,IPRINT,0,NL-1,1,NGCOND,GAS(1,4+3*NW), + 1 WSCAT,ITYPRO) + ENDIF + IF(LWD) CALL LCMPUT(KPEDIT,'LAMBDA-D',NDEL,2,WDLA) +* + IF(IPRINT.GT.3) THEN + WRITE(6,'(/17H NUMBER DENSITY =,1P,E12.4)') 1.0 + WRITE(6,'(23H WEIGHTED ATOMIC MASS =,1P,E13.5)') DAWR(INM) + DO 230 J=1,MAXH + IF(HMAKE(J).NE.' ') THEN + WRITE (6,610) HMAKE(J),(GAS(I,J),I=1,NGCOND) + ENDIF + 230 CONTINUE + WRITE (6,610) 'SIGA ',(GAS(I,3+2*NW)-GAS(I,4+3*NW), + > I=1,NGCOND) + WRITE (6,610) 'SIGW00 ',(WSCAT(I,I,1),I=1,NGCOND) + IF(NL.GT.1) THEN + WRITE (6,610) 'SIGW01 ',(WSCAT(I,I,2),I=1,NGCOND) + ENDIF + IF(LWD) WRITE (6,610) 'LAMBDA-D',(WDLA(I),I=1,NDEL) + ENDIF + ENDIF + 240 CONTINUE + CALL LCMSIX(IPWORK,' ',2) + CALL LCMCL(IPWORK,2) +*---- +* UPDATE RECORDS ISOTOPESUSED, ISOTOPERNAME, ISOTOPESMIX, ETC. +*---- + CALL LCMGET(IPEDIT,'STATE-VECTOR',IPAR) + JJISO=IPAR(2) + IF(JJISO.GT.MAXISO) CALL XABORT('EDIRES: MAXISO OVERFLOW(2).') + IF(JJISO.GT.0) THEN + CALL LCMGET(IPEDIT,'ISOTOPESUSED',IHNISO) + CALL LCMGET(IPEDIT,'ISOTOPERNAME',IHNIRF) + CALL LCMGET(IPEDIT,'ISOTOPESDENS',SDEN) + CALL LCMGET(IPEDIT,'ISOTOPESMIX',ISMIX) + CALL LCMGET(IPEDIT,'ISOTOPESTYPE',ISTYP) + CALL LCMGET(IPEDIT,'ISOTOPESTODO',ISTOD) + CALL LCMGET(IPEDIT,'ISOTOPESVOL',VOLISO) + CALL LCMGET(IPEDIT,'ISOTOPESTEMP',TNISO) + ENDIF + DO 260 INM=1,NMERGE + IF(DENTOT(INM).GT.0.0) THEN + JJISO=JJISO+1 + IF(JJISO.GT.MAXISO) CALL XABORT('EDIRES: MAXISO OVERFLOW(3).') + WRITE(TEXT12,'(A8,I4.4)') '*MAC*RES',INM + READ(TEXT12,'(3A4)') (IHNISO(I0,JJISO),I0=1,3) + WRITE(TEXT12,'(A12)') '*MAC*RES ' + READ(TEXT12,'(3A4)') (IHNIRF(I0,JJISO),I0=1,3) + SDEN(JJISO)=1.0 + ISMIX(JJISO)=INM + ISTYP(JJISO)=1 + ISTOD(JJISO)=1 + DVOL=0.0 + DO 250 IREGIO=1,NREGIO + IF(IMERGE(IREGIO).EQ.INM) DVOL=DVOL+VOLUME(IREGIO) + 250 CONTINUE + VOLISO(JJISO)=DVOL + TNISO(JJISO)=TNTOT(INM) + ENDIF + 260 CONTINUE + IPAR(2)=JJISO + IPAR(22)=IPAR(22)+1 + CALL LCMPUT(IPEDIT,'STATE-VECTOR',NSTATE,1,IPAR) + CALL LCMPUT(IPEDIT,'ISOTOPESUSED',3*JJISO,3,IHNISO) + CALL LCMPUT(IPEDIT,'ISOTOPERNAME',3*JJISO,3,IHNIRF) + CALL LCMPUT(IPEDIT,'ISOTOPESDENS',JJISO,2,SDEN) + CALL LCMPUT(IPEDIT,'ISOTOPESMIX',JJISO,1,ISMIX) + CALL LCMPUT(IPEDIT,'ISOTOPESTYPE',JJISO,1,ISTYP) + CALL LCMPUT(IPEDIT,'ISOTOPESTODO',JJISO,1,ISTOD) + CALL LCMPUT(IPEDIT,'ISOTOPESVOL',JJISO,2,VOLISO) + CALL LCMPUT(IPEDIT,'ISOTOPESTEMP',JJISO,2,TNISO) + CALL LCMSIX(IPEDIT,' ',2) ! step down CURNAM +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(TNISO,VOLISO,ISTOD,ISTYP,ISMIX,IHNIRF,SDEN,IHNISO) + DEALLOCATE(HMAKE) + DEALLOCATE(PYIELD2,YIELD2,TNTOT,DAWR,DENTOT,WORK2,PNFIRA,WPY, + 1 WORK,GAS,WSCAT,WDLA) + DEALLOCATE(ITYPRO,JPIFI,IEVOL2,LSIS2) + RETURN +* + 600 FORMAT (//44H CROSS SECTION OF MERGED/CONDENSED ISOTOPE ',A12, + 1 7H' (ISO=,I8,2H):) + 610 FORMAT (/11H REACTION ',A12,2H':/(1X,1P,10E12.4)) + END diff --git a/Dragon/src/EDISTA.f b/Dragon/src/EDISTA.f new file mode 100644 index 0000000..c062ba2 --- /dev/null +++ b/Dragon/src/EDISTA.f @@ -0,0 +1,127 @@ +*DECK EDISTA + SUBROUTINE EDISTA(IPRINT,NMERGE,ITYPE,VOLMER,VOLREL,VOLTOT, + > FLXNEW,FLXOLD,RATNEW,RATOLD) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Print homogenized/condensed macroscopic cross sections statistics. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPRINT print level; +* = 0 no print; +* = 1 print fluxes; +* = 2 1+print reaction rates; +* = 3 2+print homogenized cross sections. +* NMERGE number of regions. +* ITYPE type of statistics: +* = 1 flux relative errors; +* = 2 reaction rates relative errors; +* = 3 delta sigma. +* VOLMER current region merged volumes. +* VOLREL old volume/new volume. +* VOLTOT total old volume. +* FLXNEW new integrated flux. +* FLXOLD old integrated flux. +* RATNEW new homogenized cross sections. +* RATOLD old homogenized cross sections. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IPRINT,NMERGE,ITYPE + REAL VOLMER(NMERGE),VOLREL,VOLTOT,FLXNEW(NMERGE), + > FLXOLD(NMERGE),RATNEW(NMERGE),RATOLD(NMERGE) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6) + REAL, ALLOCATABLE, DIMENSION(:) :: VALERR +*---- +* SCRATCH STORAGE ALLOCATION +* VALERR relative error or delta sigma. +*---- + ALLOCATE(VALERR(NMERGE)) +* + IF(IPRINT.GT.2) THEN + IF(ITYPE.NE.3) THEN + WRITE(IUNOUT,6000) + ELSE + WRITE(IUNOUT,6001) + ENDIF + ENDIF + EPSMAX=0.0 + EPSAVG=0.0 + RPSAVG=0.0 + DO 100 IREG=1,NMERGE + IF(ITYPE.EQ.3) THEN + CURVAL=RATNEW(IREG) + OLDVAL=RATOLD(IREG) + VALERR(IREG)=CURVAL-OLDVAL + ELSE + IF(ITYPE.EQ.1) THEN + CURVAL=VOLREL*FLXNEW(IREG) + OLDVAL=FLXOLD(IREG) + ELSE IF(ITYPE.EQ.2) THEN + CURVAL=VOLREL*RATNEW(IREG)*FLXNEW(IREG) + OLDVAL=RATOLD(IREG)*FLXOLD(IREG) + ENDIF + IF(OLDVAL.NE.0.0) THEN + VALERR(IREG)=100.0*(CURVAL-OLDVAL)/OLDVAL + ELSE IF(CURVAL.NE.0.0) THEN + VALERR(IREG)=100.0*(CURVAL-OLDVAL)/CURVAL + ELSE + VALERR(IREG)=0.0 + ENDIF + ENDIF + IF(IPRINT.GT.2) THEN + WRITE(IUNOUT,6002) IREG,CURVAL,OLDVAL,VALERR(IREG) + ENDIF + IF(ITYPE.NE.3) THEN + EPSMAX=MAX(EPSMAX,ABS(VALERR(IREG))) + EPSAVG=EPSAVG+ABS(VALERR(IREG))*VOLMER(IREG)*VOLREL + RPSAVG=RPSAVG+VALERR(IREG)*VALERR(IREG) + ENDIF + 100 CONTINUE + IF(ITYPE.NE.3) THEN + IF(IPRINT.GE.2) THEN + WRITE(IUNOUT,6003) + WRITE(IUNOUT,6006) (VALERR(IREG),IREG=1,NMERGE) + ENDIF + EPSAVG=EPSAVG/VOLTOT + WRITE(IUNOUT,6005) EPSMAX,EPSAVG,SQRT(RPSAVG/NMERGE) + ELSE IF(IPRINT.GE.2) THEN + WRITE(IUNOUT,6004) + WRITE(IUNOUT,6006) (VALERR(IREG),IREG=1,NMERGE) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(VALERR) + RETURN +*---- +* FORMAT +*---- + 6000 FORMAT( + >4X,'REGION',13X,'CURRENT VALUE',10X,'REFERENCE',16X,' ERROR (%) ') + 6001 FORMAT( + >4X,'REGION',13X,'CURRENT VALUE',10X,'REFERENCE',16X,'DELTA SIGMA') + 6002 FORMAT(4X,I5,10X,1P,E14.4,8X,E14.4,8X,E14.4) + 6003 FORMAT(' RELATIVE ERROR (NEW-OLD) ON FLUXES (%)') + 6004 FORMAT(' DELTA SIGMA (NEW-OLD)') + 6005 FORMAT(/4X,' MAXIMUM ERROR=',F8.2,' %'/ + > 4X,'VOLUME WEIGHTED AVERAGE ERROR=',F8.2,' %'/ + > 4X,' RMS ERROR=',F8.2,' %') + 6006 FORMAT(1P,7(3X,E15.7)) + END diff --git a/Dragon/src/EDITXS.f b/Dragon/src/EDITXS.f new file mode 100644 index 0000000..0837cf2 --- /dev/null +++ b/Dragon/src/EDITXS.f @@ -0,0 +1,601 @@ +*DECK EDITXS + SUBROUTINE EDITXS(IWGOXS,IUTYPE,IPRINT,NGCOND,NL ,NBNISO, + > CTITLE,IMRG ,ENERGY,ISNNAM,ISNNRF,IPISO , + > MIXISN,AWRISN,DENISN,TMPISN,EMJISN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transfer information from edit to isotxs. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): M. T. Sissaoui +* +*Parameters: input +* IWGOXS unit for ISOTXS file. +* IUTYPE type of ISOTXS file: =2 sequential binary file; +* =3 sequential ascii file. +* IPRINT print level. +* NGCOND number of energy group. +* NL anisotropy order. +* NBNISO number of edit isotopes. +* CTITLE title. +* IMRG mixture to consider. +* ENERGY energy groups. +* ISNNAM names of edit isotopes. +* ISNNRF reference names of edit isotopes. +* IPISO pointers to isotope libraries. +* MIXISN mixture number for edit isotopes. +* AWRISN AWR values for edit isotopes. +* DENISN density for edit isotopes. +* TMPISN temperature for edit isotopes. +* EMJISN energy for edit isotopes (Mega-joules for 10**24 fission). +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPISO(NBNISO) + INTEGER IWGOXS,IUTYPE,IPRINT,NGCOND,NL,NBNISO,IMRG + INTEGER ISNNAM(3,NBNISO),ISNNRF(3,NBNISO),MIXISN(NBNISO) + CHARACTER CTITLE*72 + REAL ENERGY(NGCOND+1),AWRISN(NBNISO),DENISN(NBNISO), + > TMPISN(NBNISO),EMJISN(NBNISO) +*---- +* LOCAL VARIABLES +*---- + INTEGER IOUT,ILCMUP,ILCMDN,NFILNA,NFILCN,MXMULT,NFILMD,MAXA + PARAMETER (MAXA=10000) + REAL A(MAXA) + INTEGER IA(MAXA) + CHARACTER NAMSBR*6,HSMG*131 + PARAMETER (IOUT=6,ILCMUP=1,ILCMDN=2,NFILNA=3,NFILCN=8,MXMULT=2, + > NFILMD=1+NFILNA*MXMULT,NAMSBR='EDITXS') + TYPE(C_PTR) KPEDIT + EQUIVALENCE (A(1),IA(1)) +*---- +* EXTERNAL FUNCTIONS +*---- + DOUBLE PRECISION XDRCST +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: LOCISO,IJJ,NJJ,IRECGI,IREC + REAL, ALLOCATABLE, DIMENSION(:) :: AVGVEL,RICHI,RJCHI,RECPX,RECPS +*---- +* LOCAL PARAMETERS +*---- + CHARACTER CM*2,NAMISO*12,FMTRD*5,CIDENT*8,HABSID*8, + > HIDENT*8,HMAT*8,CDUM*8,CISO(10)*6 + INTEGER I,IFILID(NFILMD),IFILCN(NFILCN),NEXTRI, + > MXGDSC,MXGUSC,ICHIST,ISO,IFIL,JSO,KSO,IGROUP, + > IL,INFL,IFTL,IRECG,IRECNB,IRECIB, + > MRECGI,MRECPX,MRECPS,IRECP,ILCMTY, + > ILENG,IRECW,IW,IGR,NRECWR,JFZ, + > JFX,ITC,NBISO,MULTA6,IRECL, + > ITITLE,IC6TIT,JVAR,IRECWR,MRECWR + DOUBLE PRECISION NMASS + LOGICAL LFIRST +*---- +* SET ISOTXS FILE DIMENSIONING RECORD +* MULTA6 = NUMBER OF INTEGER WORDS TO STORE +* CHARACTER*6 VARIABLE +* FMTRD = FORMAT TO STORE CHARACTER*6 VARIABLE +* IN INTEGER WORDS +*---- + PARAMETER (MULTA6=2,FMTRD='(2A4)') +*---- +* EQUIVALENCES +*---- + INTEGER NITMA,NITMA6(6) + REAL FLOTT,FLOTT6(6) + EQUIVALENCE(NITMA,FLOTT),(NITMA6,FLOTT6) +*---- +* DATA +*---- + CHARACTER CFILNC(NFILNA)*10 + SAVE CFILNC + DATA (CFILNC(IFIL),IFIL=1,NFILNA) + > /'ISOTXS','DRAGON','971124'/ +*---- +* SCRATCH STORAGE ALLOCATION +* AVGVEL neutron average velocity +* LOCISO isotope localisation vector +* IJJ position of in group scattering +* NJJ number of scattering groups +*---- + ALLOCATE(LOCISO(NBNISO),IJJ(NGCOND),NJJ(NGCOND)) + ALLOCATE(AVGVEL(NGCOND)) +*----- +* EVALUATE THE ISOTOPE LOCALISATION VECTOR AND +* MAXIMUM NUMBER OF UPSCATTER AND DOWN SCATTER GROUPS +*----- + NMASS=XDRCST('Neutron mass','amu') + NEXTRI=0 + MXGDSC=0 + MXGUSC=0 + ICHIST=2 + ISO=0 +*---- +* ALLOCATE MEMORY TO STORE ISOTOPIC FISSION SPECTRUM +*---- + ALLOCATE(RICHI(NGCOND),RJCHI(NGCOND)) + DO 120 JSO=1,NBNISO + IF(MIXISN(JSO) .EQ. IMRG) THEN + ISO=ISO+1 + LOCISO(ISO)=NEXTRI + NEXTRI=NEXTRI+2+NL + KPEDIT=IPISO(JSO) ! set JSO-th isotope + IF(.NOT.C_ASSOCIATED(KPEDIT)) THEN + WRITE(HSMG,'(A6,11H: ISOTOPE '',3A4,17H'' IS NOT AVAILABL, + > 18HE IN THE MICROLIB.)') NAMSBR,(ISNNAM(ITC,JSO),ITC=1,3) + CALL XABORT(HSMG) + ENDIF +*---- +* TEST IF ALL FISSION PRODUCTION SPECTRUM IDENTICAL +* ICHIST = 2 -> NO FISSION SPECTRUM FOUND +* ICHIST = 1 -> ALL FISSION SPECTRUM IDENTICAL +* ICHIST = 0 -> AT LEAST 2 FISSION SPECTRUM ARE DIFFERENT +*---- + CALL LCMLEN(KPEDIT,'CHI',ILENG,ILCMTY) + IF(ILENG.NE.0) THEN + IF(ICHIST .EQ. 2) THEN + CALL LCMGET(KPEDIT,'CHI',RICHI) + ICHIST=1 + ELSE IF(ICHIST .EQ. 1) THEN + CALL LCMGET(KPEDIT,'CHI',RJCHI) + DO 121 IGROUP=0,NGCOND-1 + IF(RJCHI(IGROUP+1).NE.RICHI(IGROUP+1)) THEN + ICHIST =0 + GO TO 125 + ENDIF + 121 CONTINUE + 125 CONTINUE + ENDIF + ENDIF + DO 130 IL=1,NL + WRITE(CM,'(I2.2)') IL-1 + CALL LCMLEN(KPEDIT,'SCAT'//CM,ILENG,ILCMTY) + IF(ILENG.NE.0) THEN +*---- +* DATA EXISTS FOR THIS SCATTERING LEVEL FOR THIS ISOTOPE +* READ NJJ AND IJJ +* IJJ(IGTO) IS MAXIMUM GROUP NUMBER +* WITH SCATTERING TO "IGTO" GROUP +* NJJ(IGTO) IS NUMBER OF GROUPS +* WITH SCATTERING TO "IGTO" GROUP +* DETERMINE MAXIMUM NUMBER OF UP-SCATTERING GROUPS +* DETERMINE MAXIMUM NUMBER OF DOWN-SCATTERING GROUPS +*---- + CALL LCMGET(KPEDIT,'NJJS'//CM,NJJ) + CALL LCMGET(KPEDIT,'IJJS'//CM,IJJ) + DO 140 IGROUP=1,NGCOND + MXGUSC=MAX(MXGUSC,IJJ(IGROUP)-IGROUP) + MXGDSC=MAX(MXGDSC,IGROUP+NJJ(IGROUP)-IJJ(IGROUP)-1) + 140 CONTINUE + ENDIF + 130 CONTINUE +*---- +* RECOVER AVERAGED VELOCITIES +*---- + CALL LCMLEN(KPEDIT,'OVERV',ILENG,ILCMTY) + IF(ILENG .GT. 0) CALL LCMGET(KPEDIT,'OVERV',AVGVEL) + ENDIF + 120 CONTINUE + DEALLOCATE(RJCHI) +*---- +* IF ICHIST = 2 SET DEFAULT FISSION SPECTRUM ALL TO 0.0 +* AND USE A SINGLE CHI VECTOR +*---- + IF(ICHIST .EQ. 2) THEN + RICHI(:NGCOND)=0.0 + ICHIST = 1 + ENDIF + NBISO=ISO +*---- +* FILE IDENTIFICATION-RECORD 1 +*---- + NRECWR=1+NFILNA*MULTA6 + JFZ=0 + DO 150 IFIL=1,NFILNA + JFX=JFZ+1 + JFZ=JFZ+MULTA6 + READ(CFILNC(IFIL),FMTRD) (IFILID(JVAR),JVAR=JFX,JFZ) + 150 CONTINUE + IFILID(NRECWR)=1 +*---- +* TRANSFER INFORMATION TO ISOTXS +*---- + IRECWR=1 + IF(IUTYPE.EQ.2) THEN + IF(NRECWR.GT.MAXA) CALL XABORT('EDITXS: MAXA OVERFLOW(1).') + IA(:NRECWR)=IFILID(:NRECWR) + CALL XDRITE(IWGOXS,IRECWR,A,NRECWR) + ELSE IF(IUTYPE.EQ.3) THEN + WRITE(IWGOXS,6002) (CFILNC(IFIL),IFIL=1,NFILNA),1 + ENDIF +*---- +* FILE CONTROL-RECORD 2 +*---- + IFILCN(1)=NGCOND + IFILCN(2)=NBISO + IFILCN(3)=MXGUSC + IFILCN(4)=MXGDSC + IFILCN(5)=NL-1 + IFILCN(6)=ICHIST + IFILCN(7)=NL + IFILCN(8)=1 +*----- +* TRANSFER INFORMATION TO ISOTXS +*---- + IRECWR=IRECWR+1 + NRECWR=NFILCN + IF(IUTYPE.EQ.2) THEN + IF(NRECWR.GT.MAXA) CALL XABORT('EDITXS: MAXA OVERFLOW(2).') + IA(:NRECWR)=IFILCN(:NRECWR) + CALL XDRITE(IWGOXS,IRECWR,A,NRECWR) + ELSE IF(IUTYPE.EQ.3) THEN + WRITE(IWGOXS,6003) (IFILCN(I),I=1,8) + ENDIF +*---- +* FILE DATA-RECORD 3 +*---- + MRECWR=(NBISO+12)*MULTA6+1+NBISO+(2+ICHIST)*NGCOND + ALLOCATE(IREC(MRECWR)) + IREC(:MRECWR)=0 + IRECL=1 + ITITLE=1 + DO 160 IC6TIT=1,12 + CIDENT=CTITLE(ITITLE:ITITLE+5)//' ' + ITITLE=ITITLE+6 + READ(CIDENT,FMTRD) (IREC(JVAR),JVAR=IRECL,IRECL+MULTA6-1) + IRECL=IRECL+MULTA6 + 160 CONTINUE + DO 170 JSO=1,NBNISO + IF(MIXISN(JSO).EQ.IMRG) THEN + WRITE(NAMISO,'(3A4)') (ISNNAM(ITC,JSO),ITC=1,3) + CIDENT=NAMISO(1:6)//' ' + READ(CIDENT,FMTRD) (IREC(JVAR),JVAR=IRECL,IRECL+MULTA6-1) + IRECL=IRECL+MULTA6 + ENDIF + 170 CONTINUE +*---- +* SAVE SET CHI IF REQUIRED +*---- + IF(ICHIST .EQ. 1) THEN + DO 122 IGR=1,NGCOND + FLOTT=RICHI(IGR) + IREC(IRECL)=NITMA + IRECL=IRECL+1 + 122 CONTINUE + ENDIF +*---- +* SAVE AVERAGE NEUTRON VELOCITY +*---- + DO 180 IGR=1,NGCOND + FLOTT=1.0/AVGVEL(IGR) + IREC(IRECL)=NITMA + IRECL=IRECL+1 + 180 CONTINUE +*---- +* SAVE ENERGY GROUP +*---- + DO 181 IGR=1,NGCOND+1 + FLOTT=ENERGY(IGR) + IREC(IRECL)=NITMA + IRECL=IRECL+1 + 181 CONTINUE +*---- +* TRANSFER LOCISO IN RECORD VECTOR +*---- + DO 190 ISO=1,NBISO + IREC(IRECL)=LOCISO(ISO) + IRECL=IRECL+1 + 190 CONTINUE +*----- +* TRANSFER INFORMATION TO ISOTXS +*----- + IRECWR=IRECWR+1 + NRECWR=MRECWR + IF(IUTYPE.EQ.2) THEN + IF(NRECWR.GT.MAXA) CALL XABORT('EDITXS: MAXA OVERFLOW(3).') + IA(:NRECWR)=IREC(:NRECWR) + CALL XDRITE(IWGOXS,IRECWR,A,NRECWR) + ELSE IF(IUTYPE.EQ.3) THEN + WRITE(IWGOXS,6004) CTITLE(:66) + KSO=0 + LFIRST=.TRUE. + DO JSO=1,NBNISO + IF(MIXISN(JSO).EQ.IMRG) THEN + KSO=KSO+1 + WRITE(NAMISO,'(3A4)') (ISNNAM(ITC,JSO),ITC=1,3) + CISO(KSO)=NAMISO(1:6)//' ' + ENDIF + IF(LFIRST.AND.(KSO.EQ.9)) THEN + WRITE(IWGOXS,6005) CTITLE(67:72),(CISO(I),I=1,9) + KSO=0 + LFIRST=.FALSE. + ELSE IF(KSO.EQ.10) THEN + WRITE(IWGOXS,'(10(1X,A6))') (CISO(I),I=1,10) + KSO=0 + ENDIF + ENDDO + IF(KSO.GT.0) WRITE(IWGOXS,'(10(1X,A6))') (CISO(I),I=1,KSO) + IF(ICHIST.EQ.1) THEN + WRITE(IWGOXS,'(1P,6E12.5)') (RICHI(IGR),IGR=1,NGCOND) + ENDIF + WRITE(IWGOXS,'(1P,6E12.5)') (1.0/AVGVEL(IGR),IGR=1,NGCOND), + > (ENERGY(IGR),IGR=1,NGCOND+1) + WRITE(IWGOXS,'(12I6)') (LOCISO(ISO),ISO=1,NBISO) + ENDIF + DEALLOCATE(IREC) +*---- +* ISOTOPE CONTROL AND GROUP INDEPENDENT DATA +*---- + MRECGI=3*MULTA6+17+NL*(2*NGCOND+2) + MRECPX=10*NGCOND + MRECPS=NGCOND*NGCOND + ALLOCATE(IRECGI(MRECGI),RECPX(MRECPX),RECPS(MRECPS)) + ISO=0 + DO 200 JSO=1,NBNISO + IF(MIXISN(JSO).EQ.IMRG) THEN + ISO=ISO+1 + IRECGI(:MRECGI)=0 + IRECG=1 + WRITE(NAMISO,'(3A4)') (ISNNAM(ITC,JSO),ITC=1,3) + KPEDIT=IPISO(JSO) ! set JSO-th isotope + HABSID=NAMISO(1:6)//' ' + IF(IPRINT.GE.1) WRITE(IOUT,6000) HABSID(1:6),LOCISO(ISO) + READ(HABSID,FMTRD) (IRECGI(JVAR),JVAR=IRECG,IRECG+MULTA6-1) + IRECG=IRECG+MULTA6 + HIDENT='DRAGON ' + READ(HIDENT,FMTRD) (IRECGI(JVAR),JVAR=IRECG,IRECG+MULTA6-1) + IRECG=IRECG+MULTA6 + WRITE(NAMISO,'(3A4)') (ISNNRF(ITC,JSO),ITC=1,3) + HMAT=NAMISO(1:6)//' ' + READ(HMAT,FMTRD) (IRECGI(JVAR),JVAR=IRECG,IRECG+MULTA6-1) + IRECG=IRECG+MULTA6 + FLOTT=AWRISN(JSO)*REAL(NMASS) + IRECGI(IRECG)=NITMA + FLOTT=EMJISN(JSO)*1.0E-18 + IRECGI(IRECG+1)=NITMA + FLOTT=TMPISN(JSO) + IRECGI(IRECG+3)=NITMA + FLOTT=DENISN(JSO) + IRECGI(IRECG+5)=NITMA + CALL LCMLEN(KPEDIT,'CHI',ILENG,ILCMTY) + IF((ILENG.NE.0).AND.(ICHIST.EQ.0)) IRECGI(IRECG+7)=1 + CALL LCMLEN(KPEDIT,'NUSIGF',ILENG,ILCMTY) + IF(ILENG.NE.0) IRECGI(IRECG+8)=1 + CALL LCMLEN(KPEDIT,'NA',ILENG,ILCMTY) + IF(ILENG.NE.0) IRECGI(IRECG+9)=1 + CALL LCMLEN(KPEDIT,'NP',ILENG,ILCMTY) + IF(ILENG.NE.0) IRECGI(IRECG+10)=1 + CALL LCMLEN(KPEDIT,'N2N',ILENG,ILCMTY) + IF(ILENG.NE.0) IRECGI(IRECG+11)=1 + CALL LCMLEN(KPEDIT,'ND',ILENG,ILCMTY) + IF(ILENG.NE.0) IRECGI(IRECG+12)=1 + CALL LCMLEN(KPEDIT,'NT',ILENG,ILCMTY) + IF(ILENG.NE.0) IRECGI(IRECG+13)=1 + CALL LCMLEN(KPEDIT,'NTOT0',ILENG,ILCMTY) + IF(ILENG.NE.0) IRECGI(IRECG+14)=1 + CALL LCMLEN(KPEDIT,'STRD',ILENG,ILCMTY) + IF(ILENG.NE.0) IRECGI(IRECG+15)=1 + CALL LCMLEN(KPEDIT,'STRD-X',ILENG,ILCMTY) + IF(ILENG.NE.0) IRECGI(IRECG+16)=3 + IRECG=IRECG+17 + DO 210 IL=1,NL + IRECGI(IRECG)=IL-1 + IRECGI(IRECG+NL)=1 + IRECG=IRECG+1 + 210 CONTINUE + IRECG=IRECG+NL + IRECNB=IRECG + IRECIB=IRECNB+NL*NGCOND + DO 220 IL=1,NL + WRITE(CM,'(I2.2)') IL-1 + CALL LCMLEN(KPEDIT,'SCAT'//CM,ILENG,ILCMTY) + IF(ILENG.NE.0) THEN + CALL LCMGET(KPEDIT,'NJJS'//CM,NJJ) + CALL LCMGET(KPEDIT,'IJJS'//CM,IJJ) + DO 230 IGROUP=1,NGCOND + IRECGI(IRECNB)=NJJ(IGROUP) + IRECGI(IRECIB)=IJJ(IGROUP)-IGROUP+1 + IRECNB=IRECNB+1 + IRECIB=IRECIB+1 + 230 CONTINUE + ELSE + DO 240 IGROUP=1,NGCOND + IRECGI(IRECNB)=1 + IRECGI(IRECIB)=1 + IRECNB=IRECNB+1 + IRECIB=IRECIB+1 + 240 CONTINUE + ENDIF + 220 CONTINUE + IRECG=IRECG+2*NL*NGCOND +*----- +* TRANSFER INFORMATION TO ISOTXS +*----- + IF(IPRINT.GE.10) THEN + IRECW=1 + WRITE(CDUM,FMTRD) (IRECGI(JVAR),JVAR=IRECW,IRECW+MULTA6-1) + HABSID=CDUM + IRECW=IRECW+MULTA6 + WRITE(CDUM,FMTRD) (IRECGI(JVAR),JVAR=IRECW,IRECW+MULTA6-1) + HIDENT=CDUM + IRECW=IRECW+MULTA6 + WRITE(CDUM,FMTRD) (IRECGI(JVAR),JVAR=IRECW,IRECW+MULTA6-1) + HMAT=CDUM + IRECW=IRECW+MULTA6 + WRITE(IOUT,6001) HABSID(1:6),HIDENT(1:6),HMAT(1:6), + > (IRECGI(IW),IW=IRECW,IRECW+5), + > (IRECGI(IW),IW=IRECW+6,IRECW+16) + ENDIF + IRECWR=IRECWR+1 + NRECWR=MRECGI + IF(IUTYPE.EQ.2) THEN + IF(NRECWR.GT.MAXA) CALL XABORT('EDITXS: MAXA OVERFLOW(4).') + IA(:NRECWR)=IRECGI(:NRECWR) + CALL XDRITE(IWGOXS,IRECWR,A,NRECWR) + ELSE IF(IUTYPE.EQ.3) THEN + DO IW=1,6 + NITMA6(IW)=IRECGI(3*MULTA6+IW) + ENDDO + WRITE(IWGOXS,6006) HABSID(1:6),HIDENT(1:6),HMAT(1:6), + > (FLOTT6(IW),IW=1,6), + > (IRECGI(IW),IW=3*MULTA6+7,NRECWR) + ENDIF +*------ +* PRINCIPAL CROSS SECTIONS +*------ + RECPX(:MRECPX)=0.0 + IRECP=1 + CALL LCMLEN(KPEDIT,'STRD',ILENG,ILCMTY) + IF(ILENG.NE.0) THEN + CALL LCMGET(KPEDIT,'STRD',RECPX(IRECP)) + IRECP=IRECP+NGCOND + ENDIF + CALL LCMLEN(KPEDIT,'NTOT0',ILENG,ILCMTY) + IF(ILENG.EQ.0) CALL XABORT('EDITXS: NTOT0 DATA MISSING.') + CALL LCMGET(KPEDIT,'NTOT0',RECPX(IRECP)) + IRECP=IRECP+NGCOND + CALL LCMLEN(KPEDIT,'NG',ILENG,ILCMTY) + IF(ILENG.EQ.0) THEN + IFTL=IRECP-NGCOND + INFL=IRECP + CALL LCMLEN(KPEDIT,'SIGS00',ILENG,ILCMTY) + IF(ILENG.EQ.0) CALL XABORT('EDITXS: UNABLE TO MAKE NG.') + CALL LCMGET(KPEDIT,'SIGS00',RECPX(IRECP)) + DO 260 IGROUP=1,NGCOND + RECPX(INFL)=RECPX(IFTL)-RECPX(INFL) + IFTL=IFTL+1 + INFL=INFL+1 + 260 CONTINUE + ELSE + CALL LCMGET(KPEDIT,'NG',RECPX(IRECP)) + ENDIF + IRECP=IRECP+NGCOND + CALL LCMLEN(KPEDIT,'NUSIGF',ILENG,ILCMTY) + IF(ILENG.NE.0) THEN + IFTL=IRECP + CALL LCMGET(KPEDIT,'NFTOT',RECPX(IRECP)) + IRECP=IRECP+NGCOND + INFL=IRECP + CALL LCMGET(KPEDIT,'NUSIGF',RECPX(IRECP)) + IRECP=IRECP+NGCOND +*---- +* COMPUTE NU FROM NUSIGF/NFTOT +*---- + DO 250 IGROUP=1,NGCOND + IF(RECPX(IFTL).NE.0.0) RECPX(INFL)=RECPX(INFL)/RECPX(IFTL) + IFTL=IFTL+1 + INFL=INFL+1 + 250 CONTINUE + ENDIF + CALL LCMLEN(KPEDIT,'CHI',ILENG,ILCMTY) + IF((ILENG.NE.0).AND.(ICHIST.EQ.0)) THEN + CALL LCMGET(KPEDIT,'CHI',RECPX(IRECP)) + IRECP=IRECP+NGCOND + ENDIF + CALL LCMLEN(KPEDIT,'NA',ILENG,ILCMTY) + IF(ILENG.NE.0) THEN + CALL LCMGET(KPEDIT,'NA',RECPX(IRECP)) + IRECP=IRECP+NGCOND + ENDIF + CALL LCMLEN(KPEDIT,'NP',ILENG,ILCMTY) + IF(ILENG.NE.0) THEN + CALL LCMGET(KPEDIT,'NP',RECPX(IRECP)) + IRECP=IRECP+NGCOND + ENDIF + CALL LCMLEN(KPEDIT,'N2N',ILENG,ILCMTY) + IF(ILENG.NE.0) THEN + CALL LCMGET(KPEDIT,'N2N',RECPX(IRECP)) + IRECP=IRECP+NGCOND + ENDIF + CALL LCMLEN(KPEDIT,'ND',ILENG,ILCMTY) + IF(ILENG.NE.0) THEN + CALL LCMGET(KPEDIT,'ND',RECPX(IRECP)) + IRECP=IRECP+NGCOND + ENDIF + CALL LCMLEN(KPEDIT,'NT',ILENG,ILCMTY) + IF(ILENG.NE.0) THEN + CALL LCMGET(KPEDIT,'NT',RECPX(IRECP)) + IRECP=IRECP+NGCOND + ENDIF + CALL LCMLEN(KPEDIT,'STRD-X',ILENG,ILCMTY) + IF(ILENG.NE.0) THEN + CALL LCMGET(KPEDIT,'STRD-X',RECPX(IRECP)) + IRECP=IRECP+NGCOND + IF(ILENG.NE.0) CALL LCMGET(KPEDIT,'STRD-Y',RECPX(IRECP)) + IRECP=IRECP+NGCOND + IF(ILENG.NE.0) CALL LCMGET(KPEDIT,'STRD-Z',RECPX(IRECP)) + IRECP=IRECP+NGCOND + ENDIF + IRECWR=IRECWR+1 + NRECWR=IRECP-1 + IF(IUTYPE.EQ.2) THEN + CALL XDRITE(IWGOXS,IRECWR,RECPX,NRECWR) + ELSE IF(IUTYPE.EQ.3) THEN + WRITE(IWGOXS,6007) (RECPX(I),I=1,NRECWR) + ENDIF +*---- +* SCATTERING BLOCK +*---- + DO 270 IL=1,NL + WRITE(CM,'(I2.2)') IL-1 + CALL LCMLEN(KPEDIT,'SCAT'//CM,NRECWR,ILCMTY) + IF(NRECWR.NE.0) THEN + CALL LCMGET(KPEDIT,'SCAT'//CM,RECPS) + ELSE + RECPS(:NGCOND)=0.0 + NRECWR=NGCOND + ENDIF +*----- +* TRANSFER INFORMATION TO ISOTXS +*---- + IRECWR=IRECWR+1 + IF(IUTYPE.EQ.2) THEN + CALL XDRITE(IWGOXS,IRECWR,RECPS,NRECWR) + ELSE IF(IUTYPE.EQ.3) THEN + WRITE(IWGOXS,6009) (RECPS(I),I=1,NRECWR) + ENDIF + 270 CONTINUE + ENDIF + 200 CONTINUE + DEALLOCATE(RECPS,RECPX,IRECGI) + DEALLOCATE(RICHI) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(AVGVEL) + DEALLOCATE(NJJ,IJJ,LOCISO) + RETURN +*---- +* FORMAT +*---- + 6000 FORMAT(' STORING ISOTOPE = ',A6,2X,'AT LOCATION = ',I10) + 6001 FORMAT(' HABSID = ',6X,A6/' HIDENT = ',6X,A6/' HMAT = ',6X,A6/ + > ' AMASS = ',E12.5/' EFISS = ',E12.5/' ECAPT = ',E12.5/ + > ' TEMP = ',E12.5/' SIGPOT = ',E12.5/' ADENS = ',E12.5/ + > ' KBR = ',I12 /' ICHI = ',I12 /' IFIS = ',I12 / + > ' IALF = ',I12 /' INP = ',I12 /' IN2N = ',I12 / + > ' IND = ',I12 /' INT = ',I12 /' LTOT = ',I12 / + > ' LTRN = ',I12 /' ISTRPD = ',I12) + 6002 FORMAT(11H 0v isotxs ,A6,1H*,2A6,1H*,I6) + 6003 FORMAT(4H 1d ,8I6) + 6004 FORMAT(4H 2d ,1H*,A66,1H*) + 6005 FORMAT(1H*,A6,1H*,9(1X,A6)) + 6006 FORMAT(4H 4d ,3(1X,A6)/1P,6E12.5/(12I6)) + 6007 FORMAT(4H 5d ,1P,5E12.5/(6E12.5)) + 6009 FORMAT(4H 7d ,1P,5E12.5/(6E12.5)) + END diff --git a/Dragon/src/EDIUNF.f b/Dragon/src/EDIUNF.f new file mode 100644 index 0000000..339d2ef --- /dev/null +++ b/Dragon/src/EDIUNF.f @@ -0,0 +1,239 @@ +*DECK EDIUNF + SUBROUTINE EDIUNF(IPGEO1,IPGEO2,HSYM) +*----------------------------------------------------------------------- +* +*Purpose: +* Unfold a geometry. +* +*Copyright: +* Copyright (C) 2015 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPGEO1 pointer to the original geometry (L_GEOM signature). +* IPGEO2 pointer to the unfolded geometry (L_GEOM signature). +* HSYM type of symmetry: +* 'DIAG' for diagonal symmetry; +* 'SYMX' for symmetry relative to X axis; +* 'SYMY' for symmetry relative to Y axis. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPGEO1,IPGEO2 + CHARACTER HSYM*4 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + INTEGER ISTATE(NSTATE),NCODE(6),ICODE(6),ITDI(8),ITSX(8),ITSY(8) + REAL ZCODE(6) + CHARACTER*12 HSIGN + LOGICAL LDIAG,LSYMX,LSYMY,LMESHX,LMESHY,LHMIX + SAVE ITDI,ITSX,ITSY + DATA ITDI/6,5,8,7,2,1,4,3/ + DATA ITSX/7,6,5,8,3,2,1,4/ + DATA ITSY/5,8,7,6,1,4,3,2/ +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MIX,MERGE,ITURN,IHMIX + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: MIX2,MERGE2,ITURN2,IHMIX2 + REAL, ALLOCATABLE, DIMENSION(:) :: MESHX,MESHY,MESHX2,MESHY2 +* + CALL LCMGTC(IPGEO1,'SIGNATURE',12,HSIGN) + IF(HSIGN .NE. 'L_GEOM') THEN + CALL XABORT('EDIUNF: SIGNATURE OF INPUT LCM OBJECT IS '//HSIGN// + > '. L_GEOM EXPECTED.') + ENDIF + CALL LCMGET(IPGEO1,'STATE-VECTOR',ISTATE) + IF(ISTATE(1).NE.5) CALL XABORT('EDIUNF: CARTESIAN GEOMETRY EXPEC' + > //'TED.') + IF(ISTATE(8).NE.1) CALL XABORT('EDIUNF: EMBEDDED CELLS EXPECTED.') + NX=ISTATE(3) + NY=ISTATE(4) + NK=ISTATE(6) + CALL LCMGET(IPGEO1,'NCODE',NCODE) + CALL LCMGET(IPGEO1,'ICODE',ICODE) + CALL LCMGET(IPGEO1,'ZCODE',ZCODE) + LDIAG=(NCODE(1).EQ.3).AND.(NCODE(4).EQ.3) + LSYMX=(NCODE(3).EQ.5).AND.(NCODE(1).NE.3) + LSYMY=(NCODE(1).EQ.5).AND.(NCODE(4).NE.3) +*---- +* Recover original geometry +*---- + ALLOCATE(MIX(NK),MERGE(NK),ITURN(NK),IHMIX(NK)) + ALLOCATE(MESHX(NX+1),MESHY(NY+1)) + CALL LCMLEN(IPGEO1,'MESHX',ILONG,ITYLCM) + LMESHX=ILONG.NE.0 + IF(LMESHX) CALL LCMGET(IPGEO1,'MESHX',MESHX) + CALL LCMLEN(IPGEO1,'MESHY',ILONG,ITYLCM) + LMESHY=ILONG.NE.0 + IF(LMESHY) CALL LCMGET(IPGEO1,'MESHY',MESHY) + CALL LCMGET(IPGEO1,'MIX',MIX) + CALL LCMLEN(IPGEO1,'MERGE',ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + CALL LCMGET(IPGEO1,'MERGE',MERGE) + ELSE + DO I=1,NK + MERGE(I)=I + ENDDO + ENDIF + CALL LCMLEN(IPGEO1,'TURN',ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + CALL LCMGET(IPGEO1,'TURN',ITURN) + ELSE + ITURN(:NK)=1 + ENDIF + CALL LCMLEN(IPGEO1,'HMIX',ILONG,ITYLCM) + LHMIX=ILONG.NE.0 + IF(LHMIX) CALL LCMGET(IPGEO1,'HMIX',IHMIX) +*---- +* Build unfolded geometry geometry +*---- + NX2=NX + NY2=NY + IF(HSYM.EQ.'DIAG') THEN + IF(.NOT.LDIAG) CALL XABORT('EDIUNF: DIAG UNFOLDING FAILURE.') + ELSE IF(HSYM.EQ.'SYMX') THEN + IF(.NOT.LSYMX) CALL XABORT('EDIUNF: SYMX UNFOLDING FAILURE.') + NY2=2*NY-1 + ELSE IF(HSYM.EQ.'SYMY') THEN + IF(.NOT.LSYMY) CALL XABORT('EDIUNF: SYMY UNFOLDING FAILURE.') + NX2=2*NX-1 + ELSE + CALL XABORT('EDIUNF: INVALID TYPE OF SYMMETRY AXIS.') + ENDIF + ALLOCATE(MIX2(NX2,NY2),MERGE2(NX2,NY2),ITURN2(NX2,NY2), + > IHMIX2(NX2,NY2)) + ALLOCATE(MESHX2(NX2+1),MESHY2(NY2+1)) + IF(HSYM.EQ.'DIAG') THEN + NCODE(1)=NCODE(3) + NCODE(4)=NCODE(2) + ICODE(1)=ICODE(3) + ICODE(4)=ICODE(2) + ZCODE(1)=ZCODE(3) + ZCODE(4)=ZCODE(2) + IOF=0 + DO IY=1,NY + DO IX=IY,NX + IOF=IOF+1 + IF(IOF.GT.NK) CALL XABORT('EDIUNF: NK OVERFLOW(1).') + MIX2(IX,IY)=MIX(IOF) + MIX2(IY,IX)=MIX(IOF) + MERGE2(IX,IY)=MERGE(IOF) + MERGE2(IY,IX)=MERGE(IOF) + ITURN2(IX,IY)=ITURN(IOF) + ITURN2(IY,IX)=ITDI(ITURN(IOF)) + IF(LHMIX) THEN + IHMIX2(IX,IY)=IHMIX(IOF) + IHMIX2(IY,IX)=IHMIX(IOF) + ENDIF + ENDDO + ENDDO + IF(LMESHX) THEN + DO IX=1,NX+1 + MESHX2(IX)=MESHX(IX) + ENDDO + ENDIF + IF(LMESHY) THEN + DO IY=1,NY+1 + MESHY2(IY)=MESHY(IY) + ENDDO + ENDIF + ELSE IF(HSYM.EQ.'SYMX') THEN + NCODE(3)=NCODE(4) + ICODE(3)=ICODE(4) + ZCODE(3)=ZCODE(4) + DO IY=1,NY + DO IX=1,NX + IOF=(IY-1)*NX+IX + IF(IOF.GT.NK) CALL XABORT('EDIUNF: NK OVERFLOW(2).') + MIX2(IX,NY+IY-1)=MIX(IOF) + MIX2(IX,NY-IY+1)=MIX(IOF) + MERGE2(IX,NY+IY-1)=MERGE(IOF) + MERGE2(IX,NY-IY+1)=MERGE(IOF) + ITURN2(IX,NY+IY-1)=ITURN(IOF) + ITURN2(IX,NY-IY+1)=ITSX(ITURN(IOF)) + IF(LHMIX) THEN + IHMIX2(IX,NY+IY-1)=IHMIX(IOF) + IHMIX2(IX,NY-IY+1)=IHMIX(IOF) + ENDIF + ENDDO + ENDDO + IF(LMESHX) THEN + DO IX=1,NX+1 + MESHX2(IX)=MESHX(IX) + ENDDO + ENDIF + IF(LMESHY) THEN + DO IY=1,NY+1 + MESHY2(NY+IY-1)=MESHY(IY) + ENDDO + DO IY=3,NY+1 + MESHY2(NY-IY+2)=MESHY2(NY-IY+3)-(MESHY(IY)-MESHY(IY-1)) + ENDDO + ENDIF + ELSE IF(HSYM.EQ.'SYMY') THEN + NCODE(1)=NCODE(2) + ICODE(1)=ICODE(2) + ZCODE(1)=ZCODE(2) + DO IY=1,NY + DO IX=1,NX + IOF=(IY-1)*NX+IX + IF(IOF.GT.NK) CALL XABORT('EDIUNF: NK OVERFLOW(3).') + MIX2(NX+IX-1,IY)=MIX(IOF) + MIX2(NX-IX+1,IY)=MIX(IOF) + MERGE2(NX+IX-1,IY)=MERGE(IOF) + MERGE2(NX-IX+1,IY)=MERGE(IOF) + ITURN2(NX+IX-1,IY)=ITURN(IOF) + ITURN2(NX-IX+1,IY)=ITSX(ITURN(IOF)) + IF(LHMIX) THEN + IHMIX2(NX+IX-1,IY)=IHMIX(IOF) + IHMIX2(NX-IX+1,IY)=IHMIX(IOF) + ENDIF + ENDDO + ENDDO + IF(LMESHX) THEN + DO IX=1,NX+1 + MESHX2(NX+IX-1)=MESHX(IX) + ENDDO + DO IX=3,NX+1 + MESHX2(NX-IX+2)=MESHX2(NX-IX+3)-(MESHX(IX)-MESHX(IX-1)) + ENDDO + ENDIF + IF(LMESHY) THEN + DO IY=1,NY+1 + MESHY2(IY)=MESHY(IY) + ENDDO + ENDIF + ENDIF + CALL LCMEQU(IPGEO1,IPGEO2) + CALL LCMPUT(IPGEO2,'NCODE',6,1,NCODE) + CALL LCMPUT(IPGEO2,'ICODE',6,1,ICODE) + CALL LCMPUT(IPGEO2,'ZCODE',6,2,ZCODE) + IF(LMESHX) CALL LCMPUT(IPGEO2,'MESHX',NX2+1,2,MESHX) + IF(LMESHY) CALL LCMPUT(IPGEO2,'MESHY',NY2+1,2,MESHY) + CALL LCMPUT(IPGEO2,'MIX',NX2*NY2,1,MIX2) + CALL LCMPUT(IPGEO2,'MERGE',NX2*NY2,1,MERGE2) + CALL LCMPUT(IPGEO2,'TURN',NX2*NY2,1,ITURN2) + IF(LHMIX) CALL LCMPUT(IPGEO2,'HMIX',NX2*NY2,1,IHMIX2) + ISTATE(3)=NX2 + ISTATE(4)=NY2 + ISTATE(6)=NX2*NY2 + CALL LCMPUT(IPGEO2,'STATE-VECTOR',NSTATE,1,ISTATE) +*---- +* Release memory +*---- + DEALLOCATE(MESHY2,MESHX2,MESHY,MESHX) + DEALLOCATE(IHMIX2,ITURN2,MERGE2,MIX2,IHMIX,ITURN,MERGE,MIX) + RETURN + END diff --git a/Dragon/src/EDIWCU.f b/Dragon/src/EDIWCU.f new file mode 100644 index 0000000..1b6c2ee --- /dev/null +++ b/Dragon/src/EDIWCU.f @@ -0,0 +1,141 @@ +*DECK EDIWCU + SUBROUTINE EDIWCU(IPFLUX,IPRINT,NGROUP,NUN,NREGIO,NDIM,NLIN, + > NFUNL,NGCOND,NMERGE,KEYANI,VOLUME,IGCOND,IMERGE,COUWP1) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Homogenize the currents based on spherical harmonic moments of the +* flux. +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPFLUX pointer to the flux LCM object. +* IPRINT print parameter. +* NGROUP number of energy groups. +* NUN number of unknowns in flux array. +* NREGIO number of regions. +* NDIM number of dimensions. +* NLIN number of polynomial components in flux. +* NFUNL number of spherical harmonic components in flux. +* NGCOND number of merged energy groups. +* NMERGE number of merged regions. +* KEYANI position of spherical harmonic components in unknown vector. +* VOLUME volumes. +* IGCOND limit condensed groups. +* IMERGE region merging matrix. +* +*Parameters: input/output +* COUWP1 homogenized and condensed currents. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPFLUX + INTEGER IPRINT,NREGIO,NGROUP,NUN,NDIM,NLIN,NFUNL,NGCOND,NMERGE, + > KEYANI(NREGIO,NLIN,NFUNL),IGCOND(NGCOND), + > IMERGE(NREGIO) + REAL VOLUME(NREGIO),COUWP1(NMERGE,NGCOND,NDIM) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6) + TYPE(C_PTR) JPFLUX +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: WORKF + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: FLUXES +*---- +* INITIALIZATION +*---- + IF(NFUNL.EQ.1) CALL XABORT('EDIWCU: ANIS.GE.2 EXPECTED IN TRACKI' + > //'NG.') + JPFLUX=LCMGID(IPFLUX,'FLUX') + ALLOCATE(WORKF(NUN),FLUXES(NREGIO,NGROUP,NDIM)) + COUWP1(:NMERGE,:NGCOND,:NDIM)=0.0 +*---- +* PROCESS TRIVIAL 1D CASE +*---- + IF(NDIM.EQ.1) THEN + DO IGR=1,NGROUP + CALL LCMGDL(JPFLUX,IGR,WORKF) + DO IREG=1,NREGIO + FLUXES(IREG,IGR,1)=WORKF(KEYANI(IREG,1,2)) + ENDDO + ENDDO + ELSE IF(NDIM.GT.1) THEN +*---- +* PROCESS 2D AND 3D CASES +*---- + IL=1 + IOF0=1 + DO IGR=1,NGROUP + CALL LCMGDL(JPFLUX,IGR,WORKF) + DO IREG=1,NREGIO + IOF=IOF0 + DO IM=-IL,IL + IF((NDIM.EQ.2).AND.(MOD(IL+IM,2).EQ.1)) CYCLE + IOF=IOF+1 + IF(IOF.GT.NFUNL) CALL XABORT('EDIWCU: KEYANI OVERFLOW.') + IF(IM.EQ.-1) THEN + FLUXES(IREG,IGR,2)=WORKF(KEYANI(IREG,1,IOF)) + ELSE IF(IM.EQ.0) THEN + FLUXES(IREG,IGR,3)=WORKF(KEYANI(IREG,1,IOF)) + ELSE IF(IM.EQ.1) THEN + FLUXES(IREG,IGR,1)=WORKF(KEYANI(IREG,1,IOF)) + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF +*---- +* CONDENSATION AND HOMOGENIZATION OF SPHERICAL HARMONIC MOMENTS +*---- + IGRFIN=0 + DO IGRC=1,NGCOND + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGRC) + DO IGR=IGRDEB,IGRFIN + DO IREG=1,NREGIO + IRA=IMERGE(IREG) + IF(IRA.EQ.0) CYCLE + DVOL=VOLUME(IREG) + DO ID=1,NDIM + COUWP1(IRA,IGRC,ID)=COUWP1(IRA,IGRC,ID)+ + > FLUXES(IREG,IGR,ID)*DVOL + ENDDO + ENDDO + ENDDO + ENDDO + DEALLOCATE(FLUXES,WORKF) +*---- +* PRINTOUTS +*---- + IF(IPRINT.GT.0) THEN + WRITE(6,'(/42H EDIWCU: INCLUDE CURRENTS IN THE MACROLIB.)') + DO IDIM=1,NDIM + DO IGR=1,NGCOND + IF(IDIM.EQ.1) WRITE(IUNOUT,6010) IGR,'X' + IF(IDIM.EQ.2) WRITE(IUNOUT,6010) IGR,'Y' + IF(IDIM.EQ.3) WRITE(IUNOUT,6010) IGR,'Z' + WRITE(IUNOUT,6012) (COUWP1(IKK,IGR,IDIM),IKK=1,NMERGE) + ENDDO + ENDDO + ENDIF + RETURN +* + 6010 FORMAT(/' G R O U P :',I4/' REGION INTEGRATED ',A1,'-CURRENT') + 6012 FORMAT(1P,7(3X,E15.7)) + END diff --git a/Dragon/src/EDIWP1.f b/Dragon/src/EDIWP1.f new file mode 100644 index 0000000..488dc75 --- /dev/null +++ b/Dragon/src/EDIWP1.f @@ -0,0 +1,233 @@ +*DECK EDIWP1 + SUBROUTINE EDIWP1(IPFLUX,NW,NGROUP,NUN,NREGIO,NDIM,IADJ,NLIN, + > NFUNL,NGCOND,NMERGE,KEYANI,VOLUME,IGCOND,IMERGE,FLUXES,AFLUXE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Evaluate the PN weighting spectra for an homogenization based on +* spherical harmonic moments of the flux. +* +*Copyright: +* Copyright (C) 2019 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPFLUX pointer to the flux LCM object. +* NW order of the spherical harmonic expansion for the flux. +* NGROUP number of energy groups. +* NUN number of unknowns in flux array. +* NREGIO number of regions. +* NDIM number of dimensions. +* IADJ type of flux weighting: +* =0: direct flux weighting; +* =1: direct-adjoint flux weighting. +* NLIN number of polynomial components in flux. +* NFUNL number of spherical harmonic components in flux. +* NGCOND number of merged energy groups. +* NMERGE number of merged regions. +* KEYANI position of spherical harmonic components in unknown vector. +* VOLUME volumes. +* IGCOND limit condensed groups. +* IMERGE region merging matrix. +* +*Parameters: input/output +* FLUXES weighting function for PN fluxes. +* AFLUXE weighting function for PN adjoint fluxes. +* +*Reference: +* Jean-Francois Vidal et al., APOLLO3 homogenization techniques for +* transport core calculations - application to the ASTRID CFV core, +* Nuclear Engineering and Technology 49 (2017) 1379 - 1387. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPFLUX + INTEGER NW,NREGIO,NGROUP,NUN,NDIM,IADJ,NLIN,NFUNL,NGCOND, + > NMERGE,KEYANI(NREGIO,NLIN,NFUNL),IGCOND(NGCOND), + > IMERGE(NREGIO) + REAL VOLUME(NREGIO),FLUXES(NREGIO,NGROUP,NW), + > AFLUXE(NREGIO,NGROUP,NW) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPFLUX,JPFLUA + DOUBLE PRECISION DVOL +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: WORKF,WORKA + REAL, ALLOCATABLE, DIMENSION(:,:) :: FDEN,ADEN + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: FLUANI,AFLANI + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SVOL + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: DFLUA,DAFLA +*---- +* INITIALIZATION +*---- + IF(NFUNL.EQ.1) CALL XABORT('EDIWP1: ANIS.GE.2 EXPECTED IN TRACKI' + > //'NG.') + JPFLUX=LCMGID(IPFLUX,'FLUX') + ALLOCATE(WORKF(NUN)) + IF(IADJ.EQ.1) THEN + JPFLUA=LCMGID(IPFLUX,'AFLUX') + ALLOCATE(WORKA(NUN)) + ENDIF +*---- +* PROCESS TRIVIAL 1D CASE +*---- + IF(NDIM.EQ.1) THEN + DO IL=1,NW + DO IGR=1,NGROUP + IF(IADJ.EQ.0) THEN + CALL LCMGDL(JPFLUX,IGR,WORKF) + DO IREG=1,NREGIO + FLUXES(IREG,IGR,IL)=WORKF(KEYANI(IREG,1,IL+1)) + AFLUXE(IREG,IGR,IL)=1.0 + ENDDO + ELSE IF(IADJ.EQ.1) THEN + CALL LCMGDL(JPFLUX,IGR,WORKF) + CALL LCMGDL(JPFLUA,IGR,WORKA) + DO IREG=1,NREGIO + FLUXES(IREG,IGR,IL)=WORKF(KEYANI(IREG,1,IL+1)) + AFLUXE(IREG,IGR,IL)=WORKA(KEYANI(IREG,1,IL+1)) + ENDDO + ENDIF + DO IREG=1,NREGIO + FLUXES(IREG,IGR,IL)=MAX(ABS(FLUXES(IREG,IGR,IL)),1.0E-10) + AFLUXE(IREG,IGR,IL)=MAX(ABS(AFLUXE(IREG,IGR,IL)),1.0E-10) + ENDDO + ENDDO + ENDDO + DEALLOCATE(WORKF) + IF(IADJ.EQ.1) DEALLOCATE(WORKA) + RETURN + ENDIF +*---- +* RECOVER PN MOMENTS OF THE FLUX +*---- + IOF=1 + DO IL=1,NW + IOF0=IOF + NTRM=1 + IF(NDIM.EQ.2) THEN + NTRM=IL+1 + ELSE IF(NDIM.EQ.3) THEN + NTRM=2*IL+1 + ENDIF + ALLOCATE(FLUANI(NREGIO,NGROUP,NTRM),AFLANI(NREGIO,NGROUP,NTRM)) + DO IGR=1,NGROUP + IF(IADJ.EQ.0) THEN + CALL LCMGDL(JPFLUX,IGR,WORKF) + DO IREG=1,NREGIO + IOF=IOF0 + ID=0 + DO IM=-IL,IL + IF((NDIM.EQ.2).AND.(MOD(IL+IM,2).EQ.1)) CYCLE + IOF=IOF+1 + IF(IOF.GT.NFUNL) CALL XABORT('EDIWP1: KEYANI OVERFLOW.') + ID=ID+1 + FLUANI(IREG,IGR,ID)=WORKF(KEYANI(IREG,1,IOF)) + AFLANI(IREG,IGR,ID)=1.0 + ENDDO + ENDDO + ELSE IF(IADJ.EQ.1) THEN + CALL LCMGDL(JPFLUX,IGR,WORKF) + CALL LCMGDL(JPFLUA,IGR,WORKA) + DO IREG=1,NREGIO + IOF=IOF0 + ID=0 + DO IM=-IL,IL + IF((NDIM.EQ.2).AND.(MOD(IL+IM,2).EQ.1)) CYCLE + IOF=IOF+1 + IF(IOF.GT.NFUNL) CALL XABORT('EDIWP1: KEYANI OVERFLOW.') + ID=ID+1 + FLUANI(IREG,IGR,ID)=WORKF(KEYANI(IREG,1,IOF)) + AFLANI(IREG,IGR,ID)=WORKA(KEYANI(IREG,1,IOF)) + ENDDO + ENDDO + ENDIF + ENDDO +*---- +* CONDENSATION AND HOMOGENIZATION OF SPHERICAL HARMONIC MOMENTS +*---- + ALLOCATE(DFLUA(NMERGE,NGCOND,NTRM),DAFLA(NMERGE,NGCOND,NTRM), + > SVOL(NMERGE)) + DFLUA(:NMERGE,:NGCOND,:NTRM)=0.0D0 + DAFLA(:NMERGE,:NGCOND,:NTRM)=0.0D0 + IGRFIN=0 + DO IGRC=1,NGCOND + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGRC) + DO IGR=IGRDEB,IGRFIN + SVOL(:NMERGE)=0.0D0 + DO IREG=1,NREGIO + IRA=IMERGE(IREG) + IF(IRA.EQ.0) CYCLE + DVOL=VOLUME(IREG) + SVOL(IRA)=SVOL(IRA)+DVOL + DO ID=1,NTRM + DFLUA(IRA,IGRC,ID)=DFLUA(IRA,IGRC,ID)+ + > FLUANI(IREG,IGR,ID)*DVOL + DAFLA(IRA,IGRC,ID)=DAFLA(IRA,IGRC,ID)+ + > FLUANI(IREG,IGR,ID)*AFLANI(IREG,IGR,ID)*DVOL + ENDDO + ENDDO + DO IRA=1,NMERGE + DO ID=1,NTRM + DFLUA(IRA,IGRC,ID)=DFLUA(IRA,IGRC,ID)/SVOL(IRA) + DAFLA(IRA,IGRC,ID)=DAFLA(IRA,IGRC,ID)/ + > (DFLUA(IRA,IGRC,ID)*SVOL(IRA)) + ENDDO + ENDDO + ENDDO + ENDDO +*---- +* USE APOLLO3 FORMULA +*---- + ALLOCATE(FDEN(NREGIO,NGROUP),ADEN(NREGIO,NGROUP)) + FLUXES(:NREGIO,:NGROUP,IL)=0.0D0 + AFLUXE(:NREGIO,:NGROUP,IL)=0.0D0 + FDEN(:NREGIO,:NGROUP)=0.0D0 + ADEN(:NREGIO,:NGROUP)=0.0D0 + IGRFIN=0 + DO IGRC=1,NGCOND + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGRC) + DO IGR=IGRDEB,IGRFIN + DO IREG=1,NREGIO + IRA=IMERGE(IREG) + IF(IRA.EQ.0) CYCLE + DO ID=1,NTRM + FLUXES(IREG,IGR,IL)=FLUXES(IREG,IGR,IL)+ + > REAL(FLUANI(IREG,IGR,ID)*DFLUA(IRA,IGRC,ID)) + AFLUXE(IREG,IGR,IL)=AFLUXE(IREG,IGR,IL)+ + > REAL(AFLANI(IREG,IGR,ID)*DAFLA(IRA,IGRC,ID)) + FDEN(IREG,IGR)=FDEN(IREG,IGR)+REAL(DFLUA(IRA,IGRC,ID)) + ADEN(IREG,IGR)=ADEN(IREG,IGR)+REAL(DAFLA(IRA,IGRC,ID)) + ENDDO + ENDDO + ENDDO + ENDDO + DO IGR=1,NGROUP + DO IREG=1,NREGIO + FLUXES(IREG,IGR,IL)=FLUXES(IREG,IGR,IL)/FDEN(IREG,IGR) + AFLUXE(IREG,IGR,IL)=AFLUXE(IREG,IGR,IL)/ADEN(IREG,IGR) + FLUXES(IREG,IGR,IL)=MAX(ABS(FLUXES(IREG,IGR,IL)),1.0E-10) + AFLUXE(IREG,IGR,IL)=MAX(ABS(AFLUXE(IREG,IGR,IL)),1.0E-10) + ENDDO + ENDDO + DEALLOCATE(ADEN,FDEN,SVOL,DAFLA,DFLUA,AFLANI,FLUANI) + ENDDO + DEALLOCATE(WORKF) + IF(IADJ.EQ.1) DEALLOCATE(WORKA) + RETURN + END diff --git a/Dragon/src/EPC.f b/Dragon/src/EPC.f new file mode 100644 index 0000000..55d865f --- /dev/null +++ b/Dragon/src/EPC.f @@ -0,0 +1,238 @@ +*DECK EPC + SUBROUTINE EPC(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Process error propagation parameters. +* +*Copyright: +* Copyright (C) 2009 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* NENTRY number of data structures transfered to this module. +* HENTRY name of the data structures. +* IENTRY data structure type where: +* =1 for LCM memory object; +* =2 for XSM file; +* =3 for sequential binary file; +* =4 for sequential ASCII file. +* JENTRY access permission for the data structure where: +* =0 for a data structure in creation mode; +* =1 for a data structure in modifications mode; +* =2 for a data structure in read-only mode. +* KENTRY data structure pointer. +* +*Comments: +* Instructions for the use of the EPC: module: +* Param := EPC: [ Param ] [[ ParamDist ]] :: (EPCpara) (EPCget) ; +* where +* Param : parameter data structure. +* ParamDist : sequential binary/ASCII parameter distributions +* (EPCpara) : PARA keyword processing options (routine EPCPAR) +* (EPCget) : GET keyword processing options (routine EPCGET) +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='EPC ') + INTEGER ILCMUP,ILCMDN,MXFIL,MXOPT + PARAMETER (ILCMUP=1,ILCMDN=2,MXFIL=20,MXOPT=20) + INTEGER NSTATE + PARAMETER (NSTATE=40) +*---- +* Input and output parameters +*---- + INTEGER ITYPLU,INTLIR + CHARACTER CARLIR*12 + REAL REALIR + DOUBLE PRECISION DBLLIR +*---- +* Local variables +*---- + CHARACTER*12 CARRET,SENTRY(MXFIL),HET + INTEGER IEN + CHARACTER HSIGN*12 + INTEGER IPRINT,NOPT,IOPT(MXOPT) + INTEGER ISTATE(NSTATE) +*---- +* Validate entry parameters +*---- + IF(NENTRY .GT. MXFIL) CALL XABORT(NAMSBR// + > ': Too many files or data structures for this module.') +*---- +* Scan data structure to determine signature (input or update) +*---- + DO IEN=1,NENTRY + SENTRY(IEN)=' ' + IF(IENTRY(IEN) .EQ. 1 .OR. IENTRY(IEN) .EQ. 2) THEN + IF(JENTRY(IEN) .NE. 0) THEN + CALL LCMGTC(KENTRY(IEN),'SIGNATURE',12,HSIGN) + SENTRY(IEN)=HSIGN + ENDIF + ENDIF + ENDDO +*---- +* Read EDIT and main option +* Default option is NDIST option +*---- + CARRET=';' + NOPT=MXOPT + IOPT(:NOPT)=0 + IPRINT=1 + 100 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .EQ. 10) GO TO 105 + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + >': Read error -- Character variable expected') + CARRET=CARLIR + IF(CARLIR .EQ. ';') THEN + GO TO 105 + ELSE IF(CARLIR .EQ. 'EDIT') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': Read error -- integer value for EDIT expected.') + IPRINT=INTLIR + ELSE IF(CARLIR .EQ. 'RNDPhysParam') THEN + IOPT(1)=1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + >': Read error -- Character variable expected') + CARRET=CARLIR + GO TO 105 + ELSE IF(CARLIR .EQ. 'GPTPhysParam') THEN + IOPT(1)=2 + GO TO 105 + ELSE IF(CARLIR .EQ. 'RNDMicXS') THEN + IOPT(1)=3 + GO TO 105 + ELSE IF(CARLIR .EQ. 'GPTMicXS') THEN + IOPT(1)=4 + GO TO 105 + ELSE + CALL XABORT(NAMSBR//': Read error -- keyword'//CARLIR// + >'for processing option is invalid.') + ENDIF + GO TO 100 + 105 CONTINUE +*---- +* Analyze structures +* Find the first L_EPC structure or the first new structure +*---- + DO IEN=1,NENTRY + HET=HENTRY(IEN) + IF(IENTRY(IEN) .EQ. 1 .OR. IENTRY(IEN) .EQ. 2) THEN + IF(JENTRY(IEN) .EQ. 1) THEN + IF(SENTRY(IEN) .EQ. 'L_EPC ') THEN + CALL LCMGET(KENTRY(IEN),'STATE-VECTOR',ISTATE) + IF(IOPT(1) .NE. ISTATE(1)) CALL XABORT(NAMSBR// + >': Structure L_EPC :'//HET// + >' not compatible with processing option.') + IOPT(2)=IEN + IOPT(4)=ISTATE(2) + GO TO 120 + ENDIF + ELSE + IOPT(2)=IEN + SENTRY(IEN)='L_EPC ' + ISTATE(1)=IOPT(1) + HSIGN=SENTRY(IEN) + CALL LCMPTC(KENTRY(IEN),'SIGNATURE',12,HSIGN) + CALL LCMPUT(KENTRY(IEN),'STATE-VECTOR',NSTATE,1,ISTATE) + IF(ISTATE(1) .EQ. 0) THEN + HSIGN=' ' + CALL LCMPTC(KENTRY(IEN),'ParametreNom',12,HSIGN) + CALL LCMPUT(KENTRY(IEN),'ParametreNbr',1,1,0) + CALL LCMPUT(KENTRY(IEN),'ParametreNxt',1,1,0) + CALL LCMPUT(KENTRY(IEN),'ParametreRef',1,2,0.0) + ENDIF + GO TO 120 + ENDIF + ENDIF + ENDDO + CALL XABORT(NAMSBR//': No structure found for L_EPC.') + 120 CONTINUE +*---- +* Find the first read_only SEQ_ASCII or BINARY file +*---- + DO IEN=1,NENTRY + IF(JENTRY(IEN) .EQ. 2) THEN + IF(IENTRY(IEN) .EQ. 3) THEN + IOPT(3)=-IEN + GO TO 130 + ELSE IF(IENTRY(IEN) .EQ. 4) THEN + IOPT(3)=IEN + GO TO 130 + ENDIF + ENDIF + ENDDO + 130 CONTINUE +*---- +* Process option +*---- + IF(IOPT(1) .EQ. 1) THEN +*---- +* Option RNDPhysParam +*---- + CALL EPCRPD(NENTRY,KENTRY,IPRINT,NOPT,IOPT,CARRET) + ELSE IF(IOPT(1) .EQ. 2) THEN +*---- +* Option GPTPhysParam +*---- + CALL XABORT(NAMSBR//' Option GPTPhysParam not programmed yet') +* CALL EPCGPD(NENTRY,KENTRY,IPRINT,NOPT,IOPT,CARRET) + ELSE IF(IOPT(1) .EQ. 3) THEN +*---- +* Locate microlib +*---- + DO IEN=1,NENTRY + IF(IENTRY(IEN) .EQ. 1 .OR. IENTRY(IEN) .EQ. 2) THEN + IF(JENTRY(IEN) .EQ. 1) THEN + CALL LCMGTC(KENTRY(IEN),'SIGNATURE',12,HSIGN) + IF(HSIGN .EQ. 'L_LIBRARY ') THEN + IOPT(4)=IEN + GO TO 140 + ENDIF + ENDIF + ENDIF + ENDDO +* CALL XABORT(NAMSBR//' Option RNDMicXS requires a microlib') + 140 CONTINUE +*---- +* Process +*---- + CALL EPCRMD(NENTRY,KENTRY,IPRINT,NOPT,IOPT,CARRET) + ELSE IF(IOPT(1) .EQ. 4) THEN +*---- +* Option GPTMicXS +*---- + CALL XABORT(NAMSBR//' Option GPTMicXS not programmed yet') +* CALL EPCGMD(NENTRY,KENTRY,IPRINT,NOPT,IOPT,CARRET) + ENDIF +*---- +* Processing finished, return +*---- + RETURN +*---- +* Warning formats +*---- + END diff --git a/Dragon/src/EPCRMA.f b/Dragon/src/EPCRMA.f new file mode 100644 index 0000000..933683e --- /dev/null +++ b/Dragon/src/EPCRMA.f @@ -0,0 +1,279 @@ +*DECK EPCRMA + SUBROUTINE EPCRMA(IPMIC,IPRINT,NGR,NXS,NCV,NMIXT,NIFISS,IMIX, + > ISOF,ITOTL,ISCAT,NAMDXS,DENSI,ICOV,COV,DRVAR, + > XSREC,XSMAC,VAR,VAROLD,RST) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Add contribution of random error distribution to MACROLIB. +* +*Copyright: +* Copyright (C) 2009 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPMIC pointer to microlib. +* IPRINT print level. +* NGR number of groups. +* NXS number of cross section types on EPC. +* NCV maximum dimension of symmetrized covariance matrix. +* NMIXT number of MIXTURES on MICROLIB. +* NIFISS number of fissiles isotopes on MICROLIB. +* IMIX mixture containing isotope. +* ISOF fissile isotope number on MACROLIB. +* ITOTL position of total XS in NAMDXS. +* ISCAT position of scattering XS in NAMDXS. +* NAMDXS names of XS. +* DENSI isotope density. +* COV variance and covariance matrix. +* ICOV variance and covariance index. +* DRVAR random distribution (width=1.). +* XSREC microscopic vector XS. +* +*Parameters: input/output +* XSMAC macroscopic vector XS contribution. +* VAR multigroup variance. +* VAROLD multigroup variance from previous correction. +* RST ratio of scattering over total XS. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPMIC + INTEGER IPRINT,NGR,NXS,NCV,NMIXT,NIFISS,IMIX,ISOF,ITOTL, + > ISCAT + CHARACTER*6 NAMDXS(NXS) + REAL DENSI + INTEGER ICOV(NGR,NXS) + REAL COV(NCV,NXS) + DOUBLE PRECISION DRVAR(NGR,NXS) + REAL XSREC(NGR,NXS), + > XSMAC(NGR,NXS,NMIXT,NIFISS),VAR(NGR), + > VAROLD(NGR),RST(NGR) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='EPCRMA') +*---- +* Local variables +*---- + INTEGER IPRTL,IXS,IGR,ILOC,IDR,ILCMLN,ILCMTY + INTEGER KTOPT,ILOCS + DOUBLE PRECISION CTOTL,CSCAT,CABS +*---- +* Write header +*---- + IPRTL=IPRINT + IF(IPRTL .GE. 10) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF +*---- +* Two options : +* KTOPT = 0 : Scattering and total are independent +* KTOPT = 1 : RST is scattering over total XS ratio +* KTOPT = 2 : RST is absorption XS +*---- + KTOPT=2 + IF(KTOPT .EQ. 1) THEN + DO IGR=1,NGR + RST(IGR)=XSREC(IGR,ISCAT)/XSREC(IGR,ITOTL) + ENDDO + ELSE IF(KTOPT .EQ. 2) THEN + DO IGR=1,NGR + RST(IGR)=XSREC(IGR,ITOTL)-XSREC(IGR,ISCAT) +* write(6,'(1X,I5,1P,3E15.7)') +* > IGR,XSREC(IGR,ITOTL),XSREC(IGR,ISCAT),RST(IGR) + ENDDO + ELSE + RST(:NGR)=0.0 + ENDIF +*---- +* Process all vector cross section types +*---- + DO IXS=1,NXS + ILOC=1 + ILOCS=1 + IF(NAMDXS(IXS) .EQ. 'NUSIGF') THEN +* write(6,*) NAMDXS(IXS) + IF(ISOF .GT. 0) THEN + CALL LCMLEN(IPMIC,NAMDXS(IXS),ILCMLN,ILCMTY) + IF(ILCMLN .EQ. NGR) THEN + CALL LCMGET(IPMIC,NAMDXS(IXS),VAROLD) + ELSE + VAROLD(:NGR)=0.0 + ENDIF + IDR=ISOF + DO IGR=1,NGR + VAR(IGR)=REAL(COV(ILOC,IXS)*XSREC(IGR,IXS)*DRVAR(IGR,IXS)) + IF(ABS(VAR(IGR))/ABS(XSREC(IGR,IXS)) .GT. 1.0) THEN + WRITE(IOUT,*) 'VAR ',NAMDXS(IXS),IMIX,ISOF,IGR, + > VAR(IGR),XSREC(IGR,IXS),COV(ILOC,IXS),DRVAR(IGR,IXS) + ELSE + XSMAC(IGR,IXS,IMIX,IDR)=XSMAC(IGR,IXS,IMIX,IDR)+ + > DENSI*(VAR(IGR)-VAROLD(IGR)) + ENDIF + ILOC=ILOC+ICOV(IGR,IXS) + ENDDO + IF(IPRTL .GE. 10) THEN + WRITE(IOUT,*) 'VAR ',NAMDXS(IXS),IMIX,ISOF + WRITE(IOUT,6010) (VAR(IGR),IGR=1,NGR) + WRITE(IOUT,*) 'VAROLD ',NAMDXS(IXS),IMIX,ISOF + WRITE(IOUT,6010) (VAROLD(IGR),IGR=1,NGR) + ENDIF + CALL LCMPUT(IPMIC,NAMDXS(IXS),NGR,2,VAR) + ENDIF + ELSE IF(IXS .EQ. ITOTL) THEN +* write(6,*) NAMDXS(IXS) + IDR=1 + CALL LCMLEN(IPMIC,NAMDXS(IXS),ILCMLN,ILCMTY) + IF(ILCMLN .EQ. NGR) THEN + CALL LCMGET(IPMIC,NAMDXS(IXS),VAROLD) + ELSE + VAROLD(:NGR)=0 + ENDIF + IF(KTOPT .EQ. 1) THEN +*---- +* Assume the perturbation term comes from scattering with a contribution +* proportional to RST and from total with a contribution +* proportional to (1-RST) +*---- + DO IGR=1,NGR + CTOTL=COV(ILOC,ITOTL)*XSREC(IGR,ITOTL)*DRVAR(IGR,ITOTL) + CSCAT=COV(ILOCS,ISCAT)*XSREC(IGR,ISCAT)*DRVAR(IGR,ISCAT) + VAR(IGR)=REAL((1.-RST(IGR))*CTOTL+RST(IGR)*CSCAT) +* write(6,'(1X,I5,1P,6E15.7)') +* > IGR,XSREC(IGR,ITOTL),XSREC(IGR,ISCAT),RST(IGR), +* > VAR(IGR),CTOTL,CSCAT + IF(ABS(VAR(IGR))/ABS(XSREC(IGR,IXS)) .GT. 1.0) THEN + WRITE(IOUT,*) 'VAR ',NAMDXS(IXS),IMIX,ISOF,IGR, + > VAR(IGR),XSREC(IGR,IXS),COV(ILOC,IXS),DRVAR(IGR,IXS) + ELSE + XSMAC(IGR,IXS,IMIX,IDR)=XSMAC(IGR,IXS,IMIX,IDR)+ + > DENSI*(VAR(IGR)-VAROLD(IGR)) + ENDIF + ILOC=ILOC+ICOV(IGR,IXS) + ILOCS=ILOCS+ICOV(IGR,ISCAT) + ENDDO + ELSE IF(KTOPT .EQ. 2) THEN +*---- +* Assume the perturbation term comes from scattering and absorption +*---- + DO IGR=1,NGR + CABS=COV(ILOC,ITOTL)*RST(IGR)*DRVAR(IGR,ITOTL) + CTOTL=COV(ILOC,ITOTL)*XSREC(IGR,ITOTL)*DRVAR(IGR,ITOTL) + CSCAT=COV(ILOCS,ISCAT)*XSREC(IGR,ISCAT)*DRVAR(IGR,ISCAT) + VAR(IGR)=REAL(CABS+CSCAT) +* write(6,'(1X,I5,1P,7E15.7)') +* > IGR,XSREC(IGR,ITOTL),XSREC(IGR,ISCAT),RST(IGR), +* > VAR(IGR),CABS,CSCAT,CTOTL + IF(ABS(VAR(IGR))/ABS(XSREC(IGR,IXS)) .GT. 1.0) THEN + WRITE(IOUT,*) 'VAR ',NAMDXS(IXS),IMIX,ISOF,IGR, + > VAR(IGR),XSREC(IGR,IXS),COV(ILOC,IXS),DRVAR(IGR,IXS) + ELSE + XSMAC(IGR,IXS,IMIX,IDR)=XSMAC(IGR,IXS,IMIX,IDR)+ + > DENSI*(VAR(IGR)-VAROLD(IGR)) + ENDIF + ILOC=ILOC+ICOV(IGR,IXS) + ILOCS=ILOCS+ICOV(IGR,ISCAT) + ENDDO + ELSE +*---- +* Assume total and scattering are independant +*---- + DO IGR=1,NGR + CTOTL=COV(ILOC,ITOTL)*XSREC(IGR,ITOTL)*DRVAR(IGR,ITOTL) + VAR(IGR)=REAL(CTOTL) +* write(6,'(1X,I5,1P,6E15.7)') +* > IGR,XSREC(IGR,ITOTL),XSREC(IGR,ISCAT),RST(IGR), +* > VAR(IGR) + IF(ABS(VAR(IGR))/ABS(XSREC(IGR,IXS)) .GT. 1.0) THEN + WRITE(IOUT,*) 'VAR ',NAMDXS(IXS),IMIX,ISOF,IGR, + > VAR(IGR),XSREC(IGR,IXS),COV(ILOC,IXS),DRVAR(IGR,IXS) + ELSE + XSMAC(IGR,IXS,IMIX,IDR)=XSMAC(IGR,IXS,IMIX,IDR)+ + > DENSI*(VAR(IGR)-VAROLD(IGR)) + ENDIF + ILOC=ILOC+ICOV(IGR,IXS) + ENDDO + ENDIF + IF(IPRTL .GE. 10) THEN + WRITE(IOUT,*) 'VAR ',NAMDXS(IXS),IMIX + WRITE(IOUT,6010) (VAR(IGR),IGR=1,NGR) + WRITE(IOUT,*) 'VAROLD ',NAMDXS(IXS),IMIX,ISOF + WRITE(IOUT,6010) (VAROLD(IGR),IGR=1,NGR) + ENDIF + CALL LCMPUT(IPMIC,NAMDXS(IXS),NGR,2,VAR) + ELSE +* write(6,*) NAMDXS(IXS) + IDR=1 + CALL LCMLEN(IPMIC,NAMDXS(IXS),ILCMLN,ILCMTY) + IF(ILCMLN .EQ. NGR) THEN + CALL LCMGET(IPMIC,NAMDXS(IXS),VAROLD) + ELSE + VAROLD(:NGR)=0 + ENDIF + DO IGR=1,NGR + VAR(IGR)=REAL(COV(ILOC,IXS)*XSREC(IGR,IXS)*DRVAR(IGR,IXS)) +* write(6,'(1X,I5,1P,6E15.7)') +* > IGR,XSREC(IGR,ITOTL),XSREC(IGR,ISCAT),XSREC(IGR,IXS),VAR(IGR) + IF(ABS(VAR(IGR))/ABS(XSREC(IGR,IXS)) .GT. 1.0) THEN + WRITE(IOUT,*) 'VAR ',NAMDXS(IXS),IMIX,ISOF,IGR, + > VAR(IGR),XSREC(IGR,IXS),COV(ILOC,IXS),DRVAR(IGR,IXS) + ELSE + XSMAC(IGR,IXS,IMIX,IDR)=XSMAC(IGR,IXS,IMIX,IDR)+ + > DENSI*(VAR(IGR)-VAROLD(IGR)) + ENDIF + ILOC=ILOC+ICOV(IGR,IXS) + ENDDO + IF(IPRTL .GE. 10) THEN + WRITE(IOUT,*) 'VAR ',NAMDXS(IXS),IMIX + WRITE(IOUT,6010) (VAR(IGR),IGR=1,NGR) + WRITE(IOUT,*) 'VAROLD ',NAMDXS(IXS),IMIX,ISOF + WRITE(IOUT,6010) (VAROLD(IGR),IGR=1,NGR) + ENDIF + CALL LCMPUT(IPMIC,NAMDXS(IXS),NGR,2,VAR) + ENDIF + ENDDO +*---- +* Print if required +*---- + IF(IPRTL .GE. 10) THEN + DO IXS=1,NXS + IF(NAMDXS(IXS) .EQ. 'NUSIGF') THEN + IF(ISOF .GT. 0) THEN + WRITE(IOUT,*) 'MAC ',NAMDXS(IXS),IMIX,ISOF + WRITE(IOUT,6010) (XSMAC(IGR,IXS,IMIX,ISOF),IGR=1,NGR) + ENDIF + ELSE + WRITE(IOUT,*) 'MAC ',NAMDXS(IXS),IMIX + WRITE(IOUT,6010) (XSMAC(IGR,IXS,IMIX,1),IGR=1,NGR) + ENDIF + ENDDO + ENDIF +*---- +* Write header and return +*---- + IF(IPRTL .GE. 10) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(1P,10E12.4,:,' ...') + END diff --git a/Dragon/src/EPCRMD.f b/Dragon/src/EPCRMD.f new file mode 100644 index 0000000..07696d5 --- /dev/null +++ b/Dragon/src/EPCRMD.f @@ -0,0 +1,234 @@ +*DECK EPCRMD + SUBROUTINE EPCRMD(NENTRY,KENTRY,IPRINT,NOPT,IOPT,CARRET) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Driver for Error Propagation Module with option "RNDMicXS". +* +*Copyright: +* Copyright (C) 2009 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* NENTRY number of data structures transfered to this module. +* KENTRY data structure pointer. +* IPRINT print level. +* NOPT length of array IOPT containing the procession option flags. +* IOPT processing option with: +* IOPT(1) type of processing (3 for current option); +* IOPT(2) entry number for L_EPC structure; +* IOPT(3) entry number for read only SEQ_ASCII or BINARY file; +* IOPT(4) entry number for update microlib. +* CARRET last input option read. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NENTRY + TYPE(C_PTR) KENTRY(NENTRY) + INTEGER IPRINT,NOPT,IOPT(NOPT) + CHARACTER*12 CARRET +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='EPCRMD') + INTEGER ILCMUP,ILCMDN + PARAMETER (ILCMUP=1,ILCMDN=2) + INTEGER NSTATE,NTC + PARAMETER (NSTATE=40,NTC=3) + INTEGER NDPROC + PARAMETER (NDPROC=20) +*---- +* Input and output parameters +*---- + INTEGER ITYPLU,INTLIR + CHARACTER CARLIR*12 + REAL REALIR + DOUBLE PRECISION DBLLIR +*---- +* Local variables +*---- + TYPE(C_PTR) IPEPC,IPMIC + INTEGER IPCOV,IFMT,IEN,IPRTL,IXS + INTEGER ISTATE(NSTATE),ISTATM(NSTATE) + CHARACTER*6 NAMDXS(NDPROC+1) + CHARACTER*8 XSN + INTEGER NGR,NIS,NXS,NCV,ISOREC + INTEGER NMIXT,NBISO,NGROUP,NIFISS,NFI,NISL + INTEGER ITOTL,ISCAT +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NAMISO,NISOU,ISOMIX,IDVF, + > IDMF,IDXS +*---- +* Read instruction for RNDMicXS +*---- + IPRTL=IPRINT + IF(IPRTL .GE. 10) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + IF(CARRET .EQ. ';') GO TO 105 + 100 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + CONTINUE + IF(ITYPLU .EQ. 10) GO TO 105 + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + >': Read error -- Character variable expected') + CARRET=CARLIR + IF(CARLIR .EQ. ';') THEN + GO TO 105 + ELSE + CALL XABORT(NAMSBR//': Read error -- keyword'//CARLIR// + >'for processing option is invalid.') + ENDIF + GO TO 100 + 105 CONTINUE +*---- +* Output structure +*---- + IEN=ABS(IOPT(3)) + IPEPC=KENTRY(ABS(IOPT(2))) + IPCOV=FILUNIT(KENTRY(IEN)) + IPMIC=KENTRY(ABS(IOPT(4))) + IF(IOPT(3) .NE. 0) THEN +*---- +* Transfer Variance and covariance data on EPC data structure +*---- + IFMT=IOPT(3)/IEN + IF(IFMT .GT. 0) THEN + READ(IPCOV,'(3I8)') NGR,NIS,NXS + ELSE + READ(IPCOV) NGR,NIS,NXS + ENDIF + IF(IPRTL .GE. 10) THEN + WRITE(IOUT,6010) NGR,NIS,NXS + ENDIF + NCV=(NGR*(NGR+1))/2 + CALL EPCRMV(IPEPC,IPCOV,IPRINT,IFMT,NGR,NIS,NXS,NCV) + ISTATE(:NSTATE)=0 + ISTATE(1)=IOPT(1) + ISTATE(2)=NGR + ISTATE(3)=NIS + ISTATE(4)=NXS + CALL LCMPUT(IPEPC,'STATE-VECTOR',NSTATE,1,ISTATE) + ENDIF + IF(IOPT(4) .NE. 0) THEN +*---- +* Get info for EPC data structure +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(IPEPC,'STATE-VECTOR',ISTATE) + IF(ISTATE(1) .NE. 3) CALL XABORT(NAMSBR// + >': Invalid format for EPC data structure') + NGR=ISTATE(2) + NIS=ISTATE(3) + NXS=ISTATE(4) + ISOREC=ISTATE(5) + NFI=ISTATE(6) + NISL=ISTATE(7) + IF(IPRTL .GE. 10) THEN + WRITE(IOUT,6011) NGR,NIS,NXS + ENDIF + NCV=(NGR*(NGR+1))/2 +*---- +* Get info for microlib data structure +*---- + ISTATM(:NSTATE)=0 + CALL LCMGET(IPMIC,'STATE-VECTOR',ISTATM) + NMIXT=ISTATM(1) + NBISO=ISTATM(2) + NGROUP=ISTATM(3) + IF(NGROUP .NE. NGR) CALL XABORT(NAMSBR// + >': Number of groups in MICROLIB and EPC incoherent.') + CALL LCMSIX(IPMIC,'MACROLIB ',ILCMUP) + ISTATM(:NSTATE)=0 + CALL LCMGET(IPMIC,'STATE-VECTOR',ISTATM) + NIFISS=ISTATM(4) + CALL LCMSIX(IPMIC,'MACROLIB ',ILCMDN) +*---- +* Allocate memory +*---- + ALLOCATE(NAMISO(3*NIS),NISOU(3*NBISO),ISOMIX(NBISO),IDVF(2*NIS), + > IDMF(2*NBISO)) + CALL LCMGET(IPMIC,'ISOTOPESUSED',NISOU) + CALL LCMGET(IPMIC,'ISOTOPESMIX ',ISOMIX) + CALL LCMSIX(IPEPC,'XSVariances ',ILCMUP) + CALL LCMGET(IPEPC,'NAMEISO ',NAMISO) +*---- +* Variance XS +*---- + ALLOCATE(IDXS(2*NXS)) + CALL LCMGET(IPEPC,'NAMEXS ',IDXS) + ISCAT=0 + ITOTL=0 + DO IXS=1,NXS + WRITE(XSN,'(2A4)') IDXS(2*IXS-1),IDXS(2*IXS) + NAMDXS(IXS)=XSN(1:6) + IF(NAMDXS(IXS).EQ.'TOTAL ') THEN + ITOTL=IXS + ELSE IF(NAMDXS(IXS).EQ.'SIGS00') THEN + ISCAT=IXS + ENDIF + ENDDO + DEALLOCATE(IDXS) + IF(ISOREC .EQ. 0) THEN + CALL EPCRMI(IPMIC,IPRINT,NIS,NBISO,NMIXT,NIFISS, + > NAMISO,NISOU,IDVF,IDMF) + CALL LCMPUT(IPEPC,'INDEXISOV',2*NIS,1,IDVF) + CALL LCMPUT(IPEPC,'INDEXISOM',2*NBISO,1,IDMF) + ISOREC=1 + NFI=NIFISS + NISL=NBISO + ISTATE(5)=ISOREC + ISTATE(6)=NFI + ISTATE(7)=NISL + CALL LCMPUT(IPEPC,'STATE-VECTOR',NSTATE,1,ISTATE) + ELSE + IF(NFI .NE. NIFISS) CALL XABORT(NAMSBR// + >': Number of fissile isotopes in MICROLIB and EPC incoherent.') + IF(NISL .NE. NBISO) CALL XABORT(NAMSBR// + >': Number of isotopes in MICROLIB and EPC incoherent.') + CALL LCMGET(IPEPC,'INDEXISOV',IDVF) + CALL LCMGET(IPEPC,'INDEXISOM',IDMF) + ENDIF +*---- +* Update macrolib from random error distribution +*---- + CALL EPCRMU(IPEPC,IPMIC,IPRINT,NGR,NIS,NXS,NCV, + > NBISO,NMIXT,NIFISS,ITOTL,ISCAT,NAMDXS, + > NAMISO,NISOU,ISOMIX,IDVF,IDMF) + DEALLOCATE(IDMF,IDVF,ISOMIX,NISOU,NAMISO) + CALL LCMSIX(IPEPC,'XSVariances ',ILCMDN) + ENDIF + IF(IPRTL .GE. 10) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(' Creating EPC data structure with:'/ + > ' NGROUP = ',I8/ + > ' NISO = ',I8/ + > ' NXS = ',I8) + 6011 FORMAT(' Updating MICROLIB from EPC with:'/ + > ' NGROUP = ',I8/ + > ' NISO = ',I8/ + > ' NXS = ',I8) + END diff --git a/Dragon/src/EPCRMI.f b/Dragon/src/EPCRMI.f new file mode 100644 index 0000000..5c4d631 --- /dev/null +++ b/Dragon/src/EPCRMI.f @@ -0,0 +1,131 @@ +*DECK EPCRMI + SUBROUTINE EPCRMI(IPMIC,IPRINT,NIS,NBISO,NMIXT,NIFISS, + > NAMISO,NISOU,IDVF,IDMF) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Cross reference variance isotopes and MICROLIB isotopes. +* +*Copyright: +* Copyright (C) 2009 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPMIC pointer to microlib. +* IPRINT print level. +* NIS number of isotopes on EPC. +* NBISO number of isotopes on MICROLIB. +* NMIXT number of mixtures on MICROLIB. +* NIFISS number of fissiles isotopes on MICROLIB. +* +*Parameters: output +* NAMISO array containing the isotope names. +* NISOU MICROLIB isotopes used. +* IDVF variance isotopes to analyze and fission id. +* IDMF MICROLIB isotopes to analyze and fission id. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPMIC + INTEGER IPRINT,NIS,NBISO,NMIXT,NIFISS + INTEGER NAMISO(3,NIS),NISOU(3,NBISO), + > IDVF(2,NIS),IDMF(2,NBISO) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='EPCRMI') + INTEGER ILCMUP,ILCMDN + PARAMETER (ILCMUP=1,ILCMDN=2) +*---- +* Local variables +*---- + INTEGER IPRTL,NBIU,ISO,JSO,IFI +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NISON,FID,FNM +*---- +* Scratch storage allocation +* NISON MICROLIB isotopes reference names +* FID MICROLIB fissile id +* FNM MICROLIB fissile name +*---- + ALLOCATE(NISON(3,NBISO),FID(NMIXT,NIFISS),FNM(2,NIFISS)) +*---- +* Write header +*---- + IPRTL=IPRINT + IF(IPRTL .GE. 10) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF +*---- +* Isotope names identification +*---- + CALL LCMGET(IPMIC,'ISOTOPERNAME',NISON) +*---- +* Fissile isotopes identifier +*---- + CALL LCMSIX(IPMIC,'MACROLIB ',ILCMUP) + CALL LCMGET(IPMIC,'FISSIONINDEX',FID) + CALL LCMGET(IPMIC,'FISSIONNAMES',FNM) + CALL LCMSIX(IPMIC,'MACROLIB ',ILCMDN) + IDVF(:2,:NIS)=0 + IDMF(:2,:NBISO)=0 + DO ISO=1,NIS +*---- +* Test if isotope used in Microlib +*---- + NBIU=0 + DO JSO=1,NBISO + IF( (NISON(1,JSO) .EQ. NAMISO(1,ISO)) .AND. + > (NISON(2,JSO) .EQ. NAMISO(2,ISO)) .AND. + > (NISON(3,JSO) .EQ. NAMISO(3,ISO)) ) THEN + IDMF(1,JSO)=ISO + NBIU=NBIU+1 + ENDIF + ENDDO + IF(NBIU .GT. 0) IDVF(1,ISO)=1 + ENDDO +*---- +* Find fissile isotope id +*---- + DO JSO=1,NBISO + ISO=IDMF(1,JSO) + IF(ISO .GT. 0) THEN + DO IFI=1,NIFISS + IF( (FNM(1,IFI) .EQ. NISOU(1,JSO)) .AND. + > (FNM(2,IFI) .EQ. NISOU(2,JSO)) ) THEN + IDMF(2,JSO)=IFI + IDVF(2,ISO)=IFI + ENDIF + ENDDO + ENDIF + ENDDO + IF(IPRTL .GE. 2) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(FNM,FID,NISON) + RETURN +*---- +* Formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + END diff --git a/Dragon/src/EPCRMS.f b/Dragon/src/EPCRMS.f new file mode 100644 index 0000000..5d8c72f --- /dev/null +++ b/Dragon/src/EPCRMS.f @@ -0,0 +1,171 @@ +*DECK EPCRMS + SUBROUTINE EPCRMS(IPMIC,IPRINT,NGR,NXS,NMIXT,NIFISS, + > NAMDXS,XSMAC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Add perturbation to base cross section and save +* on MACROLIB. +* +*Copyright: +* Copyright (C) 2009 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPMIC pointer to MICROLIB. +* IPRINT print level. +* NGR number of groups. +* NXS number of cross section types on EPC. +* NMIXT number of mixtures on MICROLIB. +* NIFISS number of fissile isotopes on MICROLIB. +* NAMDXS names of XS. +* XSMAC macroscopic vector XS contribution. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPMIC + INTEGER IPRINT,NGR,NXS,NMIXT,NIFISS + CHARACTER*6 NAMDXS(NXS) + REAL XSMAC(NGR,NXS,NMIXT,NIFISS) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='EPCRMS') +*---- +* Local variables +*---- + TYPE(C_PTR) JPMIC,KPMIC + INTEGER IPRTL,IXS,IGR,IMIX,ILCMLN,ILCMTY,ILOC,IFI +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,IPO + REAL, ALLOCATABLE, DIMENSION(:) :: XSREC,XSSCMP + REAL, ALLOCATABLE, DIMENSION(:,:) :: XSFIS +*---- +* Scratch storage allocation +* XSREC Macroscopic vector XS +* XSFIS Macroscopic vector fission XS +* XSSCMP Compressed macroscopic scattering matrix +* IJJ IJJ scattering index +* IPO IPO scattering index +*---- + ALLOCATE(IJJ(NMIXT),IPO(NMIXT)) + ALLOCATE(XSREC(NMIXT),XSFIS(NMIXT,NIFISS),XSSCMP(NGR*NMIXT)) +*---- +* Write header +*---- + IPRTL=IPRINT + IF(IPRTL .GE. 10) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + JPMIC=LCMGID(IPMIC,'GROUP') + DO IGR=1,NGR + KPMIC=LCMGIL(JPMIC,IGR) + DO IXS=1,NXS + IF(NAMDXS(IXS) .EQ. 'SIGS00') THEN +* Total and within group scattering + CALL LCMGET(KPMIC,'SIGS00',XSREC) + IF(IPRTL .GE. 10) THEN + write(6,*) NAMDXS(IXS),IGR + WRITE(IOUT,'(1P,3E12.4)') + > (XSREC(IMIX),XSMAC(IGR,IXS,IMIX,1), + > XSREC(IMIX)+XSMAC(IGR,IXS,IMIX,1), + > IMIX=1,NMIXT) + ENDIF + DO IMIX=1,NMIXT + IF(ABS(XSREC(IMIX)) .LT. ABS(XSMAC(IGR,IXS,IMIX,1))) THEN + write(6,*) 'Erreur ',NAMDXS(IXS),' ',imix,igr + ENDIF + XSREC(IMIX)=XSREC(IMIX)+XSMAC(IGR,IXS,IMIX,1) + ENDDO + CALL LCMPUT(KPMIC,'SIGS00',NMIXT,2,XSREC) + CALL LCMGET(KPMIC,'SIGW00',XSREC) + DO IMIX=1,NMIXT + IF(ABS(XSREC(IMIX)) .LT. ABS(XSMAC(IGR,IXS,IMIX,1))) THEN + write(6,*) 'Erreur ',NAMDXS(IXS),' ',imix,igr + ENDIF + XSREC(IMIX)=XSREC(IMIX)+XSMAC(IGR,IXS,IMIX,1) + ENDDO + CALL LCMPUT(KPMIC,'SIGW00',NMIXT,2,XSREC) +* Scattering matrix + CALL LCMLEN(KPMIC,'SCAT00',ILCMLN,ILCMTY) + CALL LCMGET(KPMIC,'SCAT00',XSSCMP) + CALL LCMGET(KPMIC,'IJJS00',IJJ) + CALL LCMGET(KPMIC,'IPOS00',IPO) + DO IMIX=1,NMIXT + ILOC=IPO(IMIX)+IJJ(IMIX)-IGR + XSSCMP(ILOC)=XSSCMP(ILOC)+XSMAC(IGR,IXS,IMIX,1) + ENDDO + CALL LCMPUT(KPMIC,'SCAT00',ILCMLN,ILCMTY,XSSCMP) + ELSE IF(NAMDXS(IXS) .EQ. 'NUSIGF') THEN +* Fission + CALL LCMGET(KPMIC,NAMDXS(IXS),XSFIS) + IF(IPRTL .GE. 10) THEN + write(6,*) NAMDXS(IXS),IGR + WRITE(IOUT,'(1P,3E12.4)') + > ((XSFIS(IMIX,IFI),XSMAC(IGR,IXS,IMIX,IFI), + > XSFIS(IMIX,IFI)+XSMAC(IGR,IXS,IMIX,IFI), + > IMIX=1,NMIXT),IFI=1,NIFISS) + ENDIF + DO IFI=1,NIFISS + DO IMIX=1,NMIXT + IF(ABS(XSFIS(IMIX,IFI)) .LT. + > ABS(XSMAC(IGR,IXS,IMIX,IFI))) THEN + write(6,*) 'Erreur ',NAMDXS(IXS),' ',imix,igr + ENDIF + XSFIS(IMIX,IFI)=XSFIS(IMIX,IFI)+XSMAC(IGR,IXS,IMIX,IFI) + ENDDO + ENDDO + CALL LCMPUT(KPMIC,NAMDXS(IXS),NIFISS*NMIXT,2,XSFIS) + ELSE + CALL LCMGET(KPMIC,NAMDXS(IXS),XSREC) + IF(IPRTL .GE. 10) THEN + WRITE(6,*) NAMDXS(IXS),IGR + WRITE(IOUT,'(1P,3E12.4)') + > (XSREC(IMIX),XSMAC(IGR,IXS,IMIX,1), + > XSREC(IMIX)+XSMAC(IGR,IXS,IMIX,1), + > IMIX=1,NMIXT) + ENDIF + DO IMIX=1,NMIXT + IF(ABS(XSREC(IMIX)) .LT. ABS(XSMAC(IGR,IXS,IMIX,1))) THEN + write(6,*) 'Erreur ',NAMDXS(IXS),' ',imix,igr + ENDIF + XSREC(IMIX)=XSREC(IMIX)+XSMAC(IGR,IXS,IMIX,1) + ENDDO + CALL LCMPUT(KPMIC,NAMDXS(IXS),NMIXT,2,XSREC) + ENDIF + ENDDO + ENDDO +*---- +* Write header and return +*---- + IF(IPRTL .GE. 10) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(XSSCMP,XSFIS,XSREC) + DEALLOCATE(IPO,IJJ) + RETURN +*---- +* Formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + END diff --git a/Dragon/src/EPCRMU.f b/Dragon/src/EPCRMU.f new file mode 100644 index 0000000..7021bee --- /dev/null +++ b/Dragon/src/EPCRMU.f @@ -0,0 +1,201 @@ +*DECK EPCRMU + SUBROUTINE EPCRMU(IPEPC,IPMIC,IPRINT,NGR,NIS,NXS,NCV, + > NBISO,NMIXT,NIFISS,ITOTL,ISCAT,NAMDXS, + > NAMISO,NISOU,ISOMIX,IDVF,IDMF) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Update MACROLIB from random error distribution. +* +*Copyright: +* Copyright (C) 2009 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPEPC pointer to EPC data structure. +* IPMIC pointer to MICROLIB. +* IPRINT print level. +* NGR number of groups. +* NIS number of isotopes on EPC. +* NXS number of cross section types on EPC. +* NCV maximum dimension of symmetrized covariance matrix. +* NBISO number of isotopes on MICROLIB. +* NMIXT number of mixtures on MICROLIB. +* NIFISS number of fissiles isotopes on MICROLIB. +* ITOTL position of total XS in NAMDXS. +* ISCAT position of scattering XS in NAMDXS. +* NAMDXS names of XS. +* NAMISO array containing the isotope names. +* NISOU MICROLIB isotopes used. +* ISOMIX MICROLIB isotopes mixtures. +* IDVF variance isotopes to analyze and fission id. +* IDMF MICROLIB isotopes to analyze and fission id. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPEPC,IPMIC + INTEGER IPRINT,NGR,NIS,NXS,NCV, + > NBISO,NMIXT,NIFISS,ITOTL,ISCAT + CHARACTER*6 NAMDXS(NXS) + INTEGER NAMISO(3,NIS),NISOU(3,NBISO),ISOMIX(NBISO), + > IDVF(2,NIS),IDMF(2,NBISO) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='EPCRMU') + INTEGER ILCMUP,ILCMDN + PARAMETER (ILCMUP=1,ILCMDN=2) +*---- +* Local variables +*---- + INTEGER ILCMLN,ILCMTY,IPRTL + INTEGER ISO,IXS,JSO,IGR,ISOF + CHARACTER ISONAM*12,RECNAM*12,NAMMIC*12 + INTEGER ITC,IMIX + REAL DENSI + INTEGER ISEED,IGS,IORD,MINLEG,MAXLEG + SAVE ISEED,IGS,IORD,MINLEG,MAXLEG +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ICOV + REAL, ALLOCATABLE, DIMENSION(:) :: DENS,XSMAC,XSREC,VAR,VAROLD,RST + REAL, ALLOCATABLE, DIMENSION(:,:) :: COV + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: DRVAR +*---- +* Data statement +*---- + DATA ISEED,IGS,IORD,MINLEG,MAXLEG + > /0, -1, 1, 0, 0/ +*---- +* Scratch storage allocation +* ICOV array to store indices to reconstructe full covariance +* matrix from compressed covariance matrix. +* COV array to store compressed covariance matrix. +* DENS MICROLIB isotopes densities +* DRVAR Random variance distribution (width=1) +*---- + ALLOCATE(ICOV(NGR,NXS)) + ALLOCATE(DENS(NBISO),COV(NCV,NXS)) + ALLOCATE(DRVAR(NGR,NXS)) +*---- +* Write header +*---- + IPRTL=IPRINT + IF(IPRTL .GE. 2) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF +*---- +* Isotope densities +*---- + ALLOCATE(XSMAC(NGR*NXS*NMIXT*NIFISS)) + XSMAC(:NGR*NXS*NMIXT*NIFISS)=0.0 + ALLOCATE(XSREC(NGR*(NXS+1)),VAR(NGR),VAROLD(NGR),RST(NGR)) + CALL LCMGET(IPMIC,'ISOTOPESDENS',DENS) + DO ISO=1,NIS +*---- +* Test if isotope used in Microlib +*---- + IF(IDVF(1,ISO) .GT .0) THEN +*---- +* Isotope is used +* read covariance matrices +*---- + ICOV(:NGR,:NXS)=0 + COV(:NCV,:NXS)=0.0 + WRITE(ISONAM,'(3A4)') (NAMISO(ITC,ISO),ITC=1,3) + IF(IPRTL .GE. 2) THEN + WRITE(IOUT,*) ISONAM + ENDIF + CALL LCMSIX(IPEPC,ISONAM,ILCMUP) + DO IXS=1,NXS +*---- +* Get covariance matrices +*---- + RECNAM='INDX'//NAMDXS(IXS)//' ' + CALL LCMLEN(IPEPC,RECNAM,ILCMLN,ILCMTY) + IF(ILCMLN .EQ. NGR) THEN + CALL LCMGET(IPEPC,RECNAM,ICOV(1,IXS)) + RECNAM=NAMDXS(IXS)//' ' + CALL LCMGET(IPEPC,RECNAM,COV(1,IXS)) +*---- +* Generate random numbers from normal distribution +*---- + CALL RANDDN(ISEED,NGR,DRVAR(1,IXS)) + IF(IPRTL .GE. 5) THEN + WRITE(IOUT,*) NAMDXS(IXS),'DRVAR=[' + WRITE(IOUT,6010) (DRVAR(IGR,IXS),IGR=1,NGR) + WRITE(IOUT,*) '];' + ENDIF + ENDIF + ENDDO + CALL LCMSIX(IPEPC,ISONAM,ILCMDN) +*---- +* Scan over Microlib isotopes associated with this variance isotope +*---- + DO JSO=1,NBISO + IF(IDMF(1,JSO) .EQ. ISO) THEN + ISOF=IDMF(2,JSO) +*---- +* Read microlib for isotope +*---- + WRITE(NAMMIC,'(3A4)') (NISOU(ITC,JSO),ITC=1,3) + CALL LCMSIX(IPMIC,NAMMIC,ILCMUP) +*---- +* Get microscopic xs +*---- + CALL XDRLXS(IPMIC,IGS,IPRINT,NXS,NAMDXS,IORD,NGR,XSREC) +*---- +* Add contribution to macrolib +*---- + DENSI=DENS(JSO) + IMIX=ISOMIX(JSO) + CALL LCMSIX(IPMIC,'VARIANCES ',ILCMUP) + CALL EPCRMA(IPMIC,IPRINT,NGR,NXS,NCV,NMIXT,NIFISS, + > IMIX,ISOF,ITOTL,ISCAT,NAMDXS,DENSI,ICOV, + > COV,DRVAR,XSREC,XSMAC,VAR,VAROLD,RST) + CALL LCMSIX(IPMIC,'VARIANCES ',ILCMDN) + CALL LCMSIX(IPMIC,NAMMIC,ILCMDN) + ENDIF + ENDDO + ENDIF + ENDDO + IF(IPRTL .GE. 2) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF + DEALLOCATE(RST,VAROLD,VAR,XSREC) +*---- +* Update macrolib +*---- + CALL LCMSIX(IPMIC,'MACROLIB ',ILCMUP) + CALL EPCRMS(IPMIC,IPRINT,NGR,NXS,NMIXT,NIFISS,NAMDXS,XSMAC) + CALL LCMSIX(IPMIC,'MACROLIB ',ILCMDN) + DEALLOCATE(XSMAC) +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(DRVAR) + DEALLOCATE(COV,DENS) + DEALLOCATE(ICOV) + RETURN +*---- +* Formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(10F10.4,:,' ...') + END diff --git a/Dragon/src/EPCRMV.f b/Dragon/src/EPCRMV.f new file mode 100644 index 0000000..5ecad7b --- /dev/null +++ b/Dragon/src/EPCRMV.f @@ -0,0 +1,197 @@ +*DECK EPCRMV + SUBROUTINE EPCRMV(IPEPC,IPCOV,IPRINT,IFMT,NGR,NIS,NXS,NCV) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Extract variances and covariances from database and store on +* EPC data structure. +* +*Copyright: +* Copyright (C) 2009 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPEPC pointer to EPC deat structure. +* IPCOV pointer to vaqriance and cavariance file. +* IPRINT print level. +* IFMT format of covariance file: +* = 1 for ASCII file; +* =-1 for BINARY file. +* NGR number of groups. +* NIS number of isotopes. +* NXS number of cross section types per. +* NCV maximum dimension of symmetrized covariance matrix. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPEPC + INTEGER IPCOV,IPRINT,IFMT,NGR,NIS,NXS,NCV +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='EPCRMV') + INTEGER ILCMUP,ILCMDN + PARAMETER (ILCMUP=1,ILCMDN=2) +*---- +* Local variables +*---- + INTEGER IPRTL,ISO,NTYPE,ITYPE,NXSR,IXSR,IFCV,IPOC, + > ILCV,ICMG,IGR,JGR + CHARACTER ISONAM*12,UNAME*8,RECNAM*12,FNAME*50,XSN*8 + INTEGER ITC,NEL +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDIS,ICOV + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NAMISO,IDXS + REAL, ALLOCATABLE, DIMENSION(:) :: VAR,COV +*---- +* Scratch storage allocation +* IDIS array containing the isotope ID. +* NAMISO array containing the isotope names. +* IDXS array containing the cross section types (names). +* VAR array to store the variances. +* ICOV array to store indices to reconstructe full covariance +* matrix from compressed covariance matrix. +* COV array to store compressed covariance matrix. +*---- + ALLOCATE(IDIS(NIS),NAMISO(3,NIS),IDXS(2,NXS),ICOV(NGR)) + ALLOCATE(VAR(NGR),COV(NCV)) +*---- +* Scan over isotopes +*---- + IPRTL=IPRINT + IF(IPRTL .GE. 10) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + IFCV=NGR+1 + NXSR=0 + CALL LCMSIX(IPEPC,'XSVariances ',ILCMUP) + DO ISO=1,NIS +*---- +* Get isotope ID +*---- + IF(IFMT .GT. 0) THEN + READ(IPCOV,1000) IDIS(ISO),UNAME,NTYPE,FNAME + ELSE + READ(IPCOV) IDIS(ISO),UNAME,NTYPE,FNAME + ENDIF + IF(IDIS(ISO) .GT. 999) THEN + WRITE(ISONAM,'(I4,8X)') IDIS(ISO) + ELSE IF(IDIS(ISO) .GT. 99) THEN + WRITE(ISONAM,'(I3,9X)') IDIS(ISO) + ELSE IF(IDIS(ISO) .GT. 9) THEN + WRITE(ISONAM,'(I2,10X)') IDIS(ISO) + ELSE + WRITE(ISONAM,'(I1,11X)') IDIS(ISO) + ENDIF + READ(ISONAM,'(3A4)') (NAMISO(ITC,ISO),ITC=1,3) + CALL LCMSIX(IPEPC,ISONAM,ILCMUP) + DO ITYPE=1,NTYPE +*---- +* Get xs name and verify if in the list +*---- + IF(IFMT .GT. 0) THEN + READ(IPCOV,1001) UNAME + ELSE + READ(IPCOV) UNAME + ENDIF + DO IXSR=1,NXSR + WRITE(XSN,'(2A4)') IDXS(1,IXSR),IDXS(2,IXSR) + IF(XSN .EQ. UNAME) GO TO 100 + ENDDO + NXSR=NXSR+1 + IF(NXSR .GT. NXS) CALL XABORT(NAMSBR// + >': number of cross section types insufficient') + READ(UNAME,'(2A4)') IDXS(1,NXSR),IDXS(2,NXSR) + 100 CONTINUE +*---- +* Get variances and covariances +*---- + IF(IFMT .GT. 0) THEN + READ(IPCOV,*) (VAR(IGR),IGR=1,NGR) + READ(IPCOV,*) (COV(IGR),IGR=IFCV,NCV) + ELSE + READ(IPCOV) (VAR(IGR),IGR=1,NGR) + READ(IPCOV) (COV(IGR),IGR=IFCV,NCV) + ENDIF +*---- +* Compress variance and covariance matrix +*---- + IPOC=1 + ILCV=IFCV-1 + DO IGR=1,NGR +*---- +* Store variance for next element +*---- + COV(IPOC)=0.01*VAR(IGR) + ICMG=0 +*---- +* Scan covariance and remove trailing 0.0 +* Start at the end of COV for group IGR +*---- + DO JGR=NGR-IGR,1,-1 + IF(ICMG .EQ. 0) THEN + IF(COV(ILCV+JGR) .NE. 0.0) THEN +*---- +* First non 0.0 elements +* Add at the correct position in COV +*---- + ICMG=ICMG+1 + COV(IPOC+JGR)=COV(ILCV+JGR) + ENDIF + ELSE +*---- +* Other elements including 0.0 +* Add at the correct position in COV +*---- + ICMG=ICMG+1 + COV(IPOC+JGR)=COV(ILCV+JGR) + ENDIF + ENDDO + ILCV=ILCV+NGR-IGR + IPOC=IPOC+ICMG+1 + ICOV(IGR)=ICMG+1 + ENDDO + NEL=IPOC-1 + RECNAM=UNAME//' ' + CALL LCMPUT(IPEPC,RECNAM,NEL,2,COV) + RECNAM='INDX'//UNAME + CALL LCMPUT(IPEPC,RECNAM,NGR,1,ICOV) + ENDDO + CALL LCMSIX(IPEPC,ISONAM,ILCMDN) + ENDDO + CALL LCMPUT(IPEPC,'NAMEXS ',2*NXSR,3,IDXS) + CALL LCMPUT(IPEPC,'NAMEISO ',3*NIS,3,NAMISO) + CALL LCMSIX(IPEPC,'XSVariances ',ILCMDN) + IF(IPRTL .GE. 10) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(COV,VAR) + DEALLOCATE(ICOV,IDXS,NAMISO,IDIS) + RETURN +*---- +* Formats +*---- + 1000 FORMAT(I8,5X,A8,5X,I8,5X,A50) + 1001 FORMAT(A8) + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + END diff --git a/Dragon/src/EPCRPD.f b/Dragon/src/EPCRPD.f new file mode 100644 index 0000000..9e3cdce --- /dev/null +++ b/Dragon/src/EPCRPD.f @@ -0,0 +1,133 @@ +*DECK EPCRPD + SUBROUTINE EPCRPD(NENTRY,KENTRY,IPRINT,NOPT,IOPT,CARRET) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To extract library parameters with normal distribution +* around the average. +* +*Copyright: +* Copyright (C) 2009 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* NENTRY number of data structures transfered to this module. +* KENTRY data structure pointer. +* IPRINT print level. +* NOPT number of options. +* IOPT processing option with: +* IOPT(1) type of processing (=0 for current option); +* IOPT(2) entry position for L_EPC structure; +* IOPT(3) number of parameters; +* IOPT(4) entry for normal distribution file; +* IOPT(5) number of records on normal distribution file. +* CARRET last input option read. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NENTRY + TYPE(C_PTR) KENTRY(NENTRY) + INTEGER IPRINT,NOPT,IOPT(NOPT) + CHARACTER*12 CARRET +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='EPCRPD') + INTEGER ILCMUP,ILCMDN + PARAMETER (ILCMUP=1,ILCMDN=2) + INTEGER NSTATE + PARAMETER (NSTATE=40) +*---- +* Input and output parameters +*---- + INTEGER ITYPLU,INTLIR + CHARACTER CARLIR*12 + REAL REALIR + DOUBLE PRECISION DBLLIR +*---- +* Local variables +*---- + TYPE(C_PTR) IPNDI + INTEGER IKNDI + INTEGER ISTATE(NSTATE) + INTEGER NOREC,NTREC,NFREC,MAXD +*---- +* Output structure +*---- + IKNDI=1 + IF(IOPT(3) .EQ. 0) IKNDI=-1 + IPNDI=KENTRY(IOPT(2)) + CALL LCMGET(IPNDI,'STATE-VECTOR',ISTATE) +*---- +* Input structure +*---- + NOREC=ISTATE(1) + MAXD=ISTATE(2) + NTREC=IOPT(5) +*---- +* Recover parameter names from output and input structures +*---- + NFREC=NTREC+NOREC + ISTATE(1)=NFREC + ISTATE(2)=MAXD + CALL LCMPUT(IPNDI,'STATE-VECTOR',NSTATE,1,ISTATE) +*---- +* INPUT/OUTPUT VARIABLES +* Input data is of the form +* [ EDIT iprint ] +* [ SET (dataSET) ] +* [ GET (dataGET) ] +* where +* EDIT = keyword for print level +* iprint = integer print level +* SET = keyword to set reference value +* and extract number of parameters +* GET = keyword to set next value +* and to extract parameter +* (dataSET) = SET data processed by NDISET +* (dataGET) = GET data processed by NDIGET +*---- + IPRINT=1 + 100 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + 101 CONTINUE + IF(ITYPLU .EQ. 10) GO TO 105 + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + >': Read error -- Character variable expected') + IF(CARLIR .EQ. ';') THEN + GO TO 105 + ELSE IF(CARLIR .EQ. 'EDIT') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': Read error -- integer value for EDIT expected.') + IPRINT=INTLIR + ELSE IF(CARLIR .EQ. 'SET') THEN + CARRET=CARLIR + CARLIR=CARRET + GO TO 101 + ELSE IF(CARLIR .EQ. 'GET') THEN + CARRET=CARLIR + CARLIR=CARRET + GO TO 101 + ELSE + CALL XABORT(NAMSBR// + > ': '//CARLIR//' is an invalid keyword.') + ENDIF + GO TO 100 + 105 CONTINUE + RETURN + END diff --git a/Dragon/src/EVO.f b/Dragon/src/EVO.f new file mode 100644 index 0000000..341dd63 --- /dev/null +++ b/Dragon/src/EVO.f @@ -0,0 +1,422 @@ +*DECK EVO + SUBROUTINE EVO(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Driver for an isotopic depletion calculation. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): creation or modification type(L_BURNUP); +* HENTRY(2): modification type(L_LIBRARY); +* HENTRY(3): read-only type(L_TRACK); +* HENTRY(4): optional read-only type(L_FLUX) +* or +* HENTRY(1): creation or modification type(L_BURNUP); +* HENTRY(2): creation type(L_LIBRARY); +* HENTRY(3): read-only type(L_LIBRARY); +* HENTRY(4): read-only type(L_TRACK); +* HENTRY(5): optional read-only type(L_FLUX). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER HSMG*131,TEXT12*12,CDOOR*12,HSIGN*12 + INTEGER IPAR(NSTATE),IGP(NSTATE) + INTEGER ITYPE,ITIXS,IFLMAC,IYLMIX,IEXTR,IGLOB,ISAT,IDIRAC,ISAVE, + 1 ISET,INR + REAL RPAR(5),XT(5) + LOGICAL LOG,LMACRO + TYPE(C_PTR) IPLIB,IPFLUX,JPFLUX,IPDEPL,IPTRK,IPPOW,IPMACR,JPMACR, + 1 KPMACR + INTEGER, ALLOCATABLE, DIMENSION(:) :: JMIX,MIXBRN,MIXPWR,IEVOL, + 1 ISTYP,ISONA,ISONR,MAT,IDL + REAL, ALLOCATABLE, DIMENSION(:) :: JDEN,TIMES,VX,FLMIX,VOL,FUNKN, + 1 FLUXE + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: FMIX + REAL, ALLOCATABLE, DIMENSION(:,:) :: VMAP + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: FMAP +*---- +* PARAMETER VALIDATION +*---- + IF(NENTRY.LE.1) CALL XABORT('EVO: TWO PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('EVO: LCM O' + 1 //'BJECT EXPECTED AT FIRST LHS.') + IF(JENTRY(1).EQ.2) CALL XABORT('EVO: BURNUP HISTORY STORAGE IN CR' + 1 //'EATION OR MODIFICATION MODE EXPECTED.') + IPDEPL=KENTRY(1) + IF((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2)) CALL XABORT('EVO: LCM O' + 1 //'BJECT EXPECTED AT SECOND LHS.') + IENT=1 + IF(JENTRY(2).EQ.0) THEN +* INTERNAL LIBRARY CREATION. COPY THE FIRST RHS ON THIS LHS. + IF(NENTRY.LE.3) CALL XABORT('EVO: FOUR PARAMETERS EXPECTED.') + IF((JENTRY(3).NE.2).OR.((IENTRY(3).NE.1).AND. + 1 (IENTRY(3).NE.2))) CALL XABORT('EVO: LCM OBJECT IN READ-ONLY ' + 2 //'MODE EXPECTED AT FIRST RHS.') + CALL LCMEQU(KENTRY(3),KENTRY(2)) + IENT=4 + ELSE IF(JENTRY(2).EQ.1) THEN +* INTERNAL LIBRARY MODIFICATION. + IENT=3 + ELSE + CALL XABORT('EVO: INTERNAL LIBRARY IN CREATE OR MODIFICATION M' + 1 //'ODE EXPECTED.') + ENDIF + IPLIB=KENTRY(2) + TEXT12=HENTRY(2) + CALL LCMPTC(IPDEPL,'LINK.LIB',12,TEXT12) +*---- +* RECOVER IPTRK AND IPFLUX POINTERS +*---- + IPFLUX=C_NULL_PTR + IPTRK=C_NULL_PTR + IPPOW=C_NULL_PTR + DO 10 I=IENT,NENTRY + IF((JENTRY(I).EQ.2).AND.((IENTRY(I).EQ.1).OR.(IENTRY(I).EQ.2))) + 1 THEN + CALL LCMGTC(KENTRY(I),'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_FLUX') THEN + IPFLUX=KENTRY(I) + ELSE IF(HSIGN.EQ.'L_TRACK') THEN + IPTRK=KENTRY(I) + ELSE IF(HSIGN.EQ.'L_POWER') THEN + IPPOW=KENTRY(I) + ELSE + WRITE(HSMG,'(35HEVO: UNEXPECTED SIGNATURE AT RHS ('',A12, + 1 3H'').)') HSIGN + CALL XABORT(HSMG) + ENDIF + ELSE + CALL XABORT('EVO: LCM OBJECT IN READ-ONLY MODE EXPECTED AT ' + 1 //'RHS.') + ENDIF + 10 CONTINUE + IF((C_ASSOCIATED(IPFLUX)).AND.(.NOT.C_ASSOCIATED(IPTRK))) THEN + CALL XABORT('EVO: UNABLE TO FIND A POINTER TO A L_TRACK OBJEC' + 1 //'T.') + ENDIF +*---- +* RECOVER GENERAL INTERNAL LIBRARY INFORMATION +*---- + CALL LCMGTC(IPLIB,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_LIBRARY') THEN + TEXT12=HENTRY(2) + CALL XABORT('EVO: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_LIBRARY EXPECTED.') + ENDIF + CALL LCMGET(IPLIB,'STATE-VECTOR',IPAR) + NBMIX=IPAR(1) + NBISO=IPAR(2) + NGRO=IPAR(3) + NDEPL=IPAR(11) + NCOMB=IPAR(12) + LMACRO=(IPAR(17).GE.0).AND.(IPAR(18).EQ.1) + NDFI=IPAR(20) + CALL LCMLEN(IPLIB,'DEPL-CHAIN',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + WRITE(HSMG,'(47HEVO: NO DEPL-CHAIN DIRECTORY IN MICROLIB NAMED , + 1 A,2H .)') TRIM(HENTRY(2)) + CALL XABORT(HSMG) + ENDIF + CALL LCMSIX(IPLIB,'DEPL-CHAIN',1) + CALL LCMGET(IPLIB,'STATE-VECTOR',IPAR) + IF(IPAR(1).NE.NDEPL) THEN + WRITE(HSMG,'(43HEVO: INVALID NUMBER OF DEPLETING ISOTOPES (, + 1 14HON DEPL-CHAIN=,I6,13H ON MICROLIB=,I6,2H).)') IPAR(1), + 1 NDEPL + CALL XABORT(HSMG) + ENDIF + NSUPS=IPAR(7) + NREAC=IPAR(8) + CALL LCMSIX(IPLIB,' ',2) + ALLOCATE(JMIX(NBISO),IEVOL(NBISO),ISTYP(NBISO),MIXBRN(NBMIX), + 1 MIXPWR(NBMIX),ISONA(3*NBISO),ISONR(3*NBISO)) + ALLOCATE(JDEN(NBISO)) + CALL LCMGET(IPLIB,'ISOTOPESMIX',JMIX) + CALL LCMGET(IPLIB,'ISOTOPESDENS',JDEN) + CALL LCMGET(IPLIB,'ISOTOPESTODO',IEVOL) + CALL LCMGET(IPLIB,'ISOTOPESTYPE',ISTYP) +*---- +* RECOVER LOCAL ISOTOPES NAMES +*---- + CALL LCMGET(IPLIB,'ISOTOPESUSED',ISONA) + CALL LCMGET(IPLIB,'ISOTOPERNAME',ISONR) +*---- +* READ THE INPUT DATA +*---- +* DEFAULT OPTIONS: + IMPX=1 + IDEPL=0 + INR=-1 + XT(4)=0.0 + IF(JENTRY(1).EQ.0) THEN + INDREC=1 + RPAR(1)=1.0E-5 + RPAR(2)=1.0E-4 + RPAR(3)=80.0 + RPAR(4)=1.0E-4 + RPAR(5)=0.0 + ITYPE=2 + IEXTR=1 + IGLOB=0 + ISAT=0 + IDIRAC=0 + ITIXS=0 + IFLMAC=0 + IYLMIX=0 + HSIGN='L_BURNUP' + CALL LCMPTC(IPDEPL,'SIGNATURE',12,HSIGN) + CALL LCMPUT(IPDEPL,'ISOTOPESMIX',NBISO,1,JMIX) + CALL LCMPUT(IPDEPL,'ISOTOPESUSED',3*NBISO,3,ISONA) + MIXBRN(:NBMIX)=1 + MIXPWR(:NBMIX)=1 + CALL LCMPUT(IPDEPL,'MIXTURESBurn',NBMIX,1,MIXBRN) + CALL LCMPUT(IPDEPL,'MIXTURESPowr',NBMIX,1,MIXPWR) + ELSE IF(JENTRY(1).EQ.1) THEN + CALL LCMGTC(IPDEPL,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_BURNUP') THEN + TEXT12=HENTRY(1) + CALL XABORT('LIB: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_BURNUP EXPECTED.') + ENDIF + INDREC=2 + CALL LCMGET(IPDEPL,'STATE-VECTOR',IPAR) + ITYPE=IPAR(1) + NTIME=IPAR(3) + IEXTR=IPAR(9) + IGLOB=IPAR(10) + ISAT=IPAR(11) + IDIRAC=IPAR(12) + ITIXS=IPAR(13) + IFLMAC=IPAR(14) + IYLMIX=IPAR(15) + IF(IPAR(4).NE.NBISO) CALL XABORT('EVO: INVALID NUMBER OF ISOTO' + 1 //'PES.') + CALL LCMGET(IPDEPL,'EVOLUTION-R',RPAR) + IF(NTIME.GT.0) THEN + ALLOCATE(TIMES(NTIME+2)) + CALL LCMGET(IPDEPL,'DEPL-TIMES',TIMES) + XT(4)=TIMES(NTIME) + DEALLOCATE(TIMES) + ENDIF + CALL LCMLEN(IPDEPL,'MIXTURESBurn',ILONG,ITYLCM) + IF(ILONG.EQ.NBMIX) THEN + CALL LCMGET(IPDEPL,'MIXTURESBurn',MIXBRN) + CALL LCMGET(IPDEPL,'MIXTURESPowr',MIXPWR) + ELSE + MIXBRN(:NBMIX)=1 + MIXPWR(:NBMIX)=1 + ENDIF + CALL LCMLEN(IPDEPL,'ISOTOPESUSED',ILONG,ITYLCM) + IF(ILONG.NE.3*NBISO) CALL XABORT('EVO: INCONSISTENT RECORD IS' + 1 //'OTOPESUSED.') + ENDIF +*---- +* READ INPUT OPTIONS +*---- + IF(NBMIX.EQ.0) CALL XABORT('EVO: NBMIX NOT YET DEFINED.') + CALL EVOGET(IMPX,ITYPE,ITIXS,IEXTR,IGLOB,ISAT,IDIRAC,ISAVE,ISET, + > INR,IDEPL,IFLMAC,IYLMIX,RPAR,XT,NBMIX,IPICK,MIXBRN,MIXPWR) +* + XTI=XT(3) + XTF=XT(5) + EPS1=RPAR(1) + EPS2=RPAR(2) + EXPMAX=RPAR(3) + H1=RPAR(4) + FIT=RPAR(5) + LOG=(ISAVE.GE.0).OR.(IDEPL.GT.0) + IF(LOG.AND.(INR.EQ.-1)) CALL XABORT('EVO: TYPE OF DEPLETION NO'// + 1 'T DEFINED.') + IF(NDEPL.EQ.0) CALL XABORT('EVO: NO DEPLETING ISOTOPES.') + IF(NCOMB.EQ.0) CALL XABORT('EVO: NO DEPLETING MIXTURES.') + IF((IYLMIX.EQ.1).AND.(NDFI.EQ.0)) CALL XABORT('EVO: NO ISOTOPI'// + 1 'C FISSION YIELD DATA (PYIELD) AVAILABLE.') +*---- +* RECOVER MIXTURE VOLUMES AND AVERAGE NEUTRON FLUXES +*---- + ALLOCATE(VX(NBMIX),FLMIX(NBMIX*NGRO)) + IF(IFLMAC.EQ.0) THEN +* RECOVER GENERAL TRACKING INFORMATION + IF(.NOT.C_ASSOCIATED(IPTRK)) THEN + CALL XABORT('EVO: L_TRACK OBJECT NOT DEFINED.') + ENDIF + CALL LCMGET(IPTRK,'STATE-VECTOR',IGP) + NREG=IGP(1) + IF(IGP(4).GT.NBMIX) THEN + WRITE(HSMG,'(42HEVO: THE NUMBER OF MIXTURES IN THE TRACKIN, + 1 3HG (,I5,46H) IS GREATER THAN THE NUMBER OF MIXTURES IN TH, + 2 20HE INTERNAL LIBRARY (,I5,2H).)') IGP(4),NBMIX + CALL XABORT(HSMG) + ENDIF + IF(NREG.EQ.0) CALL XABORT('EVO: NREG = 0') + CALL LCMGTC(IPTRK,'TRACK-TYPE',12,CDOOR) + IF(CDOOR.EQ.'MCCG') THEN + CALL LCMLEN(IPTRK,'KEYFLX',LKFL,ITYLCM) + NFUNL=LKFL/NREG + ELSE + NFUNL=1 + ENDIF + ALLOCATE(MAT(NREG),VOL(NREG),IDL(NREG*NFUNL)) + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'VOLUME',VOL) + CALL LCMGET(IPTRK,'KEYFLX',IDL) +* +* RECOVER MIXTURE VOLUMES FROM L_TRACK + VX(:NBMIX)=0.0 + FLMIX(:NBMIX*NGRO)=0.0 + DO 20 I=1,NREG + IBM=MAT(I) + IF(IBM.GT.0) VX(IBM)=VX(IBM)+VOL(I) + 20 CONTINUE + IF(C_ASSOCIATED(IPFLUX)) THEN +* RECOVER MIXTURE FLUXES FROM L_FLUX + ALLOCATE(FLUXE(NREG*NGRO)) + JPFLUX=LCMGID(IPFLUX,'FLUX') + CALL LCMLEL(JPFLUX,1,ILONG,ITYLCM) + ALLOCATE(FUNKN(ILONG)) + DO 35 IGR=1,NGRO + CALL LCMGDL(JPFLUX,IGR,FUNKN) + DO 30 I=1,NREG + KEYFLX=IDL(I) + FLUXE((IGR-1)*NREG+I)=FUNKN(KEYFLX) + 30 CONTINUE + 35 CONTINUE + DEALLOCATE(FUNKN) + DO 55 IBM=1,NBMIX + DO 50 IGR=1,NGRO + FLXMIX=0.0 + DO 40 I=1,NREG + IF(MAT(I).EQ.IBM) THEN + VOLTMP=VOL(I) + FLXMIX=FLXMIX+FLUXE((IGR-1)*NREG+I)*VOLTMP + ENDIF + 40 CONTINUE + VOLTMP=VX(IBM) + IF(VOLTMP.NE.0.0) THEN + FLMIX((IBM-1)*NGRO+IGR)=FLXMIX/VOLTMP + ENDIF + 50 CONTINUE + 55 CONTINUE + DEALLOCATE(FLUXE) + ENDIF + DEALLOCATE(IDL,VOL,MAT) + ELSE IF(IFLMAC.EQ.1) THEN +* RECOVER MIXTURE VOLUMES AND FLUXES FROM L_MACROLIB + CALL LCMLEN(IPLIB,'MACROLIB',ILONG,ITYLCM) + IF(ILONG.EQ.0) CALL XABORT('EVO: NO MACROLIB IN MICROLIB.') + IPMACR=LCMGID(IPLIB,'MACROLIB') + CALL LCMGET(IPMACR,'STATE-VECTOR',IPAR) + IF(IPAR(1).NE.NGRO) CALL XABORT('EVO: INVALID NGRO.') + IF(IPAR(2).NE.NBMIX) CALL XABORT('EVO: INVALID NBMIX.') + CALL LCMGET(IPMACR,'VOLUME',VX) + ALLOCATE(FUNKN(NBMIX)) + JPMACR=LCMGID(IPMACR,'GROUP') + DO 61 IGR=1,NGRO + KPMACR=LCMGIL(JPMACR,IGR) + CALL LCMGET(KPMACR,'FLUX-INTG',FUNKN) + DO 60 IBM=1,NBMIX + FLMIX((IBM-1)*NGRO+IGR)=FUNKN(IBM)/VX(IBM) + 60 CONTINUE + 61 CONTINUE + DEALLOCATE(FUNKN) + ELSE IF(IFLMAC.EQ.2) THEN +* RECOVER MIXTURE VOLUMES AND FLUXES FROM L_POWER + IF(.NOT.C_ASSOCIATED(IPPOW)) THEN + CALL XABORT('EVO: L_POWER OBJECT NOT DEFINED.') + ENDIF + CALL LCMGET(IPPOW,'STATE-VECTOR',IGP) + NCH=IGP(6) + NB=IGP(7) + IGEO=IGP(8) + IF((IGEO.NE.7).AND.(IGEO.NE.9))CALL XABORT('EVO: INVALID GEOM' + 1 //'ETRY IN FUEL MAP : ONLY 3-D CARTESIAN OR 3-D HEXAGONAL GEO' + 2 //'METRIES AVAILABLE') + IF(IGP(1).NE.NGRO)CALL XABORT('EVO: INVALID NUMBER OF ENERGY ' + 1 //'GROUPS IN L_POWER AND MICROLIB.') + ALLOCATE(FMIX(NCH,NB),VMAP(NCH,NB),FMAP(NCH,NB,NGRO)) + CALL LCMGET(IPPOW,'FLMIX',FMIX) + CALL LCMGET(IPPOW,'VOLU-BUND',VMAP) + CALL LCMGET(IPPOW,'FLUX-BUND',FMAP) + NTOT=0 + DO 67 JB=1,NB + DO 66 ICH=1,NCH + IF(FMIX(ICH,JB).EQ.0) GO TO 70 + NTOT=NTOT+1 + IF(NTOT.GT.NBMIX) CALL XABORT('EVO: NBMIX OVERFLOW.') + VX(NTOT)=VMAP(ICH,JB) + DO 65 IGR=1,NGRO + FLMIX((NTOT-1)*NGRO+IGR)=FMAP(ICH,JB,IGR) + 65 CONTINUE + 66 CONTINUE + 67 CONTINUE + 70 CONTINUE + IF(NTOT.NE.NBMIX) CALL XABORT('EVO: ALGORITHM FAILURE.') + DEALLOCATE(FMAP,VMAP,FMIX) + ELSE + CALL XABORT('EVO: INVALID VALUE OF IFLMAC.') + ENDIF +*---- +* COMPUTE EXISTING FLUX NORMALIZATION FACTOR (KEEP OPTION) +*---- + IF(INR.EQ.4) THEN + VPH=0.0 + VTOT=0.0 + DO 80 IBM=1,NBMIX + IF(MIXPWR(IBM).EQ.1) THEN + VTOT=VTOT+VX(IBM) + DO 75 IGR=1,NGRO + VPH=VPH+VX(IBM)*FLMIX(NGRO*(IBM-1)+IGR) + 75 CONTINUE + ENDIF + 80 CONTINUE + FIT=VPH/VTOT + INR=1 + ENDIF +*---- +* PERFORM DEPLETION CALCULATION +*---- + CALL EVODRV(IPDEPL,IPLIB,INDREC,IMPX,NBISO,NGRO,NBMIX,ISONA, + 1 ISONR,JMIX,JDEN,IEVOL,ISTYP,VX,NDEPL,NSUPS,NREAC,NCOMB,EPS1, + 2 EPS2,EXPMAX,H1,ITYPE,INR,IEXTR,IGLOB,ISAT,IDIRAC,ITIXS,IFLMAC, + 3 IYLMIX,FIT,ISAVE,ISET,IDEPL,XTI,XTF,XT,LMACRO,FLMIX,IPICK, + 4 MIXBRN,MIXPWR) + CALL LCMPUT(IPLIB,'ISOTOPESDENS',NBISO,2,JDEN) +*---- +* RELEASE GENERAL INTERNAL LIBRARY INFORMATION +*---- + DEALLOCATE(FLMIX,VX) + DEALLOCATE(JDEN) + DEALLOCATE(ISONR,ISONA,MIXPWR,MIXBRN,ISTYP,IEVOL,JMIX) + RETURN + END diff --git a/Dragon/src/EVOBLD.f b/Dragon/src/EVOBLD.f new file mode 100644 index 0000000..76763ab --- /dev/null +++ b/Dragon/src/EVOBLD.f @@ -0,0 +1,501 @@ +*DECK EVOBLD + SUBROUTINE EVOBLD(IMPX,INR,IGLOB,NBMIX,NBISO,NCOMB,ISONAM,YDPL, + 1 VX,MILVO,JM,NVAR,NDFP,NSUPS,NREAC,NPAR,NFISS,XT,EPS1,EPS2,EXPMAX, + 2 H1,ITYPE,IDIRAC,FIT,DELTA,ENERG,KPAR,BPAR,YIELD,IDR,RER,RRD,AWR, + 3 FUELDN,SIG,VPH,VPHV,MIXPWR,VTOTD,IEVOLB,KFISS,KPF) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform flux normalization and call EVOSOL to solve the depletion +* system for each depleting mixture between times XT(1) and XT(2). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* IMPX print flag (equal to zero for no print). +* INR type of flux normalization: +* =0: out-of-core depletion; +* =1: constant flux depletion; +* =2: constant fuel power depletion; +* =3: constant assembly power depletion. +* IGLOB out-of-fuel power in flux normalization. Compute the burnup: +* =-1: using the Serpent mode 0 empirical formula in the fuel; +* =0: using the power released in the fuel; +* =1: using the power released in the global geometry. +* NBMIX number of mixtures. +* NBISO number of isotopes/materials including non-depleting ones. +* NCOMB number of depleting mixtures. +* ISONAM alias name of isotopes. +* YDPL initial/final number density of isotope in the depletion +* chain. YDPL(NVAR+1,2,ICMB) is the stage burnup increment +* in region ICMB. +* VX volumes of the depleting mixtures. +* MILVO mixture index corresponding to each depleting mixture. +* JM position in isotope list of each nuclide of the depletion +* chain. +* NVAR number of depleting nuclides. +* NDFP number of direct fission products (fission fragments). +* NSUPS number of non-depleting isotopes producing energy. +* NREAC maximum number of depletion reactions. +* NPAR maximum number of parent nuclides in the depletion chain. +* NFISS number of fissile isotopes producing fission products. +* XT initial and final time (independent variable). +* EPS1 required accuracy for the ode solver. +* EPS2 required accuracy for constant power iterations. +* EXPMAX saturation limit. A nuclide is saturating if +* -ADPL(MU1(I))*(XT(2)-XT(1)).GT.EXPMAX. Suggested value: +* EXPMAX=80.0. +* H1 guessed first stepsize. +* ITYPE type of ODE solution: +* =1 fifth-order Runge-Kutta method; +* =2 fourth-order Kaps-Rentrop method. +* IDIRAC saturation model flag (=1 to use Dirac function contributions +* in the saturating nuclide number densities). +* FIT flux normalization factor: +* n/cm**2/s if INR=1; +* MW/tonne of initial heavy elements if INR=2; +* W/cc of assembly volume if INR=3. +* DELTA burnup stage increments: +* DELTA(1): increment in fuel burnup for this stage; +* DELTA(2): increment in fuel neutron exposure for this stage; +* DELTA(3): target increment in fuel burnup for this stage. +* Cross section should be tabulated with respect to the sum +* of the DELTA(1) of all the previous stages. +* ENERG increment in fuel burnup for this stage in each mixture. +* KPAR position in chain of the parent nuclide and type of +* reaction. +* BPAR branching ratio for neutron induced reactions. +* YIELD mixture-dependent fission yields. +* IDR identifier for each depleting reaction. +* RER energy (Mev) per reaction. If RER(3,J)=0., the fission energy +* includes radiative capture energy. Neutrino energy is +* never included. +* RRD sum of radioactive decay constants in 10**-8/s. +* AWR mass of the nuclides in unit of neutron mass. +* FUELDN fuel initial density and mass. +* SIG initial/final microscopic depletion reaction rates for nuclide +* I in mixture IBM: +* SIG(I,1,IBM,:) fission reaction rate; +* SIG(I,2,IBM,:) gamma reaction rate; +* SIG(I,3,IBM,:) N2N reaction rate; +* cont...; +* SIG(I,NREAC,IBM,:) neutron-induced energy released; +* SIG(I,NREAC+1,IBM,:) decay energy released (10**-8 MeV/s). +* VPH initial/final integrated flux in fuel. +* VPHV initial/final integrated flux in each mixture. +* MIXPWR flags for mixtures to include in power normalization. +* VTOTD total fuel volume. +* IEVOLB flag making an isotope non-depleting: +* =0 the isotope is depleting; +* =1 to force an isotope to be non-depleting; +* =2 to force an isotope to be depleting; +* =3 to force an isotope to be at saturation +* KFISS position in chain of the fissile isotopes. +* KPF position in chain of the direct fission products (fission +* fragments). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IMPX,INR,IGLOB,NBMIX,NBISO,NCOMB,ISONAM(3,NBISO), + 1 MILVO(NCOMB),JM(NBMIX,NVAR+NSUPS),NVAR,NDFP,NSUPS,NREAC,NPAR, + 2 NFISS,ITYPE,IDIRAC,KPAR(NPAR,NVAR),IDR(NREAC,NVAR+NSUPS), + 3 MIXPWR(NBMIX),IEVOLB(NVAR,NBMIX),KFISS(NFISS,NBMIX), + 4 KPF(NDFP,NBMIX) + REAL YDPL(NVAR+1,2,NCOMB),VX(NBMIX),XT(2),EPS1,EPS2,EXPMAX,H1,FIT, + 1 DELTA(3),ENERG(NBMIX),BPAR(NPAR,NVAR),YIELD(NFISS,NDFP,NBMIX), + 2 RER(NREAC,NVAR+NSUPS),RRD(NVAR+NSUPS),AWR(NVAR),FUELDN(3), + 3 SIG(NVAR+1,NREAC+1,NBMIX,2),VPH(2),VPHV(NBMIX,2) + DOUBLE PRECISION VTOTD +*---- +* LOCAL VARIABLES +*---- + CHARACTER TEXT8*8,HSMG*131 + DOUBLE PRECISION GAR,GARD,XDRCST,EVJ,FITD,PHI2 + LOGICAL LCOOL,LSIMPL + INTEGER, ALLOCATABLE, DIMENSION(:) :: MU1,IMA,LP,CHAIN +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(MU1(NVAR+1),IMA(NVAR+1),LP(NVAR)) +*---- +* CHECK IF ONLY THE HEAVY ISOTOPES ARE PRODUCING ENERGY. IN THIS CASE, +* SOME SIMPLIFICATIONS ARE POSSIBLE +*---- + LSIMPL=.TRUE. + DO 10 IS=1,NVAR + LSIMPL=LSIMPL.AND.(RER(3,IS).EQ.0.0) + 10 CONTINUE +* + EVJ=XDRCST('eV','J')*1.0E22 + LCOOL=(INR.EQ.0) + IF(LCOOL) GO TO 410 + IF(IMPX.GT.1) WRITE (6,640) VPH(1)/VTOTD,VPH(2)/VTOTD +*---- +* CONVERGE ON A FIXED FINAL POWER. SOLVE THE DEPLETION CHAIN WITHOUT +* THE FISSION PRODUCTS. +*---- + IF((INR.GE.2).AND.(EPS2.LT.10.0)) THEN + ITER=0 + 250 ITER=ITER+1 + IF(ITER.GT.20) CALL XABORT('EVOBLD: UNABLE TO CONVERGE.') + DO 330 ICMB=1,NCOMB +* DETERMINE THE ROW AND COLUMN PROFILE OF THE ADPL MATRIX AND +* COMPUTE NVAR2, THE NUMBER OF DEPLETING NUCLIDES IN REGION ICMB. + IBM=MILVO(ICMB) + IF(IBM.EQ.0) GO TO 330 + IF(IMPX.GT.3) WRITE(6,'(/34H EVOBLD: PROCESS DEPLETING MIXTURE, + 1 I5,15H (REAL MIXTURE=,I5,2H).)') ICMB,IBM + NVAR2=0 + NSUPL2=0 + LP(:NVAR)=0 + DO 270 IS=1,NVAR + KDRI=IDR(2,IS) + IF(KDRI.EQ.0) GO TO 270 + IF((MOD(KDRI,100).NE.3).AND.(MOD(KDRI,100).NE.4)) GO TO 270 + IF(JM(IBM,IS).GT.0) THEN + NVAR2=NVAR2+1 + LP(IS)=NVAR2 + ENDIF + 270 CONTINUE + NSUPL2=NVAR2 + DO 280 IS=1,NVAR + IF(LSIMPL.AND.(AWR(IS).LE.210.0)) GO TO 280 + IF((JM(IBM,IS).GT.0).AND.(LP(IS).EQ.0)) THEN + NVAR2=NVAR2+1 + LP(IS)=NVAR2 + ENDIF + 280 CONTINUE + IF(NVAR2.EQ.0) GO TO 330 +* CHECK IF ONLY THE HEAVY ISOTOPES ARE PRODUCING ENERGY. IN +* THIS CASE, IT IS POSSIBLE TO AVOID THE SOLUTION FOR FISSION +* PRODUCTS. + NSUPF2=NVAR2-NSUPL2 + IF(LSIMPL) NSUPF2=0 + CALL EVOMU1(IMPX,NVAR,NREAC,LP,XT,LCOOL,NPAR,KPAR,RRD, + 1 SIG(1,1,IBM,1),SIG(1,1,IBM,2),EXPMAX,IEVOLB(1,IBM),MU1, + 2 IMA,MAXA) + MU1(NVAR2+1)=IMA(NVAR2)+NVAR2+1 + IMA(NVAR2+1)=IMA(NVAR2)+NVAR2+1 + MAXA=MAXA+10*(NVAR2+1) + NFISS2=0 + DO 300 I=1,NFISS + IF(KFISS(I,IBM).EQ.0) GO TO 300 + IF(LP(KFISS(I,IBM)).GT.0) NFISS2=NFISS2+1 + 300 CONTINUE + ALLOCATE(CHAIN(2*(NVAR2+1))) + DO 310 IS=1,NVAR + IF(LP(IS).GT.0) THEN + K=JM(IBM,IS) + CHAIN((LP(IS)-1)*2+1)=ISONAM(1,K) + CHAIN((LP(IS)-1)*2+2)=ISONAM(2,K) + ENDIF + 310 CONTINUE + TEXT8='*POWER*' + READ(TEXT8,'(2A4)') (CHAIN(NVAR2*2+I0),I0=1,2) + CALL EVOSOL(IMPX,LCOOL,NVAR,NREAC,NDFP,NPAR,NFISS,XT,EPS1, + 1 EXPMAX,H1,ITYPE,IDIRAC,RRD,KPAR,BPAR,KFISS(1,IBM),KPF(1,IBM), + 2 YIELD(1,1,IBM),LP,IEVOLB(1,IBM),SIG(1,1,IBM,1),SIG(1,1,IBM,2), + 3 NVAR2,NFISS2,NSUPF2,MU1,IMA,MAXA,YDPL(1,1,ICMB),CHAIN) +* + DEALLOCATE(CHAIN) + 330 CONTINUE + GAR=0.0D0 + GARD=0.0D0 + DO 360 IS=1,NVAR + DO 350 ICMB=1,NCOMB + IBM=MILVO(ICMB) + IF(IBM.EQ.0) GO TO 350 + IF(MIXPWR(IBM).EQ.1) THEN + GAR=GAR+VX(IBM)*YDPL(IS,2,ICMB)*SIG(IS,NREAC,IBM,2) + GARD=GARD+VX(IBM)*YDPL(IS,2,ICMB)*SIG(IS,NREAC+1,IBM,2) + ENDIF + 350 CONTINUE + 360 CONTINUE + IF((IGLOB.EQ.1).OR.(INR.EQ.3)) THEN + DO 370 IBM=1,NBMIX + IF(MIXPWR(IBM).EQ.1) THEN + GAR=GAR+SIG(NVAR+1,NREAC,IBM,2) + GAR=GAR+SIG(NVAR+1,NREAC+1,IBM,2) + ENDIF + 370 CONTINUE + ELSE + DO 380 ICMB=1,NCOMB + IBM=MILVO(ICMB) + IF(IBM.EQ.0) GO TO 380 + IF(MIXPWR(IBM).EQ.1) THEN + GAR=GAR+SIG(NVAR+1,NREAC,IBM,2) + GAR=GAR+SIG(NVAR+1,NREAC+1,IBM,2) + ENDIF + 380 CONTINUE + ENDIF + IF(GAR.EQ.0.0D0) CALL XABORT('EVOBLD: UNABLE TO NORMALIZE.') + IF(INR.EQ.3) THEN +* FITD IS THE DECAY POWER IN WATT PER CUBIC CENTIMETER. + FITD=(EVJ*GARD*FUELDN(3))/(FUELDN(1)*VTOTD) + IF(FITD.GT.FIT) THEN + WRITE(HSMG,'(35HEVOBLD: NEGATIVE FIT(1) FIT(DECAY)=,1P, + 1 E11.4,12H FIT(INPUT)=,E11.4,1H.)') FITD,FIT + CALL XABORT(HSMG) + ENDIF + PHI2=(FIT-FITD)*FUELDN(1)*VPH(2)/(EVJ*GAR*FUELDN(3)) + ELSE +* FITD IS THE DECAY POWER IN WATT PER GRAM. + FITD=(EVJ*GARD)/(FUELDN(1)*VTOTD) + IF(FITD.GT.FIT) THEN + WRITE(HSMG,'(35HEVOBLD: NEGATIVE FIT(2) FIT(DECAY)=,1P, + 1 E11.4,12H FIT(INPUT)=,E11.4,1H.)') FITD,FIT + CALL XABORT(HSMG) + ENDIF + PHI2=(FIT-FITD)*FUELDN(1)*VPH(2)/(EVJ*GAR) + ENDIF + ERROR=REAL(ABS(PHI2-VPH(2)/VTOTD)/ABS(PHI2)) + DO 400 IBM=1,NBMIX + VPHV(IBM,2)=VPHV(IBM,2)*REAL(PHI2*VTOTD)/VPH(2) + DO 395 IQ=1,NREAC + DO 390 IS=1,NVAR+1 + SIG(IS,IQ,IBM,2)=SIG(IS,IQ,IBM,2)*REAL(PHI2*VTOTD)/VPH(2) + 390 CONTINUE + 395 CONTINUE + 400 CONTINUE + VPH(2)=REAL(PHI2*VTOTD) + IF(IMPX.GT.3) THEN + WRITE (6,650) ITER,ERROR,VPH(1)/VTOTD,VPH(2)/VTOTD + ENDIF + IF(ERROR.LT.EPS2) THEN + IF(IMPX.GT.-1) WRITE(6,'(/29H EVOBLD: POWER CONVERGENCE IN, + 1 I3,19H ITERATIONS. ERROR=,1P,E9.2,1H.)') ITER,ERROR + GO TO 410 + ELSE + GO TO 250 + ENDIF + ENDIF +*---- +* SOLVE THE COMPLETE DEPLETION CHAIN, INCLUDING FISSION PRODUCTS +*---- + 410 DELTA(1)=0.0 + ENERG(:NBMIX)=0.0 + DO 500 ICMB=1,NCOMB +* DETERMINE THE ROW AND COLUMN PROFILE OF THE ADPL MATRIX AND +* COMPUTE NVAR2, THE NUMBER OF DEPLETING NUCLIDES IN REGION ICMB. + IBM=MILVO(ICMB) + IF(IBM.EQ.0) GO TO 500 + IF(IMPX.GT.3) WRITE(6,'(/34H EVOBLD: PROCESS DEPLETING MIXTURE, + 1 I5,15H (REAL MIXTURE=,I5,2H).)') ICMB,IBM + NVAR2=0 + NSUPL2=0 + LP(:NVAR)=0 + DO 440 IS=1,NVAR + KDRI=IDR(2,IS) + IF(KDRI.EQ.0) GO TO 440 + IF((MOD(KDRI,100).NE.3).AND.(MOD(KDRI,100).NE.4)) GO TO 440 + IF(JM(IBM,IS).GT.0) THEN + NVAR2=NVAR2+1 + LP(IS)=NVAR2 + ENDIF + 440 CONTINUE + NSUPL2=NVAR2 + DO 450 IS=1,NVAR + IF((JM(IBM,IS).GT.0).AND.(LP(IS).EQ.0)) THEN + NVAR2=NVAR2+1 + LP(IS)=NVAR2 + ENDIF + 450 CONTINUE + CALL EVOMU1(IMPX,NVAR,NREAC,LP,XT,LCOOL,NPAR,KPAR,RRD, + 1 SIG(1,1,IBM,1),SIG(1,1,IBM,2),EXPMAX,IEVOLB(1,IBM),MU1, + 2 IMA,MAXA) + MU1(NVAR2+1)=IMA(NVAR2)+NVAR2+1 + IMA(NVAR2+1)=IMA(NVAR2)+NVAR2+1 + MAXA=MAXA+10*(NVAR2+1) + NFISS2=0 + DO 460 I=1,NFISS + IF(KFISS(I,IBM).EQ.0) GO TO 460 + IF(LP(KFISS(I,IBM)).GT.0) NFISS2=NFISS2+1 + 460 CONTINUE + NSUPF2=NVAR2-NSUPL2 + ALLOCATE(CHAIN(2*(NVAR2+1))) + DO 470 IS=1,NVAR + IF(LP(IS).GT.0) THEN + K=JM(IBM,IS) + CHAIN((LP(IS)-1)*2+1)=ISONAM(1,K) + CHAIN((LP(IS)-1)*2+2)=ISONAM(2,K) + ENDIF + 470 CONTINUE + TEXT8='*POWER*' + READ(TEXT8,'(2A4)') (CHAIN(NVAR2*2+I0),I0=1,2) + CALL EVOSOL(IMPX,LCOOL,NVAR,NREAC,NDFP,NPAR,NFISS,XT,EPS1, + 1 EXPMAX,H1,ITYPE,IDIRAC,RRD,KPAR,BPAR,KFISS(1,IBM),KPF(1,IBM), + 2 YIELD(1,1,IBM),LP,IEVOLB(1,IBM),SIG(1,1,IBM,1),SIG(1,1,IBM,2), + 3 NVAR2,NFISS2,NSUPF2,MU1,IMA,MAXA,YDPL(1,1,ICMB),CHAIN) +* + DEALLOCATE(CHAIN) + IF(MIXPWR(IBM).EQ.1) THEN + DELTA(1)=DELTA(1)+YDPL(NVAR+1,2,ICMB)*VX(IBM) + ENDIF + 500 CONTINUE +*---- +* BURNUP CALCULATION. TAKE THE CONTRIBUTION OBTAINED FROM THE ODE +* SOLVER AND ADD THE CONTRIBUTION FROM THE NON-DEPLETING ISOTOPES +* PRODUCING ENERGY +*---- + DO 510 IBM=1,NBMIX + IF(MIXPWR(IBM).EQ.1) THEN + GAR=0.5D0*(SIG(NVAR+1,NREAC,IBM,1)+SIG(NVAR+1,NREAC,IBM,2) + 1 +SIG(NVAR+1,NREAC+1,IBM,1)+SIG(NVAR+1,NREAC+1,IBM,2)) + ENERG(IBM)=ENERG(IBM)+REAL(GAR*(XT(2)-XT(1))*EVJ) + ENDIF + 510 CONTINUE + DO 516 ICMB=1,NCOMB + IBM=MILVO(ICMB) + IF(IBM.EQ.0) GO TO 516 + IF(MIXPWR(IBM).EQ.1) THEN + DO 515 IS=1,NVAR + GAR=0.5D0*(YDPL(IS,1,ICMB)*SIG(IS,NREAC,IBM,1) + 1 +YDPL(IS,2,ICMB)*SIG(IS,NREAC,IBM,2) + 1 +YDPL(IS,1,ICMB)*SIG(IS,NREAC+1,IBM,1) + 1 +YDPL(IS,2,ICMB)*SIG(IS,NREAC+1,IBM,2)) + ENERG(IBM)=ENERG(IBM)+REAL(GAR*(XT(2)-XT(1))*VX(IBM)*EVJ) + 515 CONTINUE + ENDIF + 516 CONTINUE + DELTA(3)=0.0 + IF(IGLOB.LE.0) THEN + DO 520 ICMB=1,NCOMB + IBM=MILVO(ICMB) + IF(IBM.EQ.0) GO TO 520 + IF(MIXPWR(IBM).EQ.1) THEN + GAR=0.5D0*(SIG(NVAR+1,NREAC,IBM,1)+SIG(NVAR+1,NREAC,IBM,2) + 1 +SIG(NVAR+1,NREAC+1,IBM,1) + 2 +SIG(NVAR+1,NREAC+1,IBM,2)) + DELTA(1)=DELTA(1)+REAL(GAR)*(XT(2)-XT(1)) + DELTA(3)=DELTA(3)+REAL(GAR)*(XT(2)-XT(1)) + ENDIF + 520 CONTINUE + ELSE IF(IGLOB.EQ.1) THEN + DO 530 IBM=1,NBMIX + IF(MIXPWR(IBM).EQ.1) THEN + GAR=0.5D0*(SIG(NVAR+1,NREAC,IBM,1)+SIG(NVAR+1,NREAC,IBM,2) + 1 +SIG(NVAR+1,NREAC+1,IBM,1) + 2 +SIG(NVAR+1,NREAC+1,IBM,2)) + DELTA(1)=DELTA(1)+REAL(GAR)*(XT(2)-XT(1)) + DELTA(3)=DELTA(3)+REAL(GAR)*(XT(2)-XT(1)) + ENDIF + 530 CONTINUE + ENDIF + DO 545 ICMB=1,NCOMB + IBM=MILVO(ICMB) + IF(IBM.EQ.0) GO TO 545 + IF(MIXPWR(IBM).EQ.1) THEN + DO 540 IS=1,NVAR + DELTA(3)=DELTA(3)+0.5*(YDPL(IS,1,ICMB)*SIG(IS,NREAC,IBM,1) + 1 +YDPL(IS,2,ICMB)*SIG(IS,NREAC,IBM,2))*VX(IBM) + 2 *(XT(2)-XT(1)) + DELTA(3)=DELTA(3)+0.5*(YDPL(IS,1,ICMB)*SIG(IS,NREAC+1,IBM,1) + 1 +YDPL(IS,2,ICMB)*SIG(IS,NREAC+1,IBM,2))*VX(IBM) + 2 *(XT(2)-XT(1)) + 540 CONTINUE + ENDIF + 545 CONTINUE + IF(FUELDN(2) .EQ. 0.0) THEN + DELTA(1)=0.0 + DELTA(3)=0.0 + ELSE + DELTA(1)=DELTA(1)*REAL(EVJ)/FUELDN(2) + DELTA(3)=DELTA(3)*REAL(EVJ)/FUELDN(2) + ENDIF + DELTA(2)=0.5*(VPH(1)+VPH(2))*(XT(2)-XT(1))/REAL(VTOTD) + IF((.NOT.LCOOL).AND.(IMPX.GT.0)) THEN + IF(DELTA(1) .EQ. 0.0) THEN + WRITE (6,661) DELTA(2) + ELSE + WRITE (6,660) DELTA(1),DELTA(1)/8.64E-4,DELTA(2) + WRITE (6,665) DELTA(3),DELTA(3)/8.64E-4 + ENDIF + ENDIF +*---- +* PRINT THE BEGINNING- AND END-OF-STAGE NORMALIZATION POWERS +*---- + IF(IMPX.GT.-1) THEN + DO 580 IP=1,2 + DELTA1=0.0 + DELTA2=0.0 + IF(IGLOB.LE.0) THEN + DO 550 ICMB=1,NCOMB + IBM=MILVO(ICMB) + IF(IBM.EQ.0) GO TO 550 + IF(MIXPWR(IBM).EQ.1) THEN + DELTA1=DELTA1+SIG(NVAR+1,NREAC,IBM,IP) + DELTA2=DELTA2+SIG(NVAR+1,NREAC+1,IBM,IP) + ENDIF + 550 CONTINUE + ELSE IF(IGLOB.EQ.1) THEN + DO 560 IBM=1,NBMIX + IF(MIXPWR(IBM).EQ.1) THEN + DELTA1=DELTA1+SIG(NVAR+1,NREAC,IBM,IP) + DELTA2=DELTA2+SIG(NVAR+1,NREAC+1,IBM,IP) + ENDIF + 560 CONTINUE + ENDIF + DO 575 ICMB=1,NCOMB + IBM=MILVO(ICMB) + IF(IBM.EQ.0) GO TO 575 + IF(MIXPWR(IBM).EQ.1) THEN + DO 570 IS=1,NVAR + DELTA1=DELTA1+YDPL(IS,IP,ICMB)*SIG(IS,NREAC,IBM,IP)*VX(IBM) + DELTA2=DELTA2+YDPL(IS,IP,ICMB)*SIG(IS,NREAC+1,IBM,IP)*VX(IBM) + 570 CONTINUE + ENDIF + 575 CONTINUE + IF(FUELDN(2) .EQ. 0.0) THEN + DELTA1=0.0 + DELTA2=0.0 + ELSE + DELTA1=DELTA1*REAL(EVJ)/FUELDN(2) + DELTA2=DELTA2*REAL(EVJ)/FUELDN(2) + IF(IP.EQ.1) THEN + WRITE(6,680) 'BEGINNING-OF-STAGE',DELTA1 + WRITE(6,690) 'BEGINNING-OF-STAGE',DELTA2 + ELSE IF(IP.EQ.2) THEN + WRITE(6,680) 'END-OF-STAGE',DELTA1 + WRITE(6,690) 'END-OF-STAGE',DELTA2 + ENDIF + ENDIF + 580 CONTINUE + WRITE(6,'(/48H NOTE: POWER MAY EXIBITS VARIATIONS OUTSIDE THE , + 1 52HBEGINNING- AND END-OF-STAGE VALUES DURING THE STAGE.)') + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(LP,IMA,MU1) + RETURN +* + 640 FORMAT(/53H EVOBLD: STARTING VALUES OF INITIAL/FINAL AVERAGED FL, + 1 11HUX IN FUEL=,1P,2E12.4,15H E+13 N/CM**2/S) + 650 FORMAT(/37H EVOBLD: ITERATION ON FINAL POWER NB.,I3,3X,6HERROR=, + 1 1P,E12.4,3X,36HINITIAL/FINAL AVERAGED FLUX IN FUEL=,2E12.4, + 2 15H E+13 N/CM**2/S) + 660 FORMAT(/' EVOBLD: ', + 1 'FUEL BURNUP INCREMENT DURING THIS STAGE =',1P, + 1 E12.4,' MW*S**8/TONNE (',E12.4,' MW*DAY/TONNE).'/9X, + 2 'NEUTRON EXPOSURE (FLUENCE) INCREMENT =',E12.4,' N/KB.') + 661 FORMAT(/' EVOBLD: ', + 1 'NEUTRON EXPOSURE (FLUENCE) INCREMENT DURING THIS STAGE =',1P, + 2 E12.4,' N/KB.') + 665 FORMAT(' EVOBLD: ', + 1 'TARGET FUEL BURNUP INCREMENT DURING THIS STAGE =',1P, + 2 E12.4,' MW*S**8/TONNE (',E12.4,' MW*DAY/TONNE).') + 680 FORMAT(/34H EVOBLD: NEUTRON-INDUCED POWER AT ,A,2H =,1P,E12.4, + > 10H MW/TONNE.) + 690 FORMAT(/24H EVOBLD: DECAY POWER AT ,A,2H =,1P,E12.4,10H MW/TONNE.) + END diff --git a/Dragon/src/EVODPL.f b/Dragon/src/EVODPL.f new file mode 100644 index 0000000..7868b98 --- /dev/null +++ b/Dragon/src/EVODPL.f @@ -0,0 +1,425 @@ +*DECK EVODPL + SUBROUTINE EVODPL(IMPX,YDPL,NVAR,XT,EPS1,EXPMAX,H1,ITYPE,IDIRAC, + 1 IEVOL2,MU1,IMA,MAXA,NSUPF,NFISS,KFISS,YSF,ADPL,BDPL,ICHAIN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Multi-purpose driver for solving the isotopic depletion equations, +* taking into account the saturation phenomena. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* IMPX print flag (equal to zero for no print). +* YDPL initial/final number densities. +* NVAR number of nuclides in the complete depletion chain. +* XT initial and final value of the independent variable. +* EPS1 required accuracy for the ODE solver. +* EXPMAX saturation limit. A nuclide is saturating if +* -ADPL(MU1(I))*(XT(2)-XT(1)).GT.EXPMAX. Suggested value: +* EXPMAX=80.0. EXPMAX=0.0 means that the saturation model is +* not used. +* H1 guessed first stepsize. +* ITYPE type of ODE solution: +* =1 fifth-order Runge-Kutta method; +* =2 fourth-order Kaps-Rentrop method. +* IDIRAC saturation model flag (=1 to use Dirac function contributions +* in the saturating nuclide number densities. +* IEVOL2 flag making an isotope non-depleting: +* =1 to force an isotope to be non-depleting; +* =2 to force an isotope to be depleting; +* =3 to force an isotope to be at saturation. +* MU1 position of each diagonal element in matrix ADPL. +* IMA position of the first non-zero column element in matrix ADPL. +* MAXA first dimension of matrix ADPL. +* NSUPF number of depleting fission products. +* NFISS number of fissile isotopes producing fission products. +* KFISS position in chain of the fissile isotopes. +* YSF initial/final product of the fission yields and fission +* rates. +* ADPL initial/final depletion matrix. +* BDPL initial/final depletion source. +* ICHAIN name of the isotopes in the depletion chain. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IMPX,NVAR,ITYPE,IDIRAC,IEVOL2(NVAR),MU1(NVAR),IMA(NVAR), + 1 MAXA,NSUPF,NFISS,KFISS(NFISS),ICHAIN(2,NVAR) + REAL YDPL(NVAR,2),XT(2),EPS1,EXPMAX,H1,YSF(NFISS,NSUPF,2), + 1 ADPL(MAXA,2),BDPL(NVAR,2) +*---- +* LOCAL VARIABLES +*---- + LOGICAL LSAT + CHARACTER*2 SHOW(120,120) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KSAT,IPERM,MU12,IMA2,KFIS2 + REAL, ALLOCATABLE, DIMENSION(:) :: YST1,YSAT + REAL, ALLOCATABLE, DIMENSION(:,:) :: ADPL2,BDPL2,BDPL3 + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: YSF2,YSF3 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(KSAT(NVAR),IPERM(NVAR),MU12(NVAR),IMA2(NVAR), + 1 KFIS2(NFISS)) + ALLOCATE(YST1(NVAR),YSAT(NVAR),ADPL2(MAXA,2),BDPL2(NVAR,2), + 1 YSF2(NFISS,NSUPF,2)) +*---- +* COMPUTE THE LUMPING INDEX VECTOR IPERM +*---- + DO 10 I=1,NVAR + IPERM(I)=I + 10 CONTINUE + NTER=0 + 20 NTER=NTER+1 + INDSAT=0 + DO 30 I=1,NVAR + IF(IPERM(I).GE.0) THEN + LSAT=(IEVOL2(I).EQ.3).AND.(EXPMAX.GT.0.0) + IF(EXPMAX.GT.0.0) THEN + LSAT=LSAT.OR.((ABS(ADPL(MU1(I),1)*(XT(2)-XT(1))).GT.EXPMAX) + > .AND.(ABS(ADPL(MU1(I),2)*(XT(2)-XT(1))).GT.EXPMAX)) + ENDIF + IF(LSAT) THEN + DO 25 II=1,NFISS + IF(I.EQ.KFISS(II)) GO TO 30 + 25 CONTINUE + IPERM(I)=0 + IF(INDSAT.EQ.0) THEN + IF(IMPX.GT.5) WRITE(6,'(17H EVODPL: ISOTOPE ,2A4, + 1 18H IS SATURATING(1).)') ICHAIN(1,I),ICHAIN(2,I) + IPERM(I)=-NTER + INDSAT=I + ENDIF + ENDIF + ENDIF + 30 CONTINUE + IF(INDSAT.EQ.0) GO TO 60 + DO 50 I=INDSAT+1,NVAR + JMN=I-MU1(I)+IMA(I-1)+1 + IMN=I-IMA(I)+MU1(I) + DO 40 J=MIN(JMN,IMN),I-1 + IF((IPERM(I).EQ.0).AND.(IPERM(J).EQ.-NTER)) THEN + IF(IMPX.GT.5) WRITE(6,'(17H EVODPL: ISOTOPE ,2A4, + 1 18H IS SATURATING(2).)') ICHAIN(1,I),ICHAIN(2,I) + IPERM(I)=-NTER + GO TO 50 + ENDIF + 40 CONTINUE + 50 CONTINUE + GO TO 20 + 60 NTER=NTER-1 + N=0 + DO 70 I=1,NVAR + IF(IPERM(I).GT.0) THEN + N=N+1 + IPERM(I)=N + ENDIF + 70 CONTINUE + IF(IMPX.GT.3) THEN + WRITE(6,400) NVAR,XT(1),XT(2),EPS1,H1,ITYPE,NTER,NVAR-N,NFISS, + 1 NSUPF,(IPERM(I),I=1,NVAR) + WRITE(6,410) (YDPL(I,1),I=1,NVAR) + ENDIF + IF(IMPX.GT.5) THEN + NVARM=MIN(NVAR,120) + WRITE (6,'(//34H EVODPL: DEPLETION MATRIX PROFILE:/)') + DO 85 I=1,NVARM + DO 80 J=1,NVARM + SHOW(I,J)=' ' + 80 CONTINUE + 85 CONTINUE + IMAM1=0 + DO 120 I=1,NVARM + DO 90 J=I-MU1(I)+IMAM1+1,I-1 + SHOW(I,J)='*' + 90 CONTINUE + DO 100 J=I-IMA(I)+MU1(I),I-1 + SHOW(J,I)='*' + 100 CONTINUE + IF(I.GT.NVAR-NSUPF) THEN + DO 110 K=1,NFISS + KFI=KFISS(K) + IF((KFI.GT.0).AND.(KFI.LE.120)) SHOW(I,KFI)='-' + 110 CONTINUE + ENDIF + SHOW(I,I)='+' + IMAM1=IMA(I) + 120 CONTINUE + DO 130 I=1,NVARM + WRITE (6,'(1X,I4,1X,2A4,1X,120A2)') I,ICHAIN(1,I),ICHAIN(2,I), + 1 (SHOW(I,J),J=1,NVARM) + 130 CONTINUE + IF(NVAR.GT.120) + > WRITE(6,'(34H MATRIX TRUNCATED TO 120 ELEMENTS.)') + IF(IMPX .GE. 1000) THEN + write(6,'(A)') 'ORIGINAL DEPLETION SYSTEM' + write(6,'(3I10)') NVAR,NFISS,NSUPF + write(6,'(A6)') 'MU1 ' + write(6,'(20I5)') (MU1(I),I=1,NVAR) + write(6,'(A6)') 'IMA ' + write(6,'(20I5)') (IMA(I),I=1,NVAR) + write(6,'(A6)') 'ADPL1 ' + write(6,'(1P,5E20.12)') (ADPL(I,1),I=1,IMA(NVAR)) + write(6,'(A6)') 'BDPL1 ' + write(6,'(1P,5E20.12)') (BDPL(I,1),I=1,NVAR) + write(6,'(A6)') 'KFISS ' + write(6,'(20I5)') (KFISS(K),K=1,NFISS) + write(6,'(A6)') 'YSF1 ' + write(6,'(1P,5E20.12)') ((YSF(I,J,1),I=1,NFISS),J=1,NSUPF) + ENDIF + ENDIF +*---- +* LUMPING OF THE DEPLETION MATRICES +*---- + DO 135 IFI=1,NFISS + KFIS2(IFI)=KFISS(IFI) + 135 CONTINUE + DO 140 I=1,NVAR + YST1(I)=YDPL(I,1) + MU12(I)=MU1(I) + IMA2(I)=IMA(I) + 140 CONTINUE + DO 162 L=1,2 + DO 145 I=1,NVAR + BDPL2(I,L)=BDPL(I,L) + 145 CONTINUE + DO 150 I=1,IMA(NVAR) + ADPL2(I,L)=ADPL(I,L) + 150 CONTINUE + DO 161 I=1,NFISS + DO 160 J=1,NSUPF + YSF2(I,J,L)=YSF(I,J,L) + 160 CONTINUE + 161 CONTINUE + 162 CONTINUE + NVAR2=NVAR + NSUPF2=NSUPF + DO 180 ITER=1,NTER + I0=0 + NSAT=0 + DO 170 I=1,NVAR + IF((IPERM(I).GT.0).OR.(IPERM(I).LT.-ITER)) THEN + I0=I0+1 + ELSE IF(IPERM(I).EQ.-ITER) THEN + I0=I0+1 + NSAT=NSAT+1 + KSAT(NSAT)=I0 + ENDIF + 170 CONTINUE + IF(I0.NE.NVAR2) CALL XABORT('EVODPL: ALGORITHM FAILURE 1.') + MAXB=NVAR + MAXY=NSUPF + CALL EVOSAT(IMPX,MAXA,MAXB,MAXY,2,NSAT,NVAR2,KSAT,YST1,YSAT,MU12, + 1 IMA2,NSUPF2,NFISS,IDIRAC,KFIS2,YSF2(1,1,1),ADPL2(1,1),BDPL2(1,1), + 2 NSUPF3) + NVAR2=NVAR2-NSAT + NSUPF2=NSUPF3 + NSAT=0 + I0=0 + DO 175 I=1,NVAR + IF((IPERM(I).GT.0).OR.(IPERM(I).LT.-ITER)) THEN + I0=I0+1 + YDPL(I,1)=YST1(I0) + ELSE IF(IPERM(I).EQ.-ITER) THEN + NSAT=NSAT+1 + YDPL(I,1)=YSAT(NSAT) + ENDIF + 175 CONTINUE + 180 CONTINUE + IF(IMPX.GT.4) WRITE(6,420) (YDPL(I,1),I=1,NVAR) +*---- +* SOLUTION OF THE LUMPED DEPLETION SYSTEM +*---- + DO 185 I=1,NVAR + YDPL(I,2)=YDPL(I,1) + 185 CONTINUE + IF(NVAR2.EQ.0) GO TO 315 + DO 190 I=1,NVAR2 + FACT=(BDPL2(I,2)-BDPL2(I,1))/(XT(2)-XT(1)) + BDPL2(I,1)=BDPL2(I,1)-FACT*XT(1) + BDPL2(I,2)=FACT + 190 CONTINUE + DO 200 I=1,IMA2(NVAR2) + FACT=(ADPL2(I,2)-ADPL2(I,1))/(XT(2)-XT(1)) + ADPL2(I,1)=ADPL2(I,1)-FACT*XT(1) + ADPL2(I,2)=FACT + 200 CONTINUE + DO 215 I=1,NFISS + DO 210 J=1,NSUPF2 + FACT=(YSF2(I,J,2)-YSF2(I,J,1))/(XT(2)-XT(1)) + YSF2(I,J,1)=YSF2(I,J,1)-FACT*XT(1) + YSF2(I,J,2)=FACT + 210 CONTINUE + 215 CONTINUE + IF(IMPX.GT.4) THEN + WRITE(6,430) NSUPF2 + WRITE(6,440) (YST1(I),I=1,NVAR2) + ENDIF + IF(IMPX.GT.5) THEN + NVARM=MIN(NVAR2,120) + WRITE (6,'(//41H EVODPL: LUMPED DEPLETION MATRIX PROFILE:/)') + DO 225 I=1,NVARM + DO 220 J=1,NVARM + SHOW(I,J)=' ' + 220 CONTINUE + 225 CONTINUE + IMAM1=0 + DO 260 I=1,NVARM + DO 230 J=I-MU12(I)+IMAM1+1,I-1 + SHOW(I,J)='*' + 230 CONTINUE + DO 240 J=I-IMA2(I)+MU12(I),I-1 + SHOW(J,I)='*' + 240 CONTINUE + IF(I.GT.NVAR2-NSUPF2) THEN + DO 250 K=1,NFISS + KFI=KFIS2(K) + IF((KFI.GT.0).AND.(KFI.LE.60)) SHOW(I,KFI)='-' + 250 CONTINUE + ENDIF + SHOW(I,I)='+' + IMAM1=IMA2(I) + 260 CONTINUE + DO 270 I=1,NVARM + WRITE (6,'(1X,I4,1X,2A4,1X,120A2)') I,ICHAIN(1,I),ICHAIN(2,I), + 1 (SHOW(I,J),J=1,NVARM) + 270 CONTINUE + IF(NVAR.GT.120) + > WRITE(6,'(34H MATRIX TRUNCATED TO 120 ELEMENTS.)') + IF(IMPX .GE. 1000) THEN + write(6,'(A)') 'LUMPED DEPLETION SYSTEM' + write(6,'(3I10)') NVAR2,NFISS,NSUPF2 + write(6,'(A6)') 'MU1 ' + write(6,'(20I5)') (MU12(I),I=1,NVAR2) + write(6,'(A6)') 'IMA ' + write(6,'(20I5)') (IMA2(I),I=1,NVAR2) + write(6,'(A6)') 'ADPL2 ' + write(6,'(1P,5E20.12)') (ADPL2(I,1),I=1,IMA2(NVAR2)) + write(6,'(A6)') 'BDPL2 ' + write(6,'(1P,5E20.12)') (BDPL2(I,1),I=1,NVAR2) + write(6,'(A6)') 'KFISS ' + write(6,'(20I5)') (KFIS2(K),K=1,NFISS) + write(6,'(A6)') 'YSF1 ' + write(6,'(1P,5E20.12)') ((YSF2(I,J,1),I=1,NFISS),J=1,NSUPF2) + ENDIF + ENDIF + ALLOCATE(BDPL3(NVAR2,2),YSF3(NFISS,NSUPF2,2)) + DO 280 I=1,NVAR2 + BDPL3(I,1)=BDPL2(I,1) + BDPL3(I,2)=BDPL2(I,2) + 280 CONTINUE + DO 295 I=1,NFISS + DO 290 J=1,NSUPF2 + YSF3(I,J,1)=YSF2(I,J,1) + YSF3(I,J,2)=YSF2(I,J,2) + 290 CONTINUE + 295 CONTINUE + CALL EVOODE(YST1,NVAR2,XT(1),XT(2),EPS1,H1,NOK,NBAD,ITYPE,MU12, + 1 IMA2,MAXA,NSUPF2,NFISS,KFIS2,YSF3,ADPL2,BDPL3) + DEALLOCATE(YSF3,BDPL3) + IF(IMPX.GT.4) THEN + WRITE(6,450) (YST1(I),I=1,NVAR2) + IF(ITYPE.LE.2) WRITE(6,'(13H EVODPL: NOK=,I5,6H NBAD=,I5)') + 1 NOK,NBAD + ENDIF + DO 310 I=1,NVAR + IF(IPERM(I).GT.0) YDPL(I,2)=YST1(IPERM(I)) + 310 CONTINUE +*---- +* COMPUTE NUMBER DENSITIES OF THE SATURATED ISOTOPES +*---- + 315 IF(NTER.EQ.0) GO TO 370 + DO 320 I=1,NVAR + YST1(I)=YDPL(I,2) + BDPL2(I,2)=BDPL(I,2) + MU12(I)=MU1(I) + IMA2(I)=IMA(I) + 320 CONTINUE + DO 330 I=1,IMA(NVAR) + ADPL2(I,2)=ADPL(I,2) + 330 CONTINUE + DO 345 I=1,NFISS + KFIS2(I)=KFISS(I) + DO 340 J=1,NSUPF + YSF2(I,J,2)=YSF(I,J,2) + 340 CONTINUE + 345 CONTINUE + NVAR2=NVAR + NSUPF2=NSUPF + DO 365 ITER=1,NTER + I0=0 + NSAT=0 + DO 350 I=1,NVAR + IF((IPERM(I).GT.0).OR.(IPERM(I).LT.-ITER)) THEN + I0=I0+1 + ELSE IF(IPERM(I).EQ.-ITER) THEN + I0=I0+1 + NSAT=NSAT+1 + KSAT(NSAT)=I0 + ENDIF + 350 CONTINUE + IF(I0.NE.NVAR2) CALL XABORT('EVODPL: ALGORITHM FAILURE 2.') + MAXB=NVAR + MAXY=NSUPF + CALL EVOSAT(IMPX,MAXA,MAXB,MAXY,1,NSAT,NVAR2,KSAT,YST1,YSAT,MU12, + 1 IMA2,NSUPF2,NFISS,IDIRAC,KFIS2,YSF2(1,1,2),ADPL2(1,2),BDPL2(1,2), + 2 NSUPF3) + IF(IMPX.GT.4) WRITE(6,425) ITER,(YSAT(I),I=1,NSAT) + NVAR2=NVAR2-NSAT + NSUPF2=NSUPF3 + NSAT=0 + I0=0 + DO 360 I=1,NVAR + IF((IPERM(I).GT.0).OR.(IPERM(I).LT.-ITER)) THEN + I0=I0+1 + YDPL(I,2)=YST1(I0) + ELSE IF(IPERM(I).EQ.-ITER) THEN + NSAT=NSAT+1 + YDPL(I,2)=YSAT(NSAT) + ENDIF + 360 CONTINUE + 365 CONTINUE + 370 IF(IMPX.GT.3) WRITE(6,460) (YDPL(I,2),I=1,NVAR) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(YSF2,BDPL2,ADPL2,YSAT,YST1) + DEALLOCATE(KFIS2,IMA2,MU12,IPERM,KSAT) + RETURN +* + 400 FORMAT(//45H EVODPL: SOLUTION OF THE DEPLETION EQUATIONS.//14X, + 1 25HTOTAL NUMBER OF NUCLIDES=,I5/26X,13HINITIAL TIME=,1P,E12.4/ + 2 28X,11HFINAL TIME=,E12.4/15X,24HACCURACY FOR ODE SOLVER=,E12.4/ + 3 16X,23HGUESSED FIRST STEPSIZE=,E12.4,0P/22X,17HTYPE OF SOLUTION=, + 4 I3/39H NUMBER OF GROUP OF SATURATED NUCLIDES=,I5/10X, + 5 29HNUMBER OF SATURATED NUCLIDES=,I5/12X,19HNUMBER OF FISSILE N, + 6 8HUCLIDES=,I5/12X,27HNUMBER OF FISSION PRODUCTS=,I5// + 7 22H LUMPING INDEX VECTOR:/(1X,20I5)) + 410 FORMAT(/48H EVODPL: INITIAL VALUES OF THE DEPLETION SYSTEM:/ + 1 (1X,1P,10E12.4)) + 420 FORMAT(/53H EVODPL: SATURATED INITIAL CONDITIONS OF THE DEPLETIO, + 1 9HN SYSTEM:/(1X,1P,10E12.4)) + 425 FORMAT(/51H EVODPL: FINAL VALUES OF THE SATURATED NUCLIDES IN , + 1 9HGROUP NO.,I5//(1X,1P,10E12.4)) + 430 FORMAT(/42H NUMBER OF NON-SATURATED FISSION PRODUCTS=,I5) + 440 FORMAT(/55H EVODPL: INITIAL VALUES OF THE LUMPED DEPLETION SYSTEM: + 1 /(1X,1P,10E12.4)) + 450 FORMAT(/53H EVODPL: ODE SOLUTION OF THE LUMPED DEPLETION SYSTEM:/ + 1 (1X,1P,10E12.4)) + 460 FORMAT(/42H EVODPL: SOLUTION OF THE DEPLETION SYSTEM:/ + 1 (1X,1P,10E12.4)) + END diff --git a/Dragon/src/EVODRV.f b/Dragon/src/EVODRV.f new file mode 100644 index 0000000..5015c51 --- /dev/null +++ b/Dragon/src/EVODRV.f @@ -0,0 +1,1034 @@ +*DECK EVODRV + SUBROUTINE EVODRV(IPDEPL,IPLIB,INDREC,IMPX,NBISO,NGROUP,NBMIX, + 1 ISONAM,ISONRF,MIX,DEN,IEVOL,ISTYP,VX,NDEPL,NSUPS,NREAC,NCOMB, + 2 EPS1,EPS2,EXPMAX,H1,ITYPE,INR,IEXTR,IGLOB,ISAT,IDIRAC,ITIXS, + 3 IFLMAC,IYLMIX,FIT,ISAVE,ISET,IDEPL,XTI,XTF,XT,LMACRO,FLUMIX, + 4 IPICK,MIXBRN,MIXPWR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Isotopic depletion calculation main driver. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPDEPL pointer to the depletion history (L_BURNUP signature). +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* INDREC beginning of depletion flag (=1: beginning; =2: else). +* IMPX print flag (equal to zero for no print). +* NBISO number of isotopes present in the calculation domain. +* NGROUP number of energy groups. +* NBMIX number of mixtures. +* ISONAM alias name of isotopes. +* ISONRF library name of isotopes. +* MIX mix number of each isotope (can be zero). +* DEN density of each isotope. +* IEVOL non-depleting flag (=1 to force an isotope to be +* non-depleting; =2 to force an isotope to be depleting; +* =3: to force an isotope to be at saturation). +* ISTYP isotope type (=1 not fissile nor fission product; =2: fissile; +* =3: fission product). +* VX volume occupied by each mixture. +* NDEPL number of isotopes in the depletion chain. +* NSUPS number of non-depleting isotopes producing energy. +* NREAC maximum number of depletion reactions. +* NCOMB number of depleting mixtures. +* EPS1 required accuracy for the ODE solver. +* EPS2 required accuracy for constant power iterations. +* EXPMAX saturation limit. A nuclide is saturating if +* -ADPL(MU1(I))*(XT(2)-XT(1)).GT.EXPMAX. Suggested value: +* EXPMAX=80.0. +* H1 guessed first stepsize. +* ITYPE type of ODE solution: +* =1 fifth-order Runge-Kutta method; +* =2 fourth-order Kaps-Rentrop method. +* INR type of flux normalization: +* =0: out-of-core depletion; +* =1: constant flux depletion; +* =2: constant fuel power depletion; +* =3: constant assembly power depletion. +* IEXTR flux extrapolation flag (=0: no extrapolation; =1: perform +* linear extrapolation; =2: perform parabolic extrapolation). +* IGLOB out-of-fuel power in flux normalization. Compute the burnup: +* =-1: using the Serpent mode 0 empirical formula in the fuel; +* =0: using the power released in the fuel; +* =1: using the power released in the global geometry. +* ISAT initial saturation flag (=1 to save initial saturated number +* densities). +* IDIRAC saturation model flag (=1 to use Dirac function contributions +* in the saturating nuclide number densities). +* ITIXS flag for time-dependent cross sections (=0/1: on/off). +* IFLMAC 0/1/2 flag to recover fluxes from L_FLUX/L_MACROLIB/L_POWER. +* IYLMIX 0/1 flag to recover fission yield data from DEPL-CHAIN/PYIELD +* data. +* FIT flux normalization factor: +* n/cm**2/s if INR=1; +* MW/tonne of initial heavy elements if INR=2; +* W/cc of assembly volume if INR=3. +* ISAVE save flag: +* =-1: do not save the last flux calculation in the depletion +* table; +* .GE.0 save the last flux calculation in the depletion +* table at time XTI. +* ISET set flag: +* =-1: do not set the number densities to a selected time; +* .GE.0 set the number densities to time XTF of the depletion +* table. +* IDEPL depletion flag: +* =0: do not perform a depletion calculation +* =1: perform a depletion calculation. +* XTI initial save time (save the last flux calculation in the +* depletion table at time XTI). +* XTF final set time (recover the number densities from the +* depletion table at time XTF and modify the internal library). +* XT time variable (independent variable) for the depletion +* calculation. +* XT(1) initial time +* XT(2) final time +* LMACRO macrolib building flag (=.true. to compute the embedded +* macrolib). +* FLUMIX average fluxes in mixtures. +* IPICK burnup recovery flag: +* =0: do not recover the burnup in a CLE-2000 variable +* =1: recover the burnup in a CLE-2000 variable. +* MIXBRN flags for mixtures to burn. +* MIXPWR flags for mixtures to include in power normalization. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPDEPL,IPLIB + INTEGER INDREC,IMPX,NBISO,NGROUP,NBMIX,ISONAM(3,NBISO), + 1 ISONRF(3,NBISO),MIX(NBISO),IEVOL(NBISO),ISTYP(NBISO),NDEPL, + 2 NSUPS,NREAC,NCOMB,ITYPE,INR,IEXTR,IGLOB,ISAT,IDIRAC,ITIXS, + 3 IFLMAC,IYLMIX,ISAVE,ISET,IDEPL,IPICK,MIXBRN(NBMIX), + 4 MIXPWR(NBMIX) + REAL DEN(NBISO),VX(NBMIX),EPS1,EPS2,EXPMAX,H1,FIT,XTI,XTF, + 1 XT(2),FLUMIX(NGROUP,NBMIX) + LOGICAL LMACRO +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6,NSTATE=40) + TYPE(C_PTR) KPLIB + CHARACTER TEXT12*12,HSMG*131 + LOGICAL LCOOL + INTEGER IDIM(NSTATE),IPAR(NSTATE) + REAL DELTA(3),RPAR(5),BRNWIR(2),TMPDAY(3),VPH(2), + 1 FUELDN(3),DELTAT(2,2),TIMEP(2,3) + DOUBLE PRECISION T(3),WEI,DPD,XDRCST,AVCON,VTOTD,VPHINI,DBLLIR +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MILVO,ISOCMB,NFISS2, + 1 NDFP2,HREAC,IPIFI,IZAE + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: JM,INADPL,IEVOLB,KFISS, + 1 KPAR,IDR,KPF + REAL, ALLOCATABLE, DIMENSION(:) :: ENERG,RRD,AWR,PYIELD,TIMES + REAL, ALLOCATABLE, DIMENSION(:,:) :: BPAR,RER,VPHV + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: YDPL,YIELD,YIELD2 + REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: SIG + LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASK,MASKL + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO +*---- +* SCRATCH STORAGE ALLOCATION +* MILVO mixture index corresponding to each depleting mixture. +*---- + ALLOCATE(JM(NBMIX,NDEPL),MILVO(NCOMB),ISOCMB(NBISO), + 1 INADPL(3,NDEPL),IEVOLB(NDEPL,NBMIX)) + ALLOCATE(SIG(NDEPL-NSUPS+1,NREAC+1,NBMIX,1-IEXTR:2), + 1 VPHV(NBMIX,1-IEXTR:2),ENERG(NBMIX),AWR(NDEPL),IZAE(NDEPL), + 2 YDPL(NDEPL-NSUPS+1,2,NCOMB)) + ALLOCATE(MASK(NBMIX),MASKL(NGROUP)) + ALLOCATE(IPISO(NBISO)) +*---- +* INITIALIZE DATA. +*---- + AVCON=XDRCST('Neutron mass','amu')/ + 1 (1.0D-24*XDRCST('Avogadro','N/moles')) +* + IF(INDREC.EQ.1) THEN +* BEGINNING OF DEPLETION. + NTIM=0 + ELSE IF(INDREC.EQ.2) THEN + CALL LCMLEN(IPDEPL,'DEPL-TIMES',NTIM,ITYLCM) + ENDIF + IF(NTIM+2.GE.10000) CALL XABORT('EVODRV: No more than 9999'// + >'burnup steps permitted.') + ALLOCATE(TIMES(NTIM+2)) + TIMES(:NTIM+2)=0.0 + IF(NTIM.EQ.0) THEN + CALL LCMPUT(IPDEPL,'DEPL-TIMES',1,2,TIMES) + ELSE + CALL LCMGET(IPDEPL,'DEPL-TIMES',TIMES) + ENDIF +*---- +* RECOVER DEPLETION CHAIN INFO FROM LCM +*---- + NVAR=NDEPL-NSUPS + CALL LCMLEN(IPLIB,'DEPL-CHAIN',LENGT,ITYLCM) + IF (LENGT.EQ.0) CALL XABORT('EVODRV: DEPLETION CHAIN MISSING.') + CALL LCMSIX(IPLIB,'DEPL-CHAIN',1) + CALL LCMGET(IPLIB,'STATE-VECTOR',IDIM) + IF((NDEPL.NE.IDIM(1)).OR.(NSUPS.NE.IDIM(7))) + 1 CALL XABORT('EVODRV: INCONSISTENT NDEPL OR NSUPS.') + IF(NVAR.EQ.0) CALL XABORT('EVODRV: NO DEPLETING ISOTOPES') + NFISS=IDIM(2) + NDFP=IDIM(3) + NPAR=IDIM(9) + NBESP=MAX(1,IDIM(10)) + ALLOCATE(KPAR(NDEPL,NPAR),HREAC(2*NREAC),IDR(NREAC,NDEPL)) + ALLOCATE(BPAR(NDEPL,NPAR),YIELD2(NBESP,NFISS,NDFP), + 1 RER(NREAC,NDEPL),RRD(NDEPL)) + CALL LCMGET(IPLIB,'ISOTOPESDEPL',INADPL) + IF(IMPX.GT.1) THEN + WRITE(IUNOUT,'(/38HEVODRV: DEPLETING ISOTOPES FROM CHAIN:)') + WRITE(IUNOUT,'(1X,3A4,2X,3A4,2X,3A4,2X,3A4,2X,3A4,2X,3A4,2X, + 1 3A4,2X,3A4,2X,3A4,2X,3A4,2X,3A4,2X,3A4)') INADPL(:3,:NVAR) + ENDIF + CALL LCMGET(IPLIB,'PRODUCE-REAC',KPAR) + CALL LCMGET(IPLIB,'PRODUCE-RATE',BPAR) + CALL LCMGET(IPLIB,'DEPLETE-IDEN',HREAC) + CALL LCMGET(IPLIB,'DEPLETE-REAC',IDR) + CALL LCMGET(IPLIB,'DEPLETE-ENER',RER) + CALL LCMGET(IPLIB,'DEPLETE-DECA',RRD) + CALL LCMGET(IPLIB,'CHARGEWEIGHT',IZAE) + IF(NFISS*NDFP.GT.0) CALL LCMGET(IPLIB,'FISSIONYIELD',YIELD2) + CALL LCMSIX(IPLIB,' ',2) +*---- +* SET THE LCM MICROLIB ISOTOPEWISE DIRECTORIES. +*---- + CALL LIBIPS(IPLIB,NBISO,IPISO) +*---- +* DETECT THE DEPLETING ISOTOPES AND MIXTURES IN THE MICROLIB. +*---- + ICOMB=0 + JM(:NBMIX,:NDEPL)=0 + IEVOLB(:NDEPL,:NBMIX)=1 + ALLOCATE(NFISS2(NBMIX),NDFP2(NBMIX)) + NFISS2(:NBMIX)=0 + NDFP2(:NBMIX)=0 + AWR(:NDEPL)=0.0 + DO 30 ISOT=1,NBISO + IBM=MIX(ISOT) + IF(IBM.EQ.0) GO TO 30 + KPLIB=IPISO(ISOT) ! set ISOT-th isotope + DO 20 INUCL=1,NDEPL + IF((ISONRF(1,ISOT).EQ.INADPL(1,INUCL)).AND.(ISONRF(2,ISOT).EQ. + 1 INADPL(2,INUCL))) THEN + IF(JM(IBM,INUCL).GT.0) GO TO 20 + IF(C_ASSOCIATED(KPLIB)) THEN + CALL LCMLEN(KPLIB,'AWR',ILONG,ITYLCM) + IF(ILONG.EQ.1) CALL LCMGET(KPLIB,'AWR',AWR(INUCL)) + ENDIF + IF(INUCL.GT.NVAR) THEN + IF(JM(IBM,INUCL).EQ.0) THEN + IEVOLB(INUCL,IBM)=1 + JM(IBM,INUCL)=-ISOT + ENDIF + ELSE IF(IEVOL(ISOT).EQ.1) THEN + IF(JM(IBM,INUCL).EQ.0) THEN + IEVOLB(INUCL,IBM)=1 + JM(IBM,INUCL)=-ISOT + ENDIF + IF(ISTYP(ISOT).EQ.2) THEN + NFISS2(IBM)=NFISS2(IBM)+1 + JM(IBM,INUCL)=ISOT + ENDIF + ELSE + IF(ISTYP(ISOT).EQ.2) THEN + NFISS2(IBM)=NFISS2(IBM)+1 + ELSE IF(ISTYP(ISOT).EQ.3) THEN + NDFP2(IBM)=NDFP2(IBM)+1 + ENDIF + IEVOLB(INUCL,IBM)=IEVOL(ISOT) + JM(IBM,INUCL)=ISOT + IF(IEVOL(ISOT).EQ.1) GO TO 30 + DO 10 J=1,ICOMB + IF(IBM.EQ.MILVO(J)) GO TO 30 + 10 CONTINUE + ICOMB=ICOMB+1 + MILVO(ICOMB)=IBM + ENDIF + GO TO 30 + ENDIF + 20 CONTINUE + 30 CONTINUE + IF(ICOMB.NE.NCOMB) THEN + WRITE(HSMG,'(38HEVODRV: INVALID VALUE OF NCOMB (ICOMB=,I5, + 1 7H NCOMB=,I5,2H).)') ICOMB,NCOMB + CALL XABORT(HSMG) + ENDIF + DO 35 J=1,ICOMB + IBM=MILVO(J) + IF(MIXBRN(IBM).EQ.0) MILVO(J)=0 + 35 CONTINUE + IF(IYLMIX.EQ.1) THEN + NFISS=MAXVAL(NFISS2) + NDFP=MAXVAL(NDFP2) + ENDIF + DEALLOCATE(NDFP2,NFISS2) + IF(IMPX.GT.0) WRITE(IUNOUT,500) NFISS,NDFP +*---- +* SET KFISS, KPF AND YIELD +*---- + ALLOCATE(KFISS(NFISS,NBMIX),KPF(NDFP,NBMIX), + 1 YIELD(NFISS,NDFP,NBMIX)) + KFISS(:NFISS,:NBMIX)=0 + KPF(:NDFP,:NBMIX)=0 + IF(IYLMIX.EQ.0) THEN +* Use fission yield data from 'DEPL-CHAIN' + DO 40 IS=1,NVAR + KDRI=IDR(2,IS)/100 + IF((KDRI.GT.0).AND.(MOD(IDR(2,IS),100).EQ.4)) THEN + IF(KDRI.GT.NFISS) CALL XABORT('EVODRV: INVALID NFISS.') + KFISS(KDRI,:NBMIX)=IS + ELSE IF((KDRI.GT.0).AND.(MOD(IDR(2,IS),100).EQ.5)) THEN + IF(KDRI.GT.NDFP) CALL XABORT('EVODRV: INVALID NDFP.') + KPF(KDRI,:NBMIX)=IS + ENDIF + 40 CONTINUE + DO IDFP=1,NDFP + DO IFISS=1,NFISS + YIELD(IFISS,IDFP,:NBMIX)=YIELD2(NBESP,IFISS,IDFP) + ENDDO + ENDDO + ELSE IF(IYLMIX.EQ.1) THEN +* Use isotopic PIFI/PYIELD fission yield data + YIELD(:NFISS,:NDFP,:NBMIX)=0.0 + DO 65 IBM=1,NBMIX + IFISS=0 + IDFP=0 + DO 50 IS=1,NVAR + ISOT=ABS(JM(IBM,IS)) + IF(ISOT.EQ.0) GO TO 50 + IF(ISTYP(ISOT).EQ.2) THEN + IFISS=IFISS+1 + IF(IFISS.GT.NFISS) CALL XABORT('EVODRV: NFISS OVERFLOW.') + KFISS(IFISS,IBM)=IS + IF(IDR(2,IS).EQ.0) IDR(2,IS)=4 + ELSE IF(ISTYP(ISOT).EQ.3) THEN + IDFP=IDFP+1 + IF(IDFP.GT.NDFP) CALL XABORT('EVODRV: NDFP OVERFLOW.') + KPF(IDFP,IBM)=IS + IF(IDR(2,IS).EQ.0) IDR(2,IS)=5 + ENDIF + 50 CONTINUE + DO 60 IS=1,NVAR + ISOT=JM(IBM,IS) + IF(ISOT.LE.0) GO TO 60 + KPLIB=IPISO(ISOT) ! set ISOT-th isotope + IF(.NOT.C_ASSOCIATED(KPLIB)) THEN + WRITE(HSMG,'(17HEVODRV: ISOTOPE '',3A4,16H'' IS NOT AVAILAB, + > 22HLE IN THE MICROLIB(1).)') (ISONAM(I0,ISOT),I0=1,3) + CALL XABORT(HSMG) + ENDIF + CALL LCMLEN(KPLIB,'PIFI',NDFI,ITYLCM) + IF(NDFI.GT.0) THEN + ALLOCATE(IPIFI(NDFI),PYIELD(NDFI)) + CALL LCMGET(KPLIB,'PIFI',IPIFI) + CALL LCMGET(KPLIB,'PYIELD',PYIELD) + IDFP=0 + DO I=1,NDFP + IF(KPF(I,IBM).EQ.IS) THEN + IDFP=I + EXIT + ENDIF + ENDDO + IF(IDFP.EQ.0) THEN + WRITE(IUNOUT,510) 'FISSION PRODUCT',IS,(KPF(I,IBM), + 1 I=1,NDFP) + WRITE(HSMG,'(39HEVODRV: UNABLE TO FIND FP INDEX FOR ISO, + 1 5HTOPE ,3A4,5H (1).)')(ISONAM(I0,ISOT),I0=1,3) + CALL XABORT(HSMG) + ENDIF + DO 55 I=1,NDFI + IF(IPIFI(I).EQ.0) GO TO 55 + DO JST=1,NVAR + IF(ABS(JM(IBM,JST)).EQ.IPIFI(I)) THEN + IFISS=0 + DO J=1,NFISS + IF(KFISS(J,IBM).EQ.JST) THEN + IFISS=J + EXIT + ENDIF + ENDDO + IF(IFISS.EQ.0) THEN + WRITE(IUNOUT,510) 'FISSILE ISOTOPE',JST, + 1 (KFISS(J,IBM),J=1,NFISS) + CALL XABORT('EVODRV: UNABLE TO FIND FISSILE I' + 1 //'SOTOPE INDEX') + ENDIF + YIELD(IFISS,IDFP,IBM)=PYIELD(I) + GO TO 55 + ENDIF + ENDDO + WRITE(HSMG,'(39HEVODRV: UNABLE TO FIND FP INDEX FOR ISO, + 1 5HTOPE ,3A4,5H (2).)')(ISONAM(I0,ISOT),I0=1,3) + CALL XABORT(HSMG) + 55 CONTINUE + DEALLOCATE(PYIELD,IPIFI) + ENDIF + 60 CONTINUE + 65 CONTINUE + ELSE + CALL XABORT('EVODRV: INVALID VALUE OF FLAG IYLMIX.') + ENDIF + DEALLOCATE(YIELD2) +*---- +* COMPUTE THE INITIAL INTEGRATED FLUX +*---- + VPHINI=0.0D0 + DO 85 IU=1,NGROUP + DO 80 ICMB=1,NCOMB + IBM=MILVO(ICMB) + IF(IBM.GT.0) VPHINI=VPHINI+FLUMIX(IU,IBM)*VX(IBM) + 80 CONTINUE + 85 CONTINUE +*---- +* CHECK IF PERTURBATION XS OR STANDARD XS. +*---- + NXSPER=1 + CALL LCMLEN(IPLIB,'TIMESPER',LENGTH,ITYLCM) + IF((LENGTH.GE.2).AND.(LENGTH.LE.6)) THEN + CALL LCMGET(IPLIB,'TIMESPER',TIMEP) + DELTAT(1,1)=TIMEP(1,1) + DELTAT(2,1)=TIMEP(2,1) + TMPREF=DELTAT(1,1) + NXSPER=2 + IF(ITIXS.EQ.0) THEN + DO 90 IP=1,2 + DELTAT(1,IP)=1.0 + DELTAT(2,IP)=XT(IP)/8.64E-4-TMPREF + 90 CONTINUE + ELSE + XREF=XT(1)/8.64E-4 + DO 100 IP=1,2 + DELTAT(1,IP)=1.0 + DELTAT(2,IP)=XREF-TMPREF + 100 CONTINUE + ENDIF + ELSE + DO 110 IP=1,2 + DELTAT(1,IP)=1.0 + DELTAT(2,IP)=0.0 + 110 CONTINUE + ENDIF +*---- +* COMPUTE AND SAVE THE INITIAL MASS OF HEAVY ELEMENTS +*---- + VTOTD=0.0D0 + DO ICMB=1,NCOMB + IBM=MILVO(ICMB) + IF(IBM.EQ.0) CYCLE + IF(MIXPWR(IBM).GT.0) VTOTD=VTOTD+DBLE(VX(IBM)) + ENDDO + IF(INDREC.EQ.1) THEN +* +* COMPUTE THE GLOBAL HEAVY-ELEMENT MASS FOR ISOTOPES IN MIXPWR. + FUELDN(1)=0.0 + IF(IGLOB.LE.0) THEN + DO 120 ICMB=1,NCOMB + IBM=MILVO(ICMB) + IF(IBM.EQ.0) GO TO 120 + IF(MIXPWR(IBM).GT.0) THEN + DO 115 IS=1,NBISO + IF((MIX(IS).NE.IBM).OR.(IEVOL(IS).EQ.1)) GO TO 115 + KPLIB=IPISO(IS) ! set IS-th isotope + IF(C_ASSOCIATED(KPLIB)) THEN + AWRGAR=0.0 + CALL LCMLEN(KPLIB,'AWR',ILONG,ITYLCM) + IF(ILONG.EQ.1) CALL LCMGET(KPLIB,'AWR',AWRGAR) + IF((AWRGAR.GT.210.0).OR.(ISTYP(IS).EQ.2)) THEN + FUELDN(1)=FUELDN(1)+AWRGAR*DEN(IS)*VX(IBM) + ENDIF + ENDIF + 115 CONTINUE + ENDIF + 120 CONTINUE + ELSE IF(IGLOB.EQ.1) THEN + DO 125 IBM=1,NBMIX + IF(MIXPWR(IBM).GT.0) THEN + DO 124 IS=1,NBISO + IF(MIX(IS).NE.IBM) GO TO 124 + KPLIB=IPISO(IS) ! set IS-th isotope + IF(C_ASSOCIATED(KPLIB)) THEN + AWRGAR=0.0 + CALL LCMLEN(KPLIB,'AWR',ILONG,ITYLCM) + IF(ILONG.EQ.1) CALL LCMGET(KPLIB,'AWR',AWRGAR) + IF((AWRGAR.GT.210.0).OR.(ISTYP(IS).EQ.2)) THEN + FUELDN(1)=FUELDN(1)+AWRGAR*DEN(IS)*VX(IBM) + ENDIF + ENDIF + 124 CONTINUE + ENDIF + 125 CONTINUE + ENDIF + IF(FUELDN(1).EQ.0) THEN + IF(INR.LE.1) THEN + FUELDN(1)=0.0 + ELSE + CALL XABORT('EVODRV: Burnup at fixed power without '// + 1 'heavy fissile isotopes is forbidden') + ENDIF + ELSE + FUELDN(1)=FUELDN(1)*REAL(AVCON/VTOTD) + ENDIF + FUELDN(2)=FUELDN(1)*REAL(VTOTD) + VASSMB=0.0 + DO 130 IBM=1,NBMIX + IF(MIXPWR(IBM).EQ.1) THEN + VASSMB=VASSMB+VX(IBM) + ENDIF + 130 CONTINUE + FUELDN(3)=FUELDN(2)/VASSMB + CALL LCMPUT(IPDEPL,'FUELDEN-INIT',3,2,FUELDN) +* +* COMPUTE THE HEAVY-ELEMENT MASS PER MIXTURE. + DO 150 IBM=1,NBMIX + ENERG(IBM)=0.0 + DO 140 IS=1,NBISO + IF((MIX(IS).NE.IBM).OR.(IEVOL(IS).EQ.1)) GO TO 140 + KPLIB=IPISO(IS) ! set IS-th isotope + IF(C_ASSOCIATED(KPLIB)) THEN + AWRGAR=0.0 + CALL LCMLEN(KPLIB,'AWR',ILONG,ITYLCM) + IF(ILONG.EQ.1) CALL LCMGET(KPLIB,'AWR',AWRGAR) + IF((AWRGAR.GT.210.0).OR.(ISTYP(IS).EQ.2)) THEN + ENERG(IBM)=ENERG(IBM)+AWRGAR*DEN(IS)*VX(IBM) + ENDIF + ENDIF + 140 CONTINUE + ENERG(IBM)=ENERG(IBM)*REAL(AVCON) + 150 CONTINUE + CALL LCMPUT(IPDEPL,'FUELDEN-MIX',NBMIX,2,ENERG) +* +* COMPUTE THE TOTAL MASS PER MIXTURE. + ENERG(:NBMIX)=0.0 + DO 170 IS=1,NBISO + IF(DEN(IS).EQ.0.0) GO TO 170 + KPLIB=IPISO(IS) ! set IS-th isotope + AWRGAR=0.0 + IF(C_ASSOCIATED(KPLIB)) THEN + CALL LCMLEN(KPLIB,'AWR',ILONG,ITYLCM) + IF(ILONG.EQ.1) CALL LCMGET(KPLIB,'AWR',AWRGAR) + ENDIF + DO 160 IBM=1,NBMIX + IF(MIX(IS).EQ.IBM) THEN + ENERG(IBM)=ENERG(IBM)+REAL(AWRGAR*DEN(IS)*VX(IBM)*AVCON) + ENDIF + 160 CONTINUE + 170 CONTINUE + CALL LCMPUT(IPDEPL,'WEIGHT-MIX',NBMIX,2,ENERG) + ELSE + CALL LCMGET(IPDEPL,'FUELDEN-INIT',FUELDN) + ENDIF + IF(IMPX.GT.0) THEN + WRITE (6,610) FUELDN(1),VTOTD,FUELDN(2),FUELDN(3) + ENDIF +*---- +* SAVE THE LAST FLUX CALCULATION SET POINT IN THE DEPLETION TABLE. +* CROSS-SECTION PERTURBATION IS ENABLED IF ISAVE=0 AND NXSPER=2. +*---- + IF(ISAVE.EQ.0) THEN + DO 200 IP=1,NXSPER + ITIM=0 + IF(NTIM.GT.0) THEN + DO 180 I=1,NTIM + IF(ABS(TIMES(I)-XT(IP)).LE.1.0E-4*XT(IP)) ITIM=I + 180 CONTINUE + ENDIF + IF(ITIM.EQ.0) THEN + IF(NTIM.GT.0) THEN + IF(XT(IP).LT.TIMES(NTIM)) CALL XABORT('EVODRV: INVALID X1.') + ENDIF + NTIM=NTIM+1 + TIMES(NTIM)=XT(IP) + CALL LCMPUT(IPDEPL,'DEPL-TIMES',NTIM,2,TIMES) + ITIM=NTIM + ENDIF + WRITE(TEXT12,'(8HDEPL-DAT,I4.4)') ITIM + IF(IMPX.GT.0) WRITE(IUNOUT,530) XT(IP),XT(IP)/8.64E-4,TEXT12 + CALL LCMSIX(IPDEPL,TEXT12,1) + CALL LCMPUT(IPDEPL,'ISOTOPESDENS',NBISO,2,DEN) +*---- +* COMPUTE, NORMALIZE AND SAVE THE MICROSCOPIC REACTION RATES. +*---- + CALL EVOSIG(IMPX,INR,IGLOB,NGROUP,NBMIX,NBISO,NCOMB,ISONAM, + 1 IPISO,DEN,FLUMIX,VX,MILVO,JM,NVAR,NSUPS,NREAC,HREAC,IDR, + 2 RER,RRD,FIT,AWR,IZAE,FUELDN,NXSPER,DELTAT(1,IP),MIXPWR,PFACT, + 3 SIG(1,1,1,IP),VPHV(1,IP)) + NLENGT=(NVAR+1)*(NREAC+1)*NBMIX + CALL LCMPUT(IPDEPL,'MICRO-RATES',NLENGT,2,SIG(1,1,1,IP)) + CALL LCMPUT(IPDEPL,'INT-FLUX',NBMIX,2,VPHV(1,IP)) + VPHD=0.0 + DO 190 ICMB=1,NCOMB + IBM=MILVO(ICMB) + IF(IBM.GT.0) VPHD=VPHD+VPHV(IBM,IP) + 190 CONTINUE + VPH(IP)=VPHD + IF(INR.NE.0) THEN + FNORM=VPH(IP)/REAL(VPHINI) + IF(INR.EQ.3) CALL LCMPUT(IPDEPL,'FORM-POWER',1,2,PFACT) + ELSE + FNORM=0.0 + ENDIF + CALL LCMPUT(IPDEPL,'FLUX-NORM',1,2,FNORM) + IF((INDREC.EQ.1).AND.(IP.EQ.1)) THEN + BRNWIR(1)=0.0 + BRNWIR(2)=0.0 + CALL LCMPUT(IPDEPL,'BURNUP-IRRAD',2,2,BRNWIR) + ENDIF + CALL LCMSIX(IPDEPL,' ',2) + 200 CONTINUE + ELSE IF(ISAVE.EQ.1) THEN + IP=1 + ITIM=0 + IF(NTIM.GT.0) THEN + DO 210 I=1,NTIM + IF(ABS(TIMES(I)-XTI).LE.1.0E-4*XTI) ITIM=I + 210 CONTINUE + ENDIF + IF(ITIM.EQ.0) THEN + IF(NTIM.GT.0) THEN + IF(XTI.LT.TIMES(NTIM)) CALL XABORT('EVODRV: INVALID X1.') + ENDIF + NTIM=NTIM+1 + TIMES(NTIM)=XTI + CALL LCMPUT(IPDEPL,'DEPL-TIMES',NTIM,2,TIMES) + ITIM=NTIM + ENDIF + WRITE(TEXT12,'(8HDEPL-DAT,I4.4)') ITIM + IF(IMPX.GT.0) WRITE(IUNOUT,530) XTI,XTI/8.64E-4,TEXT12 + CALL LCMSIX(IPDEPL,TEXT12,1) + CALL LCMPUT(IPDEPL,'ISOTOPESDENS',NBISO,2,DEN) +*---- +* COMPUTE, NORMALIZE AND SAVE THE MICROSCOPIC REACTION RATES. +*---- + CALL EVOSIG(IMPX,INR,IGLOB,NGROUP,NBMIX,NBISO,NCOMB,ISONAM, + 1 IPISO,DEN,FLUMIX,VX,MILVO,JM,NVAR,NSUPS,NREAC,HREAC,IDR, + 2 RER,RRD,FIT,AWR,IZAE,FUELDN,NXSPER,DELTAT(1,IP),MIXPWR,PFACT, + 3 SIG(1,1,1,IP),VPHV(1,IP)) + NLENGT=(NVAR+1)*(NREAC+1)*NBMIX + CALL LCMPUT(IPDEPL,'MICRO-RATES',NLENGT,2,SIG(1,1,1,IP)) + CALL LCMPUT(IPDEPL,'INT-FLUX',NBMIX,2,VPHV(1,IP)) + VPHD=0.0 + DO 220 ICMB=1,NCOMB + IBM=MILVO(ICMB) + IF(IBM.GT.0) VPHD=VPHD+VPHV(IBM,IP) + 220 CONTINUE + VPH(IP)=VPHD + IF(INR.NE.0) THEN + FNORM=VPH(IP)/REAL(VPHINI) + IF(INR.EQ.3) CALL LCMPUT(IPDEPL,'FORM-POWER',1,2,PFACT) + ELSE + FNORM=0.0 + ENDIF + CALL LCMPUT(IPDEPL,'FLUX-NORM',1,2,FNORM) + IF((INDREC.EQ.1).AND.(IP.EQ.1)) THEN + BRNWIR(1)=0.0 + BRNWIR(2)=0.0 + CALL LCMPUT(IPDEPL,'BURNUP-IRRAD',2,2,BRNWIR) + ENDIF + CALL LCMSIX(IPDEPL,' ',2) + ENDIF +* + IF(IDEPL.EQ.1) THEN +*---- +* PERFORM A DEPLETION CALCULATION BETWEEN TIMES XT(1) AND XT(2). +*---- + IF(IMPX.GT.0) WRITE(IUNOUT,600) XT(1),XT(2) + LCOOL=.TRUE. + DO 300 IP=1,2 + ITIM=0 + DO 230 I=1,NTIM + IF(ABS(TIMES(I)-XT(IP)).LE.1.0E-4*XT(IP)) ITIM=I + 230 CONTINUE + IF(ITIM.GT.0) THEN + WRITE(TEXT12,'(8HDEPL-DAT,I4.4)') ITIM + IF(IMPX.GT.0) WRITE(IUNOUT,520) XT(IP),XT(IP)/8.64E-4,TEXT12 + CALL LCMSIX(IPDEPL,TEXT12,1) + CALL LCMGET(IPDEPL,'ISOTOPESDENS',DEN) + IF(IP.EQ.1) CALL LCMGET(IPDEPL,'BURNUP-IRRAD',BRNWIR) + CALL LCMLEN(IPDEPL,'MICRO-RATES',LENGT,ITYLCM) + IF((LENGT.GT.0).OR.(IP.EQ.1)) THEN + CALL LCMGET(IPDEPL,'MICRO-RATES',SIG(1,1,1,IP)) + CALL LCMGET(IPDEPL,'INT-FLUX',VPHV(1,IP)) + ENDIF + IF((IP.EQ.1).AND.(INR.EQ.3)) THEN + CALL LCMGET(IPDEPL,'FORM-POWER',PFACT) + ENDIF + CALL LCMSIX(IPDEPL,' ',2) + ELSE + IF(IP.EQ.1) CALL XABORT('EVODRV: NO DEPLETION DATA STORED.') + IF((IEXTR.GE.1).AND.(NTIM.GE.2).AND.(INR.NE.0)) THEN +* PERFORM MICRO REACTION RATE EXTRAPOLATION. + ITIM=0 + DO 240 I=1,NTIM + IF(ABS(TIMES(I)-XT(1)).LE.1.0E-4*XT(1)) ITIM=I + 240 CONTINUE + IF(ITIM.EQ.0) CALL XABORT('EVODRV: TABLE LOOKUP FAILURE.') + NLENGT=(NVAR+1)*(NREAC+1)*NBMIX + DO IEX=1,MIN(ITIM-IEXTR+1,IEXTR) + WRITE(TEXT12,'(8HDEPL-DAT,I4.4)') ITIM-IEX + CALL LCMSIX(IPDEPL,TEXT12,1) + CALL LCMLEN(IPDEPL,'MICRO-RATES',LENGT,ITYLCM) + IF(LENGT.NE.NLENGT) THEN + CALL XABORT('EVODRV: MICRO-RATES OVERFLOW.') + ENDIF + CALL LCMGET(IPDEPL,'MICRO-RATES',SIG(1,1,1,1-IEX)) + CALL LCMGET(IPDEPL,'INT-FLUX',VPHV(1,1-IEX)) + CALL LCMSIX(IPDEPL,' ',2) + ENDDO + N=0 + IF((IEXTR.GE.2).AND.(ITIM.GE.3)) THEN + ! parabolic extrapolation + N=3 + T(1)=TIMES(ITIM-2) + T(2)=TIMES(ITIM-1) + T(3)=TIMES(ITIM) + IF(T(1).GE.T(3)) CALL XABORT ('EVODRV: T(1).GE.T(3).') + IF(IMPX.GT.0) WRITE(IUNOUT,'(/21H EVODRV: PARABOLIC EX, + 1 51HTRAPOLAPOLATION OF MICRO REACTION RATES AT END-OF-S, + 2 5HTAGE.)') + ELSE IF((IEXTR.GE.1).AND.(ITIM.GE.2)) THEN + ! linear extrapolation + N=2 + T(1)=TIMES(ITIM-1) + T(2)=TIMES(ITIM) + IF(T(1).GE.T(2)) CALL XABORT ('EVODRV: T(1).GE.T(2).') + IF(IMPX.GT.0) WRITE(IUNOUT,'(/23H EVODRV: LINEAR EXTRAPO, + 1 51HLAPOLATION OF MICRO REACTION RATES AT END-OF-STAGE.)') + ELSE IF(ITIM.EQ.1) THEN + N=1 + T(1)=TIMES(ITIM) + IF(IMPX.GT.0) WRITE(IUNOUT,'(/21H EVODRV: NO EXTRAPOLA, + 1 49HPOLATION OF MICRO REACTION RATES AT END-OF-STAGE.)') + ENDIF + DPD=1.0D0 ! perform Lagrange extrapolation + DO I=1,N + DPD=(XT(2)-T(I))*DPD + ENDDO + VPHV(:NBMIX,2)=0.0 + SIG(:NVAR+1,:NREAC+1,:NBMIX,2)=0.0 + DO I=1,N + WEI=DPD/(XT(2)-T(I)) + DO J=1,N + IF(J.EQ.I) CYCLE + IF(T(I).EQ.T(J)) CALL XABORT('EVODRV: DIVIDE CHECK.') + WEI=WEI/(T(I)-T(J)) + ENDDO + DO IBM=1,NBMIX + VPHV(IBM,2)=VPHV(IBM,2)+REAL(WEI)*VPHV(IBM,I-N+1) + SIG(:NVAR+1,:NREAC+1,IBM,2)=SIG(:NVAR+1,:NREAC+1,IBM,2)+ + 1 REAL(WEI)*SIG(:NVAR+1,:NREAC+1,IBM,I-N+1) + ENDDO + ENDDO + ELSE + DO IBM=1,NBMIX + VPHV(IBM,2)=VPHV(IBM,1) + SIG(:NVAR+1,:NREAC+1,IBM,2)=SIG(:NVAR+1,:NREAC+1,IBM,1) + ENDDO + IF(IMPX.GT.0) WRITE(IUNOUT,'(/23H EVODRV: USE BEGINNING-, + 1 46HOF-STAGE MICRO REACTION RATES AT END-OF-STAGE.)') + ENDIF + ENDIF + VPHD=0.0 + DO 250 ICMB=1,NCOMB + IBM=MILVO(ICMB) + IF(IBM.GT.0) VPHD=VPHD+VPHV(IBM,IP) + 250 CONTINUE + VPH(IP)=VPHD +* + DO 270 ICMB=1,NCOMB + IBM=MILVO(ICMB) + IF(IBM.EQ.0) GO TO 270 + DO 260 IS=1,NVAR + IF(JM(IBM,IS).GT.0) THEN + YDPL(IS,IP,ICMB)=DEN(JM(IBM,IS)) + ELSE + YDPL(IS,IP,ICMB)=0.0 + ENDIF + 260 CONTINUE + 270 CONTINUE +* + IF(INR.NE.0) THEN +* CHECK FOR OUT-OF-CORE DEPLETION. + DO 290 IBM=1,NBMIX + DO 280 IU=1,NGROUP + LCOOL=LCOOL.AND.(FLUMIX(IU,IBM).EQ.0.) + 280 CONTINUE + 290 CONTINUE + ENDIF + 300 CONTINUE +* + IF(LCOOL.AND.(FIT.NE.0.0)) CALL XABORT('EVODRV: NEUTRON FLUX I' + 1 //'S ZERO. UNABLE TO NORMALIZE.') + IF(LCOOL.AND.(IMPX.GT.1)) THEN + WRITE (IUNOUT,'(/31H EVODRV: OUT-OF-CORE DEPLETION.)') + ELSE IF(IMPX.GT.1) THEN + WRITE (IUNOUT,'(/27H EVODRV: IN-CORE DEPLETION.)') + IF((FUELDN(3).GT.0.0).AND.(INR.EQ.3)) THEN + WRITE(IUNOUT,'(/31H EVODRV: FUEL POWER NORMALISATI, + 1 10HON FACTOR=,1P,E12.5,29H MW/TONNE. OUT-OF-FUEL POWER , + 2 12HFORM FACTOR=,E12.5)') FIT/FUELDN(3)/PFACT,PFACT + ENDIF + ENDIF + INR2=INR + IF(LCOOL) INR2=0 +*---- +* PERFORM THE DEPLETION CALCULATION +*---- + CALL EVOBLD(IMPX,INR2,IGLOB,NBMIX,NBISO,NCOMB,ISONAM,YDPL,VX, + 1 MILVO,JM,NVAR,NDFP,NSUPS,NREAC,NPAR,NFISS,XT,EPS1,EPS2,EXPMAX, + 2 H1,ITYPE,IDIRAC,FIT,DELTA,ENERG,KPAR,BPAR,YIELD,IDR,RER,RRD, + 3 AWR,FUELDN,SIG(1,1,1,1),VPH,VPHV(1,1),MIXPWR,VTOTD,IEVOLB, + 4 KFISS,KPF) +*---- +* SAVE THE INITIAL SATURATED NUMBER DENSITIES IN THE DEPLETION TABLE +*---- + IF((ISAVE.GE.0).AND.(ISAT.EQ.1)) THEN + DO 315 ICMB=1,NCOMB + IBM=MILVO(ICMB) + IF(IBM.EQ.0) GO TO 315 + DO 310 IS=1,NVAR + IF(JM(IBM,IS).GT.0) DEN(JM(IBM,IS))=YDPL(IS,1,ICMB) + 310 CONTINUE + 315 CONTINUE + ITIM=0 + DO 320 I=1,NTIM + IF(ABS(TIMES(I)-XT(1)).LE.1.0E-4*XT(1)) ITIM=I + 320 CONTINUE + IF(ITIM.EQ.0) CALL XABORT('EVODRV: MISSING TIME ENTRY.') + WRITE(TEXT12,'(8HDEPL-DAT,I4.4)') ITIM + IF(IMPX.GT.0) WRITE(IUNOUT,530) XT(1),XT(1)/8.64E-4,TEXT12 + CALL LCMSIX(IPDEPL,TEXT12,1) + CALL LCMPUT(IPDEPL,'ISOTOPESDENS',NBISO,2,DEN) + CALL LCMSIX(IPDEPL,' ',2) + ENDIF +*---- +* SAVE THE DEPLETION CALCULATION RESULT IN THE DEPLETION TABLE +*---- + DO 335 ICMB=1,NCOMB + IBM=MILVO(ICMB) + IF(IBM.EQ.0) GO TO 335 + DO 330 IS=1,NVAR + IF(JM(IBM,IS).GT.0) DEN(JM(IBM,IS))=YDPL(IS,2,ICMB) + 330 CONTINUE + 335 CONTINUE + ITIM=0 + DO 340 I=1,NTIM + IF(ABS(TIMES(I)-XT(2)).LE.1.0E-4*XT(2)) ITIM=I + 340 CONTINUE + IF(ITIM.EQ.0) THEN + IF(XT(2).LT.TIMES(NTIM)) CALL XABORT('EVODRV: INVALID X2') + NTIM=NTIM+1 + TIMES(NTIM)=XT(2) + CALL LCMPUT(IPDEPL,'DEPL-TIMES',NTIM,2,TIMES) + ITIM=NTIM + ENDIF + WRITE(TEXT12,'(8HDEPL-DAT,I4.4)') ITIM + IF(IMPX.GT.0) WRITE(IUNOUT,530) XT(2),XT(2)/8.64E-4,TEXT12 + CALL LCMSIX(IPDEPL,TEXT12,1) + CALL LCMPUT(IPDEPL,'ISOTOPESDENS',NBISO,2,DEN) + NLENGT=(NVAR+1)*(NREAC+1)*NBMIX + CALL LCMPUT(IPDEPL,'MICRO-RATES',NLENGT,2,SIG(1,1,1,2)) + CALL LCMPUT(IPDEPL,'INT-FLUX',NBMIX,2,VPHV(1,2)) + CALL LCMPUT(IPDEPL,'ENERG-MIX',NBMIX,2,ENERG) +* We use DELTA(3) instead of DELTA(1) in order to avoid different +* base points in multi-D tables. + BRNWIR(1)=BRNWIR(1)+DELTA(3)/8.64E-4 + BRNWIR(2)=BRNWIR(2)+DELTA(2) + CALL LCMPUT(IPDEPL,'BURNUP-IRRAD',2,2,BRNWIR) + IF(IMPX.GE.1) WRITE(IUNOUT,580) XT(2)/8.64E-4, + > BRNWIR(1),BRNWIR(2) + CALL LCMSIX(IPDEPL,' ',2) + ENDIF +*---- +* RELEASE THE ALLOCATED MEMORY +*---- + DEALLOCATE(IDR,HREAC,KPAR) + DEALLOCATE(RRD,RER,YIELD,BPAR) + DEALLOCATE(KPF,KFISS) +*---- +* USE THE RESULT OF A DEPLETION CALCULATION IN THE FOLLOWING RUN +*---- + IF(ISET.GE.0) THEN + ITIM=0 + DO 350 I=1,NTIM + IF(ABS(TIMES(I)-XTF).LE.1.0E-4*XTF) ITIM=I + 350 CONTINUE + IF(ITIM.EQ.0) CALL XABORT('EVODRV: NO DEPLETION DATA STORED.') + WRITE(TEXT12,'(8HDEPL-DAT,I4.4)') ITIM + IF(IMPX.GT.0) WRITE(IUNOUT,520) XTF,XTF/8.64E-4,TEXT12 + CALL LCMSIX(IPDEPL,TEXT12,1) + CALL LCMGET(IPDEPL,'ISOTOPESDENS',DEN) + CALL LCMGET(IPDEPL,'BURNUP-IRRAD',BRNWIR) + CALL LCMSIX(IPDEPL,' ',2) + IF(IMPX.GT.1) THEN + WRITE(IUNOUT,550) XTF,XTF/8.64E-4 + DO 370 ICMB=1,NCOMB + IMIXC=MILVO(ICMB) + IF(IMIXC.EQ.0) GO TO 370 + NISOCC=0 + DO 360 ISOT=1,NBISO + IMIXI=MIX(ISOT) + IF(IMIXI.EQ.IMIXC) THEN + NISOCC=NISOCC+1 + ISOCMB(NISOCC)=ISOT + ENDIF + 360 CONTINUE + WRITE(IUNOUT,560) IMIXC + WRITE(IUNOUT,570) ((ISONAM(I0,ISOCMB(I)),I0=1,2), + 1 DEN(ISOCMB(I)),I=1,NISOCC) + 370 CONTINUE + ENDIF + ENDIF +*---- +* RECOVER THE BURNUP AND SAVE IT IN A CLE-2000 VARIABLE +*---- + IF(IPICK.EQ.1) THEN + ITIM=0 + DO 375 I=1,NTIM + IF(ABS(TIMES(I)-XTF).LE.1.0E-4*XTF) ITIM=I + 375 CONTINUE + IF(ITIM.EQ.0) CALL XABORT('EVODRV: NO DEPLETION DATA STORED.') + WRITE(TEXT12,'(8HDEPL-DAT,I4.4)') ITIM + IF(IMPX.GT.0) WRITE(IUNOUT,520) XTF,XTF/8.64E-4,TEXT12 + CALL LCMSIX(IPDEPL,TEXT12,1) + CALL LCMGET(IPDEPL,'BURNUP-IRRAD',BRNWIR) + CALL LCMSIX(IPDEPL,' ',2) + CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT12,DBLLIR) + IF(ITYPLU.NE.-2) CALL XABORT('EVODRV: OUTPUT REAL EXPECTED.') + ITYPLU=2 + REALIR=BRNWIR(1) + IF(IMPX.GT.2) WRITE(IUNOUT,540) REALIR + CALL REDPUT(ITYPLU,INTLIR,REALIR,TEXT12,DBLLIR) + CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT12,DBLLIR) + IF((ITYPLU.NE.3).OR.(TEXT12.NE.';')) THEN + CALL XABORT('EVODRV: ; CHARACTER EXPECTED.') + ENDIF + ENDIF +* + IF((IDEPL.EQ.1).OR.(ISET.EQ.1).AND.LMACRO) THEN +* COMPUTE THE NEW DEPLETED MACROSCOPIC CROSS SECTIONS. + MASKL(:NGROUP)=.TRUE. + MASK(:NBMIX)=.FALSE. + DO 380 ICOMB=1,NCOMB + IBM=MILVO(ICOMB) + IF(IBM.GT.0) MASK(IBM)=.TRUE. + 380 CONTINUE +* + ITSTMP=2 + TMPDAY(1)=XT(2)/8.64E-4 + TMPDAY(2)=BRNWIR(1) + TMPDAY(3)=BRNWIR(2) + CALL LIBMIX(IPLIB,NBMIX,NGROUP,NBISO,ISONAM,MIX,DEN,MASK,MASKL, + 1 ITSTMP,TMPDAY) + ENDIF +*---- +* STORE THE GENERAL DEPLETION RELATED PARAMETERS +*---- + CALL LCMPUT(IPDEPL,'VOLUME-MIX',NBMIX,2,VX) + CALL LCMPUT(IPDEPL,'DEPLETE-MIX',NVAR*NBMIX,1,JM) + CALL LCMPUT(IPDEPL,'MIXTURESBurn',NBMIX,1,MIXBRN) + CALL LCMPUT(IPDEPL,'MIXTURESPowr',NBMIX,1,MIXPWR) + IPAR(:NSTATE)=0 + IPAR(1)=ITYPE + IPAR(2)=INR + IPAR(3)=NTIM + IPAR(4)=NBISO + IPAR(5)=NCOMB + IPAR(6)=NREAC + IPAR(7)=NVAR + IPAR(8)=NBMIX + IPAR(9)=IEXTR + IPAR(10)=IGLOB + IPAR(11)=ISAT + IPAR(12)=IDIRAC + IPAR(13)=ITIXS + IPAR(14)=IFLMAC + IPAR(15)=IYLMIX + CALL LCMPUT(IPDEPL,'STATE-VECTOR',NSTATE,1,IPAR) + RPAR(1)=EPS1 + RPAR(2)=EPS2 + RPAR(3)=EXPMAX + RPAR(4)=H1 + RPAR(5)=FIT + CALL LCMPUT(IPDEPL,'EVOLUTION-R',5,2,RPAR) + IF((IMPX.GT.1).OR.((IMPX.GT.0).AND.(INDREC.EQ.1))) THEN + WRITE(IUNOUT,590) IMPX,ITYPE,INR,NTIM,NBISO,NCOMB,NREAC, + 1 NVAR,NBMIX,IEXTR + WRITE(IUNOUT,595) IGLOB,ISAT,IDIRAC,ITIXS,IFLMAC,IYLMIX + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(TIMES) + DEALLOCATE(IPISO) + DEALLOCATE(MASKL,MASK) + DEALLOCATE(YDPL,IZAE,AWR,ENERG,VPHV,SIG) + DEALLOCATE(IEVOLB,INADPL,ISOCMB,MILVO,JM) + RETURN +* + 500 FORMAT(/36H EVODRV: NUMBER OF FISSILE ISOTOPES=,I4/9X,8HNUMBER O, + 1 19HF FISSION PRODUCTS=,I4) + 510 FORMAT(/24H EVODRV: UNABLE TO FIND ,A15,6H INDEX,I5,6H AMONG,10I5 + 1 /(56X,10I5)) + 520 FORMAT(/44H EVODRV: RECOVER INFORMATION RELATED TO TIME,1P,E12.4, + 1 8H E+8 S (,E12.4,32H DAY) FROM LCM DIRECTORY NAMED ',A12,2H'.) + 530 FORMAT(/41H EVODRV: SAVE INFORMATION RELATED TO TIME,1P,E12.4, + 1 8H E+8 S (,E12.4,30H DAY) ON LCM DIRECTORY NAMED ',A12,2H'.) + 540 FORMAT(/21H EVODRV: PICK BURNUP=,1P,E12.4,10H MWd/tonne) + 550 FORMAT(/' EVODRV: NUMBER DENSITIES PER ISOTOPE AT TIME',1P, + 1 E12.4,' E+8 S (',E12.4,' DAY)') + 560 FORMAT(/' ISOTOPIC DENSITIES AFTER BURNUP FOR MIXTURE = ',I5, + 1 22H (10**24 PARTICLES/CC)) + 570 FORMAT(1P,5(4X,2A4,':',E12.4)) + 580 FORMAT(' -> FINAL BURNUP AT TIME = ',1P,E14.6,' DAYS'/ + > ' FUEL BURNUP = ',E14.6,' MW*D/TONNE'/ + > ' NEUTRON EXPOSURE = ',E14.6,' N/KB') + 590 FORMAT(/8H OPTIONS/8H -------/ + 1 7H IMPX ,I8,30H (0=NO PRINT/1=SHORT/2=MORE)/ + 2 7H ITYPE ,I8,31H (1=CASH-KARP/2=KAPS-RENTROP)/ + 3 7H INR ,I8,47H (0=OUT-OF-CORE/1=CONSTANT FLUX/2=CONSTANT PO, + 4 4HWER)/ + 5 7H NTIM ,I8,35H (NUMBER OF DEPLETION SET POINTS)/ + 6 7H NBISO ,I8,29H (TOTAL NUMBER OF ISOTOPES)/ + 7 7H NCOMB ,I8,33H (NUMBER OF DEPLETING MIXTURES)/ + 8 7H NREAC ,I8,34H (NUMBER OF DEPLETING REACTIONS)/ + 9 7H NVAR ,I8,33H (NUMBER OF DEPLETING ISOTOPES)/ + 1 7H NBMIX ,I8,23H (NUMBER OF MIXTURES)/ + 2 7H IEXTR ,I8,47H (FLUX EXTRAPOLATION: 0=NONE/1=LINEAR/2=PARAB, + 3 5HOLIC)) + 595 FORMAT( + 1 7H IGLOB ,I8,47H (-1=SERPENT EDEPMODE-0 FORMULA/0=COMPUTE BUR, + 2 44HNUP IN FUEL/1=COMPUTE BURNUP IN GLOBAL CELL)/ + 3 7H ISAT ,I8,47H (0/1=DO NOT/DO SAVE SATURATED INITIAL NUMBER, + 4 11H DENSITIES)/ + 5 7H IDIRAC,I8,47H (0/1=DO NOT/DO USE DIRAC FUNCTION CONTRIBUTI, + 6 34HONS IN SATURATED NUMBER DENSITIES)/ + 7 7H ITIXS ,I8,38H (0/1=TIME-DEPENDENT XS FLAG ON/OFF)/ + 8 7H IFLMAC,I8,47H (0/1/2=RECOVER FLUX FROM L_FLUX/L_MACROLIB/L, + 9 7H_POWER)/ + 1 7H IYLMIX,I8,47H (0/1=RECOVER FISSION YIELD DATA FROM DEPL-CH, + 2 16HAIN/PYIELD DATA)) + 600 FORMAT(/54H EVODRV: SOLUTION OF A DEPLETION SYSTEM BETWEEN TIMES , + 1 1P,E12.4,4H AND,E12.4,6H E+8 S) + 610 FORMAT(/' EVODRV: FUEL INITIAL DENSITY = ',1P,E14.6,' G/CC'/ + > ' FUEL TOTAL VOLUME = ',E14.6,' CC'/ + > ' FUEL INITIAL MASS = ',E14.6,' G'/ + > ' FUEL INITIAL MASS/CELL VOL = ',E14.6,' G/CC') + END diff --git a/Dragon/src/EVOGET.f b/Dragon/src/EVOGET.f new file mode 100644 index 0000000..dcb7004 --- /dev/null +++ b/Dragon/src/EVOGET.f @@ -0,0 +1,401 @@ +*DECK EVOGET + SUBROUTINE EVOGET(IPRINT,ITYPE ,ITIXS ,IEXTR ,IGLOB ,ISAT , + > IDIRAC,ISAVE ,ISET ,INR ,IDEPL ,IFLMAC, + > IYLMIX,RPAR ,XT ,NBMIX ,IPICK ,MIXBRN, + > MIXPWR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read burnup input options. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input/output +* IPRINT print flag. +* ITYPE solution method: +* ITYPE=1 for fifth order Cash-Karp algorithm; +* ITYPE=2 for fourth order Kaps-Renthrop algorithm. +* ITIXS flag for time dependent xs: +* ITIXS= 0 for flag ON; +* ITIXS= 1 for flag OFF. +* IEXTR flag for power normalization: +* IEXTR= 0 no extrapolation; +* IEXTR= 1 linear extrapolation; +* IEXTR= 2 parabolic extrapolation. +* IGLOB flag for out-of-fuel power in flux normalization. +* GLOB=-1: using the Serpent mode 0 emperical formula; +* GLOB= 0: using the power released in the fuel; +* GLOB= 1: using the power released in the global geometry. +* ISAT flag for saturaton: +* ISAT= 0 for flag OFF; +* ISAT= 1 for flag ON. +* IDIRAC flag for delta Dirac saturation: +* IDIRAC= 0 for flag OFF; +* IDIRAC= 1 for flag ON. +* ISAVE flag for SAVE: +* ISAVE=-1 for no SAVE. +* ISAVE= 0 for automatic SAVE. +* ISAVE= 1 for manual SAVE. +* ISET flag for SET: +* ISET= 0 for automatic SET; +* ISET= 1 for manual SET. +* INR burnup option: +* INR= 0 for out-of-core depletion; +* INR= 1 for constant flux depletion; +* INR= 2 for constant power per kg; +* INR= 2 for constant power per volume (cc). +* IFLMAC flag to recover neutron flux: +* IFLMAC= 0 recover from L_FLUX object; +* IFLMAC= 1 recover from embedded macrolib +* in L_LIBRARY object; +* IFLMAC= 2 recover from 'FLUX-BUND' record +* in L_POWER object. +* IYLMIX flag to recover fission yield data: +* IYLMIX= 0 recover from DEPL-CHAIN data; +* IYLMIX= 1 recover from isotopic PYIELD data. +* IDEPL flag for depletion: +* IDEPL= 0 for no depletion; +* IDEPL= 1 for depletion. +* RPAR burnup parameters: +* RPAR(1) = EPS1 accuracy of ODE solver; +* RPAR(2) = EPS2 accuracy for constant +* power iteration; +* RPAR(3) = EXPMAX isotope saturation flag; +* RPAR(4) = H1 guessed first time step; +* RPAR(5) = FIT flux (N/CM**2/S) OR +* power (kW/kG INITIAL HEAVY) +* W/CC (W/CC) +* normalization factor. +* XT time control table: +* XT(1) = initial time for depletion; +* XT(2) = final time for depletion; +* XT(3) = time for save; +* XT(4) = time for last set; +* XT(5) = time for current set. +* NBMIX number of mixtures. +* IPICK flag for burnup value recovery in a CLE-2000 variable: +* IPICK= 0 for no recovery; +* IPICK= 1 for recovery. +* MIXBRN flags for mixtures to burn. +* MIXPWR flags for mixtures to include in power normalization. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IPRINT,ITYPE,ITIXS,IEXTR,IGLOB,ISAT, + > IDIRAC,ISAVE,ISET,INR,IDEPL,IFLMAC,IYLMIX,NBMIX, + > IPICK,MIXBRN(NBMIX),MIXPWR(NBMIX) + REAL RPAR(5),XT(5) +*---- +* LOCAL VARIABLES +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + REAL CSEC,CDAY,CYEAR + PARAMETER (IOUT=6,CSEC=1.0E-8,CDAY=8.64E-4, + > CYEAR=3.1536E-1,NAMSBR='EVOGET') +*---- +* INPUT FILE PARAMETERS +*---- + CHARACTER CARLIR*12 + INTEGER ITYPLU,INTLIR + REAL REALIR + DOUBLE PRECISION DBLLIR +*---- +* LOCAL PARAMETERS +*---- + INTEGER IRDT,KMIXB,KMIXP,IMIX +*---- +* READ THE BURNUP INPUT DATA. +*---- + ISAVE=0 + ISET=0 + KMIXB=0 + KMIXP=0 + 100 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + 101 CONTINUE + IF(ITYPLU .EQ. 10) GO TO 105 + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + >': CHARACTER KEYWORD EXPECTED.') + IF(CARLIR(1:4) .EQ. ';') THEN + IPICK=0 + GO TO 105 + ELSE IF(CARLIR(1:4) .EQ. 'PICK') THEN + IPICK=1 + GO TO 105 + ELSE IF(CARLIR(1:4) .EQ. 'EDIT') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': INTEGER IPRINT EXPECTED') + IPRINT=INTLIR + ELSE IF(CARLIR(1:4) .EQ. 'EPS1') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': REAL EPS1 EXPECTED') + RPAR(1)=REALIR + ELSE IF(CARLIR(1:4) .EQ. 'EPS2') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': REAL EPS2 EXPECTED') + RPAR(2)=REALIR + ELSE IF(CARLIR(1:4) .EQ. 'EXPM') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': REAL EXPM EXPECTED') + RPAR(3)=REALIR + ELSE IF(CARLIR(1:6) .EQ. 'SATOFF') THEN + RPAR(3)=0.0 + ELSE IF(CARLIR(1:9) .EQ. 'FLUX_FLUX') THEN + IFLMAC=0 + ELSE IF(CARLIR(1:8) .EQ. 'FLUX_MAC') THEN + IFLMAC=1 + ELSE IF(CARLIR(1:8) .EQ. 'FLUX_POW') THEN + IFLMAC=2 + ELSE IF(CARLIR(1:8) .EQ. 'CHAIN') THEN + IYLMIX=0 + ELSE IF(CARLIR(1:8) .EQ. 'PIFI') THEN + IYLMIX=1 + ELSE IF(CARLIR(1:4) .EQ. 'H1') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > 'REAL H1 EXPECTED') + RPAR(4)=REALIR + ELSE IF(CARLIR(1:4) .EQ. 'RUNG') THEN + ITYPE=1 + ELSE IF(CARLIR(1:4) .EQ. 'KAPS') THEN + ITYPE=2 + ELSE IF(CARLIR(1:4) .EQ. 'NOEX') THEN + IEXTR=0 + ELSE IF(CARLIR(1:4) .EQ. 'EXTR') THEN + IEXTR=1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) GO TO 101 + IEXTR=INTLIR + IF((IEXTR.NE.1).AND.(IEXTR.NE.2)) THEN + CALL XABORT('EVOGET: INVALID EXTR INDEX.') + ENDIF + ELSE IF(CARLIR(1:4) .EQ. 'EDP0') THEN + IGLOB=-1 + ELSE IF(CARLIR(1:4) .EQ. 'NOGL') THEN + IGLOB=0 + ELSE IF(CARLIR(1:4) .EQ. 'GLOB') THEN + IGLOB=1 + ELSE IF(CARLIR(1:4) .EQ. 'NSAT') THEN + ISAT=0 + ELSE IF(CARLIR(1:4) .EQ. 'SAT ') THEN + ISAT=1 + ELSE IF(CARLIR(1:4) .EQ. 'NODI') THEN + IDIRAC=0 + ELSE IF(CARLIR(1:4) .EQ. 'DIRA') THEN + IDIRAC=1 + ELSE IF(CARLIR(1:4) .EQ. 'TIXS') THEN + ITIXS=1 + ELSE IF(CARLIR(1:4) .EQ. 'TDXS') THEN + ITIXS=0 + ELSE IF(CARLIR(1:4) .EQ. 'MIXB') THEN + KMIXB=1 + MIXBRN(:NBMIX)=0 + DO IMIX=1,NBMIX + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) GO TO 101 + IF(INTLIR .GE. 1 .AND. INTLIR .LE. NBMIX) THEN + MIXBRN(INTLIR)=1 + ENDIF + ENDDO + ELSE IF(CARLIR(1:4) .EQ. 'MIXP') THEN + KMIXP=1 + MIXPWR(:NBMIX)=0 + DO IMIX=1,NBMIX + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) GO TO 101 + IF(INTLIR .GE. 1 .AND. INTLIR .LE. NBMIX) THEN + MIXPWR(INTLIR)=1 + ENDIF + ENDDO + ELSE IF(CARLIR(1:4) .EQ. 'NOSA') THEN + ISAVE=-1 + ELSE IF(CARLIR(1:4) .EQ. 'SAVE') THEN + ISAVE=1 +* SAVE THE LAST FLUX CALCULATION IN THE DEPLETION TABLE. + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': SAVE TIME EXPECTED') + XT(3)=REALIR + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + > ': TIME UNITS EXPECTED') + IF(CARLIR(1:4) .EQ. 'S') THEN + XT(3)=XT(3)*CSEC + ELSE IF(CARLIR(1:4) .EQ. 'DAY') THEN + XT(3)=XT(3)*CDAY + ELSE IF(CARLIR(1:4) .EQ. 'YEAR') THEN + XT(3)=XT(3)*CYEAR + ELSE + CALL XABORT(NAMSBR//': INVALID TIME UNITS') + ENDIF + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + > ': SAVE NORMALIZATION EXPECTED') + IF(CARLIR(1:4) .EQ. 'FLUX') THEN + INR=1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': BURNUP FLUX LEVEL EXPECTED') + RPAR(5)=REALIR + IF(RPAR(5) .EQ. 0.0) THEN + INR=0 + ENDIF + ELSE IF(CARLIR(1:4) .EQ. 'POWR') THEN + INR=2 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': BURNUP POWER EXPECTED') + RPAR(5)=REALIR + IF(RPAR(5) .EQ. 0.0) THEN + INR=0 + ENDIF + ELSE IF(CARLIR(1:4) .EQ. 'W/CC') THEN + INR=3 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': BURNUP POWER EXPECTED') + RPAR(5)=REALIR + IF(RPAR(5) .EQ. 0.0) THEN + INR=0 + ENDIF + ELSE IF(CARLIR(1:4) .EQ. 'KEEP') THEN + INR=4 + ELSE + GO TO 101 + ENDIF + ELSE IF(CARLIR(1:4) .EQ. 'DEPL') THEN + IDEPL=1 + IRDT=2 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': INITIAL OR INCREMENTAL DEPLETE TIME EXPECTED') + XT(1)=REALIR + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .EQ. 1) THEN + CALL XABORT(NAMSBR//': UNITS OR FINAL TIME EXPECTED') + ELSE IF(ITYPLU .EQ. 2) THEN + XT(2)=REALIR + IRDT=1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + ENDIF + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + > ': TIME UNITS EXPECTED') + IF(CARLIR(1:4) .EQ. 'S') THEN + XT(1)=XT(1)*CSEC + XT(2)=XT(2)*CSEC + ELSE IF(CARLIR(1:4) .EQ. 'DAY') THEN + XT(1)=XT(1)*CDAY + XT(2)=XT(2)*CDAY + ELSE IF(CARLIR(1:4) .EQ. 'YEAR') THEN + XT(1)=XT(1)*CYEAR + XT(2)=XT(2)*CYEAR + ELSE + CALL XABORT(NAMSBR//': INVALID TIME UNITS') + ENDIF + IF(IRDT .EQ. 2) THEN + XT(2)=XT(4)+XT(1) + XT(1)=XT(4) + ENDIF + IF(XT(2) .LE. XT(1)) CALL XABORT(NAMSBR// + > ': FINAL TIME IS LESS OR EQUAL TO THE INITIAL TIME.') + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + > ': DEPLETION NORMALIZATION LEVEL EXPECTED') + IF(CARLIR(1:4) .EQ. 'COOL') THEN + INR=0 + RPAR(5)=0.0 + ELSE IF(CARLIR(1:4) .EQ. 'FLUX') THEN + INR=1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': FLUX LEVEL EXPECTED') + RPAR(5)=REALIR + IF(RPAR(5) .EQ. 0.0) THEN + INR=0 + ENDIF + ELSE IF(CARLIR(1:4) .EQ. 'POWR') THEN + INR=2 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': POWER LEVEL EXPECTED') + RPAR(5)=REALIR + IF(RPAR(5) .EQ. 0.0) THEN + INR=0 + ENDIF + ELSE IF(CARLIR(1:4) .EQ. 'W/CC') THEN + INR=3 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': POWER LEVEL EXPECTED') + RPAR(5)=REALIR + IF(RPAR(5) .EQ. 0.0) THEN + INR=0 + ENDIF + ELSE IF(CARLIR(1:4) .EQ. 'KEEP') THEN + INR=4 + ELSE + GO TO 101 + ENDIF + ELSE IF(CARLIR(1:4) .EQ. 'SET') THEN + ISET=1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': SET TIME EXPECTED') + XT(5)=REALIR + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + > ': TIME UNITS EXPECTED') + IF(CARLIR(1:4) .EQ. 'S') THEN + XT(5)=XT(5)*CSEC + ELSE IF(CARLIR(1:4) .EQ. 'DAY') THEN + XT(5)=XT(5)*CDAY + ELSE IF(CARLIR(1:4) .EQ. 'YEAR') THEN + XT(5)=XT(5)*CYEAR + ELSE + CALL XABORT(NAMSBR//': INVALID TIME UNITS') + ENDIF + ELSE + CALL XABORT(NAMSBR//': '//CARLIR//' IS AN INVALID KEYWORD') + ENDIF + GO TO 100 +*---- +* INPUT DATA READ COMPLETE +*---- + 105 CONTINUE + IF((ISET .EQ. 0) .AND. (IDEPL .EQ. 0)) ISET=-1 + XT(4)=0.0 + IF(ISAVE .EQ. -1) THEN + XT(4)=-1.0 + ELSE IF(ISAVE .EQ. 0) THEN + XT(3)=XT(1) + ENDIF + IF(ISET .EQ. 0) THEN + XT(5)=XT(2) + ENDIF + IF(KMIXB .EQ. 1) THEN + IF(KMIXP .EQ. 0) THEN + DO IMIX=1,NBMIX + MIXPWR(IMIX)=MIXBRN(IMIX) + ENDDO + ENDIF + ENDIF + RETURN + END diff --git a/Dragon/src/EVOKAP.f b/Dragon/src/EVOKAP.f new file mode 100644 index 0000000..a280232 --- /dev/null +++ b/Dragon/src/EVOKAP.f @@ -0,0 +1,224 @@ +*DECK EVOKAP + SUBROUTINE EVOKAP(Y,N,X,HTRY,EPS,YSCAL,HDID,HNEXT,MU1,IMA,MAXA, + 1 NSUPF,NFISS,KFISS,YSF,ADPL,BDPL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Fourth-order Kaps-Rentrop step for integrating stiff O.D.E.'s, with +* monitoring of local truncation error to adjust stepsize. +* Special version for isotopic depletion calculations. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* Y dependent variable vector. +* N size of the dependent variable vector. +* X independent variable. +* HTRY stepsize to be attempted. +* EPS required accuracy. +* YSCAL vector against which the error is scaled. +* HDID stepsize that was actually accomplished. +* HNEXT estimated next stepsize. +* MU1 position of each diagonal element in vectors ADPL and ASS. +* IMA position of the first non-zero column element in vectors +* ADPL and ASS. +* MAXA first dimension of matrix ADPL. +* NSUPF number of depleting fission products. +* NFISS number of fissile isotopes producing fission products. +* KFISS position in chain of the fissile isotopes. +* YSF components of the product of the fission yields and fission +* rates. +* ADPL depletion matrix components. +* BDPL depletion source components. +* +*Reference: +* W.H. Press and S.A. Teukolsky, 'Integrating stiff ordinary differen- +* tial equations', Computers in physics, 3 (3), 88 (May/June 1989). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,MU1(N),IMA(N),MAXA,NSUPF,NFISS,KFISS(NFISS) + REAL Y(N),X,HTRY,EPS,YSCAL(N),HDID,HNEXT,YSF(NFISS,NSUPF,2), + 1 ADPL(MAXA,2),BDPL(N,2) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MAXTRY=40,SAFETY=0.85,GROW=1.5,PGROW=-.25,SHRNK=0.5, + 1 PSHRNK=-1./3.) + PARAMETER (GAM=.231,GAM21=-.270629667752/GAM, + 1 GAM31=.311254483294/GAM,GAM32=.852445628482E-2/GAM, + 2 GAM41=.282816832044/GAM,GAM42=-.457959483281/GAM, + 3 GAM43=-.111208333333/GAM,ALF21=.462,ALF31=-.815668168327E-1, + 4 ALF32=.961775150166,C1=.217487371653,C2=.486229037990,C3=0., + 5 C4=.296283590357,CC1=-.717088504499,CC2=1.77617912176, + 6 CC3=-.590906172617E-1,GAM2X=GAM*(1.+GAM21), + 7 GAM3X=GAM*(1.+GAM31+GAM32),GAM4X=GAM*(1.+GAM41+GAM42+GAM43)) + CHARACTER HSMG*131 + REAL, ALLOCATABLE, DIMENSION(:) :: DYDX,TEMP,YSAV,DYSAV,DFDX,ASS + REAL, ALLOCATABLE, DIMENSION(:,:) :: AK +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(DYDX(N),TEMP(N),YSAV(N),DYSAV(N),DFDX(N),AK(N,4), + 1 ASS(IMA(N))) +* + XSAV=X + NSUPL=N-NSUPF + CALL ALLUM(N,ADPL(1,1),Y(1),DYDX(1),MU1,IMA,1) + CALL ALLUM(N,ADPL(1,2),Y(1),TEMP(1),MU1,IMA,1) + DO 15 I=1,NSUPF + DO 10 J=1,NFISS + DYDX(NSUPL+I)=DYDX(NSUPL+I)+YSF(J,I,1)*Y(KFISS(J)) + TEMP(NSUPL+I)=TEMP(NSUPL+I)+YSF(J,I,2)*Y(KFISS(J)) + 10 CONTINUE + 15 CONTINUE + DO 20 I=1,N + DYDX(I)=DYDX(I)+X*TEMP(I)+BDPL(I,1)+X*BDPL(I,2) + YSAV(I)=Y(I) + DYSAV(I)=DYDX(I) + 20 CONTINUE + H=HTRY + DO 200 JTRY=1,MAXTRY + HSQ=H*H + CALL ALLUM(N,ADPL(1,2),YSAV(1),DFDX(1),MU1,IMA,1) + DO 35 I=1,NSUPF + DO 30 J=1,NFISS + DFDX(NSUPL+I)=DFDX(NSUPL+I)+YSF(J,I,2)*YSAV(KFISS(J)) + 30 CONTINUE + 35 CONTINUE + DO 40 I=1,IMA(N) + ASS(I)=-H*GAM*(ADPL(I,1)+XSAV*ADPL(I,2)) + 40 CONTINUE + DO 50 I=1,N + DFDX(I)=DFDX(I)+BDPL(I,2) + ASS(MU1(I))=1.+ASS(MU1(I)) + 50 CONTINUE + CALL ALLUF(N,ASS,MU1,IMA) + DO 60 I=1,N + AK(I,1)=H*DYSAV(I)+HSQ*GAM*DFDX(I) + 60 CONTINUE + CALL ALLUS(NSUPL,MU1(1),IMA(1),ASS(1),AK(1,1)) + IF(NSUPF.GT.0) THEN + DO 75 I=1,NSUPF + DO 70 J=1,NFISS + AK(NSUPL+I,1)=AK(NSUPL+I,1)+H*GAM*(YSF(J,I,1)+XSAV*YSF(J,I,2)) + 1 *AK(KFISS(J),1) + 70 CONTINUE + 75 CONTINUE + CALL ALLUS(NSUPF,MU1(NSUPL+1),IMA(NSUPL+1),ASS(1),AK(NSUPL+1,1)) + ENDIF + DO 80 I=1,N + Y(I)=YSAV(I)+ALF21*AK(I,1) + 80 CONTINUE + X=XSAV+ALF21*H + CALL ALLUM(N,ADPL(1,1),Y(1),DYDX(1),MU1,IMA,1) + CALL ALLUM(N,ADPL(1,2),Y(1),TEMP(1),MU1,IMA,1) + DO 95 I=1,NSUPF + DO 90 J=1,NFISS + DYDX(NSUPL+I)=DYDX(NSUPL+I)+YSF(J,I,1)*Y(KFISS(J)) + TEMP(NSUPL+I)=TEMP(NSUPL+I)+YSF(J,I,2)*Y(KFISS(J)) + 90 CONTINUE + 95 CONTINUE + DO 100 I=1,N + DYDX(I)=DYDX(I)+X*TEMP(I)+BDPL(I,1)+X*BDPL(I,2) + AK(I,2)=H*DYDX(I)+HSQ*GAM2X*DFDX(I)+GAM21*AK(I,1) + 100 CONTINUE + CALL ALLUS(NSUPL,MU1(1),IMA(1),ASS(1),AK(1,2)) + IF(NSUPF.GT.0) THEN + DO 106 I=1,NSUPF + DO 105 J=1,NFISS + AK(NSUPL+I,2)=AK(NSUPL+I,2)+H*GAM*(YSF(J,I,1)+XSAV*YSF(J,I,2)) + 1 *AK(KFISS(J),2) + 105 CONTINUE + 106 CONTINUE + CALL ALLUS(NSUPF,MU1(NSUPL+1),IMA(NSUPL+1),ASS(1),AK(NSUPL+1,2)) + ENDIF + DO 110 I=1,N + AK(I,2)=AK(I,2)-GAM21*AK(I,1) + Y(I)=YSAV(I)+ALF31*AK(I,1)+ALF32*AK(I,2) + 110 CONTINUE + X=XSAV+(ALF31+ALF32)*H + CALL ALLUM(N,ADPL(1,1),Y(1),DYDX(1),MU1,IMA,1) + CALL ALLUM(N,ADPL(1,2),Y(1),TEMP(1),MU1,IMA,1) + DO 125 I=1,NSUPF + DO 120 J=1,NFISS + DYDX(NSUPL+I)=DYDX(NSUPL+I)+YSF(J,I,1)*Y(KFISS(J)) + TEMP(NSUPL+I)=TEMP(NSUPL+I)+YSF(J,I,2)*Y(KFISS(J)) + 120 CONTINUE + 125 CONTINUE + DO 130 I=1,N + DYDX(I)=DYDX(I)+X*TEMP(I)+BDPL(I,1)+X*BDPL(I,2) + TEMP(I)=GAM31*AK(I,1)+GAM32*AK(I,2) + AK(I,3)=H*DYDX(I)+GAM3X*HSQ*DFDX(I)+TEMP(I) + 130 CONTINUE + CALL ALLUS(NSUPL,MU1(1),IMA(1),ASS(1),AK(1,3)) + IF(NSUPF.GT.0) THEN + DO 136 I=1,NSUPF + DO 135 J=1,NFISS + AK(NSUPL+I,3)=AK(NSUPL+I,3)+H*GAM*(YSF(J,I,1)+XSAV*YSF(J,I,2)) + 1 *AK(KFISS(J),3) + 135 CONTINUE + 136 CONTINUE + CALL ALLUS(NSUPF,MU1(NSUPL+1),IMA(NSUPL+1),ASS(1),AK(NSUPL+1,3)) + ENDIF + DO 140 I=1,N + AK(I,3)=AK(I,3)-TEMP(I) + TEMP(I)=GAM41*AK(I,1)+GAM42*AK(I,2)+GAM43*AK(I,3) + AK(I,4)=H*DYDX(I)+HSQ*GAM4X*DFDX(I)+TEMP(I) + 140 CONTINUE + CALL ALLUS(NSUPL,MU1(1),IMA(1),ASS(1),AK(1,4)) + IF(NSUPF.GT.0) THEN + DO 146 I=1,NSUPF + DO 145 J=1,NFISS + AK(NSUPL+I,4)=AK(NSUPL+I,4)+H*GAM*(YSF(J,I,1)+XSAV*YSF(J,I,2)) + 1 *AK(KFISS(J),4) + 145 CONTINUE + 146 CONTINUE + CALL ALLUS(NSUPF,MU1(NSUPL+1),IMA(NSUPL+1),ASS(1),AK(NSUPL+1,4)) + ENDIF + DO 150 I=1,N + AK(I,4)=AK(I,4)-TEMP(I) + Y(I)=YSAV(I)+C1*AK(I,1)+C2*AK(I,2)+C3*AK(I,3)+C4*AK(I,4) + TEMP(I)=YSAV(I)+CC1*AK(I,1)+CC2*AK(I,2)+CC3*AK(I,3) + 150 CONTINUE + X=XSAV+H + IF (X.EQ.XSAV) THEN + WRITE(HSMG,'(36HEVOKAP: STEPSIZE NOT SIGNIFICANT (H=,1P,E11.4, + 1 6H HTRY=,E11.4,2H).)') H,HTRY + CALL XABORT(HSMG) + ENDIF + ERRMAX=0. + DO 160 I=1,N + ERRMAX=MAX(ERRMAX,ABS((Y(I)-TEMP(I))/YSCAL(I))) + 160 CONTINUE + ERRMAX=ERRMAX/EPS + IF (ERRMAX.EQ.0.) THEN + HDID=H + HNEXT=GROW*H + GO TO 210 + ELSE IF (ERRMAX.LE.1.) THEN + HDID=H + HNEXT=MIN(GROW,SAFETY*(ERRMAX**PGROW))*H + GO TO 210 + ELSE + H=MAX(SHRNK,SAFETY*(ERRMAX**PSHRNK))*H + ENDIF + 200 CONTINUE + CALL XABORT('EVOKAP: EXCEEDED MAXTRY.') +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 210 DEALLOCATE(ASS,AK,DFDX,DYSAV,YSAV,TEMP,DYDX) + RETURN + END diff --git a/Dragon/src/EVOMU1.f b/Dragon/src/EVOMU1.f new file mode 100644 index 0000000..70822de --- /dev/null +++ b/Dragon/src/EVOMU1.f @@ -0,0 +1,241 @@ +*DECK EVOMU1 + SUBROUTINE EVOMU1(IMPX,NVAR,NREAC,LP,XT,LCOOL,NPAR,KPAR,DCR,SIG1, + 1 SIG2,EXPMAX,IEVOLB,MU1,IMA,MAXA) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Determination of the profile of the depletion matrix (not taking into +* account the fission yields). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IMPX print flag (equal to zero for no print). +* NVAR number of nuclides in the complete depletion chain. +* NREAC one plus the number of neutron-induced depletion reactions. +* LP lumping index (set to zero to get rid of unused isotopes). +* XT initial and final value of the independent variable. +* LCOOL out-of-core depletion flag (LCOOL=.true. to set flag). +* NPAR maximum number of parent nuclides in the depletion chain. +* KPAR position in chain of the parent nuclide and type of +* reaction. +* DCR sum of radioactive decay constants in 10**-8/s. +* SIG1 initial reaction rates: +* SIG1(I,1) fission reaction rate for nuclide I; +* SIG1(I,2) gamma reaction rate for nuclide I; +* SIG1(I,3) N2N reaction rate for nuclide I; +* ...; +* SIG1(I,NREAC) neutron-induced energy released for nuclide I; +* SIG1(I,NREAC+1) decay energy released for nuclide I. +* SIG2 final reaction rates. +* EXPMAX saturation limit. A nuclide is saturating if +* -ADPL(MU1(I))*(XT(2)-XT(1)).GT.EXPMAX. Suggested value: +* EXPMAX=80.0. +* IEVOLB flag making an isotope non-depleting: +* =1 to force an isotope to be non-depleting; +* =2 to force an isotope to be depleting; +* =3 to force an isotope to be at saturation. +* +*Parameters: output +* MU1 position of each diagonal element in vector ADPL. +* IMA position of the first non-zero column element in vector ADPL. +* MAXA maximum number of terms in ADPL, taking into account +* saturation. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + LOGICAL LCOOL + INTEGER IMPX,NVAR,NREAC,LP(NVAR),NPAR,KPAR(NPAR,NVAR), + 1 IEVOLB(NVAR),MU1(NVAR+1),IMA(NVAR+1),MAXA + REAL XT(2),DCR(NVAR),SIG1(NVAR+1,NREAC+1),SIG2(NVAR+1,NREAC+1), + 1 EXPMAX +*---- +* LOCAL VARIABLES +*---- + LOGICAL LSAT + CHARACTER*2 SHOW(65,65) + INTEGER, ALLOCATABLE, DIMENSION(:) :: IPERM + REAL, ALLOCATABLE, DIMENSION(:) :: DIAG +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IPERM(NVAR),DIAG(NVAR)) +* + DO 10 IS=1,NVAR + IF(LP(IS).EQ.0) GO TO 10 + MU1(LP(IS))=1 + IMA(LP(IS))=1 + 10 CONTINUE + NVAR2=0 + DO 30 IS=1,NVAR + IF(LP(IS).EQ.0) GO TO 30 + NVAR2=MAX(NVAR2,LP(IS)) + DO 20 K=1,NPAR + IF(KPAR(K,IS).EQ.0) GO TO 30 + IF(KPAR(K,IS).EQ.2) GO TO 20 + JS=KPAR(K,IS)/100 + KT=KPAR(K,IS)-JS*100 + IF((LCOOL.AND.(KT.GE.2)).OR.(LP(JS).EQ.0)) GO TO 20 + MU1(LP(IS))=MAX(MU1(LP(IS)),LP(IS)-LP(JS)+1) + IMA(LP(JS))=MAX(IMA(LP(JS)),LP(JS)-LP(IS)+1) + 20 CONTINUE + 30 CONTINUE +* + DO 40 IS=1,NVAR + DIAG(IS)=0.0 + IF(LP(IS).EQ.0) GO TO 40 + SIGE1=0.0 + SIGE2=0.0 + IF(.NOT.LCOOL) THEN + DO 35 IREAC=1,NREAC-1 + SIGE1=SIGE1+SIG1(IS,IREAC) + SIGE2=SIGE2+SIG2(IS,IREAC) + 35 CONTINUE + ENDIF + DIAG(IS)=(MIN(SIGE1,SIGE2)+DCR(IS))*(XT(2)-XT(1)) + 40 CONTINUE +*---- +* COMPUTE THE LUMPING INDEX VECTOR IPERM +*---- + DO 50 I=1,NVAR2 + IPERM(I)=I + 50 CONTINUE + NTER=0 + 60 NTER=NTER+1 + INDSAT=0 + DO 70 IS=1,NVAR + IF(LP(IS).GT.0) THEN + LSAT=(IEVOLB(IS).EQ.3).AND.(EXPMAX.GT.0.0) + LSAT=LSAT.OR.((EXPMAX.GT.0.0).AND.(DIAG(IS).GT.EXPMAX)) + IF((IPERM(LP(IS)).GE.0).AND.LSAT) THEN + IPERM(LP(IS))=0 + IF(INDSAT.EQ.0) THEN + IPERM(LP(IS))=-NTER + INDSAT=LP(IS) + ENDIF + ENDIF + ENDIF + 70 CONTINUE + IF(INDSAT.EQ.0) GO TO 100 + DO 90 I=INDSAT+1,NVAR2 + DO 80 J=MIN(I-MU1(I)+1,I-IMA(I)+1),I-1 + IF((IPERM(I).EQ.0).AND.(IPERM(J).EQ.-NTER)) THEN + IPERM(I)=-NTER + GO TO 90 + ENDIF + 80 CONTINUE + 90 CONTINUE + GO TO 60 + 100 NTER=NTER-1 + N=0 + DO 110 I=1,NVAR2 + IF(IPERM(I).GT.0) THEN + N=N+1 + IPERM(I)=N + ENDIF + 110 CONTINUE +* + MAXA=0 + DO 175 ITER=1,NTER + JMIN=NVAR2 + JMAX=1 + DO 130 I=1,NVAR2 + IF(-IPERM(I).NE.ITER) GO TO 130 + DO 120 J=1,NVAR2 + IF((J.LE.I).AND.(J.GT.I-MU1(I))) THEN + JMIN=MIN(JMIN,J) + JMAX=MAX(JMAX,J) + ELSE IF((I.LE.J).AND.(I.GT.J-IMA(J))) THEN + JMIN=MIN(JMIN,J) + JMAX=MAX(JMAX,J) + ENDIF + 120 CONTINUE + 130 CONTINUE + IMIN=NVAR2 + IMAX=1 + DO 145 I=1,NVAR2 + DO 140 J=1,NVAR2 + IF(-IPERM(J).NE.ITER) GO TO 140 + IF((J.LE.I).AND.(J.GT.I-MU1(I))) THEN + IMIN=MIN(IMIN,I) + IMAX=MAX(IMAX,I) + ELSE IF((I.LE.J).AND.(I.GT.J-IMA(J))) THEN + IMIN=MIN(IMIN,I) + IMAX=MAX(IMAX,I) + ENDIF + 140 CONTINUE + 145 CONTINUE + DO 170 I=IMIN,IMAX + IF(-IPERM(I).EQ.ITER) GO TO 170 + DO 160 J=JMIN,JMAX + IF(-IPERM(J).EQ.ITER) GO TO 160 + IF((J.LE.I).AND.(J.GT.I-MU1(I))) GO TO 160 + IF((I.LE.J).AND.(I.GE.J-IMA(J))) GO TO 160 + MAXA=MAXA+1 + 160 CONTINUE + 170 CONTINUE + 175 CONTINUE +* + MAXROW=1 + MAXCOL=1 + II=0 + DO 180 I=1,NVAR2 + MAXROW=MAX(MAXROW,MU1(I)) + MAXCOL=MAX(MAXCOL,IMA(I)) + II=II+MU1(I) + MU1(I)=II + II=II+IMA(I)-1 + IMA(I)=II + 180 CONTINUE + MAXA=MAXA+IMA(NVAR2) + IF(IMPX.GT.3) WRITE (6,'(/34H EVOMU1: MAXIMUM ROW PROFILE WIDTH, + 1 4X,1H=,I5/9X,30HMAXIMUM COLUMN PROFILE WIDTH =,I5)') MAXROW, + 2 MAXCOL + IF(IMPX.GT.9) THEN + NVARM=MIN(NVAR2,65) + WRITE (6,'(//34H EVOMU1: DEPLETION MATRIX PROFILE:/)') + DO 195 I=1,NVARM + DO 190 J=1,NVARM + SHOW(I,J)=' ' + 190 CONTINUE + 195 CONTINUE + IMAM1=0 + DO 220 I=1,NVARM + DO 200 J=I-MU1(I)+IMAM1+1,I + IF(IPERM(I).GT.0) THEN + SHOW(I,J)='*' + ELSE + SHOW(I,J)='+' + ENDIF + 200 CONTINUE + DO 210 J=I-IMA(I)+MU1(I),I + IF(IPERM(J).GT.0) THEN + SHOW(J,I)='*' + ELSE + SHOW(J,I)='+' + ENDIF + 210 CONTINUE + IMAM1=IMA(I) + 220 CONTINUE + DO 230 I=1,NVARM + WRITE (6,'(1X,65A2)') (SHOW(I,J),J=1,NVARM) + 230 CONTINUE + IF(NVAR2.GT.65) WRITE(6,'(18H MATRIX TRUNCATED.)') + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(DIAG,IPERM) + RETURN + END diff --git a/Dragon/src/EVOODE.f b/Dragon/src/EVOODE.f new file mode 100644 index 0000000..dbdf0de --- /dev/null +++ b/Dragon/src/EVOODE.f @@ -0,0 +1,114 @@ +*DECK EVOODE + SUBROUTINE EVOODE(YSTART,NVAR,X1,X2,EPS,H1,NOK,NBAD,ITYPE,MU1, + 1 IMA,MAXA,NSUPF,NFISS,KFISS,YSF,ADPL,BDPL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Runge-Kutta or Kaps-Rentrop driver with adaptive stepsize control +* special version for isotopic depletion calculations. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* YSTART dependent variable vector. +* NVAR dimension of the dependent variable vector (number of +* depleting isotopes). +* X1 initial value of the independent variable. +* X2 final value of the independent variable. +* EPS required accuracy. +* H1 guessed first stepsize. +* NOK number of good steps taken. +* NBAD number of bad steps taken. +* ITYPE type of ODE solution: +* =1 fifth-order Runge-Kutta method; +* =2 fourth-order Kaps-Rentrop method. +* MU1 position of each diagonal element in matrix ADPL. +* IMA position of the first non-zero column element in matrix ADPL. +* MAXA first dimension of matrix ADPL. +* NSUPF number of depleting fission products. +* NFISS number of fissile isotopes producing fission products. +* KFISS position in chain of the fissile isotopes. +* YSF components of the product of the fission yields and fission +* rates. +* ADPL depletion matrix components. +* BDPL depletion source components. +* +*----------------------------------------------------------------------- +* +* REFERENCE: +* W.H. PRESS, B.P. FLANNERY, S.A. TEUKOLSKY AND W.T. VETTERLING, +* 'NUMERICAL RECIPIES (FORTRAN VERSION)', CAMBRIDGE UNIVERSITY PRESS, +* CHAPTER 15, CAMBRIDGE (1990). +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NVAR,NOK,NBAD,ITYPE,MU1(NVAR),IMA(NVAR),MAXA,NSUPF,NFISS, + 1 KFISS(NFISS) + REAL YSTART(NVAR),X1,X2,EPS,H1,YSF(NFISS,NSUPF,2),ADPL(MAXA,2), + 1 BDPL(NVAR,2) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MAXSTP=50000,TINY=1.E-8) + REAL, ALLOCATABLE, DIMENSION(:) :: YSCAL,Y +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(YSCAL(NVAR),Y(NVAR)) +* + NSUPL=NVAR-NSUPF + X=X1 + H=SIGN(H1,X2-X1) + NOK=0 + NBAD=0 + DO 10 I=1,NVAR + Y(I)=YSTART(I) + 10 CONTINUE + DO 50 NSTP=1,MAXSTP + IF((X+H-X2)*(X+H-X1).GT.0.0) H=X2-X + CALL ALLUM(NVAR,ADPL(1,1),Y(1),YSCAL(1),MU1,IMA,1) + CALL ALLUM(NVAR,ADPL(1,2),Y(1),YSTART(1),MU1,IMA,1) + DO 25 I=1,NSUPF + DO 20 J=1,NFISS + YSCAL(NSUPL+I)=YSCAL(NSUPL+I)+YSF(J,I,1)*Y(KFISS(J)) + YSTART(NSUPL+I)=YSTART(NSUPL+I)+YSF(J,I,2)*Y(KFISS(J)) + 20 CONTINUE + 25 CONTINUE + DO 30 I=1,NVAR + YSCAL(I)=YSCAL(I)+BDPL(I,1)+X*(YSTART(I)+BDPL(I,2)) + YSCAL(I)=MAX(ABS(Y(I))+ABS(H*YSCAL(I)),TINY) + 30 CONTINUE + IF(ITYPE.EQ.1) THEN + CALL EVORK(Y,NVAR,X,H,EPS,YSCAL,HDID,HNEXT,MU1,IMA,MAXA, + 1 NSUPF,NFISS,KFISS,YSF,ADPL,BDPL) + ELSE IF(ITYPE.EQ.2) THEN + CALL EVOKAP(Y,NVAR,X,H,EPS,YSCAL,HDID,HNEXT,MU1,IMA,MAXA, + 1 NSUPF,NFISS,KFISS,YSF,ADPL,BDPL) + ENDIF + IF(HDID.EQ.H) THEN + NOK=NOK+1 + ELSE + NBAD=NBAD+1 + ENDIF + IF((X-X2)*(X2-X1).GE.0.0) THEN + DO 40 I=1,NVAR + YSTART(I)=Y(I) + 40 CONTINUE + GO TO 60 + ENDIF + H=HNEXT + 50 CONTINUE + CALL XABORT('EVOODE: TOO MANY STEPS.') +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 60 DEALLOCATE(Y,YSCAL) + END diff --git a/Dragon/src/EVORK.f b/Dragon/src/EVORK.f new file mode 100644 index 0000000..93758ee --- /dev/null +++ b/Dragon/src/EVORK.f @@ -0,0 +1,193 @@ +*DECK EVORK + SUBROUTINE EVORK(Y,N,X,HTRY,EPS,YSCAL,HDID,HNEXT,MU1,IMA,MAXA, + 1 NSUPF,NFISS,KFISS,YSF,ADPL,BDPL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Fifth-order Runge-Kutta Cash-Karp step with monitoring of local +* truncation error to ensure accuracy and adjust stepsize. +* Special version for isotopic depletion calculations. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* Y dependent variable vector. +* N size of the dependent variable vector. +* X independent variable. +* HTRY stepsize to be attempted. +* EPS required accuracy. +* YSCAL vector against which the error is scaled. +* HDID stepsize that was actually accomplished. +* HNEXT estimated next stepsize. +* MU1 position of each diagonal element in vectors ADPL and ASS. +* IMA position of the first non-zero column element in vectors +* ADPL and ASS. +* MAXA first dimension of matrix ADPL. +* NSUPF number of depleting fission products. +* NFISS number of fissile isotopes producing fission products. +* KFISS position in chain of the fissile isotopes. +* YSF components of the product of the fission yields and fission +* rates. +* ADPL depletion matrix components. +* BDPL depletion source components. +* +*Reference: +* W. H. Press, S. A. Teukolsky, W. T. Vetterling and B. P. Flannery, +* "Numerical recipes in Fortran, Second edition, Chapter 16, +* Cambridge, 1992. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,MU1(N),IMA(N),MAXA,NSUPF,NFISS,KFISS(NFISS) + REAL Y(N),X,HTRY,EPS,YSCAL(N),HDID,HNEXT,YSF(NFISS,NSUPF,2), + 1 ADPL(MAXA,2),BDPL(N,2) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (A2=.2,A3=.3,A4=.6,A5=1.,A6=.875,B21=.2,B31=3./40., + *B32=9./40.,B41=.3,B42=-.9,B43=1.2,B51=-11./54.,B52=2.5, + *B53=-70./27.,B54=35./27.,B61=1631./55296.,B62=175./512., + *B63=575./13824.,B64=44275./110592.,B65=253./4096.,C1=37./378., + *C3=250./621.,C4=125./594.,C6=512./1771.,DC1=C1-2825./27648., + *DC3=C3-18575./48384.,DC4=C4-13525./55296.,DC5=-277./14336., + *DC6=C6-.25) + PARAMETER (SAFETY=0.85,PGROW=-.2,PSHRNK=-.25,GROW=1.5,SHRNK=0.5) + CHARACTER HSMG*131 + REAL, ALLOCATABLE, DIMENSION(:) :: YTEMP,YGAR + REAL, ALLOCATABLE, DIMENSION(:,:) :: AK +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(YTEMP(N),YGAR(N),AK(N,6)) +* + NSUPL=N-NSUPF + H=HTRY + 10 CALL ALLUM(N,ADPL(1,1),Y(1),AK(1,1),MU1,IMA,1) + CALL ALLUM(N,ADPL(1,2),Y(1),YGAR(1),MU1,IMA,1) + DO 25 I=1,NSUPF + DO 20 J=1,NFISS + AK(NSUPL+I,1)=AK(NSUPL+I,1)+YSF(J,I,1)*Y(KFISS(J)) + YGAR(NSUPL+I)=YGAR(NSUPL+I)+YSF(J,I,2)*Y(KFISS(J)) + 20 CONTINUE + 25 CONTINUE + DO 30 I=1,N + AK(I,1)=AK(I,1)+BDPL(I,1)+X*(YGAR(I)+BDPL(I,2)) + YTEMP(I)=Y(I)+H*B21*AK(I,1) + 30 CONTINUE +* + CALL ALLUM(N,ADPL(1,1),YTEMP(1),AK(1,2),MU1,IMA,1) + CALL ALLUM(N,ADPL(1,2),YTEMP(1),YGAR(1),MU1,IMA,1) + DO 45 I=1,NSUPF + DO 40 J=1,NFISS + AK(NSUPL+I,2)=AK(NSUPL+I,2)+YSF(J,I,1)*YTEMP(KFISS(J)) + YGAR(NSUPL+I)=YGAR(NSUPL+I)+YSF(J,I,2)*YTEMP(KFISS(J)) + 40 CONTINUE + 45 CONTINUE + DO 50 I=1,N + AK(I,2)=AK(I,2)+BDPL(I,1)+(X+A2*H)*(YGAR(I)+BDPL(I,2)) + YTEMP(I)=Y(I)+H*(B31*AK(I,1)+B32*AK(I,2)) + 50 CONTINUE +* + CALL ALLUM(N,ADPL(1,1),YTEMP(1),AK(1,3),MU1,IMA,1) + CALL ALLUM(N,ADPL(1,2),YTEMP(1),YGAR(1),MU1,IMA,1) + DO 65 I=1,NSUPF + DO 60 J=1,NFISS + AK(NSUPL+I,3)=AK(NSUPL+I,3)+YSF(J,I,1)*YTEMP(KFISS(J)) + YGAR(NSUPL+I)=YGAR(NSUPL+I)+YSF(J,I,2)*YTEMP(KFISS(J)) + 60 CONTINUE + 65 CONTINUE + DO 70 I=1,N + AK(I,3)=AK(I,3)+BDPL(I,1)+(X+A3*H)*(YGAR(I)+BDPL(I,2)) + YTEMP(I)=Y(I)+H*(B41*AK(I,1)+B42*AK(I,2)+B43*AK(I,3)) + 70 CONTINUE +* + CALL ALLUM(N,ADPL(1,1),YTEMP(1),AK(1,4),MU1,IMA,1) + CALL ALLUM(N,ADPL(1,2),YTEMP(1),YGAR(1),MU1,IMA,1) + DO 85 I=1,NSUPF + DO 80 J=1,NFISS + AK(NSUPL+I,4)=AK(NSUPL+I,4)+YSF(J,I,1)*YTEMP(KFISS(J)) + YGAR(NSUPL+I)=YGAR(NSUPL+I)+YSF(J,I,2)*YTEMP(KFISS(J)) + 80 CONTINUE + 85 CONTINUE + DO 90 I=1,N + AK(I,4)=AK(I,4)+BDPL(I,1)+(X+A4*H)*(YGAR(I)+BDPL(I,2)) + YTEMP(I)=Y(I)+H*(B51*AK(I,1)+B52*AK(I,2)+B53*AK(I,3)+B54*AK(I,4)) + 90 CONTINUE +* + CALL ALLUM(N,ADPL(1,1),YTEMP(1),AK(1,5),MU1,IMA,1) + CALL ALLUM(N,ADPL(1,2),YTEMP(1),YGAR(1),MU1,IMA,1) + DO 105 I=1,NSUPF + DO 100 J=1,NFISS + AK(NSUPL+I,5)=AK(NSUPL+I,5)+YSF(J,I,1)*YTEMP(KFISS(J)) + YGAR(NSUPL+I)=YGAR(NSUPL+I)+YSF(J,I,2)*YTEMP(KFISS(J)) + 100 CONTINUE + 105 CONTINUE + DO 110 I=1,N + AK(I,5)=AK(I,5)+BDPL(I,1)+(X+A5*H)*(YGAR(I)+BDPL(I,2)) + YTEMP(I)=Y(I)+H*(B61*AK(I,1)+B62*AK(I,2)+B63*AK(I,3)+B64*AK(I,4)+ + 1 B65*AK(I,5)) + 110 CONTINUE +* + CALL ALLUM(N,ADPL(1,1),YTEMP(1),AK(1,6),MU1,IMA,1) + CALL ALLUM(N,ADPL(1,2),YTEMP(1),YGAR(1),MU1,IMA,1) + DO 125 I=1,NSUPF + DO 120 J=1,NFISS + AK(NSUPL+I,6)=AK(NSUPL+I,6)+YSF(J,I,1)*YTEMP(KFISS(J)) + YGAR(NSUPL+I)=YGAR(NSUPL+I)+YSF(J,I,2)*YTEMP(KFISS(J)) + 120 CONTINUE + 125 CONTINUE + DO 130 I=1,N + AK(I,6)=AK(I,6)+BDPL(I,1)+(X+A6*H)*(YGAR(I)+BDPL(I,2)) + YTEMP(I)=Y(I)+H*(C1*AK(I,1)+C3*AK(I,3)+C4*AK(I,4)+C6*AK(I,6)) + YGAR(I)=H*(DC1*AK(I,1)+DC3*AK(I,3)+DC4*AK(I,4)+DC5*AK(I,5)+ + 1 DC6*AK(I,6)) + 130 CONTINUE +* + ERRMAX=0.0 + DO 140 I=1,N + ERRMAX=MAX(ERRMAX,ABS(YGAR(I)/YSCAL(I))) + 140 CONTINUE + ERRMAX=ERRMAX/EPS + IF (ERRMAX.EQ.0.0) THEN + HDID=H + HNEXT=GROW*H + X=X+H + DO 150 I=1,N + Y(I)=YTEMP(I) + 150 CONTINUE + GO TO 170 + ELSE IF (ERRMAX.LE.1.0) THEN + HDID=H + HNEXT=MIN(GROW,SAFETY*(ERRMAX**PGROW))*H + X=X+H + DO 160 I=1,N + Y(I)=YTEMP(I) + 160 CONTINUE + GO TO 170 + ELSE + H=MAX(SHRNK,SAFETY*(ERRMAX**PSHRNK))*H + XNEW=X+H + IF (X.EQ.XNEW) THEN + WRITE(HSMG,'(35HEVORK: STEPSIZE NOT SIGNIFICANT (H=,1P,E11.4, + 1 6H HTRY=,E11.4,2H).)') H,HTRY + CALL XABORT(HSMG) + ENDIF + GO TO 10 + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 170 DEALLOCATE(AK,YGAR,YTEMP) + RETURN + END diff --git a/Dragon/src/EVOSAT.f b/Dragon/src/EVOSAT.f new file mode 100644 index 0000000..b650be8 --- /dev/null +++ b/Dragon/src/EVOSAT.f @@ -0,0 +1,380 @@ +*DECK EVOSAT + SUBROUTINE EVOSAT(IMPX,MAXA,MAXB,MAXY,LOGY,NSAT,NVAR,KSAT,YST1, + 1 YSAT,MU1,IMA,NSUPF,NFISS,IDIRAC,KFISS,YSF,ADPL,BDPL,NSUPFG) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Lumping of the depletion matrix, fission yields, sources and initial +* conditions to take into account the saturation of depleting nuclides. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IMPX print parameter. +* MAXA first dimension of matrices ADPL and AGAR. +* MAXB first dimension of matrices BDPL, IMA and MU1. +* MAXY second dimension of matrix YSF. +* LOGY number of passes through EVOSAT: +* first pass updates YSAT and YST1; +* second pass does not update YSAT and YST1. +* NSAT number of saturating nuclides. +* NVAR number of nuclides in the complete depletion chain. +* KSAT position in chain of the saturating nuclides. +* NFISS number of fissile isotopes producing fission products. +* IDIRAC saturation model flag (=1 to use Dirac function contributions +* in the saturating nuclide number densities). +* MU1 position of each diagonal element in vector ADPL. +* IMA position of the first non-zero column element in vector ADPL. +* NSUPF number of depleting fission products. +* KFISS position in chain of the fissile isotopes. +* YSF product of the fission yields and fission rates. +* ADPL depletion matrix. +* BDPL depletion source. +* +*Parameters: input/output +* YST1 number densities for all isotopes as input and of +* the non-saturated isotopes as output. +* +*Parameters: output +* NSUPFG number of lumped depleting fission products. +* YSAT number densities of the saturating isotopes. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IMPX,MAXA,MAXB,MAXY,LOGY,NSAT,NVAR,KSAT(NSAT),MU1(MAXB), + 1 IMA(MAXB),NSUPF,NFISS,IDIRAC,KFISS(NFISS),NSUPFG + REAL YST1(NVAR),YSAT(NSAT),YSF(NFISS,MAXY,LOGY),ADPL(MAXA,LOGY), + 1 BDPL(MAXB,LOGY) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(EPS=1.0E-5) + CHARACTER HSMG*131 + LOGICAL LTEST +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KEV,MGAR,IGAR + REAL, ALLOCATABLE, DIMENSION(:) :: YSTG,AGAR,BGAR,GAR + REAL, ALLOCATABLE, DIMENSION(:,:) :: A22,YSFG + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: A21,A12 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(KEV(NVAR),MGAR(NVAR-NSAT),IGAR(NVAR-NSAT)) + ALLOCATE(YSTG(NVAR-NSAT),A22(NSAT,NSAT),A21(NSAT,NVAR-NSAT,LOGY), + 1 A12(NVAR-NSAT,NSAT,LOGY),AGAR(MAXA),BGAR(NVAR-NSAT), + 2 YSFG(NFISS,NSUPF),GAR(NSAT)) +* + NSUPL=NVAR-NSUPF + I0=0 + DO 40 I=1,NVAR + DO 10 II=1,NSAT + IF(I.EQ.KSAT(II)) GO TO 20 + 10 CONTINUE + I0=I0+1 + KEV(I)=I0 + GO TO 40 + 20 DO 25 L=1,LOGY + IF(ADPL(MU1(I),L).EQ.0.0) CALL XABORT('EVOSAT: ZERO DIAGONAL COM' + 1 //'PONENT FOR A SATURATING ISOTOPE.') + 25 CONTINUE + DO 30 II=1,NFISS + IF(I.EQ.KFISS(II)) CALL XABORT('EVOSAT: A FISSILE ISOTOPE IS SAT' + 1 //'URATING.') + 30 CONTINUE + KEV(I)=0 + 40 CONTINUE + DO 50 I=1,NFISS + KFISS(I)=KEV(KFISS(I)) + 50 CONTINUE +*---- +* FIRST LOOP OVER LOGY +*---- + DO 275 L=1,LOGY +*---- +* COMPUTE MATRICES A22**-1, A21, AND A12 +*---- + DO 90 II=1,NSAT + I=KSAT(II) + IMAM1=0 + IF(I.GT.1) IMAM1=IMA(I-1) + DO 60 JJ=1,NSAT + J=KSAT(JJ) + IF((J.LE.I).AND.(J.GT.I+IMAM1-MU1(I))) THEN + A22(II,JJ)=ADPL(MU1(I)-I+J,L) + ELSE IF((I.LE.J).AND.(I.GE.J-IMA(J)+MU1(J))) THEN + A22(II,JJ)=ADPL(MU1(J)+J-I,L) + ELSE + A22(II,JJ)=0.0 + ENDIF + 60 CONTINUE + JMAM1=0 + DO 75 J=1,NVAR + J0=KEV(J) + IF(J0.EQ.0) GO TO 70 + IF((J.LE.I).AND.(J.GT.I+IMAM1-MU1(I))) THEN + A21(II,J0,L)=ADPL(MU1(I)-I+J,L) + ELSE IF((I.LE.J).AND.(I.GE.J-IMA(J)+MU1(J))) THEN + A21(II,J0,L)=ADPL(MU1(J)+J-I,L) + ELSE + A21(II,J0,L)=0.0 + ENDIF + IF((I.LE.J).AND.(I.GT.J+JMAM1-MU1(J))) THEN + A12(J0,II,L)=ADPL(MU1(J)-J+I,L) + ELSE IF((J.LE.I).AND.(J.GE.I-IMA(I)+MU1(I))) THEN + A12(J0,II,L)=ADPL(MU1(I)+I-J,L) + ELSE + A12(J0,II,L)=0.0 + ENDIF + 70 JMAM1=IMA(J) + 75 CONTINUE + IF(I.GT.NSUPL) THEN + DO 80 K=1,NFISS + A21(II,KFISS(K),L)=A21(II,KFISS(K),L)+YSF(K,I-NSUPL,L) + 80 CONTINUE + ENDIF + 90 CONTINUE + CALL ALINV(NSAT,A22,NSAT,IER) + IF(IER.NE.0) CALL XABORT('EVOSAT: SINGULAR MATRIX.') +*---- +* COMPUTE VECTOR YSTG ANT YSAT +*---- + IF(L.EQ.1) THEN +* BEGINNING-OF-STAGE DIRAC DELTA CONTRIBUTIONS: + DO 100 I=1,NSAT + YSAT(I)=YST1(KSAT(I)) + 100 CONTINUE + DO 110 I=1,NVAR + IF(KEV(I).GT.0) YSTG(KEV(I))=YST1(I) + 110 CONTINUE + IF(IDIRAC.EQ.0) THEN + DO 125 I=1,NSAT + GAR(I)=BDPL(KSAT(I),L) + DO 120 J=1,NVAR-NSAT + GAR(I)=GAR(I)+A21(I,J,L)*YSTG(J) + 120 CONTINUE + 125 CONTINUE + DO 135 I=1,NSAT + YSAT(I)=0.0 + DO 130 J=1,NSAT + YSAT(I)=YSAT(I)-A22(I,J)*GAR(J) + 130 CONTINUE + 135 CONTINUE + GO TO 220 + ENDIF + ITER=0 + 140 ITER=ITER+1 + IF(ITER.GT.50) CALL XABORT('EVOSAT: CONVERGENCE FAILURE.') + DO 155 I=1,NSAT + GAR(I)=BDPL(KSAT(I),L) + DO 150 J=1,NVAR-NSAT + GAR(I)=GAR(I)+A21(I,J,L)*YSTG(J) + 150 CONTINUE + 155 CONTINUE + ERR1=0.0 + ERR2=0.0 + DO 170 I=1,NSAT + ZCOMP=YSAT(I) + YSAT(I)=0.0 + DO 160 J=1,NSAT + YSAT(I)=YSAT(I)-A22(I,J)*GAR(J) + 160 CONTINUE + ERR1=MAX(ERR1,ABS(ZCOMP-YSAT(I))) + ERR2=MAX(ERR2,ABS(YSAT(I))) + 170 CONTINUE + DO 185 I=1,NSAT + GAR(I)=0.0 + DO 180 J=1,NSAT + GAR(I)=GAR(I)-A22(I,J)*(YST1(KSAT(J))-YSAT(J)) + 180 CONTINUE + 185 CONTINUE + DO 190 I=1,NVAR + IF(KEV(I).GT.0) YSTG(KEV(I))=YST1(I) + 190 CONTINUE + DO 210 I=1,NVAR-NSAT + DO 200 J=1,NSAT + YSTG(I)=YSTG(I)+A12(I,J,L)*GAR(J) + 200 CONTINUE + ERR2=MAX(ERR2,ABS(YSTG(I))) + 210 CONTINUE + IF(ERR1.LE.EPS*ERR2) GO TO 220 + GO TO 140 + ENDIF +*---- +* COMPUTE MATRICES A21 AND BGAR +*---- + 220 DO 235 I=1,NSAT + GAR(I)=0.0 + DO 230 J=1,NSAT + GAR(I)=GAR(I)-A22(I,J)*BDPL(KSAT(J),L) + 230 CONTINUE + 235 CONTINUE + BGAR(:NVAR-NSAT)=0.0 + DO 240 I=1,NVAR + IF(KEV(I).GT.0) BGAR(KEV(I))=BDPL(I,L) + 240 CONTINUE + DO 255 I=1,NVAR-NSAT + DO 250 J=1,NSAT + BGAR(I)=BGAR(I)+A12(I,J,L)*GAR(J) + 250 CONTINUE + 255 CONTINUE + DO 272 J=1,NVAR-NSAT + BDPL(J,L)=BGAR(J) + IF(L.EQ.1) YST1(J)=YSTG(J) + DO 260 K=1,NSAT + GAR(K)=A21(K,J,L) + 260 CONTINUE + DO 271 I=1,NSAT + A21(I,J,L)=0.0 + DO 270 K=1,NSAT + A21(I,J,L)=A21(I,J,L)+A22(I,K)*GAR(K) + 270 CONTINUE + 271 CONTINUE + 272 CONTINUE +* + 275 CONTINUE +*---- +* DETERMINE THE PROFILE PATTERN OF THE LUMPED DEPLETION MATRIX. +*---- + NSUPLG=NSUPL + DO 280 I=1,NVAR + IF((KEV(I).EQ.0).AND.(I.LE.NSUPL)) NSUPLG=NSUPLG-1 + 280 CONTINUE + NSUPFG=NVAR-NSAT-NSUPLG + MGAR(:NVAR-NSAT)=1 + IGAR(:NVAR-NSAT)=1 + IMAM1=0 + DO 305 I=1,NVAR + IKEV=KEV(I) + IF(IKEV.EQ.0) GO TO 300 + DO 290 J=1,NVAR + JKEV=KEV(J) + IF(JKEV.EQ.0) GO TO 290 + IF((J.LE.I).AND.(J.GT.I+IMAM1-MU1(I))) THEN + MGAR(IKEV)=MAX(MGAR(IKEV),IKEV-JKEV+1) + ELSE IF((I.LE.J).AND.(I.GE.J-IMA(J)+MU1(J))) THEN + IGAR(JKEV)=MAX(IGAR(JKEV),JKEV-IKEV+1) + ENDIF + 290 CONTINUE + 300 IMAM1=IMA(I) + 305 CONTINUE + DO 335 J=1,NVAR-NSAT + JIFI=0 + DO 310 IFI=1,NFISS + IF(J.EQ.KFISS(IFI)) JIFI=IFI + 310 CONTINUE + DO 330 I=1,NVAR-NSAT + IF((I.GT.NSUPLG).AND.(JIFI.GT.0)) GO TO 330 + LTEST=.FALSE. + DO 325 L=1,LOGY + DO 320 K=1,NSAT + LTEST=LTEST.OR.(A12(I,K,L)*A21(K,J,L).NE.0.0) + 320 CONTINUE + 325 CONTINUE + IF(LTEST.AND.(J.LE.I)) THEN + MGAR(I)=MAX(MGAR(I),I-J+1) + ELSE IF(LTEST) THEN + IGAR(J)=MAX(IGAR(J),J-I+1) + ENDIF + 330 CONTINUE + 335 CONTINUE + II=0 + DO 340 I=1,NVAR-NSAT + II=II+MGAR(I) + MGAR(I)=II + II=II+IGAR(I)-1 + IGAR(I)=II + 340 CONTINUE + IF(IMPX.GT.8) WRITE(6,'(/27H EVOSAT: REAL SIZE OF ADPL=,I9,3H AL, + 1 13HLOCATED SIZE=,I9,1H.)') IGAR(NVAR-NSAT),MAXA + IF(IGAR(NVAR-NSAT).GT.MAXA) THEN + WRITE(HSMG,'(24HEVOSAT: IGAR(NVAR-NSAT)=,I6,6H MAXA=,I6)') + 1 IGAR(NVAR-NSAT),MAXA + CALL XABORT(HSMG) + ENDIF +*---- +* SECOND LOOP OVER LOGY +*---- + DO 540 L=1,LOGY +*---- +* COMPUTE MATRIX AGAR AND YIELDS YSFG. +*---- + AGAR(:IGAR(NVAR-NSAT))=0.0 + IMAM1=0 + DO 445 I=1,NVAR + IKEV=KEV(I) + IF(IKEV.EQ.0) GO TO 440 + DO 420 J=1,NVAR + JKEV=KEV(J) + IF(JKEV.EQ.0) GO TO 420 + IF((J.LE.I).AND.(J.GT.I+IMAM1-MU1(I))) THEN + AGAR(MGAR(IKEV)-IKEV+JKEV)=ADPL(MU1(I)-I+J,L) + ELSE IF((I.LE.J).AND.(I.GE.J-IMA(J)+MU1(J))) THEN + AGAR(MGAR(JKEV)+JKEV-IKEV)=ADPL(MU1(J)+J-I,L) + ENDIF + 420 CONTINUE + IF(I.GT.NSUPL) THEN + DO 430 K=1,NFISS + YSFG(K,IKEV-NSUPLG)=YSF(K,I-NSUPL,L) + 430 CONTINUE + ENDIF + 440 IMAM1=IMA(I) + 445 CONTINUE + DO 495 J=1,NVAR-NSAT + JIFI=0 + DO 450 IFI=1,NFISS + IF(J.EQ.KFISS(IFI)) JIFI=IFI + 450 CONTINUE + IMAM1=0 + DO 490 I=1,NVAR-NSAT + IF((I.GT.NSUPLG).AND.(JIFI.GT.0)) GO TO 480 + IF((J.LE.I).AND.(J.GT.I+IMAM1-MGAR(I))) THEN + DO 460 K=1,NSAT + AGAR(MGAR(I)-I+J)=AGAR(MGAR(I)-I+J)-A12(I,K,L)*A21(K,J,L) + 460 CONTINUE + ELSE IF((I.LE.J).AND.(I.GE.J-IGAR(J)+MGAR(J))) THEN + DO 470 K=1,NSAT + AGAR(MGAR(J)+J-I)=AGAR(MGAR(J)+J-I)-A12(I,K,L)*A21(K,J,L) + 470 CONTINUE + ENDIF + 480 IMAM1=IGAR(I) + 490 CONTINUE + 495 CONTINUE + DO 510 I=NSUPLG+1,NVAR-NSAT + DO 505 IFI=1,NFISS + J=KFISS(IFI) + DO 500 K=1,NSAT + YSFG(IFI,I-NSUPLG)=YSFG(IFI,I-NSUPLG)-A12(I,K,L)*A21(K,J,L) + 500 CONTINUE + 505 CONTINUE + 510 CONTINUE +*---- +* REPLACE THE ORIGINAL INFORMATION WITH THE LUMPED ONE +*---- + DO 520 I=1,IGAR(NVAR-NSAT) + ADPL(I,L)=AGAR(I) + 520 CONTINUE + DO 535 I=1,NFISS + DO 530 J=1,NSUPFG + YSF(I,J,L)=YSFG(I,J) + 530 CONTINUE + 535 CONTINUE + 540 CONTINUE + DO 550 I=1,NVAR-NSAT + IMA(I)=IGAR(I) + MU1(I)=MGAR(I) + 550 CONTINUE + RETURN + END diff --git a/Dragon/src/EVOSIG.f b/Dragon/src/EVOSIG.f new file mode 100644 index 0000000..3e5c172 --- /dev/null +++ b/Dragon/src/EVOSIG.f @@ -0,0 +1,327 @@ +*DECK EVOSIG + SUBROUTINE EVOSIG(IMPX,INR,IGLOB,NGROUP,NBMIX,NBISO,NCOMB, + 1 ISONAM,IPISO,DEN,FLUMIX,VX,MILVO,JM,NVAR,NSUPS,NREAC,HREAC, + 2 IDR,RER,RRD,FIT,AWR,IZAE,FUELDN,NXSPER,DELTAT,MIXPWR,PFACT, + 3 SIG,VPHV) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute and normalize the microscopic depletion reaction rates. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IMPX print flag (equal to zero for no print). +* INR type of flux normalization: +* =0: out-of-core depletion; +* =1: constant flux depletion; +* =2: constant fuel power depletion; +* =3: constant assembly power depletion. +* IGLOB out-of-fuel power in flux normalization. Compute the burnup: +* =-1: using the Serpent mode 0 empirical formula in the fuel; +* =0: using the power released in the fuel; +* =1: using the power released in the global geometry. +* NGROUP number of energy groups. +* NBMIX number of mixtures. +* NBISO number of isotopes/materials including non-depleting ones. +* NCOMB number of depleting mixtures. +* ISONAM alias name of isotopes. +* IPISO pointer array towards microlib isotopes. +* DEN density of each isotope. +* FLUMIX average fluxes in mixtures. +* VX volumes of the depleting mixtures. +* MILVO mixture index corresponding to each depleting mixture. +* JM position in isotope list of each nuclide of the depletion +* chain. A negative value indicates a non-depleting isotope +* producing energy. +* NVAR number of depleting nuclides. +* NSUPS number of non-depleting isotopes producing energy. +* NREAC maximum number of depletion reactions. +* HREAC names of used depletion reactions: +* HREAC(1)='DECAY'; HREAC(2)='NFTOT'; +* HREAC(3)='NG' ; HREAC(4)='N2N'; etc. +* IDR identifier for each depleting reaction. +* RER energy (Mev) per reaction. If RER(3,J)=0., the fission energy +* is including radiative capture energy. Neutrino energy is +* never included. +* RRD sum of radioactive decay constants in 10**-8/s. +* FIT flux normalization factor: +* n/cm**2/s if INR=1; +* MW/tonne of initial heavy elements if INR=2; +* W/cc of assembly volume if INR=3. +* AWR mass of the nuclides in unit of neutron mass. +* IZAE 6-digit nuclide identifiers. +* FUELDN fuel initial density and mass. +* NXSPER perturbation order for cross sections. +* DELTAT perturbation coefficients for cross sections. +* MIXPWR flags for mixtures to include in power normalization. +* +*Parameters: output +* PFACT form factor for out-of-fuel power production. +* SIG microscopic reaction rates for nuclide I in mixture IBM: +* SIG(I,1,IBM) fission reaction rate; +* SIG(I,2,IBM) (n,gamma) reaction rate; +* SIG(I,3,IBM) N2N reaction rate; +* ...; +* SIG(I,NREAC,IBM) neutron-induced energy released; +* SIG(I,NREAC+1,IBM) decay energy released (10**-8 MeV/s). +* VPHV integrated fluxes in mixtures. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPISO(NBISO) + INTEGER IMPX,INR,IGLOB,NGROUP,NBMIX,NBISO,NCOMB,ISONAM(3,NBISO), + 1 MILVO(NCOMB),JM(NBMIX,NVAR+NSUPS),NVAR,NSUPS,NREAC, + 2 HREAC(2,NREAC),IDR(NREAC,NVAR+NSUPS),IZAE(NVAR+NSUPS),NXSPER, + 3 MIXPWR(NBMIX) + REAL DEN(NBISO),VX(NBMIX),RER(NREAC,NVAR+NSUPS),RRD(NVAR+NSUPS), + 1 FIT,AWR(NVAR+NSUPS),FUELDN(3),DELTAT(2),PFACT,VPHV(NBMIX), + 2 SIG(NVAR+1,NREAC+1,NBMIX),FLUMIX(NGROUP,NBMIX) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(IOUT=6,MAXREA=20) + TYPE(C_PTR) KPLIB,KPLIB5 + CHARACTER HSMG*131,NAMDXS(MAXREA)*6 + DOUBLE PRECISION GAR,GAR1,GAR2,GARD,XDRCST,EVJ,FITD,PHI,FNORM,VPH + INTEGER IPRLOC + LOGICAL LKERMA + REAL, ALLOCATABLE, DIMENSION(:) :: ZKERMA,ZNFTOT + REAL, ALLOCATABLE, DIMENSION(:,:) :: XSREC +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(XSREC(NGROUP,NREAC-1)) +*---- +* FIND U235 POSITION IN DECAY CHAIN +*---- + IS235=0 + IF(IGLOB.EQ.-1) THEN + DO 30 IST=1,NVAR+NSUPS + IF(IZAE(IST).EQ.922350) IS235=IST + 30 CONTINUE + IF(IS235.EQ.0) CALL XABORT('EVOSIG: NO U235 INFO(1).') + ENDIF +*---- +* COMPUTE MICRO RATES +*---- + IPRLOC=0 + EVJ=XDRCST('eV','J')*1.0E22 + VPH=0.0 + VPHV(:NBMIX)=0.0 + DO 60 IU=1,NGROUP + DO 40 IBM=1,NBMIX + VPHV(IBM)=VPHV(IBM)+VX(IBM)*FLUMIX(IU,IBM) + 40 CONTINUE + DO 50 ICMB=1,NCOMB + IBM=MILVO(ICMB) + IF(IBM.EQ.0) GO TO 50 + IF(MIXPWR(IBM).EQ.1) VPH=VPH+VX(IBM)*FLUMIX(IU,IBM) + 50 CONTINUE + 60 CONTINUE + SIG(:NVAR+1,:NREAC+1,:NBMIX)=0.0 + IF(NREAC-1.GT.MAXREA) CALL XABORT('EVOSIG: MAXREA OVERFLOW.') + DO 70 IREAC=2,NREAC + WRITE(NAMDXS(IREAC-1),'(A4,A2)') HREAC(1,IREAC),HREAC(2,IREAC) + 70 CONTINUE + DO 220 IBM=1,NBMIX + IF(VX(IBM).EQ.0) GO TO 220 + DO 210 IST=1,NVAR+NSUPS + K=JM(IBM,IST) + IF(K.EQ.0) THEN + GO TO 210 + ELSE IF(K.GT.0) THEN +* DEPLETING ISOTOPE. + IS=IST + FACT=1.0 + ELSE +* STABLE ISOTOPE PRODUCING ENERGY. + K=-K + IS=NVAR+1 + FACT=DEN(K)*VX(IBM) + ENDIF + SIG(IS,NREAC+1,IBM)=SIG(IS,NREAC+1,IBM)+FACT*RER(1,IST)*RRD(IST) + IF(INR.EQ.0) GO TO 210 +*---- +* RECOVER KERMA FACTORS, IF AVAILABLE +*---- + KPLIB=IPISO(K) ! set K-th isotope + IF(.NOT.C_ASSOCIATED(KPLIB)) THEN + WRITE(HSMG,'(17HEVOSIG: ISOTOPE '',3A4,19H'' IS NOT AVAILABLE , + > 16HIN THE MICROLIB.)') (ISONAM(I0,K),I0=1,3) + CALL XABORT(HSMG) + ENDIF + CALL LCMLEN(KPLIB,'H-FACTOR',LENGT,ITYLCM) + LKERMA=LENGT.EQ.NGROUP + IF(LKERMA) THEN + ALLOCATE(ZKERMA(NGROUP)) + CALL LCMGET(KPLIB,'H-FACTOR',ZKERMA) + GAR=0.0D0 + DO 100 IU=1,NGROUP + GAR=GAR+1.0E-6*DBLE(ZKERMA(IU)*FLUMIX(IU,IBM)) ! convert to MeV + 100 CONTINUE + IF(IGLOB.EQ.-1) THEN + ! use the empirical EDEPMODE=0 Serpent formula + ! R. Tuominen et al., ANE 129 (2019) 224–232. + K=JM(IBM,IS235) + IF(K.EQ.0) CALL XABORT('EVOSIG: NO U235 INFO(2).') + KPLIB5=IPISO(K) + IF(.NOT.C_ASSOCIATED(KPLIB5)) THEN + WRITE(HSMG,'(42HEVOSIG: ISOTOPE U235 IS NOT AVAILABLE IN T, + > 12HHE MICROLIB.)') (ISONAM(I0,K),I0=1,3) + CALL XABORT(HSMG) + ENDIF + ALLOCATE(ZNFTOT(NGROUP)) + CALL LCMGET(KPLIB5,'H-FACTOR',ZKERMA) + CALL LCMGET(KPLIB5,'NFTOT',ZNFTOT) + GAR1=0.0D0 + GAR2=0.0D0 + DO 110 IU=1,NGROUP + GAR1=GAR1+1.0E-6*DBLE(ZKERMA(IU)*FLUMIX(IU,IBM)) + GAR2=GAR2+DBLE(ZNFTOT(IU)*FLUMIX(IU,IBM)) + 110 CONTINUE + GAR=202.27D0*GAR*GAR2/GAR1 + DEALLOCATE(ZNFTOT) + ENDIF + SIG(IS,NREAC,IBM)=SIG(IS,NREAC,IBM)+1.0E-3*FACT*REAL(GAR) + DEALLOCATE(ZKERMA) + ELSE + IF(IGLOB.EQ.-1) THEN + CALL XABORT('EVOSIG: EDP0 OPTION NEEDS H-FACTOR INFORMATION.') + ENDIF + ENDIF +*---- +* RECOVER MULTIGROUP XS +*---- + DO 150 IXSPER=1,NXSPER + CALL XDRLXS(KPLIB,-1,IPRLOC,NREAC-1,NAMDXS,IXSPER,NGROUP,XSREC) + DO 140 IREAC=2,NREAC + CALL LCMLEN(KPLIB,NAMDXS(IREAC-1),LENGT,ITYLCM) + IF((LENGT.NE.NGROUP).AND.(IDR(IREAC,IST).GT.0)) THEN + IF((IREAC.EQ.2).AND.(MOD(IDR(2,IST),100).EQ.5)) GO TO 120 + IF(IMPX.GT.90) CALL LCMLIB(KPLIB) + IF(IMPX.GT.3) THEN + WRITE(HSMG,'(17HEVOSIG: REACTION ,A6,18H IS MISSING FOR IS, + 1 7HOTOPE '',3A4,2H''.)') NAMDXS(IREAC-1),(ISONAM(I0,K),I0=1,3) + WRITE(IOUT,'(1X,A)') HSMG + ENDIF + ENDIF + 120 GAR=0.0D0 + DO 130 IU=1,NGROUP + GAR=GAR+DBLE(XSREC(IU,IREAC-1)*FLUMIX(IU,IBM)) + 130 CONTINUE + SIG(IS,IREAC-1,IBM)=SIG(IS,IREAC-1,IBM)+1.0E-3*FACT*REAL(GAR)* + 1 DELTAT(IXSPER) + ! if(LKERMA), add energy from lumped isotopes not present in the + ! microlib. Otherwise, add energy for all isotopes. + IF(IGLOB.NE.-1) THEN + ! Lumped energy is not included with EDEPMODE=0. + SIG(IS,NREAC,IBM)=SIG(IS,NREAC,IBM)+1.0E-3*FACT*RER(IREAC,IST)* + 1 REAL(GAR)*DELTAT(IXSPER) + ENDIF + 140 CONTINUE + 150 CONTINUE + 210 CONTINUE + 220 CONTINUE +*---- +* CONSTANT FLUX OR CONSTANT POWER NORMALIZATION +*---- + PFACT=1.0 + PHI=0.0 + VTOT=0.0 + DO 230 ICMB=1,NCOMB + IBM=MILVO(ICMB) + IF(IBM.EQ.0) GO TO 230 + IF(MIXPWR(IBM).EQ.1) VTOT=VTOT+VX(IBM) + 230 CONTINUE + IF(INR.EQ.1) THEN + PHI=FIT*1.E-13 + ELSE IF(INR.GE.2) THEN + GAR=0.0D0 + GARD=0.0D0 + DO 245 ICMB=1,NCOMB + IBM=MILVO(ICMB) + IF(IBM.EQ.0) GO TO 245 + IF(MIXPWR(IBM).EQ.1) THEN + DO 240 IS=1,NVAR + IF((IGLOB.EQ.-1).AND.(AWR(IS).LE.210.0)) GO TO 240 + K=JM(IBM,IS) + IF(K.GT.0) THEN + IF(DEN(K).EQ.0.0) GO TO 240 + GAR=GAR+VX(IBM)*DEN(K)*SIG(IS,NREAC,IBM) + GARD=GARD+VX(IBM)*DEN(K)*SIG(IS,NREAC+1,IBM) + ENDIF + 240 CONTINUE + ENDIF + 245 CONTINUE + GAR1=GAR + DO 250 ICMB=1,NCOMB + IBM=MILVO(ICMB) + IF(IBM.EQ.0) GO TO 250 + IF(MIXPWR(IBM).EQ.1) GAR1=GAR1+SIG(NVAR+1,NREAC,IBM) + 250 CONTINUE + GAR2=GAR + DO 260 IBM=1,NBMIX + IF(MIXPWR(IBM).EQ.1) GAR2=GAR2+SIG(NVAR+1,NREAC,IBM) + 260 CONTINUE + PFACT=REAL(GAR2/GAR1) + IF((IGLOB.EQ.1).OR.(INR.EQ.3)) THEN + GAR=GAR2 + ELSE + GAR=GAR1 + ENDIF + IF(GAR.EQ.0.0D0) CALL XABORT('EVOSIG: UNABLE TO NORMALIZE.') + IF(INR.EQ.2) THEN +* FITD IS THE DECAY POWER IN WATT PER GRAM. + FITD=(EVJ*GARD)/(FUELDN(1)*VTOT) + IF(FITD.GT.FIT) THEN + WRITE(HSMG,'(35HEVOSIG: NEGATIVE FIT(1) FIT(DECAY)=,1P, + 1 E11.4,12H FIT(INPUT)=,E11.4,1H.)') FITD,FIT + CALL XABORT(HSMG) + ENDIF + PHI=(FIT-FITD)*FUELDN(1)*VPH/(EVJ*GAR) + ELSE IF(INR.EQ.3) THEN +* FITD IS THE DECAY POWER IN WATT PER CUBIC CENTIMETER. + FITD=(EVJ*GARD*FUELDN(3))/(FUELDN(1)*VTOT) + IF(FITD.GT.FIT) THEN + WRITE(HSMG,'(35HEVOSIG: NEGATIVE FIT(2) FIT(DECAY)=,1P, + 1 E11.4,12H FIT(INPUT)=,E11.4,1H.)') FITD,FIT + CALL XABORT(HSMG) + ENDIF + PHI=(FIT-FITD)*FUELDN(1)*VPH/(EVJ*GAR*FUELDN(3)) + ENDIF + ENDIF + IF(IMPX.GT.0) WRITE(IOUT,6000) PHI*1.0E+13 + IF(INR.GT.0) THEN + FNORM=PHI*VTOT/VPH + DO 290 IBM=1,NBMIX + VPHV(IBM)=VPHV(IBM)*REAL(FNORM) + DO 280 IQ=1,NREAC + DO 270 IS=1,NVAR+1 + SIG(IS,IQ,IBM)=SIG(IS,IQ,IBM)*REAL(FNORM) + 270 CONTINUE + 280 CONTINUE + 290 CONTINUE + ELSE + VPHV(:NBMIX)=0.0 + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XSREC) + RETURN +* + 6000 FORMAT(/' EVOSIG: flux level =',1P,E12.4,' n/cm^2/s.') + END diff --git a/Dragon/src/EVOSOL.f b/Dragon/src/EVOSOL.f new file mode 100644 index 0000000..d256faa --- /dev/null +++ b/Dragon/src/EVOSOL.f @@ -0,0 +1,229 @@ +*DECK EVOSOL + SUBROUTINE EVOSOL(IMPX,LCOOL,NVAR,NREAC,NDFP,NPAR,NFISS,XT,EPS1, + 1 EXPMAX,H1,ITYPE,IDIRAC,DCR,KPAR,BPAR,KFISS,KPF,YIELD,LP,IEVOLB, + 2 SIG1,SIG2,NVAR2,NFISS2,NSUPF2,MU1,IMA,MAXA,YDPL,ICHAIN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Put the depletion matrix system in sparse storage mode for a single +* depleting mixture. Solve this system between times XT(1) and XT(2). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* IMPX print flag (equal to zero for no print). +* LCOOL out-of-core depletion flag (LCOOL=.true. to set flag). +* NVAR number of depleting nuclides. +* NREAC one plus the number of neutron-induced depletion reactions. +* NDFP number of direct fission products (fission fragments). +* NPAR maximum number of parent nuclides in the depletion chain. +* NFISS number of fissile isotopes producing fission products. +* XT initial and final time (independent variable). +* EPS1 required accuracy for the ODE solver. +* EXPMAX saturation limit. A nuclide is saturating if +* -ADPL(MU1(I))*(XT(2)-XT(1)).GT.EXPMAX. Suggested value: +* EXPMAX=80.0. +* H1 guessed first stepsize. +* ITYPE type of ODE solution: +* =1 fifth-order Runge-Kutta method; +* =2 fourth-order Kaps-Rentrop method. +* IDIRAC saturation model flag (=1 to use Dirac function contributions +* in the saturating nuclide number densities). +* DCR sum of radioactive decay constants in 10**-8/s +* KPAR position in chain of the parent nuclide and type of +* reaction. +* BPAR branching ratio for neutron induced reactions. +* KFISS position in chain of the fissile isotopes. +* KPF position in chain of the direct fission products (fission +* fragments). +* YIELD fission yields. +* LP index vector used to remove unused isotopes from the +* depletion chain. +* IEVOLB flag making an isotope non-depleting: +* =1 to force an isotope to be non-depleting; +* =2 to force an isotope to be depleting; +* =3 to force an isotope to be at saturation. +* SIG1 initial reaction rates for nuclide I: +* SIG1(I,1) fission reaction rate; +* SIG1(I,2) gamma reaction rate; +* SIG1(I,3) N2N reaction rate; +* ...; +* SIG1(I,NREAC) neutron-induced energy; +* SIG1(I,NREAC+1) decay energy released. +* SIG2 final reaction rates. +* NVAR2 number of used isotopes in the depletion chain, where +* NVAR2=max(LP(I)). +* NFISS2 number of used fissile isotopes producing fission products. +* NSUPF2 number of used fission products. +* MU1 position of each diagonal element in matrix ADPL. +* IMA position of the first non-zero column element in matrix ADPL. +* MAXA first dimension of matrix ADPL. +* YDPL initial/final number density of each depleting isotope. +* YDPL(NVAR+1,2) is the stage burnup increment. +* ICHAIN name of the used isotopes in the depletion chain. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + LOGICAL LCOOL + INTEGER IMPX,NVAR,NREAC,NDFP,NPAR,NFISS,ITYPE,IDIRAC, + 1 KPAR(NPAR,NVAR),KFISS(NFISS),KPF(NDFP),LP(NVAR),IEVOLB(NVAR), + 2 NVAR2,NFISS2,NSUPF2,MU1(NVAR2+1),IMA(NVAR2+1),MAXA, + 3 ICHAIN(2,NVAR2+1) + REAL XT(2),EPS1,EXPMAX,H1,DCR(NVAR),BPAR(NPAR,NVAR), + 1 YIELD(NFISS,NDFP),SIG1(NVAR+1,NREAC+1),SIG2(NVAR+1,NREAC+1), + 2 YDPL(NVAR+1,2) +*---- +* LOCAL VARIABLES +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: LQ,KFISS2,IEVOL2 + REAL, ALLOCATABLE, DIMENSION(:,:) :: ADPL,BDPL,YDPL2 + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: YSF +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(LQ(NFISS),KFISS2(NFISS2),IEVOL2(NVAR2+1)) + ALLOCATE(ADPL(MAXA,2),BDPL(NVAR2+1,2),YSF(NFISS2,NSUPF2+1,2), + 1 YDPL2(NVAR2+1,2)) +*---- +* COMPUTE LQ AND KFISS2 +*---- + I0=0 + DO 10 I=1,NFISS + LQ(I)=0 + IF(KFISS(I).EQ.0) GO TO 10 + IF((LP(KFISS(I)).EQ.0).OR.(LP(KFISS(I)).GT.NVAR2)) GO TO 10 + I0=I0+1 + IF(I0.GT.NFISS2) CALL XABORT('EVOSOL: NFISS2 TOO SMALL.') + KFISS2(I0)=LP(KFISS(I)) + LQ(I)=I0 + 10 CONTINUE +*---- +* BUILD THE SPARSE DEPLETION MATRICES ADPL, BDPL AND YSF +*---- + DO 80 IP=1,2 + DO 20 I=1,IMA(NVAR2+1) + ADPL(I,IP)=0.0 + 20 CONTINUE + BDPL(NVAR2+1,IP)=0.0 + DO 40 IS=1,NVAR + IF((LP(IS).EQ.0).OR.(LP(IS).GT.NVAR2)) GO TO 40 + BDPL(LP(IS),IP)=0.0 + SIGE=0.0 + IF((.NOT.LCOOL).AND.(IP.EQ.1)) THEN + DO 25 IREAC=1,NREAC-1 + SIGE=SIGE+SIG1(IS,IREAC) + 25 CONTINUE + ELSE IF((.NOT.LCOOL).AND.(IP.EQ.2)) THEN + DO 26 IREAC=1,NREAC-1 + SIGE=SIGE+SIG2(IS,IREAC) + 26 CONTINUE + ENDIF + ADPL(MU1(LP(IS)),IP)=-SIGE-DCR(IS) + DO 30 IPAR=1,NPAR + IF(KPAR(IPAR,IS).EQ.0) GO TO 40 + IF(KPAR(IPAR,IS).EQ.2) GO TO 30 + JS=KPAR(IPAR,IS)/100 + KT=KPAR(IPAR,IS)-JS*100 + IF((LCOOL.AND.(KT.GE.2)).OR.(LP(JS).EQ.0).OR.(LP(JS).GT.NVAR2)) + 1 GO TO 30 + SIGE=0.0 + IF(KT.EQ.1) THEN + SIGE=BPAR(IPAR,IS)*DCR(JS) + ELSE IF((KT.GE.3).AND.(IP.EQ.1)) THEN + SIGE=BPAR(IPAR,IS)*SIG1(JS,KT-1) + ELSE IF((KT.GE.3).AND.(IP.EQ.2)) THEN + SIGE=BPAR(IPAR,IS)*SIG2(JS,KT-1) + ELSE + CALL XABORT('EVOSOL: UNKNOWN REACTION.') + ENDIF + IF(LP(JS).LE.LP(IS)) THEN + ADPL(MU1(LP(IS))-LP(IS)+LP(JS),IP)= + 1 ADPL(MU1(LP(IS))-LP(IS)+LP(JS),IP)+SIGE + ELSE + ADPL(MU1(LP(JS))+LP(JS)-LP(IS),IP)= + 1 ADPL(MU1(LP(JS))+LP(JS)-LP(IS),IP)+SIGE + ENDIF + 30 CONTINUE + 40 CONTINUE + IF(LCOOL) THEN + DO 51 IFIS=1,NFISS2 + DO 50 ISUPF=1,NSUPF2+1 + YSF(IFIS,ISUPF,IP)=0.0 + 50 CONTINUE + 51 CONTINUE + ELSE +* ADD ONE EQUATION TO COMPUTE THE BURNUP. + DO 55 JS=1,NVAR + IF((LP(JS).EQ.0).OR.(LP(JS).GT.NVAR2)) GO TO 55 + IF(IP.EQ.1) THEN + ADPL(MU1(NVAR2+1)-(NVAR2+1)+LP(JS),IP)=SIG1(JS,NREAC)+ + & SIG1(JS,NREAC+1) + ELSE IF(IP.EQ.2) THEN + ADPL(MU1(NVAR2+1)-(NVAR2+1)+LP(JS),IP)=SIG2(JS,NREAC)+ + & SIG2(JS,NREAC+1) + ENDIF + 55 CONTINUE +* +* ADD THE FISSION YIELD CONTRIBUTIONS. + DO 70 IFIS=1,NFISS + IF(LQ(IFIS).EQ.0) GO TO 70 + DO 56 ISUPF=1,NSUPF2+1 + YSF(LQ(IFIS),ISUPF,IP)=0.0 + 56 CONTINUE + IF(NSUPF2.EQ.0) GO TO 70 + DO 60 ISUPF=1,NDFP + LPP=LP(KPF(ISUPF)) + IF((LPP.EQ.0).OR.(LPP.GT.NVAR2)) GO TO 60 + IF(LPP+NSUPF2.LE.NVAR2) CALL XABORT('EVOSOL: FAILURE.') + IF(IP.EQ.1) THEN + YSF(LQ(IFIS),LPP-NVAR2+NSUPF2,IP)=YIELD(IFIS,ISUPF)* + 1 SIG1(KFISS(IFIS),1) + ELSE IF(IP.EQ.2) THEN + YSF(LQ(IFIS),LPP-NVAR2+NSUPF2,IP)=YIELD(IFIS,ISUPF)* + 1 SIG2(KFISS(IFIS),1) + ENDIF + 60 CONTINUE + 70 CONTINUE + ENDIF + 80 CONTINUE +*---- +* SOLVE THE DEPLETION SYSTEM. EQUATION NVAR2+1 IS USED TO COMPUTE +* THE BURNUP +*---- + YDPL2(:NVAR2+1,1)=0.0 + IEVOL2(:NVAR2+1)=0 + DO 90 IS=1,NVAR + IF((LP(IS).EQ.0).OR.(LP(IS).GT.NVAR2)) GO TO 90 + YDPL2(LP(IS),1)=YDPL(IS,1) + IEVOL2(LP(IS))=IEVOLB(IS) + 90 CONTINUE + CALL EVODPL(IMPX,YDPL2(1,1),NVAR2+1,XT,EPS1,EXPMAX,H1,ITYPE, + 1 IDIRAC,IEVOL2,MU1,IMA,MAXA,NSUPF2+1,NFISS2,KFISS2,YSF,ADPL, + 2 BDPL,ICHAIN) + YDPL(NVAR+1,2)=YDPL2(NVAR2+1,2) + DO 100 IS=NVAR,1,-1 + IF((LP(IS).EQ.0).OR.(LP(IS).GT.NVAR2)) THEN + YDPL(IS,2)=YDPL(IS,1) + ELSE + YDPL(IS,1)=YDPL2(LP(IS),1) + YDPL(IS,2)=MAX(0.0,YDPL2(LP(IS),2)) + ENDIF + 100 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(YDPL2,YSF,BDPL,ADPL) + DEALLOCATE(IEVOL2,KFISS2,LQ) + RETURN + END diff --git a/Dragon/src/EXCELP.f b/Dragon/src/EXCELP.f new file mode 100644 index 0000000..77a9fab --- /dev/null +++ b/Dragon/src/EXCELP.f @@ -0,0 +1,624 @@ +*DECK EXCELP + SUBROUTINE EXCELP( IPTRK, IFTRAK, IPRNTP, NSOUT, NREG, NBMIX, + > MATCOD, NRENOR, XSSIGT, IPIJK, N2PRO, NSBG, + > NPSYS, NBATCH, TITREC, NALBP, ALBP, MATALB, + > VOLSUR, DPROB, DPROBX ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the collision probabilities for EXCELL. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK unit of the sequential binary tracking file. +* IPRNTP print flag (equal to zero for no print). +* NSOUT number of surfaces. +* NREG total number of merged blocks for which specific values +* of the neutron flux and reactions rates are required. +* NBMIX number of mixtures (NBMIX=max(MATCOD(i))). +* MATCOD index number of the mixture type assigned to each volume. +* NRENOR normalization scheme for PIJ matrices. +* XSSIGT total macroscopic cross sections ordered by mixture. +* IPIJK pij option (=1 pij, =4 pijk). +* N2PRO number of terms in collision probability matrices, including +* surface and volume contributions. +* NSBG number of energy groups. +* NPSYS non-converged energy group indices. +* NBATCH number of tracks processed in each OpenMP core (default: =1). +* TITREC title. +* NALBP number of multigroup physical albedos. +* ALBP multigroup physical albedos. +* +*Parameters: output +* MATALB global mixture/albedo identification vector. +* VOLSUR global surface volume vector. +* DPROB collision probabilities. +* DPROBX directional collision probabilities. +* +*----------------------------------------------------------------------- +*--------+---------------- R O U T I N E S -------------+--+-----------* +* NAME / DESCRIPTION * +*--------+-------------------------------------------------------------* +* CP INtegration +* PIJI2D / TO INTEGRATE CP IN 2D GEOMETRIES (ISOTROPIC B.C.) +* PIJI3D / TO INTEGRATE CP IN 3D GEOMETRIES (ISOTROPIC B.C.) +* PIJS2D / TO INTEGRATE CP IN 2D GEOMETRIES (SPECULAR B.C.) +* PIJS3D / TO INTEGRATE CP IN 3D GEOMETRIES (SPECULAR B.C.) +* CP Normalisation +* PIJRDG / TO RENORMALIZE CP USING DIAGONAL COEFFICIENTS +* PIJRGL / TO RENORMALIZE CP USING GELBARD HOMOGENEOUS SCHEME +* PIJRNL / TO RENORMALIZE CP USING NON-LINEAR FACTORS +* PIJRHL / TO RENORMALIZE CP USING HELIOS METHOD +* Various functions +* PIJWPR / TO PRINT CP MATRICES IN SUM FORMAT +* PIJCMP / COMPRESS CP MATRIX TO SYMETRIC FORMAT +* Inline tracking +* NXTTGC / TRACK CYCLIC NXT LINE IN GEOMETRY +* NXTTGS / TRACK STANDARD NXT LINE IN GEOMETRY +* NXTXYZ / READ GEOMETRY LIMITS +*--------+-------------------------------------------------------------* +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER TITREC*72 + TYPE(C_PTR) IPTRK + INTEGER IFTRAK,IPRNTP,NSOUT,NREG,NBMIX,MATCOD(NREG), + > NRENOR,IPIJK,N2PRO,NSBG,NPSYS(NSBG),NBATCH, + > NALBP,MATALB(-NSOUT:NREG) + REAL XSSIGT(0:NBMIX,NSBG),ALBP(NALBP,NSBG), + > VOLSUR(-NSOUT:NREG,NSBG) + LOGICAL SWNZBC + DOUBLE PRECISION DPROB(N2PRO,NSBG),DPROBX(N2PRO,NSBG) +*---- +* LOCAL VARIABLES +*---- + INTEGER IOUT, ICPALL, ICPEND, MXGAUS, NSTATE + PARAMETER ( IOUT=6, ICPALL=4, ICPEND=3, MXGAUS=64, + > NSTATE=40 ) + CHARACTER NAMSBR*6 + PARAMETER ( NAMSBR='EXCELP') + INTEGER MKI1, MKI2, MKI3, MKI4, MKI5 + PARAMETER (MKI1=600,MKI2=600,MKI3=600,MKI4=600,MKI5=600) + INTEGER ISTATE(NSTATE),ICODE(6) + INTEGER NPROB,ISBG,KSBG,ITYPBC + REAL ALBEDO(6),EXTKOP(NSTATE),CUTOF,RCUTOF,ASCRP, + > YGSS,XGSS(MXGAUS),WGSS(MXGAUS),WGSSX(MXGAUS), + > ALBG(6) + LOGICAL SWVOID, LPIJK + CHARACTER CTRKT*4, COMENT*80 + DOUBLE PRECISION DANG0,DASCRP +* + INTEGER JJ,MSYM,IL,NALLOC,ITRAK,IANG,IC,IPRT,ISPEC, + > IUN,KSPEC,LOPT,MXSEG,NALBG,NANGL,NCOMNT,NCOR, + > NCORT,NDIM,NGSS,NREG2,NSCRP,NTRK,NUNKNO,JGSS, + > JUN,IFMT,MXSUB,ISA,IBATCH,IL1 ,III,IND,I,J +*---- +* Variables for NXT: inline tracking +*---- + INTEGER ILCMUP,ILCMDN + PARAMETER (ILCMUP=1,ILCMDN=2) + DOUBLE PRECISION DZERO,DONE,DTWO + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) + INTEGER IEDIMG(NSTATE),NPOINT,NBUCEL,MXMSH,MAXPIN, + > MXGSUR,MXGREG,MAXMSH,NPLANE,NUCELL(3) + CHARACTER NAMREC*12 +*---- +* Allocatable arrays +*---- + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DSV + REAL, ALLOCATABLE, TARGET, DIMENSION(:,:) :: SIGTAL,SIGT00 + REAL, POINTER, DIMENSION(:,:) :: SIGT +*-- NXT TRACKING + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IUNFLD + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DVNOR,DWGTRK + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: DGMESH,DANGLT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: DORITR +*-- Temporary arrays + REAL, ALLOCATABLE, DIMENSION(:) :: LOPATH + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SIGANG + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: STAYIN,GOSOUT +*-- Tracking file arrays + INTEGER, ALLOCATABLE, DIMENSION(:) :: NCOIL1,NSUB,NBSEG + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NUMERO + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: WEIGHT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: LENGTH +*---- +* Common blocks for Bickley functions +*---- + INTEGER L1, L2, L3, L4, L5 + REAL PAS1,XLIM1,PAS2,XLIM2,PAS3,XLIM3, + > PAS4,XLIM4,PAS5,XLIM5,BI1,BI2,BI3,BI4,BI5 + COMMON /BICKL1/ BI1(0:MKI1,3),PAS1,XLIM1,L1 + COMMON /BICKL2/ BI2(0:MKI2,3),PAS2,XLIM2,L2 + COMMON /BICKL3/ BI3(0:MKI3,3),PAS3,XLIM3,L3 + COMMON /BICKL4/ BI4(0:MKI4,3),PAS4,XLIM4,L4 + COMMON /BICKL5/ BI5(0:MKI5,3),PAS5,XLIM5,L5 + DOUBLE PRECISION ABSC(3,2) + + III(I,J)=(J+NSOUT)*NUNKNO+I+NSOUT+1 + IND(I,J) = MAX(I+NSOUT+1,J+NSOUT+1)*(MAX(I+NSOUT+1,J+NSOUT+1)-1)/2 + 1 + MIN(I+NSOUT+1,J+NSOUT+1) +*---- +* RECOVER EXCELL SPECIFIC TRACKING INFORMATION. +* ALBEDO: SURFACE ALBEDOS (REAL(6)) +* KSPEC : KIND OF PIJ INTEGRATION (0:ISOTROPE,1:SPECULAR) +* CUTOF : MFP CUTOFF FOR SPECULAR INTEGRATION +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + KSPEC=ISTATE(10) + CALL LCMGET(IPTRK,'EXCELTRACKOP',EXTKOP) + CUTOF=EXTKOP(1) + CALL LCMGET(IPTRK,'ICODE',ICODE) + CALL LCMGET(IPTRK,'ALBEDO',ALBG) +* + IPRT = IPRNTP + IF( IPRT.GE.ICPEND ) WRITE(IOUT,'(1X,A72//)') TITREC + NPLANE = 1 + IF(IFTRAK .NE. 0) THEN + READ(IFTRAK) CTRKT,NCOMNT,NTRK,IFMT + IF( CTRKT .NE.'$TRK' .OR. + > NCOMNT.LT.0 .OR. + > NTRK .EQ.0 ) CALL XABORT(NAMSBR// + > ': Invalid tracking file') + DO IC= 1,NCOMNT + READ(IFTRAK) COMENT + ENDDO + READ(IFTRAK) NDIM,ISPEC,NREG2,NSOUT,NALBG,NCOR,NANGL,MXSUB,MXSEG + IF(NREG2.NE.NREG )THEN + CALL XABORT(NAMSBR//': TRACKING FILE HAS INVALID # OF ZONES') + ENDIF + NCORT=NCOR + ELSE + IF(ISTATE(7) .NE. 4) CALL XABORT(NAMSBR// + > ': Tracking file required unless NXT: tracking provided') + NREG2=ISTATE(1) + IF(NREG2.NE.NREG )THEN + CALL XABORT(NAMSBR//': STATE VECTOR HAS INVALID # OF ZONES') + ENDIF + NSOUT=ISTATE(5) + ISPEC=ISTATE(9) + NPOINT=ISTATE(17) + MXSEG=ISTATE(18) + NANGL=ISTATE(20) + NPLANE=ISTATE(25) + CALL LCMSIX(IPTRK,'NXTRecords ',ILCMUP) + CALL LCMGET(IPTRK,'G00000001DIM',IEDIMG) + NDIM=IEDIMG(1) + ITYPBC=IEDIMG( 2) + NBUCEL=IEDIMG( 5) + NUCELL(1)=IEDIMG(13) + NUCELL(2)=IEDIMG(14) + NUCELL(3)=IEDIMG(15) + MXMSH=IEDIMG(16) + MAXPIN=IEDIMG(19) + MXGSUR=IEDIMG(24) + MXGREG=IEDIMG(25) + NCOR=1 + NCORT=NCOR + NTRK=NANGL*NPLANE*NPOINT**(NDIM-1) + IF(MXSEG .LE. 1) THEN + IF(ISPEC .EQ. 0) THEN + MXSEG=NBUCEL* + > ((MAXPIN+1)*(2*MXGREG+2)+MXGSUR+16) + ELSE + MXSEG=8*NANGL*NBUCEL* + > ((MAXPIN+1)*(2*MXGREG+2)+MXGSUR+16) + ENDIF + ENDIF + MAXMSH=MAX(MXMSH,IEDIMG(17),IEDIMG(20)) + ENDIF + NUNKNO= NREG+NSOUT+1 + IF(IFTRAK .NE. 0) THEN + READ(IFTRAK) (VOLSUR(JUN,1),JUN=-NSOUT,NREG) + READ(IFTRAK) (MATALB(JUN),JUN=-NSOUT,NREG) + READ(IFTRAK) ( NSCRP,JUN=1,NALBG) + READ(IFTRAK) ( ASCRP,JUN=1,NALBG) + READ(IFTRAK) DANG0,(DASCRP,IUN=2,NDIM), + > ((DASCRP,IUN=1,NDIM),JUN=2,NANGL) + READ(IFTRAK) (DASCRP,JUN=1,NANGL) + ELSE + CALL LCMGET(IPTRK,'MATALB ',MATALB) + ALLOCATE(DSV(-NSOUT:NREG)) + CALL LCMGET(IPTRK,'SAreaRvolume',DSV) + DO JJ=-NSOUT,0 + VOLSUR(JJ,1)=0.25*REAL(DSV(JJ)) + ENDDO + DO JJ=1,NREG + VOLSUR(JJ,1)=REAL(DSV(JJ)) + ENDDO +*---- +* Allocate memory for NXT tracking +*---- + ALLOCATE(DGMESH(-1:MAXMSH,4)) + CALL NXTXYZ(IPTRK,IPRNTP,NDIM,ITYPBC,MAXMSH,NUCELL,ABSC,DGMESH) + ALLOCATE(IUNFLD(2,NBUCEL)) + ALLOCATE(DANGLT(NDIM,NANGL),DORITR(NDIM*(NDIM+1),NPLANE,NANGL), + > DWGTRK(NANGL),DVNOR(NREG)) + NAMREC='G00000001CUF' + CALL LCMGET(IPTRK,NAMREC,IUNFLD) + CALL LCMGET(IPTRK,'TrackingDirc',DANGLT) + CALL LCMGET(IPTRK,'TrackingOrig',DORITR) + CALL LCMGET(IPTRK,'TrackingWgtD',DWGTRK) + CALL LCMGET(IPTRK,'VTNormalize ',DVNOR) + ENDIF + DO ISBG=2,NSBG + DO IUN= -NSOUT, NREG + VOLSUR(IUN,ISBG)=VOLSUR(IUN,1) + ENDDO + ENDDO +*---- +* PREPARE FOR MULTIGROUP CALCULATION +*---- + ALLOCATE(SIGTAL(-NSOUT:NREG,NSBG),SIGT00(-NSOUT:NREG,NSBG)) + LPIJK= IPIJK.EQ.4 + SWNZBC= .FALSE. + SWVOID= .FALSE. + DO ISBG=1,NSBG + IF(NPSYS(ISBG).NE.0) THEN + DO ISA=1,6 + ALBEDO(ISA)=ALBG(ISA) + ENDDO + IF(NALBP .GT. 0) THEN + DO ISA=1,6 + IF(ICODE(ISA).GT.0) ALBEDO(ISA)=ALBP(ICODE(ISA),ISBG) + ENDDO + ENDIF + DO IUN= -NSOUT, -1 + SIGT00(IUN,ISBG)= 0.0 + SIGTAL(IUN,ISBG)= ALBEDO(-MATALB(IUN)) + SWNZBC= SWNZBC.OR.(SIGTAL(IUN,ISBG).NE.0.0) + ENDDO + IUN=0 + SIGT00(IUN,ISBG)= 0.0 + SIGTAL(IUN,ISBG)= 0.0 + DO IUN= 1, NREG + SIGT00(IUN,ISBG)= XSSIGT(MATCOD(IUN),ISBG) + SIGTAL(IUN,ISBG)= XSSIGT(MATCOD(IUN),ISBG) + IF( SIGTAL(IUN,ISBG) .EQ. 0.0 )THEN + SWVOID= .TRUE. + ELSE + VOLSUR(IUN,ISBG)=VOLSUR(IUN,ISBG)*SIGTAL(IUN,ISBG) + ENDIF + ENDDO + ENDIF + ENDDO +*---- +* CHOOSE ISOTROPIC OR SPECULAR B.C. +*---- + IF( KSPEC.EQ.0 )THEN + SIGT => SIGT00 + ELSE + SIGT => SIGTAL + ENDIF +* + NPROB = (NUNKNO*(NUNKNO+1))/2 + N2PRO = NUNKNO*NUNKNO + IF(IPRNTP .GT. 1) THEN + NALLOC=(2*N2PRO*NSBG) + IF(LPIJK) NALLOC=NALLOC+(2*N2PRO*NSBG) + WRITE(IOUT,6000) NALLOC/256 + ENDIF + DPROB(:N2PRO,:NSBG)=0.0D0 + IF(LPIJK) DPROBX(:N2PRO,:NSBG)=0.0D0 + IF(IPRNTP.GT.1) WRITE(IOUT,6001) +* + IF(IPRNTP .GE. 10) WRITE(IOUT,6010) MXSEG +*---- +* BATCH TRACKING STORAGE ALLOCATION +*---- + ALLOCATE(NCOIL1(NBATCH),NSUB(NBATCH),NBSEG(NBATCH),WEIGHT(NBATCH), + 1 NUMERO(MXSEG,NBATCH),LENGTH(MXSEG,NBATCH)) + IF( ISPEC.EQ.0 )THEN +*---- +* Standard tracking +*---- + IF( NDIM.EQ.2 )THEN + ALLOCATE(LOPATH(MXSEG)) + DO IBATCH=1,(NTRK-1)/NBATCH+1 + DO ITRAK=(IBATCH-1)*NBATCH+1,MIN(IBATCH*NBATCH,NTRK) + IL1=ITRAK-(IBATCH-1)*NBATCH + IF(IFTRAK .NE. 0) THEN +*---- +* Read tracks from file +*---- + READ(IFTRAK) NSUB(IL1),NBSEG(IL1),WEIGHT(IL1),IANG, + > (NUMERO(IL,IL1),IL=1,NBSEG(IL1)), + > (LENGTH(IL,IL1),IL=1,NBSEG(IL1)) + IF(NSUB(IL1).NE.1) CALL XABORT('EXCELP: NSUB.NE.1.') + NCOIL1(IL1)=1 + ELSE +*---- +* Generate selected track +*---- + CALL NXTTGS(IPTRK ,IPRNTP,NDIM ,NANGL ,NPOINT,NTRK , + > ITRAK ,MAXMSH,NSOUT ,NREG ,NUCELL,NBUCEL, + > MXGSUR,MXGREG,MAXPIN,MXSEG ,ITYPBC,IUNFLD, + > MATALB,DSV ,DGMESH,DANGLT,DVNOR ,DWGTRK, + > DORITR,NBSEG(IL1) ,NCORT ,WEIGHT(IL1), + > NUMERO(1,IL1),LENGTH(1,IL1)) + NCOIL1(IL1)=NCORT + ENDIF + ENDDO +*$OMP PARALLEL DO +*$OMP1 PRIVATE(IL1,ITRAK,LOPATH) + DO ISBG=1,NSBG + IF(NPSYS(ISBG).EQ.0) CYCLE + DO ITRAK=(IBATCH-1)*NBATCH+1,MIN(IBATCH*NBATCH,NTRK) + IL1=ITRAK-(IBATCH-1)*NBATCH + IF(NCOIL1(IL1).EQ.0) CYCLE + CALL PIJI2D(NREG,NSOUT,NBSEG(IL1),NCOR,SWVOID, + > SIGT(-NSOUT,ISBG),WEIGHT(IL1),LENGTH(1,IL1), + > NUMERO(1,IL1),LOPATH,DPROB(1,ISBG), + > MKI1,BI1,PAS1,L1, + > MKI2,BI2,PAS2,XLIM2,L2, + > MKI3,BI3,PAS3,XLIM3) + ENDDO ! ITRAK + ENDDO ! ISBG +*$OMP END PARALLEL DO + IF(LPIJK)THEN +*$OMP PARALLEL DO +*$OMP1 PRIVATE(IL1,ITRAK,LOPATH) + DO ISBG=1,NSBG + IF(NPSYS(ISBG).EQ.0) CYCLE + DO ITRAK=(IBATCH-1)*NBATCH+1,MIN(IBATCH*NBATCH,NTRK) + IL1=ITRAK-(IBATCH-1)*NBATCH + IF(NCOIL1(IL1).EQ.0) CYCLE + CALL PIJI2D(NREG,NSOUT,NBSEG(IL1),NCOR,SWVOID, + > SIGT(-NSOUT,ISBG),WEIGHT(IL1), + > LENGTH(1,IL1),NUMERO(1,IL1),LOPATH, + > DPROBX(1,ISBG),MKI3,BI3,PAS3,L3, + > MKI4,BI4,PAS4,XLIM4,L4, + > MKI5,BI5,PAS5,XLIM5) + ENDDO ! ITRAK + ENDDO ! ISBG +*$OMP END PARALLEL DO + ENDIF + ENDDO ! IBATCH + DEALLOCATE(LOPATH) + ELSE + ALLOCATE(STAYIN(MXSEG),GOSOUT(MXSEG)) + DO IBATCH=1,(NTRK-1)/NBATCH+1 + DO ITRAK=(IBATCH-1)*NBATCH+1,MIN(IBATCH*NBATCH,NTRK) + IL1=ITRAK-(IBATCH-1)*NBATCH + IF(IFTRAK .NE. 0) THEN + READ(IFTRAK) NSUB(IL1),NBSEG(IL1),WEIGHT(IL1),IANG, + > (NUMERO(IL,IL1),IL=1,NBSEG(IL1)), + > (LENGTH(IL,IL1),IL=1,NBSEG(IL1)) + IF(NSUB(IL1).NE.1) CALL XABORT('EXCELP: NSUB.NE.1.') + NCOIL1(IL1)=1 + ELSE + CALL NXTTGS(IPTRK ,IPRNTP,NDIM ,NANGL ,NPOINT,NTRK , + > ITRAK ,MAXMSH,NSOUT ,NREG ,NUCELL,NBUCEL, + > MXGSUR,MXGREG,MAXPIN,MXSEG ,ITYPBC,IUNFLD, + > MATALB,DSV ,DGMESH,DANGLT,DVNOR ,DWGTRK, + > DORITR,NBSEG(IL1) ,NCORT ,WEIGHT(IL1), + > NUMERO(1,IL1),LENGTH(1,IL1)) + NCOIL1(IL1)=NCORT + ENDIF + ENDDO +*$OMP PARALLEL DO +*$OMP1 PRIVATE(IL1,ITRAK,STAYIN,GOSOUT) + DO ISBG=1,NSBG + IF(NPSYS(ISBG).EQ.0) CYCLE + DO ITRAK=(IBATCH-1)*NBATCH+1,MIN(IBATCH*NBATCH,NTRK) + IL1=ITRAK-(IBATCH-1)*NBATCH + IF(NCOIL1(IL1).EQ.0) CYCLE + CALL PIJI3D(NREG,NSOUT,NBSEG(IL1),NCOR,SWVOID, + > SIGT(-NSOUT,ISBG),WEIGHT(IL1),LENGTH(1,IL1), + > NUMERO(1,IL1),STAYIN,GOSOUT,DPROB(1,ISBG)) + ENDDO ! ITRAK + ENDDO ! ISBG +*$OMP END PARALLEL DO + ENDDO ! IBATCH + DEALLOCATE(GOSOUT,STAYIN) + IF(LPIJK) CALL XABORT(NAMSBR//': 3D PIJK NOT SUPPORTED') + ENDIF + ELSEIF( ISPEC.EQ.1 )THEN +*---- +* CYCLIC TRACKING +*---- + RCUTOF= CUTOF + IF( NDIM.EQ.2 )THEN + IF( DANG0.EQ. 0.0D0 )THEN + NGSS= NANGL/8 + ELSE + NGSS= (NANGL/4+1)/2 + ENDIF + CALL ALGPT( NGSS,0.0,1.0,XGSS,WGSS) + ALLOCATE(SIGANG(NGSS,-NSOUT:NREG,NSBG),STAYIN(NGSS*MXSEG), + > GOSOUT(NGSS*MXSEG)) + DO JGSS= 1, NGSS + YGSS= SQRT(1.0 - XGSS(JGSS)**2) + WGSS(JGSS)= WGSS(JGSS) * YGSS + XGSS(JGSS)= 1.0/YGSS + WGSSX(JGSS)= WGSS(JGSS) / (XGSS(JGSS)**2) + DO ISBG=1,NSBG + IF(NPSYS(ISBG).NE.0) THEN + DO IUN= -NSOUT,NREG + IF( MATALB(IUN).LE.0 )THEN + SIGANG(JGSS,IUN,ISBG)= SIGT(IUN,ISBG) + ELSE + SIGANG(JGSS,IUN,ISBG)= SIGT(IUN,ISBG)*XGSS(JGSS) + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO +*---- +* Loop over tracks +* then loop over groups +*---- + DO IBATCH=1,(NTRK-1)/NBATCH+1 + DO ITRAK=(IBATCH-1)*NBATCH+1,MIN(IBATCH*NBATCH,NTRK) + IL1=ITRAK-(IBATCH-1)*NBATCH + IF(IFTRAK .NE. 0) THEN + READ(IFTRAK) NSUB(IL1),NBSEG(IL1),WEIGHT(IL1), + > (IANG,IL=1,NSUB(IL1)),(NUMERO(IL,IL1),IL=1,NBSEG(IL1)), + > (LENGTH(IL,IL1),IL= 1,NBSEG(IL1)) + NCOIL1(IL1)=1 + ELSE + CALL NXTTGC(IPTRK ,IPRNTP,NDIM ,NANGL ,NPOINT,NTRK , + > ITRAK ,MAXMSH,NSOUT ,NREG ,NUCELL,NBUCEL, + > MXGSUR,MXGREG,MAXPIN,MXSEG ,ITYPBC,IUNFLD, + > MATALB,DSV ,DGMESH,DANGLT,DVNOR ,DWGTRK, + > DORITR,NBSEG(IL1) ,NCORT ,WEIGHT(IL1), + > NUMERO(1,IL1),LENGTH(1,IL1)) + NCOIL1(IL1)=NCORT + ENDIF + ENDDO +*$OMP PARALLEL DO +*$OMP1 PRIVATE(IL1,ITRAK,STAYIN,GOSOUT) + DO ISBG=1,NSBG + IF(NPSYS(ISBG).EQ.0) CYCLE + DO ITRAK=(IBATCH-1)*NBATCH+1,MIN(IBATCH*NBATCH,NTRK) + IL1=ITRAK-(IBATCH-1)*NBATCH + IF(NCOIL1(IL1).EQ.0) CYCLE + CALL PIJS2D(NREG,NSOUT,NBSEG(IL1),WEIGHT(IL1),RCUTOF, + > NGSS,SIGANG(1,-NSOUT,ISBG),XGSS,WGSS,LENGTH(1,IL1), + > NUMERO(1,IL1),STAYIN,GOSOUT,DPROB(1,ISBG)) + ENDDO ! ITRAK + ENDDO ! ISBG +*$OMP END PARALLEL DO + IF(LPIJK)THEN +* X-DIRECTION PROBABILITIES CALCULATIONS ( PX=PY ) +*$OMP PARALLEL DO +*$OMP1 PRIVATE(IL1,ITRAK,STAYIN,GOSOUT) + DO ISBG=1,NSBG + IF(NPSYS(ISBG).EQ.0) CYCLE + DO ITRAK=(IBATCH-1)*NBATCH+1,MIN(IBATCH*NBATCH,NTRK) + IL1=ITRAK-(IBATCH-1)*NBATCH + IF(NCOIL1(IL1).EQ.0) CYCLE + CALL PIJS2D(NREG,NSOUT,NBSEG(IL1),WEIGHT(IL1),RCUTOF, + > NGSS,SIGANG(1,-NSOUT,ISBG),XGSS,WGSSX,LENGTH(1,IL1), + > NUMERO(1,IL1),STAYIN,GOSOUT,DPROBX(1,ISBG)) + ENDDO ! ITRAK + ENDDO ! ISBG +*$OMP END PARALLEL DO + ENDIF + ENDDO ! IBATCH + DEALLOCATE(GOSOUT,STAYIN,SIGANG) + ELSE + ALLOCATE(STAYIN(MXSEG),GOSOUT(MXSEG)) + DO IBATCH=1,(NTRK-1)/NBATCH+1 + DO ITRAK=(IBATCH-1)*NBATCH+1,MIN(IBATCH*NBATCH,NTRK) + IL1=ITRAK-(IBATCH-1)*NBATCH + IF(IFTRAK .NE. 0) THEN + READ(IFTRAK) NSUB(IL1),NBSEG(IL1),WEIGHT(IL1), + > (IANG,IL=1,NSUB(IL1)),(NUMERO(IL,IL1),IL=1,NBSEG(IL1)), + > (LENGTH(IL,IL1),IL=1,NBSEG(IL1)) + NCOIL1(IL1)=1 + ELSE + CALL NXTTGC(IPTRK ,IPRNTP,NDIM ,NANGL ,NPOINT,NTRK , + > ITRAK ,MAXMSH,NSOUT ,NREG ,NUCELL,NBUCEL, + > MXGSUR,MXGREG,MAXPIN,MXSEG ,ITYPBC,IUNFLD, + > MATALB,DSV ,DGMESH,DANGLT,DVNOR ,DWGTRK, + > DORITR,NBSEG(IL1) ,NCORT ,WEIGHT(IL1), + > NUMERO(1,IL1),LENGTH(1,IL1)) + NCOIL1(IL1)=NCORT + ENDIF + ENDDO +*$OMP PARALLEL DO +*$OMP1 PRIVATE(IL1,ITRAK,STAYIN,GOSOUT) + DO ISBG=1,NSBG + IF(NPSYS(ISBG).EQ.0) CYCLE + DO ITRAK=(IBATCH-1)*NBATCH+1,MIN(IBATCH*NBATCH,NTRK) + IL1=ITRAK-(IBATCH-1)*NBATCH + IF(NCOIL1(IL1).EQ.0) CYCLE + CALL PIJS3D(NREG,NSOUT,NBSEG(IL1),WEIGHT(IL1),RCUTOF, + > SIGT(-NSOUT,ISBG),LENGTH(1,IL1),NUMERO(1,IL1),STAYIN, + > GOSOUT,DPROBX(1,ISBG)) + ENDDO ! ITRAK + ENDDO ! ISBG +*$OMP END PARALLEL DO + ENDDO ! IBATCH + DEALLOCATE(GOSOUT,STAYIN) + ENDIF + ENDIF + IF(IFTRAK .EQ. 0) THEN + DEALLOCATE(DVNOR,DWGTRK,DORITR,DANGLT) + DEALLOCATE(IUNFLD) + DEALLOCATE(DGMESH,DSV) + CALL LCMSIX(IPTRK,'NXTRecords ',ILCMDN) + ENDIF +* + DO 2050 ISBG=1,NSBG + IF(NPSYS(ISBG).EQ.0) GO TO 2050 + KSBG=(ISBG-1)*NUNKNO + CALL PIJCMP(NREG,NSOUT,NCOR,DPROB(1,ISBG), + > VOLSUR(-NSOUT,ISBG),.FALSE.,DPROB(1,ISBG)) + IF(LPIJK)THEN + CALL PIJCMP(NREG,NSOUT,NCOR,DPROBX(1,ISBG), + > VOLSUR(-NSOUT,ISBG),.TRUE.,DPROBX(1,ISBG)) + ENDIF + 2050 CONTINUE +*---- +* BATCH TRACKING STORAGE DEALLOCATION +*---- + DEALLOCATE(LENGTH,NUMERO,WEIGHT,NBSEG,NSUB,NCOIL1) +*---- +* RENORMALIZE ALL ISOTROPIC PROBS WITH VARIOUS OPTIONS +*---- + DO 2060 ISBG=1,NSBG + IF(NPSYS(ISBG).EQ.0) GO TO 2060 + IF( KSPEC.EQ.0 )THEN + IF( NRENOR.EQ.1 )THEN +* +* NORMALIZATION USING GELBARD SCHEME + CALL PIJRGL(IPRT,NREG,NSOUT,SIGTAL(-NSOUT,ISBG), + > DPROB(1,ISBG)) + IF(LPIJK) CALL PIJRGL(IPRT,NREG,NSOUT,SIGTAL(-NSOUT,ISBG), + > DPROBX(1,ISBG)) + ELSEIF( NRENOR.EQ.2 )THEN +* +* NORMALIZATION WORKING ON DIAGONAL COEFFICIENTS + CALL PIJRDG(IPRT,NREG,NSOUT,SIGTAL(-NSOUT,ISBG), + > DPROB(1,ISBG)) + IF(LPIJK) CALL PIJRDG(IPRT,NREG,NSOUT,SIGTAL(-NSOUT,ISBG), + > DPROBX(1,ISBG)) + ELSEIF( NRENOR.EQ.3 )THEN +* +* NORMALIZATION WORKING ON WEIGHT FACTORS TO KEEP DIAG = 0.0 + CALL PIJRNL(IPRT,NREG,NSOUT,SIGTAL(-NSOUT,ISBG), + > DPROB(1,ISBG)) + IF(LPIJK) CALL PIJRNL(IPRT,NREG,NSOUT,SIGTAL(-NSOUT,ISBG), + > DPROBX(1,ISBG)) + ELSEIF( NRENOR .EQ. 4 )THEN ! ATTENTION +* +* NORMALIZATION WORKING ON WEIGHT FACTORS ADDITIVE (HELIOS) + CALL PIJRHL(IPRT,NREG,NSOUT,SIGTAL(-NSOUT,ISBG), + > DPROB(1,ISBG)) + IF(LPIJK) CALL PIJRHL(IPRT,NREG,NSOUT,SIGTAL(-NSOUT,ISBG), + > DPROBX(1,ISBG)) + ENDIF + IF( IPRT.GE.ICPALL )THEN + LOPT= -1 + MSYM=1 + WRITE(IOUT,'(1H )') + WRITE(IOUT,'(35H COLLISION PROBABILITIES OUTPUT: , + > 35H *BEFORE* ALBEDO REDUCTION )') + CALL PIJWPR(LOPT,NREG,NSOUT,SIGTAL(-NSOUT,ISBG), + > DPROB(1,ISBG),VOLSUR(1,ISBG),MSYM) +* + ENDIF + ENDIF + 2060 CONTINUE + RETURN +* + 6010 FORMAT(' Maximum length of a line =',I10) + 6000 FORMAT(' *** SPACE REQUIRED FOR CP MATRICES = ',I10,' K ***') + 6001 FORMAT(' *** CP MATRICES ALLOCATED ',10X,' ***') + END diff --git a/Dragon/src/EXCELT.f b/Dragon/src/EXCELT.f new file mode 100644 index 0000000..57bacdc --- /dev/null +++ b/Dragon/src/EXCELT.f @@ -0,0 +1,350 @@ +*DECK EXCELT + SUBROUTINE EXCELT(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* EXCELL tracking operator. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert and R. Roy +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): creation or modification type(L_TRACK); +* HENTRY(2): sequential binary tracking file; +* HENTRY(3): read-only type(L_GEOM). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + INTEGER IOUT,NSTATE + PARAMETER (IOUT=6,NSTATE=40) + CHARACTER TEXT4*4,TEXT12*12,TITLE*72,HSIGN*12,CFTRAK*12 + LOGICAL LASS,LDRASS,LPRISM,LBIHET + DOUBLE PRECISION DFLOTT + INTEGER ITITL(18),ISTATE(NSTATE),IZ + REAL EXTKOP(NSTATE), FLOTT, CUTOFX, DELU, FRTM +* + TYPE(C_PTR) IPTRK, IPGEOM + INTEGER IFTRAK, IDISP, IMPX, MAXPTS, NANIS, NORE, LMERG, I, + > ISYMM, KSPEC, KTOPT, KMODL, INDIC, NITMA, LCACT, + > NMU, INSB , IQUA10, NBATCH, IBIHET, ILONG, ITYLCM +*---- +* PARAMETER VALIDATION +*---- + IF(NENTRY.LT.2) CALL XABORT + > ('EXCELT: AT LEAST TWO DATA STRUCTURES REQUIRED') + IF(IENTRY(1).GT.2) CALL XABORT + > ('EXCELT: FIRST DATA STRUCTURE NOT A LCM OBJECT') + IF(JENTRY(1).NE.0.AND.JENTRY(1).NE.1) CALL XABORT + > ('EXCELT: FIRST DATA STRUCTURE NOT IN CREATE OR MODIFY MODE') + IPTRK=KENTRY(1) +*---- +* RECOVER GEOMETRY +*---- + IPGEOM=C_NULL_PTR + DO 10 I=2,NENTRY + IF((IENTRY(I).LE.2).AND.(JENTRY(I).EQ.2)) THEN + CALL LCMGTC(KENTRY(I),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_GEOM') THEN + TEXT12=HENTRY(I) + CALL XABORT('EXCELT: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_GEOM EXPECTED.') + ENDIF + IPGEOM=KENTRY(I) + ISTATE(:NSTATE)=0 + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) + TEXT12=HENTRY(I) + CALL LCMPTC(IPTRK,'LINK.GEOM',12,TEXT12) + GO TO 20 + ENDIF + 10 CONTINUE +*---- +* RECOVER SEQUENTIAL BINARY TRACKING FILE CHARACTERISTICS +*---- + 20 CFTRAK=' ' + IFTRAK=0 + IDISP=99 + DO 30 I=2,NENTRY + IF(IENTRY(I).EQ.3) THEN + CFTRAK=HENTRY(I) + IF(JENTRY(I).EQ.0) IDISP=1 + IF(JENTRY(I).EQ.1) IDISP=-1 + IF(JENTRY(I).EQ.2) IDISP=0 + IFTRAK=FILUNIT(KENTRY(I)) + GO TO 35 + ENDIF + 30 CONTINUE +* + 35 IMPX=1 + LMERG=1 + TITLE=' ' + IF(IDISP.NE.0) LMERG=0 + IF(JENTRY(1).EQ.0) THEN + HSIGN='L_TRACK' + CALL LCMPTC(IPTRK,'SIGNATURE',12,HSIGN) + HSIGN='EXCELL' + CALL LCMPTC(IPTRK,'TRACK-TYPE',12,HSIGN) + IF(C_ASSOCIATED(IPGEOM)) THEN + MAXPTS=ISTATE(6) + ELSE + MAXPTS=0 + ENDIF + LPRISM=.FALSE. + DELU=1.0 + NANIS=1 + NORE=0 + IF(IDISP.NE.0) NORE=-1 + KSPEC=-1 + KTOPT=-1 + CUTOFX=0.0 + ISYMM=1 + INSB=0 + IF(IFTRAK.EQ.0) INSB=2 + LCACT=-1 + NMU=0 + IQUA10=5 + NBATCH=1 + IBIHET=2 + CALL LCMLEN(IPGEOM,'BIHET',ILONG,ITYLCM) + LBIHET=(ILONG.NE.0) + IF(LBIHET) IQUA10=5 + ELSE IF(JENTRY(1).EQ.1) THEN + CALL LCMGTC(IPTRK,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_TRACK') THEN + TEXT12=HENTRY(1) + CALL XABORT('EXCELT: SIGNATURE OF '//TEXT12//' IS ' + > //HSIGN//' L_TRACK EXPECTED.') + ENDIF + CALL LCMGTC(KENTRY(1),'TRACK-TYPE',12,HSIGN) + IF(HSIGN.NE.'EXCELL') THEN + TEXT12=HENTRY(1) + CALL XABORT('EXCELT: TRACK-TYPE OF '//TEXT12//' IS ' + > //HSIGN//'. EXCELL EXPECTED.') + ENDIF + ISTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + MAXPTS=ISTATE(1) + NANIS=ISTATE(6) + KMODL=ISTATE(7) + NORE=ISTATE(8) + KTOPT=ISTATE(9) + KSPEC=ISTATE(10) + ISYMM=ISTATE(12) + LCACT=ISTATE(13) + NMU=ISTATE(14) + INSB=ISTATE(22) + NBATCH=ISTATE(27) + IZ=ISTATE(39) + LPRISM=(IZ.NE.0) + CALL LCMGET(IPTRK,'EXCELTRACKOP',EXTKOP) + CUTOFX=EXTKOP(1) + DELU=EXTKOP(40) + LBIHET=(ISTATE(40).GT.0) + IF(LBIHET) THEN + CALL LCMSIX(IPTRK,'BIHET',1) + CALL LCMGET(IPTRK,'PARAM',ISTATE) + CALL LCMSIX(IPTRK,'BIHET',2) + IBIHET=ISTATE(6) + IQUA10=ISTATE(8) + ELSE + IBIHET=0 + IQUA10=0 + ENDIF + CALL LCMLEN(IPTRK,'TITLE',ILONG,ITYLCM) + IF(ILONG.GT.0) CALL LCMGTC(IPTRK,'TITLE',72,TITLE) + ENDIF + FRTM=0.05 + 40 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + 41 CONTINUE + IF(INDIC.EQ.10) GO TO 50 + IF(INDIC.NE.3) CALL XABORT('EXCELT: CHARACTER DATA EXPECTED.') + IF(TEXT4.EQ.'EDIT') THEN + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('EXCELT: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT4.EQ.'MAXR') THEN + CALL REDGET(INDIC,MAXPTS,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('EXCELT: INTEGER DATA EXPECTED(2).') + ELSE IF(TEXT4.EQ.'TITL') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TITLE,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('EXCELT: TITLE EXPECTED.') + ELSE IF(TEXT4(1:3).EQ.'PRI') THEN + IF(.NOT.C_ASSOCIATED(IPGEOM)) THEN + CALL XABORT('EXCELT: NO GEOMETRY TO PROJECT.') + ENDIF + LPRISM=.TRUE. + IF (TEXT4(4:4).EQ.'Z') THEN + IZ=3 + ELSEIF (TEXT4(4:4).EQ.'Y') THEN + IZ=2 + ELSEIF (TEXT4(4:4).EQ.'X') THEN + IZ=1 + ELSE + CALL XABORT('EXCELT: INVALID PROJECTION AXIS FOR 3D PRISM.') + ENDIF + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.2) THEN + CALL XABORT('EXCELT: REAL DATA EXPECTED') + ELSE + DELU=1.0/FLOTT + IF (DELU.LT.0.0) + > CALL XABORT('EXCELT: DELU > 0.0 EXPECTED') + ENDIF + ELSE IF(TEXT4.EQ.'ANIS') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) THEN + CALL XABORT('EXCELT: INTEGER MUST FOLLOW ANIS KEYWORD') + ELSE + NANIS=NITMA + IF(NANIS.LT.1) + > CALL XABORT('EXCELT: NANIS GREATER THAN 1 PERMITTED ONLY') + ENDIF + ELSE IF(TEXT4.EQ.'RENO') THEN + IF(IDISP.EQ.0) CALL XABORT('EXCELT: CANNOT NORMALIZE READ-ONL' + > //'Y BINARY TRACKING FILE') + NORE=0 + ELSE IF(TEXT4.EQ.'REND') THEN + IF(IDISP.EQ.0) CALL XABORT('EXCELT: CANNOT NORMALIZE READ-ONL' + > //'Y BINARY TRACKING FILE') + NORE=-1 + ELSE IF(TEXT4.EQ.'RENM') THEN + IF(IDISP.EQ.0) CALL XABORT('EXCELT: CANNOT NORMALIZE READ-ONL' + > //'Y BINARY TRACKING FILE') + NORE=-2 + ELSE IF(TEXT4.EQ.'NORE') THEN + IF(IDISP.EQ.0) CALL XABORT('EXCELT: CANNOT NORMALIZE READ-ONL' + > //'Y BINARY TRACKING FILE') + NORE=1 + ELSE IF(TEXT4.EQ.'TREG') THEN + IF(IDISP.EQ.0) CALL XABORT('EXCELT: CANNOT NORMALIZE READ-ONL' + > //'Y BINARY TRACKING FILE') + LMERG=0 + ELSE IF(TEXT4.EQ.'TMER') THEN + IF(IDISP.EQ.0) CALL XABORT('EXCELT: CANNOT NORMALIZE READ-ONL' + > //'Y BINARY TRACKING FILE') + LMERG=1 + ELSE IF(TEXT4.EQ.'PISO') THEN + KSPEC=0 + ELSE IF(TEXT4.EQ.'PSPC') THEN + KSPEC=1 + ELSE IF(TEXT4.EQ.'QUAB') THEN + CALL REDGET(INDIC,IQUA10,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('EXCELT: INTEGER DATA EXPECTED(3).') + ELSE IF(TEXT4.EQ.'BATC') THEN + CALL REDGET(INDIC,NBATCH,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('EXCELT: INTEGER DATA EXPECTED(4).') + ELSE IF(TEXT4.EQ.'SAPO') THEN + IBIHET=1 + ELSE IF(TEXT4.EQ.'HEBE') THEN + IBIHET=2 + ELSE IF(TEXT4.EQ.'SLSI') THEN + IBIHET=3 + FRTM=0.05 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF (INDIC.NE.2) GOTO 41 + FRTM=FLOTT + ELSE IF(TEXT4.EQ.'SLSS') THEN + IBIHET=4 + FRTM=0.05 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF (INDIC.NE.2) GOTO 41 + FRTM=FLOTT + ELSE IF(TEXT4.EQ.'CUT') THEN + CALL REDGET(INDIC,NITMA, FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.2.OR.FLOTT.LT.0.0) THEN + CALL XABORT('EXCELT: CUTOFF MUST BE A POSITIVE REAL') + ENDIF + CUTOFX=FLOTT + ELSE IF(TEXT4.EQ.'ONEG') THEN + INSB=0 + ELSE IF(TEXT4.EQ.'ALLG') THEN + INSB=1 + ELSE IF(TEXT4.EQ.'XCLL') THEN + INSB=2 + ELSE IF(TEXT4.EQ.'GAUS') THEN + LCACT=0 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) GO TO 41 + NMU=NITMA + ELSE IF(TEXT4.EQ.'CACA') THEN + LCACT=1 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) GO TO 41 + NMU=NITMA + ELSE IF(TEXT4.EQ.'CACB') THEN + LCACT=2 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) GO TO 41 + NMU=NITMA + ELSE IF(TEXT4.EQ.'LCMD') THEN + LCACT=3 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) GO TO 41 + NMU=NITMA + ELSE IF(TEXT4.EQ.'OPP1') THEN + LCACT=4 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) GO TO 41 + NMU=NITMA + ELSE IF(TEXT4.EQ.'OGAU') THEN + LCACT=5 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) GO TO 41 + NMU=NITMA + ELSE IF(TEXT4.EQ.'TRAK') THEN + IF(IDISP.LE.0) CALL XABORT('EXCELT: TRAK KEYWORD NOT REQUIRED') + GO TO 50 + ELSE IF(TEXT4.EQ.';') THEN + IF(IDISP.GT.0) CALL XABORT('EXCELT: TRAK KEYWORD EXPECTED') + GO TO 50 + ELSE + CALL XABORT('EXCELT: '//TEXT4//' IS AN INVALID KEY WORD.') + ENDIF + GO TO 40 +*---- +* CALL XELDRV TO PERFORM THE TRACKING +*---- + 50 IF(C_ASSOCIATED(IPGEOM)) LASS=LDRASS(IPGEOM,IMPX) +* + READ(TITLE,'(18A4)') (ITITL(I),I=1,18) + CALL LCMPUT(IPTRK,'TITLE',18,3,ITITL) + IF(IMPX.GT.1) WRITE(IOUT,'(1X,A72//)') TITLE +* + IF(MAXPTS.EQ.0) CALL XABORT('EXCELT: MAXPTS NOT DEFINED.') + CALL XELDRV(IPTRK ,IPGEOM,IMPX ,MAXPTS,NANIS ,NORE , + > LMERG, KSPEC , KTOPT,TITLE ,CUTOFX,CFTRAK, + > IFTRAK,IDISP ,ISYMM ,LCACT ,NMU ,INSB , + > NBATCH,LBIHET,LPRISM,IZ,DELU,FRTM ) +*---- +* PROCESS DOUBLE HETEROGENEITY (BIHET) DATA (IF AVAILABLE) +*---- + IF(LBIHET) CALL XDRTBH(IPGEOM,IPTRK,IQUA10,IBIHET,IMPX,FRTM) +* + RETURN + END diff --git a/Dragon/src/FLU.f b/Dragon/src/FLU.f new file mode 100644 index 0000000..31c14ec --- /dev/null +++ b/Dragon/src/FLU.f @@ -0,0 +1,452 @@ +*DECK FLU + SUBROUTINE FLU(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Multigroup flux solution in a lattice. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file. +* HENTRY(1) create or modification type(L_FLUX). +* HENTRY(I) for I>1: +* read-only type(L_MACROLIB or L_LIBRARY); +* read-only type(L_TRACK); +* read-only sequential binary tracking file; +* read-only type(L_PIJ); +* optional read-only type(L_FLUX) for unperturbed solution; +* optional read-only type(L_SOURCE) for fixed sources. +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER(IOUT=6,NSTATE=40,NLEAK=7,NSDIR=6) + TYPE(C_PTR) IPFLUX,IPTRK,IPMACR,IPSYS,IPFLUP,IPSOU + CHARACTER TEXT12*12,TITLE*72,CMODUL*12,HSIGN*12,COPTIO*4, + 1 CXDOOR*12,TYPE10*10,HISO10*10,CREBAL*3,CHLEAK*3,HTYPE(0:5)*8, + 2 CLEAK(NLEAK)*6,CSDIR(NSDIR)*1,HPTRK*12,HPMACR*12,HPSYS*12, + 3 HPFLUP*12,HPGPT*12,HSMG*131,REDUC(4)*3 + LOGICAL LTABLE,REC,LEAKSW,LFORW + DOUBLE PRECISION REFKEF + INTEGER ISTATE(NSTATE) + REAL B2(4) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MATCOD,KEYFLX,IMERG + REAL, ALLOCATABLE, DIMENSION(:) :: VOL +*---- +* DATA STATEMENTS +*---- + SAVE HTYPE,CLEAK,CSDIR + DATA (HTYPE(JJ),JJ=0,5)/' SOURCE',' GPT',' K-INF', + > ' K-EFF','BUCKLING',' LEAKAGE'/ + DATA (CLEAK(JJ),JJ=1,NLEAK) + > /'PNLR',' PNL','SIGS','ALBS','HETE','ECCO','TIBERE'/ + DATA (CSDIR(III),III=1,NSDIR) + > /'-','X','Y','Z','R','G'/ + DATA (REDUC(JJ),JJ=1,4) + > /'ON ','OFF','ON ','OFF'/ +*---- +* BICKLEY FLAG +*---- + SAVE IBICKL + DATA IBICKL/0/ +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.LE.1) CALL XABORT('FLU: TWO PARAMETERS EXPECTED.') + IPFLUX=KENTRY(1) + REC=(JENTRY(1).EQ.1) + IF(REC) THEN + CALL LCMGTC(IPFLUX,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_FLUX') THEN + TEXT12=HENTRY(1) + CALL XABORT('FLU: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_FLUX EXPECTED.') + ENDIF + ELSE + HSIGN='L_FLUX' + CALL LCMPTC(IPFLUX,'SIGNATURE',12,HSIGN) + ENDIF + IFTRAK=0 + IPMACR=C_NULL_PTR + IPTRK=C_NULL_PTR + IPSYS=C_NULL_PTR + IPSOU=C_NULL_PTR + IPFLUP=C_NULL_PTR + HPTRK=' ' + HPMACR=' ' + HPSYS=' ' + DO 10 I1=2,NENTRY + LTABLE=(IENTRY(I1).EQ.1).OR.(IENTRY(I1).EQ.2) + IF((IENTRY(I1).EQ.3).AND.(JENTRY(I1).EQ.2)) THEN + IFTRAK=FILUNIT(KENTRY(I1)) + ELSE IF(LTABLE.AND.(JENTRY(I1).EQ.2)) THEN + CALL LCMGTC(KENTRY(I1),'SIGNATURE',12,HSIGN) + IF((HSIGN.EQ.'L_TRACK').AND.(.NOT.C_ASSOCIATED(IPTRK))) THEN + IPTRK=KENTRY(I1) + HPTRK=HENTRY(I1) + ELSE IF((HSIGN.EQ.'L_MACROLIB').AND.(.NOT.C_ASSOCIATED(IPMACR))) + 1 THEN + IPMACR=KENTRY(I1) + HPMACR=HENTRY(I1) + ELSE IF((HSIGN.EQ.'L_LIBRARY').AND.(.NOT.C_ASSOCIATED(IPMACR))) + 1 THEN + CALL LCMLEN(KENTRY(I1),'MACROLIB',ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + IPMACR=KENTRY(I1) + HPMACR=HENTRY(I1) + CALL LCMSIX(IPMACR,'MACROLIB',1) + ENDIF + ELSE IF((HSIGN.EQ.'L_PIJ').AND.(.NOT.C_ASSOCIATED(IPSYS))) THEN + IPSYS=KENTRY(I1) + HPSYS=HENTRY(I1) + ELSE IF((HSIGN.EQ.'L_FLUX').AND.(.NOT.C_ASSOCIATED(IPFLUP))) + 1 THEN + IPFLUP=KENTRY(I1) + HPFLUP=HENTRY(I1) + ELSE IF((HSIGN.EQ.'L_SOURCE').AND.(.NOT.C_ASSOCIATED(IPSOU))) + 1 THEN + IPSOU=KENTRY(I1) + HPGPT=HENTRY(I1) + ELSE + WRITE(HSMG,'(20HFLU: UNKNOWN OBJECT ,A,14H OF SIGNATURE ,A, + 1 5H (1).)') TRIM(HENTRY(I1)),TRIM(HSIGN) + CALL XABORT(HSMG) + ENDIF + ELSE + WRITE(HSMG,'(20HFLU: UNKNOWN OBJECT ,A,1H.)') TRIM(HENTRY(I1)) + CALL XABORT(HSMG) + ENDIF + 10 CONTINUE + IF(.NOT.C_ASSOCIATED(IPTRK)) THEN + CALL XABORT('FLU: NO TRACKING OBJECT AT RHS.') + ELSE IF(.NOT.C_ASSOCIATED(IPMACR)) THEN + CALL XABORT('FLU: NO MACROLIB OBJECT AT RHS.') + ELSE IF(.NOT.C_ASSOCIATED(IPSYS)) THEN + CALL XABORT('FLU: NO SYSTEM OBJECT AT RHS.') + ENDIF +*---- +* RECOVER GENERAL TRACKING INFORMATION. +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + NREG= ISTATE(1) + NUN= ISTATE(2) + LEAKSW= ISTATE(3).EQ.0 + IGP4= ISTATE(4) + NSOUT= ISTATE(5) +*---- +* RECOVER MACROLIB PARAMETERS. +*---- + CALL LCMPTC(IPFLUX,'LINK.MACRO',12,HPMACR) + ISTATE(:NSTATE)=0 + CALL LCMGET(IPMACR,'STATE-VECTOR',ISTATE) + NGRP= ISTATE(1) + NMAT= ISTATE(2) + NANIS= ISTATE(3)-1 + NIFIS= ISTATE(4) + ITRANC= ISTATE(6) + LFORW = (ISTATE(13).EQ.0) + IF(IGP4.GT.NMAT) THEN + WRITE(HSMG,'(45HFLU: THE NUMBER OF MIXTURES IN THE TRACKING (, + 1 I5,55H) IS GREATER THAN THE NUMBER OF MIXTURES IN THE MACROLI, + 2 3HB (,I5,2H).)') IGP4,NMAT + CALL XABORT(HSMG) + ENDIF +*---- +* RECOVER INFORMATION FROM L_PIJ OBJECT. +*---- + ITPIJ=2 + IPHASE=1 + IF(C_ASSOCIATED(IPSYS)) THEN + CALL LCMGTC(IPSYS,'LINK.MACRO',12,TEXT12) + IF(HPMACR.NE.TEXT12) THEN + WRITE(HSMG,'(37H FLU: INVALID MACROLIB OBJECT NAME ='',A12, + 1 18H'', EXPECTED NAME='',A12,2H''.)') HPMACR,TEXT12 + CALL XABORT(HSMG) + ENDIF + CALL LCMGTC(IPSYS,'LINK.TRACK',12,TEXT12) + IF(HPTRK.NE.TEXT12) THEN + WRITE(HSMG,'(37H FLU: INVALID TRACKING OBJECT NAME ='',A12, + 1 18H'', EXPECTED NAME='',A12,2H''.)') HPTRK,TEXT12 + CALL XABORT(HSMG) + ENDIF + CALL LCMPTC(IPFLUX,'LINK.TRACK',12,HPTRK) + CALL LCMPTC(IPFLUX,'LINK.SYSTEM',12,HPSYS) + CALL LCMGET(IPSYS,'STATE-VECTOR',ISTATE) + ITPIJ=ISTATE(1) + IPHASE=ISTATE(5) + IF(ISTATE(8).NE.NGRP) CALL XABORT('FLU: INVALID NUMBER OF ENE' + 1 //'RGY GROUPS.') + IF(ISTATE(10).GT.NMAT) CALL XABORT('FLU: INVALID NUMBER OF MI' + 1 //'XTURES.') + IF(LEAKSW) THEN + IF((ISTATE(2).EQ.0).OR.(ISTATE(3).EQ.0)) LEAKSW=.FALSE. + ENDIF + ELSE + CALL LCMPTC(IPFLUX,'LINK.TRACK',12,HPTRK) + ENDIF +*---- +* INITIALISE/READ ITERATIONS PARAMETERS +*---- + IF(NREG.EQ.0) CALL XABORT('FLU: NREG = 0') + ALLOCATE(IMERG(NMAT)) + CALL FLUGPI(IPFLUX,IPMACR,ITYPEC,MAXOUT,MAXINR,EPSOUT,EPSUNK, + 1 EPSINR,IREBAL,IFRITR,IACITR,COPTIO,ILEAK,B2,NGRP,NREG,NMAT, + 2 NIFIS,LEAKSW,REFKEF,ITPIJ,IPRINT,REC,INITFL,NMERG,IMERG) + IF(IPHASE.EQ.2) THEN + IF((ILEAK.GE.7).AND.(ITPIJ.LT.3)) CALL XABORT('FLU: HETEROGE'// + > 'NEOUS BUCKLING CALCULATIONS REQUIRE PIJK EVALUATION IN ASM:') + ENDIF +*---- +* RECOVER TRACKING FILE INFORMATION. +*---- + CALL LCMGTC(IPTRK,'TRACK-TYPE',12,CMODUL) + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + IF(IPHASE.EQ.1) THEN + CXDOOR=CMODUL + ELSE + CXDOOR='TRAFIC' + IF(.NOT.C_ASSOCIATED(IPSYS)) CALL XABORT('FLU: NO PIJ OBJECT A' + 1 //'T RHS.') + ENDIF + IF(CXDOOR.EQ.'MCCG') THEN + NLF=ISTATE(6) + NANI=ISTATE(6) + ELSE IF(CXDOOR.EQ.'BIVAC') THEN + NLF=MAX(1,ISTATE(14)) + NANI=MAX(1,ISTATE(16)) + ELSE IF(CXDOOR.EQ.'TRIVAC') THEN + NLF=MAX(1,ISTATE(30)) + NANI=MAX(1,ISTATE(32)) + ELSE IF(CXDOOR.EQ.'SN') THEN + NLF=ISTATE(15) + NANI=MAX(1,ISTATE(16)) + ELSE + NLF=1 + NANI=1 + ENDIF + IF(ITYPEC.EQ.1) THEN + IF(.NOT.C_ASSOCIATED(IPFLUP)) CALL XABORT('FLU: NO UNPERTURBED' + 1 //'FLUX OBJECT AT RHS.') + CALL LCMGTC(IPFLUP,'TRACK-TYPE',12,TEXT12) + IF(TEXT12.NE.CMODUL) THEN + WRITE(HSMG,'(44HFLU: INCONSISTENT UNPERTURBED FLUX TRACK-TYP, + 1 10HE AT RHS (,A,3H). ,A,10H EXPECTED.)') TRIM(TEXT12), + 2 TRIM(CMODUL) + CALL XABORT(HSMG) + ENDIF + IF(.NOT.C_ASSOCIATED(IPSOU)) CALL XABORT('FLU: NO SOURCE OBJEC' + 1 //'T AT RHS.') + CALL LCMGTC(IPSOU,'TRACK-TYPE',12,TEXT12) + IF(TEXT12.NE.CMODUL) THEN + WRITE(HSMG,'(44HFLU: INCONSISTENT SOURCE OBJECT TRACK-TYPE A, + 1 7HT RHS (,A,3H). ,A,10H EXPECTED.)') TRIM(TEXT12),TRIM(CMODUL) + CALL XABORT(HSMG) + ENDIF + ENDIF + IF(REC) THEN + CALL LCMGTC(IPFLUX,'TRACK-TYPE',12,TEXT12) + IF(TEXT12.NE.CMODUL) THEN + WRITE(HSMG,'(44HFLU: INCONSISTENT FLUX OBJECT TRACK-TYPE AT , + 1 5HRHS (,A,3H). ,A,10H EXPECTED.)') TRIM(TEXT12),TRIM(CMODUL) + CALL XABORT(HSMG) + ENDIF + ENDIF + CALL LCMPTC(IPFLUX,'TRACK-TYPE',12,CMODUL) +*---- +* CHECK FOR THE ANISOTROPY SETTINGS COHERENCE +*---- + IF((ITRANC.NE.0).AND.(NANI.GT.1)) THEN + WRITE(IOUT,6400) CXDOOR,NANI + ITRANC=0 + ENDIF +*---- +* RECOVER TABULATED FUNCTIONS FOR THE METHOD OF CHARACTERISTICS. +*---- + IF((CXDOOR.EQ.'MCCG').AND.(IBICKL.EQ.0)) THEN + CALL XDRTA2 + IBICKL=1 + ENDIF +*---- +* THE NUMBER OF UNKNOWNS OF A CURRENT-BASED MULTICELL ITERATION IS +* INCREASED TO HOLD INTERFACE CURRENT COMPONENTS. +*---- + IF(IPHASE.EQ.1) THEN + IF(CXDOOR.EQ.'SYBIL') NUN=NUN+ISTATE(9) + IF((CXDOOR.EQ.'EXCELL').AND.(ISTATE(7).EQ.5)) NUN=NUN+ISTATE(28) + ENDIF +*---- +* THE NUMBER OF UNKNOWNS IS MULTIPLIED BY 2 WITH THE ECCO-TYPE +* ISOTROPIC STREAMING MODEL AND BY 4 FOR PIJ AND 8 FOR MOC WITH THE +* TIBERE ANISOTROPIC STREAMING MODEL. THE EXTRA-LOCATIONS ARE USED TO +* STORE THE HETEROGENEOUS FUNDAMENTAL CURRENT VALUES. +*---- + IF(ILEAK.EQ.6) NUN=NUN*2 + IF(ILEAK.GE.7) THEN + IF (CXDOOR.EQ.'MCCG')THEN + NUN=NUN*8 + ELSE + NUN=NUN*4 + ENDIF + ENDIF +*---- +* PRINT REQUIRED INFORMATION +*---- + IF(IPRINT.GE.1) THEN + IF(LFORW) THEN + TYPE10=' DIRECT' + ELSE + TYPE10=' ADJOINT' + ENDIF + IF(NLF.EQ.1 ) THEN + HISO10=' ISOTROPIC' + ELSE + HISO10=' ANISOTROP' + ENDIF + WRITE(IOUT,6010) HTYPE(ITYPEC),TYPE10,HISO10 + IF(ITYPEC.EQ.3) THEN + WRITE(IOUT,6011) COPTIO,CLEAK(MOD(ILEAK,10)),' IMPOSED' + IF(ILEAK.LT.7) THEN + WRITE(IOUT,6012) B2(4) + ELSE + WRITE(IOUT,6013) B2(1),B2(2),B2(3) + ENDIF + ELSE IF(ITYPEC.GT.3) THEN + IF(ILEAK.LT.7) THEN + WRITE(IOUT,6011) COPTIO,CLEAK(ILEAK),'G SEARCH' + WRITE(IOUT,6012) B2(4) + ELSE + WRITE(IOUT,6011) COPTIO,CLEAK(7),CSDIR(ILEAK/10)//' SEARCH' + WRITE(IOUT,6013) B2(1),B2(2),B2(3) + ENDIF + ENDIF + CREBAL='ON ' + IF(IREBAL.EQ.0) CREBAL='OFF' + CHLEAK='ON ' + IF(LEAKSW) CHLEAK='OFF' + WRITE(IOUT,6000) CXDOOR,NGRP,NREG,NUN,NMERG,MAXOUT,MAXINR, + > IFRITR,IACITR,CREBAL,REDUC(ITPIJ),CHLEAK, + > EPSOUT,EPSUNK,EPSINR + IF(ITRANC.GT.0) WRITE(IOUT,6100) + ENDIF +*---- +* RECOVER SPECIFIC TRACKING INFORMATION. +*---- + IF(CXDOOR.EQ.'MCCG') THEN + CALL LCMGET(IPTRK,'MCCG-STATE',ISTATE) + NFUNL=ISTATE(19) + NLIN=ISTATE(20) + ELSE IF(CXDOOR.EQ.'SN') THEN + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + NFUNL=ISTATE(7) + NLIN=ISTATE(8) + NDIM=ISTATE(9) + NLIN=NLIN**NDIM + NLIN=NLIN*ISTATE(35) + ELSE + NFUNL=1 + NLIN=1 + ENDIF + ALLOCATE(MATCOD(NREG),VOL(NREG),KEYFLX(NREG*NLIN*NFUNL)) + KEYFLX(:NREG*NLIN*NFUNL)=0 + CALL LCMLEN(IPTRK,'MATCOD',ILNLCM,ITYLCM) + IF(ILNLCM.NE.NREG) + 1 CALL XABORT( 'FLU: INCOMPATIBLE NUMBER OF REGIONS.') + CALL LCMGET(IPTRK,'MATCOD',MATCOD) + CALL LCMGET(IPTRK,'VOLUME',VOL) + IF((CXDOOR.EQ.'MCCG').OR.(CXDOOR.EQ.'SN')) THEN + CALL LCMGET(IPTRK,'KEYFLX$ANIS',KEYFLX) + ELSE + CALL LCMGET(IPTRK,'KEYFLX',KEYFLX) + ENDIF + CALL LCMLEN(IPTRK,'TITLE',ILNLCM,ITYLCM) + IF( ILNLCM.GT.0 )THEN + CALL LCMGTC(IPTRK,'TITLE',72,TITLE) + ELSE + TITLE='*** NO TITLE PROVIDED ***' + ENDIF +*---- +* COMPUTE THE FLUX. +*---- + IF(ITYPEC.EQ.1) THEN +* FIXED SOURCE EIGENVALUE PROBLEM + CALL FLUGPT(IPRINT,IPFLUX,IPTRK,IPMACR,IPFLUP,IPSOU,IFTRAK, + 1 IPSYS,IPHASE,ITPIJ,CXDOOR,TITLE,INITFL,LFORW,LEAKSW,IREBAL, + 2 NGRP,NMAT,NIFIS,NANIS,NLF,NLIN,NFUNL,COPTIO,NUN,MAXINR,EPSINR, + 3 MAXOUT,EPSUNK,EPSOUT,IFRITR,IACITR,ILEAK,NREG,NSOUT,MATCOD, + 4 KEYFLX,VOL,REFKEF,NMERG,IMERG) + ELSE + CALL FLUDRV(IPRINT,IPFLUX,IPTRK,IPMACR,IPSOU,IFTRAK,IPSYS, + 1 IPHASE,ITPIJ,CXDOOR,ITRANC,TITLE,B2,INITFL,LFORW,LEAKSW,IREBAL, + 2 NGRP,NMAT,NIFIS,NANIS,NLF,NLIN,NFUNL,COPTIO,NUN,MAXINR,EPSINR, + 3 MAXOUT,EPSUNK,EPSOUT,IFRITR,IACITR,ITYPEC,ILEAK,NREG,NSOUT, + 4 MATCOD,KEYFLX,VOL,REFKEF,NMERG,IMERG) + ENDIF +*---- +* RELEASE GENERAL TRACKING INFORMATION. +*---- + DEALLOCATE(IMERG) + DEALLOCATE(KEYFLX,VOL,MATCOD) + CALL LCMSIX(IPMACR,' ',0) + RETURN +* +6000 FORMAT(' FLUX SOLUTION DOOR = ** ',A6,' **'/ + > ' NB. OF GROUPS =',I10/ + > ' NB. OF REGIONS =',I10/ + > ' NB. OF UNKNOWNS PER GROUP =',I10/ + > ' NB. OF LEAKAGE ZONES =',I10/ + > ' MAX. OUTER ITERATIONS =',I10/ + > ' MAX. THERMAL ITERATIONS =',I10/ + > ' ACCELERATION SCHEME =(',I2,' FREE,',I2,' ACCELERATED)'/ + > ' REBALANCING OPTION = ',A3/ + > ' SELF-SCATTERING REDUCTION = ',A3/ + > ' FUNDAMENTAL MODE = ',A3/ + > ' EIGENVALUE TOLERANCE = ',1P,E10.3/ + > ' UNKNOWN OUTER TOLERANCE = ',E10.3/ + > ' UNKNOWN INNER TOLERANCE = ',E10.3/) +6010 FORMAT(////' P. I. M. SOLUTION TO TRANSPORT EQUATION',// + > ' CALCULATION TYPE =',2X,A8/ + > ' FORWARD/BACKWARD OPTION =',A10/ + > ' (AN)ISOTROPY OPTION =',A10) +6011 FORMAT(' LEAKAGE TYPE =',6X,A4/ + > ' LEAKAGE OPTION =',6X,A6/ + > ' BUCKLING =',2X,A8) +6012 FORMAT(' INITIAL TOTAL BUCKLING =',1P,E13.5) +6013 FORMAT(' INITIAL BUCKLING - X =',1P,E13.5/ + > ' INITIAL BUCKLING - Y =',1P,E13.5/ + > ' INITIAL BUCKLING - Z =',1P,E13.5) +6100 FORMAT(/' USE TRANSPORT CORRECTED CROSS-SECTIONS') +6400 FORMAT(//' *** WARNING: DOOR ',A12,'IS USED WITH AN ANISOTROPY', + > ' LEVEL FROM L_TRACK =',I2,' AND WITH A TRANSPORT CORRECTION S', + > 'ET IN LIB:.'/15X,'--> THE TRANSPORT CORRECTION IS DISABLED.'/) + END diff --git a/Dragon/src/FLU2AC.f b/Dragon/src/FLU2AC.f new file mode 100644 index 0000000..cdf2c41 --- /dev/null +++ b/Dragon/src/FLU2AC.f @@ -0,0 +1,84 @@ +*DECK FLU2AC + SUBROUTINE FLU2AC(NG,NUN,IG0,FLUX,AKEEP,ZMU) +* +*----------------------------------------------------------------------- +* +*Purpose: +* One-factor variationnal acceleration of the flux. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* NG number of energy groups. +* NUN number of unknowns per energy group including spherical +* harmonic terms, interface currents and fundamental +* currents. +* IG0 first group to accelerate. +* +*Parameters: input/output +* FLUX neutron flux: +* FLUX(:,:,1) for old; +* FLUX(:,:,2) for present; +* FLUX(:,:,3) for new. +* AKEEP effective multiplication factor. +* +*Parameters: output +* ZMU acceleration factor. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NG, NUN, IG0 + REAL FLUX(NUN,NG,3), ZMU + DOUBLE PRECISION AKEEP(3) +*---- +* LOCAL VARIABLES +*---- + INTEGER IG, IR + DOUBLE PRECISION DMU, R1, R2 + DOUBLE PRECISION DONE, DZERO, NOM, DENOM + PARAMETER ( DONE=1.0D0, DZERO=0.0D0 ) +*---- +* ZMU CALCULATION +*---- + NOM = DZERO + DENOM = DZERO + DO 3 IG= IG0,NG + DO 2 IR=1,NUN + R1 = FLUX(IR,IG,2) - FLUX(IR,IG,1) + R2 = FLUX(IR,IG,3) - FLUX(IR,IG,2) + NOM = NOM + R1*(R2-R1) + DENOM = DENOM + (R2-R1)*(R2-R1) + 2 CONTINUE + 3 CONTINUE +* + DMU = - NOM / DENOM + ZMU = REAL(DMU) + IF( DMU.GT.DZERO )THEN + DO 13 IG= IG0,NG + DO 12 IR=1,NUN +* +* ACCELERATED VALUES FOR PHI(2) ET PHI(3) + FLUX(IR,IG,3) = FLUX(IR,IG,2) + REAL(DMU) * + > (FLUX(IR,IG,3) - FLUX(IR,IG,2)) + FLUX(IR,IG,2) = FLUX(IR,IG,1) + REAL(DMU) * + > (FLUX(IR,IG,2) - FLUX(IR,IG,1)) + 12 CONTINUE + 13 CONTINUE + AKEEP(3)= AKEEP(2) + DMU * (AKEEP(3)-AKEEP(2)) + AKEEP(2)= AKEEP(1) + DMU * (AKEEP(2)-AKEEP(1)) + ELSE + ZMU= 1.0 + ENDIF + RETURN + END diff --git a/Dragon/src/FLU2DR.f b/Dragon/src/FLU2DR.f new file mode 100644 index 0000000..37ac316 --- /dev/null +++ b/Dragon/src/FLU2DR.f @@ -0,0 +1,1284 @@ +*DECK FLU2DR + SUBROUTINE FLU2DR(IPRT,IPMACR,IPFLUX,IPSYS,IPTRK,IPFLUP,IPSOU, + 1 IGPT,IFTRAK,CXDOOR,TITLE,NUNKNO,NREG,NSOUT,NANIS,NLF,NLIN,NFUNL, + 2 NGRP,NMAT,NIFIS,LFORW,LEAKSW,MAXINR,EPSINR,MAXOUT,EPSUNK,EPSOUT, + 3 NCPTL,NCPTA,ITYPEC,IPHASE,ITPIJ,ILEAK,OPTION,REFKEF,MATCOD, + 4 KEYFLX,VOL,XSTRC,XSDIA,XSNUF,XSCHI,LREBAL,INITFL,NMERG,IMERG) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Fixed source problem or inverse power method for K-effective or +* buckling iteration. Perform thermal iterations. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPRT print flag. +* IPMACR pointer to the macrolib LCM object. +* IPFLUX pointer to the flux LCM object. +* IPSYS pointer to the system LCM object. +* IPTRK pointer to the tracking LCM object. +* IPFLUP pointer to the unperturbed flux LCM object (if ITYPEC=1). +* IPSOU pointer to the fixed source LCM object (if ITYPEC=0 or 1). +* IGPT index of the fixed source eigenvalue problem to solve. +* IFTRAK tracking file unit number. +* CXDOOR character name of the flux solution door. +* TITLE title. +* NUNKNO number of unknowns per energy group including spherical +* harmonic terms, interface currents and fundamental +* currents. +* NREG number of regions. +* NSOUT number of outer surfaces. +* NANIS maximum cross section Legendre order in object IPMACR. +* NLF number of Legendre orders for the flux. +* NLIN number of polynomial components in flux spatial expansion. +* NFUNL number of spherical harmonics components. +* NGRP number of energy groups. +* NMAT number of mixtures in the macrolib. +* NIFIS number of fissile isotopes. +* LFORW flag set to .false. to solve an adjoint problem. +* LEAKSW leakage flag (=.true. if leakage is present on the outer +* surface). +* MAXINR maximum number of thermal iterations. +* EPSINR thermal iterations epsilon. +* MAXOUT maximum number of outer iterations. +* EPSUNK outer iterations eigenvector epsilon. +* EPSOUT outer iterations eigenvalue epsilon. +* NCPTL number of free iterations in an acceleration cycle. +* NCPTA number of accelerated iterations in an acceleration cycle. +* ITYPEC type of flux evaluation: +* =-2 Fourier analysis; +* =-1 skip the flux calculation; +* =0 fixed sources; +* =1 fixed source eigenvalue problem (GPT type); +* =2 fission sources/k effective convergence; +* =3 fission sources/k effective convergence/ +* db2 buckling evaluation; +* =4 fission sources/db2 buckling convergence; +* =5 b2 sources/db2 buckling convergence. +* IPHASE type of flux solution door (1 for asm 2 for pij). +* ITPIJ type of cp available: +* =1 scatt mod pij (wij); +* =2 stand. pij; +* =3 scatt mod pij+pijk (wij,wijk); +* =4 standard pij+pijk. +* ILEAK method used to include DB2 effect: +* =1 the scattering modified cp matrix is multiplied by PNLR; +* =2 the reduced cp matrix is multiplied by PNL; +* =3 sigs0-db2 approximation; +* =4 albedo approximation; +* =5 Todorova-type isotropic streaming model; +* =6 Ecco-type isotropic streaming model; +* >6 Tibere type anisotropic streaming model. +* OPTION type of leakage coefficients: +* 'LKRD' (recover leakage coefficients in Macrolib); +* 'RHS' (recover leakage coefficients in RHS flux object); +* 'B0' (B-0), 'P0' (P-0), 'B1' (B-1), +* 'P1' (P-1), 'B0TR' (B-0 with transport correction) or 'P0TR' +* (P-0 with transport correction). +* REFKEF target effective multiplication factor. +* MATCOD mixture indices. +* KEYFLX index of L-th order flux components in unknown vector. +* VOL volumes. +* XSTRC transport-corrected macroscopic total cross sections. +* XSDIA transport-corrected macroscopic within-group scattering cross +* sections. +* XSNUF nu*macroscopic fission cross sections. +* XSCHI fission spectrum. +* LREBAL thermal iteration rebalancing flag (=.true. if thermal +* rebalancing required). +* INITFL flux initialization flag (=0/1/2: uniform flux/LCM/DSA). +* NMERG number of leakage zones. +* IMERG leakage zone index in each material mixture zone. +* +*----------------------------------------------------------------------- +* +*---- +* INTERNAL PARAMETERS: +* SYBILF : SYBIL FLUX SOLUTION DOOR EXT ROUTINE +* TRFICF : DEFAULT CP FLUX SOLUTION DOOR EXT ROUTINE +* BIVAF : DEFAULT 2D DIFFUSION FLUX SOLUTION DOOR EXT ROUTINE +* TRIVAF : DEFAULT 3D DIFFUSION FLUX SOLUTION DOOR EXT ROUTINE +* PNF : DEFAULT PN/SPN FLUX SOLUTION DOOR EXT ROUTINE +* SNF : DEFAULT SN FLUX SOLUTION DOOR EXT ROUTINE +*---- +* + USE GANLIB + USE DOORS_MOD +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMACR,IPFLUX,IPSYS,IPTRK,IPFLUP,IPSOU + INTEGER IPRT,IGPT,IFTRAK,NUNKNO,NREG,NSOUT,NANIS,NLF,NLIN,NFUNL, + 1 NGRP,NMAT,NIFIS,MAXINR,MAXOUT,NCPTL,NCPTA,ITYPEC,IPHASE,ITPIJ, + 2 ILEAK,MATCOD(NREG),KEYFLX(NREG,NLIN,NFUNL),INITFL,NMERG, + 3 IMERG(NMAT) + REAL EPSINR,EPSUNK,EPSOUT,VOL(NREG),XSTRC(0:NMAT,NGRP), + 1 XSDIA(0:NMAT,0:NANIS,NGRP),XSNUF(0:NMAT,NIFIS,NGRP), + 2 XSCHI(0:NMAT,NIFIS,NGRP) + CHARACTER CXDOOR*12,TITLE*72,OPTION*4,HLEAK*6 + LOGICAL LFORW,LEAKSW,LREBAL,CFLI,CEXE + DOUBLE PRECISION REFKEF +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40,PI=3.141592654) + TYPE(C_PTR) IPREB,J1,JPSOU,JPFLUX,JPMACR,KPMACR,JPSYS,KPSYS,IPSTR, + 1 JPSTR,KPSTR,JPFLUP1,JPFLUP2,JPSOUR + INTEGER JPAR(NSTATE),KEYSPN(NREG) + CHARACTER CAN(0:19)*2,MESSIN*8,MESSOU*5,HTYPE(0:5)*4 + INTEGER INDD(3) + DOUBLE PRECISION AKEEP(8),FISOUR,OLDBIL,AKEFF,AKEFFO,AFLNOR, + 1 BFLNOR,DDELN1,DDELD1,PROD,FLXIN + LOGICAL LSCAL,LEXAC,REBFLG + REAL ALBEDO(6),FLUXC(NREG),B2(4) +* +************************************************************************ +* * +* ICHAR : COUNTER FOR NUM. OF OUTER ITERATIONS * +* ICTOT : TOTAL NUMBER OF FLUX CALCULATIONS * +* * +************************************************************************ +* +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS,NPSYS,KEYCUR, + 1 MATALB + REAL, ALLOCATABLE, DIMENSION(:) :: DHOM,FXSOR,XSCAT,GAMMA,V,FL,DFL + REAL, ALLOCATABLE, DIMENSION(:,:) :: DIFHET,SFNU + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: FLUX + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: XCSOU +*---- +* FOR NUMERICAL FOURIER ANALYSIS +*---- + REAL OMEGA,XLEN,EKKK,EVALRHO,SPECR + REAL, ALLOCATABLE, DIMENSION(:) :: ARRAYRHO1 + REAL, ALLOCATABLE, DIMENSION(:) :: XXX +*---- +* DATA STATEMENTS +*---- + SAVE CAN,HTYPE + DATA CAN /'00','01','02','03','04','05','06','07','08','09', + > '10','11','12','13','14','15','16','17','18','19'/ + DATA (HTYPE(JJ),JJ=0,5)/'S ','P ',2*'K ','B ','L '/ +*---- +* SCRATCH STORAGE ALLOCATION +* DHOM homogeneous leakage coefficients. +* DIFHET heterogeneous leakage coefficients. +* FLUX iteration flux: +* FLUX(:,:,1) <=old outer; +* FLUX(:,:,2) <=present outer; +* FLUX(:,:,3) <=new outer; +* FLUX(:,:,4) <=source outer; +* FLUX(:,:,5) <=old inner; +* FLUX(:,:,6) <=present inner; +* FLUX(:,:,7) <=new inner; +* FLUX(:,:,8) <=source inner. +*---- + ALLOCATE(IJJ(0:NMAT),NJJ(0:NMAT),IPOS(0:NMAT),NPSYS(NGRP)) + ALLOCATE(FLUX(NUNKNO,NGRP,8),XSCAT(0:NMAT*NGRP),GAMMA(NGRP), + 1 DHOM(NGRP),DIFHET(NMERG,NGRP),XCSOU(NGRP)) +* + REBFLG=.TRUE. + IPREB=IPMACR +* + AKEEP(:8)=0.0D0 + ICHAR=0 + ICTOT=0 +*---- +* RECOVER INDEX FOR THE CURRENTS IN FLUX, NUMERICAL SURFACES, +* ALBEDO IF NEEDED BY THE REBALANCING. +*---- + ICREB=0 + NNN=0 + INSB=0 + IBFP=0 + NDIM=0 + NFOU=0 + LX=0 + ITYPE=0 + IF(CXDOOR.EQ.'MCCG') THEN + CALL LCMGET(IPTRK,'STATE-VECTOR',JPAR) + NANIS_TRK=JPAR(6) + NDIM=JPAR(16) + INSB=JPAR(22) + CALL LCMLEN(IPTRK,'KEYCUR$MCCG',ICREB,ITYLCM) + IF(ICREB.GT.0) THEN + CALL LCMLEN(IPTRK,'NZON$MCCG',ILONG,ITYLCM) + NNN=ILONG-ICREB + ALLOCATE(KEYCUR(NSOUT),V(ILONG),MATALB(ILONG)) + CALL LCMGET(IPTRK,'KEYCUR$MCCG',KEYCUR) + CALL LCMGET(IPTRK,'V$MCCG',V) + CALL LCMGET(IPTRK,'ALBEDO',ALBEDO) + CALL LCMGET(IPTRK,'NZON$MCCG',MATALB) + ENDIF + ELSE IF(CXDOOR.EQ.'SN') THEN + CALL LCMGET(IPTRK,'STATE-VECTOR',JPAR) + ITYPE=JPAR(6) + NDIM=JPAR(9) + LX=JPAR(12) + LY=JPAR(13) + INSB=JPAR(27) + IBFP=JPAR(31) + NFOU=JPAR(34) + ENDIF +*---- +* SELECT THE CALCULATION DOORS FOR WHICH A GROUP-BY-GROUP SCALAR +* PROCEDURE WILL BE USED. A VECTORIAL APPROACH WILL BE USED WITH +* OTHER DOORS. LSCAL is true for CXDOOR = 'TRAFIC'. +*---- + LSCAL=(INSB.EQ.0) +* + CALL KDRCPU(CPU0) + IF(ILEAK.LT.6) THEN + INORM=1 + ELSE IF(ILEAK.EQ.6) THEN + INORM=2 ! Ecco + ELSE IF(ILEAK.GE.7) THEN + INORM=3 ! Tibere + ENDIF + LEXAC=.FALSE. + AKEEP(5)=1.0D0 + AKEEP(6)=1.0D0 + AKEEP(7)=1.0D0 + DIFHET(:NMERG,:NGRP)=0.0 + GAMMA(:NGRP)=1.0 +*---- +* EXTERNAL FLUX(:,:,2) INITIALISATION AND FIXED-EXTERNAL SOURCE IN +* FLUX(:,:,4) +*---- + IF(ITYPEC.GE.3) THEN + CALL LCMGET(IPFLUX,'B2 B1HOM',B2(4)) + IF(ILEAK.GE.7) CALL LCMGET(IPFLUX,'B2 HETE',B2) + ELSE + B2(:4)=0.0 + ENDIF + AKEFFO=0.0D0 + IF(LFORW) THEN + IF(ITYPEC.EQ.1) THEN + J1=LCMGID(IPSOU,'DSOUR') + JPSOU=LCMGIL(J1,IGPT) + J1=LCMGID(IPFLUX,'DFLUX') + JPFLUX=LCMGIL(J1,IGPT) + ELSE + IF(C_ASSOCIATED(IPSOU)) THEN + J1=LCMGID(IPSOU,'DSOUR') + JPSOU=LCMGIL(J1,1) + ENDIF + JPFLUX=LCMGID(IPFLUX,'FLUX') + JPSOUR=LCMLID(IPFLUX,'SOUR',NGRP) + ENDIF + ELSE + IF(ITYPEC.EQ.1) THEN + J1=LCMGID(IPSOU,'ASOUR') + JPSOU=LCMGIL(J1,IGPT) + J1=LCMGID(IPFLUX,'ADFLUX') + JPFLUX=LCMGIL(J1,IGPT) + ELSE + IF(C_ASSOCIATED(IPSOU)) THEN + J1=LCMGID(IPSOU,'ASOUR') + JPSOU=LCMGIL(J1,1) + ENDIF + JPFLUX=LCMGID(IPFLUX,'AFLUX') + JPSOUR=LCMLID(IPFLUX,'SOUR',NGRP) + ENDIF + ENDIF + ALLOCATE(FXSOR(0:NMAT)) + JPMACR=LCMGID(IPMACR,'GROUP') + DO 20 IG=1,NGRP + FLUX(:NUNKNO,IG,2)=0.0 + FLUX(:NUNKNO,IG,4)=0.0 + CALL LCMLEL(JPFLUX,1,ILINIT,ITYLCM) + IF(LFORW) THEN + CALL LCMGDL(JPFLUX,IG,FLUX(1,IG,2)) + ELSE + CALL LCMGDL(JPFLUX,NGRP-IG+1,FLUX(1,IG,2)) + ENDIF +* + IF(((ITYPEC.EQ.0).OR.(ITYPEC.EQ.-2)).AND. + 1 (.NOT.C_ASSOCIATED(IPSOU))) THEN + KPMACR=LCMGIL(JPMACR,IG) + FXSOR(0)=0.0 + CALL LCMGET(KPMACR,'FIXE',FXSOR(1)) + CALL DOORS(CXDOOR,IPTRK,NMAT,0,NUNKNO,FXSOR, + > FLUX(1,IG,4)) + ELSE IF(((ITYPEC.EQ.0).OR.(ITYPEC.EQ.1).OR.(ITYPEC.EQ.-2)) + 1 .AND.C_ASSOCIATED(IPSOU))THEN + IF(LFORW) THEN + CALL LCMGDL(JPSOU,IG,FLUX(1,IG,4)) + ELSE + CALL LCMGDL(JPSOU,NGRP-IG+1,FLUX(1,IG,4)) + ENDIF + ENDIF + 20 CONTINUE + DEALLOCATE(FXSOR) +*------- +* IF IMPORTED FLUX PRESENT FOR SN, REORDER FLUX. +*------- + IF((CXDOOR.EQ.'SN').AND.(INITFL.EQ.2)) THEN + CALL LCMLEN(IPFLUX,'KEYFLX',ILINIT,ITYLCM) + IF(ILINIT.NE.NREG) THEN + WRITE(*,*) NREG, ILINIT + CALL XABORT('FLU2DR: NUMBER OF REGIONS FROM SPN CALCULATION' + 1 //' (OBTAINED FROM LENGTH OF KEYFLX) DOES NOT MATCH NUMBER ' + 2 //'OF REGIONS IN SN CALCULATION. CHECK INPUT FILE FOR ' + 3 //'POTENTIAL ERRORS.') + ENDIF + KEYSPN(:) = 0 + CALL LCMGET(IPFLUX,'KEYFLX',KEYSPN) + DO 25 IG=1,NGRP + CALL SNEST(IPTRK,IPRT,NREG,NUNKNO,MATCOD,IG,KEYFLX,KEYSPN, + 1 FLUX(:,IG,2)) + 25 CONTINUE + ENDIF +*---- +* FOURIER ANALYSIS FLUX INITIALISATION +*---- + ALLOCATE(ARRAYRHO1(NFOU**NDIM)) + ARRAYRHO1(:)=0.0 + IFACOUNT=-1 + 26 IFACOUNT=IFACOUNT+1 +* + IF(ITYPEC.EQ.-2) THEN + IF(NFOU.EQ.0) + > CALL XABORT('FLU2DR: NEED TO SPECIFY FOURIER ANALYSIS ' + > //'KEYWORD NFOU IN TRACKING, AS WELL AS NUMBER OF ' + > //'FREQUENCIES TO INVESTIGATE.') + IF(CXDOOR.NE.'SN') + > CALL XABORT('FLU2DR: FOURIER ANALYSIS ONLY MEANT FOR SN') + IF(NGRP.NE.1) + > CALL XABORT('FLU2DR: FOURIER ANALYSIS NOT MEANT FOR MULTI-' + > //'GROUP PROBLEMS. CONSIDER ADDING THAT FUNCTIONALITY. ') + IGR=1 + + FLUX(:,:,:) = 0.0 + + SUMXSTRC=0.0 + DO IR=1,NREG + SUMXSTRC = SUMXSTRC + XSTRC(MATCOD(IR),1) + ENDDO + AVXSTRC = (SUMXSTRC/NREG) + + ALLOCATE(XXX(LX+1)) + CALL LCMGET(IPTRK,'XXX',XXX) + CALL LCMGET(IPTRK,'XLEN',XLEN) + + OMEGA = (2*PI)/(XLEN*AVXSTRC) + EKKK =(REAL(IFACOUNT)/NFOU) + + IF(ITYPE.EQ.2)THEN + PARTX=0.0 + DO IX=1,LX + PARTX = XXX(IX) + ((XXX(IX+1)-XXX(IX))/2) + IND=KEYFLX(IX,1,1) + IF(IND.GT.0) + > FLUX(IND,IGR,2) = COS(EKKK*OMEGA*AVXSTRC*PARTX) + ENDDO + ELSE + CALL XABORT('FLU2DR: FOURIER ANALYSIS FOR GEOMETRIES OTHER ' + > //'THAN CARTESIAN 1D NOT AVAILABLE.') + ENDIF + DEALLOCATE(XXX) + ENDIF +*---- +* COMPUTE FIRST K-EFFECTIVE +*---- + IF((ITYPEC.EQ.0).OR.(ITYPEC.EQ.5).OR.(ITYPEC.EQ.-2)) THEN + AKEFFO=1.0D0 + AKEFF=1.0D0 + AFLNOR=1.0D0 + ELSE IF(ITYPEC.EQ.1) THEN + CALL LCMGET(IPFLUP,'STATE-VECTOR',JPAR) + IF(JPAR(6).GE.2) THEN + CALL LCMGET(IPFLUP,'K-EFFECTIVE',RKEFF) + CALL LCMGET(IPFLUP,'K-INFINITY',CUREIN) + ENDIF + AKEFF=RKEFF + IF(JPAR(6).GE.3) THEN + B2(:4)=0.0 + CALL LCMGET(IPFLUP,'B2 B1HOM',B2(4)) + ENDIF + IF((JPAR(6).GT.2).AND.(JPAR(7).GE.6)) THEN + CALL LCMGET(IPFLUP,'B2 HETE',B2) + ENDIF + IF((JPAR(6).GT.2).AND.(JPAR(7).GE.5)) THEN + CALL LCMGET(IPFLUP,'GAMMA',GAMMA) + ENDIF + AKEFFO=AKEFF + AKEEP(2)=AKEFF + AFLNOR=1.0D0/RKEFF + ELSE + OLDBIL=0.0D0 + CALL FLUKEF(IPRT,IPMACR,NGRP,NREG,NUNKNO,NMAT,NIFIS,NANIS, + 1 MATCOD(1),VOL,KEYFLX(1,1,1),XSTRC,XSDIA,XSNUF,XSCHI,NMERG, + 2 IMERG,DIFHET,FLUX(1,1,2),B2,ILEAK,LEAKSW,OLDBIL,AKEFF,AFLNOR) + AKEFFO=AKEFF + AKEEP(2)=AKEFF + ENDIF + B2VALO=B2(4) +* + NCTOT=NCPTA+NCPTL + IF(NCPTA.EQ.0) THEN + NCPTM=NCTOT+1 + ELSE + NCPTM=NCPTL + ENDIF + MESSOU=' ' + IF(IPRT.GT.0) WRITE(6,1090) 0,1.0,EPSOUT,AKEFFO,B2(4) +*---- +* CALCULATION OF THE INITIAL LEAKAGE COEFFICIENTS +*---- + IF(ITYPEC.GT.2) THEN + DIFHET(:NMERG,:NGRP)=0.0 + IF(OPTION.EQ.'LKRD') THEN + CALL LCMGET(IPMACR,'STATE-VECTOR',JPAR) + IF(JPAR(2).NE.NMAT) THEN + CALL XABORT('FLU2DR: INVALID NMAT IN THE MACROLIB.') + ELSE IF(JPAR(9).NE.1) THEN + CALL XABORT('FLU2DR: INVALID LEAKAGE IN THE MACROLIB.') + ENDIF + ALLOCATE(FL(NMAT),DFL(NMAT)) + JPMACR=LCMGID(IPMACR,'GROUP') + DO IG=1,NGRP + KPMACR=LCMGIL(JPMACR,IG) + CALL LCMLEN(KPMACR,'DIFF',ILONG,ITYLCM) + IF(ILONG.EQ.0) CALL XABORT('FLU2DR: UNABLE TO RECOVER T' + > //'HE DIFF RECORD IN THE MACROLIB OBJECT.') + IF(NMERG.EQ.NMAT) THEN + CALL LCMGET(KPMACR,'DIFF',DIFHET(1,IG)) + ELSE + CALL LCMGET(KPMACR,'DIFF',DFL) + CALL LCMGET(KPMACR,'FLUX-INTG',FL) + DO INM=1,NMERG + DDELN1=0.D0 + DDELD1=0.D0 + DO IBM=1,NMAT + IF(IMERG(IBM).EQ.INM) THEN + DDELN1=DDELN1+FL(IBM)/DFL(IBM) + DDELD1=DDELD1+FL(IBM) + ENDIF + ENDDO + IF(DDELN1.EQ.0.D0) CALL XABORT('FLU2DR: DDELN1=0.') + DIFHET(INM,IG)=REAL(DDELD1/DDELN1) + ENDDO + ENDIF + ENDDO + DEALLOCATE(DFL,FL) + GAMMA(:NGRP)=1.0 + ELSE IF(OPTION.EQ.'RHS') THEN + CALL LCMLEN(IPFLUX,'DIFFHET',ILONG,ITYLCM) + IF(ILONG.EQ.NMERG*NGRP) THEN + IF(LFORW) THEN + CALL LCMGET(IPFLUX,'DIFFHET',DIFHET) + ELSE +* Permute the diffusion coefficients if the LKRD option +* is set for an adjoint calculation + CALL LCMGET(IPFLUX,'DIFFHET',DIFHET) + DO INM=1,NMERG + GAMMA(:NGRP)=DIFHET(INM,:NGRP) + DO IG=1,NGRP + DIFHET(INM,IG)=GAMMA(NGRP-IG+1) + ENDDO + ENDDO + ENDIF + ELSE + CALL XABORT('FLU2DR: UNABLE TO RECOVER THE DIFFHET RECO' + > //'RD IN THE FLUX OBJECT.(1)') + ENDIF + GAMMA(:NGRP)=1.0 + ELSE IF((LEAKSW).OR.(ILEAK.EQ.5)) THEN +* Todorova heterogeneous leakage model. + CALL FLULPN(IPMACR,NUNKNO,OPTION,'DIFF',NGRP,NREG,NMAT, + 1 VOL,MATCOD,NMERG,IMERG,KEYFLX(1,1,1),FLUX(1,1,2),B2(4), + 2 IPRT,DIFHET,DHOM) + GAMMA(:NGRP)=1.0 + ELSE +* FUNDAMENTAL MODE CONDITION. + IF(NMERG.NE.1) CALL XABORT('FLU2DR: ONE LEAKAGE ZONE EXPEC' + 1 //'TED.(1)') + CALL B1HOM(IPMACR,LEAKSW,NUNKNO,OPTION,'DIFF',NGRP,NREG, + 1 NMAT,NIFIS,VOL,MATCOD,KEYFLX(1,1,1),FLUX(1,1,2),REFKEF, + 2 IPRT,DIFHET(1,1),GAMMA,AKEFF,INORM,B2) + ENDIF + CALL LCMPUT(IPFLUX,'B2 B1HOM',1,2,B2(4)) + CALL LCMPUT(IPFLUX,'DIFFHET',NMERG*NGRP,2,DIFHET) + ENDIF +* +**** OUTER LOOP ****************************************** + IGDEB=1 + CFLI=.FALSE. + CEXE=.FALSE. + DO 400 IT=1,MAXOUT + CALL KDRCPU(CPU1) + MESSIN=' ' +*---- +* FISSION SOURCE CALCULATION IN FLUX(:,:,4) +*---- + IF(((ITYPEC.EQ.0).OR.(ITYPEC.EQ.-2)) + 1 .AND.(.NOT.C_ASSOCIATED(IPSOU))) THEN + ALLOCATE(FXSOR(0:NMAT)) + JPMACR=LCMGID(IPMACR,'GROUP') + FLUX(:NUNKNO,:NGRP,4)=0.0 + DO IG=1,NGRP + KPMACR=LCMGIL(JPMACR,IG) + FXSOR(0)=0.0 + CALL LCMGET(KPMACR,'FIXE',FXSOR(1)) + CALL DOORS(CXDOOR,IPTRK,NMAT,0,NUNKNO,FXSOR, + > FLUX(1,IG,4)) + ENDDO + DEALLOCATE(FXSOR) + ELSE IF((ITYPEC.EQ.0).OR.(ITYPEC.EQ.-2)) THEN + DO IG=1,NGRP + IF(LFORW) THEN + CALL LCMGDL(JPSOU,IG,FLUX(1,IG,4)) + ELSE + CALL LCMGDL(JPSOU,NGRP-IG+1,FLUX(1,IG,4)) + ENDIF + ENDDO + ELSE IF(ITYPEC.EQ.1) THEN + DO IG=1,NGRP + IF(LFORW) THEN + CALL LCMGDL(JPSOU,IG,FLUX(1,IG,4)) + ELSE + CALL LCMGDL(JPSOU,NGRP-IG+1,FLUX(1,IG,4)) + ENDIF + DO IUN=1,NUNKNO + FLUX(IUN,IG,4)=-FLUX(IUN,IG,4) + ENDDO + ENDDO + ELSE + FLUX(:NUNKNO,:NGRP,4)=0.0 + ENDIF + IF(NIFIS.GT.0) THEN + IF(CXDOOR.EQ.'BIVAC') THEN + CALL BIVFIS(IPTRK,NREG,NMAT,NIFIS,NUNKNO,NGRP,MATCOD,VOL, + > XSCHI,XSNUF,FLUX(1,1,2),FLUX(1,1,4)) + ELSE IF(CXDOOR.EQ.'TRIVAC') THEN + CALL TRIFIS(IPTRK,NREG,NMAT,NIFIS,NUNKNO,NGRP,MATCOD,VOL, + > XSCHI,XSNUF,FLUX(1,1,2),FLUX(1,1,4)) + ELSE + ALLOCATE(FXSOR(NUNKNO)) + DO IS=1,NIFIS + FXSOR(:NUNKNO)=0.0 + DO IG=1,NGRP + CALL DOORS(CXDOOR,IPTRK,NMAT,0,NUNKNO,XSNUF(0,IS,IG), + > FXSOR,FLUX(1,IG,2)) + ENDDO + DO IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.EQ.0) CYCLE + DO IE=1,NLIN + IND=KEYFLX(IR,IE,1) + IF(IND.EQ.0) CYCLE + DO IG=1,NGRP + FLUX(IND,IG,4)=FLUX(IND,IG,4)+XSCHI(IBM,IS,IG)* + > FXSOR(IND) + ENDDO + ENDDO + ENDDO + ENDDO ! IS + DEALLOCATE(FXSOR) + ENDIF + FLUX(:NUNKNO,:NGRP,4)=FLUX(:NUNKNO,:NGRP,4)*REAL(AFLNOR) + ENDIF +*---- +* VOLUME-INTEGRATED SOURCE CALCULATION FOR USE IN NEUTRON BALANCE +*---- + DO IG=1,NGRP + XCSOU(IG)=0.0D0 + DO IR=1,NREG + IND=KEYFLX(IR,1,1) + IF((CXDOOR.EQ.'BIVAC').OR.(CXDOOR.EQ.'TRIVAC')) THEN + ! volumes are already included in the sources + IF(IND.GT.0) XCSOU(IG)=XCSOU(IG)+FLUX(IND,IG,4) + ELSE + IF(IND.GT.0) XCSOU(IG)=XCSOU(IG)+FLUX(IND,IG,4)*VOL(IR) + ENDIF + ENDDO + ENDDO + ISBS=-1 + IF(C_ASSOCIATED(IPSOU)) CALL LCMLEN(IPSOU,'NBS',ISBS,ITYLCM) +*---- +* SET THE STARTING ENERGY GROUP +*---- + DO 40 IG=1,NGRP + IGDEB=IG + IF(XCSOU(IG).NE.0.0.OR.ISBS.NE.0) GO TO 50 + 40 CONTINUE +*---- +* DOWNLOAD FROM EXTERNAL FLUX(:,:,2) TO PRESENT INTERNAL FLUX(:,:,6) +*---- + 50 FLUX(:NUNKNO,:NGRP,6)=FLUX(:NUNKNO,:NGRP,2) +* +**** INNER LOOP ****************************************** + DO 270 JT=1,MAXINR + FLUX(:NUNKNO,IGDEB:NGRP,7)=FLUX(:NUNKNO,IGDEB:NGRP,6) + FLUX(:NUNKNO,IGDEB:NGRP,8)=FLUX(:NUNKNO,IGDEB:NGRP,4) + JPMACR=LCMGID(IPMACR,'GROUP') + DO 140 IG=IGDEB,NGRP +*---- +* PROCESS SELF-SCATTERING REDUCTION IN INNER SOURCES. +*---- + IF((ITPIJ.EQ.2).OR.(ITPIJ.EQ.4)) THEN + IF((CXDOOR.EQ.'BIVAC').OR.(CXDOOR.EQ.'TRIVAC')) THEN + CALL XABORT('FLU2DR: SCATTERING REDUCTION IS MANDATORY.') + ENDIF + CALL DOORS(CXDOOR,IPTRK,NMAT,NANIS,NUNKNO,XSDIA(0,0,IG), + > FLUX(1,IG,8),FLUX(1,IG,7)) + ENDIF + IF(ILEAK.EQ.6) THEN +* ECCO ISOTROPIC STREAMING MODEL. + CCLBD=0.0 + IF((ITPIJ.EQ.1).OR.(ITPIJ.EQ.3).AND.(OPTION.EQ.'B1')) + > CCLBD=1.0-GAMMA(IG) + DO 75 IE=1,NLIN + DO 70 IR=1,NREG + IBM=MATCOD(IR) + IND=NUNKNO/2+KEYFLX(IR,IE,1) + IF(IND.EQ.NUNKNO/2) GO TO 70 + IF(OPTION(2:2).EQ.'1') THEN +* B1 OR P1 CASE. + IF(ITPIJ.EQ.2) THEN + FLUX(IND,IG,8)=FLUX(IND,IG,8)+XSDIA(IBM,1,IG)* + > FLUX(IND,IG,7) + ENDIF + ELSE IF(ITPIJ.EQ.1) THEN +* B0, P0, B0TR OR P0TR CASE. + FLUX(IND,IG,8)=FLUX(IND,IG,8)-XSDIA(IBM,1,IG)* + > FLUX(IND,IG,7)*GAMMA(IG) + ENDIF + FLUX(IND,IG,8)=FLUX(IND,IG,8)+CCLBD*XSDIA(IBM,1,IG)* + > FLUX(IND,IG,7) + 70 CONTINUE + 75 CONTINUE + ELSE IF(ILEAK.GE.7) THEN +* TIBERE ANISOTROPIC STREAMING MODEL. + CCLBD=0.0 + IF((ITPIJ.EQ.3).AND.(OPTION.EQ.'B1')) CCLBD=1.0-GAMMA(IG) + DO 86 IE=1,NLIN + DO 85 IR=1,NREG + IND0=KEYFLX(IR,IE,1) + IF(IND0.EQ.0) GO TO 85 + IBM=MATCOD(IR) + INDD(1)=NUNKNO/4+IND0 + INDD(2)=NUNKNO/2+IND0 + INDD(3)=3*NUNKNO/4+IND0 + DO 80 IDIR=1,3 + IND=INDD(IDIR) + IF(OPTION(2:2).EQ.'1') THEN +* B1 OR P1 CASE. + IF(ITPIJ.EQ.4) THEN + FLUX(IND,IG,8)=FLUX(IND,IG,8)+XSDIA(IBM,1,IG)* + > FLUX(IND,IG,7) + ENDIF + ELSE IF(ITPIJ.EQ.3) THEN +* B0, P0, B0TR OR P0TR CASE. + FLUX(IND,IG,8)=FLUX(IND,IG,8)-XSDIA(IBM,1,IG)* + > FLUX(IND,IG,7)*GAMMA(IG) + ENDIF + FLUX(IND,IG,8)=FLUX(IND,IG,8)+CCLBD*XSDIA(IBM,1,IG)* + > FLUX(IND,IG,7) + 80 CONTINUE + 85 CONTINUE + 86 CONTINUE + ENDIF +*---- +* COMPUTE INNER SOURCES ASSUMING SELF-SCATTERING REDUCTION. +*---- + IF(.NOT.LSCAL) THEN + KPMACR=LCMGIL(JPMACR,IG) + NUNK2=NUNKNO + IF(ILEAK.EQ.6) NUNK2=NUNKNO/2 + IF(ILEAK.GE.7) NUNK2=NUNKNO/4 + IF((CXDOOR.EQ.'SN').AND.(IBFP.EQ.0)) THEN + NUNK2=NUNKNO + CALL SNSOUR(NUNKNO,IG,IPTRK,KPMACR,NANIS,NREG,NMAT,NUNK2, + 1 NGRP,MATCOD,FLUX(1,1,7),FLUX(1,1,8)) + ELSE IF(CXDOOR.EQ.'SN') THEN + NUNK2=NUNKNO + IPSTR=LCMGID(IPSYS,'STREAMING') + JPSTR=LCMGID(IPSTR,'GROUP') + KPSYS=LCMGIL(JPSTR,IG) + CALL SNSBFP(IG,IPTRK,KPMACR,KPSYS,NANIS,NLF,NREG,NMAT, + 1 NUNK2,NGRP,MATCOD,FLUX(1,1,7),FLUX(1,1,8)) + ELSE + HLEAK=' ' + CALL FLUSOU(CXDOOR,HLEAK,NUNKNO,IG,IPTRK,KPMACR,NMAT,NANIS, + 1 NUNK2,NGRP,FLUX(1,1,7),FLUX(1,1,8)) + ENDIF + IF((ILEAK.EQ.6).AND.(OPTION(2:2).EQ.'1')) THEN +* ECCO ISOTROPIC STREAMING MODEL. + HLEAK='ECCO ' + CALL FLUSOU(CXDOOR,HLEAK,NUNKNO,IG,IPTRK,KPMACR,NMAT,NANIS, + 1 NUNK2,NGRP,FLUX(1,1,7),FLUX(1,1,8)) + ELSE IF(ILEAK.GE.7) THEN +* TIBERE ANISOTROPIC STREAMING MODEL. + HLEAK='TIBERE' + CALL FLUSOU(CXDOOR,HLEAK,NUNKNO,IG,IPTRK,KPMACR,NMAT,NANIS, + 1 NUNK2,NGRP,FLUX(1,1,7),FLUX(1,1,8)) + ENDIF + ENDIF + 140 CONTINUE +*---- +* FLUX COMPUTATION +*---- + NPSYS(:NGRP)=0 + DO 150 IG=IGDEB,NGRP + NPSYS(IG)=IG + 150 CONTINUE + JPSTR=C_NULL_PTR + IF(C_ASSOCIATED(IPSYS)) THEN + JPSYS=LCMGID(IPSYS,'GROUP') + IF(ILEAK.EQ.6.OR.((MOD(ILEAK,10).EQ.7).AND.(IPHASE.EQ.1))) THEN + IPSTR=LCMGID(IPSYS,'STREAMING') + JPSTR=LCMGID(IPSTR,'GROUP') + ENDIF + ENDIF + IF((.NOT.LSCAL).AND.(ILEAK.EQ.0)) THEN + IDIR=0 + CALL DOORFV(CXDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IPRT,NGRP, + 1 NMAT,IDIR,NREG,NUNKNO,IPHASE,LEXAC,MATCOD,VOL,KEYFLX,TITLE, + 2 FLUX(1,1,8),FLUX(1,1,7),IPREB,IPSOU,REBFLG,FLUXC,EVALRHO) + ELSE IF(.NOT.LSCAL) THEN + CALL FLUDBV(CXDOOR,IPHASE,JPSYS,JPSTR,NPSYS,IPTRK,IFTRAK, + 1 IPRT,NREG,NUNKNO,NFUNL,NGRP,NMAT,NANIS,LEXAC,MATCOD,VOL,KEYFLX, + 2 TITLE,ILEAK,LEAKSW,XSTRC,XSDIA,B2,NMERG,IMERG,DIFHET,GAMMA, + 3 FLUX(1,1,2),FLUX(1,1,8),FLUX(1,1,7),IPREB,IPSOU,REBFLG,FLUXC) + ELSE +* A GROUP-BY-GROUP SCALAR PROCEDURE IS BEEN USED. + IF(.NOT.C_ASSOCIATED(IPSYS)) THEN + CALL XABORT('FLU2DR: MISSING L_PIJ OBJECT.') + ENDIF + KPSTR=C_NULL_PTR + DO 230 IG=IGDEB,NGRP + IF(IPRT.GT.10) WRITE(6,'(/25H FLU2DR: PROCESSING GROUP,I5, + > 6H WITH ,A,1H.)') IG,CXDOOR + KPMACR=LCMGIL(JPMACR,IG) + NUNK2=NUNKNO + IF(ILEAK.EQ.6) NUNK2=NUNKNO/2 + IF(ILEAK.GE.7) NUNK2=NUNKNO/4 + IF(CXDOOR.EQ.'BIVAC') THEN + CALL BIVSOU(NUNKNO,IG,IPTRK,KPMACR,NANIS,NREG,NMAT,NUNK2, + 1 NGRP,MATCOD,VOL,FLUX(1,1,7),FLUX(1,1,8)) + ELSE IF(CXDOOR.EQ.'TRIVAC') THEN + CALL TRIVSO(NUNKNO,IG,IPTRK,KPMACR,NANIS,NREG,NMAT,NUNK2, + 1 NGRP,MATCOD,VOL,FLUX(1,1,7),FLUX(1,1,8)) + ELSE IF((CXDOOR.EQ.'SN').AND.(IBFP.EQ.0)) THEN + CALL SNSOUR(NUNKNO,IG,IPTRK,KPMACR,NANIS,NREG,NMAT,NUNK2, + 1 NGRP,MATCOD,FLUX(1,1,7),FLUX(1,1,8)) + ELSE IF(CXDOOR.EQ.'SN') THEN + JPSYS=LCMGID(IPSYS,'GROUP') + KPSYS=LCMGIL(JPSYS,IG) + CALL SNSBFP(IG,IPTRK,KPMACR,KPSYS,NANIS,NLF,NREG,NMAT, + 1 NUNK2,NGRP,MATCOD,FLUX(1,1,7),FLUX(1,1,8)) + ELSE + HLEAK=' ' + CALL FLUSOU(CXDOOR,HLEAK,NUNKNO,IG,IPTRK,KPMACR,NMAT,NANIS, + 1 NUNK2,NGRP,FLUX(1,1,7),FLUX(1,1,8)) + ENDIF + IF((ILEAK.EQ.6).AND.(OPTION(2:2).EQ.'1')) THEN +* ECCO ISOTROPIC STREAMING MODEL. + HLEAK='ECCO ' + CALL FLUSOU(CXDOOR,HLEAK,NUNKNO,IG,IPTRK,KPMACR,NMAT,NANIS, + 1 NUNK2,NGRP,FLUX(1,1,7),FLUX(1,1,8)) + ELSE IF(ILEAK.GE.7) THEN +* TIBERE ANISOTROPIC STREAMING MODEL. + HLEAK='TIBERE' + CALL FLUSOU(CXDOOR,HLEAK,NUNKNO,IG,IPTRK,KPMACR,NMAT,NANIS, + 1 NUNK2,NGRP,FLUX(1,1,7),FLUX(1,1,8)) + ENDIF +* + NPSYS(:NGRP)=0 + NPSYS(IG)=IG + IF(ILEAK.EQ.0) THEN + IDIR=0 + CALL DOORFV(CXDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IPRT,NGRP, + 1 NMAT,IDIR,NREG,NUNKNO,IPHASE,LEXAC,MATCOD,VOL,KEYFLX,TITLE, + 2 FLUX(1,1,8),FLUX(1,1,7),IPREB,IPSOU,REBFLG,FLUXC,EVALRHO) + ELSE + CALL FLUDBV(CXDOOR,IPHASE,JPSYS,JPSTR,NPSYS,IPTRK,IFTRAK, + 1 IPRT,NREG,NUNKNO,NFUNL,NGRP,NMAT,NANIS,LEXAC,MATCOD,VOL, + 2 KEYFLX,TITLE,ILEAK,LEAKSW,XSTRC,XSDIA,B2,NMERG,IMERG,DIFHET, + 3 GAMMA,FLUX(1,1,2),FLUX(1,1,8),FLUX(1,1,7),IPREB,IPSOU,REBFLG, + 4 FLUXC) + ENDIF + 230 CONTINUE + ENDIF + IF(LREBAL.AND.(ITYPEC.NE.5)) THEN + CALL FLUBAL(IPMACR,NGRP,ILEAK,NMAT,NREG,ICREB,NUNKNO,NANIS, + 1 MATCOD,VOL,KEYFLX(1,1,1),XSTRC,XSDIA,XCSOU,IGDEB,B2,NMERG, + 2 IMERG,DIFHET,KEYCUR,MATALB(NNN+1),ALBEDO,V(NNN+1),FLUX(1,1,7)) + ENDIF +*---- +* ACCELERATING INNER ITERATIONS CYCLICALLY DEPENDING ON PARAM. +*---- + IF(MOD(JT-1,NCTOT).GE.NCPTM) THEN + CALL FLU2AC(NGRP,NUNKNO,IGDEB,FLUX(1,1,5),AKEEP(5),ZMU) + ELSE + ZMU=1.0 + ENDIF +*---- +* CALCULATING ERROR AND PREC BETWEEN PRESENT AND NEW FLUX FOR +* EACH GROUP. RETAIN LARGEST ERROR BETWEEN ANY GROUP. +*---- + EINN=0.0 + ICHAR=ICHAR+1 + ICTOT=ICTOT+NGRP-IGDEB+1 + IGDEBO=IGDEB + DO 260 IG=IGDEBO,NGRP + GINN=0.0 + FINN=0.0 + DO 240 IR=1,NREG + IND=KEYFLX(IR,1,1) + IF(IND.EQ.0) GO TO 240 + GINN=MAX(GINN,ABS(FLUX(IND,IG,6)-FLUX(IND,IG,7))) + FINN=MAX(FINN,ABS(FLUX(IND,IG,7))) + 240 CONTINUE + FLUX(:NUNKNO,IG,5)=FLUX(:NUNKNO,IG,6) + FLUX(:NUNKNO,IG,6)=FLUX(:NUNKNO,IG,7) + GINN=GINN/FINN + IF((GINN.LT.EPSINR).AND.(IGDEB.EQ.IG)) THEN + IGDEB=IGDEB+1 + ELSEIF((IGDEB.EQ.IG).AND.(IG.LT.NGRP)) THEN + ERRDEB1=GINN + ENDIF + EINN=MAX(EINN,GINN) + 260 CONTINUE +* + ITERF=JT + IF(IPRT.GT.0) WRITE(6,1080) JT,EINN,EPSINR,IGDEB,ZMU + IF((IPRT.GT.0).AND.(IGDEB.GT.1).AND.(IGDEB.LE.NGRP)) THEN + WRITE(6,1082) ERRDEB1 + ENDIF + IF(EINN.LT.EPSINR) THEN +* thermal convergence is reached + CFLI=CEXE + GOTO 280 + ENDIF +* near convergence (eps < 10.0 criterion) a new outer iteration +* is started + IF((IGDEB.GT.1).AND.(EINN.LT.10.*EPSINR)) GOTO 281 + 270 CONTINUE + MESSIN='*NOT*' +**** END OF INNER LOOP ****************************************** +* + 281 MESSIN='*NEARLY*' + 280 IF(LREBAL) THEN + IF(LEAKSW) THEN + IF(ICREB.EQ.0) THEN + WRITE(6,*) ' *** INCOMPATIBILITY ON LEAKAGE SWITCH ***' + CALL XABORT('FLU2DR: ERROR ON LEAKAGE SWITCH') + ELSE + IF(IPRT.GT.0) + & WRITE(6,*) 'FLU2DR: LEAKAGE & ICREB -> REBALANCING ON' + ENDIF + ELSE + IF(IPRT.GT.0) + & WRITE(6,*) 'FLU2DR: NO LEAKAGE-> REBALANCING ON' + ENDIF + ELSE + IF(IPRT.GT.0) WRITE(6,*) 'FLU2DR: LEAKAGE-> REBALANCING OFF' + ENDIF + CALL KDRCPU(CPU2) + IF(IPRT.GT.0) WRITE(6,1040) CPU2-CPU1,'INTERNAL',MESSIN,ITERF +*---- +* PROMOTE FROM NEW INTERNAL FLUX(,,,7) TO NEW EXTERNAL FLUX(,,,3) +*---- + FLUX(:NUNKNO,:NGRP,3)=FLUX(:NUNKNO,:NGRP,7) + FLUX(:NUNKNO,:NGRP,4)=FLUX(:NUNKNO,:NGRP,8) +*---- +* HOTELLING DEFLATION IN GPT CASES. +*---- + IF(ITYPEC.EQ.1) THEN + JPFLUP1=LCMGID(IPFLUP,'FLUX') + JPFLUP2=LCMGID(IPFLUP,'AFLUX') + DDELN1=0.0D0 + DDELD1=0.0D0 + DO 300 IG=1,NGRP + IF(LFORW) THEN + CALL LCMGDL(JPFLUP1,IG,FLUX(1,IG,5)) ! EVECT + CALL LCMGDL(JPFLUP2,IG,FLUX(1,IG,6)) ! ADECT + ELSE + CALL LCMGDL(JPFLUP2,NGRP-IG+1,FLUX(1,IG,5)) ! ADECT + CALL LCMGDL(JPFLUP1,NGRP-IG+1,FLUX(1,IG,6)) ! EVECT + ENDIF + 300 CONTINUE + FLUX(:NUNKNO,:NGRP,7)=0.0 + IF(CXDOOR.EQ.'BIVAC') THEN + CALL BIVFIS(IPTRK,NREG,NMAT,NIFIS,NUNKNO,NGRP,MATCOD,VOL, + > XSCHI,XSNUF,FLUX(1,1,6),FLUX(1,1,7)) + ELSE IF(CXDOOR.EQ.'TRIVAC') THEN + CALL TRIFIS(IPTRK,NREG,NMAT,NIFIS,NUNKNO,NGRP,MATCOD,VOL, + > XSCHI,XSNUF,FLUX(1,1,6),FLUX(1,1,7)) + ELSE + ALLOCATE(FXSOR(NUNKNO)) + DO IS=1,NIFIS + FXSOR(:NUNKNO)=0.0 + DO IG=1,NGRP + CALL DOORS(CXDOOR,IPTRK,NMAT,0,NUNKNO,XSNUF(0,IS,IG), + > FXSOR,FLUX(1,IG,6)) + ENDDO + DO IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.EQ.0) CYCLE + DO IE=1,NLIN + IND=KEYFLX(IR,IE,1) + IF(IND.EQ.0) CYCLE + DO IG=1,NGRP + FLUX(IND,IG,7)=FLUX(IND,IG,7)+XSCHI(IBM,IS,IG)* + > FXSOR(IND) + ENDDO + ENDDO + ENDDO + ENDDO ! IS + DEALLOCATE(FXSOR) + ENDIF +* + DO 335 IG=1,NGRP + DO 330 IND=1,NUNKNO + DDELN1=DDELN1+FLUX(IND,IG,7)*FLUX(IND,IG,3) + DDELD1=DDELD1+FLUX(IND,IG,7)*FLUX(IND,IG,5) + 330 CONTINUE + 335 CONTINUE + DO 345 IG=1,NGRP + DO 340 IND=1,NUNKNO + FLUX(IND,IG,3)=FLUX(IND,IG,3)-REAL(DDELN1/DDELD1)*FLUX(IND,IG,5) + 340 CONTINUE + 345 CONTINUE + ENDIF +* + IF(ITYPEC.EQ.2) THEN +* NO B-N LEAKAGE CALCULATION REQUIRED + IF(B2(4).NE.0.0) CALL XABORT('FLU2DR: NON ZERO BUCKLING.') + CALL FLUKEF(IPRT,IPMACR,NGRP,NREG,NUNKNO,NMAT,NIFIS,NANIS, + 1 MATCOD(1),VOL,KEYFLX(1,1,1),XSTRC,XSDIA,XSNUF,XSCHI,NMERG, + 2 IMERG,DIFHET,FLUX(1,1,3),B2,ILEAK,LEAKSW,OLDBIL,AKEFF,AFLNOR) + ELSE IF(ITYPEC.GT.2) THEN +* PERFORM LEAKAGE CALCULATION. + CALL LCMLEN(IPFLUX,'DIFFHET',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + CALL XABORT('FLU2DR: UNABLE TO RECOVER THE DIFFHET RECORD ' + 1 //'IN THE FLUX OBJECT.(2)') + ENDIF + CALL LCMGET(IPFLUX,'DIFFHET',DIFHET) + GAMMA(:NGRP)=1.0 + IF(ILEAK.EQ.5) THEN +* Todorova heterogeneous leakage model. + CALL FLULPN(IPMACR,NUNKNO,OPTION,HTYPE(ITYPEC),NGRP,NREG, + 1 NMAT,VOL,MATCOD,NMERG,IMERG,KEYFLX(1,1,1),FLUX(1,1,3),B2(4), + 2 IPRT,DIFHET,DHOM) + IF(.NOT.LEAKSW) THEN + CALL B1HOM(IPMACR,LEAKSW,NUNKNO,'LKRD',HTYPE(ITYPEC),NGRP, + 1 NREG,NMAT,NIFIS,VOL,MATCOD,KEYFLX(1,1,1),FLUX(1,1,3), + 2 REFKEF,IPRT,DHOM(1),GAMMA,AKEFF,INORM,B2) + GO TO 350 + ENDIF + ENDIF + IF(LEAKSW) THEN + IF(HTYPE(ITYPEC).NE.'K') THEN + CALL XABORT('FLU2DR: TYPE K EXPECTED WITH OPEN GEOMETRY.') + ENDIF + JPMACR=LCMGID(IPMACR,'GROUP') + ALLOCATE(SFNU(NMAT,NIFIS)) + PROD=0.0D0 + DO IGR=1,NGRP + KPMACR=LCMGIL(JPMACR,IGR) + SFNU(:NMAT,:NIFIS)=0.0 + IF(NIFIS.GT.0) CALL LCMGET(KPMACR,'NUSIGF',SFNU) + DO IBM=1,NMAT + FLXIN=0.0D0 + DO I=1,NREG + IND=KEYFLX(I,1,1) + IF((MATCOD(I).EQ.IBM).AND.(IND.GT.0)) THEN + FLXIN=FLXIN+FLUX(IND,IGR,3)*VOL(I) + ENDIF + ENDDO + DO NF=1,NIFIS + PROD=PROD+SFNU(IBM,NF)*FLXIN + ENDDO + ENDDO + ENDDO + DEALLOCATE(SFNU) + AKEFF=AKEFF*PROD/OLDBIL + OLDBIL=PROD + IF(IPRT.GT.0) WRITE (6,1150) B2(4),AKEFF + ELSE +* FUNDAMENTAL MODE CONDITION. + IF(NMERG.NE.1) CALL XABORT('FLU2DR: ONE LEAKAGE ZONE EXPEC' + 1 //'TED.(2)') + CALL B1HOM(IPMACR,LEAKSW,NUNKNO,OPTION,HTYPE(ITYPEC),NGRP, + 1 NREG,NMAT,NIFIS,VOL,MATCOD,KEYFLX(1,1,1),FLUX(1,1,3), + 2 REFKEF,IPRT,DIFHET(1,1),GAMMA,AKEFF,INORM,B2) + IF(ILEAK.GE.7) THEN +* COMPUTE THE DIRECTIONNAL BUCKLING COMPONENTS FOR TIBERE. + IHETL=ILEAK/10-1 + IF(IHETL.GT.0) THEN + CALL FLUBLN(IPMACR,IPRT,NGRP,NMAT,NREG,NUNKNO,NIFIS, + 1 MATCOD,VOL,KEYFLX(1,1,1),FLUX(1,1,3),IHETL,REFKEF,B2) + ENDIF + ENDIF + ENDIF + 350 CALL LCMPUT(IPFLUX,'B2 B1HOM',1,2,B2(4)) + CALL LCMPUT(IPFLUX,'DIFFHET',NMERG*NGRP,2,DIFHET) + ENDIF + IF(ITYPEC.GE.3) THEN + IF(B2(4).EQ.0.0) THEN + BFLNOR=1.0D0 + ELSE + BFLNOR=1.0D0/ABS(B2(4)) + ENDIF + EEXT=REAL(ABS(B2(4)-B2VALO)*BFLNOR) + B2VALO=B2(4) + ENDIF + IEXTF=IT + IF((ITYPEC.GT.1).AND.(ITYPEC.LT.5)) THEN + IF(AKEFF.NE.0.0) AFLNOR=1.0D0/AKEFF + EEXT=REAL(ABS(AKEFF-AKEFFO)/AKEFF) + ELSE + EEXT=0.0 + ENDIF + AKEEP(3)=AKEFF +*---- +* ACCELERATING INNER ITERATIONS CYCLICALLY DEPENDING ON PARAM. +*---- + IF(MOD(IT-1,NCTOT).GE.NCPTM) THEN + CALL FLU2AC(NGRP,NUNKNO,1,FLUX(1,1,1),AKEEP(1),ZMU) + ELSE + ZMU=1.0 + ENDIF +* + EINN=0.0 + IF(IPRT.GT.0) WRITE(6,1090) IT,EEXT,EPSOUT,AKEFF,B2(4) + IF(EEXT.LT.EPSOUT) THEN +* COMPARE FLUX FOR OUTER ITERATIONS + DO 370 IG=1,NGRP + GINN=0.0 + FINN=0.0 + DO 360 IR=1,NREG + IND=KEYFLX(IR,1,1) + IF(IND.EQ.0) GO TO 360 + GINN=MAX(GINN,ABS(FLUX(IND,IG,2)-FLUX(IND,IG,3))) + FINN=MAX(FINN,ABS(FLUX(IND,IG,3))) + 360 CONTINUE + FLUX(:NUNKNO,IG,1)=FLUX(:NUNKNO,IG,2) + FLUX(:NUNKNO,IG,2)=FLUX(:NUNKNO,IG,3) + GINN=GINN/FINN + EINN=MAX(EINN,GINN) + 370 CONTINUE + IF(IPRT.GT.0) WRITE(6,1100) IT,EINN,EPSUNK,AFLNOR,ZMU + CEXE=.TRUE. + ELSE + FLUX(:NUNKNO,:NGRP,1)=FLUX(:NUNKNO,:NGRP,2) + FLUX(:NUNKNO,:NGRP,2)=FLUX(:NUNKNO,:NGRP,3) + IF(IPRT.GT.0) WRITE(6,1110) IT,AFLNOR,ZMU + ENDIF + IF((ITYPEC.GE.2).AND.(AKEFF.NE.0.0)) THEN + AFLNOR=(AKEFF/AKEEP(3))*AFLNOR + ENDIF + AKEEP(1)=AKEEP(2) + AKEEP(2)=AKEEP(3) +*---- +* UPDATE KEFF +*---- + AKEFFO=AKEFF + IF((EEXT.LT.EPSOUT).AND.(EINN.LT.EPSUNK).AND.(IT.GE.2)) GO TO 410 + 400 CONTINUE + WRITE(6,*) '*** FLU2DR: CONVERGENCE NOT REACHED ***' + WRITE(6,*) '*** FLU2DR: CONVERGENCE NOT REACHED ***' + WRITE(6,*) '*** FLU2DR: CONVERGENCE NOT REACHED ***' + MESSOU='*NOT*' +* +**** CONVERGENCE REACHED ****************************************** + 410 RKEFF=REAL(AKEFF) + IF(IPRT.GE.3) THEN + WRITE(6,1010) (IR,IR=1,NREG) + ALLOCATE(FL(NREG)) + DO 425 IG=1,NGRP + WRITE(6,1070) IG + FL(:NREG)=0.0 + DO 420 IR=1,NREG + IND=KEYFLX(IR,1,1) + IF(IND.GT.0) FL(IR)=FLUX(IND,IG,3) + 420 CONTINUE + WRITE(6,1020) (FL(IR),IR=1,NREG) + 425 CONTINUE + DEALLOCATE(FL) + ENDIF + IF(IPRT.GE.4) THEN + ALLOCATE(FL(NREG)) + DO 445 IG=1,NGRP + WRITE(6,1070) IG + DO 440 IA=2,NFUNL + FL(:NREG)=0.0 + DO 430 IR=1,NREG + IND=KEYFLX(IR,1,IA) + IF(IND.GT.0) FL(IR)=FLUX(IND,IG,3) + 430 CONTINUE + WRITE(6,1030) IA,(FL(IR),IR=1,NREG) + 440 CONTINUE + 445 CONTINUE + DEALLOCATE(FL) + ENDIF +*---- +* COMPUTE K-INF +*---- + IF(ITYPEC.GE.2) THEN + FISOUR=0.0D0 + OLDBIL=0.0D0 + DO 490 IG=1,NGRP + DO 460 IR=1,NREG + IND=KEYFLX(IR,1,1) + IF(IND.EQ.0) GO TO 460 + DO 450 IS=1,NIFIS + FISOUR=FISOUR+XSNUF(MATCOD(IR),IS,IG)*FLUX(IND,IG,3)*VOL(IR) + 450 CONTINUE + OLDBIL=OLDBIL+XSTRC(MATCOD(IR),IG)*FLUX(IND,IG,3)*VOL(IR) + 460 CONTINUE + KPMACR=LCMGIL(JPMACR,IG) + CALL LCMGET(KPMACR,'NJJS00',NJJ(1)) + CALL LCMGET(KPMACR,'IJJS00',IJJ(1)) + CALL LCMGET(KPMACR,'IPOS00',IPOS(1)) + CALL LCMGET(KPMACR,'SCAT00',XSCAT(1)) + DO 480 IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.GT.0) THEN + IND=KEYFLX(IR,1,1) + JG=IJJ(IBM) + DO 470 JND=1,NJJ(IBM) + IF(JG.EQ.IG) THEN + OLDBIL=OLDBIL-XSDIA(IBM,0,IG)*FLUX(IND,JG,3)*VOL(IR) + ELSE + OLDBIL=OLDBIL-XSCAT(IPOS(IBM)+JND-1)*FLUX(IND,JG,3)*VOL(IR) + ENDIF + JG=JG-1 + 470 CONTINUE + ENDIF + 480 CONTINUE + 490 CONTINUE + CUREIN=0.0 + IF(FISOUR.NE.0.0) CUREIN=REAL(FISOUR/OLDBIL) +* +* FLUX NORMALIZATION TO KEFF. + IF(ITYPEC.LT.5) THEN + FLUX(:NUNKNO,:NGRP,3)=FLUX(:NUNKNO,:NGRP,3)*REAL(AKEFF/FISOUR) + FLUX(:NUNKNO,:NGRP,4)=FLUX(:NUNKNO,:NGRP,4)*REAL(AKEFF/FISOUR) + ENDIF + ENDIF +*---- +* PRINT TIME TAKEN +*---- + CALL KDRCPU(CPU1) + IF(IPRT.GE.1) WRITE(6,1040) CPU1-CPU0,'EXTERNAL',MESSOU,IEXTF +*---- +* FOURIER ANALYSIS: STORE E-VALUE AND FIND SPECTRAL RADIUS +*---- + IF(ITYPEC.EQ.-2) THEN + WRITE(6,1130) + ARRAYRHO1(IFACOUNT+1)=EVALRHO + IF(IFACOUNT.LT.(NFOU-1)) GO TO 26 + SPECR=MAXVAL(ARRAYRHO1) + WRITE(6,1140) SPECR + CALL LCMPUT(IPFLUX,'SPEC-RADIUS',1,2,SPECR) + ENDIF + DEALLOCATE(ARRAYRHO1) +*---- +* PRINT TRACKING INFORMATION +*---- + IF(IPRT.GE.1) THEN + IF((ITYPEC.EQ.0).OR.(ITYPEC.EQ.-2)) THEN + WRITE(6,1050) ICHAR,EEXT + ELSE + WRITE(6,1060) ICHAR,CUREIN,AKEFF,B2(4),EEXT + ENDIF + WRITE(6,1120) ICTOT + ENDIF +*---- +* RELEASE ARRAYS +*---- + IF(CXDOOR.EQ.'MCCG') THEN + IF(ICREB.GT.0) DEALLOCATE(MATALB,V,KEYCUR) + ENDIF +*---- +* SAVE THE SOLUTION +*---- + DO 510 IG=1,NGRP + IF(LFORW) THEN + CALL LCMPDL(JPFLUX,IG,NUNKNO,2,FLUX(1,IG,3)) + CALL LCMPDL(JPSOUR,IG,NUNKNO,2,FLUX(1,IG,4)) + ELSE + CALL LCMPDL(JPFLUX,NGRP-IG+1,NUNKNO,2,FLUX(1,IG,3)) + CALL LCMPDL(JPSOUR,NGRP-IG+1,NUNKNO,2,FLUX(1,IG,4)) + ENDIF + 510 CONTINUE + IF(C_ASSOCIATED(IPSOU)) THEN + CALL LCMLEN(IPSOU,'NORM-FS',ILEN,ITYLCM) + IF(ILEN.GT.0) THEN + CALL LCMGET(IPSOU,'NORM-FS',ZNORM) + CALL LCMPUT(IPFLUX,'NORM-FS',1,2,ZNORM) + CALL LCMPUT(IPFLUX,'MATCOD',NREG,1,MATCOD) + ENDIF + ENDIF + IF(IBFP.NE.0) THEN + CALL LCMGET(IPSYS,'ECUTOFF',ECUTOFF) + CALL LCMPUT(IPFLUX,'ECUTOFF',1,2,ECUTOFF) + CALL LCMPUT(IPFLUX,'FLUXC',NREG,2,FLUXC) + ENDIF + IF(ITYPEC.GE.2) THEN + CALL LCMPUT(IPFLUX,'K-EFFECTIVE',1,2,RKEFF) + CALL LCMPUT(IPFLUX,'K-INFINITY',1,2,CUREIN) + ENDIF + IF(ITYPEC.GE.3) THEN + CALL LCMPUT(IPFLUX,'B2 B1HOM',1,2,B2(4)) + ENDIF + IF((ITYPEC.GT.2).AND.(ILEAK.GE.7)) THEN + CALL LCMPUT(IPFLUX,'B2 HETE',3,2,B2) + ENDIF + IF((ITYPEC.GT.2).AND.(ILEAK.GE.6)) THEN + CALL LCMPUT(IPFLUX,'GAMMA',NGRP,2,GAMMA) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XCSOU,DIFHET,DHOM,GAMMA,XSCAT,FLUX) + DEALLOCATE(NPSYS,IPOS,NJJ,IJJ) + RETURN +* + 1010 FORMAT (/28H FLUXES AVERAGED :/ + 1 (9X,2H/=,I4,:,6X,2H/=,I4,:,6X,2H/=,I4,:,6X,2H/=,I4,:,6X,2H/=, + 2 I4,:,6X,2H/=,I4,:,6X,2H/=,I4,:,6X,2H/=,I4,:,6X,2H/=,I4,:,6X, + 3 2H/=,I4)) + 1020 FORMAT (7H FLUX ,2H: ,1P,10E12.5/(9X,10E12.5)) + 1030 FORMAT (5H CUR ,I2,2H: ,1P,10E12.5/(9X,10E12.5)) + 1040 FORMAT (18H FLU2DR: CPU TIME=, F10.0,1X,A8,13H CONVERGENCE , + 1 A8,14H REACHED AFTER ,I6,12H ITERATIONS. ) + 1050 FORMAT (/20H ++ TRACKING CALLED=,I4,6H TIMES , + 1 11H PRECISION=,E9.2) + 1060 FORMAT (/20H ++ TRACKING CALLED=,I4,6H TIMES , + 1 12H FINAL KINF=,1P,E13.6, + 2 12H FINAL KEFF=,E13.6,4H B2=,E12.5, + 3 11H PRECISION=,E9.2) + 1070 FORMAT (/14H ENERGY GROUP ,I6) + 1080 FORMAT (10X,3HIN(,I3,6H) FLX:,5H PRC=,1P,E9.2,5H TAR=,E9.2, + 1 7H IGDEB=, I13,6H ACCE=,0P,F12.5) + 1082 FORMAT (18X,28HFIRST UNCONVERGED GROUP PRC=,1P,E9.2) + 1090 FORMAT (5H OUT(,I3,6H) EIG:,5H PRC=,1P,E9.2,5H TAR=,E9.2, + 1 6H KEFF=,E13.6,6H BUCK=,E12.5) + 1100 FORMAT (5H OUT(,I3,6H) FLX:,5H PRC=,1P,E9.2,5H TAR=,E9.2, + 1 6H FNOR=,E13.6,6H ACCE=,0P,F12.5) + 1110 FORMAT (5H OUT(,I3,6H) FLX:,28X,6H FNOR=,1P,E13.6,6H ACCE=, + 1 0P,F12.5) + 1120 FORMAT (38H ++ TOTAL NUMBER OF FLUX CALCULATIONS=,I10) + 1130 FORMAT (24H CONVERGENCE NOT SOUGHT.) + 1140 FORMAT (49H FLU2DR: SPECTRAL RADIUS FOR FOURIER ANALYSIS IS , + 1 E13.6) + 1150 FORMAT(/18H FLU2DR: BUCKLING=,1P,E13.5,15H K-EFFECTIVE =,E13.5) + END diff --git a/Dragon/src/FLUALB.f b/Dragon/src/FLUALB.f new file mode 100644 index 0000000..230605b --- /dev/null +++ b/Dragon/src/FLUALB.f @@ -0,0 +1,102 @@ +*DECK FLUALB + SUBROUTINE FLUALB(IPSYS,NREGIO,NUNKNO,IR,MATCOD,VOLUME,KEYFLX, + > FUNKNO,SUNKNO,SIGS0,SIGT0,F1,F2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Computes information related to an albedo search. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPSYS pointer to the pij object (L_PIJ signature). +* NREGIO total number of volumes in the domain. +* NUNKNO number of unknown in the system. +* IR number of mixtures. +* MATCOD mixture index in each volume. +* VOLUME volumes. +* KEYFLX index pointing to the average fluxes in vector FUNKNO. +* FUNKNO unknowns. +* SUNKNO sources. +* SIGS0 within-group scattering macroscopic cross sections of each +* mixture. +* SIGT0 total macroscopic cross sections of each mixture. +* +*Parameters: output +* F1 first part of the neutron flux. +* F2 second part of the neutron flux. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSYS + INTEGER NREGIO,NUNKNO,IR,MATCOD(NREGIO),KEYFLX(NREGIO) + REAL VOLUME(NREGIO),FUNKNO(NUNKNO),SUNKNO(NUNKNO), + > SIGS0(0:IR),SIGT0(0:IR),F1(NREGIO),F2(NREGIO) +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: WORK +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(WORK(NREGIO**2)) +*---- +* READ PIS MATRIX +*---- + CALL LCMLEN(IPSYS,'DRAGON-WIS',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.NREGIO) THEN + CALL LCMGET(IPSYS,'DRAGON-WIS',F2) + ELSE + CALL LCMLIB(IPSYS) + CALL XABORT('FLUALB: THE ALBS OPTION OF THE ASM: MODULE HAVE N' + > //'OT BEEN ACTIVATED.') + ENDIF +* + ZNUM=0.0 + ZDEN=0.0 + DO 10 I=1,NREGIO + ZNUM=ZNUM+VOLUME(I)*FUNKNO(KEYFLX(I)) + ZDEN=ZDEN+VOLUME(I)*(SIGT0(MATCOD(I))-SIGS0(MATCOD(I)))*F2(I) + 10 CONTINUE + ZNUM=-ZNUM/ZDEN +*---- +* READ SCATTERING MODIFIED CP MATRIX. +*---- + CALL LCMLEN(IPSYS,'DRAGON-PCSCT',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.NREGIO**2) THEN + CALL LCMGET(IPSYS,'DRAGON-PCSCT',WORK) + ELSE + CALL LCMLIB(IPSYS) + CALL XABORT('FLUALB: THE SCATTERING MODIFIED PIJ ARE ABSENT FR' + > //'OM LCM.') + ENDIF +* + DO 20 I=1,NREGIO + F2(I)=F2(I)*ZNUM + F1(I)=0.0 + 20 CONTINUE + DO 40 J=1,NREGIO + SSS=SUNKNO(KEYFLX(J)) + IOF=(J-1)*NREGIO + DO 30 I=1,NREGIO + F1(I)=F1(I)+WORK(IOF+I)*SSS + 30 CONTINUE + 40 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(WORK) + RETURN + END diff --git a/Dragon/src/FLUBAL.f b/Dragon/src/FLUBAL.f new file mode 100644 index 0000000..ad922e5 --- /dev/null +++ b/Dragon/src/FLUBAL.f @@ -0,0 +1,209 @@ +*DECK FLUBAL + SUBROUTINE FLUBAL(IPMACR,NGRP,ILEAK,NMAT,NREG,ICREB,NUNKNO, + 1 NANIS,MATCOD,VOL,KEYFLX,XSTRC,XSDIA,XCSOU,IGDEB,B2,NMERG, + 2 IMERG,DIFHET,KEYCUR,MATALB,ALBEDO,SURFAC,FUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Flux rebalancing for non converged groups with up-scattering. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPMACR pointer to the macrolib LCM object. +* NGRP number of energy groups. +* ILEAK method used to include DB2 effect: +* <5 uniform DB2 model; +* =5 Todorova-type isotropic streaming model; +* =6 Ecco-type isotropic streaming model; +* >6 Tibere anisotropic streaming model. +* NMAT number of mixtures. +* NREG number of regions. +* ICREB number of outer surfaces where outgoing leakage occurs. If +* ICREB=0, perfect particle balance is assumed. +* NUNKNO number of unknowns per energy group including spherical +* harmonic terms, interface currents and fundamental currents. +* NANIS maximum cross section Legendre order. +* MATCOD mixture indices. +* VOL volumes. +* KEYFLX index of flux components in unknown vector. +* XSTRC transport-corrected macroscopic total cross sections. +* XSDIA transport-corrected macroscopic within-group scattering cross +* sections. +* XCSOU source for system of unknown. +* IGDEB first non-converged group. +* B2 directional buckling. +* NMERG number of leakage zones. +* IMERG leakage zone index in each material mixture zone. +* DIFHET heterogeneous leakage coefficients. +* KEYCUR index for currents position in FUNKNO. Used if ICREB.GT.0. +* MATALB albedo indices. Used if ICREB.GT.0. +* ALBEDO albedo array. Used if ICREB.GT.0. +* SURFAC numerical surfaces. Used if ICREB.GT.0. +* +*Parameters: input/output +* FUNKNO neutron flux. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMACR + INTEGER NGRP,ILEAK,NMAT,NREG,ICREB,NUNKNO,NANIS,MATCOD(NREG), + > KEYFLX(NREG),IGDEB,NMERG,IMERG(NMAT),KEYCUR(ICREB), + > MATALB(ICREB) + REAL VOL(NREG),FUNKNO(NUNKNO,NGRP),XSTRC(0:NMAT,NGRP), + > XSDIA(0:NMAT,0:NANIS,NGRP),B2(4),DIFHET(NMERG,NGRP), + > ALBEDO(6),SURFAC(ICREB) + DOUBLE PRECISION XCSOU(NGRP) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPMACR,KPMACR + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) :: XSCAT + REAL, ALLOCATABLE, DIMENSION(:,:) :: REBAL +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IJJ(0:NMAT),NJJ(0:NMAT),IPOS(0:NMAT)) + ALLOCATE(REBAL(NGRP,NGRP+1),XSCAT(0:NMAT*NGRP)) +*---- +* INITIALIZE REBALANCE MATRIX +*---- + NGREB=NGRP-IGDEB+1 + REBAL(:NGREB,:NGREB+1)=0.0 +*---- +* CREATE REBALANCE MATRIX +*---- + JPMACR=LCMGID(IPMACR,'GROUP') + DO 100 IGR=IGDEB,NGRP + IOFF=IGR-IGDEB+1 + KPMACR=LCMGIL(JPMACR,IGR) +*---- +* READ SCATT X-SECTIONS. +*---- + CALL LCMLEN(KPMACR,'NJJS00',ILCMLN,ITYLCM) + IF(ILCMLN.NE.NMAT) THEN + CALL LCMLIB(KPMACR) + CALL XABORT('FLUBAL: READ ERROR ON LCM RECORD = NJJS00') + ELSE + CALL LCMGET(KPMACR,'NJJS00',NJJ(1)) + CALL LCMGET(KPMACR,'IJJS00',IJJ(1)) + CALL LCMGET(KPMACR,'IPOS00',IPOS(1)) + CALL LCMGET(KPMACR,'SCAT00',XSCAT(1)) + ENDIF +*---- +* FIXE + FISSION NEUTRON SOURCES +*---- + REBAL(IOFF,NGREB+1)=REAL(XCSOU(IGR)) +*---- +* SUM OVER SURFACES +*---- + DO 35 ISUR=1,ICREB + IND=KEYCUR(ISUR) + REBAL(IOFF,IOFF)=REBAL(IOFF,IOFF)+ + > (1.0-ALBEDO(-MATALB(ISUR)))*FUNKNO(IND,IGR)*SURFAC(ISUR) + 35 CONTINUE +*---- +* SUM OVER REGIONS +*---- + DO 60 IREG=1,NREG + IBM=MATCOD(IREG) + IF(IBM.EQ.0) GO TO 60 + IND=KEYFLX(IREG) +*---- +* INCLUDE SCATTERING SOURCES FROM CONVERGED FLUX IN REBALANCE SOURCE +*---- + NGSCAT=NJJ(IBM) + IFSCAT=IJJ(IBM)-NGSCAT+1 + ISCATP=IPOS(IBM)-1+NGSCAT + DO 40 JGR=IFSCAT,IGDEB-1 + REBAL(IOFF,NGREB+1)=REBAL(IOFF,NGREB+1)+ + > FUNKNO(IND,JGR)*XSCAT(ISCATP)*VOL(IREG) + ISCATP=ISCATP-1 + 40 CONTINUE +*---- +* INCLUDE SCATTERING SOURCES FROM NON CONVERGED FLUX IN REBALANCE +* MATRIX +*---- + IF(IFSCAT.LT.IGDEB) THEN + NGSCAT=NGSCAT+IFSCAT-IGDEB + IFSCAT=IGDEB + ENDIF + ISCATP=IPOS(IBM)-1+NGSCAT + DO 50 JGR=IFSCAT,IJJ(IBM) + IF(JGR.EQ.IGR) THEN + REBAL(IOFF,IOFF)=REBAL(IOFF,IOFF)+FUNKNO(IND,IGR) + > *(XSTRC(IBM,IGR)-XSDIA(IBM,0,IGR))*VOL(IREG) + ELSE + REBAL(IOFF,JGR-IGDEB+1)=REBAL(IOFF,JGR-IGDEB+1) + > -FUNKNO(IND,JGR)*XSCAT(ISCATP)*VOL(IREG) + ENDIF + ISCATP=ISCATP-1 + 50 CONTINUE + 60 CONTINUE +*---- +* FOR ALL REGIONS ADD CONTRIBUTION DUE TO DB2 TERM +*---- + IF(ILEAK.LT.6.AND.ILEAK.GT.0) THEN + DO 70 IREG=1,NREG + IND=KEYFLX(IREG) + IF(IND.EQ.0) GO TO 70 + IBM=MATCOD(IREG) + IF(IBM.EQ.0) GO TO 70 + INM=IMERG(IBM) + IF(INM.EQ.0) GO TO 70 + REBAL(IOFF,IOFF)=REBAL(IOFF,IOFF) + > +FUNKNO(IND,IGR)*DIFHET(INM,IGR)*B2(4)*VOL(IREG) + 70 CONTINUE + ELSE IF(ILEAK.EQ.6) THEN + DO 80 IREG=1,NREG + IND=KEYFLX(IREG) + REBAL(IOFF,IOFF)=REBAL(IOFF,IOFF) + > +FUNKNO(NUNKNO/2+IND,IGR)*B2(4)*VOL(IREG) + 80 CONTINUE + ELSE IF(ILEAK.GE.7) THEN + DO 90 IREG=1,NREG + IND=KEYFLX(IREG) + REBAL(IOFF,IOFF)=REBAL(IOFF,IOFF) + > +(FUNKNO(NUNKNO/4+IND,IGR)*B2(1) + > +FUNKNO(NUNKNO/2+IND,IGR)*B2(2) + > +FUNKNO(3*NUNKNO/4+IND,IGR)*B2(3))*VOL(IREG) + 90 CONTINUE + ENDIF +100 CONTINUE +*---- +* SOLVE REBALANCE EQUATIONS +*---- + CALL ALSB(NGREB,1,REBAL,IER,NGRP) + IF(IER.NE.0) THEN + WRITE(6,'(/36H FLUBAL SINGULAR REBALANCING MATRIX.)') + GO TO 130 + ENDIF +*---- +* REBALANCE FLUXES +*---- + DO 120 IGR=IGDEB,NGRP + IOFF=IGR-IGDEB+1 + DO 110 IND=1,NUNKNO + FUNKNO(IND,IGR)=FUNKNO(IND,IGR)*REBAL(IOFF,NGREB+1) +110 CONTINUE +120 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- +130 DEALLOCATE(XSCAT,REBAL) + DEALLOCATE(IPOS,NJJ,IJJ) + RETURN + END diff --git a/Dragon/src/FLUBLN.f b/Dragon/src/FLUBLN.f new file mode 100644 index 0000000..f8eecb7 --- /dev/null +++ b/Dragon/src/FLUBLN.f @@ -0,0 +1,143 @@ +*DECK FLUBLN + SUBROUTINE FLUBLN(IPMACR,IPRINT,NGROUP,NBMIX,NREGIO,NUNKNO, + > NIFISS,MATCOD,VOLUME,KEYFLX,FUNKNO,IHETL, + > REFKEF,B2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of a directional buckling from the critical neutron +* balance. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): I. Petrovic and G. Marleau +* +*Parameters: input +* IPMACR pointer to the macrolib LCM object. +* IPRINT print selection for flux modules. +* NGROUP number of groups. +* NBMIX number of mixtures. +* NREGIO number of regions. +* NUNKNO number of unknowns in the system. +* NIFISS number of fissile isotopes. +* MATCOD material code in regions. +* IHETL type of buckling calculation: +* = 1 x-direction search; +* = 2 y-direction search; +* = 3 z-direction search; +* = 4 r-direction search (X=Y); +* = 5 global-direction search (X=Y=Z). +* VOLUME volume of regions. +* KEYFLX flux elements in unknown system. +* FUNKNO flux and directional currents. +* REFKEF target K-effective for type B or L. +* +*Parameters: output +* B2 directional buckling (X, Y, Z, hom). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMACR + INTEGER IPRINT,NGROUP,NBMIX,NREGIO,NUNKNO,NIFISS,MATCOD(NREGIO), + > KEYFLX(NREGIO),IHETL + REAL VOLUME(NREGIO),FUNKNO(NUNKNO,NGROUP),B2(4) + DOUBLE PRECISION REFKEF +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6) + TYPE(C_PTR) JPMACR,KPMACR + DOUBLE PRECISION BIL1,SUM(0:3) + REAL, ALLOCATABLE, DIMENSION(:) :: SIGT0,SIGS0 + REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGFIS,QTOTL +*---- +* COMPUTE THE TOTAL NEUTRON PRODUCTION +*---- + ALLOCATE(SIGFIS(NBMIX,NIFISS),QTOTL(NREGIO,NIFISS)) + NUN4=NUNKNO/4 + QTOTL(:NREGIO,:NIFISS)=0.0 + JPMACR=LCMGID(IPMACR,'GROUP') + DO 30 IGR=1,NGROUP + KPMACR=LCMGIL(JPMACR,IGR) + CALL LCMGET(KPMACR,'NUSIGF',SIGFIS) + DO 20 IFIS=1,NIFISS + DO 10 IREG=1,NREGIO + IBM=MATCOD(IREG) + IF(IBM.GT.0) QTOTL(IREG,IFIS)=QTOTL(IREG,IFIS) + > +FUNKNO(KEYFLX(IREG),IGR)*SIGFIS(IBM,IFIS) + 10 CONTINUE + 20 CONTINUE + 30 CONTINUE + BIL1=0.0D0 + DO 60 IGR=1,NGROUP + KPMACR=LCMGIL(JPMACR,IGR) + CALL LCMGET(KPMACR,'CHI',SIGFIS) + DO 50 IFIS=1,NIFISS + DO 40 IREG=1,NREGIO + IBM=MATCOD(IREG) + IF(IBM.GT.0) BIL1=BIL1+DBLE(VOLUME(IREG)*QTOTL(IREG,IFIS)* + > SIGFIS(IBM,IFIS)) + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + DEALLOCATE(QTOTL,SIGFIS) +*---- +* COMPUTE FISSION SOURCE AND EVALUATE NEUTRON BALANCE +*---- + ALLOCATE(SIGT0(0:NBMIX),SIGS0(0:NBMIX)) + SUM(0)=BIL1/REFKEF + SUM(1)=0.0D0 + SUM(2)=0.0D0 + SUM(3)=0.0D0 + SIGT0(0)=0.0 + SIGS0(0)=0.0 + DO 80 IGR=1,NGROUP + KPMACR=LCMGIL(JPMACR,IGR) + CALL LCMGET(KPMACR,'NTOT0',SIGT0(1)) + CALL LCMGET(KPMACR,'SIGS00',SIGS0(1)) + DO 70 IREG=1,NREGIO + IBM=MATCOD(IREG) + IND=KEYFLX(IREG) + SUM(0)=SUM(0)+(SIGS0(IBM)-SIGT0(IBM))* + > VOLUME(IREG)*FUNKNO(IND,IGR) + SUM(1)=SUM(1)+VOLUME(IREG)*FUNKNO(NUN4+IND,IGR) + SUM(2)=SUM(2)+VOLUME(IREG)*FUNKNO(2*NUN4+IND,IGR) + SUM(3)=SUM(3)+VOLUME(IREG)*FUNKNO(3*NUN4+IND,IGR) + 70 CONTINUE + 80 CONTINUE + IF(IHETL.EQ.1)THEN + B2(1)=REAL((SUM(0)-B2(2)*SUM(2)-B2(3)*SUM(3))/SUM(1)) + ELSEIF(IHETL.EQ.2)THEN + B2(2)=REAL((SUM(0)-B2(1)*SUM(1)-B2(3)*SUM(3))/SUM(2)) + ELSEIF(IHETL.EQ.3)THEN + B2(3)=REAL((SUM(0)-B2(1)*SUM(1)-B2(2)*SUM(2))/SUM(3)) + ELSEIF(IHETL.EQ.4)THEN + B2(1)=REAL((SUM(0)-B2(3)*SUM(3))/(SUM(1)+SUM(2))) + B2(2)=B2(1) + ELSEIF(IHETL.EQ.5)THEN + B2(1)=REAL(SUM(0)/(SUM(1)+SUM(2)+SUM(3))) + B2(2)=B2(1) + B2(3)=B2(1) + ELSE + CALL XABORT('FLUBLN: WHICH DIRECTIONAL BUCKLING '// + > 'WOULD YOU LIKE TO CALCULATE ? ') + ENDIF + B2(4)=B2(1)+B2(2)+B2(3) + IF(IPRINT.GE.10) WRITE(IUNOUT,6000) (B2(IDIR),IDIR=1,3) + DEALLOCATE(SIGS0,SIGT0) + RETURN +*---- +* FORMATS +*---- + 6000 FORMAT(1X,'FLUBLN OUTPUT'/1X,'HETEROGENEOUS B2 = ',1P,3E15.7) + END diff --git a/Dragon/src/FLUDBV.f b/Dragon/src/FLUDBV.f new file mode 100644 index 0000000..5f2080a --- /dev/null +++ b/Dragon/src/FLUDBV.f @@ -0,0 +1,509 @@ +*DECK FLUDBV + SUBROUTINE FLUDBV(CDOOR,IPHASE,JPSYS,JPSTR,NPSYS,IPTRK,IFTRAK, + 1 IPRT,NREG,NUNKNO,NFUNL,NGRP,NMAT,NANIS,LEXAC,MATCOD,VOL,KEYFLX, + 2 TITLE,ILEAK,LEAKSW,XSTRC,XSDIA,B2,NMERG,IMERG,DIFHET,GAMMA, + 3 FLUOLD,SUNKNO,FUNKNO,IPMACR,IPSOU,REBFLG,FLUXC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find a leakage parameter to match the input DB2 value and find the +* corresponding flux. Vectorial version. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy and A. Hebert +* +*Parameters: input +* CDOOR name of the geometry/solution operator. +* IPHASE type of flux solution door (1 for asm 2 for pij). +* JPSYS pointer to the system LCM list object. +* JPSTR pointer to the system LCM list object containing isotropic +* streaming information (=0 if not required). +* NPSYS non-converged energy group indices. +* IPTRK pointer to the tracking LCM object. +* IFTRAK tracking file unit number. +* IPRT print flag. +* NREG number of regions. +* NFUNL second dimension of matrix KEYFLX. +* NGRP number of energy groups. +* NUNKNO number of flux/sources unknowns per energy group. +* NMAT number of mixtures in the internal library. +* NANIS maximum cross section Legendre order. +* LEXAC type of exponential function calculation (=.false. to compute +* exponential functions using tables). +* MATCOD mixture indices. +* VOL volumes. +* KEYFLX index of L-th order flux components in unknown vector. +* TITLE title. +* ILEAK method used to include db2 effect: +* =1 the scattering modified cp matrix is multiplied by PNLR; +* =2 the reduced cp matrix is multiplied by PNL; +* =3 sigs0-db2 approximation; +* =4 albedo approximation; +* =5 Todorova-type isotropic streaming model; +* =6 Ecco-type isotropic streaming model; +* >6 Tibere type anisotropic streaming model. +* LEAKSW leakage flag (=.true. if leakage is present on the outer +* surface). +* XSTRC transport-corrected macroscopic total cross sections. +* XSDIA transport-corrected macroscopic within-group scattering cross +* sections. +* B2 buckling. +* NMERG number of leakage zones. +* IMERG leakage zone index in each material mixture zone. +* DIFHET heterogeneous leakage coefficients. +* GAMMA gamma factors. +* IPMACR pointer to the macrolib LCM object. +* IPSOU pointer to the fixed source LCM object. +* REBFLG ACA or SCR rebalancing flag. +* FLUOLD flux of the previous outer iteration. +* SUNKNO input sources. +* +*Parameters: input/output +* FUNKNO neutron flux. +* SUNKNO sources with additional db2 contributions. +* FLUXC flux at the cutoff energy. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER CDOOR*12,TITLE*72 + LOGICAL LEXAC,REBFLG + TYPE(C_PTR) JPSYS,JPSTR,IPTRK,IPMACR,IPSOU + INTEGER IPHASE,NPSYS(NGRP),IFTRAK,IPRT,NREG,NUNKNO,NFUNL, + 1 NGRP,NMAT,NANIS,MATCOD(NREG),KEYFLX(NREG,NFUNL),ILEAK,NMERG, + 2 IMERG(NMAT) + REAL VOL(NREG),XSTRC(0:NMAT,NGRP),XSDIA(0:NMAT,0:NANIS,NGRP), + 1 B2(4),DIFHET(NMERG,NGRP),GAMMA(NGRP),FLUXC(NREG) + REAL, INTENT(IN) :: FLUOLD(NUNKNO,NGRP) + REAL, INTENT(INOUT) :: SUNKNO(NUNKNO,NGRP),FUNKNO(NUNKNO,NGRP) + LOGICAL LEAKSW +*---- +* LOCAL VARIABLES +*---- + PARAMETER(IOUT=6) + TYPE(C_PTR) KPSYS,KPSTR + CHARACTER TEXT12*12 + INTEGER INDD(3),INDC(3),INDB(3) +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: SIGT0,SOURCE2,FUNKNO2,F1,F2,PP + REAL, ALLOCATABLE, DIMENSION(:,:) :: SOURCE +* + ALLOCATE(SOURCE(NUNKNO,NGRP)) + SOURCE(:NUNKNO,:NGRP)=SUNKNO(:NUNKNO,:NGRP) +* + IF(ILEAK.EQ.1) THEN + IF(NMERG.GT.1) CALL XABORT('FLUDBV: NB. LEAKAGE ZONES > 1.(1)') + IF(LEAKSW) CALL XABORT('FLUDBV: PNLR OPTION FORBIDDEN.') + DO 30 IGR=1,NGRP + IF((NPSYS(IGR).NE.0).AND.(B2(4).NE.0.0)) THEN + ZNUM=0.0 + ZDEN=0.0 + DO 10 IR=1,NREG + IBM=MATCOD(IR) + IND=KEYFLX(IR,1) + SSS=XSTRC(IBM,IGR)-XSDIA(IBM,0,IGR) + ZNUM=ZNUM+SSS*FLUOLD(IND,IGR)*VOL(IR) + ZDEN=ZDEN+FLUOLD(IND,IGR)*VOL(IR) + 10 CONTINUE + ALP1=ZNUM/(ZNUM+DIFHET(1,IGR)*B2(4)*ZDEN) + DO 20 IR=1,NREG + IND=KEYFLX(IR,1) + SOURCE(IND,IGR)=ALP1*SOURCE(IND,IGR) + 20 CONTINUE + ENDIF + 30 CONTINUE + IDIR=0 + CALL DOORFV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IPRT,NGRP,NMAT, + 1 IDIR,NREG,NUNKNO,IPHASE,LEXAC,MATCOD,VOL,KEYFLX,TITLE, + 2 SOURCE(1,1),FUNKNO(1,1),IPMACR,IPSOU,REBFLG,FLUXC) + ELSE IF(ILEAK.EQ.2) THEN + IF(NMERG.GT.1) CALL XABORT('FLUDBV: NB. LEAKAGE ZONES > 1.(2)') + IF(LEAKSW) CALL XABORT('FLUDBV: PNL OPTION FORBIDDEN.') + DO 50 IGR=1,NGRP + IF((NPSYS(IGR).NE.0).AND.(B2(4).NE.0.0)) THEN + ZNUM=0.0 + ZDEN=0.0 + DO 40 IR=1,NREG + IBM=MATCOD(IR) + IND=KEYFLX(IR,1) + ZNUM=ZNUM+XSTRC(IBM,IGR)*FLUOLD(IND,IGR)*VOL(IR) + ZDEN=ZDEN+FLUOLD(IND,IGR)*VOL(IR) + 40 CONTINUE + ALP1=ZNUM/(ZNUM+DIFHET(1,IGR)*B2(4)*ZDEN) + DO 45 IR=1,NREG + IND=KEYFLX(IR,1) + SOURCE(IND,IGR)=ALP1*SOURCE(IND,IGR)-(1.0-ALP1) + > *XSDIA(MATCOD(IR),0,IGR)*FLUOLD(IND,IGR) + 45 CONTINUE + ENDIF + 50 CONTINUE + IDIR=0 + CALL DOORFV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IPRT,NGRP,NMAT, + 1 IDIR,NREG,NUNKNO,IPHASE,LEXAC,MATCOD,VOL,KEYFLX,TITLE, + 2 SOURCE(1,1),FUNKNO(1,1),IPMACR,IPSOU,REBFLG,FLUXC) + ELSE IF((ILEAK.EQ.3).OR.(ILEAK.EQ.5)) THEN + DO 70 IGR=1,NGRP + IF(NPSYS(IGR).NE.0) THEN + BB=B2(4) + DO 60 IR=1,NREG + IND=KEYFLX(IR,1) + IF(IND.EQ.0) GO TO 60 + IBM=MATCOD(IR) + IF(IBM.EQ.0) GO TO 60 + INM=IMERG(IBM) + IF(INM.EQ.0) GO TO 60 + SOURCE(IND,IGR)=SOURCE(IND,IGR)-DIFHET(INM,IGR)*BB* + 1 FLUOLD(IND,IGR) + 60 CONTINUE + ENDIF + 70 CONTINUE + IDIR=0 + CALL DOORFV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IPRT,NGRP,NMAT, + 1 IDIR,NREG,NUNKNO,IPHASE,LEXAC,MATCOD,VOL,KEYFLX,TITLE, + 2 SOURCE(1,1),FUNKNO(1,1),IPMACR,IPSOU,REBFLG,FLUXC) + ELSE IF(ILEAK.EQ.4) THEN + ALLOCATE(F1(NREG),F2(NREG)) + DO 80 IGR=1,NGRP + IF(NPSYS(IGR).NE.0) THEN + KPSYS=LCMGIL(JPSYS,IGR) + CALL FLUALB(KPSYS,NREG,NUNKNO,ILCTXS,MATCOD,VOL,KEYFLX, + > FLUOLD(1,IGR),SOURCE(1,IGR),XSDIA(0,0,IGR),XSTRC(0,IGR), + > F1,F2) +* + IF(IPRT.GT.2) THEN + WRITE(IOUT,'(//33H N E U T R O N S O U R C E S :)') + WRITE(IOUT,'(1P,6(5X,E15.7))') (SOURCE(KEYFLX(I,1),IGR), + > I=1,NREG) + ENDIF + FUNKNO(:NUNKNO,IGR)=0.0 + DO 75 IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.EQ.0) GO TO 75 + INM=IMERG(IBM) + IF(INM.EQ.0) GO TO 75 + FUNKNO(KEYFLX(IR,1),IGR)=F1(IR)+DIFHET(INM,IGR)*B2(4)*F2(IR) + 75 CONTINUE + IF(IPRT.GT.2) THEN + WRITE(IOUT,'(//33H N E U T R O N F L U X E S :)') + WRITE(IOUT,'(1P,6(5X,E15.7))') (FUNKNO(KEYFLX(I,1),IGR), + > I=1,NREG) + ENDIF + ENDIF + 80 CONTINUE + DEALLOCATE(F2,F1) + ELSE IF(ILEAK.EQ.6) THEN +* ISOTROPIC STREAMING MODEL (ECCO). + IF(.NOT.C_ASSOCIATED(JPSTR)) THEN + CALL XABORT('FLUDBV: MISSING STREAMING INFO(1).') + ELSE IF(LEAKSW) THEN + CALL XABORT('FLUDBV: ECCO OPTION FORBIDDEN.') + ENDIF + DO 95 IGR=1,NGRP + IF(NPSYS(IGR).NE.0) THEN + BB=B2(4) + DO 90 IR=1,NREG + IND=KEYFLX(IR,1) + SOURCE(IND,IGR)=SOURCE(IND,IGR)-BB*FLUOLD(NUNKNO/2+IND,IGR) + 90 CONTINUE + ENDIF + 95 CONTINUE + IF(IPRT.GE.3) WRITE(IOUT,'(28H FLUDBV: FUNDAMENTAL FLUXES.)') + IDIR=0 + CALL DOORFV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IPRT,NGRP,NMAT, + 1 IDIR,NREG,NUNKNO,IPHASE,LEXAC,MATCOD,VOL,KEYFLX,TITLE, + 2 SOURCE(1,1),FUNKNO(1,1),IPMACR,IPSOU,REBFLG,FLUXC) + DO 130 IGR=1,NGRP + IF(NPSYS(IGR).NE.0) THEN + KPSTR=LCMGIL(JPSTR,IGR) + CALL LCMLEN(KPSTR,'DRAGON-TXSC',ILCTXS,ITYLCM) + ALLOCATE(SIGT0(0:ILCTXS-1)) + CALL LCMGET(KPSTR,'DRAGON-TXSC',SIGT0(0)) + ZNUM=0.0 + ZDEN=0.0 + DO 100 IR=1,NREG + IBM=MATCOD(IR) + IND=KEYFLX(IR,1) + ZNUM=ZNUM+SIGT0(IBM)*FUNKNO(IND,IGR)*VOL(IR) + ZDEN=ZDEN+FUNKNO(IND,IGR)*VOL(IR) + 100 CONTINUE + DO 110 IR=1,NREG + IBM=MATCOD(IR) + IND=KEYFLX(IR,1) + SOURCE(NUNKNO/2+IND,IGR)=SOURCE(NUNKNO/2+IND,IGR)+ + 1 (1.0-GAMMA(IGR))*(ZNUM/ZDEN-SIGT0(IBM))* + 2 FUNKNO(NUNKNO/2+IND,IGR) + 110 CONTINUE + DEALLOCATE(SIGT0) + DO 120 IR=1,NREG + IND=KEYFLX(IR,1) + SOURCE(NUNKNO/2+IND,IGR)=(SOURCE(NUNKNO/2+IND,IGR) + 1 +FUNKNO(IND,IGR)/3.0)/GAMMA(IGR) + 120 CONTINUE + ENDIF + 130 CONTINUE + IF(IPRT.GE.3) WRITE(IOUT,'(30H FLUDBV: FUNDAMENTAL CURRENTS.)') + ALLOCATE(SOURCE2((NUNKNO/2)*NGRP),FUNKNO2((NUNKNO/2)*NGRP)) + IOF=0 + DO 145 IGR=1,NGRP + DO 140 IND=1,NUNKNO/2 + IOF=IOF+1 + SOURCE2(IOF)=SOURCE(NUNKNO/2+IND,IGR) + FUNKNO2(IOF)=FUNKNO(NUNKNO/2+IND,IGR) + 140 CONTINUE + 145 CONTINUE + IDIR=0 + CALL DOORFV(CDOOR,JPSTR,NPSYS,IPTRK,IFTRAK,IPRT,NGRP,NMAT, + 1 IDIR,NREG,NUNKNO/2,IPHASE,LEXAC,MATCOD,VOL,KEYFLX,TITLE, + 2 SOURCE2(1),FUNKNO2(1),IPMACR,IPSOU,REBFLG,FLUXC) + IOF=0 + DO 155 IGR=1,NGRP + DO 150 IND=1,NUNKNO/2 + IOF=IOF+1 + SOURCE(NUNKNO/2+IND,IGR)=SOURCE2(IOF) + FUNKNO(NUNKNO/2+IND,IGR)=FUNKNO2(IOF) + 150 CONTINUE + 155 CONTINUE + DEALLOCATE(FUNKNO2,SOURCE2) + ELSE IF((MOD(ILEAK,10).EQ.7).AND.(IPHASE.EQ.1)) THEN +* ---- +* TIBERE ANISOTROPIC STREAMING MODEL FOR MOC. +* ---- + IF(.NOT.C_ASSOCIATED(JPSTR)) THEN + CALL XABORT('FLUDBV: MISSING STREAMING INFO(2).') + ELSE IF(LEAKSW) THEN + CALL XABORT('FLUDBV: TIBERE OPTION FORBIDDEN.') + ENDIF +* ADD SOURCES FOR FLUX EQUATION + DO IGR=1,NGRP + IF(NPSYS(IGR).NE.0) THEN + IF((B2(1).NE.0.0).AND.(B2(2).NE.0.0).AND. + 1 (B2(3).NE.0.0)) THEN + S=0.0 + DO IR=1,NREG + IND=KEYFLX(IR,1) + INDC(1)=3*NUNKNO/8+IND + INDC(2)=5*NUNKNO/8+IND + INDC(3)=7*NUNKNO/8+IND + SOURCE(IND,IGR)=SOURCE(IND,IGR)-(B2(1) + 1 *FLUOLD(INDC(1),IGR)+B2(2)*FLUOLD(INDC(2),IGR)+ + 2 B2(3)*FLUOLD(INDC(3),IGR)) + ENDDO + ENDIF + ENDIF + ENDDO + IF(IPRT.GE.3) WRITE(IOUT,'(28H FLUDBV: FUNDAMENTAL FLUXES.)') + IDIR=0 + NUNKNO4=NUNKNO/4 + ALLOCATE(SOURCE2(NUNKNO4*NGRP),FUNKNO2(NUNKNO4*NGRP)) + IOF=0 + DO IGR=1,NGRP + DO IND=1,NUNKNO4 + IOF=IOF+1 + SOURCE2(IOF)=SOURCE(IND,IGR) + FUNKNO2(IOF)=FUNKNO(IND,IGR) + ENDDO + ENDDO + CALL DOORFV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IPRT,NGRP,NMAT, + 1 IDIR,NREG,NUNKNO4,IPHASE,LEXAC,MATCOD,VOL,KEYFLX,TITLE, + 2 SOURCE2(1),FUNKNO2(1),IPMACR,IPSOU,REBFLG,FLUXC) + IOF=0 + DO IGR=1,NGRP + DO IND=1,NUNKNO4 + IOF=IOF+1 + SOURCE(IND,IGR)=SOURCE2(IOF) + FUNKNO(IND,IGR)=FUNKNO2(IOF) + ENDDO + ENDDO + DEALLOCATE(FUNKNO2,SOURCE2) +* ADD SOURCES FOR CURRENT EQUATIONS + DO IGR=1,NGRP + IF(NPSYS(IGR).NE.0) THEN + KPSTR=LCMGIL(JPSTR,IGR) + CALL LCMLEN(KPSTR,'DRAGON-TXSC',ILCTXS,ITYLCM) + ALLOCATE(SIGT0(0:ILCTXS-1)) + CALL LCMGET(KPSTR,'DRAGON-TXSC',SIGT0(0)) + ZNUM=0.0 + ZDEN=0.0 + DO IR=1,NREG + IBM=MATCOD(IR) + IND=KEYFLX(IR,1) + ZNUM=ZNUM+SIGT0(IBM)*FUNKNO(IND,IGR)*VOL(IR) + ZDEN=ZDEN+FUNKNO(IND,IGR)*VOL(IR) + ENDDO + DO IR=1,NREG + IBM=MATCOD(IR) + INDD(1)=NUNKNO/4+KEYFLX(IR,1) + INDD(2)=NUNKNO/2+KEYFLX(IR,1) + INDD(3)=3*NUNKNO/4+KEYFLX(IR,1) + DO IDIR=1,3 + SOURCE(INDD(IDIR),IGR)=SOURCE(INDD(IDIR),IGR)+ + 1 (1.0-GAMMA(IGR))*(ZNUM/ZDEN-SIGT0(IBM))* + 2 FUNKNO(INDD(IDIR),IGR) + ENDDO + ENDDO + DO IR=1,NREG + INDD(1)=NUNKNO/4+KEYFLX(IR,1) + INDD(2)=NUNKNO/2+KEYFLX(IR,1) + INDD(3)=3*NUNKNO/4+KEYFLX(IR,1) + DO IDIR=1,3 + SOURCE(INDD(IDIR),IGR)=(SOURCE(INDD(IDIR),IGR) + 1 +FUNKNO(KEYFLX(IR,1),IGR)/3.0)/GAMMA(IGR) + ENDDO + ENDDO + DEALLOCATE(SIGT0) + ENDIF + ENDDO + DO IDIR=1,3 + IF(IPRT.GE.3) + > WRITE(IOUT,'(30H FLUDBV: FUNDAMENTAL CURRENTS.)') + IF(IDIR.EQ.1) WRITE(6,*)'FUNDAMENTAL CURRENT X ' + IF(IDIR.EQ.2) WRITE(6,*)'FUNDAMENTAL CURRENT Y ' + IF(IDIR.EQ.3) WRITE(6,*)'FUNDAMENTAL CURRENT Z ' + NUNKNO4=NUNKNO/4 + ALLOCATE(SOURCE2(NUNKNO4*NGRP),FUNKNO2(NUNKNO4*NGRP)) + IOF=0 + DO IGR=1,NGRP + DO IND=1,NUNKNO4 + INDB(1)=NUNKNO/4+IND + INDB(2)=NUNKNO/2+IND + INDB(3)=3*NUNKNO/4+IND + IOF=IOF+1 + SOURCE2(IOF)=SOURCE(INDB(IDIR),IGR) + FUNKNO2(IOF)=FUNKNO(INDB(IDIR),IGR) + ENDDO + ENDDO + CALL DOORFV(CDOOR,JPSTR,NPSYS,IPTRK,IFTRAK,IPRT,NGRP,NMAT, + 1 IDIR,NREG,NUNKNO4,IPHASE,LEXAC,MATCOD,VOL,KEYFLX,TITLE, + 2 SOURCE2(1),FUNKNO2(1),IPMACR,IPSOU,REBFLG,FLUXC) + IOF=0 + DO IGR=1,NGRP + DO IND=1,NUNKNO4 + INDB(1)=NUNKNO/4+IND + INDB(2)=NUNKNO/2+IND + INDB(3)=3*NUNKNO/4+IND + IOF=IOF+1 + SOURCE(INDB(IDIR),IGR)=SOURCE2(IOF) + FUNKNO(INDB(IDIR),IGR)=FUNKNO2(IOF) + ENDDO + ENDDO + DEALLOCATE(FUNKNO2,SOURCE2) + ENDDO + ELSE IF((MOD(ILEAK,10).EQ.7).AND.(IPHASE.EQ.2)) THEN +* ---- +* TIBERE ANISOTROPIC STREAMING MODEL FOR PIJ. +* ---- + INDD(1)=NUNKNO/4 + INDD(2)=NUNKNO/2 + INDD(3)=3*NUNKNO/4 + NUN4=NUNKNO/4 + ALLOCATE(PP(NREG*NREG)) + DO 210 IGR=1,NGRP + IF(NPSYS(IGR).NE.0) THEN + KPSYS=LCMGIL(JPSYS,IGR) + DO 200 IDIR=1,3 + IF(B2(IDIR).NE.0.0) THEN + WRITE(TEXT12,'(6HDRAGON,I1,5HP*SCT)') IDIR + CALL LCMGET(KPSYS,TEXT12,PP) + DO 190 IR=1,NREG + IND=KEYFLX(IR,1) + S=0.0 + DO 180 JREG=1,NREG + JND=KEYFLX(JREG,1) + S=S+FLUOLD(INDD(IDIR)+JND,IGR)*PP((JREG-1)*NREG+IR) + 180 CONTINUE + SOURCE(IND,IGR)=SOURCE(IND,IGR)-B2(IDIR)*S + 190 CONTINUE + ENDIF + 200 CONTINUE + ENDIF + 210 CONTINUE + DEALLOCATE(PP) + IDIR=0 + CALL DOORFV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IPRT,NGRP,NMAT, + 1 IDIR,NREG,NUNKNO,IPHASE,LEXAC,MATCOD,VOL,KEYFLX,TITLE, + 2 SOURCE(1,1),FUNKNO(1,1),IPMACR,IPSOU,REBFLG,FLUXC) + DO 260 IDIR=1,3 + DO 250 IGR=1,NGRP + IF(NPSYS(IGR).NE.0) THEN + ZNUM=0.0 + ZDEN=0.0 + DO 220 IR=1,NREG + IBM=MATCOD(IR) + IND=KEYFLX(IR,1) + ZNUM=ZNUM+XSTRC(IBM,IGR)*FLUOLD(IND,IGR)*VOL(IR) + ZDEN=ZDEN+FLUOLD(IND,IGR)*VOL(IR) + 220 CONTINUE + DO 230 IR=1,NREG + IBM=MATCOD(IR) + IND=KEYFLX(IR,1) + IND2=INDD(IDIR)+IND + SOURCE(IND2,IGR)=SOURCE(IND2,IGR)+(1.0-GAMMA(IGR))* + 1 (ZNUM/ZDEN-XSTRC(IBM,IGR))*FLUOLD(IND2,IGR) + 230 CONTINUE + DO 240 IND=1,NUN4 + IND2=INDD(IDIR)+IND + SOURCE(IND2,IGR)=(SOURCE(IND2,IGR)+FUNKNO(IND,IGR)/3.0)/ + 1 GAMMA(IGR) + 240 CONTINUE + ENDIF + 250 CONTINUE + CALL DOORFV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IPRT,NGRP, + 1 NMAT,IDIR,NREG,NUNKNO,IPHASE,LEXAC,MATCOD,VOL,KEYFLX, + 2 TITLE,SOURCE(INDD(IDIR)+1,1),FUNKNO(INDD(IDIR)+1,1), + 3 IPMACR,IPSOU,REBFLG,FLUXC) + 260 CONTINUE + ELSE + CALL XABORT('FLUDBV: TYPE OF LEAKAGE NOT IMPLEMENTED.') + ENDIF +*---- +* COMPUTE DB2 PARAMETER CORRESPONDING TO ACTUAL LEAKAGE +*---- + IF((IPRT.GT.10).AND.(.NOT.LEAKSW)) THEN + NUN=NUNKNO + IF(ILEAK.EQ.6) NUN=NUNKNO/2 + IF(ILEAK.GE.7) NUN=NUNKNO/4 + DO 280 IGR=1,NGRP + IF(NPSYS(IGR).EQ.0) GO TO 280 + ZNUM=0.0 + ZDEN=0.0 + DO 265 IR=1,NREG + IND=KEYFLX(IR,1) + SSS=XSTRC(MATCOD(IR),IGR)-XSDIA(MATCOD(IR),0,IGR) + ZNUM=ZNUM+VOL(IR)*(SUNKNO(IND,IGR)-SSS*FUNKNO(IND,IGR)) + ZDEN=ZDEN+VOL(IR)*FUNKNO(IND,IGR) + 265 CONTINUE + DB2NEW=0.0 + IF(ZDEN.GT.0.0) DB2NEW=ZNUM/ZDEN + DB2OLD=0.0 + VOLTOT=0.0 + DO 270 IR=1,NREG + INM=IMERG(IR) + IF(INM.EQ.0) GO TO 270 + DB2OLD=DB2OLD+DIFHET(INM,IGR)*B2(4)*VOL(IR) + VOLTOT=VOLTOT+VOL(IR) + 270 CONTINUE + DB2OLD=DB2OLD/VOLTOT + WRITE(IOUT,'(15H FLUDBV: GROUP=,I5,24H DB2 LEAKAGE PARAMETER F, + > 12HROM DIFFON =,1P,E13.4/26X,30HACTUAL DB2 LEAKAGE PARAMETER =, + > E13.4)') IGR,DB2OLD,DB2NEW + 280 CONTINUE + ENDIF + SUNKNO(:NUNKNO,:NGRP)=SOURCE(:NUNKNO,:NGRP) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SOURCE) + RETURN + END diff --git a/Dragon/src/FLUDRV.f b/Dragon/src/FLUDRV.f new file mode 100644 index 0000000..428113d --- /dev/null +++ b/Dragon/src/FLUDRV.f @@ -0,0 +1,345 @@ +*DECK FLUDRV + SUBROUTINE FLUDRV(IPRT,IPFLUX,IPTRK,IPMACR,IPSOU,IFTRAK,IPSYS, + 1 IPHASE,ITPIJ,CXDOOR,ITRANC,TITLE,B2,INITFL,LFORW,LEAKSW,IREBAL, + 2 NGRP,NMAT,NIFIS,NANIS,NLF,NLIN,NFUNL,OPTION,NUN,MAXINR,EPSINR, + 3 MAXOUT,EPSUNK,EPSOUT,IFRITR,IACITR,ITYPEC,ILEAK,NREG,NSOUT, + 4 MATCOD,KEYFLX,VOL,REFKEF,NMERG,IMERG) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Driver for Boltzmann equation solvers. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPRT print flag. +* IPFLUX pointer to the flux LCM object. +* IPTRK pointer to the tracking LCM object. +* IPMACR pointer to the macrolib LCM object. +* IPSOU pointer to the fixed source LCM object. +* IFTRAK tracking file unit number. +* IPSYS pointer to the system LCM object (=0 for the method of +* characteristics). +* IPHASE 1 for asm 2 for pij. +* ITPIJ type of collision probability information available: +* =1 scattering modified pij (wij); +* =2 standard pij; +* =3 scattering modified pij+pijk (wij,wijk); +* =4 standard pij+pijk. +* CXDOOR name of the flux solution door. +* ITRANC type of transport correction (>0 to perform a correction). +* TITLE title. +* B2 initial or imposed directional bucklings. +* INITFL flux initialization flag (=0/1/2: uniform flux/LCM/DSA). +* LFORW flag set to .false. to solve an adjoint problem. +* LEAKSW leakage flag (=.true. if leakage is present on the outer +* surface). +* IREBAL flux rebalancing flag (=1: perform rebalancing). +* NGRP number of energy groups. +* NMAT number of mixtures. +* NIFIS number of fissile isotopes. +* NANIS maximum cross section Legendre order. +* NLF number of Legendre orders for the flux. +* NLIN number of polynomial components in flux spatial expansion. +* NFUNL number of spherical harmonics components. +* OPTION type of leakage coefficients: +* 'LKRD' (recover leakage coefficients in Macrolib); +* 'RHS' (recover leakage coefficients in RHS flux object); +* 'B0' (B-0), 'P0' (P-0), 'B1' (B-1), +* 'P1' (P-1), 'B0TR' (B-0 with transport correction) or 'P0TR' +* (P-0 with transport correction). +* NUN number of unknowns per energy group including spherical +* harmonic terms, interface currents and fundamental +* currents. +* MAXINR maximum number of thermal iterations. +* EPSINR thermal iterations epsilon. +* MAXOUT maximum number of outer iterations. +* EPSUNK outer iterations eigenvector epsilon. +* EPSOUT outer iterations eigenvalue epsilon. +* IFRITR number of free iterations in an acceleration cycle. +* IACITR number of accelerated iterations in an acceleration cycle. +* ITYPEC type of flux evaluation: +* =-1 skip the flux calculation; +* =0 fixed sources; +* =1 fixed source eigenvalue problem (GPT type); +* =2 fission sources/K-eff convergence; +* =3 fission sources/K-eff convergence/db2 buckling evaluation; +* =4 fission sources/db2 buckling convergence; +* =5 b2 sources/db2 buckling convergence. +* ILEAK method used to include DB2 effect: +* =1 the scattering modified cp matrix is multiplied by PNLR; +* =2 the reduced cp matrix is multiplied by PNL; +* =3 sigs0-db2 approximation; +* =4 albedo approximation; +* =5 Todorova-type isotropic streaming model; +* =6 Ecco-type isotropic streaming model; +* >6 Tibere type anisotropic streaming model. +* NREG number of regions. +* NSOUT number of outer surfaces. +* MATCOD mixture indices. +* KEYFLX index of L-th order flux components in unknown vector. +* VOL volumes. +* REFKEF target effective multiplication factor (K-eff). +* NMERG number of leakage zones. +* IMERG leakage zone index in each material mixture zone. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER CXDOOR*12,TITLE*72,OPTION*4 + TYPE(C_PTR) IPFLUX,IPTRK,IPMACR,IPSOU,IPSYS + INTEGER IPRT,IFTRAK,IPHASE,ITPIJ,ITRANC,INITFL,IREBAL,NGRP, + > NMAT,NIFIS,NANIS,NLF,NLIN,NFUNL,NUN,MAXINR,MAXOUT, + > IFRITR,IACITR,ITYPEC,ILEAK,NREG,NSOUT,MATCOD(NREG), + > KEYFLX(NREG,NLIN,NFUNL),NMERG,IMERG(NMAT) + REAL EPSUNK,EPSINR,B2(4),VOL(NREG) + LOGICAL LFORW,LEAKSW + DOUBLE PRECISION REFKEF +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6,NSTATE=40,NDIMO=2,IGPT=0) + TYPE(C_PTR) JPMACR,KPMACR,JPFLUX,IPFLUP,JPSYS,KPSYS + LOGICAL LREBAL + INTEGER ISTATE(NSTATE) + REAL EPSCON(5) + CHARACTER CAN(0:19)*2 +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: SIGT,SIGS0 + REAL, ALLOCATABLE, DIMENSION(:,:) :: FLUXO,XSTRC,XSTK + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: XSDIA,XSCHI,XSNUF +*---- +* DATA STATEMENTS +*---- + SAVE CAN + DATA CAN /'00','01','02','03','04','05','06','07','08','09', + > '10','11','12','13','14','15','16','17','18','19'/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(FLUXO(NUN,NGRP),XSTRC(0:NMAT,NGRP), + > XSDIA(0:NMAT,0:NANIS,NGRP),XSCHI(0:NMAT,NIFIS,NGRP), + > XSNUF(0:NMAT,NIFIS,NGRP),XSTK(NMAT,NIFIS)) +* + IF(IPRT.GE.3) THEN + WRITE(IUNOUT,6000) + WRITE(IUNOUT,6001) (IREGIO,VOL(IREGIO),MATCOD(IREGIO), + > IREGIO=1,NREG) + ENDIF + IPFLUP=C_NULL_PTR +*---- +* RECOVER CROSS SECTIONS. +*---- + JPMACR=LCMGID(IPMACR,'GROUP') + DO 110 IGR=1,NGRP + KPMACR=LCMGIL(JPMACR,IGR) + DO 10 IANI=0,NANIS + CALL LCMLEN(KPMACR,'NJJS'//CAN(IANI),ILNLCM,ITYLCM) + IF(ILNLCM.NE.NMAT) THEN + CALL LCMLIB(KPMACR) + CALL XABORT('FLUDRV: FLUX CALCULATION ERROR, SCATTERING'// + > ' MATRIX OF ORDER ANIS ='//CAN(IANI)//' NOT ON LCM') + ENDIF + 10 CONTINUE +*---- +* RECOVER CORRECTED TOTAL AND WITHIN-GROUP SCATTERING CROSS SECTIONS +*---- + JPSYS=LCMGID(IPSYS,'GROUP') + KPSYS=LCMGIL(JPSYS,IGR) + CALL LCMLEN(KPSYS,'DRAGON-TXSC',ILCTX,ITYLCM) + CALL LCMLEN(KPSYS,'DRAGON-S0XSC',ILCS0X,ITYLCM) + IF(ILCTX.NE.NMAT+1) THEN + CALL XABORT('FLUDRV: INVALID LENGTH FOR DRAGON-TXSC.') + ELSE IF(MOD(ILCS0X,NMAT+1).NE.0) THEN + CALL XABORT('FLUDRV: INVALID LENGTH FOR DRAGON-S0XSC.') + ENDIF + NANI_ASM=ILCS0X/(NMAT+1)-1 + ALLOCATE(SIGT(ILCTX),SIGS0(ILCS0X)) + SIGS0(:ILCS0X)=0.0 + CALL LCMGET(KPSYS,'DRAGON-TXSC',SIGT) + CALL LCMGET(KPSYS,'DRAGON-S0XSC',SIGS0) + XSTRC(0:NMAT,IGR)=SIGT(:NMAT+1) + XSDIA(0:NMAT,0:NANIS,IGR)=0.0 + DO IANI=0,MIN(NANIS,NANI_ASM) + DO IMAT=1,NMAT + XSDIA(IMAT,IANI,IGR)=SIGS0(IANI*(NMAT+1)+IMAT+1) + ENDDO + ENDDO + DEALLOCATE(SIGS0,SIGT) + IF(IPRT.GE.3) THEN + WRITE(IUNOUT,6002) IGR + WRITE(IUNOUT,6003) (IMAT,XSTRC(IMAT,IGR), + > XSDIA(IMAT,0,IGR),IMAT=1,NMAT) + ENDIF +*---- +* RECOVER FISSION CROSS SECTIONS +*---- + CALL LCMLEN(KPMACR,'CHI',ILONG,ITYLCM) + IF( ILONG.EQ.0 )THEN + IF(( ITYPEC.NE.0 ).AND.( ITYPEC.NE.5 ) + 1 .AND.( ITYPEC.NE.-2 ))THEN + CALL XABORT('FLUDRV: TYPE S, F OR L REQUESTED') + ENDIF + XSCHI(0:NMAT,:NIFIS,:NGRP)=0.0 + XSNUF(0:NMAT,:NIFIS,:NGRP)=0.0 + ELSE + CALL LCMGET(KPMACR,'CHI',XSTK) + DO 60 IFIS= 1, NIFIS + XSCHI(0,IFIS,IGR)= 0.0 + DO 50 IMAT= 1, NMAT + XSCHI(IMAT,IFIS,IGR)= XSTK(IMAT,IFIS) + 50 CONTINUE + 60 CONTINUE + CALL LCMGET(KPMACR,'NUSIGF',XSTK) + DO 80 IFIS= 1, NIFIS + XSNUF(0,IFIS,IGR)= 0.0 + DO 70 IMAT= 1, NMAT + XSNUF(IMAT,IFIS,IGR)= XSTK(IMAT,IFIS) + 70 CONTINUE + 80 CONTINUE + IF( IPRT.GT.3 )THEN + WRITE(IUNOUT,6004) (IMAT,XSNUF(IMAT,1,IGR), + > XSCHI(IMAT,1,IGR),IMAT=1,NMAT) + ENDIF + ENDIF + DO 100 IANI=0,NANIS + CALL LCMLEN(KPMACR,'NJJS'//CAN(IANI),ILNLCM,ITYLCM) + IF(ILNLCM.NE.NMAT) THEN + CALL LCMLIB(KPMACR) + CALL XABORT('FLUDRV: FLUX CALCULATION ERROR, SCATTERING'// + > ' MATRIX OF ORDER ANIS ='//CAN(IANI)//' NOT ON LCM') + ENDIF + 100 CONTINUE + 110 CONTINUE +*---- +* FLUX INITIALIZATION +*---- + IF(LFORW) THEN + CALL LCMLEN(IPFLUX,'FLUX',ILINIT,ITYLCM) + ELSE + CALL LCMLEN(IPFLUX,'AFLUX',ILINIT,ITYLCM) + ENDIF + IF((ILINIT.EQ.0).OR.(INITFL.EQ.0)) THEN + IF(LFORW) THEN + JPFLUX=LCMLID(IPFLUX,'FLUX',NGRP) + ELSE + JPFLUX=LCMLID(IPFLUX,'AFLUX',NGRP) + ENDIF + DO 130 IGR=1,NGRP + FLUXO(:NUN,IGR)=0.0 + IF(ITYPEC.GT.0) THEN + IF((CXDOOR.EQ.'BIVAC').OR.(CXDOOR.EQ.'TRIVAC')) THEN + FLUXO(:NUN,IGR)=1.0 + ELSE + DO 120 IREGIO=1,NREG + IND=KEYFLX(IREGIO,1,1) + IF(IND.GT.0) FLUXO(IND,IGR)=1.0 + 120 CONTINUE + ENDIF + ENDIF + IF(LFORW) THEN + CALL LCMPDL(JPFLUX,IGR,NUN,2,FLUXO(1,IGR)) + ELSE + CALL LCMPDL(JPFLUX,NGRP-IGR+1,NUN,2,FLUXO(1,IGR)) + ENDIF + 130 CONTINUE + ENDIF + IF(ITYPEC.GE.2) THEN + EIGENK=REAL(REFKEF) + CALL LCMPUT(IPFLUX,'K-EFFECTIVE',1,2,EIGENK) + ENDIF + IF(ITYPEC.GE.3) THEN + CALL LCMPUT(IPFLUX,'B2 B1HOM',1,2,B2(4)) + IF(ILEAK.GE.7) CALL LCMPUT(IPFLUX,'B2 HETE',3,2,B2) + ENDIF + IF(ITYPEC.EQ.-1) GO TO 1001 +* + IF(ILEAK.GE.7.AND.ITYPEC.GE.3) THEN + IF(ITRANC.EQ.0) THEN + IF(OPTION.EQ.'B0TR'.OR.OPTION.EQ.'P0TR'.OR.OPTION.EQ.'LKRD' + > .OR.OPTION.EQ.'RHS') + > CALL XABORT('FLUDRV: ILLEGAL OPTION = '//OPTION// + > ' FOR HETEROGENEOUS LEAKAGE CALCULATION'// + > ' WITHOUT TRANSPORT CORRECTED CROSS SECTIONS') + ENDIF + ENDIF +* + IF (CXDOOR.EQ.'MCCG') THEN + CALL LCMLEN(IPTRK,'KEYCUR$MCCG',ICREB,ITYLCM) + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + IF ((ICREB.GT.0).AND.(ISTATE(24).EQ.0)) THEN + LREBAL=(IREBAL.EQ.1) + ELSE + LREBAL=(IREBAL.EQ.1).AND.(.NOT.LEAKSW) + ENDIF + ELSE + LREBAL=(IREBAL.EQ.1).AND.(.NOT.LEAKSW) + ENDIF + CALL FLU2DR(IPRT,IPMACR,IPFLUX,IPSYS,IPTRK,IPFLUP,IPSOU,IGPT, + 1 IFTRAK,CXDOOR,TITLE,NUN,NREG,NSOUT,NANIS,NLF,NLIN,NFUNL,NGRP, + 2 NMAT,NIFIS,LFORW,LEAKSW,MAXINR,EPSINR,MAXOUT,EPSUNK,EPSOUT, + 3 IFRITR,IACITR,ITYPEC,IPHASE,ITPIJ,ILEAK,OPTION,REFKEF,MATCOD, + 4 KEYFLX,VOL,XSTRC,XSDIA,XSNUF,XSCHI,LREBAL,INITFL,NMERG,IMERG) +* + 1001 CALL LCMLEN(IPFLUX,'FLUX',ILON1,ITYLCM) + CALL LCMLEN(IPFLUX,'AFLUX',ILON2,ITYLCM) + ISTATE(:NSTATE)=0 + ISTATE(1)=NGRP + ISTATE(2)=NUN + IF((ILON1.GT.0).AND.(ILON2.GT.0)) THEN + ISTATE(3)=11 + ELSE IF(ILON1.GT.0) THEN + ISTATE(3)=1 + ELSE IF(ILON2.GT.0) THEN + ISTATE(3)=10 + ENDIF + ISTATE(4)=0 + ISTATE(5)=0 + ISTATE(6)=ITYPEC + ISTATE(7)=ILEAK + ISTATE(8)=IFRITR + ISTATE(9)=IACITR + ISTATE(10)=IREBAL + ISTATE(11)=MAXINR + ISTATE(12)=MAXOUT + ISTATE(17)=NMAT + ISTATE(18)=NMERG + CALL LCMPUT(IPFLUX,'STATE-VECTOR',NSTATE,1,ISTATE) + EPSCON(1)=EPSINR + EPSCON(2)=EPSUNK + EPSCON(3)=EPSOUT + EPSCON(4:5)=0.0 + CALL LCMPUT(IPFLUX,'EPS-CONVERGE',5,2,EPSCON) + CALL LCMPUT(IPFLUX,'KEYFLX',NREG,1,KEYFLX) + CALL LCMPTC(IPFLUX,'OPTION',4,OPTION) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XSTK,XSNUF,XSCHI,XSDIA,XSTRC,FLUXO) + RETURN +*---- +* FORMATS +*---- + 6000 FORMAT(//30X,' EDITION REGION/VOL/MIXTURE '// + >3(5X,'REGION',5X,'VOL ',5X,'MIXTURE')/) + 6001 FORMAT(1P,3(1X,I8,4X,E12.5,I8,4X)) + 6002 FORMAT(//30X,' G R O U P : ',I5// + >30X,' TOTAL MACROSCOPIC CROSS SECTIONS PER MIXTURE '/) + 6003 FORMAT(3(1X,'MIXTURE',4X,'NTOT0',11X,'SIGW',3X)/ + >1P,3(1X,I4,3X,E12.5,3X,E12.5)) + 6004 FORMAT(3(1X,'MIXTURE',4X,'NUSIGF',11X,'CHI ',3X)/ + >1P,3(1X,I4,3X,E12.5,3X,E12.5)) + END diff --git a/Dragon/src/FLUGPI.f b/Dragon/src/FLUGPI.f new file mode 100644 index 0000000..91c5ef2 --- /dev/null +++ b/Dragon/src/FLUGPI.f @@ -0,0 +1,439 @@ +*DECK FLUGPI + SUBROUTINE FLUGPI(IPFLUX,IPMACR,ITYPEC,MAXOUT,MAXINR,EPSOUT, + > EPSUNK,EPSINR,IREBAL,IFRITR,IACITR,COPTIO, + > ILEAK,B2,NGROUP,NREGIO,NMAT,NIFISS,LEAKSW, + > REFKEF,ITPIJ,IPRINT,REC,INITFL,NMERG,IMERG) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read data for flux solution operator. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPFLUX pointer to the flux LCM object. +* IPMACR pointer to the macrolib LCM object. +* NGROUP number of energy groups. +* NREGIO number of regions. +* NMAT number of material mixtures. +* NIFISS number of fissile isotopes. +* LEAKSW leakage flag (=.true. if leakage is present on the outer +* surface). +* ITPIJ type of collision probability information available: +* =1 scattering modified pij (wij); +* =2 standard pij; +* =3 scattering modified pij+pijk (wij,wijk); +* =4 standard pij+pijk. +* REC flux recovery flag: +* =.true. recover the existing solution as initial estimate; +* =.false. use a new initial estimate. +* +*Parameters: output +* ITYPEC type of flux evaluation: +* =-2 Fourier analysis; +* =-1 skip the flux calculation; +* =0 fixed sources; +* =1 fixed source eigenvalue problem (GPT type); +* =2 fission sources/K-eff convergence; +* =3 fission sources/K-eff convergence/db2 buckling evaluation; +* =4 fission sources/db2 buckling convergence; +* =5 b2 sources/db2 buckling convergence; +* MAXOUT maximum number of outer iterations. +* MAXINR maximum number of thermal iterations. +* EPSOUT outer iterations eigenvalue epsilon. +* EPSUNK outer iterations eigenvector epsilon. +* EPSINR thermal iterations epsilon. +* IREBAL flux rebalancing flag (=1: perform rebalancing). +* IFRITR number of free iterations in an acceleration cycle. +* IACITR number of accelerated iterations in an acceleration cycle. +* COPTIO type of leakage coefficients: +* 'LKRD' (recover leakage coefficients in Macrolib); +* 'RHS' (recover leakage coefficients in RHS flux object); +* 'B0' (B-0), 'P0' (P-0), 'B1' (B-1), +* 'P1' (P-1), 'B0TR' (B-0 with transport correction) or 'P0TR' +* (P-0 with transport correction). +* ILEAK method used to include db2 effect: +* =1 the scattering modified cp matrix is multiplied by PNLR; +* =2 the reduced cp matrix is multiplied by PNL; +* =3 sigs0-db2 approximation; +* =4 albedo approximation; +* =5 Todorova-type isotropic streaming model; +* =6 Ecco-type isotropic streaming model; +* =17,27,37,47,57,67 for heterogeneous method with pijk and +* fixed b (17) or search b_x(27), b_y (37), b_z (47), +* b_r (57) or b_x=b_y=b_z (67). +* B2 initial or imposed directional bucklings. +* REFKEF target effective multiplication factor (K-eff). +* IPRINT print selection for FLU: module (= 0/1/2/3 no print/short +* print/long print). +* INITFL flux initialisation flags: +* = 0 flux initialisation (=0.0 or 1.0); +* = 1 flux read on LCM; +* = 2 initialization from DSA flux read on LCM. +* NMERG number of leakage zones. +* IMERG leakage zone index in each material mixture zone. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPFLUX,IPMACR + INTEGER ITYPEC,MAXOUT,MAXINR,IREBAL,IFRITR,IACITR,ILEAK, + > NGROUP,NREGIO,NMAT,NIFISS,ITPIJ,IPRINT,INITFL,NMERG, + > IMERG(NMAT) + REAL EPSOUT,EPSUNK,EPSINR,B2(4) + CHARACTER COPTIO*4 + LOGICAL LEAKSW,REC + DOUBLE PRECISION REFKEF +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NBUCKN=7,NLEAK=7,NSDIR=5,ROUMIN=1.0E-5,RINMIN=5.0E-5, + > NSTATE=40) + CHARACTER CARLIR*4,CTYPEC*1,CBUCKN(0:NBUCKN)*4,CLEAK(NLEAK)*6, + > CSDIR(NSDIR)*1 + SAVE CBUCKN,CLEAK,CSDIR + INTEGER ITYPLU,INTLIR,IRSDIR(NSDIR),ISTATE(NSTATE) + REAL REALIR,BSDIR(NSDIR),EPSCON(5) + DOUBLE PRECISION DBLINP + DATA (CBUCKN(JJ),JJ=0,NBUCKN) + > /'LKRD','RHS','B0','P0','B1','P1','B0TR','P0TR'/ + DATA (CLEAK(JJ),JJ=1,NLEAK) + > /'PNLR','PNL','SIGS','ALBS','HETE','ECCO','TIBERE'/ + DATA (CSDIR(III),III=1,NSDIR) + > /'X','Y','Z','R','G'/ +*---- +* INITIALIZE TO DEFAULT VALUE +*---- + ISDIR=0 + COPTIO='B0' + IF((ITPIJ.EQ.1).OR.(ITPIJ.GE.3)) ISDIR=5 + DO 10 III=1,NSDIR + BSDIR(III)=0.0 + IRSDIR(III)=0 + 10 CONTINUE + REFKEF=1.0D0 + IPRINT=1 + IF(REC) THEN + CALL LCMGET(IPFLUX,'STATE-VECTOR',ISTATE) + ITYPEC=ISTATE(6) + ILEAK=ISTATE(7) + IFRITR=ISTATE(8) + IACITR=ISTATE(9) + IREBAL=ISTATE(10) + MAXOUT=ISTATE(12) + NMERG=ISTATE(18) + CALL LCMGET(IPFLUX,'EPS-CONVERGE',EPSCON) + EPSINR=EPSCON(1) + EPSUNK=EPSCON(2) + EPSOUT=EPSCON(3) + INITFL=1 + CALL LCMLEN(IPFLUX,'B2 HETE',ILCML1,ITYLCM) + CALL LCMLEN(IPFLUX,'B2 B1HOM',ILCML2,ITYLCM) + IF(ILCML1.EQ.3) THEN + CALL LCMGET(IPFLUX,'B2 HETE',BSDIR) + IRSDIR(1)=1 + IRSDIR(2)=1 + IRSDIR(3)=1 + ELSE IF(ILCML2.EQ.1) THEN + CALL LCMGET(IPFLUX,'B2 B1HOM',BSDIR(5)) + IRSDIR(5)=1 + ENDIF + IF(NMERG.GT.0) CALL LCMGET(IPFLUX,'IMERGE-LEAK',IMERG) + ELSE + ITYPEC=-99 + ILEAK=0 + IFRITR=3 + IACITR=3 + IREBAL=1 + MAXOUT=0 + EPSINR=RINMIN + EPSUNK=0.0 + EPSOUT=ROUMIN + INITFL=0 + NMERG=1 + IMERG(:NMAT)=1 + CALL LCMPUT(IPFLUX,'IMERGE-LEAK',NMAT,1,IMERG) + ENDIF + IF(NGROUP.EQ.1) MAXINR=1 + IF(MOD(ITPIJ,2).EQ.0) THEN + MAXINR=4*NGROUP + ELSE + MAXINR=2*NGROUP + ENDIF +*---- +* READ OPTION NAME +*---- + 20 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) + IF(ITYPLU.EQ.10) GO TO 140 + 30 IF(ITYPLU.NE.3) + > CALL XABORT('FLUGPI: READ ERROR - CHARACTER VARIABLE EXPECTED') + IF(CARLIR.EQ.';') THEN + GO TO 140 + ELSE IF(CARLIR.EQ.'EDIT') THEN + CALL REDGET(ITYPLU,IPRINT,REALIR,CARLIR,DBLINP) + IF(ITYPLU.NE.1) CALL XABORT('FLUGPI: READ ERROR - INTEGER VA' + > //'RIABLE EXPECTED') + ELSE IF(CARLIR.EQ.'TYPE') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CTYPEC,DBLINP) + IF(ITYPLU.NE.3) CALL XABORT('FLUGPI: READ ERROR - CHARACTER ' + > //'VARIABLE EXPECTED') + IF(CTYPEC.EQ.'N') THEN + ITYPEC=-1 + ELSE IF(CTYPEC.EQ.'S') THEN + ITYPEC=0 + ELSE IF(CTYPEC.EQ.'P') THEN + ITYPEC=1 + ELSE IF(CTYPEC.EQ.'K') THEN + ITYPEC=2 + ELSE IF(CTYPEC.EQ.'B') THEN + ITYPEC=4 + ILEAK=3 + ELSE IF(CTYPEC.EQ.'L') THEN + ITYPEC=5 + ILEAK=3 + ELSE IF(CTYPEC.EQ.'F') THEN + ITYPEC=-2 + ILEAK=0 + MAXOUT=1 + MAXINR=1 + ELSE + CALL XABORT('FLUGPI: READ ERROR - INVALID TYPE KEYWORD= ' + > //CTYPEC//' -- ONLY VALUES ALLOWED ARE: N,S,K,B,L OR F') + ENDIF + IF(ITYPEC.GE.2) THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) + IF(ITYPLU.NE.3) CALL XABORT('FLUGPI: READ ERROR - CHARACTE' + > //'R VARIABLE EXPECTED') + DO 40 JBUC=0,NBUCKN + IF(CARLIR.EQ.CBUCKN(JBUC)) THEN + COPTIO=CARLIR + GO TO 50 + ENDIF + 40 CONTINUE + GO TO 30 + 50 IF(ITYPEC.EQ.2) ITYPEC=3 + ILEAK=3 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) + IF(ITYPLU.NE.3) CALL XABORT('FLUGPI: READ ERROR - CHARACTE' + > //'R VARIABLE EXPECTED') + DO 70 JLEA=1,NLEAK + IF(CARLIR.EQ.CLEAK(JLEA)(:4)) THEN + ILEAK=JLEA + IF(LEAKSW.AND.(ILEAK.NE.3).AND.(ILEAK.NE.5)) THEN + CALL XABORT('FLUGPI: FUNDAMENTAL MODE EXPECTED WITH A ' + > //'LEAKAGE MODEL OTHER THAN SIGS OR HETE.') + ENDIF + IF(ILEAK.EQ.5) THEN + DO IBM=1,NMAT + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) + IF((IBM.EQ.1).AND.(ITYPLU.EQ.3)) GO TO 30 + IF(ITYPLU.NE.1) CALL XABORT('FLUGPI: READ ERROR - IN' + > //'TEGER VARIABLE EXPECTED') + IMERG(IBM)=INTLIR + NMERG=MAX(NMERG,IMERG(IBM)) + ENDDO + CALL LCMPUT(IPFLUX,'IMERGE-LEAK',NMAT,1,IMERG) + ELSE IF(ILEAK.EQ.7) THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) + IF(ITYPLU.NE.3) CALL XABORT('FLUGPI: READ ERROR - ' + > //'CHARACTER VARIABLE EXPECTED') + DO 60 III=1,NSDIR + IF(CARLIR.EQ.CSDIR(III)) THEN + ISDIR=III + GO TO 20 + ENDIF + 60 CONTINUE + GO TO 30 + ENDIF + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) + GO TO 30 + ENDIF + 70 CONTINUE + GO TO 30 + ENDIF + ELSE IF(CARLIR.EQ.'REBA') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) + IF(ITYPLU.NE.3) CALL XABORT('FLUGPI: READ ERROR - CHARACTE' + > //'R VARIABLE EXPECTED') + IF(CARLIR.EQ.'OFF ') THEN + IREBAL=0 + ELSE + IREBAL=1 + GO TO 30 + ENDIF + ELSE IF(CARLIR.EQ.'INIT') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) + IF(ITYPLU.NE.3) CALL XABORT('FLUGPI: READ ERROR - CHARACTE' + > //'R VARIABLE EXPECTED') + IF(CARLIR.EQ.'OFF') THEN +* initial flat distribution + INITFL=0 + ELSE IF(CARLIR.EQ.'ON') THEN +* use LCM flux + INITFL=1 + ELSE IF(CARLIR.EQ.'DSA') THEN +* use DSA flux + INITFL=2 + ELSE + CALL XABORT('FLUGPI: OFF/ON/DSA KEYWORD EXPECTED') + ENDIF + ELSE IF(CARLIR.EQ.'EXTE') THEN + DO 90 II=1,3 + CALL REDGET(ITYPLU,NITMA,EPSOUT,CARLIR,DBLINP) + IF(ITYPLU.EQ.1) MAXOUT=NITMA + IF(ITYPLU.EQ.3) GO TO 30 + 90 CONTINUE + ELSE IF(CARLIR.EQ.'UNKT') THEN + CALL REDGET(ITYPLU,INTLIR,EPSUNK,CARLIR,DBLINP) + IF(ITYPLU.NE.2) + > CALL XABORT('FLUGPI: REAL VALUE OF EPSUNK MUST FOLLOW' + > //' UNKT') + GO TO 20 + ELSE IF(CARLIR.EQ.'THER') THEN + DO 100 II=1,3 + CALL REDGET(ITYPLU,NITMA,EPSINR,CARLIR,DBLINP) + IF(ITYPLU.EQ.1) MAXINR=NITMA + IF(ITYPLU.EQ.3) GO TO 30 + 100 CONTINUE + ELSE IF(CARLIR.EQ.'ACCE') THEN + CALL REDGET(ITYPLU,IFRITR,REALIR,CARLIR,DBLINP) + IF(ITYPLU.NE.1) CALL XABORT('FLUGPI: READ ERROR - INTEGER VA' + > //'RIABLE EXPECTED') + CALL REDGET(ITYPLU,IACITR,REALIR,CARLIR,DBLINP) + IF(ITYPLU.NE.1) CALL XABORT('FLUGPI: READ ERROR - INTEGER VA' + > //'RIABLE EXPECTED') + ELSE IF(CARLIR.EQ.'KEFF') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) + IF(ITYPLU.NE.2) CALL XABORT('FLUGPI: READ ERROR - REAL VA' + > //'RIABLE EXPECTED FOLLOWING KEFF KEYWORD') + REFKEF=REALIR + ELSE IF(CARLIR.EQ.'BUCK') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) + IRSDIR(:NSDIR)=0 + IF(ITYPLU.EQ.2) THEN + BSDIR(5)=REALIR + IRSDIR(5)=1 + GO TO 20 + ELSE IF(ITYPLU.EQ.1) THEN + CALL XABORT('FLUGPI: READ ERROR - INTEGER ' + > //'VARIABLE FOUND FOLLOWING BUCK KEYWORD') + ENDIF + 110 CONTINUE + DO 120 III=1,NSDIR + IF(CARLIR.EQ.CSDIR(III)) THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) + IF(ITYPLU.NE.2) + > CALL XABORT('FLUGPI: READ ERROR - REAL VARIABLE '// + > 'EXPECTED FOLLOWING BUCKLING DIRECTION KEYWORD') + BSDIR(III)=REALIR + IRSDIR(III)=1 + GO TO 130 + ENDIF + 120 CONTINUE + GO TO 30 + 130 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) + IF(ITYPLU.NE.3) + > CALL XABORT('FLUGPI: READ ERROR - CHARACTER ' + > //'VARIABLE EXPECTED') + GO TO 110 + ELSE IF(CARLIR.EQ.'IDEM') THEN + IRSDIR(:NSDIR)=0 + CALL LCMLEN(IPMACR,'B2 HETE',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.3) THEN + CALL LCMGET(IPMACR,'B2 HETE',BSDIR) + IRSDIR(1)=1 + IRSDIR(2)=1 + IRSDIR(3)=1 + ENDIF + CALL LCMLEN(IPMACR,'B2 B1HOM',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.1) THEN + CALL LCMGET(IPMACR,'B2 B1HOM',BSDIR(5)) + IRSDIR(5)=1 + ENDIF + ELSE + CALL XABORT('FLUGPI: READ ERROR - ILLEGAL KEYWORD '//CARLIR) + ENDIF + GO TO 20 +*---- + 140 CONTINUE + IF(ITYPEC.EQ.3) THEN + ISDIR=0 + IF(ILEAK.EQ.7) THEN + DO 150 III=1,NSDIR + IF(IRSDIR(III).EQ.1) GO TO 160 + 150 CONTINUE + ELSE + GO TO 160 + ENDIF + CALL XABORT('FLUGPI: NO BUCKLING READ FOR TYPE K '// + > 'CALCULATION WITH IMPOSED BUCKLING') + 160 CONTINUE + ENDIF + IF(ILEAK.EQ.7) THEN + IF(IRSDIR(5).EQ.1) THEN + DO 210 III=1,NSDIR-1 + IF(IRSDIR(III).EQ.1) THEN + CALL XABORT('FLUGPI: GLOBAL INITIAL BUCKLING '// + > 'INCONSISTENT WITH X, Y, Z, R BUCKLING') + ENDIF + 210 CONTINUE + B2(1)=BSDIR(5)/3.0 + B2(2)=B2(1) + B2(3)=B2(1) + B2(4)=BSDIR(5) + ELSE IF(IRSDIR(4).EQ.1) THEN + DO 220 III=1,2 + IF(IRSDIR(III).EQ.1) THEN + CALL XABORT('FLUGPI: RADIAL INITIAL BUCKLING '// + > 'INCONSISTENT WITH X, Y BUCKLING') + ENDIF + 220 CONTINUE + B2(1)=BSDIR(4)/2.0 + B2(2)=B2(1) + B2(3)=BSDIR(3) + B2(4)=BSDIR(3)+BSDIR(4) + ELSE + B2(1)=BSDIR(1) + B2(2)=BSDIR(2) + B2(3)=BSDIR(3) + B2(4)=BSDIR(1)+BSDIR(2)+BSDIR(3) + ENDIF + ILEAK=(ISDIR+1)*10+ILEAK + ELSE + IF(IRSDIR(4).NE.0.OR.IRSDIR(3).NE.0.OR. + > IRSDIR(2).NE.0.OR.IRSDIR(1).NE.0) + > CALL XABORT('FLUGPI: FOR HOMOGENEOUS LEAKAGE METHOD'// + > 'DIRECTIONS X ,Y, Z AND R BUCKLING ARE ILLEGAL') + B2(4)=BSDIR(5) + ENDIF + IF(EPSOUT.LT.1.0E-10) THEN + CALL XABORT('FLUGPI: ERROR -- EPSOUT MUST BE GREATER '// + > 'THAN 1.0E-10') + ENDIF + IF(EPSINR.LT.1.0E-10) THEN + CALL XABORT('FLUGPI: ERROR -- EPSINR MUST BE GREATER '// + > 'THAN 1.0E-10') + ENDIF + IF(EPSUNK.LE.1.0E-10) EPSUNK=EPSINR + IF(ITYPEC.EQ.-99) CALL XABORT('FLUGPI: TYPE NOT DEFINED.') + IF(MAXOUT.EQ.0)THEN + IF(ITYPEC.LE.2) THEN + MAXOUT=MAX(2*NREGIO-1,2*NIFISS-1) + ELSE + MAXOUT=MAX(10*NREGIO+1,10*NIFISS+1) + ENDIF + ENDIF + RETURN + END diff --git a/Dragon/src/FLUGPT.f b/Dragon/src/FLUGPT.f new file mode 100644 index 0000000..de7d160 --- /dev/null +++ b/Dragon/src/FLUGPT.f @@ -0,0 +1,361 @@ +*DECK FLUGPT + SUBROUTINE FLUGPT(IPRT,IPFLUX,IPTRK,IPMACR,IPFLUP,IPSOU,IFTRAK, + 1 IPSYS,IPHASE,ITPIJ,CXDOOR,TITLE,INITFL,LFORW,LEAKSW,IREBAL, + 2 NGRP,NMAT,NIFIS,NANIS,NLF,NLIN,NFUNL,OPTION,NUN,MAXINR,EPSINR, + 3 MAXOUT,EPSUNK,EPSOUT,IFRITR,IACITR,ILEAK,NREG,NSOUT,MATCOD, + 4 KEYFLX,VOL,REFKEF,NMERG,IMERG) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Driver for Boltzmann equation solvers. Solution of a fixed source +* eigenvalue problem. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPRT print flag. +* IPFLUX pointer to the flux LCM object. +* IPTRK pointer to the tracking LCM object. +* IPMACR pointer to the macrolib LCM object. +* IPFLUP pointer to the unperturbed flux LCM object. +* IPSOU pointer to the GPT fixed source LCM object. +* IFTRAK tracking file unit number. +* IPSYS pointer to the system LCM object (=0 for the method of +* characteristics). +* IPHASE 1 for asm 2 for pij. +* ITPIJ type of collision probability information available: +* =1 scattering modified pij (wij); +* =2 standard pij; +* =3 scattering modified pij+pijk (wij,wijk); +* =4 standard pij+pijk. +* CXDOOR name of the flux solution door. +* TITLE title. +* INITFL flux initialization flag (=0/1/2: uniform flux/LCM/DSA). +* LFORW flag set to .false. to solve an adjoint problem. +* LEAKSW leakage flag (=.true. if leakage is present on the outer +* surface). +* IREBAL flux rebalancing flag (=1: perform rebalancing). +* NGRP number of energy groups. +* NMAT number of mixtures. +* NIFIS number of fissile isotopes. +* NANIS maximum cross section Legendre order. +* NLF number of Legendre orders for the flux. +* NLIN number of polynomial components in flux spatial expansion. +* NFUNL number of spherical harmonics components. +* OPTION type of leakage coefficients: +* 'LKRD' (recover leakage coefficients in Macrolib); +* 'RHS' (recover leakage coefficients in RHS flux object); +* 'B0' (B-0), 'P0' (P-0), 'B1' (B-1), +* 'P1' (P-1), 'B0TR' (B-0 with transport correction) or 'P0TR' +* (P-0 with transport correction). +* NUN number of unknowns per energy group including spherical +* harmonic terms, interface currents and fundamental +* currents. +* MAXINR maximum number of thermal iterations. +* EPSINR thermal iterations epsilon. +* MAXOUT maximum number of outer iterations. +* EPSUNK outer iterations eigenvector epsilon. +* EPSOUT outer iterations eigenvalue epsilon. +* IFRITR number of free iterations in an acceleration cycle. +* IACITR number of accelerated iterations in an acceleration cycle. +* ILEAK method used to include DB2 effect: +* =1 the scattering modified cp matrix is multiplied by PNLR; +* =2 the reduced cp matrix is multiplied by PNL; +* =3 sigs0-db2 approximation; +* =4 albedo approximation; +* =5 Todorova-type isotropic streaming model; +* =6 Ecco-type isotropic streaming model; +* >6 Tibere type anisotropic streaming model. +* NREG number of regions. +* NSOUT number of outer surfaces. +* MATCOD mixture indices. +* KEYFLX index of L-th order flux components in unknown vector. +* VOL volumes. +* REFKEF target effective multiplication factor (K-eff). +* NMERG number of leakage zones. +* IMERG leakage zone index in each material mixture zone. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER CXDOOR*12,TITLE*72,OPTION*4 + TYPE(C_PTR) IPFLUX,IPTRK,IPMACR,IPFLUP,IPSOU,IPSYS + INTEGER IPRT,IFTRAK,IPHASE,ITPIJ,INITFL,IREBAL,NGRP,NMAT, + > NIFIS,NANIS,NLF,NLIN,NFUNL,NUN,MAXINR,MAXOUT, + > IFRITR,IACITR,ILEAK,NREG,NSOUT,MATCOD(NREG), + > KEYFLX(NREG,NLIN,NFUNL),NMERG,IMERG(NMAT) + REAL EPSUNK,EPSINR,VOL(NREG) + LOGICAL LFORW,LEAKSW + DOUBLE PRECISION REFKEF +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6,NSTATE=40,NDIMO=2,ITYPEC=1) + TYPE(C_PTR) JPMACR,KPMACR,JPFLUX,JPFLUP1,JPFLUP2,JPGPT,KPFLUX, + 1 KPGPT,JPSYS,KPSYS + LOGICAL LREBAL + INTEGER ISTATE(NSTATE) + DOUBLE PRECISION AIL,BIL,GAZ + REAL EPSCON(5) + CHARACTER CAN(0:19)*2 +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: SIGT,SIGS0 + REAL, ALLOCATABLE, DIMENSION(:,:) :: FLUXO,SOURO,XSTRC,XSTK + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: XSDIA,XSCHI,XSNUF +*---- +* DATA STATEMENTS +*---- + SAVE CAN + DATA CAN /'00','01','02','03','04','05','06','07','08','09', + > '10','11','12','13','14','15','16','17','18','19'/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(FLUXO(NUN,NGRP),SOURO(NUN,NGRP),XSTRC(0:NMAT,NGRP), + > XSDIA(0:NMAT,0:NANIS,NGRP),XSCHI(0:NMAT,NIFIS,NGRP), + > XSNUF(0:NMAT,NIFIS,NGRP),XSTK(NMAT,NIFIS)) +* + IF(IPRT.GE.3) THEN + WRITE(IUNOUT,6000) + WRITE(IUNOUT,6001) (IREGIO,VOL(IREGIO),MATCOD(IREGIO), + > IREGIO=1,NREG) + ENDIF +*---- +* RECOVER CROSS SECTIONS. +*---- + JPMACR=LCMGID(IPMACR,'GROUP') + DO 100 IGR=1,NGRP + KPMACR=LCMGIL(JPMACR,IGR) + DO 10 IANI=0,NANIS + CALL LCMLEN(KPMACR,'NJJS'//CAN(IANI),ILNLCM,ITYLCM) + IF(ILNLCM.NE.NMAT) THEN + CALL LCMLIB(KPMACR) + CALL XABORT('FLUGPT: FLUX CALCULATION ERROR, SCATTERING'// + > ' MATRIX OF ORDER ANIS ='//CAN(IANI)//' NOT ON LCM') + ENDIF + 10 CONTINUE +*---- +* RECOVER CORRECTED TOTAL AND WITHIN-GROUP SCATTERING CROSS SECTIONS +*---- + JPSYS=LCMGID(IPSYS,'GROUP') + KPSYS=LCMGIL(JPSYS,IGR) + CALL LCMLEN(KPSYS,'DRAGON-TXSC',ILCTX,ITYLCM) + CALL LCMLEN(KPSYS,'DRAGON-S0XSC',ILCS0X,ITYLCM) + IF(ILCTX.NE.NMAT+1) THEN + CALL XABORT('FLUGPT: INVALID LENGTH FOR DRAGON-TXSC.') + ELSE IF(MOD(ILCS0X,NMAT+1).NE.0) THEN + CALL XABORT('FLUGPT: INVALID LENGTH FOR DRAGON-S0XSC.') + ENDIF + NANI_ASM=ILCS0X/(NMAT+1)-1 + ALLOCATE(SIGT(ILCTX),SIGS0(ILCS0X)) + SIGS0(:ILCS0X)=0.0 + CALL LCMGET(KPSYS,'DRAGON-TXSC',SIGT) + CALL LCMGET(KPSYS,'DRAGON-S0XSC',SIGS0) + XSTRC(0:NMAT,IGR)=SIGT(:NMAT+1) + XSDIA(0:NMAT,0:NANIS,IGR)=0.0 + DO IANI=0,MIN(NANIS,NANI_ASM) + DO IMAT=1,NMAT + XSDIA(IMAT,IANI,IGR)=SIGS0(IANI*(NMAT+1)+IMAT+1) + ENDDO + ENDDO + DEALLOCATE(SIGS0,SIGT) + IF(IPRT.GE.3) THEN + WRITE(IUNOUT,6002) IGR + WRITE(IUNOUT,6003) (IMAT,XSTRC(IMAT,IGR), + > XSDIA(IMAT,0,IGR),IMAT=1,NMAT) + ENDIF +*---- +* RECOVER FISSION CROSS SECTIONS +*---- + CALL LCMLEN(KPMACR,'CHI',ILONG,ITYLCM) + IF( ILONG.EQ.0 )THEN + CALL XABORT('FLUGPT: NO FISSION SPECTRA FOUND ON MACROLIB.') + ELSE + CALL LCMGET(KPMACR,'CHI',XSTK) + DO 60 IFIS= 1, NIFIS + XSCHI(0,IFIS,IGR)= 0.0 + DO 50 IMAT= 1, NMAT + XSCHI(IMAT,IFIS,IGR)= XSTK(IMAT,IFIS) + 50 CONTINUE + 60 CONTINUE + CALL LCMGET(KPMACR,'NUSIGF',XSTK) + DO 80 IFIS= 1, NIFIS + XSNUF(0,IFIS,IGR)= 0.0 + DO 70 IMAT= 1, NMAT + XSNUF(IMAT,IFIS,IGR)= XSTK(IMAT,IFIS) + 70 CONTINUE + 80 CONTINUE + ENDIF + IF( IPRT.GT.3 )THEN + WRITE(IUNOUT,6004) (IMAT,XSNUF(IMAT,1,IGR), + > XSCHI(IMAT,1,IGR),IMAT=1,NMAT) + ENDIF + DO 90 IANI=0,NANIS + CALL LCMLEN(KPMACR,'NJJS'//CAN(IANI),ILNLCM,ITYLCM) + IF(ILNLCM.NE.NMAT) THEN + CALL LCMLIB(KPMACR) + CALL XABORT('FLUGPT: FLUX CALCULATION ERROR, '// + > 'SCATTERING MATRIX OF ORDER ANIS ='//CAN(IANI)//' NOT ON LCM') + ENDIF + 90 CONTINUE + 100 CONTINUE +*---- +* GPT FLUX INITIALIZATION +*---- + CALL LCMGET(IPSOU,'STATE-VECTOR',ISTATE) + IF(LFORW) THEN + CALL LCMLEN(IPFLUX,'DLUX',ILINIT,ITYLCM) + ELSE + CALL LCMLEN(IPFLUX,'ADFLUX',ILINIT,ITYLCM) + ENDIF + IF((ILINIT.EQ.0).OR.(INITFL.EQ.0)) THEN + IF(LFORW) THEN + MAXGPT=ISTATE(3) + JPFLUX=LCMLID(IPFLUX,'DFLUX',MAXGPT) + ELSE + MAXGPT=ISTATE(4) + JPFLUX=LCMLID(IPFLUX,'ADFLUX',MAXGPT) + ENDIF + ENDIF +*---- +* MAIN LOOP OVER EIGENVALUE FIXED SOURCE SOLUTIONS. +*---- + CALL LCMGET(IPFLUP,'STATE-VECTOR',ISTATE) + IF(ISTATE(3).NE.11) CALL XABORT('FLUGPT: MISSING UNPERTURBED DIR' + 1 //'ECT AND/OR ADJOINT FLUXES.') + JPFLUP1=LCMGID(IPFLUP,'FLUX') + JPFLUP2=LCMGID(IPFLUP,'AFLUX') + IF(LFORW) THEN + JPGPT=LCMGID(IPSOU,'DSOUR') + ELSE + JPGPT=LCMGID(IPSOU,'ASOUR') + ENDIF + DO 1000 IGPT=1,MAXGPT + CALL LCMLEL(JPGPT,IGPT,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 1000 + IF(IPRT.GT.0) THEN + WRITE(IUNOUT,'(1X,29(1H-)/25H FLUGPT: GPT EQUATION NB.,I5/ + 1 1X,29(1H-))') IGPT + ENDIF + IF((ILINIT.EQ.0).OR.(INITFL.EQ.0)) THEN + KPFLUX=LCMLIL(JPFLUX,IGPT,NGRP) + DO 120 IGR=1,NGRP + FLUXO(:NUN,IGR)=0.0 + DO 110 IREGIO=1,NREG + IND=KEYFLX(IREGIO,1,1) + IF(IND.GT.0) FLUXO(IND,IGR)=1.0 + 110 CONTINUE + IF(LFORW) THEN + CALL LCMPDL(KPFLUX,IGR,NUN,2,FLUXO(1,IGR)) + ELSE + CALL LCMPDL(KPFLUX,NGRP-IGR+1,NUN,2,FLUXO(1,IGR)) + ENDIF + 120 CONTINUE + ENDIF +*---- +* RECOVER UNPERTURBED FLUXES AND VALIDATION OF THE FIXED SOURCE TERM. +*---- + IF(LFORW) THEN + KPGPT=LCMGIL(JPGPT,IGPT) + DO 130 IGR=1,NGRP + CALL LCMGDL(JPFLUP2,IGR,FLUXO(1,IGR)) + CALL LCMGDL(KPGPT,IGR,SOURO(1,IGR)) + 130 CONTINUE + ELSE + KPGPT=LCMGIL(JPGPT,IGPT) + DO 140 IGR=1,NGRP + CALL LCMGDL(JPFLUP1,IGR,FLUXO(1,IGR)) + CALL LCMGDL(KPGPT,IGR,SOURO(1,IGR)) + 140 CONTINUE + ENDIF + AIL=0.0D0 + BIL=0.0D0 + DO 155 IGR=1,NGRP + DO 150 IUN=1,NUN + GAZ=FLUXO(IUN,IGR)*SOURO(IUN,IGR) + AIL=AIL+GAZ + BIL=BIL+GAZ**2 + 150 CONTINUE + 155 CONTINUE + IF(REAL(NUN)*SQRT(BIL).LT.EPSINR) GO TO 1000 + GAZ=ABS(AIL)/SQRT(REAL(NUN)*BIL) + IF(GAZ.GT.EPSINR) CALL XABORT('FLUGPT: THE SOURCE TERM IS NOT OR' + 1 //'THOGONAL TO THE ADJOINT REFERENCE FLUX.') +* + IF (CXDOOR.EQ.'MCCG') THEN + CALL LCMLEN(IPTRK,'KEYCUR$MCCG',ICREB,ITYLCM) + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + IF ((ICREB.GT.0).AND.(ISTATE(24).EQ.0)) THEN + LREBAL=(IREBAL.EQ.1) + ELSE + LREBAL=(IREBAL.EQ.1).AND.(.NOT.LEAKSW) + ENDIF + ELSE + LREBAL=(IREBAL.EQ.1).AND.(.NOT.LEAKSW) + ENDIF + CALL FLU2DR(IPRT,IPMACR,IPFLUX,IPSYS,IPTRK,IPFLUP,IPSOU,IGPT, + 1 IFTRAK,CXDOOR,TITLE,NUN,NREG,NSOUT,NANIS,NLF,NFUNL,NGRP,NMAT, + 2 NIFIS,LFORW,LEAKSW,MAXINR,EPSINR,MAXOUT,EPSUNK,EPSOUT,IFRITR, + 3 IACITR,ITYPEC,IPHASE,ITPIJ,ILEAK,OPTION,REFKEF,MATCOD,KEYFLX, + 4 VOL,XSTRC,XSDIA,XSNUF,XSCHI,LREBAL,INITFL,NMERG,IMERG) + 1000 CONTINUE +*---- +* END OF MAIN LOOP OVER EIGENVALUE FIXED SOURCE SOLUTIONS. +*---- + ISTATE(:NSTATE)=0 + ISTATE(1)=NGRP + ISTATE(2)=NUN + IF(LFORW) THEN + ISTATE(3)=100 + ELSE + ISTATE(3)=1000 + ENDIF + ISTATE(4)=0 + ISTATE(5)=MAXGPT + ISTATE(6)=ITYPEC + ISTATE(7)=ILEAK + ISTATE(8)=IFRITR + ISTATE(9)=IACITR + ISTATE(10)=IREBAL + ISTATE(11)=MAXINR + ISTATE(12)=MAXOUT + ISTATE(17)=NMAT + ISTATE(18)=NMERG + CALL LCMPUT(IPFLUX,'STATE-VECTOR',NSTATE,1,ISTATE) + EPSCON(1)=EPSINR + EPSCON(2)=EPSUNK + EPSCON(3)=EPSOUT + EPSCON(4:5)=0.0 + CALL LCMPUT(IPFLUX,'EPS-CONVERGE',5,2,EPSCON) + CALL LCMPTC(IPFLUX,'OPTION',4,OPTION) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XSTK,XSNUF,XSCHI,XSDIA,XSTRC,SOURO,FLUXO) + RETURN +*---- +* FORMATS +*---- + 6000 FORMAT(//30X,' EDITION REGION/VOL/MIXTURE '// + >3(5X,'REGION',5X,'VOL ',5X,'MIXTURE')/) + 6001 FORMAT(1P,3(5X,I4,4X,E12.5,4X,I4,4X)) + 6002 FORMAT(//30X,' G R O U P : ',I5// + >30X,' TOTAL MACROSCOPIC CROSS SECTIONS PER MIXTURE '/) + 6003 FORMAT(3(1X,'MIXTURE',4X,'NTOT0',11X,'SIGW',3X)/ + >1P,3(1X,I4,3X,E12.5,3X,E12.5)) + 6004 FORMAT(3(1X,'MIXTURE',4X,'NUSIGF',11X,'CHI ',3X)/ + >1P,3(1X,I4,3X,E12.5,3X,E12.5)) + END diff --git a/Dragon/src/FLUKEF.f b/Dragon/src/FLUKEF.f new file mode 100644 index 0000000..329d731 --- /dev/null +++ b/Dragon/src/FLUKEF.f @@ -0,0 +1,194 @@ +*DECK FLUKEF + SUBROUTINE FLUKEF(IPRT,IPMACR,NGRP,NREG,NUNKNO,NMAT,NIFIS,NANIS, + 1 MATCOD,VOL,KEYFLX,XSTRC,XSDIA,XSNUF,XSCHI,NMERG,IMERG,DIFHET, + 2 FLUX,B2,ILEAK,LEAKSW,OLDBIL,AKEFF,AFLNOR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the effective multiplication factor. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPRT print flag. +* IPMACR pointer to the macrolib LCM object. +* NGRP number of energy groups. +* NREG number of regions. +* NUNKNO number of unknowns per energy group including spherical +* harmonic terms, interface currents and fundamental +* currents. +* NMAT number of mixtures. +* NIFIS number of fissile isotopes. +* NANIS maximum cross section Legendre order. +* MATCOD mixture indices. +* VOL volumes. +* KEYFLX index of region flux components in unknown vector. +* XSTRC transport-corrected macroscopic total cross sections. +* XSDIA transport-corrected macroscopic within-group scattering cross +* sections. +* XSNUF nu*macroscopic fission cross sections. +* XSCHI fission spectrum. +* NMERG number of leakage zones. +* IMERG leakage zone index in each material mixture zone. +* DIFHET heterogeneous leakage coefficients. +* FLUX neutron flux. +* B2 directionnal bucklings. +* ILEAK method used to include DB2 effect: +* <5 uniform DB2 model; +* =5 Todorova-type isotropic streaming model; +* =6 Ecco-type isotropic streaming model; +* >6 Tibere anisotropic streaming model. +* LEAKSW leakage flag (=.true. if leakage is present on the outer +* surface). +* +*Parameters: input/output +* OLDBIL previous norm of the flux on input and +* new norm of the flux at output. +* +*Parameters: output +* AKEFF effective multiplication factor. +* AFLNOR flux normalization factor. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMACR + INTEGER IPRT,NGRP,NREG,NUNKNO,NMAT,NIFIS,NANIS,MATCOD(NREG), + 1 KEYFLX(NREG),NMERG,IMERG(NMAT),ILEAK + REAL VOL(NREG),XSTRC(0:NMAT,NGRP),XSDIA(0:NMAT,0:NANIS,NGRP), + 1 XSNUF(0:NMAT,NIFIS,NGRP),XSCHI(0:NMAT,NIFIS,NGRP), + 2 DIFHET(NMERG,NGRP),FLUX(NUNKNO,NGRP),B2(4) + DOUBLE PRECISION OLDBIL,AKEFF,AFLNOR + LOGICAL LEAKSW +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPMACR,KPMACR + DOUBLE PRECISION LOSS,SUMCHI,PROD,FISONE,PHIC,FISOUR,AKINV, + 1 DZERO,DONE + PARAMETER (DZERO=0.0D0, DONE=1.0D0) + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) :: XSCAT +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NJJ(0:NMAT),IJJ(0:NMAT),IPOS(0:NMAT)) + ALLOCATE(XSCAT(0:NMAT*NGRP)) +* + FISOUR=DZERO + SUMCHI=DZERO + LOSS=DZERO + AKINV=DZERO + JPMACR=LCMGID(IPMACR,'GROUP') + DO 40 IGRP=1,NGRP + KPMACR=LCMGIL(JPMACR,IGRP) + DO 15 IREG=1,NREG + IND=KEYFLX(IREG) + IF(IND.EQ.0) GO TO 15 + IBM=MATCOD(IREG) + IF(IBM.EQ.0) GO TO 15 + PHIC=FLUX(IND,IGRP)*VOL(IREG) + LOSS=LOSS+XSTRC(IBM,IGRP)*PHIC + IF((ILEAK.GE.1).AND.(ILEAK.LE.5)) THEN + INM=IMERG(IBM) + IF(INM.GT.0) LOSS=LOSS+B2(4)*DIFHET(INM,IGRP)*PHIC + ELSE IF(ILEAK.EQ.6) THEN + LOSS=LOSS+B2(4)*FLUX(NUNKNO/2+IND,IGRP)*VOL(IREG) + ELSE IF(ILEAK.GE.7) THEN + LOSS=LOSS+B2(1)*FLUX(NUNKNO/4+IND,IGRP)*VOL(IREG) + 1 +B2(2)*FLUX(NUNKNO/2+IND,IGRP)*VOL(IREG) + 2 +B2(3)*FLUX(3*NUNKNO/4+IND,IGRP)*VOL(IREG) + ENDIF + DO 10 IFIS=1,NIFIS + FISOUR=FISOUR+XSNUF(IBM,IFIS,IGRP)*PHIC + AKINV=AKINV+XSNUF(IBM,IFIS,IGRP)*PHIC + 10 CONTINUE + 15 CONTINUE +* + CALL LCMGET(KPMACR,'NJJS00',NJJ(1)) + CALL LCMGET(KPMACR,'IJJS00',IJJ(1)) + CALL LCMGET(KPMACR,'IPOS00',IPOS(1)) + CALL LCMGET(KPMACR,'SCAT00',XSCAT(1)) + DO 30 IREG=1,NREG + IBM=MATCOD(IREG) + IF(IBM.GT.0) THEN + IND=KEYFLX(IREG) + JGRP=IJJ(IBM) + DO 20 JND=1,NJJ(IBM) + IF(JGRP.EQ.IGRP) THEN + LOSS=LOSS-XSDIA(IBM,0,IGRP)*FLUX(IND,IGRP)*VOL(IREG) + ELSE + LOSS=LOSS-XSCAT(IPOS(IBM)+JND-1)*FLUX(IND,JGRP)*VOL(IREG) + ENDIF + JGRP=JGRP-1 + 20 CONTINUE + ENDIF + 30 CONTINUE + 40 CONTINUE +* + IF(AKINV.NE.0.0) THEN + AKINV=DONE/AKINV + DO 70 IREG=1,NREG + IND=KEYFLX(IREG) + IF(IND.EQ.0) GO TO 70 + IBM=MATCOD(IREG) + DO 65 IFIS=1,NIFIS + FISONE=DZERO + DO 50 IGRP=1,NGRP + FISONE=FISONE+XSNUF(IBM,IFIS,IGRP)*FLUX(IND,IGRP) + 50 CONTINUE + DO 60 IGRP=1,NGRP + SUMCHI=SUMCHI+AKINV*XSCHI(IBM,IFIS,IGRP)*FISONE*VOL(IREG) + 60 CONTINUE + 65 CONTINUE + 70 CONTINUE + ENDIF +* + PROD=SUMCHI*FISOUR + IF(PROD.GT.DZERO) THEN + AFLNOR=DONE/PROD + ELSE + AFLNOR=DONE + ENDIF + IF(LEAKSW) THEN + IF(OLDBIL.GT.DZERO) THEN + AKEFF=PROD/OLDBIL + ELSE + AKEFF=PROD + ENDIF + ELSE + IF(LOSS.GT.DZERO) THEN + AKEFF=PROD/LOSS + AFLNOR=AFLNOR*LOSS + ELSE + AKEFF=PROD + ENDIF + ENDIF + OLDBIL=PROD*AFLNOR + IF(IPRT.GT.2) THEN + WRITE(6,*) + WRITE(6,*) ' ************ OLDBIL=',OLDBIL + WRITE(6,*) ' ************ PROD =',PROD + WRITE(6,*) ' ************ LOSS =',LOSS + WRITE(6,*) ' ************ AFLNOR=',AFLNOR + WRITE(6,*) ' ************ AKEFF =',AKEFF + WRITE(6,*) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XSCAT) + DEALLOCATE(IPOS,IJJ,NJJ) + RETURN + END diff --git a/Dragon/src/FLULPN.f b/Dragon/src/FLULPN.f new file mode 100644 index 0000000..7e2275c --- /dev/null +++ b/Dragon/src/FLULPN.f @@ -0,0 +1,227 @@ +*DECK FLULPN + SUBROUTINE FLULPN(IPMACR,NUNKNO,OPTION,TYPE,NGRP,NREG,NMAT, + 1 VOL,MATCOD,NMERG,IMERG,KEYFLX,FLUX,B2,IMPX,DIFHET,DHOM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of heterogeneous leakage coefficients using the Todorova +* approximation. +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMACR pointer to the macrolib LCM object (L_MACROLIB signature). +* NUNKNO number of flux/current unknowns. +* OPTION type of leakage coefficients; can be 'P0' (P-0), 'P1' (P-1), +* 'P0TR' (P-0 with transport correction). +* TYPE type of buckling iteration. +* Can be 'DIFF' (do a P0 calculation of DIFHET and exit); +* other (do another type of calculation). +* NGRP number of groups. +* NREG number of volumes. +* NMAT number of material mixtures. +* VOL volumes. +* MATCOD mixture number of each volume. +* NMERG number of leakage zones. +* IMERG leakage zone index in each material mixture zone. +* KEYFLX position of each flux in the unknown vector. +* FLUX direct unknown vector. +* B2 buckling. +* IMPX print flag. +* +*Parameters: output +* DIFHET heterogeneous diffusion coefficients. +* DHOM homogeneous diffusion coefficients. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER*4 OPTION,TYPE + TYPE(C_PTR) IPMACR + INTEGER NUNKNO,NGRP,NREG,NMAT,MATCOD(NREG),NMERG,IMERG(NMAT), + 1 KEYFLX(NREG),IMPX + REAL VOL(NREG),FLUX(NUNKNO,NGRP),B2,DIFHET(NMERG,NGRP),DHOM(NGRP) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPMACR,KPMACR + CHARACTER HSMG*131 + DOUBLE PRECISION B1GAMA,DDELN1,DDELN2,DDELD1,B2HOM,ST2,STR,GAMMA +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) :: WORK + REAL, ALLOCATABLE, DIMENSION(:,:) :: ST,FLXIN + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT1 + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: STOD +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(FLXIN(NMAT,NGRP),ST(NMAT,NGRP),SCAT1(NMAT,NGRP,NGRP)) +*---- +* INITIALIZATION +*---- + IF((IMPX.GT.0).AND.(TYPE.EQ.'DIFF')) THEN + WRITE (6,100) + ELSE IF(IMPX.GT.0) THEN + WRITE (6,110) OPTION,TYPE,B2 + ENDIF + ST(:NMAT,:NGRP)=0.0 + SCAT1(:NMAT,:NGRP,:NGRP)=0.0 +*---- +* RECOVER MACROSCOPIC CROSS SECTIONS +*---- + ALLOCATE(IJJ(NMAT),NJJ(NMAT),IPOS(NMAT),WORK(NMAT*NGRP)) + JPMACR=LCMGID(IPMACR,'GROUP') + DO IGR=1,NGRP + KPMACR=LCMGIL(JPMACR,IGR) + CALL LCMGET(KPMACR,'NTOT0',ST(1,IGR)) + CALL LCMLEN(KPMACR,'SCAT01',ILONG,ITYLCM) + IF((ILONG.NE.0).AND.(OPTION.NE.'P0').AND.(OPTION.NE.'B0')) THEN + CALL LCMGET(KPMACR,'IJJS01',IJJ) + CALL LCMGET(KPMACR,'NJJS01',NJJ) + CALL LCMGET(KPMACR,'IPOS01',IPOS) + CALL LCMGET(KPMACR,'SCAT01',WORK) + DO IBM=1,NMAT + IPO=IPOS(IBM) + DO JGR=IJJ(IBM),IJJ(IBM)-NJJ(IBM)+1,-1 + SCAT1(IBM,IGR,JGR)=WORK(IPO) ! IGR <-- JGR + IPO=IPO+1 + ENDDO + ENDDO + ENDIF + ENDDO + DEALLOCATE(WORK,IPOS,NJJ,IJJ) +*---- +* RECOVER INTEGRATED FLUX +*---- + FLXIN(:NMAT,:NGRP)=0.0 + DO IGR=1,NGRP + DO IBM=1,NMAT + DO I=1,NREG + IND=KEYFLX(I) + IF((MATCOD(I).EQ.IBM).AND.(IND.GT.0)) THEN + FLXIN(IBM,IGR)=FLXIN(IBM,IGR)+FLUX(IND,IGR)*VOL(I) + ENDIF + ENDDO + ENDDO + ENDDO + IF((OPTION.EQ.'LKRD').OR.(OPTION.EQ.'RHS')) GO TO 10 +*---- +* MAIN LOOP OVER LEAKAGE ZONES +*---- + B2HOM=DBLE(B2) + GAMMA=1.0D0 + DO INM=1,NMERG + IF((OPTION.EQ.'P0').OR.(OPTION.EQ.'B0')) THEN +* P0 or B0 approximation + DO IGR=1,NGRP + DDELN1=0.D0 + DDELD1=0.D0 + DO IBM=1,NMAT + IF(IMERG(IBM).EQ.INM) THEN + DDELN1=DDELN1+ST(IBM,IGR)*FLXIN(IBM,IGR) + DDELD1=DDELD1+FLXIN(IBM,IGR) + ENDIF + ENDDO + ST2=DDELN1/DDELD1 + IF(OPTION.EQ.'B0') GAMMA=B1GAMA(2,B2HOM,ST2) + DIFHET(INM,IGR)=REAL(1.0D0/(3.0D0*GAMMA*ST2)) + ENDDO + ELSE IF((OPTION.EQ.'P0TR').OR.(OPTION.EQ.'B0TR').OR. + 1 (TYPE.EQ.'DIFF')) THEN +* Outscatter approximation + DO IGR=1,NGRP + DDELN1=0.D0 + DDELN2=0.D0 + DDELD1=0.D0 + DO IBM=1,NMAT + IF(IMERG(IBM).EQ.INM) THEN + DDELN1=DDELN1+ST(IBM,IGR)*FLXIN(IBM,IGR) + DO JGR=1,NGRP + DDELN2=DDELN2+SCAT1(IBM,JGR,IGR)*FLXIN(IBM,IGR) + ENDDO + DDELD1=DDELD1+FLXIN(IBM,IGR) + ENDIF + ENDDO + ST2=DDELN1/DDELD1 + IF(OPTION.EQ.'B0TR') GAMMA=B1GAMA(2,B2HOM,ST2) + STR=(GAMMA*DDELN1-DDELN2)/DDELD1 + DIFHET(INM,IGR)=REAL(1.0D0/(3.0D0*STR)) + ENDDO + ELSE IF((OPTION.EQ.'P1').OR.(OPTION.EQ.'B1')) THEN +* Inscatter approximation + ALLOCATE(STOD(NGRP,NGRP+1)) + STOD(:NGRP,:NGRP+1)=0.0D0 + DO IGR=1,NGRP + IF(OPTION.EQ.'B1') THEN + DDELN1=0.D0 + DDELD1=0.D0 + DO IBM=1,NMAT + IF(IMERG(IBM).EQ.INM) THEN + DDELN1=DDELN1+ST(IBM,IGR)*FLXIN(IBM,IGR) + DDELD1=DDELD1+FLXIN(IBM,IGR) + ENDIF + ENDDO + ST2=DDELN1/DDELD1 + GAMMA=B1GAMA(2,B2HOM,ST2) + ENDIF + DO IBM=1,NMAT + IF(IMERG(IBM).EQ.INM) THEN + STOD(IGR,IGR)=STOD(IGR,IGR)+GAMMA*ST(IBM,IGR)* + 1 FLXIN(IBM,IGR) + DO JGR=1,NGRP + STOD(IGR,JGR)=STOD(IGR,JGR)-SCAT1(IBM,IGR,JGR)* + 1 FLXIN(IBM,JGR) + ENDDO + STOD(IGR,NGRP+1)=STOD(IGR,NGRP+1)+FLXIN(IBM,IGR)/3.0D0 + ENDIF + ENDDO + ENDDO + CALL ALSBD(NGRP,1,STOD,IER,NGRP) + IF(IER.NE.0) CALL XABORT('FLULPN: SINGULAR MATRIX.') + DO IGR=1,NGRP + DIFHET(INM,IGR)=REAL(STOD(IGR,NGRP+1)) + ENDDO + DEALLOCATE(STOD) + ELSE + WRITE(HSMG,'(15HFLULPN: OPTION ,A,23H IS INVALID WITH TODORO, + 1 17HVA APPROXIMATION.)') OPTION + CALL XABORT(HSMG) + ENDIF + ENDDO +*---- +* COMPUTE THE HOMOGENEOUS LEAKAGE COEFFICIENTS +*---- + 10 DO IGR=1,NGRP + DHOM(IGR)=0.0 + FLTOT=0.0 + DO IBM=1,NMAT + INM=IMERG(IBM) + DHOM(IGR)=DHOM(IGR)+FLXIN(IBM,IGR)*DIFHET(INM,IGR) + FLTOT=FLTOT+FLXIN(IBM,IGR) + ENDDO + DHOM(IGR)=DHOM(IGR)/FLTOT + ENDDO +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SCAT1,ST,FLXIN) + RETURN +* + 100 FORMAT(/54H FLULPN: OUTSCATTER DIFFUSION COEFFICIENT CALCULATION.) + 110 FORMAT(/21H FLULPN: SOLUTION OF ,A4,21H EQUATIONS WITH TYPE ,A4, + 1 10H BUCKLING=,1P,E12.4) + END diff --git a/Dragon/src/FLUSOU.f90 b/Dragon/src/FLUSOU.f90 new file mode 100644 index 0000000..680956e --- /dev/null +++ b/Dragon/src/FLUSOU.f90 @@ -0,0 +1,202 @@ +SUBROUTINE FLUSOU(CDOOR,HLEAK,MAX1,IG,IPTRK,KPMACR,NMAT,NANIS,NUN,NGRP, & + & FUNKNO,SUNKNO) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! compute the out-of-group scattering source in general cases. + ! + !Copyright: + ! Copyright (C) 2025 Ecole Polytechnique de Montreal + ! This library is free software; you can redistribute it and/or + ! modify it under the terms of the GNU Lesser General Public + ! License as published by the Free Software Foundation; either + ! version 2.1 of the License, or (at your option) any later version + ! + !Author(s): A. Hebert + ! + !Parameters: input + ! CDOOR name of the geometry/solution operator. + ! HLEAK type of model (=' ': general; ='ECCO'; ='TIBERE'). + ! MAX1 first dimension of FUNKNO and SOURCE arrays. + ! IG secondary group. + ! IPTRK pointer to the tracking (L_TRACK signature). + ! KPMACR pointer to the secondary-group related macrolib information. + ! NMAT number of mixtures in the macrolib. + ! NANIS number of Legendre components in the macrolib. + ! NUN total number of flux or source unknowns. + ! NGRP number of energy groups. + ! FUNKNO unknown vector. + ! + !Parameters: output + ! SUNKNO source vector. + !--------------------------------------------------------------------- + ! + USE GANLIB + !---- + ! SUBROUTINE ARGUMENTS + !---- + CHARACTER(LEN=12), INTENT(IN) :: CDOOR + CHARACTER(LEN=6), INTENT(IN) :: HLEAK + TYPE(C_PTR), INTENT(IN) :: IPTRK,KPMACR + INTEGER, INTENT(IN) :: MAX1,IG,NMAT,NANIS,NUN,NGRP + REAL, DIMENSION(MAX1,NGRP), INTENT(IN) :: FUNKNO + REAL, DIMENSION(MAX1,NGRP), INTENT(INOUT) :: SUNKNO + !---- + ! LOCAL VARIABLES + !---- + INTEGER, PARAMETER :: NSTATE=40 + INTEGER, DIMENSION(NSTATE) :: ISTATE + INTEGER, DIMENSION(3) :: INDD + CHARACTER CAN(0:19)*2 + !---- + ! ALLOCATABLE ARRAYS + !---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MATCOD + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: KEYFLX + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) :: XSCAT + !---- + ! DATA STATEMENTS + !---- + DATA CAN /'00','01','02','03','04','05','06','07','08','09', & + & '10','11','12','13','14','15','16','17','18','19'/ + !---- + ! SCRATCH STORAGE ALLOCATION + !---- + ALLOCATE(IJJ(0:NMAT),NJJ(0:NMAT),IPOS(0:NMAT)) + ALLOCATE(XSCAT(0:NMAT*NGRP)) + !---- + ! RECOVER TRACKING PARAMETERS + ! NFUNL: number of spherical harmonics components used to expand the + ! flux and the sources. + ! NANIS_TRK: number of components in the angular expansion of the flux + !---- + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + NREG=ISTATE(1) + IF(ISTATE(2).GT.NUN) CALL XABORT('FLUSOU: WRONG NUN.') + IF(ISTATE(4).GT.NMAT) CALL XABORT('FLUSOU: WRONG NMAT.') + NDIM=0 + NLIN=1 + NFUNL=1 + NANIS_TRK=1 + IF(CDOOR.EQ.'MCCG') THEN + NANIS_TRK=ISTATE(6) + NDIM=ISTATE(16) + CALL LCMGET(IPTRK,'MCCG-STATE',ISTATE) + NFUNL=ISTATE(19) + NLIN=ISTATE(20) + ENDIF + ALLOCATE(MATCOD(NREG),KEYFLX(NREG,NLIN,NFUNL)) + KEYFLX(:NREG,:NLIN,:NFUNL)=0 + CALL LCMLEN(IPTRK,'MATCOD',ILNLCM,ITYLCM) + IF(ILNLCM.NE.NREG) CALL XABORT('FLUSOU: INCOMPATIBLE NUMBER OF REGIONS.') + CALL LCMGET(IPTRK,'MATCOD',MATCOD) + IF(CDOOR.EQ.'MCCG') THEN + CALL LCMGET(IPTRK,'KEYFLX$ANIS',KEYFLX) + ELSE + CALL LCMGET(IPTRK,'KEYFLX',KEYFLX) + ENDIF + !---- + ! COMPUTE THE SCATTERING SOURCE IN THE GENERAL CASE + !---- + IF(HLEAK.EQ.' ') THEN + NIAL=MIN(NFUNL-1,NANIS,NANIS_TRK-1) + DO IAL=0,NIAL + FACT=REAL(2*IAL+1) + CALL LCMGET(KPMACR,'NJJS'//CAN(IAL),NJJ(1)) + CALL LCMGET(KPMACR,'IJJS'//CAN(IAL),IJJ(1)) + CALL LCMGET(KPMACR,'IPOS'//CAN(IAL),IPOS(1)) + CALL LCMGET(KPMACR,'SCAT'//CAN(IAL),XSCAT(1)) + DO IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) CYCLE + DO IAM=0,NIAL + DO IE=1,NLIN + IND=0 + IF(NDIM.EQ.3) THEN + IF(1+IAL*NANIS_TRK+IAM.GT.NFUNL) CALL XABORT('FLUSOU: KEYFLX OVERFLOW(1)') + IND=KEYFLX(IR,IE,1+IAL*NANIS_TRK+IAM) + ELSE IF((NDIM.EQ.2).AND.(IAM.LE.IAL)) THEN + IF(1+IAL*(IAL+1)/2+IAM.GT.NFUNL) CALL XABORT('FLUSOU: KEYFLX OVERFLOW(2)') + IND=KEYFLX(IR,IE,1+IAL*(IAL+1)/2+IAM) + ELSE IF(IAM.EQ.IAL) THEN + IND=KEYFLX(IR,IE,1+IAL) + ENDIF + IF(IND.EQ.0) THEN + CYCLE + ELSE IF(IND.GT.NUN) THEN + CALL XABORT('FLUSOU: NUN OVERFLOW.') + ENDIF + JG=IJJ(IBM) + DO JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + SUNKNO(IND,IG)=SUNKNO(IND,IG)+FACT*XSCAT(IPOS(IBM)+JND-1)* & + & FUNKNO(IND,JG) + ENDIF + JG=JG-1 + ENDDO ! JND + ENDDO ! IE + ENDDO ! IAM + ENDDO ! IR + ENDDO + !---- + ! COMPUTE THE SCATTERING SOURCE WITH ECCO MODEL + !---- + ELSE IF(HLEAK.EQ.'ECCO') THEN + CALL LCMGET(KPMACR,'NJJS01',NJJ(1)) + CALL LCMGET(KPMACR,'IJJS01',IJJ(1)) + CALL LCMGET(KPMACR,'IPOS01',IPOS(1)) + CALL LCMGET(KPMACR,'SCAT01',XSCAT(1)) + DO IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) CYCLE + DO IE=1,NLIN + IND=MAX1/2+KEYFLX(IR,IE,1) + JG=IJJ(IBM) + DO JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + SUNKNO(IND,IG)=SUNKNO(IND,IG)+XSCAT(IPOS(IBM)+JND-1)* & + & FUNKNO(IND,JG) + ENDIF + JG=JG-1 + ENDDO ! JND + ENDDO ! IE + ENDDO ! IR + !---- + ! COMPUTE THE SCATTERING SOURCE WITH TIBERE MODEL + !---- + ELSE IF(HLEAK.EQ.'TIBERE') THEN + CALL LCMGET(KPMACR,'NJJS01',NJJ(1)) + CALL LCMGET(KPMACR,'IJJS01',IJJ(1)) + CALL LCMGET(KPMACR,'IPOS01',IPOS(1)) + CALL LCMGET(KPMACR,'SCAT01',XSCAT(1)) + DO IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) CYCLE + DO IE=1,NLIN + INDD(1)=MAX1/4+KEYFLX(IR,IE,1) + INDD(2)=MAX1/2+KEYFLX(IR,IE,1) + INDD(3)=3*MAX1/4+KEYFLX(IR,IE,1) + DO IDIR=1,3 + IND=INDD(IDIR) + JG=IJJ(IBM) + DO JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + SUNKNO(IND,IG)=SUNKNO(IND,IG)+XSCAT(IPOS(IBM)+JND-1)* & + & FUNKNO(IND,JG) + ENDIF + JG=JG-1 + ENDDO ! IND + ENDDO ! IDIR + ENDDO ! IE + ENDDO ! IR + ENDIF + !---- + ! SCRATCH STORAGE DEALLOCATION + !---- + DEALLOCATE(KEYFLX,MATCOD) + DEALLOCATE(XSCAT) + DEALLOCATE(IPOS,NJJ,IJJ) + RETURN +END SUBROUTINE FLUSOU diff --git a/Dragon/src/FMAC.f b/Dragon/src/FMAC.f new file mode 100644 index 0000000..40c6723 --- /dev/null +++ b/Dragon/src/FMAC.f @@ -0,0 +1,259 @@ +*DECK FMAC + SUBROUTINE FMAC(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Convert a macroscopic cross section file in ascii FMAC-M format +* towards Version5 macrolib format. +* +*Copyright: +* Copyright (C) 2020 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1) create type(L_MACROLIB); +* HENTRY(2) read-only ascii file containing FMAC-M data. +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPMACR + PARAMETER(NSTATE=40,IOUT=6,MAS=38) + CHARACTER TEXT12*12,TEXT18*18,HSIGN*12,TEX(50)*6,HPART*1 + INTEGER ISTATE(NSTATE),N(MAS),IZA(40) + DOUBLE PRECISION DFLOTT +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NGPRT,NPMIN,NPMAX,NANIS, + 1 MUFIS + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NWA + REAL, ALLOCATABLE, DIMENSION(:,:) :: H2 + CHARACTER(LEN=1), ALLOCATABLE, DIMENSION(:) :: HNPRT +*---- +* PARAMETER VALIDATION +*---- + IF(NENTRY.NE.2) CALL XABORT('FMAC: TWO PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('FMAC: LCM' + 1 //' OBJECT EXPECTED AT LHS.') + IF(JENTRY(1).NE.0) CALL XABORT('FMAC: ENTRY IN CREATE MODE EXPEC' + 1 //'TED.') + IPMACR=KENTRY(1) + HSIGN='L_MACROLIB' + CALL LCMPTC(IPMACR,'SIGNATURE',12,HSIGN) +*---- +* RECOVER FMAC-M FILE +*---- + TEXT12=HENTRY(2) + IF(IENTRY(2).NE.4) CALL XABORT('FMAC: ASCII FILE NAMED '//TEXT12 + 1 //' EXPECTED AT LHS.') + IF(JENTRY(2).NE.2) CALL XABORT('FMAC: ASCII FILE IN READ-ONLY MO' + 1 //'DE EXPECTED.') + LIN=FILUNIT(KENTRY(2)) +*---- +* READ THE INPUT DATA +*---- + IMPX=1 + HPART=' ' + 10 CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('FMAC: CHARACTER DATA EXPECTED.') + IF(TEXT12.EQ.'EDIT') THEN +* READ THE PRINT INDEX. + CALL REDGET(INDIC,IMPX,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('FMAC: INTEGER DATA EXPECTED.') + ELSE IF(TEXT12.EQ.'PARTICLE') THEN +* READ THE PARTICLE TYPE ('N', 'G', 'C', 'P') + CALL REDGET(INDIC,NITMA,FLOTT,HPART,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('FMAC: CHARACTER DATA EXPECTED.') + CALL LCMPTC(IPMACR,'PARTICLE',1,HPART) + ELSE IF(TEXT12.EQ.';') THEN + GO TO 20 + ELSE + CALL XABORT('FMAC: '//TEXT12//' IS AN INVALID KEYWORD.') + ENDIF + GO TO 10 +*---- +* MACROLIB INITIALIZATION +*---- + 20 IPART=0 + NANISO=0 + ITRANC=0 + NALBP=0 + NSTEP=0 + IDF=0 +*---- +* PROCESS THE FMAC FILE FOR 1D COUPLED CROSS-SECTION DATA +*---- + READ(LIN,'(A18,I12)') TEXT18,IVERS + IF(IMPX.GT.0) WRITE(IOUT,1002) TEXT18,IVERS + READ(LIN,'(A72)') + READ(LIN,'(A30)') + READ(LIN,'(6I12)') NTYPE,(N(I),I=1,9) + READ(LIN,'(12A6)')(TEX(I),I=1,NTYPE) + IF(TEX(1).NE.'NGCAP ') THEN + CALL XABORT('FMAC: INVALID DATA TYPE='//TEX(1)//'.') + ENDIF + READ(LIN,'(6I12)') (IZA(I),I=1,40) + WRITE(IOUT,1101) (IZA(I),I=1,40) + NGP=IZA(1) + NPART=IZA(2) + NGXI=IZA(3) + NGXIF=IZA(4) + NDELG=IZA(5) + NEDIT=IZA(8) + KLEIN=IZA(10) + IADJ=IZA(12) + NUCL=IZA(13) + NK=IZA(15) + NUFIS=IZA(16) + MASM3=IZA(17) + NWO=IZA(20) + MPOINT=IZA(21) + ALLOCATE(NGPRT(NPART),HNPRT(NPART),NPMIN(NGP),NPMAX(NGP), + 1 NANIS(NGP),MUFIS(NUFIS)) + NPMIN=1 + NPMAX=NGP + NANIS=NWO + IF(MASM3.GT.38) CALL XABORT('FMAC: MASM3 OVERFLOW.') + READ(LIN,'(6I12)')(N(I),I=1,MASM3) + CALL FMAC01(IPMACR,IMPX,HPART,LIN,IVERS,NGP,NPART,NGXI,NEDIT, + 1 NUCL,NK,NUFIS,MASM3,N,NGPRT,HNPRT,NPMIN,NPMAX,NANIS,MUFIS) +*---- +* PROCESS SCATTERING INFORMATION +*---- + DO I=1,NPART + IF(HNPRT(I).EQ.HPART) THEN + IPART=I + GO TO 30 + ENDIF + ENDDO + CALL XABORT('FMAC: PARTICLE '//HPART//' NOT AVAILABLE IN FMAC-M ' + 1 //'FILE.') + 30 IF(IPART.EQ.0) CALL XABORT('FMAC: PARTICLE TYPE NOT DEFINED.') + IG1=1 + DO I=1,IPART-1 + IG1=IG1+NGPRT(I) + ENDDO + IG2=IG1+NGPRT(IPART)-1 + DO IG=IG1,IG2 + NANISO=MAX(NANISO,NANIS(IG)) + ENDDO + DO IG=1,NGP + MAXLEN=2*(NANISO+1)*NK + ALLOCATE(H2(NGP,MAXLEN),NWA(NGP,NK)) + H2(:NGP,:MAXLEN)=0.0 + NWA(:NGP,:NK)=0 + DO NP=NPMIN(IG),NPMAX(IG) + READ(LIN,'(6I12)') NPP,NQQ,(NWA(NPP,I),I=1,NK),LENGTH + IF(LENGTH.GT.MAXLEN) CALL XABORT('FMAC: MAXLEN OVERFLOW.') + READ(LIN,'(6E12.0)') (H2(NPP,J),J=1,LENGTH) + ENDDO + IF((IG.GE.IG1).AND.(IG.LE.IG2)) THEN + CALL FMAC03(IPMACR,IG,IPART,NGP,MAXLEN,NANISO,NK,NPART,HNPRT, + 1 NGPRT,NWA,H2) + ENDIF + DEALLOCATE(NWA,H2) + ENDDO +*---- +* WRITE THE STATE VECTOR AND EXIT +*---- + ISTATE(:NSTATE)=0 + ISTATE(1)=NGPRT(IPART) + ISTATE(2)=NK + ISTATE(3)=NANISO + ISTATE(4)=NUFIS + ISTATE(5)=0 + ISTATE(6)=ITRANC + ISTATE(7)=NDELG + ISTATE(8)=NALBP + ISTATE(11)=NSTEP + ISTATE(12)=IDF + ISTATE(13)=IADJ + ISTATE(17)=NPART-1 + CALL LCMPUT(IPMACR,'STATE-VECTOR',NSTATE,1,ISTATE) + IF(IMPX.GT.1) CALL LCMLIB(IPMACR) + IF(IMPX.GT.0) THEN + WRITE(IOUT,1010) IMPX,(ISTATE(I),I=1,7),ISTATE(9),ISTATE(11), + 1 ISTATE(12),ISTATE(13),ISTATE(17),HPART + WRITE(IOUT,1020) (HNPRT(I),I=1,NPART) + WRITE(IOUT,1030) (NGPRT(I),I=1,NPART) + ENDIF + DEALLOCATE(MUFIS,NANIS,NPMAX,NPMIN,HNPRT,NGPRT) + RETURN +* + 1101 FORMAT(1X,'NG =',I3,' number of energy groups;',/ + +,1X,'NPART =',I3,' number of particle types;',/ + +,1X,'NGXI =',I3,' number of groups with non-zero fission spectr + +um;',/ + +,1X,'NGXIF =',I3,' number of the first group with non-zero fissi + +on spectrum;',/ + +,1X,'NGRET =',I3,' number of delayed neutron groups;',/ + +,1X,'NGXIR =',I3,' number of groups with non-zero fission spectr + +um for delayed neutrons;',/ + +,1X,'NGXIFR=',I3,' number of the first group with non-zero fissi + +on spectrum for delayed neutrons;',/ + +,1X,'NEDIT =',I3,' number of additional edit cross-sections;' + +,/ + +,1X,'MAXGS =',I3,' not used;',/ + +,1X,'KLEIN =',I3,' not used;',/ + +,1X,'NGHIGH=',I3,' total number of groups of cascade region;',/ + +,1X,'IADJ =',I3,' 0/1 - regular/adjoint cross-section file;',/ + +,1X,'NUCL =',I3,' number of nuclides;',/ + +,1X,'NUCLF =',I3,' number of fission nuclides;',/ + +,1X,'MIX =',I3,' number of materials (compositions);',/ + +,1X,'NUFIS =',I3,' number of fission materials;',/ + +,1X,'MAS =',I3,' length of integer control array LL(MAS);',/ + +,1X,'KIN=',I6,' total number of scattering transitions (not used + +);',/ + +,1X,'MX =',I3,' maximal length of transition array (not used) + +;',/ + +,1X,'MNW =',I3,' order of PL approximation used +1;',/ + +,1X,'MPOINT=',I3,' order of discrete approximation of scattering + + indicatrix (number of angular scattering cosine points used);',/ + +,1X,'NUMD(I)=',19I3,' not used') + 1002 FORMAT(1X,A18/' FMAC: Format FMAC-M version =',I2) + 1010 FORMAT(/8H OPTIONS/8H -------/ + 1 7H IMPX ,I6,30H (0=NO PRINT/1=SHORT/2=MORE)/ + 2 7H NGROUP,I6,28H (NUMBER OF ENERGY GROUPS)/ + 3 7H NBMIX ,I6,39H (NUMBER OF MIXTURES IN THE MACROLIB)/ + 4 7H NANISO,I6,34H (MAXIMUM SCATTERING ANISOTROPY)/ + 5 7H NIFISS,I6,45H (MAXIMUM NUMBER OF FISSILE ISOTOPES IN A M, + 6 7HIXTURE)/ + 7 7H NEDMAC,I6,34H (NUMBER OF CROSS SECTION EDITS)/ + 8 7H ITRANC,I6,45H (0=NO TRANSPORT CORRECTION/1=APOLLO TYPE/2, + 9 43H=RECOVER FROM LIBRARY/4=LEAKAGE CORRECTION)/ + 1 7H NLG ,I6,39H (NUMBER OF DELAYED PRECURSOR GROUPS)/ + 2 7H ILEAK ,I6,40H (1=DIFF AVAILABLE; 2=DIFFX AVAILABLE)/ + 3 7H NSTEP ,I6,39H (NUMBER OF PERTURBATION DIRECTORIES)/ + 4 7H IDF ,I6,48H (=0/2 BOUNDARY FLUXES FOR ADF ABSENT/PRESENT)/ + 5 7H IADJ ,I6,33H (=0/1 DIRECT/ADJOINT MACROLIB)/ + 6 7H NPART0,I6,34H (NUMBER OF COMPANION PARTICLES)/ + 7 6H HPART ,A7,22H (MACROLIB PARTICLE)) + 1020 FORMAT(/22H PARTICLE NAMES:,10A8) + 1030 FORMAT(22H NB. OF ENERGY GROUPS:,10I8) + END diff --git a/Dragon/src/FMAC01.f b/Dragon/src/FMAC01.f new file mode 100644 index 0000000..cb5106e --- /dev/null +++ b/Dragon/src/FMAC01.f @@ -0,0 +1,381 @@ +*DECK FMAC01 + SUBROUTINE FMAC01(IPMACR,IMPX,HPART,LIN,IVERS,NGP,NPART,NGXI, + 1 NEDIT,NUCL,NK,NUFIS,MASM3,N,NGPRT,HNPRT,NPMIN,NPMAX,NANIS,MUFIS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover data and 1D cross sections from the FMAC-M ascii file. +* +*Copyright: +* Copyright (C) 2020 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMACR LCM object address of the MACROLIB. +* IMPX print flag. +* HPART character*1 name of the MACROLIB particle. +* LIN unit number of the FMAC-M ascii file. +* IVERS file version number. +* NGP sum of number of energy groups for all types of particles. +* NPART number of particle types. +* NGXI number of groups with non-zero fission spectrum. +* NEDIT number of additional edit cross sections. +* NUCL number of nuclides. +* NK number of mixtures. +* NUFIS number of fission materials. +* MASM3 length of integer control array. +* N integer control array. +* +*Parameters: output +* NGPRT number of energy groups per particle type. +* HNPRT character*1 names of particle types. +* NPMIN minimum transition group number. +* NPMAX maximum transition group number. +* NANIS number of Legendre orders per energy group. +* MUFIS fission material number per mixture. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMACR + INTEGER IMPX,LIN,IVERS,NGP,NPART,NGXI,NEDIT,NUCL,NK,NUFIS, + 1 MASM3,N(MASM3),NGPRT(NPART),NPMIN(NGP),NPMAX(NGP),NANIS(NGP), + 2 MUFIS(NUFIS) + CHARACTER(LEN=1) HPART,HNPRT(NPART) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(IOUT=6) + TYPE(C_PTR) JPMACR + CHARACTER TEX(50)*6,HSMG*131 +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: H1 + REAL, ALLOCATABLE, DIMENSION(:,:) :: H2 + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: H3 + CHARACTER(LEN=6), ALLOCATABLE, DIMENSION(:) :: HNGAR +* + NGROUP=0 + IPART=0 + DO K=1,MASM3 + LTOT=N(K) + IF(LTOT.EQ.0) CYCLE + IG1=0 + IG2=0 + SELECT CASE(K) + CASE(1) +* title + READ(LIN,'(12A6)') (TEX(I),I=1,LTOT) + IF(IMPX.GT.0) WRITE(IOUT,1000) (TEX(I),I=1,LTOT) + CASE(2) +* number of energy groups by particle type + IF(LTOT.NE.NPART) CALL XABORT('FMAC01: BAD RECORD 2.') + READ(LIN,'(6I12)') (NGPRT(I),I=1,LTOT) + CALL LCMPUT(IPMACR,'PARTICLE-NGR',NPART,1,NGPRT) + CASE(3) +* particle names by particle type + IF(LTOT.NE.NPART) CALL XABORT('FMAC01: BAD RECORD 3.') + ALLOCATE(HNGAR(LTOT)) + READ(LIN,'(12A6)') (HNGAR(I),I=1,LTOT) + DO I=1,LTOT + IF(HNGAR(I).EQ.'NEUT') THEN + HNPRT(I)='N' + ELSE IF(HNGAR(I).EQ.'GAMA') THEN + HNPRT(I)='G' + ELSE IF(HNGAR(I).EQ.'BETA') THEN + HNPRT(I)='B' + ELSE IF(HNGAR(I).EQ.'POSITR') THEN + HNPRT(I)='C' + ELSE IF(HNGAR(I).EQ.'PROT') THEN + HNPRT(I)='P' + ELSE + WRITE(HSMG,'(8HFMAC01: ,A6,26H IS AN INVALID PARTICLE NA, + 1 3HME.)') HNGAR(I) + CALL XABORT(HSMG) + ENDIF + ENDDO + DEALLOCATE(HNGAR) + CALL LCMPTC(IPMACR,'PARTICLE-NAM',1,NPART,HNPRT) + DO I=1,NPART + IF(HNPRT(I).EQ.HPART) THEN + IPART=I + GO TO 30 + ENDIF + ENDDO + CALL XABORT('FMAC01: PARTICLE '//HPART//' NOT AVAILABLE IN' + 1 //' FMAC-M FILE.') + 30 CONTINUE + CASE(4) +* rest energies by particle type + IF(LTOT.NE.NPART) CALL XABORT('FMAC01: BAD RECORD 4.') + ALLOCATE(H1(LTOT)) + READ(LIN,'(6E12.0)') (H1(I),I=1,LTOT) + DO I=1,LTOT + H1(I)=H1(I)*1.0E6 + ENDDO + CALL LCMPUT(IPMACR,'PARTICLE-MC2',NPART,2,H1) + DEALLOCATE(H1) + CASE(5) +* energy mesh boundaries for all particles + IF(LTOT.NE.NGP+NPART) CALL XABORT('FMAC01: BAD RECORD 5.') + ALLOCATE(H1(LTOT)) + READ(LIN,'(6E12.0)') (H1(I),I=1,LTOT) + IF(IPART.EQ.0) CALL XABORT('FMAC01: PARTICLE TYPE UNDEFINED.') + DO I=1,LTOT + H1(I)=H1(I)*1.0E6 + ENDDO + IG1=1 + DO I=1,IPART-1 + IG1=IG1+NGPRT(I)+1 + ENDDO + IG2=IG1+NGPRT(IPART) + NGROUP=NGPRT(IPART) + JPMACR=LCMLID(IPMACR,'GROUP',NGROUP) + CALL FMAC04(NGPRT,NGP,NPART,1,H1(1)) + CALL LCMPUT(IPMACR,'ENERGY',NGROUP+1,2,H1) + DEALLOCATE(H1) + CASE(6) +* group velocities + IF(LTOT.NE.NGP) CALL XABORT('FMAC01: BAD RECORD 6.') + ALLOCATE(H1(LTOT)) + READ(LIN,'(6E12.0)') (H1(I),I=1,LTOT) + DEALLOCATE(H1) + CASE(7) +* nuclide names + IF(LTOT.NE.NUCL) CALL XABORT('FMAC01: BAD RECORD 7.') + READ(LIN,'(12A6)') (TEX(I),I=1,LTOT) + CASE(8) +* nuclide nuclear densities and averaged temperatures by +* materials + IF(LTOT.NE.(NUCL+1)*NK) CALL XABORT('FMAC01: BAD RECORD 8.') + ALLOCATE(H2((NUCL+1),NK)) + READ(LIN,'(6E12.0)') ((H2(I,J),I=1,NUCL+1),J=1,NK) + DEALLOCATE(H2) + CASE(9) +* nuclide temperatures by materials + IF(LTOT.NE.NUCL*NK) CALL XABORT('FMAC01: BAD RECORD 9.') + ALLOCATE(H1(LTOT)) + READ(LIN,'(6E12.0)') (H1(I),I=1,LTOT) + DEALLOCATE(H1) + CASE(10) +* additional edit cross section names + IF(LTOT.NE.NEDIT) CALL XABORT('FMAC01: BAD RECORD 10.') + IF(IVERS.GE.5) THEN + READ(LIN,'(12A6)') (TEX(I),I=1,LTOT) + ELSE + ALLOCATE(H1(LTOT)) + READ(LIN,'(6E12.0)') (H1(I),I=1,LTOT) + DEALLOCATE(H1) + ENDIF + CASE(11) +* PMIN array + IF(LTOT.NE.NGP) CALL XABORT('FMAC01: BAD RECORD 11.') + READ(LIN,'(6I12)') (NPMIN(I),I=1,LTOT) + CASE(12) +* PMAX array + IF(LTOT.NE.NGP) CALL XABORT('FMAC01: BAD RECORD 12.') + READ(LIN,'(6I12)') (NPMAX(I),I=1,LTOT) + CASE(13) + CALL XABORT('FMAC01: This record (13) is UNDEFINED in the ve' + 1 //'rsion.ge.3 of format FMAC-M.') + CASE(14) +* number of scattering cross-section moments + IF(LTOT.NE.NGP) CALL XABORT('FMAC01: BAD RECORD 14.') + READ(LIN,'(6I12)') (NANIS(I),I=1,LTOT) + IF(IPART.EQ.0) CALL XABORT('FMAC01: PARTICLE TYPE UNDEFINED.') + CASE(15) +* total cross sections + IF(LTOT.NE.NK*NGP) CALL XABORT('FMAC01: BAD RECORD 15.') + IF(IPART.EQ.0) CALL XABORT('FMAC01: PARTICLE TYPE UNDEFINED.') + IG1=1 + DO I=1,IPART-1 + IG1=IG1+NGPRT(I) + ENDDO + IG2=IG1+NGPRT(IPART)-1 + ALLOCATE(H2(NK,NGP)) + READ(LIN,'(6E12.0)') ((H2(I,J),I=1,NK),J=1,NGP) + CALL FMAC02(IPMACR,NK,IG2-IG1+1,H2(1,IG1),'NTOT0') + DEALLOCATE(H2) + CASE(16) +* absorption cross sections + IF(LTOT.NE.NK*NGP) CALL XABORT('FMAC01: BAD RECORD 16.') + IF(IPART.EQ.0) CALL XABORT('FMAC01: PARTICLE TYPE UNDEFINED.') + IG1=1 + DO I=1,IPART-1 + IG1=IG1+NGPRT(I) + ENDDO + IG2=IG1+NGPRT(IPART)-1 + ALLOCATE(H2(NK,NGP)) + READ(LIN,'(6E12.0)') ((H2(I,J),I=1,NK),J=1,NGP) + CALL FMAC02(IPMACR,NK,IG2-IG1+1,H2(1,IG1),'ABS') + DEALLOCATE(H2) + CASE(17) +* mixture corresponding to each fissile mixture + IF(LTOT.NE.NUFIS) CALL XABORT('FMAC01: BAD RECORD 17.') + READ(LIN,'(6I12)') (MUFIS(I),I=1,LTOT) + CASE(18) +* fission cross sections + IF(LTOT.NE.NUFIS*NGP) CALL XABORT('FMAC01: BAD RECORD 18.') + ALLOCATE(H1(LTOT)) + READ(LIN,'(6E12.0)') (H1(I),I=1,LTOT) + DEALLOCATE(H1) + CASE(19) +* neutron production cross sections by fission material + IF(LTOT.NE.NUFIS*NGP) CALL XABORT('FMAC01: BAD RECORD 19.') + IF(NUFIS.EQ.0) CALL XABORT('FMAC01: NO FISSILE MIXTURES.') + IF(NGROUP.EQ.0) CALL XABORT('FMAC01: NGROUP UNDEFINED.') + ALLOCATE(H2(NUFIS,NGP),H3(NK,NUFIS,NGROUP)) + H3(:NK,:NUFIS,:NGROUP)=0.0 + READ(LIN,'(6E12.0)') ((H2(I,J),I=1,NUFIS),J=1,NGP) + IF(IPART.EQ.0) CALL XABORT('FMAC01: PARTICLE TYPE UNDEFINED.') + IG1=1 + DO I=1,IPART-1 + IG1=IG1+NGPRT(I) + ENDDO + IG2=IG1+NGPRT(IPART)-1 + DO I=1,NUFIS + IK=MUFIS(I) + IF((IK.LE.0).OR.(IK.GT.NK)) CALL XABORT('FMAC01: WRONG MUF' + 1 //'IS VALUE.') + H3(IK,I,:NGROUP)=H2(I,IG1:IG2) + ENDDO + CALL FMAC02(IPMACR,NK*NUFIS,NGROUP,H3(1,1,1),'NUSIGF') + DEALLOCATE(H3,H2) + CASE(20) +* fission spectra by fission material + IF(LTOT.NE.NUFIS*NGXI) CALL XABORT('FMAC01: BAD RECORD 20.') + IF(NUFIS.EQ.0) CALL XABORT('FMAC01: NO FISSILE MIXTURES.') + IF(NGROUP.EQ.0) CALL XABORT('FMAC01: NGROUP UNDEFINED.') + ALLOCATE(H2(NUFIS,NGXI),H3(NK,NUFIS,NGROUP)) + H3(:NK,:NUFIS,:NGROUP)=0.0 + READ(LIN,'(6E12.0)') ((H2(I,J),I=1,NUFIS),J=1,NGXI) + IF(IPART.EQ.0) CALL XABORT('FMAC01: PARTICLE TYPE UNDEFINED.') + IG1=1 + DO I=1,IPART-1 + IG1=IG1+NGPRT(I) + ENDDO + IG2=IG1+NGPRT(IPART)-1 + DO I=1,NUFIS + IK=MUFIS(I) + IF((IK.LE.0).OR.(IK.GT.NK)) CALL XABORT('FMAC01: WRONG MUF' + 1 //'IS VALUE.') + H3(IK,I,:NGXI)=H2(I,IG1:IG2+NGXI-NGROUP) + ENDDO + CALL FMAC02(IPMACR,NK*NUFIS,NGROUP,H3(1,1,1),'CHI') + DEALLOCATE(H3,H2) + CASE(21) +* fission nuclide numbers + READ(LIN,'(6I12)') (N(I),I=1,LTOT) + CASE(22) +* summary parts of delayed fission neutrons by fission nuclides + ALLOCATE(H1(LTOT)) + READ(LIN,'(6E12.0)') (H1(I),I=1,LTOT) + DEALLOCATE(H1) + CASE(23) +* relative delayed group parts of delayed fission neutrons + ALLOCATE(H1(LTOT)) + READ(LIN,'(6E12.0)') (H1(I),I=1,LTOT) + DEALLOCATE(H1) + CASE(24) +* decay constants of delayed neutrons + ALLOCATE(H1(LTOT)) + READ(LIN,'(6E12.0)') (H1(I),I=1,LTOT) + DEALLOCATE(H1) + CASE(25) +* fission spectra of instantaneous fission neutrons + ALLOCATE(H1(LTOT)) + READ(LIN,'(6E12.0)') (H1(I),I=1,LTOT) + DEALLOCATE(H1) + CASE(26) +* fission spectra of delayed fission neutrons + ALLOCATE(H1(LTOT)) + READ(LIN,'(6E12.0)') (H1(I),I=1,LTOT) + DEALLOCATE(H1) + CASE(27) +* blocked microscopic neutron production cross sections + ALLOCATE(H1(LTOT)) + READ(LIN,'(6E12.0)') (H1(I),I=1,LTOT) + DEALLOCATE(H1) + CASE(28:34) + CALL XABORT('FMAC01: This record (28:34) is UNDEFINED in the' + 1 //' version.ge.3 of format FMAC-M.') + CASE(35) +* restricted stopping power + IF(LTOT.NE.NK*(NGP+NPART)) CALL XABORT('FMAC01: INVALID RECO' + 1 //'RD 35.') + IF(IPART.EQ.0) CALL XABORT('FMAC01: PARTICLE TYPE UNDEFINED.') + IG1=1 + DO I=1,IPART-1 + IG1=IG1+NGPRT(I)+1 + ENDDO + IG2=IG1+NGPRT(IPART) + ALLOCATE(H2(NK,NGP+NPART)) + READ(LIN,'(6E12.0)') ((H2(I,J),I=1,NK),J=1,NGP+NPART) + IF((HPART.EQ.'N').OR.(HPART.EQ.'G')) THEN + DEALLOCATE(H2) + CYCLE + ENDIF + CALL FMAC04(NGPRT,NGP,NPART,NK,H2(1,1)) + CALL FMAC02(IPMACR,NK,IG2-IG1+1,H2(1,IG1),'ESTOPW') + DEALLOCATE(H2) + CASE(36) +* restricted momentum transfer cross section + IF(LTOT.NE.NK*NGP) CALL XABORT('FMAC01: BAD RECORD 36.') + IF(IPART.EQ.0) CALL XABORT('FMAC01: PARTICLE TYPE UNDEFINED.') + IG1=1 + DO I=1,IPART-1 + IG1=IG1+NGPRT(I) + ENDDO + IG2=IG1+NGPRT(IPART)-1 + ALLOCATE(H2(NK,NGP)) + READ(LIN,'(6E12.0)') ((H2(I,J),I=1,NK),J=1,NGP) + IF((HPART.EQ.'N').OR.(HPART.EQ.'G')) THEN + DEALLOCATE(H2) + CYCLE + ENDIF + CALL FMAC02(IPMACR,NK,IG2-IG1+1,H2(1,IG1),'EMOMTR') + DEALLOCATE(H2) + CASE(37) +* energy deposition cross section + IF(LTOT.NE.NK*NGP) CALL XABORT('FMAC01: BAD RECORD 37.') + IF(IPART.EQ.0) CALL XABORT('FMAC01: PARTICLE TYPE UNDEFINED.') + IG1=1 + DO I=1,IPART-1 + IG1=IG1+NGPRT(I) + ENDDO + IG2=IG1+NGPRT(IPART)-1 + ALLOCATE(H2(NK,NGP)) + READ(LIN,'(6E12.0)') ((H2(I,J),I=1,NK),J=1,NGP) + CALL FMAC02(IPMACR,NK,IG2-IG1+1,H2(1,IG1),'H-FACTOR') + DEALLOCATE(H2) + CASE(38) +* charge deposition cross section + IF(LTOT.NE.NK*NGP) CALL XABORT('FMAC01: BAD RECORD 38.') + IF(IPART.EQ.0) CALL XABORT('FMAC01: PARTICLE TYPE UNDEFINED.') + IG1=1 + DO I=1,IPART-1 + IG1=IG1+NGPRT(I) + ENDDO + IG2=IG1+NGPRT(IPART)-1 + ALLOCATE(H2(NK,NGP)) + READ(LIN,'(6E12.0)') ((H2(I,J),I=1,NK),J=1,NGP) + CALL FMAC02(IPMACR,NK,IG2-IG1+1,H2(1,IG1),'C-FACTOR') + DEALLOCATE(H2) + CASE DEFAULT + CALL XABORT('FMAC01: This record (>38) is UNDEFINED in the' + 1 //' version.ge.3 of format FMAC-M.') + END SELECT + ENDDO + RETURN + 1000 FORMAT(/9H FMAC01: ,12A6) + END diff --git a/Dragon/src/FMAC02.f b/Dragon/src/FMAC02.f new file mode 100644 index 0000000..d0f7695 --- /dev/null +++ b/Dragon/src/FMAC02.f @@ -0,0 +1,63 @@ +*DECK FMAC02 + SUBROUTINE FMAC02(IPMACR,NK,NGROUP,ARRAY,HNAME) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Save a 1D cross section in the GROUP list of a MACROLIB. +* +*Copyright: +* Copyright (C) 2020 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMACR LCM object address of the MACROLIB. +* NK number of mixtures. +* NGROUP number of energy groups. +* ARRAY array to save. +* HNAME MACROLIB name of the cross section. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMACR + INTEGER NK,NGROUP + REAL ARRAY(NK,NGROUP) + CHARACTER(LEN=*) HNAME +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPMACR,KPMACR + CHARACTER HSMG*131 +* + CALL LCMLEN(IPMACR,'GROUP',ILENG,ITYLCM) + ITY=0 + IF(ILENG.EQ.NGROUP) THEN + ITY=1 + ELSE IF(ILENG+1.EQ.NGROUP) THEN + ITY=2 + ELSE + CALL LCMLIB(IPMACR) + WRITE(HSMG,'(33HFMAC02: INVALID VALUE OF NGROUP (,I6,5H) XS=, + 1 A8,1H.)') NGROUP,HNAME + CALL XABORT(HSMG) + ENDIF + JPMACR=LCMGID(IPMACR,'GROUP') + DO IG=1,ILENG + KPMACR=LCMDIL(JPMACR,IG) + IF(ITY.EQ.1) THEN + CALL LCMPUT(KPMACR,HNAME,NK,2,ARRAY(:NK,IG)) + ELSE IF(ITY.EQ.2) THEN + CALL LCMPUT(KPMACR,HNAME,NK*2,2,ARRAY(:NK,IG:IG+1)) + ENDIF + ENDDO + RETURN + END diff --git a/Dragon/src/FMAC03.f b/Dragon/src/FMAC03.f new file mode 100644 index 0000000..e84a6e5 --- /dev/null +++ b/Dragon/src/FMAC03.f @@ -0,0 +1,145 @@ +*DECK FMAC03 + SUBROUTINE FMAC03(IPMACR,IG,IPART,NGP,MAXLEN,NANISO,NK,NPART, + 1 HNPRT,NGPRT,NWA,H2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Save a SCAT cross section in the GROUP list of a MACROLIB. +* +*Copyright: +* Copyright (C) 2020 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMACR LCM object address of the MACROLIB. +* IG secondary energy group. +* IPART index of the particle type corresponding to the MACROLIB. +* NGP sum of number of energy groups for all types of particles. +* MAXLEN second dimension of array H2. +* NANISO maximum scattering anisotropy. +* NK number of mixtures. +* NPART number of particle types. +* HNPRT character*1 names of particle types. +* NGPRT number of energy groups per particle type. +* NWA Legendre order of scattering cross-section information. +* H2 scattering cross-section information. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMACR + INTEGER IG,IPART,NGP,MAXLEN,NANISO,NK,NPART,NGPRT(NPART), + 1 NWA(NGP,NK) + CHARACTER(LEN=1) HNPRT(NPART) + REAL H2(NGP,MAXLEN) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) KPMACR + CHARACTER(LEN=2) CM + CHARACTER(LEN=12) HGROUP +*---- +* ALLOCATABLE ARRAYS +*---- + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: JPMACR + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) :: GAR + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT +*---- +* DEFINE GROUP DIRECTORIES PER PARTICLE TYPE +*---- + ALLOCATE(JPMACR(NPART)) + DO JPART=1,NPART + IF(JPART.EQ.IPART) THEN + HGROUP='GROUP' + ELSE + HGROUP='GROUP-'//HNPRT(JPART) + ENDIF + JPMACR(JPART)=LCMLID(IPMACR,HGROUP,NGPRT(IPART)) + ENDDO + IG1=1 + DO I=1,IPART-1 + IG1=IG1+NGPRT(I) + ENDDO + IG2=IG1+NGPRT(IPART)-1 + IGR=IG-IG1+1 +*---- +* LOOP OVER PARTICLE TYPES +*---- + DO JPART=1,NPART + ALLOCATE(SCAT(NK,NGPRT(JPART),NANISO+1)) + SCAT(:NK,:NGPRT(JPART),:NANISO)=0.0 + JG1=1 + DO I=1,JPART-1 + JG1=JG1+NGPRT(I) + ENDDO + JG2=JG1+NGPRT(JPART)-1 +*---- +* LOOP OVER TRANSITIONS +*---- + DO JG=JG1,JG2 +* Loop over primary energy groups + DO IBM=1,NK + IF(NWA(JG,IBM).NE.0) GO TO 10 + ENDDO + CYCLE +* Find the primary particle type + 10 JGR=JG-JG1+1 + IOF=0 + DO IBM=1,NK + IF(NWA(JG,IBM).GT.0) CALL XABORT('FMAC03: POSITIVE NWA NOT' + 1 //' IMPLEMENTED.') + IF(-NWA(JG,IBM).GT.NANISO+1) CALL XABORT('FMAC03: NWA OVER' + 1 //'FLOW.') + DO IL=1,-NWA(JG,IBM) + SCAT(IBM,JGR,IL)=H2(JG,IOF+IL) + ENDDO + IOF=IOF-NWA(JG,IBM) + ENDDO + ENDDO +*---- +* SAVE SCATTERING INFORMATION ON MACROLIB +*---- + ALLOCATE(NJJ(NK),IJJ(NK),IPOS(NK),GAR(NK*NGPRT(JPART))) + KPMACR=LCMDIL(JPMACR(JPART),IGR) + DO IL=1,NANISO + WRITE (CM,'(I2.2)') IL-1 + IPOSIT=0 + DO IBM=1,NK + J2=IGR + J1=IGR + DO JGR=1,NGPRT(JPART) + IF(SCAT(IBM,JGR,IL).NE.0.0) THEN + J2=MAX(J2,JGR) + J1=MIN(J1,JGR) + ENDIF + ENDDO + NJJ(IBM)=J2-J1+1 + IJJ(IBM)=J2 + IPOS(IBM)=IPOSIT+1 + DO JGR=J2,J1,-1 + IPOSIT=IPOSIT+1 + IF(IPOSIT.GT.NK*NGPRT(JPART)) CALL XABORT('bug') + GAR(IPOSIT)=SCAT(IBM,JGR,IL) + ENDDO + ENDDO + CALL LCMPUT(KPMACR,'SIGW'//CM,NK,2,SCAT(1,IGR,IL)) + CALL LCMPUT(KPMACR,'SCAT'//CM,IPOSIT,2,GAR) + CALL LCMPUT(KPMACR,'NJJS'//CM,NK,1,NJJ) + CALL LCMPUT(KPMACR,'IJJS'//CM,NK,1,IJJ) + CALL LCMPUT(KPMACR,'IPOS'//CM,NK,1,IPOS) + ENDDO + DEALLOCATE(GAR,IPOS,IJJ,NJJ,SCAT) + ENDDO + DEALLOCATE(JPMACR) + RETURN + END diff --git a/Dragon/src/FMAC04.f b/Dragon/src/FMAC04.f new file mode 100644 index 0000000..ad4ca0b --- /dev/null +++ b/Dragon/src/FMAC04.f @@ -0,0 +1,55 @@ +*DECK FMAC04 + SUBROUTINE FMAC04(NGPRT,NGP,NPART,NK,H) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Reorganize boundary information from FMAC-M array. +* +*Copyright: +* Copyright (C) 2020 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): C. Bienvenue +* +*Parameters: input +* NGPRT number of energy groups per particle. +* NGP number of energy groups for all particles. +* NPART number of particles in FMAC-M file. +* NK number of mixtures +* H boundary informations array from FMAC-M file. +* +*Parameters: output +* H boundary informations array organized by particle. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NGPRT(NPART),NGP,NPART + REAL H(NK,NGP+NPART),HTEMP(NK,NGP+NPART) +* + NGT1=0 + NGT2=0 + DO I=1,NPART + DO J=1,NGPRT(I)+1 + DO K=1,NK + IF(J.LE.NGPRT(I)) THEN + HTEMP(k,NGT2+J)=H(k,NGT1+J) + ELSE + HTEMP(k,NGT2+J)=H(k,NGP+NPART+1-I) + ENDIF + ENDDO + ENDDO + NGT1=NGT1+NGPRT(I) + NGT2=NGT2+NGPRT(I)+1 + ENDDO + + H=HTEMP + + RETURN + END diff --git a/Dragon/src/FMT.f b/Dragon/src/FMT.f new file mode 100644 index 0000000..422cacb --- /dev/null +++ b/Dragon/src/FMT.f @@ -0,0 +1,125 @@ +*DECK FMT + SUBROUTINE FMT(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To store and retreive information from binary and ASCII files. +* +*Copyright: +* Copyright (C) 2009 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* NENTRY number of data structures transfered to this module. +* HENTRY name of the data structures. +* IENTRY data structure type where: +* =1 for LCM memory object; +* =2 for XSM file; +* =3 for sequential binary file; +* =4 for sequential ASCII file. +* JENTRY access permission for the data structure where: +* =0 for a data structure in creation mode; +* =1 for a data structure in modifications mode; +* =2 for a data structure in read-only mode. +* KENTRY data structure pointer. +* +*Comments: +* Instructions for the use of the FMT: module: +* [[ OutFiles ]] := FMT: [[ InDds ]] :: (FMTget) ; +* or +* [[ UpdDds ]] := FMT: [[ UpdDds ]] [[ Infiles ]] :: (FMTget) ; +* where +* OutFiles : sequential binary/ASCII output files. +* UpdDds : Data structures to update. +* InFiles : sequential binary/ASCII input files. +* InDds : Input data structure. +* (FMTget) : Processing options +* (read from input using the FMTGET routine). +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='FMT ') + INTEGER ILCMUP,ILCMDN,MXFIL,MXOPT + PARAMETER (ILCMUP=1,ILCMDN=2,MXFIL=20,MXOPT=20) + INTEGER NSTATE + PARAMETER (NSTATE=40) +*---- +* Local variables +*---- + CHARACTER*12 SENTRY(MXFIL) + INTEGER IEN + CHARACTER HSIGN*12 + INTEGER IPRINT,NOPT,IOPT(MXOPT) +*---- +* Validate entry parameters +*---- + IF(NENTRY .GT. MXFIL) CALL XABORT(NAMSBR// + > ': Too many files or data structures for this module.') +*---- +* Scan data structure to determine signature (input or update) +*---- + DO IEN=1,NENTRY + SENTRY(IEN)=' ' + IF(IENTRY(IEN) .EQ. 1 .OR. IENTRY(IEN) .EQ. 2) THEN + IF(JENTRY(IEN) .NE. 0) THEN + CALL LCMGTC(KENTRY(IEN),'SIGNATURE',12,HSIGN) + SENTRY(IEN)=HSIGN + ENDIF + ENDIF + ENDDO +*---- +* Recover processing option +*---- + NOPT=MXOPT + IOPT(:NOPT)=0 + CALL FMTGET(IPRINT,NOPT,IOPT) +*---- +* Process files +*---- + IF(IOPT(1) .EQ. 1) THEN +*---- +* SUS3D format +*---- + CALL FMTSUS(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY,SENTRY, + > IPRINT,NOPT,IOPT) + ELSE IF(IOPT(1) .EQ. 2) THEN +*---- +* DIRFLX format +*---- + CALL FMTDFL(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY,SENTRY, + > IPRINT) + ELSE IF(IOPT(1) .EQ. 3) THEN +*---- +* BURNUP format +*---- + CALL FMTBRN(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY,SENTRY, + > IPRINT,NOPT,IOPT) + ENDIF +*---- +* Processing finished, return +*---- + RETURN +*---- +* Warning formats +*---- + END diff --git a/Dragon/src/FMTBRN.f b/Dragon/src/FMTBRN.f new file mode 100644 index 0000000..d5e758b --- /dev/null +++ b/Dragon/src/FMTBRN.f @@ -0,0 +1,250 @@ +*DECK FMTBRN + SUBROUTINE FMTBRN(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY,SENTRY, + > IPRINT,NOPT,IOPT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Create Matlab ASCII file for burnup. +* +*Copyright: +* Copyright (C) 2017 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* NENTRY number of data structures transfered to this module. +* HENTRY name of the data structures. +* IENTRY data structure type where: +* =1 for LCM memory object; +* =2 for XSM file; +* =3 for sequential binary file; +* =4 for sequential ASCII file. +* JENTRY access permission for the data structure where: +* =0 for a data structure in creation mode; +* =1 for a data structure in modifications mode; +* =2 for a data structure in read-only mode. +* KENTRY data structure pointer. +* SENTRY data structure signature. +* IPRINT print level. +* NOPT number of options. +* IOPT processing option. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NENTRY + CHARACTER HENTRY(NENTRY)*12 + TYPE(C_PTR) KENTRY(NENTRY) + INTEGER IENTRY(NENTRY),JENTRY(NENTRY) + CHARACTER SENTRY(NENTRY)*12 + INTEGER IPRINT,NOPT,IOPT(NOPT) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='FMTBRN') + INTEGER ILCMUP,ILCMDN + PARAMETER (ILCMUP=1,ILCMDN=2) + INTEGER NSTATE + PARAMETER (NSTATE=40) +*---- +* Local variables +*---- + INTEGER IEN,IKMAT,IKEDI,IKEVO + CHARACTER HNEWB*12,HNEWE*12 + INTEGER ISTATE(NSTATE) + INTEGER NSTEP,NBISO,NBMIXB,NGROUP,NBMIXE,MISPRT,ISTEP, + > ISOT,ISOR,IKI + REAL TIMEFS + CHARACTER FMT1*44,FMT2*44 +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ISOPRT,ISOMIX + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NAMISO,NAMRD + REAL, ALLOCATABLE, DIMENSION(:) :: FUELDN,TIME,KEFF + REAL, ALLOCATABLE, DIMENSION(:,:) :: ISODEN + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6000) NAMSBR + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6002) (IOPT(IKI),IKI=1,2) + ENDIF + ENDIF + +*---- +* Validate entry parameters +*---- + IF(NENTRY .LT. 3) CALL XABORT(NAMSBR// + > ': At least three data structures required for this option.') +*---- +* Output structure (matlab ascii file) +*---- + IEN=1 + IF(IENTRY(IEN) .EQ. 4) THEN + IF(JENTRY(IEN) .EQ. 2) CALL XABORT(NAMSBR// + > ': Data structure not in update or creation mode.') + IF(JENTRY(IEN) .EQ. 1) REWIND(FILUNIT(KENTRY(IEN))) + ELSE + CALL XABORT(NAMSBR// + > ': Invalid data structure format for '//HENTRY(IEN)//'.') + ENDIF + IKMAT=FILUNIT(KENTRY(IEN)) +*---- +* Input structure +* Edition and burnup data structures +*---- + IKEDI=0 + IKEVO=0 + DO IEN=2,NENTRY + IF(IENTRY(IEN) .EQ. 1 .OR. IENTRY(IEN) .EQ. 2) THEN + IF(JENTRY(IEN) .NE. 2) CALL XABORT(NAMSBR// + > ': Data structure not in read-only mode.') + IF(SENTRY(IEN) .EQ. 'L_EDIT') THEN + IKEDI=IEN + ELSE IF(SENTRY(IEN) .EQ. 'L_BURNUP') THEN + IKEVO=IEN + ELSE + CALL XABORT(NAMSBR// + > ': Invalid data structure type '//HENTRY(IEN)//'.') + ENDIF + ELSE + CALL XABORT(NAMSBR// + > ': Invalid data structure format for '//HENTRY(IEN)//'.') + ENDIF + ENDDO +*---- +* Get STATE-VECTOR from BURNUP data structure +*---- + IF(IKEDI .EQ. 0) CALL XABORT(NAMSBR// + > ': No EDITION structure available.') + IF(IKEVO .EQ. 0) CALL XABORT(NAMSBR// + > ': No BURNUP structure available.') + ISTATE(:NSTATE)=0 + CALL LCMGET(KENTRY(IKEVO),'STATE-VECTOR',ISTATE) + NSTEP=ISTATE(3) + NBISO=ISTATE(4) + NBMIXB=ISTATE(8) +*---- +* Get STATE-VECTOR from EDITION data structure +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(KENTRY(IKEDI),'STATE-VECTOR',ISTATE) + NGROUP=ISTATE(1) + NBMIXE=ISTATE(2) +*---- +* Allocate memory +*---- + ALLOCATE(FUELDN(NBMIXB),TIME(NSTEP),NAMISO(3,NBISO), + > ISOMIX(NBISO),NAMRD(2,NBISO),ISOPRT(NBISO)) + CALL LCMGET(KENTRY(IKEVO),'FUELDEN-MIX ',FUELDN) + CALL LCMGET(KENTRY(IKEVO),'DEPL-TIMES ',TIME) + CALL LCMGET(KENTRY(IKEVO),'ISOTOPESUSED',NAMISO) + CALL LCMGET(KENTRY(IKEVO),'ISOTOPESMIX ',ISOMIX) +*---- +* Get isotopes to to print +*---- + CALL FMTGIS(IPRINT,NBISO,NAMISO,MISPRT,NAMRD, + > NOPT,IOPT,ISOPRT) +*---- +* Allocate memory for isotopic densities and keff +*---- + ALLOCATE(KEFF(NSTEP),ISODEN(NBISO,NSTEP)) +*---- +* Loop over burnup steps and extract isotopic concentration +* keffective +*---- + DO ISTEP=1,NSTEP + WRITE(HNEWB,'(A8,I4.4)') 'DEPL-DAT',ISTEP + WRITE(HNEWE,'(A8,I4.4)') 'REF-CASE',ISTEP + CALL LCMSIX(KENTRY(IKEVO),HNEWB,ILCMUP) + CALL LCMGET(KENTRY(IKEVO),'ISOTOPESDENS',ISODEN(1,ISTEP)) + CALL LCMSIX(KENTRY(IKEVO),HNEWB,ILCMDN) + CALL LCMSIX(KENTRY(IKEDI),HNEWE,ILCMUP) + CALL LCMSIX(KENTRY(IKEDI),'MACROLIB ',ILCMUP) + CALL LCMGET(KENTRY(IKEDI),'K-EFFECTIVE ',KEFF(ISTEP)) + CALL LCMSIX(KENTRY(IKEDI),'MACROLIB ',ILCMDN) + CALL LCMSIX(KENTRY(IKEDI),HNEWE,ILCMDN) + ENDDO +*---- +* Store time and keff on ascii file +*---- + TIMEFS=1E8/(24*60*60) + FMT1=' ' + FMT2=' ' + IF(IOPT(2).EQ.1) THEN + WRITE(FMT1,'(A7,I3,A9)') '(A7,1P,',NSTEP,'E15.8,A2)' + WRITE(IKMAT,FMT1) 'Time =[', + > (TIME(ISTEP)*TIMEFS,ISTEP=1,NSTEP),'];' + WRITE(IKMAT,FMT1) 'Keff =[', + > (KEFF(ISTEP),ISTEP=1,NSTEP),'];' + WRITE(FMT2,'(A17,I3,A9)') '(A3,2A4,A3,I4,A3,1P,', + > NSTEP,'E15.8,A2)' + DO ISOR=1,MISPRT + WRITE(IKMAT,'(A3,2A4,A7,I4,A1,I4,A2)') 'Den', + > NAMRD(1,ISOR),NAMRD(2,ISOR), + > '=zeros(',NSTEP,',',NBMIXB,');' + DO ISOT=1,NBISO + IF(ISOPRT(ISOT).EQ.ISOR) THEN + WRITE(IKMAT,FMT2) 'Den', + > NAMRD(1,ISOR),NAMRD(2,ISOR), + > '(:,',ISOMIX(ISOT),')=[', + > (ISODEN(ISOT,ISTEP),ISTEP=1,NSTEP),'];' + ENDIF + ENDDO + ENDDO + ELSE + WRITE(FMT1,'(A8,I3,A20)') '(A16,1P,',NSTEP-1, + > '(E15.8,A1),E15.8,A2)' + WRITE(IKMAT,FMT1) 'Time =np.array([', + > (TIME(ISTEP)*TIMEFS,',',ISTEP=1,NSTEP-1), + > TIME(NSTEP)*TIMEFS,'])' + WRITE(IKMAT,FMT1) 'Keff =np.array([', + > (KEFF(ISTEP),',',ISTEP=1,NSTEP-1), + > KEFF(NSTEP),'])' + WRITE(FMT2,'(A21,I3,A20)') '(A3,2A4,A1,I4,A12,1P,', + > NSTEP-1,'(E15.8,A1),E15.8,A2)' + DO ISOR=1,MISPRT + WRITE(IKMAT,'(A3,2A4,A11,I4,A1,I4,A2)') 'Den', + > NAMRD(1,ISOR),NAMRD(2,ISOR), + > '=np.zeros((',NBMIXB,',',NSTEP,'))' + DO ISOT=1,NBISO + IF(ISOPRT(ISOT).EQ.ISOR) THEN + WRITE(IKMAT,FMT2) 'Den', + > NAMRD(1,ISOR),NAMRD(2,ISOR), + > '[',ISOMIX(ISOT)-1,']=np.array([', + > (ISODEN(ISOT,ISTEP),',',ISTEP=1,NSTEP-1), + > ISODEN(ISOT,NSTEP),'])' + ENDIF + ENDDO + ENDDO + ENDIF +*---- +* Release memory and return +*---- + DEALLOCATE(ISODEN,KEFF) + DEALLOCATE(ISOPRT,NAMRD,ISOMIX,NAMISO,TIME,FUELDN) + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Warning formats +*---- +*---- +* FORMATS +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6002 FORMAT(' Options',10I10) + END diff --git a/Dragon/src/FMTDFD.f b/Dragon/src/FMTDFD.f new file mode 100644 index 0000000..a740180 --- /dev/null +++ b/Dragon/src/FMTDFD.f @@ -0,0 +1,170 @@ +*DECK FMTDFD + SUBROUTINE FMTDFD(NENTRY,KENTRY,IPRINT,IKFLU ,NTREG , + > NREG ,NGROUP,NDIM ,VOLUME,KEYFLX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To process the angular fluxes and generate the directional +* flux file. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* NENTRY number of data structures transfered to this module. +* KENTRY data structure pointer. +* IPRINT print level. +* IKFLU pointer to the FLUX data structure. +* NTREG number of regions for problem. +* NREG number of unknowns for problem. +* NGROUP number of groups for problem. +* NDIM number of dimensions of problem. +* VOLUME regional volumes. +* KEYFLX index for regional fluxes in unknown vector. +* +*---------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NENTRY + TYPE(C_PTR) KENTRY(NENTRY) + INTEGER IPRINT,IKFLU + INTEGER NREG,NTREG,NGROUP,NDIM,KEYFLX(NTREG) + REAL VOLUME(NTREG) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='FMTDFD') + INTEGER ILCMUP,ILCMDN + PARAMETER (ILCMUP=1,ILCMDN=2) +*---- +* Local variables +*---- + INTEGER ILONG,ITYLCM + TYPE(C_PTR) IPU,JPU + INTEGER IFPU,IGROUP,IR,NFLUX,IFTT + CHARACTER*12 NAMFLX(2) +*---- +* Allocatable arrays +*---- + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: AFLUX +*---- +* Work storage allocation +*---- + ALLOCATE(AFLUX(NREG,2,NGROUP)) +*---- +* Initialize FLUX vectors +*---- + NFLUX=1 + NAMFLX(1)='FLUX ' + IPU=KENTRY(IKFLU) + CALL LCMLEN(IPU,'AFLUX',ILONG,ITYLCM) + write(6,*) 'FLUXADJOINT ',ILONG,ITYLCM + IF(ILONG .EQ. -1) THEN + NFLUX=2 + NAMFLX(2)='ADJOINT ' + ENDIF + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6000) NAMSBR,NGROUP,NDIM,NTREG,NREG + WRITE(IOUT,6008) + WRITE(IOUT,6012) (NAMFLX(IFTT),IFTT=1,NFLUX) + ENDIF +*---- +* Get information from FLUX data structure. +* 1. Angular flux +* 2. Angular adjoint +*---- + JPU=LCMGID(IPU,'FLUX') + DO IGROUP=1,NGROUP + CALL LCMGDL(JPU,IGROUP,AFLUX(1,1,IGROUP)) + ENDDO + IF(NFLUX .GT. 1) THEN + JPU=LCMGID(IPU,'AFLUX') + DO IGROUP=1,NGROUP + CALL LCMGDL(JPU,IGROUP,AFLUX(1,1,IGROUP)) + ENDDO + ENDIF +*---- +* Create output file +*---- + IFPU=FILUNIT(KENTRY(1)) + WRITE(IFPU,1000) NGROUP,NDIM,NREG,NFLUX + WRITE(IFPU,1001) (NAMFLX(IFTT),IFTT=1,NFLUX) +*---- +* Print volumes +*---- + WRITE(IFPU,1002) (VOLUME(IR),IR=1,NREG) +*---- +* Print angular flux +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6003) + ENDIF + DO IGROUP=1,NGROUP + WRITE(IOUT,6002) IGROUP + WRITE(IOUT,1002) (AFLUX(IR,1,IGROUP),IR=1,NREG) + WRITE(IFPU,1002) (AFLUX(IR,1,IGROUP),IR=1,NREG) + ENDDO +*---- +* Print scalar flux +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6004) + DO IGROUP=1,NGROUP + WRITE(IOUT,6002) IGROUP + WRITE(IOUT,1002) (AFLUX(KEYFLX(IR),1,IGROUP),IR=1,NTREG) + WRITE(IFPU,1002) (AFLUX(KEYFLX(IR),1,IGROUP),IR=1,NTREG) + ENDDO + ENDIF +*---- +* Print angular adjoint +*---- + IF(NFLUX .GT. 1) THEN + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6005) + ENDIF + DO IGROUP=1,NGROUP + WRITE(IOUT,6002) IGROUP + WRITE(IOUT,1002) (AFLUX(IR,2,IGROUP),IR=1,NREG) + WRITE(IFPU,1002) (AFLUX(IR,2,IGROUP),IR=1,NREG) + ENDDO + ENDIF +*---- +* Work storage deallocation +*---- + DEALLOCATE(AFLUX) +*---- +* Processing finished, return +*---- + RETURN +*---- +* Formats +*---- + 1000 FORMAT(5I10) + 1001 FORMAT(5(A12,2X)) + 1002 FORMAT(1P,5E20.10) + 6000 FORMAT('Output from routine ',A6/ + > 'Number of groups =',I5/ + > 'Number of dimens =',I5/ + > 'Number of regions =',I5/ + > 'Number of unknowns=',I5) + 6002 FORMAT('Group = ',I5) + 6003 FORMAT('Direct angular flux per region ') + 6004 FORMAT('Scalar flux per region integrated from angular flux') + 6005 FORMAT('Adjoint angular flux per region') + 6008 FORMAT('Flux record types') + 6012 FORMAT(5(A12,2X)) + END diff --git a/Dragon/src/FMTDFL.f b/Dragon/src/FMTDFL.f new file mode 100644 index 0000000..51f006e --- /dev/null +++ b/Dragon/src/FMTDFL.f @@ -0,0 +1,157 @@ +*DECK FMTDFL + SUBROUTINE FMTDFL(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY,SENTRY, + > IPRINT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To prepare information for the directional flux. +* +*Copyright: +* Copyright (C) 2009 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* NENTRY number of data structures transfered to this module. +* HENTRY name of the data structures. +* IENTRY data structure type where: +* =1 for LCM memory object; +* =2 for XSM file; +* =3 for sequential binary file; +* =4 for sequential ASCII file. +* JENTRY access permission for the data structure where: +* =0 for a data structure in creation mode; +* =1 for a data structure in modifications mode; +* =2 for a data structure in read-only mode. +* KENTRY data structure pointer. +* SENTRY data structure signature. +* IPRINT print level. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NENTRY + CHARACTER HENTRY(NENTRY)*12 + TYPE(C_PTR) KENTRY(NENTRY) + INTEGER IENTRY(NENTRY),JENTRY(NENTRY) + CHARACTER SENTRY(NENTRY)*12 + INTEGER IPRINT +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='FMTDFL') + INTEGER ILCMUP,ILCMDN + PARAMETER (ILCMUP=1,ILCMDN=2) + INTEGER NSTATE + PARAMETER (NSTATE=40) +*---- +* Local variables +*---- + INTEGER IEN,IKFLU,IKTRK + CHARACTER HSIGN*12 + INTEGER ISTATE(NSTATE) + INTEGER NTREG,NFUNL,NLIN,NTUNK,NTANI,ITROP,LTRK + INTEGER NDIM + INTEGER NGROUP,NREG +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KEYFLX + REAL, ALLOCATABLE, DIMENSION(:) :: VOLUME +*---- +* Validate entry parameters +*---- + IF(NENTRY .LT. 3) CALL XABORT(NAMSBR// + > ': At least three data structures required for this option.') +*---- +* Output structure +*---- + IEN=1 + IF(IENTRY(IEN) .EQ. 4) THEN + IF(JENTRY(IEN) .EQ. 2) CALL XABORT(NAMSBR// + > ': Data structure not in update or creation mode.') + IF(JENTRY(IEN) .EQ. 1) REWIND(FILUNIT(KENTRY(IEN))) + ELSE + CALL XABORT(NAMSBR// + > ': Invalid data structure format for '//HENTRY(IEN)//'.') + ENDIF +*---- +* Input structure +*---- + IKTRK=0 + DO IEN=2,NENTRY + IF(IENTRY(IEN) .EQ. 1 .OR. IENTRY(IEN) .EQ. 2) THEN + IF(JENTRY(IEN) .NE. 2) CALL XABORT(NAMSBR// + > ': Data structure not in read-only mode.') + IF(SENTRY(IEN) .EQ. 'L_FLUX') THEN + IKFLU=IEN + ELSE IF(SENTRY(IEN) .EQ. 'L_TRACK') THEN + IKTRK=IEN + CALL LCMGTC(KENTRY(IEN),'TRACK-TYPE',12,HSIGN) + IF((HSIGN .NE. 'EXCELL').AND.(HSIGN .NE. 'MCCG')) THEN + CALL XABORT(NAMSBR//': Only EXCELL type tracking valid.') + ENDIF + ELSE + CALL XABORT(NAMSBR// + > ': Invalid signature for '//HENTRY(IEN)//'.') + ENDIF + ELSE + CALL XABORT(NAMSBR// + > ': Invalid data structure format for '//HENTRY(IEN)//'.') + ENDIF + ENDDO +*---- +* Get STATE-VECTOR from FLUX data structure +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(KENTRY(IKFLU),'STATE-VECTOR',ISTATE) + NGROUP=ISTATE(1) + NREG=ISTATE(2) +*---- +* Get STATE-VECTOR from VOLTRK data structure +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(KENTRY(IKTRK),'STATE-VECTOR',ISTATE) + NTREG=ISTATE(1) + NTUNK=ISTATE(2) + NTANI=ISTATE(6) + ITROP=ISTATE(7) + LTRK=ISTATE(9) + CALL LCMGET(KENTRY(IKTRK),'MCCG-STATE',ISTATE) + NFUNL=ISTATE(19) + NLIN=ISTATE(20) + IF(NTUNK .NE. NREG) CALL XABORT(NAMSBR// + >': Number of unknowns in VOLTRK and FLUX inconsistent.') + IF(ITROP .NE. 4) CALL XABORT(NAMSBR// + >': Only NXT: tracking permitted.') + ALLOCATE(VOLUME(NTREG),KEYFLX(NTREG*NFUNL*NLIN)) + CALL LCMGET(KENTRY(IKTRK),'VOLUME ',VOLUME) + CALL LCMGET(KENTRY(IKTRK),'KEYFLX ',KEYFLX) + CALL LCMSIX(KENTRY(IKTRK),'NXTRecords ',ILCMUP) + ISTATE(:NSTATE)=0 + CALL LCMGET(KENTRY(IKTRK),'G00000001DIM',ISTATE) + NDIM=ISTATE(1) + CALL LCMSIX(KENTRY(IKTRK),' ',ILCMDN) +*---- +* Process information +*---- + CALL FMTDFD(NENTRY,KENTRY,IPRINT,IKFLU ,NTREG , + > NREG ,NGROUP,NDIM ,VOLUME,KEYFLX) +*---- +* Release memory and return +*---- + DEALLOCATE(VOLUME,KEYFLX) + RETURN + END diff --git a/Dragon/src/FMTGET.f b/Dragon/src/FMTGET.f new file mode 100644 index 0000000..e0540d0 --- /dev/null +++ b/Dragon/src/FMTGET.f @@ -0,0 +1,125 @@ +*DECK FMTGET + SUBROUTINE FMTGET(IPRINT,NOPT,IOPT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To read formatting command for the FMT module. +* +*Copyright: +* Copyright (C) 2009 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input/output +* IPRINT print level. +* NOPT number of options. +* IOPT processing option. +* +*Comments: +* Input data is of the form: +* [ EDIT iprint ] +* { +* SUS3D { SN | CP } | +* DIRFLX +* BURNUP +* } +* +*---------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,NOPT,IOPT(NOPT) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='FMTGET') +*---- +* Variables for input via REDGET +*---- + INTEGER ITYPLU,INTLIR + CHARACTER CARLIR*12 + REAL REALIR + DOUBLE PRECISION DBLLIR +*---- +* Initialize default values for IPRINT +*---- + IPRINT=1 +*---- +* Get data from input file +*---- + 100 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + 110 CONTINUE + IF(ITYPLU .EQ. 10) GO TO 105 + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + >': Read error -- Character variable expected.') + IF(CARLIR .EQ. ';') THEN + GO TO 105 + ELSE IF(CARLIR .EQ. 'EDIT') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': Read error -- print level expected after EDIT.') + IPRINT=INTLIR + ELSE IF(CARLIR .EQ. 'SUS3D') THEN + IF(IOPT(1) .NE. 0) CALL XABORT(NAMSBR// + > ': Only one formatting option permitted.') + IOPT(1)=1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + > ': Read error -- Character variable for SUS3D option.') + IOPT(2)=0 + IF(CARLIR .EQ. 'CP') THEN + IOPT(2)=1 + ELSE IF(CARLIR .EQ. 'SN') THEN + IOPT(2)=0 + ELSE + GO TO 110 + ENDIF + ELSE IF(CARLIR .EQ. 'DIRFLX') THEN + IF(IOPT(1) .NE. 0) CALL XABORT(NAMSBR// + > ': Only one formatting option permitted.') + IOPT(1)=2 + ELSE IF(CARLIR .EQ. 'BURNUP') THEN + IF(IOPT(1) .NE. 0) CALL XABORT(NAMSBR// + > ': Only one formatting option permitted.') + IOPT(1)=3 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + > ': Read error -- Character variable for BURNUP option.') + IOPT(2)=1 + IF(CARLIR .EQ. 'PYTHON') THEN + IOPT(2)=2 + ELSE IF(CARLIR .EQ. 'MATLAB') THEN + IOPT(2)=1 + ELSE IF(CARLIR .EQ. 'ISOP') THEN + IOPT(2)=-IOPT(2) + GO TO 105 + ELSE + GO TO 110 + ENDIF + ELSE IF(CARLIR .EQ. 'ISOP') THEN + IF(IOPT(1) .NE. 3) CALL XABORT(NAMSBR// + > ': BURNUP option not specified.') + IOPT(2)=-IOPT(2) + GO TO 105 + ELSE + CALL XABORT(NAMSBR//': Keyword '//CARLIR//' is invalid.') + ENDIF + GO TO 100 + 105 CONTINUE +*---- +* Processing finished, return +*---- + RETURN + END diff --git a/Dragon/src/FMTGIS.f b/Dragon/src/FMTGIS.f new file mode 100644 index 0000000..8e0ae80 --- /dev/null +++ b/Dragon/src/FMTGIS.f @@ -0,0 +1,134 @@ +*DECK FMTGIS + SUBROUTINE FMTGIS(IPRINT,NBISO,NAMISO,MISPRT,NAMRD, + > NOPT,IOPT,ISOPRT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read and process isotopes to print. +* +*Copyright: +* Copyright (C) 2017 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPRINT print level. +* NBISO number of isotopes on BURNUP. +* NAMISO names of isotopes on BURNUP. +* NOPT number of options. +* IOPT processing option. +* +*Parameters: output +* MISPRT number of isotopes to print. +* NAMRD isotopes names to process. +* ISOPRT isotopes print option. +* +*---------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,NBISO + INTEGER NAMISO(3,NBISO) + INTEGER MISPRT,NOPT,IOPT(NOPT) + INTEGER NAMRD(2,NBISO),ISOPRT(NBISO) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='FMTGIS') +*---- +* Variables for input via REDGET +*---- + INTEGER ITYPLU,INTLIR + CHARACTER CARLIR*12 + REAL REALIR + DOUBLE PRECISION DBLLIR +*---- +* Local variables +*---- + INTEGER ISOR,ISOT,II,KISPRT +*---- +* Get data from input file +*---- + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + IF(IOPT(2).LT. 0) THEN + IOPT(2)=-IOPT(2) + ISOR=0 + 100 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .EQ. 10) GO TO 105 + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + > ': Read error -- Character variable expected.') + IF(CARLIR .EQ. ';') THEN + GO TO 105 + ELSE + ISOR=ISOR+1 + READ(CARLIR,'(2A4)') (NAMRD(II,ISOR),II=1,2) + ENDIF + GO TO 100 + 105 CONTINUE + ELSE + ISOR=-1 + ENDIF +*---- +* All isotopes specified. +* Set print flag +*---- + MISPRT=ISOR + ISOPRT(:NBISO)=0 + IF(MISPRT .EQ. 0) THEN + KISPRT=0 + DO ISOT=1,NBISO + DO ISOR=1,KISPRT + IF(NAMISO(1,ISOT) .EQ. NAMRD(1,ISOR) .AND. + > NAMISO(2,ISOT) .EQ. NAMRD(2,ISOR)) THEN + ISOPRT(ISOT)=ISOR + GO TO 115 + ENDIF + ENDDO + KISPRT=KISPRT+1 + NAMRD(1,KISPRT)=NAMISO(1,ISOT) + NAMRD(2,KISPRT)=NAMISO(2,ISOT) + ISOPRT(ISOT)=KISPRT + 115 CONTINUE + ENDDO + MISPRT=KISPRT + ELSE + IF(MISPRT.GT.0) THEN + DO ISOT=1,NBISO + DO ISOR=1,MISPRT + IF(NAMISO(1,ISOT) .EQ. NAMRD(1,ISOR) .AND. + > NAMISO(2,ISOT) .EQ. NAMRD(2,ISOR)) THEN + ISOPRT(ISOT)=ISOR + GO TO 125 + ENDIF + ENDDO + 125 CONTINUE + ENDDO + ENDIF + ENDIF + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* Processing finished, return +*---- + RETURN +*---- +* FORMATS +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + END diff --git a/Dragon/src/FMTSUD.f b/Dragon/src/FMTSUD.f new file mode 100644 index 0000000..b41b72d --- /dev/null +++ b/Dragon/src/FMTSUD.f @@ -0,0 +1,421 @@ +*DECK FMTSUD + SUBROUTINE FMTSUD(NENTRY,IENTRY,KENTRY,IPRINT,NOPT,IOPT,IKFLU, + > NREG ,NGROUP,NDIM ,POLOAQ,AZMOAQ, + > VOLUME,XPOL ,WPOL ,XAZI ,WAZI , + > FLUX ,AFLUX ,TFLUX ,WGHT ,MU ,ETA ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To process the angular fluxes and generate the SUS3D file. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +* +*Author(s): +* G. Marleau +* +*Parameters: input +* NENTRY number of data structures transfered to this module. +* IENTRY data structure type where: +* =1 for LCM memory object; +* =2 for XSM file; +* =3 for sequential binary file; +* =4 for sequential ASCII file. +* KENTRY data structure pointer. +* IPRINT print level. +* NOPT number of options. +* IOPT processing option. +* IKFLU pointer to the FLUX data structure. +* NREG number of regions for problem. +* NGROUP number of groups for problem. +* NDIM number of dimensions of problem. +* POLOAQ polar quadrature order. +* AZMOAQ azimuthal quadrature order. +* VOLUME regional volumes. +* XPOL polar quadrature points. +* WPOL polar quadrature weights. +* XAZI azimuthal quadrature points. +* WAZI azimuthal quadrature weights. +* +*Parameters: output +* FLUX direct and adjoint flux. +* AFLUX angular components of the direct and adjoint flux. +* TFLUX temporary flux vector. +* WGHT temporary weight. +* MU temporary mu. +* ETA temporary eta. +* +*---------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) KENTRY(NENTRY) + INTEGER NENTRY,IENTRY(NENTRY) + INTEGER IPRINT,NOPT,IOPT(NOPT),IKFLU + INTEGER NREG,NGROUP,NDIM,POLOAQ,AZMOAQ + REAL VOLUME(NREG),XPOL(POLOAQ,2),WPOL(POLOAQ), + > XAZI(NDIM,AZMOAQ),WAZI(AZMOAQ) + REAL FLUX(NREG,2,NGROUP,2) + DOUBLE PRECISION AFLUX(NREG,POLOAQ,AZMOAQ*2,2,NGROUP) + DOUBLE PRECISION TFLUX(NREG+1,POLOAQ,AZMOAQ*2) + REAL WGHT(POLOAQ*AZMOAQ*2),MU(POLOAQ*AZMOAQ*2), + > ETA(POLOAQ*AZMOAQ*2) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='FMTSUD') + INTEGER ILCMUP,ILCMDN + PARAMETER (ILCMUP=1,ILCMDN=2) +*---- +* Local variables +*---- + TYPE(C_PTR) IPU + INTEGER IFPU,IAPU,IFORM,IGROUP,IKU,IAKU,NAZ,IA,IP,IR,IQUA + CHARACTER*12 NAMREC + REAL RELERR,ERRMAX,ETATMP,FNORM +*---- +* Initialize FLUX vectors +*---- + NAZ=AZMOAQ + DO IP=1,POLOAQ + XPOL(IP,2)=SQRT(1.-XPOL(IP,1)*XPOL(IP,1)) + ENDDO + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6000) NAMSBR,NGROUP,NDIM,2*AZMOAQ,POLOAQ,NREG + WRITE(IOUT,6001) + WRITE(IOUT,6011) + > (XAZI(1,IA),XAZI(2,IA),WAZI(IA),IA=1,AZMOAQ) + WRITE(IOUT,6002) + WRITE(IOUT,6011) + > (XPOL(IP,1),XPOL(IP,2),WPOL(IP),IP=1,POLOAQ) + ENDIF + FLUX(:NREG,:2,:NGROUP,:2)=0.0 + AFLUX(:NREG,:POLOAQ,:AZMOAQ*2,:2,:NGROUP)=0.0D0 +*---- +* Get information from FLUX data structure. +* 1. Flux +* 2. Angular flux +* 3. Adjoint +* 4. Angular adjoint +*---- + IPU=KENTRY(IKFLU) + CALL LCMSIX(IPU,'FLUXDIRECT ',ILCMUP) + DO IGROUP=1,NGROUP + WRITE(NAMREC,'(A4,I3,5X)') 'FLUX',IGROUP + CALL LCMGET(IPU,NAMREC,FLUX(1,1,IGROUP,1)) + ENDDO + CALL LCMSIX(IPU,'ANGULAR DIR ',ILCMUP) + DO IGROUP=1,NGROUP + WRITE(NAMREC,'(A5,I3,4X)') 'AFLUX',IGROUP + CALL LCMGET(IPU,NAMREC,AFLUX(1,1,1,1,IGROUP)) + ENDDO + CALL LCMSIX(IPU,'ANGULAR DIR ',ILCMDN) + CALL LCMSIX(IPU,'FLUXDIRECT ',ILCMDN) + CALL LCMSIX(IPU,'FLUXADJOINT ',ILCMUP) + DO IGROUP=1,NGROUP + WRITE(NAMREC,'(A4,I3,5X)') 'FLUX',IGROUP + CALL LCMGET(IPU,NAMREC,FLUX(1,2,IGROUP,1)) + ENDDO + CALL LCMSIX(IPU,'ANGULAR ADJ ',ILCMUP) + DO IGROUP=1,NGROUP + WRITE(NAMREC,'(A5,I3,4X)') 'AFLUX',IGROUP + CALL LCMGET(IPU,NAMREC,AFLUX(1,1,1,2,IGROUP)) + ENDDO + CALL LCMSIX(IPU,'ANGULAR ADJ ',ILCMDN) + CALL LCMSIX(IPU,'FLUXADJOINT ',ILCMDN) +*---- +* Create first SUS file +* Volume, and tracking directions +*---- + IFPU=FILUNIT(KENTRY(1)) + WRITE(IFPU,1000) NREG + WRITE(IFPU,1001) 2*AZMOAQ*POLOAQ +*---- +* -\Omega (\varphi+\pi,\pi-\theta) +*---- + IQUA=0 + DO IA=1,AZMOAQ + ETATMP=XAZI(2,NAZ+1-IA) + IF(ETATMP .EQ. 0.0) THEN + ETATMP=1.0E-10 + ENDIF + DO IP=1,POLOAQ + IQUA=IQUA+1 + MU(IQUA)=-XPOL(IP,2)*XAZI(1,NAZ+1-IA) + ETA(IQUA)=-XPOL(IP,2)*ETATMP + WGHT(IQUA)=WPOL(IP)/WAZI(NAZ+1-IA) + ENDDO + ENDDO +*---- +* +\Omega (\varphi,\theta) +*---- + DO IA=1,AZMOAQ + ETATMP=XAZI(2,IA) + IF(ETATMP .EQ. 0.0) THEN + ETATMP=1.0E-10 + ENDIF + DO IP=1,POLOAQ + IQUA=IQUA+1 + MU(IQUA)=XPOL(IP,2)*XAZI(1,IA) + ETA(IQUA)=XPOL(IP,2)*ETATMP + WGHT(IQUA)=WPOL(IP)/WAZI(IA) + ENDDO + ENDDO + WRITE(IFPU,1010) 'wght', + > (WGHT(IQUA),IQUA=1,POLOAQ*AZMOAQ*2) + WRITE(IFPU,1010) 'mu ', + > (MU(IQUA),IQUA=1,POLOAQ*AZMOAQ*2) + WRITE(IFPU,1010) 'eta ', + > (ETA(IQUA),IQUA=1,POLOAQ*AZMOAQ*2) + WRITE(IFPU,1010) 'vol ', + > (VOLUME(IR),IR=1,NREG) +*---- +* Print angular flux +*---- + IFPU=FILUNIT(KENTRY(2)) + IKU=IENTRY(2) + IFORM=IOPT(2) + ERRMAX=0.0 + IF(IKU .EQ. 3) THEN + DO IGROUP=1,NGROUP + WRITE(IFPU) 'Group',IGROUP + ENDDO + DO IGROUP=NGROUP+1,NGROUP+6 + WRITE(IFPU) 'Comments' + ENDDO + ELSE + DO IGROUP=1,NGROUP + WRITE(IFPU,'(A8,4X,I8)') 'Groups =',IGROUP + ENDDO + DO IGROUP=NGROUP+1,NGROUP+6 + WRITE(IFPU,'(A8)') 'Comments' + ENDDO + ENDIF + DO IGROUP=1,NGROUP + DO IA=1,AZMOAQ*2 + DO IP=1,POLOAQ + IF(IFORM .EQ. 1) THEN + DO IR=1,NREG + TFLUX(IR,IP,IA)=AFLUX(IR,IP,IA,1,IGROUP) + IF(IA .LE. AZMOAQ) THEN + FLUX(IR,1,IGROUP,2)=FLUX(IR,1,IGROUP,2) + > +REAL(AFLUX(IR,IP,IA,1,IGROUP)*WPOL(IP)/WAZI(NAZ+1-IA)) + ELSE + FLUX(IR,1,IGROUP,2)=FLUX(IR,1,IGROUP,2) + > +REAL(AFLUX(IR,IP,IA,1,IGROUP)*WPOL(IP)/WAZI(IA-NAZ)) + ENDIF + ENDDO + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6003) IP,IA,IGROUP + WRITE(IOUT,6010) (TFLUX(IR,IP,IA),IR=1,NREG) + ENDIF + ELSE + IR=1 + TFLUX(IR,IP,IA)=AFLUX(IR,IP,IA,1,IGROUP) + DO IR=1,NREG + TFLUX(IR+1,IP,IA)= + > 2.0D0*AFLUX(IR,IP,IA,1,IGROUP)-TFLUX(IR,IP,IA) + IF(IA .LE. AZMOAQ) THEN + FLUX(IR,1,IGROUP,2)=FLUX(IR,1,IGROUP,2) + > +REAL(AFLUX(IR,IP,IA,1,IGROUP)*WPOL(IP)/WAZI(NAZ+1-IA)) + ELSE + FLUX(IR,1,IGROUP,2)=FLUX(IR,1,IGROUP,2) + > +REAL(AFLUX(IR,IP,IA,1,IGROUP)*WPOL(IP)/WAZI(IA-NAZ)) + ENDIF + ENDDO + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6003) IP,IA,IGROUP + WRITE(IOUT,6010) + > ((TFLUX(IR,IP,IA)+TFLUX(IR+1,IP,IA))/2.0,IR=1,NREG) + ENDIF + ENDIF + ENDDO + ENDDO + IF(IFORM .EQ. 1) THEN + IF(IKU .EQ. 3) THEN + WRITE(IFPU) (((TFLUX(IR,IP,IA),IR=1,NREG), + > IP=1,POLOAQ),IA=1,AZMOAQ) + WRITE(IFPU) (((TFLUX(IR,IP,IA),IR=1,NREG), + > IP=1,POLOAQ),IA=AZMOAQ*2,AZMOAQ+1,-1) + ELSE + WRITE(IFPU,1002) (((TFLUX(IR,IP,IA),IR=1,NREG), + > IP=1,POLOAQ),IA=1,AZMOAQ) + WRITE(IFPU,1002) (((TFLUX(IR,IP,IA),IR=1,NREG), + > IP=1,POLOAQ),IA=AZMOAQ*2,AZMOAQ+1,-1) + ENDIF + ELSE + IF(IKU .EQ. 3) THEN + WRITE(IFPU) (((TFLUX(IR,IP,IA),IR=1,NREG+1), + > IP=1,POLOAQ),IA=1,AZMOAQ) + WRITE(IFPU) (((TFLUX(IR,IP,IA),IR=1,NREG+1), + > IP=1,POLOAQ),IA=AZMOAQ*2,AZMOAQ+1,-1) + ELSE + WRITE(IFPU,1002) (((TFLUX(IR,IP,IA),IR=1,NREG+1), + > IP=1,POLOAQ),IA=1,AZMOAQ) + WRITE(IFPU,1002) (((TFLUX(IR,IP,IA),IR=1,NREG+1), + > IP=1,POLOAQ),IA=AZMOAQ*2,AZMOAQ+1,-1) + ENDIF + ENDIF + ENDDO + IF(IPRINT .GE. 10) THEN + FNORM=FLUX(1,1,1,2)/FLUX(1,1,1,1) + DO IGROUP=1,NGROUP + WRITE(6,6030) IGROUP + DO IR=1,NREG + RELERR=100.0*(FLUX(IR,1,IGROUP,2) + > -FNORM*FLUX(IR,1,IGROUP,1)) + > /FLUX(IR,1,IGROUP,2) + ERRMAX=MAX(ERRMAX,ABS(RELERR)) + IF(IPRINT .GE. 20) THEN + WRITE(6,6031) IR,FNORM*FLUX(IR,1,IGROUP,1), + > FLUX(IR,1,IGROUP,2),RELERR + ENDIF + ENDDO + ENDDO + WRITE(6,6020) ERRMAX + ENDIF +*---- +* Print angular adjoint +*---- + IAPU=FILUNIT(KENTRY(3)) + IAKU=IENTRY(3) + ERRMAX=0.0 + IF(IAKU .EQ. 3) THEN + DO IGROUP=NGROUP,1,-1 + WRITE(IAPU) 'Group',IGROUP + ENDDO + DO IGROUP=NGROUP+1,NGROUP+6 + WRITE(IAPU) 'Comments' + ENDDO + ELSE + DO IGROUP=NGROUP,1,-1 + WRITE(IAPU,'(A8,4X,I8)') 'Groups =',IGROUP + ENDDO + DO IGROUP=NGROUP+1,NGROUP+6 + WRITE(IAPU,'(A8)') 'Comments' + ENDDO + ENDIF + DO IGROUP=NGROUP,1,-1 + DO IA=1,AZMOAQ*2 + DO IP=1,POLOAQ + IF(IFORM .EQ. 1) THEN + DO IR=1,NREG + TFLUX(IR,IP,IA)=AFLUX(IR,IP,IA,2,IGROUP) + IF(IA .LE. AZMOAQ) THEN + FLUX(IR,2,IGROUP,2)=FLUX(IR,2,IGROUP,2) + > +REAL(AFLUX(IR,IP,IA,2,IGROUP)*WPOL(IP)/WAZI(NAZ+1-IA)) + ELSE + FLUX(IR,2,IGROUP,2)=FLUX(IR,2,IGROUP,2) + > +REAL(AFLUX(IR,IP,IA,2,IGROUP)*WPOL(IP)/WAZI(IA-NAZ)) + ENDIF + ENDDO + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6004) IP,IA,IGROUP + WRITE(IOUT,6010) (TFLUX(IR,IP,IA),IR=1,NREG) + ENDIF + ELSE + IR=1 + TFLUX(IR,IP,IA)=AFLUX(IR,IP,IA,2,IGROUP) + DO IR=1,NREG + TFLUX(IR+1,IP,IA)= + > 2.0D0*AFLUX(IR,IP,IA,2,IGROUP)-TFLUX(IR,IP,IA) + IF(IA .LE. AZMOAQ) THEN + FLUX(IR,2,IGROUP,2)=FLUX(IR,2,IGROUP,2) + > +REAL(AFLUX(IR,IP,IA,2,IGROUP)*WPOL(IP)/WAZI(NAZ+1-IA)) + ELSE + FLUX(IR,2,IGROUP,2)=FLUX(IR,2,IGROUP,2) + > +REAL(AFLUX(IR,IP,IA,2,IGROUP)*WPOL(IP)/WAZI(IA-NAZ)) + ENDIF + ENDDO + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6004) IP,IA,IGROUP + WRITE(IOUT,6010) + > ((TFLUX(IR,IP,IA)+TFLUX(IR+1,IP,IA))/2.0,IR=1,NREG) + ENDIF + ENDIF + ENDDO + ENDDO + IF(IFORM .EQ. 1) THEN + IF(IAKU .EQ. 3) THEN + WRITE(IAPU) (((TFLUX(IR,IP,IA),IR=1,NREG), + > IP=1,POLOAQ),IA=1,AZMOAQ) + WRITE(IAPU) (((TFLUX(IR,IP,IA),IR=1,NREG), + > IP=1,POLOAQ),IA=AZMOAQ*2,AZMOAQ+1,-1) + ELSE + WRITE(IAPU,1002) (((TFLUX(IR,IP,IA),IR=1,NREG), + > IP=1,POLOAQ),IA=1,AZMOAQ) + WRITE(IAPU,1002) (((TFLUX(IR,IP,IA),IR=1,NREG), + > IP=1,POLOAQ),IA=AZMOAQ*2,AZMOAQ+1,-1) + ENDIF + ELSE + IF(IAKU .EQ. 3) THEN + WRITE(IAPU) (((TFLUX(IR,IP,IA),IR=1,NREG+1), + > IP=1,POLOAQ),IA=1,AZMOAQ) + WRITE(IAPU) (((TFLUX(IR,IP,IA),IR=1,NREG+1), + > IP=1,POLOAQ),IA=AZMOAQ*2,AZMOAQ+1,-1) + ELSE + WRITE(IAPU,1002) (((TFLUX(IR,IP,IA),IR=1,NREG+1), + > IP=1,POLOAQ),IA=1,AZMOAQ) + WRITE(IAPU,1002) (((TFLUX(IR,IP,IA),IR=1,NREG+1), + > IP=1,POLOAQ),IA=AZMOAQ*2,AZMOAQ+1,-1) + ENDIF + ENDIF + ENDDO + IF(IPRINT .GE. 10) THEN + FNORM=FLUX(1,2,1,2)/FLUX(1,2,1,1) + DO IGROUP=NGROUP,1,-1 + WRITE(6,6032) IGROUP + DO IR=1,NREG + RELERR=100.0*(FLUX(IR,2,IGROUP,2) + > -FNORM*FLUX(IR,2,IGROUP,1)) + > /FLUX(IR,1,IGROUP,2) + ERRMAX=MAX(ERRMAX,ABS(RELERR)) + IF(IPRINT .GE. 20) THEN + WRITE(6,6031) IR,FNORM*FLUX(IR,2,IGROUP,1), + > FLUX(IR,2,IGROUP,2),RELERR + ENDIF + ENDDO + ENDDO + WRITE(6,6020) ERRMAX + ENDIF +*---- +* Processing finished, return +*---- + RETURN +*---- +* Formats +*---- + 1000 FORMAT('Number of regions =',I5) + 1001 FORMAT('Nomber of angles =',I5) + 1002 FORMAT(1P,5E20.10) + 1010 FORMAT(A4,1P/(3E15.7)) + 6000 FORMAT('Output from routine ',A6/ + > 'Number of groups =',I5/ + > 'Number of dimens =',I5/ + > 'Number of azimuth =',I5/ + > 'Number of polar =',I5/ + > 'Number of regions =',I5) + 6001 FORMAT('Azimuthal quadrature') + 6002 FORMAT('Polar quadrature') + 6003 FORMAT('Polar =',I5,2X,'Azim = ',I5,2X,'Group = ',I5/ + > 'Direct angular flux per region ') + 6004 FORMAT('Polar =',I5,2X,'Azim = ',I5,2X,'Group = ',I5/ + > 'Adjoint angular flux per region') + 6010 FORMAT(1P,5E20.10) + 6011 FORMAT(1P,3E20.10) + 6020 FORMAT('Maximum relative on flux (%) = ',F15.7) + 6030 FORMAT(' Flux for group ',I5) + 6031 FORMAT(' Region ',I5,1P,2E20.10,5X,0P,F20.10) + 6032 FORMAT(' Adjoint for group ',I5) + END diff --git a/Dragon/src/FMTSUS.f b/Dragon/src/FMTSUS.f new file mode 100644 index 0000000..6777fd9 --- /dev/null +++ b/Dragon/src/FMTSUS.f @@ -0,0 +1,208 @@ +*DECK FMTSUS + SUBROUTINE FMTSUS(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY,SENTRY, + > IPRINT,NOPT,IOPT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To prepare information for the SUS3D code. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +* +*Author(s): +* G. Marleau +* +*Parameters: input +* NENTRY number of data structures transfered to this module. +* HENTRY name of the data structures. +* IENTRY data structure type where: +* =1 for LCM memory object; +* =2 for XSM file; +* =3 for sequential binary file; +* =4 for sequential ASCII file. +* JENTRY access permission for the data structure where: +* =0 for a data structure in creation mode; +* =1 for a data structure in modifications mode; +* =2 for a data structure in read-only mode. +* KENTRY data structure pointer. +* SENTRY data structure signature. +* IPRINT print level. +* NOPT number of options. +* IOPT processing option. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NENTRY + CHARACTER HENTRY(NENTRY)*12 + TYPE(C_PTR) KENTRY(NENTRY) + INTEGER IENTRY(NENTRY),JENTRY(NENTRY) + CHARACTER SENTRY(NENTRY)*12 + INTEGER IPRINT,NOPT,IOPT(NOPT) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='FMTSUS') + INTEGER ILCMUP,ILCMDN + PARAMETER (ILCMUP=1,ILCMDN=2) + INTEGER NSTATE + PARAMETER (NSTATE=40) +*---- +* Local variables +*---- + INTEGER IEN,IKFLU,IKTRK + CHARACTER HSIGN*12 + INTEGER ISTATE(NSTATE) + INTEGER NTREG,NTUNK,NTANI,ITROP,LTRK, + > AZMOAQ,AZMQUA,POLQUA,POLOAQ + INTEGER NDIM + INTEGER ISADJ,NGROUP,NREG,NBAQU + INTEGER LCMLN,LCMTY +*---- +* Allocatable arrays +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: VOLUME,XPOL,WPOL,XAZI,WAZI, + > FLUX,WGHT,MU,ETA + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: XDAZI,WDAZI,AFLUX, + > TFLUX +*---- +* Validate entry parameters +*---- + IF(NENTRY .LT. 5) CALL XABORT(NAMSBR// + > ': At least five data structures required for this option.') +*---- +* Output structure +*---- + IKTRK=0 + IEN=1 + IF(IENTRY(IEN) .EQ. 4) THEN + IF(JENTRY(IEN) .EQ. 2) CALL XABORT(NAMSBR// + > ': Data structure not in update or creation mode.') + IF(JENTRY(IEN) .EQ. 1) REWIND(FILUNIT(KENTRY(IEN))) + ELSE + CALL XABORT(NAMSBR// + > ': Invalid data structure format for '//HENTRY(IEN)//'.') + ENDIF + DO IEN=2,3 + IF(IENTRY(IEN) .EQ. 3 .OR. IENTRY(IEN) .EQ. 4) THEN + IF(JENTRY(IEN) .EQ. 2) CALL XABORT(NAMSBR// + > ': Data structure not in update or creation mode.') + IF(JENTRY(IEN) .EQ. 1) REWIND(FILUNIT(KENTRY(IEN))) + ELSE + CALL XABORT(NAMSBR// + > ': Invalid data structure format for '//HENTRY(IEN)//'.') + ENDIF + ENDDO +*---- +* Input structure +*---- + DO IEN=4,NENTRY + IF(IENTRY(IEN) .EQ. 1 .OR. IENTRY(IEN) .EQ. 2) THEN + IF(JENTRY(IEN) .NE. 2) CALL XABORT(NAMSBR// + > ': Data structure not in read-only mode.') + IF(SENTRY(IEN) .EQ. 'L_FLUX') THEN + IKFLU=IEN + ELSE IF(SENTRY(IEN) .EQ. 'L_TRACK') THEN + IKTRK=IEN + CALL LCMGTC(KENTRY(IEN),'TRACK-TYPE',12,HSIGN) + IF(HSIGN .NE. 'EXCELL') CALL XABORT(NAMSBR// + > ': Only EXCELL type tracking valid.') + ELSE + CALL XABORT(NAMSBR// + > ': Invalid signature for '//HENTRY(IEN)//'.') + ENDIF + ELSE + CALL XABORT(NAMSBR// + > ': Invalid data structure format for '//HENTRY(IEN)//'.') + ENDIF + ENDDO +*---- +* Get STATE-VECTOR from FLUX data structure +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(KENTRY(IKFLU),'STATE-VECTOR',ISTATE) + ISADJ=ISTATE(8) + NGROUP=ISTATE(9) + NREG=ISTATE(10) +*---- +* Get STATE-VECTOR from VOLTRK data structure +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(KENTRY(IKTRK),'STATE-VECTOR',ISTATE) + NTREG=ISTATE(1) + NTUNK=ISTATE(2) + NTANI=ISTATE(6) + ITROP=ISTATE(7) + LTRK=ISTATE(9) + AZMOAQ=ISTATE(11) + POLQUA=ISTATE(13) + POLOAQ=ISTATE(14) + AZMQUA=ISTATE(15) + IF(NTREG .NE. NTUNK) CALL XABORT(NAMSBR// + >': Inconsistent number of regions and unknowns.') + IF(NTREG .NE. NREG) CALL XABORT(NAMSBR// + >': Number of unknowns in VOLTRK and FLUX inconsistent.') + IF(ITROP .NE. 4) CALL XABORT(NAMSBR// + >': Only NXT: tracking permitted.') + IF(POLQUA .LE. -1) CALL XABORT(NAMSBR// + >': No polar quadrature provided.') + IF(AZMQUA .LE. 0) CALL XABORT(NAMSBR// + >': No azimuthal quadrature provided.') + ALLOCATE(VOLUME(NTREG)) + CALL LCMGET(KENTRY(IKTRK),'VOLUME ',VOLUME) + CALL LCMSIX(KENTRY(IKTRK),'NXTRecords ',ILCMUP) + ISTATE(:NSTATE)=0 + CALL LCMGET(KENTRY(IKTRK),'G00000001DIM',ISTATE) + NDIM=ISTATE(1) +*---- +* Allocate memory for direction and weights and read them +*---- + CALL LCMLEN(KENTRY(IKTRK),'TrackingTrkW',LCMLN,LCMTY) + AZMOAQ=LCMLN/2 + ALLOCATE(XPOL(2*POLOAQ),WPOL(POLOAQ)) + ALLOCATE(XDAZI(NDIM*AZMOAQ),WDAZI(AZMOAQ)) + CALL LCMGET(KENTRY(IKTRK),'TrackingDirc',XDAZI) + CALL LCMGET(KENTRY(IKTRK),'TrackingTrkW',WDAZI) + CALL LCMGET(KENTRY(IKTRK),'POLAR MU ',XPOL) + CALL LCMGET(KENTRY(IKTRK),'POLAR WEIGHT',WPOL) + CALL LCMSIX(KENTRY(IKTRK),'NXTRecords ',ILCMDN) + ALLOCATE(XAZI(NDIM*AZMOAQ),WAZI(AZMOAQ)) + CALL XDRSDB(NDIM*AZMOAQ,XAZI,XDAZI,1) + CALL XDRSDB(AZMOAQ,WAZI,WDAZI,1) + DEALLOCATE(WDAZI,XDAZI) +*---- +* Allocate memory for integrated and angular flux +*--- + NBAQU=POLOAQ*AZMOAQ*2 + ALLOCATE(FLUX(NREG*2*NGROUP*2),WGHT(POLOAQ*AZMOAQ*2), + > MU(POLOAQ*AZMOAQ*2),ETA(POLOAQ*AZMOAQ*2)) + ALLOCATE(AFLUX(NREG*NBAQU*2*NGROUP),TFLUX((NREG+1)*NBAQU)) +*---- +* Process information +*---- + CALL FMTSUD(NENTRY,IENTRY,KENTRY,IPRINT,NOPT,IOPT,IKFLU, + > NREG ,NGROUP,NDIM ,POLOAQ,AZMOAQ, + > VOLUME,XPOL ,WPOL , XAZI ,WAZI , + > FLUX ,AFLUX ,TFLUX, WGHT ,MU ,ETA ) +*---- +* Release memory and return +*---- + DEALLOCATE(ETA,MU,WGHT,TFLUX,AFLUX,FLUX,WAZI,XAZI,WPOL,XPOL, + > VOLUME) + RETURN +*---- +* Warning formats +*---- + END diff --git a/Dragon/src/FSDF.f90 b/Dragon/src/FSDF.f90 new file mode 100644 index 0000000..06f5b69 --- /dev/null +++ b/Dragon/src/FSDF.f90 @@ -0,0 +1,190 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Fortran-2003 bindings for the NDAS C API. +! +!Copyright: +! Copyright (C) 2012 Atomic Energy of Canada Limited and Ecole +! Polytechnique de Montreal. +! +!Author(s): A. Hebert +! +!----------------------------------------------------------------------- +! +module FSDF + private + public :: XSDOPN, XSDNAM, XSDBLD, XSDISO, XSDTHE, XSDRES, XSDTAB, XSDCL + interface XSDBLD + module procedure XSDBLD_I1, XSDBLD_R1 + end interface + interface XSDISO + module procedure XSDISO_I1, XSDISO_R1 + end interface +contains +subroutine XSDOPN(namfil, ierr) + ! open the NDAS file + use, intrinsic :: iso_c_binding + use LCMAUX + character(len=*) :: namfil + integer ierr + character(kind=c_char), dimension(73) :: name73 + interface + subroutine xsdopn_c(namp, ierr) bind(c) + use, intrinsic :: iso_c_binding + character(kind=c_char), dimension(*) :: namp + integer(c_int) :: ierr + end subroutine xsdopn_c + end interface + call STRCUT(name73, namfil) + call xsdopn_c(name73, ierr) +end subroutine XSDOPN +! +subroutine XSDNAM(iset, numericId, isonam, ierr) + ! recover an isotope name from NDAS file + use LCMAUX + use, intrinsic :: iso_c_binding + integer iset,numericId, ierr + character(len=*) :: isonam + character(kind=c_char), dimension(73) :: name73 + interface + subroutine xsdnam_c(iset, numericId, namp, ierr) bind(c) + use, intrinsic :: iso_c_binding + character(kind=c_char), dimension(*) :: namp + integer(c_int) :: iset,numericId,ierr + end subroutine xsdnam_c + end interface + call xsdnam_c(iset, numericId, name73, ierr) + call STRFIL(isonam, name73) +end subroutine XSDNAM +! +subroutine XSDBLD_I1(item, where, ierr) + ! recover a header or integer record from NDAS file + use, intrinsic :: iso_c_binding + type(c_ptr) :: pt_where + integer item,ierr + integer, target, dimension(*) :: where + integer, pointer :: where_p + interface + subroutine xsdbld_c(item, where, ierr) bind(c) + use, intrinsic :: iso_c_binding + integer(c_int) :: item, ierr + type(c_ptr), value :: where + end subroutine xsdbld_c + end interface + where_p => where(1) + pt_where=c_loc(where_p) + call xsdbld_c(item, pt_where, ierr) +end subroutine XSDBLD_I1 +! +subroutine XSDBLD_R1(item, where, ierr) + ! recover a header or real record from NDAS file + use, intrinsic :: iso_c_binding + type(c_ptr) :: pt_where + integer item,ierr + real, target, dimension(*) :: where + real, pointer :: where_p + interface + subroutine xsdbld_c(item, where, ierr) bind(c) + use, intrinsic :: iso_c_binding + integer(c_int) :: item, ierr + type(c_ptr), value :: where + end subroutine xsdbld_c + end interface + where_p => where(1) + pt_where=c_loc(where_p) + call xsdbld_c(item, pt_where, ierr) +end subroutine XSDBLD_R1 +! +subroutine XSDISO_I1(groupRange, item, nuclideIndex, where, ierr) + ! recover an integer header for an isotope + use, intrinsic :: iso_c_binding + type(c_ptr) :: pt_where + integer groupRange, item, nuclideIndex, ierr + integer, target, dimension(*) :: where + integer, pointer :: where_p + interface + subroutine xsdiso_c(groupRange, item, nuclideIndex, where, ierr) bind(c) + use, intrinsic :: iso_c_binding + integer(c_int) groupRange, item, nuclideIndex, ierr + type(c_ptr), value :: where + end subroutine xsdiso_c + end interface + where_p => where(1) + pt_where=c_loc(where_p) + call xsdiso_c(groupRange, item, nuclideIndex, pt_where, ierr) +end subroutine XSDISO_I1 +! +subroutine XSDISO_R1(groupRange, item, nuclideIndex, where, ierr) + ! recover a real header for an isotope + use, intrinsic :: iso_c_binding + type(c_ptr) :: pt_where + integer groupRange, item, nuclideIndex, ierr + real, target, dimension(*) :: where + real, pointer :: where_p + interface + subroutine xsdiso_c(groupRange, item, nuclideIndex, where, ierr) bind(c) + use, intrinsic :: iso_c_binding + integer(c_int) groupRange, item, nuclideIndex, ierr + type(c_ptr), value :: where + end subroutine xsdiso_c + end interface + where_p => where(1) + pt_where=c_loc(where_p) + call xsdiso_c(groupRange, item, nuclideIndex, pt_where, ierr) +end subroutine XSDISO_R1 +! +subroutine XSDTHE(groupRange, item, nuclideIndex, index, where, ierr) + ! recover a cross-section array + use, intrinsic :: iso_c_binding + integer groupRange, item, nuclideIndex, index, ierr + real, dimension(*) :: where + interface + subroutine xsdthe_c(groupRange, item, nuclideIndex, index, where, ierr) bind(c) + use, intrinsic :: iso_c_binding + integer(c_int) groupRange, item, nuclideIndex, index, ierr + real(c_float), dimension(*) :: where + end subroutine xsdthe_c + end interface + call xsdthe_c(groupRange, item, nuclideIndex, index, where, ierr) +end subroutine XSDTHE +! +subroutine XSDRES(nuclideIndex, where, ierr) + ! recover a resonance information array + use, intrinsic :: iso_c_binding + integer nuclideIndex, ierr + integer, dimension(*) :: where + interface + subroutine xsdres_c(nuclideIndex, where, ierr) bind(c) + use, intrinsic :: iso_c_binding + integer(c_int) nuclideIndex, ierr + integer(c_int), dimension(*) :: where + end subroutine xsdres_c + end interface + call xsdres_c(nuclideIndex, where, ierr) +end subroutine XSDRES +! +subroutine XSDTAB(item, nuclideIndex, resGroup, where, ierr) + ! recover a resonance cross-section array + use, intrinsic :: iso_c_binding + integer item, nuclideIndex, resGroup, ierr + real, dimension(*) :: where + interface + subroutine xsdtab_c(item, nuclideIndex, resGroup, where, ierr) bind(c) + use, intrinsic :: iso_c_binding + integer(c_int) item, nuclideIndex, resGroup, ierr + real(c_float), dimension(*) :: where + end subroutine xsdtab_c + end interface + call xsdtab_c(item, nuclideIndex, resGroup, where, ierr) +end subroutine XSDTAB +! +subroutine XSDCL() + ! close the NDAS file + interface + subroutine xsdcl_c() bind(c) + end subroutine xsdcl_c + end interface + call xsdcl_c() +end subroutine XSDCL +end module FSDF diff --git a/Dragon/src/GEO.f b/Dragon/src/GEO.f new file mode 100644 index 0000000..bd3d9a0 --- /dev/null +++ b/Dragon/src/GEO.f @@ -0,0 +1,84 @@ +*DECK GEO + SUBROUTINE GEO(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Geometry definition operator. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): create or modification type(L_GEOM). +* HENTRY(2): optional read-only type(L_GEOM). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + CHARACTER TEXT12*12,TEXT13*12 + TYPE(C_PTR) IPLIST +*---- +* PARAMETER VALIDATION +*---- + IF(NENTRY.EQ.0) CALL XABORT('GEO: PARAMETER EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('GEO: LCM O' + 1 //'BJECT EXPECTED AT LHS.') + IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) CALL XABORT('GEO: CREAT' + 1 //'E OR MODIFICATION MODE EXPECTED.') + ITYPE=JENTRY(1) + IPLIST=KENTRY(1) +* + IMPX=1 + IF((ITYPE.EQ.0).AND.(NENTRY.GT.1)) THEN +* CREATE A NEW GEOMETRY BASED ON AN EXISTING ONE. + IF(JENTRY(2).NE.2) CALL XABORT('GEO: RHS GEOMETRY EXPECTED OPE' + 1 //'N IN READ-ONLY MODE.') + IF((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2)) CALL XABORT('GEO: LC' + 1 //'M OBJECT EXPECTED AT RHS.') + CALL LCMGTC(KENTRY(2),'SIGNATURE',12,TEXT12) + IF(TEXT12.NE.'L_GEOM') THEN + TEXT13=HENTRY(2) + CALL XABORT('GEO: SIGNATURE OF '//TEXT13//' IS '//TEXT12// + 1 '. L_GEOM EXPECTED(1).') + ENDIF + CALL LCMEQU(KENTRY(2),IPLIST) + ELSE IF(ITYPE.EQ.1) THEN +* MODIFY AN EXISTING GEOMETRY USING THE SAME NAME. + CALL LCMGTC(IPLIST,'SIGNATURE',12,TEXT12) + IF(TEXT12.NE.'L_GEOM') THEN + TEXT13=HENTRY(1) + CALL XABORT('GEO: SIGNATURE OF '//TEXT13//' IS '//TEXT12// + 1 '. L_GEOM EXPECTED(2).') + ENDIF + ENDIF +* + TEXT12='/' + CALL GEOIN1 (TEXT12,IPLIST,1,IMPX,MAXMIX) + RETURN + END diff --git a/Dragon/src/GEOIN1.f b/Dragon/src/GEOIN1.f new file mode 100644 index 0000000..4b42df3 --- /dev/null +++ b/Dragon/src/GEOIN1.f @@ -0,0 +1,1375 @@ +*DECK GEOIN1 + RECURSIVE SUBROUTINE GEOIN1 (GEONAM,IPLIST,LEVEL,IMPX,MAXMIX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read and/or modify an object oriented geometry. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* GEONAM name of the directory where the geometry is stored. +* IPLIST pointer to the geometry LCM object (L_GEOM signature). +* LEVEL hierarchical level of the geometry. +* IMPX print flag (IMPX=0 for no print). +* +*Parameters: output +* MAXMIX maximum number of mixtures, considering all sub-geometries. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIST + INTEGER LEVEL,IMPX,MAXMIX + CHARACTER GEONAM*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MAXCOD=21,MAXHEX=9,MAXTEX=4,MAXTUR=12,MAXTYP=30, + 1 MXCL=500,NSTATE=40,IOUT=6) + LOGICAL LHEX,LTRI,EMPTY,LCM,SWANG + LOGICAL LTOT,LHOT,LCOUR + CHARACTER NAMT*12,COND(MAXCOD)*4,CHEX(MAXHEX)*8,CHET(MAXTEX)*8, + 1 CTUR(MAXTUR)*1,TYPE(0:MAXTYP)*16,TEXT4*4,CARLIR*12,TEXT12*12, + 2 DIR*1,HSMG*131 + INTEGER, ALLOCATABLE, DIMENSION(:) :: ISTATE,JSTATE,NCODE,ICODE + REAL, ALLOCATABLE, DIMENSION(:) :: ZCODE + DOUBLE PRECISION DBLLIR,DREALIR + INTEGER, ALLOCATABLE, DIMENSION(:) :: CELL,MIX,ISECT,IMESH,MERGE, + 1 ITURN,NS,MILIE,MIXDL,MIXGR + REAL, ALLOCATABLE, DIMENSION(:) :: MESH,CYL,CENT,XR0,RR0,ANG, + 1 ARPIN,RS,FRACT,POURC,PROCE + INTEGER IMIXHT,NRINGH,NZ,NAP1,NSETM,KREG,JREG,ITRI,IAN +*---- +* Data +*---- + SAVE COND,CHEX,CTUR,TYPE + DATA COND + > /'VOID','REFL','DIAG','TRAN','SYME', + > 'ALBE','ZERO','PI/2','PI' ,'SSYM', + > 9*' ','CYLI','ACYL'/ + DATA CHEX + > /'S30 ','SA60 ','SB60 ','S90 ','R120 ', + > 'R180 ','SA180 ','SB180 ','COMPLETE'/ + DATA CTUR + > /'A','B','C','D','E','F','G','H','I','J','K','L'/ + DATA TYPE + > /'VIRTUAL ','HOMOGENEOUS ','CARTESIAN 1-D ', + > 'TUBE 1-D ','SPHERE 1-D ','CARTESIAN 2-D ', + > 'TUBE 2-D (Z) ','CARTESIAN 3-D ','HEXAGONAL 2-D ', + > 'HEXAGONE 3-D (Z)','TUBE 2-D (X) ','TUBE 2-D (Y) ', + > 'HEX/TRIANGLE 2D ','HEX/TRIANGLE 3D ',' ', + > 'R-THETA ','TRIANGULAR 2-D ','TRIANGULAR 3-D ', + > ' ',' ','2-D RECT. CELL ', + > '3-D RECT. CELL X','3-D RECT. CELL Y','3-D RECT. CELL Z', + > '2-D HEX. CELL ','3-D HEX. CELL Z ','2-D HEXT CELL ', + > '3-D HEXT CELL Z ',' ',' ', + > 'DO-IT-YOURSELF '/ +* + ALLOCATE(ISTATE(NSTATE),JSTATE(NSTATE),NCODE(6),ICODE(6)) + ALLOCATE(ZCODE(6)) + IMIXHT=0 + MINMIX=0 + MINICO=1 + NPIN=0 + IRLYZ=0 + LR=0 + LX=0 + LY=0 + LZ=0 + LREG=0 + CALL LCMLEN(IPLIST,'SIGNATURE',ILONG,ITYX) + IF(ILONG.EQ.0) THEN +* INPUT A NEW GEOMETRY. + ISTATE(:NSTATE)=0 + LHEX=.FALSE. + LTRI=.FALSE. + LCOUR=.FALSE. + DO 20 I=1,6 + NCODE(I)=0 + ZCODE(I)=0.0 + ICODE(I)=0 + 20 CONTINUE + ELSE +* MODIFY AN EXISTING GEOMETRY. + CALL LCMGTC(IPLIST,'SIGNATURE',12,CARLIR) + IF(CARLIR.NE.'L_GEOM') THEN + NAMT=GEONAM + CALL XABORT('GEOIN1: SIGNATURE OF '//NAMT//' IS '//CARLIR + 1 //'. L_GEOM EXPECTED.') + ENDIF + CALL LCMGET(IPLIST,'STATE-VECTOR',ISTATE) + LR=ISTATE(2) + LX=ISTATE(3) + LY=ISTATE(4) + LZ=ISTATE(5) + LREG=ISTATE(6) + LHEX=(ISTATE(1).EQ. 8) .OR. (ISTATE(1) .EQ. 9) .OR. + 1 (ISTATE(1).EQ.12) .OR. (ISTATE(1) .EQ.13) .OR. + 2 (ISTATE(1).EQ.24) .OR. (ISTATE(1) .EQ.25) .OR. + 3 (ISTATE(1).EQ.26) .OR. (ISTATE(1) .EQ.27) + LTRI=(ISTATE(1).EQ.16).OR.(ISTATE(1).EQ.17) + LCOUR=.FALSE. + IF(LHEX) THEN + CALL LCMGET(IPLIST,'IHEX',IHEX) + LCOUR=IHEX.EQ.9 + ENDIF + CALL LCMGET(IPLIST,'NCODE',NCODE) + CALL LCMGET(IPLIST,'ZCODE',ZCODE) + CALL LCMGET(IPLIST,'ICODE',ICODE) + IF((LEVEL.EQ.1).AND.(ISTATE(1).EQ.0)) THEN + GO TO 30 + ELSE IF(LEVEL.EQ.1) THEN + GO TO 50 + ENDIF + ENDIF +* + 30 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('GEOIN1: CHARACTER DATA EXPECTED(1).') + IF(CARLIR.EQ.'VIRTUAL') THEN + ISTATE(1)=0 + ELSE IF(CARLIR.EQ.'HOMOGE') THEN + ISTATE(1)=1 + LREG=1 + ELSE IF(CARLIR.EQ.'CAR1D') THEN + ISTATE(1)=2 + CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + LREG=LX + ELSE IF(CARLIR.EQ.'SPHERE') THEN + ISTATE(1)=4 + CALL REDGET(ITYPLU,LR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + LREG=LR + ELSE IF(CARLIR.EQ.'CAR2D') THEN + ISTATE(1)=5 + CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + CALL REDGET(ITYPLU,LY,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + LREG=LX*LY + ELSE IF(CARLIR.EQ.'CAR3D') THEN + ISTATE(1)=7 + CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + CALL REDGET(ITYPLU,LY,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + CALL REDGET(ITYPLU,LZ,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + LREG=LX*LY*LZ + ELSE IF(CARLIR.EQ.'HEX') THEN + ISTATE(1)=8 + LHEX=.TRUE. + CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + LREG=LX + ELSE IF(CARLIR.EQ.'HEXZ') THEN + ISTATE(1)=9 + LHEX=.TRUE. + CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + CALL REDGET(ITYPLU,LZ,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + LREG=LX*LZ + ELSE IF(CARLIR.EQ.'HEXT') THEN + IMIXHT=1 + ISTATE(1)=12 + LHEX=.TRUE. + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + NRINGH=MAX(1,INTLIR) + LX=NRINGH + LREG=6*NRINGH*NRINGH + ELSE IF(CARLIR.EQ.'HEXTZ') THEN + IMIXHT=2 + ISTATE(1)=13 + LHEX=.TRUE. + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + NRINGH=MAX(1,INTLIR) + LX=NRINGH + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + LZ=INTLIR + LREG=6*NRINGH*NRINGH*LZ + ELSE IF(CARLIR.EQ.'RTHETA') THEN + ISTATE(1)=15 + CALL REDGET(ITYPLU,LR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + CALL REDGET(ITYPLU,LZ,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + LREG=LR*LZ + ELSE IF(CARLIR.EQ.'TRI') THEN + ISTATE(1)=16 + LTRI=.TRUE. + CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + LREG=LX + ELSE IF(CARLIR.EQ.'TRIZ') THEN + ISTATE(1)=17 + LTRI=.TRUE. + CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + CALL REDGET(ITYPLU,LZ,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + LREG=LX*LZ + ELSE IF(CARLIR(1:4).EQ.'TUBE') THEN + DIR=CARLIR(5:5) + CALL REDGET(ITYPLU,LR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + IF(DIR.EQ.' ') THEN + ISTATE(1)=3 + LX=1 + LY=1 + IRLXY=1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.3) THEN + IRLXY=0 + ELSE IF(ITYPLU.EQ.2) THEN + CALL XABORT('GEOIN1: INVALID REAL DATA.') + ELSE + LX=INTLIR + CALL REDGET(ITYPLU,LY,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTE' + 1 //'D.') + ENDIF + LREG=LR*LY*LX + IF(IRLXY.EQ.0) GO TO 60 + ELSE + LX=1 + LY=1 + LZ=1 + CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.3) THEN + IRLYZ=0 + ELSE IF(ITYPLU.EQ.2) THEN + CALL XABORT('GEOIN1: REAL DATA NOT EXPECTED.') + ELSE + LY=INTLIR + IRLYZ=1 + CALL REDGET(ITYPLU,LZ,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTE' + 1 //'D.') + ENDIF + LREG=LR*LY*LZ*LX + IF(DIR.EQ.'X') THEN + ISTATE(1)=10 + IF(IRLYZ.EQ.0) GO TO 60 + ELSE IF(DIR.EQ.'Y') THEN + ISTATE(1)=11 + IF(IRLYZ.EQ.0) THEN + LY=LX + LX=1 + GO TO 60 + ENDIF + ELSE IF(DIR.EQ.'Z') THEN + ISTATE(1)=6 + IF(IRLYZ.EQ.0) THEN + LZ=LX + LX=1 + GO TO 60 + ENDIF + ELSE + CALL XABORT('GEOIN1: INVALID DATA IN TUBE CONSTRUCT.') + ENDIF + ENDIF + ELSE IF(CARLIR(1:6).EQ.'CARCEL') THEN + CALL REDGET(ITYPLU,LR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + DIR=CARLIR(7:7) + IF(DIR.EQ.' ') THEN + ISTATE(1)=20 + LX=1 + LY=1 + IRLXY=1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.3) THEN + IRLXY=0 + ELSE IF(ITYPLU.EQ.2) THEN + CALL XABORT('GEOIN1: INVALID REAL DATA.') + ELSE + LX=INTLIR + CALL REDGET(ITYPLU,LY,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTE' + 1 //'D.') + ENDIF + LREG=(LR+1)*LY*LX + IF(IRLXY.EQ.0) GO TO 60 + ELSE + LX=1 + LY=1 + LZ=1 + CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.3) THEN + IRLYZ=0 + ELSE IF(ITYPLU.EQ.2) THEN + CALL XABORT('GEOIN1: INVALID REAL DATA.') + ELSE + LY=INTLIR + IRLYZ=1 + CALL REDGET(ITYPLU,LZ,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTE' + 1 //'D.') + ENDIF + LREG=(LR+1)*LY*LZ*LX + IF(DIR.EQ.'X') THEN + ISTATE(1)=21 + ELSE IF(DIR.EQ.'Y') THEN + ISTATE(1)=22 + IF(IRLYZ.EQ.0) THEN + LY=LX + LX=1 + GO TO 60 + ENDIF + ELSE IF(DIR.EQ.'Z') THEN + ISTATE(1)=23 + IF(IRLYZ.EQ.0) THEN + LZ=LX + LX=1 + GO TO 60 + ENDIF + ELSE + CALL XABORT('GEOIN1: INVALID DATA.') + ENDIF + ENDIF + ELSE IF(CARLIR(1:6).EQ.'HEXCEL') THEN + LHEX=.TRUE. + CALL REDGET(ITYPLU,LR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + LX=1 + IF(CARLIR(7:7).EQ.' ') THEN + ISTATE(1)=24 + LREG=LR+1 + ELSE IF(CARLIR(7:7).EQ.'Z') THEN + ISTATE(1)=25 + CALL REDGET(ITYPLU,LZ,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + LREG=(LR+1)*LZ + ELSE + CALL XABORT('GEOIN1: INVALID SUFFIX FOR HEXCEL.') + ENDIF + ELSE IF(CARLIR(1:7).EQ.'HEXTCEL') THEN + IMIXHT=1 + LHEX=.TRUE. + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1'// + > ': Number of annular regions missing.') + LR=INTLIR + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1'// + > ': Number of triangular crowns missing.') + NRINGH=MAX(1,INTLIR) + LX=NRINGH + LREG=6*NRINGH*NRINGH*(LR+1) + IF(CARLIR(8:8).EQ.' ') THEN + ISTATE(1)=26 + ELSE IF(CARLIR(8:8).EQ.'Z') THEN + IMIXHT=2 + ISTATE(1)=27 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1'// + > ': Number of z planes missing.') + LZ=INTLIR + LREG=LREG*LZ + ELSE + CALL XABORT('GEOIN1: INVALID SUFFIX FOR HEXTCEL.') + ENDIF + ELSE IF(CARLIR.EQ.'GROUP') THEN +* DO-IT-YOURSELF OPTION. + ISTATE(1)=30 + CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + LREG=LX + ELSE IF(CARLIR.EQ.':::') THEN + GO TO 60 + ELSE IF(CARLIR.NE.GEONAM) THEN +* COPY ATTRIBUTES FROM AN EXISTING GEOMETRY LOCATED ON A PARALLEL +* DIRECTORY OF THE LCM OBJECT POINTED BY IPLIST. + IF(LEVEL.EQ.1) CALL XABORT('GEOIN1: THE GEOMETRY NAME SHOULD A' + 1 //'PPEAR BEFORE THE ::.') + CALL LCMSIX(IPLIST,' ',2) + CALL LCMLEN(IPLIST,CARLIR,ILONG,ITYX) + IF(ILONG.EQ.0) THEN + WRITE(HSMG,'(26HGEOIN1: UNKNOWN GEOMETRY (,A,2H).)') CARLIR + CALL XABORT(HSMG) + ENDIF + CALL LCMSIX(IPLIST,CARLIR,1) + IFILE=KDROPN('DUMMYSQ',0,2,0) + IF(IFILE.LE.0) CALL XABORT('GEOIN1: KDROPN FAILURE.') + CALL LCMEXP(IPLIST,0,IFILE,1,1) + REWIND(IFILE) + CALL LCMSIX(IPLIST,' ',2) + CALL LCMSIX(IPLIST,GEONAM,1) + CALL LCMEXP(IPLIST,0,IFILE,1,2) + IRC=KDRCLS(IFILE,2) + IF(IRC.LT.0) CALL XABORT('GEOIN1: KDRCLS FAILURE.') + CALL LCMGET(IPLIST,'STATE-VECTOR',ISTATE) + LR=ISTATE(2) + LX=ISTATE(3) + LY=ISTATE(4) + LZ=ISTATE(5) + LREG=ISTATE(6) + LHEX=(ISTATE(1).EQ. 8) .OR. (ISTATE(1) .EQ. 9) .OR. + 1 (ISTATE(1).EQ.12) .OR. (ISTATE(1) .EQ.13) .OR. + 2 (ISTATE(1).EQ.24) .OR. (ISTATE(1) .EQ.25) .OR. + 3 (ISTATE(1).EQ.26) .OR. (ISTATE(1) .EQ.27) + LTRI=(ISTATE(1).EQ.16).OR.(ISTATE(1).EQ.17) + CALL LCMGET(IPLIST,'NCODE',NCODE) + CALL LCMGET(IPLIST,'ZCODE',ZCODE) + CALL LCMGET(IPLIST,'ICODE',ICODE) + ENDIF +* + 50 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('GEOIN1: CHARACTER DATA EXPECTED(2).') + 60 IF(CARLIR.EQ.'EDIT') THEN + CALL REDGET(ITYPLU,IMPX,REALIR,CARLIR,DREALIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + ELSE IF((CARLIR.EQ.'MIX').OR.(CARLIR.EQ.'CELL')) THEN +* INPUT MIXTURE NUMBERS OR FORCE SUB GEOMETRIES AT SPECIFIC +* LOCATIONS. + ALLOCATE(CELL(3*LREG),MIX(LREG)) + MIX(:LREG)=0 + LTOT=.TRUE. + I=0 + IKG=0 + 70 I=I+1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.3) THEN + IF(CARLIR.EQ.'PLANE') THEN + IF(I.EQ.1) THEN + IF(ISTATE(1).EQ.7.OR.ISTATE(1).EQ.9) THEN + IF(ISTATE(1).EQ.9) LY=1 + CALL GEOMIX(LX,LY,LZ,LCOUR,MIX,MINMIX,ISTATE(7)) + LTOT=.FALSE. + GO TO 70 + ELSE + CALL XABORT('GEOIN1: INVALID KEY WORD PLANE FOR NON ' + 1 //' 3-D GEOMETRY') + ENDIF + ELSE + CALL XABORT('GEOIN1: WRONG USE OF KEYWORD PLANE.') + ENDIF + ENDIF + IF((CARLIR(2:2).EQ.'-').OR.(CARLIR(2:2).EQ.'+').OR. + 1 (CARLIR.EQ.'HBC').OR.(CARLIR(1:4).EQ.'MESH').OR. + 2 (CARLIR(1:5).EQ.'SPLIT').OR.(CARLIR.EQ.'SIDE').OR. + 3 (CARLIR(:3).EQ.'MIX').OR.(CARLIR.EQ.'MERGE').OR. + 4 (CARLIR.EQ.'TURN').OR.(CARLIR.EQ.'CLUSTER').OR. + 5 (CARLIR(2:4).EQ.'PIN').OR.(CARLIR.EQ.'BIHET').OR. + 6 (CARLIR.EQ.'POURCE').OR.(CARLIR.EQ.'PROCEL').OR. + 7 (CARLIR.EQ.'SECT').OR.(CARLIR.EQ.'RADIUS').OR. + 8 (CARLIR.EQ.'HMIX').OR.(CARLIR.EQ.';').OR. + 9 (CARLIR.EQ.':::')) GO TO 90 + IF(I.GT.LREG) CALL XABORT('GEOIN1: MIX/CELL INDEX OVERFLO' + 1 //'W.') + DO 80 J=1,I-1 + JKG=-MIX(J) + WRITE (TEXT12(:4),'(A4)') CELL(3*(JKG-1)+1) + WRITE (TEXT12(5:8),'(A4)') CELL(3*(JKG-1)+2) + WRITE (TEXT12(9:),'(A4)') CELL(3*(JKG-1)+3) + IF(CARLIR.EQ.TEXT12) THEN + MIX(I)=-JKG + GO TO 70 + ENDIF + 80 CONTINUE + IKG=IKG+1 + ISTATE(8)=1 + MIX(I)=-IKG + READ (CARLIR(:4),'(A4)') CELL(3*(IKG-1)+1) + READ (CARLIR(5:8),'(A4)') CELL(3*(IKG-1)+2) + READ (CARLIR(9:),'(A4)') CELL(3*(IKG-1)+3) + ELSE IF(ITYPLU.EQ.1) THEN + IF(I.GT.LREG) CALL XABORT('GEOIN1: MIX INDEX OVERFLOW.') + MIX(I)=INTLIR + ISTATE(7)=MAX(ISTATE(7),MIX(I)) + MINMIX=MIN(MINMIX,MIX(I)) + ELSE + CALL XABORT('GEOIN1: INTEGER OR CHARACTER DATA EXPECTED.') + ENDIF + GO TO 70 + 90 CONTINUE + IF(CARLIR.EQ.'REPEAT') THEN + NBR=LREG/(I-1) + NBRR=NBR*(I-1) + IF(NBRR.NE.LREG) THEN + WRITE(IOUT,530) I-1,LREG + CALL XABORT('GEOIN1: IMPOSSIBLE TO REPEAT AN INTEGER NUMB' + 1 //'ER OF TIMES.') + ENDIF + JREP=I-1 + DO IREP=1,NBR-1 + DO II=1,I-1 + JREP=JREP+1 + MIX(JREP)=MIX(II) + ENDDO + ENDDO + I=JREP+1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('GEOIN1: CHARACTER DATA EXPECTE' + 1 //'D.') + ENDIF +*-- Begin symmetric mixtures for HEXT, HEXTZ, HEXTCEL and HEXTCELZ + IF(IMIXHT .GT. 0) THEN + IF(I-1 .NE. LREG) THEN + LTOT=.FALSE. + NRINGH=LX + NZ=MAX(LZ,1) + NAP1=LR+1 + NSETM=NRINGH*NZ*NAP1 + IF(I-1 .EQ. NSETM) THEN +*---- +* Mixture given per hexagonal rings +* create compatible complete mix array +*---- + KREG=LREG + DO IZ=NZ,1,-1 + DO IS=6,1,-1 + DO IR=NRINGH,1,-1 + JREG=(IZ-1)*NRINGH+IR-1 + DO ITRI=2*IR-1,1,-1 + DO IAN=NAP1,1,-1 + MREG=JREG*NAP1+IAN + MIX(KREG)=MIX(MREG) + KREG=KREG-1 + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + IF(KREG.NE.0) CALL XABORT('GEOIN1'// + > ': Problem with mixture reformatting.') + ELSE IF(I-1 .EQ. 6*NSETM) THEN +*---- +* Mixture given per hexagonal rings and per sector +* Create compatible complete mix array +*---- + KREG=LREG + DO IZ=NZ,1,-1 + DO IS=6,1,-1 + DO IR=NRINGH,1,-1 + JREG=((IZ-1)*6+(IS-1))*NRINGH+IR-1 + DO ITRI=2*IR-1,1,-1 + DO IAN=NAP1,1,-1 + MREG=JREG*NAP1+IAN + MIX(KREG)=MIX(MREG) + KREG=KREG-1 + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + IF(KREG.NE.0) CALL XABORT('GEOIN1'// + > ': Problem with mixture reformatting.') + ELSE + CALL XABORT('GEOIN1'// + > ': Number of mixtures provided is invalid.') + ENDIF + ENDIF + ELSE + ISTATE(6)=I-1 + ENDIF +*-- End symmetric mixtures for HEXT, HEXTZ, HEXTCEL and HEXTCELZ + IF(LTOT) LREG=I-1 + IF(IKG.GT.0) CALL LCMPUT(IPLIST,'CELL',3*IKG,3,CELL) + CALL LCMPUT(IPLIST,'MIX',LREG,1,MIX) + DEALLOCATE(MIX,CELL) + GO TO 60 + ELSE IF(CARLIR.EQ.'HMIX') THEN +* INPUT MERGED MIXTURE NUMBERS for homogenization by geometry. + ALLOCATE(MIX(LREG)) + MIX(:LREG)=0 + LHOT=.TRUE. + I=0 + 540 I=I+1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.3) GO TO 550 + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + IF(I.GT.LREG) GO TO 500 + MIX(I)=INTLIR + GO TO 540 + 550 CONTINUE + IF(CARLIR .EQ. 'REPEAT') THEN + NBR=LREG/(I-1) + NBRR=NBR*(I-1) + IF(NBRR .NE. LREG ) THEN + WRITE(IOUT,530) I-1,LREG + CALL XABORT('GEOIN1: Impossible to repeat an integer numbe' + 1 //'r of times') + ENDIF + JREP=I-1 + DO IREP=1,NBR-1 + DO II=1,I-1 + JREP=JREP+1 + MIX(JREP)=MIX(II) + ENDDO + ENDDO + I=JREP+1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('GEOIN1: CHARACTER DATA EXPECTED') + ENDIF +*-- Begin symmetric H-mixtures for HEXT, HEXTZ, HEXTCEL and HEXTCELZ + IF(IMIXHT .GT. 0) THEN + IF(I-1 .NE. LREG) THEN + LHOT=.FALSE. + NRINGH=LX + NZ=MAX(LZ,1) + NAP1=LR+1 + NSETM=NRINGH*NZ*NAP1 + IF(I-1 .EQ. NSETM) THEN +*---- +* Mixture given per hexagonal rings +* create compatible complete mix array +*---- + KREG=LREG + DO IZ=NZ,1,-1 + DO IS=6,1,-1 + DO IR=NRINGH,1,-1 + JREG=(IZ-1)*NRINGH+IR-1 + DO ITRI=2*IR-1,1,-1 + DO IAN=NAP1,1,-1 + MREG=JREG*NAP1+IAN + MIX(KREG)=MIX(MREG) + KREG=KREG-1 + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + IF(KREG.NE.0) CALL XABORT('GEOIN1'// + > ': Problem with mixture reformatting.') + ELSE IF(I-1 .EQ. 6*NSETM) THEN +*---- +* Mixture given per hexagonal rings and per sector +* Create compatible complete mix array +*---- + KREG=LREG + DO IZ=NZ,1,-1 + DO IS=6,1,-1 + DO IR=NRINGH,1,-1 + JREG=((IZ-1)*6+(IS-1))*NRINGH+IR-1 + DO ITRI=2*IR-1,1,-1 + DO IAN=NAP1,1,-1 + MREG=JREG*NAP1+IAN + MIX(KREG)=MIX(MREG) + KREG=KREG-1 + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + IF(KREG.NE.0) CALL XABORT('GEOIN1'// + > ': Problem with mixture reformatting.') + ELSE + CALL XABORT('GEOIN1'// + > ': Number of mixtures provided is invalid.') + ENDIF + ENDIF + ENDIF +*-- End symmetric H-mixtures for HEXT, HEXTZ, HEXTCEL and HEXTCELZ + IF(LHOT) LREG=I-1 + CALL LCMPUT(IPLIST,'HMIX',LREG,1,MIX) + DEALLOCATE(MIX) + GO TO 60 + ELSE IF(CARLIR(1:4).EQ.'MESH') THEN +* INPUT CARTESIAN COORDINATES. + IF(CARLIR(5:5).EQ.'X') THEN + IF(LX.EQ.0) CALL XABORT('GEOIN1: MESHX - LX=0.') + LMESH=LX+1 + ELSE IF(CARLIR(5:5).EQ.'Y') THEN + IF(LY.EQ.0) CALL XABORT('GEOIN1: MESHY - LY=0.') + LMESH=LY+1 + ELSE IF(CARLIR(5:5).EQ.'Z') THEN + IF(LZ.EQ.0) CALL XABORT('GEOIN1: MESHZ - LZ=0.') + LMESH=LZ+1 + ELSE + CALL XABORT('GEOIN1: INVALID MESH SUFFIX.') + ENDIF + ALLOCATE(MESH(LMESH)) + DO 100 I=1,LMESH + CALL REDGET(ITYPLU,INTLIR,MESH(I),TEXT12,DBLLIR) + IF(ITYPLU.NE.2) THEN + WRITE(TEXT4,'(I4)') LMESH + CALL XABORT('GEOIN1: '//TEXT4//' REAL DATA EXPECTED.(1)') + ENDIF + IF(I.GT.1) THEN + IF(MESH(I).LE.MESH(I-1)) THEN + CALL XABORT('GEOIN1: NON INCREASING MESHES.') + ENDIF + ENDIF + 100 CONTINUE + CALL LCMPUT(IPLIST,CARLIR,LMESH,2,MESH) + DEALLOCATE(MESH) + ELSE IF(CARLIR.EQ.'RADIUS') THEN +* INPUT TUBE RADIUS. + IF(LR.EQ.0) CALL XABORT('GEOIN1: RADIUS WITH LR=0.') + LCYL=LR+1 + ALLOCATE(CYL(LCYL)) + DO 110 I=1,LCYL + CALL REDGET(ITYPLU,INTLIR,CYL(I),CARLIR,DBLLIR) + IF(ITYPLU.NE.2) CALL XABORT('GEOIN1: REAL DATA EXPECTED.(2)') + IF(I.GT.1) THEN + IF(CYL(I).LE.CYL(I-1)) THEN + CALL XABORT('GEOIN1: NON INCREASING RADII.') + ENDIF + ENDIF + 110 CONTINUE + IF(CYL(1).NE.0.0) CALL XABORT('GEOIN1: INVALID FIRST RADI' + 1 //'US.') + CALL LCMPUT(IPLIST,'RADIUS',LCYL,2,CYL) + DEALLOCATE(CYL) + ELSE IF(CARLIR.EQ.'OFFCENTER') THEN +* INPUT TUBE CENTER LOCATION (USE FOR CARCEL* ONLY). + IF(LR.EQ.0) CALL XABORT('GEOIN1: OFFCENTER WITH LR=0.') + ALLOCATE(CENT(3)) + CENT(:3)=0.0 + DO 120 I=1,3 + CALL REDGET(ITYPLU,INTLIR,CENT(I),CARLIR,DBLLIR) + IF(ITYPLU.NE.2) GO TO 130 + 120 CONTINUE + CALL REDGET(ITYPLU,INTLIR,CENT(I),CARLIR,DBLLIR) + 130 CALL LCMPUT(IPLIST,'OFFCENTER',3,2,CENT) + DEALLOCATE(CENT) + GO TO 60 + ELSE IF(CARLIR.EQ.'SIDE') THEN +* INPUT THE SIDE LENGTH IN TRIANGULAR OR HEXAGONAL GEOMETRY. + IF((.NOT.LHEX).AND.(.NOT.LTRI)) CALL XABORT('GEOIN1: SIDE PRO' + 1 //'HIBITED.') + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.2) CALL XABORT('GEOIN1: REAL DATA EXPECTED.(3)') + SIDE=REALIR + CALL LCMPUT(IPLIST,'SIDE',1,2,SIDE) + IF((ISTATE(1).EQ.12).OR.(ISTATE(1).EQ.13).OR. + 1 (ISTATE(1).EQ.26).OR.(ISTATE(1).EQ.27) ) THEN +* Hexagonal mesh for HEXT and HEXTZ + SIDET=SIDE/FLOAT(LX) + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.1) THEN + CALL XABORT('GEOIN1: INVALID INTEGER DATA .') + ELSE IF(ITYPLU.EQ.2) THEN + SIDET=REALIR + HEXMMX=SIDET*FLOAT(LX)-SIDE + IF((HEXMMX.LT.0.0).OR.(HEXMMX.GT.SIDET)) THEN + CALL XABORT('GEOIN1: Invalid sidet, nringh or side ->'// + 1 ' 0 <= sidet*nringh-side <= sidet required') + ENDIF + ENDIF + CALL LCMPUT(IPLIST,'SIDET',1,2,SIDET) + IF(ITYPLU.EQ.3) GO TO 60 + ENDIF + ELSE IF(CARLIR.EQ.'SECT') THEN +* INPUT THE TYPE OF SECTORIZATION. + IF(ISTATE(1).LT.20) CALL XABORT('GEOIN1: SECT PROHIBITED.') + CALL REDGET(ITYPLU,ISTATE(14),REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) THEN + ISTATE(15)=0 + ELSE + IF((INTLIR.LT.0).OR.(INTLIR.GE.LREG)) CALL XABORT('GEOIN1: I' + > //'NVALID VALUE FOR jsect.') + ISTATE(15)=INTLIR + ENDIF + IF((.NOT.LHEX).AND.(ISTATE(14).EQ.-1)) THEN +* X-TYPE SECTORIZATION IN CARTESIAN CELL. + LREG=4*LREG-3*ISTATE(15) + ELSE IF((.NOT.LHEX).AND.(ISTATE(14).EQ.0 )) THEN +* NO SECTORIZATION IN CARTESIAN CELL. + LREG=LREG + ELSE IF((.NOT.LHEX).AND.(ISTATE(14).EQ.1)) THEN +* +-TYPE SECTORIZATION IN CARTESIAN CELL. + LREG=4*LREG-3*ISTATE(15) + ELSE IF((.NOT.LHEX).AND.(ISTATE(14).EQ.2)) THEN +* +-TYPE SECTORIZATION IN CARTESIAN CELL. + LREG=8*LREG-7*ISTATE(15) + ELSE IF((.NOT.LHEX).AND.(ISTATE(14).EQ.3)) THEN +* SHIFTED + AND X-TYPE SECTORIZATION IN CARTESIAN CELL. + LREG=8*LREG-7*ISTATE(15) + ELSE IF((.NOT.LHEX).AND.(ISTATE(14).EQ.4)) THEN +* FULL WINDMILL. + LREG=4+8*LREG-7*ISTATE(15) + ELSE IF(LHEX.AND.(ISTATE(14).EQ.-1)) THEN +* X-TYPE SECTORIZATION IN HEXAGONAL CELL. + ALLOCATE(ISECT(LREG)) + ISECT(:LREG)=2 + CALL LCMPUT(IPLIST,'SECTOR',LREG,1,ISECT) + DEALLOCATE(ISECT) + LREG=6*LREG-5*ISTATE(15) + ELSE IF(ISTATE(14).NE.-999) THEN + CALL XABORT('GEOIN1: INVALID TYPE OF SECTORIZATION.') + ENDIF + IF(ITYPLU.NE.1) GO TO 60 + ELSE IF (CARLIR.EQ.'RADS') THEN +* OPTIONS FOR CYLINDRICAL CORRECTION IN CARTESIAN GEOMETRY. + IF((ISTATE(1).NE.5).AND.(ISTATE(1).NE.7)) CALL XABORT('GEO' + 1 //'IN1: OPTION RADS IS LIMITED TO CARTESIAN GEOMETRIES.') + CALL REDGET(INDIC,NR0,REALIR,TEXT4,DREALIR) + SWANG=TEXT4.EQ.'ANG' + IF(SWANG) CALL REDGET(INDIC,NR0,REALIR,TEXT4,DREALIR) + IF(INDIC.NE.1) CALL XABORT('GEO: INTEGER DATA EXPECTED.') + IF(NR0.EQ.0) CALL XABORT('GEOIN1: NON-ZERO INTEGER EXPECTED.') + ALLOCATE(XR0(NR0),RR0(NR0),ANG(NR0)) + DO 135 I=1,NR0 + CALL REDGET(INDIC,INTLIR,XR0(I),TEXT4,DREALIR) + IF(INDIC.NE.2) CALL XABORT('GEOIN1: REAL DATA EXPECTED.(4)') + CALL REDGET(INDIC,INTLIR,RR0(I),TEXT4,DREALIR) + IF(INDIC.NE.2) CALL XABORT('GEOIN1: REAL DATA EXPECTED.(5)') + IF(SWANG) THEN + CALL REDGET(INDIC,INTLIR,ANG(I),TEXT4,DREALIR) + IF(INDIC.NE.2) CALL XABORT('GEOIN1: REAL DATA EXPECTED.(6)') + ELSE +* USE PI/2 + 0.1 + ANG(I)=1.670796327 + ENDIF + 135 CONTINUE + CALL LCMPUT(IPLIST,'XR0',NR0,2,XR0) + CALL LCMPUT(IPLIST,'RR0',NR0,2,RR0) + CALL LCMPUT(IPLIST,'ANG',NR0,2,ANG) + DEALLOCATE(ANG,RR0,XR0) + ELSE IF(CARLIR(1:5).EQ.'SPLIT') THEN +* INPUT MESH SPLITTING FACTORS. + ISTATE(11)=1 + IF(CARLIR(6:6).EQ.'X') THEN + IF(LX.EQ.0) CALL XABORT('GEOIN1: SPLITX - LX=0.') + LMESH=LX + ELSE IF(CARLIR(6:6).EQ.'Y') THEN + IF(LY.EQ.0) CALL XABORT('GEOIN1: SPLITY - LY=0.') + LMESH=LY + ELSE IF(CARLIR(6:6).EQ.'Z') THEN + IF(LZ.EQ.0) CALL XABORT('GEOIN1: SPLITZ - LZ=0.') + LMESH=LZ + ELSE IF(CARLIR(6:6).EQ.'R') THEN + IF(LR.EQ.0) CALL XABORT('GEOIN1: SPLITR - LR=0.') + LMESH=LR + ELSE IF(CARLIR(6:6).EQ.'H') THEN + IF(LX.EQ.0) CALL XABORT('GEOIN1: SPLITH - LX=0.') + LMESH=1 + ELSE IF(CARLIR(6:6).EQ.'L') THEN + IF(LX.EQ.0) CALL XABORT('GEOIN1: SPLITL - LX=0.') + LMESH=1 + ELSE + CALL XABORT('GEOIN1: INVALID SPLIT SUFFIX.') + ENDIF + ALLOCATE(IMESH(LMESH)) + DO 140 I=1,LMESH + CALL REDGET(ITYPLU,IMESH(I),REALIR,TEXT12,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + IF(CARLIR.EQ.'SPLITR') THEN + IF(IMESH(I).EQ.0) THEN + CALL XABORT('GEOIN1: INVALID MESH-SPLITTING INDEX(1).') + ENDIF + ELSE IF((CARLIR.EQ.'SPLITH').OR.(CARLIR.EQ.'SPLITL')) THEN + IF(IMESH(I).LT.0) THEN + CALL XABORT('GEOIN1: INVALID MESH-SPLITTING INDEX(2).') + ENDIF + ELSE + IF(IMESH(I).LE.0) THEN + CALL XABORT('GEOIN1: INVALID MESH-SPLITTING INDEX(3).') + ENDIF + ENDIF + 140 CONTINUE + CALL LCMPUT(IPLIST,CARLIR,LMESH,1,IMESH) + DEALLOCATE(IMESH) + ELSE IF(CARLIR.EQ.'MERGE') THEN +* INPUT CELL-MERGING ITYPLUES. + ISTATE(10)=1 + ALLOCATE(MERGE(LREG)) + I=0 + 150 I=I+1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.3) GO TO 160 + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + IF(I.GT.LREG) CALL XABORT('GEOIN1: MERGE INDEX OVERFLOW.') + MERGE(I)=INTLIR + GO TO 150 + 160 LREG=I-1 + CALL LCMPUT(IPLIST,'MERGE',LREG,1,MERGE) + DEALLOCATE(MERGE) + GO TO 60 + ELSE IF(CARLIR.EQ.'TURN') THEN +* INPUT ORIENTATION INFORMATION. + ALLOCATE(ITURN(LREG)) + I=0 + 170 I=I+1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('GEOIN1: CHARACTER DATA EXPECTED.') + DO 180 J=1,MAXTUR + IF(CARLIR.EQ.CTUR(J)) THEN + IF(I.GT.LREG) CALL XABORT('GEOIN1: TURN INDEX OVERFLOW(1).') + ITURN(I)=J + GO TO 170 + ELSE IF(CARLIR.EQ.'-'//CTUR(J)) THEN + IF(I.GT.LREG) CALL XABORT('GEOIN1: TURN INDEX OVERFLOW(2).') + ITURN(I)=MAXTUR+J + GO TO 170 + ENDIF + 180 CONTINUE + LREG=I-1 + CALL LCMPUT(IPLIST,'TURN',LREG,1,ITURN) + DEALLOCATE(ITURN) + GO TO 60 + ELSE IF(CARLIR.EQ.'CLUSTER') THEN +* DEFINE CLUSTER SUB GEOMETRIES. + ALLOCATE(CELL(3*MXCL)) + I=0 + 190 I=I+1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('GEOIN1: CHARACTER DATA EXPECTED.') + IF((CARLIR(2:2).EQ.'-').OR.(CARLIR(2:2).EQ.'+').OR. + 1 (CARLIR.EQ.'HBC').OR.(CARLIR(1:4).EQ.'MESH').OR.(CARLIR(1:5) + 2 .EQ.'SPLIT').OR.(CARLIR.EQ.'SIDE').OR.(CARLIR(:3).EQ.'MIX').OR. + 3 (CARLIR.EQ.'CELL').OR.(CARLIR.EQ.'MERGE').OR.(CARLIR.EQ.'TURN') + 4 .OR.(CARLIR(2:4).EQ.'PIN').OR.(CARLIR.EQ.'BIHET').OR. + 5 (CARLIR.EQ.'POURCE').OR.(CARLIR.EQ.'PROCEL').OR. + 6 (CARLIR.EQ.'SECT').OR.(CARLIR.EQ.'RADIUS').OR. + 7 (CARLIR.EQ.'HMIX').OR.(CARLIR.EQ.';').OR.(CARLIR.EQ.':::')) + 8 GO TO 200 + IF(I.GT.MXCL) CALL XABORT('GEOIN1: CLUSTER INDEX OVERFLOW.') + READ (CARLIR(:4),'(A4)') CELL(3*(I-1)+1) + READ (CARLIR(5:8),'(A4)') CELL(3*(I-1)+2) + READ (CARLIR(9:),'(A4)') CELL(3*(I-1)+3) + GO TO 190 + 200 CALL LCMPUT(IPLIST,'CLUSTER',3*(I-1),3,CELL) + ISTATE(13)=I-1 + DEALLOCATE(CELL) + GO TO 60 + ELSE IF(CARLIR(2:4).EQ.'PIN') THEN + IF(ISTATE(1) .NE. 3 .AND. ISTATE(1) .NE. 6 .AND. + 1 ISTATE(1) .NE. 10 .AND. ISTATE(1) .NE. 11 .AND. + 2 ISTATE(1) .NE. 4) GO TO 500 + IF(CARLIR.EQ.'NPIN') THEN + IF(NPIN.EQ.-1) CALL XABORT('GEOIN1: NPIN and DPIN cannot be ' + 1 //'used simultneously') +* INPUT NUMBER OF PINS IN CLUSTER RING. + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + IF(INTLIR.LT.1) CALL XABORT('GEOIN1: NPIN > 0 required.') + NPIN=INTLIR + CALL LCMPUT(IPLIST,'NPIN',1,1,NPIN) + ELSE IF(NAMT.EQ.'DPIN') THEN + IF(NPIN.GE.1) CALL XABORT('GEOIN1: NPIN and DPIN cannot be u' + 1 //'sed simultneously') +* INPUT DENSITY OF PIN IN CLUSTER. + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.2) CALL XABORT('GEOIN1: REAL DATA EXPECTED FOR ' + 1 //NAMT//' KEYWORD.') + NPIN=-1 + DPIN=REALIR + ISTATE(18)=-1 + CALL LCMPUT(IPLIST,'NPIN',1,1,NPIN) + CALL LCMPUT(IPLIST,'DPIN',1,2,DPIN) + ELSE IF((CARLIR.EQ.'RPIN').OR.(CARLIR.EQ.'APIN')) THEN + IF(NPIN.EQ.-1) THEN + CALL XABORT('GEOIN1: RPIN and APIN not compatible with DPI' + 1 //'N') + ELSE IF(NPIN.EQ.0) THEN + CALL XABORT('GEOIN1: NPIN required before RPIN and APIN ar' + 1 //'e defined') + ENDIF + IF(ISTATE(18) .EQ. 2) CALL XABORT('GEOIN1: CPIN* cannot be m' + 1 //'ixed with RPIN and APIN') + ISTATE(18)=1 + NAMT=CARLIR +*---- +* Allocate memory for APIN or RPIN +*---- + ALLOCATE(ARPIN(NPIN)) +* INPUT RADIUS/ANGLE OF CLUSTER RING. + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.2) CALL XABORT('GEOIN1: REAL DATA EXPECTED.(7)') + ARPIN(1)=REALIR + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.2) THEN + CALL LCMPUT(IPLIST,NAMT,1,2,ARPIN) + DEALLOCATE(ARPIN) + GO TO 60 + ENDIF + IF(NPIN.EQ.1) CALL XABORT('GEOIN1: Only one APIN or RPIN per' + 1 //'mitted.') + ARPIN(2)=REALIR + DO IPIN=2,NPIN-1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.2) CALL XABORT('GEOIN1: REAL DATA EXPECTED.' + 1 //'(8)') + ARPIN(IPIN+1)=REALIR + ENDDO + CALL LCMPUT(IPLIST,NAMT,NPIN,2,ARPIN) + DEALLOCATE(ARPIN) + ELSE IF(CARLIR(1:4).EQ.'CPIN') THEN + IF(NPIN.EQ.-1) THEN + CALL XABORT('GEOIN1: CPIN* not compatible with DPIN') + ELSE IF(NPIN.EQ.0) THEN + CALL XABORT('GEOIN1: NPIN required before CPIN* is defined') + ENDIF + IF(ISTATE(18).EQ.1) CALL XABORT('GEOIN1: CPIN* cannot be mix' + 1 //'ed with RPIN and APIN') + ISTATE(18)=2 + IF(CARLIR(5:5). NE. 'X' .AND. + 1 CARLIR(5:5). NE. 'Y' .AND. + 2 CARLIR(5:5). NE. 'Z' ) THEN + CALL XABORT('GEOIN1: Only CPINX, CPINY and CPINZ permit' + 1 //'ted -- '//CARLIR(1:5)//' provided') + ENDIF + NAMT=CARLIR +*---- +* Allocate memory for CPIN +*---- + ALLOCATE(ARPIN(NPIN)) +* INPUT Cartesian positions of pins. + DO IPIN=0,NPIN-1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.2) CALL XABORT('GEOIN1: REAL CPIN DATA EXPECT' + 1 //'ED.') + ARPIN(IPIN+1)=REALIR + ENDDO + CALL LCMPUT(IPLIST,NAMT,NPIN,2,ARPIN) + DEALLOCATE(ARPIN) + ENDIF + ELSE IF(CARLIR.EQ.'BIHET') THEN +* DOUBLE HETEROGENEITY OPTION. + ISTATE(12)=1 + IF(LEVEL.NE.1) CALL XABORT('GEOIN1: BIHET DATA SHOULD BE WRI' + 1 //'TTEN ON FIRST DIRECTORY LEVEL.') + CALL LCMSIX(IPLIST,'BIHET',1) + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('GEOIN1: CHARACTER DATA EXPECTED.') + MICRO=0 + IF(CARLIR.EQ.'TUBE') THEN + MICRO=3 + ELSE IF(CARLIR.EQ.'SPHE') THEN + MICRO=4 + ELSE + CALL XABORT('GEOIN1: PROHIBITED TYPE OF MICRO GEOMETRY.') + ENDIF + CALL REDGET(ITYPLU,NG,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + CALL REDGET(ITYPLU,NMILG,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') +* + ALLOCATE(NS(NG)) + NSMAX=0 + DO 210 I=1,NG + CALL REDGET(ITYPLU,NS(I),REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + NSMAX=MAX(NSMAX,NS(I)) + 210 CONTINUE + CALL LCMPUT(IPLIST,'NS',NG,1,NS) +* + ALLOCATE(RS((NSMAX+1)*NG)) + DO 220 IOFJ=1,(NSMAX+1)*NG + RS(IOFJ)=0.0 + 220 CONTINUE + DO 235 I=1,NG + DO 230 J=1,NS(I)+1 + IOFJ=(I-1)*(NSMAX+1)+J + CALL REDGET(ITYPLU,INTLIR,RS(IOFJ),CARLIR,DBLLIR) + IF(ITYPLU.NE.2) CALL XABORT('GEOIN1: REAL DATA EXPECTED.(9)') + 230 CONTINUE + 235 CONTINUE + CALL LCMPUT(IPLIST,'RS',(NSMAX+1)*NG,2,RS) + DEALLOCATE(RS) +* + ALLOCATE(MILIE(NMILG)) + DO 240 I=1,NMILG + CALL REDGET(ITYPLU,MILIE(I),REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + 240 CONTINUE + CALL LCMPUT(IPLIST,'MILIE',NMILG,1,MILIE) + DEALLOCATE(MILIE) +* + ALLOCATE(MIXDL(NMILG)) + DO 250 I=1,NMILG + CALL REDGET(ITYPLU,MIXDL(I),REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + 250 CONTINUE + CALL LCMPUT(IPLIST,'MIXDIL',NMILG,1,MIXDL) + DEALLOCATE(MIXDL) +* + ALLOCATE(MIXGR(NSMAX*NG*NMILG),FRACT(NG*NMILG)) + DO 260 IOFK=1,NSMAX*NG*NMILG + MIXGR(IOFK)=0 + 260 CONTINUE + DO 300 I=1,NMILG + DO 270 J=1,NG + IOFJ=(I-1)*NG+J + CALL REDGET(ITYPLU,INTLIR,FRACT(IOFJ),CARLIR,DBLLIR) + IF(ITYPLU.NE.2) CALL XABORT('GEOIN1: REAL DATA EXPECTED.(10)') + 270 CONTINUE + DO 290 J=1,NG + IOFJ=(I-1)*NG+J + IF(FRACT(IOFJ).GT.0.0) THEN + DO 280 K=1,NS(J) + IOFK=((I-1)*NG+(J-1))*NSMAX+K + CALL REDGET(ITYPLU,MIXGR(IOFK),REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEOIN1: INTEGER DATA EXPECTED.') + 280 CONTINUE + ENDIF + 290 CONTINUE + 300 CONTINUE + CALL LCMPUT(IPLIST,'FRACT',NG*NMILG,2,FRACT) + CALL LCMPUT(IPLIST,'MIXGR',NSMAX*NG*NMILG,1,MIXGR) + DEALLOCATE(FRACT,MIXGR) +* + DEALLOCATE(NS) + JSTATE(:NSTATE)=0 + JSTATE(1)=NG + JSTATE(2)=NSMAX+1 + JSTATE(3)=NMILG + JSTATE(4)=NSMAX*NG + JSTATE(5)=MICRO + CALL LCMPUT(IPLIST,'STATE-VECTOR',NSTATE,1,JSTATE) + CALL LCMSIX(IPLIST,' ',2) + ELSE IF(CARLIR.EQ.'POURCE') THEN +* CELL PROPORTIONS FOR DO-IT-YOURSELF OPTION. + IF(ISTATE(1).NE.30) CALL XABORT('GEOIN1: POURCE - KEY WORD LI' + 1 //'MITED TO DO-IT-YOURSELF GEOMETRY.') + ALLOCATE(POURC(LX)) + DO 310 I=1,LX + CALL REDGET(ITYPLU,INTLIR,POURC(I),CARLIR,DBLLIR) + IF(ITYPLU.NE.2) CALL XABORT('GEOIN1: REAL DATA EXPECTED.(11)') + 310 CONTINUE + CALL LCMPUT(IPLIST,'POURCE',LX,2,POURC) + DEALLOCATE(POURC) + ELSE IF(CARLIR.EQ.'PROCEL') THEN +* CELL PROBABILITIES FOR DO-IT-YOURSELF OPTION. + IF(ISTATE(1).NE.30) CALL XABORT('GEOIN1: PROCEL - KEY WORD LI' + 1 //'MITED TO DO-IT-YOURSELF GEOMETRY.') + ALLOCATE(PROCE(LX*LX)) + DO 325 I=1,LX + DO 320 J=1,LX + IOFJ=(J-1)*LX+I + CALL REDGET(ITYPLU,INTLIR,PROCE(IOFJ),CARLIR,DBLLIR) + IF(ITYPLU.NE.2) CALL XABORT('GEOIN1: REAL DATA EXPECTED.(12)') + 320 CONTINUE + 325 CONTINUE + CALL LCMPUT(IPLIST,'PROCEL',LX*LX,2,PROCE) + DEALLOCATE(PROCE) + ELSE IF((CARLIR(2:2).EQ.'+').OR.(CARLIR(2:2).EQ.'-').OR. + 1 (CARLIR.EQ.'HBC')) THEN +* INPUT BOUNDARY CONDITIONS. + ISURF=0 + IF(CARLIR.EQ.'X-') THEN + ISURF=1 + IF(LX.EQ.0) CALL XABORT('GEOIN1: HBC X- -> LX=0.') + ELSE IF(CARLIR.EQ.'X+') THEN + ISURF=2 + IF(LX.EQ.0) CALL XABORT('GEOIN1: HBC X+ -> LX=0.') + ELSE IF(CARLIR.EQ.'R+') THEN + ISURF=2 + IF(ISTATE(1).EQ.10) THEN + ISURF=4 + ELSE IF(ISTATE(1).EQ.11) THEN + ISURF=6 + ENDIF + IF(LR.EQ.0) CALL XABORT('GEOIN1: HBC R+ -> LR=0.') + ELSE IF(CARLIR.EQ.'Y-') THEN + ISURF=3 + IF(LY.EQ.0) CALL XABORT('GEOIN1: HBC Y- -> LY=0.') + ELSE IF(CARLIR.EQ.'Y+') THEN + ISURF=4 + IF(LY.EQ.0) CALL XABORT('GEOIN1: HBC Y+ -> LY=0.') + ELSE IF(CARLIR.EQ.'Z-') THEN + ISURF=5 + IF(LZ.EQ.0) CALL XABORT('GEOIN1: HBC Z- -> LZ=0.') + ELSE IF(CARLIR.EQ.'Z+') THEN + ISURF=6 + IF(LZ.EQ.0) CALL XABORT('GEOIN1: HBC Z+ -> LZ=0.') + ELSE IF(CARLIR.EQ.'HBC') THEN + ISURF=1 + IF(.NOT.LHEX) CALL XABORT('GEOIN1: HBC PROHIBITED.') + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('GEOIN1: CHARACTER DATA EXPECTE' + 1 //'D.') + DO 330 I=1,MAXHEX + IF(CARLIR.EQ.CHEX(I)) THEN + IHEX=I + GO TO 340 + ENDIF + 330 CONTINUE + CALL XABORT('GEOIN1: INVALID TYPE OF HEXAGONAL SYMMETRY.') + 340 CALL LCMPUT(IPLIST,'IHEX',1,1,IHEX) + LCOUR=IHEX.EQ.9 + ELSE IF(CARLIR.EQ.'TBC') THEN + ISURF=1 + IF(.NOT.LTRI) CALL XABORT('GEOIN1: TBC PROHIBITED.') + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('GEOIN1: CHARACTER DATA EXPECTE' + 1 //'D.') + DO 350 I=1,MAXTEX + IF(CARLIR.EQ.CHET(I)) THEN + ITRI=I + GO TO 360 + ENDIF + 350 CONTINUE + CALL XABORT('GEOIN1: INVALID TYPE OF TRIANGULAR SYMMETRY.') + 360 CALL LCMPUT(IPLIST,'ITRI',1,1,ITRI) + ELSE + CALL XABORT('GEOIN1: INVALID KEY WORD '//CARLIR//'.') + ENDIF + CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT4,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('GEOIN1: CHARACTER DATA EXPECTED.') + DO 370 I=1,MAXCOD + IF(TEXT4.EQ.COND(I)) THEN + NCODE(ISURF)=I + IF(TEXT4.EQ.'ACYL') NCODE(ISURF)=I-1 + IF(TEXT4.NE.'ALBE') ICODE(ISURF)=0 + GO TO 380 + ENDIF + 370 CONTINUE + CALL XABORT('GEOIN1: INVALID TYPE OF BOUNDARY CONDITION.') + 380 IF(TEXT4.EQ.'ALBE') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT4,DBLLIR) + IF(ITYPLU.EQ.1) THEN + ICODE(ISURF)=INTLIR + MINICO=MIN(MINICO,INTLIR) + ELSE IF(ITYPLU.EQ.2) THEN + ZCODE(ISURF)=REALIR + ELSE + CALL XABORT('GEOIN1: INTEGER OR REAL DATA EXPECTED.') + ENDIF + ELSE IF(TEXT4.EQ.'ACYL') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT4,DBLLIR) + IF(ITYPLU.EQ.1) THEN + ICODE(ISURF)=INTLIR + MINICO=MIN(MINICO,INTLIR) + ELSE IF(ITYPLU.EQ.2) THEN + ZCODE(ISURF)=REALIR + ELSE + CALL XABORT('GEOIN1: INTEGER OR REAL DATA EXPECTED ' + 1 //'AFTER ACYL.') + ENDIF + ELSE IF(TEXT4.EQ.'REFL') THEN + ZCODE(ISURF)=1.0 + ELSE IF(TEXT4.EQ.'VOID') THEN + ZCODE(ISURF)=0.0 + ENDIF + ELSE IF(CARLIR.EQ.';') THEN +* END-OF-GEOMETRY. + GO TO 410 + ELSE IF(CARLIR.EQ.':::') THEN +* INPUT A SUB GEOMETRY. + IMPX2=IMPX + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('GEOIN1: CHARACTER DATA EXPECTED.') + CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT4,DBLLIR) + IF((ITYPLU.NE.3).OR.(TEXT4.NE.':=')) CALL XABORT('GEOIN1: := TO' + 1 //'KEN EXPECTED.') + CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT4,DBLLIR) + IF((ITYPLU.NE.3).OR.(TEXT4.NE.'GEO:')) THEN + WRITE(HSMG,'(36HGEOIN1: GEO: TOKEN EXPECTED (CARLIR=,A, + 1 8H ITYPLU=,I2,7H TEXT4=,A,1H))') CARLIR,ITYPLU,TEXT4 + CALL XABORT(HSMG) + ENDIF + CALL LCMLEN(IPLIST,CARLIR,ILONG,ITYX) + IF(ILONG.NE.0) THEN + IF(ITYX.NE.0) CALL XABORT('GEOIN1: INVALID GEOMETRY NAME.') + ELSE + ISTATE(9)=ISTATE(9)+1 + ENDIF + CALL LCMSIX(IPLIST,CARLIR,1) + CALL GEOIN1(CARLIR,IPLIST,LEVEL+1,IMPX2,MAXMI2) + CALL LCMSIX(IPLIST,' ',2) + ISTATE(7)=MAX(ISTATE(7),MAXMI2) + ELSE IF(CARLIR.EQ.'MIX-NAMES') THEN +* DEFINE MIXTURE CHARACTER NAMES. + IF(LEVEL.NE.1) CALL XABORT('GEOIN1: MIX-NAMES DATA SHOULD BE ' + 1 //'WRITTEN ON FIRST DIRECTORY LEVEL.') + ALLOCATE(CELL(3*LREG)) + I=0 + 390 I=I+1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('GEOIN1: CHARACTER DATA EXPECTED.') + IF((CARLIR(2:2).EQ.'-').OR.(CARLIR(2:2).EQ.'+').OR. + 1 (CARLIR.EQ.'HBC').OR.(CARLIR(1:4).EQ.'MESH').OR.(CARLIR(1:5) + 2 .EQ.'SPLIT').OR.(CARLIR.EQ.'SIDE').OR.(CARLIR(:3).EQ.'MIX').OR. + 3 (CARLIR.EQ.'CELL').OR.(CARLIR.EQ.'MERGE').OR.(CARLIR.EQ.'TURN') + 4 .OR.(CARLIR(2:4).EQ.'PIN').OR.(CARLIR.EQ.'BIHET').OR. + 5 (CARLIR.EQ.'POURCE').OR.(CARLIR.EQ.'PROCEL').OR. + 6 (CARLIR.EQ.'SECT').OR.(CARLIR.EQ.'RADIUS').OR. + 7 (CARLIR.EQ.'HMIX').OR.(CARLIR.EQ.';').OR. (CARLIR.EQ.':::')) + 8 GO TO 400 + IF(I.GT.LREG) CALL XABORT('GEOIN1: MIX-NAMES INDEX OVERFLOW.') + READ (CARLIR(:4),'(A4)') CELL(3*(I-1)+1) + READ (CARLIR(5:8),'(A4)') CELL(3*(I-1)+2) + READ (CARLIR(9:),'(A4)') CELL(3*(I-1)+3) + GO TO 390 + 400 CALL LCMPUT(IPLIST,'MIX-NAMES',3*(I-1),3,CELL) + ISTATE(13)=I-1 + DEALLOCATE(CELL) + GO TO 60 + ELSE + CALL XABORT('GEOIN1: '//CARLIR//' IS AN INVALID KEY WORD.') + ENDIF + GO TO 50 +* + 410 CARLIR='L_GEOM' + CALL LCMPTC(IPLIST,'SIGNATURE',12,CARLIR) + ISTATE(2)=LR + ISTATE(3)=LX + ISTATE(4)=LY + ISTATE(5)=LZ + ISTATE(6)=LREG + CALL LCMPUT(IPLIST,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMPUT(IPLIST,'NCODE',6,1,NCODE) + CALL LCMPUT(IPLIST,'ZCODE',6,2,ZCODE) + CALL LCMPUT(IPLIST,'ICODE',6,1,ICODE) + IF(MINMIX.LT.0) + > CALL XABORT('GEOIN1: NEGATIVE MIXTURE NUMBERS INVALID') + IF(MINICO.LT.1) + > CALL XABORT('GEOIN1: ALBEDO NUMBER MUST BE GREATER THAN 0') + MAXMIX=ISTATE(7) + IF(IMPX.GT.0) THEN + CALL LCMINF(IPLIST,CARLIR,TEXT12,EMPTY,ILONG,LCM) + WRITE (IOUT,510) LEVEL,GEONAM,CARLIR,TYPE(ISTATE(1)) + ENDIF + IF(IMPX.GT.1) THEN + WRITE (IOUT,520) ISTATE(1),TYPE(ISTATE(1)),(ISTATE(I),I=2,12) + WRITE (IOUT,525) (ISTATE(I),I=13,15),ISTATE(18) + ENDIF + IF((ISTATE(8).EQ.1).AND.(ISTATE(9).EQ.0)) CALL XABORT('GEOIN1: ' + 1 //'CELL OPTION ACTIVATED WITHOUT SUB-GEOMETRIES.') + DEALLOCATE(ZCODE) + DEALLOCATE(ICODE,NCODE,JSTATE,ISTATE) + RETURN +* + 500 CALL XABORT('GEOIN1: INVALID DATA.') + 510 FORMAT(/20H CREATION OF A LEVEL,I3,27H GEOMETRY ON THE DIRECTORY , + 1 7HNAMED ',A12,21H' OF THE LCM OBJECT ',A12,12H' WITH TYPE ,A16, + 2 1H.) + 520 FORMAT(/14H STATE VECTOR:/ + 1 7H ITYPE ,I6, 4H (,A16,1H)/ + 2 7H LR ,I6,20H (NUMBER OF TUBES)/ + 3 7H LX ,I6,22H (X-DIMENSION INDEX)/ + 4 7H LY ,I6,22H (Y-DIMENSION INDEX)/ + 5 7H LZ ,I6,22H (Z-DIMENSION INDEX)/ + 6 7H LREG ,I6,22H (NUMBER OF REGIONS)/ + 7 7H MAXMIX,I6,48H (MAX. NB. OF MIXTURES/0=TRANSPARENT GEOMETRY)/ + 8 7H ISUB1 ,I6,34H (1=COMMAND CELL IS USED/0=ELSE)/ + 9 7H ISUB2 ,I6,29H (NUMBER OF SUB GEOMETRIES)/ + 1 7H IMERGE,I6,26H (1=CELL-MERGING/0=ELSE)/ + 2 7H ISPLIT,I6,28H (1=MESH-SPLITTING/0=ELSE)/ + 3 7H IBIHET,I6,34H (1=DOUBLE HETEROGENEITY/0=ELSE)) + 525 FORMAT( + 1 7H ICLUST,I6,28H (NUMBER OF CLUSTER RINGS)/ + 2 7H ISECT ,I6,26H (TYPE OF SECTORIZATION)/ + 3 7H JSECT ,I6,37H (NUMBER OF NON-SECTORIZED ANNULII)/ + 4 7H IPIN ,I6,24H (PIN LOCATION OPTION)) + 530 FORMAT(' ***** Error in GEOIN1 *****'/ + 1 ' Initial number of mixtures ',I10/ + 2 ' Cannot be repeated an integer number of times', + 3 ' to fill ',I10,' mixtures') + END diff --git a/Dragon/src/GEOMIX.f b/Dragon/src/GEOMIX.f new file mode 100644 index 0000000..9718e6d --- /dev/null +++ b/Dragon/src/GEOMIX.f @@ -0,0 +1,246 @@ +*DECK GEOMIX + SUBROUTINE GEOMIX(LX,LY,LZ,LCOUR,MIX,MINMIX,MAXMIX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Build array MIX from plane-defined information. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): E. Varin and R. Roy +* +*Parameters: input +* LX number of meshes along X-axis. +* LY number of meshes along Y-axis. +* LZ number of meshes along Z-axis. +* LCOUR flag indicating if 'CROWN' or 'UPTO' keywords are allowed. +* MIX array of material mixtures. +* +*Parameters: output +* MINMIX minimum number of mixtures, considering all sub-geometries. +* MAXMIX maximum number of mixtures, considering all sub-geometries. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER LX,LY,LZ,MIX(LX,LY,LZ),MINMIX,MAXMIX + LOGICAL LCOUR +*---- +* LOCAL VARIABLES +*---- + INTEGER IZ1,IZ2,IZ3,IX,IY,NZ,NC,NCSAME,IC,INDIC,NITMA,IHEX + CHARACTER TEXT12*12 + REAL FLOTT + DOUBLE PRECISION DFLOTT +*---- +* READ AN OPTION KEYWORD +*---- + IHEX= 0 + NC = -1 + NZ = 0 + 5 IZ2 = 0 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.EQ.1) THEN + NZ = NZ + 1 + IZ1 = NITMA + IF( IZ1.LT.1.OR.IZ1.GT.LZ )THEN + CALL XABORT('GEOMIX: INVALID PLANE NUMBER'// + > '(GREATER THAN *LZ*).') + ENDIF + ELSE + CALL XABORT('GEOMIX: PLANE NUMBER MUST BE READ'// + > '(INTEGER EXPECTED).') + ENDIF + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF( INDIC.EQ.3 )THEN + IF(TEXT12.EQ.'SAME') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.EQ.1) THEN + IZ2 = NITMA + IF( IZ2.GT.IZ1 )THEN + CALL XABORT('GEOMIX: INVALID PLANE NUMBER'// + > '(GREATER THAN PREVIOUS).') + ENDIF + GOTO 20 + ELSE + CALL XABORT('GEOMIX: SAME AS WHICH PLANE? '// + > '(INTEGER EXPECTED).') + ENDIF + ELSEIF((TEXT12.EQ.'CROWN'.OR.TEXT12.EQ.'UPTO').AND.LCOUR) THEN + NCSAME= 1 + IF( TEXT12.EQ.'UPTO' )THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('GEOMIX: INTEGER DATA'// + > ' EXPECTED AFTER *UPTO* KEYWORD') + NCSAME= NITMA + ENDIF + GO TO 30 + ELSEIF(.NOT.LCOUR.AND.(TEXT12.EQ.'CROWN'.OR.TEXT12.EQ.'UPTO')) + > THEN + CALL XABORT('GEOMIX: UNSUPPORTED KEYWORD *CROWN* OR *UPTO*' + > //': HEX3D COMPLETE ONLY') + ELSE + CALL XABORT('GEOMIX: INVALID CHARACTER VARIABLE '//TEXT12) + ENDIF + ELSEIF (INDIC.EQ.1) THEN + GOTO 20 + ELSE + CALL XABORT('GEOMIX: INTEGER OR CHARACTER VARIABLE EXPECTED') + ENDIF +*---- +* READ A CWOWN +*---- + 30 CONTINUE + NC= NC+1 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF( INDIC.EQ.3 )THEN + IF(TEXT12.EQ.'SAME') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.EQ.1) THEN + IZ3= NITMA + IF( IZ3.GT.IZ1 )THEN + CALL XABORT('GEOMIX: INVALID PLANE NUMBER'// + > '(GREATER THAN PREVIOUS).') + ENDIF + DO 41 IC= 1, NCSAME + IF( NC.EQ.0 )THEN + MIX(IHEX+1,1,IZ1)= MIX(IHEX+1,1,IZ3) + IHEX= IHEX+1 + ELSE + DO 31 IX= IHEX+1, IHEX+6*NC + MIX(IX,1,IZ1)= MIX(IX,1,IZ3) + 31 CONTINUE + IHEX= IHEX+6*NC + ENDIF + NC= NC+1 + 41 CONTINUE + NC= NC -1 + ELSE + CALL XABORT('GEOMIX: SAME AS WHICH PLANE? '// + > '(INTEGER EXPECTED).') + ENDIF + ELSEIF(TEXT12.EQ.'ALL') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.EQ.1) THEN + MAXMIX=MAX(MAXMIX,NITMA) + MINMIX=MIN(MINMIX,NITMA) + DO 42 IC= 1, NCSAME + IF( NC.EQ.0 )THEN + MIX(IHEX+1,1,IZ1)= NITMA + IHEX= IHEX+1 + ELSE + DO 32 IX= IHEX+1, IHEX+6*NC + MIX(IX,1,IZ1)= NITMA + 32 CONTINUE + IHEX= IHEX+6*NC + ENDIF + NC= NC+1 + 42 CONTINUE + NC= NC -1 + ELSE + CALL XABORT('GEOMIX: ALL OF WHICH MIX? '// + > '(INTEGER EXPECTED).') + ENDIF + ELSE + CALL XABORT('GEOMIX: KEYWORD *SAME* OR *ALL* '// + > '(CHARACTER EXPECTED).') + ENDIF + ELSEIF( INDIC.EQ.1 )THEN + IF( NCSAME.NE.1 )THEN + CALL XABORT('GEOMIX: INVALID INTEGER WITH *UPTO* ') + ENDIF + IF( NC.EQ.0 )THEN + MIX(IHEX+1,1,IZ1)= NITMA + IHEX= IHEX+1 + ELSE + DO 33 IX= 1, 6*NC + IF(.NOT.(IX.EQ.1) ) THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.1)THEN + WRITE(6,*) 'NC=',NC,' IZ1=',IZ1,' NCSAME=',NCSAME + WRITE(6,*) 'IHEX=',IHEX,' INDIC=',INDIC,' C=',TEXT12 + CALL XABORT('GEOMIX: INTEGER DATA EXPECTED(1)') + ENDIF + ENDIF + MIX(IHEX+IX,1,IZ1) = NITMA + MAXMIX=MAX(MAXMIX,NITMA) + MINMIX=MIN(MINMIX,NITMA) + 33 CONTINUE + IHEX= IHEX+6*NC + ENDIF + ELSE + CALL XABORT('GEOMIX: MIXTURE # EXPECTED '// + > '(INTEGER EXPECTED).') + ENDIF + IF( IHEX.LT.LX )THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.3)THEN + WRITE(6,*) ' TEST IZ1-2-3',IZ1,IZ2,IZ3,' IHEX NC',IHEX,NC + CALL XABORT('GEOMIX: KEYWORD *CROWN* OR *UPTO*'// + > ' MUST BE READ.') + ENDIF + IF( TEXT12.EQ.'CROWN') THEN + NCSAME= 1 + ELSEIF( TEXT12.EQ.'UPTO') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('GEOMIX: INTEGER DATA'// + > ' EXPECTED AFTER *UPTO* KEYWORD') + NCSAME= NITMA-NC-1 + ELSE + CALL XABORT('GEOMIX: KEYWORD *CROWN* OR *UPTO*'// + > ' MUST BE READ.') + ENDIF + GO TO 30 + ELSEIF( IHEX.EQ.LX )THEN + GO TO 25 + ELSE + CALL XABORT('GEOMIX: INVALID # OF MIX IN THIS PLANE.') + ENDIF +*---- +* READ MIXTURE INDICES BY PLANE +*---- + 20 IF (IZ2.EQ.0) THEN + DO 22 IY=1,LY + DO 21 IX=1,LX + IF(.NOT.((IX.EQ.1).AND.(IY.EQ.1))) THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.1) THEN + CALL XABORT('GEOMIX: INTEGER DATA EXPECTED(2)') + ENDIF + ENDIF + MIX(IX,IY,IZ1) = NITMA + MAXMIX=MAX(MAXMIX,NITMA) + MINMIX=MIN(MINMIX,NITMA) + 21 CONTINUE + 22 CONTINUE + ELSE + DO 24 IY=1,LY + DO 23 IX=1,LX + MIX(IX,IY,IZ1) = MIX(IX,IY,IZ2) + 23 CONTINUE + 24 CONTINUE + ENDIF +* + 25 CONTINUE + IF (NZ.LT.LZ) THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.3.OR.TEXT12.NE.'PLANE') THEN + CALL XABORT('GEOMIX: KEYWORD *PLANE* MUST BE READ.') + ENDIF + NC= -1 + IHEX= 0 + GO TO 5 + ENDIF + IF (NZ.NE.LZ) CALL XABORT('GEOMIX: WRONG NUMBER OF PLANES') +* + RETURN + END diff --git a/Dragon/src/HEADRV.f b/Dragon/src/HEADRV.f new file mode 100644 index 0000000..0594691 --- /dev/null +++ b/Dragon/src/HEADRV.f @@ -0,0 +1,233 @@ +*DECK HEADRV + SUBROUTINE HEADRV(IPDEP,NPART,IPMAC,NBMIX,NGRP,ZNORM,IMPX,ESUM, + 1 CSUM,IBC,RHO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute energy and charge deposition from many particles. +* +*Copyright: +* Copyright (C) 2020 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPDEP L_DEPOSITION pointer to the deposition information object. +* NPART number of particles contributing to energy and charge +* deposition. +* IPMAC L_MACROLIB pointers to the extended macrolibs. +* NBMIX number of material mixtures. +* NGRP total number of energy groups. +* ZNORM flux normalization factor. +* IMPX print parameter. +* +*Parameters: output +* ESUM total energy deposition (MeV/cc). +* CSUM total charge deposition (electron/cc). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NPART,NBMIX,NGRP,IMPX + TYPE(C_PTR) IPDEP,IPMAC(NPART) + REAL RHO(NBMIX) + DOUBLE PRECISION ZNORM,ESUM,CSUM +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPMAC,KPMAC + PARAMETER(NSTATE=40,IOUT=6) + INTEGER ISTATE(NSTATE),MAT(NBMIX) + CHARACTER HSMG*131,TEXT1*1 + DOUBLE PRECISION VTOT + LOGICAL LCHARG + REAL FLUXC(NBMIX) +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: VOL,SGD,FLIN,ESTOPW + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: EDEPOT,CDEPOT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: EDEPO,CDEPO + CHARACTER(LEN=1), ALLOCATABLE, DIMENSION(:) :: TEXT1V + CHARACTER(LEN=6), ALLOCATABLE, DIMENSION(:) :: SNAME + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: FUNA8 +*---- +* MEMORY ALLOCATION +*---- + ALLOCATE(EDEPO(NBMIX,NPART),CDEPO(NBMIX,NPART),EDEPOT(NBMIX), + 1 CDEPOT(NBMIX),VOL(NBMIX),SGD(NBMIX),FLIN(NBMIX)) + ALLOCATE(FUNA8(2*NPART+2),SNAME(2*NPART+2)) +*---- +* RECOVER ENERGY AND CHARGE DEPOSITION +*---- + CALL LCMLEN(IPDEP,'EDEPOS',LENGT,ITYLCM) + IF(LENGT.NE.0) THEN + IF(LENGT.NE.NBMIX*NPART) CALL XABORT('HEADRV: INVALID EDEPOS R' + 1 //'ECORD LENGTH.') + CALL LCMGET(IPDEP,'EDEPOS',EDEPO) + CALL LCMGET(IPDEP,'FLUX-NORM',ZNORM) + ELSE + EDEPO(:NBMIX,:NPART)=0.0D0 + ENDIF + CALL LCMLEN(IPDEP,'CDEPOS',LENGT,ITYLCM) + IF(LENGT.NE.0) THEN + IF(LENGT.NE.NBMIX*NPART) CALL XABORT('HEADRV: INVALID CDEPOS R' + 1 //'ECORD LENGTH.') + CALL LCMGET(IPDEP,'CDEPOS',CDEPO) + ELSE + CDEPO(:NBMIX,:NPART)=0.0D0 + ENDIF + EDEPOT(:NBMIX)=0.0D0 + CDEPOT(:NBMIX)=0.0D0 + CHARGE=0.0 + DO I=1,NPART + CALL LCMLEN(IPMAC(I),'FLUXC',IBC2,ITYLCM) + IF(IBC.EQ.1.AND.IBC2.NE.0) THEN + CALL LCMGET(IPMAC(I),'FLUXC',FLUXC) + CALL LCMGET(IPMAC(I),'ECUTOFF',ECUTOFF) + CALL LCMLEN(IPMAC(I),'ESTOPW',LENGT,ITYLCM) + ALLOCATE(ESTOPW(LENGT)) + CALL LCMGET(IPMAC(I),'ESTOPW',ESTOPW) + CALL LCMGET(IPMAC(I),'MATCOD',MAT) + ENDIF + CALL LCMGET(IPMAC(I),'VOLUME',VOL) + CALL LCMGTC(IPMAC(I),'PARTICLE',1,TEXT1) + SNAME(I)=TEXT1 + IF(TEXT1.EQ.'N'.OR.TEXT1.EQ.'G') THEN + CHARGE=0.0 + ELSEIF(TEXT1.EQ.'C'.OR.TEXT1.EQ.'P') THEN + CHARGE=1.0 + ELSEIF(TEXT1.EQ.'B') THEN + CHARGE=-1.0 + ELSE + CALL XABORT('HEADRV: UNKNOWN PARTICLE.') + ENDIF + FUNA8(I)='ENERGDEP' + FUNA8(NPART+I+1)='CHARGDEP' + SNAME(NPART+I+1)=SNAME(I) + JPMAC=LCMGID(IPMAC(I),'GROUP') + DO IGR=1,NGRP + KPMAC=LCMGIL(JPMAC,IGR) + CALL LCMLEN(KPMAC,'H-FACTOR',LENGT,ITYLCM) + IF(LENGT.EQ.0) THEN + WRITE(HSMG,'(42HHEADRV: NO H-FACTOR FOUND IN MACROLIB NUMB, + 1 2HER,I3,1H.)') I + CALL XABORT(HSMG) + ENDIF + CALL LCMGET(KPMAC,'FLUX-INTG',FLIN) + CALL LCMGET(KPMAC,'H-FACTOR',SGD) + DO IBM=1,NBMIX + EDEPO(IBM,I)=EDEPO(IBM,I)+FLIN(IBM)*SGD(IBM)*ZNORM/ + 1 (VOL(IBM)*RHO(IBM)) + IF(IBC.EQ.1.AND.IBC2.NE.0) THEN + EDEPO(IBM,I)=EDEPO(IBM,I)+ECUTOFF*ESTOPW(MAT(IBM)) + 1 *FLUXC(IBM)*ZNORM/RHO(IBM) + ENDIF + ENDDO + CALL LCMLEN(KPMAC,'C-FACTOR',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + LCHARG=.TRUE. + CALL LCMGET(KPMAC,'C-FACTOR',SGD) + DO IBM=1,NBMIX + CDEPO(IBM,I)=CDEPO(IBM,I)+FLIN(IBM)*SGD(IBM)*ZNORM/ + 1 (VOL(IBM)*RHO(IBM)) + IF(IBC.EQ.1.AND.IBC2.NE.0) THEN + CDEPO(IBM,I)=CDEPO(IBM,I)+ESTOPW(MAT(IBM))*FLUXC(IBM) + 1 *ZNORM/RHO(IBM)*(-CHARGE) + ENDIF + ENDDO + ENDIF + ENDDO + IF(IBC.EQ.1.AND.IBC2.NE.0) DEALLOCATE(ESTOPW) + ENDDO + FUNA8(NPART+1)='TOTENDEP' + FUNA8(2*NPART+2)='TOTCHDEP' + SNAME(NPART+1)='EDEPO' + SNAME(2*NPART+2)='CDEPO' + VTOT=0.0D0 + ESUM=0.0D0 + CSUM=0.0D0 + DO IBM=1,NBMIX + DO I=1,NPART + EDEPOT(IBM)=EDEPOT(IBM)+EDEPO(IBM,I) + CDEPOT(IBM)=CDEPOT(IBM)+CDEPO(IBM,I) + ENDDO + VTOT=VTOT+VOL(IBM) + ESUM=ESUM+EDEPOT(IBM)*VOL(IBM) + CSUM=CSUM+CDEPOT(IBM)*VOL(IBM) + ENDDO + ESUM=ESUM/VTOT + CSUM=CSUM/VTOT +*---- +* PRINT ENERGY AND CHARGE DEPOSITION +*---- + IF(IMPX.GT.0) THEN + WRITE(IOUT,1001) ' VOLUME ',(FUNA8(J),'_',SNAME(J),J=1, + 1 2*NPART+2) + DO IBM=1,NBMIX + WRITE(IOUT,1002) VOL(IBM),(EDEPO(IBM,I),I=1,NPART), + 1 EDEPOT(IBM),(CDEPO(IBM,I),I=1,NPART),CDEPOT(IBM) + ENDDO + WRITE(IOUT,'(/14H TOTAL VOLUME:,14X,1P,E12.4)') VTOT + WRITE(IOUT,'(25H TOTAL ENERGY DEPOSITION:,3X,1P,E12.4)') ESUM + WRITE(IOUT,'(25H TOTAL CHARGE DEPOSITION:,3X,1P,E12.4)') CSUM + ENDIF +*---- +* SAVE ENERGY AND CHARGE DEPOSITION +*---- + CALL LCMPUT(IPDEP,'VOLUME',NBMIX,2,VOL) + CALL LCMPUT(IPDEP,'EDEPOS',NBMIX*NPART,4,EDEPO) + CALL LCMPUT(IPDEP,'EDEPOS_TOT',NBMIX,4,EDEPOT) + IF(LCHARG) THEN + CALL LCMPUT(IPDEP,'CDEPOS',NBMIX*NPART,4,CDEPO) + CALL LCMPUT(IPDEP,'CDEPOS_TOT',NBMIX,4,CDEPOT) + ENDIF + CALL LCMPUT(IPDEP,'FLUX-NORM',1,4,ZNORM) +*---- +* PROCESS STATE-VECTOR +*---- + CALL LCMLEN(IPDEP,'STATE-VECTOR',LENGT,ITYLCM) + IF(LENGT.NE.0) THEN + CALL LCMGET(IPDEP,'STATE-VECTOR',ISTATE) + ALLOCATE(TEXT1V(NPART)) + CALL LCMGTC(IPDEP,'PARTICLE-NAM',1,NPART,TEXT1V) + DO I=1,NPART + IF(TEXT1V(I).NE.SNAME(I)(:1)) THEN + WRITE(HSMG,'(22HHEADRV: PARTICLE NAMES,2A2, + 1 16H ARE INCOHERENT.)') TEXT1V(I),SNAME(I)(:1) + CALL XABORT(HSMG) + ENDIF + ENDDO + DEALLOCATE(TEXT1V) + ELSE + ISTATE(:NSTATE)=0 + ISTATE(1)=NBMIX + ISTATE(2)=NPART + IF(LCHARG) ISTATE(3)=1 + ALLOCATE(TEXT1V(NPART)) + DO I=1,NPART + TEXT1V(I)=SNAME(I)(:1) + ENDDO + CALL LCMPTC(IPDEP,'PARTICLE-NAM',1,NPART,TEXT1V) + DEALLOCATE(TEXT1V) + ENDIF + ISTATE(4)=ISTATE(4)+1 + CALL LCMPUT(IPDEP,'STATE-VECTOR',NSTATE,1,ISTATE) +*---- +* MEMORY DEALLOCATION +*---- + DEALLOCATE(SNAME,FUNA8) + DEALLOCATE(FLIN,SGD,VOL,CDEPOT,EDEPOT,CDEPO,EDEPO) + RETURN +* + 1001 FORMAT(/1X,A11,21(1X,A8,A1,A6)) + 1002 FORMAT(1X,1P,E11.4,21E16.4) + END diff --git a/Dragon/src/HEAT.f b/Dragon/src/HEAT.f new file mode 100644 index 0000000..ad045b5 --- /dev/null +++ b/Dragon/src/HEAT.f @@ -0,0 +1,260 @@ +*DECK HEAT + SUBROUTINE HEAT(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Driver for energy and charge deposition calculation. +* +*Copyright: +* Copyright (C) 2020 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1) : create type(L_MACROLIB); +* HENTRY(2) : read-only ascii file containing HEAT-M data. +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPDEP,IPMAC,JPMAC,KPMAC + PARAMETER(NSTATE=40) + CHARACTER TEXT12*12,HSIGN*12,HSMG*131 + INTEGER ISTATE(NSTATE) + REAL NORM + DOUBLE PRECISION DFLOTT,ZNORM,ESUM,CSUM +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: VOL,SGD,FLIN,RHOI,RHO + INTEGER, ALLOCATABLE, DIMENSION(:) :: MATCOD + REAL, DIMENSION(:,:), ALLOCATABLE :: ZUFIS +*---- +* PARAMETER VALIDATION +*---- + IF(NENTRY.LE.1) CALL XABORT('HEAT: >1 PARAMETERS EXPECTED.') + IPDEP=KENTRY(1) + IPMAC=KENTRY(2) + IF((IENTRY(1).LE.2).AND.(JENTRY(1).EQ.0)) THEN + HSIGN='L_DEPOSITION' + CALL LCMPTC(IPDEP,'SIGNATURE',12,HSIGN) + ELSE IF(IENTRY(1).LE.2) THEN + CALL LCMGTC(IPDEP,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_DEPOSITION') THEN + TEXT12=HENTRY(1) + CALL XABORT('HEAT: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_DEPOSITION EXPECTED.') + ENDIF + ELSE + CALL XABORT('HEAT: L_DEPOSITION LCM OBJECT EXPECTED.') + ENDIF + NGRP=0 + NBMIX=0 + NBFIS=0 + IPICK=0 + IBC=1 + DO I=2,NENTRY + IF((IENTRY(I).NE.1).AND.(IENTRY(I).NE.2)) CALL XABORT('HEAT: L' + 1 //'CM OBJECT EXPECTED AT LHS.') + IF(JENTRY(I).NE.2) CALL XABORT('HEAT: ENTRY IN READ-ONLY MODE ' + 1 //'EXPECTED.') + HSIGN='L_MACROLIB' + CALL LCMGTC(KENTRY(I),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_MACROLIB') THEN + TEXT12=HENTRY(I) + CALL XABORT('HEAT: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + > '. L_MACROLIB EXPECTED.') + ENDIF + CALL LCMGET(KENTRY(I),'STATE-VECTOR',ISTATE) + IF(NGRP.EQ.0) THEN + NGRP=ISTATE(1) + NBMIX=ISTATE(2) + NBFIS=ISTATE(4) + ELSE + IF(ISTATE(1).NE.NGRP) THEN + WRITE(HSMG,'(39HHEAT: INVALID NUMBER OF ENERGY GROUPS (,I5, + 1 3H VS,I5,20H) IN MACROLIB NUMBER,I3,1H.)') ISTATE(1),NGRP,I + CALL XABORT(HSMG) + ELSE IF(ISTATE(2).NE.NBMIX) THEN + WRITE(HSMG,'(34HHEAT: INVALID NUMBER OF MIXTURES (,I5, + 1 3H VS,I5,20H) IN MACROLIB NUMBER,I3,1H.)') ISTATE(2),NBMIX,I + CALL XABORT(HSMG) + ELSE IF(ISTATE(4).NE.NBFIS) THEN + WRITE(HSMG,'(42HHEAT: INVALID NUMBER OF FISSILE ISOTOPES (, + 1 I5,3H VS,I5,20H) IN MACROLIB NUMBER,I3,1H.)') ISTATE(4), + 2 NBMIX,I + CALL XABORT(HSMG) + ENDIF + ENDIF + ENDDO +*---- +* READ INPUT DATA +*---- + IMPX=1 + ALLOCATE(RHO(NBMIX)) + RHO=1.0 + ZNORM=1.0D0 + 10 CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.EQ.10) GO TO 60 + IF(INDIC.NE.3) CALL XABORT('HEAT: CHARACTER DATA EXPECTED.') +* + IF(TEXT12.EQ.'EDIT') THEN + CALL REDGET(INDIC,IMPX,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('HEAT: INTEGER DATA EXPECTED.') + ELSE IF(TEXT12.EQ.'POWR') THEN +* NORMALIZATION TO A GIVEN FISSION POWER. + CALL REDGET (INDIC,NITMA,POWER,TEXT12,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('HEAT: REAL DATA EXPECTED.') +* NORMALIZATION FACTOR FOR THE DIRECT FLUX. + ALLOCATE(SGD(NBMIX),FLIN(NBMIX)) + ZNORM=0.0D0 + JPMAC=LCMGID(IPMAC,'GROUP') + DO 30 IGR=1,NGRP + KPMAC=LCMGIL(JPMAC,IGR) + CALL LCMGET(KPMAC,'FLUX-INTG',FLIN) + CALL LCMLEN(KPMAC,'H-FACTOR',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGET(KPMAC,'H-FACTOR',SGD) + ELSE + WRITE(6,'(/44H HEAT: *** WARNING *** NO H-FACTOR FOUND ON , + 1 25HLCM. USE NU*SIGF INSTEAD.)') + ALLOCATE(ZUFIS(NBMIX,NBFIS)) + SGD(:NBMIX)=0.0 + CALL LCMGET(KPMAC,'NUSIGF',ZUFIS) + DO IBM=1,NBMIX + DO IFISS=1,NBFIS + SGD(IBM)=SGD(IBM)+ZUFIS(IBM,IFISS) + ENDDO + ENDDO + DEALLOCATE(ZUFIS) + ENDIF + DO 20 IBM=1,NBFIS + ZNORM=ZNORM+FLIN(IBM)*SGD(IBM) + 20 CONTINUE + 30 CONTINUE + ZNORM=POWER/ZNORM + WRITE(6,300) ' DIRECT',ZNORM + DEALLOCATE(FLIN,SGD) + ELSE IF(TEXT12.EQ.'SOUR') THEN +* NORMALIZATION TO A GIVEN SOURCE INTENSITY. + CALL REDGET (INDIC,NITMA,SNUMB,TEXT12,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('HEAT: REAL DATA EXPECTED.') +* NORMALIZATION FACTOR FOR THE DIRECT FLUX. + ALLOCATE(VOL(NBMIX),SGD(NBMIX)) + CALL LCMGET(IPMAC,'VOLUME',VOL) + ZNORM=0.0D0 + JPMAC=LCMGID(IPMAC,'GROUP') + DO 50 IGR=1,NGRP + KPMAC=LCMGIL(JPMAC,IGR) + CALL LCMLEN(KPMAC,'FIXE',LENGT,ITYLCM) + IF(LENGT.EQ.0) THEN + CALL LCMLIB(KPMAC) + CALL XABORT('HEAT: SOURCE RECORD MISSING IN MACROLIB.') + ENDIF + CALL LCMGET(KPMAC,'FIXE',SGD) + DO 40 IBM=1,NBMIX + ZNORM=ZNORM+VOL(IBM)*SGD(IBM) + 40 CONTINUE + 50 CONTINUE + ZNORM=SNUMB/ZNORM + WRITE(6,310) ' DIRECT',ZNORM + DEALLOCATE(SGD,VOL) + ELSE IF(TEXT12.EQ.'NORM') THEN + ALLOCATE(MATCOD(NBMIX)) + CALL LCMLEN(IPMAC,'NORM-FS',ILEN,ITYLCM) + IF(ILEN.GT.0) THEN + CALL LCMGET(IPMAC,'NORM-FS',NORM) + CALL LCMGET(IPMAC,'MATCOD',MATCOD) + ELSE + CALL XABORT('HEAT: FIXED SOURCE RECORD MISSING.') + ENDIF + NMIX=MAXVAL(MATCOD) + ALLOCATE(RHOI(NMIX)) + DO IMIX=1,NMIX + CALL REDGET (INDIC,NITMA,SNUMB,TEXT12,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('HEAT: REAL DATA EXPECTED.') + RHOI(IMIX)=SNUMB + ENDDO + DO IR=1,NBMIX + RHO(IR)=RHOI(MATCOD(IR)) + ENDDO + DEALLOCATE(MATCOD,RHOI) + ZNORM=1/NORM + ELSE IF(TEXT12.EQ.';') THEN + IPICK=0 + GO TO 60 + ELSE IF(TEXT12.EQ.'PICKE') THEN + IPICK=1 + GO TO 60 + ELSE IF(TEXT12.EQ.'PICKC') THEN + IPICK=2 + GO TO 60 + ELSE IF(TEXT12.EQ.'BC') THEN + IBC=1 + ELSE IF(TEXT12.EQ.'NBC') THEN + IBC=0 + ELSE + CALL XABORT('HEAT: '//TEXT12//' IS AN INVALID KEY WORD.') + ENDIF + GO TO 10 +*---- +* COMPUTE THE ENERGY AND CHARGE DEPOSITION +*---- + 60 CALL HEADRV(IPDEP,NENTRY-1,KENTRY(2),NBMIX,NGRP,ZNORM,IMPX,ESUM, + 1 CSUM,IBC,RHO) +*---- +* RECOVER THE TOTAL ENERGY OR CHARGE DEPOSITION AND SAVE IT IN A +* CLE-2000 VARIABLE +*---- + IF(IPICK.EQ.1) THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.-2) CALL XABORT('HEAT: OUTPUT REAL EXPECTED(1).') + INDIC=2 + FLOTT=REAL(ESUM) + CALL REDPUT(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF((INDIC.NE.3).OR.(TEXT12.NE.';')) THEN + CALL XABORT('HEAT: ; CHARACTER EXPECTED(1).') + ENDIF + ELSE IF(IPICK.EQ.2) THEN + IF(JENTRY(1).NE.2) CALL XABORT('HEAT: SECOND ENTRY IN READ-O' + 1 //'NLY MODE EXPECTED.') + CALL REDGET(INDIC,NITMA,FLOT,TEXT12,DFLOTT) + IF(INDIC.NE.-2) CALL XABORT('HEAT: OUTPUT REAL EXPECTED(2).') + INDIC=2 + FLOTT=REAL(CSUM) + CALL REDPUT(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF((INDIC.NE.3).OR.(TEXT12.NE.';')) THEN + CALL XABORT('HEAT: ; CHARACTER EXPECTED(2).') + ENDIF + ENDIF + RETURN +* + 300 FORMAT(/7H HEAT: ,A7,28H FLUX NORMALIZATION FACTOR =,1P,E13.5) + 310 FORMAT(/7H HEAT: ,A7,30H SOURCE NORMALIZATION FACTOR =,1P,E13.5) + END diff --git a/Dragon/src/INF.f b/Dragon/src/INF.f new file mode 100644 index 0000000..d0c8f9a --- /dev/null +++ b/Dragon/src/INF.f @@ -0,0 +1,397 @@ +*DECK INF + SUBROUTINE INF(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Driver for the dragon information module to recover cle-2000 values +* from the xs libraries. +* +*Copyright: +* Copyright (C) 1995 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): R. Roy +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file. +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='INF ') + CHARACTER TEXT12*12,HNAMIS(3)*8,TEXTT(3)*12 + CHARACTER TEXT64*64,CFILNA*64 + LOGICAL LTMP,LPUR,LENR,LISO,LPRES + INTEGER IPARM,I,IPISO(3),ITYPL + INTEGER ITYP,NITMA,NOUT,NCARS + INTEGER ITYPE,ILOOP,NBISO,IPRINT + DOUBLE PRECISION DFLOTT + REAL FLOTT,RBASE(3),AWR(3),PRES + REAL TEMPC,TEMPK,PURWGT,PURATM,ENRWGT,ENRATM,TOTMU + IF(NENTRY.NE.0)THEN + CALL XABORT(NAMSBR//': NO DATA STRUCTURE EXPECTED') + ENDIF + CFILNA=' ' + IPRINT= 1 + ITYPE= 2 + IPARM= 0 + NBISO= 0 + LTMP=.FALSE. + LPRES=.FALSE. + LPUR=.FALSE. + LENR=.FALSE. + LISO=.FALSE. + NOUT= 1 + ITYPL=0 + ENRWGT=0.0 + PRES=0.0 + NCARS=0 + DO ILOOP=1,3 + TEXTT(ILOOP)=' ' + ENDDO + 20 CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.3 )CALL XABORT(NAMSBR//': CHARACTER DATA EXPECTED.') + TEXTT(1)=TEXT12 + IF(TEXTT(1).EQ.';' )THEN + GO TO 40 + ELSEIF(TEXTT(1).EQ.'EDIT' )THEN + CALL REDGET(ITYP,IPRINT,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.1 )CALL XABORT(NAMSBR//': INTEGER EXPECTED.') + DO I=1,NENTRY + WRITE(IOUT,*) HENTRY(I),IENTRY(I),JENTRY(I) + IF(IENTRY(I).LE.2) CALL LCMLIB(KENTRY(I)) + ENDDO + GO TO 20 + ELSEIF(TEXTT(1).EQ.'LIB:' )THEN + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.3 ) CALL XABORT + > (NAMSBR//': LIBRARY TYPE NOT SPECIFIED FOLLOWING LIB:') + IF(TEXT12.EQ.'WIMSAECL') THEN + ITYPL=1 + ELSE IF(TEXT12.EQ.'WIMSD4') THEN + ITYPL=2 + ELSE IF(TEXT12.EQ.'APLIB1') THEN + ITYPL=3 + ELSE IF(TEXT12.EQ.'DRAGON') THEN + ITYPL=4 + ELSE IF(TEXT12.EQ.'MATXS ') THEN + ITYPL=5 + ELSE IF(TEXT12.EQ.'MATXS2') THEN + ITYPL=6 + ELSE IF(TEXT12.EQ.'NDAS') THEN + ITYPL=7 + ELSE IF(TEXT12.EQ.'WIMSE') THEN + ITYPL=8 + ELSE + CALL XABORT(NAMSBR//': ILLEGAL LIBRARY TYPE FOLLOWING LIB:') + ENDIF + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.3.OR.TEXT12.NE.'FIL:' ) + > CALL XABORT(NAMSBR//': *FIL:* EXPECTED.') + CALL REDGET(ITYP,NITMA,FLOTT,TEXT64,DFLOTT) + IF( ITYP.NE.3 )CALL XABORT(NAMSBR//': LIBRARY NAME EXPECTED.') + CFILNA= TEXT64 + GO TO 20 + ELSEIF(TEXTT(1).EQ.'TMP:' )THEN + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.2 ) + > CALL XABORT(NAMSBR//': TEMPERATURE EXPECTED.') + TEMPK = FLOTT + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.3) + > CALL XABORT(NAMSBR//': *C* OR *K* UNIT EXPECTED.') + IF(TEXT12.EQ.'C')THEN + TEMPK = TEMPK + 273.15 + ELSEIF( TEXT12.NE.'K' )THEN + CALL XABORT(NAMSBR//': *C* OR *K* UNIT EXPECTED.') + ENDIF + TEMPC = TEMPK-273.15 + LTMP=.TRUE. + GO TO 20 + ELSEIF(TEXTT(1).EQ.'PRES:' )THEN + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.2 ) + > CALL XABORT(NAMSBR//': PRESSURE EXPECTED (Pa).') + PRES = FLOTT + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.3) + > CALL XABORT(NAMSBR// + > ': *Pa*, *kPa*, *MPa* or *bar* UNITS EXPECTED.') + IF( TEXT12.EQ.'kPa' ) THEN + PRES = PRES*1000.0 + ELSE IF( TEXT12.EQ.'bar' ) THEN + PRES = PRES*100000.0 + ELSE IF( TEXT12.EQ.'MPa' ) THEN + PRES = PRES*1000000.0 + ELSE IF( TEXT12.NE.'Pa' ) THEN + CALL XABORT(NAMSBR// + > ': *Pa*, *kPa*, *MPa* or *bar* UNITS EXPECTED.') + ENDIF + LPRES=.TRUE. + GO TO 20 + ELSEIF(TEXTT(1).EQ.'PUR:' )THEN + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.2 ) + > CALL XABORT(NAMSBR//': PURITY EXPECTED.') + PURWGT = FLOTT + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.3)CALL XABORT(NAMSBR//': *ATM%* OR *WGT%* ' + > //'UNIT EXPECTED.') + IF( TEXT12.EQ.'ATM%' )THEN + PURATM= PURWGT + PURWGT= 100.0/(1. + 0.8994866*(100./PURATM - 1.)) + ELSEIF( TEXT12.EQ.'WGT%' )THEN + PURATM= 100.0/(1. + 1.1117435*(100./PURWGT - 1.)) + ELSE + CALL XABORT(NAMSBR//': *ATM%* OR *WGT%* UNIT EXPECTED.') + ENDIF + LPUR=.TRUE. + GO TO 20 + ELSEIF(TEXTT(1).EQ.'ENR:' )THEN + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.2 ) + > CALL XABORT(NAMSBR//': ENRICHMENT EXPECTED.') + ENRWGT = FLOTT + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.3)CALL XABORT(NAMSBR//': *ATM%* OR *WGT%* ' + > //'UNIT EXPECTED.') + IF( TEXT12.EQ.'ATM%' )THEN + ENRATM= ENRWGT + ENRWGT= 100.0/(1. + 1.01279335*(100./ENRATM - 1.)) + ELSEIF( TEXT12.EQ.'WGT%' )THEN + ENRATM= 100.0/(1. + 0.98736825*(100./ENRWGT - 1.)) + ELSE + CALL XABORT(NAMSBR//': *ATM%* OR *WGT%* UNIT EXPECTED.') + ENDIF + LENR=.TRUE. + GO TO 20 + ELSEIF(TEXTT(1).EQ.'ISO:' )THEN + IF( NBISO.NE.0 ) + > CALL XABORT(NAMSBR//': PREVIOUS ISOTOPES NOT USED.') + CALL REDGET(ITYP,NBISO,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.1 ) + > CALL XABORT(NAMSBR//': NUMBER OF ISOTOPES EXPECTED.') + IF( NBISO.LE.0.OR.NBISO.GT.3 ) + > CALL XABORT(NAMSBR// + > ': NB OF ISOTOPES MUST BE BETWEEN 1 AND 3.') + DO I=1,NBISO + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.3) + > CALL XABORT(NAMSBR//': ISOTOPE NAME EXPECTED.') + HNAMIS(I)= TEXT12(1:8) + ENDDO + IF(ITYPL.EQ.1)THEN + CALL INFWIM(CFILNA,IPRINT,NBISO,HNAMIS,AWR) + ELSE IF(ITYPL.EQ.2)THEN + CALL INFWD4(CFILNA,4,IPRINT,NBISO,HNAMIS,AWR) + ELSE IF(ITYPL.EQ.3)THEN + CALL INFAPL(CFILNA,IPRINT,NBISO,HNAMIS,AWR) + ELSE IF(ITYPL.EQ.4)THEN + CALL INFDRA(CFILNA,IPRINT,NBISO,HNAMIS,AWR) + ELSE IF(ITYPL.EQ.5)THEN + CALL INFTR1(CFILNA,IPRINT,NBISO,HNAMIS,AWR) + ELSE IF(ITYPL.EQ.6)THEN + CALL INFTR2(CFILNA,IPRINT,NBISO,HNAMIS,AWR) + ELSE IF(ITYPL.EQ.7)THEN + CALL INFNDA(CFILNA,IPRINT,NBISO,HNAMIS,AWR) + ELSE IF(ITYPL.EQ.8)THEN + CALL INFWD4(CFILNA,5,IPRINT,NBISO,HNAMIS,AWR) + ENDIF + GO TO 20 + ELSEIF(TEXTT(1).EQ.'CALC' )THEN + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.3 )CALL XABORT(NAMSBR//': *DENS* EXPECTED.') + TEXTT(2)=TEXT12 + IF(TEXTT(2).EQ.'DENS' ) THEN + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF(ITYP.NE.3) CALL XABORT(NAMSBR//': *WATER* EXPECTED.') + TEXTT(3)=TEXT12 + NCARS=3 + IF(TEXTT(3).EQ.'WATER' ) THEN + IF( .NOT.LTMP ) + > CALL XABORT(NAMSBR//': NO TEMPERATURE GIVEN.') + IF( .NOT.LPUR ) + > CALL XABORT(NAMSBR//': NO PURITY GIVEN.') + IF(LPRES) WRITE(IOUT,9000) NAMSBR + CALL INFWAT(TEMPC,PURWGT,RBASE(1)) + NOUT= 1 + ELSEIF(TEXTT(3).EQ.'PWATER' ) THEN + IF( .NOT.LTMP ) + > CALL XABORT(NAMSBR//': NO TEMPERATURE GIVEN.') + IF( .NOT.LPUR ) + > CALL XABORT(NAMSBR//': NO PURITY GIVEN.') + IF( .NOT.LPRES) THEN + CALL INFPSA(IPRINT,TEMPK,PURWGT,PRES) + ENDIF + CALL INFWAN(TEMPK,PURWGT,PRES,RBASE(1)) + NOUT= 1 + ELSE + CALL XABORT(NAMSBR//': *WATER* or *PWATER* EXPECTED.') + ENDIF + ELSEIF(TEXTT(2).EQ.'WGT%')THEN + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.3) + > CALL XABORT(NAMSBR// + > ': *D2O*, *H2O*, *UO2* OR *THO2* EXPECTED.') + TEXTT(3)=TEXT12 + NCARS=4 + IF( NBISO.NE.3 ) + > CALL XABORT(NAMSBR//': NB OF ISOTOPES MUST BE 3.') + IPISO(1)= 0 + IPISO(2)= 0 + IPISO(3)= 0 + IF(TEXTT(3).EQ.'UO2' )THEN + IF( .NOT.LENR ) + > CALL XABORT(NAMSBR//': NO ENRICHMENT GIVEN.') + DO I=1,NBISO + IF( 15.8.LT.AWR(I).AND.AWR(I).LT.16.2 )THEN + IPISO(1)= I + ELSEIF( 234.8.LT.AWR(I).AND.AWR(I).LT.235.2 )THEN + IPISO(2)= I + ELSEIF( 237.8.LT.AWR(I).AND.AWR(I).LT.238.2 )THEN + IPISO(3)= I + ELSE + CALL XABORT(NAMSBR//': NOT A U5,U8 OR O ISOTOPE.') + ENDIF + ENDDO + IF( IPISO(1)*IPISO(2)*IPISO(3).EQ.0 ) + > CALL XABORT(NAMSBR//': MISSING ONE OF TH2,U3 OR O.') + RBASE(IPISO(2))= ENRWGT + RBASE(IPISO(3))= 100.- ENRWGT + RBASE(IPISO(1))= 2.*AWR(IPISO(1))* + > (RBASE(IPISO(2))/AWR(IPISO(2))+ RBASE(IPISO(3))/AWR(IPISO(3))) + TOTMU= RBASE(IPISO(1))+RBASE(IPISO(2))+RBASE(IPISO(3)) + RBASE(IPISO(1))= 100.*RBASE(IPISO(1))/TOTMU + RBASE(IPISO(2))= 100.*RBASE(IPISO(2))/TOTMU + RBASE(IPISO(3))= 100.*RBASE(IPISO(3))/TOTMU + ELSEIF(TEXTT(3).EQ.'THO2' )THEN + IF( .NOT.LENR ) + > CALL XABORT(NAMSBR//': NO ENRICHMENT GIVEN.') + DO I=1,NBISO + IF( 15.8.LT.AWR(I).AND.AWR(I).LT.16.2 )THEN + IPISO(1)= I + ELSEIF( 232.8.LT.AWR(I).AND.AWR(I).LT.233.2 )THEN + IPISO(2)= I + ELSEIF( 231.8.LT.AWR(I).AND.AWR(I).LT.232.2 )THEN + IPISO(3)= I + ELSE + CALL XABORT(NAMSBR// + > ': NOT A TH2,U3 OR O ISOTOPE.') + ENDIF + ENDDO + IF( IPISO(1)*IPISO(2)*IPISO(3).EQ.0 ) + > CALL XABORT(NAMSBR//': MISSING ONE OF TH2,U3 OR O.') + RBASE(IPISO(2))= ENRWGT + RBASE(IPISO(3))= 100.- ENRWGT + RBASE(IPISO(1))= 2.*AWR(IPISO(1))* + > (RBASE(IPISO(2))/AWR(IPISO(2))+ RBASE(IPISO(3))/AWR(IPISO(3))) + TOTMU= RBASE(IPISO(1))+RBASE(IPISO(2))+RBASE(IPISO(3)) + RBASE(IPISO(1))= 100.*RBASE(IPISO(1))/TOTMU + RBASE(IPISO(2))= 100.*RBASE(IPISO(2))/TOTMU + RBASE(IPISO(3))= 100.*RBASE(IPISO(3))/TOTMU + ELSEIF(TEXTT(3).EQ.'D2O' .OR. TEXTT(3).EQ.'H2O')THEN + IF( .NOT.LPUR ) + > CALL XABORT(NAMSBR//': NO PURITY GIVEN.') + DO I=1,NBISO + IF( 15.8.LT.AWR(I).AND.AWR(I).LT.16.2 )THEN + IPISO(1)= I + ELSEIF( 0.8.LT.AWR(I).AND.AWR(I).LT.1.2 )THEN + IPISO(2)= I + ELSEIF( 1.8.LT.AWR(I).AND.AWR(I).LT.2.2 )THEN + IPISO(3)= I + ELSE + CALL XABORT(NAMSBR//': NOT A H1,D2 OR O ISOTOPE.') + ENDIF + ENDDO + IF( IPISO(1)*IPISO(2)*IPISO(3).EQ.0 ) + > CALL XABORT(NAMSBR//': MISSING ONE OF H1,D2 OR O.') + RBASE(IPISO(2))= (100.-PURWGT)*2.*AWR(IPISO(2))/ + > (2.*AWR(IPISO(2))+AWR(IPISO(1))) + RBASE(IPISO(3))= PURWGT *2.*AWR(IPISO(3))/ + > (2.*AWR(IPISO(3))+AWR(IPISO(1))) + RBASE(IPISO(1))= 100.-(RBASE(IPISO(2))+RBASE(IPISO(3))) + ELSE + CALL XABORT(NAMSBR// + > ': *D2O*, *H2O*, *UO2* OR *THO2* EXPECTED.') + ENDIF + NOUT= NBISO + NBISO= 0 + ELSE + CALL XABORT(NAMSBR//': *DENS* OR *WGT%* EXPECTED.') + ENDIF + ELSEIF(TEXTT(1).EQ.'GET' )THEN + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.3 )CALL XABORT(NAMSBR//': *MASS* EXPECTED.') + TEXTT(2)=TEXT12 + NCARS=2 + IF(TEXTT(2).EQ.'MASS' ) THEN + IF( NBISO.EQ.0 ) + > CALL XABORT(NAMSBR//': ISOTOPE LIST NOT SPECIFIED.') + NOUT= NBISO + NBISO= 0 + DO ILOOP= 1, NOUT + RBASE(ILOOP)= AWR(ILOOP) + ENDDO + ELSE + CALL XABORT(NAMSBR//': *MASS* EXPECTED.') + ENDIF + ELSE + CALL XABORT(NAMSBR//': '//TEXT12//' IS AN INVALID KEYWORD.') + ENDIF +*---- +* PUT PARMS IN CLE-2000 REAL VARIABLES (WRITE MODE). +*---- + DO ILOOP= 1, NOUT + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.-ITYPE )THEN + CALL XABORT(NAMSBR//': INVALID TYPE FOR OUTPUT VALUE') + ELSEIF( IPRINT.GT.0 )THEN + IF(NCARS .EQ. 2) THEN + WRITE(IOUT,6000) NAMSBR,TEXTT(1),TEXTT(2), + > HNAMIS(ILOOP),RBASE(ILOOP) + ELSE IF(NCARS .EQ. 3) THEN + WRITE(IOUT,6001) NAMSBR,TEXTT(1),TEXTT(2),TEXTT(3), + > RBASE(ILOOP) + ELSE IF(NCARS .EQ. 4) THEN + WRITE(IOUT,6002) NAMSBR,TEXTT(1),TEXTT(2),TEXTT(3), + > HNAMIS(ILOOP),RBASE(ILOOP) + ENDIF + ENDIF + CALL REDPUT(ITYPE,NITMA,RBASE(ILOOP),TEXT12,DFLOTT) + ENDDO + GO TO 20 + 40 CONTINUE + RETURN +* + 6000 FORMAT(A6,': ',2(A12,1X),'Isotope ',A8,' <- ',1P,E15.7) + 6001 FORMAT(A6,': ',3(A12,1X),' <- ',1P,E15.7) + 6002 FORMAT(A6,': ',3(A12,1X),'Isotope ',A8,' <- ',1P,E15.7) + 9000 FORMAT('***** WARNING in ',A6,'*****'/ + > ' Pressure is not used with option -WATER-'/ + > ' For pressure dependence use option -PWATER-') + END diff --git a/Dragon/src/INFAPL.f b/Dragon/src/INFAPL.f new file mode 100644 index 0000000..7587d8c --- /dev/null +++ b/Dragon/src/INFAPL.f @@ -0,0 +1,110 @@ +*DECK INFAPL + SUBROUTINE INFAPL(CFILNA,IPRINT,NBISO,HNAMIS,AWR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To recover mass for isotopes of APOLIB libraries. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input +* CFILNA APOLIB1 file name. +* IPRINT print flag. +* NBISO number of isotopes. +* HNAMIS isotope names. +* +*Parameters: output +* AWR isotope weights. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* PARAMETERS +*---- + INTEGER IOUT,MAXIT + PARAMETER (IOUT=6,MAXIT=1000) +*---- +* FUNCTIONS +*---- + INTEGER KDROPN,KDRCLS + DOUBLE PRECISION XDRCST +*---- +* LOCAL VARIABLES +*---- + INTEGER NBISO,IPRINT,IUNIT,IISO,INDLOR,NR,NIT,I,K,IMX,NISB, + 1 NRST,ICC,NS1,IC,NRSTR,NN,IER + INTEGER IT(MAXIT) +* + REAL AA + REAL AWR(NBISO) + CHARACTER CFILNA*64,HNAMIS(NBISO)*8,HNISOR*8,FORM*4 + EQUIVALENCE(AA,NN) + REAL CONVM +*---- +* OPEN APOLIB +*---- + CONVM=REAL(XDRCST('Neutron mass','amu')) + IF( IPRINT.GT.0 ) THEN + WRITE(IOUT,6000) CFILNA + ENDIF + IUNIT=KDROPN(CFILNA,2,2,0) + IF( IUNIT.LE.0 )THEN + WRITE(IOUT,9000) CFILNA + CALL XABORT('INFAPL: APOL LIBRARY CANNOT BE OPENED') + ENDIF + IISO= 0 + REWIND(IUNIT) + 50 READ(IUNIT) INDLOR,NR,NIT,(IT(I),I=1,NIT) + IF( NIT.GT.MAXIT ) CALL XABORT('INFAPL: MAXIT IS TOO SMALL') + IF(INDLOR.EQ.9999) GO TO 700 + DO 70 IMX=1,NBISO + HNISOR= HNAMIS(IMX) + I=INDEX(HNISOR,' ') + IF(I.EQ.0) THEN + READ(HNISOR,'(I8)') NISB + ELSE + WRITE(FORM,'(2H(I,I1,1H))') I-1 + READ(HNISOR,FORM) NISB + ENDIF + IF( NISB.EQ.INDLOR )THEN + IF( IPRINT.GT.0 ) WRITE(IOUT,6001) HNISOR + IISO= IISO + 1 + NRST= IT(4) + NS1= 0 + IF( IT(5).LT.0 ) NS1= -IT(5) + IC=5+NS1+NRST + NRSTR=IT(IC) + ICC=IC+6*NRSTR+1 + NN=IT(ICC) + AWR(IMX)=AA*CONVM + ENDIF + 70 CONTINUE + DO 80 K=1,NR + READ(IUNIT) + 80 CONTINUE + GO TO 50 +* +* CHECK IF ALL NBISO ISOTOPES HAVE BEEN PROCESSED. + 700 IF( IISO.NE.NBISO )THEN + CALL XABORT('INFAPL: SOME ISOTOPES WERE NOT RECOVERED') + ENDIF +* +* CLOSE APOLIB FILE. + IER=KDRCLS(IUNIT,1) + IF(IER.LT.0) CALL XABORT( + > 'INFAPL: Impossible to close library '//CFILNA) + RETURN +* + 9000 FORMAT(/' ERROR IN PROCESSING APOL LIBRARY:',A8) + 6000 FORMAT(/' PROCESSING APOL LIBRARY NAME ',A8) + 6001 FORMAT(/' PROCESSING ISOTOPE/MATERIAL = ',A12) + END diff --git a/Dragon/src/INFDRA.f b/Dragon/src/INFDRA.f new file mode 100644 index 0000000..b5d8157 --- /dev/null +++ b/Dragon/src/INFDRA.f @@ -0,0 +1,96 @@ +*DECK INFDRA + SUBROUTINE INFDRA(CFILNA,IPRINT,NBISO,HNAMIS,AWRISO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To recover mass for isotopes of DRAGON libraries. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input +* CFILNA DRAGLIB file name. +* IPRINT print flag. +* NBISO number of isotopes. +* HNAMIS isotope names. +* +*Parameters: output +* AWRISO isotope weights. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE + INTEGER IPRINT,NBISO + CHARACTER CFILNA*64,HNAMIS(NBISO)*8 + REAL AWRISO(NBISO) +C---- +C FUNCTIONS +C---- + DOUBLE PRECISION XDRCST +C---- +C DRAGON LIBRARY PARAMETERS +C---- + TYPE(C_PTR) IPDRL + INTEGER IOUT,ISO,LENGT,ITYLCM + PARAMETER (IOUT=6) + CHARACTER NAMLOC*12,HSMG*131 + REAL CONVM +*---- +* For INFDRA, file name is limited to 12 characters +* because of the requirements for compatibility with +* LINKED_LIST +*---- + NAMLOC=CFILNA(1:12) +C---- +C TEST IF FILE NAME EXISTS +C---- + CONVM=REAL(XDRCST('Neutron mass','amu')) + IF(NAMLOC.EQ.' ' )THEN + CALL XABORT('INFDRA: DRAGON LIBRARY HAS NOT BEEN SET') + ENDIF +C---- +C OPEN FILE AND READ INFORMATION DATA RECORDS +C---- + CALL LCMOP(IPDRL,NAMLOC,2,2,0) + DO 100 ISO=1,NBISO + CALL LCMLEN(IPDRL,HNAMIS(ISO),LENGT,ITYLCM) + IF(LENGT.EQ.0) THEN + CALL LCMLIB(IPDRL) + WRITE(HSMG,9000) HNAMIS(ISO),CFILNA + CALL XABORT(HSMG) + ENDIF + CALL LCMSIX(IPDRL,HNAMIS(ISO),1) + CALL LCMGET(IPDRL,'AWR',AWRISO(ISO)) + AWRISO(ISO)=AWRISO(ISO)*CONVM + IF(IPRINT.GE.100) THEN + WRITE(IOUT,6000) HNAMIS(ISO),AWRISO(ISO) + ENDIF + CALL LCMSIX(IPDRL,' ',2) + 100 CONTINUE +C---- +C CLOSE FILE +C---- + CALL LCMCL(IPDRL,1) +C---- +C RETURN +C---- + RETURN +C---- +C PRINT FORMAT +C---- + 6000 FORMAT(' DRAGON ISOTOPE =',A8, + > ' HAS ATOMIC WEIGHT RATIO = ',F12.5) +C---- +C ABORT FORMAT +C---- + 9000 FORMAT('INFDRA: MATERIAL/ISOTOPE ',A8, + > ' IS MISING ON DRAGON LIBRARY FILE ',A64) + END diff --git a/Dragon/src/INFNDA.f b/Dragon/src/INFNDA.f new file mode 100644 index 0000000..04d6b1d --- /dev/null +++ b/Dragon/src/INFNDA.f @@ -0,0 +1,97 @@ +*DECK INFNDA + SUBROUTINE INFNDA(CFILNA,IPRINT,NBISO,HNAMIS,AWRISO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover isotopic masses for isotopes of NDAS-type libraries. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* +*Author(s): A. Hebert +* +*Parameters: input +* CFILNA name of the NDAS file. +* IPRINT print flag. +* NBISO number of isotopes present in the calculation domain. +* HNAMIS isotope names. +* +*Parameters: output +* AWRISO isotopic masses. +* +*Reference: +* Copyright (C) from NDAS Atomic Energy of Canada Limited utility (2006) +* +*----------------------------------------------------------------------- +* + USE FSDF + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,NBISO + CHARACTER CFILNA*(*),HNAMIS(NBISO)*8 + REAL AWRISO(NBISO) +*---- +* Local variables +*---- + INTEGER IOUT,MAXISO + PARAMETER(IOUT=6,MAXISO=500) + CHARACTER TEXT8*8,HSMG*131 + INTEGER I,ISO,IND,IERR,NEL,ISOID,ISONRF(2),HEADER(16), + > HNAM(2,MAXISO) + REAL RHEAD(200) +*---- +* Read NDAS library parameters +*---- + IF(CFILNA.EQ.' ' )THEN + CALL XABORT('INFNDA: NDAS library has not been set') + ENDIF + CALL XSDOPN(CFILNA,IERR) + IF(IERR.NE.0) CALL XABORT('INFNDA: XSDOPN could not open Library' + > //' files') + CALL XSDBLD(6001,HEADER,IERR) + IF(IERR.NE.0) CALL XABORT('INFNDA: XSDBLD could not read library' + > //' parameters') + NEL=HEADER(1) + IF(NEL.GT.MAXISO) THEN + WRITE(IOUT,30) MAXISO,NEL + CALL XABORT('INFNDA: Invalid number of isotopes') + ENDIF +*---- +* Recover the isotope names and identifiers from the library +*---- + DO I=1,NEL + CALL XSDNAM(I,ISOID,TEXT8,IERR) + IF(IERR.NE.0) CALL XABORT('INFNDA: XSDNAM index overflow') + READ(TEXT8,'(2A4)') HNAM(1,I),HNAM(2,I) + ENDDO +*---- +* Read through NDAS file and accumulate isotopic mass values +*---- + DO ISO=1,NBISO + READ(HNAMIS(ISO),'(2A4)') (ISONRF(I),I=1,2) + IND=0 + DO I=1,NEL + IF((ISONRF(1).EQ.HNAM(1,I)).AND. + > (ISONRF(2).EQ.HNAM(2,I))) THEN + IND=I + GO TO 10 + ENDIF + ENDDO + WRITE(HSMG,30) HNAMIS(ISO),CFILNA + CALL XABORT(HSMG) +* Load nuclide header + 10 CALL XSDISO(7000,6001,IND,RHEAD,IERR) + AWRISO(ISO)=RHEAD(3) + IF(IPRINT.GE.100) WRITE(IOUT,40) HNAMIS(ISO),AWRISO(ISO) + ENDDO + CALL XSDCL() + RETURN +* + 30 FORMAT('INFNDA: MATERIAL/ISOTOPE ',A8, + > ' IS MISSING ON NDAS LIBRARY FILE ',A8) + 40 FORMAT('INFNDA: DRAGON ISOTOPE =',A8, + > ' HAS ATOMIC WEIGHT RATIO = ',F12.5) + END diff --git a/Dragon/src/INFPSA.f b/Dragon/src/INFPSA.f new file mode 100644 index 0000000..ca76de4 --- /dev/null +++ b/Dragon/src/INFPSA.f @@ -0,0 +1,80 @@ +*DECK INFPSA + SUBROUTINE INFPSA(IPRINT,TEMPK,PURWGT,PRES) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute pressure at saturation for a mixture of light and heavy water. +* +*Copyright: +* Copyright (C) 2016 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): C. Kieffer and G. Marleau +* +*Parameters: input +* IPRINT print parameter. +* TEMPK temperature (kelvin). +* PURWGT D2O purity (in wgt%). +* +*Parameters: output +* PRES pressure (Pa). +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IPRINT + REAL TEMPK,PURWGT,PRES +*---- +* LOCAL VARIABLES +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='INFPSA') + REAL PD2O,PH2O,WGTD2O,WGTH2O,WGID2O,WGIH2O + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF +*---- +* For heavy water, T limited to 90.5 C < T < 358.5 C +*---- + WGTD2O = 0.01 * PURWGT + WGTH2O = 1.00 - WGTD2O + IF(PURWGT .LT. 1.0) THEN + CALL THMSAP(PH2O,TEMPK) + WGIH2O=WGTH2O/PH2O + ELSE + PH2O=0.0 + WGIH2O=0.0 + ENDIF + IF(PURWGT .GT. 0.0) THEN + CALL THMHSP(PD2O,TEMPK) + IF(PD2O .GT. 0.0) THEN + WGID2O=WGTD2O/PD2O + ELSE + WGID2O=WGTD2O/PH2O + ENDIF + ELSE + WGID2O=0.0 + ENDIF + PRES = 1.0 /( WGIH2O +WGID2O ) + 0.01 +*---- +* Processing finished, return +*---- + IF(IPRINT .GE. -10) THEN + WRITE(IOUT,*) 'Saturation pressure (Pa)', PRES + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + END diff --git a/Dragon/src/INFTR1.f b/Dragon/src/INFTR1.f new file mode 100644 index 0000000..84fce62 --- /dev/null +++ b/Dragon/src/INFTR1.f @@ -0,0 +1,163 @@ +*DECK INFTR1 + SUBROUTINE INFTR1(CFILNA,IPRINT,NBISO,HNAMIS,AWRISO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To recover mass for isotopes of MATXS type libraries +* use MATXS format from NJOY-II or NJOY89. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input +* CFILNA file name. +* IPRINT print flag. +* NBISO number of isotopes. +* HNAMIS isotope names. +* +*Parameters: output +* AWRISO isotope weights. +* +*Reference: +* R. E. MACFARLANE, TRANSX-CTR: A code for interfacing +* MATXS cross-section libraries to nuclear transport codes for +* fusion systems analysis, Los Alamos National Laboratory, +* Report LA-9863-MS, New Mexico, February 1984. +* +*----------------------------------------------------------------------- +* + USE XDRMOD + IMPLICIT NONE + INTEGER IPRINT,NBISO + CHARACTER CFILNA*64,HNAMIS(NBISO)*8 + REAL AWRISO(NBISO) +*---- +* LOCAL VARIABLES +*---- + INTEGER IOUT,MULT,MAXA + CHARACTER FORM*4 + PARAMETER (IOUT=6,MULT=2,MAXA=1000,FORM='(A6)') +*---- +* FUNCTIONS +*---- + INTEGER KDROPN,KDRCLS + DOUBLE PRECISION XDRCST + INTEGER NIN,IREC,NWDS,NPART,NTYPE,L2,L2H,IRZT,IT, + > NDEX,NMAT,NINP,NING,NOUTP,NOUTG,LOCT,LMC, + > IRZM,IM,ISO,LOC,IER,IA(MAXA) + CHARACTER HSMG*131,HTYPE*6,HMAT*6 + REAL RA(MAXA) + DOUBLE PRECISION DA(MAXA/2) + REAL CONVM + EQUIVALENCE (RA(1),IA(1),DA(1)) +*---- +* OPEN MATXS FILE AND INITIALIZE LIBRARY +*---- + CONVM=REAL(XDRCST('Neutron mass','amu')) + NIN=KDROPN(CFILNA,2,2,0) + IF(NIN.LE.0) THEN + WRITE(HSMG,9000) CFILNA + CALL XABORT(HSMG) + ENDIF + IREC=2 + NWDS=3 +*-------FILE CONTROL--------------- + CALL XDREED(NIN,IREC,RA,NWDS) +*---------------------------------- + NPART=IA(1) + NTYPE=IA(2) + IREC=4 + NWDS=(NPART+NTYPE)*MULT+6*NTYPE+NPART + IF(NWDS.GT.MAXA) CALL XABORT + > ('INFTR1: LENGTH OF RECORD 4 > MAXA ') +*-------FILE DATA------------------ + CALL XDREED(NIN,IREC,RA,NWDS) +*---------------------------------- + IF((NWDS/2)*2.NE.NWDS) NWDS=NWDS+1 + L2=1+NWDS + L2H=(L2-1)/MULT+1 + IRZT=5+NPART +*---- +* DATA TYPE LOOP +*---- + DO 100 IT=1,NTYPE + WRITE(HTYPE,FORM) DA(NPART+IT) + CALL XDRCAS('LOWTOUP',HTYPE) + IF(HTYPE.NE.'NSCAT'.AND.HTYPE.NE.'NTHERM') GO TO 105 + NDEX=(NPART+NTYPE)*MULT+IT + NMAT=IA(NDEX) + NDEX=NDEX+NTYPE + NINP=IA(NDEX) + NDEX=NDEX+NTYPE + NING=IA(NDEX) + NDEX=NDEX+NTYPE + NOUTP=IA(NDEX) + NDEX=NDEX+NTYPE + NOUTG=IA(NDEX) + NDEX=NDEX+NTYPE + LOCT=IA(NDEX) +*---- +* DATA TYPE CONTROL +*---- + IREC=LOCT+IRZT + NWDS=(2+MULT)*NMAT+NINP+NOUTP+1 + IF(L2+NWDS-1.GT.MAXA) CALL XABORT + > ('INFTR1: LENGTH OF CURRENT RECORD > MAXA ') +*---------------------------------------- + CALL XDREED(NIN,IREC,RA(L2),NWDS) +*---------------------------------------- + IF((NWDS/2)*2.NE.NWDS) NWDS=NWDS+1 + LMC=L2+NWDS + IRZM=IREC+1 +*---- +* READ THROUGH MATXS FILE AND GET AWR FOR ISOTOPES +*---- + DO 110 IM=1,NMAT + WRITE(HMAT,FORM) DA(L2H-1+IM) + DO 120 ISO=1,NBISO + IF(HMAT.EQ.HNAMIS(ISO)(:6)) THEN + LOC=L2-1+MULT*NMAT+IM + IREC=IA(LOC+NMAT)+IRZM + NWDS=MULT+1+6*IA(LOC) + IF(LMC+NWDS-1.GT.MAXA) CALL XABORT + > ('INFTR1: LENGTH OF CURRENT RECORD > MAXA ') +*------------------------------------------- + CALL XDREED(NIN,IREC,RA(LMC),NWDS) +*------------------------------------------- + AWRISO(ISO)=RA(LMC+MULT)*CONVM + IF(IPRINT.GE.100) THEN + WRITE(IOUT,6000) HNAMIS(ISO),AWRISO(ISO) + ENDIF + ENDIF + 120 CONTINUE + 110 CONTINUE + 105 CONTINUE + 100 CONTINUE +*---- +* CLOSE MATXS FILE. +*---- + CALL XDRCLS(NIN) + IER=KDRCLS(NIN,1) + IF(IER.LT.0) THEN + WRITE(HSMG,9001) CFILNA + CALL XABORT(HSMG) + ENDIF + RETURN +*---- +* PRINT FORMATS +*---- + 6000 FORMAT(' MATXS ISOTOPE =',A8, + > ' HAS ATOMIC WEIGHT RATIO = ',F10.3) +*---- +* ABORT FORMATS +*---- + 9000 FORMAT('INFTR1: UNABLE TO OPEN MATXS LIBRARY FILE ',A64) + 9001 FORMAT('INFTR1: UNABLE TO CLOSE MATXS LIBRARY FILE ',A64) + END diff --git a/Dragon/src/INFTR2.f b/Dragon/src/INFTR2.f new file mode 100644 index 0000000..6514c7a --- /dev/null +++ b/Dragon/src/INFTR2.f @@ -0,0 +1,129 @@ +*DECK INFTR2 + SUBROUTINE INFTR2(CFILNA,IPRINT,NBISO,HNAMIS,AWRISO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To recover mass for isotopes of MATXS type libraries +* use MATXS format from NJOY-91. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input +* CFILNA file name. +* IPRINT print flag. +* NBISO number of isotopes. +* HNAMIS isotope names. +* +*Parameters: output +* AWRISO isotope weights +* +*Reference: +* R. E. MACFARLANE, TRANSX-CTR: A code for interfacing +* MATXS cross-section libraries to nuclear transport codes for +* fusion systems analysis, Los Alamos National Laboratory, +* Report LA-9863-MS, New Mexico, February 1984. +* +*----------------------------------------------------------------------- +* + USE XDRMOD + IMPLICIT NONE + INTEGER IPRINT,NBISO + CHARACTER CFILNA*8,HNAMIS(NBISO)*64 + REAL AWRISO(NBISO) +C---- +C LOCAL VARIABLES +C---- + INTEGER IOUT,MULT,MAXA + CHARACTER FORM*4 + PARAMETER (IOUT=6,MULT=2,MAXA=1000,FORM='(A6)') +C---- +C FUNCTIONS +C---- + INTEGER KDROPN,KDRCLS + DOUBLE PRECISION XDRCST + INTEGER NIN,IREC,NWDS,NPART,NTYPE,NMAT,L2,L2H,IRZM,IM, + > ISO,LOC,IER,IA(MAXA) + CHARACTER HSMG*131,HMAT*6 + REAL RA(MAXA) + DOUBLE PRECISION DA(MAXA/2) + REAL CONVM + EQUIVALENCE (RA(1),IA(1),DA(1)) +C---- +C OPEN MATXS FILE AND INITIALIZE LIBRARY +C---- + CONVM=REAL(XDRCST('Neutron mass','amu')) + NIN=KDROPN(CFILNA,2,2,0) + IF(NIN.LE.0) THEN + WRITE(HSMG,9000) CFILNA + CALL XABORT(HSMG) + ENDIF + IREC=2 + NWDS=6 +C-------FILE CONTROL--------------- + CALL XDREED(NIN,IREC,RA,NWDS) +C---------------------------------- + NPART=IA(1) + NTYPE=IA(2) + NMAT=IA(4) + IREC=4 + NWDS=(NPART+NTYPE+NMAT)*MULT+2*NTYPE+NPART+2*NMAT + IF(NWDS.GT.MAXA) CALL XABORT + > ('INFTR2: LENGTH OF RECORD 4 > MAXA ') +C-------FILE DATA------------------ + CALL XDREED(NIN,IREC,RA,NWDS) +C---------------------------------- + IF((NWDS/2)*2.NE.NWDS) NWDS=NWDS+1 + L2=1+NWDS + L2H=NWDS/MULT+1 + IRZM=5+NPART +C---- +C READ THROUGH MATXS FILE AND GET AWR FOR ISOTOPES +C---- + DO 100 IM=1,NMAT + WRITE(HMAT,FORM) DA(L2H-1+IM) + DO 110 ISO=1,NBISO + IF(HMAT.EQ.HNAMIS(ISO)(:6)) THEN + LOC=(NPART+NTYPE+NMAT)*MULT+NPART+2*NTYPE+IM + IREC=IA(LOC+NMAT)+IRZM + NWDS=MULT+1+6*IA(LOC) + IF(L2+NWDS-1.GT.MAXA) CALL XABORT + > ('INFTR2: LENGTH OF CURRENT RECORD > MAXA ') +C------------------------------------------- + CALL XDREED(NIN,IREC,RA(L2),NWDS) +C------------------------------------------- + AWRISO(ISO)=RA(L2+MULT)*CONVM + IF(IPRINT.GE.100) THEN + WRITE(IOUT,6000) HNAMIS(ISO),AWRISO(ISO) + ENDIF + ENDIF + 110 CONTINUE + 100 CONTINUE +C---- +C CLOSE MATXS FILE. +C---- + CALL XDRCLS(NIN) + IER=KDRCLS(NIN,1) + IF(IER.LT.0) THEN + WRITE(HSMG,9001) CFILNA + CALL XABORT(HSMG) + ENDIF + RETURN +C---- +C PRINT FORMATS +C---- + 6000 FORMAT(' MATXS ISOTOPE =',A8, + > ' HAS ATOMIC WEIGHT RATIO = ',F10.3) +C---- +C ABORT FORMATS +C---- + 9000 FORMAT('INFTR2: UNABLE TO OPEN MATXS LIBRARY FILE ',A64) + 9001 FORMAT('INFTR2: UNABLE TO CLOSE MATXS LIBRARY FILE ',A64) + END diff --git a/Dragon/src/INFWAN.f b/Dragon/src/INFWAN.f new file mode 100644 index 0000000..008ec7a --- /dev/null +++ b/Dragon/src/INFWAN.f @@ -0,0 +1,62 @@ +*DECK INFWAN + SUBROUTINE INFWAN(TEMPK,PURWGT,PRES,DENSITY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute water density as a function of temperature and pressure. +* +*Copyright: +* Copyright (C) 2016 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): R. Roy and C. Kieffer +* +*Parameters: input +* TEMPK temperature (kelvin). +* PURWGT D2O purity (in wgt%). +* PRES pressure (Pa). +* +*Parameters: output +* DENSITY density (G/CM**3). +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE + REAL TEMPK,PRES,PURWGT,DENSITY,R2,R3,R4,R5 + REAL TEMPC,h, zk, zmu, cp + REAL DEND2O, DENH2O, WGTD2O, WGTH2O +*---------------------------------------------------------- +* Light water density +*---------------------------------------------------------- + CALL THMPT(PRES,TEMPK,DENH2O,h, zk, zmu, cp) + IF(DENH2O .EQ.0 ) THEN + DENH2O=0.00000001 + ENDIF +*---------------------------------------------------------- +* Heavy water density +*---------------------------------------------------------- + TEMPC=TEMPK-273.15 + IF(TEMPC.GT.358.5 .OR. TEMPC.LT.90.5 .OR. PRES .GT. 22.0E6) THEN + DEND2O = 1.11 * DENH2O + ELSE + CALL THMHPT(PRES,TEMPK,DEND2O,R2,R3,R4,R5) + ENDIF +*---------------------------------------------------------- +* Global density for the mixture +*---------------------------------------------------------- + WGTD2O = 0.01 * PURWGT + WGTH2O = 1.00 - WGTD2O + IF(PURWGT .EQ. 1.0) THEN + DENSITY=DEND2O + ELSE IF(PURWGT .EQ. 0.0) THEN + DENSITY=DENH2O + ELSE + DENSITY=DENH2O*DEND2O/(WGTH2O*DEND2O+WGTD2O*DENH2O) + ENDIF + DENSITY=DENSITY/1000.0 + RETURN + END diff --git a/Dragon/src/INFWAT.f b/Dragon/src/INFWAT.f new file mode 100644 index 0000000..dbfcafa --- /dev/null +++ b/Dragon/src/INFWAT.f @@ -0,0 +1,111 @@ +*DECK INFWAT + SUBROUTINE INFWAT(TEMPC,PURWGT,DENSTY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute water density as a function of temperature and pressure. +* +*Copyright: +* Copyright (C) 1995 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): R. Roy +* +*Parameters: input +* TEMPC temperature (celcius). +* PURWGT D2O purity (in wgt%). +* +*Parameters: output +* DENSTY density (G/CM**3). +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +* +* TEMPERATURE DEPENDENT DENSITY CALCULATION IS DONE ACCORDING TO: +* +* DENSITY = D(H2O) * D(D2O) / +* ( WGT%(H2O) * D(D2O) + WGT%(D2O) * D(H2O) ) +* + REAL TEMPC, PURWGT, DENSTY + REAL DEND2O, DENH2O, WGTD2O, WGTH2O + REAL AIKINT + REAL TDND2O(20), TDNH2O(85), TMPD2O(20), TMPH2O(85) +* +*------------------------------------------------------------------ +* +* >>> TABLES ORIGINALLY CAME FROM ROUTINE dmats.f (WIMS) +* +* +* * D2O DATA CONSISTENT WITH AECL 7531, TABLE FROM J. PHYS. CHEM. REF. +* DATA, VOL11, NO.1, 1982, P6 (SAME AUTHORS) +* + DATA TMPD2O /3.8, 6.0, 10.0, 15.0, 20.0, 25.0, 30.0, 35.0, 40.0, + > 49.99, 100.0, 111.02, 150.02, 200.0, 250.0, 275., + > 300., 325., 350.127, 360.057/ +* + DATA TDND2O / 0.90464, 0.90439, 0.90419, 0.90428, 0.90472, + > 0.90545, 0.90645, 0.90771, 0.90918, 0.91274, 0.94057, + > 0.94866, 0.98296, 1.04354, 1.13149, 1.19270, 1.2740, + > 1.3917, 1.6044, 1.7709 / +* +* * H2O DATA FROM CRNL-1533 +* + DATA TMPH2O /3.98,20.0,30.0,40.0,50.0, + > 60.0,70.0,80.0,90.0,99.6, + > 120.2,133.5,143.6,151.8,158.8,165.0, + > 170.4,175.4,179.9,188.0,195.0,201.4, + > 207.1,212.4,217.2,221.8,226.0,230.0, + > 233.8,237.4,240.9,244.2,247.3,250.3, + > 253.2,256.0,258.8,261.4,263.9,266.4, + > 268.8,271.1,273.3,275.6,277.7,279.8, + > 281.8,283.8,285.8,287.7,289.6,291.4, + > 293.2,295.0,296.7,298.4,300.1,301.7, + > 303.3,307.2,311.0,314.6,318.0,321.4, + > 324.6,327.8,330.8,333.8,336.6,339.4, + > 342.1,344.8,347.3,349.8,352.3,354.6, + > 357.0,359.2,361.4,363.6,365.7,367.8, + > 369.8,371.8,373.7/ +* + DATA TDNH2O /0.999973,0.998418,0.995848,0.992385,0.988164, + > 0.983274,0.977785,0.971753,0.965218,0.958479, + > 0.942737,0.931621,0.922712,0.915136,0.908466,0.902459, + > 0.896961,0.891869,0.887107,0.878373,0.870456,0.863165, + > 0.856371,0.849982,0.843931,0.838165,0.832644,0.827336, + > 0.822215,0.817259,0.812449,0.807771,0.803211,0.798756, + > 0.794401,0.790133,0.785946,0.781833,0.777787,0.773804, + > 0.769879,0.766007,0.762183,0.758405,0.754669,0.750972, + > 0.747310,0.743682,0.740085,0.736516,0.732973,0.729455, + > 0.725958,0.722482,0.719025,0.715585,0.712160,0.708750, + > 0.705352,0.696902,0.688503,0.680135,0.671780,0.663420, + > 0.655039,0.646619,0.638141,0.629586,0.620932,0.612153, + > 0.603220,0.594098,0.584739,0.575085,0.565162,0.554167, + > 0.543564,0.531796,0.519245,0.505736,0.490945,0.474241, + > 0.454256,0.427351,0.374304/ +* +*------------------------------------------------------------------ +* +* COMPUTE DENSITIES FOR LIGHT AND HEAVY WATER (PURE) +* AT SUCH TEMPERATURE: +* +* 1. USE DIRECT INTERPOLATION FOR LIGHT WATER: +* + DENH2O = AIKINT(TEMPC,TMPH2O,TDNH2O,85,1.0E-5) +* +* 2. INVERSE THE INTERPOLATION FOR HEAVY WATER: +* + DEND2O = 1.0/AIKINT(TEMPC,TMPD2O,TDND2O,20,1.0E-5) +* + WGTD2O = 0.01 * PURWGT + WGTH2O = 1.00 - WGTD2O +* +* COMPUTE GLOBAL DENSITY A MIX OF LIGHT AND HEAVY WATER: +* + DENSTY = DENH2O * DEND2O /( WGTH2O * DEND2O + WGTD2O * DENH2O ) +* + RETURN + END diff --git a/Dragon/src/INFWD4.f b/Dragon/src/INFWD4.f new file mode 100644 index 0000000..4a9800a --- /dev/null +++ b/Dragon/src/INFWD4.f @@ -0,0 +1,199 @@ +*DECK INFWD4 + SUBROUTINE INFWD4(CFILNA,IVERW,IPRINT,NBISO,HNAMIS,AWRISO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To recover mass for isotopes of WIMS-D4 or WIMS-E libraries. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau, A. Hebert +* +*Parameters: input +* CFILNA WIMS file name. +* IVERW TYPE OF FILE (=4: WIMS-D4; =5: WIMS-E). +* IPRINT print flag. +* NBISO number of isotopes. +* HNAMIS isotope names. +* +*Parameters: output +* AWRISO isotope weights. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE + INTEGER IVERW,IOUT,IPRINT,NBISO,KDROPN,KDRCLS + PARAMETER (IOUT=6) + CHARACTER CFILNA*64,HNAMIS(NBISO)*8 + REAL AWRISO(NBISO) + EXTERNAL KDROPN,KDRCLS +*---- +* MEMORY ALLOCATION PARAMETERS +*---- + INTEGER IBASE(1) + REAL RBASE(1) + COMMON RBASE + EQUIVALENCE (RBASE(1),IBASE(1)) +*---- +* WIMS-D4 LIBRARY PARAMETERS +*---- + INTEGER IUNIT,IUTYPE,IACTO,IACTC,LRIND,MAXISO,LPZ + PARAMETER (IUTYPE=2,IACTO=2,IACTC=1,LRIND=0,MAXISO=246,LPZ=8) + CHARACTER CWISO(MAXISO)*8 + INTEGER NPZ(LPZ),IWISO(MAXISO),NEL,NGROUP,IEL,IELRT,JEL, + > IDIEL,IZ,NFIEL,NTMP,NRIEL,IDUM,IERR,IT,JSO,ISOF, + > IP1OPT,ISORD(MAXISO) + REAL AWR,RDUM + IF(CFILNA.EQ.' ' )THEN + CALL XABORT('INFWD4: WIMS LIBRARY HAS NOT BEEN SET') + ENDIF +*---- +* OPEN WIMS-D4 LIBRARY +* READ GENERAL DIMENSIONING +*---- + IUNIT=KDROPN(CFILNA,IACTO,IUTYPE,LRIND) + IF(IUNIT.LE.0) CALL XABORT( + > 'INFWD4: WIMS-D4 LIBRARY CANNOT BE OPENED FOR MIXS :'//CFILNA) + READ(IUNIT) (NPZ(IT),IT=1,LPZ) + NEL=NPZ(1) + NGROUP=NPZ(2) + IF(NEL.GT.MAXISO) THEN + WRITE(IOUT,9000) MAXISO,NEL + CALL XABORT('INFWD4: INVALID NUMBER OF ISOTOPES') + ENDIF + IF(NBISO.GT.MAXISO) THEN + WRITE(IOUT,9001) NBISO,NEL + CALL XABORT('INFWD4: INVALID NUMBER OF ISOTOPES') + ENDIF +*---- +* READ ISOTOPE ID NUMBER AND CREATE EQUIVALENT ISOTOPE NAME +* SCAN TO ASSOCIATE WIMS ISOTOPE NUMBER WITH DRAGON ISOTOPE NUMBER +* VERIFY IF ALL ISOTOPES REQUIRED ARE PRESENT +*---- + READ(IUNIT) (IWISO(IEL),IEL=1,NEL) + DO 100 IEL=1,NEL + CWISO(IEL)=' ' + IF (IWISO(IEL).LT.10) THEN + WRITE(CWISO(IEL),'(I1)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.100) THEN + WRITE(CWISO(IEL),'(I2)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.1000) THEN + WRITE(CWISO(IEL),'(I3)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.10000) THEN + WRITE(CWISO(IEL),'(I4)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.100000) THEN + WRITE(CWISO(IEL),'(I5)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.1000000) THEN + WRITE(CWISO(IEL),'(I6)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.10000000) THEN + WRITE(CWISO(IEL),'(I7)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.100000000) THEN + WRITE(CWISO(IEL),'(I8)') IWISO(IEL) + ENDIF + DO 101 JSO=1,NBISO + IF(HNAMIS(JSO).EQ.CWISO(IEL)) THEN + ISORD(JSO)=IEL + ENDIF + 101 CONTINUE + 100 CONTINUE + IF(IPRINT.GE.100) THEN + WRITE(IOUT,6000) (CWISO(IEL),IEL=1,NEL) + ENDIF + DO 102 JSO=1,NBISO + IF(ISORD(JSO).EQ.0) THEN + WRITE(IOUT,9002) HNAMIS(JSO),CFILNA + CALL XABORT('INFWD4: MISSING ISOTOPE') + ENDIF + 102 CONTINUE +*---- +* SKIP GROUP STRUCTURE, FISSION SPECTRUM, DEPLETION CHAIN +* AND END RECORD +*---- + READ(IUNIT) RDUM + IF(IVERW.EQ.4) READ(IUNIT) RDUM + DO 110 IEL=1,NEL + READ(IUNIT) IDUM + 110 CONTINUE + IF(IVERW.EQ.4) READ(IUNIT) RDUM + DO 120 IELRT=1,NEL + IF(IVERW.EQ.4) THEN + READ(IUNIT) IDIEL,AWR,IZ,NFIEL,NTMP,NRIEL + ISOF=0 + IP1OPT=1 + ELSE IF(IVERW.EQ.5) THEN + READ(IUNIT) IDIEL,AWR,IZ,NFIEL,NTMP,NRIEL,ISOF,IP1OPT + ENDIF +*---- +* LOCATE ISOTOPE IN LIST OF LIBRARY ISOTOPES IN THE CASE +* WHERE LIBRARY IS NOT COMPLETE OR THE ORDER OF ISOTOPE +* STORED IS DIFFERENT FROM THAT OF THE ISOTOPE NAMES +*---- + IEL=0 + DO 121 JEL=1,NEL + IF(IDIEL.EQ.IWISO(JEL)) THEN + IEL=JEL + GO TO 125 + ENDIF + 121 CONTINUE + CALL XABORT('INFWD4: WIMSD4 LIBRARY INCOMPLETE') + 125 CONTINUE +*---- +* SCAN TO SEE IF ISOTOPE IS REQUIRED AND GET WEIGHTS. +*---- + DO 150 JSO=1,NBISO + IF(ISORD(JSO).EQ.IEL) THEN + AWRISO(JSO)=AWR + GO TO 155 + ENDIF + 150 CONTINUE + 155 CONTINUE +*---- +* OTHER RECORDS FOR THIS ISOTOPE +*---- + READ(IUNIT) RDUM + IF(NFIEL.GT.1) THEN + READ(IUNIT) RDUM + ENDIF + READ(IUNIT) IDUM + IF(NTMP.GT.0) THEN + READ(IUNIT) RDUM + DO 140 IT=1,NTMP + READ(IUNIT) RDUM + IF(NFIEL.GT.1) THEN + READ(IUNIT) RDUM + ENDIF + READ(IUNIT) IDUM + 140 CONTINUE + ENDIF + IF(ISOF.NE.0) READ(IUNIT) RDUM + IF(IP1OPT.NE.1) THEN + DO 130 IT=1,NTMP + READ(IUNIT) IDUM + 130 CONTINUE + ENDIF + IF(IVERW.EQ.4) READ(IUNIT) RDUM + 120 CONTINUE + IERR=KDRCLS(IUNIT,IACTC) + IF(IERR.LT.0) CALL XABORT( + > 'INFWD4: Impossible to close WIMS-D4 library '//CFILNA) +*---- +* RETURN +*---- + RETURN +*---- +* FORMAT +*---- + 9000 FORMAT(/' MAXIMUM NUMBER OF ISOTOPE SPECIFIED :',I10/ + > ' NUMBER OF ISOTOPE IN LIBRARY :',I10) + 9001 FORMAT(/' NUMBER OF ISOTOPE TO TREAT :',I10/ + > ' NUMBER OF ISOTOPE IN LIBRARY :',I10) + 9002 FORMAT(/' INFWD4: MATERIAL/ISOTOPE ',A64, + > ' IS MISSING ON WIMS-D4 FILE ',A8) + 6000 FORMAT(1X,'ISOTOPES ON LIBRARY'/6(4X,A8)) + END diff --git a/Dragon/src/INFWIM.f b/Dragon/src/INFWIM.f new file mode 100644 index 0000000..eab4bbf --- /dev/null +++ b/Dragon/src/INFWIM.f @@ -0,0 +1,120 @@ +*DECK INFWIM + SUBROUTINE INFWIM(CFILNA,IPRINT,NBISO,HNAMIS,AWR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To recover mass for isotopes of WIMS-AECL libraries. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau +* +*Parameters: input +* CFILNA WIMS file name. +* IPRINT print flag. +* NBISO number of isotopes. +* HNAMIS isotope names. +* +*Parameters: output +* AWR isotope weights +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IOUT,IUTYPE,IACTO,LRIND,MAXISO,MAXTEM,NCT, + > LPZ,LMASTB,LMASIN,LGENTB,LGENIN,LSUBTB,LSUBIN + PARAMETER (IOUT=6,IUTYPE=4,IACTO=2,LRIND=256, + > MAXISO=246,MAXTEM=20, + > NCT=10,LPZ=9,LMASTB=MAXISO+9, + > LMASIN=LMASTB-4,LGENTB=6,LGENIN=LGENTB, + > LSUBTB=6*MAXTEM+28,LSUBIN=LSUBTB-12) + INTEGER MASTER(LMASTB),GENINX(LGENTB),SUBINX(LSUBTB), + > IWISO(MAXISO),IPRINT,NBISO,NPZ(LPZ), + > ITITLE(2*NCT) + CHARACTER CFILNA*64,HNAMIS(NBISO)*8, + > CWISO(MAXISO)*8,CTITLE(NCT)*8 + REAL ZUBINX(LSUBTB),AWR(NBISO) + INTEGER IUNIT,IRISO,ISO,JSO,II,KDROPN + EXTERNAL KDROPN + EQUIVALENCE (SUBINX(1),ZUBINX(1)) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ICISO +* + IF( CFILNA.EQ.' ' )THEN + CALL XABORT('INFWIM: WIMS LIBRARY HAS NOT BEEN SET') + ENDIF +*---- +* OPEN WIMSLIB AND READ TITLE +*---- + IRISO=0 + IUNIT=KDROPN(CFILNA,IACTO,IUTYPE,LRIND) + IF(IUNIT.LE.0) CALL XABORT( + > 'INFWIM: WIMS-AECL LIBRARY CANNOT BE OPENED FOR MIXS :'//CFILNA) + CALL OPNIND(IUNIT,MASTER,LMASTB) + CALL REDIND(IUNIT,MASTER,LMASIN,GENINX,LGENTB,1) + IF(IPRINT.GT.0) THEN + CALL REDIND(IUNIT,MASTER,LMASIN,ITITLE,2*NCT,2) + CALL UPCKIC(ITITLE(1),CTITLE(1),NCT) + WRITE(IOUT,6000) CFILNA + WRITE(IOUT,'(1X,10A8)') (CTITLE(II),II=1,NCT) + ENDIF +*---- +* READ GENERAL INDEX, ISOTOPES NAMES AND GROUP STRUCTURE +*---- + CALL REDIND(IUNIT,GENINX,LGENIN,NPZ,LPZ,1) + CALL REDIND(IUNIT,GENINX,LGENIN,IWISO,NPZ(1),2) + ALLOCATE(ICISO(2*NPZ(1))) + CALL REDIND(IUNIT,GENINX,LGENIN,ICISO,2*NPZ(1),3) + CALL UPCKIC(ICISO(1),CWISO(1),NPZ(1)) + IF(IPRINT.GE.100) THEN + WRITE(IOUT,6200) (CWISO(II),II=1,NPZ(1)) + ENDIF + DEALLOCATE(ICISO) +*---- +* READ THROUGH DRAGON FILE AND ACCUMULATE WEIGHTS. +*---- + DO 120 ISO=1,NBISO + DO 130 JSO=1,NPZ(1) + IF(CWISO(JSO).EQ.HNAMIS(ISO)) THEN + IRISO=JSO + GO TO 131 + ENDIF + 130 CONTINUE + WRITE(IOUT,9002) HNAMIS(ISO),CFILNA + CALL XABORT('INFWIM: ISOTOPE NOT FOUND ON LIBRARY') + 131 CONTINUE + IF(IPRINT.GT.0) THEN + WRITE(IOUT,6001) HNAMIS(ISO) + ENDIF +*---- +* READ SUB INDEX ASSOCIATED WITH ISOTOPE +*---- + CALL REDIND(IUNIT,MASTER,LMASIN,SUBINX,LSUBTB,IRISO+4) + AWR(ISO)=ZUBINX(LSUBIN+3) + 120 CONTINUE + CALL CLSIND(IUNIT) +*---- +* RETURN +*---- + RETURN +*---- +* FORMAT +*---- + 9002 FORMAT(/' INFWIM: MATERIAL/ISOTOPE ',A8,' IS MISSING ON WIMS', + > ' FILE NAME ',A64) + 6000 FORMAT(/' PROCESSING WIMS LIBRARY NAME ',A64) + 6001 FORMAT(/' PROCESSING ISOTOPE/MATERIAL = ',A12) + 6200 FORMAT(1X,'ISOTOPES ON LIBRARY'/6(4X,A8)) + END diff --git a/Dragon/src/KDRDRV.F b/Dragon/src/KDRDRV.F new file mode 100644 index 0000000..0aed297 --- /dev/null +++ b/Dragon/src/KDRDRV.F @@ -0,0 +1,164 @@ +*DECK KDRDRV + INTEGER FUNCTION KDRDRV(HMODUL,NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Code dependent operator driver for DRAGON. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* HMODUL name of the operator. +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file. +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file; =6 for HDF5 file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*Parameters: output +* KDRDRV completion flag (=0: operator HMODUL exists; =1: does not +* exists). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER HMODUL*(*),HENTRY(NENTRY)*12 + INTEGER IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) +*---- +* LOCAL VARIABLES +*---- + REAL TBEG,TEND + DOUBLE PRECISION DMEMB,DMEMD + LOGICAL :: DRAMOD +* + KDRDRV=0 + DRAMOD=.TRUE. + CALL KDRCPU(TBEG) + CALL KDRMEM(DMEMB) + CALL XDRCRE(HMODUL,1) + IF(HMODUL.EQ.'GEO:') THEN + CALL GEO(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'SYBILT:') THEN + CALL SYBILT(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'EXCELT:') THEN + CALL EXCELT(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'NXT:') THEN + CALL NXT(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'PSP:') THEN + CALL PSP(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'TLM:') THEN + CALL TLM(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'MCCGT:') THEN + CALL MCCGT(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'LIB:') THEN + CALL LIB(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'SHI:') THEN + CALL SHI(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'MAC:') THEN + CALL MAC(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'ASM:') THEN + CALL ASM(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'FLU:') THEN + CALL FLU(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'EVO:') THEN + CALL EVO(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'EDI:') THEN + CALL EDI(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'INFO:') THEN + CALL INF(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'USS:') THEN + CALL USS(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'TONE:') THEN + CALL TONE(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'AUTO:') THEN + CALL AUTO(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'VDG:') THEN + CALL VDG(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'COMPO:') THEN + CALL COMPO(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'SNT:') THEN + CALL SNT(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'M2T:') THEN + CALL M2T(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'FMAC:') THEN + CALL FMAC(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'PSOUR:') THEN + CALL PSOUR(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'HEAT:') THEN + CALL HEAT(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'CHAB:') THEN + CALL CHAB(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'CPO:') THEN + CALL CPO(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'SAP:') THEN + CALL SAP(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +#if defined(HDF5_LIB) + ELSE IF(HMODUL.EQ.'APX:') THEN + CALL APX(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'MPO:') THEN + CALL MPO(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +#endif /* defined(HDF5_LIB) */ + ELSE IF(HMODUL.EQ.'MC:') THEN + CALL MCT(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'T:') THEN + CALL TRA(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'DMAC:') THEN + CALL DMA(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'EPC:') THEN + CALL EPC(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'FMT:') THEN + CALL FMT(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'SPH:') THEN + CALL SPH(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'CFC:') THEN + CALL CFC(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'SENS:') THEN + CALL SEN(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'DUO:') THEN + CALL DUO(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'BREF:') THEN + CALL BREF(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'S2M:') THEN + CALL S2M(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'G2S:') THEN + CALL G2S(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'G2MC:') THEN + CALL G2MC(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'SALT:') THEN + CALL SALT(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'MRG: ') THEN + CALL MRG(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'CLM: ') THEN + CALL CLM(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE + DRAMOD=.FALSE. + KDRDRV=KTRDRV(HMODUL,NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ENDIF + IF(KDRDRV.EQ.0) CALL XDRCRE(HMODUL,-1) + IF(DRAMOD)THEN + CALL KDRCPU(TEND) + CALL KDRMEM(DMEMD) + WRITE(6,5000) HMODUL,(TEND-TBEG),REAL(DMEMD-DMEMB) + ENDIF + RETURN +* + 5000 FORMAT('-->>MODULE ',A12,': TIME SPENT=',F13.3,' MEMORY USAGE=', + 1 1P,E10.3) + END diff --git a/Dragon/src/KELMRG.f b/Dragon/src/KELMRG.f new file mode 100644 index 0000000..5bcade6 --- /dev/null +++ b/Dragon/src/KELMRG.f @@ -0,0 +1,69 @@ +*DECK KELMRG + FUNCTION KELMRG(IPGEOM, NSURO, NVOLO, IDLGEO, MATGEO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Merge zones for a heterogeneous block. +* +*Copyright: +* Copyright (C) 1990 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPGEOM pointer to the geometry. +* NSURO number of surfaces for a specific geometry. +* NVOLO number of zones for a specific geometry. +* IDLGEO specific position for a geometry. +* +*Parameters: output +* MATGEO numbering of zones and surfaces for all geometries. +* KELMRG number of surfaces and zones renumbered. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE + LOGICAL SWONCE + TYPE(C_PTR) IPGEOM + INTEGER KELMRG,NSURO,NVOLO,IDLGEO,MATGEO(*) + INTEGER IOUT, IND, MATMIN, MATMAX, ITYLCM, IMRG, JMRG, + > ILEN, I + PARAMETER ( IOUT=6 ) +* + IND(I)= IDLGEO + I + CALL LCMLEN(IPGEOM, 'MERGE', ILEN, ITYLCM) + IF( ILEN.EQ.0 )THEN + KELMRG= NVOLO - NSURO + 1 + ELSE + IF( ILEN.GT.NVOLO ) + > CALL XABORT('KELMRG: MERGING HAS TOO MANY ZONES' ) + CALL LCMGET(IPGEOM, 'MERGE', MATGEO(IND(1)) ) + MATMIN= 100000000 + MATMAX=-100000000 + DO 10 IMRG= 1, ILEN + IF( MATGEO(IND(IMRG)).LT.MATMIN) MATMIN= MATGEO(IND(IMRG)) + IF( MATGEO(IND(IMRG)).GT.MATMAX) MATMAX= MATGEO(IND(IMRG)) + 10 CONTINUE + IF( MATMIN.NE.1 ) + > CALL XABORT('KELMRG: NO FIRST MERGING ZONE' ) + DO 30 JMRG= MATMIN, MATMAX + SWONCE= .FALSE. + DO 20 IMRG= 1, ILEN + SWONCE= SWONCE.OR.(MATGEO(IND(IMRG)).EQ.JMRG) + 20 CONTINUE + IF( .NOT.SWONCE )THEN + WRITE(IOUT,*) 'WHERE IS MERGE REGION NO.', JMRG + CALL XABORT('KELMRG: ERROR IN MERGE NUMBERING' ) + ENDIF + 30 CONTINUE + KELMRG= MATMAX - NSURO + 1 + ENDIF +* + RETURN + END diff --git a/Dragon/src/KELRNG.f b/Dragon/src/KELRNG.f new file mode 100644 index 0000000..e3202e0 --- /dev/null +++ b/Dragon/src/KELRNG.f @@ -0,0 +1,282 @@ +*DECK KELRNG + FUNCTION KELRNG( IPRT, NDIM, NEXTGE, NCPC, MINDO, MAXDO, + > ICORDO, NSURO, NVOLO, IDLGEO, + > MAXC, RMESHO, MATGEO, VOLSO, INDEXO ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Renumber all zones and surfaces for a block by the coordinate +* (rect/cyl) values. +* +*Copyright: +* Copyright (C) 1990 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPRT intermediate printing level for output. +* NDIM number of dimensions. +* NEXTGE rectangular(0)/circular(1) boundary. +* NCPC number of cylinders in a type + 3. +* MINDO min index values for all axes (rect/cyl). +* MAXDO max index values for all axes (rect/cyl). +* ICORDO principal axis directions (X/Y/Z) meshes. +* NSURO number of surfaces for a specific geometry. +* NVOLO number of zones for a specific geometry. +* IDLGEO specific position for a geometry. +* MAXC dimension of rmesho. +* RMESHO real mesh values (rect/cyl). +* MATGEO material numbers corresponding to geometries. +* VOLSO volumes and surfaces for each geometry. +* +*Parameters: output +* INDEXO coordinates for zones & surfaces of a cell. +* KELRNG number of surfaces and zones renumbered. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +* + INTEGER KELRNG, IPRT, NDIM, NEXTGE, NCPC, MAXC, + > NSURO, NVOLO, IDLGEO + INTEGER ICUR(4), MINDO(NCPC), MAXDO(NCPC), + > ICORDO(NCPC), INDEXO(4,*), MATGEO(*), IXYZ(3), + > MINT(3), MAXT(3), INCT(3), JINT(3), JAXT(3) + REAL VOLSO(*), RMESHO(MAXC) + DOUBLE PRECISION RECT(2,3), RAC(2), CEC(2), RAYMAX, RAYXY + LOGICAL LELCRN +* + INTEGER NSU, NVO, IDLGE, NCP, I, J, KSUR, ISUX, IVOX, + > INOX, ICX, ICY, ICZ, IDX, IDY, IDZ, JX, JY, JZ, + > IMAT, IMATX, IMATY, IMATZ, IMATYZ, IMATR, NBEXT, + > JCP, IX, IY, JRAY, NO, NESUR, NEVOL +* + INTEGER IOUT, IND + PARAMETER ( IOUT=6 ) +* + IND(I)= IDLGE + I +* + NSU = NSURO + NVO = NVOLO + IDLGE = IDLGEO + NCP = NCPC +* +* INITIALISATION OF INDEX AND VARIOUS THINGS + DO 20 I= NSU, NVO + MATGEO(IND(I))=0 + VOLSO(IND(I))=0.0 + DO 10 J= 1, 4 + INDEXO(J,IND(I))= 0 + 10 CONTINUE + 20 CONTINUE + KSUR= MOD(NDIM+1,3) + DO 25 I= 1, 3 + IXYZ(I)= ABS(ICORDO(I)) + JINT(I)= MINDO(IXYZ(I)) + JAXT(I)= MAXDO(IXYZ(I))+1 + IF( ICORDO(I).GT.0 )THEN + IF( I.EQ.3 )THEN + MINT(I)= MINDO(IXYZ(I))+1-KSUR + MAXT(I)= MAXDO(IXYZ(I))+KSUR + ELSE + MINT(I)= MINDO(IXYZ(I)) + MAXT(I)= MAXDO(IXYZ(I))+1 + ENDIF + INCT(I)= +1 + ELSE + IF( I.EQ.3 )THEN + MINT(I)= MAXDO(IXYZ(I))+KSUR + MAXT(I)= MINDO(IXYZ(I))+1-KSUR + ELSE + MINT(I)= MAXDO(IXYZ(I))+1 + MAXT(I)= MINDO(IXYZ(I)) + ENDIF + INCT(I)= -1 + ENDIF + 25 CONTINUE +* + KELRNG= 0 + ISUX= 0 + IVOX= 0 + INOX= 0 +* +* NUMBER ZONES & SURFACES + IF( NCP.LT.4 )THEN +* THERE ARE NO CYLINDER AT ALL + J= 3 + ICUR(4)= 0 + ICZ= 3 + ELSE + J= 4 + CEC(1)= DBLE(RMESHO(MINDO(J)-2)) + CEC(2)= DBLE(RMESHO(MINDO(J)-1)) + ICZ= ICORDO(J) + ENDIF +* +* AXIS ORDER IN TRUE GEOMETRY + ICX= MOD(ICZ , 3) + 1 + ICY= MOD(ICZ+1, 3) + 1 +* +* AXIS ORDER FOR NUMBERING PROCESS + IDX= IXYZ(ICX) + IDY= IXYZ(ICY) + IDZ= IXYZ(ICZ) +* +* LOOP OVER ALL "ICZ,ICY,ICX" ZONES, THEN RADIUS + DO 260 JZ= MINT(ICZ), MAXT(ICZ), INCT(ICZ) + ICUR(IDZ)= JZ-1 + IF( JZ.NE.JINT(ICZ).AND.JZ.NE.JAXT(ICZ) )THEN + IMATZ= 0 + ELSE + IMATZ= - 2*ICZ + IF( (INCT(ICZ).EQ.+1.AND.JZ.EQ.MINT(ICZ)) + > .OR.(INCT(ICZ).EQ.-1.AND.JZ.EQ.MAXT(ICZ)) ) + > IMATZ= IMATZ+1 + ENDIF + DO 250 JY= MINT(ICY), MAXT(ICY), INCT(ICY) + RECT(1,IDY)= DBLE(RMESHO(MAX(JINT(ICY) ,JY-1))) + RECT(2,IDY)= DBLE(RMESHO(MIN(JAXT(ICY)-1,JY ))) + ICUR(IDY)= JY-1 + IF( JY.NE.JINT(ICY).AND.JY.NE.JAXT(ICY) )THEN + IMATY= 0 + ELSE + IMATY= -2*IDY + IF( (INCT(ICY).EQ.+1.AND.JY.EQ.MINT(ICY)) + > .OR.(INCT(ICY).EQ.-1.AND.JY.EQ.MAXT(ICY)) ) + > IMATY= IMATY+1 + ENDIF +* +* TO EXCLUDE LINES + IF( IMATY*IMATZ .NE. 0 ) GO TO 250 + IMATYZ= IMATY + IMATZ + DO 240 JX= MINT(ICX), MAXT(ICX), INCT(ICX) + RECT(1,IDX)= DBLE(RMESHO(MAX(JINT(ICX) ,JX-1))) + RECT(2,IDX)= DBLE(RMESHO(MIN(JAXT(ICX)-1,JX ))) + ICUR(IDX)= JX-1 + IF( JX.NE.JINT(ICX).AND.JX.NE.JAXT(ICX) )THEN + IMATX= 0 + ELSE + IMATX= -2*IDX + IF( (INCT(ICX).EQ.+1.AND.JX.EQ.MINT(ICX)) + > .OR.(INCT(ICX).EQ.-1.AND.JX.EQ.MAXT(ICX)) ) + > IMATX= IMATX+1 + ENDIF +* +* TO EXCLUDE SINGLE POINTS + IF( IMATYZ*IMATX .NE. 0 ) GO TO 240 + IMAT= IMATYZ + IMATX + NBEXT=1 + IF( NCP.GT.3 )THEN + IMATR= IMAT + RAC(1)= 0.0D0 + DO 230 JRAY= MINDO(J), MAXDO(J) + RAC(2)= DBLE(RMESHO(JRAY)) + ICUR(4)= JRAY-1 + IF(LELCRN(CEC,RAC,RECT(1,ICX),RECT(1,ICY)))THEN + IF( IMAT.EQ.0 )THEN +* ZONE NUMBERING + IVOX= IVOX + 1 + INOX= INOX + 1 + NO=INOX + IMATR= IVOX + ELSE +* SURFACE NUMBERING + ISUX= ISUX - 1 + NO= ISUX + ENDIF +* IDENTIFY FACE AND CHARGE THE ZONE OR SURFACE NO + MATGEO(IND(NO))= IMATR + DO 220 JCP= 1, 4 + INDEXO(JCP,IND(NO))= ICUR(JCP) + 220 CONTINUE + ELSE + IF( IMAT.EQ.0 )THEN +* ZONE NUMBERING + INOX= INOX + 1 +* IDENTIFY FACE AND CHARGE THE ZONE OR SURFACE NO + MATGEO(IND(INOX))= -1 +* ELSE +* ISUX=ISUX-1 + ENDIF + ENDIF + RAC(1)= RAC(2) + 230 CONTINUE + ICUR(4)= MAXDO(J) + RAYMAX= DBLE(RMESHO(MAXDO(J))) + NBEXT=0 + DO 233 IX= 1, 2 + DO 232 IY= 1, 2 + RAYXY= (RECT(IX,ICX)-CEC(1))*(RECT(IX,ICX)-CEC(1)) + > + (RECT(IY,ICY)-CEC(2))*(RECT(IY,ICY)-CEC(2)) + IF( RAYXY.GE.RAYMAX ) NBEXT= NBEXT + 1 + 232 CONTINUE + 233 CONTINUE + ENDIF + IF( NBEXT.EQ.0 )THEN +* +* NUMBER 'INSIDE' OF CYLINDER + IF( NEXTGE.EQ.0 )THEN +* +* CONSIDER ONLY FOR OVERALL CARTESIAN GEOMETRY +* SET IMAT TO -1 TO IDENTIFY REGION EXTRACTED + IF( IMAT.EQ.0 )THEN +* +* ZONE NUMBERING + INOX= INOX + 1 + MATGEO(IND(INOX))= -1 + ENDIF + ENDIF + ELSE +* +* NUMBER 'OUTSIDE' OF CYLINDER + IF( IMAT.EQ.0 )THEN +* +* ZONE NUMBERING + IVOX= IVOX + 1 + INOX= INOX + 1 + IMAT= IVOX + NO = INOX + ELSE +* +* SURFACE NUMBERING + ISUX= ISUX - 1 + NO= ISUX + ENDIF +* +* IDENTIFY FACE AND CHARGE THE ZONE OR SURFACE NO + MATGEO(IND(NO))= IMAT + DO 235 JCP= 1, 4 + INDEXO(JCP,IND(NO))= ICUR(JCP) + 235 CONTINUE + ENDIF + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE +* + KELRNG= IVOX - ISUX + 1 +* + IF( IPRT.GT.5 )THEN + NESUR= 0 + NEVOL= 0 + DO 549 I= NSU, NVO + IF( I.GT.0.AND.MATGEO(IND(I)).LT.0 ) NEVOL= NEVOL+1 + IF( I.LT.0.AND.MATGEO(IND(I)).EQ.0 ) NESUR= NESUR-1 + 549 CONTINUE + WRITE(IOUT,'(/13H NUMBERING ,I8,13H VOLUMES AND ,'// + > 'I8,10H SURFACES.)') NVO-NEVOL,-NSU+NESUR + WRITE(IOUT,'(17X,7HMINDIM=,10I8)') (MINDO(J),J=1,NCP) + WRITE(IOUT,'(17X,7HMAXDIM=,10I8)') (MAXDO(J),J=1,NCP) +* + DO 550 I= NSU-NESUR, NVO + WRITE(IOUT,'(8H MATGEO(,I8,2H)=,I6,7H INDEX=,4I8)') + > I, MATGEO(IND(I)), (INDEXO(J,IND(I)),J=1,4) + 550 CONTINUE + ENDIF +* + RETURN + END diff --git a/Dragon/src/KELSYM.f b/Dragon/src/KELSYM.f new file mode 100644 index 0000000..0b1c437 --- /dev/null +++ b/Dragon/src/KELSYM.f @@ -0,0 +1,96 @@ +*DECK KELSYM + FUNCTION KELSYM( IPRT, NDIM, MAXDO, NSURO, NVOLO, + > IDLGEO, INDEXO, MATGEO, KEYSYM ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Generate the vector KEYSYM for a block. +* +*Copyright: +* Copyright (C) 1990 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPRT intermediate printing level. +* NDIM number of dimensions (2 or 3). +* MAXDO max index values for all axes (rect/cyl). +* NSURO number of surfaces for a specific geometry. +* NVOLO number of zones for a specific geometry. +* IDLGEO specific position for a geometry. +* INDEXO coordinates for zones & surfaces of a cell. +* MATGEO material numbers corresponding to geometries. +* +*Parameters: output +* KEYSYM symmetry numbers corresponding to geometries. +* KELSYM number of surfaces and zones renumbered. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +* + INTEGER KELSYM, IPRT, NDIM, NSURO, NVOLO, IDLGEO + INTEGER MAXDO(*),INDEXO(4,*),KEYSYM(*),MATGEO(*) +* + INTEGER ICUR(4), I, J, IVS, MAXPRC, MAXSUI, ISYM, IND + LOGICAL SWITCH + INTEGER IOUT + PARAMETER ( IOUT=6 ) +* + IND(I)= IDLGEO + I +* + DO 5 IVS= 0, NVOLO + KEYSYM(IND(IVS))= 0 + 5 CONTINUE + KELSYM= 0 +* +* LOCATES THE SYMMETRIC SURFACE TO EACH SURFACE + DO 50 IVS = NSURO, -1 + IF( MATGEO(IND(IVS)).EQ.0 )GO TO 51 + MAXPRC= 0 + DO 10 J = 1, 4 + ICUR(J)= INDEXO(J,IND(IVS)) +* +* FIND THE SYMMETRIC SURFACE BY CHANGING END-FACE + IF( J.LE.NDIM )THEN + MAXSUI= MAXDO(J) + IF( ICUR(J).EQ.MAXPRC)THEN + ICUR(J)= MAXSUI + ELSEIF( ICUR(J).EQ.MAXSUI)THEN + ICUR(J)= MAXPRC + ENDIF + MAXPRC= MAXSUI + ENDIF +* +* THE SENTINEL VALUE IS IVS=0 + INDEXO(J,IND(0))= ICUR(J) + 10 CONTINUE + ISYM= NSURO + 20 SWITCH= .TRUE. + DO 30 J = 1, 4 + SWITCH= SWITCH .AND. ICUR(J).EQ.INDEXO(J,IND(ISYM)) + 30 CONTINUE + IF( SWITCH )GO TO 40 + ISYM= ISYM + 1 + GO TO 20 + 40 KEYSYM(IND(IVS))= ISYM + IF( IPRT.GE.10 )THEN + WRITE(IOUT,'(22H SURFACE SYMMETRIC TO ,I6,4H IS ,I6)') + > -IVS, -ISYM + ENDIF + IF( ISYM.NE.0 ) KELSYM=KELSYM-1 + 51 CONTINUE + 50 CONTINUE +* +* RESET SENTINEL INDEXO(J,IND(0)) FOR SUBSEQUENT USES + DO 60 J= 1, 4 + INDEXO(J,IND(0))= 0 + 60 CONTINUE +* + RETURN + END diff --git a/Dragon/src/LDRASS.f b/Dragon/src/LDRASS.f new file mode 100644 index 0000000..609d187 --- /dev/null +++ b/Dragon/src/LDRASS.f @@ -0,0 +1,467 @@ +*DECK LDRASS + LOGICAL FUNCTION LDRASS(IPGEOM,IPRT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Reads the geometry on LCM and check compatibility for cell assemblies. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPGEOM pointer to the geometry LCM object (L_GEOM). +* IPRT print flag (iprt=0: no print). +* +*Parameters: output +* LDRASS checking flag: =.true. if everything was 'ok' with assembly; +* =.false. if nothing was checked. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPGEOM + INTEGER IPRT +*---- +* LOCAL VARIABLES +*---- + PARAMETER ( IOUT=6, NLCM=26, NSTATE=40, NIXS=12, NIST=1 ) + CHARACTER*12 LCMNM(NLCM), GEONAM, TEXT12 + INTEGER LNLCM(NLCM),INVLCM(NIXS),INVSTA(NIST),ISTATE(NSTATE), + > MAXGRI(3),NCODE(6) + LOGICAL LL1,LL2,LCELL,LDRCEL,EMPTY,LCM +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KEYTYP,KMERGE,KTURN,KEYCEL, + > KCHECK +*---- +* DATA STATEMENTS +*---- + DATA INVLCM/ 6, 7, 8, 9, 10, 12, 16, 17, 18, + > 20, 21, 22 / + DATA INVSTA/11 / + DATA LCMNM / 'MIX', 'MESHX', 'MESHY', 'MESHZ', 'RADIUS', + > 'SIDE', 'SPLITX', 'SPLITY', 'SPLITZ', 'SPLITR', + > 'CELL', 'COORD', 'MERGE', 'TURN','CLUSTER', + > 'NPIN', 'RPIN', 'APIN', 'BIHET', 'POURCE', + > 'PROCEL', 'IHEX', 'STATE', 'NCODE', 'ZCODE', + > 'ICODE'/ +* +* I: CELL TYPE +* J: CELL TURN (=J.EQ.1.OR.J.EQ.2) + IADR( IAXIS, I1,J1, I2,J2)= IAXIS + > + 3*(J1-1+2*(J2-1+2*(I1-1+NTYPES*(I2-1)))) +* + CALL LCMINF(IPGEOM,GEONAM,TEXT12,EMPTY,ILONG,LCM) + LDRASS= .TRUE. + IF( IPRT.GT.1 )THEN + WRITE(IOUT,'(/20H CHECKING ASSEMBLY: ,A12)') GEONAM + ENDIF + DO 10 ILCM= 1, NLCM + CALL LCMLEN(IPGEOM, LCMNM(ILCM), LNLCM(ILCM), ITPLCM ) + 10 CONTINUE +*---- +* ELIMINATES OPTIONS NOT CHECKED BY THE ROUTINE +*---- + DO 20 IIXS= 1, NIXS + IF( LNLCM(INVLCM(IIXS)).NE.0 )THEN + LDRASS= .FALSE. + GO TO 9999 + ENDIF + 20 CONTINUE + CALL LCMLEN(IPGEOM,'STATE-VECTOR',ILEN,ITPLCM) + IF( ITPLCM.NE.1 )THEN + LDRASS= .FALSE. + CALL XABORT( 'LDRASS: STATE VECTOR IS NOT AN INTEGER') + ENDIF + IF( ILEN.NE.NSTATE )THEN + LDRASS= .FALSE. + CALL XABORT( 'LDRASS: GEOMETRY HAS INVALID STATE VECTOR') + ENDIF + ISTATE(:NSTATE)=0 + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) +*---- +* ELIMINATES THE INVALID OPTIONS +*---- + DO 30 IIST= 1, NIST + IF( ISTATE(INVSTA(IIST)).NE.0 )THEN + LDRASS= .FALSE. + GO TO 9999 + ENDIF + 30 CONTINUE +* + ITYPE= ISTATE(1) +*---- +* FIX DIMENSION OF CELL ASSEMBLY +*---- + IF( ITYPE.EQ.5 )THEN + NDIM= 2 + ELSEIF( ITYPE.EQ.7 )THEN + NDIM= 3 + ELSE + LDRASS= .FALSE. + GO TO 9999 + ENDIF + LREG= ISTATE(6) + NBMIX= ISTATE(7) + ISUB1= ISTATE(8) + ISUB2= ISTATE(9) +* + IF( ISUB1.NE.0 )THEN + MAXGRI(1)= MAX(1,ISTATE(3)) + MAXGRI(2)= MAX(1,ISTATE(4)) + MAXGRI(3)= MAX(1,ISTATE(5)) + NBLOCK= MAXGRI(1)*MAXGRI(2)*MAXGRI(3) + IF( NBLOCK.EQ.1 )THEN +* +* JUST ONE CELL + LDRASS=.FALSE. + GO TO 9999 + ENDIF +* +* MANY CELLS + NTYPES= ISUB2 + IF( IPRT.GT.1 )THEN + WRITE(IOUT,'(6H ,I1,13H-D ASSEMBLY: ,3I4)') + > NDIM, (MAXGRI(I),I=1,NDIM) + ENDIF + ELSE +* +* JUST ONE CELL + LDRASS=.FALSE. + GO TO 9999 + ENDIF +*---- +* RECOVERS BOUNDARY CONDITIONS. +*---- + CALL LCMLEN(IPGEOM,'NCODE', ILEN, ITPLCM) + IF( ITPLCM.NE.1 ) + > CALL XABORT('LDRASS: THE NCODE BLOCK IS '// + > 'NOT ADEQUATELY DEFINED') + IF( ILEN.NE.6 ) + > CALL XABORT('LDRASS: THE NCODE BLOCK HAS '// + > 'INCORRECT DIMENSION') + CALL LCMGET(IPGEOM,'NCODE',NCODE) + IF( NDIM.EQ.2.AND.(NCODE(5).NE.0.OR.NCODE(6).NE.0) ) + > CALL XABORT('LDRASS: 3-D NCODE VALUES FOR A 2-D ASSEMBLY...') + NOCELL= NBLOCK + NDIAG=0 + DO 40 IAL= 1, 2*NDIM + IF( NCODE(IAL).EQ.0 ) + > CALL XABORT('LDRASS: A BOUNDARY CONDITION IS MISSING.') + IF( NCODE(IAL).EQ.3 )THEN + NDIAG=NDIAG+1 + ENDIF + 40 CONTINUE +* + LL1= .FALSE. + LL2= .FALSE. + MXDIAG=0 + NOC1=0 + NOC2=0 + NOCO=0 + IF( NDIAG.GT.0 )THEN + IF( NDIAG.NE.2 ) + > CALL XABORT('LDRASS: NO MORE THAN 2 DIAGONAL CONDITIONS') + IF( MAXGRI(1).NE.MAXGRI(2)) + > CALL XABORT('LDRASS: LX=LY WITH A DIAGONAL SYMMETRY.') + MXDIAG= MAXGRI(1) + NOC1=((MXDIAG+1)*MXDIAG)/2 + NOC2=MXDIAG*MXDIAG + LL1=((NCODE(2).EQ.3).AND.(NCODE(3).EQ.3)) + LL2=((NCODE(1).EQ.3).AND.(NCODE(4).EQ.3)) + IF( LL1 )THEN + NCODE(2)= NCODE(1) + NCODE(3)= NCODE(4) + ELSEIF( LL2 )THEN + NCODE(1)= NCODE(2) + NCODE(4)= NCODE(3) + ELSE + CALL XABORT('LDRASS: THE DIAGONAL CONDITIONS '// + > 'X+: DIAG Y-: DIAG OR '// + > 'X-: DIAG Y+: DIAG ARE THE ONLY PERMITTED.') + ENDIF + NOCO=NOC1 + IF(NOC2*MAXGRI(3) .EQ. LREG) NOCO=NOC2 + NOCELL=NOCO*MAXGRI(3) + ENDIF + IF( NOCELL.GT.LREG )THEN + CALL XABORT('LDRASS: # OF CELLS OF ASSEMBLY TOO LARGE...') + ELSEIF( NOCELL.LT.LREG )THEN + CALL XABORT('LDRASS: # OF CELLS OF ASSEMBLY TOO SMALL...') + ENDIF +*---- +* CHECK IF GENERATING CELL VECTOR IS 'OK' +*---- + CALL LCMLEN(IPGEOM,'MIX', KCELL, ITPLCM) + IF( ITPLCM.NE.1 ) + > CALL XABORT('LDRASS: THE MIX BLOCK WITH CELLS IS '// + > 'NOT ADEQUATELY DEFINED') + IF( KCELL.GT.NOCELL )THEN + CALL XABORT('LDRASS: THE ASSEMBLY HAS TOO MANY CELLS...') + ELSEIF( KCELL.LT.NOCELL )THEN + CALL XABORT('LDRASS: THE ASSEMBLY HAS NOT ENOUGH CELLS...') + ENDIF + ALLOCATE(KEYTYP(NBLOCK)) + CALL LCMGET(IPGEOM,'MIX', KEYTYP) + DO 41 I=1,KCELL + KEYTYP(I)=-KEYTYP(I) + 41 CONTINUE +*---- +* CHECK IF 'MERGE' ARE CORRECTLY DEFINED +*---- + CALL LCMLEN(IPGEOM,'MERGE', KCELL, ITPLCM) + IF( KCELL.NE.0 )THEN + IF( ITPLCM.NE.1 ) + > CALL XABORT('LDRASS: THE MERGE BLOCK IS '// + > 'NOT ADEQUATELY DEFINED') + IF( KCELL.GT.NOCELL )THEN + CALL XABORT('LDRASS: THE ASSEMBLY HAS TOO MANY MERGE...') + ELSEIF( KCELL.LT.NOCELL )THEN + CALL XABORT('LDRASS: THE ASSEMBLY HAS NOT ENOUGH MERGE...') + ENDIF + ALLOCATE(KMERGE(NOCELL)) + CALL LCMGET(IPGEOM,'MERGE', KMERGE) + DO 46 IM= 1, NOCELL + IDKT= KMERGE(IM) + IF( IDKT.GT.NOCELL ) + > CALL XABORT( 'LDRASS: MERGE NUMBER > TOTAL # OF CELLS') + DO 45 JM= IM+1, NOCELL + JDKT= KMERGE(JM) + IF( JDKT.EQ.IDKT )THEN + IF( KEYTYP(IDKT).NE.KEYTYP(JDKT) )THEN + CALL XABORT( 'LDRASS: MERGE NUMBERS ARE NOT '// + > 'CONSISTENT WITH GEOMETRIC DEFINITION') + ENDIF + ENDIF + 45 CONTINUE + 46 CONTINUE + DEALLOCATE(KMERGE) + ENDIF + ALLOCATE(KTURN(NBLOCK)) + DO 47 IT= 1, NOCELL + KTURN(IT)= 1 + 47 CONTINUE + CALL LCMLEN(IPGEOM,'TURN', KCELL, ITPLCM) + IF( KCELL.NE.0 )THEN + IF( ITPLCM.NE.1 ) + > CALL XABORT('LDRASS: THE MERGE BLOCK IS '// + > 'NOT ADEQUATELY DEFINED') + IF( KCELL.GT.NOCELL )THEN + CALL XABORT('LDRASS: THE ASSEMBLY HAS TOO MANY TURN...') + ELSEIF( KCELL.LT.NOCELL )THEN + CALL XABORT('LDRASS: THE ASSEMBLY HAS NOT ENOUGH TURN...') + ENDIF + CALL LCMGET(IPGEOM,'TURN', KTURN) + ENDIF +*---- +* EFFECTIVE MOD2 FOR TURN IN CELLS +*---- + DO 48 IT= 1, NOCELL + KTURN(IT)= MOD( KTURN(IT)+1,2 )+1 + 48 CONTINUE +*---- +* CHECK IF CELL NAMES ARE 'OK' +*---- + CALL LCMLEN(IPGEOM,'CELL', KTYPES, ITPLCM) + IF( ITPLCM.NE.3 ) + > CALL XABORT('LDRASS: THE CELL NAMES ARE NOT STORED IN' + > //' CHARACTER*4') + IF( KTYPES.GT.3*NTYPES )THEN + CALL XABORT('LDRASS: THE ASSEMBLY HAS TOO MANY CELL NAMES') + ELSEIF( KTYPES.LT.3*NTYPES )THEN + CALL XABORT('LDRASS: THE ASSEMBLY HAS NOT ENOUGH CELLS NAMES') + ENDIF + ALLOCATE(KEYCEL(3*NTYPES),KCHECK(12*NTYPES*NTYPES)) + DO 50 IT= 1,12*NTYPES*NTYPES + KCHECK(IT)= 0 + 50 CONTINUE + CALL LCMGET(IPGEOM,'CELL', KEYCEL) +*---- +* FILL UP "KEYTYP" ARRAY IN THE CASE OF DIAGONAL SYMMETRY +*---- + IF( LL1 )THEN + IF(NOCO .EQ. NOC1) THEN +*---- +* LOCATE DIAGONAL ELEMENTS IN THEIR RESPECTIVE PLANES +* WHILE UNFOLDING +*---- + K=LREG + DO 72 IZ=MAXGRI(3),1,-1 + IOFF=(IZ-1)*MXDIAG*MXDIAG + DO 71 IY=MXDIAG,1,-1 + DO 60 IX=MXDIAG,IY+1,-1 + KEYTYP(IOFF+(IY-1)*MXDIAG+IX)=KEYTYP(IOFF+(IX-1)*MXDIAG+IY) + KTURN(IOFF+(IY-1)*MXDIAG+IX)=KTURN(IOFF+(IX-1)*MXDIAG+IY) + 60 CONTINUE + DO 70 IX=IY,1,-1 + KEYTYP(IOFF+(IY-1)*MXDIAG+IX)=KEYTYP(K) + KTURN(IOFF+(IY-1)*MXDIAG+IX)=KTURN(K) + K=K-1 + 70 CONTINUE + 71 CONTINUE + 72 CONTINUE + DO 77 IZ=MAXGRI(3),1,-1 + IOFF=(IZ-1)*MXDIAG*MXDIAG + DO 76 IY=1,MXDIAG + DO 75 IX=IY+1,MXDIAG + KTURN(IOFF+(IY-1)*MXDIAG+IX)= + > MOD(KTURN(IOFF+(IY-1)*MXDIAG+IX),2) + 1 + 75 CONTINUE + 76 CONTINUE + 77 CONTINUE + IF (K.NE.0) + > CALL XABORT( 'LDRASS: UNABLE TO UNFOLD '// + > 'X+: DIAG Y-: DIAG ASSEMBLY...') + ENDIF + ELSEIF( LL2 )THEN + IF(NOCO .EQ. NOC1) THEN +*---- +* LOCATE DIAGONAL ELEMENTS IN THEIR RESPECTIVE PLANES +*---- + K=LREG + DO 82 IZ=MAXGRI(3),1,-1 + IOFF=(IZ-1)*MXDIAG*MXDIAG + DO 81 IY=MXDIAG,1,-1 + DO 80 IX=MXDIAG,IY,-1 + KEYTYP(IOFF+(IY-1)*MXDIAG+IX)=KEYTYP(K) + KTURN(IOFF+(IY-1)*MXDIAG+IX)=KTURN(K) + K=K-1 + 80 CONTINUE + 81 CONTINUE + 82 CONTINUE +*---- +* UNFOLD DIAGONAL ELEMENTS FOR EACH PLANE +*---- + DO 92 IZ=1,MAXGRI(3) + IOFF=(IZ-1)*MXDIAG*MXDIAG + DO 91 IY=1,MXDIAG + DO 90 IX=1,IY-1 + KEYTYP(IOFF+(IY-1)*MXDIAG+IX)=KEYTYP(IOFF+(IX-1)*MXDIAG+IY) + KTURN(IOFF+(IY-1)*MXDIAG+IX)=KTURN(IOFF+(IX-1)*MXDIAG+IY) + 90 CONTINUE + 91 CONTINUE + 92 CONTINUE + IF (K.NE.0) + > CALL XABORT( 'LDRASS: UNABLE TO UNFOLD '// + > 'X-: DIAG Y+: DIAG ASSEMBLY...') + DO 97 IZ=MAXGRI(3),1,-1 + IOFF=(IZ-1)*MXDIAG*MXDIAG + DO 96 IY=1,MXDIAG + DO 95 IX=1,IY-1 + KTURN(IOFF+(IY-1)*MXDIAG+IX)= + > MOD(KTURN(IOFF+(IY-1)*MXDIAG+IX),2) + 1 + 95 CONTINUE + 96 CONTINUE + 97 CONTINUE + ENDIF + ENDIF + IF(IPRT .GE. 10) THEN + WRITE(IOUT,6100) + DO 600 IZ=MAXGRI(3),1,-1 + DO 601 IY=MAXGRI(2),1,-1 + IOFF=(IZ-1)*MAXGRI(2)*MAXGRI(1)+(IY-1)*MAXGRI(1) + WRITE(IOUT,6110) (KEYTYP(IOFF+IX),IX=1,MAXGRI(1)) + 601 CONTINUE + WRITE(IOUT,6111) + 600 CONTINUE + WRITE(IOUT,6101) + DO 610 IZ=MAXGRI(3),1,-1 + DO 611 IY=MAXGRI(2),1,-1 + IOFF=(IZ-1)*MAXGRI(2)*MAXGRI(1)+(IY-1)*MAXGRI(1) + WRITE(IOUT,6110) (KTURN(IOFF+IX),IX=1,MAXGRI(1)) + 611 CONTINUE + WRITE(IOUT,6111) + 610 CONTINUE + ENDIF +*---- +* TRANSLATION B.C.: CHECK BEGIN-TO-END CONNEXIONS +*---- + DO 100 IC= 1, NDIM + IF( NCODE(2*IC-1).EQ.4 )THEN + IF( NCODE(2*IC).NE.4 ) + > CALL XABORT( 'LDRASS: TRANSLATION B.C. IS NOT WELL DEFINED') + ENDIF + 100 CONTINUE +*---- +* CHECK CELL INTERFACES +*---- + IOFF1= 0 + DO 112 IZ= 1, MAXGRI(3) + DO 111 IY= 1, MAXGRI(2) + DO 110 IX= 1, MAXGRI(1) + IOFF1= IOFF1+1 + IT1= KEYTYP(IOFF1) + JT1= KTURN(IOFF1) + IF(IX.NE.MAXGRI(1).OR.(IX.EQ.MAXGRI(1).AND.NCODE(1).EQ.4))THEN + IF(IX.NE.MAXGRI(1))THEN + IOFF2= IOFF1 + 1 + ELSE + IOFF2= IOFF1 + 1 - MAXGRI(1) + ENDIF + IT2= KEYTYP(IOFF2) + JT2= KTURN(IOFF2) + IF( KCHECK(IADR(1,IT1,JT1,IT2,JT2)).EQ.0 )THEN + LCELL= LDRCEL(IPGEOM, IT1,JT1, IT2,JT2, KEYCEL, + > NTYPES, 1, NDIM, IPRT) + KCHECK(IADR(1,IT1,JT1,IT2,JT2))= 1 + ENDIF + ENDIF + IF(IY.NE.MAXGRI(2).OR.(IY.EQ.MAXGRI(2).AND.NCODE(3).EQ.4))THEN + IF( IY.NE.MAXGRI(2) )THEN + IOFF2= IOFF1 + MAXGRI(1) + ELSE + IOFF2= IOFF1 +(1-MAXGRI(2)) * MAXGRI(1) + ENDIF + IT2= KEYTYP(IOFF2) + JT2= KTURN(IOFF2) + IF( KCHECK(IADR(2,IT1,JT1,IT2,JT2)).EQ.0 )THEN + LCELL= LDRCEL(IPGEOM, IT1,JT1, IT2,JT2, KEYCEL, + > NTYPES, 2, NDIM, IPRT) + KCHECK(IADR(2,IT1,JT1,IT2,JT2))= 1 + ENDIF + ENDIF + IF(IZ.NE.MAXGRI(3).OR.(IZ.EQ.MAXGRI(3).AND.NCODE(5).EQ.4))THEN + IF( IZ.NE.MAXGRI(3) )THEN + IOFF2= IOFF1 + MAXGRI(1)*MAXGRI(2) + ELSE + IOFF2= IOFF1 +(1-MAXGRI(3)) * MAXGRI(1) * MAXGRI(2) + ENDIF + IT2= KEYTYP(IOFF2) + JT2= KTURN(IOFF2) + IF( KCHECK(IADR(3,IT1,JT1,IT2,JT2)).EQ.0 )THEN + LCELL= LDRCEL(IPGEOM, IT1,JT1, IT2,JT2, KEYCEL, + > NTYPES, 3, NDIM, IPRT) + KCHECK(IADR(3,IT1,JT1,IT2,JT2))= 1 + ENDIF + ENDIF + 110 CONTINUE + 111 CONTINUE + 112 CONTINUE + DEALLOCATE(KCHECK,KEYCEL,KTURN,KEYTYP) + 9999 IF( IPRT.GT.0 )THEN + IF( LDRASS )THEN + WRITE(IOUT,'(1H ,A12,25H ASSEMBLY IS **OK** )') GEONAM + ELSE + WRITE(IOUT,'(1H ,A12,25H WAS NOT ASSEMBLY CHECKED )') GEONAM + ENDIF + ENDIF + RETURN +*---- +* FORMATS +*---- + 6100 FORMAT(/' Assembly by cell number' ) + 6101 FORMAT(/' Assembly turns' ) + 6110 FORMAT(40(1X,I5)) + 6111 FORMAT(' ') + END diff --git a/Dragon/src/LDRCEL.f b/Dragon/src/LDRCEL.f new file mode 100644 index 0000000..6684b7c --- /dev/null +++ b/Dragon/src/LDRCEL.f @@ -0,0 +1,370 @@ +*DECK LDRCEL + LOGICAL FUNCTION LDRCEL(IPGEOM, IT1, JT1, IT2, JT2, + > CELLT, NTYPES, IAXIS, NDIM, IPRT ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Check if two cells can be connected in an assembly of cells. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPGEOM pointer to the geometry LCM object (L_GEOM signature). +* IT1 type of the first cell. +* JT1 turn index of the first cell. +* IT2 type of the second cell. +* JT2 turn index of the second cell. +* CELLT to keep cell type names. +* NTYPES number of types. +* IAXIS axis of the connexion. +* NDIM number of dimensions. +* IPRT intermediate printing level for output. +* +*Parameters: output +* LDRCEL checking flag: =.true. if cells do connect adequately; +* =.false. if they do not connect adequately. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPGEOM + INTEGER IT1,JT1,IT2,JT2,CELLT(3*NTYPES),NTYPES,IAXIS, + > NDIM,IPRT +*---- +* LOCAL VARIABLES +*---- + PARAMETER ( IOUT=6,NSTATE=40 ) + INTEGER ISTAT1(NSTATE),ISTAT2(NSTATE),ILEN(3), JLEN(3) + CHARACTER GEOC1*12,GEOC2*12,CAXIS(3)*1,GEOCT1*18,GEOCT2*18 + LOGICAL LDRGEO +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: RIADD1,RIADD2,RIADD3,RJADD1, + > RJADD2,RJADD3 +*---- +* DATA STATEMENTS +*---- + DATA CAXIS / 'X', 'Y', 'Z' / +* + IST2=0 + IF( IAXIS.GT.NDIM )THEN + LDRCEL= .FALSE. + CALL XABORT( 'LDRCEL: # OF DIMENSIONS INCOMPATIBLE' ) + ELSE + LDRCEL= .TRUE. + ENDIF + ICX1 = MOD(IAXIS , NDIM) + 1 + ICX2 = ICX1 + ICY1 = MOD(IAXIS+1, NDIM) + 1 + ICY2 = ICY1 +* +* XY-ROTATES IF NECESSARY FROM JT1 AND JT2 + IF( JT1.EQ.2 )THEN + IF( ICX1.EQ.2 )THEN + ICX1= 1 + ELSEIF( ICX1.EQ.1 )THEN + ICX1= 2 + ENDIF + IF( ICY1.EQ.2 )THEN + ICY1= 1 + ELSEIF( ICY1.EQ.1 )THEN + ICY1= 2 + ENDIF + ENDIF + IF( JT2.EQ.2 )THEN + IF( ICX2.EQ.2 )THEN + ICX2= 1 + ELSEIF( ICX2.EQ.1 )THEN + ICX2= 2 + ENDIF + IF( ICY2.EQ.2 )THEN + ICY2= 1 + ELSEIF( ICY2.EQ.1 )THEN + ICY2= 2 + ENDIF + ENDIF + N1= 0 + N2= 0 + WRITE( GEOC1(1: 4),'(A4)') CELLT(3*IT1-2) + WRITE( GEOC1(5: 8),'(A4)') CELLT(3*IT1-1) + WRITE( GEOC1(9:12),'(A4)') CELLT(3*IT1 ) + IF( IT1.NE.IT2 )THEN + WRITE( GEOC2(1: 4),'(A4)') CELLT(3*IT2-2 ) + WRITE( GEOC2(5: 8),'(A4)') CELLT(3*IT2-1 ) + WRITE( GEOC2(9:12),'(A4)') CELLT(3*IT2 ) + IF( JT1.EQ.1 )THEN + GEOCT1= GEOC1//' ' + ELSE + GEOCT1= GEOC1//'/TURN ' + ENDIF + IF( JT2.EQ.1 )THEN + GEOCT2= GEOC2//' ' + ELSE + GEOCT2= GEOC2//'/TURN ' + ENDIF + IF( IPRT.GT.1 )THEN + WRITE(IOUT,'(1H ,A1,17H-CELL CONNEXION: ,2A18)') + > CAXIS(IAXIS), GEOCT1, GEOCT2 + ENDIF + IF( .NOT.LDRGEO(IPGEOM, GEOC1, GEOC2, 0) )THEN +* +* ANALYSE GEOMETRIES + CALL LCMSIX(IPGEOM, GEOC1, 1) + ISTAT1(:NSTATE)=0 + CALL LCMGET(IPGEOM, 'STATE-VECTOR', ISTAT1) + IST1= ISTAT1(1) + IF( IST1.EQ.0 ) THEN + CALL LCMSIX(IPGEOM, ' ', 2) + RETURN + ENDIF + IF( NDIM.EQ.2 )THEN + IF( IST1.EQ.5 .OR. IST1.EQ.20 )THEN + N1= 1 + CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICX1), ILEN(1), IT) + ALLOCATE(RIADD1(ILEN(1))) + CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICX1), RIADD1) + ELSE + CALL XABORT( 'LDRCEL: ONE CELL HAS INCORRECT DIM') + ENDIF + ELSEIF( NDIM.EQ.3 )THEN + IF( IST1.EQ.7 .OR. IST1.EQ.21 .OR. + > IST1.EQ.22 .OR. IST1.EQ.23 )THEN + N1=2 + CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICX1), ILEN(1), IT) + ALLOCATE(RIADD1(ILEN(1))) + CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICX1), RIADD1) + CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICY1), ILEN(2), IT) + ALLOCATE(RIADD2(ILEN(2))) + CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICY1), RIADD2) + IF( IAXIS.EQ.IST1-20 )THEN + N1=3 + CALL LCMLEN(IPGEOM, 'RADIUS', ILEN(3), IT) + ALLOCATE(RIADD3(ILEN(3))) + CALL LCMGET(IPGEOM, 'RADIUS', RIADD3) + ENDIF + ELSE + CALL XABORT( 'LDRCEL: ONE CELL HAS INCORRECT DIM') + ENDIF + ENDIF + CALL LCMSIX(IPGEOM, ' ', 2) +* +* SCAN THE SECOND GEOMETRY + CALL LCMSIX(IPGEOM, GEOC2, 1) + ISTAT2(:NSTATE)=0 + CALL LCMGET(IPGEOM, 'STATE-VECTOR', ISTAT2) + IST2= ISTAT2(1) + IF( IST2.EQ.0 ) THEN + CALL LCMSIX(IPGEOM, ' ', 2) + RETURN + ENDIF + IF( NDIM.EQ.2 )THEN + IF( IST2.EQ.5 .OR. IST2.EQ.20 )THEN + N2=1 + CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICX2), JLEN(1), IT) + ALLOCATE(RJADD1(JLEN(1))) + CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICX2), RJADD1) + ELSE + CALL XABORT( 'LDRCEL: ONE CELL HAS INCORRECT DIM') + ENDIF + ELSEIF( NDIM.EQ.3 )THEN + IF( IST2.EQ.7 .OR. IST2.EQ.21 .OR. + > IST2.EQ.22 .OR. IST2.EQ.23 )THEN + N2=2 + CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICX2), JLEN(1), IT) + ALLOCATE(RJADD1(JLEN(1))) + CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICX2), RJADD1) + CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICY2), JLEN(2), IT) + ALLOCATE(RJADD2(JLEN(2))) + CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICY2), RJADD2) + IF( IAXIS.EQ.IST2-20 )THEN + N2=3 + CALL LCMLEN(IPGEOM, 'RADIUS', JLEN(3), IT) + ALLOCATE(RJADD3(JLEN(3))) + CALL LCMGET(IPGEOM, 'RADIUS', RJADD3) + ENDIF + ELSE + CALL XABORT( 'LDRCEL: ONE CELL HAS INCORRECT DIM') + ENDIF + ENDIF + CALL LCMSIX(IPGEOM, ' ', 2) + ELSE +* +* GEOMETRIES ARE SIMILAR, CHECK FOR XY-ROTATIONAL INVARIANCE + IF( JT1.NE.JT2 )THEN + CALL LCMSIX(IPGEOM, GEOC1, 1) + ISTAT1(:NSTATE)=0 + CALL LCMGET(IPGEOM, 'STATE-VECTOR', ISTAT1) + IST1= ISTAT1(1) + IF( IST1.EQ.0 ) THEN + CALL LCMSIX(IPGEOM, ' ', 2) + RETURN + ENDIF + IF( JT1.EQ.1 )THEN + GEOCT1= GEOC1//' ' + ELSE + GEOCT1= GEOC1//'/TURN ' + ENDIF + IF( JT2.EQ.1 )THEN + GEOCT2= GEOC1//' ' + ELSE + GEOCT2= GEOC1//'/TURN ' + ENDIF + IF( IPRT.GT.1 )THEN + WRITE(IOUT,'(1H ,A1,17H-CELL CONNEXION: ,2A18)') + > CAXIS(IAXIS), GEOCT1, GEOCT2 + ENDIF + IF( IST1.EQ.5 .OR. IST1.EQ.20 )THEN + N1= 1 + N2= 1 + CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(1), ILEN(1), IT) + ALLOCATE(RIADD1(ILEN(1))) + CALL LCMGET(IPGEOM, 'MESH'//CAXIS(1), RIADD1) + CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(2), JLEN(1), IT) + ALLOCATE(RJADD1(JLEN(1))) + CALL LCMGET(IPGEOM, 'MESH'//CAXIS(2), RJADD1) + ELSE IF( IST1.EQ.7 .OR. IST1.EQ.21 .OR. + > IST1.EQ.22 .OR. IST1.EQ.23 )THEN + N1=2 + CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICX1), ILEN(1), IT) + ALLOCATE(RIADD1(ILEN(1))) + CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICX1), RIADD1) + CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICY1), ILEN(2), IT) + ALLOCATE(RIADD2(ILEN(2))) + CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICY1), RIADD2) + IF( IAXIS.EQ.IST1-20 )THEN + N1=3 + CALL LCMLEN(IPGEOM, 'RADIUS', ILEN(3), IT) + ALLOCATE(RIADD3(ILEN(3))) + CALL LCMGET(IPGEOM, 'RADIUS', RIADD3) + ENDIF + N2=2 + CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICX2), JLEN(1), IT) + ALLOCATE(RJADD1(JLEN(1))) + CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICX2), RJADD1) + CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICY2), JLEN(2), IT) + ALLOCATE(RJADD2(JLEN(2))) + CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICY2), RJADD2) + IF( IAXIS.EQ.IST2-20 )THEN + N2=3 + CALL LCMLEN(IPGEOM, 'RADIUS', JLEN(3), IT) + ALLOCATE(RJADD3(JLEN(3))) + CALL LCMGET(IPGEOM, 'RADIUS', RJADD3) + ENDIF + ELSE + CALL XABORT( 'LDRCEL: ONE CELL HAS INCORRECT DIM') + ENDIF + CALL LCMSIX(IPGEOM, ' ', 2) + ENDIF + ENDIF + ELSE +* +* GEOMETRY ARE OF THE SAME TYPE, CHECK FOR XY-ROTATIONAL INVARIANCE + IF( JT1.NE.JT2 )THEN + CALL LCMSIX(IPGEOM, GEOC1, 1) + ISTAT1(:NSTATE)=0 + CALL LCMGET(IPGEOM, 'STATE-VECTOR', ISTAT1) + IST1= ISTAT1(1) + IF( IST1.EQ.0 ) THEN + CALL LCMSIX(IPGEOM, ' ', 2) + RETURN + ENDIF + IF( JT1.EQ.1 )THEN + GEOCT1= GEOC1//' ' + ELSE + GEOCT1= GEOC1//'/TURN ' + ENDIF + IF( JT2.EQ.1 )THEN + GEOCT2= GEOC1//' ' + ELSE + GEOCT2= GEOC1//'/TURN ' + ENDIF + IF( IPRT.GT.1 )THEN + WRITE(IOUT,'(1H ,A1,17H-CELL CONNEXION: ,2A18)') + > CAXIS(IAXIS), GEOCT1, GEOCT2 + ENDIF + IF( IST1.EQ.5 .OR. IST1.EQ.20 )THEN + N1= 1 + N2= 1 + CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(1), ILEN(1), IT) + ALLOCATE(RIADD1(ILEN(1))) + CALL LCMGET(IPGEOM, 'MESH'//CAXIS(1), RIADD1) + CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(2), JLEN(1), IT) + ALLOCATE(RJADD1(JLEN(1))) + CALL LCMGET(IPGEOM, 'MESH'//CAXIS(2), RJADD1) + ELSE IF( IST1.EQ.7 .OR. IST1.EQ.21 .OR. + > IST1.EQ.22 .OR. IST1.EQ.23 )THEN + N1=2 + CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICX1), ILEN(1), IT) + ALLOCATE(RIADD1(ILEN(1))) + CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICX1), RIADD1) + CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICY1), ILEN(2), IT) + ALLOCATE(RIADD2(ILEN(2))) + CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICY1), RIADD2) + IF( IAXIS.EQ.IST1-20 )THEN + N1=3 + CALL LCMLEN(IPGEOM, 'RADIUS', ILEN(3), IT) + ALLOCATE(RIADD3(ILEN(3))) + CALL LCMGET(IPGEOM, 'RADIUS', RIADD3) + ENDIF + N2=2 + CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICX2), JLEN(1), IT) + ALLOCATE(RJADD1(JLEN(1))) + CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICX2), RJADD1) + CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICY2), JLEN(2), IT) + ALLOCATE(RJADD2(JLEN(2))) + CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICY2), RJADD2) + IF( IAXIS.EQ.IST2-20 )THEN + N2=3 + CALL LCMLEN(IPGEOM, 'RADIUS', JLEN(3), IT) + ALLOCATE(RJADD3(JLEN(3))) + CALL LCMGET(IPGEOM, 'RADIUS', RJADD3) + ENDIF + ELSE + CALL XABORT( 'LDRCEL: ONE CELL HAS INCORRECT DIM') + ENDIF + CALL LCMSIX(IPGEOM, ' ', 2) + ENDIF + ENDIF +* +* CHECK VECTORS THAT HAVE BEEN EXTRACTED AND RELEASE SPACE... + IF( N1.EQ.N2 )THEN + DO 40 I= 1, N1 + IF( ILEN(I).NE.JLEN(I) ) + > CALL XABORT( 'LDRCEL: INCORRECT MESHING DIM') + IF(I.EQ.1) THEN + DO 10 J= 1, ILEN(1) + IF( RIADD1(J).NE.RJADD1(J)) + > CALL XABORT( 'LDRCEL: INCORRECT MESHING(1)') + 10 CONTINUE + DEALLOCATE(RJADD1,RIADD1) + ELSE IF(I.EQ.2) THEN + DO 20 J= 1, ILEN(2) + IF( RIADD2(J).NE.RJADD2(J)) + > CALL XABORT( 'LDRCEL: INCORRECT MESHING(2)') + 20 CONTINUE + DEALLOCATE(RJADD2,RIADD2) + ELSE IF(I.EQ.3) THEN + DO 30 J= 1, ILEN(3) + IF( RIADD3(J).NE.RJADD3(J)) + > CALL XABORT( 'LDRCEL: INCORRECT MESHING(3)') + 30 CONTINUE + DEALLOCATE(RJADD3,RIADD3) + ENDIF + 40 CONTINUE + ELSE + CALL XABORT( 'LDRCEL: TYPES ARE INCOMPATIBLE') + ENDIF + RETURN + END diff --git a/Dragon/src/LDRGEO.f b/Dragon/src/LDRGEO.f new file mode 100644 index 0000000..d61795a --- /dev/null +++ b/Dragon/src/LDRGEO.f @@ -0,0 +1,179 @@ +*DECK LDRGEO + LOGICAL FUNCTION LDRGEO(IPGEOM,GEON1,GEON2,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compare two sub-geometries stored on LCM (do not compare mixture +* numbers). +* +*Copyright: +* Copyright (C) 1002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPGEOM pointer to the geometry (L_GEOM signature). +* GEON1 name of the first sub-geometry. +* GEON2 name of the second sub-geometry. +* IMPX print flag (impx=0 for no print). +* +*Parameters: output +* LDRGEO equality flag (=.true. if the two geometries are identical). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPGEOM + INTEGER IMPX + CHARACTER GEON1*12,GEON2*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MAXLEV=50) + TYPE(C_PTR) IPLIS1,IPLIS2,KDATA1(MAXLEV),KDATA2(MAXLEV) + CHARACTER NAMT*12,GEON3*12,GEON4*12,HNAME*12,NAMMY1*12,NAMMY2*12, + 1 CTMP1*4,CTMP2*4,PATH(MAXLEV)*12,FIRST(MAXLEV)*12,HSMG*131 + INTEGER IGO(MAXLEV) + LOGICAL EMPTY,LCM + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDATA1,IDATA2 + REAL, ALLOCATABLE, DIMENSION(:) :: RDATA1,RDATA2 + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DDATA1,DDATA2 +* + CALL LCMLEN(IPGEOM,GEON1,ILON1,ITY1) + IF(ILON1.EQ.0) CALL XABORT('LDRGEO: UNKNOWN GEOMETRY (1).') + CALL LCMLEN(IPGEOM,GEON1,ILON1,ITY1) + IF(ILON1.EQ.0) CALL XABORT('LDRGEO: UNKNOWN GEOMETRY (2).') + GEON3=GEON1 + GEON4=GEON2 + DO 120 IORDER=1,2 + IPLIS1=LCMGID(IPGEOM,GEON3) + IPLIS2=LCMGID(IPGEOM,GEON4) + LDRGEO=.TRUE. + ILEV=1 + KDATA1(1)=IPLIS1 + KDATA2(1)=IPLIS2 + IGO(1)=3 +* +* ASSOCIATIVE TABLE. + 10 CALL LCMINF(IPLIS1,HNAME,NAMMY1,EMPTY,ILONG,LCM) + CALL LCMINF(IPLIS2,HNAME,NAMMY2,EMPTY,ILONG,LCM) + IF(EMPTY) GO TO (100,100,110),IGO(ILEV) + NAMT=' ' + CALL LCMNXT(IPLIS1,NAMT) +* + FIRST(ILEV)=NAMT + 20 CALL LCMLEN(IPLIS1,NAMT,ILON1,ITY1) + CALL LCMLEN(IPLIS2,NAMT,ILON2,ITY2) + IF((ILON1.NE.ILON2).OR.(ITY1.NE.ITY2)) THEN + LDRGEO=.FALSE. + IF(IMPX.GT.0) WRITE (6,130) GEON3,GEON4,NAMT + RETURN + ENDIF + IF(ITY1.EQ.0) THEN +* ASSOCIATIVE TABLE DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,'(2A,A12,A)') 'LDRGEO: TOO MANY DIRECTORY ', + 1 'LEVELS ON ''',HNAME,'''.' + CALL XABORT(HSMG) + ENDIF + KDATA1(ILEV)=LCMGID(IPLIS1,NAMT) + KDATA2(ILEV)=LCMGID(IPLIS2,NAMT) + PATH(ILEV)=NAMT + IPLIS1=KDATA1(ILEV) + IPLIS2=KDATA2(ILEV) + IGO(ILEV)=1 + GO TO 10 + ELSE IF(ITY1.LE.6) THEN + IF(ITY1.EQ.1) THEN +* INTEGER DATA. + ALLOCATE(IDATA1(ILON1),IDATA2(ILON2)) + CALL LCMGET(IPLIS1,NAMT,IDATA1) + CALL LCMGET(IPLIS2,NAMT,IDATA2) + IF((NAMT.NE.'MIX').AND.(NAMT.NE.'STATE-VECTOR')) THEN + DO 40 I=1,ILON1 + LDRGEO=LDRGEO.AND.(IDATA1(I).EQ.IDATA2(I)) + 40 CONTINUE + ELSE IF(NAMT.EQ.'STATE-VECTOR') THEN + DO 50 I=1,6 + LDRGEO=LDRGEO.AND.(IDATA1(I).EQ.IDATA2(I)) + 50 CONTINUE + ENDIF + DEALLOCATE(IDATA2,IDATA1) + ELSE IF(ITY1.EQ.2) THEN +* SINGLE PRECISION DATA. + ALLOCATE(RDATA1(ILON1),RDATA2(ILON2)) + CALL LCMGET(IPLIS1,NAMT,RDATA1) + CALL LCMGET(IPLIS2,NAMT,RDATA2) + ZMAX=0.0 + DO 60 I=1,ILON1 + ZMAX=MAX(ZMAX,ABS(RDATA1(I)),ABS(RDATA2(I))) + 60 CONTINUE + IF(ZMAX.EQ.0.0) ZMAX=1.0 + DO 70 I=1,ILON1 + EPS=ABS(RDATA1(I)-RDATA2(I))/ZMAX + LDRGEO=LDRGEO.AND.(EPS.LT.1.0E-4) + 70 CONTINUE + DEALLOCATE(RDATA2,RDATA1) + ELSE IF(ITY1.EQ.3) THEN +* CHARACTER*4 DATA. + ALLOCATE(IDATA1(ILON1),IDATA2(ILON2)) + CALL LCMGET(IPLIS1,NAMT,IDATA1) + CALL LCMGET(IPLIS2,NAMT,IDATA2) + DO 80 I=1,ILON1 + WRITE(CTMP1,'(A4)') IDATA1(I) + WRITE(CTMP2,'(A4)') IDATA2(I) + LDRGEO=LDRGEO.AND.(CTMP1.EQ.CTMP2) + 80 CONTINUE + DEALLOCATE(IDATA2,IDATA1) + ELSE IF(ITY1.EQ.4) THEN +* DOUBLE PRECISION DATA. + ALLOCATE(DDATA1(ILON1),DDATA2(ILON2)) + CALL LCMGET(IPLIS1,NAMT,DDATA1) + CALL LCMGET(IPLIS2,NAMT,DDATA2) + ZMAX=0.0 + DO 85 I=1,ILON1 + ZMAX=MAX(ZMAX,REAL(ABS(DDATA1(I))),REAL(ABS(DDATA2(I)))) + 85 CONTINUE + IF(ZMAX.EQ.0.0) ZMAX=1.0 + DO 90 I=1,ILON1 + EPS=ABS(REAL(DDATA1(I)-DDATA2(I)))/ZMAX + LDRGEO=LDRGEO.AND.(EPS.LT.1.0E-4) + 90 CONTINUE + DEALLOCATE(DDATA2,DDATA1) + ELSE + CALL XABORT('LDRGEO: INVALID DATA TYPE.') + ENDIF + IF(.NOT.LDRGEO) THEN + LDRGEO=.FALSE. + IF(IMPX.GT.0) WRITE (6,130) GEON3,GEON4,NAMT + RETURN + ENDIF + ENDIF + CALL LCMNXT(IPLIS1,NAMT) + IF(NAMT.NE.FIRST(ILEV)) GO TO 20 + GO TO (100,100,110),IGO(ILEV) +* + 100 NAMT=PATH(ILEV) + ILEV=ILEV-1 + IPLIS1=KDATA1(ILEV) + IPLIS2=KDATA2(ILEV) + CALL LCMNXT(IPLIS1,NAMT) + IF(NAMT.NE.FIRST(ILEV)) GO TO 20 + GO TO (100,100,110),IGO(ILEV) + 110 GEON3=GEON2 + GEON4=GEON1 + 120 CONTINUE + RETURN +* + 130 FORMAT (/34H LDRGEO: COMPARISON OF GEOMETRIES ,A12,5H AND ,A12, + 1 16H --- LCM BLOCK ',A12,15H' IS DIFFERENT.) + END diff --git a/Dragon/src/LELCHK.f b/Dragon/src/LELCHK.f new file mode 100644 index 0000000..96ec96b --- /dev/null +++ b/Dragon/src/LELCHK.f @@ -0,0 +1,140 @@ +*DECK LELCHK + LOGICAL FUNCTION LELCHK( NSOLD, NVOLD, VOLOLD, MATOLD, ICOLD, + > NSNEW, NVNEW, VOLNEW, MATNEW, ICNEW, + > IPRT ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Check compatibility between data in the old tracking file and +* in the new geometry. +* +*Copyright: +* Copyright (C) 1991 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* NSOLD number of surfaces in tracking file. +* NVOLD number of zones in tracking file. +* VOLOLD volumes and surfaces in tracking file. +* MATOLD numbering of surfaces and zones in tracking file. +* ICOLD index of B.C. in tracking file. +* NSNEW number of surfaces in new geometry. +* NVNEW number of zones in new geometry. +* VOLNEW volumes & surfaces in new geometry. +* MATNEW numbering of surfaces and zones in new geometry. +* ICNEW index of B.C. in new geometry. +* IPRT printing level ( 0: no print) +* +*Parameters: output +* LELCHK checking flag: =.true. if everything was compatible +* =.false. if incompatibility were detected. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +* + INTEGER NSOLD,NVOLD,MATOLD(-NSOLD:NVOLD),ICOLD(6),IPRT,IOUT, + > NSNEW,NVNEW,MATNEW(-NSOLD:NVOLD),ICNEW(6),IR,NERROC + REAL VOLOLD(-NSOLD:NVOLD),VOLNEW(-NSNEW:NVNEW), + > ZERO,HUND,EMAX + PARAMETER ( IOUT=6, ZERO=0.0, HUND=100.0, EMAX=1.E-5 ) + LELCHK= .TRUE. +* +*1.1) CHECK # OF ZONES ------------------------------------------------ + IF( NVOLD.NE.NVNEW )THEN + IF( IPRT.GT.0 )THEN + WRITE(IOUT,'(40H *** INCONSISTENT # OF ZONES )') + ENDIF + LELCHK=.FALSE. + GO TO 999 + ENDIF +* +*1.2) CHECK # OF FACES ------------------------------------------------ + IF( NSOLD.NE.NSNEW )THEN + IF( IPRT.GT.0 )THEN + WRITE(IOUT,'(40H *** INCONSISTENT # OF FACES )') + ENDIF + LELCHK=.FALSE. + GO TO 999 + ENDIF +* +*1.3) CHECK CONSISTENCY OF INDEX *ICODE* ------------------------------ + DO 10 IR= 1, 6 + IF( ICOLD(IR).NE.ICNEW(IR) )THEN + IF( IPRT.GT.0 )THEN + WRITE(IOUT,'(9H ICODE(,I1,3H)= ,I6,5H(WAS ,I6,1H))') + > IR, ICNEW(IR), ICOLD(IR) + ENDIF + IF( ICOLD(IR).LE.0.OR.ICNEW(IR).LE.0 )THEN + LELCHK=.FALSE. + GO TO 999 + ENDIF + ENDIF + 10 CONTINUE +* +*1.4) CHECK IF SOME FACES HAVE ICODE=0 -------------------------------- + DO 20 IR= -NSOLD, -1 + IF( ICNEW(-MATNEW(IR)).EQ.0 )THEN + IF( IPRT.GT.0 )THEN + WRITE(IOUT,'(9H FACE(,I1,3H)= ,I6,12H HAS ICODE=0 )') + > -IR, MATNEW(IR) + ENDIF + LELCHK=.FALSE. + GO TO 999 + ENDIF + 20 CONTINUE +* +*2) CHECK CONSISTENCY OF VECTORS *VOLSUR* AND *MATALB* -------------- + NERROC= 0 + DO 30 IR= -NSOLD, NVOLD + IF( VOLOLD(IR)-VOLNEW(IR).GT.ZERO )THEN + NERROC= NERROC+1 + IF( IR.EQ.0 ) GO TO 30 + LELCHK= LELCHK.AND. + > ABS((VOLNEW(IR)-VOLOLD(IR))/VOLOLD(IR)).LE.EMAX + ENDIF + IF( MATOLD(IR).NE.MATNEW(IR) )THEN + NERROC= NERROC+1 + IF( IR.LE.0 ) LELCHK= .FALSE. + ENDIF + 30 CONTINUE + IF( IPRT.GT.0 )THEN + WRITE(IOUT,'(1H )') + IF( NERROC.EQ.0 )THEN + WRITE(IOUT,'(60H ECHO = >>> CONSISTENCY BETWEEN '// + > 'TRACKING FILE AND GEOMETRY /)') + ELSE + WRITE(IOUT,'(60H ECHO = >>> WARNING: INCONSISTENT '// + > 'TRACKING FILE /)') + DO 40 IR= -NSOLD, NVOLD + IF( IR.EQ.0 ) GO TO 40 + IF( VOLOLD(IR)-VOLNEW(IR).GT.ZERO )THEN + IF( IR.LE.0 )THEN + WRITE(IOUT,'(15H ERROR ON FACE(,I4,3H)= ,F10.7,1H%)') + > -IR,HUND*(VOLNEW(IR)-VOLOLD(IR))/VOLOLD(IR) + ELSE + WRITE(IOUT,'(15H ERROR ON ZONE(,I4,3H)= ,F10.7,1H%)') + > IR,HUND*(VOLNEW(IR)-VOLOLD(IR))/VOLOLD(IR) + ENDIF + ENDIF + IF( MATOLD(IR).NE.MATNEW(IR) )THEN + IF( IR.LE.0 )THEN + WRITE(IOUT,'(9H FACE(,I1,3H)= ,I6,5H(WAS ,I6,1H))') + > -IR, MATNEW(IR),MATOLD(IR) + ELSE + WRITE(IOUT,'(9H MIXTURE(,I1,3H)= ,I6,5H(WAS ,I6,1H))') + > IR, MATNEW(IR),MATOLD(IR) + ENDIF + ENDIF + 40 CONTINUE + ENDIF + ENDIF +* + 999 RETURN + END diff --git a/Dragon/src/LELCRN.f b/Dragon/src/LELCRN.f new file mode 100644 index 0000000..267c2e5 --- /dev/null +++ b/Dragon/src/LELCRN.f @@ -0,0 +1,75 @@ +*DECK LELCRN + FUNCTION LELCRN( CENTEC, RAYONC, X, Y) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Decide if the crown intersect a rectangular mesh. +* +*Copyright: +* Copyright (C) 1990 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* CENTEC coordinates of center. +* RAYONC inner and outer radius**2 of the crown. +* X X of the square. +* Y Y of the square. +* +*Parameters: output +* LELCRN checking flag: =.true. if interaction exists and +* =.false. otherwise. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE + LOGICAL LELCRN +* + DOUBLE PRECISION CENTEC(2), RAYONC(2), X(2), Y(2), R + INTEGER NBEXT, NBINT, IX, IY +* + NBEXT=0 + NBINT=0 + DO 20 IX=1, 2 + DO 10 IY=1, 2 + R= (X(IX)-CENTEC(1))*(X(IX)-CENTEC(1)) + > + (Y(IY)-CENTEC(2))*(Y(IY)-CENTEC(2)) + IF( R.LE.RAYONC(1) ) NBINT= NBINT+1 + IF( R.GE.RAYONC(2) ) NBEXT= NBEXT+1 + 10 CONTINUE + 20 CONTINUE + IF( NBINT.EQ.4 )THEN +* +* RECTANGLE IS CONTAINED INSIDE THE INTERNAL RADIUS + LELCRN=.FALSE. + ELSEIF( NBEXT.EQ.4 )THEN + IF( Y(1).LT.CENTEC(2).AND.CENTEC(2).LT.Y(2) )THEN + IF( CENTEC(1).LT.X(1) )THEN + LELCRN= (X(1)-CENTEC(1))*(X(1)-CENTEC(1)).LT.RAYONC(2) + ELSEIF( X(2).LT.CENTEC(1) )THEN + LELCRN= (X(2)-CENTEC(1))*(X(2)-CENTEC(1)).LT.RAYONC(2) + ELSE + LELCRN=.TRUE. + ENDIF + ELSEIF( X(1).LT.CENTEC(1).AND.CENTEC(1).LT.X(2) )THEN + IF( CENTEC(2).LT.Y(1) )THEN + LELCRN= (Y(1)-CENTEC(2))*(Y(1)-CENTEC(2)).LT.RAYONC(2) + ELSEIF( Y(2).LT.CENTEC(2) )THEN + LELCRN= (Y(2)-CENTEC(2))*(Y(2)-CENTEC(2)).LT.RAYONC(2) + ELSE + LELCRN=.TRUE. + ENDIF + ELSE + LELCRN=.FALSE. + ENDIF + ELSE + LELCRN=.TRUE. + ENDIF +* + RETURN + END diff --git a/Dragon/src/LELCSY.f b/Dragon/src/LELCSY.f new file mode 100644 index 0000000..1aedfa0 --- /dev/null +++ b/Dragon/src/LELCSY.f @@ -0,0 +1,785 @@ +*DECK LELCSY + FUNCTION LELCSY(IPGEOM,IPRT ,GEONAM,GEOCV ,NXYZ ,IGT , + > GMESH ,ISPLG ,TMESH ,ISPLT ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Verify if geometry satisfies an intrinsic symmetry. +* +*Copyright: +* Copyright (C) 2003 Ecole Polytechnique de Montreal. +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy and G. Marleau +* +*Parameters: input +* IPGEOM pointer to the reference geometry data structure. +* IPRT intermediate printing level for output. +* GEONAM name of the reference geometry. +* GEOCV name of the geometry to analyze if different from +* reference geometry. +* NXYZ maximum mesh size in directions $x$, $y$ and $z$. +* IGT geometry turn number. +* +*Parameters: scratch +* GMESH general mesh description for geometry to analyze. +* ISPLG general split desctiption for geometry to analyze. +* TMESH temporary mesh description for geometry comparison. +* ISPLT temporary split desctiption for geometry comparison. +* LELCSY result of geometry testing (true or false). +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + LOGICAL LELCSY + TYPE(C_PTR) IPGEOM + INTEGER IPRT,NXYZ + CHARACTER*12 GEONAM,GEOCV + INTEGER IGT(2) + INTEGER ISPLG(0:NXYZ-1) + INTEGER ISPLT(3,3,0:NXYZ-1) + REAL GMESH(0:NXYZ) + DOUBLE PRECISION TMESH(3,3,0:NXYZ) +*---- +* LOCAL VARIABLES +*---- + INTEGER IOUT,NSTATE + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NSTATE=40,NAMSBR='LELCSY') +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, TARGET, DIMENSION(:) :: IMIX,IMIX1,IM1,IM2 + INTEGER, POINTER, DIMENSION(:) :: IMIX2 +*---- +* LOCAL PARAMETERS +*---- + INTEGER ISTATE(NSTATE),IKT(2) + INTEGER NR,NX,NY,NZ,NK, + > NTM(2,3) + REAL OFFCEN(3),OFFTR(3,2) + INTEGER ILCMLN,ILCMTY + INTEGER IG,IDIR,ITMI,IDMI, + > IR,IX,IY,IZ + DOUBLE PRECISION DDM(3),DDD + INTEGER ITYPG,IMTN,IMTO + LELCSY=.TRUE. + IF(IPRT .GE. 10) THEN + IF(GEOCV .EQ. ' ') THEN + WRITE(IOUT,6000) NAMSBR,GEONAM,IGT(1),IGT(2) + ELSE + WRITE(IOUT,6000) NAMSBR,GEOCV,IGT(1),IGT(2) + ENDIF + ENDIF +*---- +* READ GEOMETRY INFORMATION +*---- + IF(GEOCV .NE. ' ') THEN + CALL LCMSIX(IPGEOM,GEOCV,1) + ENDIF +*---- +* STATE-VECTOR +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) + ITYPG= ISTATE(1) + NR=ISTATE(2) + NX=ISTATE(3) + NY=ISTATE(4) + NZ=ISTATE(5) + NK=ISTATE(6) + TMESH(:3,:3,0:NXYZ)=0.0D0 + ISPLT(:3,:3,0:NXYZ-1)=1 +*---- +* MESHX AND SPLITX +*---- + IDIR=1 + GMESH(0:NXYZ)=0.0 + ISPLG(0:NXYZ-1)=1 + CALL LCMLEN(IPGEOM,'MESHX',ILCMLN,ILCMTY) + IF(ILCMLN .EQ. NX+1) + > CALL LCMGET(IPGEOM,'MESHX',GMESH) + CALL LCMLEN(IPGEOM,'SPLITX',ILCMLN,ILCMTY) + IF(ILCMLN .EQ. NX) + > CALL LCMGET(IPGEOM,'SPLITX',ISPLG) + DDM(IDIR)=0.0D0 + DO 10 IX=0,NX-1 + TMESH(3,IDIR,IX)=DBLE(GMESH(IX)) + DDM(IDIR)=MAX(DDM(IDIR),ABS(TMESH(3,IDIR,IX))) + ISPLT(3,IDIR,IX)=ISPLG(IX) + 10 CONTINUE + TMESH(3,IDIR,NX)=DBLE(GMESH(NX)) + DDM(IDIR)=MAX(DDM(IDIR),ABS(TMESH(3,IDIR,NX))) +*---- +* MESHY AND SPLITY +*---- + IDIR=2 + GMESH(0:NXYZ)=0.0 + ISPLG(0:NXYZ-1)=1 + CALL LCMLEN(IPGEOM,'MESHY',ILCMLN,ILCMTY) + IF(ILCMLN .EQ. NY+1) + > CALL LCMGET(IPGEOM,'MESHY',GMESH) + CALL LCMLEN(IPGEOM,'SPLITY',ILCMLN,ILCMTY) + IF(ILCMLN .EQ. NY) + > CALL LCMGET(IPGEOM,'SPLITY',ISPLG) + DDM(IDIR)=0.0D0 + DO 11 IY=0,NY-1 + TMESH(3,IDIR,IY)=DBLE(GMESH(IY)) + DDM(IDIR)=MAX(DDM(IDIR),ABS(TMESH(3,IDIR,IX))) + ISPLT(3,IDIR,IY)=ISPLG(IY) + 11 CONTINUE + TMESH(3,IDIR,NY)=DBLE(GMESH(NY)) + DDM(IDIR)=MAX(DDM(IDIR),ABS(TMESH(3,IDIR,NX))) +*---- +* MESHZ AND SPLITZ +*---- + IDIR=3 + DDM(IDIR)=0.0D0 + IF(NZ .GT. 0) THEN + GMESH(0:NXYZ)=0.0 + ISPLG(0:NXYZ-1)=1 + CALL LCMLEN(IPGEOM,'MESHZ',ILCMLN,ILCMTY) + IF(ILCMLN .EQ. NZ+1) + > CALL LCMGET(IPGEOM,'MESHZ',GMESH) + CALL LCMLEN(IPGEOM,'SPLITZ',ILCMLN,ILCMTY) + IF(ILCMLN .EQ. NZ) + > CALL LCMGET(IPGEOM,'SPLITZ',ISPLG) + DO 12 IZ=0,NZ-1 + TMESH(3,IDIR,IZ)=DBLE(GMESH(IZ)) + DDM(IDIR)=MAX(DDM(IDIR),ABS(TMESH(3,IDIR,IX))) + ISPLT(3,IDIR,IZ)=ISPLG(IZ) + 12 CONTINUE + TMESH(3,IDIR,NZ)=DBLE(GMESH(NZ)) + DDM(IDIR)=MAX(DDM(IDIR),ABS(TMESH(3,IDIR,NX))) + ELSE + NZ=1 + ENDIF +C-- MIX + ALLOCATE(IMIX(NK)) + IMIX(:NK)=0 + CALL LCMLEN(IPGEOM,'MIX',ILCMLN,ILCMTY) + IF(ITYPG .EQ. 21) THEN +C---- +C FOR CARCELX REORDER MIXTURE +C---- + ALLOCATE(IMIX1(NK)) + IF(ILCMLN .GT. 0 .AND. ILCMLN .LE. NK) + > CALL LCMGET(IPGEOM,'MIX',IMIX1) + IMTN=0 + DO 20 IZ=1,NZ + DO 21 IY=1,NY + DO 22 IX=1,NX + DO 23 IR=1,NR+1 + IMTN=IMTN+1 + IMTO=(IX-1)*NZ*NY*(NR+1)+(IZ-1)*NY*(NR+1)+ + > (IY-1)*(NR+1)+IR + IMIX(IMTN)=IMIX1(IMTO) + 23 CONTINUE + 22 CONTINUE + 21 CONTINUE + 20 CONTINUE + DEALLOCATE(IMIX1) + ELSE IF(ITYPG .EQ. 22) THEN +C---- +C FOR CARCELY REORDER MIXTURE +C---- + ALLOCATE(IMIX1(NK)) + IF(ILCMLN .GT. 0 .AND. ILCMLN .LE. NK) + > CALL LCMGET(IPGEOM,'MIX',IMIX1) + IMTN=0 + DO 30 IZ=1,NZ + DO 31 IY=1,NY + DO 32 IX=1,NX + DO 33 IR=1,NR+1 + IMTN=IMTN+1 + IMTO=(IY-1)*NZ*NX*(NR+1)+(IX-1)*NZ*(NR+1)+ + > (IZ-1)*(NR+1)+IR + IMIX(IMTN)=IMIX1(IMTO) + 33 CONTINUE + 32 CONTINUE + 31 CONTINUE + 30 CONTINUE + DEALLOCATE(IMIX1) + ELSE + IF(ILCMLN .GT. 0 .AND. ILCMLN .LE. NK) + > CALL LCMGET(IPGEOM,'MIX',IMIX) + ENDIF +C- OFF CENTER + OFFCEN(:3)=0.0 + CALL LCMLEN(IPGEOM,'OFFCENTER',ILCMLN,ILCMTY) + IF(ILCMLN .EQ. 3) + > CALL LCMGET(IPGEOM,'OFFCENTER',OFFCEN) +C---- +C PRINT INITIAL MESH +C---- + IF(IPRT .GE. 20) THEN + WRITE(IOUT,6001) NX,NY,NZ,NR,NK + WRITE(IOUT,6002) 'MESHX =' + WRITE(IOUT,6003) (TMESH(3,1,IX),IX=0,NX) + WRITE(IOUT,6002) 'SPLTX =' + WRITE(IOUT,6004) (ISPLT(3,1,IX),IX=0,NX-1) + WRITE(IOUT,6002) 'MESHY =' + WRITE(IOUT,6003) (TMESH(3,2,IY),IY=0,NY) + WRITE(IOUT,6002) 'SPLTY =' + WRITE(IOUT,6004) (ISPLT(3,2,IY),IY=0,NY-1) + WRITE(IOUT,6002) 'MESHZ =' + WRITE(IOUT,6003) (TMESH(3,3,IZ),IZ=0,NZ) + WRITE(IOUT,6002) 'SPLTZ =' + WRITE(IOUT,6004) (ISPLT(3,3,IZ),IZ=0,NZ-1) + WRITE(IOUT,6002) 'MIXT =' + WRITE(IOUT,6004) (IMIX(IX),IX=1,NK) + WRITE(IOUT,6002) 'OFFC =' + WRITE(IOUT,6003) (OFFCEN(IX),IX=1,3) + ENDIF +C---- +C TURN GEOMETRY WITH IGT +C---- + DO 1000 IG=1,2 + IF(IGT(IG) .GT. 12 ) THEN + IKT(IG)=12-IGT(IG) + ELSE + IKT(IG)=IGT(IG) + ENDIF + IF(IG.EQ.1) THEN + ALLOCATE(IM1(2*NK)) + IMIX2=>IM1 + ELSE + ALLOCATE(IM2(2*NK)) + IMIX2=>IM2 + ENDIF + IMIX2(:NK)=0 + IF(IKT(IG) .LT. 0) THEN + OFFTR(3,IG)=-OFFCEN(3) + ELSE + OFFTR(3,IG)=OFFCEN(3) + ENDIF + IF(ABS(IKT(IG)) .EQ. 1) THEN + NTM(IG,1)=NX + NTM(IG,2)=NY + NTM(IG,3)=NZ + DO 100 IX=0,NX-1 + TMESH(IG,1,IX)=TMESH(3,1,IX+1)-TMESH(3,1,IX) + ISPLT(IG,1,IX)=ISPLT(3,1,IX) + 100 CONTINUE + DO 110 IY=0,NY-1 + TMESH(IG,2,IY)=TMESH(3,2,IY+1)-TMESH(3,2,IY) + ISPLT(IG,2,IY)=ISPLT(3,2,IY) + 110 CONTINUE + OFFTR(1,IG)=OFFCEN(1) + OFFTR(2,IG)=OFFCEN(2) + IF(IKT(IG) .LT. 0) THEN + DO 120 IZ=0,NZ-1 + TMESH(IG,3,IZ)=TMESH(3,3,NZ-IZ)-TMESH(3,3,NZ-IZ-1) + ISPLT(IG,3,IZ)=ISPLT(3,3,NZ-IZ-1) + ITMI=IZ*NX*NY*(NR+1) + IDMI=(NZ-IZ-1)*NX*NY*(NR+1) + DO 121 IY=0,NY-1 + DO 122 IX=0,NX-1 + DO 123 IR=0,NR + IMIX2(ITMI+1)=IMIX(IDMI+1) + ITMI=ITMI+1 + IDMI=IDMI+1 + 123 CONTINUE + 122 CONTINUE + 121 CONTINUE + 120 CONTINUE + ELSE + DO 130 IZ=0,NZ-1 + TMESH(IG,3,IZ)=TMESH(3,3,IZ+1)-TMESH(3,3,IZ) + ISPLT(IG,3,IZ)=ISPLT(3,3,IZ) + ITMI=IZ*NX*NY*(NR+1) + IDMI=ITMI + DO 131 IY=0,NY-1 + DO 132 IX=0,NX-1 + DO 133 IR=0,NR + IMIX2(ITMI+1)=IMIX(IDMI+1) + ITMI=ITMI+1 + IDMI=IDMI+1 + 133 CONTINUE + 132 CONTINUE + 131 CONTINUE + 130 CONTINUE + ENDIF + ELSE IF(ABS(IKT(IG)) .EQ. 2) THEN +C---- +C ROTATION OF PI/2 +C---- + NTM(IG,1)=NY + NTM(IG,2)=NX + NTM(IG,3)=NZ + DDD=DDM(2) + DDM(2)=DDM(1) + DDM(1)=DDD + DO 200 IX=0,NY-1 + TMESH(IG,1,IX)=TMESH(3,2,IX+1)-TMESH(3,2,IX) + ISPLT(IG,1,IX)=ISPLT(3,2,IX) + 200 CONTINUE + DO 210 IY=0,NX-1 + TMESH(IG,2,IY)=TMESH(3,1,NX-IY)-TMESH(3,1,NX-IY-1) + ISPLT(IG,2,IY)=ISPLT(3,1,NX-IY-1) + 210 CONTINUE + OFFTR(1,IG)=OFFCEN(2) + OFFTR(2,IG)=-OFFCEN(1) + IF(IKT(IG) .LT. 0) THEN + DO 220 IZ=0,NZ-1 + TMESH(IG,3,IZ)=TMESH(3,3,NZ-IZ)-TMESH(3,3,NZ-IZ-1) + ISPLT(IG,3,IZ)=ISPLT(3,3,NZ-IZ-1) + DO 221 IY=0,NX-1 + DO 222 IX=0,NY-1 + ITMI=IZ*NX*NY*(NR+1)+IY*NY*(NR+1)+ + > IX*(NR+1) + IDMI=(NZ-IZ-1)*NX*NY*(NR+1)+(NY-IX-1)*NX*(NR+1)+ + > IY*(NR+1) + DO 223 IR=0,NR + IMIX2(ITMI+1)=IMIX(IDMI+1) + ITMI=ITMI+1 + IDMI=IDMI+1 + 223 CONTINUE + 222 CONTINUE + 221 CONTINUE + 220 CONTINUE + ELSE + DO 230 IZ=0,NZ-1 + TMESH(IG,3,IZ)=TMESH(3,3,IZ+1)-TMESH(3,3,IZ) + ISPLT(IG,3,IZ)=ISPLT(3,3,IZ) + DO 231 IY=0,NX-1 + DO 232 IX=0,NY-1 + ITMI=IZ*NX*NY*(NR+1)+IY*NY*(NR+1)+ + > IX*(NR+1) + IDMI=IZ*NX*NY*(NR+1)+IX*NX*(NR+1)+ + > (NX-IY-1)*(NR+1) + DO 233 IR=0,NR + IMIX2(ITMI+1)=IMIX(IDMI+1) + ITMI=ITMI+1 + IDMI=IDMI+1 + 233 CONTINUE + 232 CONTINUE + 231 CONTINUE + 230 CONTINUE + ENDIF + ELSE IF(ABS(IKT(IG)) .EQ. 3) THEN +C---- +C ROTATION OF PI +C---- + NTM(IG,1)=NX + NTM(IG,2)=NY + NTM(IG,3)=NZ + DO 300 IX=0,NX-1 + TMESH(IG,1,IX)=TMESH(3,1,NX-IX)-TMESH(3,1,NX-IX-1) + ISPLT(IG,1,IX)=ISPLT(3,1,NX-IX-1) + 300 CONTINUE + DO 310 IY=0,NY-1 + TMESH(IG,2,IY)=TMESH(3,2,NY-IY)-TMESH(3,2,NY-IY-1) + ISPLT(IG,2,IY)=ISPLT(3,2,NY-IY-1) + 310 CONTINUE + OFFTR(1,IG)=-OFFCEN(1) + OFFTR(2,IG)=-OFFCEN(2) + IF(IKT(IG) .LT. 0) THEN + DO 320 IZ=0,NZ-1 + TMESH(IG,3,IZ)=TMESH(3,3,NZ-IZ)-TMESH(3,3,NZ-IZ-1) + ISPLT(IG,3,IZ)=ISPLT(3,3,NZ-IZ-1) + DO 321 IY=0,NY-1 + DO 322 IX=0,NX-1 + ITMI=IZ*NX*NY*(NR+1)+IY*NX*(NR+1)+ + > IX*(NR+1) + IDMI=(NZ-IZ-1)*NX*NY*(NR+1)+(NY-IY-1)*NX*(NR+1)+ + > (NX-IX-1)*(NR+1) + DO 323 IR=0,NR + IMIX2(ITMI+1)=IMIX(IDMI+1) + ITMI=ITMI+1 + IDMI=IDMI+1 + 323 CONTINUE + 322 CONTINUE + 321 CONTINUE + 320 CONTINUE + ELSE + DO 330 IZ=0,NZ-1 + TMESH(IG,3,IZ)=TMESH(3,3,IZ+1)-TMESH(3,3,IZ) + ISPLT(IG,3,IZ)=ISPLT(3,3,IZ) + DO 331 IY=0,NY-1 + DO 332 IX=0,NX-1 + ITMI=IZ*NX*NY*(NR+1)+IY*NX*(NR+1)+ + > IX*(NR+1) + IDMI=IZ*NX*NY*(NR+1)+(NY-IY-1)*NX*(NR+1)+ + > (NX-IX-1)*(NR+1) + DO 333 IR=0,NR + IMIX2(ITMI+1)=IMIX(IDMI+1) + ITMI=ITMI+1 + IDMI=IDMI+1 + 333 CONTINUE + 332 CONTINUE + 331 CONTINUE + 330 CONTINUE + ENDIF + ELSE IF(ABS(IKT(IG)) .EQ. 4) THEN +C---- +C ROTATION OF 3*PI/2 +C---- + NTM(IG,1)=NY + NTM(IG,2)=NX + NTM(IG,3)=NZ + DDD=DDM(2) + DDM(2)=DDM(1) + DDM(1)=DDD + DO 400 IX=0,NY-1 + TMESH(IG,1,IX)=TMESH(3,2,NY-IX)-TMESH(3,2,NY-IX-1) + ISPLT(IG,1,IX)=ISPLT(3,2,NY-IX-1) + 400 CONTINUE + DO 410 IY=0,NX-1 + TMESH(IG,2,IY)=TMESH(3,1,IY+1)-TMESH(3,1,IY) + ISPLT(IG,2,IY)=ISPLT(3,1,IY) + 410 CONTINUE + OFFTR(1,IG)=-OFFCEN(2) + OFFTR(2,IG)=OFFCEN(1) + IF(IKT(IG) .LT. 0) THEN + DO 420 IZ=0,NZ-1 + TMESH(IG,3,IZ)=TMESH(3,3,NZ-IZ)-TMESH(3,3,NZ-IZ-1) + ISPLT(IG,3,IZ)=ISPLT(3,3,NZ-IZ-1) + DO 421 IY=0,NX-1 + DO 422 IX=0,NY-1 + ITMI=IZ*NX*NY*(NR+1)+IY*NY*(NR+1)+ + > IX*(NR+1) + IDMI=(NZ-IZ-1)*NX*NY*(NR+1)+(NY-IX-1)*NX*(NR+1)+ + > IY*(NR+1) + DO 423 IR=0,NR + IMIX2(ITMI+1)=IMIX(IDMI+1) + ITMI=ITMI+1 + IDMI=IDMI+1 + 423 CONTINUE + 422 CONTINUE + 421 CONTINUE + 420 CONTINUE + ELSE + DO 430 IZ=0,NZ-1 + TMESH(IG,3,IZ)=TMESH(3,3,IZ+1)-TMESH(3,3,IZ) + ISPLT(IG,3,IZ)=ISPLT(3,3,IZ) + DO 431 IY=0,NX-1 + DO 432 IX=0,NY-1 + ITMI=IZ*NX*NY*(NR+1)+IY*NY*(NR+1)+ + > IX*(NR+1) + IDMI=IZ*NX*NY*(NR+1)+(NY-IX-1)*NX*(NR+1)+ + > IY*(NR+1) + DO 433 IR=0,NR + IMIX2(ITMI+1)=IMIX(IDMI+1) + ITMI=ITMI+1 + IDMI=IDMI+1 + 433 CONTINUE + 432 CONTINUE + 431 CONTINUE + 430 CONTINUE + ENDIF + ELSE IF(ABS(IKT(IG)) .EQ. 5) THEN +C---- +C REFLECTION WITH RESPECT TO AXIS // TO Y +C---- + NTM(IG,1)=NX + NTM(IG,2)=NY + NTM(IG,3)=NZ + DO 500 IX=0,NX-1 + TMESH(IG,1,IX)=TMESH(3,1,NX-IX)-TMESH(3,1,NX-IX-1) + ISPLT(IG,1,IX)=ISPLT(3,1,NX-IX-1) + 500 CONTINUE + DO 510 IY=0,NY-1 + TMESH(IG,2,IY)=TMESH(3,2,IY+1)-TMESH(3,2,IY) + ISPLT(IG,2,IY)=ISPLT(3,2,IY) + 510 CONTINUE + OFFTR(1,IG)=-OFFCEN(1) + OFFTR(2,IG)=OFFCEN(2) + IF(IKT(IG) .LT. 0) THEN + DO 520 IZ=0,NZ-1 + TMESH(IG,3,IZ)=TMESH(3,3,NZ-IZ)-TMESH(3,3,NZ-IZ-1) + ISPLT(IG,3,IZ)=ISPLT(3,3,NZ-IZ-1) + DO 521 IY=0,NY-1 + DO 522 IX=0,NX-1 + ITMI=IZ*NX*NY*(NR+1)+IY*NX*(NR+1)+ + > IX*(NR+1) + IDMI=(NZ-IZ-1)*NX*NY*(NR+1)+IY*NX*(NR+1)+ + > (NX-IX-1)*(NR+1) + DO 523 IR=0,NR + IMIX2(ITMI+1)=IMIX(IDMI+1) + ITMI=ITMI+1 + IDMI=IDMI+1 + 523 CONTINUE + 522 CONTINUE + 521 CONTINUE + 520 CONTINUE + ELSE + DO 530 IZ=0,NZ-1 + TMESH(IG,3,IZ)=TMESH(3,3,IZ+1)-TMESH(3,3,IZ) + ISPLT(IG,3,IZ)=ISPLT(3,3,IZ) + DO 531 IY=0,NY-1 + DO 532 IX=0,NX-1 + ITMI=IZ*NX*NY*(NR+1)+IY*NX*(NR+1)+ + > IX*(NR+1) + IDMI=IZ*NX*NY*(NR+1)+IY*NX*(NR+1)+ + > (NX-IX-1)*(NR+1) + DO 533 IR=0,NR + IMIX2(ITMI+1)=IMIX(IDMI+1) + ITMI=ITMI+1 + IDMI=IDMI+1 + 533 CONTINUE + 532 CONTINUE + 531 CONTINUE + 530 CONTINUE + ENDIF + ELSE IF(ABS(IKT(IG)) .EQ. 6) THEN +C---- +C ROTATION OF PI/2 FOLLOWED BY +C REFLECTION WITH RESPECT TO AXIS // TO Y +C---- + NTM(IG,1)=NY + NTM(IG,2)=NX + NTM(IG,3)=NZ + DDD=DDM(2) + DDM(2)=DDM(1) + DDM(1)=DDD + DO 600 IX=0,NY-1 + TMESH(IG,1,IX)=TMESH(3,2,IX+1)-TMESH(3,2,IX) + ISPLT(IG,1,IX)=ISPLT(3,2,IX) + 600 CONTINUE + DO 610 IY=0,NX-1 + TMESH(IG,2,IY)=TMESH(3,1,IY+1)-TMESH(3,1,IY) + ISPLT(IG,2,IY)=ISPLT(3,1,IY) + 610 CONTINUE + OFFTR(1,IG)=OFFCEN(2) + OFFTR(2,IG)=OFFCEN(1) + IF(IKT(IG) .LT. 0) THEN + DO 620 IZ=0,NZ-1 + TMESH(IG,3,IZ)=TMESH(3,3,NZ-IZ)-TMESH(3,3,NZ-IZ-1) + ISPLT(IG,3,IZ)=ISPLT(3,3,NZ-IZ-1) + DO 621 IY=0,NX-1 + DO 622 IX=0,NY-1 + ITMI=IZ*NX*NY*(NR+1)+IY*NY*(NR+1)+ + > IX*(NR+1) + IDMI=(NZ-IZ-1)*NX*NY*(NR+1)+IX*NX*(NR+1)+ + > IY*(NR+1) + DO 623 IR=0,NR + IMIX2(ITMI+1)=IMIX(IDMI+1) + ITMI=ITMI+1 + IDMI=IDMI+1 + 623 CONTINUE + 622 CONTINUE + 621 CONTINUE + 620 CONTINUE + ELSE + DO 630 IZ=0,NZ-1 + TMESH(IG,3,IZ)=TMESH(3,3,IZ+1)-TMESH(3,3,IZ) + ISPLT(IG,3,IZ)=ISPLT(3,3,IZ) + DO 631 IY=0,NX-1 + DO 632 IX=0,NY-1 + ITMI=IZ*NX*NY*(NR+1)+IY*NY*(NR+1)+ + > IX*(NR+1) + IDMI=IZ*NX*NY*(NR+1)+IX*NX*(NR+1)+ + > IY*(NR+1) + DO 633 IR=0,NR + IMIX2(ITMI+1)=IMIX(IDMI+1) + ITMI=ITMI+1 + IDMI=IDMI+1 + 633 CONTINUE + 632 CONTINUE + 631 CONTINUE + 630 CONTINUE + ENDIF + ELSE IF(ABS(IKT(IG)) .EQ. 7) THEN +C---- +C REFLECTION WITH RESPECT TO AXIS // TO X +C---- + NTM(IG,1)=NX + NTM(IG,2)=NY + NTM(IG,3)=NZ + DO 700 IX=0,NX-1 + TMESH(IG,1,IX)=TMESH(3,1,IX+1)-TMESH(3,1,IX) + ISPLT(IG,1,IX)=ISPLT(3,1,IX) + 700 CONTINUE + DO 710 IY=0,NY-1 + TMESH(IG,2,IY)=TMESH(3,2,NY-IY)-TMESH(3,2,NY-IY-1) + ISPLT(IG,2,IY)=ISPLT(3,2,NY-IY-1) + 710 CONTINUE + OFFTR(1,IG)=OFFCEN(1) + OFFTR(2,IG)=-OFFCEN(2) + IF(IKT(IG) .LT. 0) THEN + DO 720 IZ=0,NZ-1 + TMESH(IG,3,IZ)=TMESH(3,3,NZ-IZ)-TMESH(3,3,NZ-IZ-1) + ISPLT(IG,3,IZ)=ISPLT(3,3,NZ-IZ-1) + DO 721 IY=0,NY-1 + ITMI=IZ*NX*NY*(NR+1)+IY*NX*(NR+1) + IDMI=(NZ-IZ-1)*NX*NY*(NR+1)+(NY-IY-1)*NX*(NR+1) + DO 722 IX=0,NX-1 + DO 723 IR=0,NR + IMIX2(ITMI+1)=IMIX(IDMI+1) + ITMI=ITMI+1 + IDMI=IDMI+1 + 723 CONTINUE + 722 CONTINUE + 721 CONTINUE + 720 CONTINUE + ELSE + DO 730 IZ=0,NZ-1 + TMESH(IG,3,IZ)=TMESH(3,3,IZ+1)-TMESH(3,3,IZ) + ISPLT(IG,3,IZ)=ISPLT(3,3,IZ) + DO 731 IY=0,NY-1 + ITMI=IZ*NX*NY*(NR+1)+IY*NX*(NR+1) + IDMI=IZ*NX*NY*(NR+1)+(NY-IY-1)*NX*(NR+1) + DO 732 IX=0,NX-1 + DO 733 IR=0,NR + IMIX2(ITMI+1)=IMIX(IDMI+1) + ITMI=ITMI+1 + IDMI=IDMI+1 + 733 CONTINUE + 732 CONTINUE + 731 CONTINUE + 730 CONTINUE + ENDIF + ELSE IF(ABS(IKT(IG)) .EQ. 8) THEN +C---- +C ROTATION OF PI/2 FOLLOWED BY +C REFLECTION WITH RESPECT TO AXIS // TO X +C---- + NTM(IG,1)=NY + NTM(IG,2)=NX + NTM(IG,3)=NZ + DDD=DDM(2) + DDM(2)=DDM(1) + DDM(1)=DDD + DO 800 IX=0,NY-1 + TMESH(IG,1,IX)=TMESH(3,2,NY-IX)-TMESH(3,2,NY-IX-1) + ISPLT(IG,1,IX)=ISPLT(3,2,NY-IX-1) + 800 CONTINUE + DO 810 IY=0,NX-1 + TMESH(IG,2,IY)=TMESH(3,1,NX-IY)-TMESH(3,1,NX-IY-1) + ISPLT(IG,2,IY)=ISPLT(3,1,NX-IY-1) + 810 CONTINUE + OFFTR(1,IG)=-OFFCEN(2) + OFFTR(2,IG)=-OFFCEN(1) + IF(IKT(IG) .LT. 0) THEN + DO 820 IZ=0,NZ-1 + TMESH(IG,3,IZ)=TMESH(3,3,NZ-IZ)-TMESH(3,3,NZ-IZ-1) + ISPLT(IG,3,IZ)=ISPLT(3,3,NZ-IZ-1) + DO 821 IY=0,NX-1 + DO 822 IX=0,NY-1 + ITMI=IZ*NX*NY*(NR+1)+IY*NY*(NR+1)+ + > IX*(NR+1) + IDMI=(NZ-IZ-1)*NX*NY*(NR+1)+(NY-IX-1)*NX*(NR+1)+ + > (NX-IY-1)*(NR+1) + DO 823 IR=0,NR + IMIX2(ITMI+1)=IMIX(IDMI+1) + ITMI=ITMI+1 + IDMI=IDMI+1 + 823 CONTINUE + 822 CONTINUE + 821 CONTINUE + 820 CONTINUE + ELSE + DO 830 IZ=0,NZ-1 + TMESH(IG,3,IZ)=TMESH(3,3,IZ+1)-TMESH(3,3,IZ) + ISPLT(IG,3,IZ)=ISPLT(3,3,IZ) + DO 831 IY=0,NX-1 + DO 832 IX=0,NY-1 + ITMI=IZ*NX*NY*(NR+1)+IY*NY*(NR+1)+ + > IX*(NR+1) + IDMI=IZ*NX*NY*(NR+1)+(NY-IX-1)*NX*(NR+1)+ + > (NX-IY-1)*(NR+1) + DO 833 IR=0,NR + IMIX2(ITMI+1)=IMIX(IDMI+1) + ITMI=ITMI+1 + IDMI=IDMI+1 + 833 CONTINUE + 832 CONTINUE + 831 CONTINUE + 830 CONTINUE + ENDIF + ENDIF +C---- +C PRINT TURNED MESH +C---- + IF(IPRT .GE. 20) THEN + WRITE(IOUT,6010) IKT(IG) + WRITE(IOUT,6002) 'MESHX =' + WRITE(IOUT,6003) (TMESH(IG,1,IX),IX=0,NX) + WRITE(IOUT,6002) 'SPLTX =' + WRITE(IOUT,6004) (ISPLT(IG,1,IX),IX=0,NX-1) + WRITE(IOUT,6002) 'MESHY =' + WRITE(IOUT,6003) (TMESH(IG,2,IY),IY=0,NY) + WRITE(IOUT,6002) 'SPLTY =' + WRITE(IOUT,6004) (ISPLT(IG,2,IY),IY=0,NY-1) + WRITE(IOUT,6002) 'MESHZ =' + WRITE(IOUT,6003) (TMESH(IG,3,IZ),IZ=0,NZ) + WRITE(IOUT,6002) 'SPLTZ =' + WRITE(IOUT,6004) (ISPLT(IG,3,IZ),IZ=0,NZ-1) + WRITE(IOUT,6002) 'MIXT =' + WRITE(IOUT,6004) (IMIX2(IX),IX=1,NK) + WRITE(IOUT,6002) 'OFFC =' + WRITE(IOUT,6003) (OFFTR(IX,IG),IX=1,3) + ENDIF + 1000 CONTINUE +C---- +C COMPARE GEOMETRY +C 1- MESH AND SPLIT IN X, Y AND Z +C 2- MIXTURES +C 3- OFFCENTER +C---- + DO 900 IDIR=1,3 + IF(NTM(1,IDIR) .EQ. NTM(2,IDIR)) THEN + DO 910 IX=0,NTM(1,IDIR)-1 + DDD=ABS(TMESH(2,IDIR,IX)-TMESH(1,IDIR,IX)) + IF(DDD .GT. 1.0D-6*ABS(DDM(IDIR)) .OR. + > ISPLT(2,IDIR,IX) .NE. ISPLT(1,IDIR,IX) ) THEN + WRITE(IOUT,6020) IDIR,IX, + > ISPLT(1,IDIR,IX),ISPLT(2,IDIR,IX), + > TMESH(1,IDIR,IX),TMESH(2,IDIR,IX),DDD + LELCSY=.FALSE. + GO TO 995 + ENDIF + 910 CONTINUE + ELSE + LELCSY=.FALSE. + GO TO 995 + ENDIF + 900 CONTINUE + DO 920 IX=1,NK + IF(IM1(IX) .NE. IM2(IX) ) THEN + LELCSY=.FALSE. + WRITE(IOUT,6021) IX,IM1(IX),IM2(IX) + GO TO 995 + ENDIF + 920 CONTINUE + IF(OFFTR(1,1) .NE. OFFTR(1,2) .OR. + > OFFTR(2,1) .NE. OFFTR(2,2) .OR. + > OFFTR(3,1) .NE. OFFTR(3,2) ) THEN + LELCSY=.FALSE. + GO TO 995 + ENDIF + 995 CONTINUE +C---- +C RELEASE MEMORY +C---- + DEALLOCATE(IM2,IM1,IMIX) + IF(GEOCV .NE. ' ') THEN + CALL LCMSIX(IPGEOM,GEOCV,2) + ENDIF +C---- +C RETURN +C---- + RETURN +C---- +C FORMATS +C---- + 6000 FORMAT(1X,A6,'-- ANALYZING :',A12,2I10) + 6001 FORMAT(1X,' DIMENSIONS =',5I10/1X,' ORIGINAL MESH ') + 6002 FORMAT(1X,A7) + 6003 FORMAT(5F15.9) + 6004 FORMAT(5I15) + 6010 FORMAT(1X,' GEOMETRY AFTER TURN = ',I10) + 6020 FORMAT(1X,'ERROR FOR DIRECTION ',2I10/ + > 1X,'SPLIT = ',2I10/ + > 1X,'MESH = ',3F15.9) + 6021 FORMAT(1X,'ERROR FOR MIXTURE ',I10,2I10) + END diff --git a/Dragon/src/LHXUNH.f b/Dragon/src/LHXUNH.f new file mode 100644 index 0000000..9e61ec1 --- /dev/null +++ b/Dragon/src/LHXUNH.f @@ -0,0 +1,1502 @@ +*DECK LHXUNH + SUBROUTINE LHXUNH(IPTRK,IPGEOM,GEONAM,MESH,NCELA,IPLANZ,NCPHY, + + ICODE,ZCODE,MVOSU,NREGIO,ISURF,SIDE,ISTATE,NSMIN, + + NSMAX,MVOLUM,IHEX,LX,MCODE,IPLANI,VLAT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read and analyse hexagonal geometry. +* +*Copyright: +* Copyright (C) 1991 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): M. Ouisloumen +* +*Parameters: input +* IPTRK pointer to tracking. +* IPGEOM pointer to geometry. +* GEONAM name of geometry +* +*Parameters: output +* ISURF number of surfaces. +* SIDE side of hexagone. +* ISTATE state vector. +* NSMIN surface minimum index. +* NSMAX surface maximum index. +* MVOLUM volume maximum index. +* IHEX flag for hexagonal geometry (=1 if geometry hexagonal). +* LX number of hexagones. +* MESH dimension of array REMESH for mesh storage. +* NCELA number of cells in assembly after unfolding. +* IPLANZ number of Z planes. +* NCPHY number of physical cells. +* ICODE albedo indices. +* ZCODE geometric albedos. +* NREGIO number of physical regions. +* MVOSU number of volumes ans surfaces. +* MCODE =1 if NCODE(5)=5 ,=2 if NCODE(6)=5 ,=0 otherwise. +* IPLANI plane identifier. +* VLAT lattice indices for surface and volumes. +* +*----------------------------------------------------------------------- +* + USE GANLIB + PARAMETER(NLCM=25,NSTATE=40,NIXS=9,NIST=2) + TYPE(C_PTR) IPTRK,IPGEOM + INTEGER LNLCM(NLCM),INVLCM(NIXS),INVSTA(NIST),ISTATE(NSTATE), + + NCODE(6),ICODE(6),JCODE(6),ISTOR(8),VLAT(*) + REAL ZCODE(6) + LOGICAL L1CELL,LGMERG,LGTURN,LSPLIT,LGCELL,LGSYM,LGSIDE,LGPASS + LOGICAL LMERG1,LTURN1 + CHARACTER LCMNM(NLCM)*12,GEONAM*12,TEXT12*12 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IGG,IAA,SURL,JNR1,JCEL, + + ISECT,LSECT,ISP,ISZ,IBB,ICC,JSS,ISEC1,IXXX,ISS,ISSS,ICELL,IDD, + + IAD + REAL, ALLOCATABLE, DIMENSION(:) :: ZZZ,ZMZZ,ZZS,AQ,RR + TYPE PP + INTEGER, POINTER, DIMENSION(:) :: ILOCR + END TYPE PP + TYPE(PP), ALLOCATABLE, DIMENSION(:) :: JNR2,ISEC2 +*---- +* DATA STATEMENTS +*---- + DATA INVLCM,INVSTA /2,3,7,8,12,15,16,17,18,4,13/ + DATA ISTOR /12,6,6,4,3,2,2,2/ + DATA LCMNM / 'MIX', 'MESHX', 'MESHY', 'MESHZ', 'RADIUS', + > 'SIDE', 'SPLITX', 'SPLITY', 'SPLITZ', 'SPLITR', + > 'CELL', 'COORD', 'MERGE', 'TURN', 'CLUSTER', + > 'NPIN', 'RPIN', 'APIN', 'BIHET', 'POURCE', + > 'PROCEL', 'IHEX', 'NCODE', 'ZCODE', 'ICODE'/ +* + IFCOUR(N)=NINT( (4.+SQRT(1.+4.*FLOAT(N-1)/3.) + + +SQRT(1.+4.*FLOAT(N-2)/3.))*.25) + IFONC(N,L)= 2+(N-1)*(L+3*(N-2)) +* + LGSYM=.FALSE. + LGMERG=.FALSE. + LGTURN=.FALSE. + L1CELL=.FALSE. + LSPLIT=.FALSE. + LGCELL=.FALSE. + MCODE=0 + NRAY=0 + KRAY=0 + KSECT=0 + IPLANI=0 +* +* LECTURE DES DIFFERENTS BLOCS SUR LCM +* + DO 10 I=1,NLCM + CALL LCMLEN(IPGEOM,LCMNM(I),LNLCM(I),ITP) + 10 CONTINUE +* +* ELEMINATES OPTIONS NOT CHECKED BY THIS ROUTINE +* + DO 20 I=1,NIXS + IF(LNLCM(INVLCM(I)).NE.0) + + CALL XABORT('LHXUNH : '//GEONAM//' WAS NOT UNFOLDED ') + 20 CONTINUE +* + CALL LCMLEN(IPGEOM,'STATE-VECTOR',ILEN,ITP) + IF(ITP.NE.1.OR.ILEN.NE.NSTATE) + + CALL XABORT('LHXUNH : INVALID STATE VECTOR ') + ISTATE(:NSTATE)=0 + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) +* +* ELEMINATES THE INVALID OPTIONS +* + DO 30 IST=1, NIST + IF(ISTATE(INVSTA(IST)).NE.0) + + CALL XABORT('LHXUNH : '//GEONAM//'WAS NOT UNFOLDED') + 30 CONTINUE + ITYPE=ISTATE(1) + LX=ISTATE(3) + LZ=ISTATE(5) + LZZ=LZ + LREG=ISTATE(6) + ISTAT9=ISTATE(9) + IF(ISTATE(8).EQ.1)LGCELL=.TRUE. + IF(ISTATE(10).EQ.1)LGMERG=.TRUE. + IF(ISTATE(11).EQ.1)LSPLIT=.TRUE. + NDIM=2 + NCEL=LX + IPLANZ=1 + IF(LZ.NE.0) THEN + NCEL=LX*LZ + NDIM=3 + NCELP=LX + IPLANZ=LZ + ENDIF + IF(LX.EQ.1)L1CELL=.TRUE. + IF(LGCELL)THEN + IF(L1CELL) THEN + IF(ITYPE.NE.8.AND.ITYPE.NE.9.AND.ITYPE.NE.24.AND.ITYPE.NE.25) + + CALL XABORT('LHXUNH : INVALID TYPE OF GEOMETRY') + ELSE + IF(ITYPE.NE.8.AND.ITYPE.NE.9) + + CALL XABORT('LHXUNH : INVALID TYPE OF GEOMETRY') + ENDIF + ELSE + IF(ITYPE.NE.8.AND.ITYPE.NE.9.AND.ITYPE.NE.24.AND.ITYPE.NE.25) + + CALL XABORT('LHXUNH : INVALID TYPE OF GEOMETRY') + ENDIF +* +* RECOVERS BOUDARY CONDITIONS +* + CALL LCMGET(IPGEOM,'NCODE',NCODE) + CALL LCMGET(IPGEOM,'ZCODE',ZCODE) + CALL LCMGET(IPGEOM,'ICODE',JCODE) + DO 35 I=1,6 + IF( JCODE(I).GT.0 )THEN + ICODE(I)= JCODE(I) + ELSE + ICODE(I)= -I + ENDIF + IF( NCODE(I).EQ.0 )THEN + IF( NDIM.EQ.3.AND.(I.EQ.5.OR.I.EQ.6) )THEN + CALL XABORT('LHXUNH : A BOUNDARY CONDITION IS MISSING') + ENDIF + IF( I.EQ.1 )THEN + CALL XABORT('LHXUNH : A BOUNDARY CONDITION IS MISSING') + ENDIF + ICODE(I)= 0 + ENDIF + 35 CONTINUE +* +* ELEMINATIONS DES OPTIONS IMCOMPATIBLES +* + DO 40 I=1,6 + IF(NCODE(I).EQ.4.OR.NCODE(I).EQ.7.OR.NCODE(I).EQ.3 .OR. + + (NDIM.EQ.2.AND.NCODE(I).EQ.5) .OR. + + (NDIM.EQ.2.AND.NCODE(I).EQ.10) ) + + CALL XABORT('LHXUNH : INVALID BOUNDARY CONDITION ') + IF((NCODE(5) .EQ. 5 .OR. NCODE(5) .EQ. 10) .AND. + + (NCODE(6) .EQ. 5 .OR. NCODE(6) .EQ. 10)) CALL XABORT( + + 'LHXUNH: UNE SEULE SYMETRIE SELON Z EST VALABLE') + IF(NCODE(5) .EQ. 5 .OR. NCODE(5) .EQ. 10 ) THEN + ZCODE(5)=ZCODE(6) + ICODE(5)=ICODE(6) + ELSEIF(NCODE(6) .EQ.5 .OR. NCODE(6) .EQ. 10) THEN + ZCODE(6)=ZCODE(5) + ICODE(6)=ICODE(5) + ENDIF + 40 CONTINUE + IF(L1CELL) THEN +* +* CAS D'UNE SEULE CELLULE +* + IF(NCODE(5) .EQ. 5 .OR. NCODE(5) .EQ. 10 .OR. + > NCODE(6) .EQ. 5 .OR. NCODE(6) .EQ. 10 ) CALL XABORT( + + 'LHXUNH: THE B.C. SYME FOR ONE CELL IS NOT PERMITTED ') + IF(LGCELL) THEN + CALL LCMLEN(IPGEOM,'CELL',ILEN,ITP) + IF(ILEN.NE.3*ISTAT9.OR.ITP.NE.3) CALL XABORT('LHXUNH: ' + + //'MISSING DIMENSION OR TYPE OF CELL ') + ALLOCATE(JCEL(3*ISTAT9)) + CALL LCMGET(IPGEOM,'CELL',JCEL) + WRITE(TEXT12,'(3A4)') (JCEL(ITC),ITC=1,3) + CALL LCMLEN(IPGEOM,TEXT12,ILEN,ITP) + IF(ILEN.NE.-1.OR.ITP.NE.0) CALL XABORT('LHXUNH: ' + + //'INVALID CELL DATA ') + CALL LCMSIX(IPGEOM,TEXT12,1) + ENDIF + CALL LCMLEN(IPGEOM,'SIDE',ISIDE,ITS) + IF(ISIDE.EQ.0) CALL XABORT('LHXUNH: SIDE NOT FOUND') + IF(ITS.NE.2) CALL XABORT('LHXUNH: SIDE MUST BE REAL') + CALL LCMGET(IPGEOM,'SIDE',SIDE) + CALL LCMLEN(IPGEOM,'RADIUS',ILENR,ITPR) + CALL LCMLEN(IPGEOM,'SECTOR',ILENS,ITPS) + IXX=1 + IF(ILENR.GT.0) IXX=ILENR + ALLOCATE(ISECT(IXX)) + IF(ILENS.GT.0) THEN + IF(ILENS.NE.IXX) + + CALL XABORT('LHXUNH: INVALID SECTOR DIMENSION(1)') + CALL LCMGET(IPGEOM,'SECTOR',ISECT) + ELSE + ISECT(:IXX)=1 + ENDIF + IF(ILENR.GT.0) THEN + IF(ITPR.NE.2)CALL XABORT('LHXUNH: RADIUS MUST BE REAL') + CALL LCMLEN(IPGEOM,'SPLITR',ILENSP,ITPS) + NRAY=ILENR-1 + IF(ILENSP.GT.0) THEN + IF(ILENSP.NE.NRAY) + + CALL XABORT('LHXUNH: INVALID SPLITR DIMENSION') + IF(ITPS.NE.1) CALL XABORT('LHXUNH: SPLITR MUST BE INTEGER') + ALLOCATE(ISP(ILENSP)) + CALL LCMGET(IPGEOM,'SPLITR',ISP) + NRAY=0 + DO 36 J=1,ILENSP + NRAY=NRAY+ABS(ISP(J)) + 36 CONTINUE + IF(ILENS.GT.0) THEN + ALLOCATE(LSECT(NRAY+1)) + MADD=-1 + DO 336 J=1,ILENR-1 + KSECT=ISECT(J) + DO 335 ISPS=1,ISP(J) + MADD=MADD+1 + LSECT(MADD+1)=KSECT + 335 CONTINUE + 336 CONTINUE + LSECT(NRAY+1)=ISECT(ILENR) + DEALLOCATE(ISECT) + ALLOCATE(ISECT(NRAY+1)) + DO 337 J=1,NRAY+1 + ISECT(J)=LSECT(J) + 337 CONTINUE + DEALLOCATE(LSECT) + ENDIF + DEALLOCATE(ISP) + ENDIF + ENDIF +* + ISURF=6 + MVOSU=0 + DO 39 K=1,NRAY+1 + KSECT=ISECT(K) + IF(KSECT.GT.1) THEN + MVOSU=MVOSU+6*(KSECT-1) + ELSE + MVOSU=MVOSU+1 + ENDIF + 39 CONTINUE + DEALLOCATE(ISECT) + IF(KSECT.GT.1) ISURF=6*(KSECT-1) + MVOLUM=1+NRAY + IF(NDIM.EQ.2) THEN + NCELA=1 + NCPHY=1 + MESH=2+NRAY + NREGIO=MVOSU + ELSEIF(NDIM.EQ.3) THEN + CALL LCMLEN(IPGEOM,'MESHZ',LZ,ITZ) + IF(LZ.EQ.0) CALL XABORT('LHXUNH: MESHZ NOT FOUND') + IF(LZ.NE.2) CALL XABORT('LHXUNH: MISSING DIMENSION OF MESHZ') + IF(ITZ.NE.2)CALL XABORT('LHXUNH: MESHZ MUST BE REAL') + ALLOCATE(ZZZ(LZ)) + CALL LCMGET(IPGEOM,'MESHZ',ZZZ) + IF(ZZZ(1).NE.0.) CALL XABORT('LHXUNH: FIRST MESHZ MUST BE 0') + CALL LCMLEN(IPGEOM,'SPLITZ',LSZ,ITSZ) + IF(LSZ.GT.0) THEN + IF(ITSZ.NE.1)CALL XABORT('LHXUNH: SPLITZ MUST BE INTEGER') + IF(LSZ.NE.LZ-1)CALL XABORT('LHXUNH: WRONG SPLITZ DIMENSION') + ALLOCATE(ISZ(LSZ)) + CALL LCMGET(IPGEOM,'SPLITZ',ISZ) + CALL LCMSIX(IPTRK,'DATA_DUP',1) + CALL LCMPUT(IPTRK,'SPLITZD',LSZ,1,ISZ) + CALL LCMSIX(IPTRK,' ',2) + MZ=ISZ(1)+1 + ALLOCATE(ZMZZ(MZ)) + KSP=ISZ(1) + PAS=(ZZZ(2)-ZZZ(1))/FLOAT(KSP) + ZMZZ(1)=0.0 + DO 37 K=1,KSP + ZMZZ(K+1)=PAS*FLOAT(K)+ZZZ(1) + 37 CONTINUE + DEALLOCATE(ISZ) + ELSE + MZ=LZ + ALLOCATE(ZMZZ(MZ)) + DO 38 J=1,MZ + ZMZZ(J)=ZZZ(J) + 38 CONTINUE + ENDIF + DEALLOCATE(ZZZ) + CALL LCMSIX(IPTRK,'DATA_DUP',1) + CALL LCMPUT(IPTRK,'MESHZ',MZ,2,ZMZZ) + CALL LCMSIX(IPTRK,' ',2) + DEALLOCATE(ZMZZ) + IPLANZ=MZ-1 + ISTATE(5)=IPLANZ + NCELA=MZ-1 + ISURF=NCELA*ISURF + NCPHY=MZ-1 + MESH=NCELA*(3+NRAY) + NSMIN=MVOSU + NSMAX=MVOSU + MVOSU=NCELA*MVOSU + MVOLUM=NCELA*MVOLUM + NREGIO=MVOSU + ENDIF + NCOUR=1 + ISURF=ISURF+NSMIN+NSMAX + RETURN + ENDIF +* +* TYPE DE LA SYMETRIE CONSIDEREE +* + CALL LCMLEN(IPGEOM,'IHEX',ILEN,ITP) + IF(ITP.NE.1.OR.ILEN.NE.1)CALL XABORT('LHXUNH: TYPE OF '// + + 'SYMETRIE MUST BE INTEGER') + CALL LCMGET(IPGEOM,'IHEX',IHEX) + IF(IHEX.LT.1.OR.IHEX.GT.9) CALL XABORT('LHXUNH: INVALID TYPE OF ' + + //'SYMETRIE') + IF(NDIM.EQ.2) THEN +* +* TRAITEMENT DE LA GEOMETRIE EN 2D +* + NCELA=NCEL + NCELAP=NCEL +* +* DUPLICATION DE LA SYMETRIE CONSIDEREE +* + IF(IHEX.LT.9) THEN + ALLOCATE(IBB(ISTOR(IHEX)*NCEL)) + CALL DEPLIT(IHEX,NCEL,NCELA,IBB) + NCELAP=NCELA + ELSE + ALLOCATE(IBB(NCEL)) + DO 137 I=1,NCEL + IBB(I)=I + 137 CONTINUE + ENDIF + CALL LCMLEN(IPGEOM,'MIX',ILENX,ITPX) + IF(ILENX.NE.NCEL.OR.ITPX.NE.1) THEN + CALL XABORT('LHXUNH: MISSING TYPE OR DIMENSION OF MIX') + ENDIF + NBASE=NCEL+NCELA + CALL LCMLEN(IPGEOM,'TURN',ILENT,ITP) + IF(ILENT.GT.0) THEN + IF(ILENT.NE.NCEL)CALL XABORT('LHXUNH: EXPECTED DIMENSION'// + + 'OF TURN') + IF(ITP.NE.1)CALL XABORT('LHXUNH: EXPECTED VALUE IN TURN ') + LGTURN=.TRUE. + ENDIF + NBASE=NBASE*2 + NBASE=NBASE+NCEL+NCELA + ALLOCATE(ICC(NBASE)) + NBB=2*NCEL + IF(LGCELL) THEN + CALL LCMGET(IPGEOM,'MIX',ICC) + ICMAX=-1 + DO 147 IGX=1,NCEL + ICC(IGX)=-ICC(IGX) + ICMAX=MAX(ICMAX,ICC(IGX)) + 147 CONTINUE + IF(ISTAT9.GT.ICMAX)CALL XABORT('LHXUNH: THERE ARE DEFINED' + + //' CELLS NOT USED IN THE ASSEMBLY') + ELSE + CALL LCMGET(IPGEOM,'MIX',ICC) + ENDIF + IF(LGMERG) THEN + CALL LCMLEN(IPGEOM,'MERGE',IAUXN,ITAUX) + IF(IAUXN.NE.NCEL.OR.ITAUX.NE.1)CALL XABORT('LHXUNH: DIMEN' + + //'SION OR TYPE OF MERGE INVALID') + CALL LCMGET(IPGEOM,'MERGE',ICC(NCEL+1)) + NCPHY=0 + DO 42 I=1,NCEL + NCPHY=MAX(NCPHY,ICC(NCEL+I)) + 42 CONTINUE + ELSE + DO 146 I=1,NCEL + ICC(NCEL+I)=ICC(I) + 146 CONTINUE + LGMERG=.TRUE. + NCPHY=NCEL + ENDIF + IF(LGTURN) THEN + CALL LCMLEN(IPGEOM,'TURN',IAUXN,ITAUX) + IF(IAUXN.NE.NCEL.OR.ITAUX.NE.1)CALL XABORT('LHXUNH: DIMEN' + + //'SION OR TYPE OF TURN INVALID') + CALL LCMGET(IPGEOM,'TURN',ICC(NBB+1)) + ELSE + LGTURN=.TRUE. + DO 777 ITT=1,NCEL + ICC(NBB+ITT)=1 + 777 CONTINUE + ENDIF + NBB=NBB+NCEL +* +* DUPLICATION DE MERGE ET MIX +* + DO 47 I=1,NCELA + ICC(NBB+I)=ICC(IBB(I)) + ICC(NBB+NCELA+I)=ICC(IBB(I)+NCEL) + 47 CONTINUE +* +* CAS OU SIDE EST ENTREE UNE SEULE FOIS +* + LGSIDE=.TRUE. + CALL LCMLEN(IPGEOM,'SIDE',ISIDE,IT) + IF(ISIDE.GT.0) THEN + CALL LCMGET(IPGEOM,'SIDE',SIDE) + LGSIDE=.FALSE. + ELSEIF(.NOT.LGCELL) THEN + CALL XABORT('LHXUNH: SIDE NOT FOUND ') + ENDIF +* +* EVALUATION DE MESH +* + MESH=2*NCELA + NCOUR=1 + IF(NCELAP.GT.1)NCOUR=IFCOUR(NCELAP) + ICELC0= IFONC(NCOUR,0) + ICELC1= IFONC(NCOUR,1)-ICELC0 + IF(LGCELL) THEN + ALLOCATE(JNR1(ISTAT9),JNR2(ISTAT9),JCEL(3*ISTAT9)) + CALL LCMGET(IPGEOM,'CELL',JCEL) + NREGIO=0 + DO 48 I=1,ISTAT9 + IRTC=3*I-2 + WRITE(TEXT12,'(3A4)') (JCEL(ITC),ITC=IRTC,IRTC+2) + CALL LCMSIX(IPGEOM,TEXT12,1) + CALL LCMLEN(IPGEOM,'RADIUS',ILENR,ITP) + CALL LCMLEN(IPGEOM,'SPLITR',ILENSP,ITP) + IF(LGSIDE) THEN + CALL LCMLEN(IPGEOM,'SIDE',ISIDE,IT) + IF(ISIDE.EQ.0)CALL XABORT('LHXUNH: SIDE NOT FOUND') + CALL LCMGET(IPGEOM,'SIDE',SSIDE) + IF(I.GT.1) THEN + IF(SSIDE.NE.SIDE)CALL XABORT('LHXUNH: INCOMPATIBLE SIDE') + ENDIF + SIDE=SSIDE + ENDIF + NRAY=ILENR + IF(ILENR.GT.0)NRAY=ILENR-1 + IF(ILENSP.GT.0) THEN + ALLOCATE(JSS(ILENSP)) + CALL LCMGET(IPGEOM,'SPLITR',JSS) + NRAY=0 + DO 46 J=1,ILENSP + NRAY=NRAY+ABS(JSS(J)) + 46 CONTINUE + DEALLOCATE(JSS) + ENDIF + JNR1(I)=NRAY + ALLOCATE(JNR2(I)%ILOCR(NRAY+1)) + CALL LCMLEN(IPGEOM,'SECTOR',ILENS,ITPS) + IF(ILENS.GT.0) THEN + IF(ILENS.NE.NRAY+1) + + CALL XABORT('LHXUNH: INVALID SECTOR DIMENSION(2)') + CALL LCMGET(IPGEOM,'SECTOR',JNR2(I)%ILOCR) + ELSE + JNR2(I)%ILOCR(:NRAY+1)=1 + NREGIO=NREGIO+1+NRAY + GOTO 430 + ENDIF + DO 43 K=1,NRAY+1 + KSECT=JNR2(I)%ILOCR(K) + IF(KSECT.GT.1) THEN + NREGIO=NREGIO+6*(KSECT-1) + ELSE + NREGIO=NREGIO+1 + ENDIF + 43 CONTINUE + 430 CONTINUE + CALL LCMSIX(IPGEOM,' ',2) + 48 CONTINUE + DEALLOCATE(JCEL) + NRAY=0 + MVOSU=0 + MVOLUM=0 + ISURF=0 + DO 49 I=1,NCELA + KRAY=JNR1(ICC(NBB+I)) + NRAY=NRAY+KRAY + DO 490 JR=1,KRAY+1 + KSECT=JNR2(ICC(NBB+I))%ILOCR(JR) + IF(KSECT.GT.1) THEN + MVOSU=MVOSU+6*(KSECT-1) + ELSE + MVOSU=MVOSU+1 + ENDIF + 490 CONTINUE + IF(I.GE.ICELC0) THEN + IF(KSECT.GT.1) THEN + ISURF=ISURF+2*(KSECT-1) + IF(MOD(I-ICELC0,ICELC1).EQ.0) ISURF=ISURF+KSECT-1 + ELSE + ISURF=ISURF+2 + IF(MOD(I-ICELC0,ICELC1).EQ.0) ISURF=ISURF+1 + ENDIF + ENDIF + MVOLUM=MVOLUM+KRAY+1 + 49 CONTINUE + MESH=NRAY+MESH + DO 495 I=1,ISTAT9 + DEALLOCATE(JNR2(I)%ILOCR) + 495 CONTINUE + DEALLOCATE(JNR2,JNR1) + ELSE + CALL LCMLEN(IPGEOM,'SECTOR',ILENS,ITP) + NREGIO=NCPHY + MVOSU=NCELA + MVOLUM=NCELA + ALLOCATE(IXXX(NCEL)) + IF(ILENS.GT.0) THEN + IF(ILENS.NE.NCEL) + + CALL XABORT('LHXUNH: INVALID SECTOR DIMENSION(3)') + CALL LCMGET(IPGEOM,'SECTOR',IXXX) + ELSE + IXXX(:NCEL)=1 + ENDIF + ILESS=0 + NREGIO=0 + DO 50 L=1,ILENS + MCEL=ICC(L) + IF(MCEL.GT.ILESS) THEN + ILESS=MCEL + KSECT=IXXX(L) + IF(KSECT.GT.1) THEN + NREGIO=NREGIO+6*(KSECT-1) + ELSE + NREGIO=NREGIO+1 + ENDIF + ENDIF + 50 CONTINUE + MVOSU=0 + ISURF=0 + DO 51 I=1,NCELA + KSECT=IXXX(ICC(NBB+I)) + IF(KSECT.GT.1) THEN + MVOSU=MVOSU+6*(KSECT-1) + IF(I.GE.ICELC0) THEN + ISURF=ISURF+2*(KSECT-1) + IF(MOD(I-ICELC0,ICELC1).EQ.0) ISURF=ISURF+KSECT-1 + ENDIF + ELSE + MVOSU=MVOSU+1 + IF(I.GE.ICELC0) THEN + ISURF=ISURF+2 + IF(MOD(I-ICELC0,ICELC1).EQ.0) ISURF=ISURF+1 + ENDIF + ENDIF + 51 CONTINUE + DEALLOCATE(IXXX) + ENDIF +* +* DUPLICATION DE TURN +* + MBB=2*NCELA + IF(LGTURN) THEN + IF (IHEX.LT.9) THEN + CALL DUTURN(IHEX,ICC(NBB-NCEL+1),NCEL,ICC(NBB+MBB+1), + + NCELA,IBB) + ELSE + DO 187 I=1,NCELA + ICC(NBB+MBB+I)=ICC(NBB-NCEL+I) + 187 CONTINUE + ENDIF + ENDIF +* +* RESTORAGE DES DONNEES +* + CALL LCMSIX(IPTRK,'DATA_DUP',1) +* +*--- CE VECTEUR EST UTILE DANS LA ROUTINE MESHST + CALL LCMPUT(IPTRK,'GENER0',NCELA,1,IBB) + IF(LGCELL) THEN + CALL LCMPUT(IPTRK,'GENERATING',NCELA,1,ICC(NBB+1)) + ELSE + CALL LCMPUT(IPTRK,'MIX',NCELA,1,ICC(NBB+1)) + ENDIF + IF(LGMERG) + + CALL LCMPUT(IPTRK,'MERGE',NCELA,1,ICC(NCELA+NBB+1)) + IF(LGTURN) + + CALL LCMPUT(IPTRK,'TURN',NCELA,1,ICC(NBB+MBB+1)) + CALL LCMSIX(IPTRK,' ',2) + DEALLOCATE(IBB,ICC) +* + ELSEIF(NDIM.EQ.3) THEN +* +* TRAITEMENT DU CAS 3D +* + NCELA=NCEL + CALL LCMLEN(IPGEOM,'MIX',ILENX,ITPX) + IF(ILENX.NE.NCEL.OR.ITPX.NE.1) CALL XABORT('LHXUNH: MISSING' + + //'VECTOR MIX') + NBASE=NCEL + CALL LCMLEN(IPGEOM,'TURN',ILENT,ITPT) + IF(ILENT.GT.0)THEN + IF(ILENT.NE.NCEL.OR.ITPT.NE.1) CALL XABORT('LHXUNH: MISSING' + + //'VECTOR TURN') + LGTURN=.TRUE. + ENDIF + NBASE=NCEL+NCEL + NBASE=NCEL+NBASE + ALLOCATE(ICC(NBASE)) + CALL LCMGET(IPGEOM,'MIX',ICC) + IF(LGCELL) THEN + DO 144 IGX=1,NCEL + ICC(IGX)=-ICC(IGX) + 144 CONTINUE + ENDIF + NBB=NCEL+NCEL + LMERG1=.FALSE. + LTURN1=.FALSE. + IF(LGMERG) THEN + CALL LCMGET(IPGEOM,'MERGE',ICC(NCEL+1)) + NCPHY=0 + DO 52 I=1,NCEL + NCPHY=MAX(NCPHY,ICC(NCEL+I)) + 52 CONTINUE + LMERG1=.TRUE. + ELSE + DO 53 I=1,NCEL + ICC(I+NCEL)=ICC(I) + 53 CONTINUE + LGMERG=.TRUE. + NCPHY=NCEL + ENDIF + IF(LGTURN) THEN + CALL LCMGET(IPGEOM,'TURN',ICC(NBB+1)) + LTURN1=.TRUE. + ELSE + LGTURN=.TRUE. + DO 778 ITT=1,NCEL + ICC(NBB+ITT)=1 + 778 CONTINUE + ENDIF + NBB=NBB+NCEL +* +* SPLITING DE LA DIRECTION Z +* + CALL LCMLEN(IPGEOM,'MESHZ',ILENZ,ITPZ) + IF(LGCELL.OR.IPLANZ.GT.1) THEN + IF(ILENZ.NE.0)CALL XABORT('LHXUNH: INVALID POSITION OF MESHZ') + ENDIF + IF(ILENZ.GT.0) THEN + IF(ILENZ.NE.LZ+1.OR.ITPZ.NE.2)CALL XABORT('LHXUNH: MISSING' + + //'DIMENSION OR VALUE IN MESHZ') + ALLOCATE(ZZZ(ILENZ)) + CALL LCMGET(IPGEOM,'MESHZ',ZZZ) + MZ=ILENZ + ENDIF +* +* EVALUATION DE NREGIO +* + NREGIO=NCPHY + CALL LCMLEN(IPGEOM,'SECTOR',ILENS,ITP) + IF(LGCELL.OR.IPLANZ.GT.1) THEN + IF(ILENS.NE.0)CALL XABORT('LHXUNH: INVALID POSITION OF SECTOR') + ENDIF + IF(ILENS.GT.0) THEN + IF(ILENS.NE.NCEL)CALL XABORT('LHXUNH: INVALID DIMENSION OF' + + //'SECTOR') + IF(ITP.NE.1)CALL XABORT('LHXUNH: SECTOR MUST BE INTEGER') + ALLOCATE(ISEC1(ILENS)) + ILESS=0 + NREGIO=0 + CALL LCMGET(IPGEOM,'SECTOR',ISEC1) + DO 54 L=1,ILENS + MCEL=ICC(L) + IF(MCEL.GT.ILESS) THEN + ILESS=MCEL + KSECT=ISEC1(L) + IF(KSECT.GT.1) THEN + NREGIO=NREGIO+6*(KSECT-1) + ELSE + NREGIO=NREGIO+1 + ENDIF + ENDIF + 54 CONTINUE + ENDIF +* + CALL LCMLEN(IPGEOM,'SPLITZ',ILEN,ITP) + IF(ILEN.NE.0) THEN + IF(ILEN.NE.LZ)CALL XABORT('LHXUNH: INVALID DIMENSION OF' + + //'SPLITZ') + IF(ILENZ.LT.0)CALL XABORT('LHXUNH: MESHZ MUST BE DEFINED' + + //'LIKE SPLITZ') + ALLOCATE(ISS(LZ)) + CALL LCMGET(IPGEOM,'SPLITZ',ISS) + CALL LCMSIX(IPTRK,'DATA_DUP',1) + CALL LCMPUT(IPTRK,'SPLITZD',LZ,1,ISS) + CALL LCMSIX(IPTRK,' ',2) + MZ=0 + DO 55 K=1,LZ + MZ=MZ+ISS(K) + 55 CONTINUE + LSPLIT=.TRUE. + ELSEIF(LGCELL) THEN + CALL LCMLEN(IPGEOM,'CELL',ILEN,ITP) + IF(ILEN.NE.3*ISTAT9.OR.ITP.NE.3)CALL XABORT('LHXUNH: ' + + //'MISSING DIMENSION OR TYPE OF CELL ') + ALLOCATE(ICELL(3*ISTAT9),RR(3*ISTAT9),ISSS(ISTAT9)) + CALL LCMGET(IPGEOM,'CELL',ICELL) + ALLOCATE(ISEC1(ISTAT9),ISEC2(ISTAT9)) + IAUX=0 + NREGIO=0 + DO 70 I=1,ISTAT9 + WRITE(TEXT12(1:4),'(A4)')ICELL(3*I-2) + WRITE(TEXT12(5:8),'(A4)')ICELL(3*I-1) + WRITE(TEXT12(9:12),'(A4)')ICELL(3*I) + CALL LCMSIX(IPGEOM,TEXT12,1) + CALL LCMGET(IPGEOM,'MESHZ',RR(IAUX+1)) + CALL LCMGET(IPGEOM,'SIDE',RR(2*ISTAT9+I)) + IAUX=IAUX+2 + CALL LCMLEN(IPGEOM,'SPLITZ',ILEN,ITP) + ISSS(I)=1 + IF(ILEN.NE.0) THEN + IF(ITP.NE.1)CALL XABORT('LHXUNH: INVALID TYPE OF SPLITZ') + CALL LCMGET(IPGEOM,'SPLITZ',ISSS(I)) + LSPLIT=.TRUE. + ENDIF + CALL LCMLEN(IPGEOM,'RADIUS',ILENR,ITP) + CALL LCMLEN(IPGEOM,'SPLITR',ILENSP,LT) + NRAY=0 + NSECT=1 + IF(ILENR.GT.0) THEN + IF(ITP.NE.2)CALL XABORT('LHXUNH: RADIUS MUST BE REAL ') + NRAY=ILENR-1 + NSECT=ILENR + ENDIF + CALL LCMLEN(IPGEOM,'SECTOR',ILENS,ITP) + ALLOCATE(ISECT(NSECT)) + IF(ILENS.GT.0) THEN + IF(ILENS.NE.NSECT) + + CALL XABORT('LHXUNH: INVALID SECTOR DIMENSION(4)') + CALL LCMGET(IPGEOM,'SECTOR',ISECT) + ELSE + ISECT(:NSECT)=1 + ENDIF + IF(ILENSP.GT.0) THEN + IF(LT.NE.1)CALLXABORT('LHXUNH: SPLITR MUST BE INTEGER') + ALLOCATE(JSS(ILENSP)) + CALL LCMGET(IPGEOM,'SPLITR',JSS) + NRAY=0 + DO 246 JP=1,ILENSP + NRAY=NRAY+ABS(JSS(JP)) + 246 CONTINUE + ALLOCATE(ISEC2(I)%ILOCR(NRAY+1)) + MAD=-1 + DO 248 JP=1,ILENS + KSECT=ISECT(JP) + DO 247 JT=1,JSS(JP) + MAD=MAD+1 + ISEC2(I)%ILOCR(MAD+1)=KSECT + 247 CONTINUE + 248 CONTINUE + ISEC2(I)%ILOCR(MAD+2)=ISECT(ILENS+1) + DEALLOCATE(JSS) + ELSE + ALLOCATE(ISEC2(I)%ILOCR(NRAY+1)) + DO 249 JP=1,NSECT + ISEC2(I)%ILOCR(JP)=ISECT(JP) + 249 CONTINUE + ENDIF + DEALLOCATE(ISECT) + ISEC1(I)=NRAY + DO 255 K=1,NRAY+1 + KSECT=ISEC2(I)%ILOCR(K) + IF(KSECT.GT.1) THEN + NREGIO=NREGIO+6*(KSECT-1) + ELSE + NREGIO=NREGIO+1 + ENDIF + 255 CONTINUE + CALL LCMSIX(IPGEOM,' ',2) + 70 CONTINUE + DEALLOCATE(ICELL) +* +* COMPATIBILITE DES DONNEES DES CELLULES D'UN MEME PLAN +* + LZZ=LZ + IAUX=0 + LISP=0 + ALLOCATE(ISS(ISTAT9),ZZZ(LZ+1)) + MZZ=0 + DO 80 I=1,LZ + SIDE=RR(2*ISTAT9+ICC(IAUX+1)) + LCC=2*(ICC(IAUX+1)-1) + Z1=RR(LCC+1) + Z2=RR(LCC+2) + ZZZ(I)=Z1 + ZZZ(I+1)=Z2 + IF(LSPLIT) THEN + LISP=ISSS(ICC(IAUX+1)) + ISS(I)=LISP + MZZ=MZZ+LISP + LZZ=MZZ + ENDIF + DO 75 K=2,NCELP + IAUX=IAUX+1 + IF(SIDE.NE.RR(2*ISTAT9+ICC(IAUX+1))) + + CALL XABORT('LHXUNH: INCOMPATIBLE SIDE ') + LCC=2*(ICC(IAUX+1)-1) + IF((Z1.NE.RR(LCC+1)).OR.(Z2.NE.RR(LCC+2))) + + CALL XABORT('LHXUNH: INCOMPATIBLE MESHZ ') + IF(LSPLIT) THEN + IF(LISP.NE.ISSS(ICC(IAUX+1))) + + CALL XABORT('LHXUNH: INCOMPATIBLE SPLITZ') + ENDIF + 75 CONTINUE + IAUX=IAUX+1 + 80 CONTINUE + DEALLOCATE(RR,ISSS) + MZ=LZ+1 + IF(LSPLIT)MZ=MZZ+1 + ENDIF + ALLOCATE(ZZS(MZ)) + IF(LSPLIT) THEN + LAUX=0 + Z1=ZZZ(1) + ZZS(1)=Z1 + DO 83 K=1,LZ + MSP=ISS(K) + Z2=ZZZ(K+1) + PAS=(Z2-Z1)/REAL(MSP) + DO 81 L=1,MSP-1 + LAUX=LAUX+1 + ZZS(LAUX+1)=Z1+PAS*REAL(L) + 81 CONTINUE + LAUX=LAUX+1 + ZZS(LAUX+1)=Z2 + Z1=Z2 + 83 CONTINUE + ELSE + DO 88 J=1,MZ + ZZS(J)=ZZZ(J) + 88 CONTINUE + ENDIF + DEALLOCATE(ZZZ) +* +* STORAGE DES VALEURS DE Z +* + CALL LCMSIX(IPTRK,'DATA_DUP',1) + LSPLZM=1 + LSPLZP=1 + IF(LSPLIT) THEN + LSPLZM=ISS(1) + LSPLZP=ISS(LZ) + CALL LCMPUT(IPTRK,'SPLITZD',LZ,1,ISS) + ENDIF + IF(NCODE(5) .EQ. 5 .OR. NCODE(5) .EQ. 10) THEN + IF(NCODE(5) .EQ. 5) THEN + MDZ=2*MZ-1-LSPLZM + IOFZD=2+LSPLZM + ELSE + MDZ=2*MZ-1 + IOFZD=2 + ENDIF + ALLOCATE(AQ(MDZ)) + IQ=0 + DO 583 IW=MZ,IOFZD,-1 + AQ(IQ+1)=-ZZS(IW)+ZZS(1)+ZZS(2) + IQ=IQ+1 + 583 CONTINUE + DO 584 IW=1,MZ + AQ(IQ+1)=ZZS(IW) + IQ=IQ+1 + 584 CONTINUE + CALL LCMPUT(IPTRK,'MESHZ',MDZ,2,AQ) + DEALLOCATE(AQ) + ELSEIF(NCODE(6) .EQ. 5 .OR. NCODE(6) .EQ. 10) THEN + IF(NCODE(6) .EQ. 5) THEN + MDZ=2*MZ-LSPLZP-1 + IOFZD=LSPLZP+1 + ELSE + MDZ=2*MZ-1 + IOFZD=1 + ENDIF + ALLOCATE(AQ(MDZ)) + IQ=0 + DO 585 IW=1,MZ + AQ(IQ+1)=ZZS(IW) + IQ=IQ+1 + 585 CONTINUE + DO 586 IW=MZ-IOFZD,1,-1 + AQ(IQ+1)=AQ(IQ)+ZZS(IW+1)-ZZS(IW) + IQ=IQ+1 + 586 CONTINUE + CALL LCMPUT(IPTRK,'MESHZ',MDZ,2,AQ) + DEALLOCATE(AQ) + ELSE + CALL LCMPUT(IPTRK,'MESHZ',MZ,2,ZZS) + ENDIF + CALL LCMSIX(IPTRK,' ',2) + DEALLOCATE(ZZS) +* + IF(IHEX.LT.9) THEN +* +* DUPLICATION DE LA GEOMETRIE CONSIDEREE +* + ALLOCATE(IBB(ISTOR(IHEX)*NCEL)) + CALL DEPLIT(IHEX,NCELP,NCELAP,IBB) + IAUX=NCELP + JAUX=NCELAP + DO 65 K=2,LZ + DO 60 L=1,NCELAP + IBB(JAUX+L)=IBB(L)+IAUX + 60 CONTINUE + IAUX=IAUX+NCELP + JAUX=JAUX+NCELAP + 65 CONTINUE + ELSEIF(IHEX.EQ.9) THEN + NCELAP=NCELA/LZ + ENDIF + IF(LSPLIT)THEN + NCELA=NCELAP*LZZ + ELSE + NCELA=NCELAP*LZ + ENDIF +* +* DUPLICATION DE MERGE ET MIX +* + NBASE=NCELA+NCELA + IF(LGTURN)NBASE=NBASE+NCELA + ALLOCATE(IDD(NBASE),IAD(NCELA)) + IAUX=-1 + JAUX=0 + ICELSP=0 + MAXSP=0 + MINSP=99999 + DO 85 I=1,LZ + IF(IHEX.LT.9) THEN + MAXSP=IBB(JAUX+1) + MINSP=MAXSP + ENDIF + DO 84 J=1,NCELAP + IAUX=IAUX+1 + IF(IHEX.LT.9) THEN + IAD(IAUX+1)=IBB(JAUX+J)+ICELSP + MAXSP=MAX(MAXSP,IBB(JAUX+J)) + MINSP=MIN(MINSP,IBB(JAUX+J)) + IDD(IAUX+1)=ICC(IBB(JAUX+J)) + IDD(NCELA+IAUX+1)=ICC(NCEL+IBB(JAUX+J)) + ELSE + IAD(IAUX+1)=IAUX+1 + IDD(IAUX+1)=ICC(JAUX+J) + IDD(NCELA+IAUX+1)=ICC(NCEL+JAUX+J) + ENDIF + 84 CONTINUE + IF(LSPLIT) THEN + LISP=ISS(I) + DO 86 K=2,LISP + IF(IHEX.LT.9) ICELSP=ICELSP+MAXSP-MINSP+1 + DO 82 J=1,NCELAP + IAUX=IAUX+1 + IF(IHEX.LT.9) THEN + IAD(IAUX+1)=IBB(JAUX+J)+ICELSP + IDD(IAUX+1)=ICC(IBB(JAUX+J)) + IDD(NCELA+IAUX+1)=ISS(NCEL+IBB(JAUX+J)) + ELSE + IAD(IAUX+1)=IAUX+1 + IDD(IAUX+1)=ICC(JAUX+J) + IDD(NCELA+IAUX+1)=ICC(NCEL+JAUX+J) + ENDIF + 82 CONTINUE + 86 CONTINUE + ENDIF + JAUX=JAUX+NCELAP + 85 CONTINUE +* +* DUPLICATION DE TURN +* + MBB=NCELA+NCELA + IF(LGTURN) THEN + IAUX=2*NCEL + JAUX=0 + DO 95 I=1,LZ + IF(IHEX.LT.9) THEN + CALL DUTURN(IHEX,ICC(IAUX+1),NCELP,IDD(MBB+JAUX+1), + + NCELAP,IBB) + ELSE + DO 87 IV=1,NCELAP + IDD(MBB+JAUX+IV)=ICC(IAUX+IV) + 87 CONTINUE + ENDIF + IAUX=IAUX+NCELP + KAUX=JAUX-1 + JAUX=JAUX+NCELAP + IF(LSPLIT) THEN + LISP=ISS(I) + DO 92 J=2,LISP + DO 90 K=1,NCELAP + IDD(MBB+JAUX+1)=IDD(MBB+KAUX+K+1) + JAUX=JAUX+1 + 90 CONTINUE + 92 CONTINUE + ENDIF + 95 CONTINUE + DEALLOCATE(ISS) + ENDIF + IF(IHEX.NE.9) DEALLOCATE(IBB) + DEALLOCATE(ICC) + IF(NCODE(5) .EQ. 5 .OR. NCODE(5) .EQ. 10) THEN +* +* DUPLICATION DE LA SYMETRIE SELON L'AXE Z- +* + IF(NCODE(6) .EQ. 5 .OR. NCODE(6) .EQ. 10) CALL XABORT( + > 'LHXUNH: ONLY ONE Z SYMETRY IS PERMITED') + IF(NCODE(6) .EQ. 5) THEN + KBB=NCELA+NCELA-NCELAP*LSPLZM + IOFZD=LSPLZM + ELSE + KBB=NCELA+NCELA + IOFZD=0 + ENDIF + MCODE=1 + KK=KBB + KBB=2*KBB + IF(LGTURN)KBB=KBB+KK + ALLOCATE(IGG(KBB),IAA(KK)) + IAUX=0 + JAUX=NCELA-NCELAP + LAUX=2*NCELA-NCELAP +* +* DUPLICATION DE MIX ET MERGE +* + NCOUR=IFCOUR(NCELAP) + DO 110 I=IOFZD,LZZ-1 + IPOS=0 + IAA(IAUX+1)=IAD(JAUX+1) + IGG(IAUX+1)=IDD(JAUX+1) + IGG(KK+IAUX+1)=IDD(LAUX+1) + DO 100 J1=2,NCOUR + DO 99 J=IFONC(J1,5)-1,IFONC(J1,0)-1,-1 + IPOS=IPOS+1 + IAA(IAUX+IPOS+1)=IAD(JAUX+J+1) + IGG(IAUX+IPOS+1)=IDD(JAUX+J+1) + IGG(KK+IAUX+IPOS+1)=IDD(LAUX+J+1) + 99 CONTINUE + NCLCOR=1+3*J1*(J1-1) + DO 105 J=NCLCOR-1,IFONC(J1,5),-1 + IPOS=IPOS+1 + IAA(IAUX+IPOS+1)=IAD(JAUX+J+1) + IGG(IAUX+IPOS+1)=IDD(JAUX+J+1) + IGG(KK+IAUX+IPOS+1)=IDD(LAUX+J+1) + 105 CONTINUE + 100 CONTINUE + IAUX=IAUX+NCELAP + JAUX=JAUX-NCELAP + LAUX=LAUX-NCELAP + 110 CONTINUE + DO 115 K=1,NCELA + IAA(IAUX+K)=IAD(K) + IGG(IAUX+K)=IDD(K) + IGG(KK+IAUX+K)=IDD(NCELA+K) + 115 CONTINUE +* +* DUPLICATION DE TURN +* + IF(LGTURN) THEN + IAUX=0 + LAUX=3*NCELA-NCELAP*IOFZD + DO 130 I=IOFZD,LZZ-1 + J=-1 + JAUX2=0 + JAUX1=0 + DO 120 J1=1,NCOUR + LGPASS=.TRUE. + 118 CONTINUE + DO 119 J2=JAUX2,JAUX1,-1 + J=J+1 + ITURN=IDD(LAUX+J2+1) + IF(ITURN.LE.6) THEN + IF(ITURN.EQ.1) THEN + IGG(2*KK+IAUX+J+1)=12 + ELSEIF(ITURN.EQ.2) THEN + IGG(2*KK+IAUX+J+1)=11 + ELSEIF(ITURN.EQ.3) THEN + IGG(2*KK+IAUX+J+1)=10 + ELSEIF(ITURN.EQ.4) THEN + IGG(2*KK+IAUX+J+1)=9 + ELSEIF(ITURN.EQ.5) THEN + IGG(2*KK+IAUX+J+1)=8 + ELSEIF(ITURN.EQ.6) THEN + IGG(2*KK+IAUX+J+1)=7 + ENDIF + ELSEIF(ITURN.LE.12) THEN + IF(ITURN.EQ.12) THEN + IGG(2*KK+IAUX+J+1)=1 + ELSEIF(ITURN.EQ.11) THEN + IGG(2*KK+IAUX+J+1)=2 + ELSEIF(ITURN.EQ.10) THEN + IGG(2*KK+IAUX+J+1)=3 + ELSEIF(ITURN.EQ.9) THEN + IGG(2*KK+IAUX+J+1)=4 + ELSEIF(ITURN.EQ.8) THEN + IGG(2*KK+IAUX+J+1)=5 + ELSEIF(ITURN.EQ.7) THEN + IGG(2*KK+IAUX+J+1)=6 + ENDIF + ELSE + CALL XABORT('LHXUNH: EXPECTED VALUE OF TURN ') + ENDIF + 119 CONTINUE + IF(LGPASS) THEN + JAUX2=1+3*J1*(J1-1)-1 + JAUX1=IFONC(J1,5) + LGPASS=.FALSE. + IF(J1.GT.1) GOTO 118 + ENDIF + JAUX2=IFONC(J1+1,5)-1 + JAUX1=IFONC(J1+1,0)-1 + 120 CONTINUE + IAUX=IAUX+NCELAP + LAUX=LAUX-NCELAP + 130 CONTINUE + ENDIF + DO 135 K=1,NCELA + IGG(2*KK+IAUX+K)=IDD(2*NCELA+K) + 135 CONTINUE + IPLANI=LZZ + LZZ=2*LZZ-IOFZD + ELSEIF(NCODE(6) .EQ. 5 .OR. NCODE(6) .EQ. 10) THEN +* +* DULPLICATION DE LA GEOMETRIE SELON Z+ +* + IF(NCODE(6) .EQ. 5) THEN + KBB=NCELA+NCELA-NCELAP*LSPLZP + IOFZD=LSPLZP + ELSE + KBB=NCELA+NCELA + IOFZD=0 + ENDIF + MCODE=2 + KK=KBB + KBB=2*KBB + IF(LGTURN)KBB=KBB+KK + ALLOCATE(IGG(KBB),IAA(KK)) +* +* DUPLICATION DE MIX ET MERGE +* + DO 140 I=1,NCELA + IAA(I)=IAD(I) + IGG(I)=IDD(I) + IGG(KK+I)=IDD(NCELA+I) + 140 CONTINUE + NCOUR=IFCOUR(NCELAP) + LFIN=-NCELAP*IOFZD+NCELA + IPOS=-1 + DO 145 I=IOFZD,LZZ-1 + LFIN=LFIN-NCELAP + IPOS=IPOS+1 + IAA(NCELA+IPOS+1)=IAD(LFIN+1) + IGG(NCELA+IPOS+1)=IDD(LFIN+1) + IGG(KK+NCELA+IPOS+1)=IDD(NCELA+LFIN+1) + DO 143 J1=2,NCOUR + DO 141 J=IFONC(J1,5)-1,IFONC(J1,0)-1,-1 + IPOS=IPOS+1 + IAA(NCELA+IPOS+1)=IAD(LFIN+J+1) + IGG(NCELA+IPOS+1)=IDD(LFIN+J+1) + IGG(KK+NCELA+IPOS+1)=IDD(NCELA+LFIN+J+1) + 141 CONTINUE + NCLCOR=1+3*J1*(J1-1) + DO 142 J=NCLCOR-1,IFONC(J1,5),-1 + IPOS=IPOS+1 + IAA(NCELA+IPOS+1)=IAD(LFIN+J+1) + IGG(NCELA+IPOS+1)=IDD(LFIN+J+1) + IGG(KK+NCELA+IPOS+1)=IDD(NCELA+LFIN+J+1) + 142 CONTINUE + 143 CONTINUE + 145 CONTINUE +* +* DUPLICATION DE TURN +* + IF(LGTURN) THEN + DO 150 I=1,NCELA + IGG(2*KK+I)=IDD(2*NCELA+I) + 150 CONTINUE + LFIN=-NCELAP*IOFZD+NCELA + J=-1+NCELA + DO 155 JP=IOFZD,LZZ-1 + LFIN=LFIN-NCELAP + JAUX2=0 + JAUX1=0 + DO 154 J1=1,NCOUR + LGPASS=.TRUE. + 152 CONTINUE + DO 153 J2=JAUX2,JAUX1,-1 + J=J+1 + ITURN=IDD(2*NCELA+LFIN+J2+1) + IF(ITURN.LE.6) THEN + IF(ITURN.EQ.1) THEN + IGG(2*KK+J+1)=12 + ELSEIF(ITURN.EQ.2) THEN + IGG(2*KK+J+1)=11 + ELSEIF(ITURN.EQ.3) THEN + IGG(2*KK+J+1)=10 + ELSEIF(ITURN.EQ.4) THEN + IGG(2*KK+J+1)=9 + ELSEIF(ITURN.EQ.5) THEN + IGG(2*KK+J+1)=8 + ELSEIF(ITURN.EQ.6) THEN + IGG(2*KK+J+1)=7 + ENDIF + ELSEIF(ITURN.LE.12) THEN + IF(ITURN.EQ.12) THEN + IGG(2*KK+J+1)=1 + ELSEIF(ITURN.EQ.11) THEN + IGG(2*KK+J+1)=2 + ELSEIF(ITURN.EQ.10) THEN + IGG(2*KK+J+1)=3 + ELSEIF(ITURN.EQ.9) THEN + IGG(2*KK+J+1)=4 + ELSEIF(ITURN.EQ.8) THEN + IGG(2*KK+J+1)=5 + ELSEIF(ITURN.EQ.7) THEN + IGG(2*KK+J+1)=6 + ENDIF + ELSE + CALL XABORT('LHXUNH: EXPECTED VALUE OF TURN ') + ENDIF + 153 CONTINUE + IF(LGPASS) THEN + JAUX2=1+3*J1*(J1-1)-1 + JAUX1=IFONC(J1,5) + LGPASS=.FALSE. + IF(J1.GT.1) GOTO 152 + ENDIF + JAUX2=IFONC(J1+1,5)-1 + JAUX1=IFONC(J1+1,0)-1 + 154 CONTINUE + 155 CONTINUE + ENDIF + IPLANI=LZZ + LZZ=2*LZZ-IOFZD + ELSE + ALLOCATE(IGG(NBASE),IAA(NCELA)) + DO 156 J=1,NBASE + IGG(J)=IDD(J) + 156 CONTINUE + DO 157 J=1,NCELA + IAA(J)=IAD(J) + 157 CONTINUE + KK=NCELA + ENDIF + DEALLOCATE(IDD,IAD) +* +* RESTORAGE DES DONNEES +* + NCELA=KK + MVOSU=0 + MVOLUM=0 + MESH=3*KK + NSMIN=0 + NSMAX=0 + ISURF=0 + NCOUR=1 + IF(NCELAP.GT.1)NCOUR=IFCOUR(NCELAP) + ICELC0= IFONC(NCOUR,0) + ICELC1= IFONC(NCOUR,1)-ICELC0 + MCOU=1 + LCOU=1 + ALLOCATE(SURL(2*LZZ)) + SURL(:2*LZZ)=0 + IF(LGCELL) THEN + CALL LCMSIX(IPTRK,'DATA_DUP',1) + CALL LCMPUT(IPTRK,'GENER0',KK,1,IAA) + CALL LCMPUT(IPTRK,'GENERATING',KK,1,IGG) + CALL LCMSIX(IPTRK,' ',2) + DEALLOCATE(IAA) + NRAY=0 + NCDP=NCELA-NCELAP + ICELL1=IFONC(NCOUR,5) + IP=1 + ISAUX=0 + DO 200 I=0,KK-1 + KRAY=ISEC1(IGG(I+1)) + NRAY=NRAY+KRAY + I1=I+1 + DO 205 JR=1,KRAY+1 + KSECT=ISEC2(IGG(I+1))%ILOCR(JR) + IF(KSECT.GT.1) THEN + MSEC=6*(KSECT-1) + MVOSU=MVOSU+MSEC + IF(I1.LE.NCELAP)THEN + NSMIN=NSMIN+MSEC + ELSEIF(I1.GT.NCDP) THEN + NSMAX=NSMAX+MSEC + ENDIF + ELSE + MVOSU=MVOSU+1 + IF(I1.LE.NCELAP)THEN + NSMIN=NSMIN+1 + ELSEIF(I1.GT.NCDP) THEN + NSMAX=NSMAX+1 + ENDIF + ENDIF + 205 CONTINUE + IF(IHEX.EQ.9) THEN + IF(MCODE.EQ.1) THEN + IF(I1.LE.NCELAP) THEN + IF(I1.LE.LCOU) THEN + VLAT(MCOU)=NSMIN + IF(I1.EQ.IFONC(MCOU,5)) VLAT(NCOUR+MCOU)=NSMIN + ELSE + LCOU=LCOU+6*MCOU + MCOU=MCOU+1 + ENDIF + ENDIF + ELSEIF(MCODE.EQ.2) THEN + IF(I1.GT.NCDP) THEN + I2=I1-NCDP + IF(I2.LE.LCOU) THEN + VLAT(MCOU)=NSMAX + IF(I2.EQ.IFONC(MCOU,5)) VLAT(NCOUR+MCOU)=NSMAX + ELSE + LCOU=LCOU+6*MCOU + MCOU=MCOU+1 + ENDIF + ENDIF + ENDIF + ENDIF + ICOX=INT(AINT(REAL(I1)/REAL(NCELAP))) + IF(MOD(I1,NCELAP).NE.0)ICOX=ICOX+1 + ICOX=ICOX-1 + ICX=NCELAP*ICOX + ICELC=ICELC0+ICX + ICLIM=NCELAP+ICX + IF(I1.GE.ICELC.AND.I1.LE.ICLIM) THEN + IF(KSECT.GT.1) THEN + ISURF=ISURF+2*(KSECT-1) + ISURF0=ISURF + IF(MOD(I1-ICELC,ICELC1).EQ.0)ISURF=ISURF+KSECT-1 + IF(I1.LE.NCELAP*IP) THEN + NXX=NCELAP*(IP-1) + IF(I1.EQ.ICELC0+NXX) ISAUX=KSECT-1 + IF(I1.EQ.ICELL1+NXX) SURL(LZZ+IP)=ISURF0-ISAUX + SURL(IP)=ISURF + ELSE + ISAUX=0 + IP=IP+1 + NXX=NCELAP*(IP-1) + IF(I1.EQ.ICELC0+NXX) ISAUX=KSECT-1 + ENDIF + ELSE + ISURF=ISURF+2 + ISURF0=ISURF + IF(MOD(I1-ICELC,ICELC1).EQ.0)ISURF=ISURF+1 + IF(I1.LE.NCELAP*IP) THEN + NXX=NCELAP*(IP-1) + IF(I1.EQ.ICELC0+NXX) ISAUX=1 + IF(I1.EQ.ICELL1+NXX) SURL(LZZ+IP)=ISURF0-ISAUX + SURL(IP)=ISURF + ELSE + ISAUX=0 + IP=IP+1 + NXX=NCELAP*(IP-1) + IF(I1.EQ.ICELC0+NXX) ISAUX=1 + ENDIF + ENDIF + ENDIF + MVOLUM=MVOLUM+KRAY+1 + 200 CONTINUE + DO 206 I=1,ISTAT9 + DEALLOCATE(ISEC2(I)%ILOCR) + 206 CONTINUE + MESH=MESH+NRAY + IF(IPLANZ.EQ.1) NSMAX=NSMIN + ELSE + CALL LCMSIX(IPTRK,'DATA_DUP',1) + CALL LCMPUT(IPTRK,'MIX',KK,1,IGG) + CALL LCMSIX(IPTRK,' ',2) + NCDP=NCELA-NCELAP + MVOLUM=KK + NCOUR=IFCOUR(NCELAP) + ICELL1=IFONC(NCOUR,5) + IP=1 + ISAUX=0 + DO 210 I=0,KK-1 + I1=I+1 + KSECT=ISEC1(IGG(I+1)) + ICOX=INT(AINT(REAL(I1)/REAL(NCELAP))) + IF(MOD(I1,NCELAP).NE.0)ICOX=ICOX+1 + ICOX=ICOX-1 + ICXX=NCELAP*ICOX + ICELC=ICELC0+ICXX + ICLIM=NCELAP+ICXX + IF(KSECT.GT.1) THEN + MSEC=6*(KSECT-1) + MVOSU=MVOSU+MSEC + IF(I1.LE.NCELAP)THEN + NSMIN=NSMIN+MSEC + ELSEIF(I1.GT.NCDP) THEN + NSMAX=NSMAX+MSEC + ENDIF + IF(I1.GE.ICELC.AND.I1.LE.ICLIM) THEN + ISURF=ISURF+2*(KSECT-1) + ISURF0=ISURF + IF(MOD(I1-ICELC,ICELC1).EQ.0)ISURF=ISURF+KSECT-1 + IF(I1.LE.NCELAP*IP) THEN + NXX=NCELAP*(IP-1) + IF(I1.EQ.ICELC0+NXX) ISAUX=KSECT-1 + IF(I1.EQ.ICELL1+NXX) SURL(LZZ+IP)=ISURF0-ISAUX + SURL(IP)=ISURF + ELSE + ISAUX=0 + IP=IP+1 + NXX=NCELAP*(IP-1) + IF(I1.EQ.ICELC0+NXX) ISAUX=KSECT-1 + ENDIF + ENDIF + ELSE + MVOSU=MVOSU+1 + IF(I1.LE.NCELAP)THEN + NSMIN=NSMIN+1 + ELSEIF(I1.GT.NCDP) THEN + NSMAX=NSMAX+1 + ENDIF + IF(I1.GE.ICELC.AND.I1.LE.ICLIM) THEN + ISURF=ISURF+2 + ISURF0=ISURF + IF(MOD(I1-ICELC,ICELC1).EQ.0)ISURF=ISURF+1 + IF(I1.LE.NCELAP*IP) THEN + NXX=NCELAP*(IP-1) + IF(I1.EQ.ICELC0+NXX) ISAUX=1 + IF(I1.EQ.ICELL1+NXX) SURL(LZZ+IP)=ISURF0-ISAUX + SURL(IP)=ISURF + ELSE + ISAUX=0 + IP=IP+1 + NXX=NCELAP*(IP-1) + IF(I1.EQ.ICELC0+NXX) ISAUX=1 + ENDIF + ENDIF + ENDIF + IF(IHEX.EQ.9) THEN + IF(MCODE.EQ.1) THEN + IF(I1.LE.NCELAP) THEN + IF(I1.LE.LCOU) THEN + VLAT(MCOU)=NSMIN + IF(I1.EQ.IFONC(MCOU,5)) VLAT(NCOUR+MCOU)=NSMIN + ELSE + LCOU=LCOU+6*MCOU + MCOU=MCOU+1 + ENDIF + ENDIF + ELSEIF(MCODE.EQ.2) THEN + IF(I1.GT.NCDP) THEN + I2=I1-NCDP + IF(I2.LE.LCOU) THEN + VLAT(MCOU)=NSMAX + IF(I2.EQ.IFONC(MCOU,5)) VLAT(NCOUR+MCOU)=NSMAX + ELSE + LCOU=LCOU+6*MCOU + MCOU=MCOU+1 + ENDIF + ENDIF + ENDIF + ENDIF + 210 CONTINUE + IF(IPLANZ.EQ.1) NSMAX=NSMIN + ENDIF + DEALLOCATE(ISEC2,ISEC1) + CALL LCMSIX(IPTRK,'DATA_DUP',1) + CALL LCMPUT(IPTRK,'SURL_HEX',2*LZZ,1,SURL) + CALL LCMPUT(IPTRK,'MERGE',KK,1,IGG(KK+1)) + IF(LGTURN)CALL LCMPUT(IPTRK,'TURN',KK,1,IGG(2*KK+1)) + CALL LCMSIX(IPTRK,' ',2) + DEALLOCATE(IGG,SURL) +* +* MODIFICATION DU VECTEUR STATE +* + ISTATE(5)=LZZ + IPLANZ=LZZ + ENDIF + ISTATE(3)=NCELAP + ISURF=ISURF+NSMIN+NSMAX + RETURN + END diff --git a/Dragon/src/LIB.f b/Dragon/src/LIB.f new file mode 100644 index 0000000..d8a8b5b --- /dev/null +++ b/Dragon/src/LIB.f @@ -0,0 +1,562 @@ +*DECK LIB + SUBROUTINE LIB(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Interpolation of nuclear properties in an internal library. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert and G. Marleau +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): create or modification type(L_LIBRARY) +* HENTRY(2): optional read-only type(L_LIBRARY, L_MACROLIB or +* L_BURNUP) used to initialize a new lattice code library. +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPLIB,IPLIBX,IPBURX + INTEGER IOUT,NSTATE,ILCMUP,ILCMDN,MAXED,MAXISD + CHARACTER NAMSBR*6,HSMG*131 + PARAMETER (IOUT=6,NSTATE=40,ILCMUP=1,ILCMDN=2,MAXED=50, + > MAXISD=300,NAMSBR='LIB ') +*---- +* INPUT +*---- + INTEGER ITYPLU,INTLIR + CHARACTER CARLIR*12 + REAL REALIR + DOUBLE PRECISION DBLLIR +*---- +* LOCAL PARAMETERS +*---- + CHARACTER TEXT12*12,HSIGN*12,HVECT(MAXED)*8,HADD*8,NAMLCM*12, + > NAMMY*12 + INTEGER ISTATE(NSTATE),IPRINT,NBISOX,NBMIXX,MAXMIX,INDREC, + > NBISO,NGRO,NGT,NGF,NGFR,NL,ITRANC,ITIME,NLIB,NIDEPL, + > NCOMB,NEDMAC,NBMIX,NRES,MAXISM,ILCMLN,ILCMTY,IED, + > JED,KED,IDP,IBSTEP,MAXISO,NDEPL,NEDMA0,ITPROC,ISOADD, + > NADDXS,IPROB,IPROC,IMAC,NDEL,NFISS,IPRECI,STERN, + > STERNR + REAL TMPDAY(3),DELT,TIMBRN,SVDEPS + INTEGER IKSTEP + LOGICAL LEXIST,EMPTY,LCM + INTEGER, ALLOCATABLE, DIMENSION(:) :: IADNAM + REAL, ALLOCATABLE, DIMENSION(:) :: ENER,BSTD +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY .EQ. 0) CALL XABORT(NAMSBR//': PARAMETER EXPECTED.') + IF(IENTRY(1) .NE. 1 .AND. + > IENTRY(1) .NE. 2) CALL XABORT(NAMSBR// + >': LCM OBJECT OR XSM FILE EXPECTED AT LHS.') + IF(JENTRY(1) .NE. 0 .AND. + > JENTRY(1) .NE. 1) CALL XABORT(NAMSBR//': ENTRY' + 1 //' IN CREATE OR MODIFICATION MODE EXPECTED.') + IPLIB=KENTRY(1) +*---- +* READ THE INPUT DATA. +* DEFAULT OPTIONS: +*---- + IPRINT=1 + NBISOX=0 + NBMIXX=0 + IPLIBX=C_NULL_PTR + IPBURX=C_NULL_PTR + IBSTEP=0 + LEXIST=(JENTRY(1).EQ.1) + IF(LEXIST) THEN + CALL LCMINF(IPLIB,NAMLCM,NAMMY,EMPTY,ILCMLN,LCM) + LEXIST=.NOT.EMPTY + ENDIF + NDEPL=0 + SVDEPS=1.0E-3 + IF(.NOT.LEXIST) THEN + MAXMIX=0 + INDREC=1 + NBISO=0 + NGRO=0 + NGT=0 + NGF=9999999 + NGFR=0 + NL=2 + ITRANC=0 + IPROB=0 + ITIME=1 + NLIB=0 + NIDEPL=0 + NCOMB=0 + NEDMAC=0 + NBMIX=0 + NRES=0 + IPROC=0 + IMAC=1 + NDEL=0 + NFISS=0 + ISOADD=0 + MAXISM=MAXISD + IPRECI=4 + STERN=1 + ENDIF +*---- +* TRY TO FIND A READ-ONLY LCM OBJECT +*---- + IF(NENTRY.GT.1) THEN + IF((IENTRY(2).LE.2) .AND.(JENTRY(2).EQ.2)) THEN + CALL LCMLEN(KENTRY(2),'SIGNATURE',ILCMLN,ILCMTY) + IF(ILCMLN.EQ.0) THEN + CALL LCMLIB(KENTRY(2)) + WRITE(HSMG,'(A,30H: MISSING SIGNATURE IN OBJECT ,A,1H.)') + 1 TRIM(NAMSBR),TRIM(HENTRY(2)) + CALL XABORT(HSMG) + ENDIF + CALL LCMGTC(KENTRY(2),'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_LIBRARY') THEN + IPLIBX=KENTRY(2) + ELSE IF(HSIGN.EQ.'L_BURNUP') THEN + IPBURX=KENTRY(2) + ELSE IF(HSIGN.EQ.'L_MACROLIB') THEN +*---- +* COPY A READ-ONLY MACROLIB IN IPLIB +*---- + CALL LCMEQU(KENTRY(2),IPLIB) + INDREC=3 + CALL LCMGET(KENTRY(2),'STATE-VECTOR',ISTATE) + NGRO=ISTATE(1) + NGT=NGRO + MAXMIX=ISTATE(2) + NL=ISTATE(3) + NADDXS=ISTATE(5) + ITRANC=ISTATE(6) + NDEL=ISTATE(7) + IF(NGT.GT.0) THEN + ALLOCATE(ENER(2*NGT+1)) + CALL LCMGET(KENTRY(2),'ENERGY',ENER) + CALL LCMGET(KENTRY(2),'DELTAU',ENER(NGT+2)) + ENDIF + CALL LCMSIX(IPLIB,'MACROLIB',ILCMUP) + CALL LCMEQU(KENTRY(2),IPLIB) + IF(NADDXS.NE.0) THEN + IF(NADDXS .GT. MAXED-NEDMAC) CALL XABORT(NAMSBR// + > ': TOO MANY EXTRA EDITS REQUESTED') + ALLOCATE(IADNAM(2*NADDXS)) + CALL LCMGET(IPLIB,'ADDXSNAME-P0',IADNAM) + JED=0 + DO 120 IED=1,NADDXS + WRITE(HADD,'(2A4)') IADNAM(JED+1),IADNAM(JED+2) + DO 100 KED=1,NEDMAC + IF(HADD.EQ.HVECT(KED)) GO TO 110 + 100 CONTINUE + NEDMAC=NEDMAC+1 + HVECT(NEDMAC)=HADD + 110 CONTINUE + JED=JED+2 + 120 CONTINUE + DEALLOCATE(IADNAM) + ENDIF +*---- +* WRITE ENERGY AND DELTAU ON MACROLIB +*---- + IF(NGT.GT.0) THEN + CALL LCMPUT(IPLIB,'ENERGY',NGT+1,2,ENER) + CALL LCMPUT(IPLIB,'DELTAU',NGT,2,ENER(NGT+2)) + ENDIF + CALL LCMSIX(IPLIB,'MACROLIB',ILCMDN) + IF(NGT.GT.0) THEN + CALL LCMPUT(IPLIB,'ENERGY',NGT+1,2,ENER) + CALL LCMPUT(IPLIB,'DELTAU',NGT,2,ENER(NGT+2)) + DEALLOCATE(ENER) + ENDIF + CALL LCMSIX(KENTRY(2),' ',0) + ENDIF + ENDIF + ENDIF +*---- +* RECOVER STATE-VECTOR FROM EXISTING MICROLIB +*---- + IF(LEXIST) THEN + CALL LCMGTC(IPLIB,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_LIBRARY') THEN + TEXT12=HENTRY(1) + CALL XABORT(NAMSBR// + > ': SIGNATURE OF '//TEXT12//' IS '//HSIGN// + > '. L_LIBRARY EXPECTED.') + ENDIF + INDREC=2 + CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) + MAXMIX=ISTATE(1) + NBISO=ISTATE(2) + NGRO=ISTATE(3) + NGT=NGRO + NL=ISTATE(4) + ITRANC=ISTATE(5) + IPROB=ISTATE(6) + ITIME=ISTATE(7) + NLIB=ISTATE(8) + NGF=ISTATE(9) + NGFR=ISTATE(10) + NIDEPL=ISTATE(11) + NCOMB=ISTATE(12) + NEDMAC=ISTATE(13) + NBMIX=ISTATE(14) + NRES=ISTATE(15) + IPROC=ISTATE(17) + IMAC=ISTATE(18) + NDEL=ISTATE(19) + NFISS=ISTATE(20) + ISOADD=ISTATE(21) + MAXISM=ISTATE(22) + IPRECI=ISTATE(23) + STERN=ISTATE(27) + IF(NEDMAC.GT.0) THEN + IF(NEDMAC .GT. MAXED) CALL XABORT(NAMSBR//': MAXED OVERFLOW') + CALL LCMGTC(IPLIB,'ADDXSNAME-P0',8,NEDMAC,HVECT) + ENDIF + ENDIF +*---- +* READ LIBRARY DATA +*---- + 130 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR//': KEYWORD EXPECTED') + 140 IF(CARLIR(1:4) .EQ. 'EDIT') THEN +*--- +* READ THE PRINT INDEX +*---- + CALL REDGET(ITYPLU,IPRINT,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT(NAMSBR// + > ': VALUE FOR IPRINT EXPECTED') + ELSE IF(CARLIR(1:4) .EQ. 'NGRO') THEN +*---- +* READ THE NUMBER OF ENERGY GROUPS. +*---- + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': VALUE FOR NGRO EXPECTED') + IF(INDREC .EQ. 2) THEN + IF(NGRO .NE. INTLIR) CALL XABORT(NAMSBR// + > ': INCOMPATIBLE VALUE OF NGRO') + ELSE + NGRO=INTLIR + ENDIF + ELSE IF(CARLIR(1:4) .EQ. 'MXIS') THEN +*---- +* CHANGE MAXIMUM NUMBER OF ISOTOPES +*---- + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': VALUE FOR MXIS EXPECTED') + MAXISM=MAX(MAXISM,INTLIR) + ELSE IF(CARLIR(1:4) .EQ. 'NMIX') THEN +*---- +* READ THE MAXIMUM NUMBER OF MATERIAL MIXTURES +*---- + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': VALUE FOR NMIX EXPECTED') + MAXMIX=MAX(MAXMIX,INTLIR) + ELSE IF(CARLIR(1:4) .EQ. 'CTRA') THEN +*---- +* READ TRANSPORT CORRECTION TYPE +*---- + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + > ': CHARACTER CTRA TYPE EXPECTED') + IF(CARLIR(1:4) .EQ. 'NONE') THEN + ITRANC=0 + ELSE IF(CARLIR(1:4) .EQ. 'APOL') THEN + ITRANC=1 + ELSE IF(CARLIR(1:4) .EQ. 'WIMS') THEN + ITRANC=2 + ELSE IF(CARLIR(1:4) .EQ. 'OLDW') THEN + ITRANC=3 + ELSE IF(CARLIR(1:4) .EQ. 'LEAK') THEN + ITRANC=4 + ELSE + CALL XABORT(NAMSBR// + > ': CTRA TYPE NONE, APOL, WIMS, OLDW OR LEAK EXPECTED.') + ENDIF + ELSE IF(CARLIR(1:5) .EQ. 'STERN') THEN +*---- +* READ THE STERNHEIMER CORRECTION FLAG +*---- + CALL REDGET(ITYPLU,STERNR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .EQ. 1) THEN + IF (STERNR.NE.0 .AND. STERNR.NE.1) THEN + CALL XABORT('LIB: STERN 1 OR STERN 0 EXPECTED.') + ELSE + STERN=STERNR + ENDIF + ENDIF + IF(IPRINT . GT. 0) THEN + IF(STERN .EQ. 1) PRINT *,'STERNHEIMER CORRECTION ACTIVATED' + IF(STERN .EQ. 0) PRINT *,'STERNHEIMER CORRECTION DESACTIVATED' + ENDIF + ELSE IF(CARLIR(1:4) .EQ. 'ANIS') THEN +*---- +* READ THE SCATTERING ANISOTROPY FOR TRANSPORT THEORY CASES +*---- + CALL REDGET(ITYPLU,NL,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': VALUE FOR ANIS EXPECTED') + ELSE IF(CARLIR(1:3) .EQ. 'ADJ') THEN + IPROB=1 + ELSE IF(CARLIR(1:4) .EQ. 'PROM') THEN + ITIME=2 + ELSE IF(CARLIR(1:7) .EQ. 'RDEPCHN') THEN + ISOADD=1 + ELSE IF(CARLIR(1:7) .EQ. 'CDEPCHN') THEN + ISOADD=0 + ELSE IF(CARLIR(1:4) .EQ. 'SKIP') THEN + IPROC=-1 + IMAC=0 + ELSE IF(CARLIR(1:4) .EQ. 'INTR') THEN + IPROC=0 + IMAC=0 + ELSE IF(CARLIR(1:4) .EQ. 'SUBG') THEN + IPROC=1 + IMAC=0 + ELSE IF(CARLIR(1:4) .EQ. 'NEWL') THEN + IPROC=2 + IMAC=0 + ELSE IF(CARLIR(1:4) .EQ. 'PTSL') THEN + IPROC=4 + IMAC=0 + ELSE IF(CARLIR(1:4) .EQ. 'PTMC') THEN + IPROC=5 + IMAC=0 + ELSE IF(CARLIR(1:2) .EQ. 'PT') THEN + IPROC=3 + IMAC=0 + ELSE IF(CARLIR(1:3) .EQ. 'RSE') THEN + IPROC=6 + IMAC=0 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.2) THEN + SVDEPS=REALIR + ELSE IF(ITYPLU.EQ.3) THEN + GO TO 140 + ELSE + CALL XABORT(NAMSBR//': REAL VALUE EXPECTED FOR RSE ACCURACY') + ENDIF + ELSE IF(CARLIR(1:4) .EQ. 'MACR') THEN + IMAC=1 + ELSE IF(CARLIR(1:7) .EQ. 'CALENDF') THEN + CALL REDGET(ITYPLU,IPRECI,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': INTEGER VALUE EXPECTED FOR CALENDF ACCURACY') + ELSE IF(CARLIR(1:4) .EQ. 'DEPL') THEN + CALL LIBDEP(IPLIB,IPRINT,NIDEPL) + ELSE IF(CARLIR.EQ.'ADED') THEN + CALL REDGET(ITYPLU,NEDMA0,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': VALUE FOR ADED EXPECTED') + DO 170 IED=1,NEDMA0 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + > ': TYPE FOR ADED EXPECTED') + DO 160 JED=1,NEDMAC + IF(CARLIR(:8) .EQ. HVECT(JED)) GO TO 170 + 160 CONTINUE + NEDMAC=NEDMAC+1 + IF(NEDMAC .GT. MAXED) CALL XABORT(NAMSBR// + > ': TOO MANY EXTRA EDITS REQUESTED') + HVECT(NEDMAC)=CARLIR(:8) + 170 CONTINUE + ELSE IF(CARLIR(1:4) .EQ. 'MIXS') THEN + ITPROC=1 + GO TO 240 + ELSE IF(CARLIR(1:4) .EQ. 'MAXS') THEN + ITPROC=2 + IF(INDREC .NE. 2) CALL XABORT(NAMSBR// + > ': MAXS CAN ONLY BE USE TO UPDATE '// + > 'A LIBRARY - IT CANNOT CREATE A NEW LIBRARY') +*---- +* TRY TO FIND A SECOND READ-ONLY MICROLIB TO MODIFY ORIGINAL ONE +*---- + IF(C_ASSOCIATED(IPLIBX)) THEN + CALL LCMGET(IPLIBX,'STATE-VECTOR',ISTATE) + NBMIXX=ISTATE(1) + NBISOX=ISTATE(2) + ELSE + NBMIXX=MAXMIX + NBISOX=NBISO + IPLIBX=IPLIB + ENDIF + TMPDAY(1)=0.0 + TMPDAY(2)=0.0 + TMPDAY(3)=0.0 + CALL LCMLEN(IPLIB,'MACROLIB',ILCMLN,ILCMTY) + IF(ILCMLN .EQ. -1) THEN + CALL LCMSIX(IPLIB,'MACROLIB',ILCMUP) + CALL LCMLEN(IPLIB,'TIMESTAMP',ILCMLN,ILCMTY) + IF(ILCMLN .GT. 0 .AND. ILCMLN .LE. 3) THEN + CALL LCMGET(IPLIB,'TIMESTAMP',TMPDAY) + ENDIF + CALL LCMSIX(IPLIB,'MACROLIB',ILCMDN) + ENDIF + GO TO 240 + ELSE IF(CARLIR(1:4) .EQ. 'BURN') THEN + IF(INDREC .NE. 2) THEN + CALL XABORT(NAMSBR//': BURN CAN ONLY BE USE TO UPDATE '// + > 'A LIBRARY - IT CANNOT CREATE A NEW LIBRARY') + ELSE IF(.NOT.C_ASSOCIATED(IPBURX)) THEN + CALL XABORT(NAMSBR//': BURNUP OBJECT MISSING') + ENDIF + ITPROC=2 + CALL LCMGET(IPBURX,'STATE-VECTOR',ISTATE) + NDEPL=ISTATE(3) + NBISOX=ISTATE(4) + NBMIXX=ISTATE(8) + ALLOCATE(BSTD(NDEPL)) + CALL LCMGET(IPBURX,'DEPL-TIMES ',BSTD) + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .EQ. 3) CALL XABORT(NAMSBR//': INVALID BURNUP STEP') + IF(ITYPLU .EQ. 2) THEN + TMPDAY(1)=REALIR + TIMBRN=0.000864*TMPDAY(1) + IF(TIMBRN .LE. 0.0) THEN + IBSTEP=1 + TMPDAY(1)=0.0 + ELSE + IBSTEP=1 + IKSTEP=0 + DO 210 IDP=1,NDEPL + DELT=ABS(TIMBRN-BSTD(IDP)) + IF(DELT .LT. 1.0E-6) THEN + IBSTEP=IDP + GO TO 220 + ELSE IF(TIMBRN .GT. BSTD(IDP)) THEN + IKSTEP=IDP + ENDIF + 210 CONTINUE + WRITE(IOUT,9000) TMPDAY + WRITE(IOUT,9001) (BSTD(IDP)/0.000864,IDP=1,NDEPL) + IBSTEP=MIN(IKSTEP+1,NDEPL) + WRITE(IOUT,9002) BSTD(IBSTEP)/0.000864 + 220 CONTINUE + ENDIF + ELSE IF(ITYPLU .EQ. 1) THEN + IBSTEP=INTLIR + IF(IBSTEP .LE. 0 ) THEN + WRITE(IOUT,9010) + IBSTEP=1 + WRITE(IOUT,9010) BSTD(IBSTEP)/0.000864 + ELSE IF(IBSTEP .GT. NDEPL) THEN + IBSTEP=NDEPL + WRITE(IOUT,9011) BSTD(IBSTEP)/0.000864 + ENDIF + TMPDAY(1)=BSTD(IBSTEP)/0.000864 + ENDIF + DEALLOCATE(BSTD) + TMPDAY(2)=0.0 + TMPDAY(3)=0.0 + IF(IPRINT .GE. 1) WRITE(IOUT,6000) IBSTEP,TMPDAY(1) + GO TO 240 + ELSE IF(CARLIR(1:4) .EQ. 'CATL') THEN + ITPROC=3 + GO TO 240 + ELSE IF(CARLIR(1:1).EQ.';') THEN +* SAVE THE LIBRARY SPECIFIC INFORMATION. + TEXT12='L_LIBRARY' + CALL LCMPTC(IPLIB,'SIGNATURE',12,TEXT12) + ISTATE(:NSTATE)=0 + ISTATE(1)=MAXMIX + ISTATE(2)=NBISO + ISTATE(3)=NGRO + ISTATE(4)=NL + ISTATE(5)=ITRANC + ISTATE(6)=IPROB + ISTATE(7)=ITIME + ISTATE(8)=NLIB + ISTATE(9)=NGF + ISTATE(10)=NGFR + ISTATE(11)=NIDEPL + ISTATE(12)=NCOMB + ISTATE(13)=NEDMAC + ISTATE(14)=NBMIX + ISTATE(15)=NRES + ISTATE(17)=IPROC + ISTATE(18)=IMAC + ISTATE(19)=NDEL + ISTATE(20)=NFISS + ISTATE(21)=ISOADD + ISTATE(22)=MAXISM + ISTATE(23)=IPRECI + ISTATE(27)=STERN + CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,ISTATE) + GO TO 250 + ELSE + CALL XABORT(NAMSBR//': '//CARLIR//' IS AN INVALID KEY-WORD.') + ENDIF + GO TO 130 +*---- +* PROCESS THE LIB: MODULE INPUT DATA. +*---- + 240 CONTINUE + IF(MAXMIX.EQ.0) CALL XABORT(NAMSBR//': MAXMIX NOT YET DEFINED.') + MAXISO=MAX(NIDEPL,MAXISM)*MAXMIX + IF(ITPROC .EQ. 1) THEN + CALL LIBINP(MAXMIX,MAXED ,MAXISO,IPLIB ,INDREC,IPRINT, + > NBISO ,NGRO ,NGT ,NL ,ITRANC,IPROB , + > ITIME ,NLIB ,NGF ,NGFR ,NIDEPL,NCOMB , + > NEDMAC,NBMIX ,NRES ,IPROC ,IMAC ,NDEL , + > ISOADD,MAXISM,HVECT ,IPRECI,SVDEPS,STERN) + ELSE IF(ITPROC .EQ. 2) THEN + IF(NGRO .EQ. 0) CALL XABORT(NAMSBR// + > ': NUMBER OF GROUP REQUIRED FOR MAXS OF BURN') + CALL LIBMAC(IPLIB ,IPLIBX,IPBURX,IPRINT,MAXISO,NBISO , + > NBISOX,IBSTEP,NBMIX ,NBMIXX,NGRO ,TMPDAY) + ELSE IF(ITPROC .EQ. 3) THEN + ! catenate two microlibs + CALL LCMGET(IPLIBX,'STATE-VECTOR',ISTATE) + MAXISO=MAX(MAXISO,NBISO+ISTATE(2)) + CALL LIBCTL(MAXMIX,MAXISO,IPLIB,IPLIBX,INDREC,IMAC,ISOADD, + > NIDEPL,IPRINT,NBISO,NBMIX) + ENDIF + 250 IF(IPRINT .GE. 5) CALL LCMLIB(IPLIB) + RETURN +*---- +* FORMATS +*---- + 6000 FORMAT(' LIBRARY UPDATE AT BURNUP STEP : ',I5, + > ' BURNUP TIME = ',F20.7,' DAYS') + 9000 FORMAT(' **** WARNING *****'/ + > ' INVALID BURNUP TIME =',F20.7,' DAYS'/ + > ' BURNUP TABULATION (DAYS) ') + 9001 FORMAT(6F20.7) + 9002 FORMAT(' BURNUP STEP SELECTED =',F20.7,' DAYS') + 9010 FORMAT(' **** WARNING *****'/ + > ' BURNUP STEP NEGATIVE '/ + > ' USE FIRST BURNUP STEP AT ',F20.7,' DAYS') + 9011 FORMAT(' **** WARNING *****'/ + > ' BURNUP STEP TOO LARGE '/ + > ' USE LAST BURNUP STEP AT ',F20.7,' DAYS') + END diff --git a/Dragon/src/LIBA20.f b/Dragon/src/LIBA20.f new file mode 100644 index 0000000..73b65fc --- /dev/null +++ b/Dragon/src/LIBA20.f @@ -0,0 +1,1346 @@ +*DECK LIBA20 + SUBROUTINE LIBA20 (IPLIB,NAMFIL,NGRO,NBISO,NL,IPROC,ISONAM, + 1 ISONRF,IPISO,ISHINA,MASKI,TN,SN,SB,IMPX,NGF,NGFR,NDEL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transcription of the useful interpolated microscopic cross section +* data from APOLIB-2 to LCM data structures. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* NAMFIL name of the APOLIB-2 file. +* NGRO number of energy groups. +* NBISO number of isotopes present in the calculation domain. +* NL number of Legendre orders required in the calculation +* NL=1 or higher. +* IPROC type of library processing. +* ISONAM alias name of isotopes. +* ISONRF library reference name of isotopes. +* IPISO pointer array towards microlib isotopes. +* ISHINA self shielding names. +* MASKI isotopic mask. Isotope with index I is processed if +* MASKI(I) is .true. +* TN temperature of each isotope. +* SN dilution cross section in each energy group of each. +* isotope. a value of 1.0E10 is used for infinite dilution. +* SB dilution cross section as used by Livolant and Jeanpierre +* normalization. +* IMPX print flag. +* +*Parameters: output +* NGF number of fast groups without self-shielding. +* NGFR number of fast and resonance groups. +* NDEL number of precursor groups for delayed neutrons. +* +*Reference: +* A. Hebert, P. Bellier, M. Coste, R. Sanchez, Z. Stankovski et +* I. Zmijarevic, "APOLLO2: Notice informatique Version 2.4", +* Commissariat a l'Energie Atomique, +* Rapport SERMA/LENR/RT/98-2477/A, 1998. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB,IPISO(NBISO) + INTEGER NGRO,NBISO,NL,IPROC,ISONAM(3,NBISO),ISONRF(3,NBISO), + 1 ISHINA(3,NBISO),IMPX,NGF,NGFR,NDEL + REAL TN(NBISO),SN(NGRO,NBISO),SB(NGRO,NBISO) + CHARACTER NAMFIL*(*) + LOGICAL MASKI(NBISO) +*---- +* LOCAL VARIABLES +*---- + LOGICAL LSACO + PARAMETER (NXSMAX=10,IOUT=6,MAXHOM=9,LSACO=.FALSE.) +* NOTE: LSACO MUST BE SET TO .TRUE. WITH THE SANCHEZ-COSTE METHOD. + TYPE(C_PTR) KPLIB + EXTERNAL LIBA21 + CHARACTER TEXT8*8,TEXT20*20,TEXT80*80,NOMOBJ*20,TYPOBJ*8, + 1 TYPSEG*8,HNAMIS*12,HNISOR*12,HNISSS*12,HSMG*131,TEXT2*2, + 2 TEXT12*12 + LOGICAL LPFIX,LTRAN,LGPROB,LGTDIF,LGTTRA,LN2N,LPTHOM,L104,LABS, + 1 LDIF,LFIS,LPWD,LPED + INTEGER ZFISS,FGTD,FGHOMO,FGRESO,FAGG,FDGG,WGAL,FAG + DOUBLE PRECISION UU,XDRCST + INTEGER ITHOMO(MAXHOM),ITEXT(20),ISFICH(3),IPAR(3) + REAL TKT(5) +* + INTEGER TKCARO(31) + SAVE TKCARO + DATA TKCARO / + & 0, 1, 2, 3, 4, 5, 6, 30, 7, -8, + & 9, -10, 11, -12, 13, -14, 15, 16, -17, 18, + & -19, 20, -21, 22, 23, -24, 25, -26, 27, -28, + & 29 / +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPRO,NFS,KDS,LGS,NOM,NOMS, + 1 NOMOB,VINTE,ITCARO,ITC104,ITS104,ITITLE,IZSECT,ISECTT,IFDG,IIAD, + 2 IDEPL + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IPR + REAL, ALLOCATABLE, DIMENSION(:) :: ENERG,DELTA,SECT,XSTOT,TAUX, + 1 DELTF,SIGTF,SIGAF,ENER,AMASS,TEMP,TEMPS,SEQHO,SQRTE,PWD,PED + REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGS + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LGTRE + TYPE(C_PTR) ICHDIM_PTR,ICHTYP_PTR,ICHDKL_PTR,TSEGM_PTR + INTEGER, POINTER, DIMENSION(:) :: ICHDIM,ICHTYP,ICHDKL,ITSEGM + REAL, POINTER, DIMENSION(:) :: RTSEGM + LOGICAL, POINTER, DIMENSION(:) :: LTSEGM +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IPR(7+2*(NL-1),NBISO),ITYPRO(NL),NFS(NGRO)) + ALLOCATE(ENERG(NGRO+1),DELTA(NGRO),SECT(NGRO),SIGS(NGRO,NL), + 1 SCAT(NGRO,NGRO,NL),XSTOT(NGRO)) +* + ANEUT=REAL(XDRCST('Neutron mass','amu')) + NGF=NGRO+1 + NGFR=0 + NDEL=0 + IF(IMPX.GT.0) WRITE (IOUT,800) NAMFIL +*---- +* OPEN AND PROBE THE APOLIB-2 FILE. +*---- + TKT(:5)=0.0 + CALL KDRCPU(TK1) + CALL AEXTPA(NAMFIL,ISFICH) + IADRES=ISFICH(1) + NBOBJ=ISFICH(2) + LBLOC=ISFICH(3) + IUNIT=KDROPN(NAMFIL,2,4,LBLOC) + IF(IUNIT.LE.0) THEN + TEXT12=NAMFIL + CALL XABORT('LIBA20: APOLLO-2 LIBRARY '//TEXT12//' CANNOT B'// + 1 'E OPENED') + ENDIF +*---- +* INDEX THE APOLIB-2 FILE. +*---- + IDKNO=1-TKCARO(14) + IDKTY=1-TKCARO(21) + IDKDS=1-TKCARO(10) + IDKTS=1-TKCARO(23) + IDKDA=1-TKCARO(26) + IDKNS=TKCARO(2)+1 + IDKLS=TKCARO(8) + ALLOCATE(KDS(NBOBJ-3),LGS(NBOBJ-3),NOMOB(7*(NBOBJ-3))) + KDS(:NBOBJ-3)=0 + LGS(:NBOBJ-3)=0 + NOMOB(:7*(NBOBJ-3))=0 + CALL LCMSIX(IPLIB,'INDEX',1) + TEXT12=NAMFIL + CALL LCMLEN(IPLIB,TEXT12,ILENG,ITYLCM) + CALL LCMSIX(IPLIB,TEXT12,1) + IF(ILENG.NE.0) THEN +* RECOVER AN EXISTING INDEX. + CALL LCMGET(IPLIB,'IPAR',IPAR) + CALL LCMGET(IPLIB,'KDS',KDS) + CALL LCMGET(IPLIB,'LGS',LGS) + CALL LCMGET(IPLIB,'NOMOB',NOMOB) + ELSE +* CREATE A NEW INDEX. + ALLOCATE(VINTE(2*NBOBJ)) + CALL AEXDIR(IUNIT,LBLOC,VINTE,IADRES,2*NBOBJ) + NSEGM=0 + DO 10 IOBJ=3,NBOBJ + IDKOBJ=VINTE(2*IOBJ-1) + LGSEG=VINTE(2*IOBJ)+1 + ALLOCATE(ITCARO(LGSEG)) + CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG) + IDK=ITCARO(IDKNO) + CALL AEXCPC(IDK,20,ITCARO(1),NOMOBJ) + IDK=ITCARO(IDKTY) + CALL AEXCPC(IDK,8,ITCARO(1),TYPOBJ) + JDKDS=ITCARO(IDKDS) + JDKTS=ITCARO(IDKTS) + NS=ITCARO(IDKNS) + IDK=ITCARO(IDKDA) + CALL AEXCPC(IDK,8,ITCARO(1),TEXT8) + IF(TYPOBJ.EQ.'APOLIB') THEN + IPAR(2)=IDKOBJ + IPAR(3)=LGSEG + ELSE IF(TYPOBJ.EQ.'APOLIBE') THEN + NSEGM=NSEGM+1 + ISO2=(NSEGM-1)*7+1 + CALL LCMCAR(NOMOBJ,.TRUE.,NOMOB(ISO2)) + CALL LCMCAR(TEXT8,.TRUE.,NOMOB(ISO2+5)) + KDS(NSEGM)=IDKOBJ + LGS(NSEGM)=LGSEG + ELSE + CALL XABORT('LIBA20: WEIRD SEGMENT TYPE: '//TYPOBJ//'.') + ENDIF + DEALLOCATE(ITCARO) + 10 CONTINUE + DEALLOCATE(VINTE) + IPAR(1)=NSEGM +* +* SAVE THE INDEX. + CALL LCMPUT(IPLIB,'IPAR',3,1,IPAR) + CALL LCMPUT(IPLIB,'NOMOB',7*(NBOBJ-3),1,NOMOB) + CALL LCMPUT(IPLIB,'KDS',NBOBJ-3,1,KDS) + CALL LCMPUT(IPLIB,'LGS',NBOBJ-3,1,LGS) + ENDIF + CALL LCMSIX(IPLIB,' ',2) + CALL LCMSIX(IPLIB,' ',2) +*---- +* RECOVER GENERIC INFORMATION FROM THE APOLIB SEGMENT. +*---- + NSEGM=IPAR(1) + IDKOBJ=IPAR(2) + LGSEG=IPAR(3) + NISOT=0 + NISOTS=0 + NAMASS=0 + IDKCOM=0 + ISCOM=0 + ALLOCATE(ITCARO(LGSEG)) + CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG) + IDK=ITCARO(IDKNO) + CALL AEXCPC(IDK,20,ITCARO(1),NOMOBJ) + IDK=ITCARO(IDKTY) + CALL AEXCPC(IDK,8,ITCARO(1),TYPOBJ) + JDKDS=ITCARO(IDKDS) + JDKTS=ITCARO(IDKTS) + NS=ITCARO(IDKNS) + IDK=ITCARO(IDKDA) + CALL AEXCPC(IDK,8,ITCARO(1),TEXT8) + IF(TYPOBJ.NE.'APOLIB') CALL XABORT('LIBA20: UNABLE TO FIND TH'// + 1 'E APOLIB SEGMENT.') + DO 80 IS=1,NS + IDK=JDKTS+8*(IS-1) + CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG) + LNGS=ITCARO(IDKLS+IS) + IF(LNGS.LE.0) GO TO 80 + JDKS=ITCARO(JDKDS+IS) + CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR,ICHDKL_PTR) + CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) + CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) + CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) + TSEGM_PTR=LCMARA(LNGS+1) + CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) + CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /)) + CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1) + IF(TYPSEG.EQ.'PHEAD') THEN + CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + CALL AEXCPC(0,NV,ITSEGM(IDK),TEXT80) + IF((IMPX.GT.0).AND.(NV.GT.0)) WRITE (IOUT,810) TEXT80 + CALL AEXGNV(3,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + IF(NV.EQ.0) THEN + TEXT12=NAMFIL + CALL XABORT('LIBA20: NO ISOTOPES PRESENT ON APOLIB-2 FIL'// + 1 'E NAMED: '//TEXT12) + ENDIF + NISOT=NV/20 + ALLOCATE(NOM(5*NISOT)) + IF(IMPX.GE.10) THEN + WRITE(IOUT,'(/41H LIBA20: STANDARD ISOTOPE NAMES PRESENT I, + 1 10HN LIBRARY:)') + ENDIF + DO 20 ISO=1,NISOT + ISO2=(ISO-1)*5+1 + CALL AEXCPC(0,20,ITSEGM(IDK+ISO2-1),TEXT20) + IF(IMPX.GE.10) WRITE(IOUT,'(8H -----> ,A20)') TEXT20 + CALL LCMCAR(TEXT20,.TRUE.,NOM(ISO2)) + 20 CONTINUE + CALL AEXGNV(6,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + NISOTS=NV/20 + IF(NISOTS.GT.0) THEN + ALLOCATE(NOMS(5*NISOTS)) + IF(IMPX.GE.10) THEN + WRITE(IOUT,'(/38H LIBA20: SELF-SHIELDED ISOTOPE NAMES P, + 1 18HRESENT IN LIBRARY:)') + ENDIF + DO 30 ISO=1,NISOTS + ISO2=(ISO-1)*5+1 + CALL AEXCPC(0,20,ITSEGM(IDK+ISO2-1),TEXT20) + IF(IMPX.GE.10) WRITE(IOUT,'(8H -----> ,A20)') TEXT20 + CALL LCMCAR(TEXT20,.TRUE.,NOMS(ISO2)) + 30 CONTINUE + ENDIF + ELSE IF(TYPSEG.EQ.'PMAIL') THEN + CALL AEXGNV(3,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + IF(NV-1.NE.NGRO) CALL XABORT('LIBA20: BAD GROUP STRUCTURE.') + DO 40 IG=1,NV + ENERG(IG)=RTSEGM(IDK+IG-1)*1.0E6 + 40 CONTINUE + CALL AEXGNV(5,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + IF(NV.EQ.NGRO) THEN + DO 50 IG=1,NGRO + DELTA(IG)=RTSEGM(IDK+IG-1) + 50 CONTINUE + ELSE + DO 60 IG=1,NGRO + DELTA(IG)=LOG(ENERG(IG)/ENERG(IG+1)) + 60 CONTINUE + ENDIF + CALL LCMPUT(IPLIB,'ENERGY',NGRO+1,2,ENERG) + CALL LCMPUT(IPLIB,'DELTAU',NGRO,2,DELTA) + ELSE IF(TYPSEG.EQ.'PCONST') THEN + CALL AEXGNV(13,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NAMASS) + ALLOCATE(AMASS(NAMASS)) + DO 70 IA=1,NAMASS + AMASS(IA)=RTSEGM(IDK+IA-1)/ANEUT + 70 CONTINUE + ELSE IF(TYPSEG.EQ.'PCOM') THEN +* ISOTOPE-DEPENDENT COMMENTS ARE AVAILABLE. + IDKCOM=IDKOBJ + LGCOM=LGSEG + ISCOM=IS + ENDIF + CALL LCMDRD(TSEGM_PTR) + CALL LCMDRD(ICHDIM_PTR) + CALL LCMDRD(ICHTYP_PTR) + CALL LCMDRD(ICHDKL_PTR) + 80 CONTINUE + DEALLOCATE(ITCARO) + IF(NAMASS.NE.NISOT) CALL XABORT('LIBA20: INVALID AWR INFO.') +*---- +* SET THE CORRESPONDANCE BETWEEN THE APOLIB AND THE LIST OF ISOTOPES. +*---- + IF(IMPX.GT.1) WRITE(IOUT,820) NISOT,NISOTS,NSEGM + CALL LIBA27(NAMFIL,NBISO,NISOT,NSEGM,NL,ISONRF,ISHINA,MASKI, + 1 NOM,NOMOB,IPR) + DEALLOCATE(NOM) + IF(NISOTS.GT.0) DEALLOCATE(NOMS) + CALL KDRCPU(TK2) + TKT(1)=TK2-TK1 +*---- +* READ THROUGH APOLIB-2 FILE AND ACCUMULATE CROSS SECTIONS FOR THIS +* RANGE OF MATS, LEGENDRE ORDERS, AND GROUPS. +*---- + CALL LCMGET(IPLIB,'ENERGY',ENERG) + DO 560 IMX=1,NBISO +*---- +* PROCESS INFINITE DILUTION INFORMATION. +*---- + KISEG=IPR(2,IMX) + IF(KISEG.GT.0) THEN + IF(IMPX.GT.1) WRITE(IOUT,'(/29H LIBA20: PROCESSING ISOTOPE '', + 1 3A4,2H''.)') (ISONRF(I0,IMX),I0=1,3) +* +* RECOVER THE ISOTOPE TITLE. + CALL KDRCPU(TK1) + IF(IDKCOM.EQ.0) THEN +* MAKE A NEW TITLE. + ISO2=(KISEG-1)*7+1 + CALL LCMCAR(NOMOBJ,.FALSE.,NOMOB(ISO2)) + CALL LCMCAR(TEXT8,.FALSE.,NOMOB(ISO2+5)) + TEXT80='APOLIB-2 ISOTOPE:'//NOMOBJ(7:)//TEXT8 + ELSE +* RECOVER THE TITLE FROM THE PCOM SEGMENT. + IF(IPR(1,IMX).LE.0) CALL XABORT('LIBA20: BAD TITLE.') + ALLOCATE(ITITLE(LGCOM)) + CALL AEXDIR(IUNIT,LBLOC,ITITLE,IDKCOM,LGCOM) + JDKDS=ITITLE(IDKDS) + JDKTS=ITITLE(IDKTS) + NS=ITITLE(IDKNS) + IDK=JDKTS+8*(ISCOM-1) + CALL AEXCPC(IDK,8,ITITLE(1),TYPSEG) + IF(TYPSEG.NE.'PCOM') CALL XABORT('LIBA20: SEGMENT ERROR.') + LNGS=ITITLE(IDKLS+ISCOM) + IF(LNGS.LE.0) CALL XABORT('LIBA20: LENGTH ERROR.') + JDKS=ITITLE(JDKDS+ISCOM) + CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, + 1 ICHDKL_PTR) + CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) + CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) + CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) + TSEGM_PTR=LCMARA(LNGS+1) + CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) + CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1) + CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + ISO2=(IPR(1,IMX)-1)*20+1 + CALL AEXCPC(0,NV,ITSEGM(IDK+ISO2-1),TEXT80) + CALL LCMDRD(TSEGM_PTR) + CALL LCMDRD(ICHDIM_PTR) + CALL LCMDRD(ICHTYP_PTR) + CALL LCMDRD(ICHDKL_PTR) + DEALLOCATE(ITITLE) + ENDIF + READ(TEXT80,'(20A4)') (ITEXT(I),I=1,20) + IF(IMPX.GT.2) WRITE(IOUT,870) TEXT80 +* + IDKOBJ=KDS(KISEG) + LGSEG=LGS(KISEG) + ALLOCATE(ITCARO(LGSEG)) + CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG) + IDK=ITCARO(IDKNO) + CALL AEXCPC(IDK,20,ITCARO(1),NOMOBJ) + IDK=ITCARO(IDKTY) + CALL AEXCPC(IDK,8,ITCARO(1),TYPOBJ) + JDKDS=ITCARO(IDKDS) + JDKTS=ITCARO(IDKTS) + NS=ITCARO(IDKNS) +*---- +* RECOVER THE INFINITE DILUTION CROSS SECTION NUMEROTATION. +*---- + LPFIX=.FALSE. + LTRAN=.FALSE. + DO 160 IS=1,NS + IDK=JDKTS+8*(IS-1) + CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG) + LNGS=ITCARO(IDKLS+IS) + IF(LNGS.LE.0) GO TO 160 + JDKS=ITCARO(JDKDS+IS) + CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, + 1 ICHDKL_PTR) + CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) + CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) + CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) + TSEGM_PTR=LCMARA(LNGS+1) + CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) + CALL C_F_POINTER(TSEGM_PTR,LTSEGM,(/ LNGS+1 /)) + CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /)) + CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1) + IF(TYPSEG.EQ.'PFIX') THEN + LPFIX=.TRUE. + CALL AEXGNV(2,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + ZFISS=ITSEGM(IDK) + CALL AEXGNV(4,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + LGPROB=LTSEGM(IDK) + CALL AEXGNV(5,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + LGTDIF=LTSEGM(IDK) + CALL AEXGNV(6,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + LGTTRA=LTSEGM(IDK) + CALL AEXGNV(7,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + FGTD=ITSEGM(IDK) + CALL AEXGNV(8,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + ID2=ITSEGM(IDK) + CALL AEXGNV(12,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NSECTT) + ALLOCATE(IZSECT(NSECTT)) + NSETOT=0 + NPHY=MAX(0,NSECTT-5) + DO 90 I=1,NSECTT + IZSECT(I)=ITSEGM(IDK+I-1) + IF((IZSECT(I).NE.0).AND.(I.LE.5)) NSETOT=NSETOT+1 + 90 CONTINUE + IF(IMPX.GT.2) WRITE(IOUT,875) (IZSECT(I),I=1,NSECTT) + CALL AEXGNV(14,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NANISD) + CALL AEXGNV(16,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NANIST) + CALL AEXGNV(18,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NSECTT) + ALLOCATE(LGTRE(NSECTT)) + DO 100 I=1,NSECTT + LGTRE(I)=LTSEGM(IDK+I-1) + 100 CONTINUE + CALL AEXGNV(24,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NTEMP) + ALLOCATE(TEMP(NTEMP)) + DO 110 I=1,NTEMP + TEMP(I)=RTSEGM(IDK+I-1) + 110 CONTINUE + IF(IMPX.GT.2) WRITE(IOUT,880) (TEMP(I),I=1,NTEMP) + CALL AEXGNV(26,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + IF(NV/8.NE.NSECTT) CALL XABORT('LIBA20: INVALID TYPSECT.') + ALLOCATE(ISECTT(2*NSECTT)) + III=0 + DO 120 I=1,NSECTT + I2=(I-1)*2+1 + IF(IZSECT(I).NE.0) THEN + III=III+1 + I3=(III-1)*2+1 + CALL AEXCPC(0,8,ITSEGM(IDK+I2-1),TEXT8) + CALL LCMCAR(TEXT8,.TRUE.,ISECTT(I3)) + ENDIF + 120 CONTINUE + IF(IMPX.GT.2) WRITE(IOUT,890) ZFISS,LGPROB,LGTDIF,LGTTRA, + 1 FGTD,ID2,NSECTT,NSETOT,NPHY,NANISD,NANIST,(LGTRE(I),I=1, + 2 NSECTT) + IF(NANIST.GT.NANISD) CALL XABORT('LIBA20: NANIST.GT.NANISD') + ELSE IF(TYPSEG.EQ.'PPPSN') THEN + LTRAN=.TRUE. + CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + FAGG=ITSEGM(IDK) + CALL AEXGNV(2,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + LAGG=ITSEGM(IDK) + CALL AEXGNV(3,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + FDGG=ITSEGM(IDK) + CALL AEXGNV(4,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + WGAL=ITSEGM(IDK) + CALL AEXGNV(5,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + FAG=ITSEGM(IDK) + CALL AEXGNV(6,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + LAG=ITSEGM(IDK) + CALL AEXGNV(7,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + IF(NV.NE.NGRO) CALL XABORT('LIBA20: INVALID LIBRARY(1).') + ALLOCATE(IFDG(NV)) + DO 130 I=1,NV + IFDG(I)=ITSEGM(IDK+I-1) + 130 CONTINUE + CALL AEXGNV(9,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + IF(NV.NE.NGRO+1) CALL XABORT('LIBA20: INVALID LIBRARY(2).') + ALLOCATE(IIAD(NV)) + DO 140 I=1,NV + IIAD(I)=ITSEGM(IDK+I-1) + 140 CONTINUE + CALL AEXGNV(11,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NGTD) + ALLOCATE(IDEPL(NGTD)) + DO 150 I=1,NGTD + IDEPL(I)=ITSEGM(IDK+I-1) + 150 CONTINUE + IF(IMPX.GT.2) WRITE(IOUT,900) FAGG,LAGG,FDGG,WGAL,FAG,LAG, + 1 NGTD + ENDIF + CALL LCMDRD(TSEGM_PTR) + CALL LCMDRD(ICHDIM_PTR) + CALL LCMDRD(ICHTYP_PTR) + CALL LCMDRD(ICHDKL_PTR) + 160 CONTINUE + IF(.NOT.LPFIX) CALL XABORT('LIBA20: NO PFIX SEGMENT.') +*---- +* RECOVER THE INFINITE DILUTION CROSS SECTIONS. +*---- + ITSEC=0 + NDIFG=0 + NPSN=0 + DO 220 IS=1,NS + IDK=JDKTS+8*(IS-1) + CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG) + LNGS=ITCARO(IDKLS+IS) + IF(LNGS.LE.0) GO TO 220 + JDKS=ITCARO(JDKDS+IS) + CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, + 1 ICHDKL_PTR) + CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) + CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) + CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) + TSEGM_PTR=LCMARA(LNGS+1) + CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) + CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /)) + CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1) + IF(TYPSEG.EQ.'PSECT') THEN +* RECOVER A VECTOR CROSS SECTION. + ITSEC=ITSEC+1 + IF(ITSEC.GT.NXSMAX) THEN + CALL XABORT('LIBA20: SECT OVERFLOW.') + ELSE IF(ITSEC.LE.NSETOT) THEN + I3=(ITSEC-1)*2+1 + CALL LCMCAR(TEXT8,.FALSE.,ISECTT(I3)) + ELSE IF(ITSEC.EQ.NSETOT+1) THEN + TEXT8='SIGS00' + ELSE IF(ITSEC.GT.NSETOT+1) THEN + CALL XABORT('LIBA20: UNKNOWN CROSS SECTION TYPE(1).') + ENDIF + CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + DO 190 JMX=IMX,NBISO + IF(IPR(2,JMX).EQ.KISEG) THEN + KPLIB=IPISO(JMX) ! set JMX-th isotope + CALL LCMLEN(KPLIB,'ALIAS',ILENG,ITYLCM) + IF(ILENG.EQ.0) THEN + WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3) + CALL LCMPTC(KPLIB,'ALIAS',12,HNAMIS) + IF(IPR(1,JMX).LE.0) CALL XABORT('LIBA20: BAD AWR.') + CALL LCMPUT(KPLIB,'AWR',1,2,AMASS(IPR(1,JMX))) + CALL LCMPUT(KPLIB,'README',20,3,ITEXT) + ENDIF + IF(ITSEC.EQ.1) THEN + SIGS(:NGRO,1)=0.0 + CALL LCMPUT(KPLIB,'SIGS00',NGRO,2,SIGS) + CALL LCMPUT(KPLIB,'NTOT0',NGRO,2,SIGS) + ENDIF + CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM(IDK), + 1 SECT) + IF(TEXT8.EQ.'SIGA') THEN + CALL LCMPUT(KPLIB,'NTOT0',NGRO,2,SECT) + ELSE IF(TEXT8.EQ.'NEXCESS') THEN + LN2N=.FALSE. + DO 170 IG=1,NGRO + LN2N=LN2N.OR.(SECT(IG).NE.0.0) + 170 CONTINUE + IF(LN2N) THEN + CALL LCMPUT(KPLIB,'N2N',NGRO,2,SECT) + CALL LCMPUT(KPLIB,'SIGS00',NGRO,2,SECT) + ENDIF + ELSE IF(TEXT8.EQ.'SIGF') THEN + CALL LCMPUT(KPLIB,'NFTOT',NGRO,2,SECT) + ELSE IF(TEXT8.EQ.'NUSIGF') THEN + CALL LCMPUT(KPLIB,'NUSIGF',NGRO,2,SECT) + ELSE IF(TEXT8.EQ.'CHI') THEN + CALL LCMPUT(KPLIB,'CHI',NGRO,2,SECT) + ELSE IF(TEXT8.EQ.'SIGS00') THEN + CALL LCMGET(KPLIB,'NTOT0',XSTOT) + CALL LCMGET(KPLIB,'SIGS00',SIGS) + NDIFG=NV + DO 180 IG=1,NGRO + XSTOT(IG)=XSTOT(IG)+SECT(IG) + SIGS(IG,1)=SIGS(IG,1)+SECT(IG) + 180 CONTINUE + CALL LCMPUT(KPLIB,'NTOT0',NGRO,2,XSTOT) + CALL LCMPUT(KPLIB,'SIGS00',NGRO,2,SIGS) + ELSE + CALL XABORT('LIBA20: UNKNOWN X-S TYPE:'//TEXT8) + ENDIF + ENDIF + 190 CONTINUE + ELSE IF(TYPSEG.EQ.'PPSN') THEN +* RECOVER A MATRIX CROSS SECTION. + IF(.NOT.LTRAN) CALL XABORT('LIBA20: PPPSN MISSING.') + CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + NPSN=NV + DO 210 JMX=IMX,NBISO + IF(IPR(2,JMX).EQ.KISEG) THEN + KPLIB=IPISO(JMX) ! set JMX-th isotope + SCAT(:NGRO,:NGRO,1)=0.0 + CALL LIBA23(NGRO,1,TN(JMX),NTEMP,NGTD,NV,TEMP,FGTD,ID2, + 1 FAGG,LAGG,FDGG,WGAL,FAG,LAG,IFDG,IIAD,IDEPL,RTSEGM(IDK), + 2 SCAT) + CALL LCMGET(KPLIB,'SIGS00',SIGS) + IF(LGPROB) THEN + DO 205 IG=1,NGRO + DO 200 JG=1,NGRO + SCAT(JG,IG,1)=SCAT(JG,IG,1)*SIGS(IG,1) + 200 CONTINUE + 205 CONTINUE + ENDIF + CALL XDRLGS(KPLIB,1,IMPX,0,0,1,NGRO,SIGS,SCAT,ITYPRO) + ENDIF + 210 CONTINUE + ENDIF + CALL LCMDRD(TSEGM_PTR) + CALL LCMDRD(ICHDIM_PTR) + CALL LCMDRD(ICHTYP_PTR) + CALL LCMDRD(ICHDKL_PTR) + 220 CONTINUE + DEALLOCATE(ITCARO) + DO 240 JMX=IMX,NBISO + IF(IPR(2,JMX).EQ.KISEG) THEN + IF(.NOT.LTRAN) THEN + KPLIB=IPISO(JMX) ! set JMX-th isotope + CALL LCMGET(KPLIB,'SIGS00',SIGS) + SCAT(:NGRO,:NGRO,1)=0.0 + DO 230 IG=1,NGRO + SCAT(IG,IG,1)=SIGS(IG,1) + 230 CONTINUE + CALL XDRLGS(KPLIB,1,IMPX,0,0,1,NGRO,SIGS,SCAT,ITYPRO) + ENDIF + IPR(2,JMX)=0 + ENDIF + 240 CONTINUE + CALL KDRCPU(TK2) + TKT(2)=TKT(2)+(TK2-TK1) +*---- +* RECOVER SCATTERING X-S FOR HIGHER LEGENDRE ORDERS. +*---- + CALL KDRCPU(TK1) + DO 270 IL=2,MIN(NANISD,NL) + WRITE(TEXT2,'(I2.2)') IL-1 + KISEG=IPR(7+(IL-1),IMX) + IF(KISEG.EQ.0) THEN + WRITE(HNAMIS,'(3A4)') (ISONAM(I0,IMX),I0=1,3) + WRITE(HNISOR,'(3A4)') (ISONRF(I0,IMX),I0=1,3) + WRITE(HSMG,830) IL-1,HNAMIS,HNISOR,NAMFIL + CALL XABORT(HSMG) + ENDIF + IDKOBJ=KDS(KISEG) + LGSEG=LGS(KISEG) + ALLOCATE(ITCARO(LGSEG)) + CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG) + LDKDS=ITCARO(IDKDS) + LDKTS=ITCARO(IDKTS) + IF(ITCARO(IDKNS).NE.1) CALL XABORT('LIBA20: INVALID DIFF(1).') + CALL AEXCPC(LDKTS,8,ITCARO(1),TYPSEG) + IF(TYPSEG.NE.'PSECT') CALL XABORT('LIBA20: INVALID DIFF(2).') + LNGS=ITCARO(IDKLS+1) + IF(LNGS.LE.0) CALL XABORT('LIBA20: INVALID DIFF(3).') + LDKS=ITCARO(LDKDS+1) + CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, + 1 ICHDKL_PTR) + CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) + CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) + CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) + TSEGM_PTR=LCMARA(LNGS+1) + CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) + CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /)) + CALL AEXDIR(IUNIT,LBLOC,ITSEGM,LDKS,LNGS+1) + CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + IF(NV.NE.NDIFG) CALL XABORT('LIBA20: INVALID DIFF(4).') + CALL LCMDRD(ICHDIM_PTR) + CALL LCMDRD(ICHTYP_PTR) + CALL LCMDRD(ICHDKL_PTR) + DEALLOCATE(ITCARO) + DO 260 JMX=IMX,NBISO + IF(IPR(7+(IL-1),JMX).EQ.KISEG) THEN + KPLIB=IPISO(JMX) ! set JMX-th isotope + CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM(IDK), + 1 SECT) + CALL LCMPUT(KPLIB,'SIGS'//TEXT2,NGRO,2,SECT) + IF(IL.GT.NANIST) THEN + SCAT(:NGRO,:NGRO,1)=0.0 + DO 250 IG=1,NGRO + SIGS(IG,1)=SECT(IG) + SCAT(IG,IG,1)=SECT(IG) + 250 CONTINUE + CALL XDRLGS(KPLIB,1,IMPX,IL-1,IL-1,1,NGRO,SIGS,SCAT, + 1 ITYPRO) + ENDIF + IPR(7+(IL-1),JMX)=0 + ENDIF + 260 CONTINUE + CALL LCMDRD(TSEGM_PTR) + 270 CONTINUE +*---- +* RECOVER TRANSFER MATRICES FOR HIGHER LEGENDRE ORDERS. +*---- + DO 300 IL=2,MIN(NANIST,NL) + WRITE(TEXT2,'(I2.2)') IL-1 + KISEG=IPR(7+(NL-1)+(IL-1),IMX) + IF(KISEG.EQ.0) THEN + WRITE(HNAMIS,'(3A4)') (ISONAM(I0,IMX),I0=1,3) + WRITE(HNISOR,'(3A4)') (ISONRF(I0,IMX),I0=1,3) + WRITE(HSMG,830) IL-1,HNAMIS,HNISOR,NAMFIL + CALL XABORT(HSMG) + ENDIF + IDKOBJ=KDS(KISEG) + LGSEG=LGS(KISEG) + ALLOCATE(ITCARO(LGSEG)) + CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG) + LDKDS=ITCARO(IDKDS) + LDKTS=ITCARO(IDKTS) + IF(ITCARO(IDKNS).NE.1) CALL XABORT('LIBA20: INVALID TRAN(1).') + CALL AEXCPC(LDKTS,8,ITCARO(1),TYPSEG) + IF(TYPSEG.NE.'PPSN') CALL XABORT('LIBA20: INVALID TRAN(2).') + LNGS=ITCARO(IDKLS+1) + IF(LNGS.LE.0) CALL XABORT('LIBA20: INVALID TRAN(3).') + LDKS=ITCARO(LDKDS+1) + CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, + 1 ICHDKL_PTR) + CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) + CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) + CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) + TSEGM_PTR=LCMARA(LNGS+1) + CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) + CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /)) + CALL AEXDIR(IUNIT,LBLOC,ITSEGM,LDKS,LNGS+1) + CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + IF(NV.NE.NPSN) CALL XABORT('LIBA20: INVALID TRAN(4).') + CALL LCMDRD(ICHDIM_PTR) + CALL LCMDRD(ICHTYP_PTR) + CALL LCMDRD(ICHDKL_PTR) + DEALLOCATE(ITCARO) + DO 290 JMX=IMX,NBISO + IF(IPR(7+(NL-1)+(IL-1),JMX).EQ.KISEG) THEN + KPLIB=IPISO(JMX) ! set JMX-th isotope + CALL LIBA23(NGRO,IL,TN(JMX),NTEMP,NGTD,NV,TEMP,FGTD,ID2, + 1 FAGG,LAGG,FDGG,WGAL,FAG,LAG,IFDG,IIAD,IDEPL,RTSEGM(IDK), + 2 SCAT) + CALL LCMGET(KPLIB,'SIGS'//TEXT2,SIGS) + IF(LGPROB) THEN + DO 285 IG=1,NGRO + DO 280 JG=1,NGRO + SCAT(JG,IG,1)=SCAT(JG,IG,1)*SIGS(IG,1) + 280 CONTINUE + 285 CONTINUE + ENDIF + CALL XDRLGS(KPLIB,1,IMPX,IL-1,IL-1,1,NGRO,SIGS,SCAT,ITYPRO) + IPR(7+(NL-1)+(IL-1),JMX)=0 + ENDIF + 290 CONTINUE + CALL LCMDRD(TSEGM_PTR) + 300 CONTINUE + CALL KDRCPU(TK2) + TKT(3)=TKT(3)+(TK2-TK1) +*---- +* RECOVER A PRODUCTION X-S. +*---- + CALL KDRCPU(TK1) + IF(NPHY.GE.1) THEN + KISEG=IPR(3,IMX) + IF(KISEG.EQ.0) THEN + WRITE(HNAMIS,'(3A4)') (ISONAM(I0,IMX),I0=1,3) + WRITE(HNISOR,'(3A4)') (ISONRF(I0,IMX),I0=1,3) + WRITE(HSMG,840) HNAMIS,HNISOR,NAMFIL + CALL XABORT(HSMG) + ENDIF + IDKOBJ=KDS(KISEG) + LGSEG=LGS(KISEG) + ALLOCATE(ITCARO(LGSEG)) + CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG) + LDKDS=ITCARO(IDKDS) + LDKTS=ITCARO(IDKTS) + NS=ITCARO(IDKNS) + IF(NS.NE.NPHY) CALL XABORT('LIBA20: INVALID PRODUCTION X-S(' + 1 //'1).') + ENDIF + DO 320 IPHY=1,NPHY + IDK=LDKTS+8*(IPHY-1) + CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG) + IF(TYPSEG.NE.'PSECT') CALL XABORT('LIBA20: INVALID PRODUCTION' + 1 //' X-S(2).') + LNGS=ITCARO(IDKLS+IPHY) + IF(LNGS.LE.0) CALL XABORT('LIBA20: INVALID PRODUCTION X-S(3).') + LDKS=ITCARO(LDKDS+IPHY) + CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, + 1 ICHDKL_PTR) + CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) + CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) + CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) + TSEGM_PTR=LCMARA(LNGS+1) + CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) + CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /)) + CALL AEXDIR(IUNIT,LBLOC,ITSEGM,LDKS,LNGS+1) + CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + CALL LCMDRD(ICHDIM_PTR) + CALL LCMDRD(ICHTYP_PTR) + CALL LCMDRD(ICHDKL_PTR) + I3=(NSETOT+IPHY-1)*2+1 + CALL LCMCAR(TEXT8,.FALSE.,ISECTT(I3)) + DO 310 JMX=IMX,NBISO + IF(IPR(3,JMX).EQ.KISEG) THEN + KPLIB=IPISO(JMX) ! set JMX-th isotope + CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM(IDK), + 1 SECT) + IF(TEXT8.EQ.'CREA-P') THEN + TEXT8='NP' + ELSE IF (TEXT8.EQ.'CREA-H2') THEN + TEXT8='ND' + ELSE IF (TEXT8.EQ.'CREA-H3') THEN + TEXT8='NT' + ENDIF + CALL LCMPUT(KPLIB,TEXT8,NGRO,2,SECT) + ENDIF + 310 CONTINUE + CALL LCMDRD(TSEGM_PTR) + 320 CONTINUE + DO 330 JMX=IMX,NBISO + IF(IPR(3,JMX).EQ.KISEG) IPR(3,JMX)=0 + 330 CONTINUE + IF(NPHY.GE.1) DEALLOCATE(ITCARO) + DEALLOCATE(ISECTT) +*---- +* RECOVER DELAYED NEUTRON DATA. +*---- + KISEG=IPR(4,IMX) + IF(KISEG.GT.0) THEN + IDKOBJ=KDS(KISEG) + LGSEG=LGS(KISEG) + ALLOCATE(ITCARO(LGSEG)) + CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG) + IDK=ITCARO(IDKNO) + CALL AEXCPC(IDK,20,ITCARO(1),NOMOBJ) + IDK=ITCARO(IDKTY) + CALL AEXCPC(IDK,8,ITCARO(1),TYPOBJ) + JDKDS=ITCARO(IDKDS) + JDKTS=ITCARO(IDKTS) + NS=ITCARO(IDKNS) + ICHI=0 + NDEL0=0 + LPWD=.FALSE. + DO 350 IS=1,NS + IDK=JDKTS+8*(IS-1) + CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG) + LNGS=ITCARO(IDKLS+IS) + IF(LNGS.LE.0) GO TO 350 + JDKS=ITCARO(JDKDS+IS) + CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, + 1 ICHDKL_PTR) + CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) + CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) + CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) + TSEGM_PTR=LCMARA(LNGS+1) + CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) + CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /)) + CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1) + CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,ILENG) + CALL LCMDRD(ICHDIM_PTR) + CALL LCMDRD(ICHTYP_PTR) + CALL LCMDRD(ICHDKL_PTR) + IF(TYPSEG.EQ.'.R1 RCHI') THEN + ICHI=ICHI+1 + ELSE IF(TYPSEG.EQ.'.R1 RRBE') THEN + NDEL0=ILENG + NDEL=MAX(NDEL,NDEL0) + ALLOCATE(PWD(NDEL)) + DO IDEL=1,NDEL + PWD(IDEL)=RTSEGM(IDK+IDEL-1) + ENDDO + LPWD=.TRUE. + ELSE IF(TYPSEG.EQ.'.R1 RBET') THEN + ALLOCATE(PED(NGRO)) + DO IGR=1,NGRO + PED(IGR)=RTSEGM(IDK+IGR-1) + ENDDO + LPED=.TRUE. + ENDIF + DO 340 JMX=IMX,NBISO + IF(IPR(4,JMX).EQ.KISEG) THEN + KPLIB=IPISO(JMX) ! set JMX-th isotope + IF(TYPSEG.EQ.'.R1 RLAM') THEN + CALL LCMPUT(KPLIB,'LAMBDA-D',ILENG,2,RTSEGM(IDK)) + NDEL0=ILENG + NDEL=MAX(NDEL,NDEL0) + ELSE IF(TYPSEG.EQ.'.R1 RCHI') THEN + WRITE(TEXT2,'(I2.2)') ICHI + CALL LCMPUT(KPLIB,'CHI'//TEXT2,ILENG,2,RTSEGM(IDK)) + ENDIF + ENDIF + 340 CONTINUE + CALL LCMDRD(TSEGM_PTR) + 350 CONTINUE + DEALLOCATE(ITCARO) + IF(LPWD.AND.LPED) THEN + DO 390 JMX=IMX,NBISO + IF(IPR(4,JMX).EQ.KISEG) THEN + KPLIB=IPISO(JMX) ! set JMX-th isotope + DO 380 IDEL=1,NDEL0 + WRITE(TEXT2,'(I2.2)') IDEL + CALL LCMGET(KPLIB,'NUSIGF',SECT) + DO 370 IGR=1,NGRO + SECT(IGR)=SECT(IGR)*PWD(IDEL)*PED(IGR) + 370 CONTINUE + CALL LCMPUT(KPLIB,'NUSIGF'//TEXT2,NGRO,2,SECT) + 380 CONTINUE + ENDIF + 390 CONTINUE + ENDIF + IF(LPWD) DEALLOCATE(PWD) + IF(LPED) DEALLOCATE(PED) + DO 400 JMX=IMX,NBISO + IF(IPR(4,JMX).EQ.KISEG) IPR(4,JMX)=0 + 400 CONTINUE + ENDIF +*---- +* RELEASE ALLOCATED MEMORY FOR THE CURRENT ISOTOPE. +*---- + IF(LTRAN) DEALLOCATE(IDEPL,IIAD,IFDG) + DEALLOCATE(TEMP,IZSECT,LGTRE) + CALL KDRCPU(TK2) + TKT(2)=TKT(2)+(TK2-TK1) + IF((IMPX.GT.9).AND.(IPR(5,IMX).EQ.0)) THEN + KPLIB=IPISO(IMX) ! set IMX-th isotope + CALL LCMLIB(KPLIB) + ENDIF + ENDIF +*---- +* PROCESS SELF-SHIELDING INFORMATION. +*---- + KISEG=IPR(5,IMX) + IF(KISEG.GT.0) THEN + CALL KDRCPU(TK1) + IDKOBJ=KDS(KISEG) + LGSEG=LGS(KISEG) + ALLOCATE(ITCARO(LGSEG)) + CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG) + IDK=ITCARO(IDKNO) + CALL AEXCPC(IDK,20,ITCARO(1),NOMOBJ) + IDK=ITCARO(IDKTY) + CALL AEXCPC(IDK,8,ITCARO(1),TYPOBJ) + JDKDS=ITCARO(IDKDS) + JDKTS=ITCARO(IDKTS) + NS=ITCARO(IDKNS) +*---- +* RECOVER THE SELF-SHIELDED CROSS SECTION NUMEROTATION. +*---- + LPTHOM=.FALSE. + LGHOMO=0 + DO 440 IS=1,NS + IDK=JDKTS+8*(IS-1) + CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG) + LNGS=ITCARO(IDKLS+IS) + IF(LNGS.LE.0) GO TO 440 + JDKS=ITCARO(JDKDS+IS) + CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, + 1 ICHDKL_PTR) + CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) + CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) + CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) + TSEGM_PTR=LCMARA(LNGS+1) + CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) + CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /)) + CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1) + IF(TYPSEG.EQ.'PTHOM1') THEN + LPTHOM=.TRUE. + CALL AEXGNV(4,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NTHOMO) + IF(NTHOMO.GT.MAXHOM) CALL XABORT('LIBA20: ITHOMO OVERFLOW.') + DO 410 I=1,NTHOMO + ITHOMO(I)=ITSEGM(IDK+I-1) + 410 CONTINUE + FGHOMO=ITHOMO(1) + LGHOMO=ITHOMO(2) + FGRESO=ITHOMO(3) + NGHOMO=LGHOMO-FGHOMO+1 + NGF=MIN(NGF,FGHOMO) + NGFR=MAX(NGFR,LGHOMO) + L104=.FALSE. + IF(NTHOMO.GE.9) L104=ITHOMO(9).NE.0 + CALL AEXGNV(13,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NBIN) + CALL AEXGNV(16,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NSEQHO) + ALLOCATE(SEQHO(NSEQHO)) + DO 420 I=1,NSEQHO + SEQHO(I)=RTSEGM(IDK+I-1) + 420 CONTINUE + CALL AEXGNV(22,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NTEMPS) + ALLOCATE(TEMPS(NTEMPS)) + DO 430 I=1,NTEMPS + TEMPS(I)=RTSEGM(IDK+I-1) + 430 CONTINUE + IF(IMPX.GT.1) THEN + WRITE(IOUT,910) (SEQHO(I),I=1,NSEQHO) + WRITE(IOUT,920) (TEMPS(I),I=1,NTEMPS) + WRITE(IOUT,930) FGHOMO,FGRESO,NGHOMO,NSEQHO,NTEMPS,L104, + 1 NBIN + ENDIF + ENDIF + CALL LCMDRD(TSEGM_PTR) + CALL LCMDRD(ICHDIM_PTR) + CALL LCMDRD(ICHTYP_PTR) + CALL LCMDRD(ICHDKL_PTR) + 440 CONTINUE + IF(.NOT.LPTHOM) CALL XABORT('LIBA20: NO PTHOM1 SEGMENT.') + LENGTH=NGHOMO*NSEQHO*NTEMPS + IF(LENGTH.EQ.0) THEN + DEALLOCATE(SEQHO,ITCARO) + DO 450 JMX=IMX,NBISO + IF(IPR(5,JMX).EQ.KISEG) IPR(5,JMX)=0 + 450 CONTINUE + GO TO 550 + ENDIF + ALLOCATE(TAUX(7*NGHOMO)) + TAUX(:7*NGHOMO)=0.0 +*---- +* RECOVER THE SELF-SHIELDED FLUX (REACTION 104). +*---- + IF(L104) THEN + KISEG=IPR(6,IMX) + IF(KISEG.EQ.0) THEN + WRITE(HNAMIS,'(3A4)') (ISONAM(I0,IMX),I0=1,3) + WRITE(HNISSS,'(3A4)') (ISHINA(I0,IMX),I0=1,3) + WRITE(HSMG,850) HNAMIS,HNISSS,NAMFIL,1 + CALL XABORT(HSMG) + ENDIF + IDKOBJ=KDS(KISEG) + LGSEG=LGS(KISEG) + ALLOCATE(ITC104(LGSEG)) + CALL AEXDIR(IUNIT,LBLOC,ITC104,IDKOBJ,LGSEG) + LDKDS=ITC104(IDKDS) + LDKTS=ITC104(IDKTS) + IF(ITC104(IDKNS).NE.1) CALL XABORT('LIBA20: INVALID FL104(' + 1 //'1).') + CALL AEXCPC(LDKTS,8,ITC104(1),TYPSEG) + IF(TYPSEG.NE.'.R3 TXSS') CALL XABORT('LIBA20: INVALID FL10' + 1 //'4(2).') + LNGS=ITC104(IDKLS+1) + IF(LNGS.LE.0) CALL XABORT('LIBA20: INVALID FL104(3).') + LDKS=ITC104(LDKDS+1) + CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, + 1 ICHDKL_PTR) + CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) + CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) + CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) + ALLOCATE(ITS104(LNGS+1)) + CALL AEXDIR(IUNIT,LBLOC,ITS104,LDKS,LNGS+1) + CALL AEXGNV(1,ITS104,ICHDIM,ICHTYP,ICHDKL,IDK104,NV) + IF(NV.NE.LENGTH) CALL XABORT('LIBA20: INVALID FL104(4).') + CALL LCMDRD(ICHDIM_PTR) + CALL LCMDRD(ICHTYP_PTR) + CALL LCMDRD(ICHDKL_PTR) + DEALLOCATE(ITC104) + ENDIF +*---- +* RECOVER THE SELF-SHIELDED EFFECTIVE RATES. +*---- + LPTHOM=.FALSE. + KISEG=IPR(5,IMX) + DO 470 IS=1,NS + IDK=JDKTS+8*(IS-1) + CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG) + LNGS=ITCARO(IDKLS+IS) + IF(LNGS.LE.0) GO TO 470 + JDKS=ITCARO(JDKDS+IS) + CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, + 1 ICHDKL_PTR) + CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) + CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) + CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) + TSEGM_PTR=LCMARA(LNGS+1) + CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) + CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1) + IF(TYPSEG.EQ.'PTHOM2') THEN + LPTHOM=.TRUE. + CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDKA,NV) + LABS=NV.EQ.LENGTH + CALL AEXGNV(5,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDKD,NV) + LDIF=NV.EQ.LENGTH + CALL AEXGNV(9,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDKF,NV) + LFIS=NV.EQ.LENGTH + DO 460 JMX=IMX,NBISO + IF(IPR(5,JMX).EQ.KISEG) THEN + WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3) + KPLIB=IPISO(JMX) ! set JMX-th isotope + CALL LIBA24(HNAMIS,NGRO,FGHOMO,NGHOMO,NSEQHO,NTEMPS, + 1 LFIS,L104,SEQHO,TEMPS,TN(JMX),SN(1,JMX),ITSEGM(IDKA), + 2 ITSEGM(IDKD),ITSEGM(IDKF),ITS104(IDK104),IMPX,TAUX) +* +* COMPUTE THE SELF-SHIELDED FLUX AND CROSS SECTIONS. + CALL LIBA25(KPLIB,LABS,LDIF,LFIS,L104,NGRO,FGHOMO, + 1 NGHOMO,NSEQHO,NL,SEQHO,SN(1,JMX),SB(1,JMX),DELTA, + 2 ISONAM(1,JMX),TAUX,IMPX) + IPR(5,JMX)=0 + IPR(6,JMX)=0 + ENDIF + 460 CONTINUE + ENDIF + CALL LCMDRD(TSEGM_PTR) + CALL LCMDRD(ICHDIM_PTR) + CALL LCMDRD(ICHTYP_PTR) + CALL LCMDRD(ICHDKL_PTR) + 470 CONTINUE + IF(.NOT.LPTHOM) CALL XABORT('LIBA20: NO PTHOM2 SEGMENT.') + IF(L104) DEALLOCATE(ITS104) + DEALLOCATE(SEQHO,ITCARO) + CALL KDRCPU(TK2) + TKT(4)=TKT(4)+(TK2-TK1) +*---- +* RECOVER THE AUTOLIB (BIN CROSS SECTIONS) INFORMATION. +*---- + IF((NBIN.GT.0).AND.(IPROC.GE.3)) THEN + CALL KDRCPU(TK1) + KISEG=IPR(7,IMX) + IF(KISEG.EQ.0) THEN + WRITE(HNAMIS,'(3A4)') (ISONAM(I0,IMX),I0=1,3) + WRITE(HNISSS,'(3A4)') (ISHINA(I0,IMX),I0=1,3) + WRITE(HSMG,850) HNAMIS,HNISSS,NAMFIL,2 + CALL XABORT(HSMG) + ENDIF +*---- +* PROCESS THE RESOLVED ENERGY DOMAIN. +*---- + IDKOBJ=KDS(KISEG) + LGSEG=LGS(KISEG) + ALLOCATE(ITCARO(LGSEG)) + CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG) + JDKDS=ITCARO(IDKDS) + JDKTS=ITCARO(IDKTS) + NS=ITCARO(IDKNS) + FGRESO=MAX(FGRESO,FGHOMO) + IF(NS.EQ.(LGHOMO-FGRESO+1)*NTEMPS) THEN + NGBIN=LGHOMO-FGRESO+1 + ELSE IF(NS.EQ.NGHOMO*NTEMPS) THEN + NGBIN=NGHOMO + ELSE + CALL XABORT('LIBA20: INVALID PTHOM5(1).') + ENDIF + LBIN=0 + NFS(:NGRO)=0 + DO 480 IG=1,NGBIN + IDK=JDKTS+8*(IG-1) + CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG) + IF(TYPSEG.NE.'PTHOM5') CALL XABORT('LIBA20: INVALID PTH' + 1 //'OM5(2).') + LNGS=ITCARO(IDKLS+IG) + IF(LNGS.LE.0) CALL XABORT('LIBA20: INVALID PTHOM5(3).') + JDKS=ITCARO(JDKDS+IG) + CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, + 1 ICHDKL_PTR) + CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) + CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) + CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) + TSEGM_PTR=LCMARA(LNGS+1) + CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) + CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1) + CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDKD,NV) + LBIN=LBIN+NV + NFS(FGRESO+IG-1)=NV + CALL LCMDRD(TSEGM_PTR) + CALL LCMDRD(ICHDIM_PTR) + CALL LCMDRD(ICHTYP_PTR) + CALL LCMDRD(ICHDKL_PTR) + 480 CONTINUE + IF(LSACO) THEN + NFSBIN=NFS(FGRESO) + LBIN=LBIN+(FGRESO-FGHOMO)*NFSBIN + ELSE + NFSBIN=0 + ENDIF + DO 530 JMX=IMX,NBISO + IF(IPR(7,JMX).EQ.KISEG) THEN + ALLOCATE(DELTF(LBIN),SIGTF(LBIN),SIGAF(LBIN)) + IOF=(FGRESO-FGHOMO)*NFSBIN + ALLOCATE(SQRTE(NTEMPS)) + KPLIB=IPISO(JMX) ! set JMX-th isotope + DO 500 IG=1,NGBIN + IGG=FGRESO+IG-1 + CALL LIBA26(LGSEG,IG,NGBIN,IUNIT,LBLOC,TKCARO,ITCARO, + 1 NFS(IGG),TN(JMX),NTEMPS,TEMPS,DELTF(IOF+1),SIGTF(IOF+1), + 2 SIGAF(IOF+1),DELINF,SGTINF,SGAINF) + IG2=IG+FGRESO-FGHOMO + F1=DELTA(IGG)/DELINF + F2=(TAUX(4*NGHOMO+IG2)+ + 1 TAUX(5*NGHOMO+IG2))/(SGTINF*DELTA(IGG)) + F3=TAUX(4*NGHOMO+IG2)/(SGAINF*DELTA(IGG)) + DO 490 I=1,NFS(IGG) + DELTF(IOF+I)=DELTF(IOF+I)*F1 + SIGTF(IOF+I)=SIGTF(IOF+I)*F2 + SIGAF(IOF+I)=SIGAF(IOF+I)*F3 + 490 CONTINUE + IOF=IOF+NFS(IGG) + 500 CONTINUE + DEALLOCATE(SQRTE) +*---- +* PROCESS THE UNRESOLVED ENERGY DOMAIN. THE AUTOLIB OF THE FIRST +* RESOLVED ENERGY GROUP IS USED AND NORMALIZED TO THE CORRECT +* INFINITE DILUTION VALUES. USED WITH THE SANCHEZ-COSTE METHOD. +*---- + IF(LSACO) THEN + E0=ENERG(FGHOMO) + IG2=FGRESO-FGHOMO+1 + E1=DELTA(FGRESO) + E2=(TAUX(4*NGHOMO+IG2)+TAUX(5*NGHOMO+IG2)) + E3=TAUX(4*NGHOMO+IG2) + IBIN=0 + DO 515 IGG=FGHOMO,FGRESO-1 + NFS(IGG)=NFSBIN + IG2=IGG-FGHOMO+1 + F1=DELTA(IGG)/E1 + F2=(TAUX(4*NGHOMO+IG2)+TAUX(5*NGHOMO+IG2))/E2 + F3=TAUX(4*NGHOMO+IG2)/E3 + JBIN=(FGRESO-FGHOMO)*NFSBIN + DO 510 I=1,NFSBIN + IBIN=IBIN+1 + JBIN=JBIN+1 + DELTF(IBIN)=DELTF(JBIN)*F1 + SIGTF(IBIN)=SIGTF(JBIN)*F2/F1 + SIGAF(IBIN)=SIGAF(JBIN)*F3/F1 + 510 CONTINUE + 515 CONTINUE + ELSE + E0=ENERG(FGRESO) + ENDIF +* + ALLOCATE(ENER(LBIN+1)) + ENER(1)=E0 + UU=0.0D0 + DO 520 I=1,LBIN + UU=UU+DELTF(I) + ENER(I+1)=REAL(E0*EXP(-UU)) + SIGAF(I)=SIGTF(I)-SIGAF(I) + 520 CONTINUE + DEALLOCATE(DELTF) + CALL LCMPUT(KPLIB,'BIN-NFS',NGRO,1,NFS) + CALL LCMPUT(KPLIB,'BIN-ENERGY',LBIN+1,2,ENER) + CALL LCMPUT(KPLIB,'BIN-NTOT0',LBIN,2,SIGTF) + CALL LCMPUT(KPLIB,'BIN-SIGS00',LBIN,2,SIGAF) + DEALLOCATE(SIGAF,SIGTF,ENER) + IPR(7,JMX)=0 + ENDIF + 530 CONTINUE + DEALLOCATE(ITCARO) + CALL KDRCPU(TK2) + TKT(5)=TKT(5)+(TK2-TK1) + ELSE + KISEG=IPR(7,IMX) + DO 540 JMX=IMX,NBISO + IF(IPR(7,JMX).EQ.KISEG) IPR(7,JMX)=0 + 540 CONTINUE + ENDIF + DEALLOCATE(TEMPS,TAUX) +* + 550 IF(IMPX.GT.9) THEN + KPLIB=IPISO(IMX) ! set IMX-th isotope + CALL LCMLIB(KPLIB) + ENDIF + ENDIF + 560 CONTINUE +* + DEALLOCATE(LGS,KDS,NOMOB,AMASS) + IERR=KDRCLS(IUNIT,1) + IF(IERR.LT.0) THEN + TEXT12=NAMFIL + CALL XABORT('LIBA20: APOLLO-2 LIBRARY '//TEXT12//' CANNOT B'// + 1 'E CLOSED') + ENDIF +*---- +* CHECK IF ALL REACTIONS HAVE BEEN PROCESSED. +*---- + DO 575 IMX=1,NBISO + DO 570 I=2,7+2*(NL-1) + IF(IPR(I,IMX).NE.0) THEN + WRITE(HSMG,950) I,(ISONAM(I0,IMX),I0=1,3) + CALL XABORT(HSMG) + ENDIF + 570 CONTINUE + 575 CONTINUE + IF(IMPX.GT.2) WRITE(IOUT,940) (TKT(I),I=1,5) +*---- +* ADD NG CROSS SECTIONS. +*---- + DO 610 IMX=1,NBISO + IF(MASKI(IMX)) THEN + KPLIB=IPISO(IMX) ! set IMX-th isotope + CALL LCMGET(KPLIB,'NTOT0',SECT) + CALL LCMLEN(KPLIB,'SIGS00',LENGT,ITYLCM) + IF(LENGT.EQ.NGRO) THEN + CALL LCMGET(KPLIB,'SIGS00',XSTOT) + DO 580 IU=1,NGRO + SECT(IU)=SECT(IU)-XSTOT(IU) + 580 CONTINUE + ENDIF + CALL LCMLEN(KPLIB,'NFTOT',LENGT,ITYLCM) + IF(LENGT.EQ.NGRO) THEN + CALL LCMGET(KPLIB,'NFTOT',XSTOT) + DO 590 IU=1,NGRO + SECT(IU)=SECT(IU)-XSTOT(IU) + 590 CONTINUE + ENDIF + CALL LCMLEN(KPLIB,'N2N',LENGT,ITYLCM) + IF(LENGT.EQ.NGRO) THEN + CALL LCMGET(KPLIB,'N2N',XSTOT) + DO 600 IU=1,NGRO + SECT(IU)=SECT(IU)+XSTOT(IU) + 600 CONTINUE + ENDIF + CALL LCMPUT(KPLIB,'NG',NGRO,2,SECT) + ENDIF + 610 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XSTOT,SCAT,SIGS,SECT,DELTA,ENERG) + DEALLOCATE(NFS,ITYPRO,IPR) + RETURN +* + 800 FORMAT(/43H LIBA20: PROCESSING APOLIB-2 LIBRARY NAME: ,A12,1H.) + 810 FORMAT(/32H LIBA20: X-SECTION LIBRARY INFO:/9X,A80/) + 820 FORMAT(/35H LIBA20: PROBING THE APOLIB-2 FILE./9X,11HNUMBER OF I, + 1 29HSOTOPES AT INFINITE DILUTION=,I8/9X,21HNUMBER OF SELF-SHIELD, + 2 12HED ISOTOPES=,I8/9X,27HNUMBER OF APOLIBE SEGMENTS=,I8) + 830 FORMAT(9HLIBA20: P,I2,27H INFO OF MATERIAL/ISOTOPE ',A12,5H' = ', + 1 A12,35H' IS MISSING ON APOLIB-2 FILE NAME ,A12,1H.) + 840 FORMAT(45HLIBA20: PRODUCTION INFO OF MATERIAL/ISOTOPE ',A12, + 1 5H' = ',A12,35H' IS MISSING ON APOLIB-2 FILE NAME ,A12,1H.) + 850 FORMAT(49HLIBA20: SELF-SHIELDING DATA OF MATERIAL/ISOTOPE ',A12, + 1 5H' = ',A12,35H' IS MISSING ON APOLIB-2 FILE NAME ,A12,1H(,I1, + 2 2H).) + 870 FORMAT(/9X,15HISOTOPE TITLE: ,A80) + 875 FORMAT(/9X,6HZSECT=,10I10/(15X,10I10)) + 880 FORMAT(/9X,13HTEMPERATURES=,1P,9E12.4/(22X,9E12.4)) + 890 FORMAT(/9X,6HZFISS=,I2,8H LGPROB=,L2,8H LGTDIF=,L2,8H LGTTRA=,L2, + 1 6H FGTD=,I5,5H ID2=,I5,8H NSECTT=,I3,8H NSETOT=,I3,6H NPHY=,I3/ + 2 9X,7HNANISD=,I3,8H NANIST=,I3,8H LGTREA=,10L2) + 900 FORMAT(/9X,5HFAGG=,I5,6H LAGG=,I5,6H FDGG=,I5,6H WGAL=,I5,5H FAG=, + 1 I5,5H LAG=,I5,6H NGTD=,I5) + 910 FORMAT(/9X,10HDILUTIONS=,1P,9E12.4/(19X,9E12.4)) + 920 FORMAT(/9X,28HSELF-SHIELDING TEMPERATURES=,1P,7E12.4/(37X,7E12.4)) + 930 FORMAT(/9X,7HFGHOMO=,I4,8H FGRESO=,I4,8H NGHOMO=,I4,8H NSEQHO=, + 1 I4,8H NTEMPS=,I4,6H L104=,L2,6H NBIN=,I5) + 940 FORMAT(/26H LIBA20: CPU TIME USAGE --,F10.2,9H INDEXING/26X, + 1 F10.2,24H INFINITE DILUTION P0 XS/26X,F10.2,11H PN XS DATA/ + 2 26X,F10.2,27H DILUTION-DEPENDENT XS DATA/26X,F10.2,5H AUTO, + 3 12HLIB XS DATA.) + 950 FORMAT(26HLIBA20: REMAINING REACTION,I3,14H FOR ISOTOPE ',3A4, + 1 2H'.) + END diff --git a/Dragon/src/LIBA21.f b/Dragon/src/LIBA21.f new file mode 100644 index 0000000..2fcac1d --- /dev/null +++ b/Dragon/src/LIBA21.f @@ -0,0 +1,91 @@ +*DECK LIBA21 + SUBROUTINE LIBA21(TYPSEG,RETCAR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Description of the archive segments used in the APOLIB-2 file +* used as external subroutine by subroutine AEXTRT. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* TYPSEG type of segment. +* +*Parameters: output +* RETCAR encoded generic character type of segment. +* +*----------------------------------------------------------------------- +* + CHARACTER*(*) TYPSEG + CHARACTER*(*) RETCAR +* + IF (TYPSEG .EQ. 'APOLIB') THEN + RETCAR = 'LIIIIIIIIIII' +* + ELSEIF (TYPSEG .EQ. 'PCOM') THEN + RETCAR = 'C1C1' +* + ELSEIF (TYPSEG .EQ. 'PCONST') THEN + RETCAR = 'I1I1I1I1I1I1R1' +* + ELSEIF (TYPSEG .EQ. 'PFIX') THEN + RETCAR = 'IIILLLIIIRRI1I1I1L1R1R1R1C1C1' +* + ELSEIF (TYPSEG .EQ. 'PFLUXC') THEN + RETCAR = 'R1' +* + ELSEIF (TYPSEG .EQ. 'PHEAD ') THEN + RETCAR = 'CC1C1R1' +* + ELSEIF (TYPSEG .EQ. 'PMAIL ') THEN + RETCAR = 'RIR1R1I1I1' +* + ELSEIF (TYPSEG .EQ. 'PNUMF') THEN + RETCAR = 'C1C1R3' +* + ELSEIF (TYPSEG .EQ. 'PPPSN') THEN + RETCAR = 'IIIIIII1I1I1' +* + ELSEIF (TYPSEG .EQ. 'PPSN') THEN + RETCAR = 'R1' +* + ELSEIF (TYPSEG .EQ. 'PSECT') THEN + RETCAR = 'R1' +* + ELSEIF (TYPSEG .EQ. 'PTHOM1') THEN + RETCAR = 'RCI1I1I1I2I2R1R1R1R1' +* + ELSEIF (TYPSEG .EQ. 'PTHOM2') THEN + RETCAR = 'R3R3R3' +* + ELSEIF (TYPSEG .EQ. 'PTHOM3') THEN + RETCAR = 'R1R1R1R1' +* + ELSEIF (TYPSEG .EQ. 'PTHOM4') THEN + RETCAR = 'R1R1R1R1R1R1R1R1R1R1R1' +* + ELSEIF (TYPSEG .EQ. 'PTHOM5') THEN + RETCAR = 'R1R1R1' +* + ELSEIF (TYPSEG .EQ. 'QFIX') THEN + RETCAR = 'I1' +* + ELSEIF (TYPSEG .EQ. 'QFIXS') THEN + RETCAR = 'I1' +* + ELSEIF (TYPSEG .EQ. 'QFLUXC') THEN + RETCAR = 'I1' + ELSE + RETCAR = ' ' + ENDIF +* + RETURN + END diff --git a/Dragon/src/LIBA22.f b/Dragon/src/LIBA22.f new file mode 100644 index 0000000..30905d7 --- /dev/null +++ b/Dragon/src/LIBA22.f @@ -0,0 +1,117 @@ +*DECK LIBA22 + SUBROUTINE LIBA22(NG,TT,NT0,NSECT0,FGTD,TEMP,SECT0,SECT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Temperature interpolation of a cross section array stored in the +* APOLIB-2 format. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NG number of energy groups. +* TT temperature of isotope. +* NT0 number of tabulated temperatures. +* NSECT0 size of vector SECT0. +* FGTD first temperature-dependent energy group. +* TEMP tabulated temperatures. +* SECT0 input cross section data in APOLIB-2 compressed format. +* +*Parameters: output +* SECT interpolated cross section. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NG,NT0,NSECT0 + REAL TT,TEMP(NT0),SECT0(NSECT0),SECT(NG) +*---- +* LOCAL VARIABLES +*---- + CHARACTER HSMG*131 + PARAMETER (NINT=2,DTMIN=1.0) + INTEGER FGTD + DOUBLE PRECISION S + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DTEMP,WEIJHT +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(DTEMP(NT0),WEIJHT(NT0)) +* + IF(NSECT0.EQ.NG) THEN + DO 10 I=1,NG + SECT(I)=SECT0(I) + 10 CONTINUE + RETURN + ENDIF +* + DO 15 I=1,NT0 + DTEMP(I)=TEMP(I) + 15 CONTINUE + IF(NT0.EQ.1) THEN + IPROX=1 + IGTFIX=1 + ELSE + CALL LIBA28(TT,DTEMP,NT0,NINT,WEIJHT,IORD,IPROX,I0) + IF(ABS(TT-TEMP(IPROX)).LE.DTMIN) THEN + IGTFIX=1 + ELSE IF((TT.LT.TEMP(1)).OR.(TT.GT.TEMP(NT0))) THEN + WRITE(HSMG,'(A,F8.2,A,F8.2,A,F8.2)') + 1 'LIBA22: A TEMPERATURE', TT,'K IS NOT INCLUDED BETWEEN ', + 2 TEMP(1),' AND ',TEMP(NT0) + WRITE(6,'(/1X,A)') HSMG + IGTFIX=2 + ELSE + IGTFIX=0 + ENDIF + ENDIF +* + IDIS=NG+1-FGTD + IPID=(IPROX-1)*IDIS + IF(FGTD.GT.1) THEN + DO 20 I=1,FGTD-1 + SECT(I)=SECT0(I) + 20 CONTINUE + ENDIF + IF(IGTFIX.EQ.1) THEN + ISECT0=FGTD+IPID + IF(ISECT0+IDIS-1.GT.NSECT0) CALL XABORT('LIBA22: NSECT0 OVERFL' + 1 //'OW.') + DO 30 I=1,IDIS + SECT(FGTD+I-1)=SECT0(ISECT0+I-1) + 30 CONTINUE + ELSE + DO 50 I=FGTD,NG + S=0.D0 + ID=I+I0*IDIS + IDP=I+IPID + DO 40 J=1,IORD + S=S+WEIJHT(J)*SECT0(ID) + ID=ID+IDIS + 40 CONTINUE + IF(IGTFIX.EQ.2) THEN + IF(SECT0(IDP).GE.0.) THEN + S=MAX(0.D0,S) + ELSE + S=MIN(S,0.D0) + ENDIF + ENDIF + SECT(I)=REAL(S) + 50 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(WEIJHT,DTEMP) + RETURN + END diff --git a/Dragon/src/LIBA23.f b/Dragon/src/LIBA23.f new file mode 100644 index 0000000..59d3896 --- /dev/null +++ b/Dragon/src/LIBA23.f @@ -0,0 +1,179 @@ +*DECK LIBA23 + SUBROUTINE LIBA23(NG,NANI,TT,NT0,NGTD,NPSN0,TEMP,FGTD,ID2,FAGG, + 1 LAGG,FDGG,WGAL,FAG,LAG,FDG,IAD,DEPL,PSN0,SCAT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly and temperature interpolation of a transfer matrix stored +* in the APOLIB-2 format. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NG number of energy groups. +* NANI anisotropy level. NANI=1 for isotropic scattering. +* TT temperature of isotope. +* NT0 number of tabulated temperatures. +* NGTD temperature dependence flag: =0 if no dependence; +* =NG+1 otherwise. +* NPSN0 size of vector PSN0. +* TEMP tabulated temperatures. +* FGTD first temperature-dependent group. +* ID2 number of temperature-dependent terms in the matrix. +* FAGG first incoming group for the galoche. +* LAGG last incoming group for the galoche. +* FDGG first outgoing group for the galoche. +* WGAL galoche width. The last outgoing group is FDGG+WGAL-1. +* FAG first incoming group for the rest of the matrix. +* LAG last incoming group for the rest of the matrix. +* FDG first outgoing group per incoming group for the rest of +* the matrix. +* IAD offset in vector PSN of the data related to each incoming +* group. +* DEPL displacement of the IAD offset for the first two +* temperatures. +* PSN0 input cross section data in APOLIB-2 compressed format. +* +*Parameters: output +* SCAT interpolated transfer matrix. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NG,NANI,NT0,NGTD,NPSN0,FGTD,ID2,FAGG,LAGG,FDGG,WGAL,FAG, + 1 LAG,FDG(NG),IAD(NG+1),DEPL(NGTD) + REAL TT,TEMP(NT0),PSN0(NPSN0),SCAT(NG,NG) +*---- +* LOCAL VARIABLES +*---- + CHARACTER HSMG*131 + PARAMETER (NINT=2,DTMIN=1.0) + LOGICAL LGTP,LGAUX + DOUBLE PRECISION S + REAL, ALLOCATABLE, DIMENSION(:) :: PSN + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DTEMP,WEIJHT +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(DTEMP(NT0),WEIJHT(NT0)) +* + NPSN=IAD(NG+1)-1 + IF(NT0.EQ.1) THEN + IPROX=1 + IGTFIX=1 + ELSE + DO 10 I=1,NT0 + DTEMP(I)=TEMP(I) + 10 CONTINUE + CALL LIBA28(TT,DTEMP,NT0,NINT,WEIJHT,IORD,IPROX,I0) + IF(ABS(TT-TEMP(IPROX)).LE.DTMIN) THEN + IGTFIX=1 + ELSE IF((TT.LT.TEMP(1)).OR.(TT.GT.TEMP(NT0))) THEN + WRITE(HSMG,'(A,F8.2,A,F8.2,A,F8.2)') + 1 'LIBA23: A TEMPERATURE', TT,'K IS NOT INCLUDED BETWEEN ', + 2 TEMP(1),' AND ',TEMP(NT0) + WRITE(6,'(/1X,A)') HSMG + IGTFIX=2 + ELSE + IGTFIX=0 + ENDIF + ENDIF + ALLOCATE(PSN(NPSN)) + LGTP=I0.GT.0 +*---- +* GALOCHE +*---- + IF(WGAL.NE.0) THEN + DO 15 I=1,WGAL*(LAGG+1-FAGG) + PSN(I)=PSN0(I) + 15 CONTINUE + ENDIF + DO 50 IGA=FAG,LAG + IPGD=FDG(IGA) + IDGD=IPGD+IAD(IGA+1)-IAD(IGA)-1 +*---- +* PART INDEPENDENT OF TEMPERATURE OF LENGTH LONG FROM IPGD TO IGD +*---- + IF(IPGD.LT.FGTD)THEN + IGD=MIN0(IDGD,FGTD-1) + LONG=IGD+1-IPGD + DO 20 I=1,LONG + PSN(IAD(IGA)+I-1)=PSN0(IAD(IGA)+I-1) + 20 CONTINUE + ELSE + IGD=IPGD-1 + LONG=0 + ENDIF + IF(IGD.LT.IDGD)THEN + LONT=IDGD-IGD +*---- +* PART DEPENDENT OF TEMPERATURE +*---- + DO 40 IG=1,LONT + ID=IAD(IGA)+LONG+IG-1 + ID0=ID + IDP=ID + IF(IPROX.GT.1)IDP=IDP+DEPL(IGA)+ID2*(IPROX-2) + IF(IGTFIX .EQ. 1) THEN + PSN(ID0)=PSN0(IDP) + ELSE + S=0.0D0 + IF(LGTP)ID=ID+DEPL(IGA)+ID2*(I0-1) + SP=PSN0(IDP) + LGAUX=.NOT.LGTP + DO 30 J=1,IORD + S=S+PSN0(ID)*WEIJHT(J) + IF(LGAUX)THEN + ID=ID+DEPL(IGA) + LGAUX=.FALSE. + ELSE + ID=ID+ID2 + ENDIF + 30 CONTINUE + IF(IGTFIX.EQ.2) THEN + IF(SP.GE.0.) THEN + S=MAX(0.D0,S) + ELSE + S=MIN(S,0.D0) + ENDIF + ENDIF + PSN(ID0)=REAL(S) + ENDIF + 40 CONTINUE + ENDIF + 50 CONTINUE +*---- +* BUILD THE COMPLETE TRANSFER MATRIX SCAT(IG->JG). +*---- + DO 70 IG=1,NG + DO 60 JG=1,NG + RAUX=0. + IF((JG.GE.FAGG).AND.(JG.LE.LAGG).AND. + 1 (IG.GE.FDGG).AND.(IG.LE.(FDGG+WGAL-1))) THEN + RAUX=PSN((JG-FAGG)*WGAL+IG-FDGG+1) + ELSE + IF((IG.GE.FDG(JG)) .AND. + 1 (IG.LE.(IAD(JG+1)-IAD(JG)+FDG(JG)-1)) + 2 .AND.(JG.GE.FAG).AND.(JG.LE.LAG)) + 3 RAUX=PSN(IAD(JG)+IG-FDG(JG)) + ENDIF + SCAT(JG,IG)=RAUX/REAL(2*NANI-1) + 60 CONTINUE + 70 CONTINUE + DEALLOCATE(PSN) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(WEIJHT,DTEMP) + RETURN + END diff --git a/Dragon/src/LIBA24.f b/Dragon/src/LIBA24.f new file mode 100644 index 0000000..5fee9be --- /dev/null +++ b/Dragon/src/LIBA24.f @@ -0,0 +1,423 @@ +*DECK LIBA24 + SUBROUTINE LIBA24(HNAMIS,NGRO,FGHOMO,NGHOMO,NSEQHO,NTEMPS,LFIS, + 1 L104,SEQHOM,TEMPS,TN,SN,ABSOHE,DIFFHE,FISSHE,FLUXHE,IMPX,TAUX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Temperature and dilution interpolation of self-shielded effective +* rates in the APOLIB-2 format. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* HNAMIS name of the isotope. +* NGRO number of energy groups. +* FGHOMO first self-shielded energy group. +* NGHOMO number of self-shielded energy groups. +* NSEQHO number of tabulated dilutions. +* NTEMPS number of tabulated temperatures. +* LFIS fission reaction flag (=.true. if the fission reaction is +* self-shielded). +* L104 resonance flux flag (=.true. if the apolib contains dilution +* /temperature-dependent flux information). If this information +* is not provided, it will be reconstructed from a balance +* relation. +* SEQHOM tabulated dilutions. +* TEMPS tabulated temperatures. +* TN temperature of isotope. +* SN dilution of isotope. +* ABSOHE tabulated absorption effective reaction rates. +* DIFFHE tabulated diffusion effective reaction rates. +* FISSHE tabulated nu*fission effective reaction rates +* (if LFIS=.true.). +* FLUXHE tabulated self-shielded fluxes (if L104=.true.). +* IMPX print flag. +* +*Parameters: output +* TAUX interpolated effective rates: +* TAUX(I,1) absorption effective rates; +* TAUX(I,2) diffusion effective rates; +* TAUX(I,3) nu*fission effective rates; +* TAUX(I,4) pseudo-absorption effective rates used to +* reconstruct the self-shielded flux; +* TAUX(I,5) infinite-dilution absorption x-s; +* TAUX(I,6) infinite-dilution diffusion x-s; +* TAUX(I,7) infinite-dilution fission x-s. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER HNAMIS*12 + INTEGER NGRO,FGHOMO,NGHOMO,NSEQHO,NTEMPS,IMPX + LOGICAL LFIS,L104 + REAL SEQHOM(NSEQHO),TEMPS(NTEMPS),TN,SN(NGRO), + 1 ABSOHE(NGHOMO,NSEQHO,NTEMPS),DIFFHE(NGHOMO,NSEQHO,NTEMPS), + 2 FISSHE(NGHOMO,NSEQHO,NTEMPS),FLUXHE(NGHOMO,NSEQHO,NTEMPS), + 3 TAUX(NGHOMO,7) +*---- +* LOCAL VARIABLES +*---- + CHARACTER HSMG*131,TEXTE*80 + PARAMETER (NINT=2,NINTSS=3,DTMIN=1.0) + LOGICAL LGONE + DOUBLE PRECISION S1,S2,S3,S4,SUMA,SUMS,SUMF,SUM104,REL,RNTERP + REAL, ALLOCATABLE, DIMENSION(:,:) :: ABSOH,DIFFH,FISSH,FLUXH + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SQRTEM,SEQ2,WEIJHT, + 1 WEIGH +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(WEIJHT(NTEMPS),SQRTEM(NTEMPS),ABSOH(NGHOMO,NSEQHO), + 1 DIFFH(NGHOMO,NSEQHO),FISSH(NGHOMO,NSEQHO), + 2 FLUXH(NGHOMO,NSEQHO)) + WEIJHT(:NTEMPS)=0.0D0 +*---- +* SQUARE ROOT OF TEMPERATURE INTERPOLATION. +* +* IGTFIX=1 IF ONLY ONE TABULATED TEMPERATURE OR IF STT IS ONE OF THE +* TABULATED TEMPERATURES. IGTFIX=2 IF STT IS OUTSIDE THE TABULATED +* RANGE. IGTFIX=0 OTHERWISE. +* +*---- + DO 10 I=1,NTEMPS + SQRTEM(I)=SQRT(TEMPS(I)) + 10 CONTINUE + IF(NTEMPS.EQ.1) THEN + IGTFIX=1 + IPROX=1 + ELSE + STT=SQRT(TN) + CALL LIBA28(STT,SQRTEM,NTEMPS,NINT,WEIJHT,IORD,IPROX,I0) + IF(ABS(TN-TEMPS(IPROX)).LE.DTMIN) THEN + IGTFIX=1 + ELSEIF((STT.LT.SQRTEM(1)).OR.(STT.GT.SQRTEM(NTEMPS))) THEN + WRITE(HSMG,'(A,F8.2,A,F8.2,A,F8.2,2A)') + 1 'LIBA24: A TEMPERATURE', TN,'K IS NOT INCLUDED BETWEEN ', + 2 TEMPS(1),' AND ',TEMPS(NTEMPS),' ISOTOPE:',HNAMIS + WRITE(6,'(/1X,A)') HSMG + IGTFIX=2 + ELSE + IGTFIX=0 + ENDIF + ENDIF +* + IF(IGTFIX .EQ. 1) THEN + DO 25 J=1,NSEQHO + DO 20 I=1,NGHOMO + ABSOH(I,J)=ABSOHE(I,J,IPROX) + DIFFH(I,J)=DIFFHE(I,J,IPROX) + IF(LFIS) FISSH(I,J)=FISSHE(I,J,IPROX) + IF(L104) FLUXH(I,J)=FLUXHE(I,J,IPROX) + 20 CONTINUE + 25 CONTINUE + ELSE + DO 45 J=1,NSEQHO + DO 40 I=1,NGHOMO + S1=0.D0 + S2=0.D0 + S3=0.D0 + S4=0.D0 + DO 30 K=1,IORD + S1=S1+WEIJHT(K)*ABSOHE(I,J,I0+K) + S2=S2+WEIJHT(K)*DIFFHE(I,J,I0+K) + IF(LFIS)S3=S3+WEIJHT(K)*FISSHE(I,J,I0+K) + IF(L104)S4=S4+WEIJHT(K)*FLUXHE(I,J,I0+K) + 30 CONTINUE + IF(IGTFIX.EQ.2) THEN + IF(ABSOHE(I,J,IPROX).GE.0.) THEN + S1=MAX(0.D0,S1) + ELSE + S1=MIN(S1,0.D0) + ENDIF + IF(DIFFHE(I,J,IPROX).GE.0.) THEN + S2=MAX(0.D0,S2) + ELSE + S2=MIN(S2,0.D0) + ENDIF + ENDIF + ABSOH(I,J)=REAL(S1) + DIFFH(I,J)=REAL(S2) + IF(LFIS) THEN + IF(IGTFIX .EQ. 2) THEN + IF(FISSHE(I,J,IPROX).GE.0.) THEN + S3=MAX(0.D0,S3) + ELSE + S3=MIN(S3,0.D0) + ENDIF + ENDIF + FISSH(I,J)=REAL(S3) + ENDIF + IF(L104) THEN + IF(IGTFIX .EQ. 2) THEN + IF(FLUXHE(I,J,IPROX).GE.0.) THEN + S4=MAX(0.D0,S4) + ELSE + S4=MIN(S4,0.D0) + ENDIF + ENDIF + FLUXH(I,J)=REAL(S4) + ENDIF + 40 CONTINUE + 45 CONTINUE + ENDIF +*---- +* SET INFINITE DILUTION VALUES. +*---- + DO 50 I=1,NGHOMO + TAUX(I,5)=ABSOH(I,NSEQHO) + TAUX(I,6)=DIFFH(I,NSEQHO) + IF(LFIS) TAUX(I,7)=FISSH(I,NSEQHO) + 50 CONTINUE +*---- +* DILUTION INTERPOLATION. +*---- + LGONE=NSEQHO.EQ.1 + NSEQH1=0 + SEQHO1=0.0 + SEQHO0=0.0 + IF(.NOT.LGONE)THEN + NSEQH1=NSEQHO-1 + SEQHO1=SEQHOM(NSEQH1) + SEQHO0=SEQHOM(NSEQHO) + ENDIF + DO 110 IGG=FGHOMO,FGHOMO+NGHOMO-1 + IGSSC=IGG+1-FGHOMO + BACK=SN(IGG) + IF(LGONE) THEN +*---- +* UNIQUE TABULATED TEMPERATURE. +*---- + TAUX(IGSSC,1)=ABSOH(IGSSC,NSEQHO) + TAUX(IGSSC,2)=DIFFH(IGSSC,NSEQHO) + IF(LFIS) TAUX(IGSSC,3)=FISSH(IGSSC,NSEQHO) + IF(L104) TAUX(IGSSC,4)=FLUXH(IGSSC,NSEQHO) + GOTO 110 + ENDIF +*---- +* MANY TABULATED TEMPERATURES. +*---- + IF(BACK.GE.SEQHO1)THEN +* +* ASYMPTOTIC BEHAVIOR: REACTION RATES VARY LINEARLY WITH +* 1/SEQHOM FOR THE LAST 2 POINTS OF THE TABULATION +* + IF(BACK.GT.SEQHO0) BACK=SEQHO0 + AUX=1.0/(BACK*(SEQHO0-SEQHO1)) + AUX1=SEQHO1*(SEQHO0-BACK)*AUX + AUX2=SEQHO0*(SEQHO1-BACK)*AUX + TAUX(IGSSC,1)=ABSOH(IGSSC,NSEQH1)*AUX1 + 1 -ABSOH(IGSSC,NSEQHO)*AUX2 + TAUX(IGSSC,2)=DIFFH(IGSSC,NSEQH1)*AUX1 + 1 -DIFFH(IGSSC,NSEQHO)*AUX2 + IF(LFIS) TAUX(IGSSC,3)=FISSH(IGSSC,NSEQH1)*AUX1 + 1 -FISSH(IGSSC,NSEQHO)*AUX2 + IF(L104) TAUX(IGSSC,4)=FLUXH(IGSSC,NSEQH1)*AUX1 + 1 -FLUXH(IGSSC,NSEQHO)*AUX2 + ELSE +* +* REACTION RATES VARY WITH THE SQRT OF THE BACKGROUND XSECT +* + BACKH2=SQRT(BACK) + ALLOCATE(SEQ2(NSEQHO),WEIGH(NINTSS)) + DO 60 I=1,NSEQHO + SEQ2(I)=SQRT(SEQHOM(I)) + 60 CONTINUE + CALL LIBA28(BACKH2,SEQ2,NSEQHO,NINTSS,WEIGH,IORD,IPR,I0) + DO 70 ISEQHO=1,NSEQHO + IF(ABS(BACK-SEQHOM(ISEQHO)).LE.1.E-2) THEN + TAUX(IGSSC,1)=ABSOH(IGSSC,ISEQHO) + TAUX(IGSSC,2)=DIFFH(IGSSC,ISEQHO) + IF(LFIS) TAUX(IGSSC,3)=FISSH(IGSSC,ISEQHO) + IF(L104) TAUX(IGSSC,4)=FLUXH(IGSSC,ISEQHO) + DEALLOCATE(WEIGH,SEQ2) + GOTO 110 + ENDIF + 70 CONTINUE + SUMA=0.D0 + SUMS=0.D0 + SUMF=0.D0 + SUM104=0.D0 + DO 80 I=1,IORD + I1=I+I0 + SUMA=SUMA+WEIGH(I)*ABSOH(IGSSC,I1) + SUMS=SUMS+WEIGH(I)*DIFFH(IGSSC,I1) + IF(LFIS) SUMF=SUMF+WEIGH(I)*FISSH(IGSSC,I1) + IF(L104) SUM104=SUM104+WEIGH(I)*FLUXH(IGSSC,I1) + 80 CONTINUE + DO 90 I=1,IORD + I1=I+I0 + IF(SEQHOM(I1).GT.BACK) THEN + IF(I1-1.GT.0) THEN +* +* ABSORPTION RATE CRITERION. +* + YMIN=MIN(ABSOH(IGSSC,I1-1),ABSOH(IGSSC,I1)) + YMAX=MAX(ABSOH(IGSSC,I1-1),ABSOH(IGSSC,I1)) + IF((SUMA.GT.YMAX) .OR. (SUMA.LT.YMIN)) THEN + RNTERP=SUMA + SUMA=ABSOH(IGSSC,I1-1)+ + 1 (ABSOH(IGSSC,I1)-ABSOH(IGSSC,I1-1))* + 1 (BACKH2-SEQ2(I1-1))/(SEQ2(I1)-SEQ2(I1-1)) + REL = (RNTERP-SUMA)/SUMA + IF(REL.GE.0.1 .OR. IMPX .GT. 3) THEN + WRITE(TEXTE,10000) + 1 'ABS. G=',IGG,' DIL=',BACK, + 1 ' INT. LIN. --> ERR. RELA.=',REL + WRITE(6,'(/1X,A)') TEXTE + ENDIF + ENDIF +* +* SCATTERING RATE CRITERION. +* + YMIN = MIN(DIFFH(IGSSC,I1-1),DIFFH(IGSSC,I1)) + YMAX = MAX(DIFFH(IGSSC,I1-1),DIFFH(IGSSC,I1)) + IF((SUMS.GT.YMAX) .OR. (SUMS.LT.YMIN)) THEN + RNTERP=SUMS + SUMS=DIFFH(IGSSC,I1-1)+ + 1 (DIFFH(IGSSC,I1)-DIFFH(IGSSC,I1-1))* + 1 (BACKH2-SEQ2(I1-1))/(SEQ2(I1)-SEQ2(I1-1)) + REL = (RNTERP-SUMS)/SUMS + IF(REL.GE. 0.1 .OR. IMPX .GT. 3) THEN + WRITE(TEXTE,10000) + 1 'DIF. G=',IGG,' DIL=',BACK, + 1 ' INT. LIN. --> ERR. RELA.=',REL + WRITE(6,'(/1X,A)') TEXTE + ENDIF + ENDIF +* +* PRODUCTION RATE CRITERION. +* + IF(LFIS) THEN + YMIN = MIN(FISSH(IGSSC,I1-1),FISSH(IGSSC,I1)) + YMAX = MAX(FISSH(IGSSC,I1-1),FISSH(IGSSC,I1)) + IF((SUMF.GT.YMAX) .OR. (SUMF.LT.YMIN)) THEN + RNTERP=SUMF + SUMF=FISSH(IGSSC,I1-1)+ + 1 (FISSH(IGSSC,I1)-FISSH(IGSSC,I1-1))* + 1 (BACKH2-SEQ2(I1-1))/(SEQ2(I1)-SEQ2(I1-1)) + REL = (RNTERP-SUMF)/SUMF + IF(REL.GE.0.1 .OR. IMPX .GT. 3) THEN + WRITE(TEXTE,10000) + 1 'FIS. G=',IGG,' DIL=',BACK, + 1 ' INT. LIN. --> ERR. RELA.=',REL + WRITE(6,'(/1X,A)') TEXTE + ENDIF + ENDIF + ENDIF +* +* TEST FLUX 104 +* + IF(L104) THEN + YMIN = MIN(FLUXH(IGSSC,I1-1),FLUXH(IGSSC,I1)) + YMAX = MAX(FLUXH(IGSSC,I1-1),FLUXH(IGSSC,I1)) + IF((SUM104.GT.YMAX) .OR. (SUM104.LT.YMIN)) THEN + RNTERP=SUM104 + SUM104=FLUXH(IGSSC,I1-1)+ + 1 (FLUXH(IGSSC,I1)-FLUXH(IGSSC,I1-1))* + 1 (BACKH2-SEQ2(I1-1))/(SEQ2(I1)-SEQ2(I1-1)) + REL = (RNTERP-SUM104)/SUM104 + IF(REL.GE.0.1 .OR. IMPX .GT. 3) THEN + WRITE(TEXTE,10000) + 1 'FIS. G=',IGG,' DIL=',BACK, + 1 ' INT. LIN. --> ERR. RELA.=',REL + WRITE(6,'(/1X,A)') TEXTE + ENDIF + ENDIF + ENDIF +* + ELSE + SUMA=ABSOH(IGSSC,1)+ + 1 (ABSOH(IGSSC,2)-ABSOH(IGSSC,1))* + 1 (BACKH2-SEQ2(1))/(SEQ2(2)-SEQ2(1)) + IF(SUMA.LE.0.) THEN + SUMA=ABSOH(IGSSC,1) + WRITE(TEXTE,3000) + 1 ' DIL. : ',BACK, ' TROP PETITE ', + 2 'TAUX ABS. NON EXTRAPOLES GR. ',IGG + WRITE(6,'(/1X,A)') TEXTE + ENDIF +* + SUMS=DIFFH(IGSSC,1)+ + 1 (DIFFH(IGSSC,2)-DIFFH(IGSSC,1))* + 1 (BACKH2-SEQ2(1))/(SEQ2(2)-SEQ2(1)) + IF(SUMS.LE.0.) THEN + SUMS=DIFFH(IGSSC,1) + WRITE(TEXTE,3000) + 1 ' DIL. : ',BACK, ' TROP PETITE ', + 2 'TAUX DIFF. NON EXTRAPOLES GR. ',IGG + WRITE(6,'(/1X,A)') TEXTE + ENDIF +* + IF(LFIS) SUMF=FISSH(IGSSC,1)+ + 1 (FISSH(IGSSC,2)-FISSH(IGSSC,1))* + 1 (BACKH2-SEQ2(1))/(SEQ2(2)-SEQ2(1)) + IF(LFIS.AND.SUMF.LE.0.) THEN + SUMF=FISSH(IGSSC,1) + WRITE(TEXTE,3000) + 1 ' DIL. : ',BACK, ' TROP PETITE ', + 2 'TAUX PROD. NON EXTRAPOLES GR. ',IGG + WRITE(6,'(/1X,A)') TEXTE + ENDIF +* + IF(L104) SUM104=FLUXH(IGSSC,1)+ + 1 (FLUXH(IGSSC,2)-FLUXH(IGSSC,1))* + 1 (BACKH2-SEQ2(1))/(SEQ2(2)-SEQ2(1)) + IF(L104.AND.SUM104.LE.0.) THEN + SUM104=FLUXH(IGSSC,1) + WRITE(TEXTE,3000) + 1 ' DIL. : ',BACK, ' TROP PETITE ', + 2 'FLUX 104 NON EXTRAPOLES GR. ',IGG + WRITE(6,'(/1X,A)') TEXTE + ENDIF + ENDIF + GOTO 100 + ENDIF + 90 CONTINUE +* + 100 TAUX(IGSSC,1)=REAL(SUMA) + TAUX(IGSSC,2)=REAL(SUMS) + IF(LFIS) TAUX(IGSSC,3)=REAL(SUMF) + IF(L104) TAUX(IGSSC,4)=REAL(SUM104) + IF(SUMA.LE.0.) THEN + WRITE(TEXTE,1000) + 1 HNAMIS,'GROUPE ',IGG,' DIL. ',BACK,' ABS. <= 0.' + CALL XABORT('LIBA24:'//TEXTE) + ENDIF + IF(SUMS.LE.0.) THEN + WRITE(TEXTE,1000) + 1 HNAMIS,'GROUPE ',IGG,' DIL. ',BACK,' DIF. <= 0.' + CALL XABORT('LIBA24:'//TEXTE) + ENDIF + IF(LFIS .AND. SUMF.LE.0.) THEN + WRITE(TEXTE,1000) + 1 HNAMIS,'GROUPE ',IGG,' DIL. ',BACK,' FIS. <= 0.' + CALL XABORT('LIBA24:'//TEXTE) + ENDIF + IF(L104 .AND. (1.-SUM104/BACK).LE.0.) THEN + WRITE(TEXTE,1000) + 1 HNAMIS,'GROUPE ',IGG,' DIL. ',BACK,' FLU. <= 0.' + CALL XABORT('LIBA24:'//TEXTE) + ENDIF + DEALLOCATE(WEIGH,SEQ2) + ENDIF + 110 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(FLUXH,FISSH,DIFFH,ABSOH,SQRTEM,WEIJHT) + RETURN +* +1000 FORMAT(9H ISOTOPE:,A12,2X,A,I3,A,E13.5,A) +3000 FORMAT(A,E13.5,A,A,I3) +10000 FORMAT(A,I3,A,1P,E13.5,A,E13.5) + END diff --git a/Dragon/src/LIBA25.f b/Dragon/src/LIBA25.f new file mode 100644 index 0000000..3c18edc --- /dev/null +++ b/Dragon/src/LIBA25.f @@ -0,0 +1,244 @@ +*DECK LIBA25 + SUBROUTINE LIBA25(IPLIB,LABS,LDIF,LFIS,L104,NGRO,FGHOMO,NGHOMO, + 1 NSEQHO,NL,SEQHOM,SN,SB,DELTA,ISONAM,TAUX,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute self-shielded flux and cross sections from effective rates. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* LABS absorption reaction flag (=.true. if the absorption reaction +* is self-shielded). +* LDIF scattering reaction flag (=.true. if the scattering reaction +* is self-shielded). +* LFIS fission reaction flag (=.true. if the fission reaction is +* self-shielded). +* L104 resonance flux flag (=.true. if the apolib contains dilution +* /temperature-dependent flux information). If this information +* is not provided, it will be reconstructed from a balance +* relation. +* NGRO number of energy groups. +* FGHOMO first self-shielded energy group. +* NGHOMO number of self-shielded energy groups. +* NSEQHO number of tabulated dilutions. +* NL number of legendre orders required in the calculation +* NL=1 or higher. +* SEQHOM tabulated dilutions. +* SN dilution of isotope. +* SB dilution of isotope used in Livolant-Jeanpierre normalization. +* DELTA lethargy widths. +* ISONAM alias name of current isotope. +* TAUX interpolated effective rates: +* TAUX(I,1) absorption effective rates; +* TAUX(I,2) diffusion effective rates; +* TAUX(I,3) nu*fission effective rates; +* TAUX(I,4) pseudo-absorption effective rates used to +* reconstruct the self-shielded flux; +* TAUX(I,5) infinite-dilution absorption x-s. +* IMPX print flag. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + INTEGER NGRO,FGHOMO,NGHOMO,NSEQHO,NL,ISONAM(3),IMPX + REAL SEQHOM(NSEQHO),SN(NGRO),SB(NGRO),DELTA(NGRO),TAUX(NGHOMO,6) + LOGICAL LABS,LDIF,LFIS,L104 +*---- +* LOCAL VARIABLES +*---- + PARAMETER(IOUT=6) + CHARACTER HSMG*131,STAR*1 + LOGICAL LFIS2 + INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPRO + DOUBLE PRECISION TMP,TMP1,AUX,FAC,ZNPHI + REAL, ALLOCATABLE, DIMENSION(:) :: SECT,VECT,SIGF,SS1 + REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGS + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(ITYPRO(NGRO)) + ALLOCATE(SECT(NGRO),SIGS(NGRO,NL),SCAT(NGRO,NGRO,NL),VECT(NGRO), + 1 SIGF(NGRO),SS1(NGRO)) +*---- +* RECOVER INFINITE-DILUTION X-S INFORMATION. +*---- + CALL LCMGET(IPLIB,'NTOT0',SECT) + CALL XDRLGS(IPLIB,-1,IMPX,0,NL-1,1,NGRO,SIGS,SCAT,ITYPRO) + CALL LCMLEN(IPLIB,'NUSIGF',LENGT,ITYLCM) + IF(LENGT.EQ.NGRO) THEN + CALL LCMGET(IPLIB,'NUSIGF',SIGF) + LFIS2=LFIS + ELSE + SIGF(:NGRO)=0.0 + LFIS2=.FALSE. + ENDIF +*---- +* COMPUTE P0 TRANSFER PROBABILITIES. +*---- + DO 15 IG2=1,NGRO + VECT(IG2)=SIGS(IG2,1) + SECT(IG2)=SECT(IG2)-SIGS(IG2,1) + DO 10 IG1=1,NGRO + SCAT(IG2,IG1,1)=SCAT(IG2,IG1,1)/SIGS(IG1,1) + 10 CONTINUE + 15 CONTINUE +*---- +* RECOVER THE EFFECTIVE FLUX. +*---- + IF(IMPX.GT.4) WRITE(IOUT,200) + DO 20 L=1,NGRO + SS1(L)=1.0 + 20 CONTINUE + DO 50 L=FGHOMO,FGHOMO+NGHOMO-1 + SEIM=MAX(0.0,SN(L)) + IF(SEIM.EQ.0.) CALL XABORT('LIBA25: SELF SHIELDING FAILURE.') + IF(LABS.AND.LDIF) THEN +* COMPUTE THE EFFECTIVE FLUX. + TMP1=0.0D0 + DO 30 IG2=1,FGHOMO-1 + TMP1=TMP1+SCAT(L,IG2,1)*SIGS(IG2,1)*DELTA(IG2)/DELTA(L) + 30 CONTINUE + IF(TMP1.GT.5.0E-3*TAUX(L-FGHOMO+1,2)/DELTA(L)) THEN +* USE A SIMPLIFIED MODEL. + AUX=TAUX(L-FGHOMO+1,1)/DELTA(L) + ELSE +* USE A SLOWING-DOWN BALANCE EQUATION. + TMP=TMP1 + DO 40 IG2=FGHOMO,FGHOMO+NGHOMO-1 + TMP=TMP+SCAT(L,IG2,1)*TAUX(IG2-FGHOMO+1,2)/DELTA(L) + 40 CONTINUE + AUX=(TAUX(L-FGHOMO+1,1)+TAUX(L-FGHOMO+1,2))/DELTA(L)-TMP + ENDIF + ELSE IF(LABS) THEN +* COMPUTE THE EFFECTIVE FLUX USING A SIMPLIFIED MODEL. + AUX=TAUX(L-FGHOMO+1,1)/DELTA(L) + ELSE + AUX=0.0 + ENDIF +* + IF((NSEQHO.EQ.1).OR.(SB(L).GE.1.0E10)) THEN +* USE AN INFINITE DILUTION VALUE. + ZNPHI=0.0 + ELSE IF(L104.AND.(SEIM.GT.SEQHOM(NSEQHO-1))) THEN +* USE AN INTERPOLATED VALUE NEAR INFINITE DILUTION. + FAC=(SEQHOM(NSEQHO-1)/SEIM)**2 + ZNPHI=FAC*TAUX(L-FGHOMO+1,4)+(1.0D0-FAC)*AUX + ELSE IF(L104) THEN +* USE AN INTERPOLATED VALUE. + ZNPHI=TAUX(L-FGHOMO+1,4) + ELSE +* USE A CALCULATED VALUE. + ZNPHI=AUX + ENDIF + PHI0=REAL(1.0D0-ZNPHI/SB(L)) + STAR=' ' + IF((PHI0.LE.0.0).OR.(PHI0.GT.1.2)) THEN + STAR='*' + IF(IMPX.GT.4) THEN + WRITE(HSMG,220) PHI0,L,ZNPHI,SEIM,(ISONAM(I0),I0=1,3),STAR + WRITE(IOUT,'(/1X,A131)') HSMG + ENDIF + ENDIF + IF(PHI0.LE.0.0) PHI0=TAUX(L-FGHOMO+1,2)/DELTA(L)/VECT(L) + SS1(L)=PHI0 + SECT(L)=TAUX(L-FGHOMO+1,1)/DELTA(L)/PHI0 + IF(LFIS2) SIGF(L)=TAUX(L-FGHOMO+1,3)/DELTA(L)/PHI0 + IF(LDIF) SIGS(L,1)=TAUX(L-FGHOMO+1,2)/DELTA(L)/PHI0 + IF(IMPX.GT.4) WRITE(IOUT,210) L,PHI0,SIGF(L),SECT(L),SIGS(L,1), + 1 SEIM,SB(L),ZNPHI + 50 CONTINUE + IF(IMPX.GT.4) WRITE(IOUT,'(/)') +* + CALL LCMPUT(IPLIB,'NWT0',NGRO,2,SS1) +*---- +* SELF-SHIELDING OF THE TRANSFERT CROSS SECTIONS. +*---- + IF(LDIF) THEN + DO 65 IG1=1,NGRO + DO 60 IG2=1,NGRO + SCAT(IG2,IG1,1)=SCAT(IG2,IG1,1)*SIGS(IG1,1) + 60 CONTINUE + 65 CONTINUE + INGRO=NL-1 + DO 70 IL=NL-1,0,-1 + IF(ITYPRO(IL+1).EQ.0) THEN + INGRO=INGRO-1 + ELSE + GO TO 80 + ENDIF + 70 CONTINUE + 80 DO 100 IL=1,NL-1 + IF(ITYPRO(IL+1).GT.0) THEN + DO 95 IG2=1,NGRO + SIGS(IG2,IL+1)=SIGS(IG2,IL+1)*SIGS(IG2,1)/VECT(IG2) + DO 90 IG1=1,NGRO + SCAT(IG2,IG1,IL+1)=SCAT(IG2,IG1,IL+1)*SIGS(IG1,1)/VECT(IG1) + 90 CONTINUE + 95 CONTINUE + ENDIF + 100 CONTINUE +*---- +* SAVE SELF-SHIELDED X-S INFORMATION. +*---- + CALL XDRLGS(IPLIB,1,IMPX,0,INGRO,1,NGRO,SIGS,SCAT,ITYPRO) + ENDIF +*---- +* SELF-SHIELDING OF THE RADIATIVE CAPTURE CROSS SECTIONS. +*---- + CALL LCMLEN(IPLIB,'NG',LENGT,ITYLCM) + IF(LENGT.EQ.NGRO) THEN + CALL LCMGET(IPLIB,'NG',VECT) + DO 105 I=1,NGHOMO + IG=FGHOMO+I-1 + VECT(IG)=VECT(IG)*SECT(IG)*DELTA(IG)/TAUX(I,5) + 105 CONTINUE + CALL LCMPUT(IPLIB,'NG',NGRO,2,VECT) + ENDIF +*---- +* SELF-SHIELDING OF THE FISSION CROSS SECTIONS. +*---- + IF(LFIS2) THEN + CALL LCMGET(IPLIB,'NUSIGF',SS1) + CALL LCMGET(IPLIB,'NFTOT',VECT) + DO 110 I=1,NGRO + IF(SS1(I).NE.0.0) VECT(I)=VECT(I)*SIGF(I)/SS1(I) + 110 CONTINUE + CALL LCMPUT(IPLIB,'NFTOT',NGRO,2,VECT) + CALL LCMPUT(IPLIB,'NUSIGF',NGRO,2,SIGF) + ENDIF +* + DO 120 I=1,NGRO + SECT(I)=SECT(I)+SIGS(I,1) + 120 CONTINUE + CALL LCMPUT(IPLIB,'NTOT0',NGRO,2,SECT) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SS1,SIGF,VECT,SCAT,SIGS,SECT) + DEALLOCATE(ITYPRO) + RETURN +* + 200 FORMAT(/5X,'GROUP',11X,'PHI0',10X,'SIGF0',10X,'SIGA0',10X, + 1 'SIGS0',10X,'DILUT',13X,'SB',10X,'ZNPHI') + 210 FORMAT(5X,I5,1P,7E15.5) + 220 FORMAT(47HLIBA25: *** WARNING *** INVALID VALUE OF PHI0 (,1P, + 1 E11.3,0P,10H) IN GROUP,I4,8H. ZNPHI=,1P E11.3,2X,5HSEIM=,E11.3, + 2 2X,5HISO=',3A4,2H' ,A1) + END diff --git a/Dragon/src/LIBA26.f b/Dragon/src/LIBA26.f new file mode 100644 index 0000000..539e3e0 --- /dev/null +++ b/Dragon/src/LIBA26.f @@ -0,0 +1,159 @@ +*DECK LIBA26 + SUBROUTINE LIBA26(LGSEG,IG,NGBIN,IUNIT,LBLOC,TKCARO,TCAROB,NSIGF, + 1 TT,NTEMPS,TEMPS,DELTF,SIGTF,SIGAF,DELINF,SGTINF,SGAINF) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Temperature interpolation of autolib (bin cross sections) information. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* LGSEG dimension of the directory block. +* IG coarse energy group under consideration. +* NGBIN number of coarse energy groups. +* IUNIT APOLIB-2 file unit number. +* LBLOC number of words in the direct access buffer. +* TKCARO index array used to parse tcarob. +* TCAROB directory block. +* NSIGF number of fine energy groups. +* TT temperature of isotope. +* NTEMPS number of tabulated temperatures. +* TEMPS tabulated temperatures. +* +*Parameters: output +* DELTF fine group lethargy widths. +* SIGTF fine group total x-s. +* SIGAF fine group absorption x-s. +* DELINF calculated lethargy width for group IG. +* SGTINF calculated infinite-dilution total x-s for group IG. +* SGAINF calculated infinite-dilution absorption x-s for group IG. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER LGSEG,TKCARO(31),TCAROB(LGSEG),IG,NGBIN,IUNIT,LBLOC,NSIGF, + 1 NTEMPS + REAL TT,TEMPS(NTEMPS),DELTF(NSIGF),SIGTF(NSIGF),SIGAF(NSIGF), + 1 DELINF,SGTINF,SGAINF +*---- +* LOCAL VARIABLES +*---- + EXTERNAL LIBA21 + CHARACTER HSMG*131,TYPSEG*8 + PARAMETER (NINT=2,DTMIN=1.0) + DOUBLE PRECISION D1,D2,D3 + LOGICAL LOK + TYPE(C_PTR) ICHDIM_PTR,ICHTYP_PTR,ICHDKL_PTR,TSEGM_PTR + INTEGER, POINTER, DIMENSION(:) :: ICHDIM,ICHTYP,ICHDKL,ITSEGM + REAL, POINTER, DIMENSION(:) :: RTSEGM + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SQRTEM,WEIJHT +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(WEIJHT(NTEMPS),SQRTEM(NTEMPS)) +*---- +* COMPUTE THE WEIGHTS. +*---- + DO 10 I=1,NTEMPS + SQRTEM(I)=SQRT(TEMPS(I)) + 10 CONTINUE + IF(NTEMPS.EQ.1) THEN + IPROX=1 + IGTFIX=1 + ELSE + STT=SQRT(TT) + CALL LIBA28(STT,SQRTEM,NTEMPS,NINT,WEIJHT,IORD,IPROX,I0) + IF(ABS(TT-TEMPS(IPROX)).LE.DTMIN) THEN + IGTFIX=1 + ELSEIF((STT.LT.SQRTEM(1)).OR.(STT.GT.SQRTEM(NTEMPS))) THEN + WRITE(HSMG,'(A,F8.2,A,F8.2,A,F8.2)') + 1 'LIBA26: A TEMPSERATURE', TT,'K IS NOT INCLUDED BETWEEN ', + 2 TEMPS(1),' AND ',TEMPS(NTEMPS) + WRITE(6,'(/1X,A)') HSMG + IGTFIX=2 + ELSE + IGTFIX=0 + ENDIF + ENDIF +*---- +* LOOP OVER TABULATED TEMPERATURES. +*---- + D1=0.0D0 + IDKDS=1-TKCARO(10) + IDKTS=1-TKCARO(23) + IDKLS=TKCARO(8) + JDKDS=TCAROB(IDKDS) + JDKTS=TCAROB(IDKTS) + SIGTF(:NSIGF)=0.0 + SIGAF(:NSIGF)=0.0 + DO 50 J=1,IORD + IT=I0+J + IS=(IT-1)*NGBIN+IG + IDK=JDKTS+8*(IS-1) + CALL AEXCPC(IDK,8,TCAROB,TYPSEG) + LNGS=TCAROB(IDKLS+IS) + IF(LNGS.LE.0) CALL XABORT('LIBA26: INVALID PTHOM5(1).') + JDKS=TCAROB(JDKDS+IS) + CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR,ICHDKL_PTR) + CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) + CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) + CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) + TSEGM_PTR=LCMARA(LNGS+1) + CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) + CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /)) + CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1) + CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDD,NV) + IF(NV.NE.NSIGF) CALL XABORT('LIBA26: INVALID PTHOM5(2).') + CALL AEXGNV(3,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDT,NV) + CALL AEXGNV(5,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDA,NV) + CALL LCMDRD(ICHDIM_PTR) + CALL LCMDRD(ICHTYP_PTR) + CALL LCMDRD(ICHDKL_PTR) + IF(IT.EQ.I0+1) THEN + D1=0.0D0 + DO 20 I=1,NSIGF + DELTF(I)=RTSEGM(IDD+I-1) + D1=D1+DELTF(I) + 20 CONTINUE + ELSE + LOK=.TRUE. + DO 30 I=1,NSIGF + LOK=LOK.AND.(DELTF(I).EQ.RTSEGM(IDD+I-1)) + 30 CONTINUE + IF(.NOT.LOK) CALL XABORT('LIBA26: INVALID AUTOLIB MESH.') + ENDIF + DO 40 I=1,NSIGF + SIGTF(I)=SIGTF(I)+REAL(WEIJHT(J)*RTSEGM(IDT+I-1)) + SIGAF(I)=SIGAF(I)+REAL(WEIJHT(J)*RTSEGM(IDA+I-1)) + 40 CONTINUE + CALL LCMDRD(TSEGM_PTR) + 50 CONTINUE + D2=0.0D0 + D3=0.0D0 + DO 60 I=1,NSIGF + SIGTF(I)=MAX(SIGTF(I),0.0) + SIGAF(I)=MAX(SIGAF(I),0.0) + D2=D2+SIGTF(I)*DELTF(I) + D3=D3+SIGAF(I)*DELTF(I) + 60 CONTINUE + DELINF=REAL(D1) + SGTINF=REAL(D2/D1) + SGAINF=REAL(D3/D1) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SQRTEM,WEIJHT) + RETURN + END diff --git a/Dragon/src/LIBA27.f b/Dragon/src/LIBA27.f new file mode 100644 index 0000000..508be5c --- /dev/null +++ b/Dragon/src/LIBA27.f @@ -0,0 +1,248 @@ +*DECK LIBA27 + SUBROUTINE LIBA27(NAMFIL,NBISO,NISOT,NSEGM,NL,ISONRF,ISHINA, + 1 MASKI,NOM,NOMOB,IPR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Probe the APOLIB-2 file and compute the IPR main index vector. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NAMFIL name of the APOLIB-2 file. +* NBISO number of isotopes present in the calculation domain. +* NISOT number of isotopes in the PHEAD segment. +* NSEGM number of APOLIBE segments in the APOLIB-2 file. +* NL number of Legendre orders required in the calculation +* NL=1 or higher. +* ISONRF library name of isotopes. +* ISHINA self shielding name. +* MASKI isotopic mask. Isotope with index I is processed if +* MASKI(I)=.true. +* NOM isotope names in the PHEAD segment. +* NOMOB APOLIBE segment names. +* +*Parameters: output +* IPR main index vector: +* IPR(1,I) index in PHEAD segment table; +* IPR(2,I) segment index of main data (ISOTOP); +* IPR(3,I) segment index of production data (PHYSIQ); +* IPR(4,I) segment index of delayed neutron data (BETAEF); +* IPR(5,I) segment index of main ss data (SSDATA); +* IPR(6,I) segment index of 104 flux data (SSPOND); +* IPR(7,I) segment index of autolib data (SSSECT); +* IPR(..,I) segment index of pn diff xs data (DIFF..); +* IPR(..,I) segment index of pn transfer data (TRAN..). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER NAMFIL*(*) + INTEGER NBISO,NISOT,NSEGM,NL,ISONRF(3,NBISO),ISHINA(3,NBISO), + 1 NOM(5,NISOT),NOMOB(7,NSEGM),IPR(7+2*(NL-1),NBISO) + LOGICAL MASKI(NBISO) +*---- +* LOCAL VARIABLES +*---- + CHARACTER TEXT20*20,HNISOR*12,HNISSS*12,HSMG*131 + INTEGER NITCA(5) +* + IPR(:7+2*(NL-1),:NBISO)=0 + DO 200 IMX=1,NBISO + IF(MASKI(IMX)) THEN + WRITE(HNISOR,'(3A4)') (ISONRF(I0,IMX),I0=1,3) + WRITE(HNISSS,'(3A4)') (ISHINA(I0,IMX),I0=1,3) + CALL LCMCAR(HNISOR,.TRUE.,NITCA) + KISO=0 + DO 10 ISO=1,NISOT + IF(NITCA(1).EQ.NOM(1,ISO)) THEN + IF(NITCA(2).EQ.NOM(2,ISO)) THEN + IF(NITCA(3).EQ.NOM(3,ISO)) THEN + KISO=ISO + GO TO 20 + ENDIF + ENDIF + ENDIF + 10 CONTINUE + WRITE (HSMG,300) HNISOR,NAMFIL + CALL XABORT(HSMG) + 20 IPR(1,IMX)=KISO +* + TEXT20='ISOTOP'//HNISOR(:12) + CALL LCMCAR(TEXT20,.TRUE.,NITCA) + KISEG=0 + DO 30 ISEG=1,NSEGM + IF(NITCA(1).EQ.NOMOB(1,ISEG)) THEN + IF(NITCA(2).EQ.NOMOB(2,ISEG)) THEN + IF(NITCA(3).EQ.NOMOB(3,ISEG)) THEN + IF(NITCA(4).EQ.NOMOB(4,ISEG)) THEN + IF(NITCA(5).EQ.NOMOB(5,ISEG)) THEN + KISEG=ISEG + GO TO 40 + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + 30 CONTINUE + WRITE (HSMG,300) HNISOR,NAMFIL + CALL XABORT(HSMG) + 40 IPR(2,IMX)=KISEG +* + TEXT20='PHYSIQ'//HNISOR(:12) + CALL LCMCAR(TEXT20,.TRUE.,NITCA) + KISEG=0 + DO 50 ISEG=1,NSEGM + IF(NITCA(1).EQ.NOMOB(1,ISEG)) THEN + IF(NITCA(2).EQ.NOMOB(2,ISEG)) THEN + IF(NITCA(3).EQ.NOMOB(3,ISEG)) THEN + IF(NITCA(4).EQ.NOMOB(4,ISEG)) THEN + IF(NITCA(5).EQ.NOMOB(5,ISEG)) THEN + KISEG=ISEG + GO TO 60 + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + 50 CONTINUE + 60 IPR(3,IMX)=KISEG +* + TEXT20='BETAEF'//HNISOR(:12) + CALL LCMCAR(TEXT20,.TRUE.,NITCA) + KISEG=0 + DO 70 ISEG=1,NSEGM + IF(NITCA(1).EQ.NOMOB(1,ISEG)) THEN + IF(NITCA(2).EQ.NOMOB(2,ISEG)) THEN + IF(NITCA(3).EQ.NOMOB(3,ISEG)) THEN + IF(NITCA(4).EQ.NOMOB(4,ISEG)) THEN + IF(NITCA(5).EQ.NOMOB(5,ISEG)) THEN + KISEG=ISEG + GO TO 80 + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + 70 CONTINUE + 80 IPR(4,IMX)=KISEG +* + IF(HNISSS.NE.' ') THEN + TEXT20='SSDATA'//HNISSS(:12) + CALL LCMCAR(TEXT20,.TRUE.,NITCA) + KISEG=0 + DO 90 ISEG=1,NSEGM + IF(NITCA(1).EQ.NOMOB(1,ISEG)) THEN + IF(NITCA(2).EQ.NOMOB(2,ISEG)) THEN + IF(NITCA(3).EQ.NOMOB(3,ISEG)) THEN + IF(NITCA(4).EQ.NOMOB(4,ISEG)) THEN + IF(NITCA(5).EQ.NOMOB(5,ISEG)) THEN + KISEG=ISEG + GO TO 100 + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + 90 CONTINUE + WRITE (HSMG,310) HNISSS,NAMFIL + CALL XABORT(HSMG) + 100 IPR(5,IMX)=KISEG +* + TEXT20='SSPOND'//HNISSS(:12) + CALL LCMCAR(TEXT20,.TRUE.,NITCA) + KISEG=0 + DO 110 ISEG=1,NSEGM + IF(NITCA(1).EQ.NOMOB(1,ISEG)) THEN + IF(NITCA(2).EQ.NOMOB(2,ISEG)) THEN + IF(NITCA(3).EQ.NOMOB(3,ISEG)) THEN + IF(NITCA(4).EQ.NOMOB(4,ISEG)) THEN + IF(NITCA(5).EQ.NOMOB(5,ISEG)) THEN + KISEG=ISEG + GO TO 120 + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + 110 CONTINUE + 120 IPR(6,IMX)=KISEG +* + TEXT20='SSSECT'//HNISSS(:12) + CALL LCMCAR(TEXT20,.TRUE.,NITCA) + KISEG=0 + DO 130 ISEG=1,NSEGM + IF(NITCA(1).EQ.NOMOB(1,ISEG)) THEN + IF(NITCA(2).EQ.NOMOB(2,ISEG)) THEN + IF(NITCA(3).EQ.NOMOB(3,ISEG)) THEN + IF(NITCA(4).EQ.NOMOB(4,ISEG)) THEN + IF(NITCA(5).EQ.NOMOB(5,ISEG)) THEN + KISEG=ISEG + GO TO 140 + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + 130 CONTINUE + 140 IPR(7,IMX)=KISEG + ENDIF +* + DO 190 IL=2,NL + WRITE(TEXT20,'(4HDIFF,I2.2,A12)') IL-1,HNISOR + CALL LCMCAR(TEXT20,.TRUE.,NITCA) + KISEG=0 + DO 150 ISEG=1,NSEGM + IF(NITCA(1).EQ.NOMOB(1,ISEG)) THEN + IF(NITCA(2).EQ.NOMOB(2,ISEG)) THEN + IF(NITCA(3).EQ.NOMOB(3,ISEG)) THEN + IF(NITCA(4).EQ.NOMOB(4,ISEG)) THEN + IF(NITCA(5).EQ.NOMOB(5,ISEG)) THEN + KISEG=ISEG + GO TO 160 + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + 150 CONTINUE + 160 IPR(7+(IL-1),IMX)=KISEG +* + WRITE(TEXT20,'(4HTRAN,I2.2,A12)') IL-1,HNISOR + CALL LCMCAR(TEXT20,.TRUE.,NITCA) + KISEG=0 + DO 170 ISEG=1,NSEGM + IF(NITCA(1).EQ.NOMOB(1,ISEG)) THEN + IF(NITCA(2).EQ.NOMOB(2,ISEG)) THEN + IF(NITCA(3).EQ.NOMOB(3,ISEG)) THEN + IF(NITCA(4).EQ.NOMOB(4,ISEG)) THEN + IF(NITCA(5).EQ.NOMOB(5,ISEG)) THEN + KISEG=ISEG + GO TO 180 + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + 170 CONTINUE + 180 IPR(7+(NL-1)+(IL-1),IMX)=KISEG + 190 CONTINUE + ENDIF + 200 CONTINUE + RETURN +* + 300 FORMAT(26HLIBA27: MATERIAL/ISOTOPE ',A12,20H' IS MISSING ON APOL, + 1 15HIB-2 FILE NAME ,A12,1H.) + 310 FORMAT(49HLIBA27: SELF-SHIELDING DATA OF MATERIAL/ISOTOPE ',A12, + 1 35H' IS MISSING ON APOLIB-2 FILE NAME ,A12,1H.) + END diff --git a/Dragon/src/LIBA28.f b/Dragon/src/LIBA28.f new file mode 100644 index 0000000..ab4e15e --- /dev/null +++ b/Dragon/src/LIBA28.f @@ -0,0 +1,117 @@ +*DECK LIBA28 + SUBROUTINE LIBA28(X,XP,NXP,LL,FP,L,IPROX,I0) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the interpolation weights FP for the Lagrange interpolation. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* X abscissa. +* XP tabulated abscissa. +* NXP number of tabulated points. +* LL requested interpolation order. +* +*Parameters: output +* FP weights for Lagrange interpolation. +* L interpolation limit (number of non-zero weights). +* IPROX index of closest tabulated point. +* I0 number of leading zero weights. +* +*Comments: +* Evaluation method. +* F(X) = sum for I = 1 to L of F(I+I0)*FP(I) +* for LL.le.NXP uses an LL-point "centered" Lagrange interpolation, +* otherwise it uses a linear interpolation formula. +* Attention: it is assumed that XP(I+1) > XP(I) for all I +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NXP,LL,L,IPROX,I0 + REAL X + DOUBLE PRECISION XP(NXP),FP(LL) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION PP,XI,XX +* + L=LL + IF(L.LE.NXP) GO TO 20 +*---- +* CONSTANT FUNCTION DEFINED BY A SINGLE POINT +*---- + IF(NXP.LE.1)THEN + I0=0 + L=1 + IPROX=1 + FP(1)=1.0D0 + GO TO 100 + ENDIF +*---- +* NXP < L: SWITCH TO LINEAR INTERPOLATION +*---- + L=2 + 20 L2=(L+1)/2 +*---- +* LOCATE FIRST POINT TO THE RIGHT OF XX (PT IXP) +*---- + DO 30 IXP=1,NXP + IF(XP(IXP).GT.X)GO TO 40 + 30 CONTINUE +*---- +* X IS TO THE RIGHT OF EVERY POINT XP +*---- + IXP=1 + IPROX=NXP + GO TO 60 +*---- +* XP(IMIN) IS THE FIRST POINT FOR THE INTERPOLATION +*---- + 40 IMIN=IXP-L2 + IPROX=IXP + IF(IXP.GT.1)THEN + IF((X-XP(IXP-1)).LT.(XP(IXP)-X))IPROX=IXP-1 + ENDIF + IF(L.EQ.1)THEN + FP(1)=1.0D0 + I0=IPROX-1 + GO TO 100 + ENDIF + IF(IMIN.GE.1)GO TO 50 + IMIN=1 + IMAX=L + GO TO 70 +*---- +* XP(IMAX) IS THE LAST POINT FOR THE INTERPOLATION +*---- + 50 IMAX=IMIN+L-1 + IF(IMAX.LE.NXP)GO TO 70 + 60 IMAX=NXP + IMIN=NXP-L+1 +*---- +* CENTERED POLYNOMIAL INTERPOLATION OF DEGRE L +*---- + 70 I0=IMIN-1 + XX=X + DO 90 I=IMIN,IMAX + PP=1.0D0 + XI=XP(I) + DO 80 J=IMIN,IMAX + IF(I.NE.J)PP=PP*((XX-XP(J))/(XI-XP(J))) + 80 CONTINUE + FP(I+1-IMIN)=PP + 90 CONTINUE + 100 RETURN + END diff --git a/Dragon/src/LIBA2G.f b/Dragon/src/LIBA2G.f new file mode 100644 index 0000000..0969f81 --- /dev/null +++ b/Dragon/src/LIBA2G.f @@ -0,0 +1,137 @@ +*DECK LIBA2G + SUBROUTINE LIBA2G (NAMFIL,NGRO,IPENER) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover energy group information from an APOLIB2 library. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NAMFIL name of the APOLIB2 file. +* +*Parameters: output +* NGRO number of energy groups. +* IPENER pointer of the energy mesh limit array. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* Subroutine arguments +*---- + INTEGER NGRO + CHARACTER NAMFIL*(*) + TYPE(C_PTR) IPENER +*---- +* Local variables +*---- + PARAMETER (IACTO=2,IACTC=1,ILIBDA=4) + EXTERNAL LIBA21 + INTEGER ISFICH(3) + CHARACTER TEXT80*80,NOMOBJ*20,TYPOBJ*8,TYPSEG*8,HSMG*131 +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: VINTE,ITCARO + INTEGER, POINTER, DIMENSION(:) :: ITSEGM + REAL, POINTER, DIMENSION(:) :: RTSEGM + TYPE(C_PTR) ICHDIM_PTR,ICHTYP_PTR,ICHDKL_PTR,TSEGM_PTR + INTEGER, POINTER, DIMENSION(:) :: ICHDIM,ICHTYP,ICHDKL + REAL, POINTER, DIMENSION(:) :: ENERG +* + INTEGER TKCARO(31) + SAVE TKCARO + DATA TKCARO / + & 0, 1, 2, 3, 4, 5, 6, 30, 7, -8, + & 9, -10, 11, -12, 13, -14, 15, 16, -17, 18, + & -19, 20, -21, 22, 23, -24, 25, -26, 27, -28, + & 29 / +* + CALL AEXTPA(NAMFIL,ISFICH) + IADRES=ISFICH(1) + NBOBJ=ISFICH(2) + LBLOC=ISFICH(3) + IUNIT=KDROPN(NAMFIL,IACTO,ILIBDA,LBLOC) + IF(IUNIT.LE.0) THEN + WRITE(HSMG,'(26HLIBA2G: APOLLO-2 LIBRARY '',A16,9H'' CANNOT , + > 29HBE OPENED BY KDROPN (ERRCODE=,I2,2H).)') NAMFIL,IUNIT + CALL XABORT(HSMG) + ENDIF + ALLOCATE(VINTE(2*NBOBJ)) + CALL AEXDIR(IUNIT,LBLOC,VINTE,IADRES,2*NBOBJ) + IDKSV=1-TKCARO(12) + IDKNO=1-TKCARO(14) + IDKTY=1-TKCARO(21) + IDKDS=1-TKCARO(10) + IDKTS=1-TKCARO(23) + IDKNS=TKCARO(2)+1 + IDKLS=TKCARO(8) + DO 150 IOBJ=3,NBOBJ + IDKOBJ=VINTE(2*IOBJ-1) + LGSEG=VINTE(2*IOBJ)+1 + ALLOCATE(ITCARO(LGSEG)) + CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG) + IDK=ITCARO(IDKSV) + CALL AEXCPC(IDK,80,ITCARO,TEXT80) +* + IDK=ITCARO(IDKNO) + CALL AEXCPC(IDK,20,ITCARO,NOMOBJ) + IDK=ITCARO(IDKTY) + CALL AEXCPC(IDK,8,ITCARO,TYPOBJ) + IF(TYPOBJ.EQ.'APOLIB') THEN + JDKDS=ITCARO(IDKDS) + JDKTS=ITCARO(IDKTS) + NS=ITCARO(IDKNS) + DO 140 IS=1,NS + IDK=JDKTS+8*(IS-1) + CALL AEXCPC(IDK,8,ITCARO,TYPSEG) + IF(TYPSEG.EQ.'PMAIL') THEN + LNGS=ITCARO(IDKLS+IS) + JDKS=ITCARO(JDKDS+IS) + TSEGM_PTR=LCMARA(LNGS+1) + CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) + CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /)) + CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1) + CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, + 1 ICHDKL_PTR) + CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) + CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) + CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) + CALL AEXGNV(3,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + NGRO=NV-1 + IPENER=LCMARA(NGRO+1) + CALL C_F_POINTER(IPENER,ENERG,(/ NGRO+1 /)) + DO 130 IG=1,NV + ENERG(IG)=RTSEGM(IDK+IG-1)*1.0E6 + 130 CONTINUE + CALL LCMDRD(ICHDIM_PTR) + CALL LCMDRD(ICHTYP_PTR) + CALL LCMDRD(ICHDKL_PTR) + CALL LCMDRD(TSEGM_PTR) + DEALLOCATE(ITCARO) + GO TO 160 + ENDIF + 140 CONTINUE + ENDIF + DEALLOCATE(ITCARO) + 150 CONTINUE + CALL XABORT('LIBA2G: NO GROUP STRUCTURE AVAILABLE') +* + 160 IERR=KDRCLS(IUNIT,IACTC) + IF(IERR.LT.0) THEN + WRITE(HSMG,'(26HLIBA2G: APOLLO-2 LIBRARY '',A16,9H'' CANNOT , + > 29HBE CLOSED BY KDRCLS (ERRCODE=,I2,2H).)') NAMFIL,IERR + CALL XABORT(HSMG) + ENDIF + DEALLOCATE(VINTE) + RETURN + END diff --git a/Dragon/src/LIBA30.f b/Dragon/src/LIBA30.f new file mode 100644 index 0000000..7c5e47a --- /dev/null +++ b/Dragon/src/LIBA30.f @@ -0,0 +1,533 @@ +*DECK LIBA30 + SUBROUTINE LIBA30 (IPLIB,NAMFIL,NGRO,NBISO,NL,ISONAM,ISONRF, + 1 IPISO,MASKI,TN,LSHI,SN,SB,IMPX,NGF,NGFR,NDEL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transcription of the useful interpolated microscopic cross section +* data from APOLIB-3 to LCM data structures. +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* NAMFIL name of the APOLIB-3 file in HDF5 format. +* NGRO number of energy groups. +* NBISO number of isotopes present in the calculation domain. +* NL number of Legendre orders required in the calculation +* NL=1 or higher. +* ISONAM alias name of isotopes. +* ISONRF library reference name of isotopes. +* IPISO pointer array towards microlib isotopes. +* MASKI isotopic mask. Isotope with index I is processed if +* MASKI(I)=.true. +* TN temperature of each isotope. +* LSHI resonant region number associated with each isotope. +* Infinite dilution will be assumed if LSHI(i)=0. +* SN dilution cross section in each energy group of each +* isotope. a value of 1.0E10 is used for infinite dilution. +* SB dilution cross section as used by Livolant and Jeanpierre +* normalization. +* IMPX print flag. +* +*Parameters: output +* NGF number of fast groups without self-shielding. +* NGFR number of fast and resonance groups. +* NDEL number of precursor groups for delayed neutrons. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB,IPISO(NBISO) + INTEGER NGRO,NBISO,NL,ISONAM(3,NBISO),ISONRF(3,NBISO),LSHI(NBISO), + 1 IMPX,NGF,NGFR,NDEL + REAL TN(NBISO),SN(NGRO,NBISO),SB(NGRO,NBISO) + CHARACTER NAMFIL*(*) + LOGICAL MASKI(NBISO) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPAP1,IPAP2 + PARAMETER (IOUT=6) + TYPE(C_PTR) KPLIB + CHARACTER RECNAM*80,RECNA2*80,TEXT80*80,HNAMIS*12,HNISOR*12, + 1 HSMG*131,TEXT12*12,CFILNA1*64,CFILNA2*64 + LOGICAL L104,LSIGS,LABSO,LFISS,LDIF + INTEGER RANK,TYPE,NBYTE,DIMSR(5) + DOUBLE PRECISION XDRCST,DSUM + REAL TKT(5) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPRO,ORANIS,ENRANG, + 1 FSTTMP,TMPMON,ADDTMP,ITEMPA,ISPAOF,IAFAG,IFAGR,FLXADD + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IPR + REAL, ALLOCATABLE, DIMENSION(:) :: ENERG,DELTA,SECT,XSTOT,TAUX, + 1 AMASS,TEMP,TEMPM,XS,WGTFLX,BGXS,ABSOXS,DIFFXS,FISSXS,DK104 + REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGS + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT + CHARACTER(LEN=24), ALLOCATABLE, DIMENSION(:) :: NOM,NOMS,HREANM +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IPR(2,NBISO),ITYPRO(NL)) + ALLOCATE(SECT(NGRO),SIGS(NGRO,NL),SCAT(NGRO,NGRO,NL),XSTOT(NGRO)) +* + ANEUT=REAL(XDRCST('Neutron mass','amu')) + NGF=NGRO+1 + NGFR=0 + NDEL=0 + IF(IMPX.GT.0) WRITE (IOUT,800) NAMFIL +*---- +* OPEN THE APOLIB-3 FILE. +*---- + IND = INDEX(NAMFIL, ":") + IF(IND.EQ.0) THEN + CFILNA1=NAMFIL + CFILNA2=" " + ELSE + CFILNA1=NAMFIL(:IND-1) + CFILNA2=NAMFIL(IND+1:) + ENDIF + CALL hdf5_open_file(CFILNA1, IPAP1, .TRUE.) + IF(IMPX.GT.0) THEN + CALL hdf5_read_data(IPAP1,"Head/LibraryInfo",TEXT80) + WRITE (IOUT,810) TEXT80 + WRITE (IOUT,'(40H LIBA30: NUMBER OF ISOTOPES IN MICROLIB=,I6)') + 1 NBISO + ENDIF + CALL hdf5_read_data(IPAP1,"Head/nbIs",NISOT) + CALL hdf5_read_data(IPAP1,"Head/IsNames",NOM) + IF(IMPX.GE.10) THEN + DO ISO=1,NISOT + WRITE(IOUT,'(8H -----> ,A)') TRIM(NOM(ISO)) + ENDDO + ENDIF + NISOTS=0 + IF(CFILNA2.NE.' ') THEN + CALL hdf5_open_file(CFILNA2, IPAP2, .TRUE.) + CALL hdf5_read_data(IPAP2,"Isotopes/NIsotope",NISOTS) + CALL hdf5_read_data(IPAP2,"Isotopes/IsoNames",NOMS) + IF(IMPX.GE.10) THEN + DO ISO=1,NISOTS + WRITE(IOUT,'(8H SS---> ,A)') TRIM(NOMS(ISO)) + ENDDO + ENDIF + ENDIF +*---- +* RECOVER INFORMATION FROM EnergyMesh GROUP +*---- + CALL hdf5_read_data(IPAP1, "EnergyMesh/nbGr", NGRI) + CALL hdf5_read_data(IPAP1, "EnergyMesh/EnMshInMeV", ENERG) + CALL hdf5_read_data(IPAP1, "EnergyMesh/EnGrInLtg", DELTA) + ENERG(:NGRO+1)=ENERG(:NGRO+1)*1.E6 + IF(NGRI.NE.NGRO) CALL XABORT('LIBA30: INVALIB NGRO.') + CALL LCMPUT(IPLIB,'ENERGY',NGRO+1,2,ENERG) + CALL LCMPUT(IPLIB,'DELTAU',NGRO,2,DELTA) +*---- +* RECOVER INFORMATION FROM PhysicalData GROUP +*---- + CALL hdf5_read_data(IPAP1, "PhysicalData/AtomicMass", AMASS) + IF(SIZE(AMASS).NE.NISOT) CALL XABORT('LIBA30: INVALIB NISOT.') + DO IA=1,NISOT + AMASS(IA)=AMASS(IA)/ANEUT + ENDDO +*---- +* RECOVER INFORMATION FROM WeightFlux GROUP +*---- + CALL hdf5_read_data(IPAP1, "WeightFlux/nbFluxTypes", NBFLX) + IF(NBFLX.GT.0) THEN + CALL hdf5_read_data(IPAP1, "WeightFlux/FlxAdd", FLXADD) + CALL hdf5_read_data(IPAP1, "WeightFlux/WgtFlx", WGTFLX) + ENDIF +*---- +* SET THE CORRESPONDANCE BETWEEN THE APOLIB AND THE LIST OF ISOTOPES. +*---- + IF(IMPX.GT.1) WRITE(IOUT,820) NISOT,NISOTS + IPR(:2,:NBISO)=0 + CALL KDRCPU(TK1) + DO 50 IMX=1,NBISO + IF(MASKI(IMX)) THEN + WRITE(HNISOR,'(3A4)') (ISONRF(I0,IMX),I0=1,3) + KISO=0 + DO 10 ISO=1,NISOT + IF(HNISOR.EQ.NOM(ISO)) THEN + KISO=ISO + GO TO 20 + ENDIF + 10 CONTINUE + WRITE (HSMG,780) HNISOR,TRIM(CFILNA1) + CALL XABORT(HSMG) + 20 IPR(1,IMX)=KISO +* + IF((NISOTS.GT.0).AND.(LSHI(IMX).GT.0)) THEN + KISO=0 + DO 30 ISO=1,NISOTS + IF(HNISOR.EQ.NOMS(ISO)) THEN + KISO=ISO + GO TO 40 + ENDIF + 30 CONTINUE + WRITE (HSMG,790) HNISOR,TRIM(CFILNA2) + CALL XABORT(HSMG) + 40 IPR(2,IMX)=KISO + ENDIF + ENDIF + 50 CONTINUE + DEALLOCATE(NOM) + IF(NISOTS.GT.0) DEALLOCATE(NOMS) + CALL KDRCPU(TK2) + TKT(1)=TK2-TK1 +*---- +* RECOVER INFORMATION FROM TemperatureM GROUP +*---- + CALL hdf5_read_data(IPAP1, "TemperatureM/TempMshAdd", ITEMPA) + CALL hdf5_read_data(IPAP1, "TemperatureM/TempMesh", TEMPM) +*---- +* PROCESS INFINITE DILUTION INFORMATION. +*---- + CALL KDRCPU(TK1) + DO 560 IMX=1,NBISO + KISEG=IPR(1,IMX) + IF(KISEG.GT.0) THEN + WRITE(HNAMIS,'(3A4)') (ISONAM(I0,IMX),I0=1,3) + WRITE(HNISOR,'(3A4)') (ISONRF(I0,IMX),I0=1,3) + IF(IMPX.GT.0) WRITE (IOUT,830) HNAMIS,HNISOR + IF(IMPX.GT.1) WRITE(IOUT,'(/29H LIBA30: PROCESSING ISOTOPE '', + 1 A,2H''.)') TRIM(HNISOR) + WRITE(TEXT80,'(18HAPOLIB-3 ISOTOPE: ,A)') TRIM(HNISOR) +*---- +* RECOVER INFORMATION FROM Dimensions GROUP +*---- + WRITE(RECNAM,'(10HIsotopeXS/,A,12H/Dimensions/)') TRIM(HNISOR) + CALL hdf5_read_data(IPAP1, TRIM(RECNAM)//"nbRea", NBREA) + CALL hdf5_read_data(IPAP1, TRIM(RECNAM)//"orAnis", ORANIS) + CALL hdf5_read_data(IPAP1, TRIM(RECNAM)//"nbTemp", NBTMP) + CALL hdf5_read_data(IPAP1, TRIM(RECNAM)//"nbTypEner", NBTENR) +*---- +* RECOVER INFORMATION FROM Info GROUP +*---- + WRITE(RECNAM,'(10HIsotopeXS/,A,6H/Info/)') TRIM(HNISOR) + CALL hdf5_read_data(IPAP1, TRIM(RECNAM)//"WgtFlxON", IWFLON) + CALL hdf5_read_data(IPAP1, TRIM(RECNAM)//"isFissile", ISFIS) + CALL hdf5_read_data(IPAP1, TRIM(RECNAM)//"isTranProb", ITPROB) + CALL hdf5_read_data(IPAP1, TRIM(RECNAM)//"FstTmpDepGr", FSTTMP) + CALL hdf5_read_data(IPAP1, TRIM(RECNAM)//"EnergyRange", ENRANG) + CALL hdf5_read_data(IPAP1, TRIM(RECNAM)//"ReaNames", HREANM) + CALL hdf5_read_data(IPAP1, TRIM(RECNAM)//"ChiErgMshInd", ICHIEG) + CALL hdf5_read_data(IPAP1, TRIM(RECNAM)//"TempMshON", TMPMON) + CALL hdf5_read_data(IPAP1, TRIM(RECNAM)//"addrTempIntp", ADDTMP) + CALL hdf5_read_data(IPAP1, TRIM(RECNAM)//"isPartOf", ISPAOF) + WRITE(RECNAM,'(10HIsotopeXS/,A,12H/ReactionXS/)') TRIM(HNISOR) + WRITE(RECNA2,'(10HIsotopeXS/,A,19H/Profile/SCATTProf/)') + 1 TRIM(HNISOR) + DO JMX=IMX,NBISO + IF(IPR(1,JMX).EQ.KISEG) THEN + KPLIB=IPISO(JMX) ! set JMX-th isotope + CALL LCMLEN(KPLIB,'ALIAS',ILENG,ITYLCM) + IF(ILENG.EQ.0) THEN + WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3) + CALL LCMPTC(KPLIB,'ALIAS',12,HNAMIS) + IF(IPR(1,JMX).LE.0) CALL XABORT('LIBA30: BAD AWR.') + CALL LCMPUT(KPLIB,'AWR',1,2,AMASS(IPR(1,JMX))) + CALL LCMPTC(KPLIB,'README',80,TEXT80) + ENDIF + IF(NBFLX.GT.0) THEN + IOF=FLXADD(IWFLON+1)+1 + SECT(:NGRO)=WGTFLX(IOF:IOF+NGRO-1) + CALL LCMPUT(KPLIB,'NWT0',NGRO,2,SECT) + ENDIF + LSIGS=.FALSE. + LABSO=.FALSE. + DO I=1,NBREA + IGR0=ENRANG(2*I-1)+1 + NBGR=ENRANG(2*I) + IFGTD=FSTTMP(I) + IF(IFGTD.GE.1) THEN + NTDG=NBGR-IFGTD+1 ! number of temp-dependent groups + NBTMP2=NBTMP + MSHIND=TMPMON(I)+1 + IADD=ITEMPA(MSHIND) + IF(ITEMPA(MSHIND+1)-ITEMPA(MSHIND).NE.NBTMP) THEN + CALL XABORT('LIBA30: INVALID NBTMP.') + ENDIF + ELSE + NTDG=0 + NBTMP2=1 + IADD=0 + ENDIF + NGDG=NBGR-IGR0+1 ! number of groups in energy range + IF(IMPX.GT.2) THEN + WRITE(IOUT,860) TRIM(HREANM(I)),NGDG,NTDG + IF(ISPAOF(I).GE.0) WRITE(IOUT,870) HREANM(ISPAOF(I)+1) + IF(IFGTD.GE.1) WRITE(IOUT,880) TEMPM(IADD+1:IADD+NBTMP) + ENDIF + IND=LEN(TRIM(HREANM(I))) + CALL hdf5_read_data(IPAP1, TRIM(RECNAM)//HREANM(I), XS) + NSECT0=SIZE(XS) + IF(HREANM(I)(IND-3:IND).EQ.'TOTA') THEN + IF(NSECT0.NE.NGDG+(NBTMP2-1)*NTDG) THEN + WRITE(HSMG,'(33HLIBA30: INVALID SIZE FOR ISOTOPE ,A, + 1 14H AND REACTION ,A,7H. SIZE=,I6,11H SHOULD BE=,I6, + 2 7H. NGDF=,I6,6H NTDG=,I6,7H NBTMP=,I6,1H.)') + 3 TRIM(HNISOR),TRIM(HREANM(I)),NSECT0, + 4 NGDG+(NBTMP2-1)*NTDG,NGDG,NTDG,NBTMP2 + WRITE(IOUT,'(/1X,A)') HSMG + GO TO 550 + ENDIF + SECT(:NGRO)=0.0 + IF(IFGTD.GE.1) THEN + CALL LIBA22(NGDG,TN(JMX),NBTMP,NSECT0,IFGTD, + 1 TEMPM(IADD+1),XS(1),SECT(IGR0)) + ELSE + IF(NSECT0.NE.NGDG) CALL XABORT('LIBA30: INVALID NSEC' + 1 //'T0(1).') + SECT(IGR0:IGR0+NGDG-1)=XS(:NSECT0) + ENDIF + IF(HREANM(I).EQ.'ABSO-TOTA') LABSO=.TRUE. + TEXT12=HREANM(I)(:12) + IF(TEXT12.EQ.'MT16-TOTA') TEXT12='N2N' + IF(TEXT12.EQ.'MT17-TOTA') TEXT12='N3N' + IF(TEXT12.EQ.'MT28-TOTA') TEXT12='NNP' + IF(TEXT12.EQ.'MT37-TOTA') TEXT12='N4N' + IF(TEXT12.EQ.'MT102-TOTA') TEXT12='NG' + IF(TEXT12.EQ.'MT103-TOTA') TEXT12='NP' + IF(TEXT12.EQ.'MT104-TOTA') TEXT12='ND' + IF(TEXT12.EQ.'MT105-TOTA') TEXT12='NT' + IF(TEXT12.EQ.'MT107-TOTA') TEXT12='NA' + IF(TEXT12.EQ.'MT108-TOTA') TEXT12='N2A' + IF(TEXT12.EQ.'FISS-TOTA') TEXT12='NFTOT' + IF(TEXT12.EQ.'NUFISS-TOTA') TEXT12='NUSIGF' + IF(TEXT12.EQ.'CHI-TOTA') TEXT12='CHI' + CALL LCMPUT(KPLIB,TEXT12,NGRO,2,SECT) + ELSE IF(HREANM(I)(IND-3:IND).EQ.'JUMP') THEN + IF(ORANIS(I).LE.0) THEN + CALL XABORT('LIBA30: INVALID JUMP ANISOTROPY.') + ELSE IF(NSECT0.NE.(NGDG+(NBTMP2-1)*NTDG)*ORANIS(I)) THEN + CALL XABORT('LIBA30: INVALID JUMP SIZE.') + ENDIF + IF(HREANM(I)(:4).EQ.'SCAT') THEN + SIGS(:NGRO,:NL)=0.0 + DO IL=1,MIN(ORANIS(I),NL) + IOF1=(IL-1)*(NGDG+(NBTMP2-1)*NTDG)+1 + IOF2=IL*(NGDG+(NBTMP2-1)*NTDG) + IF(IFGTD.GE.1) THEN + CALL LIBA22(NGDG,TN(JMX),NBTMP,NSECT0,IFGTD, + 1 TEMPM(IADD+1),XS(IOF1),SIGS(IGR0,IL)) + ELSE + IF(NSECT0.NE.NGDG*ORANIS(I)) CALL XABORT('LIBA30' + 1 //': INVALID NSECT0(2).') + SIGS(IGR0:IGR0+NGDG-1,IL)=XS(IOF1:IOF2) + ENDIF + ENDDO + LSIGS=.TRUE. + IF(.NOT.LABSO) CALL XABORT('LIBA30: NO ABSO-TOTA.') + SECT(:NGRO)=0.0 + CALL LCMGET(KPLIB,'ABSO-TOTA',SECT) + DO IG=1,NGRO + SECT(IG)=SECT(IG)+SIGS(IG,1) + ENDDO + CALL LCMPUT(KPLIB,'NTOT0',NGRO,2,SECT) + CALL LCMLEN(KPLIB,'NXN-TOTA',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGET(KPLIB,'NXN-TOTA',SECT) + DO IG=1,NGRO + SIGS(IG,1)=SIGS(IG,1)+SECT(IG) + ENDDO + ENDIF + ENDIF + ELSE IF(HREANM(I)(IND-3:IND).EQ.'PROF') THEN + IF(HREANM(I)(:4).EQ.'SCAT') THEN + IF(.NOT.LSIGS) CALL XABORT('LIBA30: SIGS NOT SET.') + CALL hdf5_read_data(IPAP1,TRIM(RECNA2)//"AddressFAG", + 1 IAFAG) + IF(SIZE(IAFAG).NE.(NBGR+1)*ORANIS(I)) CALL XABORT('LI' + 1 //'BA30: INVALID AddressFAG SIZE.') + CALL hdf5_read_data(IPAP1,TRIM(RECNA2)//"FstArrGroup", + 1 IFAGR) + NV=0 + DO IL=1,ORANIS(I) + DO IG=1,NGRO ! departure group + NV=NV+(IAFAG((IL-1)*(NGRO+1)+IG+1)-IAFAG((IL-1)* + 1 (NGRO+1)+IG)) + ENDDO + IF(IFGTD.GE.1) THEN + DO IG=IFGTD,NGRO ! departure group + NV=NV+(NBTMP2-1)*(IAFAG((IL-1)*(NGRO+1)+IG+1)- + 1 IAFAG((IL-1)*(NGRO+1)+IG)) + ENDDO + ENDIF + ENDDO + IF(NSECT0.NE.NV) CALL XABORT('LIBA30: INVALID NSECTO(' + 1 //'3).') + ILMIN=MIN(ORANIS(I),NL) + CALL LIBA33(NBGR,ILMIN,TN(JMX),NBTMP,NSECT0,IFGTD, + 1 TEMPM(IADD+1),IAFAG,IFAGR,XS,SCAT) + IF(ITPROB.NE.0) THEN + DO IL=1,ILMIN + DO IG=1,NBGR + SCAT(:NBGR,IG,IL)=SCAT(:NBGR,IG,IL)*SIGS(IG,IL) + ENDDO + ENDDO + ELSE + DO IL=1,ILMIN + DO IG=1,NBGR + DSUM=SUM(SCAT(:NGRO,IG,IL)) + SCAT(:NBGR,IG,IL)=SCAT(:NBGR,IG,IL)*SIGS(IG,IL)/ + 1 REAL(DSUM) + ENDDO + ENDDO + ENDIF + DEALLOCATE(IFAGR,IAFAG) + CALL XDRLGS(KPLIB,1,IMPX,0,ILMIN-1,1,NBGR,SIGS,SCAT, + 1 ITYPRO) + ENDIF + ELSE + CALL XABORT('LIBA30: TOTA/JUMP/PROF SUFFIX EXPECTED.') + ENDIF + 550 DEALLOCATE(XS) + ENDDO + IF(IMPX.GT.1) CALL LCMLIB(KPLIB) + ENDIF + ENDDO + DO JMX=IMX,NBISO + IF(IPR(1,JMX).EQ.KISEG) IPR(1,JMX)=0 + ENDDO + DEALLOCATE(ISPAOF,ADDTMP,TMPMON,HREANM,ENRANG,FSTTMP,ORANIS) + ENDIF + 560 CONTINUE + DEALLOCATE(TEMPM,ITEMPA,AMASS) + CALL KDRCPU(TK2) + TKT(2)=TK2-TK1 +*---- +* PROCESS SELF-SHIELDING DATA. +*---- + L104=.FALSE. + LABSO=.TRUE. + LDIF=.TRUE. + CALL KDRCPU(TK1) + DO 600 IMX=1,NBISO + KISEG=IPR(2,IMX) + IF(KISEG.GT.0) THEN + WRITE(HNISOR,'(3A4)') (ISONRF(I0,IMX),I0=1,3) + IF(IMPX.GT.1) WRITE(IOUT,'(/31H LIBA30: PROCESSING SELF-SHIELD, + 1 12HED ISOTOPE '',A,2H''.)') TRIM(HNISOR) +*---- +* RECOVER INFORMATION FROM Dimensions GROUP +*---- + WRITE(RECNAM,'(9HIsotopes/,A,11H/HomoRates/)') TRIM(HNISOR) + IF(.NOT.hdf5_group_exists(IPAP2,TRIM(RECNAM))) THEN + WRITE(HSMG,'(38HLIBA30: missing HomoRates in group ,A,1H.)') + 1 TRIM(RECNAM) + CALL XABORT(HSMG) + ENDIF + CALL hdf5_read_data(IPAP2, TRIM(RECNAM)//"FirstGrp", IGR0) + CALL hdf5_read_data(IPAP2, TRIM(RECNAM)//"LastGrp", JGR0) + CALL hdf5_read_data(IPAP2, TRIM(RECNAM)//"NbOfGrp", NBGR) + CALL hdf5_read_data(IPAP2, TRIM(RECNAM)//"Temp", TEMP) + CALL hdf5_read_data(IPAP2, TRIM(RECNAM)//"BgXS", BGXS) + CALL hdf5_read_data(IPAP2, TRIM(RECNAM)//"AbsoRate", ABSOXS) + CALL hdf5_read_data(IPAP2, TRIM(RECNAM)//"DiffRate", DIFFXS) + CALL hdf5_info(IPAP2,TRIM(RECNAM)//"FissRate",RANK,TYPE,NBYTE, + 1 DIMSR) + NGF=MIN(NGF,IGR0) + NGFR=MAX(NGFR,JGR0) + LFISS=(TYPE.NE.99) + NBTMP=SIZE(TEMP) + NBDIL=SIZE(BGXS) + IF(IMPX.GT.1) THEN + WRITE(IOUT,910) (BGXS(I),I=1,NBDIL) + WRITE(IOUT,920) (TEMP(I),I=1,NBTMP) + WRITE(IOUT,930) IGR0,JGR0,NBGR,NBDIL,NBTMP + ENDIF + IF(LFISS) THEN + CALL hdf5_read_data(IPAP2, TRIM(RECNAM)//"FissRate",FISSXS) + ELSE + ALLOCATE(FISSXS(NBDIL*NBGR*NBTMP)) + FISSXS(:NBDIL*NBGR*NBTMP)=0.0 + ENDIF + ALLOCATE(TAUX(7*NBGR),DK104(NBDIL*NBGR*NBTMP)) + DK104(:NBDIL*NBGR*NBTMP)=0.0 + DO JMX=IMX,NBISO + IF(IPR(2,JMX).EQ.KISEG) THEN + WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3) + KPLIB=IPISO(JMX) ! set JMX-th isotope + IF(IMPX.GT.3) WRITE(IOUT,'(/17H LIBA30: PROCESS ,A12,1H:)') + 1 HNAMIS + CALL LIBA34(HNAMIS,NGRO,IGR0,NBGR,NBDIL,NBTMP,LFISS,L104, + 1 BGXS,TEMP,TN(JMX),SN(1,JMX),ABSOXS,DIFFXS,FISSXS,DK104, + 2 IMPX,TAUX) +* +* COMPUTE THE SELF-SHIELDED FLUX AND CROSS SECTIONS. + CALL LIBA25(KPLIB,LABSO,LDIF,LFISS,L104,NGRO,IGR0,NBGR, + 1 NBDIL,NL,BGXS,SN(1,JMX),SB(1,JMX),DELTA,ISONAM(1,JMX), + 2 TAUX,IMPX) + ENDIF + ENDDO + DO JMX=IMX,NBISO + IF(IPR(2,JMX).EQ.KISEG) IPR(2,JMX)=0 + ENDDO + DEALLOCATE(TAUX,DK104,FISSXS,DIFFXS,ABSOXS,BGXS,TEMP) + ENDIF + 600 CONTINUE + CALL KDRCPU(TK2) + TKT(3)=TK2-TK1 +*---- +* CHECK IF ALL REACTIONS HAVE BEEN PROCESSED. +*---- + DO 575 IMX=1,NBISO + DO 570 I=1,2 + IF(IPR(I,IMX).NE.0) THEN + WRITE(HSMG,950) I,(ISONAM(I0,IMX),I0=1,3) + CALL XABORT(HSMG) + ENDIF + 570 CONTINUE + 575 CONTINUE + IF(IMPX.GT.2) WRITE(IOUT,940) (TKT(I),I=1,3) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + IF(NBFLX.GT.0) DEALLOCATE(WGTFLX,FLXADD) + DEALLOCATE(DELTA,ENERG) + DEALLOCATE(XSTOT,SCAT,SIGS,SECT) + DEALLOCATE(ITYPRO,IPR) + RETURN +* + 780 FORMAT(26HLIBA30: MATERIAL/ISOTOPE ',A,22H' IS MISSING ON APOLIB, + 1 13H-3 FILE NAME ,A,1H.) + 790 FORMAT(49HLIBA30: SELF-SHIELDING DATA OF MATERIAL/ISOTOPE ',A12, + 1 35H' IS MISSING ON APOLIB-3 FILE NAME ,A,1H.) + 800 FORMAT(/43H LIBA30: PROCESSING APOLIB-3 LIBRARY NAME: ,A,1H.) + 810 FORMAT(/32H LIBA30: X-SECTION LIBRARY INFO:/9X,A80/) + 820 FORMAT(/35H LIBA30: PROBING THE APOLIB-3 FILE./9X,11HNUMBER OF I, + 1 29HSOTOPES AT INFINITE DILUTION=,I8/9X,21HNUMBER OF SELF-SHIELD, + 2 12HED ISOTOPES=,I8) + 830 FORMAT(/30H PROCESSING ISOTOPE/MATERIAL ',A12,11H' (HNISOR=',A12, + 1 3H').) + 860 FORMAT(/9X,5H---- ,A,5H ----/9X,29HNUMBER OF GROUPS IN ENERGY RA, + 1 4HNGE=,I5/10X,32HNUMBER OF TEMP-DEPENDENT GROUPS=,I5) + 870 FORMAT(9X,21HGLOBAL REACTION NAME=,A) + 880 FORMAT(9X,13HTEMPERATURES=,1P,9E12.4/(22X,9E12.4)) + 910 FORMAT(/9X,10HDILUTIONS=,1P,9E12.4/(19X,9E12.4)) + 920 FORMAT(/9X,28HSELF-SHIELDING TEMPERATURES=,1P,7E12.4/(37X,7E12.4)) + 930 FORMAT(/9X,5HIGR0=,I4,6H JGR0=,I4,6H NBGR=,I4,7H NBDIL=,I4, + 1 7H NBTMP=,I4) + 940 FORMAT(/26H LIBA30: CPU TIME USAGE --,F10.2,9H INDEXING/26X, + 1 F10.2,24H INFINITE DILUTION P0 XS/26X,F10.2,16H DILUTION-DEPEND, + 2 11HENT XS DATA) + 950 FORMAT(26HLIBA30: REMAINING REACTION,I3,14H FOR ISOTOPE ',3A4, + 1 2H'.) + END diff --git a/Dragon/src/LIBA33.f b/Dragon/src/LIBA33.f new file mode 100644 index 0000000..073487f --- /dev/null +++ b/Dragon/src/LIBA33.f @@ -0,0 +1,151 @@ +*DECK LIBA33 + SUBROUTINE LIBA33(NG,NANI,TT,NT0,NPSN0,FGTD,TEMP,IAFAG,IFAGR, + 1 PSN0,SCAT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly and temperature interpolation of a transfer matrix stored +* in the APOLIB-3 format. +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NG number of energy groups. +* NANI anisotropy level. NANI=1 for isotropic scattering. +* TT temperature of isotope. +* NT0 number of tabulated temperatures. +* NPSN0 size of vector PSN0. +* FGTD first temperature-dependent group. +* TEMP tabulated temperatures. +* IAFAG address for the first arrival group XS +* IFAGR first arrival group index. +* PSN0 input cross section data in APOLIB-3 compressed format. +* +*Parameters: output +* SCAT interpolated transfer matrix (JG<-IG,ITEMP,IL). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NG,NANI,NT0,NPSN0,FGTD,IAFAG(NG+1,NANI),IFAGR(NG,NANI) + REAL TT,TEMP(NT0),PSN0(NPSN0),SCAT(NG,NG,NANI) +*---- +* LOCAL VARIABLES +*---- + CHARACTER HSMG*131 + PARAMETER (NINT=2,DTMIN=1.0) + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DTEMP,WEIJHT,S + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:) :: DSCATT +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(DTEMP(NT0),WEIJHT(NT0),DSCATT(NG,NG,NT0,NANI),S(NG)) +* + IF(NT0.EQ.1) THEN + IPROX=1 + IGTFIX=1 + ELSE + DO I=1,NT0 + DTEMP(I)=TEMP(I) + ENDDO + CALL LIBA28(TT,DTEMP,NT0,NINT,WEIJHT,IORD,IPROX,I0) + IF(ABS(TT-TEMP(IPROX)).LE.DTMIN) THEN + IGTFIX=1 + ELSE IF((TT.LT.TEMP(1)).OR.(TT.GT.TEMP(NT0))) THEN + WRITE(HSMG,'(A,F8.2,A,F8.2,A,F8.2)') + 1 'LIBA33: A TEMPERATURE', TT,'K IS NOT INCLUDED BETWEEN ', + 2 TEMP(1),' AND ',TEMP(NT0) + WRITE(6,'(/1X,A)') HSMG + IGTFIX=2 + ELSE + IGTFIX=0 + ENDIF + ENDIF +*---- +* SCATTERING MATRIX RECONSTRUCTION +*---- + DSCATT(:NG,:NG,:NT0,:NANI)=0.D0 + NV=0 + DO IL=1,NANI + DO IG=1,NG ! departure group + JG1=IFAGR(IG,IL)+1 + ISIZE=IAFAG(IG+1,IL)-IAFAG(IG,IL) + JG2=JG1+ISIZE-1 + IF(JG2.GT.NG) CALL XABORT('LIBA33: NG OVERFLOW(1)') + IF(NV+ISIZE.GT.NPSN0) CALL XABORT('LIBA33: NPSN0 OVERFLOW(1)') + DSCATT(JG1:JG2,IG,1,IL)=PSN0(NV+1:NV+ISIZE)/REAL(2*IL-1) + NV=NV+ISIZE + ENDDO + IF(FGTD.GE.1) THEN + DO IT=2,NT0 + DO IG=1,FGTD-1 ! departure group + DSCATT(:NG,IG,IT,IL)=DSCATT(:NG,IG,1,IL) + ENDDO + DO IG=FGTD,NG ! departure group + JG1=IFAGR(IG,IL)+1 + ISIZE=IAFAG(IG+1,IL)-IAFAG(IG,IL) + JG2=JG1+ISIZE-1 + IF(JG2.GT.NG) CALL XABORT('LIBA33: NG OVERFLOW(2)') + IF(NV+ISIZE.GT.NPSN0) CALL XABORT('LIBA33: NPSN0 OVERFLO' + 1 //'W(2)') + DSCATT(JG1:JG2,IG,IT,IL)=PSN0(NV+1:NV+ISIZE)/REAL(2*IL-1) + NV=NV+ISIZE + ENDDO + ENDDO + ENDIF + ENDDO +*---- +* TEMPERATURE INTERPOLATION +*---- + SCAT(:NG,:NG,:NANI)=0.0 + IF(FGTD.GE.1) THEN + DO IL=1,NANI + SCAT(:NG,:FGTD-1,IL)=REAL(DSCATT(:NG,:FGTD-1,1,IL)) + ENDDO + ELSE + DO IL=1,NANI + SCAT(:NG,:NG,IL)=REAL(DSCATT(:NG,:NG,1,IL)) + ENDDO + RETURN + ENDIF + IDIS=NG+1-FGTD + DO IL=1,NANI + IF(IGTFIX.EQ.1) THEN + DO I=1,IDIS + SCAT(:NG,FGTD+I-1,IL)=REAL(DSCATT(:NG,FGTD+I-1,IPROX,IL)) + ENDDO + ELSE + DO IG=FGTD,NG ! departure group + S(:NG)=0.D0 + DO J=1,IORD ! temperature weighting + S(:NG)=S(:NG)+WEIJHT(J)*DSCATT(:NG,IG,I0+J,IL) + ENDDO + IF(IGTFIX.EQ.2) THEN + DO JG=1,NG ! arrival group + IF(DSCATT(JG,IG,IPROX,IL).GE.0.) THEN + S(JG)=MAX(0.D0,S(JG)) + ELSE + S(JG)=MIN(S(JG),0.D0) + ENDIF + ENDDO + ENDIF + SCAT(:NG,IG,IL)=REAL(S(:NG)) + ENDDO + ENDIF + ENDDO +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(S,DSCATT,WEIJHT,DTEMP) + RETURN + END diff --git a/Dragon/src/LIBA34.f b/Dragon/src/LIBA34.f new file mode 100644 index 0000000..56c35ac --- /dev/null +++ b/Dragon/src/LIBA34.f @@ -0,0 +1,423 @@ +*DECK LIBA34 + SUBROUTINE LIBA34(HNAMIS,NGRO,FGHOMO,NGHOMO,NSEQHO,NTEMPS,LFIS, + 1 L104,SEQHOM,TEMPS,TN,SN,ABSOHE,DIFFHE,FISSHE,FLUXHE,IMPX,TAUX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Temperature and dilution interpolation of self-shielded effective +* rates in the APOLIB-3 format. +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* HNAMIS name of the isotope. +* NGRO number of energy groups. +* FGHOMO first self-shielded energy group. +* NGHOMO number of self-shielded energy groups. +* NSEQHO number of tabulated dilutions. +* NTEMPS number of tabulated temperatures. +* LFIS fission reaction flag (=.true. if the fission reaction is +* self-shielded). +* L104 resonance flux flag (=.true. if the apolib contains dilution +* /temperature-dependent flux information). If this information +* is not provided, it will be reconstructed from a balance +* relation. +* SEQHOM tabulated dilutions. +* TEMPS tabulated temperatures. +* TN temperature of isotope. +* SN dilution of isotope. +* ABSOHE tabulated absorption effective reaction rates. +* DIFFHE tabulated diffusion effective reaction rates. +* FISSHE tabulated nu*fission effective reaction rates +* (if LFIS=.true.). +* FLUXHE tabulated self-shielded fluxes (if L104=.true.). +* IMPX print flag. +* +*Parameters: output +* TAUX interpolated effective rates: +* TAUX(I,1) absorption effective rates; +* TAUX(I,2) diffusion effective rates; +* TAUX(I,3) nu*fission effective rates; +* TAUX(I,4) pseudo-absorption effective rates used to +* reconstruct the self-shielded flux; +* TAUX(I,5) infinite-dilution absorption x-s; +* TAUX(I,6) infinite-dilution diffusion x-s; +* TAUX(I,7) infinite-dilution fission x-s. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER HNAMIS*12 + INTEGER NGRO,FGHOMO,NSEQHO,NGHOMO,NTEMPS,IMPX + LOGICAL LFIS,L104 + REAL SEQHOM(NSEQHO),TEMPS(NTEMPS),TN,SN(NGRO), + 1 ABSOHE(NSEQHO,NGHOMO,NTEMPS),DIFFHE(NSEQHO,NGHOMO,NTEMPS), + 2 FISSHE(NSEQHO,NGHOMO,NTEMPS),FLUXHE(NSEQHO,NGHOMO,NTEMPS), + 3 TAUX(NGHOMO,7) +*---- +* LOCAL VARIABLES +*---- + CHARACTER HSMG*131,TEXTE*80 + PARAMETER (NINT=2,NINTSS=3,DTMIN=1.0) + LOGICAL LGONE + DOUBLE PRECISION S1,S2,S3,S4,SUMA,SUMS,SUMF,SUM104,REL,RNTERP + REAL, ALLOCATABLE, DIMENSION(:,:) :: ABSOH,DIFFH,FISSH,FLUXH + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SQRTEM,SEQ2,WEIJHT, + 1 WEIGH +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(WEIJHT(NTEMPS),SQRTEM(NTEMPS),ABSOH(NSEQHO,NGHOMO), + 1 DIFFH(NSEQHO,NGHOMO),FISSH(NSEQHO,NGHOMO), + 2 FLUXH(NSEQHO,NGHOMO)) + WEIJHT(:NTEMPS)=0.0D0 +*---- +* SQUARE ROOT OF TEMPERATURE INTERPOLATION. +* +* IGTFIX=1 IF ONLY ONE TABULATED TEMPERATURE OR IF STT IS ONE OF THE +* TABULATED TEMPERATURES. IGTFIX=2 IF STT IS OUTSIDE THE TABULATED +* RANGE. IGTFIX=0 OTHERWISE. +* +*---- + DO 10 I=1,NTEMPS + SQRTEM(I)=SQRT(TEMPS(I)) + 10 CONTINUE + IF(NTEMPS.EQ.1) THEN + IGTFIX=1 + IPROX=1 + ELSE + STT=SQRT(TN) + CALL LIBA28(STT,SQRTEM,NTEMPS,NINT,WEIJHT,IORD,IPROX,I0) + IF(ABS(TN-TEMPS(IPROX)).LE.DTMIN) THEN + IGTFIX=1 + ELSEIF((STT.LT.SQRTEM(1)).OR.(STT.GT.SQRTEM(NTEMPS))) THEN + WRITE(HSMG,'(A,F8.2,A,F8.2,A,F8.2,2A)') + 1 'LIBA34: A TEMPERATURE', TN,'K IS NOT INCLUDED BETWEEN ', + 2 TEMPS(1),' AND ',TEMPS(NTEMPS),' ISOTOPE:',HNAMIS + WRITE(6,'(/1X,A)') HSMG + IGTFIX=2 + ELSE + IGTFIX=0 + ENDIF + ENDIF +* + IF(IGTFIX .EQ. 1) THEN + DO 25 I=1,NGHOMO + DO 20 J=1,NSEQHO + ABSOH(J,I)=ABSOHE(J,I,IPROX) + DIFFH(J,I)=DIFFHE(J,I,IPROX) + IF(LFIS) FISSH(J,I)=FISSHE(J,I,IPROX) + IF(L104) FLUXH(J,I)=FLUXHE(J,I,IPROX) + 20 CONTINUE + 25 CONTINUE + ELSE + DO 45 J=1,NSEQHO + DO 40 I=1,NGHOMO + S1=0.D0 + S2=0.D0 + S3=0.D0 + S4=0.D0 + DO 30 K=1,IORD + S1=S1+WEIJHT(K)*ABSOHE(J,I,I0+K) + S2=S2+WEIJHT(K)*DIFFHE(J,I,I0+K) + IF(LFIS)S3=S3+WEIJHT(K)*FISSHE(J,I,I0+K) + IF(L104)S4=S4+WEIJHT(K)*FLUXHE(J,I,I0+K) + 30 CONTINUE + IF(IGTFIX.EQ.2) THEN + IF(ABSOHE(J,I,IPROX).GE.0.) THEN + S1=MAX(0.D0,S1) + ELSE + S1=MIN(S1,0.D0) + ENDIF + IF(DIFFHE(J,I,IPROX).GE.0.) THEN + S2=MAX(0.D0,S2) + ELSE + S2=MIN(S2,0.D0) + ENDIF + ENDIF + ABSOH(J,I)=REAL(S1) + DIFFH(J,I)=REAL(S2) + IF(LFIS) THEN + IF(IGTFIX .EQ. 2) THEN + IF(FISSHE(J,I,IPROX).GE.0.) THEN + S3=MAX(0.D0,S3) + ELSE + S3=MIN(S3,0.D0) + ENDIF + ENDIF + FISSH(J,I)=REAL(S3) + ENDIF + IF(L104) THEN + IF(IGTFIX .EQ. 2) THEN + IF(FLUXHE(J,I,IPROX).GE.0.) THEN + S4=MAX(0.D0,S4) + ELSE + S4=MIN(S4,0.D0) + ENDIF + ENDIF + FLUXH(J,I)=REAL(S4) + ENDIF + 40 CONTINUE + 45 CONTINUE + ENDIF +*---- +* SET INFINITE DILUTION VALUES. +*---- + DO 50 I=1,NGHOMO + TAUX(I,5)=ABSOH(NSEQHO,I) + TAUX(I,6)=DIFFH(NSEQHO,I) + IF(LFIS) TAUX(I,7)=FISSH(NSEQHO,I) + 50 CONTINUE +*---- +* DILUTION INTERPOLATION. +*---- + LGONE=NSEQHO.EQ.1 + NSEQH1=0 + SEQHO1=0.0 + SEQHO0=0.0 + IF(.NOT.LGONE)THEN + NSEQH1=NSEQHO-1 + SEQHO1=SEQHOM(NSEQH1) + SEQHO0=SEQHOM(NSEQHO) + ENDIF + DO 110 IGG=FGHOMO,FGHOMO+NGHOMO-1 + IGSSC=IGG+1-FGHOMO + BACK=SN(IGG) + IF(LGONE) THEN +*---- +* UNIQUE TABULATED TEMPERATURE. +*---- + TAUX(IGSSC,1)=ABSOH(NSEQHO,IGSSC) + TAUX(IGSSC,2)=DIFFH(NSEQHO,IGSSC) + IF(LFIS) TAUX(IGSSC,3)=FISSH(NSEQHO,IGSSC) + IF(L104) TAUX(IGSSC,4)=FLUXH(NSEQHO,IGSSC) + GOTO 110 + ENDIF +*---- +* MANY TABULATED TEMPERATURES. +*---- + IF(BACK.GE.SEQHO1)THEN +* +* ASYMPTOTIC BEHAVIOR: REACTION RATES VARY LINEARLY WITH +* 1/SEQHOM FOR THE LAST 2 POINTS OF THE TABULATION +* + IF(BACK.GT.SEQHO0) BACK=SEQHO0 + AUX=1.0/(BACK*(SEQHO0-SEQHO1)) + AUX1=SEQHO1*(SEQHO0-BACK)*AUX + AUX2=SEQHO0*(SEQHO1-BACK)*AUX + TAUX(IGSSC,1)=ABSOH(NSEQH1,IGSSC)*AUX1 + 1 -ABSOH(NSEQHO,IGSSC)*AUX2 + TAUX(IGSSC,2)=DIFFH(NSEQH1,IGSSC)*AUX1 + 1 -DIFFH(NSEQHO,IGSSC)*AUX2 + IF(LFIS) TAUX(IGSSC,3)=FISSH(NSEQH1,IGSSC)*AUX1 + 1 -FISSH(NSEQHO,IGSSC)*AUX2 + IF(L104) TAUX(IGSSC,4)=FLUXH(NSEQH1,IGSSC)*AUX1 + 1 -FLUXH(NSEQHO,IGSSC)*AUX2 + ELSE +* +* REACTION RATES VARY WITH THE SQRT OF THE BACKGROUND XSECT +* + BACKH2=SQRT(BACK) + ALLOCATE(SEQ2(NSEQHO),WEIGH(NINTSS)) + DO 60 I=1,NSEQHO + SEQ2(I)=SQRT(SEQHOM(I)) + 60 CONTINUE + CALL LIBA28(BACKH2,SEQ2,NSEQHO,NINTSS,WEIGH,IORD,IPR,I0) + DO 70 ISEQHO=1,NSEQHO + IF(ABS(BACK-SEQHOM(ISEQHO)).LE.1.E-2) THEN + TAUX(IGSSC,1)=ABSOH(ISEQHO,IGSSC) + TAUX(IGSSC,2)=DIFFH(ISEQHO,IGSSC) + IF(LFIS) TAUX(IGSSC,3)=FISSH(ISEQHO,IGSSC) + IF(L104) TAUX(IGSSC,4)=FLUXH(ISEQHO,IGSSC) + DEALLOCATE(WEIGH,SEQ2) + GOTO 110 + ENDIF + 70 CONTINUE + SUMA=0.D0 + SUMS=0.D0 + SUMF=0.D0 + SUM104=0.D0 + DO 80 I=1,IORD + I1=I+I0 + SUMA=SUMA+WEIGH(I)*ABSOH(I1,IGSSC) + SUMS=SUMS+WEIGH(I)*DIFFH(I1,IGSSC) + IF(LFIS) SUMF=SUMF+WEIGH(I)*FISSH(I1,IGSSC) + IF(L104) SUM104=SUM104+WEIGH(I)*FLUXH(I1,IGSSC) + 80 CONTINUE + DO 90 I=1,IORD + I1=I+I0 + IF(SEQHOM(I1).GT.BACK) THEN + IF(I1-1.GT.0) THEN +* +* ABSORPTION RATE CRITERION. +* + YMIN=MIN(ABSOH(I1-1,IGSSC),ABSOH(I1,IGSSC)) + YMAX=MAX(ABSOH(I1-1,IGSSC),ABSOH(I1,IGSSC)) + IF((SUMA.GT.YMAX) .OR. (SUMA.LT.YMIN)) THEN + RNTERP=SUMA + SUMA=ABSOH(I1-1,IGSSC)+ + 1 (ABSOH(I1,IGSSC)-ABSOH(I1-1,IGSSC))* + 1 (BACKH2-SEQ2(I1-1))/(SEQ2(I1)-SEQ2(I1-1)) + REL = (RNTERP-SUMA)/SUMA + IF(REL.GE.0.1 .OR. IMPX .GT. 3) THEN + WRITE(TEXTE,10000) + 1 'ABS. G=',IGG,' DIL=',BACK, + 1 ' INT. LIN. --> ERR. RELA.=',REL + WRITE(6,'(/1X,A)') TEXTE + ENDIF + ENDIF +* +* SCATTERING RATE CRITERION. +* + YMIN = MIN(DIFFH(I1-1,IGSSC),DIFFH(I1,IGSSC)) + YMAX = MAX(DIFFH(I1-1,IGSSC),DIFFH(I1,IGSSC)) + IF((SUMS.GT.YMAX) .OR. (SUMS.LT.YMIN)) THEN + RNTERP=SUMS + SUMS=DIFFH(I1-1,IGSSC)+ + 1 (DIFFH(I1,IGSSC)-DIFFH(I1-1,IGSSC))* + 1 (BACKH2-SEQ2(I1-1))/(SEQ2(I1)-SEQ2(I1-1)) + REL = (RNTERP-SUMS)/SUMS + IF(REL.GE. 0.1 .OR. IMPX .GT. 3) THEN + WRITE(TEXTE,10000) + 1 'DIF. G=',IGG,' DIL=',BACK, + 1 ' INT. LIN. --> ERR. RELA.=',REL + WRITE(6,'(/1X,A)') TEXTE + ENDIF + ENDIF +* +* PRODUCTION RATE CRITERION. +* + IF(LFIS) THEN + YMIN = MIN(FISSH(I1-1,IGSSC),FISSH(I1,IGSSC)) + YMAX = MAX(FISSH(I1-1,IGSSC),FISSH(I1,IGSSC)) + IF((SUMF.GT.YMAX) .OR. (SUMF.LT.YMIN)) THEN + RNTERP=SUMF + SUMF=FISSH(I1-1,IGSSC)+ + 1 (FISSH(I1,IGSSC)-FISSH(I1-1,IGSSC))* + 1 (BACKH2-SEQ2(I1-1))/(SEQ2(I1)-SEQ2(I1-1)) + REL = (RNTERP-SUMF)/SUMF + IF(REL.GE.0.1 .OR. IMPX .GT. 3) THEN + WRITE(TEXTE,10000) + 1 'FIS. G=',IGG,' DIL=',BACK, + 1 ' INT. LIN. --> ERR. RELA.=',REL + WRITE(6,'(/1X,A)') TEXTE + ENDIF + ENDIF + ENDIF +* +* TEST FLUX 104 +* + IF(L104) THEN + YMIN = MIN(FLUXH(I1-1,IGSSC),FLUXH(I1,IGSSC)) + YMAX = MAX(FLUXH(I1-1,IGSSC),FLUXH(I1,IGSSC)) + IF((SUM104.GT.YMAX) .OR. (SUM104.LT.YMIN)) THEN + RNTERP=SUM104 + SUM104=FLUXH(I1-1,IGSSC)+ + 1 (FLUXH(I1,IGSSC)-FLUXH(I1-1,IGSSC))* + 1 (BACKH2-SEQ2(I1-1))/(SEQ2(I1)-SEQ2(I1-1)) + REL = (RNTERP-SUM104)/SUM104 + IF(REL.GE.0.1 .OR. IMPX .GT. 3) THEN + WRITE(TEXTE,10000) + 1 'FIS. G=',IGG,' DIL=',BACK, + 1 ' INT. LIN. --> ERR. RELA.=',REL + WRITE(6,'(/1X,A)') TEXTE + ENDIF + ENDIF + ENDIF +* + ELSE + SUMA=ABSOH(1,IGSSC)+ + 1 (ABSOH(2,IGSSC)-ABSOH(1,IGSSC))* + 1 (BACKH2-SEQ2(1))/(SEQ2(2)-SEQ2(1)) + IF(SUMA.LE.0.) THEN + SUMA=ABSOH(1,IGSSC) + WRITE(TEXTE,3000) + 1 ' DIL. : ',BACK, ' TROP PETITE ', + 2 'TAUX ABS. NON EXTRAPOLES GR. ',IGG + WRITE(6,'(/1X,A)') TEXTE + ENDIF +* + SUMS=DIFFH(1,IGSSC)+ + 1 (DIFFH(2,IGSSC)-DIFFH(1,IGSSC))* + 1 (BACKH2-SEQ2(1))/(SEQ2(2)-SEQ2(1)) + IF(SUMS.LE.0.) THEN + SUMS=DIFFH(1,IGSSC) + WRITE(TEXTE,3000) + 1 ' DIL. : ',BACK, ' TROP PETITE ', + 2 'TAUX DIFF. NON EXTRAPOLES GR. ',IGG + WRITE(6,'(/1X,A)') TEXTE + ENDIF +* + IF(LFIS) SUMF=FISSH(1,IGSSC)+ + 1 (FISSH(2,IGSSC)-FISSH(1,IGSSC))* + 1 (BACKH2-SEQ2(1))/(SEQ2(2)-SEQ2(1)) + IF(LFIS.AND.SUMF.LE.0.) THEN + SUMF=FISSH(1,IGSSC) + WRITE(TEXTE,3000) + 1 ' DIL. : ',BACK, ' TROP PETITE ', + 2 'TAUX PROD. NON EXTRAPOLES GR. ',IGG + WRITE(6,'(/1X,A)') TEXTE + ENDIF +* + IF(L104) SUM104=FLUXH(1,IGSSC)+ + 1 (FLUXH(2,IGSSC)-FLUXH(1,IGSSC))* + 1 (BACKH2-SEQ2(1))/(SEQ2(2)-SEQ2(1)) + IF(L104.AND.SUM104.LE.0.) THEN + SUM104=FLUXH(1,IGSSC) + WRITE(TEXTE,3000) + 1 ' DIL. : ',BACK, ' TROP PETITE ', + 2 'FLUX 104 NON EXTRAPOLES GR. ',IGG + WRITE(6,'(/1X,A)') TEXTE + ENDIF + ENDIF + GOTO 100 + ENDIF + 90 CONTINUE +* + 100 TAUX(IGSSC,1)=REAL(SUMA) + TAUX(IGSSC,2)=REAL(SUMS) + IF(LFIS) TAUX(IGSSC,3)=REAL(SUMF) + IF(L104) TAUX(IGSSC,4)=REAL(SUM104) + IF(SUMA.LE.0.) THEN + WRITE(TEXTE,1000) + 1 HNAMIS,'GROUPE ',IGG,' DIL. ',BACK,' ABS. <= 0.' + CALL XABORT('LIBA34:'//TEXTE) + ENDIF + IF(SUMS.LE.0.) THEN + WRITE(TEXTE,1000) + 1 HNAMIS,'GROUPE ',IGG,' DIL. ',BACK,' DIF. <= 0.' + CALL XABORT('LIBA34:'//TEXTE) + ENDIF + IF(LFIS .AND. SUMF.LE.0.) THEN + WRITE(TEXTE,1000) + 1 HNAMIS,'GROUPE ',IGG,' DIL. ',BACK,' FIS. <= 0.' + CALL XABORT('LIBA34:'//TEXTE) + ENDIF + IF(L104 .AND. (1.-SUM104/BACK).LE.0.) THEN + WRITE(TEXTE,1000) + 1 HNAMIS,'GROUPE ',IGG,' DIL. ',BACK,' FLU. <= 0.' + CALL XABORT('LIBA34:'//TEXTE) + ENDIF + DEALLOCATE(WEIGH,SEQ2) + ENDIF + 110 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(FLUXH,FISSH,DIFFH,ABSOH,SQRTEM,WEIJHT) + RETURN +* +1000 FORMAT(9H ISOTOPE:,A12,2X,A,I3,A,E13.5,A) +3000 FORMAT(A,E13.5,A,A,I3) +10000 FORMAT(A,I3,A,1P,E13.5,A,E13.5) + END diff --git a/Dragon/src/LIBADD.f b/Dragon/src/LIBADD.f new file mode 100644 index 0000000..b7262c5 --- /dev/null +++ b/Dragon/src/LIBADD.f @@ -0,0 +1,181 @@ +*DECK LIBADD + SUBROUTINE LIBADD (IPLIB,NBISO,MASKI,IMPX,NGRO,NL,ITRANC,ISONAM, + 1 IPISO,NIR,GIR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Add transport correction and Goldstein-Cohen data to a /microlib/ +* directory. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* NBISO number of isotopes present in the calculation domain. +* MASKI isotopic mask. Isotope with index I is processed if +* MASKI(I)=.true. +* IMPX print flag. +* NGRO number of energy groups. +* NL number of Legendre orders required in the calculation +* NL=1 (for isotropic scattering) or higher. +* ITRANC transport correction option (=0: no correction; =1: Apollo- +* type; =2: recover TRANC record; =3: Wims-type; =4: leakage +* correction alone). +* ISONAM alias name of each isotope. +* IPISO pointer array towards microlib isotopes. +* NIR group index with an imposed IR slowing-down model (=0 for no +* IR model). +* GIR value of the imposed Goldstein-Cohen parameter for groups +* with an IR model. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB,IPISO(NBISO) + INTEGER NBISO,IMPX,NGRO,NL,ITRANC,ISONAM(3,NBISO),NIR(NBISO) + LOGICAL MASKI(NBISO) + REAL GIR(NBISO) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IOUT=6) + TYPE(C_PTR) JPLIB,KPLIB + CHARACTER TEXT12*12,HSMG*131 +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: WORK,WR2,DELTA + REAL, ALLOCATABLE, DIMENSION(:,:) :: SCAT +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(WORK(NGRO),WR2(NGRO),SCAT(NGRO,NGRO),DELTA(NGRO+1)) +*---- +* RECOVER THE ENERGY GRID. +*---- + CALL LCMLEN(IPLIB,'ENERGY',LENGT,ITYLCM) + IF(LENGT.EQ.0) CALL XABORT('LIBADD: NO GROUP STRUCTURE AVAILABLE') + CALL LCMGET(IPLIB,'ENERGY',DELTA) + NGX=0 + DO 10 IGR=1,NGRO + IF((NGX.EQ.0).AND.(DELTA(IGR+1).LT.4.0)) NGX=IGR-1 + 10 CONTINUE + DO 15 IGR=1,NGRO + DELTA(IGR)=LOG(DELTA(IGR)/DELTA(IGR+1)) + 15 CONTINUE +* + DO 110 ISO=1,NBISO + IF(MASKI(ISO)) THEN + WRITE(TEXT12,'(3A4)') ISONAM(1,ISO),ISONAM(2,ISO),ISONAM(3,ISO) + KPLIB=IPISO(ISO) ! set ISO-th isotope + IF(.NOT.C_ASSOCIATED(KPLIB)) GO TO 110 + CALL LCMLEN(KPLIB,'NTOT0',ILENG,ITYLCM) + IF(ILENG.EQ.0) THEN + JPLIB=LCMGID(IPLIB,'ISOTOPESLIST') + CALL LCMLIB(JPLIB) + WRITE(HSMG,'(17H LIBADD: ISOTOPE ,A12,6H (ISO=,I6, + 1 17H) IS NOT DEFINED.)') TEXT12,ISO + CALL XABORT(HSMG) + ENDIF +* +* REDIFINE THE GOLDSTEIN-COHEN PARAMETERS. + IF(NIR(ISO).GT.0) THEN + DO 20 IGR=1,MIN(NGRO,NIR(ISO)-1) + WORK(IGR)=1.0 + 20 CONTINUE + DO 30 IGR=NIR(ISO),NGRO + WORK(IGR)=GIR(ISO) + 30 CONTINUE + CALL LCMPUT(KPLIB,'NGOLD',NGRO,2,WORK) + IF(IMPX.GT.1) THEN + IF(GIR(ISO).EQ.-998.0) THEN + WRITE(IOUT,210) TEXT12,'PT',NIR(ISO) + ELSE IF(GIR(ISO).EQ.-999.0) THEN + WRITE(IOUT,210) TEXT12,'PTSL',NIR(ISO) + ELSE IF(GIR(ISO).EQ.-1000.0) THEN + WRITE(IOUT,210) TEXT12,'PTMC',NIR(ISO) + ELSE + WRITE(IOUT,200) TEXT12,GIR(ISO),NIR(ISO) + ENDIF + ENDIF + ENDIF +* +* COMPUTE OR RECOVER THE TRANSPORT CORRECTION. + IF(ITRANC.EQ.2) THEN +* RECOVER THE TRANSPORT CORRECTION FROM THE LIBRARY. + CALL LCMLEN(KPLIB,'TRANC',ILENG,ITYLCM) + IF(ILENG.EQ.0) THEN + WORK(:NGRO)=0.0 + CALL LCMPUT(KPLIB,'TRANC',NGRO,2,WORK) + ENDIF + ELSE IF(ITRANC.NE.0) THEN + WORK(:NGRO)=0.0 + CALL LCMLEN(KPLIB,'NTOT1',ILENG,ITYLCM) + IF(ILENG.NE.0) THEN +* LEAKAGE CORRECTION. + CALL LCMGET(KPLIB,'NTOT1',WORK) + CALL LCMGET(KPLIB,'NTOT0',WR2) + DO 40 IG1=1,NGRO + WORK(IG1)=WR2(IG1)-WORK(IG1) + 40 CONTINUE + ENDIF + IF((NL.GE.2).AND.(ITRANC.NE.4)) THEN + CALL LCMLEN(KPLIB,'SCAT-SAVED',ILENG,ITYLCM) + IF(ILENG.EQ.0) THEN + WRITE(HSMG,'(37H LIBADD: NO SCAT-SAVED RECORD FOR ISO, + 1 5HTOPE ,A12,1H.)') TEXT12 + CALL XABORT(HSMG) + ENDIF + CALL XDRLGS(KPLIB,-1,0,1,1,1,NGRO,WR2,SCAT,ITY) + IF(ITRANC.EQ.1) THEN +* APOLLO-TYPE TRANSPORT CORRECTION. USE THE MICRO- +* REVERSIBILITY PRINCIPLE AT ALL ENERGIES. + DO 50 IG1=1,NGRO + WORK(IG1)=WORK(IG1)+WR2(IG1) + 50 CONTINUE + ELSE IF(ITRANC.EQ.3) THEN +* WIMS-TYPE TRANSPORT CORRECTION. USE THE MICRO- +* REVERSIBILITY PRINCIPLE BELOW 4 EV AND A 1/E SPECTRUM +* ABOVE. + DO 65 IG1=1,MIN(NGRO,NGX) + DO 60 IG2=1,NGRO + WORK(IG1)=WORK(IG1)+SCAT(IG1,IG2)*DELTA(IG2)/DELTA(IG1) + 60 CONTINUE + 65 CONTINUE + DO 70 IG1=NGX+1,NGRO + WORK(IG1)=WORK(IG1)+WR2(IG1) + 70 CONTINUE + ELSE + CALL XABORT('LIBADD: UNKNOWN TYPE OF CORRECTION.') + ENDIF + ENDIF +* ***CAUTION*** 'TRANC' CONTAINS BOTH TRANSPORT AND LEAKAGE +* CORRECTIONS. + CALL LCMPUT(KPLIB,'TRANC',NGRO,2,WORK) + ENDIF + ENDIF + 110 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(DELTA,SCAT,WR2,WORK) + RETURN +* + 200 FORMAT(/51H LIBADD: THE GOLDSTEIN-COHEN PARAMETER OF ISOTOPE ', + 1 A12,12H' WAS SET TO,F5.2,33H FOR GROUPS WITH INDEX GREATER OR, + 2 9H EQUAL TO,I4,1H.) + 210 FORMAT(/18H LIBADD: ISOTOPE ',A12,20H' IS PROCESSED WITH ,A, + 1 48H METHOD IN GROUPS WITH INDEX GREATER OR EQUAL TO,I4,1H.) + END diff --git a/Dragon/src/LIBADJ.f b/Dragon/src/LIBADJ.f new file mode 100644 index 0000000..0f90281 --- /dev/null +++ b/Dragon/src/LIBADJ.f @@ -0,0 +1,161 @@ +*DECK LIBADJ + SUBROUTINE LIBADJ (IPLIB,NGRO,NBISO,NL,NDEL,NBESP,IPISO,NED, + 1 NAMEAD) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transposition of the usefull interpolated microscopic cross section +* for producing an adjoint problem. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* NGRO number of energy groups. +* NBISO number of isotopes present in the calculation domain. +* NL number of Legendre orders required in the calculation +* NL=1 or higher. +* NDEL number of delayed precursor groups. +* NBESP number of energy-dependent fission spectra. +* IPISO pointer array towards microlib isotopes. +* NED number of extra vector edits from matxs. +* NAMEAD matxs names of the extra vector edits. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB,IPISO(NBISO) + INTEGER NGRO,NBISO,NL,NDEL,NBESP,NED,NAMEAD(2,NED) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPLIB + INTEGER I,J,I0,IED,IDEL,IL,IMPX,IMT,INGRO,LENGT,ITYLCM + REAL SUM + CHARACTER TEXT8*8,HNUSIG*12,HCHI*12 + INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPRO + REAL, ALLOCATABLE, DIMENSION(:,:) :: GA1,GA2,SIGS + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(ITYPRO(NL),GA1(NGRO,2),GA2(NGRO,NGRO),SIGS(NGRO,NL), + 1 SCAT(NGRO,NGRO,NL)) +*---- +* ***MATERIAL/ISOTOPE LOOP*** +*---- + IF(NBESP.NE.0) CALL XABORT('LIBADJ: MULTIPLE FISSION SPECTRA NOT' + 1 //' IMPLEMENTED.') + IMPX=0 + DO 200 IMT=1,NBISO + JPLIB=IPISO(IMT) + IF(.NOT.C_ASSOCIATED(JPLIB)) GO TO 200 + CALL XDRLGS(JPLIB,-1,IMPX,0,NL-1,1,NGRO,SIGS,SCAT,ITYPRO) + INGRO=NL-1 + DO 10 IL=NL-1,0,-1 + IF(ITYPRO(IL+1).EQ.0) THEN + INGRO=INGRO-1 + ELSE + GO TO 20 + ENDIF + 10 CONTINUE + 20 DO 50 IL=0,INGRO + IF(ITYPRO(IL+1).GT.0) THEN + DO 35 I=1,NGRO + GA1(I,1)=SIGS(NGRO-I+1,IL+1) + DO 30 J=1,NGRO + GA2(I,J)=SCAT(NGRO-J+1,NGRO-I+1,IL+1) + 30 CONTINUE + 35 CONTINUE + DO 45 I=1,NGRO + SIGS(I,IL+1)=GA1(I,1) + DO 40 J=1,NGRO + SCAT(NGRO-J+1,NGRO-I+1,IL+1)=GA2(J,I) + 40 CONTINUE + 45 CONTINUE + ENDIF + 50 CONTINUE + CALL XDRLGS(JPLIB,1,IMPX,0,INGRO,1,NGRO,SIGS,SCAT,ITYPRO) +* + CALL LCMLEN(JPLIB,'TRANC',LENGT,ITYLCM) + IF (LENGT.GT.0) THEN + CALL LCMGET(JPLIB,'TRANC',GA1(1,1)) + DO 130 I=1,NGRO + GA1(I,2)=GA1(NGRO-I+1,1) + 130 CONTINUE + CALL LCMPUT(JPLIB,'TRANC',NGRO,2,GA1(1,2)) + ENDIF +* + CALL LCMGET(JPLIB,'NTOT0',GA1(1,1)) + DO 140 I=1,NGRO + GA1(I,2)=GA1(NGRO-I+1,1) + 140 CONTINUE + CALL LCMPUT(JPLIB,'NTOT0',NGRO,2,GA1(1,2)) +* + DO 175 IDEL=0,NDEL + IF(IDEL.EQ.0) THEN + HNUSIG='NUSIGF' + HCHI='CHI' + ELSE + WRITE(HNUSIG,'(6HNUSIGF,I2.2)') IDEL + WRITE(HCHI,'(3HCHI,I2.2)') IDEL + ENDIF + CALL LCMLEN(JPLIB,HNUSIG,LENGT,ITYLCM) + IF (LENGT.GT.0) THEN + CALL LCMGET(JPLIB,HNUSIG,GA1(1,1)) + SUM=0.0 + DO 150 I=1,NGRO + SUM=SUM+GA1(I,1) + 150 CONTINUE + DO 160 I=1,NGRO + GA1(I,2)=GA1(NGRO-I+1,1)/SUM + 160 CONTINUE + CALL LCMGET(JPLIB,HCHI,GA1(1,1)) + CALL LCMPUT(JPLIB,HCHI,NGRO,2,GA1(1,2)) + DO 170 I=1,NGRO + GA1(I,2)=GA1(NGRO-I+1,1)*SUM + 170 CONTINUE + CALL LCMPUT(JPLIB,HNUSIG,NGRO,2,GA1(1,2)) + ENDIF + 175 CONTINUE +* + DO 190 IED=1,NED + WRITE(TEXT8,'(2A4)') (NAMEAD(I0,IED),I0=1,2) + IF((TEXT8.EQ.'TRANC').OR.(TEXT8.EQ.'NTOT0').OR. + 1 (TEXT8(:6).EQ.'NUSIGF').OR.(TEXT8(:3).EQ.'CHI')) + 2 GO TO 190 + CALL LCMLEN(JPLIB,TEXT8,LENGT,ITYLCM) + IF (LENGT.GT.0) THEN + CALL LCMGET(JPLIB,TEXT8,GA1(1,1)) + DO 180 I=1,NGRO + GA1(I,2)=GA1(NGRO-I+1,1) + 180 CONTINUE + CALL LCMPUT(JPLIB,TEXT8,NGRO,2,GA1(1,2)) + ENDIF + 190 CONTINUE + 200 CONTINUE +* + CALL LCMGET(IPLIB,'DELTAU',GA1(1,1)) + DO 210 I=1,NGRO + GA1(I,2)=GA1(NGRO-I+1,1) + 210 CONTINUE + CALL LCMPUT(IPLIB,'DELTAU',NGRO,2,GA1(1,2)) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SCAT,SIGS,GA2,GA1,ITYPRO) + RETURN + END diff --git a/Dragon/src/LIBAPL.f b/Dragon/src/LIBAPL.f new file mode 100644 index 0000000..24efbcb --- /dev/null +++ b/Dragon/src/LIBAPL.f @@ -0,0 +1,1000 @@ +*DECK LIBAPL + SUBROUTINE LIBAPL (IPLIB,NAMFIL,MAXTRA,NGRO,NBISO,NL,ISONAM, + 1 ISONRF,IPISO,ISHINA,MASKI,TN,SN,SB,IMPX,NGF,NGFR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transcription of the useful interpolated microscopic cross section +* data from APOLIB-1 to LCM data structures. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* NAMFIL name of the apolib file. +* MAXTRA available storage for apollo compacted +* transfer cross sections. +* NGRO number of energy groups. +* NBISO number of isotopes present in the calculation domain. +* NL number of Legendre orders required in the calculation +* NL=1 or higher. +* ISONAM alias name of isotopes. +* ISONRF library reference name of isotopes. +* IPISO pointer array towards microlib isotopes. +* ISHINA self-shielding name. +* MASKI isotopic mask. Isotope with index I is processed if +* MASKI(I)=.true. +* TN temperature of each isotope. +* SN dilution cross section in each energy group of each. +* isotope. a value of 1.0E10 is used for infinite dilution. +* SB dilution cross section as used by Livolant and Jeanpierre +* normalization. +* IMPX print flag. +* +*Parameters: output +* NGF number of fast groups without self-shielding. +* NGFR number of fast and resonance groups. +* +*Reference: +* A. Hoffmann, F. Jeanpierre, A. Kavenoky, M. Livolant AND H. Lorain, +* 'APOLLO - Code multigroupe de resolution de l'equation du transport +* pour les neutrons thermiques et rapides', Rapport SERMA 'T' No. +* 1 193, Commissariat a l'Energie Atomique, Saclay (1973). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + PARAMETER(MAXQUA=11,MAXDIL=60) + CHARACTER*(*) NAMFIL + TYPE(C_PTR) IPLIB,IPISO(NBISO) + INTEGER MAXTRA,NGRO,NBISO,NL,ISONAM(3,NBISO),ISONRF(3,NBISO), + 1 ISHINA(3,NBISO),IMPX,NGF,NGFR + REAL TN(NBISO),SN(NGRO,NBISO),SB(NGRO,NBISO) + LOGICAL MASKI(NBISO) +*---- +* LOCAL VARIABLES +*---- + CHARACTER FORM*4,HVEC(5)*6,HSMG*131,HNISOR*12,HSHI*12,HNAMIS*12 + PARAMETER (NSYSO=6,MAXIT=1000,MAXVEC=11,MAXTMP=40) + TYPE(C_PTR) KPLIB + LOGICAL NOTG,LEXC,LALL,LALL2,LALBIS + DOUBLE PRECISION X1,X2,DDE,ENER,TMP + INTEGER IANIS(80),ITY(80),NEXT(80),NEXU(80),NEXV(80),NEXW(80), + 1 III(80),IT(MAXIT),ITYPE(MAXVEC),ITYSEC(MAXVEC),TIT(18),NTETA(4), + 2 NSE(4) + REAL TETAB(MAXTMP),SIGE(MAXDIL,4),SEAUX(MAXDIL,150),XE(MAXDIL), + 1 GE(MAXDIL) + EQUIVALENCE(AA,NN) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NISB,NISBEF,ITYPRO + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IPR + REAL, ALLOCATABLE, DIMENSION(:) :: AWR,VECT,SIG1,SIGA,SIGF, + 1 PRI,VTHER,SSS,SSS1,SS1,SS11,UUU,DELTA + REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGS,PHI,PP,PP1 + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT,SEFF + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LINF +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IPR(4,NBISO),NISB(NBISO),NISBEF(NBISO),ITYPRO(NL)) + ALLOCATE(AWR(NBISO),VECT(NGRO+1),SIGS(NGRO,NL),SIG1(NGRO), + 1 SIGA(NGRO),SIGF(NGRO),PRI(MAXTRA),VTHER(NGRO),PHI(NGRO,MAXQUA), + 2 PP(NGRO,NGRO+1),PP1(NGRO,NGRO+1),SSS(NGRO),SSS1(NGRO),SS1(NGRO), + 3 SS11(NGRO),UUU(NGRO),DELTA(NGRO),SCAT(NGRO,NGRO,NL), + 4 SEFF(MAXDIL,NGRO,4)) + ALLOCATE(LINF(NGRO)) +* + IQUAN=0 + X1=0.0D0 + X2=0.0D0 + NGF=NGRO+1 + NGFR=0 + DO 10 IMX=1,NBISO + IPR(1,IMX)=0 + HSHI=' ' + IF(MASKI(IMX)) THEN + WRITE(HSHI,'(3A4)') (ISHINA(I0,IMX),I0=1,3) + WRITE(HNISOR,'(3A4)') (ISONRF(I0,IMX),I0=1,3) + I=INDEX(HNISOR,' ') + IF(I.EQ.0) THEN + READ(HNISOR,'(I8)') NISB(IMX) + ELSE + WRITE(FORM,'(2H(I,I1,1H))') I-1 + READ(HNISOR,FORM) NISB(IMX) + ENDIF + I=INDEX(HSHI,' ') + IF(HSHI.EQ.' ') THEN + NISBEF(IMX)=0 + ELSE IF(I.EQ.0) THEN + READ(HSHI,'(I8)') NISBEF(IMX) + ELSE + WRITE(FORM,'(2H(I,I1,1H))') I-1 + READ(HSHI,FORM) NISBEF(IMX) + ENDIF + ENDIF + IF(HSHI.EQ.' ') THEN + IPR(2,IMX)=1 + ELSE + IPR(2,IMX)=0 + ENDIF + IPR(3,IMX)=0 + IPR(4,IMX)=0 + 10 CONTINUE + IF(IMPX.GT.0) WRITE(NSYSO,890) NAMFIL + NIN=KDROPN(NAMFIL,2,2,0) + IF(NIN.LE.0) THEN + WRITE(HSMG,'(36HLIBAPL: UNABLE TO OPEN LIBRARY FILE ,A16, + 1 6H. NIN=,I4,1H.)') NAMFIL,NIN + CALL XABORT(HSMG) + ENDIF +*---- +* RECOVER THE GROUP STRUCTURE +*---- + 20 READ(NIN) INDLOR,NR,NIT,(IT(I),I=1,NIT) + IF(INDLOR.EQ.9999) THEN + WRITE(NSYSO,940) + CALL LCMGET(IPLIB,'DELTAU',DELTA) + CALL LCMGET(IPLIB,'ENERGY',VECT) + E0=1.0E-6*VECT(1) + DO 25 I=1,NGRO + UUU(I)=LOG(VECT(1)/VECT(I+1)) + 25 CONTINUE + ELSE IF(IT(3).EQ.0) THEN + DO 30 K=1,NR + READ(NIN) + 30 CONTINUE + GO TO 20 + ELSE + READ(NIN) E0,DEL,(UUU(I),I=1,NGRO),(DELTA(I),I=1,NGRO) + NR1=NR-1 + VECT(1)=1.0E6*E0 + DO 40 I=1,NGRO + VECT(I+1)=1.0E6*E0*EXP(-UUU(I)) + 40 CONTINUE + CALL LCMPUT(IPLIB,'ENERGY',NGRO+1,2,VECT) + CALL LCMPUT(IPLIB,'DELTAU',NGRO,2,DELTA) + ENDIF +*---- +* ***MATERIAL/ISOTOPE LOOP*** +*---- + NED=0 + LALBIS=.TRUE. + 45 NOTG=.TRUE. + REWIND(NIN) + NTITLE=18 + 50 READ(NIN) INDLOR,NR,NIT,(IT(I),I=1,NIT),(TIT(I),I=1,NTITLE) + IF(NIT.GT.MAXIT) THEN + WRITE(HSMG,960) 'MAXIT' + CALL XABORT(HSMG) + ENDIF + IF(INDLOR.EQ.9999) GO TO 740 + IMAIL=IT(1) + IF(IMAIL.EQ.99) THEN + IX=47 + ELSE IF(IMAIL.EQ.142) THEN + IX=60 + ELSE IF(IMAIL.EQ.172) THEN + IX=80 + ELSE + WRITE(HSMG,'(45HLIBAPL: INCONSISTENT GROUP STRUCTURES. IT(1)=, + 1 I5)') IMAIL + CALL XABORT(HSMG) + ENDIF + LALL=.TRUE. + LALL2=LALBIS + DO 70 IMX=1,NBISO + IF(MASKI(IMX)) THEN + IMT=IMX + LALL=LALL.AND.(IPR(1,IMX).EQ.1).AND.(IPR(2,IMX).EQ.1) + LALL2=LALL2.AND.(IPR(1,IMX).EQ.1) + IF((INDLOR.EQ.NISB(IMX)).AND.(IPR(1,IMX).EQ.0)) GO TO 90 + IF((INDLOR.EQ.NISBEF(IMX)).AND.(IPR(1,IMX).EQ.1).AND. + 1 (IPR(2,IMX).EQ.0)) GO TO 500 + ENDIF + 70 CONTINUE + IF(LALL) THEN + GO TO 740 + ELSE IF(LALL2) THEN + LALBIS=.FALSE. + GO TO 45 + ELSE + DO 80 K=1,NR + READ(NIN) + 80 CONTINUE + GO TO 50 + ENDIF +*---- +* MATERIAL CONTROL +*---- + 90 IPR(1,IMT)=1 + NOTG=.FALSE. + NR1=NR + IF(IT(2).NE.NGRO) CALL XABORT('LIBAPL: INCONSISTENT GROUP STRUC' + 1 //'TURES.') + IF(IT(3).NE.0) THEN + READ(NIN) + NR1=NR-1 + ENDIF + NRST=IT(4) + KPLIB=IPISO(IMT) ! set IMT-th isotope + DO 106 J=1,NGRO + SIG1(J)=0.0 + SIGA(J)=0.0 + SIGF(J)=0.0 + DO 105 IL=1,NL + SIGS(J,IL)=0.0 + 105 CONTINUE + 106 CONTINUE + NTYPE=0 + NS1=0 + DO 205 IRST=1,NRST + IF(IRST.GT.1) THEN + IQUAN=1 + ITYSEC(1)=IT(4+NS1+IRST) + ELSE IF(IT(5).GT.0) THEN + IQUAN=1 + ITYSEC(1)=IT(5) + ELSE IF(IT(5).EQ.0) THEN + IQUAN=4 + ITYSEC(1)=1 + ITYSEC(2)=2 + ITYSEC(3)=3 + ITYSEC(4)=4 + ELSE IF(IT(5).LT.0) THEN + NS1=-IT(5) + IQUAN=NS1 + DO 110 I=1,IQUAN + ITYSEC(I)=IT(5+I) + 110 CONTINUE + ENDIF + IF(IQUAN.GT.MAXQUA) CALL XABORT('LIBAPL: MAXQUA TOO SMALL.') + READ(NIN)((PHI(J,ISEC),J=1,NGRO),ISEC=1,IQUAN) + NR1=NR1-1 + DO 200 ISEC=1,IQUAN + IMMOND=ITYSEC(ISEC) + DO 120 I=1,NTYPE + IF(IMMOND.EQ.ITYPE(I)) GO TO 200 + 120 CONTINUE + IF(IMPX.GT.7) THEN + WRITE(NSYSO,920) NISB(IMT),IRST,IMMOND + WRITE(NSYSO,930) (PHI(J,ISEC),J=1,NGRO) + ENDIF + NTYPE=NTYPE+1 + ITYPE(NTYPE)=IMMOND + IF(IMMOND.EQ.1) THEN + DO 140 J=1,NGRO + SIGS(J,1)=PHI(J,ISEC) + 140 CONTINUE + ELSE IF(IMMOND.EQ.2) THEN + DO 150 J=1,NGRO + SIGA(J)=PHI(J,ISEC) + 150 CONTINUE + ELSE IF(IMMOND.EQ.3) THEN + CALL LCMPUT(KPLIB,'NUSIGF',NGRO,2,PHI(1,ISEC)) + ELSE IF(IMMOND.EQ.4) THEN + DO 155 J=1,NGRO + PHI(J,ISEC)=PHI(J,ISEC)*DELTA(J) + 155 CONTINUE + CALL LCMPUT(KPLIB,'CHI',NGRO,2,PHI(1,ISEC)) + ELSE IF(IMMOND.EQ.5) THEN + CALL LCMPUT(KPLIB,'NG',NGRO,2,PHI(1,ISEC)) + IPR(3,IMT)=1 + DO 160 I=1,NED + IF(HVEC(I).EQ.'NG') GO TO 200 + 160 CONTINUE + NED=NED+1 + HVEC(NED)='NG' + ELSE IF(IMMOND.EQ.6) THEN + CALL LCMPUT(KPLIB,'NFTOT',NGRO,2,PHI(1,ISEC)) + IPR(4,IMT)=1 + DO 170 I=1,NED + IF(HVEC(I).EQ.'NFTOT') GO TO 200 + 170 CONTINUE + NED=NED+1 + HVEC(NED)='NFTOT' + ELSE IF(IMMOND.EQ.10) THEN + DO 180 J=1,NGRO + SIG1(J)=PHI(J,ISEC) + 180 CONTINUE + ELSE IF(IMMOND.EQ.11) THEN + DO 185 J=1,NGRO + VECT(J)=1.0/(3.0*PHI(J,ISEC)) + 185 CONTINUE + CALL LCMPUT(KPLIB,'STRD',NGRO,2,VECT) + DO 190 I=1,NED + IF(HVEC(I).EQ.'STRD') GO TO 200 + 190 CONTINUE + NED=NED+1 + HVEC(NED)='STRD' + ELSE + WRITE(NSYSO,920) NISB(IMT),IRST,IMMOND + CALL XABORT('LIBAPL: UNKNOWN REACTION TYPE.') + ENDIF + 200 CONTINUE + 205 CONTINUE +*---- +* SCATTERING MATRIX CONTROL +*---- + ITH=0 + IMAT=0 + IC=5+NS1+NRST + NRSTR=IT(IC) + ICC=IC+6*NRSTR+1 + NN=IT(ICC) + AWR(IMT)=AA + NN=IT(ICC+1) + AT=AA + NKDEB=1 + IIIC=1 +* + IF(NRSTR.EQ.0)GO TO 380 + IC=IC-5 + ITH=0 + IMAT=0 + IMAT1=0 + ITROUV=0 + IMAT0=0 + DO 290 IS=1,NRSTR + IC=IC+6 + IF(IT(IC).GT.NL-1) GO TO 280 + IF(IT(IC+1).EQ.7) THEN +* DO TEMPERATURE INTERPOLATION FOR THE THERMAL TRANSFER MATRICES. + IF(IX.NE.IT(IC+3)) THEN + WRITE(NSYSO,950) IX,IT(IC+3) + IX=IT(IC+3) + ENDIF + IF(IT(IC).EQ.1) IMAT1=IMAT1+1 + IF(IMAT1.EQ.1) THEN + IMAT=0 + ITROUV=0 + ENDIF + ITH=1 + TEMPI=REAL(IT(IC+5))+0.16 + TEMPA=TN(IMT) + IMAT=IMAT+1 + IF(ITROUV.NE.0) GO TO 280 + ITEST=(IMAT/2)*2-IMAT + IF(ITEST.NE.0) THEN + READ(NIN)((PP1(K,J),K=1,IX),J=1,IX),(SSS1(K),K=1,IX), + 1 (SS11(K),K=1,IX) + NR1=NR1-1 + X1=TEMPI + ELSE + IF(IT(IC).EQ.0) THEN + READ(NIN)((PP(K,J),K=1,IX),J=1,IX),(SSS(K),K=1,IX), + 1 (SS1(K),K=1,IX) + NR1=NR1-1 + X2=TEMPI + ELSE + READ(NIN)((PP(K,J),K=1,IX),J=1,IX),(SSS1(K),K=1,IX), + 1 (SS11(K),K=1,IX) + NR1=NR1-1 + X2=TEMPI + ENDIF + ENDIF + IF(IMAT.EQ.1)GO TO 290 + XX=REAL((TEMPA-X1)*(TEMPA-X2)) + IF(XX.LE.0.)ITROUV=1 + IF((TEMPA.LE.TEMPI).AND.(IMAT.EQ.2))ITROUV=1 + IF(IT(IC+6).EQ.1.AND.IT(IC).NE.1)IMAT0=IMAT + IF(IMAT.EQ.IMAT0)ITROUV=1 + IF(ITROUV.NE.1)GO TO 290 + XX=REAL((TEMPA-X1)/(X1-X2)) + IF(IMAT.EQ.1)XX=0. + I2=IIIC+IX*IX-1 + IF(I2.GT.MAXTRA) THEN + WRITE(HSMG,960) 'MAXTRA' + CALL XABORT(HSMG) + ENDIF + IF(IT(IC).EQ.0) THEN + DO 215 K=1,IX + SSS(K)=SSS1(K)+(SSS1(K)-SSS(K))*XX + KI=NGRO-K+1 + SS1(K)=SS11(K)+(SS11(K)-SS1(K))*XX + DO 210 J=1,IX + KJ=NGRO-J+1 + PP(J,K)=PP1(J,K)+(PP1(J,K)-PP(J,K))*XX + 210 CONTINUE + 215 CONTINUE + DO 225 J=1,IX + DO 220 K=1,IX + PRI(IIIC+(J-1)*IX+K-1)=PP(J,K) + 220 CONTINUE + 225 CONTINUE + ELSE +* ANISOTROPES + DO 245 K=1,IX + KI=NGRO-K+1 + DO 240 J=1,IX + KJ=NGRO-J+1 + PP1(J,K)=PP1(J,K)+(PP1(J,K)-PP(J,K))*XX + 240 CONTINUE + 245 CONTINUE + DO 255 J=1,IX + DO 250 K=1,IX + PRI(IIIC+(J-1)*IX+K-1)=PP1(J,K) + 250 CONTINUE + 255 CONTINUE + ENDIF + IANIS(NKDEB)=IT(IC) + ITY(NKDEB)=7 + NEXT(NKDEB)=IX*IX + NEXU(NKDEB)=IX + NEXV(NKDEB)=IX + NEXW(NKDEB)=INT(TEMPA) + ELSE + IANIS(NKDEB)=IT(IC) + ITY(NKDEB)=IT(IC+1) + NEXT(NKDEB)=IT(IC+2) + NEXU(NKDEB)=IT(IC+3) + NEXV(NKDEB)=IT(IC+4) + NEXW(NKDEB)=IT(IC+5) + I2=IIIC+NEXT(NKDEB)-1 + IF(I2.GE.IIIC) THEN + IF(I2.GT.MAXTRA) THEN + WRITE(HSMG,960) 'MAXTRA' + CALL XABORT(HSMG) + ENDIF + READ(NIN)(PRI(J),J=IIIC,I2) + NR1=NR1-1 + ENDIF + ENDIF + III(NKDEB)=IIIC + IIIC=I2+1 + NKDEB=NKDEB+1 + GOTO 290 + 280 READ(NIN) + NR1=NR1-1 + 290 CONTINUE +*---- +* FREE GAS THERMAL DIFFUSION MATRICES. +*---- + IF(IX.EQ.0)GO TO 380 + IF(ITH.NE.0)GO TO 360 + T=TN(IMT)/293.16 + AMT=AWR(IMT) + IF(AMT.LT.1.0)AMT=1.0 + DO 300 K=NGRO-IX+1,NGRO + SIG1(K)=SIG1(K)/SIGS(K,1) + 300 CONTINUE + X1=0.0253D-06 + DDE=-UUU(NGRO-IX) + ENER=E0*EXP(DDE) + X2=SQRT(ENER/X1) + DO 305 J=1,IX + K=IX+1-J + IE=NGRO-IX+J + DDE=-UUU(IE) + ENER=E0*DEXP(DDE) + DDE=SQRT(ENER/X1) + VECT(K)=REAL(X2-DDE) + X2=DDE + VTHER(K)=2.0*VECT(K)/DELTA(IE) + 305 CONTINUE + CALL LIBBAS(1,AT,0.0,AMT,T,IX,VTHER,VECT,NGRO,PP,SSS,SSS1,SS11) + IF(AMT.GT.100.) THEN + DO 310 J=1,IX + K=NGRO-J+1 + SSS(J)=SIGS(K,1) + 310 CONTINUE + ENDIF + DO 335 I=1,IX + K=NGRO-I+1 + SIG1(K)=SIG1(K)*SSS(I) + SS1(I)=SIG1(K) + RENORM=0.0 + DO 320 J=1,IX + RENORM=RENORM+VTHER(J)*VECT(J)*PP(J,I) + 320 CONTINUE + RENORM=RENORM/(VTHER(I)*VECT(I)) + RENORM=1.0/RENORM + DO 330 J=1,IX + PP(J,I)=PP(J,I)*SSS(I)*RENORM + 330 CONTINUE + 335 CONTINUE + DO 345 J=1,IX + AUX=VTHER(J)*VTHER(J) + DO 340 I=1,IX + PP(I,J)=PP(I,J)/AUX*VTHER(I)*VTHER(I) + 340 CONTINUE + 345 CONTINUE + I2=IIIC+IX*IX + IF(I2.GT.MAXTRA) THEN + WRITE(HSMG,960) 'MAXTRA' + CALL XABORT(HSMG) + ENDIF + DO 355 J=1,IX + DO 350 K=1,IX + PRI(IIIC+(J-1)*IX+K-1)=PP(J,K) + 350 CONTINUE + 355 CONTINUE + IANIS(NKDEB)=0 + ITY(NKDEB)=7 + NEXT(NKDEB)=IX*IX + NEXU(NKDEB)=IX + NEXV(NKDEB)=IX + NEXW(NKDEB)=INT(TN(IMT)) + III(NKDEB)=IIIC + IIIC=I2+1 + NKDEB=NKDEB+1 +* + 360 DO 370 J=1,IX + K=NGRO-J+1 + SIG1(K)=SS1(J) + SIGS(K,1)=SSS(J) + 370 CONTINUE +* + 380 IF(NR1.GT.0) THEN + DO 390 IR=1,NR1 + READ(NIN) + 390 CONTINUE + ENDIF + NKDEB=NKDEB-1 + IIIC=IIIC-1 + IF(IMPX.GT.0) THEN + WRITE(NSYSO,860) (ISONAM(I0,IMT),I0=1,3),(TIT(J),J=1,9), + 1 NISBEF(IMT),IIIC,(ITYPE(L),L=1,NTYPE) + WRITE(NSYSO,870) (ITY(L),L=1,NKDEB) + WRITE(NSYSO,880) (TIT(J),J=10,18) + ENDIF + IF(IMPX.GT.7) THEN + DO 395 K1=1,NKDEB + I1=III(K1) + I2=I1+NEXT(K1)-1 + WRITE(NSYSO,910) NISB(IMT),K1,ITY(K1),NEXU(K1),NEXV(K1), + 1 NEXW(K1),IANIS(K1),(PRI(K),K=I1,I2) + 395 CONTINUE + ENDIF +*---- +* SAVE SCATTERING MATRICES ON LCM +*---- + INGRO=0 + DO 396 IG1=1,NGRO + IF(SIG1(IG1).NE.0.0) INGRO=NL-1 + 396 CONTINUE + DO 480 IL=0,INGRO + ZL=2.0*REAL(IL)+1.0 + DO 420 IG2=1,NGRO + CALL LIBSEC(MAXTRA,IG2,IL,NGRO,IX,UUU,DELTA,SIGS(1,1),SIG1,PRI, + 1 NLET,VECT,DEL,NKDEB,IANIS,ITY,NEXT,NEXU,NEXV,NEXW,III) + DO 400 IG1=1,IG2 + SCAT(IG2,IG1,IL+1)=VECT(IG2-IG1+1)*DELTA(IG2)/(ZL*DELTA(IG1)) + 400 CONTINUE + DO 410 IG1=IG2+1,NGRO + SCAT(IG2,IG1,IL+1)=VECT(IG2+NGRO-IG1+1)*DELTA(IG2)/(ZL*DELTA(IG1)) + 410 CONTINUE + 420 CONTINUE +* + IF(IL.EQ.0) THEN +* PROCESS NEXCESS INFORMATION. + LEXC=.FALSE. + DO 430 IG1=1,NGRO-IX + SSS(IG1)=-SIGS(IG1,1) + DO 425 IG2=1,NGRO + SSS(IG1)=SSS(IG1)+SCAT(IG2,IG1,1) + 425 CONTINUE + IF(SSS(IG1)/SIGS(IG1,1).GT.1.0E-5) THEN + LEXC=.TRUE. + SIGS(IG1,1)=SIGS(IG1,1)+SSS(IG1) + ELSE + SSS(IG1)=0.0 + ENDIF + 430 CONTINUE + DO 440 IG1=NGRO-IX+1,NGRO + SSS(IG1)=0.0 + 440 CONTINUE + IF(LEXC) CALL LCMPUT(KPLIB,'N2N',NGRO,2,SSS) + ENDIF +* + IF(IL.GT.0) THEN + DO 455 IG1=1,NGRO + SIGS(IG1,IL+1)=0.0 + DO 450 IG2=1,NGRO + SIGS(IG1,IL+1)=SIGS(IG1,IL+1)+SCAT(IG2,IG1,IL+1) + 450 CONTINUE + 455 CONTINUE + ENDIF + 480 CONTINUE + DO 490 IG1=1,NGRO + VECT(IG1)=SIGA(IG1)+SIGS(IG1,1)-SSS(IG1) + 490 CONTINUE +*---- +* SAVE INFINITE-DILUTION X-S INFORMATION. +*---- + WRITE(HNAMIS,'(3A4)') (ISONAM(I0,IMT),I0=1,3) + CALL LCMPUT(KPLIB,'NTOT0',NGRO,2,VECT) + CALL LCMPUT(KPLIB,'README',18,3,TIT) + CALL LCMPTC(KPLIB,'ALIAS',12,HNAMIS) + CALL LCMPUT(KPLIB,'AWR',1,2,AWR(IMT)) + CALL XDRLGS(KPLIB,1,0,0,INGRO,1,NGRO,SIGS,SCAT,ITYPRO) + GO TO 50 +*---- +* SELF-SHIELDING CONTROL. +*---- + 500 IPR(2,IMT)=1 + IF((IT(1).NE.IMAIL).OR.(IT(2).NE.NGRO).OR.(IT(3).NE.0)) + 1 CALL XABORT('LIBAPL: SELF-SHIELDING FAILURE (1).') + NS=IT(4) +*---- +* RECOVER INFINITE-DILUTION X-S INFORMATION. +*---- + KPLIB=IPISO(IMT) ! set IMT-th isotope + CALL LCMGET(KPLIB,'NTOT0',SIGA) + CALL XDRLGS(KPLIB,-1,0,0,NL-1,1,NGRO,SIGS,SCAT,ITYPRO) +*---- +* COMPUTE P0 TRANSFER PROBABILITIES. +*---- + DO 515 IG2=1,NGRO + SIGA(IG2)=SIGA(IG2)-SIGS(IG2,1) + DO 510 IG1=1,NGRO + SCAT(IG2,IG1,1)=SCAT(IG2,IG1,1)/SIGS(IG1,1) + 510 CONTINUE + 515 CONTINUE +* + ISS=0 + IAS=0 + IFS=0 + I104=0 + JTYSEC=0 + NTYPE=0 + DO 520 IK=1,NS + IF(IT(IK+4).NE.JTYSEC) THEN + NTYPE=NTYPE+1 + IF(NTYPE.GT.4) CALL XABORT('LIBAPL: TOO MANY TYPES.') + NTETA(NTYPE)=1 + IF(IT(IK+4).EQ.101) ISS=NTYPE + IF(IT(IK+4).EQ.102) IAS=NTYPE + IF(IT(IK+4).EQ.103) IFS=NTYPE + IF(IT(IK+4).EQ.104) I104=NTYPE + JTYSEC=IT(IK+4) + ITYPE(NTYPE)=IT(IK+4) + ELSE + NTETA(NTYPE)=NTETA(NTYPE)+1 + ENDIF + 520 CONTINUE + IF(IFS.GT.0) CALL LCMGET(KPLIB,'NUSIGF',SIGF) + IF(IAS.EQ.0) CALL XABORT('LIBAPL: SELF-SHIELDING FAILURE (2).') + IF(IMPX.GT.0) THEN + WRITE(NSYSO,990) NISBEF(IMT),(TIT(I),I=1,9), + 1 (ITYPE(I),I=1,NTYPE) + WRITE(NSYSO,880) (TIT(I),I=10,18) + ENDIF +*---- +* TEMPERATURE INTERPOLATION OF EFFECTIVE REACTION RATES. +*---- + DO 590 I=1,NTYPE + IF(NTETA(I).EQ.1) THEN + READ (NIN) TEMP,NSEI,(SIGE(K,I),K=1,NSEI),N2,N6,((SEFF(K,J + 1 ,I),J=1,N6),K=1,NSEI) + ELSE + IF(NTETA(I).GT.MAXTMP) THEN + WRITE(HSMG,960) 'MAXTMP' + CALL XABORT(HSMG) + ENDIF + DO 532 ITET=1,NTETA(I) + READ(NIN) TETAB(ITET),NSEI,(SIGE(K,I),K=1,NSEI),N2,N6, + 1 ((SEAUX(K,J),J=1,N6),K=1,NSEI) + IF(ITET.NE.1) THEN + IF(TN(IMT).LT.TETAB(ITET)) GO TO 540 + IF(ITET.EQ.NTETA(I)) GO TO 560 + ENDIF + DO 531 K=1,NSEI + DO 530 J=1,N6 + SEFF(K,J,I)=SEAUX(K,J) + 530 CONTINUE + 531 CONTINUE + 532 CONTINUE + 540 ITE=ITET+1 + DO 550 ITT=ITE,NTETA(I) + READ(NIN) + 550 CONTINUE + 560 DT=SQRT(TN(IMT))-SQRT(TETAB(ITET)) + DT=DT/(SQRT(TETAB(ITET))-SQRT(TETAB(ITET-1))) + DO 575 K=1,NSEI + DO 570 J=1,N6 + SEFF(K,J,I)=(SEAUX(K,J)-SEFF(K,J,I))*DT+SEAUX(K,J) + 570 CONTINUE + 575 CONTINUE + ENDIF + IF(NSEI.GT.MAXDIL) THEN + WRITE(HSMG,'(37HLIBAPL: MAXDIL SHOULD BE INCREASED TO,I4)') + 1 NSEI + CALL XABORT(HSMG) + ELSE IF(NSEI.GT.1) THEN + IF(SIGE(1,I).GT.SIGE(2,I)) CALL XABORT('LIBAPL: INVALID ORDER' + 1 //'ING OF THE DILUTIONS.') + ENDIF + NGF=MIN(NGF,N2-1) + NGFR=MAX(NGFR,N2+N6-1) + IF(I.EQ.I104) THEN + DO 585 J=1,N6 + DO 580 K=1,NSEI + IF((SIGE(K,I).LT.1.0E10).OR.(K.EQ.1)) THEN + SEFF(K,J,I)=(1.0-SEFF(K,J,I))*SIGE(K,I) + ELSE + SEFF(K,J,I)=SEFF(K-1,J,I) + ENDIF + 580 CONTINUE + 585 CONTINUE + ENDIF + NSE(I)=NSEI + 590 CONTINUE +*---- +* DILUTION INTERPOLATION OF EFFECTIVE REACTION RATES. +*---- + DO 600 L=1,NGRO + IF(ISS.NE.0) PHI(L,ISS)=SIGS(L,1) + IF(IAS.NE.0) PHI(L,IAS)=SIGA(L) + IF(IFS.NE.0) PHI(L,IFS)=SIGF(L) + IF(I104.NE.0) PHI(L,I104)=SIGA(L) + LINF(L)=.FALSE. + VECT(L)=SIGS(L,1) + 600 CONTINUE +* + DO 625 LE=1,N6 + L=LE+N2-1 + SEIM=MAX(0.0,SN(L,IMT)) + DO 620 I=1,NTYPE + IF(NSE(I).EQ.1) THEN + PHI(L,I)=SEFF(1,LE,I) + ELSE + NSEI=NSE(I) + IF(SIGE(NSE(I),I).GE.1.0E10) NSEI=NSE(I)-1 + IF(SEIM.LT.SIGE(NSEI,I)) THEN + DO 610 K=1,NSEI + XE(K)=SQRT(SIGE(K,I)) + GE(K)=SEFF(K,LE,I) + 610 CONTINUE + CALL LIBLAG(NSEI,XE,GE,SQRT(SEIM),PHI(L,I)) + ELSE IF(NSE(I).GT.NSEI) THEN + IF(I.EQ.I104) LINF(L)=.TRUE. + FAC=SIGE(NSEI,I)/SEIM + PHI(L,I)=FAC*SEFF(NSEI,LE,I)+(1.0-FAC)*SEFF(NSE(I),LE,I) + ENDIF + ENDIF + 620 CONTINUE + 625 CONTINUE +*---- +* RECOVER THE EFFECTIVE FLUX. +*---- + IF(IMPX.GT.4) WRITE(NSYSO,1020) + DO 630 L=1,NGRO + SS1(L)=1.0 + 630 CONTINUE + DO 660 L=N2,N2+N6-1 + SEIM=SN(L,IMT) + IF(SEIM.EQ.0.) CALL XABORT('LIBAPL: SELF-SHIELDING FAILURE (3).') + IF((IAS.NE.0).AND.(ISS.NE.0)) THEN +* COMPUTE THE EFFECTIVE FLUX. + TMP1=0.0D0 + DO 640 IG2=1,N2-1 + TMP1=TMP1+SCAT(L,IG2,1)*PHI(IG2,ISS)*DELTA(IG2)/DELTA(L) + 640 CONTINUE + IF(TMP1.GT.5.0E-3*PHI(L,ISS)) THEN +* USE A SIMPLIFIED MODEL. + AUX=PHI(L,IAS) + ELSE +* USE A SLOWING-DOWN BALANCE EQUATION. + TMP=TMP1 + DO 650 IG2=N2,N2+N6-1 + TMP=TMP+SCAT(L,IG2,1)*PHI(IG2,ISS)*DELTA(IG2)/DELTA(L) + 650 CONTINUE + AUX=REAL(PHI(L,IAS)+PHI(L,ISS)-TMP) + ENDIF + ELSE IF(IAS.NE.0) THEN +* COMPUTE THE EFFECTIVE FLUX USING A SIMPLIFIED MODEL. + AUX=PHI(L,IAS) + ELSE + AUX=0.0 + ENDIF +* + IF(SB(L,IMT).GE.1.0E10) THEN +* USE AN INFINITE DILUTION VALUE. + ZNPHI=0.0 + ELSE IF((I104.NE.0).AND.LINF(L)) THEN +* USE AN INTERPOLATED VALUE NEAR INFINITE DILUTION. + NSEI=NSE(I104) + IF(SIGE(NSE(I104),I104).GE.1.0E10) NSEI=NSE(I104)-1 + FAC=(SIGE(NSEI,I104)/SEIM)**2 + ZNPHI=FAC*PHI(L,I104)+(1.0-FAC)*AUX + ELSE IF(I104.NE.0) THEN +* USE AN INTERPOLATED VALUE. + ZNPHI=PHI(L,I104) + ELSE +* USE A CALCULATED VALUE. + ZNPHI=AUX + ENDIF + PHI0=1.0-ZNPHI/SB(L,IMT) + IF((PHI0.LE.0.0).OR.(PHI0.GT.1.2)) THEN + WRITE(HSMG,980) PHI0,L,ZNPHI,SEIM,(ISONAM(I0,IMT),I0=1,3) + WRITE(NSYSO,'(/1X,A131)') HSMG + ENDIF + SS1(L)=PHI0 + IF(IFS.GT.0) SIGF(L)=PHI(L,IFS)/PHI0 + IF(IAS.GT.0) SIGA(L)=PHI(L,IAS)/PHI0 + IF(ISS.GT.0) SIGS(L,1)=PHI(L,ISS)/PHI0 + IF(IMPX.GT.4) WRITE(NSYSO,1010) L,PHI0,SIGF(L),SIGA(L),SIGS(L,1), + 1 SEIM,SB(L,IMT),ZNPHI + 660 CONTINUE + IF(IMPX.GT.4) WRITE(NSYSO,'(/)') +* + CALL LCMPUT(KPLIB,'NWT0',NGRO,2,SS1) +*---- +* SELF-SHIELDING OF THE TRANSFERT CROSS SECTIONS. +*---- + IF(ISS.NE.0) THEN + DO 675 IG1=1,NGRO + DO 670 IG2=1,NGRO + SCAT(IG2,IG1,1)=SCAT(IG2,IG1,1)*SIGS(IG1,1) + 670 CONTINUE + 675 CONTINUE + INGRO=NL-1 + DO 680 IL=NL-1,0,-1 + IF(ITYPRO(IL+1).EQ.0) THEN + INGRO=INGRO-1 + ELSE + GO TO 685 + ENDIF + 680 CONTINUE + 685 DO 695 IL=1,NL-1 + IF(ITYPRO(IL+1).GT.0) THEN + DO 691 IG2=1,NGRO + SIGS(IG2,IL+1)=SIGS(IG2,IL+1)*SIGS(IG2,1)/VECT(IG2) + DO 690 IG1=1,NGRO + SCAT(IG2,IG1,IL+1)=SCAT(IG2,IG1,IL+1)*SIGS(IG1,1)/VECT(IG1) + 690 CONTINUE + 691 CONTINUE + ENDIF + 695 CONTINUE +* +* SAVE SELF-SHIELDED X-S INFORMATION. + CALL XDRLGS(KPLIB,1,0,0,INGRO,1,NGRO,SIGS,SCAT,ITYPRO) + ENDIF +*---- +* SELF-SHIELDING OF THE RADIATIVE CAPTURE CROSS SECTIONS. +*---- + IF(IPR(3,IMT).EQ.1) THEN + CALL LCMGET(KPLIB,'NTOT0',SS1) + DO 700 I=1,NGRO + SS1(I)=SS1(I)-VECT(I) + 700 CONTINUE + CALL LCMGET(KPLIB,'NG',VECT) + DO 710 I=1,NGRO + IF(SS1(I).EQ.0.0) GO TO 710 + VECT(I)=VECT(I)*SIGA(I)/SS1(I) + 710 CONTINUE + CALL LCMPUT(KPLIB,'NG',NGRO,2,VECT) + ENDIF +*---- +* SELF-SHIELDING OF THE FISSION CROSS SECTIONS. +*---- + IF(IFS.NE.0) THEN + IF(IPR(4,IMT).EQ.1) THEN + CALL LCMGET(KPLIB,'NUSIGF',SS1) + CALL LCMGET(KPLIB,'NFTOT',VECT) + DO 720 I=1,NGRO + IF(SS1(I).EQ.0.0) GO TO 720 + VECT(I)=VECT(I)*SIGF(I)/SS1(I) + 720 CONTINUE + CALL LCMPUT(KPLIB,'NFTOT',NGRO,2,VECT) + ENDIF + CALL LCMPUT(KPLIB,'NUSIGF',NGRO,2,SIGF) + ENDIF +* + DO 730 I=1,NGRO + SIGA(I)=SIGA(I)+SIGS(I,1) + 730 CONTINUE + CALL LCMPUT(KPLIB,'NTOT0',NGRO,2,SIGA) + GO TO 50 +*---- +* CHECK IF ALL NBISO ISOTOPES HAVE BEEN PROCESSED. +*---- + 740 NISOT=0 + DO 750 IMT=1,NBISO + IF(MASKI(IMT)) THEN + IF((IPR(1,IMT).EQ.0).AND.(.NOT.NOTG)) THEN + GO TO 45 + ELSE IF((IPR(1,IMT).EQ.0).AND.NOTG) THEN + WRITE(NSYSO,900) (ISONAM(I0,IMT),I0=1,3),NAMFIL + NISOT=NISOT+1 + ELSE IF((IPR(2,IMT).EQ.0).AND.(.NOT.NOTG)) THEN + GO TO 45 + ELSE IF((IPR(2,IMT).EQ.0).AND.NOTG) THEN + WRITE(NSYSO,900) (ISHINA(I0,IMT),I0=1,3),NAMFIL + NISOT=NISOT+1 + ENDIF + ENDIF + 750 CONTINUE +*---- +* ADD NG CROSS SECTIONS. +*---- + DO 790 IMT=1,NBISO + IF(MASKI(IMT).AND.(IPR(3,IMT).EQ.0)) THEN + KPLIB=IPISO(IMT) ! set IMT-th isotope + CALL LCMGET(KPLIB,'NTOT0',VECT) + CALL LCMLEN(KPLIB,'SIGS00',LENGT,ITYLCM) + IF(LENGT.EQ.NGRO) THEN + CALL LCMGET(KPLIB,'SIGS00',SSS) + DO 760 IU=1,NGRO + VECT(IU)=VECT(IU)-SSS(IU) + 760 CONTINUE + ENDIF + IF(IPR(4,IMT).EQ.1) THEN + CALL LCMGET(KPLIB,'NFTOT',SSS) + DO 770 IU=1,NGRO + VECT(IU)=VECT(IU)-SSS(IU) + 770 CONTINUE + ENDIF + CALL LCMLEN(KPLIB,'N2N',LENGT,ITYLCM) + IF(LENGT.EQ.NGRO) THEN + CALL LCMGET(KPLIB,'N2N',SSS) + DO 780 IU=1,NGRO + VECT(IU)=VECT(IU)+SSS(IU) + 780 CONTINUE + ENDIF + CALL LCMPUT(KPLIB,'NG',NGRO,2,VECT) + ENDIF + 790 CONTINUE +*---- +* CLOSE THE APOLIB FILE. +*---- + IER=KDRCLS(NIN,1) + IF(IER.LT.0) THEN + WRITE(HSMG,'(37HLIBAPL: UNABLE TO CLOSE LIBRARY FILE ,A16,1H. + 1 )') NAMFIL + CALL XABORT(HSMG) + ENDIF + IF((IMPX.GT.0).AND.(NED.GT.0)) WRITE(NSYSO,1030) (HVEC(I), + 1 I=1,NED) + IF(NISOT.GT.0) CALL XABORT('LIBAPL: MISSING ISOTOPES') +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(LINF) + DEALLOCATE(SEFF,SCAT,DELTA,UUU,SS11,SS1,SSS1,SSS,PP1,PP,PHI, + 1 VTHER,PRI,SIGF,SIGA,SIG1,SIGS,VECT,AWR) + DEALLOCATE(ITYPRO,NISBEF,NISB,IPR) + RETURN +* + 860 FORMAT(1X,3A4,3H * ,9A4,2H *,I10,I12,2X,8I3) + 870 FORMAT(1H+,101X,10I3/(102X,10I3)) + 880 FORMAT(14X,2H* ,9A4,2H *) + 890 FORMAT(/35H PROCESSING APOLLO-1 LIBRARY NAMED ,A16,1H.// + 1 55X,14HSELF-SHIELDING,1X,8HTRANSFER/22H ISOTOPE..... LIBRARY , + 2 7HCONTENT,25(1H.),6X,4HDATA,6X,7HFILL-IN,2X,7HVECTOR , + 3 5HTYPES,11(1H.),1X,12HMATRIX TYPES,11(1H.)/1X,12(1H-),1X, + 4 40(1H-),1X,14(1H-),1X,8(1H-),1X,23(1H-),1X,23(1H-)) + 900 FORMAT(/27H LIBAPL: MATERIAL/ISOTOPE ',3A4,16H' IS MISSING ON , + 1 17HAPOLIB FILE NAME ,A8,1H.) + 910 FORMAT(//8H ISOTOPE,I12,5X,20HDIFFUSION MATRIX NB.,I3,5X, + 1 6HTYPE =,I3,5X,6HNEXU =,I3,5X,6HNEXV =,I3,5X,6HNEXW =,I4,5X, + 1 12HANISOTROPY =,I3/(1P,10E13.5)) + 920 FORMAT(//8H ISOTOPE,I12,5X,8HRECORD =,I3,5X,10HREACTION =,I3) + 930 FORMAT(1X,1P,10E13.5) + 940 FORMAT(/47H LIBAPL: UNABLE TO RECOVER THE GROUP STRUCTURE.) + 950 FORMAT(/53H LIBAPL: *** WARNING *** THE NUMBER OF THERMAL GROUPS, + 1 17H WAS CHANGED FROM,I4,3H TO,I4,1H.) + 960 FORMAT(30HLIBAPL: INSUFFICIENT VALUE OF ,A6,1H.) + 980 FORMAT(47HLIBAPL: *** WARNING *** INVALID VALUE OF PHI0 (,1P, + 1 E11.3,0P,10H) IN GROUP,I4,8H. ZNPHI=,1P E12.3,2X,5HSEIM=,E12.3, + 2 2X,5HISO=',3A4,1H') + 990 FORMAT(1X,I12,3H * ,9A4,2H *,21H SELF-SHIELDING DATA.,4X,8I4) + 1010 FORMAT(5X,I5,1P,8E15.5) + 1020 FORMAT(/5X,'GROUP',11X,'PHI0',10X,'SIGF0',10X,'SIGA0',10X, + 1 'SIGS0',10X,'DILUT',13X,'SB',12X,'ZNPHI') + 1030 FORMAT(/39H EXTRA REACTION EDITS FOUND ON APOLIB: ,5A7) + END diff --git a/Dragon/src/LIBBAS.f b/Dragon/src/LIBBAS.f new file mode 100644 index 0000000..ffb88a9 --- /dev/null +++ b/Dragon/src/LIBBAS.f @@ -0,0 +1,138 @@ +*DECK LIBBAS + SUBROUTINE LIBBAS(NISO,AT,AKT,AMT,T,IX,V,DV,NDTE,P,XS,X,E) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Scattering kernel based on the free gas model of Brown and St. John. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NISO number of terms in the model: +* NISO=1 : pure free gas model; +* NISO=2 : Brown and St. John model. +* AT potential microscopic cross section. +* AKT exponential constant in the model. Equal to zero for the +* pure free gas model. +* AMT isotope mass divided by neutron mass. +* T absolute temperature divided by 293.6K. +* IX number of thermal groups. +* V neutron velocities. +* DV used to transform velocity to energy. +* NDTE first dimension of matrix P. +* +*Parameters: output +* P scattering kernel. The first index is for secondary neutrons. +* XS scattering microscopic cross section. +* +*Parameters: scratch +* X temporary storage. +* E temporary storage. +* +*Reference: +* H. C. Honeck, 'The distribution of thermal neutrons in space and +* energy in reactor lattices. Part 1: theory', Nucl. Sci. Eng., 8, +* 193 (1960). +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NISO,IX,NDTE + REAL AT(NISO),AKT(NISO),AMT(NISO),T,V(IX),DV(IX),P(NDTE,IX), + 1 XS(IX),X(IX),E(IX) +*---- +* LOCAL VARIABLES +*---- + INTEGER I,N,J + REAL AM,BETS,BET,TAUS,TAU,ALPHA,THETA,ZETA,OMEG,CONST, + 1 CONST1,TEM,WA,WB,EA,EB,AFERF +* + DO 110 I=1,IX + XS(I)=0.0 + DO 100 J=1,IX + P(I,J)=0.0 + 100 CONTINUE + 110 CONTINUE + DO 500 N=1,NISO + IF(AT(N).EQ.0.0) GO TO 500 + AM=AMT(N) + BETS=AM/T + BET=SQRT(BETS) + DO 120 I=1,IX + X(I)=BET*V(I) + E(I)=X(I)*X(I) + 120 CONTINUE + TAUS=BETS/(BETS+AKT(N)) + TAU=SQRT(TAUS) + ALPHA=AKT(N)*TAUS/BETS + THETA=(AM+1.0)/(2.0*AM*TAU) + ZETA=TAU-THETA + OMEG=TAUS*(BETS+(AM+1.0)*AKT(N))/BETS + CONST=(AT(N)*TAU*TAUS*(AM+1.0)*(AM+1.0))/(4.0*AM*OMEG) + DO 400 I=1,IX + DO 300 J=I,IX + CONST1=CONST*X(I)/X(J) + WA=ALPHA*E(J) + TEM=0.0 + IF(WA.GE.50.0) GO TO 250 + EA=AFERF((THETA*X(I))+(ZETA*X(J)))+AFERF((THETA*X(I))-(ZETA*X(J))) + TEM=CONST1*EA*EXP(-WA) + 250 WB=(OMEG*E(I)-E(J))/AM + IF(WB.GE.50.0) GO TO 260 + EB=AFERF((THETA*X(J))-(ZETA*X(I)))-AFERF((ZETA*X(I))+(THETA*X(J))) + TEM=TEM+CONST1*EB*EXP(-WB) + 260 IF(TEM.LE.1.E-15) GO TO 350 + P(I,J)=TEM + 300 CONTINUE + 350 EA=TAU*X(I) + WA=ALPHA*E(I) + IF(WA.LT.50.0) GO TO 352 + WA=0.0 + GOTO 353 + 352 WA=EXP(-WA) + 353 EB=WA*AFERF(EA)*(EA+(0.5/EA)) + IF(E(I).LT.50.0) GO TO 355 + WB=0.0 + GOTO 356 + 355 WB=EXP(-E(I)) + 356 XS(I)=XS(I)+(AT(N)*TAUS*TAUS/BET)*(EB+0.5641896*WB) + 400 CONTINUE + 500 CONTINUE + DO 610 I=1,IX + E(I)=0.0 + WA=(V(I)*V(I))/T + IF(WA.GE.50.0) GO TO 610 + E(I)=V(I)*V(I)*EXP(-WA) + 610 CONTINUE + DO 630 I=1,IX + DO 620 J=I,IX + IF(E(I).LE.1.E-20) GO TO 620 + P(J,I)=P(I,J)*E(J)/E(I) + 620 CONTINUE + 630 CONTINUE + DO 650 J=1,IX + TEM=0.0 + DO 640 I=1,IX + TEM=TEM+P(I,J)*DV(I) + 640 CONTINUE + P(J,J)=((XS(J)-TEM)/DV(J))+P(J,J) + 650 CONTINUE + DO 690 I=1,IX + XS(I)=XS(I)/V(I) + DO 680 J=1,IX + P(I,J)=P(I,J)*DV(J)/V(I) + 680 CONTINUE + 690 CONTINUE + RETURN + END diff --git a/Dragon/src/LIBCAT.f b/Dragon/src/LIBCAT.f new file mode 100644 index 0000000..2eb4ea3 --- /dev/null +++ b/Dragon/src/LIBCAT.f @@ -0,0 +1,149 @@ +*DECK LIBCAT + SUBROUTINE LIBCAT (MAXNOR,NPAR,NDIL,DEMT,DEMP,IPRECI,LNORAJ, + 1 SIGERD,SEFFER,NOR,PROSIG,ERRBST) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the weights and base points for a principal cross-section +* type and the partial base points for NPAR partial reactions. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXNOR maximum order of a probability table. +* NPAR number of partial cross sections types. +* NDIL number of dilutions used to test the accuracy of the table. +* DEMT moments of the principal cross section. +* DEMP moments for each partial cross section. +* IPRECI accuracy criteria for the table (=1/=2/=3). +* LNORAJ algorithm flag (=.true.: find an order NOR.le.MAXNOR +* corresponding to accuracy IPRECI; =.false.: compute the +* table at order NOR. if this is impossible, try an order +* smaller than NOR). +* SIGERD list of dilutions used to test the accuracy of the table. +* SEFFER list of reference self-shielded cross sections corresponding +* to each cross-section type and each dilution. +* +*Parameters: input/output +* NOR input order of the table if LNORAJ=.false.and +* output order of the table. +* +*Parameters: output +* PROSIG probability table. +* PROSIG(inor,1): weights; +* PROSIG(inor,2): base points for the principal x-s; +* PROSIG(inor,3): base points for a partial x-s; +* etc. +* ERRBST probability table error. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXNOR,NPAR,NDIL,IPRECI,NOR + REAL SIGERD(NDIL),SEFFER(NPAR+2,NDIL),PROSIG(MAXNOR,2+NPAR), + 1 ERRBST + DOUBLE PRECISION DEMT(1-MAXNOR:MAXNOR), + 1 DEMP(-MAXNOR/2:(MAXNOR-1)/2,NPAR) + LOGICAL LNORAJ +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:,:) :: SEFF + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: PROSIC +* + EPS=0.2**(1+IPRECI) + IF(.NOT.LNORAJ) THEN +* COMPUTE A TABLE FOR AN IMPOSED VALUE OF NOR. + IF(NOR.GT.MAXNOR) CALL XABORT('LIBCAT: INVALID INPUT ORDER.') + 10 CALL ALPRTB(NOR,1-NOR,DEMT(1-NOR),IER,PROSIG(1,1),PROSIG(1,2)) + IF(IER.NE.0) THEN + NOR=NOR-1 + GO TO 10 + ENDIF + JINI=-NOR/2 + DO 20 IPAR=1,NPAR + CALL LIBMPA(NOR,JINI,PROSIG(1,1),PROSIG(1,2),DEMP(JINI,IPAR), + 1 PROSIG(1,IPAR+2)) + 20 CONTINUE + RETURN + ENDIF +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(PROSIC(MAXNOR,2+NPAR,MAXNOR),SEFF(NPAR+2,NDIL)) +*---- +* COMPUTE THE TABLE FOR EACH AVAILABLE ORDER. THE MAXIMUM ORDER IS +* LIMITED TO 10 TO AVOID NUMERICAL INSTABILITIES. +*---- + ERRBST=1.0E10 + DO 90 INOR=1,10 + CALL ALPRTB(INOR,1-INOR,DEMT(1-INOR),IER,PROSIC(1,1,INOR), + 1 PROSIC(1,2,INOR)) + IF(IER.NE.0) GO TO 90 + JINI=-INOR/2 + DO 30 IPAR=1,NPAR + CALL LIBMPA(INOR,JINI,PROSIC(1,1,INOR),PROSIC(1,2,INOR), + 1 DEMP(JINI,IPAR),PROSIC(1,IPAR+2,INOR)) + 30 CONTINUE +*---- +* COMPUTE THE SELF-SHIELDED CROSS SECTIONS FROM THE TABLE. +*---- + DO 70 IDIL=1,NDIL + DO 40 IPAR=1,NPAR+2 + SEFF(IPAR,IDIL)=0.0 + 40 CONTINUE + DO 55 IOR=1,INOR + ASTPD=SIGERD(IDIL)*PROSIC(IOR,1,INOR)/(PROSIC(IOR,2,INOR)+ + 1 SIGERD(IDIL)) + SEFF(1,IDIL)=SEFF(1,IDIL)+ASTPD + DO 50 IPAR=2,NPAR+2 + SEFF(IPAR,IDIL)=SEFF(IPAR,IDIL)+ASTPD*PROSIC(IOR,IPAR,INOR) + 50 CONTINUE + 55 CONTINUE + DO 60 IPAR=2,NPAR+2 + SEFF(IPAR,IDIL)=SEFF(IPAR,IDIL)/SEFF(1,IDIL) + 60 CONTINUE + 70 CONTINUE +*---- +* COMPUTE THE TABLE ACCURACY. +*---- + ERROR=0.0 + DO 85 IDIL=1,NDIL + DO 80 I=2,NPAR+2 + ERROR=MAX(ERROR,ABS(SEFF(I,IDIL)-SEFFER(I,IDIL))/ + 1 ABS(SEFFER(I,NDIL))) + 80 CONTINUE + 85 CONTINUE + IF(1.2*ERROR.LT.ERRBST) THEN + NOR=INOR + IF(ERROR.LT.EPS) THEN + ERRBST=ERROR + GO TO 100 + ENDIF + ERRBST=ERROR + ENDIF + 90 CONTINUE +*---- +* SELECT THE ORDER NOR TABLE. +*---- + 100 DO 115 IPAR=1,2+NPAR + DO 110 I=1,NOR + PROSIG(I,IPAR)=PROSIC(I,IPAR,NOR) + 110 CONTINUE + 115 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SEFF,PROSIC) + RETURN + END diff --git a/Dragon/src/LIBCMB.f b/Dragon/src/LIBCMB.f new file mode 100644 index 0000000..3b784c6 --- /dev/null +++ b/Dragon/src/LIBCMB.f @@ -0,0 +1,222 @@ +*DECK LIBCMB + SUBROUTINE LIBCMB(MAXMIX,MAXISO,NBISO,NEWISO,NNMIX,MIXCMB,VOLTOT, + > VOLFRA,DENMIX,ISONAM,ISONRF,SHINA,ISOMIX,HLIB, + > ILLIB,DENISO,TMPISO,LSHI,SNISO,SBISO,NTFG,NIR, + > GIR,MASKI,IEVOL,ITYP) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Combine mixtures by volume fraction. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input/output +* MAXMIX maximum value of nbmix. +* MAXISO maximum number of isotopes permitted. +* NBISO number of isotopes before combination. +* NEWISO number of isotopes after combination. +* NNMIX new mixture to create or modify. +* MIXCMB mixture to add. +* VOLTOT total volume fraction to date. +* VOLFRA volume fraction of current mixture. +* DENMIX density of each mixture. +* ISONAM name of isotopes. +* ISONRF reference name of isotopes. +* SHINA self-shielding name of isotopes. +* ISOMIX mix number of each isotope. +* HLIB isotope options. +* ILLIB xs library index for each isotope. +* DENISO density of isotopes. +* TMPISO temperature of isotopes. +* LSHI self-shielding flag. +* SNISO dilution cross section. +* SBISO dilution cross section used in Livolant-Jeanpierre +* normalization. +* NTFG number of thermal inelastic groups, +* NIR Goldstein-Cohen flag: +* use IR approximation for groups with index.ge.NIR; +* use library value if NIR=0. +* GIR Goldstein-Cohen IR parameter of each isotope. +* MASKI treat isotope logical. +* IEVOL depletion suppression flag (=1/2 to suppress/force depletion). +* ITYP type of isotope. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXMIX,MAXISO,NBISO,NEWISO,NNMIX,MIXCMB, + > ISONAM(3,MAXISO),ISONRF(3,MAXISO),ISOMIX(MAXISO), + > ILLIB(MAXISO),LSHI(MAXISO),NTFG(MAXISO),NIR(MAXISO), + > IEVOL(MAXISO),ITYP(MAXISO) + LOGICAL MASKI(MAXISO) + REAL VOLTOT,VOLFRA,DENMIX(MAXMIX),DENISO(MAXISO), + > TMPISO(MAXISO),SNISO(MAXISO),SBISO(MAXISO), + > GIR(MAXISO) + CHARACTER(LEN=12) SHINA(MAXISO) + CHARACTER(LEN=8) HLIB(MAXISO,4) + DOUBLE PRECISION TOTWPC +*---- +* LOCAL PARAMETERS +*---- + CHARACTER HSMG*131 +* + CMBVOL=VOLTOT+VOLFRA + IF(MIXCMB.EQ.NNMIX) GO TO 150 + RMAS1=1.0 + RMAS2=1.0 + IF(MIXCMB.EQ.0) THEN +*---- +* MIXTURE TO ADD IS VOID +*---- + IF(DENMIX(NNMIX).EQ.-1.0) THEN +*---- +* REDUCE ATOMIC DENSITY +*---- + RMAS1=VOLTOT/CMBVOL + ELSE +*---- +* REDUCE MIXTURE DENSITY BUT NOT WEIGHT PERCENT +*---- + DENMIX(NNMIX)=DENMIX(NNMIX)*VOLTOT/CMBVOL + ENDIF + ELSE +*---- +* MIXTURE TO ADD IS NOT VOID +*---- + IF(DENMIX(NNMIX).EQ.-1.0) THEN + IF(DENMIX(MIXCMB).EQ.-1.0) THEN +*---- +* REDUCE ATOMIC DENSITY +*---- + RMAS1=VOLTOT/CMBVOL + RMAS2=VOLFRA/CMBVOL + ELSE + IF(VOLTOT.GT.0.0) + > CALL XABORT('LIBCMB: CANNOT COMBINE MIXTURE WITH '// + > ' WEIGHT PERCENT AND ATOM CONTENTS') +*---- +* TRANSFER MIXTURE DENSITY WITH INITIAL WEIGHT PERCENT TO NEWISO +*---- + DENMIX(NNMIX)=DENMIX(MIXCMB) + ENDIF + ELSE + IF(DENMIX(MIXCMB).EQ.-1.0) + > CALL XABORT('LIBCMB: CANNOT COMBINE MIXTURE WITH '// + > ' WEIGHT PERCENT AND ATOM CONTENTS') +*---- +* REDUCE MIXTURE DENSITY AND WEIGHT PERCENT FOR OLD ISO +* TRANSFER MIXTURE DENSITY WITH REDUCED WEIGHT PERCENT TO NEWISO +*---- + RMAS1=VOLTOT*DENMIX(NNMIX) + RMAS2=VOLFRA*DENMIX(MIXCMB) + CMBMAS=RMAS1+RMAS2 + RMAS1=RMAS1/CMBMAS + RMAS2=RMAS2/CMBMAS + DENMIX(NNMIX)=CMBMAS/CMBVOL + ENDIF + ENDIF + NEWISO=NBISO +*---- +* RESET OLD DENSITIES +*---- + IF(VOLTOT.EQ.0.0) THEN + DO 90 ISO=1,NBISO + IF(ISOMIX(ISO).EQ.NNMIX) THEN + IF(MASKI(ISO)) THEN + WRITE(HSMG,'(15HLIBCMB: MIXTURE,I6,18H IS ALREADY DEFINE, + > 14HD FOR ISOTOPE ,3A4,1H.)') NNMIX,(ISONAM(I,ISO),I=1,3) + CALL XABORT(HSMG) + ENDIF + ISOMIX(ISO)=0 + ENDIF + 90 CONTINUE + ENDIF + IF(DENMIX(MIXCMB).EQ.-1.0) THEN + TOTWPC=1.0D0 + ELSE + TOTWPC=0.0D0 + DO ISO=1,NBISO + IF(ISOMIX(ISO).EQ.MIXCMB) THEN + TOTWPC=TOTWPC+DBLE(DENISO(ISO)) + ENDIF + ENDDO + TOTWPC=1.0D0/TOTWPC + ENDIF + DO 100 ISO=1,NBISO + IF(ISOMIX(ISO).EQ.NNMIX) THEN + DENISO(ISO)=DENISO(ISO)*RMAS1 + ENDIF + 100 CONTINUE + DO 110 ISO=1,NBISO + IF(ISOMIX(ISO).EQ.MIXCMB) THEN +*---- +* SCAN ISO IN NNMIX TO IDENTIFY IDENTICAL ISOTOPES +*---- + DO 111 JSO=1,NBISO + IF(ISOMIX(JSO).EQ.NNMIX) THEN + IF(ISONRF(1,JSO).EQ.ISONRF(1,ISO).AND. + > ISONRF(2,JSO).EQ.ISONRF(2,ISO)) THEN + IF(ISONAM(1,JSO).NE.ISONAM(1,ISO).OR. + > ISONAM(2,JSO).NE.ISONAM(2,ISO).OR. + > TMPISO(JSO) .NE.TMPISO(ISO) .OR. + > LSHI(JSO) .NE.LSHI(ISO) .OR. + > SNISO(JSO) .NE.SNISO(ISO) .OR. + > SBISO(JSO) .NE.SBISO(ISO) ) THEN + WRITE(HSMG,'(17HLIBCMB: ISOTOPES ,3A4,5H AND ,3A4, + > 18H CANNOT BE MERGED.)') (ISONAM(I,ISO),I=1,3), + > (ISONAM(I,JSO),I=1,3) + CALL XABORT(HSMG) + ENDIF + DENISO(JSO)=DENISO(JSO)+REAL(TOTWPC)*DENISO(ISO)*RMAS2 + GO TO 115 + ENDIF + ENDIF + 111 CONTINUE + ISO2=0 + DO 112 JSO=1,NBISO + IF(ISOMIX(JSO).EQ.0) THEN + ISO2=JSO + GO TO 113 + ENDIF + 112 CONTINUE + NEWISO=NEWISO+1 + IF(NEWISO.GT.MAXISO) CALL XABORT('LIBCMB: MAXISO OVERFLOW.') + ISO2=NEWISO + 113 ISOMIX(ISO2)=NNMIX + DENISO(ISO2)=REAL(TOTWPC)*DENISO(ISO)*RMAS2 + TMPISO(ISO2)=TMPISO(ISO) + NTFG(ISO2)=NTFG(ISO) + NIR(ISO2)=NIR(ISO) + GIR(ISO2)=GIR(ISO) + SNISO(ISO2)=SNISO(ISO) + SBISO(ISO2)=SBISO(ISO) + LSHI(ISO2)=LSHI(ISO) + MASKI(ISO2)=.TRUE. + IEVOL(ISO2)=IEVOL(ISO) + ITYP(ISO2)=ITYP(ISO) + DO 120 ITC=1,3 + ISONAM(ITC,ISO2)=ISONAM(ITC,ISO) + ISONRF(ITC,ISO2)=ISONRF(ITC,ISO) + 120 CONTINUE + SHINA(ISO2)=SHINA(ISO) + DO 140 ILC=1,4 + HLIB(ISO2,ILC)=HLIB(ISO,ILC) + 140 CONTINUE + ILLIB(ISO2)=ILLIB(ISO) + ENDIF + 115 CONTINUE + 110 CONTINUE + 150 NBISO=NEWISO + VOLTOT=CMBVOL + RETURN + END diff --git a/Dragon/src/LIBCOM.f b/Dragon/src/LIBCOM.f new file mode 100644 index 0000000..b7418e4 --- /dev/null +++ b/Dragon/src/LIBCOM.f @@ -0,0 +1,93 @@ +*DECK LIBCOM + SUBROUTINE LIBCOM(NFS,DELTA,SIGAF,SIGTF,NORA,NOR,COMOM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute a set of comoments ((SIGA**P)*(SIGT**Q)). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NFS number of fine energy groups. +* DELTA lethargy widths of the fine groups. +* SIGAF microscopic absorption x-sections in the fine groups. +* SIGTF microscopic total x-sections in the fine groups. +* NORA related to the number of absorption moments to preserve. +* NOR related to the number of total moments to preserve: +* (2-NORA)/2 <= P <= (NORA+1)/2 and (2-NOR)/2 <= Q <= (NOR+1)/2. +* +*Parameters: output +* COMOM comoments. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NFS,NORA,NOR + REAL DELTA(NFS),SIGAF(NFS),SIGTF(NFS) + DOUBLE PRECISION COMOM(NORA,NOR) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION DEL,T,T0,SIGT,SIGA + INTEGER PNOR,QNOR +* + DEL=0.0D0 + DO 15 PNOR=1,NORA + DO 10 QNOR=1,NOR + COMOM(PNOR,QNOR)=0.0D0 + 10 CONTINUE + 15 CONTINUE +* + DO 80 IGF=1,NFS + DELF=DELTA(IGF) + SIGT=MAX(0.001,SIGTF(IGF)) + SIGA=MAX(0.001,SIGAF(IGF)) + DEL=DEL+DELF + T0=DELF + DO 40 PNOR=MAX(1,NORA/2),NORA + T=T0 + DO 20 QNOR=MAX(1,NOR/2),NOR + COMOM(PNOR,QNOR)=COMOM(PNOR,QNOR)+T + T=T*SIGT + 20 CONTINUE + T=T0/SIGT + DO 30 QNOR=NOR/2-1,1,-1 + COMOM(PNOR,QNOR)=COMOM(PNOR,QNOR)+T + T=T/SIGT + 30 CONTINUE + T0=T0*SIGA + 40 CONTINUE + T0=DELF/SIGA + DO 70 PNOR=NORA/2-1,1,-1 + T=T0 + DO 50 QNOR=MAX(1,NOR/2),NOR + COMOM(PNOR,QNOR)=COMOM(PNOR,QNOR)+T + T=T*SIGT + 50 CONTINUE + T=T0/SIGT + DO 60 QNOR=NOR/2-1,1,-1 + COMOM(PNOR,QNOR)=COMOM(PNOR,QNOR)+T + T=T/SIGT + 60 CONTINUE + T0=T0/SIGA + 70 CONTINUE + 80 CONTINUE +* + IF(DEL.EQ.0.0) CALL XABORT('LIBCOM: ALGORITHM FAILURE.') + DO 100 PNOR=1,NORA + DO 90 QNOR=1,NOR + COMOM(PNOR,QNOR)=COMOM(PNOR,QNOR)/DEL + 90 CONTINUE + 100 CONTINUE + RETURN + END diff --git a/Dragon/src/LIBCON.f b/Dragon/src/LIBCON.f new file mode 100644 index 0000000..8830a11 --- /dev/null +++ b/Dragon/src/LIBCON.f @@ -0,0 +1,118 @@ +*DECK LIBCON + SUBROUTINE LIBCON(IPLIB,IMX,NBISO,ISOMIX,DENISO,DENMIX,IN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Convert weight percent to atomic density. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPLIB pointer to the internal library. +* IMX mixture index to process. +* NBISO number of isotopes present in the calculation domain. +* ISOMIX mix number of each isotope. +* IN type of conversion: +* =1 conversion of wgt% to nb atoms with denmix; +* =2 conversion of nb atoms to wgt% and denmix. +* +*Parameters: input/output +* DENISO number density (if IN=1) or weight percent (if IN=2) for +* isotopes present in mixture IMX on input. On optput, +* number density. +* DENMIX mixture density g*cm**(-3) (if IN=2). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + INTEGER IMX,NBISO,ISOMIX(NBISO),IN + REAL DENISO(NBISO),DENMIX +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) KPLIB + DOUBLE PRECISION XDRCST,AVCON + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO +*---- +* INTERNAL PARAMETERS +*---- + PARAMETER (IOUT=6) +*------ +* COMPUTE NUMBER DENSITIES FOR ISOTOPES +*------ + AVCON=1.0D-24*XDRCST('Avogadro','N/moles') + > /XDRCST('Neutron mass','amu') + IF(IN.EQ.1) THEN + IF(DENMIX.EQ.-1.0) CALL XABORT('LIBCON: DENMIX NOT DEFINED') + TWPC=0.0 + DO 120 ISO=1,NBISO + IF(ISOMIX(ISO).EQ.IMX) TWPC=DENISO(ISO)+TWPC + 120 CONTINUE + IF(TWPC.EQ.0.0) THEN + IF(DENMIX.EQ.0.0) THEN + RETURN + ELSE + CALL XABORT('LIBCON: A MIXTURE OF DENSITY > 0.0 '// + > 'HAS ALL ITS ISOTOPIC WEIGHT PERCENT = 0.0') + ENDIF + ENDIF + WMIX=DENMIX*REAL(AVCON)/TWPC + IF(NBISO.GT.0) THEN + ALLOCATE(IPISO(NBISO)) + CALL LIBIPS(IPLIB,NBISO,IPISO) + DO 130 ISO=1,NBISO + IF(ISOMIX(ISO).EQ.IMX) THEN + KPLIB=IPISO(ISO) ! set ISO-th isotope + CALL LCMGET(KPLIB,'AWR',AWRISO) + IF(AWRISO.GT.0.0) THEN + DENISO(ISO)=DENISO(ISO)*WMIX/AWRISO + ELSE + DENISO(ISO)=0.0 + ENDIF + ENDIF + 130 CONTINUE + DEALLOCATE(IPISO) + ENDIF + ELSE IF(IN.EQ.2) THEN + CALL LCMLEN(IPLIB,'ISOTOPESUSED',ILONG,ITYLCM) +*------ +* COMPUTE MIXTURE DENSITIES AND ISOTOPIC WEIGHT PERCENTS +* (NORMALIZED TO 100.) +*------ + DENMIX=0.0 + IF((NBISO.GT.0).AND.(NBISO.LE.ILONG/3)) THEN + ALLOCATE(IPISO(NBISO)) + CALL LIBIPS(IPLIB,NBISO,IPISO) + DO 220 ISO=1,NBISO + IF(ISOMIX(ISO).EQ.IMX) THEN + KPLIB=IPISO(ISO) ! set ISO-th isotope + CALL LCMGET(KPLIB,'AWR',AWRISO) + DENISO(ISO)=DENISO(ISO)*AWRISO/REAL(AVCON) + DENMIX=DENMIX+DENISO(ISO) + ENDIF + 220 CONTINUE + DEALLOCATE(IPISO) + ENDIF + IF(DENMIX.NE.0.0) THEN + DO 230 ISO=1,NBISO + IF(ISOMIX(ISO).EQ.IMX) + > DENISO(ISO)=100.*DENISO(ISO)/DENMIX + 230 CONTINUE + ENDIF + ELSE + CALL XABORT('LIBCON: INVALID *IN* VALUE') + ENDIF + RETURN + END diff --git a/Dragon/src/LIBCOR.f b/Dragon/src/LIBCOR.f new file mode 100644 index 0000000..2fe872d --- /dev/null +++ b/Dragon/src/LIBCOR.f @@ -0,0 +1,177 @@ +*DECK LIBCOR + SUBROUTINE LIBCOR (IPLIB,NGRO,ISOT,JSOT,HNAMIS1,HNAMIS2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the correlation information between a pair of resonant +* isotopes for the CALENDF method. +* +*Copyright: +* Copyright (C) 2003 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the internal library (L_LIBRARY signature). +* NGRO number of energy groups. +* ISOT position in list of the first isotope. +* JSOT position in list of the second isotope. +* HNAMIS1 local name of the first isotope: +* HNAMIS1(1:8) is the local isotope name; +* HNAMIS1(9:12) is a suffix function of the mixture index. +* HNAMIS2 local name of the second isotope +* HNAMIS2(1:8) is the local isotope name; +* HNAMIS2(9:12) is a suffix function of the mixture index. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + INTEGER NGRO,ISOT,JSOT + CHARACTER HNAMIS1*12,HNAMIS2*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER(MAXNPT=12) + TYPE(C_PTR) JPLIB,IP1,IP2,JP1,JP2,KP1,KP2 + REAL SIGQT1(MAXNPT),SIGQT2(MAXNPT),WSLD1(MAXNPT**2), + 1 WSLD2(MAXNPT**2) + DOUBLE PRECISION SUMA1,SUMB1,SUMA2,SUMB2 + INTEGER, ALLOCATABLE, DIMENSION(:) :: NFS1,NFS2 + REAL, ALLOCATABLE, DIMENSION(:) :: TBIN1,TBIN2,EBIN,DBIN,PROB1, + 1 PROB2 + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: COMOM +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NFS1(NGRO),NFS2(NGRO)) +* + JPLIB=LCMGID(IPLIB,'ISOTOPESLIST') + IP1=LCMGIL(JPLIB,ISOT) ! set ISOT-th isotope + IP2=LCMGIL(JPLIB,JSOT) ! set JSOT-th isotope + CALL LCMLEN(IP1,'BIN-NFS',LENGT1,ITYLCM) + CALL LCMLEN(IP2,'BIN-NFS',LENGT2,ITYLCM) + IF((LENGT1.EQ.0).OR.(LENGT1.NE.LENGT2)) CALL XABORT('LIBCOR: UNA' + 1 //'BLE TO FIND CONSISTENT BIN TYPE INFORMATION.') + CALL LCMGET(IP1,'BIN-NFS',NFS1) + CALL LCMGET(IP2,'BIN-NFS',NFS2) + LBIN=0 + IGRMIN=1 + IGRMAX=NGRO + DO 10 IGRP=NGRO,1,-1 + IF(NFS1(IGRP).NE.NFS2(IGRP)) CALL XABORT('INVALID BIN INFO.') + IF((IGRMAX.EQ.IGRP).AND.(NFS1(IGRP).EQ.0)) IGRMAX=IGRP-1 + LBIN=LBIN+NFS1(IGRP) + 10 CONTINUE + DO 20 IGRP=1,NGRO + IF((IGRMIN.EQ.IGRP).AND.(NFS1(IGRP).EQ.0)) IGRMIN=IGRP+1 + 20 CONTINUE + ALLOCATE(TBIN1(LBIN),TBIN2(LBIN),EBIN(LBIN+1),DBIN(LBIN)) + CALL LCMGET(IP1,'BIN-ENERGY',EBIN) + CALL LCMGET(IP1,'BIN-NTOT0',TBIN1) + CALL LCMGET(IP2,'BIN-NTOT0',TBIN2) + CALL LCMSIX(IP1,'PT-TABLE',1) + CALL LCMSIX(IP2,'PT-TABLE',1) +*--- +* LOOP OVER THE RESONANT ENERGY GROUPS. +*--- + LBIN=0 + JP1=LCMGID(IP1,'GROUP-PT') + JP2=LCMGID(IP2,'GROUP-PT') + DO 130 IGRP=IGRMIN,IGRMAX + SUMA1=0.0D0 + SUMB1=0.0D0 + SUMA2=0.0D0 + SUMB2=0.0D0 + DO 30 IGF=1,NFS1(IGRP) + SIGTA=MAX(0.002,TBIN1(LBIN+IGF)) + SIGTB=MAX(0.002,TBIN2(LBIN+IGF)) + DELM=LOG(EBIN(LBIN+IGF)/EBIN(LBIN+IGF+1)) + SUMA1=SUMA1+TBIN1(LBIN+IGF)*DELM + SUMB1=SUMB1+SIGTA*DELM + SUMA2=SUMA2+TBIN2(LBIN+IGF)*DELM + SUMB2=SUMB2+SIGTB*DELM + TBIN1(LBIN+IGF)=SIGTA + TBIN2(LBIN+IGF)=SIGTB + DBIN(LBIN+IGF)=DELM + 30 CONTINUE + DO 40 IGF=1,NFS1(IGRP) + TBIN1(LBIN+IGF)=TBIN1(LBIN+IGF)*REAL(SUMA1/SUMB1) + TBIN2(LBIN+IGF)=TBIN2(LBIN+IGF)*REAL(SUMA2/SUMB2) + 40 CONTINUE +* + CALL LCMLEL(JP1,IGRP,N1,ITYLCM) + CALL LCMLEL(JP2,IGRP,N2,ITYLCM) + IF((N1.EQ.0).OR.(N2.EQ.0)) GO TO 120 + KP1=LCMGIL(JP1,IGRP) + KP2=LCMGIL(JP2,IGRP) + CALL LCMLEN(KP1,'SIGQT-SIGS',NQT1,ITYLCM) + CALL LCMLEN(KP2,'SIGQT-SIGS',NQT2,ITYLCM) + CALL LCMLEN(KP1,'PROB-TABLE',NQT10,ITYLCM) + CALL LCMLEN(KP2,'PROB-TABLE',NQT20,ITYLCM) + ALLOCATE(PROB1(NQT10),PROB2(NQT20)) + CALL LCMGET(KP1,'PROB-TABLE',PROB1) + CALL LCMGET(KP2,'PROB-TABLE',PROB2) + DO 50 I=1,NQT1 + SIGQT1(I)=PROB1(MAXNPT+I) + 50 CONTINUE + DO 60 I=1,NQT2 + SIGQT2(I)=PROB2(MAXNPT+I) + 60 CONTINUE +* + ALLOCATE(COMOM(NQT1*NQT2)) + CALL LIBCOM(NFS1(IGRP),DBIN(LBIN+1),TBIN1(LBIN+1), + 1 TBIN2(LBIN+1),NQT1,NQT2,COMOM) + CALL LIBOMG(NQT1,1-NQT1/2,SIGQT1,NQT2,1-NQT2/2,SIGQT2, + 1 COMOM,WSLD1) + DEALLOCATE(COMOM) +*--- +* CHECK NORMALIZATION OF THE CORRELATED WEIGHT MATRIX. +*--- + DO 80 I=1,NQT1 + SUM=0.0 + DO 70 J=1,NQT2 + SUM=SUM+WSLD1((J-1)*NQT1+I) + 70 CONTINUE + IF(ABS(SUM-PROB1(I)).GT.1.0E-4) THEN + CALL XABORT('LIBCOR: BAD NORMALIZATION EXCEPTION(1).') + ENDIF + 80 CONTINUE + DO 100 I=1,NQT2 + SUM=0.0 + DO 90 J=1,NQT1 + SUM=SUM+WSLD1((I-1)*NQT1+J) + 90 CONTINUE + IF(ABS(SUM-PROB2(I)).GT.1.0E-4) THEN + CALL XABORT('LIBCOR: BAD NORMALIZATION EXCEPTION(2).') + ENDIF + 100 CONTINUE + DEALLOCATE(PROB2,PROB1) +* + CALL LCMPUT(KP1,HNAMIS2,NQT1*NQT2,2,WSLD1) + DO 115 I=1,NQT1 + DO 110 J=1,NQT2 + WSLD2((I-1)*NQT2+J)=WSLD1((J-1)*NQT1+I) + 110 CONTINUE + 115 CONTINUE + CALL LCMPUT(KP2,HNAMIS1,NQT2*NQT1,2,WSLD2) + 120 LBIN=LBIN+NFS1(IGRP) + 130 CONTINUE +* + CALL LCMSIX(IP2,' ',2) + CALL LCMSIX(IP1,' ',2) + DEALLOCATE(DBIN,EBIN,TBIN2,TBIN1) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(NFS2,NFS1) + RETURN + END diff --git a/Dragon/src/LIBCOV.f b/Dragon/src/LIBCOV.f new file mode 100644 index 0000000..f09dad6 --- /dev/null +++ b/Dragon/src/LIBCOV.f @@ -0,0 +1,57 @@ +*DECK LIBCOV + SUBROUTINE LIBCOV(TEXT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Convert a lower-case character variable to upper case. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* TEXT variable to be converted. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER*(*) TEXT +* + DO 10 I=1,LEN(TEXT) + IF(TEXT(I:I).EQ.'a') TEXT(I:I)='A' + IF(TEXT(I:I).EQ.'b') TEXT(I:I)='B' + IF(TEXT(I:I).EQ.'c') TEXT(I:I)='C' + IF(TEXT(I:I).EQ.'d') TEXT(I:I)='D' + IF(TEXT(I:I).EQ.'e') TEXT(I:I)='E' + IF(TEXT(I:I).EQ.'f') TEXT(I:I)='F' + IF(TEXT(I:I).EQ.'g') TEXT(I:I)='G' + IF(TEXT(I:I).EQ.'h') TEXT(I:I)='H' + IF(TEXT(I:I).EQ.'i') TEXT(I:I)='I' + IF(TEXT(I:I).EQ.'j') TEXT(I:I)='J' + IF(TEXT(I:I).EQ.'k') TEXT(I:I)='K' + IF(TEXT(I:I).EQ.'l') TEXT(I:I)='L' + IF(TEXT(I:I).EQ.'m') TEXT(I:I)='M' + IF(TEXT(I:I).EQ.'n') TEXT(I:I)='N' + IF(TEXT(I:I).EQ.'o') TEXT(I:I)='O' + IF(TEXT(I:I).EQ.'p') TEXT(I:I)='P' + IF(TEXT(I:I).EQ.'q') TEXT(I:I)='Q' + IF(TEXT(I:I).EQ.'r') TEXT(I:I)='R' + IF(TEXT(I:I).EQ.'s') TEXT(I:I)='S' + IF(TEXT(I:I).EQ.'t') TEXT(I:I)='T' + IF(TEXT(I:I).EQ.'u') TEXT(I:I)='U' + IF(TEXT(I:I).EQ.'v') TEXT(I:I)='V' + IF(TEXT(I:I).EQ.'w') TEXT(I:I)='W' + IF(TEXT(I:I).EQ.'x') TEXT(I:I)='X' + IF(TEXT(I:I).EQ.'y') TEXT(I:I)='Y' + IF(TEXT(I:I).EQ.'z') TEXT(I:I)='Z' + 10 CONTINUE + RETURN + END diff --git a/Dragon/src/LIBCTL.f b/Dragon/src/LIBCTL.f new file mode 100644 index 0000000..24d7a3e --- /dev/null +++ b/Dragon/src/LIBCTL.f @@ -0,0 +1,475 @@ +*DECK LIBCTL + SUBROUTINE LIBCTL (MAXMIX,MAXISO,IPLIB,IPLIBX,INDREC,IMAC,ISOADD, + 1 NDEPL,IMPX,NBISO,NBMIX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Catenate two microscopic cross section libraries. +* +*Copyright: +* Copyright (C) 2024 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXMIX maximum value of NBMIX. +* MAXISO maximum number of isotopes permitted. +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* IPLIBX pointer to a read-only microscopic cross section library +* (L_LIBRARY signature) to catenate. +* INDREC type of action: +* =1 a new microlib is created; =2 the microlib is updated. +* IMAC macrolib construction flag: +* =0 do not compute an embedded macrolib; +* =1 compute an embedded macrolib. +* ISOADD flag to complete the depletion chain: +* =0 complete; =1 do not complete. +* NDEPL number of depleting isotopes (used by EVO:). +* IMPX print flag. +* +*Parameters: output +* NBISO number of isotopes present in the calculation domain. +* NBMIX number of mixtures defined in the library. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB,IPLIBX + INTEGER MAXMIX,MAXED,MAXISO,INDREC,IMAC,ISOADD,NDEPL,IMPX,NBISO +*---- +* LOCAL PARAMETERS +*---- + PARAMETER (IOUT=6,NSTATE=40,MAXED=50,MAXLIB=20) + INTEGER ISTATE(NSTATE) + REAL TMPDAY(3) + DOUBLE PRECISION DBLLIR + LOGICAL EMPTY,LCM + CHARACTER HSMG*131,CARLIR*12,HSIGN*12,TEXT12*12 + TYPE(C_PTR) JPLIB,KPLIB,KPLIB2 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ISOMIX,NTFG,LSHI,NIR, + 1 IEVOL,ITYP,ILLIB,KGAS,ISOMIX2,NTFG2,LSHI2,NIR2,IEVOL2,ITYP2, + 2 ILLIB2,KGAS2,LOCUPD + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISONAM,ISONRF,ISONAM2, + > ISONRF2 + REAL, ALLOCATABLE, DIMENSION(:) :: DENISO,DENMIX,TMPISO,SNISO, + > SBISO,GIR,DENISO2,TMPISO2,SNISO2,SBISO2,GIR2,DENMIX2,ENERGY + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:,:) :: HLIB,HLIB2 + CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: SHINA,SHINA2 + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HVECT,HVECT2 + CHARACTER(LEN=64), ALLOCATABLE, DIMENSION(:) :: HNAME,HNAME2 + LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASK,MASKI,MASKL,MASKI2 + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: JPISO2 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(ISONAM(3,MAXISO),ISONRF(3,MAXISO),ISOMIX(MAXISO), + > NTFG(MAXISO),LSHI(MAXISO),NIR(MAXISO),IEVOL(MAXISO), + > ITYP(MAXISO),ILLIB(MAXISO),KGAS(MAXMIX),LOCUPD(MAXMIX)) + ALLOCATE(SHINA(MAXISO),HLIB(MAXISO,4),HVECT(MAXED), + > HNAME(MAXLIB)) + ALLOCATE(DENISO(MAXISO),TMPISO(MAXISO),SNISO(MAXISO), + > SBISO(MAXISO),GIR(MAXISO),DENMIX(MAXMIX)) + ALLOCATE(MASKI(MAXISO),MASK(MAXMIX)) +*---- +* RECOVER FIRST MICROLIB +*---- + IF((INDREC.EQ.2).AND.(NBISO.GT.0)) THEN +* THE LIBRARY IS UPDATED. READ OLD LIBRARY INFORMATION. + CALL LIBINF(IPLIB,MAXISO,MAXLIB,MAXED,MAXMIX,NBISO,NGRO,NL, + 1 ITRANC,NLIB,NCOMB,NEDMAC,NBMIX,ISONAM,ISONRF,ISOMIX,DENISO, + 2 TMPISO,SHINA,SNISO,SBISO,NTFG,LSHI,GIR,NIR,MASKI,HLIB,IEVOL, + 3 ITYP,ILLIB,KGAS,DENMIX,HVECT,HNAME) + ELSE + NBISO=0 + NGRO=0 + NL=0 + ITRANC=-999 + NLIB=0 + NEDMAC=0 + NCOMB=0 + NEDMAC=0 + NBMIX=0 + DENMIX(:MAXMIX)=-1.0 + ENDIF +*---- +* RECOVER A READ-ONLY MICROLIB +*---- + IF(C_ASSOCIATED(IPLIBX)) THEN + CALL LCMINF(IPLIBX,CARLIR,TEXT12,EMPTY,ILCMLN,LCM) + CALL LCMGTC(IPLIBX,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_LIBRARY') THEN + CALL XABORT('LIBCTL: SIGNATURE OF '//CARLIR//' IS '//HSIGN// + 1 '. L_LIBRARY EXPECTED.') + ENDIF + CALL LCMGET(IPLIBX,'STATE-VECTOR',ISTATE) + NBMIX2=ISTATE(1) + NBISO2=ISTATE(2) + NLIB2=ISTATE(8) + NEDMAC2=ISTATE(13) + IF((NGRO.GT.0).AND.(ISTATE(3).NE.NGRO)) THEN + WRITE(HSMG,'(44HLIBCTL: THE RHS MICROLIB HAS AN INCOMPATIBLE, + 1 26H NUMBER OF ENERGY GROUPS (,I5,4H VS ,I5,2H).)') ISTATE(3), + 2 NGRO + CALL XABORT(HSMG) + ENDIF + NGRO=ISTATE(3) + IF((ITRANC.GT.0).AND.(ISTATE(5).NE.ITRANC)) THEN + WRITE(HSMG,'(44HLIBCTL: THE RHS MICROLIB HAS AN INCOMPATIBLE, + 1 23H TRANSPORT CORRECTION (,I5,4H VS ,I5,2H).)') ISTATE(5), + 2 ITRANC + CALL XABORT(HSMG) + ENDIF + ITRANC=ISTATE(5) + ALLOCATE(ISONAM2(3,NBISO2),ISONRF2(3,NBISO2),ISOMIX2(NBISO2), + > NTFG2(NBISO2),LSHI2(NBISO2),NIR2(NBISO2),IEVOL2(NBISO2), + > ITYP2(NBISO2),ILLIB2(NBISO2),KGAS2(NBMIX2)) + ALLOCATE(SHINA2(NBISO2),HLIB2(NBISO2,4),HVECT2(MAXED), + > HNAME2(MAXLIB)) + ALLOCATE(DENISO2(NBISO2),TMPISO2(NBISO2),SNISO2(NBISO2), + > SBISO2(NBISO2),GIR2(NBISO2),DENMIX2(MAXMIX),ENERGY(NGRO+1)) + ALLOCATE(MASKI2(NBISO2)) + ALLOCATE(JPISO2(NBISO2)) + CALL LCMGET(IPLIBX,'ENERGY',ENERGY) + CALL LCMPUT(IPLIB,'ENERGY',NGRO+1,2,ENERGY) + CALL LIBINF(IPLIBX,NBISO2,MAXLIB,MAXED,MAXMIX,NBISO2,NGRO,NL2, + 1 ITRANC,NLIB2,NCOMB2,NEDMAC2,NBMIX2,ISONAM2,ISONRF2,ISOMIX2, + 2 DENISO2,TMPISO2,SHINA2,SNISO2,SBISO2,NTFG2,LSHI2,GIR2,NIR2, + 3 MASKI2,HLIB2,IEVOL2,ITYP2,ILLIB2,KGAS2,DENMIX2,HVECT2,HNAME2) + JPLIB=LCMLID(IPLIB,'ISOTOPESLIST',MAXISO) + CALL LIBIPS(IPLIBX,NBISO2,JPISO2) +*---- +* ADD ENTRIES INTO HVECT2 AND HNAME +*---- + DO IED=1,NEDMAC2 + DO JED=1,NEDMAC + IF(HVECT2(IED).EQ.HVECT(JED)) GO TO 40 + ENDDO + NEDMAC=NEDMAC+1 + IF(NEDMAC.GT.MAXED) CALL XABORT('LIBCTL: MAXED OVERFLOW(2).') + HVECT(NEDMAC)=HVECT2(IED) + 40 CONTINUE + ENDDO + DO ILIB=1,NLIB2 + DO JLIB=1,NLIB + IF(HNAME2(ILIB).EQ.HNAME(JLIB)) GO TO 45 + ENDDO + NLIB=NLIB+1 + IF(NLIB.GT.MAXLIB) CALL XABORT('LIBCTL: MAXLIB OVERFLOW(2).') + HNAME(NLIB)=HNAME2(ILIB) + 45 CONTINUE + ENDDO +*---- +* READ GROUP (descmix2) +*---- + LOCUPD(:MAXMIX)=0 + NNMIX=0 + 60 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + 70 IF(ITYPLU.NE.3) CALL XABORT('LIBCTL: CHARACTER DATA EXPECTED.') + IF(CARLIR.EQ.';') THEN + GO TO 80 + ELSE IF(CARLIR(1:3).EQ.'MIX') THEN + CALL REDGET(ITYPLU,NNMIX,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE. 1) CALL XABORT('LIBCTL: MIXTURE TO UPDATE MUST' + > //' BE GIVEN.') + IF(NNMIX.GT.MAXMIX) THEN + CALL XABORT('LIBCTL: MAXMIX OVERFLOW.') + ELSE IF(NNMIX.LE.0) THEN + CALL XABORT('LIBCTL: MIX NUMBER.LE.0.') + ENDIF + NBMIX=MAX(NBMIX,NNMIX) + LOCUPD(NNMIX)=NNMIX + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.1) THEN + IF(INTLIR.LE.0 .OR.INTLIR.GT.NBMIX2) THEN + CALL XABORT('LIBCTL: RHS NBMIX OVERFLOW.') + ENDIF + LOCUPD(NNMIX)=INTLIR + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + ENDIF + DENMIX(NNMIX)=DENMIX2(LOCUPD(NNMIX)) + IF(ITYPLU.EQ.2) THEN + IF(DENMIX(NNMIX).EQ.-1.0) THEN + CALL LIBCON(IPLIBX,NNMIX,NBISO2,ISOMIX2,DENISO2, + > DENMIX(NNMIX),2) + ENDIF + DENMIX(NNMIX)=REALIR + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + ENDIF + GO TO 70 + ELSE IF(CARLIR(1:3).EQ.'ALL') THEN + DO ISO=1,NBISO2 + NNMIX=ISOMIX2(ISO) + NBMIX=MAX(NBMIX,NNMIX) + LOCUPD(NNMIX)=NNMIX + ENDDO + ELSE + WRITE(HSMG,'(16HLIBCTL: KEYWORD ,A,20H IS NOT IMPLEMENTED.)') + > TRIM(CARLIR) + CALL XABORT(HSMG) + ENDIF + GO TO 60 +*---- +* CATENATE LIBRARIES +*---- + 80 NL=MAX(NL,NL2) + MIXTURE: DO NNMIX=1,NBMIX + IF(LOCUPD(NNMIX).EQ.0) CYCLE + DO ISO=1,NBISO + IF(ISOMIX(ISO).EQ.NNMIX) THEN + WRITE(HSMG,'(15HLIBCTL: MIXTURE,I8,18H IS ALREADY DEFINE, + > 14HD FOR ISOTOPE ,3A4,1H.)') NNMIX,(ISONAM(I,ISO),I=1,3) + WRITE(6,'(1X,A)') TRIM(HSMG) + CYCLE MIXTURE + ENDIF + ENDDO + KGAS(NNMIX)=KGAS2(LOCUPD(NNMIX)) + OUTER: DO ISO2=1,NBISO2 + IF(ISOMIX2(ISO2).NE.LOCUPD(NNMIX)) CYCLE + NBISO=NBISO+1 + IF(NBISO.GT.MAXISO) THEN + WRITE(6,'(33H LIBCTL: MAXISO OVERFLOW (MAXISO=,I7,4H ISO, + > 18HTOPES PER MIXTURE=,I7,2H).)') MAXISO,1+MAXISO/NBMIX + CALL XABORT(HSMG) + ENDIF + ISOMIX(NBISO)=NNMIX + DENISO(NBISO)=DENISO2(ISO2) + TMPISO(NBISO)=TMPISO2(ISO2) + NIR(NBISO)=NIR2(ISO2) + GIR(NBISO)=GIR2(ISO2) + IEVOL(NBISO)=IEVOL2(ISO2) + ITYP(NBISO)=ITYP2(ISO2) + SNISO(NBISO)=SNISO2(ISO2) + SBISO(NBISO)=SBISO2(ISO2) + ISONAM(:3,NBISO)=ISONAM2(:3,ISO2) + ISONRF(:3,NBISO)=ISONRF2(:3,ISO2) + HLIB(NBISO,:4)=HLIB2(ISO2,:4) + ILLIB(NBISO)=ILLIB2(ISO2) + LSHI(NBISO)=LSHI2(ISO2) + SHINA(NBISO)=SHINA2(ISO2) + NTFG(NBISO)=NTFG2(ISO2) + MASKI(NBISO)=.FALSE. + DO JSO=1,NBISO-1 + IF((ISONAM(1,JSO).EQ.ISONAM(1,NBISO)).AND. + 1 (ISONAM(2,JSO).EQ.ISONAM(2,NBISO)).AND. + 2 (ISONAM(3,JSO).EQ.ISONAM(3,NBISO))) CYCLE OUTER + ENDDO + MASKI(NBISO)=.TRUE. + KPLIB2=JPISO2(ISO2) ! set ISO2-th isotope + IF(.NOT.C_ASSOCIATED(KPLIB2)) THEN + WRITE(HSMG,'(17HLIBCTL: ISOTOPE '',3A4,7H'' (ISO=,I8, + 1 39H) IS NOT AVAILABLE IN THE RHS MICROLIB.)') + 2 (ISONAM2(I0,ISO2),I0=1,3),ISO2 + CALL XABORT(HSMG) + ENDIF + JPLIB=LCMGID(IPLIB,'ISOTOPESLIST') + KPLIB=LCMDIL(JPLIB,NBISO) ! create a new list entry + CALL LCMEQU(KPLIB2,KPLIB) ! KPLIB2 --> KPLIB + ENDDO OUTER + IF(DENMIX(NNMIX).GE.0.0) THEN + CALL LIBCON(IPLIB,NNMIX,NBISO,ISOMIX,DENISO,DENMIX(NNMIX),1) + ENDIF + ENDDO MIXTURE + DEALLOCATE(JPISO2) + DEALLOCATE(MASKI2) + DEALLOCATE(ENERGY,DENMIX2,GIR2,SBISO2,SNISO2,TMPISO2,DENISO2) + DEALLOCATE(HNAME2,HVECT2,HLIB2,SHINA2) + DEALLOCATE(KGAS2,ILLIB2,ITYP2,IEVOL2,NIR2,LSHI2,NTFG2,ISOMIX2, + 1 ISONRF2,ISONAM2) + ENDIF +*---- +* ADD THE MISSING ISOTOPES FROM THE DEPLETION CHAIN. +*---- + IF((NDEPL.NE.0).AND.(ISOADD.EQ.0)) THEN + NBISOL=NBISO + CALL LCMSIX(IPLIB,'DEPL-CHAIN',1) + CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) + IF(ISTATE(1).NE.NDEPL) CALL XABORT('LIBCTL: INVALID NUMBER OF ' + > //'DEPLETING ISOTOPES.') + NFISS=ISTATE(2) + NSUPF=ISTATE(5) + NSUPS=ISTATE(7) + NREAC=ISTATE(8) + NPAR=ISTATE(9) + CALL LIBEAD(IPLIB,MAXISO,MAXMIX,IMPX,NDEPL,NFISS,NSUPS, + 1 NREAC,NPAR,NBISO,ISONAM,ISONRF,HLIB,ILLIB,ISOMIX,TMPISO, + 2 IEVOL,ITYP,NCOMB) + CALL LCMSIX(IPLIB,' ',2) +* + DO ISOT=NBISOL+1,NBISO + SNISO(ISOT)=1.0E10 + SBISO(ISOT)=1.0E10 + DENISO(ISOT)=0.0 + NTFG(ISOT)=0 + HLIB(ISOT,2)=SHINA(ISOT)(:8) + HLIB(ISOT,3)=SHINA(ISOT)(:8) + HLIB(ISOT,4)=SHINA(ISOT)(:8) + LSHI(ISOT)=0 + GIR(ISOT)=1.0 + NIR(ISOT)=0 + MASKI(ISOT)=.TRUE. + ENDDO + ENDIF +*---- +* SET THE MIXTURE MASKS. +*---- + DO 110 I=1,NBMIX + MASK(I)=.FALSE. + DO 90 JJ=1,NBISO + IF(ISOMIX(JJ).EQ.I) THEN + MASK(I)=.TRUE. + GO TO 100 + ENDIF + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE +*---- +* SAVE THE LIBRARY SPECIFIC INFORMATION. +*---- + NBMIX=0 + DO I=1,NBISO + NBMIX=MAX(NBMIX,ISOMIX(I)) + ENDDO + IF(NBMIX.GT.MAXMIX) CALL XABORT('LIBCTL: MAXMIX TOO SMALL.') + TEXT12='L_LIBRARY' + CALL LCMPTC(IPLIB,'SIGNATURE',12,TEXT12) + ISTATE(:NSTATE)=0 + ISTATE(1)=MAXMIX + ISTATE(2)=NBISO + ISTATE(3)=NGRO + ISTATE(4)=NL + ISTATE(5)=ITRANC + ISTATE(8)=NLIB + ISTATE(11)=NDEPL + ISTATE(12)=NCOMB + ISTATE(13)=NEDMAC + ISTATE(14)=NBMIX + ISTATE(17)=-1 + ISTATE(18)=IMAC + ISTATE(21)=ISOADD + CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMPUT(IPLIB,'ISOTOPESUSED',3*NBISO,3,ISONAM) + CALL LCMPUT(IPLIB,'ISOTOPERNAME',3*NBISO,3,ISONRF) + CALL LCMPUT(IPLIB,'ISOTOPESMIX',NBISO,1,ISOMIX) + CALL LCMPUT(IPLIB,'ISOTOPESTODO',NBISO,1,IEVOL) + CALL LCMPUT(IPLIB,'ISOTOPESTYPE',NBISO,1,ITYP) + CALL LCMPTC(IPLIB,'ILIBRARYTYPE',8,NBISO,HLIB(:NBISO,1)) + CALL LCMPUT(IPLIB,'ILIBRARYINDX',NBISO,1,ILLIB) + CALL LCMPTC(IPLIB,'ISOTOPESCOH',8,NBISO,HLIB(:NBISO,2)) + CALL LCMPTC(IPLIB,'ISOTOPESINC',8,NBISO,HLIB(:NBISO,3)) + CALL LCMPTC(IPLIB,'ISOTOPESRESK',8,NBISO,HLIB(:NBISO,4)) + CALL LCMPUT(IPLIB,'ISOTOPESNTFG',NBISO,1,NTFG) + CALL LCMPTC(IPLIB,'ISOTOPESHIN',12,NBISO,SHINA) + CALL LCMPUT(IPLIB,'ISOTOPESSHI',NBISO,1,LSHI) + CALL LCMPUT(IPLIB,'ISOTOPESGIR',NBISO,2,GIR) + CALL LCMPUT(IPLIB,'ISOTOPESNIR',NBISO,1,NIR) + CALL LCMPUT(IPLIB,'ISOTOPESTEMP',NBISO,2,TMPISO) + CALL LCMPUT(IPLIB,'ISOTOPESDENS',NBISO,2,DENISO) + IF(NEDMAC.GT.0) THEN + CALL LCMPTC(IPLIB,'ADDXSNAME-P0',8,NEDMAC,HVECT) + ENDIF + IF(NLIB.GT.0) THEN + CALL LCMPTC(IPLIB,'ILIBRARYNAME',64,NLIB,HNAME) + ENDIF + CALL LCMPUT(IPLIB,'MIXTUREGAS',NBMIX,1,KGAS) +*---- +* CHECK FOR DUPLICATE ALIAS. +*---- + DO 130 I=1,NBISO + IF(ISOMIX(I).EQ.0) GO TO 130 + DO 120 J=I+1,NBISO + IF((ISOMIX(I).EQ.ISOMIX(J)).AND.(ISONRF(1,I).EQ.ISONRF(1,J)) + 1 .AND.(ISONRF(2,I).EQ.ISONRF(2,J)) + 2 .AND.(ISONRF(3,I).EQ.ISONRF(3,J)).AND.(LSHI(I).NE.0)) THEN + WRITE(HSMG,200) (ISONAM(I1,I),I1=1,3),(ISONAM(I1,J),I1=1,3), + > (ISONRF(I1,I),I1=1,3),ISOMIX(I) + CALL XABORT(HSMG) + ENDIF + 120 CONTINUE + 130 CONTINUE +*---- +* PRINT TABLE OF CONTENTS. +*---- + IF(IMPX.GT.1) THEN + IF(NLIB.GT.0) THEN + WRITE(IOUT,150) + DO ILIB=1,NLIB + WRITE(IOUT,'(1X,I4,4H -- ,A)') ILIB,HNAME(ILIB) + ENDDO + ENDIF + WRITE(IOUT,160) + DO I=1,NBISO + IF(ISOMIX(I).EQ.0) CYCLE + IF(MASK(ISOMIX(I))) THEN + WRITE(IOUT,170) I,(ISONAM(I0,I),I0=1,3),(ISONRF(I0,I), + > I0=1,3),HLIB(I,1),ILLIB(I),ISOMIX(I),DENISO(I), + > TMPISO(I),SNISO(I),LSHI(I),SHINA(I),NTFG(I),HLIB(I,3), + > HLIB(I,4),HLIB(I,2) + ENDIF + ENDDO + ENDIF +*---- +* COMPUTE THE MACROSCOPIC X-SECTIONS. +*---- + IF(IMAC.EQ.1) THEN + ALLOCATE(MASKL(NGRO)) + MASKL(:NGRO)=.TRUE. + ITSTMP=0 + TMPDAY(1)=0.0 + TMPDAY(2)=0.0 + TMPDAY(3)=0.0 + CALL LIBMIX(IPLIB,NBMIX,NGRO,NBISO,ISONAM,ISOMIX,DENISO,MASK, + > MASKL,ITSTMP,TMPDAY) + DEALLOCATE(MASKL) + ENDIF +*---- +* PRINT STATE VECTOR +*---- + IF(IMPX.GT.0) WRITE(IOUT,180) IMPX,NLIB,NBISO,NBMIX,NDEPL,NCOMB, + > NEDMAC,NGRO,NL,ITRANC,IMAC,ISOADD +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(MASK,MASKI) + DEALLOCATE(DENMIX,GIR,SBISO,SNISO,TMPISO,DENISO) + DEALLOCATE(HNAME,HVECT,HLIB,SHINA) + DEALLOCATE(LOCUPD,KGAS,ILLIB,ITYP,IEVOL,NIR,LSHI,NTFG,ISOMIX, + 1 ISONRF,ISONAM) + RETURN +* + 150 FORMAT(/35H AVAILABLE CROSS-SECTION LIBRARIES:) + 160 FORMAT(58X,'NUMBER'/' SPEC LOCAL NAME ISOTOPE FRO', + 1 'M LIBRARY MIX DENSITY TEMP(K) SIGZERO SELF-SHIEL', + 2 ' THERMAL CORRECTION'/' ------- ------------ ------------ ', + 3 '------------ ---- ---------- --------- --------- -------', + 4 '--- ------------------') + 170 FORMAT(1X,I7,2X,3A4,2X,3A4,2X,A8,I4,2X,I4,1P,E12.4,2E11.3,I4,2X, + 1 A8,I4,1X,3A8) + 180 FORMAT(/16H LIBCTL: OPTIONS/8H -------/ + 1 7H IMPX ,I8,30H (0=NO PRINT/1=SHORT/2=MORE)/ + 2 7H NLIB ,I8,32H (NUMBER OF SETS OF LIBRARIES)/ + 3 7H NBISO ,I8,36H (NUMBER OF ISOTOPES OR MATERIALS)/ + 4 7H NBMIX ,I8,23H (NUMBER OF MIXTURES)/ + 5 7H NDEPL ,I8,33H (NUMBER OF DEPLETING ISOTOPES)/ + 6 7H NCOMB ,I8,33H (NUMBER OF DEPLETING MIXTURES)/ + 7 7H NEDMAC,I8,34H (NUMBER OF CROSS SECTION EDITS)/ + 8 7H NGRO ,I8,28H (NUMBER OF ENERGY GROUPS)/ + 9 7H NL ,I8,30H (NUMBER OF LEGENDRE ORDERS)/ + 1 7H ITRANC,I8,45H (0=NO TRANSPORT CORRECTION/1=APOLLO TYPE/2, + 2 57H=RECOVER FROM LIBRARY/3=WIMS-D TYPE/4=LEAKAGE CORRECTION)/ + 3 7H IMAC ,I8,45H (0=DO NOT/1=DO BUILD AN EMBEDDED MACROLIB)/ + 4 7H ISOADD,I8,37H (0=COMPLETE BURNUP CHAIN/1=DO NOT)) + 200 FORMAT(9HLIBCTL: ',3A4,7H' AND ',3A4,24H' ARE BOTH ALIAS FOR THE, + 1 23H SAME LIBRARY ISOTOPE ',3A4,12H' IN MIXTURE,I5,1H.) + END diff --git a/Dragon/src/LIBD10.F b/Dragon/src/LIBD10.F new file mode 100644 index 0000000..c98de35 --- /dev/null +++ b/Dragon/src/LIBD10.F @@ -0,0 +1,62 @@ +*DECK LIBD10 +#if defined(HDF5_LIB) + SUBROUTINE LIBD10 (MAXDIL,NAMFIL,HNISOR,NDIL,DILUT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find the dilutions corresponding to a resonant isotope within a +* library in Apolib-3 format. +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXDIL maximum number of dilutions. +* NAMFIL name of the APOLIB-3 file. +* HNISOR library name of the resonant isotope. +* +*Parameters: output +* NDIL number of finite dilutions. +* DILUT dilutions. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXDIL,NDIL + CHARACTER HNISOR*12,NAMFIL*(*) + REAL DILUT(MAXDIL) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPAP + CHARACTER RECNAM*80 + REAL, ALLOCATABLE, DIMENSION(:) :: BGXS +*---- +* OPEN AND PROBE THE APOLIB-3 FILE. +*---- + CALL hdf5_open_file(NAMFIL, IPAP, .TRUE.) + WRITE(RECNAM,'(9HIsotopes/,A,15H/HomoRates/BgXS)') TRIM(HNISOR) + CALL hdf5_read_data(IPAP, RECNAM, BGXS) + NDIL=SIZE(BGXS) + IF(NDIL.GT.MAXDIL) CALL XABORT('LIBD10: MAXDIL IS TOO SMALL.') + DILUT(:NDIL)=BGXS(:) + NDIL=NDIL-1 + DEALLOCATE(BGXS) + CALL hdf5_close_file(IPAP) +#else + SUBROUTINE LIBD10 + CALL XABORT('LIBD10: THE HDF5 API IS NOT AVAILABLE.') +#endif /* defined(HDF5_LIB) */ + RETURN + END diff --git a/Dragon/src/LIBDEN.f b/Dragon/src/LIBDEN.f new file mode 100644 index 0000000..da4eeb2 --- /dev/null +++ b/Dragon/src/LIBDEN.f @@ -0,0 +1,1150 @@ +*DECK LIBDEN + SUBROUTINE LIBDEN (IPLIB,NGROUP,NBISO,NBMIX,NL,NDEL,NESP,ISONAM, + 1 IPISO,MIX,DEN,MASK,MASKL,NED,NAMEAD,ITRANC,MAXNFI,NPART,LSAME, + 2 ITSTMP,TMPDAY,STERN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transformation of the isotope ordered microscopic cross sections to +* group ordered macroscopic cross sections (part 2). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert and A. Naceur +* +*Parameters: input +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* NGROUP number of energy groups. +* NBISO number of isotopes present in the calculation domain. +* NBMIX number of mixtures present in the calculation domain. +* NL number of Legendre orders required in the calculation +* (NL=1 or higher). +* NDEL number of delayed precursor groups. +* NESP number of energy-dependent fission spectra. +* ISONAM names of microlib isotopes. +* IPISO pointer array towards microlib isotopes. +* MIX mixture number of each isotope (can be zero). +* DEN density of each isotope. +* MASK mixture mask (=.true. if a mixture is to be made). +* MASKL group mask (=.true. if an energy group is to be treated). +* NED number of extra edit vectors. +* NAMEAD names of these extra edits. +* ITRANC type of transport corrections in the microlib +* (=0: no transport correction). +* MAXNFI maximum number of fissionable isotopes in a mixture. +* NPART number of companion particles. +* LSAME fission spectrum flag (=.true. if all the isotopes have the +* same fission spectrum and the same precursor group decay +* constants). +* ITSTMP type of cross section perturbation (=0: perturbation +* forbidden; =1: perturbation not used even if present; +* =2: perturbation used if present). +* TMPDAY time stamp in day/burnup/irradiation. +* STERN Sternheimer flag (=0/1: off/on). +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB,IPISO(NBISO) + INTEGER NGROUP,NBISO,NBMIX,NL,NDEL,NESP,ISONAM(3,NBISO), + 1 MIX(NBISO),NED,ITRANC,MAXNFI,NPART,NAMEAD(2,NED),ITSTMP,STERN + REAL DEN(NBISO),TMPDAY(3) + LOGICAL MASK(NBMIX),MASKL(NGROUP),LSAME +*---- +* LOCAL VARIABLES +*---- + INTEGER NBLK,NSTATE,IOUT,MAXESP + PARAMETER (NBLK=50,NSTATE=40,IOUT=6,MAXESP=4) + CHARACTER CM*4,CV*12,HSMG*131,TEXT12*12,HCM(0:10)*2,NORD(3)*4, + 1 TEXT2*2,HPRT1*1 + LOGICAL EXIST,MASKK,LOGL,LALL,LWP1,LSTRD,LH,LC,LOVERV,LDIFF, + 1 LFISS,LWT0,LWT1 + INTEGER IDATA(NSTATE),IESP(MAXESP+1),I,J,I0,IOF,IOF0,IP,IPOSDE, + 1 IPASS,ISP,IGR,IG1,LLL,LLL0,IGMIN,IGMAX,IBM,JBM,IDEL,IED,IFIS, + 2 NXSPER,ISOT,IBLK,ILONG,LENGTZ,ITYLCM,IWFIS,IXSPER,KFIS,M,NBM0, + 3 NFISS0,NFISSI,NGROUPS + REAL TMPPER(2,3),TIMFCT,DENISO,ENEAVG,FACT,TOTDEN,XTF + DOUBLE PRECISION SQFMAS,XDRCST,NMASS,EVJ,ZNU + TYPE(C_PTR) JPLIB,KPLIB +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IPOS,IJJ,NJJ,IWRK,NGPART + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NJJM,IJJM,INDFIS + REAL, ALLOCATABLE, DIMENSION(:) :: GA1,GA2,SCAT,VOLMIX,NWTMIX, + 1 VOLI,C2PART,KGAS,ENER + REAL, ALLOCATABLE, DIMENSION(:,:) :: GA3,GAR,WRK1,WRK2,DENMAT + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: GAF,CHECK,ZNUS,ZCHI,FLUX + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:,:) :: IPGRP + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LMADE + CHARACTER(LEN=1), ALLOCATABLE, DIMENSION(:) :: HNPART + CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: ISONRF +*---- +* DATA STATEMENTS +*---- + DATA HCM/'00','01','02','03','04','05','06','07','08','09','10'/ + DATA NORD/' ',' LIN',' QUA'/ +*---- +* SCRATCH STORAGE ALLOCATION +* IPGRP LCM pointers of the macrolib groupwise directories. +*---- + ALLOCATE(NJJM(NBMIX,NBLK),IJJM(NBMIX,NBLK),IPOS(NBMIX), + 1 INDFIS(NBMIX,MAXNFI),IJJ(NGROUP),NJJ(NGROUP)) + ALLOCATE(GA2(NGROUP*NGROUP),GA3(NDEL,MAXNFI),GAR(NBMIX,NBLK+1), + 1 GAF(NBMIX,NGROUP,NBLK),SCAT(NGROUP*NBMIX),CHECK(NBMIX,NGROUP,NL), + 2 ZNUS(NBMIX*MAXNFI*NESP,NGROUP,0:NDEL), + 3 ZCHI(NBMIX*MAXNFI*NESP,NGROUP,0:NDEL)) + ALLOCATE(IPGRP(NGROUP,NPART+1)) + ALLOCATE(LMADE(NBISO)) + ALLOCATE(NGPART(NPART+1),C2PART(NPART+1),HNPART(NPART+1)) + ALLOCATE(DENMAT(NBMIX,NGROUP+1)) +*---- +* FOR AVERAGED NEUTRON VELOCITY +* V=SQRT(2*ENER/M)=SQRT(2/M)*SQRT(ENER) +* SQFMAS=SQRT(2/M) IN CM/S/SQRT(EV) FOR V IN CM/S AND E IN EV +* =SQRT(2*1.602189E-19(J/EV)* 1.0E4(CM2/M2) /1.67495E-27 (KG)) +* =1383155.30602 CM/S/SQRT(EV) +*---- + EVJ=XDRCST('eV','J') + NMASS=XDRCST('Neutron mass','kg') + SQFMAS=SQRT(2.0D4*EVJ/NMASS) +*---- +* SET MULTIPLE FISSION SPECTRA INFORMATION. +*---- + IF(NESP.GT.1) THEN + IF(NESP.GT.MAXESP) CALL XABORT('LIBDEN: MAXESP OVERFLOW.') + CALL LCMGET(IPLIB,'CHI-LIMITS',IESP) + ENDIF +*---- +* SET CROSS SECTION PERTURBATION INFORMATION. +*---- + NXSPER=1 + TIMFCT=0.0 + CALL LCMLEN(IPLIB,'TIMESPER',ILONG,ITYLCM) + IF((ILONG.GE.2).AND.(ILONG.LE.6)) THEN + IF(ITSTMP.EQ.0) THEN + CALL XABORT('LIBDEN: XS PERTURBATION FORBIDDEN.') + ELSE IF(ITSTMP.EQ.2) THEN + CALL LCMGET(IPLIB,'TIMESPER',TMPPER) + TIMFCT=TMPDAY(1)-TMPPER(1,1) + XTF=TIMFCT/TMPPER(2,1) + IF(XTF.NE.0.0) NXSPER=2 + IF(XTF.LT.0.0) THEN + WRITE(IOUT,6000) TMPPER(1,1),TMPDAY(1) + ELSE IF(XTF.GT.1.0) THEN + WRITE(IOUT,6001) TMPPER(1,1)+TMPPER(2,1),TMPDAY(1) + ENDIF + ENDIF + ENDIF +*---- +* RECOVER MIXTURE VOLUMES IN MICROLIB. +*---- + CALL LCMLEN(IPLIB,'ISOTOPESVOL',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + ALLOCATE(VOLMIX(NBMIX),VOLI(NBISO)) + CALL LCMGET(IPLIB,'ISOTOPESVOL',VOLI) + VOLMIX(:NBMIX)=0.0 + DO ISOT=1,NBISO + IBM=MIX(ISOT) + IF(IBM.GT.0) VOLMIX(IBM)=VOLI(ISOT) + ENDDO + CALL LCMPUT(IPLIB,'MIXTURESVOL',NBMIX,2,VOLMIX) + DEALLOCATE(VOLI,VOLMIX) + ENDIF +*---- +* MASKK=.TRUE. IF MIXTURE MASKING IS TO BE USED (IT IS NOT USED IF +* ALL MIXTURES ARE TO BE UPDATED). +*---- + LDIFF=.TRUE. + CALL LCMLEN(IPLIB,'MACROLIB',ILONG,ITYLCM) + MASKK=(ILONG.EQ.-1) + IF(MASKK) THEN + CALL LCMSIX(IPLIB,'MACROLIB',1) + CALL LCMGTC(IPLIB,'SIGNATURE',12,TEXT12) + IF(TEXT12.NE.'L_MACROLIB') THEN + CALL XABORT('LIBDEN: INVALID SIGNATURE ON THE MACROLIB.') + ENDIF + CALL LCMGET(IPLIB,'STATE-VECTOR',IDATA) + NBM0=IDATA(2) + NFISSI=IDATA(4)/NESP + LDIFF=(IDATA(9).EQ.1) + IF(IDATA(1).NE.NGROUP) THEN + WRITE(HSMG,'(37HLIBDEN: EXISTING MACROLIB HAS NGROUP=,I4, + 1 25H NEW MACROLIB HAS NGROUP=,I4,1H.)') IDATA(1),NGROUP + CALL XABORT(HSMG) + ELSE IF((IDATA(6).NE.2).AND.(ITRANC.GT.0)) THEN + WRITE(HSMG,'(37HLIBDEN: EXISTING MACROLIB HAS ITRANC=,I4, + 1 25H NEW MACROLIB HAS ITRANC=,I4,1H.)') IDATA(6),ITRANC + CALL XABORT(HSMG) + ELSE IF(NBM0.GT.NBMIX) THEN + WRITE(HSMG,'(36HLIBDEN: EXISTING MACROLIB HAS NBMIX=,I4, + 1 24H NEW MACROLIB HAS NBMIX=,I4,1H.)') NBM0,NBMIX + CALL XABORT(HSMG) + ELSE IF(NFISSI.GT.NBISO) THEN + WRITE(HSMG,'(37HLIBDEN: EXISTING MACROLIB HAS NFISSI=,I4, + 1 13H GREATER THAN,I5,1H.)') IDATA(4),NBISO + CALL XABORT(HSMG) + ENDIF + IF(NFISSI.GT.0) THEN + CALL LCMLEN(IPLIB,'FISSIONINDEX',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN +* THE NAMES ARE NOT DEFINED. + DO 11 IFIS=1,NFISSI + DO 10 IBM=1,NBMIX + INDFIS(IBM,IFIS)=0 + 10 CONTINUE + 11 CONTINUE + ELSE IF(ILONG.EQ.NFISSI*NBMIX) THEN + CALL LCMGET(IPLIB,'FISSIONINDEX',INDFIS) + DO 16 IFIS=1,NFISSI + DO 15 IBM=1,NBMIX + IF(INDFIS(IBM,IFIS).GT.NBISO) THEN + CALL XABORT('LIBDEN: INVALID RECORD FISSIONINDEX.') + ENDIF + 15 CONTINUE + 16 CONTINUE + ELSE IF(ILONG.LT.NFISSI*NBMIX) THEN +* REORDER THE 'FISSIONINDEX' MATRIX. + ALLOCATE(IWRK(ILONG)) + CALL LCMGET(IPLIB,'FISSIONINDEX',IWRK) + DO 31 IFIS=1,NFISSI + DO 20 IBM=1,NBM0 + INDFIS(IBM,IFIS)=IWRK((IFIS-1)*NBM0+IBM) + 20 CONTINUE + DO 30 IBM=NBM0+1,NBMIX + INDFIS(IBM,IFIS)=0 + 30 CONTINUE + 31 CONTINUE + DEALLOCATE(IWRK) + ELSE + CALL XABORT('LIBDEN: INVALID NUMBER OF MIXTURES.') + ENDIF + ENDIF + CALL LCMSIX(IPLIB,' ',2) + LALL=NBMIX.GT.NBM0 + ELSE + NFISSI=0 + LALL=.FALSE. + ENDIF +*---- +* RECOVER PARTICLE DATA +*---- + CALL LCMLEN(IPLIB,'PARTICLE',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + HPRT1=' ' + HNPART(1)=' ' + ELSE + CALL LCMGTC(IPLIB,'PARTICLE',1,HPRT1) + CALL LCMGTC(IPLIB,'PARTICLE-NAM',1,NPART+1,HNPART) + CALL LCMGET(IPLIB,'PARTICLE-NGR',NGPART) + CALL LCMGET(IPLIB,'PARTICLE-MC2',C2PART) + CALL LCMSIX(IPLIB,'MACROLIB',1) + CALL LCMPTC(IPLIB,'PARTICLE',1,HPRT1) + CALL LCMPTC(IPLIB,'PARTICLE-NAM',1,NPART+1,HNPART) + CALL LCMPUT(IPLIB,'PARTICLE-NGR',NPART+1,1,NGPART) + CALL LCMPUT(IPLIB,'PARTICLE-MC2',NPART+1,2,C2PART) + CALL LCMSIX(IPLIB,' ',2) + IF(HPRT1.NE.HNPART(1)) THEN + WRITE(HSMG,'(27HLIBDEN: MICROLIB PARTICLE (,A1,10H) IS DIFFE, + 1 26HRENT FROM PARTICLE-NAM(1)=,A1,1H.)') HPRT1,HNPART(1) + CALL XABORT(HSMG) + ENDIF + DO IP=2,NPART+1 + ALLOCATE(GA1(NGPART(IP)+1)) + CALL LCMGET(IPLIB,HNPART(IP)//'ENERGY',GA1) + CALL LCMSIX(IPLIB,'MACROLIB',1) + CALL LCMPUT(IPLIB,HNPART(IP)//'ENERGY',NGPART(IP)+1,2,GA1) + CALL LCMSIX(IPLIB,' ',2) + DEALLOCATE(GA1) + ENDDO + ENDIF +*---- +* SELECT NUMBER OF GROUPS TO PROCESS +*---- + NGROUPS=0 + DO 35 LLL=1,NGROUP + IF(MASKL(LLL).OR.LALL) NGROUPS=NGROUPS+1 + 35 CONTINUE + IF(NGROUPS.EQ.0) GO TO 880 +*---- +* CHECK IF ALL REQUIRED ISOTOPES ARE PRESENT IN THE MICROLIB +*---- + ALLOCATE(GA1(NGROUP+1)) + DO 40 ISOT=1,NBISO + IF(MIX(ISOT).EQ.0) GO TO 40 + IF(.NOT.MASK(MIX(ISOT))) GO TO 40 + JPLIB=IPISO(ISOT) + IF(.NOT.C_ASSOCIATED(JPLIB)) THEN + WRITE(HSMG,'(17HLIBDEN: ISOTOPE '',3A4,8H'' (SPEC=,I6,5H) IS , + > 30HNOT AVAILABLE IN THE MICROLIB.)') (ISONAM(I0,ISOT),I0=1,3), + > ISOT + CALL XABORT(HSMG) + ENDIF + 40 CONTINUE +*---- +* SET THE LCM MACROLIB GROUPWISE AND MICROLIB ISOTOPEWISE DIRECTORIES +*---- + CALL LCMSIX(IPLIB,'MACROLIB',1) + JPLIB=LCMLID(IPLIB,'GROUP',NGROUP) + DO 45 LLL=1,NGROUP + IPGRP(LLL,1)=LCMDIL(JPLIB,LLL) + 45 CONTINUE + DO 47 IP=2,NPART+1 + JPLIB=LCMLID(IPLIB,'GROUP-'//HNPART(IP),NGROUP) + DO 46 LLL=1,NGROUP + IPGRP(LLL,IP)=LCMDIL(JPLIB,LLL) + 46 CONTINUE + 47 CONTINUE + CALL LCMSIX(IPLIB,' ',2) +*---- +* PROCESS THE SCATTERING TABLES. +*---- + DO 52 I=1,NGROUP + DO 51 IBM=1,NBMIX + DO 50 J=1,NL + CHECK(IBM,I,J)=0.0 + 50 CONTINUE + 51 CONTINUE + 52 CONTINUE + DO 245 IP=1,NPART+1 + DO 240 M=1,NL + IF(M.LE.11) THEN + CM=HCM(M-1)//' ' + ELSE + WRITE(CM,'(I2.2,2X)') M-1 + ENDIF + DO 235 IPASS=0,(NGROUP-1)/NBLK + LLL0=IPASS*NBLK + DO 70 IBLK=1,NBLK + DO 60 IBM=1,NBMIX + GAR(IBM,IBLK)=0.0 + 60 CONTINUE + DO 71 LLL=1,NGROUP + DO 72 IBM=1,NBMIX + GAF(IBM,LLL,IBLK)=0.0 + 72 CONTINUE + 71 CONTINUE + 70 CONTINUE + DO 80 ISOT=1,NBISO + LMADE(ISOT)=DEN(ISOT).EQ.0.0 + 80 CONTINUE + DO 140 ISOT=1,NBISO + IF(LMADE(ISOT)) GO TO 140 + JPLIB=IPISO(ISOT) + IF(.NOT.C_ASSOCIATED(JPLIB)) GO TO 140 +* +* RECOVER THE MICROSCOPIC TRANSFER XS WITHOUT USING XDRLGS (IN +* ORDER TO REDUCE CPU TIME) + IF(IP.GE.2) CALL LCMSIX(JPLIB,HNPART(IP),1) + FACT=1.0 + DO 135 IXSPER=1,NXSPER + CALL LCMLEN(JPLIB,'SIGS'//CM//NORD(IXSPER),ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 130 + CALL LCMGET(JPLIB,'SIGS'//CM//NORD(IXSPER),GA1) + CALL LCMGET(JPLIB,'NJJS'//CM//NORD(IXSPER),NJJ) + CALL LCMGET(JPLIB,'IJJS'//CM//NORD(IXSPER),IJJ) + CALL LCMGET(JPLIB,'SCAT'//CM//NORD(IXSPER),GA2) + IOF0=0 + DO 90 LLL=1,LLL0 + IOF0=IOF0+NJJ(LLL) + 90 CONTINUE + DO 110 IBM=1,NBMIX + IF((MASK(IBM).OR.(.NOT.MASKK)).AND.(MIX(ISOT).EQ.IBM)) THEN + IOF=IOF0 + DO 105 IBLK=1,NBLK + LLL=LLL0+IBLK + IF(LLL.GT.NGROUP) GO TO 110 + GAR(IBM,IBLK)=GAR(IBM,IBLK)+GA1(LLL)*DEN(ISOT) + DO 100 IG1=IJJ(LLL),IJJ(LLL)-NJJ(LLL)+1,-1 + IOF=IOF+1 + GAF(IBM,IG1,IBLK)=GAF(IBM,IG1,IBLK)+GA2(IOF)*DEN(ISOT)*FACT + 100 CONTINUE + 105 CONTINUE + ENDIF + 110 CONTINUE + LMADE(ISOT)=.TRUE. + 130 FACT=FACT*TIMFCT + 135 CONTINUE + IF(IP.GE.2) CALL LCMSIX(JPLIB,' ',2) +*- + 140 CONTINUE + DO 230 IBLK=1,NBLK + LLL=LLL0+IBLK + IF(LLL.GT.NGROUP) GO TO 230 + KPLIB=IPGRP(LLL,IP) + IF(MASKL(LLL).OR.LALL) THEN + IF(MASKK) THEN + ILONG=1 + IF(M.GT.1) CALL LCMLEN(KPLIB,'SIGS'//CM,ILONG,ITYLCM) + GAR(:NBMIX,NBLK+1)=0.0 + IF(ILONG.GT.0) THEN + CALL LCMGET(KPLIB,'SIGS'//CM,GAR(1,NBLK+1)) + ENDIF + DO 150 IBM=1,NBMIX + IF(.NOT.MASK(IBM)) GAR(IBM,IBLK)=GAR(IBM,NBLK+1) + 150 CONTINUE + ENDIF + CALL LCMPUT(KPLIB,'SIGS'//CM,NBMIX,2,GAR(1,IBLK)) + ENDIF +* + LOGL=MASKL(LLL).OR.LALL + DO 165 IBM=1,NBMIX + DO 160 IG1=1,NGROUP + LOGL=LOGL.OR.(MASKL(IG1).AND.(GAF(IBM,IG1,IBLK).NE.0.0)) + 160 CONTINUE + 165 CONTINUE + IF(LOGL) THEN + IF(MASKK) THEN + ILONG=1 + IF(M.GT.1) CALL LCMLEN(KPLIB,'SCAT'//CM,ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + DO 170 I=1,NBMIX + IPOS(I)=-99 + 170 CONTINUE + CALL LCMGET(KPLIB,'SCAT'//CM,SCAT) + CALL LCMGET(KPLIB,'NJJS'//CM,NJJM(1,IBLK)) + CALL LCMGET(KPLIB,'IJJS'//CM,IJJM(1,IBLK)) + CALL LCMGET(KPLIB,'IPOS'//CM,IPOS) + DO 190 IBM=1,NBMIX + IF(.NOT.MASK(IBM)) THEN + IPOSDE=IPOS(IBM) + IF(IPOSDE.EQ.-99) GO TO 190 + DO 180 IG1=IJJM(IBM,IBLK),IJJM(IBM,IBLK)-NJJM(IBM,IBLK) + 1 +1,-1 + GAF(IBM,IG1,IBLK)=SCAT(IPOSDE) + IPOSDE=IPOSDE+1 + 180 CONTINUE + ENDIF + 190 CONTINUE + ENDIF + ENDIF +* + IPOSDE=0 + DO 220 IBM=1,NBMIX + IPOS(IBM)=IPOSDE+1 + IGMIN=LLL + IGMAX=LLL + DO 200 IG1=NGROUP,1,-1 + IF(GAF(IBM,IG1,IBLK).NE.0.0) THEN + IGMIN=MIN(IGMIN,IG1) + IGMAX=MAX(IGMAX,IG1) + ENDIF + 200 CONTINUE + IJJM(IBM,IBLK)=IGMAX + NJJM(IBM,IBLK)=IGMAX-IGMIN+1 + DO 210 IG1=IGMAX,IGMIN,-1 + IPOSDE=IPOSDE+1 + SCAT(IPOSDE)=GAF(IBM,IG1,IBLK) + CHECK(IBM,IG1,M)=CHECK(IBM,IG1,M)+SCAT(IPOSDE) + 210 CONTINUE + GAR(IBM,1)=SCAT(IPOS(IBM)+IJJM(IBM,IBLK)-LLL) + 220 CONTINUE + CALL LCMPUT(KPLIB,'SCAT'//CM,IPOSDE,2,SCAT) + CALL LCMPUT(KPLIB,'NJJS'//CM,NBMIX,1,NJJM(1,IBLK)) + CALL LCMPUT(KPLIB,'IJJS'//CM,NBMIX,1,IJJM(1,IBLK)) + CALL LCMPUT(KPLIB,'IPOS'//CM,NBMIX,1,IPOS) + CALL LCMPUT(KPLIB,'SIGW'//CM,NBMIX,2,GAR(1,1)) + ENDIF + 230 CONTINUE + 235 CONTINUE + 240 CONTINUE + 245 CONTINUE +*---- +* STERNHEIMER DENSITY CORRECTION FOR CHARGED PARTICLE CASES +*---- + IF(HPRT1.EQ.'B'.OR.HPRT1.EQ.'C') THEN + ALLOCATE(ISONRF(NBISO),ENER(NGROUP+1),KGAS(NBMIX)) + CALL LCMGTC(IPLIB,'ISOTOPERNAME',12,NBISO,ISONRF) + CALL LCMGET(IPLIB,'ENERGY',ENER) + CALL LCMGET(IPLIB,'MIXTUREGAS',KGAS) + CALL LIBSDC(NBMIX,NGROUP,NBISO,ISONRF,MIX,DEN,MASK,ENER,KGAS, + 1 DENMAT) + DEALLOCATE(KGAS,ENER,ISONRF) + ENDIF +*---- +* PROCESS THE REACTION VECTORS TOTAL, TOTAL-P1, STRD, H-FACTOR, +* C-FACTOR, OVERV AND TRANC. +*---- + LWP1=.FALSE. + LSTRD=.FALSE. + LH=.FALSE. + LC=.FALSE. + LOVERV=.FALSE. + DO 340 IBM=1,NBMIX + IF(MASK(IBM).OR.(.NOT.MASKK)) THEN + DO 255 IP=1,14 + DO 250 LLL=1,NGROUP + GAF(IBM,LLL,IP)=0.0 + 250 CONTINUE + 255 CONTINUE + TOTDEN=0.0 + DO 320 ISOT=1,NBISO + IF((MIX(ISOT).NE.IBM).OR.(DEN(ISOT).EQ.0.0)) GO TO 320 + JPLIB=IPISO(ISOT) + IF(.NOT.C_ASSOCIATED(JPLIB)) GO TO 320 +*- + DENISO=DEN(ISOT) + TOTDEN=TOTDEN+DENISO + DO 315 IXSPER=1,NXSPER + CALL LCMGET(JPLIB,'NTOT0 '//NORD(IXSPER),GA1) + DO 260 LLL=1,NGROUP + GAF(IBM,LLL,1)=GAF(IBM,LLL,1)+GA1(LLL)*DENISO + 260 CONTINUE + CALL LCMLEN(JPLIB,'NTOT1 '//NORD(IXSPER),ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + LWP1=.TRUE. + CALL LCMGET(JPLIB,'NTOT1 '//NORD(IXSPER),GA1) + DO 270 LLL=1,NGROUP + GAF(IBM,LLL,3)=GAF(IBM,LLL,3)+GA1(LLL)*DENISO + 270 CONTINUE + ENDIF + IF(LDIFF) THEN + CALL LCMLEN(JPLIB,'STRD '//NORD(IXSPER),ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + LSTRD=.TRUE. + CALL LCMGET(JPLIB,'STRD '//NORD(IXSPER),GA1) + DO 280 LLL=1,NGROUP + GAF(IBM,LLL,5)=GAF(IBM,LLL,5)+GA1(LLL)*DENISO + 280 CONTINUE + ENDIF + ENDIF + CALL LCMLEN(JPLIB,'H-FACTOR'//NORD(IXSPER),ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + LH=.TRUE. + CALL LCMGET(JPLIB,'H-FACTOR'//NORD(IXSPER),GA1) !eV-barns + DO 290 LLL=1,NGROUP + GAF(IBM,LLL,7)=GAF(IBM,LLL,7)+GA1(LLL)*DENISO !MeV/cm + 290 CONTINUE + ENDIF + CALL LCMLEN(JPLIB,'C-FACTOR'//NORD(IXSPER),ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + LC=.TRUE. + CALL LCMGET(JPLIB,'C-FACTOR'//NORD(IXSPER),GA1) + DO 295 LLL=1,NGROUP + GAF(IBM,LLL,13)=GAF(IBM,LLL,13)+GA1(LLL)*DENISO + 295 CONTINUE + ENDIF + CALL LCMLEN(JPLIB,'OVERV '//NORD(IXSPER),ILONG,ITYLCM) + IF((ILONG.GT.0).AND.((HPRT1.EQ.'N').OR.(HPRT1.EQ.'NEUT').OR. + 1 (HPRT1.EQ.' '))) THEN + LOVERV=.TRUE. + CALL LCMGET(JPLIB,'OVERV '//NORD(IXSPER),GA1) + DO 300 LLL=1,NGROUP + GAF(IBM,LLL,9)=GAF(IBM,LLL,9)+GA1(LLL)*DENISO + 300 CONTINUE + ENDIF + IF(ITRANC.NE.0) THEN + CALL LCMGET(JPLIB,'TRANC '//NORD(IXSPER),GA1) + DO 310 LLL=1,NGROUP + GAF(IBM,LLL,11)=GAF(IBM,LLL,11)+GA1(LLL)*DENISO + 310 CONTINUE + ENDIF + DENISO=DENISO*TIMFCT + 315 CONTINUE +*- + 320 CONTINUE + IF(LOVERV) THEN + DO 330 LLL=1,NGROUP + IF(GAF(IBM,LLL,9).NE.0.0) THEN + GAF(IBM,LLL,9)=GAF(IBM,LLL,9)/TOTDEN + ENDIF + 330 CONTINUE + ENDIF + ENDIF + !----------------------------------------------------------- + !APPLY STERNHEIMER DENSITY CORRECTION ON HEAT DEPOSITION FOR + !ELECTRON AND POSITRON. + !REASON: SOFT INLEASTIC HEAT DEPOSITION IN ELECTR + !CONTAINS A COLLISONNAL STOPPING POWER WHICH HAS NOT + !BEEN CORRECTED IN NJOY. + !----------------------------------------------------------- + IF (STERN.EQ.1) THEN + IF (HPRT1.EQ.'B'.OR.HPRT1.EQ.'C') THEN + DO LLL=1,NGROUP + GAF(IBM,LLL,7)=GAF(IBM,LLL,7)-DENMAT(IBM,LLL) !eV/cm + ENDDO + ENDIF + ENDIF + 340 CONTINUE + DO 420 LLL=1,NGROUP + KPLIB=IPGRP(LLL,1) + IF(MASKL(LLL).OR.LALL) THEN + IF(MASKK) THEN + GAF(:NBMIX,LLL,2)=0.0 + CALL LCMGET(KPLIB,'NTOT0',GAF(1,LLL,2)) + DO 350 IBM=1,NBMIX + IF(.NOT.MASK(IBM)) GAF(IBM,LLL,1)=GAF(IBM,LLL,2) + 350 CONTINUE + ENDIF + CALL LCMPUT(KPLIB,'NTOT0',NBMIX,2,GAF(1,LLL,1)) + IF(LWP1) THEN + IF(MASKK) THEN + GAF(:NBMIX,LLL,4)=0.0 + CALL LCMGET(KPLIB,'NTOT1',GAF(1,LLL,4)) + DO 360 IBM=1,NBMIX + IF(.NOT.MASK(IBM)) GAF(IBM,LLL,3)=GAF(IBM,LLL,4) + 360 CONTINUE + ENDIF + CALL LCMPUT(KPLIB,'NTOT1',NBMIX,2,GAF(1,LLL,3)) + ENDIF + IF(LSTRD) THEN + IF(MASKK) THEN + GAF(:NBMIX,LLL,6)=0.0 + CALL LCMGET(KPLIB,'DIFF',GAF(1,LLL,6)) + DO 370 IBM=1,NBMIX + IF(.NOT.MASK(IBM)) THEN + GAF(IBM,LLL,5)=1.0/(3.0*GAF(IBM,LLL,6)) + ENDIF + 370 CONTINUE + ENDIF + DO 380 IBM=1,NBMIX + IF(GAF(IBM,LLL,5).NE.0.0) THEN + GAF(IBM,LLL,5)=1.0/(3.0*GAF(IBM,LLL,5)) + ENDIF + 380 CONTINUE + CALL LCMPUT(KPLIB,'DIFF',NBMIX,2,GAF(1,LLL,5)) + ENDIF + IF(LH) THEN + IF(MASKK) THEN + GAF(:NBMIX,LLL,8)=0.0 + CALL LCMLEN(KPLIB,'H-FACTOR',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPLIB,'H-FACTOR',GAF(1,LLL,8)) + DO 390 IBM=1,NBMIX + IF(.NOT.MASK(IBM)) GAF(IBM,LLL,7)=GAF(IBM,LLL,8) + 390 CONTINUE + ENDIF + ENDIF + CALL LCMPUT(KPLIB,'H-FACTOR',NBMIX,2,GAF(1,LLL,7)) !eV/cm + ENDIF + IF(LC) THEN + IF(MASKK) THEN + GAF(:NBMIX,LLL,14)=0.0 + CALL LCMGET(KPLIB,'C-FACTOR',GAF(1,LLL,14)) + DO 395 IBM=1,NBMIX + IF(.NOT.MASK(IBM)) GAF(IBM,LLL,13)=GAF(IBM,LLL,14) + 395 CONTINUE + ENDIF + CALL LCMPUT(KPLIB,'C-FACTOR',NBMIX,2,GAF(1,LLL,13)) !e/cm + ENDIF + IF(LOVERV) THEN + IF(MASKK) THEN + GAF(:NBMIX,LLL,10)=0.0 + CALL LCMGET(KPLIB,'OVERV',GAF(1,LLL,10)) + DO 400 IBM=1,NBMIX + IF(.NOT.MASK(IBM)) GAF(IBM,LLL,9)=GAF(IBM,LLL,10) + 400 CONTINUE + ENDIF + CALL LCMPUT(KPLIB,'OVERV',NBMIX,2,GAF(1,LLL,9)) + ENDIF + IF(ITRANC.NE.0) THEN + IF(MASKK) THEN + GAF(:NBMIX,LLL,12)=0.0 + CALL LCMGET(KPLIB,'TRANC',GAF(1,LLL,12)) + DO 410 IBM=1,NBMIX + IF(.NOT.MASK(IBM)) GAF(IBM,LLL,11)=GAF(IBM,LLL,12) + 410 CONTINUE + ENDIF + CALL LCMPUT(KPLIB,'TRANC',NBMIX,2,GAF(1,LLL,11)) + ENDIF + ENDIF + 420 CONTINUE +*---- +* PROCESS THE FISSION VECTORS FOR EACH NEW FISSILE ISOTOPE. +*---- + NFISS0=NFISSI + DO 460 ISOT=1,NBISO + IBM=MIX(ISOT) + IF(IBM.EQ.0) GO TO 460 + IF(MASK(IBM).OR.(.NOT.MASKK)) THEN + JPLIB=IPISO(ISOT) + IF(.NOT.C_ASSOCIATED(JPLIB)) GO TO 460 + CALL LCMLEN(JPLIB,'NUSIGF',ILONG,ITYLCM) + IF(NESP.EQ.1) THEN + CALL LCMLEN(JPLIB,'CHI',LENGTZ,ITYLCM) + ELSE + CALL LCMLEN(JPLIB,'CHI--01',LENGTZ,ITYLCM) + ENDIF + IF((ILONG.GT.0).AND.(LENGTZ.GT.0)) THEN + IF(NESP.EQ.1) THEN + CALL LCMGET(JPLIB,'CHI',GA1) + ELSE + CALL LCMGET(JPLIB,'CHI--01',GA1) + ENDIF + LFISS=.FALSE. + DO 425 IGR=1,NGROUP + LFISS=LFISS.OR.(GA1(IGR).GT.0.0) + 425 CONTINUE + IF(.NOT.LFISS) GO TO 455 + DO 430 IFIS=1,NFISSI + IWFIS=INDFIS(IBM,IFIS) + IF((IWFIS.EQ.ISOT).OR.(IWFIS.EQ.0)) THEN + KFIS=IFIS + GO TO 450 + ENDIF + 430 CONTINUE + NFISSI=NFISSI+1 + IF(NFISSI.GT.MAXNFI) CALL XABORT('LIBDEN: INDFIS IS FULL.') + KFIS=NFISSI + DO 440 JBM=1,NBMIX + INDFIS(JBM,KFIS)=0 + 440 CONTINUE + 450 INDFIS(IBM,KFIS)=ISOT + ENDIF + 455 CONTINUE + ENDIF + 460 CONTINUE + IF(NFISS0.GT.0) THEN + ALLOCATE(WRK1(NBM0,NFISS0*NESP),WRK2(NBM0,NFISS0*NESP)) + DO 480 LLL=1,NGROUP + IF(MASKL(LLL).OR.LALL) THEN + DO 465 IDEL=0,NDEL + ZNUS(:NBMIX*MAXNFI*NESP,LLL,IDEL)=0.0 + ZCHI(:NBMIX*MAXNFI*NESP,LLL,IDEL)=0.0 + 465 CONTINUE + KPLIB=IPGRP(LLL,1) + CALL LCMLEN(KPLIB,'NUSIGF',ILONG,ITYLCM) + IF(ILONG.NE.NBM0*NFISS0*NESP) THEN + CALL XABORT('LIBDEN: NBM ERROR.') + ENDIF + CALL LCMGET(KPLIB,'NUSIGF',WRK1) + CALL LCMGET(KPLIB,'CHI',WRK2) + DO 467 IFIS=1,NFISS0*NESP + DO 466 IBM=1,NBM0 + ZNUS((IFIS-1)*NBMIX+IBM,LLL,0)=WRK1(IBM,IFIS) + ZCHI((IFIS-1)*NBMIX+IBM,LLL,0)=WRK2(IBM,IFIS) + 466 CONTINUE + 467 CONTINUE + DO 475 IDEL=1,NDEL + WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL + CALL LCMLEN(KPLIB,TEXT12,ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + CALL LCMGET(KPLIB,TEXT12,WRK1) + WRITE(TEXT12,'(3HCHI,I2.2)') IDEL + CALL LCMGET(KPLIB,TEXT12,WRK2) + DO 471 IFIS=1,NFISS0*NESP + DO 470 IBM=1,NBM0 + ZNUS((IFIS-1)*NBMIX+IBM,LLL,IDEL)=WRK1(IBM,IFIS) + ZCHI((IFIS-1)*NBMIX+IBM,LLL,IDEL)=WRK2(IBM,IFIS) + 470 CONTINUE + 471 CONTINUE + ENDIF + 475 CONTINUE + ENDIF + 480 CONTINUE + DEALLOCATE(WRK2,WRK1) + ENDIF + IF(NFISSI.GT.0) THEN + DO 525 ISP=1,NESP + DO 520 KFIS=1,NFISSI + IF(KFIS.GT.NFISS0*NESP) THEN + DO 492 IDEL=0,NDEL + DO 491 LLL=1,NGROUP + DO 490 IBM=1,NBMIX + IOF=(KFIS-1)*NBMIX*NESP+(ISP-1)*NBMIX+IBM + ZNUS(IOF,LLL,IDEL)=0.0 + ZCHI(IOF,LLL,IDEL)=0.0 + 490 CONTINUE + 491 CONTINUE + 492 CONTINUE + ELSE + DO 510 IBM=1,NBMIX + IWFIS=INDFIS(IBM,KFIS) + IF((IWFIS.NE.0).AND.(MASK(IBM).OR.(.NOT.MASKK))) THEN + DO 505 IDEL=0,NDEL + DO 500 LLL=1,NGROUP + IOF=(KFIS-1)*NBMIX*NESP+(ISP-1)*NBMIX+IBM + ZNUS(IOF,LLL,IDEL)=0.0 + ZCHI(IOF,LLL,IDEL)=0.0 + 500 CONTINUE + 505 CONTINUE + ENDIF + 510 CONTINUE + ENDIF + 520 CONTINUE + 525 CONTINUE +*- + IF(NESP.EQ.1) THEN +* ONE FISSION SPECTRUM (CLASSICAL CASE) + DO 585 KFIS=1,NFISSI + DO 580 IBM=1,NBMIX + IWFIS=INDFIS(IBM,KFIS) + IF((IWFIS.NE.0).AND.(MASK(IBM).OR.(.NOT.MASKK))) THEN + IF(LSAME) THEN + IOF=IBM + ELSE + IOF=(KFIS-1)*NBMIX+IBM + ENDIF + JPLIB=IPISO(IWFIS) + IF(.NOT.C_ASSOCIATED(JPLIB)) GO TO 580 +*- + DENISO=DEN(IWFIS) + DO 570 IXSPER=1,NXSPER + CALL LCMGET(JPLIB,'NUSIGF '//NORD(IXSPER),GA1) + DO 530 LLL=1,NGROUP + ZNUS(IOF,LLL,0)=ZNUS(IOF,LLL,0)+GA1(LLL)*DENISO + 530 CONTINUE + IF(NDEL.GT.0) THEN + WRITE(TEXT12,'(6HNUSIGF,I2.2,A4)') NDEL,NORD(IXSPER) + CALL LCMLEN(JPLIB,TEXT12,ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + DO 545 IDEL=1,NDEL + WRITE(TEXT12,'(6HNUSIGF,I2.2,A4)') IDEL,NORD(IXSPER) + CALL LCMGET(JPLIB,TEXT12,GA1) + DO 540 LLL=1,NGROUP + ZNUS(IOF,LLL,IDEL)=ZNUS(IOF,LLL,IDEL)+GA1(LLL)* + 1 DENISO + 540 CONTINUE + 545 CONTINUE + ENDIF + WRITE(TEXT12,'(3HCHI,I2.2,3X,A4)') NDEL,NORD(IXSPER) + CALL LCMLEN(JPLIB,TEXT12,ILONG,ITYLCM) + IF((ILONG.GT.0).AND.(IXSPER.EQ.1)) THEN + DO 555 IDEL=1,NDEL + WRITE(TEXT12,'(3HCHI,I2.2,3X,A4)') IDEL,NORD(IXSPER) + CALL LCMGET(JPLIB,TEXT12,GA1) + DO 550 LLL=1,NGROUP + ZCHI(IOF,LLL,IDEL)=GA1(LLL) + 550 CONTINUE + 555 CONTINUE + ENDIF + ENDIF + IF(IXSPER.EQ.1) THEN + CALL LCMGET(JPLIB,'CHI '//NORD(IXSPER),GA1) + DO 560 LLL=1,NGROUP + ZCHI(IOF,LLL,0)=GA1(LLL) + 560 CONTINUE + ENDIF + DENISO=DENISO*TIMFCT + 570 CONTINUE + ENDIF + 580 CONTINUE + 585 CONTINUE + ELSE +* NESP>1 MULTIPLE FISSION SPECTRA CASE + DO 662 ISP=1,NESP + DO 661 KFIS=1,NFISSI + DO 660 IBM=1,NBMIX + IWFIS=INDFIS(IBM,KFIS) + IF((IWFIS.NE.0).AND.(MASK(IBM).OR.(.NOT.MASKK))) THEN + IF(LSAME) THEN + IOF=IBM + ELSE + IOF=(KFIS-1)*NBMIX*NESP+(ISP-1)*NBMIX+IBM + ENDIF + JPLIB=IPISO(IWFIS) + IF(.NOT.C_ASSOCIATED(JPLIB)) GO TO 660 +*- + DENISO=DEN(IWFIS) + DO 650 IXSPER=1,NXSPER + CALL LCMGET(JPLIB,'NUSIGF '//NORD(IXSPER),GA1) + DO 610 LLL=IESP(ISP)+1,IESP(ISP+1) + ZNUS(IOF,LLL,0)=ZNUS(IOF,LLL,0)+GA1(LLL)*DENISO + 610 CONTINUE + IF((NDEL.GT.0).AND.(ISP.EQ.1)) THEN + WRITE(TEXT12,'(6HNUSIGF,I2.2,A4)') NDEL,NORD(IXSPER) + CALL LCMLEN(JPLIB,TEXT12,ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + DO 625 IDEL=1,NDEL + WRITE(TEXT12,'(6HNUSIGF,I2.2,A4)') IDEL,NORD(IXSPER) + CALL LCMGET(JPLIB,TEXT12,GA1) + DO 620 LLL=1,NGROUP + ZNUS(IOF,LLL,IDEL)=ZNUS(IOF,LLL,IDEL)+GA1(LLL)* + 1 DENISO + 620 CONTINUE + 625 CONTINUE + ENDIF + WRITE(TEXT12,'(3HCHI,I2.2,3X,A4)') NDEL,NORD(IXSPER) + CALL LCMLEN(JPLIB,TEXT12,ILONG,ITYLCM) + IF((ILONG.GT.0).AND.(IXSPER.EQ.1)) THEN + DO 635 IDEL=1,NDEL + WRITE(TEXT12,'(3HCHI,I2.2,3X,A4)') IDEL,NORD(IXSPER) + CALL LCMGET(JPLIB,TEXT12,GA1) + DO 630 LLL=1,NGROUP + ZCHI(IOF,LLL,IDEL)=GA1(LLL) + 630 CONTINUE + 635 CONTINUE + ENDIF + ENDIF + IF(IXSPER.EQ.1) THEN + WRITE(TEXT2,'(I2.2)') ISP + TEXT12='CHI--'//TEXT2//' '//NORD(IXSPER) + CALL LCMLEN(JPLIB,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.NGROUP) THEN + CALL LCMGET(JPLIB,TEXT12,GA1) + DO 640 LLL=1,NGROUP + ZCHI(IOF,LLL,0)=GA1(LLL) + 640 CONTINUE + ENDIF + ENDIF + DENISO=DENISO*TIMFCT + 650 CONTINUE + ENDIF + 660 CONTINUE + 661 CONTINUE + 662 CONTINUE + ENDIF +*- + DO 680 LLL=1,NGROUP + IF(MASKL(LLL).OR.LALL) THEN + KPLIB=IPGRP(LLL,1) + ILONG=NBMIX*NFISSI*NESP + IF(LSAME) ILONG=NBMIX + CALL LCMPUT(KPLIB,'NUSIGF',ILONG,2,ZNUS(1,LLL,0)) + CALL LCMPUT(KPLIB,'CHI',ILONG,2,ZCHI(1,LLL,0)) + DO 670 IDEL=1,NDEL + WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL + CALL LCMPUT(KPLIB,TEXT12,ILONG,2,ZNUS(1,LLL,IDEL)) + WRITE(TEXT12,'(3HCHI,I2.2)') IDEL + CALL LCMPUT(KPLIB,TEXT12,ILONG,2,ZCHI(1,LLL,IDEL)) + 670 CONTINUE + ENDIF + 680 CONTINUE + ENDIF +*---- +* PROCESS THE EXTRA VECTOR EDITS. +*---- + DO 770 IED=1,NED + WRITE(CV,'(2A4)') (NAMEAD(I0,IED),I0=1,2) + IF(CV(:2).EQ.'NW') GO TO 770 + IF(CV.EQ.'TRANC') GO TO 770 + IF((CV(:3).EQ.'BST').OR.(CV(:3).EQ.'CST')) GO TO 770 + IF(CV(:8).EQ.'H-FACTOR') GO TO 770 + EXIST=.FALSE. + DO 740 IBM=1,NBMIX + IF(MASK(IBM).OR.(.NOT.MASKK)) THEN + DO 690 LLL=1,NGROUP + GAF(IBM,LLL,1)=0.0 + 690 CONTINUE + DO 730 ISOT=1,NBISO + IF((MIX(ISOT).NE.IBM).OR.(DEN(ISOT).EQ.0.0)) GO TO 730 + JPLIB=IPISO(ISOT) + IF(.NOT.C_ASSOCIATED(JPLIB)) GO TO 730 +*- + DENISO=DEN(ISOT) + DO 710 IXSPER=1,NXSPER + CALL LCMLEN(JPLIB,CV(:8)//NORD(IXSPER),ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 720 + EXIST=.TRUE. + CALL LCMGET(JPLIB,CV(:8)//NORD(IXSPER),GA1) + DO 700 LLL=1,NGROUP + GAF(IBM,LLL,1)=GAF(IBM,LLL,1)+GA1(LLL)*DENISO + 700 CONTINUE + DENISO=DENISO*TIMFCT + 710 CONTINUE +*- + 720 CONTINUE + 730 CONTINUE + ENDIF + 740 CONTINUE + DO 760 LLL=1,NGROUP + IF(MASKL(LLL).OR.LALL) THEN + KPLIB=IPGRP(LLL,1) + IF(MASKK) THEN + CALL LCMLEN(KPLIB,CV,ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + EXIST=.TRUE. + GAF(:NBMIX,LLL,2)=0.0 + CALL LCMGET(KPLIB,CV,GAF(1,LLL,2)) + DO 750 IBM=1,NBMIX + IF(.NOT.MASK(IBM)) GAF(IBM,LLL,1)=GAF(IBM,LLL,2) + 750 CONTINUE + ENDIF + ENDIF + IF(EXIST) CALL LCMPUT(KPLIB,CV,NBMIX,2,GAF(1,LLL,1)) + ENDIF + 760 CONTINUE + 770 CONTINUE +* + CALL LCMGET(IPLIB,'ENERGY',GA1) + IF(GA1(NGROUP+1).EQ.0.0) GA1(NGROUP+1)=1.0E-5 + CALL LCMSIX(IPLIB,'MACROLIB',1) + IF(NED.GT.0) CALL LCMPUT(IPLIB,'ADDXSNAME-P0',2*NED,3,NAMEAD) + IF(MASKK) THEN + CALL LCMGET(IPLIB,'STATE-VECTOR',IDATA) + IDATA(2)=MAX(NBM0,NBMIX) + IDATA(3)=MAX(IDATA(3),NL) + IDATA(4)=NFISSI*NESP + IDATA(5)=MAX(IDATA(5),NED) + ELSE + IDATA(1)=NGROUP + IDATA(2)=NBMIX + IDATA(3)=NL + IDATA(4)=NFISSI*NESP + IDATA(5)=NED + TEXT12='L_MACROLIB' + CALL LCMPTC(IPLIB,'SIGNATURE',12,TEXT12) + CALL LCMPUT(IPLIB,'ENERGY',NGROUP+1,2,GA1) + ENDIF +*---- +* COMPUTE 1/V (ENER IS IN EV, NEUTRON MASS IS IN KG) +*---- + IF((.NOT.LOVERV).AND.((HPRT1.EQ.'N').OR.(HPRT1.EQ.'NEUT').OR. + 1 (HPRT1.EQ.' '))) THEN + DO 800 LLL=1,NGROUP + ENEAVG=SQRT(GA1(LLL)*GA1(LLL+1)) + ZNU=1.0/(SQRT(ENEAVG)*SQFMAS) + DO 790 IBM=1,NBMIX + GAR(IBM,1)=REAL(ZNU) + 790 CONTINUE + KPLIB=IPGRP(LLL,1) + CALL LCMPUT(KPLIB,'OVERV',NBMIX,2,GAR(1,1)) + 800 CONTINUE + ENDIF + DEALLOCATE(GA1) +*---- +* SET THE STATE VECTOR +*---- + IF(LSAME) IDATA(4)=MIN(NFISSI*NESP,1) + IDATA(6)=ITRANC + IF(ITRANC.NE.0) IDATA(6)=2 + IDATA(7)=NDEL + IDATA(8)=0 + IDATA(9)=0 + IF(LSTRD) IDATA(9)=1 + IDATA(10)=0 + IF(LWP1) IDATA(10)=1 + DO 810 I=11,NSTATE + IDATA(I)=0 + 810 CONTINUE + CALL LCMLEN(IPLIB,'SPH',ILONG,ITYLCM) + IF(ILONG.NE.0) IDATA(14)=1 + CALL LCMPUT(IPLIB,'TIMESTAMP',3,2,TMPDAY) + CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,IDATA) +*---- +* RECOVER THE PRECURSOR DECAY CONSTANTS. +*---- + IF(NDEL*NFISSI.GT.0) THEN + IF(NFISS0.GT.0) THEN + CALL LCMLEN(IPLIB,'LAMBDA-D',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + GA3(:NDEL,1)=0.0 + ELSE + CALL LCMGET(IPLIB,'LAMBDA-D',GA3(1,1)) + ENDIF + ENDIF + DO 825 KFIS=NFISS0+1,NFISSI + DO 820 IDEL=1,NDEL + GA3(IDEL,KFIS)=0.0 + 820 CONTINUE + 825 CONTINUE + CALL LCMSIX(IPLIB,' ',2) + DO 835 KFIS=1,NFISSI + DO 830 IBM=1,NBMIX + IWFIS=INDFIS(IBM,KFIS) + IF((IWFIS.NE.0).AND.(MASK(IBM).OR.(.NOT.MASKK))) THEN + JPLIB=IPISO(IWFIS) + IF(.NOT.C_ASSOCIATED(JPLIB)) GO TO 830 + CALL LCMLEN(JPLIB,'LAMBDA-D',ILONG,ITYLCM) + IF(LSAME.AND.(ILONG.GT.0)) THEN + CALL LCMGET(JPLIB,'LAMBDA-D',GA3(1,1)) + ELSE IF(ILONG.GT.0) THEN + CALL LCMGET(JPLIB,'LAMBDA-D',GA3(1,KFIS)) + ENDIF + ENDIF + 830 CONTINUE + 835 CONTINUE + CALL LCMSIX(IPLIB,'MACROLIB',1) + IF(LSAME) THEN + CALL LCMPUT(IPLIB,'LAMBDA-D',NDEL,2,GA3(1,1)) + ELSE + CALL LCMPUT(IPLIB,'LAMBDA-D',NDEL*NFISSI,2,GA3) + ENDIF + ENDIF +* + IF((NFISSI.GT.0).AND.(.NOT.LSAME)) THEN + CALL LCMPUT(IPLIB,'FISSIONINDEX',NBMIX*NFISSI,1,INDFIS) + ENDIF +* + DO 850 LLL=1,NGROUP + IF(MASKL(LLL).OR.LALL) THEN + KPLIB=IPGRP(LLL,1) + DO 840 M=0,NL-1 + IF(M.LE.10) THEN + CM=HCM(M)//' ' + ELSE + WRITE(CM,'(I2.2,2X)') M + ENDIF + CALL LCMPUT(KPLIB,'CHECK'//CM,NBMIX,2,CHECK(1,LLL,M+1)) + 840 CONTINUE + ENDIF + 850 CONTINUE + CALL LCMSIX(IPLIB,' ',2) +*---- +* RECOVER THE INTEGRATED FLUX +*---- + CALL LCMLEN(IPLIB,'MIXTURESVOL',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + ALLOCATE(VOLMIX(NBMIX),NWTMIX(NGROUP),FLUX(NBMIX,NGROUP,2)) + CALL LCMGET(IPLIB,'MIXTURESVOL',VOLMIX) + LWT0=.FALSE. + LWT1=.FALSE. + FLUX(:NBMIX,:NGROUP,:2)=0.0 + DO 860 ISOT=1,NBISO + IBM=MIX(ISOT) + IF(IBM.GT.0) THEN + JPLIB=IPISO(ISOT) + IF(C_ASSOCIATED(JPLIB)) THEN + CALL LCMLEN(JPLIB,'NWT0',ILONG,ITYLCM) + IF(ILONG.EQ.NGROUP) THEN + LWT0=.TRUE. + CALL LCMGET(JPLIB,'NWT0',NWTMIX) + DO IGR=1,NGROUP + FLUX(IBM,IGR,1)=NWTMIX(IGR)*VOLMIX(IBM) + ENDDO + ENDIF + CALL LCMLEN(JPLIB,'NWT1',ILONG,ITYLCM) + IF(ILONG.EQ.NGROUP) THEN + LWT1=.TRUE. + CALL LCMGET(JPLIB,'NWT1',NWTMIX) + DO IGR=1,NGROUP + FLUX(IBM,IGR,2)=NWTMIX(IGR)*VOLMIX(IBM) + ENDDO + ENDIF + ENDIF + ENDIF + 860 CONTINUE + CALL LCMSIX(IPLIB,'MACROLIB',1) + CALL LCMPUT(IPLIB,'VOLUME',NBMIX,2,VOLMIX) + JPLIB=LCMGID(IPLIB,'GROUP') + DO 870 IGR=1,NGROUP + KPLIB=LCMGIL(JPLIB,IGR) + IF(LWT0) CALL LCMPUT(KPLIB,'FLUX-INTG',NBMIX,2,FLUX(1,IGR,1)) + IF(LWT1) CALL LCMPUT(KPLIB,'FLUX-INTG-P1',NBMIX,2,FLUX(1,IGR,2)) + 870 CONTINUE + CALL LCMSIX(IPLIB,' ',2) + DEALLOCATE(FLUX,NWTMIX,VOLMIX) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 880 DEALLOCATE(DENMAT) + DEALLOCATE(HNPART,C2PART,NGPART) + DEALLOCATE(LMADE) + DEALLOCATE(IPGRP) + DEALLOCATE(ZCHI,ZNUS,CHECK,SCAT,GAF,GAR,GA3,GA2) + DEALLOCATE(NJJ,IJJ,INDFIS,IPOS,IJJM,NJJM) + RETURN +*---- +* FORMAT +*---- + 6000 FORMAT(' WARNING IN LIBDEN FOR PERTURBATION'/ + > ' EXTRAPOLATION BELOW PRETURBATION TABLES'/ + > ' INITIAL TIME = ',F15.6,' DAYS'/ + > ' EXTRAPOLATION TIME = ',F15.6,' DAYS') + 6001 FORMAT(' WARNING IN LIBDEN FOR PERTURBATION'/ + > ' EXTRAPOLATION ABOVE PRETURBATION TABLES'/ + > ' FINAL TIME = ',F15.6,' DAYS'/ + > ' EXTRAPOLATION TIME = ',F15.6,' DAYS') + END diff --git a/Dragon/src/LIBDEP.F b/Dragon/src/LIBDEP.F new file mode 100644 index 0000000..e1b539a --- /dev/null +++ b/Dragon/src/LIBDEP.F @@ -0,0 +1,313 @@ +*DECK LIBDEP + SUBROUTINE LIBDEP(IPLIB,IMPX,NDEPL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read the information related to the depletion calculation. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert and G. Marleau +* +*Parameters: input +* IPLIB pointer to the internal microscopic cross section library +* (L_LIBRARY signature). +* IMPX print flag. +* +*Parameters: output +* NDEPL number of depleting isotopes. +* +*----------------------------------------------------------------------- +* + USE GANLIB +#if defined(HDF5_LIB) + USE hdf5_wrap +#endif /* defined(HDF5_LIB) */ + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + INTEGER IMPX,NDEPL +*---- +* LOCAL PARAMETERS +*---- + TYPE(C_PTR) IPDRL + INTEGER IOUT,NSTATE,MAXR,INDIC,NEL,IEVOT,NITMA,NDFI, + > NDFP,NHEAVY,NLIGHT,NOTHER,NSTABL,NREAC,NPAR, + > ITEXT4,I,J,ISTA,ILONG,ITYLCM,NBESP + REAL FLOTT + PARAMETER (IOUT=6,NSTATE=40,MAXR=12) + DOUBLE PRECISION DBLINP + CHARACTER NMDEPL(MAXR)*8,TEXT4*4,HSMG*131,CFILNA*64, + > HHLIB*8,TEXT12*12,NAMLCM*12,NAMMY*12 + LOGICAL EMPTY,LCM,LEXIST + INTEGER ISTATE(NSTATE) +#if defined(HDF5_LIB) + CHARACTER CFILNA1*64,CFILNA2*64 +#endif /* defined(HDF5_LIB) */ +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: INAM,IZAE,HREAC,IDR,KPAR, + > ITNAM,ITZEA,MATNO,KPAX + REAL, ALLOCATABLE, DIMENSION(:) :: RER,RRD,BPAR,YIELD,BPAX,ENER +#if defined(HDF5_LIB) + INTEGER, ALLOCATABLE, DIMENSION(:) :: DIMS_AP +#endif /* defined(HDF5_LIB) */ +*---- +* DATA STATEMENTS +*---- + SAVE NMDEPL + DATA NMDEPL/'DECAY ','NFTOT ','NG ','N2N ', + > 'N3N ','N4N ','NA ','NP ', + > 'N2A ','NNP ','ND ','NT '/ +*---- +* READ INFORMATION AVAILABLE ON INPUT +*---- + CALL REDGET(INDIC,NEL,FLOTT,TEXT4,DBLINP) + IEVOT=-99 + NBESP=1 + IF(INDIC.EQ.1) THEN + IEVOT=0 + ELSE IF((INDIC.EQ.3).AND.(TEXT4.EQ.'LIB:')) THEN + CALL REDGET(INDIC,NITMA,FLOTT,HHLIB,DBLINP) + IF(INDIC.NE.3) THEN + CALL XABORT('LIBDEP: CHARACTER LIBRARY NAME REQUIRED.') + ELSE IF((HHLIB.NE.'DRAGON ') .AND. (HHLIB.NE.'WIMSAECL') .AND. + > (HHLIB.NE.'WIMSD4 ') .AND. (HHLIB.NE.'WIMSE ') .AND. + > (HHLIB.NE.'APLIB2 ') .AND. (HHLIB.NE.'APLIB3 ') .AND. + > (HHLIB.NE.'NDAS ') .AND. (HHLIB.NE.'APXSM ') ) THEN + WRITE(HSMG,'(30HLIBDEP: INVALID EVOL LIB TYPE ,A8)') HHLIB + CALL XABORT(HSMG) + ENDIF + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DBLINP) + IF((INDIC.NE.3).OR.(TEXT4.NE.'FIL:')) + > CALL XABORT('LIBDEP: FIL: EXPECTED.') + CFILNA=' ' + CALL REDGET(INDIC,NITMA,FLOTT,CFILNA,DBLINP) + IF(INDIC.NE.3) CALL XABORT('LIBDEP: CHARACTER DATA EXPECTED.') + IF(HHLIB.EQ.'DRAGON') THEN + TEXT12=CFILNA(:12) + CALL LCMINF(IPLIB,NAMLCM,NAMMY,EMPTY,ILONG,LCM) + IF(TEXT12.EQ.NAMLCM) THEN + IPDRL=IPLIB + ELSE + INQUIRE(FILE=TRIM(TEXT12),EXIST=LEXIST) + IF(.NOT.LEXIST) THEN + WRITE(HSMG,'(17HLIBDEP: XSM FILE ,A,14H DOESNT EXIST.)') + > TRIM(TEXT12) + CALL XABORT(HSMG) + ENDIF + CALL LCMOP(IPDRL,TEXT12,2,2,0) + ENDIF + CALL LCMLEN(IPDRL,'DEPL-CHAIN',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + CALL XABORT('LIBDEP: NO BURNUP DATA ON DRAGLIB NAMED '// + > TEXT12//'.') + ENDIF + CALL LCMSIX(IPDRL,'DEPL-CHAIN',1) + CALL LCMGET(IPDRL,'STATE-VECTOR',ISTATE) + NDEPL=ISTATE(1) + NDFI=ISTATE(2) + NDFP=ISTATE(3) + NHEAVY=ISTATE(4) + NLIGHT=ISTATE(5) + NOTHER=ISTATE(6) + NSTABL=ISTATE(7) + NREAC=ISTATE(8) + NPAR=ISTATE(9) + NBESP=MAX(1,ISTATE(10)) + ALLOCATE(INAM(3*NDEPL),IZAE(NDEPL),HREAC(2*NREAC), + 1 IDR(NREAC*NDEPL),RER(NREAC*NDEPL),RRD(NDEPL),KPAR(NPAR*NDEPL), + 2 BPAR(NPAR*NDEPL)) + IF(NDFP.GT.0) ALLOCATE(YIELD(NBESP*NDFI*NDFP)) + CALL LCMGET(IPDRL,'STATE-VECTOR',ISTATE) + CALL LCMGET(IPDRL,'ISOTOPESDEPL',INAM) + CALL LCMGET(IPDRL,'CHARGEWEIGHT',IZAE) + CALL LCMGET(IPDRL,'DEPLETE-IDEN',HREAC) + CALL LCMGET(IPDRL,'DEPLETE-REAC',IDR) + CALL LCMGET(IPDRL,'DEPLETE-ENER',RER) + CALL LCMGET(IPDRL,'DEPLETE-DECA',RRD) + CALL LCMGET(IPDRL,'PRODUCE-REAC',KPAR) + CALL LCMGET(IPDRL,'PRODUCE-RATE',BPAR) + IF(NDFI*NDFP.GT.0) CALL LCMGET(IPDRL,'FISSIONYIELD',YIELD) + CALL LCMSIX(IPDRL,' ',2) + IF(TEXT12.NE.NAMLCM) CALL LCMCL(IPDRL,1) + GO TO 20 + ELSE IF(HHLIB.EQ.'WIMSAECL') THEN + CALL LIBEWI(CFILNA,NEL) + IEVOT=2 + ELSE IF(HHLIB.EQ.'WIMSD4') THEN + CALL LIBENI(CFILNA,NEL) + IEVOT=3 + ELSE IF(HHLIB.EQ.'APLIB2') THEN + CALL LIBEAI(CFILNA,NEL) + IEVOT=4 + ELSE IF(HHLIB.EQ.'NDAS') THEN + CALL LIBND5(CFILNA,NEL) + IEVOT=5 + ELSE IF(HHLIB.EQ.'APXSM') THEN + CALL LIBXS1(CFILNA,NEL) + IEVOT=6 + ELSE IF(HHLIB.EQ.'WIMSE') THEN + CALL LIBENI(CFILNA,NEL) + IEVOT=7 + ELSE IF(HHLIB.EQ.'APLIB3') THEN +#if defined(HDF5_LIB) + I = INDEX(CFILNA, ":") + IF(I.EQ.0) THEN + CFILNA1=CFILNA + CFILNA2=" " + ELSE + CFILNA1=CFILNA(:I-1) + CFILNA2=CFILNA(I+1:) + ENDIF + CALL hdf5_open_file(CFILNA1, IPDRL, .TRUE.) + CALL hdf5_read_data(IPDRL, "Head/nbIs", NEL) + CALL hdf5_close_file(IPDRL) + IF(CFILNA2.NE.' ') THEN + CALL hdf5_open_file(CFILNA2, IPDRL, .TRUE.) + CALL hdf5_get_shape(IPDRL,"/Yields/YieldEnMshInMeV",DIMS_AP) + CALL hdf5_close_file(IPDRL) + NBESP=DIMS_AP(1)-1 + DEALLOCATE(DIMS_AP) + ENDIF + IEVOT=8 +#else + CALL XABORT('LIBDEP: THE HDF5 API IS NOT AVAILABLE(1).') +#endif /* defined(HDF5_LIB) */ + ENDIF + ELSE + CALL XABORT('LIBDEP: INVALID KEY WORD.') + ENDIF + IF(IEVOT.EQ.0.OR.IEVOT.GT.1) THEN +*---- +* ALLOCATE/INITIALIZE WORK VECTORS FOR WIMS-AECL, WIMSD4 +* AND INPUT FILE +*---- + ALLOCATE(ENER(NBESP+1),ITNAM(3*NEL),ITZEA(NEL),MATNO(NEL), + 1 KPAX((NEL+MAXR)*NEL),BPAX((NEL+MAXR)*NEL*NBESP)) + TEXT4=' ' + READ(TEXT4,'(A4)') ITEXT4 + ITNAM(:3*NEL)=ITEXT4 + ITZEA(:NEL)=0 + MATNO(:NEL)=0 + KPAX(:(NEL+MAXR)*NEL)=0 + BPAX(:(NEL+MAXR)*NEL*NBESP)=0.0 + IF(IEVOT.EQ.0) THEN + CALL LIBEIR(MAXR,NEL,NMDEPL,ITNAM,ITZEA,KPAX,BPAX) + ELSE IF(IEVOT.EQ.2) THEN + CALL LIBEWR(CFILNA,MAXR,NEL,ITNAM,KPAX,BPAX) + ELSE IF(IEVOT.EQ.3) THEN + CALL LIBENR(CFILNA,4,MAXR,NEL,ITNAM,KPAX,BPAX) + ELSE IF(IEVOT.EQ.4) THEN + CALL LIBEAR(CFILNA,MAXR,NEL,NMDEPL,ITNAM,ITZEA,KPAX,BPAX) + ELSE IF(IEVOT.EQ.5) THEN + CALL LIBND6(CFILNA,MAXR,NEL,ITNAM,KPAX,BPAX) + ELSE IF(IEVOT.EQ.6) THEN + CALL LIBXS2(CFILNA,MAXR,NEL,NMDEPL,ITNAM,ITZEA,KPAX,BPAX) + ELSE IF(IEVOT.EQ.7) THEN + CALL LIBENR(CFILNA,5,MAXR,NEL,ITNAM,KPAX,BPAX) + ELSE IF(IEVOT.EQ.8) THEN +#if defined(HDF5_LIB) + CALL LIBE3R(CFILNA1,CFILNA2,MAXR,NEL,NBESP,IMPX,ITNAM,ITZEA, + 1 KPAX,BPAX,ENER) +#else + CALL XABORT('LIBDEP: THE HDF5 API IS NOT AVAILABLE(2).') +#endif /* defined(HDF5_LIB) */ + ENDIF + CALL LIBWET(MAXR,NEL,NBESP,NSTATE,NMDEPL,ITNAM,ISTATE,MATNO, + > KPAX,BPAX) + NDEPL=ISTATE(1) + NDFI=ISTATE(2) + NDFP=ISTATE(3) + NHEAVY=ISTATE(4) + NLIGHT=ISTATE(5) + NOTHER=ISTATE(6) + NSTABL=ISTATE(7) + NREAC=ISTATE(8) + NPAR=ISTATE(9) + NBESP=ISTATE(10) + ENDIF +*---- +* ALLOCATE DECAY CHAIN +*---- + NDEPL=MAX(NDEPL,1) + NDFI=MAX(NDFI,1) + NDFP=MAX(NDFP,1) + ALLOCATE(INAM(3*NDEPL),IZAE(NDEPL),IDR(NREAC*NDEPL), + 1 RER(NREAC*NDEPL),RRD(NDEPL),KPAR(NPAR*NDEPL),BPAR(NPAR*NDEPL), + 2 YIELD(NDFI*NDFP*NBESP)) +*---- +* SET DECAY CHAIN +*---- + CALL LIBWED(MAXR,NEL,NBESP,NDEPL,NDFI,NDFP,NHEAVY,NLIGHT,NOTHER, + > NREAC,NPAR,ITNAM,ITZEA,MATNO,KPAX,BPAX,INAM,IZAE,IDR, + > RER,RRD,KPAR,BPAR,YIELD) +*---- +* RELEASE WORK VECTORS FOR WIMS-AECL, WIMS-NEA, DRAGLIB +* AND INPUT FILE +*---- + DEALLOCATE(BPAX,KPAX,MATNO,ITZEA,ITNAM) +*---- +* SELECT USED DEPLETION REACTION NAMES +*---- + ALLOCATE(HREAC(2*NREAC)) + DO 10 I=1,NREAC + READ(NMDEPL(I),'(2A4)') (HREAC(2*(I-1)+J),J=1,2) + 10 CONTINUE +*---- +* PRINT DECAY CHAIN IF REQUIRED +*---- + 20 CALL LIBEPR(IMPX,NBESP,NDEPL,NSTABL,NDFI,NDFP,NREAC,NPAR,INAM, + > HREAC,IDR,RER,RRD,KPAR,BPAR,YIELD,IZAE) +*---- +* SAVE CHAIN +*---- + CALL LCMSIX(IPLIB,'DEPL-CHAIN',1) + CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMPUT(IPLIB,'ISOTOPESDEPL',3*NDEPL,3,INAM) + CALL LCMPUT(IPLIB,'CHARGEWEIGHT',NDEPL,1,IZAE) + CALL LCMPUT(IPLIB,'DEPLETE-IDEN',2*NREAC,3,HREAC) + CALL LCMPUT(IPLIB,'DEPLETE-REAC',NREAC*NDEPL,1,IDR) + CALL LCMPUT(IPLIB,'DEPLETE-ENER',NREAC*NDEPL,2,RER) + CALL LCMPUT(IPLIB,'DEPLETE-DECA',NDEPL,2,RRD) + CALL LCMPUT(IPLIB,'PRODUCE-REAC',NPAR*NDEPL,1,KPAR) + CALL LCMPUT(IPLIB,'PRODUCE-RATE',NPAR*NDEPL,2,BPAR) + IF(NDFI*NDFP.GT.0) THEN + CALL LCMPUT(IPLIB,'FISSIONYIELD',NDFI*NDFP*NBESP,2,YIELD) + IF(NBESP.GT.1) CALL LCMPUT(IPLIB,'ENERGY-YIELD',NBESP+1,2,ENER) + ENDIF + CALL LCMSIX(IPLIB,' ',2) + IF(IMPX.GE.2) WRITE(IOUT,6000) (ISTATE(ISTA),ISTA=1,10) +*---- +* RELEASE DECAY CHAIN +*---- + DEALLOCATE(HREAC) + IF(NDFP.GT.0) DEALLOCATE(YIELD) + DEALLOCATE(BPAR,KPAR,RER,RRD,IDR,IZAE,INAM) + IF(IEVOT.GT.1) DEALLOCATE(ENER) + RETURN +*---- +* FORMAT +*---- + 6000 FORMAT(/' STATE-VECTOR FOR DEPLETION CHAIN'/' -------'/ + > ' NDEPL ',I6,' (NUMBER OF DEPLETING ISOTOPES)'/ + > ' NDFI ',I6,' (NUMBER OF DIRECT FISSILE ISOTOPES)'/ + > ' NDFP ',I6,' (NUMBER OF DIRECT FISSION PRODUCT)'/ + > ' NHEAVY ',I6,' (NUMBER OF HEAVY ISOTOPES)'/ + > ' NLIGHT ',I6,' (NUMBER OF FISSION PRODUCTS)'/ + > ' NOTHER ',I6,' (NUMBER OF OTHER ISOTOPES)'/ + > ' NSTABL ',I6,' (NUMBER OF STABLE ISOTOPES PRODUCING ENERGY)'/ + > ' NREAC ',I6,' (MAXIMUM NUMBER OF DEPLETION REACTIONS)'/ + > ' NPAR ',I6,' (MAXIMUM NUMBER OF PARENT REACTIONS)'/ + > ' NBESP ',I6,' (NUMBER OF ENERGY-DEPENDENT FISSION YIELD MAT', + > 'RICES)'/) + END diff --git a/Dragon/src/LIBDI1.f b/Dragon/src/LIBDI1.f new file mode 100644 index 0000000..ba10359 --- /dev/null +++ b/Dragon/src/LIBDI1.f @@ -0,0 +1,52 @@ +*DECK LIBDI1 + SUBROUTINE LIBDI1 (MAXDIL,IPDRL,HNISOR,NDIL,DILUT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find the dilutions corresponding to a resonant isotope within a +* library in Draglib format. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXDIL maximum number of dilutions. +* IPDRL pointer to the Draglib (L_DRAGLIB signature). +* HNISOR library name of the resonant isotope. +* +*Parameters: output +* NDIL number of finite dilutions. +* DILUT dilutions. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPDRL + INTEGER MAXDIL,NDIL + CHARACTER HNISOR*12 + REAL DILUT(MAXDIL) +* + CALL LCMLEN (IPDRL,HNISOR,ILEN,ITYLCM) + IF(ILEN.EQ.0) CALL XABORT('LIBDI1: ISOTOPE '//HNISOR//' NOT AVAI' + 1 //'LABLE IN THE DRAGLIB.') + CALL LCMSIX (IPDRL,HNISOR,1) + CALL LCMLEN (IPDRL,'TEMPERATURE',NTMP,ITYLCM) + IF(NTMP.GT.0) CALL LCMSIX (IPDRL,'SUBTMP0001',1) + CALL LCMLEN (IPDRL,'DILUTION',NDIL,ITYLCM) + IF(NDIL+1.GT.MAXDIL) CALL XABORT('LIBDI1: MAXDIL IS TOO SMALL.') + IF(NDIL.GT.0) CALL LCMGET (IPDRL,'DILUTION',DILUT) + DILUT(NDIL+1)=1.0E10 + IF(NTMP.GT.0) CALL LCMSIX (IPDRL,' ',2) + CALL LCMSIX (IPDRL,' ',2) + RETURN + END diff --git a/Dragon/src/LIBDI2.f b/Dragon/src/LIBDI2.f new file mode 100644 index 0000000..7e0d459 --- /dev/null +++ b/Dragon/src/LIBDI2.f @@ -0,0 +1,168 @@ +*DECK LIBDI2 + SUBROUTINE LIBDI2 (MAXDIL,NAMFIL,HNISOR,NDIL,DILUT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find the dilutions corresponding to a resonant isotope within a +* library in matxs (njoy-89) format. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXDIL maximum number of dilutions. +* NAMFIL name of the MATXS file. +* HNISOR library name of the resonant isotope. +* +*Parameters: output +* NDIL number of finite dilutions. +* DILUT dilutions. +* +*----------------------------------------------------------------------- +* + USE XDRMOD + IMPLICIT CHARACTER*6 (H) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXDIL,NDIL + CHARACTER NAMFIL*(*),HNISOR*12 + REAL DILUT(MAXDIL) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MULT=2,MAXA=1000) + REAL A(MAXA) + INTEGER IA(MAXA) + CHARACTER HSMG*131 + DOUBLE PRECISION HA(MAXA/2) + EQUIVALENCE (A(1),IA(1),HA(1)) +* + NIN=KDROPN(NAMFIL,2,2,0) + IF(NIN.LE.0) THEN + WRITE (HSMG,'(35HLIBDI2: UNABLE TO OPEN LIBRARY FILE,1X,A16, + 1 6H. NIN=,I4,1H.)') NAMFIL,NIN + CALL XABORT(HSMG) + ENDIF + NDIL=0 + NWDS=1+3*MULT + IREC=1 +* -------------------------------- + CALL XDREED (NIN,IREC,A(1),NWDS) +* -------------------------------- +* + NWDS=3 + IREC=2 +* -------------------------------- + CALL XDREED (NIN,IREC,A(1),NWDS) +* -------------------------------- + NPART=IA(1) + NTYPE=IA(2) + NHOLL=IA(3) + NWDS=NHOLL*MULT + IF(NWDS.GT.MAXA) + 1 CALL XABORT('LIBDI2: INSUFFICIENT VALUE OF MAXA(1).') + IREC=3 +* -------------------------------- + CALL XDREED (NIN,IREC,A(1),NWDS) +* -------------------------------- + NWDS=(NPART+NTYPE)*MULT+6*NTYPE+NPART + IF(NWDS.GT.MAXA) + 1 CALL XABORT('LIBDI2: INSUFFICIENT VALUE OF MAXA(2).') + IREC=4 +* -------------------------------- + CALL XDREED (NIN,IREC,A(1),NWDS) +* -------------------------------- + NWC=NPART+NTYPE + IF((NWDS/2)*2.NE.NWDS) NWDS=NWDS+1 + L2=1+NWDS + L2H=(L2-1)/MULT+1 + NEX1=(NPART+NTYPE)*MULT+6*NTYPE + IREC=IREC+NPART + IRZT=5+NPART + DO 680 IT=1,NTYPE + WRITE(HTYPE,'(A6)') HA(NPART+IT) + IF(HTYPE.NE.'NSCAT') GO TO 680 + NDEX=(NPART+NTYPE)*MULT+IT + NMAT=IA(NDEX) + NDEX=NDEX+NTYPE + NINP=IA(NDEX) + NDEX=NDEX+NTYPE + NING=IA(NDEX) + NDEX=NDEX+NTYPE + NOUTP=IA(NDEX) + NDEX=NDEX+NTYPE + NOUTG=IA(NDEX) + NDEX=NDEX+NTYPE + LOCT=IA(NDEX) + NWDS=(2+MULT)*NMAT+NINP+NOUTP+1 + IF(L2+NWDS-1.GT.MAXA) + 1 CALL XABORT('LIBDI2: INSUFFICIENT VALUE OF MAXA(3).') + IREC=LOCT+IRZT +* --------------------------------- + CALL XDREED (NIN,IREC,A(L2),NWDS) +* --------------------------------- + IF((NWDS/2)*2.NE.NWDS) NWDS=NWDS+1 + LMC=L2+NWDS + LMCH=L2H+NWDS/MULT + NSBLK=IA(L2+NMAT*(MULT+2)+NINP+NOUTP) + IRZM=IREC+1 +*---- +* MATERIAL/ISOTOPE LOOP +*---- + DO 670 IM=1,NMAT + WRITE (HMAT,'(A6)') HA(L2H-1+IM) + IF(HMAT.NE.HNISOR(:6)) GO TO 670 +* + LOC=L2-1+MULT*NMAT+IM + NSUBM=IA(LOC) + LOCM=IA(LOC+NMAT) + IREC=LOCM+IRZM + NWDS=MULT+1+6*NSUBM + IF(LMC+NWDS-1.GT.MAXA) + 1 CALL XABORT('LIBDI2: INSUFFICIENT VALUE OF MAXA(4).') +* ---------------------------------- + CALL XDREED (NIN,IREC,A(LMC),NWDS) +* ---------------------------------- + NWDS=NWDS+MULT-1 + DO 307 ISUBM=1,NSUBM + DILI=A(LMC+MULT+6*(ISUBM-1)+2) + DO 555 I=1,NDIL + IF(ABS(DILI-DILUT(I)).LT.1.0E-5*ABS(DILI)) GO TO 307 + 555 CONTINUE + DO 556 I=1,NDIL + IF(DILI.LT.DILUT(I)) THEN + DO 557 J=NDIL,I,-1 + DILUT(J+1)=DILUT(J) + 557 CONTINUE + DILUT(I)=DILI + NDIL=NDIL+1 + IF(NDIL.GT.MAXDIL) CALL XABORT('LIBDI2: MAXDIL IS TOO SMALL.') + GO TO 307 + ENDIF + 556 CONTINUE + NDIL=NDIL+1 + IF(NDIL.GT.MAXDIL) CALL XABORT('LIBDI2: MAXDIL IS TOO SMALL.') + DILUT(NDIL)=DILI + 307 CONTINUE + 670 CONTINUE + 680 CONTINUE + NDIL=NDIL-1 + IF(NDIL.LT.0) CALL XABORT('LIBDI2: UNABLE TO FIND THE TABULATED' + 1 //' DILUTIONS.') + CALL XDRCLS(NIN) + IER=KDRCLS(NIN,1) + IF(IER.LT.0) THEN + WRITE (HSMG,'(36HLIBDI2: UNABLE TO CLOSE LIBRARY FILE,1X,A16, + 1 1H.)') NAMFIL + CALL XABORT(HSMG) + ENDIF + RETURN + END diff --git a/Dragon/src/LIBDI3.f b/Dragon/src/LIBDI3.f new file mode 100644 index 0000000..9b2fbb4 --- /dev/null +++ b/Dragon/src/LIBDI3.f @@ -0,0 +1,167 @@ +*DECK LIBDI3 + SUBROUTINE LIBDI3 (MAXDIL,NAMFIL,HNISOR,NDIL,DILUT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find the dilutions corresponding to a resonant isotope within a +* library in matxs (njoy-91) format. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXDIL maximum number of dilutions. +* NAMFIL name of the MATXS file. +* HNISOR library name of the resonant isotope. +* +*Parameters: output +* NDIL number of finite dilutions. +* DILUT dilutions. +* +*----------------------------------------------------------------------- +* + USE XDRMOD + USE LIBEEDR + IMPLICIT CHARACTER*6 (H) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXDIL,NDIL + CHARACTER NAMFIL*(*),HNISOR*12 + REAL DILUT(MAXDIL) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MULT=2,MAXA=10000) + REAL A(MAXA) + INTEGER IA(MAXA) + CHARACTER HSMG*131 + DOUBLE PRECISION XHA(MAXA/2) + EQUIVALENCE (A(1),IA(1),XHA(1)) +* + ILIBIN=2 + IF(NAMFIL(:1).EQ.'_') ILIBIN=3 + NIN=KDROPN(NAMFIL,2,ILIBIN,0) + IF(NIN.LE.0) THEN + WRITE (HSMG,'(35HLIBDI3: UNABLE TO OPEN LIBRARY FILE,1X,A16, + 1 6H. NIN=,I4,1H.)') NAMFIL,NIN + CALL XABORT(HSMG) + ENDIF + NDIL=0 + NWDS=1+3*MULT + IREC=1 +* --FILE IDENTIFICATION-------------- + IF(ILIBIN.EQ.2) THEN + CALL XDREED (NIN,IREC,A(1),NWDS) + ELSE IF(ILIBIN.EQ.3) THEN + CALL LIBEED (NIN,IREC,A(1),NWDS) + ENDIF +* ----------------------------------- +* + NWDS=6 + IREC=2 +* --FILE CONTROL--------------------- + IF(ILIBIN.EQ.2) THEN + CALL XDREED (NIN,IREC,A(1),NWDS) + ELSE IF(ILIBIN.EQ.3) THEN + CALL LIBEED (NIN,IREC,A(1),NWDS) + ENDIF +* ----------------------------------- + NPART=IA(1) + NTYPE=IA(2) + NHOLL=IA(3) + NMAT=IA(4) +* + NWDS=NHOLL*MULT + IF(NWDS.GT.MAXA) + 1 CALL XABORT('LIBDI3: INSUFFICIENT VALUE OF MAXA(1).') + IREC=3 +* --HOLLERITH IDENTIFICATION--------- + IF(ILIBIN.EQ.2) THEN + CALL XDREED (NIN,IREC,A(1),NWDS) + ELSE IF(ILIBIN.EQ.3) THEN + CALL LIBEED (NIN,IREC,A(1),NWDS) + ENDIF +* ----------------------------------- + NWDS=(NPART+NTYPE+NMAT)*MULT+2*NTYPE+NPART+2*NMAT + IF(NWDS.GT.MAXA) + 1 CALL XABORT('LIBDI3: INSUFFICIENT VALUE OF MAXA(2).') + IREC=4 +* --FILE DATA------------------------ + IF(ILIBIN.EQ.2) THEN + CALL XDREED (NIN,IREC,A(1),NWDS) + ELSE IF(ILIBIN.EQ.3) THEN + CALL LIBEED (NIN,IREC,A(1),NWDS) + ENDIF +* ----------------------------------- + IF((NWDS/2)*2.NE.NWDS) NWDS=NWDS+1 + L2=1+NWDS + IREC=IREC+NPART + IRZM=IREC+1 +* + DO 50 IM=1,NMAT + WRITE (HMAT,'(A6)') XHA(NPART+NTYPE+IM) + IF(HMAT.NE.HNISOR(:6)) GO TO 50 +* + LOC=(NPART+NTYPE+NMAT)*MULT+NPART+2*NTYPE+IM + NSUB=IA(LOC) + LOCM=IA(LOC+NMAT) + IREC=LOCM+IRZM + NWDS=MULT+1+6*NSUB + IF(L2+NWDS-1.GT.MAXA) + 1 CALL XABORT('LIBDI3: INSUFFICIENT VALUE OF MAXA(3).') +* --MATERIAL CONTROL------------------ + IF(ILIBIN.EQ.2) THEN + CALL XDREED (NIN,IREC,A(L2),NWDS) + ELSE IF(ILIBIN.EQ.3) THEN + CALL LIBEED (NIN,IREC,A(L2),NWDS) + ENDIF +* ------------------------------------ + IF((NWDS/2)*2.NE.NWDS) NWDS=NWDS+1 +* + DO 40 ISUBM=1,NSUB + DILI=A(L2+MULT+6*(ISUBM-1)+2) + DO 10 I=1,NDIL + IF(ABS(DILI-DILUT(I)).LT.1.0E-5*ABS(DILI)) GO TO 40 + 10 CONTINUE + DO 30 I=1,NDIL + IF(DILI.LT.DILUT(I)) THEN + DO 20 J=NDIL,I,-1 + DILUT(J+1)=DILUT(J) + 20 CONTINUE + DILUT(I)=DILI + NDIL=NDIL+1 + IF(NDIL.GT.MAXDIL) CALL XABORT('LIBDI3: MAXDIL IS TOO SMALL.') + GO TO 40 + ENDIF + 30 CONTINUE + NDIL=NDIL+1 + IF(NDIL.GT.MAXDIL) CALL XABORT('LIBDI3: MAXDIL IS TOO SMALL.') + DILUT(NDIL)=DILI + 40 CONTINUE + 50 CONTINUE + NDIL=NDIL-1 + IF(NDIL.LT.0) CALL XABORT('LIBDI3: UNABLE TO FIND THE TABULATED' + 1 //' DILUTIONS.') +* --CLOSE CCCC FILE-- + IF(ILIBIN.EQ.2) THEN + CALL XDRCLS(NIN) + ELSE IF(ILIBIN.EQ.3) THEN + CALL LIBCLS() + ENDIF +* ------------------- + IER=KDRCLS(NIN,1) + IF(IER.LT.0) THEN + WRITE (HSMG,'(36HLIBDI3: UNABLE TO CLOSE LIBRARY FILE,1X,A16, + 1 1H.)') NAMFIL + CALL XABORT(HSMG) + ENDIF + RETURN + END diff --git a/Dragon/src/LIBDI4.f b/Dragon/src/LIBDI4.f new file mode 100644 index 0000000..457bc82 --- /dev/null +++ b/Dragon/src/LIBDI4.f @@ -0,0 +1,123 @@ +*DECK LIBDI4 + SUBROUTINE LIBDI4 (MAXDIL,NAMFIL,HSHI,NDIL,DILUT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find the dilutions corresponding to a resonant isotope within a +* library in Apolib-1 format. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXDIL maximum number of dilutions. +* NAMFIL name of the Apolib file. +* HSHI library name of the self-shielding data. +* +*Parameters: output +* NDIL number of finite dilutions. +* DILUT dilutions. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXDIL,NDIL + CHARACTER NAMFIL*(*),HSHI*12 + REAL DILUT(MAXDIL) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MAXIT=1000) + CHARACTER FORM*4,HSMG*131 + INTEGER IT(MAXIT),NTETA(3) + REAL, ALLOCATABLE, DIMENSION(:) :: WORK +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(WORK(MAXDIL)) +* + NIN=KDROPN(NAMFIL,2,2,0) + IF(NIN.LE.0) THEN + WRITE (HSMG,'(35HLIBDI4: UNABLE TO OPEN LIBRARY FILE,1X,A16, + 1 6H. NIN=,I4,1H.)') NAMFIL,NIN + CALL XABORT(HSMG) + ENDIF + I=INDEX(HSHI,' ') + IF(HSHI.EQ.' ') THEN + NISBEF=0 + ELSE IF(I.EQ.0) THEN + READ(HSHI,'(I8)') NISBEF + ELSE + WRITE(FORM,'(2H(I,I1,1H))') I-1 + READ(HSHI,FORM) NISBEF + ENDIF + 10 READ(NIN) INDLOR,NR,NIT,(IT(I),I=1,NIT),(DUMMY,I=1,18) + IF(NIT.GT.MAXIT) CALL XABORT('LIBDI4: INVALID MAXIT.') + IF(INDLOR.EQ.9999) THEN + CALL XABORT('LIBDI4: UNABLE TO FIND ISOTOPE '//HSHI//'.') + ELSE IF(INDLOR.EQ.NISBEF) THEN + NTYPE=0 + JTYSEC=0 + DO 20 IK=1,IT(4) + IF(IT(IK+4).NE.JTYSEC) THEN + NTYPE=NTYPE+1 + NTETA(NTYPE)=1 + JTYSEC=IT(IK+4) + ELSE + NTETA(NTYPE)=NTETA(NTYPE)+1 + ENDIF + 20 CONTINUE + DO 55 I=1,NTYPE + READ (NIN) TEMP,NSEI,(WORK(K),K=1,NSEI) + IF(NSEI.GT.MAXDIL) CALL XABORT('LIBDI4: INVALID MAXDIL.') + IF(I.EQ.1) THEN + NDIL=NSEI + DO 30 K=NSEI,1,-1 + IF(WORK(K).GE.1.0E10) THEN + NDIL=NDIL-1 + ELSE + DILUT(K)=WORK(K) + ENDIF + 30 CONTINUE + DILUT(NDIL+1)=1.0E10 + ELSE + DO 40 K=NSEI,1,-1 + IF((WORK(K).LT.1.0E10).AND.(WORK(K).NE.DILUT(K))) THEN + WRITE(HSMG,'(26HLIBDI4: INVALID DILUTION (,1P,E12.4, + 1 9H) ON TYPE,I2,11H REACTIONS.,E12.4,10H EXPECTED.)') + 2 WORK(K),I,DILUT(K) + CALL XABORT(HSMG) + ENDIF + 40 CONTINUE + ENDIF + DO 50 ITET=2,NTETA(I) + READ(NIN) + 50 CONTINUE + 55 CONTINUE + ELSE + DO 60 K=1,NR + READ(NIN) + 60 CONTINUE + GO TO 10 + ENDIF + IER=KDRCLS(NIN,1) + IF(IER.LT.0) THEN + WRITE (HSMG,'(36HLIBDI4: UNABLE TO CLOSE LIBRARY FILE,1X,A16, + 1 1H.)') NAMFIL + CALL XABORT(HSMG) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(WORK) + RETURN + END diff --git a/Dragon/src/LIBDI5.f b/Dragon/src/LIBDI5.f new file mode 100644 index 0000000..97e749d --- /dev/null +++ b/Dragon/src/LIBDI5.f @@ -0,0 +1,149 @@ +*DECK LIBDI5 + SUBROUTINE LIBDI5 (MAXDIL,NAMFIL,HSHI,NDIL,DILUT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find the dilutions corresponding to a resonant isotope within a +* library in Apolib-2 format. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXDIL maximum number of dilutions. +* NAMFIL name of the APOLIB-2 file. +* HSHI library name of the self-shielding data. +* +*Parameters: output +* NDIL number of finite dilutions. +* DILUT dilutions. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXDIL,NDIL + CHARACTER HSHI*12 + CHARACTER NAMFIL*(*) + REAL DILUT(MAXDIL) +*---- +* LOCAL VARIABLES +*---- + EXTERNAL LIBA21 + CHARACTER HSMG*131,TEXT8*8,TEXT20*20,NOMOBJ*20,TYPOBJ*8,TYPSEG*8 + LOGICAL LISO,LPTHOM + INTEGER ISFICH(3) + INTEGER, ALLOCATABLE, DIMENSION(:) :: VINTE,ITCARO + TYPE(C_PTR) ICHDIM_PTR,ICHTYP_PTR,ICHDKL_PTR,TSEGM_PTR + INTEGER, POINTER, DIMENSION(:) :: ICHDIM,ICHTYP,ICHDKL,ITSEGM + REAL, POINTER, DIMENSION(:) :: RTSEGM +* + INTEGER TKCARO(31) + SAVE TKCARO + DATA TKCARO / + & 0, 1, 2, 3, 4, 5, 6, 30, 7, -8, + & 9, -10, 11, -12, 13, -14, 15, 16, -17, 18, + & -19, 20, -21, 22, 23, -24, 25, -26, 27, -28, + & 29 / +*---- +* INDEX THE APOLIB-2 FILE. +*---- + CALL AEXTPA(NAMFIL,ISFICH) + IADRES=ISFICH(1) + NBOBJ=ISFICH(2) + LBLOC=ISFICH(3) + NIN=KDROPN(NAMFIL,2,4,LBLOC) + IF(NIN.LE.0) THEN + WRITE (HSMG,'(35HLIBDI5: UNABLE TO OPEN LIBRARY FILE,1X,A16, + 1 1H.)') NAMFIL + CALL XABORT(HSMG) + ENDIF + ALLOCATE(VINTE(2*NBOBJ)) + CALL AEXDIR(NIN,LBLOC,VINTE,IADRES,2*NBOBJ) + IDKNO=1-TKCARO(14) + IDKTY=1-TKCARO(21) + IDKDS=1-TKCARO(10) + IDKTS=1-TKCARO(23) + IDKDA=1-TKCARO(26) + IDKNS=TKCARO(2)+1 + IDKLS=TKCARO(8) +* + TEXT20='SSDATA'//HSHI + LISO=.FALSE. + DO 70 I=3,NBOBJ + IDKOBJ=VINTE(2*I-1) + LGSEG=VINTE(2*I)+1 + ALLOCATE(ITCARO(LGSEG)) + CALL AEXDIR(NIN,LBLOC,ITCARO,IDKOBJ,LGSEG) + IDK=ITCARO(IDKNO) + CALL AEXCPC(IDK,20,ITCARO,NOMOBJ) + IDK=ITCARO(IDKTY) + CALL AEXCPC(IDK,8,ITCARO,TYPOBJ) + JDKDS=ITCARO(IDKDS) + JDKTS=ITCARO(IDKTS) + NS=ITCARO(IDKNS) + IDK=ITCARO(IDKDA) + CALL AEXCPC(IDK,8,ITCARO,TEXT8) + IF((TYPOBJ.EQ.'APOLIBE').AND.(NOMOBJ.EQ.TEXT20)) THEN + LISO=.TRUE. + LPTHOM=.FALSE. + DO 60 IS=1,NS + IDK=JDKTS+8*(IS-1) + CALL AEXCPC(IDK,8,ITCARO,TYPSEG) + LNGS=ITCARO(IDKLS+IS) + IF(LNGS.LE.0) GO TO 60 + JDKS=ITCARO(JDKDS+IS) + CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, + 1 ICHDKL_PTR) + CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) + CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) + CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) + TSEGM_PTR=LCMARA(LNGS+1) + CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) + CALL AEXDIR(NIN,LBLOC,ITSEGM,JDKS,LNGS+1) + IF(TYPSEG.EQ.'PTHOM1') THEN + CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /)) + LPTHOM=.TRUE. + CALL AEXGNV(16,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NSEQHO) + NDIL=NSEQHO-1 + IF(NDIL.GT.MAXDIL) CALL XABORT('LIBDI5: INVALID MAXDIL.') + DILMAX=RTSEGM(IDK+NSEQHO-1) + IF(DILMAX.LT.1.0E10) THEN + WRITE(HSMG,'(35HLIBDI5: INVALID INFINITE DILUTION (,1P, + 1 E12.4,14H) FOR ISOTOPE ,A12,1H.)') DILMAX,HSHI + CALL XABORT(HSMG) + ENDIF + DO 50 J=1,NSEQHO + DILUT(J)=RTSEGM(IDK+J-1) + 50 CONTINUE + ENDIF + CALL LCMDRD(TSEGM_PTR) + CALL LCMDRD(ICHDIM_PTR) + CALL LCMDRD(ICHTYP_PTR) + CALL LCMDRD(ICHDKL_PTR) + 60 CONTINUE + IF(.NOT.LPTHOM) CALL XABORT('LIBDI5: NO PTHOM1 SEGMENT ' + 1 //'FOR ISOTOPE '//HSHI//'.') + ENDIF + DEALLOCATE(ITCARO) + 70 CONTINUE + DEALLOCATE(VINTE) + IF(.NOT.LISO) CALL XABORT('LIBDI5: UNABLE TO FIND ISOTOPE ' + 1 //HSHI//'.') + IER=KDRCLS(NIN,1) + IF(IER.LT.0) THEN + WRITE (HSMG,'(36HLIBDI5: UNABLE TO CLOSE LIBRARY FILE,1X,A16, + 1 1H.)') NAMFIL + CALL XABORT(HSMG) + ENDIF + RETURN + END diff --git a/Dragon/src/LIBDI6.f b/Dragon/src/LIBDI6.f new file mode 100644 index 0000000..7dbb392 --- /dev/null +++ b/Dragon/src/LIBDI6.f @@ -0,0 +1,213 @@ +*DECK LIBDI6 + SUBROUTINE LIBDI6 (MAXDIL,NGROUP,NAMFIL,HNISOR,HSHI,NDIL,DILUT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find the dilutions corresponding to a resonant isotope within a +* library in WIMS-AECL format. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXDIL maximum number of dilutions. +* NGROUP number of energy groups. +* NAMFIL name of the WIMS-AECL format file. +* HNISOR library name of the isotope. +* HSHI library name of the self-shielding data. +* +*Parameters: output +* NDIL number of finite dilutions. +* DILUT dilutions. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER NAMFIL*(*),HNISOR*12,HSHI*12 + INTEGER MAXDIL,NGROUP,NDIL + REAL DILUT(MAXDIL) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IOUT=6,MAXRES=50,MAXTEM=20) + CHARACTER FMT*6,HSMG*131 + REAL RS1(3*MAXRES) + REAL, ALLOCATABLE, DIMENSION(:) :: DSIGPL + REAL, ALLOCATABLE, DIMENSION(:,:) :: GAR +*---- +* WIMS-AECL LIBRARY PARAMETERS +*---- + PARAMETER (IACTC=1,MAXISO=246,NCT=10,LPZ=9,LMASTB=MAXISO+9, + > LMASIN=LMASTB-4,LGENTB=6,LGENIN=LGENTB, + > LSUBTB=6*MAXTEM+28,LSUBIN=LSUBTB-12, + > LRESTB=MAXRES*5,LRESIN=LRESTB) + CHARACTER CWISO(MAXISO)*8,CTITLE(NCT)*8 + INTEGER MASTER(LMASTB),GENINX(LGENTB),SUBINX(LSUBTB), + > SUBINR(LSUBTB),RESINX(LRESTB),ITITLE(2*NCT), + > NPZ(LPZ),IWISO(2*MAXISO) +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(GAR(NGROUP,2)) +*---- +* OPEN WIMSLIB AND READ GENERAL DIMENSIONING +*---- + IUNIT=KDROPN(NAMFIL,2,4,256) + IF(IUNIT.LE.0) THEN + WRITE (HSMG,'(35HLIBDI6: UNABLE TO OPEN LIBRARY FILE,1X,A16, + 1 8H. IUNIT=,I4,1H.)') NAMFIL,IUNIT + CALL XABORT(HSMG) + ENDIF + CALL OPNIND(IUNIT,MASTER,LMASTB) + CALL REDIND(IUNIT,MASTER,LMASIN,GENINX,LGENTB,1) + CALL REDIND(IUNIT,MASTER,LMASIN,ITITLE,2*NCT,2) + CALL UPCKIC(ITITLE(1),CTITLE(1),NCT) + CALL REDIND(IUNIT,GENINX,LGENIN,NPZ,LPZ,1) + IF(NPZ(2).NE.NGROUP) THEN + WRITE(IOUT,9001) NGROUP,NPZ(2) + CALL XABORT('LIBDI6: INVALID NUMBER OF GROUPS(1)') + ENDIF + NEL=NPZ(1) + NGF=NPZ(4) + NGR=NPZ(5) + NGTHER=NPZ(6) + NGFR=NGF+NGR + MXSCT=NGROUP*(NGROUP+2) + IF(NGFR+NGTHER.NE.NGROUP) THEN + WRITE(IOUT,9001) NGROUP,NGFR+NGTHER + CALL XABORT('LIBDI6: INVALID NUMBER OF GROUPS(2)') + ENDIF + IF(NEL.GT.MAXISO) THEN + WRITE(IOUT,9003) MAXISO,NEL + CALL XABORT('LIBDI6: INVALID NUMBER OF ISOTOPES') + ENDIF + ALLOCATE(DSIGPL(NGR)) +*---- +* READ ISOTOPES NAMES +*--- + CALL REDIND(IUNIT,GENINX,LGENIN,IWISO,2*NEL,3) + CALL UPCKIC(IWISO(1),CWISO(1),NEL) + CALL REDIND(IUNIT,GENINX,LGENIN,IWISO,NEL,2) + NRDT=NGTHER-1 +*--- +* READ THROUGH DRAGON FILE AND ACCUMULATE CROSS SECTIONS FOR +* CROSS SECTION ARE SAVED ONLY IF ISOTOPE IS USED +*---- + IDRES=INDEX(HSHI,'.') + IF(IDRES.GT.0) THEN + WRITE(FMT,'(2H(F,I1,3H.1))') IDRES+1 + READ(HSHI,FMT) RIND + ENDIF + IRISO=0 + DO 120 IEL=1,NEL + IF(CWISO(IEL).EQ.HNISOR(1:8)) THEN + IRISO=IEL + IF(IDRES.EQ.0) THEN + RIND=FLOAT(IWISO(IRISO)) + ENDIF + GO TO 125 + ENDIF + 120 CONTINUE + CALL XABORT('LIBDI6: ISOTOPE NOT FOUND ON LIBRARY') + 125 CONTINUE +*---- +* READ SUB INDEX ASSOCIATED WITH ISOTOPE +*--- + CALL REDIND(IUNIT,MASTER,LMASIN,SUBINX,LSUBTB,IRISO+4) + IENDF=SUBINX(LSUBIN+12) +*---- +* FAST AND/OR RESONANCE XS +*---- + CALL REDIND(IUNIT,SUBINX,LSUBIN,GAR(NGF+1:,2),NGR,9) + IF(IENDF.EQ.0) THEN + CALL REDIND(IUNIT,SUBINX,LSUBIN,GAR(NGF+1:,1),NGR,2) + DO 130 IG=NGF+1,NGFR + DSIGPL(IG-NGF)=GAR(IG,1)*GAR(IG,2) + 130 CONTINUE + ELSE + DSIGPL(:NGR)=0.0 + ENDIF +*---- +* MODIFIED SUB IDX LENGTH FOR RESONANCE +*---- + LSUBTR=NGR+7 + LSUBZ=NGR+1 + CALL REDIND(IUNIT,MASTER,LMASIN,SUBINR,LSUBTR,NEL+5) +*---- +* MODIFIED RES IDX LENGTH FOR RESONANCE +*---- + LRESND=SUBINR(NGR+6) + IGRF=NGF + DO 300 IGR=1,NGR + IGRF=IGRF+1 + CALL REDIND(IUNIT,SUBINR,LSUBZ,RESINX,LRESND+1,IGR) + NRES=RESINX(LRESND+1) + IF(NRES.GT.MAXRES) THEN + WRITE(IOUT,9005) NRES,MAXRES + CALL XABORT('LIBDI6: INVALID NUMBER OF RESONANCE') + ENDIF + IF(IGR.EQ.1) THEN + CALL REDIND(IUNIT,RESINX,LRESND,RS1,3*NRES,1) +*---- +* IDENTIFY SELF SHIELDING RESONNANT ISOTOPE +*---- + DO 310 JRES=1,NRES + IF(IDRES.EQ.0) THEN + XRS1=FLOAT(INT((RS1(3*(JRES-1)+1)+0.01)*10.) + > -INT(RS1(3*(JRES-1)+1)+0.01)*10)/10.+0.02 + XRS1=ABS(RS1(3*(JRES-1)+1)-XRS1-RIND) + ELSE + XRS1=ABS(RS1(3*(JRES-1)+1)-RIND) + ENDIF + IF(XRS1.LE.0.01) THEN + KRES=JRES + NTMPR=INT(RS1(3*(KRES-1)+2)+0.1) + NDILR=INT(RS1(3*(KRES-1)+3)+0.1) + IF(NDILR.GT.MAXDIL) THEN + WRITE(IOUT,9007) NDILR,MAXDIL + CALL XABORT('LIBDI6: INVALID NUMBER OF RES DIL') + ENDIF + CALL REDIND(IUNIT,RESINX,LRESND,DILUT,NDILR,3+5*(KRES-1)) + DO 313 II=1,NDILR + IF(DILUT(II)-DSIGPL(IGR).GT.0.0) THEN + DILUT(II)=DILUT(II)-DSIGPL(IGR) + ELSE + DILUT(II)=0.0 + ENDIF + DILUT(II)=MIN(DILUT(II),1.0E10) + 313 CONTINUE + GO TO 300 + ENDIF + 310 CONTINUE + GO TO 110 + ENDIF + 300 CONTINUE + 110 NDIL=NDILR-1 + CALL CLSIND(IUNIT) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(DSIGPL,GAR) +*---- +* RETURN +*---- + RETURN + 9001 FORMAT(/' LIBDI6: NUMBER OF GROUPS SPECIFIED :',I10/ + > ' NUMBER OF GROUPS IN LIBRARY :',I10) + 9003 FORMAT(/' LIBDI6: MAXIMUM NUMBER OF ISOTOPE SPECIFIED :',I10/ + > ' NUMBER OF ISOTOPE IN LIBRARY :',I10) + 9005 FORMAT(/' LIBDI6: NUMBER OF RESONANT ISOTOPES :',I10/ + > ' MAXIMUM NUMBER OF RESONANT ISOTOPES :',I10) + 9007 FORMAT(/' LIBDI6: NUMBER OF RESONANT DILUTION :',I10/ + > ' MAXIMUM NUMBER OF RESONANT DILUTION :',I10) + END diff --git a/Dragon/src/LIBDI8.f b/Dragon/src/LIBDI8.f new file mode 100644 index 0000000..3f4c767 --- /dev/null +++ b/Dragon/src/LIBDI8.f @@ -0,0 +1,198 @@ +*DECK LIBDI8 + SUBROUTINE LIBDI8 (MAXDIL,NGROUP,NAMFIL,HNISOR,HSHI,NDIL,DILUT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find the dilutions corresponding to a resonant isotope within a +* library in WIMS-D4 format. +* +*Copyright: +* Copyright (C) 2009 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXDIL maximum number of dilutions. +* NGROUP number of energy groups. +* NAMFIL name of the WIMS-D4 format file. +* HNISOR library name of the isotope. +* HSHI library name of the self-shielding data. +* +*Parameters: output +* NDIL number of finite dilutions. +* DILUT dilutions. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER NAMFIL*(*),HNISOR*12,HSHI*12 + INTEGER MAXDIL,NGROUP,NDIL + REAL DILUT(MAXDIL) +*---- +* LOCAL VARIABLES +*---- + INTEGER IUTYPE,LRIND,IACTO,IACTC + PARAMETER (IUTYPE=2,LRIND=0,IACTO=2,IACTC=1,LPZ=8,MAXISO=246) + CHARACTER FMT*6,HSMG*131,CWISO(MAXISO)*8 + INTEGER NPZ(LPZ),IWISO(2*MAXISO) + REAL, ALLOCATABLE, DIMENSION(:) :: GAR,SCR +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(GAR(MAXDIL+1)) +*---- +* OPEN WIMS-D4 LIBRARY AND READ GENERAL DIMENSIONING +*---- + IDRES=INDEX(HSHI,'.') + IUNIT=KDROPN(NAMFIL,IACTO,IUTYPE,LRIND) + IF(IUNIT.LE.0) THEN + WRITE (HSMG,'(35HLIBDI8: UNABLE TO OPEN LIBRARY FILE,1X,A16, + 1 8H. IUNIT=,I4,1H.)') NAMFIL,IUNIT + CALL XABORT(HSMG) + ENDIF + READ(IUNIT) (NPZ(II),II=1,LPZ) + IF(NPZ(2).NE.NGROUP) THEN + CALL XABORT('LIBDI8: INVALID NUMBER OF GROUPS') + ENDIF + NEL=NPZ(1) + NGR=NPZ(5) + NW=4*NGR+2*NPZ(3) + ALLOCATE(SCR(NW)) + SCR(:NW)=0.0 +*---- +* READ ISOTOPE ID NUMBER AND CREATE EQUIVALENT ISOTOPE NAME +* SCAN TO ASSOCIATE WIMS ISOTOPE NUMBER WITH DRAGON ISOTOPE NUMBER +*---- + IRISO=0 + IRIND=0 + READ(IUNIT) (IWISO(ITC),ITC=1,NEL) + DO 10 IEL=1,NEL + CWISO(IEL)=' ' + IF (IWISO(IEL).LT.10) THEN + WRITE(CWISO(IEL),'(I1)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.100) THEN + WRITE(CWISO(IEL),'(I2)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.1000) THEN + WRITE(CWISO(IEL),'(I3)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.10000) THEN + WRITE(CWISO(IEL),'(I4)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.100000) THEN + WRITE(CWISO(IEL),'(I5)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.1000000) THEN + WRITE(CWISO(IEL),'(I6)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.10000000) THEN + WRITE(CWISO(IEL),'(I7)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.100000000) THEN + WRITE(CWISO(IEL),'(I8)') IWISO(IEL) + ENDIF + IF(CWISO(IEL).EQ.HNISOR(1:8)) THEN + IRISO=IEL + IF(IDRES.EQ.0) THEN + IRIND=IWISO(IRISO) + ENDIF + GO TO 20 + ENDIF + 10 CONTINUE + CALL XABORT('LIBDI8: ISOTOPE NOT FOUND ON LIBRARY') + 20 CONTINUE +*---- +* READ GROUP STRUCTURE +*---- + READ(IUNIT) (DUMMY,ITC=1,NGROUP) +*---- +* RECOVER FISSION SPECTRUM +*---- + READ(IUNIT) (DUMMY,ITC=1,NPZ(3)) +*---- +* READ DEPLETION CHAIN +*---- + DO 30 IEL=1,NEL + READ(IUNIT) DUMMY + 30 CONTINUE + READ(IUNIT) DUMMY +*---- +* READ FILE FOR TEMPERATURE DEPENDENT XS +*---- + NRTOT=0 + DO 50 IELRT=1,NEL + READ(IUNIT) IDIEL,AWR,IZ,NFIEL,NTMP,NRIEL + IF(NRIEL.GT.0) NRTOT=NRTOT+NRIEL + IF(IELRT.EQ.IRISO) THEN + READ(IUNIT) (SCR(I),I=1,NW) + ELSE + READ(IUNIT) DUMMY + ENDIF + IF(NFIEL.GT.1) READ(IUNIT) DUMMY + READ(IUNIT) NSCT + IF(NTMP.GT.0) THEN + READ(IUNIT) DUMMY + DO 40 IT=1,NTMP + READ(IUNIT) DUMMY + IF(NFIEL.GT.1) READ(IUNIT) DUMMY + READ(IUNIT) NSCT + 40 CONTINUE + ENDIF + READ(IUNIT) ENDR + 50 CONTINUE +*---- +* IDENTIFY RESONANT ISOTOPE +*---- + IF(IDRES.GT.0) THEN + WRITE(FMT,'(2H(F,I1,3H.1))') IDRES+1 + READ(HSHI,FMT) RIND + ELSE + RIND=FLOAT(IWISO(IRISO)) + ENDIF +*---- +* SCAN OVER RESONANCE SETS+1 AND READ RESONANCE INFO +*---- + DO 90 IGR=1,NGR + DO 70 IRS=1,2*NRTOT+1 + READ(IUNIT) XIDR,M1,M2,(DUMMY,IT=1,M1),(GAR(ID),ID=1,M2), + 1 ((DUMMY,ID=1,M2),IT=1,M1) + IF(M2.GT.MAXDIL) CALL XABORT('LIBDI8: MAXDIL OVERFLOW.') + IF(IDRES.EQ.0) THEN + XRS1=FLOAT(INT((XIDR+0.01)*10.)-INT(XIDR+0.01)*10)/10. + XRS1=ABS(XIDR-XRS1-RIND) + ELSE + XRS1=ABS(XIDR-RIND) + ENDIF + IF(XRS1.LE.0.01) THEN + NDIL=M2-1 + DO 60 ID=1,NDIL + DSIGPL=SCR(IGR)*SCR(NW-NGR+IGR) + IF(GAR(ID)-DSIGPL.GT.0.0) THEN + DILUT(ID)=GAR(ID)-DSIGPL + ELSE + DILUT(ID)=0.0 + ENDIF + 60 CONTINUE + DILUT(M2)=MIN(GAR(M2),1.0E10) + GO TO 100 + ENDIF + IF(XIDR.EQ.0.0) GO TO 80 + 70 CONTINUE + 80 CONTINUE + READ(IUNIT) ENDR + 90 CONTINUE + NDIL=0 + DILUT(1)=1.0E10 + 100 IERR=KDRCLS(IUNIT,IACTC) + IF(IERR.LT.0) THEN + HNISOR=NAMFIL + CALL XABORT('LIBDI8: WIMS-D4 LIBRARY '//HNISOR// + 1 ' CANNOT BE CLOSED.') + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SCR,GAR) + RETURN + END diff --git a/Dragon/src/LIBDI9.f b/Dragon/src/LIBDI9.f new file mode 100644 index 0000000..a72732e --- /dev/null +++ b/Dragon/src/LIBDI9.f @@ -0,0 +1,198 @@ +*DECK LIBDI9 + SUBROUTINE LIBDI9 (MAXDIL,NGROUP,NAMFIL,HNISOR,HSHI,NDIL,DILUT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find the dilutions corresponding to a resonant isotope within a +* library in WIMS-E format. +* +*Copyright: +* Copyright (C) 2016 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXDIL maximum number of dilutions. +* NGROUP number of energy groups. +* NAMFIL name of the WIMS-E format file. +* HNISOR library name of the isotope. +* HSHI library name of the self-shielding data. +* +*Parameters: output +* NDIL number of finite dilutions. +* DILUT dilutions. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER NAMFIL*(*),HNISOR*12,HSHI*12 + INTEGER MAXDIL,NGROUP,NDIL + REAL DILUT(MAXDIL) +*---- +* LOCAL VARIABLES +*---- + INTEGER IUTYPE,LRIND,IACTO,IACTC + PARAMETER (IUTYPE=2,LRIND=0,IACTO=2,IACTC=1,LPZ=8,MAXISO=246) + CHARACTER FMT*6,HSMG*131,CWISO(MAXISO)*8 + INTEGER NPZ(LPZ),IWISO(2*MAXISO) + REAL, ALLOCATABLE, DIMENSION(:) :: GAR,SCR +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(GAR(MAXDIL+1)) +*---- +* OPEN WIMS-E LIBRARY AND READ GENERAL DIMENSIONING +*---- + IDRES=INDEX(HSHI,'.') + IUNIT=KDROPN(NAMFIL,IACTO,IUTYPE,LRIND) + IF(IUNIT.LE.0) THEN + WRITE (HSMG,'(35HLIBDI9: UNABLE TO OPEN LIBRARY FILE,1X,A16, + 1 8H. IUNIT=,I4,1H.)') NAMFIL,IUNIT + CALL XABORT(HSMG) + ENDIF + READ(IUNIT) (NPZ(II),II=1,LPZ) + IF(NPZ(2).NE.NGROUP) THEN + CALL XABORT('LIBDI9: INVALID NUMBER OF GROUPS') + ENDIF + NEL=NPZ(1) + NGR=NPZ(5) + NW=4*NGR+2*NPZ(3)+NPZ(4) + ALLOCATE(SCR(NW)) + SCR(:NW)=0.0 +*---- +* READ ISOTOPE ID NUMBER AND CREATE EQUIVALENT ISOTOPE NAME +* SCAN TO ASSOCIATE WIMS ISOTOPE NUMBER WITH DRAGON ISOTOPE NUMBER +*---- + IRISO=0 + IRIND=0 + READ(IUNIT) (IWISO(ITC),ITC=1,NEL) + DO 10 IEL=1,NEL + CWISO(IEL)=' ' + IF (IWISO(IEL).LT.10) THEN + WRITE(CWISO(IEL),'(I1)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.100) THEN + WRITE(CWISO(IEL),'(I2)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.1000) THEN + WRITE(CWISO(IEL),'(I3)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.10000) THEN + WRITE(CWISO(IEL),'(I4)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.100000) THEN + WRITE(CWISO(IEL),'(I5)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.1000000) THEN + WRITE(CWISO(IEL),'(I6)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.10000000) THEN + WRITE(CWISO(IEL),'(I7)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.100000000) THEN + WRITE(CWISO(IEL),'(I8)') IWISO(IEL) + ENDIF + IF(CWISO(IEL).EQ.HNISOR(1:8)) THEN + IRISO=IEL + IF(IDRES.EQ.0) THEN + IRIND=IWISO(IRISO) + ENDIF + GO TO 20 + ENDIF + 10 CONTINUE + CALL XABORT('LIBDI9: ISOTOPE NOT FOUND ON LIBRARY') + 20 CONTINUE +*---- +* READ GROUP STRUCTURE +*---- + READ(IUNIT) (DUMMY,ITC=1,NGROUP) +*---- +* READ DEPLETION CHAIN +*---- + DO 30 IEL=1,NEL + READ(IUNIT) DUMMY + 30 CONTINUE +*---- +* READ FILE FOR TEMPERATURE DEPENDENT XS +*---- + NRTOT=0 + DO 50 IELRT=1,NEL + READ(IUNIT) IDIEL,AWR,IZ,NFIEL,NTMP,NRIEL,ISOF,IP1OPT + IF(NRIEL.GT.0) NRTOT=NRTOT+NRIEL + IF(IELRT.EQ.IRISO) THEN + READ(IUNIT) (SCR(I),I=1,NW) + ELSE + READ(IUNIT) DUMMY + ENDIF + IF(NFIEL.GT.1) READ(IUNIT) DUMMY + READ(IUNIT) NSCT + IF(NTMP.GT.0) THEN + READ(IUNIT) DUMMY + DO 40 IT=1,NTMP + READ(IUNIT) DUMMY + IF(NFIEL.GT.1) READ(IUNIT) DUMMY + READ(IUNIT) NSCT + 40 CONTINUE + ENDIF + IF(ISOF.NE.0) READ(IUNIT) DUMMY + IF(IP1OPT.NE.1) THEN + DO 45 IT=1,NTMP + READ(IUNIT) DUMMY + 45 CONTINUE + ENDIF + 50 CONTINUE +*---- +* IDENTIFY RESONANT ISOTOPE +*---- + IF(IDRES.GT.0) THEN + WRITE(FMT,'(2H(F,I1,3H.1))') IDRES+1 + READ(HSHI,FMT) RIND + ELSE + RIND=FLOAT(IWISO(IRISO)) + ENDIF +*---- +* SCAN OVER RESONANCE SETS+1 AND READ RESONANCE INFO +*---- + DO 90 IGR=1,NGR + DO 70 IRS=1,3*NRTOT+1 + READ(IUNIT) XIDR,M1,M2,(DUMMY,IT=1,M1),(GAR(ID),ID=1,M2), + 1 ((DUMMY,ID=1,M2),IT=1,M1) + IF(M2.GT.MAXDIL) CALL XABORT('LIBDI9: MAXDIL OVERFLOW.') + IF(IDRES.EQ.0) THEN + XRS1=FLOAT(INT((XIDR+0.01)*10.)-INT(XIDR+0.01)*10)/10. + XRS1=ABS(XIDR-XRS1-RIND) + ELSE + XRS1=ABS(XIDR-RIND) + ENDIF + IF(XRS1.LE.0.01) THEN + NDIL=M2-1 + DO 60 ID=1,NDIL + DSIGPL=SCR(IGR)*SCR(NW-NGR+IGR) + IF(GAR(ID)-DSIGPL.GT.0.0) THEN + DILUT(ID)=GAR(ID)-DSIGPL + ELSE + DILUT(ID)=0.0 + ENDIF + 60 CONTINUE + DILUT(M2)=MIN(GAR(M2),1.0E10) + GO TO 100 + ENDIF + IF(XIDR.EQ.0.0) GO TO 80 + 70 CONTINUE + 80 CONTINUE + READ(IUNIT) ENDR + 90 CONTINUE + NDIL=0 + DILUT(1)=1.0E10 + 100 IERR=KDRCLS(IUNIT,IACTC) + IF(IERR.LT.0) THEN + HNISOR=NAMFIL + CALL XABORT('LIBDI9: WIMS-E LIBRARY '//HNISOR// + 1 ' CANNOT BE CLOSED.') + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SCR,GAR) + RETURN + END diff --git a/Dragon/src/LIBDRA.f b/Dragon/src/LIBDRA.f new file mode 100644 index 0000000..9d23805 --- /dev/null +++ b/Dragon/src/LIBDRA.f @@ -0,0 +1,418 @@ +*DECK LIBDRA + SUBROUTINE LIBDRA (IPLIB,IPDRL,NAMFIL,NGRO,NBISO,NL,ISONAM, + 1 ISONRF,IPISO,TN,SN,SB,MASKI,NED,HVECT,IMPX,NGF,NGFR,NDEL,NBESP) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transcription of the useful interpolated microscopic cross section +* data from a microscopic x-section library (draglib format) to LCM +* data structures. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* IPDRL pointer to the draglib (L_DRAGLIB signature). +* NAMFIL name of the Dragon library file. +* NGRO number of energy groups. +* NBISO number of isotopes present in the calculation domain. +* NL number of Legendre orders required in the calculation +* NL=1 or higher. +* ISONAM alias name of isotopes. +* ISONRF library name of isotopes. +* IPISO pointer array towards microlib isotopes. +* TN temperature of each isotope. +* SN dilution cross section in each energy group of each +* isotope. a value of 1.0e10 is used for infinite dilution. +* SB dilution cross section as used in livolant and jeanpierre +* normalization. +* MASKI isotopic mask. Isotope with index I is processed if +* MASKI(I)=.true. +* NED number of extra vector edits. +* HVECT names of the extra vector edits. +* IMPX print flag. +* +*Parameters: output +* NGF number of fast groups without self-shielding. +* NGFR number of fast and resonance groups. +* NDEL number of precursor groups for delayed neutrons. +* NBESP number of energy-dependent fission spectra. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + PARAMETER(MAXDEL=10,MAXESP=4) + CHARACTER*(*) HVECT(NED),NAMFIL + TYPE(C_PTR) IPLIB,IPDRL,IPISO(NBISO) + INTEGER NGRO,NBISO,NL,ISONAM(3,NBISO),ISONRF(3,NBISO),NED,IMPX, + 1 NGF,NGFR,NDEL,NBESP + REAL TN(NBISO),SN(NGRO,NBISO),SB(NGRO,NBISO) + LOGICAL MASKI(NBISO) +*---- +* LOCAL VARIABLES +*---- + CHARACTER CD*4,HSMG*131,HTITLE*80,HNISOR*12,HNAMIS*12,HNUSIG*12, + 1 HCHI*12 + PARAMETER (IOUT=6,MAXTMP=50,NOTX=3) + TYPE(C_PTR) KPLIB + LOGICAL LSIGF,LGOLD,LOGT,LNZERO + INTEGER IESP(MAXESP+1) + DOUBLE PRECISION FACTOR,TERP(MAXTMP),DDELI + REAL TEMP(MAXTMP),ZLAMB(MAXDEL),EESP(MAXESP+1) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NFS,ITYPRO,ITITLE + REAL, ALLOCATABLE, DIMENSION(:) :: AWR,DELTA,TOTAL,GOLD,ZNPHI, + 1 ENER,BIN,EBIN,SIGS2,SCAT2,TOTAL2,SIGF2,CHI2,SADD2,GOLD2,BIN2, + 2 ZNPHI2,CHI4G2 + REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGS,SIGF,CHI,SADD,CHI4G + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LSCAT,LADD +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NFS(NGRO),ITYPRO(NL)) + ALLOCATE(AWR(NBISO),DELTA(NGRO),SIGS(NGRO,NL),SCAT(NGRO,NGRO,NL), + 1 TOTAL(NGRO),SIGF(NGRO,0:MAXDEL),CHI(NGRO,0:MAXDEL), + 2 SADD(NGRO,NED),GOLD(NGRO),ZNPHI(NGRO)) + ALLOCATE(LSCAT(NL),LADD(NED)) +*---- +* RECOVER THE GROUP STRUCTURE. +*---- + NGF=NGRO+1 + NGFR=0 + NDEL=0 + IF(IMPX.GT.0) WRITE (IOUT,900) NAMFIL + CALL LCMLEN(IPDRL,'README',LENGT,ITYLCM) + IF((IMPX.GT.0).AND.(LENGT.GT.0)) THEN + ALLOCATE(ITITLE(LENGT)) + CALL LCMGET(IPDRL,'README',ITITLE) + WRITE (IOUT,940) + I2=0 + DO 10 J=0,LENGT/20 + I1=I2+1 + I2=MIN(I1+19,LENGT) + WRITE (HTITLE,'(20A4)') (ITITLE(I),I=I1,I2) + WRITE (IOUT,'(1X,A80)') HTITLE + 10 CONTINUE + DEALLOCATE(ITITLE) + WRITE (IOUT,'(40H LIBDRA: NUMBER OF ISOTOPES IN MICROLIB=,I6)') + 1 NBISO + ENDIF + ALLOCATE(ENER(NGRO+1)) + CALL LCMLEN(IPDRL,'ENERGY',LENGT,ITYLCM) + LENGT=LENGT-1 + IF(LENGT.NE.NGRO) CALL XABORT('LIBDRA: INVALID GROUP STRUCTURE.') + CALL LCMGET(IPDRL,'ENERGY',ENER) + CALL LCMLEN(IPDRL,'DELTAU',LENGT,ITYLCM) + IF(LENGT.EQ.NGRO) THEN + CALL LCMGET(IPDRL,'DELTAU',DELTA) + ELSE IF(LENGT.EQ.0) THEN + IF(ENER(NGRO+1).EQ.0.0) ENER(NGRO+1)=1.0E-5 + DO 15 J=1,NGRO + DELTA(J)=LOG(ENER(J)/ENER(J+1)) + 15 CONTINUE + ENDIF + CALL LCMPUT(IPLIB,'ENERGY',NGRO+1,2,ENER) + CALL LCMPUT(IPLIB,'DELTAU',NGRO,2,DELTA) + DEALLOCATE(ENER) + CALL LCMLEN(IPDRL,'CHI-LIMITS',NBESP,ITYLCM) + IF(NBESP.GT.0) THEN + NBESP=NBESP-1 + IF(NBESP.GT.MAXESP) CALL XABORT('LIBDRA: MAXESP OVERFLOW.') + CALL LCMGET(IPDRL,'CHI-LIMITS',IESP) + CALL LCMPUT(IPLIB,'CHI-LIMITS',NBESP+1,1,IESP) + CALL LCMGET(IPDRL,'CHI-ENERGY',EESP) + CALL LCMPUT(IPLIB,'CHI-ENERGY',NBESP+1,2,EESP) + ENDIF + ALLOCATE(CHI4G(NGRO,NBESP)) +*---- +* READ THROUGH DRAGON FILE AND ACCUMULATE CROSS SECTIONS FOR THIS RANGE +* OF MATS, LEGENDRE ORDERS, AND GROUPS. +*---- + DO 400 IMX=1,NBISO + IF(MASKI(IMX)) THEN + WRITE(HNAMIS,'(3A4)') (ISONAM(I0,IMX),I0=1,3) + WRITE(HNISOR,'(3A4)') (ISONRF(I0,IMX),I0=1,3) + CALL LCMLEN(IPDRL,HNISOR,LENGT,ITYLCM) + IF(LENGT.EQ.0) THEN + CALL LCMLIB(IPDRL) + WRITE (HSMG,910) HNAMIS,HNISOR,NAMFIL,IMX + CALL XABORT(HSMG) + ENDIF + IF(IMPX.GT.0) WRITE (IOUT,920) HNAMIS,HNISOR + CALL LCMSIX(IPDRL,HNISOR,1) +* + CALL LCMGET(IPDRL,'AWR',AWR(IMX)) + CALL LCMLEN(IPDRL,'README',LTITLE,ITYLCM) + IF(LTITLE.GT.0) THEN + ALLOCATE(ITITLE(LTITLE)) + CALL LCMGET(IPDRL,'README',ITITLE) + IF(IMPX.GT.0) THEN + WRITE (IOUT,930) + I2=0 + DO 20 J=0,LTITLE/20 + I1=I2+1 + I2=MIN(I1+19,LTITLE) + WRITE (HTITLE,'(20A4)') (ITITLE(I),I=I1,I2) + WRITE (IOUT,'(1X,A80)') HTITLE + 20 CONTINUE + ENDIF + ENDIF +*---- +* RECOVER BIN TYPE INFORMATION (IF AVAILABLE). +*---- + LBIN=0 + CALL LCMLEN (IPDRL,'BIN-NFS',LENGT,ITYXSM) + IF(LENGT.GT.0) THEN + CALL LCMGET (IPDRL,'BIN-NFS',NFS) + DO 30 I=1,NGRO + LBIN=LBIN+NFS(I) + 30 CONTINUE + ALLOCATE(BIN(3*LBIN),EBIN(LBIN+1)) + CALL LCMGET (IPDRL,'BIN-ENERGY',EBIN) + CALL LCMLEN(IPDRL,'BIN-DELI',LENDEL,ITYLCM) + IF((LENDEL.EQ.1).AND.(ITYLCM.EQ.2)) THEN + CALL LCMGET (IPDRL,'BIN-DELI',RDELI) + ELSE IF((LENDEL.EQ.1).AND.(ITYLCM.EQ.4)) THEN + CALL LCMGET (IPDRL,'BIN-DELI',DDELI) + RDELI=REAL(DDELI) + ENDIF + ENDIF +*---- +* RECOVER ECCOLIB INFORMATION (IF AVAILABLE). +*---- + DELECC=0.0 + IGECCO=0 + CALL LCMLEN(IPDRL,'ONFLIGHTDEL',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGET(IPDRL,'ONFLIGHTDEL',DELECC) + CALL LCMGET(IPDRL,'ONFLIGHTIGR',IGECCO) + ENDIF +* + CALL LCMLEN (IPDRL,'TEMPERATURE',NTMP,ITYLCM) + IF(NTMP.GT.MAXTMP) CALL XABORT('LIBDRA: MAXTMP OVERFLOW.') + IF(NTMP.EQ.0) THEN + CALL LCMLEN (IPDRL,'LAMBDA-D',NDEL0,ITYLCM) + NDEL=MAX(NDEL,NDEL0) + IF(NDEL0.GT.MAXDEL) CALL XABORT('LIBDRA: MAXDEL OVERFLOW.') + IF(NDEL0.GT.0) CALL LCMGET (IPDRL,'LAMBDA-D',ZLAMB) + CALL LIBDRB (IPDRL,NGRO,NL,NDEL0,NBESP,SN(1,IMX),SB(1,IMX), + 1 NED,HVECT,DELTA,LBIN,NFS,EBIN,AWR(IMX),DELECC,IGECCO,IMPX, + 2 NGF,NGFR,LSCAT,LSIGF,LADD,LGOLD,SIGS(1,1),SCAT(1,1,1),TOTAL, + 3 ZNPHI,SIGF(1,1),CHI(1,1),CHI4G(1,1),SADD(1,1),GOLD(1), + 4 BIN(1)) + ELSE +*---- +* PERFORM TEMPERATURE LAGRANGIAN INTERPOLATION (ORDER ABS(NOTX)). +*---- + CALL LCMSIX (IPDRL,'SUBTMP0001',1) + CALL LCMLEN (IPDRL,'LAMBDA-D',NDEL0,ITYLCM) + NDEL=MAX(NDEL,NDEL0) + IF(NDEL0.GT.MAXDEL) CALL XABORT('LIBDRA: MAXDEL OVERFLOW.') + IF(NDEL0.GT.0) CALL LCMGET (IPDRL,'LAMBDA-D',ZLAMB) + CALL LCMSIX (IPDRL,' ',2) + CALL LCMGET (IPDRL,'TEMPERATURE',TEMP) + CALL LIBLEX(NTMP,TN(IMX),TEMP,NOTX,TERP) + DO 121 IG1=1,NGRO + TOTAL(IG1)=0.0 + ZNPHI(IG1)=0.0 + DO 100 IDEL=0,NDEL0 + SIGF(IG1,IDEL)=0.0 + CHI(IG1,IDEL)=0.0 + 100 CONTINUE + DO 105 ISP=1,NBESP + CHI4G(IG1,ISP)=0.0 + 105 CONTINUE + GOLD(IG1)=0.0 + DO 115 IL=1,NL + SIGS(IG1,IL)=0.0 + DO 110 IG2=1,NGRO + SCAT(IG1,IG2,IL)=0.0 + 110 CONTINUE + 115 CONTINUE + DO 120 IED=1,NED + SADD(IG1,IED)=0.0 + 120 CONTINUE + 121 CONTINUE + DO 125 IG=1,3*LBIN + BIN(IG)=0.0 + 125 CONTINUE + ALLOCATE(SIGS2(NGRO*NL),SCAT2(NGRO*NGRO*NL),TOTAL2(NGRO), + 1 SIGF2(NGRO*(NDEL0+1)),CHI2(NGRO*(NDEL0+1)),SADD2(NGRO*NED), + 2 GOLD2(NGRO),BIN2(3*LBIN),ZNPHI2(NGRO),CHI4G2(NGRO*NBESP)) + FACTOR=1.0D0 + DO 210 ITM=1,NTMP + TERPM=REAL(TERP(ITM)) + FACTOR=FACTOR-TERP(ITM) + IF(TERPM.EQ.0.0) GO TO 210 + IF(IMPX.GT.4) WRITE(6,'(/30H DRAGLIB ACCESS AT TEMPERATURE, + > 1P,E12.4,18H KELVIN. FACTOR = ,E12.4)') TEMP(ITM),TERPM + WRITE (CD,'(I4.4)') ITM + CALL LCMSIX (IPDRL,'SUBTMP'//CD,1) + CALL LIBDRB (IPDRL,NGRO,NL,NDEL0,NBESP,SN(1,IMX),SB(1,IMX), + 1 NED,HVECT,DELTA,LBIN,NFS,EBIN,AWR(IMX),DELECC,IGECCO,IMPX, + 2 NGF,NGFR,LSCAT,LSIGF,LADD,LGOLD,SIGS2(1),SCAT2(1),TOTAL2, + 3 ZNPHI2,SIGF2(1),CHI2(1),CHI4G2(1),SADD2(1),GOLD2(1),BIN2(1)) + CALL LCMSIX (IPDRL,' ',2) + DO 130 IG=1,NGRO + TOTAL(IG)=TOTAL(IG)+TERPM*TOTAL2(IG) + ZNPHI(IG)=ZNPHI(IG)+TERPM*ZNPHI2(IG) + 130 CONTINUE + IF(LSIGF) THEN + DO 141 IDEL=0,NDEL0 + DO 140 IG=1,NGRO + IOFSET=IDEL*NGRO+IG-1 + SIGF(IG,IDEL)=SIGF(IG,IDEL)+TERPM*SIGF2(IOFSET+1) + CHI(IG,IDEL)=CHI(IG,IDEL)+TERPM*CHI2(IOFSET+1) + 140 CONTINUE + 141 CONTINUE + DO 146 ISP=1,NBESP + DO 145 IG=1,NGRO + IOFSET=(ISP-1)*NGRO+IG-1 + CHI4G(IG,ISP)=CHI4G(IG,ISP)+TERPM*CHI4G2(IOFSET+1) + 145 CONTINUE + 146 CONTINUE + ENDIF + DO 160 IL=1,NL + IF(LSCAT(IL)) THEN + DO 150 IG2=1,NGRO + SIGS(IG2,IL)=SIGS(IG2,IL)+TERPM*SIGS2((IL-1)*NGRO+IG2) + IOF=(IL-1)*NGRO*NGRO+(IG2-1)*NGRO + DO 151 IG1=1,NGRO + SCAT(IG1,IG2,IL)=SCAT(IG1,IG2,IL)+TERPM* + > SCAT2(IOF+IG1) + 151 CONTINUE + 150 CONTINUE + ENDIF + 160 CONTINUE + DO 180 IED=1,NED + IF(LADD(IED)) THEN + DO 170 IG=1,NGRO + SADD(IG,IED)=SADD(IG,IED)+TERPM*SADD2((IED-1)*NGRO+IG) + 170 CONTINUE + ENDIF + 180 CONTINUE + IF(LGOLD) THEN + DO 190 IG=1,NGRO + GOLD(IG)=GOLD(IG)+TERPM*GOLD2(IG) + 190 CONTINUE + ENDIF + DO 200 IG=1,3*LBIN + BIN(IG)=BIN(IG)+TERPM*BIN2(IG) + 200 CONTINUE + 210 CONTINUE + DEALLOCATE(CHI4G2,ZNPHI2,BIN2,GOLD2,SADD2,CHI2,SIGF2,TOTAL2, + > SCAT2,SIGS2) + IF(ABS(FACTOR).GT.1.0D-4) CALL XABORT('LIBDRA: TERP ERROR') + ENDIF + CALL LCMSIX(IPDRL,' ',2) +*---- +* SAVE CROSS SECTION DATA ON LCM. +*---- + KPLIB=IPISO(IMX) ! set IMX-th isotope + CALL LCMPTC(KPLIB,'ALIAS',12,HNAMIS) + CALL LCMPUT(KPLIB,'AWR',1,2,AWR(IMX)) + IF(LTITLE.GT.0) THEN + CALL LCMPUT(KPLIB,'README',LTITLE,3,ITITLE) + DEALLOCATE(ITITLE) + ENDIF + DO 220 IG=1,NGRO + IF(TOTAL(IG).LT.0.0) THEN + WRITE(HSMG,'(42HLIBDRA: NEGATIVE TOTAL CROSS SECTION IN GR, + 1 3HOUP,I4,14H FOR ISOTOPE '',A12,2H''.)') IG,HNAMIS + CALL XABORT(HSMG) + ELSE IF(ZNPHI(IG).LT.0.0) THEN + WRITE(HSMG,'(41HLIBDRA: NEGATIVE INTEGRATED FLUX IN GROUP, + 1 I4,14H FOR ISOTOPE '',A12,2H''.)') IG,HNAMIS + CALL XABORT(HSMG) + ENDIF + 220 CONTINUE + CALL LCMPUT(KPLIB,'NTOT0',NGRO,2,TOTAL) + CALL LCMPUT(KPLIB,'NWT0',NGRO,2,ZNPHI) + IF(NDEL0.GT.0) CALL LCMPUT (KPLIB,'LAMBDA-D',NDEL0,2,ZLAMB) + IF(LSIGF) THEN + DO 250 IDEL=0,NDEL0 + IF(IDEL.EQ.0) THEN + HNUSIG='NUSIGF' + ELSE + WRITE(HNUSIG,'(6HNUSIGF,I2.2)') IDEL + ENDIF + CALL LCMPUT(KPLIB,HNUSIG,NGRO,2,SIGF(1,IDEL)) + IF(IDEL.EQ.0) THEN + IF(NBESP.GT.0) GO TO 250 + HCHI='CHI' + ELSE + WRITE(HCHI,'(3HCHI,I2.2)') IDEL + ENDIF + CALL LCMPUT(KPLIB,HCHI,NGRO,2,CHI(1,IDEL)) + 250 CONTINUE + DO 260 ISP=1,NBESP + LNZERO=.FALSE. + DO 255 IG=1,NGRO + LNZERO=LNZERO.OR.(CHI4G(IG,ISP).NE.0.0) + 255 CONTINUE + IF(LNZERO) THEN + WRITE(HCHI,'(5HCHI--,I2.2)') ISP + CALL LCMPUT(KPLIB,HCHI,NGRO,2,CHI4G(1,ISP)) + ENDIF + 260 CONTINUE + ENDIF + CALL XDRLGS(KPLIB,1,0,0,NL-1,1,NGRO,SIGS,SCAT,ITYPRO) + DO 340 IED=1,NED + IF(LADD(IED).AND.(HVECT(IED)(:3).NE.'CHI') + 1 .AND.(HVECT(IED)(:2).NE.'NU') + 2 .AND.(HVECT(IED).NE.'NTOT0') + 3 .AND.(HVECT(IED)(:3).NE.'NWT')) THEN + CALL LCMPUT(KPLIB,HVECT(IED),NGRO,2,SADD(1,IED)) + ENDIF + 340 CONTINUE + IF(LGOLD) CALL LCMPUT(KPLIB,'NGOLD',NGRO,2,GOLD) + IF(LBIN.GT.0) THEN + CALL LCMPUT(KPLIB,'BIN-NFS',NGRO,1,NFS) + CALL LCMPUT(KPLIB,'BIN-ENERGY',LBIN+1,2,EBIN) + CALL LCMPUT(KPLIB,'BIN-NTOT0',LBIN,2,BIN) + CALL LCMPUT(KPLIB,'BIN-SIGS00',LBIN,2,BIN(LBIN+1)) + LOGT=.FALSE. + DO 350 I=1,LBIN + LOGT=LOGT.OR.(BIN(2*LBIN+I).NE.0.0) + 350 CONTINUE + IF(LOGT) THEN + CALL LCMPUT(KPLIB,'BIN-NUSIGF',LBIN,2,BIN(2*LBIN+1)) + ENDIF + DEALLOCATE(EBIN,BIN) + IF(LENDEL.EQ.1) CALL LCMPUT(KPLIB,'BIN-DELI',1,2,RDELI) + ENDIF + IF(IMPX.GT.9) CALL LCMLIB(KPLIB) + ENDIF + 400 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(LADD,LSCAT) + DEALLOCATE(CHI4G,ZNPHI,GOLD,SADD,CHI,SIGF,TOTAL,SCAT,SIGS,DELTA, + 1 AWR) + DEALLOCATE(ITYPRO,NFS) + RETURN +* + 900 FORMAT(/33H PROCESSING DRAGON LIBRARY NAMED ,A12,1H.) + 910 FORMAT(26HLIBDRA: MATERIAL/ISOTOPE ',A12,5H' = ',A12,9H' IS MISS, + 1 25HING ON DRAGON FILE NAMED ,A12,10H (ISOTOPE=,I10,2H).) + 920 FORMAT(/30H PROCESSING ISOTOPE/MATERIAL ',A12,11H' (HNISOR=',A12, + 1 3H').) + 930 FORMAT(/23H ISOTOPE/MATERIAL INFO:) + 940 FORMAT(/24H X-SECTION LIBRARY INFO:) + END diff --git a/Dragon/src/LIBDRB.f b/Dragon/src/LIBDRB.f new file mode 100644 index 0000000..600f737 --- /dev/null +++ b/Dragon/src/LIBDRB.f @@ -0,0 +1,773 @@ +*DECK LIBDRB + SUBROUTINE LIBDRB (IPDRL,NGRO,NL,NDEL,NBESP,SN,SB,NED,HVECT,DELTA, + 1 LBIN,NFS,BENER,AWR,DELECC,IGECCO,IMPX,NGF,NGFR,LSCAT,LSIGF,LADD, + 2 LGOLD,SIGS,SCAT,TOTAL,ZNPHI,SIGF,CHI,CHI4G,SADD,GOLD,BIN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read an interpolate in dilution one isotope in draglib format at a +* selected temperature. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPDRL pointer to the draglib (L_DRAGLIB signature). +* NGRO number of energy groups. +* NL number of Legendre orders required in the calculation. +* NL=1 or higher. +* NDEL number of delayed precursor groups. +* NBESP number of energy-dependent fission spectra. +* SN dilution cross section in each energy group. A value of +* 1.0E10 is used for infinite dilution. +* SB dilution cross section as used in Livolant and Jeanpierre +* normalization. +* NED number of extra vector edits. +* HVECT names of the extra vector edits. +* DELTA lethargy widths. +* LBIN number of fine groups. +* NFS number of fine groups per coarse group. +* BENER energy limits of the fine groups. +* AWR mass ratio for current isotope. +* DELECC lethargy width of eccolib libraries. +* IGECCO number of equal-width lethargy groups with eccolib libraries. +* IMPX print flag. +* +*Parameters: input/output +* NGF number of fast groups without self-shielding. +* NGFR number of fast and resonance groups. +* +*Parameters: output +* LSCAT scattering mask (=.true. if a given Legendre order of the +* scattering cross section exists). +* LSIGF fission mask (=.true. if the isotope can fission). +* LADD additional cross section mask (=.true. if a given additional +* cross section exists). +* LGOLD Goldstein-Cohen mask (=.true. if Goldstein-Cohen parameters +* exists). +* SIGS scattering cross sections. +* SCAT scattering transfer matrices. +* TOTAL total cross sections. +* ZNPHI fluxes. +* SIGF nu*fission cross sections. +* CHI fission spectrum. +* CHI4G energy-dependent fission spectra. +* SADD additional cross sections. +* GOLD Goldstein-Cohen parameters. +* BIN BIN(IGR,1): total fine group cross sections; +* BIN(IGR,2): isotropic scattering fine group cross sections; +* BIN(IGR,3): nu*fission fine group cross sections. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + PARAMETER(MAXDIL=50) + CHARACTER*(*) HVECT(NED) + TYPE(C_PTR) IPDRL + INTEGER NGRO,NL,NDEL,NBESP,NED,LBIN,NFS(NGRO),IGECCO,IMPX,NGF,NGFR + REAL SN(NGRO),SB(NGRO),DELTA(NGRO),BENER(LBIN+1),AWR,DELECC, + 1 SIGS(NGRO,NL),SCAT(NGRO,NGRO,NL),TOTAL(NGRO),ZNPHI(NGRO), + 2 SIGF(NGRO,0:NDEL),CHI(NGRO,0:NDEL),CHI4G(NGRO,NBESP), + 3 SADD(NGRO,NED),GOLD(NGRO),BIN(LBIN,3) + LOGICAL LSCAT(NL),LSIGF,LADD(NED),LGOLD +*---- +* LOCAL VARIABLES +*---- + CHARACTER CM*2,CD*4,HSMG*131,HNUSIG*12,HCHI*12,HTOTAL*5 + PARAMETER (IOUT=6,MAXTRA=10000) + INTEGER KTOTLR,KSIGFR,KCHIR,KPHIR + LOGICAL LPCAT + DOUBLE PRECISION TMP,ZNGAR,SQD,SQ0,SQ1,SQ2,SQ3,FACT1,FACT2 + REAL DILUT(MAXDIL) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NJJ,IJJ,KADDR + REAL, ALLOCATABLE, DIMENSION(:) :: GAR,PRI,STIS,UUU,SSS + REAL, ALLOCATABLE, DIMENSION(:,:) :: TERP,SIGT + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LSDIL,LPDIL,LINF +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NJJ(NGRO),IJJ(NGRO),KADDR(NED)) + ALLOCATE(GAR(NGRO**2),TERP(MAXDIL,NGRO),SIGT(NGRO,MAXDIL)) + ALLOCATE(LSDIL(NL),LPDIL(NL),LINF(NGRO)) +* + TOTAL(:NGRO)=0.0 + HTOTAL='NTOT0' + CALL LCMLEN(IPDRL,'NTOT0',LENGT,ITYLCM) + IF(LENGT.EQ.0) CALL XABORT('LIBDRB: MISSING TOTAL XS INFO.') + CALL LCMGET(IPDRL,HTOTAL,TOTAL) + CALL LCMLEN(IPDRL,'NUSIGF',LENGT,ITYLCM) + LSIGF=(LENGT.GT.0) + IF(LSIGF) THEN + DO 10 IDEL=0,NDEL + IF(IDEL.EQ.0) THEN + HNUSIG='NUSIGF' + HCHI='CHI' + ELSE + WRITE(HNUSIG,'(6HNUSIGF,I2.2)') IDEL + WRITE(HCHI,'(3HCHI,I2.2)') IDEL + CALL LCMLEN(IPDRL,HNUSIG,ILONG,ITYLCM) + IF(ILONG.EQ.0) CALL XABORT('LIBDRB: MISSING '//HNUSIG// + 1 ' INFO.') + ENDIF + SIGF(:NGRO,IDEL)=0.0 + CALL LCMGET(IPDRL,HNUSIG,SIGF(1,IDEL)) + IF((NBESP.EQ.0).OR.(IDEL.GT.0)) THEN + CHI(:NGRO,IDEL)=0.0 + CALL LCMLEN(IPDRL,HCHI,LENGT,ITYLCM) + IF(LENGT.GT.0) CALL LCMGET(IPDRL,HCHI,CHI(1,IDEL)) + ENDIF + 10 CONTINUE + DO 15 ISP=1,NBESP + WRITE(HCHI,'(5HCHI--,I2.2)') ISP + CHI4G(:NGRO,ISP)=0.0 + CALL LCMLEN(IPDRL,HCHI,LENGT,ITYLCM) + IF(LENGT.GT.0) CALL LCMGET(IPDRL,HCHI,CHI4G(1,ISP)) + 15 CONTINUE + ELSE + SIGF(:NGRO,0:NDEL)=0.0 + ENDIF + DO 150 IL=0,NL-1 + SIGS(:NGRO,IL+1)=0.0 + SCAT(:NGRO,:NGRO,IL+1)=0.0 + WRITE (CM,'(I2.2)') IL + CALL LCMLEN(IPDRL,'SCAT'//CM,LENGT,ITYLCM) + LPCAT=(LENGT.GT.0) + IF(LPCAT.AND.(IGECCO.EQ.0)) THEN + CALL LCMGET(IPDRL,'NJJS'//CM,NJJ) + CALL LCMGET(IPDRL,'IJJS'//CM,IJJ) + LENGT2=0 + DO 20 I=1,NGRO + LENGT2=LENGT2+NJJ(I) + 20 CONTINUE + GAR(:LENGT)=0.0 + CALL LCMGET(IPDRL,'SCAT'//CM,GAR) + IGAR=0 +* IG2 IS THE SECONDARY GROUP. + DO 40 IG2=1,NGRO + DO 30 IG1=IJJ(IG2),IJJ(IG2)-NJJ(IG2)+1,-1 + IGAR=IGAR+1 + SCAT(IG2,IG1,IL+1)=GAR(IGAR) + 30 CONTINUE + 40 CONTINUE + ELSE IF(LPCAT) THEN + ! on-flight elastic scattering kernel + CALL LCMGET(IPDRL,'NJJS'//CM,NJJ) + CALL LCMGET(IPDRL,'IJJS'//CM,IJJ) + ALLOCATE(PRI(MAXTRA),STIS(NGRO),UUU(NGRO),SSS(IGECCO)) + CALL LIBPRI(MAXTRA,DELECC,AWR,0,IL,NPRI,PRI) + LENGT2=0 + DO 50 I=1,NGRO + LENGT2=LENGT2+NJJ(I) + 50 CONTINUE + GAR(:LENGT)=0.0 + CALL LCMGET(IPDRL,'SCAT'//CM,GAR) + UUU(1)=DELTA(1) + DO 60 I=2,NGRO + UUU(I)=UUU(I-1)+DELTA(I) + 60 CONTINUE + IGAR=0 +* IG2 IS THE SECONDARY GROUP. + DO 90 IG2=1,NGRO + IF(IG2.LE.IGECCO) THEN + CALL LIBECT(MAXTRA,IG2,PRI,UUU,DELECC,DELTA,NPRI,1,MML,STIS) + IGAR=IGAR+NJJ(IG2) + SSS(IG2)=GAR(IGAR) + DO 70 I=1,MML + IG1=IG2-I+1 + IF(IG1.LE.0) GO TO 90 + SCAT(IG2,IG1,IL+1)=STIS(I)*SSS(IG1) + 70 CONTINUE + ELSE + DO 80 IG1=IJJ(IG2),IJJ(IG2)-NJJ(IG2)+1,-1 + IGAR=IGAR+1 + SCAT(IG2,IG1,IL+1)=GAR(IGAR) + 80 CONTINUE + ENDIF + 90 CONTINUE + DEALLOCATE(SSS,UUU,STIS,PRI) + ENDIF + CALL LCMLEN(IPDRL,'SIGS'//CM,LENGT,ITYLCM) + LSCAT(IL+1)=(LENGT.GT.0) + IF(LSCAT(IL+1)) THEN + CALL LCMGET(IPDRL,'SIGS'//CM,SIGS(1,IL+1)) + CALL LCMLEN(IPDRL,'PCAT'//CM,LENGT,ITYLCM) + IF(.NOT.LPCAT.AND.(LENGT.GT.0)) THEN + CALL LCMGET(IPDRL,'NJJS'//CM,NJJ) + CALL LCMGET(IPDRL,'IJJS'//CM,IJJ) + LENGT=0 + DO 100 I=1,NGRO + LENGT=LENGT+NJJ(I) + 100 CONTINUE + GAR(:LENGT)=0.0 + CALL LCMGET(IPDRL,'PCAT'//CM,GAR) + IGAR=0 + DO 115 IG2=1,NGRO + DO 110 IG1=IJJ(IG2),IJJ(IG2)-NJJ(IG2)+1,-1 + IGAR=IGAR+1 + SCAT(IG2,IG1,IL+1)=GAR(IGAR)*SIGS(IG1,IL+1) + 110 CONTINUE + 115 CONTINUE + ELSE IF(.NOT.LPCAT) THEN + DO 120 IG1=1,NGRO + SCAT(IG1,IG1,IL+1)=SIGS(IG1,IL+1) + 120 CONTINUE + ENDIF + ELSE IF(LPCAT) THEN + DO 140 IG1=1,NGRO + TMP=0.0D0 + DO 130 IG2=1,NGRO + TMP=TMP+SCAT(IG2,IG1,IL+1) + 130 CONTINUE + SIGS(IG1,IL+1)=REAL(TMP) + 140 CONTINUE + LSCAT(IL+1)=.TRUE. + ENDIF + 150 CONTINUE + LSCAT(1)=.TRUE. + DO 160 IED=1,NED + SADD(:NGRO,IED)=0.0 + CALL LCMLEN(IPDRL,HVECT(IED),LENGT,ITYLCM) + LADD(IED)=(LENGT.GT.0) + IF(LADD(IED)) CALL LCMGET(IPDRL,HVECT(IED),SADD(1,IED)) + 160 CONTINUE + CALL LCMLEN(IPDRL,'NGOLD',LENGT,ITYLCM) + LGOLD=(LENGT.GT.0) + IF(LGOLD) THEN + GOLD(:NGRO)=0.0 + CALL LCMGET(IPDRL,'NGOLD',GOLD) + ELSE + GOLD(:NGRO)=1.0 + ENDIF + IF(LBIN.GT.0) THEN + CALL LCMGET(IPDRL,'BIN-'//HTOTAL,BIN(1,1)) + CALL LCMGET(IPDRL,'BIN-SIGS00',BIN(1,2)) + CALL LCMLEN(IPDRL,'BIN-NUSIGF',LENGF,ITYLCM) + IF(LENGF.GT.0) THEN + CALL LCMGET(IPDRL,'BIN-NUSIGF',BIN(1,3)) + ELSE + BIN(:LBIN,3)=0.0 + ENDIF + IGF0=0 + DO 190 IG=1,NGRO + IF(NFS(IG).GT.0) THEN +* BIN CROSS SECTION NORMALIZATION. + SQ0=0.0D0 + SQ1=0.0D0 + SQ2=0.0D0 + SQ3=0.0D0 + DO 170 IGF=IGF0+1,IGF0+NFS(IG) + DELTAU=LOG(BENER(IGF)/BENER(IGF+1)) + SQ0=SQ0+DELTAU + SQ1=SQ1+BIN(IGF,1)*DELTAU + SQ2=SQ2+(BIN(IGF,1)-BIN(IGF,2))*DELTAU + SQ3=SQ3+BIN(IGF,3)*DELTAU + 170 CONTINUE + FACT1=TOTAL(IG)*(SQ0/SQ1) + FACT2=(TOTAL(IG)-SIGS(IG,1))*(SQ0/SQ2) + DO 180 IGF=IGF0+1,IGF0+NFS(IG) + BIN(IGF,2)=REAL(BIN(IGF,2)*FACT2+BIN(IGF,1)*(FACT1-FACT2)) + BIN(IGF,1)=REAL(BIN(IGF,1)*FACT1) + IF((LENGF.GT.0).AND.(SQ3.NE.0.0)) THEN + BIN(IGF,3)=REAL(BIN(IGF,3)*(SIGF(IG,0)*(SQ0/SQ3))) + ENDIF + 180 CONTINUE + IGF0=IGF0+NFS(IG) + ENDIF + 190 CONTINUE + ENDIF + KTOTLR=0 + KSIGFR=0 + KPHIR=0 + KCHIR=0 + KADR=0 + KADDR(:NED)=0 +*---- +* PERFORM DILUTION INTERPOLATION. +*---- + CALL LCMLEN(IPDRL,'DILUTION',NDIL,ITYLCM) + IF(NDIL.GT.0) THEN + IF(NDIL+1.GT.MAXDIL) CALL XABORT('LIBDRB: INVALID MAXDIL.') + CALL LCMGET(IPDRL,'DILUTION',DILUT) + IF(DILUT(NDIL).GE.1.0E10) CALL XABORT('LIBDRB: INVALID DILUTI' + 1 //'ON VALUE.') +*---- +* FIND MAX LENGTH OF VECTORS ON SUBMAT +* KTOTLR,KSIGFR,KCHIR,KPHIR AND KADDR +* GIVES LENGTH OF SELF SHIELDING VECTOR +* FOR TOTAL, SIGF, CHI, PHI AND ADD XS +*---- + LSDIL(:NL)=.FALSE. + LPDIL(:NL)=.FALSE. + DO 240 IDIL=1,NDIL + WRITE (CD,'(I4.4)') IDIL + CALL LCMSIX(IPDRL,'SUBMAT'//CD,1) + SIGT(:NGRO,IDIL)=0.0 + CALL LCMGET(IPDRL,HTOTAL,SIGT(1,IDIL)) + DO 220 IL=0,NL-1 + WRITE (CM,'(I2.2)') IL + CALL LCMLEN(IPDRL,'SCAT'//CM,LENGT,ITYLCM) + IF(.NOT.LSDIL(IL+1)) + > LSDIL(IL+1)=(LENGT.GT.0).AND.LSCAT(IL+1) + CALL LCMLEN(IPDRL,'SIGS'//CM,LENGT,ITYLCM) + IF(.NOT.LPDIL(IL+1)) + > LPDIL(IL+1)=(LENGT.GT.0).AND.LSCAT(IL+1) + 220 CONTINUE + CALL LCMLEN(IPDRL,HTOTAL,LENGT,ITYLCM) + KTOTLR=MAX(KTOTLR,LENGT) + CALL LCMLEN(IPDRL,'NUSIGF',LENGT,ITYLCM) + KSIGFR=MAX(KSIGFR,LENGT) + IF(NBESP.EQ.0) THEN + CALL LCMLEN(IPDRL,'CHI',LENGT,ITYLCM) + KCHIR=MAX(KCHIR,LENGT) + ELSE + DO 225 ISP=1,NBESP + WRITE(HCHI,'(5HCHI--,I2.2)') ISP + CALL LCMLEN(IPDRL,HCHI,LENGT,ITYLCM) + KCHIR=MAX(KCHIR,LENGT) + 225 CONTINUE + ENDIF + CALL LCMLEN(IPDRL,'NWT0',LENGT,ITYLCM) + KPHIR=MAX(KPHIR,LENGT) + DO 230 IED=1,NED + CALL LCMLEN(IPDRL,HVECT(IED),LENGT,ITYLCM) + IF((LENGT.GT.0).AND.LADD(IED)) THEN + KADDR(IED)=MAX(KADDR(IED),LENGT) + KADR=MAX(KADDR(IED),KADR) + ENDIF + 230 CONTINUE + CALL LCMSIX(IPDRL,' ',2) + 240 CONTINUE + NGRRE=MAX(KTOTLR,KSIGFR,KCHIR,KPHIR,KADR) + IF(NGRRE.GT.NGRO) CALL XABORT('LIBDRB: TOO MANY GROUPS.') +* + TERP(:MAXDIL,:NGRO)=0.0 + DILUT(NDIL+1)=1.0E10 + DO 280 IG1=1,NGRRE + LINF(IG1)=.FALSE. + ZNPHI(IG1)=0.0 + DILX=MIN(SN(IG1),1.0E10) + IF(DILX.LE.0.0) THEN + WRITE (HSMG,930) IG1 + CALL XABORT(HSMG) + ENDIF + IFIRST=0 + DO 260 I=1,NDIL+1 + IF(ABS(DILX-DILUT(I)).LE.1.0E-5*ABS(DILX)) THEN + TERP(I,IG1)=1.0 + GO TO 280 + ELSE IF(DILX.LT.DILUT(I)) THEN + IFIRST=I-1 + GO TO 270 + ENDIF + 260 CONTINUE +* + 270 SQD=SQRT(DILX) + IF((IFIRST-1.GE.1).AND.(IFIRST+2.LE.NDIL)) THEN + SQ0=SQRT(DILUT(IFIRST-1)) + SQ1=SQRT(DILUT(IFIRST)) + SQ2=SQRT(DILUT(IFIRST+1)) + SQ3=SQRT(DILUT(IFIRST+2)) + TERP(IFIRST-1,IG1)=REAL((SQ1-SQD)*(SQ2-SQD)*(SQ3-SQD)/ + 1 (SQ1-SQ0)/(SQ2-SQ0)/(SQ3-SQ0)) + TERP(IFIRST,IG1)=REAL((SQ0-SQD)*(SQ2-SQD)*(SQ3-SQD)/ + 1 (SQ0-SQ1)/(SQ2-SQ1)/(SQ3-SQ1)) + TERP(IFIRST+1,IG1)=REAL((SQ0-SQD)*(SQ1-SQD)*(SQ3-SQD)/ + 1 (SQ0-SQ2)/(SQ1-SQ2)/(SQ3-SQ2)) + TERP(IFIRST+2,IG1)=REAL((SQ0-SQD)*(SQ1-SQD)*(SQ2-SQD)/ + 1 (SQ0-SQ3)/(SQ1-SQ3)/(SQ2-SQ3)) + TT=TERP(IFIRST-1,IG1)*SIGT(IG1,IFIRST-1) + 1 +TERP(IFIRST,IG1)*SIGT(IG1,IFIRST) + 2 +TERP(IFIRST+1,IG1)*SIGT(IG1,IFIRST+1) + 3 +TERP(IFIRST+2,IG1)*SIGT(IG1,IFIRST+2) + YMIN=MIN(SIGT(IG1,IFIRST),SIGT(IG1,IFIRST+1)) + YMAX=MAX(SIGT(IG1,IFIRST),SIGT(IG1,IFIRST+1)) + IF((TT.GT.YMAX).OR.(TT.LT.YMIN)) THEN + TERP(IFIRST-1,IG1)=0.0 + TERP(IFIRST,IG1)=REAL((SQ2-SQD)/(SQ2-SQ1)) + TERP(IFIRST+1,IG1)=REAL((SQ1-SQD)/(SQ1-SQ2)) + TERP(IFIRST+2,IG1)=0.0 + ENDIF + ELSE IF((IFIRST.EQ.1).AND.(IFIRST+2.LE.NDIL)) THEN + SQ1=SQRT(DILUT(1)) + SQ2=SQRT(DILUT(2)) + SQ3=SQRT(DILUT(3)) + TERP(1,IG1)=REAL((SQ2-SQD)*(SQ3-SQD)/(SQ2-SQ1)/(SQ3-SQ1)) + TERP(2,IG1)=REAL((SQ1-SQD)*(SQ3-SQD)/(SQ1-SQ2)/(SQ3-SQ2)) + TERP(3,IG1)=REAL((SQ1-SQD)*(SQ2-SQD)/(SQ1-SQ3)/(SQ2-SQ3)) + TT=TERP(1,IG1)*SIGT(IG1,1)+TERP(2,IG1)*SIGT(IG1,2) + 1 +TERP(3,IG1)*SIGT(IG1,3) + YMIN=MIN(SIGT(IG1,1),SIGT(IG1,2)) + YMAX=MAX(SIGT(IG1,1),SIGT(IG1,2)) + IF((TT.GT.YMAX).OR.(TT.LT.YMIN)) THEN + TERP(1,IG1)=REAL((SQ2-SQD)/(SQ2-SQ1)) + TERP(2,IG1)=REAL((SQ1-SQD)/(SQ1-SQ2)) + TERP(3,IG1)=0.0 + ENDIF + ELSE IF((IFIRST-1.GE.1).AND.(IFIRST+1.EQ.NDIL)) THEN + SQ0=SQRT(DILUT(NDIL-2)) + SQ1=SQRT(DILUT(NDIL-1)) + SQ2=SQRT(DILUT(NDIL)) + TERP(NDIL-2,IG1)=REAL((SQ1-SQD)*(SQ2-SQD)/(SQ1-SQ0)/(SQ2-SQ0)) + TERP(NDIL-1,IG1)=REAL((SQ0-SQD)*(SQ2-SQD)/(SQ0-SQ1)/(SQ2-SQ1)) + TERP(NDIL,IG1)=REAL((SQ0-SQD)*(SQ1-SQD)/(SQ0-SQ2)/(SQ1-SQ2)) + TT=TERP(NDIL-2,IG1)*SIGT(IG1,NDIL-2) + 1 +TERP(NDIL-1,IG1)*SIGT(IG1,NDIL-1) + 2 +TERP(NDIL,IG1)*SIGT(IG1,NDIL) + YMIN=MIN(SIGT(IG1,NDIL-1),SIGT(IG1,NDIL)) + YMAX=MAX(SIGT(IG1,NDIL-1),SIGT(IG1,NDIL)) + IF((TT.GT.YMAX).OR.(TT.LT.YMIN)) THEN + TERP(NDIL-2,IG1)=0.0 + TERP(NDIL-1,IG1)=REAL((SQ2-SQD)/(SQ2-SQ1)) + TERP(NDIL,IG1)=REAL((SQ1-SQD)/(SQ1-SQ2)) + ENDIF + ELSE IF((IFIRST.EQ.0).OR.((IFIRST.EQ.1).AND.(NDIL.EQ.2))) THEN + SQ0=SQRT(DILUT(1)) + SQ1=SQRT(DILUT(2)) + TERP(1,IG1)=REAL((SQ1-SQD)/(SQ1-SQ0)) + TERP(2,IG1)=REAL((SQ0-SQD)/(SQ0-SQ1)) + ELSE IF(IFIRST.EQ.NDIL) THEN + LINF(IG1)=.TRUE. + TERP(NDIL,IG1)=DILUT(NDIL)/DILX + ELSE + CALL XABORT('LIBDRB: FAILURE OF DILUTION INTERPOLATION.') + ENDIF + 280 CONTINUE +* + NGRODP=NGRO+1 + NGROIN=0 + DO 330 IDIL=1,NDIL + NCORF=0 + DO 290 IG1=NGRO,1,-1 + IF(TERP(IDIL,IG1).NE.0.0) THEN + NCORF=IG1 + GO TO 300 + ENDIF + 290 CONTINUE + 300 NGROIN=MAX(NCORF,NGROIN) + NCORD=NGRO+1 + DO 310 IG1=1,NGROIN + IF(TERP(IDIL,IG1).NE.0.0) THEN + NCORD=IG1 + GO TO 320 + ENDIF + 310 CONTINUE + 320 NGRODP=MIN(NCORD,NGRODP) + 330 CONTINUE + DO 345 IDIL=1,NDIL + DO 340 IG1=1,NGRO + IF(SIGT(IG1,IDIL).NE.0.0) THEN + NGF=MIN(NGF,IG1-1) + NGFR=MAX(NGFR,IG1) + ENDIF + 340 CONTINUE + 345 CONTINUE + IF(NGROIN.EQ.0.OR.NGRRE.EQ.0) THEN + ZNPHI(:NGRO)=1.0 + GO TO 850 + ENDIF + KTOTLR=MIN(KTOTLR,NGROIN) + KSIGFR=MIN(KSIGFR,NGROIN) + KCHIR=MIN(KCHIR,NGROIN) + KPHIR=MIN(KPHIR,NGROIN) + DO 360 IED=1,NED + KADDR(IED)=MIN(KADDR(IED),NGROIN) + 360 CONTINUE +*---- +* VARIOUS DIMENSION OF VECTORS ARE SET +* LOOP OVER DILUTION AND SELF-SHIELD XS +* FROM NGRODP TO NGROIN (THESE CORRESPOND +* TO CASES WHERE DIL<1.0E10 FOR AT LEAST ONE GROUP +* HERE ONE ASSUMES THAT TOTAL XS ALWAYS SELF-SHIELDED +*---- + DO 640 IDIL=1,NDIL + DO 370 IG1=1,NGRO + IF(TERP(IDIL,IG1).NE.0.0) GO TO 380 + 370 CONTINUE + GO TO 640 + 380 WRITE (CD,'(I4.4)') IDIL + CALL LCMSIX(IPDRL,'SUBMAT'//CD,1) + DO 390 IG1=NGRODP,NGROIN + TOTAL(IG1)=TOTAL(IG1)+TERP(IDIL,IG1)*SIGT(IG1,IDIL) + 390 CONTINUE + IF(KSIGFR.GT.0) THEN + DO 420 IDEL=0,NDEL + IF(IDEL.EQ.0) THEN + HNUSIG='NUSIGF' + ELSE + WRITE(HNUSIG,'(6HNUSIGF,I2.2)') IDEL + ENDIF + GAR(:KSIGFR)=0.0 + CALL LCMGET(IPDRL,HNUSIG,GAR) + DO 410 IG1=NGRODP,KSIGFR + SIGF(IG1,IDEL)=SIGF(IG1,IDEL)+TERP(IDIL,IG1)*GAR(IG1) + 410 CONTINUE + 420 CONTINUE + ENDIF + IF(KCHIR.GT.0) THEN + DO 440 IDEL=0,NDEL + IF(IDEL.EQ.0) THEN + IF(NBESP.GT.0) GO TO 440 + HCHI='CHI' + ELSE + WRITE(HCHI,'(3HCHI,I2.2)') IDEL + ENDIF + GAR(:KCHIR)=0.0 + CALL LCMGET(IPDRL,HCHI,GAR) + DO 430 IG1=NGRODP,KCHIR + CHI(IG1,IDEL)=CHI(IG1,IDEL)+TERP(IDIL,IG1)*GAR(IG1) + 430 CONTINUE + 440 CONTINUE + DO 460 ISP=1,NBESP + WRITE(HCHI,'(5HCHI--,I2.2)') ISP + GAR(:KCHIR)=0.0 + CALL LCMLEN(IPDRL,HCHI,ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(IPDRL,HCHI,GAR) + DO 450 IG1=NGRODP,KCHIR + CHI4G(IG1,ISP)=CHI4G(IG1,ISP)+TERP(IDIL,IG1)*GAR(IG1) + 450 CONTINUE + ENDIF + 460 CONTINUE + ENDIF + DO 600 IL=0,NL-1 + WRITE (CM,'(I2.2)') IL + IF(LSDIL(IL+1).AND.(IGECCO.EQ.0)) THEN + CALL LCMGET(IPDRL,'NJJS'//CM,NJJ) + CALL LCMGET(IPDRL,'IJJS'//CM,IJJ) + LENGT=0 + DO 470 I=1,NGRO + LENGT=LENGT+NJJ(I) + 470 CONTINUE + GAR(:LENGT)=0.0 + CALL LCMGET(IPDRL,'SCAT'//CM,GAR) + IGAR=0 + DO 490 IG2=1,NGRO + DO 480 IG1=IJJ(IG2),IJJ(IG2)-NJJ(IG2)+1,-1 + IGAR=IGAR+1 + SCAT(IG2,IG1,IL+1)=SCAT(IG2,IG1,IL+1)+TERP(IDIL,IG1) + 1 *GAR(IGAR) + 480 CONTINUE + 490 CONTINUE + ELSE IF(LSDIL(IL+1)) THEN + ! on-flight elastic scattering kernel + CALL LCMGET(IPDRL,'NJJS'//CM,NJJ) + CALL LCMGET(IPDRL,'IJJS'//CM,IJJ) + ALLOCATE(PRI(MAXTRA),STIS(NGRO),UUU(NGRO),SSS(IGECCO)) + CALL LIBPRI(MAXTRA,DELECC,AWR,0,IL,NPRI,PRI) + LENGT2=0 + DO 500 I=1,NGRO + LENGT2=LENGT2+NJJ(I) + 500 CONTINUE + GAR(:LENGT)=0.0 + CALL LCMGET(IPDRL,'SCAT'//CM,GAR) + UUU(1)=DELTA(1) + DO 510 I=2,NGRO + UUU(I)=UUU(I-1)+DELTA(I) + 510 CONTINUE + IGAR=0 +* IG2 IS THE SECONDARY GROUP. + DO 540 IG2=1,NGRO + IF(IG2.LE.IGECCO) THEN + CALL LIBECT(MAXTRA,IG2,PRI,UUU,DELECC,DELTA,NPRI,1,MML, + 1 STIS) + IGAR=IGAR+NJJ(IG2) + SSS(IG2)=GAR(IGAR) + DO 520 I=1,MML + IG1=IG2-I+1 + IF(IG1.LE.0) GO TO 540 + SCAT(IG2,IG1,IL+1)=SCAT(IG2,IG1,IL+1)+TERP(IDIL,IG1)* + 1 STIS(I)*SSS(IG1) + 520 CONTINUE + ELSE + DO 530 IG1=IJJ(IG2),IJJ(IG2)-NJJ(IG2)+1,-1 + IGAR=IGAR+1 + SCAT(IG2,IG1,IL+1)=SCAT(IG2,IG1,IL+1)+TERP(IDIL,IG1)* + 1 GAR(IGAR) + 530 CONTINUE + ENDIF + 540 CONTINUE + DEALLOCATE(SSS,UUU,STIS,PRI) + ENDIF + IF(LPDIL(IL+1)) THEN + GAR(:NGRO)=0.0 + CALL LCMGET(IPDRL,'SIGS'//CM,GAR) + DO 590 IG1=NGRODP,NGROIN + SIGS(IG1,IL+1)=SIGS(IG1,IL+1)+TERP(IDIL,IG1)*GAR(IG1) + 590 CONTINUE + ENDIF + 600 CONTINUE + IF(KPHIR.GT.0) THEN + GAR(:KPHIR)=0.0 + CALL LCMGET(IPDRL,'NWT0',GAR) + DO 610 IG1=NGRODP,KPHIR + IF(.NOT.LINF(IG1)) THEN + ZNPHI(IG1)=ZNPHI(IG1)+TERP(IDIL,IG1)*GAR(IG1)* + 1 DILUT(IDIL) + ELSE + ZNPHI(IG1)=GAR(IG1)*DILUT(IDIL) + ENDIF + 610 CONTINUE + ENDIF + DO 630 IED=1,NED + IF(KADDR(IED).GT.0) THEN + GAR(:KADDR(IED))=0.0 + CALL LCMGET(IPDRL,HVECT(IED),GAR) + DO 620 IG1=NGRODP,KADDR(IED) + SADD(IG1,IED)=SADD(IG1,IED)+TERP(IDIL,IG1)*GAR(IG1) + 620 CONTINUE + ENDIF + 630 CONTINUE + CALL LCMSIX(IPDRL,' ',2) + 640 CONTINUE +*---- +* COMPUTE MISSING SCATTERING INFORMATION. +*---- + DO 710 IL=0,NL-1 + IF(LPDIL(IL+1).AND.(.NOT.LSDIL(IL+1))) THEN + WRITE (CM,'(I2.2)') IL + CALL LCMGET(IPDRL,'NJJS'//CM,NJJ) + CALL LCMGET(IPDRL,'IJJS'//CM,IJJ) + LENGT=0 + DO 650 I=1,NGRO + LENGT=LENGT+NJJ(I) + 650 CONTINUE + GAR(:LENGT)=0.0 + CALL LCMGET(IPDRL,'PCAT'//CM,GAR) + IGAR=0 + DO 680 IG2=1,NGRO + DO 660 IG1=1,NGRO + SCAT(IG2,IG1,IL+1)=0.0 + 660 CONTINUE + DO 670 IG1=IJJ(IG2),IJJ(IG2)-NJJ(IG2)+1,-1 + IGAR=IGAR+1 + SCAT(IG2,IG1,IL+1)=GAR(IGAR)*SIGS(IG1,IL+1) + 670 CONTINUE + 680 CONTINUE + ELSE IF((.NOT.LPDIL(IL+1)).AND.LSDIL(IL+1)) THEN + DO 700 IG1=1,NGRO + TMP=0.0D0 + DO 690 IG2=1,NGRO + TMP=TMP+SCAT(IG2,IG1,IL+1) + 690 CONTINUE + IF(IL.EQ.0) THEN + SIGS(IG1,1)=MIN(REAL(TMP),TOTAL(IG1)) + ELSE + SIGS(IG1,IL+1)=REAL(TMP) + ENDIF + 700 CONTINUE + ENDIF + 710 CONTINUE +*---- +* COMPUTE CONDENSED FINE STRUCTURE FUNCTION. +*---- + DO 740 IG1=1,NGROIN + IF((.NOT.LSDIL(1)).AND.(.NOT.LPDIL(1))) THEN +* SCATTERING CROSS SECTIONS ARE NOT SELF-SHIELDED. + TMP=-TOTAL(IG1) + DO 720 IG2=1,IG1-1 + TMP=TMP+SCAT(IG1,IG2,1)*ZNPHI(IG2)*DELTA(IG2)/DELTA(IG1) + 720 CONTINUE + ZNGAR=(TMP+SCAT(IG1,IG1,1))*SB(IG1)/ + 1 (SB(IG1)-SCAT(IG1,IG1,1)) + ELSE +* SCATTERING CROSS SECTIONS ARE SELF-SHIELDED. + ZNGAR=-TOTAL(IG1) + DO 730 IG2=1,IG1 + ZNGAR=ZNGAR+SCAT(IG1,IG2,1)*DELTA(IG2)/DELTA(IG1) + 730 CONTINUE + ENDIF + IF(IG1.LT.NGRODP) ZNGAR=0.0 + IF(KPHIR.EQ.0) THEN +* USE A CALCULATED VALUE. + ZNPHI(IG1)=REAL(1.0+ZNGAR/SB(IG1)) + ELSE IF(LINF(IG1)) THEN +* USE AN INTERPOLATED VALUE NEAR INFINITE DILUTION. + AUX=(DILUT(NDIL)/SB(IG1))**2 + ZNPHI(IG1)=REAL(AUX*ZNPHI(IG1)+(1.0-AUX)*ZNGAR) + ZNPHI(IG1)=1.0+ZNPHI(IG1)/SB(IG1) + ELSE +* USE AN INTERPOLATED VALUE. + ZNPHI(IG1)=1.0+ZNPHI(IG1)/SB(IG1) + ENDIF + IF((ZNPHI(IG1).LE.0.0).OR.(ZNPHI(IG1).GT.10.0)) THEN + WRITE (HSMG,960) ZNPHI(IG1),IG1,SB(IG1),SN(IG1),KPHIR + CALL XABORT(HSMG) + ELSE IF((ZNPHI(IG1).GT.1.2).AND.(IMPX.GE.3)) THEN + WRITE (HSMG,960) ZNPHI(IG1),IG1,SB(IG1),SN(IG1),KPHIR + WRITE(6,'(1X,A)') HSMG + ENDIF + 740 CONTINUE + DO 750 IG1=NGROIN+1,NGRO + ZNPHI(IG1)=1.0 + 750 CONTINUE +*---- +* DIVIDE EFFECTIVE REACTION RATES BY ZNPHI FOR SELF-SHIELDED +* REACTION RATES +*---- + DO 780 IL=0,NL-1 + IF(LSCAT(IL+1).AND.(LSDIL(IL+1).OR.LPDIL(IL+1))) THEN + DO 770 IG1=NGRODP,NGROIN + SIGS(IG1,IL+1)=SIGS(IG1,IL+1)/ZNPHI(IG1) + DO 760 IG2=1,NGRO + SCAT(IG2,IG1,IL+1)=SCAT(IG2,IG1,IL+1)/ZNPHI(IG1) + 760 CONTINUE + 770 CONTINUE + ENDIF + 780 CONTINUE + DO 790 IG1=NGRODP,NGROIN + TOTAL(IG1)=TOTAL(IG1)/ZNPHI(IG1) + 790 CONTINUE + IF(KSIGFR.GT.0) THEN + DO 810 IDEL=0,NDEL + DO 800 IG1=NGRODP,NGROIN + SIGF(IG1,IDEL)=SIGF(IG1,IDEL)/ZNPHI(IG1) + 800 CONTINUE + 810 CONTINUE + ENDIF + DO 830 IED=1,NED + IF(KADDR(IED).GT.0) THEN + DO 820 IG1=NGRODP,NGROIN + SADD(IG1,IED)=SADD(IG1,IED)/ZNPHI(IG1) + 820 CONTINUE + ENDIF + 830 CONTINUE + IF(IMPX.GT.4) THEN + WRITE(IOUT,940) + DO 840 IG1=1,NGRO + WRITE (IOUT,950) IG1,SN(IG1),SB(IG1),ZNPHI(IG1),TOTAL(IG1), + 1 SIGS(IG1,1),SIGF(IG1,0),GOLD(IG1) + 840 CONTINUE + WRITE (IOUT,'(/)') + ENDIF + ELSE + ZNPHI(:NGRO)=1.0 + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 850 DEALLOCATE(LINF,LPDIL,LSDIL) + DEALLOCATE(SIGT,TERP,GAR) + DEALLOCATE(KADDR,IJJ,NJJ) + RETURN +* + 930 FORMAT(42HLIBDRB: NEGATIVE OR ZERO DILUTION IN GROUP,I4,1H.) + 940 FORMAT(/5X,'GROUP',10X,'DILUT',13X,'SB',11X,'NWT0',10X,'NTOT0', + 1 11X,'SIGS',9X,'NUSIGF',10X,'NGOLD') + 950 FORMAT(5X,I5,1P,8E15.5) + 960 FORMAT(32HLIBDRB: INVALID VALUE OF ZNPHI (,1P,E11.3, + 1 10H) IN GROUP,I4,11H. DILUTION=,E11.3,2H (,E11.3, + 2 9H). KPHIR=,I4,1H.) + END diff --git a/Dragon/src/LIBE3R.f b/Dragon/src/LIBE3R.f new file mode 100644 index 0000000..c644c52 --- /dev/null +++ b/Dragon/src/LIBE3R.f @@ -0,0 +1,298 @@ +*DECK LIBE3R + SUBROUTINE LIBE3R(CFILNA1,CFILNA2,MAXR,NEL,NBESP,IMPX,ITNAM, + 1 ITZEA,KPAX,BPAX,ENER) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read depletion data on an APOLIB-3 formatted library. +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input +* CFILNA1 APOLIB-3 cross section file name. +* CFILNA2 APOLIB-3 depletion file name. +* MAXR number of reaction types. +* NEL number of isotopes on library. +* NBESP number of energy-dependent fission yield matrices. +* IMPX print flag. +* +*Parameters: output +* ITNAM reactive isotope names in chain. +* ITZEA 6-digit nuclide identifier: +* atomic number z*10000 (digits) + mass number a*10 + +* energy state (0 = ground state, 1 = first state, etc.). +* KPAX complete reaction type matrix. +* BPAX complete branching ratio matrix. +* ENER output energy mesh corresponding to a yield macrogroup. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER CFILNA1*(*),CFILNA2*(*) + INTEGER MAXR,NEL,NBESP,IMPX,ITNAM(3,NEL),ITZEA(NEL), + 1 KPAX(NEL+MAXR,NEL) + REAL BPAX(NBESP,NEL+MAXR,NEL),ENER(NBESP+1) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPAP1,IPAP2 + DOUBLE PRECISION SUM + PARAMETER (IOUT=6,MAXR2=12) + PARAMETER (KDECAY=1,KFISSP=2,KCAPTU=3,KN2N=4,KN3N=5,KN4N=6) + CHARACTER RECNAM*80,RECNAM2*80,HSMG*131,NMDEPA(MAXR2)*6 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IA,IZ + REAL, ALLOCATABLE, DIMENSION(:) :: BRANCH,FSYIELDS,YIELDEN + CHARACTER(LEN=100), ALLOCATABLE, DIMENSION(:) :: LIST + CHARACTER(LEN=24), ALLOCATABLE, DIMENSION(:) :: NAMES,DEPLNAMES, + > FSISNAMES,FSPRNAMES,PNAMES,REACID +*---- +* DATA STATEMENTS +*---- + SAVE NMDEPA + DATA NMDEPA/'DECAY ','NUFISS','MT102 ','MT16 ', + > 'MT17 ','MT37 ','MT107 ','MT103 ', + > 'MT108 ','MT28 ','MT104 ','MT105 '/ +*---- +* OPEN APOLIB FILES +*---- + CALL hdf5_open_file(CFILNA1,IPAP1,.true.) + IF(IMPX.GT.1) THEN + CALL hdf5_list_groups(IPAP1,"/",LIST) + WRITE(*,*) + WRITE(*,*) 'LIBE3R: GROUP TABLE OF CONTENTS FOR FILE ',CFILNA1 + DO I=1,SIZE(LIST) + WRITE(*,*) TRIM(LIST(I)) + ENDDO + DEALLOCATE(LIST) + ENDIF + IPAP2=C_NULL_PTR + IF(CFILNA2.NE.' ') THEN + CALL hdf5_open_file(CFILNA2,IPAP2,.true.) + IF(IMPX.GT.1) THEN + CALL hdf5_list_groups(IPAP2,"/",LIST) + WRITE(*,*) + WRITE(*,*) 'LIBE3R: GROUP TABLE OF CONTENTS FOR FILE ',CFILNA2 + DO I=1,SIZE(LIST) + WRITE(*,*) TRIM(LIST(I)) + ENDDO + DEALLOCATE(LIST) + ENDIF + ENDIF +*---- +* RECOVER INFORMATION FROM Head AND PhysicalData GROUPS IN IPAP1 +*---- + CALL hdf5_read_data(IPAP1,"Head/nbIs",NISOT) + IF(NISOT.NE.NEL) CALL XABORT('LIBE3R: INVALID VALUE OF NEL.') + CALL hdf5_read_data(IPAP1,"Head/IsNames",NAMES) + DO ISO=1,NISOT + READ(NAMES(ISO),'(3A4)') (ITNAM(II,ISO),II=1,3) + ENDDO + CALL hdf5_read_data(IPAP1,"PhysicalData/MassNb",IA) + CALL hdf5_read_data(IPAP1,"PhysicalData/AtomicNb",IZ) +*---- +* RECOVER INFORMATION FROM "Yields GROUP IN IPAP2 +*---- + IF(C_ASSOCIATED(IPAP2)) THEN + CALL hdf5_list_groups(IPAP2,"Chain",DEPLNAMES) + CALL hdf5_read_data(IPAP2,"Yields/FsIsNames",FSISNAMES) + CALL hdf5_read_data(IPAP2,"Yields/FsPrNames",FSPRNAMES) + CALL hdf5_read_data(IPAP2,"Yields/FsYields",FSYIELDS) + CALL hdf5_read_data(IPAP2,"Yields/YieldEnMshInMeV",YIELDEN) + NDEP=SIZE(DEPLNAMES) + NDFI=SIZE(FSISNAMES) + NDFP=SIZE(FSPRNAMES) +*---- +* FISSION YIELD NORMALIZATION +*---- + DO IGF=1,NBESP + DO IFI=1,NDFI + SUM=0.0D0 + DO IFP=1,NDFP + IOF=((IFP-1)*NDFI+IFI-1)*NBESP+IGF + SUM=SUM+FSYIELDS(IOF) + ENDDO + DO IFP=1,NDFP + IOF=((IFP-1)*NDFI+IFI-1)*NBESP+IGF + FSYIELDS(IOF)=2.0*FSYIELDS(IOF)/REAL(SUM) + ENDDO + ENDDO + ENDDO + ELSE + NDEP=0 + NDFI=0 + NDFP=0 + ENDIF +*---- +* MAIN LOOP OVER ISOTOPES +*---- + NDFP2=0 + DO ISO=1,NISOT + ITZEA(ISO)=IZ(ISO)*10000+IA(ISO)*10 + II=LEN(TRIM(NAMES(ISO))) + IF(NAMES(ISO)(II:II).EQ."M") ITZEA(ISO)=ITZEA(ISO)+1 +*---- +* DECAY AND BURNOUT OF ISOTOPE ISO +*---- + WRITE(RECNAM,'(10HIsotopeXS/,A,10H/DecayData)') TRIM(NAMES(ISO)) + IF(hdf5_group_exists(IPAP1,TRIM(RECNAM))) THEN + CALL hdf5_read_data(IPAP1,TRIM(RECNAM)//"/Lambda",DECAY) + IF(DECAY.NE.0.0) THEN + KPAX(NEL+KDECAY,ISO)=1 + BPAX(:,NEL+KDECAY,ISO)=DECAY*1.E8 + ENDIF + ENDIF + WRITE(RECNAM,'(10HIsotopeXS/,A,12H/ReactionXS/)') + 1 TRIM(NAMES(ISO)) + IF(hdf5_group_exists(IPAP1,TRIM(RECNAM))) THEN + CALL hdf5_list_datasets(IPAP1,TRIM(RECNAM),LIST) + DO IREAC=2,MAXR + II=LEN(TRIM(NMDEPA(IREAC))) + DO I=1,SIZE(LIST) + IF(LIST(I)(:II).EQ.NMDEPA(IREAC)) THEN + KPAX(NEL+IREAC,ISO)=1 + EXIT + ENDIF + ENDDO + ENDDO + DEALLOCATE(LIST) + ENDIF + WRITE(RECNAM,'(10HIsotopeXS/,A,8H/Energy/)') TRIM(NAMES(ISO)) + IF(hdf5_group_exists(IPAP1,TRIM(RECNAM))) THEN + IF(KPAX(NEL+KFISSP,ISO).EQ.1) THEN + WRITE(RECNAM2,'(A,16HFISS/EnergyValue)') TRIM(RECNAM) + CALL hdf5_read_data(IPAP1,TRIM(RECNAM2),VALUE) + BPAX(:,NEL+KFISSP,ISO)=VALUE + ENDIF + IF(KPAX(NEL+KCAPTU,ISO).EQ.1) THEN + WRITE(RECNAM2,'(A,18HMT-102/EnergyValue)') TRIM(RECNAM) + CALL hdf5_read_data(IPAP1,TRIM(RECNAM2),VALUE) + BPAX(:,NEL+KCAPTU,ISO)=VALUE + ENDIF + ENDIF + IF(IMPX.GT.2) THEN + WRITE(IOUT,100) NAMES(ISO),BPAX(1,NEL+KDECAY,ISO), + 1 BPAX(1,NEL+KFISSP,ISO),BPAX(1,NEL+KCAPTU,ISO) + WRITE(IOUT,110) (NMDEPA(I),KPAX(NEL+I,ISO),I=1,MAXR) + ENDIF +*---- +* PARENT REACTIONS OF ISOTOPE ISO +*---- + IF(.NOT.C_ASSOCIATED(IPAP2)) CYCLE + DO I=1,NDEP + IF(NAMES(ISO).EQ.DEPLNAMES(I)) GO TO 10 + ENDDO + GO TO 25 + 10 WRITE(RECNAM,'(6HChain/,A,9H/NBPARENT)') TRIM(NAMES(ISO)) + CALL hdf5_read_data(IPAP2, RECNAM, NBPAR) + IF(NBPAR.EQ.0) GO TO 25 + WRITE(RECNAM,'(6HChain/,A,1H/)') TRIM(NAMES(ISO)) + CALL hdf5_read_data(IPAP2,TRIM(RECNAM)//"BRANCHRATIO",BRANCH) + CALL hdf5_read_data(IPAP2,TRIM(RECNAM)//"PARENTNAME",PNAMES) + CALL hdf5_read_data(IPAP2,TRIM(RECNAM)//"REACTIONID",REACID) + IF(IMPX.GT.2) WRITE(IOUT,120) (PNAMES(IPAR),IPAR=1,NBPAR) + DO IPAR=1,NBPAR + JSO=0 + DO I=1,NISOT + IF(PNAMES(IPAR).EQ.NAMES(I)) THEN + JSO=I + GO TO 20 + ENDIF + ENDDO + WRITE(HSMG,'(38HLIBE3R: UNABLE TO FIND PARENT ISOTOPE ,A, + 1 8H OF SON ,A,19H IN DEPLETION LIST.)') TRIM(PNAMES(IPAR)), + 2 TRIM(NAMES(ISO)) + CALL XABORT(HSMG) + 20 IF(REACID(IPAR)(:5).EQ.'DRTYP') THEN + KPAX(ISO,JSO)=KDECAY + ELSE IF(REACID(IPAR).EQ.'REAMT102') THEN + KPAX(ISO,JSO)=KCAPTU + ELSE IF(REACID(IPAR).EQ.'REAMT16') THEN + KPAX(ISO,JSO)=KN2N + ELSE IF(REACID(IPAR).EQ.'REAMT17') THEN + KPAX(ISO,JSO)=KN3N + ELSE IF(REACID(IPAR).EQ.'REAMT37') THEN + KPAX(ISO,JSO)=KN4N + ELSE + WRITE(HSMG,'(36HLIBE3R: UNKNOWN PRODUCTION REACTION ,A)') + 1 TRIM(REACID(IPAR)) + CALL XABORT(HSMG) + ENDIF + BPAX(:,ISO,JSO)=BRANCH(IPAR) + ENDDO + DEALLOCATE(REACID,PNAMES,BRANCH) +*---- +* FISSION YIELD OF ISOTOPE ISO +*---- + 25 IFP=0 + DO I=1,NDFP + IF(NAMES(ISO).EQ.FSPRNAMES(I)) THEN + IFP=I + GO TO 30 + ENDIF + ENDDO + GO TO 50 + 30 DO IPAR=1,NDFI + JSO=0 + DO I=1,NISOT + IF(FSISNAMES(IPAR).EQ.NAMES(I)) THEN + JSO=I ! fissile isotope + GO TO 40 + ENDIF + ENDDO + WRITE(HSMG,'(39HLIBE3R: UNABLE TO FIND FISSILE ISOTOPE ,A, + 1 8H OF SON ,A,19H IN DEPLETION LIST.)') TRIM(PNAMES(IPAR)), + 2 TRIM(NAMES(ISO)) + CALL XABORT(HSMG) + 40 KPAX(ISO,JSO)=KFISSP + DO I=1,NBESP + IOF=((IFP-1)*NDFI+IPAR-1)*NBESP+I + BPAX(I,ISO,JSO)=FSYIELDS(IOF) + ENER(I)=YIELDEN(I)*1.E6 + ENDDO + ENER(NBESP+1)=YIELDEN(NBESP+1)*1.E6 + ENDDO + 50 DO IPAR=1,NDFP + IF(FSPRNAMES(IPAR).EQ.NAMES(ISO)) THEN + NDFP2=NDFP2+1 + GO TO 60 + ENDIF + ENDDO + 60 CONTINUE + ENDDO + IF(NDFP2.NE.NDFP) CALL XABORT('LIBE3R: MISSING FISSION PRODUCT.') + IF(C_ASSOCIATED(IPAP2)) DEALLOCATE(YIELDEN,FSYIELDS,FSPRNAMES, + 1 FSISNAMES,DEPLNAMES) + DEALLOCATE(IZ,IA,NAMES) + CALL hdf5_close_file(IPAP1) + CALL hdf5_close_file(IPAP2) +*---- +* FIND FISSION PRODUCTS +*---- + DO ISO=1,NISOT + DO JSO=1,NISOT + IF(KPAX(JSO,ISO).EQ.KFISSP) KPAX(NEL+KFISSP,JSO)=-1 + ENDDO + ENDDO + RETURN +* + 100 FORMAT(/44H LIBE3R: DECAY AND BURNOUT DATA FOR ISOTOPE=,A/ + 1 5X,6HDECAY=,1P,E12.5,7H E-8 /S,16H FISSION ENERGY=,E12.5,4H MEV, + 1 16H CAPTURE ENERGY=,E12.5,4H MEV) + 110 FORMAT(5X,12(A6,2H= ,I1,2X)) + 120 FORMAT(5X,14HPARENT NAMES: ,12A8/(19X,12A8)) + END diff --git a/Dragon/src/LIBEAD.f b/Dragon/src/LIBEAD.f new file mode 100644 index 0000000..c03885d --- /dev/null +++ b/Dragon/src/LIBEAD.f @@ -0,0 +1,224 @@ +*DECK LIBEAD + SUBROUTINE LIBEAD (IPLIB,MAXISO,MAXMIX,IMPX,NDEPL,NFISS,NSUPS, + 1 NREAC,NPAR,NBISO,ISONAM,ISONRF,HLIB,ILLIB,MIX,TN,IEVOL,ITYP, + 2 NCOMB) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Add the missing isotopes from the depletion chain. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* MAXISO maximum value of nbiso. +* MAXMIX maximum number of mixtures. +* IMPX print flag. Equal to zero for no print. +* NDEPL number of depleting isotopes. +* NFISS number of fissiles isotopes producing fission products. +* NSUPS number of non-depleting isotopes producing energy. +* NREAC maximum number of depletion reactions. +* NPAR maximum number of parent nuclides in the depletion chain. +* NBISO old/new number of isotopes present in the calculation +* domain. +* ISONAM alias name of isotopes. +* ISONRF library name of isotopes. +* HLIB isotope options. +* ILLIB xs library index for each isotope. +* MIX mix number of each isotope (can be zero). +* TN temperature of each isotope. +* IEVOL non-depletion mask (=1/2 to suppress/force depletion of an +* isotope). +* ITYP isotope type: +* =1: the isotope is not fissile and not a fission product; +* =2: the isotope is fissile; =3: is a fission product. +* NCOMB number of depleting mixtures. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + INTEGER MAXISO,MAXMIX,IMPX,NDEPL,NFISS,NSUPS,NREAC,NPAR, + 1 NBISO,ISONAM(3,MAXISO),ISONRF(3,MAXISO),ILLIB(MAXISO), + 2 MIX(MAXISO),IEVOL(MAXISO),ITYP(MAXISO),NCOMB + REAL TN(MAXISO) + CHARACTER(LEN=8) HLIB(MAXISO,4) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IOUT=6) + CHARACTER TEXT1*12,TEXT2*12,TEXT3*8 + INTEGER, ALLOCATABLE, DIMENSION(:) :: MILVO,IIPAR,KFISS + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IDR,KPAR,HGAR +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(MILVO(MAXMIX),IIPAR(NDEPL),IDR(NREAC,NDEPL), + 1 KPAR(NPAR,NDEPL),KFISS(NFISS),HGAR(3,NDEPL)) +*---- +* FIND THE NUMBER OF DEPLETING MIXTURES +*---- + CALL LCMGET(IPLIB,'ISOTOPESDEPL',HGAR) + IF(NDEPL.GT.MAXISO) CALL XABORT('LIBEAD: TOO MANY DEPLETING ISOT' + 1 //'OPES.') + CALL LCMGET(IPLIB,'DEPLETE-REAC',IDR) + CALL LCMGET(IPLIB,'PRODUCE-REAC',KPAR) + NCOMB=0 + DO 30 ISOT=1,NBISO + IBM=MIX(ISOT) + IF(IBM.EQ.0) GO TO 30 + IF((IEVOL(ISOT).NE.1).AND.(ITYP(ISOT).GT.1)) THEN + DO 10 J=1,NCOMB + IF(IBM.EQ.MILVO(J)) GO TO 30 + 10 CONTINUE + NCOMB=NCOMB+1 + MILVO(NCOMB)=IBM + GO TO 30 + ENDIF + IF((IEVOL(ISOT).EQ.1).OR.(ILLIB(ISOT).EQ.0)) GO TO 30 + DO 20 I=1,NDEPL-NSUPS + IF((ISONRF(1,ISOT).EQ.HGAR(1,I)).AND.(ISONRF(2,ISOT).EQ. + 1 HGAR(2,I)).AND.(ISONRF(3,ISOT).EQ.HGAR(3,I))) THEN + ITYP(ISOT)=1 + IF(IEVOL(ISOT).EQ.2) ITYP(ISOT)=3 + IF(MOD(IDR(2,I),100).EQ.3) ITYP(ISOT)=2 + IF(MOD(IDR(2,I),100).EQ.4) ITYP(ISOT)=2 + IF(MOD(IDR(2,I),100).EQ.5) ITYP(ISOT)=3 + DO 15 J=1,NCOMB + IF(IBM.EQ.MILVO(J)) GO TO 30 + 15 CONTINUE + NCOMB=NCOMB+1 + MILVO(NCOMB)=IBM + GO TO 30 + ENDIF + 20 CONTINUE + IEVOL(ISOT)=1 + 30 CONTINUE +*---- +* ADD THE MISSING ISOTOPES FROM THE DEPLETION CHAIN +*---- + KFISS(:NFISS)=0 + DO 35 INUCL=1,NDEPL-NSUPS + IF(MOD(IDR(2,INUCL),100).EQ.4) THEN + KDRI=IDR(2,INUCL)/100 + IF(KDRI.GT.NFISS) CALL XABORT('LIBEAD: INVALID NFISS.') + IF(KDRI.GT.0) KFISS(KDRI)=INUCL + ENDIF + 35 CONTINUE + NBOLD=NBISO + DO 130 ICOMB=1,NCOMB + IBM=MILVO(ICOMB) + ITER=0 + IFIRST=0 + DO 36 I=1,NBISO + IF(MIX(I).EQ.IBM) THEN + IFIRST=I + GO TO 40 + ENDIF + 36 CONTINUE + CALL XABORT('LIBEAD: UNABLE TO FIND A DEPLETING MIXTURE.') + 40 ITER=ITER+1 + IF(ITER.GT.100) CALL XABORT('LIBEAD: UNABLE TO COMPLETE THE BURN' + 1 //'UP CHAINS.') + NADD=0 + DO 120 INUCL=1,NDEPL-NSUPS + DO 50 I=1,NBISO + IF((ISONRF(1,I).EQ.HGAR(1,INUCL)).AND.(ISONRF(2,I).EQ. + 1 HGAR(2,INUCL)).AND.(ISONRF(3,I).EQ.HGAR(3,INUCL)).AND. + 2 (MIX(I).EQ.IBM)) GO TO 120 + 50 CONTINUE + WRITE(TEXT1,'(3A4)') (HGAR(I0,INUCL),I0=1,3) + I1=INDEX(TEXT1,'_') + IF(I1.EQ.0) THEN + TEXT2=TEXT1 + ELSE + TEXT2=TEXT1(:I1-1) + ENDIF + TEXT2(9:12)=' ' + DO 60 I=1,NBISO + IF(MIX(I).NE.IBM) GO TO 60 + WRITE(TEXT1,'(3A4)') (ISONRF(I0,I),I0=1,3) + I1=INDEX(TEXT1,'_') + IF(I1.EQ.0) THEN + TEXT3=TEXT1(:8) + ELSE + TEXT3=TEXT1(:I1-1) + ENDIF + IF(TEXT3.EQ.TEXT2(:8)) GO TO 120 + 60 CONTINUE + IIPAR(:NDEPL-NSUPS)=0 + IF(MOD(IDR(2,INUCL),100).EQ.5) THEN + DO 70 IFIS=1,NFISS + IF(KFISS(IFIS).GT.0) IIPAR(KFISS(IFIS))=1 + 70 CONTINUE + ENDIF + DO 80 IPAR=1,NPAR + KGAR=KPAR(IPAR,INUCL) + IF(KGAR.EQ.0) THEN + GO TO 90 + ELSE + IIPAR(KGAR/100)=1 + ENDIF + 80 CONTINUE + 90 DO 110 JNUCL=1,NDEPL-NSUPS + IF(IIPAR(JNUCL).EQ.1) THEN + NBISOL=NBISO + DO 100 I=1,NBISOL + IF((ISONRF(1,I).EQ.HGAR(1,JNUCL)).AND.(ISONRF(2,I).EQ. + 1 HGAR(2,JNUCL)).AND.(ISONRF(3,I).EQ.HGAR(3,JNUCL)).AND. + 2 (MIX(I).EQ.IBM)) THEN +* A PARENT EXISTS. ADD ONE ISOTOPE IN THE ISOTOPE LIST AND +* SET ISOTOPE PARAMETERS TO STANDARD VALUES. + NBISO=NBISO+1 + IF(NBISO.GT.MAXISO) CALL XABORT('LIBEAD: MAXISO TOO SMALL.') + NADD=NADD+1 + IF(IMPX.GT.8) WRITE(IOUT,'(25H LIBEAD: ADDING ISOTOPE '', + 1 3A4,20H'' TO CHILD ISOTOPE '',3A4,12H'' IN MIXTURE,I5)') + 2 (HGAR(I0,INUCL),I0=1,3),(HGAR(I0,JNUCL),I0=1,3),IBM +* TEXT2 IS THE NEW ALIAS NAME FOR NBISO-TH ISOTOPE. + READ(TEXT2,'(3A4)') (ISONAM(I0,NBISO),I0=1,3) + DO 95 I0=1,3 + ISONRF(I0,NBISO)=HGAR(I0,INUCL) + 95 CONTINUE + HLIB(NBISO,1)=HLIB(IFIRST,1) + ILLIB(NBISO)=ILLIB(IFIRST) + MIX(NBISO)=IBM + TN(NBISO)=TN(IFIRST) + IEVOL(NBISO)=0 + ITYP(NBISO)=1 + IF(MOD(IDR(2,INUCL),100).EQ.3) ITYP(NBISO)=2 + IF(MOD(IDR(2,INUCL),100).EQ.4) ITYP(NBISO)=2 + IF(MOD(IDR(2,INUCL),100).EQ.5) ITYP(NBISO)=3 + GO TO 120 + ENDIF + 100 CONTINUE + ENDIF + 110 CONTINUE + 120 CONTINUE + IF(NADD.GT.0) GO TO 40 + IF((IMPX.GT.0).AND.(NBISO-NBOLD.GT.0)) THEN + WRITE(IOUT,150) NBISO-NBOLD,IBM + ENDIF + NBOLD=NBISO + 130 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(HGAR,KFISS,KPAR,IDR,IIPAR,MILVO) + RETURN +* + 150 FORMAT(/8H LIBEAD:,I5,39H DEPLETING ISOTOPES HAVE BEEN ADDED IN , + 1 7HMIXTURE,I5,1H.) + END diff --git a/Dragon/src/LIBEAI.f b/Dragon/src/LIBEAI.f new file mode 100644 index 0000000..c6f755d --- /dev/null +++ b/Dragon/src/LIBEAI.f @@ -0,0 +1,124 @@ +*DECK LIBEAI + SUBROUTINE LIBEAI(CFILNA,NEL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Initialize dimensions for depletion data with APOLIB-2. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input +* CFILNA APOLIB-2 file name. +* +*Parameters: output +* NEL number of isotopes on library. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER CFILNA*(*) + INTEGER NEL +* + EXTERNAL LIBA21 + CHARACTER TYPOBJ*8,TYPSEG*8,TEXT8*8 + INTEGER ISFICH(3) +*---- +* SCRATCH STORAGE ALLOCATION +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: VINTE,ITCARO,ITSEGM + TYPE(C_PTR) ICHDIM_PTR,ICHTYP_PTR,ICHDKL_PTR + INTEGER, POINTER, DIMENSION(:) :: ICHDIM,ICHTYP,ICHDKL +* + INTEGER TKCARO(31) + SAVE TKCARO + DATA TKCARO / + & 0, 1, 2, 3, 4, 5, 6, 30, 7, -8, + & 9, -10, 11, -12, 13, -14, 15, 16, -17, 18, + & -19, 20, -21, 22, 23, -24, 25, -26, 27, -28, + & 29 / +*---- +* PROBE AND OPEN THE APOLIB-2 FILE. +*---- + CALL AEXTPA(CFILNA,ISFICH) + IADRES=ISFICH(1) + NBOBJ=ISFICH(2) + LBLOC=ISFICH(3) + IUNIT=KDROPN(CFILNA,2,4,LBLOC) + IF(IUNIT.LE.0) THEN + TEXT8=CFILNA + CALL XABORT('LIBEAI: APOLLO-2 LIBRARY '//TEXT8//' CANNOT BE'// + > ' OPENED') + ENDIF +*---- +* INDEX THE APOLIB-2 FILE. +*---- + ALLOCATE(VINTE(2*NBOBJ)) + CALL AEXDIR(IUNIT,LBLOC,VINTE,IADRES,2*NBOBJ) + IDKNO=1-TKCARO(14) + IDKTY=1-TKCARO(21) + IDKDS=1-TKCARO(10) + IDKTS=1-TKCARO(23) + IDKNS=TKCARO(2)+1 + IDKLS=TKCARO(8) +* + DO 70 I=3,NBOBJ + IDKOBJ=VINTE(2*I-1) + LGSEG=VINTE(2*I)+1 + ALLOCATE(ITCARO(LGSEG)) + CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG) + IDK=ITCARO(IDKTY) + CALL AEXCPC(IDK,8,ITCARO,TYPOBJ) + JDKDS=ITCARO(IDKDS) + JDKTS=ITCARO(IDKTS) + NS=ITCARO(IDKNS) + IF(TYPOBJ.EQ.'APOLIB') THEN + DO 60 IS=1,NS + IDK=JDKTS+8*(IS-1) + CALL AEXCPC(IDK,8,ITCARO,TYPSEG) + LNGS=ITCARO(IDKLS+IS) + IF(LNGS.LE.0) GO TO 60 + JDKS=ITCARO(JDKDS+IS) + CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, + 1 ICHDKL_PTR) + CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) + CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) + CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) + ALLOCATE(ITSEGM(LNGS+1)) + CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1) + IF(TYPSEG.EQ.'PHEAD') THEN + CALL AEXGNV(3,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + IF(NV.EQ.0) THEN + TEXT8=CFILNA + CALL XABORT('LIBEAI: NO ISOTOPES PRESENT ON APOLIB-2 '// + 1 'FILE NAMED: '//TEXT8) + ENDIF + NEL=NV/20 + ENDIF + DEALLOCATE(ITSEGM) + CALL LCMDRD(ICHDIM_PTR) + CALL LCMDRD(ICHTYP_PTR) + CALL LCMDRD(ICHDKL_PTR) + 60 CONTINUE + ENDIF + DEALLOCATE(ITCARO) + 70 CONTINUE + DEALLOCATE(VINTE) + IERR=KDRCLS(IUNIT,1) + IF(IERR.LT.0) THEN + TEXT8=CFILNA + CALL XABORT('LIBEAI: APOLLO-2 LIBRARY '//TEXT8//' CANNOT BE'// + > ' CLOSED') + ENDIF + RETURN + END diff --git a/Dragon/src/LIBEAR.f b/Dragon/src/LIBEAR.f new file mode 100644 index 0000000..8b7746c --- /dev/null +++ b/Dragon/src/LIBEAR.f @@ -0,0 +1,580 @@ +*DECK LIBEAR + SUBROUTINE LIBEAR(CFILNA,MAXR,NEL,NMDEPL,ITNAM,ITZEA,KPAX,BPAX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read depletion data on an APOLIB-2 formatted library. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input +* CFILNA APOLIB-2 file name. +* MAXR number of reaction types. +* NEL number of isotopes on library. +* NMDEPL names of reactions: +* NMDEPL(1)='DECAY'; NMDEPL(2)='NFTOT'; +* NMDEPL(3)='NG' ; NMDEPL(4)='N2N'; +* etc. +* +*Parameters: output +* ITNAM reactive isotope names in chain. +* ITZEA 6-digit nuclide identifier: +* atomic number z*10000 (digits) + mass number a*10 + +* energy state (0 = ground state, 1 = first state, etc.). +* KPAX complete reaction type matrix. +* BPAX complete branching ratio matrix. +* +*----------------------------------------------------------------------- +* +*---- +* INPUT FORMAT +*---- +* LIB: APLIB2 FIL: CFILNA CHAIN +* [[ hnamson +* [ FROM [[ { DECAY | reaction } yield hnampar ]] ] +* ]] +* ENDCHAIN +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER CFILNA*(*),NMDEPL(MAXR)*8 + INTEGER MAXR,NEL,ITNAM(3,NEL),ITZEA(NEL),KPAX(NEL+MAXR,NEL) + REAL BPAX(NEL+MAXR,NEL) +* + EXTERNAL LIBA21 + INTEGER ISFICH(3),NITCA(5) + PARAMETER (IOUT=6) + CHARACTER TEXT20*20,NOMOBJ*20,TEXT8*8,TEXT12*12,TYPOBJ*8,TYPSEG*8, + > HNISOR*20,HITNAM*20,HSMG*131,TEXT16*16 + LOGICAL LPHEAD,LPCONS,LPNUMF,LTEST,LPFIX + DOUBLE PRECISION DBLINP +*---- +* SCRATCH STORAGE ALLOCATION +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: VINTE,NOMOB,KDS,LGS,ITCARO, + 1 NOM,IA,IZ,NFG,IZSECT,ISECTT,IKEEP + REAL, ALLOCATABLE, DIMENSION(:) :: GAMMA + TYPE(C_PTR) ICHDIM_PTR,ICHTYP_PTR,ICHDKL_PTR,TSEGM_PTR + INTEGER, POINTER, DIMENSION(:) :: ICHDIM,ICHTYP,ICHDKL,ITSEGM + REAL, POINTER, DIMENSION(:) :: RTSEGM +* + INTEGER TKCARO(31) + SAVE TKCARO + DATA TKCARO / + & 0, 1, 2, 3, 4, 5, 6, 30, 7, -8, + & 9, -10, 11, -12, 13, -14, 15, 16, -17, 18, + & -19, 20, -21, 22, 23, -24, 25, -26, 27, -28, + & 29 / +*---- +* OPEN AND PROBE THE APOLIB-2 FILE. +*---- + CALL AEXTPA(CFILNA,ISFICH) + IADRES=ISFICH(1) + NBOBJ=ISFICH(2) + LBLOC=ISFICH(3) + IUNIT=KDROPN(CFILNA,2,4,LBLOC) + IF(IUNIT.LE.0) THEN + TEXT12=CFILNA + CALL XABORT('LIBEAR: APOLLO-2 LIBRARY '//TEXT12//' CANNOT B'// + 1 'E OPENED') + ENDIF +*---- +* INDEX THE APOLIB-2 FILE. +*---- + ALLOCATE(VINTE(2*NBOBJ)) + CALL AEXDIR(IUNIT,LBLOC,VINTE,IADRES,2*NBOBJ) + IDKNO=1-TKCARO(14) + IDKTY=1-TKCARO(21) + IDKDS=1-TKCARO(10) + IDKTS=1-TKCARO(23) + IDKNS=TKCARO(2)+1 + IDKLS=TKCARO(8) +* + NSEGM=0 + NMGY=0 + NISOT=0 + ALLOCATE(NOMOB(5*(NBOBJ-3)),KDS(NBOBJ-3),LGS(NBOBJ-3)) + LPHEAD=.FALSE. + LPCONS=.FALSE. + LPNUMF=.FALSE. + DO 80 IOBJ=3,NBOBJ + IDKOBJ=VINTE(2*IOBJ-1) + LGSEG=VINTE(2*IOBJ)+1 + ALLOCATE(ITCARO(LGSEG)) + CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG) + IDK=ITCARO(IDKNO) + CALL AEXCPC(IDK,20,ITCARO(1),NOMOBJ) + IDK=ITCARO(IDKTY) + CALL AEXCPC(IDK,8,ITCARO(1),TYPOBJ) + JDKDS=ITCARO(IDKDS) + JDKTS=ITCARO(IDKTS) + NS=ITCARO(IDKNS) + IF(TYPOBJ.EQ.'APOLIB') THEN + DO 70 IS=1,NS + IDK=JDKTS+8*(IS-1) + CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG) + LTESTS=ITCARO(IDKLS+IS) + IF(LTESTS.LE.0) GO TO 70 + JDKS=ITCARO(JDKDS+IS) + CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, + 1 ICHDKL_PTR) + CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) + CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) + CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) + TSEGM_PTR=LCMARA(LTESTS+1) + CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LTESTS+1 /)) + CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LTESTS+1 /)) + CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LTESTS+1) + IF(TYPSEG.EQ.'PHEAD') THEN + LPHEAD=.TRUE. + CALL AEXGNV(3,ITSEGM,ICHDIM,ICHTYP, + 1 ICHDKL,IDK,NV) + IF(NV.EQ.0) THEN + TEXT12=CFILNA + CALL XABORT('LIBEAR: NO ISOTOPES PRESENT ON APOLIB-2 '// + 1 'FILE NAMED: '//TEXT12) + ENDIF + NISOT=NV/20 + IF(NISOT.NE.NEL) CALL XABORT('LIBEAR: INVALID NEL.') + ALLOCATE(NOM(5*NISOT)) + DO 20 ISO=1,NISOT + ISO2=(ISO-1)*5+1 + CALL AEXCPC(0,20,ITSEGM(IDK+ISO2-1),HNISOR) + CALL LCMCAR(HNISOR,.TRUE.,NOM(ISO2)) + READ(HNISOR,'(3A4)') (ITNAM(II,ISO),II=1,3) + 20 CONTINUE + ELSE IF(TYPSEG.EQ.'PCONST') THEN + LPCONS=.TRUE. + CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + ALLOCATE(IA(NV)) + DO 30 I=1,NV + IA(I)=ITSEGM(IDK+I-1) + 30 CONTINUE + CALL AEXGNV(3,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + ALLOCATE(IZ(NV)) + DO 40 I=1,NV + IZ(I)=ITSEGM(IDK+I-1) + 40 CONTINUE + CALL AEXGNV(5,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + ALLOCATE(NFG(NV)) + DO 50 I=1,NV + NFG(I)=ITSEGM(IDK+I-1) + 50 CONTINUE + ELSE IF(TYPSEG.EQ.'PNUMF') THEN + LPNUMF=.TRUE. + CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NBFISS) + NBFISS=NBFISS/7 + CALL AEXGNV(4,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NBPF) + NBPF=NBPF/7 + CALL AEXGNV(7,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + ALLOCATE(GAMMA(NV)) + DO 60 I=1,NV + GAMMA(I)=RTSEGM(IDK+I-1) + 60 CONTINUE + NMGY=NV/(NBFISS*NBPF) + ENDIF + CALL LCMDRD(TSEGM_PTR) + CALL LCMDRD(ICHDIM_PTR) + CALL LCMDRD(ICHTYP_PTR) + CALL LCMDRD(ICHDKL_PTR) + 70 CONTINUE + ELSE IF(TYPOBJ.EQ.'APOLIBE') THEN + NSEGM=NSEGM+1 + ISO2=(NSEGM-1)*5+1 + CALL LCMCAR(NOMOBJ,.TRUE.,NOMOB(ISO2)) + KDS(NSEGM)=IDKOBJ + LGS(NSEGM)=LGSEG + ELSE + CALL XABORT('LIBEAR: WEIRD SEGMENT TYPE: '//TYPOBJ//' (1).') + ENDIF + DEALLOCATE(ITCARO) + 80 CONTINUE + IF(.NOT.LPHEAD) CALL XABORT('LIBEAR: PHEAD SEGMENT NOT FOUND.') + IF(.NOT.LPCONS) CALL XABORT('LIBEAR: PCONST SEGMENT NOT FOUND.') + IF(.NOT.LPNUMF) CALL XABORT('LIBEAR: PNUMF SEGMENT NOT FOUND.') + DEALLOCATE(VINTE) +*---- +* SET THE CORRESPONDANCE BETWEEN THE APOLIB AND THE LIST OF ISOTOPES. +*---- + KISEG2=0 + DO 260 ISO=1,NISOT + ISO2=(ISO-1)*5+1 + CALL LCMCAR(TEXT16,.FALSE.,NOM(ISO2)) + TEXT20='ISOTOP'//TEXT16(:14) + CALL LCMCAR(TEXT20,.TRUE.,NITCA(1)) + DO 90 ISEG=1,NSEGM + ISEG2=(ISEG-1)*5+1 + IF(NITCA(1).EQ.NOMOB(ISEG2)) THEN + IF(NITCA(2).EQ.NOMOB(ISEG2+1)) THEN + IF(NITCA(3).EQ.NOMOB(ISEG2+2)) THEN + IF(NITCA(4).EQ.NOMOB(ISEG2+3)) THEN + IF(NITCA(5).EQ.NOMOB(ISEG2+4)) THEN + KISEG2=ISEG + GO TO 100 + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + 90 CONTINUE + WRITE (HSMG,500) HNISOR,CFILNA + CALL XABORT(HSMG) + 100 KISEG3=0 + TEXT20='PHYSIQ'//TEXT16(:14) + CALL LCMCAR(TEXT20,.TRUE.,NITCA(1)) + DO 110 ISEG=1,NSEGM + ISEG2=(ISEG-1)*5+1 + IF(NITCA(1).EQ.NOMOB(ISEG2)) THEN + IF(NITCA(2).EQ.NOMOB(ISEG2+1)) THEN + IF(NITCA(3).EQ.NOMOB(ISEG2+2)) THEN + IF(NITCA(4).EQ.NOMOB(ISEG2+3)) THEN + IF(NITCA(5).EQ.NOMOB(ISEG2+4)) THEN + KISEG3=ISEG + GO TO 120 + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + 110 CONTINUE +*---- +* ACTIVATION OF CORRESPONDING 'ISOTOP'//NAME SEGMENT. +*---- + 120 IDKOBJ=KDS(KISEG2) + LGSEG=LGS(KISEG2) + ALLOCATE(ITCARO(LGSEG)) + CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG) + IDK=ITCARO(IDKNO) + CALL AEXCPC(IDK,20,ITCARO(1),NOMOBJ) + IDK=ITCARO(IDKTY) + CALL AEXCPC(IDK,8,ITCARO(1),TYPOBJ) + JDKDS=ITCARO(IDKDS) + JDKTS=ITCARO(IDKTS) + NS=ITCARO(IDKNS) + NSETOT=0 + NPHY=0 +*---- +* RECOVER THE INFINITE DILUTION CROSS SECTION NUMEROTATION. +*---- + LPFIX=.FALSE. + DO 160 IS=1,NS + IDK=JDKTS+8*(IS-1) + CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG) + LTESTS=ITCARO(IDKLS+IS) + IF(LTESTS.LE.0) GO TO 160 + JDKS=ITCARO(JDKDS+IS) + CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR,ICHDKL_PTR) + CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) + CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) + CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) + TSEGM_PTR=LCMARA(LTESTS+1) + CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LTESTS+1 /)) + CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LTESTS+1 /)) + CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LTESTS+1) + IF(TYPSEG.EQ.'PFIX') THEN + LPFIX=.TRUE. +* NG ENERGY. + CALL AEXGNV(11,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + IF(NV.NE.0) THEN + IF(RTSEGM(IDK).NE.0.0) THEN + KPAX(NEL+3,ISO)=1 + BPAX(NEL+3,ISO)=RTSEGM(IDK) + ENDIF + ENDIF +* AVAILABLE CROSS SECTION TYPES. + CALL AEXGNV(12,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NSECTT) + ALLOCATE(IZSECT(NSECTT)) + NSETOT=0 + NPHY=MAX(0,NSECTT-5) + DO 130 I=1,NSECTT + IZSECT(I)=ITSEGM(IDK+I-1) + IF((IZSECT(I).NE.0).AND.(I.LE.5)) NSETOT=NSETOT+1 + 130 CONTINUE +* FISSION ENERGIES. + CALL AEXGNV(20,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NMGEF) + IF(NMGEF.NE.0) THEN + IF(RTSEGM(IDK+NMGEF-1).NE.0.0) THEN + KPAX(NEL+2,ISO)=1 + BPAX(NEL+2,ISO)=RTSEGM(IDK+NMGEF-1) + ENDIF + ENDIF +* RADIOACTIVE DECAY CONSTANTS. + CALL AEXGNV(22,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NCHANN) + SUM=0.0 + DO 140 I=1,NCHANN + SUM=SUM+RTSEGM(IDK+I-1) + 140 CONTINUE + IF(SUM.NE.0.0) BPAX(NEL+1,ISO)=SUM*1.0E8 +* X-S NAMES. + CALL AEXGNV(26,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + IF(NV/8.NE.NSECTT) CALL XABORT('LIBEAR: INVALID TYPSECT.') + ALLOCATE(ISECTT(2*NSECTT)) + III=0 + DO 150 I=1,NSECTT + I2=(I-1)*2+1 + IF(IZSECT(I).NE.0) THEN + III=III+1 + I3=(III-1)*2+1 + CALL AEXCPC(0,8,ITSEGM(IDK+I2-1),TEXT8) + CALL LCMCAR(TEXT8,.TRUE.,ISECTT(I3)) + ENDIF + 150 CONTINUE + ENDIF + CALL LCMDRD(TSEGM_PTR) + CALL LCMDRD(ICHDIM_PTR) + CALL LCMDRD(ICHTYP_PTR) + CALL LCMDRD(ICHDKL_PTR) + 160 CONTINUE + IF(.NOT.LPFIX) CALL XABORT('LIBEAR: NO PFIX SEGMENT.') +*---- +* TEST THE INFINITE DILUTION CROSS SECTIONS. +*---- + ITSEC=0 + DO 210 IS=1,NS + LTESTS=ITCARO(IDKLS+IS) + IF(LTESTS.LE.0) GO TO 210 + IDK=JDKTS+8*(IS-1) + CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG) + JDKS=ITCARO(JDKDS+IS) + CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR,ICHDKL_PTR) + CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) + CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) + CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) + TSEGM_PTR=LCMARA(LTESTS+1) + CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LTESTS+1 /)) + CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LTESTS+1 /)) + CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LTESTS+1) + IF(TYPSEG.EQ.'PSECT') THEN +* RECOVER A VECTOR CROSS SECTION. + ITSEC=ITSEC+1 + IF(ITSEC.GT.NSETOT) GO TO 200 + CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP, + 1 ICHDKL,IDK,NV) + I3=(ITSEC-1)*2+1 + CALL LCMCAR(TEXT8,.FALSE.,ISECTT(I3)) + IF(TEXT8.EQ.'SIGA') THEN + LTEST=.FALSE. + DO 170 IG=1,NV + LTEST=LTEST.OR.(RTSEGM(IDK+IG-1).NE.0.0) + 170 CONTINUE + IF(LTEST) KPAX(NEL+3,ISO)=1 + ELSE IF(TEXT8.EQ.'NEXCESS') THEN + LTEST=.FALSE. + DO 180 IG=1,NV + LTEST=LTEST.OR.(RTSEGM(IDK+IG-1).NE.0.0) + 180 CONTINUE + IF(LTEST) KPAX(NEL+4,ISO)=1 + ELSE IF(TEXT8.EQ.'SIGF') THEN + LTEST=.FALSE. + DO 190 IG=1,NV + LTEST=LTEST.OR.(RTSEGM(IDK+IG-1).NE.0.0) + 190 CONTINUE + IF(LTEST) KPAX(NEL+2,ISO)=1 + ENDIF + ENDIF + 200 CALL LCMDRD(TSEGM_PTR) + CALL LCMDRD(ICHDIM_PTR) + CALL LCMDRD(ICHTYP_PTR) + CALL LCMDRD(ICHDKL_PTR) + 210 CONTINUE +*---- +* TEST THE PRODUCTION REACTIONS. +*---- + IF(NPHY.GE.1) THEN + IF(KISEG3.EQ.0) CALL XABORT('LIBEAR: INVALID PRODUCTION X-S (' + 1 //'1).') + IDKOBJ=KDS(KISEG3) + LGSEG=LGS(KISEG3) + CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG) + LDKDS=ITCARO(IDKDS) + LDKTS=ITCARO(IDKTS) + NS=ITCARO(IDKNS) + IF(NS.NE.NPHY) CALL XABORT('LIBEAR: INVALID PRODUCTION X-S(2)' + 1 //'.') + DO 240 IPHY=1,NPHY + IDK=LDKTS+8*(IPHY-1) + CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG) + IF(TYPSEG.NE.'PSECT') CALL XABORT('LIBEAR: INVALID PRODUCTION' + 1 //' X-S(3).') + LNGS=ITCARO(IDKLS+IPHY) + IF(LNGS.LE.0) CALL XABORT('LIBEAR: INVALID PRODUCTION X-S(4).') + LDKS=ITCARO(LDKDS+IPHY) + CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, + 1 ICHDKL_PTR) + CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) + CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) + CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) + TSEGM_PTR=LCMARA(LNGS+1) + CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) + CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /)) + CALL AEXDIR(IUNIT,LBLOC,ITSEGM,LDKS,LNGS+1) + CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + CALL LCMDRD(ICHDIM_PTR) + CALL LCMDRD(ICHTYP_PTR) + CALL LCMDRD(ICHDKL_PTR) + I3=(NSETOT+IPHY-1)*2+1 + CALL LCMCAR(TEXT8,.FALSE.,ISECTT(I3)) + IF(TEXT8.EQ.'CREA-P') THEN + LTEST=.FALSE. + DO 220 IG=1,NV + LTEST=LTEST.OR.(RTSEGM(IDK+IG-1).NE.0.0) + 220 CONTINUE + IF(LTEST) KPAX(NEL+8,ISO)=1 + ELSE IF(TEXT8.EQ.'CREA-H2') THEN + LTEST=.FALSE. + DO 225 IG=1,NV + LTEST=LTEST.OR.(RTSEGM(IDK+IG-1).NE.0.0) + 225 CONTINUE + IF(LTEST) KPAX(NEL+11,ISO)=1 + ELSE IF(TEXT8.EQ.'CREA-H3') THEN + LTEST=.FALSE. + DO 230 IG=1,NV + LTEST=LTEST.OR.(RTSEGM(IDK+IG-1).NE.0.0) + 230 CONTINUE + IF(LTEST) KPAX(NEL+12,ISO)=1 + ENDIF + CALL LCMDRD(TSEGM_PTR) + 240 CONTINUE + ENDIF + DEALLOCATE(ITCARO) +*---- +* SET OTHER INFORMATION. +*---- + ITZEA(ISO)=IZ(ISO)*10000+IA(ISO)*10 + IPF=NFG(ISO) + IF(IPF.LT.0) THEN + KPAX(NEL+2,ISO)=-1 + DO 250 JSO=1,NISOT + IFI=NFG(JSO) + IF(IFI.GT.0) THEN + IOFSET=((-IPF-1)*NBFISS+(IFI-1))*NMGY+NMGY + BPAX(ISO,JSO)=GAMMA(IOFSET) + IF(BPAX(ISO,JSO).NE.0.0) KPAX(ISO,JSO)=2 + ENDIF + 250 CONTINUE + ENDIF + DEALLOCATE(ISECTT,IZSECT) + 260 CONTINUE +* + DEALLOCATE(LGS,KDS,NOMOB,GAMMA,NFG,IZ,IA,NOM) + IERR=KDRCLS(IUNIT,1) + IF(IERR.LT.0) THEN + TEXT12=CFILNA + CALL XABORT('LIBEAR: APOLLO-2 LIBRARY '//TEXT12//' CANNOT B'// + 1 'E CLOSED') + ENDIF +*---- +* RECOVER INFORMATION FROM INPUT DATA STREAM. +*---- + ALLOCATE(IKEEP(NEL)) + IKEEP(:NEL)=0 + TEXT12=' ' + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + IF(INDIC.NE.3.OR.TEXT12.NE.'CHAIN') + > CALL XABORT('LIBEAR: KEYWORD CHAIN MISSING') + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + DO 340 IEL=1,NEL + IF(TEXT12.EQ.'ENDCHAIN') GO TO 350 + IF(INDIC.NE.3) CALL XABORT('LIBEAR: ISOTOPE NAME hnamson MISSING') + I1=INDEX(TEXT12,'_') + HNISOR=' ' + IF(I1.EQ.0) THEN + HNISOR(:12)=TEXT12 + ELSE + HNISOR(:I1-1)=TEXT12(:I1-1) + ENDIF + IDEPL=0 + DO 270 JEL=1,NEL + WRITE(TEXT12,'(3A4)') (ITNAM(II,JEL),II=1,3) + I1=INDEX(TEXT12,'_') + HITNAM=' ' + IF(I1.EQ.0) THEN + HITNAM(:12)=TEXT12 + ELSE + HITNAM(:I1-1)=TEXT12(:I1-1) + ENDIF + IF(HNISOR.EQ.HITNAM) THEN + IDEPL=JEL + GO TO 280 + ENDIF + 270 CONTINUE + WRITE(HSMG,'(25HLIBEAR: MISSING ISOTOPE '',A12,5H''(1).)') + > HNISOR + CALL XABORT(HSMG) + 280 IKEEP(IDEPL)=1 + IF(BPAX(NEL+1,IDEPL).NE.0.0) KPAX(NEL+1,IDEPL)=1 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + IF(INDIC.NE.3) CALL XABORT('LIBEAR: REACTION TYPE EXPECTED') + IF(TEXT12.EQ.'FROM') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + 290 IF(INDIC.NE.3) CALL XABORT('LIBEAR: REACTION TYPE EXPECTED') + DO 330 IREAC=1,MAXR + RRAT=1.0 + IF(TEXT12.EQ.NMDEPL(IREAC)) THEN + DO 320 JEL=1,NEL + CALL REDGET(INDIC,ISOT,RRAT,TEXT12,DBLINP) + IF(INDIC.NE.2) GO TO 290 + CALL REDGET(INDIC,ISOT,FLOTT,TEXT12,DBLINP) + IF(INDIC.NE.3) CALL XABORT('LIBEAR: ISOTOPE NAME HNAMPAR ' + > //'MISSING') + I1=INDEX(TEXT12,'_') + TEXT20=' ' + IF(I1.EQ.0) THEN + TEXT20(:12)=TEXT12 + ELSE + TEXT20(:I1-1)=TEXT12(:I1-1) + ENDIF + JDEPL=0 + DO 300 JREL=1,NEL + WRITE(TEXT12,'(3A4)') (ITNAM(II,JREL),II=1,3) + I1=INDEX(TEXT12,'_') + HITNAM=' ' + IF(I1.EQ.0) THEN + HITNAM(:12)=TEXT12 + ELSE + HITNAM(:I1-1)=TEXT12(:I1-1) + ENDIF + IF(TEXT20.EQ.HITNAM) THEN + JDEPL=JREL + GO TO 310 + ENDIF + 300 CONTINUE + WRITE(HSMG,'(25HLIBEAR: MISSING ISOTOPE '',A12,5H''(2).)') + > TEXT20 + CALL XABORT(HSMG) + 310 KPAX(IDEPL,JDEPL)=IREAC + BPAX(IDEPL,JDEPL)=RRAT + 320 CONTINUE + CALL XABORT('LIBEAR: TO MANY PARENT ISOTOPES') + ENDIF + 330 CONTINUE + ENDIF + 340 CONTINUE + IF(INDIC.NE.3.OR.TEXT12.NE.'ENDCHAIN') + > CALL XABORT('LIBEAR: KEYWORD ENDCHAIN MISSING') + 350 DO 380 JEL=1,NEL + IF(IKEEP(JEL).EQ.0) THEN + DO 360 IREAC=1,NEL+MAXR + KPAX(IREAC,JEL)=0 + 360 CONTINUE + DO 370 IEL=1,NEL + KPAX(JEL,IEL)=0 + 370 CONTINUE + ENDIF + 380 CONTINUE + DEALLOCATE(IKEEP) + RETURN +* + 500 FORMAT(26HLIBEAR: MATERIAL/ISOTOPE ',A20,20H' IS MISSING ON APOL, + > 15HIB-2 FILE NAME ,A12,1H.) + END diff --git a/Dragon/src/LIBECT.f b/Dragon/src/LIBECT.f new file mode 100644 index 0000000..327fc62 --- /dev/null +++ b/Dragon/src/LIBECT.f @@ -0,0 +1,114 @@ +*DECK LIBECT + SUBROUTINE LIBECT(MAXTRA,LLL,PRI,UUU,DELI,DELTA,NEXT,III,MML,STIS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Build the elastic scattering law for neutrons with secondary energy +* in group LLL. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXTRA dimension of array PRI. +* LLL secondary energy group index. +* PRI info to rebuild the scat matrix. +* UUU lethargy limits of the fine groups. +* DELI elementary lethargy width. +* DELTA lethargy width of each energy group. +* NEXT length of x-s structure for the current isotope. +* III offset in PRI array for the current isotope. +* +*Parameters: output +* MML number of down-scattering groups (including group LLL). +* STIS values of the transfer macroscopic cross section: +* STIS(1): from group LLL; +* STIS(2): from group LLL-1; +* STIS(LLL): from group 1. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER LLL,NEXT,III,MML + REAL PRI(MAXTRA),UUU(LLL),DELI,DELTA(LLL),STIS(LLL) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION DAUX +* + STIS(:LLL)=0.0 + MML=1 + MM=0 + LDELH=INT(UUU(LLL)/DELI+0.1) + LARGRL=INT(DELTA(LLL)/DELI+0.1) + LDELB=LDELH-LARGRL+1 + IHM=III+NEXT-1 + LTES=LDELB-NEXT + INDICE=1 + INTER2=0 + J=0 + DO 70 MM1=1,LLL + MM=LLL-MM1+1 + MDELH=INT(UUU(MM)/DELI+0.1) + IF(MDELH.LE.LTES) THEN + MM=MM+1 + GO TO 80 + ENDIF + LARGRM=INT(DELTA(MM)/DELI+0.1) + MDELB=MAX(MDELH-LARGRM+1,LTES+1) + DAUX=0.0D0 + LARG=MIN(LARGRM,LARGRL) + IF(LARG.LE.4) THEN + DO 20 MDEL=MDELB,MDELH + IBAS=MAX(LDELB-MDEL+III,III) + IHAUT=MIN(LDELH-MDEL+III,IHM) + DO 10 I=IBAS,IHAUT + DAUX=DAUX+PRI(I) + 10 CONTINUE + 20 CONTINUE + GO TO 60 + ENDIF + IHAUT=MIN(LDELH-MDELB+III,IHM) + IF(INDICE.EQ.1) THEN + INDICE=2 + INTER2=III-1 + J=LARG+1 + ELSE IF(INDICE.EQ.2) THEN + J=0 + IBAS=MAX(LDELB-MDELH+III,III) + LARGLI=ABS(LARGRM-LARGRL) + INTER1=MIN(IBAS+LARG-2,IHAUT) + DO 30 I=IBAS,INTER1 + J=J+1 + DAUX=DAUX+PRI(I)*REAL(J) + 30 CONTINUE + INTER1=INTER1+1 + INTER2=MIN(IHAUT,INTER1+LARGLI) + IF(INTER1.GT.INTER2) GO TO 60 + J=LARG + DO 40 I=INTER1,INTER2 + DAUX=DAUX+PRI(I)*REAL(LARG) + 40 CONTINUE + ENDIF + INTER2=INTER2+1 + IF(INTER2.GT.IHAUT) GO TO 60 + DO 50 I=INTER2,IHAUT + J=J-1 + DAUX=DAUX+PRI(I)*REAL(J) + 50 CONTINUE +* + 60 STIS(MM1)=REAL(DAUX) + STIS(MM1)=STIS(MM1)*DELI/DELTA(MM) + 70 CONTINUE + 80 MML=LLL-MM+1 + RETURN + END diff --git a/Dragon/src/LIBEED.f90 b/Dragon/src/LIBEED.f90 new file mode 100644 index 0000000..5fb8aea --- /dev/null +++ b/Dragon/src/LIBEED.f90 @@ -0,0 +1,166 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Read bcd-formatted MATXS format records. +! LIBEED: transfer data from CCCC file to array. +! LIBCLS: close file and release unit number. +! +!Copyright: +! Copyright (C) 2021 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): A. Hebert +! +!Parameters: input +! iucccc file unit +! numrec record number to read +! nwds number of words to read +! +!Parameters: output +! ra location in central memory where information is to be stored +! +!----------------------------------------------------------------------- +! +module LIBEEDR + use, intrinsic :: iso_c_binding + private + integer, parameter :: nbunit=99,ntoc=50000 + integer, save :: ipunit,nbrec,npart,ntype,nmat,nsub + integer, save :: iucccc_old=0 + integer, save, dimension(ntoc) :: atoc(1:ntoc)=0 + double precision, allocatable, save, dimension(:) :: hmatn + integer, allocatable, save, dimension(:) :: nsubm + character(len=3), save, dimension(ntoc) :: btoc + public :: LIBEED, LIBCLS +contains + subroutine LIBEED(iucccc,numrec,ra,nwds) + integer, intent(in) :: iucccc,numrec,nwds + real, intent(out), target :: ra(nwds) + character(len=72) :: text72 + character(len=131) :: hsmg + ! + type(c_ptr) ra_ptr + integer, pointer :: ia(:) + double precision, pointer :: da(:) + ! + if (numrec.eq.0) then + call XABORT('LIBEED: record number 0 cannot be read '// & + 'from cccc file') + endif + ! + if (iucccc.ne.iucccc_old) iucccc_old=0 + if (iucccc_old.eq.0) then + iucccc_old=iucccc + ipunit=0 + npart=0 + ntype=0 + nmat=0 + rewind iucccc + i=0 + nbrec=0 + do + i=i+1 + read(iucccc,'(A72)',end=10) text72 + if((text72(3:3).eq.'d').or.(text72(3:3).eq.'v')) then + nbrec=nbrec+1 + if(nbrec.gt.ntoc) call XABORT('LIBEED: ntoc overflow.') + atoc(nbrec)=i + btoc(nbrec)=text72(1:3) + endif + enddo + 10 rewind iucccc + endif + ! + if (nwds.eq.0) return + if (numrec.eq.1) then + rewind iucccc + else if(numrec.gt.nbrec) then + call XABORT('LIBEED: nbrec overflow.') + else + nskip=atoc(numrec)-ipunit-1 + if (nskip.gt.0) then + do i=1,nskip + read(iucccc,'(a72)') text72 + enddo + else if (nskip.lt.0) then + do i=1,-nskip + backspace iucccc + enddo + endif + endif + ra_ptr=c_loc(ra) + call c_f_pointer(ra_ptr,ia,(/ nwds /)) + call c_f_pointer(ra_ptr,da,(/ nwds /)) + ipunit=atoc(numrec) + if(btoc(numrec).eq.' 0v') then + read(iucccc,'(4x,a8,1x,2a8,1x,i6)') (da(jj),jj=1,3),ia(7) + else if(btoc(numrec).eq.' 1d') then + read(iucccc,'(6x,6i6)') (ia(jj),jj=1,nwds) + npart=ia(1) + ntype=ia(2) + nmat=ia(4) + allocate(hmatn(nmat),nsubm(nmat)) + else if(btoc(numrec).eq.' 2d') then + read(iucccc,'(4x/(9a8))') (da(jj),jj=1,nwds/2) + ipunit=ipunit+1+(nwds/2-1)/9 + else if(btoc(numrec).eq.' 3d') then + ndr=npart+ntype+nmat + nir=npart+2*ntype+2*nmat + if(2*ndr+nir.ne.nwds) call XABORT('LIBEED: invalid nwds(1).') + read(iucccc,'(8x,8a8:/(9a8))') (da(jj),jj=1,ndr) + ipunit=ipunit+ndr/9 + read(iucccc,'(12i6)') (ia(2*ndr+i),i=1,nir) + ipunit=ipunit+1+(nir-1)/12 + if(.not.allocated(hmatn)) call XABORT('LIBEED: hmatn not allocated.') + hmatn(:nmat)=da(npart+ntype+1:ndr) + nsubm(:nmat)=ia(2*ndr+npart+2*ntype+1:2*ndr+npart+2*ntype+nmat) + else if(btoc(numrec).eq.' 6d') then + ndr=nwds/4 + read(iucccc,'(8x,8a8:/(9a8))') (da(jj),jj=1,ndr) + ipunit=ipunit+ndr/9 + read(iucccc,'(12i6)') (ia(2*ndr+i),i=1,2*ndr) + ipunit=ipunit+1+(2*ndr-1)/12 + else if((btoc(numrec).eq.' 4d').or.(btoc(numrec).eq.' 7d').or. & + (btoc(numrec).eq.' 9d').or.(btoc(numrec).eq.'10d')) then + read(iucccc,'(12x,5e12.0:/(6e12.0))') (ra(jj),jj=1,nwds) + ipunit=ipunit+nwds/6 + else if(btoc(numrec).eq.' 5d') then + read(iucccc,'(4x,a8,e12.0)') da(1),ra(3) + nsub=0 + do i=1,nmat + if(hmatn(i).eq.da(1)) then + nsub=nsubm(i) + go to 20 + endif + enddo + write(hsmg,'(49HLIBEED: unable to find material control data for , & + & a,1h.)') da(1) + call XABORT(HSMG) + 20 do i=1,nsub + ll=4+6*(i-1) + read(iucccc,'(2e12.0,4i6)') ra(ll),ra(ll+1),ia(ll+2),ia(ll+3), & + ia(ll+4),ia(ll+5) + ipunit=ipunit+1 + enddo + if(3+6*nsub.ne.nwds) call XABORT('LIBEED: invalid nwds(2).') + else if(btoc(numrec).eq.' 8d') then + read(iucccc,'(8x,a8/(12i6))') da(1),(ia(jj),jj=3,nwds) + ipunit=ipunit+1+(nwds-3)/12 + else + call XABORT('LIBEED: invalid record type.') + endif + end subroutine LIBEED + ! + subroutine LIBCLS() + if(allocated(hmatn)) deallocate(nsubm,hmatn) + ipunit=0 + npart=0 + ntype=0 + nmat=0 + iucccc_old=0 + end subroutine LIBCLS +end module LIBEEDR diff --git a/Dragon/src/LIBEIR.f b/Dragon/src/LIBEIR.f new file mode 100644 index 0000000..96951cf --- /dev/null +++ b/Dragon/src/LIBEIR.f @@ -0,0 +1,224 @@ +*DECK LIBEIR + SUBROUTINE LIBEIR(MAXR,NEL,NMDEPL,ITNAM,ITZEA,KPAX,BPAX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read depletion data on input file. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert and G. Marleau. +* +*Parameters: input +* MAXR number of reaction types. +* NEL number of isotopes on library. +* NMDEPL names of reactions: +* NMDEPL(1)='DECAY'; NMDEPL(2)='NFTOT'; +* NMDEPL(3)='NG' ; NMDEPL(4)='N2N'; +* etc. +* +*Parameters: output +* ITNAM reactive isotope names in chain. +* ITZEA 6-digit nuclide identifier: +* atomic number z*10000 (digits) + mass number a*10 + +* energy state (0 = ground state, 1 = first state, etc.). +* KPAX complete reaction type matrix. +* BPAX complete branching ratio matrix. +* +*Comments: +* INPUT FORMAT +* CHAIN +* [[ hnamson [ izea ] +* [ [[ { DECAY constant | +* reaction [energy] } ]] ] +* [ { STABLE | +* FROM [[ { DECAY | reaction } +* [[ yield hnampar ]] ]] } ] +* ]] +* ENDCHAIN +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXR,NEL,ITNAM(3,NEL),ITZEA(NEL),KPAX(NEL+MAXR,NEL) + CHARACTER NMDEPL(MAXR)*8 + REAL BPAX(NEL+MAXR,NEL) +*---- +* INPUT FILE PARAMETERS +*---- + CHARACTER TEXT12*12 + INTEGER KNADPL(3) + DOUBLE PRECISION DBLINP +*---- +* INTERNAL PARAMETERS +* KFISSP : DRAGON FISSION PRODUCT FLAG = 2 +* POSITION OF NFTOT IN NMDEPL +*---- + INTEGER KFISSP + PARAMETER (KFISSP=2) + INTEGER INDIC,NITMA,NDEPL,IEL,JEL,IDEPL,INTG,IREAC,ISOT,JREL,JDEPL + REAL FLOTT,RRAT +*---- +* READ LIST OF ISOTOPES AND PROPERTIES +*---- + TEXT12=' ' + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + IF(INDIC.NE.3.OR.TEXT12.NE.'CHAIN') + > CALL XABORT('LIBEIR: KEYWORD CHAIN MISSING') + NDEPL=0 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + DO 100 IEL=1,NEL +*---- +* EXIT IF ENDCHAIN READ +*---- + IF(TEXT12.EQ.'ENDCHAIN') GO TO 105 +*---- +* ISOTOPE NAME READ +* IF NAME ALREADY EXISTS SELECT ISOTOPE NUMBER +* IF NAME NOT DEFINED ADD TO ISOTOPE LIST +*---- + IF(INDIC.NE.3) + > CALL XABORT('LIBEIR: ISOTOPE NAME HNAMSON MISSING') + READ(TEXT12,'(3A4)') KNADPL(1),KNADPL(2),KNADPL(3) + DO 110 JEL=1,NDEPL + IF(KNADPL(1).EQ.ITNAM(1,JEL).AND. + > KNADPL(2).EQ.ITNAM(2,JEL).AND. + > KNADPL(3).EQ.ITNAM(3,JEL) ) THEN + IDEPL=JEL + GO TO 115 + ENDIF + 110 CONTINUE + NDEPL=NDEPL+1 + IF(NDEPL.GT.NEL) + > CALL XABORT('LIBEIR: TO MANY ISOTOPES') + IDEPL=NDEPL + ITNAM(1,IDEPL)=KNADPL(1) + ITNAM(2,IDEPL)=KNADPL(2) + ITNAM(3,IDEPL)=KNADPL(3) + 115 CONTINUE +*---- +* READ IZEA +*---- + CALL REDGET(INDIC,INTG,FLOTT,TEXT12,DBLINP) + IF(INDIC.EQ.1) THEN + ITZEA(IDEPL)=INTG + CALL REDGET(INDIC,INTG,FLOTT,TEXT12,DBLINP) + ELSE + ITZEA(IDEPL)=0 + ENDIF +*---- +* LOOP OVER ALL PARAMETERS ASSOCIATED WITH SON ISOTOPES +*---- + 120 CONTINUE + IF(INDIC.NE.3) CALL XABORT('LIBEIR: REACTION TYPE EXPECTED FOR' + > //' ISOTOPE '//TEXT12) +*---- +* IF KEYWORD IS 'FROM' READ LIST OF PARENT NUCLIDES +*---- + IF(TEXT12.EQ.'FROM') THEN +*---- +* LOOP OVER ALL PARAMETERS ASSOCIATED WITH PARENT ISOTOPES +*---- + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + 130 CONTINUE + IF(INDIC.NE.3) + > CALL XABORT('LIBEIR: REACTION TYPE EXPECTED.') + DO 140 IREAC=1,MAXR + RRAT=1.0 +*---- +* TEST IF KEYWORD IS A REACTION +*---- + IF(TEXT12.EQ.NMDEPL(IREAC)) THEN +*---- +* READ LIST OF YIELD AND PARENT ISOTOPES +*---- + DO 150 JEL=1,NEL +*---- +* IF YIELD ABSENT GO TO TEST FOR NEW REACTION TYPE +*---- + CALL REDGET(INDIC,ISOT,RRAT,TEXT12,DBLINP) + IF(INDIC.NE.2) GO TO 130 + CALL REDGET(INDIC,ISOT,FLOTT,TEXT12,DBLINP) + IF(INDIC.NE.3) + > CALL XABORT('LIBEIR: ISOTOPE NAME hnampar MISSING') +*---- +* ISOTOPE NAME READ +* IF NAME ALREADY EXISTS SELECT ISOTOPE NUMBER +* IF NAME NOT DEFINED ADD TO ISOTOPE LIST +*---- + READ(TEXT12,'(3A4)') KNADPL(1),KNADPL(2),KNADPL(3) + DO 160 JREL=1,NDEPL + IF(KNADPL(1).EQ.ITNAM(1,JREL).AND. + > KNADPL(2).EQ.ITNAM(2,JREL).AND. + > KNADPL(3).EQ.ITNAM(3,JREL) ) THEN + JDEPL=JREL + GO TO 165 + ENDIF + 160 CONTINUE + NDEPL=NDEPL+1 + IF(NDEPL.GT.NEL) CALL XABORT('LIBEIR: TO MANY ISOTOPES') + JDEPL=NDEPL + ITNAM(1,JDEPL)=KNADPL(1) + ITNAM(2,JDEPL)=KNADPL(2) + ITNAM(3,JDEPL)=KNADPL(3) + 165 CONTINUE + KPAX(IDEPL,JDEPL)=IREAC + BPAX(IDEPL,JDEPL)=RRAT + 150 CONTINUE + CALL XABORT('LIBEIR: TO MANY PARENT ISOTOPES') + ENDIF + 140 CONTINUE + ELSE IF(TEXT12.EQ.'STABLE') THEN + DO 141 IREAC=1,MAXR + IF(KPAX(NEL+IREAC,IDEPL).NE.0) KPAX(NEL+IREAC,IDEPL)=-9999 + 141 CONTINUE + CALL REDGET(INDIC,INTG,FLOTT,TEXT12,DBLINP) +*---- +* READ NEXT KEYWORD FOR THIS ISOTOPE +*---- + ELSE + DO 170 IREAC=1,MAXR + RRAT=0.0 + IF(TEXT12.EQ.NMDEPL(IREAC)) THEN + CALL REDGET(INDIC,ISOT,RRAT,TEXT12,DBLINP) + IF(INDIC.EQ.1) THEN + CALL XABORT('LIBEIR: INVALID INTEGER') + ELSE IF(INDIC.EQ.2) THEN + CALL REDGET(INDIC,INTG,FLOTT,TEXT12,DBLINP) + ENDIF + KPAX(NEL+IREAC,IDEPL)=1 + BPAX(NEL+IREAC,IDEPL)=RRAT +*---- +* READ NEXT KEYWORD FOR THIS ISOTOPE +*---- + GO TO 120 + ENDIF + 170 CONTINUE + ENDIF + 100 CONTINUE + IF(INDIC.NE.3.OR.TEXT12.NE.'ENDCHAIN') + > CALL XABORT('LIBEIR: KEYWORD ENDCHAIN MISSING') + 105 CONTINUE +*---- +* FIND FISSION PRODUCTS +*---- + DO 200 IEL=1,NDEPL + DO 210 JEL=1,NDEPL + IF(KPAX(JEL,IEL).EQ.KFISSP) KPAX(NEL+KFISSP,JEL)=-1 + 210 CONTINUE + 200 CONTINUE +*---- +* RETURN FROM LIBEIR +*---- + RETURN + END diff --git a/Dragon/src/LIBENI.f b/Dragon/src/LIBENI.f new file mode 100644 index 0000000..19867c1 --- /dev/null +++ b/Dragon/src/LIBENI.f @@ -0,0 +1,62 @@ +*DECK LIBENI + SUBROUTINE LIBENI(CFILNA,NEL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Initialize dimensions for depletion data for WIMS-D4 format library. +* +*Copyright: +* Copyright (C) 1997 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau. +* +*Parameters: input +* CFILNA WIMS file name. +* +*Parameters: output +* NEL number of isotopes on library. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* PARAMETERS +*---- + INTEGER LRIND,IACTO,IACTC,IUTYPE,LPZ + PARAMETER (LRIND=0,IACTO=2,IACTC=1,IUTYPE=2,LPZ=8) +*---- +* EXTERNAL FUNCTIONS +*---- + INTEGER KDRCLS,KDROPN +*---- +* LOCAL VARIABLES +*----- + INTEGER NEL,IUNIT,II,IERR + CHARACTER CFILNA*8 +*---- +* WIMS-D4 LIBRARY PARAMETERS +*---- + INTEGER NPZ(LPZ) +*---- +* OPEN WIMS-D4 LIBRARY +* READ GENERAL DIMENSIONING +*---- + IUNIT=KDROPN(CFILNA,IACTO,IUTYPE,LRIND) + IF(IUNIT.LE.0) CALL XABORT('LIBENI: WIMS-D4 LIBRARY '// + > CFILNA//' CANNOT BE OPENED FOR DEPLETION') + READ(IUNIT) (NPZ(II),II=1,LPZ) + NEL=NPZ(1) + IERR=KDRCLS(IUNIT,IACTC) + IF(IERR.LT.0) + > CALL XABORT('LIBENI: WIMS-D4 LIBRARY '// + > CFILNA//' CANNOT BE CLOSED') +*---- +* RETURN +*---- + RETURN + END diff --git a/Dragon/src/LIBENR.f b/Dragon/src/LIBENR.f new file mode 100644 index 0000000..b7782cb --- /dev/null +++ b/Dragon/src/LIBENR.f @@ -0,0 +1,204 @@ +*DECK LIBENR + SUBROUTINE LIBENR(CFILNA,IVERW,MAXR,NEL,ITNAM,KPAX,BPAX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read depletion data on a WIMA-D4 or WIMSE formatted library. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau +* +*Parameters: input +* CFILNA WIMS-D4 or WIMS-E file name. +* IVERW type of file (=4: WIMS-D4; =5: WIMS-E). +* MAXR number of reaction types. +* NEL number of isotopes on library. +* +*Parameters: output +* ITNAM reactive isotope names in chain. +* KPAX complete reaction type matrix. +* BPAX complete branching ratio matrix. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER CFILNA*8 + INTEGER IVERW,MAXR,NEL,ITNAM(3,NEL),KPAX(NEL+MAXR,NEL) + REAL BPAX(NEL+MAXR,NEL) +*---- +* INTERNAL PARAMETERS +* CONVE : ENERGY CONVERSION FACTOR FROM JOULES/(MOLES*10**-24) +* TO MEV/NUCLIDE = 1.03643526E+13 +* CONVD : DECAY CONSTANT CONVERSION FACTOR FROM S**(-1) TO +* 10**(-8)*S**(-1) = 1.0+8 +*---- + INTEGER KCAPTU,KDECAY,KFISSP + REAL CONVE,CONVD + PARAMETER (KCAPTU=3,KDECAY=1,KFISSP=2, + > CONVE=1.03643526E+13,CONVD=1.0E+8) + CHARACTER TEXT8*8 +*---- +* WIMS-D4 LIBRARY PARAMETERS +* IUTYPE : TYPE OF FILE = 2 (BINARY) +* LRIND : LENGHT RECORD ON DA FILE = 0 +* IACTO : OPEN ACTION = 2 (READ ONLY) +* IACTC : CLOSE ACTION = 2 (KEEP) +* MAXISO : MAX. NB. ISOTOPE = 246 +* MLDEP : MAXIMUM NUMBER OF REACTION PER +* ISOTOPE IN WIMS-D4 = MAXISO+4 +* LPZ : LENGTH OF WIMS PARAMETER ARRAY = 8 +* NPZ : LIST OF MAIN PARAMETERS +* IWISO : ID OF ISOTOPE +* IBURN : INTEGER BURNUP DATA +* RBURN : REAL BURNUP DATA +*---- + INTEGER IUTYPE,LRIND,IACTO,IACTC,MAXISO,MLDEP,LPZ + PARAMETER (IUTYPE=2,LRIND=0,IACTO=2,IACTC=1,MAXISO=246, + > MLDEP=MAXISO+4,LPZ=8) + INTEGER NPZ(LPZ),IWISO(MAXISO),IBURN(MLDEP) + REAL RBURN(MLDEP),RTEMP +*---- +* EXTERNAL FUNCTIONS +*---- + INTEGER KDROPN,LIBWID,KDRCLS +*---- +* LOCAL VARIABLES +*---- + INTEGER IUNIT,II,J,ISO,JC,JB,JSO,IT,IERR +*---- +* OPEN WIMS-D4 OR WIMSE LIBRARY +* READ GENERAL DIMENSIONING +* READ ISOTOPE ID NUMBER AND CREATE EQUIVALENT ISOTOPE NAME +*---- + IUNIT=KDROPN(CFILNA,IACTO,IUTYPE,LRIND) + IF(IUNIT.LE.0) CALL XABORT('LIBENR: WIMS-D4 LIBRARY '// + > CFILNA//' CANNOT BE OPENED FOR DEPLETION') + READ(IUNIT) (NPZ(II),II=1,LPZ) + IF(NPZ(1).NE.NEL) CALL XABORT('LIBENR: TOO MANY ISOTOPES '// + > 'ON WIMS-D4 LIBRARY'//CFILNA) + READ(IUNIT) (IWISO(J),J=1,NEL) + DO 10 ISO=1,NEL + TEXT8=' ' + IF (IWISO(ISO).LT.10) THEN + WRITE(TEXT8,'(I1)') IWISO(ISO) + ELSE IF(IWISO(ISO).LT.100) THEN + WRITE(TEXT8,'(I2)') IWISO(ISO) + ELSE IF(IWISO(ISO).LT.1000) THEN + WRITE(TEXT8,'(I3)') IWISO(ISO) + ELSE IF(IWISO(ISO).LT.10000) THEN + WRITE(TEXT8,'(I4)') IWISO(ISO) + ELSE IF(IWISO(ISO).LT.100000) THEN + WRITE(TEXT8,'(I5)') IWISO(ISO) + ELSE IF(IWISO(ISO).LT.1000000) THEN + WRITE(TEXT8,'(I6)') IWISO(ISO) + ELSE IF(IWISO(ISO).LT.10000000) THEN + WRITE(TEXT8,'(I7)') IWISO(ISO) + ELSE IF(IWISO(ISO).LT.100000000) THEN + WRITE(TEXT8,'(I8)') IWISO(ISO) + ENDIF + READ(TEXT8,'(2A4)') ITNAM(1,ISO),ITNAM(2,ISO) + 10 CONTINUE +*--- +* READ TWO ADDITIONAL RECORDS BEFORE DEPLETION DATA +*---- + READ(IUNIT) (RTEMP,J=1,NPZ(2)+1) + IF(IVERW.EQ.4) READ(IUNIT) (RTEMP,J=1,NPZ(3)) +*---- +* READ DEPLETION CHAIN FOR EACH ISOTOPES +*---- + DO 100 ISO=1,NEL + RBURN(1)=0.0 + READ(IUNIT) JC,IBURN(1), + > (RBURN(JB),IBURN(JB),JB=2,JC/2) + IF(JC/2.GT.MLDEP) CALL XABORT('LIBENR: MLDEP OVERFLOW.') +*---- +* CAPTURE -> RBURN(2) > ALWAYS PRESENT +* IF ISOTOPE RESULTING FROM CAPTURE IS KNOWN STORE IN ADEQUATE +* POSITION ELSE STORE IN NEL+1 +* DECAY -> RBURN(3) > 0.0 +* IF ISOTOPE RESULTING FROM DECAY IS KNOWN STORE IN ADEQUATE +* POSITION ELSE STORE IN NEL+2 +* FISSILE -> IBURN(4) > 1 +* JC=8 -> ISOTOPE RESULTING FROM FISSION NOT KNOWN STORE IN NEL+3 +* JC>8 -> ISOTOPE RESULTING FROM FISSION KNOWN STORE IN ADEQUATE +* POSITION +*---- + IF(JC.GE.8) THEN +* radiative capture, always present + JSO=LIBWID(NEL,IWISO,IBURN(2)) + IF(JSO.GT.0) THEN + IF(KPAX(JSO,ISO) .EQ. 0) THEN + KPAX(JSO,ISO)=KCAPTU + BPAX(JSO,ISO)=RBURN(2) + KPAX(NEL+KCAPTU,JSO)=1 + ENDIF + ENDIF + KPAX(NEL+KCAPTU,ISO)=1 +* +* radioactive decay, optionnal + IF(RBURN(3).GT.0.0) THEN + JSO=LIBWID(NEL,IWISO,IBURN(3)) + IF(JSO.GT.0) THEN + IF(KPAX(JSO,ISO) .EQ. 0) THEN + KPAX(JSO,ISO)=KDECAY + BPAX(JSO,ISO)=1.0 + KPAX(NEL+KCAPTU,JSO)=1 + ENDIF + ENDIF + KPAX(NEL+KDECAY,ISO)=1 + BPAX(NEL+KDECAY,ISO)=RBURN(3)*CONVD + ENDIF +* +* fission energy, optionnal + IF(IBURN(4).GT.1) THEN + KPAX(NEL+KFISSP,ISO)=1 + BPAX(NEL+KFISSP,ISO)=RBURN(4)*CONVE + ENDIF +* +* fission yields and non-fission energy, optionnal + DO 102 IT=5,JC/2 + IF(IBURN(IT).EQ.-1) THEN +* radiative capture energy, extension to the WIMS-D4 and +* WIMS-E specifications + BPAX(NEL+KCAPTU,ISO)=RBURN(IT)*CONVE + ELSE IF(IBURN(IT).EQ.-2) THEN +* radioactive decay energy, extension to the WIMS-D4 and +* WIMS-E specifications + BPAX(NEL+KDECAY,ISO)=RBURN(IT)*CONVE + ELSE IF(RBURN(IT).GT.0.0) THEN +* fission yields + JSO=LIBWID(NEL,IWISO,IBURN(IT)) + IF(JSO.GT.0) THEN + IF(KPAX(JSO,ISO) .EQ. 0) THEN + KPAX(JSO,ISO)=KFISSP + BPAX(JSO,ISO)=RBURN(IT) + KPAX(NEL+KFISSP,JSO)=-1 + KPAX(NEL+KCAPTU,JSO)=1 + ENDIF + ENDIF + ENDIF + 102 CONTINUE + ENDIF + 100 CONTINUE +*---- +* CLOSE WIMS-D4 OR WIMSE LIBRARY +*---- + IERR=KDRCLS(IUNIT,IACTC) + IF(IERR.LT.0) + > CALL XABORT('LIBENR: WIMS LIBRARY '//CFILNA// + > ' CANNOT BE CLOSED') +*---- +* RETURN +*---- + RETURN + END diff --git a/Dragon/src/LIBEPR.f b/Dragon/src/LIBEPR.f new file mode 100644 index 0000000..ad893cc --- /dev/null +++ b/Dragon/src/LIBEPR.f @@ -0,0 +1,349 @@ +*DECK LIBEPR + SUBROUTINE LIBEPR(IMPX,NBESP,NDEPL,NSTABL,NDFI,NDFP,NREAC,NPAR, + > HNADPL,NMDEPL,IDR,RER,RRD,KPAR,BPAR,YIELD,IZAE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Print isotopic depletion chain. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau +* +*Parameters: input +* IMPX print parameter: +* .ge.5 nice formatted printout; +* .ge.10 dragon input formatted; +* .ge.20 dragon/APOLIB-2 input formatted. +* NBESP number of energy-dependent fission yield matrices. +* NDEPL number of depleting isotopes. +* NSTABL number of non-depleting isotopes producing energy. +* NDFI number of direct fissile isotopes. +* NDFP number of direct fission product. +* NREAC maximum number of depletion reaction in the depletion chain. +* NPAR maximum number of parent isopopes from decay and +* neutron-induced reactions. +* HNADPL reactive isotope names in chain. +* NMDEPL names of used depletion reactions +* (NMDEPL(1)='DECAY'; NMDEPL(2)='NFTOT'; +* NMDEPL(3)='NG' ; NMDEPL(4)='N2N'; +* etc.). +* IDR DEPLETE-REAC matrix (reaction identifiers). +* RER DEPLETE-ENER matrix (MeV/reaction values). +* RRD DEPLETE-DECA vector (decay constant values). +* KPAR PRODUCE-REAC matrix (production identifiers). +* BPAR PRODUCE-RATE matrix (branching ratios). +* YIELD fission product yield matrix. +* IZAE 6-digit nuclide identifier: +* atomic number z*10000 (digits) + mass number a*10 + +* energy state (0 = ground state, 1 = first state, etc.). +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IMPX,NBESP,NDEPL,NSTABL,NDFI,NDFP,NREAC,NPAR, + > HNADPL(3,NDEPL),NMDEPL(2,NREAC),IDR(NREAC,NDEPL), + > KPAR(NPAR,NDEPL),IZAE(NDEPL) + REAL RER(NREAC,NDEPL),RRD(NDEPL),BPAR(NPAR,NDEPL), + > YIELD(NBESP,NDFI,NDFP) +*---- +* LOCAL VARIABLES +*---- + INTEGER I,J,ISO,KRD,KRF,ISOF,IPF,KRC,IOF,KROTH,NBPROD,IPAR, + > JSO,KREAC,ISOFP,IOFS,IREAC,NBFIS,IOUT,IBESP + REAL RATD1,RATD2,RATF,RATC,RREAC + REAL, ALLOCATABLE, DIMENSION(:) :: RATFS +*---- +* INTERNAL PARAMETERS +*---- + REAL CNVDAY + PARAMETER (IOUT=6,CNVDAY=1.0E+8/86400.0) + CHARACTER NONOFF(2)*3 + CHARACTER LINE*130 + SAVE NONOFF + DATA NONOFF/'NO ','YES'/ +*---- +* PRINT THE DEPLETION CHAIN. +*---- + IF(IMPX.GE.5) THEN + WRITE(IOUT,6000) ((NMDEPL(J,I),J=1,2),I=4,NREAC) + WRITE(IOUT,6010) + ALLOCATE(RATFS(NBESP)) + DO 40 ISO=1,NDEPL + KRD=1 + RATD1=0.0 + RATD2=0.0 + IF(IDR(1,ISO).NE.0) THEN + RATD1=CNVDAY/RRD(ISO) + RATD2=RER(1,ISO) + KRD=2 + ENDIF + KRF=1 + RATF=0.0 + RATFS(:)=0.0 + IF(MOD(IDR(2,ISO),100).EQ.3) THEN + KRF=2 + RATF=RER(2,ISO) + ELSE IF(MOD(IDR(2,ISO),100).EQ.4) THEN + KRF=2 + RATF=RER(2,ISO) + ISOF=IDR(2,ISO)/100 + IF(ISOF.NE.0) THEN + DO 20 IBESP=1,NBESP + DO 10 IPF=1,NDFP + RATFS(IBESP)=RATFS(IBESP)+YIELD(IBESP,ISOF,IPF) + 10 CONTINUE + 20 CONTINUE + ENDIF + ENDIF + KRC=1 + RATC=0.0 + IF(IDR(3,ISO).NE.0) THEN + RATC=RER(3,ISO) + KRC=2 + ENDIF + LINE=' ' +*---- +* WRITE ISOTOPE PROPERTIES +*---- + WRITE(LINE(:18),'(I5,1X,2A4,1X,A3)') ISO,HNADPL(1,ISO), + > HNADPL(2,ISO),NONOFF(KRD) + IF(KRD.EQ.2) WRITE(LINE(19:42),'(1P,2E12.4)') RATD1,RATD2 + WRITE(LINE(45:47),'(A3)') NONOFF(KRF) + IF(KRF.EQ.2) WRITE(LINE(48:71),'(1P,2E12.4)') RATF,RATFS(1) + WRITE(LINE(74:76),'(A3)') NONOFF(KRC) + IF(KRC.EQ.2) WRITE(LINE(77:88),'(1P,E12.4)') RATC + IOF=91 + DO 30 I=4,NREAC + KROTH=1 + IF(IDR(I,ISO).GT.0) KROTH=2 + IF(IOF+7.GT.130) THEN + WRITE(IOUT,'(1X,A)') LINE + IOF=91 + LINE=' ' + ENDIF + WRITE(LINE(IOF:IOF+7),'(A3,5X)') NONOFF(KROTH) + IOF=IOF+8 + 30 CONTINUE + WRITE(IOUT,'(1X,A)') LINE + 40 CONTINUE + DEALLOCATE(RATFS) +*---- +* WRITE PARENTS FROM ALL REACTION EXCEPT FISSION +*---- + WRITE(IOUT,7000) + DO 70 ISO=1,NDEPL-NSTABL + NBPROD=0 + DO 50 IPAR=1,NPAR + JSO=KPAR(IPAR,ISO)/100 + KREAC=MOD(KPAR(IPAR,ISO),100) + RREAC=BPAR(IPAR,ISO) + IF(JSO.GT.0) THEN + IF((KREAC.LE.0).OR.(KREAC.GT.NREAC)) CALL XABORT('LIBEPR' + > //': INDALID REACTION INDEX') + NBPROD=NBPROD+1 + IF(NBPROD.EQ.1) THEN + WRITE(IOUT,6012) ISO,HNADPL(1,ISO),HNADPL(2,ISO), + > NMDEPL(1,KREAC),NMDEPL(2,KREAC),JSO,HNADPL(1,JSO), + > HNADPL(2,JSO),RREAC + ELSE + WRITE(IOUT,6013) NMDEPL(1,KREAC),NMDEPL(2,KREAC), + > JSO,HNADPL(1,JSO),HNADPL(2,JSO),RREAC + ENDIF + ENDIF + 50 CONTINUE +*---- +* WRITE PARENTS FROM FISSION IF REQUIRED +*---- + IF(MOD(IDR(2,ISO),100).EQ.2) THEN + GO TO 70 + ELSE IF(MOD(IDR(2,ISO),100).EQ.5) THEN + ISOFP=IDR(2,ISO)/100 + IF(ISOFP.GT.NDFP) + > CALL XABORT('LIBEPR: INVALID FISSION PRODUCT NUMBER') + DO 60 JSO=1,NDEPL + IF(MOD(IDR(2,JSO),100).EQ.4) THEN + ISOF=IDR(2,JSO)/100 + IF(ISOF.GT.NDFI) THEN + CALL XABORT('LIBEPR: INVALID FISSILE NUMBER') + ELSE IF(ISOF.GT.0) THEN + RREAC=YIELD(1,ISOF,ISOFP) + IF(RREAC.GT.0.0) THEN + NBPROD=NBPROD+1 + IF(NBPROD.EQ.1) THEN + WRITE(IOUT,6012) ISO,HNADPL(1,ISO),HNADPL(2,ISO), + > NMDEPL(1,2),NMDEPL(2,2),JSO,HNADPL(1,JSO), + > HNADPL(2,JSO),RREAC + ELSE + WRITE(IOUT,6013) NMDEPL(1,2),NMDEPL(2,2),JSO, + > HNADPL(1,JSO),HNADPL(2,JSO),RREAC + ENDIF + ENDIF + ENDIF + ENDIF + 60 CONTINUE + ENDIF + 70 CONTINUE + ENDIF +* + IF(IMPX.GE.10) THEN + WRITE(IOUT,'(/1X,4HDEPL,I6,6H CHAIN)') NDEPL + DO 330 ISO=1,NDEPL + LINE=' ' + WRITE(LINE(:17),'(1H'',2A4,1H'',I7)') HNADPL(1,ISO), + > HNADPL(2,ISO),IZAE(ISO) + IOFS=18 + IF(IDR(1,ISO).NE.0) THEN + WRITE(LINE(IOFS:IOFS+20),'(1X,5HDECAY,1P,E14.6)') RRD(ISO) + IOFS=IOFS+20 +* IF(RER(1,ISO).NE.0.0) THEN +* WRITE(LINE(IOFS:IOFS+13),'(1X,1P,E12.5)') RER(1,ISO) +* IOFS=IOFS+13 +* ENDIF + ENDIF + IF((MOD(IDR(2,ISO),100).EQ.3).OR.(MOD(IDR(2,ISO),100).EQ.4)) + > THEN + WRITE(LINE(IOFS:IOFS+15),'(1X,5HNFTOT,F9.4)') RER(2,ISO) + IOFS=IOFS+15 + ENDIF + IF(IDR(3,ISO).NE.0) THEN + WRITE(LINE(IOFS:IOFS+17),'(1X,2HNG,1P,E14.6)') RER(3,ISO) + IOFS=IOFS+17 + ENDIF + DO 80 IREAC=4,NREAC + IF(IDR(IREAC,ISO).NE.0) THEN + IF(IOFS+9.GT.71) THEN + WRITE(IOUT,'(1X,A)') LINE + LINE=' ' + IOFS=18 + ENDIF + WRITE(LINE(IOFS:IOFS+9),'(1X,2A4)') NMDEPL(1,IREAC), + > NMDEPL(2,IREAC) + IOFS=IOFS+9 + ENDIF + 80 CONTINUE + IF(ISO.GT.NDEPL-NSTABL) THEN + WRITE(LINE(IOFS:IOFS+7),'(7H STABLE)') + IOFS=IOFS+7 + IF(IOFS.GT.71) CALL XABORT('LIBEPR: LINE OVERFLOW.') + ENDIF + IF(LINE.NE.' ') WRITE(IOUT,'(1X,A)') LINE + LINE=' ' + IOFS=7 + NBPROD=0 + DO 310 IPAR=1,NPAR + JSO=KPAR(IPAR,ISO)/100 + KREAC=MOD(KPAR(IPAR,ISO),100) + RREAC=BPAR(IPAR,ISO) + IF(JSO.GT.0) THEN + NBPROD=NBPROD+1 + IF(NBPROD.EQ.1) WRITE(LINE(2:6),'(5HFROM )') + IF(IOFS+34.GE.71) THEN + WRITE(IOUT,'(1X,A)') LINE + LINE=' ' + IOFS=7 + ENDIF + WRITE(LINE(IOFS:IOFS+34),6100) + > NMDEPL(1,KREAC),NMDEPL(2,KREAC),RREAC,HNADPL(1,JSO), + > HNADPL(2,JSO) + IOFS=IOFS+34 + ENDIF + 310 CONTINUE + IF(LINE.NE.' ') WRITE(IOUT,'(1X,A)') LINE + LINE=' ' + IOFS=16 + NBFIS=0 + IF(MOD(IDR(2,ISO),100).EQ.2) THEN + GO TO 330 + ELSE IF(MOD(IDR(2,ISO),100).EQ.5) THEN + ISOFP=IDR(2,ISO)/100 + DO 320 JSO=1,NDEPL + IF(MOD(IDR(2,JSO),100).EQ.4) THEN + ISOF=IDR(2,JSO)/100 + IF(ISOF.GT.0) THEN + RREAC=YIELD(1,ISOF,ISOFP) + IF(RREAC.GT.0.0) THEN + NBPROD=NBPROD+1 + IF(NBPROD.EQ.1) WRITE(LINE(2:6),'(5HFROM )') + NBFIS=NBFIS+1 + IF(NBFIS.EQ.1) WRITE(LINE(7:14),'(A8)') 'NFTOT ' + WRITE(LINE(IOFS:IOFS+24),6101) + > RREAC,HNADPL(1,JSO),HNADPL(2,JSO) + IOFS=IOFS+24 + IF(IOFS.GE.60) THEN + WRITE(IOUT,'(1X,A)') LINE + LINE=' ' + IOFS=16 + ENDIF + ENDIF + ENDIF + ENDIF + 320 CONTINUE + IF(LINE.NE.' ') WRITE(IOUT,'(1X,A)') LINE + ENDIF + 330 CONTINUE + WRITE(IOUT,'(9H ENDCHAIN)') + ENDIF +* + IF(IMPX.GE.500) THEN + WRITE(IOUT,'(/1X,33HDEPL LIB: APLIB2 FIL: XXXXX CHAIN)') + DO 350 ISO=1,NDEPL-NSTABL + LINE=' ' + WRITE(LINE(:8),'(2A4)') HNADPL(1,ISO),HNADPL(2,ISO) + IOFS=14 + NBPROD=0 + DO 340 IPAR=1,NPAR + JSO=KPAR(IPAR,ISO)/100 + KREAC=MOD(KPAR(IPAR,ISO),100) + RREAC=BPAR(IPAR,ISO) + IF(JSO.GT.0) THEN + NBPROD=NBPROD+1 + IF(NBPROD.EQ.1) WRITE(LINE(10:13),'(4HFROM)') + WRITE(LINE(IOFS:IOFS+29),'(1X,2A4,1P,E11.4,1X,2A4)') + > NMDEPL(1,KREAC),NMDEPL(2,KREAC),RREAC,HNADPL(1,JSO), + > HNADPL(2,JSO) + IOFS=IOFS+29 + IF(IOFS.GE.71) THEN + WRITE(IOUT,'(1X,A)') LINE + LINE=' ' + IOFS=14 + ENDIF + ENDIF + 340 CONTINUE + IF(LINE.NE.' ') WRITE(IOUT,'(1X,A)') LINE + 350 CONTINUE + WRITE(IOUT,'(9H ENDCHAIN)') + ENDIF +*---- +* RETURN FROM LIBEPR +*---- + RETURN +*---- +* FORMAT +*---- + 6000 FORMAT(/' DEPLETION CHAIN DATA'/' --------------------'// + > 43X,'DEPLETION REACTIONS'/ + > ' -----------------------------', + > '--------------------------------------------'/ + > ' ISOTOPE ......DECAY................ ..........', + > '.FISSION......... ......NG....... ',10A4:/(91X,10A4)) + 6010 FORMAT(' NB. NAME MLIFE(DAYS) ENERGY(MEV) ENERGY', + > '(MEV) TOTAL YIELD ENERGY(MEV)') + 6012 FORMAT(I5,1X,2A4,4X,2A4,3X,I5,1X,2A4,1X,1P,E14.6) + 6013 FORMAT(18X,2A4,3X,I5,1X,2A4,1X,1P,E14.6) + 6100 FORMAT(2A4,1X,1P,E13.6,2H ',2A4,2H' ) + 6101 FORMAT(1P,E13.6,2H ',2A4,1H') + 7000 FORMAT(//27X,'PRODUCTION REACTIONS'/ + > 18X,'---------------------------------------'/ + > ' ISOTOPE REACTION ISOTOPE',14X,'YIELD'/ + > ' NB. NAME NB. NAME ') + END diff --git a/Dragon/src/LIBEST.f b/Dragon/src/LIBEST.f new file mode 100644 index 0000000..b6ddbc1 --- /dev/null +++ b/Dragon/src/LIBEST.f @@ -0,0 +1,265 @@ +*DECK LIBEST + SUBROUTINE LIBEST (IPLIB,NGROUP,NBISO,NBMIX,IPISO,MIX,DEN,MASK, + 1 MASKL,NED,NAMEAD,ITSTMP,TMPDAY,STERN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover the stopping powers from microscopic cross-section library +* and generate record 'ESTOPW' in the group ordered macroscopic +* cross-section library. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert and A. Naceur +* +*Parameters: input +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* NGROUP number of energy groups. +* NBISO number of isotopes present in the calculation domain. +* NBMIX number of mixtures present in the calculation domain. +* IPISO pointer array towards microlib isotopes. +* MIX mixture number of each isotope (can be zero). +* DEN density of each isotope. +* MASK mixture mask (=.true. if a mixture is to be made). +* MASKL group mask (=.true. if an energy group is to be treated). +* NED number of extra edit vectors. +* NAMEAD names of these extra edits. +* ITSTMP type of cross section perturbation (=0: perturbation +* forbidden; =1: perturbation not used even if present; +* =2: perturbation used if present). +* TMPDAY time stamp in day/burnup/irradiation. +* STERN Sternheimer flag (=0/1: off/on). +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB,IPISO(NBISO) + INTEGER NGROUP,NBISO,NBMIX,MIX(NBISO),NED,NAMEAD(2,NED),ITSTMP, + 1 STERN + REAL DEN(NBISO),TMPDAY(3) + REAL DENMIXR, DENMIX(NBMIX) + LOGICAL MASK(NBMIX),MASKL(NGROUP) +*---- +* LOCAL VARIABLES +*---- + INTEGER NSTATE,IOUT + PARAMETER (NSTATE=40,IOUT=6) + CHARACTER CV*12,HSMG*131,TEXT12*12,HPRT1*1,NORD(3)*4 + LOGICAL EXIST + INTEGER IDATA(NSTATE),I0,LLL,IBM,IED,NXSPER,ISOT,ILONG, + 1 ITYLCM,IXSPER,NGROUPS,ICV + REAL TMPPER(2,3),TIMFCT,DENISO,XTF + TYPE(C_PTR) JPLIB,KPLIB +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KGAS + REAL, ALLOCATABLE, DIMENSION(:) :: GA1,ENER + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: ESTOP,GAF + REAL, ALLOCATABLE, DIMENSION(:,:) :: DENMAT + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPGRP + CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: ISONRF +*---- +* DATA STATEMENTS +*---- + DATA NORD/' ',' LIN',' QUA'/ +*---- +* SCRATCH STORAGE ALLOCATION +* IPGRP LCM pointers of the macrolib groupwise directories. +*---- + ALLOCATE(KGAS(NBMIX)) + ALLOCATE(ESTOP(NBMIX,NGROUP+1,2),GAF(NBMIX,NGROUP+1,2)) + ALLOCATE(DENMAT(NBMIX,NGROUP+1)) + ALLOCATE(IPGRP(NGROUP)) +*---- +* SET CROSS SECTION PERTURBATION INFORMATION. +*---- + NXSPER=1 + TIMFCT=0.0 + CALL LCMLEN(IPLIB,'TIMESPER',ILONG,ITYLCM) + IF((ILONG.GE.2).AND.(ILONG.LE.6)) THEN + IF(ITSTMP.EQ.0) THEN + CALL XABORT('LIBDEN: XS PERTURBATION FORBIDDEN.') + ELSE IF(ITSTMP.EQ.2) THEN + CALL LCMGET(IPLIB,'TIMESPER',TMPPER) + TIMFCT=TMPDAY(1)-TMPPER(1,1) + XTF=TIMFCT/TMPPER(2,1) + IF(XTF.NE.0.0) NXSPER=2 + IF(XTF.LT.0.0) THEN + WRITE(IOUT,6000) TMPPER(1,1),TMPDAY(1) + ELSE IF(XTF.GT.1.0) THEN + WRITE(IOUT,6001) TMPPER(1,1)+TMPPER(2,1),TMPDAY(1) + ENDIF + ENDIF + ENDIF +*---- +* VALIDATE MACROLIB SIGNATURE AND STATE-VECTOR. +*---- + CALL LCMSIX(IPLIB,'MACROLIB',1) + CALL LCMGTC(IPLIB,'SIGNATURE',12,TEXT12) + IF(TEXT12.NE.'L_MACROLIB') THEN + CALL XABORT('LIBEST: INVALID SIGNATURE ON THE MACROLIB.') + ENDIF + CALL LCMGTC(IPLIB,'PARTICLE',1,HPRT1) + IF((HPRT1.NE.'B').AND.(HPRT1.NE.'C')) THEN + CALL XABORT('LIBEST: INVALID PARTICLE TYPE. B OR C EXPECTED.') + ENDIF + CALL LCMGET(IPLIB,'STATE-VECTOR',IDATA) + IF(IDATA(1).NE.NGROUP) THEN + WRITE(HSMG,'(37HLIBEST: EXISTING MACROLIB HAS NGROUP=,I4, + 1 25H NEW MACROLIB HAS NGROUP=,I4,1H.)') IDATA(1),NGROUP + CALL XABORT(HSMG) + ELSE IF(IDATA(2).NE.NBMIX) THEN + WRITE(HSMG,'(36HLIBEST: EXISTING MACROLIB HAS NBMIX=,I4, + 1 24H NEW MACROLIB HAS NBMIX=,I4,1H.)') IDATA(2),NBMIX + CALL XABORT(HSMG) + ENDIF + CALL LCMSIX(IPLIB,' ',2) +*---- +* SELECT NUMBER OF GROUPS TO PROCESS +*---- + NGROUPS=0 + DO LLL=1,NGROUP + IF(MASKL(LLL)) NGROUPS=NGROUPS+1 + ENDDO + IF(NGROUPS.EQ.0) GO TO 50 +*---- +* SET THE LCM MACROLIB GROUPWISE AND MICROLIB ISOTOPEWISE DIRECTORIES +*---- + CALL LCMSIX(IPLIB,'MACROLIB',1) + JPLIB=LCMLID(IPLIB,'GROUP',NGROUP) + DO LLL=1,NGROUP + IPGRP(LLL)=LCMDIL(JPLIB,LLL) + ENDDO + CALL LCMSIX(IPLIB,' ',2) +*---- +* PROCESS THE STOPPING POWERS. +*---- + ESTOP(:NBMIX,:NGROUP+1,:2)=0.0 + EXIST=.FALSE. + ALLOCATE(GA1(NGROUP+1)) + DO 40 IED=1,NED + WRITE(CV,'(2A4)') (NAMEAD(I0,IED),I0=1,2) + IF((CV(:3).EQ.'BST').OR.(CV(:3).EQ.'CST')) THEN + ICV=0 + IF(CV(2:4).EQ.'STC') THEN + ICV=1 + ELSE IF(CV(2:4).EQ.'STR') THEN + ICV=2 + ELSE + CALL XABORT('LIBEST: BSTC, BSTR, CSTC OR CSTR EXPECTED.') + ENDIF + DO 30 IBM=1,NBMIX + IF(MASK(IBM)) THEN + DO 20 ISOT=1,NBISO + IF((MIX(ISOT).NE.IBM).OR.(DEN(ISOT).EQ.0.0)) GO TO 20 + JPLIB=IPISO(ISOT) + IF(.NOT.C_ASSOCIATED(JPLIB)) GO TO 20 +*- + DENISO=DEN(ISOT) + DO IXSPER=1,NXSPER + CALL LCMLEN(JPLIB,CV(:8)//NORD(IXSPER),ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 10 + EXIST=.TRUE. + GA1(:NGROUP+1)=0.0 + CALL LCMGET(JPLIB,CV(:8)//NORD(IXSPER),GA1) + DO LLL=1,NGROUP+1 + ESTOP(IBM,LLL,ICV)=ESTOP(IBM,LLL,ICV)+GA1(LLL)*DENISO + ENDDO + DENISO=DENISO*TIMFCT + ENDDO +*- + 10 CONTINUE + 20 CONTINUE + ENDIF + 30 CONTINUE + ENDIF + 40 CONTINUE + DEALLOCATE(GA1) +*---- +* APPLY STERNHEIMER DENSITY CORRECTION TO STOPPING POWERS +*---- + IF (STERN.EQ.1) THEN + ALLOCATE(ISONRF(NBISO),ENER(NGROUP+1)) + CALL LCMGTC(IPLIB,'ISOTOPERNAME',12,NBISO,ISONRF) + CALL LCMGET(IPLIB,'ENERGY',ENER) + CALL LCMGET(IPLIB,'MIXTUREGAS',KGAS) + CALL LIBSDC(NBMIX,NGROUP,NBISO,ISONRF,MIX,DEN,MASK,ENER,KGAS, + 1 DENMAT) + DO IBM=1,NBMIX + DO LLL=1,NGROUP+1 + ESTOP(IBM,LLL,1)=ESTOP(IBM,LLL,1)-DENMAT(IBM,LLL) !eV/cm + ENDDO + ENDDO + DEALLOCATE(ENER,ISONRF) + WRITE(6,*) "STERNHEIMER CORRECTION APPLIED TO ESTOPW" + ELSE + WRITE(6,*) "STERNHEIMER CORRECTION NOT APPLIED TO ESTOPW" + ENDIF +*---- +* SAVE STOPPING POWERS IN THE MACROLIB +*---- + IF(EXIST) THEN + DO LLL=1,NGROUP+1 + GAF(:NBMIX,LLL,1)=ESTOP(:NBMIX,LLL,1)+ESTOP(:NBMIX,LLL,2) + ENDDO + DO LLL=1,NGROUP + IF(MASKL(LLL)) THEN + KPLIB=IPGRP(LLL) + CALL LCMLEN(KPLIB,'ESTOPW',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + GAF(:NBMIX,LLL,2)=0.0 + GAF(:NBMIX,LLL+1,2)=0.0 + CALL LCMGET(KPLIB,'ESTOPW',GAF(1,LLL,2)) + DO IBM=1,NBMIX + IF(.NOT.MASK(IBM)) THEN + GAF(IBM,LLL:LLL+1,1)=GAF(IBM,LLL:LLL+1,2) + ENDIF + ENDDO + ENDIF + ALLOCATE(GA1(2*NBMIX)) + GA1(:NBMIX)=GAF(:NBMIX,LLL,1) + GA1(NBMIX+1:2*NBMIX)=GAF(:NBMIX,LLL+1,1) + CALL LCMPUT(KPLIB,'ESTOPW',NBMIX*2,2,GA1) + DEALLOCATE(GA1) + ENDIF + ENDDO + ENDIF +*---- +* RECOVER MIXTURES DENSITIES +*---- + DO IBM=1,NBMIX + CALL LIBCON(IPLIB,IBM,NBISO,MIX,DEN,DENMIXR,2) + DENMIX(IBM)=DENMIXR !g/cm3 + ENDDO + CALL LCMPUT(KPLIB,'MIXTURESDENS',NBMIX,2,DENMIX) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 50 DEALLOCATE(IPGRP) + DEALLOCATE(GAF,ESTOP) + DEALLOCATE(KGAS) + RETURN +*---- +* FORMAT +*---- + 6000 FORMAT(' WARNING IN LIBEST FOR PERTURBATION'/ + > ' EXTRAPOLATION BELOW PRETURBATION TABLES'/ + > ' INITIAL TIME = ',F15.6,' DAYS'/ + > ' EXTRAPOLATION TIME = ',F15.6,' DAYS') + 6001 FORMAT(' WARNING IN LIBEST FOR PERTURBATION'/ + > ' EXTRAPOLATION ABOVE PRETURBATION TABLES'/ + > ' FINAL TIME = ',F15.6,' DAYS'/ + > ' EXTRAPOLATION TIME = ',F15.6,' DAYS') + END diff --git a/Dragon/src/LIBEWI.f b/Dragon/src/LIBEWI.f new file mode 100644 index 0000000..4c3b7f6 --- /dev/null +++ b/Dragon/src/LIBEWI.f @@ -0,0 +1,84 @@ +*DECK LIBEWI + SUBROUTINE LIBEWI(CFILNA,NEL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Initialize dimensions for depletion data on WIMS-AECL +* format library. +* +*Copyright: +* Copyright (C) 1997 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* CFILNA file name. +* +*Parameters: output +* NEL number of isotopes on library. +* +*Comments: +* WIMS-AECL library parameters +* MAXISO : max. nb. of iso = 246 +* MLDEP : maximum number of reaction per +* isotope = MAXISO +4 +* LPZ : length of parameter array = 9 +* LMASTB : length of mst tab = MAXISO+9 +* LMASIN : length of mst idx = LMASTB-4 +* LGENTB : length of gen tab = 6 +* LGENIN : length of gen idx = LGENTB +* MASTER : master index array +* GENINX : general index array +* NPZ : list of main parameters +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* WIMS-AECL LIBRARY PARAMETERS +*---- + INTEGER LRIND,IACTO,IACTC,IUTYPE,MAXISO,MLDEP,LPZ, + 1 MAXTEM,LMASTB,LMASIN,LGENTB,LGENIN + PARAMETER (LRIND=256,IACTO=2,IACTC=1,IUTYPE=4,MAXISO=246, + 1 MLDEP=MAXISO+4,LPZ=9,MAXTEM=20,LMASTB=MAXISO+9, + 2 LMASIN=LMASTB-4,LGENTB=6,LGENIN=LGENTB) + INTEGER MASTER(LMASTB),GENINX(LGENTB),NPZ(LPZ) +*---- +* EXTERNAL FUNCTIONS +*---- + INTEGER KDROPN +*---- +* LOCAL VARIABLES +*---- + INTEGER NEL,IUNIT + CHARACTER CFILNA*8 +*---- +* OPEN WIMS-AECL LIBRARY +* READ INDEX AND GENERAL DIMENSIONING NPZ +*---- + IUNIT=KDROPN(CFILNA,IACTO,IUTYPE,LRIND) + IF(IUNIT.LE.0) CALL XABORT('LIBEWI: WIMS-AECL LIBRARY '// + > CFILNA//' CANNOT BE OPENED FOR DEPLETION') + CALL OPNIND(IUNIT,MASTER,LMASTB) + CALL REDIND(IUNIT,MASTER,LMASIN,GENINX,LGENTB,1) + CALL REDIND(IUNIT,GENINX,LGENIN,NPZ,LPZ,1) + NEL=NPZ(1) + IF(NEL.GT.MAXISO) CALL XABORT('LIBEWI: TOO MANY ISOTOPES '// + > 'ON WIMS-AECL LIBRARY'//CFILNA) +*---- +* CLOSE WIMS-AECL LIBRARY AND +* RETURN +*---- + CALL CLSIND(IUNIT) +*---- +* RETURN +*---- + RETURN + END diff --git a/Dragon/src/LIBEWR.f b/Dragon/src/LIBEWR.f new file mode 100644 index 0000000..3e26261 --- /dev/null +++ b/Dragon/src/LIBEWR.f @@ -0,0 +1,221 @@ +*DECK LIBEWR + SUBROUTINE LIBEWR(CFILNA,MAXR,NEL,ITNAM,KPAX,BPAX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read depletion data on a WIMS-AECL formatted library. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau +* +*Parameters: input +* CFILNA file name. +* MAXR number of reaction types. +* NEL number of isotopes on library. +* +*Parameters: output +* ITNAM reactive isotope names in chain. +* KPAX complete reaction type matrix. +* BPAX complete branching ratio matrix. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER CFILNA*8 + INTEGER MAXR,NEL,ITNAM(3,NEL),KPAX(NEL+MAXR,NEL) + REAL BPAX(NEL+MAXR,NEL) +*---- +* INTERNAL PARAMETERS +* CONVE : ENERGY CONVERSION FACTOR FROM JOULES/(MOLES*10**-24) +* TO MEV/NUCLIDE = 1.03643526E+13 +* CONVD : DECAY CONSTANT CONVERSION FACTOR FROM S**(-1) TO +* 10**(-8)*S**(-1) = 1.0+8 +*---- + INTEGER KCAPTU,KDECAY,KFISSP,KN2N,KN3N + REAL CONVE,CONVD + PARAMETER (KDECAY=1,KFISSP=2,KCAPTU=3,KN2N=4,KN3N=5, + > CONVE=1.03643526E+13,CONVD=1.0E+8) + CHARACTER TEXT8*8 +*---- +* WIMS-AECL LIBRARY PARAMETERS +* IUTYPE : TYPE OF FILE = 4 (DA) I +* LRIND : LENGHT RECORD ON DA FILE = 256 I +* IACTO : OPEN ACTION = 2 (READ ONLY) I +* IACTC : CLOSE ACTION = 2 (KEEP) I +* MAXISO : MAX. NB. OF ISO = 246 I +* MLDEP : MAXIMUM NUMBER OF REACTION PER I +* ISOTOPE IN WIMS-AECL = MAXISO+4 +* LPZ : LENGTH OF WIMS PARAMETER ARRAY = 9 I +* LMASTB : LENGTH OF MST TAB = MAXISO+9 I +* LMASIN : LENGTH OF MST IDX = LMASTB-4 I +* LGENTB : LENGTH OF GEN TAB = 6 I +* LGENIN : LENGTH OF GEN IDX = LGENTB I +* LSUBTB : LENGTH OF SUB TAB = 6*MAXTEM+21-5+12 I +* LSUBIN : LENGTH OF SUB IDX = LSUBTB-12 I +* ICAPTU : WIMS-AECL CAPTURE FLAG = 1 I +* IDECAY : WIMS-AECL DECAY FLAG = 2 I +* IFISSP : WIMS-AECL FISSION PRODUCT FLAG = 3 I +* IFISSI : WIMS-AECL FISSILE ISOTOPE FLAG = 4 I +* IN2N : WIMS-AECL N2N FLAG = 5 I +* IN3N : WIMS-AECL N3N FLAG = 6 I +* MASTER : MASTER INDEX ARRAY I(LMASTB) +* GENINX : GENERAL INDEX ARRAY I(LGENTB) +* SUBINX : SUB INDEX ARRAY I(LSUBTB) +* NPZ : LIST OF MAIN PARAMETERS I(LPZ) +* IWISO : ID OF ISOTOPE I(2*MAXISO) +* IBURN : INTEGER BURNUP PARAMETERS I(2,MLDEP) +* RBURN : REAL BURNUP PARAMETERS R(2,MLDEP) +*---- + INTEGER IUTYPE,LRIND,IACTO,IACTC,MAXISO,MLDEP,LPZ, + > MAXTEM,LMASTB,LMASIN,LGENTB,LGENIN,LSUBTB, + > LSUBIN,ICAPTU,IDECAY,IFISSP,IFISSI,IN2N,IN3N + PARAMETER (IUTYPE=4,LRIND=256,IACTO=2,IACTC=1,MAXISO=246, + > MLDEP=MAXISO+4,LPZ=9,MAXTEM=20,LMASTB=MAXISO+9, + > LMASIN=LMASTB-4,LGENTB=6,LGENIN=LGENTB, + > LSUBTB=6*MAXTEM+28,LSUBIN=LSUBTB-12,ICAPTU=1, + > IDECAY=2,IFISSP=3,IFISSI=4,IN2N=5,IN3N=6) + INTEGER MASTER(LMASTB),GENINX(LGENTB),SUBINX(LSUBTB), + > NPZ(LPZ),IWISO(2*MAXISO) +*---- +* EXTERNAL FUNCTIONS +*---- + INTEGER KDROPN,LIBWID +*---- +* LOCAL VARIABLES +*---- + INTEGER IUNIT,IEL2,IEL,ISO,NBURN,NMIN,NFP,JBRN,JSO + INTEGER NDECAY,IBURN(2*MLDEP) + DOUBLE PRECISION TOTLAM + REAL RBURN(2*MLDEP) +*---- +* OPEN WIMS-AECL LIBRARY +* READ INDEX AND GENERAL DIMENSIONING NPZ +* READ ISOTOPE NAME AND ID NUMBER +*---- + IUNIT=KDROPN(CFILNA,IACTO,IUTYPE,LRIND) + IF(IUNIT.LE.0) CALL XABORT('LIBEWR: WIMS-AECL LIBRARY '// + > CFILNA//' CANNOT BE OPENED FOR DEPLETION') + CALL OPNIND(IUNIT,MASTER,LMASTB) + CALL REDIND(IUNIT,MASTER,LMASIN,GENINX,LGENTB,1) + CALL REDIND(IUNIT,GENINX,LGENIN,NPZ,LPZ,1) + IF(NPZ(1).NE.NEL) CALL XABORT('LIBEWR: TOO MANY ISOTOPES '// + > 'ON WIMS-AECL LIBRARY'//CFILNA) + CALL REDIND(IUNIT,GENINX,LGENIN,IWISO,2*NEL,3) + IEL2=1 + DO 10 IEL=1,NEL + CALL UPCKIC(IWISO(IEL2),TEXT8,1) + READ(TEXT8,'(2A4)') ITNAM(1,IEL),ITNAM(2,IEL) + IEL2=IEL2+2 + 10 CONTINUE + CALL REDIND(IUNIT,GENINX,LGENIN,IWISO,NEL,2) +*---- +* READ DEPLETION CHAIN FOR EACH ISOTOPES +*---- + DO 100 ISO=1,NEL +*---- +* READ SUB INDEX ASSOCIATED WITH ISOTOPE +*---- + NDECAY=0 + TOTLAM=0.0D0 + CALL REDIND(IUNIT,MASTER,LMASIN,SUBINX,LSUBTB,ISO+4) + NBURN=SUBINX(LSUBIN+1) + IF(NBURN.GT.MAXISO) THEN + CALL XABORT('LIBEWR: NBURN LARGER THAN MAXISO') + ENDIF + NMIN=2*MAX0(NBURN,1) + CALL REDIND(IUNIT,SUBINX,LSUBIN,GENINX,4,1) + CALL REDIND(IUNIT,GENINX,4,IBURN,NMIN,1) + CALL REDIND(IUNIT,GENINX,4,RBURN,NMIN,2) +*---- +* STORE REACTION TYPES AND RATES IN KPAX AND BPAX STARTING +* WITH HEAVIER ISOTOPES +*---- + NFP=0 + DO 101 JBRN=1,NBURN + IF(IBURN(2*(JBRN-1)+2).EQ.IDECAY.AND. + > RBURN(2*(JBRN-1)+1).GE.0.0) THEN + JSO=LIBWID(NEL,IWISO,IBURN(2*(JBRN-1)+1)) + NDECAY=NDECAY+1 + TOTLAM=TOTLAM+DBLE(RBURN(2*(JBRN-1)+1)) + IF(JSO.GT.0) THEN + KPAX(JSO,ISO)=KDECAY + BPAX(JSO,ISO)=RBURN(2*(JBRN-1)+1) + KPAX(NEL+KCAPTU,JSO)=1 + ENDIF + KPAX(NEL+KDECAY,ISO)=1 + ELSE IF(IBURN(2*(JBRN-1)+2).EQ.IFISSI.AND. + > RBURN(2*(JBRN-1)+1).GE.0.0) THEN + KPAX(NEL+KFISSP,ISO)=1 + BPAX(NEL+KFISSP,ISO)=RBURN(2*(JBRN-1)+1)*CONVE + ELSE IF(IBURN(2*(JBRN-1)+2).EQ.ICAPTU) THEN + JSO=LIBWID(NEL,IWISO,IBURN(2*(JBRN-1)+1)) + IF(JSO.GT.0) THEN + KPAX(JSO,ISO)=KCAPTU + BPAX(JSO,ISO)=RBURN(2*(JBRN-1)+1) + KPAX(NEL+KCAPTU,JSO)=1 + ENDIF + KPAX(NEL+KCAPTU,ISO)=1 + ELSE IF(IBURN(2*(JBRN-1)+2).EQ.IN2N) THEN + JSO=LIBWID(NEL,IWISO,IBURN(2*(JBRN-1)+1)) + IF(JSO.GT.0) THEN + KPAX(JSO,ISO)=KN2N + BPAX(JSO,ISO)=RBURN(2*(JBRN-1)+1) + KPAX(NEL+KCAPTU,JSO)=1 + ENDIF + KPAX(NEL+KN2N,ISO)=1 + ELSE IF(IBURN(2*(JBRN-1)+2).EQ.IN3N) THEN + JSO=LIBWID(NEL,IWISO,IBURN(2*(JBRN-1)+1)) + IF(JSO.GT.0) THEN + KPAX(JSO,ISO)=KN3N + BPAX(JSO,ISO)=RBURN(2*(JBRN-1)+1) + KPAX(NEL+KCAPTU,JSO)=1 + ENDIF + KPAX(NEL+KN3N,ISO)=1 + ELSE IF(IBURN(2*(JBRN-1)+2).EQ.IFISSP.AND. + > RBURN(2*(JBRN-1)+1).GE.0.0) THEN + JSO=LIBWID(NEL,IWISO,IBURN(2*(JBRN-1)+1)) + IF(JSO.GT.0) THEN + NFP=NFP+1 + KPAX(JSO,ISO)=KFISSP + BPAX(JSO,ISO)=RBURN(2*(JBRN-1)+1) + KPAX(NEL+KFISSP,JSO)=-1 + KPAX(NEL+KCAPTU,JSO)=1 + ENDIF + ENDIF + 101 CONTINUE + IF(NDECAY .EQ. 1) THEN + BPAX(NEL+KDECAY,ISO)=REAL(TOTLAM)*CONVD + DO JSO=1,NEL + IF(KPAX(JSO,ISO).EQ. KDECAY) THEN + BPAX(JSO,ISO)=1.0 + ENDIF + ENDDO + ELSE IF(NDECAY .GT. 1) THEN + BPAX(NEL+KDECAY,ISO)=REAL(TOTLAM)*CONVD + DO JSO=1,NEL + IF(KPAX(JSO,ISO).EQ. KDECAY) THEN + BPAX(JSO,ISO)=BPAX(JSO,ISO)/REAL(TOTLAM) + ENDIF + ENDDO + ENDIF + 100 CONTINUE +*---- +* CLOSE WIMS-AECL LIBRARY +*---- + CALL CLSIND(IUNIT) +*---- +* RETURN +*---- + RETURN + END diff --git a/Dragon/src/LIBEXT.f b/Dragon/src/LIBEXT.f new file mode 100644 index 0000000..c8d54be --- /dev/null +++ b/Dragon/src/LIBEXT.f @@ -0,0 +1,211 @@ +*DECK LIBEXT + SUBROUTINE LIBEXT (IPDRL,NGRO,NL,NDIL,NED,HVECT,NDEL,LSTAY,IMPX, + 1 DILUT,MDIL,LSCAT,LSIGF,LADD,LGOLD,FLUX,TOTAL,SIGF,SIGS,SCAT, + 2 SADD,ZDEL,DELTG,GOLD,ISMIN,ISMAX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read dilution-dependent information of one isotope in multi-dilution +* internal library format. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPDRL pointer to the multi-dilution internal library. +* NGRO number of energy groups. +* NL number of Legendre orders required in the calculation +* (NL=1 or higher). +* NDIL number of finite dilutions. +* NED number of extra vector edits. +* HVECT names of the extra vector edits. +* NDEL number of delayed neutron precursor groups. +* LSTAY dilution reduction flag (=.true. do not reduce). +* IMPX print flag. +* +*Parameters: input/output +* DILUT dilutions. +* +*Parameters: output +* MDIL number of finite dilutions used. +* LSCAT Legendre flag (=.true. if a given Legendre order of the +* scattering cross section exists). +* LSIGF fission flag (=.true. if the isotope can fission). +* LADD additional xs flag (=.true. if a given additional cross +* section exists). +* LGOLD Goldstein-Cohen flag (=.true. if Goldstein-Cohen parameters +* exists). +* FLUX weighting flux. +* TOTAL total cross sections. +* SIGF nu*fission cross sections. +* SIGS scattering cross sections. +* SCAT scattering transfer matrices (sec,prim,Legendre,dilution). +* SADD additional cross sections. +* ZDEL delayed nu-sigf cross sections. +* DELTG lethargy widths. +* GOLD Goldstein-Cohen parameters. +* ISMIN minimum secondary group corresponding to each primary group. +* ISMAX maximum secondary group corresponding to each primary group. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPDRL + INTEGER NGRO,NL,NDIL,NED,NDEL,IMPX,MDIL,ISMIN(NL,NGRO), + 1 ISMAX(NL,NGRO) + REAL DILUT(NDIL+1),FLUX(NGRO,NDIL+1),TOTAL(NGRO,NDIL+1), + 1 SIGF(NGRO,NDIL+1),SIGS(NGRO,NL,NDIL+1),SCAT(NGRO,NGRO,NL,NDIL+1), + 2 SADD(NGRO,NED,NDIL+1),ZDEL(NGRO,NDEL,NDIL+1),DELTG(NGRO), + 3 GOLD(NGRO) + CHARACTER HVECT(NED)*8 + LOGICAL LSTAY,LSIGF,LSCAT(NL),LADD(NED),LGOLD + INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPRO,IPDIL +*---- +* LOCAL VARIABLES +*---- + PARAMETER(MAXTIT=10) + TYPE(C_PTR) JPDRL,KPDRL + CHARACTER TEXNUD*12 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(ITYPRO(NL),IPDIL(NDIL+1)) +* + DO 10 IL=1,NL + LSCAT(IL)=.FALSE. + 10 CONTINUE + LSIGF=.FALSE. + DO 20 IED=1,NED + LADD(IED)=.FALSE. + 20 CONTINUE + CALL LCMGET(IPDRL,'DELTAU',DELTG) +*---- +* RECOVER DILUTION-DEPENDENT VALUES. +*---- + JPDRL=LCMGID(IPDRL,'ISOTOPESLIST') + DO 80 IDIL=1,NDIL+1 + KPDRL=LCMGIL(JPDRL,IDIL) ! set IDIL-th isotope + CALL LCMGET(KPDRL,'NWT0',FLUX(1,IDIL)) + CALL LCMGET(KPDRL,'NTOT0',TOTAL(1,IDIL)) + CALL LCMLEN(KPDRL,'NUSIGF',LENGT,ITYLCM) + LSIGF=LSIGF.OR.(LENGT.GT.0) + IF(LENGT.GT.0) THEN + CALL LCMGET(KPDRL,'NUSIGF',SIGF(1,IDIL)) + ELSE + SIGF(:NGRO,IDIL)=0.0 + ENDIF + CALL XDRLGS(KPDRL,-1,IMPX,0,NL-1,1,NGRO,SIGS(1,1,IDIL), + 1 SCAT(1,1,1,IDIL),ITYPRO) + DO 30 IL=0,NL-1 + LSCAT(IL+1)=LSCAT(IL+1).OR.(ITYPRO(IL+1).GT.0) + 30 CONTINUE + DO 50 IED=1,NED + DO 40 IG1=1,NGRO + SADD(IG1,IED,IDIL)=0.0 + 40 CONTINUE + CALL LCMLEN(KPDRL,HVECT(IED),LENGT,ITYLCM) + LADD(IED)=LADD(IED).OR.(LENGT.GT.0) + IF(LENGT.GT.0) CALL LCMGET(KPDRL,HVECT(IED),SADD(1,IED,IDIL)) + 50 CONTINUE + DO 70 IDEL=1,NDEL + WRITE(TEXNUD,'(6HNUSIGF,I2.2)') IDEL + DO 60 IG1=1,NGRO + ZDEL(IG1,IDEL,IDIL)=0.0 + 60 CONTINUE + CALL LCMLEN(KPDRL,TEXNUD,LENGT,ITYLCM) + IF(LENGT.GT.0) CALL LCMGET(KPDRL,TEXNUD,ZDEL(1,IDEL,IDIL)) + 70 CONTINUE + IF(IDIL.EQ.NDIL+1) THEN + CALL LCMLEN(KPDRL,'NGOLD',LENGT,ITYLCM) + LGOLD=LENGT.GT.0 + IF(LGOLD) THEN + CALL LCMGET(KPDRL,'NGOLD',GOLD) + ELSE + GOLD(:NGRO)=1.0 + ENDIF + ENDIF + 80 CONTINUE +*---- +* SET THE SIGNIFICANT DILUTIONS. +*---- + MDIL=0 + IF(LSTAY) THEN + MDIL=NDIL + DO 85 IDIL=1,NDIL + IPDIL(IDIL)=IDIL + 85 CONTINUE + ELSE + DO 90 IDIL=1,NDIL + IF(DILUT(IDIL).LT.1.5) THEN + CONTINUE + ELSE IF((DILUT(IDIL).GT.1.0E5).AND.(DILUT(IDIL).LT.1.0E10)) THEN + CONTINUE + ELSE + MDIL=MDIL+1 + IPDIL(MDIL)=IDIL + ENDIF + 90 CONTINUE + ENDIF + IPDIL(MDIL+1)=NDIL+1 + DO 122 IDIL=1,MDIL+1 + DILUT(IDIL)=DILUT(IPDIL(IDIL)) + DO 121 IG1=1,NGRO + FLUX(IG1,IDIL)=FLUX(IG1,IPDIL(IDIL)) + TOTAL(IG1,IDIL)=TOTAL(IG1,IPDIL(IDIL)) + SIGF(IG1,IDIL)=SIGF(IG1,IPDIL(IDIL)) + DO 105 IL=1,NL + SIGS(IG1,IL,IDIL)=SIGS(IG1,IL,IPDIL(IDIL)) + DO 100 IG2=1,NGRO + SCAT(IG2,IG1,IL,IDIL)=SCAT(IG2,IG1,IL,IPDIL(IDIL)) + 100 CONTINUE + 105 CONTINUE + DO 110 IED=1,NED + SADD(IG1,IED,IDIL)=SADD(IG1,IED,IPDIL(IDIL)) + 110 CONTINUE + DO 120 IDEL=1,NDEL + ZDEL(IG1,IDEL,IDIL)=ZDEL(IG1,IDEL,IPDIL(IDIL)) + 120 CONTINUE + 121 CONTINUE + 122 CONTINUE +*---- +* COMPUTE THE SCATTERING BANDWIDTH AND MOST THERMAL GROUPS. +*---- + DO 160 IL=1,NL + IF(LSCAT(IL)) THEN + DO 130 IG1=1,NGRO + ISMIN(IL,IG1)=NGRO + ISMAX(IL,IG1)=1 + 130 CONTINUE + DO 142 IG2=1,NGRO + DO 141 IDIL=1,MDIL+1 + DO 140 IG1=NGRO,1,-1 + IF(SCAT(IG2,IG1,IL,IDIL).NE.0.0) THEN + ISMIN(IL,IG1)=MIN(ISMIN(IL,IG1),IG2) + ISMAX(IL,IG1)=MAX(ISMAX(IL,IG1),IG2) + ENDIF + 140 CONTINUE + 141 CONTINUE + 142 CONTINUE + ELSE + DO 150 IG1=1,NGRO + ISMIN(IL,IG1)=NGRO+1 + ISMAX(IL,IG1)=0 + 150 CONTINUE + ENDIF + 160 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IPDIL,ITYPRO) + RETURN + END diff --git a/Dragon/src/LIBFQD.f b/Dragon/src/LIBFQD.f new file mode 100644 index 0000000..59e84d1 --- /dev/null +++ b/Dragon/src/LIBFQD.f @@ -0,0 +1,957 @@ +*DECK LIBFQD + SUBROUTINE LIBFQD(MAXNOR,LPART,MAXTRA,HNAMIS,IPLIB,NGRO,NL,NED, + 1 NDEL,NDIL,IGRMIN,IGRMAX,LBIN,NFS,IMPX,LSCAT,LSIGF,LADD,DILUT, + 2 FLUX,TOTAL,SIGF,SIGS,SCAT,SADD,ZDEL,EBIN,SIGTF,SIGSF,SIGFF, + 3 AWR,ISMIN,ISMAX,GOLD,IPRECI,NOR,LBSIGF) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute NOR-point Calendf-type probability tables; +* compute physical and/or slowing-down correlated probability tables; +* component of the Ribon extended method. +* +*Copyright: +* Copyright (C) 2003 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXNOR first dimension of matrix PRTSIG. Equal to the maximum order +* of a probability table. +* LPART maximum scattering bandwidth for the isotope. +* MAXTRA maximum number of energy bins of size DELI. +* HNAMIS name of the isotope. +* IPLIB pointer to the internal library (L_LIBRARY signature). +* NGRO number of energy groups. +* NL number of Legendre orders required in the calculation +* (NL=1 or higher). +* NED number of extra vector edits. +* NDEL number of delayed neutron precursor groups. +* NDIL number of finite dilutions. +* IGRMIN first self-shielded group with BIN data. +* IGRMAX most thermal self-shielded group with BIN data. +* LBIN number of fine (bin) energy groups. +* NFS number of fine energy groups in each group. +* IMPX print flag (equal to zero for no print). +* LSCAT anisotropy flag (=.true. if a given Legendre order of the +* scattering cross section exists). +* LSIGF fission flag (=.true. if the isotope can fission). +* LADD additional cross section flag (=.true. if a given additional +* cross section exists). +* DILUT dilutions. +* FLUX weighting flux. +* TOTAL total cross sections. +* SIGF nu*fission cross sections. +* SIGS scattering cross sections. +* SCAT scattering transfer matrices (sec,prim,Legendre,dilution). +* SADD additional cross sections. +* ZDEL delayed nu-sigf cross sections. +* EBIN fine group energy limits in EV. +* SIGTF microscopic total x-sections in the fine groups. +* SIGSF microscopic P0 scattering x-sections in the fine groups. +* AWR mass ratio for current isotope. +* SIGFF microscopic nu*fission cross sections in the fine groups. +* ISMIN minimum secondary group corresponding to each primary group. +* ISMAX maximum secondary group corresponding to each primary group. +* GOLD method flag: =-998.0 to use the CALENDF approach; =-999.0 to +* use the Ribon extended approach; =1.0 to use the ST model. +* IPRECI accuracy index for probability tables in CALENDF. +* LBSIGF autolib (bin) fission data flag. +* +*Parameters: output +* NOR number of subgroups in each group. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + INTEGER MAXNOR,LPART,MAXTRA,NGRO,NL,NED,NDEL,NDIL,IGRMIN,IGRMAX, + 1 LBIN,NFS(NGRO),IMPX,ISMIN(NL,NGRO),ISMAX(NL,NGRO),IPRECI, + 2 NOR(NGRO) + REAL DILUT(NDIL+1),FLUX(NGRO,NDIL+1),TOTAL(NGRO,NDIL+1), + 1 SIGF(NGRO,NDIL+1),SIGS(NGRO,NL,NDIL+1),SCAT(NGRO,NGRO,NL,NDIL+1), + 2 SADD(NGRO,NED,NDIL+1),ZDEL(NGRO,NDEL,NDIL+1),EBIN(LBIN+1), + 3 SIGTF(LBIN),SIGSF(LBIN),SIGFF(LBIN),AWR,GOLD(NGRO) + LOGICAL LSCAT(NL),LSIGF,LADD(NED),LBSIGF + CHARACTER HNAMIS*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IALTER=0,MAXDIL=65) + TYPE(C_PTR) JPLIB,KPLIB + CHARACTER HSMG*131,TAG*2 + LOGICAL LNORAJ,LPHYS,LCALEN,LRIBON,LDIL(MAXDIL+1),LPTMC + INTEGER IPERD(MAXDIL+1) + REAL XSREF(MAXDIL),TEST(8),DILUT2(MAXDIL+1),TSCAT(20,MAXDIL), + 1 DIFFS(20,MAXDIL) + DOUBLE PRECISION SIGTI2,SIGAI2,SIGTIN,SIGAIN,DELMAC,T,TF,T0,T1, + 1 T2,ACCUM1,ACCUM2,ACCUM3,ACCUM4,FACT(MAXDIL),BB(MAXDIL+1) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISM + REAL, ALLOCATABLE, DIMENSION(:) :: WSLD,DELTA,UUU,STIS,SIGAF, + 1 PRTSIW,PRTABS,GAR,SEFR + REAL, ALLOCATABLE, DIMENSION(:,:) :: PRTSIG,PRI,PRTSIG1,PRTSIG2, + 1 SCAT00,PRTRS + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: PRTPH + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: PHIMT,CC,MOMT,MOMP + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: MATRIX,WORK,RSTAR + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: PHI +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(ISM(2,NL)) + ALLOCATE(PRTSIG(MAXNOR,3+NL+NL*LPART+NED+NDEL),WSLD(MAXNOR**2), + 1 DELTA(LBIN),UUU(LBIN),STIS(LBIN),SIGAF(LBIN), + 2 PRI(MAXTRA,NL),PRTPH(MAXNOR,NDIL,NL),PRTSIW(MAXNOR), + 3 PRTABS(MAXNOR),PRTRS(MAXNOR,NDIL+1), + 4 PRTSIG1(MAXNOR,3+NL+NL*LPART+NED+NDEL),SCAT00(LBIN,NGRO), + 5 PRTSIG2(MAXNOR,3+NL+NL*LPART+NED+NDEL),GAR(LBIN)) + ALLOCATE(PHIMT(MAXNOR),MATRIX(MAXNOR,MAXNOR+1), + 1 PHI(LBIN,NDIL,NL),WORK(NDIL+1,MAXNOR),CC(MAXNOR), + 2 RSTAR(LBIN,NDIL+1)) +* + IF(NDIL.GT.MAXDIL) CALL XABORT('LIBFQD: MAXDIL OVERFLOW.') +*---- +* NORMALIZE THE BIN-TYPE DATA AND COMPUTE DELTA AND SIGAF. +*---- + IBIN=0 + DELMIN=1.0E10 + DO 40 IGRP=IGRMIN,IGRMAX + SIGTIN=0.0D0 + SIGAIN=0.0D0 + SIGSIN=0.0D0 + SIGFIN=0.0D0 + SIGTI2=0.0D0 + SIGAI2=0.0D0 + SIGSI2=0.0D0 + SIGFI2=0.0D0 + DO 20 IGF=1,NFS(IGRP) + DELM=LOG(EBIN(IBIN+IGF)/EBIN(IBIN+IGF+1)) + DELMIN=MIN(DELMIN,DELM) + SIGTIN=SIGTIN+SIGTF(IBIN+IGF)*DELM + SIGAIN=SIGAIN+(SIGTF(IBIN+IGF)-SIGSF(IBIN+IGF))*DELM + SIGSIN=SIGSIN+SIGSF(IBIN+IGF)*DELM + IF(LBSIGF) SIGFIN=SIGFIN+SIGFF(IBIN+IGF)*DELM + SIGTF(IBIN+IGF)=MAX(0.002,SIGTF(IBIN+IGF)) + SIGAF(IBIN+IGF)=SIGTF(IBIN+IGF)-SIGSF(IBIN+IGF) + SIGTI2=SIGTI2+SIGTF(IBIN+IGF)*DELM + SIGAI2=SIGAI2+SIGAF(IBIN+IGF)*DELM + SIGSI2=SIGSI2+SIGSF(IBIN+IGF)*DELM + IF(LBSIGF) SIGFI2=SIGFI2+SIGFF(IBIN+IGF)*DELM + UUU(IBIN+IGF)=LOG(EBIN(1)/EBIN(IBIN+IGF+1)) + DELTA(IBIN+IGF)=DELM + 20 CONTINUE + DO 30 IGF=1,NFS(IGRP) + SIGTF(IBIN+IGF)=SIGTF(IBIN+IGF)*REAL(SIGTIN/SIGTI2) + SIGSF(IBIN+IGF)=SIGSF(IBIN+IGF)*REAL(SIGSIN/SIGSI2) + IF(LBSIGF) SIGFF(IBIN+IGF)=SIGFF(IBIN+IGF)*(SIGFIN/SIGFI2) + SIGAF(IBIN+IGF)=SIGAF(IBIN+IGF)*REAL(SIGAIN/SIGAI2) + 30 CONTINUE + IBIN=IBIN+NFS(IGRP) + 40 CONTINUE +*---- +* ASSUME THAT THE ELEMENTARY LETHARGY WIDTH DELI IS A RATIONAL FRACTION +* OF THE LETHARGY UNIT. CHECK THIS ASSUMPTION. +*---- + CALL LCMLEN(IPLIB,'BIN-DELI',LENGT,ITYLCM) + IF((LENGT.EQ.1).AND.(ITYLCM.EQ.2)) THEN + CALL LCMGET(IPLIB,'BIN-DELI',DELI) + ELSE + DELI=1.0/REAL(INT(1.00001/DELMIN)) + ENDIF + IBIN=0 + ERR=0.0 + DO 60 IGRP=IGRMIN,IGRMAX + DO 50 IGF=1,NFS(IGRP) + LARGH=INT(DELTA(IBIN+IGF)/DELI+0.1) + ERR=MAX(ERR,ABS(DELTA(IBIN+IGF)/DELI-REAL(LARGH))) + 50 CONTINUE + IBIN=IBIN+NFS(IGRP) + 60 CONTINUE + IF((IMPX.GT.0).OR.(ERR.GT.0.05)) THEN + WRITE(6,'(/47H LIBFQD: THE ELEMENTARY LETHARGY WIDTH OF ISOTO, + 1 4HPE '',A12,11H'' IS SET TO,1P,E11.4,6H. ERR=,E10.3)') HNAMIS, + 2 DELI,ERR + ENDIF + IF(ERR.GT.0.05) THEN + WRITE(HSMG,'(45HLIBFQD: UNABLE TO SET THE ELEMENTARY LETHARGY, + 1 20H WIDTH FOR ISOTOPE '',A12,2H''.)') HNAMIS + WRITE(6,'(A)') HSMG + ENDIF +*---- +* COMPUTE THE PRI ARRAY FOR VARIOUS LEGENDRE ORDERS. +*---- + DO 70 IL=1,NL + CALL LIBPRI(MAXTRA,DELI,AWR,IALTER,IL-1,NEXT,PRI(1,IL)) + 70 CONTINUE +*---- +* COMPUTE AUTOLIB CROSS SECTIONS FOR THE PO SCATTERING MATRIX +*---- + SCAT00(:LBIN,:NGRO)=0.0 + LLL=0 + DO IGRP=IGRMIN,IGRMAX + GAR0=0.0 + DO LI=1,NFS(IGRP) + LLL=LLL+1 + GAR0=GAR0+DELTA(LLL) + GAR(:LBIN)=0.0 + CALL LIBECT(MAXTRA,LLL,PRI(1,1),UUU,DELI,DELTA,NEXT,1, + 1 MML,STIS) + DO I=1,MML + LLJ=LLL-I+1 + GAR(LLJ)=STIS(I)*SIGSF(LLJ)*DELTA(LLJ)/DELTA(LLL) + ENDDO + LLJ=0 + DO JGRP=IGRMIN,IGRMAX + DO LJ=1,NFS(JGRP) + LLJ=LLJ+1 + SCAT00(LLJ,IGRP)=SCAT00(LLJ,IGRP)+GAR(LLJ) + ENDDO + ENDDO + ENDDO + ENDDO +*---- +* MAIN LOOP OVER THE COARSE ENERGY GROUPS. +*---- + NOR(:NGRO)=0 + CALL LCMSIX(IPLIB,'PT-TABLE',1) + CALL LCMPUT(IPLIB,'NDEL',1,1,NDEL) + IBIN=0 + JPLIB=LCMLID(IPLIB,'GROUP-PT',NGRO) +* ------------------ + DO 810 IGRP=1,NGRO +*---- +* REMOVE BADLY BEHAVED COLLOCATIONS POINTS. +*---- + MDIL=NDIL + LDIL(:NDIL+1)=.TRUE. + DO 90 IDIL=NDIL,1,-1 + IF(DILUT(IDIL).LT.1.0) THEN + MDIL=MDIL-1 + LDIL(IDIL)=.FALSE. + ELSE IF((DILUT(IDIL).GT.1.0E5).AND.(DILUT(IDIL).LT.1.0E10)) THEN + MDIL=MDIL-1 + LDIL(IDIL)=.FALSE. + ELSE IF(TOTAL(IGRP,IDIL).LE.0.0) THEN + MDIL=MDIL-1 + LDIL(IDIL)=.FALSE. + ENDIF + 90 CONTINUE + IDD=0 + DO 100 IDIL=1,NDIL+1 + IF(LDIL(IDIL)) THEN + IDD=IDD+1 + DILUT2(IDD)=DILUT(IDIL) + IPERD(IDD)=IDIL + ENDIF + 100 CONTINUE + IF(IDD.NE.MDIL+1) CALL XABORT('LIBFQD: INTERNAL ERROR.') +* + LCALEN=(NFS(IGRP).GT.0).AND.(GOLD(IGRP).EQ.-998.0) + LRIBON=(NFS(IGRP).GT.0).AND.(GOLD(IGRP).EQ.-999.0) + LPTMC=(NFS(IGRP).GT.0).AND.(GOLD(IGRP).EQ.-1000.0) +*---- +* ACTIVE SPM IN GROUPS IGRMAX-1 and IGRMAX +*---- + IF(LPTMC.AND.(IGRP.GE.IGRMAX-1)) THEN + LPTMC=.FALSE. + LCALEN=.TRUE. + ENDIF + LPHYS=(.NOT.LCALEN).AND.(.NOT.LRIBON).AND.(.NOT.LPTMC) +* + PRTSIG(:MAXNOR,:3+NL+NL*LPART+NED+NDEL)=0.0 +* + IF(IMPX.GT.1) THEN + WRITE(6,'(/25H LIBFQD: PROCESSING GROUP,I4,14H FOR ISOTOPE '', + 1 A12,2H''.)') IGRP,HNAMIS + ENDIF + DO 110 IDIL=1,MDIL + JDIL=IPERD(IDIL) + XSREF(IDIL)=TOTAL(IGRP,JDIL)-SIGS(IGRP,1,JDIL) + 110 CONTINUE +*---- +* COMPUTE THE RESONANT FLUX BY SOLVING A SLOWING-DOWN EQUATION. COMPUTE +* STIS USING LIBECT AND COMPUTE THE FINE FLUX. NORMALIZE THE RESONANT +* FLUX TO THE DILUTION-DEPENDENT NJOY COLLISION RATES. +*---- + IF(LRIBON) THEN + RSTAR(:LBIN,:NDIL+1)=0.0D0 + DO 142 IDIL=1,MDIL + T0=0.0D0 + DELMAC=0.0D0 + DO 130 IGF=1,NFS(IGRP) + DELM=DELTA(IBIN+IGF) + DELMAC=DELMAC+DELM + CALL LIBECT(MAXTRA,IBIN+IGF,PRI(1,1),UUU,DELI,DELTA,NEXT,1, + 1 MML,STIS) + PHI(IBIN+IGF,IDIL,1)=DILUT2(IDIL) + DO 120 J=2,MML + JGF=IBIN+IGF-J+1 + PHI(IBIN+IGF,IDIL,1)=PHI(IBIN+IGF,IDIL,1)+DBLE(STIS(J)* + 1 (SIGTF(JGF)-SIGAF(JGF))*DELTA(JGF)/DELTA(IBIN+IGF))* + 2 PHI(JGF,IDIL,1) + 120 CONTINUE + PHI(IBIN+IGF,IDIL,1)=PHI(IBIN+IGF,IDIL,1)/(SIGTF(IBIN+IGF)+ + 1 DILUT2(IDIL)-DBLE(STIS(1)*(SIGTF(IBIN+IGF)-SIGAF(IBIN+IGF)))) + T0=T0+PHI(IBIN+IGF,IDIL,1)*SIGTF(IBIN+IGF)*DELM + 130 CONTINUE +* + JDIL=IPERD(IDIL) + FACT(IDIL)=FLUX(IGRP,JDIL)*TOTAL(IGRP,JDIL)*DELMAC/T0 + DO 141 IL=2,NL + DO 140 IGF=1,NFS(IGRP) + BONDAR=SIGTF(IBIN+IGF)+DILUT2(IDIL) + PHI(IBIN+IGF,IDIL,IL)=PHI(IBIN+IGF,IDIL,IL-1)/BONDAR + 140 CONTINUE + 141 CONTINUE + 142 CONTINUE +* +* COMPUTE THE FINE-GROUP SLOWING-DOWN SOURCE. + DO 152 IGF=1,NFS(IGRP) + CALL LIBECT(MAXTRA,IBIN+IGF,PRI(1,1),UUU,DELI,DELTA,NEXT,1, + 1 MML,STIS) + DO 151 J=1,MML + JGF=IBIN+IGF-J+1 + ACCUM1=DBLE(STIS(J)*(SIGTF(JGF)-SIGAF(JGF))*DELTA(JGF)/ + 1 DELTA(IBIN+IGF)) + DO 150 IDIL=1,MDIL+1 + IF(IDIL.LE.MDIL) THEN + RSTAR(IBIN+IGF,IDIL)=RSTAR(IBIN+IGF,IDIL)+ACCUM1* + 1 PHI(JGF,IDIL,1) + ELSE + RSTAR(IBIN+IGF,IDIL)=RSTAR(IBIN+IGF,IDIL)+ACCUM1 + ENDIF + 150 CONTINUE + 151 CONTINUE + 152 CONTINUE + DO 162 IDIL=1,MDIL + DO 161 IGF=1,NFS(IGRP) + RSTAR(IBIN+IGF,IDIL)=RSTAR(IBIN+IGF,IDIL)*FACT(IDIL) + DO 160 IL=1,NL + PHI(IBIN+IGF,IDIL,IL)=PHI(IBIN+IGF,IDIL,IL)*FACT(IDIL) + 160 CONTINUE + 161 CONTINUE + 162 CONTINUE + ENDIF +*---- +* TEST FINE FLUX. +*---- + IF((IMPX.GT.5).AND.LRIBON) THEN + WRITE(6,910) IGRP,HNAMIS + DO 240 IDIL=1,MDIL + DELMAC=0.0D0 + TF=0.0D0 + T0=0.0D0 + T1=0.0D0 + T2=0.0D0 + DO 230 IGF=1,NFS(IGRP) + DELM=DELTA(IBIN+IGF) + DELMAC=DELMAC+DELM + TF=TF+PHI(IBIN+IGF,IDIL,1)*DELM + T0=T0+PHI(IBIN+IGF,IDIL,1)*SIGTF(IBIN+IGF)*DELM + T1=T1+PHI(IBIN+IGF,IDIL,1)*SIGAF(IBIN+IGF)*DELM + T2=T2+RSTAR(IBIN+IGF,IDIL)*DELM + 230 CONTINUE + JDIL=IPERD(IDIL) + BTOT=TOTAL(IGRP,JDIL)*FLUX(IGRP,JDIL) + BABS=(TOTAL(IGRP,JDIL)-SIGS(IGRP,1,JDIL))*FLUX(IGRP,JDIL) + WRITE(6,'(1X,I5,1P,8E12.4)') IDIL,T0/DELMAC,BTOT,T1/DELMAC, + 1 BABS,T2/DELMAC,(T0+DILUT2(IDIL)*TF)/DELMAC-DILUT2(IDIL), + 2 TF/DELMAC,((T2/DELMAC)+DILUT2(IDIL))/((T0/TF)+DILUT2(IDIL)) + 240 CONTINUE + DELMAC=0.0D0 + T0=0.0D0 + T1=0.0D0 + DO 250 IGF=1,NFS(IGRP) + DELM=DELTA(IBIN+IGF) + DELMAC=DELMAC+DELM + T0=T0+SIGTF(IBIN+IGF)*DELM + T1=T1+SIGAF(IBIN+IGF)*DELM + 250 CONTINUE + BTOT=TOTAL(IGRP,NDIL+1) + BABS=TOTAL(IGRP,NDIL+1)-SIGS(IGRP,1,NDIL+1) + WRITE(6,'(3X,3HINF,1P,4E12.4)') T0/DELMAC,BTOT,T1/DELMAC,BABS + ENDIF +*---- +* PROCESS CLASSICAL PROBABILITY TABLE INFORMATION IN TOTAL XS. +*---- + LNORAJ=.TRUE. + ERROR1=0.0 + 260 NPAR=1 + IF(LPHYS) THEN + NPART=3+NL+NED+NDEL + DO 270 IL=1,NL + NPART=NPART+MAX(ISMAX(IL,IGRP)-ISMIN(IL,IGRP)+1,0) + 270 CONTINUE + IF(NPART.GT.3+NL+NL*LPART+NED+NDEL) CALL XABORT('LIBFQD: BUG.') + CALL LIBTAB (IGRP,NGRO,NL,NDIL,NPART,NED,NDEL,HNAMIS,IMPX, + 1 LSCAT,LSIGF,LADD,DILUT,TOTAL,SIGF,SIGS,SCAT,SADD,ZDEL,1.0, + 2 ISMIN,ISMAX,NOR(IGRP),PRTSIG) + DO 280 JNOR=1,NOR(IGRP) + PRTABS(JNOR)=PRTSIG(JNOR,2)-PRTSIG(JNOR,4) + 280 CONTINUE + GO TO 780 + ELSE IF(LCALEN.OR.LRIBON) THEN + ALLOCATE(MOMT(2*MAXNOR),MOMP(MAXNOR),SEFR((NPAR+2)*MDIL)) + CALL LIBMOM(NFS(IGRP),MDIL,NPAR,DELTA(IBIN+1),SIGTF(IBIN+1), + 1 SIGAF(IBIN+1),SIGTF(IBIN+1),MAXNOR,DILUT2,MOMT, + 2 MOMP,SEFR) +* + CALL LIBCAT(MAXNOR,NPAR,MDIL,MOMT,MOMP,IPRECI,LNORAJ,DILUT2, + 1 SEFR,NOR(IGRP),PRTSIG,ERRBST) + ERROR1=ERRBST +* + DEALLOCATE(SEFR,MOMP,MOMT) + DO 285 JNOR=1,NOR(IGRP) + PRTABS(JNOR)=PRTSIG(JNOR,3)! absorption + PRTSIG(JNOR,3)=0.0 + 285 CONTINUE +*--- + ELSE IF(LPTMC) THEN + IF(LBSIGF) NPAR=2 + ALLOCATE(MOMT(2*MAXNOR),MOMP(NPAR*MAXNOR),SEFR((NPAR+2)*MDIL)) +* CALENDF PT FOR SIGT, SIGS AND NUSIGF + CALL LIBMOM(NFS(IGRP),MDIL,NPAR,DELTA(IBIN+1),SIGTF(IBIN+1), + 1 SIGSF(IBIN+1),SIGFF(IBIN+1),MAXNOR,DILUT2,MOMT,MOMP,SEFR) + CALL LIBCAT(MAXNOR,NPAR,MDIL,MOMT,MOMP,IPRECI,LNORAJ,DILUT2, + 1 SEFR,NOR(IGRP),PRTSIG1,ERRBST) + ERROR1=ERRBST + DEALLOCATE(SEFR,MOMP,MOMT) +* + DO INOR=1,NOR(IGRP) + PRTSIG(INOR,1)=PRTSIG1(INOR,1)!weight + PRTSIG(INOR,2)=PRTSIG1(INOR,2)!total + IF(LBSIGF) THEN + PRTSIG(INOR,3)=PRTSIG1(INOR,4)!fission + ELSE + PRTSIG(INOR,3)=0.0 + ENDIF + PRTSIG(INOR,4)=PRTSIG1(INOR,3)!scattering + PRTABS(INOR)=PRTSIG(INOR,2)-PRTSIG(INOR,4)! absorption + ENDDO +* + IOF2=4+NL + DO IL=1,NL + DO JGRP=ISMIN(IL,IGRP),ISMAX(IL,IGRP) + NPAR2=1 + ALLOCATE(MOMT(2*MAXNOR),MOMP(NPAR*MAXNOR), + 1 SEFR((NPAR+2)*MDIL)) + CALL LIBMOM(NFS(IGRP),MDIL,NPAR2,DELTA(IBIN+1), + 1 SIGTF(IBIN+1),SCAT00(IBIN+1,JGRP),SIGTF(IBIN+1),MAXNOR, + 2 DILUT2,MOMT,MOMP,SEFR) + LNORAJ=.FALSE. + CALL LIBCAT(MAXNOR,NPAR2,MDIL,MOMT,MOMP,IPRECI,LNORAJ, + 1 DILUT2,SEFR,NOR(IGRP),PRTSIG2,ERRBST) + ERROR1=ERRBST + DEALLOCATE(SEFR,MOMP,MOMT) + DO INOR=1,NOR(IGRP) + PRTSIG(INOR,IOF2)=PRTSIG2(INOR,3) + ENDDO + IOF2=IOF2+1 + ENDDO + ENDDO + NPAR=MAX(NPAR,NPAR2) + ENDIF + IF(NOR(IGRP).EQ.0) THEN + CALL XABORT('LIBFQD: NO SUBGROUPS.') + ELSE IF(NOR(IGRP).GT.MDIL) THEN + LNORAJ=.FALSE. + NOR(IGRP)=MDIL + GO TO 260 + ENDIF +*---- +* REMOVING SMALL PROBABILITIES. +*---- + INOR=0 + 290 INOR=INOR+1 + IF(INOR.GT.NOR(IGRP)) GO TO 310 + IF(ABS(PRTSIG(INOR,1)).LT.1.0E-10) THEN + DO 305 JNOR=INOR+1,NOR(IGRP) + DO 300 J=1,NPAR+2 + PRTSIG(JNOR-1,J)=PRTSIG(JNOR,J) + 300 CONTINUE + 305 CONTINUE + INOR=INOR-1 + NOR(IGRP)=NOR(IGRP)-1 + ENDIF + GO TO 290 +* + 310 IF(LRIBON.AND.(IMPX.GT.3)) THEN + WRITE(6,'(/7X,11HPROBABILITY,7X,5HTOTAL,2X,10HABSORPTION)') + TEST(:3)=0.0 + DO 320 INOR=1,NOR(IGRP) + TEST(1)=TEST(1)+PRTSIG(INOR,1) + TEST(2)=TEST(2)+PRTSIG(INOR,1)*PRTSIG(INOR,2) + TEST(3)=TEST(3)+PRTSIG(INOR,1)*PRTSIG(INOR,3) + WRITE(6,'(1X,I5,1P,3E12.4)') INOR,(PRTSIG(INOR,J),J=1,3) + 320 CONTINUE + WRITE(6,'(6H CHECK,1P,3E12.4)') (TEST(J),J=1,3) + TEST(:3)=0.0 + DO 330 I=1,NFS(IGRP) + TEST(1)=TEST(1)+DELTA(IBIN+I) + TEST(2)=TEST(2)+SIGTF(IBIN+I)*DELTA(IBIN+I) + TEST(3)=TEST(3)+SIGAF(IBIN+I)*DELTA(IBIN+I) + 330 CONTINUE + DO 340 J=2,3 + TEST(J)=TEST(J)/TEST(1) + 340 CONTINUE + TEST(1)=1.0 + WRITE(6,'(6H EXACT,1P,3E12.4)') (TEST(J),J=1,3) + ENDIF +*---- +* COMPUTE THE REFERENCE SELF-SHIELDED CROSS SECTIONS AT SELECTED +* VALUES OF THE DILUTION FOR AN HOMOGENEOUS MEDIA. SECOL-TYPE +* APPROXIMATION. +*---- + IF(IBIN+NFS(IGRP).GT.LBIN) CALL XABORT('LIBFQD: PHI OVERFLOW.') +* + DO 405 IDIL=1,MDIL + DO 400 IL=1,NL + IF(LPHYS.OR.LCALEN.OR.LPTMC) THEN +* USE A BONDARENKO RESONANT FLUX. + T0=0.0D0 + DO 350 INOR=1,NOR(IGRP) + BONDAR=(DILUT2(IDIL)+PRTSIG(INOR,2))**IL + PRTPH(INOR,IDIL,IL)=DILUT2(IDIL)/BONDAR + T0=T0+PRTSIG(INOR,1)*PRTPH(INOR,IDIL,1) + 350 CONTINUE + IF(IL.EQ.1) BB(IDIL)=FLUX(IGRP,IPERD(IDIL))/T0 + DO 360 INOR=1,NOR(IGRP) + PRTPH(INOR,IDIL,IL)=PRTPH(INOR,IDIL,IL)*REAL(BB(IDIL)) + 360 CONTINUE + ELSE +* COMPUTE THE BASE POINTS OF THE RESONANT FLUX. + JINI=(1-NOR(IGRP))/2 + PHIMT(:NOR(IGRP))=0.0D0 + DELMAC=0.0D0 + DO 385 IGF=1,NFS(IGRP) + DELM=DELTA(IBIN+IGF) + SIGT=SIGTF(IBIN+IGF) + DELMAC=DELMAC+DELM + T0=PHI(IBIN+IGF,IDIL,IL)*DELM + T=T0 + DO 370 INOR=1-JINI,NOR(IGRP) + PHIMT(INOR)=PHIMT(INOR)+T + T=T*SIGT + 370 CONTINUE + T=T0/SIGT + DO 380 INOR=-JINI,1,-1 + PHIMT(INOR)=PHIMT(INOR)+T + T=T/SIGT + 380 CONTINUE + 385 CONTINUE + DO 390 INOR=1,NOR(IGRP) + PHIMT(INOR)=PHIMT(INOR)/DELMAC + 390 CONTINUE + CALL LIBMPA(NOR(IGRP),JINI,PRTSIG(1,1),PRTSIG(1,2),PHIMT, + 1 PRTPH(1,IDIL,IL)) + ENDIF + 400 CONTINUE + 405 CONTINUE +*---- +* COMPUTE THE BASE POINTS OF THE SLOWING-DOWN SOURCE. +*---- + IF(LRIBON) THEN + JINI=-NOR(IGRP)/2 + DO 440 IDIL=1,MDIL+1 + PHIMT(:NOR(IGRP))=0.0D0 + DELMAC=0.0D0 + DO 425 IGF=1,NFS(IGRP) + DELM=DELTA(IBIN+IGF) + SIGT=SIGTF(IBIN+IGF) + DELMAC=DELMAC+DELM + T0=RSTAR(IBIN+IGF,IDIL)*DELM + T=T0 + DO 410 INOR=1-JINI,NOR(IGRP) + PHIMT(INOR)=PHIMT(INOR)+T + T=T*SIGT + 410 CONTINUE + T=T0/SIGT + DO 420 INOR=-JINI,1,-1 + PHIMT(INOR)=PHIMT(INOR)+T + T=T/SIGT + 420 CONTINUE + 425 CONTINUE + DO 430 INOR=1,NOR(IGRP) + PHIMT(INOR)=PHIMT(INOR)/DELMAC + 430 CONTINUE + CALL LIBMPA(NOR(IGRP),JINI,PRTSIG(1,1),PRTSIG(1,2),PHIMT, + 1 PRTRS(1,IDIL)) + 440 CONTINUE + ENDIF +*---- +* NORMALIZATION OF THE FLUX-RELATED BASE POINTS. THIS NORMALIZATION +* PERMITS TO RE-OBTAIN THE BASE POINTS IN TOTAL X-SECTION IF THE RMS +* APPROACH IS APPLIED TO THE PRTPH MATRIX. +*---- + DO 490 IDIL=1,MDIL + T0=0.0D0 + DO 450 INOR=1,NOR(IGRP) + T0=T0+PRTSIG(INOR,1)*PRTSIG(INOR,2)*PRTPH(INOR,IDIL,1) + 450 CONTINUE + JDIL=IPERD(IDIL) + FACTOR=FLUX(IGRP,JDIL)*TOTAL(IGRP,JDIL)/REAL(T0) + DO 465 IL=1,NL + DO 460 INOR=1,NOR(IGRP) + PRTPH(INOR,IDIL,IL)=PRTPH(INOR,IDIL,IL)*FACTOR + 460 CONTINUE + 465 CONTINUE +* + IF(IMPX.GT.9) THEN + WRITE(6,'(/7X,11HPROBABILITY,3X,9HFINE-FLUX,4X,9HDILUTION=,1P, + 1 E8.1,5H BARN)') DILUT2(IDIL) + TEST(1)=0.0 + TEST(2)=0.0 + TEST(3)=0.0 + DO 470 INOR=1,NOR(IGRP) + PGAR=PRTPH(INOR,IDIL,1) + TEST(1)=TEST(1)+PRTSIG(INOR,1) + TEST(2)=TEST(2)+PRTSIG(INOR,1)*PGAR + TEST(3)=TEST(3)+PRTSIG(INOR,1)*PRTSIG(INOR,2)*PGAR + WRITE(6,'(1X,I5,1P,2E12.4)') INOR,PRTSIG(INOR,1),PGAR + 470 CONTINUE + TEST(3)=TEST(3)/TEST(2) + TEST(2)=TEST(2)/TEST(1) + WRITE(6,'(6H CHECK,1P,3E12.4)') (TEST(J),J=1,3) + IF(LRIBON) THEN + TEST(1)=0.0 + TEST(2)=0.0 + TEST(3)=0.0 + DO 480 IGF=1,NFS(IGRP) + DELM=DELTA(IBIN+IGF) + TEST(1)=TEST(1)+DELM + TEST(2)=TEST(2)+REAL(PHI(IBIN+IGF,IDIL,1))*DELM + TEST(3)=TEST(3)+REAL(PHI(IBIN+IGF,IDIL,1))*SIGTF(IBIN+IGF)* + 1 DELM + 480 CONTINUE + TEST(3)=TEST(3)/TEST(2) + TEST(2)=TEST(2)/TEST(1) + TEST(1)=1.0 + WRITE(6,'(6H EXACT,1P,3E12.4)') (TEST(J),J=1,3) + ENDIF + ENDIF + 490 CONTINUE +*---- +* USE A ROOT MEAN SQUARE TECHNIQUE TO FIND BASE POINTS OF THE +* SCATTERING XS VECTOR AND MATRIX CORRELATED TO THE TOTAL XS IN +* GROUP IGRP. NOTE: PRTPH(INOR,IDIL,1) IS USED INSTEAD OF +* PRTPH(INOR,IDIL,IL) ON LINE LABELED 500 IN ORDER TO BE CONSISTENT +* WITH USSIT0 AND USSIT1. THIS MAY CHANGE IN FUTURE. +*---- + IF(LPTMC) GO TO 780 + IOF1=4 + IOF2=NL+4 + DO 560 IL=1,NL + IF(LSCAT(IL)) THEN + DO 505 INOR=1,NOR(IGRP) + WORK(MDIL+1,INOR)=1.0D0 + DO 500 IDIL=1,MDIL + WORK(IDIL,INOR)=PRTPH(INOR,IDIL,1) + 500 CONTINUE + 505 CONTINUE + CALL ALST2F(NDIL+1,MDIL+1,NOR(IGRP),WORK,PHIMT) + DO 510 IDIL=1,MDIL+1 + JDIL=IPERD(IDIL) + BB(IDIL)=SIGS(IGRP,IL,JDIL)*FLUX(IGRP,JDIL) + 510 CONTINUE + CALL ALST2S(NDIL+1,MDIL+1,NOR(IGRP),WORK,PHIMT,BB,CC) + DO 520 INOR=1,NOR(IGRP) + PRTSIG(INOR,IOF1)=REAL(CC(INOR))/PRTSIG(INOR,1) + 520 CONTINUE + DO 550 JGRP=ISMIN(IL,IGRP),ISMAX(IL,IGRP) + DO 530 IDIL=1,MDIL+1 + JDIL=IPERD(IDIL) + BB(IDIL)=SCAT(JGRP,IGRP,IL,JDIL)*FLUX(IGRP,JDIL) + 530 CONTINUE + CALL ALST2S(NDIL+1,MDIL+1,NOR(IGRP),WORK,PHIMT,BB,CC) + DO 540 INOR=1,NOR(IGRP) + PRTSIG(INOR,IOF2)=REAL(CC(INOR))/PRTSIG(INOR,1) + 540 CONTINUE + IOF2=IOF2+1 + 550 CONTINUE + ENDIF + IOF1=IOF1+1 + 560 CONTINUE +*---- +* COMPUTE THE ROOT MEAN SQUARE COEFFICIENT MATRIX FOR P0 FLUX. +*---- + DO 575 INOR=1,NOR(IGRP) + WORK(MDIL+1,INOR)=1.0D0 + DO 570 IDIL=1,MDIL + WORK(IDIL,INOR)=PRTPH(INOR,IDIL,1) + 570 CONTINUE + 575 CONTINUE + CALL ALST2F(NDIL+1,MDIL+1,NOR(IGRP),WORK,PHIMT) +*---- +* USE A ROOT MEAN SQUARE TECHNIQUE TO FIND BASE POINTS OF THE +* ABSORPTION XS CORRELATED TO THE TOTAL XS IN GROUP IGRP. +*---- + DO 580 IDIL=1,MDIL+1 + JDIL=IPERD(IDIL) + BB(IDIL)=(TOTAL(IGRP,JDIL)-SIGS(IGRP,1,JDIL))*FLUX(IGRP,JDIL) + 580 CONTINUE + CALL ALST2S(NDIL+1,MDIL+1,NOR(IGRP),WORK,PHIMT,BB,CC) + DO 590 INOR=1,NOR(IGRP) + PRTABS(INOR)=REAL(CC(INOR))/PRTSIG(INOR,1) + 590 CONTINUE +*---- +* USE A ROOT MEAN SQUARE TECHNIQUE TO FIND BASE POINTS OF THE NU*SIGF +* XS CORRELATED TO THE TOTAL XS IN GROUP IGRP. +*---- + IF(LSIGF) THEN + DO 600 IDIL=1,MDIL+1 + JDIL=IPERD(IDIL) + BB(IDIL)=SIGF(IGRP,JDIL)*FLUX(IGRP,JDIL) + 600 CONTINUE + CALL ALST2S(NDIL+1,MDIL+1,NOR(IGRP),WORK,PHIMT,BB,CC) + DO 610 INOR=1,NOR(IGRP) + PRTSIG(INOR,3)=REAL(CC(INOR))/PRTSIG(INOR,1) + 610 CONTINUE + ENDIF +*---- +* USE A ROOT MEAN SQUARE TECHNIQUE TO FIND BASE POINTS OF THE +* ADDITIONAL XS CORRELATED TO THE TOTAL XS IN GROUP IGRP. +*---- + DO 640 IED=1,NED + IF(LADD(IED)) THEN + DO 620 IDIL=1,MDIL+1 + JDIL=IPERD(IDIL) + BB(IDIL)=SADD(IGRP,IED,JDIL)*FLUX(IGRP,JDIL) + 620 CONTINUE + CALL ALST2S(NDIL+1,MDIL+1,NOR(IGRP),WORK,PHIMT,BB,CC) + DO 630 INOR=1,NOR(IGRP) + PRTSIG(INOR,IOF2)=REAL(CC(INOR))/PRTSIG(INOR,1) + 630 CONTINUE + ENDIF + IOF2=IOF2+1 + 640 CONTINUE +*---- +* USE A ROOT MEAN SQUARE TECHNIQUE TO FIND BASE POINTS OF THE DELAYED +* NU*SIGF XS CORRELATED TO THE TOTAL XS IN GROUP IGRP. +*---- + IF(LSIGF) THEN + DO 670 IDEL=1,NDEL + DO 650 IDIL=1,MDIL+1 + JDIL=IPERD(IDIL) + BB(IDIL)=ZDEL(IGRP,IDEL,JDIL)*FLUX(IGRP,JDIL) + 650 CONTINUE + CALL ALST2S(NDIL+1,MDIL+1,NOR(IGRP),WORK,PHIMT,BB,CC) + DO 660 INOR=1,NOR(IGRP) + PRTSIG(INOR,IOF2)=REAL(CC(INOR))/PRTSIG(INOR,1) + 660 CONTINUE + IOF2=IOF2+1 + 670 CONTINUE + ENDIF +*---- +* USE A ROOT MEAN SQUARE TECHNIQUE TO FIND THE ELEMENTS OF THE +* SLOWING-DOWN RELATED CORRELATED WEIGHT MATRIX AND SECONDARY +* SCATTERING XS IN GROUP IGRP. +*---- + IF(LPHYS.OR.LCALEN.OR.LPTMC) THEN + DO 685 INOR=1,NOR(IGRP) + PRTSIW(INOR)=PRTSIG(INOR,4) + DO 680 JNOR=1,NOR(IGRP) + WSLD((INOR-1)*NOR(IGRP)+JNOR)=PRTSIG(INOR,1)*PRTSIG(JNOR,1) + 680 CONTINUE + 685 CONTINUE + ELSE + DO 705 INOR=1,NOR(IGRP) + DO 690 IDIL=1,MDIL+1 + BB(IDIL)=PRTRS(INOR,IDIL) + 690 CONTINUE + CALL ALST2S(NDIL+1,MDIL+1,NOR(IGRP),WORK,PHIMT,BB,CC) + DO 700 I=1,NOR(IGRP) + WSLD((I-1)*NOR(IGRP)+INOR)=REAL(CC(I))*PRTSIG(INOR,1) + 700 CONTINUE + 705 CONTINUE +* + DO 730 J=1,NOR(IGRP) + T0=0.0D0 + DO 710 I=1,NOR(IGRP) + T0=T0+WSLD((J-1)*NOR(IGRP)+I) + 710 CONTINUE + DO 720 I=1,NOR(IGRP) + WSLD((J-1)*NOR(IGRP)+I)= + 1 REAL(WSLD((J-1)*NOR(IGRP)+I)*(PRTSIG(J,1)/T0)) + 720 CONTINUE + PRTSIW(J)=REAL(T0)/PRTSIG(J,1) + 730 CONTINUE + ENDIF + IDOMAX=0 + EROLD1=1.0E10 + EROLD2=1.0E10 + IF(LCALEN.OR.LPTMC) GO TO 780 +*---- +* SOLVE SUBGROUP FORM OF THE SLOWING-DOWN EQUATION FOR AN HOMOGENEOUS +* MIXTURE AT SELECTED DILUTIONS. +*---- + ERROR1=-9999.0 + ERROR2=-9999.0 + IDMAX=0 + DO 770 IDIL=1,MDIL + DO 750 I=1,NOR(IGRP) + MATRIX(I,NOR(IGRP)+1)=PRTSIG(I,1)*DILUT2(IDIL) + DO 740 J=1,NOR(IGRP) + MATRIX(I,J)=-WSLD((J-1)*NOR(IGRP)+I)*PRTSIW(J) + 740 CONTINUE + MATRIX(I,I)=MATRIX(I,I)+(PRTSIG(I,2)+DILUT2(IDIL))*PRTSIG(I,1) + 750 CONTINUE + CALL ALSBD(NOR(IGRP),1,MATRIX,IER,MAXNOR) + IF(IER.NE.0) CALL XABORT('LIBFQD: SINGULAR MATRIX(2).') +*---- +* TEST THE ACCURACY OF THE PROBABILITY TABLES FOR THIS ENERGY GROUP. +*---- + ACCUM1=0.0D0 + ACCUM2=0.0D0 + ACCUM3=0.0D0 + ACCUM4=0.0D0 + DO 760 I=1,NOR(IGRP) + ACCUM1=ACCUM1+PRTSIG(I,1)*PRTABS(I)*MATRIX(I,NOR(IGRP)+1) + ACCUM2=ACCUM2+PRTSIG(I,1)*MATRIX(I,NOR(IGRP)+1) + ACCUM3=ACCUM3+PRTSIG(I,1)*PRTABS(I)*PRTPH(I,IDIL,1) + ACCUM4=ACCUM4+PRTSIG(I,1)*PRTPH(I,IDIL,1) + 760 CONTINUE + ACCUM1=ACCUM1/ACCUM2 + ACCUM3=ACCUM3/ACCUM4 + IF(ABS(ACCUM1-XSREF(IDIL))/ABS(XSREF(IDIL)).GT.ERROR1) THEN + EROLD1=ERROR1 + EROLD2=ERROR2 + IDOMAX=IDMAX + ERROR1=ABS(REAL(ACCUM1)-XSREF(IDIL))/ABS(XSREF(IDIL)) + ERROR2=ABS(REAL(ACCUM3)-XSREF(IDIL))/ABS(XSREF(IDIL)) + IDMAX=IDIL + ELSE IF(ABS(REAL(ACCUM1)-XSREF(IDIL))/ABS(XSREF(IDIL)).GT.EROLD1) + 1 THEN + EROLD1=ABS(REAL(ACCUM1)-XSREF(IDIL))/ABS(XSREF(IDIL)) + EROLD2=ABS(REAL(ACCUM3)-XSREF(IDIL))/ABS(XSREF(IDIL)) + IDOMAX=IDIL + ENDIF + 770 CONTINUE + IF(IMPX.GT.1) THEN + TAG='=>' + IF(LPHYS) TAG='--' + IF(LCALEN) TAG='==' + IF(LPTMC) TAG='>>' + WRITE(6,900) TAG,IGRP,NOR(IGRP),ERROR1*100.0,ERROR2*100.0, + 1 DILUT2(IDMAX),EROLD1*100.0,EROLD2*100.0,DILUT2(IDOMAX) + ENDIF + IF(ERROR1.GT.0.01) THEN + WRITE(HSMG,'(42HLIBFQD: UNABLE TO COMPUTE THE PROBABILITY , + 1 15HTABLES IN GROUP,I4,17H. TABLE ACCURACY=,1P,E9.2,2H %, + 2 10H ISOTOPE='',A12,2H''.)') IGRP,ERROR1*100.0,HNAMIS + WRITE(6,'(1X,A)') HSMG + ENDIF +* + 780 IF((IMPX.GT.2).AND.(NOR(IGRP).GT.1)) THEN + WRITE(6,'(/7H GROUP=,I4,16H TABLE ACCURACY=,1P,E9.2,2H %)') + 1 IGRP,ERROR1*100.0 + WRITE(6,'(/7X,11HPROBABILITY,7X,5HTOTAL,2X,10HABSORPTION,2X, + 1 10HNU-FISSION,2X,10HSCATTERING,12(1H.))') + TEST(:8)=0.0 + IOF=NL+IGRP-ISMIN(1,IGRP) + JMIN=5 + JMAX=MIN(JMIN+ISMAX(1,IGRP)-ISMIN(1,IGRP),8) + DO 790 JNOR=1,NOR(IGRP) + TEST(1)=TEST(1)+PRTSIG(JNOR,1) + TEST(2)=TEST(2)+PRTSIG(JNOR,1)*PRTSIG(JNOR,2) + TEST(3)=TEST(3)+PRTSIG(JNOR,1)*PRTABS(JNOR) + TEST(4)=TEST(4)+PRTSIG(JNOR,1)*PRTSIG(JNOR,3) + DO J=JMIN,JMAX + TEST(J)=TEST(J)+PRTSIG(JNOR,1)*PRTSIG(JNOR,IOF+J-1) + ENDDO + WRITE(6,'(1X,I5,1P,8E12.4)') JNOR,(PRTSIG(JNOR,J),J=1,2), + 1 PRTABS(JNOR),PRTSIG(JNOR,3),(PRTSIG(JNOR,IOF+J-1),J=JMIN,JMAX) + 790 CONTINUE + WRITE(6,'(6H CHECK,1P,8E12.4)') (TEST(J),J=1,JMAX) + TEST(:8)=0.0 + TEST(1)=1.0 + TEST(2)=TOTAL(IGRP,NDIL+1) + TEST(3)=TOTAL(IGRP,NDIL+1)-SIGS(IGRP,1,NDIL+1) + TEST(4)=SIGF(IGRP,NDIL+1) + DO J=JMIN,JMAX + TEST(J)=SCAT(IGRP+J-5,IGRP,1,NDIL+1) + ENDDO + WRITE(6,'(6H EXACT,1P,8E12.4)') (TEST(I),I=1,JMAX) + TEST(:8)=0.0 +*--- +* CHECK POINT BASES OF THE SCATTERING MATRIX +*--- + IF(IGRP.GE.IGRMIN.AND.IGRP.LT.IGRMAX) THEN + DIFFS(:20,:MAXDIL)=0.0 + DO IPART=4+NL,4+NL+ISMAX(1,IGRP)-ISMIN(1,IGRP) + DO IDIL=1,NDIL+1 + TEST(:8)=0.0 + DO INOR=1,NOR(IGRP) + TEST(1)=TEST(1)+PRTSIG(INOR,1)*PRTSIG(INOR,IPART)/ + 1 (PRTSIG(INOR,2)+DILUT2(IDIL)) + TEST(2)=TEST(2)+PRTSIG(INOR,1)/(PRTSIG(INOR,2)+DILUT2(IDIL)) + ENDDO + TSCAT(IPART,IDIL)=TEST(1)/TEST(2) + DIFFS(IPART,IDIL)=(TSCAT(IPART,IDIL)- + 1 SCAT(IGRP+IPART-4-NL,IGRP,1,IDIL))/ + 2 SCAT(IGRP+IPART-4-NL,IGRP,1,IDIL) + ENDDO + WRITE(6,*)'SCATTERING MATRIX COEFFICIENTS FOR IDIL=1,NDIL+1' + WRITE(6,'(11H SECONDARY ,1P,I3,9H PRIMARY ,1P,I3)') + 1 IGRP+IPART-4-NL,IGRP + WRITE(6,*)'CALENDF' + WRITE(6,'(5(4X,F12.4))') (TSCAT(IPART,IDIL),IDIL=1,NDIL+1) + WRITE(6,*)'NJOY' + WRITE(6,'(5(4X,F12.4))') (SCAT(IGRP+IPART-4-NL, + 1 IGRP,1,IDIL),IDIL=1,NDIL+1) + WRITE(*,*)'RELATIVE DIFFERENCE (%)' + WRITE(6,'(5(4X,F12.4))') + 1 (1.E2*DIFFS(IPART,IDIL),IDIL=1,NDIL+1) + ENDDO + ENDIF + ENDIF + IF(NOR(IGRP).GT.1) THEN +* SAVE THE PROBABILITY TABLE INTO IPLIB. + KPLIB=LCMDIL(JPLIB,IGRP) + NPART=3+NL+NED+NDEL + DO 800 IL=1,NL + ISM(1,IL)=ISMIN(IL,IGRP) + ISM(2,IL)=ISMAX(IL,IGRP) + NPART=NPART+MAX(0,(ISMAX(IL,IGRP)-ISMIN(IL,IGRP)+1)) + 800 CONTINUE + CALL LCMPUT(KPLIB,'PROB-TABLE',NPART*MAXNOR,2,PRTSIG) + IF(LRIBON) THEN + CALL LCMPUT(KPLIB,'SIGQT-SIGS',NOR(IGRP),2,PRTSIW) + CALL LCMPUT(KPLIB,'SIGQT-SLOW',NOR(IGRP)**2,2,WSLD) + ELSE IF(LCALEN.OR.LPTMC) THEN + IOF=NL+IGRP-ISMIN(1,IGRP) + CALL LCMPUT(KPLIB,'SIGQT-SIGS',NOR(IGRP),2,PRTSIG(1,IOF+4)) + ENDIF + CALL LCMPUT(KPLIB,'ISM-LIMITS',2*NL,1,ISM) + ENDIF + IBIN=IBIN+NFS(IGRP) + 810 CONTINUE + CALL LCMPUT(IPLIB,'NOR',NGRO,1,NOR) + CALL LCMSIX(IPLIB,' ',2) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(RSTAR,CC,WORK,PHI,MATRIX,PHIMT) + DEALLOCATE(GAR,PRTSIG2,SCAT00,PRTSIG1,PRTRS,PRTABS,PRTSIW,PRTPH, + 1 PRI,SIGAF,STIS,UUU,DELTA,WSLD,PRTSIG) + DEALLOCATE(ISM) + RETURN +* + 900 FORMAT(/9H LIBFQD: ,A2,6HGROUP=,I3,7H ORDER=,I2,7H ERROR=,1P, + 1 E9.2,4H % (,E9.2,15H %) AT DILUTION,E10.3,5H BARN/29X, + 2 7H ERROR=,1P,E9.2,4H % (,E9.2,15H %) AT DILUTION,E10.3,6H BARN.) + 910 FORMAT(/32H LIBFQD: TEST FINE FLUX IN GROUP,I5,14H FOR ISOTOPE ', + 1 A12,2H':/9H DILUTION,16X,5HTOTAL,14X,10HABSORPTION,12X, + 2 12HSLOWING-DOWN,20X,4HFLUX/11X,7HAUTOLIB,8X,4HNJOY,5X,7HAUTOLIB, + 3 8X,4HNJOY) + END diff --git a/Dragon/src/LIBINF.f b/Dragon/src/LIBINF.f new file mode 100644 index 0000000..69c27ac --- /dev/null +++ b/Dragon/src/LIBINF.f @@ -0,0 +1,221 @@ +*DECK LIBINF + SUBROUTINE LIBINF (IPLIB,MAXISO,MAXLIB,MAXED,MAXMIX,NBISO,NGRO, + 1 NL,ITRANC,NLIB,NCOMB,NEDMAC,NBMIX,ISONAM,ISONRF,ISOMIX,DENISO, + 2 TMPISO,SHINA,SNISO,SBISO,NTFG,LSHI,GIR,NIR,MASKI,HLIB,IEVOL, + 3 ITYP,ILLIB,KGAS,DENMIX,HVECT,HNAME) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover general information from a microlib. +* +*Copyright: +* Copyright (C) 2024 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* MAXISO maximum number of isotopes permitted. +* MAXLIB maximum number of external cross-section libraries. +* MAXED maximum number of extra vector edits. +* MAXMIX maximum number of material mixtures. +* +*Parameters: output +* NBISO number of isotopes present in the microlib. +* NGRO number of energy groups. +* NL anisotropy order in the microlib. +* ITRANC type of transport correction: =0 no transport correction +* =1 Apollo type transport correction; =2 recover from +* library; =3 WIMS-D type; =4 leakage correction alone. +* NLIB number of cross-section libraries. +* NCOMB number of depleting mixtures (used by EVO:). +* NEDMAC number of extra vector edits. +* NBMIX number of mixtures defined in the microlib. +* ISONAM alias name of each isotope. +* ISONRF library name of each isotope. +* ISOMIX mix number of each isotope. +* DENISO density of each isotope. +* MASK mixture masks.* TMPISO temperature of each isotope. +* SHINA self-shielding name of each isotope. +* SNISO dilution cross section of each isotope. A value of 1.0E10 +* is used for infinite dilution. +* SBISO dilution cross section of each isotope used with Livolant- +* Jeanpierre normalization. +* NTFG number of thermal groups where the thermal inelastic +* correction is applied. +* LSHI resonant region number associated with i-th isotope. +* Infinite dilution will be assumed if LSHI(I)=0. A negative +* value is indicating correlation of cross sections with all +* isotopes sharing the same LSHI value. +* GIR Goldstein-Cohen IR parameter of each isotope. +* NIR Goldstein-Cohen IR cutoff energy index. Use IR approximation. +* for groups with index.ge.nir; Use library value if NIR=0. +* MASKI isotope masks. +* HLIB isotope options. +* IEVOL flag making an isotope non-depleting: +* =1 to force an isotope to be non-depleting; +* =2 to force an isotope to be depleting; +* =3 to force an isotope to be at saturation. +* ITYP isotopic type: +* =1: the isotope is not fissile and not a fission product; +* =2: the isotope is fissile; =3: is a fission product. +* ILLIB xs library index for each isotope (.le.NLIB). +* KGAS state of mixture (used for stopping power correction): +* =0: solid or liquid; +* =1: gas. +* DENMIX mixture density (set to -1.0 to avoid using them). +* HVECT extra vector edits names. +* HNAME external cross-section libraries names. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + INTEGER MAXISO,MAXLIB,MAXED,MAXMIX,NBISO,NGRO,NL,ITRANC,NLIB, + 1 NCOMB,NEDMAC,NBMIX,ISONAM(3,MAXISO),ISONRF(3,MAXISO), + 2 ISOMIX(MAXISO),NTFG(MAXISO),LSHI(MAXISO),NIR(MAXISO), + 3 IEVOL(MAXISO),ITYP(MAXISO),ILLIB(MAXISO),KGAS(MAXMIX) + REAL DENISO(MAXISO),TMPISO(MAXISO),SNISO(MAXISO),SBISO(MAXISO), + 2 GIR(MAXISO),DENMIX(MAXMIX) + LOGICAL MASKI(MAXISO) + CHARACTER(LEN=12) SHINA(MAXISO) + CHARACTER(LEN=8) HLIB(MAXISO,4),HVECT(MAXED) + CHARACTER(LEN=64) HNAME(MAXLIB) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + TYPE(C_PTR) JPLIB + INTEGER ISTATE(NSTATE) +*---- +* RECOVER STATE-VECTOR INFORMATION +*---- + CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) + NBISO=ISTATE(2) + NGRO=ISTATE(3) + NL=ISTATE(4) + ITRANC=ISTATE(5) + NLIB=ISTATE(8) + NCOMB=ISTATE(12) + NEDMAC=ISTATE(13) + NBMIX=ISTATE(14) + IF(NBISO.GT.MAXISO) CALL XABORT('LIBINF: MAXISO OVERFLOW.') + IF(NLIB.GT.MAXLIB) CALL XABORT('LIBINF: MAXLIB OVERFLOW(1).') + IF(NEDMAC.GT.MAXED) CALL XABORT('LIBINF: MAXED OVERFLOW(1).') + IF(NBMIX.GT.MAXMIX) CALL XABORT('LIBINF: MAXMIX OVERFLOW.') +*---- +* RECOVER ISOTOPIC INFORMATION +*---- + CALL LCMGET(IPLIB,'ISOTOPESUSED',ISONAM) + CALL LCMLEN(IPLIB,'ISOTOPERNAME',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGET(IPLIB,'ISOTOPERNAME',ISONRF) + ELSE + CALL LCMGET(IPLIB,'ISOTOPESUSED',ISONRF) + ENDIF + HLIB(NBISO,:4)=' ' + ILLIB(:NBISO)=0 + CALL LCMLEN(IPLIB,'ILIBRARYTYPE',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGTC(IPLIB,'ILIBRARYTYPE',8,NBISO,HLIB(:NBISO,1)) + CALL LCMGET(IPLIB,'ILIBRARYINDX',ILLIB) + ENDIF + CALL LCMLEN(IPLIB,'ISOTOPESNTFG',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGET(IPLIB,'ISOTOPESNTFG',NTFG) + CALL LCMGTC(IPLIB,'ISOTOPESCOH',8,NBISO,HLIB(:NBISO,2)) + CALL LCMGTC(IPLIB,'ISOTOPESINC',8,NBISO,HLIB(:NBISO,3)) + ELSE + NTFG(:NBISO)=0 + HLIB(:NBISO,2)=' ' + HLIB(:NBISO,3)=' ' + ENDIF + CALL LCMLEN(IPLIB,'ISOTOPESRESK',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGTC(IPLIB,'ISOTOPESRESK',8,NBISO,HLIB(:NBISO,4)) + ELSE + HLIB(:NBISO,4)=' ' + ENDIF + CALL LCMLEN(IPLIB,'ISOTOPESHIN',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGTC(IPLIB,'ISOTOPESHIN',12,NBISO,SHINA) + ELSE + SHINA(:NBISO)=' ' + ENDIF + CALL LCMLEN(IPLIB,'ISOTOPESSHI',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGET(IPLIB,'ISOTOPESSHI',LSHI) + ELSE + LSHI(:NBISO)=0 + ENDIF + CALL LCMLEN(IPLIB,'ISOTOPESNIR',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGET(IPLIB,'ISOTOPESGIR',GIR) + CALL LCMGET(IPLIB,'ISOTOPESNIR',NIR) + ELSE + GIR(:NBISO)=1.0 + NIR(:NBISO)=0 + ENDIF + CALL LCMGET(IPLIB,'ISOTOPESDENS',DENISO) + CALL LCMGET(IPLIB,'ISOTOPESMIX',ISOMIX) + CALL LCMLEN(IPLIB,'ISOTOPESTEMP',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGET(IPLIB,'ISOTOPESTEMP',TMPISO) + ELSE + TMPISO(:NBISO)=0.0 + ENDIF + CALL LCMLEN(IPLIB,'ISOTOPESTODO',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGET(IPLIB,'ISOTOPESTODO',IEVOL) + ELSE + IEVOL(:NBISO)=0 + ENDIF + CALL LCMLEN(IPLIB,'ISOTOPESTYPE',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGET(IPLIB,'ISOTOPESTYPE',ITYP) + ELSE + ITYP(:NBISO)=1 + ENDIF + SNISO(:NBISO)=0.0 + SBISO(:NBISO)=0.0 + JPLIB=LCMGID(IPLIB,'ISOTOPESLIST') + DO IIISO=1,NBISO + CALL LCMLEL(JPLIB,IIISO,ILONG,ITYLCM) + MASKI(IIISO)=ILONG.NE.0 + ENDDO +*---- +* RECOVER MIXTURES STATES +*---- + CALL LCMLEN(IPLIB,'MIXTUREGAS',ILENG,ITYLCM) + IF(ILENG.EQ.NBMIX) THEN + CALL LCMGET(IPLIB,'MIXTUREGAS',KGAS) + ELSE + KGAS(:NBMIX)=0 + ENDIF +*---- +* UNSET MIXTURES DENSITIES +*---- + DENMIX(:MAXMIX)=-1.0 +*---- +* RECOVER EXTRA VECTOR EDIT NAMES +*---- + IF(NEDMAC.GT.0) THEN + CALL LCMGTC(IPLIB,'ADDXSNAME-P0',8,NEDMAC,HVECT) + ENDIF +*---- +* RECOVER EXTERNAL CROSS-SECTION LIBRARY NAMES +*---- + IF(NLIB.GT.0) THEN + CALL LCMGTC(IPLIB,'ILIBRARYNAME',64,NLIB,HNAME) + ENDIF + RETURN + END diff --git a/Dragon/src/LIBINP.f b/Dragon/src/LIBINP.f new file mode 100644 index 0000000..13817d3 --- /dev/null +++ b/Dragon/src/LIBINP.f @@ -0,0 +1,855 @@ +*DECK LIBINP + SUBROUTINE LIBINP (MAXMIX,MAXED,MAXISO,IPLIB,INDREC,IMPX,NBISO, + 1 NGRO,NGT,NL,ITRANC,IPROB,ITIME,NLIB,NGF,IGRMAX,NDEPL,NCOMB, + 2 NEDMAC,NBMIX,NRES,IPROC,IMAC,NDEL,ISOADD,MAXISM,HVECT,IPRECI, + 3 SVDEPS,STERN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read the information related to microscopic cross section libraries. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input/output +* MAXMIX maximum value of NBMIX. +* MAXED maximum value of NEDMAC. +* MAXISO maximum number of isotopes permitted. +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* INDREC type of action: +* =1 a new microlib is created; =2 the microlib is updated; +* =3 a read-only macrolib is copied in the microlib. +* IMPX print flag. +* NBISO number of isotopes present in the calculation domain. +* NGRO number of energy groups. +* NGT number of energy groups to test. +* NL number of Legendre orders required in the calculation. +* NL=1 (for isotropic scattering) or higher. +* ITRANC type of transport correction: =0 no transport correction +* =1 Apollo type transport correction; =2 recover from +* library; =3 WIMS-D type; =4 leakage correction alone. +* IPROB adjoint macrolib flag: +* =0 direct problem; =1 adjoint problem. +* ITIME MATXS type of fission spectrum: +* =1 steady-state; =2 prompt. +* NLIB number of cross-section libraries. +* NGF number of fast groups without self-shielding. +* IGRMAX maximum group index with self-shielding. +* NDEPL number of depleting isotopes (used by EVO:). +* NCOMB number of depleting mixtures (used by EVO:). +* NEDMAC number of extra vector edits. +* NBMIX number of mixtures defined in the microlib. +* NRES number of resonant mixtures (used by SHI:, TONE: or USS:). +* IPROC type of microlib processing: +* =-1: skip temperature/dilution interpolation; +* =0: perform temperature/dilution interpolation; +* =1: perform temperature interpolation and compute physical +* probability tables; +* =2: perform temperature interpolation and build a +* temperature-independent microlib; +* =3: perform temperature interpolation and compute calendf- +* type mathematical probability tables based on bin-type +* cross-sections for total cross sections; +* =4: compute slowing-down correlated probability tables. +* =5: perform temperature interpolation and compute calendf- +* type mathematical probability tables based on bin-type +* cross-sections for all available cross-sections types. +* =6: compute orthogonal bases for the resonance spectrum +* expansion (RSE) method. +* IMAC macrolib construction flag: +* =0 do not compute an embedded macrolib; +* =1 compute an embedded macrolib. +* NDEL number of precursor groups for delayed neutrons. +* ISOADD flag to complete the depletion chain: +* =0 complete; =1 do not complete. +* MAXISM maximum number of isotopes per mixture. +* HVECT matxs names of the extra vector edits. +* IPRECI accuracy index for probability tables in CALENDF. +* SVDEPS rank accuracy of the singular value decomposition. +* STERN Sternheimer flag (=0/1: off/on). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + INTEGER MAXMIX,MAXED,MAXISO,INDREC,IMPX,NBISO,NGRO,NGT,NL,ITRANC, + > IPROB,ITIME,NLIB,NGF,IGRMAX,NDEPL,NCOMB,NEDMAC,NBMIX,NRES,IPROC, + > IMAC,NDEL,ISOADD,MAXISM,IPRECI,STERN + REAL SVDEPS + CHARACTER*(*) HVECT(MAXED) +*---- +* LOCAL PARAMETERS +*---- + PARAMETER (IOUT=6,NHOBL=18,MAXPAR=5,MAXLIB=20,NSTATE=40, + > MAXTRA=10000) + TYPE(C_PTR) JPLIB + DOUBLE PRECISION DBLINP + CHARACTER TEXT4*4,TEXT12*12,HOBL(NHOBL)*8,HSMG*131,NAMFIL*64, + > NAMLBT*8,NAMLCM*12,NAMMY*12 + LOGICAL LNEW,EMPTY,LCM,LSET + INTEGER KCHAR(2),ISTATE(NSTATE) + REAL TMPDAY(3) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ISOMIX,NTFG,LSHI,NIR,ILLIB, + > IEVOL,ITYP,KGAS + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISONAM,ISONRF + REAL, ALLOCATABLE, DIMENSION(:) :: DENISO,DENMIX,TMPISO,SNISO, + > SBISO,GIR,TMPMIX,GSN,GSB + LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASK,MASKI,MASKL + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:,:) :: HLIB + CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: SHINA + CHARACTER(LEN=64), ALLOCATABLE, DIMENSION(:) :: HNAME +*---- +* DATA STATEMENTS +*---- + SAVE HOBL + DATA HOBL /'NFTOT ','NG ','N2N ','N3N ', + > 'N4N ','NA ','NP ','N2A ', + > 'NNP ','ND ','NT ','NX ', + > 'TRANC ','BSTC ','BSTR ','CSTC ', + > 'CSTR ','H-FACTOR'/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(ISONAM(3,MAXISO),ISONRF(3,MAXISO),ISOMIX(MAXISO), + > NTFG(MAXISO),LSHI(MAXISO),NIR(MAXISO),ILLIB(MAXISO),I + > EVOL(MAXISO),ITYP(MAXISO),KGAS(MAXMIX)) + ALLOCATE(DENISO(MAXISO),DENMIX(MAXMIX),TMPISO(MAXISO), + > SNISO(MAXISO),SBISO(MAXISO),GIR(MAXISO),TMPMIX(MAXMIX)) + ALLOCATE(MASK(MAXMIX),MASKI(MAXISO)) + ALLOCATE(HNAME(MAXLIB)) + ALLOCATE(HLIB(MAXISO,4),SHINA(MAXISO)) +*---- +* INITIALIZATIONS. +*---- + KEVOL=0 + IF((NGT.NE.0).AND.(NGT.NE.NGRO)) THEN + WRITE(HSMG,400) NGT,NGRO + CALL XABORT(HSMG) + ENDIF + IF((INDREC.EQ.2).AND.(NBISO.GT.0)) THEN +* THE LIBRARY IS UPDATED. READ OLD LIBRARY INFORMATION. + CALL LIBINF(IPLIB,MAXISO,MAXLIB,MAXED,MAXMIX,NBISO,NGRO,NL, + 1 ITRANC,NLIB,NCOMB,NEDMAC,NBMIX,ISONAM,ISONRF,ISOMIX,DENISO, + 2 TMPISO,SHINA,SNISO,SBISO,NTFG,LSHI,GIR,NIR,MASKI,HLIB,IEVOL, + 3 ITYP,ILLIB,KGAS,DENMIX,HVECT,HNAME) + NNMIX=NBMIX + DO 20 IIIMIX=1,MAXMIX + DO 10 IIISO=1,NBISO + IF(ISOMIX(IIISO).EQ.IIIMIX) THEN + TMPMIX(IIIMIX)=TMPISO(IIISO) + GO TO 20 + ENDIF + 10 CONTINUE + TMPMIX(IIIMIX)=-1.0 + 20 CONTINUE + ELSE + NBISO=0 + NELSN=0 + NNMIX=0 + DO IIIMIX=1,MAXMIX + DENMIX(IIIMIX)=-1.0 + TMPMIX(IIIMIX)=-1.0 + KGAS(IIIMIX)=0 + ENDDO + ENDIF +*---- +* READ THE SPECIFICATION FOR EACH ISOTOPE. +*---- + TEXT12='MIXS' + JLIB=0 + LSET=.TRUE. + 40 IF(TEXT12.EQ.'MIXS') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DBLINP) + IF((INDIC.EQ.3).AND.(TEXT4.EQ.';')) THEN + MASKI(:NBISO)=.TRUE. + GO TO 100 + ENDIF + IF((INDIC.NE.3).OR.(TEXT4.NE.'LIB:')) + > CALL XABORT('LIBINP: KEYWORD LIB: EXPECTED') + CALL REDGET(INDIC,NITMA,FLOTT,NAMLBT,DBLINP) + IF(INDIC.NE.3) + > CALL XABORT('LIBINP: CHARACTER LIBRARY NAME REQUIRED.') + IF( (NAMLBT.NE.'MATXS' ).AND.(NAMLBT.NE.'MATXS2').AND. + > (NAMLBT.NE.'APLIB1').AND.(NAMLBT.NE.'APLIB2').AND. + > (NAMLBT.NE.'APLIB3').AND.(NAMLBT.NE.'APXSM' ).AND. + > (NAMLBT.NE.'DRAGON').AND.(NAMLBT.NE.'WIMSAECL').AND. + > (NAMLBT.NE.'WIMSD4').AND.(NAMLBT.NE.'WIMSE' ).AND. + > (NAMLBT.NE.'NDAS' ).AND.(NAMLBT.NE.'MICROLIB')) THEN + WRITE(HSMG,'(29HLIBINP: INVALID LIBRARY TYPE ,A8)') NAMLBT + CALL XABORT(HSMG) + ENDIF + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + IF((INDIC.NE.3).OR.(TEXT12.NE.'FIL:')) + > CALL XABORT('LIBINP: FIL: EXPECTED.') + NAMFIL=' ' + CALL REDGET(INDIC,NITMA,FLOTT,NAMFIL,DBLINP) + IF(INDIC.NE.3) CALL XABORT('LIBINP: CHARACTER DATA EXPECTED'// + > '(1).') + CALL LIBNRG(IPLIB,NAMLBT,NAMFIL,NGRO,NGT) + IF(NLIB.GT.0) CALL LCMGTC(IPLIB,'ILIBRARYNAME',64,NLIB,HNAME) + DO 50 ILIB=1,NLIB + IF(HNAME(ILIB).EQ.NAMFIL) THEN + JLIB=ILIB + GO TO 60 + ENDIF + 50 CONTINUE + NLIB=NLIB+1 + IF(NLIB.GT.MAXLIB) CALL XABORT('LIBINP: MAXLIB OVERFLOW.') + HNAME(NLIB)=NAMFIL + CALL LCMPTC(IPLIB,'ILIBRARYNAME',64,NLIB,HNAME) + JLIB=NLIB + 60 CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + IF(INDIC.NE.3) CALL XABORT('LIBINP: CHARACTER DATA EXPECTED'// + > '(2).') + GO TO 40 + ELSE IF(TEXT12.EQ.';') THEN + GO TO 100 + ELSE IF(TEXT12.EQ.'MIX') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + IF(INDIC.EQ.1) THEN + NNMIX=NITMA + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + ELSE + NNMIX=NNMIX+1 + ENDIF + IF(NNMIX.GT.MAXMIX) THEN + CALL XABORT('LIBINP: MIX NUMBER LARGER THAN MAXMIX.') + ELSE IF(NNMIX.LE.0) THEN + CALL XABORT('LIBINP: MIX NUMBER .LE. 0.') + ENDIF + NBMIX=MAX(NNMIX,NBMIX) + IF(INDIC.EQ.3) THEN + CALL LCMLEN(IPLIB,'MACROLIB',ILONG,ITYLCM) + IF((ILONG.NE.0).AND.LSET) THEN +* perform a reset of the macrolib to be safe + CALL LCMSIX(IPLIB,'MACROLIB',1) + CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) + ISTATE(4)=0 + CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMSIX(IPLIB,' ',2) + MASKI(:NBISO)=.TRUE. + LSET=.FALSE. + ENDIF + IF(TEXT12.EQ.'COMB') THEN +*---- +* THIS MIXTURE IS A COMBINATION OF OTHER MIXTURES. +*---- + CALL LCMINF(IPLIB,NAMLCM,NAMMY,EMPTY,ILONG,LCM) + VOLTOT=0.0 + 70 VOLFRA=0.0 + MIXCMB=0 + CALL REDGET(INDIC,MIXCMB,FLOTT,TEXT12,DBLINP) + IF(INDIC.EQ.3) THEN + IF(VOLTOT.EQ.0.0) CALL XABORT('LIBINP: TOTAL VOLUME F' + > //'RACTION OF 0.0 IS ILLEGAL.') + GO TO 40 + ENDIF + IF(INDIC.EQ.2) CALL XABORT('LIBINP: MIXTURE NUMBER MISSI' + > //'NG FOR COMBINATION.') + CALL REDGET(INDIC,NITMA,VOLFRA,TEXT12,DBLINP) + IF((INDIC.EQ.1).OR.(INDIC.EQ.3)) CALL XABORT('LIBINP: VO' + > //'LUME FRACTION MISSING FOR COMBINATION.') + IF(VOLFRA.EQ.0.0) CALL XABORT('LIBINP: INDIVIDUAL VOLUME' + > //' FRACTION OF 0.0 IS ILLEGAL.') + CALL LIBCMB(MAXMIX,MAXISO,NBISO,NEWISO,NNMIX,MIXCMB, + 1 VOLTOT,VOLFRA,DENMIX,ISONAM,ISONRF,SHINA,ISOMIX,HLIB, + 2 ILLIB,DENISO,TMPISO,LSHI,SNISO,SBISO,NTFG,NIR,GIR,MASKI, + 3 IEVOL,ITYP) + GO TO 70 + ELSE + WRITE(HSMG,'(41HLIBINP: ONLY COMB KEYWORD CAN FOLLOW MIXT, + > 12HURE NUMBER (,A,8H READED))') TEXT12 + CALL XABORT(HSMG) + ENDIF + ELSE + IF(INDIC.NE.2) CALL XABORT('LIBINP: REAL NUMBER EXPECTED.') + TMPMIX(NNMIX)=FLOTT + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + IF(INDIC.EQ.2) THEN + IF(DENMIX(NNMIX).EQ.-1.0) THEN + CALL LIBCON(IPLIB,NNMIX,NBISO,ISOMIX,DENISO, + > DENMIX(NNMIX),2) + ENDIF + DENMIX(NNMIX)=FLOTT + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + ENDIF + IF(INDIC.NE.3) CALL XABORT('LIBINP: CHARACTER DATA EXPECT'// + > 'ED(4).') + IF(TEXT12.EQ.'NOEV') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + IF(INDIC.NE.3) CALL XABORT('LIBINP: CHARACTER DATA EXPE'// + > 'CTED(5).') + KEVOL=1 + ELSE IF(TEXT12.EQ.'EVOL') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + IF(INDIC.NE.3) CALL XABORT('LIBINP: CHARACTER DATA EXPE'// + > 'CTED(6).') + KEVOL=2 + ELSE + KEVOL=0 + ENDIF + IF(TEXT12.EQ.'NOGAS') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + IF(INDIC.NE.3) CALL XABORT('LIBINP: CHARACTER DATA EXPE'// + > 'CTED(7).') + KGAS(NNMIX)=0 + ENDIF + IF(TEXT12.EQ.'GAS') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + IF(INDIC.NE.3) CALL XABORT('LIBINP: CHARACTER DATA EXPE'// + > 'CTED(8).') + KGAS(NNMIX)=1 + ENDIF + IF((TEXT12.EQ.'MIX').OR.(TEXT12.EQ.'MIXS').OR. + > (TEXT12.EQ.';')) THEN + DO 80 IISO=1,NBISO + IF(ISOMIX(IISO).EQ.NNMIX) THEN + TMPISO(IISO)=TMPMIX(NNMIX) + MASKI(IISO)=.TRUE. + ENDIF + 80 CONTINUE + ENDIF + ENDIF + GO TO 40 + ENDIF + READ(TEXT12,'(2A4)') KCHAR(1),KCHAR(2) + DO 81 I=1,NBISO + IF((KCHAR(1).EQ.ISONAM(1,I)).AND.(KCHAR(2).EQ.ISONAM(2,I)).AND. + > (NNMIX.EQ.ISOMIX(I))) THEN +* UPDATE AN EXISTING ISOTOPE. + NEWISO=I + LNEW=.FALSE. + GO TO 82 + ENDIF + 81 CONTINUE + LNEW=.TRUE. + NBISO=NBISO+1 + NEWISO=NBISO + IF(NBISO.GT.MAXISO) THEN + WRITE(6,'(15H LIBINP: NBISO=,I6,8H MAXISO=,I6)') NBISO,MAXISO + CALL XABORT('LIBINP: MAXISO TOO SMALL.') + ENDIF + READ(TEXT12,'(3A4)') (ISONAM(I0,NBISO),I0=1,3) + READ(TEXT12,'(3A4)') (ISONRF(I0,NBISO),I0=1,3) + SHINA(NBISO)=' ' + HLIB(NBISO,2:4)=' ' + NTFG(NBISO)=0 + LSHI(NBISO)=0 + GIR(NBISO)=1.0 + NIR(NBISO)=0 + ISOMIX(NBISO)=NNMIX + DENISO(NBISO)=0.0 + SNISO(NBISO)=1.0E10 + SBISO(NBISO)=1.0E10 + IEVOL(NBISO)=KEVOL + ITYP(NBISO)=1 +* + 82 MASKI(NEWISO)=.TRUE. + HLIB(NEWISO,1)=NAMLBT + ILLIB(NEWISO)=JLIB + TMPISO(NEWISO)=TMPMIX(NNMIX) + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + IF(INDIC.EQ.3.AND.TEXT12.EQ.'=') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + IF(INDIC.EQ.3) THEN + READ(TEXT12,'(3A4)') (ISONRF(I0,NEWISO),I0=1,3) + ELSE + CALL XABORT('LIBINP: LIBRARY ISOTOPE NAME MISSING AFTER =') + ENDIF + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + ENDIF + IF(INDIC.NE.2) THEN + CALL XABORT('LIBINP: ISOTOPIC DENSITY OR WEIGHT PERCENT EXPECT' + > //'ED.') + ENDIF + IF((.NOT.LNEW).AND.(DENMIX(NNMIX).NE.-1.0).AND.(ABS(DENISO(NEWISO) + 1 -FLOTT).GT.1.0E-4)) THEN + CALL XABORT('LIBINP: PERTURBATION OF THE WEIGHT PERCENTS IS FOR' + 1 //'BIDDEN.') + ENDIF + DENISO(NEWISO)=FLOTT + 90 CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + IF(INDIC.EQ.2) THEN + SNISO(NEWISO)=FLOTT + SBISO(NEWISO)=FLOTT + ELSE IF(INDIC.EQ.1) THEN + LSHI(NEWISO)=NITMA + NRES=MAX(NRES,NITMA) + IF(IPROC.EQ.3) THEN + NIR(NEWISO)=1 + GIR(NEWISO)=-998.0 + ELSE IF(IPROC.EQ.4) THEN + NIR(NEWISO)=1 + GIR(NEWISO)=-999.0 + ELSE IF(IPROC.EQ.5) THEN + NIR(NEWISO)=1 + GIR(NEWISO)=-1000.0 + ELSE IF(IPROC.EQ.6) THEN + NIR(NEWISO)=1 + GIR(NEWISO)=-1001.0 + ENDIF + ELSE IF(TEXT12.EQ.'INF') THEN + SNISO(NEWISO)=1.0E10 + SBISO(NEWISO)=1.0E10 + ELSE IF(TEXT12.EQ.'SHIB') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + IF(INDIC.NE.3) CALL XABORT('LIBINP: CHARACTER DATA EXPECTED'// + > '(9).') + SHINA(NEWISO)=TEXT12 + ELSE IF(TEXT12.EQ.'THER') THEN + CALL REDGET(INDIC,NTFG(NEWISO),FLOTT,TEXT12,DBLINP) + IF(INDIC.NE.1) CALL XABORT('LIBINP: NUMBER OF THERMALIZED '// + > 'GROUPS REQUIRED.') + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + IF(INDIC.NE.3) CALL XABORT('LIBINP: CHARACTER DATA EXPECTED'// + > '(10).') + HLIB(NEWISO,3)=TEXT12(:8) + ELSE IF(TEXT12.EQ.'TCOH') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + IF(INDIC.NE.3) CALL XABORT('LIBINP: CHARACTER DATA EXPECTED'// + > '(11).') + HLIB(NEWISO,2)=TEXT12(:8) + ELSE IF(TEXT12.EQ.'RESK') THEN + TEXT12='RESK' + HLIB(NEWISO,4)=TEXT12(:8) + ELSE IF(TEXT12.EQ.'DBYE') THEN + CALL REDGET(INDIC,NITMA,TMPISO(NEWISO),TEXT12,DBLINP) + IF(INDIC.NE.2) CALL XABORT('LIBINP: REAL DATA EXPECTED.') + ELSE IF(TEXT12.EQ.'CORR') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + IF(INDIC.NE.1) CALL XABORT('LIBINP: INTEGER DATA EXPECTED(2).') + LSHI(NEWISO)=-NITMA + NRES=MAX(NRES,NITMA) + IF(IPROC.EQ.3) THEN + NIR(NEWISO)=1 + GIR(NEWISO)=-998.0 + ELSE IF(IPROC.EQ.4) THEN + NIR(NEWISO)=1 + GIR(NEWISO)=-999.0 + ELSE IF(IPROC.EQ.5) THEN + NIR(NEWISO)=1 + GIR(NEWISO)=-1000.0 + ELSE IF(IPROC.EQ.6) THEN + NIR(NEWISO)=1 + GIR(NEWISO)=-1001.0 + ENDIF + ELSE IF(TEXT12.EQ.'IRSET') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + IF(INDIC.EQ.2) THEN + GIR(NEWISO)=FLOTT + IF((IPROC.EQ.3).AND.(FLOTT.NE.1.0)) CALL XABORT('LIBINP: P' + > //'T MAIN OPTION NOT EXPECTED.') + IF((IPROC.EQ.4).AND.(FLOTT.NE.1.0)) CALL XABORT('LIBINP: P' + > //'TSL MAIN OPTION NOT EXPECTED.') + ELSE IF(INDIC.EQ.3) THEN + IF(TEXT12.EQ.'PT') THEN + IF(IPROC.NE.3) CALL XABORT('LIBINP: PT MAIN OPTION NOT ' + > //'SET.') + GIR(NEWISO)=-998.0 + ELSE IF(TEXT12.EQ.'PTSL') THEN + IF(IPROC.NE.4) CALL XABORT('LIBINP: PTSL MAIN OPTION NO' + > //'T SET.') + GIR(NEWISO)=-999.0 + ELSE IF(TEXT12.EQ.'PTMC') THEN + IF(IPROC.NE.5) CALL XABORT('LIBINP: PTMC MAIN OPTION NO' + > //'T SET.') + GIR(NEWISO)=-1000.0 + ELSE IF(TEXT12.EQ.'RSE') THEN + IF(IPROC.NE.6) CALL XABORT('LIBINP: RSE MAIN OPTION NOT' + > //' SET.') + GIR(NEWISO)=-1001.0 + ELSE + CALL XABORT('LIBINP: PT, PTSL OR PTMC EXPECTED.') + ENDIF + ELSE + CALL XABORT('LIBINP: REAL OR CHARACTER DATA EXPECTED.') + ENDIF + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + IF(INDIC.EQ.1) THEN + IF((NITMA.LT.0).OR.(NITMA.GT.NGRO)) CALL + > XABORT('LIBINP: INVALID VALUE OF NIR.') + NIR(NEWISO)=NITMA + ELSE IF((INDIC.EQ.3).AND.(TEXT12.EQ.'NONE')) THEN + NIR(NEWISO)=NGRO+1 + ELSE + CALL XABORT('LIBINP: NONE OR INTEGER DATA EXPECTED.') + ENDIF + ELSE IF(TEXT12.EQ.'NOEV') THEN + IEVOL(NEWISO)=1 + ELSE IF(TEXT12.EQ.'EVOL') THEN + IEVOL(NEWISO)=2 + ELSE IF(TEXT12.EQ.'SAT') THEN + IEVOL(NEWISO)=3 + ELSE + IF(INDIC.NE.3) CALL XABORT('LIBINP: CHARACTER DATA EXPECTED'// + > '(12).') + GO TO 40 + ENDIF + GO TO 90 +*---- +* INCLUDE SOME DEFAULT EXTRA EDITS. +*---- + 100 IF((NGRO.EQ.0).OR.(NGT.EQ.0)) CALL XABORT('LIBINP: NUMBER OF GRO' + > //'UPS REQUIRED.') + DO 120 I=1,NHOBL + DO 110 IED=1,NEDMAC + IF(HVECT(IED).EQ.HOBL(I)) GO TO 120 + 110 CONTINUE + NEDMAC=NEDMAC+1 + IF(NEDMAC.GT.MAXED) CALL XABORT('LIBINP: TOO MANY EXTRA EDITS R' + > //'EQUESTED.') + HVECT(NEDMAC)=HOBL(I) + 120 CONTINUE +*---- +* ADD THE MISSING ISOTOPES FROM THE DEPLETION CHAIN. +*---- + IF((NDEPL.NE.0).AND.(ISOADD.EQ.0)) THEN + NBISOL=NBISO + CALL LCMSIX(IPLIB,'DEPL-CHAIN',1) + CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) + IF(ISTATE(1).NE.NDEPL) CALL XABORT('LIBINP: INVALID NUMBER OF' + > //' DEPLETING ISOTOPES.') + NFISS=ISTATE(2) + NSUPF=ISTATE(5) + NSUPS=ISTATE(7) + NREAC=ISTATE(8) + NPAR=ISTATE(9) + CALL LIBEAD(IPLIB,MAXISO,MAXMIX,IMPX,NDEPL,NFISS,NSUPS, + 1 NREAC,NPAR,NBISO,ISONAM,ISONRF,HLIB,ILLIB,ISOMIX,TMPISO, + 2 IEVOL,ITYP,NCOMB) + CALL LCMSIX(IPLIB,' ',2) +* + DO 140 ISOT=NBISOL+1,NBISO + SNISO(ISOT)=1.0E10 + SBISO(ISOT)=1.0E10 + DENISO(ISOT)=0.0 + NTFG(ISOT)=0 + SHINA(ISOT)=' ' + HLIB(ISOT,2:4)=' ' + LSHI(ISOT)=0 + GIR(ISOT)=1.0 + NIR(ISOT)=0 + MASKI(ISOT)=.TRUE. + 140 CONTINUE + ENDIF +*---- +* SET THE MIXTURE MASKS. +*---- + DO 170 I=1,NBMIX + MASK(I)=.FALSE. + DO 150 JJ=1,NBISO + IF((ISOMIX(JJ).EQ.I).AND.MASKI(JJ)) THEN + MASK(I)=.TRUE. + GO TO 160 + ENDIF + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE +*---- +* FIND AND NAME DISTINCT ISOTOPES. +*---- + DO 200 I=1,NBISO + IF(MASKI(I).AND.(ILLIB(I).NE.0)) THEN +* CATENATE THE 4-DIGIT MIXTURE SUFFIX. + DO 190 J=1,I-1 + IF((ISONAM(1,I).NE.ISONAM(1,J)).OR.(ISONAM(2,I).NE.ISONAM(2,J))) + > GO TO 190 + IF((ISONRF(1,I).NE.ISONRF(1,J)).OR.(ISONRF(2,I).NE.ISONRF(2,J)) + > .OR.(ISONRF(3,I).NE.ISONRF(3,J))) GO TO 190 + IF(SHINA(I).NE.SHINA(J)) GO TO 190 + IF((LSHI(I).NE.0).AND.(LSHI(J).NE.0).AND.(DENISO(I).EQ.0.0) + > .AND.(DENISO(J).NE.0.0)) GO TO 190 + IF((LSHI(I).NE.0).AND.(LSHI(J).NE.0).AND.(DENISO(I).NE.0.0) + > .AND.(DENISO(J).EQ.0.0)) GO TO 190 + DO 180 IOP=1,4 + IF(HLIB(I,IOP).NE.HLIB(J,IOP)) GO TO 190 + 180 CONTINUE + IF(ILLIB(I).NE.ILLIB(J)) GO TO 190 + IF((NTFG(I).NE.NTFG(J)).OR.(GIR(I).NE.GIR(J)).OR. + > (NIR(I).NE.NIR(J)).OR.(TMPISO(I).NE.TMPISO(J))) GO TO 190 + IF(((LSHI(I).EQ.0).AND.(LSHI(J).EQ.0)) + > .OR.((IPROC.NE.0).AND.(LSHI(I).EQ.LSHI(J)))) THEN + MASKI(I)=.FALSE. + WRITE(TEXT4,'(I4.4)') ISOMIX(J) + GO TO 195 + ENDIF + 190 CONTINUE + WRITE(TEXT4,'(I4.4)') ISOMIX(I) + 195 READ(TEXT4,'(A4)') ISONAM(3,I) + ENDIF + 200 CONTINUE +* + IF(IMPX.GT.1) THEN + WRITE (IOUT,320) + DO 210 I=1,NBISO + IF(ISOMIX(I).EQ.0) GO TO 210 + DZN=DENMIX(ISOMIX(I)) + IF(DZN.EQ.-1.0) THEN + WRITE (IOUT,330) I,(ISONAM(I0,I),I0=1,3),(ISONRF(I0,I), + > I0=1,3),HLIB(I,1),ILLIB(I),ISOMIX(I),DENISO(I), + > TMPISO(I),SNISO(I),LSHI(I),SHINA(I),NTFG(I),HLIB(I,3), + > HLIB(I,4),HLIB(I,2) + ELSE + WRITE (IOUT,340) I,(ISONAM(I0,I),I0=1,3),(ISONRF(I0,I), + > I0=1,3),HLIB(I,1),ILLIB(I),ISOMIX(I),DZN,DENISO(I), + > TMPISO(I),SNISO(I),LSHI(I),SHINA(I),NTFG(I),HLIB(I,3), + > HLIB(I,4),HLIB(I,2) + ENDIF + 210 CONTINUE + ENDIF +*---- +* READ OLD DILUTIONS IF PRESENT. +*---- + NGIS=NGRO*NBISO + ALLOCATE(GSN(NGIS),GSB(NGIS)) + GSN(:NGIS)=1.0E10 + GSB(:NGIS)=1.0E10 + CALL LCMLEN(IPLIB,'ISOTOPESDSN',NELSN,ITYLCM) + IF(NELSN.GT.0) THEN + CALL LCMGET(IPLIB,'ISOTOPESDSN',GSN) + CALL LCMGET(IPLIB,'ISOTOPESDSB',GSB) + ENDIF + ILOCSN=0 + ILOCSB=0 + DO 215 ISO=1,NBISO + IF(SNISO(ISO).GT.0.0) THEN + GSN(ILOCSN+1:ILOCSN+NGRO)=SNISO(ISO) + GSB(ILOCSB+1:ILOCSB+NGRO)=SBISO(ISO) + ENDIF + ILOCSN=ILOCSN+NGRO + ILOCSB=ILOCSB+NGRO + 215 CONTINUE +*---- +* SAVE THE LIBRARY SPECIFIC INFORMATION. +*---- + NBMIX=0 + DO 220 I=1,NBISO + NBMIX=MAX(NBMIX,ISOMIX(I)) + 220 CONTINUE + IF(NBMIX.GT.MAXMIX) CALL XABORT('LIBINP: MAXMIX TOO SMALL.') + TEXT12='L_LIBRARY' + CALL LCMPTC(IPLIB,'SIGNATURE',12,TEXT12) + ISTATE(:NSTATE)=0 + ISTATE(1)=MAXMIX + ISTATE(2)=NBISO + ISTATE(3)=NGRO + ISTATE(4)=NL + ISTATE(5)=ITRANC + ISTATE(6)=IPROB + ISTATE(7)=ITIME + ISTATE(8)=NLIB + ISTATE(9)=MIN(NGF,NGRO+1) + ISTATE(10)=IGRMAX + ISTATE(11)=NDEPL + ISTATE(12)=NCOMB + ISTATE(13)=NEDMAC + ISTATE(14)=NBMIX + ISTATE(15)=NRES + ISTATE(17)=IPROC + ISTATE(18)=IMAC + ISTATE(19)=NDEL + ISTATE(20)=0 + ISTATE(21)=ISOADD + ISTATE(22)=MAXISM + ISTATE(23)=IPRECI + ISTATE(27)=STERN + CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMPUT(IPLIB,'ISOTOPESUSED',3*NBISO,3,ISONAM) + CALL LCMPUT(IPLIB,'ISOTOPERNAME',3*NBISO,3,ISONRF) + CALL LCMPUT(IPLIB,'ISOTOPESMIX',NBISO,1,ISOMIX) + CALL LCMPUT(IPLIB,'ISOTOPESTODO',NBISO,1,IEVOL) + CALL LCMPUT(IPLIB,'ISOTOPESTYPE',NBISO,1,ITYP) + IF(NLIB.GT.0) THEN + CALL LCMPTC(IPLIB,'ILIBRARYTYPE',8,NBISO,HLIB(:NBISO,1)) + CALL LCMPUT(IPLIB,'ILIBRARYINDX',NBISO,1,ILLIB) + CALL LCMPTC(IPLIB,'ISOTOPESCOH',8,NBISO,HLIB(:NBISO,2)) + CALL LCMPTC(IPLIB,'ISOTOPESINC',8,NBISO,HLIB(:NBISO,3)) + CALL LCMPTC(IPLIB,'ISOTOPESRESK',8,NBISO,HLIB(:NBISO,4)) + CALL LCMPUT(IPLIB,'ISOTOPESNTFG',NBISO,1,NTFG) + CALL LCMPTC(IPLIB,'ISOTOPESHIN',12,NBISO,SHINA) + CALL LCMPUT(IPLIB,'ISOTOPESSHI',NBISO,1,LSHI) + CALL LCMPUT(IPLIB,'ISOTOPESDSN',NGIS,2,GSN) + CALL LCMPUT(IPLIB,'ISOTOPESDSB',NGIS,2,GSB) + CALL LCMPUT(IPLIB,'ISOTOPESGIR',NBISO,2,GIR) + CALL LCMPUT(IPLIB,'ISOTOPESNIR',NBISO,1,NIR) + ENDIF + CALL LCMPUT(IPLIB,'ISOTOPESTEMP',NBISO,2,TMPISO) + IF(NEDMAC.GT.0) THEN + CALL LCMPTC(IPLIB,'ADDXSNAME-P0',8,NEDMAC,HVECT) + ENDIF + CALL LCMPUT(IPLIB,'MIXTUREGAS',NBMIX,1,KGAS) + DEALLOCATE(GSB,GSN) +*---- +* CHECK FOR DUPLICATE ALIAS. +*---- + DO 255 I=1,NBISO + IF(ISOMIX(I).EQ.0) GO TO 255 + DO 250 J=I+1,NBISO + IF((ISOMIX(I).EQ.ISOMIX(J)).AND.(ISONRF(1,I).EQ.ISONRF(1,J)) + 1 .AND.(ISONRF(2,I).EQ.ISONRF(2,J)) + 2 .AND.(ISONRF(3,I).EQ.ISONRF(3,J)).AND.(LSHI(I).NE.0)) THEN + WRITE(HSMG,390) (ISONAM(I1,I),I1=1,3),(ISONAM(I1,J),I1=1,3), + > (ISONRF(I1,I),I1=1,3),ISOMIX(I) + CALL XABORT(HSMG) + ENDIF + 250 CONTINUE + 255 CONTINUE +*---- +* READ AND INTERPOLATE IN THE MICROSCOPIC X-SECTIONS LIBRARIES. +*---- + IF(NGRO.EQ.0) CALL XABORT('LIBINP: NUMBER OF GROUPS NOT DEFINED.') + IF((IPROC.EQ.0).AND.(NLIB.GT.0)) THEN +* ------------------------------------ + CALL LIBLIB (IPLIB,NBISO,MASKI,IMPX) +* ------------------------------------ + ELSE IF((IPROC.GT.0).AND.(NLIB.GT.0)) THEN + CALL LIBSUB (MAXISO,MAXTRA,IPLIB,IPROC,NGRO,NBISO,NLIB,ISONAM, + 1 TMPISO,MASKI,IPRECI,SVDEPS,IMPX) + ELSE IF((IPROC.EQ.-1).AND.(NLIB.GT.0)) THEN + JPLIB=LCMLID(IPLIB,'ISOTOPESLIST',NBISO) + ENDIF + CALL LCMVAL(IPLIB,' ') +* + IF(IMPX.GT.0) THEN + CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) + ITRANC=ISTATE(5) + NGF=ISTATE(9) + IGRMAX=ISTATE(10) + NDEPL=ISTATE(11) + NBESP=ISTATE(16) + NDEL=ISTATE(19) + NFISS=ISTATE(20) + NPART=ISTATE(26) + STERN=ISTATE(27) + WRITE (IOUT,300) IMPX,IPROB,ITIME,NLIB,NGF,IGRMAX,NBISO,NBMIX, + 1 NRES,NCOMB,NEDMAC,NGRO,NL + WRITE (IOUT,305) ITRANC,NBESP,IPROC,IMAC,NDEL,NDEPL,NFISS, + 1 ISOADD,MAXISM,IPRECI,NPART,STERN + IF(IPROC.EQ.6) WRITE(IOUT,306) SVDEPS + IF(NEDMAC.GT.0) WRITE (IOUT,310) (I,HVECT(I),I=1,NEDMAC) + IF(NLIB.GT.0) THEN + WRITE(IOUT,315) + DO 260 ILIB=1,NLIB + WRITE(IOUT,'(1X,I4,4H -- ,A)') ILIB,HNAME(ILIB) + 260 CONTINUE + ENDIF + ENDIF +*---- +* COMPUTE AND STORE THE EFFECTIVE DENSITY FROM AWR AND MATERIAL DENSITY +*---- + DO 270 IMX=1,NBMIX + IF(MASK(IMX).AND.(DENMIX(IMX).GE.0.0)) THEN + CALL LIBCON(IPLIB,IMX,NBISO,ISOMIX,DENISO,DENMIX(IMX),1) + ENDIF + 270 CONTINUE + IF(IMPX.GT.0) THEN + WRITE (IOUT,370) + DO 280 I=1,NBISO + IF(ISOMIX(I).EQ.0) GO TO 280 + IF(MASK(ISOMIX(I))) THEN + WRITE (IOUT,380) I,(ISONAM(I0,I),I0=1,3),(ISONRF(I0,I), + > I0=1,3),HLIB(I,1),ILLIB(I),ISOMIX(I),DENISO(I), + > TMPISO(I),SNISO(I),LSHI(I),SHINA(I),NTFG(I), + > HLIB(I,3),HLIB(I,4),HLIB(I,2) + ENDIF + 280 CONTINUE + ENDIF + CALL LCMPUT(IPLIB,'ISOTOPESDENS',NBISO,2,DENISO) +*---- +* STORE MIXTURES DENSITIES +*---- + CALL LCMPUT(IPLIB,'MIXTURESDENS',NBMIX,2,DENMIX) +*---- +* COMPUTE THE MACROSCOPIC X-SECTIONS. +*---- + IF(IMAC.EQ.1) THEN + ALLOCATE(MASKL(NGRO)) + MASKL(:NGRO)=.TRUE. + ITSTMP=0 + TMPDAY(1)=0.0 + TMPDAY(2)=0.0 + TMPDAY(3)=0.0 + CALL LIBMIX(IPLIB,NBMIX,NGRO,NBISO,ISONAM,ISOMIX,DENISO,MASK, + > MASKL,ITSTMP,TMPDAY) + DEALLOCATE(MASKL) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(HNAME) + DEALLOCATE(MASKI,MASK) + DEALLOCATE(HLIB) + DEALLOCATE(TMPMIX,GIR,SBISO,SNISO,TMPISO,DENMIX,DENISO) + DEALLOCATE(KGAS,ITYP,IEVOL,ILLIB,NIR,LSHI,NTFG,ISOMIX, + > ISONRF,ISONAM) + RETURN +* + 300 FORMAT(/8H OPTIONS/8H -------/ + 1 7H IMPX ,I6,30H (0=NO PRINT/1=SHORT/2=MORE)/ + 2 7H IPROB ,I6,23H (0=DIRECT/1=ADJOINT)/ + 3 7H ITIME ,I6,28H (1=STEADY-STATE/2=PROMPT)/ + 4 7H NLIB ,I6,32H (NUMBER OF SETS OF LIBRARIES)/ + 5 7H NGF ,I6,48H (NUMBER OF FAST GROUP WITHOUT SELF-SHIELDING)/ + 6 7H IGRMAX,I6,41H (LAST GROUP INDEX WITH SELF-SHIELDING)/ + 7 7H NBISO ,I6,36H (NUMBER OF ISOTOPES OR MATERIALS)/ + 8 7H NBMIX ,I6,23H (NUMBER OF MIXTURES)/ + 9 7H NRES ,I6,40H (NUMBER OF SETS OF RESONANT MIXTURES)/ + 1 7H NCOMB ,I6,33H (NUMBER OF DEPLETING MIXTURES)/ + 2 7H NEDMAC,I6,34H (NUMBER OF CROSS SECTION EDITS)/ + 3 7H NGRO ,I6,28H (NUMBER OF ENERGY GROUPS)/ + 4 7H NL ,I6,30H (NUMBER OF LEGENDRE ORDERS)) + 305 FORMAT( + 1 7H ITRANC,I6,45H (0=NO TRANSPORT CORRECTION/1=APOLLO TYPE/2, + 2 57H=RECOVER FROM LIBRARY/3=WIMS-D TYPE/4=LEAKAGE CORRECTION)/ + 3 7H NBESP ,I6,47H (NUMBER OF ENERGY-DEPENDENT FISSION SPECTRA)/ + 4 7H IPROC ,I6,47H (-1=SKIP LIBRARY PROCESSING/0=DILUTION INTER, + 5 49HPOLATION/1=USE PHYSICAL TABLES/2=BUILD A DRAGLIB// + 6 17X,56H3=COMPUTE CALENDF TABLES/4=SLOWING-DOWN TABLES/5=ALL CAL, + 7 11HENDF/6=RSE)/ + 8 7H IMAC ,I6,45H (0=DO NOT/1=DO BUILD AN EMBEDDED MACROLIB)/ + 9 7H NDEL ,I6,31H (NUMBER OF PRECURSOR GROUPS)/ + 1 7H NDEPL ,I6,33H (NUMBER OF DEPLETING ISOTOPES)/ + 2 7H NFISS ,I6,48H (NUMBER OF FISSILE ISOTOPES WITH PYIELD DATA)/ + 3 7H ISOADD,I6,37H (0=COMPLETE BURNUP CHAIN/1=DO NOT)/ + 4 7H MAXISM,I6,40H (MAX. NUMBER OF ISOTOPES PER MIXTURE)/ + 5 7H IPRECI,I6,34H (CALENDF ACCURACY FLAG:1/2/3/4)/ + 6 7H NPART ,I6,34H (NUMBER OF COMPANION PARTICLES)/ + 7 7H STERN ,I6,47H (STERNHEIMER FLAG FOR CHARGED PARTICLES:0/1)) + 306 FORMAT(7H SVDEPS,1P,E10.3,27H (RANK ACCURACY OF THE SVD)) + 310 FORMAT(/45H CROSS SECTION EDIT NAME (LCM DIRECTORY NAME)/1X, + 1 44(1H-)/(1X,I3,2X,A6,5X,I3,2X,A6,5X,I3,2X,A6)) + 315 FORMAT(/35H AVAILABLE CROSS-SECTION LIBRARIES:) + 320 FORMAT(/' SPEC LOCAL NAME ISOTOPE FROM LIBRARY MI', + 1 'X DENSITY WEIGHT% TEMP(K) SIGZERO SELF-SHIEL ', + 2 'THERMAL CORRECTION'/' ------- ------------ ------------ --', + 3 '---------- ---- ---------- ---------- --------- --------', + 4 ' ---------- ------------------') + 330 FORMAT(1X,I7,2X,3A4,2X,3A4,2X,A8,I4,2X,I4,1P,E12.4,12X,E11.3, + 1 E10.2,I4,2X,A8,I4,1X,3A8) + 340 FORMAT(1X,I7,2X,3A4,2X,3A4,2X,A8,I4,2X,I4,1P,2E12.4,E11.3,E10.2, + 1 I4,2X,A8,I4,1X,3A8) + 370 FORMAT(/58X,'NUMBER'/' SPEC LOCAL NAME ISOTOPE FRO', + 1 'M LIBRARY MIX DENSITY TEMP(K) SIGZERO SELF-SHIEL', + 2 ' THERMAL CORRECTION'/' ------- ------------ ------------ ', + 3 '------------ ---- ---------- --------- --------- -------', + 4 '--- ------------------') + 380 FORMAT(1X,I7,2X,3A4,2X,3A4,2X,A8,I4,2X,I4,1P,E12.4,2E11.3,I4,2X, + 1 A8,I4,1X,3A8) + 390 FORMAT(9HLIBINP: ',3A4,7H' AND ',3A4,24H' ARE BOTH ALIAS FOR THE, + 1 23H SAME LIBRARY ISOTOPE ',3A4,12H' IN MIXTURE,I5,1H.) + 400 FORMAT('LIBINP: Invalid group structure',2I10) + END diff --git a/Dragon/src/LIBIPS.f b/Dragon/src/LIBIPS.f new file mode 100644 index 0000000..b56c375 --- /dev/null +++ b/Dragon/src/LIBIPS.f @@ -0,0 +1,64 @@ +*DECK LIBIPS + SUBROUTINE LIBIPS(IPLIB,NBISO,IPISO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Construct the pointer array towards microlib isotopes. +* +*Copyright: +* Copyright (C) 2017 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* NBISO number of isotopes present in the calculation domain. +* +*Parameters: output +* IPISO pointer array towards microlib isotopes. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NBISO + TYPE(C_PTR) IPLIB,IPISO(NBISO) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPLIB +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISONAM +* + ALLOCATE(ISONAM(3,NBISO)) + CALL LCMGET(IPLIB,'ISOTOPESUSED',ISONAM) + JPLIB=LCMGID(IPLIB,'ISOTOPESLIST') + DO 10 ISOT=1,NBISO + CALL LCMLEL(JPLIB,ISOT,LENGTH,ITYLCM) + IF(LENGTH.NE.0) THEN + IPISO(ISOT)=LCMGIL(JPLIB,ISOT) ! set ISOT-th isotope + ELSE + DO JSOT=1,ISOT-1 + IF(ISONAM(1,ISOT).NE.ISONAM(1,JSOT)) CYCLE + IF(ISONAM(2,ISOT).NE.ISONAM(2,JSOT)) CYCLE + IF(ISONAM(3,ISOT).NE.ISONAM(3,JSOT)) CYCLE + IF(.NOT.C_ASSOCIATED(IPISO(JSOT))) CYCLE + IPISO(ISOT)=IPISO(JSOT) ! set JSOT-th isotope + GO TO 10 + ENDDO + IPISO(ISOT)=C_NULL_PTR + ENDIF + 10 CONTINUE + DEALLOCATE(ISONAM) + RETURN + END diff --git a/Dragon/src/LIBLAG.f b/Dragon/src/LIBLAG.f new file mode 100644 index 0000000..9aadef3 --- /dev/null +++ b/Dragon/src/LIBLAG.f @@ -0,0 +1,107 @@ +*DECK LIBLAG + SUBROUTINE LIBLAG(NEF,XE,GE,XI,GS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Lagrange interpolation in a table of points using the APOLLO2 recipe. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NEF number of points. +* XE x-values. +* GE f(x)-values. +* XI interpolating x-value. +* +*Parameters: output +* GS interpolated value f(XI). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NEF + REAL XE(NEF),GE(NEF),XI,GS +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NINT=3) + REAL WEIGHT(NINT) +*---- +* CONSTANT FUNCTION DEFINED BY A SINGLE POINT +*---- + IF(NEF.EQ.1) THEN + GS=GE(1) + RETURN + ENDIF +* + IORD=MIN(NINT,NEF) +*---- +* LOCATE FIRST POINT TO THE RIGHT OF XI (PT IXP) +*---- + DO 30 IXP=1,NEF + IF(ABS(XE(IXP)-XI).LE.1.0E-5*ABS(XI)) THEN + GS=GE(IXP) + RETURN + ELSE IF(XE(IXP).GT.XI) THEN + IMIN=IXP-(IORD+1)/2 + IMAX=IMIN+IORD-1 + GO TO 40 + ENDIF + 30 CONTINUE +*---- +* XI IS TO THE RIGHT OF EVERY POINT XE +*---- + IMAX=NEF + IMIN=NEF-IORD+1 + GO TO 70 +* + 40 IF(IMIN.LT.1) THEN + IMIN=1 + IMAX=IORD + ELSE IF(IMAX.GT.NEF) THEN + IMIN=NEF-IORD+1 + IMAX=NEF + ENDIF +* + 70 I0=IMIN-1 + DO 90 I=IMIN,IMAX + PP=1.0 + DO 80 J=IMIN,IMAX + IF(I.NE.J) PP=PP*((XI-XE(J))/(XE(I)-XE(J))) + 80 CONTINUE + WEIGHT(I+1-IMIN)=PP + 90 CONTINUE +* + GS=0.0 + DO 110 I=1,IORD + GS=GS+WEIGHT(I)*GE(I+I0) + 110 CONTINUE + DO 120 I=1,IORD + I1=I+I0 + IF(XE(I1).GT.XI) THEN + IF(I1-1.GT.0) THEN + YMIN=MIN(GE(I1-1),GE(I1)) + YMAX=MAX(GE(I1-1),GE(I1)) + IF((GS.GT.YMAX).OR.(GS.LT.YMIN)) THEN + GS=GE(I1-1)+(GE(I1)-GE(I1-1))* + 1 (XI-XE(I1-1))/(XE(I1)-XE(I1-1)) + ENDIF + ELSE + GS=GE(1)+(GE(2)-GE(1))*(XI-XE(1))/(XE(2)-XE(1)) + IF(GS.LE.0.) GS=GE(1) + ENDIF + RETURN + ENDIF + 120 CONTINUE + RETURN + END diff --git a/Dragon/src/LIBLEX.f b/Dragon/src/LIBLEX.f new file mode 100644 index 0000000..f7dfa30 --- /dev/null +++ b/Dragon/src/LIBLEX.f @@ -0,0 +1,99 @@ +*DECK LIBLEX + SUBROUTINE LIBLEX(NELE,PNTE,ELMT,NOTX,TERP) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute factors for Lagrangian interpolation. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert and G. Marleau +* +*Parameters: input +* NELE number of elements in table. +* PNTE extrapolation point. +* ELMT values of elements in table. +* NOTX order of interpolation: +* >0 order NOTX in square root of PNTE; +* <0 order -NOTX in PNTE. +* +*Parameters: output +* TERP extrapolation factor. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NELE,NOTX + REAL PNTE,ELMT(NELE) + DOUBLE PRECISION TERP(NELE) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION FACTOR,TERM,SQPNTE +* + I1=1 + I2=NELE + NORD=ABS(NOTX) + TERP(:NELE)=0.0D0 + DO 100 I=1,NELE + IF(PNTE.EQ.ELMT(I)) THEN + TERP(I)=1.0D0 + RETURN + ELSE IF(PNTE.GT.ELMT(I)) THEN + I1=MAX(I-(NORD-1)/2,I1) + ELSE IF(PNTE.LT.ELMT(I)) THEN + I2=MIN(I+(NORD-1)/2,I2) + ENDIF + 100 CONTINUE +* + IF(I1.EQ.1) THEN + I2=MIN(NELE,NORD+1) + ELSE IF(I2.EQ.NELE) THEN + I1=MAX(1,NELE-NORD) + ENDIF + FACTOR=1.0D0 + IF(NOTX.LT.0) THEN + SQPNTE=DBLE(PNTE) + DO 110 I=I1,I2 + IF(ABS(PNTE-ELMT(I)).LE.1.0E-5*ABS(PNTE)) THEN + TERP(I)=1.0D0 + RETURN + ENDIF + FACTOR=FACTOR*( SQPNTE-DBLE(ELMT(I)) ) + 110 CONTINUE + DO 120 I=I1,I2 + TERM=FACTOR/( SQPNTE-DBLE(ELMT(I)) ) + DO 130 J=I1,I2 + IF(I.NE.J) TERM=TERM/ + > ( DBLE(ELMT(I))-DBLE(ELMT(J)) ) + 130 CONTINUE + TERP(I)=TERM + 120 CONTINUE + ELSE + SQPNTE=DBLE(SQRT(PNTE)) + DO 160 I=I1,I2 + IF(ABS(PNTE-ELMT(I)).LE.1.0E-5*ABS(PNTE)) THEN + TERP(I)=1.0D0 + RETURN + ENDIF + FACTOR=FACTOR*( SQPNTE-DBLE(SQRT(ELMT(I))) ) + 160 CONTINUE + DO 170 I=I1,I2 + TERM=FACTOR/( SQPNTE-DBLE(SQRT(ELMT(I))) ) + DO 180 J=I1,I2 + IF(I.NE.J) TERM=TERM/ + > ( DBLE(SQRT(ELMT(I)))-DBLE(SQRT(ELMT(J))) ) + 180 CONTINUE + TERP(I)=TERM + 170 CONTINUE + ENDIF + RETURN + END diff --git a/Dragon/src/LIBLIB.f b/Dragon/src/LIBLIB.f new file mode 100644 index 0000000..53abc67 --- /dev/null +++ b/Dragon/src/LIBLIB.f @@ -0,0 +1,180 @@ +*DECK LIBLIB + SUBROUTINE LIBLIB (IPLIB,NBISO,MASKI,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transcription of the useful interpolated microscopic cross section +* data from various format of libraries to LCM. A two dimensional +* interpolation in temperature and dilution is performed (Part A). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* NBISO number of isotopes present in the calculation domain. +* MASKI isotopic masks. An isotope with index I is process if +* MASKI(I)=.true. +* IMPX print flag. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + INTEGER NBISO,IMPX + LOGICAL MASKI(*) +*---- +* INTERNAL PARAMETERS +*---- + INTEGER IOUT,MAXED,NSTATE + PARAMETER (IOUT=6,MAXED=50,NSTATE=40) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPLIB,KPLIB + INTEGER IPAR(NSTATE),NGRO,NL,ITRANC,ITIME,NLIB,NGF,IGRMAX,NED, + > NDEL,IPROC,ILENG,ITYLCM,IVOID,NBESP,ISOT,NPART,IOF + CHARACTER HVECT(MAXED)*8,TEXT4*4,NAMLBT*8,TEXT12*12 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NTFG,NIR,LSHI,ILLIB + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISONA,ISONR,NAME,ISHIN + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: IHLIB + REAL, ALLOCATABLE, DIMENSION(:) :: TMPIS,GIR + REAL, ALLOCATABLE, DIMENSION(:,:) :: SN,SB + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO +*---- +* RECOVER INFORMATION FROM THE /MICROLIB/ DIRECTORY. +*---- + CALL LCMGET(IPLIB,'STATE-VECTOR',IPAR) + IF(NBISO.NE.IPAR(2)) CALL XABORT('LIBLIB: INCONSISTENT LIBRARY.') + NGRO=IPAR(3) + NL=IPAR(4) + ITRANC=IPAR(5) + ITIME=IPAR(7) + NLIB=IPAR(8) + NGF=IPAR(9) + IGRMAX=IPAR(10) + NED=IPAR(13) + IF(NED.GT.MAXED) CALL XABORT('LIBLIB: MAXED OVERFLOW.') + NBESP=IPAR(16) + IPROC=IPAR(17) + NDEL=IPAR(19) + CALL LCMGTC(IPLIB,'ADDXSNAME-P0',8,NED,HVECT) +*---- +* MEMORY ALLOCATION. +*---- + ALLOCATE(ISONA(3,NBISO),ISONR(3,NBISO),IPISO(NBISO),TMPIS(NBISO), + > IHLIB(2,NBISO,4),ILLIB(NBISO),NAME(16,NLIB),NTFG(NBISO), + > ISHIN(3,NBISO),LSHI(NBISO),SN(NGRO,NBISO),SB(NGRO,NBISO), + > NIR(NBISO),GIR(NBISO)) +*---- +* RECOVER ARRAYS. +*---- + CALL LCMGET(IPLIB,'ISOTOPESUSED',ISONA) + CALL LCMGET(IPLIB,'ISOTOPERNAME',ISONR) + JPLIB=LCMLID(IPLIB,'ISOTOPESLIST',NBISO) + CALL LCMGET(IPLIB,'ISOTOPESTEMP',TMPIS) + CALL LCMGET(IPLIB,'ILIBRARYTYPE',IHLIB(1,1,1)) + CALL LCMGET(IPLIB,'ILIBRARYINDX',ILLIB) + CALL LCMGET(IPLIB,'ILIBRARYNAME',NAME) + CALL LCMLEN(IPLIB,'ISOTOPESNTFG',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGET(IPLIB,'ISOTOPESNTFG',NTFG) + CALL LCMGET(IPLIB,'ISOTOPESCOH',IHLIB(1,1,2)) + CALL LCMGET(IPLIB,'ISOTOPESINC',IHLIB(1,1,3)) + ELSE + NTFG(:NBISO)=0 + ENDIF + CALL LCMLEN(IPLIB,'ISOTOPESRESK',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGET(IPLIB,'ISOTOPESRESK',IHLIB(1,1,4)) + ELSE + NAMLBT=',' + DO ISOT=1,NBISO + IOF=6*NBISO+(ISOT-1)*2 + READ(NAMLBT,'(2A4)') IHLIB(:2,1,4) + ENDDO + ENDIF + CALL LCMLEN(IPLIB,'ISOTOPESHIN',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGET(IPLIB,'ISOTOPESHIN',ISHIN) + ELSE + TEXT4=' ' + READ(TEXT4,'(A4)') IVOID + ISHIN(:2,:NBISO)=IVOID + ENDIF + CALL LCMLEN(IPLIB,'ISOTOPESSHI',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGET(IPLIB,'ISOTOPESSHI',LSHI) + ELSE + LSHI(:NBISO)=0 + ENDIF + CALL LCMLEN(IPLIB,'ISOTOPESDSN',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGET(IPLIB,'ISOTOPESDSN',SN) + CALL LCMGET(IPLIB,'ISOTOPESDSB',SB) + ELSE + SN(:NGRO,:NBISO)=1.0E10 + SB(:NGRO,:NBISO)=1.0E10 + ENDIF + CALL LCMLEN(IPLIB,'ISOTOPESNIR',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGET(IPLIB,'ISOTOPESNIR',NIR) + CALL LCMGET(IPLIB,'ISOTOPESGIR',GIR) + ELSE + NIR(:NBISO)=0 + GIR(:NBISO)=0.0 + ENDIF + DO ISOT=1,NBISO + IF(MASKI(ISOT).AND.(ILLIB(ISOT).NE.0)) THEN + IPISO(ISOT)=LCMDIL(JPLIB,ISOT) ! set ISOT-th isotope + ELSE + IPISO(ISOT)=C_NULL_PTR + ENDIF + ENDDO +*---- +* RECOVER AND INTERPOLATE MICROSCOPIC CROSS SECTIONS. +*---- + CALL LIBLIC (IPLIB,NBISO,MASKI,IMPX,NGRO,NL,ITRANC,ITIME,NLIB, + 1 NED,HVECT,ISONA,ISONR,IPISO,ISHIN,TMPIS,IHLIB,ILLIB,NAME,NTFG, + 2 LSHI,SN,SB,NIR,GIR,NGF,IGRMAX,NDEL,NBESP,NPART,IPROC) +*---- +* RESET ISOTOPE ALIAS. +*---- + DO ISOT=1,NBISO + KPLIB=IPISO(ISOT) + IF(C_ASSOCIATED(KPLIB)) THEN + WRITE(TEXT12,'(3A4)') ISONA(:3,ISOT) + CALL LCMPTC(KPLIB,'ALIAS',12,TEXT12) + ENDIF + ENDDO +* + DEALLOCATE(GIR,NIR,SB,SN,LSHI,NTFG,NAME,ILLIB,IHLIB,TMPIS,ISHIN, + 1 IPISO,ISONR,ISONA) +* + IPAR(9)=NGF + IPAR(10)=IGRMAX + IPAR(16)=NBESP + IPAR(19)=NDEL + IPAR(26)=NPART-1 + CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,IPAR) + IF(IMPX.GT.9) THEN + WRITE (IOUT,'(36H LIBLIB: VALIDATION OF MICROLIB DATA)') + CALL LCMVAL(IPLIB,' ') + ENDIF + RETURN + END diff --git a/Dragon/src/LIBLIC.F b/Dragon/src/LIBLIC.F new file mode 100644 index 0000000..a669c9d --- /dev/null +++ b/Dragon/src/LIBLIC.F @@ -0,0 +1,253 @@ +*DECK LIBLIC + SUBROUTINE LIBLIC (IPLIB,NBISO,MASKI,IMPX,NGRO,NL,ITRANC,ITIME, + 1 NLIB,NED,HVECT,ISONAM,ISONRF,IPISO,ISHINA,TMPISO,IHLIB,ILLIB, + 2 INAME,NTFG,LSHI,SN,SB,NIR,GIR,NGF,IGRMAX,NDEL,NBESP,NPART,IPROC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transcription of the useful interpolated microscopic cross section +* data from various format of libraries to lcm. A two dimensional +* interpolation in temperature and dilution is performed (Part B). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* NBISO number of isotopes present in the calculation domain. +* MASKI isotopic masks. An isotope with index I is processed if +* MASKI(I)=.true. +* IMPX print flag. +* NGRO number of energy groups. +* NL number of Legendre orders required in the calculation +* NL=1 (for isotropic scattering) or higher. +* ITRANC type of transport correction: =0 no transport correction +* =1 Apollo type transport correction; =2 recover from +* library; =3 Wims-D type; =4 leakage correction alone. +* ITIME MATXS type of fission spectrum: +* =1 steady-state; =2 prompt. +* NLIB number of independent libraries. +* NED number of requested vector edits. +* HVECT names of the requested vector edits. +* ISONAM alias name of each isotope. +* ISONRF library reference name of each isotope. +* IPISO pointer array towards microlib isotopes. +* ISHINA self-shielding name of each isotope. +* TMPISO temperature of each isotope. +* IHLIB isotope options. +* ILLIB xs library index for each isotope (.le.NLIB). +* INAME names of the NLIB xs libraries. +* NTFG number of thermal groups where the thermal inelastic +* correction is applied. +* LSHI resonant region number associated with each isotope. +* Infinite dilution will be assumed if LSHI(i)=0. +* SN dilution cross section in each energy group of each +* isotope. a value of 1.0E10 is used for infinite dilution. +* SB dilution cross section as used in Livolant and Jeanpierre +* normalization. +* NIR first group index with an imposed IR slowing-down model; +* =0 for no IR model. +* GIR value of the imposed Goldstein-Cohen parameter for groups +* with an IR model. +* NGF number of fast groups without self-shielding. +* IGRMAX maximum group index with self-shielding. +* NDEL number of precursor groups for delayed neutrons. +* NBESP number of energy-dependent fission spectra. +* NPART number of particles. +* IPROC type of library processing. +* +*----------------------------------------------------------------------- +* + USE GANLIB +#if defined(HDF5_LIB) + USE hdf5_wrap +#endif /* defined(HDF5_LIB) */ + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB,IPISO(NBISO) + INTEGER NBISO,IMPX,NGRO,NL,ITRANC,ITIME,NLIB,NED,NGF,IGRMAX,NDEL, + > NBESP,NPART,IPROC,ISONAM(3,NBISO),ISONRF(3,NBISO), + > ISHINA(3,NBISO),IHLIB(2,NBISO,4),ILLIB(NBISO),INAME(16,NLIB), + > NTFG(NBISO),LSHI(NBISO),NIR(NBISO) + LOGICAL MASKI(NBISO) + CHARACTER*(*) HVECT(NED) + REAL TMPISO(NBISO),SN(NGRO,NBISO),SB(NGRO,NBISO),GIR(NBISO) +*---- +* INTERNAL PARAMETERS +*---- + TYPE(C_PTR) IPDRL,IPMIC + INTEGER MAXDIL + PARAMETER (MAXDIL=65) +*---- +* LOCAL VARIABLES +*---- + INTEGER I,J,IND1,NBIS,NDEL0,NGF0,NGFR0,MAXTRA,ILIB,ILONG,NBESP0, + 1 NPART0 + CHARACTER NAMLBT*8,NAMFIL*64,HSMG*131,NAMLCM*12,NAMMY*12 + LOGICAL LTEST,EMPTY,LCM,LEXIST +*---- +* CHECK FOR DUPLICATE ISOTOPE NAMES. +*---- + DO 40 I=1,NBISO + IF(MASKI(I).AND.(ILLIB(I).NE.0).AND.(LSHI(I).NE.0)) THEN + DO 30 J=I+1,NBISO + IF(MASKI(J).AND.(ISONAM(1,I).EQ.ISONAM(1,J)).AND. + 1 (ISONAM(2,I).EQ.ISONAM(2,J)).AND. + 2 (ISONAM(3,I).EQ.ISONAM(3,J))) THEN + WRITE (HSMG,200) ISONAM(1,I),ISONAM(2,I),ISONAM(3,I) + CALL XABORT(HSMG) + ENDIF + 30 CONTINUE + ENDIF + 40 CONTINUE +* + NPART=1 + NGF0=NGRO+1 + NGFR0=0 + IND1=1 + 50 NBIS=1 + LTEST=MASKI(IND1) + DO 60 I=IND1+1,NBISO + IF(ILLIB(I).EQ.0) THEN + NBIS=NBIS+1 + ELSE IF((IHLIB(1,I,1).EQ.IHLIB(1,IND1,1)).AND. + 1 (IHLIB(2,I,1).EQ.IHLIB(2,IND1,1)).AND. + 2 (ILLIB(I).EQ.ILLIB(IND1))) THEN + NBIS=NBIS+1 + LTEST=LTEST.OR.MASKI(I) + ELSE + GO TO 70 + ENDIF + 60 CONTINUE + 70 WRITE(NAMLBT,'(2A4)') IHLIB(1,IND1,1),IHLIB(2,IND1,1) + ILIB=ILLIB(IND1) + IF(ILIB.EQ.0) THEN + NAMFIL=' ' + ELSE + WRITE(NAMFIL,'(16A4)') (INAME(I,ILIB),I=1,16) + ENDIF + NDEL0=0 + CALL LCMINF(IPLIB,NAMLCM,NAMMY,EMPTY,ILONG,LCM) + IF(LTEST.AND.(NAMLBT.EQ.'DRAGON')) THEN +* TRANSFER INFORMATION FROM DRAGON LIBRARY TO LCM. + CALL LCMOP(IPDRL,NAMFIL(:12),2,2,0) + CALL LIBDRA(IPLIB,IPDRL,NAMFIL,NGRO,NBIS,NL,ISONAM(1,IND1), + 1 ISONRF(1,IND1),IPISO(IND1),TMPISO(IND1),SN(1,IND1),SB(1,IND1), + 2 MASKI(IND1),NED,HVECT,IMPX,NGF0,NGFR0,NDEL0,NBESP0) + CALL LCMCL(IPDRL,1) + NBESP=MAX(NBESP,NBESP0) + ELSE IF(LTEST.AND.(NAMLBT(1:4).EQ.'WIMS')) THEN +* TRANSFER INFORMATION FROM WIMS LIBRARY FILE TO LCM. + IF(NAMLBT.EQ.'WIMSD4') THEN +* WIMS-D4 FORMAT + CALL LIBWD4(IPLIB,IMPX,NAMFIL,NGRO,NBIS,NL,ISONAM(1,IND1), + 1 ISONRF(1,IND1),IPISO(IND1),ISHINA(1,IND1),TMPISO(IND1), + 2 SN(1,IND1),SB(1,IND1),MASKI(IND1),NGF0,NGFR0) + ELSE IF(NAMLBT.EQ.'WIMSE') THEN +* WIMS-E FORMAT + CALL LIBWE(IPLIB,IMPX,NAMFIL,NGRO,NBIS,NL,ISONAM(1,IND1), + 1 ISONRF(1,IND1),IPISO(IND1),ISHINA(1,IND1),TMPISO(IND1), + 2 SN(1,IND1),SB(1,IND1),MASKI(IND1),NGF0,NGFR0) + ELSE IF(NAMLBT.EQ.'WIMSAECL') THEN +* WIMS-AECL FORMAT + CALL LIBWIM(IPLIB,IMPX,NAMFIL,NGRO,NBIS,NL,ISONAM(1,IND1), + 1 ISONRF(1,IND1),IPISO(IND1),ISHINA(1,IND1),TMPISO(IND1), + 2 SN(1,IND1),SB(1,IND1),MASKI(IND1),NGF0,NGFR0) + ENDIF + ELSE IF(LTEST.AND.(NAMLBT.EQ.'MATXS')) THEN +* TRANSFER INFORMATION FROM MATXS (NJOY-89) TO LCM. + CALL LIBTR1(IPLIB,NAMFIL,NGRO,NBIS,NL,ISONAM(1,IND1), + 1 ISONRF(1,IND1),IPISO(IND1),IHLIB(1,IND1,2),IHLIB(1,IND1,3), + 2 NTFG(IND1),TMPISO(IND1),SN(1,IND1),SB(1,IND1),MASKI(IND1),NED, + 3 HVECT,ITIME,IMPX,NGF0,NGFR0) + ELSE IF(LTEST.AND.(NAMLBT.EQ.'MATXS2')) THEN +* TRANSFER INFORMATION FROM MATXS (NJOY-91) TO LCM. + CALL LIBTR2(IPLIB,NAMFIL,NGRO,NBIS,NL,ISONAM(1,IND1), + 1 ISONRF(1,IND1),IPISO(IND1),IHLIB(1,IND1,2),IHLIB(1,IND1,3), + 2 IHLIB(1,IND1,4),NTFG(IND1),TMPISO(IND1),SN(1,IND1),SB(1,IND1), + 3 MASKI(IND1),NED,HVECT,ITIME,IMPX,NGF0,NGFR0,NPART0) + NPART=MAX(NPART,NPART0) + ELSE IF(LTEST.AND.(NAMLBT.EQ.'APLIB1')) THEN +* TRANSFER INFORMATION FROM APOLIB-1 TO LCM. + MAXTRA=NL*NGRO**2 + CALL LIBAPL(IPLIB,NAMFIL,MAXTRA,NGRO,NBIS,NL,ISONAM(1,IND1), + 1 ISONRF(1,IND1),IPISO(IND1),ISHINA(1,IND1),MASKI(IND1), + 2 TMPISO(IND1),SN(1,IND1),SB(1,IND1),IMPX,NGF0,NGFR0) + ELSE IF(LTEST.AND.(NAMLBT.EQ.'APLIB2')) THEN +* TRANSFER INFORMATION FROM APOLIB-2 TO LCM. + CALL LIBA20(IPLIB,NAMFIL,NGRO,NBIS,NL,IPROC,ISONAM(1,IND1), + 1 ISONRF(1,IND1),IPISO(IND1),ISHINA(1,IND1),MASKI(IND1), + 2 TMPISO(IND1),SN(1,IND1),SB(1,IND1),IMPX,NGF0,NGFR0,NDEL0) + ELSE IF(LTEST.AND.(NAMLBT.EQ.'APXSM')) THEN +* TRANSFER INFORMATION FROM APOLIB-XSM TO LCM. + CALL LIBXS4(IPLIB,NAMFIL,NGRO,NBIS,NL,IPROC,ISONAM(1,IND1), + 1 ISONRF(1,IND1),IPISO(IND1),ISHINA(1,IND1),MASKI(IND1), + 2 TMPISO(IND1),SN(1,IND1),SB(1,IND1),IMPX,NGF0,NGFR0,NDEL0) + ELSE IF(LTEST.AND.(NAMLBT.EQ.'APLIB3')) THEN +* TRANSFER INFORMATION FROM APOLIB-3 TO LCM. +#if defined(HDF5_LIB) + CALL LIBA30 (IPLIB,NAMFIL,NGRO,NBIS,NL,ISONAM(1,IND1), + 1 ISONRF(1,IND1),IPISO(IND1),MASKI(IND1),TMPISO(IND1),LSHI(IND1), + 2 SN(1,IND1),SB(1,IND1),IMPX,NGF0,NGFR0,NDEL0) +#else + CALL XABORT('LIBLIC: THE HDF5 API IS NOT AVAILABLE.') +#endif /* defined(HDF5_LIB) */ + ELSE IF(LTEST.AND.(NAMLBT.EQ.'NDAS')) THEN + CALL LIBND1(IPLIB,NAMFIL,NGRO,NBIS,NL,ISONAM(1,IND1), + 1 ISONRF(1,IND1),IPISO(IND1),MASKI(IND1),TMPISO(IND1),SN(1,IND1), + 2 SB(1,IND1),IMPX,NGF0,NGFR0,NDEL0) + ELSE IF(LTEST.AND.(NAMLBT.EQ.'MICROLIB')) THEN +* TRANSFER INFORMATION FROM MICROLIB LIBRARY TO LCM. + CALL LCMINF(IPLIB,NAMLCM,NAMMY,EMPTY,ILONG,LCM) + IF(NAMFIL.EQ.NAMLCM) THEN + IPMIC=IPLIB + ELSE + INQUIRE(FILE=TRIM(NAMFIL),EXIST=LEXIST) + IF(.NOT.LEXIST) THEN + WRITE(HSMG,'(17HLIBLIC: XSM FILE ,A,14H DOESNT EXIST.)') + 1 TRIM(NAMFIL) + CALL XABORT(HSMG) + ENDIF + CALL LCMOP(IPMIC,NAMFIL(:12),2,2,0) + ENDIF + CALL LIBMIC(IPLIB,IPMIC,NAMFIL,NGRO,NBIS,ISONAM(1,IND1), + 1 ISONRF(1,IND1),IPISO(IND1),MASKI(IND1),IMPX,NGF0,NGFR0,NDEL0, + 2 NBESP0) + IF(NAMFIL.NE.NAMLCM) CALL LCMCL(IPMIC,1) + NBESP=MAX(NBESP,NBESP0) + ENDIF + IF(LTEST) THEN + NGF=MIN(NGF,NGF0) + IGRMAX=MAX(IGRMAX,NGFR0) + IF(NDEL.EQ.0) THEN + NDEL=NDEL0 + ELSE IF((NDEL0.NE.NDEL).AND.(NDEL0.NE.0)) THEN + ILIB=ILLIB(IND1) + IF(ILIB.GT.0) WRITE(6,210) (INAME(I,ILIB),I=1,4),NDEL0,NDEL + NDEL=MAX(NDEL,NDEL0) + ENDIF +* +* COMPUTE THE TRANSPORT XS AND ADD COMPLEMENTARY INFORMATION. + CALL LIBADD(IPLIB,NBIS,MASKI(IND1),IMPX,NGRO,NL,ITRANC, + 1 ISONAM(1,IND1),IPISO(IND1),NIR(IND1),GIR(IND1)) + ENDIF +* + IND1=IND1+NBIS + IF(IND1.LE.NBISO) GO TO 50 + RETURN +* + 200 FORMAT(8HLIBLIC: ,3A4,34H IS A DUPLICATE ISOTOPE/MATERIAL N, + 1 4HAME.) + 210 FORMAT(/51H LIBLIC: INVALID NB OF PRECURSOR GROUPS IN LIBRARY , + 1 4A4,8H (NDEL0=,I3,6H NDEL=,I3,2H).) + END diff --git a/Dragon/src/LIBMAC.f b/Dragon/src/LIBMAC.f new file mode 100644 index 0000000..8445239 --- /dev/null +++ b/Dragon/src/LIBMAC.f @@ -0,0 +1,460 @@ +*DECK LIBMAC + SUBROUTINE LIBMAC(IPLIB ,IPLIBX,IPBURX,IPRINT,MAXISO,NBISO , + > NBISOX,IBSTEP,NBMIX ,NBMIXX,NGRO ,TMPDAY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read the information related to microscopic cross section library. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau +* +*Parameters: input/output +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* IPLIBX pointer to the RHS microlib object. +* IPBURX pointer to the RHS burnup object. +* IPRINT print flag. +* MAXISO maximum number of isotopes permitted. +* NBISO number of isotopes present on IPLIB. +* NBISOX number of isotopes present on IPLIBX or IPBURX. +* IBSTEP burnup step on IPBURX if 'BURN' option activated. +* NBMIX number of mixtures defined on IPLIB. +* NBMIXX number of mixtures defined on IPLIBX or IPBURX. +* NGRO number of energy groups. +* TMPDAY time/burnup/irradiation stamp in days. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE + INTEGER IOUT,NTC + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NTC=3,NAMSBR='LIBMAC') +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB,IPLIBX,IPBURX + INTEGER IPRINT,MAXISO,NBISO,NBISOX,IBSTEP,NBMIX,NBMIXX,NGRO + REAL TMPDAY(3) +*---- +* INPUT +*---- + INTEGER NSTATE + PARAMETER (NSTATE=40) + INTEGER ITYPLU,INTLIR,ILONG,ITYLCM,NCOMB,ISOT,IBM,J, + > ISTATE(NSTATE) + CHARACTER TEXT4*4,CARLIR*12 + REAL REALIR + DOUBLE PRECISION DBLLIR +*---- +* LOCAL PARAMETERS +*---- + INTEGER KCHAR(NTC),ISO,JSO,IMIX,NISOM,ITSTMP,NNMIX,MODISO, + > NMIXUP,NIUPD,IMIXX,ILCMLN,ILCMTY,ITC,ITEXT4 +*---- +* ALLOCATABLE STATEMENTS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MIX,MIXIX,LOCUPD,LISM,IEVOL, + > IEVOLX + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISONAM,ISONMX + REAL, ALLOCATABLE, DIMENSION(:) :: DEN,DENMIX,DENIX,DENMOD + LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASKM,MASKG +*---- +* SCRATCH STORAGE ALLOCATION +* ISONAM old name of isotopes. +* ISONMX new name of isotopes. +* MIX mix number of each isotope on IPLIB (can be zero). +* DEN density of each isotope on IPLIB. +* DENMIX density of mixture on IPLIB (can be -1.0). +* MIXIX mix index of each isotope on IPLIBX or IPBURX (can be zero). +* DENIX density of each isotope on IPLIBX or IPBURX. +* LOCUPD location of IPLIB mixture in IPLIBX or IPBURX. +* LISM location in IPLIB of isotope associated with a mixture. +* DENMOD modified density of each isotope on IPLIB. +* MASKM mixture update mask. +* MASKG group update mask. +* IEVOL flag making an isotope non-depleting: +* =1 to force an isotope to be non-depleting; +* =2 to force an isotope to be depleting; +* =3 to force an isotope to be at saturation +*---- + ALLOCATE(MIX(MAXISO),MIXIX(NBISOX),LOCUPD(NBMIX),LISM(MAXISO), + > IEVOL(MAXISO),IEVOLX(NBISOX)) + ALLOCATE(ISONAM(NTC,MAXISO),ISONMX(NTC,NBISOX)) + ALLOCATE(DEN(MAXISO),DENMIX(NBMIX),DENIX(NBISOX),DENMOD(MAXISO)) + ALLOCATE(MASKM(NBMIX),MASKG(NGRO)) +*---- +* INITIALIZE +*---- + TEXT4=' ' + READ(TEXT4,'(A4)') ITEXT4 + ISONAM(:NTC,:MAXISO)=ITEXT4 + ISONMX(:NTC,:NBISOX)=ITEXT4 + MIX(:MAXISO)=0 + DEN(:MAXISO)=0.0 + DENMIX(:NBMIX)=-1.0 +*---- +* READ ORIGINAL ISOTOPE AND MIXTURE INFORMATION FROM IPLIB +*---- + IF(NBISO.GT.MAXISO) CALL XABORT('LIBMAC: MAXISO OVERFLOW.') + CALL LCMGET(IPLIB,'ISOTOPESDENS',DEN) + CALL LCMGET(IPLIB,'ISOTOPESMIX',MIX) + CALL LCMGET(IPLIB,'ISOTOPESUSED',ISONAM) + CALL LCMLEN(IPLIB,'ISOTOPESTODO',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(IPLIB,'ISOTOPESTODO',IEVOL) + ELSE + IEVOL(:MAXISO)=0 + ENDIF + DO 10 JSO=1,NBISO + DENMOD(JSO)=DEN(JSO) + 10 CONTINUE + DENMIX(:NBMIX)=1.0 + LOCUPD(:NBMIX)=0 +*---- +* WRITE ORIGINAL MATERIAL COMPOSITION IF REQUIRED +*---- + IF(IPRINT.GT.0) THEN + WRITE(IOUT,6000) NGRO,NBISO,NBMIX + DO 600 IMIX=1,NBMIX + NISOM=0 + DO 601 ISO=1,NBISO + IF(MIX(ISO).EQ.IMIX) THEN + NISOM=NISOM+1 + LISM(NISOM)=ISO + ENDIF + 601 CONTINUE + IF(NISOM.GT.0) THEN + WRITE(IOUT,6010) IMIX + WRITE(IOUT,6011) ((ISONAM(ITC,LISM(ISO)),ITC=1,NTC-1), + > DEN(LISM(ISO)),IEVOL(LISM(ISO)),ISO=1,NISOM) + ENDIF + 600 CONTINUE + ENDIF +*---- +* READ ISOTOPE AND MIXTURE INFORMATION FROM IPLIBX OR IPBURX +*---- + ITSTMP=2 + IF((IBSTEP.EQ.0).AND.(NBISOX.GT.0)) THEN +* READ FROM A MICROLIB. + IF(.NOT.C_ASSOCIATED(IPLIBX)) THEN + CALL XABORT(NAMSBR//': MICROLIB OBJECT MISSING') + ENDIF + CALL LCMGET(IPLIBX,'ISOTOPESDENS',DENIX) + CALL LCMGET(IPLIBX,'ISOTOPESMIX',MIXIX) + CALL LCMGET(IPLIBX,'ISOTOPESUSED',ISONMX) + CALL LCMLEN(IPLIBX,'ISOTOPESTODO',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(IPLIBX,'ISOTOPESTODO',IEVOLX) + ELSE + IEVOLX(:NBISOX)=0 + ENDIF + ELSE IF((IBSTEP.GT.0).AND.(NBISOX.GT.0)) THEN +* READ FROM A MICROLIB OBJECT. + CALL LCMGET(IPLIB,'ISOTOPESMIX',MIXIX) + CALL LCMGET(IPLIB,'ISOTOPESUSED',ISONMX) + CALL LCMLEN(IPLIB,'ISOTOPESTODO',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(IPLIB,'ISOTOPESTODO',IEVOLX) + ELSE + IEVOLX(:NBISOX)=0 + ENDIF +* READ FROM A BURNUP OBJECT. + IF(.NOT.C_ASSOCIATED(IPBURX)) THEN + CALL XABORT(NAMSBR//': BURNUP OBJECT MISSING') + ENDIF + WRITE(CARLIR,'(8HDEPL-DAT,I4.4)') IBSTEP + CALL LCMSIX(IPBURX,CARLIR,1) + CALL LCMGET(IPBURX,'ISOTOPESDENS',DENIX) + CALL LCMLEN(IPBURX,'BURNUP-IRRAD',ILONG,ITYLCM) + IF(ILONG.EQ.2) THEN + CALL LCMGET(IPBURX,'BURNUP-IRRAD',TMPDAY(2)) + ENDIF + CALL LCMSIX(IPBURX,' ',2) + ENDIF + IF(IPRINT.GT.0) THEN + WRITE(IOUT,6001) NGRO,NBISOX,NBMIX + DO 620 IMIX=1,NBMIX + NISOM=0 + DO 621 ISO=1,NBISO + IF(MIX(ISO).EQ.IMIX) THEN + NISOM=NISOM+1 + LISM(NISOM)=ISO + ENDIF + 621 CONTINUE + WRITE(IOUT,6010) IMIX + WRITE(IOUT,6011) ((ISONAM(ITC,LISM(ISO)),ITC=1,NTC-1), + > DENMOD(LISM(ISO)),IEVOLX(LISM(ISO)),ISO=1,NISOM) + 620 CONTINUE + ENDIF +*---- +* READ UPDATE INFORMATION FROM INPUT +* FORMAT PERMITTED ARE +* [MIX IMLIB [ IMLIBX ] [ DENMOD ] [ NAMISO CONCM(I) ] ] ; +* DEFAULT: +* MIX ABSENT, IPLIBX >0 -> ALL ISOTOPES AND ALL MIXTURES +* MIX ABSENT, IPLIBX =0 -> NO UPDATE - PRINT ONLY +* IMLIBX ABSENT, IPLIBX >0 -> CONCF(ISO,IMX)=CONC(ISO,IMLIBX) +* IMLIBX ABSENT, IPLIBX =0 -> CONCF(ISO,IMX)=CONC(ISO,-IMLIB) +* IMLIBX > 0 -> CORRECTION FROM IPLIBX +* IMLIBX = -IMLIB -> CORRECTION FROM IPLIB +* DENMOD PRESENT -> CONCF(I,IMX)=CONCF(I,IMX)*DENMOD +* NAMISO ABSENT, IPLIBX >0 -> ALL ISOTOPE FOR MIXTURE +* NAMISO ABSENT, IPLIBX =0 -> ALL ISOTOPE FOR MIXTURE +* NAMISO PRESENT, CONCM >=0 -> ISOTOPE SPECIFIED +* CONCF(I,IMX)=DENMOD*CONCM(I,IMX) +* NAMISO PRESENT, CONCM <0 -> ISOTOPE SPECIFIED +* CONCF(I,IMX)=CONC(ISO,-IMLIB)*DENMOD +*---- + NNMIX=0 + 100 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + 101 IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + >': CHARACTER DATA EXPECTED.') + IF(CARLIR.EQ.';') THEN + GO TO 105 + ELSE IF(CARLIR(1:3).EQ.'MIX') THEN + CALL REDGET(ITYPLU,NNMIX,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': MIXTURE TO UPDATE MUST BE GIVEN.') + IF(NNMIX.GT.NBMIX) THEN + CALL XABORT(NAMSBR//': CANNOT UPDATE THIS MIXTURE.') + ELSE IF(NNMIX.LE.0) THEN + CALL XABORT(NAMSBR//': MIX NUMBER.LE.0.') + ENDIF + IF(IBSTEP.EQ.0) THEN + LOCUPD(NNMIX)=NNMIX + ELSE + LOCUPD(NNMIX)=-NNMIX + ENDIF + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.1) THEN + IF(INTLIR.LE.0 .OR. + > INTLIR.GT.NBMIXX) CALL XABORT(NAMSBR// + > ': CANNOT UPDATE THIS MIXTURE.') + LOCUPD(NNMIX)=INTLIR + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + ENDIF + IF(ITYPLU.EQ.2) THEN + DENMIX(NNMIX)=REALIR + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + ENDIF + GO TO 101 + ENDIF + IF(CARLIR.EQ.'NOEV') THEN + DO 30 ISO=1,NBISO + IF(NNMIX.EQ.MIX(ISO)) IEVOL(ISO)=1 + 30 CONTINUE + ELSE IF(CARLIR.EQ.'EVOL') THEN + DO 35 ISO=1,NBISO + IF(NNMIX.EQ.MIX(ISO)) IEVOL(ISO)=2 + 35 CONTINUE + ELSE + READ(CARLIR,'(2A4)') (KCHAR(ITC),ITC=1,NTC-1) + MODISO=0 + IF(LOCUPD(NNMIX).LT.0) THEN + DO 40 ISO=1,NBISO + IF(KCHAR(1).EQ.ISONAM(1,ISO) .AND. + > KCHAR(2).EQ.ISONAM(2,ISO) .AND. + > NNMIX.EQ.MIX(ISO)) THEN + MODISO=ISO + GO TO 45 + ENDIF + 40 CONTINUE + WRITE(IOUT,'(10H MIXTURE :,1X,I10,10H ISOTOPE :,1X,2A4)') + > NNMIX,(KCHAR(ITC),ITC=1,NTC-1) + CALL XABORT(NAMSBR// + > ': CANNOT UPDATE THIS ISOTOPE IN CURRENT MIXTURE.') + 45 CONTINUE + CALL REDGET(ITYPLU,INTLIR,DENMOD(MODISO),CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': NEW ISOTOPIC DENSITY EXPECTED.') + ELSE IF(LOCUPD(NNMIX).GT.0) THEN + DO 50 ISO=1,NBISOX + IF(KCHAR(1).EQ.ISONMX(1,ISO) .AND. + > KCHAR(2).EQ.ISONMX(2,ISO) .AND. + > LOCUPD(NNMIX).EQ.MIXIX(ISO)) THEN + MODISO=ISO + GO TO 55 + ENDIF + 50 CONTINUE + WRITE(IOUT,'(10H MIXTURE :,1X,I10,10H ISOTOPE :,1X,2A4)') + > NNMIX,(KCHAR(ITC),ITC=1,NTC-1) + CALL XABORT(NAMSBR// + > ': CANNOT UPDATE THIS ISOTOPE IN CURRENT MIXTURE.') + 55 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': NEW ISOTOPIC DENSITY EXPECTED.') + IF(REALIR.LT.0.0) THEN + DENIX(MODISO)=-DENIX(MODISO) + ELSE + DENIX(MODISO)=REALIR + ENDIF + ENDIF + ENDIF + GO TO 100 + 105 CONTINUE + IF((NNMIX.EQ.0).AND.(NBISOX.GT.0)) THEN + IF(IBSTEP.EQ.0) THEN + LOCUPD(:NBMIX)=IMIX + ELSE IF(IBSTEP.GT.0) THEN + LOCUPD(:NBMIX)=-IMIX + ENDIF + ENDIF +*---- +* TRANSFER DENSITY FROM DENMOD OR DENIX TO DEN IF REQUIRED +*---- + NMIXUP=0 + DO 70 IMIX=1,NBMIX + MASKM(IMIX)=.FALSE. + IF(LOCUPD(IMIX).GT.0) THEN + NIUPD=0 + IMIXX=LOCUPD(IMIX) + DO 71 ISO=1,NBISOX + IF(MIXIX(ISO).EQ.IMIXX) THEN + DO 72 JSO=1,NBISO + IF(ISONAM(1,JSO).EQ.ISONMX(1,ISO) .AND. + > ISONAM(2,JSO).EQ.ISONMX(2,ISO) .AND. + > MIX(JSO) .EQ.IMIX) THEN + IF(DENMIX(IMIX)*DENIX(ISO) .NE. DEN(JSO)) THEN + DEN(JSO)=DENMIX(IMIX)*DENIX(ISO) + NIUPD=NIUPD+1 + ENDIF + ENDIF + 72 CONTINUE + ENDIF + 71 CONTINUE + IF(NIUPD .NE. 0) THEN + MASKM(IMIX)=.TRUE. + NMIXUP=NMIXUP+1 + ENDIF + ELSE IF(LOCUPD(IMIX).LT.0) THEN + NIUPD=0 + DO 73 ISO=1,NBISOX + IF(MIXIX(ISO).EQ.IMIX) THEN + DO 74 JSO=1,NBISO + IF(ISONAM(1,JSO).EQ.ISONMX(1,ISO) .AND. + > ISONAM(2,JSO).EQ.ISONMX(2,ISO) .AND. + > MIX(JSO) .EQ.IMIX) THEN + IF(DENMIX(IMIX)*DENIX(ISO) .NE. DEN(JSO)) THEN + IF(DENMIX(IMIX)*DENIX(ISO).GE.0.0) THEN + DEN(JSO)=DENMIX(IMIX)*DENIX(ISO) + NIUPD=NIUPD+1 + ENDIF + ENDIF + ENDIF + 74 CONTINUE + ENDIF + 73 CONTINUE + IF(NIUPD.NE.0) THEN + MASKM(IMIX)=.TRUE. + NMIXUP=NMIXUP+1 + ENDIF + ENDIF + 70 CONTINUE +*---- +* UPDATE ALL MATERIAL IF MACROLIB DIRECTORY ABSENT +*---- + CALL LCMLEN(IPLIB,'MACROLIB',ILCMLN,ILCMTY) + IF(ILCMLN.EQ.0) THEN + NMIXUP=NBMIX + MASKM(:NBMIX)=.TRUE. + IF(IPRINT.GT.0) WRITE(IOUT,6004) + ENDIF +*---- +* RECOMPUTE THE NUMBER OF DEPLETING MIXTURES +*---- + IF(NMIXUP.GT.0) THEN + NCOMB=0 + DO 90 ISOT=1,NBISO + IBM=MIX(ISOT) + IF(IBM.EQ.0) GO TO 90 + IF(IEVOL(ISOT).NE.1) THEN + DO 80 J=1,NCOMB + IF(IBM.EQ.LOCUPD(J)) GO TO 90 + 80 CONTINUE + NCOMB=NCOMB+1 + LOCUPD(NCOMB)=IBM + GO TO 90 + ENDIF + 90 CONTINUE + IF(IPRINT.GT.0) WRITE(IOUT,6020) NCOMB + CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) + IF(ISTATE(12).NE.NCOMB) THEN + ISTATE(12)=NCOMB + CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,ISTATE) + ENDIF +*---- +* WRITE UPDATED MATERIAL COMPOSITION IF REQUIRED +*---- + IF(IPRINT.GT.0) THEN + WRITE(IOUT,6002) + DO 630 IMIX=1,NBMIX + NISOM=0 + IF(MASKM(IMIX)) THEN + DO 631 ISO=1,NBISO + IF(MIX(ISO).EQ.IMIX) THEN + NISOM=NISOM+1 + LISM(NISOM)=ISO + ENDIF + 631 CONTINUE + IF(NISOM.GT.0) THEN + WRITE(IOUT,6010) IMIX + WRITE(IOUT,6011) ((ISONAM(ITC,LISM(ISO)),ITC=1,NTC-1), + > DEN(LISM(ISO)),IEVOL(LISM(ISO)),ISO=1,NISOM) + ENDIF + ENDIF + 630 CONTINUE + ENDIF +*---- +* SAVE ISOTOPE NEW DENSITY +*---- + CALL LCMPUT(IPLIB,'ISOTOPESDENS',NBISO,2,DEN) + CALL LCMPUT(IPLIB,'ISOTOPESTODO',NBISO,1,IEVOL) +*---- +* COMPUTE THE MACROSCOPIC X-SECTIONS +*---- + MASKG(:NGRO)=.TRUE. + CALL LIBMIX(IPLIB,NBMIX,NGRO,NBISO,ISONAM,MIX,DEN,MASKM,MASKG, + > ITSTMP,TMPDAY) + ELSE + IF(IPRINT.GT.0) WRITE(IOUT,6003) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(MASKG,MASKM) + DEALLOCATE(DENMOD,DENIX,DENMIX,DEN) + DEALLOCATE(ISONMX,ISONAM) + DEALLOCATE(IEVOLX,IEVOL,LISM,LOCUPD,MIXIX,MIX) + RETURN +*---- +* FORMAT +*---- + 6000 FORMAT(/' LIBMAC: MODIFIED LIBRARY PROPERTIES '/ + > ' NUMBER OF GROUPS = ',I10/ + > ' NUMBER OF ISOTOPES = ',I10/ + > ' NUMBER OF MIXTURES = ',I10/ + > ' ORIGINAL NUMBER DENSITIES IN MIXTURES', + > ' FOLLOWS') + 6001 FORMAT(/' LIBMAC: OLD LIBRARY PROPERTIES (READ ONLY) '/ + > ' NUMBER OF GROUPS = ',I10/ + > ' NUMBER OF ISOTOPES = ',I10/ + > ' NUMBER OF MIXTURES = ',I10/ + > ' ORIGINAL NUMBER DENSITIES IN MIXTURES', + > ' FOLLOWS') + 6002 FORMAT(/' LIBMAC: FINAL NUMBER DENSITIES MIXTURES FOLLOWS') + 6003 FORMAT(/' LIBMAC: NO UPDATED MIXTURES') + 6004 FORMAT(/' LIBMAC: MACROSCOPIC ABSENT -> ALL MIXTURES UPDATED') + 6010 FORMAT(/' ISOTOPIC DENSITIES FOR MIXTURE =',I4) + 6011 FORMAT(1P,5(4X,2A4,':',E12.4,' (',I1,')')) + 6020 FORMAT(/' LIBMAC: NUMBER OF DEPLETING MIXTURES =',I4) + END diff --git a/Dragon/src/LIBMIC.f b/Dragon/src/LIBMIC.f new file mode 100644 index 0000000..74707a1 --- /dev/null +++ b/Dragon/src/LIBMIC.f @@ -0,0 +1,171 @@ +*DECK LIBMIC + SUBROUTINE LIBMIC (IPLIB,IPMIC,NAMFIL,NGRO,NBISO,ISONAM,ISONRF, + 1 IPISO,MASKI,IMPX,NGF,NGFR,NDEL,NBESP) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transcription of the useful microscopic cross section data from a +* microlib to LCM data structures. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* IPMIC pointer to the input microlib (L_LIBRARY signature). +* NAMFIL name of the Dragon library file. +* NGRO number of energy groups. +* NBISO number of isotopes present in the calculation domain. +* ISONAM alias name of isotopes. +* ISONRF library name of isotopes. +* IPISO pointer array towards microlib isotopes in IPLIB. +* MASKI isotopic mask. Isotope with index I is processed if +* MASKI(I)=.true. +* IMPX print flag. +* +*Parameters: output +* NGF number of fast groups without self-shielding. +* NGFR number of fast and resonance groups. +* NDEL number of precursor groups for delayed neutrons. +* NBESP number of energy-dependent fission spectra. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + PARAMETER(MAXESP=4) + CHARACTER*(*) NAMFIL + TYPE(C_PTR) IPLIB,IPMIC,IPISO(NBISO) + INTEGER NGRO,NBISO,ISONAM(3,NBISO),ISONRF(3,NBISO),IMPX,NGF,NGFR, + 1 NDEL,NBESP + LOGICAL MASKI(NBISO) +*---- +* LOCAL VARIABLES +*---- + CHARACTER HSMG*131,HTITLE*80,HNISOR*12,HNAMIS*12 + PARAMETER (IOUT=6,NOTX=3,NSTATE=40) + TYPE(C_PTR) JPLIB,KPLIB,KPMIC + INTEGER IESP(MAXESP+1),ISTATE(NSTATE) + REAL EESP(MAXESP+1) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ITITLE,JSOMIX + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: JSONAM + REAL, ALLOCATABLE, DIMENSION(:) :: DELTA,ENER + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: JPISO +*---- +* RECOVER THE GROUP STRUCTURE. +*---- + NGF=NGRO+1 + NGFR=0 + NDEL=0 + IF(IMPX.GT.0) WRITE (IOUT,900) NAMFIL + CALL LCMLEN(IPMIC,'README',LENGT,ITYLCM) + IF((IMPX.GT.0).AND.(LENGT.GT.0)) THEN + ALLOCATE(ITITLE(LENGT)) + CALL LCMGET(IPMIC,'README',ITITLE) + WRITE (IOUT,940) + I2=0 + DO 10 J=0,LENGT/20 + I1=I2+1 + I2=MIN(I1+19,LENGT) + WRITE (HTITLE,'(20A4)') (ITITLE(I),I=I1,I2) + WRITE (IOUT,'(1X,A80)') HTITLE + 10 CONTINUE + DEALLOCATE(ITITLE) + ENDIF + ALLOCATE(DELTA(NGRO),ENER(NGRO+1)) + CALL LCMLEN(IPMIC,'ENERGY',LENGT,ITYLCM) + LENGT=LENGT-1 + IF(LENGT.NE.NGRO) CALL XABORT('LIBMIC: INVALID GROUP STRUCTURE.') + CALL LCMGET(IPMIC,'ENERGY',ENER) + CALL LCMLEN(IPMIC,'DELTAU',LENGT,ITYLCM) + IF(LENGT.EQ.NGRO) THEN + CALL LCMGET(IPMIC,'DELTAU',DELTA) + ELSE IF(LENGT.EQ.0) THEN + IF(ENER(NGRO+1).EQ.0.0) ENER(NGRO+1)=1.0E-5 + DO 20 J=1,NGRO + DELTA(J)=LOG(ENER(J)/ENER(J+1)) + 20 CONTINUE + ENDIF + CALL LCMPUT(IPLIB,'ENERGY',NGRO+1,2,ENER) + CALL LCMPUT(IPLIB,'DELTAU',NGRO,2,DELTA) + DEALLOCATE(ENER,DELTA) + CALL LCMLEN(IPMIC,'CHI-LIMITS',NBESP,ITYLCM) + IF(NBESP.GT.0) THEN + NBESP=NBESP-1 + IF(NBESP.GT.MAXESP) CALL XABORT('LIBMIC: MAXESP OVERFLOW.') + CALL LCMGET(IPMIC,'CHI-LIMITS',IESP) + CALL LCMPUT(IPLIB,'CHI-LIMITS',NBESP+1,1,IESP) + CALL LCMGET(IPMIC,'CHI-ENERGY',EESP) + CALL LCMPUT(IPLIB,'CHI-ENERGY',NBESP+1,2,EESP) + ENDIF +*---- +* SET THE INPUT LCM MICROLIB ISOTOPEWISE DIRECTORIES. +*---- + CALL LCMGET(IPMIC,'STATE-VECTOR',ISTATE) + NBML=ISTATE(2) + ALLOCATE(JPISO(NBML)) + CALL LIBIPS(IPMIC,NBML,JPISO) +*---- +* READ THROUGH MICROLIB AND ACCUMULATE CROSS SECTIONS. +*---- + ALLOCATE(JSONAM(3,NBML),JSOMIX(NBML)) + CALL LCMGET(IPMIC,'ISOTOPESUSED',JSONAM) + CALL LCMGET(IPMIC,'ISOTOPESMIX',JSOMIX) + DO 40 IMX=1,NBISO + IF(MASKI(IMX)) THEN + WRITE(HNAMIS,'(3A4)') (ISONAM(I0,IMX),I0=1,3) + WRITE(HNISOR,'(3A4)') (ISONRF(I0,IMX),I0=1,3) + KML=0 + DO IML=1,NBML + IF((ISONRF(1,IMX).EQ.JSONAM(1,IML)).AND. + 1 (ISONRF(2,IMX).EQ.JSONAM(2,IML)).AND. + 2 (ISONRF(3,IMX).EQ.JSONAM(3,IML))) THEN + KML=IML + GO TO 30 + ENDIF + ENDDO + DO IML=1,NBML + IF(ISONRF(1,IMX).EQ.JSONAM(1,IML)) THEN + WRITE(IOUT,'(22H POSSIBLE CANDIDATE: '',3A4,1H'')') + 1 JSONAM(:3,IML) + ENDIF + ENDDO + WRITE (HSMG,910) HNAMIS,HNISOR,NAMFIL + CALL XABORT(HSMG) + 30 KPMIC=JPISO(KML) ! set KML-th isotope + KPLIB=IPISO(IMX) ! set IMX-th isotope + IF(.NOT.C_ASSOCIATED(KPMIC)) THEN + WRITE(HSMG,'(17HLIBMIC: ISOTOPE '',3A4,7H'' (ISO=,I8, + 1 35H) IS NOT AVAILABLE IN THE MICROLIB.)') (JSONAM(I0,KML), + 2 I0=1,3),KML + CALL XABORT(HSMG) + ENDIF + IF(.NOT.C_ASSOCIATED(KPLIB)) THEN + JPLIB=LCMGID(IPLIB,'ISOTOPESLIST') + KPLIB=LCMDIL(JPLIB,IMX) + IPISO(IMX)=KPLIB + ENDIF + CALL LCMEQU(KPMIC,KPLIB) ! KPMIC --> KPLIB + ENDIF + 40 CONTINUE + DEALLOCATE(JSOMIX,JSONAM,JPISO) + RETURN +* + 900 FORMAT(/27H PROCESSING MICROLIB NAMED ,A12,1H.) + 910 FORMAT(26HLIBMIC: MATERIAL/ISOTOPE ',A12,5H' = ',A12,9H' IS MISS, + 1 22HING ON MICROLIB NAMED ,A12,1H.) + 940 FORMAT(/24H X-SECTION LIBRARY INFO:) + END diff --git a/Dragon/src/LIBMIX.f b/Dragon/src/LIBMIX.f new file mode 100644 index 0000000..1a800bc --- /dev/null +++ b/Dragon/src/LIBMIX.f @@ -0,0 +1,152 @@ +*DECK LIBMIX + SUBROUTINE LIBMIX(IPLIB,NBMIX,NGROUP,NBISO,ISONAM,MIX,DEN,MASK, + 1 MASKL,ITSTMP,TMPDAY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transformation of the isotope ordered microscopic cross sections to +* group ordered macroscopic cross sections (part 1). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* NBMIX number of material mixtures. +* NGROUP number of energy groups. +* NBISO number of isotopes present in the calculation domain. +* ISONAM names of microlib isotopes. +* MIX mixture number of each isotope (can be zero). +* DEN density of each isotope. +* MASK mixture mask (=.true. if a mixture is to be made). +* MASKL group mask (=.true. if an energy group is to be treated). +* ITSTMP type of cross section perturbation (=0 perturbation +* forbidden; =1 perturbation not used even if present; +* =2 perturbation used if present). +* TMPDAY time stamp in day/burnup/irradiation. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + INTEGER NBMIX,NGROUP,NBISO,ISONAM(3,NBISO),MIX(NBISO),ITSTMP + REAL DEN(NBISO),TMPDAY(3) + LOGICAL MASK(NBMIX),MASKL(NGROUP) +*---- +* LOCAL VARIABLES +*---- + INTEGER NBLK,NSTATE + PARAMETER (NBLK=50,NSTATE=40) + LOGICAL LSAME,LSTOPW + INTEGER ISTATE(NSTATE),I,IPROB,ITRANC,LENGTH,ITYLCM,MAXNFI,NBESP, + 1 NDEL,NED,NESP,NFISSI,NL,NPART,STERN + CHARACTER TEXT12*12,HPRT1*1 + REAL OLDTIM(3) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: JNED + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO +*---- +* RECOVER SOME LIBRARY PARAMETERS. +*---- + CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) + NL=ISTATE(4) + ITRANC=ISTATE(5) + IPROB=ISTATE(6) + NED=ISTATE(13) + NBESP=ISTATE(16) + NDEL=ISTATE(19) + NPART=ISTATE(26) + STERN=ISTATE(27) + ALLOCATE(JNED(2*NED)) + IF(NED.GT.0) CALL LCMGET(IPLIB,'ADDXSNAME-P0',JNED) +*---- +* LOOK FOR OLD LIBRARY DATA +*---- + CALL LCMLEN(IPLIB,'MACROLIB',LENGTH,ITYLCM) + IF(LENGTH.EQ.-1) THEN + CALL LCMSIX(IPLIB,'MACROLIB',1) + CALL LCMGTC(IPLIB,'SIGNATURE',12,TEXT12) + IF(TEXT12.NE.'L_MACROLIB') THEN + CALL XABORT('LIBMIX: INVALID SIGNATURE ON THE MACROLIB.') + ENDIF + CALL LCMLEN(IPLIB,'TIMESTAMP',LENGTH,ITYLCM) + IF((LENGTH.GT.0).AND.(LENGTH.LE.3)) THEN + CALL LCMGET(IPLIB,'TIMESTAMP',OLDTIM) + IF(ITSTMP.EQ.0) THEN + TMPDAY(1)=OLDTIM(1) + TMPDAY(2)=OLDTIM(2) + TMPDAY(3)=OLDTIM(3) + ENDIF + ENDIF + CALL LCMSIX(IPLIB,' ',2) + ENDIF +*---- +* SET THE LCM MICROLIB ISOTOPEWISE DIRECTORIES. +*---- + ALLOCATE(IPISO(NBISO)) + CALL LIBIPS(IPLIB,NBISO,IPISO) +*---- +* TRANSPOSE THE MICROSCOPIC CROSS SECTIONS TO ADJOINT ORDERING. +*---- + IF(IPROB.EQ.1) THEN + CALL LIBADJ (IPLIB,NGROUP,NBISO,NL,NDEL,NBESP,IPISO,NED,JNED) + ENDIF +*---- +* SET MULTIPLE FISSION SPECTRA INFORMATION. +*---- + IF(NBESP.EQ.0) THEN + NESP=1 + ELSE + NESP=NBESP + ENDIF +*---- +* COMPUTE THE MAXIMUM NUMBER OF FISSIONABLE ISOTOPES IN A MIXTURE. +*---- + DO 20 I=1,NBISO + IF(MIX(I).GT.NBMIX) CALL XABORT('LIBMIX: NBMIX OVERFLOW.') + 20 CONTINUE + MAXNFI=MIN(NBISO,200) + CALL LIBNFI (IPLIB,NGROUP,NBISO,NBMIX,NDEL,NESP,IPISO,MIX,MAXNFI, + 1 NFISSI,LSAME) +*---- +* BUILD THE MACROSCOPIC CROSS SECTIONS. +*---- + CALL LIBDEN (IPLIB,NGROUP,NBISO,NBMIX,NL,NDEL,NESP,ISONAM,IPISO, + 1 MIX,DEN,MASK,MASKL,NED,JNED,ITRANC,NFISSI,NPART,LSAME,ITSTMP, + 2 TMPDAY,STERN) +*---- +* RECOVER STOPPING POWERS. +*---- + LSTOPW=.FALSE. + CALL LCMLEN(IPLIB,'PARTICLE',LENGTH,ITYLCM) + IF(LENGTH.GT.0) THEN + CALL LCMGTC(IPLIB,'PARTICLE',1,HPRT1) + LSTOPW=((HPRT1.EQ.'B').OR.(HPRT1.EQ.'C')) + ENDIF + IF(LSTOPW) THEN + CALL LIBEST (IPLIB,NGROUP,NBISO,NBMIX,IPISO,MIX,DEN,MASK,MASKL, + 1 NED,JNED,ITSTMP,TMPDAY,STERN) + ENDIF +*---- +* TRANSPOSE THE MICROSCOPIC CROSS SECTIONS BACK TO FORWARD ORDERING. +*---- + IF(IPROB.EQ.1) THEN + CALL LIBADJ (IPLIB,NGROUP,NBISO,NL,NDEL,NBESP,IPISO,NED,JNED) + ENDIF + DEALLOCATE(IPISO,JNED) + RETURN + END diff --git a/Dragon/src/LIBMOM.f b/Dragon/src/LIBMOM.f new file mode 100644 index 0000000..94f472b --- /dev/null +++ b/Dragon/src/LIBMOM.f @@ -0,0 +1,142 @@ +*DECK LIBMOM + SUBROUTINE LIBMOM(NFS,NDIL,NPAR,DELTA,SIGTF,SIGSF,SIGFF,NOR, + 1 SIGERD,MOMT,MOMP,SEFFER) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute a set of total (SIGT**N) and partial (SIGA*(SIGT**N)) moments +* and a set of reference self-shielded flux and cross sections. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NFS number of fine energy groups. +* NDIL number of dilutions. +* NPAR number of partial cross sections (NPAR=0, 1 or 2). +* DELTA lethargy widths of the fine groups. +* SIGTF microscopic principal x-sections in the fine groups. +* SIGSF microscopic partial x-sections 1 in the fine groups. +* SIGFF microscopic partial x-sections 2 in the fine groups. +* NOR related to the number of moments to preserve. +* For the total moments: -NOR+1 <= N <= NOR. +* For the partial moments: -NOR/2 <= N <= (NOR-1)/2. +* SIGERD dilutions used to compute SEFFER. +* +*Parameters: output +* MOMT total moments. +* MOMP partial moments in absorption. +* SEFFER Bondarenko self-shielded flux and cross sections at each +* dilution. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NFS,NDIL,NPAR,NOR + REAL DELTA(NFS),SIGTF(NFS),SIGSF(NFS),SIGFF(NFS),SIGERD(NDIL), + 1 SEFFER(NPAR+2,NDIL) + DOUBLE PRECISION MOMT(2*NOR),MOMP(NOR,NPAR) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION T,DEL +* + DEL=0.0D0 + DO 10 I=1,2*NOR + MOMT(I)=0.0D0 + 10 CONTINUE + DO 21 I=1,NOR + DO 20 J=1,NPAR + MOMP(I,J)=0.0D0 + 20 CONTINUE + 21 CONTINUE + DO 26 IDIL=1,NDIL + DO 25 IPAR=1,NPAR+2 + SEFFER(IPAR,IDIL)=0.0 + 25 CONTINUE + 26 CONTINUE +* + DO 70 IGF=1,NFS + DELF=DELTA(IGF) + SIGT=MAX(0.001,SIGTF(IGF)) + DEL=DEL+DELF + T=DELF + DO 30 INOR=NOR,2*NOR + MOMT(INOR)=MOMT(INOR)+T + T=T*SIGT + 30 CONTINUE + T=DELF/SIGT + DO 40 INOR=NOR-1,1,-1 + MOMT(INOR)=MOMT(INOR)+T + T=T/SIGT + 40 CONTINUE + DO 45 IDIL=1,NDIL + T=SIGERD(IDIL)*DELF + SEFFER(1,IDIL)=SEFFER(1,IDIL)+REAL(T)/(SIGERD(IDIL)+SIGT) + SEFFER(2,IDIL)=SEFFER(2,IDIL)+REAL(T)*SIGT/(SIGERD(IDIL)+SIGT) + 45 CONTINUE + IF(NPAR.GT.0) THEN + SIGS=MAX(1.E-9,SIGSF(IGF)) + T=DELF*SIGS + DO 50 INOR=NOR/2+1,NOR + MOMP(INOR,1)=MOMP(INOR,1)+T + T=T*SIGT + 50 CONTINUE + T=DELF*SIGS/SIGT + DO 60 INOR=NOR/2,1,-1 + MOMP(INOR,1)=MOMP(INOR,1)+T + T=T/SIGT + 60 CONTINUE + DO 65 IDIL=1,NDIL + T=SIGERD(IDIL)*DELF + SEFFER(3,IDIL)=SEFFER(3,IDIL)+REAL(T)*SIGS/(SIGERD(IDIL)+SIGT) + 65 CONTINUE + IF(NPAR.EQ.2) THEN + SIGF=MAX(1.E-9,SIGFF(IGF)) + T=DELF*SIGF + DO 500 INOR=NOR/2+1,NOR + MOMP(INOR,2)=MOMP(INOR,2)+T + T=T*SIGT + 500 CONTINUE + T=DELF*SIGF/SIGT + DO 600 INOR=NOR/2,1,-1 + MOMP(INOR,2)=MOMP(INOR,2)+T + T=T/SIGT + 600 CONTINUE + DO 650 IDIL=1,NDIL + T=SIGERD(IDIL)*DELF + SEFFER(4,IDIL)=SEFFER(4,IDIL)+REAL(T)*SIGF/(SIGERD(IDIL)+ + 1 SIGT) + 650 CONTINUE + ENDIF + ENDIF + 70 CONTINUE +* + IF(DEL.EQ.0.0) CALL XABORT('LIBMOM: ALGORITHM FAILURE.') + DO 80 INOR=1,2*NOR + MOMT(INOR)=MOMT(INOR)/DEL + 80 CONTINUE + IF(NPAR.GT.0) THEN + DO 95 INOR=1,NOR + DO 90 IPAR=1,NPAR + MOMP(INOR,IPAR)=MOMP(INOR,IPAR)/REAL(DEL) + 90 CONTINUE + 95 CONTINUE + ENDIF + DO 110 IDIL=1,NDIL + DO 100 IPAR=2,NPAR+2 + SEFFER(IPAR,IDIL)=SEFFER(IPAR,IDIL)/SEFFER(1,IDIL) + 100 CONTINUE + SEFFER(1,IDIL)=SEFFER(1,IDIL)/REAL(DEL) + 110 CONTINUE + RETURN + END diff --git a/Dragon/src/LIBMPA.f b/Dragon/src/LIBMPA.f new file mode 100644 index 0000000..651df37 --- /dev/null +++ b/Dragon/src/LIBMPA.f @@ -0,0 +1,73 @@ +*DECK LIBMPA + SUBROUTINE LIBMPA(NOR,JINI,WEIGHT,BASEPT,DEMP,SP) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute a set of partial base points preserving NOR partial moments +* of a function using the modified Ribon approach. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NOR number of partial moments to preserve. +* JINI minimum order of the partial moment we want to preserve. +* We must have 1-NOR <= JINI <= 0 (order 0 moment is always +* preserved). +* WEIGHT weights of the probability table. +* BASEPT base points of the probability table. +* DEMP partial moments. +* +*Parameters: output +* SP base points for the partial cross section. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NOR,JINI + DOUBLE PRECISION DEMP(JINI:NOR+JINI-1) + REAL WEIGHT(NOR),BASEPT(NOR),SP(NOR) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MAXNOR=20) + DOUBLE PRECISION DDA(0:MAXNOR),DD,DSIGX +* + IF(NOR.GT.MAXNOR) CALL XABORT('LIBMPA: STORAGE OVERFLOW.') + IF(NOR.LE.0) CALL XABORT('LIBMPA: NEGATIVE OR ZERO VALUE OF NOR.') + IF((1-NOR.GT.JINI).OR.(JINI.GT.0)) CALL XABORT('LIBMPA: INCONSIST' + 1 //'ENT VALUE OF JINI.') +* + DO 50 I=1,NOR + DSIGX=DBLE(BASEPT(I)) + DDA(0)=1.0D0 + J0=0 + DO 20 J=1,NOR + IF(J.EQ.I) GO TO 20 + J0=J0+1 + DDA(J0)=DDA(J0-1) + DO 10 K=1,J0-1 + DDA(J0-K)=DDA(J0-K-1)-DDA(J0-K)*DBLE(BASEPT(J)) + 10 CONTINUE + DDA(0)=-DDA(0)*DBLE(BASEPT(J)) + 20 CONTINUE + DD=0.0D0 + DO 30 J=0,NOR-1 + DD=DD+DDA(J)*DEMP(J+JINI) + 30 CONTINUE + DO 40 J=1,NOR + IF(J.NE.I) DD=DD/(DBLE(BASEPT(J))-DSIGX) + 40 CONTINUE + SP(I)=REAL(((-1.0D0)**(NOR-1))*DD*DSIGX**(-JINI))/WEIGHT(I) + 50 CONTINUE + RETURN + END diff --git a/Dragon/src/LIBND0.f b/Dragon/src/LIBND0.f new file mode 100644 index 0000000..2a2ccf9 --- /dev/null +++ b/Dragon/src/LIBND0.f @@ -0,0 +1,55 @@ +*DECK LIBND0 + SUBROUTINE LIBND0 (NAMFIL,NGRO,IPENER) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover energy group information from a NDAS library. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* +*Author(s): A. Hebert +* +*Parameters: input +* NAMFIL name of the NDAS file. +* +*Parameters: output +* NGRO number of energy groups. +* IPENER pointer of the energy mesh limit array. +* +*Reference: +* Copyright (C) from NDAS Atomic Energy of Canada Limited utility (2006) +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE FSDF + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NGRO + CHARACTER NAMFIL*(*) + TYPE(C_PTR) IPENER +*---- +* Local variables +*---- + INTEGER IERR,HEADER(16) + REAL, POINTER, DIMENSION(:) :: ENERG +* + CALL XSDOPN(NAMFIL,IERR) + IF(IERR.NE.0) CALL XABORT('LIBND0: XSDOPN could not open Library' + > //' files') + CALL XSDBLD(6001,HEADER,IERR) + IF(IERR.NE.0) CALL XABORT('LIBND0: XSDBLD could not read library' + > //' parameters') + NGRO=HEADER(2) + IPENER=LCMARA(NGRO+1) + CALL C_F_POINTER(IPENER,ENERG,(/ NGRO+1 /)) + CALL XSDBLD(5019,ENERG,IERR) + IF(IERR.NE.0) CALL XABORT('LIBND0: XSDBLD could not read energy ' + > //'group limits') + CALL XSDCL() + RETURN + END diff --git a/Dragon/src/LIBND1.f b/Dragon/src/LIBND1.f new file mode 100644 index 0000000..7827a6a --- /dev/null +++ b/Dragon/src/LIBND1.f @@ -0,0 +1,516 @@ +*DECK LIBND1 + SUBROUTINE LIBND1 (IPLIB,NAMFIL,NGRO,NBISO,NL,ISONAM,ISONRF, + 1 IPISO,MASKI,TN,SN,SB,IMPX,NGF,NGFR,NDEL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transcription of the useful interpolated microscopic cross section +* data from NDAS to LCM data structures. Memory allocation interface. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* NAMFIL name of the NDAS file. +* NGRO number of energy groups. +* NBISO number of isotopes present in the calculation domain. +* NL number of Legendre orders required in the calculation +* NL=1 or higher. +* ISONAM alias name of isotopes. +* ISONRF library reference name of isotopes. +* IPISO pointer array towards microlib isotopes. +* MASKI isotopic mask. Isotope with index I is processed if +* MASKI(I)=.true. +* TN temperature of each isotope. +* SN dilution cross section in each energy group of each +* isotope. A value of 1.0E10 is used for infinite dilution. +* SB dilution cross section as used by Livolant and Jeanpierre +* normalization. +* IMPX print flag +* +*Parameters: output +* NGF number of fast groups without self-shielding. +* NGFR number of fast and resonance groups. +* NDEL number of precursor groups for delayed neutrons. +* +*Reference: +* P. J. Laughton, "NJOYPREP and WILMAPREP: UNIX-Based Tools for WIMS- +* AECL Cross-Section Library Production," Atomic Energy of Canada, +* Report COG-92-414 (Rev. 0), June 1993. +* Copyright (C) from NDAS Atomic Energy of Canada Limited utility (2006) +* +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE FSDF + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPLIB,IPISO(NBISO) + INTEGER NGRO,NBISO,NL,ISONAM(3,NBISO),ISONRF(3,NBISO),IMPX,NGF, + 1 NGFR,NDEL + REAL TN(NBISO),SN(NGRO,NBISO),SB(NGRO,NBISO) + CHARACTER NAMFIL*(*) + LOGICAL MASKI(NBISO) +*---- +* Local variables +*---- + INTEGER IOUT + PARAMETER(IOUT=6) + TYPE(C_PTR) KPLIB + INTEGER I,I0,IERR,HEADER(16),NISOLB,NGFIS,NGTHER,MAXTMP,MAXDIL, + 1 MAXTDN,MAXPN,NF,NP1,IND,IHEAD(200),NBTEM,NBDIL,ISOID,IG,IG1,NL2, + 2 IJ,IM,IMX,IOF,J,ITYPRO(2) + REAL RHEAD(200),WW,SUM + DOUBLE PRECISION XDRCST,ANEUT + CHARACTER TEXT8*8,HSMG*131,HNAMIS*12,HNISOR*12 + LOGICAL LCUBIC + PARAMETER(LCUBIC=.TRUE.) + EXTERNAL XDRCST + EQUIVALENCE(RHEAD(1),IHEAD(1)) +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: HNAM + REAL, ALLOCATABLE, DIMENSION(:) :: DELTA,TEMPS,DILUS,TERPT,LOAD, + 1 ENER,CHI,WT0,GC,RESD + REAL, ALLOCATABLE, DIMENSION(:,:) :: GAR1,GAR2,THERXS,XA,XS,XF,XN + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT +*---- +* Read NDAS library parameters +*---- + CALL XSDOPN(NAMFIL,IERR) + IF(IERR.NE.0) CALL XABORT('LIBND1: XSDOPN could not open Library' + > //' files') + CALL XSDBLD(6001,HEADER,IERR) + IF(IERR.NE.0) CALL XABORT('LIBND1: XSDBLD could not read library' + > //' parameters') + IF(NGRO.NE.HEADER(2)) CALL XABORT('LIBND1: Invalid number of ene' + > //'rgy groups') + NISOLB=HEADER(1) + NGFIS=HEADER(3) + NGF=HEADER(4) + NGFR=HEADER(4)+HEADER(5) + NGTHER=HEADER(6) + MAXTMP=HEADER(11) + MAXDIL=HEADER(12) + MAXTDN=HEADER(13) + IF(HEADER(14).NE.2) CALL XABORT('LIBND1: Old NDAS format not sup' + > //'ported') + MAXPN=MAX(HEADER(15),HEADER(16)) + NDEL=0 + IF(IMPX.GT.1) WRITE(IOUT,100) (HEADER(I),I=1,16) +*---- +* Scratch storage allocation +* HNAM isotope names in NDAS library +* DELTA lethargy widths +* TEMPS temperature base points +* DILUS dilution base points +* TERPT interpolation factors in temperature +* GAR1 vector xs components (1: transport corr. total; +* 2: absorption; 3: fission; 4: nu*fission; 5: P0 scattering; +* 6: P1 scattering, 7: (n,2n) +* GAR2 self-shielded xs returned by LIBND3 +* SCAT P0 and P1 differential scattering xs components +* THERXS temperature-dependent thermal cross section components +* LOAD storage array containing differential scattering components +* XA dilution-dependent absorption effective cross sections +* XS dilution-dependent scattering effective cross sections +* XF dilution-dependent nu*fission effective cross sections +* XN dilution-dependent NJOY fluxes +*---- + ALLOCATE(HNAM(2,NISOLB)) + ALLOCATE(DELTA(NGRO),TEMPS(MAXTMP),DILUS(MAXDIL),TERPT(MAXTMP), + 1 GAR1(NGRO,7),GAR2(NGRO,6),SCAT(NGRO,NGRO,2),THERXS(NGTHER,2), + 2 LOAD(MAXPN),XA(NGFR-NGF,MAXDIL),XS(NGFR-NGF,MAXDIL), + 3 XF(NGFR-NGF,MAXDIL),XN(NGFR-NGF,MAXDIL)) +*---- +* Recover the group structure +*---- + ANEUT=XDRCST('Neutron mass','amu') + ALLOCATE(ENER(NGRO+1)) + CALL XSDBLD(5019,ENER,IERR) + IF(IERR.NE.0) CALL XABORT('LIBND1: xsdbld could not read energy ' + > //'group limits') + IF(ENER(NGRO+1).EQ.0.0) ENER(NGRO+1)=1.0E-5 + DO I=1,NGRO + DELTA(I)=LOG(ENER(I)/ENER(I+1)) + ENDDO + CALL LCMPUT(IPLIB,'ENERGY',NGRO+1,2,ENER) + CALL LCMPUT(IPLIB,'DELTAU',NGRO,2,DELTA) + DEALLOCATE(ENER) +*---- +* Recover the isotope names and identifiers from the library +*---- + DO I=1,NISOLB + CALL XSDNAM(I,ISOID,TEXT8,IERR) + IF(IERR.NE.0) CALL XABORT('LIBND1: XSDNAM index overflow') + READ(TEXT8,'(2A4)') HNAM(1,I),HNAM(2,I) + ENDDO +*---- +* Read through NDAS file and accumulate cross sections for this range +* of MATS, Legendre orders, and groups +*---- + DO IMX=1,NBISO + IF(MASKI(IMX)) THEN + WRITE(HNAMIS,'(3A4)') (ISONAM(I0,IMX),I0=1,3) + WRITE(HNISOR,'(3A4)') (ISONRF(I0,IMX),I0=1,3) + IND=0 + DO I=1,NISOLB + IF((ISONRF(1,IMX).EQ.HNAM(1,I)).AND. + > (ISONRF(2,IMX).EQ.HNAM(2,I))) THEN + IND=I + GO TO 10 + ENDIF + ENDDO + WRITE (HSMG,130) HNAMIS,HNISOR,NAMFIL + CALL XABORT(HSMG) + 10 IF(IMPX.GT.9) CALL LCMLIB(IPLIB) + KPLIB=IPISO(IMX) ! set IMX-th isotope +* Load nuclide header + CALL XSDISO(7000,6001,IND,RHEAD,IERR) + IF(IMPX.GT.0) THEN + WRITE(IOUT,110) HNAMIS,HNISOR + ENDIF + IF(IMPX.GT.5) THEN + WRITE(IOUT,120) IHEAD(1),IHEAD(2),RHEAD(3),(IHEAD(I),I=4,12) + ENDIF + CALL LCMPTC(KPLIB,'ALIAS',12,HNAMIS) + CALL LCMPUT(KPLIB,'AWR',1,2,RHEAD(3)/REAL(ANEUT)) + NF=IHEAD(5) + NBTEM=IHEAD(6) + NP1=IHEAD(10) + IF(NBTEM.GT.MAXTMP) CALL XABORT('LIBND1: MAXTMP overflow(1)') + IF(NBTEM.EQ.1) THEN + TERPT(1)=1.0 + ELSE +* Thermal temperatures + CALL XSDISO(7000,5017,IND,TEMPS,IERR) + CALL ALTERP(LCUBIC,NBTEM,TEMPS,TN(IMX),.FALSE.,TERPT) + ENDIF +* +* transport-corrected total and absorption XS + CALL XSDISO(7002,5013,IND,GAR1(:,1),IERR) + CALL XSDISO(7002,5004,IND,GAR1(:,2),IERR) + IF(NGTHER.GT.0) THEN + GAR1(NGFR+1:NGFR+NGTHER,1)=0.0 + GAR1(NGFR+1:NGFR+NGTHER,2)=0.0 + DO I=1,NBTEM + WW=TERPT(I) + IF(ABS(WW).GT.1.0E-6) THEN + CALL XSDTHE(7004,5013,-1,I,THERXS(:,1),IERR) + CALL XSDTHE(7004,5004,-1,I,THERXS(:,2),IERR) + DO I0=1,NGTHER + IOF=NGFR+I0 + GAR1(IOF,1)=GAR1(IOF,1)+WW*THERXS(I0,1) + GAR1(IOF,2)=GAR1(IOF,2)+WW*THERXS(I0,2) + ENDDO + ENDIF + ENDDO + ENDIF +* +* fission spectrum, fission XS and nu*fission XS + IF(IHEAD(11).EQ.1) THEN + ALLOCATE(CHI(NGRO)) + CHI(:NGRO)=0.0 + CALL XSDISO(7002,5008,IND,CHI,IERR) + SUM=0.0 + DO I=1,NGRO + SUM=SUM+CHI(I) + ENDDO + IF(ABS(SUM-1.0).GT.1.0E-5) CALL XABORT('LIBND1: Fission sp' + > //'ectrum does not sum to one') + CALL LCMPUT(KPLIB,'CHI',NGRO,2,CHI) + DEALLOCATE(CHI) +* + CALL XSDISO(7002,5005,IND,GAR1(:,3),IERR) + CALL XSDISO(7002,5006,IND,GAR1(:,4),IERR) + IF(NGTHER.GT.0) THEN + GAR1(NGFR+1:NGFR+NGTHER,3)=0.0 + GAR1(NGFR+1:NGFR+NGTHER,4)=0.0 + DO I=1,NBTEM + WW=TERPT(I) + IF(ABS(WW).GT.1.0E-6) THEN + CALL XSDTHE(7004,5005,-1,I,THERXS(:,1),IERR) + CALL XSDTHE(7004,5006,-1,I,THERXS(:,2),IERR) + DO I0=1,NGTHER + IOF=NGFR+I0 + GAR1(IOF,3)=GAR1(IOF,3)+WW*THERXS(I0,1) + GAR1(IOF,4)=GAR1(IOF,4)+WW*THERXS(I0,2) + ENDDO + ENDIF + ENDDO + ENDIF + ELSE + GAR1(:NGRO,3)=0.0 + GAR1(:NGRO,4)=0.0 + ENDIF +* +* (n,2n) XS + CALL XSDISO(7001,5007,IND,GAR1(:,7),IERR) + GAR1(NGF+1:NGRO,7)=0.0 + CALL LCMPUT(KPLIB,'N2N',NGRO,2,GAR1(1,7)) +* +* P0 differential scattering XS + CALL XSDISO(7002,5015,IND,LOAD,IERR) + GAR1(:NGRO,5)=0.0 + SCAT(:NGRO,:NGRO,1)=0.0 + IJ=0 + DO IG=1,NGFR + IM=NINT(LOAD(IJ+2)) + IG1=-NINT(LOAD(IJ+1))+IG + IJ=IJ+2 + DO I0=1,IM +* --- IG is the primary group + SCAT(IG1+I0,IG,1)=LOAD(IJ+I0) + GAR1(IG,5)=GAR1(IG,5)+LOAD(IJ+I0) + ENDDO + IJ=IJ+IM + ENDDO + IF(NGTHER.GT.0) THEN + SCAT(:NGRO,NGFR+1:NGFR+NGTHER,1)=0.0 + GAR1(NGFR+1:NGFR+NGTHER,5)=0.0 + DO I=1,NBTEM + WW=TERPT(I) + IF(ABS(WW).GT.1.0E-6) THEN + CALL XSDTHE(7004,5015,-1,I,LOAD,IERR) + IJ=0 + DO IG=1,NGTHER + IM=NINT(LOAD(IJ+2)) + IG1=-NINT(LOAD(IJ+1))+NGFR+IG + IJ=IJ+2 + DO I0=1,IM +* --- NGFR+IG is the primary group + SCAT(IG1+I0,NGFR+IG,1)=SCAT(IG1+I0,NGFR+IG,1)+WW* + > LOAD(IJ+I0) + GAR1(NGFR+IG,5)=GAR1(NGFR+IG,5)+WW*LOAD(IJ+I0) + ENDDO + IJ=IJ+IM + ENDDO + ENDIF + ENDDO + ENDIF + IF(NP1.GT.0) THEN +* P1 differential scattering XS + CALL XSDISO(7002,5016,IND,LOAD,IERR) + GAR1(:NGRO,6)=0.0 + SCAT(:NGRO,:NGRO,2)=0.0 + IJ=0 + DO IG=1,NGFR + IM=NINT(LOAD(IJ+2)) + IG1=-NINT(LOAD(IJ+1))+IG + IJ=IJ+2 + DO I0=1,IM +* --- IG is the primary group + SCAT(IG1+I0,IG,2)=LOAD(IJ+I0) + GAR1(IG,6)=GAR1(IG,6)+LOAD(IJ+I0) + ENDDO + IJ=IJ+IM + ENDDO + IF(NGTHER.GT.0) THEN + GAR1(NGFR+1:NGFR+NGTHER,6)=0.0 + SCAT(:NGRO,NGFR+1:NGFR+NGTHER,2)=0.0 + DO I=1,NBTEM + WW=TERPT(I) + IF(ABS(WW).GT.1.0E-6) THEN + CALL XSDTHE(7004,5016,-1,I,LOAD,IERR) + IJ=0 + DO IG=1,NGTHER + IM=NINT(LOAD(IJ+2)) + IG1=-NINT(LOAD(IJ+1))+NGFR+IG + IJ=IJ+2 + DO I0=1,IM +* --- NGFR+IG is the primary group + SCAT(IG1+I0,NGFR+IG,2)=SCAT(IG1+I0,NGFR+IG,2)+WW* + > LOAD(IJ+I0) + GAR1(NGFR+IG,6)=GAR1(NGFR+IG,6)+WW*LOAD(IJ+I0) + ENDDO + IJ=IJ+IM + ENDDO + ENDIF + ENDDO + ENDIF + ENDIF +*---- +* Recover self-shielding data +*---- + ALLOCATE(WT0(NGRO)) + WT0(:NGRO)=1.0 + IF((NF.GE.1).AND.(NF.LE.3)) THEN +* +* --- Recover Goldstein-Sehgal parameters + ALLOCATE(GC(NGRO)) + GC(:NGRO)=1.0 + CALL XSDISO(7000,5012,IND,GC(NGF+1:),IERR) + CALL LCMPUT(KPLIB,'NGOLD',NGRO,2,GC) + DEALLOCATE(GC) +* + CALL XSDRES(IND,IHEAD,IERR) + NBTEM=IHEAD(1) + NBDIL=IHEAD(2) + IF(NBTEM.GT.MAXTMP) CALL XABORT('LIBND1: MAXTMP overflow') + IF(NBDIL.GT.MAXDIL) CALL XABORT('LIBND1: MAXDIL overflow') +* +* --- Temperature interpolation + IF(NBTEM.EQ.1) THEN + TERPT(1)=1.0 + ELSE +* Resonance temperatures + DO I=1,NBTEM + TEMPS(I)=RHEAD(2+I) + ENDDO + CALL ALTERP(LCUBIC,NBTEM,TEMPS,TN(IMX),.FALSE.,TERPT) + ENDIF + ALLOCATE(RESD(MAXTDN)) + DO I=1,NBDIL + DILUS(I)=RHEAD(2+NBTEM+I) + ENDDO + XA(:NGFR-NGF,:NBDIL)=0.0 + XS(:NGFR-NGF,:NBDIL)=0.0 + XF(:NGFR-NGF,:NBDIL)=0.0 + XN(:NGFR-NGF,:NBDIL)=0.0 + DO IG=1,NGFR-NGF +* --- Absorption + CALL XSDTAB(5004,IND,IG,RESD,IERR) + DO I=1,NBTEM + WW=TERPT(I) + IF(ABS(WW).GT.1.0E-6) THEN + IOF=(I-1)*NBDIL + DO J=1,NBDIL + XA(IG,J)=XA(IG,J)+WW*RESD(IOF+J) + ENDDO + ENDIF + ENDDO +* --- Scattering + CALL XSDTAB(5015,IND,IG,RESD,IERR) + DO I=1,NBTEM + WW=TERPT(I) + IF(ABS(WW).GT.1.0E-6) THEN + IOF=(I-1)*NBDIL + DO J=1,NBDIL + XS(IG,J)=XS(IG,J)+WW*RESD(IOF+J) + ENDDO + ENDIF + ENDDO + IF(NF.EQ.3) THEN +* --- Nu*Fission + CALL XSDTAB(5006,IND,IG,RESD,IERR) + DO I=1,NBTEM + WW=TERPT(I) + IF(ABS(WW).GT.1.0E-6) THEN + IOF=(I-1)*NBDIL + DO J=1,NBDIL + XF(IG,J)=XF(IG,J)+WW*RESD(IOF+J) + ENDDO + ENDIF + ENDDO + ENDIF +* --- NJOY Flux + CALL XSDTAB(5021,IND,IG,RESD,IERR) + DO I=1,NBTEM + WW=TERPT(I) + IF(ABS(WW).GT.1.0E-6) THEN + IOF=(I-1)*NBDIL + DO J=1,NBDIL + XN(IG,J)=XN(IG,J)+WW*RESD(IOF+J) + ENDDO + ENDIF + ENDDO + ENDDO + DEALLOCATE(RESD) +* +* --- Dilution interpolation and Livolant-Jeanpierre +* normalization + CALL LIBND3(NGF,NGFR,NGRO,NBDIL,SN(1,IMX),SB(1,IMX),DILUS, + > DELTA,NF,XA,XS,XF,XN,GAR1,SCAT(1,1,1),GAR2,WT0) +* +* --- Apply self-shielding on SCAT and GAR1 + DO IG=NGF+1,NGFR + DO IM=1,2 + WW=GAR2(IG,4+IM)/GAR1(IG,4+IM) + DO IG1=1,NGRO + SCAT(IG1,IG,IM)=SCAT(IG1,IG,IM)*WW + ENDDO + ENDDO + DO I=1,6 + GAR1(IG,I)=GAR2(IG,I) + ENDDO + ENDDO + ENDIF + CALL LCMPUT(KPLIB,'NWT0',NGRO,2,WT0) + DEALLOCATE(WT0) +*---- +* Save xs information on the microlib +*---- + DO IG=1,NGRO +* (n,g) xs + GAR1(IG,7)=GAR1(IG,2)+GAR1(IG,7)-GAR1(IG,3) +* Total xs + GAR1(IG,2)=GAR1(IG,2)+GAR1(IG,5) +* Transport correction + GAR1(IG,1)=GAR1(IG,2)-GAR1(IG,1) + ENDDO + CALL LCMPUT(KPLIB,'TRANC',NGRO,2,GAR1(1,1)) + CALL LCMPUT(KPLIB,'NTOT0',NGRO,2,GAR1(1,2)) + CALL LCMPUT(KPLIB,'NG',NGRO,2,GAR1(1,7)) + IF(NF.EQ.3) THEN + CALL LCMPUT(KPLIB,'NFTOT',NGRO,2,GAR1(1,3)) + CALL LCMPUT(KPLIB,'NUSIGF',NGRO,2,GAR1(1,4)) + ENDIF + NL2=1 + IF((NL.GE.2).AND.(NP1.GT.0)) NL2=2 + CALL XDRLGS(KPLIB,1,IMPX,0,NL2-1,1,NGRO,GAR1(1,5),SCAT,ITYPRO) + IF(IMPX.GT.5) CALL LCMLIB(KPLIB) + ENDIF + ENDDO + CALL XSDCL() +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(XN,XF,XS,XA,LOAD,THERXS,SCAT,GAR2,GAR1,TERPT,DILUS, + 1 TEMPS,DELTA) + DEALLOCATE(HNAM) + RETURN +* + 100 FORMAT(/21H NDAS LIBRARY OPTIONS/21H --------------------/ + 1 7H NISOLB,I6,39H (Number of isotopes in NDAS library)/ + 2 7H NGRO ,I6,28H (Number of energy groups)/ + 3 7H NGFIS ,I6,29H (Number of fission groups)/ + 4 7H NGF ,I6,26H (Number of fast groups)/ + 5 7H NGRES ,I6,31H (Number of resonance groups)/ + 6 7H NGTHER,I6,29H (Number of thermal groups)/ + 7 7H NBFISS,I6,31H (Number of fissile nuclides)/ + 8 7H NBFP ,I6,31H (Number of fission products)/ + 9 7H NBP1 ,I6,40H (Number of nuclides with P1 matrices)/ + 1 7H NBRES ,I6,33H (Number of resonance nuclides)/ + 2 7H MAXTMP,I6,40H (Maximum number of temperature nodes)/ + 3 7H MAXDIL,I6,37H (Maximum number of dilution nodes)/ + 4 7H MAXTDN,I6,36H (Maximum number of product nodes)/ + 5 7H IOLD ,I6,32H (Library type: old=1, new>=2)/ + 6 7H MAXP0 ,I6,34H (Maximum length of P0 matrices)/ + 7 7H MAXP1 ,I6,34H (Maximum length of P1 matrices)) + 110 FORMAT(/30H Processing isotope/material ',A12,11H' (HNISOR=',A12, + 1 3H').) + 120 FORMAT(/16H ISOTOPE OPTIONS/16H ---------------/ + 1 7H NBURN ,I6,46H (Number of daughters in burnup calculation)/ + 2 7H ID ,I6,15H (Numeric ID)/ + 3 5H AW ,1P E10.2,14H (Atomic mass)/ + 4 7H IZ ,I6,22H (Number of protons)/ + 5 7H NF ,I6,24H (Self-shielding flag)/ + 6 7H NT ,I6,38H (Number of thermal xs temperatures)/ + 7 7H NR ,I6/ + 8 7H NDAT2 ,I6/ + 9 7H NDAT3 ,I6/ + 1 7H NP1 ,I6,23H (P1 scattering flag)/ + 2 7H NS ,I6,25H (Fissile isotope flag)/ + 3 7H IENDFB,I6,28H (Type of evaluation file)) + 130 FORMAT(26HLIBND1: Material/isotope ',A12,5H' = ',A12,9H' is miss, + 1 23Hing on NDAS file named ,A24,1H.) + END diff --git a/Dragon/src/LIBND3.f b/Dragon/src/LIBND3.f new file mode 100644 index 0000000..c2d2b62 --- /dev/null +++ b/Dragon/src/LIBND3.f @@ -0,0 +1,185 @@ +*DECK LIBND3 + SUBROUTINE LIBND3(NGF,NGFR,NGRO,NBDIL,SN,SB,DILUS,DELTA,NF,XA,XS, + > XF,XN,GAR1,SCAT,GAR2,WT0) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Interpolate dilution-tabulated information, perform +* Livolant-Jeanpierre normalization and compute self-shielded +* cross sections at specific dilution. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* +*Author(s): A. Hebert +* +*Parameters: input +* NGF number of fast groups without self-shielding. +* NGFR number of fast and resonance groups. +* NGRO number of energy groups. +* NBDIL number of dilutions. +* SN actual dilution of the nuclide. +* SB dilution of the nuclide, as used in Livolant-Jeanpierre +* normalization. +* DILUS tabulation points in dilution. +* DELTA lethargy widths. +* NF flag set to 3 if fission information is present. +* XA tabulated absorption effective reaction rates. +* XS tabulated scattering effective reaction rates. +* XF tabulated nu*fission effective reaction rates. +* XN tabulated NJOY flux. +* GAR1 infinite dilution cross sections. +* SCAT infinite dilution P0 differential scattering cross sections. +* +*Parameters: output +* GAR2 interpolated self-shielded cross sections. +* WT0 NJOY flux. +* +*Reference: +* Copyright (C) from NDAS Atomic Energy of Canada Limited utility (2006) +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NGF,NGFR,NGRO,NBDIL,NF + REAL SN(NGRO),SB(NGRO),DILUS(NBDIL),DELTA(NGRO), + 1 XA(NGFR-NGF,NBDIL),XS(NGFR-NGF,NBDIL),XF(NGFR-NGF,NBDIL), + 2 XN(NGFR-NGF,NBDIL),GAR1(NGRO,6),SCAT(NGRO,NGRO),GAR2(NGRO,6), + 3 WT0(NGRO) +*---- +* Local variables +*---- + REAL WW,ZNGAR,SSFACT,AUX,XN3 + INTEGER I,IG,IG2 + CHARACTER HSMG*131 + LOGICAL LCUBIC + PARAMETER(LCUBIC=.TRUE.) + REAL, ALLOCATABLE, DIMENSION(:) :: TERPD,DD,XA2,XS2,XF2,WK + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LINF +*---- +* Scratch storage allocation +*---- + ALLOCATE(TERPD(NBDIL),LINF(NGRO)) +*---- +* Dilution interpolation +*---- + ALLOCATE(DD(NBDIL)) + DO I=1,NBDIL + DD(I)=LOG10(DILUS(I)) + ENDDO + ALLOCATE(XA2(NGRO),XS2(NGRO),XF2(NGRO)) + DO IG=1,NGF + XA2(IG)=GAR1(IG,2) + XS2(IG)=GAR1(IG,5) + XF2(IG)=GAR1(IG,4) + WT0(IG)=1.0 + ENDDO + ALLOCATE(WK(3*NBDIL)) + DO IG=NGF+1,NGFR + TERPD(:NBDIL)=0.0 + LINF(IG)=SN(IG).EQ.DILUS(NBDIL) + DO I=1,NBDIL + IF(ABS(SN(IG)-DILUS(I)).LE.1.0E-5*ABS(SN(IG))) THEN + TERPD(I)=1.0 + GO TO 10 + ENDIF + ENDDO + IF((NBDIL.EQ.1).OR.(SN(IG).GE.DILUS(NBDIL))) THEN +* No interpolation above infinite dilution + TERPD(NBDIL)=1.0 + ELSE IF((NBDIL.EQ.2).OR.(SN(IG).GE.DILUS(NBDIL-1))) THEN +* One over SN interpolation near infinite dilution + LINF(IG)=.TRUE. + TERPD(NBDIL-1)=DILUS(NBDIL-1)/SN(IG) + TERPD(NBDIL)=1.0-DILUS(NBDIL-1)/SN(IG) + ELSE +* Perform Ceschino cubic interpolation + CALL ALTERP(LCUBIC,NBDIL-1,DD,LOG10(SN(IG)),.FALSE., + > TERPD,WK) + ENDIF + 10 XA2(IG)=0.0 + XS2(IG)=0.0 + XF2(IG)=0.0 + WT0(IG)=0.0 + DO I=1,NBDIL + WW=TERPD(I) + IF(ABS(WW).GT.1.0E-6) THEN + XA2(IG)=XA2(IG)+WW*XA(IG-NGF,I) + XS2(IG)=XS2(IG)+WW*XS(IG-NGF,I) + IF(NF.EQ.3) XF2(IG)=XF2(IG)+WW*XF(IG-NGF,I) + WT0(IG)=WT0(IG)+WW*XN(IG-NGF,I) + ENDIF + ENDDO + ENDDO + DEALLOCATE(WK,DD) +*---- +* Livolant-Jeanpierre normalization +*---- + DO IG=NGF+1,NGFR + IF(SB(IG).NE.SN(IG)) THEN + ZNGAR=-(XA2(IG)+XS2(IG)) + DO IG2=1,IG + SSFACT=XS2(IG2)/GAR1(IG2,5) + ZNGAR=ZNGAR+SCAT(IG,IG2)*SSFACT*DELTA(IG2)/DELTA(IG) + ENDDO + XN3=(WT0(IG)-1.0)*SN(IG) + IF(LINF(IG)) THEN +* Use an interpolated value near infinite dilution + AUX=(DILUS(NBDIL-1)/SB(IG))**2 + XN3=AUX*XN3+(1.0-AUX)*ZNGAR + XN3=1.0+XN3/SB(IG) + ELSE + XN3=1.0+XN3/SB(IG) + ENDIF + IF((XN3.LE.0.0).OR.(XN3.GT.2.0)) THEN + WRITE (HSMG,100) XN3,IG,SB(IG),SN(IG) + CALL XABORT(HSMG) + ELSE IF(XN3.GT.1.2) THEN + WRITE (HSMG,100) XN3,IG,SB(IG),SN(IG) + WRITE(6,'(1X,A)') HSMG + ENDIF + WT0(IG)=XN3 + ENDIF + ENDDO +*---- +* Divide effective reaction rates by NJOY flux for obtaining +* self-shielded cross sections +*---- + DO I=1,6 + DO IG=1,NGRO + GAR2(IG,I)=GAR1(IG,2) + ENDDO + ENDDO + DO IG=NGF+1,NGFR +* Absorption xs + GAR2(IG,2)=XA2(IG)/WT0(IG) +* P0 scattering xs + GAR2(IG,5)=XS2(IG)/WT0(IG) +* nu*fission xs + GAR2(IG,4)=XF2(IG)/WT0(IG) +* Transport-corrected total xs + GAR2(IG,1)=GAR1(IG,1)*(GAR2(IG,2)+GAR2(IG,5))/(GAR1(IG,2)+ + > GAR1(IG,5)) +* Fission xs + IF((NF.EQ.3).AND.(XF2(IG).EQ.0.0)) THEN + GAR2(IG,3)=GAR1(IG,3) + ELSE IF(NF.EQ.3) THEN + GAR2(IG,3)=GAR1(IG,3)*GAR2(IG,4)/GAR1(IG,4) + ENDIF +* P1 scattering xs + GAR2(IG,6)=GAR1(IG,6)*GAR2(IG,5)/GAR1(IG,5) + ENDDO + DEALLOCATE(XF2,XS2,XA2) +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(LINF,TERPD) + RETURN +* + 100 FORMAT(37H LIBND3: Invalid value of NJOY flux (,1P,E11.3, + 1 10H) in group,I4,11H. Dilution=,E11.3,2H (,E11.3,2H).) + END diff --git a/Dragon/src/LIBND5.f b/Dragon/src/LIBND5.f new file mode 100644 index 0000000..c78230f --- /dev/null +++ b/Dragon/src/LIBND5.f @@ -0,0 +1,57 @@ +*DECK LIBND5 + SUBROUTINE LIBND5(CFILNA,NEL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Initialize dimensions for depletion data with NDAS library files. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* +*Author(s): A. Hebert +* +*Parameters: input +* CFILNA NDAS file name. +* +*Parameters: output +* NEL number of isotopes on library. +* +*Reference: +* Copyright (C) from NDAS Atomic Energy of Canada Limited utility (2006) +* +*----------------------------------------------------------------------- +* + USE FSDF + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER CFILNA*(*) + INTEGER NEL +*---- +* Local variables +*---- + CHARACTER TEXT12*12 + INTEGER IND,IERR,HEADER(16),IHEAD(200) +*---- +* PROBE AND OPEN THE NDAS FILE. +*---- + CALL XSDOPN(CFILNA,IERR) + IF(IERR.NE.0) THEN + TEXT12=CFILNA + CALL XABORT('LIBND5: NDAS library '//TEXT12//' cannot be'// + > ' opened') + ENDIF + CALL XSDBLD(6001,HEADER,IERR) + IF(IERR.NE.0) CALL XABORT('LIBND5: XSDBLD could not read library' + > //' parameters') + NEL=0 + DO IND=1,HEADER(1) +* Load nuclide header + CALL XSDISO(7000,6001,IND,IHEAD,IERR) + IF(IHEAD(1).NE.0) NEL=NEL+1 + ENDDO + CALL XSDCL() + RETURN + END diff --git a/Dragon/src/LIBND6.f b/Dragon/src/LIBND6.f new file mode 100644 index 0000000..7baeaf5 --- /dev/null +++ b/Dragon/src/LIBND6.f @@ -0,0 +1,165 @@ +*DECK LIBND6 + SUBROUTINE LIBND6(CFILNA,MAXR,NEL,ITNAM,KPAX,BPAX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read depletion data on a NDAS formatted library. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* +*Author(s): A. Hebert +* +*Parameters: input +* CFILNA NDAS file name. +* MAXR number of reaction types. +* NEL number of isotopes on library. +* +*Parameters: output +* ITNAM reactive isotope names in chain. +* KPAX complete reaction type matrix. +* BPAX complete branching ratio matrix. +* +*Reference: +* Copyright (C) from NDAS Atomic Energy of Canada Limited utility (2006) +* +*----------------------------------------------------------------------- +* + USE FSDF + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER MAXR,NEL,ITNAM(3,NEL),KPAX(NEL+MAXR,NEL) + CHARACTER CFILNA*(*) + REAL BPAX(NEL+MAXR,NEL) +*---- +* Local variables +*---- + CHARACTER TEXT8*8,TEXT12*12 + INTEGER IND,J,IERR,HEADER(16),IHEAD(200),ISO,JSO,ISOID,NBCHIL, + > LIBWID +*---- +* INTERNAL PARAMETERS +* CONVE : ENERGY CONVERSION FACTOR FROM JOULES/(MOLES*10**-24) +* TO MEV/NUCLIDE = 1.03643526E+13 +* CONVD : DECAY CONSTANT CONVERSION FACTOR FROM S**(-1) TO +* 10**(-8)*S**(-1) = 1.0+8 +*---- + INTEGER KCAPTU,KDECAY,KFISSP,KN2N + REAL CONVE,CONVD + PARAMETER(KCAPTU=3,KDECAY=1,KFISSP=2,KN2N=4,CONVE=1.03643526E+13, + > CONVD=1.0E+8) + INTEGER NDECAY + DOUBLE PRECISION TOTLAM + EXTERNAL LIBWID + INTEGER, ALLOCATABLE, DIMENSION(:) :: CHILDR,IWISO + REAL, ALLOCATABLE, DIMENSION(:) :: BURNDA +*---- +* Scratch storage allocation +*---- + ALLOCATE(CHILDR(2*NEL),IWISO(NEL)) + ALLOCATE(BURNDA(2*NEL)) +*---- +* Open and probe the NDAS file +*---- + CALL XSDOPN(CFILNA,IERR) + IF(IERR.NE.0) THEN + TEXT12=CFILNA + CALL XABORT('LIBND6: NDAS library '//TEXT12//' cannot be'// + > ' opened') + ENDIF + CALL XSDBLD(6001,HEADER,IERR) + IF(IERR.NE.0) CALL XABORT('LIBND6: XSDBLD could not read library' + > //' parameters') + ISO=0 + DO IND=1,HEADER(1) +* Load nuclide header + CALL XSDISO(7000,6001,IND,IHEAD,IERR) + NBCHIL=IHEAD(1) + IF(NBCHIL.GT.NEL) CALL XABORT('LIBND6: Children overflow') + IF(NBCHIL.NE.0) THEN + ISO=ISO+1 + IF(ISO.GT.NEL) CALL XABORT('LIBND6: NEL overflow') + CALL XSDNAM(IND,IWISO(ISO),TEXT8,IERR) + IF(IERR.NE.0) CALL XABORT('LIBND6: XSDNAM index overflow') + ENDIF + ENDDO + ISO=0 + DO IND=1,HEADER(1) +* Load nuclide header + CALL XSDISO(7000,6001,IND,IHEAD,IERR) + NBCHIL=IHEAD(1) + IF(NBCHIL.NE.0) THEN + ISO=ISO+1 + NDECAY=0 + TOTLAM=0.0D0 + CALL XSDNAM(IND,ISOID,TEXT8,IERR) + READ(TEXT8,'(2A4)') ITNAM(1,ISO),ITNAM(2,ISO) +* Load burnup children data + CALL XSDISO(7000,5002,IND,CHILDR,IERR) +* Load burnup coefficients + CALL XSDISO(7000,5003,IND,BURNDA,IERR) + DO J=1,2*NBCHIL,2 + JSO=LIBWID(NEL,IWISO,CHILDR(J)) + IF(CHILDR(J+1).EQ.1) THEN + IF(JSO.GT.0) THEN + KPAX(JSO,ISO)=KCAPTU + BPAX(JSO,ISO)=BURNDA(J) + KPAX(NEL+KCAPTU,JSO)=1 + ENDIF + KPAX(NEL+KCAPTU,ISO)=1 + ELSE IF(CHILDR(J+1).EQ.2) THEN + NDECAY=NDECAY+1 + TOTLAM=TOTLAM+DBLE(BURNDA(J)) + IF(JSO.GT.0) THEN + KPAX(JSO,ISO)=KDECAY + BPAX(JSO,ISO)=BURNDA(J) + KPAX(NEL+KCAPTU,JSO)=1 + ENDIF + KPAX(NEL+KDECAY,ISO)=1 + ELSE IF(CHILDR(J+1).EQ.3) THEN + IF(JSO.GT.0) THEN + KPAX(JSO,ISO)=KFISSP + BPAX(JSO,ISO)=BURNDA(J) + KPAX(NEL+KFISSP,JSO)=-1 + KPAX(NEL+KCAPTU,JSO)=1 + ENDIF + ELSE IF(CHILDR(J+1).EQ.4) THEN + KPAX(NEL+KFISSP,ISO)=1 + BPAX(NEL+KFISSP,ISO)=BURNDA(J)*CONVE + ELSE IF(CHILDR(J+1).EQ.5) THEN + IF(JSO.GT.0) THEN + KPAX(JSO,ISO)=KN2N + BPAX(JSO,ISO)=BURNDA(J) + KPAX(NEL+KCAPTU,JSO)=1 + ENDIF + KPAX(NEL+KN2N,ISO)=1 + ENDIF + ENDDO + IF(NDECAY .EQ. 1) THEN + BPAX(NEL+KDECAY,ISO)=REAL(TOTLAM)*CONVD + DO JSO=1,NEL + IF(KPAX(JSO,ISO).EQ. KDECAY) THEN + BPAX(JSO,ISO)=1.0 + ENDIF + ENDDO + ELSE IF(NDECAY .GT. 1) THEN + BPAX(NEL+KDECAY,ISO)=REAL(TOTLAM)*CONVD + DO JSO=1,NEL + IF(KPAX(JSO,ISO).EQ. KDECAY) THEN + BPAX(JSO,ISO)=BPAX(JSO,ISO)/REAL(TOTLAM) + ENDIF + ENDDO + ENDIF + ENDIF + ENDDO + CALL XSDCL() +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(BURNDA) + DEALLOCATE(IWISO,CHILDR) + RETURN + END diff --git a/Dragon/src/LIBND7.f b/Dragon/src/LIBND7.f new file mode 100644 index 0000000..730641c --- /dev/null +++ b/Dragon/src/LIBND7.f @@ -0,0 +1,91 @@ +*DECK LIBND7 + SUBROUTINE LIBND7 (MAXDIL,NGRO,NAMFIL,HNISOR,NDIL,DILUT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find the dilutions corresponding to a resonant isotope within a +* library in NDAS format. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXDIL maximum number of dilutions. +* NGRO number of energy groups. +* NAMFIL NDAS library name. +* HNISOR library name of the isotope. +* +*Parameters: output +* NDIL number of finite dilutions. +* DILUT dilutions. +* +*Reference: +* Copyright (C) from NDAS Atomic Energy of Canada Limited utility (2006) +* +*----------------------------------------------------------------------- +* + USE FSDF + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + CHARACTER NAMFIL*(*),HNISOR*12 + INTEGER MAXDIL,NGRO,NDIL + REAL DILUT(MAXDIL) +*---- +* Local variables +*---- + INTEGER I,IND,IERR,ISOID,HEADER(16),NISOLB,NF,NTEM,IHEAD(200) + REAL RHEAD(200) + CHARACTER HSMG*131,TEXT8*8 + EQUIVALENCE(RHEAD(1),IHEAD(1)) +*---- +* Read NDAS library parameters +*---- + CALL XSDOPN(NAMFIL,IERR) + IF(IERR.NE.0) CALL XABORT('LIBND7: XSDOPN could not open Library' + > //' files') + CALL XSDBLD(6001,HEADER,IERR) + IF(IERR.NE.0) CALL XABORT('LIBND7: XSDBLD could not read library' + > //' parameters') + IF(NGRO.NE.HEADER(2)) CALL XABORT('LIBND7: Invalid number of e' + > //'nergy groups') + NISOLB=HEADER(1) +*---- +* Read through NDAS file +*---- + IND=0 + DO I=1,NISOLB + CALL XSDNAM(I,ISOID,TEXT8,IERR) + IF(IERR.NE.0) CALL XABORT('LIBND7: XSDNAM index overflow') + IF(TEXT8.EQ.HNISOR(:8)) THEN + IND=I + GO TO 10 + ENDIF + ENDDO + WRITE (HSMG,100) HNISOR,NAMFIL + CALL XABORT(HSMG) +* Load nuclide header + 10 CALL XSDISO(7000,6001,IND,RHEAD,IERR) + NF=IHEAD(5) + IF((NF.GE.1).AND.(NF.LE.3)) THEN + CALL XSDRES(IND,IHEAD,IERR) + NTEM=IHEAD(1) + NDIL=IHEAD(2) + IF(NDIL.GT.MAXDIL) CALL XABORT('LIBND7: MAXDIL overflow') + DO I=1,NDIL + DILUT(I)=RHEAD(2+NTEM+I) + ENDDO + NDIL=NDIL-1 + ELSE + NDIL=0 + ENDIF + CALL XSDCL() + RETURN +* + 100 FORMAT(26HLIBND7: Material/isotope ',A12,20H' is missing on NDAS, + > 12H file named ,A24,1H.) + END diff --git a/Dragon/src/LIBNFI.f b/Dragon/src/LIBNFI.f new file mode 100644 index 0000000..dbb0aef --- /dev/null +++ b/Dragon/src/LIBNFI.f @@ -0,0 +1,194 @@ +*DECK LIBNFI + SUBROUTINE LIBNFI(IPLIB,NGRO,NBISO,NBMIX,NDEL,NESP,IPISO,MIX, + 1 MAXNFI,NFISSI,LSAME) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the maximum number of fissionable isotopes in a mixture. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* NGRO number of energy groups. +* NBISO number of isotopes present in the calculation domain. +* NBMIX number of mixtures present in the calculation domain. +* NDEL number of delayed precursor groups. +* NESP number of energy-dependent fission spectra. +* IPISO pointer array towards microlib isotopes. +* MIX mixture number of each isotope (can be zero for void). +* MAXNFI second dimension of array INDFIS. +* +*Parameters: output +* NFISSI maximum number of fissionable isotopes in a mixture. +* LSAME fission spectrum mask (=.true. if all the isotopes have the +* same fission spectrum and the same precursor group decay +* constants. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB,IPISO(NBISO) + INTEGER NGRO,NBISO,NBMIX,NDEL,NESP,MIX(NBISO),MAXNFI,NFISSI + LOGICAL LSAME +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPLIB + INTEGER MAXGRO,NSTATE + PARAMETER (MAXGRO=50,NSTATE=40) + CHARACTER HSMG*131,TEXT12*12 + REAL CHI2(MAXGRO),LAM1(MAXGRO),LAM2(MAXGRO) + INTEGER IDATA(NSTATE),ISOT,IBM,IFIS,IGR,ILONG,ITYLCM,IWFIS,JBM, + 1 KFIS,LENGT1,LENGT2,LENGTZ + LOGICAL LFISS +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IWRK + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: INDFIS + REAL, ALLOCATABLE, DIMENSION(:) :: CHI1 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(INDFIS(NBMIX,MAXNFI),CHI1(NGRO)) +* + NFISSI=0 + CALL LCMLEN(IPLIB,'MACROLIB',ILONG,ITYLCM) + LSAME=(NGRO.LE.MAXGRO).AND.(NDEL.LE.MAXGRO) + IF(ILONG.EQ.-1) THEN + CALL LCMSIX(IPLIB,'MACROLIB',1) + CALL LCMGTC(IPLIB,'SIGNATURE',12,TEXT12) + IF(TEXT12.NE.'L_MACROLIB') THEN + CALL XABORT('LIBNFI: INVALID SIGNATURE ON THE MACROLIB.') + ENDIF + CALL LCMGET(IPLIB,'STATE-VECTOR',IDATA) + IF(IDATA(1).NE.NGRO) THEN + WRITE(HSMG,'(38HLIBNFI: EXISTING MACROLIB HAVE NGROUP=,I4, + 1 26H NEW MACROLIB HAVE NGROUP=,I4,1H.)') IDATA(1),NGRO + CALL XABORT(HSMG) + ELSE IF(IDATA(2).GT.NBMIX) THEN + WRITE(HSMG,'(37HLIBNFI: EXISTING MACROLIB HAVE NBMIX=,I4, + 1 25H NEW MACROLIB HAVE NBMIX=,I4,1H.)') IDATA(2),NBMIX + CALL XABORT(HSMG) + ELSE IF(IDATA(4).GT.NBISO*NESP) THEN + WRITE(HSMG,'(38HLIBNFI: EXISTING MACROLIB HAVE NFISSI=,I4, + 1 13H GREATER THAN,I5,1H.)') IDATA(4)/NESP,NBISO + CALL XABORT(HSMG) + ENDIF + NFISSI=IDATA(4)/NESP + LSAME=LSAME.AND.(NFISSI.LE.1) + IF(NFISSI.GT.0) THEN + CALL LCMLEN(IPLIB,'FISSIONINDEX',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN +* THE NAMES ARE NOT DEFINED. + DO 15 IFIS=1,NFISSI + DO 10 IBM=1,NBMIX + INDFIS(IBM,IFIS)=0 + 10 CONTINUE + 15 CONTINUE + ELSE IF(ILONG.EQ.NFISSI*NBMIX) THEN + CALL LCMGET(IPLIB,'FISSIONINDEX',INDFIS) + ELSE IF(ILONG.LT.NFISSI*NBMIX) THEN +* REORDER THE 'FISSIONINDEX' MATRIX. + ALLOCATE(IWRK(ILONG)) + CALL LCMGET(IPLIB,'FISSIONINDEX',IWRK) + DO 31 IFIS=1,NFISSI + DO 20 IBM=1,IDATA(2) + INDFIS(IBM,IFIS)=IWRK((IFIS-1)*IDATA(2)+IBM) + 20 CONTINUE + DO 30 IBM=IDATA(2)+1,NBMIX + INDFIS(IBM,IFIS)=0 + 30 CONTINUE + 31 CONTINUE + DEALLOCATE(IWRK) + ELSE + CALL XABORT('LIBNFI: INVALID NUMBER OF MIXTURES.') + ENDIF + ENDIF + CALL LCMSIX(IPLIB,' ',2) + ENDIF + DO 100 ISOT=1,NBISO + IBM=MIX(ISOT) + IF(IBM.GT.0) THEN + JPLIB=IPISO(ISOT) + IF(C_ASSOCIATED(JPLIB)) THEN + CALL LCMLEN(JPLIB,'NUSIGF',ILONG,ITYLCM) + IF(NESP.EQ.1) THEN + CALL LCMLEN(JPLIB,'CHI',LENGTZ,ITYLCM) + ELSE + CALL LCMLEN(JPLIB,'CHI--01',LENGTZ,ITYLCM) + ENDIF + IF((ILONG.GT.0).AND.(LENGTZ.GT.0)) THEN + IF(NESP.EQ.1) THEN + CALL LCMGET(JPLIB,'CHI',CHI1) + ELSE + CALL LCMGET(JPLIB,'CHI--01',CHI1) + ENDIF + LFISS=.FALSE. + DO 35 IGR=1,NGRO + LFISS=LFISS.OR.(CHI1(IGR).GT.0.0) + 35 CONTINUE + IF(.NOT.LFISS) GO TO 100 + IF(LSAME) THEN + CALL LCMLEN(JPLIB,'LAMBDA-D',LENGT1,ITYLCM) + IF((LENGT1.EQ.NDEL).AND.(NDEL.GT.0)) THEN + CALL LCMGET(JPLIB,'LAMBDA-D',LAM1) + ENDIF + ENDIF + DO 40 IFIS=1,NFISSI + IWFIS=INDFIS(IBM,IFIS) + IF((IWFIS.EQ.ISOT).OR.(IWFIS.EQ.0)) THEN + KFIS=IFIS + GO TO 90 + ENDIF + 40 CONTINUE + IF(LSAME) THEN + DO 70 IFIS=1,NFISSI + IWFIS=INDFIS(IBM,IFIS) + JPLIB=IPISO(IWFIS) + CALL LCMGET(JPLIB,'CHI',CHI2) + DO 50 IGR=1,NGRO + LSAME=LSAME.AND.(ABS(CHI1(IGR)-CHI2(IGR)).LE.1.0E-3) + 50 CONTINUE + CALL LCMLEN(JPLIB,'LAMBDA-D',LENGT2,ITYLCM) + IF((LENGT1.EQ.NDEL).AND.(LENGT2.EQ.NDEL) + 1 .AND.(NDEL.GT.0)) THEN + CALL LCMGET(JPLIB,'LAMBDA-D',LAM2) + DO 60 IGR=1,NDEL + LSAME=LSAME.AND.(LAM1(IGR).EQ.LAM2(IGR)) + 60 CONTINUE + ENDIF + 70 CONTINUE + ENDIF + NFISSI=NFISSI+1 + IF(NFISSI.GT.MAXNFI) CALL XABORT('LIBNFI: INDFIS OVERFL' + 1 //'OW.') + KFIS=NFISSI + DO 80 JBM=1,NBMIX + INDFIS(JBM,KFIS)=0 + 80 CONTINUE + 90 INDFIS(IBM,KFIS)=ISOT + ENDIF + ENDIF + ENDIF + 100 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(CHI1,INDFIS) + RETURN + END diff --git a/Dragon/src/LIBNOT.f b/Dragon/src/LIBNOT.f new file mode 100644 index 0000000..6ac7da0 --- /dev/null +++ b/Dragon/src/LIBNOT.f @@ -0,0 +1,140 @@ +*DECK LIBNOT + SUBROUTINE LIBNOT (IPLIB,NGRO,NL,NDIL,NED,NDEL,IMPX,LSCAT,LSIGF, + 1 LADD,DILUT,FLUX,TOTAL,SIGF,SIGS,SCAT,SADD,ZDEL,HVECT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Write the incremental x-s data on a temperature-independant Draglib. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the internal library (L_LIBRARY signature). +* NGRO number of energy groups. +* NL number of Legendre orders required in the calculation +* (NL=1 or higher). +* NDIL number of finite dilutions. +* NED number of extra vector edits. +* NDEL number of delayed neutron precursor groups. +* IMPX print flag. +* LSCAT Legendre flag (=.true. if a given Legendre order of the +* scattering cross section exists). +* LSIGF fission flag (=.true. if the isotope can fission). +* LADD additional xs flag (=.true. if a given additional cross +* section exists). +* DILUT dilutions. +* FLUX weighting flux. +* TOTAL total cross sections. +* SIGF nu*fission cross sections. +* SIGS diffusion cross sections. +* SCAT scattering transfer matrices (sec,prim,Legendre,dilution). +* SADD additional cross sections. +* ZDEL delayed nu-sigf cross sections. +* HVECT names of the extra vector edits. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + INTEGER NGRO,NL,NDIL,NED,NDEL,IMPX + REAL DILUT(NDIL+1),FLUX(NGRO,NDIL+1),TOTAL(NGRO,NDIL+1), + 1 SIGF(NGRO,NDIL+1),SIGS(NGRO,NL,NDIL+1),SCAT(NGRO,NGRO,NL,NDIL+1), + 2 SADD(NGRO,NED,NDIL+1),ZDEL(NGRO,NDEL,NDIL+1) + LOGICAL LSIGF,LSCAT(NL),LADD(NED) + CHARACTER HVECT(NED)*8 +*---- +* LOCAL VARIABLES +*---- + CHARACTER TEXT12*12,CD*4 + INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPRO + REAL, ALLOCATABLE, DIMENSION(:) :: GAS + REAL, ALLOCATABLE, DIMENSION(:,:) :: GA1 + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: GA2 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(ITYPRO(NL)) + ALLOCATE(GAS(NGRO),GA1(NGRO,NL),GA2(NGRO,NGRO,NL)) +* + CALL LCMPUT(IPLIB,'DILUTION',NDIL,2,DILUT) + DO 130 IDIL=1,NDIL + WRITE (CD,'(I4.4)') IDIL + CALL LCMSIX(IPLIB,'SUBMAT'//CD,1) + DO 10 IG1=1,NGRO + GAS(IG1)=FLUX(IG1,IDIL)-1.0 + 10 CONTINUE + CALL LCMPUT(IPLIB,'NWT0',NGRO,2,GAS) + DO 20 IG1=1,NGRO + GAS(IG1)=TOTAL(IG1,IDIL)*FLUX(IG1,IDIL)-TOTAL(IG1,NDIL+1) + 20 CONTINUE + CALL LCMPUT(IPLIB,'NTOT0',NGRO,2,GAS) + IF(LSIGF) THEN + DO 30 IG1=1,NGRO + GAS(IG1)=SIGF(IG1,IDIL)*FLUX(IG1,IDIL)-SIGF(IG1,NDIL+1) + 30 CONTINUE + CALL LCMPUT(IPLIB,'NUSIGF',NGRO,2,GAS) + ENDIF + INGRO=NL-1 + DO 40 IL=NL-1,0,-1 + IF(.NOT.LSCAT(IL+1)) THEN + INGRO=INGRO-1 + ELSE + GO TO 50 + ENDIF + 40 CONTINUE + 50 DO 80 IL=1,INGRO+1 + IF(LSCAT(IL)) THEN + DO 65 IG1=1,NGRO + GA1(IG1,IL)=SIGS(IG1,IL,IDIL)*FLUX(IG1,IDIL)- + 1 SIGS(IG1,IL,NDIL+1) + DO 60 IG2=1,NGRO + GA2(IG1,IG2,IL)=SCAT(IG1,IG2,IL,IDIL)*FLUX(IG2,IDIL)- + 1 SCAT(IG1,IG2,IL,NDIL+1) + 60 CONTINUE + 65 CONTINUE + ELSE + DO 75 IG1=1,NGRO + GA1(IG1,IL)=0.0 + DO 70 IG2=1,NGRO + GA2(IG1,IG2,IL)=0.0 + 70 CONTINUE + 75 CONTINUE + ENDIF + 80 CONTINUE + CALL XDRLGS(IPLIB,1,IMPX,0,INGRO,1,NGRO,GA1,GA2,ITYPRO) + DO 100 IED=1,NED + IF(LADD(IED)) THEN + DO 90 IG1=1,NGRO + GAS(IG1)=SADD(IG1,IED,IDIL)*FLUX(IG1,IDIL)-SADD(IG1,IED,NDIL+1) + 90 CONTINUE + CALL LCMPUT(IPLIB,HVECT(IED),NGRO,2,GAS) + ENDIF + 100 CONTINUE + DO 120 IDEL=1,NDEL + WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL + DO 110 IG1=1,NGRO + GAS(IG1)=ZDEL(IG1,IDEL,IDIL)*FLUX(IG1,IDIL)-ZDEL(IG1,IDEL,NDIL+1) + 110 CONTINUE + CALL LCMPUT(IPLIB,TEXT12,NGRO,2,GAS) + 120 CONTINUE + CALL LCMSIX(IPLIB,' ',2) + 130 CONTINUE + IF(IMPX.GT.3) CALL LCMLIB(IPLIB) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GA2,GA1,GAS) + DEALLOCATE(ITYPRO) + RETURN + END diff --git a/Dragon/src/LIBNRG.F b/Dragon/src/LIBNRG.F new file mode 100644 index 0000000..fc00e9d --- /dev/null +++ b/Dragon/src/LIBNRG.F @@ -0,0 +1,406 @@ +*DECK LIBNRG + SUBROUTINE LIBNRG(IPLIB,NAMLBT,NAMFIL,NGROUP,NGT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Test for energy mesh compatibility. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input/output +* IPLIB pointer to the internal library. +* NAMLBT library type. +* NAMFIL library file name. +* NGROUP total number of groups. +* NGT number of groups to test. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE LIBEEDR +#if defined(HDF5_LIB) + USE hdf5_wrap +#endif /* defined(HDF5_LIB) */ +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + INTEGER NGROUP,NGT + CHARACTER NAMLBT*8,NAMFIL*(*) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IOUT=6,LRIND=256,IACTO=2,IACTC=1,ILIBDA=4, + > NMTYP=8) + CHARACTER HSMG*131,HMTYP(NMTYP)*1,HFORMAT*132 +#if defined(HDF5_LIB) + CHARACTER CFILNA1*64 +#endif /* defined(HDF5_LIB) */ +*---- +* LIBRARY PARAMETERS +*---- + PARAMETER (MAXISO=246,NCT=10,LPZ=9,LMASTB=MAXISO+9, + > LMASIN=LMASTB-4,LGENTB=6,LGENIN=LGENTB, + > MAXA=10000,MULT=2) + TYPE(C_PTR) IPDRL + CHARACTER HPRT*6,NAMLCM*12,NAMMY*12 + LOGICAL EMPTY,LCM,LEXIST + INTEGER ILONG,MASTER(LMASTB),GENINX(LGENTB),NPZ(LPZ), + > IA(MAXA) + REAL RA(MAXA) + DOUBLE PRECISION DA(MAXA/2) + EQUIVALENCE (RA(1),IA(1),DA(1)) +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, POINTER, DIMENSION(:) :: ENERG + REAL, ALLOCATABLE, DIMENSION(:) :: UUU,TEMPE,EIER + TYPE(C_PTR) IPENER +*---- +* DATA STATEMENTS +*---- + SAVE HMTYP + DATA HMTYP /'N','n','G','g','B','b','C','c'/ +* + NGRI=0 + ILIBIN=2 +*---- +* READ LIBRARY GROUP STRUCTURE +*---- + IF((NAMLBT.EQ.'DRAGON').OR.(NAMLBT.EQ.'MICROLIB')) THEN +*--- +* DRAGON LIBRARY +*---- + CALL LCMINF(IPLIB,NAMLCM,NAMMY,EMPTY,ILONG,LCM) + IF(NAMFIL.EQ.NAMLCM) THEN + IPDRL=IPLIB + ELSE + INQUIRE(FILE=TRIM(NAMFIL),EXIST=LEXIST) + IF(.NOT.LEXIST) THEN + WRITE(HSMG,'(17HLIBNRG: XSM FILE ,A,14H DOESNT EXIST.)') + > TRIM(NAMFIL) + CALL XABORT(HSMG) + ENDIF + CALL LCMOP(IPDRL,NAMFIL,2,2,0) + ENDIF + CALL LCMLEN(IPDRL,'ENERGY',LENGT,ITYLCM) + IF(LENGT.EQ.0) THEN + CALL LCMLIB(IPDRL) + CALL XABORT('LIBNRG: NO GROUP STRUCTURE AVAILABLE') + ENDIF + NGRI=LENGT-1 + ALLOCATE(ENERG(LENGT)) + CALL LCMGET(IPDRL,'ENERGY',ENERG) + IF(NAMFIL.NE.NAMLCM) CALL LCMCL(IPDRL,1) + ELSE IF(NAMLBT.EQ.'WIMSAECL') THEN +*--- +* WIMS-AECL LIBRARY +*---- + IUNIT=KDROPN(NAMFIL,IACTO,ILIBDA,LRIND) + IF(IUNIT.LE.0) THEN + HFORMAT='(27HLIBNRG: WIMS-AECL LIBRARY '',A16,8H'' CANNOT'// + > '30H BE OPENED BY KDROPN (ERRCODE=,I2,2H).)' + WRITE(HSMG,HFORMAT) NAMFIL,IUNIT + CALL XABORT(HSMG) + ENDIF + CALL OPNIND(IUNIT,MASTER,LMASTB) + CALL REDIND(IUNIT,MASTER,LMASIN,GENINX,LGENTB,1) + CALL REDIND(IUNIT,GENINX,LGENIN,NPZ,LPZ,1) + NGRI=NPZ(2) + ALLOCATE(ENERG(NGRI+1)) + CALL REDIND(IUNIT,GENINX,LGENIN,ENERG,NGRI+1,4) + CALL CLSIND(IUNIT) + ELSE IF((NAMLBT.EQ.'WIMSD4').OR.(NAMLBT.EQ.'WIMSE')) THEN +*--- +* WIMSD4 OR WIMSE LIBRARY +*---- + IUNIT=KDROPN(NAMFIL,IACTO,ILIBIN,LRIND) + IF(IUNIT.LE.0) THEN + HFORMAT='(22HLIBNRG: WIMS LIBRARY '',A16,9H'' CANNOT '// + > '29HBE OPENED BY KDROPN (ERRCODE=,I2,2H).)' + WRITE(HSMG,HFORMAT) NAMFIL,IUNIT + CALL XABORT(HSMG) + ENDIF + READ(IUNIT) (NPZ(II),II=1,LPZ-1) + NGRI=NPZ(2) + READ(IUNIT) ITEMP + ALLOCATE(ENERG(NGRI+1)) + READ(IUNIT) (ENERG(J),J=1,NGRI+1) + IERR=KDRCLS(IUNIT,IACTC) + IF(IERR.LT.0) THEN + HFORMAT='(22HLIBNRG: WIMS LIBRARY '',A16,9H'' CANNOT '// + > '29HBE CLOSED BY KDRCLS (ERRCODE=,I2,2H).)' + WRITE(HSMG,HFORMAT) NAMFIL,IERR + CALL XABORT(HSMG) + ENDIF + ELSE IF(NAMLBT.EQ.'APLIB1') THEN +*--- +* APOLLO-1 LIBRARY +*---- + IUNIT=KDROPN(NAMFIL,IACTO,ILIBIN,LRIND) + IF(IUNIT.LE.0) THEN + HFORMAT='(26HLIBNRG: APOLLO-1 LIBRARY '',A16,9H'' CANNOT '// + > '29HBE OPENED BY KDROPN (ERRCODE=,I2,2H).)' + WRITE(HSMG,HFORMAT) NAMFIL,IUNIT + CALL XABORT(HSMG) + ENDIF + REWIND(IUNIT) + 100 CONTINUE + READ(IUNIT) INDLOR,NR,NIA,(IA(I),I=1,NIA) + IF(NIA.GT.MAXA) + > CALL XABORT('LIBNRG: DIMENSION MAXA =1000 TOO SMALL') + IF(INDLOR.EQ.9999) + > CALL XABORT('LIBNRG: NO GROUP STRUCTURE AVAILABLE') + NGRI=IA(1) + IF(IA(3).EQ.0) THEN + DO 110 K=1,NR + READ(IUNIT) + 110 CONTINUE + GO TO 100 + ELSE + ALLOCATE(ENERG(NGRI+1),UUU(NGRI)) + READ(IUNIT) E0,DEL,(UUU(I),I=1,NGRI) + E0=1.0E+6*E0 + ENERG=E0 + DO 120 IG=1,NGRI + ENERG(IG+1)=E0*EXP(-UUU(IG)) + 120 CONTINUE + DEALLOCATE(UUU) + ENDIF + IERR=KDRCLS(IUNIT,IACTC) + IF(IERR.LT.0) THEN + HFORMAT='(26HLIBNRG: APOLLO-1 LIBRARY '',A16,9H'' CANNOT '// + > '29HBE CLOSED BY KDRCLS (ERRCODE=,I2,2H).)' + WRITE(HSMG,HFORMAT) NAMFIL,IERR + CALL XABORT(HSMG) + ENDIF + ELSE IF(NAMLBT.EQ.'APLIB2') THEN +*--- +* APOLLO-2 LIBRARY +*---- + CALL LIBA2G(NAMFIL,NGRI,IPENER) + CALL C_F_POINTER(IPENER,ENERG,(/ NGRI+1 /)) + ELSE IF(NAMLBT.EQ.'APXSM') THEN +*--- +* APOLLO-XSM LIBRARY +*---- + CALL LIBXS3(NAMFIL,NGRI,IPENER) + CALL C_F_POINTER(IPENER,ENERG,(/ NGRI+1 /)) + ELSE IF(NAMLBT.EQ.'APLIB3') THEN +*--- +* APOLLO-3 LIBRARY +*---- +#if defined(HDF5_LIB) + IND=INDEX(NAMFIL, ":") + IF(IND.EQ.0) THEN + CFILNA1=NAMFIL + ELSE + CFILNA1=NAMFIL(:IND-1) + ENDIF + CALL hdf5_open_file(CFILNA1, IPDRL, .TRUE.) + CALL hdf5_read_data(IPDRL, "EnergyMesh/nbGr", NGRI) + ALLOCATE(ENERG(NGRI+1)) + CALL hdf5_read_data(IPDRL, "EnergyMesh/EnMshInMeV", EIER) + ENERG(:NGRI+1)=EIER(:NGRI+1)*1.E6 + DEALLOCATE(EIER) + CALL hdf5_close_file(IPDRL) +#else + CALL XABORT('LIBNRG: THE HDF5 API IS NOT AVAILABLE.') +#endif /* defined(HDF5_LIB) */ + ELSE IF(NAMLBT.EQ.'MATXS') THEN +*--- +* MATXS LIBRARY +*---- + IUNIT=KDROPN(NAMFIL,IACTO,ILIBIN,LRIND) + IF(IUNIT.LE.0) THEN + HFORMAT='(23HLIBNRG: MATXS LIBRARY '',A16,11H'' CANNOT BE'// + > '27H OPENED BY KDROPN (ERRCODE=,I2,2H).)' + WRITE(HSMG,HFORMAT) NAMFIL,IUNIT + CALL XABORT(HSMG) + ENDIF + NWDS=3 + IREC=2 + CALL XDREED(IUNIT,IREC,RA,NWDS) + NPART=IA(1) + NTYPE=IA(2) + IREC=4 + NWDS=(NPART+NTYPE)*MULT+6*NTYPE+NPART + IF(NWDS.GT.MAXA) + > CALL XABORT('LIBNRG: INSUFFICIENT VALUE OF MAXA(1).') + CALL XDREED(IUNIT,IREC,RA,NWDS) + NEX1=(NPART+NTYPE)*MULT+6*NTYPE + DO 180 I=1,NPART + NGX=IA(NEX1+I) + WRITE(HPRT,'(A6)') DA(I) + IREC=IREC+1 + IF(HPRT.EQ.'NEUT'.OR.HPRT.EQ.'neut'.OR. + > HPRT.EQ.'N'.OR.HPRT.EQ.'n') THEN + IF(NGRI.EQ.0) THEN + NGRI=NGX + ALLOCATE(ENERG(NGRI+1)) + CALL XDREED(IUNIT,IREC,ENERG,NGRI+1) + ELSE + IF(NGX.NE.NGRI) + > CALL XABORT('LIBNRG: INVALID GROUP STRUCTURE.') + ALLOCATE(TEMPE(NGRI+1)) + CALL XDREED(IUNIT,IREC,TEMPE,NGRI+1) + DO 170 IG=0,NGRI + IF(TEMPE(IG+1).NE.ENERG(IG+1)) + > CALL XABORT('LIBNRG: INVALID GROUP STRUCTURE.') + 170 CONTINUE + DEALLOCATE(TEMPE) + ENDIF + ENDIF + 180 CONTINUE + CALL XDRCLS(IUNIT) + IERR=KDRCLS(IUNIT,IACTC) + IF(IERR.LT.0) THEN + HFORMAT='(23HLIBNRG: MATXS LIBRARY '',A16,11H'' CANNOT BE'// + > '27H CLOSED BY KDRCLS (ERRCODE=,I2,2H).)' + WRITE(HSMG,HFORMAT) NAMFIL,IERR + CALL XABORT(HSMG) + ENDIF + ELSE IF(NAMLBT.EQ.'MATXS2') THEN +*--- +* MATXS2 LIBRARY +*---- + IF(NAMFIL(:1).EQ.'_') ILIBIN=3 + IUNIT=KDROPN(NAMFIL,IACTO,ILIBIN,LRIND) + IF(IUNIT.LE.0) THEN + HFORMAT='(24HLIBNRG: MATXS2 LIBRARY '',A16,10H'' CANNOT B'// + > '28HE OPENED BY KDROPN (ERRCODE=,I2,2H).)' + WRITE(HSMG,HFORMAT) NAMFIL,IUNIT + CALL XABORT(HSMG) + ENDIF + NWDS=6 + IREC=2 + IF(ILIBIN.EQ.2) THEN + CALL XDREED(IUNIT,IREC,RA,NWDS) + ELSE IF(ILIBIN.EQ.3) THEN + CALL LIBEED(IUNIT,IREC,RA,NWDS) + ENDIF + NPART=IA(1) + NTYPE=IA(2) + NMAT=IA(4) + IREC=4 + NWDS=(NPART+NTYPE+NMAT)*MULT+2*NTYPE+NPART+2*NMAT + IF(NWDS.GT.MAXA) + > CALL XABORT('LIBNRG: INSUFFICIENT VALUE OF MAXA(2).') + NEX1=(NPART+NTYPE+NMAT)*MULT + IF(ILIBIN.EQ.2) THEN + CALL XDREED(IUNIT,IREC,RA,NWDS) + ELSE IF(ILIBIN.EQ.3) THEN + CALL LIBEED(IUNIT,IREC,RA,NWDS) + ENDIF + NGX=IA(NEX1+1) ! use the energy mesh of the first particle + WRITE(HPRT,'(A6)') DA(1) ! name of the first particle + IREC=IREC+1 + DO 195 IMTYP=1,NMTYP + IF(HPRT.EQ.HMTYP(IMTYP)) THEN + IF(NGRI.EQ.0) THEN + NGRI=NGX + ALLOCATE(ENERG(NGRI+1)) + IF(ILIBIN.EQ.2) THEN + CALL XDREED(IUNIT,IREC,ENERG,NGRI+1) + ELSE + CALL LIBEED(IUNIT,IREC,ENERG,NGRI+1) + ENDIF + ELSE + IF(NGX.NE.NGRI) + > CALL XABORT('LIBNRG: INVALID GROUP STRUCTURE.') + ALLOCATE(TEMPE(NGRI+1)) + IF(ILIBIN.EQ.2) THEN + CALL XDREED(IUNIT,IREC,TEMPE,NGRI+1) + ELSE + CALL LIBEED(IUNIT,IREC,TEMPE,NGRI+1) + ENDIF + DO 190 IG=0,NGRI + IF(TEMPE(IG+1).NE.ENERG(IG+1)) + > CALL XABORT('LIBNRG: INVALID GROUP STRUCTURE.') + 190 CONTINUE + DEALLOCATE(TEMPE) + ENDIF + ENDIF + 195 CONTINUE + IF(ILIBIN.EQ.2) THEN + CALL XDRCLS(IUNIT) + ELSE + CALL LIBCLS() + ENDIF + IERR=KDRCLS(IUNIT,IACTC) + IF(IERR.LT.0) THEN + HFORMAT='(24HLIBNRG: MATXS2 LIBRARY '',A16,10H'' CANNOT B'// + > '28HE CLOSED BY KDRCLS (ERRCODE=,I2,2H).)' + WRITE(HSMG,HFORMAT) NAMFIL,IERR + CALL XABORT(HSMG) + ENDIF + ELSE IF(NAMLBT.EQ.'NDAS') THEN +*--- +* WIMS-NDAS LIBRARY +*---- + CALL LIBND0(NAMFIL,NGRI,IPENER) + CALL C_F_POINTER(IPENER,ENERG,(/ NGRI+1 /)) + ENDIF + IF(ENERG(NGRI+1).EQ.0.0) ENERG(NGRI+1)=1.0E-5 + IF(NGT.EQ.0) THEN +*---- +* IF NGT=0 SAVE GROUP STRUCTURE AND SET GROUP PARAMETERS +*---- + NGROUP=NGRI + CALL LCMPUT(IPLIB,'ENERGY',NGRI+1,2,ENERG) + JG=0 + DO 210 IG=1,NGROUP + ENERG(JG+1)=LOG(ENERG(JG+1)/ENERG(JG+2)) + JG=JG+1 + 210 CONTINUE + CALL LCMPUT(IPLIB,'DELTAU',NGROUP,2,ENERG) + NGT=NGROUP + ELSE IF(NGRI.EQ.NGT) THEN +*---- +* IF NGT>0 VALIDATE GROUP STRUCTURE +*---- + ALLOCATE(EIER(NGT+1)) + CALL LCMGET(IPLIB,'ENERGY',EIER) + JG=0 + DO 220 IG=1,NGT + ERROR=ABS(ENERG(JG+1)-EIER(JG+1)) + IF(ERROR.GT.ABS(ENERG(JG+1))*1.0E-4) THEN + WRITE(IOUT,'(1X,A20)') 'OLD GROUP STRUCTURE=' + WRITE(IOUT,'(1P,5E15.7)') + > (EIER(IPR+1),IPR=0,NGT) + WRITE(IOUT,'(1X,A20)') 'NEW GROUP STRUCTURE=' + WRITE(IOUT,'(1P,5E15.7)') + > (ENERG(IPR+1),IPR=0,NGT) + WRITE(IOUT,'(7H ERROR=,1P,E10.3,9H IN GROUP,I4)') + > ERROR,IG + WRITE(IOUT,'(7H VALUE=,1P,E10.3,3H VS,E10.3)') ENERG(JG+1), + > EIER(JG+1) + CALL XABORT('LIBNRG: INCOMPATIBLE GROUP STRUCTURE') + ENDIF + JG=JG+1 + 220 CONTINUE + DEALLOCATE(EIER) + ELSE + WRITE(IOUT,'(1X,A20,1X,I10)') 'OLD NUMBER OF GROUPS=',NGT + WRITE(IOUT,'(1X,A20,1X,I10)') 'NEW NUMBER OF GROUPS=',NGRI + CALL XABORT('LIBNRG: INCOMPATIBLE NUMBER OF GROUPS') + ENDIF + IF((NAMLBT.EQ.'NDAS').OR.(NAMLBT.EQ.'APLIB2').OR. + > (NAMLBT.EQ.'APXSM')) THEN + CALL LCMDRD(IPENER) + ELSE + DEALLOCATE(ENERG) + ENDIF +*---- +* RETURN +*---- + RETURN + END diff --git a/Dragon/src/LIBOMG.f b/Dragon/src/LIBOMG.f new file mode 100644 index 0000000..e4b7162 --- /dev/null +++ b/Dragon/src/LIBOMG.f @@ -0,0 +1,119 @@ +*DECK LIBOMG + SUBROUTINE LIBOMG(MX,IX,X,MY,IY,Y,DCM,OMEG) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the correlated weight matrix preserving a matrix of moments. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MX number of base points in the first variable. +* IX order of the first moment of the first variable. We must +* have 1-MX <= IX <= 0 (order 0 moment is always preserved). +* X base points in the first variable. +* MY number of base points in the second variable. +* IY order of the first moment of the second variable. We must +* have 1-MY <= IY <= 0 (order 0 moment is always preserved). +* Y base points in the second variable. +* DCM co-moments. +* +*Parameters: output +* OMEG correlated weight matrix. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + REAL X(MX),Y(MY),OMEG(MX,MY) + DOUBLE PRECISION DCM(MX,MY) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MAXNOR=20) + DOUBLE PRECISION DD,DAUX,WORK,DDA(0:MAXNOR),PROD1(MAXNOR,MAXNOR), + 1 PROD2(MAXNOR,MAXNOR) +* + IF(MX.GT.MAXNOR) CALL XABORT('LIBOMG: STORAGE OVERFLOW(1).') + IF(MY.GT.MAXNOR) CALL XABORT('LIBOMG: STORAGE OVERFLOW(2).') + IF((1-MX.GT.IX).OR.(IX.GT.0)) CALL XABORT('LIBOMG: INCONSISTENT ' + 1 //'VALUE OF IX.') + IF((1-MY.GT.IY).OR.(IY.GT.0)) CALL XABORT('LIBOMG: INCONSISTENT ' + 1 //'VALUE OF IY.') +* + DO 15 I=1,MX + DO 10 J=1,MY + PROD1(I,J)=0.0D0 + 10 CONTINUE + 15 CONTINUE + DO 52 I=1,MX + DAUX=DBLE(X(I)) + DDA(0)=1.0D0 + J0=0 + DO 30 J=1,MX + IF(J.EQ.I) GO TO 30 + J0=J0+1 + DDA(J0)=DDA(J0-1) + DO 20 K=1,J0-1 + DDA(J0-K)=DDA(J0-K-1)-DDA(J0-K)*DBLE(X(J)) + 20 CONTINUE + DDA(0)=-DDA(0)*DBLE(X(J)) + 30 CONTINUE + DD=1.0D0 + DO 40 J=1,MX + IF(J.NE.I) DD=DD*(DBLE(X(J))-DAUX) + 40 CONTINUE + WORK=((-1.0D0)**(MX-1))*DAUX**(-IX)/DD + DO 51 J=1,MY + DO 50 K=1,MX + PROD1(I,J)=PROD1(I,J)+WORK*DDA(K-1)*DCM(K,J) + 50 CONTINUE + 51 CONTINUE + 52 CONTINUE +* + DO 65 I=1,MX + DO 60 J=1,MY + PROD2(I,J)=0.0D0 + 60 CONTINUE + 65 CONTINUE + DO 102 I=1,MY + DAUX=DBLE(Y(I)) + DDA(0)=1.0D0 + J0=0 + DO 80 J=1,MY + IF(J.EQ.I) GO TO 80 + J0=J0+1 + DDA(J0)=DDA(J0-1) + DO 70 K=1,J0-1 + DDA(J0-K)=DDA(J0-K-1)-DDA(J0-K)*DBLE(Y(J)) + 70 CONTINUE + DDA(0)=-DDA(0)*DBLE(Y(J)) + 80 CONTINUE + DD=1.0D0 + DO 90 J=1,MY + IF(J.NE.I) DD=DD*(DBLE(Y(J))-DAUX) + 90 CONTINUE + WORK=((-1.0D0)**(MY-1))*DAUX**(-IY)/DD + DO 101 J=1,MX + DO 100 K=1,MY + PROD2(J,I)=PROD2(J,I)+WORK*DDA(K-1)*PROD1(J,K) + 100 CONTINUE + 101 CONTINUE + 102 CONTINUE +* + DO 125 I=1,MX + DO 120 J=1,MY + OMEG(I,J)=REAL(PROD2(I,J)) + 120 CONTINUE + 125 CONTINUE + RETURN + END diff --git a/Dragon/src/LIBPRI.f b/Dragon/src/LIBPRI.f new file mode 100644 index 0000000..9461406 --- /dev/null +++ b/Dragon/src/LIBPRI.f @@ -0,0 +1,257 @@ +*DECK LIBPRI + SUBROUTINE LIBPRI(MAXTRA,DELI,AWR,IALTER,IL,N,PRI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the PRI array for various Legendre orders using Gaussian +* integration. +* +*Copyright: +* Copyright (C) 2003 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXTRA allocated dimension of array PRI. +* DELI elementary lethargy width of the equi-width lethargy mesh. +* AWR mass ratio for current isotope. +* IALTER type of approximation (=0: use exponentials; =1: use Taylor +* expansions). +* IL Legendre order (=0: isotropic kernel). +* +*Parameters: output +* N exact dimension of array PRI. +* PRI array containing the slowing-down probabilities defined on +* an equi-width lethargy mesh. +* +*Reference: +* M. Grandotto-Biettoli, "AUTOSECOL, un calcul automatique de +* l'auto-protection des resonances des isotopes lourds," +* Note CEA-N-1961, Commissariat a l'Energie Atomique, 1977. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXTRA,IALTER,IL,N + REAL DELI,AWR,PRI(MAXTRA) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NGPT=6,MAXNL=50) + DOUBLE PRECISION AWRB,ALP,T0,FACT + REAL UI(NGPT),WI(NGPT),UJ(NGPT),WJ(NGPT) + REAL POLY(0:MAXNL),CALC(0:MAXNL,0:2) + CHARACTER HSMG*131 + ZMU(AWR,U)=0.5*(AWR+1.0)*EXP(-0.5*U)-0.5*(AWR-1.0)*EXP(0.5*U) +*---- +* COMPUTE THE LEGENDRE POLYNOMIAL OF ORDER IL. +*---- + IF(IL.GT.MAXNL) CALL XABORT('LIBPRI: IL OVERFLOW.') + IF(IL.EQ.0) THEN + POLY(0)=1.0 + ELSE IF(IL.EQ.1) THEN + POLY(0)=0.0 + POLY(1)=1.0 + ELSE + CALC(0:MAXNL,0:1)=0.0 + CALC(0,0)=1.0 + CALC(1,1)=1.0 + DO 15 J=2,IL + DO 10 I=0,IL + T0=-REAL(J-1)*CALC(I,MOD(J-2,3)) + IF(I.GT.0) T0=T0+(2.0*REAL(J-1)+1.0)*CALC(I-1,MOD(J-1,3)) + CALC(I,MOD(J,3))=REAL(T0)/REAL(J) + 10 CONTINUE + 15 CONTINUE + DO 20 I=0,IL + POLY(I)=CALC(I,MOD(IL,3)) + 20 CONTINUE + ENDIF +* + AWRB=AWR + IF(AWR.LT.1.0001) AWRB=1.0001 + ALP=((AWRB-1.D0)/(AWRB+1.D0))**2 + REPS=REAL(-DLOG(ALP)) + N=INT(REPS/DELI) + IF(N+2.GT.MAXTRA) THEN + WRITE(HSMG,'(25HLIBPRI: MAXTRA OVERFLOW (,I8,2H >,I8,2H).)') + 1 N+2,MAXTRA + CALL XABORT(HSMG) + ENDIF +* + IF(N.EQ.0) THEN +* COMPUTE PRI(1). + PRI(1)=0.0 + CALL ALGPT(NGPT,0.0,DELI-REPS,UI,WI) + DO 41 I=1,NGPT + CALL ALGPT(NGPT,UI(I),UI(I)+REPS,UJ,WJ) + DO 40 J=1,NGPT + FACT=POLY(0) + T0=1.0D0 + DO 30 K=1,IL + T0=T0*ZMU(AWR,UJ(J)-UI(I)) + FACT=FACT+POLY(K)*T0 + 30 CONTINUE + IF(IALTER.EQ.0) THEN + PRI(1)=PRI(1)+WI(I)*WJ(J)*EXP(UI(I)-UJ(J))*REAL(FACT) + ELSE + PRI(1)=PRI(1)+WI(I)*WJ(J)*REAL(FACT) + ENDIF + 40 CONTINUE + 41 CONTINUE + CALL ALGPT(NGPT,DELI-REPS,DELI,UI,WI) + DO 51 I=1,NGPT + CALL ALGPT(NGPT,UI(I),DELI,UJ,WJ) + DO 50 J=1,NGPT + FACT=POLY(0) + T0=1.0D0 + DO 45 K=1,IL + T0=T0*ZMU(AWR,UJ(J)-UI(I)) + FACT=FACT+POLY(K)*T0 + 45 CONTINUE + IF(IALTER.EQ.0) THEN + PRI(1)=PRI(1)+WI(I)*WJ(J)*EXP(UI(I)-UJ(J))*REAL(FACT) + ELSE + PRI(1)=PRI(1)+WI(I)*WJ(J)*REAL(FACT) + ENDIF + 50 CONTINUE + 51 CONTINUE +* +* COMPUTE PRI(2). + PRI(2)=0.0 + CALL ALGPT(NGPT,DELI-REPS,DELI,UI,WI) + DO 61 I=1,NGPT + CALL ALGPT(NGPT,DELI,UI(I)+REPS,UJ,WJ) + DO 60 J=1,NGPT + FACT=POLY(0) + T0=1.0D0 + DO 55 K=1,IL + T0=T0*ZMU(AWR,UJ(J)-UI(I)) + FACT=FACT+POLY(K)*T0 + 55 CONTINUE + IF(IALTER.EQ.0) THEN + PRI(2)=PRI(2)+WI(I)*WJ(J)*EXP(UI(I)-UJ(J))*REAL(FACT) + ELSE + PRI(2)=PRI(2)+WI(I)*WJ(J)*REAL(FACT) + ENDIF + 60 CONTINUE + 61 CONTINUE + ELSE +* COMPUTE PRI(1). + PRI(1)=0.0 + CALL ALGPT(NGPT,0.0,DELI,UI,WI) + DO 71 I=1,NGPT + CALL ALGPT(NGPT,REAL(UI(I)),DELI,UJ,WJ) + DO 70 J=1,NGPT + FACT=POLY(0) + T0=1.0D0 + DO 65 K=1,IL + T0=T0*ZMU(AWR,UJ(J)-UI(I)) + FACT=FACT+POLY(K)*T0 + 65 CONTINUE + IF(IALTER.EQ.0) THEN + PRI(1)=PRI(1)+WI(I)*WJ(J)*EXP(UI(I)-UJ(J))*REAL(FACT) + ELSE + PRI(1)=PRI(1)+WI(I)*WJ(J)*REAL(FACT) + ENDIF + 70 CONTINUE + 71 CONTINUE +* +* COMPUTE PRI(L) FOR L=2,N. + CALL ALGPT(NGPT,0.0,DELI,UI,WI) + DO 82 L=2,N + PRI(L)=0.0 + DO 81 I=1,NGPT + CALL ALGPT(NGPT,REAL(L-1)*DELI,REAL(L)*DELI,UJ,WJ) + DO 80 J=1,NGPT + FACT=POLY(0) + T0=1.0D0 + DO 75 K=1,IL + T0=T0*ZMU(AWR,UJ(J)-UI(I)) + FACT=FACT+POLY(K)*T0 + 75 CONTINUE + IF(IALTER.EQ.0) THEN + PRI(L)=PRI(L)+WI(I)*WJ(J)*EXP(UI(I)-UJ(J))*REAL(FACT) + ELSE + PRI(L)=PRI(L)+WI(I)*WJ(J)*REAL(FACT) + ENDIF + 80 CONTINUE + 81 CONTINUE + 82 CONTINUE +* +* COMPUTE PRI(N+1). + PRI(N+1)=0.0 + CALL ALGPT(NGPT,0.0,REAL(N+1)*DELI-REPS,UI,WI) + DO 91 I=1,NGPT + CALL ALGPT(NGPT,REAL(N)*DELI,UI(I)+REPS,UJ,WJ) + DO 90 J=1,NGPT + FACT=POLY(0) + T0=1.0D0 + DO 85 K=1,IL + T0=T0*ZMU(AWR,UJ(J)-UI(I)) + FACT=FACT+POLY(K)*T0 + 85 CONTINUE + IF(IALTER.EQ.0) THEN + PRI(N+1)=PRI(N+1)+WI(I)*WJ(J)*EXP(UI(I)-UJ(J))*REAL(FACT) + ELSE + PRI(N+1)=PRI(N+1)+WI(I)*WJ(J)*REAL(FACT) + ENDIF + 90 CONTINUE + 91 CONTINUE + CALL ALGPT(NGPT,REAL(N+1)*DELI-REPS,DELI,UI,WI) + DO 101 I=1,NGPT + CALL ALGPT(NGPT,REAL(N)*DELI,REAL(N+1)*DELI,UJ,WJ) + DO 100 J=1,NGPT + FACT=POLY(0) + T0=1.0D0 + DO 95 K=1,IL + T0=T0*ZMU(AWR,UJ(J)-UI(I)) + FACT=FACT+POLY(K)*T0 + 95 CONTINUE + IF(IALTER.EQ.0) THEN + PRI(N+1)=PRI(N+1)+WI(I)*WJ(J)*EXP(UI(I)-UJ(J))*REAL(FACT) + ELSE + PRI(N+1)=PRI(N+1)+WI(I)*WJ(J)*REAL(FACT) + ENDIF + 100 CONTINUE + 101 CONTINUE +* +* COMPUTE PRI(N+2). + PRI(N+2)=0.0 + CALL ALGPT(NGPT,REAL(N+1)*DELI-REPS,DELI,UI,WI) + DO 111 I=1,NGPT + CALL ALGPT(NGPT,REAL(N+1)*DELI,UI(I)+REPS,UJ,WJ) + DO 110 J=1,NGPT + FACT=POLY(0) + T0=1.0D0 + DO 105 K=1,IL + T0=T0*ZMU(AWR,UJ(J)-UI(I)) + FACT=FACT+POLY(K)*T0 + 105 CONTINUE + IF(IALTER.EQ.0) THEN + PRI(N+2)=PRI(N+2)+WI(I)*WJ(J)*EXP(UI(I)-UJ(J))*REAL(FACT) + ELSE + PRI(N+2)=PRI(N+2)+WI(I)*WJ(J)*REAL(FACT) + ENDIF + 110 CONTINUE + 111 CONTINUE + ENDIF + N=N+2 + IF(IALTER.EQ.0) THEN + DO 120 I=1,N + PRI(I)=PRI(I)/DELI/REAL(1.0D0-ALP) + 120 CONTINUE + ELSE + DO 130 I=1,N + PRI(I)=PRI(I)/DELI/REPS + 130 CONTINUE + ENDIF + RETURN + END diff --git a/Dragon/src/LIBPTT.f b/Dragon/src/LIBPTT.f new file mode 100644 index 0000000..689a4f7 --- /dev/null +++ b/Dragon/src/LIBPTT.f @@ -0,0 +1,381 @@ +*DECK LIBPTT + SUBROUTINE LIBPTT(IGRP,NDIL,NPART,DILUT,XSDIL,GOLD,HNAMIS,IMPX, + 1 NOR,WEIGH,SIGX,SIGP) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transform dilution dependent total and partial self-shielded cross +* section into probability tables. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IGRP energy group index of the probability table. +* NDIL number of finite dilutions. +* NPART number of partial cross sections. +* DILUT dilutions with DILUT(NDIL+1)=1.e10. +* XSDIL dilution dependent self-shielded cross sections: +* XSDIL(I,1) total self-shielded cross sections; +* XSDIL(I,2) nu*fission self-shielded cross sections; +* XSDIL(I,3) P0 scattering cross sections; +* etc. +* XSDIL(NDIL+1,j) are the infinite dilution values. +* GOLD Goldstein-Cohen parameter. +* HNAMIS local name of the isotope: +* HNAMIS(1:8) is the local isotope name; +* HNAMIS(9:12) is a suffix function of the mixture index. +* IMPX print parameter (equal to zero for no print). +* +*Parameters: output +* NOR order for the probability table. +* WEIGH quadrature weights for the probability table. +* SIGX base points for the total cross sections. +* SIGP base points for the partial cross sections. +* +*----------------------------------------------------------------------- +* + IMPLICIT DOUBLE PRECISION(A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + PARAMETER (MAXNOR=12) + INTEGER IGRP,NDIL,NPART,IMPX,NOR + REAL DILUT(NDIL+1),XSDIL(NDIL+1,NPART+1),GOLD,WEIGH(NOR), + 1 SIGX(NOR),SIGP(MAXNOR,NPART) + CHARACTER HNAMIS*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (TARGET=0.2D-3,EPSRID=5.0D-4) + REAL PRECA + DOUBLE PRECISION SIGXI,CC,DD,EE,DENOM + DOUBLE PRECISION DA(0:MAXNOR-1),DB(0:MAXNOR-1),DC(0:MAXNOR) + COMPLEX*16 SIGX0(MAXNOR),CCC,DCC,XCC + LOGICAL LCONV,LFAIL + CHARACTER HSMG*131 + REAL, ALLOCATABLE, DIMENSION(:) :: WABS + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: TEST,SDDK + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: TOFIT +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(TEST(NPART+2),SDDK(NDIL),TOFIT(NDIL,2)) +* + IF(IMPX.GT.5) THEN + WRITE(6,'(/47H LIBPTT: DILUTION DEPENDANT CROSS SECTIONS OF I, + 1 8HSOTOPE '',A12,10H'' IN GROUP,I4,1H:/9X,10HDILUTIONS=,1P, + 2 9E12.4,:/(19X,9E12.4))') HNAMIS,IGRP,(DILUT(I),I=1,NDIL+1) + WRITE(6,'(10X,9HTOTAL XS=,1P,9E12.4,:/(19X,9E12.4))') + 1 (XSDIL(I,1),I=1,NDIL+1) + IF(GOLD.NE.1.0) THEN + WRITE(6,'(6X,13HPRINCIPAL XS=,1P,9E12.4,:/(19X,9E12.4))') + 1 (XSDIL(I,1)-(1.0-GOLD)*XSDIL(I,3),I=1,NDIL+1) + ENDIF + IF(IMPX.GT.6) THEN + DO 10 J=1,NPART + WRITE(6,'(4X,10HPARTIAL XS,I4,1H=,1P,9E12.4,:/(19X, + 1 9E12.4))') J,(XSDIL(I,J+1),I=1,NDIL+1) + 10 CONTINUE + ENDIF + ENDIF + IF(NPART.LT.2) CALL XABORT('LIBPTT: SCATTERING INFO MISSING.') +*---- +* CHECK IF THE ENERGY GROUP IS REALLY RESONANT. +*---- + IF(NDIL.EQ.0) THEN + NOR=1 + WEIGH(1)=1.0 + SIGX(1)=XSDIL(1,1) + DO 20 J=1,NPART + SIGP(1,J)=XSDIL(1,J+1) + 20 CONTINUE + PREC0=0.0D0 + PREC=0.0D0 + PREC1=0.0D0 + GO TO 480 + ENDIF + PREC=0.0D0 + PREC0=0.0D0 + PREC1=0.0D0 + LCONV=.FALSE. + DO 30 IDIL=1,NDIL + ERR=ABS(DBLE((XSDIL(NDIL+1,1))/(XSDIL(IDIL,1)))-1.0D0) + PREC=MAX(PREC,ERR) + ERR=ABS(DBLE((XSDIL(NDIL+1,1)-(1.0D0-GOLD)*XSDIL(NDIL+1,3))/ + 1 (XSDIL(IDIL,1)-(1.0-GOLD)*XSDIL(IDIL,3)))-1.0D0) + PREC0=MAX(PREC0,ERR) + ERR=ABS(DBLE((XSDIL(NDIL+1,1)-XSDIL(NDIL+1,3))/ + 1 (XSDIL(IDIL,1)-XSDIL(IDIL,3)))-1.0D0) + PREC1=MAX(PREC1,ERR) + LCONV=LCONV.OR.(ABS(XSDIL(IDIL,1)).EQ.ABS(XSDIL(IDIL+1,1))) + 30 CONTINUE + IF(IMPX.GT.3) WRITE(6,'(/36H LIBPTT: ORDER 1 PROBABILITY TABLE , + 1 24HCALCULATION OF ISOTOPE '',A12,10H'' IN GROUP,I4,8H. ERROR=,1P, + 2 3D11.3,1H.)') HNAMIS,IGRP,PREC0,PREC,PREC1 + IF(PREC.LE.TARGET) THEN + NOR=1 + WEIGH(1)=1.0 + SIGX(1)=XSDIL(NDIL+1,1) + DO 40 J=1,NPART + SIGP(1,J)=XSDIL(NDIL+1,J+1) + 40 CONTINUE + GO TO 360 + ENDIF + IF(LCONV) THEN + WRITE(HSMG,'(45HLIBPTT: UNIFORM TOTAL XS IS NOT EXPECTED IN G, + 1 4HROUP,I4,1H.)') IGRP + CALL XABORT(HSMG) + ENDIF +*---- +* FIND THE PADE APPROXIMATION FOR ABS+XGOLD*SIGS CROSS SECTION USING +* A PADE REGRESSION. +*---- + XGOLD=GOLD + 45 ALLOCATE(WABS(NDIL+1)) + DO 60 IDIL=1,NDIL+1 + WABS(IDIL)=REAL(XSDIL(IDIL,1)-(1.0D0-XGOLD)*XSDIL(IDIL,3)) + 60 CONTINUE + CALL ALPLSF(3,NDIL+1,DILUT,WABS,EPSRID,.TRUE.,NOR,DA,DB,PRECA) + DEALLOCATE(WABS) + NOR=NOR+1 + IF(NOR.GT.MAXNOR) CALL XABORT('LIBPTT: NOR IS TOO LARGE.') + PREC0=DBLE(PRECA) +* +* FIND THE BASE POINTS IN ABS+XGOLD*SIGS CROSS SECTION. + SGN=1.0D0 + DC(0)=DA(0) + DO 70 I=2,NOR + SGN=-SGN + DC(I-1)=SGN*(DB(I-2)+DA(I-1)) + 70 CONTINUE + DC(NOR)=-SGN + CALL ALROOT(DC,NOR,SIGX0,LFAIL) + IF(LFAIL) CALL XABORT('LIBPTT: POLYNOMIAL ROOT FINDING FAILURE.') +* + DO 110 I=1,NOR +* +* NEWTON IMPROVEMENT OF THE ROOTS. + CCC=0.0D0 + XCC=1.0D0 + DO 80 J=0,NOR + CCC=CCC+DC(J)*XCC + XCC=XCC*SIGX0(I) + 80 CONTINUE + DCC=0.0D0 + XCC=1.0D0 + DO 85 J=1,NOR + DCC=DCC+DC(J)*XCC*REAL(J) + XCC=XCC*SIGX0(I) + 85 CONTINUE + SIGX0(I)=SIGX0(I)-CCC/DCC +* +* COMPUTE THE WEIGHTS. + IF(AIMAG(CMPLX(SIGX0(I))).NE.0.0) CALL XABORT('LIBPTT: COMPLEX ' + 1 //'ROOT.') + SIGXI=DBLE(SIGX0(I)) + CC=1.0D0 + DD=0.0D0 + DO 90 J=0,NOR-1 + DD=DD+DB(J)*CC + CC=-CC*SIGXI + 90 CONTINUE + DO 100 J=1,NOR + IF(J.NE.I) DD=DD/(DBLE(SIGX0(J))-SIGXI) + 100 CONTINUE + WEIGH(I)=REAL(DD) + 110 CONTINUE +*---- +* PROCESS THE TOTAL CROSS SECTIONS. +*---- + DO 210 IDIL=1,NDIL + SCC=DA(NOR-1) + DO 200 I=NOR-2,0,-1 + SCC=DA(I)+SCC*DILUT(IDIL) + 200 CONTINUE + SDDK(IDIL)=(XSDIL(IDIL,1)-(1.0-XGOLD)*XSDIL(IDIL,3))/SCC + TOFIT(IDIL,1)=DILUT(IDIL) + TOFIT(IDIL,2)=XSDIL(IDIL,1)/SDDK(IDIL) + SDDK(IDIL)=SDDK(IDIL)*SDDK(IDIL) + 210 CONTINUE + IF(XGOLD.NE.1.0) THEN + CALL ALDFIT(NDIL,NOR-1,TOFIT(1,1),TOFIT(1,2),SDDK,DA) + ENDIF + DO 220 I=0,NOR-1 + DA(I)=DA(I)*XSDIL(NDIL+1,1)/DA(NOR-1) + 220 CONTINUE +*---- +* COMPUTE THE BASE POINTS IN TOTAL CROSS SECTION. +*---- + DO 240 I=1,NOR + SIGXI=DBLE(SIGX0(I)) + CC=1.0D0 + DD=0.0D0 + EE=0.0D0 + DO 230 J=0,NOR-1 + DD=DD+DA(J)*CC + EE=EE+DB(J)*CC + CC=-CC*SIGXI + 230 CONTINUE + SIGX(I)=REAL(DD/EE) + IF(SIGX(I).LT.0.0) THEN + IF(XGOLD.EQ.1.0) CALL XABORT('LIBPTT: NEGATIVE BASE POINTS FO' + 1 //'R THE TOTAL CROSS SECTION.') + XGOLD=MIN(1.0D0,XGOLD+0.1D0) + GO TO 45 + ENDIF + 240 CONTINUE +*---- +* PROCESS THE PARTIAL CROSS SECTIONS. +*---- + DO 300 IPART=1,NPART + IF(XSDIL(NDIL+1,IPART+1).EQ.0.0) THEN + DO 250 I=1,NOR + SIGP(I,IPART)=0.0 + 250 CONTINUE + GO TO 300 + ENDIF + DO 260 IDIL=1,NDIL + TOFIT(IDIL,1)=DILUT(IDIL) + TOFIT(IDIL,2)=XSDIL(IDIL,IPART+1)/SQRT(SDDK(IDIL)) + 260 CONTINUE + CALL ALDFIT(NDIL,NOR-1,TOFIT(1,1),TOFIT(1,2),SDDK,DA) + IF(DA(NOR-1).EQ.0.0) THEN + DO 265 I=1,NOR + SIGP(I,IPART)=XSDIL(NDIL+1,IPART+1) + 265 CONTINUE + GO TO 300 + ENDIF + DO 270 I=0,NOR-1 + DA(I)=DA(I)*XSDIL(NDIL+1,IPART+1)/DA(NOR-1) + 270 CONTINUE +*---- +* COMPUTE THE BASE POINTS IN PARTIAL CROSS SECTION. +*---- + DO 290 I=1,NOR + SIGXI=DBLE(SIGX0(I)) + CC=1.0D0 + DD=0.0D0 + EE=0.0D0 + DO 280 J=0,NOR-1 + DD=DD+DA(J)*CC + EE=EE+DB(J)*CC + CC=-CC*SIGXI + 280 CONTINUE + SIGP(I,IPART)=REAL(DD/EE) + 290 CONTINUE + 300 CONTINUE +*---- +* REMOVING SMALL PROBABILITIES. +*---- + INOR=0 + 330 INOR=INOR+1 + IF(INOR.GT.NOR) GO TO 360 + IF(ABS(WEIGH(INOR)).LE.5.0E-7) THEN + DO 355 JNOR=INOR+1,NOR + WEIGH(JNOR-1)=WEIGH(JNOR) + SIGX(JNOR-1)=SIGX(JNOR) + DO 350 J=1,NPART + SIGP(JNOR-1,J)=SIGP(JNOR,J) + 350 CONTINUE + 355 CONTINUE + INOR=INOR-1 + NOR=NOR-1 + ENDIF + GO TO 330 +*---- +* NORMALIZE THE PROBABILITY TABLE TO INFINITE DILUTION X-S. +*---- + 360 CC=0.0D0 + DO 390 I=1,NOR + CC=CC+WEIGH(I) + 390 CONTINUE + DO 400 I=1,NOR + WEIGH(I)=WEIGH(I)/REAL(CC) + 400 CONTINUE + CC=0.0D0 + DO 410 I=1,NOR + CC=CC+WEIGH(I)*SIGX(I) + 410 CONTINUE + IF(CC.NE.0.0) THEN + DO 420 I=1,NOR + SIGX(I)=SIGX(I)*XSDIL(NDIL+1,1)/REAL(CC) + 420 CONTINUE + ENDIF + DO 450 J=1,NPART + CC=0.0D0 + DO 430 I=1,NOR + CC=CC+WEIGH(I)*SIGP(I,J) + 430 CONTINUE + IF(CC.NE.0.0) THEN + DO 440 I=1,NOR + SIGP(I,J)=SIGP(I,J)*XSDIL(NDIL+1,J+1)/REAL(CC) + 440 CONTINUE + ENDIF + 450 CONTINUE +*---- +* TEST THE ACCURACY OF THE PROBABILITY TABLE. +*---- + PREC=0.0D0 + PREC1=0.0D0 + DO 470 IDIL=1,NDIL+1 + CC=0.0D0 + DD=0.0D0 + EE=0.0D0 + DO 460 I=1,NOR + DENOM=SIGX(I)-(1.0-GOLD)*SIGP(I,2)+DILUT(IDIL) + CC=CC+WEIGH(I)/DENOM + DD=DD+WEIGH(I)*SIGX(I)/DENOM + EE=EE+WEIGH(I)*(SIGX(I)-SIGP(I,2))/DENOM + 460 CONTINUE + PREC=MAX(PREC,ABS((DD/CC)/DBLE(XSDIL(IDIL,1))-1.0D0)) + PREC1=MAX(PREC1,ABS((EE/CC)/DBLE(XSDIL(IDIL,1)- + 1 XSDIL(IDIL,3))-1.0D0)) + 470 CONTINUE + 480 IF((IMPX.GE.3).AND.(NOR.GT.1)) THEN + WRITE(6,'(14H LIBPTT: ORDER,I3,27H PROBABILITY TABLE CALCULAT, + 1 16HION OF ISOTOPE '',A12,10H'' IN GROUP,I4,8H. ERROR=,1P, + 2 3D11.3,1H.)') NOR,HNAMIS,IGRP,PREC0,PREC,PREC1 + ENDIF + IF((IMPX.GE.2).AND.(NOR.GT.1)) THEN + WRITE(6,'(/34H LIBPTT: SIGT BASE POINTS IN GROUP,I4,1H:)') IGRP + WRITE(6,'(1X,1P,12E12.4)') SIGX(:NOR) + ENDIF +* + IF(((IMPX.GT.4).AND.(NOR.GT.1)).OR.(IMPX.GT.5)) THEN + WRITE(6,'(/27H LIBPTT: PROBABILITY TABLE:/7X,11HPROBABILITY, + 1 2X,10HTOTAL-----,2X,22HPARTIAL CROSS SECTIONS)') + DO 490 J=1,NPART+2 + TEST(J)=0.0D0 + 490 CONTINUE + DO 510 INOR=1,NOR + TEST(1)=TEST(1)+WEIGH(INOR) + TEST(2)=TEST(2)+WEIGH(INOR)*SIGX(INOR) + DO 500 J=1,NPART + TEST(J+2)=TEST(J+2)+WEIGH(INOR)*SIGP(INOR,J) + 500 CONTINUE + WRITE(6,'(1X,I5,1P,7E12.4,:/(30X,5E12.4))') INOR, + 1 WEIGH(INOR),SIGX(INOR),(SIGP(INOR,J),J=1,NPART) + 510 CONTINUE + WRITE(6,'(6H CHECK,1P,7E12.4,:/(30X,5E12.4))') (REAL(TEST(J)), + 1 J=1,NPART+2) + TEST(1)=1.0D0 + DO 520 J=1,NPART+1 + TEST(J+1)=XSDIL(NDIL+1,J) + 520 CONTINUE + WRITE(6,'(6H EXACT,1P,7E12.4,:/(30X,5E12.4))') (REAL(TEST(J)), + 1 J=1,NPART+2) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(TOFIT,SDDK,TEST) + RETURN + END diff --git a/Dragon/src/LIBPTW.f b/Dragon/src/LIBPTW.f new file mode 100644 index 0000000..d67f9a3 --- /dev/null +++ b/Dragon/src/LIBPTW.f @@ -0,0 +1,243 @@ +*DECK LIBPTW + SUBROUTINE LIBPTW (IPLIB,IPTMP,IPROC,NGRO,NL,HNAMIS,NED,HVECT, + 1 NDIL,DILUT,AWR,IPRECI,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Build a temperature-independant draglib (IPROC=2) on the internal +* library or write the probability table information (IPROC=1/3/4). +* +*Copyright: +* Copyright (C) 2003 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the isotopic directory in microlib. +* IPTMP pointer to the multi-dilution internal library. +* IPROC type of microlib processing: +* =1: perform temperature interpolation and compute physical +* probability tables. +* =2: perform temperature interpolation and build a +* temperature-independent draglib; +* =3: perform temperature interpolation and compute calendf- +* type mathematical probability tables based on bin-type +* cross-sections for total cross sections; +* =4: perform temperature interpolation and compute physical +* probability tables or slowing-down correlated probability +* tables. +* =5: perform temperature interpolation and compute calendf- +* type mathematical probability tables based on bin-type +* cross-sections for all available cross-sections types. +* NGRO number of energy groups. +* NL number of Legendre orders required in the calculation +* (NL=1 or higher). +* HNAMIS local name of the isotope: +* HNAMIS(1:8) is the local isotope name; +* HNAMIS(9:12) is a suffix function of the mix number. +* NED number of extra vector edits. +* HVECT names of the extra vector edits. +* NDIL number of finite dilutions. +* DILUT dilutions. +* AWR mass ratio for current isotope. +* IPRECI accuracy index for probability tables in CALENDF. +* IMPX print flag. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB,IPTMP + INTEGER IPROC,NGRO,NL,NED,NDIL,IPRECI,IMPX + REAL DILUT(NDIL+1),AWR + CHARACTER HNAMIS*12,HVECT(NED)*8 +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPLIB,KPLIB,JPTMP,KPTMP + PARAMETER (MAXNPT=12,MAXTRA=10000) + CHARACTER TEXT12*12,TEXX12*12 + LOGICAL LSIGF,LGOLD,EMPTY,LCM,LBSIGF +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NFS,NOR,NBIN + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISMIN,ISMAX,ISM + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LSCAT,LADD + REAL, ALLOCATABLE, DIMENSION(:) :: GOLD,FLUX,TOTAL,SIGF,SIGS,SCAT, + 1 SADD,ZDEL,DELTG,TBIN,SBIN,FBIN,EBIN + TYPE(C_PTR) SIGP_PTR + REAL, POINTER, DIMENSION(:) :: SIGP +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(ISMIN(NL,NGRO),ISMAX(NL,NGRO),NFS(NGRO),NOR(NGRO), + 1 ISM(2,NL)) + ALLOCATE(LSCAT(NL),LADD(NED)) + ALLOCATE(GOLD(NGRO)) +*---- +* COPY INFINITE DILUTION DATA FROM IPTMP TO IPLIB. +*---- + JPTMP=LCMGID(IPTMP,'ISOTOPESLIST') + CALL LCMLEL(JPTMP,NDIL+1,ILENG,ITYLCM) + IF(ILENG.EQ.0) THEN + TEXT12=HNAMIS(1:8) + WRITE(TEXT12(9:12),'(I4.4)') NDIL+1 + CALL XABORT('LIBPTW: MISSING LIST ITEM FOR '//TEXT12) + ENDIF + KPTMP=LCMGIL(JPTMP,NDIL+1) ! set (NDIL+1)-th isotope + CALL LCMLEN(KPTMP,'LAMBDA-D',NDEL,ITYLCM) + CALL LCMEQU(KPTMP,IPLIB) +* + IF(NDIL.GT.0) THEN +* RECOVER INFORMATION FROM IPTMP AND PUT NEW INFORMATION INTO +* IPLIB. + ALLOCATE(FLUX(NGRO*(NDIL+1)),TOTAL(NGRO*(NDIL+1)), + 1 SIGF(NGRO*(NDIL+1)),SIGS(NGRO*NL*(NDIL+1)), + 2 SCAT(NGRO*NGRO*NL*(NDIL+1)),SADD(NGRO*NED*(NDIL+1)), + 3 ZDEL(NGRO*NDEL*(NDIL+1)),DELTG(NGRO)) +* + IF(IMPX.GT.2) THEN + WRITE(6,'(/32H LIBPTW: DILUTIONS FOR ISOTOPE '',A12,2H'':)') + 1 HNAMIS + WRITE(6,'(1X,1P,12E12.4)') DILUT(:NDIL+1) + ENDIF + CALL LIBEXT(IPTMP,NGRO,NL,NDIL,NED,HVECT,NDEL,.FALSE.,IMPX, + 1 DILUT,MDIL,LSCAT,LSIGF,LADD,LGOLD,FLUX,TOTAL,SIGF,SIGS,SCAT, + 2 SADD,ZDEL,DELTG,GOLD,ISMIN,ISMAX) +* +* DESTROY THE MULTI-DILUTION INTERNAL LIBRARY. + CALL LCMCL(IPTMP,2) +* + IF(IPROC.EQ.1) THEN +* COMPUTE THE PHYSICAL PROBABILITY TABLES. + MAXNOR=MAXNPT + CALL LCMINF(IPLIB,TEXT12,TEXX12,EMPTY,ILONG,LCM) + CALL LCMSIX(IPLIB,'PT-TABLE',1) + CALL LCMPUT(IPLIB,'NDEL',1,1,NDEL) + JPLIB=LCMLID(IPLIB,'GROUP-PT',NGRO) + DO 20 IGRP=1,NGRO + NPART=3+NL+NED+NDEL + DO 10 IL=1,NL + NPART=NPART+MAX(ISMAX(IL,IGRP)-ISMIN(IL,IGRP)+1,0) + 10 CONTINUE + IF(LGOLD) THEN + GOLD0=GOLD(IGRP) + ELSE + GOLD0=1.0 + ENDIF + IF(LCM) THEN + SIGP_PTR=LCMARA(MAXNOR*NPART) + CALL C_F_POINTER(SIGP_PTR,SIGP,(/ MAXNOR*NPART /)) + ELSE + ALLOCATE(SIGP(MAXNOR*NPART)) + ENDIF + SIGP(:MAXNOR*NPART)=0.0 + CALL LIBTAB(IGRP,NGRO,NL,MDIL,NPART,NED,NDEL,HNAMIS,IMPX, + 1 LSCAT,LSIGF,LADD,DILUT,TOTAL,SIGF,SIGS,SCAT,SADD,ZDEL,GOLD0, + 2 ISMIN,ISMAX,NOR(IGRP),SIGP) +* + IF(NOR(IGRP).GT.1) THEN +* SAVE THE PROBABILITY TABLE INTO IPLIB. + KPLIB=LCMDIL(JPLIB,IGRP) + IF(LCM) THEN + CALL LCMPPD(KPLIB,'PROB-TABLE',MAXNOR*NPART,2,SIGP_PTR) + ELSE + CALL LCMPUT(KPLIB,'PROB-TABLE',MAXNOR*NPART,2,SIGP) + DEALLOCATE(SIGP) + ENDIF + DO 15 IL=1,NL + ISM(1,IL)=ISMIN(IL,IGRP) + ISM(2,IL)=ISMAX(IL,IGRP) + 15 CONTINUE + CALL LCMPUT(KPLIB,'ISM-LIMITS',2*NL,1,ISM) + ELSE + IF(LCM) THEN + CALL LCMDRD(SIGP_PTR) + ELSE + DEALLOCATE(SIGP) + ENDIF + ENDIF + 20 CONTINUE + CALL LCMPUT(IPLIB,'NOR',NGRO,1,NOR) + CALL LCMSIX(IPLIB,' ',2) + ELSE IF(IPROC.EQ.2) THEN +* BUILD A TEMPERATURE-INDEPENDENT DRAGLIB. + CALL LIBNOT(IPLIB,NGRO,NL,MDIL,NED,NDEL,IMPX,LSCAT,LSIGF, + 1 LADD,DILUT,FLUX,TOTAL,SIGF,SIGS,SCAT,SADD,ZDEL,HVECT) + ELSE IF((IPROC.EQ.3).OR.(IPROC.EQ.4).OR.(IPROC.EQ.5)) THEN +* COMPUTE PHYSICAL PROBABILITY TABLES OR PROBABILITY TABLES +* TAKING INTO ACCOUNT SLOWING-DOWN EFFECTS. +* +* RECOVER BIN TYPE INFORMATION (IF AVAILABLE). + LBSIGF=.FALSE. + CALL LCMLEN(IPLIB,'BIN-NFS',LENGT,ITYLCM) + LBIN=0 + IF(LENGT.GT.0) THEN + CALL LCMGET(IPLIB,'BIN-NFS',NFS) + IGRMIN=1 + IGRMAX=NGRO + DO 30 IGRP=NGRO,1,-1 + IF((IGRMAX.EQ.IGRP).AND.(NFS(IGRP).EQ.0)) IGRMAX=IGRP-1 + LBIN=LBIN+NFS(IGRP) + 30 CONTINUE + DO 40 IGRP=1,NGRO + IF((IGRMIN.EQ.IGRP).AND.(NFS(IGRP).EQ.0)) IGRMIN=IGRP+1 + 40 CONTINUE + ALLOCATE(NBIN(NGRO),TBIN(LBIN),SBIN(LBIN),FBIN(LBIN), + 1 EBIN(LBIN+1)) + CALL LCMGET(IPLIB,'BIN-ENERGY',EBIN) + CALL LCMGET(IPLIB,'BIN-NTOT0',TBIN) + CALL LCMGET(IPLIB,'BIN-SIGS00',SBIN) + CALL LCMLEN(IPLIB,'BIN-NUSIGF',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGET(IPLIB,'BIN-NUSIGF',FBIN) + LBSIGF=.TRUE. + ENDIF + ELSE + NFS(:NGRO)=0 + IGRMIN=1 + IGRMAX=0 + ENDIF +* +* RECOVER SCATTERING MATRIX PROFILE. + LPART=0 + DO 55 IL=1,NL + DO 50 IG1=1,NGRO + LPART=MAX(LPART,ISMAX(IL,IG1)-ISMIN(IL,IG1)+1) + 50 CONTINUE + 55 CONTINUE +* + CALL LIBFQD(MAXNPT,LPART,MAXTRA,HNAMIS,IPLIB,NGRO,NL,NED, + 1 NDEL,MDIL,IGRMIN,IGRMAX,LBIN,NFS,IMPX,LSCAT,LSIGF,LADD, + 2 DILUT,FLUX,TOTAL,SIGF,SIGS,SCAT,SADD,ZDEL,EBIN,TBIN,SBIN, + 3 FBIN,AWR,ISMIN,ISMAX,GOLD,IPRECI,NOR,LBSIGF) +* + IF(LBIN.GT.0) THEN + DEALLOCATE(EBIN,SBIN,TBIN,NBIN) + IF(LBSIGF) DEALLOCATE(FBIN) + ENDIF + ELSE + CALL XABORT('LIBPTW: INVALID VALUE OF IPROC.') + ENDIF + DEALLOCATE(DELTG,ZDEL,SADD,SCAT,SIGS,SIGF,TOTAL,FLUX) + ELSE +* DESTROY THE MULTI-DILUTION INTERNAL LIBRARY. + CALL LCMCL(IPTMP,2) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GOLD) + DEALLOCATE(LADD,LSCAT) + DEALLOCATE(ISM,NOR,NFS,ISMAX,ISMIN) +* + RETURN + END diff --git a/Dragon/src/LIBRSC.f b/Dragon/src/LIBRSC.f new file mode 100644 index 0000000..6013770 --- /dev/null +++ b/Dragon/src/LIBRSC.f @@ -0,0 +1,350 @@ +*DECK LIBRSC + SUBROUTINE LIBRSC(MAXTRA,IPLIB,LBIN,NGRP,NBISO,ISONAM,MASKI,LSHI, + 1 NFS,IMPX,IALTER) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the correlation information between a pair of resonant +* isotopes for the resonance spectrum expansion (RSE) method. +* +*Copyright: +* Copyright (C) 2023 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXTRA maximum number of energy bins of size DELI. +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* ISOT index of the isotope been processed. +* LBIN number of fine energy groups. +* NGRP number of coarse energy groups. +* NBISO number of isotopes present in the calculation domain. +* ISONAM alias name of isotopes. +* MASKI isotope masks (isotope with index I is process if +* MASKI(I)=.true.). +* LSHI resonant region number associated with each isotope. +* NFS number of fine energy groups in each coarse energy group. +* IMPX print flag (equal to zero for no print). +* IALTER type of approximation (=0: use exponentials; =1: use Taylor +* expansions). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + INTEGER MAXTRA,ISOT,LBIN,NGRP,NBISO,ISONAM(3,NBISO),LSHI(NBISO), + 1 NFS(NGRP),IMPX,IALTER + LOGICAL MASKI(NBISO) +*---- +* LOCAL VARIABLES +* KPLIB1: ISOTOPE WHERE THE COLLISION OCCURS +* KPLIB2: SOURCE ISOTOPE +*---- + TYPE(C_PTR) KPLIB1,KPLIB2,LPLIB1,LPLIB2,MPLIB,IOFSET + CHARACTER HNAMIS1*12,HNAMIS2*12,HSMG*131 +*---- +* ALLOCATABLE ARRAYS +*---- + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO + INTEGER, ALLOCATABLE, DIMENSION(:) :: NJJ,MRANK,NFS2,ISOMIX + REAL, ALLOCATABLE, DIMENSION(:) :: EBIN,UUU,DEL,STR,SIGT,SIGS,PRI, + 1 STIS + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: TTT,DDD + DOUBLE PRECISION, POINTER, DIMENSION(:,:) :: SSIGT,SSIGS + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LCORR + TYPE MATRIX_ARRAY + DOUBLE PRECISION, POINTER, DIMENSION(:,:) :: MATRIX + END TYPE MATRIX_ARRAY + TYPE(MATRIX_ARRAY), ALLOCATABLE, DIMENSION(:) :: SIGT_M,TSIGT_M, + 1 SCAT_M,DDD_M,U_M,T_M + TYPE(MATRIX_ARRAY), ALLOCATABLE, DIMENSION(:,:) :: TSCAT_M +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IPISO(NBISO),NJJ(NGRP),MRANK(NGRP),ISOMIX(NBISO), + 1 LCORR(NBISO)) + ALLOCATE(EBIN(LBIN+1),UUU(LBIN+1),DEL(LBIN),STR(LBIN),SIGT(LBIN), + 1 SIGS(LBIN),PRI(MAXTRA),STIS(LBIN)) + ALLOCATE(U_M(NGRP),T_M(NGRP),SIGT_M(NGRP),SCAT_M(NGRP), + 1 TSIGT_M(NGRP),TSCAT_M(NGRP,NGRP)) +*---- +* FIND CORRELATED ISOTOPES. +*---- + CALL LIBIPS(IPLIB,NBISO,IPISO) + CALL LCMGET(IPLIB,'ISOTOPESMIX',ISOMIX) + LCORR(:NBISO)=.TRUE. + DO 30 ISOT=1,NBISO + IF(.NOT.MASKI(ISOT).OR.(LSHI(ISOT).EQ.0)) GO TO 30 + WRITE(HNAMIS1,'(3A4)') (ISONAM(I0,ISOT),I0=1,3) + KPLIB1=IPISO(ISOT) + DO 20 JSOT=1,NBISO + IF(JSOT.EQ.ISOT) GO TO 20 + IF((.NOT.MASKI(JSOT)).OR.(LSHI(ISOT).NE.LSHI(JSOT))) GO TO 20 + WRITE(HNAMIS2,'(3A4)') (ISONAM(I0,JSOT),I0=1,3) + IF(LSHI(ISOT).GT.0) THEN + ! temperature correlation effect + IF(HNAMIS2(:8).NE.HNAMIS1(:8)) GO TO 20 + ENDIF + LCORR(ISOT)=.FALSE. + CALL LCMSIX(KPLIB1,'PT-TABLE',1) + CALL LCMLEN(KPLIB1,HNAMIS2,LENGT,ITYLCM) + CALL LCMSIX(KPLIB1,' ',2) + IF(LENGT.NE.0) GO TO 20 + IF(IMPX.GT.0) WRITE (6,'(/35H LIBRSC: COMPUTING CORRELATION EFFE, + 1 32HCTS BETWEEN ISOTOPES/MATERIALS '',A12,7H'' AND '',A12,2H''.)') + 2 HNAMIS1,HNAMIS2 +*---- +* RECOVER ISOTOPIC AND AUTOLIB DATA. +*---- + ALLOCATE(NFS2(NGRP)) + KPLIB2=IPISO(JSOT) + CALL LCMGET(KPLIB2,'AWR',AWR) + CALL LCMGET(KPLIB2,'BIN-ENERGY',EBIN) + CALL LCMGET(KPLIB2,'BIN-NTOT0',SIGT) + CALL LCMLEN(KPLIB2,'BIN-SIGS00',ILONG,ITYLCM) + CALL LCMGET(KPLIB2,'BIN-SIGS00',SIGS) + CALL LCMGET(KPLIB2,'BIN-NFS',NFS2) + IBIN=0 + DELMIN=1.0E10 + UUU(1)=0.0 + DO IG=1,NGRP + IF(NFS(IG).NE.NFS2(IG)) THEN + WRITE(HSMG,'(38HLIBRSC: INCOMPATIBLE BIN-NFS BETWEEN '',A12, + 1 7H'' AND '',A12,2H''.)') HNAMIS1,HNAMIS2 + CALL XABORT(HSMG) + ENDIF + DO LI=1,NFS(IG) + DELM=LOG(EBIN(IBIN+LI)/EBIN(IBIN+LI+1)) + UUU(IBIN+LI+1)=LOG(EBIN(1)/EBIN(IBIN+LI+1)) + DEL(IBIN+LI)=DELM + DELMIN=MIN(DELMIN,DELM) + ENDDO + IBIN=IBIN+NFS(IG) + ENDDO + DEALLOCATE(NFS2) + IF(IBIN.NE.LBIN) CALL XABORT('LIBRSC: INVALID NUMBER OF BINS.') + CALL LCMLEN(KPLIB2,'BIN-DELI',LENGT,ITYLCM) + IF((LENGT.EQ.1).AND.(ITYLCM.EQ.2)) THEN + CALL LCMGET(KPLIB2,'BIN-DELI',DELI) + ELSE + DELI=1.0/REAL(INT(1.00001/DELMIN)) + ENDIF + PRI(:MAXTRA)=0.0 + CALL LIBPRI(MAXTRA,DELI,AWR,IALTER,0,NEXT,PRI) +*---- +* NULLIFY POINTERS +*---- + DO IG=1,NGRP + NULLIFY(SIGT_M(IG)%MATRIX) + NULLIFY(TSIGT_M(IG)%MATRIX) + DO JG=1,NGRP + NULLIFY(TSCAT_M(IG,JG)%MATRIX) + ENDDO + ENDDO +*---- +* LOOP OVER RESONANT GROUPS AND RECOVER T_M AND U_M DATA +*---- + MRANK(:NGRP)=0 + CALL LCMSIX(KPLIB1,'PT-TABLE',1) + CALL LCMGET(KPLIB1,'NOR',MRANK) + LPLIB1=LCMGID(KPLIB1,'GROUP-RSE') + DO IG=1,NGRP + LGBIN=NFS(IG) + IF(LGBIN.EQ.0) CYCLE + MPLIB=LCMGIL(LPLIB1,IG) + MI=MRANK(IG) + CALL LCMGPD(MPLIB,'T_M',IOFSET) + CALL C_F_POINTER(IOFSET,T_M(IG)%MATRIX,(/ MI,MI /)) + CALL LCMGPD(MPLIB,'U_M',IOFSET) + CALL C_F_POINTER(IOFSET,U_M(IG)%MATRIX,(/ LGBIN,MI /)) + ENDDO + CALL LCMSIX(KPLIB1,' ',2) +*---- +* LOOP OVER RESONANT GROUPS +*---- + ALLOCATE(DDD_M(NGRP)) + LLL=0 + DO IG=1,NGRP + NJJ(IG)=0 + LGBIN=NFS(IG) + IF(LGBIN.EQ.0) CYCLE + ! + ! compute SIGT_M + MI=MRANK(IG) + ALLOCATE(SSIGT(MI,MI)) + SSIGT(:,:)=0.0D0 + DO LI=1,LGBIN + SIGMA=SIGT(LLL+LI) + DO IMR1=1,MI + DO IMR2=1,MI + SSIGT(IMR1,IMR2)=SSIGT(IMR1,IMR2)+U_M(IG)%MATRIX(LI,IMR1)* + 1 SIGMA*U_M(IG)%MATRIX(LI,IMR2) + ENDDO + ENDDO + ENDDO + SIGT_M(IG)%MATRIX=>SSIGT + NULLIFY(SSIGT) + ! + ! compute SCAT_M + DO JG=1,NGRP + NULLIFY(SCAT_M(JG)%MATRIX) + NULLIFY(DDD_M(JG)%MATRIX) + ENDDO + DO LI=1,LGBIN + III=1 + CALL LIBECT(MAXTRA,LLL+LI,PRI,UUU(2),DELI,DEL,NEXT,III,MML, + 1 STIS) + STR(:LBIN)=0.0 + DO MM=1,MML + LLJ=LLL+LI-MM+1 + STR(LLJ)=STIS(MM)*SIGS(LLJ) + ENDDO + LLJ=LLL + DO JG=IG,1,-1 + LGBIN2=NFS(JG) + IF(LLL+LI-MML+1.GT.LLJ+LGBIN2) EXIT + IF(.NOT.ASSOCIATED(U_M(JG)%MATRIX)) THEN + CALL XABORT('LIBRSC: U_M(JG)%MATRIX IS NOT ASSOCIATED.') + ENDIF + MJ=MRANK(JG) + IF(LI.EQ.1) THEN + NJJ(IG)=NJJ(IG)+1 + ALLOCATE(DDD_M(JG)%MATRIX(LGBIN,MJ)) + DDD_M(JG)%MATRIX(:LGBIN,:MJ)=0.0D0 + ENDIF + DO LJ=1,LGBIN2 + DDD_M(JG)%MATRIX(LI,:MJ)=DDD_M(JG)%MATRIX(LI,:MJ)+ + 1 STR(LLJ+LJ)*U_M(JG)%MATRIX(LJ,:MJ) + ENDDO + IF(JG.GT.1) LLJ=LLJ-NFS(JG-1) + ENDDO + ENDDO + ! + DO JG=IG-NJJ(IG)+1,IG + IF(ASSOCIATED(U_M(IG)%MATRIX).AND. + 1 ASSOCIATED(DDD_M(JG)%MATRIX)) THEN + MJ=MRANK(JG) + ALLOCATE(SSIGS(MI,MJ)) + DO I=1,MI + DO J=1,MJ + SSIGS(I,J)=DOT_PRODUCT(U_M(IG)%MATRIX(:LGBIN,I), + 1 DDD_M(JG)%MATRIX(:LGBIN,J)) + ENDDO + ENDDO + SCAT_M(JG)%MATRIX => SSIGS + NULLIFY(SSIGS) + DEALLOCATE(DDD_M(JG)%MATRIX) + ENDIF + ENDDO +*---- +* LINEAR TRANSFORMATION +*---- + ALLOCATE(TTT(MI,MI)) + TTT(:MI,:MI)=TRANSPOSE(T_M(IG)%MATRIX(:MI,:MI)) + IF(ASSOCIATED(SIGT_M(IG)%MATRIX)) THEN + ALLOCATE(TSIGT_M(IG)%MATRIX(MI,MI)) + ALLOCATE(SSIGT(MI,MI),DDD(MI,MI)) + DO I=1,MI + DO J=1,MI + DDD(I,J)=DOT_PRODUCT(SIGT_M(IG)%MATRIX(I,:MI), + 1 T_M(IG)%MATRIX(:MI,J)) + ENDDO + ENDDO + SSIGT=MATMUL(TTT,DDD) + TSIGT_M(IG)%MATRIX => SSIGT + NULLIFY(SSIGT) + DEALLOCATE(DDD,SIGT_M(IG)%MATRIX) + ENDIF + DO JG=1,IG + IF(ASSOCIATED(SCAT_M(JG)%MATRIX)) THEN + MJ=MRANK(JG) + ALLOCATE(TSCAT_M(IG,JG)%MATRIX(MI,MJ)) + ALLOCATE(SSIGS(MI,MJ),DDD(MI,MJ)) + DO I=1,MI + DO J=1,MJ + DDD(I,J)=DOT_PRODUCT(SCAT_M(JG)%MATRIX(I,:MJ), + 1 T_M(JG)%MATRIX(:MJ,J)) + ENDDO + ENDDO + SSIGS=MATMUL(TTT,DDD) + TSCAT_M(IG,JG)%MATRIX => SSIGS + NULLIFY(SSIGS) + DEALLOCATE(DDD,SCAT_M(JG)%MATRIX) + ENDIF + ENDDO + DEALLOCATE(TTT) + LLL=LLL+LGBIN + ENDDO + DEALLOCATE(DDD_M) +*---- +* SAVE INFORMATION IN IPLIB +*---- + NPOS=0 + DO IG=1,NGRP + NPOS=NPOS+NJJ(IG) + ENDDO + CALL LCMSIX(KPLIB1,'PT-TABLE',1) + CALL LCMSIX(KPLIB1,HNAMIS2,1) + LPLIB1=LCMLID(KPLIB1,'SIGT_M',NGRP) ! holds TSIGT_M information + LPLIB2=LCMLID(KPLIB1,'SCAT_M',NPOS) ! holds TSCAT_M information + CALL LCMPUT(KPLIB1,'NJJS00',NGRP,1,NJJ) + CALL LCMSIX(KPLIB1,' ',2) + IPOS=0 + DO IG=1,NGRP + MI=MRANK(IG) + IF(MI.EQ.0) CYCLE + IF(ASSOCIATED(TSIGT_M(IG)%MATRIX)) THEN + CALL LCMPDL(LPLIB1,IG,MI*MI,4,TSIGT_M(IG)%MATRIX) + DEALLOCATE(TSIGT_M(IG)%MATRIX) + ENDIF + DO JG=IG,IG-NJJ(IG)+1,-1 + MJ=MRANK(JG) + IPOS=IPOS+1 + IF(IPOS.GT.NPOS) CALL XABORT('LIBRSC: NPOS OVERFLOW.') + IF(ASSOCIATED(TSCAT_M(IG,JG)%MATRIX)) THEN + CALL LCMPDL(LPLIB2,IPOS,MI*MJ,4,TSCAT_M(IG,JG)%MATRIX) + DEALLOCATE(TSCAT_M(IG,JG)%MATRIX) + ELSE + ALLOCATE(SSIGS(MI,MJ)) + SSIGS(:MI,:MJ)=0.0D0 + CALL LCMPDL(LPLIB2,IPOS,MI*MJ,4,SSIGS) + DEALLOCATE(SSIGS) + ENDIF + ENDDO + ENDDO + CALL LCMSIX(KPLIB1,' ',2) + 20 CONTINUE + 30 CONTINUE +*---- +* ERASE T_M AND U_M DATA +*---- + DO 40 ISOT=1,NBISO + IF(.NOT.MASKI(ISOT).OR.(LSHI(ISOT).EQ.0).OR.LCORR(ISOT)) GO TO 40 + KPLIB1=IPISO(ISOT) + CALL LCMSIX(KPLIB1,'PT-TABLE',1) + LPLIB1=LCMGID(KPLIB1,'GROUP-RSE') + DO IG=1,NGRP + IF(NFS(IG).EQ.0) CYCLE + MPLIB=LCMGIL(LPLIB1,IG) + CALL LCMDEL(MPLIB,'T_M') + CALL LCMDEL(MPLIB,'U_M') + ENDDO + CALL LCMSIX(KPLIB1,' ',2) + 40 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(TSCAT_M,TSIGT_M,SCAT_M,SIGT_M,T_M,U_M) + DEALLOCATE(STIS,PRI,SIGS,SIGT,STR,DEL,UUU,EBIN) + DEALLOCATE(LCORR,ISOMIX,MRANK,NJJ,IPISO) + RETURN + END diff --git a/Dragon/src/LIBRSE.f b/Dragon/src/LIBRSE.f new file mode 100644 index 0000000..541e404 --- /dev/null +++ b/Dragon/src/LIBRSE.f @@ -0,0 +1,573 @@ +*DECK LIBRSE + SUBROUTINE LIBRSE(IPLIB,IPTMP,MAXTRA,HNAMIS,LBIN,NGRP,NL,NED, + 1 NDEL,HVECT,NFS,IMPX,DELI,AWR,IALTER,SVDEPS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Process snapshots for the resonance spectrum expansion method. +* +*Copyright: +* Copyright (C) 2023 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the isotopic directory in microlib. +* IPTMP pointer to the multi-dilution internal library. +* MAXTRA maximum number of energy bins of size DELI. +* HNAMIS local name of the isotope: +* HNAMIS(1:8) is the local isotope name; +* HNAMIS(9:12) is a suffix function of the mix number. +* LBIN number of fine energy groups. +* NGRP number of coarse energy groups. +* NL number of Legendre orders required in the calculation +* (NL=1 or higher). +* NED number of extra vector edits. +* NDEL number of delayed neutron precursor groups. +* HVECT names of the extra vector edits. +* NFS number of fine energy groups in each coarse energy group. +* IMPX print flag (equal to zero for no print). +* DELI elementary lethargy width. +* AWR mass ratio for current isotope. +* IALTER type of approximation (=0: use exponentials; =1: use Taylor +* expansions). +* SVDEPS rank accuracy of the singular value decomposition. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB,IPTMP + INTEGER MAXTRA,LBIN,NGRP,NL,NED,NDEL,NFS(NGRP),IMPX,IALTER + REAL DELI,AWR,SVDEPS + CHARACTER HNAMIS*12,HVECT(NED)*8 +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPLIB1,JPLIB2,KPLIB,JPTMP,KPTMP + PARAMETER (MAXITER=100,MAXNOR=12) + CHARACTER TEXT12*12 + LOGICAL LGOLD,LRSE + DOUBLE PRECISION DQQ,GAR0,GAR1(3),FFF + CHARACTER(LEN=4),DIMENSION(4),PARAMETER :: + 1 HPART=(/'NWT0','NTOT','SIGF','SIGS'/) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NJJ,MRANK + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISMIN,ISMAX,ISM + REAL, ALLOCATABLE, DIMENSION(:) :: DELTAU,EBIN,UUU,DEL,STR,SIGS, + 1 SIGT,PRI,STIS,KSN,DILUT,DELTG,GOLD,SIGP + REAL, ALLOCATABLE, DIMENSION(:,:) :: FLUX,TOTAL,SIGF + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SIGSD,SADD,ZDEL + REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: SCAT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: W,PHIGAR,DGAR + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: V,XSDIL,TTT,DDD + DOUBLE PRECISION, POINTER, DIMENSION(:,:) :: U,SSIGS,SSIGT + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LSCAT,LADD + COMPLEX(KIND=8), ALLOCATABLE, DIMENSION(:,:) :: CT,CD + TYPE VECTOR_ARRAY + DOUBLE PRECISION, POINTER, DIMENSION(:) :: VECTOR + END TYPE VECTOR_ARRAY + TYPE MATRIX_ARRAY + DOUBLE PRECISION, POINTER, DIMENSION(:,:) :: MATRIX + END TYPE MATRIX_ARRAY + TYPE(VECTOR_ARRAY), ALLOCATABLE, DIMENSION(:) :: UU_V,U_V,SIGT_V, + 1 WEIGHT_V,GAMMA_V + TYPE(MATRIX_ARRAY), ALLOCATABLE, DIMENSION(:) :: PHI_M,DDD_M,U_M, + 1 V_M,SIGT_M,T_M,SIGP_M,EFF_M + TYPE(MATRIX_ARRAY), ALLOCATABLE, DIMENSION(:,:) :: SCAT_M,TSCAT_M +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NJJ(NGRP),MRANK(NGRP)) + ALLOCATE(EBIN(LBIN+1),UUU(LBIN+1),DEL(LBIN),STR(LBIN),SIGS(LBIN), + 1 SIGT(LBIN),PRI(MAXTRA),STIS(LBIN),EFF_M(NGRP),PHI_M(NGRP), + 2 UU_V(NGRP),U_V(NGRP),U_M(NGRP),V_M(NGRP),SIGT_M(NGRP), + 3 SCAT_M(NGRP,NGRP),T_M(NGRP),SIGT_V(NGRP),WEIGHT_V(NGRP), + 4 GAMMA_V(NGRP),TSCAT_M(NGRP,NGRP),SIGP_M(NGRP),ISM(2,NL)) + CALL LCMLEN(IPTMP,'ISOTOPESLIST',NDIL,ITYLCM) + ALLOCATE(FLUX(NGRP,NDIL),TOTAL(NGRP,NDIL),SIGF(NGRP,NDIL), + 1 SIGSD(NGRP,NL,NDIL),SCAT(NGRP,NGRP,NL,NDIL),SADD(NGRP,NED,NDIL), + 2 ZDEL(NGRP,NDEL,NDIL),DELTG(NGRP),LSCAT(NL),LADD(NED),GOLD(NGRP), + 3 ISMIN(NL,NGRP),ISMAX(NL,NGRP)) +*---- +* ALLOCATE DILUTION-DEPENDENT ARRAYS +*---- + ALLOCATE(DILUT(NDIL),KSN(NGRP*NDIL),DELTAU(NGRP)) + CALL LCMGET(IPTMP,'DELTAU',DELTAU) + CALL LCMGET(IPTMP,'ISOTOPESDSN',KSN) + DO IDIL=1,NDIL + DILUT(IDIL)=KSN((IDIL-1)*NGRP+1) + ENDDO + DEALLOCATE(KSN) + IF(IMPX.GT.2) THEN + WRITE(6,'(/32H LIBRSE: DILUTIONS FOR ISOTOPE '',A12,2H'':)') + 1 HNAMIS + WRITE(6,'(1X,1P,12E12.4)') DILUT(:NDIL) + ENDIF +*---- +* RECOVER INFORMATION FROM *TEMPORARY* LCM OBJECT. +*---- + NDIL=NDIL-1 + CALL LIBEXT(IPTMP,NGRP,NL,NDIL,NED,HVECT,NDEL,.TRUE.,IMPX,DILUT, + 1 MDIL,LSCAT,LSIGF,LADD,LGOLD,FLUX,TOTAL,SIGF,SIGSD,SCAT,SADD, + 2 ZDEL,DELTG,GOLD,ISMIN,ISMAX) + NDIL=NDIL+1 +*---- +* COPY INFINITE DILUTION DATA FROM IPTMP TO IPLIB. +*---- + JPTMP=LCMGID(IPTMP,'ISOTOPESLIST') + CALL LCMLEL(JPTMP,NDIL,ILENG,ITYLCM) + IF(ILENG.EQ.0) THEN + TEXT12=HNAMIS(1:8) + WRITE(TEXT12(9:12),'(I4.4)') NDIL + CALL XABORT('LIBRSE: MISSING LIST ITEM FOR '//TEXT12) + ENDIF + KPTMP=LCMGIL(JPTMP,NDIL) ! set NDIL-th isotope + CALL LCMLEN(KPTMP,'LAMBDA-D',NDEL,ITYLCM) + CALL LCMEQU(KPTMP,IPLIB) +* +* DESTROY THE MULTI-DILUTION INTERNAL LIBRARY. + CALL LCMCL(IPTMP,2) +*---- +* RECOVER AUTOLIB DATA. +*---- + CALL LCMGET(IPLIB,'BIN-ENERGY',EBIN) + CALL LCMGET(IPLIB,'BIN-NTOT0',SIGT) + CALL LCMGET(IPLIB,'BIN-SIGS00',SIGS) +*---- +* NULLIFY POINTERS +*---- + DO IG=1,NGRP + NULLIFY(SIGT_M(IG)%MATRIX) + DO JG=1,NGRP + NULLIFY(SCAT_M(IG,JG)%MATRIX) + NULLIFY(TSCAT_M(IG,JG)%MATRIX) + ENDDO + ENDDO +*---- +* ELASTIC SCATTERING INFORMATION USED TO REBUILD THE SCAT MATRIX. +*---- + IBIN=0 + DELMIN=1.0E10 + UUU(1)=0.0 + DO IG=1,NGRP + FFF=0.0D0 + DO LI=1,NFS(IG) + DELM=LOG(EBIN(IBIN+LI)/EBIN(IBIN+LI+1)) + UUU(IBIN+LI+1)=LOG(EBIN(1)/EBIN(IBIN+LI+1)) + DEL(IBIN+LI)=DELM + DELMIN=MIN(DELMIN,DELM) + FFF=FFF+DELM + ENDDO + FFF=DELTAU(IG)/FFF + DEL(IBIN+1:IBIN+NFS(IG))=DEL(IBIN+1:IBIN+NFS(IG))*REAL(FFF) + IBIN=IBIN+NFS(IG) + ENDDO + CALL LCMLEN(IPLIB,'BIN-DELI',LENGT,ITYLCM) + IF((LENGT.EQ.1).AND.(ITYLCM.EQ.2)) THEN + CALL LCMGET(IPLIB,'BIN-DELI',DELI) + ELSE + DELI=1.0/REAL(INT(1.00001/DELMIN)) + ENDIF + PRI(:MAXTRA)=0.0 + CALL LIBPRI(MAXTRA,DELI,AWR,IALTER,0,NEXT,PRI) +*---- +* SOLVE FLUX CALCULATOR CASES FOR MANY DILUTIONS +*---- + LLL=0 + DO IG=1,NGRP + LGBIN=NFS(IG) + IF(LGBIN.EQ.0) CYCLE + ALLOCATE(EFF_M(IG)%MATRIX(NDIL,3)) + ALLOCATE(PHI_M(IG)%MATRIX(NFS(IG),NDIL)) + LLL=LLL+LGBIN + ENDDO + ALLOCATE(PHIGAR(LBIN)) + DO IDIL=1,NDIL + PHIGAR(:)=0.0D0 + LLL=0 + DO IG=1,NGRP + IF(IMPX.GE.9) WRITE(6,'(29H LIBRSE: coarse energy group=,I8, + 1 10H dilution=,1P,E12.4)') IG,DILUT(IDIL) + LGBIN=NFS(IG) + IF(LGBIN.EQ.0) CYCLE + LLL1=LLL + GAR0=0.0D0 + GAR1(:3)=0.0D0 + DO LI=1,LGBIN + LLL=LLL+1 + III=1 + STR(:LBIN)=0.0 + CALL LIBECT(MAXTRA,LLL,PRI,UUU(2),DELI,DEL,NEXT,III,MML, + 1 STIS) + DO MM=1,MML + STR(MM)=STR(MM)+STIS(MM)*SIGS(LLL-MM+1) + ENDDO + SIGMA=SIGT(LLL)-STR(1) + DQQ=DILUT(IDIL)*DEL(LLL) + DO MM=2,MIN(LLL,MML) + DQQ=DQQ+STR(MM)*PHIGAR(LLL-MM+1) + ENDDO + PHIGAR(LLL)=DQQ/(DILUT(IDIL)+SIGMA) + GAR0=GAR0+(UUU(LLL+1)-UUU(LLL)) + GAR1(1)=GAR1(1)+PHIGAR(LLL) + GAR1(2)=GAR1(2)+SIGT(LLL)*PHIGAR(LLL) + GAR1(3)=GAR1(3)+SIGS(LLL)*PHIGAR(LLL) + ENDDO + FFF=FLUX(IG,IDIL)*GAR0/GAR1(1) + PHI_M(IG)%MATRIX(:LGBIN,IDIL)=PHIGAR(LLL1+1:LLL1+LGBIN)*FFF + EFF_M(IG)%MATRIX(IDIL,:3)=GAR1(:3)*FFF/GAR0 + ENDDO + ENDDO + DEALLOCATE(PHIGAR) +*---- +* LOOP OVER RESONANT GROUPS +*---- + MRANK(:NGRP)=0 + ALLOCATE(W(NDIL),V(NDIL,NDIL),DDD_M(NGRP)) + LLL=0 + DO IG=1,NGRP + NJJ(IG)=0 + LRSE=(NFS(IG).GT.0).AND.(GOLD(IG).EQ.-1001.0) + IF(.NOT.LRSE) CYCLE + LGBIN=NFS(IG) + ALLOCATE(U(LGBIN,NDIL)) + U(:LGBIN,:NDIL)=PHI_M(IG)%MATRIX(:LGBIN,:NDIL) + !***************** SVD ***************** + CALL ALSVDF(U,LGBIN,NDIL,LGBIN,NDIL,W,V) + !*************************************** + U_M(IG)%MATRIX=>U + DO IDIL=1,NDIL + IF(W(IDIL).LE.SVDEPS*DELI) THEN + EXIT + ELSE + MRANK(IG)=MRANK(IG)+1 + IF(MRANK(IG).GT.20) CALL XABORT('LIBRSE: MRANK OVERFLOW.') + ENDIF + ENDDO + MI=MRANK(IG) + IF(MI.EQ.0) CYCLE + ALLOCATE(V_M(IG)%MATRIX(NDIL,MI)) + DO IM=1,MI + V_M(IG)%MATRIX(:NDIL,IM)=V(:NDIL,IM)/W(IM) + ENDDO + ! + ! compute UU_V and U_V + ALLOCATE(UU_V(IG)%VECTOR(MI),U_V(IG)%VECTOR(MI)) + DO IMR1=1,MI + UU_V(IG)%VECTOR(IMR1)=SUM(U_M(IG)%MATRIX(:LGBIN,IMR1)) + U_V(IG)%VECTOR(IMR1)=0.0D0 + DO LI=1,LGBIN + U_V(IG)%VECTOR(IMR1)=U_V(IG)%VECTOR(IMR1)+DEL(LLL+LI)* + 1 U_M(IG)%MATRIX(LI,IMR1) + ENDDO + ENDDO + ! + ! compute SIGT_M + ALLOCATE(SSIGT(MI,MI)) + SSIGT(:,:)=0.0D0 + DO LI=1,LGBIN + SIGMA=SIGT(LLL+LI) + DO IMR1=1,MI + DO IMR2=1,MI + SSIGT(IMR1,IMR2)=SSIGT(IMR1,IMR2)+U_M(IG)%MATRIX(LI,IMR1)* + 1 SIGMA*U_M(IG)%MATRIX(LI,IMR2) + ENDDO + ENDDO + ENDDO + SIGT_M(IG)%MATRIX=>SSIGT + NULLIFY(SSIGT) + ! + ! compute SCAT_M + DO JG=1,NGRP + NULLIFY(DDD_M(JG)%MATRIX) + ENDDO + DO LI=1,LGBIN + III=1 + STR(:LBIN)=0.0 + CALL LIBECT(MAXTRA,LLL+LI,PRI,UUU(2),DELI,DEL,NEXT,III,MML, + 1 STIS) + DO MM=1,MML + LLJ=LLL+LI-MM+1 + STR(LLJ)=STIS(MM)*SIGS(LLJ) + ENDDO + LLJ=LLL + DO JG=IG,1,-1 + LGBIN2=NFS(JG) + IF(LLL+LI-MML+1.GT.LLJ+LGBIN2) EXIT + IF(.NOT.ASSOCIATED(U_M(JG)%MATRIX)) THEN + CALL XABORT('LIBRSE: U_M(JG)%MATRIX IS NOT ASSOCIATED.') + ENDIF + MJ=MRANK(JG) + IF(LI.EQ.1) THEN + NJJ(IG)=NJJ(IG)+1 + ALLOCATE(DDD_M(JG)%MATRIX(LGBIN,MJ)) + DDD_M(JG)%MATRIX(:LGBIN,:MJ)=0.0D0 + ENDIF + DO LJ=1,LGBIN2 + DDD_M(JG)%MATRIX(LI,:MJ)=DDD_M(JG)%MATRIX(LI,:MJ)+ + 1 STR(LLJ+LJ)*U_M(JG)%MATRIX(LJ,:MJ) + ENDDO + IF(JG.GT.1) LLJ=LLJ-NFS(JG-1) + ENDDO + ENDDO + ! + NPOS=0 + DO JG=IG-NJJ(IG)+1,IG + IF(ASSOCIATED(U_M(IG)%MATRIX).AND. + 1 ASSOCIATED(DDD_M(JG)%MATRIX)) THEN + MJ=MRANK(JG) + NPOS=NPOS+1 + ALLOCATE(SSIGS(MI,MJ)) + SSIGS=MATMUL(TRANSPOSE(U(:LGBIN,:MI)), + 1 DDD_M(JG)%MATRIX(:LGBIN,:MJ)) + SCAT_M(IG,JG)%MATRIX => SSIGS + NULLIFY(SSIGS) + DEALLOCATE(DDD_M(JG)%MATRIX) + ENDIF + ENDDO + IF(NPOS.EQ.0) CALL XABORT('LIBRSE: NPOS=0.') +*---- +* LINEAR TRANSFORMATION +*---- + ALLOCATE(T_M(IG)%MATRIX(MI,MI),SIGT_V(IG)%VECTOR(MI)) + ALLOCATE(WEIGHT_V(IG)%VECTOR(MI),GAMMA_V(IG)%VECTOR(MI)) + ALLOCATE(CT(MI,MI),CD(MI,MI)) + CALL ALHQR(MI,MI,SIGT_M(IG)%MATRIX,MAXITER,ITER,CT,CD) + DO LI=1,MI + IF(AIMAG(CD(LI,LI)) /= 0.0D0) THEN + CALL XABORT('LIBRSE: COMPLEX EIGENVALUE FOUND.') + ENDIF + SIGT_V(IG)%VECTOR(LI)=REAL(CD(LI,LI),8) + DO LJ=1,MI + T_M(IG)%MATRIX(LI,LJ)=REAL(CT(LI,LJ),8) + ENDDO + ENDDO + DEALLOCATE(CD,CT) + ALLOCATE(TTT(MI,MI)) + TTT(:MI,:MI)=TRANSPOSE(T_M(IG)%MATRIX(:MI,:MI)) + WEIGHT_V(IG)%VECTOR=MATMUL(TTT,UU_V(IG)%VECTOR)/DELTG(IG) + GAMMA_V(IG)%VECTOR=MATMUL(TTT,U_V(IG)%VECTOR) + DO JG=1,IG + IF(ASSOCIATED(SCAT_M(IG,JG)%MATRIX)) THEN + MJ=MRANK(JG) + ALLOCATE(TSCAT_M(IG,JG)%MATRIX(MI,MJ)) + ALLOCATE(SSIGS(MI,MJ),DDD(MI,MJ)) + DDD=MATMUL(SCAT_M(IG,JG)%MATRIX,T_M(JG)%MATRIX) + SSIGS=MATMUL(TTT,DDD) + TSCAT_M(IG,JG)%MATRIX => SSIGS + NULLIFY(SSIGS) + DEALLOCATE(DDD) + ENDIF + ENDDO + DEALLOCATE(TTT) + LLL=LLL+LGBIN + IF(IMPX.EQ.1) THEN + WRITE(6,'(15H LIBRSE: RANK('',A12,2H'',,I4,2H)=,I3)') HNAMIS, + 1 IG,MI + ELSE IF(IMPX.GE.2) THEN + WRITE(6,'(/10H LIBRSE: '',A12,27H'' SIGT BASE POINTS IN GROUP, + 1 I5,1H:)') HNAMIS,IG + WRITE(6,'(1X,1P,12E12.4)') SIGT_V(IG)%VECTOR(:MI) + ENDIF + IF(IMPX.GE.3) THEN + WRITE(6,'(/10H LIBRSE: '',A12,23H'' NWT0 WEIGHTS IN GROUP,I5, + 1 1H:)') HNAMIS,IG + WRITE(6,'(1X,1P,12E12.4)') WEIGHT_V(IG)%VECTOR(:MI) + ENDIF + ENDDO + DEALLOCATE(DDD_M) +*---- +* COMPUTE RESONANCE SPECTRUM EXPANSION TABLES +* XSDIL dilution dependent self-shielded cross sections: +* XSDIL(1,:NDIL) self-shielded fluxes; +* XSDIL(2,:NDIL) total self-shielded cross sections; +* XSDIL(3,:NDIL) nu*fission self-shielded cross sections; +* XSDIL(4,:NDIL) P0 scattering cross sections; +* etc. +* XSDIL(j,NDIL) are the infinite dilution values. +*---- + ALLOCATE(DGAR(NDIL)) + DO IG=1,NGRP + MI=MRANK(IG) + IF(MI.EQ.0) CYCLE + NPART=3+NL+NED+NDEL + DO IL=1,NL + NPART=NPART+MAX(ISMAX(IL,IG)-ISMIN(IL,IG)+1,0) + ENDDO + ALLOCATE(SIGP_M(IG)%MATRIX(NPART,MI),XSDIL(NPART,NDIL)) + XSDIL(1,:NDIL)=EFF_M(IG)%MATRIX(:NDIL,1) + XSDIL(2,:NDIL)=EFF_M(IG)%MATRIX(:NDIL,2) + XSDIL(3,:NDIL)=SIGF(IG,:NDIL)*XSDIL(1,:NDIL) + XSDIL(4,:NDIL)=EFF_M(IG)%MATRIX(:NDIL,3) + DGAR(:NDIL)=XSDIL(4,:NDIL)/(SIGSD(IG,1,:NDIL)*XSDIL(1,:NDIL)) + DO IL=2,NL + XSDIL(3+IL,:NDIL)=DGAR(:NDIL)*SIGSD(IG,IL,:NDIL)*XSDIL(1,:NDIL) + ENDDO + IF(NPART.EQ.3+NL) EXIT + IOF=3+NL + DO IL=1,NL + IF(LSCAT(IL)) THEN + DO JG=ISMIN(IL,IG),ISMAX(IL,IG) + IOF=IOF+1 + XSDIL(IOF,:NDIL)=DGAR(:NDIL)*SCAT(JG,IG,IL,:NDIL)* + 1 XSDIL(1,:NDIL) + ENDDO + ENDIF + ENDDO + DO IED=1,NED + IOF=IOF+1 + IF((HVECT(IED).EQ.'NINEL').OR.(HVECT(IED).EQ.'NELAS').OR. + 1 (HVECT(IED).EQ.'N2N').OR.(HVECT(IED).EQ.'N3N').OR. + 2 (HVECT(IED).EQ.'N4N').OR.(HVECT(IED).EQ.'NX').OR. + 3 (HVECT(IED).EQ.'STRD')) THEN + XSDIL(IOF,:NDIL)=SADD(IG,IED,:NDIL)*XSDIL(1,:NDIL) + ELSE + XSDIL(IOF,:NDIL)=SADD(IG,IED,:NDIL)*XSDIL(1,:NDIL) + ENDIF + ENDDO + DO IDEL=1,NDEL + IOF=IOF+1 + XSDIL(IOF,:NDIL)=ZDEL(IG,IDEL,:NDIL)*XSDIL(1,:NDIL) + ENDDO + IF(IOF.NE.NPART) CALL XABORT('LIBRSE: INVALID NPART.') + ALLOCATE(DDD(NPART,MI)) + DDD(:NPART,:MI)=MATMUL(XSDIL(:NPART,:NDIL), + 1 V_M(IG)%MATRIX(:NDIL,:MI)) + SIGP_M(IG)%MATRIX(:NPART,:MI)=MATMUL(DDD(:NPART,:MI), + 1 T_M(IG)%MATRIX(:MI,:MI)) + DEALLOCATE(DDD,XSDIL) + IF(IMPX.GE.3) THEN + WRITE(6,'(/10H LIBRSE: '',A12,27H'' TABLE COMPONENTS IN GROUP, + 1 I5,1H:)') HNAMIS,IG + DO IPART=1,4 + IF(IPART.EQ.1) THEN + WRITE(6,'(1X,A5,1P,12E12.4/(6X,12E12.4))') HPART(IPART), + 1 SIGP_M(IG)%MATRIX(1,:MI) + ELSE + WRITE(6,'(1X,A5,1P,12E12.4/(6X,12E12.4))') HPART(IPART), + 1 SIGP_M(IG)%MATRIX(IPART,:MI)/SIGP_M(IG)%MATRIX(1,:MI) + ENDIF + ENDDO + ENDIF + ENDDO + DEALLOCATE(DGAR) +*---- +* SAVE SCAT_M INFORMATION IN IPLIB +*---- + CALL LCMSIX(IPLIB,'PT-TABLE',1) + NPOS=0 + DO IG=1,NGRP + DO JG=1,IG + IF(ASSOCIATED(SCAT_M(IG,JG)%MATRIX)) NPOS=NPOS+1 + ENDDO + ENDDO + IF(NPOS.EQ.0) GO TO 10 + CALL LCMSIX(IPLIB,HNAMIS,1) + JPLIB2=LCMLID(IPLIB,'SCAT_M',NPOS) ! holds TSCAT_M information + IPOS=0 + DO IG=1,NGRP + MI=MRANK(IG) + IF(MI.EQ.0) CYCLE + NJJ(IG)=0 + DO JG=IG,1,-1 + IF(ASSOCIATED(SCAT_M(IG,JG)%MATRIX)) THEN + MJ=MRANK(JG) + IPOS=IPOS+1 + IF(IPOS.GT.NPOS) CALL XABORT('LIBRSE: NPOS OVERFLOW.') + NJJ(IG)=NJJ(IG)+1 + CALL LCMPDL(JPLIB2,IPOS,MI*MJ,4,TSCAT_M(IG,JG)%MATRIX) + DEALLOCATE(TSCAT_M(IG,JG)%MATRIX) + ENDIF + ENDDO + ENDDO + CALL LCMPUT(IPLIB,'NJJS00',NGRP,1,NJJ) + CALL LCMSIX(IPLIB,' ',2) +*---- +* SAVE GROUP-RSE INFORMATION IN IPLIB +*---- + 10 CALL LCMPUT(IPLIB,'NDEL',1,1,NDEL) + CALL LCMPUT(IPLIB,'SVD-EPS',1,2,SVDEPS) + JPLIB1=LCMLID(IPLIB,'GROUP-RSE',NGRP) + DO IG=1,NGRP + MI=MRANK(IG) + IF(MI.EQ.0) CYCLE + NPART=SIZE(SIGP_M(IG)%MATRIX,1) + KPLIB=LCMDIL(JPLIB1,IG) + LGBIN=NFS(IG) + CALL LCMPUT(KPLIB,'SIGT_V',MI,4,SIGT_V(IG)%VECTOR) + CALL LCMPUT(KPLIB,'WEIGHT_V',MI,4,WEIGHT_V(IG)%VECTOR) + CALL LCMPUT(KPLIB,'GAMMA_V',MI,4,GAMMA_V(IG)%VECTOR) + CALL LCMPUT(KPLIB,'T_M',MI*MI,4,T_M(IG)%MATRIX) + CALL LCMPUT(KPLIB,'U_M',LGBIN*MI,4,U_M(IG)%MATRIX) + CALL LCMPUT(KPLIB,'RSE-TABLE',NPART*MI,4,SIGP_M(IG)%MATRIX) + DEALLOCATE(SIGT_V(IG)%VECTOR,GAMMA_V(IG)%VECTOR, + 1 WEIGHT_V(IG)%VECTOR,SIGP_M(IG)%MATRIX) + DO IL=1,NL + ISM(1,IL)=ISMIN(IL,IG) + ISM(2,IL)=ISMAX(IL,IG) + ENDDO + CALL LCMPUT(KPLIB,'ISM-LIMITS',2*NL,1,ISM) + CALL LCMVAL(KPLIB,' ') + ENDDO +*---- +* PROCESS UNRESOLVED ENERGY DOMAIN. +*---- + JPLIB1=LCMLID(IPLIB,'GROUP-PT',NGRP) + DO IG=1,NGRP + LRSE=(NFS(IG).GT.0).AND.(GOLD(IG).EQ.-1001.0) + IF(LRSE) CYCLE + NPART=3+NL+NED+NDEL + DO IL=1,NL + NPART=NPART+MAX(ISMAX(IL,IG)-ISMIN(IL,IG)+1,0) + ENDDO + ALLOCATE(SIGP(MAXNOR*NPART)) + SIGP(:MAXNOR*NPART)=0.0 + NDIL=NDIL-1 + CALL LIBTAB(IG,NGRP,NL,NDIL,NPART,NED,NDEL,HNAMIS,IMPX,LSCAT, + 1 LSIGF,LADD,DILUT,TOTAL,SIGF,SIGSD,SCAT,SADD,ZDEL,1.0,ISMIN, + 2 ISMAX,MRANK(IG),SIGP) + NDIL=NDIL+1 +* + IF(MRANK(IG).GT.1) THEN +* SAVE THE PROBABILITY TABLE INTO IPLIB. + KPLIB=LCMDIL(JPLIB1,IG) + CALL LCMPUT(KPLIB,'PROB-TABLE',MAXNOR*NPART,2,SIGP) + DO IL=1,NL + ISM(1,IL)=ISMIN(IL,IG) + ISM(2,IL)=ISMAX(IL,IG) + ENDDO + CALL LCMPUT(KPLIB,'ISM-LIMITS',2*NL,1,ISM) + ENDIF + DEALLOCATE(SIGP) + ENDDO + CALL LCMPUT(IPLIB,'NOR',NGRP,1,MRANK) + CALL LCMSIX(IPLIB,' ',2) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DO IG=1,NGRP + LRSE=(NFS(IG).GT.0).AND.(GOLD(IG).EQ.-1001.0) + IF(.NOT.LRSE) CYCLE + DEALLOCATE(U_M(IG)%MATRIX,U_V(IG)%VECTOR,UU_V(IG)%VECTOR) + DEALLOCATE(PHI_M(IG)%MATRIX,EFF_M(IG)%MATRIX) + DEALLOCATE(T_M(IG)%MATRIX,V_M(IG)%MATRIX) + ENDDO + DEALLOCATE(ISMAX,ISMIN) + DEALLOCATE(GOLD,LADD,LSCAT,DELTG,ZDEL,SADD,SCAT,SIGSD,SIGF,TOTAL, + 1 FLUX) + DEALLOCATE(DELTAU,DILUT,ISM,SIGP_M,TSCAT_M,WEIGHT_V,GAMMA_V, + 1 SIGT_V,T_M,SCAT_M,SIGT_M,V_M,U_M,UU_V,U_V,PHI_M,EFF_M,V,W,STIS, + 2 PRI,SIGT,SIGS,STR,DEL,UUU,EBIN) + DEALLOCATE(MRANK,NJJ) + RETURN + END diff --git a/Dragon/src/LIBSDC.f b/Dragon/src/LIBSDC.f new file mode 100644 index 0000000..f231c23 --- /dev/null +++ b/Dragon/src/LIBSDC.f @@ -0,0 +1,203 @@ +*DECK LIBSDC + SUBROUTINE LIBSDC(NBMIX,NGROUP,NBISO,ISONRF,MIX,DEN,MASK,ENER, + 1 KGAS,DENMAT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Apply Sternheimer density correction to the collision stopping power. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert and A. Naceur +* +*Parameters: input +* NBMIX number of mixtures present in the calculation domain. +* NGROUP number of energy groups. +* NBISO number of isotopes present in the calculation domain. +* ISONRF character*12 reference names of isotopes. +* MIX mixture number of each isotope (can be zero). +* DEN density of each isotope. +* MASK mixture mask (=.true. if a mixture is to be made). +* ENER energy groups limits. +* KGAS state of each mixture (=0: solid/liquid; =1: gas). +* +*Parameters: input/output +* DENMAT Sterheimer density correction (delta). +* +*References: +* [1]. L. J. Lorence Jr., J. E. Morel, and G. D. Valdez, "Physics guide +* to CEPXS: A multigroup coupled electron-photon cross section +* generating code," Technical report SAND89-1685, Sandia National +* Laboratories, Albuquerque, New Mexico 87185 and Livermore, +* California 94550. +* +* [2]. Sternheimer, R. M. (1956). Density effect for the ionization +* loss in various materials. Physical Review, 103(3), 511. +*----------------------------------------------------------------------- +* + IMPLICIT DOUBLE PRECISION(A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER :: NBMIX,NGROUP,NBISO,MIX(NBISO),KGAS(NBMIX) + CHARACTER(LEN=12) :: ISONRF(NBISO) + REAL :: DEN(NBISO),ENER(NGROUP+1) !,ESTOP(NBMIX,NGROUP+1) + REAL :: DENMAT(NBMIX,NGROUP+1) + LOGICAL :: MASK(NBMIX) +*---- +* LOCAL VARIABLES +*---- + INTEGER :: I + DOUBLE PRECISION :: PITT(12) + CHARACTER(LEN=2) :: ELEMNT(100) + CHARACTER(LEN=131) :: HSMG + DOUBLE PRECISION, PARAMETER :: DM=3.0D0 ! Sternheimer exponent + DOUBLE PRECISION, PARAMETER :: CEMASS=0.510976D0 !Electron mass MeV + DOUBLE PRECISION, PARAMETER :: C2=0.249467D0 ! 3/8 Thomson xs + DOUBLE PRECISION :: XDRCST +*---- +* DATA STATEMENTS +*---- + DATA (ELEMNT(I),I=1,100) / + 1 'h', 'he', 'li', 'be', 'b', 'c', 'n', + 2 'o', 'f', 'ne', 'na', 'mg', 'al', 'si', + 3 'p', 's', 'cl', 'ar', 'k', 'ca', 'sc', + 4 'ti', 'v', 'cr', 'mn', 'fe', 'co', 'ni', + 5 'cu', 'zn', 'ga', 'ge', 'as', 'se', 'br', + 6 'kr', 'rb', 'sr', 'y', 'zr', 'nb', 'mo', + 7 'tc', 'ru', 'rh', 'pd', 'ag', 'cd', 'in', + 8 'sn', 'sb', 'te', 'i', 'xe', 'cs', 'ba', + 9 'la', 'ce', 'pr', 'nd', 'pm', 'sm', 'eu', + 1 'gd', 'tb', 'dy', 'ho', 'er', 'tm', 'yb', + 2 'lu', 'hf', 'ta', 'w', 're', 'os', 'ir', + 3 'pt', 'au', 'hg', 'tl', 'pb', 'bi', 'po', + 4 'at', 'rn', 'fr', 'ra', 'ac', 'th', 'pa', + 5 'u', 'np', 'pu', 'am', 'cm', 'bk', 'cf', + 6 'es', 'fm' / + DATA (PITT(I),I=1,12) / + 1 18.7D0, 42.0D0, 38.0D0, 60.0D0, 71.0D0, 78.0D0, + 2 85.0D0, 89.0D0, 92.0D0, 131.0D0, 146.0D0, 156.0D0 / +*---- +* MAIN LOOP OVER MIXTURES +*---- + AVCON=1.0D-24*XDRCST('Avogadro','N/moles') + DO IBM=1,NBMIX + IF(MASK(IBM)) THEN +*---- +* CALCULATE THE MEAN IONIZATION ENERGY, EION, IN EV +*---- + EION=0.0D0 + ZZA=0.0D0 + DO ISOT=1,NBISO + IF((MIX(ISOT).NE.IBM).OR.(DEN(ISOT).EQ.0.0)) CYCLE + IZ=0 + DO I=1,100 + IF(ISONRF(ISOT)(:2).EQ.ELEMNT(I)) THEN + IZ=I + EXIT + ENDIF + ENDDO + IF(IZ.EQ.0) THEN + WRITE(HSMG,'(40HLIBSDC: UNABLE TO ASSIGN AN ATOMIC NUMBE, + 1 5HR TO ,A,1H.)') ISONRF(ISOT)(:2) + CALL XABORT(HSMG) + ENDIF + WAZ=DEN(ISOT)*REAL(IZ)/AVCON + IF(IZ.GE.13) THEN +* for Z > 13, use definition of mean ionization given by +* Sternheimer + PIT=(9.76D0+58.8D0*(REAL(IZ)**(-1.19D0)))*REAL(IZ) + ELSE +* obtain ionization energy from the data statement + PIT=PITT(IZ) + ENDIF + EION=EION+WAZ*LOG(PIT) + ZZA=ZZA+WAZ + ENDDO + EION = EXP(EION/ZZA) +*---- +* EVALUATE PLANCK'S CONSTANT TIMES THE PLASMA FREQUENCY IN EV +*---- + HNUP = 28.8D0*SQRT(ZZA) +*---- +* EVALUATE PARAMETERS IN THE STERNHEIMER FORMALISM +*---- + C = - (2.0D0*LOG(EION/HNUP) + 1.0D0) + IF(KGAS(IBM).EQ.0) THEN +* The material is a solid/liquid + IF(EION .GE. 100.D0) THEN + X1 = 3.0D0 + IF(-C .GE. 5.215D0) THEN + X0 = -0.326D0 * C - 1.5D0 + ELSE + X0 = 0.2D0 + ENDIF + ELSE + X1 = 2.0D0 + IF(-C .GE. 3.681D0) THEN + X0 = -0.326D0 * C - 1.0D0 + ELSE + X0 = 0.2D0 + ENDIF + ENDIF + ELSE +* The material is a gas + IF(-C .LT. 12.25D0) THEN + X1 = 4.0D0 + X0 = 2.0D0 + IF(-C .LT. 11.5D0) X0 = 1.9D0 + IF(-C .LT. 11.0D0) X0 = 1.8D0 + IF(-C .LT. 10.5D0) X0 = 1.7D0 + IF(-C .LT. 10.0D0) X0 = 1.6D0 + ELSE IF(-C .GE. 13.804D0) THEN + X1 = 5.0D0 + X0 = -.326D0 * C - 2.5D0 + ELSE + X1 = 5.0D0 + X0 = 2.0D0 + ENDIF + ENDIF +* + IF(X1.LT.X0) THEN + WRITE(HSMG,*) 'LIBSDC: NEGATIVE REAL TO REAL POWER. HAVE ', + 1 'YOU NEGLECTED THE "GAS" KEYWORD FOR A GASEOUS MIXTURE?' + CALL XABORT(HSMG) + ENDIF + B = (-C - 4.606D0*X0) / (X1 - X0)**DM + CONV = 2.0D0*AVCON*C2*CEMASS*ZZA +*---- +* CALCULATE THE DENSITY CORRECTION FACTOR +*---- + DO LLL=1,NGROUP+1 + T = ENER(LLL)/CEMASS/1.0D6 + T1 = T + 1.0D0 + T2 = T + 2.0D0 + BSQ = T * T2 / T1**2 +*---- +* EVALUATE THE ELECTRON'S MOMENTUM / (MASS OF THE ELECTRON * C) +*---- + PMC = SQRT(2.0D0*T + T*T) +*---- +* EVALUTE THE ENERGY PARAMETER IN THE STERNHEIMER FORMALISM +*---- + X = LOG10(PMC) + IF(X.LE.X0) THEN + DS = 0.0D0 + ELSE IF(X.LE.X1) THEN + DS = 4.606D0*X+C+B*((X1-X)**DM) + ELSE + DS = 4.606D0*X+C + ENDIF + IF(DS.LT.0.0) DS=0.0D0 + DENMAT(IBM,LLL)= REAL(CONV*DS/BSQ) + ENDDO + ENDIF + ENDDO + RETURN + END diff --git a/Dragon/src/LIBSEC.f b/Dragon/src/LIBSEC.f new file mode 100644 index 0000000..aaf3a3c --- /dev/null +++ b/Dragon/src/LIBSEC.f @@ -0,0 +1,246 @@ +*DECK LIBSEC + SUBROUTINE LIBSEC(MAXTRA,LLL,IANNN,NGRO,IX,UUU,DELTA,SIGS,SIG1, + 1 PRI,NLET,STR,DEL,NRSTR,IANIS,ITY,NEXT,NEXU,NEXV,NEXW,III) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the values of the transfer macroscopic cross section for +* secondary neutrons in group LLL. Component of the APOLIB-1 reader. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXTRA available storage for apollo compacted transfer +* cross sections. +* LLL group number for secondary neutrons. +* IANNN type of transport correction (=-1: transport corrected P0; +* =0: P0; =1: P1). +* NGRO number of groups. +* IX number of groups with up-scattering. +* UUU groups limits in lethargy units. +* DELTA groups width in lethargy units. +* SIGS diffusion P0 microscopic cross sections. +* SIG1 diffusion P1 microscopic cross sections. +* PRI transfer microscopic cross sections. +* DEL elementary mesh element in lethargy. +* NRSTR number of cross section structures own by the isotope. +* IANIS Legendre order corresponding to each cross section structure. +* ITY type of each cross section structure. +* NEXT length of each cross section structure. +* NEXU information related to each cross section structure. +* NEXV information related to each cross section structure. +* NEXW information related to each cross section structure. +* III offset in vector PRI of each cross section structure. +* +*Parameters: output +* NLET number of down-scattering groups (including group LLL). +* STR values of the transfer macroscopic cross section: +* STR(1) from group LLL; +* STR(2) from group LLL-1; +* STR(LLL) from group 1; +* STR(LLL+1) from group NGRO; +* STR(LLL+2) from group NGRO-1; +* STR(NGRO) from group LLL+1. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXTRA,LLL,IANNN,NGRO,IX,NLET,NRSTR,IANIS(80),ITY(80), + 1 NEXT(80),NEXU(80),NEXV(80),NEXW(80),III(80) + REAL UUU(NGRO),DELTA(NGRO),SIGS(NGRO),SIG1(NGRO),PRI(MAXTRA), + 1 STR(NGRO),DEL +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION DAUX + LOGICAL SELF + EQUIVALENCE(AUX1,K12) +* + NGROIN=NGRO-IX + IAN=IANNN + IF(IANNN.EQ.-1)IAN=0 + DO 71 MM=1,NGRO + STR(MM)=0.0 + 71 CONTINUE + NLET=1 + SELF=.FALSE. + IF (NRSTR.GT.0) THEN + DO 250 K=1,NRSTR + IF (IANIS(K).NE.IAN) GOTO 250 + MML=0 + IF (ITY(K).EQ.1) THEN +* ELASTIC SLOWING-DOWN MATRIX. + IF (LLL.GT.NGROIN) GO TO 250 + SELF=.TRUE. + LDELH=INT(UUU(LLL)/DEL+0.1) + LARGRL=INT(DELTA(LLL)/DEL+0.1) + LDELB=LDELH-LARGRL+1 + NP2=NEXT(K) + IHM=III(K)+NP2-1 + LTES=LDELB-NP2 + ISOTOP=K + INDICE=1 + DO 210 MM1=1,LLL + MM=LLL-MM1+1 + MDELH=INT(UUU(MM)/DEL+0.1) + IF(MDELH.LE.LTES)GOTO 211 + LARGRM=INT(DELTA(MM)/DEL+0.1) + MDELB=MDELH-LARGRM+1 + MDELB=MAX0(MDELB,LTES+1) + DAUX=0.0 + LARG=MIN0(LARGRM,LARGRL) + IF(LARG.GT.4) THEN + IHAUT=LDELH-MDELB+III(K) + IHAUT=MIN0(IHAUT,IHM) + J=0 + INTER2=0 + IF (INDICE.EQ.2) THEN + IBAS=LDELB-MDELH+III(K) + IBAS=MAX0(IBAS,III(K)) + LARGLI=IABS(LARGRM-LARGRL) + INTER1=IBAS+LARG-2 + INTER1=MIN0(INTER1,IHAUT) + DO 182 I=IBAS,INTER1 + J=J+1 + DAUX=DAUX+PRI(I)*FLOAT(J) + 182 CONTINUE + INTER1=INTER1+1 + INTER2=INTER1+LARGLI + INTER2=MIN0(IHAUT,INTER2) + IF(INTER1.GT.INTER2) GO TO 1004 + J=LARG + DO 183 I=INTER1,INTER2 + DAUX=DAUX+PRI(I)*FLOAT(LARG) + 183 CONTINUE + ELSE IF (INDICE.EQ.1) THEN + INDICE=2 + INTER2=III(K)-1 + J=LARG+1 + ENDIF + INTER2=INTER2+1 + DO 184 I=INTER2,IHAUT + J=J-1 + DAUX=DAUX+PRI(I)*FLOAT(J) + 184 CONTINUE + ELSE + DO 83 MDEL=MDELB,MDELH + IBAS=LDELB-MDEL+III(K) + IHAUT=LDELH-MDEL+III(K) + IBAS=MAX0(IBAS,III(K)) + IHAUT=MIN0(IHAUT,IHM) + DO 82 I=IBAS,IHAUT + DAUX=DAUX+PRI(I) + 82 CONTINUE + 83 CONTINUE + ENDIF + 1004 STR(MM1)=STR(MM1)+REAL(DAUX*SIGS(MM)*DEL/DELTA(LLL)) + 210 CONTINUE + MM=MM-1 + 211 MML=LLL-MM + ELSE IF (ITY(K).EQ.4) THEN +* STANDARD GALOCHE. + IF (LLL.GT.NGROIN) GO TO 250 + SELF=.TRUE. + NEX1=NEXU(K) + NEX2=NEXV(K) + NEX3=NEXW(K) + IF(LLL.GT.(NEX2+NEX3)) GO TO 801 + IPR=III(K)-1+(LLL*(LLL-1))/2 + DO 802 I=1,LLL + IPR=IPR+1 + STR(I)=STR(I)+PRI(IPR) + 802 CONTINUE + MML=LLL + GO TO 240 + 801 IF(LLL.GT.NEX1) GO TO 803 + IPR=III(K)-1+LLL*(NEX2+NEX3)-((NEX2+NEX3)*(NEX2+NEX3+1))/2 + DO 804 I=1,NEX2 + IPR=IPR+1 + STR(I)=STR(I)+PRI(IPR) + 804 CONTINUE + LN3=LLL-NEX3+1 + DO 807 I=LN3,LLL + IPR=IPR+1 + STR(I)=STR(I)+PRI(IPR) + 807 CONTINUE + MML=LLL + GO TO 240 + 803 IF(NEX2.EQ.0) GO TO 250 + IPR=III(K)-1+NEX1*NEX3-((NEX2+NEX3)*(NEX2+NEX3-1))/2+ + 1 (LLL-1)*NEX2 + DO 813 I=1,NEX2 + IPR=IPR+1 + STR(I)=STR(I)+PRI(IPR) + 813 CONTINUE + MML=NEX2 + ELSE IF (ITY(K).EQ.7) THEN +* THERMAL TRANSFER MATRIX. + IF (LLL.LE.NGROIN) GO TO 250 + SELF=.TRUE. + IPR=III(K)-1+(NGRO-LLL)*IX + DO 5003 MM=1,LLL-NGROIN + STR(MM)=STR(MM)+PRI(IPR+MM+NGRO-LLL) + 5003 CONTINUE + DO 5004 MM=1,NGRO-LLL + STR(MM+LLL)=STR(MM+LLL)+PRI(IPR+MM) + 5004 CONTINUE + MML=LLL-NGROIN + ELSE IF (ITY(K).EQ.8) THEN +* RECTANGLE SLOWING-DOWN MATRIX. + IF(LLL.LT.NEXU(K))GO TO 250 + IF(LLL.GT.NEXV(K))GO TO 250 + IPR=III(K)-1+(LLL-NEXU(K))*NEXW(K) + LN1=LLL-NEXU(K)+2 + DO 355 I=LN1,LN1+NEXW(K)-1 + IPR=IPR+1 + STR(I)=STR(I)+PRI(IPR) + 355 CONTINUE + MML=NEXW(K)+LLL-NEXU(K)+1 + ELSE IF (ITY(K).EQ.9) THEN +* GREULING-GOERTZEL SLOWING DOWN MATRIX. + NEX1=NEXU(K) + NEX3=NEXW(K) + IF ((LLL.LT.NEX1).OR.(LLL.GT.NEX3)) GO TO 250 + SELF=.TRUE. + NEX2=NEXV(K) + NEX4=NEXT(K)/3 + MML=LLL-NEX1+1 + IPR=NEX3-LLL+III(K)-1 + J=IPR+1+NEX4 + DAUX=PRI(J) + J=IPR+1+2*NEX4 + IF(LLL.GT.NEX2) THEN + LN1=LLL-NEX2+1 + ELSE + LN1=1 + STR(1)=STR(1)+PRI(J) + ENDIF + J=IPR+LN1-1 + DO 360 MM=LN1,MML + J=J+1 + STR(MM)=STR(MM)+REAL(PRI(J)*DAUX) + 360 CONTINUE + ENDIF + 240 NLET=MAX0(NLET,MML) + 250 CONTINUE + ENDIF + IF ((.NOT.SELF).AND.(IAN.EQ.0)) THEN + STR(1)=STR(1)+SIGS(LLL) + ELSE IF ((.NOT.SELF).AND.(IAN.EQ.1)) THEN + STR(1)=STR(1)+3.0*SIG1(LLL) + ENDIF + IF (IANNN.EQ.-1) THEN + STR(1)=STR(1)-SIG1(LLL) + ENDIF + RETURN + END diff --git a/Dragon/src/LIBSUB.f b/Dragon/src/LIBSUB.f new file mode 100644 index 0000000..63095de --- /dev/null +++ b/Dragon/src/LIBSUB.f @@ -0,0 +1,517 @@ +*DECK LIBSUB + SUBROUTINE LIBSUB (MAXISO,MAXTRA,IPLIB,IPROC,NGRO,NBISO,NLIB, + 1 ISONAM,TN,MASKI,IPRECI,SVDEPS,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Production of an internal library with subgroups. +* +*Copyright: +* Copyright (C) 2003 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXISO maximum number of isotopes permitted. +* MAXTRA maximum number of energy bins of size DELI. +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* IPROC type of microlib processing: +* =2: perform temperature interpolation and build a +* temperature-independent draglib; +* =3: perform temperature interpolation and compute calendf- +* type mathematical probability tables based on bin-type +* cross-sections for total cross sections; +* =4: perform temperature interpolation and compute physical +* probability tables or slowing-down correlated probability +* tables. +* =5: perform temperature interpolation and compute calendf- +* type mathematical probability tables based on bin-type +* cross-sections for all available cross-sections types. +* =6: compute orthogonal bases for the resonance spectrum +* expansion (RSE) method. +* NGRO number of energy groups. +* NBISO number of isotopes present in the calculation domain. +* NLIB number of independent libraries. +* ISONAM alias name of isotopes. +* TN temperature of each isotope. +* MASKI isotope masks (isotope with index I is process if +* MASKI(I)=.true.). +* IPRECI accuracy index for probability tables in CALENDF. +* SVDEPS rank accuracy of the singular value decomposition. +* IMPX print flag. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + INTEGER MAXISO,MAXTRA,IPROC,NGRO,NBISO,NLIB,ISONAM(3,NBISO), + 1 IPRECI,IMPX + LOGICAL MASKI(NBISO) + REAL TN(NBISO),SVDEPS +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MAXDIL=65,MAXED=50,NSTATE=40,MAXESP=4,IALTER=0) + TYPE(C_PTR) JPLIB,KPLIB,IPTMP,JPTMP,KPTMP,IPDRL + CHARACTER NAMLBT*8,NAMFIL*64,HNISOR*12,HSMG*131,TEXT12*12, + 1 HSHI*12,HVECT(MAXED)*8,HNAMIS*12,HNAMIS2*12,TEXT4*4,CFILNA2*64 + LOGICAL LLENG,LLSHI,LTRANC,LINDEX,MASK2(MAXDIL) + INTEGER ISOR(3),IPAR(NSTATE),IPAR2(NSTATE),IESP(MAXESP+1) + REAL DILUT(MAXDIL),EESP(MAXESP+1) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: LSHI,NFS,ILLIB,NTFG,NIR, + 1 INAME,IJCEDM,KISONA,KISONR,KSHI,KTYPE,KNAME,KCOH,KINC,KRSK,KNTFG, + 2 KNIR,KSHIN + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISONRF,ISHINA + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: IHLIB + LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASKJ + REAL, ALLOCATABLE, DIMENSION(:) :: GIR,KGIR,KSN,KTN,ENER,EBIN + REAL, ALLOCATABLE, DIMENSION(:,:) :: SN +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(LSHI(NBISO),NFS(NGRO),ISONRF(3,MAXISO),ISHINA(3,MAXISO), + 2 IHLIB(2,MAXISO,4),ILLIB(MAXISO),NTFG(MAXISO),NIR(MAXISO)) + ALLOCATE(MASKJ(NBISO)) + ALLOCATE(SN(NGRO,NBISO),GIR(MAXISO)) +* + TKSUB=0.0 + TKTAB=0.0 +*---- +* CHECK FOR DUPLICATE ISOTOPE NAMES. MASKI(I) NUST BE SET IN SUCH A WAY +* THAT TWO IDENTICAL ISOTOPES ARE NEVER PROCESSED. +*---- + CALL LCMGET(IPLIB,'ILIBRARYINDX',ILLIB) + DO 20 I=1,NBISO + IF(MASKI(I).AND.(ILLIB(I).NE.0)) THEN + DO 10 J=I+1,NBISO + IF(MASKI(J).AND.(ISONAM(1,I).EQ.ISONAM(1,J)).AND.(ISONAM(2,I) + 1 .EQ.ISONAM(2,J)).AND.(ISONAM(3,I).EQ.ISONAM(3,J))) THEN + WRITE (HSMG,300) (ISONAM(I0,I),I0=1,3) + CALL XABORT(HSMG) + ENDIF + 10 CONTINUE + ENDIF + 20 CONTINUE +*---- +* PROCESS THE NON-RESONANT ISOTOPES. +*---- + CALL LCMGET(IPLIB,'ISOTOPESSHI',LSHI) + DO 35 ISOT=1,NBISO + MASKJ(ISOT)=MASKI(ISOT).AND.(LSHI(ISOT).EQ.0) + DO 30 I=1,NGRO + SN(I,ISOT)=1.0E10 + 30 CONTINUE + 35 CONTINUE + CALL KDRCPU(TK1) +* -------------------------------------- + CALL LIBLIB(IPLIB,NBISO,MASKJ(1),IMPX) +* -------------------------------------- + CALL KDRCPU(TK2) + TKSUB=TKSUB+(TK2-TK1) + CALL LCMLEN(IPLIB,'ENERGY',ILENG,ITYLCM) + LLENG=(ILENG.EQ.NGRO+1) + CALL LCMLEN(IPLIB,'INDEX',ILENG,ITYLCM) + LINDEX=(ILENG.NE.0) +*---- +* RECOVER SOME LIBRARY PARAMETERS. +*---- + CALL LCMGET(IPLIB,'STATE-VECTOR',IPAR) + NL=IPAR(4) + NED=IPAR(13) + NDEL=IPAR(19) + IF(NED.GT.0) THEN + IF(NED.GT.MAXED) CALL XABORT('LIBSUB: MAXED OVERFLOW.') + CALL LCMGTC(IPLIB,'ADDXSNAME-P0',8,NED,HVECT) + ENDIF +*---- +* RECOVER INFORMATION FROM THE /MICROLIB/ DIRECTORY. +*---- + CALL LCMGET(IPLIB,'ISOTOPERNAME',ISONRF) + CALL LCMGET(IPLIB,'ILIBRARYTYPE',IHLIB(1,1,1)) + CALL LCMLEN(IPLIB,'ISOTOPESNTFG',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGET(IPLIB,'ISOTOPESNTFG',NTFG) + CALL LCMGET(IPLIB,'ISOTOPESCOH',IHLIB(1,1,2)) + CALL LCMGET(IPLIB,'ISOTOPESINC',IHLIB(1,1,3)) + ELSE + NTFG(:NBISO)=0 + ENDIF + CALL LCMLEN(IPLIB,'ISOTOPESRESK',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGET(IPLIB,'ISOTOPESRESK',IHLIB(1,1,4)) + ELSE + NAMLBT=',' + DO ISOT=1,NBISO + READ(NAMLBT,'(2A4)') IHLIB(1,ISOT,4),IHLIB(2,ISOT,4) + ENDDO + ENDIF + CALL LCMLEN(IPLIB,'ISOTOPESHIN',ILENG,ITYLCM) + LLSHI=(ILENG.GT.0) + IF(LLSHI) CALL LCMGET(IPLIB,'ISOTOPESHIN',ISHINA) + CALL LCMLEN(IPLIB,'ISOTOPESNIR',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGET(IPLIB,'ISOTOPESNIR',NIR) + CALL LCMGET(IPLIB,'ISOTOPESGIR',GIR) + ELSE + NIR(:NBISO)=0 + GIR(:NBISO)=0.0 + ENDIF +*---- +* PROCESS THE RESONANT ISOTOPES. +*---- + JPLIB=LCMLID(IPLIB,'ISOTOPESLIST',NBISO) + IMPY=MAX(0,IMPX-5) + LTRANC=.FALSE. + DO 200 ISOT=1,NBISO + IF(MASKI(ISOT).AND.(LSHI(ISOT).NE.0)) THEN + WRITE(HNAMIS,'(3A4)') (ISONAM(I0,ISOT),I0=1,3) + IF(IMPX.GT.0) WRITE (6,'(/33H LIBSUB: PROCESSING ISOTOPE/MATER, + 1 5HIAL '',A12,2H''.)') HNAMIS +* +* RECOVER MULTI-DILUTION INFORMATION. +* +* FIND THE DILUTION VALUES. + NDIL=0 + CALL LCMOP(IPTMP,'*TEMPORARY*',0,1,0) + WRITE(HNISOR,'(3A4)') (ISONRF(I0,ISOT),I0=1,3) + WRITE(NAMLBT,'(2A4)') IHLIB(1,ISOT,1),IHLIB(2,ISOT,1) + ALLOCATE(INAME(16*NLIB)) + CALL LCMGET(IPLIB,'ILIBRARYNAME',INAME) + ILIB=ILLIB(ISOT) + WRITE(NAMFIL,'(16A4)') (INAME(16*(ILIB-1)+I),I=1,16) + DEALLOCATE(INAME) + IF(NAMLBT.EQ.'DRAGON') THEN + CALL LCMOP(IPDRL,NAMFIL(:12),2,2,0) + CALL LIBDI1(MAXDIL,IPDRL,HNISOR,NDIL,DILUT) + CALL LCMCL(IPDRL,1) + ELSE IF(NAMLBT.EQ.'MATXS') THEN + CALL LIBDI2(MAXDIL,NAMFIL,HNISOR,NDIL,DILUT) + ELSE IF(NAMLBT.EQ.'MATXS2') THEN + CALL LIBDI3(MAXDIL,NAMFIL,HNISOR,NDIL,DILUT) + ELSE IF(NAMLBT.EQ.'APLIB1') THEN + WRITE(HSHI,'(3A4)') (ISHINA(I0,ISOT),I0=1,3) + CALL LIBDI4(MAXDIL,NAMFIL,HSHI,NDIL,DILUT) + ELSE IF(NAMLBT.EQ.'APLIB2') THEN + WRITE(HSHI,'(3A4)') (ISHINA(I0,ISOT),I0=1,3) + IF(HSHI.EQ.' ') THEN + WRITE (HSMG,'(35HLIBSUB: SELF-SHIELDING ISOTOPE NOT , + 1 25HDEFINED FOR MAIN ISOTOPE ,A12,1H.)') HNISOR + CALL XABORT(HSMG) + ENDIF + CALL LIBDI5(MAXDIL,NAMFIL,HSHI,NDIL,DILUT) + ELSE IF(NAMLBT.EQ.'APXSM') THEN + WRITE(HSHI,'(3A4)') (ISHINA(I0,ISOT),I0=1,3) + IF(HSHI.EQ.' ') THEN + WRITE (HSMG,'(35HLIBSUB: SELF-SHIELDING ISOTOPE NOT , + 1 25HDEFINED FOR MAIN ISOTOPE ,A12,1H.)') HNISOR + CALL XABORT(HSMG) + ENDIF + CALL LIBXS6(MAXDIL,NAMFIL,HSHI,NDIL,DILUT) + ELSE IF(NAMLBT.EQ.'APLIB3') THEN + IND = INDEX(NAMFIL, ":") + IF(IND.EQ.0) THEN + CALL XABORT('LIBSUB: NO SELF SHIELDING DATA AVAILABLE,') + ELSE + CFILNA2=NAMFIL(IND+1:) + ENDIF + CALL LIBD10(MAXDIL,CFILNA2,HNISOR,NDIL,DILUT) + ELSE IF(NAMLBT.EQ.'WIMSAECL') THEN + WRITE(HSHI,'(3A4)') (ISHINA(I0,ISOT),I0=1,3) + CALL LIBDI6(MAXDIL,NGRO,NAMFIL,HNISOR,HSHI,NDIL,DILUT) + ELSE IF(NAMLBT.EQ.'NDAS') THEN + CALL LIBND7(MAXDIL,NGRO,NAMFIL,HNISOR,NDIL,DILUT) + ELSE IF(NAMLBT.EQ.'WIMSD4') THEN + WRITE(HSHI,'(3A4)') (ISHINA(I0,ISOT),I0=1,3) + CALL LIBDI8(MAXDIL,NGRO,NAMFIL,HNISOR,HSHI,NDIL,DILUT) + ELSE IF(NAMLBT.EQ.'WIMSE') THEN + WRITE(HSHI,'(3A4)') (ISHINA(I0,ISOT),I0=1,3) + CALL LIBDI9(MAXDIL,NGRO,NAMFIL,HNISOR,HSHI,NDIL,DILUT) + ELSE + CALL XABORT('LIBSUB: '//NAMLBT//' LIBRARY TREATMENT IS ' + 1 //'NOT IMPLEMENTED.') + ENDIF + IF(NDIL.EQ.0) GO TO 70 + 50 IF(DILUT(1).LT.1.0) THEN + DO 60 I=2,NDIL+1 + DILUT(I-1)=DILUT(I) + 60 CONTINUE + NDIL=NDIL-1 + GO TO 50 + ENDIF + IF(IMPX.GT.4) THEN + WRITE(6,'(/32H LIBSUB: DILUTIONS FOR ISOTOPE '',A12, + 1 2H'':/(1X,1P,10E12.4))') HNAMIS,(DILUT(I),I=1,NDIL+1) + ENDIF + 70 IF(NDIL.EQ.0) THEN + WRITE(HSMG,'(41HLIBSUB: NOT ENOUGH DILUTIONS FOR ISOTOPE , + 1 A,1H.)') HNAMIS + CALL XABORT(HSMG) + ENDIF +* +* PROCESS THE ISOTOPE FOR EACH DILUTION. + TEXT12='L_LIBRARY' + READ(TEXT12,'(3A4)') (ISOR(I),I=1,3) + CALL LCMPUT(IPTMP,'SIGNATURE',3,3,ISOR) + DO 80 I=1,NSTATE + IPAR2(I)=IPAR(I) + 80 CONTINUE + IPAR2(2)=NDIL+1 + CALL LCMPUT(IPTMP,'STATE-VECTOR',NSTATE,1,IPAR2) + IF(NED.GT.0) THEN + ALLOCATE(IJCEDM(2*NED)) + CALL LCMGET(IPLIB,'ADDXSNAME-P0',IJCEDM) + CALL LCMPUT(IPTMP,'ADDXSNAME-P0',2*NED,3,IJCEDM) + DEALLOCATE(IJCEDM) + ENDIF + IF(LINDEX) THEN + CALL LCMSIX(IPLIB,'INDEX',1) + CALL LCMSIX(IPTMP,'INDEX',1) + CALL LCMEQU(IPLIB,IPTMP) + CALL LCMSIX(IPTMP,' ',2) + CALL LCMSIX(IPLIB,' ',2) + ENDIF +* +* BUILD A MICROLIB WITH NDIL+1 ISOTOPES. + ALLOCATE(KISONA(3*(NDIL+1)),KISONR(3*(NDIL+1)),KSHI(NDIL+1), + 1 KTYPE(2*(NDIL+1)),KNAME(NDIL+1)) + IF(NTFG(ISOT).GT.0) THEN + ALLOCATE(KCOH(2*(NDIL+1)),KINC(2*(NDIL+1)),KRSK(2*(NDIL+1)), + 1 KNTFG(NDIL+1)) + ENDIF + IF(NIR(ISOT).NE.0) THEN + ALLOCATE(KGIR(NDIL+1),KNIR(NDIL+1)) + ENDIF + IF(LLSHI) ALLOCATE(KSHIN(3*(NDIL+1))) + ALLOCATE(KSN(NGRO*(NDIL+1)),KTN(NDIL+1)) + DO 100 IDIL=1,NDIL+1 + KSHI(IDIL)=LSHI(ISOT) + MASK2(IDIL)=.TRUE. + KISONA(3*(IDIL-1)+1)=ISONAM(1,ISOT) + KISONA(3*(IDIL-1)+2)=ISONAM(2,ISOT) + KISONR(3*(IDIL-1)+1)=ISONRF(1,ISOT) + KISONR(3*(IDIL-1)+2)=ISONRF(2,ISOT) + KISONR(3*(IDIL-1)+3)=ISONRF(3,ISOT) + WRITE(TEXT4,'(I4.4)') IDIL + READ(TEXT4,'(A4)') KISONA(3*(IDIL-1)+3) + IF(NIR(ISOT).NE.0) THEN + KGIR(IDIL)=GIR(ISOT) + KNIR(IDIL)=NIR(ISOT) + ENDIF + KTYPE(2*(IDIL-1)+1)=IHLIB(1,ISOT,1) + KTYPE(2*(IDIL-1)+2)=IHLIB(2,ISOT,1) + KNAME(IDIL)=ILLIB(ISOT) + IF(NTFG(ISOT).GT.0) THEN + KCOH(2*(IDIL-1)+1)=IHLIB(1,ISOT,2) + KCOH(2*(IDIL-1)+2)=IHLIB(2,ISOT,2) + KINC(2*(IDIL-1)+1)=IHLIB(1,ISOT,3) + KINC(2*(IDIL-1)+2)=IHLIB(2,ISOT,3) + KRSK(2*(IDIL-1)+1)=IHLIB(1,ISOT,4) + KRSK(2*(IDIL-1)+2)=IHLIB(2,ISOT,4) + KNTFG(IDIL)=NTFG(ISOT) + ENDIF + IF(LLSHI) THEN + KSHIN(3*(IDIL-1)+1)=ISHINA(1,ISOT) + KSHIN(3*(IDIL-1)+2)=ISHINA(2,ISOT) + KSHIN(3*(IDIL-1)+3)=ISHINA(3,ISOT) + ENDIF + DO 90 I=1,NGRO + KSN((IDIL-1)*NGRO+I)=DILUT(IDIL) + 90 CONTINUE + KTN(IDIL)=TN(ISOT) + 100 CONTINUE + ALLOCATE(INAME(16*NLIB)) + CALL LCMGET(IPLIB,'ILIBRARYNAME',INAME) + CALL LCMPUT(IPTMP,'ILIBRARYNAME',16*NLIB,3,INAME) + DEALLOCATE(INAME) + CALL LCMPUT(IPTMP,'ISOTOPESUSED',3*(NDIL+1),3,KISONA) + CALL LCMPUT(IPTMP,'ISOTOPERNAME',3*(NDIL+1),3,KISONR) + DEALLOCATE(KISONR,KISONA) + IF(NIR(ISOT).NE.0) THEN + CALL LCMPUT(IPTMP,'ISOTOPESGIR',NDIL+1,2,KGIR) + CALL LCMPUT(IPTMP,'ISOTOPESNIR',NDIL+1,1,KNIR) + DEALLOCATE(KNIR,KGIR) + ENDIF + CALL LCMPUT(IPTMP,'ISOTOPESSHI',NDIL+1,1,KSHI) + CALL LCMPUT(IPTMP,'ILIBRARYTYPE',2*(NDIL+1),3,KTYPE) + CALL LCMPUT(IPTMP,'ILIBRARYINDX',NDIL+1,1,KNAME) + DEALLOCATE(KNAME,KTYPE,KSHI) + IF(NTFG(ISOT).GT.0) THEN + CALL LCMPUT(IPTMP,'ISOTOPESCOH',2*(NDIL+1),3,KCOH) + CALL LCMPUT(IPTMP,'ISOTOPESINC',2*(NDIL+1),3,KINC) + CALL LCMPUT(IPTMP,'ISOTOPESRESK',2*(NDIL+1),3,KRSK) + CALL LCMPUT(IPTMP,'ISOTOPESNTFG',NDIL+1,1,KNTFG) + DEALLOCATE(KNTFG,KRSK,KINC,KCOH) + ENDIF + IF(LLSHI) THEN + CALL LCMPUT(IPTMP,'ISOTOPESHIN',3*(NDIL+1),3,KSHIN) + DEALLOCATE(KSHIN) + ENDIF + CALL LCMPUT(IPTMP,'ISOTOPESDSN',NGRO*(NDIL+1),2,KSN) + CALL LCMPUT(IPTMP,'ISOTOPESDSB',NGRO*(NDIL+1),2,KSN) + CALL LCMPUT(IPTMP,'ISOTOPESTEMP',NDIL+1,2,KTN) + IF(NED.GT.0) CALL LCMPTC(IPTMP,'ADDXSNAME-P0',8,NED,HVECT) + DEALLOCATE(KTN,KSN) +* + CALL KDRCPU(TK1) +* --------------------------------------- + CALL LIBLIB(IPTMP,NDIL+1,MASK2(1),IMPY) +* --------------------------------------- + CALL KDRCPU(TK2) + TKSUB=TKSUB+(TK2-TK1) +* +* RECOVER THE SELF-SHIELDING GROUP LIMITS. + CALL LCMGET(IPTMP,'STATE-VECTOR',IPAR2) + LTRANC=LTRANC.OR.(IPAR2(5).NE.0) + IPAR(9)=MIN(IPAR(9),IPAR2(9)) + IPAR(10)=MAX(IPAR(10),IPAR2(10)) + IPAR(16)=MAX(IPAR(16),IPAR2(16)) + IPAR(19)=MAX(IPAR(19),IPAR2(19)) +* +* RECOVER GROUP STRUCTURE + IF(.NOT.LLENG) THEN + ALLOCATE(ENER(NGRO+1)) + CALL LCMGET(IPTMP,'ENERGY',ENER) + CALL LCMPUT(IPLIB,'ENERGY',NGRO+1,2,ENER) + CALL LCMGET(IPTMP,'DELTAU',ENER) + CALL LCMPUT(IPLIB,'DELTAU',NGRO,2,ENER) + DEALLOCATE(ENER) + LLENG=.TRUE. + ENDIF +* +* RECOVER ENERGY-DEPENDENT FISSION SPECTRA + CALL LCMLEN(IPTMP,'CHI-LIMITS',NBESP,ITYLCM) + IF(NBESP.GT.0) THEN + NBESP=NBESP-1 + IF(NBESP.GT.MAXESP) CALL XABORT('LIBSUB: MAXESP OVERFLOW.') + CALL LCMGET(IPTMP,'CHI-LIMITS',IESP) + CALL LCMPUT(IPLIB,'CHI-LIMITS',NBESP+1,1,IESP) + CALL LCMGET(IPTMP,'CHI-ENERGY',EESP) + CALL LCMPUT(IPLIB,'CHI-ENERGY',NBESP+1,2,EESP) + ENDIF +* +* RECOVER BIN TYPE INFORMATION (IF AVAILABLE). + JPTMP=LCMGID(IPTMP,'ISOTOPESLIST') + KPLIB=LCMDIL(JPLIB,ISOT) ! set ISOT-th isotope + CALL LCMLEL(JPTMP,NDIL+1,ILENG,ITYLCM) + IF(ILENG.EQ.0) THEN + TEXT12=HNAMIS(1:8) + WRITE(TEXT12(9:12),'(I4.4)') NDIL+1 + CALL XABORT('LIBSUB: MISSING LIST ITEM FOR '//TEXT12) + ENDIF + KPTMP=LCMGIL(JPTMP,NDIL+1) ! set (NDIL+1)-th isotope + CALL LCMGET(KPTMP,'AWR',AWR) + CALL LCMLEN(KPTMP,'BIN-NFS',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGET(KPTMP,'BIN-NFS',NFS) + CALL LCMPUT(KPLIB,'BIN-NFS',NGRO,1,NFS) + LBIN=0 + DO 130 I=1,NGRO + LBIN=LBIN+NFS(I) + 130 CONTINUE + IF(IMPX.GT.1) THEN + WRITE(6,'(/41H LIBSUB: NUMBER OF UFG BINS FOR ISOTOPE '', + 1 A12,2H''=,I10)') HNAMIS,LBIN + ENDIF + ALLOCATE(EBIN(LBIN+1)) + CALL LCMLEN(KPTMP,'BIN-ENERGY',ILONG,ITYLCM) + IF(ILONG.GT.LBIN+1) CALL XABORT('LIBSUB: NFS OVERFLOW.') + CALL LCMGET(KPTMP,'BIN-ENERGY',EBIN) + CALL LCMPUT(KPLIB,'BIN-ENERGY',LBIN+1,2,EBIN) + CALL LCMGET(KPTMP,'BIN-NTOT0',EBIN) + CALL LCMPUT(KPLIB,'BIN-NTOT0',LBIN,2,EBIN) + CALL LCMGET(KPTMP,'BIN-SIGS00',EBIN) + CALL LCMPUT(KPLIB,'BIN-SIGS00',LBIN,2,EBIN) + CALL LCMLEN(KPTMP,'BIN-NUSIGF',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPTMP,'BIN-NUSIGF',EBIN) + CALL LCMPUT(KPLIB,'BIN-NUSIGF',LBIN,2,EBIN) + ENDIF + DEALLOCATE(EBIN) + ENDIF +* + CALL KDRCPU(TK1) + IF(IPROC.EQ.6) THEN +* USE THE RESONANCE SPECTRUM EXPANSION METHOD. + CALL LCMLEN(KPTMP,'BIN-NFS',ILENG,ITYLCM) + IF(ILENG.EQ.0) THEN + CALL LCMLIB(KPTMP) + WRITE(HSMG,'(38HLIBSUB: BIN DATA MISSING FOR ISOTOPE '', + 1 A12,2H''.)') HNAMIS + CALL XABORT(HSMG) + ENDIF + NDEL=IPAR(19) + CALL LIBRSE(KPLIB,IPTMP,MAXTRA,HNAMIS,LBIN,NGRO,NL,NED,NDEL, + 1 HVECT,NFS,IMPX,DELI,AWR,IALTER,SVDEPS) + ELSE +* RESET CALENDF MAXIMUM ACCURACY FOR INTERMEDIATE ISOTOPES. + IPRECJ=IPRECI + IF((AWR.LT.220.0).AND.(IPRECI.GT.3)) IPRECJ=3 +* +* USE THE SUBGROUP METHOD. + CALL LIBPTW(KPLIB,IPTMP,IPROC,NGRO,NL,HNAMIS,NED,HVECT,NDIL, + 1 DILUT,AWR,IPRECJ,IMPX,MAXTRA) + ENDIF +* +* RESET ALIAS + CALL LCMPTC(KPLIB,'ALIAS',12,HNAMIS) + CALL KDRCPU(TK2) + TKTAB=TKTAB+(TK2-TK1) + ENDIF + 200 CONTINUE +*---- +* COMPUTE CORRELATION INFORMATION BETWEEN PAIRS OF RESONANT ISOTOPES. +*---- + CALL KDRCPU(TK1) + IF((IPROC.EQ.3).OR.(IPROC.EQ.4).OR.(IPROC.EQ.5)) THEN + DO 220 ISOT=1,NBISO + WRITE(HNAMIS,'(3A4)') (ISONAM(I0,ISOT),I0=1,3) + IF(MASKI(ISOT).AND.(LSHI(ISOT).LT.0)) THEN + DO 210 JSOT=1,ISOT-1 + IF(MASKI(JSOT).AND.(LSHI(ISOT).EQ.LSHI(JSOT))) THEN + WRITE(HNAMIS2,'(3A4)') (ISONAM(I0,JSOT),I0=1,3) + IF(IMPX.GT.0) WRITE (6,'(/26H LIBSUB: COMPUTING CORRELA, + 1 41HTION EFFECTS BETWEEN ISOTOPES/MATERIALS '',A12, + 2 7H'' AND '',A12,2H''.)') HNAMIS,HNAMIS2 + CALL LIBCOR(IPLIB,NGRO,ISOT,JSOT,HNAMIS,HNAMIS2) + ENDIF + 210 CONTINUE + ENDIF + 220 CONTINUE + ELSE IF(IPROC.EQ.6) THEN + CALL LIBRSC(MAXTRA,IPLIB,LBIN,NGRO,NBISO,ISONAM,MASKI,LSHI, + 1 NFS,IMPX,IALTER) + ENDIF + CALL KDRCPU(TK2) + TKTAB=TKTAB+(TK2-TK1) +*---- +* RESET IPAR(5) FOR TRANSPORT CORRECTION AND SAVE STATE-VECTOR. +*---- + IF((IPROC.LE.2).AND.LTRANC) IPAR(5)=2 + CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,IPAR) +* + IF(IMPX.GT.0) WRITE(6,'(/30H LIBSUB: CPU TIME IN LIBLIB=,F10.2, + 1 9H SECONDS./9X,21HCPU TIME IN SUBGROUP=,F10.2,9H SECONDS.)') + 2 TKSUB,TKTAB +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GIR,SN) + DEALLOCATE(MASKJ) + DEALLOCATE(NIR,NTFG,ILLIB,IHLIB,ISHINA,ISONRF,NFS,LSHI) + RETURN +* + 300 FORMAT(8HLIBSUB: ,3A4,34H IS A DUPLICATE ISOTOPE/MATERIAL N, + 1 4HAME.) + END diff --git a/Dragon/src/LIBTAB.f b/Dragon/src/LIBTAB.f new file mode 100644 index 0000000..c218979 --- /dev/null +++ b/Dragon/src/LIBTAB.f @@ -0,0 +1,187 @@ +*DECK LIBTAB + SUBROUTINE LIBTAB (IGRP,NGRO,NL,NDIL,NPART,NED,NDEL,HNAMIS,IMPX, + 1 LSCAT,LSIGF,LADD,DILUT,TOTAL,SIGF,SIGS,SCAT,SADD,ZDEL,GOLD,ISMIN, + 2 ISMAX,NOR,SIGP) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transform dilution dependent information into probability tables. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IGRP energy group index where the transformation occurs. +* NGRO number of energy groups. +* NL number of Legendre orders required in the calculation +* (NL=1 or higher). +* NDIL number of finite dilutions. +* NPART 2 + number of partial cross sections. +* NED number of extra vector edits. +* NDEL number of delayed neutron precursor groups. +* HNAMIS local name of the isotope: +* HNAMIS(1:8) the local isotope name; +* HNAMIS(9:12) suffix function of the mix number. +* IMPX print flag. +* LSCAT Legendre flag (=.true. if a given Legendre order of the +* scattering cross section exists). +* LSIGF fission flag (=.true. if the isotope can fission). +* LADD additional xs flag (=.true. if a given additional cross +* section exists). +* DILUT dilutions. +* TOTAL total cross sections. +* SIGF nu*fission cross sections. +* SIGS scattering cross sections. +* SCAT scattering transfer matrices (sec,prim,Legendre,dilution). +* SADD additional cross sections. +* ZDEL delayed nu-sigf cross sections. +* GOLD Goldstein-Cohen parameter. +* ISMIN minimum secondary group corresponding to each primary group. +* ISMAX maximum secondary group corresponding to each primary group. +* +*Parameters: output +* NOR order of the probability table. +* SIGP partial cross sections. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + PARAMETER (MAXNOR=12) + INTEGER IGRP,NGRO,NL,NDIL,NPART,NED,NDEL,IMPX,ISMIN(NL,NGRO), + 1 ISMAX(NL,NGRO),NOR + REAL DILUT(NDIL+1),TOTAL(NGRO,NDIL+1),SIGF(NGRO,NDIL+1), + 1 SIGS(NGRO,NL,NDIL+1),SCAT(NGRO,NGRO,NL,NDIL+1), + 2 SADD(NGRO,NED,NDIL+1),ZDEL(NGRO,NDEL,NDIL+1),GOLD, + 3 SIGP(MAXNOR,NPART) + LOGICAL LSIGF,LSCAT(NL),LADD(NED) + CHARACTER HNAMIS*12 +*---- +* LOCAL VARIABLES +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: DILUT2,XSDIL + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LDIL +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(LDIL(NDIL+1),DILUT2(NDIL+1)) +*---- +* REMOVE BADLY BEHAVED COLLOCATIONS POINTS. +*---- + MDIL=NDIL + DO 10 IDIL=1,NDIL+1 + LDIL(IDIL)=.TRUE. + 10 CONTINUE + TEST=TOTAL(IGRP,NDIL+1) + DO 20 IDIL=NDIL,1,-1 + IF(ABS(TOTAL(IGRP,IDIL)-TEST).LE.2.0E-4*ABS(TEST)) THEN + MDIL=MDIL-1 + LDIL(IDIL)=.FALSE. + ELSE IF(DILUT(IDIL).LT.1.0) THEN + MDIL=MDIL-1 + LDIL(IDIL)=.FALSE. + ELSE IF((DILUT(IDIL).GT.1.0E5).AND.(DILUT(IDIL).LT.1.0E10)) THEN + MDIL=MDIL-1 + LDIL(IDIL)=.FALSE. + ELSE IF(TOTAL(IGRP,IDIL).LE.0.0) THEN + MDIL=MDIL-1 + LDIL(IDIL)=.FALSE. + ELSE IF(TOTAL(IGRP,IDIL)-(1.0-GOLD)*SIGS(IGRP,1,IDIL).LE.0.0) THEN + MDIL=MDIL-1 + LDIL(IDIL)=.FALSE. + ELSE + TEST=TOTAL(IGRP,IDIL) + ENDIF + 20 CONTINUE +* + ALLOCATE(XSDIL((MDIL+1)*(NPART-1))) + IOFSET=-1 + IDD=0 + DO 30 IDIL=1,NDIL+1 + IF(LDIL(IDIL)) THEN + IDD=IDD+1 + DILUT2(IDD)=DILUT(IDIL) + IOFSET=IOFSET+1 + XSDIL(IOFSET+1)=TOTAL(IGRP,IDIL) + ENDIF + 30 CONTINUE + IF(IDD.NE.MDIL+1) CALL XABORT('LIBTAB: INTERNAL ERROR.') + DO 40 IDIL=1,NDIL+1 + IF(LDIL(IDIL)) THEN + IOFSET=IOFSET+1 + IF(LSIGF) THEN + XSDIL(IOFSET+1)=SIGF(IGRP,IDIL) + ELSE + XSDIL(IOFSET+1)=0.0 + ENDIF + ENDIF + 40 CONTINUE + DO 55 IL=1,NL + DO 50 IDIL=1,NDIL+1 + IF(LDIL(IDIL)) THEN + IOFSET=IOFSET+1 + IF(LSCAT(IL)) THEN + XSDIL(IOFSET+1)=SIGS(IGRP,IL,IDIL) + ELSE + XSDIL(IOFSET+1)=0.0 + ENDIF + ENDIF + 50 CONTINUE + 55 CONTINUE + IF(NPART.EQ.3+NL) GO TO 100 + DO 70 IL=1,NL + IF(LSCAT(IL)) THEN + DO 65 IG2=ISMIN(IL,IGRP),ISMAX(IL,IGRP) + DO 60 IDIL=1,NDIL+1 + IF(LDIL(IDIL)) THEN + IOFSET=IOFSET+1 + XSDIL(IOFSET+1)=SCAT(IG2,IGRP,IL,IDIL) + ENDIF + 60 CONTINUE + 65 CONTINUE + ENDIF + 70 CONTINUE + DO 85 IED=1,NED + DO 80 IDIL=1,NDIL+1 + IF(LDIL(IDIL)) THEN + IOFSET=IOFSET+1 + IF(LADD(IED)) THEN + XSDIL(IOFSET+1)=SADD(IGRP,IED,IDIL) + ELSE + XSDIL(IOFSET+1)=0.0 + ENDIF + ENDIF + 80 CONTINUE + 85 CONTINUE + DO 95 IDEL=1,NDEL + DO 90 IDIL=1,NDIL+1 + IF(LDIL(IDIL)) THEN + IOFSET=IOFSET+1 + XSDIL(IOFSET+1)=ZDEL(IGRP,IDEL,IDIL) + ENDIF + 90 CONTINUE + 95 CONTINUE +* + 100 DO 115 IPART=1,NPART + DO 110 INOR=1,MAXNOR + SIGP(INOR,IPART)=0.0 + 110 CONTINUE + 115 CONTINUE + CALL LIBPTT(IGRP,MDIL,NPART-2,DILUT2,XSDIL,GOLD,HNAMIS, + 1 IMPX,NOR,SIGP(1,1),SIGP(1,2),SIGP(1,3)) +* + DEALLOCATE(XSDIL) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(DILUT2,LDIL) + RETURN + END diff --git a/Dragon/src/LIBTE2.f b/Dragon/src/LIBTE2.f new file mode 100644 index 0000000..77a10b7 --- /dev/null +++ b/Dragon/src/LIBTE2.f @@ -0,0 +1,173 @@ +*DECK LIBTE2 + SUBROUTINE LIBTE2 (NGRO,NSUBM,TMIX,SMIX,TN,SN,TERP) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the Lagrange interpolation factors (TERP) for temperature and +* dilution interpolation of cross sections. TRANSX 2.0 algorithm. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NGRO number of energy groups. +* NSUBM number of submaterials (number of temperature/dilution +* collocation points). +* TMIX temperature of each submaterial in the library. +* SMIX dilution of each submaterial in the library. +* The submaterials are ordered by decreasing dilution and +* then by increasing temperature. +* TN temperature of the isotope. +* SN dilution cross section in each energy group of the isotope. +* A value of 1.0E10 is used for infinite dilution. +* +*Parameters: output +* TERP Lagrange interpolation factors. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NGRO,NSUBM + REAL TMIX(NSUBM),SMIX(NSUBM),TN,SN(NGRO),TERP(NGRO,NSUBM) + REAL, ALLOCATABLE, DIMENSION(:) :: WORK +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IOUT=6) + DOUBLE PRECISION CHECK +* + IF(NSUBM.EQ.1) THEN + DO 10 I=1,NGRO + TERP(I,1)=1.0 + 10 CONTINUE + RETURN + ENDIF +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(WORK(NSUBM)) +* + DO 115 ISUBM=1,NSUBM + TMAT=TMIX(ISUBM) + SMAT=SMIX(ISUBM) +*---- +* FIND TEMPERATURES VALUES +*---- + NTEMP=0 + DO 20 JSUBM=1,NSUBM + IF(SMIX(JSUBM).LT.0.9E10) GO TO 20 + NTEMP=NTEMP+1 + WORK(NTEMP)=TMIX(JSUBM) + 20 CONTINUE + TERPT=0.0 +*---- +* LIMIT TEMPERATURE INTERPOLATION TO LINEAR IS TN A GRID TEMPERATURE? +*---- + DO 30 ITMP=1,NTEMP + TT=WORK(ITMP) + IF(ABS(TN-TT).LT.1.E-3*TN+1.E-3) THEN + IF(ABS(TN-TMAT).LT.1.E-3*TMAT+1.E-3) TERPT=1.0 + GO TO 70 + ENDIF + 30 CONTINUE +*---- +* IF TEMP OUT OF RANGE USE ENDPOINTS +*---- + IF((TN.GT.WORK(NTEMP).AND.ABS(TMAT-WORK(NTEMP)).LT.1.E-3*TMAT + > +1.E-3).OR.(TN.LT.WORK(1).AND.ABS(TMAT-WORK(1)).LT. + > 1.E-3*TMAT+1.E-3)) THEN + TERPT=1.0 + GO TO 70 + ENDIF +*---- +* FIND BRACKETING TEMPS +*---- + IF(NTEMP.EQ.1) THEN + TERPT=1.0 + GO TO 70 + ENDIF + DO 40 ITMP=1,NTEMP-1 + IF(WORK(ITMP).LT.TN.AND.WORK(ITMP+1).GT.TN) THEN + ILOW=ITMP + IHIGH=ITMP+1 + IF(ABS(TMAT-WORK(ITMP)).LT.1.E-3*TMAT+1.E-3.OR.ABS(TMAT- + > WORK(ITMP+1)).LT.1.E-3*TMAT+1.E-3) GO TO 50 + ENDIF + 40 CONTINUE + GO TO 70 + 50 TERPT=1.0 + DO 60 ITMP=ILOW,IHIGH + TT=WORK(ITMP) + IF(ABS(TMAT-TT).LT.1.E-3*TMAT+1.E-3) GO TO 60 + TERPT=TERPT*(TN-TT)/(TMAT-TT) + IF(ABS(TERPT).LT.1.E-3) GO TO 70 + 60 CONTINUE +* +*---- +* FIND SIGMA-ZERO VALUES +*---- + 70 NTEMP=0 + NSIGZ=0 + DO 80 JSUBM=1,NSUBM + IF(SMIX(JSUBM).GE.0.9E10) NTEMP=NTEMP+1 + IF(NTEMP.GT.1) GO TO 80 + NSIGZ=NSIGZ+1 + WORK(NSIGZ)=SMIX(JSUBM) + 80 CONTINUE +*---- +* FIND TERP FACTOR FOR SIGMA-ZERO +*---- + DO 110 JJ=1,NGRO + TERPS=0.0 + IF((SN(JJ).GE.WORK(1)).OR.(NSIGZ.EQ.1)) THEN + IF(SMAT.EQ.WORK(1)) TERPS=1.0 + ELSE IF(SN(JJ).LE.WORK(NSIGZ)) THEN + IF(SMAT.EQ.WORK(NSIGZ)) TERPS=1.0 + ELSE IF((SN(JJ).GT.WORK(2)).OR.(NSIGZ.EQ.2)) THEN + IF(SMAT.EQ.WORK(1)) TERPS=1.0-WORK(2)/SN(JJ) + IF(SMAT.EQ.WORK(2)) TERPS=WORK(2)/SN(JJ) + ELSE + DO 90 I=2,NSIGZ-1 + IF(SN(JJ).LT.WORK(I+1)) GO TO 90 + IF(SMAT.EQ.WORK(I+1)) TERPS=(ALOG10(WORK(I))-ALOG10(SN(JJ))) + X /(ALOG10(WORK(I))-ALOG10(WORK(I+1))) + IF(SMAT.EQ.WORK(I)) TERPS=(ALOG10(SN(JJ))-ALOG10(WORK(I+1))) + X /(ALOG10(WORK(I))-ALOG10(WORK(I+1))) + GO TO 100 + 90 CONTINUE + ENDIF + 100 TERP(JJ,ISUBM)=TERPT*TERPS + 110 CONTINUE + 115 CONTINUE +*---- +* CHECK FOR CONSISTENCY OF THE TERP FACTORS. +*---- + DO 130 JJ=1,NGRO + CHECK=0.0D0 + DO 120 ISUBM=1,NSUBM + CHECK=CHECK+TERP(JJ,ISUBM) + 120 CONTINUE + IF(ABS(CHECK-1.0D0).GT.5.0D-3) THEN + WRITE (IOUT,200) JJ,CHECK,(TERP(JJ,ISUBM),ISUBM=1,NSUBM) + CALL XABORT('LIBTE2: INTERPOLATION FAILURE.') + ENDIF + 130 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(WORK) + RETURN +* + 200 FORMAT (/51H LIBTE2: INCONSISTENT LAGRANGE INTERPOLATION FACTOR, + 1 9H IN GROUP,I4,8H. CHECK=,1P,E13.3/9H FACTORS=,1P,9E13.3/ + 2 (9X,1P,9E13.3)) + END diff --git a/Dragon/src/LIBTER.f b/Dragon/src/LIBTER.f new file mode 100644 index 0000000..8fe3641 --- /dev/null +++ b/Dragon/src/LIBTER.f @@ -0,0 +1,124 @@ +*DECK LIBTER + SUBROUTINE LIBTER (NGRO,NSUBM,TMIX,SMIX,TN,SN,TERP) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the Lagrange interpolation factors (TERP) for temperature and +* dilution interpolation of cross sections. TRANSX CTR algorithm. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NGRO number of energy groups. +* NSUBM number of submaterials (number of temperature/dilution +* collocation points). +* TMIX temperature of each submaterial in the library. +* SMIX dilution of each submaterial in the library. +* The submaterials are ordered by decreasing dilution and +* then by increasing temperature. +* TN temperature of the isotope. +* SN dilution cross section in each energy group of the isotope. +* A value of 1.0E10 is used for infinite dilution. +* +*Parameters: output +* TERP Lagrange interpolation factors. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NGRO,NSUBM + REAL TMIX(NSUBM),SMIX(NSUBM),TN,SN(NGRO),TERP(NGRO,NSUBM) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IOUT=6) + DOUBLE PRECISION CHECK +*---- +* TEMPERATURE AND BACKGROUND LOOP +*---- + IF (NSUBM.EQ.1) THEN + DO 10 I=1,NGRO + TERP(I,1)=1.0 + 10 CONTINUE + RETURN + ENDIF + BREAK=0.0 + SMIN=1.0E10 + DO 20 ISUBM=1,NSUBM + ST=SMIX(ISUBM) + IF ((ST.LT.1.0E8).AND.(ST.GT.BREAK)) BREAK=ST + IF (ST.LT.SMIN) SMIN=ST + 20 CONTINUE + DO 70 ISUBM=1,NSUBM + DO 30 JJ=1,NGRO + TERP(JJ,ISUBM)=0.0 + 30 CONTINUE + TMAT=TMIX(ISUBM) + SMAT=SMIX(ISUBM) +*---- +* COMPUTE TERP FACTORS +*---- + TERPT=1.0 + DO 40 ISM=1,NSUBM + TT=TMIX(ISM) + ST=SMIX(ISM) + IF (ST.LE.0.99E10) GO TO 40 + IF (ABS(TMAT-TT).LT.1.0E-5*TMAT+1.0E-5) GO TO 40 + TERPT=TERPT*(TN-TT)/(TMAT-TT) + IF (ABS(TERPT).LT.1.0E-5) GO TO 70 + 40 CONTINUE + DO 60 JJ=1,NGRO + TERPS=TERPT + IF ((SN(JJ).LT.SMIN).AND.(SMAT.GT.1.01*SMIN)) GO TO 60 + IF ((SN(JJ).LT.BREAK).AND.(SMAT.GT.1.01*BREAK)) GO TO 60 + IF ((SN(JJ).GE.BREAK).AND.(SMAT.LT.0.99*BREAK)) GO TO 60 + TLAST=-1.0 + DO 50 ISM=1,NSUBM + TT=TMIX(ISM) + ST=SMIX(ISM) + IF (TLAST.LT.0.) TLAST=TT + IF (TT.NE.TLAST) GO TO 50 + IF (ABS(SMAT-ST).LT.1.0E-5*SMAT) GO TO 50 + IF ((SN(JJ).GE.SMIN).AND.(SN(JJ).LT.BREAK)) THEN + IF (ST.GT.1.01*BREAK) GO TO 50 + TERPS=TERPS*LOG(SN(JJ)/ST)/LOG(SMAT/ST) + ELSE IF ((SN(JJ).GE.SMIN).AND.(SN(JJ).GE.BREAK)) THEN + IF (ST.LT.0.99*BREAK) GO TO 50 + TERPS=TERPS*((ST/SN(JJ))-1.)/((ST/SMAT)-1.) + ELSE + IF (ST.GT.1.01*SMIN) GO TO 50 + TERPS=TERPS*(SN(JJ)**2-ST**2)/(SMAT**2-ST**2) + ENDIF + IF (ABS(TERPS).LE.1.0E-5) GO TO 60 + 50 CONTINUE + TERP(JJ,ISUBM)=TERPS + 60 CONTINUE + 70 CONTINUE +*---- +* CHECK FOR CONSISTENCY OF THE TERP FACTORS. +*---- + DO 90 JJ=1,NGRO + CHECK=0.0D0 + DO 80 ISUBM=1,NSUBM + CHECK=CHECK+TERP(JJ,ISUBM) + 80 CONTINUE + IF (ABS(CHECK-1.0D0).GT.5.0D-3) THEN + WRITE (IOUT,100) JJ,CHECK,(TERP(JJ,ISUBM),ISUBM=1,NSUBM) + CALL XABORT('LIBTER: INTERPOLATION FAILURE.') + ENDIF + 90 CONTINUE + RETURN + 100 FORMAT (/51H LIBTER: INCONSISTENT LAGRANGE INTERPOLATION FACTOR, + 1 9H IN GROUP,I4,8H. CHECK=,1P,E13.3/9H FACTORS=,1P,9E13.3/ + 2 (9X,1P,9E13.3)) + END diff --git a/Dragon/src/LIBTR1.f b/Dragon/src/LIBTR1.f new file mode 100644 index 0000000..063d9a3 --- /dev/null +++ b/Dragon/src/LIBTR1.f @@ -0,0 +1,793 @@ +*DECK LIBTR1 + SUBROUTINE LIBTR1 (IPLIB,NAMFIL,NGRO,NBISO,NL,ISONAM,ISONRF, + 1 IPISO,ICOHNA,IINCNA,NTFG,TN,SN,SB,MASKI,NED,HVECT,ITIME,IMPX, + 2 NGF,NGFR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transcription of the useful interpolated microscopic cross section +* data from matxs to LCM data structures. Use matxs format from NJOY-II +* or NJOY89. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* NAMFIL name of the MATXS library file. +* NGRO number of energy groups. +* NBISO number of isotopes present in the calculation domain. +* NL number of Legendre orders required in the calculation +* NL=1 or higher. +* ISONAM alias name of isotopes. +* ISONRF library reference name of isotopes. +* IPISO pointer array towards microlib isotopes. +* ICOHNA hcoh name. +* IINCNA hinc name. +* NTFG number of thermal groups where the thermal inelastic +* correction is applied. +* TN temperature of each isotope. +* SN dilution cross section in each energy group of each +* isotope. A value of 1.0E10 is used for infinite dilution. +* SB dilution cross section as used by Livolant and Jeanpierre +* normalization. +* MASKI isotopic mask. Isotope with index I is processed if +* MASKI(I)=.true. +* NED number of extra vector edits from matxs. +* HVECT matxs names of the extra vector edits. +* MATXS reserved names: +* NWT0/NWT1 p0/p1 library weight function; +* NTOT0/NTOT1 p0/p1 neutron total cross sections; +* NELAS neutron elastic scattering cross section; +* NINEL neutron inelastic scattering cross section; +* NG radiative capture cross section; +* NFTOT total fission cross section; +* NUDEL number of delayed secondary neutrons (nu-d); +* NFSLO nu * slow fission cross section; +* CHIS/CHID slow/delayed fission spectrum; +* NF/NNF/N2NF/N3NF nu * partial fission cross sections; +* N2N/N3N/N4N (n,2n),(n,3n),(n,4n) cross sections. +* ITIME MATXS type of fission spectrum: +* =1 steady-state; =2 prompt. +* IMPX print flag. +* +*Parameters: output +* NGF number of fast groups without self-shielding. +* NGFR number of fast and resonance groups. +* +*Reference: +* R. E. Macfarlane, TRANSX-CTR: A code for interfacing matxs cross- +* section libraries to nuclear transport codes for fusion systems +* analysis, Los Alamos National Laboratory, Report LA-9863-MS, +* New Mexico, February 1984. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT CHARACTER*6 (H) +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB,IPISO(NBISO) + INTEGER NGRO,NBISO,NL,ISONAM(3,NBISO),ISONRF(3,NBISO), + 1 ICOHNA(2,NBISO),IINCNA(2,NBISO),NTFG(NBISO),NED,ITIME,IMPX, + 2 NGF,NGFR + REAL TN(NBISO),SN(NGRO,NBISO),SB(NGRO,NBISO) + LOGICAL MASKI(NBISO) + CHARACTER NAMFIL*(*),HVECT(NED)*(*) +*---- +* LOCAL VARIABLES +*---- + CHARACTER FORM*4,HSMG*131,HNISOR*12,HINC*6,HCOH*6,README*88, + 1 HNAMIS*12 + PARAMETER (MULT=2,IOUT=6,FORM='(A6)',MAXA=1000) + TYPE(C_PTR) KPLIB + LOGICAL LSUBM1,LTIME,LTERP + DOUBLE PRECISION HA(MAXA/2) + REAL A(MAXA) + INTEGER IA(MAXA),IHGAR(22) + CHARACTER*6 HGAR(18) + EQUIVALENCE (A(1),IA(1),HA(1)) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPRO + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IPR + REAL, ALLOCATABLE, DIMENSION(:) :: AWR,CNORM,SNORM,DNORM,SFIS, + 1 SAVE,VECT,GAR,XS,TERP,TEMP,SIGZ + REAL, ALLOCATABLE, DIMENSION(:,:) :: CHI,SIGF,TOTAL,FLUX + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SIGS,SCAT + LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: LOGIED +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IPR(2,NBISO),ITYPRO(NL)) + ALLOCATE(AWR(NBISO),CNORM(NBISO),SNORM(NBISO),DNORM(NBISO), + 1 SFIS(NGRO),SAVE(NGRO),CHI(NGRO,NBISO),SIGS(NGRO,NL,NBISO), + 2 SIGF(NGRO,NBISO),TOTAL(NGRO,NBISO),SCAT(NGRO,NGRO,NL), + 3 FLUX(NGRO,NBISO),VECT(NGRO),GAR(NGRO)) + ALLOCATE(LOGIED(NED,NBISO)) +* + NGF=NGRO+1 + NGFR=0 + DO 20 I=1,NBISO + IPR(1,I)=0 + IPR(2,I)=0 + 20 CONTINUE + IF(IMPX.GT.0) WRITE (IOUT,890) NAMFIL + NIN=KDROPN(NAMFIL,2,2,0) + IF(NIN.LE.0) THEN + WRITE (HSMG,'(36HLIBTR1: UNABLE TO OPEN LIBRARY FILE ,A,1H.)') + 1 NAMFIL + CALL XABORT(HSMG) + ENDIF +*---- +* INITIALIZE MATXS LIBRARY +*---- + NWDS=1+3*MULT + IREC=1 +* -------------------------------- + CALL XDREED (NIN,IREC,A(1),NWDS) +* -------------------------------- + WRITE(HN,FORM) HA(1) + WRITE(HU,FORM) HA(2) + WRITE(HS,FORM) HA(3) + IVER=IA(1+3*MULT) + IF(IMPX.GT.0) WRITE (IOUT,935) HN,HU,HS,IVER +*---- +* FILE CONTROL +*---- + NWDS=3 + IREC=2 +* -------------------------------- + CALL XDREED (NIN,IREC,A(1),NWDS) +* -------------------------------- + NPART=IA(1) + NTYPE=IA(2) + NHOLL=IA(3) +*---- +* SET HOLLERITH IDENTIFICATION +*---- + NWDS=NHOLL*MULT + IF(NWDS.GT.MAXA) + 1 CALL XABORT('LIBTR1: INSUFFICIENT VALUE OF MAXA(1).') + IREC=3 +* -------------------------------- + CALL XDREED (NIN,IREC,A(1),NWDS) +* -------------------------------- + WRITE(README(9:),'(6H FROM ,12A6)') (HA(I),I=1,MIN(NHOLL,12)) + IF(IMPX.GT.0) WRITE (IOUT,'(1X,12A6)') (HA(I),I=1,MIN(NHOLL,12)) +*---- +* FILE DATA +*---- + NWDS=(NPART+NTYPE)*MULT+6*NTYPE+NPART + IF(NWDS.GT.MAXA) + 1 CALL XABORT('LIBTR1: INSUFFICIENT VALUE OF MAXA(2).') + IREC=4 +* -------------------------------- + CALL XDREED (NIN,IREC,A(1),NWDS) +* -------------------------------- + NWC=NPART+NTYPE + IF((NWDS/2)*2.NE.NWDS) NWDS=NWDS+1 + L2=1+NWDS + L2H=(L2-1)/MULT+1 +*---- +* CHECK GROUP STRUCTURES +*---- + NEX1=(NPART+NTYPE)*MULT+6*NTYPE + DO 170 I=1,NPART + WRITE(HPART,FORM) HA(I) + NG=IA(NEX1+I) + IF(((HPART.EQ.'NEUT').OR.(HPART.EQ.'N')).AND.(NG.NE.NGRO)) + 1 CALL XABORT('LIBTR1: INCONSISTENT GROUP STRUCTURES.') + NWDS=IA(NEX1+I)+1 + ALLOCATE(XS(NWDS)) + IREC=IREC+1 +* ------------------------------ + CALL XDREED (NIN,IREC,XS,NWDS) +* ------------------------------ + IF((HPART.EQ.'NEUT').OR.(HPART.EQ.'N')) THEN +* ENERGY BOUND IN EACH GROUP (IN EV): + CALL LCMPUT(IPLIB,'ENERGY',NGRO+1,2,XS) + DO 169 J=1,NGRO + VECT(J)=LOG(XS(J)/XS(J+1)) + 169 CONTINUE + CALL LCMPUT(IPLIB,'DELTAU',NGRO,2,VECT) + ENDIF + DEALLOCATE(XS) + 170 CONTINUE + IRZT=5+NPART +*---- +* READ THROUGH MATXS FILE AND ACCUMULATE CROSS SECTIONS +* FOR THIS RANGE OF MATS, LEGENDRE ORDERS, AND GROUPS. +*---- + DO 212 KM=1,NBISO + DO 205 IED=1,NED + LOGIED(IED,KM)=.FALSE. + 205 CONTINUE + CNORM(KM)=0.0 + DO 211 KG=1,NGRO + CHI(KG,KM)=0.0 + SIGF(KG,KM)=0.0 + TOTAL(KG,KM)=0.0 + DO 210 IL=1,NL + SIGS(KG,IL,KM)=0.0 + 210 CONTINUE + 211 CONTINUE + 212 CONTINUE +*---- +* ***DATA TYPE LOOP*** +*---- + DO 680 IT=1,NTYPE + WRITE(HTYPE,FORM) HA(NPART+IT) + IF(HTYPE.EQ.'NSCAT') THEN + ITYPE=1 + ELSE IF(HTYPE.EQ.'NTHERM') THEN + ITYPE=2 + ELSE + GO TO 680 + ENDIF + NDEX=(NPART+NTYPE)*MULT+IT + NMAT=IA(NDEX) + NDEX=NDEX+NTYPE + NINP=IA(NDEX) + NDEX=NDEX+NTYPE + NING=IA(NDEX) + NDEX=NDEX+NTYPE + NOUTP=IA(NDEX) + NDEX=NDEX+NTYPE + NOUTG=IA(NDEX) + NDEX=NDEX+NTYPE + LOCT=IA(NDEX) +*---- +* DATA TYPE CONTROL +*---- + NWDS=(2+MULT)*NMAT+NINP+NOUTP+1 + IF(L2+NWDS-1.GT.MAXA) + 1 CALL XABORT('LIBTR1: INSUFFICIENT VALUE OF MAXA(3).') + IREC=LOCT+IRZT +* --------------------------------- + CALL XDREED (NIN,IREC,A(L2),NWDS) +* --------------------------------- + IF((NWDS/2)*2.NE.NWDS) NWDS=NWDS+1 + LMC=L2+NWDS + LMCH=L2H+NWDS/MULT + NSBLK=IA(L2+NMAT*(MULT+2)+NINP+NOUTP) + IRZM=IREC+1 +*---- +* ***MATERIAL/ISOTOPE LOOP*** +*---- + DO 670 IM=1,NMAT + WRITE (HMAT,FORM) HA(L2H-1+IM) + 300 DO 305 IMX=1,NBISO + IF(MASKI(IMX)) THEN + IMT=IMX + WRITE(HNAMIS,'(3A4)') (ISONAM(ITC,IMX),ITC=1,3) + WRITE(HNISOR,'(3A4)') (ISONRF(ITC,IMX),ITC=1,3) + WRITE(HCOH,'(A4,A2)') (ICOHNA(ITC,IMX),ITC=1,2) + WRITE(HINC,'(A4,A2)') (IINCNA(ITC,IMX),ITC=1,2) + IF(NTFG(IMX).EQ.0) IPR(2,IMX)=1 + IF((HMAT.EQ.HNISOR(:6)).AND.(IPR(ITYPE,IMX).EQ.0)) GO TO 306 + ENDIF + 305 CONTINUE + GO TO 670 +*---- +* MATERIAL CONTROL +*---- + 306 IPR(ITYPE,IMT)=1 + KPLIB=IPISO(IMT) ! set IMT-th isotope + IF(ITYPE.EQ.1) THEN + DO 227 IL=0,NL-1 + DO 226 IG2=1,NGRO + DO 225 IG1=1,NGRO + SCAT(IG1,IG2,IL+1)=0.0 + 225 CONTINUE + 226 CONTINUE + 227 CONTINUE + ELSE + CALL XDRLGS(KPLIB,-1,0,0,NL-1,1,NGRO,SIGS(1,1,IMT),SCAT, + 1 ITYPRO) + ENDIF +* + LOC=L2-1+MULT*NMAT+IM + NSUBM=IA(LOC) + LOCM=IA(LOC+NMAT) + IREC=LOCM+IRZM + NWDS=MULT+1+6*NSUBM + IF(LMC+NWDS-1.GT.MAXA) + 1 CALL XABORT('LIBTR1: INSUFFICIENT VALUE OF MAXA(4).') +* ---------------------------------- + CALL XDREED (NIN,IREC,A(LMC),NWDS) +* ---------------------------------- +* MASS RATIO OF EACH MATERIAL/ISOTOPE IN THE CALCULATION DOMAIN: + AWR(IMT)=A(LMC+MULT) + NWDS=NWDS+MULT-1 + L3=LMC+NWDS + L3H=LMCH+NWDS/MULT + ALLOCATE(TERP(NSUBM*NGRO),TEMP(NSUBM),SIGZ(NSUBM)) + DO 307 ISUBM=1,NSUBM + TEMP(ISUBM)=A(LMC+MULT+6*(ISUBM-1)+1) + SIGZ(ISUBM)=A(LMC+MULT+6*(ISUBM-1)+2) + 307 CONTINUE + CALL LIBTER(NGRO,NSUBM,TEMP,SIGZ,TN(IMT),SN(1,IMT),TERP) + DEALLOCATE(SIGZ,TEMP) + L5=0 + IFTOT=0 +*---- +* TEMPERATURE AND BACKGROUND LOOP +*---- + DO 600 ISUBM=1,NSUBM + LOC=LMC+MULT+6*(ISUBM-1) + TMAT=A(LOC+1) + SMAT=A(LOC+2) + LOCS=IA(LOC+6) + LSUBM1=(ISUBM.EQ.1) + IF(.NOT.LSUBM1) THEN + LTERP=.TRUE. + DO 324 IK=1,NGRO + LTERP=LTERP.AND.(TERP(NGRO*(ISUBM-1)+IK).EQ.0.0) + 324 CONTINUE + IF(LTERP) GO TO 600 + ENDIF +*---- +* PROCESS THIS SUBMATERIAL +*---- + LOC=LMC+MULT+6*(ISUBM-1) + N1DR=IA(LOC+3) + N1DB=IA(LOC+4) + N2DB=IA(LOC+5) + JREC=IREC+LOCS +*---- +* VECTOR CONTROL +*---- + IF(N1DR.EQ.0) GO TO 475 + NWDS=(3+MULT)*N1DR + IF(L3+NWDS-1.GT.MAXA) + 1 CALL XABORT('LIBTR1: INSUFFICIENT VALUE OF MAXA(5).') + JREC=JREC+1 +* --------------------------------- + CALL XDREED (NIN,JREC,A(L3),NWDS) +* --------------------------------- + NEX1=L3-1+MULT*N1DR + NEX2=NEX1+N1DR + NEX3=NEX2+N1DR + IF(LSUBM1.AND.(IMPX.GT.4)) THEN + WRITE (IOUT,870) HTYPE,HMAT,(HA(L3H+IR-1),IR=1,N1DR) + ENDIF +*---- +* VECTOR PARTIALS +*---- + IF(LSUBM1) THEN + IFTOT=0 +* IF NF IS PRESENT, SET IFTOT=1 AND USE NF+NNF+N2NF+N3NF + DO 325 IR=1,N1DR + WRITE(HVPS,FORM) HA(L3H-1+IR) + IF(HVPS.EQ.'NF') IFTOT=1 + 325 CONTINUE + DO 335 KG=1,NGRO + SFIS(KG)=0.0 + SAVE(KG)=0.0 + 335 CONTINUE + ENDIF +*---- +* LOOP OVER REACTIONS +*---- + IB=0 + DO 470 IR=1,N1DR + IBLK=IA(NEX1+IR) + IF(IBLK.GT.IB) THEN + NWDS=0 +* MANY VECTORS (REACTIONS) ARE STORED IN BLOCK IBLK. + DO 340 IJ=1,N1DR + IF(IA(NEX1+IJ).NE.IBLK) GO TO 340 + NWDS=NWDS+IA(NEX3+IJ)-IA(NEX2+IJ)+1 + 340 CONTINUE + ALLOCATE(XS(NWDS)) + JREC=JREC+1 +* ------------------------------ + CALL XDREED (NIN,JREC,XS,NWDS) +* ------------------------------ + IB=IBLK + L5=0 + ENDIF + WRITE(HVPS,FORM) HA(L3H-1+IR) + NK=IA(NEX3+IR)-IA(NEX2+IR)+1 +*---- +* SAVE REQUIRED EXTRA EDIT. +*---- + DO 346 IED=1,NED + IF(HVPS.EQ.HVECT(IED)) THEN + IF(LSUBM1) THEN + DO 341 IK=1,NGRO + VECT(IK)=0.0 + 341 CONTINUE + ELSE + CALL LCMGET(KPLIB,HVECT(IED),VECT) + ENDIF + DO 345 IK=1,NK + IF(XS(L5+IK).EQ.0.0) GO TO 345 + JJ=IA(NEX2+IR)+IK-1 + TERPZ=1.0 + IF(.NOT.LSUBM1) TERPZ=TERP(NGRO*(ISUBM-1)+JJ) + VECT(JJ)=VECT(JJ)+TERPZ*XS(L5+IK) + 345 CONTINUE + LOGIED(IED,IMT)=.TRUE. + CALL LCMPUT(KPLIB,HVECT(IED),NGRO,2,VECT) + GO TO 347 + ENDIF + 346 CONTINUE +*---- +* SAVE MODEL WEIGHT FUNCTIONS +*---- + 347 IF((HTYPE.EQ.'NSCAT').AND.(HVPS.EQ.'NWT0').AND.LSUBM1) THEN + DO 355 IK=1,NK + JJ=IA(NEX2+IR)+IK-1 + FLUX(JJ,IMT)=XS(L5+IK) + 355 CONTINUE + GO TO 466 + ENDIF + IF((HTYPE.EQ.'NTHERM').AND.(HVPS.NE.HINC).AND. + 1 (HVPS.NE.HCOH)) GO TO 466 +*---- +* LOOP OVER GROUPS +*---- + DO 440 IK=1,NK + IF(XS(L5+IK).EQ.0.0) GO TO 440 + JJ=IA(NEX2+IR)+IK-1 + LTIME=(ITIME.EQ.1) +*---- +* INTERPOLATION FACTOR +*---- + TERPZ=1.0 + IF(.NOT.LSUBM1) TERPZ=TERP(NGRO*(ISUBM-1)+JJ) + IF((SMAT.LT.0.9E10).AND.(ABS(XS(L5+IK)).GT.1.0E-6).AND. + 1 (.NOT.LSUBM1).AND.(HVPS.EQ.'NTOT0')) THEN + NGF=MIN(NGF,JJ-1) + NGFR=MAX(NGFR,JJ) + ENDIF + IF(ABS(TERPZ).LT.1.0E-3) GO TO 440 + ADD=TERPZ*XS(L5+IK) +* + IF(HVPS.EQ.'NTOT0') THEN +* TOTAL XSEC + TOTAL(JJ,IMT)=TOTAL(JJ,IMT)+ADD + ELSE IF((.NOT.LSUBM1).AND.(HVPS.EQ.'NFTOT')) THEN +* FISSION CROSS SECTION + SIGF(JJ,IMT)=SIGF(JJ,IMT)+ADD*SAVE(JJ) + ELSE IF(LSUBM1.AND.(HVPS.EQ.'NFTOT')) THEN + SFIS(JJ)=SFIS(JJ)+ADD + ELSE IF(LSUBM1.AND.(HVPS.EQ.'NFSLO')) THEN +* SLOW FISSION + SIGF(JJ,IMT)=SIGF(JJ,IMT)+ADD + SAVE(JJ)=SAVE(JJ)+ADD + IF(IK.EQ.1) SNORM(IMT)=0.0 + SNORM(IMT)=SNORM(IMT)+ADD*FLUX(JJ,IMT) + ELSE IF(LSUBM1.AND.(HVPS.EQ.'CHIS')) THEN +* SLOW FISSION + IF(SNORM(IMT).EQ.0.0) THEN + WRITE (HSMG,1050) HMAT + CALL XABORT(HSMG) + ENDIF + ADDD=SNORM(IMT)*XS(L5+IK) + CNORM(IMT)=CNORM(IMT)+ADDD + CHI(JJ,IMT)=CHI(JJ,IMT)+ADDD + ELSE IF(LSUBM1.AND.LTIME.AND.(HVPS.EQ.'NUDEL')) THEN +* DELAYED FISSION + SIGF(JJ,IMT)=SIGF(JJ,IMT)+ADD*SFIS(JJ) + SAVE(JJ)=SAVE(JJ)+SFIS(JJ)*ADD + IF(IK.EQ.1) DNORM(IMT)=0.0 + DNORM(IMT)=DNORM(IMT)+ADD*SFIS(JJ)*FLUX(JJ,IMT) + ELSE IF(LSUBM1.AND.LTIME.AND.(HVPS.EQ.'CHID')) THEN +* DELAYED FISSION + IF(DNORM(IMT).EQ.0.0) THEN + WRITE (HSMG,1060) HMAT + CALL XABORT(HSMG) + ENDIF + ADDD=DNORM(IMT)*XS(L5+IK) + CNORM(IMT)=CNORM(IMT)+ADDD + CHI(JJ,IMT)=CHI(JJ,IMT)+ADDD + ENDIF + 440 CONTINUE +* +* END OF REACTION LOOP + 466 L5=L5+NK + IF(L5.EQ.NWDS) DEALLOCATE(XS) + 470 CONTINUE +*---- +* SCATTERING MATRIX CONTROL +*---- + 475 IF(N2DB.EQ.0) GO TO 600 + DO 580 K=1,N2DB + NWDS=MULT+2+2*NOUTG + IF(L3+NWDS-1.GT.MAXA) + 1 CALL XABORT('LIBTR1: INSUFFICIENT VALUE OF MAXA(6).') + JREC=JREC+1 +* --------------------------------- + CALL XDREED (NIN,JREC,A(L3),NWDS) +* --------------------------------- + LORD=IA(L3+MULT+1) + IF(LORD.EQ.0) GO TO 580 + WRITE(HMTX,FORM) HA(L3H) + LONE=IA(L3+MULT) + LN=L3+MULT+1 + LG=LN+NOUTG + IFISN=0 + IF(HTYPE.EQ.'NSCAT'.AND.(HMTX.EQ.'NF'.OR.HMTX.EQ.'NNF' + 1 .OR.HMTX.EQ.'N2NF'.OR.HMTX.EQ.'N3NF')) IFISN=1 + IF(HTYPE.EQ.'NSCAT'.AND.HMTX.EQ.'NFTOT')IFISN=2 +*---- +* SCATTERING SUB-BLOCKS +*---- + INC=(NOUTG-1)/NSBLK+1 + DO 570 J=1,NSBLK + NWDS=0 + DO 480 JJ=(J-1)*INC+1,MIN(J*INC,NOUTG) + NWDS=NWDS+IA(LN+JJ) + 480 CONTINUE + IF(NWDS.EQ.0) GO TO 570 + NWDS=NWDS*LORD + ALLOCATE(XS(NWDS)) + JREC=JREC+1 +* ------------------------------ + CALL XDREED (NIN,JREC,XS,NWDS) +* ------------------------------ + IF(IFTOT.EQ.1.AND.IFISN.EQ.2) GO TO 560 +*---- +* STORE DESIRED CROSS SECTIONS +*---- + IF(HTYPE.EQ.'NTHERM'.AND.HMTX.NE.HINC.AND. + 1 HMTX.NE.HCOH) GO TO 530 + L5=0 +*---- +* LOOP OVER SINK, ORDER, SOURCE +*---- + DO 525 JJ=(J-1)*INC+1,MIN(J*INC,NOUTG) + NP=IA(LN+JJ) + IF(NP.EQ.0) GO TO 520 + DO 510 IL=1,LORD + ILNOW=IL+LONE + IF(ILNOW.GT.NL) GO TO 510 + DO 500 IP=1,NP + XSNOW=XS(L5+IP+NP*(IL-1)) + IF(XSNOW.EQ.0.) GO TO 500 + JJP=IA(LG+JJ)-IP+1 +*---- +* INTERPOLATION FACTOR +*---- + TERPZ=1.0 + IF(.NOT.LSUBM1) TERPZ=TERP(NGRO*(ISUBM-1)+JJP) + IF(ABS(TERPZ).LT.1.0E-3) GO TO 500 + XSEC=TERPZ*XSNOW +*---- +* CHECK FOR FISSION MATRICES +*---- + IF(IFISN.GT.0) GO TO 490 +*---- +* THERMAL CORRECTION TO SCATTERING MATRIX +*---- + IF((HMTX.EQ.'NELAS').AND.(JJP.GE.NGRO-NTFG(IMT)+1)) THEN + IF(ILNOW.EQ.1) TOTAL(JJP,IMT)=TOTAL(JJP,IMT)-XSEC + GO TO 500 + ENDIF + IF(((HMTX.EQ.HINC).OR.(HMTX.EQ.HCOH)).AND.(JJP.LT. + 1 NGRO-NTFG(IMT)+1)) GO TO 500 +*---- +* TOTAL SCATTERING MATRIX +*---- +* SCAT(SECONDARY,PRIMARY,ORDER+1) + SCAT(JJ,JJP,ILNOW)=SCAT(JJ,JJP,ILNOW)+XSEC +*---- +* TOTAL XS AND TOTAL SCATTERING VECTOR +*---- + SIGS(JJP,ILNOW,IMT)=SIGS(JJP,ILNOW,IMT)+XSEC + IF((ILNOW.EQ.1).AND.(JJP.GE.NGRO-NTFG(IMT)+1)) THEN + TOTAL(JJP,IMT)=TOTAL(JJP,IMT)+XSEC + ENDIF +*---- +* FISSION VECTORS +*---- + 490 IF(ILNOW.NE.1) GO TO 500 + IF(IFTOT.EQ.1.AND.IFISN.NE.1) GO TO 500 + IF(IFTOT.EQ.0.AND.IFISN.NE.2) GO TO 500 + SIGF(JJP,IMT)=SIGF(JJP,IMT)+XSEC + CNORM(IMT)=CNORM(IMT)+XSEC*FLUX(JJP,IMT) + CHI(JJ,IMT)=CHI(JJ,IMT)+XSEC*FLUX(JJP,IMT) + 500 CONTINUE + 510 CONTINUE + 520 L5=L5+NP*LORD + 525 CONTINUE +*---- +* ACCUMULATE FISSION NUBAR +*---- + 530 IF(LSUBM1.AND.(HTYPE.EQ.'NSCAT')) THEN + IF(IFTOT.EQ.1.AND.IFISN.NE.1) GO TO 560 + IF(IFTOT.EQ.0.AND.IFISN.NE.2) GO TO 560 + L5=0 + DO 555 JJ=(J-1)*INC+1,MIN(J*INC,NOUTG) + NP=IA(LN+JJ) + IF(NP.EQ.0) GO TO 550 + DO 540 IP=1,NP + JJP=IA(LG+JJ)-IP+1 + SAVE(JJP)=SAVE(JJP)+XS(L5+IP) + 540 CONTINUE + 550 L5=L5+NP*LORD + 555 CONTINUE + ENDIF + 560 DEALLOCATE(XS) + 570 CONTINUE + HGAR(MOD(K-1,18)+1)=HMTX + IF((K.EQ.1).AND.LSUBM1.AND.(IMPX.GT.4)) THEN + WRITE (IOUT,880) HTYPE,HMAT + ENDIF + IF((MOD(K-1,18).EQ.17).AND.LSUBM1.AND.(IMPX.GT.4)) THEN + WRITE (IOUT,885) (HGAR(I)//' ',I=1,18) + ELSE IF((K.EQ.N2DB).AND.LSUBM1.AND.(IMPX.GT.4)) THEN + WRITE (IOUT,885) (HGAR(I)//' ',I=1,MOD(N2DB-1,18)+1) + ENDIF + 580 CONTINUE +*---- +* SAVE FISSION NU FOR SHIELDING TERMS +*---- + IF(LSUBM1.AND.(HTYPE.EQ.'NSCAT')) THEN + DO 590 JJ=1,NGRO + IF(SFIS(JJ).EQ.0) GO TO 590 + SAVE(JJ)=SAVE(JJ)/SFIS(JJ) + 590 CONTINUE + ENDIF +*---- +* END OF SUBMATERIAL LOOP +*---- + 600 CONTINUE + DEALLOCATE(TERP) +*---- +* SAVE SCATTERING MATRICES ON LCM +*---- + CALL XDRLGS(KPLIB,1,0,0,NL-1,1,NGRO,SIGS(1,1,IMT),SCAT,ITYPRO) +* + GO TO 300 +*---- +* END OF MATERIAL AND DATA TYPE LOOPS +*---- + 670 CONTINUE + 680 CONTINUE +*---- +* CLOSE MATXS FILE. +*---- + CALL XDRCLS(NIN) + IER=KDRCLS(NIN,1) + IF(IER.LT.0) THEN + WRITE (HSMG,'(37HLIBTR1: UNABLE TO CLOSE LIBRARY FILE ,A,1H. + 1 )') NAMFIL + CALL XABORT(HSMG) + ENDIF +*---- +* CHECK IF ALL NBISO ISOTOPES HAVE BEEN PROCESSED. +*---- + NISOT=0 + DO 700 I=1,NBISO + IF(MASKI(I)) THEN + IF((IPR(1,I).EQ.0).OR.(IPR(2,I).EQ.0)) THEN + WRITE (IOUT,910) (ISONAM(ITC,I),ITC=1,3),NAMFIL + NISOT=NISOT+1 + ENDIF + ENDIF + 700 CONTINUE + IF(NISOT.GT.0) CALL XABORT('LIBTR1: MISSING ISOTOPES') +*---- +* PRINT FINAL FLUX COMPONENTS +*---- + IF(IMPX.GT.6) THEN + DO 720 IRG=1,NBISO + IF(MASKI(IRG)) THEN + SUM=0.0 + DO 710 JJ=1,NGRO + SUM=SUM+FLUX(JJ,IRG) + 710 CONTINUE + WRITE(IOUT,927) (ISONAM(ITC,IRG),ITC=1,3),SUM + WRITE(IOUT,928) (FLUX(I,IRG),I=1,NGRO) + ENDIF + 720 CONTINUE + ENDIF +*---- +* PERFORM LIVOLANT-JEANPIERRE NORMALIZATION AND SAVE CROSS SECTION +* INFORMATION ON LCM. +*---- + DO 830 IM=1,NBISO + IF(MASKI(IM)) THEN + WRITE(HNAMIS,'(3A4)') (ISONAM(ITC,IM),ITC=1,3) + KPLIB=IPISO(IM) ! set IM-th isotope + DO 740 I=1,NGRO + IF((SN(I,IM).NE.SB(I,IM)).AND.(SN(I,IM).LT.1.0E10)) THEN + VECT(I)=1.0/(1.0+(TOTAL(I,IM)-SIGS(I,1,IM))*(1.0/SN(I,IM)- + 1 1.0/SB(I,IM))) + ELSE + VECT(I)=1.0 + ENDIF + IF(SN(I,IM).LT.1.0E10) THEN + FLUX(I,IM)=SN(I,IM)/(SN(I,IM)+TOTAL(I,IM)-SIGS(I,1,IM))/ + 1 VECT(I) + ELSE + FLUX(I,IM)=1.0 + ENDIF + TOTAL(I,IM)=TOTAL(I,IM)*VECT(I) + 740 CONTINUE + IF(IMPX.GT.5) THEN + WRITE(IOUT,920) HNAMIS + WRITE(IOUT,928) (VECT(I),I=1,NGRO) + ENDIF + CALL LCMPUT(KPLIB,'NTOT0',NGRO,2,TOTAL(1,IM)) + CALL LCMPUT(KPLIB,'NWT0',NGRO,2,FLUX(1,IM)) + CALL XDRLGS(KPLIB,-1,0,0,NL-1,1,NGRO,SIGS(1,1,IM),SCAT, + 1 ITYPRO) + DO 752 IL=0,NL-1 + DO 751 IG2=1,NGRO + FACTOR=VECT(IG2) + SIGS(IG2,IL+1,IM)=SIGS(IG2,IL+1,IM)*FACTOR + DO 750 IG1=1,NGRO + SCAT(IG1,IG2,IL+1)=SCAT(IG1,IG2,IL+1)*FACTOR + 750 CONTINUE + 751 CONTINUE + 752 CONTINUE + CALL XDRLGS(KPLIB,1,0,0,NL-1,1,NGRO,SIGS(1,1,IM),SCAT, + 1 ITYPRO) + DO 780 IED=1,NED + IF(LOGIED(IED,IM).AND.(HVECT(IED)(:3).NE.'CHI') + 1 .AND.(HVECT(IED)(:2).NE.'NU') + 2 .AND.(HVECT(IED).NE.'NTOT0') + 3 .AND.(HVECT(IED)(:3).NE.'NWT')) THEN + CALL LCMGET(KPLIB,HVECT(IED),GAR) + DO 770 I=1,NGRO + GAR(I)=GAR(I)*VECT(I) + 770 CONTINUE + CALL LCMPUT(KPLIB,HVECT(IED),NGRO,2,GAR) + ENDIF + 780 CONTINUE +* + IF(CNORM(IM).NE.0.0) THEN +* FISSION SOURCE NORMALIZATION + DO 790 JJ=1,NGRO + CHI(JJ,IM)=CHI(JJ,IM)/CNORM(IM) + SIGF(JJ,IM)=SIGF(JJ,IM)*VECT(JJ) + 790 CONTINUE + CALL LCMPUT(KPLIB,'NUSIGF',NGRO,2,SIGF(1,IM)) + CALL LCMPUT(KPLIB,'CHI',NGRO,2,CHI(1,IM)) + ENDIF + CALL LCMPTC(KPLIB,'ALIAS',12,HNAMIS) + CALL LCMPUT(KPLIB,'AWR',1,2,AWR(IM)) + WRITE(README(:8),'(A8)') HNAMIS(1:8) + READ(README,'(22A4)') (IHGAR(I),I=1,22) + CALL LCMPUT(KPLIB,'README',22,3,IHGAR) + ENDIF + 830 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(LOGIED) + DEALLOCATE(GAR,VECT,FLUX,SCAT,TOTAL,SIGF,SIGS,CHI,SAVE,SFIS, + 1 DNORM,SNORM,CNORM,AWR) + DEALLOCATE(ITYPRO,IPR) + RETURN +* + 870 FORMAT(/52H AVAILABLE IDENTIFIERS OF REACTION VECTORS FOR TYPE , + 1 A6,14H AND MATERIAL ,A6,1H:/(1X,18A7)) + 880 FORMAT(/53H AVAILABLE IDENTIFIERS OF REACTION MATRICES FOR TYPE , + 1 A6,14H AND MATERIAL ,A6,1H:) + 885 FORMAT(1X,18A7) + 890 FORMAT(/32H PROCESSING MATXS LIBRARY NAMED ,A,1H.) + 910 FORMAT(/27H LIBTR1: MATERIAL/ISOTOPE ',3A4,16H' IS MISSING ON , + 1 16HMATXS FILE NAME ,A,1H.) + 920 FORMAT(/40H L-J NORMALIZATION FACTORS FOR MATERIAL ,A12) + 927 FORMAT(/19H FLUX FOR MATERIAL ,3A4,7H SUM=,1P,E12.5) + 928 FORMAT(1X,1P,10E12.4) + 935 FORMAT(/16H MATXS FILE ID: ,3A6,6H VERS ,I2) + 1050 FORMAT(35HLIBTR1: SNORM MISSING FOR MATERIAL ,A6,1H.) + 1060 FORMAT(35HLIBTR1: DNORM MISSING FOR MATERIAL ,A6,1H.) + END diff --git a/Dragon/src/LIBTR2.f b/Dragon/src/LIBTR2.f new file mode 100644 index 0000000..29c75ef --- /dev/null +++ b/Dragon/src/LIBTR2.f @@ -0,0 +1,894 @@ +*DECK LIBTR2 + SUBROUTINE LIBTR2 (IPLIB,NAMFIL,NGRO,NBISO,NL,ISONAM,ISONRF, + 1 IPISO,ICOHNA,IINCNA,IIRESK,NTFG,TN,SN,SB,MASKI,NED,HVECT,ITIME, + 2 IMPX,NGF,NGFR,NPART) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transcription of the useful interpolated microscopic cross section +* data from matxs to lcm data structures. Use matxs format from NJOY-91. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* NAMFIL name of the MATXS library file. +* NGRO number of energy groups. +* NBISO number of isotopes present in the calculation domain. +* NL number of Legendre orders required in the calculation +* NL=1 or higher. +* ISONAM alias name of isotopes. +* ISONRF library name of isotopes. +* IPISO pointer array towards microlib isotopes. +* ICOHNA hcoh name. +* IINCNA hinc name. +* IIRESK resk name. +* NTFG number of thermal groups where the thermal inelastic +* correction is applied. +* TN temperature of each isotope. +* SN dilution cross section in each energy group of each +* isotope. A value of 1.0E10 is used for infinite dilution. +* SB dilution cross section as used by livolant and jeanpierre +* normalization. +* MASKI isotopic mask. Isotope with index I is processed if +* MASKI(I)=.true. +* NED number of extra vector edits from matxs. +* HVECT matxs names of the extra vector edits. +* MATXS reserved names: +* NWT0/NWT1 p0/p1 library weight function; +* NTOT0/NTOT1 p0/p1 neutron total cross sections; +* NELAS neutron elastic scattering cross section; +* NINEL neutron inelastic scattering cross section; +* NG radiative capture cross section; +* NFTOT total fission cross section; +* NUDEL number of delayed secondary neutrons (nu-d); +* CHID delayed fission spectrum; +* NF/NNF/N2NF/N3NF nu * partial fission cross sections; +* N2N/N3N/N4N (n,2n),(n,3n),(n,4n) cross sections. +* ITIME MATXS type of fission spectrum: +* =1 steady-state; =2 prompt. +* IMPX print flag. +* +*Parameters: output +* NGF number of fast groups without self-shielding. +* NGFR number of fast and resonance groups. +* NPART number of particles. +* +*Reference: +* R. E. Macfarlane, TRANSX 2: A code for interfacing matxs cross- +* section libraries to nuclear transport codes, Los Alamos National +* Laboratory, Report LA-12312-MS, New Mexico, July 1992. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE LIBEEDR + IMPLICIT CHARACTER*6 (H) +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER*(*) HVECT(NED),NAMFIL + TYPE(C_PTR) IPLIB,IPISO(NBISO) + INTEGER NGRO,NBISO,NL,ISONAM(3,NBISO),ISONRF(3,NBISO), + 1 ICOHNA(2,NBISO),IINCNA(2,NBISO),IIRESK(2,NBISO),NTFG(NBISO), + 2 NED,ITIME,IMPX,NGF,NGFR,NPART + LOGICAL MASKI(NBISO) + REAL TN(NBISO),SN(NGRO,NBISO),SB(NGRO,NBISO) +*---- +* LOCAL VARIABLES +*---- + CHARACTER FORM*4,HSMG*131,HNISOR*12,HINC*6,HCOH*6,HRSK*6, + 1 README*88,HNAMIS*12,TEXT12*12,HPRT1*1,HPRT2*1 + CHARACTER HN*8,HU*8,HS*8 + PARAMETER (MULT=2,IOUT=6,FORM='(A6)',MAXA=10000) + TYPE(C_PTR) KPLIB + LOGICAL LSUBM1,LTIME,LTERP,LPART,LDEP(2) + DOUBLE PRECISION XHA(MAXA/2) + REAL A(MAXA) + INTEGER IA(MAXA),IHGAR(22) + EQUIVALENCE (A(1),IA(1),XHA(1)) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IPR,ITYPRO,NGPART + REAL, ALLOCATABLE, DIMENSION(:) :: SFIS,SAVE,CHI,SIGF,TOTAL,FLUX, + 1 VECT,GAR,XS,TERP,TEMP,SIGZ,C2PART + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SIGS,XSMAT + REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: SCAT + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LOGIED + CHARACTER(LEN=1), ALLOCATABLE, DIMENSION(:) :: HNPART + CHARACTER(LEN=6), ALLOCATABLE, DIMENSION(:) :: HMTX2 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IPR(NBISO),ITYPRO(NL)) + ALLOCATE(SFIS(NGRO),SAVE(NGRO),CHI(NGRO),SIGF(NGRO),TOTAL(NGRO), + 1 FLUX(NGRO),VECT(NGRO+1),GAR(NGRO),XSMAT(NGRO,NGRO,NL)) + ALLOCATE(LOGIED(NED)) +* + NGF=NGRO+1 + NGFR=0 + DO 100 I=1,NBISO + IPR(I)=0 + 100 CONTINUE + IF(IMPX.GT.0) WRITE (IOUT,920) NAMFIL + ILIBIN=2 + IF(NAMFIL(:1).EQ.'_') ILIBIN=3 + NIN=KDROPN(NAMFIL,2,ILIBIN,0) + IF(NIN.LE.0) THEN + WRITE (HSMG,'(36HLIBTR2: UNABLE TO OPEN LIBRARY FILE ,A,1H.)') + 1 NAMFIL + CALL XABORT(HSMG) + ENDIF +*---- +* INITIALIZE MATXS LIBRARY +*---- + NWDS=1+3*MULT + IREC=1 +* --FILE IDENTIFICATION-------------- + IF(ILIBIN.EQ.2) THEN + CALL XDREED (NIN,IREC,A(1),NWDS) + ELSE IF(ILIBIN.EQ.3) THEN + CALL LIBEED (NIN,IREC,A(1),NWDS) + ENDIF +* ----------------------------------- + WRITE(HN,'(A8)') XHA(1) + WRITE(HU,'(A8)') XHA(2) + WRITE(HS,'(A8)') XHA(3) + IVER=IA(1+3*MULT) + IF(IMPX.GT.0) WRITE (IOUT,970) HN,HU,HS,IVER +* + NWDS=6 + IREC=2 +* --FILE CONTROL--------------------- + IF(ILIBIN.EQ.2) THEN + CALL XDREED (NIN,IREC,A(1),NWDS) + ELSE IF(ILIBIN.EQ.3) THEN + CALL LIBEED (NIN,IREC,A(1),NWDS) + ENDIF +* ----------------------------------- + NPART=IA(1) + NTYPE=IA(2) + NHOLL=IA(3) + NMAT=IA(4) + MAXW=IA(5) + ALLOCATE(NGPART(NPART),C2PART(NPART),HNPART(NPART), + 1 SIGS(NGRO,NL,NPART),SCAT(NGRO,NGRO,NL,NPART)) +* + NWDS=NHOLL*MULT + IF(NWDS.GT.MAXA) + 1 CALL XABORT('LIBTR2: INSUFFICIENT VALUE OF MAXA(1).') + IREC=3 +* --HOLLERITH IDENTIFICATION--------- + IF(ILIBIN.EQ.2) THEN + CALL XDREED (NIN,IREC,A(1),NWDS) + ELSE IF(ILIBIN.EQ.3) THEN + CALL LIBEED (NIN,IREC,A(1),NWDS) + ENDIF +* ----------------------------------- + WRITE(README(9:),'(6H FROM ,9A8)') (XHA(I),I=1,MIN(NHOLL,9)) + IF(IMPX.GT.0) WRITE (IOUT,'(1X,9A8)') (XHA(I),I=1,MIN(NHOLL,9)) +* + NWDS=(NPART+NTYPE+NMAT)*MULT+2*NTYPE+NPART+2*NMAT + IF(NWDS.GT.MAXA) + 1 CALL XABORT('LIBTR2: INSUFFICIENT VALUE OF MAXA(2).') + IREC=4 +* --FILE DATA------------------------ + IF(ILIBIN.EQ.2) THEN + CALL XDREED (NIN,IREC,A(1),NWDS) + ELSE IF(ILIBIN.EQ.3) THEN + CALL LIBEED (NIN,IREC,A(1),NWDS) + ENDIF +* ----------------------------------- + + IF((NWDS/2)*2.NE.NWDS) NWDS=NWDS+1 + L2=1+NWDS + L2H=1+NWDS/MULT +*---- +* CHECK GROUP STRUCTURES AND FIND INCIDENT PARTICLE TYPE +*---- + NEX1=(NPART+NTYPE+NMAT)*MULT + LPART=.FALSE. + HCOH=' ' + HINC=' ' + HRSK=' ' + DO 120 I=1,NPART + WRITE(HPRT,FORM) XHA(I) + CALL LIBCOV(HPRT) + LPART=(HPRT.EQ.'N').OR.(HPRT.EQ.'G').OR.(HPRT.EQ.'B').OR. + 1 (HPRT.EQ.'C') + NG=IA(NEX1+I) + IF(LPART.AND.(I.EQ.1).AND.(NG.NE.NGRO)) + 1 CALL XABORT('LIBTR2: INCONSISTENT GROUP STRUCTURES.') + HNPART(I)=HPRT(:1) + IF(HPRT.EQ.'N') THEN + C2PART(I)=9.39565413E8 + ELSE IF((HPRT.EQ.'B').OR.(HPRT.EQ.'C')) THEN + C2PART(I)=5.10976031E5 + ELSE + C2PART(I)=0.0 + ENDIF + NGPART(I)=NG + NWDS=NG+1 + ALLOCATE(XS(NWDS)) + IREC=IREC+1 +* --GROUP STRUCTURE---------------- + IF(ILIBIN.EQ.2) THEN + CALL XDREED (NIN,IREC,XS,NWDS) + ELSE IF(ILIBIN.EQ.3) THEN + CALL LIBEED (NIN,IREC,XS,NWDS) + ENDIF +* --------------------------------- + IF(LPART) THEN +* ENERGY BOUND IN EACH GROUP (IN EV): + DO 110 J=1,NGRO + VECT(J)=LOG(XS(J)/XS(J+1)) + 110 CONTINUE + IF(I.EQ.1) THEN + CALL LCMPUT(IPLIB,'ENERGY',NGRO+1,2,XS) + CALL LCMPUT(IPLIB,'DELTAU',NGRO,2,VECT) + CALL LCMPTC(IPLIB,'PARTICLE',1,HNPART(1)) + ELSE + CALL LCMPUT(IPLIB,HNPART(I)//'ENERGY',NGRO+1,2,XS) + CALL LCMPUT(IPLIB,HNPART(I)//'DELTAU',NGRO,2,VECT) + ENDIF + ENDIF + DEALLOCATE(XS) + 120 CONTINUE + CALL LCMPTC(IPLIB,'PARTICLE-NAM',1,NPART,HNPART) + CALL LCMPUT(IPLIB,'PARTICLE-NGR',NPART,1,NGPART) + CALL LCMPUT(IPLIB,'PARTICLE-MC2',NPART,2,C2PART) + IF(.NOT.LPART) THEN + WRITE(HSMG,'(8HLIBTR2: ,A,32HIS NOT A SUPPORTED PARTICLE TYPE, + 1 35H (''N'', ''G'', ''B'' AND ''C'' SUPPORTED).)') HPRT + CALL XABORT(HSMG) + ENDIF +*---- +* READ THROUGH MATXS FILE AND ACCUMULATE CROSS SECTIONS FOR THIS RANGE +* MATS, LEGENDRE ORDERS, AND GROUPS. +* +* ***MATERIAL/ISOTOPE LOOP*** +*---- + HPRT1=HNPART(1) + IRZM=IREC+1 + DO 840 IM=1,NMAT + 130 CNORM=0.0 + DO 153 IG1=1,NGRO + CHI(IG1)=0.0 + SIGF(IG1)=0.0 + TOTAL(IG1)=0.0 + DO 152 IL=1,NL + DO 151 IP=1,NPART + SIGS(IG1,IL,IP)=0.0 + DO 150 IG2=1,NGRO + SCAT(IG1,IG2,IL,IP)=0.0 + 150 CONTINUE + 151 CONTINUE + 152 CONTINUE + 153 CONTINUE + WRITE (HMAT,FORM) XHA(NPART+NTYPE+IM) + DO 160 IMX=1,NBISO + IF(MASKI(IMX)) THEN + IMT=IMX + WRITE(HNAMIS,'(3A4)') (ISONAM(ITC,IMX),ITC=1,3) + WRITE(HNISOR,'(3A4)') (ISONRF(ITC,IMX),ITC=1,3) + WRITE(HCOH,'(A4,A2)') (ICOHNA(ITC,IMX),ITC=1,2) + WRITE(HINC,'(A4,A2)') (IINCNA(ITC,IMX),ITC=1,2) + WRITE(HRSK,'(A4,A2)') (IIRESK(ITC,IMX),ITC=1,2) + CALL LIBCOV(HCOH) + CALL LIBCOV(HINC) + CALL LIBCOV(HRSK) + IF((HMAT.EQ.HNISOR(:6)).AND.(IPR(IMX).EQ.0)) GO TO 170 + ENDIF + 160 CONTINUE + GO TO 840 +*---- +* RECOVER THE MATERIAL CONTROL +*---- + 170 IPR(IMT)=1 + LOGIED(:NED)=.FALSE. + LDEP(:2)=.FALSE. + KPLIB=IPISO(IMT) ! set IMT-th isotope + LOC=(NPART+NTYPE+NMAT)*MULT+NPART+2*NTYPE+IM + NSUB=IA(LOC) + LOCM=IA(LOC+NMAT) + IREC=LOCM+IRZM + NWDS=MULT+1+6*NSUB + IF(L2+NWDS-1.GT.MAXA) + 1 CALL XABORT('LIBTR2: INSUFFICIENT VALUE OF MAXA(3).') +* --MATERIAL CONTROL------------------ + IF(ILIBIN.EQ.2) THEN + CALL XDREED (NIN,IREC,A(L2),NWDS) + ELSE IF(ILIBIN.EQ.3) THEN + CALL LIBEED (NIN,IREC,A(L2),NWDS) + ENDIF +* ------------------------------------ +* MASS RATIO OF EACH MATERIAL/ISOTOPE IN THE CALCULATION DOMAIN: + AWR=A(L2+MULT) + IF((NWDS/2)*2.NE.NWDS) NWDS=NWDS+1 + L3=L2+NWDS + L3H=L2H+NWDS/MULT + ALLOCATE(TERP(NSUB*NGRO),TEMP(NSUB),SIGZ(NSUB)) + DO 175 ISUBM=1,NSUB + TEMP(ISUBM)=A(L2+MULT+6*(ISUBM-1)+1) + SIGZ(ISUBM)=A(L2+MULT+6*(ISUBM-1)+2) + 175 CONTINUE + NSUB0=0 + DO 185 ITYPE=1,NTYPE + N0=0 + DO 180 ISUBM=1,NSUB + IF(IA(L2+MULT+6*(ISUBM-1)+3).EQ.ITYPE) N0=N0+1 + 180 CONTINUE + CALL LIBTE2(NGRO,N0,TEMP(NSUB0+1),SIGZ(NSUB0+1),TN(IMT), + 1 SN(1,IMT),TERP(NSUB0*NGRO+1)) + NSUB0=NSUB0+N0 + 185 CONTINUE + IF(NSUB0.NE.NSUB) CALL XABORT('LIBTR2: DATA TYPE FAILURE.') + DEALLOCATE(SIGZ,TEMP) +*---- +* TEMPERATURE AND BACKGROUND LOOP +*---- + IOLDTY=0 + L5=0 + DNORM=0.0 + DO 720 ISUBM=1,NSUB + LOC=L2+MULT+6*(ISUBM-1) + TMAT=A(LOC+1) + SMAT=A(LOC+2) + ITYPE=IA(LOC+3) + LSUBM1=(ITYPE.NE.IOLDTY) + IOLDTY=ITYPE + N1D=IA(LOC+4) + N2D=IA(LOC+5) + LOCS=IA(LOC+6) + LOCG=(NPART+NTYPE+NMAT)*MULT + JINP=IA(LOCG+NPART+ITYPE) + NING=IA(LOCG+JINP) + JOUTP=IA(LOCG+NPART+NTYPE+ITYPE) + NOUTG=IA(LOCG+JOUTP) + HPRT1=HNPART(JINP) + HPRT2=HNPART(JOUTP) + CALL LIBCOV(HPRT1) + CALL LIBCOV(HPRT2) + WRITE(HTYPE,FORM) XHA(NPART+ITYPE) + CALL LIBCOV(HTYPE) + IF(IMPX.GT.6) WRITE(IOUT,870) ISUBM,HPRT1,HPRT2,HTYPE,HMAT + IF(.NOT.LSUBM1) THEN + LTERP=.TRUE. + DO 190 IK=1,NGRO + LTERP=LTERP.AND.(TERP(NGRO*(ISUBM-1)+IK).EQ.0.0) + 190 CONTINUE + IF(LTERP) GO TO 720 + ENDIF +*---- +* PROCESS THIS SUBMATERIAL +*---- + JREC=IREC+LOCS + IF(N1D.EQ.0) GO TO 460 + NWDS=(2+MULT)*N1D + IF(L3+NWDS-1.GT.MAXA) + 1 CALL XABORT('LIBTR2: INSUFFICIENT VALUE OF MAXA(4).') + JREC=JREC+1 +* --VECTOR CONTROL-------------------- + IF(ILIBIN.EQ.2) THEN + CALL XDREED (NIN,JREC,A(L3),NWDS) + ELSE IF(ILIBIN.EQ.3) THEN + CALL LIBEED (NIN,JREC,A(L3),NWDS) + ENDIF +* ------------------------------------ + NEX1=L3-1+MULT*N1D + NEX2=NEX1+N1D + IF(LSUBM1.AND.(IMPX.GT.4)) THEN + WRITE (IOUT,880) HTYPE,HMAT,(XHA(L3H+IR-1),IR=1,N1D) + ENDIF +*---- +* VECTOR PARTIALS +*---- + IF(LSUBM1) THEN + DO 210 KG=1,NGRO + SFIS(KG)=0.0 + SAVE(KG)=0.0 + 210 CONTINUE + ENDIF +*---- +* LOOP OVER REACTIONS +*---- + IRMAX=0 + DO 455 IR=1,N1D + IF(IR.GT.IRMAX) THEN +* MANY VECTORS (REACTIONS) ARE STORED IN VECTOR BLOCK. + NWDS=0 + IJ0=IRMAX+1 + DO 220 IJ=IJ0,N1D + NW=IA(NEX2+IJ)-IA(NEX1+IJ)+1 + IF(NWDS+NW.GE.MAXW) GO TO 230 + IRMAX=IRMAX+1 + NWDS=NWDS+NW + 220 CONTINUE + 230 IF(NWDS.EQ.0) CALL XABORT('LIBTR2: MAXW IS TOO SMALL.') + ALLOCATE(XS(NWDS)) + JREC=JREC+1 +* --VECTOR BLOCK------------------- + IF(ILIBIN.EQ.2) THEN + CALL XDREED (NIN,JREC,XS,NWDS) + ELSE IF(ILIBIN.EQ.3) THEN + CALL LIBEED (NIN,JREC,XS,NWDS) + ENDIF +* --------------------------------- + L5=0 + ENDIF + WRITE(HVPS,FORM) XHA(L3H-1+IR) + CALL LIBCOV(HVPS) + IF(IMPX.GT.5) WRITE(IOUT,890) 'VECTOR',HVPS + NK=IA(NEX2+IR)-IA(NEX1+IR)+1 +*---- +* SAVE REQUIRED EXTRA EDIT. +*---- + DO 260 I=1,NED + TEXT12=HVECT(I) + CALL LIBCOV(TEXT12) + IF(HVPS.EQ.TEXT12) THEN + VECT(:NGRO+1)=0.0 + IF(.NOT.LSUBM1) CALL LCMGET(KPLIB,HVECT(I),VECT) + DO 250 IK=1,NK + IF(XS(L5+IK).EQ.0.0) GO TO 250 + JJ=IA(NEX1+IR)+IK-1 + TERPZ=1.0 + IF(.NOT.LSUBM1) TERPZ=TERP(NGRO*(ISUBM-1)+JJ) + VECT(JJ)=VECT(JJ)+TERPZ*XS(L5+IK) + 250 CONTINUE + LOGIED(I)=.TRUE. + IF((TEXT12(:3).EQ.'BST').OR.(TEXT12(:3).EQ.'CST')) THEN +* STOPPING POWER + CALL LCMPUT(KPLIB,HVECT(I),NGRO+1,2,VECT) + ELSE + CALL LCMPUT(KPLIB,HVECT(I),NGRO,2,VECT) + ENDIF + GO TO 270 + ENDIF + 260 CONTINUE +*---- +* SAVE ENERGY DEPOSITION. +*---- + IF(HVPS(2:).EQ.'HEAT') THEN + VECT(:NGRO+1)=0.0 + IF(.NOT.LSUBM1) CALL LCMGET(KPLIB,HVECT(I),VECT) + DO 261 IK=1,NK + IF(XS(L5+IK).EQ.0.0) GO TO 261 + JJ=IA(NEX1+IR)+IK-1 + TERPZ=1.0 + IF(.NOT.LSUBM1) TERPZ=TERP(NGRO*(ISUBM-1)+JJ) + VECT(JJ)=VECT(JJ)+TERPZ*XS(L5+IK) + 261 CONTINUE + LDEP(1)=.TRUE. + CALL LCMPUT(KPLIB,'H-FACTOR',NGRO,2,VECT) + GO TO 270 + ELSE IF(HVPS(2:).EQ.'CHAR') THEN + VECT(:NGRO+1)=0.0 + IF(.NOT.LSUBM1) CALL LCMGET(KPLIB,HVECT(I),VECT) + DO 262 IK=1,NK + IF(XS(L5+IK).EQ.0.0) GO TO 262 + JJ=IA(NEX1+IR)+IK-1 + TERPZ=1.0 + IF(.NOT.LSUBM1) TERPZ=TERP(NGRO*(ISUBM-1)+JJ) + VECT(JJ)=VECT(JJ)+TERPZ*XS(L5+IK) + 262 CONTINUE + LDEP(2)=.TRUE. + CALL LCMPUT(KPLIB,'C-FACTOR',NGRO,2,VECT) + GO TO 270 + ENDIF +*---- +* SAVE MODEL WEIGHT FUNCTIONS +*---- + 270 IF((HTYPE.EQ.HPRT1//'SCAT').AND.(HVPS.EQ.HPRT1//'WT0').AND.LSUBM1) + 1 THEN + DO 280 IK=1,NK + JJ=IA(NEX1+IR)+IK-1 + FLUX(JJ)=XS(L5+IK) + 280 CONTINUE + GO TO 450 + ENDIF + IF((HTYPE.EQ.'NTHERM').AND.(HVPS.NE.HINC).AND. + 1 (HVPS.NE.HCOH).AND.(HVPS.NE.HRSK)) GO TO 450 +*---- +* LOOP OVER GROUPS +*---- + DO 440 IK=1,NK + IF(XS(L5+IK).EQ.0.0) GO TO 440 + JJ=IA(NEX1+IR)+IK-1 + LTIME=(ITIME.EQ.1) +*---- +* INTERPOLATION FACTOR +*---- + TERPZ=1.0 + IF(.NOT.LSUBM1) TERPZ=TERP(NGRO*(ISUBM-1)+JJ) + IF((SMAT.LT.0.9E10).AND.(ABS(XS(L5+IK)).GT.1.0E-6).AND. + 1 (.NOT.LSUBM1).AND.(HVPS.EQ.'NTOT0')) THEN + NGF=MIN(NGF,JJ-1) + NGFR=MAX(NGFR,JJ) + ENDIF + IF(ABS(TERPZ).LT.1.0E-3) GO TO 440 + ADD=TERPZ*XS(L5+IK) +* + IF(HVPS.EQ.HPRT1//'TOT0') THEN +* TOTAL XSEC + TOTAL(JJ)=TOTAL(JJ)+ADD + ELSE IF((.NOT.LSUBM1).AND.(HVPS.EQ.'NFTOT')) THEN +* FISSION CROSS SECTION + SIGF(JJ)=SIGF(JJ)+ADD*SAVE(JJ) + ELSE IF(LSUBM1.AND.(HVPS.EQ.'NFTOT')) THEN + SFIS(JJ)=SFIS(JJ)+ADD + ELSE IF(LSUBM1.AND.LTIME.AND.(HVPS.EQ.'NUDEL')) THEN +* DELAYED FISSION + SIGF(JJ)=SIGF(JJ)+ADD*SFIS(JJ) + SAVE(JJ)=SAVE(JJ)+SFIS(JJ)*ADD + IF(IK.EQ.1) DNORM=0.0 + DNORM=DNORM+ADD*SFIS(JJ)*FLUX(JJ) + ELSE IF(LSUBM1.AND.LTIME.AND.(HVPS.EQ.'CHID')) THEN +* DELAYED FISSION + IF(DNORM.EQ.0.0) THEN + WRITE (HSMG,980) HMAT + CALL XABORT(HSMG) + ENDIF + ADDD=DNORM*XS(L5+IK) + CNORM=CNORM+ADDD + CHI(JJ)=CHI(JJ)+ADDD + ENDIF + 440 CONTINUE +* +* END OF REACTION LOOP + 450 L5=L5+NK + IF(L5.EQ.NWDS) DEALLOCATE(XS) + 455 CONTINUE +*---- +* RECOVER SCATTERING MATRIX CONTROL INFORMATION. +*---- + 460 IF(N2D.EQ.0) GO TO 720 + ALLOCATE(HMTX2(N2D)) + DO 700 K=1,N2D + NWDS=MULT+2+2*NOUTG + IF(L3+NWDS-1.GT.MAXA) + 1 CALL XABORT('LIBTR2: INSUFFICIENT VALUE OF MAXA(5).') + JREC=JREC+1 +* --MATRIX CONTROL-------------------- + IF(ILIBIN.EQ.2) THEN + CALL XDREED (NIN,JREC,A(L3),NWDS) + ELSE IF(ILIBIN.EQ.3) THEN + CALL LIBEED (NIN,JREC,A(L3),NWDS) + ENDIF +* ------------------------------------ + LORD=IA(L3+MULT) + IF(LORD.EQ.0) GO TO 700 + WRITE(HMTX,FORM) XHA(L3H) + HMTX2(K)=HMTX + CALL LIBCOV(HMTX) + IF(IMPX.GT.5) WRITE(IOUT,890) 'MATRIX',HMTX + LN=L3+MULT+1 + LG=LN+NOUTG + IFISN=0 + IF(HTYPE.EQ.'NSCAT'.AND.(HMTX.EQ.'NF'.OR.HMTX.EQ.'NNF' + 1 .OR.HMTX.EQ.'N2NF'.OR.HMTX.EQ.'N3NF')) IFISN=1 + IF(HTYPE.EQ.'NSCAT'.AND.HMTX.EQ.'NFTOT') IFISN=2 + JCONST=IA(L3+MULT+1) +*---- +* RECOVER A NEW SCATTERING MATRIX SUB-BLOCK. +*---- + IF(NING.NE.NOUTG) CALL XABORT('LIBTR2: ONLY (N,N) ALLOWED.') + DO 467 IL=1,NL + DO 466 JJ=1,NOUTG + DO 465 JJP=1,NING + XSMAT(JJP,JJ,IL)=0.0 + 465 CONTINUE + 466 CONTINUE + 467 CONTINUE + NOUMAX=0 + 470 NWDS=0 + NOUMIN=NOUMAX+1 + DO 475 JJ=NOUMIN,NOUTG + NW=IA(LN+JJ)*LORD + IF(NWDS+NW.GE.MAXW) GO TO 480 + NOUMAX=NOUMAX+1 + NWDS=NWDS+NW + 475 CONTINUE + 480 IF(NWDS.GT.0) THEN + ALLOCATE(XS(NWDS)) + JREC=JREC+1 +* --MATRIX SUB-BLOCK--------------- + IF(ILIBIN.EQ.2) THEN + CALL XDREED (NIN,JREC,XS,NWDS) + ELSE IF(ILIBIN.EQ.3) THEN + CALL LIBEED (NIN,JREC,XS,NWDS) + ENDIF +* --------------------------------- + L5=0 + ELSE + GO TO 520 + ENDIF + DO 515 JJ=NOUMIN,NOUMAX + NP=IA(LN+JJ) + IF(NP.EQ.0) GO TO 510 + DO 500 IL=1,LORD + IF(IL.GT.NL) GO TO 500 + DO 490 IP=1,NP + JJP=IA(LG+JJ)-IP+1 + XSMAT(JJP,JJ,IL)=XS(L5+IP+NP*(IL-1)) + 490 CONTINUE + 500 CONTINUE + 510 L5=L5+NP*LORD + 515 CONTINUE + DEALLOCATE(XS) + 520 IF(NOUMAX.LT.NOUTG) GO TO 470 + IF(JCONST.NE.0) THEN + IF(LORD.GT.1) CALL XABORT('LIBTR2: INVALID DATA ON MATXS2.') + NWDS=NOUTG+JCONST + ALLOCATE(XS(NWDS)) + JREC=JREC+1 +* --CONSTANT SUB-BLOCK------------- + IF(ILIBIN.EQ.2) THEN + CALL XDREED (NIN,JREC,XS,NWDS) + ELSE IF(ILIBIN.EQ.3) THEN + CALL LIBEED (NIN,JREC,XS,NWDS) + ENDIF +* --------------------------------- + L5=0 + DO 535 JJ=1,NOUTG + SPEC=XS(L5+JJ) + JJP0=NING-JCONST+1 + DO 530 JJP=JJP0,NING + XSMAT(JJP,JJ,1)=XSMAT(JJP,JJ,1)+SPEC*XS(L5+NOUTG+JJP-JJP0+1) + 530 CONTINUE + 535 CONTINUE + DEALLOCATE(XS) + ENDIF +*---- +* STORE DESIRED CROSS SECTIONS +*---- + IF((HTYPE.EQ.'NTHERM').AND.(HMTX.NE.HINC).AND. + 1 (HMTX.NE.HCOH).AND.(HMTX.NE.HRSK)) GO TO 670 +*---- +* LOOP OVER SINK, ORDER, SOURCE +*---- + DO 660 JJ=1,NOUTG + DO 650 IL=1,LORD + IF(IL.GT.NL) GO TO 650 + DO 640 JJP=1,NING + XSNOW=XSMAT(JJP,JJ,IL) + IF(XSNOW.EQ.0.) GO TO 640 +*---- +* INTERPOLATION FACTOR +*---- + TERPZ=1.0 + IF(.NOT.LSUBM1) TERPZ=TERP(NGRO*(ISUBM-1)+JJP) + IF(ABS(TERPZ).LT.1.0E-3) GO TO 640 + XSEC=TERPZ*XSNOW +*---- +* CHECK FOR SCATTERING AND FISSION MATRICES +*---- + IF(IFISN.EQ.0) THEN +* THERMAL CORRECTION TO SCATTERING MATRIX + IF((HMTX.EQ.'NELAS').AND.(JJP.GE.NGRO-NTFG(IMT)+1)) THEN + IF(IL.EQ.1) TOTAL(JJP)=TOTAL(JJP)-XSEC + GO TO 640 + ENDIF + IF(((HMTX.EQ.HINC).OR.(HMTX.EQ.HCOH).OR.(HMTX.EQ.HRSK)).AND. + 1 (JJP.LT.NGRO-NTFG(IMT)+1)) GO TO 640 +* TOTAL SCATTERING MATRIX +* SCAT(SECONDARY,PRIMARY,ORDER+1) + SCAT(JJ,JJP,IL,JOUTP)=SCAT(JJ,JJP,IL,JOUTP)+XSEC +* TOTAL XS AND TOTAL SCATTERING VECTOR + SIGS(JJP,IL,JOUTP)=SIGS(JJP,IL,JOUTP)+XSEC + IF((IL.EQ.1).AND.(JJP.GE.NGRO-NTFG(IMT)+1)) THEN + TOTAL(JJP)=TOTAL(JJP)+XSEC + ENDIF + ELSE IF((IL.EQ.1).AND.(IFISN.NE.0).AND.(HTYPE.EQ.'NSCAT')) THEN +* FISSION VECTORS + SIGF(JJP)=SIGF(JJP)+XSEC + CNORM=CNORM+XSEC*FLUX(JJP) + CHI(JJ)=CHI(JJ)+XSEC*FLUX(JJP) + ENDIF + 640 CONTINUE + 650 CONTINUE + 660 CONTINUE +*---- +* ACCUMULATE FISSION NUBAR +*---- + 670 IF(LSUBM1.AND.(IFISN.NE.0).AND.(HTYPE.EQ.'NSCAT')) THEN + DO 685 JJ=1,NOUTG + DO 680 JJP=1,NING + SAVE(JJP)=SAVE(JJP)+XSMAT(JJP,JJ,1) + 680 CONTINUE + 685 CONTINUE + ENDIF +* + IF((K.EQ.N2D).AND.LSUBM1.AND.(IMPX.GT.4)) THEN + WRITE (IOUT,900) HTYPE,HMAT,(HMTX2(I),I=1,N2D) + ENDIF + 700 CONTINUE + DEALLOCATE(HMTX2) +*---- +* SAVE FISSION NU FOR SHIELDING TERMS +*---- + IF(LSUBM1.AND.(HTYPE.EQ.'NSCAT')) THEN + DO 710 JJ=1,NGRO + IF(SFIS(JJ).EQ.0) GO TO 710 + SAVE(JJ)=SAVE(JJ)/SFIS(JJ) + 710 CONTINUE + ENDIF +* +* END OF SUBMATERIAL LOOP. + 720 CONTINUE + DEALLOCATE(TERP) +*---- +* PRINT FINAL FLUX COMPONENTS +*---- + IF((IMPX.GT.6).AND.MASKI(IMT)) THEN + SUM=0.0 + DO 730 JJ=1,NGRO + SUM=SUM+FLUX(JJ) + 730 CONTINUE + WRITE(IOUT,950) HNAMIS,SUM + WRITE(IOUT,960) (FLUX(I),I=1,NGRO) + ENDIF +*---- +* PERFORM LIVOLANT-JEANPIERRE NORMALIZATION AND SAVE CROSS SECTION +* INFORMATION ON LCM. +*---- + IF(HNPART(1).EQ.'N') THEN + DO 740 I=1,NGRO + IF((SN(I,IMT).NE.SB(I,IMT)).AND.(SN(I,IMT).LT.1.0E10)) THEN + VECT(I)=1.0/(1.0+(TOTAL(I)-SIGS(I,1,1))*(1.0/SN(I,IMT) + 1 -1.0/SB(I,IMT))) + ELSE + VECT(I)=1.0 + ENDIF + IF(SN(I,IMT).LT.1.0E10) THEN + FLUX(I)=SN(I,IMT)/(SN(I,IMT)+TOTAL(I)-SIGS(I,1,1))/VECT(I) + ELSE + FLUX(I)=1.0 + ENDIF + TOTAL(I)=TOTAL(I)*VECT(I) + 740 CONTINUE + IF(IMPX.GT.5) THEN + WRITE(IOUT,940) HNAMIS + WRITE(IOUT,960) (VECT(I),I=1,NGRO) + ENDIF + DO 752 IL=0,NL-1 + DO 751 IG2=1,NGRO + FACTOR=VECT(IG2) + SIGS(IG2,IL+1,1)=SIGS(IG2,IL+1,1)*FACTOR + DO 750 IG1=1,NGRO + SCAT(IG1,IG2,IL+1,1)=SCAT(IG1,IG2,IL+1,1)*FACTOR + 750 CONTINUE + 751 CONTINUE + 752 CONTINUE +* + DO 810 IED=1,NED + TEXT12=HVECT(IED) + CALL LIBCOV(TEXT12) + IF(LOGIED(IED).AND.(TEXT12(:3).NE.'CHI') + 1 .AND.(TEXT12(:2).NE.'NU') + 2 .AND.(TEXT12.NE.'NTOT0') + 3 .AND.(TEXT12(2:).NE.'HEAT') + 4 .AND.(TEXT12(2:).NE.'CHAR') + 5 .AND.(TEXT12(:3).NE.'NWT')) THEN + CALL LCMGET(KPLIB,HVECT(IED),GAR) + DO 800 I=1,NGRO + GAR(I)=GAR(I)*VECT(I) + 800 CONTINUE + CALL LCMPUT(KPLIB,HVECT(IED),NGRO,2,GAR) + ENDIF + 810 CONTINUE + IF(LDEP(1)) THEN + CALL LCMGET(KPLIB,'H-FACTOR',GAR) + DO 811 I=1,NGRO + GAR(I)=GAR(I)*VECT(I) + 811 CONTINUE + CALL LCMPUT(KPLIB,'H-FACTOR',NGRO,2,GAR) + ENDIF + IF(LDEP(2)) THEN + CALL LCMGET(KPLIB,'C-FACTOR',GAR) + DO 812 I=1,NGRO + GAR(I)=GAR(I)*VECT(I) + 812 CONTINUE + CALL LCMPUT(KPLIB,'C-FACTOR',NGRO,2,GAR) + ENDIF + ENDIF +*---- +* SAVE CROSS SECTION INFORMATION ON LCM. +*---- + DO 815 IP=1,NPART + IF(IP.EQ.1) THEN + CALL LCMPUT(KPLIB,'NTOT0',NGRO,2,TOTAL) + CALL LCMPUT(KPLIB,'NWT0',NGRO,2,FLUX) + CALL XDRLGS(KPLIB,1,0,0,NL-1,1,NGRO,SIGS(1,1,IP), + 1 SCAT(1,1,1,IP),ITYPRO) + ELSE + CALL LCMSIX(KPLIB,HNPART(IP),1) + CALL XDRLGS(KPLIB,1,0,0,NL-1,1,NGRO,SIGS(1,1,IP), + 1 SCAT(1,1,1,IP),ITYPRO) + CALL LCMSIX(KPLIB,' ',2) + ENDIF + 815 CONTINUE +* + IF(CNORM.NE.0.0) THEN +* FISSION SOURCE NORMALIZATION + DO 820 JJ=1,NGRO + CHI(JJ)=CHI(JJ)/CNORM + SIGF(JJ)=SIGF(JJ)*VECT(JJ) + 820 CONTINUE + CALL LCMPUT(KPLIB,'NUSIGF',NGRO,2,SIGF) + CALL LCMPUT(KPLIB,'CHI',NGRO,2,CHI) + ENDIF + CALL LCMPTC(KPLIB,'ALIAS',12,HNAMIS) + CALL LCMPUT(KPLIB,'AWR',1,2,AWR) + WRITE(README(:8),'(A8)') HNAMIS(1:8) + READ(README,'(22A4)') (IHGAR(I),I=1,22) + CALL LCMPUT(KPLIB,'README',22,3,IHGAR) + GO TO 130 +*---- +* END OF MATERIAL/ISOTOPE LOOP. +*---- + 840 CONTINUE +*---- +* CLOSE MATXS FILE. +*---- +* --CLOSE CCCC FILE-- + IF(ILIBIN.EQ.2) THEN + CALL XDRCLS(NIN) + ELSE IF(ILIBIN.EQ.3) THEN + CALL LIBCLS() + ENDIF +* ------------------- + IER=KDRCLS(NIN,1) + IF(IER.LT.0) THEN + WRITE (HSMG,'(37HLIBTR2: UNABLE TO CLOSE LIBRARY FILE ,A,1H. + 1 )') NAMFIL + CALL XABORT(HSMG) + ENDIF +*---- +* CHECK IF ALL NBISO ISOTOPES HAVE BEEN PROCESSED. +*---- + NISOT=0 + DO 860 IMT=1,NBISO + IF(MASKI(IMT)) THEN + IF(IPR(IMT).EQ.0) THEN + WRITE (IOUT,930) (ISONAM(ITC,IMT),ITC=1,3),NAMFIL + NISOT=NISOT+1 + ENDIF + ENDIF + 860 CONTINUE + IF(NISOT.GT.0) CALL XABORT('LIBTR2: MISSING ISOTOPES') +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SCAT,SIGS,HNPART,C2PART,NGPART) + DEALLOCATE(LOGIED) + DEALLOCATE(XSMAT,GAR,VECT,FLUX,TOTAL,SIGF,CHI,SAVE,SFIS) + DEALLOCATE(ITYPRO,IPR) + RETURN +* + 870 FORMAT(/31H LIBTR2: PROCESSING SUBMATERIAL,I5,5X,12HINCIDENT PAR, + 1 6HTICLE=,A1,3H-->,A1,5X,10HDATA TYPE=,A6,5X,9HMATERIAL=,A6) + 880 FORMAT(/52H AVAILABLE IDENTIFIERS OF REACTION VECTORS FOR TYPE , + 1 A6,14H AND MATERIAL ,A6,1H:/(1X,18A7)) + 890 FORMAT(/9H PROCESS ,A6,10H REACTION ,A6) + 900 FORMAT(/53H AVAILABLE IDENTIFIERS OF REACTION MATRICES FOR TYPE , + 1 A6,14H AND MATERIAL ,A6,1H:/(1X,18A7)) + 920 FORMAT(/33H PROCESSING MATXS2 LIBRARY NAMED ,A,1H.) + 930 FORMAT(/27H LIBTR2: MATERIAL/ISOTOPE ',3A4,16H' IS MISSING ON , + 1 16HMATXS FILE NAME ,A,1H.) + 940 FORMAT(/40H L-J NORMALIZATION FACTORS FOR MATERIAL ,A12) + 950 FORMAT(/19H FLUX FOR MATERIAL ,A12,7H SUM=,1P,E12.5) + 960 FORMAT(1X,1P,10E12.4) + 970 FORMAT(/17H MATXS2 FILE ID: ,3A8,6H VERS ,I2) + 980 FORMAT(35HLIBTR2: DNORM MISSING FOR MATERIAL ,A6,1H.) + END diff --git a/Dragon/src/LIBWD4.f b/Dragon/src/LIBWD4.f new file mode 100644 index 0000000..4262efa --- /dev/null +++ b/Dragon/src/LIBWD4.f @@ -0,0 +1,788 @@ +*DECK LIBWD4 + SUBROUTINE LIBWD4(IPLIB,IPRINT,NAMFIL,NGROUP,NBISO,NL,ISONAM, + > ISONRF,IPISO,ISHINA,TN,SN,SB,MASKI,NGF,NGFR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transcription of the interpolated microscopic xs read from a +* microscopic xs library in WIMS-D4 format to LCM data structures. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPLIB pointer to the internal library. +* IPRINT print flag. +* NAMFIL WIMS-D4 library file name. +* NGROUP number of groups. +* NBISO number of isotopes. +* NL number of Legendre scattering order: +* =1 isotropic; +* =2 linearly anisotropic; +* etc. +* ISONAM local isotope names. +* ISONRF library isotope names. +* IPISO pointer array towards microlib isotopes. +* ISHINA self-shielding isotope names. +* TN isotope tempterature. +* SN dilution xs. +* SB Livolant-Jeanpierre dilution xs. +* MASKI logical mask for processing isotope. +* +*Parameters: output +* NGF number of fast groups without self-shielding. +* NGFR number of fast and resonance groups. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB,IPISO(NBISO) + INTEGER NDPROC + PARAMETER (NDPROC=10) + INTEGER IPRINT,NGROUP,NBISO,NL,ISONAM(3,NBISO),ISONRF(3,NBISO), + > ISHINA(3,NBISO),NGF,NGFR + CHARACTER NAMFIL*8,NAMDXS(NDPROC)*6 + LOGICAL MASKI(NBISO) + REAL TN(NBISO),SN(NGROUP,NBISO),SB(NGROUP,NBISO) +*---- +* FUNCTIONS +*---- + DOUBLE PRECISION XDRCST +*---- +* INTERNAL PARAMETERS +*---- + INTEGER IOUT,ITLIB,MAXTEM,MAXDIL,NOTX + REAL CONVM + PARAMETER (IOUT=6,ITLIB=2,MAXTEM=20,MAXDIL=20,NOTX=-1) + TYPE(C_PTR) KPLIB + CHARACTER NAMSBR*6 + PARAMETER (NAMSBR='LIBWD4') +*---- +* LOCAL VARIABLES +*---- + CHARACTER HNAMIS*12,HSHIR*8 + REAL TMPT(MAXTEM),DILT(MAXDIL),REST(MAXDIL*MAXTEM),XSCOR(4) + DOUBLE PRECISION TERP(MAXTEM) + INTEGER IP1,NPROC,IUNIT,KDROPN,II,NEL,NGR,NGTHER,MXSCT,IENDF, + > ITC,IEL,JEL,JSO,NGX,IG,JC,NRTOT,IELRT,NFIS,NISOR,NSCT, + > IT,ILOCX,ILOCY,ILOCS,NRDT,ITXS,IACT,NSRES,IDRES,ILCR, + > IXRES,IRES,NTYP,IGF,IGRF,IGR,ITYP,NTMPR,NDILR,ITT,IGRL, + > IG1,ISETP1,JG,NBAC,IERR,KDRCLS,IP0 + REAL ENDR,XX,RIND,XIND,XRS1 +*---- +* WIMS-D4 LIBRARY PARAMETERS +* IUTYPE type of file = 2 (binary) +* LRIND lenght record on da file = 0 +* IACTO open action = 2 (read only) +* IACTC close action = 2 (keep) +* MAXISO maximum number of isotopes = 246 +* LPZ length of Wims parameter array = 8 +* NSETP1 number of p1 scattering sets = 4 +* NPZ list of main parameters +* IWISO id of isotope +* IDIEL isotopic id +* IZ isotopic charge +* NF number fission +* NR number resonance +*---- + INTEGER IUTYPE,LRIND,IACTO,IACTC,MAXISO,LPZ,NSETP1 + PARAMETER (IUTYPE=2,LRIND=0,IACTO=2,IACTC=1,MAXISO=246, + > LPZ=8,NSETP1=4) + CHARACTER CWISO(MAXISO)*8,FMT*6 + INTEGER NPZ(LPZ),IWISO(MAXISO),IDIEL,IZ,NFIEL, + > NF(MAXISO),NTMP,NRIEL,NR(MAXISO),IDTEMP(2), + > NBATOM(NSETP1) + REAL AWR + INTEGER IPRLOC +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPRO,ISORD,NTM,NDI + REAL, ALLOCATABLE, DIMENSION(:) :: DELTA,XSSCMP,AW,ENER,TMPXS, + > TMPSC,RID,RTMP,RDIL,RESI,RRI,RIT + REAL, ALLOCATABLE, DIMENSION(:,:) :: XSREC,XSOUT,GAR,DSIGPL + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT +*---- +* DATA +*---- + SAVE NBATOM,NAMDXS + DATA NBATOM + > /1,2,16,12/ + DATA NAMDXS + > /'NTOT0 ','TRANC ','NUSIGF','NFTOT ','CHI ', + > 'NU ','NG ','N2N ','NGOLD ','NWT0 '/ +*---- +* SCRATCH STORAGE ALLOCATION +* ITYPRO cross section processed +* DELTA lethargy +* XSREC general xs vector +* SCAT complete scattering matrix SCAT(JG,IG) (from IG to JG) +* XSSCMP compress scattering for transfer +* XSOUT self shielding parameter +* ISORD local isotope flag +* AW isotope atomic weight +* GAR intermediate xs vector: +* GAR(I,1): library fission spectrum; +* GAR(I,2): potential scattering xs; +* GAR(I,3): transport xs; +* GAR(I,4): absorption xs +*---- + ALLOCATE(ITYPRO(NL),ISORD(NBISO)) + ALLOCATE(DELTA(NGROUP),XSREC(NGROUP,NDPROC+NL), + > SCAT(NGROUP,NGROUP,NL),XSSCMP(NGROUP*(NGROUP+2)), + > XSOUT(NGROUP,7),AW(NBISO),GAR(NGROUP,4)) +*---- +* OPEN WIMS-D4 LIBRARY +* READ GENERAL DIMENSIONING +*---- + IPRLOC=0 + IF(ABS(IPRINT) .GE. 100) IPRLOC=100 + CONVM=REAL(XDRCST('Neutron mass','amu')) + IP0=NDPROC+1 + IP1=NDPROC+2 + NPROC=NDPROC+NL + IUNIT=KDROPN(NAMFIL,IACTO,IUTYPE,LRIND) + IF(IUNIT.LE.0) CALL XABORT(NAMSBR//': WIMS-D4 LIBRARY '// + > NAMFIL//' CANNOT BE OPENED FOR MIXS') + IF(ABS(IPRINT) .GE. 5) THEN + WRITE(IOUT,6000) NAMSBR,NAMFIL + ENDIF + READ(IUNIT) (NPZ(II),II=1,LPZ) + IF(NPZ(2).NE.NGROUP) THEN + WRITE(IOUT,9001) NGROUP,NPZ(2) + CALL XABORT(NAMSBR//': INVALID NUMBER OF GROUPS') + ENDIF + NEL=NPZ(1) + NGF=NPZ(4) + NGR=NPZ(5) + NGTHER=NPZ(6) + NGFR=NGF+NGR + MXSCT=NGROUP*(NGROUP+2) + IF(NGFR+NGTHER.NE.NGROUP) THEN + WRITE(IOUT,9001) NGROUP,NGFR+NGTHER + CALL XABORT(NAMSBR//': INVALID NUMBER OF GROUPS') + ENDIF + IF(NEL.GT.MAXISO) THEN + WRITE(IOUT,9002) MAXISO,NEL + CALL XABORT(NAMSBR//': INVALID NUMBER OF ISOTOPES') + ENDIF + IENDF=0 + ALLOCATE(DSIGPL(NGR,NEL)) +*---- +* READ ISOTOPE ID NUMBER AND CREATE EQUIVALENT ISOTOPE NAME +* SCAN TO ASSOCIATE WIMS ISOTOPE NUMBER WITH DRAGON ISOTOPE NUMBER +* VERIFY IF ALL ISOTOPES REQUIRED ARE PRESENT +*---- + READ(IUNIT) (IWISO(ITC),ITC=1,NEL) + ISORD(:NBISO)=0 + DO 100 IEL=1,NEL + CWISO(IEL)=' ' + IF (IWISO(IEL).LT.10) THEN + WRITE(CWISO(IEL),'(I1)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.100) THEN + WRITE(CWISO(IEL),'(I2)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.1000) THEN + WRITE(CWISO(IEL),'(I3)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.10000) THEN + WRITE(CWISO(IEL),'(I4)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.100000) THEN + WRITE(CWISO(IEL),'(I5)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.1000000) THEN + WRITE(CWISO(IEL),'(I6)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.10000000) THEN + WRITE(CWISO(IEL),'(I7)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.100000000) THEN + WRITE(CWISO(IEL),'(I8)') IWISO(IEL) + ENDIF + READ(CWISO(IEL),'(2A4)') (IDTEMP(ITC),ITC=1,2) + DO 101 JSO=1,NBISO + IF(MASKI(JSO)) THEN + IF(ISONRF(1,JSO).EQ.IDTEMP(1).AND. + > ISONRF(2,JSO).EQ.IDTEMP(2)) ISORD(JSO)=IEL + ENDIF + 101 CONTINUE + 100 CONTINUE + DO 102 JSO=1,NBISO + IF(MASKI(JSO).AND.(ISORD(JSO).EQ.0)) THEN + WRITE(IOUT,9003) (ISONRF(ITC,JSO),ITC=1,3),NAMFIL + CALL XABORT(NAMSBR//': MISSING ISOTOPE') + ENDIF + 102 CONTINUE +*---- +* READ GROUP STRUCTURE +*---- + ALLOCATE(ENER(NGROUP+1)) + READ(IUNIT) (ENER(ITC),ITC=1,NGROUP+1) + IF(ENER(NGROUP+1).EQ.0.0) ENER(NGROUP+1)=1.0E-5 + CALL LCMPUT(IPLIB,'ENERGY',NGROUP+1,2,ENER) + NGX=0 + DO 103 IG=1,NGROUP + IF(NGX.EQ.0.AND.ENER(IG+1).LT.4.0) NGX=IG-1 + DELTA(IG)=LOG(ENER(IG)/ENER(IG+1)) + 103 CONTINUE + DEALLOCATE(ENER) + CALL LCMPUT(IPLIB,'DELTAU',NGROUP,2,DELTA) +*---- +* RECOVER FISSION SPECTRUM +* INITIALIZE FAST AND THERMAL GROUPS XPO AND GOLD +* ONLY RESONANCE GROUPS FOR THESE CROSS SECTIONS +* INITIALIZE XN2N +* NO SUCH REACTION FOR THIS LIBRARY +*---- + GAR(:NGROUP,1)=0.0 + READ(IUNIT) (GAR(ITC,1),ITC=1,NPZ(3)) +*---- +* READ DEPLETION CHAIN +*---- + DO 120 IEL=1,NEL + READ(IUNIT) JC + 120 CONTINUE + READ(IUNIT) ENDR +*---- +* ALLOCATE MEMORY FOR TEMPERATURE DEPENDENT XS +* AND FOR RESONANCE CALCULATION +*---- + ALLOCATE(TMPXS(NGROUP*5*MAXTEM),TMPSC(NGROUP*NGROUP*MAXTEM)) +*---- +* READ FILE +* CROSS SECTION ARE SAVED ONLY IF ISOTOPE IS USED +*---- + AW(:NBISO)=0.0 + NRTOT=0 + DO 130 IELRT=1,NEL + READ(IUNIT) IDIEL,AWR,IZ,NFIEL,NTMP,NRIEL + IF(NRIEL.GT.0) THEN + NRTOT=NRTOT+NRIEL + ENDIF + IF(NTMP.GT.MAXTEM) THEN + CALL XABORT(NAMSBR//': INVALID MAXTEM FOR P0.') + ENDIF +*---- +* LOCATE ISOTOPE IN LIST OF LIBRARY ISOTOPES IN THE CASE +* WHERE LIBRARY IS NOT COMPLETE OR THE ORDER OF ISOTOPE +* STORED IS DIFFERENT FROM THAT OF THE ISOTOPE NAMES +*---- + IEL=0 + DO 140 JEL=1,NEL + IF(IDIEL.EQ.IWISO(JEL)) THEN + IEL=JEL + NF(IEL)=NFIEL + NFIS=0 + IF(NF(IEL).GT.1) NFIS=1 + NR(IEL)=NRIEL + GO TO 145 + ENDIF + 140 CONTINUE + CALL XABORT(NAMSBR//': WIMSD4 LIBRARY INCOMPLETE') + 145 CONTINUE + NISOR=0 +*---- +* SCAN TO SEE IF ISOTOPE IS REQUIRED +*---- + DO 150 JSO=1,NBISO + IF(MASKI(JSO).AND.(ISORD(JSO).EQ.IEL)) THEN + NISOR=1 + GO TO 155 + ENDIF + 150 CONTINUE + 155 CONTINUE + IF(NISOR.EQ.0) THEN +*---- +* ISOTOPE NOT REQUIRED/SKIP RECORDS +*---- + READ(IUNIT) XX + IF(NF(IEL).GT.1) READ(IUNIT) XX + READ(IUNIT) NSCT + IF(NTMP.GT.0) THEN + READ(IUNIT) XX + DO 160 IT=1,NTMP + READ(IUNIT) XX + IF(NF(IEL).GT.1) THEN + READ(IUNIT) XX + ENDIF + READ(IUNIT) NSCT + 160 CONTINUE + ENDIF + ELSE +*---- +* ISOTOPE REQUIRED READ FAST AND/OR RESONANCE XS +*---- + XSREC(:NGROUP,:NPROC)=0.0 + XSREC(:NGROUP,9)=1.0 + READ(IUNIT) (GAR(NGF+II,2),II=1,NGR), + > (XX,II=1,NGR), + > (GAR(II,3),II=1,NGFR), + > (GAR(II,4),II=1,NGFR), + > (XX,II=1,NGR), + > (XSREC(NGF+II,9),II=1,NGR) + DSIGPL(:NGR,IEL)=0.0 + DO 180 IG=NGF+1,NGFR + DSIGPL(IG-NGF,IEL)=GAR(IG,2)*XSREC(IG,9) + 180 CONTINUE + IF(NF(IEL).GT.1) THEN + READ(IUNIT) (XSREC(II,3),II=1,NGFR), + > (XSREC(II,4),II=1,NGFR) + DO 185 IG=1,NGROUP + XSREC(IG,5)=GAR(IG,1) + 185 CONTINUE + ENDIF +*---- +* READ AND DECOMPRESS P0 SCATTERING CROSS SECTIONS +* COMPUTE P0 SCATTERING OUT OF GROUP +*---- + READ(IUNIT) NSCT,(XSSCMP(II),II=1,NSCT) + CALL LIBWSC(NGROUP,1,NGFR,NSCT,XSSCMP,SCAT(1,1,1), + > XSREC(1,IP0)) +*---- +* THERMAL XS +*---- + IF(NTMP.EQ.1) THEN + READ(IUNIT) XX + READ(IUNIT) (GAR(NGFR+II,3),II=1,NGTHER), + > (GAR(NGFR+II,4),II=1,NGTHER) + IF(NF(IEL).GT.1) THEN + READ(IUNIT) (XSREC(NGFR+II,3),II=1,NGTHER), + > (XSREC(NGFR+II,4),II=1,NGTHER) + ENDIF + READ(IUNIT) NSCT,(XSSCMP(II),II=1,NSCT) +*---- +* READ AND DECOMPRESS P0 SCATTERING CROSS SECTIONS +* COMPUTE P0 SCATTERING OUT OF GROUP +*---- + CALL LIBWSC(NGROUP,NGFR+1,NGROUP,NSCT,XSSCMP, + > SCAT(1,1,1),XSREC(1,IP0)) +*---- +* SAVE INFORMATION FOR ISOTOPES WITHOUT SELF SHIELDING DATA +*---- + DO 200 JSO=1,NBISO + IF(MASKI(JSO).AND.(ISORD(JSO).EQ.IEL)) THEN + WRITE(HNAMIS,'(3A4)') (ISONAM(ITC,JSO),ITC=1,3) + IF(ABS(IPRINT) .GE. 5) THEN + WRITE(IOUT,6001) HNAMIS + IF(ABS(IPRINT) .GE. 100) THEN + WRITE(IOUT,6200) TN(JSO) + ENDIF + ENDIF + AW(JSO)=AWR/CONVM +*---- +* BUILT TOTAL CROSS SECTION FROM INFORMATION IN XSNG WHICH IS +* CURRENTLY ABSORPTION AND SIGS WHICH IS TOTAL SCATTERING +* OUT OF GROUP +* COMPUTE REAL NG CROSS SECTION WHICH IS +* CURRENT NG (ABSORPTION)-FISSION-N2N +*---- + DO 201 IG=1,NGROUP + XSREC(IG,1)=GAR(IG,4)+XSREC(IG,IP0) + IF(NF(IEL).GT.1) THEN + XSREC(IG,7)=GAR(IG,4)-XSREC(IG,8)-XSREC(IG,4) + ELSE + XSREC(IG,7)=GAR(IG,4)-XSREC(IG,8) + ENDIF + IF(XSREC(IG,4).NE.0) THEN + XSREC(IG,6)=XSREC(IG,3)/XSREC(IG,4) + ELSE + XSREC(IG,6)=0.0 + ENDIF + 201 CONTINUE + IF(IENDF.LT.2) THEN +*---- +* COMPUTE TRANSPORT CORRECTION AND STORE IN TRAN +*---- + DO 202 IG=1,NGROUP + XSREC(IG,2)=XSREC(IG,1)-GAR(IG,3) + 202 CONTINUE + ELSE + DO 203 IG=1,NGROUP + XSREC(IG,2)=GAR(IG,3) + 203 CONTINUE + ENDIF +*---- +* SAVE ISOTOPE INFORMATION +*---- + KPLIB=IPISO(JSO) ! set JSO-th isotope + CALL LCMPTC(KPLIB,'ALIAS',12,HNAMIS) + CALL LCMPUT(KPLIB,'AWR',1,2,AW(JSO)) + CALL XDRLGS(KPLIB,1,IPRLOC,0,0,1,NGROUP, + > XSREC(1,IP0),SCAT,ITYPRO) + CALL XDRLXS(KPLIB,1,IPRLOC,NDPROC,NAMDXS,1,NGROUP,XSREC) + ENDIF + 200 CONTINUE + ELSE IF(NTMP.GT.1) THEN +*---- +* READ TEMPERATURE DEPENDENT XS +*---- + READ(IUNIT) (TMPT(II),II=1,NTMP) + ILOCX=0 + ILOCY=NGFR + ILOCS=0 + NRDT=NGTHER-1 + DO 210 IT=1,NTMP + READ(IUNIT) (TMPXS(ILOCY+II+1),II=0,NRDT), + > (TMPXS(ILOCY+II+NGROUP+1),II=0,NRDT) + IF(NF(IEL).GT.1) THEN + READ(IUNIT) (TMPXS(ILOCY+II+2*NGROUP+1),II=0,NRDT), + > (TMPXS(ILOCY+II+3*NGROUP+1),II=0,NRDT) + ENDIF + READ(IUNIT) NSCT,(XSSCMP(II),II=1,NSCT) +*---- +* READ AND DECOMPRESS P0 SCATTERING CROSS SECTIONS +* COMPUTE P0 SCATTERING OUT OF GROUP +* COMPUTE TOTAL XS +*---- + CALL LIBWSC(NGROUP,NGFR+1,NGROUP,NSCT,XSSCMP, + > TMPSC(ILOCS+1),TMPXS(ILOCX+4*NGROUP+1)) + ILOCX=ILOCX+5*NGROUP + ILOCY=ILOCY+5*NGROUP + ILOCS=ILOCS+NGROUP*NGROUP + 210 CONTINUE +*---- +* SAVE INFORMATION FOR ISOTOPES +* NO SELF SHIELDING +*---- + DO 220 JSO=1,NBISO + IF(MASKI(JSO).AND.(ISORD(JSO).EQ.IEL)) THEN + WRITE(HNAMIS,'(3A4)') (ISONAM(ITC,JSO),ITC=1,3) + IF(ABS(IPRINT) .GE. 5) WRITE(IOUT,6001) HNAMIS + AW(JSO)=AWR/CONVM +*---- +* FIND TEMPERATURE INTERPOLATION COEFFICIENTS +* INTERPOLATE IN TEMPERATURE +*---- + CALL LIBLEX(NTMP,TN(JSO),TMPT,NOTX,TERP) + IF(ABS(IPRINT) .GE. 100) THEN + WRITE(IOUT,6201) TN(JSO) + WRITE(IOUT,6202) (TMPT(ITC),ITC=1,NTMP) + WRITE(IOUT,6203) (TERP(ITC),ITC=1,NTMP) + ENDIF + ITXS=1 + IACT=1 + CALL LIBWTE(IACT,ITXS,NGROUP,NGTHER,NTMP,NF(IEL),TERP, + > SCAT,XSREC(1,IP0),GAR(1,4),XSREC(1,3), + > XSREC(1,4),GAR(1,3),TMPXS,TMPSC) +*---- +* BUILT TOTAL CROSS SECTION FROM INFORMATION IN XSNG WHICH IS +* CURRENTLY ABSORPTION AND SIGS WHICH IS TOTAL SCATTERING +* OUT OF GROUP +* COMPUTE REAL NG CROSS SECTION WHICH IS +* CURRENT NG (ABSORPTION)-FISSION-N2N +*---- + DO 221 IG=1,NGROUP + XSREC(IG,1)=GAR(IG,4)+XSREC(IG,IP0) + IF(NF(IEL).GT.1) THEN + XSREC(IG,7)=GAR(IG,4)-XSREC(IG,8)-XSREC(IG,4) + ELSE + XSREC(IG,7)=GAR(IG,4)-XSREC(IG,8) + ENDIF + IF(XSREC(IG,4).NE.0) THEN + XSREC(IG,6)=XSREC(IG,3)/XSREC(IG,4) + ELSE + XSREC(IG,6)=0.0 + ENDIF + 221 CONTINUE + IF(IENDF.LT.2) THEN +*---- +* COMPUTE TRANSPORT CORRECTION AND STORE IN TRAN +*---- + DO 222 IG=1,NGROUP + XSREC(IG,2)=XSREC(IG,1)-GAR(IG,3) + 222 CONTINUE + ELSE + DO 223 IG=1,NGROUP + XSREC(IG,2)=GAR(IG,3) + 223 CONTINUE + ENDIF +*---- +* SAVE ISOTOPE INFORMATION +*---- + KPLIB=IPISO(JSO) ! set JSO-th isotope + CALL LCMPTC(KPLIB,'ALIAS',12,HNAMIS) + CALL LCMPUT(KPLIB,'AWR',1,2,AW(JSO)) + CALL XDRLGS(KPLIB,1,IPRLOC,0,0,1,NGROUP, + > XSREC(1,IP0),SCAT,ITYPRO) + CALL XDRLXS(KPLIB,1,IPRLOC,NDPROC,NAMDXS,1,NGROUP,XSREC) + ENDIF + 220 CONTINUE + ENDIF + ENDIF + READ(IUNIT) ENDR + 130 CONTINUE +*---- +* RELEASE MEMORY FOR TEMPERATURE DEPENDENT XS +*---- + DEALLOCATE(TMPSC,TMPXS) +*---- +* ALLOCATE MEMORY FOR RESONANCE READ +* READ ALL GROUP AND ALL RESONANCES +*---- + NTYP=2 + ALLOCATE(NTM(NTYP*NRTOT*NGR),NDI(NTYP*NRTOT*NGR)) + ALLOCATE(RID(NRTOT),RTMP(MAXTEM*NTYP*NRTOT*NGR), + > RDIL(MAXDIL*NTYP*NRTOT*NGR),RESI(MAXDIL*MAXTEM*NTYP*NRTOT*NGR)) + NTM(:NTYP*NRTOT*NGR)=0 + NDI(:NTYP*NRTOT*NGR)=0 + RID(:NRTOT)=0.0 + RTMP(:MAXTEM*NTYP*NRTOT*NGR)=0.0 + RDIL(:MAXDIL*NTYP*NRTOT*NGR)=0.0 + RESI(:MAXDIL*MAXTEM*NTYP*NRTOT*NGR)=0.0 + CALL LIBWRG(IUNIT,NTYP,NGR,NRTOT,MAXTEM,MAXDIL,NSRES,RID,NTM, + > NDI,RTMP,RDIL,RESI) +*---- +* ALLOCATE MEMORY FOR RESONANCE PROCESSING +*---- + ALLOCATE(RRI(MAXDIL*MAXTEM*2),RIT(MAXDIL)) +*---- +* PROCESS RESONANCES +*---- + IF(ABS(IPRINT) .GE. 5) WRITE(IOUT,6010) + DO 230 JSO=1,NBISO + IF(.NOT.MASKI(JSO)) GO TO 235 + IEL=ISORD(JSO) + IF(IEL.EQ.0) CALL XABORT(NAMSBR//': INVALID VALUE OF ISORD') + IF(NR(IEL).EQ.0) GO TO 235 + NFIS=0 + IF(NF(IEL).GT.1) NFIS=1 + WRITE(HNAMIS,'(3A4)') (ISONAM(ITC,JSO),ITC=1,3) + KPLIB=IPISO(JSO) ! set JSO-th isotope + WRITE(HSHIR,'(2A4)') (ISHINA(ITC,JSO),ITC=1,2) + IDRES=INDEX(HSHIR,'.') + IF(IDRES.GT.0) THEN + WRITE(FMT,'(2H(F,I1,3H.1))') IDRES+1 + READ(HSHIR,FMT) RIND + ELSE + RIND=FLOAT(IWISO(IEL)) + ENDIF +*---- +* IDENTIFY RESONANCE SET +* DEFAULF IS RESONNANCE ID SPECIFIED OR FIRST SET ENCOUNTERED +*---- + ILCR=0 + DO 231 IXRES=1,NSRES + XIND=RID(ILCR+1) + IF(IDRES.EQ.0) THEN + XRS1=FLOAT(INT((XIND+0.01)*10.)-INT(XIND+0.01)*10)/10. + XRS1=ABS(XIND-XRS1-RIND) + ELSE + XRS1=ABS(XIND-RIND) + ENDIF + IF(XRS1.LE.0.01) THEN + IRES=IXRES + GO TO 236 + ENDIF + ILCR=ILCR+1 + 231 CONTINUE +*---- +* START MODIFICATION: 98/05/05 (G.M.) +* 1) NO SPECIFIC RESONNANCE ID SPECIFIED AND +* NO RESONNANCE ID FOUND WITH ADEQUATE IWISO +* EVEN IF NR(IEL) > 0 +* ASSUME NO RESONANCE PRESENT +* REQUIRED FOR ANL 69 GROUPS WIMSD4 LIBRARY +* ISOTOPE '10' HAS NRES=1 BUT ID DIFFERENT +* FROM 10.X WHERE x IS AN INTEGER +* 2) CORRECT ERROR IN LOOP INDEX FOR +* WRITE(IOUT,9004) +*---- + IF(IDRES.EQ.0) GO TO 235 + WRITE(IOUT,9004) (ISONAM(ITC,JSO),ITC=1,3),RIND +*---- +* END MODIFICATION: G.M. (98/05/05) +*---- + CALL XABORT(NAMSBR//': UNABLE TO IDENTIFY RESONANCE SET '// + > 'FOR THIS ISOTOPE') + 236 CONTINUE +*---- +* THIS ISOTOPE NEEDS TO BE CORRECTED FOR SELF SHIELDING +* FIRST READ UNCORRECTED CROSS SECTIONS +*---- + NTYP=2 + XSCOR(1)=0.0 + XSCOR(2)=0.0 + XSCOR(3)=0.0 + XSCOR(4)=0.0 + IF(ABS(IPRINT) .GE. 5) WRITE(IOUT,6011) HNAMIS,XIND,TN(JSO) + CALL XDRLGS(KPLIB,-1,0,0,0,1,NGROUP,XSREC(1,IP0),SCAT, ITYPRO) + CALL XDRLXS(KPLIB,-1,0,NDPROC,NAMDXS,1,NGROUP,XSREC) +*---- +* SCAN RESONAMCE GROUPS AND CORRECT CROSS SECTIONS +*---- + DO 232 IGF=1,NGFR + XSOUT(IGF,3)=XSREC(IGF,IP0) + XSOUT(IGF,4)=1.0 + XSOUT(IGF,5)=1.0 + 232 CONTINUE + IGRF=NGF + DO 240 IGR=1,NGR + IGRF=IGRF+1 +*---- +* PREPARE VECTORS FOR SELF SHIELDING +*---- + IF(ABS(IPRINT) .GE. 100) THEN + WRITE(IOUT,6004) IGRF,SN(IGRF,JSO),DSIGPL(IGR,IEL) + ENDIF + DO 250 ITYP=1,NTYP + IF((ITYP.EQ.2).AND.(NF(IEL).NE.3)) GO TO 250 + CALL LIBWRP(IPRINT,NTYP,NGR,NRTOT,MAXTEM,MAXDIL,IGR,IRES, + > ITYP,DSIGPL(IGR,IEL),NTM,NDI,RTMP,RDIL,RESI, + > NTMPR,NDILR,TMPT,DILT,REST) + IF(NDILR.GT.0.AND.NTMPR.GT.0) THEN + CALL LIBWRI(NTMPR,NDILR,TN(JSO),SN(IGRF,JSO),TMPT,DILT, + > REST,RIT,XSOUT(IGRF,ITYP),XSCOR(ITYP)) + IF(ABS(IPRINT) .GE. 100) THEN + IF(ITYP.EQ.1) THEN + WRITE(IOUT,6002) 'absorption ' + ELSE IF(ITYP.EQ.2) THEN + WRITE(IOUT,6002) 'fission ' + ELSE IF(ITYP.EQ.3) THEN + WRITE(IOUT,6002) 'scattering ' + ENDIF + WRITE(IOUT,6003) (REST(ITT),ITT=1,NTMPR*NDILR) + IF(ITYP.EQ.1) THEN + WRITE(IOUT,6005) XSOUT(IGRF,ITYP) + ELSE IF(ITYP.EQ.2) THEN + WRITE(IOUT,6006) XSOUT(IGRF,ITYP) + ELSE IF(ITYP.EQ.3) THEN + WRITE(IOUT,6007) XSOUT(IGRF,ITYP) + ENDIF + ENDIF + ENDIF + 250 CONTINUE + 240 CONTINUE +*---- +* CORRECT CROSS SECTIONS FOR ALL RESONANCE GROUPS +*---- + IGRF=NGF+1 + IGRL=NGF+NGR + IF(NF(IEL).NE.3) NTYP=1 + CALL LIBWRE(NTYP,IPRINT,ITLIB,NGROUP,1,IGRF,IGRL,NGR, + > SCAT,XSREC(1,IP0),XSREC(1,1),XSREC(1,7), + > XSREC(1,3),XSREC(1,4),XSREC(1,6), + > DELTA,SN(1,JSO),SB(1,JSO),XSOUT,XSCOR, + > DSIGPL(1,IEL)) +*---- +* PRINT CROSS SECTIONS IF REQUIRED +*---- + IF(ABS(IPRINT) .GE. 5) THEN + WRITE(IOUT,6100) HNAMIS + DO 233 IG1=NGF+1,NGFR + WRITE(IOUT,6101) IG1,SN(IG1,JSO),SB(IG1,JSO), + > XSOUT(IG1,4),XSREC(IG1,1), + > XSREC(IG1,IP0),XSREC(IG1,3),XSREC(IG1,9) + 233 CONTINUE + ENDIF +*---- +* SET NWT0 THE RESONANCE FLUX WEIGHTING +*---- + XSREC(:NGROUP,10)=1.0 + DO 234 IG1=NGF+1,NGFR + XSREC(IG1,10)=XSOUT(IG1,4) + 234 CONTINUE +*---- +* SAVE SELF-SHIELDED XS +*---- + CALL XDRLGS(KPLIB,1,0,0,0,1,NGROUP,XSREC(1,IP0),SCAT, ITYPRO) + CALL XDRLXS(KPLIB,1,0,NDPROC,NAMDXS,1,NGROUP,XSREC) + 235 CONTINUE + 230 CONTINUE +*---- +* RELEASE MEMORY FOR RESONANCE PROCESSING +*---- + DEALLOCATE(RIT,RRI,RID) +*---- +* RELEASE MEMORY FOR RESONANCE READ +*---- + DEALLOCATE(RESI,RDIL,RTMP) + DEALLOCATE(NDI,NTM) +*---- +* P1 SCATTERING +*---- + IF(NL.GE.2) THEN + DO 260 ISETP1=1,NSETP1 + DO 270 IG=1,NGROUP + XSREC(IG,IP1)=0.0 + READ(IUNIT,END=300) (SCAT(JG,IG,2),JG=1,NGROUP) + DO 280 JG=1,NGROUP + XSREC(IG,IP1)=XSREC(IG,IP1)+SCAT(JG,IG,2) + 280 CONTINUE + 270 CONTINUE + DO 290 JSO=1,NBISO + NBAC=INT(AW(JSO)*CONVM+0.01) + IF(NBAC.EQ.NBATOM(ISETP1)) THEN +*---- +* CLASSIFY BY ATOMIC NUMBER +*---- + WRITE(HNAMIS,'(3A4)') (ISONAM(ITC,JSO),ITC=1,3) + IF(IPRINT.GT.5) WRITE(IOUT,6300) HNAMIS + KPLIB=IPISO(JSO) ! set JSO-th isotope + CALL XDRLGS(KPLIB,-1,0,0,0,1,NGROUP,XSREC(1,IP0), + > SCAT,ITYPRO) + CALL XDRLGS(KPLIB,1,0,0,NL-1,1,NGROUP,XSREC(1,IP0), + > SCAT,ITYPRO) + ENDIF + 290 CONTINUE + 260 CONTINUE + ENDIF + 300 IERR=KDRCLS(IUNIT,IACTC) + IF(IERR.LT.0) + > CALL XABORT(NAMSBR//': WIMS-D4 LIBRARY '// + > NAMFIL//' CANNOT BE CLOSED') + IF(ABS(IPRINT) .GE. 5) THEN + WRITE(IOUT,6009) NAMSBR + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(DSIGPL) + DEALLOCATE(GAR,AW,XSOUT,XSSCMP,SCAT,XSREC,DELTA) + DEALLOCATE(ISORD,ITYPRO) +*---- +* RETURN +*---- + RETURN +*---- +* FORMAT +*---- + 9001 FORMAT(/' NUMBER OF GROUPS SPECIFIED :',I10/ + > ' NUMBER OF GROUPS IN LIBRARY :',I10) + 9002 FORMAT(/' MAXIMUM NUMBER OF ISOTOPE SPECIFIED :',I10/ + > ' NUMBER OF ISOTOPE IN LIBRARY :',I10) + 9003 FORMAT(/' LIBWD4: MATERIAL/ISOTOPE ',3A4, + > ' IS MISSING ON WIMS-D4 FILE ',A8) + 9004 FORMAT(/' LIBWD4: FOR ISOTOPE ',3A4, + > ' SELF-SHIELDING ISOTOPE ',F8.1,' NOT AVAILABLE') + 6000 FORMAT('(* Output from --',A6,'-- follows '// + > ' READING WIMS-D4 LIBRARY NAME ',A8) + 6001 FORMAT(' PROCESSING ISOTOPE/MATERIAL = ',A12) + 6002 FORMAT(' Resonance integral tabulation for ',A12) + 6003 FORMAT(1P,5E15.7) + 6004 FORMAT(' Processing GROUP = ', I10,' at dilutions = ', + > 1P,2E15.7) + 6005 FORMAT(' Interpolated absorption rate = ',1P,E15.7) + 6006 FORMAT(' Interpolated fission rate = ',1P,E15.7) + 6007 FORMAT(' Interpolated scattering rate = ',1P,E15.7) + 6009 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(' RESONANCE IDENTIFICATION') + 6011 FORMAT(' ISOTOPE ID = ',A12,' RESONANCE ID = ',F8.1, + > ' at temperature = ',F10.5) + 6100 FORMAT(' SELF SHIELDING PROPERTIES FOR ISOTOPE =',A12/ + > 5X,'GROUP',10X,'DILUT',13X,'SB',11X,'NPHI',10X,'NTOT0', + > 11X,'SIGS',9X,'NUSIGF',10X,'NGOLD') + 6101 FORMAT(5X,I5,1P,8E15.5) + 6200 FORMAT(' TEMPERATURE = ',F10.5,10X, + > ' CROSS SECTION TABULATED AT A SINGLE TEMPERATURE') + 6201 FORMAT(' TEMPERATURE = ',F10.5,10X, + > ' CROSS SECTION TABULATED AT MULTIPLE TEMPERATURES') + 6202 FORMAT(' TABULATION TEMPERATURES= ',/(5F15.5)) + 6203 FORMAT(' INTERPOLATION FACTORS = ',1P,/(5E15.5)) + 6300 FORMAT(' P1 SCATTERING CROSS SECTION FOUND FOR =',A12) + END diff --git a/Dragon/src/LIBWE.f b/Dragon/src/LIBWE.f new file mode 100644 index 0000000..b37f331 --- /dev/null +++ b/Dragon/src/LIBWE.f @@ -0,0 +1,789 @@ +*DECK LIBWE + SUBROUTINE LIBWE(IPLIB,IPRINT,NAMFIL,NGROUP,NBISO,NL,ISONAM, + > ISONRF,IPISO,ISHINA,TN,SN,SB,MASKI,NGF,NGFR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transcription of the interpolated microscopic xs read from a +* microscopic xs library in WIMS-E format to LCM data structures. +* +*Copyright: +* Copyright (C) 2016 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert and G. Marleau +* +*Parameters: input +* IPLIB pointer to the internal library. +* IPRINT print flag. +* NAMFIL WIMS-E library file name. +* NGROUP number of groups. +* NBISO number of isotopes. +* NL number of Legendre scattering order: +* =1 isotropic; +* =2 linearly anisotropic; +* etc. +* ISONAM local isotope names. +* ISONRF library isotope names. +* IPISO pointer array towards microlib isotopes. +* ISHINA self-shielding isotope names. +* TN isotope tempterature. +* SN dilution xs. +* SB Livolant-Jeanpierre dilution xs. +* MASKI logical mask for processing isotope. +* +*Parameters: output +* NGF number of fast groups without self-shielding. +* NGFR number of fast and resonance groups. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB,IPISO(NBISO) + INTEGER NDPROC + PARAMETER (NDPROC=10) + INTEGER IPRINT,NGROUP,NBISO,NL,ISONAM(3,NBISO),ISONRF(3,NBISO), + > ISHINA(3,NBISO),NGF,NGFR + CHARACTER NAMFIL*8,NAMDXS(NDPROC)*6 + LOGICAL MASKI(NBISO) + REAL TN(NBISO),SN(NGROUP,NBISO),SB(NGROUP,NBISO) +*---- +* FUNCTIONS +*---- + DOUBLE PRECISION XDRCST +*---- +* INTERNAL PARAMETERS +*---- + INTEGER IOUT,ITLIB,MAXTEM,MAXDIL,NOTX + REAL CONVM + PARAMETER (IOUT=6,ITLIB=2,MAXTEM=20,MAXDIL=20,NOTX=-1) + TYPE(C_PTR) KPLIB + CHARACTER NAMSBR*6 + PARAMETER (NAMSBR='LIBWE') +*---- +* LOCAL VARIABLES +*---- + CHARACTER HNAMIS*12,HSHIR*8 + REAL TMPT(MAXTEM),DILT(MAXDIL),REST(MAXDIL*MAXTEM),XSCOR(4) + DOUBLE PRECISION TERP(MAXTEM) + INTEGER IP1,IUNIT,KDROPN,II,NEL,NGR,NGTHER,MXSCT,IENDF,ITC, + > IEL,JEL,JSO,NGX,IG,JC,NRTOT,IELRT,NFIS,NISOR,NSCT,IT, + > ILOCX,ILOCY,ILOCS,NRDT,ITXS,IACT,NSRES,IDRES,ILCR, + > IXRES,IRES,NTYP,IGF,IGRF,IGR,ITYP,NTMPR,NDILR,ITT, + > IGRL,IG1,IERR,KDRCLS,IP0,ISOF,IP1OPT,ITYP0,MAXLEG + REAL XX,RIND,XIND,XRS1 +*---- +* WIMS-E LIBRARY PARAMETERS +* IUTYPE type of file = 2 (binary) +* LRIND lenght record on da file = 0 +* IACTO open action = 2 (read only) +* IACTC close action = 2 (keep) +* MAXISO maximum number of isotopes = 246 +* LPZ length of Wims parameter array = 8 +* NSETP1 number of p1 scattering sets = 4 +* NPZ list of main parameters +* IWISO id of isotope +* IDIEL isotopic id +* IZ isotopic charge +* NF number fission +* NR number resonance +*---- + INTEGER IUTYPE,LRIND,IACTO,IACTC,MAXISO,LPZ,NSETP1 + PARAMETER (IUTYPE=2,LRIND=0,IACTO=2,IACTC=1,MAXISO=246, + > LPZ=8,NSETP1=4) + CHARACTER CWISO(MAXISO)*8,FMT*6 + INTEGER NPZ(LPZ),IWISO(MAXISO),IDIEL,IZ,NFIEL, + > NF(MAXISO),NTMP,NRIEL,NR(MAXISO),IDTEMP(2) + REAL AWR + INTEGER IPRLOC +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPRO,ISORD,NTM,NDI + REAL, ALLOCATABLE, DIMENSION(:) :: DELTA,XSSCMP,AW,ENER,TMPXS0, + > TMPSC0,TMPXS1,TMPSC1,RID,RTMP,RDIL,RESI,RRI,RIT + REAL, ALLOCATABLE, DIMENSION(:,:) :: XSREC,XSOUT,GAR,DSIGPL + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT +*---- +* DATA +*---- + SAVE NAMDXS + DATA NAMDXS + > /'NTOT0 ','TRANC ','NUSIGF','NFTOT ','CHI ', + > 'NU ','NG ','N2N ','NGOLD ','NWT0 '/ +*---- +* SCRATCH STORAGE ALLOCATION +* ITYPRO cross section processed +* DELTA lethargy +* XSREC general xs vector +* SCAT complete scattering matrix SCAT(JG,IG) (from IG to JG) +* XSSCMP compress scattering for transfer +* XSOUT self shielding parameter +* ISORD local isotope flag +* AW isotope atomic weight +* GAR intermediate xs vector: +* GAR(I,1): fission spectrum; +* GAR(I,2): potential scattering xs; +* GAR(I,3): transport xs; +* GAR(I,4): absorption xs +* GAR(I,5): n2n xs +*---- + ALLOCATE(ITYPRO(NL),ISORD(NBISO)) + ALLOCATE(DELTA(NGROUP),XSREC(NGROUP,NDPROC+NL), + > SCAT(NGROUP,NGROUP,NL),XSSCMP(NGROUP*(NGROUP+2)), + > XSOUT(NGROUP,7),AW(NBISO),GAR(NGROUP,5)) +*---- +* OPEN WIMS-E LIBRARY +* READ GENERAL DIMENSIONING +*---- + IPRLOC=0 + IF(ABS(IPRINT).GE.100) IPRLOC=100 + CONVM=REAL(XDRCST('Neutron mass','amu')) + IP0=NDPROC+1 + IP1=NDPROC+2 + IUNIT=KDROPN(NAMFIL,IACTO,IUTYPE,LRIND) + IF(IUNIT.LE.0) CALL XABORT(NAMSBR//': WIMS-E LIBRARY '// + > NAMFIL//' CANNOT BE OPENED FOR MIXS') + IF(ABS(IPRINT).GE.5) THEN + WRITE(IOUT,6000) NAMSBR,NAMFIL + ENDIF + READ(IUNIT) (NPZ(II),II=1,LPZ) + IF(NPZ(2).NE.NGROUP) THEN + WRITE(IOUT,9001) NGROUP,NPZ(2) + CALL XABORT(NAMSBR//': INVALID NUMBER OF GROUPS') + ENDIF + NEL=NPZ(1) + NGF=NPZ(4) + NGR=NPZ(5) + NGTHER=NPZ(6) + NGFR=NGF+NGR + MXSCT=NGROUP*(NGROUP+2) + IF(NGFR+NGTHER.NE.NGROUP) THEN + WRITE(IOUT,9001) NGROUP,NGFR+NGTHER + CALL XABORT(NAMSBR//': INVALID NUMBER OF GROUPS') + ENDIF + IF(NEL.GT.MAXISO) THEN + WRITE(IOUT,9002) MAXISO,NEL + CALL XABORT(NAMSBR//': INVALID NUMBER OF ISOTOPES') + ENDIF + IENDF=0 + ALLOCATE(DSIGPL(NGR,NEL)) +*---- +* READ ISOTOPE ID NUMBER AND CREATE EQUIVALENT ISOTOPE NAME +* SCAN TO ASSOCIATE WIMS ISOTOPE NUMBER WITH DRAGON ISOTOPE NUMBER +* VERIFY IF ALL ISOTOPES REQUIRED ARE PRESENT +*---- + READ(IUNIT) (IWISO(ITC),ITC=1,NEL) + ISORD(:NBISO)=0 + DO 100 IEL=1,NEL + CWISO(IEL)=' ' + IF (IWISO(IEL).LT.10) THEN + WRITE(CWISO(IEL),'(I1)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.100) THEN + WRITE(CWISO(IEL),'(I2)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.1000) THEN + WRITE(CWISO(IEL),'(I3)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.10000) THEN + WRITE(CWISO(IEL),'(I4)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.100000) THEN + WRITE(CWISO(IEL),'(I5)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.1000000) THEN + WRITE(CWISO(IEL),'(I6)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.10000000) THEN + WRITE(CWISO(IEL),'(I7)') IWISO(IEL) + ELSE IF(IWISO(IEL).LT.100000000) THEN + WRITE(CWISO(IEL),'(I8)') IWISO(IEL) + ENDIF + READ(CWISO(IEL),'(2A4)') (IDTEMP(ITC),ITC=1,2) + DO 101 JSO=1,NBISO + IF(MASKI(JSO)) THEN + IF(ISONRF(1,JSO).EQ.IDTEMP(1).AND. + > ISONRF(2,JSO).EQ.IDTEMP(2)) ISORD(JSO)=IEL + ENDIF + 101 CONTINUE + 100 CONTINUE + DO 102 JSO=1,NBISO + IF(MASKI(JSO).AND.(ISORD(JSO).EQ.0)) THEN + WRITE(IOUT,9003) (ISONRF(ITC,JSO),ITC=1,3),NAMFIL + CALL XABORT(NAMSBR//': MISSING ISOTOPE') + ENDIF + 102 CONTINUE +*---- +* READ GROUP STRUCTURE +*---- + ALLOCATE(ENER(NGROUP+1)) + READ(IUNIT) (ENER(ITC),ITC=1,NGROUP+1) + IF(ENER(NGROUP+1).EQ.0.0) ENER(NGROUP+1)=1.0E-5 + CALL LCMPUT(IPLIB,'ENERGY',NGROUP+1,2,ENER) + NGX=0 + DO 103 IG=1,NGROUP + IF(NGX.EQ.0.AND.ENER(IG+1).LT.4.0) NGX=IG-1 + DELTA(IG)=LOG(ENER(IG)/ENER(IG+1)) + 103 CONTINUE + DEALLOCATE(ENER) + CALL LCMPUT(IPLIB,'DELTAU',NGROUP,2,DELTA) +*---- +* READ DEPLETION CHAIN +*---- + DO 120 IEL=1,NEL + READ(IUNIT) JC + 120 CONTINUE +*---- +* ALLOCATE MEMORY FOR TEMPERATURE DEPENDENT XS +* AND FOR RESONANCE CALCULATION +*---- + ALLOCATE(TMPXS0(NGROUP*5*MAXTEM),TMPSC0(NGROUP*NGROUP*MAXTEM)) + ALLOCATE(TMPXS1(NGROUP*MAXTEM),TMPSC1(NGROUP*NGROUP*MAXTEM)) +*---- +* READ FILE +* CROSS SECTION ARE SAVED ONLY IF ISOTOPE IS USED +*---- + AW(:NBISO)=0.0 + NRTOT=0 + DO 130 IELRT=1,NEL + READ(IUNIT) IDIEL,AWR,IZ,NFIEL,NTMP,NRIEL,ISOF,IP1OPT + IF(NRIEL.GT.0) THEN + NRTOT=NRTOT+NRIEL + ENDIF + IF(NTMP.GT.MAXTEM) THEN + WRITE(IOUT,9005) IDIEL,NTMP,MAXTEM + CALL XABORT(NAMSBR//': INVALID MAXTEM FOR P0 and P1.') + ENDIF +*---- +* LOCATE ISOTOPE IN LIST OF LIBRARY ISOTOPES IN THE CASE +* WHERE LIBRARY IS NOT COMPLETE OR THE ORDER OF ISOTOPE +* STORED IS DIFFERENT FROM THAT OF THE ISOTOPE NAMES +*---- + IEL=0 + DO 140 JEL=1,NEL + IF(IDIEL.EQ.IWISO(JEL)) THEN + IEL=JEL + NF(IEL)=NFIEL + NFIS=0 + IF(NF(IEL).GT.1) NFIS=1 + NR(IEL)=NRIEL + GO TO 145 + ENDIF + 140 CONTINUE + CALL XABORT(NAMSBR//': WIMSE LIBRARY INCOMPLETE') + 145 CONTINUE + NISOR=0 +*---- +* SCAN TO SEE IF ISOTOPE IS REQUIRED +*---- + DO 150 JSO=1,NBISO + IF(MASKI(JSO).AND.(ISORD(JSO).EQ.IEL)) THEN + NISOR=1 + GO TO 155 + ENDIF + 150 CONTINUE + 155 CONTINUE + IF(NISOR.EQ.0) THEN +*---- +* ISOTOPE NOT REQUIRED/SKIP RECORDS +*---- + READ(IUNIT) XX + IF(NF(IEL).GT.1) READ(IUNIT) XX + READ(IUNIT) NSCT + IF(NTMP.GT.0) THEN + READ(IUNIT) XX + DO 160 IT=1,NTMP + READ(IUNIT) XX + IF(NF(IEL).GT.1) THEN + READ(IUNIT) XX + ENDIF + READ(IUNIT) NSCT + 160 CONTINUE + IF(ISOF.NE.0) READ(IUNIT) XX + IF(IP1OPT.NE.1) THEN + DO 165 IT=1,NTMP + READ(IUNIT) XX + 165 CONTINUE + ENDIF + ENDIF + ELSE +*---- +* ISOTOPE REQUIRED READ FAST AND/OR RESONANCE XS +*---- + XSREC(:NGROUP,:NDPROC+NL)=0.0 + XSREC(:NGROUP,9)=1.0 + SCAT(:NGROUP,:NGROUP,:NL)=0.0 + GAR(:NGROUP,:5)=0.0 + READ(IUNIT) (GAR(NGF+II,2),II=1,NGR), + > (XX,II=1,NGR), + > (GAR(II,5),II=1,NGF), + > (GAR(II,3),II=1,NGFR), + > (GAR(II,4),II=1,NGFR), + > (XX,II=1,NGR), + > (XSREC(NGF+II,9),II=1,NGR) + DSIGPL(:NGR,IEL)=0.0 + DO 180 IG=NGF+1,NGFR + DSIGPL(IG-NGF,IEL)=GAR(IG,2)*XSREC(IG,9) + 180 CONTINUE + IF(NF(IEL).GT.1) THEN + READ(IUNIT) (XSREC(II,3),II=1,NGFR), + > (XSREC(II,4),II=1,NGFR) + ENDIF +*---- +* READ AND DECOMPRESS P0 SCATTERING CROSS SECTIONS +* COMPUTE P0 SCATTERING OUT OF GROUP +*---- + READ(IUNIT) NSCT,(XSSCMP(II),II=1,NSCT) + IF(NSCT.GT.NGROUP*(NGROUP+2)) + > CALL XABORT('LIBWE: XSSCMP OVERFLOW(1).') + CALL LIBWSC(NGROUP,1,NGFR,NSCT,XSSCMP,SCAT(1,1,1), + > XSREC(1,IP0)) +*---- +* THERMAL XS +*---- + IF(NTMP.EQ.1) THEN + READ(IUNIT) XX + READ(IUNIT) (GAR(NGFR+II,3),II=1,NGTHER), + > (GAR(NGFR+II,4),II=1,NGTHER) + IF(NF(IEL).GT.1) THEN + READ(IUNIT) (XSREC(NGFR+II,3),II=1,NGTHER), + > (XSREC(NGFR+II,4),II=1,NGTHER) + ENDIF + READ(IUNIT) NSCT,(XSSCMP(II),II=1,NSCT) + IF(NSCT.GT.NGROUP*(NGROUP+2)) + > CALL XABORT('LIBWE: XSSCMP OVERFLOW(2).') +*---- +* READ AND DECOMPRESS P0 SCATTERING CROSS SECTIONS +* COMPUTE P0 SCATTERING OUT OF GROUP +*---- + CALL LIBWSC(NGROUP,NGFR+1,NGROUP,NSCT,XSSCMP, + > SCAT(1,1,1),XSREC(1,IP0)) +*---- +* READ FISSION SPECTRUM +*---- + IF(ISOF.NE.0) THEN + READ(IUNIT) (GAR(ITC,1),ITC=1,NPZ(3)) + IF(NF(IEL).GT.1) THEN + DO 184 IG=1,NGROUP + XSREC(IG,5)=GAR(IG,1) + 184 CONTINUE + ENDIF + ENDIF +*---- +* READ P1 DATA +*---- + IF(IP1OPT.NE.1) THEN + READ(IUNIT) NSCT,(XSSCMP(II),II=1,NSCT) + IF(NSCT.GT.NGROUP*(NGROUP+2)) + > CALL XABORT('LIBWE: XSSCMP OVERFLOW(3).') + IF(NL.GT.1) THEN + CALL LIBWSC(NGROUP,1,NGROUP,NSCT,XSSCMP,SCAT(1,1,2), + > XSREC(1,IP1)) + ENDIF + ENDIF +*---- +* SAVE INFORMATION FOR ISOTOPES WITHOUT SELF SHIELDING DATA +*---- + DO 200 JSO=1,NBISO + IF(MASKI(JSO).AND.(ISORD(JSO).EQ.IEL)) THEN + WRITE(HNAMIS,'(3A4)') (ISONAM(ITC,JSO),ITC=1,3) + IF(ABS(IPRINT).GE.5) THEN + WRITE(IOUT,6001) HNAMIS + IF(ABS(IPRINT).GE.100) THEN + WRITE(IOUT,6200) TN(JSO) + ENDIF + ENDIF + AW(JSO)=AWR/CONVM +*---- +* BUILT TOTAL CROSS SECTION FROM INFORMATION IN XSNG WHICH IS +* CURRENTLY ABSORPTION AND SIGS WHICH IS TOTAL SCATTERING +* OUT OF GROUP +* COMPUTE REAL NG CROSS SECTION WHICH IS +* CURRENT NG (ABSORPTION)-FISSION-N2N +* COMPUTE TRANSPORT CORRECTION +*---- + DO 201 IG=1,NGROUP + XSREC(IG,1)=GAR(IG,4)+XSREC(IG,IP0) + XSREC(IG,2)=XSREC(IG,1)-GAR(IG,3) + XSREC(IG,8)=GAR(IG,5) + IF(NF(IEL).GT.1) THEN + XSREC(IG,7)=GAR(IG,4)+XSREC(IG,8)-XSREC(IG,4) + ELSE + XSREC(IG,7)=GAR(IG,4)+XSREC(IG,8) + ENDIF + IF(XSREC(IG,4).NE.0) THEN + XSREC(IG,6)=XSREC(IG,3)/XSREC(IG,4) + ELSE + XSREC(IG,6)=0.0 + ENDIF + 201 CONTINUE +*---- +* SAVE ISOTOPE INFORMATION +*---- + MAXLEG=0 + IF((IP1OPT.NE.1).AND.(NL.GT.1)) MAXLEG=1 + KPLIB=IPISO(JSO) ! set JSO-th isotope + CALL LCMPTC(KPLIB,'ALIAS',12,HNAMIS) + CALL LCMPUT(KPLIB,'AWR',1,2,AW(JSO)) + CALL XDRLGS(KPLIB,1,IPRLOC,0,MAXLEG,1,NGROUP, + > XSREC(1,IP0),SCAT,ITYPRO) + CALL XDRLXS(KPLIB,1,IPRLOC,NDPROC,NAMDXS,1,NGROUP,XSREC) + ENDIF + 200 CONTINUE + ELSE IF(NTMP.GT.1) THEN +*---- +* READ TEMPERATURE DEPENDENT XS +*---- + READ(IUNIT) (TMPT(II),II=1,NTMP) + ILOCX=0 + ILOCY=NGFR + ILOCS=0 + NRDT=NGTHER-1 + DO 210 IT=1,NTMP + READ(IUNIT) (TMPXS0(ILOCY+II+1),II=0,NRDT), + > (TMPXS0(ILOCY+II+NGROUP+1),II=0,NRDT) + IF(NF(IEL).GT.1) THEN + READ(IUNIT) (TMPXS0(ILOCY+II+2*NGROUP+1),II=0,NRDT), + > (TMPXS0(ILOCY+II+3*NGROUP+1),II=0,NRDT) + ENDIF + READ(IUNIT) NSCT,(XSSCMP(II),II=1,NSCT) + IF(NSCT.GT.NGROUP*(NGROUP+2)) + > CALL XABORT('LIBWE: XSSCMP OVERFLOW(4).') +*---- +* READ AND DECOMPRESS P0 SCATTERING CROSS SECTIONS +* COMPUTE P0 SCATTERING OUT OF GROUP +* COMPUTE TOTAL XS +*---- + CALL LIBWSC(NGROUP,NGFR+1,NGROUP,NSCT,XSSCMP, + > TMPSC0(ILOCS+1),TMPXS0(ILOCX+4*NGROUP+1)) + ILOCX=ILOCX+5*NGROUP + ILOCY=ILOCY+5*NGROUP + ILOCS=ILOCS+NGROUP*NGROUP + 210 CONTINUE +*---- +* READ FISSION SPECTRUM +*---- + IF(ISOF.NE.0) THEN + READ(IUNIT) (GAR(ITC,1),ITC=1,NPZ(3)) + IF(NF(IEL).GT.1) THEN + DO 185 IG=1,NGROUP + XSREC(IG,5)=GAR(IG,1) + 185 CONTINUE + ENDIF + ENDIF +*---- +* READ P1 DATA +*---- + IF(IP1OPT.NE.1) THEN + ILOCS=0 + ILOCX=0 + DO 215 IT=1,NTMP + READ(IUNIT) NSCT,(XSSCMP(II),II=1,NSCT) + IF(NSCT.GT.NGROUP*(NGROUP+2)) + > CALL XABORT('LIBWE: XSSCMP OVERFLOW(5).') + IF(NL.GT.1) THEN + CALL LIBWSC(NGROUP,1,NGROUP,NSCT,XSSCMP, + > TMPSC1(ILOCS+1),TMPXS1(ILOCX+1)) + ILOCS=ILOCS+NGROUP*NGROUP + ILOCX=ILOCX+NGROUP + ENDIF + 215 CONTINUE + ENDIF +*---- +* SAVE INFORMATION FOR ISOTOPES +* NO SELF SHIELDING +*---- + DO 220 JSO=1,NBISO + IF(MASKI(JSO).AND.(ISORD(JSO).EQ.IEL)) THEN + WRITE(HNAMIS,'(3A4)') (ISONAM(ITC,JSO),ITC=1,3) + IF(ABS(IPRINT).GE.5) WRITE(IOUT,6001) HNAMIS + AW(JSO)=AWR/CONVM +*---- +* FIND TEMPERATURE INTERPOLATION COEFFICIENTS +* INTERPOLATE IN TEMPERATURE +*---- + CALL LIBLEX(NTMP,TN(JSO),TMPT,NOTX,TERP) + IF(ABS(IPRINT).GE.100) THEN + WRITE(IOUT,6201) TN(JSO) + WRITE(IOUT,6202) (TMPT(ITC),ITC=1,NTMP) + WRITE(IOUT,6203) (TERP(ITC),ITC=1,NTMP) + ENDIF + ITXS=1 + IACT=1 + CALL LIBWTE(IACT,ITXS,NGROUP,NGTHER,NTMP,NF(IEL),TERP, + > SCAT,XSREC(1,IP0),GAR(1,4),XSREC(1,3), + > XSREC(1,4),GAR(1,3),TMPXS0,TMPSC0) + IF((IP1OPT.NE.1).AND.(NL.GT.1)) THEN + CALL LIBWTF(NGROUP,NTMP,TERP,SCAT(1,1,2), + > XSREC(1,IP1),TMPXS1,TMPSC1) + ENDIF +*---- +* BUILT TOTAL CROSS SECTION FROM INFORMATION IN XSNG WHICH IS +* CURRENTLY ABSORPTION AND SIGS WHICH IS TOTAL SCATTERING +* OUT OF GROUP +* COMPUTE REAL NG CROSS SECTION WHICH IS +* CURRENT NG (ABSORPTION)-FISSION-N2N +* COMPUTE TRANSPORT CORRECTION +*---- + DO 221 IG=1,NGROUP + XSREC(IG,1)=GAR(IG,4)+XSREC(IG,IP0) + XSREC(IG,2)=XSREC(IG,1)-GAR(IG,3) + XSREC(IG,8)=GAR(IG,5) + IF(NF(IEL).GT.1) THEN + XSREC(IG,7)=GAR(IG,4)+XSREC(IG,8)-XSREC(IG,4) + ELSE + XSREC(IG,7)=GAR(IG,4)+XSREC(IG,8) + ENDIF + IF(XSREC(IG,4).NE.0) THEN + XSREC(IG,6)=XSREC(IG,3)/XSREC(IG,4) + ELSE + XSREC(IG,6)=0.0 + ENDIF + 221 CONTINUE +*---- +* SAVE ISOTOPE INFORMATION +*---- + MAXLEG=0 + IF((IP1OPT.NE.1).AND.(NL.GT.1)) MAXLEG=1 + KPLIB=IPISO(JSO) ! set JSO-th isotope + CALL LCMPTC(KPLIB,'ALIAS',12,HNAMIS) + CALL LCMPUT(KPLIB,'AWR',1,2,AW(JSO)) + CALL XDRLGS(KPLIB,1,IPRLOC,0,MAXLEG,1,NGROUP, + > XSREC(1,IP0),SCAT,ITYPRO) + CALL XDRLXS(KPLIB,1,IPRLOC,NDPROC,NAMDXS,1,NGROUP,XSREC) + ENDIF + 220 CONTINUE + ENDIF + ENDIF + 130 CONTINUE +*---- +* RELEASE MEMORY FOR TEMPERATURE DEPENDENT XS +*---- + DEALLOCATE(TMPSC0,TMPXS0,TMPSC1,TMPXS1) +*---- +* ALLOCATE MEMORY FOR RESONANCE READ +* READ ALL GROUP AND ALL RESONANCES +*---- + NTYP=3 + ALLOCATE(NTM(NTYP*NRTOT*NGR),NDI(NTYP*NRTOT*NGR)) + ALLOCATE(RID(NRTOT),RTMP(MAXTEM*NTYP*NRTOT*NGR), + > RDIL(MAXDIL*NTYP*NRTOT*NGR),RESI(MAXDIL*MAXTEM*NTYP*NRTOT*NGR)) + NTM(:NTYP*NRTOT*NGR)=0 + NDI(:NTYP*NRTOT*NGR)=0 + RID(:NRTOT)=0.0 + RTMP(:MAXTEM*NTYP*NRTOT*NGR)=0.0 + RDIL(:MAXDIL*NTYP*NRTOT*NGR)=0.0 + RESI(:MAXDIL*MAXTEM*NTYP*NRTOT*NGR)=0.0 + CALL LIBWRG(IUNIT,NTYP,NGR,NRTOT,MAXTEM,MAXDIL,NSRES,RID,NTM, + > NDI,RTMP,RDIL,RESI) +*---- +* ALLOCATE MEMORY FOR RESONANCE PROCESSING +*---- + ALLOCATE(RRI(MAXDIL*MAXTEM*2),RIT(MAXDIL)) +*---- +* PROCESS RESONANCES +*---- + IF(ABS(IPRINT).GE.5) WRITE(IOUT,6010) + DO 230 JSO=1,NBISO + IF(.NOT.MASKI(JSO)) GO TO 235 + IEL=ISORD(JSO) + IF(IEL.EQ.0) CALL XABORT(NAMSBR//': INVALID VALUE OF ISORD') + IF(NR(IEL).EQ.0) GO TO 235 + NFIS=0 + IF(NF(IEL).GT.1) NFIS=1 + WRITE(HNAMIS,'(3A4)') (ISONAM(ITC,JSO),ITC=1,3) + KPLIB=IPISO(JSO) ! set JSO-th isotope + WRITE(HSHIR,'(2A4)') (ISHINA(ITC,JSO),ITC=1,2) + IDRES=INDEX(HSHIR,'.') + IF(IDRES.GT.0) THEN + WRITE(FMT,'(2H(F,I1,3H.1))') IDRES+1 + READ(HSHIR,FMT) RIND + ELSE + RIND=FLOAT(IWISO(IEL)) + ENDIF +*---- +* IDENTIFY RESONANCE SET +* DEFAULT IS RESONNANCE ID SPECIFIED OR FIRST SET ENCOUNTERED +*---- + ILCR=0 + DO 231 IXRES=1,NSRES + XIND=RID(ILCR+1) + IF(IDRES.EQ.0) THEN + XRS1=FLOAT(INT((XIND+0.01)*10.)-INT(XIND+0.01)*10)/10. + XRS1=ABS(XIND-XRS1-RIND) + ELSE + XRS1=ABS(XIND-RIND) + ENDIF + IF(XRS1.LE.0.01) THEN + IRES=IXRES + GO TO 236 + ENDIF + ILCR=ILCR+1 + 231 CONTINUE + IF(IDRES.EQ.0) GO TO 235 + WRITE(IOUT,9004) (ISONAM(ITC,JSO),ITC=1,3),RIND +*---- +* END MODIFICATION: G.M. (98/05/05) +*---- + CALL XABORT(NAMSBR//': UNABLE TO IDENTIFY RESONANCE SET '// + > 'FOR THIS ISOTOPE') + 236 CONTINUE +*---- +* THIS ISOTOPE NEEDS TO BE CORRECTED FOR SELF SHIELDING +* FIRST READ UNCORRECTED CROSS SECTIONS +*---- + XSCOR(1)=0.0 + XSCOR(2)=0.0 + XSCOR(3)=0.0 + XSCOR(4)=0.0 + IF(ABS(IPRINT).GE.5) WRITE(IOUT,6011) HNAMIS,XIND,TN(JSO) + CALL XDRLGS(KPLIB,-1,0,0,0,1,NGROUP,XSREC(1,IP0),SCAT, + > ITYPRO) + CALL XDRLXS(KPLIB,-1,0,NDPROC,NAMDXS,1,NGROUP,XSREC) +*---- +* SCAN RESONAMCE GROUPS AND CORRECT CROSS SECTIONS +*---- + DO 232 IGF=1,NGROUP + XSOUT(IGF,2)=0.0 + XSOUT(IGF,3)=XSREC(IGF,IP0) + XSOUT(IGF,4)=1.0 + XSOUT(IGF,5)=1.0 + 232 CONTINUE + IGRF=NGF + DO 240 IGR=1,NGR + IGRF=IGRF+1 +*---- +* PREPARE VECTORS FOR SELF SHIELDING +*---- + IF(ABS(IPRINT).GE.100) THEN + WRITE(IOUT,6004) IGRF,SN(IGRF,JSO),DSIGPL(IGR,IEL) + ENDIF + DO 250 ITYP=1,NTYP + ITYP0=ITYP + IF((NF(IEL).NE.3).AND.(ITYP.EQ.2)) GO TO 250 + IF((NF(IEL).NE.3).AND.(ITYP.EQ.3)) ITYP0=2 + CALL LIBWRP(IPRINT,NTYP,NGR,NRTOT,MAXTEM,MAXDIL,IGR,IRES, + > ITYP0,DSIGPL(IGR,IEL),NTM,NDI,RTMP,RDIL,RESI, + > NTMPR,NDILR,TMPT,DILT,REST) + IF(NDILR.GT.0.AND.NTMPR.GT.0) THEN + CALL LIBWRI(NTMPR,NDILR,TN(JSO),SN(IGRF,JSO),TMPT,DILT, + > REST,RIT,XSOUT(IGRF,ITYP),XSCOR(ITYP)) + IF(ABS(IPRINT).GE.100) THEN + IF(ITYP.EQ.1) THEN + WRITE(IOUT,6002) 'absorption ' + ELSE IF(ITYP.EQ.2) THEN + WRITE(IOUT,6002) 'fission ' + ELSE IF(ITYP.EQ.3) THEN + WRITE(IOUT,6002) 'scattering ' + ENDIF + WRITE(IOUT,6003) (REST(ITT),ITT=1,NTMPR*NDILR) + IF(ITYP.EQ.1) THEN + WRITE(IOUT,6005) XSOUT(IGRF,ITYP) + ELSE IF(ITYP.EQ.2) THEN + WRITE(IOUT,6006) XSOUT(IGRF,ITYP) + ELSE IF(ITYP.EQ.3) THEN + WRITE(IOUT,6007) XSOUT(IGRF,ITYP) + ENDIF + ENDIF + ENDIF + 250 CONTINUE + 240 CONTINUE +*---- +* CORRECT CROSS SECTIONS FOR ALL RESONANCE GROUPS +*---- + IGRF=NGF+1 + IGRL=NGF+NGR + CALL LIBWRE(NTYP,IPRINT,ITLIB,NGROUP,NL,IGRF,IGRL,NGR, + > SCAT,XSREC(1,IP0),XSREC(1,1),XSREC(1,7), + > XSREC(1,3),XSREC(1,4),XSREC(1,6), + > DELTA,SN(1,JSO),SB(1,JSO),XSOUT,XSCOR, + > DSIGPL(1,IEL)) +*---- +* PRINT CROSS SECTIONS IF REQUIRED +*---- + IF(ABS(IPRINT).GE.5) THEN + WRITE(IOUT,6100) HNAMIS + DO 233 IG1=NGF+1,NGFR + WRITE(IOUT,6101) IG1,SN(IG1,JSO),SB(IG1,JSO), + > XSOUT(IG1,4),XSREC(IG1,1), + > XSREC(IG1,IP0),XSREC(IG1,3),XSREC(IG1,9) + 233 CONTINUE + ENDIF +*---- +* SET NWT0 THE RESONANCE FLUX WEIGHTING +*---- + XSREC(:NGROUP,10)=1.0 + DO 234 IG1=NGF+1,NGFR + XSREC(IG1,10)=XSOUT(IG1,4) + 234 CONTINUE +*---- +* SAVE SELF-SHIELDED XS +*---- + CALL XDRLGS(KPLIB,1,0,0,0,1,NGROUP,XSREC(1,IP0),SCAT, ITYPRO) + CALL XDRLXS(KPLIB,1,0,NDPROC,NAMDXS,1,NGROUP,XSREC) + 235 CONTINUE + 230 CONTINUE +*---- +* RELEASE MEMORY FOR RESONANCE PROCESSING +*---- + DEALLOCATE(RIT,RRI,RID) +*---- +* RELEASE MEMORY FOR RESONANCE READ +*---- + DEALLOCATE(RESI,RDIL,RTMP) + DEALLOCATE(NDI,NTM) + IERR=KDRCLS(IUNIT,IACTC) + IF(IERR.LT.0) + > CALL XABORT(NAMSBR//': WIMS-E LIBRARY '//NAMFIL// + > ' CANNOT BE CLOSED') + IF(ABS(IPRINT).GE.5) WRITE(IOUT,6009) NAMSBR +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(DSIGPL) + DEALLOCATE(GAR,AW,XSOUT,XSSCMP,SCAT,XSREC,DELTA) + DEALLOCATE(ISORD,ITYPRO) +*---- +* RETURN +*---- + RETURN +*---- +* FORMAT +*---- + 9001 FORMAT(/' NUMBER OF GROUPS SPECIFIED :',I10/ + > ' NUMBER OF GROUPS IN LIBRARY :',I10) + 9002 FORMAT(/' MAXIMUM NUMBER OF ISOTOPE SPECIFIED :',I10/ + > ' NUMBER OF ISOTOPE IN LIBRARY :',I10) + 9003 FORMAT(/' LIBWE: MATERIAL/ISOTOPE ',3A4, + > ' IS MISSING ON WIMS-E FILE ',A8) + 9004 FORMAT(/' LIBWE: FOR ISOTOPE ',3A4, + > ' SELF-SHIELDING ISOTOPE ',F8.1,' NOT AVAILABLE') + 9005 FORMAT(/14H LIBWE: IDIEL=,I9,6H NTMP=,I5,8H MAXTEM=,I5) + 6000 FORMAT('(* Output from --',A6,'-- follows '// + > ' READING WIMS-E LIBRARY NAME ',A8) + 6001 FORMAT(' PROCESSING ISOTOPE/MATERIAL = ',A12) + 6002 FORMAT(' Resonance integral tabulation for ',A12) + 6003 FORMAT(1P,5E15.7) + 6004 FORMAT(' Processing GROUP = ', I10,' at dilutions = ', + > 1P,2E15.7) + 6005 FORMAT(' Interpolated absorption rate = ',1P,E15.7) + 6006 FORMAT(' Interpolated fission rate = ',1P,E15.7) + 6007 FORMAT(' Interpolated scattering rate = ',1P,E15.7) + 6009 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(' RESONANCE IDENTIFICATION') + 6011 FORMAT(' ISOTOPE ID = ',A12,' RESONANCE ID = ',F8.1, + > ' at temperature = ',F10.5) + 6100 FORMAT(' SELF SHIELDING PROPERTIES FOR ISOTOPE =',A12/ + > 5X,'GROUP',10X,'DILUT',13X,'SB',11X,'NPHI',10X,'NTOT0', + > 11X,'SIGS',9X,'NUSIGF',10X,'NGOLD') + 6101 FORMAT(5X,I5,1P,8E15.5) + 6200 FORMAT(' TEMPERATURE = ',F10.5,10X, + > ' CROSS SECTION TABULATED AT A SINGLE TEMPERATURE') + 6201 FORMAT(' TEMPERATURE = ',F10.5,10X, + > ' CROSS SECTION TABULATED AT MULTIPLE TEMPERATURES') + 6202 FORMAT(' TABULATION TEMPERATURES= ',/(5F15.5)) + 6203 FORMAT(' INTERPOLATION FACTORS = ',1P,/(5E15.5)) + END diff --git a/Dragon/src/LIBWED.f b/Dragon/src/LIBWED.f new file mode 100644 index 0000000..73245f1 --- /dev/null +++ b/Dragon/src/LIBWED.f @@ -0,0 +1,181 @@ +*DECK LIBWED + SUBROUTINE LIBWED(MAXR,NEL,NBESP,NDEPL,NDFI,NDFP,NHEAVY,NLIGHT, + > NOTHER,NREAC,NPAR,ITNAM,ITZEA,MATNO,KPAX,BPAX, + > HNADPL,IZEA,IDR,RER,RRD,KPAR,BPAR,YIELD) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Create /depletion/ records in /microlib/. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau +* +*Parameters: input +* MAXR number of reaction types. +* NEL number of isotopes on library. +* NBESP number of energy-dependent fission yield matrices. +* NDEPL number of depleting isotopes. +* NDFI number of direct fissile isotopes. +* NDFP number of direct fission product. +* NHEAVY number of heavy isotopes (fissile isotopes + decay + +* capture isotopes). +* NLIGHT number of light isotopes (fission product + decay + +* capture isotopes). +* NOTHER number of other isotopes (depleting isotopes + decay + +* capture isotopes). +* NREAC maximum number of depletion reaction in the depletion chain. +* NPAR maximum number of parent isopopes from decay and capture. +* ITNAM reactive isotope names in chain. +* ITZEA 6-digit nuclide identifier: +* atomic number z*10000 (digits) + mass number a*10 + +* energy state (0 = ground state, 1 = first state, etc.). +* MATNO reaction material index. +* KPAX complete reaction type matrix. +* BPAX complete branching ratio matrix. +* +*Parameters: output +* HNADPL reactive isotope names in chain. +* IZEA 6-digit nuclide identifier: +* atomic number z*10000 (digits) + mass number a*10 + +* energy state (0 = ground state, 1 = first state, etc.). +* IDR DEPLETE-REAC matrix (reaction identifiers). +* RER DEPLETE-ENER matrix (MeV/reaction values). +* RRD DEPLETE-DECA vector (decay constant values). +* KPAR PRODUCE-REAC matrix (production identifiers). +* BPAR PRODUCE-RATE matrix (branching ratios). +* YIELD fission product yield matrix. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXR,NEL,NBESP,NDEPL,NDFI,NDFP,NHEAVY,NLIGHT,NOTHER,NREAC, + > NPAR,ITNAM(3,NEL),ITZEA(NEL),MATNO(NEL),KPAX(NEL+MAXR,NEL), + > HNADPL(3,NDEPL),IZEA(NDEPL),IDR(NREAC,NDEPL),KPAR(NPAR,NDEPL) + REAL BPAX(NBESP,NEL+MAXR,NEL),RER(NREAC,NDEPL),RRD(NDEPL), + > BPAR(NPAR,NDEPL),YIELD(NBESP,NDFI,NDFP) +*---- +* LOCAL VARIABLES +*---- + CHARACTER TEXT4*4 + INTEGER ITEXT4,ISOHEA,ISOLIG,ISOOTH,ISOSTA,ISO,ISONUM,IT,IEL, + > IPAR,JEL,JSO,IFI,IFP +*---- +* INTERNAL PARAMETERS +*---- + INTEGER KDECAY,KFISSP,KFISSI,KHEAT + PARAMETER (KDECAY=1,KFISSP=2,KFISSI=6,KHEAT=9) +*---- +* INITIALIZE DECAY CHAIN +*---- + TEXT4=' ' + READ(TEXT4,'(A4)') ITEXT4 + HNADPL(:3,:NDEPL)=ITEXT4 + IZEA(:NDEPL)=0 + IDR(:NREAC,:NDEPL)=0 + KPAR(:NPAR,:NDEPL)=0 + RER(:NREAC,:NDEPL)=0.0 + RRD(:NDEPL)=0.0 + BPAR(:NPAR,:NDEPL)=0.0 + YIELD(:NBESP,:NDFI,:NDFP)=0.0 +*---- +* RENUMBER ISOTOPES AND SAVE IDR, RER AND RRD +*---- + ISOHEA=0 + ISOLIG=ISOHEA+NHEAVY + ISOOTH=ISOLIG+NLIGHT + ISOSTA=ISOOTH+NOTHER + DO 100 ISO=NEL,1,-1 + ISONUM=0 + IF(MATNO(ISO).EQ.-KFISSI) THEN + ISOHEA=ISOHEA+1 + ISONUM=ISOHEA + ELSE IF(MATNO(ISO).EQ.-KFISSP) THEN + ISOLIG=ISOLIG+1 + ISONUM=ISOLIG + ELSE IF(MATNO(ISO).EQ.-KDECAY) THEN + ISOOTH=ISOOTH+1 + ISONUM=ISOOTH + ELSE IF(MATNO(ISO).EQ.-KHEAT) THEN + ISOSTA=ISOSTA+1 + ISONUM=ISOSTA + ENDIF + IF(ISONUM.GT.0) THEN + MATNO(ISO)=ISONUM + HNADPL(1,ISONUM)=ITNAM(1,ISO) + HNADPL(2,ISONUM)=ITNAM(2,ISO) + HNADPL(3,ISONUM)=ITNAM(3,ISO) + IZEA(ISONUM)=ITZEA(ISO) + IDR(1,ISONUM)=KPAX(NEL+1,ISO) + RRD(ISONUM)=BPAX(1,NEL+1,ISO) + DO 101 IT=2,NREAC + IDR(IT,ISONUM)=KPAX(NEL+IT,ISO) + RER(IT,ISONUM)=BPAX(1,NEL+IT,ISO) + 101 CONTINUE + ENDIF + 100 CONTINUE +*---- +* CREATE KPAR AND BPAR MATRIX +*---- + DO 110 IEL=1,NEL + ISO=MATNO(IEL) + IF(ISO.GT.0) THEN + IPAR=0 + DO 111 JEL=1,NEL + JSO=MATNO(JEL) + IF(JSO.GT.0) THEN + IF((KPAX(IEL,JEL).NE.0).AND.(KPAX(IEL,JEL).NE.KFISSP)) + > THEN + IPAR=IPAR+1 + IF(IPAR.GT.NPAR) + > CALL XABORT('LIBWED: TOO MANY DECAY PARENTS') + KPAR(IPAR,ISO)=JSO*100+KPAX(IEL,JEL) + BPAR(IPAR,ISO)=BPAX(1,IEL,JEL) + ENDIF + ENDIF + 111 CONTINUE + ENDIF + 110 CONTINUE +*---- +* CREATE YIELD MATRIX +*---- + DO 120 IEL=1,NEL + ISO=MATNO(IEL) + IF(ISO.GT.0) THEN + IF(MOD(IDR(KFISSP,ISO),100).EQ.4) THEN + IFI=IDR(KFISSP,ISO)/100 + IF(IFI.EQ.0) GO TO 120 + IF(IFI.GT.NDFI) + > CALL XABORT('LIBWED: INVALID FISSILE ISOTOPE NUMBER') + DO 121 JEL=1,NEL + JSO=MATNO(JEL) + IF(JSO.GT.0) THEN + IF(MOD(IDR(KFISSP,JSO),100).EQ.2) THEN + GO TO 121 + ELSE IF(MOD(IDR(KFISSP,JSO),100).EQ.5) THEN + IFP=IDR(KFISSP,JSO)/100 + IF(IFP.GT.NDFP) CALL XABORT('LIBWED: INVALID FI'// + > 'SSION PRODUCT NUMBER') + IF(KPAX(JEL,IEL) .EQ. KFISSP) THEN + YIELD(:,IFI,IFP)=BPAX(:,JEL,IEL) + ENDIF + ENDIF + ENDIF + 121 CONTINUE + ENDIF + ENDIF + 120 CONTINUE +*---- +* RETURN +*---- + RETURN + END diff --git a/Dragon/src/LIBWET.f b/Dragon/src/LIBWET.f new file mode 100644 index 0000000..f30cd99 --- /dev/null +++ b/Dragon/src/LIBWET.f @@ -0,0 +1,312 @@ +*DECK LIBWET + SUBROUTINE LIBWET(MAXR,NEL,NBESP,NSTATE,NMDEPL,ITNAM,ISTATE, + > MATNO,KPAX,BPAX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Identify the depleting isotopes by type and reorder them (recompute +* the KPAX and BPAX matrices). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau +* +*Parameters: input +* MAXR number of reaction types. +* NEL number of isotopes on library. +* NBESP number of energy-dependent fission yield matrices. +* NSTATE number of parameters in the state vector. +* NMDEPL names of reactions: +* NMDEPL(1)='DECAY'; NMDEPL(2)='NFTOT'; +* NMDEPL(3)='NG' ; NMDEPL(4)='N2N'; +* etc. +* ITNAM reactive isotope names in chain. +* +*Parameters: output +* ISTATE state vector containing the library parameters. +* MATNO reaction material indices. +* +*Parameters: input/output +* KPAX complete reaction type matrix. +* BPAX complete branching ratio matrix. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXR,NEL,NBESP,NSTATE,ITNAM(3,NEL),ISTATE(NSTATE), + > MATNO(NEL),KPAX(NEL+MAXR,NEL) + CHARACTER NMDEPL(MAXR)*8 + REAL BPAX(NBESP,NEL+MAXR,NEL) +*---- +* LOCAL VARIABLES +*---- + INTEGER NDFP,JSO,ISO,ITR,NUNTIL,NHEAVY,NDFI,IUNTIL,NEW, + > NLIGHT,NOTHER,NIFP,KPAX0,KPAX1,KPAX2,IEL,JEL, + > KREAC,II,NPAR,ICOUNT,NREAC,NSTABL + REAL SUMFI + CHARACTER TEXT12*12 + LOGICAL LOGPF +*---- +* INTERNAL PARAMETERS +*---- + INTEGER KDECAY,KFISSP,KCAPTU,KFISSI,KHEAT + PARAMETER (KDECAY=1,KFISSP=2,KCAPTU=3,KFISSI=6,KHEAT=9) +*---- +* COMPUTE NUMBER OF DIRECT FISSION PRODUCT +* NUMBER DIRECT FISSION PRODUCT +* +* SET MATNO TO LIGHT (-KFISSP) FOR FISSION PRODUCT +* SET MATNO TO HEAVY (-KFISSI) FOR FISSILE ISOTOPES +* SET MATNO TO STABLE (-KHEAT) FOR STABLE ISOTOPES PRODUCING ENERGY +* SET MATNO TO 0 TO UNUSED ISOTOPES +*---- + NDFI=0 + NDFP=0 + DO 100 JSO=NEL,1,-1 + MATNO(JSO)=0 + KPAX0=KPAX(NEL+KDECAY,JSO) + KPAX1=KPAX(NEL+KFISSP,JSO) + KPAX2=KPAX(NEL+KCAPTU,JSO) + IF((KPAX0.EQ.-9999).OR.(KPAX1.EQ.-9999).OR.(KPAX2.EQ.-9999)) + > THEN +* JSO IS A STABLE ISOTOPE + MATNO(JSO)=-KHEAT + DO 222 ITR=1,MAXR + IF(BPAX(1,NEL+ITR,JSO).GT.0.0) THEN + KPAX(NEL+ITR,JSO)=2 + KPAX(JSO,:NEL)=0 + ENDIF + 222 CONTINUE + GO TO 100 + ELSE IF(KPAX1.LT.0) THEN +* JSO IS A FISSION PRODUCT + MATNO(JSO)=-KFISSP + NIFP=0 + DO 101 ISO=NEL,1,-1 + IF((KPAX(JSO,ISO).EQ.KFISSP).AND. + > (BPAX(1,JSO,ISO).GT.0.0)) THEN + NIFP=NIFP+1 + ENDIF + 101 CONTINUE + IF(NIFP.GT.0) THEN + NDFP=NDFP+1 + KPAX(NEL+KFISSP,JSO)=5+100*NDFP + ELSE + KPAX(NEL+KFISSP,JSO)=5 + ENDIF + ELSE IF(KPAX1.GT.0) THEN +* JSO IS A FISSILE ISOTOPE + MATNO(JSO)=-KFISSI + SUMFI=0.0 + DO 221 ISO=1,NEL + IF(KPAX(ISO,JSO).EQ.KFISSP) SUMFI=SUMFI+BPAX(1,ISO,JSO) + 221 CONTINUE + IF(SUMFI.GT.0.0) THEN + NDFI=NDFI+1 + KPAX(NEL+KFISSP,JSO)=4+100*NDFI + ELSE + KPAX(NEL+KFISSP,JSO)=3 + ENDIF + ENDIF + 100 CONTINUE +*---- +* CHECK IF THE DEPLETION CHAIN IS COHERENT +*---- + DO 200 IEL=1,NEL + DO 210 JEL=1,NEL + KREAC=KPAX(JEL,IEL) + IF(KREAC.EQ.KFISSP) THEN + IF(MOD(KPAX(NEL+KFISSP,JEL),100).NE.5) THEN + WRITE(TEXT12,'(3A4)') (ITNAM(II,JEL),II=1,3) + CALL XABORT('LIBWET: SON '//TEXT12//' IS NOT A FISSION '// + > 'PRODUCT') + ENDIF + IF((KPAX(NEL+KFISSP,IEL).NE.3).AND. + > (MOD(KPAX(NEL+KFISSP,IEL),100).NE.4)) THEN + WRITE(TEXT12,'(3A4)') (ITNAM(II,IEL),II=1,3) + CALL XABORT('LIBWET: PARENT '//TEXT12//' IS NOT A FISSI'// + > 'LE ISOTOPE') + ENDIF + ELSE IF(KREAC.NE.0) THEN + IF(KPAX(NEL+KREAC,IEL).EQ.0) THEN + WRITE(TEXT12,'(3A4)') (ITNAM(II,IEL),II=1,3) + CALL XABORT('LIBWET: PARENT '//TEXT12//' DOES NOT DEPL'// + > 'ETE VIA REACTION '//NMDEPL(KREAC)) + ENDIF + ENDIF + 210 CONTINUE + 200 CONTINUE +*---- +* SET MATNO TO OTHER (-KDECAY) FOR ISOTOPES WITH DAUGHTER OR FATHER +* AND FOR ISOTOPES WITH DECAY +*---- + DO 112 ISO=1,NEL + IF(MATNO(ISO).EQ.0) THEN + IF(KPAX(NEL+KDECAY,ISO).GT.0 .OR. + > KPAX(NEL+KCAPTU,ISO).GT.0) THEN + MATNO(ISO)=-KDECAY + GO TO 115 + ENDIF + DO 113 JSO=1,NEL + IF(KPAX(JSO,ISO).GT.0) THEN + MATNO(ISO)=-KDECAY + GO TO 115 + ELSE IF(KPAX(ISO,JSO).GT.0) THEN + MATNO(ISO)=-KDECAY + GO TO 115 + ENDIF + 113 CONTINUE + ENDIF + 115 CONTINUE + 112 CONTINUE +*---- +* SET MATNO TO STABLE (-KHEAT) FOR OTHER ISOTOPES PRODUCING ENERGY +*---- + DO 212 ISO=1,NEL + IF(MATNO(ISO).EQ.0) THEN + DO 213 ITR=2,MAXR + IF(BPAX(1,NEL+ITR,ISO).NE.0.0) THEN + MATNO(ISO)=-KHEAT + GO TO 215 + ENDIF + 213 CONTINUE + ENDIF + 215 CONTINUE + 212 CONTINUE +*---- +* COMPUTE THE MAXIMUM NUMBER OF PARENTS FOR AN ISOTOPE +*---- + NPAR=0 + DO 116 ISO=1,NEL + ICOUNT=0 + DO 114 JSO=1,NEL + LOGPF=((MATNO(ISO).EQ.-KFISSP).AND.(MATNO(JSO).EQ.-KFISSI)) + IF((BPAX(1,ISO,JSO).NE.0.0).AND.(.NOT.LOGPF)) ICOUNT=ICOUNT+1 + 114 CONTINUE + NPAR=MAX(NPAR,ICOUNT) + 116 CONTINUE +*---- +* COMPUTE THE MAXIMUM NUMBER OF DEPLETION REACTIONS +*---- + NREAC=4 + DO 118 ISO=1,NEL + DO 117 ITR=1,MAXR + IF(KPAX(NEL+ITR,ISO).NE.0) NREAC=MAX(NREAC,ITR) + 117 CONTINUE + 118 CONTINUE +*---- +* SET MATNO TO HEAVY (-KFISSI) FOR ISOTOPES RESULTING FROM DECAY +* OR CAPTURE OF HEAVY ISOTOPE UNTIL ALL HEAVY ISOTOPES IDENTIFIED +*---- + NUNTIL=NEL + NHEAVY=0 + DO 120 IUNTIL=1,NUNTIL + NEW=0 + DO 121 ISO=NEL,1,-1 + IF(MATNO(ISO).EQ.-KFISSI) THEN + NHEAVY=NHEAVY+1 + DO 122 JSO=NEL,1,-1 + IF(MATNO(JSO).NE.-KFISSI) THEN + IF((KPAX(JSO,ISO).NE.0).AND.(KPAX(JSO,ISO).NE.KFISSP)) + > THEN + NEW=NEW+1 + MATNO(JSO)=-KFISSI + ENDIF + ENDIF + 122 CONTINUE + ENDIF + 121 CONTINUE + IF(NEW.EQ.0) GO TO 125 + NHEAVY=0 + 120 CONTINUE + 125 CONTINUE +*---- +* SET MATNO TO LIGHT (-KFISSP) FOR ISOTOPES RESULTING FROM DECAY +* OR CAPTURE OF LIGHT ISOTOPE UNTIL ALL LIGHT ISOTOPES IDENTIFIED +*---- + NUNTIL=NUNTIL-NHEAVY + NLIGHT=0 + DO 130 IUNTIL=1,NUNTIL + NEW=0 + DO 131 ISO=NEL,1,-1 + IF(MATNO(ISO).EQ.-KFISSP) THEN + NLIGHT=NLIGHT+1 + DO 132 JSO=NEL,1,-1 + IF(MATNO(JSO).NE.-KFISSI.AND. + > MATNO(JSO).NE.-KFISSP) THEN + IF(KPAX(JSO,ISO).NE.0) THEN + NEW=NEW+1 + MATNO(JSO)=-KFISSP + ENDIF + ENDIF + 132 CONTINUE + ENDIF + 131 CONTINUE + IF(NEW.EQ.0) GO TO 135 + NLIGHT=0 + 130 CONTINUE + 135 CONTINUE +*---- +* SET MATNO TO OTHER (-KDECAY) FOR ISOTOPES RESULTING FROM DECAY +* OR CAPTURE OF OTHER ISOTOPE UNTIL ALL OTHER ISOTOPES IDENTIFIED +*---- + NUNTIL=NUNTIL-NLIGHT + NOTHER=0 + DO 140 IUNTIL=1,NUNTIL + NEW=0 + DO 141 ISO=NEL,1,-1 + IF(MATNO(ISO).EQ.-KDECAY) THEN + NOTHER=NOTHER+1 + DO 142 JSO=NEL,1,-1 + IF(MATNO(JSO).NE.-KFISSI.AND. + > MATNO(JSO).NE.-KFISSP.AND. + > MATNO(JSO).NE.-KDECAY) THEN + IF(KPAX(JSO,ISO).NE.0) THEN + NEW=NEW+1 + MATNO(JSO)=-KDECAY + ENDIF + ENDIF + 142 CONTINUE + ENDIF + 141 CONTINUE + IF(NEW.EQ.0) GO TO 145 + NOTHER=0 + 140 CONTINUE + 145 CONTINUE +*---- +* COUNT THE NUMBER OF STABLE ISOTOPES AND SET TO ZERO THEIR RADIOACTIVE +* DECAY CONSTANT. +*---- + NSTABL=0 + DO 150 ISO=1,NEL + IF(MATNO(ISO).EQ.-KHEAT) THEN + NSTABL=NSTABL+1 + BPAX(:,NEL+KDECAY,ISO)=0.0 + ENDIF + 150 CONTINUE +* + ISTATE(:NSTATE)=0 + ISTATE(1)=NHEAVY+NLIGHT+NOTHER+NSTABL + ISTATE(2)=NDFI + ISTATE(3)=NDFP + ISTATE(4)=NHEAVY + ISTATE(5)=NLIGHT + ISTATE(6)=NOTHER + ISTATE(7)=NSTABL + ISTATE(8)=NREAC + ISTATE(9)=NPAR + ISTATE(10)=NBESP +*---- +* RETURN +*---- + RETURN + END diff --git a/Dragon/src/LIBWID.f b/Dragon/src/LIBWID.f new file mode 100644 index 0000000..04e9b30 --- /dev/null +++ b/Dragon/src/LIBWID.f @@ -0,0 +1,51 @@ +*DECK LIBWID + FUNCTION LIBWID(NEL,IWISO,ISOID) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find isotope number associated with isotope id on WIMS-NEA and +* WIMS-AECL library. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* NEL number of isotopes on library. +* IWISO id of isotope on library. +* ISOID isotope id requested. +* +*Parameters: output +* LIBWID isotope number associated with id (= 0 when isotope id is +* not found). +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NEL,IWISO(NEL),ISOID,LIBWID +*---- +* LOCAL VARIABLES +*---- + INTEGER IEL +*---- + LIBWID=0 + IF(ISOID.GT.0) THEN + DO 100 IEL=1,NEL + IF(IWISO(IEL).EQ.ISOID) THEN + LIBWID=IEL + GO TO 105 + ENDIF + 100 CONTINUE + 105 CONTINUE + ENDIF + RETURN + END diff --git a/Dragon/src/LIBWIM.f b/Dragon/src/LIBWIM.f new file mode 100644 index 0000000..b70c13d --- /dev/null +++ b/Dragon/src/LIBWIM.f @@ -0,0 +1,776 @@ +*DECK LIBWIM + SUBROUTINE LIBWIM(IPLIB,IPRINT,NAMFIL,NGROUP,NBISO,NL,ISONAM, + > ISONRF,IPISO,ISHINA,TN,SN,SB,MASKI,NGF,NGFR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transcription of the interpolated microscopic xs read from a +* microscopic xs library in WIMS-AECL format to LCM data structures. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPLIB pointer to the internal library. +* IPRINT print flag. +* NAMFIL WIMS-EACL file name. +* NGROUP number of groups. +* NBISO number of isotopes. +* NL number of Legendre scattering order: +* =1 isotropic; +* =2 linearly anisotropic. +* ISONAM local isotope names. +* ISONRF library isotope names. +* IPISO pointer array towards microlib isotopes. +* ISHINA self-shielding isotope names. +* TN isotope tempterature. +* SN dilution xs. +* SB Livolant-Jeanpierre dilution xs. +* MASKI logical mask for processing isotope. +* +*Parameters: output +* NGF number of fast groups without self-shielding. +* NGFR number of fast and resonance groups. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NDPROC + PARAMETER (NDPROC=10) + TYPE(C_PTR) IPLIB,IPISO(NBISO) + INTEGER IPRINT,NGROUP,NBISO,NL,ISONAM(3,NBISO),ISONRF(3,NBISO), + > ISHINA(3,NBISO),NGF,NGFR + CHARACTER NAMFIL*8 + LOGICAL MASKI(NBISO) + REAL TN(NBISO),SN(NGROUP,NBISO),SB(NGROUP,NBISO) +*---- +* FUNCTIONS +*---- + DOUBLE PRECISION XDRCST +*---- +* INTERNAL PARAMETERS +*---- + INTEGER IOUT,ITLIB,MAXRES,MAXTEM,MAXDIL,NOTX + REAL CONVM + PARAMETER (IOUT=6,ITLIB=1,MAXRES=50,MAXTEM=20,MAXDIL=20,NOTX=-1) +*---- +* LOCAL VARIABLES +*---- + CHARACTER NAMDXS(NDPROC)*6,HNAMIS*12,HNISOR*12,HSHIR*8, + > README*96,FMT*6 + INTEGER IHGAR(24),IP1,NPROC,IUNIT,KDROPN,II,NEL,NGR,NGTHER, + > MXSCT,NGX,IG,ILOCX,ILOCY,ILOCS,NRDT,JSO,ITC,IDRES,IEL, + > IRISO,IENDF,NF,NSCT,NTMP,IREC,JJJ,IACT,ITMP,ITXS,NTYP, + > LSUBTR,LSUBZ,LRESND,IGRF,IGR,NRES,IGF,JRES,KRES,NTMPR, + > NDILR,NTD,ITT,IRRICS,ILL,IGRL,IG1,IP0 + REAL TMPT(MAXTEM),DILT(MAXTEM),RS1(3*MAXRES),XSCOR(4), + > AWJSO,RIND,XRS1,ASIGPL + DOUBLE PRECISION TERP(MAXTEM) + TYPE(C_PTR) KPLIB +*---- +* WIMS-AECL LIBRARY PARAMETERS +* IUTYPE : TYPE OF FILE = 4 (DA) +* LRIND : LENGHT RECORD ON DA FILE = 256 +* IACTO : OPEN ACTION = 2 (READ ONLY) +* IACTC : CLOSE ACTION = 2 (KEEP) +* MAXISO : MAX. NB. OF ISO = 246 +* NCT : NUMBER OF C*8 IN TITLE = 10 +* LPZ : LENGTH OF WIMS PARAMETER ARRAY = 9 +* LMASTB : LENGTH OF MST TAB = MAXISO+9 +* LMASIN : LENGTH OF MST IDX = LMASTB-4 +* LGENTB : LENGTH OF GEN TAB = 6 +* LGENIN : LENGTH OF GEN IDX = LGENTB +* LSUBTB : LENGTH OF SUB TAB = 6*MAXTEM+21-5+12 +* LSUBIN : LENGTH OF SUB IDX = LSUBTB-12 +* LRESTB : LENGTH OF RES TAB = 5*MAXRES +* LRESIN : LENGTH OF RES IDX = LRESIN +* MASTER : MASTER INDEX ARRAY +* GENINX : GENERAL INDEX ARRAY +* SUBINX : SUB INDEX ARRAY GENERAL +* SUBINR : SUB INDEX ARRAY RESONANCE +* RESINX : RESONANCE INDEX ARRAY +* IWISO : ID OF ISOTOPE +* CWISO : ISOTOPE NAMES +* MASTER : MASTER INDEX ARRAY +* GENINX : GENERAL INDEX ARRAY +* SUBINX : SUB INDEX ARRAY +*---- + INTEGER IUTYPE,LRIND,IACTO,IACTC,MAXISO,NCT,LPZ,LMASTB, + > LMASIN,LGENTB,LGENIN,LSUBTB,LSUBIN,LRESTB, + > LRESIN,ILONG,ITYLCM + PARAMETER (IUTYPE=4,LRIND=256,IACTO=2,IACTC=1, + > MAXISO=246,NCT=10,LPZ=9,LMASTB=MAXISO+9, + > LMASIN=LMASTB-4,LGENTB=6,LGENIN=LGENTB, + > LSUBTB=6*MAXTEM+28,LSUBIN=LSUBTB-12, + > LRESTB=MAXRES*5,LRESIN=LRESTB) + CHARACTER CWISO(MAXISO)*8,CTITLE(NCT)*8 + INTEGER MASTER(LMASTB),GENINX(LGENTB),SUBINX(LSUBTB), + > SUBINR(LSUBTB),RESINX(LRESTB),NXS(MAXTEM), + > ITITLE(2*NCT),NPZ(LPZ),IWISO(2*MAXISO) + REAL AWR + INTEGER IPRLOC + EQUIVALENCE (SUBINX(LSUBIN+3),AWR) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPRO + REAL, ALLOCATABLE, DIMENSION(:) :: DELTA,XSSCMP,ENER,TMPXS,TMPSC, + > RRI,RIT,DSIGPL + REAL, ALLOCATABLE, DIMENSION(:,:) :: XSREC,XSOUT,GAR + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT +*---- +* DATA +*---- + SAVE NAMDXS + DATA NAMDXS /'NTOT0 ','TRANC ','NUSIGF','NFTOT ','CHI ', + > 'NU ','NG ','N2N ','NGOLD ','NWT0 '/ +*---- +* SCRATCH STORAGE ALLOCATION +* ITYPRO cross section processed +* DELTA lethergy +* XSREC general xs vector +* SCAT complete scattering matrix SCAT(JG,IG) (from IG to JG) +* XSSCMP compress scattering for transfer +* XSOUT self shielding parameter +* GAR intermediate xs vector: +* GAR(I,1): library fission spectrum; +* GAR(I,2): potential scattering xs +*---- + ALLOCATE(ITYPRO(NL)) + ALLOCATE(DELTA(NGROUP),XSREC(NGROUP,NDPROC+NL), + > SCAT(NGROUP,NGROUP,NL),XSSCMP(NGROUP*(NGROUP+2)), + > XSOUT(NGROUP,7),GAR(NGROUP,2)) +*---- +* OPEN WIMSLIB AND READ TITLE +* READ GENERAL DIMENSIONING +*---- + IPRLOC=IPRINT + IF(IPRINT .LT. 20) IPRLOC=0 + CONVM=REAL(XDRCST('Neutron mass','amu')) + IP0=NDPROC+1 + IP1=NDPROC+2 + NPROC=NDPROC+NL + IUNIT=KDROPN(NAMFIL,IACTO,IUTYPE,LRIND) + IF(IUNIT.LE.0) CALL XABORT('LIBWIM: WIMS-AECL LIBRARY '// + > NAMFIL//' CANNOT BE OPENED FOR MIXS') + CALL OPNIND(IUNIT,MASTER,LMASTB) + CALL REDIND(IUNIT,MASTER,LMASIN,GENINX,LGENTB,1) + CALL REDIND(IUNIT,MASTER,LMASIN,ITITLE,2*NCT,2) + CALL UPCKIC(ITITLE(1),CTITLE(1),NCT) + WRITE(README(9:96),'(6H FROM ,10A8,A2)') + > (CTITLE(II),II=1,NCT),' ' + IF(IPRINT.GE.5) THEN + WRITE(IOUT,6000) NAMFIL + WRITE(IOUT,'(1X,10A8)') (CTITLE(II),II=1,NCT) + ENDIF + CALL REDIND(IUNIT,GENINX,LGENIN,NPZ,LPZ,1) + IF(NPZ(2).NE.NGROUP) THEN + WRITE(IOUT,9001) NGROUP,NPZ(2) + CALL XABORT('LIBWIM: INVALID NUMBER OF GROUPS') + ENDIF + NEL=NPZ(1) + NGF=NPZ(4) + NGR=NPZ(5) + NGTHER=NPZ(6) + NGFR=NGF+NGR + MXSCT=NGROUP*(NGROUP+2) + IF(NGFR+NGTHER.NE.NGROUP) THEN + WRITE(IOUT,9001) NGROUP,NGFR+NGTHER + CALL XABORT('LIBWIM: INVALID NUMBER OF GROUPS') + ENDIF + IF(NEL.GT.MAXISO) THEN + WRITE(IOUT,9003) MAXISO,NEL + CALL XABORT('LIBWIM: INVALID NUMBER OF ISOTOPES') + ENDIF + ALLOCATE(DSIGPL(NGR)) +*---- +* READ ISOTOPES NAMES +*---- + CALL REDIND(IUNIT,GENINX,LGENIN,IWISO,2*NEL,3) + CALL UPCKIC(IWISO(1),CWISO(1),NEL) + CALL REDIND(IUNIT,GENINX,LGENIN,IWISO,NEL,2) +*---- +* READ GROUP STRUCTURE +*---- + ALLOCATE(ENER(NGROUP+1)) + CALL REDIND(IUNIT,GENINX,LGENIN,ENER,NGROUP+1,4) + IF(ENER(NGROUP+1).EQ.0.0) ENER(NGROUP+1)=1.0E-5 + CALL LCMPUT(IPLIB,'ENERGY',NGROUP+1,2,ENER) + NGX=0 + DO 100 IG=1,NGROUP + IF(NGX.EQ.0.AND.ENER(IG+1).LT.4.0) NGX=IG-1 + DELTA(IG)=LOG(ENER(IG)/ENER(IG+1)) + 100 CONTINUE + CALL LCMPUT(IPLIB,'DELTAU',NGROUP,2,DELTA) + DEALLOCATE(ENER) +*---- +* INITIALIZE ALL XSREC +* READ FISSION SPECTRUM +*---- + GAR(:NGROUP,1)=0.0 + CALL REDIND(IUNIT,GENINX,LGENIN,GAR(:,1),NPZ(3),5) +*---- +* ALLOCATE MEMORY FOR TEMPERATURE DEPENDENT XS +* AND FOR RESONANCE CALCULATION +*---- + ALLOCATE(TMPXS(5*NGROUP),TMPSC(NGROUP*NGROUP), + > RRI(MAXDIL*MAXTEM*2),RIT(MAXDIL)) + ILOCX=0 + ILOCY=NGFR + ILOCS=0 + NRDT=NGTHER-1 +*---- +* READ THROUGH DRAGON FILE AND ACCUMULATE CROSS SECTIONS FOR +* CROSS SECTION ARE SAVED ONLY IF ISOTOPE IS USED +*---- + DO 110 JSO=1,NBISO + IF(.NOT.MASKI(JSO)) GO TO 115 +*---- +* LOCATE ISOTOPE +*---- + WRITE(HNAMIS,'(3A4)') (ISONAM(ITC,JSO),ITC=1,3) + WRITE(HNISOR,'(3A4)') (ISONRF(ITC,JSO),ITC=1,3) + WRITE(HSHIR,'(2A4)') (ISHINA(ITC,JSO),ITC=1,2) + IDRES=INDEX(HSHIR,'.') + IF(IDRES.GT.0) THEN + WRITE(FMT,'(2H(F,I1,3H.1))') IDRES+1 + READ(HSHIR,FMT) RIND + ENDIF + IRISO=0 + DO 120 IEL=1,NEL + IF(CWISO(IEL).EQ.HNISOR(1:8)) THEN + IRISO=IEL + IF(IDRES.EQ.0) THEN + RIND=FLOAT(IWISO(IRISO)) + ENDIF + GO TO 125 + ENDIF + 120 CONTINUE + WRITE(IOUT,9002) HNISOR,NAMFIL + CALL XABORT('LIBWIM: ISOTOPE NOT FOUND ON LIBRARY') + 125 CONTINUE + IF(IPRINT.GE.5) WRITE(IOUT,6001) HNAMIS + XSREC(:NGROUP,:NPROC)=0.0 + SCAT(:NGROUP,:NGROUP,:NL)=0.0 +*---- +* READ SUB INDEX ASSOCIATED WITH ISOTOPE +*---- + CALL REDIND(IUNIT,MASTER,LMASIN,SUBINX,LSUBTB,IRISO+4) +*---- +* FOR ENDF/B-VI LIBRARY : IENDF = 2 +* FOR ENDF/B-V LIBRARY : IENDF = 1 +* FOR WINFRITH LIBRARY : IENDF = 0 +*---- + IENDF=SUBINX(LSUBIN+12) + AWJSO=AWR/CONVM +*---- +* FAST AND/OR RESONANCE XS +*---- + CALL REDIND(IUNIT,SUBINX,LSUBIN,XSREC(NGF+1:,9),NGR,9) + DSIGPL(:NGR)=0.0 + IF(IENDF.EQ.0) THEN + CALL REDIND(IUNIT,SUBINX,LSUBIN,GAR(NGF+1:,2),NGR,2) + DO 130 IG=NGF+1,NGFR + DSIGPL(IG-NGF)=GAR(IG,2)*XSREC(IG,9) + 130 CONTINUE + ENDIF + CALL REDIND(IUNIT,SUBINX,LSUBIN,XSREC(:,8),NGF,13) + NF=SUBINX(LSUBIN+5) + IF(NF.GT.1) THEN + CALL REDIND(IUNIT,SUBINX,LSUBIN,XSREC(:,3),NGFR,10) + CALL REDIND(IUNIT,SUBINX,LSUBIN,XSREC(:,4),NGFR,12) + DO 135 IG=1,NGROUP + XSREC(IG,5)=GAR(IG,1) + 135 CONTINUE + ENDIF + NSCT=SUBINX(LSUBIN+8) + IF(NSCT.GT.MXSCT) THEN + WRITE(IOUT,9004) NSCT,MXSCT + CALL XABORT('LIBWIM: INVALID SCATTERING MATRIX -E/0') + ENDIF +*---- +* READ AND DECOMPRESS P0 SCATTERING CROSS SECTIONS +* COMPUTE TOTAL P0 SCATTERING OUT OF GROUP +*---- + CALL REDIND(IUNIT,SUBINX,LSUBIN,XSSCMP,NSCT,14) + CALL LIBWSC(NGROUP,1,NGFR,NSCT,XSSCMP,SCAT(1,1,1),XSREC(1,IP0)) +*---- +* FOR IENDF=2 READ XS FOR NG AND TOTAL +* FOR IENDF=0,1 READ XS FOR NG AND TRANSPORT +*---- + IF(IENDF.GE.2) THEN +*---- +* READ TOTAL XS FOR IENDF=2 +*---- + CALL REDIND(IUNIT,SUBINX,LSUBIN,XSREC(:,2),NGFR,5) + CALL REDIND(IUNIT,SUBINX,LSUBIN,XSREC(:,7),NGFR,5) + ELSE +*---- +* COMPUTE TOTAL XS FOR IENDF=0,1 +*---- + CALL REDIND(IUNIT,SUBINX,LSUBIN,XSREC(:,2),NGFR,4) + CALL REDIND(IUNIT,SUBINX,LSUBIN,XSREC(:,7),NGFR,6) + ENDIF +*---- +* THERMAL XS +*---- + NTMP=SUBINX(LSUBIN+6) + IF(NTMP.GT.MAXTEM) THEN + CALL XABORT('LIBWIM: INVALID MAXTEM FOR P0.') + ENDIF + CALL REDIND(IUNIT,SUBINX,LSUBIN,NXS,NTMP,3) + CALL REDIND(IUNIT,SUBINX,LSUBIN,TMPT,NTMP,15) + IREC=16 + IF(NTMP.EQ.1) THEN + IF(IPRINT.GE.100) THEN + WRITE(IOUT,6200) TN(JSO) + ENDIF + IREC=IREC+2 + IF(NF.GT.1) THEN + CALL REDIND(IUNIT,SUBINX,LSUBIN,XSREC(NGFR+1:,3), + > NGTHER,IREC) + CALL REDIND(IUNIT,SUBINX,LSUBIN,XSREC(NGFR+1:,4), + > NGTHER,IREC+1) + ENDIF + IREC=IREC+2 + IF(NXS(1).GT.MXSCT) THEN + WRITE(IOUT,9004) NXS(1),MXSCT + CALL XABORT('LIBWIM: INVALID SCATTERING MATRIX -T/0') + ENDIF + CALL REDIND(IUNIT,SUBINX,LSUBIN,XSSCMP,NXS(1),IREC) + IREC=IREC+1 +*---- +* DECOMPRESS P0 SCATTERING CROSS SECTIONS AND COMPUTE +* P0 SCATTERING OUT OF GROUP +*---- + CALL LIBWSC(NGROUP,NGFR+1,NGROUP,NXS(1),XSSCMP, + > SCAT(1,1,1),XSREC(1,IP0)) + IF(IENDF.GE.2) THEN + CALL REDIND(IUNIT,SUBINX,LSUBIN,XSREC(NGFR+1:,2), + > NGTHER,IREC-4) + ELSE + CALL REDIND(IUNIT,SUBINX,LSUBIN,XSREC(NGFR+1:,2), + > NGTHER,IREC-5) + ENDIF + CALL REDIND(IUNIT,SUBINX,LSUBIN,XSREC(NGFR+1:,7), + > NGTHER,IREC-4) + ELSE IF(NTMP.GT.1) THEN +*---- +* AVALUATE LAGRANGIAN INTERPOLATION FACTOR FOR +* AVAILABLE TEMPERATURES (ORDER NOTX) AND INTERPOLATE. +*---- + CALL LIBLEX(NTMP,TN(JSO),TMPT,NOTX,TERP) + IF(IPRINT.GE.100) THEN + WRITE(IOUT,6201) TN(JSO) + WRITE(IOUT,6202) (TMPT(JJJ),JJJ=1,NTMP) + WRITE(IOUT,6203) (TERP(JJJ),JJJ=1,NTMP) + ENDIF + NRDT=NGTHER-1 + IACT=1 + DO 140 ITMP=1,NTMP + IF(TERP(ITMP).EQ.0.0D0) THEN + IREC=IREC+5 + ELSE + IREC=IREC+2 + IF(NF.GT.1) THEN + CALL REDIND(IUNIT,SUBINX,LSUBIN,TMPXS(ILOCY+2*NGROUP+1:), + > NGTHER,IREC) + CALL REDIND(IUNIT,SUBINX,LSUBIN,TMPXS(ILOCY+3*NGROUP+1:), + > NGTHER,IREC+1) + ELSE + TMPXS(ILOCY+2*NGROUP+1:ILOCY+2*NGROUP+NGTHER)=0.0 + TMPXS(ILOCY+3*NGROUP+1:ILOCY+3*NGROUP+NGTHER)=0.0 + ENDIF + IREC=IREC+2 + IF(NXS(ITMP).GT.MXSCT) THEN + WRITE(IOUT,9004) NXS(ITMP),MXSCT + CALL XABORT('LIBWIM: INVALID SCATTERING MATRIX -T/0') + ENDIF + CALL REDIND(IUNIT,SUBINX,LSUBIN,XSSCMP,NXS(ITMP),IREC) + IREC=IREC+1 +*---- +* DECOMPRESS P0 SCATTERING CROSS SECTIONS AND COMPUTE +* P0 SCATTERING OUT OF GROUP +*---- + CALL LIBWSC(NGROUP,NGFR+1,NGROUP,NXS(ITMP),XSSCMP, + > TMPSC(ILOCS+1),TMPXS(ILOCX+4*NGROUP+1)) + IF(IENDF.GE.2) THEN + CALL REDIND(IUNIT,SUBINX,LSUBIN,TMPXS(ILOCY+1:), + > NGTHER,IREC-4) + ELSE + CALL REDIND(IUNIT,SUBINX,LSUBIN,TMPXS(ILOCY+1:), + > NGTHER,IREC-5) + ENDIF + CALL REDIND(IUNIT,SUBINX,LSUBIN,TMPXS(ILOCY+NGROUP+1:), + > NGTHER,IREC-4) + ITXS=1 + CALL LIBWTE(IACT,ITXS,NGROUP,NGTHER,1,NF,TERP(ITMP), + > SCAT(1,1,1),XSREC(1,IP0),XSREC(1,7), + > XSREC(1,3),XSREC(1,4),XSREC(1,2),TMPXS,TMPSC) + IACT=2 + ENDIF + 140 CONTINUE + ENDIF +*---- +* BUILT CROSS SECTION FROM INFORMATION IN NG WHICH IS +* CURRENTLY ABSORPTION AND SCATTERING OUT OF GROUP +* COMPUTE REAL NG CROSS SECTION WHICH IS +* CURRENT NG (ABSORPTION)-FISSION+N2N +* SINCE ABSORPTION IS DEFINED AS +* TOTAL-SIGS WHERE SIGS CONTAINE 2*N2N SINCE A N2N CONTRIBUTION +* PRODUCES AN EQUIVALENT OF 2 NEUTRON BY DIFFUSION +*---- + DO 150 IG=1,NGROUP + XSREC(IG,1)=XSREC(IG,7)+XSREC(IG,IP0) + IF(NF.GT.1) THEN + XSREC(IG,7)=XSREC(IG,7)+XSREC(IG,8)-XSREC(IG,4) + ELSE + XSREC(IG,7)=XSREC(IG,7)+XSREC(IG,8) + ENDIF + IF(XSREC(IG,4).NE.0) THEN + XSREC(IG,6)=XSREC(IG,3)/XSREC(IG,4) + ELSE + XSREC(IG,6)=0 + ENDIF + 150 CONTINUE + IF(IENDF.LT.2) THEN +*---- +* COMPUTE TRANSPORT CORRECTION AND STORE IN TRAN +*---- + DO 151 IG=1,NGROUP + XSREC(IG,2)=XSREC(IG,1)-XSREC(IG,2) + 151 CONTINUE + ENDIF +*---- +* SELF SHIELDING DATA +*---- + NTYP=1 + XSCOR(1)=0.0 + IF(SUBINX(LSUBIN+5).EQ.3) THEN + NTYP=2 + XSCOR(2)=0.0 + ENDIF +*---- +* MODIFIED SUB IDX LENGTH FOR RESONANCE +*---- + LSUBTR=NGR+7 + LSUBZ=NGR+1 + CALL REDIND(IUNIT,MASTER,LMASIN,SUBINR,LSUBTR,NEL+5) +*---- +* MODIFIED RES IDX LENGTH FOR RESONANCE +*---- + LRESND=SUBINR(NGR+6) + IF(NTYP.EQ.2.AND.SUBINR(NGR+7).EQ.1) THEN + NTYP=3 + XSCOR(3)=0.0 + ENDIF + XSCOR(4)=0.0 + IGRF=NGF + KRES=0 + DO 300 IGR=1,NGR + IGRF=IGRF+1 + CALL REDIND(IUNIT,SUBINR,LSUBZ,RESINX,LRESND+1,IGR) + NRES=RESINX(LRESND+1) + IF(NRES.GT.MAXRES) THEN + WRITE(IOUT,9005) NRES,MAXRES + CALL XABORT('LIBWIM: INVALID NUMBER OF RESONANCE') + ENDIF + IF(IGR.EQ.1) THEN + CALL REDIND(IUNIT,RESINX,LRESND,RS1,3*NRES,1) + DO 314 IGF=1,NGFR + XSOUT(IGF,3)=XSREC(IGF,IP0) + XSOUT(IGF,4)=1.0 + XSOUT(IGF,5)=1.0 + 314 CONTINUE +*---- +* IDENTIFY SELF SHIELDING RESONNANT ISOTOPE +*---- + DO 310 JRES=1,NRES + IF(IDRES.EQ.0) THEN + XRS1=FLOAT(INT((RS1(3*(JRES-1)+1)+0.01)*10.) + > -INT(RS1(3*(JRES-1)+1)+0.01)*10)/10.+0.02 + XRS1=ABS(RS1(3*(JRES-1)+1)-XRS1-RIND) + ELSE + XRS1=ABS(RS1(3*(JRES-1)+1)-RIND) + ENDIF + IF(XRS1.LE.0.01) THEN + KRES=JRES + NTMPR=INT(RS1(3*(KRES-1)+2)+0.1) + NDILR=INT(RS1(3*(KRES-1)+3)+0.1) + IF(NTMPR.GT.MAXTEM) THEN + WRITE(IOUT,9006) NTMPR,MAXTEM + CALL XABORT('LIBWIM: INVALID NUMBER OF RES TEMP') + ELSE IF(NDILR.GT.MAXTEM) THEN + WRITE(IOUT,9007) NDILR,MAXTEM + CALL XABORT('LIBWIM: INVALID NUMBER OF RES DIL') + ENDIF + NTD=NDILR*NTMPR + IF(IPRINT.GE.5) THEN + WRITE(IOUT,6002) RS1(3*(JRES-1)+1) + ENDIF + CALL REDIND(IUNIT,RESINX,LRESND,TMPT,NTMPR,2+5*(KRES-1)) + CALL REDIND(IUNIT,RESINX,LRESND,DILT,NDILR,3+5*(KRES-1)) + IF(IPRINT.GE.100) THEN + WRITE(IOUT,6003) TN(JSO) + WRITE(IOUT,6008) (TMPT(ITT),ITT=1,NTMPR) + WRITE(IOUT,6004) SN(IGRF,JSO),DSIGPL(IGR) + WRITE(IOUT,6008) (DILT(ITT),ITT=1,NDILR) + ENDIF + DO 312 II=1,NTMPR + TMPT(II)=SQRT(TMPT(II)) + 312 CONTINUE + DO 313 II=1,NDILR + IF(DILT(II)-DSIGPL(IGR).GT.0.0) THEN + DILT(II)=SQRT(DILT(II)-DSIGPL(IGR)) + ELSE + DILT(II)=0.0 + ENDIF + 313 CONTINUE + GO TO 311 + ENDIF + 310 CONTINUE +*---- +* NO SELF SHIELDING DATA FOR THIS ISOTOPE EXIT TO 301 +*---- + XSREC(:NGROUP,10)=0.0 + GO TO 301 + ENDIF +*---- +* READ SELF SHIELDING DATA FOR THIS ISOTOPE +*---- + 311 CONTINUE +*---- +* READ FLUX FOR THIS RESONANCE INTEGRAL +*---- + IF(IENDF.GE.2) THEN +*---- +* READ TOTAL RR AND FLUX +*---- + CALL REDIND(IUNIT,RESINX,LRESND,RRI,2*NTD,4+5*(KRES-1)) + CALL LIBWRI(NTMPR,NDILR,TN(JSO),SN(IGRF,JSO),TMPT, + > DILT,RRI(1),RIT,XSOUT(IGRF,1),XSCOR(1)) + CALL LIBWRI(NTMPR,NDILR,TN(JSO),SN(IGRF,JSO),TMPT,DILT, + > RRI(NTD+1),RIT,XSOUT(IGRF,4),XSCOR(4)) + ELSE +*---- +* READ TOTAL RR +*---- + CALL REDIND(IUNIT,RESINX,LRESND,RRI,NTD,4+5*(KRES-1)) + CALL LIBWRI(NTMPR,NDILR,TN(JSO),SN(IGRF,JSO),TMPT, + > DILT,RRI(1),RIT,XSOUT(IGRF,1),XSCOR(1)) + IF(IPRINT.GE.100) THEN + WRITE(IOUT,6005) XSOUT(IGRF,1) + WRITE(IOUT,6008) (RRI(ITT),ITT=1,NTD) + ENDIF + ENDIF + IF(NTYP.GE.2) THEN +*---- +* READ FISSION RR +*---- + CALL REDIND(IUNIT,RESINX,LRESND,RRI,NTD,5+5*(KRES-1)) + CALL LIBWRI(NTMPR,NDILR,TN(JSO),SN(IGRF,JSO),TMPT,DILT, + > RRI(1),RIT,XSOUT(IGRF,2),XSCOR(2)) + IF(IPRINT.GE.100) THEN + WRITE(IOUT,6006) XSOUT(IGRF,2) + WRITE(IOUT,6008) (RRI(ITT),ITT=1,NTD) + ENDIF + IF(NTYP.GE.3) THEN +*---- +* READ SCATTERING RR +*---- + CALL REDIND(IUNIT,RESINX,LRESND,RRI,NTD, + > 6+5*(KRES-1)) + IRRICS=0 + ASIGPL=0.0 + DO 340 ILL=1,NTD + ASIGPL=ASIGPL+RRI(IRRICS+1) + IRRICS=IRRICS+1 + 340 CONTINUE + IF(ASIGPL.GT.0.0) THEN + CALL LIBWRI(NTMPR,NDILR,TN(JSO),SN(IGRF,JSO),TMPT, + > DILT,RRI(1),RIT,XSOUT(IGRF,3),XSCOR(3)) + IF(IPRINT.GE.100) THEN + WRITE(IOUT,6007) XSOUT(IGRF,3) + WRITE(IOUT,6008) (RRI(ITT),ITT=1,NTD) + ENDIF + ENDIF + ENDIF + ENDIF + 300 CONTINUE +*---- +* CORRECT CROSS SECTIONS FOR CURRENT GROUP +*---- + IGRL=IGRF + IGRF=NGF+1 + CALL LIBWRE(NTYP,IPRINT,ITLIB,NGROUP,1,IGRF,IGRL,NGR, + > SCAT,XSREC(1,IP0),XSREC(1,1),XSREC(1,7), + > XSREC(1,3),XSREC(1,4),XSREC(1,6), + > DELTA,SN(1,JSO),SB(1,JSO),XSOUT,XSCOR, + > DSIGPL) +*---- +* PRINT CROSS SECTIONS IF REQUIRED +*---- + IF(IPRINT.GE.5) THEN + WRITE(IOUT,6100) + DO 400 IG1=NGF+1,NGFR + WRITE(IOUT,6101) IG1,SN(IG1,JSO),SB(IG1,JSO), + > XSOUT(IG1,4),XSREC(IG1,1), + > XSREC(IG1,IP0),XSREC(IG1,3), + > XSREC(IG1,9) + 400 CONTINUE + ENDIF +*---- +* SET NWT0 THE RESONANCE FLUX WEIGHTING +*---- + XSREC(:NGROUP,10)=1.0 + DO 401 IG1=NGF+1,NGFR + XSREC(IG1,10)=XSOUT(IG1,4) + 401 CONTINUE + 301 CONTINUE +*---- +* P1 SCATTERING +*---- + IF(NL.EQ.2) THEN + IREC=16+NTMP*5 + NTMP=SUBINX(LSUBIN+10) + IF(NTMP+1.GT.MAXTEM) THEN + CALL XABORT('LIBWIM: INVALID MAXTEM FOR P1.') + ELSE IF(NTMP.GT.0) THEN + CALL REDIND(IUNIT,SUBINX,LSUBIN,NXS,NTMP+1,7) + CALL REDIND(IUNIT,SUBINX,LSUBIN,TMPT,NTMP,5) + NSCT=NXS(NTMP+1) + IF(NSCT.GT.MXSCT) THEN + WRITE(IOUT,9004) NSCT,MXSCT + CALL XABORT('LIBWIM: INVALID SCATTERING MATRIX -E/1') + ENDIF + CALL REDIND(IUNIT,SUBINX,LSUBIN,XSSCMP,NSCT,IREC) + IREC=IREC+1 +*---- +* DECOMPRESS P1 SCATTERING CROSS SECTIONS AND COMPUTE +* P1 SCATTERING OUT OF GROUP +*---- + CALL LIBWSC(NGROUP,1,NGFR,NSCT,XSSCMP, + > SCAT(1,1,2),XSREC(1,IP1)) + ENDIF + IF(NTMP.EQ.1) THEN + IF(NXS(1).GT.MXSCT) THEN + WRITE(IOUT,9004) NXS(1),MXSCT + CALL XABORT('LIBWIM: INVALID SCATTERING MATRIX -T/1') + ENDIF + CALL REDIND(IUNIT,SUBINX,LSUBIN,XSSCMP,NXS(1),IREC) + IREC=IREC+1 +*---- +* DECOMPRESS P1 SCATTERING CROSS SECTIONS AND COMPUTE +* P1 SCATTERING OUT OF GROUP +*---- + CALL LIBWSC(NGROUP,NGFR+1,NGROUP,NXS(1),XSSCMP, + > SCAT(1,1,2),XSREC(1,IP1)) + ELSE IF(NTMP.GT.1) THEN +*---- +* AVALUATE LAGRANGIAN INTERPOLATION FACTOR FOR +* AVAILABLE TMPTERATURES (ORDER NOTX) AND INTERPOLATE. +*---- + CALL LIBLEX(NTMP,TN(JSO),TMPT,NOTX,TERP) + NRDT=NGTHER-1 + IACT=1 + DO 170 ITMP=1,NTMP + IF(TERP(ITMP).EQ.0.0D0) THEN + IREC=IREC+1 + ELSE + IF(NXS(ITMP).GT.MXSCT) THEN + WRITE(IOUT,9004) NXS(ITMP),MXSCT + CALL XABORT('LIBWIM: INVALID SCATTERING MATRIX -T/1') + ENDIF + CALL REDIND(IUNIT,SUBINX,LSUBIN,XSSCMP,NXS(ITMP),IREC) + IREC=IREC+1 +*---- +* DECOMPRESS P1 SCATTERING CROSS SECTIONS AND COMPUTE +* P1 SCATTERING OUT OF GROUP +*---- + CALL LIBWSC(NGROUP,NGFR+1,NGROUP,NXS(ITMP),XSSCMP, + > TMPSC(ILOCS+1),TMPXS(ILOCX+4*NGROUP+1)) + ITXS=2 + CALL LIBWTE(IACT,ITXS,NGROUP,NGTHER,1,NF,TERP(ITMP), + > SCAT(1,1,2),XSREC(1,IP1),XSREC(1,7), + > XSREC(1,3),XSREC(1,4),XSREC(1,2), + > TMPXS,TMPSC) + IACT=2 + ENDIF + 170 CONTINUE + ENDIF + ENDIF +*---- +* SAVE MAIN CROSS SECTIONS ON LCM +*---- + KPLIB=IPISO(JSO) ! set JSO-th isotope + CALL LCMPTC(KPLIB,'ALIAS',12,HNAMIS) + CALL LCMPUT(KPLIB,'AWR',1,2,AWJSO) + CALL XDRLGS(KPLIB,1,IPRLOC,0,NL-1,1,NGROUP,XSREC(1,NDPROC+1), + > SCAT,ITYPRO) + CALL XDRLXS(KPLIB,1,IPRLOC,NDPROC,NAMDXS,1,NGROUP,XSREC) + CALL LCMLEN(KPLIB,'NTOT0',ILONG,ITYLCM) + IF(ILONG.EQ.0) CALL LCMPUT(KPLIB,'NTOT0',NGROUP,2,XSREC(1,1)) + WRITE(README(:8),'(A8)') HNAMIS(1:8) + READ(README,'(24A4)') (IHGAR(II),II=1,24) + CALL LCMPUT(KPLIB,'README',24,3,IHGAR) + IF(IPRINT.GE.100) CALL LCMLIB(KPLIB) + 115 CONTINUE + 110 CONTINUE + DEALLOCATE(RIT,RRI,TMPSC,TMPXS) + CALL CLSIND(IUNIT) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(DSIGPL,GAR,XSOUT,XSSCMP,SCAT,XSREC,DELTA) + DEALLOCATE(ITYPRO) +*---- +* RETURN +*---- + RETURN +*---- +* FORMAT +*---- + 9001 FORMAT(/' NUMBER OF GROUPS SPECIFIED :',I10/ + > ' NUMBER OF GROUPS IN LIBRARY :',I10) + 9002 FORMAT(/' LIBWIM: MATERIAL/ISOTOPE ',A12,' IS MISSING ON WIMS', + > ' FILE NAME ',A8) + 9003 FORMAT(/' MAXIMUM NUMBER OF ISOTOPE SPECIFIED :',I10/ + > ' NUMBER OF ISOTOPE IN LIBRARY :',I10) + 9004 FORMAT(/' DIMENSION OF SCATTERING MATRIX :',I10/ + > ' MAXIMUM DIMENSION OF SCATTERING MATRIX :',I10) + 9005 FORMAT(/' NUMBER OF RESONANT ISOTOPES :',I10/ + > ' MAXIMUM NUMBER OF RESONANT ISOTOPES :',I10) + 9006 FORMAT(/' NUMBER OF RESONANT TEMPERATURE :',I10/ + > ' MAXIMUM NUMBER OF RESONANT TEMPERATURE :',I10) + 9007 FORMAT(/' NUMBER OF RESONANT DILUTION :',I10/ + > ' MAXIMUM NUMBER OF RESONANT DILUTION :',I10) + 6000 FORMAT(' READING WIMS-AECL LIBRARY NAME ',A8) + 6001 FORMAT(' PROCESSING ISOTOPE/MATERIAL = ',A12) + 6002 FORMAT(' SELF SHIELDING ISOTOPE = ',F9.3) + 6003 FORMAT(' RESONANCE TEMPERATURE = ',1P,E15.7) + 6004 FORMAT(' RESONANCE DILUTIONS = ',1P,2E15.7) + 6005 FORMAT(' ABSORPTION RATE = ',1P,E15.7) + 6006 FORMAT(' FISSION RATE = ',1P,E15.7) + 6007 FORMAT(' SCATTERING RATE = ',1P,E15.7) + 6008 FORMAT(1P,5E15.7) + 6100 FORMAT(/5X,'GROUP',10X,'DILUT',13X,'SB',11X,'NPHI',10X,'NTOT0', + > 11X,'SIGS',9X,'NUSIGF',10X,'NGOLD') + 6101 FORMAT(5X,I5,1P,8E15.5) + 6200 FORMAT(' TEMPERATURE = ',F10.5,10X, + > ' CROSS SECTION TABULATED AT A SINGLE TEMPERATURE') + 6201 FORMAT(' TEMPERATURE = ',F10.5,10X, + > ' CROSS SECTION TABULATED AT MULTIPLE TEMPERATURES') + 6202 FORMAT(' TABULATION TEMPERATURES= ',/(5F15.5)) + 6203 FORMAT(' INTERPOLATION FACTORS = ',1P,/(5E15.5)) + END diff --git a/Dragon/src/LIBWRE.f b/Dragon/src/LIBWRE.f new file mode 100644 index 0000000..2e707f5 --- /dev/null +++ b/Dragon/src/LIBWRE.f @@ -0,0 +1,270 @@ +*DECK LIBWRE + SUBROUTINE LIBWRE(NTYP,IPRINT,ITLIB ,NGROUP,NL,IGRF,IGRL,NGR, + > SCAT,SIGS,TOTAL,XSNG,SIGF,XSFI,XNU,DELTA, + > DIL,DLJ,XSOUT,XSCOR,DSIGPL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Resonance integral temperature and dilution interpolation. +* +*Copyright: +* Copyright (C) 1997 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* NTYP types of self shielding rates: +* = 1 only absorption; +* = 2 absorption+fission; +* = 3 absorption+fission+scattering. +* IPRINT print flag. +* ITLIB types of library: +* = 1 WIMS-AECL; +* = 2 WIMS-D4. +* NGROUP number of groups. +* NL number of Legendre scattering order. +* IGRF first resonance group to treat. +* IGRL last resonance group to treat. +* NGR number of resonance groups. +* SCAT complete scattering matrix +* SCAT(JG,IG) is from IG to JG. +* SIGS total scattering out of group. +* TOTAL total XS. +* XSNG (n,g) XS. +* SIGF nu*fission XS. +* XSFI fission XS +* XNU 1/nu +* DELTA lethargy. +* DIL standard dilution. +* DLJ Livolant-Jeanpierre dilution. +* XSOUT resonnances integrals. +* XSCOR total correction. +* DSIGPL potential XS times G-C parameters. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='LIBWRE') +*---- +* INTEFACE VRAIABLES +*---- + INTEGER NTYP,IPRINT,ITLIB,NGROUP,NL,IGRF,IGRL,NGR + REAL SCAT(NGROUP,NGROUP,NL),SIGS(NGROUP,NL),TOTAL(NGROUP), + 1 XSNG(NGROUP),SIGF(NGROUP),XSFI(NGROUP), + 2 XNU(NGROUP),DELTA(NGROUP),DIL(NGROUP), + 3 DLJ(NGROUP),XSOUT(NGROUP,7),XSCOR(4),DSIGPL(NGR) +*---- +* LOCAL VARIABLES +*---- + INTEGER IGRR,JG,IG1,IG2,IL + REAL XSF,DDIL,DDLJ + DOUBLE PRECISION XNUMER,XDENOM +* +*----- +* + IF(ABS(IPRINT) .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + DO 100 IGRR=IGRF,IGRL + DDLJ=DLJ(IGRR) + DDIL=DIL(IGRR) + IF(ABS(IPRINT) .GE. 1000) THEN + WRITE(IOUT,*) 'Potential XS*GC parameter ',DSIGPL(IGRR-IGRF+1) + ENDIF + IF(NTYP.EQ.3.AND.XSCOR(3).GT.0.0) THEN +*---- +* COMPUTE FLUX +* SCATTERING IS SELF-SHIELDED +*---- + IF(IGRR .EQ. IGRF) THEN + IF(ABS(IPRINT) .GE. 100) THEN + WRITE(IOUT,6020) + ENDIF + ENDIF + IF(ITLIB.EQ.1) THEN + XNUMER=DBLE(DDLJ-XSOUT(IGRR,1)) + DO 110 JG=1,IGRR-1 + XNUMER=XNUMER+DBLE( + > XSOUT(JG,4)*DELTA(JG)*SCAT(IGRR,JG,1)/DELTA(IGRR)) + 110 CONTINUE + XDENOM=DBLE(DDLJ+SIGS(IGRR,1)-SCAT(IGRR,IGRR,1)) + XSOUT(IGRR,4)=REAL(XNUMER/XDENOM) + XNUMER=DBLE(DDIL-XSOUT(IGRR,1)) + DO 115 JG=1,IGRR-1 + XNUMER=XNUMER+DBLE( + > XSOUT(JG,5)*DELTA(JG)*SCAT(IGRR,JG,1)/DELTA(IGRR)) + 115 CONTINUE + XDENOM=DBLE(DDIL+SIGS(IGRR,1)-SCAT(IGRR,IGRR,1)) + XSOUT(IGRR,5)=REAL(XNUMER/XDENOM) + ELSE + XSOUT(IGRR,4)=(DDLJ-XSOUT(IGRR,1))/DDLJ + XSOUT(IGRR,5)=(DDIL-XSOUT(IGRR,1))/DDIL + ENDIF + IF(ABS(IPRINT) .GE. 1000) THEN + WRITE(IOUT,*) 'Flux 2 ',XSOUT(IGRR,4) + ENDIF + IF(XNU(IGRR).NE.0.0) THEN + XSOUT(IGRR,6)=XSOUT(IGRR,2)/XNU(IGRR) + ELSE + XSOUT(IGRR,6)=0.0 + ENDIF + XSOUT(IGRR,7)=XSOUT(IGRR,1)-XSOUT(IGRR,6) + IF(ABS(IPRINT) .GE. 1000) THEN + WRITE(IOUT,*) 'Total ',XSOUT(IGRR,1),XSOUT(IGRR,3), + > XSOUT(IGRR,1)+XSOUT(IGRR,3) + ENDIF + XSOUT(IGRR,1)=XSOUT(IGRR,1)+XSOUT(IGRR,3) + ELSE IF(XSCOR(1).GT.0.0) THEN +*---- +* COMPUTE FLUX AND DRAGLIB FLUX +* SCATTERING IS NOT SELF-SHIELDED +*---- + IF(IGRR .EQ. IGRF) THEN + IF(ABS(IPRINT) .GE. 100) THEN + WRITE(IOUT,6021) + ENDIF + ENDIF + IF(ITLIB.EQ.1) THEN + XNUMER=DBLE(DDLJ-XSOUT(IGRR,1)) + DO 120 JG=1,IGRR-1 + XNUMER=XNUMER+DBLE( + > XSOUT(JG,4)*DELTA(JG)*SCAT(IGRR,JG,1)/DELTA(IGRR)) + 120 CONTINUE + XDENOM=DBLE(DDLJ+SIGS(IGRR,1)-SCAT(IGRR,IGRR,1)) + XSOUT(IGRR,4)=REAL(XNUMER/XDENOM) + IF(ABS(IPRINT) .GE. 1000) THEN + WRITE(IOUT,*) 'Flux 1 ',XSOUT(IGRR,4),XNUMER,XDENOM + ENDIF + XNUMER=DBLE(DDIL-XSOUT(IGRR,1)) + DO 130 JG=1,IGRR-1 + XNUMER=XNUMER+DBLE( + > XSOUT(JG,5)*DELTA(JG)*SCAT(IGRR,JG,1)/DELTA(IGRR)) + 130 CONTINUE + XDENOM=DBLE(DDIL+SIGS(IGRR,1)-SCAT(IGRR,IGRR,1)) + XSOUT(IGRR,5)=REAL(XNUMER/XDENOM) + ELSE + XSOUT(IGRR,4)=(DDLJ-XSOUT(IGRR,1))/DDLJ + XSOUT(IGRR,5)=(DDIL-XSOUT(IGRR,1))/DDIL + IF(ABS(IPRINT) .GE. 1000) THEN + WRITE(IOUT,*) 'Flux 2 ',XSOUT(IGRR,4) + ENDIF + ENDIF + XSOUT(IGRR,3)=SIGS(IGRR,1)*XSOUT(IGRR,4) + IF(NTYP.LT.2) THEN + XSOUT(IGRR,2)=SIGF(IGRR)*XSOUT(IGRR,4) + ENDIF + IF(XNU(IGRR).NE.0.0) THEN + XSOUT(IGRR,6)=XSOUT(IGRR,2)/XNU(IGRR) + ELSE + XSOUT(IGRR,6)=0.0 + ENDIF + IF(ABS(IPRINT) .GE. 1000) THEN + WRITE(IOUT,*) 'Total ',XSOUT(IGRR,1), + > SIGS(IGRR,1)*XSOUT(IGRR,5), + > XSOUT(IGRR,1)+SIGS(IGRR,1)*XSOUT(IGRR,5) + ENDIF + XSOUT(IGRR,1)=SIGS(IGRR,1)*XSOUT(IGRR,5)+XSOUT(IGRR,1) + XSOUT(IGRR,7)=XSOUT(IGRR,1)-XSOUT(IGRR,3)-XSOUT(IGRR,6) + ELSE IF(XSOUT(IGRR,4).NE.0.0) THEN + IF(IGRR .EQ. IGRF) THEN + IF(ABS(IPRINT) .GE. 100) THEN + WRITE(IOUT,6022) + ENDIF + ENDIF + IF(XNU(IGRR).NE.0.0) THEN + XSOUT(IGRR,6)=SIGF(IGRR)*XSOUT(IGRR,4)/XNU(IGRR) + ELSE + XSOUT(IGRR,6)=0.0 + ENDIF + XSOUT(IGRR,1)=TOTAL(IGRR)*XSOUT(IGRR,4) + XSOUT(IGRR,2)=SIGF(IGRR)*XSOUT(IGRR,4) + XSOUT(IGRR,3)=SIGS(IGRR,1)*XSOUT(IGRR,4) + XSOUT(IGRR,7)=XSOUT(IGRR,1)-XSOUT(IGRR,3)-XSOUT(IGRR,6) + IF(ABS(IPRINT) .GE. 1000) THEN + WRITE(IOUT,*) 'Total ',TOTAL(IGRR)*XSOUT(IGRR,4) + ENDIF + ELSE + IF(IGRR .EQ. IGRF) THEN + IF(ABS(IPRINT) .GE. 100) THEN + WRITE(IOUT,6023) + ENDIF + ENDIF + XSOUT(IGRR,4)=1.0 + IF(XNU(IGRR).NE.0.0) THEN + XSOUT(IGRR,6)=SIGF(IGRR)/XNU(IGRR) + ELSE + XSOUT(IGRR,6)=0.0 + ENDIF + XSOUT(IGRR,1)=TOTAL(IGRR) + XSOUT(IGRR,2)=SIGF(IGRR) + XSOUT(IGRR,3)=SIGS(IGRR,1) + XSOUT(IGRR,7)=XSOUT(IGRR,1)-XSOUT(IGRR,3)-XSOUT(IGRR,6) + IF(ABS(IPRINT) .GE. 1000) THEN + WRITE(IOUT,*) 'Total ',TOTAL(IGRR) + ENDIF + ENDIF + 100 CONTINUE + DO 142 IG2=IGRF,IGRL + XSF=XSOUT(IG2,3)/(XSOUT(IG2,4)*SIGS(IG2,1)) + DO 141 IL=1,NL + DO 140 IG1=1,NGROUP + SCAT(IG1,IG2,IL)=XSF*SCAT(IG1,IG2,IL) + 140 CONTINUE + 141 CONTINUE + 142 CONTINUE + IF(ABS(IPRINT) .GE. 100) THEN + WRITE(IOUT,6010) 'FLUX ' + WRITE(IOUT,6011) (XSOUT(IG1,4),IG1=IGRF,IGRL) + WRITE(IOUT,6010) 'TOTAL RATE ' + WRITE(IOUT,6011) (XSOUT(IG1,1),IG1=IGRF,IGRL) + WRITE(IOUT,6010) 'TOTAL XS ' + WRITE(IOUT,6011) (XSOUT(IG1,1)/XSOUT(IG1,4),IG1=IGRF,IGRL) + WRITE(IOUT,6010) 'FISSION RATE ' + WRITE(IOUT,6011) (XSOUT(IG1,2),IG1=IGRF,IGRL) + WRITE(IOUT,6010) 'FISSION XS ' + WRITE(IOUT,6011) (XSOUT(IG1,2)/XSOUT(IG1,4),IG1=IGRF,IGRL) + WRITE(IOUT,6010) 'SCATTERING RATE ' + WRITE(IOUT,6011) (XSOUT(IG1,3),IG1=IGRF,IGRL) + WRITE(IOUT,6010) 'SCATTERING XS ' + WRITE(IOUT,6011) (XSOUT(IG1,3)/XSOUT(IG1,4),IG1=IGRF,IGRL) + WRITE(IOUT,6010) 'NG RATE ' + WRITE(IOUT,6011) (XSOUT(IG1,7),IG1=IGRF,IGRL) + WRITE(IOUT,6010) 'NG XS ' + WRITE(IOUT,6011) (XSOUT(IG1,7)/XSOUT(IG1,4),IG1=IGRF,IGRL) + WRITE(IOUT,6001) NAMSBR + ENDIF + DO 150 IG1=IGRF,IGRL + TOTAL(IG1)=XSOUT(IG1,1)/XSOUT(IG1,4) + SIGF(IG1)=XSOUT(IG1,2)/XSOUT(IG1,4) + XSF=XSOUT(IG1,3)/(XSOUT(IG1,4)*SIGS(IG1,1)) + SIGS(IG1,1)=XSOUT(IG1,3)/XSOUT(IG1,4) + DO IL=2,NL + SIGS(IG1,IL)=XSF*SIGS(IG1,IL) + ENDDO + XSFI(IG1)=XSOUT(IG1,6)/XSOUT(IG1,4) + XSNG(IG1)=XSOUT(IG1,7)/XSOUT(IG1,4) + 150 CONTINUE +*---- +* RETURN LIBWRE +*---- + RETURN +*---- +* FORMAT +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(' Record = ',A16) + 6011 FORMAT(1P,5E15.7) + 6020 FORMAT(' Flux computed with self shielded scattering XS.') + 6021 FORMAT(' Flux computed without self shielded scattering XS.') + 6022 FORMAT(' Flux tabulated.') + 6023 FORMAT(' Flux initialized to unity.') + END diff --git a/Dragon/src/LIBWRG.f b/Dragon/src/LIBWRG.f new file mode 100644 index 0000000..ed09303 --- /dev/null +++ b/Dragon/src/LIBWRG.f @@ -0,0 +1,148 @@ +*DECK LIBWRG + SUBROUTINE LIBWRG(IUNIT,NTYP,NGR,NRTOT,MAXTEM,MAXDIL,NSRES,RID, + > NTM,NDI,RTMP,RDIL,RESI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read resonance information from WIMS-D4 library. +* +*Copyright: +* Copyright (C) 1997 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IUNIT WIMS-D4 read unit. +* NTYP number of resonance tables per isotopes. +* NGR number of resonance groups. +* NRTOT number of resonance sets. +* MAXTEM max nb temperature. +* MAXDIL max nb dilutions. +* NSRES nb of resonance set. +* RID resonance id. +* NTM number of temperatures. +* NDI number of dilutions. +* RTMP resonance temperature. +* RDIL resonance dilution. +* RESI resonance integrals. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* PARAMETERS +*---- + INTEGER IOUT + PARAMETER (IOUT=6) +*---- +* INTERFACE PARAMETERS +*---- + INTEGER IUNIT,NTYP,NGR,NRTOT,MAXTEM,MAXDIL + INTEGER NTM(NTYP,NRTOT,NGR),NDI(NTYP,NRTOT,NGR) +* + REAL RID(NRTOT),RTMP(MAXTEM,NTYP,NRTOT,NGR), + 1 RDIL(MAXDIL,NTYP,NRTOT,NGR), + 2 RESI(MAXDIL,MAXTEM,NTYP,NRTOT,NGR) +*---- +* LOCAL VARIABLES +*---- + INTEGER IGR,NSRES,ISRES,IPREV,IRS,M1,M2,IT,ID,ISR,ITYP, + 1 NTIS + REAL XIDR,ENDR +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: TMPT,DILT + REAL, ALLOCATABLE, DIMENSION(:,:) :: REST +*---- +* SCRATCH STORAGE ALLOCATION +* TMPT : TEMPERATURE +* DILT : DILUTION +* REST : RESONANCE INTEGRALS +*---- + ALLOCATE(TMPT(MAXTEM),DILT(MAXDIL),REST(MAXDIL,MAXTEM)) +*---- +* SCAN OVER RESONANCE GROUPS +*---- + NSRES=0 + ISRES=0 + DO 100 IGR=1,NGR + IPREV=0 +*---- +* SCAN OVER RESONANCE SETS + 1 +* AND READ RESONANCE INFO +*---- + DO 110 IRS=1,NTYP*NRTOT+1 + READ(IUNIT) XIDR,M1,M2, + > (TMPT(IT),IT=1,M1),(DILT(ID),ID=1,M2), + > ((REST(ID,IT),ID=1,M2),IT=1,M1) + IF(XIDR.EQ.0.0) GO TO 115 + IF((M1.EQ.0).AND.(M2.EQ.0)) GO TO 110 + DO 120 ISR=1,NSRES + IF(XIDR.EQ.RID(ISR)) THEN + ISRES=ISR + GO TO 125 + ENDIF + 120 CONTINUE + NSRES=NSRES+1 + IF(NSRES.GT.NRTOT) THEN + CALL XABORT('LIBWRG: TO MANY RESONANCE SET') + ENDIF + ISRES=NSRES + IPREV=0 + RID(ISRES)=XIDR + 125 CONTINUE + IF(ISRES.NE.IPREV) THEN + ITYP=1 + IPREV=ISRES + ELSE IF((ISRES.EQ.IPREV).AND.(ITYP.EQ.1)) THEN + ITYP=2 + ELSE IF((ISRES.EQ.IPREV).AND.(ITYP.EQ.2)) THEN + ITYP=3 + IPREV=0 + ENDIF + NTIS=NTM(ITYP,ISRES,IGR) + IF(NTIS.GT.0) THEN + WRITE(IOUT,9000) IGR,ISRES,ITYP,XIDR + CALL XABORT('LIBWRG: DUPLICATE RESONANCE SET') + ENDIF +*---- +* SAVE RESONANCE INFORMATION FOR THIS SET +*---- + NTM(ITYP,ISRES,IGR)=M1 + NDI(ITYP,ISRES,IGR)=M2 + DO 130 IT=1,M1 + RTMP(IT,ITYP,ISRES,IGR)=TMPT(IT) + 130 CONTINUE + DO 131 ID=1,M2 + RDIL(ID,ITYP,ISRES,IGR)=DILT(ID) + 131 CONTINUE + DO 140 IT=1,M1 + DO 141 ID=1,M2 + RESI(ID,IT,ITYP,ISRES,IGR)=REST(ID,IT) + 141 CONTINUE + 140 CONTINUE + 110 CONTINUE + 115 CONTINUE + IF(NTYP.EQ.2) READ(IUNIT) ENDR + 100 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(REST,DILT,TMPT) + RETURN +*---- +* FORMAT +*---- + 9000 FORMAT(' LIBWRG ERROR - WIMS-D4 DUPLICATE RESONANCE SET'/ + > ' RESONANCE GROUP = ',I10/ + > ' RESONANCE SET = ',I10/ + > ' INTEGRAL TYPE = ',I10/ + > ' RESONANCE ID = ',F20.5) + END diff --git a/Dragon/src/LIBWRI.f b/Dragon/src/LIBWRI.f new file mode 100644 index 0000000..b590754 --- /dev/null +++ b/Dragon/src/LIBWRI.f @@ -0,0 +1,91 @@ +*DECK LIBWRI + SUBROUTINE LIBWRI(NTMPR,NDILR,TMPISO,DILISO,TMPT,DILT,REST,RIT, + > XSOUT,XSCOR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Resonance integral temperature and dilution interpolation. +* +*Copyright: +* Copyright (C) 1997 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* NTMPR number of temperature tables. +* NDILR number of dilution tables. +* TMPISO temperature of isotope. +* DILISO dilution of isotope. +* TMPT sqrt(temperature) in table. +* DILT sqrt(dilution) in table. +* REST resonance rates input. +* +*Parameters: output +* XSOUT resonance integrals. +* XSCOR resonance integrals correction. +* +*Parameters: scratch +* RIT dummy vector. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE + REAL EPSRI,SQDILI + PARAMETER (EPSRI=0.0005,SQDILI=1.0E+5) + INTEGER NTMPR,NDILR + REAL TMPISO,DILISO,TMPT(NTMPR),DILT(NDILR), + > REST(NDILR,NTMPR),RIT(NDILR),XSOUT,XSCOR + INTEGER IDIL,NDILE,JDEPT,JFINT,IR,JD + REAL SQTD,SQTT,ALPHA,AIKINT,ASLOPE +*---- +* SIMPLE LINEAR INTERFOLATION IN SQRT(TMP) +*---- + SQTD=SQRT(DILISO) + XSOUT=0.0 + DO 110 IDIL=NDILR,1,-1 + IF(DILT(IDIL).LT.SQDILI) THEN + NDILE=IDIL + GO TO 115 + ENDIF + 110 CONTINUE + RETURN + 115 CONTINUE + SQTT=SQRT(TMPISO) + IF(NTMPR.EQ.1) THEN + JDEPT=1 + JFINT=1 + ALPHA=0.0 + ELSE + JDEPT=1 + DO 100 IR=1,NTMPR-1 + IF(SQTT.GE.TMPT(IR)) JDEPT=IR + 100 CONTINUE + JFINT=JDEPT+1 + ALPHA=(SQTT-TMPT(JDEPT))/(TMPT(JFINT)-TMPT(JDEPT)) + ENDIF + DO 120 JD=1,NDILR + RIT(JD)=(1.-ALPHA)*REST(JD,JDEPT)+ + > ALPHA*REST(JD,JFINT) + 120 CONTINUE + IF(SQTD .GT. DILT(NDILE)) THEN +*---- +* INTERPOLATE LINEARLY BETWEEN LAST DILUTION IN TABLE +* AND INFINITE DILUTION +*---- + ASLOPE=(DILT(NDILE)/SQTD)**2 + XSOUT=ASLOPE*RIT(NDILE)+(1.0-ASLOPE)*RIT(NDILR) + ELSE +*---- +* AIKINT INTERPOLATION FOR DILUTION +*---- + XSOUT=AIKINT(SQTD,DILT,RIT,NDILE,EPSRI) + ENDIF + XSCOR=XSCOR+XSOUT + RETURN + END diff --git a/Dragon/src/LIBWRP.f b/Dragon/src/LIBWRP.f new file mode 100644 index 0000000..0a206a3 --- /dev/null +++ b/Dragon/src/LIBWRP.f @@ -0,0 +1,111 @@ +*DECK LIBWRP + SUBROUTINE LIBWRP(IPRINT,NTYP,NGR,NRTOT,MAXTEM,MAXDIL,IGR,IRES, + > ITYP,DSIGPL,NTM,NDI,RTMP,RDIL,RESI,NTMPR,NDILR, + > TMPT,DILT,REST) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Prepare WIMS-D4 resonance data. +* +*Copyright: +* Copyright (C) 1997 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPRINT print flag. +* NTYP number of resonance tables per isotopes. +* NGR number of resonance groups. +* NRTOT maminum number of resonant isotopes. +* MAXTEM maminum number of temperature. +* MAXDIL maminum number of dilutions. +* IGR resonance group number. +* IRES resonance isotope set. +* ITYP XS type. +* DSIGPL background XS. +* NTM number of temperatures. +* NDI number of dilutions. +* RTMP resonance temperature. +* RDIL resonance dilution. +* RESI resonance integrals. +* +*Parameters: output +* NTMPR number of local temperatures. +* NDILR number of local dilutions. +* TMPT work temperature. +* DILT work dilution. +* REST work resonance integrals. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* PARAMETERS +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='LIBWRP') +*---- +* INTERFACE VARIABLES +*---- + INTEGER IPRINT,NTYP,NGR,NRTOT,MAXTEM,MAXDIL,IGR,IRES,ITYP, + 1 NTMPR,NDILR + INTEGER NTM(NTYP,NRTOT,NGR),NDI(NTYP,NRTOT,NGR) + REAL DSIGPL + REAL RTMP(MAXTEM,NTYP,NRTOT,NGR),RDIL(MAXDIL,NTYP,NRTOT,NGR), + 1 RESI(MAXDIL,MAXTEM,NTYP,NRTOT,NGR),TMPT(MAXTEM), + 2 DILT(MAXDIL),REST(MAXDIL*MAXTEM) +*---- +* LOCAL VARIABLES +*---- + INTEGER ITT,IT,IPOS,ID + REAL XDIL +* +*---- +* + NTMPR=NTM(ITYP,IRES,IGR) + NDILR=NDI(ITYP,IRES,IGR) + IF(ABS(IPRINT) .GE. 100) THEN + WRITE(IOUT,6010) NAMSBR + WRITE(IOUT,6000) + WRITE(IOUT,6002) (RTMP(ITT,ITYP,IRES,IGR),ITT=1,NTMPR) + WRITE(IOUT,6001) + WRITE(IOUT,6002) (RDIL(ITT,ITYP,IRES,IGR),ITT=1,NDILR) + ENDIF + DO 100 IT=1,NTMPR + TMPT(IT)=SQRT(RTMP(IT,ITYP,IRES,IGR)) + 100 CONTINUE + DO 110 ID=1,NDILR + XDIL=RDIL(ID,ITYP,IRES,IGR)-DSIGPL + IF(XDIL.GT.0.0) THEN + DILT(ID)=SQRT(XDIL) + ELSE + DILT(ID)=0.0 + ENDIF + 110 CONTINUE + IPOS=0 + DO 120 IT=1,NTMPR + DO 121 ID=1,NDILR + IPOS=IPOS+1 + REST(IPOS)=RESI(ID,IT,ITYP,IRES,IGR) + 121 CONTINUE + 120 CONTINUE + IF(ABS(IPRINT) .GE. 100) THEN + WRITE(IOUT,6011) NAMSBR + ENDIF + RETURN +*---- +* FORMAT +*---- + 6000 FORMAT(' RESONANCE TEMPERATURE TABULATION = ') + 6001 FORMAT(' RESONANCE DILUTIONS TABULATION = ') + 6002 FORMAT(1P,5E15.7) + 6010 FORMAT('(* Output from --',A6,'-- follows ') + 6011 FORMAT(' Output from --',A6,'-- completed *)') + END diff --git a/Dragon/src/LIBWSC.f b/Dragon/src/LIBWSC.f new file mode 100644 index 0000000..79e3858 --- /dev/null +++ b/Dragon/src/LIBWSC.f @@ -0,0 +1,73 @@ +*DECK LIBWSC + SUBROUTINE LIBWSC(NGROUP,NGD,NGF,NSCT,CSCAT,XSCAT,SIGS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Expand WIMS format scattering cross sections. +* +*Copyright: +* Copyright (C) 1997 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* NGROUP number of groups. +* NGD starting group number. +* NGF finishing group number. +* NSCT number of elements in CSCAT. +* CSCAT WIMS condense scattering at input. +* +*Parameters: output +* XSCAT DRAGON format expanded scattering. +* SCAT(JG,IG) is from IG to JG. +* SIGS total scattering out of group. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* INTERFACE VARIABLES +*---- + INTEGER NGROUP,NGD,NGF,NSCT + REAL CSCAT(NSCT),XSCAT(NGROUP,NGROUP),SIGS(NGROUP) +*---- +* LOCAL VARIABLES +*---- + INTEGER LG,IG1,IG2,N2,IGG + DOUBLE PRECISION SUMSCT +* +*---- +* + LG=0 + DO 100 IG1=NGD,NGF + XSCAT(:NGROUP,IG1)=0.0 + LG=LG+1 + IG2=IG1-INT(CSCAT(LG)+0.1) + LG=LG+1 + N2=INT(CSCAT(LG)+0.1) + SUMSCT=0.0D0 + DO 110 IGG=1,N2 + LG=LG+1 + IG2=IG2+1 + IF(IG2.LT.1) THEN + CALL XABORT('LIBWSC: IG2 < 1') + ELSE IF(IG2.GT.NGROUP) THEN + CALL XABORT('LIBWSC: IG2 > NGROUP') + ENDIF + XSCAT(IG2,IG1)=CSCAT(LG) + SUMSCT=SUMSCT+DBLE(CSCAT(LG)) + 110 CONTINUE + SIGS(IG1)=REAL(SUMSCT) + 100 CONTINUE + IF(LG.NE.NSCT) CALL XABORT('LIBWSC: INVALID COUNT') +*---- +* RETURN LIBWSC +*---- + RETURN + END diff --git a/Dragon/src/LIBWTE.f b/Dragon/src/LIBWTE.f new file mode 100644 index 0000000..ffe4dec --- /dev/null +++ b/Dragon/src/LIBWTE.f @@ -0,0 +1,132 @@ +*DECK LIBWTE + SUBROUTINE LIBWTE(IACT,ITXS,NGROUP,NGTHER,NTMP,NF,TERP,SCAT, + > SIGS,XSNG,SIGF,XSFI,TRAN,TMPXS,TMPSC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform temperature interpolation for WIMS-AECL or WIMS-D4 XS. +* +*Copyright: +* Copyright (C) 1997 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IACT Action: +* = 1 initialize before adding; +* = 2 only add. +* ITXS type: +* = 1 all cross sections; +* = 2 only scattering. +* NGROUP number of groups. +* NGTHER number of thermal groups. +* NTMP number of temperature. +* NF flag for fissile. +* TERP temperature coefficients. +* +*Parameters: input/output +* SCAT complete scattering matrix +* SCAT(JG,IG) is from IG to JG. +* SIGS total scattering out of group. +* XSNG (n,g) XS. +* SIGF nu*fission XS. +* XSFI fission XS. +* TRAN transport XS. +* +*Parameters: scratch +* TMPXS temperature dependent vect XS. +* TMPSC temperature dependent scat XS. +* +*Comments: +* WIMS-AECL library parameters +* MAXISO : max. nb. of iso = 246 +* MLDEP : maximum number of reaction per +* isotope = MAXISO +4 +* LPZ : length of parameter array = 9 +* LMASTB : length of mst tab = MAXISO+9 +* LMASIN : length of mst idx = LMASTB-4 +* LGENTB : length of gen tab = 6 +* LGENIN : length of gen idx = LGENTB +* MASTER : master index array +* GENINX : general index array +* NPZ : list of main parameters +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* INTERFACE VARIABLES +*---- + INTEGER IACT,ITXS,NGROUP,NGTHER,NTMP,NF + DOUBLE PRECISION TERP(NTMP) + REAL SCAT(NGROUP,NGROUP),SIGS(NGROUP), + 1 XSNG(NGROUP),SIGF(NGROUP),XSFI(NGROUP), + 2 TRAN(NGROUP),TMPXS(NGROUP,5,NTMP), + 3 TMPSC(NGROUP,NGROUP,NTMP) +*---- +* LOCAL VARIABLES +*---- + INTEGER IGF,ITM,IGD,NGD + REAL RTERP +*---- +* INITIALIZED IF REQUIRED +*---- + NGD=NGROUP-NGTHER+1 + IF(IACT.EQ.1) THEN + IF(ITXS.EQ.1) THEN + XSNG(NGD:NGD+NGTHER-1)=0.0 + TRAN(NGD:NGD+NGTHER-1)=0.0 + IF(NF.GT.1) THEN + SIGF(NGD:NGD+NGTHER-1)=0.0 + XSFI(NGD:NGD+NGTHER-1)=0.0 + ENDIF + ENDIF + IF(ITXS.GE.1) THEN + SIGS(NGD:NGD+NGTHER-1)=0.0 + DO 110 IGD=NGD,NGROUP + SCAT(:NGROUP,IGD)=0.0 + 110 CONTINUE + ENDIF + ENDIF +*---- +* INTERPOLATE STANDARD CROSS SECTIONS IN TEMPERATURE +*---- + IF(ITXS.EQ.1) THEN + DO 120 ITM=1,NTMP + RTERP=REAL(TERP(ITM)) + IF(RTERP.NE.0.0) THEN + DO 121 IGD=NGD,NGROUP + TRAN(IGD)=TRAN(IGD)+RTERP*TMPXS(IGD,1,ITM) + XSNG(IGD)=XSNG(IGD)+RTERP*TMPXS(IGD,2,ITM) + IF(NF.GT.1) THEN + SIGF(IGD)=SIGF(IGD)+RTERP*TMPXS(IGD,3,ITM) + XSFI(IGD)=XSFI(IGD)+RTERP*TMPXS(IGD,4,ITM) + ENDIF + 121 CONTINUE + ENDIF + 120 CONTINUE + ENDIF +*---- +* INTERPOLATE SCATTERING CROSS SECTIONS IN TEMPERATURE +*---- + IF(ITXS.GE.1) THEN + DO 130 ITM=1,NTMP + RTERP=REAL(TERP(ITM)) + IF(RTERP.NE.0.0D0) THEN + DO 131 IGD=NGD,NGROUP + SIGS(IGD)=SIGS(IGD)+RTERP*TMPXS(IGD,5,ITM) + DO 132 IGF=1,NGROUP + SCAT(IGF,IGD)=SCAT(IGF,IGD)+RTERP*TMPSC(IGF,IGD,ITM) + 132 CONTINUE + 131 CONTINUE + ENDIF + 130 CONTINUE + ENDIF + RETURN + END diff --git a/Dragon/src/LIBWTF.f b/Dragon/src/LIBWTF.f new file mode 100644 index 0000000..abcd5f5 --- /dev/null +++ b/Dragon/src/LIBWTF.f @@ -0,0 +1,61 @@ +*DECK LIBWTF + SUBROUTINE LIBWTF(NGROUP,NTMP,TERP,SCAT,SIGS,TMPXS,TMPSC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform temperature interpolation for WIMS-E P1 scattering matrices. +* +*Copyright: +* Copyright (C) 2016 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NGROUP number of energy groups. +* NTMP number of temperatures. +* TERP temperature coefficients. +* TMPXS temperature dependent vectorial scattering cross sections. +* TMPSC temperature dependent scattering matrix. +* +*Parameters: output +* SCAT complete scattering matrix from ig to jg. +* SIGS scattering cross sections. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* INTERFACE VARIABLES +*---- + INTEGER NGROUP,NTMP + DOUBLE PRECISION TERP(NTMP) + REAL SCAT(NGROUP,NGROUP),SIGS(NGROUP), + > TMPXS(NGROUP,NTMP),TMPSC(NGROUP,NGROUP,NTMP) +*---- +* LOCAL VARIABLES +*---- + INTEGER IGF,ITM,IGD + REAL RTERP +*---- +* INTERPOLATE SCATTERING CROSS SECTIONS IN TEMPERATURE +*---- + SIGS(:NGROUP)=0.0 + SCAT(:NGROUP,:NGROUP)=0.0 + DO 130 ITM=1,NTMP + RTERP=REAL(TERP(ITM)) + IF(RTERP.NE.0.0D0) THEN + DO 131 IGD=1,NGROUP + SIGS(IGD)=SIGS(IGD)+RTERP*TMPXS(IGD,ITM) + DO 132 IGF=1,NGROUP + SCAT(IGF,IGD)=SCAT(IGF,IGD)+RTERP*TMPSC(IGF,IGD,ITM) + 132 CONTINUE + 131 CONTINUE + ENDIF + 130 CONTINUE + RETURN + END diff --git a/Dragon/src/LIBXS1.f b/Dragon/src/LIBXS1.f new file mode 100644 index 0000000..767fd5a --- /dev/null +++ b/Dragon/src/LIBXS1.f @@ -0,0 +1,44 @@ +*DECK LIBXS1 + SUBROUTINE LIBXS1(CFILNA,NEL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Initialize dimensions for depletion data with APOLIB-XSM. +* +*Copyright: +* Copyright (C) 2014 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input +* CFILNA APOLIB-XSM file name. +* +*Parameters: output +* NEL number of isotopes on library. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER CFILNA*(*) + INTEGER NEL +*---- +* Local variables +*---- + TYPE(C_PTR) IPAP +* + CALL LCMOP(IPAP,CFILNA,2,2,0) + CALL LCMSIX(IPAP,'PHEAD',1) + CALL LCMLEN(IPAP,'NOM',NV,ITYLCM) + NEL=NV/5 + CALL LCMSIX(IPAP,' ',2) + CALL LCMCL(IPAP,1) + RETURN + END diff --git a/Dragon/src/LIBXS2.f b/Dragon/src/LIBXS2.f new file mode 100644 index 0000000..2fdd82c --- /dev/null +++ b/Dragon/src/LIBXS2.f @@ -0,0 +1,292 @@ +*DECK LIBXS2 + SUBROUTINE LIBXS2(CFILNA,MAXR,NEL,NMDEPL,ITNAM,ITZEA,KPAX,BPAX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read depletion data on an APOLIB-XSM formatted library. +* +*Copyright: +* Copyright (C) 2014 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input +* CFILNA APOLIB-XSM file name. +* MAXR number of reaction types. +* NEL number of isotopes on library. +* NMDEPL names of reactions: +* NMDEPL(1)='DECAY'; NMDEPL(2)='NFTOT'; +* NMDEPL(3)='NG' ; NMDEPL(4)='N2N'; +* etc. +* +*Parameters: output +* ITNAM reactive isotope names in chain. +* ITZEA 6-digit nuclide identifier: +* atomic number z*10000 (digits) + mass number a*10 + +* energy state (0 = ground state, 1 = first state, etc.). +* KPAX complete reaction type matrix. +* BPAX complete branching ratio matrix. +* +*Comments: +* INPUT FORMAT +* LIB: APLIB2 FIL: CFILNA CHAIN +* [[ hnamson +* [ FROM [[ { DECAY | reaction } yield hnampar ]] ] +* ]] +* ENDCHAIN +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER CFILNA*(*),NMDEPL(MAXR)*8 + INTEGER MAXR,NEL,ITNAM(3,NEL),ITZEA(NEL),KPAX(NEL+MAXR,NEL) + REAL BPAX(NEL+MAXR,NEL) +* + TYPE(C_PTR) IPAP + PARAMETER (IOUT=6) + CHARACTER TEXT20*20,TEXT12*12,HNISOR*20,HITNAM*20,HSMG*131 + DOUBLE PRECISION DBLINP + REAL E458(9) +*---- +* SCRATCH STORAGE ALLOCATION +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NOM,IA,IZ,NFG,IKEEP + REAL, ALLOCATABLE, DIMENSION(:) :: GAMMA,RTSEGM + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HSECTT +*---- +* OPEN APOLIB FILE +*---- + CALL LCMOP(IPAP,CFILNA,2,2,0) +*---- +* RECOVER INFORMATION FROM PHEAD DIRECTORY +*---- + CALL LCMSIX(IPAP,'PHEAD',1) + CALL LCMLEN(IPAP,'NOM',NV,ITYLCM) + NISOT=NV/5 + ALLOCATE(NOM(5*NISOT)) + CALL LCMGET(IPAP,'NOM',NOM) + DO 20 ISO=1,NISOT + WRITE(HNISOR,'(5A4)') (NOM((ISO-1)*5+II),II=1,5) + READ(HNISOR,'(3A4)') (ITNAM(II,ISO),II=1,3) + 20 CONTINUE + CALL LCMSIX(IPAP,' ',2) +*---- +* RECOVER INFORMATION FROM PCONST DIRECTORY +*---- + CALL LCMSIX(IPAP,'PCONST',1) + CALL LCMLIB(IPAP) + CALL LCMLEN(IPAP,'A',NV,ITYLCM) + IF(NV.NE.NISOT) CALL XABORT('LIBXS2: IA OVERFLOW') + ALLOCATE(IA(NISOT),IZ(NISOT),NFG(NISOT)) + CALL LCMGET(IPAP,'A',IA) + CALL LCMGET(IPAP,'Z',IZ) + CALL LCMGET(IPAP,'NFG',NFG) + CALL LCMSIX(IPAP,' ',2) +*---- +* RECOVER INFORMATION FROM PNUMF DIRECTORY +*---- + CALL LCMSIX(IPAP,'PNUMF',1) + CALL LCMLEN(IPAP,'GAMMA',NGAMMA,ITYLCM) + CALL LCMLEN(IPAP,'NOMFIS',NBFISS,ITYLCM) + CALL LCMLEN(IPAP,'NOMPF',NBPF,ITYLCM) + NBFISS=NBFISS/2 + NBPF=NBPF/2 + ALLOCATE(GAMMA(NGAMMA)) + CALL LCMGET(IPAP,'GAMMA',GAMMA) + NMGY=NGAMMA/(NBFISS*NBPF) + CALL LCMSIX(IPAP,' ',2) +*---- +* LOOP OVER ISOTOPES +*---- + CALL LCMSIX(IPAP,'QFIX',1) + DO 260 ISO=1,NISOT + WRITE(HNISOR,'(5A4)') (NOM((ISO-1)*5+II),II=1,5) + WRITE(TEXT12,'(4HISOT,I8.8)') ISO + CALL LCMSIX(IPAP,TEXT12,1) + CALL LCMSIX(IPAP,'ISOTOP',1) +* NG ENERGY. + CALL LCMLEN(IPAP,'EGAMM',NV,ITYLCM) + IF(NV.NE.0) THEN + KPAX(NEL+3,ISO)=1 + CALL LCMGET(IPAP,'EGAMM',BPAX(NEL+3,ISO)) + ENDIF +* FISSION ENERGIES. + CALL LCMLEN(IPAP,'EF',NV,ITYLCM) + IF(NV.NE.0) THEN + KPAX(NEL+2,ISO)=1 + CALL LCMGET(IPAP,'EF',BPAX(NEL+2,ISO)) + ENDIF + CALL LCMLEN(IPAP,'ENER_458',NV,ITYLCM) + IF(NV.NE.0) THEN + KPAX(NEL+2,ISO)=1 + CALL LCMGET(IPAP,'ENER_458',E458) + BPAX(NEL+2,ISO)=E458(8) + ENDIF +* RADIOACTIVE DECAY CONSTANTS. + CALL LCMLEN(IPAP,'LAMBD0',NCHANN,ITYLCM) + IF(NCHANN.GT.0) THEN + ALLOCATE(RTSEGM(NCHANN)) + CALL LCMGET(IPAP,'LAMBD0',RTSEGM) + SUM=0.0 + DO 140 I=1,NCHANN + SUM=SUM+RTSEGM(I) + 140 CONTINUE + DEALLOCATE(RTSEGM) + IF(SUM.NE.0.0) BPAX(NEL+1,ISO)=SUM*1.0E8 + ENDIF +* X-S NAMES. + CALL LCMLEN(IPAP,'TYSECT',NV,ITYLCM) + NSECTT=NV/2 + ALLOCATE(HSECTT(NSECTT)) + CALL LCMGTC(IPAP,'TYSECT',8,NSECTT,HSECTT) + DO 150 IS=1,NSECTT + IF(HSECTT(IS).EQ.'SIGA') THEN + KPAX(NEL+3,ISO)=1 + ELSE IF(HSECTT(IS).EQ.'NEXCESS') THEN + KPAX(NEL+4,ISO)=1 + ELSE IF(HSECTT(IS).EQ.'SIGF') THEN + KPAX(NEL+2,ISO)=1 + ELSE IF(HSECTT(IS).EQ.'CREA-A') THEN + KPAX(NEL+7,ISO)=1 + ELSE IF(HSECTT(IS).EQ.'CREA-P') THEN + KPAX(NEL+8,ISO)=1 + ELSE IF(HSECTT(IS).EQ.'CREA-H2') THEN + KPAX(NEL+11,ISO)=1 + ELSE IF(HSECTT(IS).EQ.'CREA-H3') THEN + KPAX(NEL+12,ISO)=1 + ENDIF + 150 CONTINUE + DEALLOCATE(HSECTT) +*---- +* SET OTHER INFORMATION. +*---- + ITZEA(ISO)=IZ(ISO)*10000+IA(ISO)*10 + IPF=NFG(ISO) + IF(IPF.LT.0) THEN + KPAX(NEL+2,ISO)=-1 + DO 250 JSO=1,NISOT + IFI=NFG(JSO) + IF(IFI.GT.0) THEN + IOFSET=((-IPF-1)*NBFISS+(IFI-1))*NMGY+NMGY + IF(IOFSET.GT.NGAMMA) CALL XABORT('LIBXS2: GAMMA OVERFLOW.') + BPAX(ISO,JSO)=GAMMA(IOFSET) + IF(BPAX(ISO,JSO).NE.0.0) KPAX(ISO,JSO)=2 + ENDIF + 250 CONTINUE + ENDIF + CALL LCMSIX(IPAP,' ',2) + CALL LCMSIX(IPAP,' ',2) + 260 CONTINUE + CALL LCMSIX(IPAP,' ',2) +* + DEALLOCATE(GAMMA,NFG,IZ,IA,NOM) + CALL LCMCL(IPAP,1) +*---- +* RECOVER INFORMATION FROM INPUT DATA STREAM. +*---- + ALLOCATE(IKEEP(NEL)) + IKEEP(:NEL)=0 + TEXT12=' ' + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + IF(INDIC.NE.3.OR.TEXT12.NE.'CHAIN') + > CALL XABORT('LIBXS2: KEYWORD CHAIN MISSING') + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + DO 340 IEL=1,NEL + IF(TEXT12.EQ.'ENDCHAIN') GO TO 350 + IF(INDIC.NE.3) CALL XABORT('LIBXS2: ISOTOPE NAME hnamson MISSING') + I1=INDEX(TEXT12,'_') + HNISOR=' ' + IF(I1.EQ.0) THEN + HNISOR(:12)=TEXT12 + ELSE + HNISOR(:I1-1)=TEXT12(:I1-1) + ENDIF + IDEPL=0 + DO 270 JEL=1,NEL + WRITE(TEXT12,'(3A4)') (ITNAM(II,JEL),II=1,3) + I1=INDEX(TEXT12,'_') + HITNAM=' ' + IF(I1.EQ.0) THEN + HITNAM(:12)=TEXT12 + ELSE + HITNAM(:I1-1)=TEXT12(:I1-1) + ENDIF + IF(HNISOR.EQ.HITNAM) THEN + IDEPL=JEL + GO TO 280 + ENDIF + 270 CONTINUE + WRITE(HSMG,'(25HLIBXS2: MISSING ISOTOPE '',A12,5H''(1).)') + > HNISOR + CALL XABORT(HSMG) + 280 IKEEP(IDEPL)=1 + IF(BPAX(NEL+1,IDEPL).NE.0.0) KPAX(NEL+1,IDEPL)=1 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + IF(INDIC.NE.3) CALL XABORT('LIBXS2: REACTION TYPE EXPECTED') + IF(TEXT12.EQ.'FROM') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP) + 290 IF(INDIC.NE.3) CALL XABORT('LIBXS2: REACTION TYPE EXPECTED') + DO 330 IREAC=1,MAXR + RRAT=1.0 + IF(TEXT12.EQ.NMDEPL(IREAC)) THEN + DO 320 JEL=1,NEL + CALL REDGET(INDIC,ISOT,RRAT,TEXT12,DBLINP) + IF(INDIC.NE.2) GO TO 290 + CALL REDGET(INDIC,ISOT,FLOTT,TEXT12,DBLINP) + IF(INDIC.NE.3) CALL XABORT('LIBXS2: ISOTOPE NAME HNAMPAR ' + > //'MISSING') + I1=INDEX(TEXT12,'_') + TEXT20=' ' + IF(I1.EQ.0) THEN + TEXT20(:12)=TEXT12 + ELSE + TEXT20(:I1-1)=TEXT12(:I1-1) + ENDIF + JDEPL=0 + DO 300 JREL=1,NEL + WRITE(TEXT12,'(3A4)') (ITNAM(II,JREL),II=1,3) + I1=INDEX(TEXT12,'_') + HITNAM=' ' + IF(I1.EQ.0) THEN + HITNAM(:12)=TEXT12 + ELSE + HITNAM(:I1-1)=TEXT12(:I1-1) + ENDIF + IF(TEXT20.EQ.HITNAM) THEN + JDEPL=JREL + GO TO 310 + ENDIF + 300 CONTINUE + WRITE(HSMG,'(25HLIBXS2: MISSING ISOTOPE '',A12,5H''(2).)') + > TEXT20 + CALL XABORT(HSMG) + 310 KPAX(IDEPL,JDEPL)=IREAC + BPAX(IDEPL,JDEPL)=RRAT + 320 CONTINUE + CALL XABORT('LIBXS2: TO MANY PARENT ISOTOPES') + ENDIF + 330 CONTINUE + ENDIF + 340 CONTINUE + IF(INDIC.NE.3.OR.TEXT12.NE.'ENDCHAIN') + > CALL XABORT('LIBXS2: KEYWORD ENDCHAIN MISSING') + 350 DO 380 JEL=1,NEL + IF(IKEEP(JEL).EQ.0) THEN + DO 360 IREAC=1,NEL+MAXR + KPAX(IREAC,JEL)=0 + 360 CONTINUE + DO 370 IEL=1,NEL + KPAX(JEL,IEL)=0 + 370 CONTINUE + ENDIF + 380 CONTINUE + DEALLOCATE(IKEEP) + RETURN + END diff --git a/Dragon/src/LIBXS3.f b/Dragon/src/LIBXS3.f new file mode 100644 index 0000000..9b319a1 --- /dev/null +++ b/Dragon/src/LIBXS3.f @@ -0,0 +1,50 @@ +*DECK LIBXS3 + SUBROUTINE LIBXS3 (NAMFIL,NGRO,IPENER) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover energy group information from an APOLIB-XSM library. +* +*Copyright: +* Copyright (C) 2014 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NAMFIL name of the APOLIB-XSM file. +* +*Parameters: output +* NGRO number of energy groups. +* IPENER pointer of the energy mesh limit array. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* Subroutine arguments +*---- + INTEGER NGRO + CHARACTER NAMFIL*(*) + TYPE(C_PTR) IPENER +*---- +* Local variables +*---- + TYPE(C_PTR) IPAP + REAL, POINTER, DIMENSION(:) :: ENERG +* + CALL LCMOP(IPAP,NAMFIL,2,2,0) + CALL LCMSIX(IPAP,'PMAIL',1) + CALL LCMLEN(IPAP,'E',NV,ITYLCM) + NGRO=NV-1 + IPENER=LCMARA(NGRO+1) + CALL C_F_POINTER(IPENER,ENERG,(/ NGRO+1 /)) + CALL LCMGET(IPAP,'E',ENERG) + CALL LCMSIX(IPAP,' ',2) + CALL LCMCL(IPAP,1) + RETURN + END diff --git a/Dragon/src/LIBXS4.f b/Dragon/src/LIBXS4.f new file mode 100644 index 0000000..6debb37 --- /dev/null +++ b/Dragon/src/LIBXS4.f @@ -0,0 +1,958 @@ +*DECK LIBXS4 + SUBROUTINE LIBXS4 (IPLIB,NAMFIL,NGRO,NBISO,NL,IPROC,ISONAM, + 1 ISONRF,IPISO,ISHINA,MASKI,TN,SN,SB,IMPX,NGF,NGFR,NDEL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transcription of the useful interpolated microscopic cross section +* data from APOLIB-XSM to LCM data structures. +* +*Copyright: +* Copyright (C) 2014 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* NAMFIL name of the APOLIB-XSM file. +* NGRO number of energy groups. +* NBISO number of isotopes present in the calculation domain. +* NL number of Legendre orders required in the calculation +* NL=1 or higher. +* IPROC type of library processing. +* ISONAM alias name of isotopes. +* ISONRF library reference name of isotopes. +* IPISO pointer array towards microlib isotopes. +* ISHINA self shielding names. +* MASKI isotopic mask. Isotope with index I is processed if +* MASKI(I)=.true. +* TN temperature of each isotope. +* SN dilution cross section in each energy group of each +* isotope. a value of 1.0E10 is used for infinite dilution. +* SB dilution cross section as used by Livolant and Jeanpierre +* normalization. +* IMPX print flag. +* +*Parameters: output +* NGF number of fast groups without self-shielding. +* NGFR number of fast and resonance groups. +* NDEL number of precursor groups for delayed neutrons. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB,IPISO(NBISO) + INTEGER NGRO,NBISO,NL,IPROC,ISONAM(3,NBISO),ISONRF(3,NBISO), + 1 ISHINA(3,NBISO),IMPX,NGF,NGFR,NDEL + REAL TN(NBISO),SN(NGRO,NBISO),SB(NGRO,NBISO) + CHARACTER NAMFIL*(*) + LOGICAL MASKI(NBISO) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPAP + LOGICAL LSACO + PARAMETER (IOUT=6,MAXHOM=9,LSACO=.FALSE.) +* NOTE: LSACO MUST BE SET TO .TRUE. WITH THE SANCHEZ-COSTE METHOD. + TYPE(C_PTR) KPLIB + EXTERNAL LIBA21 + CHARACTER TEXT20*20,TEXT80*80,HNAMIS*12,HNISOR*12,HNISSS*12, + 1 HSMG*131,TEXT2*2,TEXT12*12 + LOGICAL LTRAN,LGPROB,LGTDIF,LGTTRA,LN2N,L104,LABS,LDIF, + 1 LFIS,LPWD,LPED + INTEGER ZFISS,FGTD,FGHOMO,FGRESO,FAGG,FDGG,WGAL,FAG + DOUBLE PRECISION UU,XDRCST + INTEGER ITHOMO(MAXHOM),ITEXT(20) + REAL TKT(5) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPRO,NFS,NOM,NOMS,ISECTT, + 1 IFDG,IIAD,IDEPL + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IPR + REAL, ALLOCATABLE, DIMENSION(:) :: ENERG,DELTA,SECT,XSTOT,TAUX, + 1 DELTF,SIGTF,SIGAF,SIGFF,ENER,AMASS,TEMP,TEMPS,SEQHO,PWD,PED,DKA, + 2 DKD,DKF,DK104 + REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGS,CHID + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LGTRE + REAL, POINTER, DIMENSION(:) :: RTSEGM +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IPR(2,NBISO),ITYPRO(NL),NFS(NGRO)) + ALLOCATE(ENERG(NGRO+1),DELTA(NGRO),SECT(NGRO),SIGS(NGRO,NL), + 1 SCAT(NGRO,NGRO,NL),XSTOT(NGRO)) +* + ANEUT=REAL(XDRCST('Neutron mass','amu')) + NGF=NGRO+1 + NGFR=0 + NDEL=0 + IF(IMPX.GT.0) WRITE (IOUT,800) NAMFIL +*---- +* OPEN THE APOLIB-XSM FILE. +*---- + CALL LCMOP(IPAP,NAMFIL,2,2,0) +*---- +* RECOVER INFORMATION FROM PHEAD DIRECTORY +*---- + CALL LCMSIX(IPAP,'PHEAD',1) + IF(IMPX.GT.0) THEN + CALL LCMGTC(IPAP,'COMH',80,TEXT80) + WRITE (IOUT,810) TEXT80 + WRITE (IOUT,'(40H LIBXS4: NUMBER OF ISOTOPES IN MICROLIB=,I6)') + 1 NBISO + ENDIF + CALL LCMLEN(IPAP,'NOM',NV,ITYLCM) + NISOT=NV/5 + ALLOCATE(NOM(5*NISOT)) + CALL LCMGET(IPAP,'NOM',NOM) + IF(IMPX.GE.10) THEN + DO ISO=1,NISOT + WRITE(TEXT20,'(5A4)') (NOM((ISO-1)*5+II),II=1,5) + WRITE(IOUT,'(8H -----> ,A20)') TEXT20 + ENDDO + ENDIF + CALL LCMLEN(IPAP,'NOMS',NV,ITYLCM) + NISOTS=NV/5 + ALLOCATE(NOMS(5*NISOTS)) + CALL LCMGET(IPAP,'NOMS',NOMS) + IF(IMPX.GE.10) THEN + DO ISO=1,NISOTS + WRITE(TEXT20,'(5A4)') (NOMS((ISO-1)*5+II),II=1,5) + WRITE(IOUT,'(8H -----> ,A20)') TEXT20 + ENDDO + ENDIF + CALL LCMSIX(IPAP,' ',2) +*---- +* RECOVER INFORMATION FROM PMAIL DIRECTORY +*---- + CALL LCMSIX(IPAP,'PMAIL',1) + CALL LCMLEN(IPAP,'E',NV,ITYLCM) + NGRO=NV-1 + CALL LCMGET(IPAP,'E',ENERG) + CALL LCMGET(IPAP,'DEL',DELTA) + CALL LCMPUT(IPLIB,'ENERGY',NGRO+1,2,ENERG) + CALL LCMPUT(IPLIB,'DELTAU',NGRO,2,DELTA) + CALL LCMSIX(IPAP,' ',2) +*---- +* RECOVER INFORMATION FROM PCONST DIRECTORY +*---- + CALL LCMSIX(IPAP,'PCONST',1) + CALL LCMLEN(IPAP,'AMASS',NAMASS,ITYLCM) + IF(NAMASS.NE.NISOT) CALL XABORT('LIBXS4: INVALID AWR INFO.') + ALLOCATE(AMASS(NAMASS)) + CALL LCMGET(IPAP,'AMASS',AMASS) + DO IA=1,NAMASS + AMASS(IA)=AMASS(IA)/ANEUT + ENDDO + CALL LCMSIX(IPAP,' ',2) +*---- +* SET THE CORRESPONDANCE BETWEEN THE APOLIB AND THE LIST OF ISOTOPES. +*---- + IF(IMPX.GT.1) WRITE(IOUT,820) NISOT,NISOTS + IPR(:2,:NBISO)=0 + CALL KDRCPU(TK1) + DO 50 IMX=1,NBISO + IF(MASKI(IMX)) THEN + WRITE(HNISOR,'(3A4)') (ISONRF(I0,IMX),I0=1,3) + WRITE(HNISSS,'(3A4)') (ISHINA(I0,IMX),I0=1,3) + KISO=0 + DO 10 ISO=1,NISOT + IF(ISONRF(1,IMX).EQ.NOM((ISO-1)*5+1)) THEN + IF(ISONRF(2,IMX).EQ.NOM((ISO-1)*5+2)) THEN + IF(ISONRF(3,IMX).EQ.NOM((ISO-1)*5+3)) THEN + KISO=ISO + GO TO 20 + ENDIF + ENDIF + ENDIF + 10 CONTINUE + WRITE (HSMG,780) HNISOR,NAMFIL + CALL XABORT(HSMG) + 20 IPR(1,IMX)=KISO +* + IF((NISOTS.GT.0).AND.(HNISSS.NE.' ')) THEN + KISO=0 + DO 30 ISO=1,NISOTS + IF(ISHINA(1,IMX).EQ.NOMS((ISO-1)*5+1)) THEN + IF(ISHINA(2,IMX).EQ.NOMS((ISO-1)*5+2)) THEN + IF(ISHINA(3,IMX).EQ.NOMS((ISO-1)*5+3)) THEN + KISO=ISO + GO TO 40 + ENDIF + ENDIF + ENDIF + 30 CONTINUE + WRITE (HSMG,790) HNISSS,NAMFIL + CALL XABORT(HSMG) + 40 IPR(2,IMX)=KISO + ENDIF + ENDIF + 50 CONTINUE + DEALLOCATE(NOM) + IF(NISOTS.GT.0) DEALLOCATE(NOMS) + CALL KDRCPU(TK2) + TKT(1)=TK2-TK1 +*---- +* READ THROUGH APOLIB-XSM FILE AND ACCUMULATE CROSS SECTIONS FOR THIS +* RANGE OF MATS, LEGENDRE ORDERS, AND GROUPS. +*---- + CALL LCMGET(IPLIB,'ENERGY',ENERG) + DO 560 IMX=1,NBISO +*---- +* PROCESS INFINITE DILUTION INFORMATION. +*---- + CALL LCMSIX(IPAP,'QFIX',1) + KISEG=IPR(1,IMX) + IF(KISEG.GT.0) THEN + CALL KDRCPU(TK1) + IF(IMPX.GT.1) WRITE(IOUT,'(/29H LIBXS4: PROCESSING ISOTOPE '', + 1 3A4,2H''.)') (ISONRF(I0,IMX),I0=1,3) + WRITE(TEXT12,'(4HISOT,I8.8)') KISEG + CALL LCMSIX(IPAP,TEXT12,1) + WRITE(TEXT80,'(19HAPOLIB-XSM ISOTOPE:,3A4)') (ISONRF(I0,IMX), + 1 I0=1,3) + READ(TEXT80,'(20A4)') (ITEXT(I),I=1,20) + IF(IMPX.GT.2) WRITE(IOUT,870) TEXT80 +*---- +* RECOVER INFORMATION FROM ISOTOP DIRECTORY +*---- + CALL LCMSIX(IPAP,'ISOTOP',1) + CALL LCMGET(IPAP,'LGPROB',LGPROB) + CALL LCMGET(IPAP,'ZFISS',ZFISS) + CALL LCMGET(IPAP,'LGTTRA',LGTTRA) + CALL LCMGET(IPAP,'FGTD',FGTD) + CALL LCMLEN(IPAP,'ID2',NV,ITYLCM) + IF(NV.EQ.1) THEN + CALL LCMGET(IPAP,'ID2',ID2) + ELSE + ID2=0 + ENDIF + CALL LCMLEN(IPAP,'TEMP',NTEMP,ITYLCM) + ALLOCATE(TEMP(NTEMP)) + CALL LCMGET(IPAP,'TEMP',TEMP) + CALL LCMLEN(IPAP,'NANISD',NV,ITYLCM) + IF(NV.EQ.1) THEN + CALL LCMGET(IPAP,'NANISD',NANISD) + CALL LCMGET(IPAP,'NANIST',NANIST) + ELSE + NANISD=0 + NANIST=0 + ENDIF + CALL LCMLEN(IPAP,'LGTREA',NSECTT,ITYLCM) + ALLOCATE(LGTRE(NSECTT),ISECTT(2*NSECTT)) + CALL LCMGET(IPAP,'LGTREA',LGTRE) + CALL LCMGET(IPAP,'TYSECT',ISECTT) + IF(IMPX.GT.2) WRITE(IOUT,880) (TEMP(I),I=1,NTEMP) + IF(IMPX.GT.2) WRITE(IOUT,890) ZFISS,LGPROB,LGTDIF,LGTTRA, + 1 FGTD,ID2,NSECTT,NANISD,NANIST,(LGTRE(I),I=1,NSECTT) + IF(NANIST.GT.NANISD) CALL XABORT('LIBXS4: NANIST.GT.NANISD') + CALL LCMLEN(IPAP,'PPPSN',NV,ITYLCM) + LTRAN=(NV.NE.0) + IF(LTRAN) THEN + CALL LCMSIX(IPAP,'PPPSN',1) + CALL LCMGET(IPAP,'FAGG',FAGG) + CALL LCMGET(IPAP,'LAGG',LAGG) + CALL LCMGET(IPAP,'FDGG',FDGG) + CALL LCMGET(IPAP,'WGAL',WGAL) + CALL LCMGET(IPAP,'FAG',FAG) + CALL LCMGET(IPAP,'LAG',LAG) + CALL LCMGET(IPAP,'NGTD',NGTD) + CALL LCMLEN(IPAP,'FDG',NV,ITYLCM) + ALLOCATE(IFDG(NV)) + CALL LCMGET(IPAP,'FDG',IFDG) + CALL LCMLEN(IPAP,'IAD',NV,ITYLCM) + ALLOCATE(IIAD(NV)) + CALL LCMGET(IPAP,'IAD',IIAD) + CALL LCMLEN(IPAP,'DEPL',NGTD,ITYLCM) + ALLOCATE(IDEPL(NGTD)) + CALL LCMGET(IPAP,'DEPL',IDEPL) + IF(IMPX.GT.2) WRITE(IOUT,900) FAGG,LAGG,FDGG,WGAL,FAG,LAG, + 1 NGTD + CALL LCMSIX(IPAP,' ',2) + ENDIF + CALL LCMSIX(IPAP,' ',2) +*---- +* RECOVER INFORMATION FROM PSECT DIRECTORY +*---- + CALL LCMSIX(IPAP,'PSECT',1) + CALL LCMSIX(IPAP,'DIFP0',1) + CALL LCMLEN(IPAP,'SECT',NV,ITYLCM) + ALLOCATE(RTSEGM(NV)) + CALL LCMGET(IPAP,'SECT',RTSEGM) + DO JMX=IMX,NBISO + IF(IPR(1,JMX).EQ.KISEG) THEN + KPLIB=IPISO(JMX) ! set JMX-th isotope + CALL LCMLEN(KPLIB,'ALIAS',ILENG,ITYLCM) + IF(ILENG.EQ.0) THEN + WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3) + CALL LCMPTC(KPLIB,'ALIAS',12,HNAMIS) + IF(IPR(1,JMX).LE.0) CALL XABORT('LIBXS4: BAD AWR.') + CALL LCMPUT(KPLIB,'AWR',1,2,AMASS(IPR(1,JMX))) + CALL LCMPUT(KPLIB,'README',20,3,ITEXT) + ENDIF + CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT) + CALL LCMPUT(KPLIB,'NTOT0',NGRO,2,SECT) + CALL LCMPUT(KPLIB,'SIGS00',NGRO,2,SECT) + ENDIF + ENDDO + DEALLOCATE(RTSEGM) + CALL LCMSIX(IPAP,' ',2) + CALL LCMLEN(IPAP,'SIGA',NV,ITYLCM) + IF(NV.NE.0) THEN + CALL LCMSIX(IPAP,'SIGA',1) + CALL LCMLEN(IPAP,'SECT',NV,ITYLCM) + ALLOCATE(RTSEGM(NV)) + CALL LCMGET(IPAP,'SECT',RTSEGM) + DO JMX=IMX,NBISO + IF(IPR(1,JMX).EQ.KISEG) THEN + KPLIB=IPISO(JMX) ! set JMX-th isotope + CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM, + 1 SECT) + CALL LCMGET(KPLIB,'NTOT0',XSTOT) + DO IG=1,NGRO + XSTOT(IG)=XSTOT(IG)+SECT(IG) + ENDDO + CALL LCMPUT(KPLIB,'NTOT0',NGRO,2,XSTOT) + ENDIF + ENDDO + DEALLOCATE(RTSEGM) + CALL LCMSIX(IPAP,' ',2) + ENDIF + CALL LCMLEN(IPAP,'NEXCESS',NV,ITYLCM) + IF(NV.NE.0) THEN + CALL LCMSIX(IPAP,'NEXCESS',1) + CALL LCMLEN(IPAP,'SECT',NV,ITYLCM) + IF(NV.EQ.NGRO) THEN + ALLOCATE(RTSEGM(NV)) + CALL LCMGET(IPAP,'SECT',RTSEGM) + DO JMX=IMX,NBISO + IF(IPR(1,JMX).EQ.KISEG) THEN + KPLIB=IPISO(JMX) ! set JMX-th isotope + CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT) + CALL LCMGET(KPLIB,'SIGS00',SIGS) + LN2N=.FALSE. + DO IG=1,NGRO + LN2N=LN2N.OR.(SECT(IG).NE.0.0) + SIGS(IG,1)=SIGS(IG,1)+SECT(IG) + ENDDO + IF(LN2N) THEN + CALL LCMPUT(KPLIB,'N2N',NGRO,2,SECT) + CALL LCMPUT(KPLIB,'SIGS00',NGRO,2,SIGS) + ENDIF + ENDIF + ENDDO + DEALLOCATE(RTSEGM) + ENDIF + CALL LCMSIX(IPAP,' ',2) + ENDIF + CALL LCMLEN(IPAP,'SIGF',NV,ITYLCM) + IF(NV.NE.0) THEN + CALL LCMSIX(IPAP,'SIGF',1) + CALL LCMLEN(IPAP,'SECT',NV,ITYLCM) + IF(NV.EQ.NGRO) THEN + ALLOCATE(RTSEGM(NV)) + CALL LCMGET(IPAP,'SECT',RTSEGM) + DO JMX=IMX,NBISO + IF(IPR(1,JMX).EQ.KISEG) THEN + KPLIB=IPISO(JMX) ! set JMX-th isotope + CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT) + CALL LCMPUT(KPLIB,'NFTOT',NGRO,2,SECT) + ENDIF + ENDDO + DEALLOCATE(RTSEGM) + ENDIF + CALL LCMSIX(IPAP,' ',2) + ENDIF + CALL LCMLEN(IPAP,'NUSIGF',NV,ITYLCM) + IF(NV.NE.0) THEN + CALL LCMSIX(IPAP,'NUSIGF',1) + CALL LCMLEN(IPAP,'SECT',NV,ITYLCM) + IF(NV.EQ.NGRO) THEN + ALLOCATE(RTSEGM(NV)) + CALL LCMGET(IPAP,'SECT',RTSEGM) + DO JMX=IMX,NBISO + IF(IPR(1,JMX).EQ.KISEG) THEN + KPLIB=IPISO(JMX) ! set JMX-th isotope + CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT) + CALL LCMPUT(KPLIB,'NUSIGF',NGRO,2,SECT) + ENDIF + ENDDO + DEALLOCATE(RTSEGM) + ENDIF + CALL LCMSIX(IPAP,' ',2) + ENDIF + CALL LCMLEN(IPAP,'CHI',NV,ITYLCM) + IF(NV.NE.0) THEN + CALL LCMSIX(IPAP,'CHI',1) + CALL LCMLEN(IPAP,'SECT',NV,ITYLCM) + IF(NV.EQ.NGRO) THEN + ALLOCATE(RTSEGM(NV)) + CALL LCMGET(IPAP,'SECT',RTSEGM) + DO JMX=IMX,NBISO + IF(IPR(1,JMX).EQ.KISEG) THEN + KPLIB=IPISO(JMX) ! set JMX-th isotope + CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT) + CALL LCMPUT(KPLIB,'CHI',NGRO,2,SECT) + ENDIF + ENDDO + DEALLOCATE(RTSEGM) + ENDIF + CALL LCMSIX(IPAP,' ',2) + ENDIF + CALL LCMLEN(IPAP,'CREA-A',NV,ITYLCM) + IF(NV.NE.0) THEN + CALL LCMSIX(IPAP,'CREA-A',1) + CALL LCMLEN(IPAP,'SECT',NV,ITYLCM) + IF(NV.EQ.NGRO) THEN + ALLOCATE(RTSEGM(NV)) + CALL LCMGET(IPAP,'SECT',RTSEGM) + DO JMX=IMX,NBISO + IF(IPR(1,JMX).EQ.KISEG) THEN + KPLIB=IPISO(JMX) ! set JMX-th isotope + CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT) + CALL LCMPUT(KPLIB,'NA',NGRO,2,SECT) + ENDIF + ENDDO + DEALLOCATE(RTSEGM) + ENDIF + CALL LCMSIX(IPAP,' ',2) + ENDIF + CALL LCMLEN(IPAP,'CREA-P',NV,ITYLCM) + IF(NV.NE.0) THEN + CALL LCMSIX(IPAP,'CREA-P',1) + CALL LCMLEN(IPAP,'SECT',NV,ITYLCM) + IF(NV.EQ.NGRO) THEN + ALLOCATE(RTSEGM(NV)) + CALL LCMGET(IPAP,'SECT',RTSEGM) + DO JMX=IMX,NBISO + IF(IPR(1,JMX).EQ.KISEG) THEN + KPLIB=IPISO(JMX) ! set JMX-th isotope + CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT) + CALL LCMPUT(KPLIB,'NP',NGRO,2,SECT) + ENDIF + ENDDO + DEALLOCATE(RTSEGM) + ENDIF + CALL LCMSIX(IPAP,' ',2) + ENDIF + CALL LCMLEN(IPAP,'CREA-H2',NV,ITYLCM) + IF(NV.NE.0) THEN + CALL LCMSIX(IPAP,'CREA-H2',1) + CALL LCMLEN(IPAP,'SECT',NV,ITYLCM) + IF(NV.EQ.NGRO) THEN + ALLOCATE(RTSEGM(NV)) + CALL LCMGET(IPAP,'SECT',RTSEGM) + DO JMX=IMX,NBISO + IF(IPR(1,JMX).EQ.KISEG) THEN + KPLIB=IPISO(JMX) ! set JMX-th isotope + CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT) + CALL LCMPUT(KPLIB,'ND',NGRO,2,SECT) + ENDIF + ENDDO + DEALLOCATE(RTSEGM) + ENDIF + CALL LCMSIX(IPAP,' ',2) + ENDIF + CALL LCMLEN(IPAP,'CREA-H3',NV,ITYLCM) + IF(NV.NE.0) THEN + CALL LCMSIX(IPAP,'CREA-H3',1) + CALL LCMLEN(IPAP,'SECT',NV,ITYLCM) + IF(NV.EQ.NGRO) THEN + ALLOCATE(RTSEGM(NV)) + CALL LCMGET(IPAP,'SECT',RTSEGM) + DO JMX=IMX,NBISO + IF(IPR(1,JMX).EQ.KISEG) THEN + KPLIB=IPISO(JMX) ! set JMX-th isotope + CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT) + CALL LCMPUT(KPLIB,'NT',NGRO,2,SECT) + ENDIF + ENDDO + DEALLOCATE(RTSEGM) + ENDIF + CALL LCMSIX(IPAP,' ',2) + ENDIF + CALL LCMSIX(IPAP,' ',2) +*---- +* RECOVER SCATTERING INFORMATION FROM ISOTOP DIRECTORY +*---- + CALL LCMSIX(IPAP,'ISOTOP',1) + IF(.NOT.LTRAN) THEN + DO JMX=IMX,NBISO + IF(IPR(1,JMX).EQ.KISEG) THEN + KPLIB=IPISO(JMX) ! set JMX-th isotope + CALL LCMGET(KPLIB,'SIGS00',SIGS) + SCAT(:NGRO,:NGRO,1)=0.0 + DO IG=1,NGRO + SCAT(IG,IG,1)=SIGS(IG,1) + ENDDO + CALL XDRLGS(KPLIB,1,IMPX,0,0,1,NGRO,SIGS,SCAT,ITYPRO) + ENDIF + ENDDO + ELSE + CALL LCMLEN(IPAP,'PSN',NV,ITYLCM) + IF(NV.EQ.0) CALL XABORT('LIBXS4: PPPSN MISSING.') + ALLOCATE(RTSEGM(NV)) + CALL LCMGET(IPAP,'PSN',RTSEGM) + DO JMX=IMX,NBISO + IF(IPR(1,JMX).EQ.KISEG) THEN + KPLIB=IPISO(JMX) ! set JMX-th isotope + SCAT(:NGRO,:NGRO,1)=0.0 + CALL LIBA23(NGRO,1,TN(JMX),NTEMP,NGTD,NV,TEMP,FGTD,ID2, + 1 FAGG,LAGG,FDGG,WGAL,FAG,LAG,IFDG,IIAD,IDEPL,RTSEGM,SCAT) + CALL LCMGET(KPLIB,'SIGS00',SIGS) + IF(LGPROB) THEN + DO IG=1,NGRO + DO JG=1,NGRO + SCAT(JG,IG,1)=SCAT(JG,IG,1)*SIGS(IG,1) + ENDDO + ENDDO + ENDIF + CALL XDRLGS(KPLIB,1,IMPX,0,0,1,NGRO,SIGS,SCAT,ITYPRO) + ENDIF + ENDDO + DEALLOCATE(RTSEGM) + ENDIF + CALL LCMSIX(IPAP,' ',2) + CALL KDRCPU(TK2) + TKT(2)=TKT(2)+(TK2-TK1) +*---- +* RECOVER SCATTERING X-S FOR HIGHER LEGENDRE ORDERS. +*---- + CALL KDRCPU(TK1) + DO 270 IL=2,MIN(NANISD,NL) + WRITE(TEXT2,'(I2.2)') IL-1 + WRITE(TEXT12,'(4HDIFF,I8.8)') IL-1 + CALL LCMLEN(IPAP,TEXT12,NV,ITYLCM) + IF(NV.EQ.0) THEN + CALL LCMLIB(IPAP) + WRITE(HSMG,'(42HLIBXS4: MISSING SCATTERING MATRIX OF ORDER, + 1 I4,1H.)') IL-1 + CALL XABORT(HSMG) + ENDIF + CALL LCMSIX(IPAP,TEXT12,1) + CALL LCMLEN(IPAP,'SECT',NV,ITYLCM) + IF(NV.EQ.0) CALL XABORT('LIBXS4: ZERO SCATTERING RECORD.') + ALLOCATE(RTSEGM(NV)) + CALL LCMGET(IPAP,'SECT',RTSEGM) + DO 260 JMX=IMX,NBISO + IF(IPR(1,JMX).EQ.KISEG) THEN + KPLIB=IPISO(JMX) ! set JMX-th isotope + CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT) + CALL LCMPUT(KPLIB,'SIGS'//TEXT2,NGRO,2,SECT) + IF(IL.GT.NANIST) THEN + SCAT(:NGRO,:NGRO,1)=0.0 + DO IG=1,NGRO + SIGS(IG,1)=SECT(IG) + SCAT(IG,IG,1)=SECT(IG) + ENDDO + CALL XDRLGS(KPLIB,1,IMPX,IL-1,IL-1,1,NGRO,SIGS,SCAT, + 1 ITYPRO) + ENDIF + ENDIF + 260 CONTINUE + CALL LCMSIX(IPAP,' ',2) + DEALLOCATE(RTSEGM) + 270 CONTINUE +*---- +* RECOVER TRANSFER MATRICES FOR HIGHER LEGENDRE ORDERS. +*---- + DO 300 IL=2,MIN(NANIST,NL) + WRITE(TEXT2,'(I2.2)') IL-1 + WRITE(TEXT12,'(4HTRAN,I8.8)') IL-1 + CALL LCMLEN(IPAP,TEXT12,NV,ITYLCM) + IF(NV.EQ.0) THEN + CALL LCMLIB(IPAP) + WRITE(HSMG,'(40HLIBXS4: MISSING TRANSFER MATRIX OF ORDER,I4, + 1 1H.)') IL-1 + CALL XABORT(HSMG) + ENDIF + CALL LCMSIX(IPAP,TEXT12,1) + CALL LCMLEN(IPAP,'PSN',NV,ITYLCM) + IF(NV.EQ.0) CALL XABORT('LIBXS4: ZERO TRANSFER RECORD.') + ALLOCATE(RTSEGM(NV)) + CALL LCMGET(IPAP,'PSN',RTSEGM) + DO 290 JMX=IMX,NBISO + IF(IPR(1,JMX).EQ.KISEG) THEN + KPLIB=IPISO(JMX) ! set JMX-th isotope + CALL LIBA23(NGRO,IL,TN(JMX),NTEMP,NGTD,NV,TEMP,FGTD,ID2, + 1 FAGG,LAGG,FDGG,WGAL,FAG,LAG,IFDG,IIAD,IDEPL,RTSEGM,SCAT) + CALL LCMGET(KPLIB,'SIGS'//TEXT2,SIGS) + IF(LGPROB) THEN + DO IG=1,NGRO + DO JG=1,NGRO + SCAT(JG,IG,1)=SCAT(JG,IG,1)*SIGS(IG,1) + ENDDO + ENDDO + ENDIF + CALL XDRLGS(KPLIB,1,IMPX,IL-1,IL-1,1,NGRO,SIGS,SCAT,ITYPRO) + ENDIF + 290 CONTINUE + CALL LCMSIX(IPAP,' ',2) + DEALLOCATE(RTSEGM) + 300 CONTINUE + CALL KDRCPU(TK2) + TKT(3)=TKT(3)+(TK2-TK1) +*---- +* RECOVER DELAYED NEUTRON DATA. +*---- + CALL KDRCPU(TK1) + CALL LCMLEN(IPAP,'BETAEF',NV,ITYLCM) + IF(NV.NE.0) THEN + CALL LCMSIX(IPAP,'BETAEF',1) + CALL LCMLEN(IPAP,'WD',NDEL0,ITYLCM) + IF(NDEL0.GT.0) THEN + LPWD=.TRUE. + NDEL=MAX(NDEL,NDEL0) + ALLOCATE(PWD(NDEL0)) + CALL LCMGET(IPAP,'WD',PWD) + ENDIF + CALL LCMLEN(IPAP,'PED',NV,ITYLCM) + IF(NV.EQ.NGRO) THEN + LPED=.TRUE. + ALLOCATE(PED(NGRO)) + CALL LCMGET(IPAP,'PED',PED) + ENDIF + DO 340 JMX=IMX,NBISO + IF(IPR(1,JMX).EQ.KISEG) THEN + KPLIB=IPISO(JMX) ! set JMX-th isotope + CALL LCMLEN(IPAP,'LAMBDA',NV,ITYLCM) + IF(NV.GT.0) THEN + NDEL=MAX(NDEL,NV) + ALLOCATE(RTSEGM(NV)) + CALL LCMGET(IPAP,'LAMBDA',RTSEGM) + CALL LCMPUT(KPLIB,'LAMBDA-D',NV,2,RTSEGM) + DEALLOCATE(RTSEGM) + ENDIF + CALL LCMLEN(IPAP,'CHID',NV,ITYLCM) + IF((NV.GT.0).AND.(NV.EQ.NDEL0*NGRO)) THEN + ALLOCATE(CHID(NGRO,NDEL0)) + CALL LCMGET(IPAP,'CHID',CHID) + DO IDEL=1,NDEL0 + WRITE(TEXT2,'(I2.2)') IDEL + CALL LCMPUT(KPLIB,'CHI'//TEXT2,NGRO,2,CHID(1,IDEL)) + ENDDO + DEALLOCATE(CHID) + ENDIF + ENDIF + 340 CONTINUE + IF(LPWD.AND.LPED) THEN + DO 390 JMX=IMX,NBISO + IF(IPR(1,JMX).EQ.KISEG) THEN + KPLIB=IPISO(JMX) ! set JMX-th isotope + DO 380 IDEL=1,NDEL0 + WRITE(TEXT2,'(I2.2)') IDEL + CALL LCMGET(KPLIB,'NUSIGF',SECT) + DO 370 IGR=1,NGRO + SECT(IGR)=SECT(IGR)*PWD(IDEL)*PED(IGR) + 370 CONTINUE + CALL LCMPUT(KPLIB,'NUSIGF'//TEXT2,NGRO,2,SECT) + 380 CONTINUE + ENDIF + 390 CONTINUE + ENDIF + IF(LPWD) DEALLOCATE(PWD) + IF(LPED) DEALLOCATE(PED) + CALL LCMSIX(IPAP,' ',2) + ENDIF + CALL LCMSIX(IPAP,' ',2) + DO JMX=IMX,NBISO + IF(IPR(1,JMX).EQ.KISEG) IPR(1,JMX)=0 + ENDDO + IF(LTRAN) DEALLOCATE(IDEPL,IIAD,IFDG) + DEALLOCATE(ISECTT,LGTRE,TEMP) + CALL KDRCPU(TK2) + TKT(2)=TKT(2)+(TK2-TK1) + IF((IMPX.GT.9).AND.(IPR(1,IMX).EQ.0)) THEN + KPLIB=IPISO(IMX) ! set IMX-th isotope + CALL LCMLIB(KPLIB) + ENDIF + ENDIF + CALL LCMSIX(IPAP,' ',2) +*---- +* PROCESS SELF-SHIELDING INFORMATION. +*---- + L104=.FALSE. + CALL LCMSIX(IPAP,'QFIXS',1) + KISEG=IPR(2,IMX) + IF(KISEG.GT.0) THEN + CALL KDRCPU(TK1) + IF(IMPX.GT.1) WRITE(IOUT,'(/31H LIBXS4: PROCESSING SELF SHIELD, + 1 13HING ISOTOPE '',3A4,2H''.)') (ISHINA(I0,IMX),I0=1,3) + WRITE(TEXT12,'(4HISOT,I8.8)') KISEG + CALL LCMSIX(IPAP,TEXT12,1) + CALL LCMSIX(IPAP,'SSDATA',1) + CALL LCMLEN(IPAP,'ITHOMO',NTHOMO,ITYLCM) + IF(NTHOMO.GT.MAXHOM) CALL XABORT('LIBXS4: ITHOMO OVERFLOW.') + CALL LCMGET(IPAP,'ITHOMO',ITHOMO) + FGHOMO=ITHOMO(1) + LGHOMO=ITHOMO(2) + FGRESO=ITHOMO(3) + NGHOMO=LGHOMO-FGHOMO+1 + ALLOCATE(TAUX(7*NGHOMO)) + TAUX(:7*NGHOMO)=0.0 + CALL LCMGET(IPAP,'OXM',IOXM) + NGF=MIN(NGF,FGHOMO) + NGFR=MAX(NGFR,LGHOMO) + CALL LCMLEN(IPAP,'SEQHOM',NSEQHO,ITYLCM) + ALLOCATE(SEQHO(NSEQHO)) + CALL LCMGET(IPAP,'SEQHOM',SEQHO) + CALL LCMLEN(IPAP,'TEMPS',NTEMPS,ITYLCM) + ALLOCATE(TEMPS(NTEMPS)) + CALL LCMGET(IPAP,'TEMPS',TEMPS) + IF(IMPX.GT.1) THEN + WRITE(IOUT,910) (SEQHO(I),I=1,NSEQHO) + WRITE(IOUT,920) (TEMPS(I),I=1,NTEMPS) + WRITE(IOUT,930) FGHOMO,FGRESO,NGHOMO,NSEQHO,NTEMPS + ENDIF + CALL LCMSIX(IPAP,'PTHOM2',1) + LENGTH=NGHOMO*NTEMPS*NSEQHO + ALLOCATE(DKA(LENGTH),DKD(LENGTH),DKF(LENGTH),DK104(LENGTH)) + DKA(:LENGTH)=0.0 + DKD(:LENGTH)=0.0 + DKF(:LENGTH)=0.0 + DK104(:LENGTH)=0.0 + CALL LCMLEN(IPAP,'ABSOH',NV,ITYLCM) + LABS=NV.EQ.LENGTH + CALL LCMLEN(IPAP,'DIFFH',NV,ITYLCM) + LDIF=NV.EQ.LENGTH + CALL LCMLEN(IPAP,'FISSH',NV,ITYLCM) + LFIS=NV.EQ.LENGTH + IF(LABS) CALL LCMGET(IPAP,'ABSOH',DKA) + IF(LDIF) CALL LCMGET(IPAP,'DIFFH',DKD) + IF(LFIS) THEN + CALL LCMGET(IPAP,'FISSH',DKF) + LFIS=.FALSE. + DO I=1,LENGTH + LFIS=LFIS.OR.(DKF(I).NE.0.0) + ENDDO + ENDIF + DO 460 JMX=IMX,NBISO + IF(IPR(2,JMX).EQ.KISEG) THEN + WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3) + KPLIB=IPISO(JMX) ! set JMX-th isotope + IF(IMPX.GT.3) WRITE(6,'(/17H LIBXS4: PROCESS ,A12,1H:)') + 1 HNAMIS + CALL LIBA24(HNAMIS,NGRO,FGHOMO,NGHOMO,NSEQHO,NTEMPS,LFIS,L104, + 1 SEQHO,TEMPS,TN(JMX),SN(1,JMX),DKA,DKD,DKF,DK104,IMPX,TAUX) +* +* COMPUTE THE SELF-SHIELDED FLUX AND CROSS SECTIONS. + CALL LIBA25(KPLIB,LABS,LDIF,LFIS,L104,NGRO,FGHOMO,NGHOMO, + 1 NSEQHO,NL,SEQHO,SN(1,JMX),SB(1,JMX),DELTA,ISONAM(1,JMX), + 2 TAUX,IMPX) + ENDIF + 460 CONTINUE + CALL LCMSIX(IPAP,' ',2) ! PTHOM2 + CALL LCMSIX(IPAP,' ',2) ! SSDATA + DEALLOCATE(DK104,DKF,DKD,DKA) + CALL KDRCPU(TK2) + TKT(4)=TKT(4)+(TK2-TK1) +*---- +* RECOVER THE AUTOLIB (BIN CROSS SECTIONS) INFORMATION. +*---- + CALL KDRCPU(TK1) + CALL LCMLEN(IPAP,'SSSECT',NV,ITYLCM) + IF((NV.NE.0).AND.(IPROC.GE.3)) THEN + CALL KDRCPU(TK1) + CALL LCMSIX(IPAP,'SSSECT',1) + LBIN=0 + NFS(:NGRO)=0 + NGBIN=MIN(NGHOMO,NGRO-FGRESO+1) + DO IG=1,NGBIN + WRITE(TEXT12,'(6HPTHOM5,I6.6)') IG + CALL LCMSIX(IPAP,TEXT12,1) + CALL LCMSIX(IPAP,'NTEMPS000001',1) + CALL LCMLEN(IPAP,'DELTF',NFS(FGRESO+IG-1),ITYLCM) + LBIN=LBIN+NFS(FGRESO+IG-1) + CALL LCMSIX(IPAP,' ',2) + CALL LCMSIX(IPAP,' ',2) + ENDDO + IF(LSACO) THEN + NFSBIN=NFS(FGRESO) + LBIN=LBIN+(FGRESO-FGHOMO)*NFSBIN + ELSE + NFSBIN=0 + ENDIF + DO 530 JMX=IMX,NBISO + IF(IPR(2,JMX).EQ.KISEG) THEN + ALLOCATE(DELTF(LBIN),SIGTF(LBIN),SIGAF(LBIN),SIGFF(LBIN)) + IOF=(FGRESO-FGHOMO)*NFSBIN + KPLIB=IPISO(JMX) ! set JMX-th isotope + DO 500 IG=1,NGBIN + IGG=FGRESO+IG-1 + WRITE(TEXT12,'(6HPTHOM5,I6.6)') IG + CALL LCMSIX(IPAP,TEXT12,1) + CALL LIBXS5(IG,NGBIN,IPAP,NFS(IGG),TN(JMX),NTEMPS,TEMPS, + 1 DELTF(IOF+1),SIGTF(IOF+1),SIGAF(IOF+1),SIGFF(IOF+1),DELINF, + 2 SGTINF,SGAINF,SGFINF) + CALL LCMSIX(IPAP,' ',2) + IG2=IG+FGRESO-FGHOMO + F1=DELTA(IGG)/DELINF + F2=(TAUX(4*NGHOMO+IG2)+ + 1 TAUX(5*NGHOMO+IG2))/(SGTINF*DELTA(IGG)) + F3=TAUX(4*NGHOMO+IG2)/(SGAINF*DELTA(IGG)) + IF(SGFINF.NE.0.0) THEN + F4=TAUX(6*NGHOMO+IG2)/(SGFINF*DELTA(IGG)) + ELSE + F4=0.0 + ENDIF + DO 490 I=1,NFS(IGG) + DELTF(IOF+I)=DELTF(IOF+I)*F1 + SIGTF(IOF+I)=SIGTF(IOF+I)*F2 + SIGAF(IOF+I)=SIGAF(IOF+I)*F3 + IF(SGFINF.NE.0.0) SIGFF(IOF+I)=SIGFF(IOF+I)*F4 + 490 CONTINUE + IOF=IOF+NFS(IGG) + 500 CONTINUE +*---- +* PROCESS THE UNRESOLVED ENERGY DOMAIN. THE AUTOLIB OF THE FIRST +* RESOLVED ENERGY GROUP IS USED AND NORMALIZED TO THE CORRECT +* INFINITE DILUTION VALUES. USED WITH THE SANCHEZ-COSTE METHOD. +*---- + IF(LSACO) THEN + E0=ENERG(FGHOMO) + IG2=FGRESO-FGHOMO+1 + E1=DELTA(FGRESO) + E2=(TAUX(4*NGHOMO+IG2)+TAUX(5*NGHOMO+IG2)) + E3=TAUX(4*NGHOMO+IG2) + E4=TAUX(6*NGHOMO+IG2) + IBIN=0 + DO 515 IGG=FGHOMO,FGRESO-1 + NFS(IGG)=NFSBIN + IG2=IGG-FGHOMO+1 + F1=DELTA(IGG)/E1 + F2=(TAUX(4*NGHOMO+IG2)+TAUX(5*NGHOMO+IG2))/E2 + F3=TAUX(4*NGHOMO+IG2)/E3 + IF(E4.NE.0.0) F4=TAUX(6*NGHOMO+IG2)/E4 + JBIN=(FGRESO-FGHOMO)*NFSBIN + DO 510 I=1,NFSBIN + IBIN=IBIN+1 + JBIN=JBIN+1 + DELTF(IBIN)=DELTF(JBIN)*F1 + SIGTF(IBIN)=SIGTF(JBIN)*F2/F1 + SIGAF(IBIN)=SIGAF(JBIN)*F3/F1 + IF(E4.NE.0.0) SIGFF(IBIN)=SIGFF(JBIN)*F4/F1 + 510 CONTINUE + 515 CONTINUE + ELSE + E0=ENERG(FGRESO) + ENDIF +* + ALLOCATE(ENER(LBIN+1)) + ENER(1)=E0 + UU=0.0D0 + DO 520 I=1,LBIN + UU=UU+DELTF(I) + ENER(I+1)=REAL(E0*EXP(-UU)) + SIGAF(I)=SIGTF(I)-SIGAF(I) + 520 CONTINUE + DEALLOCATE(DELTF) + CALL LCMPUT(KPLIB,'BIN-NFS',NGRO,1,NFS) + CALL LCMPUT(KPLIB,'BIN-ENERGY',LBIN+1,2,ENER) + CALL LCMPUT(KPLIB,'BIN-NTOT0',LBIN,2,SIGTF) + CALL LCMPUT(KPLIB,'BIN-SIGS00',LBIN,2,SIGAF) + IF(SGFINF.NE.0.0) CALL LCMPUT(KPLIB,'BIN-SIGF',LBIN,2,SIGFF) + DEALLOCATE(ENER,SIGFF,SIGAF,SIGTF) + ENDIF + 530 CONTINUE + CALL KDRCPU(TK2) + TKT(5)=TKT(5)+(TK2-TK1) + CALL LCMSIX(IPAP,' ',2) ! SSSECT + ENDIF + DO JMX=IMX,NBISO + IF(IPR(2,JMX).EQ.KISEG) IPR(2,JMX)=0 + ENDDO + CALL LCMSIX(IPAP,' ',2) ! ISOT + DEALLOCATE(TAUX,TEMPS,SEQHO) + ENDIF + CALL LCMSIX(IPAP,' ',2) ! QFIXS + 560 CONTINUE + CALL LCMCL(IPAP,1) +*---- +* CHECK IF ALL REACTIONS HAVE BEEN PROCESSED. +*---- + DO 575 IMX=1,NBISO + DO 570 I=1,2 + IF(IPR(I,IMX).NE.0) THEN + WRITE(HSMG,950) I,(ISONAM(I0,IMX),I0=1,3) + CALL XABORT(HSMG) + ENDIF + 570 CONTINUE + 575 CONTINUE + IF(IMPX.GT.2) WRITE(IOUT,940) (TKT(I),I=1,5) +*---- +* ADD NG CROSS SECTIONS. +*---- + DO 610 IMX=1,NBISO + IF(MASKI(IMX)) THEN + KPLIB=IPISO(IMX) ! set IMX-th isotope + CALL LCMGET(KPLIB,'NTOT0',SECT) + CALL LCMLEN(KPLIB,'SIGS00',LENGT,ITYLCM) + IF(LENGT.EQ.NGRO) THEN + CALL LCMGET(KPLIB,'SIGS00',XSTOT) + DO 580 IU=1,NGRO + SECT(IU)=SECT(IU)-XSTOT(IU) + 580 CONTINUE + ENDIF + CALL LCMLEN(KPLIB,'NFTOT',LENGT,ITYLCM) + IF(LENGT.EQ.NGRO) THEN + CALL LCMGET(KPLIB,'NFTOT',XSTOT) + DO 590 IU=1,NGRO + SECT(IU)=SECT(IU)-XSTOT(IU) + 590 CONTINUE + ENDIF + CALL LCMLEN(KPLIB,'N2N',LENGT,ITYLCM) + IF(LENGT.EQ.NGRO) THEN + CALL LCMGET(KPLIB,'N2N',XSTOT) + DO 600 IU=1,NGRO + SECT(IU)=SECT(IU)+XSTOT(IU) + 600 CONTINUE + ENDIF + CALL LCMPUT(KPLIB,'NG',NGRO,2,SECT) + ENDIF + 610 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(AMASS) + DEALLOCATE(XSTOT,SCAT,SIGS,SECT,DELTA,ENERG) + DEALLOCATE(NFS,ITYPRO,IPR) + RETURN +* + 780 FORMAT(26HLIBXS4: MATERIAL/ISOTOPE ',A12,20H' IS MISSING ON APOL, + 1 15HIB-2 FILE NAME ,A12,1H.) + 790 FORMAT(49HLIBXS4: SELF-SHIELDING DATA OF MATERIAL/ISOTOPE ',A12, + 1 35H' IS MISSING ON APOLIB-2 FILE NAME ,A12,1H.) + 800 FORMAT(/43H LIBXS4: PROCESSING APOLIB-2 LIBRARY NAME: ,A12,1H.) + 810 FORMAT(/32H LIBXS4: X-SECTION LIBRARY INFO:/9X,A80/) + 820 FORMAT(/35H LIBXS4: PROBING THE APOLIB-2 FILE./9X,11HNUMBER OF I, + 1 29HSOTOPES AT INFINITE DILUTION=,I8/9X,21HNUMBER OF SELF-SHIELD, + 2 12HED ISOTOPES=,I8) + 870 FORMAT(/9X,15HISOTOPE TITLE: ,A80) + 880 FORMAT(/9X,13HTEMPERATURES=,1P,9E12.4/(22X,9E12.4)) + 890 FORMAT(/9X,6HZFISS=,I2,8H LGPROB=,L2,8H LGTDIF=,L2,8H LGTTRA=,L2, + 1 6H FGTD=,I5,5H ID2=,I5,8H NSECTT=,I3/9X,7HNANISD=,I3,8H NANIST=, + 2 I3,8H LGTREA=,15L2/(38X,15L2)) + 900 FORMAT(/9X,5HFAGG=,I5,6H LAGG=,I5,6H FDGG=,I5,6H WGAL=,I5,5H FAG=, + 1 I5,5H LAG=,I5,6H NGTD=,I5) + 910 FORMAT(/9X,10HDILUTIONS=,1P,9E12.4/(19X,9E12.4)) + 920 FORMAT(/9X,28HSELF-SHIELDING TEMPERATURES=,1P,7E12.4/(37X,7E12.4)) + 930 FORMAT(/9X,7HFGHOMO=,I4,8H FGRESO=,I4,8H NGHOMO=,I4,8H NSEQHO=, + 1 I4,8H NTEMPS=,I4) + 940 FORMAT(/26H LIBXS4: CPU TIME USAGE --,F10.2,9H INDEXING/26X, + 1 F10.2,24H INFINITE DILUTION P0 XS/26X,F10.2,11H PN XS DATA/ + 2 26X,F10.2,27H DILUTION-DEPENDENT XS DATA/26X,F10.2,5H AUTO, + 3 12HLIB XS DATA.) + 950 FORMAT(26HLIBXS4: REMAINING REACTION,I3,14H FOR ISOTOPE ',3A4, + 1 2H'.) + END diff --git a/Dragon/src/LIBXS5.f b/Dragon/src/LIBXS5.f new file mode 100644 index 0000000..2a2bf24 --- /dev/null +++ b/Dragon/src/LIBXS5.f @@ -0,0 +1,146 @@ +*DECK LIBXS5 + SUBROUTINE LIBXS5(IG,NGBIN,IPAP,NSIGF,TT,NTEMPS,TEMPS,DELTF, + 1 SIGTF,SIGAF,SIGFF,DELINF,SGTINF,SGAINF,SGFINF) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Temperature interpolation of autolib (bin cross sections) information. +* +*Copyright: +* Copyright (C) 2014 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IG coarse energy group under consideration. +* NGBIN number of coarse energy groups. +* IPAP APOLIB-XSM pointer. +* NSIGF number of fine energy groups. +* TT temperature of isotope. +* NTEMPS number of tabulated temperatures. +* TEMPS tabulated temperatures. +* +*Parameters: output +* DELTF fine group lethargy widths. +* SIGTF fine group total x-s. +* SIGAF fine group absorption x-s. +* SIGFF fine group fission x-s. +* DELINF calculated lethargy width for group IG. +* SGTINF calculated infinite-dilution total x-s for group IG. +* SGAINF calculated infinite-dilution absorption x-s for group IG. +* SGFINF calculated infinite-dilution fission x-s for group IG. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPAP + INTEGER IG,NGBIN,NSIGF,NTEMPS + REAL TT,TEMPS(NTEMPS),DELTF(NSIGF),SIGTF(NSIGF),SIGAF(NSIGF), + 1 SIGFF(NSIGF),DELINF,SGTINF,SGAINF +*---- +* LOCAL VARIABLES +*---- + CHARACTER HSMG*131,TEXT12*12 + PARAMETER (NINT=2,DTMIN=1.0) + DOUBLE PRECISION D1,D2,D3,D4 + LOGICAL LOK + REAL, ALLOCATABLE, DIMENSION(:) :: DT,DA,DF,DD + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SQRTEM,WEIJHT +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(WEIJHT(NTEMPS),SQRTEM(NTEMPS)) +*---- +* COMPUTE THE WEIGHTS. +*---- + DO 10 I=1,NTEMPS + SQRTEM(I)=SQRT(TEMPS(I)) + 10 CONTINUE + IF(NTEMPS.EQ.1) THEN + IPROX=1 + IGTFIX=1 + ELSE + STT=SQRT(TT) + CALL LIBA28(STT,SQRTEM,NTEMPS,NINT,WEIJHT,IORD,IPROX,I0) + IF(ABS(TT-TEMPS(IPROX)).LE.DTMIN) THEN + IGTFIX=1 + ELSEIF((STT.LT.SQRTEM(1)).OR.(STT.GT.SQRTEM(NTEMPS))) THEN + WRITE(HSMG,'(A,F8.2,A,F8.2,A,F8.2)') + 1 'LIBXS5: A TEMPERATURE', TT,'K IS NOT INCLUDED BETWEEN ', + 2 TEMPS(1),' AND ',TEMPS(NTEMPS) + WRITE(6,'(/1X,A)') HSMG + IGTFIX=2 + ELSE + IGTFIX=0 + ENDIF + ENDIF +*---- +* LOOP OVER TABULATED TEMPERATURES. +*---- + ALLOCATE(DT(NSIGF),DA(NSIGF),DF(NSIGF),DD(NSIGF)) + D1=0.0D0 + SIGTF(:NSIGF)=0.0 + SIGAF(:NSIGF)=0.0 + SIGFF(:NSIGF)=0.0 + DO 50 J=1,IORD + IT=I0+J + WRITE(TEXT12,'(6HNTEMPS,I6.6)') IT + CALL LCMSIX(IPAP,TEXT12,1) + CALL LCMLEN(IPAP,'DELTF',NV,ITYLCM) + CALL LCMLEN(IPAP,'SIGFF',NF,ITYLCM) + IF(NV.NE.NSIGF) CALL XABORT('LIBXS5: INVALID NSIGF.') + CALL LCMGET(IPAP,'SIGTF',DT) + CALL LCMGET(IPAP,'SIGAF',DA) + IF(NF.EQ.NSIGF) CALL LCMGET(IPAP,'SIGFF',DF) + CALL LCMGET(IPAP,'DELTF',DD) + CALL LCMSIX(IPAP,' ',2) + IS=(IT-1)*NGBIN+IG + IF(IT.EQ.I0+1) THEN + D1=0.0D0 + DO 20 I=1,NSIGF + DELTF(I)=DD(I) + D1=D1+DELTF(I) + 20 CONTINUE + ELSE + LOK=.TRUE. + DO 30 I=1,NSIGF + LOK=LOK.AND.(DELTF(I).EQ.DD(I)) + 30 CONTINUE + IF(.NOT.LOK) CALL XABORT('LIBXS5: INVALID AUTOLIB MESH.') + ENDIF + DO 40 I=1,NSIGF + SIGTF(I)=SIGTF(I)+REAL(WEIJHT(J)*DT(I)) + SIGAF(I)=SIGAF(I)+REAL(WEIJHT(J)*DA(I)) + IF(NF.EQ.NSIGF) SIGFF(I)=SIGFF(I)+REAL(WEIJHT(J)*DF(I)) + 40 CONTINUE + 50 CONTINUE + D2=0.0D0 + D3=0.0D0 + D4=0.0D0 + DO 60 I=1,NSIGF + SIGTF(I)=MAX(SIGTF(I),0.0) + SIGAF(I)=MAX(SIGAF(I),0.0) + SIGFF(I)=MAX(SIGFF(I),0.0) + D2=D2+SIGTF(I)*DELTF(I) + D3=D3+SIGAF(I)*DELTF(I) + D4=D4+SIGFF(I)*DELTF(I) + 60 CONTINUE + DELINF=REAL(D1) + SGTINF=REAL(D2/D1) + SGAINF=REAL(D3/D1) + SGFINF=REAL(D4/D1) + DEALLOCATE(DT,DA,DF,DD) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SQRTEM,WEIJHT) + RETURN + END diff --git a/Dragon/src/LIBXS6.f b/Dragon/src/LIBXS6.f new file mode 100644 index 0000000..8c4ed53 --- /dev/null +++ b/Dragon/src/LIBXS6.f @@ -0,0 +1,92 @@ +*DECK LIBXS6 + SUBROUTINE LIBXS6 (MAXDIL,NAMFIL,HSHI,NDIL,DILUT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find the dilutions corresponding to a resonant isotope within a +* library in Apolib-XSM format. +* +*Copyright: +* Copyright (C) 2014 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXDIL maximum number of dilutions. +* NAMFIL name of the APOLIB-XSM file. +* HSHI library name of the self-shielding data. +* +*Parameters: output +* NDIL number of finite dilutions. +* DILUT dilutions. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXDIL,NDIL + CHARACTER HSHI*12 + CHARACTER NAMFIL*(*) + REAL DILUT(MAXDIL) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPAP + CHARACTER TEXT20*20,TEXT12*12,HSMG*131 + INTEGER, ALLOCATABLE, DIMENSION(:) :: NOMS +*---- +* OPEN AND PROBE THE APOLIB-XSM FILE. +*---- + CALL LCMOP(IPAP,NAMFIL,2,2,0) + CALL LCMSIX(IPAP,'PHEAD',1) + CALL LCMLEN(IPAP,'NOMS',NV,ITYLCM) + NISOTS=NV/5 + ALLOCATE(NOMS(5*NISOTS)) + CALL LCMGET(IPAP,'NOMS',NOMS) + KISEG=0 + DO ISO=1,NISOTS + WRITE(TEXT20,'(5A4)') (NOMS((ISO-1)*5+II),II=1,5) + IF(TEXT20(:12).EQ.HSHI) THEN + KISEG=ISO + EXIT + ENDIF + ENDDO + DEALLOCATE(NOMS) + IF(KISEG.EQ.0) THEN + WRITE(HSMG,'(45HLIBXS6: UNABLE TO FIND SELF-SHIELDED ISOTOPE , + 1 A12,1H.)') HSHI + CALL XABORT(HSMG) + ENDIF + CALL LCMSIX(IPAP,' ',2) +*---- +* RECOVER DILUTIONS +*---- + CALL LCMSIX(IPAP,'QFIXS',1) + WRITE(TEXT12,'(4HISOT,I8.8)') KISEG + CALL LCMSIX(IPAP,TEXT12,1) + CALL LCMSIX(IPAP,'SSDATA',1) + CALL LCMLEN(IPAP,'SEQHOM',NDIL,ITYLCM) + IF(NDIL.EQ.0) THEN + WRITE(HSMG,'(47HLIBXS6: NO DILUTIONS FOR SELF-SHIELDED ISOTOPE , + 1 A12,1H.)') HSHI + CALL XABORT(HSMG) + ELSE IF(NDIL.GT.MAXDIL) THEN + WRITE(HSMG,'(46HLIBXS6: MAXDIL OVERFLOW SELF-SHIELDED ISOTOPE , + 1 A12,1H.)') HSHI + CALL XABORT(HSMG) + ENDIF + NDIL=NDIL-1 + CALL LCMGET(IPAP,'SEQHOM',DILUT) + CALL LCMSIX(IPAP,' ',2) + CALL LCMSIX(IPAP,' ',2) + CALL LCMSIX(IPAP,' ',2) + CALL LCMCL(IPAP,1) + RETURN + END diff --git a/Dragon/src/M2T.f b/Dragon/src/M2T.f new file mode 100644 index 0000000..427c21c --- /dev/null +++ b/Dragon/src/M2T.f @@ -0,0 +1,156 @@ +*DECK M2T + SUBROUTINE M2T(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover information from a macrolib and translate the requested data +* towards an Apotrim interface file. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1) create or modification ascii file containing +* Apotrim data; +* HENTRY(2) read-only type(L_MACROLIB). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPMAC + PARAMETER (NSTATE=40,IOUT=6) + CHARACTER TEXT12*12,TEXT20*20,HSIGN*12 + DOUBLE PRECISION DFLOTT + INTEGER ISTATE(NSTATE) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NBM,HBM + REAL, ALLOCATABLE, DIMENSION(:) :: BUP,TEMP +*---- +* PARAMETER VALIDATION +*---- + IF(NENTRY.LE.1) CALL XABORT('M2T: MINIMUM OF 2 OBJECTS EXPECTED.') + TEXT12=HENTRY(1) + IF(IENTRY(1).NE.4) CALL XABORT('M2T: ASCII FILE NAMED '//TEXT12 + 1 //' EXPECTED AT LHS.') + IF(JENTRY(1).EQ.2) CALL XABORT('M2T: ASCII FILE IN CREATE OR MOD' + 1 //'IFICATION MODE EXPECTED.') + LOUT=FILUNIT(KENTRY(1)) + IF((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2)) CALL XABORT('M2T: LCM ' + 1 //'OBJECT EXPECTED AT RHS.') + IF(JENTRY(2).NE.2) CALL XABORT('M2T: LCM OBJECTS IN READ-ONLY MO' + 1 //'DE EXPECTED AT RHS.') + CALL LCMGTC(KENTRY(2),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_MACROLIB') CALL XABORT('M2T: MACROLIB OBJECT EXPE' + 1 //'CTED AT RHS.') + IPMAC=KENTRY(2) + CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE) + NGRP=ISTATE(1) + MAXMIX=ISTATE(2) + MAXNL=ISTATE(3) + NBFIS=ISTATE(4) + IF(NBFIS.GT.1) CALL XABORT('M2T: THE CAPABILITY TO MERGE MANY FI' + 1 //'SSION SPECTRA IS NOT IMPLEMENTED.') +*---- +* ALLOCATE MEMORY +*---- + ALLOCATE(NBM(MAXMIX),HBM(5*MAXMIX),BUP(MAXMIX),TEMP(MAXMIX)) + NBM(:MAXMIX)=1 + BUP(:MAXMIX)=0.0 + TEMP(:MAXMIX)=0.0 +*---- +* READ THE INPUT DATA +*---- + NL=1 + NBMIX=0 + ICTR=0 + IGMAIL=0 + IMPX=1 + 20 CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('M2T: CHARACTER DATA EXPECTED(1).') + IF(TEXT12.EQ.'EDIT') THEN +* READ THE PRINT INDEX. + CALL REDGET(INDIC,IMPX,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('M2T: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT12.EQ.'MIX') THEN +* READ A MATERIAL MIXTURE. + TEXT20=' ' + CALL REDGET(INDIC,NITMA,FLOTT,TEXT20,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('M2T: CHARACTER DATA EXPECTED(2).') + NBMIX=NBMIX+1 + IF(NBMIX.GT.MAXMIX) CALL XABORT('M2T: MAXMIX OVERFLOW.') + READ(TEXT20,'(5A4)') (HBM(5*(NBMIX-1)+I0),I0=1,5) + 30 CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('M2T: CHARACTER DATA EXPECTED(3).') + IF(TEXT12.EQ.'FROM') THEN + CALL REDGET(INDIC,NBM(NBMIX),FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('M2T: INTEGER DATA EXPECTED(2).') + GO TO 30 + ELSE IF(TEXT12.EQ.'BURN') THEN +* READ A BURNUP. + CALL REDGET(INDIC,NITMA,BUP(NBMIX),TEXT12,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('M2T: REAL DATA EXPECTED(1).') + GO TO 30 + ELSE IF(TEXT12.EQ.'TEMP') THEN +* READ A TEMPERATURE. + CALL REDGET(INDIC,NITMA,TEMP(NBMIX),TEXT12,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('M2T: REAL DATA EXPECTED(2).') + GO TO 30 + ELSE IF(TEXT12.NE.'ENDMIX') THEN + CALL XABORT('M2T: FROM, BURN, TEMP OR ENDMIX EXPECTED.') + ENDIF + ELSE IF(TEXT12.EQ.'PN') THEN +* READ THE ANISOTROPY ORDER + CALL REDGET(INDIC,NITMA,FLOTT,TEXT20,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('M2T: INTEGER DATA EXPECTED(3).') + NL=MIN(NITMA+1,MAXNL) + ELSE IF(TEXT12.EQ.'TRAN') THEN +* PERFORM TRANSPORT CORRECTION + ICTR=1 + ELSE IF(TEXT12.EQ.'NOMA') THEN +* DO NOT WRITE ENERGY MESH ON APOTRIM FILE + IGMAIL=1 + ELSE IF(TEXT12.EQ.';') THEN + GO TO 40 + ELSE + CALL XABORT('M2T: '//TEXT12//' IS AN INVALID KEYWORD.') + ENDIF + GO TO 20 +*---- +* RECOVER INFORMATION +*---- + 40 CALL M2TDRV(IMPX,LOUT,IPMAC,NGRP,NBMIX,MAXMIX,NL,NBFIS,ICTR, + 1 IGMAIL,BUP,TEMP,HBM,NBM) +*---- +* RELEASE MEMORY +*---- + DEALLOCATE(TEMP,BUP,HBM,NBM) + RETURN + END diff --git a/Dragon/src/M2TDRV.f b/Dragon/src/M2TDRV.f new file mode 100644 index 0000000..44aee88 --- /dev/null +++ b/Dragon/src/M2TDRV.f @@ -0,0 +1,294 @@ +*DECK M2TDRV + SUBROUTINE M2TDRV(IMPX,LOUT,IPMAC,NGRP,NBMIX,MAXMIX,NL,NBFIS,ICTR, + 1 IGMAIL,BUP,TEMP,HBM,NBM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Build an Apotrim interface file. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IMPX print index. +* LOUT Apotrim file unit number. +* IPMAC LCM pointer to the Macrolib. +* NGRP number of energy groups. +* NBMIX number of material mixtures in the Apotrim file. +* MAXMIX number of material mixtures in the Macrolib. +* NL maximum anisotropy level in the Apotrim file (=1 for +* isotropic collision in LAB). +* NBFIS maximum number of fissile isotopes in a mixture. +* ICTR flag set to 1 if the Apotrim xs are transport corrected. +* IGMAIL flag set to 1 to avoid writing the energy mesh on file. +* BUP burnup of each Apotrim mixture. +* TEMP temperature of each Apotrim mixture in Celsius. +* HBM name of material mixtures in the Apotrim file. +* NBM corresponding material mixtures indices in the Macrolib. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMAC + INTEGER IMPX,LOUT,NGRP,NBMIX,MAXMIX,NL,NBFIS,ICTR,IGMAIL, + 1 HBM(5,NBMIX),NBM(NBMIX) + REAL BUP(NBMIX),TEMP(NBMIX) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPMAC,KPMAC + CHARACTER TEXT20*20,FMTOUT*80,CM*2 + PARAMETER(FMTOUT='(1P,6E13.5)',IOUT=6) + INTEGER FFAGGM,LLAGGM,FFDGGM,WWGALM,FFAGM,LLAGM,NNPSNM +*---- +* ALLOCATABLE STATEMENTS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IFDG,IADR,IJJ,NJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) :: GAR1,XTRAN,SIG,WORK,TRAN + REAL, ALLOCATABLE, DIMENSION(:,:) :: GAR2 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IFDG(NGRP),IADR(NGRP+1),IJJ(MAXMIX),NJJ(MAXMIX), + 1 IPOS(MAXMIX)) + ALLOCATE(GAR1(NGRP),GAR2(5,NGRP),XTRAN(NGRP*NGRP),SIG(MAXMIX), + 1 WORK(NGRP*MAXMIX),TRAN(NGRP)) +*---- +* RECOVER THE ENERGY MESH +*---- + IF(IGMAIL.EQ.0) THEN + CALL LCMGET(IPMAC,'ENERGY',GAR1) + DO 10 I=1,NGRP+1 + GAR1(I)=1.0E-6*GAR1(I) + 10 CONTINUE + WRITE(LOUT,'(2I8)') NBMIX,NGRP + WRITE(LOUT,FMTOUT) (GAR1(I),I=1,NGRP+1) + IF(IMPX.GE.1) THEN + WRITE(IOUT,4000) NBMIX,NGRP + WRITE(IOUT,4100) (GAR1(I),I=1,NGRP+1) + ENDIF + ENDIF +*---- +* MIXTURE LOOP +*---- + DO 100 IMED=1,NBMIX + WRITE(TEXT20,'(5A4)') (HBM(I0,IMED),I0=1,5) + IF(IMPX.GT.0) WRITE(IOUT,'(/25H M2TDRV: PROCESS MIXTURE ,A20)') + 1 TEXT20 + IBM=NBM(IMED) + JPMAC=LCMGID(IPMAC,'GROUP') +*---- +* RECOVER FISSION INFORMATION +*---- + LFIS=0 + IF(NBFIS.EQ.1) THEN + DO 20 IGR=1,NGRP + KPMAC=LCMGIL(JPMAC,IGR) + CALL LCMLEN(KPMAC,'CHI',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPMAC,'CHI',SIG) + GAR1(IGR)=SIG(IBM) + IF(GAR1(IGR).NE.0.0) LFIS=1 + ELSE + GAR1(IGR)=0.0 + ENDIF + 20 CONTINUE + IF((LFIS.EQ.1).AND.(IMPX.GE.1)) THEN + WRITE(IOUT,1110) + WRITE(IOUT,4100) (GAR1(IGR),IGR=1,NGRP) + ENDIF + ENDIF + WRITE(LOUT,'(A20,2I5,3I3,2I10)') TEXT20,IMED,NGRP,LFIS,ICTR,NL-1, + 1 NINT(TEMP(IMED)),NINT(BUP(IMED)) + IF(LFIS.EQ.1) WRITE(LOUT,FMTOUT) (GAR1(IGR),IGR=1,NGRP) +*---- +* RECOVER TRANSPORT CORRECTION +*---- + IF(ICTR.GT.0) THEN + DO 25 IGR=1,NGRP + KPMAC=LCMGIL(JPMAC,IGR) + CALL LCMLEN(KPMAC,'TRANC',ILONG1,ITYLCM) + CALL LCMLEN(KPMAC,'SIGS01',ILONG2,ITYLCM) + IF(ILONG1.GT.0) THEN + CALL LCMGET(KPMAC,'TRANC',SIG) + TRAN(IGR)=SIG(IBM) + ELSE IF(ILONG2.GT.0) THEN + CALL LCMGET(KPMAC,'SIGS01',SIG) + TRAN(IGR)=SIG(IBM) + ELSE + TRAN(IGR)=0.0 + ENDIF + 25 CONTINUE + ENDIF +*---- +* RECOVER REMAINING VECTOR XS INFORMATION +*---- + IF(ICTR.EQ.0) THEN + IOF=0 + NXS=4 + ELSE + IOF=1 + NXS=5 + ENDIF + DO 30 IGR=1,NGRP + KPMAC=LCMGIL(JPMAC,IGR) + CALL LCMGET(KPMAC,'NTOT0',SIG) + GAR2(IOF+1,IGR)=SIG(IBM) + IF(ICTR.GT.0) THEN + GAR2(1,IGR)=TRAN(IGR) + GAR2(IOF+1,IGR)=GAR2(IOF+1,IGR)-TRAN(IGR) + ENDIF + GAR2(IOF+2,IGR)=SIG(IBM) + CALL LCMLEN(KPMAC,'SIGS00',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPMAC,'SIGS00',SIG) + GAR2(IOF+2,IGR)=GAR2(IOF+2,IGR)-SIG(IBM) + ENDIF + CALL LCMLEN(KPMAC,'N2N',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPMAC,'N2N',SIG) + GAR2(IOF+2,IGR)=GAR2(IOF+2,IGR)+SIG(IBM) + GAR2(IOF+4,IGR)=SIG(IBM) + ELSE + GAR2(IOF+4,IGR)=0.0 + ENDIF + CALL LCMLEN(KPMAC,'N3N',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPMAC,'N3N',SIG) + GAR2(IOF+2,IGR)=GAR2(IOF+2,IGR)+2.0*SIG(IBM) + GAR2(IOF+4,IGR)=GAR2(IOF+4,IGR)+2.0*SIG(IBM) + ENDIF + CALL LCMLEN(KPMAC,'N4N',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPMAC,'N4N',SIG) + GAR2(IOF+2,IGR)=GAR2(IOF+2,IGR)+3.0*SIG(IBM) + GAR2(IOF+4,IGR)=GAR2(IOF+4,IGR)+3.0*SIG(IBM) + ENDIF + CALL LCMLEN(KPMAC,'NUSIGF',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPMAC,'NUSIGF',SIG) + GAR2(IOF+3,IGR)=SIG(IBM) + ELSE + GAR2(IOF+3,IGR)=0.0 + ENDIF + 30 CONTINUE + WRITE(IOUT,4300) NL-1 + DO 40 IGR=1,NGRP + WRITE(LOUT,FMTOUT) (GAR2(II,IGR),II=1,NXS) + 40 CONTINUE + IF(IMPX.GE.1) THEN + WRITE(IOUT,1000) + DO 50 IGR=1,NGRP + WRITE(IOUT,'(8X,I7,1P,6E15.6)') IGR,(GAR2(II,IGR),II=1,NXS) + 50 CONTINUE + ENDIF +*---- +* RECOVER TRANSFER XS INFORMATION +*---- + DO 90 INL=1,NL + WRITE (CM,'(I2.2)') INL-1 + IADR(1)=1 + NNPSNM=0 + FFAGGM=NGRP+1 + LLAGGM=0 + FFDGGM=NGRP+1 + WWGALM=0 + FFAGM=1 + LLAGM=NGRP + DO 70 IGR=1,NGRP + KPMAC=LCMGIL(JPMAC,IGR) + IFDG(IGR)=NGRP+1 + CALL LCMGET(KPMAC,'IJJS'//CM,IJJ) + CALL LCMGET(KPMAC,'NJJS'//CM,NJJ) + CALL LCMGET(KPMAC,'IPOS'//CM,IPOS) + CALL LCMGET(KPMAC,'SCAT'//CM,WORK) + IF(ICTR.GT.0) THEN + IOF=IPOS(IBM)-IGR+IJJ(IBM) + WORK(IOF)=WORK(IOF)-TRAN(IGR) + ENDIF + IFDG(IGR)=MIN(IFDG(IGR),IJJ(IBM)-NJJ(IBM)+1) + IPO=IPOS(IBM)+NJJ(IBM) + DO 60 IB=1,NJJ(IBM) + NNPSNM=NNPSNM+1 + XTRAN(NNPSNM)=WORK(IPO-IB)*REAL(2*INL-1) + 60 CONTINUE + IADR(IGR+1)=IADR(IGR)+(IJJ(IBM)-IFDG(IGR)+1) + 70 CONTINUE + WRITE(LOUT,'(A20,2I5,3I3,2I10)') TEXT20,IMED,NGRP,LFIS,ICTR,INL-1, + 1 NINT(TEMP(IMED)),NINT(BUP(IMED)) + WRITE(LOUT,'(8I8)') FFAGGM,LLAGGM,FFDGGM,WWGALM,FFAGM,LLAGM + WRITE(LOUT,'(8I8)') (IFDG(IGR),IGR=1,NGRP) + WRITE(LOUT,'(8I8)') (IADR(IGR),IGR=1,NGRP+1) + WRITE(LOUT,'(I10)') NNPSNM + WRITE(LOUT,FMTOUT) (XTRAN(II),II=1,NNPSNM) + IF(IMPX.GE.2) THEN + WRITE(IOUT,3000) INL-1 + WRITE(IOUT,3050) FFAGGM,LLAGGM,FFDGGM,WWGALM,FFAGM,LLAGM,NNPSNM + WRITE(IOUT,3100) + WRITE(IOUT,4200) (IFDG(IGR),IGR=1,NGRP) + WRITE(IOUT,3200) + WRITE(IOUT,4200) (IADR(IGR),IGR=1,NGRP+1) + ENDIF +* PRINT TRANSFERT MATRICES ON LISTING, WIDLY AS THEY ARE CODED +* IN MACROLIB FOR IMPX.EQ.2, EXPLICITLY FOR IMPX.EQ.3 + IF(IMPX.EQ.2) THEN + WRITE(IOUT,3300) + WRITE(IOUT,4100) (XTRAN(II),II=1,NNPSNM) + ENDIF + IF(IMPX.EQ.3) THEN + WRITE(IOUT,3300) + DO 85 IG=1,NGRP + DO 80 IGP=1,NGRP + SECT=0.0 + IF((IG.GE.FFAGGM).AND.(IG.LE.LLAGGM).AND. + 1 (IGP.GE.FFDGGM).AND.(IGP.LE.(FFDGGM+WWGALM-1))) THEN + SECT=XTRAN((IG-FFAGGM)*WWGALM+IGP-FFDGGM+1) + WRITE(IOUT,3060) IGP,IG,SECT + ELSE IF((IGP.GE.IFDG(IG)).AND. + 1 (IGP.LE.(IADR(IG+1)-IADR(IG)+IFDG(IG)-1)) + 2 .AND.(IG.GE.FFAGM).AND.(IG.LE.LLAGM)) THEN + SECT=XTRAN(IADR(IG)+IGP-IFDG(IG)) + WRITE(IOUT,3060) IGP,IG,SECT + ENDIF + 80 CONTINUE + 85 CONTINUE + ENDIF + 90 CONTINUE + 100 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(TRAN,WORK,SIG,XTRAN,GAR2,GAR1) + DEALLOCATE(IPOS,NJJ,IJJ,IADR,IFDG) + RETURN +* + 1000 FORMAT (//29X,10(2H**)/29X,'** CROSS SECTIONS **'/29X, + 1 10(2H**)//) + 1110 FORMAT (//31X,10(2H**)/31X,'* FISSION SPECTRUM *', + 1 /31X,10(2H**)) + 3000 FORMAT (//26X,15(2H**)/26X,'* P',I1,' TRANSFER CROSS SECTIONS *'/ + 1 26X,15(2H**)/) + 3050 FORMAT (//10X,'FAGGM = ',I6,10X,'LAGGM = ',I6,10X,'FDGGM = ',I6 + 1 /10X,'WGALM = ',I6,10X,'FAGM = ',I6,10X,'LAGM = ',I6 + 2 /10X,'NPSNM = ',I10) + 3060 FORMAT (1X,I3,' ==>',I3,1P,E13.5) + 3100 FORMAT (//26X,6(2H**)/26X,'* FDGM *'/26X,6(2H**)/) + 3200 FORMAT (//26X,6(2H**)/26X,'* IADM *'/26X,6(2H**)/) + 3300 FORMAT (//26X,6(2H**)/26X,'* XTRAN *'/26X,6(2H**)/) + 4000 FORMAT (//25X,11(3H***)/25X,'* NUMBER OF MIXTURES : ',I5, + 1 ' *'/25X,'* ',I5,'-GROUP ENERGY MESH *'/25X,11(3H***)) + 4100 FORMAT (2X,1P,5E15.6) + 4200 FORMAT (3X,5I10) + 4300 FORMAT (//28X,13(2H**)/28X,'* ANISOTROPY LEVEL : P',I1,' *'/ + 1 28X,13(2H**)) + END diff --git a/Dragon/src/MAC.f b/Dragon/src/MAC.f new file mode 100644 index 0000000..c4f0cde --- /dev/null +++ b/Dragon/src/MAC.f @@ -0,0 +1,281 @@ +*DECK MAC + SUBROUTINE MAC(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Macroscopic cross sections and diffusion coefficients input module. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert and G. Marleau +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1) create or modification type(L_MACROLIB); +* HENTRY(2) optional read-only type(L_MACROLIB) or +* type(L_OPTIMIZE). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPMACR,JPLIST,KPLIST + PARAMETER(NSTATE=40,IOUT=6) + CHARACTER TEXT12*12,HSIGN*12,CARLIR*12 + INTEGER ISTATE(NSTATE) + INTEGER NALBP + DOUBLE PRECISION DBLLIR +*---- +* PARAMETER VALIDATION +*---- + IF(NENTRY.EQ.0) CALL XABORT('MAC: PARAMETER EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('MAC: LCM ' + 1 //'OBJECT EXPECTED AT LHS.') + IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) CALL XABORT('MAC: ENTR' + 1 //'Y IN CREATE OR MODIFICATION MODE EXPECTED.') + ITYPE=JENTRY(1) + IPMACR=KENTRY(1) + NGO=0 +*---- +* LOOK FOR OTHER MACROLIB IN SET OF DATA STRUCTURES +*---- + NMACSR=1 + NOLDMX=0 + NGO=0 + NLO=0 + NFO=0 + NEO=0 + ITO=0 + IPMAC2=0 + IF(NENTRY.GT.2) CALL XABORT('MAC: ONLY TWO OBJECTS PERMITTED.') + IF(NENTRY.EQ.2) THEN + IPMAC2=NENTRY + IF((IENTRY(IPMAC2).NE.1).AND.(IENTRY(IPMAC2).NE.2)) THEN + CALL XABORT('MAC: INVALID STRUCTURE TYPE FOR SECOND OBJECT.') + ELSE IF(JENTRY(IPMAC2).NE.2) THEN + CALL XABORT('MAC: DATA STRUCTURE '//HENTRY(IPMAC2)//' NOT ' + 1 //'IN READ-ONLY MODE') + ENDIF + CALL LCMGTC(KENTRY(IPMAC2),'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_MACROLIB') THEN + NMACSR=2 + ISTATE(:NSTATE)=0 + CALL LCMGET(KENTRY(IPMAC2),'STATE-VECTOR',ISTATE) + IF(ISTATE(2).GT.0) THEN + NOLDMX=ISTATE(2) + NGO=ISTATE(1) + NLO=ISTATE(3) + NFO=ISTATE(4) + NEO=ISTATE(5) + ITO=ISTATE(6) + ELSE + NMACSR=1 + ENDIF + ELSE IF(HSIGN.EQ.'L_LIBRARY') THEN + NMACSR=-2 + CALL LCMSIX(KENTRY(IPMAC2),'MACROLIB',1) + ISTATE(:NSTATE)=0 + CALL LCMGET(KENTRY(IPMAC2),'STATE-VECTOR',ISTATE) + IF(ISTATE(2).GT.0) THEN + NOLDMX=ISTATE(2) + NGO=ISTATE(1) + NLO=ISTATE(3) + NFO=ISTATE(4) + NEO=ISTATE(5) + ITO=ISTATE(6) + ELSE + CALL LCMSIX(KENTRY(IPMAC2),' ',2) + NMACSR=1 + ENDIF + ELSE IF(HSIGN.EQ.'L_OPTIMIZE') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.10) CALL XABORT('MAC: NO INPUT DATA EXPECTED.') + CALL MACOPT(IPMACR,KENTRY(IPMAC2)) + RETURN + ELSE + CALL XABORT('MAC: SECOND DATA STRUCTURE HAS INVALID SIGNATU' + 1 //'RE SET TO '//HSIGN//'.') + ENDIF + ENDIF +*---- +* READ THE INPUT DATA +*---- +* DEFAULT OPTIONS: + IPRINT=1 + IF(ITYPE.EQ.0) THEN + INDREC=1 + NANISO=1 + NGROUP=0 + NBMIX=0 + NIFISS=0 + NEDMAC=0 + ITRANC=0 + NDELG=0 + NALBP=0 + NSTEP=0 + IDF=0 + NPART0=0 + ELSE + INDREC=2 + CALL LCMGTC(IPMACR,'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_LIBRARY') THEN + CALL LCMSIX(IPMACR,'MACROLIB',1) + ELSE IF(HSIGN.NE.'L_MACROLIB') THEN + TEXT12=HENTRY(1) + CALL XABORT('MAC: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_MACROLIB OR L_LIBRARY EXPECTED.') + ENDIF + ISTATE(:NSTATE)=0 + CALL LCMGET(IPMACR,'STATE-VECTOR',ISTATE) + NGROUP=ISTATE(1) + NBMIX=ISTATE(2) + NANISO=ISTATE(3) + NIFISS=ISTATE(4) + NEDMAC=ISTATE(5) + ITRANC=ISTATE(6) + NDELG=ISTATE(7) + NALBP =ISTATE(8) + NSTEP=ISTATE(11) + IDF=ISTATE(12) + NPART0=ISTATE(17) + ENDIF +*---- +* PROCESS THE MAC: INPUT DATA +*---- + IF(NMACSR.EQ.1) THEN + CALL MACDRV(IPMACR,INDREC,IPRINT,IDF,NBMIX,NGROUP,NANISO, + 1 NIFISS,NEDMAC,ITRANC,NDELG,NSTEP,NALBP) + ELSE + NNEWMX=0 + NANISO=MAX(NLO,NANISO) + NIFISS=NFO+NIFISS + NEDMAC=MAX(NEDMAC,NEO) + ITRANC=MAX(ITRANC,ITO) +*---- +* TAKE MACROSCOPIC XS FROM OLD MACROLIB +* READ MAIN INPUT PARAMETERS UNTIL KEYWORD MIX FOUND +*---- + 1000 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('MAC: CHARACTER KEYWORD EXPECTED.') + IF(CARLIR.EQ.'EDIT') THEN + CALL REDGET(ITYPLU,IPRINT,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('MAC: EDIT LEVEL SHOULD BE AN ' + 1 //'INTEGER.') + ELSE IF(CARLIR.EQ.'NMIX') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('MAC: READ ERROR - NUMBER OF M' + 1 //'IXTURES EXPECTED.') + NNEWMX=MAX(INTLIR,NNEWMX) + ELSE IF(CARLIR.EQ.'ANIS') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('MAC: READ ERROR - ANIS LEVEL ' + 1 //'EXPECTED.') + NANISO=MAX(NANISO,INTLIR) + ELSE IF(CARLIR.EQ.'NIFI') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('MAC: READ ERROR - NUMBER FISS' + 1 //'ILE ISOTOPES EXPECTED.') + NIFISS=MAX(INTLIR,NIFISS) + ELSE IF(CARLIR(1:4).EQ.'CTRA') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('MAC: CTRA MUST BE FOLLOWED BY' + 1 //' CHARACTER.') + IF(CARLIR.EQ.'OFF') THEN + ITRANC=0 + ELSE IF(CARLIR.EQ.'ON') THEN + ITRANC=2 + ELSE + CALL XABORT('MAC: INVALID CTRA OPTION.') + ENDIF + ELSE IF(CARLIR(1:3).EQ.'MIX') THEN + GO TO 1005 + ELSE + CALL XABORT('MAC: KEYWORD '//CARLIR//' NOT PERMITTED.') + ENDIF + GO TO 1000 + 1005 CONTINUE + NTOTMX=NOLDMX+NBMIX+NNEWMX + IF(NGROUP.EQ.0) THEN + IF(NGO.EQ.0) CALL XABORT('MAC: MACROLIBS HAVE 0 GROUP.') + NGROUP=NGO + ELSE IF(NGROUP.NE.NGO) THEN + CALL XABORT('MAC: MACROLIBS HAVE DIFFERENT GROUP STRUCTURE' + 1 //'S.') + ENDIF + CALL MACUPD(NENTRY,KENTRY,IPRINT,NTOTMX,NBMIX,NGROUP, + 1 NANISO,NIFISS,NEDMAC,ITRANC) + IF(NMACSR.EQ.-2) CALL LCMSIX(KENTRY(IPMAC2),' ',2) + ENDIF +* + IF(ITYPE.EQ.0) THEN + HSIGN='L_MACROLIB' + CALL LCMPTC(IPMACR,'SIGNATURE',12,HSIGN) + ENDIF + IF(ITYPE.NE.2) THEN + ISTATE(:NSTATE)=0 + ISTATE(1)=NGROUP + ISTATE(2)=NBMIX + ISTATE(3)=NANISO + ISTATE(4)=NIFISS + ISTATE(5)=NEDMAC + ISTATE(6)=ITRANC + ISTATE(7)=NDELG + ISTATE(8)=NALBP + ISTATE(11)=NSTEP + ISTATE(12)=IDF + ISTATE(17)=NPART0 + IF(ITRANC.NE.0) ISTATE(6)=2 + JPLIST=LCMGID(IPMACR,'GROUP') + KPLIST=LCMGIL(JPLIST,1) + CALL LCMLEN(KPLIST,'DIFF',ILONG,ITYLCM) + IF(ILONG.GT.0) ISTATE(9)=1 + CALL LCMLEN(KPLIST,'DIFFX',ILONG,ITYLCM) + IF(ILONG.GT.0) ISTATE(9)=2 + CALL LCMPUT(IPMACR,'STATE-VECTOR',NSTATE,1,ISTATE) + ENDIF + IF(IPRINT.GT.1) CALL LCMLIB(IPMACR) + IF(IPRINT.GT.0) WRITE(IOUT,100) IPRINT,(ISTATE(I),I=1,9), + 1 ISTATE(11),ISTATE(12),ISTATE(17) + CALL LCMSIX(IPMACR,' ',0) + RETURN +* + 100 FORMAT(/8H OPTIONS/8H -------/ + 1 7H IPRINT,I6,30H (0=NO PRINT/1=SHORT/2=MORE)/ + 2 7H NGROUP,I6,28H (NUMBER OF ENERGY GROUPS)/ + 3 7H NBMIX ,I6,39H (NUMBER OF MIXTURES IN THE MACROLIB)/ + 4 7H NANISO,I6,34H (MAXIMUM SCATTERING ANISOTROPY)/ + 5 7H NIFISS,I6,45H (MAXIMUM NUMBER OF FISSILE ISOTOPES IN A M, + 6 7HIXTURE)/ + 7 7H NEDMAC,I6,34H (NUMBER OF CROSS SECTION EDITS)/ + 8 7H ITRANC,I6,45H (0=NO TRANSPORT CORRECTION/1=APOLLO TYPE/2, + 9 43H=RECOVER FROM LIBRARY/4=LEAKAGE CORRECTION)/ + 1 7H NLG ,I6,39H (NUMBER OF DELAYED PRECURSOR GROUPS)/ + 2 7H NALB ,I6,31H (NUMBER OF PHYSICAL ALBEDOS)/ + 3 7H ILEAK ,I6,40H (1=DIFF AVAILABLE; 2=DIFFX AVAILABLE)/ + 4 7H NSTEP ,I6,39H (NUMBER OF PERTURBATION DIRECTORIES)/ + 5 7H IDF ,I6,48H (=0/2 BOUNDARY FLUXES FOR ADF ABSENT/PRESENT)/ + 6 7H NPART0,I6,34H (NUMBER OF COMPANION PARTICLES)) + END diff --git a/Dragon/src/MACDRV.f b/Dragon/src/MACDRV.f new file mode 100644 index 0000000..cbdf780 --- /dev/null +++ b/Dragon/src/MACDRV.f @@ -0,0 +1,356 @@ +*DECK MACDRV + SUBROUTINE MACDRV(IPLIST,INDREC,IPRINT,IDF,NBMIX,NGROUP,NANISO, + > NIFISS,NEDMAC,ITRANC,NDELG,NSTEP,NALBP) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Input macroscopic cross sections in Dragon/Donjon. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPLIST LCM pointer to the macrolib. +* INDREC =1 the macrolib is created; +* =2 an existing macrolib is modified. +* IPRINT print level. +* IDF discontinuity factor flag. +* +*Parameters: output +* NBMIX number of mixtures. +* NGROUP maximum number of groups (default = 1). +* NANISO maximum scattering anisotropy (default = 1 corresponding to +* isotropic collision in laboratory). +* NIFISS number of fissile isotopes per mixtures (default = 0). +* NEDMAC number of aditional edition cross section types. +* ITRANC type of transport correction: =0 no transport correction +* =1 Apollo type transport correction; =2 recover from +* library; =4 leakage correction alone. +* NDELG number of precursor groups for delayed neutrons. +* NSTEP number of delta cross-section sets used for generalized +* perturbation theory (GPT) or kinetics calculations. +* NALBP number of physical albedos. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIST + INTEGER INDREC,IPRINT,IDF,NBMIX,NGROUP,NANISO,NIFISS,NEDMAC, + > ITRANC,NDELG,NSTEP,NALBP +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPLIST,KPLIST,LPLIST + PARAMETER (IUNOUT=6,NCXST=18) + CHARACTER CARLIR*12,CARLU*4,CGOXSN*7 + LOGICAL LIREAD,LOLDXS(NCXST),LNEWXS(NCXST),LNORM,LADD,LUPD + INTEGER ITYPLU,INTLIR,IMATER + REAL REALIR + DOUBLE PRECISION DBLINP + DOUBLE PRECISION SQFMAS,XDRCST,NMASS,EVJ +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ISCATA,IPERMU + REAL, ALLOCATABLE, DIMENSION(:) :: TOTL,TOT1,FISS,SPEC,FIXE,TRANC, + > DIFF,NFTOT,H,SCAT,NUDL,CHDL,OVERV,XSINT0,XSINT1,DIFFX,DIFFY, + > DIFFZ,ENE,VEL,VOL + REAL, ALLOCATABLE, DIMENSION(:,:) :: ALB + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HADF + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: XADF +*---- +* FOR AVERAGED NEUTRON VELOCITY +* V=SQRT(2*ENER/M)=SQRT(2/M)*SQRT(ENER) +* SQFMAS=SQRT(2/M) IN CM/S/SQRT(EV) FOR V IN CM/S AND E IN EV +* =SQRT(2*1.602189E-19(J/EV)* 1.0E4(CM2/M2) /1.67495E-27 (KG)) +* =1383155.30602 CM/S/SQRT(EV) +*---- + EVJ=XDRCST('eV','J') + NMASS=XDRCST('Neutron mass','kg') + SQFMAS=SQRT(2.0D4*EVJ/NMASS) +*---- +* INITIALIZE USEFUL PARAMETERS +*---- + LIREAD=.TRUE. + LNORM=.FALSE. + LADD=.FALSE. + LUPD=(INDREC.EQ.2) + NEXTRE=1 + NEXTMI=1 + MAXFIS=MAX(1,NIFISS) + ALLOCATE(ISCATA(NANISO)) + ISCATA(:NANISO)=0 + DO 120 IL=1,NCXST + LOLDXS(IL)=.FALSE. + LNEWXS(IL)=.FALSE. + 120 CONTINUE + LPLIST=IPLIST + ISTEP=0 + NTYPE=0 +*---- +* READ A MAIN OPTION +*---- + 1000 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) + IF(ITYPLU.NE.3) + > CALL XABORT('MACDRV: READ ERROR 1 CHARACTER VARIABLE EXPECTED') +*---- +* CHECK FOR STOP/RETURN +*---- + 1002 IF(CARLIR.EQ.';') THEN + GO TO 2000 + ELSE IF(CARLIR.EQ.'EDIT') THEN +*---- +* READ THE PRINT INDEX +*---- + CALL REDGET(ITYPLU,IPRINT,REALIR,CARLU,DBLINP) + IF(ITYPLU.NE.1) + > CALL XABORT('MACDRV: READ ERROR - INTEGER VARIABLE EXPECTED') + ELSE IF(CARLIR.EQ.'DELP') THEN +*---- +* READ THE NUMBER OF PRECURSOR GROUPS FOR DELAYED NEUTRONS +*---- + CALL REDGET(ITYPLU,NDELG,REALIR,CARLU,DBLINP) + IF(ITYPLU.NE.1) + > CALL XABORT('MACDRV: READ ERROR - INTEGER VARIABLE EXPECTED') + ELSE IF(CARLIR.EQ.'STEP') THEN +*---- +* STEP TO A GPT SUB-DIRECTORY +*---- + CARLIR=' ' + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) + IF((ITYPLU.NE.3).OR.(CARLIR.NE.'INPUT')) + > CALL XABORT('MACDRV: READ ERROR - INPUT STRING EXPECTED') + CALL REDGET(ITYPLU,ISTEP,REALIR,CARLU,DBLINP) + IF(ITYPLU.NE.1) + > CALL XABORT('MACDRV: READ ERROR - INTEGER VARIABLE EXPECTED') + IF(INDREC.EQ.1) THEN + IF(ISTEP.LT.NSTEP) + > CALL XABORT('MACDRV: THIS DIRECTORY STEP ALREADY EXISTS.') + ENDIF + NSTEP=MAX(NSTEP,ISTEP) + JPLIST=LCMLID(IPLIST,'STEP',NSTEP) + KPLIST=LCMDIL(JPLIST,ISTEP) + LPLIST=KPLIST + ELSE IF(CARLIR.EQ.'READ') THEN + IF(NBMIX.EQ.0) CALL XABORT('MACDRV: NBMIX NOT YET DEFINED') + ALLOCATE(IPERMU(NBMIX)) + NBELEM=0 +*---- +* IDENTIFY MIXTURES TO READ +*---- + NUMMAT=0 + DO 100 IMATER=1,NBMIX + CALL REDGET(ITYPLU,JPERMU,REALIR,CGOXSN,DBLINP) + IF(ITYPLU.NE.1) GO TO 1001 + IF(JPERMU.GT.NBMIX) CALL XABORT('MACDRV: MATERIAL NUMBER IS' + > //' LARGER THAN NBMIX') + IPERMU(IMATER)=JPERMU + NUMMAT=MAX(NUMMAT,JPERMU) + IF(IMATER.EQ.NBMIX) + > CALL REDGET(ITYPLU,INTLIR,REALIR,CGOXSN,DBLINP) + NBELEM=NBELEM+1 + 100 CONTINUE + 1001 IF(ITYPLU.NE.3) + > CALL XABORT('MACDRV: READ ERROR 2 CHARACTER VARIABLE EXPECTED') + IF(LIREAD) THEN + ALLOCATE(TOTL(NBMIX*NGROUP),TOT1(NBMIX*NGROUP), + > FISS(NBMIX*NGROUP*MAXFIS),SPEC(NBMIX*NGROUP*MAXFIS), + > FIXE(NBMIX*NGROUP),TRANC(NBMIX*NGROUP),DIFF(NBMIX*NGROUP), + > NFTOT(NBMIX*NGROUP),H(NBMIX*NGROUP), + > SCAT(NBMIX*NGROUP*NGROUP*NANISO)) + ALLOCATE(NUDL(NBMIX*NGROUP*MAXFIS*MAX(NDELG,1)), + > CHDL(NBMIX*NGROUP*MAXFIS*MAX(NDELG,1))) + ALLOCATE(OVERV(NBMIX*NGROUP),XSINT0(NBMIX*NGROUP), + > XSINT1(NBMIX*NGROUP),DIFFX(NBMIX*NGROUP),DIFFY(NBMIX*NGROUP), + > DIFFZ(NBMIX*NGROUP)) + CALL MACIXS(LPLIST,MAXFIS,NGROUP,NBMIX,NIFISS,NANISO,NDELG, + > TOTL,TOT1,FISS,SPEC,FIXE,TRANC,DIFF,NFTOT,H,SCAT, + > LOLDXS,ISCATA,NUDL,CHDL,DIFFX,DIFFY,DIFFZ,OVERV, + > XSINT0,XSINT1) + LIREAD=.FALSE. + ENDIF + IF(CGOXSN.EQ.'INPUT ') THEN + ALLOCATE(HADF(NTYPE),XADF(NBMIX,NGROUP,NTYPE)) + CALL MACXSR(MAXFIS,NGROUP,NBMIX,NIFISS,NANISO,NDELG,NTYPE, + > TOTL,TOT1,FISS,SPEC,FIXE,TRANC,DIFF,NFTOT,H,SCAT, + > LOLDXS,LNEWXS,CARLIR,LADD,LUPD,IPRINT,ISCATA, + > NUDL,CHDL,DIFFX,DIFFY,DIFFZ,OVERV,XSINT0,XSINT1, + > HADF,XADF) + IF(NTYPE.GT.0) THEN + CALL LCMSIX(IPLIST,'ADF',1) + CALL LCMPUT(IPLIST,'NTYPE',1,1,NTYPE) + CALL LCMPTC(IPLIST,'HADF',8,NTYPE,HADF) + DO ITYPE=1,NTYPE + CALL LCMPUT(IPLIST,HADF(ITYPE),NBMIX*NGROUP,2, + > XADF(1,1,ITYPE)) + ENDDO + CALL LCMSIX(IPLIST,' ',2) + ENDIF + DEALLOCATE(XADF,HADF) + ENDIF + DEALLOCATE(IPERMU) + GO TO 1002 + ELSE IF(CARLIR.EQ.'NGRO') THEN + CALL REDGET(ITYPLU,NGROUP,REALIR,CARLU,DBLINP) + IF(ITYPLU.NE.1) + > CALL XABORT('MACDRV: READ ERROR - INTEGER VARIABLE EXPECTED') + ELSE IF(CARLIR.EQ.'NMIX') THEN + CALL REDGET(ITYPLU,NBMIX,REALIR,CARLU,DBLINP) + IF(ITYPLU.NE.1) + > CALL XABORT('MACDRV: READ ERROR - INTEGER VARIABLE EXPECTED') + ELSE IF(CARLIR.EQ.'ANIS') THEN + NANISC=NANISO + CALL REDGET(ITYPLU,NANISO,REALIR,CARLU,DBLINP) + IF(ITYPLU.NE.1) + > CALL XABORT('MACDRV: READ ERROR - INTEGER VARIABLE EXPECTED') + IF(NANISO.GT.NANISC) THEN + DEALLOCATE(ISCATA) + ALLOCATE(ISCATA(NANISO)) + ISCATA(:NANISO)=0 + ENDIF + ELSE IF(CARLIR.EQ.'NADF') THEN + CALL REDGET(ITYPLU,NTYPE,REALIR,CARLIR,DBLINP) + IF(ITYPLU.NE.1) CALL XABORT('MACDRV: READ ERROR - NUMBER ADF ' + > //'TYPES EXPECTED.') + IF(NTYPE.GT.0) IDF=2 + ELSE IF(CARLIR.EQ.'CTRA') THEN +*---- +* READ TRANSPORT CORRECTION TYPE +*---- + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLU,DBLINP) + IF(ITYPLU.NE.3) CALL XABORT('MACDRV: READ ERROR - CHARACTER CT' + > //'RA TYPE EXPECTED') + IF(CARLU.EQ.'NONE') THEN + ITRANC=0 + ELSE IF(CARLU.EQ.'APOL') THEN + ITRANC=1 + ELSE IF(CARLU.EQ.'WIMS') THEN + ITRANC=2 + ELSE IF(CARLU.EQ.'LEAK') THEN + ITRANC=4 + ELSE + CALL XABORT('MACDRV: NONE, APOL, WIMS OR LEAK EXPECTED') + ENDIF + ELSE IF(CARLIR.EQ.'NIFI') THEN + CALL REDGET(ITYPLU,NIFISS,REALIR,CARLU,DBLINP) + IF(ITYPLU.NE.1) + > CALL XABORT('MACDRV: READ ERROR - INTEGER VARIABLE EXPECTED') + MAXFIS=MAX(1,NIFISS) + ELSE IF(CARLIR.EQ.'NORM') THEN + LNORM=.TRUE. + ELSE IF(CARLIR.EQ.'ADD') THEN + IF(.NOT.LUPD) CALL XABORT('MACDRV: CANNOT USE THE ADD OPTION ON' + > //' A MACROLIB IN CREATION MODE') + LADD=.TRUE. + ELSE IF(CARLIR.EQ.'VOLUME') THEN +*---- +* READ MIXTURE VOLUMES +*---- + ALLOCATE(VOL(NBMIX)) + DO 177 IBM=1,NBMIX + CALL REDGET(ITYPLU,INTLU,VOL(IBM),CARLU,DBLINP) + IF(ITYPLU.NE.2) CALL XABORT('MACDRV: READ ERROR - REAL V' + > //'ARIABLE EXPECTED FOR VOLUME') + 177 CONTINUE + CALL LCMPUT(IPLIST,'VOLUME',NBMIX,2,VOL) + DEALLOCATE(VOL) + ELSE IF(CARLIR.EQ.'ENER') THEN +*---- +* READ ENERGY GROUPS +*---- + IF(NGROUP.GT.0) THEN + ALLOCATE(ENE(NGROUP+1),VEL(NGROUP)) + CALL REDGET(ITYPLU,INTLU,ENEMAX,CARLU,DBLINP) + IF(ITYPLU.NE.2) CALL XABORT('MACDRV: READ ERROR - REAL VAR' + > //'IABLE EXPECTED') + DO 179 IGR=1,NGROUP + ENE(IGR)=ENEMAX + CALL REDGET(ITYPLU,INTLU,ENECUR,CARLU,DBLINP) + IF(ITYPLU.NE.2) CALL XABORT('MACDRV: READ ERROR - REAL V' + > //'ARIABLE EXPECTED') + IF(ENECUR.GT.ENEMAX) CALL XABORT('MACDRV: READ ERROR - E' + > //'NERGY GOES FROM MAX TO MIN') + ENEMAX=ENECUR + 179 CONTINUE + IF(ENEMAX.LE.0.0) THEN + ENE(NGROUP+1)=1.0E-5 + ELSE + ENE(NGROUP+1)=ENEMAX + ENDIF + CALL LCMPUT(IPLIST,'ENERGY',NGROUP+1,2,ENE) + VELG1=SQRT(ENE(1)) + JVEL=1 + DO 178 IGR=1,NGROUP + VELG2=SQRT(ENE(IGR+1)) + VEL(JVEL)=REAL(SQFMAS)*SQRT(VELG1*VELG2) + VELG1=VELG2 + ENE(IGR)=LOG(ENE(IGR)/ENE(IGR+1)) + JVEL=JVEL+1 + 178 CONTINUE + CALL LCMPUT(IPLIST,'AVGVEL',NGROUP,2,VEL) + CALL LCMPUT(IPLIST,'DELTAU',NGROUP,2,ENE) + DEALLOCATE(VEL,ENE) + ENDIF + ELSE IF(CARLIR.EQ.'ALBP') THEN +*---- +* READ GROUP INDEPENDENT PHYSICAL ALBEDOS +*---- + CALL REDGET(ITYPLU,NALBD,REALIR,CARLU,DBLINP) + IF(ITYPLU.NE.1) CALL XABORT('MACDRV: INTEGER DATA EXPECTED.') + IF(NALBD.GT.0) THEN + NALBP=NALBD + IF(NGROUP.EQ.0) CALL XABORT('MACDRV: NGROUP MISSING FOR ALBP') + ALLOCATE(ALB(NALBD,NGROUP)) + DO IAL=1,NALBD + DO IGR=1,NGROUP + CALL REDGET(ITYPLU,INTLIR,ALB(IAL,IGR),CARLU,DBLINP) + IF(ITYPLU.NE.2) CALL XABORT('MACDRV: ALBEDO EXPECTED.') + ENDDO + ENDDO + CALL LCMPUT(IPLIST,'ALBEDO',NALBP*NGROUP,2,ALB) + DEALLOCATE(ALB) + ELSE + NALBP=0 + ENDIF + ELSE + CALL XABORT('MACDRV: '//CARLIR//' IS AN INVALID KEY-WORD.') + ENDIF + GO TO 1000 +*---- +* TRANSFER MODIFIED X-S ON THE MACROLIB +*---- + 2000 IF(.NOT.LIREAD) THEN + CALL MACPXS(LPLIST,MAXFIS,NGROUP,NBMIX,NIFISS,NANISO,NDELG, + > ITRANC,LNEWXS,TOTL,TOT1,FISS,SPEC,FIXE,TRANC,DIFF, + > NFTOT,H,SCAT,NEDMAC,ISCATA,NUDL,CHDL,DIFFX,DIFFY, + > DIFFZ,OVERV,XSINT0,XSINT1) + DEALLOCATE(DIFFZ,DIFFY,DIFFX,XSINT1,XSINT0,OVERV) + DEALLOCATE(CHDL,NUDL) + DEALLOCATE(SCAT,H,NFTOT,DIFF,TRANC,FIXE,SPEC,FISS,TOT1,TOTL) + ENDIF + DEALLOCATE(ISCATA) +*---- +* NORMALIZATION OF X-S INFORMATION +*---- + IF(LNORM) THEN + CALL MACNXS(IPLIST,MAXFIS,NGROUP,NBMIX,NIFISS,NANISO) + ENDIF +*---- +* PRINT/CHECK X-S INFORMATION +*---- + IF((IPRINT.NE.0).AND.(IPRINT.NE.1)) THEN + CALL MACWXS(IPLIST,IPRINT,NGROUP,NBMIX,NIFISS,NANISO, + > ITRANC,NEDMAC) + ENDIF + RETURN + END diff --git a/Dragon/src/MACIXS.f b/Dragon/src/MACIXS.f new file mode 100644 index 0000000..4fdf812 --- /dev/null +++ b/Dragon/src/MACIXS.f @@ -0,0 +1,295 @@ +*DECK MACIXS + SUBROUTINE MACIXS(IPLIST,MAXFIS,NGROUP,NBMIX,NIFISS,NANISO,NDELG, + > XSTOTL,XSTOT1,XSFISS,XSSPEC,XSFIXE,XSTRAN, + > XSDIFF,XSNFTO,XSH,XSSCAT,LOLDXS,ISCATA,XSNUDL, + > XSCHDL,XSDIFX,XSDIFY,XSDIFZ,XSOVRV,XSINT0, + > XSINT1) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Cross sections initialization. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPLIST LCM pointer to the macrolib. +* MAXFIS set to max(1,NIFISS). +* NGROUP number of energy groups. +* NBMIX maximum number of mixtures. +* NIFISS number of fissile isotopes. +* NANISO maximum Legendre order: +* =1 isotropic collision; +* =2 linearly anisotropic collision. +* NDELG number of precursor groups for delayed neutrons. +* +*Parameters: output +* XSTOTL P0 total cross section of mixture. +* XSTOT1 P1 total cross section of mixture. +* XSFISS nu*fission cross section of mixture. +* XSSPEC fission spectrum. +* XSFIXE fixed sources. +* XSTRAN transport correction. +* XSDIFF isotropic diffusion coefficient. +* XSNFTO fission cross section of mixture. +* XSH power factor (h-factor). +* XSSCAT scattering cross section of mixture/group. +* XSNUDL delayed nu*fission cross section of mixture. +* XSCHDL delayed neutron fission spectrum. +* XSDIFX x-directed diffusion coefficients. +* XSDIFY y-directed diffusion coefficients. +* XSDIFZ z-directed diffusion coefficients. +* XSOVRV reciprocal neutron velocities. +* XSINT0 P0 volume-integrated flux of mixture. +* XSINT1 P1 volume-integrated flux of mixture. +* LOLDXS flag to check if cross section type is already present on +* the macrolib. +* ISCATA check for scattering anisotropy. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIST + INTEGER MAXFIS,NGROUP,NBMIX,NIFISS,NANISO,NDELG,ISCATA(NANISO) + REAL XSTOTL(NBMIX,NGROUP),XSTOT1(NBMIX,NGROUP), + > XSFISS(NBMIX,MAXFIS,NGROUP),XSSPEC(NBMIX,MAXFIS,NGROUP), + > XSFIXE(NBMIX,NGROUP),XSTRAN(NBMIX,NGROUP), + > XSDIFF(NBMIX,NGROUP),XSNFTO(NBMIX,NGROUP), + > XSH(NBMIX,NGROUP),XSSCAT(NGROUP,NBMIX,NANISO,NGROUP), + > XSNUDL(NBMIX,MAXFIS,NDELG,NGROUP), + > XSCHDL(NBMIX,MAXFIS,NDELG,NGROUP), + > XSDIFX(NBMIX,NGROUP),XSDIFY(NBMIX,NGROUP), + > XSDIFZ(NBMIX,NGROUP),XSOVRV(NBMIX,NGROUP), + > XSINT0(NBMIX,NGROUP),XSINT1(NBMIX,NGROUP) + LOGICAL LOLDXS(18) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPLIST,KPLIST + CHARACTER CANISO*2,NAMREC*12,CHID*12,NUSIGD*12 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: INGSCT,IFGSCT + REAL, ALLOCATABLE, DIMENSION(:) :: XSWORK +*---- +* SCRATCH STORAGE ALLOCATION +* INGSCT number of scattering group for cross sections. +* IFGSCT first scattering group for cross sections. +* XSWORK work cross-section vector. +*---- + ALLOCATE(INGSCT(NBMIX),IFGSCT(NBMIX)) + ALLOCATE(XSWORK(NBMIX*NGROUP)) +*---- +* READ/INITIALIZE MACROLIB CROSS SECTION DATA +*---- + XSTOTL(:NBMIX,:NGROUP)=0.0 + XSTOT1(:NBMIX,:NGROUP)=0.0 + XSFISS(:NBMIX,:NIFISS,:NGROUP)=0.0 + XSSPEC(:NBMIX,:NIFISS,:NGROUP)=0.0 + XSFIXE(:NBMIX,:NGROUP)=0.0 + XSTRAN(:NBMIX,:NGROUP)=0.0 + XSDIFF(:NBMIX,:NGROUP)=0.0 + XSNFTO(:NBMIX,:NGROUP)=0.0 + XSH(:NBMIX,:NGROUP)=0.0 + XSSCAT(:NGROUP,:NBMIX,:NANISO,:NGROUP)=0.0 + IF(NDELG.GT.0) THEN + XSNUDL(:NBMIX,:NIFISS,:NDELG,:NGROUP)=0.0 + XSCHDL(:NBMIX,:NIFISS,:NDELG,:NGROUP)=0.0 + ENDIF + XSDIFX(:NBMIX,:NGROUP)=0.0 + XSDIFY(:NBMIX,:NGROUP)=0.0 + XSDIFZ(:NBMIX,:NGROUP)=0.0 + XSOVRV(:NBMIX,:NGROUP)=0.0 + XSINT0(:NBMIX,:NGROUP)=0.0 + XSINT1(:NBMIX,:NGROUP)=0.0 + JPLIST=LCMLID(IPLIST,'GROUP',NGROUP) + DO 200 IGROUP=1,NGROUP + KPLIST=LCMDIL(JPLIST,IGROUP) +*---- +* READ OR INITIALISE CHI AND NUSIGF +*---- + CALL LCMLEN(KPLIST,'NUSIGF',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + LOLDXS(2)=.TRUE. + CALL LCMGET(KPLIST,'NUSIGF',XSFISS(1,1,IGROUP)) + ELSE + XSFISS(:NBMIX,:NIFISS,IGROUP)=0.0 + ENDIF + CALL LCMLEN(KPLIST,'CHI',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + LOLDXS(4)=.TRUE. + CALL LCMGET(KPLIST,'CHI',XSSPEC(1,1,IGROUP)) + ELSE + XSSPEC(:NBMIX,:NIFISS,IGROUP)=0.0 + ENDIF +*---- +* READ OR INITIALISE TOTAL XS, FIXED SOURCES AND TRANSPORT CORRECTION +*---- + CALL LCMLEN(KPLIST,'NTOT0',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + LOLDXS(1)=.TRUE. + CALL LCMGET(KPLIST,'NTOT0',XSTOTL(1,IGROUP)) + ELSE + XSTOTL(:NBMIX,IGROUP)=0.0 + ENDIF + CALL LCMLEN(KPLIST,'FIXE',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + LOLDXS(3)=.TRUE. + CALL LCMGET(KPLIST,'FIXE',XSFIXE(1,IGROUP)) + ELSE + XSFIXE(:NBMIX,IGROUP)=0.0 + ENDIF + CALL LCMLEN(KPLIST,'TRANC',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + LOLDXS(6)=.TRUE. + CALL LCMGET(KPLIST,'TRANC',XSTRAN(1,IGROUP)) + ELSE + XSTRAN(:NBMIX,IGROUP)=0.0 + ENDIF + CALL LCMLEN(KPLIST,'DIFF',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + LOLDXS(7)=.TRUE. + CALL LCMGET(KPLIST,'DIFF',XSDIFF(1,IGROUP)) + ELSE + XSDIFF(:NBMIX,IGROUP)=0.0 + ENDIF + CALL LCMLEN(KPLIST,'H-FACTOR',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + LOLDXS(8)=.TRUE. + CALL LCMGET(KPLIST,'H-FACTOR',XSH(1,IGROUP)) + ELSE + XSH(:NBMIX,IGROUP)=0.0 + ENDIF + CALL LCMLEN(KPLIST,'NTOT1',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + LOLDXS(9)=.TRUE. + CALL LCMGET(KPLIST,'NTOT1',XSTOT1(1,IGROUP)) + ELSE + XSTOT1(:NBMIX,IGROUP)=0.0 + ENDIF +*---- +* READ OR INITIALISE DIFFX, DIFFY, DIFFZ, CHID AND OVERV +*---- + CALL LCMLEN(KPLIST,'DIFFX',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + LOLDXS(10)=.TRUE. + CALL LCMGET(KPLIST,'DIFFX',XSDIFX(1,IGROUP)) + ELSE + XSDIFX(:NBMIX,IGROUP)=0.0 + ENDIF + CALL LCMLEN(KPLIST,'DIFFY',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + LOLDXS(11)=.TRUE. + CALL LCMGET(KPLIST,'DIFFY',XSDIFY(1,IGROUP)) + ELSE + XSDIFY(:NBMIX,IGROUP)=0.0 + ENDIF + CALL LCMLEN(KPLIST,'DIFFZ',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + LOLDXS(12)=.TRUE. + CALL LCMGET(KPLIST,'DIFFZ',XSDIFZ(1,IGROUP)) + ELSE + XSDIFZ(:NBMIX,IGROUP)=0.0 + ENDIF + DO I=1,NDELG + WRITE(NUSIGD,'(A6,I2.2)') 'NUSIGF',I + CALL LCMLEN(KPLIST,NUSIGD,ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + LOLDXS(13)=.TRUE. + CALL LCMGET(KPLIST,NUSIGD,XSNUDL(1,1,I,IGROUP)) + ELSE + XSNUDL(:NBMIX,:NIFISS,I,IGROUP)=0.0 + ENDIF + WRITE(CHID,'(A3,I2.2)') 'CHI',I + CALL LCMLEN(KPLIST,CHID,ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + LOLDXS(14)=.TRUE. + CALL LCMGET(KPLIST,CHID,XSCHDL(1,1,I,IGROUP)) + ELSE + XSCHDL(:NBMIX,:NIFISS,I,IGROUP)=0.0 + ENDIF + ENDDO + CALL LCMLEN(KPLIST,'OVERV',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + LOLDXS(15)=.TRUE. + CALL LCMGET(KPLIST,'OVERV',XSOVRV(1,IGROUP)) + ELSE + XSOVRV(:NBMIX,IGROUP)=0.0 + ENDIF + CALL LCMLEN(KPLIST,'NFTOT',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + LOLDXS(16)=.TRUE. + CALL LCMGET(KPLIST,'NFTOT',XSNFTO(1,IGROUP)) + ELSE + XSNFTO(:NBMIX,IGROUP)=0.0 + ENDIF + CALL LCMLEN(KPLIST,'FLUX-INTG',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + LOLDXS(17)=.TRUE. + CALL LCMGET(KPLIST,'FLUX-INTG',XSINT0(1,IGROUP)) + ELSE + XSINT0(:NBMIX,IGROUP)=0.0 + ENDIF + CALL LCMLEN(KPLIST,'FLUX-INTG-P1',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + LOLDXS(18)=.TRUE. + CALL LCMGET(KPLIST,'FLUX-INTG-P1',XSINT1(1,IGROUP)) + ELSE + XSINT1(:NBMIX,IGROUP)=0.0 + ENDIF +*---- +* READ OR INITIALISE SCATTERING CROSS SECTIONS +*---- + DO 203 IANIS=1,NANISO + WRITE(CANISO,'(I2.2)') IANIS-1 + NAMREC='SCAT'//CANISO + CALL LCMLEN(KPLIST,NAMREC,ILCMLN,ITYLCM) + ICMATR=0 + IF(ILCMLN.GT.0) THEN + LOLDXS(5)=.TRUE. + ISCATA(IANIS)=1 +*---- +* READ COMPRESS SCATTERING XS PLUS INFORMATION TO EXPAND XS +*---- + CALL LCMGET(KPLIST,NAMREC,XSWORK) + NAMREC='NJJS'//CANISO + CALL LCMLEN(KPLIST,NAMREC,ICMATR,ITYLCM) + CALL LCMGET(KPLIST,NAMREC,INGSCT) + NAMREC='IJJS'//CANISO + CALL LCMGET(KPLIST,NAMREC,IFGSCT) +*---- +* EXPAND SCATTERING XS TO XSSCAT(JGROUP,IMATER,IANIS,IGROUP) +* WHERE IGROUP IS THE SECONDARY GROUP. +*---- + IPWRK=1 + DO 204 IMATER=1,ICMATR + IF(INGSCT(IMATER).GT.0) THEN + IGD=IFGSCT(IMATER) + IGF=IGD-INGSCT(IMATER)+1 + DO 205 JGROUP=IGD,IGF,-1 + XSSCAT(JGROUP,IMATER,IANIS,IGROUP)=XSWORK(IPWRK) + IPWRK=IPWRK+1 + 205 CONTINUE + ENDIF + 204 CONTINUE + ENDIF + 203 CONTINUE + 200 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XSWORK) + DEALLOCATE(IFGSCT,INGSCT) + RETURN + END diff --git a/Dragon/src/MACNFI.f b/Dragon/src/MACNFI.f new file mode 100644 index 0000000..c0f46b9 --- /dev/null +++ b/Dragon/src/MACNFI.f @@ -0,0 +1,220 @@ +*DECK MACNFI + SUBROUTINE MACNFI(IPMACR,IPRINT,IEN ,NTOTMX,NGROUP,NIFISS, + > NEDMAC,NBMIXF,NGROF ,NIFISF,NEDF ,NDELF , + > NBMIXO,NIFISO,NEDO ,NDELO ,IMLOC ,ENERGN, + > NAMEDN,NUMFN ,NUMPX ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Update list of fissile isotopes from those on a specific macrolib. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPMACR pointer to structures. +* IPRINT print level. +* IEN macrolib index to process. +* NTOTMX maximum number of mixtures. +* NGROUP number of groups. +* NIFISS maximum number fissile isotopes per mixture. +* NEDMAC number of aditional edition x-s. +* NBMIXO number of mixtures in IPMACR. +* NIFISO number of fissile isotopes in IPMACR. +* NEDO number of aditional x-s in IPMACR. +* NDELO number of precursor groups in IPMACR. +* IMLOC mixture location. +* NBMIXF final number of mixtures. +* +*Parameters: input/output +* NGROF number of groups tested. +* NIFISF final number fissile isotopes. +* NEDF final number of aditional x-s. +* NDELF final number of precursor groups. +* ENERGN final energy/lethargy vector. +* NAMEDN final edit names. +* NUMFN final 'FISSIONINDEX' record. +* NUMPX correspondence between old and new 'NUSIGF' arrays. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMACR + INTEGER IPRINT,IEN ,NTOTMX,NGROUP,NIFISS,NEDMAC, + > NBMIXF,NGROF,NIFISF,NEDF,NDELF,NBMIXO, + > NIFISO,NEDO,NDELO,IMLOC(2,NTOTMX), + > NAMEDN(2,NEDMAC),NUMFN(NBMIXF,NIFISS), + > NUMPX(NBMIXF,NIFISS) + REAL ENERGN(2*NGROUP+1) +*---- +* LOCAL VARIABLES +*---- + INTEGER IOUT + PARAMETER (IOUT=6) + INTEGER IGR,ILO,ILN,JLN,IMXN,IMAC,IMIX,ITC,ISOT,ILCMLN, + > ILCMTY,NGROO +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NAMEDO,NUMFO + REAL, ALLOCATABLE, DIMENSION(:) :: ENERGO +*---- +* SCRATCH STORAGE ALLOCATION +* ENERGO energy/lethargy vector in IPMACR +* NAMEDO edit names in IPMACR +* NUMFO 'FISSIONINDEX' record in IPMACR +*---- + ALLOCATE(NAMEDO(2,NEDO),NUMFO(NBMIXO,NIFISO)) +*---- +* PRINT HEADER IF REQUIRED +*---- + IF(IPRINT.GE.10) WRITE(IOUT,6000) IEN +*---- +* TEST FOR ENERGY +*---- + NGROO=0 + CALL LCMLEN(IPMACR,'ENERGY',ILCMLN,ILCMTY) + IF(ILCMLN.GT.0) THEN + NGROO=ILCMLN-1 + ALLOCATE(ENERGO(2*NGROO+1)) + IF(NGROF.GT.0) THEN + CALL LCMGET(IPMACR,'ENERGY',ENERGO(1)) + DO IGR=1,NGROO + ENERGO(NGROO+1+IGR)=LOG(ENERGO(IGR)/ENERGO(IGR+1)) + ENDDO + DO IGR=1,2*NGROO+1 + IF(ABS(ENERGN(IGR)-ENERGO(IGR)).GT.1.0E-6*ENERGN(IGR)) THEN + WRITE(IOUT,9000) IEN + WRITE(IOUT,'(21H MACNFI: ENERGN MESH:)') + WRITE(IOUT,'(5X,1P,10E12.4)') ENERGN(:2*NGROO+1) + WRITE(IOUT,'(21H MACNFI: ENERGO MESH:)') + WRITE(IOUT,'(5X,1P,10E12.4)') ENERGO(:2*NGROO+1) + GO TO 110 + ENDIF + ENDDO + ELSE + CALL LCMGET(IPMACR,'ENERGY',ENERGN(1)) + DO IGR=1,NGROO + ENERGN(NGROO+1+IGR)=LOG(ENERGN(IGR)/ENERGN(IGR+1)) + ENDDO + NGROF=NGROO + ENDIF + ENDIF +*---- +* TEST FOR ADDITIONAL EDIT XS +*---- + 110 IF(NEDO.GT.0) THEN + CALL LCMGET(IPMACR,'ADDXSNAME-P0',NAMEDO) + IF(IPRINT.GE.10) THEN + WRITE(IOUT,6010) 'ADDXSNAME-P0' + WRITE(IOUT,6011) ((NAMEDO(ITC,ILO),ITC=1,2),ILO=1,NEDO) + ENDIF + NEDF=0 + DO 140 ILO=1,NEDO + DO 120 ILN=1,NEDF + IF( NAMEDO(1,ILO) .EQ. NAMEDN(1,ILN) .AND. + > NAMEDO(1,ILO) .EQ. NAMEDN(1,ILN) ) GO TO 130 + 120 CONTINUE + NEDF=NEDF+1 + NAMEDN(1,ILN)=NAMEDO(1,ILO) + NAMEDN(2,ILN)=NAMEDO(2,ILO) + 130 CONTINUE + 140 CONTINUE + ENDIF +*---- +* TEST FOR PRECURSOR GROUPS +*---- + IF(NDELO.GT.0) THEN + IF(NDELF.EQ.0) THEN + NDELF=NDELO + ELSE IF(NDELF.NE.NDELO) THEN + CALL XABORT('MACNFI: INVALID NUMBER OF PRECURSOR GROUPS.') + ENDIF + ENDIF +*---- +* TEST FOR FISSILE ISOTOPES NAMES +* STORE IN NUMFN THE LOCATION OF CROSS SECTION IN OLD NUSIGF AND CHI +*---- + IF(NIFISO.GT.0) THEN + CALL LCMLEN(IPMACR,'FISSIONINDEX',ILCMLN,ILCMTY) + IF(ILCMLN.EQ.0) THEN + IF(NIFISO.EQ.1) THEN +* IF(NIFISF.GT.1) CALL XABORT('MACNFI: MISSING FISSIONINDEX RE' +* > //'CORD.') + DO 145 IMXN=1,NBMIXF ! loop over new mixture indices + IMAC=IMLOC(1,IMXN) ! old macrolib index + IMIX=IMLOC(2,IMXN) ! old mixture index + IF(IMAC.EQ.IEN) THEN + NIFISF=1 + NUMFN(IMXN,1)=1 + NUMPX(IMXN,1)=IMIX + ENDIF + 145 CONTINUE + GO TO 190 + ENDIF + NUMFO(:NBMIXO,:NIFISO)=-1 + ELSE + IF(ILCMLN.GT.NBMIXO*NIFISO) + > CALL XABORT('MACNFI: FISSIONINDEX OVERFLOW,') + CALL LCMGET(IPMACR,'FISSIONINDEX',NUMFO) + ENDIF + IF(IPRINT.GE.10) THEN + WRITE(IOUT,6010) 'FISSIONINDEX' + WRITE(IOUT,6012) ((NUMFO(ITC,ILO),ITC=1,NBMIXO),ILO=1,NIFISO) + ENDIF + DO 180 IMXN=1,NBMIXF ! loop over new mixture indices + IMAC=IMLOC(1,IMXN) ! old macrolib index + IMIX=IMLOC(2,IMXN) ! old mixture index + IF(IMAC.EQ.IEN) THEN + DO 170 ILO=1,NIFISO ! loop over old fissile isotopes + ISOT=NUMFO(IMIX,ILO) ! a reference to the old microlib + DO 150 JLN=1,NIFISF ! loop over new fissile isotopes + IF(NUMFN(IMXN,JLN).EQ.ISOT) GO TO 170 + 150 CONTINUE + DO 160 JLN=1,NIFISF + IF(NUMFN(IMXN,JLN).EQ.0) THEN + NUMFN(IMXN,JLN)=ISOT + NUMPX(IMXN,JLN)=(ILO-1)*NBMIXO+IMIX + GO TO 170 + ENDIF + 160 CONTINUE + NIFISF=NIFISF+1 + IF(NIFISF.GT.NIFISS) CALL XABORT('MACNFI: NUMFN OVERFLOW') + NUMFN(IMXN,NIFISF)=ISOT + NUMPX(IMXN,NIFISF)=(ILO-1)*NBMIXO+IMIX + 170 CONTINUE + ENDIF + 180 CONTINUE + 190 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + IF(NGROO.GT.0) DEALLOCATE(ENERGO) + DEALLOCATE(NUMFO,NAMEDO) + RETURN +*---- +* EDIT FORMATS +*---- + 6000 FORMAT(1X,'MACNFI - PROCESSING MACROLIB : ',I12) + 6010 FORMAT(7X, ' PRECESSING RECORD : ',A12) + 6011 FORMAT(10(2A4,4X)) + 6012 FORMAT(10(I8,4X)) +*---- +* WARNING FORMATS +*---- + 9000 FORMAT(' **** WARNING IN MACNFI FOR MACROLIB : ',I12/ + > ' ENERGY GROUP STRUCTURE NOT COMPATIBLE'/ + > ' **** CORRECTION: USE LAST ENERGY STRUCTURE') + END diff --git a/Dragon/src/MACNXS.f b/Dragon/src/MACNXS.f new file mode 100644 index 0000000..255e884 --- /dev/null +++ b/Dragon/src/MACNXS.f @@ -0,0 +1,141 @@ +*DECK MACNXS + SUBROUTINE MACNXS(IPLIST,MAXFIS,NGROUP,NBMIX,NIFISS,NANISO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Normalization of macroscopic cross section information. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPLIST LCM pointer to the macrolib. +* MAXFIS set to max(1,NIFISS). +* NGROUP number of energy groups. +* NBMIX number of mixtures. +* NIFISS number of fissile isotopes. +* NANISO maximum Legendre order: +* =1 isotropic collision; +* =2 linearly anisotropic collision. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIST + INTEGER MAXFIS,NGROUP,NBMIX,NIFISS,NANISO +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPLIST,KPLIST + CHARACTER CANISO*2 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: INGSCT,IFGSCT + REAL, ALLOCATABLE, DIMENSION(:) :: XSWORK,XSWOR2 + REAL, ALLOCATABLE, DIMENSION(:,:) :: CHWORK + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: SCWORK +*---- +* SCRATCH STORAGE ALLOCATION +* INGSCT number of scattering group for cross sections. +* IFGSCT first scattering group for cross sections. +*---- + ALLOCATE(INGSCT(NBMIX),IFGSCT(NBMIX)) + ALLOCATE(XSWORK(NBMIX*NGROUP),XSWOR2(NBMIX*NIFISS), + > CHWORK(NBMIX,MAXFIS)) + ALLOCATE(SCWORK(NBMIX,NANISO,NGROUP)) +* + DO 100 IMIX=1,NBMIX + DO 110 IAN=1,NANISO + DO 120 IG=1,NGROUP + SCWORK(IMIX,IAN,IG)=0.0D0 + 120 CONTINUE + 110 CONTINUE + DO 130 JFIS=1,NIFISS + CHWORK(IMIX,JFIS)=0.0 + 130 CONTINUE + 100 CONTINUE + JPLIST=LCMGID(IPLIST,'GROUP') + DO 140 IGR=1,NGROUP + KPLIST=LCMGIL(JPLIST,IGR) +*---- +* COMPUTE SUM OF FISSION SPECTRUM. +*---- + CALL LCMLEN(KPLIST,'CHI',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPLIST,'CHI',XSWOR2) + DO 150 IFISS=1,NIFISS + DO 160 IMAT=1,NBMIX + CHWORK(IMAT,IFISS)=CHWORK(IMAT,IFISS) + > +XSWOR2((IFISS-1)*NBMIX+IMAT) + 160 CONTINUE + 150 CONTINUE + ENDIF +*---- +* SUM TRANSFER MATRICES OVER SECONDARY GROUPS. +*---- + DO 170 IANIS=1,NANISO + WRITE(CANISO,'(I2.2)') IANIS-1 + CALL LCMLEN(KPLIST,'NJJS'//CANISO,ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPLIST,'NJJS'//CANISO,INGSCT) + CALL LCMGET(KPLIST,'IJJS'//CANISO,IFGSCT) + CALL LCMGET(KPLIST,'SCAT'//CANISO,XSWORK) + IPO=0 + DO 180 IMAT=1,NBMIX + IDG=IFGSCT(IMAT) + IFG=IDG-INGSCT(IMAT)+1 + DO 190 JGR=IDG,IFG,-1 + IPO=IPO+1 + SCWORK(IMAT,IANIS,JGR)=SCWORK(IMAT,IANIS,JGR) + > +XSWORK(IPO) + 190 CONTINUE + 180 CONTINUE + ENDIF + 170 CONTINUE + 140 CONTINUE +*---- +* WRITE NORMALIZED X-S ON THE MACROLIB. +*---- + DO 200 IGR=1,NGROUP + KPLIST=LCMGIL(JPLIST,IGR) + CALL LCMLEN(KPLIST,'CHI',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPLIST,'CHI',XSWOR2) + DO 210 IFISS=1,NIFISS + DO 220 IMAT=1,NBMIX + IF(CHWORK(IMAT,IFISS).GT.0.5) XSWOR2((IFISS-1)*NBMIX+IMAT) + > =XSWOR2((IFISS-1)*NBMIX+IMAT)/CHWORK(IMAT,IFISS) + 220 CONTINUE + 210 CONTINUE + CALL LCMPUT(KPLIST,'CHI',NBMIX*NIFISS,2,XSWOR2) + ENDIF + DO 230 IANIS=1,NANISO + WRITE(CANISO,'(I2.2)') IANIS-1 + CALL LCMLEN(KPLIST,'SIGS'//CANISO,ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + DO 240 IMAT=1,NBMIX + XSWORK(IMAT)=REAL(SCWORK(IMAT,IANIS,IGR)) + 240 CONTINUE + CALL LCMPUT(KPLIST,'SIGS'//CANISO,NBMIX,2,XSWORK) + ENDIF + 230 CONTINUE + 200 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SCWORK) + DEALLOCATE(CHWORK,XSWOR2,XSWORK) + DEALLOCATE(IFGSCT,INGSCT) + RETURN + END diff --git a/Dragon/src/MACOPT.f b/Dragon/src/MACOPT.f new file mode 100644 index 0000000..f38bb3f --- /dev/null +++ b/Dragon/src/MACOPT.f @@ -0,0 +1,196 @@ +*DECK MACOPT + SUBROUTINE MACOPT(IPMAC,IPOPT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Update a Macrolib using control variables from a L_OPTIMIZE object. +* +*Copyright: +* Copyright (C) 2012 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMAC pointer to the macrolib to be updated. +* IPOPT pointer to the L_OPTIMIZE object open in read-only mode. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMAC,IPOPT +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + TYPE(C_PTR) JPMAC,KPMAC + INTEGER ISTATE(NSTATE) +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: GAR + REAL, ALLOCATABLE, DIMENSION(:,:) :: SPH,ALB + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: VARV +*---- +* GET L_OPTIMIZE INFORMATION +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(IPOPT,'DEL-STATE',ISTATE) + NGRP=ISTATE(1) + NMIX=ISTATE(2) + ITYPE=ISTATE(3) + IDELTA=ISTATE(4) + NGR1=ISTATE(5) + NGR2=ISTATE(6) + IBM1=ISTATE(7) + IBM2=ISTATE(8) +*---- +* GET MACROLIB INFORMATION +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE) + IF(ISTATE(1).NE.NGRP) CALL XABORT('MACOPT: INVALID NGRP.') + IF(ISTATE(2).NE.NMIX) CALL XABORT('MACOPT: INVALID NMIX.') + NIFISS=ISTATE(4) + NED=ISTATE(5) + NALBP=ISTATE(8) + ILEAK=ISTATE(9) + IF(ITYPE.EQ.2) THEN + ISTATE(10)=MAX(1,ISTATE(10)) + CALL LCMPUT(IPMAC,'STATE-VECTOR',NSTATE,1,ISTATE) + ENDIF + NPERT=(NGR2-NGR1+1)*(NALBP+IBM2-IBM1+1) + IF(IDELTA.EQ.5) NPERT=(NGR2-NGR1+1)*NALBP +*---- +* CORRECT MACROLIB +*---- + ALLOCATE(VARV(NPERT)) + CALL LCMGET(IPOPT,'VAR-VALUE',VARV) + IF(IDELTA.LE.2) THEN +*---- +* UPDATE ONLY LEAKAGE INFORMATION IN MACROLIB +*---- + ALLOCATE(GAR(3*NMIX)) + JPMAC=LCMGID(IPMAC,'GROUP') + IPERT=0 + DO 70 IGR=NGR1,NGR2 + KPMAC=LCMDIL(JPMAC,IGR) + IF((IDELTA.EQ.1).AND.(ITYPE.EQ.1).AND.(ILEAK.EQ.1)) THEN + CALL LCMGET(KPMAC,'DIFF',GAR) + DO 10 IBM=IBM1,IBM2 + IPERT=IPERT+1 + GAR(IBM)=REAL(VARV(IPERT)) + 10 CONTINUE + CALL LCMPUT(KPMAC,'DIFF',NMIX,2,GAR) + ELSE IF((IDELTA.EQ.1).AND.(ITYPE.EQ.1).AND.(ILEAK.EQ.2)) THEN + CALL LCMGET(KPMAC,'DIFFX',GAR) + CALL LCMGET(KPMAC,'DIFFY',GAR(NMIX+1)) + CALL LCMGET(KPMAC,'DIFFZ',GAR(2*NMIX+1)) + DO 20 IBM=IBM1,IBM2 + IPERT=IPERT+1 + GAR(IBM)=REAL(VARV(IPERT)) + GAR(NMIX+IBM)=REAL(VARV(IPERT)) + GAR(2*NMIX+IBM)=REAL(VARV(IPERT)) + 20 CONTINUE + CALL LCMPUT(KPMAC,'DIFFX',NMIX,2,GAR) + CALL LCMPUT(KPMAC,'DIFFY',NMIX,2,GAR(NMIX+1)) + CALL LCMPUT(KPMAC,'DIFFZ',NMIX,2,GAR(2*NMIX+1)) + ELSE IF((IDELTA.EQ.1).AND.(ITYPE.EQ.2)) THEN + CALL LCMLEN(KPMAC,'NTOT1',ILONG,ITYLCM) + IF(ILONG.NE.0.0) THEN + CALL LCMGET(KPMAC,'NTOT1',GAR) + ELSE + CALL LCMGET(KPMAC,'NTOT0',GAR) + ENDIF + DO 30 IBM=IBM1,IBM2 + IPERT=IPERT+1 + GAR(IBM)=REAL(VARV(IPERT)) + 30 CONTINUE + CALL LCMPUT(KPMAC,'NTOT1',NMIX,2,GAR) + ELSE IF((IDELTA.EQ.2).AND.(ITYPE.EQ.1).AND.(ILEAK.EQ.1)) THEN + CALL LCMGET(KPMAC,'DIFF',GAR) + DO 40 IBM=IBM1,IBM2 + IPERT=IPERT+1 + FACT=REAL(VARV(IPERT)) + GAR(IBM)=GAR(IBM)*FACT + 40 CONTINUE + CALL LCMPUT(KPMAC,'DIFF',NMIX,2,GAR) + ELSE IF((IDELTA.EQ.2).AND.(ITYPE.EQ.1).AND.(ILEAK.EQ.2)) THEN + CALL LCMGET(KPMAC,'DIFFX',GAR) + CALL LCMGET(KPMAC,'DIFFY',GAR(NMIX+1)) + CALL LCMGET(KPMAC,'DIFFZ',GAR(2*NMIX+1)) + DO 50 IBM=IBM1,IBM2 + IPERT=IPERT+1 + FACT=REAL(VARV(IPERT)) + GAR(IBM)=GAR(IBM)*FACT + GAR(NMIX+IBM)=GAR(NMIX+IBM)*FACT + GAR(2*NMIX+IBM)=GAR(2*NMIX+IBM)*FACT + 50 CONTINUE + CALL LCMPUT(KPMAC,'DIFFX',NMIX,2,GAR) + CALL LCMPUT(KPMAC,'DIFFY',NMIX,2,GAR(NMIX+1)) + CALL LCMPUT(KPMAC,'DIFFZ',NMIX,2,GAR(2*NMIX+1)) + ELSE IF((IDELTA.EQ.2).AND.(ITYPE.EQ.2)) THEN + CALL LCMLEN(KPMAC,'NTOT1',ILONG,ITYLCM) + IF(ILONG.NE.0.0) THEN + CALL LCMGET(KPMAC,'NTOT1',GAR) + ELSE + CALL LCMGET(KPMAC,'NTOT0',GAR) + ENDIF + DO 60 IBM=IBM1,IBM2 + IPERT=IPERT+1 + FACT=REAL(VARV(IPERT)) + GAR(IBM)=GAR(IBM)*FACT + 60 CONTINUE + CALL LCMPUT(KPMAC,'NTOT1',NMIX,2,GAR) + ENDIF + 70 CONTINUE + DEALLOCATE(GAR) + ELSE IF(IDELTA.EQ.5) THEN +*---- +* CORRECT ONLY THE ALBEDO +*---- + ALLOCATE(ALB(NALBP,NGRP)) + CALL LCMGET(IPMAC,'ALBEDO',ALB) + IPERT=0 + DO 90 IGR=NGR1,NGR2 + DO 80 IAL=1,NALBP + IPERT=IPERT+1 + FACT=0.5*(1.0-ALB(IAL,IGR))/(1.0+ALB(IAL,IGR))*REAL(VARV(IPERT)) + ALB(IAL,IGR)=(1.0-2.0*FACT)/(1.0+2.0*FACT) + 80 CONTINUE + 90 CONTINUE + CALL LCMPUT(IPMAC,'ALBEDO',NGRP*NALBP,2,ALB) + DEALLOCATE(ALB) + ELSE +*---- +* APPLY A FULL SPH CORRECTION +*---- + IPRINT=0 + IMC=IDELTA-2 + ALLOCATE(SPH(NMIX+NALBP,NGRP)) + SPH(:NMIX+NALBP,:NGRP)=1.0 + IPERT=0 + DO 120 IGR=NGR1,NGR2 + DO 100 IBM=IBM1,IBM2 + IPERT=IPERT+1 + SPH(IBM,IGR)=REAL(VARV(IPERT)) + 100 CONTINUE + DO 110 IAL=1,NALBP + IPERT=IPERT+1 + SPH(NMIX+IAL,IGR)=REAL(VARV(IPERT)) + 110 CONTINUE + 120 CONTINUE + CALL SPHCMA(IPMAC,IPRINT,IMC,NMIX,NGRP,NIFISS,NED,NALBP,SPH) + DEALLOCATE(SPH) + ENDIF + DEALLOCATE(VARV) + IF(IPERT.NE.NPERT) CALL XABORT('MACOPT: UPDATE FAILURE.') + RETURN + END diff --git a/Dragon/src/MACPRM.f b/Dragon/src/MACPRM.f new file mode 100644 index 0000000..36470f6 --- /dev/null +++ b/Dragon/src/MACPRM.f @@ -0,0 +1,178 @@ +*DECK MACPRM + SUBROUTINE MACPRM(IPMACR,IPRINT,NGROUP,NANISO,NBMIXF,NIFISF, + > NEDF ,NDELF ,NREACD,NTREA ,IGR ,NAMREA, + > NAMEDN,IXSPRO,XSGEN ,XSIGS ,XSSCAT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Save a new macrolib created from old macrolibs. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPMACR pointer to structures. +* IPRINT print level. +* NGROUP number of groups. +* NANISO maximun scattering anisotropy. +* NBMIXF final number of mixtures. +* NIFISF final number fissile isotopes. +* NEDF final number of aditional x-s. +* NDELF final number of precursor groups. +* NREACD number of default x-s. +* NTREA total number of x-s types. +* IGR current group being processed. +* NAMREA name of default x-s. +* NAMEDN name of edit x-s. +* IXSPRO flag for cross section processing. +* XSGEN general x-s vector. +* XSIGS scattering x-s vector. +* XSSCAT general scattering matrix. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMACR + INTEGER IPRINT,NGROUP,NANISO,NBMIXF,NIFISF,NEDF,NDELF,NREACD, + > NTREA,IGR,NAMEDN(2,NEDF),IXSPRO(NTREA+2*NANISO+1) + CHARACTER NAMREA(NREACD)*12 + REAL XSGEN(NBMIXF,NTREA+2),XSIGS(NBMIXF,NANISO), + > XSSCAT(NGROUP,NBMIXF,NANISO) +*---- +* LOCAL VARIABLES +*---- + INTEGER IOUT + PARAMETER (IOUT=6) + INTEGER IDEL,IMIX,IREA,IREAF,IREAP,IREAA,IED,IANIS,IGD,IGF, + > JGR,ITC,NELEM,IOF + CHARACTER NAMADD*12,CANISO*2,CHID*12,NUSIGD*12 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISCAT + REAL, ALLOCATABLE, DIMENSION(:) :: SCTMP +*---- +* SCRATCH STORAGE ALLOCATION +* SCTMP temporary scattering matrix +* ISCAT scattering pointer +*---- + ALLOCATE(ISCAT(NBMIXF,3)) + ALLOCATE(SCTMP(NGROUP*NBMIXF)) +*---- +* PRINT HEADER +*---- + IF(IPRINT.GE.10) WRITE(IOUT,6000) +*---- +* 1) DEFAULT XS +*---- + DO 100 IREA=1,NREACD + IF(IXSPRO(IREA).EQ.1) THEN + IF(IPRINT.GE.10) WRITE(IOUT,6010) NAMREA(IREA) + CALL LCMPUT(IPMACR,NAMREA(IREA),NBMIXF,2,XSGEN(1,IREA)) + ENDIF + 100 CONTINUE +*---- +* 2) CHI AND NUSIGF +*---- + IF(NIFISF.GT.0) THEN + IREAF=NREACD+1 + IREAP=NREACD+NIFISF+1 + IF(IXSPRO(IREAF).EQ.1) THEN + IF(IPRINT.GE.10) WRITE(IOUT,6010) 'NUSIGF ' + CALL LCMPUT(IPMACR,'NUSIGF',NBMIXF*NIFISF,2,XSGEN(1,IREAF)) + ENDIF + IF(IXSPRO(IREAP).EQ.1) THEN + IF(IPRINT.GE.10) WRITE(IOUT,6010) 'CHI ' + CALL LCMPUT(IPMACR,'CHI',NBMIXF*NIFISF,2,XSGEN(1,IREAP)) + ENDIF + DO 110 IDEL=1,NDELF + WRITE(NUSIGD,'(A6,I2.2)') 'NUSIGF',IDEL + IF(IPRINT.GE.10) WRITE(IOUT,6010) NUSIGD + IOF=IREAF+2*IDEL*NIFISF + CALL LCMPUT(IPMACR,NUSIGD,NBMIXF*NIFISF,2,XSGEN(1,IOF)) + WRITE(CHID,'(A3,I2.2)') 'CHI',IDEL + IF(IPRINT.GE.10) WRITE(IOUT,6010) CHID + IOF=IREAP+2*IDEL*NIFISF + CALL LCMPUT(IPMACR,CHID,NBMIXF*NIFISF,2,XSGEN(1,IOF)) + 110 CONTINUE + ENDIF +*---- +* 3) ADDITIONAL EDIT XS +*---- + IF(NEDF.GT.0) THEN + IREAA=NREACD+2*NIFISF*(NDELF+1) + DO 120 IED=1,NEDF + IF(IXSPRO(IREAA+IED).EQ.1) THEN + WRITE(NAMADD,'(A4,A2)') (NAMEDN(ITC,IED),ITC=1,2) + IF(IPRINT.GE.10) WRITE(IOUT,6010) NAMADD + CALL LCMPUT(IPMACR,NAMADD,NBMIXF,2,XSGEN(1,IREAA+IED)) + ENDIF + 120 CONTINUE + ENDIF +*---- +* 4) SCATTERING XS +*---- + DO 130 IANIS=1,NANISO + IF(IXSPRO(NTREA+IANIS).EQ.1) THEN + WRITE(CANISO,'(I2.2)') IANIS-1 + IF(IPRINT.GE.10) WRITE(IOUT,6010) 'SCATTERING'//CANISO + XSGEN(:NBMIXF,1)=0.0 +*---- +* 4.3) TREAT SCAT +*---- + NELEM=0 + DO 140 IMIX=1,NBMIXF + IGD=IGR + IGF=IGR + XSGEN(IMIX,1)=XSSCAT(IGR,IMIX,IANIS) + DO 141 JGR=1,NGROUP + IF(XSSCAT(JGR,IMIX,IANIS).NE.0.0) THEN + IGD=MAX(IGD,JGR) + IGF=MIN(IGF,JGR) + ENDIF + 141 CONTINUE + ISCAT(IMIX,1)=IGD + ISCAT(IMIX,2)=IGD-IGF+1 + ISCAT(IMIX,3)=NELEM+1 + DO 142 JGR=IGD,IGF,-1 + NELEM=NELEM+1 + SCTMP(NELEM)=XSSCAT(JGR,IMIX,IANIS) + 142 CONTINUE + 140 CONTINUE + CALL LCMPUT(IPMACR,'SIGW'//CANISO,NBMIXF,2,XSGEN(1,1)) + CALL LCMPUT(IPMACR,'IJJS'//CANISO,NBMIXF,1,ISCAT(1,1)) + CALL LCMPUT(IPMACR,'NJJS'//CANISO,NBMIXF,1,ISCAT(1,2)) + CALL LCMPUT(IPMACR,'IPOS'//CANISO,NBMIXF,1,ISCAT(1,3)) + CALL LCMPUT(IPMACR,'SCAT'//CANISO,NELEM,2,SCTMP) + ENDIF + IF(IXSPRO(NTREA+NANISO+IANIS).EQ.1) THEN + CALL LCMPUT(IPMACR,'SIGS'//CANISO,NBMIXF,2,XSIGS(1,IANIS)) + ENDIF + 130 CONTINUE + DEALLOCATE(SCTMP) + DEALLOCATE(ISCAT) +*---- +* 6) STOPPING POWER +*---- + IF(IXSPRO(NTREA+2*NANISO+1).EQ.1) THEN + IF(IPRINT.GE.10) WRITE(IOUT,6010) 'ESTOPW' + CALL LCMPUT(IPMACR,'ESTOPW',2*NBMIXF,2,XSGEN(1,NTREA+1)) + ENDIF + RETURN +*---- +* EDIT FORMATS +*---- + 6000 FORMAT(1X,'MACPRM - SAVING CROSS SECTIONS '/) + 6010 FORMAT(7X, ' SAVING RECORD : ',A12) + END diff --git a/Dragon/src/MACPXS.f b/Dragon/src/MACPXS.f new file mode 100644 index 0000000..827689d --- /dev/null +++ b/Dragon/src/MACPXS.f @@ -0,0 +1,258 @@ +*DECK MACPXS + SUBROUTINE MACPXS(IPLIST,MAXFIS,NGROUP,NBMIX,NIFISS,NANISO,NDELG, + > ITRANC,LNEWXS,XSTOTL,XSTOT1,XSFISS,XSSPEC, + > XSFIXE,XSTRAN,XSDIFF,XSNFTO,XSH,XSSCAT,NEDMAC, + > ISCATA,XSNUDL,XSCHDL,XSDIFX,XSDIFY,XSDIFZ, + > XSOVRV,XSINT0,XSINT1) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transfer cross section information on the macrolib. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPLIST LCM pointer to the macrolib. +* MAXFIS set to max(1,NIFISS). +* NGROUP number of energy groups. +* NBMIX maximum number of mixtures. +* NIFISS number of fissile isotopes. +* NANISO maximum Legendre order (=1 isotropic collision; +* =2 linearly anisotropic collision). +* NDELG number of precursor groups for delayed neutrons. +* ITRANC transport correction option (=0 no correction; =1 Apollo- +* type; =2 recover TRANC record; =4 leakage correction alone). +* LNEWXS check change in cross sections. +* XSTOTL P0 total cross section of mixture. +* XSTOT1 P1 total cross section of mixture. +* XSFISS nu*fission cross section of mixture. +* XSSPEC fission spectrum. +* XSFIXE fixe sources. +* XSTRAN transport correction. +* XSDIFF isotropic diffusion coefficient. +* XSNFTO fission cross section of mixture. +* XSH power factor. +* XSSCAT scattering cross section of mixture/group. +* NEDMAC number of macro edit cross sections. +* XSNUDL delayed nu*fission cross section of mixture. +* XSCHDL delayed-neutron fission spectrum. +* XSDIFX x-directed diffusion coefficients. +* XSDIFY y-directed diffusion coefficients. +* XSDIFZ z-directed diffusion coefficients. +* XSOVRV reciprocal neutron velocities. +* XSINT0 P0 volume-integrated flux of mixture. +* XSINT1 P1 volume-integrated flux of mixture. +* ISCATA check for scattering anisotropy. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIST + INTEGER MAXFIS,NGROUP,NBMIX,NIFISS,NANISO,NDELG,ITRANC,NEDMAC, + > ISCATA(NANISO) + REAL XSTOTL(NBMIX,NGROUP),XSTOT1(NBMIX,NGROUP), + > XSFISS(NBMIX,MAXFIS,NGROUP),XSSPEC(NBMIX,MAXFIS,NGROUP), + > XSFIXE(NBMIX,NGROUP),XSTRAN(NBMIX,NGROUP), + > XSDIFF(NBMIX,NGROUP),XSNFTO(NBMIX,NGROUP), + > XSH(NBMIX,NGROUP),XSSCAT(NGROUP,NBMIX,NANISO,NGROUP), + > XSNUDL(NBMIX,MAXFIS,NDELG,NGROUP), + > XSCHDL(NBMIX,MAXFIS,NDELG,NGROUP), + > XSDIFX(NBMIX,NGROUP),XSDIFY(NBMIX,NGROUP), + > XSDIFZ(NBMIX,NGROUP),XSOVRV(NBMIX,NGROUP), + > XSINT0(NBMIX,NGROUP),XSINT1(NBMIX,NGROUP) + LOGICAL LNEWXS(18) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(MAXNED=50) + TYPE(C_PTR) JPLIST,KPLIST + CHARACTER CANISO*2,CHID*12,NUSIGD*12,HVECT(MAXNED)*8 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: INGSCT,IFGSCT,IPOSCT + REAL, ALLOCATABLE, DIMENSION(:) :: XSWORK +*---- +* SCRATCH STORAGE ALLOCATION +* INGSCT number of scattering group for cross sections. +* IFGSCT first scattering group for cross sections. +* IPOSCT material position in scattering. +*---- + ALLOCATE(INGSCT(NBMIX),IFGSCT(NBMIX),IPOSCT(NBMIX)) + ALLOCATE(XSWORK(NBMIX*(2+NGROUP))) +*---- +* GET NUMBER OF MACRO EDIT X-SECTIONS +*---- + CALL LCMLEN(IPLIST,'ADDXSNAME-P0',ILCMLN,ILCMTY) + NEDMAC=ILCMLN/2 + IF(NEDMAC.GT.MAXNED) CALL XABORT('MACPXS: MAXNED OVERFLOW(1).') + IF(NEDMAC.GT.0) CALL LCMGTC(IPLIST,'ADDXSNAME-P0',8,NEDMAC,HVECT) + IF(LNEWXS(8)) THEN + DO IED=1,NEDMAC + IF(HVECT(IED).EQ.'H-FACTOR') GO TO 5 + ENDDO + NEDMAC=NEDMAC+1 + IF(NEDMAC.GT.MAXNED) CALL XABORT('MACPXS: MAXNED OVERFLOW(2).') + HVECT(NEDMAC)='H-FACTOR' + ENDIF + 5 IF(LNEWXS(15)) THEN + DO IED=1,NEDMAC + IF(HVECT(IED).EQ.'OVERV') GO TO 10 + ENDDO + NEDMAC=NEDMAC+1 + IF(NEDMAC.GT.MAXNED) CALL XABORT('MACPXS: MAXNED OVERFLOW(3).') + HVECT(NEDMAC)='OVERV' + ENDIF + 10 IF(LNEWXS(16)) THEN + DO IED=1,NEDMAC + IF(HVECT(IED).EQ.'NFTOT') GO TO 15 + ENDDO + NEDMAC=NEDMAC+1 + IF(NEDMAC.GT.MAXNED) CALL XABORT('MACPXS: MAXNED OVERFLOW(4).') + HVECT(NEDMAC)='NFTOT' + ENDIF + 15 IF(NEDMAC.GT.0) CALL LCMPTC(IPLIST,'ADDXSNAME-P0',8,NEDMAC,HVECT) +* + JPLIST=LCMLID(IPLIST,'GROUP',NGROUP) + DO 100 IGR=1,NGROUP + KPLIST=LCMDIL(JPLIST,IGR) +*---- +* PUT TOTAL, FIXE AND TRANC ON THE MACROLIB IF MODIFIED +*---- + IF(LNEWXS(1)) CALL LCMPUT(KPLIST,'NTOT0',NBMIX,2,XSTOTL(1,IGR)) + IF(LNEWXS(3)) CALL LCMPUT(KPLIST,'FIXE' ,NBMIX,2,XSFIXE(1,IGR)) + IF(LNEWXS(6)) CALL LCMPUT(KPLIST,'TRANC',NBMIX,2,XSTRAN(1,IGR)) + IF(LNEWXS(7)) CALL LCMPUT(KPLIST,'DIFF',NBMIX,2,XSDIFF(1,IGR)) + IF(LNEWXS(8)) CALL LCMPUT(KPLIST,'H-FACTOR',NBMIX,2,XSH(1,IGR)) + IF(LNEWXS(9)) CALL LCMPUT(KPLIST,'NTOT1',NBMIX,2,XSTOT1(1,IGR)) +*---- +* PUT CHI AND NUSIGF ON THE MACROLIB IF MODIFIED +*---- + IF(LNEWXS(2)) + > CALL LCMPUT(KPLIST,'NUSIGF',NBMIX*NIFISS,2,XSFISS(1,1,IGR)) + IF(LNEWXS(4)) + > CALL LCMPUT(KPLIST,'CHI',NBMIX*NIFISS,2,XSSPEC(1,1,IGR)) +*---- +* PUT DIFFX, DIFFY AND DIFFZ ON THE MACROLIB IF MODIFIED +*---- + IF(LNEWXS(10))CALL LCMPUT(KPLIST,'DIFFX',NBMIX,2,XSDIFX(1,IGR)) + IF(LNEWXS(11))CALL LCMPUT(KPLIST,'DIFFY',NBMIX,2,XSDIFY(1,IGR)) + IF(LNEWXS(12))CALL LCMPUT(KPLIST,'DIFFZ',NBMIX,2,XSDIFZ(1,IGR)) +*---- +* PUT CHID, NUSIGD AND OVERV ON THE MACROLIB IF MODIFIED +*---- + IF(LNEWXS(13)) THEN + DO I=1,NDELG + WRITE(NUSIGD,'(A6,I2.2)') 'NUSIGF',I + CALL LCMPUT(KPLIST,NUSIGD,NBMIX*NIFISS,2,XSNUDL(1,1,I,IGR)) + ENDDO + ENDIF + IF(LNEWXS(14)) THEN + DO I=1,NDELG + WRITE(CHID,'(A3,I2.2)') 'CHI',I + CALL LCMPUT(KPLIST,CHID,NBMIX*NIFISS,2,XSCHDL(1,1,I,IGR)) + ENDDO + ENDIF + IF(LNEWXS(15))CALL LCMPUT(KPLIST,'OVERV',NBMIX,2,XSOVRV(1,IGR)) + IF(LNEWXS(16))CALL LCMPUT(KPLIST,'NFTOT',NBMIX,2,XSNFTO(1,IGR)) + IF(LNEWXS(17))CALL LCMPUT(KPLIST,'FLUX-INTG',NBMIX,2, + > XSINT0(1,IGR)) + IF(LNEWXS(18))CALL LCMPUT(KPLIST,'FLUX-INTG-P1',NBMIX,2, + > XSINT1(1,IGR)) +*---- +* COMPRESS AND PUT ON SCATT ON THE MACROLIB IF MODIFIED +*---- + DO 60 IANIS=1,NANISO + WRITE(CANISO,'(I2.2)') IANIS-1 + IF(LNEWXS(5).AND.ISCATA(IANIS).EQ.2) THEN + NELEM=0 + DO 50 INM=1,NBMIX + J2=IGR + J1=IGR + DO 20 JGR=1,NGROUP + IF(XSSCAT(JGR,INM,IANIS,IGR).NE.0.0) THEN + J2=MAX(J2,JGR) + J1=MIN(J1,JGR) + ENDIF + 20 CONTINUE + INGSCT(INM)=J2-J1+1 + IFGSCT(INM)=J2 + IPOSCT(INM)=NELEM+1 + DO 30 JGR=J2,J1,-1 + NELEM=NELEM+1 + XSWORK(2*NBMIX+NELEM)=XSSCAT(JGR,INM,IANIS,IGR) + 30 CONTINUE +*---- +* STORE DIAGONAL ELEMENTS OF SCATTERING MATRIX +* AND TOTAL SCATTERING OUT OF GROUP +*---- + XSWORK(INM)=XSSCAT(IGR,INM,IANIS,IGR) + XSTOT=0.0 + DO 40 JGR=1,NGROUP + XSTOT=XSTOT+XSSCAT(IGR,INM,IANIS,JGR) + 40 CONTINUE + XSWORK(NBMIX+INM)=XSTOT + 50 CONTINUE + CALL LCMPUT(KPLIST,'NJJS'//CANISO,NBMIX,1,INGSCT) + CALL LCMPUT(KPLIST,'IJJS'//CANISO,NBMIX,1,IFGSCT) + CALL LCMPUT(KPLIST,'IPOS'//CANISO,NBMIX,1,IPOSCT) + CALL LCMPUT(KPLIST,'SIGW'//CANISO,NBMIX,2,XSWORK) + CALL LCMPUT(KPLIST,'SIGS'//CANISO,NBMIX,2,XSWORK(NBMIX+1)) + CALL LCMPUT(KPLIST,'SCAT'//CANISO,NELEM,2, + > XSWORK(2*NBMIX+1)) + ENDIF + 60 CONTINUE +*---- +* COMPUTE/RECOVER TRANSPORT CORRECTION +*---- + IF(ITRANC.EQ.2) THEN +* RECOVER TRANSPORT CORRECTION FROM RECORD 'TRANC'. + CALL LCMLEN(KPLIST,'TRANC',ILCMLN,ITYLCM) + IF(ILCMLN.NE.NBMIX) CALL XABORT('MACPXS: NO TRANC RECORD ' + > //'AVAILABLE') + ELSE IF(ITRANC.NE.0) THEN + XSWORK(:NBMIX)=0.0 + CALL LCMLEN(KPLIST,'NTOT1',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.NBMIX) THEN +* LEAKAGE CORRECTION. + CALL LCMGET(KPLIST,'NTOT0',XSWORK(NBMIX+1)) + CALL LCMGET(KPLIST,'NTOT1',XSWORK(2*NBMIX+1)) + DO 70 INM=1,NBMIX + XSWORK(INM)=XSWORK(NBMIX+INM)-XSWORK(2*NBMIX+INM) + 70 CONTINUE + ENDIF + IF(ITRANC.EQ.1) THEN +* APOLLO-TYPE TRANSPORT CORRECTION. + CALL LCMLEN(KPLIST,'SIGS01',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.NBMIX) THEN + CALL LCMGET(KPLIST,'SIGS01',XSWORK(NBMIX+1)) + DO 80 INM=1,NBMIX + XSWORK(INM)=XSWORK(INM)+XSWORK(NBMIX+INM) + 80 CONTINUE + ENDIF + ELSE IF(ITRANC.NE.4) THEN + CALL XABORT('MACPXS: UNKNOWN TYPE OF CORRECTION.') + ENDIF +* ***CAUTION*** 'TRANC' CONTAINS BOTH TRANSPORT AND LEAKAGE +* CORRECTIONS. + CALL LCMPUT(KPLIST,'TRANC',NBMIX,2,XSWORK) + ENDIF + 100 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XSWORK) + DEALLOCATE(IPOSCT,IFGSCT,INGSCT) + RETURN + END diff --git a/Dragon/src/MACRDM.f b/Dragon/src/MACRDM.f new file mode 100644 index 0000000..c5b7bf0 --- /dev/null +++ b/Dragon/src/MACRDM.f @@ -0,0 +1,267 @@ +*DECK MACRDM + SUBROUTINE MACRDM(IPMACR,IPRINT,IEN ,NTOTMX,NGROUP,NANISO, + > NBMIXF,NIFISF,NEDF ,NDELF ,NREACD,NTREA , + > IMLOC ,NAMREA,NAMEDN,NUMPX ,IXSPRO,XSGEN , + > XSIGS ,XSSCAT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read an old macrolib and transfer information to vectors for a new +* macrolib. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPMACR pointer to structures. +* IPRINT print level. +* IEN macrolib index to process. +* NTOTMX maximum number of mixtures. +* NGROUP number of groups. +* NANISO maximun scattering anisotropy. +* NBMIXF final number of mixtures. +* NIFISF final number fissile isotopes. +* NEDF final number of aditional x-s. +* NDELF final number of precursor groups. +* NREACD number of default x-s. +* NTREA total number of x-s types. +* IMLOC mixture location. +* NAMREA names of default x-s. +* NAMEDN total number of x-s. +* NUMPX correspondence between old and new 'NUSIGF' arrays. +* +*Parameters: output +* IXSPRO flag for x-s processing. +* XSGEN general x-s vector. +* XSIGS scattering x-s vector. +* XSSCAT general scattering matrix. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMACR + INTEGER IPRINT,IEN,NTOTMX,NGROUP,NANISO,NBMIXF,NIFISF,NEDF, + > NDELF,NREACD,NTREA,IMLOC(2,NTOTMX),NAMEDN(2,NEDF), + > NUMPX(NBMIXF,NIFISF),IXSPRO(NTREA+2*NANISO+1) + REAL XSGEN(NBMIXF,NTREA+2),XSIGS(NBMIXF,NANISO), + > XSSCAT(NGROUP,NBMIXF,NANISO) + CHARACTER NAMREA(NREACD)*12 +*---- +* LOCAL VARIABLES +*---- + INTEGER IOUT + PARAMETER (IOUT=6) + INTEGER IDEL,ILCMLN,ILCMTY,IMIX,IREA,IREAF,IREAP,IREAA, + > IFIS,IED,IANIS,IOMIX,NGF,IGD,IGF,IPOS,IGT,ITC + CHARACTER NAMADD*12,CANISO*2,CHID*12,NUSIGD*12 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISCAT + REAL, ALLOCATABLE, DIMENSION(:) :: XSTMP,SCTMP +*---- +* SCRATCH STORAGE ALLOCATION +* XSTMP temporary x-s vector +* SCTMP temporary scattering matrix +* ISCAT scattering pointer +*---- + ALLOCATE(ISCAT(NTOTMX,3)) + ALLOCATE(XSTMP(NTOTMX*(NIFISF+1)),SCTMP(NGROUP*NTOTMX)) +*---- +* PRINT HEADER IF REQUIRED +*---- + IF(IPRINT.GE.10) WRITE(IOUT,6000) +*---- +* 1) DEFAULT XS +*---- + DO 110 IREA=1,NREACD + CALL LCMLEN(IPMACR,NAMREA(IREA),ILCMLN,ILCMTY) + IF((ILCMLN.GT.0).OR.((IREA.EQ.2).AND.(IXSPRO(2).EQ.1))) THEN + IF(IPRINT.GE.6) WRITE(IOUT,6010) NAMREA(IREA) + IXSPRO(IREA)=1 + IF(ILCMLN.GT.0) THEN + CALL LCMGET(IPMACR,NAMREA(IREA),XSTMP) + ELSE IF(NAMREA(IREA)(:4).EQ.'NTOT') THEN + CALL LCMGET(IPMACR,'NTOT0',XSTMP) + ELSE + CALL XABORT('MACRDM: MISSING REACTION '//NAMREA(IREA)//'.') + ENDIF + DO 100 IMIX=1,NTOTMX + IF(IMLOC(1,IMIX).EQ.IEN) THEN + IOMIX=IMLOC(2,IMIX) + XSGEN(IMIX,IREA)=XSTMP(IOMIX) + ENDIF + 100 CONTINUE + ENDIF + 110 CONTINUE +*---- +* 2) NUSIGF AND CHI +*---- + IF(NIFISF.GT.0) THEN + IREAF=NREACD + IREAP=NREACD+NIFISF + CALL LCMLEN(IPMACR,'NUSIGF',ILCMLN,ILCMTY) + IF(ILCMLN.GT.0) THEN + IF(IPRINT.GE.10) THEN + WRITE(IOUT,6010) 'NUSIGF ' + WRITE(IOUT,6010) 'CHI ' + ENDIF + CALL LCMGET(IPMACR,'NUSIGF',XSTMP) + IXSPRO(IREAF+1)=1 + IXSPRO(IREAP+1)=1 + DO 130 IMIX=1,NTOTMX + IF(IMLOC(1,IMIX).EQ.IEN) THEN + DO 120 IFIS=1,NIFISF + IOMIX=NUMPX(IMIX,IFIS) + IF(IOMIX.NE.0) XSGEN(IMIX,IREAF+IFIS)=XSTMP(IOMIX) + 120 CONTINUE + ENDIF + 130 CONTINUE + CALL LCMGET(IPMACR,'CHI',XSTMP) + DO 150 IMIX=1,NTOTMX + IF(IMLOC(1,IMIX).EQ.IEN) THEN + DO 140 IFIS=1,NIFISF + IOMIX=NUMPX(IMIX,IFIS) + IF(IOMIX.NE.0) XSGEN(IMIX,IREAP+IFIS)=XSTMP(IOMIX) + 140 CONTINUE + ENDIF + 150 CONTINUE + ENDIF + DO 200 IDEL=1,NDELF + IREAF=IREAF+2*NIFISF + IREAP=IREAP+2*NIFISF + WRITE(NUSIGD,'(A6,I2.2)') 'NUSIGF',IDEL + WRITE(CHID,'(A3,I2.2)') 'CHI',IDEL + CALL LCMLEN(IPMACR,NUSIGD,ILCMLN,ILCMTY) + IF(ILCMLN.GT.0) THEN + IF(IPRINT.GE.10) THEN + WRITE(IOUT,6010) NUSIGD + WRITE(IOUT,6010) CHID + ENDIF + CALL LCMGET(IPMACR,NUSIGD,XSTMP) + IXSPRO(IREAF+1)=1 + IXSPRO(IREAP+1)=1 + DO 170 IMIX=1,NTOTMX + IF(IMLOC(1,IMIX).EQ.IEN) THEN + DO 160 IFIS=1,NIFISF + IOMIX=NUMPX(IMIX,IFIS) + IF(IOMIX.NE.0) XSGEN(IMIX,IREAF+IFIS)=XSTMP(IOMIX) + 160 CONTINUE + ENDIF + 170 CONTINUE + CALL LCMGET(IPMACR,CHID,XSTMP) + DO 190 IMIX=1,NTOTMX + IF(IMLOC(1,IMIX).EQ.IEN) THEN + DO 180 IFIS=1,NIFISF + IOMIX=NUMPX(IMIX,IFIS) + IF(IOMIX.NE.0) XSGEN(IMIX,IREAP+IFIS)=XSTMP(IOMIX) + 180 CONTINUE + ENDIF + 190 CONTINUE + ENDIF + 200 CONTINUE + ENDIF +*---- +* 3) ADDITIONAL EDIT XS +*---- + IF(NEDF.GT.0) THEN + IREAA=NREACD+2*NIFISF*(NDELF+1) + DO 220 IED=1,NEDF + WRITE(NAMADD,'(A4,A2)') (NAMEDN(ITC,IED),ITC=1,2) + CALL LCMLEN(IPMACR,NAMADD,ILCMLN,ILCMTY) + IF(ILCMLN.GT.0) THEN + IF(IPRINT.GE.10) WRITE(IOUT,6010) NAMADD + IXSPRO(IREAA+IED)=1 + CALL LCMGET(IPMACR,NAMADD,XSTMP) + DO 210 IMIX=1,NTOTMX + IF(IMLOC(1,IMIX).EQ.IEN) THEN + IOMIX=IMLOC(2,IMIX) + XSGEN(IMIX,IREAA+IED)=XSTMP(IOMIX) + ENDIF + 210 CONTINUE + ENDIF + 220 CONTINUE + ENDIF +*---- +* 5) SCATTERING XS +*---- + DO 250 IANIS=1,NANISO + WRITE(CANISO,'(I2.2)') IANIS-1 + CALL LCMLEN(IPMACR,'SCAT'//CANISO,ILCMLN,ILCMTY) + IF(ILCMLN.GT.0) THEN + IXSPRO(NTREA+IANIS)=1 + IF(IPRINT.GE.10) WRITE(IOUT,6010) 'SCATTERING'//CANISO +*---- +* 4.3) TREAT SCAT +*---- + CALL LCMGET(IPMACR,'IJJS'//CANISO,ISCAT(1,1)) + CALL LCMGET(IPMACR,'NJJS'//CANISO,ISCAT(1,2)) + CALL LCMGET(IPMACR,'IPOS'//CANISO,ISCAT(1,3)) + CALL LCMGET(IPMACR,'SCAT'//CANISO,SCTMP) + DO 240 IMIX=1,NTOTMX + IF(IMLOC(1,IMIX).EQ.IEN) THEN + IOMIX=IMLOC(2,IMIX) + NGF=ISCAT(IOMIX,2) + IF(NGF.GT.0) THEN + IGD=ISCAT(IOMIX,1) + IGF=IGD-NGF+1 + IPOS=ISCAT(IOMIX,3) + DO 230 IGT=IGD,IGF,-1 + XSSCAT(IGT,IMIX,IANIS)=SCTMP(IPOS) + IPOS=IPOS+1 + 230 CONTINUE + ENDIF + ENDIF + 240 CONTINUE + ENDIF + CALL LCMLEN(IPMACR,'SIGS'//CANISO,ILCMLN,ILCMTY) + IF(ILCMLN.GT.0) THEN + IXSPRO(NTREA+NANISO+IANIS)=1 + CALL LCMGET(IPMACR,'SIGS'//CANISO,XSTMP) + DO 245 IMIX=1,NTOTMX + IF(IMLOC(1,IMIX).EQ.IEN) THEN + IOMIX=IMLOC(2,IMIX) + XSIGS(IMIX,IANIS)=XSTMP(IOMIX) + ENDIF + 245 CONTINUE + ENDIF + 250 CONTINUE + DEALLOCATE(SCTMP,XSTMP) + DEALLOCATE(ISCAT) +*---- +* 6) STOPPING POWER +*---- + CALL LCMLEN(IPMACR,'ESTOPW',ILCMLN,ILCMTY) + IF(ILCMLN.GT.0) THEN + IF(IPRINT.GE.10) WRITE(IOUT,6010) 'ESTOPW' + ALLOCATE(XSTMP(ILCMLN)) + IXSPRO(NTREA+2*NANISO+1)=1 + CALL LCMGET(IPMACR,'ESTOPW',XSTMP) + DO 260 IMIX=1,NTOTMX + IF(IMLOC(1,IMIX).EQ.IEN) THEN + IOMIX=IMLOC(2,IMIX) + IF(IOMIX.GT.ILCMLN/2) CALL XABORT('MACRDM: XSTMP OVERFLOW.') + XSGEN(IMIX,NTREA+1)=XSTMP(IOMIX) + XSGEN(IMIX,NTREA+2)=XSTMP(ILCMLN/2+IOMIX) + ENDIF + 260 CONTINUE + DEALLOCATE(XSTMP) + ENDIF + RETURN +*---- +* EDIT FORMATS +*---- + 6000 FORMAT(1X,'MACRDM - READING CROSS SECTIONS '/) + 6010 FORMAT(7X, ' READING RECORD : ',A12) + END diff --git a/Dragon/src/MACUPD.f b/Dragon/src/MACUPD.f new file mode 100644 index 0000000..8efd97c --- /dev/null +++ b/Dragon/src/MACUPD.f @@ -0,0 +1,295 @@ +*DECK MACUPD + SUBROUTINE MACUPD(NENTRY,KENTRY,IPRINT,NTOTMX,NBMIX ,NGROUP, + > NANISO,NIFISS,NEDMAC,ITRANC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Update Dragon macrolib with other Dragon macrolib. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* NENTRY number of structures. +* KENTRY pointer to structures. +* IPRINT print level. +* NTOTMX maximum number of mixtures in input macrolibs. +* NBMIX number of mixtures on output macrolib. +* NGROUP number of groups. +* NANISO maximun scattering anisotropy. +* NIFISS number fissile isotopes per mixture. +* NEDMAC number of aditional edition x-s. +* ITRANC type of transport correction. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) KENTRY(NENTRY) + INTEGER NENTRY,IPRINT,NTOTMX,NBMIX,NGROUP,NANISO,NIFISS, + > NEDMAC,ITRANC +*---- +* LOCAL VARIABLES +*---- + INTEGER IOUT,NSTATE,MAXPAR + PARAMETER (IOUT=6,NSTATE=40,MAXPAR=10) +*---- +* INPUT +*---- + CHARACTER CARLIR*12 + INTEGER ITYPLU,INTLIR + REAL REALIR + DOUBLE PRECISION DBLLIR +*---- +* LOCAL PARAMETERS +*---- + TYPE(C_PTR) IPMACR + INTEGER ISTATE(NSTATE),ITEXT4,IMIX,IEN,NUMNEW,NUMOLD,NBMIXF, + > NIFISF,NGROF,NEDF,NDELF,NBMIXO,NIFISO,NEDO,NDELO, + > ILCMLN,ILCMTY,ITC,NPART,I + CHARACTER TEXT4*4,HGROUP*12,HPART0*1,HPART(MAXPAR)*1 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NAMEN,NUMFN,NUMPX + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IMLOC + REAL, ALLOCATABLE, DIMENSION(:) :: ENERN +*---- +* SCRATCH STORAGE ALLOCATION +* IMLOC mixture location +*---- + ALLOCATE(IMLOC(2,NTOTMX)) +*---- +* INITIALIZE IMLOC FOR MIXTURE ALREADY PRESENT ON OUTPUT MACROLIB +*---- + TEXT4=' ' + READ(TEXT4,'(A4)') ITEXT4 + IMLOC(:2,:NTOTMX)=0 + DO 100 IMIX=1,NBMIX + IMLOC(1,IMIX)=1 + IMLOC(2,IMIX)=IMIX + 100 CONTINUE + IF(IPRINT.GE.5) WRITE(IOUT,6000) +*---- +* READ INPUT DATA +* TYPICAL FORMAT: +* EDIT iprint +* CTRA { ON | OFF } +* MIX numnew numold [{ UPDL | OLDL }] +* WHERE +* iprint = PRINT LEVEL +* numnew = NEW MIXTURE NUMBER +* numold = OLD MIXTURE NUMBER +* UPDL = TAKE numold FORM LIBRARY TO UPDATE +* OLDL = TAKE numold FORM OLD LIBRARY +*---- + ITYPLU = 3 + CARLIR = 'MIX' + 1000 CONTINUE + IF(ITYPLU.NE.3) CALL XABORT('MACUPD: CHARACTER KEYWORD EXPECTED.') +*---- +* CHECK FOR STOP/RETURN +*---- + IF(CARLIR .EQ. ';') THEN + GO TO 1005 + ELSE IF(CARLIR(1:3).EQ.'MIX') THEN +*---- +* READ MIX CARD +*---- + CALL REDGET(ITYPLU,NUMNEW,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('MACUPD: NEW MIXTURE NUMBER IS NOT' + > //' AN INTEGER.') + CALL REDGET(ITYPLU,NUMOLD,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('MACUPD: OLD MIXTURE NUMBER IS NOT' + > //' AN INTEGER.') + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('MACUPD: STRUCTURE TYPE IS NOT CHA' + > //'RACTER.') +*--- +* TEST IF NUMNEW IS VALID +*---- + IF(NUMNEW.GT.NTOTMX) CALL XABORT('MACUPD: NEW MATERIAL NUMBER ' + > //'IS TOO LARGE.') +*---- +* BY DEFAULT CARLIR IS ASSUMED TO BE OLDL +* IF CARLIR IS UPDL STORE INFORMATION IN IMLOC +* KEYWORD OLDL NOT PROCESSED IF PRESENT +* PROCESS KEYWORD OLDL ACCORDING TO USER'S GUIDE IN THE +* CASE WHERE IT IS PRESENT +*---- + IF(CARLIR(1:4).EQ.'UPDL') THEN + IMLOC(1,NUMNEW)=1 + IMLOC(2,NUMNEW)=NUMOLD + ELSE IF(CARLIR(1:4).EQ.'OLDL') THEN + IMLOC(1,NUMNEW)=2 + IMLOC(2,NUMNEW)=NUMOLD + ELSE + IMLOC(1,NUMNEW)=2 + IMLOC(2,NUMNEW)=NUMOLD + GO TO 1000 + ENDIF + ELSE + CALL XABORT('MACUPD: KEYWORD '//CARLIR//' NOT PERMITTED.') + ENDIF + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + GO TO 1000 + 1005 CONTINUE +*---- +* RECOVER CRITICITY PARAMETERS +*---- + CALL LCMLEN(KENTRY(2),'K-EFFECTIVE',ILCMLN,ILCMTY) + IF(ILCMLN.EQ.1) THEN + CALL LCMGET(KENTRY(2),'K-EFFECTIVE',REALIR) + CALL LCMPUT(KENTRY(1),'K-EFFECTIVE',1,2,REALIR) + ENDIF + CALL LCMLEN(KENTRY(2),'K-INFINITY',ILCMLN,ILCMTY) + IF(ILCMLN.EQ.1) THEN + CALL LCMGET(KENTRY(2),'K-INFINITY',REALIR) + CALL LCMPUT(KENTRY(1),'K-INFINITY',1,2,REALIR) + ENDIF + CALL LCMLEN(KENTRY(2),'B2 B1HOM',ILCMLN,ILCMTY) + IF(ILCMLN.EQ.1) THEN + CALL LCMGET(KENTRY(2),'B2 B1HOM',REALIR) + CALL LCMPUT(KENTRY(1),'B2 B1HOM',1,2,REALIR) + ENDIF +*---- +* FIND TOTAL NUMBER OF MIXTURES CREATED +*---- + DO 120 IMIX=NTOTMX,1,-1 + IF(IMLOC(2,IMIX).NE.0) THEN + NBMIXF=IMIX + GO TO 125 + ENDIF + 120 CONTINUE + CALL XABORT('MACUPD: NO MIXTURES FOUND.') + 125 CONTINUE +*---- +* TEST FOR ENERGY +* FIND ADDITIONAL XS NAME +* FIND TOTAL NUMBER OF FISSILE ISOTOPES AND THEIR NAME +*---- + ALLOCATE(NAMEN(2*NEDMAC),NUMFN(NBMIXF*NIFISS), + > NUMPX(NBMIXF*NIFISS),ENERN(2*NGROUP+1)) + NAMEN(:2*NEDMAC)=ITEXT4 +*---- +* INITIALIZE VECTOR +*---- + NUMFN(:NBMIXF*NIFISS)=0 + NUMPX(:NBMIXF*NIFISS)=0 + NIFISF=0 + NGROF =0 + NEDF =0 + NDELF =0 + DO 130 IEN=1,NENTRY + IPMACR=KENTRY(IEN) + DO 131 IMIX=1,NTOTMX + IF(IMLOC(1,IMIX).EQ.IEN) THEN + ISTATE(:NSTATE)=0 + CALL LCMGET(IPMACR,'STATE-VECTOR',ISTATE) + NBMIXO=ISTATE(2) + NIFISO=ISTATE(4) + NEDO=ISTATE(5) + NDELO=ISTATE(7) + CALL MACNFI(IPMACR,IPRINT,IEN ,NTOTMX,NGROUP,NIFISS, + > NEDMAC,NBMIXF,NGROF ,NIFISF,NEDF ,NDELF , + > NBMIXO,NIFISO,NEDO ,NDELO ,IMLOC ,ENERN , + > NAMEN ,NUMFN ,NUMPX ) + GO TO 135 + ENDIF + 131 CONTINUE + 135 CONTINUE + 130 CONTINUE +*---- +* SAVE ENERGY, ADDITIONAL XS NAME AND FISSILE ISOTOPES INFORMATION +* ON FINAL MACROLIB +*---- + IPMACR=KENTRY(1) + IF(NGROF.GT.0) THEN + CALL LCMPUT(IPMACR,'ENERGY',NGROF+1,2,ENERN) + CALL LCMPUT(IPMACR,'DELTAU',NGROF,2,ENERN(NGROF+2)) + IF(IPRINT.GE.5) THEN + WRITE(IOUT,6010) 'ENERGY ' + WRITE(IOUT,6013) (ENERN(ITC),ITC=1,NGROF+1) + WRITE(IOUT,6010) 'DELTAU ' + WRITE(IOUT,6013) (ENERN(ITC),ITC=NGROF+2,2*NGROF+1) + ENDIF + ENDIF + IF(NEDF.GT.0) THEN + CALL LCMPUT(IPMACR,'ADDXSNAME-P0',2*NEDF,3,NAMEN) + IF(IPRINT.GE.5) THEN + WRITE(IOUT,6010) 'ADDXSNAME-P0' + WRITE(IOUT,6011) (NAMEN(ITC),ITC=1,2*NEDO) + ENDIF + ENDIF + IF(NIFISF.GT.0) THEN + IF(IPRINT.GE.5) THEN + WRITE(IOUT,6010) 'FISSIONINDEX' + WRITE(IOUT,6012) (NUMFN(ITC),ITC=1,NBMIXF*NIFISF) + ENDIF + ENDIF + DEALLOCATE(ENERN) +*---- +* CROSS SECTION PROCESSING IN GROUP LIST DIRECTORY WITH UPDATE. +*---- + HGROUP='GROUP' + CALL MACUPG(KENTRY,HGROUP,NENTRY,NIFISF,NDELF,NEDF,NGROUP,NBMIXF, + > NIFISS,NANISO,NEDMAC,NTOTMX,ITRANC,IPRINT,NAMEN,NUMPX,IMLOC) +*---- +* RESET NUMFFN TO ONE FOR TERMS WHICH ARE NOT 0 AND SAVE +*---- + IF(NIFISF.GT.0) THEN + CALL LCMPUT(IPMACR,'FISSIONINDEX',NBMIXF*NIFISF,1,NUMFN) + ENDIF +*---- +* CCROSS SECTION PROCESSING IN COMPANION GROUP LIST DIRECTORY WITH +* UPDATE. +*---- + NPART=0 + DO 140 IEN=1,NENTRY + IPMACR=KENTRY(IEN) + CALL LCMLEN(IPMACR,'STATE-VECTOR',ILCMLN,ILCMTY) + IF(ILCMLN.EQ.0) GO TO 140 + CALL LCMGET(IPMACR,'STATE-VECTOR',ISTATE) + IF(ISTATE(17).GT.0) THEN + NPART=ISTATE(17)+1 + IF(NPART.GT.MAXPAR) CALL XABORT('MAXUPD: MAXPAR OVERFLOW.') + CALL LCMGTC(IPMACR,'PARTICLE',1,HPART0) + CALL LCMGTC(IPMACR,'PARTICLE-NAM',1,NPART,HPART) + GO TO 150 + ENDIF + 140 CONTINUE + 150 DO I=1,NPART + IF(HPART(I).EQ.HPART0) CYCLE + HGROUP='GROUP-'//HPART(I) + CALL MACUPG(KENTRY,HGROUP,NENTRY,NIFISF,NDELF,NEDF,NGROUP, + > NBMIXF,NIFISS,NANISO,NEDMAC,NTOTMX,ITRANC,IPRINT,NAMEN,NUMPX, + > IMLOC) + ENDDO + DEALLOCATE(NUMPX,NUMFN,NAMEN) + NBMIX=NBMIXF + NIFISS=NIFISF + NEDMAC=NEDF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IMLOC) + RETURN +*---- +* EDIT FORMATS +*---- + 6000 FORMAT(1X,'MACUPD - UPDATING MACROLIB ') + 6010 FORMAT(7X, ' PRECESSING RECORD : ',A12) + 6011 FORMAT(10(2A4,4X)) + 6012 FORMAT(10(I8,4X)) + 6013 FORMAT(1P,8E15.7) + END diff --git a/Dragon/src/MACUPG.f b/Dragon/src/MACUPG.f new file mode 100644 index 0000000..b8c2d66 --- /dev/null +++ b/Dragon/src/MACUPG.f @@ -0,0 +1,125 @@ +*DECK MACUPG + SUBROUTINE MACUPG(KENTRY,HGROUP,NENTRY,NIFISF,NDELF,NEDF,NGROUP, + > NBMIXF,NIFISS,NANISO,NEDMAC,NTOTMX,ITRANC,IPRINT,NAMEN,NUMPX, + > IMLOC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Cross section processing in GROUP list directory with update. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* KENTRY array of macrolib structures. +* HGROUP character*12 name of GROUP list directory. +* NENTRY number of structures. +* NIFISF maximum number fissile isotopes per mixture. +* NDELF final number of precursor groups. +* NEDF final number of aditional x-s. +* NGROUP number of groups. +* NBMIXF final number of mixtures. +* NIFISS number fissile isotopes per mixture. +* NANISO maximun scattering anisotropy. +* NEDMAC number of aditional edition x-s. +* NTOTMX maximum number of mixtures in input macrolibs. +* ITRANC type of transport correction. +* IPRINT print level. +* NAMEN total number of x-s. +* NUMPX correspondence between old and new 'NUSIGF' arrays. +* IMLOC mixture location. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER HGROUP*12 + INTEGER NENTRY,NIFISF,NDELF,NEDF,NGROUP,NBMIXF,NIFISS,NANISO, + > NEDMAC,NTOTMX,ITRANC,IPRINT,NAMEN(2*NEDMAC),NUMPX(NBMIXF*NIFISS), + > IMLOC(2,NTOTMX) + TYPE(C_PTR) KENTRY(NENTRY) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPMACR,JPMACR,KPMACR + INTEGER IOUT,NREACD,NTREA,IGR,IEN,IMIX,IPRG + PARAMETER (IOUT=6,NREACD=14) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IXSPRO + REAL, ALLOCATABLE, DIMENSION(:) :: XSGEN,XSIGS,SCAT +*---- +* DATA +*---- + CHARACTER NAMREA(NREACD)*12 + SAVE NAMREA + DATA NAMREA + > /'NTOT0 ','NTOT1 ','TRANC ','FIXE ', + > 'DIFF ','DIFFX ','DIFFY ','DIFFZ ', + > 'NSPH ','H-FACTOR ','C-FACTOR ','OVERV ', + > 'FLUX-INTG ','FLUX-INTG-P1'/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + NTREA=NREACD+2*NIFISF*(1+NDELF)+NEDF + ALLOCATE(XSGEN(NBMIXF*(NTREA+2)),XSIGS(NBMIXF*NANISO), + > IXSPRO(NTREA+2*NANISO+1),SCAT(NGROUP*NBMIXF*NANISO)) + IXSPRO(:NTREA+2*NANISO+1)=0 + IPRG=IPRINT + DO 140 IGR=1,NGROUP + XSGEN(:NBMIXF*(NTREA+2))=0.0 + XSIGS(:NBMIXF*NANISO)=0.0 + SCAT(:NGROUP*NBMIXF*NANISO)=0.0 + DO 150 IEN=1,NENTRY + IPMACR=KENTRY(IEN) + IF(IEN.EQ.1) THEN +* IPMACR IS OPEN IN CREATION/MODIFICATION MODE + JPMACR=LCMLID(IPMACR,HGROUP,NGROUP) + KPMACR=LCMDIL(JPMACR,IGR) + ELSE +* IPMACR IS OPEN IN READ-ONLY MODE + JPMACR=LCMGID(IPMACR,HGROUP) + KPMACR=LCMGIL(JPMACR,IGR) + ENDIF + IF(IPRG.GE.10) WRITE(IOUT,6020) IEN + DO 151 IMIX=1,NTOTMX + IF(IMLOC(1,IMIX).EQ.IEN) THEN + CALL MACRDM(KPMACR,IPRG ,IEN ,NTOTMX,NGROUP,NANISO, + > NBMIXF,NIFISF,NEDF ,NDELF ,NREACD,NTREA , + > IMLOC ,NAMREA,NAMEN ,NUMPX ,IXSPRO,XSGEN , + > XSIGS ,SCAT ) + GO TO 155 + ENDIF + 151 CONTINUE + 155 CONTINUE + 150 CONTINUE + IPMACR=KENTRY(1) + JPMACR=LCMLID(IPMACR,HGROUP,NGROUP) + KPMACR=LCMDIL(JPMACR,IGR) +*---- +* FOR TRANC OFF DO NOT SAVE TRANSPORT CORRECTION +*---- + IF(ITRANC.EQ.0) IXSPRO(2)=0 + CALL MACPRM(KPMACR,IPRG ,NGROUP,NANISO,NBMIXF,NIFISF, + > NEDF ,NDELF ,NREACD,NTREA ,IGR ,NAMREA, + > NAMEN ,IXSPRO,XSGEN ,XSIGS ,SCAT ) + IPRG=0 + 140 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SCAT,IXSPRO,XSIGS,XSGEN) + RETURN + 6020 FORMAT(' MACUPG: PROCESSING MACROLIB',I12) + END diff --git a/Dragon/src/MACWXS.f b/Dragon/src/MACWXS.f new file mode 100644 index 0000000..7b32431 --- /dev/null +++ b/Dragon/src/MACWXS.f @@ -0,0 +1,388 @@ +*DECK MACWXS + SUBROUTINE MACWXS(IPLIST,IPRINT,NGROUP,NBMIX,NIFISS,NANISO,ICTRA, + > NEDMAC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Print/check cross section information if required. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPLIST LCM pointer to the macrolib. +* IPRINT print level. +* NGROUP number of energy groups. +* NBMIX number of mixtures. +* NIFISS number of fissile isotopes. +* NANISO maximum Legendre order: +* =1 isotropic collision; +* =2 linearly anisotropic collision. +* ICTRA type of transport correction. +* NEDMAC number of macro edit cross sections. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIST + INTEGER IPRINT,NGROUP,NBMIX,NIFISS,NANISO,ICTRA,NEDMAC +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPLIST,KPLIST + CHARACTER CANISO*2,NAMREC*12,CEDNAM*12,NAMRE1*12,NAMRE2*12 + PARAMETER (IUNOUT=6,ILCMUP=1,ILCMDN=2,IOUT=6) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: INGSCT,IFGSCT,IPOSCT + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: CADNAM + REAL, ALLOCATABLE, DIMENSION(:) :: XSWORK,XSWOR2,TCOR + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCWORK +*---- +* SCRATCH STORAGE ALLOCATION +* INGSCT number of scattering group for cross sections. +* IFGSCT first scattering group for cross sections. +* IPOSCT mixture location in cross section matrix. +* TCOR transport correction. +* CADNAM additional cross section names. +*---- + ALLOCATE(INGSCT(NBMIX),IFGSCT(NBMIX),IPOSCT(NBMIX), + > CADNAM(2,NEDMAC+1)) + ALLOCATE(XSWORK(NBMIX*(2+NGROUP)),XSWOR2(NBMIX*NIFISS), + > SCWORK(NBMIX,NANISO,NGROUP),TCOR(NBMIX)) +* + IF(IPRINT.GT.1) WRITE(IUNOUT,6000) + SCWORK(:NBMIX,:NANISO,:NGROUP)=0.0 + IF(NEDMAC.GT.0) CALL LCMGET(IPLIST,'ADDXSNAME-P0',CADNAM) + JPLIST=LCMGID(IPLIST,'GROUP') + DO 100 IGR=1,NGROUP + KPLIST=LCMGIL(JPLIST,IGR) + IF(ICTRA.EQ.0) THEN + TCOR(:NBMIX)=0.0 + ELSE + CALL LCMGET(KPLIST,'TRANC',TCOR) + ENDIF +*---- +* PRINT TOTAL X-S AND FIXE SOURCES INFORMATION +*---- + IF(IPRINT.GT.1) THEN + IF(NBMIX.LE.7) THEN + WRITE(IUNOUT,6001) IGR,(II,II=1,NBMIX) + ELSE + WRITE(IUNOUT,6001) IGR,(II,II=1,7) + WRITE(IUNOUT,6011) (II,II=8,NBMIX) + ENDIF + CALL LCMGET(KPLIST,'NTOT0',XSWORK) + IF(NBMIX.LE.7) THEN + WRITE(IUNOUT,6002) 'NTOT0 ', + > (XSWORK(II)-TCOR(II),II=1,NBMIX) + ELSE + WRITE(IUNOUT,6002) 'NTOT0 ', + > (XSWORK(II)-TCOR(II),II=1,7) + WRITE(IUNOUT,6010) (XSWORK(II)-TCOR(II),II=8,NBMIX) + ENDIF + CALL LCMLEN(KPLIST,'NTOT1',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPLIST,'NTOT1',XSWORK) + IF(NBMIX.LE.7) THEN + WRITE(IUNOUT,6002) 'NTOT1 ',(XSWORK(II),II=1,NBMIX) + ELSE + WRITE(IUNOUT,6002) 'NTOT1 ',(XSWORK(II),II=1,7) + WRITE(IUNOUT,6010) (XSWORK(II),II=8,NBMIX) + ENDIF + ENDIF + CALL LCMLEN(KPLIST,'FIXE',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPLIST,'FIXE',XSWORK) + IF(NBMIX.LE.7) THEN + WRITE(IUNOUT,6002) 'FIXE ',(XSWORK(II),II=1,NBMIX) + ELSE + WRITE(IUNOUT,6002) 'FIXE ',(XSWORK(II),II=1,7) + WRITE(IUNOUT,6010) (XSWORK(II),II=8,NBMIX) + ENDIF + ENDIF + CALL LCMLEN(KPLIST,'TRANC',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPLIST,'TRANC',XSWORK) + IF(NBMIX.LE.7) THEN + WRITE(IUNOUT,6002) 'TRANC ',(XSWORK(II),II=1,NBMIX) + ELSE + WRITE(IUNOUT,6002) 'TRANC ',(XSWORK(II),II=1,7) + WRITE(IUNOUT,6010) (XSWORK(II),II=8,NBMIX) + ENDIF + ENDIF + CALL LCMLEN(KPLIST,'DIFF',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPLIST,'DIFF',XSWORK) + IF(NBMIX.LE.7) THEN + WRITE(IUNOUT,6002) 'DIFF ',(XSWORK(II),II=1,NBMIX) + ELSE + WRITE(IUNOUT,6002) 'DIFF ',(XSWORK(II),II=1,7) + WRITE(IUNOUT,6010) (XSWORK(II),II=8,NBMIX) + ENDIF + ENDIF + CALL LCMLEN(KPLIST,'H-FACTOR',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPLIST,'H-FACTOR',XSWORK) + IF(NBMIX.LE.7) THEN + WRITE(IUNOUT,6002) 'H-FACTOR ',(XSWORK(II),II=1,NBMIX) + ELSE + WRITE(IUNOUT,6002) 'H-FACTOR ',(XSWORK(II),II=1,7) + WRITE(IUNOUT,6010) (XSWORK(II),II=8,NBMIX) + ENDIF + ENDIF + CALL LCMLEN(KPLIST,'FLUX-INTG',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPLIST,'FLUX-INTG',XSWORK) + IF(NBMIX.LE.7) THEN + WRITE(IUNOUT,6002) 'FLUX-INTG ',(XSWORK(II),II=1,NBMIX) + ELSE + WRITE(IUNOUT,6002) 'FLUX-INTG ',(XSWORK(II),II=1,7) + WRITE(IUNOUT,6010) (XSWORK(II),II=8,NBMIX) + ENDIF + ENDIF + CALL LCMLEN(KPLIST,'FLUX-INTG-P1',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPLIST,'FLUX-INTG-P1',XSWORK) + IF(NBMIX.LE.7) THEN + WRITE(IUNOUT,6002) 'FLUX-INTG-P1',(XSWORK(II),II=1,NBMIX) + ELSE + WRITE(IUNOUT,6002) 'FLUX-INTG-P1',(XSWORK(II),II=1,7) + WRITE(IUNOUT,6010) (XSWORK(II),II=8,NBMIX) + ENDIF + ENDIF + ENDIF +*---- +* PRINT FISSION INFORMATION +*---- + IF(IPRINT.GT.1) THEN + CALL LCMLEN(KPLIST,'NUSIGF',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPLIST,'NUSIGF',XSWOR2) + DO 110 IFISS=1,NIFISS + IOF=(IFISS-1)*NBMIX + WRITE(IUNOUT,6003) IFISS + IF(NBMIX.LE.7) THEN + WRITE(IUNOUT,6002) 'NUSIGF',(XSWOR2(IOF+II),II=1,NBMIX) + ELSE + WRITE(IUNOUT,6002) 'NUSIGF',(XSWOR2(IOF+II),II=1,7) + WRITE(IUNOUT,6010) (XSWOR2(IOF+II),II=8,NBMIX) + ENDIF + 110 CONTINUE + ENDIF +* + CALL LCMLEN(KPLIST,'CHI',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPLIST,'CHI',XSWOR2) + DO 115 IFISS=1,NIFISS + IOF=(IFISS-1)*NBMIX + WRITE(IUNOUT,6003) IFISS + IF(NBMIX.LE.7) THEN + WRITE(IUNOUT,6002) 'CHI',(XSWOR2(IOF+II),II=1,NBMIX) + ELSE + WRITE(IUNOUT,6002) 'CHI',(XSWOR2(IOF+II),II=1,7) + WRITE(IUNOUT,6010) (XSWOR2(IOF+II),II=8,NBMIX) + ENDIF + 115 CONTINUE + ENDIF +* + CALL LCMLEN(KPLIST,'NFTOT',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPLIST,'NFTOT',XSWORK) + IF(NBMIX.LE.7) THEN + WRITE(IUNOUT,6002) 'NFTOT ',(XSWORK(II),II=1,NBMIX) + ELSE + WRITE(IUNOUT,6002) 'NFTOT ',(XSWORK(II),II=1,7) + WRITE(IUNOUT,6010) (XSWORK(II),II=8,NBMIX) + ENDIF + ENDIF + ENDIF +*---- +* PRINT SCATTERING MATRICES INFORMATION +*---- + MAXMXR=0 + IF(ICTRA.NE.0) THEN + NNANIS=1 + ELSE + NNANIS=NANISO + ENDIF + DO 120 IANIS=1,NNANIS + WRITE(CANISO,'(I2.2)') IANIS-1 + CALL LCMLEN(KPLIST,'NJJS'//CANISO,ILCMLN,ITYLCM) + IF(ILCMLN.EQ.0) GO TO 120 + IF(ILCMLN.LT.NBMIX) THEN + MAXMXR=ILCMLN + ELSE IF(ILCMLN.GT.NBMIX) THEN + CALL XABORT('MACWXS: NUMBER OF MIXTURES ON LCM IS LARGER'// + > ' THAN THE MAXIMUM PROVIDED ON NMIX CARD') + ELSE + MAXMXR=NBMIX + ENDIF + NAMREC='SIGW'//CANISO + NAMRE1='SIGS'//CANISO + NAMRE2='SCAT'//CANISO + CALL LCMGET(KPLIST,'NJJS'//CANISO,INGSCT) + CALL LCMGET(KPLIST,'IJJS'//CANISO,IFGSCT) + CALL LCMGET(KPLIST,'IPOS'//CANISO,IPOSCT) + CALL LCMGET(KPLIST,NAMREC,XSWORK) + CALL LCMLEN(KPLIST,NAMRE1,ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) CALL LCMGET(KPLIST,NAMRE1,XSWORK(NBMIX+1)) + CALL LCMGET(KPLIST,NAMRE2,XSWORK(2*NBMIX+1)) + IF(IPRINT.GT.1) THEN + IF(NBMIX.LE.7) THEN + WRITE(IUNOUT,6002) NAMREC, + > (XSWORK(II)-TCOR(II),II=1,MAXMXR) + IF(ILCMLN.GT.0) THEN + WRITE(IUNOUT,6002) NAMRE1, + > (XSWORK(NBMIX+II)-TCOR(II),II=1,MAXMXR) + ENDIF + ELSE + WRITE(IUNOUT,6002) NAMREC, + > (XSWORK(II)-TCOR(II),II=1,7) + WRITE(IUNOUT,6010) (XSWORK(II)-TCOR(II),II=8,MAXMXR) + IF(ILCMLN.GT.0) THEN + WRITE(IUNOUT,6002) NAMRE1, + > (XSWORK(NBMIX+II)-TCOR(II),II=1,7) + WRITE(IUNOUT,6010) (XSWORK(NBMIX+II)-TCOR(II),II=8, + > MAXMXR) + ENDIF + ENDIF + ENDIF + IF(IPRINT.GT.2) THEN + IF=2*NBMIX+1 + IS=2*NBMIX+INGSCT(1) + IDG=IFGSCT(1) + IFG=IDG-INGSCT(1)+1 + IDIAG=IS+IFG-IGR + XSWORK(IDIAG)=XSWORK(IDIAG)-TCOR(1) + IF(INGSCT(1).GT.0) THEN + IF(IS-IF+1.LE.4) THEN + WRITE(IUNOUT,6004) NAMRE2,1,IFG,IDG, + > (XSWORK(J),J=IS,IF,-1) + ELSE + WRITE(IUNOUT,6004) NAMRE2,1,IFG,IDG, + > (XSWORK(J),J=IS,IS-3,-1) + WRITE(IUNOUT,6010)(XSWORK(J),J=IS-4,IF,-1) + ENDIF + ENDIF + DO 130 IMAT=2,MAXMXR + IF=IS+1 + IS=IS+INGSCT(IMAT) + IDG=IFGSCT(IMAT) + IFG=IDG-INGSCT(IMAT)+1 + IDIAG=IS+IFG-IGR + XSWORK(IDIAG)=XSWORK(IDIAG)-TCOR(IMAT) + IF(INGSCT(IMAT).GT.0) THEN + IF(IS-IF+1.LE.4) THEN + WRITE(IUNOUT,6005) IMAT,IFG,IDG, + > (XSWORK(J),J=IS,IF,-1) + ELSE + WRITE(IUNOUT,6005) IMAT,IFG,IDG, + > (XSWORK(J),J=IS,IS-3,-1) + WRITE(IUNOUT,6010)(XSWORK(J),J=IS-4,IF,-1) + ENDIF + ENDIF + 130 CONTINUE + ENDIF + IF((IPRINT.GT.4).OR.(IPRINT.LT.0)) THEN +*---- +* VALIDATION OF SCATTERING INFORMATION +*---- + IPO=0 + DO 90 IMAT=1,NBMIX + IDG=IFGSCT(IMAT) + IFG=IDG-INGSCT(IMAT)+1 + IF(IPOSCT(IMAT).NE.IPO+1) THEN + WRITE(IUNOUT,6006) 'IPOS'//CANISO,IGR,IMAT + ENDIF + XS=XSWORK(IMAT) + IF(XS.GT.0.0) THEN + ERR=ABS((XS-XSWORK(2*NBMIX+IPO+1+IDG-IGR))/XS) + IF(ERR.GT.1.0E-5) THEN + WRITE(IUNOUT,6006) 'SIGW'//CANISO,IGR,IMAT + WRITE(IUNOUT,'(7H ERROR=,1P,E15.5)') ERR + ENDIF + ENDIF + DO 80 JGR=IDG,IFG,-1 + IPO=IPO+1 + SCWORK(IMAT,IANIS,JGR)=SCWORK(IMAT,IANIS,JGR) + > +XSWORK(2*NBMIX+IPO) + 80 CONTINUE + 90 CONTINUE + ENDIF + 120 CONTINUE + IF(IPRINT.GE.4) THEN +*---- +* PRINT ADDITIONAL XS INFORMATION IF REQUIRED +*---- + DO 200 IED=1,NEDMAC + WRITE(CEDNAM,'(2A4)') CADNAM(1,IED),CADNAM(2,IED) + CALL LCMLEN(KPLIST,CEDNAM,ILCMLN,ILCMTY) + IF(ILCMLN .GT. 0) THEN + CALL LCMGET(KPLIST,CEDNAM,XSWORK) + IF(NBMIX .LE. 6) THEN + WRITE(IOUT,6007) CEDNAM,(XSWORK(ITC),ITC=1,NBMIX) + ELSE + WRITE(IOUT,6007) CEDNAM,(XSWORK(ITC),ITC=1,6) + WRITE(IOUT,6010) (XSWORK(ITC),ITC=7,NBMIX) + ENDIF + ENDIF + 200 CONTINUE + ENDIF + 100 CONTINUE + IF((IPRINT.GT.4).OR.(IPRINT.LT.0)) THEN + DO 160 IGR=1,NGROUP + KPLIST=LCMGIL(JPLIST,IGR) + DO 150 IANIS=1,NANISO + WRITE(CANISO,'(I2.2)') IANIS-1 + CALL LCMLEN(KPLIST,'SIGS'//CANISO,ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPLIST,'SIGS'//CANISO,XSWORK) + DO 140 IMAT=1,NBMIX + XS=XSWORK(IMAT) + IF(XS.GT.0.0) THEN + ERR=ABS((SCWORK(IMAT,IANIS,IGR)-XS)/XS) + IF(ERR.GT.1.0E-4) THEN + WRITE(IUNOUT,6006) 'SIGS'//CANISO,IGR,IMAT + WRITE(IUNOUT,'(7H ERROR=,1P,E15.5)') ERR + ENDIF + ENDIF + 140 CONTINUE + ENDIF + 150 CONTINUE + 160 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(TCOR,SCWORK,XSWOR2,XSWORK) + DEALLOCATE(CADNAM,IPOSCT,IFGSCT,INGSCT) + RETURN +*---- +* FORMAT +*---- + 6000 FORMAT(//' EDITION OF X-S STORED ON LCM.'/1X,29(1H-)) + 6001 FORMAT(/' G R O U P : ',I5/' MIXTURE',I8,6I16) + 6002 FORMAT(1X,A12,1P,7E16.8) + 6003 FORMAT(/14X,'FISSIONABLE ISOTOPE POSITION:',I5) + 6004 FORMAT(1X,A12,1X,'MIXTURE:',I5,3X,'FROM GROUPS:',I5,' TO ',I5,5X, + >1P,4E16.8) + 6005 FORMAT(14X,'MIXTURE:',I5,3X,'FROM GROUPS:',I5,' TO ',I5,5X, + >1P,4E16.8) + 6006 FORMAT(/39H MACWXS: INCONSISTENT VALUE OF RECORD ',A12,7H' IN GR, + >3HOUP,I4,12H AND MIXTURE,I6,1H.) + 6007 FORMAT(1X,'ADDITIONAL XS : ',A12,1P,6E16.8) + 6010 FORMAT(1P,(13X,7E16.8)) + 6011 FORMAT(7I16) + END diff --git a/Dragon/src/MACXSR.f b/Dragon/src/MACXSR.f new file mode 100644 index 0000000..2824ee2 --- /dev/null +++ b/Dragon/src/MACXSR.f @@ -0,0 +1,690 @@ +*DECK MACXSR + SUBROUTINE MACXSR(MAXFIS,NGROUP,NBMIX,NIFISS,NANISO,NDELG,NTYPE, + > XSTOTL,XSTOT1,XSFISS,XSSPEC,XSFIXE,XSTRAN, + > XSDIFF,XSNFTO,XSH,XSSCAT,LOLDXS,LNEWXS,CARLIR, + > LADD,LUPD,IPRINT,ISCATA,XSNUDL,XSCHDL,XSDIFX, + > XSDIFY,XSDIFZ,XSOVRV,XSINT0,XSINT1,HADF,XADF) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read cross sections from input file. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* MAXFIS set to max(1,NIFISS). +* NGROUP number of energy groups. +* NBMIX maximum number of mixtures. +* NIFISS number of fissile isotopes. +* NANISO maximum Legendre order: +* =1 isotropic collision; +* =2 linearly anisotropic collision. +* NDELG number of precursor groups for delayed neutrons. +* NTYPE number of boundary regions types for ADF calculations. +* LOLDXS flag for cross section type already present on the macrolib. +* CARLIR last string read. +* LADD flag (true) for reading invcrementsçal XS. +* LUPD flag (true) for updating XS. +* IPRINT print level. +* +*Parameters: input/output +* XSTOTL P0 total cross section of mixture. +* XSTOT1 P1 total cross section of mixture. +* XSFISS nu*fission cross section of mixture. +* XSNFTO fission cross section of mixture. +* XSSPEC fission spectrum. +* XSFIXE fixe sources. +* XSTRAN transport correction. +* XSDIFF isotropic diffusion coefficient. +* XSH power factor. +* XSSCAT scattering cross section of mixture/group. +* XSNUDL delayed nu*fission cross section of mixture. +* XSCHDL delayed-neutron fission spectrum. +* XSDIFX x-directed diffusion coefficients. +* XSDIFY y-directed diffusion coefficients. +* XSDIFZ z-directed diffusion coefficients. +* XSOVRV reciprocal neutron velocities. +* XSINT0 P0 volume-integrated flux of mixture. +* XSINT1 P1 volume-integrated flux of mixture. +* +*Parameters: output +* LNEWXS flag for cross section modified. +* ISCATA check for scattering anisotropy. +* HADF names of the boundary flux types. +* XADF averaged fluxes in boundary regions. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + PARAMETER (NCXST=18) + INTEGER MAXFIS,NGROUP,NBMIX,NIFISS,NANISO,NDELG,IPRINT, + > ISCATA(NANISO) + REAL XSTOTL(NBMIX,NGROUP),XSTOT1(NBMIX,NGROUP), + > XSFISS(NBMIX,MAXFIS,NGROUP),XSSPEC(NBMIX,MAXFIS,NGROUP), + > XSFIXE(NBMIX,NGROUP),XSTRAN(NBMIX,NGROUP), + > XSDIFF(NBMIX,NGROUP),XSNFTO(NBMIX,NGROUP), + > XSH(NBMIX,NGROUP),XSSCAT(NGROUP,NBMIX,NANISO,NGROUP), + > XSNUDL(NBMIX,MAXFIS,NDELG,NGROUP), + > XSCHDL(NBMIX,MAXFIS,NDELG,NGROUP), + > XSDIFX(NBMIX,NGROUP),XSDIFY(NBMIX,NGROUP), + > XSDIFZ(NBMIX,NGROUP),XSOVRV(NBMIX,NGROUP), + > XSINT0(NBMIX,NGROUP),XSINT1(NBMIX,NGROUP), + > XADF(NBMIX,NGROUP,NTYPE) + LOGICAL LOLDXS(NCXST),LNEWXS(NCXST),LADD,LUPD + CHARACTER HADF(NTYPE)*8,CARLIR*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6) + CHARACTER CARXST(NCXST)*6 + DOUBLE PRECISION DBLINP +*---- +* ALLOCATABLE ARRAYS +*---- + LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: LINIXS +*---- +* SCRATCH STORAGE ALLOCATION +* LINIXS flag for cross section read per mixture. +*---- + ALLOCATE(LINIXS(NCXST,NBMIX)) +* + HADF(:)=' ' + XADF(:,:,:)=0.0 + MATNUM=0 + DO 200 IM=1,NBMIX + DO 210 IT=1,NCXST + LINIXS(IT,IM)=.TRUE. + 210 CONTINUE + 200 CONTINUE +*---- +* START READING KEYWORDS +*---- + ITYPE=0 + 1000 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) + 1001 IF(ITYPLU.NE.3) CALL XABORT('MACXSR: READ ERROR - CHARACTER VARI' + > //'ABLE EXPECTED: TOTA, NUSI, FIXE, TRAN, DIFF, CHI, SCAT, MIX ') + IF((CARLIR.EQ.'NTOT0').OR.(CARLIR.EQ.'TOTAL')) THEN + IF(MATNUM.LE.0)CALL XABORT('MACXSR: NO MIXTURE NUMBER PROVIDED') + IF(LINIXS(1,MATNUM)) THEN + LINIXS(1,MATNUM)=.FALSE. + ELSE + CALL XABORT('MACXSR: TOTAL XS FOR THIS MATERIAL ALREADY READ') + ENDIF + LNEWXS(1)=.TRUE. +*---- +* TOTAL XS +*---- + DO 100 IGROUP=1,NGROUP + CALL REDGET(ITYPLU,INTLIR,FLOTT,CARLIR,DBLINP) + IF(ITYPLU.NE.2) CALL XABORT('MACXSR: READ ERROR - REAL VARIA' + > //'BLE EXPECTED: TOTAL XS') + IF(LADD) FLOTT=FLOTT+XSTOTL(MATNUM,IGROUP) + XSTOTL(MATNUM,IGROUP)=FLOTT + 100 CONTINUE + ELSE IF(CARLIR.EQ.'NUSIGF') THEN + IF(MATNUM.LE.0)CALL XABORT('MACXSR: NO MIXTURE NUMBER PROVIDED') + IF(NIFISS.EQ.0)CALL XABORT('MACXSR: NIFISS EXPECTED GREATER TH' + > //'AN ZERO') + IF(LINIXS(2,MATNUM)) THEN + LINIXS(2,MATNUM)=.FALSE. + ELSE + CALL XABORT('MACXSR: NUSIGF FOR THIS MATERIAL ALREADY READ') + ENDIF + LNEWXS(2)=.TRUE. +*---- +* NUSIGF XS +*---- + DO 110 IFIS=1,NIFISS + DO 120 IGROUP=1,NGROUP + CALL REDGET(ITYPLU,INTLIR,FLOTT,CARLIR,DBLINP) + IF(ITYPLU.NE.2) CALL XABORT('MACXSR: READ ERROR - REAL VAR' + > //'IABLE EXPECTED: NUSIGF') + IF(LADD) FLOTT=FLOTT+XSFISS(MATNUM,IFIS,IGROUP) + XSFISS(MATNUM,IFIS,IGROUP)=FLOTT + 120 CONTINUE + 110 CONTINUE + ELSE IF(CARLIR.EQ.'FIXE') THEN + IF(MATNUM.LE.0)CALL XABORT('MACXSR: NO MIXTURE NUMBER PROVIDED') + IF(LINIXS(3,MATNUM)) THEN + LINIXS(3,MATNUM)=.FALSE. + ELSE + CALL XABORT('MACXSR: FIXE FOR THIS MATERIAL ALREADY READ') + ENDIF + LNEWXS(3)=.TRUE. +*---- +* FIXED SOURCES +*---- + DO 130 IGROUP=1,NGROUP + CALL REDGET(ITYPLU,INTLIR,FLOTT,CARLIR,DBLINP) + IF(ITYPLU.NE.2) CALL XABORT('MACXSR: READ ERROR - REAL VARIA' + > //'BLE EXPECTED: FIXE') + IF(LADD) FLOTT=FLOTT+XSFIXE(MATNUM,IGROUP) + XSFIXE(MATNUM,IGROUP)=FLOTT + 130 CONTINUE + ELSE IF(CARLIR.EQ.'TRANC') THEN + IF(MATNUM.LE.0)CALL XABORT('MACXSR: NO MIXTURE NUMBER PROVIDED') + IF(LINIXS(6,MATNUM)) THEN + LINIXS(6,MATNUM)=.FALSE. + ELSE + CALL XABORT('MACXSR: TRANC FOR THIS MATERIAL ALREADY READ') + ENDIF + LNEWXS(6)=.TRUE. +*---- +* TRANSPORT CORRECTION +*---- + DO 140 IGROUP=1,NGROUP + CALL REDGET(ITYPLU,INTLIR,FLOTT,CARLIR,DBLINP) + IF(ITYPLU.NE.2) CALL XABORT('MACXSR: READ ERROR - REAL VARIA' + > //'BLE EXPECTED: TRANC') + IF(LADD) FLOTT=FLOTT+XSTRAN(MATNUM,IGROUP) + XSTRAN(MATNUM,IGROUP)=FLOTT + 140 CONTINUE + ELSE IF(CARLIR.EQ.'DIFF') THEN + IF(MATNUM.LE.0)CALL XABORT('MACXSR: NO MIXTURE NUMBER PROVIDED') + IF(LINIXS(7,MATNUM)) THEN + LINIXS(7,MATNUM)=.FALSE. + ELSE + CALL XABORT('MACXSR: DIFF FOR THIS MATERIAL ALREADY READ') + ENDIF + LNEWXS(7)=.TRUE. +*---- +* ISOTROPIC DIFFUSION COEFFICIENT +*---- + DO 145 IGROUP=1,NGROUP + CALL REDGET(ITYPLU,INTLIR,FLOTT,CARLIR,DBLINP) + IF(ITYPLU.NE.2) CALL XABORT('MACXSR: READ ERROR - REAL VARIA' + > //'BLE EXPECTED: DIFF') + IF(LADD) FLOTT=FLOTT+XSDIFF(MATNUM,IGROUP) + XSDIFF(MATNUM,IGROUP)=FLOTT + 145 CONTINUE + ELSE IF(CARLIR.EQ.'DIFFX') THEN + IF(MATNUM.LE.0)CALL XABORT('MACXSR: NO MIXTURE NUMBER PROVIDED') + IF(LINIXS(10,MATNUM)) THEN + LINIXS(10,MATNUM)=.FALSE. + ELSE + CALL XABORT('MACXSR: DIFFX FOR THIS MATERIAL ALREADY READ') + ENDIF + LNEWXS(10)=.TRUE. +*---- +* X-DIRECTED DIFFUSION COEFFICIENT +*---- + DO IGROUP=1,NGROUP + CALL REDGET(ITYPLU,INTLIR,FLOTT,CARLIR,DBLINP) + IF(ITYPLU.NE.2) CALL XABORT('MACXSR: READ ERROR - REAL VARIA' + > //'BLE EXPECTED: DIFFX') + IF(LADD) CALL XABORT('MACXSR: INVALID OPTION ADD FOR DIFFX') + XSDIFX(MATNUM,IGROUP)=FLOTT + ENDDO + ELSE IF(CARLIR.EQ.'DIFFY') THEN + IF(MATNUM.LE.0)CALL XABORT('MACXSR: NO MIXTURE NUMBER PROVIDED') + IF(LINIXS(11,MATNUM)) THEN + LINIXS(11,MATNUM)=.FALSE. + ELSE + CALL XABORT('MACXSR: DIFFY FOR THIS MATERIAL ALREADY READ') + ENDIF + LNEWXS(11)=.TRUE. +*---- +* Y-DIRECTED DIFFUSION COEFFICIENT +*---- + DO IGROUP=1,NGROUP + CALL REDGET(ITYPLU,INTLIR,FLOTT,CARLIR,DBLINP) + IF(ITYPLU.NE.2) CALL XABORT('MACXSR: READ ERROR - REAL VARIA' + > //'BLE EXPECTED: DIFFY') + IF(LADD) CALL XABORT('MACXSR: INVALID OPTION ADD FOR DIFFY') + XSDIFY(MATNUM,IGROUP)=FLOTT + ENDDO + ELSE IF(CARLIR.EQ.'DIFFZ') THEN + IF(MATNUM.LE.0)CALL XABORT('MACXSR: NO MIXTURE NUMBER PROVIDED') + IF(LINIXS(12,MATNUM)) THEN + LINIXS(12,MATNUM)=.FALSE. + ELSE + CALL XABORT('MACXSR: DIFFZ FOR THIS MATERIAL ALREADY READ') + ENDIF + LNEWXS(12)=.TRUE. +*---- +* Z-DIRECTED DIFFUSION COEFFICIENT +*---- + DO IGROUP=1,NGROUP + CALL REDGET(ITYPLU,INTLIR,FLOTT,CARLIR,DBLINP) + IF(ITYPLU.NE.2) CALL XABORT('MACXSR: READ ERROR - REAL VARIA' + > //'BLE EXPECTED: DIFFZ') + IF(LADD) CALL XABORT('MACXSR: INVALID OPTION ADD FOR DIFFZ') + XSDIFZ(MATNUM,IGROUP)=FLOTT + ENDDO + ELSE IF(CARLIR.EQ.'NUSIGD') THEN + IF(MATNUM.LE.0)CALL XABORT('MACXSR: NO MIXTURE NUMBER PROVIDED') + IF(NDELG.EQ.0)CALL XABORT('MACXSR: NDG EXPECTED GREATER THAN' + > //' ZERO') + IF(LINIXS(13,MATNUM)) THEN + LINIXS(13,MATNUM)=.FALSE. + ELSE + CALL XABORT('MACXSR: NUSIGD FOR THIS MATERIAL ALREADY READ') + ENDIF + LNEWXS(13)=.TRUE. +*---- +* DELAYED-NEUTRON NU*FISSION CROSS SECTIONS +*---- + DO 12 IFIS=1,NIFISS + DO 11 IDELG=1,NDELG + DO 10 IGROUP=1,NGROUP + CALL REDGET(ITYPLU,INTLIR,FLOTT,CARLIR,DBLINP) + IF(ITYPLU.NE.2) CALL XABORT('MACXSR: READ ERROR - REAL VAR' + > //'IABLE EXPECTED: NUSIGD ') + IF(LADD) CALL XABORT('MACXSR: INVALID OPTION ADD FOR NUSIGD') + XSNUDL(MATNUM,IFIS,IDELG,IGROUP)=FLOTT + 10 CONTINUE + 11 CONTINUE + 12 CONTINUE + ELSE IF(CARLIR.EQ.'CHDL') THEN + IF(MATNUM.LE.0)CALL XABORT('MACXSR: NO MIXTURE NUMBER PROVIDED') + IF(NDELG.EQ.0)CALL XABORT('MACXSR: NDG EXPECTED GREATER THAN' + > //' ZERO') + IF(LINIXS(14,MATNUM)) THEN + LINIXS(14,MATNUM)=.FALSE. + ELSE + CALL XABORT('MACXSR: CHDL FOR THIS MATERIAL ALREADY READ') + ENDIF + LNEWXS(14)=.TRUE. +*---- +* DELAYED-NEUTRON FISSION SPECTRUM +*---- + DO 22 IFIS=1,NIFISS + DO 21 IDELG=1,NDELG + DO 20 IGROUP=1,NGROUP + CALL REDGET(ITYPLU,INTLIR,FLOTT,CARLIR,DBLINP) + IF(ITYPLU.NE.2) CALL XABORT('MACXSR: READ ERROR - REAL VAR' + > //'IABLE EXPECTED: CHDL ') + IF(LADD) CALL XABORT('MACXSR: INVALID OPTION ADD FOR CHDL') + XSCHDL(MATNUM,IFIS,IDELG,IGROUP)=FLOTT + 20 CONTINUE + 21 CONTINUE + 22 CONTINUE + ELSE IF(CARLIR.EQ.'OVERV') THEN + IF(MATNUM.LE.0)CALL XABORT('MACXSR: NO MIXTURE NUMBER PROVIDED') + IF(LINIXS(15,MATNUM)) THEN + LINIXS(15,MATNUM)=.FALSE. + ELSE + CALL XABORT('MACXSR: OVERV FOR THIS MATERIAL ALREADY READ') + ENDIF + LNEWXS(15)=.TRUE. +*---- +* RECIPROCAL NEUTRON VELOCITY +*---- + DO IGROUP=1,NGROUP + CALL REDGET(ITYPLU,INTLIR,FLOTT,CARLIR,DBLINP) + IF(ITYPLU.NE.2) CALL XABORT('MACXSR: READ ERROR - REAL VARIA' + > //'BLE EXPECTED: OVERV') + IF(LADD) CALL XABORT('MACXSR: INVALID OPTION ADD FOR OVERV') + XSOVRV(MATNUM,IGROUP)=FLOTT + ENDDO + ELSE IF(CARLIR.EQ.'FLUX-INTG') THEN + IF(MATNUM.LE.0)CALL XABORT('MACXSR: NO MIXTURE NUMBER PROVIDED') + IF(LINIXS(17,MATNUM)) THEN + LINIXS(17,MATNUM)=.FALSE. + ELSE + CALL XABORT('MACXSR: FLUX-INTG FOR THIS MATERIAL ALREADY READ') + ENDIF + LNEWXS(17)=.TRUE. +*---- +* P0 VOLUME-INTEGRATED FLUX +*---- + DO IGROUP=1,NGROUP + CALL REDGET(ITYPLU,INTLIR,FLOTT,CARLIR,DBLINP) + IF(ITYPLU.NE.2) CALL XABORT('MACXSR: READ ERROR - REAL VARIA' + > //'BLE EXPECTED: FLUX-INTG') + IF(LADD) CALL XABORT('MACXSR: INVALID OPTION ADD FOR FLUX-IN' + > //'TG') + XSINT0(MATNUM,IGROUP)=FLOTT + ENDDO + ELSE IF(CARLIR.EQ.'FLUX-INTG-P1') THEN + IF(MATNUM.LE.0)CALL XABORT('MACXSR: NO MIXTURE NUMBER PROVIDED') + IF(LINIXS(18,MATNUM)) THEN + LINIXS(18,MATNUM)=.FALSE. + ELSE + CALL XABORT('MACXSR: FLUX-INTG-P1 FOR THIS MATERIAL ALREADY ' + > //'READ') + ENDIF + LNEWXS(18)=.TRUE. +*---- +* P1 VOLUME-INTEGRATED FLUX +*---- + DO IGROUP=1,NGROUP + CALL REDGET(ITYPLU,INTLIR,FLOTT,CARLIR,DBLINP) + IF(ITYPLU.NE.2) CALL XABORT('MACXSR: READ ERROR - REAL VARIA' + > //'BLE EXPECTED: FLUX-INTG-P1') + IF(LADD) CALL XABORT('MACXSR: INVALID OPTION ADD FOR FLUX-IN' + > //'TG-P1') + XSINT1(MATNUM,IGROUP)=FLOTT + ENDDO + ELSE IF(CARLIR.EQ.'H-FACTOR') THEN + IF(MATNUM.LE.0)CALL XABORT('MACXSR: NO MIXTURE NUMBER PROVIDED') + IF(LINIXS(8,MATNUM)) THEN + LINIXS(8,MATNUM)=.FALSE. + ELSE + CALL XABORT('MACXSR: H-FACTOR FOR THIS MATERIAL ALREADY READ') + ENDIF + LNEWXS(8)=.TRUE. +*---- +* POWER FACTOR +*---- + DO 146 IGROUP=1,NGROUP + CALL REDGET(ITYPLU,INTLIR,FLOTT,CARLIR,DBLINP) + IF(ITYPLU.NE.2) CALL XABORT('MACXSR: READ ERROR - REAL VARIA' + > //'BLE EXPECTED: H-FACTOR') + IF(LADD) FLOTT=FLOTT+XSH(MATNUM,IGROUP) + XSH(MATNUM,IGROUP)=FLOTT + 146 CONTINUE + ELSE IF(CARLIR.EQ.'NTOT1') THEN + IF(MATNUM.LE.0)CALL XABORT('MACXSR: NO MIXTURE NUMBER PROVIDED') + IF(LINIXS(9,MATNUM)) THEN + LINIXS(9,MATNUM)=.FALSE. + ELSE + CALL XABORT('MACXSR: P1 TOTAL XS FOR THIS MATERIAL ALREADY R' + > //'EAD') + ENDIF + LNEWXS(9)=.TRUE. +*---- +* P1 TOTAL XS +*---- + DO 147 IGROUP=1,NGROUP + CALL REDGET(ITYPLU,INTLIR,FLOTT,CARLIR,DBLINP) + IF(ITYPLU.NE.2) CALL XABORT('MACXSR: READ ERROR - REAL VARIA' + > //'BLE EXPECTED: P1 TOTAL XS') + IF(LADD) FLOTT=FLOTT+XSTOT1(MATNUM,IGROUP) + XSTOT1(MATNUM,IGROUP)=FLOTT + 147 CONTINUE + ELSE IF(CARLIR.EQ.'CHI') THEN + IF(MATNUM.LE.0)CALL XABORT('MACXSR: NO MIXTURE NUMBER PROVIDED') + IF(NIFISS.EQ.0)CALL XABORT('MACXSR: NIFISS EXPECTED GREATER TH' + > //'AN ZERO') + IF(LINIXS(4,MATNUM)) THEN + LINIXS(4,MATNUM)=.FALSE. + ELSE + CALL XABORT('MACXSR: CHI FOR THIS MATERIAL ALREADY READ') + ENDIF + LNEWXS(4)=.TRUE. +*---- +* FISSION SPECTRUM +*---- + DO 150 IFIS=1,NIFISS + DO 160 IGROUP=1,NGROUP + CALL REDGET(ITYPLU,INTLIR,FLOTT,CARLIR,DBLINP) + IF(ITYPLU.NE.2) CALL XABORT('MACXSR: READ ERROR - REAL VAR' + > //'IABLE EXPECTED: CHI ') + IF(LADD) FLOTT=FLOTT+XSSPEC(MATNUM,IFIS,IGROUP) + XSSPEC(MATNUM,IFIS,IGROUP)=FLOTT + 160 CONTINUE + 150 CONTINUE + ELSE IF(CARLIR.EQ.'NFTOT') THEN + IF(MATNUM.LE.0)CALL XABORT('MACXSR: NO MIXTURE NUMBER PROVIDED') + IF(LINIXS(16,MATNUM)) THEN + LINIXS(16,MATNUM)=.FALSE. + ELSE + CALL XABORT('MACXSR: NFTOT FOR THIS MATERIAL ALREADY READ') + ENDIF + LNEWXS(16)=.TRUE. +*---- +* FISSION XS +*---- + DO 155 IGROUP=1,NGROUP + CALL REDGET(ITYPLU,INTLIR,FLOTT,CARLIR,DBLINP) + IF(ITYPLU.NE.2) CALL XABORT('MACXSR: READ ERROR - REAL VARIA' + > //'BLE EXPECTED: NFTOT') + IF(LADD) FLOTT=FLOTT+XSNFTO(MATNUM,IGROUP) + XSNFTO(MATNUM,IGROUP)=FLOTT + 155 CONTINUE + ELSE IF(CARLIR.EQ.'SCAT') THEN + IF(MATNUM.LE.0)CALL XABORT('MACXSR: NO MIXTURE NUMBER PROVIDED') + IF(LINIXS(5,MATNUM)) THEN + LINIXS(5,MATNUM)=.FALSE. + ELSE + CALL XABORT('MACXSR: SCATT XS FOR THIS MATERIAL ALREADY READ') + ENDIF + LNEWXS(5)=.TRUE. +*---- +* SCATTERING XS: XSSCAT(JGROUP,MATNUM,JANS,IGROUP) WHERE IGROUP IS +* THE SECONDARY GROUP. +*---- + DO 170 JANS=1,NANISO + ISCATA(JANS)=2 + DO 180 IGROUP=1,NGROUP +*---- +* READ NUMBER OF GROUPS AND FIRST GROUP +*---- + CALL REDGET(ITYPLU,ING,REALIR,CARLIR,DBLINP) + IF(ITYPLU.NE.1) THEN + CALL XABORT('MACXSR: READ ERROR - INTEGER VARIABLE EXPEC' + > //'TED FOR SCAT: NGSCAT ') + ENDIF + CALL REDGET(ITYPLU,IFG,REALIR,CARLIR,DBLINP) + IF(ITYPLU.NE.1) CALL XABORT('MACXSR: READ ERROR - INTEGER ' + > //'VARIABLE EXPECTED FOR SCAT: NFSCAT') +*---- +* READ SCATTERING XS +*---- + DO 190 JGROUP=NGROUP,1,-1 + IF((JGROUP.GT.IFG).OR.(JGROUP.LE.(IFG-ING))) THEN + IF(.NOT.LADD) XSSCAT(JGROUP,MATNUM,JANS,IGROUP)=0.0 + ELSE + CALL REDGET(ITYPLU,INTLIR,FLOTT,CARLIR,DBLINP) + IF(ITYPLU.NE.2) CALL XABORT('MACXSR: READ ERROR - REAL' + > //' VARIABLE EXPECTED: SCAT') + IF(LADD) FLOTT=FLOTT+XSSCAT(JGROUP,MATNUM,JANS,IGROUP) + XSSCAT(JGROUP,MATNUM,JANS,IGROUP)=FLOTT + ENDIF + 190 CONTINUE + 180 CONTINUE + 170 CONTINUE + ELSE IF(CARLIR.EQ.'ADF') THEN + CALL REDGET(ITYPLU,INTLIR,FLOTT,CARLIR,DBLINP) + IF(ITYPLU.NE.3) CALL XABORT('MACXSR: READ ERROR - CHARACTER ' + > //'VARIABLE EXPECTED: HADF') + ITYPE=ITYPE+1 + IF(ITYPE.GT.NTYPE) CALL XABORT('MACXSR: NTYPE OVERFLOW.') + IF(HADF(ITYPE).EQ.' ') THEN + HADF(ITYPE)=CARLIR(:8) + ELSE IF(CARLIR(:8).NE.HADF(ITYPE)) THEN + CALL XABORT('MACXSR: READ ERROR - ADF NAME '//HADF(ITYPE)// + 1 ' EXPECTED.') + ENDIF + DO 205 IGROUP=1,NGROUP + CALL REDGET(ITYPLU,INTLIR,FLOTT,CARLIR,DBLINP) + IF(ITYPLU.NE.2) CALL XABORT('MACXSR: READ ERROR - REAL VAR' + > //'IABLE EXPECTED: XADF ') + XADF(MATNUM,IGROUP,ITYPE)=FLOTT + 205 CONTINUE + ELSE + IF(.NOT. LUPD .AND. MATNUM.GT.0 ) THEN +*---- +* RESET XS THAT WERE NOT READ FOR THIS MATERIAL TO 0.0 +*---- + IF(LINIXS(1,MATNUM).AND.LOLDXS(1)) THEN + LNEWXS(1)=.TRUE. + DO 300 IGG=1,NGROUP + XSTOTL(MATNUM,IGG)=0.0 + 300 CONTINUE + ENDIF + IF(LINIXS(2,MATNUM).AND.LOLDXS(2)) THEN + LNEWXS(2)=.TRUE. + DO 310 IGG=1,NGROUP + DO 320 IFS=1,NIFISS + XSFISS(MATNUM,IFS,IGG)=0.0 + 320 CONTINUE + 310 CONTINUE + ENDIF + IF(LINIXS(3,MATNUM).AND.LOLDXS(3)) THEN + LNEWXS(3)=.TRUE. + DO 330 IGG=1,NGROUP + XSFIXE(MATNUM,IGG)=0.0 + 330 CONTINUE + ENDIF + IF(LINIXS(4,MATNUM).AND.LOLDXS(4)) THEN + LNEWXS(4)=.TRUE. + DO 340 IGG=1,NGROUP + DO 350 IFS=1,NIFISS + XSSPEC(MATNUM,IFS,IGG)=0.0 + 350 CONTINUE + 340 CONTINUE + ENDIF + IF(LINIXS(5,MATNUM).AND.LOLDXS(5)) THEN + LNEWXS(5)=.TRUE. + DO 360 JANS=1,NANISO + IF(ISCATA(JANS).GE.1) THEN + ISCATA(JANS)=2 + DO 370 IGG=1,NGROUP + DO 380 JGG=1,NGROUP + XSSCAT(JGG,MATNUM,JANS,IGG)=0.0 + 380 CONTINUE + 370 CONTINUE + ENDIF + 360 CONTINUE + ENDIF + IF(LINIXS(6,MATNUM).AND.LOLDXS(6)) THEN + LNEWXS(6)=.TRUE. + DO 390 IGG=1,NGROUP + XSTRAN(MATNUM,IGG)=0.0 + 390 CONTINUE + ENDIF + IF(LINIXS(7,MATNUM).AND.LOLDXS(7)) THEN + LNEWXS(7)=.TRUE. + DO 400 IGG=1,NGROUP + XSDIFF(MATNUM,IGG)=0.0 + 400 CONTINUE + ENDIF + IF(LINIXS(8,MATNUM).AND.LOLDXS(8)) THEN + LNEWXS(8)=.TRUE. + DO 410 IGG=1,NGROUP + XSH(MATNUM,IGG)=0.0 + 410 CONTINUE + ENDIF + IF(LINIXS(9,MATNUM).AND.LOLDXS(9)) THEN + LNEWXS(9)=.TRUE. + DO 420 IGG=1,NGROUP + XSTOT1(MATNUM,IGG)=0.0 + 420 CONTINUE + ENDIF + IF(LINIXS(10,MATNUM).AND.LOLDXS(10)) THEN + LNEWXS(10)=.TRUE. + DO 430 IGG=1,NGROUP + XSDIFX(MATNUM,IGG)=0.0 + 430 CONTINUE + ENDIF + IF(LINIXS(11,MATNUM).AND.LOLDXS(11)) THEN + LNEWXS(11)=.TRUE. + DO 440 IGG=1,NGROUP + XSDIFY(MATNUM,IGG)=0.0 + 440 CONTINUE + ENDIF + IF(LINIXS(12,MATNUM).AND.LOLDXS(12)) THEN + LNEWXS(12)=.TRUE. + DO 450 IGG=1,NGROUP + XSDIFZ(MATNUM,IGG)=0.0 + 450 CONTINUE + ENDIF + IF(LINIXS(13,MATNUM).AND.LOLDXS(13)) THEN + LNEWXS(13)=.TRUE. + DO 462 IGG=1,NGROUP + DO 461 IDELG=1,NDELG + DO 460 IFS=1,NIFISS + XSNUDL(MATNUM,IFS,IDELG,IGG)=0.0 + 460 CONTINUE + 461 CONTINUE + 462 CONTINUE + ENDIF + IF(LINIXS(14,MATNUM).AND.LOLDXS(14)) THEN + LNEWXS(14)=.TRUE. + DO 472 IGG=1,NGROUP + DO 471 IDELG=1,NDELG + DO 470 IFS=1,NIFISS + XSCHDL(MATNUM,IFS,IDELG,IGG)=0.0 + 470 CONTINUE + 471 CONTINUE + 472 CONTINUE + ENDIF + IF(LINIXS(15,MATNUM).AND.LOLDXS(15)) THEN + LNEWXS(15)=.TRUE. + DO 480 IGG=1,NGROUP + XSOVRV(MATNUM,IGG)=0.0 + 480 CONTINUE + ENDIF + IF(LINIXS(16,MATNUM).AND.LOLDXS(16)) THEN + LNEWXS(16)=.TRUE. + DO 490 IGG=1,NGROUP + XSNFTO(MATNUM,IGG)=0.0 + 490 CONTINUE + ENDIF + IF(LINIXS(17,MATNUM).AND.LOLDXS(17)) THEN + LNEWXS(17)=.TRUE. + DO 500 IGG=1,NGROUP + XSINT0(MATNUM,IGG)=0.0 + 500 CONTINUE + ENDIF + IF(LINIXS(18,MATNUM).AND.LOLDXS(18)) THEN + LNEWXS(18)=.TRUE. + DO 510 IGG=1,NGROUP + XSINT1(MATNUM,IGG)=0.0 + 510 CONTINUE + ENDIF + ENDIF +*---- +* READ MIXTURE INDEX +*---- + IF(CARLIR.EQ.'MIX') THEN + MATNUM=MATNUM+1 + ITYPE=0 + CALL REDGET(ITYPLU,MATNUM,REALIR,CARLIR,DBLINP) + IF(MATNUM.GT.NBMIX) CALL XABORT('MACXSR: MATNUM OVERFLOW.') + IF(ITYPLU.NE.1) GO TO 1001 + ELSE +*---- +* ALL MIXTURE READ RETURN +*---- + IF(IPRINT.GE.1) THEN +*---- +* FIND MATERIAL FOR WHICH XS ARE READ AND PRINT TYPE OF XS READ +*---- + WRITE(IUNOUT,6000) NANISO + DO 220 IM=1,NBMIX + DO 230 IT=1,NCXST + IF(.NOT.LINIXS(IT,IM)) THEN + CARXST(IT)='READ ' + ELSE + CARXST(IT)=' ' + ENDIF + 230 CONTINUE + WRITE(IUNOUT,6001) IM,(CARXST(JJ),JJ=1,7),CARXST(15), + > CARXST(16),CARXST(17),CARXST(18) + 220 CONTINUE + ENDIF + GO TO 550 + ENDIF + ENDIF +*---- +* RETURN TO READ NEXT KEYWORD +*---- + GO TO 1000 +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 550 DEALLOCATE(LINIXS) + RETURN +*---- +* FORMAT +*---- + 6000 FORMAT(' CROSS SECTION TYPE',5X,'NTOT0 ',5X,'NUSIGF',5X,'FIXE ', + > 5X,'CHI ',5X,'SCAT (NL= 1,',I3,')',8X,'TRANC ',5X,'DIFF ', + > 5X,'H-FACTOR',3X,'NFTOT',6X,'FLUX-INTG',2X,'FLUX-INTG-P1') + 6001 FORMAT(' MATERIAL ',I5,4X,5(5X,A6),16X,A6,3X,5(5X,A6)) + END diff --git a/Dragon/src/MCCGA.f b/Dragon/src/MCCGA.f new file mode 100644 index 0000000..49fcacf --- /dev/null +++ b/Dragon/src/MCCGA.f @@ -0,0 +1,324 @@ +*DECK MCCGA + SUBROUTINE MCCGA(IPSYS,NPSYS,IPTRK,IFTRAK,IMPX,NGRP,NBMIX,NANI, + 1 NALBP,ISTRM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of PJJ for flux integration when isotropic scattering is +* considered and calculation of preconditioning matrices for +* Algebraic Collapsing Acceleration or Self-Collision Probability +* acceleration of inner iterations (vectorial version). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert and R. Le Tellier +* +*Parameters: input/output +* IPSYS pointer to the PIJ LCM object (L_PIJ signature). IPSYS is a +* list of NGRP directories. +* NPSYS index array pointing to the IPSYS list component corresponding +* to each energy group. Set to zero if a group is not to be +* processed. Usually, NPSYS(I)=I. +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK tracking file unit number. +* IMPX print flag (equal to zero for no print). +* NGRP number of energy groups. +* NBMIX number of mixtures. +* NANI number of Legendre orders. +* NALBP number of physical albedos. +* ISTRM type of streaming effect: +* =1 no streaming effect; +* =2 isotropic streaming effect; +* =3 anisotropic streaming effect. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSYS,IPTRK + INTEGER IFTRAK,IMPX,NGRP,NBMIX,NANI,NALBP,ISTRM,NPSYS(NGRP) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + INTEGER JPAR(NSTATE),TRTY,PACA,STIS,IGB(8) + CHARACTER*4 TEXT4 + REAL ZREAL(4),DELU,FACSYM + LOGICAL LEXA,LEXF,CYCLIC,LTMT,LACA,LPJJ,LPJJAN,LVOID,LPRISM, + 1 LBIHET + TYPE(C_PTR) JPSYS +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NGIND + REAL, ALLOCATABLE, DIMENSION(:) :: CPO,SIGAL + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: CAZ0,CAZ1,CAZ2 + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: KPSYS +*---- +* GENERIC INTERFACES +*---- + INTERFACE + SUBROUTINE SUBPJJ_TEMPLATE(M,NSEG,NSUB,LPS,IS,JS,H,KANGL,NOM, + 1 NZON,TR,W,NFI,NREG,PJJ,PSJ,IMU,NMU,NFUNL,NANGL, + 2 NPJJM,TRHAR,LPJJAN,PJJIND) + INTEGER M,NSEG,NSUB,NFI,NREG,LPS,IS(NFI-NREG+1),JS(LPS), + 1 NZON(NFI),KANGL(NSUB),NOM(NSEG),IMU,NMU,NFUNL,NANGL,NPJJM, + 2 PJJIND(NPJJM,2) + REAL TR(0:M),PSJ(LPS),TRHAR(NMU,NFUNL,NANGL) + DOUBLE PRECISION W,H(NSUB),PJJ(NREG,NPJJM) + LOGICAL LPJJAN + END SUBROUTINE SUBPJJ_TEMPLATE + ! + SUBROUTINE SUBDSP_TEMPLATE(N,NFI,NLONG,LC,NZON,NOM,KM,MCU,IM, + 1 PREV,NEXT,H) + INTEGER N,NFI,NLONG,LC,NZON(NFI),NOM(N),KM(NLONG),MCU(LC), + 1 IM(NLONG),PREV(N),NEXT(N) + DOUBLE PRECISION, OPTIONAL :: H(N) + END SUBROUTINE SUBDSP_TEMPLATE + ! + SUBROUTINE SUBDSC_TEMPLATE(N,M,NFI,NOM,NZON,H,XST,XSW,DINV,B,A) + INTEGER N,M,NFI,NOM(N),NZON(NFI) + REAL XST(0:M),XSW(0:M) + DOUBLE PRECISION H(N),DINV(N),B(N),A(N) + END SUBROUTINE SUBDSC_TEMPLATE + ! + SUBROUTINE SUBDS2_TEMPLATE(SUBDSC,LC,M,N,H,NOM,NZON,TR,SC,W,NFI, + 1 DIAGF,DIAGQ,CA,CQ,PREV,NEXT,DINV2,A2,B2) + INTEGER LC,M,N,NFI,NZON(NFI),NOM(N),PREV(N),NEXT(N) + DOUBLE PRECISION W,H(N),CA(LC),DIAGF(NFI),DINV2(N),A2(N),B2(N) + REAL TR(0:M),SC(0:M),DIAGQ(NFI),CQ(LC) + EXTERNAL SUBDSC + END SUBROUTINE SUBDS2_TEMPLATE + END INTERFACE + PROCEDURE(SUBPJJ_TEMPLATE), POINTER :: SUBPJJ + PROCEDURE(SUBDSP_TEMPLATE), POINTER :: SUBDSP + PROCEDURE(SUBDSC_TEMPLATE), POINTER :: SUBDSC + PROCEDURE(SUBDS2_TEMPLATE), POINTER :: SUBDS2 + PROCEDURE(SUBPJJ_TEMPLATE) :: MCGDSCA,MCGDSCE,MCGDDDF + PROCEDURE(SUBDSP_TEMPLATE) :: MOCDSP,MCGDSP + PROCEDURE(SUBDSC_TEMPLATE) :: MCGDS2E,MCGDS2A + PROCEDURE(SUBDS2_TEMPLATE) :: MOCDS2,MCGDS2 +*---- +* RECOVER MCCG3D SPECIFIC PARAMETERS +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',JPAR) + IF(JPAR(4).GT.NBMIX) CALL XABORT('MCCGA: INVALID NBMIX.') + IF(IFTRAK.LE.0) CALL XABORT('MCCGA: INVALID TRACKING FILE.') +* recover state-vector information + LBIHET=JPAR(40).NE.0 + IF(LBIHET) THEN + CALL LCMSIX(IPTRK,'BIHET',1) + CALL LCMGET(IPTRK,'PARAM',IGB) + NREG=IGB(3) + CALL LCMSIX(IPTRK,' ',2) + ELSE + NREG=JPAR(1) + ENDIF + NFI=NREG+JPAR(5) + IF(JPAR(6).NE.NANI) CALL XABORT('MCCGA: INVALID NANI.') + TRTY=JPAR(9) + IF(TRTY.EQ.1) THEN + IF(JPAR(5).EQ.0) NFI=NREG+1 + CYCLIC=.TRUE. + NLONG=NREG + ELSE + CYCLIC=.FALSE. + NLONG=NFI + ENDIF + NZP=JPAR(39) + LPRISM=(NZP.NE.0) + CALL LCMGET(IPTRK,'MCCG-STATE',JPAR) + NMU=JPAR(2) + NMAX=JPAR(5) + IAAC=JPAR(7) + STIS=JPAR(15) + ISCR=JPAR(8) + LC=JPAR(6) + LPS=JPAR(9) + PACA=JPAR(10) + LC0=JPAR(17) + LTMT=(JPAR(14).EQ.1) + LEXA=(JPAR(11).EQ.1) + LEXF=(JPAR(12).EQ.1) + NPJJM=JPAR(16) +* recover real parameters + CALL LCMGET(IPTRK,'REAL-PARAM',ZREAL) + HDD=ZREAL(2) + DELU=ZREAL(3) + FACSYM=ZREAL(4) +* recover tracking file information + REWIND IFTRAK + READ(IFTRAK) TEXT4,NCOMNT,NBTR,IFMT + DO ICOM=1,NCOMNT + READ(IFTRAK) + ENDDO + READ(IFTRAK) NDIM,ISPEC,N2REG,N2SOU,NALBG,NCOR,NANGL,MXSUB,MXSEG + IF(NCOR.NE.1) + 1 CALL XABORT('MCCGA: INVALID TRACKING FILE: NCOR.NE.1') + READ(IFTRAK) + READ(IFTRAK) + READ(IFTRAK) + READ(IFTRAK) + ALLOCATE(CAZ0(NANGL),CAZ1(NANGL),CAZ2(NANGL),CPO(NMU)) + IF(NDIM.EQ.2) THEN + CALL LCMGET(IPTRK,'XMU$MCCG',CPO) + READ(IFTRAK) (CAZ1(JJ),CAZ2(JJ),JJ=1,NANGL) + ELSE ! NDIM.EQ.3 +** correction Sylvie Musongela, december 2019 + READ(IFTRAK) (CAZ1(JJ),CAZ2(JJ),CAZ0(JJ),JJ=1,NANGL) + DO JJ=1,NANGL + CAZ1(JJ)=CAZ1(JJ)/SQRT(1.0D0-CAZ0(JJ)*CAZ0(JJ)) + CAZ2(JJ)=CAZ2(JJ)/SQRT(1.0D0-CAZ0(JJ)*CAZ0(JJ)) + ENDDO + ENDIF +*--- +* DETERMINE THE NUMBER OF GROUPS TO BE PROCESSED +* RECOVER POINTERS TO EACH GROUP PROPERTIES +* CREATE AN INDEX FOR THE GROUPS TO BE PROCESSED +*--- + NGEFF=0 + DO IG=1,NGRP + IOFSET=NPSYS(IG) + IF(IOFSET.NE.0) NGEFF=NGEFF+1 + ENDDO + ALLOCATE(NGIND(NGEFF),KPSYS(NGEFF)) + II=1 + DO IG=1,NGRP + IOFSET=NPSYS(IG) + IF(IOFSET.NE.0) THEN + NGIND(II)=IG + IF(LBIHET) THEN + JPSYS=LCMGIL(IPSYS,IOFSET) + KPSYS(II)=LCMGID(JPSYS,'BIHET') + ELSE + KPSYS(II)=LCMGIL(IPSYS,IOFSET) + ENDIF + II=II+1 + ENDIF + ENDDO +*---- +* CONSTRUCT TOTAL CROSS SECTIONS ARRAY AND CHECK FOR ZERO CROSS SECTION +*---- + ALLOCATE(SIGAL((NBMIX+7)*NGEFF)) + CALL MCGSIG(IPTRK,NBMIX,NGEFF,NALBP,KPSYS,SIGAL,LVOID) + IF((LVOID).AND.(STIS.EQ.-1)) THEN + IF(IMPX.GT.0) + 1 WRITE(6,*) 'VOID EXISTS -> STIS SET TO 1 INSTEAD OF -1' + STIS=1 + ENDIF +*--- +* IS THERE SOMETHING TO DO ? +*--- + LACA=(IAAC.GT.0) + LPJJ=((STIS.EQ.1).OR.(ISCR.GT.0)) + IF(.NOT.(LACA.OR.LPJJ)) GOTO 10 + LPJJAN=(LPJJ.AND.(NANI.GT.1)) + IF(HDD.GT.0.0) THEN + ISCH=0 + ELSEIF(LEXF) THEN + ISCH=-1 + ELSE + ISCH=1 + ENDIF +*---- +* PRECONDITIONING MATRICES CALCULATION +*---- + IF(ISCH.EQ.1) THEN +* PJJ/SCR: Step-Characteristics Scheme with Tabulated Exponentials + IF(CYCLIC) THEN +* ACA: cyclic tracking + SUBPJJ => MCGDSCA + SUBDS2 => MOCDS2 + SUBDSP => MOCDSP + IF(LEXA) THEN +* ACA: Exact Exponentials + SUBDSC => MCGDS2E + ELSE +* ACA: Tabulated Exponentials +* ACA: Exact Exponentials + SUBDSC => MCGDS2A + ENDIF + ELSE +* ACA: non-cyclic tracking + SUBPJJ => MCGDSCA + SUBDS2 => MCGDS2 + SUBDSP => MCGDSP + IF(LEXA) THEN +* ACA: Exact Exponentials + SUBDSC => MCGDS2E + ELSE +* ACA: Tabulated Exponentials + SUBDSC => MCGDS2A + ENDIF + ENDIF + ELSEIF(ISCH.EQ.0) THEN +* PJJ/SCR: Diamond-Differencing Scheme + IF(CYCLIC) THEN +* ACA: cyclic tracking + SUBPJJ => MCGDDDF + SUBDS2 => MOCDS2 + SUBDSP => MOCDSP + IF(LEXA) THEN +* ACA: Exact Exponentials + SUBDSC => MCGDS2E + ELSE +* ACA: Tabulated Exponentials + SUBDSC => MCGDS2A + ENDIF + ELSE +* ACA: non-cyclic tracking + SUBPJJ => MCGDDDF + SUBDS2 => MCGDS2 + SUBDSP => MCGDSP + IF(LEXA) THEN +* ACA: Exact Exponentials + SUBDSC => MCGDS2E + ELSE +* ACA: Tabulated Exponentials + SUBDSC => MCGDS2A + ENDIF + ENDIF + ELSEIF(ISCH.EQ.-1) THEN +* PJJ/SCR: Step-Characteristics Scheme with Exact Exponentials + IF(CYCLIC) THEN +* ACA: cyclic tracking + SUBPJJ => MCGDSCE + SUBDS2 => MOCDS2 + SUBDSP => MOCDSP + IF(LEXA) THEN +* ACA: Exact Exponentials + SUBDSC => MCGDS2E + ELSE +* ACA: Tabulated Exponentials + SUBDSC => MCGDS2A + ENDIF + ELSE +* ACA: non-cyclic tracking + SUBPJJ => MCGDSCE + SUBDS2 => MCGDS2 + SUBDSP => MCGDSP + IF(LEXA) THEN +* ACA: Exact Exponentials + SUBDSC => MCGDS2E + ELSE +* ACA: Tabulated Exponentials + SUBDSC => MCGDS2A + ENDIF + ENDIF + ENDIF + CALL MCGASM(SUBPJJ,SUBDS2,SUBDSP,SUBDSC,IPTRK,KPSYS,IMPX,IFTRAK, + 1 NANI,NGEFF,NFI,NREG,NLONG,NBMIX,NMU,NANGL,NMAX,LC,NDIM,NGIND, + 2 CYCLIC,ISCR,CAZ0,CAZ1,CAZ2,CPO,LC0,PACA,LPS,LTMT,NPJJM,LACA, + 3 LPJJ,LPJJAN,SIGAL,LPRISM,N2REG,N2SOU,NZP,DELU,FACSYM,ISTRM) +* + 10 DEALLOCATE(SIGAL,KPSYS,NGIND,CPO,CAZ2,CAZ1,CAZ0) + RETURN + END diff --git a/Dragon/src/MCCGF.f b/Dragon/src/MCCGF.f new file mode 100644 index 0000000..f88b489 --- /dev/null +++ b/Dragon/src/MCCGF.f @@ -0,0 +1,536 @@ +*DECK MCCGF + SUBROUTINE MCCGF(KPSYS,IPTRK,IFTRAK,IPMACR,IMPX,NGRP,NGEFF,NGIND, + 1 IDIR,NBREG,NBMIX,NUNKNO,LEXAC,MAT,VOL,KEYFLX, + 2 FUNKNO,SUNKNO,TITR,REBFLG) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solve N-group transport equation for fluxes using the method of +* characteristics (vectorial version). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert and R. Le Tellier +* +*Parameters: input/output +* KPSYS pointer to the assembly LCM object (L_PIJ signature). KPSYS is +* an array of directories. +* IPTRK pointer to the tracking (L_TRACK signature). +* IPMACR pointer to the macrolib LCM object. +* IFTRAK tracking file unit number. +* IMPX print flag (equal to zero for no print). +* NGRP number of energy groups. +* NGEFF number of energy groups processed in parallel. +* NGIND energy group indices assign to the NGEFF set. +* IDIR direction of fundamental current for TIBERE with MoC +* (=0,1,2,3). +* NBREG total number of volumes for which specific values of the +* neutron flux and reactions rates are required. +* NBMIX number of mixtures (NBMIX=max(MAT(i))). +* NUNKNO total number of unknowns in vectors SUNKNO and FUNKNO. +* LEXAC type of exponential function calculation (=.false. to compute +* exponential functions using tables). +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX position of flux elements in FUNKNO vector. +* FUNKNO unknown vector. +* SUNKNO input source vector. +* TITR title. +* REBFLG ACA or SCR rebalancing flag. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) KPSYS(NGEFF),IPTRK,IPMACR + INTEGER NGRP,NGEFF,NGIND(NGEFF),IFTRAK,IMPX,IDIR,NBREG,NBMIX, + 1 NUNKNO,MAT(NBREG),KEYFLX(NBREG) + REAL VOL(NBREG),FUNKNO(NUNKNO,NGEFF),SUNKNO(NUNKNO,NGEFF) + CHARACTER TITR*72 + LOGICAL LEXAC,REBFLG +*---- +* GENERIC INTERFACES +*---- + INTERFACE + SUBROUTINE MOCFFI_TEMPLATE(SUBSCH,NR,NS,NUN,MT,LINE,SEGLEN, + 1 NRSEG,NE,MATALB,SIGANG,KEYFLX,YG,FLUX,EXPT,EXP2, + 2 FLM,FLP,CYM,CYP,IDIR,OMG2) + INTEGER NR,NS,NUN,MT,LINE,NRSEG(LINE),NE,MATALB(-NS:NR), + 1 KEYFLX(NR),IDIR + REAL SIGANG(-6:MT),YG(NE) + DOUBLE PRECISION SEGLEN(LINE),FLUX(NUN),EXPT(NE,LINE), + 1 EXP2(NE,LINE),FLM(NE,LINE),FLP(NE,LINE),CYM(NE,LINE), + 2 CYP(NE,LINE),OMG2(NE,3) + EXTERNAL SUBSCH + END SUBROUTINE MOCFFI_TEMPLATE + ! + SUBROUTINE MOCFFA_TEMPLATE(SUBSCH,NR,NS,NUN,MT,LINE,SEGLEN, + 1 NRSEG,NE,NF,MATALB,SIGANG,KEYFLX,YG,FLUX,EXPT,EXP2, + 2 FLM,FLP,CYM,CYP,NPHI,NSUB,KANGL,TRHAR) + INTEGER NR,NS,NUN,MT,LINE,NRSEG(LINE),NE,NF,MATALB(-NS:NR), + 1 KEYFLX(NR,NF),NPHI,NSUB,KANGL(NSUB) + REAL SIGANG(-6:MT),YG(NE),TRHAR(NE,NF,NPHI,2) + DOUBLE PRECISION SEGLEN(LINE),FLUX(NUN),EXPT(NE,LINE), + 1 EXP2(NE,LINE),FLM(NE,LINE),FLP(NE,LINE),CYM(NE,LINE), + 2 CYP(NE,LINE) + EXTERNAL SUBSCH + END SUBROUTINE MOCFFA_TEMPLATE + ! + SUBROUTINE MOCSCH_TEMPLATE(N,NREG,NSOUT,M,NOM,NZON,H,SIGANG, + 1 EXPT,EXP2,NMU,ZMU) + INTEGER N,NREG,NSOUT,M,NOM(N),NZON(-NSOUT:NREG),NMU + REAL SIGANG(-6:M),ZMU(NMU) + DOUBLE PRECISION H(N),EXPT(NMU,N),EXP2(2,NMU,N) + END SUBROUTINE MOCSCH_TEMPLATE + ! + SUBROUTINE MCGFFI_TEMPLATE(SUBSCH,K,KPN,M,N,H,NOM,NZON,XST,S, + 1 NREG,KEYFLX,KEYCUR,F,B,W,OMEGA2,IDIR,NSOUT,XSI) + INTEGER K,KPN,M,N,NOM(N),NZON(K),NREG,KEYFLX(NREG,1), + 1 KEYCUR(K-NREG),IDIR,NSOUT + REAL XST(0:M) + DOUBLE PRECISION W,H(N),S(KPN),F(KPN),B(N),OMEGA2(3), + 1 XSI(NSOUT) + EXTERNAL SUBSCH + END SUBROUTINE MCGFFI_TEMPLATE + ! + SUBROUTINE MCGFFA_TEMPLATE(SUBSCH,K,KPN,M,N,H,NOM,NZON,XST,SP, + 1 SM,NREG,NMU,NANI,NFUNL,NMOD,TRHAR,KEYFLX,KEYCUR,IMU, + 2 F,B,MODP,MODM) + INTEGER K,KPN,M,N,NOM(N),NZON(K),NMU,NFUNL,NMOD,NREG, + 1 KEYFLX(NREG,NFUNL),KEYCUR(K-NREG),IMU,NANI,MODP,MODM + REAL XST(0:M),TRHAR(NMU,NFUNL,NMOD) + DOUBLE PRECISION H(N),SP(N),SM(N),F(KPN),B(2,N) + EXTERNAL SUBSCH + END SUBROUTINE MCGFFA_TEMPLATE + ! + SUBROUTINE MCGSCH_TEMPLATE(N,K,M,NOM,NZON,H,XST,B) + INTEGER N,K,M,NOM(N),NZON(K) + REAL XST(0:M) + DOUBLE PRECISION H(N),B(N) + END SUBROUTINE MCGSCH_TEMPLATE + END INTERFACE + PROCEDURE(MOCFFI_TEMPLATE), POINTER :: MOCFFI + PROCEDURE(MOCFFA_TEMPLATE), POINTER :: MOCFFA + PROCEDURE(MOCSCH_TEMPLATE), POINTER :: MOCSCH + PROCEDURE(MCGFFI_TEMPLATE), POINTER :: MCGFFI + PROCEDURE(MCGFFA_TEMPLATE), POINTER :: MCGFFA + PROCEDURE(MCGSCH_TEMPLATE), POINTER :: MCGSCH + PROCEDURE(MOCFFI_TEMPLATE) :: MOCFFIS,MOCFFIR,MOCFFIT + PROCEDURE(MOCFFA_TEMPLATE) :: MOCFFAS,MOCFFAR,MOCFFAT + PROCEDURE(MOCSCH_TEMPLATE) :: MOCSCAS,MOCDDFS,MOCSCES,MOCSCA, + 1 MOCDDF,MOCSCE,MOCSCAT,MOCDDFT,MOCSCET,MOCSCEL,MOCDDFL,MOCSCAL + PROCEDURE(MCGFFI_TEMPLATE) :: MCGFFIS,MCGFFIR,MCGFFIT + PROCEDURE(MCGFFA_TEMPLATE) :: MCGFFAS,MCGFFAR,MCGFFAT + PROCEDURE(MCGSCH_TEMPLATE) :: MCGSCAS,MCGDDFS,MCGSCES,MCGSCA, + 1 MCGDDF,MCGSCE,MCGSCAT,MCGDDFT,MCGSCET,MCGSCEL,MCGDDFL,MCGSCAL +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6,NSTATE=40,MXNMU=64) + CHARACTER TEXT4*4,TOPT*72 + INTEGER JPAR(NSTATE),PACA,STIS,TRTY,IGB(8) + REAL ZREAL(4),HDD,DELU,FACSYM + LOGICAL CYCLIC,LVOID,LEXF,LFORW,LPRISM + EXTERNAL MOCFFAL,MCGFFAL + INTEGER, TARGET, SAVE, DIMENSION(1) :: IDUMMY +*---- +* ALLOCATABLE ARRAYS +*---- + TYPE(C_PTR) WZMU_PTR,ZMU_PTR,V_PTR,NZON_PTR,KEY_PTR,KEYCUR_PTR + INTEGER, ALLOCATABLE, DIMENSION(:) :: ITST,MATALB + REAL, ALLOCATABLE, DIMENSION(:) :: SIGAL,REPS,EPS,CPO + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: CAZ0,CAZ1,CAZ2 + LOGICAL, ALLOCATABLE, DIMENSION(:) :: INCONV + INTEGER, POINTER, DIMENSION(:) :: NZON,KEY,KEYCUR + REAL, POINTER, DIMENSION(:) :: WZMU,ZMU,V +* + IF(MAT(1).LT.0) CALL XABORT('MCCGF: EXPECTING MAT(1)>=0') + IF(VOL(1).LT.0.0) CALL XABORT('MCCGF: EXPECTING VOL(1)>=0') + IF(IMPX.GT.3) WRITE(IUNOUT,'(//8H MCCGF: ,A72/)') TITR +*---- +* RECOVER MCCG SPECIFIC PARAMETERS +*---- +* check for cross-sections in SYS object + CALL LCMGET(IPTRK,'STATE-VECTOR',JPAR) + CALL LCMLEN(KPSYS(1),'DRAGON-TXSC',ILENG,ITYLCM) + IF(ILENG.NE.NBMIX+1) CALL XABORT('MCCGF: INVALID VALUE OF NBMIX.') + IF(JPAR(4).GT.NBMIX) CALL XABORT('MCCGF: MIXTURE OVERFLOW.') +* check for a tracking binary file + IF(IFTRAK.LE.0) CALL XABORT('MCCGF: INVALID TRACKING FILE.') +* recover state-vector information + IF(JPAR(40).EQ.1) THEN + CALL LCMSIX(IPTRK,'BIHET',1) + CALL LCMGET(IPTRK,'PARAM',IGB) + NREG=IGB(3) + CALL LCMSIX(IPTRK,' ',2) + ELSE + NREG=JPAR(1) + ENDIF + NSOU=JPAR(5) + NFI=NREG+NSOU + IF(JPAR(2).GT.NUNKNO) + 1 CALL XABORT('MCCGF: UNKNOWN VECTOR OVERFLOW.') + NANI=JPAR(6) + TRTY=JPAR(9) + IF(TRTY.EQ.1) THEN + CYCLIC=.TRUE. + NLONG=NREG + ELSE + CYCLIC=.FALSE. + NLONG=NFI + ENDIF +* recover the number of tracks dispached in eack OpenMP core + NBATCH=JPAR(27) + IF(NBATCH.EQ.0) NBATCH=1 + NZP=JPAR(39) + LPRISM=(NZP.NE.0) + CALL LCMGET(IPTRK,'MCCG-STATE',JPAR) + NMU=JPAR(2) + IF(NMU.GT.MXNMU) + 1 CALL XABORT('MCCGF: POLAR ANGLE QUADRATURE OVERFLOW') + NMAX=JPAR(5) + MAXI=JPAR(13) + STIS=JPAR(15) + LC=JPAR(6) + IAAC=JPAR(7) + KRYL=JPAR(3) + IDIFC=JPAR(4) + ISCR=JPAR(8) + LPS=JPAR(9) + PACA=JPAR(10) + LEXF=(JPAR(12).EQ.1) + LFORW=(JPAR(18).EQ.0) + NFUNL=JPAR(19) + NLIN=JPAR(20) +* to be coherent with the exponential function used for the Pjj calculation + IF((LEXAC).AND.(.NOT.LEXF).AND.(STIS.EQ.1)) STIS=0 + NPJJM=JPAR(16) +* recover real parameters + CALL LCMGET(IPTRK,'REAL-PARAM',ZREAL) + EPSI=ZREAL(1) + DELU=ZREAL(3) + FACSYM=ZREAL(4) +!!! temporary + HDD=ZREAL(2) + IF(HDD.GT.0.0) THEN + ISCH=0 + ELSEIF(LEXF) THEN + ISCH=-1 + ELSE + ISCH=1 + ENDIF +*---- +* RECOVER TRACKING FILE INFORMATION +*---- + REWIND IFTRAK + READ(IFTRAK) TEXT4,NCOMNT,NBTR,IFMT + DO ICOM=1,NCOMNT + READ(IFTRAK) + ENDDO + READ(IFTRAK) NDIM,ISPEC,N2REG,N2SOU,NALBG,NCOR,NANGL,MXSUB,MXSEG + IF(NCOR.NE.1) + 1 CALL XABORT('MCCGF: INVALID TRACKING FILE: NCOR.NE.1') + ALLOCATE(MATALB(N2REG+N2SOU+1)) + READ(IFTRAK) + READ(IFTRAK) (MATALB(JJ),JJ=1,N2REG+N2SOU+1) + READ(IFTRAK) + READ(IFTRAK) + ALLOCATE(CAZ0(NANGL),CAZ1(NANGL),CAZ2(NANGL),CPO(NMU)) + IF(NDIM.EQ.2) THEN + CALL LCMGET(IPTRK,'XMU$MCCG',CPO) + READ(IFTRAK) (CAZ1(JJ),CAZ2(JJ),JJ=1,NANGL) + ELSE ! NDIM.EQ.3 +** correction Sylvie Musongela, december 2019 + READ(IFTRAK) (CAZ1(JJ),CAZ2(JJ),CAZ0(JJ),JJ=1,NANGL) + DO JJ=1,NANGL + CAZ1(JJ)=CAZ1(JJ)/SQRT(1.0D0-CAZ0(JJ)*CAZ0(JJ)) + CAZ2(JJ)=CAZ2(JJ)/SQRT(1.0D0-CAZ0(JJ)*CAZ0(JJ)) + ENDDO + ENDIF +*---- +* RECOVER TRACKING TABLE INFORMATION +*---- +* recover polar quadrature + CALL LCMGPD(IPTRK,'WZMU$MCCG',WZMU_PTR) + CALL LCMGPD(IPTRK,'ZMU$MCCG',ZMU_PTR) +* recover modified MATALB, VOLSUR and KEYFLX + CALL LCMGPD(IPTRK,'V$MCCG',V_PTR) + CALL LCMGPD(IPTRK,'NZON$MCCG',NZON_PTR) + CALL LCMGPD(IPTRK,'KEYFLX$ANIS',KEY_PTR) +* recover index for the currents in FUNKNO (non-cyclic case) + IF(.NOT.CYCLIC) CALL LCMGPD(IPTRK,'KEYCUR$MCCG',KEYCUR_PTR) +* + CALL C_F_POINTER(WZMU_PTR,WZMU,(/ NMU /)) + CALL C_F_POINTER(ZMU_PTR,ZMU,(/ NMU /)) + CALL C_F_POINTER(V_PTR,V,(/ NLONG /)) + CALL C_F_POINTER(NZON_PTR,NZON,(/ NLONG /)) + CALL C_F_POINTER(KEY_PTR,KEY,(/ NREG*NLIN*NFUNL /)) + IF(.NOT.CYCLIC) THEN + CALL C_F_POINTER(KEYCUR_PTR,KEYCUR,(/ NLONG-NBREG /)) + ELSE + KEYCUR=>IDUMMY + ENDIF +*---- +* CONSTRUCT TOTAL CROSS SECTIONS ARRAY AND CHECK FOR ZERO CROSS SECTION +*---- + CALL LCMLEN(KPSYS(1),'ALBEDO',NALBP,ITYLCM) + ALLOCATE(SIGAL((NBMIX+7)*NGEFF)) + CALL MCGSIG(IPTRK,NBMIX,NGEFF,NALBP,KPSYS,SIGAL,LVOID) + IF((LVOID).AND.(STIS.EQ.-1)) THEN + IF(IMPX.GT.0) + 1 WRITE(IUNOUT,*) 'VOID EXISTS -> STIS SET TO 1 INSTEAD OF -1' + STIS=1 + ENDIF + ISCH=ISCH+10*STIS+100*(NLIN-1) +*---- +* ASSIGN GENERIC INTERFACES +*---- + NULLIFY(MOCFFI) + NULLIFY(MOCFFA) + NULLIFY(MOCSCH) + NULLIFY(MCGFFI) + NULLIFY(MCGFFA) + NULLIFY(MCGSCH) + IF(CYCLIC) THEN +* -------------------------------- +* Method of Cyclic Characteristics +* -------------------------------- +*********'Source Term Isolation' Strategy turned off + IF(ISCH.EQ.1) THEN +* Step-Characteristics Scheme with Tabulated Exponentials + TOPT='CYCLIC - STIS 0 - SC SCHEME - TABULATED EXP' + MOCFFI => MOCFFIS + MOCFFA => MOCFFAS + MOCSCH => MOCSCAS + ELSEIF(ISCH.EQ.0) THEN +* Diamond-Differencing Scheme + TOPT='CYCLIC - STIS 0 - DD0 SCHEME' + MOCFFI => MOCFFIS + MOCFFA => MOCFFAS + MOCSCH => MOCDDFS + ELSEIF(ISCH.EQ.-1) THEN +* Step-Characteristics Scheme with Exact Exponentials + TOPT='CYCLIC - STIS 0 - SC SCHEME - EXACT EXP' + MOCFFI => MOCFFIS + MOCFFA => MOCFFAS + MOCSCH => MOCSCES +*********'Source Term Isolation' Strategy turned on + ELSEIF(ISCH.EQ.11) THEN +* Step-Characteristics Scheme with Tabulated Exponentials + TOPT='CYCLIC - STIS 1 - SC SCHEME - TABULATED EXP' + MOCFFI => MOCFFIR + MOCFFA => MOCFFAR + MOCSCH => MOCSCA + ELSEIF(ISCH.EQ.10) THEN +* Diamond-Differencing Scheme + TOPT='CYCLIC - STIS 1 - DD0 SCHEME' + MOCFFI => MOCFFIR + MOCFFA => MOCFFAR + MOCSCH => MOCDDF + ELSEIF(ISCH.EQ.9) THEN +* Step-Characteristics Scheme with Exact Exponentials + TOPT='CYCLIC - STIS 1 - SC SCHEME - EXACT EXP' + MOCFFI => MOCFFIR + MOCFFA => MOCFFAR + MOCSCH => MOCSCE +*********'MOCC/MCI' Iterative Strategy + ELSEIF(ISCH.EQ.-9) THEN +* Step-Characteristics Scheme with Tabulated Exponentials + TOPT='CYCLIC - STIS -1 - SC SCHEME - TABULATED EXP' + MOCFFI => MOCFFIT + MOCFFA => MOCFFAT + MOCSCH => MOCSCAT + ELSEIF(ISCH.EQ.-10) THEN +* Diamond-Differencing Scheme + TOPT='CYCLIC - STIS -1 - DD0 SCHEME' + MOCFFI => MOCFFIT + MOCFFA => MOCFFAT + MOCSCH => MOCDDFT + ELSEIF(ISCH.EQ.-11) THEN +* Step-Characteristics Scheme with Exact Exponentials + TOPT='CYCLIC - STIS -1 - SC SCHEME - EXACT EXP' + MOCFFI => MOCFFIT + MOCFFA => MOCFFAT + MOCSCH => MOCSCET + ELSEIF(ISCH.EQ.199) THEN +* Lin.-Disc.-Characteristics Scheme with Exact Exponentials + TOPT='CYCLIC - STIS 0 - LDC SCHEME - EXACT EXP' + MOCFFI => MOCFFIT + MOCFFA => MOCFFAT + MOCSCH => MOCSCEL + ELSEIF(ISCH.EQ.200) THEN +* Lin.-Disc.-Characteristics Scheme with Exact Exponentials + TOPT='CYCLIC - STIS 0 - LDC SCHEME - DD1 SCHEME' + MOCFFI => MOCFFIT + MOCFFA => MOCFFAT + MOCSCH => MOCDDFL + ELSEIF(ISCH.EQ.201) THEN +* Lin.-Disc.-Characteristics Scheme with Exact Exponentials + TOPT='CYCLIC - STIS 0 - LDC SCHEME - TABULATED EXP' + MOCFFI => MOCFFIT + MOCFFA => MOCFFAT + MOCSCH => MOCSCAL + ELSE + CALL XABORT('MCCGF: CYCLIC SCHEME NOT IMPLEMENTED') + ENDIF + ELSE +* ------------------------------------ +* Method of Non-Cyclic Characteristics +* ------------------------------------ + IF(ISCH.EQ.1) THEN +* Step-Characteristics Scheme with Tabulated Exponentials + TOPT='NON CYCLIC - STIS 0 - SC SCHEME - TABULATED EXP' + MCGFFI => MCGFFIS + MCGFFA => MCGFFAS + MCGSCH => MCGSCAS + ELSEIF(ISCH.EQ.0) THEN +* Diamond-Differencing Scheme + TOPT='NON CYCLIC - STIS 0 - DD0 SCHEME' + MCGFFI => MCGFFIS + MCGFFA => MCGFFAS + MCGSCH => MCGDDFS + ELSEIF(ISCH.EQ.-1) THEN +* Step-Characteristics Scheme with Exact Exponentials + TOPT='NON CYCLIC - STIS 0 - SC SCHEME - EXACT EXP' + MCGFFI => MCGFFIS + MCGFFA => MCGFFAS + MCGSCH => MCGSCES + ELSEIF(ISCH.EQ.11) THEN +* Step-Characteristics Scheme with Tabulated Exponentials + TOPT='NON CYCLIC - STIS 1 - SC SCHEME - TABULATED EXP' + MCGFFI => MCGFFIR + MCGFFA => MCGFFAR + MCGSCH => MCGSCA + ELSEIF(ISCH.EQ.10) THEN +* Diamond-Differencing Scheme + TOPT='NON CYCLIC - STIS 1 - DD0 SCHEME' + MCGFFI => MCGFFIR + MCGFFA => MCGFFAR + MCGSCH => MCGDDF + ELSEIF(ISCH.EQ.9) THEN +* Step-Characteristics Scheme with Exact Exponentials + TOPT='NON CYCLIC - STIS 1 - SC SCHEME - EXACT EXP' + MCGFFI => MCGFFIR + MCGFFA => MCGFFAR + MCGSCH => MCGSCE + ELSEIF(ISCH.EQ.-9) THEN +* Step-Characteristics Scheme with Tabulated Exponentials + TOPT='NON CYCLIC - STIS -1 - SC SCHEME - TABULATED EXP' + MCGFFI => MCGFFIT + MCGFFA => MCGFFAT + MCGSCH => MCGSCAT + ELSEIF(ISCH.EQ.-10) THEN +* Diamond-Differencing Scheme + TOPT='NON CYCLIC - STIS -1 - DD0 SCHEME' + MCGFFI => MCGFFIT + MCGFFA => MCGFFAT + MCGSCH => MCGDDFT + ELSEIF(ISCH.EQ.-11) THEN +* Step-Characteristics Scheme with Exact Exponentials + TOPT='NON CYCLIC - STIS -1 - SC SCHEME - EXACT EXP' + MCGFFI => MCGFFIT + MCGFFA => MCGFFAT + MCGSCH => MCGSCET + ELSEIF(ISCH.EQ.199) THEN +* Lin.-Disc.-Characteristics Scheme with Exact Exponentials + TOPT='NON CYCLIC - STIS 0 - LDC SCHEME - EXACT EXP' + MCGFFI => MCGFFIT + MCGFFA => MCGFFAT + MCGSCH => MCGSCEL + ELSEIF(ISCH.EQ.200) THEN +* Diamond-Differencing Scheme + TOPT='NON CYCLIC - STIS 0 - DD1 SCHEME' + MCGFFI => MCGFFIT + MCGFFA => MCGFFAT + MCGSCH => MCGDDFL + ELSEIF(ISCH.EQ.201) THEN +* Lin.-Disc.-Characteristics Scheme with Tabulated Exponentials + TOPT='NON CYCLIC - STIS 0 - LDC SCHEME - TABULATED EXP' + MCGFFI => MCGFFIT + MCGFFA => MCGFFAT + MCGSCH => MCGSCAL + ELSE + CALL XABORT('MCCGF: NON-CYCLIC SCHEME NOT IMPLEMENTED') + ENDIF + ENDIF +*---- +* PERFORM INNER ITERATIONS TO COMPUTE THE NEUTRON FLUX IN THE DIFFERENT +* GROUPS +*---- + ALLOCATE(REPS(MAXI*NGEFF),EPS(NGEFF),ITST(NGEFF),INCONV(NGEFF)) + INCONV(:NGEFF)=.TRUE. + LNCONV=NGEFF +* + IF(IDIFC.EQ.1) THEN +* ------------------------------------ +* ACA-Simplified Transport Calculation +* ------------------------------------ + TOPT='ACA-SIMPLIFIED TRANSPORT OPERATOR' + CALL MCGFLS(IMPX,IPTRK,IPMACR,NUNKNO,NFI,NBREG,NLONG,NBMIX, + 1 NGRP,NGEFF,LC,LFORW,PACA,NZON,KEY,KEYCUR,NGIND,KPSYS, + 2 INCONV,EPSI,MAXI,FUNKNO,SUNKNO) +* ------------------------------------ + ELSE + IF(CYCLIC) THEN +* -------------------------------- +* Method of Cyclic Characteristics +* -------------------------------- + CALL MCGFLX(MOCFFI,MOCFFA,MOCSCH,MOCFFAL,CYCLIC,KPSYS, + 1 IMPX,IPTRK,IFTRAK,IPMACR,NDIM,NFI,NUNKNO,NLONG,NBREG, + 2 NSOU,NGRP,NGEFF,NGIND,NZON,MATALB,V,FUNKNO,SUNKNO, + 3 NBMIX,NANI,MAXI,IAAC,KRYL,ISCR,NMU,NANGL,NMAX,LC,EPSI, + 4 CAZ0,CAZ1,CAZ2,CPO,ZMU,WZMU,LFORW,PACA,NLIN,NFUNL,KEY, + 5 KEYCUR,SIGAL,LPS,REPS,EPS,ITST,INCONV,LNCONV,REBFLG, + 6 STIS,NPJJM,LPRISM,N2REG,N2SOU,NZP,DELU,FACSYM,IDIR,NBATCH) + ELSE +* ------------------------------------ +* Method of Non-Cyclic Characteristics +* ------------------------------------ + CALL MCGFLX(MCGFFI,MCGFFA,MCGSCH,MCGFFAL,CYCLIC,KPSYS, + 1 IMPX,IPTRK,IFTRAK,IPMACR,NDIM,NFI,NUNKNO,NLONG,NBREG, + 2 NSOU,NGRP,NGEFF,NGIND,NZON,MATALB,V,FUNKNO,SUNKNO, + 3 NBMIX,NANI,MAXI,IAAC,KRYL,ISCR,NMU,NANGL,NMAX,LC,EPSI, + 4 CAZ0,CAZ1,CAZ2,CPO,ZMU,WZMU,LFORW,PACA,NLIN,NFUNL,KEY, + 5 KEYCUR,SIGAL,LPS,REPS,EPS,ITST,INCONV,LNCONV,REBFLG, + 6 STIS,NPJJM,LPRISM,N2REG,N2SOU,NZP,DELU,FACSYM,IDIR,NBATCH) + ENDIF + ENDIF + DEALLOCATE(INCONV,SIGAL,CPO,CAZ2,CAZ1,CAZ0,MATALB) +*--- +* PRINT RESULTS +*--- + IF(IMPX.GT.0) WRITE(IUNOUT,50) TOPT + IF((IDIFC.EQ.0).AND.(MAXI.GT.1).AND.(IMPX.GT.1)) THEN + DO II=1,NGEFF + WRITE(IUNOUT,100) NGIND(II) + IF(IMPX.GT.3) + 1 WRITE(IUNOUT,200) (SUNKNO(KEYFLX(I),II),I=1,NBREG) + ITEMP=ITST(II) + TEMP=EPS(II) + IF((ITEMP.EQ.MAXI).AND.(TEMP.GT.EPSI)) WRITE(IUNOUT,60) + WRITE(IUNOUT,70) ITEMP,TEMP + IF(IMPX.GT.2) THEN + WRITE(IUNOUT,150) (REPS(MAXI*(II-1)+I),I=1,MIN(ITEMP,100)) + ENDIF + ENDDO + ENDIF + DEALLOCATE(ITST,EPS,REPS) + RETURN +* + 50 FORMAT(9X,18H M O C PARAMETERS:,2X,A72) + 60 FORMAT(49H *** WARNING *** MAXIMUM NUMBER OF MCCG ITERATION, + 1 10HS REACHED.) + 70 FORMAT(34H MCCGF: NUMBER OF MCCG ITERATIONS=,I4, + 1 11H ACCURACY=,1P,E11.4,1H.) + 100 FORMAT(9X,8H GROUP (,I4,4H) : ) + 150 FORMAT('---- EPS ----'/(1P,6E16.6)) + 200 FORMAT(/33H N E U T R O N S O U R C E S :/(1P,6(5X,E15.7))) + END diff --git a/Dragon/src/MCCGT.f b/Dragon/src/MCCGT.f new file mode 100644 index 0000000..cb890d9 --- /dev/null +++ b/Dragon/src/MCCGT.f @@ -0,0 +1,1050 @@ +*DECK MCCGT + SUBROUTINE MCCGT(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Adapt EXCELL tracking to MCCG requirements. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert and R. Le Tellier +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1) modification type(L_TRACK); +* HENTRY(2) sequential binary tracking file; +* HENTRY(3) read-only type(L_GEOM). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPTRK,IPGEO + INTEGER NSTATE,MXGAUS,IOUT,IBCV + PARAMETER (NSTATE=40,MXGAUS=64,IOUT=6,IBCV=-7) + INTEGER ITRK,IFTR,IGEO,IFTRAK,J,NCOMNT,NBTR,ICOM, + 1 NDIM,ISPEC,N2REG,N2SOU,NALBG,NCOR,NANGL,MXSEG,NREG,NSOU,NANIS, + 2 ISYMM,IMPX,LCACT,NMU,MAXI,IAAC,ISCR,KRYL,IDIFC,ILEXA,ILEXF,INDIC, + 3 NITMA,NZP,N2RS,DIMKEYF,TYPOR1,TYPOR2,LTMT,STIS,LMXMCU,TRTY,PACA, + 4 SSYM,H,IMU,NFI,LMCU,N3MAX,ILINE,IANGL,N2SEG,NSEG,LMCU0,NLONG, + 5 LPS,NFIRST,NLEV,IK,JK,K,ILAST,IH,KJ,IPOS,IJEND,IJ,NFUNL,NUN,IA, + 6 IR,IKEY,ICUR,NPJJM,IFORW,II,I,IBIHET,IQUA10,IR2,NREG2,IFMT,NSUB, + 7 MXSUB,NMOD,NLIN,IE + INTEGER ISOU,IDIM,IDIR + REAL EPSI,HDD,TMUIM,FACSYM,DELU,FLOTT,DUM + DOUBLE PRECISION WEI2D,DFLOTT,CMU + CHARACTER TEXT4*4,TEXT12*12,TITLE*72,HSIGN*12,CFTRAK*12, + 1 COMNT(10)*80 + LOGICAL LPRISM,ACFLAG,LACA,LSCR,CYCLIC,LBIHET + INTEGER IGP(NSTATE),KTITL(18),NCODE(6),IGB(8) + REAL ZREAL(4),ZMU(MXGAUS),WZMU(MXGAUS),XMU(MXGAUS),ALBEDO(6), + 1 EXTKOP(NSTATE),XMU0(2*MXGAUS),WZMU0(2*MXGAUS) + DOUBLE PRECISION CMUV(MXGAUS),CMUIV(MXGAUS),SMUV(MXGAUS), + 1 SMUIV(MXGAUS),TMUV(MXGAUS),TMUIV(MXGAUS) +*---- +* ALLOCATABLE STATEMENTS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: INDREG,NZON,NZONA,ITEMP, + 1 MCUW,MCUI,NRSEG,KANGL,INOM3D,KM,MCU,IM,IS,JS,IPI,INVPI,LEV,LEVPT, + 2 KMROR,MCUROR,IMROR,JU,IWORK,IM0,MCU0,KEYFLX,KEYCUR,KEYANI,MAT + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISGNR + REAL, ALLOCATABLE, DIMENSION(:) :: ZZ,VV,RTEMP,VA,VOL + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DENSTY,SEGLEN,T2D, + 1 H3D,SURFD,VNUM + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: CAZ,XSIXYZ +*---- +* DATA STATEMENTS +*---- + INTEGER FACMCU(3) + DATA FACMCU / 2,8,12 / +*---- +* PARAMETER VALIDATION +*---- + ITRK=0 + IFTR=0 + IGEO=0 + IF(NENTRY.LE.1) CALL XABORT('MCCGT: two PARAMETERS EXPECTED.') +* tracking table in modification mode + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) + 1 CALL XABORT('MCCGT: LINKED LIST EXPECTED AT LHS.') + ITRK=1 + IF(JENTRY(ITRK).NE.1) + 1 CALL XABORT('MCCGT: ENTRY IN MODIFICATION MODE EXPECTED(1).') + IF(IENTRY(2).EQ.3) THEN +* tracking file in read-only mode + IFTR=2 + IF(JENTRY(IFTR).NE.2) + 1 CALL XABORT('MCCGT: ENTRY IN READ-ONLY MODE EXPECTED(1).') + ELSE + CALL XABORT('MCCGT: INVALID OR MISSING ENTRY(1)') + ENDIF + IF(NENTRY.GE.3) THEN + IF(IENTRY(3).LE.2) THEN +* geometry table in read-only mode + IGEO=3 + IF (JENTRY(IGEO).NE.2) + 1 CALL XABORT('MCCGT: ENTRY IN READ-ONLY MODE EXPECTED(2).') + ELSE + CALL XABORT('MCCGT: INVALID OR MISSING ENTRY(2)') + ENDIF + ENDIF +* + IPTRK=KENTRY(ITRK) + IFTRAK=FILUNIT(KENTRY(IFTR)) + IF(IGEO.NE.0) THEN + IPGEO=KENTRY(IGEO) + ELSE + IPGEO=C_NULL_PTR + ENDIF +* + CALL LCMGTC(IPTRK,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_TRACK') THEN + TEXT12=HENTRY(ITRK) + CALL XABORT('MCCGT: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_TRACK EXPECTED.') + ENDIF + CALL LCMGTC(IPTRK,'TRACK-TYPE',12,HSIGN) + IF(HSIGN.NE.'EXCELL') THEN + TEXT12=HENTRY(ITRK) + CALL XABORT('MCCGT: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. EXCELL EXPECTED.') + ENDIF +*---- +* RECOVER GEOMETRY +*---- + IF(C_ASSOCIATED(IPGEO)) THEN + CALL LCMGTC(IPGEO,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_GEOM') THEN + TEXT12=HENTRY(IGEO) + CALL XABORT('MCCGT: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_GEOM EXPECTED.') + ENDIF + TEXT12=HENTRY(IGEO) + CALL LCMPTC(IPTRK,'LINK.GEOM',12,TEXT12) + ENDIF +*---- +* RECOVER SEQUENTIAL BINARY TRACKING FILE CHARACTERISTICS +*---- + CFTRAK=HENTRY(IFTR) + CALL LCMPTC(IPTRK,'LINK.FTRACK',12,CFTRAK) + REWIND IFTRAK + READ(IFTRAK) TEXT4,NCOMNT,NBTR,IFMT + DO ICOM=1,NCOMNT + READ(IFTRAK) COMNT(ICOM) + ENDDO + READ(IFTRAK) NDIM,ISPEC,N2REG,N2SOU,NALBG,NCOR,NANGL,MXSUB,MXSEG + IF((NDIM.NE.2).AND.(NDIM.NE.3)) + & CALL XABORT('2D OR 3D EXCELT TRACKING EXPECTED') +*---- +* RECOVER TRACKING STATE-VECTOR AND USER INPUT INFORMATION +*---- + IGP(:NSTATE)=0 + CALL LCMGET(IPTRK,'STATE-VECTOR',IGP) + CALL LCMGET(IPTRK,'ALBEDO',ALBEDO) + NREG=IGP(1) + NSOU=IGP(5) + NANIS=IGP(6) + TRTY=IGP(9) + CYCLIC=(TRTY.EQ.1) + ISYMM=IGP(12) +* + IMPX=1 + LCACT=IGP(13) + NMU=IGP(14) + LBIHET=(IGP(40).NE.0) + MAXI=20 + IAAC=1 + ISCR=0 + KRYL=10 + IDIFC=0 + EPSI=1.0E-5 + HDD=0.0 + PACA=3 + ILEXA=0 + LTMT=0 + ILEXF=0 + STIS=0 + LMXMCU=0 + IFORW=0 + NFUNL=1 + NLIN=1 + DELU=0.0 + FACSYM=0.0 + IF(NANIS.LE.4) STIS=1 +*---- +* PROCESS DOUBLE HETEROGENEITY (BIHET) DATA (IF AVAILABLE) +*---- + IF(LBIHET) THEN + IF(.NOT.C_ASSOCIATED(IPGEO)) CALL XABORT('MCCGT: NO RHS GEOME' + > //'TRY DEFINED.') + CALL LCMSIX(IPTRK,'BIHET',1) + CALL LCMGET(IPTRK,'PARAM',IGB) + IR2=IGB(2) + NREG2=IGB(3) + IBIHET=IGB(6) + IQUA10=IGB(8) + ALLOCATE(MAT(NREG),VOL(NREG)) + CALL LCMGET(IPTRK,'IBI',MAT) + CALL LCMGET(IPTRK,'VOLUME',VOL) + CALL LCMSIX(IPTRK,' ',2) + CALL LCMPUT(IPTRK,'MATCOD',NREG,1,MAT) + CALL LCMPUT(IPTRK,'VOLUME',NREG,2,VOL) + DEALLOCATE(VOL,MAT) + IGP(1)=NREG2 + IGP(2)=IGP(2)-(NREG-NREG2) + IGP(4)=IR2 + CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,IGP) + NREG=NREG2 + ENDIF +* + 10 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + 20 IF(INDIC.EQ.10) GO TO 30 + IF(INDIC.NE.3) CALL XABORT('MCCGT: CHARACTER DATA EXPECTED(1).') + IF(TEXT4.EQ.'EDIT') THEN + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MCCGT: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT4.EQ.'GAUS') THEN + LCACT=-1 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) GO TO 20 + NMU=NITMA + ELSE IF(TEXT4.EQ.'DGAU') THEN + LCACT=0 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) GO TO 20 + NMU=NITMA + ELSE IF(TEXT4.EQ.'CACA') THEN + LCACT=1 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) GO TO 20 + NMU=NITMA + ELSE IF(TEXT4.EQ.'CACB') THEN + LCACT=2 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) GO TO 20 + NMU=NITMA + ELSE IF(TEXT4.EQ.'LCMD') THEN + LCACT=3 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) GO TO 20 + NMU=NITMA + ELSE IF(TEXT4.EQ.'OPP1') THEN + LCACT=4 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) GO TO 20 + NMU=NITMA + ELSE IF(TEXT4.EQ.'OGAU') THEN + LCACT=5 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) GO TO 20 + NMU=NITMA + ELSE IF(TEXT4.EQ.'EPSI') THEN +* CONVERGENCE CRITERION FOR INNER ITERATIONS. + CALL REDGET(INDIC,NITMA,EPSI,TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MCCGT: REAL DATA EXPECTED(1).') + ELSE IF(TEXT4.EQ.'SCR') THEN +* SCR ACCELERATION FLAG. + CALL REDGET(INDIC,ISCR,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MCCGT: INTEGER DATA EXPECTED(2).') + ELSE IF(TEXT4.EQ.'KRYL') THEN +* GMRES FLAG. + CALL REDGET(INDIC,KRYL,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MCCGT: INTEGER DATA EXPECTED(3).') + ELSE IF(TEXT4.EQ.'AAC') THEN +* ACA ACCELERATION FLAG. + CALL REDGET(INDIC,IAAC,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MCCGT: INTEGER DATA EXPECTED(4).') + ELSE IF(TEXT4.EQ.'BICG') THEN +* ACA SYSTEM RESOLUTION TYPE (obsolete because it is the only option!) + IF(IAAC.EQ.0) CALL XABORT('MCCGT: BICG ONLY IF ACA IS ON.') + ELSE IF(TEXT4.EQ.'ILU0') THEN +* ILU0 PRECONDITIONER FOR SOLVING ACA SYSTEM + PACA=3 + IF(IAAC.EQ.0) CALL XABORT('MCCGT: ILU0 ONLY IF ACA IS ON.') + ELSE IF(TEXT4.EQ.'DIAG') THEN +* DIAGONAL PRECONDITIONER FOR SOLVING ACA SYSTEM + PACA=1 + IF(IAAC.EQ.0) CALL XABORT('MCCGT: DIAG ONLY IF ACA IS ON.') + ELSE IF(TEXT4.EQ.'FULL') THEN +* FULL MATRIX PRECONDITIONER FOR SOLVING ACA SYSTEM + PACA=2 + IF(IAAC.EQ.0) CALL XABORT('MCCGT: FULL ONLY IF ACA IS ON.') + ELSE IF(TEXT4.EQ.'NONE') THEN +* NO PRECONDITIONER FOR SOLVING ACA SYSTEM + PACA=0 + IF(IAAC.EQ.0) CALL XABORT('MCCGT: NONE ONLY IF ACA IS ON.') + ELSE IF(TEXT4.EQ.'TMT') THEN +* TO USE A TRACK MERGING TECHNIQUE IN ACA CALCULATION + LTMT=1 + IF(IAAC.EQ.0) CALL XABORT('MCCGT: LTMT ONLY IF ACA IS ON.') + ELSE IF(TEXT4.EQ.'LEXA') THEN +* TO FORCE EXACT EXPONENTIALS IN PRECONDITIONER CALCULATIONS + ILEXA=1 + ELSE IF(TEXT4.EQ.'DIFC') THEN +* TRANSPORT/DIFFUSION SOLUTION FLAG. + IDIFC=1 + IAAC=1 + ELSE IF(TEXT4.EQ.'MCU') THEN +* MAXIMUM DIMENSION OF MCU FOR MEMORY ALLOCATION. + CALL REDGET(INDIC,LMXMCU,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MCCGT: INTEGER DATA EXPECTED(5).') + ELSE IF(TEXT4.EQ.'HDD') THEN +* SELECTION OD STEP CHARACTERISTICS METHOD. + CALL REDGET(INDIC,NITMA,HDD,TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MCCGT: REAL DATA EXPECTED(2).') + ELSE IF(TEXT4.EQ.'STIS') THEN +* 'SOURCE TERM ISOLATION' FLAG + CALL REDGET(INDIC,STIS,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MCCGT: INTEGER DATA EXPECTED(6).') + IF(ABS(STIS).GT.1) THEN + CALL XABORT('MCCGT: STIS MUST BE SET TO -1, 0 OR 1.') + ENDIF + ELSE IF(TEXT4.EQ.'LEXF') THEN +* TO FORCE EXACT EXPONENTIALS IN FLUX CALCULATIONS + ILEXF=1 + ELSE IF(TEXT4.EQ.'ADJ') THEN +* ADJOINT FLUX CALCULATION + IFORW=1 + ELSE IF(TEXT4.EQ.'MAXI') THEN +* MAXIMUM NUMBER OF INNER ITERATIONS. + CALL REDGET(INDIC,MAXI,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MCCGT: INTEGER DATA EXPECTED(7).') + ELSE IF(TEXT4.EQ.'SC') THEN +* STEP CHARACTERISTICS OR DD0 SCHEME. + NLIN=1 + ELSE IF(TEXT4.EQ.'LDC') THEN +* LINEAR DISCONTINUOUS CHARACTERISTICS OR DD1 SCHEME. + NLIN=3 + STIS=0 + ELSE IF(TEXT4.EQ.';') THEN + GO TO 30 + ELSE + CALL XABORT('MCCGT: '//TEXT4//' IS AN INVALID KEY WORD.') + ENDIF + GO TO 10 +* + 30 IF(NMU.EQ.0) THEN + IF(ISPEC.EQ.0) THEN + IF(ISYMM.LE.1) THEN + NMU=(NANGL+1)/2 + ELSE IF(ISYMM.GE.2) THEN + NMU=NANGL + ENDIF + ELSE IF(ISPEC.EQ.1) THEN + IF(ISYMM.LE.1) THEN + NMU=(NANGL/4+1)/2 + ELSE IF(ISYMM.GE.2) THEN + NMU=NANGL/4 + ENDIF + ENDIF + ENDIF + IGP(13)=LCACT + LACA=(IAAC.GT.0) + LSCR=((ISCR.GT.0).AND.(.NOT.CYCLIC)) + ZREAL(1)=EPSI + ZREAL(2)=HDD + ACFLAG=((LSCR).OR.(LACA)) + NZP=IGP(39) + LPRISM=(NZP.NE.0) + IF(LPRISM) THEN +* 3D PRISMATIC GEOMETRY + CALL LCMGET(IPTRK,'NCODE',NCODE) + IF(NCODE(6).EQ.30) THEN + IF(NCODE(5).EQ.30) THEN +* Z- and Z+ surfaces symmetry + SSYM=2 + FACSYM=0.0 + ELSE +* Z+ symmetry + SSYM=1 + FACSYM=1.0 + ENDIF + ELSE + SSYM=0 + FACSYM=0.0 + ENDIF + N2RS=N2SOU+N2REG+1 + ALLOCATE(ZZ(NZP+1),INDREG(N2RS*(NZP+2))) + CALL LCMSIX(IPTRK,'PROJECTION',1) + CALL LCMGET(IPTRK,'IND2T3',INDREG) + CALL LCMGET(IPTRK,'ZCOORD',ZZ) + CALL LCMSIX(IPTRK,'PROJECTION',2) + CALL LCMGET(IPTRK,'EXCELTRACKOP',EXTKOP) + DELU=EXTKOP(40) + ZREAL(3)=DELU + ELSE + ZREAL(3)=0.0 + ENDIF +* + IF(IMPX.GT.1) THEN + CALL LCMGET(IPTRK,'TITLE',KTITL) + WRITE(TITLE,'(3A4)') (KTITL(J),J=1,3) + WRITE(IOUT,100) TITLE + IF(LPRISM) WRITE(IOUT,*) '3D PRISMATIC EXTENDED TRACKING' + ENDIF +*--- +* CALCULATE POLAR QUADRATURE IF REQUIRED +*--- + TMUIM=0.0 + IF(NDIM.EQ.2) THEN + IF(LCACT.EQ.-1) THEN + CALL ALGPT ( 2*NMU, -1.0, 1.0, XMU0(1), WZMU0(1)) + DO IMU=1,NMU + XMU(NMU-IMU+1)=XMU0(IMU) + WZMU(NMU-IMU+1)=WZMU0(IMU) + ENDDO + ELSE IF(LCACT.EQ.0) THEN + CALL ALGPT ( NMU, 0.0, 1.0, XMU(1), WZMU(1)) + ELSE + IF(LCACT.GE.3) THEN + IF(NMU.GT.4) NMU=4 + IF(NMU.LT.2) NMU=2 + ENDIF + CALL ALCACT( LCACT, NMU, XMU, WZMU) + ENDIF + IF(LPRISM) THEN + DO IMU=1,NMU + ZMU(IMU)=1.0 + WZMU(IMU)=0.5*WZMU(IMU) + CMU=DBLE(XMU(IMU)) + CMUV(IMU)=CMU + CMUIV(IMU)=1.D0/CMU + SMUV(IMU)=SQRT(1.D0-CMU**2) + SMUIV(IMU)=1.D0/SMUV(IMU) + TMUV(IMU)=SMUV(IMU)/CMU + TMUIV(IMU)=1.D0/TMUV(IMU) + TMUIM=MAX(REAL(TMUIM),REAL(TMUIV(IMU))) + ENDDO + ELSE + DO IMU=1,NMU + DUM=SQRT(1.-XMU(IMU)*XMU(IMU)) + ZMU(IMU)=1./DUM + WZMU(IMU)=WZMU(IMU)*DUM + ENDDO + ENDIF + IF(IMPX.GT.3) THEN + CALL PRINAM('XMU ',XMU(1),NMU) + CALL PRINAM('ZMU ',ZMU(1),NMU) + CALL PRINAM('WZMU ',WZMU(1),NMU) + ENDIF + ELSE ! NDIM.EQ.3 + NMU=1 + WZMU(1)=1.0 + XMU(1)=0.0 + ZMU(1)=1.0 + ENDIF + IF(LPRISM) THEN + CALL LCMSIX(IPTRK,'PROJECTION',1) + CALL LCMPUT(IPTRK,'CMU',NMU,4,CMUV) + CALL LCMPUT(IPTRK,'CMUI',NMU,4,CMUIV) + CALL LCMPUT(IPTRK,'SMU',NMU,4,SMUV) + CALL LCMPUT(IPTRK,'SMUI',NMU,4,SMUIV) + CALL LCMPUT(IPTRK,'TMU',NMU,4,TMUV) + CALL LCMPUT(IPTRK,'TMUI',NMU,4,TMUIV) + CALL LCMSIX(IPTRK,'PROJECTION',2) + ENDIF + CALL LCMPUT(IPTRK,'ZMU$MCCG',NMU,2,ZMU) + CALL LCMPUT(IPTRK,'XMU$MCCG',NMU,2,XMU) + CALL LCMPUT(IPTRK,'WZMU$MCCG',NMU,2,WZMU) + + NFI=NREG+NSOU + ALLOCATE(VV(NFI+1),NZON(NFI+1),ITEMP(NSOU),RTEMP(NSOU)) + IF(ACFLAG) ALLOCATE(NZONA(NFI+1)) +*--- +* RECOVER VOLUME AND MATALB ARRAYS +*--- + IF(LPRISM) THEN +* 3D PRISMATIC GEOMETRY + READ(IFTRAK) + READ(IFTRAK) + CALL LCMSIX(IPTRK,'PROJECTION',1) + CALL LCMGET(IPTRK,'VOLSUR',VV) + CALL LCMGET(IPTRK,'MATALB',NZON) + CALL LCMSIX(IPTRK,'PROJECTION',2) + ELSE +* REGULAR 2D OR 3D GEOMETRY + READ(IFTRAK) (VV(NSOU+II+1),II=-NSOU,NREG) + READ(IFTRAK) (NZON(NSOU+II+1),II=-NSOU,NREG) + ENDIF +*--- +* REORDER VOLUME AND MATALB ARRAYS (SURFACE -j BECOMES NV+j) +* [S(-NS) S(-NS+1) ... S(-1) 0 V(1) ... V(NV-1) V(NV)] +* ->[V(1)... V(NV-1) V(NV) S(-1) ... S(-NS+1) S(-NS)] +*--- + DO I=1,NSOU + ITEMP(I)=NZON(NSOU-I+1) + RTEMP(I)=VV(NSOU-I+1) + ENDDO + DO I=1,NREG + VV(I)=VV(NSOU+I+1) + NZON(I)=NZON(NSOU+I+1) + IF(ACFLAG) NZONA(I)=NZON(I) + ENDDO + DO I=1,NSOU + NZON(NREG+I)=ITEMP(I) + IF(ACFLAG) THEN + IF(ALBEDO(-ITEMP(I)).GT.0.0) THEN + NZONA(NREG+I)=ITEMP(I) + ELSE + NZONA(NREG+I)=IBCV + ENDIF + ENDIF + VV(NREG+I)=RTEMP(I) + ENDDO + DEALLOCATE(RTEMP,ITEMP) +* + ALLOCATE(DENSTY(NANGL),CAZ(NDIM,NANGL)) + READ(IFTRAK) + READ(IFTRAK) + READ(IFTRAK) ((CAZ(IDIM,II),IDIM=1,NDIM),II=1,NANGL) + READ(IFTRAK) (DENSTY(II),II=1,NANGL) + IF(LPRISM) NDIM=3 +*--- +* CALCULATE NUMERICAL SURFACES FOR NON CYCLIC TRACKING +* IF AAC OR SCR USED, CALCULATE CONNECTION MATRICES +*--- + IF(ACFLAG) THEN + IF(LMXMCU.EQ.0) LMXMCU=FACMCU(NDIM)*NFI + ALLOCATE(MCUW(LMXMCU),MCUI(LMXMCU)) + MCUW(:LMXMCU)=0 + MCUI(:LMXMCU)=0 + ENDIF + ALLOCATE(SEGLEN(MXSEG),NRSEG(MXSEG),KANGL(MXSUB)) + ALLOCATE(SURFD(NSOU),XSIXYZ(NSOU,3)) + SURFD(:NSOU)=0.0D0 + XSIXYZ(:NSOU,:3)=0.0D0 + LMCU=NFI + IF(LPRISM) THEN +* 3D PRISMATIC GEOMETRY: 3D TRACKS ARE RECONSTRUCTED + ALLOCATE(VNUM(2*NREG*NMU*NANGL)) + VNUM(:2*NREG*NMU*NANGL)=0.0D0 + ALLOCATE(T2D(MXSEG)) + N3MAX=(INT(FACSYM)+1)*MXSEG*(NZP+2) + IF(SSYM.LT.2) THEN + ALLOCATE(INOM3D(N3MAX),H3D(N3MAX)) + ELSE + TMUIM=TMUIM/ZZ(NZP+1) + ENDIF + DO ILINE=1,NBTR + READ(IFTRAK) NSUB,N2SEG,WEI2D,(KANGL(II),II=1,NSUB), + 1 (NRSEG(II),II=1,N2SEG),(SEGLEN(II),II=1,N2SEG) + IF(NSUB.GT.MXSUB) CALL XABORT('MCCGT: MXSUB OVERFLOW.') + IANGL=KANGL(1) + IF(N2SEG.GT.0) THEN + T2D(1)=0.0D0 + DO II=1,N2SEG-1 + T2D(II+1)=T2D(II)+SEGLEN(II+1) + ENDDO + IF(SSYM.EQ.2) THEN + FACSYM=MAX(TMUIM*REAL(T2D(N2SEG)),FACSYM) + ALLOCATE(INOM3D((INT(FACSYM)+1)*N3MAX), + 1 H3D((INT(FACSYM)+1)*N3MAX)) + ENDIF +!!!! IF(N2SEG-2.GE.3) then +!!!! do IZP=0,NZP +!!!! IF(IZP.lt.NZP) write(8,900) T2D,T2D, +!!!! 1 ZZ(IZP+1),ZZ(IZP+2) +!!!! do II=1,N2SEG-2 +!!!! write(8,900) T2D(II),T2D(II+1), +!!!! 1 ZZ(IZP+1),ZZ(IZP+1) +!!!! IF(IZP.lt.NZP) write(8,900) T2D(II+1),T2D(II+1) +!!!! 1 ,ZZ(IZP+1),ZZ(IZP+2) +!!!! enddo +!!!! enddo +!!!! 900 FORMAT( +!!!! 1 7H line([,E16.8,1H,,E16.8,3H],[,E16.8,1H,,E16.8,2H],, +!!!! 2 26H 'Color','r','Marker','o')/) + CALL MCGPTV(N2SOU,N2REG,NZP,SSYM,NREG,NSOU,N2SEG,N2SEG-2, + 1 NANGL,NMU,LMCU,LMXMCU,IANGL,INDREG,NRSEG,MCUW,MCUI,ZZ, + 2 T2D,WEI2D,CMUV,CMUIV,SMUV,SMUIV,TMUV,TMUIV,WZMU,DELU, + 3 INOM3D,H3D,SURFD,VNUM,ACFLAG) +!!!! endif + IF(SSYM.EQ.2) DEALLOCATE(H3D,INOM3D) + ENDIF + ENDDO + IF(SSYM.LT.2) DEALLOCATE(H3D,INOM3D) + DEALLOCATE(T2D) + CALL MCGPTN(IMPX,NREG,NSOU,NANGL,NMU,VV,VNUM,SURFD,DENSTY,WZMU) + IF(IMPX.GT.4) CALL PRINDM('VNORF',VNUM,2*NREG*NANGL*NMU) + CALL LCMSIX(IPTRK,'PROJECTION',1) + CALL LCMPUT(IPTRK,'VNORF',2*NREG*NANGL*NMU,4,VNUM) + CALL LCMSIX(IPTRK,'PROJECTION',2) + DEALLOCATE(VNUM) + ELSE +* REGULAR 2D OR 3D GEOMETRY + DO ILINE=1,NBTR + READ(IFTRAK) NSUB,NSEG,WEI2D,(KANGL(II),II=1,NSUB), + 1 (NRSEG(II),II=1,NSEG),(SEGLEN(II),II=1,NSEG) + IF(NSUB.GT.MXSUB) CALL XABORT('MCCGT: MXSUB OVERFLOW.') + IANGL=KANGL(1) + IF(NSEG.GT.0) THEN + CALL MCGDTV(NDIM,NFI,NREG,NSOU,NSEG,NMU,LMCU,LMXMCU, + 1 NZONA,NRSEG,MCUW,MCUI,WEI2D,SEGLEN,WZMU,SURFD, + 2 CYCLIC,ACFLAG,ZMU,XSIXYZ,CAZ(1,IANGL)) + ENDIF + ENDDO + IF(.NOT.CYCLIC) THEN + CALL XDRSDB(NSOU,VV(NREG+1),SURFD,1) + DO IDIR=1,3 + DO ISOU=1,NSOU + XSIXYZ(ISOU,IDIR)=XSIXYZ(ISOU,IDIR)/SURFD(ISOU) + ENDDO + ENDDO + CALL LCMPUT(IPTRK,'XSI$MCCG',NSOU*3,4,XSIXYZ) + ENDIF + ENDIF +* + DEALLOCATE(XSIXYZ,SURFD) + DEALLOCATE(KANGL,NRSEG,SEGLEN,CAZ,DENSTY) + IF(LPRISM) DEALLOCATE(INDREG,ZZ) +*--- +* CREATE CONNECTION MATRICES IN KM/MCU FORMAT +*--- + LMCU0=0 + IF(ACFLAG) THEN +* KM(i) is the number of non-diagonal element on row i +* MCU gives the column indexes. + ALLOCATE(KM(NFI),MCU(LMXMCU)) + CALL MCGREC(NFI,KM,MCUW,MCUI,MCU,LMCU,LMXMCU,0) + DEALLOCATE(MCUI,MCUW) + NLONG=NFI + IF(CYCLIC) THEN +* if cyclic tracking, only the volume related data are stored + LMCU=0 + DO I=1,NREG + LMCU=LMCU+KM(I) + ENDDO + NLONG=NREG + IF(NSOU.EQ.0) NFI=NREG+1 + ENDIF + ALLOCATE(IM(NLONG+1)) +* construct IM +* containing number of sparse matrix elements in rows before I +* so location of J-th non-zero in row # I is IM(I)+J i.e. +* IM(K+1)=sum_i=1^K KM(i) where K in [1,NLONG] + IM(:)=0 + DO I=1,NLONG + IM(I+1)=IM(I)+KM(I) + ENDDO + IF(LSCR) THEN +*--- +* SCR ACCELERATION : CREATE INDEX FOR THE SURFACES NEIGHBORS +*--- + LPS=IM(NFI+1)-IM(NREG+1) + ALLOCATE(IS(NSOU+1),JS(LPS)) + LPS=0 + DO I=NREG+1,NFI + IS(I-NREG)=LPS + DO J=IM(I)+1,IM(I+1) + IF(MCU(J).GT.0) THEN + LPS=LPS+1 + JS(LPS)=MCU(J) + ENDIF + ENDDO + ENDDO + IS(NSOU+1)=LPS + ENDIF + IF(LACA) THEN +*--- +* ACA ACCELERATION : +*--- + ALLOCATE(IPI(NFI),INVPI(NFI)) + IF(PACA.GE.2) THEN + LMCU0=LMCU + ALLOCATE(LEV(NLONG),LEVPT(NLONG+1),KMROR(NLONG), + 1 MCUROR(LMCU),IMROR(NLONG+1),JU(NLONG),VA(NFI)) + IF(PACA.EQ.3) ALLOCATE(IWORK(NFI),IM0(NFI+1),MCU0(LMCU0)) +* construct IPI permutation : old_index=IPI(new_index) or +* F_new=F_old(IPI) reordering of the unknowns of the +* corrective system for ilu0 preconditioner. + NFIRST=1 + TYPOR1=0 + TYPOR2=0 + CALL RENUM(NLONG,LMCU,NFIRST,IM,MCU,TYPOR1,TYPOR2,NLEV, + 1 LEV,LEVPT,IPI) + IF(CYCLIC) THEN + DO I=NLONG+1,NFI + IPI(I)=I + ENDDO + ENDIF +* reorder everything according to IPI +* construct INVPI permutation : new_index=INVPI(old_index) +* or F_old=F_new(INVPI) + DO I=1,NFI + J=IPI(I) + INVPI(J)=I + ENDDO + DO I=1,NLONG + J=IPI(I) + KMROR(I)=KM(J) + ENDDO + IMROR=0 + DO I=1,NLONG + IMROR(I+1)=IMROR(I)+KMROR(I) + ENDDO + DO I=1,NLONG + J=IPI(I) + IK=IMROR(I) + DO JK=IM(J)+1,IM(J+1) + IK=IK+1 + IF(MCU(JK).GT.0) THEN + MCUROR(IK)=INVPI(MCU(JK)) + ELSE + MCUROR(IK)=MCU(JK) + ENDIF + ENDDO + ENDDO +* sort each line by increasing column index + DO I=1,NLONG + K=IMROR(I)+1 + CALL SORTIN(KMROR(I),MCUROR(K)) + ENDDO + DO I=1,NFI + J=IPI(I) + NZONA(I)=NZON(J) + VA(I)=VV(J) + IF(J.GT.NREG) THEN + IF(ALBEDO(-NZON(J)).EQ.0.0) NZONA(I)=IBCV + ENDIF + ENDDO + JU(:NLONG)=0 + IF(PACA.EQ.3) THEN + IM0(:NLONG+1)=LMCU + IWORK(:NLONG)=0 + ILAST=0 + LMCU0=0 + ENDIF + DO 50 I=1,NLONG +* construct JU (and IM0/MCU0 for optimized storage) +* MCUROR(JU(i):IMROR(i+1)) corresponds to the upper triangular part of line i. +* MCUROR(IMROR(i)+1:JU(i)-1) correspond to the lower triangular part of line i. + DO IH=IMROR(I)+1,IMROR(I+1) + H=MCUROR(IH) + IF(H.GT.0) THEN + IF((H.GT.I).AND.(JU(I).EQ.0)) JU(I)=IH + IF(PACA.EQ.3) IWORK(H)=IH + ENDIF + ENDDO + IF(JU(I).EQ.0) JU(I)=IMROR(I+1)+1 + IF(PACA.EQ.3) THEN + DO IK=IMROR(I)+1,JU(I)-1 + K=MCUROR(IK) + IF(K.GT.0) THEN + DO KJ=JU(K),IMROR(K+1) + J=MCUROR(KJ) + IF(IWORK(J).GT.0) THEN + IPOS=0 + IJEND=MIN(IM0(I+1),LMCU0) + DO IJ=IM0(I)+1,IJEND + IF(MCU0(IJ).EQ.J) THEN + IPOS=IJ + GOTO 40 + ENDIF + ENDDO + 40 CONTINUE + IF(IPOS.EQ.0) THEN + IF(ILAST.NE.I) THEN + IM0(ILAST+1:I)=LMCU0 + ILAST=I + ENDIF + LMCU0=LMCU0+1 + MCU0(LMCU0)=J + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + DO IH=IMROR(I)+1,IMROR(I+1) + H=MCUROR(IH) + IF(H.GT.0) IWORK(H)=0 + ENDDO + ENDIF + 50 CONTINUE + IF(PACA.EQ.3) THEN + IF(LMCU0.EQ.0) THEN + PACA=4 ! SPECIAL CASE WHEN THERE IS NO EXTRA-STORAGE FOR ILU0-ACA + ELSE + IM0(ILAST+1:NLONG+1)=LMCU0 + ENDIF + ENDIF + ELSE + DO I=1,NFI + IPI(I)=I + INVPI(I)=I + ENDDO + ENDIF + ENDIF + ENDIF + IF(CYCLIC.AND.(NSOU.EQ.0)) THEN + NZON(NREG+1)=-1 + NZONA(NREG+1)=-1 + ENDIF + IF(IMPX.GT.3) THEN + CALL PRINIM('MATALB',NZON(1),NFI) + CALL PRINAM('VOLSUR',VV(1),NFI) + IF(ACFLAG) THEN + CALL PRINIM('MATALA',NZONA(1),NFI) + WRITE(IOUT,'(16H MCGREC : LMCU =,I6)') LMCU + CALL PRINIM('KM ',KM(1),NLONG) + CALL PRINIM('MCU ',MCU(1),LMCU) + IF((LACA).AND.(PACA.GE.2)) THEN + CALL PRINIM('IPERM ',INVPI(1),NFI) + CALL PRINIM('KMROR ',KMROR(1),NLONG) + CALL PRINIM('MCUROR',MCUROR(1),LMCU) + CALL PRINIM('JU ',JU(1),NLONG) + IF(PACA.GE.3) THEN + WRITE(IOUT,'(16H MCCGT : LMCU0 =,I6)') LMCU0 + IF(LMCU0.GT.0) THEN + CALL PRINIM('IM0 ',IM0(1),NLONG+1) + CALL PRINIM('MCU0 ',MCU0(1),LMCU0) + ENDIF + ENDIF + ENDIF + IF(LSCR) THEN + CALL PRINIM('IS ',IS(1),NSOU+1) + CALL PRINIM('JS ',JS(1),LPS) + ENDIF + ENDIF + ENDIF +* + CALL LCMPUT(IPTRK,'NZON$MCCG',NFI,1,NZON) + CALL LCMPUT(IPTRK,'MATCOD',NREG,1,NZON) + CALL LCMPUT(IPTRK,'V$MCCG',NFI,2,VV) + CALL LCMPUT(IPTRK,'VOLUME',NREG,2,VV) + IF(ACFLAG) THEN + IF(LACA) THEN + CALL LCMPUT(IPTRK,'NZONA$MCCG',NFI,1,NZONA) + IF(PACA.GE.2) THEN + CALL LCMPUT(IPTRK,'VA$MCCG',NFI,2,VA) + CALL LCMPUT(IPTRK,'KM$MCCG',NLONG,1,KMROR) + CALL LCMPUT(IPTRK,'IM$MCCG',NLONG+1,1,IMROR) + CALL LCMPUT(IPTRK,'MCU$MCCG',LMCU,1,MCUROR) + CALL LCMPUT(IPTRK,'JU$MCCG',NLONG,1,JU) + IF(PACA.EQ.3) THEN + CALL LCMPUT(IPTRK,'IM0$MCCG',NLONG+1,1,IM0) + CALL LCMPUT(IPTRK,'MCU0$MCCG',LMCU0,1,MCU0) + ENDIF + IF(PACA.GE.3) DEALLOCATE(MCU0,IM0,IWORK) + DEALLOCATE(VA,JU,IMROR,MCUROR,KMROR,LEVPT,LEV) + ELSE + CALL LCMPUT(IPTRK,'KM$MCCG',NLONG,1,KM) + CALL LCMPUT(IPTRK,'IM$MCCG',NLONG+1,1,IM) + CALL LCMPUT(IPTRK,'MCU$MCCG',LMCU,1,MCU) + CALL LCMPUT(IPTRK,'VA$MCCG',NLONG,2,VV) + ENDIF + CALL LCMPUT(IPTRK,'INVPI$MCCG',NFI,1,INVPI) + CALL LCMPUT(IPTRK,'PI$MCCG',NLONG,1,IPI) + DEALLOCATE(INVPI,IPI) + ENDIF + IF(LSCR) THEN + CALL LCMPUT(IPTRK,'IS$MCCG',NSOU+1,1,IS) + CALL LCMPUT(IPTRK,'JS$MCCG',LPS,1,JS) + DEALLOCATE(JS,IS) + ENDIF + DEALLOCATE(IM,MCU,KM,NZONA) + ENDIF + DEALLOCATE(NZON,VV) + IF(.NOT.LACA) LMCU=0 + IF(.NOT.LSCR) LPS=0 +*--- +* MODIFY KEYFLX FOR ANISOTROPIC SCATTERING +* CREATE KEYCUR +*--- + IF(NDIM.EQ.1) THEN + NFUNL=NANIS + NMOD=2 + ELSE IF(NDIM.EQ.2) THEN + NFUNL=NANIS*(NANIS+1)/2 + NMOD=4 + ELSE ! NDIM.EQ.3 + NFUNL=NANIS*NANIS + NMOD=8 + ENDIF + DIMKEYF=NREG*NLIN*NFUNL + + IGP(2)=DIMKEYF + TEXT12='MCCG' + CALL LCMPTC(IPTRK,'TRACK-TYPE',12,TEXT12) +* non-cyclic tracking -> MCCG used (else MOCC) + IF(.NOT.CYCLIC) IGP(2)=IGP(2)+IGP(5) + + NUN=IGP(2) + ALLOCATE(KEYFLX(DIMKEYF)) + IF(NLIN.EQ.1) THEN + DO 65 IA=1,NFUNL + DO 60 IR=1,NREG + KEYFLX((IA-1)*NREG+IR)=(IA-1)*NREG+IR + 60 CONTINUE + 65 CONTINUE + ELSE IF(NLIN.EQ.3) THEN + DO 72 IA=1,NFUNL + DO 71 IE=1,3 + DO 70 IR=1,NREG + KEYFLX((IA-1)*3*NREG+(IE-1)*NREG+IR) + 1 =(IA-1)*3*NREG+(IE-1)*NREG+IR + 70 CONTINUE + 71 CONTINUE + 72 CONTINUE + ENDIF + IF(.NOT.CYCLIC) THEN + ALLOCATE(KEYCUR(NSOU)) + IKEY=1 + ICUR=0 + DO I=1,NUN + IF((KEYFLX(IKEY).NE.I).OR.(IKEY.GT.DIMKEYF)) THEN + ICUR=ICUR+1 + IF(ICUR.GT.NSOU) + 1 CALL XABORT('MCCGT: INCORRECT NUMBER OF UNKNOWNS') + KEYCUR(ICUR)=I + ELSE + IKEY=IKEY+1 + ENDIF + ENDDO + CALL LCMPUT(IPTRK,'KEYCUR$MCCG',NSOU,1,KEYCUR) + DEALLOCATE(KEYCUR) + ENDIF + CALL LCMPUT(IPTRK,'KEYFLX$ANIS',DIMKEYF,1,KEYFLX) + CALL LCMPUT(IPTRK,'KEYFLX',NREG,1,KEYFLX(:NREG)) + DEALLOCATE(KEYFLX) +*--- +* GENERATE ALL SIGNS FOR SPHERICAL HARMONICS +*--- + ALLOCATE(ISGNR(NMOD,NFUNL),KEYANI(NFUNL)) + CALL MOCIK3(NANIS-1,NFUNL,NMOD,ISGNR,KEYANI) + DEALLOCATE(ISGNR) +*--- +* GENERATE INDEX FOR PJJ(NU'->NU) STORAGE +* IF 'SOURCE TERM ISOLATION' OPTION IS ON +*--- + IF((STIS.NE.0).OR.(ISCR.GT.0)) THEN + CALL MCGPJJ(IPTRK,IMPX,NDIM,NANIS,NFUNL,NPJJM,KEYANI) + ELSE + NPJJM=1 + ENDIF + DEALLOCATE(KEYANI) +* + IGP(14)=NMU + IGP(16)=NDIM + CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,IGP) +*--- +* GENERATE MCCG-STATE AND REAL-PARAM VECTORS +*--- + IGP(:NSTATE)=0 + IGP(1)=LCACT + IGP(2)=NMU + IGP(3)=KRYL + IGP(4)=IDIFC + IGP(5)=MXSEG + IGP(6)=LMCU + IGP(7)=IAAC + IGP(8)=ISCR + IGP(9)=LPS + IGP(10)=PACA + IGP(11)=ILEXA + IGP(12)=ILEXF + IGP(13)=MAXI + IGP(14)=LTMT + IGP(15)=STIS + IGP(16)=NPJJM + IGP(17)=LMCU0 + IGP(18)=IFORW + IGP(19)=NFUNL + IGP(20)=NLIN + CALL LCMPUT(IPTRK,'MCCG-STATE',NSTATE,1,IGP) + ZREAL(4)=FACSYM + CALL LCMPUT(IPTRK,'REAL-PARAM',4,2,ZREAL) +* + IF(IMPX.GT.1) THEN + CALL LCMGET(IPTRK,'MCCG-STATE',IGP) + WRITE(IOUT,120) (IGP(I),I=1,11) + WRITE(IOUT,130) (IGP(I),I=12,20) + CALL LCMGET(IPTRK,'REAL-PARAM',ZREAL) + WRITE(IOUT,140) (ZREAL(I),I=1,4) + ENDIF +*---- +* PROCESS DOUBLE HETEROGENEITY (BIHET) DATA (IF AVAILABLE) +*---- + IF(LBIHET) THEN + CALL LCMGET(IPTRK,'EXCELTRACKOP',EXTKOP) + CALL XDRTBH(IPGEO,IPTRK,IQUA10,IBIHET,IMPX,EXTKOP(39)) + ENDIF +* + IF(IMPX.GT.2) CALL LCMLIB(IPTRK) + RETURN +* + 100 FORMAT(/ + 1 44H MM MM CCCCC CCCCC GGGGG TTTTTTTT/ + 2 44H MMM MMM CCCCCCC CCCCCCC GGGGGGG TTTTTTTT/ + 4 41H MMMM MMMM CC CC CC CC GG TT/ + 5 41H MM MM MM CC CC GG GGG TT/ + 6 41H MM MM CC CC GG GGG TT/ + 7 41H MM MM CC CC CC CC GG GG TT/ + 8 41H MM MM CCCCCCC CCCCCCC GGGGGGG TT/ + 9 41H MM MM CCCCC CCCCC GGGGG TT/ + 1 17H TRACKING TITLE: ,A72/) + 120 FORMAT(/ + 1 55H STATE VECTOR RELATED TO THE METHOD OF CHARACTERISTICS:/ + 2 7H LCACT ,I9,29H (TYPE OF POLAR QUADRATURE)/ + 1 7H NMU ,I9,48H (ORDER OF THE POLAR QUADRATURE IN 2D/1 IN 3D)/ + 5 7H KRYL ,I9,48H (<0 Bi-CGSTAB SCHEME USED /0=KRYLOV SCHEMES N, + 6 30HOT USED/ >0=GMRES SCHEME USED)/ + 7 7H IDIFC ,I9,39H (0=TRANSPORT/1=CDD SOLUTION OF FLUX)/ + 8 7H NMAX ,I9,42H (MAXIMUM NUMBER OF ELEMENTS IN A TRACK)/ + 9 7H LMCU ,I9,42H (DIMENSION OF MCU FOR ACA ACCELERATION)/ + 3 7H IAAC ,I9,48H (0=NO ACCELERATION/1=CDD ACCELERATION OF INNE, + 4 13HR ITERATIONS)/ + 2 7H SCR ,I9,48H (0=NO ACCELERATION/1=SCR ACCELERATION OF INNE, + 3 13HR ITERATIONS)/ + 4 7H LPS ,I9,42H (DIMENSION OF PSJ FOR SCR ACCELERATION)/ + 5 7H PACA ,I9,48H (PRECONDITIONER FOR SOLVING THE ACA SYSTEM WI, + 6 38HTH BICGSTAB (>2=ILU0, 1=DIAG, 0=NONE))/ + 7 7H LEXA ,I9,48H (1=FORCE EXACT EXPONENTIAL USAGE IN PRECONDIT, + 8 18HIONER CALCULATION)) + 130 FORMAT( + 1 7H LEXF ,I9,48H (1=FORCE EXACT EXPONENTIAL USAGE IN FLUX CALC, + 2 8HULATION)/ + 3 7H MAXI ,I9,39H (MAXIMUM NUMBER OF INNER ITERATIONS)/ + 4 7H LTMT ,I9,48H (TO USE TRACK MERGING FOR ACA SYSTEM CALCULAT, + 5 4HION)/ + 6 7H STIS ,I9,48H (1=SOURCE TERM ISOLATION FOR FLUX INTEGRATION, + 7 1H)/ + 8 7H NPJJM ,I9,48H (NUMBER OF PJJ MODES TO STORE FOR STIS OPTION, + 9 1H)/ + 1 7H LMCU0 ,I9,48H (DIMENSION OF MCU0 FOR ILU0-ACA ACCELERATION)/ + 2 7H IFORW ,I9,40H (0/1=DIRECT/ADJOINT FLUX CALCULATION)/ + 3 7H NFUNL ,I9,45H (NUMBER OF SPHERICAL HARMONICS COMPONENTS)/ + 4 7H NLIN ,I9,43H (1/3=SC OR DD0 SCHEME/LDC OR DD1 SCHEME)) + 140 FORMAT(/ + 1 12H REAL PARAM:/ + 2 7H EPSI ,1P,E12.4,33H (TOLERANCE ON INNER ITERATION)/ + 3 7H HDD ,1P,E12.4,41H (0.0=STEP CHARACTERISTICS SOLUTION/>0., + 4 32H0=DIAMOND DIFFERENCING SOLUTION)/ + 5 7H DELU ,1P,E12.4,42H (TRACK SPACING FOR 3D PRISMATIC GEOMETR, + 6 2HY)/ + 7 7H FACSYM,1P,E12.4,42H (TRACKING SYMMETRY FACTOR FOR MAXIMUM T, + 8 38HRACK LENGTH FOR 3D PRISMATIC GEOMETRY)/) + END diff --git a/Dragon/src/MCGABG.f b/Dragon/src/MCGABG.f new file mode 100644 index 0000000..c724d04 --- /dev/null +++ b/Dragon/src/MCGABG.f @@ -0,0 +1,210 @@ +*DECK MCGABG + SUBROUTINE MCGABG(IPRINT,LFORW,PACA,N,LC,EPSM,MAXM,IM,MCU,JU, + 1 DIAGF,CF,ILUDF,ILUCF,RHS,F,FAC,LC0,IM0,MCU0) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solve the ACA corrective system using BICGSTAB. +* +*Reference: (p382) +* MEURANT, G. 1999. "Computer Solution of Large Linear Systems". +* Studies in Mathematics and its Applications vol.28. North Holland. +* 776p. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IPRINT print parameter. +* LFORW flag set to .false. to transpose the coefficient matrix. +* PACA type of preconditioner to solve the ACA corrective system. +* N dimension of the corrective system. +* LC dimension of profiled matrices MCU and CQ. +* IM connection matrix. +* MCU connection matrix. +* DIAGF diagonal elements of the matrix to inverse. +* CF non-diagonal elements of the matrix to inverse. +* RHS right hand-side of the corrective system (already +* preconditioned). +* FAC scaling factor for precision. +* LC0 used in ILU0-ACA acceleration. +* IM0 used in ILU0-ACA acceleration. +* MCU0 used in ILU0-ACA acceleration. +* EPSM stopping criterion. +* MAXM maximum number of iterations allowed. +* +*Parameters: output +* F corrective fluxes and currents. +* +*Parameters: scratch +* JU undefined. +* ILUDF undefined. +* ILUCF undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IPRINT,PACA,N,LC,IM(N+1),MCU(LC),JU(N),MAXM,LC0,IM0(*), + 1 MCU0(*) + REAL DIAGF(N),CF(LC),ILUDF(N),ILUCF(LC),EPSM,FAC + DOUBLE PRECISION RHS(N),F(N) + LOGICAL LFORW +*---- +* LOCAL VARIABLE +*---- + REAL EPSMAX,EPSINF,EPS2 + PARAMETER (EPSMAX=1E-7) + INTEGER I,J,ITER + DOUBLE PRECISION R,BI,WI,RT1 + DOUBLE PRECISION DDOT,AUX(2),EPS,FNORM,RHSN,ASIN,ASIN2,SIN,CN,SQ2 + LOGICAL DEBUG + INTRINSIC SQRT,ABS,SIGN + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: PI,RI,SI,ROT,API, + 1 ASI +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(PI(N),RI(N),SI(N),ROT(N),API(N),ASI(N)) +* + SQ2=1.D0/SQRT(2.D0) +*---- + DEBUG=.FALSE. + EPSINF=EPSMAX*FAC + ITER=0 +* + RHSN=0.0 + DO I=1,N + RHSN=MAX(RHSN,ABS(RHS(I))) + ENDDO + IF(RHSN.LT.EPSINF) THEN + DO I=1,N + F(I)=0.0 + ENDDO + IF(DEBUG) WRITE(6,200) RHSN,EPSINF + GO TO 40 + ENDIF + EPS2=EPSMAX*REAL(RHSN) + EPS2=EPS2*EPS2 +*--- +* initial corrective flux is set to rhs +* calculate (P times (D times RHS)) -> RI + CALL MCGPRA(LFORW,3,PACA,.FALSE.,N,LC,IM,MCU,JU,DIAGF,CF,ILUDF, + 1 ILUCF,DIAGF,RHS(1),RI,LC0,IM0,MCU0,CF) + DO I=1,N + F(I)=RHS(I) + RI(I)=RHS(I)-RI(I) + PI(I)=RI(I) + ROT(I)=RI(I) + ENDDO + R=DDOT(N,RI,1,RI,1) + FNORM=DDOT(N,F,1,F,1) + EPS=SQRT(R/FNORM) + IF(DEBUG) WRITE(6,100) ITER,EPS,EPSM + IF(EPS.LE.EPSM) THEN + IF(IPRINT.GT.2) WRITE(6,100) ITER,EPS,EPSM + GO TO 40 + ENDIF + AUX(1)=R +* + DO WHILE (ITER.LT.MAXM) +* BiCGSTAB iterations + ITER=ITER+1 +* calculate (P times (D times PI)) -> API + CALL MCGPRA(LFORW,3,PACA,.FALSE.,N,LC,IM,MCU,JU,DIAGF,CF, + 1 ILUDF,ILUCF,DIAGF,PI(1),API,LC0,IM0,MCU0,CF) +* + AUX(2)=AUX(1)/DDOT(N,API,1,ROT,1) + DO J=1,N + SI(J)=RI(J)-AUX(2)*API(J) + ENDDO + ITER=ITER+1 +* calculate (P times (D times SI)) -> ASI + CALL MCGPRA(LFORW,3,PACA,.FALSE.,N,LC,IM,MCU,JU,DIAGF,CF, + 1 ILUDF,ILUCF,DIAGF,SI(1),ASI,LC0,IM0,MCU0,CF) +* +!!!! ASIN=DDOT(N,ASI,1,ASI,1) +!!!! ASIN2=DDOT(N,ASI,1,SI,1) +!!!! IF(ASIN.GT.EPSMAX*ASIN2) THEN +!!!! WI=ASIN2/ASIN +!!!! ELSE +!!!!* assuming lucky breakdown +!!!! WI=1.0 +!!!! ENDIF +* Modification proposed by Sleijpen and Van der Vorst (Numerical Algorithms, 10:203-223, 1995) + ASIN2=DDOT(N,ASI,1,SI,1) + ASIN=SQRT(DDOT(N,ASI,1,ASI,1)) + SIN=SQRT(DDOT(N,SI,1,SI,1)) + CN=ASIN*SIN + IF(CN.GT.EPSMAX*ASIN2) THEN + CN=ASIN2/CN + WI=MAX(ABS(CN),SQ2)*SIN/ASIN + WI=SIGN(WI,CN) + ELSE +* assuming lucky breakdown + WI=1.0 + ENDIF +* calculate new iterate + DO J=1,N + F(J)=F(J)+AUX(2)*PI(J)+WI*SI(J) + RI(J)=SI(J)-WI*ASI(J) + ENDDO + R=DDOT(N,RI,1,RI,1) + FNORM=DDOT(N,F,1,F,1) + IF(FNORM.LT.EPS2) GOTO 30 + EPS=SQRT(R/FNORM) + IF(DEBUG) WRITE(6,100) ITER,EPS,EPSM + IF(EPS.LE.EPSM) GO TO 20 + RT1=AUX(1) + AUX(1)=DDOT(N,RI,1,ROT,1) + BI=AUX(1)/RT1*AUX(2)/WI + DO J=1,N + PI(J)=RI(J)+BI*(PI(J)-WI*API(J)) + ENDDO + ENDDO + 20 CONTINUE +* determine final residual norm + ITER=ITER+1 +* calculate (P times (D times F)) -> RI + CALL MCGPRA(LFORW,3,PACA,.FALSE.,N,LC,IM,MCU,JU,DIAGF,CF,ILUDF, + 1 ILUCF,DIAGF,F(1),RI,LC0,IM0,MCU0,CF) + DO I=1,N + RI(I)=RHS(I)-RI(I) + ENDDO +* + R=DDOT(N,RI,1,RI,1) + FNORM=DDOT(N,F,1,F,1) + IF(FNORM.LT.EPS2) GOTO 30 + EPS=SQRT(R/FNORM) + IF(IPRINT.GT.2) WRITE(6,100) ITER,EPS,EPSM +!!!! IF(EPS.GT.EPSM) THEN +!!!! DO I=1,N +!!!! PI(I)=RI(I) +!!!! ROT(I)=RI(I) +!!!! ENDDO +!!!! GO TO 10 +!!!! ENDIF + GO TO 40 +* + 30 IF(DEBUG) WRITE(6,300) ITER,FNORM,EPS2 + F(:N)=0.0 +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 40 DEALLOCATE(ASI,API,ROT,SI,RI,PI) + RETURN +* + 100 FORMAT(12X,14H MCGABG: ITER=,I3,5H EPS=,E9.2,5H TAR=,E9.2) + 200 FORMAT(12X,27H MCGABG: RHS INFINITE NORM=,E9.2,5H LIM=,E9.2/ + 1 12X,33H -> ACA CORRECTION IS SET TO ZERO) + 300 FORMAT(12X,14H MCGABG: ITER=,I3,7H FNORM=,E9.2,5H LIM=,E9.2) + END diff --git a/Dragon/src/MCGABGR.f b/Dragon/src/MCGABGR.f new file mode 100644 index 0000000..ea36bd4 --- /dev/null +++ b/Dragon/src/MCGABGR.f @@ -0,0 +1,294 @@ +*DECK MCGABGR + SUBROUTINE MCGABGR(IPRINT,LFORW,PACA,N,NG,NFIRST,NGEFF,M,LC,NGIND, + 1 NGINDV,NCONV,KPSYS,JPMACR,NZON,IPERM,IM,MCU,JU, + 2 EPSM,MAXM,RHS,F,FAC,LC0,IM0,MCU0) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solve the ACA corrective system (in a rebalancing form) using +* BICGSTAB. +* +*Reference: (p382) +* MEURANT, G. 1999. "Computer Solution of Large Linear Systems". +* Studies in Mathematics and its Applications vol.28. North Holland. +* 776p. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IPRINT print parameter. +* LFORW flag set to .false. to transpose the coefficient matrix. +* PACA type of preconditioner to solve the ACA corrective system. +* N number of unknowns per group. +* NG total number of groups. +* NFIRST first group to proceed. +* NGEFF number of unconverged groups. +* M number of material mixtures. +* LC dimension of profiled matrices MCU and CQ. +* NGIND index of the groups to process. +* NGINDV index to pass from "NGEFF format" to "NG format". +* NCONV logical array of convergence status for each group (.TRUE.: +* not converged). +* KPSYS pointer array for each group properties. +* JPMACR pointer to the macrolib LCM object ('GROUP' directory). +* NZON index-number of the mixture type assigned to each volume. +* IPERM permutation array for ACA. +* IM connection matrix. +* MCU connection matrix. +* JU used for ilu0 preconditioner. +* EPSM stopping criterion. +* MAXM maximum number of iterations allowed. +* RHS right hand-side of the corrective system (already +* preconditioned). +* FAC scaling factor for precision. +* LC0 used in ILU0-ACA acceleration. +* IM0 used in ILU0-ACA acceleration. +* MCU0 used in ILU0-ACA acceleration. +* +*Parameters: output +* F corrective fluxes and currents. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IPRINT,PACA,N,NG,NFIRST,NGEFF,M,LC,NGIND(NGEFF), + 1 NGINDV(NG),KPSYS(NGEFF),JPMACR,NZON(N),IPERM(N),IM(N+1),MCU(LC), + 2 JU(N),MAXM,LC0,IM0(*),MCU0(*) + REAL EPSM,FAC + DOUBLE PRECISION RHS(N,NGEFF),F(N,NGEFF) + LOGICAL LFORW,NCONV(NGEFF) +*---- +* LOCAL VARIABLE +*---- + REAL EPSMAX,EPSINF,EPS2 + PARAMETER (EPSMAX=1E-7) + INTEGER I,II,J,ITER + DOUBLE PRECISION R,BI,WI,RT1,ASIN,ASIN2,SQ2 + DOUBLE PRECISION DDOT,AUX(2),EPS,FNORM,RHSN + LOGICAL DEBUG + INTRINSIC SQRT,ABS + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: PI,RI,SI,ROT,API, + 1 ASI +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(PI(N,NGEFF),RI(N,NGEFF),SI(N,NGEFF),ROT(N,NGEFF), + 1 API(N,NGEFF),ASI(N,NGEFF)) +* + SQ2=1.D0/SQRT(2.D0) +*--- + DEBUG=.FALSE. + EPSINF=EPSMAX*FAC + ITER=0 +* + RHSN=0.0 + DO II=NFIRST,NGEFF + IF (NCONV(II)) THEN + DO I=1,N + RHSN=MAX(RHSN,ABS(RHS(I,II))) + ENDDO + ENDIF + ENDDO + IF (RHSN.LT.EPSINF) THEN + DO II=NFIRST,NGEFF + IF (NCONV(II)) THEN + DO I=1,N + F(I,II)=0.0D0 + ENDDO + ENDIF + ENDDO + IF (DEBUG) WRITE(6,200) RHSN,EPSINF + GO TO 40 + ENDIF + EPS2=EPSMAX*REAL(RHSN) + EPS2=EPS2*EPS2 +*--- +* initial corrective flux is set to rhs +* calculate (P times (D times RHS)) -> RI + CALL MCGACA(LFORW,PACA,N,NG,NFIRST,NGEFF,M,LC,NGIND,NGINDV,NCONV, + 1 KPSYS,JPMACR,NZON,IPERM,IM,MCU,JU,RHS(1,1),LC0,IM0,MCU0,RI) + R=0.0 + FNORM=0.0 + DO II=NFIRST,NGEFF + IF (NCONV(II)) THEN + DO I=1,N + F(I,II)=RHS(I,II) + RI(I,II)=RHS(I,II)-RI(I,II) + PI(I,II)=RI(I,II) + ROT(I,II)=RI(I,II) + ENDDO + R=R+DDOT(N,RI(1,II),1,RI(1,II),1) + FNORM=FNORM+DDOT(N,F(1,II),1,F(1,II),1) + ENDIF + ENDDO + EPS=SQRT(R/FNORM) + IF (DEBUG) WRITE(6,100) ITER,EPS,EPSM + IF (EPS.LE.EPSM) GO TO 40 + AUX(1)=R !!DDOT(N,RI,1,ROT,1) +* + DO WHILE (ITER.LT.MAXM) +* BiCGSTAB iterations + ITER=ITER+1 +* calculate (P times (D times PI)) -> API + CALL MCGACA(LFORW,PACA,N,NG,NFIRST,NGEFF,M,LC,NGIND,NGINDV, + 1 NCONV,KPSYS,JPMACR,NZON,IPERM,IM,MCU,JU,PI(1,1),LC0,IM0, + 2 MCU0,API) +* + AUX(2)=0.0 + DO II=NFIRST,NGEFF + IF (NCONV(II)) THEN + AUX(2)=AUX(2)+DDOT(N,API(1,II),1,ROT(1,II),1) + ENDIF + ENDDO + AUX(2)=AUX(1)/AUX(2) + DO II=NFIRST,NGEFF + IF (NCONV(II)) THEN + DO J=1,N + SI(J,II)=RI(J,II)-AUX(2)*API(J,II) + ENDDO + ENDIF + ENDDO + ITER=ITER+1 +* calculate (P times (D times SI)) -> ASI + CALL MCGACA(LFORW,PACA,N,NG,NFIRST,NGEFF,M,LC,NGIND,NGINDV, + 1 NCONV,KPSYS,JPMACR,NZON,IPERM,IM,MCU,JU,SI(1,1),LC0,IM0, + 2 MCU0,ASI) +* + ASIN2=0.0 + ASIN=0.0 + DO II=NFIRST,NGEFF + IF (NCONV(II)) THEN + ASIN2=ASIN2+DDOT(N,ASI(1,II),1,SI(1,II),1) + ASIN=ASIN+DDOT(N,ASI(1,II),1,ASI(1,II),1) + ENDIF + ENDDO + IF (ASIN.GT.EPSMAX*ASIN2) THEN + WI=ASIN2/ASIN + ELSE +* assuming lucky breakdown + WI=1.0 + ENDIF +!!!!* Modification proposed by Sleijpen and Van der Vorst +!!!!* (Numerical Algorithms, 10:203-223, 1995) +!!!! ASIN2=0.0 +!!!! ASIN=0.0 +!!!! SIN=0.0 +!!!! DO II=NFIRST,NGEFF +!!!! IF (NCONV(II)) THEN +!!!! ASIN2=ASIN2+DDOT(N,ASI(1,II),1,SI(1,II),1) +!!!! ASIN=ASIN+DDOT(N,ASI(1,II),1,ASI(1,II),1) +!!!! SIN=SIN+DDOT(N,SI(1,II),1,SI(1,II),1) +!!!! ENDIF +!!!! ENDDO +!!!! ASIN=SQRT(ASIN) +!!!! SIN=SQRT(SIN) +!!!! CN=ASIN*SIN +!!!! IF (CN.GT.EPSMAX*ASIN2) THEN +!!!! CN=ASIN2/CN +!!!! WI=MAX(ABS(CN),SQ2)*SIN/ASIN +!!!! WI=SIGN(WI,CN) +!!!! ELSE +!!!!* assuming lucky breakdown +!!!! WI=1.0 +!!!! ENDIF +* calculate new iterate + R=0.0 + FNORM=0.0 + DO II=NFIRST,NGEFF + IF (NCONV(II)) THEN + DO J=1,N + F(J,II)=F(J,II)+AUX(2)*PI(J,II)+WI*SI(J,II) + RI(J,II)=SI(J,II)-WI*ASI(J,II) + ENDDO + R=R+DDOT(N,RI(1,II),1,RI(1,II),1) + FNORM=FNORM+DDOT(N,F(1,II),1,F(1,II),1) + ENDIF + ENDDO + IF (FNORM.LT.EPS2) GOTO 30 + EPS=SQRT(R/FNORM) + IF (DEBUG) WRITE(6,100) ITER,EPS,EPSM + IF (EPS.LE.EPSM) GO TO 20 + RT1=AUX(1) + AUX(1)=0.0 + DO II=NFIRST,NGEFF + IF (NCONV(II)) THEN + AUX(1)=AUX(1)+DDOT(N,RI(1,II),1,ROT(1,II),1) + ENDIF + ENDDO + BI=AUX(1)/RT1*AUX(2)/WI + DO II=NFIRST,NGEFF + IF (NCONV(II)) THEN + DO J=1,N + PI(J,II)=RI(J,II)+BI*(PI(J,II)-WI*API(J,II)) + ENDDO + ENDIF + ENDDO + ENDDO + 20 CONTINUE +* determine final residual norm + ITER=ITER+1 +* calculate (P times (D times F)) -> RI + CALL MCGACA(LFORW,PACA,N,NG,NFIRST,NGEFF,M,LC,NGIND,NGINDV,NCONV, + 1 KPSYS,JPMACR,NZON,IPERM,IM,MCU,JU,F(1,1),LC0,IM0,MCU0,RI) +* + R=0.0 + FNORM=0.0 + DO II=NFIRST,NGEFF + IF (NCONV(II)) THEN + DO I=1,N + RI(I,II)=RHS(I,II)-RI(I,II) + ENDDO + R=R+DDOT(N,RI(1,II),1,RI(1,II),1) + FNORM=FNORM+DDOT(N,F(1,II),1,F(1,II),1) + ENDIF + ENDDO + IF (FNORM.LT.EPS2) GOTO 30 + EPS=SQRT(R/FNORM) + IF (IPRINT.GT.0) WRITE(6,400) EPS,ITER +!!!! R=0.0 +!!!! FNORM=0.0 +!!!! EPS=0.0 +!!!! DO II=NFIRST,NGEFF +!!!! IF (NCONV(II)) THEN +!!!! DO I=1,N +!!!! R=MAX(R,ABS(RI(I,II))) +!!!! FNORM=MAX(FNORM,ABS(F(I,II))) +!!!! ENDDO +!!!! EPS=MAX(EPS,R/FNORM) +!!!! ENDIF +!!!! ENDDO +!!!! WRITE(*,*) ' PRC=',EPS + GO TO 40 +* + 30 IF (DEBUG) WRITE(6,300) ITER,FNORM,EPS2 + DO II=NFIRST,NGEFF + IF (NCONV(II)) THEN + DO I=1,N + F(I,II)=0.0 + ENDDO + ENDIF + ENDDO +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 40 DEALLOCATE(ASI,API,ROT,SI,RI,PI) + RETURN +* + 100 FORMAT(9X,14H MCGABGR:ITER=,I3,5H EPS=,E9.2,5H TAR=,E9.2) + 200 FORMAT(9X,27H MCGABGR:RHS INFINITE NORM=,E9.2,5H LIM=,E9.2/ + 1 9X,33H -> ACA CORRECTION IS SET TO ZERO) + 300 FORMAT(9X,14H MCGABGR:ITER=,I3,7H FNORM=,E9.2,5H LIM=,E9.2) + 400 FORMAT(10X,48HACA: UP-SCATTE. GROUPS: MULTIGROUP BICGSTAB: PRC:, + 1 E9.2,2H (,I4,12H ITERATIONS)) + END diff --git a/Dragon/src/MCGACA.f b/Dragon/src/MCGACA.f new file mode 100644 index 0000000..a69b169 --- /dev/null +++ b/Dragon/src/MCGACA.f @@ -0,0 +1,149 @@ +*DECK MCGACA + SUBROUTINE MCGACA(LFORW,PACA,N,NG,NFIRST,NGEFF,M,LC,NGIND,NGINDV, + 1 NCONV,KPSYS,JPMACR,NZON,IPERM,IM,MCU,JU,XIN, + 2 LC0,IM0,MCU0,XOUT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the product of the left-hand side ACA matrix in its multigroup +* form with a vector and apply group per group left preconditioner. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* LFORW flag set to .false. to transpose the coefficient matrix. +* PACA type of preconditioner to solve the ACA corrective system. +* N number of unknowns per group. +* NG total number of groups. +* NFIRST first group to proceed. +* NGEFF number of unconverged groups. +* M number of material mixtures. +* LC dimension of profiled matrices MCU and CQ. +* NGIND index of the groups to process. +* NGINDV index to pass from "NGEFF format" to "NG format". +* NCONV logical array of convergence status for each group (.TRUE. +* not converged). +* KPSYS pointer array for each group properties. +* JPMACR pointer to the macrolib LCM object ('GROUP' directory). +* NZON index-number of the mixture type assigned to each volume. +* IPERM permutation array for ACA. +* IM connection matrix. +* MCU connection matrix. +* JU used for ilu0 preconditioner. +* XIN undefined. +* LC0 used in ILU0-ACA acceleration. +* IM0 used in ILU0-ACA acceleration. +* MCU0 used in ILU0-ACA acceleration. +* +*Parameters: output +* XOUT product. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) KPSYS(NGEFF),JPMACR + INTEGER PACA,N,NFIRST,NGEFF,NG,M,LC,NGIND(NGEFF),NGINDV(NG), + 1 NZON(N),IPERM(N),IM(N+1),MCU(LC),JU(N),LC0,IM0(*),MCU0(*) + DOUBLE PRECISION XIN(N,NGEFF),XOUT(N,NGEFF) + LOGICAL LFORW,NCONV(NGEFF) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPSYS,KPMACR + INTEGER I,J,II,IG,JG,JJ,JND,IBM + REAL, TARGET, SAVE, DIMENSION(1) :: DUMMY +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NJJ,IJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) :: XSCAT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: TEMP +* + TYPE(C_PTR) DIAGF_PTR,CF_PTR,LUDF_PTR,LUCF_PTR,DIAGQ_PTR,CQ_PTR + REAL, POINTER, DIMENSION(:) :: DIAGF,CF,LUDF,LUCF,DIAGQ,CQ +*---- +* INITIALIZE POINTERS +*---- + LUDF=>DUMMY + LUCF=>DUMMY +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NJJ(0:M),IJJ(0:M),IPOS(0:M),XSCAT(0:M*NG),TEMP(N)) +* + DO II=NFIRST,NGEFF + IF(NCONV(II)) THEN +* compute temp=sum_{g' ne g} Sigma_s^{g<-g'} XIN^{g'} + IG=NGIND(II) + JPSYS=KPSYS(II) + CALL LCMGPD(JPSYS,'DIAGF$MCCG',DIAGF_PTR) + CALL LCMGPD(JPSYS,'CF$MCCG',CF_PTR) + CALL C_F_POINTER(DIAGF_PTR,DIAGF,(/ N /)) + CALL C_F_POINTER(CF_PTR,CF,(/ LC /)) + IF(PACA.GE.2) THEN + CALL LCMGPD(JPSYS,'ILUDF$MCCG',LUDF_PTR) + CALL C_F_POINTER(LUDF_PTR,LUDF,(/ N /)) + IF(PACA.LT.4) THEN + CALL LCMGPD(JPSYS,'ILUCF$MCCG',LUCF_PTR) + CALL C_F_POINTER(LUCF_PTR,LUCF,(/ LC /)) + ENDIF + ENDIF + KPMACR=LCMGIL(JPMACR,IG) + CALL LCMGPD(JPSYS,'DIAGQ$MCCG',DIAGQ_PTR) + CALL LCMGPD(JPSYS,'CQ$MCCG',CQ_PTR) + CALL C_F_POINTER(DIAGQ_PTR,DIAGQ,(/ N /)) + CALL C_F_POINTER(CQ_PTR,CQ,(/ LC /)) + CALL LCMGET(KPMACR,'NJJS00',NJJ(1)) + CALL LCMGET(KPMACR,'IJJS00',IJJ(1)) + CALL LCMGET(KPMACR,'IPOS00',IPOS(1)) + CALL LCMGET(KPMACR,'SCAT00',XSCAT(1)) + DO I=1,N + TEMP(I)=0.0D0 + J=IPERM(I) + IBM=NZON(J) + IF(IBM.GT.0) THEN + JG=IJJ(IBM) + DO 10 JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + JJ=NGINDV(JG) + IF(JJ.GE.NFIRST) THEN + TEMP(I)=TEMP(I)+XSCAT(IPOS(IBM)+JND-1)*XIN(I,JJ) + ENDIF + ENDIF + JG=JG-1 + 10 CONTINUE + ENDIF + ENDDO +* compute E^{g}*temp + CALL MCGPRA(LFORW,1,PACA,.FALSE.,N,LC,IM,MCU,JU,DIAGQ,CQ, + 1 LUDF,LUCF,DIAGF,TEMP(1),XOUT(1,II),LC0,IM0,MCU0,CF) +* compute D^{g}*XIN^{g} + CALL MCGPRA(LFORW,1,PACA,.FALSE.,N,LC,IM,MCU,JU,DIAGF,CF, + 1 LUDF,LUCF,DIAGF,XIN(1,II),TEMP(1),LC0,IM0,MCU0,CF) +* temp=D^{g}*XIN^{g}-E^{g}*sum_{g' ne g} Sigma_s^{g<-g'} XIN^{g'} + DO I=1,N + TEMP(I)=TEMP(I)-XOUT(I,II) + ENDDO +* apply single-group preconditioner XOUT^{g}=P^{g}*temp + CALL MCGPRA(LFORW,2,PACA,.TRUE.,N,LC,IM,MCU,JU,DIAGF,CF, + 1 LUDF,LUCF,DIAGF,XOUT(1,II),TEMP(1),LC0,IM0,MCU0,CF) + ENDIF + ENDDO +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(TEMP,XSCAT,IPOS,IJJ,NJJ) + RETURN + END diff --git a/Dragon/src/MCGASM.f b/Dragon/src/MCGASM.f new file mode 100644 index 0000000..d58660d --- /dev/null +++ b/Dragon/src/MCGASM.f @@ -0,0 +1,675 @@ +*DECK MCGASM + SUBROUTINE MCGASM(SUBPJJ,SUBDS2,SUBDSP,SUBDSC,IPTRK,KPSYS,IPRINT, + 1 IFTRAK,NANI,NGEFF,NFI,NREG,NLONG,M,NMU,NANGL, + 2 N2MAX,LC,NDIM,NGIND,CYCLIC,ISCR,CAZ0,CAZ1,CAZ2, + 3 CPO,LC0,PACA,LPS,LTMT,NPJJM,LACA,LPJJ,LPJJAN, + 4 SIGAL,LPRISM,N2REG,N2SOU,NZP,DELU,FACSYM,ISTRM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Preconditioning matrices calculation based on the Algebraic Collapsing +* Acceleration developed by I. R. Suslov and R. Le Tellier +* or Self-Collision Probabilities acceleration developed by G.J. Wu +* and R. Roy. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): I. Suslov and R. Le Tellier +* +*Parameters: input/output +* SUBPJJ PJJ calculation subroutine. +* SUBDS2 ACA coefficients summation subroutine. +* SUBDSP ACA coefficients position subroutine. +* SUBDSC ACA coefficients calculation subroutine. +* IPTRK pointer to the tracking (L_TRACK signature). +* KPSYS pointer array for each group properties. +* IPRINT print parameter (equal to zero for no print). +* IFTRAK tracking file unit number if IOFSET=0. +* NANI number of Legendre orders. +* NGEFF number of groups to process. +* NFI total number of volumes and surfaces for which specific values +* of the neutron flux and reactions rates are required. +* NREG number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* NLONG order of the corrective system. +* M number of material mixtures. +* NMU order of the polar quadrature in 2D / 1 in 3D. +* NANGL number of tracking angles in the plane. +* N2MAX maximum number of elements in a track. +* LC dimension of vector MCU. +* NDIM number of dimensions for the geometry. +* NGIND index of the groups to process. +* CYCLIC flag set to .true. for cyclic tracking. +* ISCR SCR preconditionning flag. +* CAZ0 cosines of the tracking polar angles in 3D. +* CAZ1 first cosines of the different tracking azimuthal angles. +* CAZ2 second cosines of the different tracking azimuthal angles. +* CPO cosines of the different tracking polar angles in 2D. +* PACA type of preconditioner to solve the ACA corrective system. +* LC0 used in ILU0-ACA acceleration. +* LPS dimension of JS. +* LTMT tracking merging flag. +* NPJJM number of pjj modes to store for STIS option. +* LACA ACA flag. +* LPJJ PJJ flag. +* LPJJAN anisotropic PJJ flag. +* SIGAL albedos and total cross sections array. +* LPRISM 3D prismatic extended tracking flag. +* N2REG number of regions in the 2D tracking if LPRISM. +* N2SOU number of external surfaces in the 2D tracking if LPRISM. +* NZP number of z-plans if LPRISM. +* DELU input track spacing for 3D track reconstruction if LPRISM. +* FACSYM tracking symmetry factor for maximum track length if LPRISM. +* ISTRM type of streaming effect: +* =1 no streaming effect; +* =2 isotropic streaming effect; +* =3 anisotropic streaming effect. +* +*Reference: +* Igor R. Suslov, "An Algebraic Collapsing Acceleration in Long +* Characteristics Transport Theory" Proc. of 11-th Symposium of +* AER, 178/9-188, Csopak, September 2001. +* \\\\ +* Igor R. Suslov, "Solution of Transport Equation in 2- and 3- +* dimensional Irregular Geometry by the Method of Characteristics" +* Int. Conf. Mathematical. Methods and Supercomputing in Nuclear +* Applications, Karlsruhe, 1994. +* \\\\ +* G.J. Wu and R. Roy, "Acceleration Techniques for Trajectory-based +* Deterministic 3D Transport Solvers", +* Ann. Nucl. Energy, 30, 567-583 (2003). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,KPSYS(NGEFF) + INTEGER IPRINT,IFTRAK,NGEFF,NFI,NREG,NLONG,M,NMU,NANGL,N2MAX,LC, + 1 NDIM,NGIND(NGEFF),LC0,PACA,LPS,NPJJM,N2REG,N2SOU,NZP,ISTRM + REAL CPO(NMU),SIGAL(-6:M,NGEFF),DELU,FACSYM + DOUBLE PRECISION CAZ0(NANGL),CAZ1(NANGL),CAZ2(NANGL) + LOGICAL LTMT,LACA,LPJJ,LPJJAN,LPRISM,LFORC,CYCLIC + EXTERNAL SUBPJJ,SUBDS2,SUBDSP,SUBDSC +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPSYS + INTEGER NCODE(6),SSYM + REAL T1,T2,T3,XMUANG(1) + DOUBLE PRECISION WEIGHT,WEIGHT0 + CHARACTER TEXT4*4 + INTEGER, TARGET, SAVE, DIMENSION(1) :: IDUMMY + INTEGER, TARGET, SAVE, DIMENSION(1,1) :: I2DUMMY + REAL, TARGET, SAVE, DIMENSION(1) :: DUMMY +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, POINTER, DIMENSION(:) :: NZON,KM,IM,MCU,NZONA,IPERM, + 1 JU,IM0,MCU0,IS,JS + INTEGER, POINTER, DIMENSION(:,:) :: PJJIND + REAL, POINTER, DIMENSION(:) :: ZMU,WZMU,V,VA + TYPE(C_PTR) :: ZMU_PTR,WZMU_PTR,NZON_PTR,V_PTR,KM_PTR,IM_PTR, + 1 MCU_PTR,NZONA_PTR,VA_PTR,IPERM_PTR,JU_PTR,IM0_PTR,MCU0_PTR, + 2 PJJIND_PTR,IS_PTR,JS_PTR + INTEGER, ALLOCATABLE, DIMENSION(:) :: NOM,NOM0,PREV,NEXT,NOM3D, + 1 NOM3D0,KANGL,KEYANI + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISGNR + REAL, ALLOCATABLE, DIMENSION(:) :: ZMUA,WZMUA,PJJ,PSJ,XSW,CQ, + 1 DIAGQ,DIAGFR,CFR,WORK,LUDF,LUCF,PJJX,PJJY,PJJZ,PJJXI,PJJYI, + 2 PJJZI,PSJX,PSJY,PSJZ + REAL, ALLOCATABLE, DIMENSION(:,:) :: RHARM + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: TRHAR + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: H,H0,HH,H3D,H3D0, + 1 PJJD,PJJDX,PJJDY,PJJDZ,PJJDXI,PJJDYI,PJJDZI + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: DIAGF,CF + INTEGER, POINTER, DIMENSION(:) :: INDREG + REAL, POINTER, DIMENSION(:) :: ZZZ + DOUBLE PRECISION, POINTER, DIMENSION(:) :: VNORF,CMU,CMUI,SMU, + 1 SMUI,TMU,TMUI + TYPE(C_PTR) :: INDREG_PTR,ZZZ_PTR,VNORF_PTR,CMU_PTR,CMUI_PTR, + 1 SMU_PTR,SMUI_PTR,TMU_PTR,TMUI_PTR +*---- +* INITIALIZE POINTERS +*---- + KM=>IDUMMY + IM=>IDUMMY + MCU=>IDUMMY + NZONA=>IDUMMY + VA=>DUMMY + IPERM=>IDUMMY + JU=>IDUMMY + IM0=>IDUMMY + MCU0=>IDUMMY + IS=>IDUMMY + JS=>IDUMMY + PJJIND=>I2DUMMY +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(DIAGF(NLONG,NGEFF),CF(LC,NGEFF)) +*---- +* TRACKING INFORMATION PINNING AND MEMORY ALLOCATION +* NZON index-number of the mixture type assigned to each volume. +* NZONA index-number of the mixture type assigned to each volume for +* ACA. +* ISGNR array of the spherical harmonics signs for the different +* reflections. +* V volumes and surfaces. +* VA volumes and surfaces reordered for ACA. +* ZMU polar quadrature set in 2D. +* WZMU polar quadrature set in 2D. +* KM used in ACA acceleration. +* MCU used in ACA acceleration. +* IM used in ACA acceleration. +* JU used in ACA acceleration for ilu0. +* IPERM permutation array for the unknowns of the corrective system +* for ilu0. +* LC0 used in ILU0-ACA acceleration. +* IM0 used in ILU0-ACA acceleration. +* MCU0 used in ILU0-ACA acceleration. +* IS arrays for surfaces neighbors +* JS JS(IS(ISOUT)+1:IS(ISOUT+1)) give the neighboring regions to +* surface ISOUT. +* PJJIND index of the modes for STIS option. +*---- +*--- +* GENERATE ALL SIGNS FOR SPHERICAL HARMONICS +*--- + IF(NDIM.EQ.1) THEN + NFUNL=NANI + NMOD=2 + ELSE IF((.NOT.LPRISM).AND.(NDIM.EQ.2)) THEN + NFUNL=NANI*(NANI+1)/2 + NMOD=4 + ELSE ! NDIM.EQ.3 + NFUNL=NANI*NANI + NMOD=8 + ENDIF + ALLOCATE(ISGNR(NMOD,NFUNL),KEYANI(NFUNL)) + CALL MOCIK3(NANI-1,NFUNL,NMOD,ISGNR,KEYANI) + DEALLOCATE(KEYANI) +*--- +* ASSEMBLY OF SCR AND ACA MATRICES +*--- +* recover polar quadrature + CALL LCMGPD(IPTRK,'ZMU$MCCG',ZMU_PTR) + CALL LCMGPD(IPTRK,'WZMU$MCCG',WZMU_PTR) + CALL C_F_POINTER(ZMU_PTR,ZMU,(/ NMU /)) + CALL C_F_POINTER(WZMU_PTR,WZMU,(/ NMU /)) +* recover MATALB and VOLSUR + CALL LCMGPD(IPTRK,'NZON$MCCG',NZON_PTR) + CALL LCMGPD(IPTRK,'V$MCCG',V_PTR) + CALL C_F_POINTER(NZON_PTR,NZON,(/ NFI /)) + CALL C_F_POINTER(V_PTR,V,(/ NFI /)) + IF(LACA) THEN +* recover connection matrices + CALL LCMGPD(IPTRK,'KM$MCCG',KM_PTR) + CALL LCMGPD(IPTRK,'IM$MCCG',IM_PTR) + CALL LCMGPD(IPTRK,'MCU$MCCG',MCU_PTR) + CALL C_F_POINTER(KM_PTR,KM,(/ NFI /)) + CALL C_F_POINTER(IM_PTR,IM,(/ NLONG+1 /)) + CALL C_F_POINTER(MCU_PTR,MCU,(/ LC /)) +* recover modified MATALB and VOLSUR + CALL LCMGPD(IPTRK,'NZONA$MCCG',NZONA_PTR) + CALL LCMGPD(IPTRK,'VA$MCCG',VA_PTR) + CALL C_F_POINTER(NZONA_PTR,NZONA,(/ NFI /)) + CALL C_F_POINTER(VA_PTR,VA,(/ NFI /)) +* recover permutation array + CALL LCMGPD(IPTRK,'INVPI$MCCG',IPERM_PTR) + CALL C_F_POINTER(IPERM_PTR,IPERM,(/ NFI /)) + IF(PACA.GE.2) THEN + CALL LCMGPD(IPTRK,'JU$MCCG',JU_PTR) + CALL C_F_POINTER(JU_PTR,JU,(/ NLONG /)) + IF(PACA.EQ.3) THEN + CALL LCMLEN(IPTRK,'IM0$MCCG',ILONG1,ITYLCM) + CALL LCMLEN(IPTRK,'MCU0$MCCG',ILONG2,ITYLCM) + CALL LCMGPD(IPTRK,'IM0$MCCG',IM0_PTR) + CALL LCMGPD(IPTRK,'MCU0$MCCG',MCU0_PTR) + CALL C_F_POINTER(IM0_PTR,IM0,(/ ILONG1 /)) + CALL C_F_POINTER(MCU0_PTR,MCU0,(/ ILONG2 /)) + ENDIF + ENDIF + ENDIF + IF((.NOT.CYCLIC).AND.(ISCR.GT.0)) THEN +* recover (IS,JS) array for surfaces neighbors identification + CALL LCMGPD(IPTRK,'IS$MCCG',IS_PTR) + CALL LCMGPD(IPTRK,'JS$MCCG',JS_PTR) + CALL C_F_POINTER(IS_PTR,IS,(/ NFI-NREG+1 /)) + CALL C_F_POINTER(JS_PTR,JS,(/ LPS /)) + ENDIF + IF(LPJJAN) THEN + CALL LCMGPD(IPTRK,'PJJIND$MCCG',PJJIND_PTR) + CALL C_F_POINTER(PJJIND_PTR,PJJIND,(/ NPJJM,2 /)) + ENDIF + IF(LPRISM) THEN + CALL LCMGET(IPTRK,'NCODE',NCODE) + IF(NCODE(6).EQ.30) THEN + IF(NCODE(5).EQ.30) THEN +* Z- and Z+ surfaces symmetry + SSYM=2 + ELSE +* Z+ symmetry + SSYM=1 + ENDIF + ELSE + SSYM=0 + ENDIF + NMAX=(INT(FACSYM)+1)*N2MAX*(NZP+2) + ELSE + NMAX=N2MAX + ENDIF + ALLOCATE(NOM(N2MAX)) + ALLOCATE(H(N2MAX),HH(N2MAX),ZMUA(NMU),WZMUA(NMU)) + IF(LPJJ) THEN +* Self-Collision Probabilities + ALLOCATE(PJJ(NREG*NPJJM*NGEFF),PJJX(NREG*NPJJM*NGEFF), + > PJJXI(NREG*NPJJM*NGEFF),PJJY(NREG*NPJJM*NGEFF), + > PJJYI(NREG*NPJJM*NGEFF),PJJZ(NREG*NPJJM*NGEFF), + > PJJZI(NREG*NPJJM*NGEFF)) + IF(LPS.GT.0) THEN + ALLOCATE(PSJ(LPS*NGEFF),PSJX(LPS*NGEFF),PSJY(LPS*NGEFF), + > PSJZ(LPS*NGEFF)) + PSJ(:LPS*NGEFF)=0.0 + PSJX(:LPS*NGEFF)=0.0 + PSJY(:LPS*NGEFF)=0.0 + PSJZ(:LPS*NGEFF)=0.0 + ENDIF + ALLOCATE(PJJD(NREG*NPJJM*NGEFF),PJJDX(NREG*NPJJM*NGEFF), + > PJJDXI(NREG*NPJJM*NGEFF),PJJDY(NREG*NPJJM*NGEFF), + > PJJDYI(NREG*NPJJM*NGEFF),PJJDZ(NREG*NPJJM*NGEFF), + > PJJDZI(NREG*NPJJM*NGEFF)) + PJJD(:NREG*NPJJM*NGEFF)=0.0D0 + PJJDX(:NREG*NPJJM*NGEFF)=0.0D0 + PJJDXI(:NREG*NPJJM*NGEFF)=0.0D0 + PJJDY(:NREG*NPJJM*NGEFF)=0.0D0 + PJJDYI(:NREG*NPJJM*NGEFF)=0.0D0 + PJJDZ(:NREG*NPJJM*NGEFF)=0.0D0 + PJJDZI(:NREG*NPJJM*NGEFF)=0.0D0 + ENDIF + IF(LACA) THEN +* Algebraic Collapsing Acceleration + ALLOCATE(XSW((M+1)*NANI*NGEFF)) + IF(LTMT) ALLOCATE(NOM0(N2MAX),H0(N2MAX)) + ALLOCATE(PREV(NMAX),NEXT(NMAX)) + ALLOCATE(CQ(LC*NGEFF),DIAGQ(NLONG*NGEFF),DIAGFR(NLONG),CFR(LC), + 1 WORK(6*NMAX)) + IF(PACA.GE.2) THEN + ALLOCATE(LUDF(NLONG)) + IF(LC0.GT.0) ALLOCATE(LUCF(LC0)) + ENDIF + DO II=1,NGEFF + JPSYS=KPSYS(II) + CALL LCMGET(JPSYS,'DRAGON-S0XSC',XSW((II-1)*(M+1)+1)) + ENDDO + CQ(:LC*NGEFF)=0.0 + DIAGQ(:NLONG*NGEFF)=0.0 + DIAGF(:NLONG,:NGEFF)=0.0D0 + CF(:LC,:NGEFF)=0.0D0 + ENDIF +* + NMUA=NMU + DO IE=1,NMUA + ZMUA(IE)=ZMU(IE) + WZMUA(IE)=WZMU(IE) + ENDDO + IF((.NOT.LPRISM).AND.(NDIM.EQ.2).AND.LTMT) THEN + NMUA=1 + ZMUI=ZMUA(1) + W=WZMUA(1) + TEMP=ZMUI*W + DO IE=2,NMU + ZMUI=ZMUA(IE) + WZMUI=WZMUA(IE) + W=W+WZMUI + TEMP=TEMP+ZMUI*WZMUI + ENDDO + ZMUA=TEMP/W + WZMUA=W + ENDIF +*--- +* SUMMATION UPON THE TRACKING +*--- + REWIND IFTRAK + READ(IFTRAK) TEXT4,NCOMNT,NBTR,IFMT + DO ICOM=1,NCOMNT + READ(IFTRAK) + ENDDO + READ(IFTRAK) (NITMA,II=1,7),MXSUB,NITMA + DO ICOM=1,6 + READ(IFTRAK) + ENDDO + CALL KDRCPU(T1) + IANGL0=0 + IPANG=1 + NMERG=0 + NTR=0 + NTRTMT=0 + NSE=0 + NSETMT=0 + LFORC=.FALSE. + NTPROC=1 +* + ALLOCATE(KANGL(MXSUB)) + IF(LPRISM) THEN +* 3D PRISMATIC GEOMETRY CONSTRUCTED FROM A 2D TRACKING + N3TR=0 + N3TRTMT=0 + N3SE=0 + N3SETMT=0 + ALLOCATE(NOM3D(NMAX),H3D(NMAX)) + IF(LTMT) ALLOCATE(NOM3D0(2*NMAX),H3D0(2*NMAX)) + CALL LCMSIX(IPTRK,'PROJECTION',1) + CALL LCMGPD(IPTRK,'IND2T3',INDREG_PTR) + CALL LCMGPD(IPTRK,'ZCOORD',ZZZ_PTR) + CALL LCMGPD(IPTRK,'VNORF',VNORF_PTR) + CALL LCMGPD(IPTRK,'CMU',CMU_PTR) + CALL LCMGPD(IPTRK,'CMUI',CMUI_PTR) + CALL LCMGPD(IPTRK,'SMU',SMU_PTR) + CALL LCMGPD(IPTRK,'SMUI',SMUI_PTR) + CALL LCMGPD(IPTRK,'TMU',TMU_PTR) + CALL LCMGPD(IPTRK,'TMUI',TMUI_PTR) + CALL C_F_POINTER(INDREG_PTR,INDREG,(/ (N2SOU+N2REG+1)*(NZP+1) /)) + CALL C_F_POINTER(ZZZ_PTR,ZZZ,(/ NZP+1 /)) + CALL C_F_POINTER(VNORF_PTR,VNORF,(/ NREG*NANGL*NMU*2 /)) + CALL C_F_POINTER(CMU_PTR,CMU,(/ NMU /)) + CALL C_F_POINTER(CMUI_PTR,CMUI,(/ NMU /)) + CALL C_F_POINTER(SMU_PTR,SMU,(/ NMU /)) + CALL C_F_POINTER(SMUI_PTR,SMUI,(/ NMU /)) + CALL C_F_POINTER(TMU_PTR,TMU,(/ NMU /)) + CALL C_F_POINTER(TMUI_PTR,TMUI,(/ NMU /)) + CALL LCMSIX(IPTRK,'PROJECTION',2) + DO 10 ILINE=1,NBTR + READ(IFTRAK) NSUB,NSEG,WEIGHT,(KANGL(II),II=1,NSUB), + 1 (NOM(II),II=1,NSEG),(H(II),II=1,NSEG) + IF(NSUB.GT.MXSUB) CALL XABORT('MCGASM: MXSUB OVERFLOW.') + IANGL=KANGL(1) + IF(LPJJ) THEN +* ---------------------------- +* Self-Collision Probabilities +* ---------------------------- + NR2SE=NSEG-2 + HH=0.0 + DO II=0,NR2SE + HH(II+2)=HH(II+1)+H(II+2) + ENDDO + CALL MCGPTS(SUBPJJ,NFI,NREG,M,NANI,NFUNL,NANGL,NMU,NMOD, + 1 LPS,NPJJM,NGEFF,IANGL,NSEG,ISGNR,NZON,NOM,IS,JS, + 2 PJJIND,WEIGHT,CPO,CAZ1,CAZ2,ZMU,WZMU,SIGAL,HH,PSJ, + 3 PJJD,LPJJAN,NR2SE,NMAX,NZP,N2REG,N2SOU,DELU,INDREG, + 4 ZZZ,VNORF,CMU,CMUI,SMU,SMUI,TMU,TMUI,SSYM) + ENDIF + IF(LTMT) THEN +* ---------------- +* Tracking Merging (angle by angle) for ACA +* ---------------- + NTR=NTR+1 + NSE=NSE+NSEG + LFORC=(IPANG.NE.IANGL) + IF(LFORC) THEN + ITEMP=IANGL + IANGL=IPANG + IPANG=ITEMP + ENDIF + IF(ILINE.EQ.NBTR) LFORC=.TRUE. + CALL MCGTMT(NMERG,NTRTMT,NSETMT,NSEG,NSEG0,NOM,NOM0,WEIGHT, + 1 WEIGHT0,H,H0,LFORC,NTPROC) + IF(NTPROC.EQ.0) GOTO 10 + ENDIF + IF(LACA) THEN +* --------------------------------- +* Algebraic Collapsing Acceleration +* --------------------------------- + NR2SE=NSEG-2 + HH=0.0 + DO II=0,NR2SE + HH(II+2)=HH(II+1)+H(II+2) + ENDDO + CALL MCGPTA(NFI,NREG,NLONG,M,NANGL,NMU,LC,NGEFF, + 1 IANGL,NSEG,NOM,NZONA,IPERM,KM,IM,MCU,PREV,NEXT, + 2 WEIGHT,ZMU,WZMU,SIGAL,XSW,HH,DIAGQ,CQ,DIAGF, + 3 CF,WORK,LTMT,SUBDS2,SUBDSP,SUBDSC,NR2SE,NMAX, + 4 NZP,N2REG,N2SOU,DELU,INDREG,NOM3D,NOM3D0,H3D, + 5 H3D0,ZZZ,VNORF,CMU,CMUI,SMU,SMUI,TMU,TMUI,N3TR, + 6 N3TRTMT,N3SE,N3SETMT,NTPROC,SSYM) + ENDIF + 10 CONTINUE + IF(LTMT) THEN +* process last integration line for ACA TMT + CALL MCGTMT(NMERG,NTRTMT,NSETMT,NSEG,NSEG0,NOM,NOM0,WEIGHT, + 1 WEIGHT0,H,H0,LFORC,NTPROC) + NR2SE=NSEG-2 + HH=0.0 + DO II=0,NR2SE + HH(II+2)=HH(II+1)+H(II+2) + ENDDO + CALL MCGPTA(NFI,NREG,NLONG,M,NANGL,NMU,LC,NGEFF,IANGL,NSEG, + 1 NOM,NZONA,IPERM,KM,IM,MCU,PREV,NEXT,WEIGHT,ZMU,WZMU, + 2 SIGAL,XSW,HH,DIAGQ,CQ,DIAGF,CF,WORK,LTMT,SUBDS2,SUBDSP, + 3 SUBDSC,NR2SE,NMAX,NZP,N2REG,N2SOU,DELU,INDREG,NOM3D, + 4 NOM3D0,H3D,H3D0,ZZZ,VNORF,CMU,CMUI,SMU,SMUI,TMU,TMUI, + 5 N3TR,N3TRTMT,N3SE,N3SETMT,NTPROC,SSYM) + DEALLOCATE(H3D0,NOM3D0) + ENDIF + DEALLOCATE(H3D,NOM3D) + ELSE +* REGULAR 2D OR 3D GEOMETRY + ALLOCATE(TRHAR(NMU,NFUNL,NANGL),RHARM(NMU,NFUNL)) + DO IANGL=1,NANGL + IF(NDIM.EQ.2) THEN + CALL MOCCHR(NDIM,NANI-1,NFUNL,NMU,CPO(1),CAZ1(IANGL), + 1 CAZ2(IANGL),RHARM) + ELSE + XMUANG(1)=REAL(CAZ0(IANGL)) + CALL MOCCHR(NDIM,NANI-1,NFUNL,1,XMUANG(1),CAZ1(IANGL), + 1 CAZ2(IANGL),RHARM) + ENDIF + DO JF=1,NFUNL + DO IE=1,NMU + TRHAR(IE,JF,IANGL)=ISGNR(1,JF)*RHARM(IE,JF) + ENDDO + ENDDO + ENDDO + DEALLOCATE(RHARM) + DO 20 ILINE=1,NBTR + READ(IFTRAK) NSUB,NSEG,WEIGHT,(KANGL(II),II=1,NSUB), + 1 (NOM(II),II=1,NSEG),(H(II),II=1,NSEG) + IF(NSUB.GT.MXSUB) CALL XABORT('MCGASM: MXSUB OVERFLOW.') + IANGL=KANGL(1) + DO II=1,NSEG + IF(NOM(II).LT.0) THEN + NOM(II)=NREG-NOM(II) + ELSE IF(NOM(II).EQ.0) THEN + NOM(II)=NREG+1 + ENDIF + ENDDO + IF(LPJJ) THEN +* ---------------------------- +* Self-Collision Probabilities +* ---------------------------- + IF(ISTRM.LE.2) THEN + CALL MCGDS4(SUBPJJ,NSEG,NSUB,NMU,LPS,NFUNL,NANGL,NGEFF, + 1 WEIGHT,KANGL,TRHAR,H,ZMU,WZMU,NOM,NZON,NFI,NREG,NDIM, + 2 M,IS,JS,PJJD,PSJ,LPJJAN,NPJJM,PJJIND,SIGAL,1) + ELSE IF(ISTRM.EQ.3) THEN +* TIBERE model + CALL MCGDSD(NSEG,NSUB,NMU,LPS,NFUNL,NANGL,NGEFF,WEIGHT, + 1 TRHAR,H,ZMU,WZMU,KANGL,NOM,NZON,NFI,NREG,NDIM,M,IS, + 2 JS,PJJD,PSJ,LPJJAN,NPJJM,PJJIND,SIGAL,1,CAZ1(IANGL), + 3 CAZ2(IANGL),PJJDX,PJJDY,PJJDZ,PJJDXI,PJJDYI,PJJDZI, + 4 CAZ0(IANGL),PSJX,PSJY,PSJZ) + ENDIF + ENDIF + IF(LTMT) THEN +* ---------------- +* Tracking Merging (angle by angle) for ACA +* ---------------- + NTR=NTR+1 + NSE=NSE+NSEG + IF(ILINE.EQ.NBTR) LFORC=.TRUE. + CALL MCGTMT(NMERG,NTRTMT,NSETMT,NSEG,NSEG0,NOM,NOM0,WEIGHT, + 1 WEIGHT0,H,H0,LFORC,NTPROC) + IF(NTPROC.EQ.0) GOTO 20 + ENDIF + IF(LACA) THEN +* --------------------------------- +* Algebraic Collapsing Acceleration +* --------------------------------- + DO II=1,NSEG + NOM(II)=IPERM(NOM(II)) + ENDDO + CALL MCGDS1(SUBDS2,SUBDSP,SUBDSC,NSEG,NMUA,NGEFF,WEIGHT,H, + 1 ZMUA,WZMUA,NOM,NZONA,NLONG,NFI,NDIM,LC,M,KM,IM,MCU, + 2 DIAGF,DIAGQ,CF,CQ,PREV,NEXT,SIGAL,XSW,WORK) + ENDIF + 20 CONTINUE + DEALLOCATE(TRHAR) + IF(LTMT) THEN +* process last integration line + CALL MCGTMT(NMERG,NTRTMT,NSETMT,NSEG,NSEG0,NOM,NOM0,WEIGHT, + 1 WEIGHT0,H,H0,LFORC,NTPROC) + DO II=1,NSEG + NOM(II)=IPERM(NOM(II)) + ENDDO + CALL MCGDS1(SUBDS2,SUBDSP,SUBDSC,NSEG,NMUA,NGEFF,WEIGHT,H, + 1 ZMUA,WZMUA,NOM,NZONA,NLONG,NFI,NDIM,LC,M,KM,IM,MCU, + 2 DIAGF,DIAGQ,CF,CQ,PREV,NEXT,SIGAL,XSW,WORK) + ENDIF + ENDIF +* + IF((LTMT).AND.(IPRINT.GT.1)) THEN + WRITE(6,*) 'TRACKING MERGING: FROM TRACKING FILE' + WRITE(6,*) ' ', + 1 NTR,' TRACKS ->', + 2 NTRTMT,' EQUIVALENT TRACKS' + WRITE(6,*) ' ', + 1 NSE,' SEGMENTS ->', + 2 NSETMT, ' SEGMENTS' + IF((.NOT.LPRISM).AND.(NDIM.EQ.2)) + 1 WRITE(6,*) ' ', + 2 NMU,' POLAR ANGLES ->', + 3 ' 1 EQUIVALENT POLAR ANGLE' + IF(LPRISM) THEN + WRITE(6,*) 'TRACKING MERGING: 3D PRISMATIC EXTENSION' + WRITE(6,*) ' ', + 1 N3TR,' TRACKS ->', + 2 N3TRTMT,' EQUIVALENT TRACKS' + WRITE(6,*) ' ', + 1 N3SE,' SEGMENTS ->', + 2 N3SETMT, ' SEGMENTS' + ENDIF + ENDIF + CALL KDRCPU(T2) + IF(IPRINT.GT.0) THEN + WRITE(6,100) 'SUMMATION UPON THE TRACKING FOR ACA/SCR ',(T2-T1) + ENDIF +*--- +* FOR ACA: (IF PACA.GE.2) +* CALCULATION OF ILU0 PRECONDITIONER FOR BICGSTAB ITERATIONS +*--- + IF(LACA) THEN + DO II=1,NGEFF + IG=NGIND(II) + JPSYS=KPSYS(II) + IF(IPRINT.GT.2) WRITE(6,200) 'GROUP',IG + CALL MCGDS3(NLONG,PACA,M,SIGAL(0,II), + 1 XSW((II-1)*(M+1)+1),VA,NZONA,LC,MCU,IM,JU,LC0,IM0, + 2 MCU0,DIAGF(1,II),CF(1,II),DIAGQ((II-1)*NLONG+1),DIAGFR, + 3 CFR,LUDF,LUCF) +* + IF(IPRINT.GT.3) THEN + CALL PRINAM('DIAGF ',DIAGFR(1),NLONG) + CALL PRINAM('CF ',CFR(1),LC) + ENDIF + CALL LCMPUT(JPSYS,'DIAGF$MCCG',NLONG,2,DIAGFR) + CALL LCMPUT(JPSYS,'CF$MCCG',LC,2,CFR) + IF(PACA.GE.2) THEN + CALL LCMPUT(JPSYS,'ILUDF$MCCG',NLONG,2,LUDF) + IF(LC0.GT.0) CALL LCMPUT(JPSYS,'ILUCF$MCCG',LC0,2,LUCF) + ENDIF + IF(IPRINT.GT.3) THEN + CALL PRINAM('DIAGQ ',DIAGQ((II-1)*NLONG+1),NLONG) + CALL PRINAM('CQ ',CQ((II-1)*LC+1),LC) + ENDIF + CALL LCMPUT(JPSYS,'CQ$MCCG',LC,2,CQ((II-1)*LC+1)) + CALL LCMPUT(JPSYS,'DIAGQ$MCCG',NLONG,2,DIAGQ((II-1)*NLONG+1)) + ENDDO + CALL KDRCPU(T3) + IF(IPRINT.GT.0) THEN + WRITE(6,100) 'CALCULATION OF ACA PRECONDITIONER ', + 1 (T3-T2) + ENDIF +* + IF(PACA.GE.2) THEN + IF(LC0.GT.0) DEALLOCATE(LUCF) + DEALLOCATE(LUDF) + ENDIF + DEALLOCATE(WORK,CFR,DIAGFR,DIAGQ,CQ) + DEALLOCATE(NEXT,PREV) + IF(LTMT) DEALLOCATE(H0,NOM0) + DEALLOCATE(XSW) + ENDIF +*---- +* FOR SCR/STIS: +* VECTORS NORMALIZATION +*---- + IF(LPJJ) THEN + CALL MCGDS6(NGEFF,NPJJM,NREG,PJJD,V,PJJ) + CALL MCGDS6(NGEFF,NPJJM,NREG,PJJDX,V,PJJX) + CALL MCGDS6(NGEFF,NPJJM,NREG,PJJDY,V,PJJY) + CALL MCGDS6(NGEFF,NPJJM,NREG,PJJDZ,V,PJJZ) + CALL MCGDS6(NGEFF,NPJJM,NREG,PJJDXI,V,PJJXI) + CALL MCGDS6(NGEFF,NPJJM,NREG,PJJDYI,V,PJJYI) + CALL MCGDS6(NGEFF,NPJJM,NREG,PJJDZI,V,PJJZI) + DEALLOCATE(PJJD,PJJDX,PJJDY,PJJDZ,PJJDXI,PJJDYI,PJJDZI) +* + DO II=1,NGEFF + JPSYS=KPSYS(II) + IF(IPRINT.GT.3) THEN + CALL PRINAM('PJJ ',PJJ((II-1)*NREG*NPJJM+1),NREG*NPJJM) + IF(LPS.GT.0) CALL PRINAM('PSJ ',PSJ((II-1)*LPS+1),LPS) + ENDIF + CALL LCMPUT(JPSYS,'PJJ$MCCG',NREG*NPJJM,2, + 1 PJJ((II-1)*NREG*NPJJM+1)) + CALL LCMPUT(JPSYS,'PJJX$MCCG',NREG*NPJJM,2, + 1 PJJX((II-1)*NREG*NPJJM+1)) + CALL LCMPUT(JPSYS,'PJJY$MCCG',NREG*NPJJM,2, + 1 PJJY((II-1)*NREG*NPJJM+1)) + CALL LCMPUT(JPSYS,'PJJZ$MCCG',NREG*NPJJM,2, + 1 PJJZ((II-1)*NREG*NPJJM+1)) + CALL LCMPUT(JPSYS,'PJJXI$MCCG',NREG*NPJJM,2, + 1 PJJXI((II-1)*NREG*NPJJM+1)) + CALL LCMPUT(JPSYS,'PJJYI$MCCG',NREG*NPJJM,2, + 1 PJJYI((II-1)*NREG*NPJJM+1)) + CALL LCMPUT(JPSYS,'PJJZI$MCCG',NREG*NPJJM,2, + 1 PJJZI((II-1)*NREG*NPJJM+1)) + IF(LPS.GT.0) THEN + CALL LCMPUT(JPSYS,'PSJ$MCCG',LPS,2,PSJ((II-1)*LPS+1)) + CALL LCMPUT(JPSYS,'PSJX$MCCG',LPS,2,PSJX((II-1)*LPS+1)) + CALL LCMPUT(JPSYS,'PSJY$MCCG',LPS,2,PSJY((II-1)*LPS+1)) + CALL LCMPUT(JPSYS,'PSJZ$MCCG',LPS,2,PSJZ((II-1)*LPS+1)) + ENDIF + ENDDO +* + IF(LPS.GT.0) DEALLOCATE(PSJ,PSJX,PSJY,PSJZ) + DEALLOCATE(PJJX,PJJXI,PJJY,PJJYI,PJJZ,PJJZI) + DEALLOCATE(PJJ) + ENDIF +* + DEALLOCATE(KANGL,WZMUA,ZMUA,HH,H,NOM) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(CF,DIAGF) + RETURN +* + 100 FORMAT(' -->>TIME SPENT IN: ',A40,':',F13.3,' s.') + 200 FORMAT(1X,A6,1X,I4) + END diff --git a/Dragon/src/MCGBIC.f b/Dragon/src/MCGBIC.f new file mode 100644 index 0000000..829059c --- /dev/null +++ b/Dragon/src/MCGBIC.f @@ -0,0 +1,373 @@ +*DECK MCGBIC + SUBROUTINE MCGBIC(SUBFFI,SUBFFA,SUBDLC,SUBSCH,CYCLIC,KPSYS, + 1 IPRINT,IPTRK,IFTRAK,IPMACR,NDIM,K,N,NLONG,PHIOUT, + 2 NZON,MATALB,M,NANI,NMU,NMAX,NANGL,NREG,NSOUT,SOUR, + 3 IAAC,ISCR,LC,LFORW,PACA,ITST,MAXI,QFR,PHIIN,CAZ0, + 4 CAZ1,CAZ2,CPO,ZMU,WZMU,V,EPS,EPSI,REPSI,SIGAL,LPS, + 5 NG,NGEFF,NGIND,NCONV,LNCONV,NLIN,NFUNL,KEYFLX,KEYCUR, + 6 STIS,NPJJM,REBFLG,LPRISM,N2REG,N2SOU,NZP,DELU,FACSYM, + 7 IDIR,NBATCH) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solve the linear system obtained by the characteristics formalism +* with BiCGSTAB iterative approach. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: +* SUBFFI flux integration subroutine with isotropic source. +* SUBFFA flux integration subroutine with anisotropic source. +* SUBDLC flux integration subroutine with linear-discontinuous source. +* SUBSCH track coefficients calculation subroutine. +* CYCLIC cyclic tracking flag. +* KPSYS pointer array for each group properties. +* IPRINT print parameter (equal to zero for no print). +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK tracking file unit number. +* IPMACR pointer to the macrolib LCM object. +* NDIM number of dimensions for the geometry. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* N total number of unknowns in vectors SUNKNO and FUNKNO. +* NLONG number of spatial unknowns. +* PHIOUT output flux vector. +* NZON mixture-albedo index array in MCCG format. +* MATALB albedo-mixture index array in MOCC format. +* M number of material mixtures. +* NANI scattering anisotropy (=1 for isotropic scattering). +* NMU order of the polar quadrature set. +* NMAX maximum number of elements in a track. +* NANGL number of tracking angles in the plan. +* NREG number of regions (volumes). +* NSOUT number of outer surfaces. +* SOUR scratch. +* IAAC no acceleration / CDD acceleration of inner iterations (0/1). +* ISCR no acceleration / SCR acceleration of inner iterations (0/1). +* LC dimension of profiled matrices MCU and CQ. +* LFORW flag set to .false. to transpose the coefficient matrix. +* PACA type of preconditioner to solve the ACA corrective system. +* ITST output: number of inner iterations. +* MAXI maximum number of inner iterations allowed. +* QFR input source vector. +* PHIIN input flux vector. +* CAZ0 cosines of the tracking polar angles in 3D. +* CAZ1 first cosines of the different tracking azimuthal angles. +* CAZ2 second cosines of the different tracking azimuthal angles. +* CPO cosines of the different tracking polar angles in 2D. +* ZMU polar quadrature set. +* WZMU polar quadrature set. +* V volumes. +* EPS precision reached after min(MAXI,ITST) iterations. +* EPSI tolerance for stopping criterion. Process is stopped +* as soon as: ||Phi(n+1)-Phi(n)||/||Phi(n)|| <= eps +* with ||.|| the euclidean norm. +* REPSI array containing precision of each iteration. +* SIGAL total cross-section and albedo array. +* LPS used in scr acceleration. +* NG number of groups. +* NGEFF number of groups to process. +* NGIND index of the groups to process. +* NCONV array of convergence flag for each group. +* LNCONV number of unconverged groups. +* NLIN number of polynomial components in flux spatial expansion. +* NFUNL number of moments of the flux (in 2D: NFUNL=NANI*(NANI+1)/2). +* KEYFLX position of flux elements in FUNKNO vector. +* KEYCUR position of current elements in FUNKNO vector. +* STIS 'Source term isolation' option for flux integration. +* NPJJM number of pjj modes to store for STIS option. +* REBFLG ACA or SCR rebalancing flag. +* LPRISM 3D prismatic extended tracking flag. +* N2REG number of regions in the 2D tracking if LPRISM. +* N2SOU number of external surfaces in the 2D tracking if LPRISM. +* NZP number of z-plans if LPRISM. +* DELU input track spacing for 3D track reconstruction if LPRISM. +* FACSYM tracking symmetry factor for maximum track length if LPRISM. +* IDIR direction of fundamental current for TIBERE with MoC +* (=0,1,2,3). +* NBATCH number of tracks processed in each OpenMP core (default: =1). +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) KPSYS(NGEFF),IPTRK,IPMACR + INTEGER NGEFF,IPRINT,IFTRAK,NDIM,K,N,NLONG,NG,NZON(NLONG),M, + 1 NANI,NMU,NMAX,IAAC,LC,PACA,ITST(NGEFF),MAXI,NANGL,NREG,NSOUT, + 2 ISCR,LPS,NGIND(NGEFF),LNCONV,NLIN,NFUNL,KEYFLX(NREG,NLIN,NFUNL), + 3 KEYCUR(NLONG-NREG),STIS,NPJJM,MATALB(-NSOUT:NREG),N2REG,N2SOU, + 4 NZP,IDIR,NBATCH + REAL QFR(N,NGEFF),PHIIN(N,NGEFF),CPO(NMU),ZMU(NMU),WZMU(NMU), + 1 V(NLONG),EPS(NGEFF),EPSI,REPSI(MAXI,NGEFF),SIGAL(-6:M,NGEFF), + 2 DELU,FACSYM + DOUBLE PRECISION CAZ0(NANGL),CAZ1(NANGL),CAZ2(NANGL), + 1 PHIOUT(N,NGEFF),SOUR(N,NGEFF) + LOGICAL LFORW,CYCLIC,NCONV(NGEFF),REBFLG,LPRISM + EXTERNAL SUBFFI,SUBFFA,SUBDLC,SUBSCH +*--- +* LOCAL VARIABLES +*--- + INTEGER J,II,ITER,MAXINT + REAL R,BI,WI,RT1,EPSINT,REPSMAX + REAL SDOT + DOUBLE PRECISION DDOT + LOGICAL RHSFLG + INTRINSIC SQRT,ABS +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:,:) :: RHS,PI,RI,SI,ROT,API,AUX +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(RHS(N,NGEFF),PI(N,NGEFF),RI(N,NGEFF),SI(N,NGEFF), + 1 ROT(N,NGEFF),API(N,NGEFF),AUX(2,NGEFF)) +*--- + IF(MAXI.LT.4) CALL XABORT('MCGBIC: MAXI MUST BE >= 4.') + MAXINT=MAXI-1 + EPSINT=0.01*EPSI + RHSFLG=.TRUE. +*--- + ITER=1 +* a first iteration + CALL MCGFL1(SUBFFI,SUBFFA,SUBDLC,SUBSCH,CYCLIC,KPSYS,IPRINT,IPTRK, + 1 IFTRAK,IPMACR,NDIM,K,N,NLONG,PHIOUT,NZON,MATALB,M,NANI,NMU, + 2 NMAX,NANGL,NREG,NSOUT,NG,NGEFF,NGIND,SOUR,IAAC,ISCR,LC,LFORW, + 3 PACA,EPSINT,MAXINT,NLIN,NFUNL,KEYFLX,KEYCUR,QFR,PHIIN(1,1), + 4 CAZ0,CAZ1,CAZ2,CPO,ZMU,WZMU,V,SIGAL,LPS,NCONV,.FALSE.,STIS, + 5 NPJJM,REBFLG,LPRISM,N2REG,N2SOU,NZP,DELU,FACSYM,IDIR,NBATCH) + DO II=1,NGEFF + IF (NCONV(II)) THEN + DO J=1,N + RI(J,II)=REAL(PHIOUT(J,II))-PHIIN(J,II) + PHIIN(J,II)=REAL(PHIOUT(J,II)) + ENDDO + R=SDOT(N,RI(1,II),1,RI(1,II),1) + REPSI(ITER,II)=REAL(SQRT(R/DDOT(N,PHIOUT(1,II),1, + 1 PHIOUT(1,II),1))) + IF (REPSI(ITER,II).LE.EPSI) THEN + NCONV(II)=.FALSE. + ITST(II)=ITER + EPS(II)=REPSI(ITER,II) + LNCONV=LNCONV-1 + ENDIF + IF (LNCONV.EQ.0) RETURN + ENDIF + ENDDO +*--- + 10 ITER=ITER+1 +* compute initial residual vector + CALL MCGFL1(SUBFFI,SUBFFA,SUBDLC,SUBSCH,CYCLIC,KPSYS,IPRINT,IPTRK, + 1 IFTRAK,IPMACR,NDIM,K,N,NLONG,PHIOUT,NZON,MATALB,M,NANI,NMU, + 2 NMAX,NANGL,NREG,NSOUT,NG,NGEFF,NGIND,SOUR,IAAC,ISCR,LC,LFORW, + 3 PACA,EPSINT,MAXINT,NLIN,NFUNL,KEYFLX,KEYCUR,QFR,PHIIN(1,1), + 4 CAZ0,CAZ1,CAZ2,CPO,ZMU,WZMU,V,SIGAL,LPS,NCONV,.FALSE.,STIS, + 5 NPJJM,REBFLG,LPRISM,N2REG,N2SOU,NZP,DELU,FACSYM,IDIR,NBATCH) + DO II=1,NGEFF + IF (NCONV(II)) THEN + DO J=1,N + RI(J,II)=REAL(PHIOUT(J,II))-PHIIN(J,II) + ENDDO + R=SDOT(N,RI(1,II),1,RI(1,II),1) + REPSI(ITER,II)=REAL(SQRT(R/DDOT(N,PHIOUT(1,II),1, + 1 PHIOUT(1,II),1))) + IF (REPSI(ITER,II).LE.EPSI) THEN + NCONV(II)=.FALSE. + ITST(II)=ITER + EPS(II)=REPSI(ITER,II) + LNCONV=LNCONV-1 + DO J=1,N + PHIIN(J,II)=REAL(PHIOUT(J,II)) + ENDDO + ENDIF + IF (LNCONV.EQ.0) RETURN + DO J=1,N + PI(J,II)=RI(J,II) + ROT(J,II)=RI(J,II) + ENDDO +* RT2=R !!SDOT(N,RI,1,ROT,1) + AUX(1,II)=R !!SDOT(N,RI(1,II),1,ROT(1,II),1) + ENDIF + ENDDO +*--- + IF (RHSFLG) THEN +* evaluate RHS of the linear system + IF (IPRINT.GT.3) THEN + WRITE(6,100) IAAC,ISCR + ENDIF + RHS(:N,:NGEFF)=0.0 + CALL MCGFL1(SUBFFI,SUBFFA,SUBDLC,SUBSCH,CYCLIC,KPSYS,IPRINT, + 1 IPTRK,IFTRAK,IPMACR,NDIM,K,N,NLONG,PHIOUT,NZON,MATALB, + 2 M,NANI,NMU,NMAX,NANGL,NREG,NSOUT,NG,NGEFF,NGIND,SOUR,IAAC, + 2 ISCR,LC,LFORW,PACA,EPSINT,MAXINT,NLIN,NFUNL,KEYFLX,KEYCUR, + 3 QFR,RHS(1,1),CAZ0,CAZ1,CAZ2,CPO,ZMU,WZMU,V,SIGAL,LPS, + 4 NCONV,.FALSE.,STIS,NPJJM,REBFLG,LPRISM,N2REG,N2SOU,NZP, + 5 DELU,FACSYM,IDIR,NBATCH) + DO II=1,NGEFF + IF (NCONV(II)) THEN + DO J=1,N + RHS(J,II)=REAL(PHIOUT(J,II)) + ENDDO + ENDIF + ENDDO + RHSFLG=.FALSE. + ENDIF +* + CALL MCGFL1(SUBFFI,SUBFFA,SUBDLC,SUBSCH,CYCLIC,KPSYS,IPRINT,IPTRK, + 1 IFTRAK,IPMACR,NDIM,K,N,NLONG,PHIOUT,NZON,MATALB,M,NANI,NMU, + 2 NMAX,NANGL,NREG,NSOUT,NG,NGEFF,NGIND,SOUR,IAAC,ISCR,LC,LFORW, + 3 PACA,EPSINT,MAXINT,NLIN,NFUNL,KEYFLX,KEYCUR,QFR,PI(1,1),CAZ0, + 4 CAZ1,CAZ2,CPO,ZMU,WZMU,V,SIGAL,LPS,NCONV,.FALSE.,STIS,NPJJM, + 5 REBFLG,LPRISM,N2REG,N2SOU,NZP,DELU,FACSYM,IDIR,NBATCH) + ITER=ITER+1 + DO II=1,NGEFF + IF (NCONV(II)) THEN + DO J=1,N + API(J,II)=PI(J,II)-REAL(PHIOUT(J,II))+RHS(J,II) + ENDDO + REPSI(ITER,II)=REPSI((ITER-1),II) + ENDIF + ENDDO + +* + DO WHILE (ITER.LT.(MAXI-1)) +* BiCGSTAB iterations + ITER=ITER+1 +* + DO II=1,NGEFF + IF (NCONV(II)) THEN + AUX(2,II)=AUX(1,II)/SDOT(N,API(1,II),1,ROT(1,II),1) + DO J=1,N + SI(J,II)=RI(J,II)-AUX(2,II)*API(J,II) + ENDDO + ENDIF + ENDDO +* + CALL MCGFL1(SUBFFI,SUBFFA,SUBDLC,SUBSCH,CYCLIC,KPSYS,IPRINT, + 1 IPTRK,IFTRAK,IPMACR,NDIM,K,N,NLONG,PHIOUT,NZON,MATALB, + 2 M,NANI,NMU,NMAX,NANGL,NREG,NSOUT,NG,NGEFF,NGIND,SOUR,IAAC, + 3 ISCR,LC,LFORW,PACA,EPSINT,MAXINT,NLIN,NFUNL,KEYFLX,KEYCUR, + 4 QFR,SI(1,1),CAZ0,CAZ1,CAZ2,CPO,ZMU,WZMU,V,SIGAL,LPS,NCONV, + 5 .FALSE.,STIS,NPJJM,REBFLG,LPRISM,N2REG,N2SOU,NZP,DELU, + 6 FACSYM,IDIR,NBATCH) + REPSMAX=0.0 + DO II=1,NGEFF + IF (NCONV(II)) THEN + DO J=1,N + RI(J,II)=SI(J,II)-REAL(PHIOUT(J,II))+RHS(J,II) + ENDDO + WI=SDOT(N,RI(1,II),1,SI(1,II),1)/ + 1 SDOT(N,RI(1,II),1,RI(1,II),1) + DO J=1,N + PHIIN(J,II)=PHIIN(J,II)+AUX(2,II)*PI(J,II)+WI*SI(J,II) + RI(J,II)=SI(J,II)-WI*RI(J,II) + ENDDO + R=SDOT(N,RI(1,II),1,RI(1,II),1) + REPSI(ITER,II)=SQRT(R/SDOT(N,PHIIN(1,II),1, + 1 PHIIN(1,II),1)) + REPSMAX=MAX(REPSMAX,REPSI(ITER,II)) + IF (REPSI(ITER,II).LE.EPSI) THEN + NCONV(II)=.FALSE. + ITST(II)=ITER + EPS(II)=REPSI(ITER,II) + LNCONV=LNCONV-1 + ENDIF + IF (LNCONV.EQ.0) GO TO 20 + RT1=AUX(1,II) + AUX(1,II)=SDOT(N,RI(1,II),1,ROT(1,II),1) + BI=AUX(1,II)/RT1*AUX(2,II)/WI + DO J=1,N + PI(J,II)=RI(J,II)+BI*(PI(J,II)-WI*API(J,II)) + ENDDO + ENDIF + ENDDO +* + CALL MCGFL1(SUBFFI,SUBFFA,SUBDLC,SUBSCH,CYCLIC,KPSYS,IPRINT, + 1 IPTRK,IFTRAK,IPMACR,NDIM,K,N,NLONG,PHIOUT,NZON,MATALB, + 2 M,NANI,NMU,NMAX,NANGL,NREG,NSOUT,NG,NGEFF,NGIND,SOUR,IAAC, + 3 ISCR,LC,LFORW,PACA,EPSINT,MAXINT,NLIN,NFUNL,KEYFLX,KEYCUR, + 4 QFR,PI(1,1),CAZ0,CAZ1,CAZ2,CPO,ZMU,WZMU,V,SIGAL,LPS,NCONV, + 5 .FALSE.,STIS,NPJJM,REBFLG,LPRISM,N2REG,N2SOU,NZP,DELU, + 6 FACSYM,IDIR,NBATCH) + ITER=ITER+1 + DO II=1,NGEFF + IF (NCONV(II)) THEN + DO J=1,N + API(J,II)=PI(J,II)-REAL(PHIOUT(J,II))+RHS(J,II) + ENDDO + REPSI(ITER,II)=REPSI((ITER-1),II) + ENDIF + ENDDO + ENDDO +* + 20 CONTINUE +* determine final residual norm + ITER=ITER+1 + DO II=1,NGEFF + IF (NCONV(II)) THEN + ITST(II)=ITER + ELSE + IF (ITST(II).NE.1) THEN + NCONV(II)=.TRUE. + ITST(II)=ITST(II)+1 + ENDIF + ENDIF + ENDDO + CALL MCGFL1(SUBFFI,SUBFFA,SUBDLC,SUBSCH,CYCLIC,KPSYS,IPRINT,IPTRK, + 1 IFTRAK,IPMACR,NDIM,K,N,NLONG,PHIOUT,NZON,MATALB,M,NANI,NMU, + 2 NMAX,NANGL,NREG,NSOUT,NG,NGEFF,NGIND,SOUR,0,0,LC,LFORW,PACA, + 3 EPSINT,MAXINT,NLIN,NFUNL,KEYFLX,KEYCUR,QFR,PHIIN(1,1),CAZ0, + 4 CAZ1,CAZ2,CPO,ZMU,WZMU,V,SIGAL,LPS,NCONV,.FALSE.,STIS,NPJJM, + 5 REBFLG,LPRISM,N2REG,N2SOU,NZP,DELU,FACSYM,IDIR,NBATCH) + DO II=1,NGEFF + IF (NCONV(II)) THEN + DO J=1,N + RI(J,II)=REAL(PHIOUT(J,II))-PHIIN(J,II) + ENDDO + R=SDOT(N,RI(1,II),1,RI(1,II),1) + REPSI(ITST(II),II)=SQRT(R/SDOT(N,PHIIN(1,II),1, + 1 PHIIN(1,II),1)) + DO J=1,N + PHIIN(J,II)=REAL(PHIOUT(J,II)) + ENDDO + EPS(II)=REPSI(ITST(II),II) + ENDIF + ENDDO + LNCONV=0 + IF (ITER.LT.MAXI) THEN + DO II=1,NGEFF + IF (EPS(II).GT.EPSI) THEN + IF ((IAAC.GT.0).OR.(ISCR.GT.0)) THEN + IAAC=0 + ISCR=0 + RHSFLG=.TRUE. + ENDIF + IF (IPRINT.GT.2) WRITE(6,200) ITER + NCONV(II)=.TRUE. + LNCONV=LNCONV+1 + ELSE + NCONV(II)=.FALSE. + ENDIF + ENDDO + IF (LNCONV.GT.0) GO TO 10 + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(AUX,API,ROT,SI,RI,PI,RHS) + RETURN +* + 100 FORMAT(31H RHS CALCULATED WITH AAC-SCR : ,I1,1H-,I1) + 200 FORMAT(37H WARNING : BAD PREVISION, RESTART AT ,I4,10H ITERATION) + END diff --git a/Dragon/src/MCGCAL.f b/Dragon/src/MCGCAL.f new file mode 100644 index 0000000..160c7ce --- /dev/null +++ b/Dragon/src/MCGCAL.f @@ -0,0 +1,75 @@ +*DECK MCGCAL + SUBROUTINE MCGCAL(N,NOMCEL,NREG,MCUW,MCUI,LMCU,LMXMCU) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of connection matrices. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): I. Suslov +* +*Parameters: input +* N number of segments on this track. +* NOMCEL integer tracking elements. +* NREG number of volumes. +* LMCU dimension (used) of MCUW. +* LMXMCU real dimension of MCUW MCUI. +* +*Parameters: input/output +* MCUW cell connection matrix. +* MCUI cell connection matrix. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,NOMCEL(N),NREG,MCUW(LMXMCU),MCUI(LMXMCU),LMCU,LMXMCU +* + CHARACTER HSMG*131 +* + DO 10 I=1,N + ICEL=NOMCEL(I) + IF (I.EQ.N) THEN + ICEL1=-1 + ELSE + ICEL1=NOMCEL(I+1) + ENDIF + IF(ICEL.EQ.ICEL1) THEN + IF (ICEL1.GT.NREG) THEN + ICEL1=-1 + ELSE + GOTO 6 + ENDIF + ENDIF +* IS THERE AREADY AN ELEMENT IN MATRIX FOR CELL ICEL ? + IF (MCUW(ICEL).NE.0) GOTO 5 +* NO : + MCUW(ICEL)=ICEL1 + GOTO 6 +* YES : + 5 II=ICEL + IF(MCUW(II).EQ.ICEL1) GOTO 6 + ICEL=MCUI(II) + IF(ICEL.NE.0) GOTO 5 +* ADD NEW ELEMENT + LMCU=LMCU+1 + IF(LMCU.GT.LMXMCU) THEN + WRITE(HSMG,'(46HMCGCAL: MEMORY OVERFLOW. INCREASE MCU. LMXMCU= + 1 ,I10,1H.)') LMXMCU + CALL XABORT(HSMG) + ENDIF + MCUW(LMCU)=ICEL1 + MCUI(II)=LMCU + 6 CONTINUE + 10 CONTINUE +* + RETURN + END diff --git a/Dragon/src/MCGCDD.f b/Dragon/src/MCGCDD.f new file mode 100644 index 0000000..97c2158 --- /dev/null +++ b/Dragon/src/MCGCDD.f @@ -0,0 +1,176 @@ +*DECK MCGCDD + SUBROUTINE MCGCDD(IPRINT,IPMACR,II,NG,NGEFF,NGIND,NCONV,M,NLONG, + 1 NUN,NREG,LC,LFORW,PACA,NZON,KEYFLX,KEYCUR,IPERM, + 2 IM,MCU,JU,EPSINT,MAXINT,FLUX,QFR,DIAGQ,CQ,DIAGF, + 3 CF,ILUDF,ILUCF,LC0,IM0,MCU0) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of the CDD equations (ACA method) for a synthetic diffusion +* flux calculation. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): I. Suslov and R. Le Tellier +* +*Parameters: input +* IPRINT print parameter. +* IPMACR pointer to the macrolib LCM object ('GROUP' directory) +* II group being processed (II <= NGEFF). +* NG number of groups. +* NGEFF number of groups to process. +* NGIND index of the groups to process. +* NCONV logical array of convergence status for each group (.TRUE. +* not converged). +* M number of material mixtures. +* NLONG size of the corrective system. +* NUN number of unknowns per group. +* NREG number of volume regions. +* LC dimension of profiled matrices MCU and CQ. +* LFORW flag set to .false. to transpose the coefficient matrix. +* PACA type of preconditioner to solve the ACA corrective system. +* NZON index-number of the mixture type assigned to each volume. +* KEYFLX position of flux elements in FLUX vector. +* KEYCUR position of current elements in FLUX vector. +* IPERM permutation array. +* IM used in cdd acceleration. +* MCU used in cdd acceleration. +* JU used in ACA acceleration for ilu0. +* EPSINT stopping criterion for BICGSTAB in ACA resolution. +* MAXINT maximum number of iterations allowed for BICGSTAB in ACA +* resolution. +* QFR source vector. +* DIAGQ used in cdd acceleration. +* CQ used in cdd acceleration. +* DIAGF used in cdd acceleration. +* CF used in cdd acceleration. +* ILUDF used in cdd acceleration. +* ILUCF used in cdd acceleration. +* LC0 used in ILU0-ACA acceleration. +* IM0 used in ILU0-ACA acceleration. +* MCU0 used in ILU0-ACA acceleration. +* +*Parameters: output +* FLUX zonal scalar flux. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMACR + INTEGER IPRINT,II,NG,NGEFF,NGIND(NGEFF),M,NLONG,NUN,NREG,LC,PACA, + 1 NZON(NLONG),KEYFLX(NREG),KEYCUR(*),IPERM(NLONG),IM(NLONG+1), + 2 MCU(LC),JU(NLONG),MAXINT,LC0,IM0(*),MCU0(*) + REAL EPSINT,FLUX(NUN),QFR(NUN,NGEFF),DIAGQ(NLONG),CQ(LC), + 1 DIAGF(NLONG),CF(LC),ILUDF(NLONG),ILUCF(LC) + LOGICAL LFORW,NCONV(NGEFF) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPMACR,KPMACR + DOUBLE PRECISION FF +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NJJ,IJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) :: XSCAT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: AR,PHI +*---- +* SCRATCH STORAGE ALLOCATION +*---- + IF(C_ASSOCIATED(IPMACR)) THEN + JPMACR=LCMGID(IPMACR,'GROUP') + ALLOCATE(NJJ(0:M),IJJ(0:M),IPOS(0:M),XSCAT(0:M*NG)) + ELSE + JPMACR=C_NULL_PTR + ENDIF + ALLOCATE(PHI(NLONG),AR(NLONG)) +*---- +* CONSTRUCT RHS OF THE CDD SYSTEM +*---- + DO I=1,NLONG + J=IPERM(I) + IF(NZON(J).GE.0) THEN + FF=DIAGQ(I)*QFR(KEYFLX(J),II) + ELSE + FF=0.0 + ENDIF + DO IL=IM(I)+1,IM(I+1) + IF(MCU(IL).GT.0) THEN + L=IPERM(MCU(IL)) + IF(NZON(L).GE.0) FF=FF+CQ(IL)*QFR(KEYFLX(L),II) + ENDIF + ENDDO + PHI(I)=FF + ENDDO +*---- +* INVERSE THE SYSTEM BY THE ITERATIVE METHOD BICGSTAB +*---- +* apply preconditioner to RHS + CALL MCGPRA(LFORW,2,PACA,.TRUE.,NLONG,LC,IM,MCU,JU,DIAGF,CF, + 1 ILUDF,ILUCF,DIAGF,AR,PHI,LC0,IM0,MCU0,CF) +* + CALL MCGABG(IPRINT,LFORW,PACA,NLONG,LC,EPSINT,MAXINT,IM,MCU,JU, + 1 DIAGF,CF,ILUDF,ILUCF,AR,PHI,1.0,LC0,IM0,MCU0) +* + IF(C_ASSOCIATED(JPMACR)) THEN +*--- +* MODIFY THE CONTRIBUTION FORM THIS GROUP TO OTHER GROUP ISOTROPIC SOURCES +* (JACOBI -> GAUSS-SEIDEL) +*--- + IG=NGIND(II) + DO JJ=1,NGEFF + IF(NCONV(JJ)) THEN + JG=NGIND(JJ) + IF(JG.GT.IG) THEN + KPMACR=LCMGIL(JPMACR,JG) + CALL LCMGET(KPMACR,'NJJS00',NJJ(1)) + CALL LCMGET(KPMACR,'IJJS00',IJJ(1)) + CALL LCMGET(KPMACR,'IPOS00',IPOS(1)) + CALL LCMGET(KPMACR,'SCAT00',XSCAT(1)) + DO 10 I=1,NLONG + J=IPERM(I) + IBM=NZON(J) + IF(IBM.GT.0) THEN + IND=KEYFLX(J) + IGG=IJJ(IBM) + DO 20 JND=1,NJJ(IBM) + IF(IG.EQ.IGG) THEN + QFR(IND,JJ)=QFR(IND,JJ)+ + 1 XSCAT(IPOS(IBM)+JND-1)*(REAL(PHI(I))-FLUX(IND)) + GOTO 10 + ENDIF + IGG=IGG-1 + 20 CONTINUE + ENDIF + 10 CONTINUE + ENDIF + ENDIF + ENDDO + ENDIF +*--- +* REORDER FLUX VECTOR +*--- + DO I=1,NLONG + J=IPERM(I) + IF(NZON(J).GE.0) THEN + FLUX(KEYFLX(J))=REAL(PHI(I)) + ELSE + FLUX(KEYCUR(J-NREG))=REAL(PHI(I)) + ENDIF + ENDDO +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(AR,PHI) + IF(C_ASSOCIATED(IPMACR)) DEALLOCATE(XSCAT,IPOS,IJJ,NJJ) + RETURN + END diff --git a/Dragon/src/MCGCOEF.f b/Dragon/src/MCGCOEF.f new file mode 100644 index 0000000..298bf04 --- /dev/null +++ b/Dragon/src/MCGCOEF.f @@ -0,0 +1,106 @@ +*DECK MCGCOEF + SUBROUTINE MCGCOEF(NFUNL,NMU,ZMU,WZMU,NANGL,CAZ1,CAZ2,COEFI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find MOC coefficients for DD1 approximation up to P3 scattering order +* using a Gauss-Chebyshev or Leonard-McDaniel-Chebyshev quadrature. +* +*Copyright: +* Copyright (C) 2015 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input +* NFUNL number of spherical harmonics components. +* NMU number of polar angles. +* ZMU polar quadrature set in 2D. +* WZMU polar quadrature set in 2D. +* NANGL number of azimuthal angles. +* CAZ1 first azimuthal cosines. +* CAZ2 second azimuthal cosines. +* +*Parameters: output +* COEFI Gram-Schmidt MOC coefficients. +* +*Reference: +* A. Hebert, "High-Order Diamond Differencing Along Finite +* Characteristics," Nucl. Sci. Eng., 169, 81-97 (2011). +* +*----------------------------------------------------------------------- +* + IMPLICIT DOUBLE PRECISION(A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NFUNL,NMU + REAL ZMU(NMU),WZMU(NMU) + DOUBLE PRECISION CAZ1(NANGL),CAZ2(NANGL),COEFI(2*NFUNL,2*NFUNL) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: COEF,COEF2,COEF3 + DOUBLE PRECISION, DIMENSION(2,2) :: M + INTEGER, DIMENSION(10), PARAMETER :: + > LL=(/ 0, 1, 1, 2, 2, 2, 3, 3, 3, 3 /) + INTEGER, DIMENSION(10), PARAMETER :: + > MM=(/ 0, -1, 1, -2, 0, 2, -3, -1, 1, 3 /) +* + ALLOCATE(COEF(2*NFUNL,2*NFUNL)) + DO I=1,NFUNL + IL=LL(I) ; IM=MM(I) ; + DO J=1,NFUNL + ILP=LL(J) ; IMP=MM(J) ; + CALL MCGDYA(NMU,ZMU,WZMU,NANGL,CAZ1,CAZ2,IL,IM,ILP,IMP,M) ; + COEF(I,J)=M(1,1) ; COEF(I,NFUNL+J)=M(1,2) ; + COEF(NFUNL+I,J)=M(2,1) ; COEF(NFUNL+I,NFUNL+J)=M(2,2) ; + ENDDO + ENDDO + IF(NFUNL == 1) THEN + CALL ALPINVD(2*NFUNL,2*NFUNL,COEF,COEFI(1,1)) ; + ELSEIF(NFUNL == 3) THEN + ALLOCATE(COEF2(2*NFUNL+1,2*NFUNL), COEF3(2*NFUNL,2*NFUNL+1)) + COEF2=0.0D0 ; COEF2(1:2*NFUNL,:)=COEF ; + COEF2(2*NFUNL+1,2)=1.0D0 ; COEF2(2*NFUNL+1,NFUNL+3)=-1.0D0 ; + CALL ALPINVD(2*NFUNL+1,2*NFUNL,COEF2,COEF3(1,1)) ; + COEFI=COEF3(:,1:2*NFUNL) ; + DEALLOCATE(COEF2, COEF3) + ELSEIF(NFUNL == 6) THEN + ALLOCATE(COEF2(2*NFUNL+3,2*NFUNL), COEF3(2*NFUNL,2*NFUNL+3)) + COEF2=0.0D0 ; COEF2(1:2*NFUNL,:)=COEF ; + COEF2(2*NFUNL+1,2)=1.0D0 ; COEF2(2*NFUNL+1,NFUNL+3)=-1.0D0 ; + COEF2(2*NFUNL+2,5)=SQRT(3.0D0) ; COEF2(2*NFUNL+2,6)=1.0D0 ; + COEF2(2*NFUNL+2,NFUNL+4)=1.0D0 ; + COEF2(2*NFUNL+3,NFUNL+5)=SQRT(3.0D0) ; + COEF2(2*NFUNL+3,NFUNL+6)=-1.0D0 ; COEF2(2*NFUNL+3,4)=1.0D0 ; + CALL ALPINVD(2*NFUNL+3,2*NFUNL,COEF2,COEF3(1,1)) ; + COEFI=COEF3(:,1:2*NFUNL) ; + DEALLOCATE(COEF2, COEF3) + ELSEIF(NFUNL == 10) THEN + ALLOCATE(COEF2(2*NFUNL+6,2*NFUNL), COEF3(2*NFUNL,2*NFUNL+6)) + COEF2=0.0D0 ; COEF2(1:2*NFUNL,:)=COEF ; + COEF2(2*NFUNL+1,2)=1.0D0 ; COEF2(2*NFUNL+1,NFUNL+3)=-1.0D0 ; + COEF2(2*NFUNL+2,5)=SQRT(3.0D0) ; COEF2(2*NFUNL+2,6)=1.0D0 ; + COEF2(2*NFUNL+2,NFUNL+4)=1.0D0 ; + COEF2(2*NFUNL+3,NFUNL+5)=SQRT(3.0D0) ; + COEF2(2*NFUNL+3,NFUNL+6)=-1.0D0 ; COEF2(2*NFUNL+3,4)=1.0D0 ; + COEF2(2*NFUNL+4,8)=1.0D0 ; COEF2(2*NFUNL+4,NFUNL+9)=-1.0D0 ; + COEF2(2*NFUNL+5,7)=1.0D0 ; COEF2(2*NFUNL+5,NFUNL+10)=-1.0D0 ; + COEF2(2*NFUNL+6,10)=1.0D0 ; + COEF2(2*NFUNL+6,9)=SQRT(5.0D0/3.0D0) ; + COEF2(2*NFUNL+6,NFUNL+8)=-SQRT(5.0D0/3.0D0) ; + COEF2(2*NFUNL+6,NFUNL+7)=1.0D0 ; + CALL ALPINVD(2*NFUNL+6,2*NFUNL,COEF2,COEF3(1,1)) ; + COEFI=COEF3(:,1:2*NFUNL) ; + DEALLOCATE(COEF2, COEF3) + ELSE + CALL XABORT('MCGCOEF: NFUNL MUST BE = 1, 3, 6 OR 10') + ENDIF + DEALLOCATE(COEF) + RETURN + END diff --git a/Dragon/src/MCGDDDF.f b/Dragon/src/MCGDDDF.f new file mode 100644 index 0000000..18ad2fb --- /dev/null +++ b/Dragon/src/MCGDDDF.f @@ -0,0 +1,129 @@ +*DECK MCGDDDF + SUBROUTINE MCGDDDF(M,NSEG,NSUB,LPS,IS,JS,H,KANGL,NOM,NZON,TR,W, + 1 NFI,NREG,PJJ,PSJ,IMU,NMU,NFUNL,NANGL,NPJJM, + 2 TRHAR,LPJJAN,PJJIND) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of contribution in PJJ and PSJ coefficients on one track. +* Diamond-Differencing scheme. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* LPS dimension of PSJ. +* M number of material mixtures. +* NSEG number of elements for this track. +* NSUB number of subtracks for this track. +* IS arrays for surfaces neighbors. +* JS JS(IS(ISOUT)+1:IS(ISOUT+1)) give the neighboring regions to +* surface ISOUT. +* H real tracking elements. +* KANGL track direction indices. +* NOM integer tracking elements. +* NZON index-number of the mixture type assigned to each volume. +* TR macroscopic total cross section. +* W weight associated with this track. +* NFI total number of volumes and surfaces for which specific values +* of the neutron flux and reactions rates are required. +* NREG number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* IMU polar angle index. +* NMU order of the polar quadrature set. +* NFUNL number of moments of the flux (in 2D : NFUNL=NANI*(NANI+1)/2). +* NANGL number of tracking angles in the plane. +* NPJJM number of pjj modes to store for LPJJAN option. +* TRHAR spherical harmonics components for each azimuthal angle in +* the plane. +* LPJJAN flag for the calculation of anisotropic moments of the pjj. +* PJJIND index of the modes for LPJJAN option. +* +*Parameters: input/output +* PJJ collision probabilities. +* PSJ escape probabilities. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*--- +* SUBROUTINE ARGUMENTS +*--- + INTEGER M,NSEG,NSUB,NFI,NREG,LPS,IS(NFI-NREG+1),JS(LPS),NZON(NFI), + 1 KANGL(NSUB),NOM(NSEG),IMU,NMU,NFUNL,NANGL,NPJJM,PJJIND(NPJJM,2) + REAL TR(0:M),PSJ(LPS),TRHAR(NMU,NFUNL,NANGL) + DOUBLE PRECISION W,H(NSEG),PJJ(NREG,NPJJM) + LOGICAL LPJJAN +*--- +* LOCAL VARIABLES +*--- + INTEGER I,J,NOMI,IC,IC0,NZI,NOMJ,IMOD,INU,INUP,IANG,ISUB + DOUBLE PRECISION TRI,TRJ,TAU,EXPT,HJD,HID,TAUD,EXPTD,TEMPD + LOGICAL LNEW +* + ISUB=0 + LNEW=.TRUE. + IANG=KANGL(1) + DO I=1,NSEG + NOMI=NOM(I) + NZI=NZON(NOMI) + IF(NZI.LT.0) THEN +* Boundary Condition + LNEW=.TRUE. + IF(LPS.GT.0) THEN +* SCR for a non-cyclic tracking + IF(I.EQ.1) THEN + J=I+1 + ELSE !! I.EQ.NSEG + J=I-1 + ENDIF + NOMJ=NOM(J) + IC=0 + DO IC0=IS(NOMI-NREG)+1,IS(NOMI-NREG+1) + IC=IC0 + IF(JS(IC0).EQ.NOMJ) GOTO 10 + ENDDO + CALL XABORT('MCGDDDF: UNABLE TO SET IC.') + 10 HJD=H(J) + TRJ=TR(NZON(NOMJ)) + TAU=HJD*TRJ + EXPT=2.0D0*HJD/(2.0D0+TAU) + PSJ(IC)=PSJ(IC)+REAL(W*EXPT) + ENDIF + ELSE +* this cell is a volume + IF(LNEW) THEN + ISUB=ISUB+1 + IF(ISUB.GT.NSUB) CALL XABORT('MCGDDDF: NSUB OVERFLOW.') + LNEW=.FALSE. + IANG=KANGL(ISUB) + IF(IANG.GT.NANGL) CALL XABORT('MCGDDDF: NANGL OVERFLOW.') + ENDIF + TRI=TR(NZI) + HID=H(I) + TAUD=HID*TRI + EXPTD=HID/(2.D0+TAUD) + EXPTD=EXPTD*W*HID + IF(LPJJAN) THEN + DO IMOD=1,NPJJM + INU=PJJIND(IMOD,1) + INUP=PJJIND(IMOD,2) + TEMPD=DBLE(TRHAR(IMU,INU,IANG))* + 1 DBLE(TRHAR(IMU,INUP,IANG)) + PJJ(NOMI,IMOD)=PJJ(NOMI,IMOD)+EXPTD*TEMPD + ENDDO + ELSE + PJJ(NOMI,1)=PJJ(NOMI,1)+EXPTD + ENDIF + ENDIF + ENDDO +* + RETURN + END diff --git a/Dragon/src/MCGDDF.f b/Dragon/src/MCGDDF.f new file mode 100644 index 0000000..4e04994 --- /dev/null +++ b/Dragon/src/MCGDDF.f @@ -0,0 +1,59 @@ +*DECK MCGDDF + SUBROUTINE MCGDDF(N,K,M,NOM,NZON,H,XST,B) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculate coefficients of a track for the characteristics integration. +* Diamond-Differencing scheme without fix-up with +* 'source term isolation' option turned on. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* N number of elements in the current track. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* M number of material mixtures. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* H vector containing the lenght of the different segments of this +* track. +* XST macroscopic total cross section. +* +*Parameters: output +* B DD1 coefficients. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,K,M,NOM(N),NZON(K) + REAL XST(0:M) + DOUBLE PRECISION H(N),B(N) +*--- +* LOCAL VARIABLES +*--- + INTEGER I,NOMI,NZI + DOUBLE PRECISION TAUD,HID +* + DO I=2,N-1 + NOMI=NOM(I) + NZI=NZON(NOMI) + HID=H(I) + TAUD=HID*XST(NZI) + B(I)=2.D0*HID/(2.D0+TAUD) + ENDDO +* + RETURN + END diff --git a/Dragon/src/MCGDDFL.f b/Dragon/src/MCGDDFL.f new file mode 100644 index 0000000..790ac82 --- /dev/null +++ b/Dragon/src/MCGDDFL.f @@ -0,0 +1,69 @@ +*DECK MCGDDFL + SUBROUTINE MCGDDFL(N,K,M,NOM,NZON,H,XST,B) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculate coefficients of a track for the characteristics +* integration. +* DD1 Diamond-Differencing scheme without fix-up with +* 'source term isolation' option turned off. +* +*Copyright: +* Copyright (C) 2015 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* N number of elements in the current track. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* M number of material mixtures. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* H vector containing the lenght of the different segments of this +* track. +* XST macroscopic total cross section. +* +*Parameters: output +* B DD1 coefficients. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,K,M,NOM(N),NZON(K) + REAL XST(0:M) + DOUBLE PRECISION H(N),B(0:5,N) +*--- +* LOCAL VARIABLES +*--- + INTEGER I,NOMI,NZI + DOUBLE PRECISION SQ3,TAUD,HID,H2,H3,DEN +* + SQ3=SQRT(3.0D0) + DO I=2,N-1 + NOMI=NOM(I) + NZI=NZON(NOMI) + HID=H(I) + TAUD=HID*XST(NZI) + H2=HID*HID + H3=H2*HID + DEN=(TAUD+6.0D0)*TAUD+12.0D0 + B(0,I)=((TAUD-6.0D0)*TAUD+12.0D0)/DEN + B(1,I)=12.0D0*HID/DEN + B(2,I)=H2*(TAUD+6.0D0)/DEN + B(3,I)=-2.0D0*SQ3*H3/DEN + B(4,I)=-2.0D0*SQ3*TAUD/DEN + B(5,I)=H3/DEN + ENDDO +* + RETURN + END diff --git a/Dragon/src/MCGDDFS.f b/Dragon/src/MCGDDFS.f new file mode 100644 index 0000000..396c2ed --- /dev/null +++ b/Dragon/src/MCGDDFS.f @@ -0,0 +1,61 @@ +*DECK MCGDDFS + SUBROUTINE MCGDDFS(N,K,M,NOM,NZON,H,XST,B) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculate coefficients of a track for the characteristics integration. +* Diamond-Differencing scheme without fix-up with +* 'source term isolation' option turned off. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* N number of elements in the current track. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* M number of material mixtures. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* H vector containing the lenght of the different segments of this +* track. +* XST macroscopic total cross section. +* +*Parameters: output +* B DD1 coefficients. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,K,M,NOM(N),NZON(K) + REAL XST(0:M) + DOUBLE PRECISION H(N),B(2,N) +*--- +* LOCAL VARIABLES +*--- + INTEGER I,NOMI,NZI + DOUBLE PRECISION TAUD,HID,TEMP +* + DO I=2,N-1 + NOMI=NOM(I) + NZI=NZON(NOMI) + HID=H(I) + TAUD=HID*XST(NZI) + TEMP=HID/(2.D0+TAUD) + B(1,I)=TEMP+TEMP + B(2,I)=HID*TEMP + ENDDO +* + RETURN + END diff --git a/Dragon/src/MCGDDFT.f b/Dragon/src/MCGDDFT.f new file mode 100644 index 0000000..a545f84 --- /dev/null +++ b/Dragon/src/MCGDDFT.f @@ -0,0 +1,59 @@ +*DECK MCGDDFT + SUBROUTINE MCGDDFT(N,K,M,NOM,NZON,H,XST,B) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculate coefficients of a track for the characteristics integration. +* Diamond-Differencing scheme without fix-up. with +* 'MOCC/MCI' integration strategy. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* N number of elements in the current track. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* M number of material mixtures. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* H vector containing the lenght of the different segments of this +* track. +* XST macroscopic total cross section. +* and step characteristics (SC). +* +*Parameters: output +* B DD1 coefficients. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,K,M,NOM(N),NZON(K) + REAL XST(0:M) + DOUBLE PRECISION H(N),B(N) +*--- +* LOCAL VARIABLES +*--- + INTEGER I,NOMI,NZI + DOUBLE PRECISION TAUD +* + DO I=2,N-1 + NOMI=NOM(I) + NZI=NZON(NOMI) + TAUD=H(I)*XST(NZI) + B(I)=2.D0*TAUD/(2.D0+TAUD) + ENDDO +* + RETURN + END diff --git a/Dragon/src/MCGDS1.f b/Dragon/src/MCGDS1.f new file mode 100644 index 0000000..5d4cb70 --- /dev/null +++ b/Dragon/src/MCGDS1.f @@ -0,0 +1,116 @@ +*DECK MCGDS1 + SUBROUTINE MCGDS1(SUBDS2,SUBDSP,SUBDSC,N,NMU,NGEFF,WEITF,HTF,ZMU, + 1 WZMU,NOM,NZON,NLONG,NFI,NDIM,LC,M,KM,IM,MCU, + 2 DIAGF,DIAGQ,CF,CQ,PREV,NEXT,SIGAL,XSW,WORK) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the contributions in preconditionning matrices +* of a 2D-track. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): I. Suslov and R. Le Tellier +* +*Parameters: input +* SUBDS2 ACA coefficients summation subroutine. +* SUBDSP ACA coefficients position subroutine. +* SUBDSC ACA coefficients calculation subroutine. +* N number of elements in the current track. +* NMU order of the polar quadrature set. +* NGEFF number of energy groups to process. +* NFI total number of volumes and surfaces. +* NDIM number of dimensions in the geometry. +* NLONG total number of cells with unknowns quantities. +* M number of material mixtures. +* LC dimension of vector MCU. +* NZON index-number of the mixture type assigned to each volume. +* WEITF track weight. +* NOM integer tracking elements. +* HTF real tracking elements. +* ZMU polar quadrature set. +* WZMU polar quadrature set. +* KM used in CDD acceleration. +* IM used in CDD acceleration. +* MCU used in CDD acceleration. +* SIGAL albedos and total cross sections array. +* XSW scattering cross sections array. +* +*Parameters: input/output +* CQ undefined. +* CF undefined. +* DIAGQ undefined. +* DIAGF undefined. +* +*Parameters: scratch +* PREV undefined. +* NEXT undefined. +* WORK undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NLONG,NFI,NDIM,LC,NGEFF,M,N,NMU,NOM(N),NZON(NFI), + 1 KM(NLONG),IM(NLONG),MCU(LC),PREV(N),NEXT(N) + DOUBLE PRECISION WEITF,HTF(N) + REAL ZMU(NMU),WZMU(NMU),DIAGQ(NLONG,NGEFF),CQ(LC,NGEFF), + 1 SIGAL(-6:M,NGEFF),XSW(0:M,NGEFF) + DOUBLE PRECISION DIAGF(NLONG,NGEFF),CF(LC,NGEFF),WORK(N,3) + EXTERNAL SUBDS2,SUBDSP,SUBDSC +*---- +* LOCAL VARIABLES +*---- + INTEGER IMU,I,II + REAL ZMUI + DOUBLE PRECISION W + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: HG +*---- +* POSITION OF COEFFICIENTS FOR THIS TRACK IN ACA MATRICES +*---- +* MCGDSP: non cyclic tracking +* MOCDSP: cyclic tracking + CALL SUBDSP(N,NFI,NLONG,LC,NZON,NOM,KM,MCU,IM,PREV,NEXT,HTF) +*---- +* CALCULATION OF COEFFICIENTS +*---- + IF (NDIM.EQ.3) THEN +* 3D calculation -> no loop over a polar angle + DO II=1,NGEFF +* MCGDS2: non cyclic tracking +* MOCDS2: cyclic tracking + CALL SUBDS2(SUBDSC,LC,M,N,HTF,NOM,NZON,SIGAL(0,II), + 1 XSW(0,II),WEITF,NFI,DIAGF(1,II),DIAGQ(1,II), + 2 CF(1,II),CQ(1,II),PREV,NEXT,WORK(1,1),WORK(1,2), + 3 WORK(1,3)) + ENDDO + ELSE +* 2D calculation -> loop over the polar angle + ALLOCATE(HG(N)) + DO IMU=1,NMU + ZMUI=ZMU(IMU) + W=WEITF*WZMU(IMU) + DO I=1,N + IF(NZON(NOM(I)).GE.0) THEN + HG(I)=HTF(I)*ZMUI + ENDIF + ENDDO + DO II=1,NGEFF + CALL SUBDS2(SUBDSC,LC,M,N,HG,NOM,NZON,SIGAL(0,II), + 1 XSW(0,II),W,NFI,DIAGF(1,II),DIAGQ(1,II),CF(1,II), + 2 CQ(1,II),PREV,NEXT,WORK(1,1),WORK(1,2),WORK(1,3)) + ENDDO + ENDDO + DEALLOCATE(HG) + ENDIF +* + RETURN + END diff --git a/Dragon/src/MCGDS2.f b/Dragon/src/MCGDS2.f new file mode 100644 index 0000000..16ac09f --- /dev/null +++ b/Dragon/src/MCGDS2.f @@ -0,0 +1,232 @@ +*DECK MCGDS2 + SUBROUTINE MCGDS2(SUBDSC,LC,M,N,H,NOM,NZON,TR,SC,W,NFI,DIAGF, + 1 DIAGQ,CA,CQ,PREV,NEXT,DINV2,A2,B2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of contribution in second-order ACA coefficients on one +* track. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): I. Suslov and R. Le Tellier +* +*Parameters: input +* SUBDSC ACA coefficients calculation subroutine. +* LC dimension of vector MCU. +* M number of material mixtures. +* N number of elements for this track. +* H tracking widths. +* NOM integer tracking elements. +* NZON index-number of the mixture type assigned to each volume. +* TR macroscopic total cross section. +* SC macroscopic P0 scattering cross section. +* W weight associated with this track. +* NFI total number of volumes and surfaces for which specific values +* of the neutron flux and reactions rates are required. +*Parameters: input/output +* CA undefined. +* CQ undefined. +* DIAGQ undefined. +* DIAGF undefined. +* +*Parameters: scratch +* PREV undefined. +* NEXT undefined. +* DINV2 undefined. +* A2 undefined. +* B2 undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +* +*--- +* SUBROUTINE ARGUMENTS +*--- + INTEGER LC,M,N,NFI,NZON(NFI),NOM(N),PREV(N),NEXT(N) + DOUBLE PRECISION W,H(N),CA(LC),DIAGF(NFI),DINV2(N),A2(N),B2(N) + REAL TR(0:M),SC(0:M),DIAGQ(NFI),CQ(LC) + EXTERNAL SUBDSC +*--- +* LOCAL VARIABLES +*--- + INTEGER IBCV + DOUBLE PRECISION DMINV,DMAX + PARAMETER(DMINV=2.D-2,IBCV=-7) + DOUBLE PRECISION WW,AAW,CAW,AQW,CQW,CAWP,CQWP, + 1 B,A,DINV,DH,DHP,BN,AN,DINVN,BP,AP,DINVP + INTEGER I,I1,NOMI,NZI,NOMIN,NZIN,NOMIP,NZIP,ICN,ICP +* + DMAX=1.D0/DMINV + WW=W +*--- +* CALCULATE COEFFICIENTS OF THIS TRACK +*--- +* MCGDS2A: Tabulated Exponentials +* MCGDS2E: Exact Exponentials + CALL SUBDSC(N,M,NFI,NOM,NZON,H,TR,SC,DINV2,B2,A2) +*---- +* CONSTRUCTION OF ACA MATRICES +*--- +* ------------------- +* Left outer boundary +* ------------------- + I1=2 + ICN=NEXT(1) + ICP=PREV(1) + NZIP=IBCV + NOMI=NOM(1) + NZI=NZON(NOMI) + NOMIN=NOM(I1) + NZIN=NZON(NOMIN) + IF (NZI.NE.IBCV) THEN +* Other than void boundary condition (treated as white reflection) + DIAGF(NOMI)=DIAGF(NOMI)+WW + DIAGQ(NOMI)=DIAGQ(NOMI)+REAL(W*(DINV2(I1)-1.D0)) + IF(ICN.GT.0) THEN + CA(ICN)=CA(ICN)-WW*A2(I1) + CQ(ICN)=CQ(ICN)+REAL(W*B2(I1)) + ENDIF + ENDIF +* ------------ +* Volume Cells +* ------------ + DHP=0.0 + AP=0.0 + BP=0.0 + AN=0.0 + BN=0.0 + DO I=2,N-1 + ICN=NEXT(I) + ICP=PREV(I) + NOMIP=NOMI + NZIP=NZI + NOMI=NOMIN + NZI=NZIN + NOMIN=NOM(I+1) + NZIN=NZON(NOMIN) + DINV=DINV2(I) + B=B2(I) + A=A2(I) + DH=0.0 + IF (NZIN.EQ.IBCV) THEN +* next cell is a fixed boundary condition + DH=1.D0/(1.D0+DINV) + ELSEIF (NZIN.GE.0) THEN +* next cell is a volume + I1=I+1 + DINVN=DINV2(I1) + BN=B2(I1) + AN=A2(I1) + IF (ABS(DINV+DINVN).LT.DMINV) THEN + DH=DMAX + ELSE + DH=1.D0/(DINV+DINVN) + ENDIF + ENDIF + IF (NZIP.EQ.IBCV) THEN +* previous cell is a fixed boundary condition + DHP=1.D0/(1.D0+DINV) + ELSEIF (NZIP.GE.0) THEN +* previous cell is a volume + I1=I-1 + DINVP=DINV2(I1) + BP=B2(I1) + AP=A2(I1) + IF (ABS(DINV+DINVP).LT.DMINV) THEN + DHP=DMAX + ELSE + DHP=1.D0/(DINV+DINVP) + ENDIF + ENDIF +* assembling coefficients + IF ((NZIN.LT.0).AND.(NZIN.NE.IBCV)) THEN +* next cell is a surface with reflective boundary condition + AAW=0.D0 + AQW=0.D0 + CAW=0.D0 + CQW=1.D0 + ELSE +* next cell is a volume or a fixed boundary condition + AAW=DH*A + AQW=DH*B + IF (NZIN.GE.0) THEN +* next cell is a volume + CAW=DH*AN + CQW=DH*BN + ELSE +* next cell is a fixed boundary condition + CAW=0.D0 + CQW=0.D0 + ENDIF + ENDIF + IF ((NZIP.LT.0).AND.(NZIP.NE.IBCV)) THEN +* previous cell is a surface with reflective boundary condition + CAWP=0.D0 + CQWP=1.D0 + ELSE +* previous cell is a volume or a fixed boundary condition + AAW=AAW+DHP*A + AQW=AQW+DHP*B + IF (NZIP.GE.0) THEN +* previous cell is a volume + CAWP=DHP*AP + CQWP=DHP*BP + ELSE +* previous cell is a fixed boundary condition + CAWP=0.D0 + CQWP=0.D0 + ENDIF + ENDIF +* assembling matrices + DIAGF(NOMI)=DIAGF(NOMI)+AAW*WW + DIAGQ(NOMI)=DIAGQ(NOMI)-REAL(W*AQW) + IF(ICN.GT.0) THEN +* next cell is a volume different from this one + CA(ICN)=CA(ICN)-CAW*WW + CQ(ICN)=CQ(ICN)+REAL(W*CQW) + ELSE +* next cell is a voided boundary or a volume identical to this one + DIAGF(NOMI)=DIAGF(NOMI)-CAW*WW + DIAGQ(NOMI)=DIAGQ(NOMI)+REAL(W*CQW) + ENDIF + IF(ICP.GT.0) THEN +* previous cell is a volume different from this one + CA(ICP)=CA(ICP)-CAWP*WW + CQ(ICP)=CQ(ICP)+REAL(W*CQWP) + ELSE +* previous cell is a voided boundary or a volume identical to this one + DIAGF(NOMI)=DIAGF(NOMI)-CAWP*WW + DIAGQ(NOMI)=DIAGQ(NOMI)+REAL(W*CQWP) + ENDIF + ENDDO +* -------------------- +* Right outer boundary +* -------------------- + ICN=NEXT(N) + ICP=PREV(N) + NOMIP=NOMI + NZIP=NZI + NOMI=NOMIN + NZI=NZIN + NZIN=IBCV + IF (NZI.NE.IBCV) THEN +* Other than void boundary condition (treated as white reflection) + I1=N-1 + DIAGF(NOMI)=DIAGF(NOMI)+WW + DIAGQ(NOMI)=DIAGQ(NOMI)+REAL(W*(DINV2(I1)-1.D0)) + IF(ICP.GT.0) THEN + CA(ICP)=CA(ICP)-WW*A2(I1) + CQ(ICP)=CQ(ICP)+REAL(W*B2(I1)) + ENDIF + ENDIF +* + RETURN + END diff --git a/Dragon/src/MCGDS2A.f b/Dragon/src/MCGDS2A.f new file mode 100644 index 0000000..3c53a81 --- /dev/null +++ b/Dragon/src/MCGDS2A.f @@ -0,0 +1,83 @@ +*DECK MCGDS2A + SUBROUTINE MCGDS2A(N,M,NFI,NOM,NZON,H,XST,XSW,DINV,B,A) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of ACA coefficients for this track +* (tabulated exponentials version). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s) : R. Le Tellier +* +*Parameters: input +* N number of elements for this track. +* M number of material mixtures. +* NFI total number of volumes and surfaces for which specific values +* of the neutron flux and reactions rates are required. +* NOM integer tracking elements. +* NZON zone number. +* H tracking widths. +* XST total cross sections array. +* XSW scattering cross sections array. +* +*Parameters: output +* DINV undefined. +* B undefined. +* A undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*--- +* SUBROUTINE ARGUMENTS +*--- + INTEGER N,M,NFI,NOM(N),NZON(NFI) + REAL XST(0:M),XSW(0:M) + DOUBLE PRECISION H(N),DINV(N),B(N),A(N) +*--- +* LOCAL VARIABLES +*--- + DOUBLE PRECISION TAUDMIN + PARAMETER(TAUDMIN=1.D-3) + INTEGER I,NOMI,NZI + REAL TAU + DOUBLE PRECISION TAUD,ALPHA,TEMP +* tabulated exponential common block + REAL E0, E1, PAS1, DX1, XLIM1 + INTEGER MEX1, LAU + PARAMETER ( MEX1=7936 ) + COMMON /EXP0/ E0(0:MEX1),E1(0:MEX1),PAS1,DX1,XLIM1 +* + DO I=1,N + NOMI=NOM(I) + NZI=NZON(NOMI) + IF (NZI.GE.0) THEN + TAUD=H(I)*DBLE(XST(NZI)) + IF (TAUD.GT.TAUDMIN) THEN + TAU=REAL(TAUD) + LAU=MIN(INT(TAU*PAS1),MEX1) +* Linear interpolation in table of (1-exp(-x)) + TEMP=DBLE(E0(LAU)+E1(LAU)*TAU) + ALPHA=2.D0/TEMP-2.D0/TAUD-1.D0 + DINV(I)=TAUD/(2.D0+TAUD*ALPHA) + B(I)=0.5D0*TAUD*(DINV(I)-ALPHA) + A(I)=1.D0-B(I) + B(I)=B(I)/XST(NZI) + A(I)=A(I)+B(I)*XSW(NZI) + ELSE + DINV(I)=0.5D0*TAUD + B(I)=0.D0 + A(I)=1.D0 + ENDIF + ENDIF + ENDDO +* + RETURN + END diff --git a/Dragon/src/MCGDS2E.f b/Dragon/src/MCGDS2E.f new file mode 100644 index 0000000..799585d --- /dev/null +++ b/Dragon/src/MCGDS2E.f @@ -0,0 +1,74 @@ +*DECK MCGDS2E + SUBROUTINE MCGDS2E(N,M,NFI,NOM,NZON,H,XST,XSW,DINV,B,A) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of ACA coefficients for this track +* (exact exponentials version). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s) : R. Le Tellier +* +*Parameters: input +* N number of elements for this track. +* M number of material mixtures. +* NFI total number of volumes and surfaces for which specific values +* of the neutron flux and reactions rates are required. +* NOM integer tracking elements. +* NZON zone number. +* H tracking widths. +* XST total cross sections array. +* XSW scattering cross sections array. +* +*Parameters: output +* DINV undefined. +* B undefined. +* A undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*--- +* SUBROUTINE ARGUMENTS +*--- + INTEGER N,M,NFI,NOM(N),NZON(NFI) + REAL XST(0:M),XSW(0:M) + DOUBLE PRECISION H(N),DINV(N),B(N),A(N) +*--- +* LOCAL VARIABLES +*--- + DOUBLE PRECISION TAUDMIN + PARAMETER(TAUDMIN=1.D-3) + INTEGER I,NOMI,NZI + DOUBLE PRECISION TAUD,ALPHA,TEMP +* + DO I=1,N + NOMI=NOM(I) + NZI=NZON(NOMI) + IF (NZI.GE.0) THEN + TAUD=H(I)*DBLE(XST(NZI)) + IF (TAUD.GT.TAUDMIN) THEN + TEMP=1.D0-DEXP(-TAUD) + ALPHA=2.D0/TEMP-2.D0/TAUD-1.D0 + DINV(I)=TAUD/(2.D0+TAUD*ALPHA) + B(I)=0.5D0*TAUD*(DINV(I)-ALPHA) + A(I)=1.D0-B(I) + B(I)=B(I)/XST(NZI) + A(I)=A(I)+B(I)*XSW(NZI) + ELSE + DINV(I)=0.5D0*TAUD + B(I)=0.D0 + A(I)=1.D0 + ENDIF + ENDIF + ENDDO +* + RETURN + END diff --git a/Dragon/src/MCGDS3.f b/Dragon/src/MCGDS3.f new file mode 100644 index 0000000..ec46d8a --- /dev/null +++ b/Dragon/src/MCGDS3.f @@ -0,0 +1,111 @@ +*DECK MCGDS3 + SUBROUTINE MCGDS3(NLONG,PACA,M,TR,SC,V,NZON,LC,MCU,IM,JU,LC0,IM0, + 1 MCU0,DIAGF,CF,DIAGQ,DIAGFR,CFR,LUDF,LUCF) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Adding of capture and when PACA>=2 calculation of ILU0 preconditioner +* for BICGSTAB iterations to solve the precontioning system. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): I. Suslov and R. Le Tellier +* +*Parameters: input +* NLONG corrective system dimension. +* PACA type of preconditioner to solve the ACA corrective system. +* M number of material mixtures. +* TR macroscopic total cross section. +* SC macroscopic P0 scattering cross section. +* V volumes. +* NZON index-number of the mixture type assigned to each volume. +* LC dimension of CF and MCU. +* MCU used in CDD acceleration. +* IM used in CDD acceleration. +* JU used in ilu0 preconditioner. +* LC0 used in ILU0-ACA acceleration. +* IM0 used in ILU0-ACA acceleration. +* MCU0 used in ILU0-ACA acceleration. +* DIAGF diagonal contribution for D (Double Precision). +* CF non diagonal contribution for left hand-side matrix D. +* +*Parameters: input/output +* DIAGQ diagonal contribution for right hand-side matrix +* used in CDD acceleration. +* +*Parameters: output +* DIAGFR diagonal contribution for D. +* CFR non diagonal contribution for D. +* LUDF diagonal contribution for ilu0 decomposition of D. +* LUCF non diagonal contribution for ilu0 decomposition of D. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NLONG,PACA,M,NZON(NLONG),LC,MCU(LC),IM(NLONG+1),JU(NLONG), + 1 LC0,IM0(*),MCU0(*) + DOUBLE PRECISION DIAGF(NLONG),CF(LC) + REAL TR(0:M),SC(0:M),V(NLONG),DIAGQ(NLONG),DIAGFR(NLONG),CFR(LC), + 1 LUDF(NLONG),LUCF(LC0) +*---- +* LOCAL VARIABLES +*---- + INTEGER IBCV + PARAMETER(IBCV=-7) +*---- +* ADDING OF CAPTURE +*---- + DO I=1,NLONG + NZN=NZON(I) + IF(NZN.GE.0) THEN + DIAGF(I)=DIAGF(I)+DBLE((TR(NZN)-SC(NZN))*V(I)/2.0) + DIAGQ(I)=DIAGQ(I)+V(I)/2.0 + ELSEIF(NZN.EQ.IBCV) THEN + DIAGF(I)=1.D0 + ENDIF + ENDDO +*---- +* TYPE CONVERSION +*---- + DO I=1,NLONG + DIAGFR(I)=REAL(DIAGF(I)) + ENDDO + DO I=1,LC + CFR(I)=REAL(CF(I)) + ENDDO + IF(PACA.GE.2) THEN +*---- +* ILU0 DECOMPOSITION : BICGSTAB WILL BE USED TO SOLVE THE SYSTEM +*---- + CALL MSRILU(NLONG,LC,IM,MCU,JU,DIAGF,CF) + DO I=1,NLONG + LUDF(I)=REAL(DIAGF(I)) + ENDDO + IF(PACA.EQ.2) THEN + DO I=1,LC + LUCF(I)=REAL(CF(I)) + ENDDO + ELSEIF(PACA.EQ.3) THEN + DO I=1,NLONG + DO IJ=IM0(I)+1,IM0(I+1) + J=MCU0(IJ) + DO IK=IM(I)+1,IM(I+1) + IF(MCU(IK).EQ.J) GOTO 10 + ENDDO + CALL XABORT('MCGDS3: ILU0-ACA PROBLEM') + 10 LUCF(IJ)=REAL(CF(IK)) + ENDDO + ENDDO + ENDIF + ENDIF +* + RETURN + END diff --git a/Dragon/src/MCGDS4.f b/Dragon/src/MCGDS4.f new file mode 100644 index 0000000..a9b64c8 --- /dev/null +++ b/Dragon/src/MCGDS4.f @@ -0,0 +1,108 @@ +*DECK MCGDS4 + SUBROUTINE MCGDS4(SUBSCH,NSEG,NSUB,NMU,LPS,NFUNL,NANGL,NGEFF, + 1 WEI2D,KANGL,TRHAR,H2D,ZMU,WZMU,NOMCEL,NZON,NFI, + 2 NREG,NDIM,M,IS,JS,PJJ,PSJ,LPJJAN,NPJJM,PJJIND, + 3 SIGAL,MUST) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the PJJ and PSJ. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* SUBSCH track coefficients calculation subroutine. +* NSEG number of elements in the current track. +* NSUB number of subtracks in the current track. +* NMU order of the polar quadrature set. +* LPS first dimension of PSJ. +* NFUNL number of moments of the flux (in 2D : NFUNL=NANI*(NANI+1)/2). +* NANGL number of tracking angles in the plane. +* NGEFF number of energy groups to process. +* NFI total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* NREG number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* NDIM number of dimensions for the geometry. +* M number of material mixtures. +* IS arrays for surfaces neighbors +* JS JS(IS(ISOUT)+1:IS(ISOUT+1)) give the neighboring regions to +* surface ISOUT. +* NZON index-number of the mixture type assigned to each volume. +* TRHAR spherical harmonics components for each angle in the plane. +* WEI2D track weight. +* KANGL track direction indices. +* NOMCEL integer tracking elements. +* H2D real tracking elements. +* ZMU polar quadrature set. +* WZMU polar quadrature set. +* LPJJAN flag for the calculation of anisotropic moments of the pjj. +* NPJJM number of pjj modes to store for LPJJAN option. +* PJJIND index of the modes for LPJJAN option. +* SIGAL albedos and total cross sections array. +* MUST polar index in TRHAR for 3D geometry. +* +*Parameters: input/output +* PJJ collision probabilities. +* PSJ escape probabilities. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NGEFF,NSEG,NSUB,NMU,LPS,NFUNL,NANGL,KANGL(NSEG), + 1 NOMCEL(NSEG),NZON(NFI),NFI,M,NREG,NDIM,IS(NFI-NREG+1),JS(LPS), + 2 NPJJM,PJJIND(NPJJM,2),MUST + DOUBLE PRECISION WEI2D,H2D(NSEG) + REAL TRHAR(NMU,NFUNL,NANGL),ZMU(NMU),WZMU(NMU),PSJ(LPS,NGEFF), + 1 SIGAL(-6:M,NGEFF) + DOUBLE PRECISION PJJ(NREG,NPJJM,NGEFF) + LOGICAL LPJJAN + EXTERNAL SUBSCH +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION W + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: HG +*---- +* CALCULATION OF COEFFICIENTS +*---- + IF(NDIM.EQ.3) THEN +* 3D calculation -> no loop over a polar angle + DO II=1,NGEFF +* MCGDSCA: Step-Characteristics Scheme with Tabulated Exponentials +* MCGDSCE: Step-Characteristics Scheme with Exact Exponentials +* MCGDDDF: Diamond-Differencing Scheme + CALL SUBSCH(M,NSEG,NSUB,LPS,IS,JS,H2D,KANGL,NOMCEL,NZON, + 1 SIGAL(0,II),WEI2D,NFI,NREG,PJJ(1,1,II),PSJ(1,II),MUST, + 2 NMU,NFUNL,NANGL,NPJJM,TRHAR,LPJJAN,PJJIND) + ENDDO + ELSE +* 2D calculation -> loop over the polar angle + ALLOCATE(HG(NSEG)) + DO IMU=1,NMU + ZMUI=ZMU(IMU) + W=WEI2D*WZMU(IMU) + DO I=1,NSEG + IF(NZON(NOMCEL(I)).GE.0) HG(I)=H2D(I)*ZMUI + ENDDO + DO II=1,NGEFF + CALL SUBSCH(M,NSEG,NSUB,LPS,IS,JS,HG,KANGL,NOMCEL,NZON, + 1 SIGAL(0,II),W,NFI,NREG,PJJ(1,1,II),PSJ(1,II),IMU, + 2 NMU,NFUNL,NANGL,NPJJM,TRHAR,LPJJAN,PJJIND) + ENDDO + ENDDO + DEALLOCATE(HG) + ENDIF +* + RETURN + END diff --git a/Dragon/src/MCGDS6.f b/Dragon/src/MCGDS6.f new file mode 100644 index 0000000..686ecae --- /dev/null +++ b/Dragon/src/MCGDS6.f @@ -0,0 +1,55 @@ +*DECK MCGDS6 + SUBROUTINE MCGDS6(NGEFF,NPJJM,NREG,PJJD,VOL,PJJ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Volume normalization and conversion from double to single precision +* of the PJJ. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* NGEFF number of groups to process. +* NPJJM number of pjj modes to store for LPJJAN option. +* NREG number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* PJJD PJJ in double precision to be normalized. +* VOL region volumes. +* +*Parameters: output +* PJJ PJJ in sigle precision, normalized. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*--- +* SUBROUTINE ARGUMENTS +*--- + INTEGER NGEFF,NPJJM,NREG + DOUBLE PRECISION PJJD(NREG,NPJJM,NGEFF) + REAL VOL(NREG),PJJ(NREG,NPJJM,NGEFF) +*--- +* LOCAL VARIABLES +*--- + INTEGER II,I,IMOD + DOUBLE PRECISION VID +* + DO 30 I=1,NREG + VID=2.D0/DBLE(VOL(I)) + DO 20 II=1,NGEFF + DO 10 IMOD=1,NPJJM + PJJ(I,IMOD,II)=REAL(PJJD(I,IMOD,II)*VID) + 10 CONTINUE + 20 CONTINUE + 30 CONTINUE +* + RETURN + END diff --git a/Dragon/src/MCGDSCA.f b/Dragon/src/MCGDSCA.f new file mode 100644 index 0000000..3b31e38 --- /dev/null +++ b/Dragon/src/MCGDSCA.f @@ -0,0 +1,158 @@ +*DECK MCGDSCA + SUBROUTINE MCGDSCA(M,NSEG,NSUB,LPS,IS,JS,H,KANGL,NOM,NZON,TR,W, + 1 NFI,NREG,PJJ,PSJ,IMU,NMU,NFUNL,NANGL,NPJJM, + 2 TRHAR,LPJJAN,PJJIND) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of contribution in PJJ and PSJ coefficients on one track. +* Step-Characteristics scheme with tabulated exponential calls. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* LPS dimension of PSJ. +* M number of material mixtures. +* NSEG number of elements for this track. +* NSUB number of subtracks for this track. +* IS arrays for surfaces neighbors. +* JS JS(IS(ISOUT)+1:IS(ISOUT+1)) give the neighboring regions to +* surface ISOUT. +* H real tracking elements. +* KANGL track direction indices. +* NOM integer tracking elements. +* NZON index-number of the mixture type assigned to each volume. +* TR macroscopic total cross section. +* W weight associated with this track. +* NFI total number of volumes and surfaces for which specific values +* of the neutron flux and reactions rates are required. +* NREG number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* IMU polar angle index. +* NMU order of the polar quadrature set. +* NFUNL number of moments of the flux (in 2D : NFUNL=NANI*(NANI+1)/2). +* NANGL number of tracking angles in the plane. +* NPJJM number of pjj modes to store for LPJJAN option. +* TRHAR spherical harmonics components for each azimuthal angle in +* the plane. +* LPJJAN flag for the calculation of anisotropic moments of the pjj. +* PJJIND index of the modes for LPJJAN option. +* +*Parameters: input/output +* PJJ collision probabilities. +* PSJ escape probabilities. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*--- +* SUBROUTINE ARGUMENTS +*--- + INTEGER M,NSEG,NSUB,NFI,NREG,LPS,IS(NFI-NREG+1),JS(LPS),NZON(NFI), + 1 KANGL(NSUB),NOM(NSEG),IMU,NMU,NFUNL,NANGL,NPJJM,PJJIND(NPJJM,2) + REAL TR(0:M),PSJ(LPS),TRHAR(NMU,NFUNL,NANGL) + DOUBLE PRECISION W,H(NSUB),PJJ(NREG,NPJJM) + LOGICAL LPJJAN +*--- +* LOCAL VARIABLES +*--- + DOUBLE PRECISION TAUDMIN + PARAMETER(TAUDMIN=2.D-2) + INTEGER I,J,NOMI,IC,IC0,NZI,NOMJ,IMOD,INU,INUP,IANG,ISUB + DOUBLE PRECISION TRI,TRJ,TAU,EXPT,HJD,HID,TAUD,TAUD3,TAUD4,TAUD5, + 1 EXPTD,TEMPD + LOGICAL LNEW +* tabulated exponential common block + REAL E0, E1, PAS1, DX1, XLIM1 + INTEGER MEX1, LAU + PARAMETER ( MEX1=7936 ) + COMMON /EXP1/ E0(0:MEX1),E1(0:MEX1),PAS1,DX1,XLIM1 +* + ISUB=0 + LNEW=.TRUE. + IANG=KANGL(1) + DO I=1,NSEG + NOMI=NOM(I) + NZI=NZON(NOMI) + IF(NZI.LT.0) THEN +* Boundary Condition + LNEW=.TRUE. + IF(LPS.GT.0) THEN +* SCR for a non-cyclic tracking + IF(I.EQ.1) THEN + J=I+1 + ELSE !! I.EQ.NSEG + J=I-1 + ENDIF + NOMJ=NOM(J) + IC=0 + DO IC0=IS(NOMI-NREG)+1,IS(NOMI-NREG+1) + IC=IC0 + IF(JS(IC).EQ.NOMJ) GOTO 10 + ENDDO + CALL XABORT('MCGDSCA: UNABLE TO SET IC.') + 10 HJD=H(J) + TRJ=TR(NZON(NOMJ)) + TAU=HJD*TRJ + IF(TAU.GE.XLIM1) THEN + EXPT=1.0D0/TRJ + ELSE + LAU=INT(TAU*PAS1) + EXPT=HJD*(E0(LAU)+E1(LAU)*TAU) + ENDIF + PSJ(IC)=PSJ(IC)+REAL(W*EXPT) + ENDIF + ELSE +* this cell is a volume + IF(LNEW) THEN + ISUB=ISUB+1 + IF(ISUB.GT.NSUB) CALL XABORT('MCGDSCA: NSUB OVERFLOW.') + LNEW=.FALSE. + IANG=KANGL(ISUB) + IF(IANG.GT.NANGL) CALL XABORT('MCGDSCA: NANGL OVERFLOW.') + ENDIF + TRI=TR(NZI) + HID=H(I) + TAUD=HID*TRI + TAU=REAL(TAUD) + IF(TAUD.LE.TAUDMIN) THEN +* expansion in Taylor serie in O(TAUD^3) + TAUD3=TAUD/3.D0 + TAUD4=0.125D0*TAUD + TAUD5=0.2D0*TAUD + EXPTD=HID*(0.5D0-TAUD3*(0.5D0-TAUD4*(1.D0-TAUD5))) + ELSE + IF(TAU.GE.XLIM1) THEN +* Out of the table range + EXPTD=(1.D0-1.D0/TAUD)/DBLE(TRI) + ELSE +* Linear interpolation in table of (1-exp(-x))/x + LAU=INT(TAU*PAS1) + EXPTD=(1.D0-DBLE(E0(LAU)+E1(LAU)*TAU))/DBLE(TRI) + ENDIF + ENDIF + EXPTD=EXPTD*W*HID + IF(LPJJAN) THEN + DO IMOD=1,NPJJM + INU=PJJIND(IMOD,1) + INUP=PJJIND(IMOD,2) + TEMPD=DBLE(TRHAR(IMU,INU,IANG))* + 1 DBLE(TRHAR(IMU,INUP,IANG)) + PJJ(NOMI,IMOD)=PJJ(NOMI,IMOD)+EXPTD*TEMPD + ENDDO + ELSE + PJJ(NOMI,1)=PJJ(NOMI,1)+EXPTD + ENDIF + ENDIF + ENDDO +* + RETURN + END diff --git a/Dragon/src/MCGDSCB.f b/Dragon/src/MCGDSCB.f new file mode 100644 index 0000000..00f26e6 --- /dev/null +++ b/Dragon/src/MCGDSCB.f @@ -0,0 +1,187 @@ +*DECK MCGDSCB + SUBROUTINE MCGDSCB(M,NSEG,NSUB,LPS,IS,JS,H,KANGL,NOM,NZON,TR,W, + 1 NFI,NREG,PJJ,PSJ,IMU,NMU,NFUNL,NANGL,NPJJM, + 2 TRHAR,LPJJAN,PJJIND,OMEGA2,PJJX,PJJY,PJJZ, + 3 PJJXI,PJJYI,PJJZI,PSJX,PSJY,PSJZ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of contribution in PJJ and PSJ coefficients on one track, +* as well as directional values for TIBERE. +* Step-Characteristics scheme with tabulated exponential calls. +* +*Copyright: +* Copyright (C) 2019 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): S. Musongela +* +*Parameters: input +* LPS dimension of PSJX, PSJY and PSJZ. +* M number of material mixtures. +* NSEG number of elements for this track. +* NSUB number of subtracks for this track. +* IS arrays for surfaces neighbors. +* JS JS(IS(ISOUT)+1:IS(ISOUT+1)) give the neighboring regions to +* surface ISOUT. +* H real tracking elements. +* KANGL track direction indices. +* NOM integer tracking elements. +* NZON index-number of the mixture type assigned to each volume. +* TR macroscopic total cross section. +* W weight associated with this track. +* NFI total number of volumes and surfaces for which specific values +* of the neutron flux and reactions rates are required. +* NREG number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* IMU polar angle index. +* NMU order of the polar quadrature set. +* NFUNL number of moments of the flux (in 2D : NFUNL=NANI*(NANI+1)/2). +* NANGL number of tracking angles in the plane. +* NPJJM number of pjj modes to store for LPJJAN option. +* TRHAR spherical harmonics components for each azimuthal angle in +* the plane. +* LPJJAN flag for the calculation of anisotropic moments of the pjj. +* PJJIND index of the modes for LPJJAN option. +* OMEGA2 square x, y and z-component of the direction Omega for 2D +* geometry. +* +*Parameters: input/output +* PJJ collision probabilities. +* PJJX collision probabilities for TIBERE. +* PJJY collision probabilities for TIBERE. +* PJJZ collision probabilities for TIBERE. +* PJJXI collision probabilities for TIBERE. +* PJJYI collision probabilities for TIBERE. +* PJJZI collision probabilities for TIBERE. +* PSJ escape probabilities. +* PSJX escape probabilities for TIBERE. +* PSJY escape probabilities for TIBERE. +* PSJZ escape probabilities for TIBERE. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*--- +* SUBROUTINE ARGUMENTS +*--- + INTEGER M,NSEG,NSUB,NFI,NREG,LPS,IS(NFI-NREG+1),JS(LPS),NZON(NFI), + 1 KANGL(NSUB),NOM(NSEG),IMU,NMU,NFUNL,NANGL,NPJJM,PJJIND(NPJJM,2) + REAL TR(0:M),PSJ(LPS),TRHAR(NMU,NFUNL,NANGL) + REAL PSJX(LPS),PSJY(LPS),PSJZ(LPS) + DOUBLE PRECISION W,H(NSUB),PJJ(NREG,NPJJM),OMEGA2(3) + DOUBLE PRECISION PJJX(NREG,NPJJM),PJJY(NREG,NPJJM), + 1 PJJZ(NREG,NPJJM),PJJXI(NREG,NPJJM),PJJYI(NREG,NPJJM), + 2 PJJZI(NREG,NPJJM) + LOGICAL LPJJAN +*--- +* LOCAL VARIABLES +*--- + DOUBLE PRECISION TAUDMIN + PARAMETER(TAUDMIN=2.D-2) + INTEGER I,J,NOMI,IC,IC0,NZI,NOMJ,IMOD,INU,INUP,IANG,ISUB + DOUBLE PRECISION TRI,TRJ,TAU,EXPT,HJD,HID,TAUD,TAUD3,TAUD4,TAUD5, + 1 EXPTD,TEMPD + LOGICAL LNEW +* tabulated exponential common block + REAL E0, E1, PAS1, DX1, XLIM1 + INTEGER MEX1, LAU + PARAMETER ( MEX1=7936 ) + COMMON /EXP1/ E0(0:MEX1),E1(0:MEX1),PAS1,DX1,XLIM1 +* + ISUB=0 + LNEW=.TRUE. + IANG=KANGL(1) + DO I=1,NSEG + NOMI=NOM(I) + NZI=NZON(NOMI) + IF(NZI.LT.0) THEN +* Boundary Condition + LNEW=.TRUE. + IF(LPS.GT.0) THEN +* SCR for a non-cyclic tracking + IF(I.EQ.1) THEN + J=I+1 + ELSE !! I.EQ.NSEG + J=I-1 + ENDIF + NOMJ=NOM(J) + IC=0 + DO IC0=IS(NOMI-NREG)+1,IS(NOMI-NREG+1) + IC=IC0 + IF(JS(IC0).EQ.NOMJ) GOTO 10 + ENDDO + CALL XABORT('MCGDSCB: UNABLE TO SET IC.') + 10 HJD=H(J) + TRJ=TR(NZON(NOMJ)) + TAU=HJD*TRJ + IF(TAU.GE.XLIM1) THEN + EXPT=1.0D0/TRJ + ELSE + LAU=INT(TAU*PAS1) + EXPT=HJD*(E0(LAU)+E1(LAU)*TAU) + ENDIF + PSJ(IC)=PSJ(IC)+REAL(W*EXPT) + PSJX(IC)=PSJX(IC)+REAL(W*EXPT*3.0*OMEGA2(1)) + PSJY(IC)=PSJY(IC)+REAL(W*EXPT*3.0*OMEGA2(2)) + PSJZ(IC)=PSJZ(IC)+REAL(W*EXPT*3.0*OMEGA2(3)) + ENDIF + ELSE +* this cell is a volume + IF(LNEW) THEN + ISUB=ISUB+1 + IF(ISUB.GT.NSUB) CALL XABORT('MCGDSCB: NSUB OVERFLOW.') + LNEW=.FALSE. + IANG=KANGL(ISUB) + IF(IANG.GT.NANGL) CALL XABORT('MCGDSCB: NANGL OVERFLOW.') + ENDIF + TRI=TR(NZI) + HID=H(I) + TAUD=HID*TRI + TAU=REAL(TAUD) + IF(TAUD.LE.TAUDMIN) THEN +* expansion in Taylor serie in O(TAUD^3) + TAUD3=TAUD/3.D0 + TAUD4=0.125D0*TAUD + TAUD5=0.2D0*TAUD + EXPTD=HID*(0.5D0-TAUD3*(0.5D0-TAUD4*(1.D0-TAUD5))) + ELSE + IF(TAU.GE.XLIM1) THEN +* Out of the table range + EXPTD=(1.D0-1.D0/TAUD)/DBLE(TRI) + ELSE +* Linear interpolation in table of (1-exp(-x))/x + LAU=INT(TAU*PAS1) + EXPTD=(1.D0-DBLE(E0(LAU)+E1(LAU)*TAU))/DBLE(TRI) + ENDIF + ENDIF + EXPTD=EXPTD*W*HID + IF(LPJJAN) THEN + DO IMOD=1,NPJJM + INU=PJJIND(IMOD,1) + INUP=PJJIND(IMOD,2) + TEMPD=DBLE(TRHAR(IMU,INU,IANG))* + 1 DBLE(TRHAR(IMU,INUP,IANG)) + PJJ(NOMI,IMOD)=PJJ(NOMI,IMOD)+EXPTD*TEMPD + ENDDO + ELSE + PJJ(NOMI,1)=PJJ(NOMI,1)+EXPTD + PJJX(NOMI,1)=PJJX(NOMI,1)+EXPTD*3.0*OMEGA2(1) + PJJY(NOMI,1)=PJJY(NOMI,1)+EXPTD*3.0*OMEGA2(2) + PJJZ(NOMI,1)=PJJZ(NOMI,1)+EXPTD*3.0*OMEGA2(3) + PJJXI(NOMI,1)=PJJXI(NOMI,1)+EXPTD*9.0* + 1 OMEGA2(1)*OMEGA2(1) + PJJYI(NOMI,1)=PJJYI(NOMI,1)+EXPTD*9.0* + 1 OMEGA2(2)*OMEGA2(2) + PJJZI(NOMI,1)=PJJZI(NOMI,1)+EXPTD*9.0* + 1 OMEGA2(3)*OMEGA2(3) + ENDIF + ENDIF + ENDDO +* + RETURN + END diff --git a/Dragon/src/MCGDSCE.f b/Dragon/src/MCGDSCE.f new file mode 100644 index 0000000..180cb8f --- /dev/null +++ b/Dragon/src/MCGDSCE.f @@ -0,0 +1,152 @@ +*DECK MCGDSCE + SUBROUTINE MCGDSCE(M,NSEG,NSUB,LPS,IS,JS,H,KANGL,NOM,NZON,TR,W, + 1 NFI,NREG,PJJ,PSJ,IMU,NMU,NFUNL,NANGL,NPJJM, + 2 TRHAR,LPJJAN,PJJIND) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of contribution in PJJ and PSJ coefficients on one track. +* Step-Characteristics scheme with exact exponential calls. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* LPS dimension of PSJ. +* M number of material mixtures. +* NSEG number of elements for this track. +* NSUB number of subtracks in for this track. +* IS arrays for surfaces neighbors. +* JS JS(IS(ISOUT)+1:IS(ISOUT+1)) give the neighboring regions to +* surface ISOUT. +* H real tracking elements. +* KANGL track direction indices. +* NOM integer tracking elements. +* NZON index-number of the mixture type assigned to each volume. +* TR macroscopic total cross section. +* W weight associated with this track. +* NFI total number of volumes and surfaces for which specific values +* of the neutron flux and reactions rates are required. +* NREG number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* IMU polar angle index. +* NMU order of the polar quadrature set. +* NFUNL number of moments of the flux (in 2D : NFUNL=NANI*(NANI+1)/2). +* NANGL number of tracking angles in the plane. +* NPJJM number of pjj modes to store for LPJJAN option. +* TRHAR spherical harmonics components for each azimuthal angle in +* the plane. +* LPJJAN flag for the calculation of anisotropic moments of the pjj. +* PJJIND index of the modes for LPJJAN option. +* +*Parameters: input/output +* PJJ collision probabilities. +* PSJ escape probabilities. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*--- +* SUBROUTINE ARGUMENTS +*--- + INTEGER M,NSEG,NSUB,NFI,NREG,LPS,IS(NFI-NREG+1),JS(LPS),NZON(NFI), + 1 KANGL(NSUB),NOM(NSEG),IMU,NMU,NFUNL,NANGL,NPJJM,PJJIND(NPJJM,2) + REAL TR(0:M),PSJ(LPS),TRHAR(NMU,NFUNL,NANGL) + DOUBLE PRECISION W,H(NSUB),PJJ(NREG,NPJJM) + LOGICAL LPJJAN +*--- +* LOCAL VARIABLES +*--- + REAL TAUMIN + DOUBLE PRECISION TAUDMIN + PARAMETER(TAUDMIN=2.D-2,TAUMIN=2.E-2) + INTEGER I,J,NOMI,IC,IC0,NZI,NOMJ,IMOD,INU,INUP,IANG,ISUB + DOUBLE PRECISION TRI,TRJ,TAU,EXPT,HJD,HID,TAUD,TAUD3,TAUD4,TAUD5, + 1 EXPTD,TEMPD + LOGICAL LNEW +* tabulated exponential common block + REAL E0, E1, PAS1, DX1, XLIM1 + INTEGER MEX1, LAU + PARAMETER ( MEX1=7936 ) + COMMON /EXP1/ E0(0:MEX1),E1(0:MEX1),PAS1,DX1,XLIM1 +* + ISUB=0 + LNEW=.TRUE. + IANG=KANGL(1) + DO I=1,NSEG + NOMI=NOM(I) + NZI=NZON(NOMI) + IF(NZI.LT.0) THEN +* Boundary Condition + LNEW=.TRUE. + IF(LPS.GT.0) THEN +* SCR for a non-cyclic tracking + IF(I.EQ.1) THEN + J=I+1 + ELSE !! I.EQ.NSEG + J=I-1 + ENDIF + NOMJ=NOM(J) + IC=0 + DO IC0=IS(NOMI-NREG)+1,IS(NOMI-NREG+1) + IC=IC0 + IF(JS(IC0).EQ.NOMJ) GOTO 10 + ENDDO + CALL XABORT('MCGDSCE: UNABLE TO SET IC.') + 10 HJD=H(J) + TRJ=TR(NZON(NOMJ)) + TAU=HJD*TRJ + IF(TAU.LE.TAUMIN) THEN + LAU=MIN(INT(TAU*PAS1),MEX1) + EXPT=HJD*(E0(LAU)+E1(LAU)*TAU) + ELSE + EXPT=(1.0D0-EXP(-TAU))/TRJ + ENDIF + PSJ(IC)=PSJ(IC)+REAL(W*EXPT) + ENDIF + ELSE +* this cell is a volume + IF(LNEW) THEN + ISUB=ISUB+1 + IF(ISUB.GT.NSUB) CALL XABORT('MCGDSCE: NSUB OVERFLOW.') + LNEW=.FALSE. + IANG=KANGL(ISUB) + IF(IANG.GT.NANGL) CALL XABORT('MCGDSCE: NANGL OVERFLOW.') + ENDIF + TRI=TR(NZI) + HID=H(I) + TAUD=HID*TRI + EXPTD=0.0D0 + IF(TAUD.LE.TAUDMIN) THEN +* expansion in Taylor serie in O(TAUD^3) + TAUD3=TAUD/3.D0 + TAUD4=0.125D0*TAUD + TAUD5=0.2D0*TAUD + EXPTD=HID*(0.5D0-TAUD3*(0.5D0-TAUD4*(1.D0-TAUD5))) + ELSE + EXPTD=(1.D0-(1.D0-DEXP(-TAUD))/TAUD)/DBLE(TRI) + ENDIF + EXPTD=EXPTD*W*HID + IF(LPJJAN) THEN + DO IMOD=1,NPJJM + INU=PJJIND(IMOD,1) + INUP=PJJIND(IMOD,2) + TEMPD=DBLE(TRHAR(IMU,INU,IANG))* + 1 DBLE(TRHAR(IMU,INUP,IANG)) + PJJ(NOMI,IMOD)=PJJ(NOMI,IMOD)+EXPTD*TEMPD + ENDDO + ELSE + PJJ(NOMI,1)=PJJ(NOMI,1)+EXPTD + ENDIF + ENDIF + ENDDO +* + RETURN + END diff --git a/Dragon/src/MCGDSD.f b/Dragon/src/MCGDSD.f new file mode 100644 index 0000000..e9ed4d0 --- /dev/null +++ b/Dragon/src/MCGDSD.f @@ -0,0 +1,139 @@ +*DECK MCGDSD + SUBROUTINE MCGDSD(NSEG,NSUB,NMU,LPS,NFUNL,NANGL,NGEFF,WEI2D, + 1 TRHAR,H2D,ZMU,WZMU,KANGL,NOMCEL,NZON,NFI,NREG, + 2 NDIM,M,IS,JS,PJJ,PSJ,LPJJAN,NPJJM,PJJIND,SIGAL, + 3 MUST,PHI1,PHI2,PJJX,PJJY,PJJZ,PJJXI,PJJYI, + 4 PJJZI,CAZ0,PSJX,PSJY,PSJZ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the PJJ and PSJ as well as directional values for +* TIBERE. +* +*Copyright: +* Copyright (C) 2019 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): S. Musongela +* +*Parameters: input +* NSEG number of elements in the current track. +* NSUB number of subtracks in the current track. +* NMU order of the polar quadrature set. +* LPS first dimension of PSJ. +* NFUNL number of moments of the flux (in 2D : NFUNL=NANI*(NANI+1)/2). +* NANGL number of tracking angles in the plane. +* NGEFF number of energy groups to process. +* NFI total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* NREG number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* NDIM number of dimensions for the geometry. +* M number of material mixtures. +* IS arrays for surfaces neighbors. +* JS JS(IS(ISOUT)+1:IS(ISOUT+1)) give the neighboring regions to +* surface ISOUT. +* NZON index-number of the mixture type assigned to each volume. +* TRHAR spherical harmonics components for this angle in the plane. +* WEI2D track weight. +* KANGL track direction indices. +* NOMCEL integer tracking elements. +* H2D real tracking elements. +* ZMU polar quadrature set. +* WZMU polar quadrature set. +* LPJJAN flag for the calculation of anisotropic moments of the pjj. +* NPJJM number of pjj modes to store for LPJJAN option. +* PJJIND index of the modes for LPJJAN option. +* SIGAL albedos and total cross sections array. +* MUST polar index in TRHAR for 3D geometry. +* CAZ0 cosines of the tracking polar angles in 3D. +* PHI1 first cosine of the tracking azimuthal angle. +* PHI2 second cosine of the tracking azimuthal angle. +* +*Parameters: input/output +* PJJ collision probabilities. +* PJJX collision probabilities for TIBERE. +* PJJY collision probabilities for TIBERE. +* PJJZ collision probabilities for TIBERE. +* PJJXI collision probabilities for TIBERE. +* PJJYI collision probabilities for TIBERE. +* PJJZI collision probabilities for TIBERE. +* PSJ escape probabilities. +* PSJX escape probabilities for TIBERE. +* PSJY escape probabilities for TIBERE. +* PSJZ escape probabilities for TIBERE. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NGEFF,NSEG,NSUB,NMU,LPS,NFUNL,NANGL,KANGL(NSUB), + 1 NOMCEL(NSEG),NZON(NFI),NFI,M,NREG,NDIM,IS(NFI-NREG+1),JS(LPS), + 2 NPJJM,PJJIND(NPJJM,2),MUST + DOUBLE PRECISION WEI2D,ZZZ,H2D(NSEG) + REAL TRHAR(NMU,NFUNL,NANGL),ZMU(NMU),WZMU(NMU),PSJ(LPS,NGEFF), + 1 SIGAL(-6:M,NGEFF),PSJX(LPS,NGEFF),PSJY(LPS,NGEFF), + 2 PSJZ(LPS,NGEFF) + DOUBLE PRECISION PJJ(NREG,NPJJM,NGEFF),PHI1,PHI2,CAZ0 + DOUBLE PRECISION PJJX(NREG,NPJJM,NGEFF),PJJY(NREG,NPJJM,NGEFF), + > PJJZ(NREG,NPJJM,NGEFF),PJJXI(NREG,NPJJM,NGEFF), + > PJJYI(NREG,NPJJM,NGEFF),PJJZI(NREG,NPJJM,NGEFF) + LOGICAL LPJJAN +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION W,OMEGA2(3) + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: HG +*---- +* CALCULATION OF COEFFICIENTS +*---- + IF(NDIM.EQ.3) THEN +* 3D calculation -> no loop over a polar angle + DO II=1,NGEFF +* MCGDSCB: Step-Characteristics Scheme with Tabulated +* exponentials + OMEGA2(3)=CAZ0*CAZ0 + ZZZ=1.0D0/SQRT(1.0D0-OMEGA2(3)) + OMEGA2(1)=(PHI1/ZZZ)**2 + OMEGA2(2)=(PHI2/ZZZ)**2 + W=WEI2D + CALL MCGDSCB(M,NSEG,NSUB,LPS,IS,JS,H2D(1),KANGL,NOMCEL,NZON, + 1 SIGAL(0,II),W,NFI,NREG,PJJ(1,1,II),PSJ(1,II),MUST,NMU, + 2 NFUNL,NANGL,NPJJM,TRHAR,LPJJAN,PJJIND,OMEGA2, + 3 PJJX(1,1,II),PJJY(1,1,II),PJJZ(1,1,II),PJJXI(1,1,II), + 4 PJJYI(1,1,II),PJJZI(1,1,II),PSJX(1,II),PSJY(1,II), + 5 PSJZ(1,II)) + ENDDO + ELSE +* 2D calculation -> loop over the polar angle + ALLOCATE(HG(NSEG)) + DO IMU=1,NMU + OMEGA2(1)=(PHI1/ZMU(IMU))**2 + OMEGA2(2)=(PHI2/ZMU(IMU))**2 + OMEGA2(3)=(1.0-1.0/ZMU(IMU)**2) + ZMUI=ZMU(IMU) + W=WEI2D*WZMU(IMU) + DO I=1,NSEG + IF(NZON(NOMCEL(I)).GE.0) THEN + HG(I)=H2D(I)*ZMUI + ENDIF + ENDDO + DO II=1,NGEFF + CALL MCGDSCB(M,NSEG,NSUB,LPS,IS,JS,HG(1),KANGL,NOMCEL, + 1 NZON,SIGAL(0,II),W,NFI,NREG,PJJ(1,1,II),PSJ(1,II), + 2 IMU,NMU,NFUNL,NANGL,NPJJM,TRHAR,LPJJAN,PJJIND, + 3 OMEGA2,PJJX(1,1,II),PJJY(1,1,II),PJJZ(1,1,II), + 4 PJJXI(1,1,II),PJJYI(1,1,II),PJJZI(1,1,II), + 5 PSJX(1,II),PSJY(1,II),PSJZ(1,II)) + ENDDO + ENDDO + DEALLOCATE(HG) + ENDIF +* + RETURN + END diff --git a/Dragon/src/MCGDSP.f b/Dragon/src/MCGDSP.f new file mode 100644 index 0000000..df65f5a --- /dev/null +++ b/Dragon/src/MCGDSP.f @@ -0,0 +1,117 @@ +*DECK MCGDSP + SUBROUTINE MCGDSP(N,NFI,NLONG,LC,NZON,NOM,KM,MCU,IM,PREV,NEXT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the position of the coefficients relative to a track +* in ACA matrices. Non-cylic tracking version. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): I. Suslov and R. Le Tellier +* +*Parameters: input +* N number of elements in the current track. +* NFI total number of volumes and surfaces. +* NLONG total number of cells with unknowns quantities. +* LC dimension of vector MCU. +* NZON index-number of the mixture type assigned to each volume. +* NOM integer tracking elements. +* KM used in CDD acceleration. +* MCU used in CDD acceleration. +* IM used in CDD acceleration. +* +*Parameters: output +* PREV PREV(I) location of non diagonal element (NOM(I),NOM(I-1)) +* of preconditioning matrices in vector CF and CQ. +* NEXT NEXT(I) location of non diagonal element (NOM(I),NOM(I+1)) +* of preconditioning matrices in vector CF and CQ. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,NFI,NLONG,LC,NZON(NFI),NOM(N),KM(NLONG),MCU(LC), + 1 IM(NLONG),PREV(N),NEXT(N) +*---- +* LOCAL VARIABLES +*---- + INTEGER I,I1,I2,II,FOUN,FOUP,NOMI,NOMIN,NOMIP,NZI +*---- +* CONSTRUCT PREV & NEXT +*---- + DO I=1,N + FOUN=-1 + FOUP=-1 +* current cell + NOMI=NOM(I) + IF((NOMI.LT.1).OR.(NOMI.GT.NFI)) THEN + write(6,*) 'NOMI= ',NOMI,' I= ',I,' NFI= ',NFI + CALL XABORT('MCGDSP: KM OVERFLOW.') + ENDIF + I1=IM(NOMI) +* next cell + IF(I.EQ.N) THEN + NOMIN=-1 + ELSE + NOMIN=NOM(I+1) + ENDIF +* previous cell + IF(I.EQ.1) THEN + NOMIP=-1 + ELSE + NOMIP=NOM(I-1) + ENDIF +* + NZI=NZON(NOMI) + IF (NOMI.EQ.NOMIN) THEN + IF (NZI.GE.0) THEN + FOUN=0 + ELSE + NOMIN=-1 + ENDIF + ENDIF + IF (NOMI.EQ.NOMIP) THEN + IF (NZI.GE.0) THEN + FOUP=0 + ELSE + NOMIP=-1 + ENDIF + ENDIF +* + I2=I1+KM(NOMI) + I1=I1+1 + DO II=I1,I2 + IF ((FOUN.LT.0).AND.(MCU(II).EQ.NOMIN)) THEN + FOUN=II + ENDIF + IF ((FOUP.LT.0).AND.(MCU(II).EQ.NOMIP)) THEN + FOUP=II + ENDIF + IF ((FOUN.GE.0).AND.(FOUP.GE.0)) GOTO 10 + ENDDO +* connectivity between NOMI and NOMIN and/or NOMIP not found + WRITE(6,100) I,NOMI,NOMIN,NOMIP + CALL PRINIM('NOM ',NOM(1),N) + CALL PRINIM('MCU ',MCU(I1),KM(NOMI)) +! CALL XABORT('MCGDSP: FAILURE 1.') + 10 IF ((FOUN.LE.LC).AND.(FOUP.LE.LC)) THEN + PREV(I)=FOUP + NEXT(I)=FOUN + ELSE + CALL XABORT('MCGDSP: CQ/CF OVERFLOW.') + ENDIF + ENDDO +* + 100 FORMAT(1X,'I=',I3,' NOMI=',I5,' NOMIN=',I5,' NOMIP=',I5) +* + RETURN + END diff --git a/Dragon/src/MCGDTV.f b/Dragon/src/MCGDTV.f new file mode 100644 index 0000000..478f304 --- /dev/null +++ b/Dragon/src/MCGDTV.f @@ -0,0 +1,131 @@ +*DECK MCGDTV + SUBROUTINE MCGDTV(NDIM,NFI,NREG,NSOU,NSEG,NMU,LMCU,LMXMCU,NZONA, + 1 NRSEG,MCUW,MCUI,WEI2D,SEGLEN,WZMU,SURFD,CYCLIC, + 2 ACFLAG,ZMU,XSIXYZ,CAZ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the contribution of a track to the numerical surfaces and +* connection matrices for an EXCELT tracking. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* NDIM number of dimensions for the geometry. +* NFI total number of volumes and surfaces. +* NREG number of regions. +* NSOU number of external surfaces. +* NSEG number of segments for this track. +* NMU number of polar angles. +* LMXMCU maximum dimension for the connection matrix. +* NZONA index-number of the mixture/albedo type assigned to +* each volume/surface. +* NRSEG vector containing the region number of the different segments +* of this track. +* WEI2D weight for this track. +* SEGLEN vector containing the length of the different segments of this +* track. +* ZMU polar quadrature points. +* WZMU polar quadrature weights. +* CYCLIC cyclic tracking flag. +* ACFLAG preconditioning techniques flag. +* CAZ directional cosines. +* +*Parameters: input/output +* LMCU number of elements in the connection matrix. +* MCUW temporary connection matrix. +* MCUI temporary connection matrix. +* SURFD numerical surfaces. +* XSIXYZ XSI for B1 leakage. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NDIM,NFI,NREG,NSOU,NSEG,NMU,LMCU,LMXMCU, + 1 NZONA(NFI),NRSEG(NSEG),MCUW(LMXMCU),MCUI(LMXMCU) + REAL WZMU(NMU) + DOUBLE PRECISION WEI2D,SEGLEN(NSEG),SURFD(NSOU) + LOGICAL CYCLIC,ACFLAG + REAL ZMU(NMU) + DOUBLE PRECISION CAZ(NDIM),XSIXYZ(NSOU,3) + DOUBLE PRECISION OMEGA2(3) + INTEGER IDIR +*--- +* LOCAL VARIABLES +*--- + INTEGER II,NOMCEL,IMU,ITEMP + DOUBLE PRECISION WEIGHT + IF(.NOT.CYCLIC) THEN +* non cyclic tracking: calculate numerical surfaces + DO II=1,NSEG,NSEG-1 + NOMCEL=-NRSEG(II) + IF (NOMCEL.GT.0) THEN + IF (NDIM.EQ.2) THEN + DO IMU=1,NMU + OMEGA2(1)=(CAZ(1)/DBLE(ZMU(IMU)))**2 + OMEGA2(2)=(CAZ(2)/DBLE(ZMU(IMU)))**2 + OMEGA2(3)=1.0D0-1.0D0/DBLE(ZMU(IMU)**2) + WEIGHT=WEI2D*DBLE(WZMU(IMU)) + SURFD(NOMCEL)=SURFD(NOMCEL)+WEIGHT + DO IDIR=1,3 + XSIXYZ(NOMCEL,IDIR)=XSIXYZ(NOMCEL,IDIR)+ + 1 3.0D0*OMEGA2(IDIR)*WEIGHT + ENDDO + ENDDO + ELSE + WEIGHT=WEI2D + SURFD(NOMCEL)=SURFD(NOMCEL)+WEIGHT + DO IDIR=1,3 + XSIXYZ(NOMCEL,IDIR)=XSIXYZ(NOMCEL,IDIR)+ + 1 3.0D0*CAZ(IDIR)*CAZ(IDIR)*WEIGHT + ENDDO + ENDIF + ENDIF + ENDDO + ENDIF +* + IF(ACFLAG) THEN +* SCR or ACA acceleration required + DO II=1,NSEG + IF(NRSEG(II).LT.0) THEN + NRSEG(II)=NREG-NRSEG(II) + ELSE IF(NRSEG(II).EQ.0) THEN + NRSEG(II)=NREG+1 + ENDIF + ENDDO + IF (CYCLIC) THEN +* cyclic tracking: "unfold" the tracking line +* calculate connection matrices + CALL MCGTRK(NFI,NZONA,NSEG,NRSEG,SEGLEN) + CALL MOCCAL(NSEG,NRSEG,NREG,MCUW,MCUI,LMCU,LMXMCU) + DO II=1,NSEG/2 + ITEMP=NRSEG(II) + NRSEG(II)=NRSEG(NSEG+1-II) + NRSEG(NSEG+1-II)=ITEMP + ENDDO + CALL MOCCAL(NSEG,NRSEG,NREG,MCUW,MCUI,LMCU,LMXMCU) + ELSE +* non-cyclic tracking: calculate connection matrices + CALL MCGCAL(NSEG,NRSEG,NREG,MCUW,MCUI,LMCU,LMXMCU) + DO II=1,NSEG/2 + ITEMP=NRSEG(II) + NRSEG(II)=NRSEG(NSEG+1-II) + NRSEG(NSEG+1-II)=ITEMP + ENDDO + CALL MCGCAL(NSEG,NRSEG,NREG,MCUW,MCUI,LMCU,LMXMCU) + ENDIF + ENDIF +* + RETURN + END diff --git a/Dragon/src/MCGDYA.f b/Dragon/src/MCGDYA.f new file mode 100644 index 0000000..8d39758 --- /dev/null +++ b/Dragon/src/MCGDYA.f @@ -0,0 +1,74 @@ +*DECK MCGDYA + SUBROUTINE MCGDYA(NMU,ZMU,WZMU,NANGL,CAZ1,CAZ2,IL,IM,ILP,IMP,MM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Returns the dyadic matrix of Eq. (43). +* +*Copyright: +* Copyright (C) 2015 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input +* NMU number of polar angles. +* ZMU polar quadrature set in 2D. +* WZMU polar quadrature set in 2D. +* NANGL number of azimuthal angles. +* CAZ1 first azimuthal cosines. +* CAZ2 second azimuthal cosines. +* IL spherical harmonics index. +* IM spherical harmonics index. +* ILP spherical harmonics index. +* IMP spherical harmonics index. +* +*Parameters: output +* MM dyadic matrix. +* +*----------------------------------------------------------------------- +* + IMPLICIT DOUBLE PRECISION(A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NMU, IL, IM, ILP, IMP + REAL ZMU(NMU),WZMU(NMU) + DOUBLE PRECISION CAZ1(NANGL),CAZ2(NANGL),MM(2,2) +* + REAL PNSH + DOUBLE PRECISION DYAD(2,2) + REAL, DIMENSION(:), ALLOCATABLE :: WW, MU, ETA, XI + DOUBLE PRECISION, PARAMETER :: PI=3.14159265358979323846264338328 +* + ALLOCATE(WW(2*NMU*NANGL), MU(2*NMU*NANGL), ETA(2*NMU*NANGL), + > XI(2*NMU*NANGL)) + DO IANGLE=1,NANGL + DO IMU=1,NMU + MU((IANGLE-1)*NMU+IMU)=SQRT(1.0-1.0/ZMU(IMU)**2) + ETA((IANGLE-1)*NMU+IMU)=REAL(CAZ1(IANGLE)/ZMU(IMU)) + XI((IANGLE-1)*NMU+IMU)=REAL(CAZ2(IANGLE)/ZMU(IMU)) + WW((IANGLE-1)*NMU+IMU)=WZMU(IMU)*MU((IANGLE-1)*NMU+IMU) + MU((NANGL+IANGLE-1)*NMU+IMU)=-MU((IANGLE-1)*NMU+IMU) + ETA((NANGL+IANGLE-1)*NMU+IMU)=-ETA((IANGLE-1)*NMU+IMU) + XI((NANGL+IANGLE-1)*NMU+IMU)=-XI((IANGLE-1)*NMU+IMU) + WW((NANGL+IANGLE-1)*NMU+IMU)=WW((IANGLE-1)*NMU+IMU) + ENDDO + ENDDO + MM(:,:)=0.0D0 ; WSUM=0.0D0 ; + DO IANGLE=1,2*NMU*NANGL + DYAD=MATMUL(RESHAPE((/ ETA(IANGLE), XI(IANGLE) /),(/ 2, 1 /)), + > RESHAPE((/ ETA(IANGLE), XI(IANGLE) /),(/ 1, 2 /))) + RLM=PNSH(IL,IM,MU(IANGLE),ETA(IANGLE),XI(IANGLE)) + RLMP=PNSH(ILP,IMP,MU(IANGLE),ETA(IANGLE),XI(IANGLE)) + WSUM=WSUM+WW(IANGLE) + MM=MM+WW(IANGLE)*RLM*RLMP*DYAD + ENDDO + MM=(2.0D0*ILP+1.0D0)/WSUM*MM + DEALLOCATE(WW, MU, ETA, XI) + RETURN + END diff --git a/Dragon/src/MCGFCA.f b/Dragon/src/MCGFCA.f new file mode 100644 index 0000000..892bbbd --- /dev/null +++ b/Dragon/src/MCGFCA.f @@ -0,0 +1,535 @@ +*DECK MCGFCA + SUBROUTINE MCGFCA(IPTRK,KPSYS,IPMACR,IPRINT,N1,NG,NGEFF,KPN,NREG, + 1 NANI,NFUNL,M,LC,LFORW,PACA,KEYFLX,KEYCUR,NZON, + 2 NGIND,NCONV,MXACA,EPSACA,MACFLG,REBFLG,PHIOUT, + 3 PHIIN,COMBFLG,NPJJM,KEYANI,IDIR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Acceleration of iterations (ACA method). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IPTRK pointer to the tracking LCM object. +* KPSYS pointer array for each group properties. +* IPMACR pointer to the macrolib LCM object. +* IPRINT print parameter (equal to zero for no print). +* N1 number of unknowns per group of the corrective system. +* NG number of groups. +* NGEFF number of groups to process. +* KPN total number of unknowns in vectors SUNKNO and FUNKNO. +* NREG number of volumes. +* NANI scattering anisotropy (=1 for isotropic scattering). +* NFUNL number of moments of the flux (in 2D: NFUNL=NANI*(NANI+1)/2). +* M number of material mixtures. +* LC dimension of profiled matrices MCU and CQ. +* LFORW flag set to .false. to transpose the coefficient matrix. +* PACA type of preconditioner to solve the ACA corrective system. +* KEYFLX position of flux elements in FI vector. +* KEYCUR position of current elements in FI vector. +* NZON index-number of the mixture type assigned to each volume. +* NGIND index of the groups to process. +* NCONV logical array of convergence status for each group (.TRUE. +* not converged). +* MXACA maximum number of iterations. +* EPSACA convergence criterion. +* MACFLG multigroup cross section flag. +* REBFLG rebalancing form flag for ACA. +* PHIIN initial guess (for this iteration) of zonal scalar flux. +* COMBFLG flag for three-step scheme in combination wih SCR. +* NPJJM second dimension of PJJ. +* KEYANI 'mode to l' index: l=KEYANI(nu). +* IDIR direction of fundamental current for TIBERE with MoC +* (=0,1,2,3). +* +*Parameters: input/output +* PHIOUT zonal scalar flux. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,KPSYS(NGEFF),IPMACR + INTEGER N1,N2,NGEFF,NG,IPRINT,KPN,NREG,NANI,NFUNL,M,LC,PACA, + 1 KEYFLX(NREG,NFUNL),KEYCUR(*),NZON(N1),NGIND(NGEFF),MXACA,NPJJM, + 2 KEYANI(NFUNL),IDIR + REAL EPSACA,PHIIN(KPN,NGEFF) + DOUBLE PRECISION PHIOUT(KPN,NGEFF) + LOGICAL LFORW,NCONV(NGEFF),MACFLG,REBFLG,COMBFLG +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPMACR,KPMACR,JPSYS + INTEGER LC0 + REAL FLXN + CHARACTER*12 NGTYP + INTEGER, TARGET, SAVE, DIMENSION(1) :: IDUMMY + REAL, TARGET, SAVE, DIMENSION(1) :: DUMMY +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NGINDV,NJJ,IJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) :: XSCAT + REAL, ALLOCATABLE, DIMENSION(:,:) :: XSW,PJJ + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: AR,PSI,ARSCR +* + TYPE(C_PTR) PJJIND_PTR,IM_PTR,MCU_PTR,IPERM_PTR,JU_PTR,IM0_PTR, + 1 MCU0_PTR + TYPE(C_PTR) DIAGQ_PTR,CQ_PTR,LUDF_PTR,LUCF_PTR,CF_PTR,DIAGF_PTR + INTEGER, POINTER, DIMENSION(:) :: IM,MCU,IPERM,JU,IM0,MCU0 + INTEGER, POINTER, DIMENSION(:,:) :: PJJIND + REAL, POINTER, DIMENSION(:) :: DIAGQ,CQ,LUDF,LUCF,CF,DIAGF +*---- +* INITIALIZE POINTERS +*---- + JU=>IDUMMY + IM0=>IDUMMY + MCU0=>IDUMMY + LUDF=>DUMMY + LUCF=>DUMMY + CF=>DUMMY + DIAGF=>DUMMY +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NGINDV(NG),AR(N1,NGEFF),PSI(N1,NGEFF),XSW(0:M,NANI), + 1 ARSCR(KPN,NGEFF)) + AR(:N1,:NGEFF)=0.0D0 + XSW(0:M,:NANI)=0.0 + ARSCR(:KPN,:NGEFF)=0.0D0 +* recover connection matrices + CALL LCMGPD(IPTRK,'IM$MCCG',IM_PTR) + CALL LCMGPD(IPTRK,'MCU$MCCG',MCU_PTR) + CALL C_F_POINTER(IM_PTR,IM,(/ N1+1 /)) + CALL C_F_POINTER(MCU_PTR,MCU,(/ LC /)) +* recover permutation array + CALL LCMGPD(IPTRK,'PI$MCCG',IPERM_PTR) + CALL C_F_POINTER(IPERM_PTR,IPERM,(/ N1 /)) + IF(PACA.GE.2) THEN + CALL LCMGPD(IPTRK,'JU$MCCG',JU_PTR) + CALL C_F_POINTER(JU_PTR,JU,(/ N1 /)) + ENDIF + IF(PACA.EQ.3) THEN + CALL LCMLEN(IPTRK,'IM0$MCCG',LIM0,ITYLCM) + CALL LCMLEN(IPTRK,'MCU0$MCCG',LC0,ITYLCM) + CALL LCMGPD(IPTRK,'IM0$MCCG',IM0_PTR) + CALL LCMGPD(IPTRK,'MCU0$MCCG',MCU0_PTR) + CALL C_F_POINTER(IM0_PTR,IM0,(/ LIM0 /)) + CALL C_F_POINTER(MCU0_PTR,MCU0,(/ LC0 /)) + ELSE + LIM0=0 + LC0=0 + ENDIF + IF(MACFLG) THEN + JPMACR=LCMGID(IPMACR,'GROUP') + ALLOCATE(NJJ(0:M),IJJ(0:M),IPOS(0:M),XSCAT(0:M*NG)) + ENDIF + IF(REBFLG) THEN +* N2: number of groups to treat at the same time. +* rebalancing + N2=NGEFF + ELSE +* inner iterations acceleration + N2=1 + ENDIF +*---- +* CONSTRUCT NGINDV (index to pass from "NGEFF format" to "NG format"). +*---- + NGINDV(:NG)=0 + DO II=1,NGEFF + IF(NCONV(II)) THEN + IG=NGIND(II) + NGINDV(IG)=II + ENDIF + ENDDO +*---- +* COMPUTE RESIDUAL OF THE PREVIOUS FREE ITERATION FOR RHS WITHOUT +* COMBFLG OPTION +*---- + IF(IPRINT.GT.10) WRITE(6,*) 'Direction',IDIR + IF(.NOT.COMBFLG) THEN + DO II=1,NGEFF + IF(NCONV(II)) THEN + IG=NGIND(II) + JPSYS=KPSYS(II) + CALL LCMGET(JPSYS,'DRAGON-S0XSC',XSW) + IF(MACFLG) THEN + KPMACR=LCMGIL(JPMACR,IG) + CALL LCMGET(KPMACR,'NJJS00',NJJ(1)) + CALL LCMGET(KPMACR,'IJJS00',IJJ(1)) + CALL LCMGET(KPMACR,'IPOS00',IPOS(1)) + CALL LCMGET(KPMACR,'SCAT00',XSCAT(1)) + ENDIF +* residual for ACA system + CALL MCGFCR(IPRINT,IG,II,NG,NGEFF,KPN,N1,NREG,NANI,NFUNL, + 1 M,.TRUE.,KEYFLX,KEYCUR,NZON,NGINDV,MACFLG,PHIOUT,PHIIN, + 2 XSW,IPERM(1),NJJ,IJJ,IPOS,XSCAT,AR(1,II)) + ENDIF + ENDDO +*---- +* COMPUTE RESIDUAL OF THE PREVIOUS FREE ITERATION FOR RHS WITH COMBFLG +* OPTION +*---- + ELSE + ALLOCATE(PJJ(NREG,NPJJM)) + CALL LCMGPD(IPTRK,'PJJIND$MCCG',PJJIND_PTR) + CALL C_F_POINTER(PJJIND_PTR,PJJIND,(/ NPJJM,2 /)) + DO II=1,NGEFF + IF(NCONV(II)) THEN + IG=NGIND(II) + JPSYS=KPSYS(II) + CALL LCMGET(JPSYS,'DRAGON-S0XSC',XSW) + IF(MACFLG) THEN + KPMACR=LCMGIL(JPMACR,IG) + CALL LCMGET(KPMACR,'NJJS00',NJJ(1)) + CALL LCMGET(KPMACR,'IJJS00',IJJ(1)) + CALL LCMGET(KPMACR,'IPOS00',IPOS(1)) + CALL LCMGET(KPMACR,'SCAT00',XSCAT(1)) + ENDIF +* residual for ACA system + CALL MCGFCR(IPRINT,IG,II,NG,NGEFF,KPN,N1,NREG,NANI,NFUNL, + 1 M,.TRUE.,KEYFLX,KEYCUR,NZON,NGINDV,MACFLG,PHIOUT,PHIIN, + 2 XSW,IPERM(1),NJJ,IJJ,IPOS,XSCAT,AR(1,II)) +* residual for SCR-combined scheme + CALL MCGFCR(IPRINT,IG,II,NG,NGEFF,KPN,N1,NREG,NANI,NFUNL, + 1 M,.FALSE.,KEYFLX,KEYCUR,NZON,NGINDV,MACFLG,PHIOUT, + 2 PHIIN,XSW,KEYANI(1),NJJ,IJJ,IPOS,XSCAT,ARSCR(1,II)) + IF(NANI.GT.1) THEN + IF(IDIR.EQ.0) THEN + CALL LCMGET(JPSYS,'PJJ$MCCG',PJJ) + ELSEIF(IDIR.EQ.1) THEN + CALL LCMGET(JPSYS,'PJJX$MCCG',PJJ) + ELSEIF(IDIR.EQ.2) THEN + CALL LCMGET(JPSYS,'PJJY$MCCG',PJJ) + ELSEIF(IDIR.EQ.3) THEN + CALL LCMGET(JPSYS,'PJJZ$MCCG',PJJ) + ENDIF + DO I=1,N1 + J=IPERM(I) + IBM=NZON(J) + IF(IBM.GE.0) THEN + DO IMOD=1,NPJJM + INU1=PJJIND(IMOD,1) + INU2=PJJIND(IMOD,2) + IF((INU1.EQ.1).AND.(INU2.NE.1)) THEN + IND2=KEYFLX(J,INU2) + AR(I,II)=AR(I,II)+PJJ(J,IMOD)*ARSCR(IND2,II) + ELSEIF((INU2.EQ.1).AND.(INU1.NE.1)) THEN + IND1=KEYFLX(J,INU1) + AR(I,II)=AR(I,II)+PJJ(J,IMOD)*ARSCR(IND1,II) + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF + ENDIF + ENDDO + DEALLOCATE(PJJ) + ENDIF +*--- +* ITERATIVE APPROACH TO SOLVE THE PRECONDITIONING SYSTEM +*--- +* --- +* GROUP PER GROUP PROCEDURE +* --- + IF(MACFLG) THEN +* MULTIGROUP REBALANCING (GAUSS-SEIDEL SCHEME) + NGTYP='GAUSS-SEIDEL' + PSI(:N1,:NGEFF)=0.0D0 + NGFAST=NGEFF + IF(REBFLG) THEN +* ONLY FOR FAST GROUPS (thermal group will be treated iteratively) + DO II=1,NGEFF + IF(NCONV(II)) THEN + IG=NGIND(II) + KPMACR=LCMGIL(JPMACR,IG) + CALL LCMGET(KPMACR,'IJJS00',IJJ(1)) + DO IBM=1,M + IF(IJJ(IBM).GT.IG) THEN + NGFAST=II-1 ! last fast group index in NGEFF format + GOTO 5 + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF + ELSE +* INNER ITERATION ACCELERATION + NGTYP=' ONE-GROUP' + NGFAST=NGEFF + ENDIF + 5 CONTINUE + DO II=1,NGFAST + IF(NCONV(II)) THEN +* infinite norm of group scalar flux + FLXN=0.0 + DO I=1,NREG + IND=KEYFLX(I,1) + TEMP=REAL(ABS(PHIOUT(IND,II))) + FLXN=MAX(TEMP,FLXN) + ENDDO + IF(MACFLG) THEN +* contribution from other groups (Gauss-Seidel multigroup +* scheme without iterations) + IG=NGIND(II) + KPMACR=LCMGIL(JPMACR,IG) + CALL LCMGET(KPMACR,'NJJS00',NJJ(1)) + CALL LCMGET(KPMACR,'IJJS00',IJJ(1)) + CALL LCMGET(KPMACR,'IPOS00',IPOS(1)) + CALL LCMGET(KPMACR,'SCAT00',XSCAT(1)) + DO I=1,N1 + J=IPERM(I) + IBM=NZON(J) + IF(IBM.GT.0) THEN + JG=IJJ(IBM) + DO 10 JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + JJ=NGINDV(JG) + IF(JJ.GT.0) THEN + AR(I,II)=AR(I,II)+XSCAT(IPOS(IBM)+JND-1)* + 1 PSI(I,JJ) + ENDIF + ENDIF + JG=JG-1 + 10 CONTINUE + ENDIF + ENDDO + ENDIF +* apply preconditioner to RHS + IG=NGIND(II) + JPSYS=KPSYS(II) + CALL LCMGPD(JPSYS,'DIAGQ$MCCG',DIAGQ_PTR) + CALL LCMGPD(JPSYS,'CQ$MCCG',CQ_PTR) + CALL C_F_POINTER(DIAGQ_PTR,DIAGQ,(/ N1 /)) + CALL C_F_POINTER(CQ_PTR,CQ,(/ LC /)) + IF(PACA.GE.2) THEN + CALL LCMGPD(JPSYS,'ILUDF$MCCG',LUDF_PTR) + CALL C_F_POINTER(LUDF_PTR,LUDF,(/ N1 /)) + IF(PACA.LT.4) THEN + CALL LCMGPD(JPSYS,'ILUCF$MCCG',LUCF_PTR) + CALL C_F_POINTER(LUCF_PTR,LUCF,(/ LC /)) + ENDIF + IF(PACA.GE.3) THEN + CALL LCMGPD(JPSYS,'CF$MCCG',CF_PTR) + CALL C_F_POINTER(CF_PTR,CF,(/ N1 /)) + ENDIF + ELSE IF(PACA.EQ.1) THEN + CALL LCMGPD(JPSYS,'DIAGF$MCCG',DIAGF_PTR) + CALL C_F_POINTER(DIAGF_PTR,DIAGF,(/ LC /)) + ENDIF + CALL MCGPRA(LFORW,3,PACA,.TRUE.,N1,LC,IM,MCU,JU,DIAGQ,CQ, + 1 LUDF,LUCF,DIAGF,AR(1,II),PSI(1,II),LC0,IM0,MCU0,CF) +* group per group BICGSTAB + JPSYS=KPSYS(II) + CALL LCMGPD(JPSYS,'DIAGF$MCCG',DIAGF_PTR) + CALL LCMGPD(JPSYS,'CF$MCCG',CF_PTR) + CALL C_F_POINTER(DIAGF_PTR,DIAGF,(/ N1 /)) + CALL C_F_POINTER(CF_PTR,CF,(/ LC /)) + IF(PACA.GE.2) THEN + CALL LCMGPD(JPSYS,'ILUDF$MCCG',LUDF_PTR) + CALL C_F_POINTER(LUDF_PTR,LUDF,(/ N1 /)) + IF(PACA.LT.4) THEN + CALL LCMGPD(JPSYS,'ILUCF$MCCG',LUCF_PTR) + CALL C_F_POINTER(LUCF_PTR,LUCF,(/ LC /)) + ENDIF + ENDIF + CALL MCGABG(IPRINT,LFORW,PACA,N1,LC,EPSACA,MXACA,IM,MCU, + 1 JU,DIAGF,CF,LUDF,LUCF,AR(1,II),PSI(1,II),FLXN,LC0, + 2 IM0,MCU0) + ENDIF + ENDDO +* + IF((REBFLG).AND.(IPRINT.GT.0)) THEN + IF(NGFAST.GT.0) WRITE(6,100) NGIND(1),NGIND(NGFAST),NGTYP + ELSE + IF(IPRINT.GT.1) WRITE(6,100) NGIND(1),NGIND(NGFAST),NGTYP + ENDIF +* + IF((REBFLG).AND.(NGFAST.LT.NGEFF)) THEN +* --- +* MULTIGROUP PROCEDURE +* --- +* THERMAL GROUPS REBALANCING + FLXN=0.0 + NFIRST=NGFAST+1 + DO II=NFIRST,NGEFF + IF(NCONV(II)) THEN +* infinite norm of multigroup (thermal groups) scalar flux + DO I=1,NREG + IND=KEYFLX(I,1) + TEMP=REAL(ABS(PHIOUT(IND,II))) + FLXN=MAX(TEMP,FLXN) + ENDDO +* contribution from fast groups to rhs + IG=NGIND(II) + KPMACR=LCMGIL(JPMACR,IG) + CALL LCMGET(KPMACR,'NJJS00',NJJ(1)) + CALL LCMGET(KPMACR,'IJJS00',IJJ(1)) + CALL LCMGET(KPMACR,'IPOS00',IPOS(1)) + CALL LCMGET(KPMACR,'SCAT00',XSCAT(1)) + DO I=1,N1 + J=IPERM(I) + IBM=NZON(J) + IF(IBM.GT.0) THEN + JG=IJJ(IBM) + DO 20 JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + JJ=NGINDV(JG) + IF((JJ.GT.0).AND.(JJ.LE.NGFAST)) THEN + AR(I,II)=AR(I,II)+XSCAT(IPOS(IBM)+JND-1)* + 1 PSI(I,JJ) + ENDIF + ENDIF + JG=JG-1 + 20 CONTINUE + ENDIF + ENDDO + ENDIF + ENDDO +* apply preconditioner to RHS + DO II=NFIRST,NGEFF + IF(NCONV(II)) THEN + JPSYS=KPSYS(II) + CALL LCMGPD(JPSYS,'DIAGQ$MCCG',DIAGQ_PTR) + CALL LCMGPD(JPSYS,'CQ$MCCG',CQ_PTR) + CALL C_F_POINTER(DIAGQ_PTR,DIAGQ,(/ 1 /)) + CALL C_F_POINTER(CQ_PTR,CQ,(/ 1 /)) + IF(PACA.GE.2) THEN + CALL LCMGPD(JPSYS,'ILUDF$MCCG',LUDF_PTR) + CALL C_F_POINTER(LUDF_PTR,LUDF,(/ 1 /)) + IF(PACA.LT.4) THEN + CALL LCMGPD(JPSYS,'ILUCF$MCCG',LUCF_PTR) + CALL C_F_POINTER(LUCF_PTR,LUCF,(/ 1 /)) + ENDIF + IF(PACA.GE.3) THEN + CALL LCMGPD(JPSYS,'CF$MCCG',CF_PTR) + CALL C_F_POINTER(CF_PTR,CF,(/ 1 /)) + ENDIF + ELSEIF(PACA.EQ.1) THEN + CALL LCMGPD(JPSYS,'DIAGF$MCCG',DIAGF_PTR) + CALL C_F_POINTER(DIAGF_PTR,DIAGF,(/ 1 /)) + ENDIF + CALL MCGPRA(LFORW,3,PACA,.TRUE.,N1,LC,IM,MCU,JU,DIAGQ,CQ, + 1 LUDF,LUCF,DIAGF,AR(1,II),PSI(1,II),LC0,IM0,MCU0,CF) + ENDIF + ENDDO +* multigroup BICGSTAB + CALL MCGABGR(IPRINT,LFORW,PACA,N1,NG,NFIRST,NGEFF,M,LC,NGIND, + 1 NGINDV,NCONV,KPSYS,JPMACR,NZON,IPERM,IM,MCU,JU,EPSACA, + 2 MXACA,AR,PSI,FLXN,LC0,IM0,MCU0) + ENDIF +*---- +* PERFORM THE CORRECTION +*---- + IF(COMBFLG) THEN +* ----------------------------------------------- +* ACA is combined in a three-step scheme with SCR +* ----------------------------------------------- + ALLOCATE(PJJ(NREG,NPJJM)) + CALL LCMGPD(IPTRK,'PJJIND$MCCG',PJJIND_PTR) + CALL C_F_POINTER(PJJIND_PTR,PJJIND,(/ NPJJM,2 /)) + DO II=1,NGEFF + IF(NCONV(II)) THEN + IG=NGIND(II) + JPSYS=KPSYS(II) + CALL LCMGET(JPSYS,'DRAGON-S0XSC',XSW) + IF(MACFLG) THEN + KPMACR=LCMGIL(JPMACR,IG) + CALL LCMGET(KPMACR,'NJJS00',NJJ(1)) + CALL LCMGET(KPMACR,'IJJS00',IJJ(1)) + CALL LCMGET(KPMACR,'IPOS00',IPOS(1)) + CALL LCMGET(KPMACR,'SCAT00',XSCAT(1)) + ENDIF + IF(IDIR.EQ.0) THEN + CALL LCMGET(JPSYS,'PJJ$MCCG',PJJ) + ELSEIF(IDIR.EQ.1) THEN + CALL LCMGET(JPSYS,'PJJX$MCCG',PJJ) + ELSEIF(IDIR.EQ.2) THEN + CALL LCMGET(JPSYS,'PJJY$MCCG',PJJ) + ELSEIF(IDIR.EQ.3) THEN + CALL LCMGET(JPSYS,'PJJZ$MCCG',PJJ) + ENDIF + DO I=1,N1 + J=IPERM(I) + IBM=NZON(J) + IF(IBM.GE.0) THEN +* Flux Correction + IND=KEYFLX(J,1) + PHIOUT(IND,II)=PHIOUT(IND,II) + 1 +(1.0-PJJ(J,1)*XSW(IBM,1))*PSI(I,II) + DO IMOD=1,NPJJM + INU1=PJJIND(IMOD,1) + INU2=PJJIND(IMOD,2) + IF(INU1.EQ.1) THEN + IND2=KEYFLX(J,INU2) + PHIOUT(IND,II)=PHIOUT(IND,II) + 1 -PJJ(J,IMOD)*ARSCR(IND2,II) + ELSEIF(INU2.EQ.1) THEN + IND1=KEYFLX(J,INU1) + PHIOUT(IND,II)=PHIOUT(IND,II) + 1 -PJJ(J,IMOD)*ARSCR(IND1,II) + ENDIF + ENDDO + IF(MACFLG) THEN + JG=IJJ(IBM) + DO 30 JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + JJ=NGINDV(JG) + IF(JJ.GT.0) THEN + PHIOUT(IND,II)=PHIOUT(IND,II)-PJJ(J,1)* + 1 XSCAT(IPOS(IBM)+JND-1)*PSI(I,JJ) + ENDIF + ENDIF + JG=JG-1 + 30 CONTINUE + ENDIF + ELSE +* Current Correction + IND=KEYCUR(J-NREG) + PHIOUT(IND,II)=PHIOUT(IND,II)+PSI(I,II) + ENDIF + ENDDO + ENDIF + ENDDO + DEALLOCATE(PJJ) + ELSE +* ----------------- +* ACA is used alone +* ----------------- + DO II=1,NGEFF + IF(NCONV(II)) THEN + DO I=1,N1 + J=IPERM(I) + IF(NZON(J).GE.0) THEN +* Flux Correction + IND=KEYFLX(J,1) + PHIOUT(IND,II)=PHIOUT(IND,II)+PSI(I,II) + ELSE +* Current Correction + IND=KEYCUR(J-NREG) + PHIOUT(IND,II)=PHIOUT(IND,II)+PSI(I,II) + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + IF(MACFLG) DEALLOCATE(XSCAT,IPOS,IJJ,NJJ) + DEALLOCATE(ARSCR,XSW,PSI,AR,NGINDV) + RETURN +* + 100 FORMAT(10X,11HACA: GROUPS,I4,3H TO,I4,2H: ,A12,7H SCHEME) + END diff --git a/Dragon/src/MCGFCF.f b/Dragon/src/MCGFCF.f new file mode 100644 index 0000000..6cffc54 --- /dev/null +++ b/Dragon/src/MCGFCF.f @@ -0,0 +1,496 @@ +*DECK MCGFCF + SUBROUTINE MCGFCF(SUBFFI,SUBFFA,SUBLDC,SUBSCH,IFTRAK,NBTR,NMAX, + 1 NDIM,KPN,K,NREG,M,NGEFF,NANGL,NMU,NLF,NFUNL, + 2 NMOD,NLFX,NLIN,NFUNLX,KEYFLX,KEYCUR,NZON,NCONV, + 3 CAZ0,CAZ1,CAZ2,CPO,ZMU,WZMU,S,SIGAL,ISGNR,IDIR, + 4 NSOUT,NBATCH,XSI,PHI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Flux integration upon the non-cyclic tracking. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* SUBFFI flux integration subroutine with isotropic source. +* SUBFFA flux integration subroutine with anisotropic source. +* SUBLDC flux integration subroutine with linear-discontinuous source. +* SUBSCH track coefficients calculation subroutine. +* IFTRAK tracking file unit number. +* NBTR total number of tracking lines. +* NMAX maximum number of elements in a track. +* NDIM number of dimensions for the geometry. +* KPN total number of unknowns in vectors PHI. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* NREG number of volumes. +* M number of material mixtures. +* NGEFF number of groups to process. +* NANGL number of tracking angles in the tracking file. +* NMU order of the polar quadrature in 2D / 1 in 3D. +* NLF number of Legendre orders for the flux. +* NFUNL number of moments of the flux (in 2D: NFUNL=NLF*(NLF+1)/2). +* NMOD first dimension of ISGNR. +* NLFX scattering anisotropy used to compute spherical harmonics. +* NLIN linear discontinuous flag (=1 SC/DD0; =3 LDC/DD1). +* NFUNLX number of spherical harmonics components. +* KEYFLX position of flux elements in PHI vector. +* KEYCUR position of current elements in PHI vector. +* NZON index-number of the mixture type assigned to each volume. +* NCONV logical array of convergence status for each group (.TRUE. +* not converged). +* CAZ0 cosines of the tracking polar angles in 3D. +* CAZ1 first cosines of the different tracking azimuthal angles. +* CAZ2 second cosines of the different tracking azimuthal angles. +* CPO cosines of the different tracking polar angles in 2D. +* ZMU polar quadrature set in 2D. +* WZMU polar quadrature set in 2D. +* S total source vector components. +* SIGAL total cross-section and albedo array. +* ISGNR sign of correction. +* IDIR direction of fundamental current for TIBERE with MoC +* (=0,1,2,3). +* NSOUT number of outer surfaces. +* NBATCH number of tracks processed in each OpenMP core (default: =1). +* XSI x,y and z component of the shape parameter for TIBERE. +* +*Parameters: input/output +* PHI vector containing the zonal scalar flux. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NGEFF,K,KPN,M,NMAX,NDIM,NMU,NZON(K),NLF,NFUNL,NMOD, + 1 NLFX,NLIN,NFUNLX,NREG,KEYFLX(NREG,NLIN,NFUNL),KEYCUR(K-NREG), + 2 IFTRAK,NBTR,NANGL,ISGNR(NMOD,NFUNLX),IDIR,NSOUT,NBATCH + REAL CPO(NMU),ZMU(NMU),WZMU(NMU),SIGAL(-6:M,NGEFF) + DOUBLE PRECISION CAZ0(NANGL),CAZ1(NANGL),CAZ2(NANGL), + 1 PHI(KPN,NGEFF),S(KPN,NGEFF),XSI(NSOUT) + LOGICAL NCONV(NGEFF) + EXTERNAL SUBFFI,SUBFFA,SUBLDC,SUBSCH +*---- +* LOCAL VARIABLES +*---- + INTEGER I,II,ILINE,IMU,IANG0,NOMP,INDP,NOMM,INDM,NOMI,JF,IND, + 1 NSUB,INDX,INDY,IREG,I0,NDFUNLX,IBATCH,IL1 + REAL XMUANG(1) + DOUBLE PRECISION WEIGHT,Q0,Q1,Q0X,Q1X,Q0Y,Q1Y,ZMUI,OMEGA2(3),ZZZ +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NSEG,IANG + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NOM + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: RHARM,TRHAR + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: T2D,WEITF,B,FLUX + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: HTF,COEFI,FLUV, + 1 DFLUV + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: PHIV,DPHIV + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: STOT,DSTOT +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NSEG(NBATCH),WEITF(NBATCH),IANG(NBATCH),NOM(NMAX,NBATCH), + 1 HTF(NMAX,NBATCH),FLUX(KPN)) +*--- +* Compute flux and currents for this tracking line +*--- + PHI(:KPN,:NGEFF)=0.0D0 + IF((NLF.EQ.1).AND.(NLIN.EQ.1)) THEN +* -------------------- +* Isotropic Scattering +* -------------------- + ALLOCATE(B(2*NMAX)) + IF(NDIM.EQ.3) THEN +* --- +* 3D calculation -> no loop over the polar angle +* --- + DO IBATCH=1,(NBTR-1)/NBATCH+1 + DO ILINE=(IBATCH-1)*NBATCH+1,MIN(IBATCH*NBATCH,NBTR) + IL1=ILINE-(IBATCH-1)*NBATCH + READ(IFTRAK) NSUB,NSEG(IL1),WEITF(IL1),IANG(IL1), + 1 (NOM(I,IL1),I=1,NSEG(IL1)),(HTF(I,IL1),I=1,NSEG(IL1)) + IF(NSUB.NE.1) CALL XABORT('MCGFCF: NSUB.NE.1.') + ENDDO +*$OMP PARALLEL DO +*$OMP1 PRIVATE(IL1,OMEGA2,ZZZ,FLUX,ILINE,B) + DO II=1,NGEFF + IF(NCONV(II)) THEN + FLUX(:KPN)=0.0D0 + DO ILINE=(IBATCH-1)*NBATCH+1,MIN(IBATCH*NBATCH,NBTR) + IL1=ILINE-(IBATCH-1)*NBATCH +* MCGFFIR: 'Source Term Isolation' Strategy turned on +* MCGFFIS: 'Source Term Isolation' Strategy turned off +* MCGFFIT: 'MOCC/MCI' Iterative Strategy + OMEGA2(3)=CAZ0(IANG(IL1))*CAZ0(IANG(IL1)) + ZZZ=1.0D0/SQRT(1.0D0-OMEGA2(3)) + OMEGA2(1)=3.0D0*(CAZ1(IANG(IL1))/ZZZ)**2 + OMEGA2(2)=3.0D0*(CAZ2(IANG(IL1))/ZZZ)**2 + OMEGA2(3)=3.0D0*OMEGA2(3) + CALL SUBFFI(SUBSCH,K,KPN,M,NSEG(IL1),HTF(1,IL1), + 1 NOM(1,IL1),NZON,SIGAL(0,II),S(1,II),NREG,KEYFLX, + 2 KEYCUR,FLUX,B,WEITF(IL1),OMEGA2,IDIR,NSOUT,XSI) + ENDDO ! ILINE + PHI(:KPN,II)=PHI(:KPN,II)+FLUX(:KPN) + ENDIF + ENDDO ! II +*$OMP END PARALLEL DO + ENDDO ! IBATCH + ELSE +* --- +* 2D calculation -> loop over the polar angle +* --- + ALLOCATE(T2D(NMAX)) + DO IBATCH=1,(NBTR-1)/NBATCH+1 + DO ILINE=(IBATCH-1)*NBATCH+1,MIN(IBATCH*NBATCH,NBTR) + IL1=ILINE-(IBATCH-1)*NBATCH + READ(IFTRAK) NSUB,NSEG(IL1),WEITF(IL1),IANG(IL1), + 1 (NOM(I,IL1),I=1,NSEG(IL1)),(HTF(I,IL1),I=1,NSEG(IL1)) + IF(NSUB.NE.1) CALL XABORT('MCGFCF: NSUB.NE.1.') + ENDDO +*$OMP PARALLEL DO +*$OMP1 PRIVATE(IL1,OMEGA2,ZMUI,WEIGHT,I0,T2D,FLUX,IMU,ILINE,B) + DO II=1,NGEFF + IF(NCONV(II)) THEN + FLUX(:KPN)=0.0D0 + DO ILINE=(IBATCH-1)*NBATCH+1,MIN(IBATCH*NBATCH,NBTR) + IL1=ILINE-(IBATCH-1)*NBATCH + DO IMU=1,NMU + ZMUI=ZMU(IMU) + OMEGA2(1)=3.0D0*(CAZ1(IANG(IL1))/ZMUI)**2 + OMEGA2(2)=3.0D0*(CAZ2(IANG(IL1))/ZMUI)**2 + OMEGA2(3)=3.0D0*(1.0-1.0/ZMUI**2) + WEIGHT=WEITF(IL1)*DBLE(WZMU(IMU)) + DO I0=2,NSEG(IL1)-1 + T2D(I0)=HTF(I0,IL1)*ZMUI + ENDDO + CALL SUBFFI(SUBSCH,K,KPN,M,NSEG(IL1),T2D(1),NOM(1,IL1), + 1 NZON,SIGAL(0,II),S(1,II),NREG,KEYFLX,KEYCUR, + 2 FLUX,B,WEIGHT,OMEGA2,IDIR,NSOUT,XSI) + ENDDO + ENDDO ! ILINE + PHI(:KPN,II)=PHI(:KPN,II)+FLUX(:KPN) + ENDIF + ENDDO ! II +*$OMP END PARALLEL DO + ENDDO ! IBATCH + DEALLOCATE(T2D) + ENDIF + DEALLOCATE(B) + ELSE IF(NLIN.EQ.1) THEN +* ---------------------- +* Anisotropic Scattering +* ---------------------- + ALLOCATE(STOT(NMAX,NMU,2),B(2*NMAX)) + ALLOCATE(RHARM(NMU,NFUNL,NBATCH),TRHAR(NMU,NFUNL,2)) + IANG0=0 + IF(NDIM.EQ.3) THEN +* --- +* 3D calculation -> no loop over the polar angle +* --- + DO IBATCH=1,(NBTR-1)/NBATCH+1 + DO ILINE=(IBATCH-1)*NBATCH+1,MIN(IBATCH*NBATCH,NBTR) + IL1=ILINE-(IBATCH-1)*NBATCH + READ(IFTRAK) NSUB,NSEG(IL1),WEITF(IL1),IANG(IL1), + 1 (NOM(I,IL1),I=1,NSEG(IL1)),(HTF(I,IL1),I=1,NSEG(IL1)) + IF(NSUB.NE.1) CALL XABORT('MCGFCF: NSUB.NE.1.') + IF(IANG(IL1).NE.IANG0) THEN + IANG0=IANG(IL1) + XMUANG(1)=REAL(CAZ0(IANG(IL1))) + CALL MOCCHR(3,NLF-1,NFUNL,1,XMUANG(1),CAZ1(IANG(IL1)), + 1 CAZ2(IANG(IL1)),RHARM(1,1,IL1)) + ELSE IF(IL1.EQ.1) THEN + RHARM(:NMU,:NFUNL,IL1)=RHARM(:NMU,:NFUNL,NBATCH) + ELSE + RHARM(:NMU,:NFUNL,IL1)=RHARM(:NMU,:NFUNL,IL1-1) + ENDIF + ENDDO +*$OMP PARALLEL DO +*$OMP1 PRIVATE(IL1,TRHAR,NOMP,INDP,NOMM,INDM,STOT,NOMI,Q0,Q1,JF,IND) +*$OMP2 PRIVATE(FLUX,I0,ILINE,B) + DO II=1,NGEFF + IF(NCONV(II)) THEN + FLUX(:KPN)=0.0D0 + DO ILINE=(IBATCH-1)*NBATCH+1,MIN(IBATCH*NBATCH,NBTR) + IL1=ILINE-(IBATCH-1)*NBATCH + DO 10 JF=1,NFUNL + TRHAR(1,JF,1)=ISGNR(1,JF)*RHARM(1,JF,IL1) + TRHAR(1,JF,2)=ISGNR(NMOD,JF)*RHARM(1,JF,IL1) + 10 CONTINUE + STOT(:NMAX,:NMU,:2)=0.0D0 +* incoming flux in + direction + NOMP=NOM(1,IL1) + INDP=KEYCUR(-NOMP) +* incoming flux in - direction + NOMM=NOM(NSEG(IL1),IL1) + INDM=KEYCUR(-NOMM) + STOT(1,1,1)=WEITF(IL1)*S(INDP,II) + STOT(NSEG(IL1),1,2)=WEITF(IL1)*S(INDM,II) +* regional sources + DO I0=2,NSEG(IL1)-1 + NOMI=NOM(I0,IL1) + Q0=0.0D0 + Q1=0.0D0 + DO JF=1,NFUNL + IND=KEYFLX(NOMI,1,JF) + Q0=Q0+S(IND,II)*TRHAR(1,JF,1) + Q1=Q1+S(IND,II)*TRHAR(1,JF,2) + ENDDO + STOT(I0,1,1)=WEITF(IL1)*Q0 + STOT(I0,1,2)=WEITF(IL1)*Q1 + ENDDO +* MCGFFAR: 'Source Term Isolation' Strategy turned on +* MCGFFAS: 'Source Term Isolation' Strategy turned off +* MCGFFAT: 'MOCC/MCI' Iterative Strategy + CALL SUBFFA(SUBSCH,K,KPN,M,NSEG(IL1),HTF(1,IL1), + 1 NOM(1,IL1),NZON,SIGAL(0,II),STOT(1,1,1), + 2 STOT(1,1,2),NREG,1,NLF,NFUNL,TRHAR,KEYFLX, + 3 KEYCUR,1,FLUX,B) + ENDDO ! ILINE + PHI(:KPN,II)=PHI(:KPN,II)+FLUX(:KPN) + ENDIF + ENDDO ! II +*$OMP END PARALLEL DO + ENDDO ! IBATCH +* --- + ELSE +* --- +* 2D calculation -> loop over the polar angle +* --- + ALLOCATE(T2D(NMAX)) + IANG0=0 + DO IBATCH=1,(NBTR-1)/NBATCH+1 + DO ILINE=(IBATCH-1)*NBATCH+1,MIN(IBATCH*NBATCH,NBTR) + IL1=ILINE-(IBATCH-1)*NBATCH + READ(IFTRAK) NSUB,NSEG(IL1),WEITF(IL1),IANG(IL1), + 1 (NOM(I,IL1),I=1,NSEG(IL1)),(HTF(I,IL1),I=1,NSEG(IL1)) + IF(NSUB.NE.1) CALL XABORT('MCGFCF: NSUB.NE.1.') + IF(IANG(IL1).NE.IANG0) THEN + IANG0=IANG(IL1) + CALL MOCCHR(2,NLF-1,NFUNL,NMU,CPO(1),CAZ1(IANG(IL1)), + 1 CAZ2(IANG(IL1)),RHARM(1,1,IL1)) + ELSE IF(IL1.EQ.1) THEN + RHARM(:NMU,:NFUNL,IL1)=RHARM(:NMU,:NFUNL,NBATCH) + ELSE + RHARM(:NMU,:NFUNL,IL1)=RHARM(:NMU,:NFUNL,IL1-1) + ENDIF + ENDDO +*$OMP PARALLEL DO +*$OMP1 PRIVATE(IL1,TRHAR,NOMP,INDP,NOMM,INDM,NOMI,IMU,WEIGHT,STOT,I0) +*$OMP2 PRIVATE(JF,Q0,Q1,ZMUI,T2D,FLUX,ILINE,B) + DO II=1,NGEFF + IF(NCONV(II)) THEN + FLUX(:KPN)=0.0D0 + DO ILINE=(IBATCH-1)*NBATCH+1,MIN(IBATCH*NBATCH,NBTR) + IL1=ILINE-(IBATCH-1)*NBATCH + DO 25 JF=1,NFUNL + DO 20 IMU=1,NMU + TRHAR(IMU,JF,1)=ISGNR(1,JF)*RHARM(IMU,JF,IL1) + TRHAR(IMU,JF,2)=ISGNR(NMOD,JF)*RHARM(IMU,JF,IL1) + 20 CONTINUE + 25 CONTINUE + STOT(:NMAX,:NMU,:2)=0.0D0 +* incoming flux in + direction + NOMP=NOM(1,IL1) + INDP=KEYCUR(-NOMP) +* incoming flux in - direction + NOMM=NOM(NSEG(IL1),IL1) + INDM=KEYCUR(-NOMM) + DO IMU=1,NMU + WEIGHT=WEITF(IL1)*DBLE(WZMU(IMU)) + STOT(1,IMU,1)=WEIGHT*S(INDP,II) + STOT(NSEG(IL1),IMU,2)=WEIGHT*S(INDM,II) + ENDDO +* regional sources + DO I0=2,NSEG(IL1)-1 + NOMI=NOM(I0,IL1) + DO IMU=1,NMU + Q0=0.0D0 + Q1=0.0D0 + WEIGHT=WEITF(IL1)*DBLE(WZMU(IMU)) + DO JF=1,NFUNL + IND=KEYFLX(NOMI,1,JF) + Q0=Q0+S(IND,II)*TRHAR(IMU,JF,1) + Q1=Q1+S(IND,II)*TRHAR(IMU,JF,2) + ENDDO + STOT(I0,IMU,1)=WEIGHT*Q0 + STOT(I0,IMU,2)=WEIGHT*Q1 + ENDDO + ENDDO + DO IMU=1,NMU + ZMUI=ZMU(IMU) + WEIGHT=WEITF(IL1)*DBLE(WZMU(IMU)) + DO I=2,NSEG(IL1)-1 + T2D(I)=HTF(I,IL1)*ZMUI + ENDDO + CALL SUBFFA(SUBSCH,K,KPN,M,NSEG(IL1),T2D(1),NOM(1,IL1), + 1 NZON,SIGAL(0,II),STOT(1,IMU,1),STOT(1,IMU,2), + 2 NREG,NMU,NLF,NFUNL,TRHAR,KEYFLX,KEYCUR,IMU,FLUX,B) + ENDDO + ENDDO ! ILINE + PHI(:KPN,II)=PHI(:KPN,II)+FLUX(:KPN) + ENDIF + ENDDO ! II +*$OMP END PARALLEL DO + ENDDO ! IBATCH +* --- + DEALLOCATE(T2D) + ENDIF + DEALLOCATE(TRHAR,RHARM,B,STOT) + ELSE IF(NLIN.EQ.3) THEN +* ----------------------------------------- +* Linear discontinuous source approximation +* ----------------------------------------- + NDFUNLX=NDIM*NFUNLX + ALLOCATE(B(6*NMAX)) + ALLOCATE(RHARM(NMU,NFUNLX,NBATCH),TRHAR(NMU,NFUNLX,2)) + ALLOCATE(PHIV(NFUNLX,NREG,NGEFF),DPHIV(NDFUNLX,NREG,NGEFF)) + ALLOCATE(FLUV(NFUNLX,NREG),DFLUV(NDFUNLX,NREG)) + ALLOCATE(STOT(NMAX,NMU,2),DSTOT(NMAX,NMU,2)) + DO II=1,NGEFF + IF(NCONV(II)) THEN + PHIV(:NFUNLX,:NREG,II)=0.0D0 + DPHIV(:NDFUNLX,:NREG,II)=0.0D0 + ENDIF + ENDDO + IF(NDIM.EQ.3) THEN + CALL XABORT('MCGFCF: 3D LDC APPROXIMATION NOT IMPLEMENTED') + ELSE +* --- +* 2D calculation -> loop over the polar angle +* --- + ALLOCATE(T2D(NMAX)) + IANG0=0 + DO IBATCH=1,(NBTR-1)/NBATCH+1 + DO ILINE=(IBATCH-1)*NBATCH+1,MIN(IBATCH*NBATCH,NBTR) + IL1=ILINE-(IBATCH-1)*NBATCH + READ(IFTRAK) NSUB,NSEG(IL1),WEITF(IL1),IANG(IL1), + 1 (NOM(I,IL1),I=1,NSEG(IL1)),(HTF(I,IL1),I=1,NSEG(IL1)) + IF(NSUB.NE.1) CALL XABORT('MCGFCF: NSUB.NE.1.') + IF(IANG(IL1).NE.IANG0) THEN + IANG0=IANG(IL1) + CALL MOCCHR(2,NLFX-1,NFUNLX,NMU,CPO(1),CAZ1(IANG(IL1)), + 1 CAZ2(IANG(IL1)),RHARM(1,1,IL1)) + ELSE IF(IL1.EQ.1) THEN + RHARM(:NMU,:NFUNLX,IL1)=RHARM(:NMU,:NFUNLX,NBATCH) + ELSE + RHARM(:NMU,:NFUNLX,IL1)=RHARM(:NMU,:NFUNLX,IL1-1) + ENDIF + ENDDO +*$OMP PARALLEL DO +*$OMP1 PRIVATE(IL1,JF,IMU,TRHAR,NOMP,INDP,NOMM,INDM,NOMI,STOT,DSTOT,I0) +*$OMP2 PRIVATE(ZMUI,WEIGHT,T2D,FLUX,FLUV,DFLUV,ILINE,B,Q0,Q1,Q0X,Q1X) +*$OMP3 PRIVATE(Q0Y,Q1Y,IND,INDX,INDY) + DO II=1,NGEFF + IF(NCONV(II)) THEN + FLUX(:KPN)=0.0D0 + FLUV(:NFUNLX,:NREG)=0.0D0 + DFLUV(:NDFUNLX,:NREG)=0.0D0 + DO ILINE=(IBATCH-1)*NBATCH+1,MIN(IBATCH*NBATCH,NBTR) + IL1=ILINE-(IBATCH-1)*NBATCH + DO 35 JF=1,NFUNLX + DO 30 IMU=1,NMU + TRHAR(IMU,JF,1)=ISGNR(1,JF)*RHARM(IMU,JF,IL1) + TRHAR(IMU,JF,2)=ISGNR(NMOD,JF)*RHARM(IMU,JF,IL1) + 30 CONTINUE + 35 CONTINUE + STOT(:NMAX,:NMU,:2)=0.0D0 + DSTOT(:NMAX,:NMU,:2)=0.0D0 +* incoming flux in + direction + NOMP=NOM(1,IL1) + INDP=KEYCUR(-NOMP) +* incoming flux in - direction + NOMM=NOM(NSEG(IL1),IL1) + INDM=KEYCUR(-NOMM) + DO IMU=1,NMU + STOT(1,IMU,1)=S(INDP,II) + STOT(NSEG(IL1),IMU,2)=S(INDM,II) + ENDDO +* regional sources + DO I0=2,NSEG(IL1)-1 + NOMI=NOM(I0,IL1) + DO IMU=1,NMU + Q0=0.0D0 + Q1=0.0D0 + Q0X=0.0D0 + Q1X=0.0D0 + Q0Y=0.0D0 + Q1Y=0.0D0 + DO JF=1,NFUNL + IND=KEYFLX(NOMI,1,JF) + INDX=KEYFLX(NOMI,2,JF) + INDY=KEYFLX(NOMI,3,JF) + Q0=Q0+S(IND,II)*TRHAR(IMU,JF,1) + Q1=Q1+S(IND,II)*TRHAR(IMU,JF,2) + Q0X=Q0X+S(INDX,II)*TRHAR(IMU,JF,1) + Q1X=Q1X+S(INDX,II)*TRHAR(IMU,JF,2) + Q0Y=Q0Y+S(INDY,II)*TRHAR(IMU,JF,1) + Q1Y=Q1Y+S(INDY,II)*TRHAR(IMU,JF,2) + ENDDO + STOT(I0,IMU,1)=Q0 + STOT(I0,IMU,2)=Q1 + DSTOT(I0,IMU,1)=Q0X*CAZ1(IANG(IL1))+Q0Y* + 1 CAZ2(IANG(IL1)) + DSTOT(I0,IMU,2)=-Q1X*CAZ1(IANG(IL1))-Q1Y* + 1 CAZ2(IANG(IL1)) + ENDDO + ENDDO + DO IMU=1,NMU + ZMUI=ZMU(IMU) + WEIGHT=WEITF(IL1)*DBLE(WZMU(IMU)) + DO I0=2,NSEG(IL1)-1 + T2D(I0)=HTF(I0,IL1)*ZMUI + ENDDO +* MCGFFAL: 'Source Term Isolation' Strategy turned off + CALL SUBLDC(SUBSCH,K,KPN,M,NSEG(IL1),T2D,NOM(1,IL1), + 1 NZON,WEIGHT,SIGAL(0,II),STOT(1,IMU,1), + 2 STOT(1,IMU,2),DSTOT(1,IMU,1),DSTOT(1,IMU,2),NREG, + 3 NMU,NLF,NFUNLX,TRHAR,KEYCUR,IMU,B,FLUX,FLUV,DFLUV) + ENDDO + ENDDO ! ILINE + PHI(:KPN,II)=PHI(:KPN,II)+FLUX(:KPN) + PHIV(:NFUNLX,:NREG,II)=PHIV(:NFUNLX,:NREG,II)+ + 1 FLUV(:NFUNLX,:NREG) + DPHIV(:NDFUNLX,:NREG,II)=DPHIV(:NDFUNLX,:NREG,II)+ + 1 DFLUV(:NDFUNLX,:NREG) + ENDIF + ENDDO ! II +*$OMP END PARALLEL DO + ENDDO ! IBATCH + ALLOCATE(COEFI(2*NFUNLX,2*NFUNLX)) + CALL MCGCOEF(NFUNLX,NMU,ZMU,WZMU,NANGL,CAZ1,CAZ2,COEFI) + DO II=1,NGEFF + IF(NCONV(II)) THEN + DO IREG=1,NREG + DPHIV(:,IREG,II)=MATMUL(COEFI,DPHIV(:,IREG,II)) + DO JF=1,NFUNL + PHI(KEYFLX(IREG,1,JF),II)=PHIV(JF,IREG,II) + PHI(KEYFLX(IREG,2,JF),II)=DPHIV(JF,IREG,II) + PHI(KEYFLX(IREG,3,JF),II)=DPHIV(NFUNLX+JF,IREG,II) + ENDDO + ENDDO + ENDIF + ENDDO + DEALLOCATE(COEFI) +* --- + DEALLOCATE(T2D) + ENDIF + DEALLOCATE(DSTOT,STOT,DFLUV,FLUV,DPHIV,PHIV) + DEALLOCATE(TRHAR,RHARM,B) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(FLUX,HTF,NOM,IANG,WEITF,NSEG) + RETURN + END diff --git a/Dragon/src/MCGFCR.f b/Dragon/src/MCGFCR.f new file mode 100644 index 0000000..4503da9 --- /dev/null +++ b/Dragon/src/MCGFCR.f @@ -0,0 +1,136 @@ +*DECK MCGFCR + SUBROUTINE MCGFCR(IPRINT,IG,II,NG,NGEFF,KPN,N,NREG,NANI,NFUNL,M, + 1 LTYPE,KEYFLX,KEYCUR,NZON,NGINDV,REBAL,FI,FIOLD, + 2 SC,TAB,NJJ,IJJ,IPOS,XSCAT,AR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute residual of a previous free iterations for ACA method. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IPRINT print parameter (equal to zero for no print). +* IG index of group to process in "NG format". +* II index of group to process in "NGEFF format". +* NG number of groups. +* NGEFF number of groups to process. +* KPN total number of unknowns in vectors SUNKNO and FUNKNO. +* N total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* NREG number of volumes. +* NANI scattering anisotropy (=1 for isotropic scattering). +* NFUNL number of moments of the flux (in 2D : NFUNL=NANI*(NANI+1)/2). +* M number of material mixtures. +* LTYPE flag to know how the residual vector is organized: +* .TRUE. for ACA, with permutation array, only the isotropic +* moments; +* .FALSE. for SCR, without permutation array, all the moments. +* KEYFLX position of flux elements in FI vector. +* KEYCUR position of current elements in FI vector. +* NZON index-number of the mixture type assigned to each volume. +* NGINDV index to pass from "NGEFF format" to "NG format" +* REBAL type of acceleration (.TRUE. rebalancing ; .FALSE. +* inner iterations acceleration). +* FI zonal scalar flux. +* SC macroscopic "in group" scattering cross section. +* FIOLD old zonal scalar flux. +* TAB if LTYPE, IPERM(N) permutation array, +* otherwise, KEYANI(NFUNL) 'mode to l' index: l=KEYANI(nu). +* NJJ scattering information. +* IJJ scattering information. +* IPOS scattering information. +* XSCAT scattering information. +* +*Parameters: output +* AR residual form previous free iteration. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IPRINT,IG,II,NG,NGEFF,KPN,N,NREG,NANI,NFUNL,M, + 1 KEYFLX(NREG,NFUNL),KEYCUR(*),TAB(*),NZON(N),NGINDV(NG), + 2 NJJ(0:M),IJJ(0:M),IPOS(0:M) + REAL FIOLD(KPN,NGEFF),SC(0:M,NANI),XSCAT(0:M*NG) + DOUBLE PRECISION AR(*),FI(KPN,NGEFF) + LOGICAL REBAL,LTYPE +* + IF(IPRINT.GT.99) WRITE(6,'(23H MCGFCR: PROCESS GROUPS,2I6)') IG,II +* + IF (LTYPE) THEN +*--- +* ACA RESIDUAL +*--- + DO I=1,N + J=TAB(I) + IBM=NZON(J) + IF(IBM.GE.0) THEN + SIGC=SC(IBM,1) + IND=KEYFLX(J,1) + ELSE + SIGC=0.5 + IND=KEYCUR(J-NREG) + ENDIF + AR(I)=(FI(IND,II)-FIOLD(IND,II))*SIGC + IF ((REBAL).AND.(IBM.GT.0)) THEN +* rebalancing option on : contribution from other groups. + JG=IJJ(IBM) + DO 10 JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + JJ=NGINDV(JG) + IF (JJ.GT.0) THEN + AR(I)=AR(I)+XSCAT(IPOS(IBM)+JND-1)* + 1 (FI(IND,JJ)-FIOLD(IND,JJ)) + ENDIF + ENDIF + JG=JG-1 + 10 CONTINUE + ENDIF + ENDDO + ELSE +*--- +* SCR RESIDUAL +*--- + DO I=1,N + IBM=NZON(I) + IF(IBM.GE.0) THEN + DO INU=1,NFUNL + IND=KEYFLX(I,INU) + IL=TAB(INU) + SIGC=REAL(2*IL+1)*SC(IBM,IL+1) + AR(IND)=(FI(IND,II)-FIOLD(IND,II))*SIGC + ENDDO + ELSE + SIGC=0.5 + IND=KEYCUR(I-NREG) + AR(IND)=(FI(IND,II)-FIOLD(IND,II))*SIGC + ENDIF + IF ((REBAL).AND.(IBM.GT.0)) THEN +* rebalancing option on: contribution from other groups. + IND=KEYFLX(I,1) + JG=IJJ(IBM) + DO 20 JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + JJ=NGINDV(JG) + IF (JJ.GT.0) THEN + AR(IND)=AR(IND)+XSCAT(IPOS(IBM)+JND-1)* + 1 (FI(IND,JJ)-FIOLD(IND,JJ)) + ENDIF + ENDIF + JG=JG-1 + 20 CONTINUE + ENDIF + ENDDO + ENDIF + RETURN + END diff --git a/Dragon/src/MCGFCS.f b/Dragon/src/MCGFCS.f new file mode 100644 index 0000000..759ff03 --- /dev/null +++ b/Dragon/src/MCGFCS.f @@ -0,0 +1,112 @@ +*DECK MCGFCS + SUBROUTINE MCGFCS(N,NDIM,NZON,QN,FI,M,NANI,NLIN,NFUNL,SC,S,KPN, + 1 NREG,IPRINT,KEYFLX,KEYCUR,IBC,SIGAL,STIS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of source for collision at iteration iter. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): I. Suslov and R. Le Tellier +* +*Parameters: input +* N number of spatial unknowns. +* NDIM number of dimensions for the geometry. +* NZON index-number of the mixture type assigned to each volume. +* QN input source (fission-other groups) vector. +* FI unknown vector. +* M number of material mixtures. +* NANI scattering anisotropy (=1 for isotropic scattering). +* NLIN linear discontinuous flag (=1 SC/DD0; =3 LDC/DD1). +* NFUNL number of spherical harmonics components. +* SC macroscopic scattering cross section. +* KPN total number of unknowns in vectors QN and FI. +* NREG number of volumes. +* IPRINT print parameter (equal to zero for no print). +* KEYFLX position of flux elements in FI vector. +* KEYCUR position of current elements in FI. +* IBC index for boundary condition to connect a surface to another. +* STIS integration strategy flag. +* SIGAL total cross-section and albedo array. +* +*Parameters: output +* S source elements vector. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,NDIM,NZON(N),M,NANI,NLIN,NFUNL,KPN,NREG,IPRINT, + 1 KEYFLX(NREG,NLIN,NFUNL),KEYCUR(N-NREG),IBC(N-NREG),STIS + REAL QN(KPN),FI(KPN),SC(0:M,NANI),SIGAL(-6:M) + DOUBLE PRECISION S(KPN) +* + IF(NDIM.EQ.2) THEN +* 2D geometry + DO IR=1,N + IBM=NZON(IR) + IF(IBM.LT.0) THEN +* Boundary condition + ISUR=IR-NREG + ISUR2=IBC(ISUR) + IND=KEYCUR(ISUR) + IND2=KEYCUR(ISUR2) + IF(IND.GT.0) S(IND)=SIGAL(IBM)*FI(IND2) + ELSEIF(IBM.GE.0) THEN +* Volume cell + DO IL=0,NANI-1 + XSC=REAL(2*IL+1)*SC(IBM,IL+1) + DO IM=0,IL + DO IE=1,NLIN + IND=KEYFLX(IR,IE,1+IL*(IL+1)/2+IM) + IF(IND.GT.0) THEN + S(IND)=QN(IND)+XSC*FI(IND) + IF(STIS.EQ.-1) S(IND)=S(IND)/SIGAL(IBM) + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF + ENDDO + ELSE ! NDIM.EQ.3 +* 3D geometry + DO IR=1,N + IBM=NZON(IR) + IF(IBM.LT.0) THEN +* Boundary condition + ISUR=IR-NREG + ISUR2=IBC(ISUR) + IND=KEYCUR(ISUR) + IND2=KEYCUR(ISUR2) + IF(IND.GT.0) S(IND)=SIGAL(IBM)*FI(IND2) + ELSEIF(IBM.GE.0) THEN +* Volume cell + INDA=0 + DO IL=0,NANI-1 + XSC=REAL(2*IL+1)*SC(IBM,IL+1) + DO IM=-IL,IL + DO IE=1,NLIN + INDA=INDA+1 + IND=KEYFLX(IR,IE,INDA) + IF(IND.GT.0) THEN + S(IND)=QN(IND)+XSC*FI(IND) + IF(STIS.EQ.-1) S(IND)=S(IND)/SIGAL(IBM) + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF + ENDDO + ENDIF +* + IF(IPRINT.GT.6) CALL PRINDM ('S ',S,KPN) + RETURN + END diff --git a/Dragon/src/MCGFFAL.f b/Dragon/src/MCGFFAL.f new file mode 100644 index 0000000..bda8917 --- /dev/null +++ b/Dragon/src/MCGFFAL.f @@ -0,0 +1,138 @@ +*DECK MCGFFAL + SUBROUTINE MCGFFAL(SUBSCH,K,KPN,M,N,H,NOM,NZON,WEIGHT,XST,SP,SM, + 1 DSP,DSM,NREG,NMU,NANI,NFUNLX,TRHAR,KEYCUR,IMU,B,F, + 2 PHIV,DPHIV) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of transport equation on a finite track. +* Linear-discontinuous-characteristics approximation. +* Ray-tracing (anisotropic scattering case,'source term isolation' off). +* +*Copyright: +* Copyright (C) 2015 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* SUBSCH track coefficients calculation subroutine. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* KPN total number of unknowns in vectors F. +* M number of material mixtures. +* N number of elements in the current track. +* H vector containing the lenght of the different segments of this +* track. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* WEIGHT track weight. +* XST macroscopic total cross section. +* SP total source vector for + direction. +* SM total source vector for - direction. +* DSP linear component of the total source vector for + direction. +* DSM linear component of the total source vector for - direction. +* NREG number of volumes. +* NMU order of the polar quadrature set. +* NANI scattering anisotropy (=1 for isotropic scattering). +* NFUNLX number of moments of the spherical harmonics. +* NMOD third dimension of TRHAR. +* TRHAR spherical harmonics components for this angle in the plane. +* KEYCUR position of current elements in PHI vector. +* IMU azimuthal angle corresponding to this track. +* +*Parameters: input/output +* F vector containing the zonal scalar flux (surface components). +* PHIV vector containing the zonal scalar flux (component 1). +* DPHIV vector containing the zonal scalar flux (components 2 and 3). +* +*Parameters: scratch +* B undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER K,KPN,M,N,NOM(N),NZON(K),NMU,NFUNLX,NREG, + 1 KEYCUR(K-NREG),IMU,NANI + REAL XST(0:M),TRHAR(NMU,NFUNLX,2) + DOUBLE PRECISION WEIGHT,H(N),SP(N),SM(N),DSP(N),DSM(N),B(0:5,N), + 1 F(KPN),PHIV(NFUNLX,NREG),DPHIV(2*NFUNLX,NREG) + EXTERNAL SUBSCH +*---- +* LOCAL VARIABLES +*--- + REAL ETA,XI + DOUBLE PRECISION F0,DF0,SI,SJ,DSI,DSJ,RM,RP,DSIG,DH + INTEGER I,NOMI,IND1,INDN,JF,J,NOMJ +*---- +* Calculation of the coefficients for this track. +*---- +* MCGSCAL: Linear discontinuous-Characteristics Scheme with +* Tabulated Exponentials +* MCGDDFL: Diamond-Differencing DD1 Scheme +* MCGSCEL: Linear discontinuous-Characteristics Scheme with +* Exact Exponentials + IF(NANI.LE.0) CALL XABORT('MCGFFAL: INVALID VALUE OF NANI.') + CALL SUBSCH(N,K,M,NOM,NZON,H,XST,B) +*---- +* Summation along the track in both directions +*---- +* incoming flux in + direction + IND1=KEYCUR(-NOM(1)) + RP=SP(1) +* incoming flux in - direction + INDN=KEYCUR(-NOM(N)) + RM=SM(N) +* track angles in 3D + ETA=TRHAR(IMU,3,1) + XI=TRHAR(IMU,2,1) + DO I=2,N-1 +* + direction + NOMI=NOM(I) + DSIG=XST(NZON(NOMI)) + DH=H(I) + SI=SP(I) + DSI=DSP(I) + F0=B(1,I)*RP+B(2,I)*SI+B(3,I)*DSI + DF0=B(4,I)*RP-B(3,I)*SI/(DH*DH)+B(5,I)*DSIG*DSI + RP=B(0,I)*RP+B(1,I)*SI-B(3,I)*DSIG*DSI + DO JF=1,NFUNLX + PHIV(JF,NOMI)=PHIV(JF,NOMI)+WEIGHT*F0*TRHAR(IMU,JF,1) + DPHIV(JF,NOMI)=DPHIV(JF,NOMI)+WEIGHT*DF0*ETA* + > TRHAR(IMU,JF,1) + DPHIV(NFUNLX+JF,NOMI)=DPHIV(NFUNLX+JF,NOMI)+WEIGHT*DF0*XI* + > TRHAR(IMU,JF,1) + ENDDO +* - direction + J=N+1-I + NOMJ=NOM(J) + DSIG=XST(NZON(NOMJ)) + DH=H(J) + SJ=SM(J) + DSJ=DSM(J) + F0=B(1,J)*RM+B(2,J)*SJ+B(3,J)*DSJ + DF0=B(4,J)*RM-B(3,J)*SJ/(DH*DH)+B(5,J)*DSIG*DSJ + RM=B(0,J)*RM+B(1,J)*SJ-B(3,J)*DSIG*DSJ + DO JF=1,NFUNLX + PHIV(JF,NOMJ)=PHIV(JF,NOMJ)+WEIGHT*F0*TRHAR(IMU,JF,2) + DPHIV(JF,NOMJ)=DPHIV(JF,NOMJ)-WEIGHT*DF0*ETA* + > TRHAR(IMU,JF,2) + DPHIV(NFUNLX+JF,NOMJ)=DPHIV(NFUNLX+JF,NOMJ)-WEIGHT*DF0*XI* + > TRHAR(IMU,JF,2) + ENDDO + ENDDO +* outgoing flux in + direction + F(INDN)=F(INDN)+WEIGHT*RP +* outgoing flux in - direction + F(IND1)=F(IND1)+WEIGHT*RM +* + RETURN + END diff --git a/Dragon/src/MCGFFAR.f b/Dragon/src/MCGFFAR.f new file mode 100644 index 0000000..a1872bc --- /dev/null +++ b/Dragon/src/MCGFFAR.f @@ -0,0 +1,110 @@ +*DECK MCGFFAR + SUBROUTINE MCGFFAR(SUBSCH,K,KPN,M,N,H,NOM,NZON,XST,SP,SM,NREG,NMU, + 1 NANI,NFUNL,TRHAR,KEYFLX,KEYCUR,IMU,F,B) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of transport equation on a track +* ray-tracing (anisotropic scattering,'source term isolation' on). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): I. Suslov and R. Le Tellier +* +*Parameters: input +* SUBSCH track coefficients calculation subroutine. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* KPN total number of unknowns in vectors F. +* M number of material mixtures. +* N number of elements in the current track. +* H vector containing the lenght of the different segments of this +* track. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* XST macroscopic total cross section. +* SP total source vector for + direction. +* SM total source vector for - direction. +* NREG number of volumes. +* NMU order of the polar quadrature set. +* NANI scattering anisotropy (=1 for isotropic scattering). +* NFUNL number of moments of the flux (in 2D : NFUNL=NANI*(NANI+1)/2). +* TRHAR spherical harmonics components for this angle in the plane. +* KEYFLX position of flux elements in PHI vector. +* KEYCUR position of current elements in PHI vector. +* IMU azimuthal angle corresponding to this track. +* +*Parameters: input/output +* F vector containing the zonal scalar flux. +* +*Parameters: scratch +* B undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER K,KPN,M,N,NOM(N),NZON(K),NMU,NFUNL,NREG, + 1 KEYFLX(NREG,NFUNL),KEYCUR(K-NREG),IMU,NANI + REAL XST(0:M),TRHAR(NMU,NFUNL,2) + DOUBLE PRECISION H(N),SP(N),SM(N),F(KPN),B(N) + EXTERNAL SUBSCH +*---- +* LOCAL VARIABLES +*--- + DOUBLE PRECISION F0,FAS,RP,RM + INTEGER I,NOMI,IND,IND1,INDN,JF,J,NOMJ +*---- +* Calculation of the coefficients for this track. +*---- +* MCGSCA: Step-Characteristics Scheme with Tabulated Exponentials +* MCGDDF: Diamond-Differencing Scheme +* MCGSCE: Step-Characteristics Scheme with Exact Exponentials + IF(NANI.LE.0) CALL XABORT('MCGFFA: INVALID VALUE OF NANI.') + CALL SUBSCH(N,K,M,NOM,NZON,H,XST,B) +*---- +* Summation along the track in both directions +*---- +* incoming flux in + direction + IND1=KEYCUR(-NOM(1)) + RP=SP(1) +* incoming flux in - direction + INDN=KEYCUR(-NOM(N)) + RM=SM(N) + DO I=2,N-1 +* + direction + NOMI=NOM(I) + FAS=SP(I) + F0=B(I)*RP + RP=RP+B(I)*(FAS-XST(NZON(NOMI))*RP) + DO JF=1,NFUNL + IND=KEYFLX(NOMI,JF) + F(IND)=F(IND)+F0*TRHAR(IMU,JF,1) + ENDDO +* - direction + J=N+1-I + NOMJ=NOM(J) + FAS=SM(J) + F0=B(J)*RM + RM=RM+B(J)*(FAS-XST(NZON(NOMJ))*RM) + DO JF=1,NFUNL + IND=KEYFLX(NOMJ,JF) + F(IND)=F(IND)+F0*TRHAR(IMU,JF,2) + ENDDO + ENDDO +* outgoing flux in + direction + F(INDN)=F(INDN)+RP +* outgoing flux in - direction + F(IND1)=F(IND1)+RM +* + RETURN + END diff --git a/Dragon/src/MCGFFAS.f b/Dragon/src/MCGFFAS.f new file mode 100644 index 0000000..0b30d77 --- /dev/null +++ b/Dragon/src/MCGFFAS.f @@ -0,0 +1,110 @@ +*DECK MCGFFAS + SUBROUTINE MCGFFAS(SUBSCH,K,KPN,M,N,H,NOM,NZON,XST,SP,SM,NREG,NMU, + 1 NANI,NFUNL,TRHAR,KEYFLX,KEYCUR,IMU,F,B) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of transport equation on a track +* ray-tracing (anisotropic scattering,'source term isolation' off). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): I. Suslov and R. Le Tellier +* +*Parameters: input +* SUBSCH track coefficients calculation subroutine. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* KPN total number of unknowns in vectors F. +* M number of material mixtures. +* N number of elements in the current track. +* H vector containing the lenght of the different segments of this +* track. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* XST macroscopic total cross section. +* SP total source vector for + direction. +* SM total source vector for - direction. +* NREG number of volumes. +* NMU order of the polar quadrature set. +* NANI scattering anisotropy (=1 for isotropic scattering). +* NFUNL number of moments of the flux (in 2D : NFUNL=NANI*(NANI+1)/2). +* TRHAR spherical harmonics components for this angle in the plane. +* KEYFLX position of flux elements in PHI vector. +* KEYCUR position of current elements in PHI vector. +* IMU azimuthal angle corresponding to this track. +* +*Parameters: input/output +* F vector containing the zonal scalar flux. +* +*Parameters: scratch +* B undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER K,KPN,M,N,NOM(N),NZON(K),NMU,NFUNL,NREG, + 1 KEYFLX(NREG,NFUNL),KEYCUR(K-NREG),IMU,NANI + REAL XST(0:M),TRHAR(NMU,NFUNL,2) + DOUBLE PRECISION H(N),SP(N),SM(N),F(KPN),B(2,N) + EXTERNAL SUBSCH +*---- +* LOCAL VARIABLES +*--- + DOUBLE PRECISION F0,SI,SJ,RM,RP + INTEGER I,NOMI,IND,IND1,INDN,JF,J,NOMJ +*---- +* Calculation of the coefficients for this track. +*---- +* MCGSCAS: Step-Characteristics Scheme with Tabulated Exponentials +* MCGDDFS: Diamond-Differencing Scheme +* MCGSCES: Step-Characteristics Scheme with Exact Exponentials + IF(NANI.LE.0) CALL XABORT('MCGFFAS: INVALID VALUE OF NANI.') + CALL SUBSCH(N,K,M,NOM,NZON,H,XST,B) +*---- +* Summation along the track in both directions +*---- +* incoming flux in + direction + IND1=KEYCUR(-NOM(1)) + RP=SP(1) +* incoming flux in - direction + INDN=KEYCUR(-NOM(N)) + RM=SM(N) + DO I=2,N-1 +* + direction + NOMI=NOM(I) + SI=SP(I) + F0=B(1,I)*RP+B(2,I)*SI + RP=RP+B(1,I)*(SI-XST(NZON(NOMI))*RP) + DO JF=1,NFUNL + IND=KEYFLX(NOMI,JF) + F(IND)=F(IND)+F0*TRHAR(IMU,JF,1) + ENDDO +* - direction + J=N+1-I + NOMJ=NOM(J) + SJ=SM(J) + F0=B(1,J)*RM+B(2,J)*SJ + RM=RM+B(1,J)*(SJ-XST(NZON(NOMJ))*RM) + DO JF=1,NFUNL + IND=KEYFLX(NOMJ,JF) + F(IND)=F(IND)+F0*TRHAR(IMU,JF,2) + ENDDO + ENDDO +* outgoing flux in + direction + F(INDN)=F(INDN)+RP +* outgoing flux in - direction + F(IND1)=F(IND1)+RM +* + RETURN + END diff --git a/Dragon/src/MCGFFAT.f b/Dragon/src/MCGFFAT.f new file mode 100644 index 0000000..b90ea7d --- /dev/null +++ b/Dragon/src/MCGFFAT.f @@ -0,0 +1,108 @@ +*DECK MCGFFAT + SUBROUTINE MCGFFAT(SUBSCH,K,KPN,M,N,H,NOM,NZON,XST,SP,SM,NREG,NMU, + 1 NANI,NFUNL,TRHAR,KEYFLX,KEYCUR,IMU,F,B) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of transport equation on a track +* ray-tracing (anisotropic scattering,'MOCC/MCI' integration strategy). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): I. Suslov and R. Le Tellier +* +*Parameters: input +* SUBSCH track coefficients calculation subroutine. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* KPN total number of unknowns in vectors F. +* M number of material mixtures. +* N number of elements in the current track. +* H vector containing the lenght of the different segments of this +* track. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* XST macroscopic total cross section. +* SP total source vector for + direction. +* SM total source vector for - direction. +* NREG number of volumes. +* NMU order of the polar quadrature set. +* NANI scattering anisotropy (=1 for isotropic scattering). +* NFUNL number of moments of the flux (in 2D : NFUNL=NANI*(NANI+1)/2). +* TRHAR spherical harmonics components for this angle in the plane. +* KEYFLX position of flux elements in PHI vector. +* KEYCUR position of current elements in PHI vector. +* IMU azimuthal angle corresponding to this track. +* +*Parameters: input/output +* F vector containing the zonal scalar flux. +* +*Parameters: scratch +* B undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER K,KPN,M,N,NOM(N),NZON(K),NMU,NFUNL,NREG, + 1 KEYFLX(NREG,NFUNL),KEYCUR(K-NREG),IMU,NANI + REAL XST(0:M),TRHAR(NMU,NFUNL,2) + DOUBLE PRECISION H(N),SP(N),SM(N),F(KPN),B(N) + EXTERNAL SUBSCH +*---- +* LOCAL VARIABLES +*--- + DOUBLE PRECISION F0,RP,RM + INTEGER I,NOMI,IND,IND1,INDN,JF,J,NOMJ +*---- +* Calculation of the coefficients for this track. +*---- +* MCGSCAT: Step-Characteristics Scheme with Tabulated Exponentials +* MCGDDFT: Diamond-Differencing Scheme +* MCGSCET: Step-Characteristics Scheme with Exact Exponentials + IF(NANI.LE.0) CALL XABORT('MCGFFAT: INVALID VALUE OF NANI.') + CALL SUBSCH(N,K,M,NOM,NZON,H,XST,B) +*---- +* Summation along the track in both directions +*---- +* incoming flux in + direction + IND1=KEYCUR(-NOM(1)) + RP=SP(1) +* incoming flux in - direction + INDN=KEYCUR(-NOM(N)) + RM=SM(N) + DO I=2,N-1 +* + direction + NOMI=NOM(I) + F0=B(I)*(RP-SP(I)) + RP=RP-F0 + DO JF=1,NFUNL + IND=KEYFLX(NOMI,JF) + F(IND)=F(IND)+F0*TRHAR(IMU,JF,1) + ENDDO +* - direction + J=N+1-I + NOMJ=NOM(J) + F0=B(J)*(RM-SM(J)) + RM=RM-F0 + DO JF=1,NFUNL + IND=KEYFLX(NOMJ,JF) + F(IND)=F(IND)+F0*TRHAR(IMU,JF,2) + ENDDO + ENDDO +* outgoing flux in + direction + F(INDN)=F(INDN)+RP +* outgoing flux in - direction + F(IND1)=F(IND1)+RM +* + RETURN + END diff --git a/Dragon/src/MCGFFIR.f b/Dragon/src/MCGFFIR.f new file mode 100644 index 0000000..91ad708 --- /dev/null +++ b/Dragon/src/MCGFFIR.f @@ -0,0 +1,131 @@ +*DECK MCGFFIR + SUBROUTINE MCGFFIR(SUBSCH,K,KPN,M,N,H,NOM,NZON,XST,S,NREG,KEYFLX, + 1 KEYCUR,F,B,W,OMEGA2,IDIR,NSOUT,XSI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of transport equation on a track +* ray-tracing (isotropic scattering case,'source term isolation' on). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): I. Suslov and R. Le Tellier +* +*Parameters: input +* SUBSCH track coefficients calculation subroutine. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* KPN total number of unknowns in vectors F. +* M number of material mixtures. +* N number of elements in the current track. +* H vector containing the lenght of the different segments of this +* track. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* XST macroscopic total cross section. +* S total source vector. +* NREG number of volumes. +* KEYFLX position of flux elements in PHI vector. +* KEYCUR position of current elements in PHI vector. +* W weight associated with this track. +* OMEGA2 square x, y and z-component of the direction +* Omega for 2D geometry. +* IDIR direction of fundamental current for TIBERE with MoC +* (=0,1,2,3). +* NSOUT number of outer surfaces. +* XSI x,y and z component of the shape parameter for TIBERE. +* +*Parameters: input/output +* F vector containing the zonal scalar flux. +* +*Parameters: scratch +* B undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER K,KPN,M,N,NOM(N),NZON(K),NREG,KEYFLX(NREG,1), + 1 KEYCUR(K-NREG),IDIR,NSOUT + REAL XST(0:M) + DOUBLE PRECISION W,H(N),S(KPN),F(KPN),B(N),OMEGA2(3) + DOUBLE PRECISION XSI(NSOUT) + EXTERNAL SUBSCH +*--- +* LOCAL VARIABLES +*--- + DOUBLE PRECISION F0,RP,RM,WW,SSS + INTEGER I,J,NOMI,IND,IND1,INDN,NOMJ,INDC +* + WW=DBLE(W) +*---- +* Calculation coefficients for this track. +*---- +* MCGSCA: Step-Characteristics Scheme with Tabulated Exponentials +* MCGDDF: Diamond-Differencing Scheme +* MCGSCE: Step-Characteristics Scheme with Exact Exponentials + CALL SUBSCH(N,K,M,NOM,NZON,H,XST,B) +*---- +* Summation along the track in both directions +*---- +* incoming flux in + direction + IND1=KEYCUR(-NOM(1)) + RP=S(IND1) +* incoming flux in - direction + INDN=KEYCUR(-NOM(N)) + RM=S(INDN) + IF(IDIR.GT.0) THEN +* incoming flux in + direction + RP=RP*OMEGA2(IDIR)/XSI(IND1-NREG) +* incoming flux in - direction + RM=RM*OMEGA2(IDIR)/XSI(INDN-NREG) + ENDIF + DO I=2,N-1 +* + direction + NOMI=NOM(I) + SSS=S(NOMI) + IF(IDIR.GT.0) THEN + SSS=SSS*OMEGA2(IDIR) + ENDIF + F0=B(I)*RP + RP=RP+B(I)*(SSS-DBLE(XST(NZON(NOMI)))*RP) + IND=KEYFLX(NOMI,1) + F(IND)=F(IND)+F0*WW + INDC=KPN/2+IND +* Calculate Xi, Yi and Zi for TIBERE + IF(IDIR.GT.0) THEN + F(INDC)=F(INDC)+F0*WW*OMEGA2(IDIR) + ENDIF +* - direction + J=N+1-I + NOMJ=NOM(J) + SSS=S(NOMJ) + IF(IDIR.GT.0) THEN + SSS=SSS*OMEGA2(IDIR) + ENDIF + F0=B(J)*RM + RM=RM+B(J)*(SSS-DBLE(XST(NZON(NOMJ)))*RM) + IND=KEYFLX(NOMJ,1) + F(IND)=F(IND)+F0*WW + INDC=KPN/2+IND +* Calculate Xi, Yi and Zi for TIBERE + IF(IDIR.GT.0) THEN + F(INDC)=F(INDC)+F0*WW*OMEGA2(IDIR) + ENDIF + ENDDO +* outgoing flux in + direction + F(INDN)=F(INDN)+RP*WW +* outgoing flux in - direction + F(IND1)=F(IND1)+RM*WW +* + RETURN + END diff --git a/Dragon/src/MCGFFIS.f b/Dragon/src/MCGFFIS.f new file mode 100644 index 0000000..9f68a5e --- /dev/null +++ b/Dragon/src/MCGFFIS.f @@ -0,0 +1,136 @@ +*DECK MCGFFIS + SUBROUTINE MCGFFIS(SUBSCH,K,KPN,M,N,H,NOM,NZON,XST,S,NREG,KEYFLX, + 1 KEYCUR,F,B,W,OMEGA2,IDIR,NSOUT,XSI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of transport equation on a track +* ray-tracing (isotropic scattering case,'source term isolation' off). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): I. Suslov and R. Le Tellier +* +*Parameters: input +* SUBSCH Track coefficients calculation subroutine. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* KPN total number of unknowns in vectors F. +* M number of material mixtures. +* N number of elements in the current track. +* H vector containing the lenght of the different segments of this +* track. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* XST macroscopic total cross section. +* S total source vector. +* NREG number of volumes. +* KEYFLX position of flux elements in PHI vector. +* KEYCUR position of current elements in PHI vector. +* W weight associated with this track. +* OMEGA2 square x, y and z-component of the direction +* Omega for 2D geometry. +* IDIR direction of fundamental current for TIBERE with MoC +* (=0,1,2,3). +* NSOUT number of outer surfaces. +* XSI x,y and z component of the shape parameter for TIBERE. +* +*Parameters: input/output +* F vector containing the zonal scalar flux. +* +*Parameters: scratch +* B undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER K,KPN,M,N,NOM(N),NZON(K),NREG,KEYFLX(NREG,1), + 1 KEYCUR(K-NREG),IDIR + REAL XST(0:M) + DOUBLE PRECISION W,H(N),S(KPN),F(KPN),B(2,N),OMEGA2(3) + INTEGER NSOUT + DOUBLE PRECISION XSI(NSOUT) + EXTERNAL SUBSCH +*--- +* LOCAL VARIABLES +*--- + DOUBLE PRECISION F0,SI,SJ,RM,RP,WW + INTEGER I,J,NOMI,IND,IND1,INDN,NOMJ,INDC +* + WW=DBLE(W) +*---- +* Calculation coefficients for this track. +*---- +* MCGSCAS: Step-Characteristics Scheme with Tabulated Exponentials +* MCGDDFS: Diamond-Differencing Scheme +* MCGSCES: Step-Characteristics Scheme with Exact Exponentials + CALL SUBSCH(N,K,M,NOM,NZON,H,XST,B) +*---- +* Summation along the track in both directions +*---- +* Calculation of the incoming current on surface with the correction XSI +* incoming flux in + direction + IND1=KEYCUR(-NOM(1)) + RP=S(IND1) +* incoming flux in - direction + INDN=KEYCUR(-NOM(N)) + RM=S(INDN) + IF(IDIR.GT.0) THEN +* incoming flux in + direction + RP=RP*OMEGA2(IDIR)/XSI(IND1-NREG) +* incoming flux in - direction + RM=RM*OMEGA2(IDIR)/XSI(INDN-NREG) + ENDIF +* + DO I=2,N-1 + NOMI=NOM(I) + SI=S(NOMI) + J=N+1-I + NOMJ=NOM(J) + SJ=S(NOMJ) + IF(IDIR.EQ.0) THEN +* + direction + F0=B(1,I)*RP+B(2,I)*SI + RP=RP+B(1,I)*(SI-XST(NZON(NOMI))*RP) + IND=KEYFLX(NOMI,1) + F(IND)=F(IND)+F0*WW +* - direction + F0=B(1,J)*RM+B(2,J)*SJ + RM=RM+B(1,J)*(SJ-XST(NZON(NOMJ))*RM) + IND=KEYFLX(NOMJ,1) + F(IND)=F(IND)+F0*WW + ELSE +* Solve current equation for TIBERE +* and calculate Xi, Yi and Zi +* + direction + F0=B(1,I)*RP+B(2,I)*SI*OMEGA2(IDIR) + RP=RP+B(1,I)*(SI*OMEGA2(IDIR)-XST(NZON(NOMI))*RP) + IND=KEYFLX(NOMI,1) + F(IND)=F(IND)+F0*WW + INDC=KPN/2+IND + F(INDC)=F(INDC)+F0*WW*OMEGA2(IDIR) +* - direction + F0=B(1,J)*RM+B(2,J)*SJ*OMEGA2(IDIR) + RM=RM+B(1,J)*(SJ*OMEGA2(IDIR)-XST(NZON(NOMJ))*RM) + IND=KEYFLX(NOMJ,1) + F(IND)=F(IND)+F0*WW + INDC=KPN/2+IND + F(INDC)=F(INDC)+F0*WW*OMEGA2(IDIR) + ENDIF + ENDDO +* outgoing flux in + direction + F(INDN)=F(INDN)+RP*WW +* outgoing flux in - direction + F(IND1)=F(IND1)+RM*WW + RETURN + END diff --git a/Dragon/src/MCGFFIT.f b/Dragon/src/MCGFFIT.f new file mode 100644 index 0000000..881abdc --- /dev/null +++ b/Dragon/src/MCGFFIT.f @@ -0,0 +1,124 @@ +*DECK MCGFFIT + SUBROUTINE MCGFFIT(SUBSCH,K,KPN,M,N,H,NOM,NZON,XST,S,NREG,KEYFLX, + 1 KEYCUR,F,B,W,OMEGA2,IDIR,NSOUT,XSI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of transport equation on a track +* ray-tracing (isotropic scattering case,'MOCC/MCI' +* integration strategy). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): I. Suslov and R. Le Tellier +* +*Parameters: input +* SUBSCH Track coefficients calculation subroutine. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* KPN total number of unknowns in vectors F. +* M number of material mixtures. +* N number of elements in the current track. +* H vector containing the lenght of the different segments of this +* track. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* XST macroscopic total cross section. +* S total source vector. +* NREG number of volumes. +* KEYFLX position of flux elements in PHI vector. +* KEYCUR position of current elements in PHI vector. +* W weight associated with this track. +* OMEGA2 square x, y and z-component of the direction +* Omega for 2D geometry. +* IDIR direction of fundamental current for TIBERE with MoC +* (=0,1,2,3). +* NSOUT number of outer surfaces. +* XSI x,y and z component of the shape parameter for TIBERE. +* +*Parameters: input/output +* F vector containing the zonal scalar flux. +* +*Parameters: scratch +* B undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER K,KPN,M,N,NOM(N),NZON(K),NREG,KEYFLX(NREG,1), + 1 KEYCUR(K-NREG),IDIR + REAL XST(0:M) + DOUBLE PRECISION W,H(N),S(KPN),F(KPN),B(N),OMEGA2(3) + INTEGER NSOUT + DOUBLE PRECISION XSI(NSOUT) + EXTERNAL SUBSCH +*--- +* LOCAL VARIABLES +*--- + DOUBLE PRECISION F0,RP,RM,WW,OMG2D,AP,AM + INTEGER I,J,NOMI,IND,IND1,INDN,NOMJ,INDC +* + WW=DBLE(W) +*---- +* Calculation coefficients for this track. +*---- +* MCGSCAT: Step-Characteristics Scheme with Tabulated Exponentials +* MCGDDFT: Diamond-Differencing Scheme +* MCGSCET: Step-Characteristics Scheme with Exact Exponentials + CALL SUBSCH(N,K,M,NOM,NZON,H,XST,B) +*---- +* Summation along the track in both directions +*---- +* incoming flux in + direction + OMG2D=OMEGA2(IDIR)/3.0D0 + IND1=KEYCUR(-NOM(1)) + RP=S(IND1) +* incoming flux in - direction + INDN=KEYCUR(-NOM(N)) + RM=S(INDN) + IF(IDIR.GT.0) THEN + AP=OMEGA2(IDIR)/XSI(IND1-NREG) + AM=OMEGA2(IDIR)/XSI(INDN-NREG) + ENDIF + DO I=2,N-1 +* + direction + NOMI=NOM(I) + F0=B(I)*(RP-S(NOMI)) + RP=RP-F0 + IND=KEYFLX(NOMI,1) + F(IND)=F(IND)+F0*WW + INDC=KPN/2+IND +* Calculate Xi, Yi and Zi for TIBERE + IF(IDIR.GE.1) THEN + F(INDC)=F(INDC)+F0*WW*OMG2D + ENDIF +* - direction + J=N+1-I + NOMJ=NOM(J) + F0=B(J)*(RM-S(NOMJ)) + RM=RM-F0 + IND=KEYFLX(NOMJ,1) + F(IND)=F(IND)+F0*WW + INDC=KPN/2+IND +* Calculate Xi, Yi and Zi for TIBERE + IF(IDIR.GE.1) THEN + F(INDC)=F(INDC)+F0*WW*OMG2D + ENDIF + ENDDO +* outgoing flux in + direction + F(INDN)=F(INDN)+RP*WW +* outgoing flux in - direction + F(IND1)=F(IND1)+RM*WW +* + RETURN + END diff --git a/Dragon/src/MCGFL1.f b/Dragon/src/MCGFL1.f new file mode 100644 index 0000000..efaacc1 --- /dev/null +++ b/Dragon/src/MCGFL1.f @@ -0,0 +1,342 @@ +*DECK MCGFL1 + SUBROUTINE MCGFL1(SUBFFI,SUBFFA,SUBLDC,SUBSCH,CYCLIC,KPSYS,IPRINT, + 1 IPTRK,IFTRAK,IPMACR,NDIM,K,KPN,NLONG,PHIOUT,NZON, + 2 MATALB,M,NANI,NMU,N2MAX,NANGL,NREG,NSOUT,NG,NGEFF, + 3 NGIND,S,IAAC,ISCR,LC,LFORW,PACA,EPSACC,MAXACC,NLIN, + 4 NFUNL,KEYFLX,KEYCUR,QFR,PHIIN,CAZ0,CAZ1,CAZ2,CPO,ZMU, + 5 WZMU,V,SIGAL,LPS,NCONV,LAST,STIS,NPJJM,REBFLG,LPRISM, + 6 N2REG,N2SOU,NZP,DELU,FACSYM,IDIR,NBATCH) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform one inner iteration of the characteristics method. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input/output +* SUBFFI flux integration subroutine with isotropic source. +* SUBFFA flux integration subroutine with anisotropic source. +* SUBLDC flux integration subroutine with linear-discontinuous source. +* SUBSCH track coefficients calculation subroutine. +* CYCLIC cyclic tracking flag. +* KPSYS pointer array for each group properties. +* IPRINT print parameter (equal to zero for no print). +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK tracking file unit number. +* IPMACR pointer to the macrolib LCM object. +* NDIM number of dimensions for the geometry. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* KPN total number of unknowns per group in vector PHIIN. +* NLONG number of spatial unknowns. +* PHIOUT output flux vector. +* NZON mixture-albedo index array in MCCG format. +* MATALB albedo-mixture index array in MOCC format. +* M number of material mixtures. +* NANI scattering anisotropy (=1 for isotropic scattering). +* NMU order of the polar quadrature in 2D / 1 in 3D. +* N2MAX maximum number of elements in a track. +* NANGL number of tracking angles in the plane. +* NREG number of volumes. +* NSOUT number of outer surfaces. +* NG number of groups. +* NGEFF number of groups to process. +* NGIND index of the groups to process. +* S scratch. +* IAAC no acceleration / CDD acceleration of inner iterations (0/1). +* ISCR no acceleration / SCR acceleration of inner iterations (0/1). +* LC dimension of profiled matrices MCU and CQ. +* LFORW flag set to .false. to transpose the coefficient matrix. +* PACA type of preconditioner to solve the ACA corrective system. +* EPSACC stopping criterion for BICGSTAB in ACA resolution. +* MAXACC maximum number of iterations allowed for BICGSTAB in ACA +* resolution. +* NLIN number of polynomial components in flux spatial expansion. +* NFUNL number of moments of the flux (in 2D: NFUNL=NANI*(NANI+1)/2). +* KEYFLX position of flux elements in PHIIN vector. +* KEYCUR position of current elements in PHIIN vector. +* QFR input source vector. +* PHIIN input flux vector. +* CAZ0 cosines of the tracking polar angles in 3D. +* CAZ1 first cosines of the different tracking azimuthal angles. +* CAZ2 second cosines of the different tracking azimuthal angles. +* CPO cosines of the different tracking polar angles in 2D. +* ZMU polar quadrature set in 2D. +* WZMU polar quadrature set in 2D. +* V volumes. +* SIGAL total cross-section and albedo array. +* LPS used in scr acceleration. +* NCONV logical array of convergence status for each group (.TRUE. +* not converged). +* LAST flag for SCR and ACA rebalancing. +* STIS source term isolation' option for flux integration. +* NPJJM number of pjj modes to store for STIS option. +* REBFLG ACA or SCR rebalancing flag. +* LPRISM 3D prismatic extended tracking flag. +* N2REG number of regions in the 2D tracking if LPRISM. +* N2SOU number of external surfaces in the 2D tracking if LPRISM. +* NZP number of z-plans if LPRISM. +* DELU input track spacing for 3D track reconstruction if LPRISM. +* FACSYM tracking symmetry factor for maximum track length if LPRISM. +* IDIR direction of fundamental current for TIBERE with MoC +* (=0,1,2,3). +* NBATCH number of tracks processed in each OpenMP core (default: =1). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*--- +* SUBROUTINES ARGUMENTS +*--- + TYPE(C_PTR) KPSYS(NGEFF),IPTRK,IPMACR + INTEGER NGEFF,IPRINT,IFTRAK,NDIM,K,KPN,NLONG,NG,NGIND(NGEFF), + 1 NZON(NLONG),M,NANI,NMU,N2MAX,NANGL,IAAC,LC,PACA,NREG,NSOUT, + 2 ISCR,LPS,NLIN,NFUNL,KEYFLX(NREG,NLIN,NFUNL),KEYCUR(NLONG-NREG), + 3 MAXACC,STIS,NPJJM,MATALB(-NSOUT:NREG),N2REG,N2SOU,NZP,IDIR,NBATCH + REAL QFR(KPN,NGEFF),PHIIN(KPN,NGEFF),CPO(NMU),ZMU(NMU),WZMU(NMU), + 1 V(NLONG),SIGAL(-6:M,NGEFF),EPSACC,DELU,FACSYM + DOUBLE PRECISION CAZ0(NANGL),CAZ1(NANGL),CAZ2(NANGL), + 1 PHIOUT(KPN,NGEFF),S(KPN,NGEFF) + LOGICAL LFORW,CYCLIC,NCONV(NGEFF),LAST,REBFLG,LPRISM + EXTERNAL SUBFFI,SUBFFA,SUBLDC,SUBSCH +*--- +* LOCAL VARIABLES +*--- + TYPE(C_PTR) JPSYS + REAL T1,T2,T3 + INTEGER NCODE(6),SSYM + INTEGER, DIMENSION(1), TARGET :: IDUMMY + CHARACTER TEXT4*4 + LOGICAL MACFLG,COMBFLG + INTEGER ICREB,ITYLCM +*---- +* ALLOCATABLE ARRAYS +*---- + TYPE(C_PTR) IBC_PTR,XSSC_PTR,PJJM_PTR + TYPE(C_PTR) INDREG_PTR,Z_PTR,VNORF_PTR,CMU_PTR,CMUI_PTR,SMU_PTR, + 1 SMUI_PTR,TMU_PTR,TMUI_PTR + INTEGER, ALLOCATABLE, DIMENSION(:) ::KEYANI + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISGNR + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: XSIXYZ + INTEGER, POINTER, DIMENSION(:) :: IBC,INDREG,PJJM + REAL, POINTER, DIMENSION(:) :: XSSC,Z + DOUBLE PRECISION, POINTER, DIMENSION(:) :: VNORF,CMU,CMUI,SMU, + 1 SMUI,TMU,TMUI +* + PHIOUT(:KPN,:NGEFF)=0.0D0 +* + REWIND IFTRAK + READ(IFTRAK) TEXT4,NCOMNT,NBTR,IFMT + DO ICOM=1,NCOMNT + READ(IFTRAK) + ENDDO + READ(IFTRAK) (NITMA, II=1,7),MXSUB,NITMA + DO ICOM=1,6 + READ(IFTRAK) + ENDDO +* + IF(LPRISM) THEN + CALL LCMGET(IPTRK,'NCODE',NCODE) + IF(NCODE(6).EQ.30) THEN + IF(NCODE(5).EQ.30) THEN +* Z- and Z+ surfaces symmetry + SSYM=2 + ELSE +* Z+ symmetry + SSYM=1 + ENDIF + ELSE + SSYM=0 + ENDIF + NDIMB=3 + NMAX=(INT(FACSYM)+1)*N2MAX*(NZP+2) + ELSE + NDIMB=NDIM + NMAX=N2MAX + ENDIF +*---- +* SOURCE ELEMENTS CALCULATION +*---- + IF(NLONG-NREG.GT.0) THEN + CALL LCMGPD(IPTRK,'BC-REFL+TRAN',IBC_PTR) + CALL C_F_POINTER(IBC_PTR,IBC,(/ NLONG-NREG /)) + ELSE + IBC => IDUMMY + ENDIF + DO II=1,NGEFF + IF(NCONV(II)) THEN + JPSYS=KPSYS(II) + CALL LCMGPD(JPSYS,'DRAGON-S0XSC',XSSC_PTR) + CALL C_F_POINTER(XSSC_PTR,XSSC,(/ (M+1)*NANI /)) + CALL MCGFCS(NLONG,NDIMB,NZON,QFR(1,II),PHIIN(1,II),M,NANI, + 1 NLIN,NFUNL,XSSC,S(1,II),KPN,NREG,IPRINT,KEYFLX,KEYCUR, + 2 IBC,SIGAL(-6,II),STIS) + ENDIF + ENDDO +*--- +* GENERATE ALL SIGNS FOR SPHERICAL HARMONICS +*--- + NANIX=NANI + IF(NLIN.EQ.3) NANIX=MAX(NANI,3) + IF(NDIM.EQ.1) THEN + NFUNLX=NANIX + NMOD=2 + ELSE IF((.NOT.LPRISM).AND.(NDIM.EQ.2)) THEN + NFUNLX=NANIX*(NANIX+1)/2 + NMOD=4 + ELSE ! NDIM.EQ.3 + NFUNLX=NANIX*NANIX + NMOD=8 + ENDIF + ALLOCATE(ISGNR(NMOD,NFUNLX),KEYANI(NFUNLX)) + CALL MOCIK3(NANIX-1,NFUNLX,NMOD,ISGNR,KEYANI) +*---- +* FLUX INTEGRATION UPON THE TRACKING FILE +*---- + CALL KDRCPU(T1) + IF(CYCLIC) THEN +* -------------------------------- +* Method of Cyclic Characteristics +* -------------------------------- + CALL MOCFCF(SUBFFI,SUBFFA,SUBLDC,SUBSCH,IFTRAK,NBTR,MXSUB, + 1 N2MAX,NDIM,KPN,NREG,NSOUT,M,6,NGEFF,NANGL,NMU,NANI, + 2 NFUNL,NMOD,NANIX,NLIN,NFUNLX,KEYFLX,MATALB,NCONV,SIGAL, + 3 CAZ1,CAZ2,CPO,ZMU,WZMU,S,ISGNR,IDIR,NBATCH,PHIOUT) + ELSE +* ------------------------------------ +* Method of Non-Cyclic Characteristics +* ------------------------------------ + IF(LPRISM) THEN +* 3D PRISMATIC GEOMETRY CONSTRUCTED FROM A 2D TRACKING + CALL LCMSIX(IPTRK,'PROJECTION',1) + CALL LCMGPD(IPTRK,'IND2T3',INDREG_PTR) + CALL LCMGPD(IPTRK,'ZCOORD',Z_PTR) + CALL LCMGPD(IPTRK,'VNORF',VNORF_PTR) + CALL LCMGPD(IPTRK,'CMU',CMU_PTR) + CALL LCMGPD(IPTRK,'CMUI',CMUI_PTR) + CALL LCMGPD(IPTRK,'SMU',SMU_PTR) + CALL LCMGPD(IPTRK,'SMUI',SMUI_PTR) + CALL LCMGPD(IPTRK,'TMU',TMU_PTR) + CALL LCMGPD(IPTRK,'TMUI',TMUI_PTR) + CALL LCMSIX(IPTRK,'PROJECTION',2) +* + CALL C_F_POINTER(INDREG_PTR,INDREG, + 1 (/ (N2REG+N2SOU+1)*(NZP+2) /)) + CALL C_F_POINTER(Z_PTR,Z,(/ NZP+1 /)) + CALL C_F_POINTER(VNORF_PTR,VNORF,(/ NREG*NANGL*NMU*2 /)) + CALL C_F_POINTER(CMU_PTR,CMU,(/ NMU /)) + CALL C_F_POINTER(CMUI_PTR,CMUI,(/ NMU /)) + CALL C_F_POINTER(SMU_PTR,SMU,(/ NMU /)) + CALL C_F_POINTER(SMUI_PTR,SMUI,(/ NMU /)) + CALL C_F_POINTER(TMU_PTR,TMU,(/ NMU /)) + CALL C_F_POINTER(TMUI_PTR,TMUI,(/ NMU /)) + CALL MCGPTF(SUBFFI,SUBFFA,SUBSCH,IFTRAK,NBTR,N2MAX,KPN, + 1 K,NREG,M,NGEFF,NANGL,NMU,NANI,NFUNL,NMOD,KEYFLX, + 2 KEYCUR,NZON,NCONV,CAZ1,CAZ2,CPO,WZMU,PHIOUT,S,SIGAL, + 3 ISGNR,NMAX,NZP,N2REG,N2SOU,DELU,INDREG,Z,VNORF,CMU, + 4 CMUI,SMU,SMUI,TMU,TMUI,SSYM,IDIR) + ELSE +* REGULAR 2D OR 3D GEOMETRY + ALLOCATE(XSIXYZ(NSOUT,3)) + XSIXYZ(:NSOUT,:3)=0.0D0 + CALL LCMLEN(IPTRK,'XSI$MCCG',ICREB,ITYLCM) + IF(ICREB.EQ.3*NSOUT) CALL LCMGET(IPTRK,'XSI$MCCG',XSIXYZ) + CALL MCGFCF(SUBFFI,SUBFFA,SUBLDC,SUBSCH,IFTRAK,NBTR,N2MAX, + 1 NDIM,KPN,K,NREG,M,NGEFF,NANGL,NMU,NANI,NFUNL,NMOD, + 2 NANIX,NLIN,NFUNLX,KEYFLX,KEYCUR,NZON,NCONV,CAZ0,CAZ1, + 3 CAZ2,CPO,ZMU,WZMU,S,SIGAL,ISGNR,IDIR,NSOUT,NBATCH, + 4 XSIXYZ(1,IDIR),PHIOUT) + DEALLOCATE(XSIXYZ) + ENDIF + ENDIF +* + IF(STIS.EQ.1) THEN + CALL LCMGPD(IPTRK,'PJJIND$MCCG',PJJM_PTR) + CALL C_F_POINTER(PJJM_PTR,PJJM,(/ NPJJM*2 /)) + CALL MCGFST(NGEFF,KPSYS,NCONV,KPN,NLONG,NREG,NANI,NFUNL,NPJJM, + 1 KEYFLX,KEYCUR,PJJM,NZON,V,S,PHIOUT,IDIR) + ELSEIF(STIS.EQ.-1) THEN + DO II=1,NGEFF + IF(NCONV(II)) THEN + CALL MCGFMC(KPN,NLONG,NREG,M,NANI,NFUNL,NZON,KEYFLX,KEYCUR, + 1 PHIOUT(1,II),V,S(1,II),SIGAL(0,II),KEYANI) + ENDIF + ENDDO + ELSE + DO II=1,NGEFF + IF(NCONV(II)) THEN + DO I=1,NLONG + IF(V(I).GT.0.) THEN + IF(NZON(I).LT.0) THEN + IND=KEYCUR(I-NREG) + PHIOUT(IND,II)=PHIOUT(IND,II)/V(I) + ELSE + DO IL=1,NFUNL + DO IU=1,NLIN + IND=KEYFLX(I,IU,IL) + PHIOUT(IND,II)=PHIOUT(IND,II)/V(I) + ENDDO + ENDDO + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF + CALL KDRCPU(T2) +*---- +* PRECONDITIONING TECHNIQUES +*---- + MACFLG=((LAST).AND.(C_ASSOCIATED(IPMACR)).AND.((IAAC.GT.1).OR. + 1 (ISCR.GT.1))) + REBFLG=(REBFLG.AND.MACFLG) + COMBFLG=((IAAC.GT.0).AND.(ISCR.GT.0)) + IF(IAAC.GT.0) THEN +* --------------------------------- +* Algebraic Collapsing Acceleration +* --------------------------------- + IF(REBFLG) MAXACC=IAAC + CALL MCGFCA(IPTRK,KPSYS,IPMACR,IPRINT,NLONG,NG,NGEFF,KPN,NREG, + 1 NANI,NFUNL,M,LC,LFORW,PACA,KEYFLX,KEYCUR,NZON,NGIND,NCONV, + 2 MAXACC,EPSACC,MACFLG,REBFLG,PHIOUT,PHIIN,COMBFLG,NPJJM, + 3 KEYANI,IDIR) + CALL KDRCPU(T3) +* --------------------------------- + ENDIF + NLON2=NLONG + IF(COMBFLG) NLON2=NREG + IF(ISCR.GT.0) THEN +* --------------------------------- +* Self-Collision Rebalancing Method +* --------------------------------- + IF(REBFLG) THEN +* rebalancing + MAXSCR=ISCR + ELSE + MAXSCR=1 + ENDIF + CALL MCGSCR(IPTRK,KPSYS,IPMACR,IPRINT,NLON2,NG,NGEFF,KPN,K, + 1 NREG,NANI,NFUNL,M,LPS,KEYFLX,KEYCUR,NZON,NGIND,NCONV, + 2 MAXSCR,EPSACC,MACFLG,PHIOUT,PHIIN,V,NPJJM,KEYANI,IDIR) + CALL KDRCPU(T3) +* --------------------------------- + ENDIF + DEALLOCATE(KEYANI,ISGNR) + IF(IPRINT.GT.1) THEN + WRITE(6,100) ' FLUX INTEGRATION ',(T2-T1) + IF((IAAC.GT.0).OR.(ISCR.NE.0)) THEN + WRITE(6,100) ' ACCELERATION ',(T3-T2) + ENDIF + ENDIF + RETURN +* + 100 FORMAT(10X,'MCGFL1: -->>TIME SPENT IN ',A24,':',F13.3) + END diff --git a/Dragon/src/MCGFLS.f b/Dragon/src/MCGFLS.f new file mode 100644 index 0000000..cd2242b --- /dev/null +++ b/Dragon/src/MCGFLS.f @@ -0,0 +1,134 @@ +*DECK MCGFLS + SUBROUTINE MCGFLS(IMPX,IPTRK,IPMACR,NUN,K,NREG,NLONG,M,NG,NGEFF, + 1 LC,LFORW,PACA,NZON,KEYFLX,KEYCUR,NGIND,KPSYS, + 2 NCONV,EPSI,MAXI,FIMEM,QFR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Synthetic diffusion (ACA) flux calculation. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): I. Suslov and R. Le Tellier +* +*Parameters: input +* IMPX print flag (equal to zero for no print). +* IPTRK pointer to the tracking (L_TRACK signature). +* IPMACR pointer to the macrolib LCM object. +* NUN number of unknowns per group. +* K number of volumes and outer surfaces. +* NREG number of volume regions. +* NLONG size of the corrective system. +* M number of material mixtures. +* NG number of groups. +* NGEFF number of groups to process. +* LC dimension of profiled matrices MCU and CQ. +* LFORW flag set to .false. to transpose the coefficient matrix. +* PACA type of preconditioner to solve the ACA corrective system. +* NZON index-number of the mixture type assigned to each volume. +* KEYFLX position of flux elements in FIMEM vector. +* KEYCUR position of current elements in FIMEM vector. +* NGIND index of the groups to process. +* KPSYS pointer to system groups. +* NCONV array of convergence flag for each group. +* EPSI stopping criterion for BICGSTAB in ACA resolution. +* MAXI maximum number of iterations allowed for BICGSTAB in ACA +* resolution. +* QFR input source vector. +* +*Parameters: input/output +* FIMEM unknown vector. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) KPSYS(NGEFF),IPTRK,IPMACR + INTEGER IMPX,NUN,K,NREG,M,NG,NGEFF,LC,PACA,NZON(NLONG), + 1 KEYFLX(NREG),KEYCUR(NLONG-NREG),NGIND(NGEFF),MAXI + REAL EPSI,FIMEM(NUN,NGEFF),QFR(NUN,NGEFF) + LOGICAL LFORW,NCONV(NGEFF) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPSYS + INTEGER, TARGET, SAVE, DIMENSION(1) :: IDUMMY + REAL, TARGET, SAVE, DIMENSION(1) :: DUMMY +*---- +* ALLOCATABLE ARRAYS +*---- + TYPE(C_PTR) IM_PTR,MCU_PTR,JU_PTR,IM0_PTR,MCU0_PTR,IPERM_PTR, + 1 DIAGF_PTR,CF_PTR,CQ_PTR,LUDF_PTR,LUCF_PTR,DIAGQ_PTR + INTEGER, POINTER, DIMENSION(:) :: IM,MCU,IPERM,JU,IM0,MCU0 + REAL, POINTER, DIMENSION(:) :: DIAGQ,CQ,LUDF,LUCF,CF,DIAGF +*---- +* INITIALIZE POINTERS +*---- + JU=>IDUMMY + IM0=>IDUMMY + MCU0=>IDUMMY + LUDF=>DUMMY + LUCF=>DUMMY + CF=>DUMMY + DIAGF=>DUMMY +* + IF(K.LE.0) CALL XABORT('MCGFLS: INVALID VALUE OF K.') + M1=M+1 +* recover connection matrices + CALL LCMGPD(IPTRK,'IM$MCCG',IM_PTR) + CALL LCMGPD(IPTRK,'MCU$MCCG',MCU_PTR) + CALL C_F_POINTER(IM_PTR,IM,(/ NLONG+1 /)) + CALL C_F_POINTER(MCU_PTR,MCU,(/ LC /)) +* recover permutation array + CALL LCMGPD(IPTRK,'PI$MCCG',IPERM_PTR) + CALL C_F_POINTER(IPERM_PTR,IPERM,(/ NLONG /)) + IF(PACA.GE.2) THEN + CALL LCMGPD(IPTRK,'JU$MCCG',JU_PTR) + CALL C_F_POINTER(JU_PTR,JU,(/ NLONG /)) + ENDIF + IF(PACA.EQ.3) THEN + CALL LCMLEN(IPTRK,'IM0$MCCG',LIM0,ITYLCM) + CALL LCMLEN(IPTRK,'MCU0$MCCG',LMCU0,ITYLCM) + CALL LCMGPD(IPTRK,'IM0$MCCG',IM0_PTR) + CALL LCMGPD(IPTRK,'MCU0$MCCG',MCU0_PTR) + CALL C_F_POINTER(IM0_PTR,IM0,(/ LIM0 /)) + CALL C_F_POINTER(MCU0_PTR,MCU0,(/ LMCU0 /)) + ELSE + LMCU0=0 + ENDIF + DO II=1,NGEFF + IF(NCONV(II)) THEN + JPSYS=KPSYS(II) + CALL LCMGPD(JPSYS,'DIAGF$MCCG',DIAGF_PTR) + CALL LCMGPD(JPSYS,'CF$MCCG',CF_PTR) + CALL C_F_POINTER(DIAGF_PTR,DIAGF,(/ NLONG /)) + CALL C_F_POINTER(CF_PTR,CF,(/ LC /)) + IF(PACA.GE.2) THEN + CALL LCMGPD(JPSYS,'ILUDF$MCCG',LUDF_PTR) + CALL C_F_POINTER(LUDF_PTR,LUDF,(/ NLONG /)) + IF(PACA.LT.4) THEN + CALL LCMGPD(JPSYS,'ILUCF$MCCG',LUCF_PTR) + CALL C_F_POINTER(LUCF_PTR,LUCF,(/ LC /)) + ENDIF + ENDIF + CALL LCMGPD(JPSYS,'DIAGQ$MCCG',DIAGQ_PTR) + CALL LCMGPD(JPSYS,'CQ$MCCG',CQ_PTR) + CALL C_F_POINTER(DIAGQ_PTR,DIAGQ,(/ NLONG /)) + CALL C_F_POINTER(CQ_PTR,CQ,(/ LC /)) + CALL MCGCDD(IMPX,IPMACR,II,NG,NGEFF,NGIND,NCONV,M,NLONG,NUN, + 1 NREG,LC,LFORW,PACA,NZON,KEYFLX,KEYCUR,IPERM,IM,MCU,JU, + 2 EPSI,MAXI,FIMEM(1,II),QFR,DIAGQ,CQ,DIAGF,CF,LUDF,LUCF, + 3 LMCU0,IM0,MCU0) + ENDIF + ENDDO +* + RETURN + END diff --git a/Dragon/src/MCGFLX.f b/Dragon/src/MCGFLX.f new file mode 100644 index 0000000..b0358db --- /dev/null +++ b/Dragon/src/MCGFLX.f @@ -0,0 +1,214 @@ +*DECK MCGFLX + SUBROUTINE MCGFLX(SUBFFI,SUBFFA,SUBSCH,SUBLDC,CYCLIC,KPSYS,IPRINT, + 1 IPTRK,IFTRAK,IPMACR,NDIM,K,KPN,NLONG,NREG,NSOUT,NG, + 2 NGEFF,NGIND,NZON,MATALB,V,FIMEM,QFR,M,NANI,MAXI,IAAC, + 3 KRYL,ISCR,NMU,NANGL,NMAX,LC,EPSI,CAZ0,CAZ1,CAZ2,CPO, + 4 ZMU,WZMU,LFORW,PACA,NLIN,NFUNL,KEYFLX,KEYCUR,SIGAL,LPS, + 5 REPS,EPS,ITST,NCONV,LNCONV,REBFLG,STIS,NPJJM,LPRISM, + 6 N2REG,N2SOU,NZP,DELU,FACSYM,IDIR,NBATCH) +* +*----------------------------------------------------------------------- +* +*Purpose: +* MOC solution of the transport equation in 2D,3D-irregular geometry. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert and R. Le Tellier +* +*Parameters: input/output +* SUBFFI flux integration subroutine with isotropic source. +* SUBFFA flux integration subroutine with anisotropic source. +* SUBLDC flux integration subroutine with linear-discontinuous source. +* SUBSCH track coefficients calculation subroutine. +* CYCLIC cyclic tracking flag. +* KPSYS pointer array for each group properties. +* IPRINT print parameter (equal to zero for no print). +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK tracking file unit number. +* IPMACR pointer to the macrolib LCM object. +* NDIM number of dimensions for the geometry. +* K total number of volumes-surfaces for which specific values +* of the neutron flux and reactions rates are required. +* KPN total number of unknowns in vectors SUNKNO and FUNKNO. +* NLONG number of spatial unknowns. +* NREG number of regions (volumes). +* NSOUT number of outer surfaces. +* NG number of groups. +* NGEFF number of groups to process. +* NGIND index of the groups to process. +* NZON mixture-albedo index array in MCCG format. +* MATALB albedo-mixture index array in MOCC format. +* V volumes and surfaces. +* FIMEM unknown vector. +* QFR input source vector. +* M number of material mixtures. +* NANI scattering anisotropy (=1 for isotropic scattering). +* MAXI maximum number of inner iterations. +* IAAC no acceleration / CDD acceleration of inner iterations (0/1). +* KRYL Bi-CGSTAB scheme used / GMRES scheme not used / GMRES scheme +* used (Krylov subspace dimension = KRYL) (<0 / 0 / >0). +* ISCR no acceleration / SCR acceleration of inner iterations (0/1). +* NMU order of the polar quadrature in 2D / 1 in 3D. +* NANGL number of tracking angles in the plane. +* NMAX maximum number of elements in a track. +* LC dimension of MCU vector. +* EPSI tolerance of inner iterations. +* CAZ0 cosines of the tracking polar angles in 3D. +* CAZ1 first cosines of the different tracking azimuthal angles. +* CAZ2 second cosines of the different tracking azimuthal angles. +* CPO cosines of the different tracking polar angles in 2D. +* ZMU polar quadrature set in 2D. +* WZMU polar quadrature set in 2D. +* LFORW flag set to .false. to transpose the coefficient matrix. +* PACA type of preconditioner to solve the ACA corrective system. +* NLIN number of polynomial components in flux spatial expansion. +* NFUNL number of moments of the flux (in 2D: NFUNL=NANI*(NANI+1)/2). +* KEYFLX position of flux elements in FUNKNO vector. +* KEYCUR position of current elements in FUNKNO vector. +* SIGAL total cross-section and albedo array. +* LPS dimension of PSJ vector for SCR acceleration. +* EPS array of the precision reached for each group. +* REPS array of the precision for each iteration and each group. +* ITST array of the number of iterations for each group. +* NCONV array of convergence flag for each group. +* LNCONV number of unconverged groups. +* REBFLG ACA or SCR rebalancing flag. +* STIS 'Source term isolation' option for flux integration. +* NPJJM number of pjj modes to store for STIS option. +* LPRISM 3D prismatic extended tracking flag. +* N2REG number of regions in the 2D tracking if LPRISM. +* N2SOU number of external surfaces in the 2D tracking if LPRISM. +* NZP number of z-plans if LPRISM. +* DELU input track spacing for 3D track reconstruction if LPRISM. +* FACSYM tracking symmetry factor for maximum track length if LPRISM. +* IDIR direction of fundamental current for TIBERE with MoC +* (=0,1,2,3). +* NBATCH number of tracks processed in each OpenMP core (default: =1). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPMACR,KPSYS(NGEFF) + INTEGER NGEFF,IPRINT,IFTRAK,NDIM,K,KPN,NLONG,NREG,NSOUT,NG, + 1 NGIND(NGEFF),NZON(NLONG),MATALB(-NSOUT:NREG),M,NANI,MAXI, + 2 IAAC,KRYL,NMU,NANGL,NMAX,LC,PACA,ISCR,LPS,ITST(NGEFF),LNCONV, + 3 NLIN,NFUNL,KEYFLX(NREG,NLIN,NFUNL),KEYCUR(NLONG-NREG),STIS, + 4 NPJJM,N2REG,N2SOU,NZP,IDIR,NBATCH + REAL V(NLONG),FIMEM(KPN,NGEFF),QFR(KPN,NGEFF),EPSI,CPO(NMU), + 1 ZMU(NMU),WZMU(NMU),SIGAL(-6:M,NGEFF),REPS(MAXI,NGEFF),EPS(NGEFF), + 2 DELU,FACSYM + DOUBLE PRECISION CAZ0(NANGL),CAZ1(NANGL),CAZ2(NANGL) + LOGICAL LFORW,CYCLIC,NCONV(NGEFF),REBFLG,LPRISM + EXTERNAL SUBFFI,SUBFFA,SUBLDC,SUBSCH +*---- +* ALLOCATABLE ARRAYS +*---- + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: SOUR,FLUX +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6) + REAL MAXDIF,MAXFL +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(SOUR(KPN,NGEFF),FLUX(KPN,NGEFF)) + SOUR(:KPN,:NGEFF)=0.0D0 +*--- + IF(IPRINT.GT.5) THEN + DO II=1,NGEFF + WRITE(6,*) 'GROUP(',NGIND(II),')' + CALL PRINAM('FI-0 ',FIMEM(1,II),KPN) + ENDDO + ENDIF +*---- +* INNER ITERATIONS FOR THE TRANSPORT SOLUTION +*---- + IF(KRYL.EQ.0) THEN +* --------------------------- +* Richardson Iterative Scheme +* --------------------------- + EPSINT=0.1*EPSI + MAXINT=200 + ITER=0 + DO WHILE ((LNCONV.GT.0).AND.(ITER.LT.MAXI)) + ITER=ITER+1 + CALL MCGFL1(SUBFFI,SUBFFA,SUBLDC,SUBSCH,CYCLIC,KPSYS,IPRINT, + 1 IPTRK,IFTRAK,IPMACR,NDIM,K,KPN,NLONG,FLUX,NZON,MATALB, + 2 M,NANI,NMU,NMAX,NANGL,NREG,NSOUT,NG,NGEFF,NGIND,SOUR, + 3 IAAC,ISCR,LC,LFORW,PACA,EPSINT,MAXINT,NLIN,NFUNL, + 4 KEYFLX,KEYCUR,QFR,FIMEM,CAZ0,CAZ1,CAZ2,CPO,ZMU,WZMU,V, + 5 SIGAL,LPS,NCONV,(MAXI.EQ.1),STIS,NPJJM,REBFLG,LPRISM, + 6 N2REG,N2SOU,NZP,DELU,FACSYM,IDIR,NBATCH) +* residual calculation and update NCONV + DO II=1,NGEFF + IF(NCONV(II)) THEN + IF(MAXI.GT.1) THEN + MAXFL=0.0 + MAXDIF=0.0 + DO I=1,KPN + TEMP=REAL(ABS(FLUX(I,II))) + MAXFL=MAX(TEMP,MAXFL) + FIMEM(I,II)=FIMEM(I,II)-REAL(FLUX(I,II)) + MAXDIF=MAX(ABS(FIMEM(I,II)),MAXDIF) + ENDDO + IF(MAXFL.EQ.0.0) MAXFL=1.0 + REPS(ITER,II)=MAXDIF/MAXFL + IF(ITER.GT.2) THEN + IF(REPS(ITER,II).GT.REPS(ITER-1,II)) THEN +* preconditioning cutoff + IAAC=0 + ISCR=0 + ENDIF + ENDIF + IF((REPS(ITER,II).LT.EPSI).OR.(ITER.EQ.MAXI)) THEN + NCONV(II)=.FALSE. + ITST(II)=ITER + EPS(II)=REPS(ITER,II) + LNCONV=LNCONV-1 + ENDIF + ENDIF + DO I=1,KPN + FIMEM(I,II)=REAL(FLUX(I,II)) + ENDDO + ENDIF + ENDDO + ENDDO + ELSEIF(KRYL.GT.0) THEN +* ---------------------- +* GMRES Iterative Scheme +* ---------------------- + CALL MCGMRE(SUBFFI,SUBFFA,SUBLDC,SUBSCH,CYCLIC,KPSYS,IPRINT, + 1 IPTRK,IFTRAK,IPMACR,NDIM,K,KPN,NLONG,FLUX,NZON,MATALB, + 2 M,NANI,NMU,NMAX,NANGL,NREG,NSOUT,SOUR,IAAC,ISCR,LC,LFORW, + 3 PACA,ITST,MAXI,QFR,FIMEM,CAZ0,CAZ1,CAZ2,CPO,ZMU,WZMU,V, + 4 EPS,EPSI,REPS,KRYL,SIGAL,LPS,NG,NGEFF,NGIND,NCONV,LNCONV, + 5 NLIN,NFUNL,KEYFLX,KEYCUR,STIS,NPJJM,REBFLG,LPRISM,N2REG, + 6 N2SOU,NZP,DELU,FACSYM,IDIR,NBATCH) + ELSE +* -------------------------- +* Bi-CGSTAB Iterative Scheme +* -------------------------- + CALL MCGBIC(SUBFFI,SUBFFA,SUBLDC,SUBSCH,CYCLIC,KPSYS,IPRINT, + 1 IPTRK,IFTRAK,IPMACR,NDIM,K,KPN,NLONG,FLUX,NZON,MATALB, + 2 M,NANI,NMU,NMAX,NANGL,NREG,NSOUT,SOUR,IAAC,ISCR,LC,LFORW, + 3 PACA,ITST,MAXI,QFR,FIMEM,CAZ0,CAZ1,CAZ2,CPO,ZMU,WZMU,V, + 4 EPS,EPSI,REPS,SIGAL,LPS,NG,NGEFF,NGIND,NCONV,LNCONV,NLIN, + 5 NFUNL,KEYFLX,KEYCUR,STIS,NPJJM,REBFLG,LPRISM,N2REG,N2SOU, + 6 NZP,DELU,FACSYM,IDIR,NBATCH) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(FLUX,SOUR) + RETURN + END diff --git a/Dragon/src/MCGFMC.f b/Dragon/src/MCGFMC.f new file mode 100644 index 0000000..5206900 --- /dev/null +++ b/Dragon/src/MCGFMC.f @@ -0,0 +1,73 @@ +*DECK MCGFMC + SUBROUTINE MCGFMC(KPN,K,NREG,M,NANI,NFUNL,NZON,KEYFLX,KEYCUR, + 1 PHIOUT,V,S,ST,KEYANI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Addition of the regional source to the flux when the 'MOCC/MCI' +* integration strategy is turned on for the method of characteristics +* integration. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* KPN total number of unknowns per group in flux vector. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* NREG number of volumes. +* M number of material mixtures. +* NANI scattering anisotropy (=1 for isotropic scattering). +* NFUNL number of moments of the flux (in 2D : NFUNL=NANI*(NANI+1)/2). +* NZON index-number of the mixture type assigned to each volume. +* KEYFLX position of flux elements in flux vector. +* KEYCUR position of current elements in flux vector. +* V volumes. +* S source vector. +* ST total cross sections array. +* KEYANI 'mode to l' index: l=KEYANI(nu). +* +*Parameters: input/output +* PHIOUT flux vector. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER KPN,K,NREG,M,NANI,NFUNL,NZON(K),KEYFLX(NREG,NFUNL), + 1 KEYCUR(K-NREG),KEYANI(NFUNL) + REAL V(K),ST(0:M) + DOUBLE PRECISION PHIOUT(KPN),S(KPN) +*---- +* LOCAL VARIABLES +*---- + INTEGER I,IBM,IL,IND +* + IF(NANI.LE.0) CALL XABORT('MCGFMC: INVALID VALUE OF NANI.') + DO I=1,K + IF(V(I).GT.0.) THEN + IBM=NZON(I) + IF (IBM.LT.0) THEN + IND=KEYCUR(I-NREG) + PHIOUT(IND)=PHIOUT(IND)/DBLE(V(I)) + ELSE + DO IL=1,NFUNL + IND=KEYFLX(I,IL) + PHIOUT(IND)=PHIOUT(IND)/DBLE(V(I)*ST(IBM)) + 1 +S(IND)/DBLE(2*KEYANI(IL)+1) + ENDDO + ENDIF + ENDIF + ENDDO +* + RETURN + END diff --git a/Dragon/src/MCGFST.f b/Dragon/src/MCGFST.f new file mode 100644 index 0000000..c1e25fe --- /dev/null +++ b/Dragon/src/MCGFST.f @@ -0,0 +1,135 @@ +*DECK MCGFST + SUBROUTINE MCGFST(NGEFF,KPSYS,NCONV,KPN,K,NREG,NANI,NFUNL,NPJJM, + 1 KEYFLX,KEYCUR,PJJIND,NZON,V,S,PHIOUT,IDIR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Addition of the contribution to the flux of the regional source +* when the 'source term isolation' option is turned on for the +* method of characteristics integration. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* NGEFF number of groups to process. +* KPSYS pointer array for each group properties. +* NCONV logical array of convergence status for each group (.TRUE. +* not converged). +* KPN total number of unknowns per group in flux vector. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* NREG number of volumes. +* NANI scattering anisotropy (=1 for isotropic scattering). +* NFUNL number of moments of the flux (in 2D : NFUNL=NANI*(NANI+1)/2). +* NPJJM number of pjj modes to store for STIS option. +* KEYFLX position of flux elements in flux vector. +* KEYCUR position of current elements in flux vector. +* PJJIND index for pjj(nu <- nu') modes. +* NZON index-number of the mixture type assigned to each volume. +* V volumes. +* S source vector. +* IDIR direction of fundamental current for TIBERE with MoC +* (=0,1,2,3). +* +*Parameters: input/output +* PHIOUT flux vector. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) KPSYS(NGEFF) + INTEGER NGEFF,KPN,K,NREG,NANI,NFUNL,NPJJM,KEYFLX(NREG,NFUNL), + 1 KEYCUR(K-NREG),PJJIND(NPJJM,2),NZON(K),IDIR + REAL V(K) + DOUBLE PRECISION S(KPN,NGEFF),PHIOUT(KPN,NGEFF) + LOGICAL NCONV(NGEFF) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPSYS + INTEGER II,I,IND,IMOD,INU,INUP,INDP + REAL, ALLOCATABLE, DIMENSION(:,:) :: PJJ,PJJI + CHARACTER*12 NPJJT,NPJJIT +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(PJJ(NREG,NPJJM),PJJI(NREG,NPJJM)) +* + IF(IDIR .EQ.0) THEN + NPJJT='PJJ$MCCG' + NPJJIT=' ' + ELSEIF(IDIR .EQ. 1) THEN + NPJJT='PJJX$MCCG' + NPJJIT='PJJXI$MCCG' + ELSEIF(IDIR .EQ. 2) THEN + NPJJT='PJJY$MCCG' + NPJJIT='PJJYI$MCCG' + ELSE + NPJJT='PJJZ$MCCG' + NPJJIT='PJJZI$MCCG' + ENDIF + IF(NANI.LE.0) CALL XABORT('MCGFST: INVALID VALUE OF NANI.') + DO II=1,NGEFF + IF(NCONV(II)) THEN + JPSYS=KPSYS(II) + CALL LCMGET(JPSYS,NPJJT,PJJ) + IF(IDIR.GT.0) CALL LCMGET(JPSYS,NPJJIT,PJJI) + DO I=1,K + IF(V(I).GT.0.) THEN + IF(NZON(I).LT.0) THEN + IND=KEYCUR(I-NREG) + PHIOUT(IND,II)=PHIOUT(IND,II)/V(I) + ELSE + DO INU=1,NFUNL + IND=KEYFLX(I,INU) + PHIOUT(IND,II)=PHIOUT(IND,II)/V(I) + ENDDO +* DIVIDE THE EXTRA TERMS XI, YI, AND ZI BY THE VOLUME + IF(IDIR.NE.0) THEN + IND=KEYFLX(I,NFUNL) + PHIOUT(IND+KPN/2,II)=PHIOUT(IND+KPN/2,II)/V(I) + ENDIF + DO IMOD=1,NPJJM + INU=PJJIND(IMOD,1) + INUP=PJJIND(IMOD,2) + IND=KEYFLX(I,INU) + INDP=KEYFLX(I,INUP) + PHIOUT(IND,II)=PHIOUT(IND,II)+ + 1 PJJ(I,IMOD)*S(INDP,II) + IF(IDIR .GT. 0) THEN + PHIOUT(IND+KPN/2,II)=PHIOUT(IND+KPN/2,II)+ + 1 PJJI(I,IMOD)*S(INDP,II) + ENDIF + IF(INU.NE.INUP) THEN + PHIOUT(INDP,II)=PHIOUT(INDP,II)+ + 1 PJJ(I,IMOD)*S(IND,II) + IF(IDIR .GT. 0) THEN + PHIOUT(INDP+KPN/2,II)=PHIOUT(INDP+KPN/2,II)+ + 1 PJJI(I,IMOD)*S(IND,II) + ENDIF + ENDIF + ENDDO + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(PJJI,PJJ) +* + RETURN + END diff --git a/Dragon/src/MCGMRE.f b/Dragon/src/MCGMRE.f new file mode 100644 index 0000000..5b5e6b0 --- /dev/null +++ b/Dragon/src/MCGMRE.f @@ -0,0 +1,316 @@ +*DECK MCGMRE + SUBROUTINE MCGMRE(SUBFFI,SUBFFA,SUBLDC,SUBSCH,CYCLIC,KPSYS, + 1 IPRINT,IPTRK,IFTRAK,IPMACR,NDIM,KV,NUN,NLONG,PHIOUT, + 2 NZON,MATALB,M,NANI,NMU,NMAX,NANGL,NREG,NSOUT,SOUR,IAAC, + 3 ISCR,LC,LFORW,PACA,ITST,MAXI,QFR,PHIIN,CAZ0,CAZ1,CAZ2, + 4 CPO,ZMU,WZMU,VOL,EPS,ERRTOL,REPSI,NSTART,SIGAL,LPS, + 5 NGROUP,NGEFF,NGIND,NCONV,LNCONV,NLIN,NFUNL,KEYFLX, + 6 KEYCUR,STIS,NPJJM,REBFLG,LPRISM,N2REG,N2SOU,NZP,DELU, + 7 FACSYM,IDIR,NBATCH) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solve the linear system obtained by the characteristics formalism +* with GMRES iterative approach. +* +*Copyright: +* Copyright (C) 2015 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier and A. Hebert +* +*Parameters: +* SUBFFI flux integration subroutine with isotropic source. +* SUBFFA flux integration subroutine with anisotropic source. +* SUBLDC flux integration subroutine with linear-discontinuous source. +* SUBSCH track coefficients calculation subroutine. +* CYCLIC cyclic tracking flag. +* KPSYS pointer array for each group properties. +* IPRINT print parameter (equal to zero for no print). +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK tracking file unit number. +* IPMACR pointer to the macrolib LCM object. +* NDIM number of dimensions for the geometry. +* KV total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* NUN total number of unknowns in vectors QFR and PHIIN. +* NLONG number of spatial unknowns. +* PHIOUT output flux vector. +* NZON mixture-albedo index array in MCCG format. +* MATALB albedo-mixture index array in MOCC format. +* M number of material mixtures. +* NANI scattering anisotropy (=1 for isotropic scattering). +* NMU order of the polar quadrature set. +* NMAX maximum number of elements in a track. +* NANGL number of tracking angles in the plane. +* NREG number of regions (volumes). +* NSOUT number of outer surfaces. +* SOUR undefined. +* IAAC no acceleration / CDD acceleration of inner iterations (0/1). +* ISCR no acceleration / SCR acceleration of inner iterations (0/1). +* LC dimension of profiled matrices MCU and CQ. +* LFORW flag set to .false. to transpose the coefficient matrix. +* PACA type of preconditioner to solve the ACA corrective system. +* ITST output: number of inner iterations. +* MAXI maximum number of inner iterations allowed. +* QFR input source vector. +* PHIIN input flux vector. +* CAZ0 cosines of the tracking polar angles in 3D. +* CAZ1 first cosines of the different tracking azimuthal angles. +* CAZ2 second cosines of the different tracking azimuthal angles. +* CPO cosines of the different tracking polar angles in 2D. +* ZMU polar quadrature set. +* WZMU polar quadrature set. +* VOL volumes. +* EPS precision reached after min(MAXI,ITST) iterations. +* ERRTOL tolerance for stopping criterion. process is stopped +* as soon as ||Phi(n+1)-Phi(n)||/||Phi(n)|| <= EPS +* with ||.|| the euclidean norm. +* REPSI array containing precision of each iteration. +* NSTART undefined. +* SIGAL total cross-section and albedo array. +* LPS used in scr acceleration. +* NGROUP number of groups. +* NGEFF number of groups to process. +* NGIND index of the groups to process. +* NCONV array of convergence flag for each group. +* LNCONV number of unconverged groups. +* NLIN number of polynomial components in flux spatial expansion. +* NFUNL number of moments of the flux (in 2D: NFUNL=NANI*(NANI+1)/2). +* KEYFLX position of flux elements in PHIOUT vector. +* KEYCUR position of current elements in PHIOUT vector. +* STIS Source term isolation option for flux integration. +* NPJJM number of pjj modes to store for STIS option. +* REBFLG ACA or SCR rebalancing flag. +* LPRISM 3D prismatic extended tracking flag. +* N2REG number of regions in the 2D tracking if LPRISM. +* N2SOU number of external surfaces in the 2D tracking if LPRISM. +* NZP number of z-plans if LPRISM. +* DELU input track spacing for 3D track reconstruction if LPRISM. +* FACSYM tracking symmetry factor for maximum track length if LPRISM. +* IDIR direction of fundamental current for TIBERE with MoC +* (=0,1,2,3). +* NBATCH number of tracks processed in each OpenMP core (default: =1). +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT DOUBLE PRECISION(A-H,O-Z) +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) KPSYS(NGEFF),IPTRK,IPMACR + INTEGER NGEFF,IPRINT,IFTRAK,NDIM,KV,NUN,NLONG,NGROUP,NZON(NLONG), + 1 M,NANI,NMU,NMAX,IAAC,LC,PACA,ITST(NGEFF),NSTART,MAXI,NANGL,NREG, + 2 NSOUT,ISCR,LPS,NGIND(NGEFF),LNCONV,NLIN,NFUNL,KEYFLX(NREG,NLIN, + 3 NFUNL),KEYCUR(NLONG-NREG),STIS,NPJJM,MATALB(-NSOUT:NREG),N2REG, + 4 N2SOU,NZP,IDIR,NBATCH + REAL QFR(NUN,NGEFF),PHIIN(NUN,NGEFF),CPO(NMU),ZMU(NMU), + 1 WZMU(NMU),VOL(NLONG),EPS(NGEFF),ERRTOL,REPSI(MAXI,NGEFF), + 2 SIGAL(-6:M,NGEFF),DELU,FACSYM + DOUBLE PRECISION PHIOUT(NUN,NGEFF),CAZ0(NANGL),CAZ1(NANGL), + 1 CAZ2(NANGL),SOUR(NUN,NGEFF) + LOGICAL LFORW,CYCLIC,NCONV(NGEFF),REBFLG,LPRISM + EXTERNAL SUBFFI,SUBFFA,SUBLDC,SUBSCH +*--- +* Local variables +*--- + REAL EPSINTO,FAC + LOGICAL RHSFLG + PARAMETER (FAC=100.0,MAXINT=200) +*--- +* Allocatable arrays +*--- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KMAX + REAL, ALLOCATABLE, DIMENSION(:,:) :: RHS, GAR + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DENOM, RHO + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: R, G, C, S, FLOUT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: V, H +*--- +* Scratch storage allocation +*--- + ALLOCATE(DENOM(NGEFF),RHO(NGEFF),KMAX(NGEFF),FLOUT(NUN,NGEFF)) + ALLOCATE(RHS(NUN,NGEFF),GAR(NUN,NGEFF),V(NUN,NGEFF,NSTART+1), + 1 G(NSTART+1,NGEFF),H(NSTART+1,NSTART,NGEFF),C(NSTART+1,NGEFF), + 2 S(NSTART+1,NGEFF),R(NUN,NGEFF)) +* + IF(MAXI.LT.3) CALL XABORT('MCGMRE: MAXI MUST BE >= 3.') + RHSFLG=.TRUE. + EPSINTO=ERRTOL/FAC + MAXIT=MAXI-1 + NCONV(:)=.FALSE. + RHO(:)=0.0D0 + LNCONV=0 + DO II=1,NGEFF + DENOM(II)=SQRT(DOT_PRODUCT(QFR(:,II),QFR(:,II))) + RHO(II)=1.0D20 + NCONV(II)=(DENOM(II) /= 0.0D0) + IF(NCONV(II)) LNCONV=LNCONV+1 + ITST(II)=0 + EPS(II)=0.0 + ENDDO +*--- +* Global GMRES(M) iteration +*--- + ITER=0 + DO WHILE((LNCONV /= 0) .AND. (ITER < MAXIT)) + ITER=ITER+1 + CALL MCGFL1(SUBFFI,SUBFFA,SUBLDC,SUBSCH,CYCLIC,KPSYS,IPRINT, + 1 IPTRK,IFTRAK,IPMACR,NDIM,KV,NUN,NLONG,PHIOUT(1,1),NZON, + 2 MATALB,M,NANI,NMU,NMAX,NANGL,NREG,NSOUT,NGROUP,NGEFF,NGIND, + 3 SOUR,IAAC,ISCR,LC,LFORW,PACA,EPSINTO,MAXINT,NLIN,NFUNL, + 4 KEYFLX,KEYCUR,QFR,PHIIN(1,1),CAZ0,CAZ1,CAZ2,CPO,ZMU,WZMU, + 5 VOL,SIGAL,LPS,NCONV,.FALSE.,STIS,NPJJM,REBFLG,LPRISM,N2REG, + 6 N2SOU,NZP,DELU,FACSYM,IDIR,NBATCH) + ERROR=0.0D0 + DO II=1,NGEFF + REPSI(ITER,II)=0.0 + IF(.NOT.NCONV(II)) CYCLE + R(:,II)=PHIOUT(:,II)-PHIIN(:,II) + RHO(II)=SQRT(DOT_PRODUCT(R(:,II),R(:,II))) + REPSI(ITER,II)=REAL(RHO(II)/DENOM(II)) + IF(IPRINT.GT.4) WRITE(6,200) ITER,II,REPSI(ITER,II) + EPS(II)=REPSI(ITER,II) + ITST(II)=ITER + ERROR=MAX(ERROR,RHO(II)/DENOM(II)) + IF(RHO(II) < ERRTOL*DENOM(II)) THEN + NCONV(II)=.FALSE. + LNCONV=LNCONV-1 + ENDIF + ENDDO +* +* Test do termination on entry + IF(LNCONV == 0) EXIT +* + H(:,:,:)=0.0D0 + V(:,:,:)=0.0D0 + C(:,:)=0.0D0 + S(:,:)=0.0D0 + G(:,:)=0.0D0 + KMAX(:)=0 + DO II=1,NGEFF + IF(.NOT.NCONV(II)) CYCLE + G(1,II)=RHO(II) + V(:,II,1)=R(:,II)/RHO(II) + ENDDO +*--- +* Evaluate RHS of the linear system +*--- + IF(RHSFLG) THEN + IF(IPRINT > 3) WRITE(6,100) IAAC,ISCR + RHS(:,:)=0.0 + CALL MCGFL1(SUBFFI,SUBFFA,SUBLDC,SUBSCH,CYCLIC,KPSYS,IPRINT, + 1 IPTRK,IFTRAK,IPMACR,NDIM,KV,NUN,NLONG,FLOUT(1,1),NZON, + 2 MATALB,M,NANI,NMU,NMAX,NANGL,NREG,NSOUT,NGROUP,NGEFF, + 3 NGIND,SOUR,IAAC,ISCR,LC,LFORW,PACA,EPSINTO,MAXINT,NLIN, + 4 NFUNL,KEYFLX,KEYCUR,QFR,RHS(1,1),CAZ0,CAZ1,CAZ2,CPO,ZMU, + 5 WZMU,VOL,SIGAL,LPS,NCONV,.FALSE.,STIS,NPJJM,REBFLG, + 6 LPRISM,N2REG,N2SOU,NZP,DELU,FACSYM,IDIR,NBATCH) + DO II=1,NGEFF + IF(NCONV(II)) RHS(:,II)=REAL(FLOUT(:,II)) + ENDDO + RHSFLG=.FALSE. + ENDIF +*--- +* GMRES(1) iteration +*--- + K=0 + DO WHILE((LNCONV /= 0) .AND. (K < NSTART) .AND. (ITER < MAXIT)) + K=K+1 + ITER=ITER+1 + GAR(:,:)=REAL(V(:,:,K)) + CALL MCGFL1(SUBFFI,SUBFFA,SUBLDC,SUBSCH,CYCLIC,KPSYS,IPRINT, + 1 IPTRK,IFTRAK,IPMACR,NDIM,KV,NUN,NLONG,FLOUT(1,1),NZON, + 2 MATALB,M,NANI,NMU,NMAX,NANGL,NREG,NSOUT,NGROUP,NGEFF, + 3 NGIND,SOUR,IAAC,ISCR,LC,LFORW,PACA,EPSINTO,MAXINT,NLIN, + 4 NFUNL,KEYFLX,KEYCUR,QFR,GAR(1,1),CAZ0,CAZ1,CAZ2,CPO,ZMU, + 5 WZMU,VOL,SIGAL,LPS,NCONV,.FALSE.,STIS,NPJJM,REBFLG, + 6 LPRISM,N2REG,N2SOU,NZP,DELU,FACSYM,IDIR,NBATCH) + V(:,:,K+1)=V(:,:,K)-FLOUT(:,:)+RHS(:,:) + ERROR=0.0D0 + DO II=1,NGEFF + REPSI(ITER,II)=0.0 + IF(.NOT.NCONV(II)) CYCLE + KMAX(II)=K +* +* Modified Gram-Schmidt + DO J=1,K + H(J,K,II)=DOT_PRODUCT(V(:,II,J),V(:,II,K+1)) + V(:,II,K+1)=V(:,II,K+1)-H(J,K,II)*V(:,II,J) + ENDDO + H(K+1,K,II)=SQRT(DOT_PRODUCT(V(:,II,K+1),V(:,II,K+1))) +* +* Reorthogonalize + DO J=1,K + HR=DOT_PRODUCT(V(:,II,J),V(:,II,K+1)) + H(J,K,II)=H(J,K,II)+HR + V(:,II,K+1)=V(:,II,K+1)-HR*V(:,II,J) + ENDDO + H(K+1,K,II)=SQRT(DOT_PRODUCT(V(:,II,K+1),V(:,II,K+1))) +* + ! Watch out do happy breakdown + IF(H(K+1,K,II) /= 0.0D0) V(:,II,K+1)=V(:,II,K+1)/H(K+1,K,II) +* +* Form and store the information for the new Givens rotation + DO I=1,K-1 + W1=C(I,II)*H(I,K,II)-S(I,II)*H(I+1,K,II) + W2=S(I,II)*H(I,K,II)+C(I,II)*H(I+1,K,II) + H(I,K,II)=W1 + H(I+1,K,II)=W2 + ENDDO + ZNU=SQRT(H(K,K,II)**2+H(K+1,K,II)**2) + IF(ZNU /= 0.0D0) THEN + C(K,II)=H(K,K,II)/ZNU + S(K,II)=-H(K+1,K,II)/ZNU + H(K,K,II)=C(K,II)*H(K,K,II)-S(K,II)*H(K+1,K,II) + H(K+1,K,II)=0.0D0 + W1=C(K,II)*G(K,II)-S(K,II)*G(K+1,II) + W2=S(K,II)*G(K,II)+C(K,II)*G(K+1,II) + G(K,II)=W1 + G(K+1,II)=W2 + ENDIF +* +* Update the residual norm + RHO(II)=ABS(G(K+1,II)) + REPSI(ITER,II)=REAL(RHO(II)/DENOM(II)) + IF(IPRINT.GT.4) WRITE(6,200) ITER,II,REPSI(ITER,II) + EPS(II)=REPSI(ITER,II) + ITST(II)=ITER + IF(RHO(II) < ERRTOL*DENOM(II)) THEN + NCONV(II)=.FALSE. + LNCONV=LNCONV-1 + ENDIF + ERROR=MAX(ERROR,RHO(II)/DENOM(II)) + ENDDO + ENDDO +*--- +* At this point either K > NSTART or RHOGRP < ERRTOL. It's time to +* compute PHIIN and cycle. +*--- + DO II=1,NGEFF + K=KMAX(II) + IF(K == 0) CYCLE + G(K,II)=G(K,II)/H(K,K,II) + DO L=K-1,1,-1 + W1=G(L,II)-DOT_PRODUCT(H(L,L+1:K,II),G(L+1:K,II)) + G(L,II)=W1/H(L,L,II) + ENDDO + DO J=1,K + PHIIN(:,II)=PHIIN(:,II)+REAL(G(J,II)*V(:,II,J)) + ENDDO + ENDDO + ENDDO +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(R, S, C, H, G, V, GAR, RHS) + DEALLOCATE(FLOUT, KMAX, RHO, DENOM) + RETURN +* + 100 FORMAT(' MCGMRE: RHS CALCULATED WITH AAC-SCR : ',I2,1H-,I1) + 200 FORMAT(' MCGMRE: EPS Iteration ',I5,' Group ',I5,2X,1P,E16.7) + END diff --git a/Dragon/src/MCGPJJ.f b/Dragon/src/MCGPJJ.f new file mode 100644 index 0000000..c837c56 --- /dev/null +++ b/Dragon/src/MCGPJJ.f @@ -0,0 +1,109 @@ +*DECK MCGPJJ + SUBROUTINE MCGPJJ(IPTRK,IPRINT,NDIM,NANI,MAXNU,NPJJM,KEYANI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the effective number of pjj intermodes to be stored in 2D or +* 3D and the corresponding index when an expansion up to order L +* of the scattering cross-section is considered in order to +* construct the source term of the scalar flux moments for +* a method of characteristics iteration. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IPTRK pointer to the tracking (L_TRACK signature). +* IPRINT print flag (> 1 for print). +* NDIM number of dimensions for the geometry. +* NANI scattering anisotropy (=1 for isotropic scattering). +* MAXNU number of angular modes nu=(l,m). +* KEYANI 'mode to l' index: l=KEYANI(nu): +* Cartesian 2D KEYANI(NU)=INT(0.5*(SQRT(REAL(1+8*(NU-1)))-1.0)); +* Cartesian 3D KEYANI(NU)=INT(SQRT(REAL(NU-1))). +* +*Parameters: output +* NPJJM number of non-vanishing pjj modes. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER IPRINT,NDIM,NANI,MAXNU,NPJJM,KEYANI(MAXNU) +*---- +* LOCAL VARIABLES +*---- + INTEGER MAXPJJM,IL,INU,ILP,INUP,L,LT,DT,NMODE,NMODO,NPJJM0 + LOGICAL EVEN + CHARACTER CDIM*2 + INTEGER, ALLOCATABLE, DIMENSION(:) :: IPJJM +*--- +* Compute the number of effective modes +*--- + MAXPJJM=MAXNU*(MAXNU+1)/2 + L=NANI-1 + LT=L/2 + DT=L-2*LT + IF (NDIM.EQ.2) THEN + CDIM='2D' + NMODE=(LT+1)**2 ! number of 'even l' modes + NMODO=(LT+1)*(LT+2*DT) ! number of 'odd l' modes + ELSE ! NDIM.EQ.3 + CDIM='3D' + NMODE=(L+1-DT)*(LT+1) + NMODO=(L+1+DT)*(LT+DT) + ENDIF +* 'even l' and 'odd l' modes are unconnected +* (i.e. pjj('even l' <- 'odd l') = 0) +* and pjj(nu <- nu') = pjj(nu' <- nu) +* so the effective number of pjj is + NPJJM=NMODE*(NMODE+1)/2+NMODO*(NMODO+1)/2 +* + IF (IPRINT.GT.1) THEN + WRITE(*,*) '--------------------' + WRITE(*,*) 'ANISOTROPY INDEX FOR L=',NANI-1,' IN ',CDIM + CALL PRINIM('NU->L ',KEYANI(1),MAXNU) + WRITE(*,*) '--------------------' + WRITE(*,*) NPJJM, + 1 ' PJJ(NU <- NU'') MODES OUT OF',MAXPJJM,' TO BE STORED' + ENDIF +*--- +* Compute and store the indexes for these modes +*--- + ALLOCATE(IPJJM(2*NPJJM)) + NPJJM0=-1 + DO INU=1,MAXNU + IL=KEYANI(INU) + DO INUP=1,INU + ILP=KEYANI(INUP) + EVEN=(MOD((IL+ILP),2).EQ.0) + IF (EVEN) THEN + NPJJM0=NPJJM0+1 + IPJJM(NPJJM0+1)=INU + IPJJM(NPJJM+NPJJM0+1)=INUP + ENDIF + ENDDO + ENDDO + NPJJM0=NPJJM0+1 + IF(NPJJM0.NE.NPJJM) CALL XABORT('MCGPIJ: bug.') + CALL LCMPUT(IPTRK,'PJJIND$MCCG',2*NPJJM,1,IPJJM) + IF (IPRINT.GT.1) THEN + WRITE(*,*) 'INDEXES FOR THE CORRESPONDING',NPJJM,' MODES:' + CALL PRINIM('-> NU ',IPJJM(1),NPJJM) + CALL PRINIM('NU''-> ',IPJJM(NPJJM+1),NPJJM) + ENDIF + DEALLOCATE(IPJJM) +* + RETURN + END diff --git a/Dragon/src/MCGPRA.f b/Dragon/src/MCGPRA.f new file mode 100644 index 0000000..169f0f3 --- /dev/null +++ b/Dragon/src/MCGPRA.f @@ -0,0 +1,159 @@ +*DECK MCGPRA + SUBROUTINE MCGPRA(LFORW,OPT,PACA,FLOUT,NLONG,LC,IM,MCU,JU,DIAGM, + 1 CM,ILUDF,ILUCF,DIAGF,XIN,XOUT,LC0,IM0,MCU0,CF) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Multiply a matrix stored in MSR format with a vector +* and apply preconditioner (diagonal / ILUO stored in MSR format) +* to this vector. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* LFORW flag set to .false. to transpose the coefficient matrix. +* OPT 1 product matrix-vector only; +* 2 preconditioner only; +* 3 both. +* PACA type of preconditioner. +* FLOUT flag for output: +* .false. matrix-vector product to -preconditioned vector +* to XOUT; +* .true. matrix-vector product to XOUT and +* preconditioned vector to XIN. +* NLONG size of the corrective system. +* LC dimension of profiled matrices MCU and CM. +* IM MSR indexes vector. +* MCU MSR indexes vector. +* JU used in ACA acceleration for ilu0. +* DIAGM diagonal of matrix to multiply by. +* CM non-diagonal elements of matrix to multiply by. +* ILUDF diagonal of ilu0 matrix. +* ILUCF non-diagonal elements of ilu0 matrix. +* DIAGF vector of diagonal preconditioning. +* LC0 used in ILU0-ACA acceleration. +* IM0 used in ILU0-ACA acceleration. +* MCU0 used in ILU0-ACA acceleration. +* CF non-diagonal elements of the matrix +* corresponding to the ILU0 decomposition ILUCF. +* +*Parameters: input/output +* XIN input vector to be precondition. +* +*Parameters: output +* XOUT output vector preconditioned. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER OPT,PACA,NLONG,LC,IM(NLONG),MCU(LC),JU(NLONG),LC0,IM0(*), + 1 MCU0(*) + REAL DIAGM(NLONG),CM(LC),ILUDF(NLONG),ILUCF(LC),DIAGF(NLONG), + 1 CF(LC) + DOUBLE PRECISION XIN(NLONG),XOUT(NLONG) + LOGICAL LFORW,FLOUT +*--- +* LOCAL VARIABLES +*--- + INTEGER I,J,IJ + DOUBLE PRECISION FF +* + IF(MOD(OPT,2).EQ.1) THEN +*--- +* MATRIX VECTOR PRODUCT +*--- + IF(LFORW) THEN +* direct calculation + DO I=1,NLONG + FF=XIN(I)*DIAGM(I) + DO IJ=IM(I)+1,IM(I+1) + J=MCU(IJ) + IF((J.GT.0).AND.(J.LE.NLONG)) FF=FF+CM(IJ)*XIN(J) + ENDDO + XOUT(I)=FF + ENDDO + ELSE +* adjoint calculation + DO I=1,NLONG + XOUT(I)=XIN(I)*DIAGM(I) + ENDDO + DO I=1,NLONG + DO IJ=IM(I)+1,IM(I+1) + J=MCU(IJ) + IF((J.GT.0).AND.(J.LE.NLONG)) XOUT(J)=XOUT(J) + 1 +CM(IJ)*XIN(I) + ENDDO + ENDDO + ENDIF + ENDIF +* + IF((OPT/2).EQ.1) THEN +*--- +* APPLY PRECONDITIONER +*--- + IF(PACA.EQ.4) THEN +* apply ILU0 preconditioner (optimized storage = no extra-storage) + IF(FLOUT) THEN + CALL MSRLUS1(LFORW,NLONG,LC,IM,MCU,JU,ILUDF,CF,XOUT,XIN) + ELSE + CALL MSRLUS1(LFORW,NLONG,LC,IM,MCU,JU,ILUDF,CF,XOUT,XOUT) + ENDIF + ELSE IF(PACA.EQ.3) THEN +* apply ILU0 preconditioner (optimized storage) + IF(FLOUT) THEN + CALL MSRLUS2(LFORW,NLONG,LC,LC0,IM,MCU,IM0,MCU0,JU,ILUDF, + 1 ILUCF,CF,XOUT,XIN) + ELSE + CALL MSRLUS2(LFORW,NLONG,LC,LC0,IM,MCU,IM0,MCU0,JU,ILUDF, + 1 ILUCF,CF,XOUT,XOUT) + ENDIF + ELSEIF(PACA.EQ.2) THEN +* apply ILU0 preconditioner (complete storage) + IF(FLOUT) THEN + CALL MSRLUS(LFORW,NLONG,LC,IM,MCU,JU,ILUDF,ILUCF,XOUT,XIN) + ELSE + CALL MSRLUS(LFORW,NLONG,LC,IM,MCU,JU,ILUDF,ILUCF,XOUT,XOUT) + ENDIF + ELSEIF(PACA.EQ.1) THEN +* apply Diagonal preconditioner + IF(FLOUT) THEN + DO I=1,NLONG + XIN(I)=XOUT(I)/DIAGF(I) + ENDDO + ELSE + DO I=1,NLONG + XOUT(I)=XOUT(I)/DIAGF(I) + ENDDO + ENDIF + ELSEIF(PACA.EQ.0) THEN +* no preconditioner + IF(FLOUT) THEN + DO I=1,NLONG + XIN(I)=XOUT(I) + ENDDO + ENDIF + ENDIF + ELSE +*--- +* DO NOT APPLY PRECONDITIONER +*--- + IF(FLOUT) THEN + DO I=1,NLONG + XIN(I)=XOUT(I) + ENDDO + ENDIF + ENDIF +* + RETURN + END diff --git a/Dragon/src/MCGPT1.f b/Dragon/src/MCGPT1.f new file mode 100644 index 0000000..3910790 --- /dev/null +++ b/Dragon/src/MCGPT1.f @@ -0,0 +1,154 @@ +*DECK MCGPT1 + SUBROUTINE MCGPT1(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I,K,ZI, + 1 TK,TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Reconstruct 3D track for a 3D prismatic geometry from a 2D track. +* polar angle in [0, pi/2] case. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* N2SOU number of external surfaces in the 2D tracking. +* N2REG number of regions in the 2D tracking. +* NZP number of z-planes. +* NR2D number of segments corresponding to regions for this 2D track. +* INDREG region/surface index to go from the 2D to the 3D geometry. +* Z z-plan coordinates. +* NOM2D vector containing the region number of the different segments +* of this 2D track. +* T2D vector containing the local coordinates of the segments +* boundaries for this 2D track. +* CPOI inverse of the polar cosine. +* SPOI inverse of the polar sine. +* TPO polar tangent. +* TPOI polar cotangent. +* +*Parameters: input/output +* I starting/ending z plan. +* K starting/ending x-y tracking segment. +* ZI strating/ending z coordinate. +* TK starting/ending x-y tracking coordinate. +* TIN orientation of the starting/surface. +* +*Parameters: output +* N3D number of segments for this 3D track. +* NOM3D vector containing the region number of the different segments +* of this 3D track. +* H3D vector containing the length of the different segments of this +* 3D track. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N2SOU,N2REG,NZP,NR2D,INDREG(-N2SOU:N2REG,0:NZP+1), + 1 NOM2D(NR2D+2),I,K,N3D,NOM3D(*),TIN + REAL Z(0:NZP) + DOUBLE PRECISION ZI,TK,CPOI,SPOI,TPO,TPOI,H3D(N3D),T2D(0:NR2D) +*--- +* LOCAL VARIABLES +*--- +!! INTEGER II,N3DP + DOUBLE PRECISION DELZ,DELT,X,L +!! REAL Tstart,Zstart +* +!!!! Tstart=TK +!!!! Zstart=ZI +!!!! N3DP=N3D + DO WHILE ((I.LE.NZP).AND.(K.LE.NR2D)) + N3D=N3D+1 + NOM3D(N3D)=INDREG(NOM2D(K+1),I) + IF (TIN.EQ.0) THEN +* track enters the region through bottom boundary + DELZ=Z(I)-Z(I-1) + DELT=T2D(K)-TK + ELSE +* track enters the region through left boundary + DELZ=Z(I)-ZI + DELT=T2D(K)-T2D(K-1) + ENDIF + X=DELT/DELZ + IF (TPO.LT.X) THEN +* track leaves the region through the top boundary + ZI=Z(I) + I=I+1 + TK=TK+DELZ*TPO + L=DELZ*CPOI + TIN=0 + ELSE +* track leaves the region through the right boundary + TK=T2D(K) + K=K+1 + ZI=ZI+DELT*TPOI + L=DELT*SPOI + TIN=1 + ENDIF + IF (L.GT.0.0) THEN + H3D(N3D)=DBLE(L) + ELSE + N3D=N3D-1 + ENDIF + ENDDO + N3D=N3D+1 + H3D(N3D)=0.5 + NOM3D(N3D)=INDREG(NOM2D(K+1),I) +!!!! call MCGPTP(8,N3D-N3DP+1,NOM3D(N3DP),Tstart,ZStart,CPO,SPO, +!!!! 1 H3D(N3DP),1) +* + RETURN +* + END + +!!!!*DECK MCGPTP +!!!! SUBROUTINE MCGPTP(IPOUT,N3D,NOM3D,TS,ZS,CPO,SPO,H3D,DIR) +!!!!* +!!!! IMPLICIT NONE +!!!!* +!!!! INTEGER IPOUT,N3D,NOM3D(N3D),DIR +!!!! REAL TS,ZS,H3D(N3D) +!!!! DOUBLE PRECISION CPO,SPO +!!!!* +!!!! INTEGER II +!!!! REAL ZE,TE +!!!!* +!!!! WRITE(IPOUT,201) TS,ZS,NOM3D(1) +!!!! DO II=2,N3D-1 +!!!! TE=TS+H3D(II)*SPO +!!!! IF (DIR.EQ.1) ZE=ZS+H3D(II)*CPO +!!!! IF (DIR.EQ.2) ZE=ZS-H3D(II)*CPO +!!!! WRITE(IPOUT,100) TS,TE,ZS,ZE +!!!! WRITE(IPOUT,200) 0.5*(TS+TE),0.5*(ZS+ZE),NOM3D(II) +!!!! TS=TE +!!!! ZS=ZE +!!!! ENDDO +!!!! WRITE(IPOUT,202) TS,ZS,NOM3D(N3D) +!!!!* +!!!! RETURN +!!!!* +!!!! 100 FORMAT( +!!!! 1 7H line([,E16.8,1H,,E16.8,3H],[,E16.8,1H,,E16.8,2H],, +!!!! 2 14H 'Marker','+')/) +!!!! 200 FORMAT( +!!!! 1 6H text(,E16.8,1H,,E16.8,1H,,1H',I4,2H',, +!!!! 2 32H 'HorizontalAlignment','center')/) +!!!! 201 FORMAT( +!!!! 1 6H text(,E16.8,1H,,E16.8,1H,,1H',I4,2H',, +!!!! 2 27H 'VerticalAlignment','top',, +!!!! 3 31H 'HorizontalAlignment','right')/) +!!!! 202 FORMAT( +!!!! 1 6H text(,E16.8,1H,,E16.8,1H,,1H',I4,2H',, +!!!! 2 30H 'VerticalAlignment','bottom',, +!!!! 3 30H 'HorizontalAlignment','left')/) +!!!! END diff --git a/Dragon/src/MCGPT2.f b/Dragon/src/MCGPT2.f new file mode 100644 index 0000000..d8bd531 --- /dev/null +++ b/Dragon/src/MCGPT2.f @@ -0,0 +1,112 @@ +*DECK MCGPT2 + SUBROUTINE MCGPT2(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I,K,ZI, + 1 TK,TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Reconstruct 3D track for a 3D prismatic geometry from a 2D track. +* polar angle in [pi/2, pi] case. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* N2SOU number of external surfaces in the 2D tracking. +* N2REG number of regions in the 2D tracking. +* NZP number of z-planes. +* NR2D number of segments corresponding to regions for this 2D track. +* INDREG region/surface index to go from the 2D to the 3D geometry. +* Z z-plan coordinates. +* NOM2D vector containing the region number of the different segments of +* this 2D track. +* T2D vector containing the local coordinates of the segments +* boundaries for this 2D track. +* CPOI inverse of the polar cosine. +* SPOI inverse of the polar sine. +* TPO polar tangent. +* TPOI polar cotangent. +* +*Parameters: input/output +* I starting/ending z plan. +* K starting/ending x-y tracking segment. +* ZI strating/ending z coordinate. +* TK starting/ending x-y tracking coordinate. +* TIN orientation of the starting/surface. +* +*Parameters: output +* N3D number of segments for this 3D track. +* NOM3D vector containing the region number of the different segments +* of this 3D track. +* H3D vector containing the length of the different segments of this +* 3D track. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N2SOU,N2REG,NZP,NR2D,INDREG(-N2SOU:N2REG,0:NZP+1), + 1 NOM2D(NR2D+2),I,K,N3D,NOM3D(*),TIN + REAL Z(0:NZP) + DOUBLE PRECISION ZI,TK,CPOI,SPOI,TPO,TPOI,H3D(N3D),T2D(0:NR2D) +*--- +* LOCAL VARIABLES +*--- +!! INTEGER N3DP + DOUBLE PRECISION DELZ,DELT,X,L +!! REAL Tstart,Zstart +* +!!!! Tstart=TK +!!!! Zstart=ZI +!!!! N3DP=N3D + DO WHILE ((I.GE.1).AND.(K.LE.NR2D)) + N3D=N3D+1 + NOM3D(N3D)=INDREG(NOM2D(K+1),I) + IF (TIN.EQ.0) THEN +* track enters the region through top boundary + DELZ=Z(I)-Z(I-1) + DELT=T2D(K)-TK + ELSE +* track enters the region through right boundary + DELZ=ZI-Z(I-1) + DELT=T2D(K)-T2D(K-1) + ENDIF + X=DELT/DELZ + IF (TPO.LT.X) THEN +* track leaves the region through the bottom boundary + ZI=Z(I-1) + I=I-1 + TK=TK+DELZ*TPO + L=DELZ*CPOI + TIN=0 + ELSE +* track leaves the region through the right boundary + TK=T2D(K) + K=K+1 + ZI=ZI-DELT*TPOI + L=DELT*SPOI + TIN=1 + ENDIF + IF (L.GT.0.0) THEN + H3D(N3D)=DBLE(L) + ELSE + N3D=N3D-1 + ENDIF + ENDDO + N3D=N3D+1 + H3D(N3D)=0.5 + NOM3D(N3D)=INDREG(NOM2D(K+1),I) +!!!! call MCGPTP(8,N3D-N3DP+1,NOM3D(N3DP),Tstart,ZStart,CPO,SPO, +!!!! 1 H3D(N3DP),2) +* + RETURN +* + END diff --git a/Dragon/src/MCGPTA.f b/Dragon/src/MCGPTA.f new file mode 100644 index 0000000..82cab66 --- /dev/null +++ b/Dragon/src/MCGPTA.f @@ -0,0 +1,402 @@ +*DECK MCGPTA + SUBROUTINE MCGPTA(NFI,NREG,NLONG,M,NANGL,NMU,LC,NGEFF, + 1 IANGL,NSEG,NOM2D,NZONA,IPERM,KM,IM,MCU,PREV, + 2 NEXT,W2D,ZMU,WZMU,SIGAL,XSW,T2D,DIAGQ,CQ, + 3 DIAGF,CF,WORK,LTMT,SUBDS2,SUBDSP,SUBDSC,NR2D, + 4 NMAX,NZP,N2REG,N2SOU,DELU,INDREG,NOM3D,NOM3D0, + 5 H3D,H3D0,Z,VNORF,CMU,CMUI,SMU,SMUI,TMU,TMUI, + 6 N3TR,N3TRTMT,N3SE,N3SETMT,N2TPROC,SSYM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Flux integration upon the tracking (3D prismatic extended tracking). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* NFI total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* NREG number of volumes. +* NLONG order of the corrective system. +* M number of material mixtures. +* NANGL number of tracking angles in the plane. +* NMU order of the polar quadrature. +* LC dimension of vector MCU. +* NGEFF number of energy groups to process. +* IANGL direction index for the current 2D track. +* NSEG number of segments for the current 2D track. +* NOM2D vector containing the region number of the different +* segments of this 2D track. +* NZONA index-number of the mixture type assigned to each volume +* for ACA. +* IPERM permutation array. +* KM used in CDD acceleration. +* IM used in CDD acceleration. +* MCU used in CDD acceleration. +* W2D 2D track weight. +* ZMU polar quadrature set in 2D. +* WZMU polar quadrature set in 2D. +* SIGAL total cross-section and albedo array. +* XSW scattering cross sections array. +* T2D vector containing the local coordinates of the segments +* boundaries for this 2D track. +* LTMT track merging flag. +* SUBDS2 ACA coefficients summation subroutine. +* SUBDSP ACA coefficients position subroutine. +* SUBDSC ACA coefficients calculation subroutine for this 2D track. +* NR2D number of segments corresponding to regions for this 2D track. +* NMAX maximum number of segments for the 3D tracks. +* NZP number of z-planes. +* N2SOU number of external surfaces in the 2D tracking. +* N2REG number of regions in the 2D tracking. +* DELU input track spacing for 3D track reconstruction. +* INDREG region/surface index to go from the 2D to the 3D geometry. +* Z z-plan coordinates. +* VNORF normalization factors per angle. +* CMU polar angle cosines. +* CMUI inverse of polar angle cosines. +* SMU polar angle sines. +* SMUI inverse of polar angle sines. +* TMU polar angle tangents. +* TMUI inverse of polar angle tangents. +* N2TPROC number of 2D tracks corresponding to this merged track (if LTMT). +* SSYM symmetry flag. +* +*Parameters: input/output +* CQ undefined. +* CF undefined. +* DIAGQ undefined. +* DIAGF undefined. +* N3TR total number of 3D tracks generated. +* N3TRTMT total number of 3D merged tracks. +* N3SE total number of segments on the 3D tracks generated. +* N3SETMT total number of segments on the 3D merged tracks. +* +*Parameters: scratch +* PREV undefined. +* NEXT undefined. +* WORK undefined. +* NOM3D undefined. +* NOM3D0 undefined. +* H3D undefined. +* H3D0 undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NFI,NREG,NLONG,M,NANGL,NMU,LC,NGEFF,IANGL,NSEG, + 1 NOM2D(NSEG),NZONA(NFI),IPERM(NFI),KM(NLONG),IM(NLONG),MCU(LC), + 2 NMAX,PREV(NMAX),NEXT(NMAX),NR2D,NZP,N2REG,N2SOU, + 3 INDREG(-N2SOU:N2REG,0:NZP+1),NOM3D(NMAX),NOM3D0(NMAX,2),N3TR, + 4 N3TRTMT,N3SE,N3SETMT,N2TPROC,SSYM + REAL ZMU(NMU),WZMU(NMU),SIGAL(-6:M,NGEFF),XSW(0:M,NGEFF), + 1 DIAGQ(NLONG,NGEFF),CQ(LC,NGEFF),DELU,Z(0:NZP) + DOUBLE PRECISION W2D,DIAGF(NLONG,NGEFF),CF(LC,NGEFF),WORK(NMAX,3), + 1 VNORF(NREG,NANGL,NMU,2),CMU(NMU),CMUI(NMU),SMU(NMU),SMUI(NMU), + 2 TMU(NMU),TMUI(NMU),H3D(NMAX),H3D0(NMAX,2),T2D(0:NR2D) + LOGICAL LTMT + EXTERNAL SUBDS2,SUBDSP,SUBDSC +*---- +* LOCAL VARIABLES +*---- + INTEGER IMU,NBTR,KST,IST,ILINE,I,I1,I2,K,N3D,II,NMERG1,NMERG2, + 1 N3D01,N3D02,TIN,NTR,NSE,NTPROC,N3DP + DOUBLE PRECISION CPO,CPOI,SPO,SPOI,TPO,TPOI,LTOT,DELTE,DELZE,T, + 1 Z1,Z2,TP,Z1P,W3D,W3D01,W3D02,W3DPO,W3DS,WPO + LOGICAL LFORC +* + NTR=0 + NSE=0 + DO IMU=1,NMU +* ------------polar angle loop + NMERG1=0 + NMERG2=0 + LFORC=.FALSE. + CPO=CMU(IMU) + CPOI=CMUI(IMU) + SPO=SMU(IMU) + SPOI=SMUI(IMU) + TPO=TMU(IMU) + TPOI=TMUI(IMU) + WPO=WZMU(IMU) + IF (SSYM.EQ.2) GOTO 15 +*--- +* CONSTRUCT THE 3D TRACKS WHICH ENTER THE GEOMETRY THROUGH A BOTTOM/TOP SURFACE +*--- +* length of the spatial integration interval + LTOT=T2D(NR2D)*CPO +* number of 3D tracks generated for this x-y track and this polar direction + NBTR=INT(LTOT/DELU)+1 +* effective track spacing in T + DELTE=T2D(NR2D)/DBLE(NBTR) + W3DPO=W2D*DELTE*CPO + W3DS=WPO*W3DPO + T=-0.5D0*DELTE + KST=1 + DO 10 ILINE=1,NBTR + T=T+DELTE + TP=T + DO WHILE (T2D(KST).LT.T) + KST=KST+1 + ENDDO + K=KST +* --- +* positive polar sine track +* --- + I1=1 + Z1=Z(I1-1) + TIN=0 + W3D=W3DS + N3D=1 + NOM3D(N3D)=INDREG(NOM2D(K+1),0) + H3D(N3D)=0.5 + CALL MCGPT1(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I1,K,Z1,T, + 1 TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=2,N3D-1 + H3D(II)=H3D(II)*VNORF(NOM3D(II),IANGL,IMU,1) + ENDDO + IF (SSYM.EQ.1) THEN +* the top boundary condition is a surface symmetry + IF (TIN.EQ.0) THEN +* this track has encountered the top boundary -> it is reflected + N3DP=N3D + N3D=N3D-1 + I1=I1-1 + CALL MCGPT2(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I1,K,Z1, + 1 T,TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=N3DP,N3D-1 + H3D(II)=H3D(II)*VNORF(NOM3D(II),IANGL,IMU,2) + ENDDO + ENDIF + ENDIF + IF (LTMT) THEN + NTR=NTR+1 + NSE=NSE+N3D + CALL MCGTMT(NMERG1,N3TRTMT,N3SETMT,N3D,N3D01,NOM3D, + 1 NOM3D0(1,1),W3D,W3D01,H3D,H3D0(1,1),LFORC,NTPROC) + IF (NTPROC.EQ.0) GOTO 31 + ENDIF + NOM3D(1)=NREG-NOM3D(1) + NOM3D(N3D)=NREG-NOM3D(N3D) + DO II=1,N3D + NOM3D(II)=IPERM(NOM3D(II)) + ENDDO + CALL MCGDS1(SUBDS2,SUBDSP,SUBDSC,N3D,NMU,NGEFF,W3D, + 1 H3D,ZMU,WZMU,NOM3D,NZONA,NLONG,NFI,3,LC,M,KM,IM, + 2 MCU,DIAGF,DIAGQ,CF,CQ,PREV,NEXT,SIGAL,XSW,WORK) + 31 T=TP + IF (SSYM.EQ.1) GOTO 10 + K=KST +* --- +* negative polar sine track +* --- + I2=NZP + Z2=Z(I2) + TIN=0 + W3D=W3DS + N3D=1 + NOM3D(N3D)=INDREG(NOM2D(K+1),NZP+1) + H3D(N3D)=0.5 + CALL MCGPT2(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I2,K,Z2,T, + 1 TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=2,N3D-1 + H3D(II)=H3D(II)*VNORF(NOM3D(II),IANGL,IMU,2) + ENDDO + IF (LTMT) THEN + NTR=NTR+1 + NSE=NSE+N3D + CALL MCGTMT(NMERG2,N3TRTMT,N3SETMT,N3D,N3D02,NOM3D, + 1 NOM3D0(1,2),W3D,W3D02,H3D,H3D0(1,2),LFORC,NTPROC) + IF (NTPROC.EQ.0) GOTO 32 + ENDIF + NOM3D(1)=NREG-NOM3D(1) + NOM3D(N3D)=NREG-NOM3D(N3D) + DO II=1,N3D + NOM3D(II)=IPERM(NOM3D(II)) + ENDDO + CALL MCGDS1(SUBDS2,SUBDSP,SUBDSC,N3D,NMU,NGEFF,W3D, + 1 H3D,ZMU,WZMU,NOM3D,NZONA,NLONG,NFI,3,LC,M,KM,IM, + 2 MCU,DIAGF,DIAGQ,CF,CQ,PREV,NEXT,SIGAL,XSW,WORK) +* --- + 32 T=TP + 10 CONTINUE +*--- +* CONSTRUCT THE 3D TRACKS WHICH ENTER THE GEOMETRY THROUGH A LATERAL SURFACE +*--- +* length of the spatial integration interval + 15 LTOT=Z(NZP)*SPO +! LTOT=(Z(NZP)-Z(0))*SPO with Z(0)=0.0 +* number of 3D tracks generated for this x-y track and this polar direction + NBTR=INT(LTOT/DELU)+1 +* effective track spacing in Z + DELZE=Z(NZP)/DBLE(NBTR) +! DELZE=(Z(NZP)-Z(0))/DBLE(NBTR) with Z(0)=0.0 + W3DPO=W2D*DELZE*SPO + W3DS=WPO*W3DPO + Z1=-0.5D0*DELZE +! Z1=Z(0)-0.5D0*DELZE with Z(0)=0.0 + IST=1 + DO 20 ILINE=1,NBTR + Z1=Z1+DELZE + Z1P=Z1 + DO WHILE (Z(IST).LT.Z1) + IST=IST+1 + ENDDO + I=IST +* --- +* positive polar sine track +* --- + K=1 + T=T2D(K-1) + TIN=1 + W3D=W3DS + N3D=1 + N3DP=2 + NOM3D(N3D)=INDREG(NOM2D(1),IST) + H3D(N3D)=0.5 + 21 CONTINUE + CALL MCGPT1(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I,K,Z1,T, + 1 TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=N3DP,N3D-1 + H3D(II)=H3D(II)*VNORF(NOM3D(II),IANGL,IMU,1) + ENDDO + IF (SSYM.GT.0) THEN +* the top boundary condition is a surface symmetry + IF (TIN.EQ.0) THEN +* this track has encountered the top boundary -> it is reflected + N3DP=N3D + N3D=N3D-1 + I=I-1 + CALL MCGPT2(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I,K,Z1, + 1 T,TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=N3DP,N3D-1 + H3D(II)=H3D(II)*VNORF(NOM3D(II),IANGL,IMU,2) + ENDDO + IF ((SSYM.EQ.2).AND.(TIN.EQ.0)) THEN +* the bottom boundary is a surface symmetry +* this track has encountered the bottom boundary -> it is reflected + N3DP=N3D + N3D=N3D-1 + I=I+1 + GOTO 21 + ENDIF + ENDIF + ENDIF + IF (LTMT) THEN + NTR=NTR+1 + NSE=NSE+N3D + IF (ILINE.EQ.NBTR) LFORC=.TRUE. + CALL MCGTMT(NMERG1,N3TRTMT,N3SETMT,N3D,N3D01,NOM3D, + 1 NOM3D0(1,1),W3D,W3D01,H3D,H3D0(1,1),LFORC,NTPROC) + IF (NTPROC.EQ.0) GOTO 41 + ENDIF + NOM3D(1)=NREG-NOM3D(1) + NOM3D(N3D)=NREG-NOM3D(N3D) + DO II=1,N3D + NOM3D(II)=IPERM(NOM3D(II)) + ENDDO + CALL MCGDS1(SUBDS2,SUBDSP,SUBDSC,N3D,NMU,NGEFF,W3D, + 1 H3D,ZMU,WZMU,NOM3D,NZONA,NLONG,NFI,3,LC,M,KM,IM, + 2 MCU,DIAGF,DIAGQ,CF,CQ,PREV,NEXT,SIGAL,XSW,WORK) + 41 Z1=Z1P + I=IST +* --- +* negative polar sine track +* --- + K=1 + T=T2D(K-1) + TIN=1 + W3D=W3DS + N3D=1 + N3DP=2 + NOM3D(N3D)=INDREG(NOM2D(1),IST) + H3D(N3D)=0.5 + 22 CONTINUE + CALL MCGPT2(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I,K,Z1,T, + 1 TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=N3DP,N3D-1 + H3D(II)=H3D(II)*VNORF(NOM3D(II),IANGL,IMU,2) + ENDDO + IF (SSYM.EQ.2) THEN +* the bottom boundary is a surface symmetry + IF (TIN.EQ.0) THEN +* this track has encountered the bottom boundary -> it is reflected + N3DP=N3D + N3D=N3D-1 + I=I+1 + CALL MCGPT1(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I,K,Z1, + 1 T,TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=N3DP,N3D-1 + H3D(II)=H3D(II)*VNORF(NOM3D(II),IANGL,IMU,1) + ENDDO + IF (TIN.EQ.0) THEN +* the top boundary is a surface symmetry +* this track has encountered the top boundary -> it is reflected + N3DP=N3D + N3D=N3D-1 + I=I-1 + GOTO 22 + ENDIF + ENDIF + ENDIF + IF (LTMT) THEN + NTR=NTR+1 + NSE=NSE+N3D + CALL MCGTMT(NMERG2,N3TRTMT,N3SETMT,N3D,N3D02,NOM3D, + 1 NOM3D0(1,2),W3D,W3D02,H3D,H3D0(1,2),LFORC,NTPROC) + IF (NTPROC.EQ.0) GOTO 42 + ENDIF + NOM3D(1)=NREG-NOM3D(1) + NOM3D(N3D)=NREG-NOM3D(N3D) + DO II=1,N3D + NOM3D(II)=IPERM(NOM3D(II)) + ENDDO + CALL MCGDS1(SUBDS2,SUBDSP,SUBDSC,N3D,NMU,NGEFF,W3D, + 1 H3D,ZMU,WZMU,NOM3D,NZONA,NLONG,NFI,3,LC,M,KM,IM, + 2 MCU,DIAGF,DIAGQ,CF,CQ,PREV,NEXT,SIGAL,XSW,WORK) +* --- + 42 Z1=Z1P + 20 CONTINUE + IF (LTMT) THEN +* process last positive polar sine track + CALL MCGTMT(NMERG1,N3TRTMT,N3SETMT,N3D,N3D01,NOM3D, + 1 NOM3D0(1,1),W3D,W3D01,H3D,H3D0(1,1),LFORC,NTPROC) + NOM3D(1)=NREG-NOM3D(1) + NOM3D(N3D)=NREG-NOM3D(N3D) + DO II=1,N3D + NOM3D(II)=IPERM(NOM3D(II)) + ENDDO + CALL MCGDS1(SUBDS2,SUBDSP,SUBDSC,N3D,NMU,NGEFF,W3D, + 1 H3D,ZMU,WZMU,NOM3D,NZONA,NLONG,NFI,3,LC,M,KM,IM, + 2 MCU,DIAGF,DIAGQ,CF,CQ,PREV,NEXT,SIGAL,XSW,WORK) +* process last negative polar sine track + CALL MCGTMT(NMERG2,N3TRTMT,N3SETMT,N3D,N3D02,NOM3D, + 1 NOM3D0(1,2),W3D,W3D02,H3D,H3D0(1,2),LFORC,NTPROC) + NOM3D(1)=NREG-NOM3D(1) + NOM3D(N3D)=NREG-NOM3D(N3D) + DO II=1,N3D + NOM3D(II)=IPERM(NOM3D(II)) + ENDDO + CALL MCGDS1(SUBDS2,SUBDSP,SUBDSC,N3D,NMU,NGEFF,W3D, + 1 H3D,ZMU,WZMU,NOM3D,NZONA,NLONG,NFI,3,LC,M,KM,IM, + 2 MCU,DIAGF,DIAGQ,CF,CQ,PREV,NEXT,SIGAL,XSW,WORK) + ENDIF +* ------------polar angle loop + ENDDO +* + N3TR=N3TR+N2TPROC*NTR + N3SE=N3SE+N2TPROC*NSE + RETURN +* + END diff --git a/Dragon/src/MCGPTF.f b/Dragon/src/MCGPTF.f new file mode 100644 index 0000000..5e88feb --- /dev/null +++ b/Dragon/src/MCGPTF.f @@ -0,0 +1,663 @@ +*DECK MCGPTF + SUBROUTINE MCGPTF(SUBFFI,SUBFFA,SUBSCH,IFTRAK,N2BTR,N2MAX, + 1 KPN,K,NREG,M,NGEFF,NANGL,NMU,NANI,NFUNL,NMOD, + 2 KEYFLX,KEYCUR,NZON,NCONV,CAZ1,CAZ2,XMU,WZMU,PHI, + 3 S,SIGAL,ISGNR,NMAX,NZP,N2REG,N2SOU,DELU,INDREG, + 4 Z,VNORF,CMU,CMUI,SMU,SMUI,TMU,TMUI,SSYM,IDIR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Flux integration upon the tracking (3D prismatic extended tracking). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* SUBFFI isotropic flux integration subroutine. +* SUBFFA anisotropic flux integration subroutine. +* SUBSCH track coefficients calculation subroutine. +* IFTRAK tracking file unit number. +* N2BTR total number of 2D tracking lines. +* N2MAX maximum number of elements in a 2D track. +* KPN total number of unknowns in vectors PHI. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* NREG number of volumes. +* M number of material mixtures. +* NGEFF number of groups to process. +* NANGL number of tracking angles in the tracking file. +* NMU order of the polar quadrature in 2D / 1 in 3D. +* NANI scattering anisotropy (=1 for isotropic scattering). +* NFUNL number of moments of the flux (in 2D: NFUNL=NANI*(NANI+1)/2). +* NMOD first dimension of ISGNR. +* KEYFLX position of flux elements in PHI vector. +* KEYCUR position of current elements in PHI vector. +* NZON index-number of the mixture type assigned to each volume. +* NCONV logical array of convergence status for each group (.TRUE. +* not converged). +* CAZ1 first cosines of the different tracking azimuthal angles. +* CAZ2 second cosines of the different tracking azimuthal angles. +* XMU cosines of the different tracking polar angles. +* (polar quadrature in 2D / tracking angles in 3D). +* WZMU polar quadrature set in 2D. +* S total source vector components. +* SIGAL total cross-section and albedo array. +* ISGNR spherical harmonic signs. +* NMAX maximum number of segments for the 3D tracks. +* NZP number of z-plans. +* N2SOU number of external surfaces in the 2D tracking. +* N2REG number of regions in the 2D tracking. +* DELU input track spacing for 3D track reconstruction. +* INDREG region/surface index to go from the 2D to the 3D geometry. +* Z z-plan coordinates. +* VNORF normalization factors per angle. +* CMU polar angle cosines. +* CMUI inverse of polar angle cosines. +* SMU polar angle sines. +* SMUI inverse of polar angle sines. +* TMU polar angle tangents. +* TMUI inverse of polar angle tangents. +* SSYM symmetry flag. +* IDIR direction of fundamental current for TIBERE with MoC +* (=0,1,2,3). +* +*Parameters: input/output +* PHI vector containing the zonal scalar flux. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NGEFF,K,KPN,M,N2MAX,NMU,NZON(K),NANI,NFUNL,NMOD, + 1 NREG,KEYFLX(NREG,NFUNL),KEYCUR(K-NREG),IFTRAK,N2BTR,NANGL, + 2 ISGNR(NMOD,NFUNL),NMAX,NZP,N2REG,N2SOU, + 3 INDREG(-N2SOU:N2REG,0:NZP+1),SSYM,IDIR + REAL WZMU(NMU),SIGAL(-6:M,NGEFF),XMU(NMU),DELU,Z(0:NZP) + DOUBLE PRECISION CAZ1(NANGL),CAZ2(NANGL),PHI(KPN,NGEFF), + 1 S(KPN,NGEFF),VNORF(NREG,NANGL,NMU,2),CMU(NMU),CMUI(NMU), + 2 SMU(NMU),SMUI(NMU),TMU(NMU),TMUI(NMU) + LOGICAL NCONV(NGEFF) + EXTERNAL SUBFFI,SUBFFA,SUBSCH +*---- +* LOCAL VARIABLES +*---- + INTEGER MODUR,MODDL,MODDR,MODUL + PARAMETER(MODUR=1,MODDL=8,MODDR=5,MODUL=4) + INTEGER II,I2LIN,IANG,N2SEG,NR2D,NBTR,KST,IST,ILINE,N3D,I,I1,I2, + 1 IMU,IANG0,NOMP,INDP,NOMM,INDM,NOMI,JF,IND,TIN,N3DP,NSUB + DOUBLE PRECISION W2D,Q0,Q1,CPO,CPOI,SPO,SPOI,TPO,TPOI,LTOT,DELTE, + 1 DELZE,T,Z1,Z2,TP,Z1P,W3DPO,WPO,W3D,OMEGAX,OMEGAY,OMEGAZ +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NOM2D,NOM3D + REAL, ALLOCATABLE, DIMENSION(:,:) :: RHARM + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: TRHAR + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: H2D,H3D,T2D,B + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:) :: STOT +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NOM2D(N2MAX),H2D(N2MAX),NOM3D(NMAX),H3D(NMAX),B(4*NMAX), + 1 T2D(0:N2MAX-1)) +* + IF(NANI.EQ.1) THEN +*--- +* ISOTROPIC SCATTERING +*--- + DO I2LIN=1,N2BTR + READ(IFTRAK) NSUB,N2SEG,W2D,IANG,(NOM2D(I),I=1,N2SEG), + 1 (H2D(I),I=1,N2SEG) + IF(NSUB.NE.1) CALL XABORT('MCGPTF: NSUB.NE.1.') + NR2D=N2SEG-2 + T2D(0)=0.0 + DO II=1,NR2D + T2D(II)=T2D(II-1)+H2D(II+1) + ENDDO + DO IMU=1,NMU + CPO=CMU(IMU) + CPOI=CMUI(IMU) + SPO=SMU(IMU) + SPOI=SMUI(IMU) + TPO=TMU(IMU) + TPOI=TMUI(IMU) + WPO=WZMU(IMU) + IF(SSYM.EQ.2) GOTO 15 +*--- +* CONSTRUCT THE 3D TRACKS WHICH ENTER THE GEOMETRY THROUGH A BOTTOM/TOP +* SURFACE +*--- +* length of the spatial integration interval + LTOT=T2D(NR2D)*CPO +* number of 3D tracks generated for this x-y track and this polar +* direction + NBTR=INT(LTOT/DELU)+1 +* effective track spacing in T + DELTE=T2D(NR2D)/DBLE(NBTR) + W3DPO=W2D*DELTE*CPO + W3D=WPO*W3DPO + T=-0.5D0*DELTE + KST=1 + DO 10 ILINE=1,NBTR + T=T+DELTE + TP=T + DO WHILE (T2D(KST).LT.T) + KST=KST+1 + ENDDO + K=KST +* --- +* positive polar sine track +* --- + I1=1 + Z1=Z(I1-1) + TIN=0 + N3D=1 + NOM3D(N3D)=INDREG(NOM2D(K+1),0) + H3D(N3D)=0.5D0 + CALL MCGPT1(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I1,K,Z1, + 1 T,TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=2,N3D-1 + H3D(II)=H3D(II)*VNORF(NOM3D(II),IANG,IMU,1) + ENDDO + IF(SSYM.EQ.1) THEN +* the top boundary condition is a surface symmetry + IF(TIN.EQ.0) THEN +* this track has encountered the top boundary -> it is reflected + N3DP=N3D + N3D=N3D-1 + I1=I1-1 + CALL MCGPT2(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I1,K, + 1 Z1,T,TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=N3DP,N3D-1 + H3D(II)=H3D(II)*VNORF(NOM3D(II),IANG,IMU,2) + ENDDO + ENDIF + ENDIF + DO II=1,NGEFF + IF(NCONV(II)) THEN +* MCGFFIR: 'Source Term Isolation' Strategy turned on +* MCGFFIS: 'Source Term Isolation' Strategy turned off +* MCGFFIT: 'MOCC/MCI' Iterative Strategy + OMEGAX=0.0D0 + OMEGAY=0.0D0 + OMEGAZ=0.0D0 + IDIR=0 + CALL SUBFFI(SUBSCH,K,KPN,M,N3D,H3D,NOM3D,NZON, + 1 SIGAL(0,II),S(1,II),NREG,KEYFLX,KEYCUR,PHI(1,II), + 2 B,W3D,OMEGAX,OMEGAY,OMEGAZ,IDIR) + ENDIF + ENDDO + T=TP + IF(SSYM.EQ.1) GOTO 10 + K=KST +* --- +* negative polar sine track +* --- + I2=NZP + Z2=Z(I2) + TIN=0 + N3D=1 + NOM3D(N3D)=INDREG(NOM2D(K+1),NZP+1) + H3D(N3D)=0.5D0 + CALL MCGPT2(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I2,K,Z2, + 1 T,TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=2,N3D-1 + H3D(II)=H3D(II)*VNORF(NOM3D(II),IANG,IMU,2) + ENDDO + DO II=1,NGEFF + IF(NCONV(II)) THEN +* MCGFFIR: 'Source Term Isolation' Strategy turned on +* MCGFFIS: 'Source Term Isolation' Strategy turned off +* MCGFFIT: 'MOCC/MCI' Iterative Strategy + OMEGAX=0.0D0 + OMEGAY=0.0D0 + OMEGAZ=0.0D0 + IDIR=0 + CALL SUBFFI(SUBSCH,K,KPN,M,N3D,H3D,NOM3D,NZON, + 1 SIGAL(0,II),S(1,II),NREG,KEYFLX,KEYCUR,PHI(1,II), + 2 B,W3D,OMEGAX,OMEGAY,OMEGAZ,IDIR) + ENDIF + ENDDO +* --- + T=TP + 10 CONTINUE +*--- +* CONSTRUCT THE 3D TRACKS WHICH ENTER THE GEOMETRY THROUGH A LATERAL +* SURFACE +*--- +* length of the spatial integration interval + 15 LTOT=Z(NZP)*SPO +! LTOT=(Z(NZP)-Z(0))*SPO with Z(0)=0.0 +* number of 3D tracks generated for this x-y track and this polar +* direction + NBTR=INT(LTOT/DELU)+1 +* effective track spacing in Z + DELZE=Z(NZP)/DBLE(NBTR) +! DELZE=(Z(NZP)-Z(0))/DBLE(NBTR) with Z(0)=0.0 + W3DPO=W2D*DELZE*SPO + W3D=WPO*W3DPO + Z1=-0.5D0*DELZE +! Z1=Z(0)-0.5D0*DELZE with Z(0)=0.0 + IST=1 + DO 20 ILINE=1,NBTR + Z1=Z1+DELZE + Z1P=Z1 + DO WHILE (Z(IST).LT.Z1) + IST=IST+1 + ENDDO + I=IST +* --- +* positive polar sine track +* --- + K=1 + T=T2D(K-1) + TIN=1 + N3D=1 + N3DP=2 + NOM3D(N3D)=INDREG(NOM2D(1),IST) + H3D(N3D)=0.5D0 + 21 CONTINUE + CALL MCGPT1(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I,K,Z1, + 1 T,TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=N3DP,N3D-1 + H3D(II)=H3D(II)*VNORF(NOM3D(II),IANG,IMU,1) + ENDDO + IF(SSYM.GT.0) THEN +* the top boundary condition is a surface symmetry + IF(TIN.EQ.0) THEN +* this track has encountered the top boundary -> it is reflected + N3DP=N3D + N3D=N3D-1 + I=I-1 + CALL MCGPT2(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I,K, + 1 Z1,T,TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=N3DP,N3D-1 + H3D(II)=H3D(II)*VNORF(NOM3D(II),IANG,IMU,2) + ENDDO + IF((SSYM.EQ.2).AND.(TIN.EQ.0)) THEN +* the bottom boundary is a surface symmetry +* this track has encountered the bottom boundary -> it is +* reflected + N3DP=N3D + N3D=N3D-1 + I=I+1 + GOTO 21 + ENDIF + ENDIF + ENDIF + DO II=1,NGEFF + IF(NCONV(II)) THEN +* MCGFFIR: 'Source Term Isolation' Strategy turned on +* MCGFFIS: 'Source Term Isolation' Strategy turned off +* MCGFFIT: 'MOCC/MCI' Iterative Strategy + OMEGAX=0.0D0 + OMEGAY=0.0D0 + OMEGAZ=0.0D0 + IDIR=0 + CALL SUBFFI(SUBSCH,K,KPN,M,N3D,H3D,NOM3D,NZON, + 1 SIGAL(0,II),S(1,II),NREG,KEYFLX,KEYCUR,PHI(1,II), + 2 B,W3D,OMEGAX,OMEGAY,OMEGAZ,IDIR) + ENDIF + ENDDO + Z1=Z1P + I=IST +* --- +* negative polar sine track +* --- + K=1 + T=T2D(K-1) + TIN=1 + N3D=1 + N3DP=2 + NOM3D(N3D)=INDREG(NOM2D(1),IST) + H3D(N3D)=0.5D0 + 22 CONTINUE + CALL MCGPT2(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I,K,Z1, + 1 T,TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=N3DP,N3D-1 + H3D(II)=H3D(II)*VNORF(NOM3D(II),IANG,IMU,2) + ENDDO + IF(SSYM.EQ.2) THEN +* the bottom boundary is a surface symmetry + IF(TIN.EQ.0) THEN +* this track has encountered the bottom boundary -> it is +* reflected + N3DP=N3D + N3D=N3D-1 + I=I+1 + CALL MCGPT1(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I,K, + 1 Z1,T,TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=N3DP,N3D-1 + H3D(II)=H3D(II)*VNORF(NOM3D(II),IANG,IMU,1) + ENDDO + IF(TIN.EQ.0) THEN +* the top boundary is a surface symmetry +* this track has encountered the top boundary -> it is +* reflected + N3DP=N3D + N3D=N3D-1 + I=I-1 + GOTO 22 + ENDIF + ENDIF + ENDIF + DO II=1,NGEFF + IF(NCONV(II)) THEN +* MCGFFIR: 'Source Term Isolation' Strategy turned on +* MCGFFIS: 'Source Term Isolation' Strategy turned off +* MCGFFIT: 'MOCC/MCI' Iterative Strategy + OMEGAX=0.0D0 + OMEGAY=0.0D0 + OMEGAZ=0.0D0 + IDIR=0 + CALL SUBFFI(SUBSCH,K,KPN,M,N3D,H3D,NOM3D,NZON, + 1 SIGAL(0,II),S(1,II),NREG,KEYFLX,KEYCUR,PHI(1,II), + 2 B,W3D,OMEGAX,OMEGAY,OMEGAZ,IDIR) + ENDIF + ENDDO +* --- + Z1=Z1P + 20 CONTINUE + ENDDO + ENDDO + ELSE +*--- +* ANISOTROPIC SCATTERING +*--- + ALLOCATE(STOT(NMAX,NMU,NGEFF,2)) + STOT(:NMAX,:NMU,:NGEFF,:2)=0.0D0 + ALLOCATE(RHARM(NMU,NFUNL),TRHAR(NMU,NFUNL,4)) + IANG0=0 + DO I2LIN=1,N2BTR + READ(IFTRAK) NSUB,N2SEG,W2D,IANG,(NOM2D(I),I=1,N2SEG), + 1 (H2D(I),I=1,N2SEG) + IF(NSUB.NE.1) CALL XABORT('MCGPTF: NSUB.NE.1.') + NR2D=N2SEG-2 + T2D(0)=0.0 + DO II=1,NR2D + T2D(II)=T2D(II-1)+H2D(II+1) + ENDDO + IF(IANG.NE.IANG0) THEN + IANG0=IANG + CALL MOCCHR(3,NANI-1,NFUNL,NMU,XMU,CAZ1(IANG),CAZ2(IANG), + 1 RHARM) + DO 26 JF=1,NFUNL + DO 25 IMU=1,NMU + ! positive polar sine track + TRHAR(IMU,JF,1)=ISGNR(MODUR,JF)*RHARM(IMU,JF) + TRHAR(IMU,JF,2)=ISGNR(MODDL,JF)*RHARM(IMU,JF) + ! negative polar sine track + TRHAR(IMU,JF,3)=ISGNR(MODDR,JF)*RHARM(IMU,JF) + TRHAR(IMU,JF,4)=ISGNR(MODUL,JF)*RHARM(IMU,JF) + 25 CONTINUE + 26 CONTINUE + ENDIF + DO IMU=1,NMU + CPO=CMU(IMU) + CPOI=CMUI(IMU) + SPO=SMU(IMU) + SPOI=SMUI(IMU) + TPO=TMU(IMU) + TPOI=TMUI(IMU) + WPO=WZMU(IMU) +*--- +* CONSTRUCT THE 3D TRACKS WHICH ENTER THE GEOMETRY THROUGH A BOTTOM/TOP +* SURFACE +*--- +* length of the spatial integration interval + LTOT=T2D(NR2D)*CPO +* number of 3D tracks generated for this x-y track and this polar +* direction + NBTR=INT(LTOT/DELU)+1 +* effective track spacing in T + DELTE=T2D(NR2D)/DBLE(NBTR) + W3DPO=W2D*DELTE*CPO + W3D=WPO*W3DPO + T=-0.5D0*DELTE + KST=1 + DO 30 ILINE=1,NBTR + T=T+DELTE + TP=T + DO WHILE (T2D(KST).LT.T) + KST=KST+1 + ENDDO + K=KST +* --- +* positive polar sine track +* --- + I1=1 + Z1=Z(I1-1) + TIN=0 + N3D=1 + NOM3D(N3D)=INDREG(NOM2D(K+1),0) + H3D(N3D)=0.5D0 + CALL MCGPT1(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I1,K,Z1, + 1 T,TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=2,N3D-1 + H3D(II)=H3D(II)*VNORF(NOM3D(II),IANG,IMU,1) + ENDDO + DO II=1,NGEFF + IF(NCONV(II)) THEN +* incoming flux in + direction + NOMP=NOM3D(1) + INDP=KEYCUR(-NOMP) +* incoming flux in - direction + NOMM=NOM3D(N3D) + INDM=KEYCUR(-NOMM) + STOT(1,IMU,II,1)=W3D*S(INDP,II) + STOT(N3D,IMU,II,2)=W3D*S(INDM,II) +* regional sources + DO I=2,N3D-1 + NOMI=NOM3D(I) + Q0=0.0D0 + Q1=0.0D0 + DO JF=1,NFUNL + IND=KEYFLX(NOMI,JF) + Q0=Q0+S(IND,II)*TRHAR(IMU,JF,1) + Q1=Q1+S(IND,II)*TRHAR(IMU,JF,2) + ENDDO + STOT(I,IMU,II,1)=W3D*Q0 + STOT(I,IMU,II,2)=W3D*Q1 + ENDDO +* MCGFFAR: 'Source Term Isolation' Strategy turned on +* MCGFFAS: 'Source Term Isolation' Strategy turned off +* MCGFFAT: 'MOCC/MCI' Iterative Strategy + CALL SUBFFA(SUBSCH,K,KPN,M,N3D,H3D,NOM3D,NZON, + 1 SIGAL(0,II),STOT(1,IMU,II,1),STOT(1,IMU,II,2), + 2 NREG,NMU,NANI,NFUNL,TRHAR(1,1,1),KEYFLX,KEYCUR, + 3 IMU,PHI(1,II),B) + ENDIF + ENDDO + T=TP + K=KST +* --- +* negative polar sine track +* --- + I2=NZP + Z2=Z(I2) + TIN=0 + N3D=1 + NOM3D(N3D)=INDREG(NOM2D(K+1),NZP+1) + H3D(N3D)=0.5D0 + CALL MCGPT2(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I2,K,Z2, + 1 T,TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=2,N3D-1 + H3D(II)=H3D(II)*VNORF(NOM3D(II),IANG,IMU,2) + ENDDO + DO II=1,NGEFF + IF(NCONV(II)) THEN +* incoming flux in + direction + NOMP=NOM3D(1) + INDP=KEYCUR(-NOMP) +* incoming flux in - direction + NOMM=NOM3D(N3D) + INDM=KEYCUR(-NOMM) + STOT(1,IMU,II,1)=W3D*S(INDP,II) + STOT(N3D,IMU,II,2)=W3D*S(INDM,II) +* regional sources + DO I=2,N3D-1 + NOMI=NOM3D(I) + Q0=0.0D0 + Q1=0.0D0 + DO JF=1,NFUNL + IND=KEYFLX(NOMI,JF) + Q0=Q0+S(IND,II)*TRHAR(IMU,JF,3) + Q1=Q1+S(IND,II)*TRHAR(IMU,JF,4) + ENDDO + STOT(I,IMU,II,1)=W3D*Q0 + STOT(I,IMU,II,2)=W3D*Q1 + ENDDO +* MCGFFAR: 'Source Term Isolation' Strategy turned on +* MCGFFAS: 'Source Term Isolation' Strategy turned off +* MCGFFAT: 'MOCC/MCI' Iterative Strategy + CALL SUBFFA(SUBSCH,K,KPN,M,N3D,H3D,NOM3D,NZON, + 1 SIGAL(0,II),STOT(1,IMU,II,1),STOT(1,IMU,II,2), + 2 NREG,NMU,NANI,NFUNL,TRHAR(1,1,3),KEYFLX,KEYCUR, + 3 IMU,PHI(1,II),B) + ENDIF + ENDDO +* --- + T=TP + 30 CONTINUE +*--- +* CONSTRUCT THE 3D TRACKS WHICH ENTER THE GEOMETRY THROUGH A LATERAL +* SURFACE +*--- +* length of the spatial integration interval + LTOT=Z(NZP)*SPO +! LTOT=(Z(NZP)-Z(0))*SPO with Z(0)=0.0 +* number of 3D tracks generated for this x-y track and this polar +* direction + NBTR=INT(LTOT/DELU)+1 +* effective track spacing in Z + DELZE=Z(NZP)/DBLE(NBTR) +! DELZE=(Z(NZP)-Z(0))/DBLE(NBTR) with Z(0)=0.0 + W3DPO=W2D*DELZE*SPO + W3D=WPO*W3DPO + Z1=-0.5D0*DELZE +! Z1=Z(0)-0.5D0*DELZE with Z(0)=0.0 + IST=1 + DO 40 ILINE=1,NBTR + Z1=Z1+DELZE + Z1P=Z1 + DO WHILE (Z(IST).LT.Z1) + IST=IST+1 + ENDDO + I=IST +* --- +* positive polar sine track +* --- + K=1 + T=T2D(K-1) + TIN=1 + N3D=1 + NOM3D(N3D)=INDREG(NOM2D(1),IST) + H3D(N3D)=0.5D0 + CALL MCGPT1(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I,K,Z1, + 1 T,TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=2,N3D-1 + H3D(II)=H3D(II)*VNORF(NOM3D(II),IANG,IMU,1) + ENDDO + DO II=1,NGEFF + IF(NCONV(II)) THEN +* incoming flux in + direction + NOMP=NOM3D(1) + INDP=KEYCUR(-NOMP) +* incoming flux in - direction + NOMM=NOM3D(N3D) + INDM=KEYCUR(-NOMM) + STOT(1,IMU,II,1)=W3D*S(INDP,II) + STOT(N3D,IMU,II,2)=W3D*S(INDM,II) +* regional sources + DO I=2,N3D-1 + NOMI=NOM3D(I) + Q0=0.0D0 + Q1=0.0D0 + DO JF=1,NFUNL + IND=KEYFLX(NOMI,JF) + Q0=Q0+S(IND,II)*TRHAR(IMU,JF,1) + Q1=Q1+S(IND,II)*TRHAR(IMU,JF,2) + ENDDO + STOT(I,IMU,II,1)=W3D*Q0 + STOT(I,IMU,II,2)=W3D*Q1 + ENDDO +* MCGFFAR: 'Source Term Isolation' Strategy turned on +* MCGFFAS: 'Source Term Isolation' Strategy turned off +* MCGFFAT: 'MOCC/MCI' Iterative Strategy + CALL SUBFFA(SUBSCH,K,KPN,M,N3D,H3D,NOM3D,NZON, + 1 SIGAL(0,II),STOT(1,IMU,II,1),STOT(1,IMU,II,2), + 2 NREG,NMU,NANI,NFUNL,TRHAR(1,1,1),KEYFLX,KEYCUR, + 3 IMU,PHI(1,II),B) + ENDIF + ENDDO + Z1=Z1P + I=IST +* --- +* negative polar sine track +* --- + K=1 + T=T2D(K-1) + TIN=1 + N3D=1 + NOM3D(N3D)=INDREG(NOM2D(1),IST) + H3D(N3D)=0.5D0 + CALL MCGPT2(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I,K,Z1, + 1 T,TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=2,N3D-1 + H3D(II)=H3D(II)*VNORF(NOM3D(II),IANG,IMU,2) + ENDDO + DO II=1,NGEFF + IF(NCONV(II)) THEN +* incoming flux in + direction + NOMP=NOM3D(1) + INDP=KEYCUR(-NOMP) +* incoming flux in - direction + NOMM=NOM3D(N3D) + INDM=KEYCUR(-NOMM) + STOT(1,IMU,II,1)=W3D*S(INDP,II) + STOT(N3D,IMU,II,2)=W3D*S(INDM,II) +* regional sources + DO I=2,N3D-1 + NOMI=NOM3D(I) + Q0=0.0D0 + Q1=0.0D0 + DO JF=1,NFUNL + IND=KEYFLX(NOMI,JF) + Q0=Q0+S(IND,II)*TRHAR(IMU,JF,3) + Q1=Q1+S(IND,II)*TRHAR(IMU,JF,4) + ENDDO + STOT(I,IMU,II,1)=W3D*Q0 + STOT(I,IMU,II,2)=W3D*Q1 + ENDDO +* MCGFFAR: 'Source Term Isolation' Strategy turned on +* MCGFFAS: 'Source Term Isolation' Strategy turned off +* MCGFFAT: 'MOCC/MCI' Iterative Strategy + CALL SUBFFA(SUBSCH,K,KPN,M,N3D,H3D,NOM3D,NZON, + 1 SIGAL(0,II),STOT(1,IMU,II,1),STOT(1,IMU,II,2), + 2 NREG,NMU,NANI,NFUNL,TRHAR(1,1,3),KEYFLX,KEYCUR, + 3 IMU,PHI(1,II),B) + ENDIF + ENDDO +* --- + Z1=Z1P + 40 CONTINUE + ENDDO + ENDDO + DEALLOCATE(TRHAR,RHARM,STOT) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(B,H3D,NOM3D,H2D,NOM2D,T2D) +* + RETURN + END diff --git a/Dragon/src/MCGPTN.f b/Dragon/src/MCGPTN.f new file mode 100644 index 0000000..2a0fb68 --- /dev/null +++ b/Dragon/src/MCGPTN.f @@ -0,0 +1,177 @@ +*DECK MCGPTN + SUBROUTINE MCGPTN(IMPX,NREG,NSOU,NANGL,NMU,VOLSUR,VOLNUM,SURNUM, + 1 DENSTY,WZMU) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute errors and normalization factors for 3D prismatic extended +* tracking (adapted from NXTTLS.f). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IMPX print flag. +* NREG number of regions. +* NSOU number of external surfaces. +* NANGL number of plan tracking angles. +* NMU number of polar angles. +* SURNUM numerical surfaces. +* DENSTY plan tracking track density per angle. +* WZMU polar quadrature weights. +* +*Parameters: input/output +* VOLSUR analytical volume and surfaces +* / analytical volumes and numerical surfaces. +* VOLNUM numerical volumes per angle / normalization factors per angle. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IMPX,NREG,NSOU,NANGL,NMU + REAL VOLSUR(NREG+NSOU),WZMU(NMU) + DOUBLE PRECISION DENSTY(NANGL),VOLNUM(NREG,NANGL,NMU,2), + > SURNUM(NSOU) +*---- +* LOCAL VARIABLES +*---- + INTEGER IOUT + CHARACTER NAMSBR*6,CSGMU(2)*1 + PARAMETER (IOUT=6,NAMSBR='MCGPTN') + INTEGER IR,IS,IANGL,IMU,ISGMU,NBVERG,NBVERA,NBSERR,NBV0,ITDIR + REAL RTEMP + DOUBLE PRECISION DCERR,DSVERG,DMVERG,DAVERG,DSVERA,DMVERA,DAVERA, + 1 DSSERR,DMSERR,DASERR + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: VGLNUM + DATA CSGMU / '+','-' / +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(VGLNUM(NREG)) + VGLNUM(:NREG)=0.0D0 +* + ITDIR=0 + DO 10 IANGL=1,NANGL + IF(DENSTY(IANGL).EQ.0.0D0) GOTO 10 + ITDIR=ITDIR+1 + DO 20 IMU=1,NMU + DO 30 ISGMU=1,2 + NBVERA=0 + DSVERA=0.D0 + DMVERA=0.D0 + DAVERA=0.D0 + NBV0=0 + DO IR=1,NREG + IF(VOLNUM(IR,ITDIR,IMU,ISGMU).EQ.0.D0) THEN + IF(IMPX.GE.10) WRITE(IOUT,300) NAMSBR,IR,ITDIR,IMU,ISGMU + VOLNUM(IR,ITDIR,IMU,ISGMU)=1.D0 + NBV0=NBV0+1 + ELSE + VGLNUM(IR)=VGLNUM(IR) + 1 +2.0*WZMU(IMU)*VOLNUM(IR,ITDIR,IMU,ISGMU) + VOLNUM(IR,ITDIR,IMU,ISGMU)=VOLNUM(IR,ITDIR,IMU,ISGMU) + 1 *DENSTY(IANGL) + VOLNUM(IR,ITDIR,IMU,ISGMU)=DBLE(VOLSUR(IR)) + 1 /VOLNUM(IR,ITDIR,IMU,ISGMU) + NBVERA=NBVERA+1 + ENDIF + DCERR=100.0D0*(1.D0-VOLNUM(IR,ITDIR,IMU,ISGMU)) + DMVERA=MAX(DMVERA,ABS(DCERR)) + DSVERA=DSVERA+DCERR*DCERR + DAVERA=DAVERA+DCERR + ENDDO + DSVERA=SQRT(DSVERA/DBLE(NBVERA)) + DAVERA=DAVERA/DBLE(NBVERA) + IF(NBV0.GT.0) THEN + WRITE(IOUT,500) NAMSBR,NBV0,ITDIR,IMU,CSGMU(ISGMU) + ELSE + IF(IMPX.GE.2) WRITE(IOUT,100) DSVERA,DMVERA,DAVERA,ITDIR, + 1 IMU,CSGMU(ISGMU) + ENDIF + 30 CONTINUE + 20 CONTINUE + 10 CONTINUE +* + NBVERG=0 + DSVERG=0.D0 + DMVERG=0.D0 + DAVERG=0.D0 + NBV0=0 + DO IR=1,NREG + IF(VGLNUM(IR).EQ.0.D0) THEN + WRITE(IOUT,300) NAMSBR,IR + VGLNUM(IR)=1.D0 + NBV0=NBV0+1 + ELSE + VGLNUM(IR)=DBLE(VOLSUR(IR))/VGLNUM(IR) + NBVERG=NBVERG+1 + ENDIF + DCERR=100.0D0*(1.D0-VGLNUM(IR)) + DMVERG=MAX(DMVERG,ABS(DCERR)) + DSVERG=DSVERG+DCERR*DCERR + DAVERG=DAVERG+DCERR + ENDDO + IF(NBV0.GT.0) THEN + WRITE(IOUT,500) NAMSBR,NBV0 + ENDIF + DSVERG=SQRT(DSVERG/DBLE(NBVERG)) + DAVERG=DAVERG/DBLE(NBVERG) + IF(IMPX.GE.1) WRITE(IOUT,150) DSVERG,DMVERG,DAVERG +* + NBSERR=0 + DSSERR=0.D0 + DMSERR=0.D0 + DASERR=0.D0 + DO IR=1,NSOU + IS=NREG+IR + IF(SURNUM(IR).EQ.0.D0) THEN + WRITE(IOUT,400) NAMSBR,-IR + SURNUM(IR)=1.D0 + ELSE + RTEMP=VOLSUR(IS) + VOLSUR(IS)=REAL(SURNUM(IR)) + SURNUM(IR)=RTEMP/VOLSUR(IS) + NBSERR=NBSERR+1 + ENDIF + DCERR=100.0D0*(1.D0-SURNUM(IR)) + DMSERR=MAX(DMSERR,ABS(DCERR)) + DSSERR=DSSERR+DCERR*DCERR + DASERR=DASERR+DCERR + ENDDO + DSSERR=SQRT(DSSERR/DBLE(NBSERR)) + DASERR=DASERR/DBLE(NBSERR) + IF(IMPX.GE.1) WRITE(IOUT,200) DSSERR,DMSERR,DASERR +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(VGLNUM) + RETURN +* + 100 FORMAT(' Angular RMS, maximum and average errors (%) ', + 1 'on region volumes :',3(2X,F10.5), + 2 ' for plan tracking angle',I3,' for polar angle',I3, + 3 '(',A1,')') + 150 FORMAT(' Global RMS, maximum and average errors (%) ', + 1 'on region volumes :',3(2X,F10.5)) + 200 FORMAT(' Global RMS, maximum and average errors (%) ', + 1 'on surface areas :',3(2X,F10.5)) + 300 FORMAT(1X,'***** Warning in ',A6,'*****'/ + 1 7X,'For region ',I8, + 2 1X,'no crossing by angle ',I8,I8,'(',I1,')') + 400 FORMAT(1X,'***** Warning in ',A6,'*****'/ + 1 7X,'For surface ',I8, + 2 1X,'no crossing by any angle ') + 500 FORMAT(1X,'***** Warning in ',A6,'*****'/ + 1 7X,I8,' regions not tracked for direction ',I8,I8, + 2 '(',A1,')') + END diff --git a/Dragon/src/MCGPTS.f b/Dragon/src/MCGPTS.f new file mode 100644 index 0000000..7de7a98 --- /dev/null +++ b/Dragon/src/MCGPTS.f @@ -0,0 +1,332 @@ +*DECK MCGPTS + SUBROUTINE MCGPTS(SUBPJJ,NFI,NREG,M,NANI,NFUNL,NANGL,NMU,NMOD,LPS, + 1 NPJJM,NGEFF,IANGL,NSEG,ISGNR,NZON,NOM2D,IS,JS, + 2 PJJIND,W2D,XMU,CAZ1,CAZ2,ZMU,WZMU,SIGAL,T2D,PSJ, + 3 PJJD,LPJJAN,NR2D,NMAX,NZP,N2REG,N2SOU,DELU, + 4 INDREG,Z,VNORF,CMU,CMUI,SMU,SMUI,TMU,TMUI,SSYM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the PJJ and PSJ (3D prismatic extended tracking). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* SUBPJJ PJJ calculation subroutine. +* NFI total number of volumes and surfaces for which specific values +* of the neutron flux and reactions rates are required. +* NREG number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* M number of material mixtures. +* NANI number of Legendre orders. +* NFUNL number of moments of the flux (in 2D: NFUNL=NANI*(NANI+1)/2). +* NANGL number of tracking angles in the plane. +* NMU order of the polar quadrature in 2D / 1 in 3D. +* NMOD first dimension of ISGNR. +* LPS dimension of JS. +* NPJJM number of pjj modes to store for STIS option. +* NGEFF number of groups to process. +* IANGL direction index of this track. +* NSEG number of elements in the current track. +* ISGNR spherical harmonic signs. +* NZON index-number of the mixture type assigned to each volume. +* NOM2D vector containing the region number of the different segments +* of this 2D track. +* IS arrays for surfaces neighbors. +* JS JS(IS(ISOUT)+1:IS(ISOUT+1)) give the neighboring regions to +* surface ISOUT. +* PJJIND index of the modes for LPJJAN option. +* W2D track weight. +* XMU polar angle cosines. +* CAZ1 first cosines of the different tracking azimuthal angles. +* CAZ2 second cosines of the different tracking azimuthal angles. +* ZMU polar quadrature set. +* WZMU polar quadrature set. +* SIGAL albedos and total cross sections array. +* T2D vector containing the local coordinates of the segments +* boundaries for this 2D track. +* LPJJAN anisotropic scattering flag. +* NR2D number of segments corresponding to regions for this 2D track. +* NMAX maximum number of segments for the 3D tracks. +* NZP number of z-planes. +* N2SOU number of external surfaces in the 2D tracking. +* N2REG number of regions in the 2D tracking. +* DELU input track spacing for 3D track reconstruction. +* INDREG region/surface index to go from the 2D to the 3D geometry. +* Z z-plan coordinates. +* VNORF normalization factors per angle. +* CMU polar angle cosines. +* CMUI inverse of polar angle cosines. +* SMU polar angle sines. +* SMUI inverse of polar angle sines. +* TMU polar angle tangents. +* TMUI inverse of polar angle tangents. +* SSYM symmetry flag. +* +*Parameters: input/output +* PJJD collision probabilities. +* PSJ leakage probabilities. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NFI,NREG,M,NANI,NFUNL,NANGL,NMU,NMOD,LPS,NPJJM,NGEFF, + 1 IANGL,NSEG,ISGNR(NMOD,NFUNL),NZON(NFI),NOM2D(NSEG),JS(LPS), + 2 IS(NFI-NREG+1),PJJIND(NPJJM,2),NR2D,NMAX,NZP,N2REG,N2SOU, + 3 INDREG(-N2SOU:N2REG,0:NZP+1),SSYM + REAL XMU(NMU),ZMU(NMU),WZMU(NMU),SIGAL(-6:M,NGEFF),PSJ(LPS,NGEFF), + 1 DELU,Z(0:NZP) + DOUBLE PRECISION PJJD(NREG,NPJJM,NGEFF),VNORF(NREG,NANGL,NMU,2), + 1 CMU(NMU),CMUI(NMU),SMU(NMU),SMUI(NMU),TMU(NMU),TMUI(NMU), + 2 W2D,T2D(0:NR2D),CAZ1(NANGL),CAZ2(NANGL) + LOGICAL LPJJAN + EXTERNAL SUBPJJ +*---- +* LOCAL VARIABLES +*---- + INTEGER MODUR,MODDR + PARAMETER(MODUR=1,MODDR=5) + INTEGER JF,IE,IMU,NBTR,KST,IST,ILINE,I,I1,I2,K,N3D,II,TIN,N3DP, + 1 NSUB,NANGL0,KANGL(1) + DOUBLE PRECISION CPO,CPOI,SPO,SPOI,TPO,TPOI,LTOT,DELTE,DELZE,T, + 1 Z1,Z2,TP,Z1P,WPO,W3D,W3DPO +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NOM3D + REAL, ALLOCATABLE, DIMENSION(:,:) :: RHARM,TRHARP,TRHARM + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: H3D +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NOM3D(NMAX),RHARM(NMU,NFUNL),TRHARP(NMU,NFUNL), + 1 TRHARM(NMU,NFUNL),H3D(NMAX)) +* + NSUB=1 + NANGL0=1 + KANGL(1)=1 + IF (LPJJAN) THEN + IF(MODDR.GT.NMOD) CALL XABORT('MCGPTS: NMOD OVERFLOW') + CALL MOCCHR(3,NANI-1,NFUNL,NMU,XMU,CAZ1(IANGL),CAZ2(IANGL), + 1 RHARM) + DO JF=1,NFUNL + DO IE=1,NMU + TRHARP(IE,JF)=ISGNR(MODUR,JF)*RHARM(IE,JF) + TRHARM(IE,JF)=ISGNR(MODDR,JF)*RHARM(IE,JF) + ENDDO + ENDDO + ENDIF +* + DO IMU=1,NMU + CPO=CMU(IMU) + CPOI=CMUI(IMU) + SPO=SMU(IMU) + SPOI=SMUI(IMU) + TPO=TMU(IMU) + TPOI=TMUI(IMU) + WPO=WZMU(IMU) + IF (SSYM.EQ.2) GOTO 15 +*--- +* CONSTRUCT THE 3D TRACKS WHICH ENTER THE GEOMETRY THROUGH A BOTTOM/TOP SURFACE +*--- +* length of the spatial integration interval + LTOT=T2D(NR2D)*CPO +* number of 3D tracks generated for this x-y track and this polar direction + NBTR=INT(LTOT/DELU)+1 +* effective track spacing in T + DELTE=T2D(NR2D)/DBLE(NBTR) + W3DPO=W2D*DELTE*CPO + W3D=WPO*W3DPO + T=-0.5D0*DELTE + KST=1 + DO 10 ILINE=1,NBTR + T=T+DELTE + TP=T + DO WHILE (T2D(KST).LT.T) + KST=KST+1 + ENDDO + K=KST +* --- +* positive polar sine track +* --- + I1=1 + Z1=Z(I1-1) + TIN=0 + N3D=1 + NOM3D(N3D)=NREG-INDREG(NOM2D(K+1),0) + H3D(N3D)=0.5D0 + CALL MCGPT1(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I1,K,Z1,T, + 1 TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=2,N3D-1 + H3D(II)=H3D(II)*VNORF(NOM3D(II),IANGL,IMU,1) + ENDDO + IF (SSYM.EQ.1) THEN +* the top boundary condition is a surface symmetry + IF (TIN.EQ.0) THEN +* this track has encountered the top boundary -> it is reflected + N3DP=N3D + N3D=N3D-1 + I1=I1-1 + CALL MCGPT2(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I1,K,Z1, + 1 T,TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=N3DP,N3D-1 + H3D(II)=H3D(II)*VNORF(NOM3D(II),IANGL,IMU,2) + ENDDO + ENDIF + ENDIF + NOM3D(N3D)=NREG-NOM3D(N3D) + CALL MCGDS4(SUBPJJ,N3D,NSUB,NMU,LPS,NFUNL,NANGL0,NGEFF,W3D, + 1 KANGL,TRHARP,H3D,ZMU,WZMU,NOM3D,NZON,NFI,NREG,3,M,IS,JS, + 2 PJJD,PSJ,LPJJAN,NPJJM,PJJIND,SIGAL,IMU,1) + T=TP + IF (SSYM.EQ.1) GOTO 10 + K=KST +* --- +* negative polar sine track +* --- + I2=NZP + Z2=Z(I2) + TIN=0 + N3D=1 + NOM3D(N3D)=NREG-INDREG(NOM2D(K+1),NZP+1) + H3D(N3D)=0.5D0 + CALL MCGPT2(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I2,K,Z2,T, + 1 TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + NOM3D(N3D)=NREG-NOM3D(N3D) + DO II=2,N3D-1 + H3D(II)=H3D(II)*VNORF(NOM3D(II),IANGL,IMU,2) + ENDDO + CALL MCGDS4(SUBPJJ,N3D,NSUB,NMU,LPS,NFUNL,NANGL0,NGEFF,W3D, + 1 KANGL,TRHARM,H3D,ZMU,WZMU,NOM3D,NZON,NFI,NREG,3,M,IS,JS, + 2 PJJD,PSJ,LPJJAN,NPJJM,PJJIND,SIGAL,IMU,1) +* --- + T=TP + 10 CONTINUE +*--- +* CONSTRUCT THE 3D TRACKS WHICH ENTER THE GEOMETRY THROUGH A LATERAL SURFACE +*--- +* length of the spatial integration interval + 15 LTOT=Z(NZP)*SPO +! LTOT=(Z(NZP)-Z(0))*SPO with Z(0)=0.0 +* number of 3D tracks generated for this x-y track and this polar direction + NBTR=INT(LTOT/DELU)+1 +* effective track spacing in Z + DELZE=Z(NZP)/DBLE(NBTR) +! DELZE=(Z(NZP)-Z(0))/DBLE(NBTR) with Z(0)=0.0 + W3DPO=W2D*DELZE*SPO + W3D=WPO*W3DPO + Z1=-0.5D0*DELZE +! Z1=Z(0)-0.5D0*DELZE with Z(0)=0.0 + IST=1 + DO 20 ILINE=1,NBTR + Z1=Z1+DELZE + Z1P=Z1 + DO WHILE (Z(IST).LT.Z1) + IST=IST+1 + ENDDO + I=IST +* --- +* positive polar sine track +* --- + K=1 + T=T2D(K-1) + TIN=1 + N3D=1 + N3DP=2 + NOM3D(N3D)=NREG-INDREG(NOM2D(1),IST) + H3D(N3D)=0.5D0 + 21 CONTINUE + CALL MCGPT1(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I,K,Z1,T, + 1 TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=N3DP,N3D-1 + H3D(II)=H3D(II)*VNORF(NOM3D(II),IANGL,IMU,1) + ENDDO + IF (SSYM.GT.0) THEN +* the top boundary condition is a surface symmetry + IF (TIN.EQ.0) THEN +* this track has encountered the top boundary -> it is reflected + N3DP=N3D + N3D=N3D-1 + I=I-1 + CALL MCGPT2(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I,K,Z1, + 1 T,TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=N3DP,N3D-1 + H3D(II)=H3D(II)*VNORF(NOM3D(II),IANGL,IMU,2) + ENDDO + IF ((SSYM.EQ.2).AND.(TIN.EQ.0)) THEN +* the bottom boundary is a surface symmetry +* this track has encountered the bottom boundary -> it is reflected + N3DP=N3D + N3D=N3D-1 + I=I+1 + GOTO 21 + ENDIF + ENDIF + ENDIF + NOM3D(N3D)=NREG-NOM3D(N3D) + CALL MCGDS4(SUBPJJ,N3D,NSUB,NMU,LPS,NFUNL,NANGL0,NGEFF,W3D, + 1 KANGL,TRHARP,H3D,ZMU,WZMU,NOM3D,NZON,NFI,NREG,3,M,IS,JS, + 2 PJJD,PSJ,LPJJAN,NPJJM,PJJIND,SIGAL,IMU,1) + Z1=Z1P + I=IST +* --- +* negative polar sine track +* --- + K=1 + T=T2D(K-1) + TIN=1 + N3D=1 + N3DP=2 + NOM3D(N3D)=NREG-INDREG(NOM2D(1),IST) + H3D(N3D)=0.5D0 + 22 CONTINUE + CALL MCGPT2(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I,K,Z1,T, + 1 TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=N3DP,N3D-1 + H3D(II)=H3D(II)*VNORF(NOM3D(II),IANGL,IMU,2) + ENDDO + IF (SSYM.EQ.2) THEN +* the bottom boundary is a surface symmetry + IF (TIN.EQ.0) THEN +* this track has encountered the bottom boundary -> it is reflected + N3DP=N3D + N3D=N3D-1 + I=I+1 + CALL MCGPT1(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I,K,Z1, + 1 T,TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=N3DP,N3D-1 + H3D(II)=H3D(II)*VNORF(NOM3D(II),IANGL,IMU,1) + ENDDO + IF (TIN.EQ.0) THEN +* the top boundary is a surface symmetry +* this track has encountered the top boundary -> it is reflected + N3DP=N3D + N3D=N3D-1 + I=I-1 + GOTO 22 + ENDIF + ENDIF + ENDIF + NOM3D(N3D)=NREG-NOM3D(N3D) + CALL MCGDS4(SUBPJJ,N3D,NSUB,NMU,LPS,NFUNL,NANGL0,NGEFF,W3D, + 1 KANGL,TRHARM,H3D,ZMU,WZMU,NOM3D,NZON,NFI,NREG,3,M,IS,JS, + 2 PJJD,PSJ,LPJJAN,NPJJM,PJJIND,SIGAL,IMU,1) +* --- + Z1=Z1P + 20 CONTINUE +* + ENDDO + DEALLOCATE(H3D,TRHARM,TRHARP,RHARM,NOM3D) + RETURN + END diff --git a/Dragon/src/MCGPTV.f b/Dragon/src/MCGPTV.f new file mode 100644 index 0000000..69fb48a --- /dev/null +++ b/Dragon/src/MCGPTV.f @@ -0,0 +1,332 @@ +*DECK MCGPTV + SUBROUTINE MCGPTV(N2SOU,N2REG,NZP,SSYM,N3REG,N3SOU,N2D,NR2D,NANGL, + 1 NMU,LMCU,LMXMCU,IANGL,INDREG,NOM2D,MCUW,MCUI,Z, + 2 T2D,W2D,CMU,CMUI,SMU,SMUI,TMU,TMUI,WZMU,DELU, + 3 NOM3D,H3D,SURF,VNUM,ACFLAG) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the contribution of reconstructed tracks to the numerical +* surfaces/volumes and connection matrices for a 3D prismatic extended +* tracking (from a 2D EXCELT tracking). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* N2SOU number of external surfaces in the 2D tracking. +* N2REG number of regions in the 2D tracking. +* NZP number of z-planes. +* SSYM symmetry flag (0=none, 1=top, 2=top and bottom). +* N3REG number of regions in the 3D geometry. +* N3SOU number of external surfaces in the 3D geometry. +* N2D number of segments for this 2D track. +* NR2D number of segments corresponding to regions for this 2D track. +* NANGL number of plan tracking angles. +* NMU number of polar angles. +* LMXMCU maximum dimension for the connection matrix. +* IANGL index of the tracking angle considered. +* INDREG region/surface index to go from the 2D to the 3D geometry. +* NOM2D vector containing the region number of the different segments +* of this 2D track. +* Z z-plan coordinates. +* T2D vector containing the local coordinates of the segments +* boundaries for this 2D track. +* W2D weight for this 2D track. +* WZMU polar quadrature weight. +* DELU input track spacing for 3D track reconstruction. +* ACFLAG preconditioning flag. +* +*Parameters: input/output +* LMCU number of elements in the connection matrix. +* MCUW temporary connection matrix. +* MCUI temporary connection matrix. +* SURF numerical surfaces. +* VNUM numerical volumes. +* +*Parameters: +* CMU undefined. +* CMUI undefined. +* SMU undefined. +* SMUI undefined. +* TMU undefined. +* TMUI undefined. +* +*Parameters: scratch +* NOM3D undefined. +* H3D undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N2SOU,N2REG,NZP,SSYM,N3REG,N3SOU,N2D,NR2D,NANGL,NMU, + 1 LMCU,LMXMCU,IANGL,INDREG(-N2SOU:N2REG,0:NZP+1),NOM2D(N2D), + 2 MCUW(LMXMCU),MCUI(LMXMCU),NOM3D(*) + REAL Z(0:NZP),WZMU(NMU),DELU + DOUBLE PRECISION W2D,T2D(0:NR2D),H3D(*),SURF(N3SOU),CMU(NMU), + 1 CMUI(NMU),SMU(NMU),SMUI(NMU),TMU(NMU),TMUI(NMU), + 2 VNUM(N3REG,NANGL,NMU,2) + LOGICAL ACFLAG +*--- +* LOCAL VARIABLES +*--- + INTEGER IMU,NBTR,KST,IST,ILINE,I,I1,I2,K,N3D,II,ITEMP,TIN,N3DP + DOUBLE PRECISION CPO,CPOI,SPO,SPOI,TPO,TPOI,LTOT,DELTE,DELZE,T,Z1, + 1 Z2,TP,Z1P,WPO,W3D,W3DPO +* + DO IMU=1,NMU + CPO=CMU(IMU) + CPOI=CMUI(IMU) + SPO=SMU(IMU) + SPOI=SMUI(IMU) + TPO=TMU(IMU) + TPOI=TMUI(IMU) + WPO=WZMU(IMU) + IF (SSYM.EQ.2) GOTO 15 +*--- +* CONSTRUCT THE 3D TRACKS WHICH ENTER THE GEOMETRY THROUGH A BOTTOM/TOP +* SURFACE +*--- +* length of the spatial integration interval + LTOT=T2D(NR2D)*CPO +* number of 3D tracks generated for this x-y track and this polar +* direction + NBTR=INT(LTOT/DELU)+1 +* effective track spacing in T + DELTE=T2D(NR2D)/DBLE(NBTR) + W3DPO=W2D*DELTE*CPO + W3D=WPO*W3DPO + T=-0.5D0*DELTE + KST=1 + DO 10 ILINE=1,NBTR + T=T+DELTE + TP=T + DO WHILE (T2D(KST).LT.T) + KST=KST+1 + ENDDO + K=KST +* --- +* positive polar sine track +* --- + I1=1 + Z1=Z(I1-1) + TIN=0 + N3D=1 + NOM3D(N3D)=INDREG(NOM2D(K+1),0) + H3D(N3D)=0.5D0 + CALL MCGPT1(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I1,K,Z1,T, + 1 TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + SURF(-NOM3D(1))=SURF(-NOM3D(1))+W3D + NOM3D(1)=N3REG-NOM3D(1) + DO II=2,N3D-1 + VNUM(NOM3D(II),IANGL,IMU,1)=VNUM(NOM3D(II),IANGL,IMU,1) + 1 +H3D(II)*W3DPO + ENDDO + IF (SSYM.EQ.1) THEN +* the top boundary condition is a surface symmetry + IF (TIN.EQ.0) THEN +* this track has encountered the top boundary -> it is reflected + N3DP=N3D + N3D=N3D-1 + I1=I1-1 + CALL MCGPT2(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I1,K,Z1, + 1 T,TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=N3DP,N3D-1 + VNUM(NOM3D(II),IANGL,IMU,2)=VNUM(NOM3D(II),IANGL,IMU,2) + 1 +H3D(II)*W3DPO + ENDDO + ENDIF + ENDIF + SURF(-NOM3D(N3D))=SURF(-NOM3D(N3D))+W3D + NOM3D(N3D)=N3REG-NOM3D(N3D) + IF(ACFLAG) THEN + CALL MCGCAL(N3D,NOM3D,N3REG,MCUW,MCUI,LMCU,LMXMCU) + DO II=1,N3D/2 + ITEMP=NOM3D(II) + NOM3D(II)=NOM3D(N3D+1-II) + NOM3D(N3D+1-II)=ITEMP + ENDDO + CALL MCGCAL(N3D,NOM3D,N3REG,MCUW,MCUI,LMCU,LMXMCU) + ENDIF + T=TP + IF (SSYM.EQ.1) GOTO 10 + K=KST +* --- +* negative polar sine track +* --- + I2=NZP + Z2=Z(I2) + TIN=0 + N3D=1 + NOM3D(N3D)=INDREG(NOM2D(K+1),NZP+1) + H3D(N3D)=0.5D0 + CALL MCGPT2(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I2,K,Z2,T, + 1 TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + SURF(-NOM3D(1))=SURF(-NOM3D(1))+W3D + NOM3D(1)=N3REG-NOM3D(1) + DO II=2,N3D-1 + VNUM(NOM3D(II),IANGL,IMU,2)=VNUM(NOM3D(II),IANGL,IMU,2) + 1 +H3D(II)*W3DPO + ENDDO + SURF(-NOM3D(N3D))=SURF(-NOM3D(N3D))+W3D + NOM3D(N3D)=N3REG-NOM3D(N3D) + IF(ACFLAG) THEN + CALL MCGCAL(N3D,NOM3D,N3REG,MCUW,MCUI,LMCU,LMXMCU) + DO II=1,N3D/2 + ITEMP=NOM3D(II) + NOM3D(II)=NOM3D(N3D+1-II) + NOM3D(N3D+1-II)=ITEMP + ENDDO + CALL MCGCAL(N3D,NOM3D,N3REG,MCUW,MCUI,LMCU,LMXMCU) + ENDIF +* --- + T=TP + 10 CONTINUE +*--- +* CONSTRUCT THE 3D TRACKS WHICH ENTER THE GEOMETRY THROUGH A LATERAL SURFACE +*--- +* length of the spatial integration interval + 15 LTOT=Z(NZP)*SPO +! LTOT=(Z(NZP)-Z(0))*SPO with Z(0)=0.0 +* number of 3D tracks generated for this x-y track and this polar direction + NBTR=INT(LTOT/DELU)+1 +* effective track spacing in Z + DELZE=Z(NZP)/DBLE(NBTR) +! DELZE=(Z(NZP)-Z(0))/DBLE(NBTR) with Z(0)=0.0 + W3DPO=W2D*DELZE*SPO + W3D=WPO*W3DPO + Z1=-0.5D0*DELZE +! Z1=Z(0)-0.5D0*DELZE with Z(0)=0.0 + IST=1 + DO 20 ILINE=1,NBTR + Z1=Z1+DELZE + Z1P=Z1 + DO WHILE (Z(IST).LT.Z1) + IST=IST+1 + ENDDO + I=IST +* --- +* positive polar sine track +* --- + K=1 + T=T2D(K-1) + TIN=1 + N3D=1 + N3DP=2 + NOM3D(N3D)=INDREG(NOM2D(1),IST) + H3D(N3D)=0.5D0 + SURF(-NOM3D(N3D))=SURF(-NOM3D(N3D))+W3D + NOM3D(N3D)=N3REG-NOM3D(N3D) + 21 CONTINUE + CALL MCGPT1(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I,K,Z1,T, + 1 TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=N3DP,N3D-1 + VNUM(NOM3D(II),IANGL,IMU,1)=VNUM(NOM3D(II),IANGL,IMU,1) + 1 +H3D(II)*W3DPO + ENDDO + IF (SSYM.GT.0) THEN +* the top boundary condition is a surface symmetry + IF (TIN.EQ.0) THEN +* this track has encountered the top boundary -> it is reflected + N3DP=N3D + N3D=N3D-1 + I=I-1 + CALL MCGPT2(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I,K,Z1, + 1 T,TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=N3DP,N3D-1 + VNUM(NOM3D(II),IANGL,IMU,2)=VNUM(NOM3D(II),IANGL,IMU,2) + 1 +H3D(II)*W3DPO + ENDDO + IF ((SSYM.EQ.2).AND.(TIN.EQ.0)) THEN +* the bottom boundary is a surface symmetry +* this track has encountered the bottom boundary -> it is reflected + N3DP=N3D + N3D=N3D-1 + I=I+1 + GOTO 21 + ENDIF + ENDIF + ENDIF + SURF(-NOM3D(N3D))=SURF(-NOM3D(N3D))+W3D + NOM3D(N3D)=N3REG-NOM3D(N3D) + IF(ACFLAG) THEN + CALL MCGCAL(N3D,NOM3D,N3REG,MCUW,MCUI,LMCU,LMXMCU) + DO II=1,N3D/2 + ITEMP=NOM3D(II) + NOM3D(II)=NOM3D(N3D+1-II) + NOM3D(N3D+1-II)=ITEMP + ENDDO + CALL MCGCAL(N3D,NOM3D,N3REG,MCUW,MCUI,LMCU,LMXMCU) + ENDIF + Z1=Z1P + I=IST +* --- +* negative polar sine track +* --- + K=1 + T=T2D(K-1) + TIN=1 + N3D=1 + N3DP=2 + NOM3D(N3D)=INDREG(NOM2D(1),IST) + H3D(N3D)=0.5D0 + SURF(-NOM3D(N3D))=SURF(-NOM3D(N3D))+W3D + NOM3D(N3D)=N3REG-NOM3D(N3D) + 22 CONTINUE + CALL MCGPT2(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I,K,Z1,T, + 1 TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=N3DP,N3D-1 + VNUM(NOM3D(II),IANGL,IMU,2)=VNUM(NOM3D(II),IANGL,IMU,2) + 1 +H3D(II)*W3DPO + ENDDO + IF (SSYM.EQ.2) THEN +* the bottom boundary is a surface symmetry + IF (TIN.EQ.0) THEN +* this track has encountered the bottom boundary -> it is reflected + N3DP=N3D + N3D=N3D-1 + I=I+1 + CALL MCGPT1(N2SOU,N2REG,NZP,NR2D,INDREG,Z,NOM2D,T2D,I,K,Z1, + 1 T,TIN,CPOI,SPOI,TPO,TPOI,N3D,NOM3D,H3D) + DO II=N3DP,N3D-1 + VNUM(NOM3D(II),IANGL,IMU,1)=VNUM(NOM3D(II),IANGL,IMU,1) + 1 +H3D(II)*W3DPO + ENDDO + IF (TIN.EQ.0) THEN +* the top boundary is a surface symmetry +* this track has encountered the top boundary -> it is reflected + N3DP=N3D + N3D=N3D-1 + I=I-1 + GOTO 22 + ENDIF + ENDIF + ENDIF + SURF(-NOM3D(N3D))=SURF(-NOM3D(N3D))+W3D + NOM3D(N3D)=N3REG-NOM3D(N3D) + IF(ACFLAG) THEN + CALL MCGCAL(N3D,NOM3D,N3REG,MCUW,MCUI,LMCU,LMXMCU) + DO II=1,N3D/2 + ITEMP=NOM3D(II) + NOM3D(II)=NOM3D(N3D+1-II) + NOM3D(N3D+1-II)=ITEMP + ENDDO + CALL MCGCAL(N3D,NOM3D,N3REG,MCUW,MCUI,LMCU,LMXMCU) + ENDIF +* --- + Z1=Z1P + 20 CONTINUE + ENDDO +* + RETURN + END diff --git a/Dragon/src/MCGREC.f b/Dragon/src/MCGREC.f new file mode 100644 index 0000000..fbf8c43 --- /dev/null +++ b/Dragon/src/MCGREC.f @@ -0,0 +1,61 @@ +*DECK MCGREC + SUBROUTINE MCGREC(NFI,KM,MCUW,MCUI,MCU,LMCU,LMXMCU,IPRINT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Reform connection matrices. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): I. Suslov and R. Le Tellier +* +*Parameters: input +* NFI total number of volumes and surfaces for which specific values +* of the neutron flux and reactions rates are required. +* MCUW undefined. +* MCUI undefined. +* LMCU dimension (used) of MCUW. +* LMXMCU real dimension of MCUW MCUI. +* IPRINT print level flag. +* +*Parameters: output +* KM number of non-diagonal element on each row. +* MCU column indexes of nonzero elements. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NFI,KM(NFI),MCUW(LMXMCU),MCUI(LMXMCU),MCU(LMCU),LMCU, + 1 LMXMCU,IPRINT +* + IM=0 + DO 10 I=1,NFI + IP=IM+1 + II=0 + IC=I + IF( MCUW(I).EQ.0 ) GOTO 9 + 3 II=II+1 + IM=IM+1 + IF(IM.GT.LMCU) CALL XABORT('MCGREC: OVERFLOW.') + MCU(IM)=MCUW(IC) + IC=MCUI(IC) + IF(IC.NE.0) GOTO 3 + 9 CONTINUE + KM(I)=II + IF(II.EQ.0) GOTO 10 + IPP=IP+II-1 + IF(IPRINT.GE.10) WRITE (6,13) I,(MCU(JP),JP=IP,IPP) + CALL SORTIN(II,MCU(IP)) + 10 CONTINUE +* + 13 FORMAT(1X,'I=',I3,' MCU=',30I4) + RETURN + END diff --git a/Dragon/src/MCGSCA.f b/Dragon/src/MCGSCA.f new file mode 100644 index 0000000..737d24d --- /dev/null +++ b/Dragon/src/MCGSCA.f @@ -0,0 +1,74 @@ +*DECK MCGSCA + SUBROUTINE MCGSCA(N,K,M,NOM,NZON,H,XST,B) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculate coefficients of a track for the characteristics integration. +* Step-Characteristics scheme with tabulated exponential calls with +* 'source term isolation' option turned on. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* N number of elements in the current track. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* M number of material mixtures. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* H vector containing the lenght of the different segments of this +* track. +* XST macroscopic total cross section. +* and step characteristics (SC). +* +*Parameters: output +* B undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,K,M,NOM(N),NZON(K) + REAL XST(0:M) + DOUBLE PRECISION H(N),B(N) +*--- +* LOCAL VARIABLES +*--- + INTEGER I,NOMI,NZI + REAL TAU + DOUBLE PRECISION HID,TAUD +* tabulated exponential common block + REAL E0, E1, PAS1, DX1, XLIM1 + INTEGER MEX1, LAU + PARAMETER ( MEX1=7936 ) + COMMON /EXP1/ E0(0:MEX1),E1(0:MEX1),PAS1,DX1,XLIM1 +* + DO I=2,N-1 + NOMI=NOM(I) + NZI=NZON(NOMI) + HID=H(I) + TAUD=HID*XST(NZI) + TAU=REAL(TAUD) + IF(TAU.GE.XLIM1) THEN +* Out of the table range + B(I)=1.D0/XST(NZI) + ELSE +* Linear interpolation in table of (1-exp(-x))/x + LAU=INT(TAUD*PAS1) + B(I)=HID*(E0(LAU)+E1(LAU)*TAUD) + ENDIF + ENDDO +* + RETURN + END diff --git a/Dragon/src/MCGSCAL.f b/Dragon/src/MCGSCAL.f new file mode 100644 index 0000000..5e80d80 --- /dev/null +++ b/Dragon/src/MCGSCAL.f @@ -0,0 +1,103 @@ +*DECK MCGSCAL + SUBROUTINE MCGSCAL(N,K,M,NOM,NZON,H,XST,B) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculate coefficients of a track for the characteristics +* integration. Linear-Discontinuous-Characteristics scheme +* with tabulated exponential calls with source term isolation +* option turned off. +* +*Copyright: +* Copyright (C) 2015 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* N number of elements in the current track. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* M number of material mixtures. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* H vector containing the lenght of the different segments of this +* track. +* XST macroscopic total cross section. +* +*Parameters: output +* B LDC coefficients. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,K,M,NOM(N),NZON(K) + REAL XST(0:M) + DOUBLE PRECISION H(N),B(0:5,N) +*--- +* LOCAL VARIABLES +*--- + INTEGER I,NOMI,NZI + DOUBLE PRECISION TAUDMIN,SQ3,TAUD,HID,TEMP,DSIG,C1,C2,H2,H3,TEMP1 +* tabulated exponential common block + REAL E0, E1, PAS1, DX1, XLIM1 + INTEGER MEX1, LAU + PARAMETER ( MEX1=7936, TAUDMIN=2.0D-2 ) + COMMON /EXP1/ E0(0:MEX1),E1(0:MEX1),PAS1,DX1,XLIM1 +* + SQ3=SQRT(3.0D0) + DO I=2,N-1 + NOMI=NOM(I) + NZI=NZON(NOMI) + HID=H(I) + TAUD=HID*XST(NZI) + IF(TAUD.LE.TAUDMIN) THEN +* Use Taylor series expansions + H2=HID*HID + H3=H2*HID + B(0,I)=TAUD*(0.5D0*TAUD-1.0D0)+1.0D0 + B(1,I)=HID*(TAUD*(TAUD/6.0D0-0.5D0)+1.0D0) + B(2,I)=H2*(TAUD*(TAUD-4.0D0)+12.0D0)/24.0D0 + B(3,I)=-SQ3*H3*(TAUD*(TAUD-2.0D0)+4.0D0)/24.0D0 + B(4,I)=-SQ3*TAUD*(TAUD*(TAUD-2.0D0)+4.0D0)/24.0D0 + B(5,I)=H3*(TAUD*TAUD-TAUD+4.0D0)/40.0D0 + ELSE IF(TAUD.GE.XLIM1) THEN +* Out of the table range + B(0,I)=0.D0 + TEMP=1.D0/TAUD + DSIG=DBLE(XST(NZI)) + B(1,I)=TEMP*HID + B(2,I)=HID*(1.D0-TEMP)/DSIG + B(3,I)=-SQ3*HID*(2.0D0-(TAUD+2.0D0)*TEMP)/DSIG**2 + B(4,I)=-SQ3*(2.0D0-(TAUD+2.0D0)*TEMP)/TAUD + C1=TAUD*(TAUD-6.0D0)-12.0D0 + C2=TAUD*(3.0D0*TAUD+12.0D0)+12.0D0 + B(5,I)=(C1+C2*TEMP)/(TAUD*DSIG**3) + ELSE +* Use tabulated exponential + LAU=INT(REAL(TAUD)*PAS1) + TEMP=DBLE(E0(LAU)+E1(LAU)*TAUD) + TEMP1=1.0D0-TEMP*TAUD + DSIG=DBLE(XST(NZI)) + B(0,I)=TEMP1 + TEMP=(1.D0-TEMP1)/TAUD + B(1,I)=TEMP*HID + B(2,I)=HID*(1.D0-TEMP)/DSIG + B(3,I)=-SQ3*HID*(2.0D0-(TAUD+2.0D0)*TEMP)/DSIG**2 + B(4,I)=-SQ3*(2.0D0-(TAUD+2.0D0)*TEMP)/TAUD + C1=TAUD*(TAUD-6.0D0)-12.0D0 + C2=TAUD*(3.0D0*TAUD+12.0D0)+12.0D0 + B(5,I)=(C1+C2*TEMP)/(TAUD*DSIG**3) + ENDIF + ENDDO +* + RETURN + END diff --git a/Dragon/src/MCGSCAS.f b/Dragon/src/MCGSCAS.f new file mode 100644 index 0000000..cbbe8e4 --- /dev/null +++ b/Dragon/src/MCGSCAS.f @@ -0,0 +1,84 @@ +*DECK MCGSCAS + SUBROUTINE MCGSCAS(N,K,M,NOM,NZON,H,XST,B) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculate coefficients of a track for the characteristics integration. +* Step-Characteristics scheme with tabulated exponential calls with +* 'source term isolation' option turned off. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* N number of elements in the current track. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* M number of material mixtures. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* H vector containing the lenght of the different segments of this +* track. +* XST macroscopic total cross section. +* +*Parameters: output +* B undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,K,M,NOM(N),NZON(K) + REAL XST(0:M) + DOUBLE PRECISION H(N),B(2,N) +*--- +* LOCAL VARIABLES +*--- + INTEGER I,NOMI,NZI + REAL TAU + DOUBLE PRECISION TAUDMIN,TAUD,HID,HID2,TAUD3,TAUD4,TAUD5 +* tabulated exponential common block + REAL E0, E1, PAS1, DX1, XLIM1 + INTEGER MEX1, LAU + PARAMETER ( MEX1=7936, TAUDMIN=2.D-2 ) + COMMON /EXP1/ E0(0:MEX1),E1(0:MEX1),PAS1,DX1,XLIM1 +* + DO I=2,N-1 + NOMI=NOM(I) + NZI=NZON(NOMI) + HID=H(I) + TAUD=HID*XST(NZI) + TAU=REAL(TAUD) + IF(TAU.GE.XLIM1) THEN +* Out of the table range + B(1,I)=1.D0/XST(NZI) + B(2,I)=(HID-B(1,I))*B(1,I) + ELSE +* Linear interpolation in table of (1-exp(-x))/x + LAU=INT(TAU*PAS1) + B(1,I)=HID*(E0(LAU)+E1(LAU)*TAU) + IF(TAUD.LE.TAUDMIN) THEN +* and expansion in Taylor serie in O(TAUD^3) + TAUD3=TAUD/3.D0 + TAUD4=0.125D0*TAUD + TAUD5=0.2D0*TAUD + HID2=HID*HID + B(2,I)=HID2*(0.5D0-TAUD3*(0.5D0-TAUD4*(1.D0-TAUD5))) + ELSE + B(2,I)=(HID-B(1,I))/XST(NZI) + ENDIF + ENDIF + ENDDO +* + RETURN + END diff --git a/Dragon/src/MCGSCAT.f b/Dragon/src/MCGSCAT.f new file mode 100644 index 0000000..04bdbff --- /dev/null +++ b/Dragon/src/MCGSCAT.f @@ -0,0 +1,65 @@ +*DECK MCGSCAT + SUBROUTINE MCGSCAT(N,K,M,NOM,NZON,H,XST,B) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculate coefficients of a track for the characteristics integration. +* Step-Characteristics scheme with tabulated exponential calls. +* MOCC/MCI integration strategy. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* N number of elements in the current track. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* M number of material mixtures. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* H vector containing the lenght of the different segments of this +* track. +* XST macroscopic total cross section. +* and step characteristics (SC). +* +*Parameters: output +* B undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,K,M,NOM(N),NZON(K) + REAL XST(0:M) + DOUBLE PRECISION H(N),B(N) +*--- +* LOCAL VARIABLES +*--- + INTEGER I,NOMI,NZI + DOUBLE PRECISION TAUD +* tabulated exponential common block + REAL E0, E1, PAS1, DX1, XLIM1 + INTEGER MEX1, LAU + PARAMETER ( MEX1=7936) + COMMON /EXP0/ E0(0:MEX1),E1(0:MEX1),PAS1,DX1,XLIM1 +* + DO I=2,N-1 + NOMI=NOM(I) + NZI=NZON(NOMI) + TAUD=H(I)*XST(NZI) + LAU=MIN(INT(TAUD*PAS1),MEX1) + B(I)=E0(LAU)+E1(LAU)*TAUD + ENDDO +* + RETURN + END diff --git a/Dragon/src/MCGSCE.f b/Dragon/src/MCGSCE.f new file mode 100644 index 0000000..348f6bf --- /dev/null +++ b/Dragon/src/MCGSCE.f @@ -0,0 +1,71 @@ +*DECK MCGSCE + SUBROUTINE MCGSCE(N,K,M,NOM,NZON,H,XST,B) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculate coefficients of a track for the characteristics integration. +* Step-Characteristics scheme with exact exponential calls with +* 'source term isolation' option turned on. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* N number of elements in the current track. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* M number of material mixtures. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* H vector containing the lenght of the different segments of this +* track. +* XST macroscopic total cross section. +* +*Parameters: output +* B undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,K,M,NOM(N),NZON(K) + REAL XST(0:M) + DOUBLE PRECISION H(N),B(N) +*--- +* LOCAL VARIABLES +*--- + INTEGER I,NOMI,NZI + DOUBLE PRECISION TAUDMIN,TAUD,HID +* tabulated exponential common block + REAL E0, E1, PAS1, DX1, XLIM1 + INTEGER MEX1, LAU + PARAMETER ( MEX1=7936, TAUDMIN=2.D-2 ) + COMMON /EXP1/ E0(0:MEX1),E1(0:MEX1),PAS1,DX1,XLIM1 +* + DO I=2,N-1 + NOMI=NOM(I) + NZI=NZON(NOMI) + HID=H(I) + TAUD=HID*XST(NZI) + IF(TAUD.LE.TAUDMIN) THEN +* Linear interpolation in table of (1-exp(-x))/x + LAU=INT(TAUD*PAS1) + B(I)=HID*(E0(LAU)+E1(LAU)*TAUD) + ELSE +* Exact exponential + B(I)=(1.D0-DEXP(-TAUD))/XST(NZI) + ENDIF + ENDDO +* + RETURN + END diff --git a/Dragon/src/MCGSCEL.f b/Dragon/src/MCGSCEL.f new file mode 100644 index 0000000..0355e69 --- /dev/null +++ b/Dragon/src/MCGSCEL.f @@ -0,0 +1,85 @@ +*DECK MCGSCEL + SUBROUTINE MCGSCEL(N,K,M,NOM,NZON,H,XST,B) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculate coefficients of a track for the characteristics +* integration. Linear-Discontinuous-Characteristics scheme with +* exact exponential calls. Source term isolation option turned off. +* +*Copyright: +* Copyright (C) 2015 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* N number of elements in the current track. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* M number of material mixtures. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* H vector containing the lenght of the different segments of this +* track. +* XST macroscopic total cross section. +* +*Parameters: output +* B LDC coefficients. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,K,M,NOM(N),NZON(K) + REAL XST(0:M) + DOUBLE PRECISION H(N),B(0:5,N) +*--- +* LOCAL VARIABLES +*--- + INTEGER I,NOMI,NZI + DOUBLE PRECISION TAUDMIN,SQ3,TAUD,HID,TEMP,DSIG,C1,C2,H2,H3,TEMP1 +* tabulated exponential common block + PARAMETER ( TAUDMIN=2.0D-2) +* + SQ3=SQRT(3.0D0) + DO I=2,N-1 + NOMI=NOM(I) + NZI=NZON(NOMI) + HID=H(I) + TAUD=HID*XST(NZI) + IF(TAUD.LE.TAUDMIN) THEN +* Use Taylor series expansions + H2=HID*HID + H3=H2*HID + B(0,I)=TAUD*(0.5D0*TAUD-1.0D0)+1.0D0 + B(1,I)=HID*(TAUD*(TAUD/6.0D0-0.5D0)+1.0D0) + B(2,I)=H2*(TAUD*(TAUD-4.0D0)+12.0D0)/24.0D0 + B(3,I)=-SQ3*H3*(TAUD*(TAUD-2.0D0)+4.0D0)/24.0D0 + B(4,I)=-SQ3*TAUD*(TAUD*(TAUD-2.0D0)+4.0D0)/24.0D0 + B(5,I)=H3*(TAUD*TAUD-TAUD+4.0D0)/40.0D0 + ELSE +* Use exact exponential + TEMP1=EXP(-TAUD) + DSIG=DBLE(XST(NZI)) + B(0,I)=TEMP1 + TEMP=(1.D0-TEMP1)/TAUD + B(1,I)=TEMP*HID + B(2,I)=HID*(1.D0-TEMP)/DSIG + B(3,I)=-SQ3*HID*(2.0D0-(TAUD+2.0D0)*TEMP)/DSIG**2 + B(4,I)=-SQ3*(2.0D0-(TAUD+2.0D0)*TEMP)/TAUD + C1=TAUD*(TAUD-6.0D0)-12.0D0 + C2=TAUD*(3.0D0*TAUD+12.0D0)+12.0D0 + B(5,I)=(C1+C2*TEMP)/(TAUD*DSIG**3) + ENDIF + ENDDO +* + RETURN + END diff --git a/Dragon/src/MCGSCES.f b/Dragon/src/MCGSCES.f new file mode 100644 index 0000000..7b70242 --- /dev/null +++ b/Dragon/src/MCGSCES.f @@ -0,0 +1,78 @@ +*DECK MCGSCES + SUBROUTINE MCGSCES(N,K,M,NOM,NZON,H,XST,B) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculate coefficients of a track for the characteristics integration. +* Step-Characteristics scheme with exact exponential calls with +* 'source term isolation' option turned off. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* N number of elements in the current track. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* M number of material mixtures. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* H vector containing the lenght of the different segments of this +* track. +* XST macroscopic total cross section. +* +*Parameters: output +* B undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,K,M,NOM(N),NZON(K) + REAL XST(0:M) + DOUBLE PRECISION H(N),B(2,N) +*--- +* LOCAL VARIABLES +*--- + INTEGER I,NOMI,NZI + DOUBLE PRECISION TAUDMIN,TAUD,HID,HID2,TAUD3,TAUD4,TAUD5 +* tabulated exponential common block + REAL E0, E1, PAS1, DX1, XLIM1 + INTEGER MEX1, LAU + PARAMETER ( MEX1=7936, TAUDMIN=2.D-2 ) + COMMON /EXP1/ E0(0:MEX1),E1(0:MEX1),PAS1,DX1,XLIM1 +* + DO I=2,N-1 + NOMI=NOM(I) + NZI=NZON(NOMI) + HID=H(I) + TAUD=HID*XST(NZI) + IF(TAUD.LE.TAUDMIN) THEN +* Linear interpolation in table of (1-exp(-x))/x + LAU=INT(TAUD*PAS1) + B(1,I)=HID*(E0(LAU)+E1(LAU)*TAUD) +* and expansion in Taylor serie in O(TAUD^3) + TAUD3=TAUD/3.D0 + TAUD4=0.125D0*TAUD + TAUD5=0.2D0*TAUD + HID2=HID*HID + B(2,I)=HID2*(0.5D0-TAUD3*(0.5D0-TAUD4*(1.D0-TAUD5))) + ELSE +* Exact exponential + B(1,I)=(1.D0-DEXP(-TAUD))/XST(NZI) + B(2,I)=(HID-B(1,I))/XST(NZI) + ENDIF + ENDDO +* + RETURN + END diff --git a/Dragon/src/MCGSCET.f b/Dragon/src/MCGSCET.f new file mode 100644 index 0000000..e2f5b34 --- /dev/null +++ b/Dragon/src/MCGSCET.f @@ -0,0 +1,59 @@ +*DECK MCGSCET + SUBROUTINE MCGSCET(N,K,M,NOM,NZON,H,XST,B) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculate coefficients of a track for the characteristics integration. +* Step-Characteristics scheme with exact exponential calls. +* MOCC/MCI integration strategy. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* N number of elements in the current track. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* M number of material mixtures. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* H vector containing the lenght of the different segments of this +* track. +* XST macroscopic total cross section. +* and step characteristics (SC). +* +*Parameters: output +* B undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,K,M,NOM(N),NZON(K) + REAL XST(0:M) + DOUBLE PRECISION H(N),B(N) +*--- +* LOCAL VARIABLES +*--- + INTEGER I,NOMI,NZI + DOUBLE PRECISION TAUD +* + DO I=2,N-1 + NOMI=NOM(I) + NZI=NZON(NOMI) + TAUD=H(I)*XST(NZI) + B(I)=1.D0-DEXP(-TAUD) + ENDDO +* + RETURN + END diff --git a/Dragon/src/MCGSCR.f b/Dragon/src/MCGSCR.f new file mode 100644 index 0000000..2287848 --- /dev/null +++ b/Dragon/src/MCGSCR.f @@ -0,0 +1,338 @@ +*DECK MCGSCR + SUBROUTINE MCGSCR(IPTRK,KPSYS,IPMACR,IPRINT,N1,NG,NGEFF,KPN,K, + 1 NREG,NANI,NFUNL,M,LPS,KEYFLX,KEYCUR,NZON,NGIND, + 2 NCONV,MXSCR,EPSSCR,REBAL,PHIOUT,PHIIN,V,NPJJM, + 3 KEYANI,IDIR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Acceleration of inner iteration (SCR method). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IPTRK pointer to the tracking LCM object. +* KPSYS pointer array for each group properties. +* IPMACR pointer to the macrolib LCM object. +* IPRINT print parameter (equal to zero for no print). +* N1 number of unknowns per group of the corrective system. +* NG number of groups. +* NGEFF number of groups to process. +* KPN total number of unknowns in vectors SUNKNO and FUNKNO. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* NREG number of volumes. +* NANI scattering anisotropy (=1 for isotropic scattering). +* NFUNL number of moments of the flux (in 2D NFUNL=NANI*(NANI+1)/2). +* M number of material mixtures. +* LPS dimension of PSJ. +* KEYFLX position of flux elements in FI vector. +* KEYCUR position of current elements in FI vector. +* NZON index-number of the mixture type assigned to each volume. +* NGIND index of the groups to process. +* NCONV logical array of convergence status for each group (.TRUE. +* not converged). +* MXSCR maximum number of iterations for rebalancing system. +* EPSSCR convergence criterion for rebalancing system. +* REBAL type of acceleration (.TRUE. rebalancing ; .FALSE. inner +* iterations acceleration). +* PHIIN initial guess (for this iteration) of zonal scalar flux. +* V volumes. +* NPJJM second dimension of PJJ. +* KEYANI 'mode to l' index l=KEYANI(nu). +* IDIR direction of fundamental current for TIBERE with MoC +* =0,1,2,3. +* +*Parameters: input/output +* PHIOUT zonal scalar flux. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,KPSYS(NGEFF),IPMACR + INTEGER N1,NGEFF,NG,IPRINT,KPN,K,NREG,NANI,NFUNL,M,LPS, + 1 KEYFLX(NREG,NFUNL),KEYCUR(*),NZON(K),NGIND(NGEFF),MXSCR,NPJJM, + 2 KEYANI(NFUNL),IDIR + REAL EPSSCR,PHIIN(KPN,NGEFF),V(N1) + DOUBLE PRECISION PHIOUT(KPN,NGEFF) + LOGICAL NCONV(NGEFF),REBAL +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPMACR,KPMACR,JPSYS + DOUBLE PRECISION TEMP + CHARACTER*12 NGTYP + CHARACTER*12 NAMPJJ,NAMPSJ + INTEGER, TARGET, SAVE, DIMENSION(1) :: IDUMMY +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NGINDV,NJJ,IJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) :: XSCAT,MATR + REAL, ALLOCATABLE, DIMENSION(:) :: PJJ,PSJ + REAL, ALLOCATABLE, DIMENSION(:,:) :: SC + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: AR,PSI +* + TYPE(C_PTR) PJJIND_PTR,IS_PTR,JS_PTR + INTEGER, POINTER, DIMENSION(:) :: IS,JS + INTEGER, POINTER, DIMENSION(:,:) :: PJJIND +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NGINDV(NG),SC(0:M,NANI),AR(KPN,NGEFF,2),PSI(KPN,NGEFF,2), + 1 PJJ(NREG*NPJJM),PSJ(LPS)) + PSI(:KPN,:NGEFF,:2)=0.0D0 + AR(:KPN,:NGEFF,:2)=0.0D0 + CALL LCMGPD(IPTRK,'PJJIND$MCCG',PJJIND_PTR) + CALL C_F_POINTER(PJJIND_PTR,PJJIND,(/ NPJJM,2 /)) + IF(N1.GT.NREG) THEN +* recover (IS,JS) arrays +* IS: arrays for surfaces neighbors +* JS: JS(IS(ISOUT)+1:IS(ISOUT+1)) give the neighboring regions to +* surface ISOUT. + CALL LCMGPD(IPTRK,'IS$MCCG',IS_PTR) + CALL LCMGPD(IPTRK,'JS$MCCG',JS_PTR) + CALL C_F_POINTER(IS_PTR,IS,(/ N1-NREG+1 /)) + CALL C_F_POINTER(JS_PTR,JS,(/ LPS /)) + ELSE + IS=>IDUMMY + JS=>IDUMMY + ENDIF + IF(REBAL) THEN + JPMACR=LCMGID(IPMACR,'GROUP') + ALLOCATE(NJJ(0:M),IJJ(0:M),IPOS(0:M),XSCAT(0:M*NG)) + ENDIF + IF(IDIR .EQ.0) THEN + NAMPJJ='PJJ$MCCG' + NAMPSJ='PSJ$MCCG' + ELSEIF(IDIR .EQ. 1) THEN + NAMPJJ='PJJX$MCCG' + NAMPSJ='PSJX$MCCG' + ELSEIF(IDIR .EQ. 2) THEN + NAMPJJ='PJJY$MCCG' + NAMPSJ='PSJY$MCCG' + ELSE + NAMPJJ='PJJZ$MCCG' + NAMPSJ='PSJZ$MCCG' + ENDIF +*---- +* CONSTRUCT NGINDV (index to pass from "NGEFF format" to "NG format"). +*---- + NGINDV(:NG)=0 + DO II=1,NGEFF + IF(NCONV(II)) THEN + IG=NGIND(II) + NGINDV(IG)=II + ENDIF + ENDDO +*--- +* COMPUTE RESIDUAL OF THE PREVIOUS FREE ITERATION FOR RHS +*--- + DO II=1,NGEFF + IF(NCONV(II)) THEN + IG=NGIND(II) + JPSYS=KPSYS(II) + CALL LCMGET(JPSYS,'DRAGON-S0XSC',SC(0,1)) + IF(REBAL) THEN + KPMACR=LCMGIL(JPMACR,IG) + CALL LCMGET(KPMACR,'NJJS00',NJJ(1)) + CALL LCMGET(KPMACR,'IJJS00',IJJ(1)) + CALL LCMGET(KPMACR,'IPOS00',IPOS(1)) + CALL LCMGET(KPMACR,'SCAT00',XSCAT(1)) + ENDIF + CALL MCGFCR(IPRINT,IG,II,NG,NGEFF,KPN,N1,NREG,NANI,NFUNL, + 1 M,.FALSE.,KEYFLX,KEYCUR,NZON,NGINDV,REBAL,PHIOUT, + 2 PHIIN,SC,KEYANI,NJJ,IJJ,IPOS,XSCAT,AR(1,II,1)) + ENDIF + ENDDO +*--- +* GAUSS SEIDEL ITERATIVE APPROACH TO SOLVE THE REBALANCING SYSTEM +*--- + IF(REBAL) THEN + NGTYP='GAUSS-SEIDEL' + NFIRST=NGEFF+1 + DO II=1,NGEFF + IF(NCONV(II)) THEN + IG=NGIND(II) + KPMACR=LCMGIL(JPMACR,IG) + CALL LCMGET(KPMACR,'IJJS00',IJJ(1)) + DO IBM=1,M + IF(IJJ(IBM).GT.IG) THEN + NFIRST=II ! first thermal group index in NGEFF format + GOTO 5 + ENDIF + ENDDO + ENDIF + ENDDO + ELSE + NGTYP=' ONE-GROUP' + NFIRST=1 + ENDIF + 5 CONTINUE +* + IF(NANI.GT.1) ALLOCATE(MATR(NFUNL*(NFUNL+1)*NREG)) + DO ITSCR=1,MXSCR + DO 20 II=1,NGEFF + IF(NCONV(II)) THEN + IF((II.LT.NFIRST).AND.(ITSCR.GT.1)) GOTO 20 + IG=NGIND(II) + JPSYS=KPSYS(II) + CALL LCMGET(JPSYS,'DRAGON-S0XSC',SC(0,1)) + CALL LCMGET(JPSYS,NAMPJJ,PJJ) + IF(REBAL) THEN + KPMACR=LCMGIL(JPMACR,IG) + CALL LCMGET(KPMACR,'NJJS00',NJJ(1)) + CALL LCMGET(KPMACR,'IJJS00',IJJ(1)) + CALL LCMGET(KPMACR,'IPOS00',IPOS(1)) + CALL LCMGET(KPMACR,'SCAT00',XSCAT(1)) + ENDIF + DO I=1,NREG + IBM=NZON(I) + DO INU=1,NFUNL + IND=KEYFLX(I,INU) + AR(IND,II,2)=AR(IND,II,1) + ENDDO + IF(REBAL) THEN +* rebalancing option on : contribution from others groups. + IF(IBM.GT.0) THEN + IND=KEYFLX(I,1) + JG=IJJ(IBM) + DO 10 JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + JJ=NGINDV(JG) + IF(JJ.GT.0) THEN + AR(IND,II,2)=AR(IND,II,2)+ + 1 XSCAT(IPOS(IBM)+JND-1)*PSI(I,JJ,1) + ENDIF + ENDIF + JG=JG-1 + 10 CONTINUE + ENDIF + ENDIF + ENDDO + IF(NANI.EQ.1) THEN + DO I=1,NREG + IBM=NZON(I) + IND=KEYFLX(I,1) + PSI(IND,II,1)=AR(IND,II,2) + 1 *PJJ(I)/(1.0-SC(IBM,1)*PJJ(I)) + ENDDO + ELSE + CALL MCGSCS(KPN,K,NREG,M,NANI,NFUNL,NPJJM,KEYFLX,KEYANI, + 1 PJJIND,NZON,SC(0,1),PJJ,AR(1,II,2),PSI(1,II,1),MATR) + ENDIF + ENDIF + 20 CONTINUE + IF(REBAL) THEN + ERRSCR=0.0 + DO II=NFIRST,NGEFF + IF(NCONV(II)) THEN + ERR1=0.0 + ERR2=0.0 + DO I=1,NREG + DO INU=1,NFUNL + IND=KEYFLX(I,INU) + TEMP1=REAL(ABS(PSI(IND,II,1)-PSI(IND,II,2))) + TEMP2=REAL(ABS(PSI(IND,II,1))) + ERR1=MAX(ERR1,TEMP1) + ERR2=MAX(ERR2,TEMP2) + PSI(IND,II,2)=PSI(IND,II,1) + ENDDO + ENDDO + IF(ERR2.GT.0.0) ERRSCR=MAX(ERRSCR,ERR1/ERR2) + ENDIF + ENDDO + IF(ERRSCR.LT.EPSSCR) GO TO 30 + ENDIF + ENDDO + 30 CONTINUE + IF(NANI.GT.1) DEALLOCATE(MATR) +* + IF((REBAL).AND.(IPRINT.GT.0)) THEN + IF(NFIRST.GT.1) WRITE(6,100) NGIND(1),NGIND(NFIRST-1),NGTYP + IF((MXSCR.GT.1).AND.(NFIRST.LE.NGEFF)) THEN + WRITE(6,200) NGTYP,ERRSCR,(ITSCR-1) + ENDIF + ELSE + IF(IPRINT.GT.1) WRITE(6,100) NGIND(1),NGIND(NGEFF),NGTYP + ENDIF +*---- +* PERFORM THE CORRECTION +*---- +* Flux Correction + DO II=1,NGEFF + IF(NCONV(II)) THEN + DO I=1,NREG + DO INU=1,NFUNL + IND=KEYFLX(I,INU) + PHIOUT(IND,II)=PHIOUT(IND,II)+PSI(IND,II,1) + ENDDO + ENDDO + ENDIF + ENDDO +* Current Correction + IF(N1.GT.NREG) THEN + DO II=1,NGEFF + IF(NCONV(II)) THEN + IG=NGIND(II) + JPSYS=KPSYS(II) + CALL LCMGET(JPSYS,NAMPSJ,PSJ) + CALL LCMGET(JPSYS,'DRAGON-S0XSC',SC(0,1)) + IF(REBAL) THEN + KPMACR=LCMGIL(JPMACR,IG) + CALL LCMGET(KPMACR,'NJJS00',NJJ(1)) + CALL LCMGET(KPMACR,'IJJS00',IJJ(1)) + CALL LCMGET(KPMACR,'IPOS00',IPOS(1)) + CALL LCMGET(KPMACR,'SCAT00',XSCAT(1)) + ENDIF + DO I=NREG+1,N1 + IIS=I-NREG + INDC=KEYCUR(IIS) + DO J=IS(IIS)+1,IS(IIS+1) + MCUI=JS(J) + IND=KEYFLX(MCUI,1) + IBM=NZON(MCUI) + IF(IBM.GT.0) THEN + TEMP=SC(IBM,1)*(PHIOUT(IND,II)-PHIIN(IND,II)) + IF(REBAL) THEN + JG=IJJ(IBM) + DO 40 JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + JJ=NGINDV(JG) + IF(JJ.GT.0) THEN + TEMP=TEMP+XSCAT(IPOS(IBM)+JND-1) + 1 *(PHIOUT(IND,JJ)-PHIIN(IND,JJ)) + ENDIF + ENDIF + JG=JG-1 + 40 CONTINUE + ENDIF + PHIOUT(INDC,II)=PHIOUT(INDC,II)+PSJ(J)*TEMP/V(I) + ENDIF + ENDDO + ENDDO + ENDIF + ENDDO + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + IF(REBAL) DEALLOCATE(XSCAT,IPOS,IJJ,NJJ) + DEALLOCATE(PSJ,PJJ,PSI,AR,SC,NGINDV) + RETURN +* + 100 FORMAT(10X,11HSCR: GROUPS,I4,3H TO,I4,2H: ,A12,7H SCHEME) + 200 FORMAT(10X,24HSCR: UP-SCATTE. GROUPS: ,A12,17H ITERATIONS: PRC:, + 1 E9.2,2H (,I4,12H ITERATIONS)) + END diff --git a/Dragon/src/MCGSCS.f b/Dragon/src/MCGSCS.f new file mode 100644 index 0000000..92f07aa --- /dev/null +++ b/Dragon/src/MCGSCS.f @@ -0,0 +1,102 @@ +*DECK MCGSCS + SUBROUTINE MCGSCS(KPN,K,NREG,M,NANI,NFUNL,NPJJM,KEYFLX,KEYANI, + 1 PJJIND,NZON,XSW,PJJ,AR,PSI,MATRIX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solve the SCR anisotropic system. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* KPN total number of unknowns in vectors SUNKNO and FUNKNO. +* K total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* NREG number of volumes. +* M number of material mixtures. +* NANI scattering anisotropy (=1 for isotropic scattering). +* NFUNL number of moments of the flux (in 2D : NFUNL=NANI*(NANI+1)/2). +* NPJJM second dimension of PJJ. +* KEYFLX position of flux elements in FI vector. +* KEYANI 'mode to l' index l=KEYANI(nu). +* PJJIND index for pjj(nu <- nu') modes. +* NZON index-number of the mixture type assigned to each volume. +* XSW macroscopic scattering cross section. +* PJJ used in scr acceleration. +* AR residuals of the current iteration. +* +*Parameters: output +* PSI corrective flux. +* +*Parameters: scratch +* MATRIX undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER KPN,K,NREG,M,NANI,NFUNL,NPJJM,KEYFLX(NREG,NPJJM), + 1 KEYANI(NFUNL),PJJIND(NPJJM,2),NZON(K) + REAL XSW(0:M,NANI),PJJ(NREG,NPJJM),MATRIX(NFUNL,NFUNL+1,NREG) + DOUBLE PRECISION AR(KPN),PSI(KPN) +*--- +* LOCAL VARIABLES +*--- + INTEGER IRHS,I,INU,IMOD,INUP,L,LP,L1,LP1,NZI,IND,INDP,IER + REAL DL,DLP,XSWI,XSWIP,TEMP +*--- +* CONSTRUCT LINEAR SYSTEM BY REGION TO SOLVE +*--- + IRHS=NFUNL+1 + MATRIX(:NFUNL,:NFUNL+1,:NREG)=0.0 + DO 10 IMOD=1,NPJJM + INU=PJJIND(IMOD,1) + INUP=PJJIND(IMOD,2) + IF((INU.GT.NFUNL).OR.(INUP.GT.NFUNL)) GOTO 10 + L=KEYANI(INU) + L1=L+1 + LP=KEYANI(INUP) + LP1=LP+1 + DL=REAL(2*L+1) + DLP=REAL(2*LP+1) + DO I=1,NREG + NZI=NZON(I) + IND=KEYFLX(I,INU) + INDP=KEYFLX(I,INUP) + XSWI=XSW(NZI,L1) + XSWIP=XSW(NZI,LP1) + TEMP=PJJ(I,IMOD) + MATRIX(INU,IRHS,I)=MATRIX(INU,IRHS,I)+TEMP*REAL(AR(INDP)) + MATRIX(INU,INUP,I)=-DLP*XSWIP*TEMP + IF(INU.EQ.INUP) THEN + MATRIX(INU,INUP,I)=MATRIX(INU,INUP,I)+1.0 + ELSE + MATRIX(INUP,IRHS,I)=MATRIX(INUP,IRHS,I)+TEMP*REAL(AR(IND)) + MATRIX(INUP,INU,I)=-DL*XSWI*TEMP + ENDIF + ENDDO + 10 CONTINUE +*--- +* SOLVE LINEAR SYSTEM BY REGION +*--- + DO I=1,NREG + CALL ALSB(NFUNL,1,MATRIX(1,1,I),IER,NFUNL) + IF(IER.NE.0) CALL XABORT('MCGSCS: SINGULAR MATRIX.') + DO INU=1,NFUNL + IND=KEYFLX(I,INU) + PSI(IND)=MATRIX(INU,IRHS,I) + ENDDO + ENDDO +* + RETURN + END diff --git a/Dragon/src/MCGSIG.f b/Dragon/src/MCGSIG.f new file mode 100644 index 0000000..9509841 --- /dev/null +++ b/Dragon/src/MCGSIG.f @@ -0,0 +1,77 @@ +*DECK MCGSIG + SUBROUTINE MCGSIG(IPTRK,NMAT,NGEFF,NALBP,KPSYS,SIGAL,LVOID) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Construct total cross sections and albedos array and check for void. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IPTRK pointer to the tracking (L_TRACK signature). +* NMAT number of mixtures. +* NGEFF effective number of energy groups. +* NALBP number of physical albedos. +* KPSYS pointer array for each group properties. +* +*Parameters: output +* SIGAL total cross sections and albedos array. +* LVOID void flag. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*--- +* SUBROUTINES ARGUMENTS +*--- + TYPE(C_PTR) IPTRK,KPSYS(NGEFF) + INTEGER NMAT,NGEFF,NALBP + REAL SIGAL(-6:NMAT,NGEFF) + LOGICAL LVOID +*--- +* LOCAL VARIABLES +*--- + TYPE(C_PTR) JPSYS + INTEGER I,II,ISA,ICODE(6) + REAL ALBG(6),ALBEDO(6) + REAL, ALLOCATABLE, DIMENSION(:) :: ALBP +*--- +* RECOVER ALBEDO INFORMATION FROM TRACKING +*--- + CALL LCMGET(IPTRK,'ICODE',ICODE) + CALL LCMGET(IPTRK,'ALBEDO',ALBG) +* + LVOID=.FALSE. + ALLOCATE(ALBP(NALBP)) + DO II=1,NGEFF + JPSYS=KPSYS(II) + DO ISA=1,6 + ALBEDO(ISA)=ALBG(ISA) + ENDDO + IF(NALBP .GT. 0) THEN + CALL LCMGET(JPSYS,'ALBEDO',ALBP) + DO ISA=1,6 + IF(ICODE(ISA).GT.0) ALBEDO(ISA)=ALBP(ICODE(ISA)) + ENDDO + ENDIF + CALL LCMGET(JPSYS,'DRAGON-TXSC',SIGAL(0,II)) + DO I=1,NMAT + IF (SIGAL(I,II).EQ.0.0) LVOID=.TRUE. + ENDDO + DO ISA=-6,-1 + SIGAL(ISA,II)=ALBEDO(-ISA) + ENDDO + ENDDO + DEALLOCATE(ALBP) +* + RETURN + END diff --git a/Dragon/src/MCGTMT.f b/Dragon/src/MCGTMT.f new file mode 100644 index 0000000..e8977c5 --- /dev/null +++ b/Dragon/src/MCGTMT.f @@ -0,0 +1,97 @@ +*DECK MCGTMT + SUBROUTINE MCGTMT(NMERG,NTRTMT,NSETMT,NSEG,NSEG0,NOM,NOM0,WEIGHT, + 1 WEIGHT0,H,H0,LFORC,NTPROC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Track merging. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* NMERG number of merged tracks for the track under contruction. +* NTRTMT total number of finalized tracks. +* NSETMT total number of segments in finalized tracks. +* NSEG number of segments in the track to be processed. +* NSEG0 number of segments in the track under construction. +* NOM0 integer tracking elements for the under construction. +* WEIGHT0 weight of the under construction. +* H real tracking elements for the track to be processed. +* LFORC flag to force a merged track to be finalized. +* +*Parameters: input/output +* NOM integer tracking elements for the finalized track. +* WEIGHT weight of the finalized track. +* H0 real tracking elements for the finalized track. +* +*Parameters: output +* NTPROC number of merged tracks for the finalized track. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NMERG,NTRTMT,NSETMT,NSEG,NSEG0,NOM(NSEG), + 1 NOM0(NSEG),NTPROC + DOUBLE PRECISION WEIGHT,H(NSEG),WEIGHT0,H0(NSEG) + LOGICAL LFORC +*---- +* LOCAL VARIABLES +*---- + INTEGER II,NTEMP + DOUBLE PRECISION TEMP +* + IF (NMERG.GT.0) THEN + IF ((LFORC).OR.(NSEG.NE.NSEG0)) GOTO 20 + DO II=1,NSEG + IF (NOM(II).NE.NOM0(II)) GOTO 20 + ENDDO +* merge this track with the previous one + DO II=1,NSEG + H0(II)=H0(II)+WEIGHT*H(II) + ENDDO + WEIGHT0=WEIGHT0+WEIGHT + ELSE +* start + DO II=1,NSEG + H0(II)=WEIGHT*H(II) + NOM0(II)=NOM(II) + ENDDO + WEIGHT0=WEIGHT + ENDIF + NMERG=NMERG+1 + NSEG0=NSEG + NTPROC=0 + RETURN + 20 CONTINUE +* finalize this "merged" track and start a new one + NTRTMT=NTRTMT+1 + NSETMT=NSETMT+NSEG0 + DO II=1,MAX(NSEG0,NSEG) + TEMP=H(II) + H(II)=H0(II)/WEIGHT0 + H0(II)=WEIGHT*TEMP + NTEMP=NOM(II) + NOM(II)=NOM0(II) + NOM0(II)=NTEMP + ENDDO + NTPROC=NMERG + NMERG=1 + TEMP=WEIGHT + WEIGHT=WEIGHT0 + WEIGHT0=TEMP + NTEMP=NSEG + NSEG=NSEG0 + NSEG0=NTEMP + RETURN + END diff --git a/Dragon/src/MCGTRK.f b/Dragon/src/MCGTRK.f new file mode 100644 index 0000000..5a0d57a --- /dev/null +++ b/Dragon/src/MCGTRK.f @@ -0,0 +1,72 @@ +*DECK MCGTRK + SUBROUTINE MCGTRK(NFI,NZON,NSEG,NOM,H) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Unfold a tracking line (MOCC) for connection matrices. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: output +* NFI number of regions (volumes and surfaces). +* NZON index-number of the mixture type assigned to each volume. +*Parameters: input/output +* NSEG number of segment of this track folded/unfolded. +* NOM segment index array of this track folded/unfolded. +* H segment length array of this track folded/unfolded. +* +*Comments: +* Preconditioner calculation. +* ex: -5 2 3 1 -4 -4 2 1 -1 -1 1 -5 +* r v v r r r +* --> 2 3 1 -4 2 1 +* where r stands for reflective boundary condition, +* v \\ void \\ . +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NFI,NZON(NFI),NSEG,NOM(NSEG) + DOUBLE PRECISION H(NSEG) +*---- +* LOCAL VARIABLES +*---- + INTEGER IBCV + PARAMETER(IBCV=-7) + INTEGER I,IP,NOMI,NZI +*---- + I=1 + IP=0 + DO WHILE (I.LE.NSEG) + NOMI=NOM(I) + NZI=NZON(NOMI) + IF ((NZI.GE.0).OR.(NZI.EQ.IBCV)) THEN +* this cell is a volume or a voided boundary + IF ((IP.GE.1).AND.(NOM(IP).EQ.NOMI)) THEN + H(IP)=H(IP)+H(I) + ELSE + IP=IP+1 + NOM(IP)=NOM(I) + H(IP)=H(I) + ENDIF + ENDIF + I=I+1 + ENDDO + IF ((NOM(IP).EQ.NOM(1)).AND.(IP.GT.1)) THEN + H(1)=H(1)+H(IP) + IP=IP-1 + ENDIF + NSEG=IP +* + RETURN + END diff --git a/Dragon/src/MCT.f b/Dragon/src/MCT.f new file mode 100644 index 0000000..0681972 --- /dev/null +++ b/Dragon/src/MCT.f @@ -0,0 +1,202 @@ +*DECK MCT + SUBROUTINE MCT(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Monte-Carlo method based on NXT geometry analysis. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier and B. Arsenault +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1) creation type(L_MC); +* HENTRY(2) read-only or modification type(L_TRACK); +* HENTRY(3) read-only type(L_LIBRARY) or type(L_MACROLIB). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPOUT,IPTRK,IPLIB + INTEGER NSTATE,IOUT,ITC,NSRCK,IKZ,KCT,NGRP,NFREG,NBMIX,NMIX, + 1 NFM,NL,NDEL,NED,ISEED,IPRINT,NBSCO,NMERGE,NGCOND + PARAMETER (NSTATE=40,IOUT=6) + INTEGER ISTATE(NSTATE),GSTATE(NSTATE) + DOUBLE PRECISION XYZL(2,3),KEFF,REKEFF + CHARACTER NAMREC*12,HSIGN*12 + LOGICAL MODIF,LN2N +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: INMIX,NAMEAD + REAL, ALLOCATABLE, DIMENSION(:) :: XST,XSS,XSSNN,XNUFI,XCHI,XSN2N, + < XSN3N,XSEDI +*---- +* PARAMETER VALIDATION +*---- + IF(NENTRY.NE.3) CALL XABORT('MCT: THREE PARAMETERS EXPECTED.') +* output table in creation or modification mode + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) + 1 CALL XABORT('MCT: LCM OBJECT EXPECTED AT LHS (1).') + IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) + 1 CALL XABORT('MCT: ENTRY IN CREATION '// + 2 'OR MODIFICATION MODE EXPECTED.') + IPOUT=KENTRY(1) + MODIF=(JENTRY(1).EQ.1) +* tracking table in read-only mode + IF((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2)) + 1 CALL XABORT('MCT: LCM OBJECT EXPECTED AT LHS (2).') + IF((JENTRY(2).NE.1).AND.(JENTRY(2).NE.2)) CALL XABORT('MCT: ENTR' + 1 //'Y IN READ-ONLY OR MODIFICATION MODE EXPECTED.') + IPTRK=KENTRY(2) + CALL LCMGTC(IPTRK,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_TRACK') THEN + NAMREC=HENTRY(2) + CALL XABORT('MCT: INVALID SIGNATURE FOR '//NAMREC) + ENDIF +* xs library in read-only mode + IF((IENTRY(3).NE.1).AND.(IENTRY(3).NE.2)) + 1 CALL XABORT('MCT: LCM OBJECT EXPECTED AT LHS (3).') + IF(JENTRY(3).NE.2) + 1 CALL XABORT('MCT: ENTRY IN READ-ONLY MODE EXPECTED (2).') + IPLIB=KENTRY(3) + CALL LCMGTC(IPLIB,'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_LIBRARY') THEN + CALL LCMSIX(IPLIB,'MACROLIB',1) + CALL LCMGTC(IPLIB,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_MACROLIB') THEN + NAMREC=HENTRY(3) + CALL XABORT('MCT: INVALID SIGNATURE FOR '//NAMREC) + ENDIF + ELSE IF(HSIGN.NE.'L_MACROLIB') THEN + NAMREC=HENTRY(3) + CALL XABORT('MCT: INVALID SIGNATURE FOR '//NAMREC) + ENDIF +*---- +* INITIALIZE OUTPUT TABLE +*---- + IF(MODIF) THEN + CALL LCMGTC(IPOUT,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_MC') THEN + NAMREC=HENTRY(1) + CALL XABORT('MCT: INVALID SIGNATURE FOR '//NAMREC) + ENDIF + CALL LCMGET(IPOUT,'STATE-VECTOR',ISTATE) + ELSE + HSIGN='L_MC' + CALL LCMPTC(IPOUT,'SIGNATURE',12,HSIGN) + ISTATE(:NSTATE)=0 + ENDIF +*---- +* READ INPUT PARAMETERS +*---- + GSTATE(:NSTATE)=0 + CALL LCMGET(IPLIB,'STATE-VECTOR',GSTATE) + NGRP = GSTATE(1) + GSTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,'STATE-VECTOR',GSTATE) + NFREG= GSTATE(1) + NBMIX= GSTATE(4) + ALLOCATE(INMIX(NFREG)) + CALL LCMGET(IPTRK,'MATCOD',INMIX) + CALL MCTGET(IPOUT,NGRP,NFREG,NBMIX,INMIX,IPRINT) + DEALLOCATE(INMIX) + CALL LCMGET(IPOUT,'STATE-VECTOR',ISTATE) + ISEED=ISTATE(4) + LN2N=(ISTATE(5).EQ.1) +*---- +* VALIDATE THE OPTIONS SPECIFIED FOR THE KCODE CARD +*---- + IF ((ISTATE(1).GT.0).AND. + < (ISTATE(2).GT.0).AND. + < (ISTATE(3).GT.0).AND. + < (ISTATE(2).LE.ISTATE(3))) THEN + NSRCK=ISTATE(1) + IKZ =ISTATE(2) + KCT =ISTATE(3) + ELSE + CALL XABORT('MCT: INVALID PARAMETERS SPECIFIED FOR KCODE CARD') + ENDIF +*---- +* RECOVER MACROSCOPIC CROSS SECTIONS. +*---- + GSTATE(:NSTATE)=0 + CALL LCMGET(IPLIB,'STATE-VECTOR',GSTATE) + NGRP = GSTATE(1) + NMIX = GSTATE(2) + NL = GSTATE(3) + NFM = GSTATE(4) + NED = GSTATE(5) + NDEL = GSTATE(7) + ALLOCATE(NAMEAD(2*NED)) + IF(NED.GT.0) CALL LCMGET(IPLIB,'ADDXSNAME-P0',NAMEAD) + ALLOCATE(XST(NMIX*NGRP),XSS(NMIX*NGRP*NL), + > XSSNN(NGRP*NGRP*NMIX*NL),XNUFI(NFM*NMIX*NGRP*(1+NDEL)), + > XCHI(NFM*NMIX*NGRP*(1+NDEL)),XSN2N(NMIX*NGRP),XSN3N(NMIX*NGRP), + > XSEDI(NMIX*NGRP*NED)) + CALL MCTLIB(IPLIB,NMIX,NGRP,NL,NFM,NDEL,NED,NAMEAD,LN2N, + < XST,XSS,XSSNN,XNUFI,XCHI,XSN2N,XSN3N,XSEDI) +*---- +* POWER ITERATION WITH THE MONTE-CARLO METHOD IN 1D/2D/3D CARTESIAN +* GEOMETRY. +*---- + GSTATE(:NSTATE)=0 + CALL LCMGET(IPOUT,'STATE-VECTOR',GSTATE) + NMERGE=GSTATE(7) + NGCOND=GSTATE(8) + NBSCO=5+NGCOND*NL+2*NFM*(1+NDEL)+NED + CALL MCTFLX(IPTRK,IPOUT,IPRINT,NMIX,NGRP,NL,NFM,NDEL,NED, + < NAMEAD,XST,XSS,XSSNN,XNUFI,XCHI,XSN2N,XSN3N, + < XSEDI,NSRCK,IKZ,KCT,ISEED,XYZL,NBSCO,NMERGE, + < NGCOND,KEFF,REKEFF) +* + DEALLOCATE(XSEDI,XSN3N,XSN2N,XCHI,XNUFI,XSSNN,XSS,XST,NAMEAD) +*---- +* RESET LIBRARY ON ROOT LEVEL +*---- + CALL LCMSIX(IPLIB,' ',0) +*---- +* SAVE KEFF INFORMATION ON MC OBJECT +*---- + CALL LCMPUT(IPOUT,'K-EFFECTIVE',1,2,REAL(KEFF)) + CALL LCMPUT(IPOUT,'K-EFFECTI-SD',1,2,REAL(REKEFF)) + IF(IPRINT.GT.0) WRITE(6,100) (ISTATE(ITC),ITC=1,9) + RETURN +* + 100 FORMAT(/8H OPTIONS/8H -------/ + 1 7H NSRCK ,I8,34H (NUMBER OF HISTORIES PER CYCLE)/ + 2 7H IKZ ,I8,29H (NUMBER OF CYCLES TO SKIP)/ + 3 7H KCT ,I8,27H (TOTAL NUMBER OF CYCLES)/ + 4 7H ISEED ,I8,45H (INITIAL SEED FOR RANDOM NUMBER GENERATOR)/ + 5 7H IN2N ,I8,24H (N2N PROCESSING FLAG)/ + 6 7H ITALLY,I8,20H (TYPE OF TALLIES)/ + 7 7H NMERGE,I8,44H (NUMBER OF HOMOGENIZED MIXTURES IN TALLY)/ + 8 7H NGCOND,I8,40H (NUMBER OF CONDENSED GROUPS IN TALLY)/ + 9 7H NREG ,I8,34H (NUMBER OF REGIONS IN GEOMETRY)) + END diff --git a/Dragon/src/MCTALLY.f b/Dragon/src/MCTALLY.f new file mode 100644 index 0000000..4edf6d6 --- /dev/null +++ b/Dragon/src/MCTALLY.f @@ -0,0 +1,131 @@ +*DECK MCTALLY + SUBROUTINE MCTALLY(ITALLY,NFREG,NMIX,NGRP,NL,NFM,NDEL,NED,NBSCO, + 1 NMERGE,NGCOND,IREG,IGR,NU,MATCOD,IMERGE,INDGRP,XSM,XST,XSS, + 2 XSN2N,XSN3N,XSSNN,XSNUSI,XSCHI,XSEDI,SCORE1,SCORE2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Score for effective multiplication factor and macrolib information. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ITALLY type of tally (=1 score effective multiplication factor; +* =2 also score macrolib information). +* NFREG number of regions. +* NMIX number of material mixtures. +* NGRP number of energy groups. +* NL number of Legendre orders required in the estimations +* (NL=1 or higher). +* NFM number of fissile isotopes. +* NDEL number of delayed precursor groups. +* NED number of extra edit vectors. +* NBSCO number of macrolib-related scores. +* NMERGE number of homogenized regions. +* NGCOND number of condensed energy groups. +* IREG index of the region where the particle is located. +* IGR index of the energy group of the particle. +* NU particle weight. +* MATCOD region material. +* IMERGE homogenized regions indices. +* INDGRP condensed groups indices. +* XSM maximum macroscopic total cross section. +* XST total macroscopic cross sections for each mixture and energy +* group. +* XSS total scattering cross sections for each mixture and energy +* group. +* XSN2N N2N macroscopic cross sections for each mixture and energy +* group. +* XSN3N N3N macroscopic cross sections for each mixture and energy +* group. +* XSSNN in-group and out-of-group macroscopic transfert cross sections +* for each mixture. +* XSNUSI the values of Nu time the fission cross sections for each +* isotope per mixture and energy group. +* XSCHI fission spectrum for isotopes per mixture and energy group. +* XSEDI extra edit cross sections for each mixture and energy group. +* +*Parameters: input/output +* SCORE1 score for total flux and effective multiplication factor. +* SCORE2 macrolib score matrix. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ITALLY,NFREG,NMIX,NGRP,NL,NFM,NDEL,NED,NBSCO,NMERGE, + 1 NGCOND,IREG,IGR,MATCOD(NFREG),IMERGE(NFREG),INDGRP(NGRP) + REAL NU,XSM,XST(NMIX,NGRP),XSS(NMIX,NGRP,NL),XSN2N(NMIX,NGRP), + 1 XSN3N(NMIX,NGRP),XSSNN(NMIX,NGRP,NGRP,NL), + 2 XSNUSI(NMIX,NFM,NGRP,1+NDEL),XSCHI(NMIX,NFM,NGRP,1+NDEL), + 3 XSEDI(NMIX,NGRP,NED),SCORE1(3),SCORE2(NBSCO,NMERGE,NGCOND) +*---- +* LOCAL VARIABLES +*---- + INTEGER IBM,IFM,IED,JGR,IBMCD,IGRCD,JGRCD,IOF,IL,IDEL + REAL WW +* + WW=NU/XSM + IF(IREG.GT.0) THEN + SCORE1(1)=SCORE1(1)+WW + IBM=MATCOD(IREG) + IF(IBM.GT.0) THEN + DO IFM=1,NFM + SCORE1(2)=SCORE1(2)+WW*XSNUSI(IBM,IFM,IGR,1) + ENDDO + SCORE1(3)=SCORE1(3)+WW*(XST(IBM,IGR)-XSS(IBM,IGR,1)-2.0* + 1 XSN2N(IBM,IGR)-3.0*XSN3N(IBM,IGR)) + ENDIF + IF(ITALLY.EQ.2) THEN + IBMCD=IMERGE(IREG) + IF(IBMCD.EQ.0) GO TO 10 + IGRCD=INDGRP(IGR) + IF(IGRCD.EQ.0) GO TO 10 + SCORE2(1,IBMCD,IGRCD)=SCORE2(1,IBMCD,IGRCD)+WW + IF(IBM.EQ.0) GO TO 10 + SCORE2(2,IBMCD,IGRCD)=SCORE2(2,IBMCD,IGRCD)+WW*XST(IBM,IGR) + SCORE2(3,IBMCD,IGRCD)=SCORE2(3,IBMCD,IGRCD)+WW*XSS(IBM,IGR,1) + SCORE2(4,IBMCD,IGRCD)=SCORE2(4,IBMCD,IGRCD)+WW*XSN2N(IBM,IGR) + SCORE2(5,IBMCD,IGRCD)=SCORE2(5,IBMCD,IGRCD)+WW*XSN3N(IBM,IGR) + IOF=5 + DO IL=1,NL + DO JGR=1,NGRP + JGRCD=INDGRP(JGR) + SCORE2(IOF+JGRCD,IBMCD,IGRCD)=SCORE2(IOF+JGRCD,IBMCD,IGRCD) + 1 +WW*XSSNN(IBM,JGR,IGR,IL) + ENDDO + IOF=IOF+NGCOND + ENDDO + DO IDEL=1,1+NDEL + DO IFM=1,NFM + SCORE2(IOF+IFM,IBMCD,IGRCD)=SCORE2(IOF+IFM,IBMCD,IGRCD)+ + 1 WW*XSNUSI(IBM,IFM,IGR,IDEL) + ENDDO + IOF=IOF+NFM + DO IFM=1,NFM + DO JGR=1,NGRP + JGRCD=INDGRP(JGR) + SCORE2(IOF+IFM,IBMCD,JGRCD)=SCORE2(IOF+IFM,IBMCD,JGRCD)+ + 1 WW*XSNUSI(IBM,IFM,IGR,IDEL)*XSCHI(IBM,IFM,JGR,IDEL) + ENDDO + ENDDO + IOF=IOF+NFM + ENDDO + DO IED=1,NED + SCORE2(IOF+IED,IBMCD,IGRCD)=SCORE2(IOF+IED,IBMCD,IGRCD)+WW* + 1 XSEDI(IBM,IGR,IED) + ENDDO + ENDIF + ENDIF + 10 RETURN + END diff --git a/Dragon/src/MCTCCC.f b/Dragon/src/MCTCCC.f new file mode 100644 index 0000000..62dd8a9 --- /dev/null +++ b/Dragon/src/MCTCCC.f @@ -0,0 +1,125 @@ +*DECK MCTCCC + SUBROUTINE MCTCCC(NDIM,ITRN,CELLPO,ODIR,POS,ODIRC,POSC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Change global coordinates to turned cell coordinates +* (adapted from NXTRTL.f). +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* NDIM dimensions of problem. +* ITRN geometry original turn number. +* CELLPO cell global coordinates. +* ODIR search (octant) direction in global geometry. +* POS global coordinates. +* +*Parameters: output +* POSC final coordinates. +* ODIRC search (octant) direction in cell. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NDIM,ITRN,ODIR(3),ODIRC(3) + DOUBLE PRECISION CELLPO(3,2),POS(3),POSC(3) +*---- +* LOCAL VARIABLES +*---- + INTEGER IDIR,IKT + DOUBLE PRECISION POSO(3) +*---- +* CHANGE COORDINATES TO LOCAL CELL COORDINATES (ORIGIN=CELL CENTER) +*---- + DO IDIR=1,NDIM + POSO(IDIR)=POS(IDIR) + 1 -0.5D0*(CELLPO(IDIR,1)+CELLPO(IDIR,2)) + ENDDO +*---- +* CHANGE COORDINATES ACCORDING TO TURN +*---- +* Z AXIS REFLECTION FOR 3-D GEOMETRY + IKT=ITRN + IF(NDIM .EQ. 3) THEN + IF(ITRN .GT. 12 ) THEN + IKT=IKT-12 + POSC(NDIM)=-POSO(NDIM) + ODIRC(NDIM)=-ODIR(NDIM) + ELSE + POSC(NDIM)=POSO(NDIM) + ODIRC(NDIM)=ODIR(NDIM) + ENDIF + ENDIF + IF(IKT .EQ. 1) THEN +* NO TURN IN X-Y PLANE + DO IDIR=1,2 + POSC(IDIR)=POSO(IDIR) + ODIRC(IDIR)=ODIR(IDIR) + ENDDO + ELSE IF(IKT .EQ. 2) THEN +* ROTATION OF -PI/2 OF GEOMETRY IMPLIES A ROTATION +* OF PI/2 OF LINE. + POSC(1)=-POSO(2) + POSC(2)= POSO(1) + ODIRC(1)=-ODIR(2) + ODIRC(2)= ODIR(1) + ELSE IF(IKT .EQ. 3) THEN +* ROTATION OF PI OF GEOMETRY IMPLIES A ROTATION +* OF -PI OF LINE. + POSC(1)=-POSO(1) + POSC(2)=-POSO(2) + ODIRC(1)=-ODIR(1) + ODIRC(2)=-ODIR(2) + ELSE IF(IKT .EQ. 4) THEN +* ROTATION OF -3*PI/2 OF GEOMETRY IMPLIES A ROTATION +* OF 3PI/2 OF LINE. + POSC(1)= POSO(2) + POSC(2)=-POSO(1) + ODIRC(1)= ODIR(2) + ODIRC(2)=-ODIR(1) + ELSE IF(IKT .EQ. 5) THEN +* REFLECTION WITH RESPECT TO AXIS // TO Y + POSC(1)=-POSO(1) + POSC(2)= POSO(2) + ODIRC(1)=-ODIR(1) + ODIRC(2)= ODIR(2) + ELSE IF(IKT .EQ. 6) THEN +* ROTATION OF PI/2 FOLLOWED BY +* REFLECTION WITH RESPECT TO AXIS // TO Y +* IMPLIES REFLECTION WITH RESPECT TO AXIS // TO Y +* FOLLOWED BY A ROTATION OF -PI/2 OF LINE. + POSC(1)= POSO(2) + POSC(2)= POSO(1) + ODIRC(1)= ODIR(2) + ODIRC(2)= ODIR(1) + ELSE IF(IKT .EQ. 7) THEN +* REFLECTION WITH RESPECT TO AXIS // TO X + POSC(1)= POSO(1) + POSC(2)=-POSO(2) + ODIRC(1)= ODIR(1) + ODIRC(2)=-ODIR(2) + ELSE IF(IKT .EQ. 8) THEN +* ROTATION OF PI/2 FOLLOWED BY +* REFLECTION WITH RESPECT TO AXIS // TO X +* IMPLIES REFLECTION WITH RESPECT TO AXIS // TO X +* FOLLOWED BY A ROTATION OF -PI/2 OF LINE. + POSC(1)=-POSO(2) + POSC(2)=-POSO(1) + ODIRC(1)=-ODIR(2) + ODIRC(2)=-ODIR(1) + ENDIF +* + RETURN + END diff --git a/Dragon/src/MCTCTR.f b/Dragon/src/MCTCTR.f new file mode 100644 index 0000000..278c70f --- /dev/null +++ b/Dragon/src/MCTCTR.f @@ -0,0 +1,233 @@ +*DECK MCTCTR + SUBROUTINE MCTCTR(IPTRK,IPRINT,NDIM,MAXMSH,NUCELL,MXGSUR,MXGREG, + 1 MAXPIN,IUNFLD,DGMESH,NBIND,ODIR,POS,IREG,INDX, + 2 IDIRC,MESHC,NSURC,NREGC,NTPIN,CELLPO,PINCEN, + 3 INDEX,IDREG,DCMESH,ITPIN,DRAPIN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find region index from global coordinates of a point within the +* geometry. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure. +* IPRINT print level. +* NDIM problem dimensions. +* MAXMSH maximum number of elements in MESH array. +* NUCELL number of cell after unfolding in $X$, $Y$ and +* $Z$ directions. +* MXGSUR maximum number of surfaces for any geometry. +* MXGREG maximum number of region for any geometry. +* MAXPIN maximum number of pins in a cell. +* IUNFLD description of unfolded geometry. +* DGMESH meshing vector for global geometry. +* NBIND first dimension of INDX. +* ODIR search (octant) direction. +* POS spatial coordinates of the point to locate. +* +*Parameters: input/output +* IREG region index. +* INDX position index in the geometry structure. +* +*Parameters: scratch +* IDIRC undefined. +* MESHC undefined. +* NSURC undefined. +* NREGC undefined. +* NTPIN undefined. +* CELLPO undefined. +* PINCEN undefined. +* INDEX undefined. +* IDREG undefined. +* DCMESH undefined. +* ITPIN undefined. +* DRAPIN undefined. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER IPRINT,NDIM,MAXMSH,NUCELL(3),MXGSUR,MXGREG,MAXPIN, + 1 IUNFLD(2,NUCELL(1),NUCELL(2),NUCELL(3)),NBIND,ODIR(3),IREG, + 2 INDX(NBIND,0:2),IDIRC(2),MESHC(4,2),NSURC(2),NREGC(2),NTPIN, + 3 INDEX(5,-MXGSUR:MXGREG,2),IDREG(MXGREG,2),ITPIN(3,MAXPIN) + DOUBLE PRECISION DGMESH(-1:MAXMSH,4),POS(3),CELLPO(3,2),PINCEN(3), + 1 DCMESH(-1:MAXMSH,4,2),DRAPIN(-1:4,MAXPIN) +*---- +* LOCAL VARIABLES +*---- + INTEGER JJ,ICELO,ICEL,ITRNO,ITRN,ILEV,ODIRC(3),IDG1,IDG2,IDIR + DOUBLE PRECISION POSC(4) + CHARACTER NAMCEL*9,NAMREC*12 + LOGICAL INPIN + INTEGER INDOS(2,3) + CHARACTER RIDNAM*3 + PARAMETER (RIDNAM='RIC') + DATA INDOS / 2,3, + 1 3,1, + 2 1,2 / +*---- +* FIND LOCATION WITHIN THE GLOBAL ASSEMBLY (level 0) +*---- + ICELO=INDX(5,0) + ITRNO=INDX(6,0) + DO IDIR=1,NDIM + IF (ODIR(IDIR).EQ.1) THEN + INDX(IDIR,0)=1 + DO WHILE (POS(IDIR).GT.DGMESH(INDX(IDIR,0),IDIR)) + INDX(IDIR,0)=INDX(IDIR,0)+1 + ENDDO + ELSE + INDX(IDIR,0)=NUCELL(IDIR)-1 + DO WHILE (POS(IDIR).LE.DGMESH(INDX(IDIR,0),IDIR)) + INDX(IDIR,0)=INDX(IDIR,0)-1 + ENDDO + INDX(IDIR,0)=INDX(IDIR,0)+1 + ENDIF + ENDDO + DO IDIR=NDIM+1,3 + INDX(IDIR,0)=1 + ENDDO + ICEL=IUNFLD(1,INDX(1,0),INDX(2,0),INDX(3,0)) + ITRN=IUNFLD(2,INDX(1,0),INDX(2,0),INDX(3,0)) + INDX(5,0)=ICEL + INDX(6,0)=ITRN + IF (IPRINT.GT.4) THEN + WRITE(6,*) '**** FIND REGION WITHIN THE GEOMETRY ****' + IF (IPRINT.GT.5) THEN + WRITE(6,*) '0 - GLOBAL MESH:' + WRITE(6,'(3(I3,1X,1H(,F8.6,1H<,F8.6,1H<,F8.6,1H),2X))') + 1 (INDX(JJ,0),DGMESH(INDX(JJ,0)-1,JJ),POS(JJ), + 2 DGMESH(INDX(JJ,0),JJ),JJ=1,NDIM) + ENDIF + WRITE(6,*) 'CELL:',ICEL,' ROTATION:',ITRN + ENDIF +*---- +* ENTER THE CORRESPONDING CELL GEOMETRY +*---- + ILEV=1 + IF (ICEL.EQ.ICELO) THEN + IF (INDX(7,ILEV).LE.0) THEN + WRITE(NAMCEL,'(A1,I8.8)') 'C',ICEL + NAMREC=NAMCEL//RIDNAM + CALL LCMGET(IPTRK,NAMREC,IDREG(1,ILEV)) + ENDIF + IF (ITRN.NE.ITRNO) THEN + CELLPO(1,2)=DGMESH(INDX(1,0),1) + CELLPO(1,1)=DGMESH(INDX(1,0)-1,1) + CELLPO(2,2)=DGMESH(INDX(2,0),2) + CELLPO(2,1)=DGMESH(INDX(2,0)-1,2) + IF(NDIM.EQ.3) THEN + CELLPO(3,2)=DGMESH(INDX(3,0),3) + CELLPO(3,1)=DGMESH(INDX(3,0)-1,3) + ENDIF + ENDIF + ELSE + CALL MCTLDC(IPTRK,IPRINT,NDIM,MAXMSH,MXGSUR,MXGREG,NBIND,ICEL, + 1 INDX(1,0),RIDNAM,DGMESH,IDIRC(ILEV),MESHC(1,ILEV), + 2 NSURC(ILEV),NREGC(ILEV),NTPIN,CELLPO,DCMESH(-1,1,ILEV), + 3 INDEX(1,-MXGSUR,ILEV),ITPIN,DRAPIN,IDREG(1,ILEV)) + ENDIF +*---- +* AFTER THE CALL TO MCTCCC THE COORDINATES ARE IN TERMS OF CELL COORDINATES +*---- + CALL MCTCCC(NDIM,ITRN,CELLPO,ODIR,POS,ODIRC,POSC) +*---- +* FIND IF IT IS WITHIN A PIN +*---- + IF (NTPIN.GT.0) THEN + CALL MCTPIR(IPTRK,IPRINT,NDIM,MAXMSH,MXGSUR,MXGREG,NTPIN, + 1 NBIND,INDX(1,1),ITPIN,DRAPIN,DCMESH,MESHC(1,2),NSURC(2), + 2 NREGC(2),PINCEN,INDEX(1,-MXGSUR,2),IDREG(1,2),POSC, + 3 IDIRC(2),INPIN) + ELSE + INPIN=.FALSE. + ENDIF +*---- +* FIND LOCATION WITHIN CELL OR PIN +*---- + IF (INPIN) ILEV=2 +* Find location in Cartesian mesh + DO IDIR=1,NDIM + JJ=1 + DO WHILE (POSC(IDIR).GT.DCMESH(JJ,IDIR,ILEV)) + JJ=JJ+1 + ENDDO + INDX(IDIR,ILEV)=JJ + ENDDO + DO IDIR=NDIM+1,3 + INDX(IDIR,ILEV)=1 + ENDDO + IF (IDIRC(ILEV).GT.0) THEN +* Find location in cylindrical mesh + IF (ILEV.EQ.1) THEN +* calculate distance to the cell center +* (already calculated for a pin in MCTPIR) + IDG1=INDOS(1,IDIRC(ILEV)) + IDG2=INDOS(2,IDIRC(ILEV)) + POSC(4)=((POSC(IDG1)-DCMESH(-1,IDG1,ILEV))**2 + 1 +(POSC(IDG2)-DCMESH(-1,IDG2,ILEV))**2) + POSC(4)=SQRT(POSC(4)) + ENDIF + JJ=MESHC(4,ILEV) + IF (POSC(4).GT.DCMESH(JJ,4,ILEV)) THEN + INDX(4,ILEV)=0 + ELSE + JJ=JJ-1 + DO WHILE(POSC(4).LT.DCMESH(JJ,4,ILEV)) + JJ=JJ-1 + ENDDO + INDX(4,ILEV)=JJ+1 + ENDIF + ELSE + INDX(4,ILEV)=0 + ENDIF + IF (IPRINT.GT.5) THEN + WRITE(6,*) ILEV,'- LOCAL MESH:' + WRITE(6,'(3(I3,1X,1H(,F8.6,1H<,F8.6,1H<,F8.6,1H),2X))') + 1 (INDX(JJ,ILEV),DCMESH(INDX(JJ,ILEV)-1,JJ,ILEV),POSC(JJ), + 2 DCMESH(INDX(JJ,ILEV),JJ,ILEV),JJ=1,NDIM) + ENDIF +* Find location of this element in the index + IREG=1 + DO WHILE ((INDX(1,ILEV).NE.INDEX(1,IREG,ILEV)).OR. + 1 (INDX(2,ILEV).NE.INDEX(2,IREG,ILEV)).OR. + 2 (INDX(3,ILEV).NE.INDEX(3,IREG,ILEV)).OR. + 3 (INDX(4,ILEV).NE.INDEX(4,IREG,ILEV))) + IREG=IREG+1 + IF (IREG.GT.NREGC(ILEV)) THEN + WRITE(6,*) (INDX(JJ,ILEV),JJ=1,4) + CALL XABORT('MCTCTR: INDEXES DO NOT MATCH') + ENDIF + ENDDO +* + IREG=ABS(IDREG(IREG,ILEV)) + DO JJ=1,2 + INDX(7,JJ)=0 + ENDDO + INDX(7,ILEV)=IREG + IF (IPRINT.GT.4) THEN + WRITE(6,*) 'REGION:',IREG + WRITE(6,*) '*** FOUND REGION WITHIN THE GEOMETRY ***' + ENDIF + IF (IREG.LE.0) THEN + WRITE(6,*) INDX(1,ILEV),INDX(2,ILEV),INDX(3,ILEV),INDX(4,ILEV) + CALL XABORT('MCTCTR: INVALID REGION FOUND.') + ENDIF +* + RETURN + END diff --git a/Dragon/src/MCTFLX.f b/Dragon/src/MCTFLX.f new file mode 100644 index 0000000..5c19295 --- /dev/null +++ b/Dragon/src/MCTFLX.f @@ -0,0 +1,437 @@ +*DECK MCTFLX + SUBROUTINE MCTFLX(IPTRK,IPOUT,IPRINT,NMIX,NGRP,NL,NFM,NDEL,NED, + < NAMEAD,XSTOT,XSS,XSSNN,XSNUSI,XSCHI,XSN2N, + < XSN3N,XSEDI,NSRCK,IKZ,KCT,ISEED,XYZL,NBSCO, + < NMERGE,NGCOND,KEFF,REKEFF) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Power iteration with the Monte Carlo method in 1D/2D/3D Cartesian +* geometry. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): B. Arsenault +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure. +* IPOUT pointer to the MC data structure. +* IPRINT print flag. +* NMIX number of mixtures in the geometry. +* NGRP number of energy groups. +* NL number of Legendre orders required in the estimations +* (NL=1 or higher). +* NFM number of fissile isotopes. +* NDEL number of delayed precursor groups. +* NED number of extra edit vectors. +* NAMEAD names of these extra edits. +* XSTOT total macroscopic cross sections for each mixture and energy +* group. +* XSS total scattering cross sections for each mixture and energy +* group. +* XSSNN in-group and out-of-group macroscopic transfert cross sections +* for each mixture. +* XSNUSI the values of Nu time the fission cross sections for each +* isotope per mixture and energy group. +* XSCHI the values of fission spectrum per isotope per mixture for +* each energy group. +* XSN2N N2N macroscopic cross sections for each mixture and energy +* group. +* XSN3N N3N macroscopic cross sections for each mixture and energy +* group. +* XSEDI extra edit cross sections for each mixture and energy group. +* NSRCK number of neutrons generated per cycle. +* IKZ number of inactive cycles. +* KCT number of active cycles. +* ISEED the seed for the generation of random numbers. +* XYZL Cartesian boundary coordinates. +* NBSCO number of macrolib-related scores. +* NMERGE number of homogenized regions. +* NGCOND number of condensed energy groups. +* +*Parameters: output +* KEFF effective multiplication factor. +* REKEFF standard deviation on the effective multiplication factor. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPOUT + INTEGER IPRINT,NMIX,NGRP,NL,NFM,NDEL,NED,NAMEAD(2,NED),NSRCK,IKZ, + < KCT,ISEED,NBSCO,NMERGE,NGCOND + REAL XSTOT(NMIX,NGRP),XSS(NMIX,NGRP,NL),XSN2N(NMIX,NGRP), + < XSN3N(NMIX,NGRP),XSSNN(NGRP,NGRP,NMIX,NL), + < XSCHI(NMIX,NFM,NGRP,1+NDEL),XSNUSI(NMIX,NFM,NGRP,1+NDEL), + < XSEDI(NMIX,NGRP,NED) + DOUBLE PRECISION XYZL(2,3),KEFF,REKEFF + CHARACTER NAMREC*12 +*---- +* LOCAL VARIABLES +*---- + INTEGER NSTATE + PARAMETER(NSTATE=40) + INTEGER ICYCLE,ILOOP,NLOOP,IDIR,IFIRST,MIX,ISONBR,NFREG,NFSUR, + < ANGBC,NTRK,JJ,ITYPBC,ITRK,IDIRG,NBOCEL,NBUCEL,IDIAG, + < ISAXIS(3),NOCELL(3),NUCELL(3),ICODE(6),MXMSH,MAXREG, + < NBTCLS,MAXPIN,MAXMSP,MAXRSP,MXGSUR,MXGREG,NUNK,MAXMSH, + < NDIM,ESTATE(NSTATE),GSTATE(NSTATE),ITALLY,IND,IOF,IGR, + < ILON1,ILON2,ITYLCM,IBANK1,IBANK2 + REAL ALBEDO(6),RAND,NUCALL,NULIMIT,SCORE1(3),FACT1,FACT2 + LOGICAL LKEEP + DOUBLE PRECISION ABSC(3,2),POS(3),KCYCLE,WEIGHT,NU,SUM1,SUM2, + < ASCORE1(3),BSCORE1(3),DIT + CHARACTER HSMG*131 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: INMIX,IBCRT,IUNFLD,INDEX, + 1 IDREG,ITPIN,INDGRP,IMERGE,IGCR + REAL, ALLOCATABLE, DIMENSION(:) :: NUCYCLE + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCORE2 + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DGMESH,DCMESH, + 1 DRAPIN + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: ASCORE2,BSCORE2 + INTEGER, POINTER, DIMENSION(:,:) :: INGEN1,INGEN2,INGAR + DOUBLE PRECISION, POINTER, DIMENSION(:,:) :: DNGEN1,DNGEN2,DNGAR +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(SCORE2(NBSCO,NMERGE,NGCOND)) + ALLOCATE(ASCORE2(NBSCO,NMERGE,NGCOND), + < BSCORE2(NBSCO,NMERGE,NGCOND)) +*---- +* SET THE RANDOM NUMBER GENERATOR +*---- + IFIRST=1 + IF(ISEED.EQ.0) THEN + CALL CLETIM(DIT) + ISEED=INT(DIT) + DO JJ=0,MOD(ISEED,10) + CALL RANDF(ISEED,IFIRST,RAND) + ENDDO + ENDIF +*---- +* RECOVER SOME BASIC NXT GEOMETRY ANALYSIS INFO AND ALLOCATE RELATED +* MEMORY +*---- + GSTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,'STATE-VECTOR',GSTATE) + NFREG =GSTATE( 1) + NMIX =GSTATE( 4) + NFSUR =GSTATE( 5) + IF(GSTATE(7).NE.4) + 1 CALL XABORT('MCTFLX: ONLY NXT: GEOMETRY ANALYSIS IS PERMITTED') + ANGBC =ABS(GSTATE(10)) +*---- +* READ THE MATERIAL NUMBER ASSOCIATED TO EACH REGION NUMBER +*---- + ALLOCATE(INMIX(NFREG),IBCRT(NFSUR)) + CALL LCMGET(IPTRK,'MATCOD',INMIX) + CALL LCMGET(IPTRK,'BC-REFL+TRAN',IBCRT) + CALL LCMGET(IPTRK,'ALBEDO',ALBEDO) + CALL LCMGET(IPTRK,'ICODE',ICODE) + CALL LCMSIX(IPTRK,'NXTRecords',1) + ESTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,'G00000001DIM',ESTATE) + NDIM =ESTATE( 1) + ITYPBC =ESTATE( 2) + IDIRG =ESTATE( 3) + NBOCEL =ESTATE( 4) + NBUCEL =ESTATE( 5) + IDIAG =ESTATE( 6) + ISAXIS(1)=ESTATE( 7) + ISAXIS(2)=ESTATE( 8) + ISAXIS(3)=ESTATE( 9) + NOCELL(1)=ESTATE(10) + NOCELL(2)=ESTATE(11) + NOCELL(3)=ESTATE(12) + NUCELL(1)=ESTATE(13) + NUCELL(2)=ESTATE(14) + NUCELL(3)=ESTATE(15) + MXMSH =ESTATE(16) + MAXREG =ESTATE(17) + NBTCLS =ESTATE(18) + MAXPIN =ESTATE(19) + MAXMSP =ESTATE(20) + MAXRSP =ESTATE(21) + IF(NFSUR.NE.ESTATE(22)) + 1 CALL XABORT('MCTFLX: INCONSISTENT NUMBER OF OUTER SURFACES') + IF(NFREG.NE.ESTATE(23)) + 1 CALL XABORT('MCTFLX: INCONSISTENT NUMBER OF REGIONS') + MXGSUR =ESTATE(24) + MXGREG =ESTATE(25) + NUNK=NFSUR+NFREG+1 + MAXMSH=MAX(MXMSH,MAXMSP,MAXREG) +* cell index and orientation for the cells filling the geometry + ALLOCATE(IUNFLD(2*NBUCEL)) + NAMREC='G00000001CUF' + CALL LCMGET(IPTRK,NAMREC,IUNFLD) +* global mesh for geometry + ALLOCATE(DGMESH((MAXMSH+2)*4)) + DGMESH(:(MAXMSH+2)*4)=0.0D0 +* +* An offset of 2 has been used to be compatible with the definition +* of the pin geometries where the first two values give the offset +* of the pin. With a Cartesian geometry the array doesn't contain +* the offests. + CALL NXTXYZ(IPTRK,IPRINT,NDIM,ITYPBC,MAXMSH,NUCELL,ABSC,DGMESH) + DO IDIR=1,NDIM + XYZL(1,IDIR)=ABSC(IDIR,2)-ABSC(IDIR,1) + XYZL(2,IDIR)=ABSC(IDIR,2) + ENDDO + ALLOCATE(INDEX(2*5*(MXGSUR+MXGREG+1)),IDREG(2*MXGREG), + 1 ITPIN(3*(MAXPIN+1))) + ALLOCATE(DCMESH(2*4*(MAXMSH+2)),DRAPIN(6*(MAXPIN+1))) +*---- +* TALLY INITIALIZATION +*---- + CALL LCMGET(IPOUT,'STATE-VECTOR',GSTATE) + ITALLY=GSTATE(6) + IF(ITALLY.EQ.2) THEN + ALLOCATE(INDGRP(NGRP)) + INDGRP(:NGRP)=0 + CALL LCMLEN(IPOUT,'REF:IMERGE',ILON1,ITYLCM) + CALL LCMLEN(IPOUT,'REF:IGCOND',ILON2,ITYLCM) + ALLOCATE(IMERGE(ILON1),IGCR(ILON2)) + CALL LCMGET(IPOUT,'REF:IMERGE',IMERGE) + CALL LCMGET(IPOUT,'REF:IGCOND',IGCR) + IOF=1 + JJ=IGCR(1) + DO IND=1,NGRP + IF(IND.GT.JJ) THEN + IOF=IOF+1 + IF(IOF.GT.NGCOND) CALL XABORT('MCTFLX: NGCOND OVERFLOW.') + JJ=IGCR(IOF) + ENDIF + INDGRP(IND)=IOF + ENDDO + ENDIF +*---- +* MEMORY ALLOCATION FOR THE POWER ITERATION +*---- + ALLOCATE(INGEN1(2,2*NSRCK),DNGEN1(4,2*NSRCK)) + ALLOCATE(INGEN2(2,2*NSRCK),DNGEN2(4,2*NSRCK)) + ALLOCATE(NUCYCLE(2*NSRCK)) + INGEN1(:2,:2*NSRCK)=0 + DNGEN1(:4,:2*NSRCK)=0.0 + INGEN2(:2,:2*NSRCK)=0 + DNGEN2(:4,:2*NSRCK)=0.0 +*---- +* UNIFORM INITIAL ESTIMATE OF SOURCE NEUTRONS +*---- + DO ILOOP=1,NSRCK + DO IDIR=1,NDIM + CALL RANDF(ISEED,IFIRST,RAND) + POS(IDIR)=RAND*(XYZL(2,IDIR)-XYZL(1,IDIR))+XYZL(1,IDIR) + ENDDO + INGEN1(1,ILOOP) = -1 + INGEN1(2,ILOOP) = -1 + DNGEN1(1,ILOOP) = 1.0D0 + DNGEN1(2,ILOOP) = POS(1) + DNGEN1(3,ILOOP) = POS(2) + DNGEN1(4,ILOOP) = POS(3) + ENDDO + IBANK1=NSRCK +*---- +* POWER ITERATION +*---- + KCYCLE=1.D0 + SUM1=0.0D0 + SUM2=0.0D0 + IF(ITALLY.GT.0) THEN + ASCORE1(:3)=0.0D0 + BSCORE1(:3)=0.0D0 + IF(ITALLY.EQ.2) THEN + ASCORE2(:NBSCO,:NMERGE,:NGCOND)=0.0D0 + BSCORE2(:NBSCO,:NMERGE,:NGCOND)=0.0D0 + ENDIF + ENDIF + DO ICYCLE=1,KCT + IBANK2=0 + SCORE1(:3)=0.0 + SCORE2(:NBSCO,:NMERGE,:NGCOND)=0.0 + WEIGHT=KCYCLE + KCYCLE=0.D0 + DO NTRK=1,IBANK1 + NU = DNGEN1(1,NTRK) + NLOOP=MAX(1,INT(NU/WEIGHT)) + DNGEN1(1,NTRK)=NU/(DBLE(NLOOP)*WEIGHT) + DO ILOOP=1,NLOOP +*---- +* TRACK EACH NEUTRON INDIVIDUALLY +*---- + MIX = INGEN1(1,NTRK) + ISONBR = INGEN1(2,NTRK) + NUCALL = REAL(DNGEN1(1,NTRK)) + POS(1) = DNGEN1(2,NTRK) + POS(2) = DNGEN1(3,NTRK) + POS(3) = DNGEN1(4,NTRK) + CALL MCTRK(IPTRK,IPRINT,NFREG,NFSUR,NDIM,NMIX,ANGBC,ITYPBC, + 1 MAXMSH,NUCELL,MXGSUR,MXGREG,MAXPIN,IBCRT,ICODE,ALBEDO, + 2 IUNFLD,DGMESH,XYZL,INDEX,IDREG,DCMESH,ITPIN,DRAPIN,ISEED, + 3 NGRP,NL,NFM,NDEL,NED,INMIX,XSTOT,XSS,XSN2N,XSN3N,XSSNN, + 4 XSNUSI,XSCHI,XSEDI,MIX,ISONBR,NUCALL,POS,ITALLY,NBSCO, + 5 NMERGE,NGCOND,IMERGE,INDGRP,SCORE1,SCORE2) + IF(ISONBR.GT.0) THEN + IBANK2=IBANK2+1 + IF(IBANK2.GT.2*NSRCK) THEN + CALL XABORT('MCTFLX: TOO MANY NEUTRON TRACKS BEING'// + 1 ' BANKED.') + ENDIF + INGEN2(1,IBANK2) = MIX + INGEN2(2,IBANK2) = ISONBR + DNGEN2(1,IBANK2) = NUCALL + DNGEN2(2,IBANK2) = POS(1) + DNGEN2(3,IBANK2) = POS(2) + DNGEN2(4,IBANK2) = POS(3) + NUCYCLE(IBANK2) = NUCALL + KCYCLE=KCYCLE+NUCALL + ENDIF + ENDDO +* END OF THE NTRK CYCLE + ENDDO + KCYCLE=KCYCLE/DBLE(NSRCK) +*---- +* RUSSIAN ROULETTE +*---- + IF(IBANK2.GT.NSRCK) THEN + CALL SORTRE(IBANK2,NUCYCLE) + NULIMIT=NUCYCLE(IBANK2-NSRCK+1) + IBANK1=0 + DO ITRK=1,IBANK2 + MIX = INGEN2(1,ITRK) + ISONBR = INGEN2(2,ITRK) + NUCALL = REAL(DNGEN2(1,ITRK)) + POS(1) = DNGEN2(2,ITRK) + POS(2) = DNGEN2(3,ITRK) + POS(3) = DNGEN2(4,ITRK) + LKEEP=(NUCALL.GE.NULIMIT) + IF(.NOT.LKEEP) THEN + CALL RANDF(ISEED,IFIRST,RAND) + LKEEP=RAND.LE.(NUCALL/NULIMIT) + NUCALL=NULIMIT + ENDIF + IF(LKEEP) THEN + IBANK1=IBANK1+1 + INGEN1(1,IBANK1) = MIX + INGEN1(2,IBANK1) = ISONBR + DNGEN1(1,IBANK1) = NUCALL + DNGEN1(2,IBANK1) = POS(1) + DNGEN1(3,IBANK1) = POS(2) + DNGEN1(4,IBANK1) = POS(3) + ENDIF + ENDDO + ELSE + IBANK1 = IBANK2 + INGAR => INGEN2 + INGEN2 => INGEN1 + INGEN1 => INGAR + DNGAR => DNGEN2 + DNGEN2 => DNGEN1 + DNGEN1 => DNGAR + ENDIF +*---- +* K-EFFECTIVE OF THE PROBLEM WITH THE RELATIVE ERROR +*---- + IF(ICYCLE.GT.IKZ) THEN + SUM1=SUM1+KCYCLE + SUM2=SUM2+KCYCLE**2 + IF(ITALLY.GT.0) THEN + DO IND=1,3 + ASCORE1(IND)=ASCORE1(IND)+SCORE1(IND) + BSCORE1(IND)=BSCORE1(IND)+SCORE1(IND)**2 + ENDDO + IF(ITALLY.EQ.2) THEN + DO IND=1,NBSCO + DO MIX=1,NMERGE + DO IGR=1,NGCOND + ASCORE2(IND,MIX,IGR)=ASCORE2(IND,MIX,IGR)+ + 1 SCORE2(IND,MIX,IGR) + BSCORE2(IND,MIX,IGR)=BSCORE2(IND,MIX,IGR)+ + 1 SCORE2(IND,MIX,IGR)**2 + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + ENDIF + IF(IPRINT.GT.0) WRITE(6,1000) ICYCLE,KCYCLE + ENDDO + FACT1=REAL(KCT-IKZ) + FACT2=REAL(KCT-IKZ-1) + KEFF=SUM1/FACT1 + REKEFF=SQRT((SUM2-FACT1*KEFF**2)/FACT1/FACT2) + WRITE(6,2000) KCT,KCYCLE,KEFF,REKEFF + IF(ITALLY.GT.0) THEN + DO IND=1,3 + ASCORE1(IND)=ASCORE1(IND)/FACT1 + BSCORE1(IND)=SQRT((BSCORE1(IND)-FACT1*ASCORE1(IND)**2)/FACT1/ + 1 FACT2) + ENDDO + KEFF=ASCORE1(2)/ASCORE1(3) + REKEFF=KEFF*(BSCORE1(2)/ASCORE1(2)-BSCORE1(3)/ASCORE1(3)) + WRITE(6,3000) KEFF,REKEFF + ENDIF + IF(ITALLY.EQ.2) THEN + DO IND=1,NBSCO + DO MIX=1,NMERGE + DO IGR=1,NGCOND +*---- +* CHECK FIRST FOR 0-TALLIES IN TOTAL CROSS-SECTIONS PER MIXTURE +*---- + IF(ASCORE2(1,MIX,IGR).EQ.0.0D0) THEN + WRITE(HSMG,'(28HMCPTFLX: ZERO TALLY FOR MIX ,I5, + 1 10H IN GROUP ,I5,28H. INCREASE KCODE PARAMETERS.)') + 2 MIX,IGR + CALL XABORT(HSMG) + ENDIF + ASCORE2(IND,MIX,IGR)=ASCORE2(IND,MIX,IGR)/FACT1 + BSCORE2(IND,MIX,IGR)=SQRT((BSCORE2(IND,MIX,IGR)-FACT1* + 1 ASCORE2(IND,MIX,IGR)**2)/FACT1/FACT2) + ENDDO + ENDDO + ENDDO + ENDIF +*---- +* RECONSTRUCT THE TALLY-GENERATED MACROLIB +*---- + IF(ITALLY.EQ.2) THEN + CALL MCTOUT(IPOUT,NL,NFM,NDEL,NED,NAMEAD,NBSCO,NMERGE,NGCOND, + 1 ASCORE1,ASCORE2) + DEALLOCATE(IGCR,IMERGE) + ENDIF +*---- +* DEALLOCATE MEMORY +*---- +* POWER ITERATION RELATED + DEALLOCATE(NUCYCLE,DNGEN2,INGEN2,DNGEN1,INGEN1) + IF(ITALLY.EQ.2) DEALLOCATE(INDGRP) +* +* TRACKING RELATED + CALL LCMSIX(IPTRK,' ',2) + DEALLOCATE(DRAPIN,ITPIN,DCMESH,IDREG,INDEX,DGMESH,IUNFLD,IBCRT, + 1 INMIX) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(BSCORE2,ASCORE2) + DEALLOCATE(SCORE2) + RETURN +* + 1000 FORMAT(' CYCLE NUMBER: ',I5,' K-EFFECTIVE CYCLE: ',F8.6) + 2000 FORMAT(/' CYCLE NUMBER: ',I5,' K-EFFECTIVE CYCLE: ',F8.6, + < ' K-EFFECTIVE AVERAGE: ',F8.6, + < ' SIGMA: ',F8.6) + 3000 FORMAT(/' VIRTUAL COLLISION ESTIMATION: K-EFFECTIVE AVERAGE: ', + < F8.6,' SIGMA: ',F8.6) + END diff --git a/Dragon/src/MCTGET.f b/Dragon/src/MCTGET.f new file mode 100644 index 0000000..8395744 --- /dev/null +++ b/Dragon/src/MCTGET.f @@ -0,0 +1,234 @@ +*DECK MCTGET + SUBROUTINE MCTGET(IPOUT,NGRP,NFREG,NBMIX,MATCOD,IPRINT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To read from the input file the MC: module input options. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): B. Arsenault +* +*Parameters: input +* IPOUT pointer to the MC: data structure. +* NGRP number of energy groups. +* NFREG number of regions. +* NBMIX maximum number of mixtures. +* MATCOD region material. +* +*Parameters: input/output +* IPRINT print parameter. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPOUT + INTEGER NSTATE,NGRP,NFREG,NBMIX,MATCOD(NFREG),IPRINT +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + INTEGER ISTATE(NSTATE),INDIC,NITMA,NMERGE,IREGIO,IMATER,NGCOND, + 1 IGROUP,JGROUP + REAL FLOTT + CHARACTER TEXT*12 + DOUBLE PRECISION DFLOTT +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IMERGE,MIXMER,IGCR +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IMERGE(NFREG),MIXMER(0:NBMIX),IGCR(NGRP)) +*---- +* READ INPUT +*---- + IPRINT=1 + ISTATE(:NSTATE)=0 + 10 CALL REDGET(INDIC,NITMA,FLOTT,TEXT,DFLOTT) + IF(INDIC.EQ.10) GO TO 200 + IF(INDIC.NE.3) CALL XABORT('MCTGET: CHARACTER DATA EXPECTED(1)') + IF(TEXT(1:4).EQ.'EDIT') THEN + CALL REDGET(INDIC,IPRINT,FLOTT,TEXT,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MCTGET: INTEGER DATA EXPECTED FOR' + < //' IPRINT') + ELSE IF(TEXT(1:5).EQ.'KCODE') THEN +* READ THE NSRCK PARAMETER + CALL REDGET(INDIC,ISTATE(1),FLOTT,TEXT,DFLOTT) + IF (INDIC.NE.1) CALL XABORT('MCTGET: INTEGER DATA EXPECTED FOR' + < //' NSRCK') +* READ THE IKZ PARAMETER + CALL REDGET(INDIC,ISTATE(2),FLOTT,TEXT,DFLOTT) + IF (INDIC.NE.1) CALL XABORT('MCTGET: INTEGER DATA EXPECTED FOR' + < //' IKZ') +* READ THE KCT PARAMETER + CALL REDGET(INDIC,ISTATE(3),FLOTT,TEXT,DFLOTT) + IF (INDIC.NE.1) CALL XABORT('MCTGET: INTEGER DATA EXPECTED FOR' + < //' KCT') + ELSE IF(TEXT(1:4).EQ.'SEED') THEN +* INPUT A SEED INTEGER + CALL REDGET(INDIC,ISTATE(4),FLOTT,TEXT,DFLOTT) + IF (INDIC.NE.1) CALL XABORT('MCTGET: INTEGER DATA EXPECTED FOR' + < //' SEED') + ELSE IF(TEXT(1:3).EQ.'N2N') THEN +* N2N CROSS SECTION RECOVERY FLAG + ISTATE(5)=1 + ELSE IF(TEXT(1:5).EQ.'TALLY') THEN +* DEFINE A TALLY + IF(ISTATE(6).NE.0) CALL XABORT('MCTGET: TALLY EXISTS') + ISTATE(6)=1 + NMERGE=0 + NGCOND=0 + 20 CALL REDGET(INDIC,NITMA,FLOTT,TEXT,DFLOTT) + 30 IF(INDIC.NE.3) CALL XABORT('MCTGET: CHARACTER DATA EXPECTED(2)') + IF(TEXT(:4).EQ.'MERG') THEN +*---- +* MERGING DIRECTIVE ANALYSIS +*---- + CALL REDGET(INDIC,NITMA,FLOTT,TEXT,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('MCTGET: CHARACTER DATA EXPECTED' + < //'(3)') + IF(TEXT.EQ.'COMP') THEN +*---- +* COMPLETE MERGE +*---- + IMERGE(:NFREG)=1 + NMERGE=1 + GO TO 20 + ELSE IF(TEXT.EQ.'MIX') THEN +*---- +* MERGE BY MIXTURES +*---- + DO 40 IMATER=0,NBMIX + MIXMER(IMATER)=IMATER + 40 CONTINUE + DO 50 IREGIO=1,NFREG + NMERGE=MAX(NMERGE,MATCOD(IREGIO)) + IMERGE(IREGIO)=MIXMER(MATCOD(IREGIO)) + 50 CONTINUE + NMERGE=NBMIX + CALL REDGET(INDIC,NITMA,FLOTT,TEXT,DFLOTT) + IF(INDIC.EQ.1) THEN +*---- +* SPECIFY MIXTURES TO BE MERGED +*---- + NMERGE=MAX(0,NITMA) + MIXMER(1)=NITMA + DO 60 IMATER=2,NBMIX + CALL REDGET(INDIC,NITMA,FLOTT,TEXT,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MCTGET: INTEGER DATA EXPEC' + < //'TED FOR IMIXM') + NMERGE=MAX(NMERGE,NITMA) + MIXMER(IMATER)=NITMA + 60 CONTINUE + DO 70 IREGIO=1,NFREG + IMERGE(IREGIO)=MIXMER(MATCOD(IREGIO)) + 70 CONTINUE + ELSE IF(INDIC.EQ.3) THEN +*---- +* ASSOCIATE ONE REGION BY MIXTURE +*---- + GO TO 30 + ELSE + CALL XABORT('MCTGET: READ ERROR - INVALID TYPE READ') + ENDIF + ELSE IF(TEXT.EQ.'REGI') THEN +*---- +* MERGE BY REGIONS +*---- + CALL REDGET(INDIC,NITMA,FLOTT,TEXT,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MCTGET: INTEGER DATA EXPEC' + < //'TED FOR IREGM') + NMERGE=MAX(0,NITMA) + IMERGE(1)=NITMA + DO 80 IREGIO=2,NFREG + CALL REDGET(INDIC,NITMA,FLOTT,TEXT,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MCTGET: INTEGER DATA EXPECTE' + < //'D FOR IREGM') + NMERGE=MAX(NMERGE,NITMA) + IMERGE(IREGIO)=NITMA + 80 CONTINUE + ELSE IF(TEXT.EQ.'NONE') THEN +*---- +* NO MERGING +*---- + NMERGE=NFREG + DO 90 IREGIO=1,NFREG + IMERGE(IREGIO)=IREGIO + 90 CONTINUE + ELSE + CALL XABORT('MCTGET: '//TEXT//' IS AN INVALID KEYWORD(1)') + ENDIF + ELSE IF(TEXT(:4).EQ.'COND') THEN +*---- +* GROUP CONDENSATION DIRECTIVE ANALYSIS +*---- + DO 110 IGROUP=1,NGRP+1 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT,DFLOTT) + IF(INDIC.EQ.3) THEN + IF(IGROUP.EQ.1) THEN + IF(TEXT.EQ.'NONE') THEN + NGCOND=NGRP + DO 100 JGROUP=1,NGRP + IGCR(JGROUP)=JGROUP + 100 CONTINUE + GO TO 20 + ELSE + NGCOND=1 + IGCR(NGCOND)=NGRP + ENDIF + ENDIF + IF(IGCR(NGCOND).NE.NGRP) THEN + NGCOND=NGCOND+1 + IGCR(NGCOND)=NGRP + ENDIF + GO TO 30 + ELSE IF(INDIC.EQ.1) THEN + IF(NITMA.GT.NGRP) NITMA=NGRP + IF(NGCOND.GT.0) THEN + IF(NITMA.GT.IGCR(NGCOND)) THEN + NGCOND=NGCOND+1 + IGCR(NGCOND)=NITMA + ENDIF + ELSE + NGCOND=NGCOND+1 + IGCR(NGCOND)=NITMA + ENDIF + ENDIF + 110 CONTINUE + ELSE IF(TEXT(:4).EQ.'ENDT') THEN + GO TO 120 + ELSE + CALL XABORT('MCTGET: '//TEXT//' IS AN INVALID KEYWORD(2)') + ENDIF + GO TO 20 + 120 CALL LCMPUT(IPOUT,'REF:IMERGE',NFREG,1,IMERGE) + CALL LCMPUT(IPOUT,'REF:IGCOND',NGCOND,1,IGCR) + IF((NMERGE.GT.0).AND.(NGCOND.GT.0)) ISTATE(6)=2 + ISTATE(7)=NMERGE + ISTATE(8)=NGCOND + ELSE IF(TEXT(1:1).EQ.';') THEN + GO TO 200 + ELSE + CALL XABORT('MCTGET: '//TEXT//' IS AN INVALID KEYWORD(3)') + ENDIF + GO TO 10 + 200 ISTATE(9)=NFREG + CALL LCMPUT(IPOUT,'STATE-VECTOR',NSTATE,1,ISTATE) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IGCR,MIXMER,IMERGE) + RETURN + END diff --git a/Dragon/src/MCTLDC.f b/Dragon/src/MCTLDC.f new file mode 100644 index 0000000..ef22df7 --- /dev/null +++ b/Dragon/src/MCTLDC.f @@ -0,0 +1,126 @@ +*DECK MCTLDC + SUBROUTINE MCTLDC(IPTRK,IPRINT,NDIM,MAXMSH,MXGSUR,MXGREG,NBIND, + 1 ICEL,INDX,ADDREC,DGMESH,IDIRC,MESHC,NSURC,NREGC,NTPIN, + 2 CELLPO,DCMESH,INDEX,ITPIN,DRAPIN,ID) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Load cell contents. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure. +* IPRINT print level. +* NDIM problem dimensions. +* MAXMSH maximum number of elements in MESH array. +* MXGSUR maximum number of surfaces for any geometry. +* MXGREG maximum number of region for any geometry. +* NBIND first dimension of INDX. +* ICEL requested cell index. +* INDX position index in the geometry structure. +* ADDREC name of additional requested record. +* DGMESH meshing vector for global geometry. +* +*Parameters: output +* IDIRC cylinders orientation. +* MESHC cell meshes size. +* NSURC number of surfaces for the cell. +* NREGC number of regions for the cell. +* NTPIN number of pins within the cell. +* CELLPO cell global coordinates. +* DCMESH cell meshing vector. +* INDEX cell index vector. +* ID additional requested record. +* ITPIN undefined. +* DRAPIN undefined. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER IPRINT,NDIM,MAXMSH,MXGSUR,MXGREG,NBIND,ICEL,INDX(NBIND), + 1 IDIRC,MESHC(4),NSURC,NREGC,NTPIN,INDEX(5,-MXGSUR:MXGREG), + 2 ITPIN(3,NTPIN),ID(MXGREG) + DOUBLE PRECISION DGMESH(-1:MAXMSH,4),CELLPO(3,2), + 1 DCMESH(-1:MAXMSH,4),DRAPIN(-1:4,NTPIN) + CHARACTER ADDREC*3 +*---- +* LOCAL VARIABLES +*---- + INTEGER NSTATE,IOUT + PARAMETER(NSTATE=40,IOUT=6) + INTEGER ESTATE(NSTATE) + INTEGER IDIR,ITYPG + CHARACTER NAMCEL*9,NAMREC*12 + CHARACTER CDIR(4)*1 + DATA CDIR /'X','Y','Z','R'/ +*---- +* LOAD CELL RECORDS +*---- + IF(IPRINT.GT.50) THEN + WRITE(6,'(/21H MCTLDC: PROCESS CELL,I6)') ICEL + ENDIF + WRITE(NAMCEL,'(A1,I8.8)') 'C',ICEL + NAMREC=NAMCEL//'DIM' + ESTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,NAMREC,ESTATE) + ITYPG=ESTATE(1) + MESHC(1)=ESTATE(3) + MESHC(2)=ESTATE(4) + MESHC(3)=ESTATE(5) + MESHC(4)=ESTATE(2) + NREGC=ESTATE(39)!8 + NSURC=ESTATE(40)!9 + NTPIN=ESTATE(18) + NAMREC=NAMCEL//ADDREC + CALL LCMGET(IPTRK,NAMREC,ID) + NAMREC=NAMCEL//'VSC' + CALL LCMGET(IPTRK,NAMREC,INDEX(1,-NSURC)) + DO IDIR=1,4 + NAMREC=NAMCEL//'SM'//CDIR(IDIR) + IF(MESHC(IDIR) .GT. 0) THEN + CALL LCMGET(IPTRK,NAMREC,DCMESH(-1,IDIR)) + ENDIF + ENDDO + IF(NTPIN .GT .0) THEN + NAMREC=NAMCEL//'PIN' + CALL LCMGET(IPTRK,NAMREC,DRAPIN) + NAMREC=NAMCEL//'PNT' + CALL LCMGET(IPTRK,NAMREC,ITPIN) + ENDIF + CELLPO(1,2)=DGMESH(INDX(1),1) + CELLPO(1,1)=DGMESH(INDX(1)-1,1) + CELLPO(2,2)=DGMESH(INDX(2),2) + CELLPO(2,1)=DGMESH(INDX(2)-1,2) + IF(NDIM .EQ. 3) THEN + CELLPO(3,2)=DGMESH(INDX(3),3) + CELLPO(3,1)=DGMESH(INDX(3)-1,3) + ENDIF + IF(ITYPG .EQ. 20 .OR. ITYPG .EQ. 21 .OR. + > ITYPG .EQ. 22 .OR. ITYPG .EQ. 23) THEN + IF(ITYPG .EQ. 21 ) THEN + IDIRC=1 + ELSE IF(ITYPG .EQ. 22) THEN + IDIRC=2 + ELSE + IDIRC=3 + ENDIF + ELSE + IDIRC=0 + ENDIF +* + RETURN + END diff --git a/Dragon/src/MCTLDP.f b/Dragon/src/MCTLDP.f new file mode 100644 index 0000000..7663726 --- /dev/null +++ b/Dragon/src/MCTLDP.f @@ -0,0 +1,86 @@ +*DECK MCTLDP + SUBROUTINE MCTLDP(IPTRK,IPRINT,MAXMSH,MXGSUR,MXGREG,ITPIN,ADDREC, + 1 MESHP,NSURP,NREGP,DPMESH,INDEX,ID) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Load pin contents. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure. +* IPRINT print level. +* MAXMSH maximum number of elements in MESH array. +* MXGSUR maximum number of surfaces for any geometry. +* MXGREG maximum number of region for any geometry. +* ITPIN pin index. +* ADDREC name of additional requested record. +* +*Parameters: output +* MESHP pin meshes size. +* NSURP number of surfaces for the pin. +* NREGP number of regions for the pin. +* DPMESH pin meshing vector. +* INDEX pin index vector. +* ID additional requested record. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER IPRINT,MAXMSH,MXGSUR,MXGREG,ITPIN,MESHP(4),NSURP,NREGP, + 1 INDEX(5,-MXGSUR:MXGREG),ID(MXGREG) + DOUBLE PRECISION DPMESH(-1:MAXMSH,4) + CHARACTER ADDREC*3 +*---- +* LOCAL VARIABLES +*---- + INTEGER NSTATE,IOUT + PARAMETER(NSTATE=40,IOUT=6) + INTEGER ESTATE(NSTATE) + INTEGER IDIR + CHARACTER NAMPIN*9,NAMREC*12 + CHARACTER CDIR(4)*1 + DATA CDIR /'X','Y','Z','R'/ +*---- +* LOAD PIN RECORDS +*---- + IF(IPRINT.GT.50) THEN + WRITE(6,'(/20H MCTLDP: PROCESS PIN,I6)') ITPIN + ENDIF + WRITE(NAMPIN,'(A1,I8.8)') 'P',ITPIN + NAMREC=NAMPIN//'DIM' + ESTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,NAMREC,ESTATE) + MESHP(1)=ESTATE(3) + MESHP(2)=ESTATE(4) + MESHP(3)=ESTATE(5) + MESHP(4)=ESTATE(2) + NREGP=ESTATE(39)!8 + NSURP=ESTATE(40)!9 + NAMREC=NAMPIN//ADDREC + CALL LCMGET(IPTRK,NAMREC,ID) + NAMREC=NAMPIN//'VSC' + CALL LCMGET(IPTRK,NAMREC,INDEX(1,-NSURP)) + DO IDIR=1,4 + NAMREC=NAMPIN//'SM'//CDIR(IDIR) + IF(MESHP(IDIR) .GT. 0) THEN + CALL LCMGET(IPTRK,NAMREC,DPMESH(-1,IDIR)) + ENDIF + ENDDO +* + RETURN + END diff --git a/Dragon/src/MCTLIB.f b/Dragon/src/MCTLIB.f new file mode 100644 index 0000000..661c6f6 --- /dev/null +++ b/Dragon/src/MCTLIB.f @@ -0,0 +1,204 @@ +*DECK MCTLIB + SUBROUTINE MCTLIB(IPLIB,NMIX,NGRP,NL,NFM,NDEL,NED,NAMEAD,LN2N, + < XSTOT,XSS,XSSNN,XSNUSI,XSCHI,XSN2N,XSN3N,XSEDI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover macroscopic cross-section information from the macrolib. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): B. Arsenault +* +*Parameters: input +* IPLIB pointer to the LIBRARY data structure. +* NMIX number of mixtures in the geometry. +* NGRP number of energy groups. +* NL number of Legendre orders required in the estimations +* (NL=1 or higher). +* NFM number of fissile isotopes. +* NDEL number of delayed precursor groups. +* NED number of extra edit vectors. +* NAMEAD names of these extra edits. +* LN2N N2N cross section recovery flag. +* +*Parameters: output +* XSTOT total macroscopic cross sections for each mixture and energy +* group. +* XSS total scattering cross sections for each mixture and energy +* group. +* XSSNN in-group and out-of-group macroscopic transfert cross sections +* for each mixture and energy group. +* XSNUSI the values of Nu time the fission cross sections for each +* isotope per mixture and energy group. +* XSCHI the values of fission spectrum per isotope per mixture for +* each energy group. +* XSN2N N2N macroscopic cross sections for each mixture and energy +* group. +* XSN3N N3N macroscopic cross sections for each mixture and energy +* group. +* XSEDI extra edit cross sections for each mixture and energy group. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + INTEGER NMIX,NGRP,NL,NFM,NDEL,NED,NAMEAD(2,NED) + LOGICAL LN2N + REAL XSTOT(NMIX,NGRP),XSS(NMIX,NGRP,NL),XSN2N(NMIX,NGRP), + < XSN3N(NMIX,NGRP),XSSNN(NMIX,NGRP,NGRP,NL), + < XSNUSI(NMIX,NFM,NGRP,1+NDEL),XSCHI(NMIX,NFM,NGRP,1+NDEL), + < XSEDI(NMIX,NGRP,NED) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPMC,KPMC + INTEGER IGROUP,JGROUP,IMAT,IED,IPOS,IEN0,IENBR,ILONG,ITYLCM, + < IMAX,IL,IDEL + DOUBLE PRECISION SUM + CHARACTER TEXT12*12,CM*2 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJS00,NJJS00,IPOS00 + REAL, ALLOCATABLE, DIMENSION(:) :: SCAT +*---- +* ALLOCATE THE MEMORY THAT IS REQUIRED TO READ THE SCATTERING MATTRICES +*---- + ALLOCATE(IJJS00(NMIX),NJJS00(NMIX),IPOS00(NMIX)) +*---- +* PROCESS THE CROSS SECTIONS FOR EACH ENERGY GROUP +* THIS IS THE MAIN LOOP +*---- + XSSNN(:NMIX,:NGRP,:NGRP,:NL)=0.0 + JPMC = LCMGID(IPLIB,'GROUP') + DO IGROUP=1,NGRP + KPMC = LCMGIL(JPMC,IGROUP) +*---- +* READ THE TOTAL MACROSCOPIC CROSS SECTIONS +*---- + CALL LCMGET(KPMC,'NTOT0',XSTOT(1,IGROUP)) +*---- +* READ THE TOTAL SCATTERING CROSS SECTIONS AND MATRICES +*---- + DO IL=1,NL + WRITE(CM,'(I2.2)') IL-1 + CALL LCMGET(KPMC,'SIGS'//CM,XSS(1,IGROUP,IL)) + CALL LCMGET(KPMC,'IJJS'//CM,IJJS00) + CALL LCMGET(KPMC,'NJJS'//CM,NJJS00) + CALL LCMGET(KPMC,'IPOS'//CM,IPOS00) + IMAX=0 + DO IMAT=1,NMIX + IMAX=IMAX+NJJS00(IMAT) + ENDDO + ALLOCATE(SCAT(IMAX)) + CALL LCMGET(KPMC,'SCAT'//CM,SCAT) + DO IMAT=1,NMIX + IPOS=IPOS00(IMAT) + IEN0=IJJS00(IMAT) + IENBR=NJJS00(IMAT) + DO WHILE (IENBR.GE.1) + XSSNN(IMAT,IGROUP,IEN0,IL)=SCAT(IPOS) + IPOS=IPOS+1 + IENBR=IENBR-1 + IEN0=IEN0-1 + ENDDO + ENDDO + DEALLOCATE(SCAT) + ENDDO +*---- +* RECOVER THE N2N MACROSCOPIC CROSS SECTIONS +*---- + IF(LN2N) THEN + CALL LCMLEN(KPMC,'N2N',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPMC,'N2N',XSN2N(1,IGROUP)) + ELSE + XSN2N(:NMIX,IGROUP)=0.0 + ENDIF + CALL LCMLEN(KPMC,'N3N',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPMC,'N3N',XSN3N(1,IGROUP)) + ELSE + XSN3N(:NMIX,IGROUP)=0.0 + ENDIF + DO IMAT=1,NMIX + XSS(IMAT,IGROUP,1)=XSS(IMAT,IGROUP,1)-2.0*XSN2N(IMAT,IGROUP) + 1 -3.0*XSN3N(IMAT,IGROUP) + IF(XSS(IMAT,IGROUP,1).LT.0.0) CALL XABORT('MCTLIB: BUG1') + XSS(IMAT,IGROUP,1)=MIN(XSTOT(IMAT,IGROUP),XSS(IMAT,IGROUP,1)) + ENDDO + ELSE + XSN2N(:NMIX,IGROUP)=0.0 + XSN3N(:NMIX,IGROUP)=0.0 +* N2N CORRECTION IN UPPER ENERGY GROUPS + DO IMAT=1,NMIX + IF(XSS(IMAT,IGROUP,1).GT.XSTOT(IMAT,IGROUP)) THEN + XSN2N(IMAT,IGROUP)=XSS(IMAT,IGROUP,1)-XSTOT(IMAT,IGROUP) + XSS(IMAT,IGROUP,1)=2.0*XSTOT(IMAT,IGROUP)- + 1 XSS(IMAT,IGROUP,1) + ENDIF + IF(XSS(IMAT,IGROUP,1).LT.0.0) CALL XABORT('MCTLIB: BUG2') + ENDDO + ENDIF +*---- +* RECOVER FISSION INFORMATION +*---- + IF(NFM.GT.0) THEN + CALL LCMGET(KPMC,'NUSIGF',XSNUSI(1,1,IGROUP,1)) + CALL LCMGET(KPMC,'CHI',XSCHI(1,1,IGROUP,1)) + DO IDEL=1,NDEL + WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL + CALL LCMGET(KPMC,TEXT12,XSNUSI(1,1,IGROUP,1+IDEL)) + WRITE(TEXT12,'(3HCHI,I2.2)') IDEL + CALL LCMGET(KPMC,TEXT12,XSCHI(1,1,IGROUP,1+IDEL)) + ENDDO + ENDIF +*---- +* RECOVER SPECIAL EDIT CROSS SECTIONS +*---- + DO IED=1,NED + WRITE(TEXT12,'(2A4)') NAMEAD(1,IED),NAMEAD(2,IED) + CALL LCMLEN(KPMC,TEXT12,ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPMC,TEXT12,XSEDI(1,IGROUP,IED)) + ELSE + XSEDI(:NMIX,IGROUP,IED)=0.0 + ENDIF + ENDDO + ENDDO +*---- +* RELEASE THE TEMPORARY MEMORY ALLOCATION +*---- + DEALLOCATE(IPOS00,NJJS00,IJJS00) +*---- +* SCATTERING MATRIX NORMALIZATION +*---- + DO IL=1,NL + DO IMAT=1,NMIX + DO IGROUP=1,NGRP + SUM=0.0D0 + DO JGROUP=1,NGRP + SUM=SUM+XSSNN(IMAT,JGROUP,IGROUP,IL) ! JGROUP <-- IGROUP + ENDDO + IF(SUM.NE.0.0) THEN + DO JGROUP=1,NGRP + XSSNN(IMAT,JGROUP,IGROUP,IL)=XSSNN(IMAT,JGROUP,IGROUP,IL) + 1 *XSS(IMAT,IGROUP,IL)/REAL(SUM) + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO + RETURN + END diff --git a/Dragon/src/MCTOUT.f b/Dragon/src/MCTOUT.f new file mode 100644 index 0000000..1bca444 --- /dev/null +++ b/Dragon/src/MCTOUT.f @@ -0,0 +1,244 @@ +*DECK MCTOUT + SUBROUTINE MCTOUT(IPOUT,NL,NFM,NDEL,NED,NAMEAD,NBSCO,NMERGE, + 1 NGCOND,ASCORE1,ASCORE2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Reconstruct the macrolib using a macrolib-related tally. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPOUT pointer to the MC data structure. +* NL number of Legendre orders required in the estimations +* (NL=1 or higher). +* NFM number of fissile isotopes. +* NDEL number of delayed precursor groups. +* NED number of extra edit vectors. +* NAMEAD names of these extra edits. +* NBSCO number of macrolib-related scores. +* NMERGE number of homogenized regions. +* NGCOND number of condensed energy groups. +* ASCORE1 score for total flux and effective multiplication factor. +* ASCORE2 macrolib score matrix. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPOUT + INTEGER NL,NFM,NDEL,NED,NAMEAD(2,NED),NBSCO,NMERGE,NGCOND + DOUBLE PRECISION ASCORE1(3),ASCORE2(NBSCO,NMERGE,NGCOND) +*---- +* LOCAL VARIABLES +*---- + INTEGER NSTATE + PARAMETER(NSTATE=40) + TYPE(C_PTR) JPOUT,KPOUT + INTEGER ISTATE(NSTATE),IGR,JGR,IMIX,IPOSDE,IGMIN,IGMAX,IFM,IOF, + > IOF2,IED,I0,IL,IDEL,HSIGN(3) + CHARACTER TEXT12*12,CM*2 + DOUBLE PRECISION SUM,SUM2 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) :: GAR1,GAR2 + REAL, ALLOCATABLE, DIMENSION(:,:) :: GAR3 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IJJ(NMERGE),NJJ(NMERGE),IPOS(NMERGE)) + ALLOCATE(GAR1(NMERGE),GAR2(NMERGE*NGCOND),GAR3(NMERGE,NFM)) +*---- +* SCATTERING MATRIX NORMALIZATION +*---- + DO IMIX=1,NMERGE + DO IGR=1,NGCOND + SUM=0.0D0 + DO JGR=1,NGCOND + SUM=SUM+ASCORE2(5+JGR,IMIX,IGR) ! JGR <-- IGR + ENDDO + DO JGR=1,NGCOND + ASCORE2(5+JGR,IMIX,IGR)=ASCORE2(5+JGR,IMIX,IGR)* + 1 ASCORE2(3,IMIX,IGR)/SUM + ENDDO + ENDDO + ENDDO +*---- +* FISSION SPECTRUM NORMALIZATION +*---- + IOF=5+NGCOND*NL + IOF2=IOF+NFM + DO IMIX=1,NMERGE + DO IFM=1,NFM + SUM=0.0D0 + DO IGR=1,NGCOND + SUM=SUM+ASCORE2(IOF+IFM,IMIX,IGR) + ENDDO + SUM2=0.0D0 + DO IGR=1,NGCOND + SUM2=SUM2+ASCORE2(IOF2+IFM,IMIX,IGR) + ENDDO + IF(SUM2.NE.0.0) THEN + DO IGR=1,NGCOND + ASCORE2(IOF2+IFM,IMIX,IGR)=ASCORE2(IOF2+IFM,IMIX,IGR)* + 1 SUM/SUM2 + ENDDO + ENDIF + ENDDO + ENDDO +*---- +* REFORMAT CROSS-SECTION INFORMATION INTO MACROLIB FORMAT +*---- + CALL LCMSIX(IPOUT,'MACROLIB',1) + JPOUT=LCMLID(IPOUT,'GROUP',NGCOND) + DO IGR=1,NGCOND + KPOUT=LCMDIL(JPOUT,IGR) + DO IMIX=1,NMERGE + GAR1(IMIX)=REAL(ASCORE2(1,IMIX,IGR)/ASCORE1(1)) + ENDDO + CALL LCMPUT(KPOUT,'NWT0',NMERGE,2,GAR1) + DO IMIX=1,NMERGE + GAR1(IMIX)=REAL(ASCORE2(2,IMIX,IGR)/ASCORE2(1,IMIX,IGR)) + ENDDO + CALL LCMPUT(KPOUT,'NTOT0',NMERGE,2,GAR1) + DO IMIX=1,NMERGE + GAR1(IMIX)=REAL((ASCORE2(3,IMIX,IGR)+2.0*ASCORE2(4,IMIX,IGR)+ + 1 3.0*ASCORE2(5,IMIX,IGR))/ASCORE2(1,IMIX,IGR)) + ENDDO + CALL LCMPUT(KPOUT,'SIGS00',NMERGE,2,GAR1) +*---- +* REFORMAT SCATTERING INFORMATION +*---- + IOF=5 + DO IL=1,NL + WRITE(CM,'(I2.2)') IL-1 + IPOSDE=0 + DO IMIX=1,NMERGE + IPOS(IMIX)=IPOSDE+1 + IGMIN=IGR + IGMAX=IGR + DO JGR=NGCOND,1,-1 + IF(ASCORE2(IOF+IGR,IMIX,JGR).NE.0.0) THEN + IGMIN=MIN(IGMIN,JGR) + IGMAX=MAX(IGMAX,JGR) + ENDIF + ENDDO + IJJ(IMIX)=IGMAX + NJJ(IMIX)=IGMAX-IGMIN+1 + DO JGR=IGMAX,IGMIN,-1 + IPOSDE=IPOSDE+1 + GAR2(IPOSDE)=REAL(ASCORE2(IOF+IGR,IMIX,JGR)/ + 1 ASCORE2(1,IMIX,JGR)) + IF(JGR.EQ.IGR) THEN + GAR2(IPOSDE)=GAR2(IPOSDE)+REAL((2.0*ASCORE2(4,IMIX,IGR)+ + 1 3.0*ASCORE2(5,IMIX,IGR))/ASCORE2(1,IMIX,IGR)) + ENDIF + ENDDO + GAR1(IMIX)=REAL((ASCORE2(IOF+IGR,IMIX,IGR) + 1 +2.0*ASCORE2(4,IMIX,IGR)+3.0*ASCORE2(5,IMIX,IGR))/ + 2 ASCORE2(1,IMIX,IGR)) + ENDDO + CALL LCMPUT(KPOUT,'SCAT'//CM,IPOSDE,2,GAR2) + CALL LCMPUT(KPOUT,'NJJS'//CM,NMERGE,1,NJJ) + CALL LCMPUT(KPOUT,'IJJS'//CM,NMERGE,1,IJJ) + CALL LCMPUT(KPOUT,'IPOS'//CM,NMERGE,1,IPOS) + CALL LCMPUT(KPOUT,'SIGW'//CM,NMERGE,2,GAR1) + IF(IL.GT.1) THEN + GAR1(:NMERGE)=0.0 + DO IMIX=1,NMERGE + DO JGR=1,NGCOND + GAR1(IMIX)=GAR1(IMIX)+REAL(ASCORE2(IOF+JGR,IMIX,IGR)/ + 1 ASCORE2(1,IMIX,IGR)) + ENDDO + GAR1(IMIX)=GAR1(IMIX)+REAL((2.0*ASCORE2(4,IMIX,IGR)+3.0* + 1 ASCORE2(5,IMIX,IGR))/ASCORE2(1,IMIX,IGR)) + ENDDO + CALL LCMPUT(KPOUT,'SIGS'//CM,NMERGE,2,GAR1) + ENDIF + IOF=IOF+NGCOND + ENDDO +*---- +* REFORMAT FISSION INFORMATION +*---- + DO IDEL=1,1+NDEL + IF(IDEL.EQ.1) THEN + TEXT12='NUSIGF' + ELSE + WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL-1 + ENDIF + DO IMIX=1,NMERGE + DO IFM=1,NFM + GAR3(IMIX,IFM)=REAL(ASCORE2(IOF+IFM,IMIX,IGR)/ + 1 ASCORE2(1,IMIX,IGR)) + ENDDO + ENDDO + CALL LCMPUT(KPOUT,TEXT12,NMERGE*NFM,2,GAR3) + IF(IDEL.EQ.1) THEN + TEXT12='CHI' + ELSE + WRITE(TEXT12,'(3HCHI,I2.2)') IDEL-1 + ENDIF + IOF2=IOF+NFM + DO IMIX=1,NMERGE + DO IFM=1,NFM + SUM=0.0D0 + DO JGR=1,NGCOND + SUM=SUM+ASCORE2(IOF+IFM,IMIX,JGR) + ENDDO + IF(SUM.NE.0.0) THEN + GAR3(IMIX,IFM)=REAL(ASCORE2(IOF2+IFM,IMIX,IGR)/SUM) + ELSE + GAR3(IMIX,IFM)=0.0 + ENDIF + ENDDO + ENDDO + CALL LCMPUT(KPOUT,TEXT12,NMERGE*NFM,2,GAR3) + IOF=IOF2+NFM + ENDDO +*---- +* REFORMAT ADDITIONAL EDIT INFORMATION +*---- + DO IED=1,NED + WRITE(TEXT12,'(2A4)') NAMEAD(1,IED),NAMEAD(2,IED) + DO IMIX=1,NMERGE + GAR1(IMIX)=REAL(ASCORE2(IOF+IED,IMIX,IGR)/ + 1 ASCORE2(1,IMIX,IGR)) + ENDDO + CALL LCMPUT(KPOUT,TEXT12,NMERGE,2,GAR1) + ENDDO + ENDDO +*---- +* CREATE THE STATE VECTOR AND THE SIGNATURE +*---- + ISTATE(:NSTATE)=0 + ISTATE(1)=NGCOND + ISTATE(2)=NMERGE + ISTATE(3)=NL + ISTATE(4)=NFM + ISTATE(5)=NED + ISTATE(7)=NDEL + CALL LCMPUT(IPOUT,'STATE-VECTOR',NSTATE,1,ISTATE) + TEXT12='L_MACROLIB' + READ(TEXT12,'(3A4)') (HSIGN(I0),I0=1,3) + CALL LCMPUT(IPOUT,'SIGNATURE',3,3,HSIGN) + CALL LCMSIX(IPOUT,' ',2) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GAR3,GAR2,GAR1) + DEALLOCATE(IPOS,NJJ,IJJ) + RETURN + END diff --git a/Dragon/src/MCTPIR.f b/Dragon/src/MCTPIR.f new file mode 100644 index 0000000..29a673b --- /dev/null +++ b/Dragon/src/MCTPIR.f @@ -0,0 +1,148 @@ +*DECK MCTPIR + SUBROUTINE MCTPIR(IPTRK,IPRINT,NDIM,MAXMSH,MXGSUR,MXGREG,NTPIN, + 1 NBIND,INDX,ITPIN,DRAPIN,DCMESH,MESHP,NSURP,NREGP, + 2 PINCEN,INDEX,IDREG,POSC,IDIRP,INPIN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Search if point is within a pin. If so, load pin contents and change +* coordinates to pin local ones. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure. +* IPRINT print level. +* NDIM problem dimensions. +* MAXMSH maximum number of elements in MESH array. +* MXGSUR maximum number of surfaces for any geometry. +* MXGREG maximum number of region for any geometry. +* NTPIN number of pins within the cell. +* NBIND first dimension of INDX. +* ITPIN integer pin descriptor. +* DRAPIN double pin descriptor. + +*Parameters: input/output +* INDX position index in the geometry structure. +* DCMESH cell and pin (if point is in pin) meshing. +* POSC local cell/pin (if point is in pin, cell otherwise) +* coordinates of the point. +* +*Parameters: output +* MESHP pin meshes size (if point is in pin). +* NSURP number of surfaces for the pin (if point is in pin). +* NREGP number of regions for the pin (if point is in pin). +* PINCEN cell coordinates of the pin center (if point is in pin). +* INDEX pin index vector (if point is in pin). +* IDREG pin region id array (if point is in pin). +* IDIRP pin orientation (if point is in pin). +* INPIN logical flag: true (if point is within a pin). +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER IPRINT,NDIM,MAXMSH,MXGSUR,MXGREG,NTPIN,NBIND, + 1 INDX(NBIND,2),ITPIN(3,NTPIN),IDIRP,MESHP(4),NSURP,NREGP, + 2 INDEX(5,-MXGSUR:MXGREG),IDREG(NREGP) + DOUBLE PRECISION DCMESH(-1:MAXMSH,4,2),DRAPIN(-1:4,NTPIN), + 1 PINCEN(3),POSC(4) + LOGICAL INPIN +*---- +* LOCAL COORDINATES +*---- + INTEGER IDIR,ITPINO,IPIN,IDG1,IDG2 + DOUBLE PRECISION POSO(3),HALFL,R,PI,XDRCST,ANGP,COSP,SINP + CHARACTER NAMPIN*9,NAMREC*12 + INTEGER INDOS(2,3) + CHARACTER RIDNAM*3 + PARAMETER (RIDNAM='RIC') + DATA INDOS / 2,3, + 1 3,1, + 2 1,2 / +*---- +* SCAN PINS TO FIND IF THE POINT IS LOCATED WITHIN ONE OF THEN +*---- + PI=XDRCST('Pi',' ') +* CHANGE COORDINATES TO TAKE INTO ACCOUNT OFFCEN FOR CYLINDERS AND PINS + DO IDIR=1,NDIM + POSO(IDIR)=POSC(IDIR)-DCMESH(-1,IDIR,1) + ENDDO + ITPINO=INDX(6,1) +* SCAN PINS + DO 10 IPIN=1,NTPIN + IDIRP=ABS(ITPIN(3,IPIN)) + IF (NDIM.EQ.3) THEN +* VERIFY THE POSITION ALONG THE PIN AXIS + HALFL=0.5D0*DRAPIN(IDIRP,IPIN) + IF ((POSO(IDIRP).LT.-HALFL).OR. + 1 (POSO(IDIRP).GT.HALFL)) GOTO 10 + ENDIF +* VERIFY RADIAL POSITION +* IDG1 is first direction of plane perpendicular +* to main direction ($Y, $Z$ or $X$). +* IDG2 is second direction of plane perpendicular +* to main direction ($Z$, $X$ or $Y$). +* IDIRP is main cylinder direction ($X$, $Y$ or $Z$) +* for 2D case IDIRP=3 + IDG1=INDOS(1,IDIRP) + IDG2=INDOS(2,IDIRP) +* pin center + PINCEN(IDG1)=DRAPIN(0,IPIN)*COS(DRAPIN(-1,IPIN)) + PINCEN(IDG2)=DRAPIN(0,IPIN)*SIN(DRAPIN(-1,IPIN)) + PINCEN(IDIRP)=0.D0 +* distance with respect to this center + R=((POSO(IDG1)-PINCEN(IDG1))**2+(POSO(IDG2)-PINCEN(IDG2))**2) + R=SQRT(R) + IF (R.LT.DRAPIN(4,IPIN)) THEN + INDX(5,1)=IPIN + INDX(6,1)=ITPIN(2,IPIN) + GOTO 20 + ENDIF + 10 CONTINUE +* NO + INPIN=.FALSE. + RETURN +* YES + 20 CONTINUE + INPIN=.TRUE. + POSC(4)=R + IF (IPRINT.GT.4) THEN + WRITE(6,*) 'PIN: TYPE:',INDX(6,1),' INDEX IN CELL:',INDX(5,1) + ENDIF + IF (INDX(6,1).EQ.ITPINO) THEN + IF (INDX(7,2).LE.0) THEN + WRITE(NAMPIN,'(A1,I8.8)') 'P',ITPINO + NAMREC=NAMPIN//RIDNAM + CALL LCMGET(IPTRK,NAMREC,IDREG) + ENDIF + ELSE + CALL MCTLDP(IPTRK,IPRINT,MAXMSH,MXGSUR,MXGREG,INDX(6,1), + 1 RIDNAM,MESHP,NSURP,NREGP,DCMESH(-1,1,2),INDEX,IDREG) + ENDIF +* Change coordinates to (origin=pin center) + DO IDIR=1,NDIM + POSO(IDIR)=POSO(IDIR)-PINCEN(IDIR) + ENDDO +* Rotate geometry by (Pi/2-alpha) for pin at alpha. + ANGP=0.5D0*PI-DRAPIN(-1,INDX(5,1)) + COSP=COS(ANGP) + SINP=SIN(ANGP) + POSC(IDG1)=POSO(IDG1)*COSP-POSO(IDG2)*SINP + POSC(IDG2)=POSO(IDG1)*SINP+POSO(IDG2)*COSP + POSC(IDIRP)=POSO(IDIRP) +* + RETURN + END diff --git a/Dragon/src/MCTPSP.f b/Dragon/src/MCTPSP.f new file mode 100644 index 0000000..2a8cb66 --- /dev/null +++ b/Dragon/src/MCTPSP.f @@ -0,0 +1,64 @@ +*DECK MCTPSP + SUBROUTINE MCTPSP(IPTRK,POS,IREG,IEV) +*----------------------------------------------------------------------- +* +*Purpose: +* Store position and region index in TRACKING table for PSP display. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure. +* POS point global coordinates. +* IREG region/surface index. +* IEV event index. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER IREG,IEV + DOUBLE PRECISION POS(3) +*---- +* LOCAL VARIABLES +*---- + INTEGER ILONG,ITYLCM,NPOINT +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: REGI,EVENT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: COORD +* + CALL LCMSIX(IPTRK,'MCpoints',1) + CALL LCMLEN(IPTRK,'REGI',ILONG,ITYLCM) + NPOINT=ILONG+1 + ALLOCATE(COORD(3,NPOINT),REGI(NPOINT),EVENT(NPOINT)) + IF (ILONG.GT.0) THEN + CALL LCMGET(IPTRK,'COORD',COORD) + CALL LCMGET(IPTRK,'REGI',REGI) + CALL LCMGET(IPTRK,'EVENT',EVENT) + ENDIF + COORD(1,NPOINT)=POS(1) + COORD(2,NPOINT)=POS(2) + COORD(3,NPOINT)=POS(3) + REGI(NPOINT)=IREG + EVENT(NPOINT)=IEV + CALL LCMPUT(IPTRK,'COORD',3*NPOINT,4,COORD) + CALL LCMPUT(IPTRK,'REGI',NPOINT,1,REGI) + CALL LCMPUT(IPTRK,'EVENT',NPOINT,1,EVENT) + DEALLOCATE(EVENT,REGI,COORD) + CALL LCMSIX(IPTRK,' ',2) +* + RETURN + END diff --git a/Dragon/src/MCTPTR.f b/Dragon/src/MCTPTR.f new file mode 100644 index 0000000..daa2055 --- /dev/null +++ b/Dragon/src/MCTPTR.f @@ -0,0 +1,178 @@ +*DECK MCTPTR + SUBROUTINE MCTPTR(IPTRK,IPRINT,NDIM,MAXMSH,ITYPBC,NUCELL,MXGSUR, + 1 MXGREG,MAXPIN,IUNFLD,DGMESH,XYZL,NBIND,POS, + 2 LENGTH,VDIR,ODIR,IDS,IDSO,IREG,INDX,IDIRC, + 3 MESHC,NSURC,NREGC,NTPIN,CELLPO,PINCEN,INDEX, + 4 IDREG,DCMESH,ITPIN,DRAPIN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find region/surface index from an initial position and a path to +* travel. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure. +* IPRINT print level. +* NDIM problem dimensions. +* MAXMSH maximum number of elements in MESH array. +* ITYPBC type of boundary. +* NUCELL number of cell after unfolding in +* $X$, $Y$ and $Z$ directions. +* MXGSUR maximum number of surfaces for any geometry. +* MXGREG maximum number of region for any geometry. +* MAXPIN maximum number of pins in a cell. +* IUNFLD description of unfolded geometry. +* DGMESH meshing vector for global geometry. +* XYZL undefined. +* NBIND first dimension of INDX. +* VDIR travel direction (unit vector). +* +*Parameters: output +* IDS outer surface orientation index. ABS(IDSO). +* IDSO outer surface oreientation index with +-1:X+-; +-2:Y+-; +* +-3:Z+- faces. +* IREG region/surface index. +* ODIR search (octant) direction. +* +*Parameters: input/output +* POS initial/final position. +* LENGTH length to travel/remaining length on the path. +* INDX location index of the initial/final position in the +* geometry structure. +* +*Parameters: scratch +* IDIRC undefined. +* MESHC undefined. +* NSURC undefined. +* NREGC undefined. +* NTPIN undefined. +* CELLPO undefined. +* PINCEN undefined. +* INDEX undefined. +* IDREG undefined. +* DCMESH undefined. +* ITPIN undefined. +* DRAPIN undefined. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER IPRINT,NDIM,MAXMSH,ITYPBC,NUCELL(3),MXGSUR,MXGREG,MAXPIN, + 1 IUNFLD(2,NUCELL(1),NUCELL(2),NUCELL(3)),NBIND,ODIR(3),IREG, + 2 INDX(NBIND,0:2),IDIRC(2),MESHC(4,2),NSURC(2),NREGC(2),NTPIN, + 3 INDEX(5,-MXGSUR:MXGREG,2),IDREG(MXGREG,2),ITPIN(3,MAXPIN) + DOUBLE PRECISION DGMESH(-1:MAXMSH,4),XYZL(2,NDIM),POS(3),LENGTH, + 1 VDIR(3),CELLPO(3,2),PINCEN(3),DCMESH(-1:MAXMSH,4,2), + 2 DRAPIN(-1:4,MAXPIN) +*---- +* LOCAL VARIABLES +*---- + INTEGER IDIR,IBCO(3),IDS,IDSO,JJ + DOUBLE PRECISION VCOR(3),LEN,LENM + DOUBLE PRECISION EPS + PARAMETER(EPS=1.D-8) + INTEGER INDOS(2,3) + DATA INDOS / 2,3, + 1 3,1, + 2 1,2 / +*---- +* VERIFY IF A BOUNDARY IS REACHED +*---- + IDSO=0 + LENM=0.0D0 + IF(ITYPBC.EQ.0) THEN +* CARTESIAN BOUNDARY +* find corresponding geometry corner corresponding to travel direction +* check if a boundary is reached and if so, which one it is + IDS=0 + LENM=LENGTH + DO IDIR=1,NDIM + IF(VDIR(IDIR).GT.EPS) THEN + ODIR(IDIR)=1 + IBCO(IDIR)=2 + VCOR(IDIR)=XYZL(2,IDIR)-POS(IDIR) + LEN=VCOR(IDIR)/VDIR(IDIR) + IF(LEN.LT.LENM) THEN + LENM=LEN + IDS=IDIR + IF(IDIR.EQ.1) THEN + IREG=-2 ; + ELSEIF(IDIR.EQ.2) THEN + IREG=-4 ; + ELSEIF(IDIR.EQ.3) THEN + IREG=-6 ; + ENDIF + ENDIF + ELSEIF(VDIR(IDIR).LT.-EPS) THEN + ODIR(IDIR)=-1 + IBCO(IDIR)=1 + VCOR(IDIR)=XYZL(1,IDIR)-POS(IDIR) + LEN=VCOR(IDIR)/VDIR(IDIR) + IF(LEN.LT.LENM) THEN + LENM=LEN + IDS=IDIR + IF(IDIR.EQ.1) THEN + IREG=-1 ; + ELSEIF(IDIR.EQ.2) THEN + IREG=-3 ; + ELSEIF(IDIR.EQ.3) THEN + IREG=-5 ; + ENDIF + ENDIF + ELSE + ODIR(IDIR)=0 + ENDIF + ENDDO + ELSE +* CYLINDRICAL BOUNDARY + CALL XABORT('MCTPTR: CYLINDRICAL/HEXAGONAL BOUNDARY NOT IMPLEM' + 1 //'ENTED YET.') + ENDIF + IF(IDS.EQ.0) THEN +*---- +* NO: LOCATE POINT WITHIN THE GEOMETRY +*---- + DO IDIR=1,NDIM + POS(IDIR)=POS(IDIR)+LENGTH*VDIR(IDIR) + ENDDO + DO IDIR=NDIM+1,3 + POS(IDIR)=1.D0 + ENDDO +!!!!!! for the time being it is the same routine as for a starting point +!!!!!! an optimized version should use the info of the previous point +!!!!!! to start its search + CALL MCTCTR(IPTRK,IPRINT,NDIM,MAXMSH,NUCELL,MXGSUR,MXGREG, + 1 MAXPIN,IUNFLD,DGMESH,NBIND,ODIR,POS,IREG,INDX,IDIRC,MESHC, + 2 NSURC,NREGC,NTPIN,CELLPO,PINCEN,INDEX,IDREG,DCMESH,ITPIN, + 3 DRAPIN) + ELSE +*---- +* YES: LOCATE POINT ON THE BOUNDARY +*---- + POS(IDS)=XYZL(IBCO(IDS),IDS) + DO JJ=1,2 + IDIR=INDOS(JJ,IDS) + POS(IDIR)=POS(IDIR)+LENM*VDIR(IDIR) + ENDDO + LENGTH=LENGTH-LENM + IDSO=IDS + IF(IBCO(IDS).EQ.1) IDSO=-IDSO + ENDIF +* + RETURN + END diff --git a/Dragon/src/MCTRK.f b/Dragon/src/MCTRK.f new file mode 100644 index 0000000..870468f --- /dev/null +++ b/Dragon/src/MCTRK.f @@ -0,0 +1,399 @@ +*DECK MCTRK + SUBROUTINE MCTRK(IPTRK,IPRINT,NFREG,NFSUR,NDIM,NMIX,ANGBC,ITYPBC, + 1 MAXMSH,NUCELL,MXGSUR,MXGREG,MAXPIN,BCRT,ICODE, + 2 ALBEDO,IUNFLD,DGMESH,XYZL,INDEX,IDREG,DCMESH, + 3 ITPIN,DRAPIN,ISEED,NGRP,NL,NFM,NDEL,NED,MATCOD, + 4 XST,XSS,XSN2N,XSN3N,XSSNN,XSNUSI,XSCHI,XSEDI, + 5 MIX,ISONBR,NU,POS,ITALLY,NBSCO,NMERGE,NGCOND, + 6 IMERGE,INDGRP,SCORE1,SCORE2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Simulation of a single particle from source to death. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): B. Arsenault +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure. +* IPRINT print level. +* NFREG number of regions. +* NFSUR number of surfaces. +* NDIM problem dimensions. +* NMIX number of mixtures in the geometry. +* ANGBC angular treatment for boundary conditions (=0 isotropic; +* =1 specular). +* ITYPBC type of boundary. +* MAXMSH maximum number of elements in MESH array. +* NUCELL number of cell after unfolding in $X$, $Y$ and $Z$ directions. +* MXGSUR maximum number of surfaces for any geometry. +* MXGREG maximum number of region for any geometry. +* MAXPIN maximum number of pins in a cell. +* BCRT reflection/translation array. +* ICODE albedo index array. +* ALBEDO albedo array. +* IUNFLD description of unfolded geometry. +* DGMESH meshing vector for global geometry. +* XYZL Cartesian boundary coordinates. +* ISEED the seed for the generation of random numbers. +* NGRP number of energy groups. +* NL number of Legendre orders required in the estimations +* (NL=1 or higher). +* NFM number of fissile isotopes. +* NDEL number of delayed precursor groups. +* NED number of extra edit vectors. +* XST total macroscopic cross sections for each mixture and energy +* group. +* XSS total scattering cross sections for each mixture and energy +* group. +* XSN2N N2N macroscopic cross sections for each mixture and energy +* group. +* XSN3N N3N macroscopic cross sections for each mixture and energy +* group. +* MATCOD region material. +* XSSNN in-group and out-of-group macroscopic transfert cross sections +* for each mixture. +* XSNUSI the values of Nu time the fission cross sections for each +* isotope per mixture and energy group. +* XSCHI the values of fission spectrum per isotope per mixture for +* each energy group. +* XSEDI extra edit cross sections for each mixture and energy group. +* MIX the mixture number where the fission occurs. +* ISONBR the isotopic number where the fission occurs. +* NU the value of the particle weight. +* POS location of the particle in the x, y, and z directions. +* ITALLY type of tally (=0 no tally; =1 score effective +* multiplication factor; =2 also score macrolib information). +* NBSCO number of macrolib related scores. +* NMERGE number of homogenized regions. +* NGCOND number of condensed energy groups. +* IMERGE homogenized regions indices. +* INDGRP condensed groups indices. +* INDEX undefined. +* IDREG undefined. +* DCMESH undefined. +* ITPIN undefined. +* DRAPIN undefined. +* +*Parameters: input/output +* SCORE1 score for total flux and effective multiplication factor. +* SCORE2 macrolib score matrix. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER IPRINT,NFREG,NFSUR,NDIM,NMIX,ANGBC,ITYPBC,MAXMSH, + 1 NUCELL(3),MXGSUR,MXGREG,MAXPIN,MIX,ISONBR, + 2 BCRT(NFSUR),ICODE(6),IUNFLD(2,NUCELL(1),NUCELL(2),NUCELL(3)), + 3 INDEX(5,-MXGSUR:MXGREG,2),IDREG(MXGREG,2),ITPIN(3,MAXPIN), + 4 ISEED,NGRP,NL,NFM,NDEL,NED,MATCOD(NFREG),ITALLY,NBSCO,NMERGE, + 5 NGCOND,IMERGE(NFREG),INDGRP(NGRP) + REAL ALBEDO(6),XST(NMIX,NGRP),XSS(NMIX,NGRP,NL),XSN2N(NMIX,NGRP), + 1 XSN3N(NMIX,NGRP),XSSNN(NMIX,NGRP,NGRP,NL), + 2 XSNUSI(NMIX,NFM,NGRP,1+NDEL),XSCHI(NMIX,NFM,NGRP,1+NDEL), + 3 XSEDI(NMIX,NGRP,NED),NU,SCORE1(3),SCORE2(NBSCO,NMERGE,NGCOND) + DOUBLE PRECISION DGMESH(-1:MAXMSH,4),XYZL(2,NDIM), + 1 DCMESH(-1:MAXMSH,4,2),DRAPIN(-1:4,MAXPIN),POS(3) +*---- +* LOCAL VARIABLES +*---- + INTEGER NBIND + PARAMETER (NBIND=7) + DOUBLE PRECISION XDRCST,PI,TWOPI + INTEGER INDX(NBIND,0:2),ODIR(3),IREG,IDIRC(2),MESHC(4,2),NSURC(2), + 1 NREGC(2),NTPIN,IDIR,ILEV,IDS,IDSO,IPSP,IEV,II,IGROUP,IGR, + 2 ISUR,ISUR2,IBM,IDIM,IFIRST + DOUBLE PRECISION CELLPO(3,2),PINCEN(3),LENGTH,MU,MUS,VIS,PHI, + 2 VDIR(3),OMEGA(3),ALB,NUSIGF0 + LOGICAL TRACK,ACTIVE,KILLED,VIRTUAL + PARAMETER (ACTIVE=.TRUE.,KILLED=.FALSE.) + REAL RAND,XSM + DOUBLE PRECISION PSCAT,PN2N,PN3N,XPROB,XX +*---- +* DATA VALUES +*---- + INTEGER INDOS(2,3),INDIC(-3:3) + DATA INDOS / 2,3, + 1 3,1, + 2 1,2 / + DATA INDIC / 5,3,1,0,2,4,6/ +*---- +* LOAD CONSTANTS +*---- + PI=XDRCST('Pi',' ') + TWOPI=2.D0*PI + IFIRST=1 +*---- +* TRACK THE NEUTRON PATH +*---- + DO ILEV=0,2 + DO IDIR=1,3 + INDX(IDIR,ILEV)=1 + ENDDO + DO IDIR=4,NBIND + INDX(IDIR,ILEV)=0 + ENDDO + ENDDO + ODIR(:3)=1 + + TRACK=ACTIVE + LENGTH=0.D0 + IDSO=0 + VIRTUAL=.FALSE. + + DO WHILE(TRACK.EQV.ACTIVE) + IF(IDSO.EQ.0) THEN + IF(LENGTH.EQ.0.D0) THEN + IF(MIX.EQ.-1) THEN + IGR=1 + ELSE + CALL RANDF(ISEED,IFIRST,RAND) + XPROB=0.D0 + IGR=0 + DO WHILE((RAND.GE.XPROB).AND.(IGR.LT.NGRP)) + IGR=IGR+1 + XPROB=XPROB+XSCHI(MIX,ISONBR,IGR,1) + ENDDO + ENDIF +*---- +* SET THE TRACK DIRECTION FOR THE FIRST FLIGHT +*---- + XSM=0.0 + DO II=1,NMIX + XSM=MAX(XSM,XST(II,IGR)) + ENDDO + CALL RANDF(ISEED,IFIRST,RAND) + MU=2.D0*RAND-1.D0 + MUS=DSQRT(1.D0-MU*MU) + CALL RANDF(ISEED,IFIRST,RAND) + PHI=TWOPI*RAND + VDIR(1)=MUS*COS(PHI) + VDIR(2)=MUS*SIN(PHI) + VDIR(3)=MU + ELSE +*---- +* IF IT IS A VIRTUAL COLLISION, KEEP THE SAME DIRECTION, +* IF IT IS NOT A VIRTUAL COLLISION IT CONSISTS OF AN ISOTROPIC +* SCATTERING REACTION. +*---- + IF(.NOT.VIRTUAL) THEN + CALL RANDF(ISEED,IFIRST,RAND) + PHI=TWOPI*RAND + CALL RANDF(ISEED,IFIRST,RAND) + MU=COS(PI*(2.D0*RAND-1.D0)) + MUS=DSQRT(1.D0-MU*MU) + VIS=DSQRT(1.D0-VDIR(1)*VDIR(1)) + OMEGA(1)=VDIR(1)*MU-VIS*MUS*COS(PHI) + OMEGA(2)=VDIR(2)*MU+MUS*(VDIR(1)*VDIR(2)* + 1 COS(PHI)-VDIR(3)*SIN(PHI))/VIS + OMEGA(3)=VDIR(3)*MU+MUS*(VDIR(1)*VDIR(3)* + 1 COS(PHI)+VDIR(2)*SIN(PHI))/VIS + DO II=1,3 + VDIR(II)=OMEGA(II) + ENDDO + ENDIF + ENDIF +*---- +* SAMPLE THE FREE PATH DISTANCE +*---- + CALL RANDF(ISEED,IFIRST,RAND) + LENGTH=-LOG(RAND)/XSM + ENDIF +*---- +* LOCATE THE NEUTRON IN THE GEOMETRY +*---- + CALL MCTPTR(IPTRK,IPRINT,NDIM,MAXMSH,ITYPBC,NUCELL,MXGSUR, + 1 MXGREG,MAXPIN,IUNFLD,DGMESH,XYZL,NBIND,POS,LENGTH,VDIR, + 2 ODIR,IDS,IDSO,IREG,INDX,IDIRC,MESHC,NSURC,NREGC,NTPIN, + 3 CELLPO,PINCEN,INDEX,IDREG,DCMESH,ITPIN,DRAPIN) +*--- +* TALLY PROCESSING +*--- + IF(ITALLY.GT.0) THEN + CALL MCTALLY(ITALLY,NFREG,NMIX,NGRP,NL,NFM,NDEL,NED,NBSCO, + 1 NMERGE,NGCOND,IREG,IGR,NU,MATCOD,IMERGE,INDGRP,XSM,XST,XSS, + 2 XSN2N,XSN3N,XSSNN,XSNUSI,XSCHI,XSEDI,SCORE1,SCORE2) + ENDIF +*---- +* AN INTERACTION HAS BEEN DETECTED, DETECT IF IT IS A VIRTUAL OR A +* REAL COLLISION +*---- + IF(IREG.GT.0) THEN + IBM=MATCOD(IREG) + CALL RANDF(ISEED,IFIRST,RAND) + VIRTUAL=(RAND.LE.((XSM-XST(IBM,IGR))/XSM)) +*--- +* DETERMINE THE TYPE OF REACTION +*--- + IF(.NOT.VIRTUAL) THEN + CALL RANDF(ISEED,IFIRST,RAND) + PSCAT=XSS(IBM,IGR,1)/XST(IBM,IGR) + PN2N=XSN2N(IBM,IGR)/XST(IBM,IGR) + PN3N=XSN3N(IBM,IGR)/XST(IBM,IGR) + IF(RAND.LE.PSCAT+PN2N+PN3N) THEN +*--- +* ISOTROPIC SCATTERING OR NxN EVENT +*--- + IF(RAND.GT.PSCAT+PN2N) THEN + NU=3.0*NU + ELSE IF(RAND.GT.PSCAT) THEN + NU=2.0*NU + ENDIF + XX = 0.D0 + CALL RANDF(ISEED,IFIRST,RAND) + IGROUP=NGRP + DO WHILE((RAND.GT.XX).AND.(IGROUP.GE.1)) + XX=XX+XSSNN(IBM,IGROUP,IGR,1)/XSS(IBM,IGR,1) + IGROUP=IGROUP-1 + ENDDO + IGR=IGROUP+1 + TRACK=ACTIVE + XSM=0.0 + DO II=1,NMIX + XSM=MAX(XSM,XST(II,IGR)) + ENDDO + ELSE +*--- +* CAPTURE OR FISSION EVENT +*--- + TRACK = KILLED + MIX = IBM + NUSIGF0=0.0D0 + DO II=1,NFM + NUSIGF0=NUSIGF0+XSNUSI(IBM,II,IGR,1) + ENDDO + IF((NUSIGF0.GT.0.0).AND.(NFM.EQ.1)) THEN + NU=NU*XSNUSI(IBM,1,IGR,1)/(XST(IBM,IGR)-XSS(IBM,IGR,1)- + 1 XSN2N(IBM,IGR)-XSN3N(IBM,IGR)) + ISONBR=1 + ELSE IF(NUSIGF0.GT.0.0) THEN + CALL RANDF(ISEED,IFIRST,RAND) + XPROB=0.D0 + ISONBR=0 + DO WHILE((RAND.GE.XPROB).AND.(ISONBR.LT.NFM)) + ISONBR=ISONBR+1 + XPROB=XPROB+XSNUSI(IBM,ISONBR,IGR,1)/NUSIGF0 + ENDDO + NU=NU*XSNUSI(IBM,ISONBR,IGR,1)/(XST(IBM,IGR)- + 1 XSS(IBM,IGR,1)-2.0*XSN2N(IBM,IGR)-3.0*XSN3N(IBM,IGR)) + ELSE + NU=0.0 + ISONBR=0 + ENDIF + ENDIF + ENDIF + ELSE +*---- +* A BOUNDARY CONDITION HAS BEEN ENCOUNTERED +*---- + IF(ITYPBC.EQ.0) THEN +*---- +* CARTESIAN BOUNDARY +*---- + ISUR=-IREG + ISUR2=BCRT(ISUR) + IREG=-ISUR2 + IF((ISUR2.EQ.ISUR).AND.(ANGBC.EQ.1)) THEN +* SPECULAR REFLECTIVE BOUNDARY CONDITION + IF(IPRINT.GT.4) WRITE(6,*) 'SPECULAR REFLECTION ON ',ISUR + ALB=ALBEDO(-ICODE(INDIC(IDSO))) + IF(ALB.EQ.0.0) THEN +* no leakage + ISONBR = 0 + TRACK = KILLED + ELSE IF(ALB.EQ.1.0) THEN + VDIR(IDS)=-VDIR(IDS) + ELSE + CALL RANDF(ISEED,IFIRST,RAND) + TRACK=(RAND.LE.ALB) + VDIR(IDS)=-VDIR(IDS) + ENDIF + ELSE IF(ISUR2.NE.ISUR) THEN +* PERIODIC BOUNDARY CONDITION + IF(IPRINT.GT.4) WRITE(6,*) 'BC TRANSLATION FROM ',ISUR, + 1 ' TO',ISUR2 + IPSP=-ISUR + IEV=-INDIC(IDSO) + IF(IPRINT.GT.99) CALL MCTPSP(IPTRK,POS,IPSP,IEV) + IF(IDSO.GT.0) THEN + POS(IDS)=POS(IDS)-(XYZL(2,IDS)-XYZL(1,IDS)) + ELSE + POS(IDS)=POS(IDS)+(XYZL(2,IDS)-XYZL(1,IDS)) + ENDIF + IDSO=-IDSO + ELSE IF((ISUR2.EQ.ISUR).AND.(ANGBC.EQ.0)) THEN +* WHITE BOUNDARY CONDITION + ALB=ALBEDO(-ICODE(INDIC(IDSO))) + IF(ALB.EQ.0.0) THEN +* no leakage + ISONBR = 0 + TRACK = KILLED + ELSE +* otherwise, choose randomly according to albedo + CALL RANDF(ISEED,IFIRST,RAND) + TRACK=(RAND.LE.ALB) + IF(TRACK.EQV.ACTIVE) THEN +* FOR ISOTROPIC BC, CHOOSE RANDOMLY THE REENTERING +* DIRECTION + CALL RANDF(ISEED,IFIRST,RAND) + MU=2.D0*RAND-1.D0 + MUS=DSQRT(1.D0-MU*MU) + CALL RANDF(ISEED,IFIRST,RAND) + PHI=PI*RAND + VDIR(IDS)=-SIGN(1,IDSO)*MUS*SIN(PHI) + VDIR(INDOS(1,IDS))=MUS*COS(PHI) + VDIR(INDOS(2,IDS))=MU + DO IDIM=1,NDIM + IF(IDIM.NE.IDS) THEN + CALL RANDF(ISEED,IFIRST,RAND) + POS(IDIM)=XYZL(1,IDIM)+RAND*(XYZL(2,IDIM)- + 1 XYZL(1,IDIM)) + ENDIF + ENDDO + CALL RANDF(ISEED,IFIRST,RAND) + LENGTH=-LOG(RAND)/XSM + ELSE + ISONBR = 0 + ENDIF + ENDIF + ELSE + CALL XABORT('MCTRK: INVALID TYPE OF BOUNDARY CONDITION.') + ENDIF + ELSE +*---- +* CYLINDRICAL BOUNDARY +*---- + CALL XABORT('MCTRK: CYLINDRICAL BOUNDARY NOT IMPLEMENTED.') + ENDIF + IF(IPRINT.GT.99) THEN + IPSP=-IREG + IEV=-INDIC(IDSO) + CALL MCTPSP(IPTRK,POS,IPSP,IEV) + ENDIF + ENDIF +*---- +* SAVE NEUTRON PATHS IN NXT TABLE FOR PSP DISPLAY +*---- + IF(IPRINT.GT.99) THEN + IF(TRACK.EQV.KILLED) THEN + IPSP=-ABS(IREG) + ELSE + IPSP=ABS(IREG) + ENDIF + CALL MCTPSP(IPTRK,POS,IPSP,1) + ENDIF + ENDDO + RETURN + END diff --git a/Dragon/src/MESHST.f b/Dragon/src/MESHST.f new file mode 100644 index 0000000..b0d9c76 --- /dev/null +++ b/Dragon/src/MESHST.f @@ -0,0 +1,1924 @@ +*DECK MESHST + SUBROUTINE MESHST(IPTRK,IPGEOM,REMESH,FVOL,STAIRS,FACST,NCEL, + > IPLANZ,ISTATE,NCYL,NSECT,NCPHY,VOLSUR,MATALB,SIDE,NCOUR, + > NSMIN,NSMAX,NS,FACB,NVOL,SURB,VSYM,SSYM,IHEX,LXI,NV,MCODE, + > SURL,IPLANI,VLAT,ZMIN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* General numbering of hexagonal assembly. +* +*Copyright: +* Copyright (C) 1991 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): M. Ouisloumen +* +*Parameters: input +* MCODE =1 for Z- symmetry; =2 for Z+ symmetry; =0 otherwise. +* +*Parameters: input/output +* REMESH coordinates of geometry. +* FVOL first zone number. +* NVOL first volume number. +* STAIRS see TRKHEX. +* FACST see TRKHEX. +* NCEL number of cells. +* NSECT number of sectors in region. +* NCYL number of cylinders in cell. +* NCPHY number of physical cells. +* VOLSUR volumes and external surfaces +* MATALB material albedo vector. +* FACB first face number. +* SURB first cell number. +* VSYM initial geometry volumes. +* SSYM initial geometry surfaces. +* IPTRK undefined. +* IPGEOM undefined. +* IPLANZ undefined. +* ISTATE undefined. +* SIDE undefined. +* NCOUR undefined. +* NSMIN undefined. +* NSMAX undefined. +* NS undefined. +* IHEX undefined. +* LXI undefined. +* NV undefined. +* SURL undefined. +* IPLANI undefined. +* VLAT undefined. +* ZMIN undefined. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE + INTEGER NSTATE + REAL PI,SQRT3 + PARAMETER (NSTATE=40) + PARAMETER (PI=3.141592653589793,SQRT3=1.732050807568877) + TYPE(C_PTR) IPTRK,IPGEOM + INTEGER NCEL,IPLANZ,NCPHY,NCOUR,IHEX,LXI,NV,MCODE,IPLANI + INTEGER FVOL(NCEL),STAIRS(IPLANZ),FACST(IPLANZ), + > ISTATE(NSTATE),MATALB(*),NVOL(*),NSMIN,NSMAX,NS, + > NSECT(*),NCYL(NCEL),FACB(*),SURB(*), + > VSYM(*),SSYM(*),SURL(*),VLAT(*) + REAL REMESH(*),VOLSUR(*),SIDE,ZMIN +*---- +* LOCAL VARIABLES +*---- + CHARACTER TEXT12*12 + LOGICAL LGCELL,L1CELL,LGSS,LGTURN,LG3D,LGPASS,LSPLIT,LGMERG + REAL POIDSH + INTEGER IFONC,IFCOUR,N,L + INTEGER NEIGHB + INTEGER LLL,KSS,LX,LZ,ISTAT9,NDIM,LZZ,ILENT,ITP,ICEL2, + > I,ICEL0,NCOUS,ICOU,KCEL,LCEL,ILENZ,IAZ,K,IAUX, + > ISURFP,ISURF,ISAUX,JSUR,ISF,IPOINT,KREG,KSURF1, + > KSURF2,NSURF1,NSURF2,ISUR,ITC,ILENR,MDR,IOFS, + > NRAY,ILENSP,MADD,J,ISEC,LSECT,MIXF, + > IFVOL,NZONE,MVOL,JVOL,IVOL,ISURB,JSURB,IST,IY,KZAUX, + > NAUX,MIXX,JSP,KBB,JJ,IV,IS,ILENS,ITS,IC,KMIX,NMIX, + > IXZPL,KXI,NXI,LFF,LZF,ISTO,ISS1,IMERMX,ISZ, + > IFRT,IMER0,IMER1,ISX,IMERG,JMERG,MMCYL,IZON,IFF, + > ILENM,ISS,ICEL + INTEGER JSECT,LL,IZZ,KY,IMMS,IBSS,IFR0,IXX,ICCOIN,KCCOIN, + > MROT,NCPER,ISURSY,MSMAX,ISSXX,IPPZ,IPP1,IXP,JCCOIN, + > JP,MXI,IP,ISURB6,ITT9,ISURSX,KSURBX,K1,ICX,ICY,ICZ, + > IDEBX,NBASE,ICELC0,ICELC1,NCC,MCYL,NZONE1,IA, + > NSECTO,IV1,JVT,IVTURN,ITURN,KAUX,KVOL1,KVOL2, + > KSECTX,NZZ,ICXX,ICELC,ICLIM,IXX0,ISS0,JSS0,M,ISS2, + > IJSUR,KKB,IXV,LFROT,IVFIN,IVORIN,IVMIN,IVSYM,NZON, + > IVAUX,IVMAX,IVOR,IVV,IVSYM0,IVV1,KVV,KVOR,ISY,MSAUX, + > IVLMAX,NSAUX,IPPX,ISYAUX,LSMAX,LSPLZM,IDDX,KX2,KSECT + INTEGER KX1,KXP,IDEB,IYAUX,II,KSAUX,IVLAT,JTX,IX1,JX,IFR,IW, + > JW,MSUR,MCPHY,ISYX,LSPLZP + REAL VEX,X,Y,XM,YM,XP,YP,YPP,ZAUX,ZBUX,Z,SURF,R1,R2,PAS, + > VOLUM1,VOLUM2,R,VOLUME,VOLUMS,VCYL,SAUX,XTAN,SAUX1 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: VTURN,PHTURN,VOL1,ISECT,MXX, + + IMX,IMX2,ISSS,IMIX,IPSECT,ICC,ICELL,KNUM,NUMG,ITRN,ISPZ,KVOL,IBB, + + ITT,IAA + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISXY + REAL, ALLOCATABLE, DIMENSION(:) :: ZZZ,RAY,KRAY,RR + TYPE PP + REAL, POINTER, DIMENSION(:) :: R + INTEGER, POINTER, DIMENSION(:) :: I1,I2 + END TYPE PP + TYPE(PP), ALLOCATABLE, DIMENSION(:) :: IOF +*---- +* DATA +*---- + INTEGER ROT(12) + SAVE ROT + DATA ROT /2,3,4,5,6,1,6,1,2,3,4,5/ +* +* STATEMENT FUNCTIONS +*---- + IFONC(N,L)= 2+(N-1)*(L+3*(N-2)) + IFCOUR(N)=NINT( (4.+SQRT(1.+4.*FLOAT(N-1)/3.) + + +SQRT(1.+4.*FLOAT(N-2)/3.))*.25) +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(VOL1(NCPHY),VTURN(NCPHY),PHTURN(NCPHY)) +* + LZ=ISTATE(5) + LX=ISTATE(3) + ISTAT9=ISTATE(9) + LGCELL=.FALSE. + L1CELL=.FALSE. + LGSS=.FALSE. + LGTURN=.FALSE. + LG3D=.FALSE. + IF(ISTATE(8).EQ.1) LGCELL=.TRUE. + NDIM=2 + LZZ=1 + L1CELL=(LX.EQ.1) + IF(LZ.GT.0) THEN + NDIM=3 + LG3D=.TRUE. + LZZ=LZ + L1CELL=(LX*LZ.EQ.1) + ENDIF + VEX=1.5*SQRT(3.)*SIDE*SIDE + CALL LCMLEN(IPGEOM,'TURN',ILENT,ITP) + IF(ILENT.GT.0) LGTURN=.TRUE. + NCOUR=1 + IF(LX.GT.1)NCOUR=IFCOUR(LX) +* +* COORDONNEES DES CENTRES DES HEXAGONES +* + X=0. + Y=0. + XM=0. + YM=0. + YP=0. + XP=0. + ICEL=1 + 18 REMESH(ICEL)=X + REMESH(NCEL+ICEL)=Y + ICEL2=NEIGHB(ICEL,2,9,LX,POIDSH) + IF(ICEL2.GT.LX) GOTO 20 + ICEL=ICEL2 + Y=Y+SIDE*SQRT3 + GO TO 18 + 20 ICEL=1 + Y=0 + 21 ICEL2=NEIGHB(ICEL,5,9,LX,POIDSH) + IF(ICEL2.GT.LX) GOTO 22 + ICEL=ICEL2 + REMESH(ICEL)=X + Y=Y-SIDE*SQRT3 + REMESH(NCEL+ICEL)=Y + GOTO 21 + 22 CONTINUE + DO 30 I=2,NCOUR + LGPASS=.FALSE. + XP=XP+1.5*SIDE + YP=YP+.5*SIDE*SQRT3 + ICEL=IFONC(I,0) + ICEL0=ICEL + X=XP + Y=YP + YPP=YP + 23 REMESH(ICEL)=X + REMESH(NCEL+ICEL)=Y + ICEL2=NEIGHB(ICEL,2,9,LX,POIDSH) + IF(ICEL2.GT.LX) GOTO 25 + Y=Y+SIDE*SQRT3 + ICEL=ICEL2 + GO TO 23 + 25 ICEL=ICEL0 + Y=YP + 26 ICEL2=NEIGHB(ICEL,5,9,LX,POIDSH) + IF(ICEL2.GT.LX) GOTO 27 + Y=Y-SIDE*SQRT3 + ICEL=ICEL2 + REMESH(ICEL)=X + REMESH(NCEL+ICEL)=Y + GOTO 26 + 27 IF(LGPASS) GOTO 28 + XM=XM-1.5*SIDE + YM=YM+.5*SIDE*SQRT3 + YPP=YM + ICEL=IFONC(I,2) + ICEL0=ICEL + X=XM + Y=YM + LGPASS=.TRUE. + GO TO 23 + 28 CONTINUE + 30 CONTINUE +* +* POUR EVITER DES EFFETS DE DIFFERENCE +* + NCOUS=7 + DO 31 ICOU=3,NCOUR,2 + KCEL=IFONC(ICOU,0)+6*ICOU-NCOUS + LCEL=KCEL-3*(ICOU-1) + REMESH(NCEL+KCEL)=0. + REMESH(NCEL+LCEL)=0. + NCOUS=NCOUS+1 + 31 CONTINUE + STAIRS(1)=LX + IF(LG3D) THEN + CALL LCMSIX(IPTRK,'DATA_DUP',1) + CALL LCMLEN(IPTRK,'MESHZ',ILENZ,ITP) + IF(ILENZ.NE.LZZ+1)CALL XABORT('MESHST: MISSING DIMENSION MESHZ') + ALLOCATE(ZZZ(ILENZ)) + CALL LCMGET(IPTRK,'MESHZ',ZZZ) + CALL LCMSIX(IPTRK,' ',2) +* +*--- TEST SUR L'ORDONANCE DES PLANS DES CELLULES SUIVANT L'AXE Z +* + ZAUX=ZZZ(1) + ZMIN=ZAUX + DO 29 IAZ=1,ILENZ-1 + ZBUX=ZZZ(IAZ+1) + IF(ZAUX.GE.ZBUX)CALL XABORT('MESHST: WRONG CELLS PLAN POSITION') + ZAUX=ZBUX + 29 CONTINUE + Z=ZZZ(2) + DO 32 K=1,LX + REMESH(2*NCEL+K)=Z + 32 CONTINUE + IAUX=0 + DO 35 I=2,LZ + STAIRS(I)=I*LX + Z=ZZZ(I+1) + DO 33 K=1,LX + IAUX=IAUX+1 + REMESH(LX+IAUX)=REMESH(K) + REMESH(NCEL+LX+IAUX)=REMESH(NCEL+K) + REMESH(2*NCEL+LX+IAUX)=Z + 33 CONTINUE + 35 CONTINUE + ENDIF +* +* CALCUL DES SURFACES EXTERNES ET AFFECTATION DES ALBEDOS +* + ISURFP=6 + IF(NCOUR.GT.1)ISURFP=6*(3+2*(NCOUR-2)) + ISS=1 + ISURF=NS + ISAUX=ISURF + IF(LG3D) THEN + ISAUX=ISURF-NSMAX + ISS=NSMIN+1 + DO 70 I=1,NSMIN + MATALB(I)=-6 + 70 CONTINUE + DO 71 I=1,NSMAX + MATALB(ISAUX+I)=-5 + 71 CONTINUE + ENDIF + DO 75 I=ISS,ISAUX + MATALB(I)=-1 + 75 CONTINUE + JSUR=NS-NSMAX+1 + DO 80 K=1,LZZ + ISF=ISS+ISURFP-1 + SURF=SIDE + FACST(K)=ISF + ISS=ISF+1 + 80 CONTINUE + IPOINT=2*NCEL + IF(LG3D) THEN + IPOINT=3*NCEL + ENDIF +* + KREG=ISURF+1 + VOLSUR(KREG)=0. + MATALB(KREG)=0 + KSURF1=0 + KSURF2=ISAUX + NSURF1=NSMIN+1 + NSURF2=NS+1 + ISUR=0 + Z=0.0 + KSECT=0 + IF(L1CELL) THEN +* +* CAS D'UNE SEULE CELLULE +* + CALL LCMLEN(IPGEOM,'SECTOR',ILENS,ITC) + CALL LCMLEN(IPGEOM,'RADIUS',ILENR,ITP) + MDR=ILENR + IF(ILENR.EQ.0) MDR=1 + ALLOCATE(ISECT(MDR),MXX(MDR)) + CALL LCMLEN(IPGEOM,'MIX',ILENM,ITP) + IF(ILENS.GT.0) THEN + IF(ILENS.NE.MDR) CALL XABORT('MESHST: INCONSISTENT LENGTHS(1' + + //').') + CALL LCMGET(IPGEOM,'SECTOR',ISECT) + K=0 + DO J=1,MDR + K=K+6*(ISECT(J)-1) + ENDDO + IF(K.NE.ILENM) THEN + CALL XABORT('MESHST: SECTOR-DEFINED MIX INDICES EXPECTED(1' + + //').') + ENDIF + ALLOCATE(IMX2(ILENM)) + CALL LCMGET(IPGEOM,'MIX',IMX2) + IOFS=0 + DO J=1,MDR + IOFS=IOFS+1 + MXX(J)=IMX2(IOFS) + DO K=2,6*(ISECT(J)-1) + IOFS=IOFS+1 + IF(IMX2(IOFS).NE.MXX(J)) THEN + CALL XABORT('MESHST: SECTOR-DEPENDENT MIX NOT IM' + + //'PLEMENTED(1).') + ENDIF + ENDDO + ENDDO + DEALLOCATE(IMX2) + ELSE + IF(ILENM.NE.MDR) CALL XABORT('MESHST: INCONSISTENT LENGTHS(2' + + //').') + CALL LCMGET(IPGEOM,'MIX',MXX) + ISECT(:MDR)=1 + ENDIF + IF(ILENR.GT.0) THEN + ALLOCATE(RAY(ILENR)) + CALL LCMGET(IPGEOM,'RADIUS',RAY) + CALL LCMLEN(IPGEOM,'SPLITR',ILENSP,ITP) + IF(ILENSP.GT.0) THEN + IF(ITP.NE.1.OR.ILENSP.NE.ILENR-1) + + CALL XABORT('MESHST: '// + + 'MISSING TYPE OR DIMENSION OF SPLITR') + ALLOCATE(ISSS(ILENSP)) + CALL LCMGET(IPGEOM,'SPLITR',ISSS) + NRAY=0 + DO 101 I=1,ILENSP + NRAY=NRAY+ABS(ISSS(I)) + 101 CONTINUE + ALLOCATE(KRAY(NRAY+1),IMIX(NRAY+1),IPSECT(NRAY+1)) + R1=0.0 + MADD=-1 + KRAY(1)=0.0 + DO 103 J=1,ILENSP + ISEC=ISSS(J) + LSECT=ISECT(J) + MIXF=MXX(J) + IF(ISEC.EQ.0)CALL XABORT('MESHST: INVALID SPLITR') + IF(ISEC.GT.0) THEN + R2=RAY(J+1) + PAS=(R2-R1)/FLOAT(ISEC) + DO 111 K=1,ISEC + MADD=MADD+1 + KRAY(MADD+2)=R1+PAS*FLOAT(K) + IMIX(MADD+1)=MIXF + IPSECT(MADD+1)=LSECT + 111 CONTINUE + R1=R2 + ELSE + R2=RAY(J+1) + R1=R1**2 + R2=R2**2 + PAS=(R2-R1)/FLOAT(-ISEC) + DO 112 K=1,-ISEC + MADD=MADD+1 + KRAY(MADD+2)=SQRT(R1+PAS*FLOAT(K)) + IMIX(MADD+1)=MIXF + IPSECT(MADD+1)=LSECT + 112 CONTINUE + R1=SQRT(R2) + ENDIF + 103 CONTINUE + IMIX(NRAY+1)=MXX(ILENR) + IPSECT(NRAY+1)=ISECT(ILENR) + DEALLOCATE(MXX,ISSS,ISECT) + ALLOCATE(ISECT(NRAY+1)) + DO 104 J=1,NRAY+1 + ISECT(J)=IPSECT(J) + 104 CONTINUE + DEALLOCATE(IPSECT) + ELSE + NRAY=ILENR-1 + ALLOCATE(IMIX(NRAY+1),KRAY(NRAY+1)) + DO 105 J=1,NRAY+1 + IMIX(J)=MXX(J) + KRAY(J)=RAY(J) + 105 CONTINUE + ENDIF + DEALLOCATE(MXX,RAY) + ELSE + ALLOCATE(IMIX(MDR)) + DO 106 J=1,MDR + IMIX(J)=MXX(J) + 106 CONTINUE + DEALLOCATE(MXX) + NRAY=0 + ENDIF + IAUX=2 + IF(LG3D)IAUX=3*NCEL + IFVOL=0 + NZONE=NRAY+1 + MVOL=0 + JVOL=1 + IVOL=0 + ISURB=NSMIN + JSURB=0 + DO 119 I=1,NCEL + NVOL(I)=JVOL + IF(LG3D) THEN + Z=REMESH(2*NCEL+I) + IF(I.GT.STAIRS(1)) THEN + IST=1 + DO 129 IY=2,LZZ + IF(I.LE.STAIRS(IY)) THEN + IST=IY-1 + GOTO 139 + ENDIF + 129 CONTINUE + 139 KZAUX=I-STAIRS(IST) + IF(IST.GT.1)KZAUX=KZAUX+STAIRS(IST-1) + Z=Z-REMESH(2*NCEL+KZAUX) + ENDIF + ENDIF + NCYL(I)=NRAY + FVOL(I)=IFVOL+1 + IFVOL=IFVOL+NZONE + DO 117 J=1,NRAY + IAUX=IAUX+1 + REMESH(IAUX)=KRAY(J+1) + 117 CONTINUE + VOLUM1=0. + IF(LG3D) THEN + IF(IPLANZ.GT.1) THEN + IF(I.LE.STAIRS(1)) THEN + FACB(I)=KSURF1 + ELSEIF(I.GT.STAIRS(IPLANZ-1)) THEN + ISUR=ISUR+1 + FACB(LX+ISUR)=KSURF2 + ENDIF + ELSE + FACB(I)=KSURF1 + FACB(LX+I)=KSURF2 + ENDIF + ENDIF + NAUX=0 + DO 120 J=1,NRAY+1 + MVOL=MVOL+1 + KSECT=ISECT(J) + NSECT(MVOL)=KSECT + NAUX=1 + IF(KSECT.GT.1) NAUX=6*(KSECT-1) + IVOL=IVOL+NAUX + MIXX=IMIX(J) + KREG=KREG+1 + IF(J.EQ.NZONE) THEN + VOLUM2=VEX + ELSE + R=KRAY(J+1) + VOLUM2=PI*R*R + ENDIF + VOLUME=(VOLUM2-VOLUM1)/REAL(NAUX) + VOLUMS=0.0 + IF(LG3D) THEN + VOLUMS=VOLUME*.25 +* +* SURFACES SUPERIEURES ET INFERIEURES (SELON L'AXE Z) +* + IF(IPLANZ.GT.1) THEN + IF(I.LE.STAIRS(1)) THEN + KSURF1=KSURF1+1 + NSURF1=NSURF1-1 + VOLSUR(NSURF1)=VOLUMS + ELSEIF(I.GT.STAIRS(IPLANZ-1)) THEN + KSURF2=KSURF2+1 + NSURF2=NSURF2-1 + VOLSUR(NSURF2)=VOLUMS + ENDIF + ELSE + KSURF1=KSURF1+1 + NSURF1=NSURF1-1 + VOLSUR(NSURF1)=VOLUMS + KSURF2=KSURF2+1 + NSURF2=NSURF2-1 + VOLSUR(NSURF2)=VOLUMS + ENDIF + VOLUME=VOLUME*Z + ENDIF + VOLUM1=VOLUM2 + VOLSUR(KREG)=VOLUME + MATALB(KREG)=MIXX + DO 121 K=2,NAUX + KREG=KREG+1 + VOLSUR(KREG)=VOLUME + MATALB(KREG)=MIXX + IF(LG3D) THEN + IF(IPLANZ.GT.1) THEN + IF(I.LE.STAIRS(1)) THEN + KSURF1=KSURF1+1 + NSURF1=NSURF1-1 + VOLSUR(NSURF1)=VOLUMS + ELSEIF(I.GT.STAIRS(IPLANZ-1)) THEN + KSURF2=KSURF2+1 + NSURF2=NSURF2-1 + VOLSUR(NSURF2)=VOLUMS + ENDIF + ELSE + KSURF1=KSURF1+1 + NSURF1=NSURF1-1 + VOLSUR(NSURF1)=VOLUMS + KSURF2=KSURF2+1 + NSURF2=NSURF2-1 + VOLSUR(NSURF2)=VOLUMS + ENDIF + ENDIF + 121 CONTINUE + JVOL=IVOL+1 + 120 CONTINUE + SURF=SIDE + JSP=6 + KBB=1 + IF(KSECT.GT.1) THEN + SURF=SIDE/(KSECT-1) + JSP=NAUX + KBB=KSECT-1 + ENDIF + IF(LG3D)SURF=SURF*Z + DO 118 JJ=1,JSP + JSUR=JSUR-1 + VOLSUR(JSUR)=.25*SURF + 118 CONTINUE + DO 122 JJ=1,6 + JSURB=JSURB+1 + SURB(JSURB)=ISURB + ISURB=ISURB+KBB + 122 CONTINUE + 119 CONTINUE + DEALLOCATE(IMIX,ISECT) + IF(LG3D) DEALLOCATE(ZZZ) + IF(NRAY.GT.0) DEALLOCATE(KRAY) + DO 715 IV=1,NV + VSYM(IV)=IV + 715 CONTINUE + DO 716 IS=1,NS + SSYM(IS)=IS + 716 CONTINUE + GO TO 800 + ENDIF +* CAS D'UN ASSEMBLAGE DE CELLULE +* + IPP1=0 + MROT=0 + MSMAX=0 + ALLOCATE(ISXY(6,MAX(IPLANZ,IPLANI))) + IF(LGCELL) THEN +* +* SPLITING DES RAYONS ET DEFINITION DES SECTEURS POUR +* LES CELLULES GENERATRICES +* + ALLOCATE(IOF(ISTAT9),ICC(ISTAT9),ICELL(3*ISTAT9)) + CALL LCMGET(IPGEOM,'CELL',ICELL) + DO 10 I=1,ISTAT9 + WRITE(TEXT12(1:4),'(A4)') ICELL(3*I-2) + WRITE(TEXT12(5:8),'(A4)') ICELL(3*I-1) + WRITE(TEXT12(9:12),'(A4)') ICELL(3*I) + CALL LCMSIX(IPGEOM,TEXT12,1) + CALL LCMLEN(IPGEOM,'RADIUS',ILENR,ITP) + CALL LCMLEN(IPGEOM,'SECTOR',ILENS,ITS) + IF(ILENR.GT.0) THEN + ALLOCATE(ISECT(ILENR),IMX(ILENR)) + CALL LCMLEN(IPGEOM,'MIX',ILENM,ITP) + IF(ILENS.GT.0) THEN + IF(ILENS.NE.ILENR) CALL XABORT('MESHST: INCONSISTENT L' + + //'ENGTHS(3).') + CALL LCMGET(IPGEOM,'SECTOR',ISECT) + K=0 + DO J=1,ILENR + K=K+6*(ISECT(J)-1) + ENDDO + IF(K.NE.ILENM) THEN + CALL XABORT('MESHST: SECTOR-DEFINED MIX INDICES EXPE' + + //'CTED(2).') + ENDIF + ALLOCATE(IMX2(ILENM)) + CALL LCMGET(IPGEOM,'MIX',IMX2) + IOFS=0 + DO J=1,ILENR + IOFS=IOFS+1 + IMX(J)=IMX2(IOFS) + DO K=2,6*(ISECT(J)-1) + IOFS=IOFS+1 + IF(IMX2(IOFS).NE.IMX(J)) THEN + CALL XABORT('MESHST: SECTOR-DEPENDENT MIX NOT IM' + + //'PLEMENTED(2).') + ENDIF + ENDDO + ENDDO + DEALLOCATE(IMX2) + ELSE + IF(ILENM.NE.ILENR) CALL XABORT('MESHST: INCONSISTENT L' + + //'ENGTHS(4).') + ISECT(:ILENR)=1 + CALL LCMGET(IPGEOM,'MIX',IMX) + ENDIF + CALL LCMLEN(IPGEOM,'SPLITR',ILENSP,ITP) + IF(ILENSP.GT.0) THEN + IF(ITP.NE.1.OR.ILENSP.NE.ILENR-1) + + CALL XABORT('MESHST: '// + + 'MISSING TYPE OR DIMENSION OF SPLITR') + ALLOCATE(RR(ILENR)) + CALL LCMGET(IPGEOM,'RADIUS',RR) + ALLOCATE(ISSS(ILENSP)) + CALL LCMGET(IPGEOM,'SPLITR',ISSS) + NRAY=1 + DO 5 J=1,ILENSP + NRAY=NRAY+ABS(ISSS(J)) + 5 CONTINUE + ALLOCATE(IOF(I)%R(NRAY),IOF(I)%I1(NRAY),IOF(I)%I2(NRAY)) + KMIX=0 + DO 7 J=1,ILENR-1 + NMIX=IMX(J) + ISEC=ISSS(J) + LSECT=ISECT(J) + IF(ISEC.EQ.0)CALL XABORT('MESHST: INVALID SPLITR') + DO 6 L=1,ABS(ISEC) + IOF(I)%I1(KMIX+1)=NMIX + IOF(I)%I2(KMIX+1)=LSECT + KMIX=KMIX+1 + 6 CONTINUE + 7 CONTINUE + IOF(I)%I1(KMIX+1)=IMX(ILENR) + IOF(I)%I2(KMIX+1)=ISECT(ILENR) + IOF(I)%R(1)=0.0 + R1=0. + IAUX=0 + DO 109 K=1,ILENSP + ISEC=ISSS(K) + IF(ISEC.EQ.0)CALLXABORT('MESHST: INVALID SPLITR') + IF(ISEC.GT.0) THEN + R2=RR(K+1) + PAS=(R2-R1)/FLOAT(ISEC) + DO 8 L=1,ISEC + IAUX=IAUX+1 + IOF(I)%R(IAUX+1)=R1+PAS*REAL(L) + 8 CONTINUE + R1=R2 + ELSE + R2=RR(K+1) + R1=R1**2 + R2=R2**2 + PAS=(R2-R1)/FLOAT(-ISEC) + DO 108 L=1,-ISEC + IAUX=IAUX+1 + IOF(I)%R(IAUX+1)=SQRT(R1+PAS*REAL(L)) + 108 CONTINUE + R1=SQRT(R2) + ENDIF + 109 CONTINUE + DEALLOCATE(ISSS,RR) + ICC(I)=NRAY-1 + ELSE + ICC(I)=ILENR-1 + ALLOCATE(IOF(I)%R(ILENR)) + CALL LCMGET(IPGEOM,'RADIUS',IOF(I)%R) + ALLOCATE(IOF(I)%I1(ILENR),IOF(I)%I2(ILENR)) + DO 9 J=1,ILENR + IOF(I)%I1(J)=IMX(J) + IOF(I)%I2(J)=ISECT(J) + 9 CONTINUE + ENDIF + DEALLOCATE(IMX,ISECT) + ELSE + ICC(I)=0 + ALLOCATE(IOF(I)%I1(1),IOF(I)%I2(1)) + CALL LCMLEN(IPGEOM,'MIX',ILENM,ITP) + IF(ILENS.GT.0) THEN + CALL LCMGET(IPGEOM,'SECTOR',IOF(I)%I2(1)) + IF(6*(IOF(I)%I2(1)-1).NE.ILENM) THEN + CALL XABORT('MESHST: SECTOR-DEFINED MIX INDICES EXPE' + + //'CTED(3).') + ENDIF + ALLOCATE(IMX2(ILENM)) + CALL LCMGET(IPGEOM,'MIX',IMX2) + DO K=2,6*(IOF(I)%I2(1)-1) + IF(IMX2(K).NE.IMX2(1)) THEN + CALL XABORT('MESHST: SECTOR-DEPENDENT MIX NOT IMPL' + + //'EMENTED(3).') + ENDIF + ENDDO + IOF(I)%I1(1)=IMX2(1) + DEALLOCATE(IMX2) + ELSE + IF(ILENM.NE.1) CALL XABORT('MESHST: INCONSISTENT LENGT' + + //'HS(5).') + CALL LCMGET(IPGEOM,'MIX',IOF(I)%I1(1)) + IOF(I)%I2(1)=1 + ENDIF + ENDIF + IF(ILENS.EQ.0) THEN + IF(LGTURN)CALL XABORT('MESHST: SECTOR MUST BE DEFINED '// + + 'OR CANCEL TURN ') + ENDIF + CALL LCMSIX(IPGEOM,' ',2) + 10 CONTINUE +*--- NUMEROTATION DES VOLUMES DE LA SYMETRIE D'ENTREE + IXZPL=IPLANZ + IF(MCODE.GT.0)IXZPL=IPLANI + KXI=LXI*IXZPL + NXI=KXI + IF(IHEX.LE.9) THEN + CALL LCMSIX(IPTRK,'DATA_DUP',1) + CALL LCMLEN(IPTRK,'SPLITZD',LFF,KSS) + CALL LCMSIX(IPTRK,' ',2) + LSPLIT=.FALSE. + LZF=IXZPL + IF(LFF.GT.0) THEN + LZF=LFF + NXI=LXI*LZF + LSPLIT=.TRUE. + ENDIF + ALLOCATE(KNUM(2*NXI),NUMG(NXI)) + CALL LCMLEN(IPGEOM,'MERGE',LLL,KSS) + LGMERG=.FALSE. + IF(LLL.GT.0) THEN + CALL LCMGET(IPGEOM,'MERGE',KNUM) + LGMERG=.TRUE. + CALL LCMGET(IPGEOM,'MIX',NUMG) + DO I=1,NXI + NUMG(I)=-NUMG(I) + ENDDO + ELSE + CALL LCMGET(IPGEOM,'MIX',KNUM) + DO I=1,NXI + KNUM(I)=-KNUM(I) + NUMG(I)=KNUM(I) + ENDDO + ENDIF + IF(LGTURN) THEN + CALL LCMGET(IPGEOM,'TURN',KNUM(NXI+1)) + ELSE + KNUM(NXI+1:2*NXI)=1 + LGTURN=.TRUE. + ENDIF + IVOL=0 + ISTO=0 + ALLOCATE(ITRN(KXI*3),ISPZ(LZF)) + IF(LSPLIT) THEN + CALL LCMSIX(IPTRK,'DATA_DUP',1) + CALL LCMGET(IPTRK,'SPLITZD',ISPZ) + CALL LCMSIX(IPTRK,' ',2) + ELSE + ISPZ(:LZF)=1 + ENDIF + ALLOCATE(KVOL(KXI)) + ISS=-1 + ISS1=-1 + IMERMX=0 + DO 182 ISZ=1,LZF + IFRT=ISS1 + IMER0=KNUM(LXI*ISZ) + IMER1=IMER0 + DO 482 ISX=1,LXI + ISS=ISS+1 + ISS1=ISS1+1 + IMERG=KNUM(ISS1+1) + JMERG=NUMG(ISS1+1) + MMCYL=ICC(JMERG) + IF(LSPLIT) THEN + IMER0=MAX(IMER0,IMERG) + IMER1=MIN(IMER1,IMERG) + ENDIF + IZON=0 + IZZ=0 + LL=0 + DO 171 IFF=1,MMCYL+1 + JSECT=IOF(JMERG)%I2(IFF) + IF(JSECT.GT.1) THEN + LL=JSECT-1 + IZZ=6*LL + ELSE + LL=1 + IZZ=1 + ENDIF + IZON=IZON+IZZ + 171 CONTINUE + IMERG=IMERG+IMERMX + IF(LGMERG) THEN + DO 281 KY=1,ISTO + IF(IMERG.EQ.ITRN(KXI+KY)) THEN + IMMS=ITRN(2*KXI+KY) + IBSS=KVOL(IMMS+1) + KVOL(ISS+1)=IBSS + ITRN(ISS+1)=ITRN(IMMS+1) + GOTO 381 + ENDIF + 281 CONTINUE + ENDIF + ITRN(KXI+ISTO+1)=IMERG + ITRN(2*KXI+ISTO+1)=ISS + ISTO=ISTO+1 + KVOL(ISS+1)=IVOL+1 + IVOL=IVOL+IZON + ITRN(ISS+1)=IVOL-IZZ+LL*ROT(KNUM(NXI+ISS1+1)) + 381 CONTINUE + 482 CONTINUE + IF(LSPLIT) THEN + IFR0=IFRT + DO 582 IXX=1,ISPZ(ISZ)-1 + IMERMX=IMERMX+IMER0-IMER1+1 + IFRT=IFR0 + DO 682 ISX=1,LXI + ISS=ISS+1 + IFRT=IFRT+1 + IMERG=KNUM(IFRT+1) + JMERG=NUMG(IFRT+1) + MMCYL=ICC(JMERG) + IZON=0 + IZZ=0 + LL=0 + DO 671 IFF=1,MMCYL+1 + JSECT=IOF(JMERG)%I2(IFF) + IF(JSECT.GT.1) THEN + LL=JSECT-1 + IZZ=6*LL + ELSE + LL=1 + IZZ=1 + ENDIF + IZON=IZON+IZZ + 671 CONTINUE + IMERG=IMERG+IMERMX + IF(LGMERG) THEN + DO 681 KY=1,ISTO + IF(IMERG.EQ.ITRN(KXI+KY)) THEN + IMMS=ITRN(2*KXI+KY) + IBSS=KVOL(IMMS+1) + KVOL(ISS+1)=IBSS + ITRN(ISS+1)=ITRN(IMMS+1) + GOTO 781 + ENDIF + 681 CONTINUE + ENDIF + ITRN(KXI+ISTO+1)=IMERG + ITRN(2*KXI+ISTO+1)=ISS + ISTO=ISTO+1 + KVOL(ISS+1)=IVOL+1 + IVOL=IVOL+IZON + ITRN(ISS+1)=IVOL-IZZ+LL*ROT(KNUM(NXI+IFRT+1)) + 781 CONTINUE + 682 CONTINUE + 582 CONTINUE + ENDIF + 182 CONTINUE +*--- RECHERCHE DU NOMBRE DE SURFACES QUE PRESENTE LA SYMETRIE + ICCOIN=-1 + JCCOIN=-1 + KCCOIN=-1 + MROT=6 + NCPER=0 + IF(IHEX.EQ.1) THEN + NCPER=NINT(REAL(NCOUR)/2.) + ELSEIF(IHEX.EQ.2) THEN + NCPER=NCOUR + MROT=3 + ELSEIF(IHEX.EQ.3) THEN + NCPER=2*NINT(REAL(NCOUR)/2.)-1 + ICCOIN=LXI-NINT(REAL(NCPER)/2.)+1 + MROT=3 + ELSEIF(IHEX.EQ.4) THEN + NCPER=3*NINT(REAL(NCOUR)/2.)-2 + IF(MOD(NCOUR,2).EQ.0)NCPER=NCPER+1 + ICCOIN=LXI-NCPER+NINT(REAL(NCOUR)/2.) + MROT=2 + ELSEIF(IHEX.EQ.5) THEN + NCPER=1 + IF(NCOUR.GT.1)NCPER=2*(NCOUR-1) + ICCOIN=LXI-NCPER+NCOUR-1 + KCCOIN=LXI + MROT=3 + ELSEIF(IHEX.EQ.6) THEN + NCPER=1 + IF(NCOUR.GT.1)NCPER=4+3*(NCOUR-2)-1 + KCCOIN=LXI-NCPER+NCOUR-1 + ICCOIN=KCCOIN+NCOUR-1 + JCCOIN=ICCOIN+NCOUR-1 + MROT=2 + ELSEIF(IHEX.EQ.7) THEN + NCPER=1 + IF(NCOUR.GT.1)NCPER=3*NCOUR-2 + ICCOIN=LXI-NCOUR+1 + KCCOIN=ICCOIN-NCOUR+1 + MROT=1 + ELSEIF(IHEX.EQ.8) THEN + NCPER=1 + IF(NCOUR.GT.1)NCPER=2*(NCOUR+NINT(REAL(NCOUR)/2.))-3 + JCCOIN=LXI-NINT(REAL(NCOUR)/2.)+1 + KCCOIN=JCCOIN-NCOUR+1 + ICCOIN=KCCOIN-NCOUR+1 + MROT=1 + ELSEIF(IHEX.EQ.9) THEN + MROT=1 + NCPER=1 + IF(NCOUR.GT.1) NCPER=6*(NCOUR-1) + ICCOIN=IFONC(NCOUR,0) + JCCOIN=IFONC(NCOUR,1) + KCCOIN=IFONC(NCOUR,2) + ELSE + CALL XABORT('MESHST: INVALID TYPE OF SYMETRIE ') + ENDIF + ISURSY=0 + ISAUX=1 + MSMAX=0 + ISSXX=0 + IPPZ=LZF + IPP1=IPLANZ + IF(MCODE.GT.0) IPP1=IPLANI + ISXY(:6,:IPP1)=0 + IXP=0 + DO 500 JP=1,IPPZ + MXI=LXI*(JP-1) + DO 501 IP=IXP+1,IXP+ISPZ(JP) + ISURB6=0 + ITT9=NUMG(LXI+MXI) + ISURSX=IOF(ITT9)%I2(ICC(ITT9)+1)-1 + KSURBX=ISURSX + IF(ISURSX.EQ.0) THEN + ISURSX=1 + KSURBX=1 + ENDIF + JSECT=0 + DO 183 K1=LXI+MXI,LXI+MXI-NCPER+1,-1 + K=NUMG(K1) + JSECT=IOF(K)%I2(ICC(K)+1) + ICX=2 + IF(IHEX.GT.2) THEN + IF(K1.EQ.ICCOIN+MXI)ICX=3 + IF(K1.EQ.JCCOIN+MXI)ICX=3 + IF(K1.EQ.KCCOIN+MXI)ICX=3 + IF(IHEX.EQ.9) THEN + IF(K1.EQ.MXI+IFONC(NCOUR,3))ICX=3 + IF(K1.EQ.MXI+IFONC(NCOUR,4))ICX=3 + IF(K1.EQ.MXI+IFONC(NCOUR,5))ICX=3 + ENDIF + IF(K1.GE.ICCOIN+MXI) THEN + IF(IHEX.LE.4) THEN + IF(K1.EQ.MXI+LXI.AND.MOD(NCOUR,2).NE.0) THEN + ICY=1 + IF(IHEX.EQ.4)ICY=2 + ISURB6=ISURB6+ICY*(JSECT-1) + IF(JSECT.EQ.1)ISURB6=ISURB6+ICY + IF(IHEX.EQ.3) ICX=1 + ELSE + ISURB6=ISURB6+2*(JSECT-1) + IF(JSECT.EQ.1)ISURB6=ISURB6+2 + ENDIF + ELSE + ICZ=ICX + IF(K1.EQ.ICCOIN+MXI)ICZ=2 + ISURB6=ISURB6+ICZ*(JSECT-1) + IF(JSECT.EQ.1)ISURB6=ISURB6+ICZ + ENDIF + ENDIF + ENDIF + IF(JSECT.GT.1) THEN + ISURSY=ISURSY+ICX*(JSECT-1) + ELSE + ISURSY=ISURSY+ICX + ENDIF + 183 CONTINUE + IDEBX=2 + IF(JSECT.GT.1)IDEBX=JSECT + IF(IHEX.EQ.1.OR.IHEX.EQ.3.OR.IHEX.EQ.4.OR.IHEX.EQ.8) THEN + IF(MOD(NCOUR,2).NE.0) THEN + IF(JSECT.GT.1) THEN + ISURSY=ISURSY-JSECT+1 + ELSE + ISURSY=ISURSY-1 + ENDIF + IF(IHEX.EQ.8) THEN + ISURSY=ISURSY-ISURSX + ISURB6=ISURB6-ISURSX + ENDIF + ENDIF + ENDIF + ISXY(1,IP)=ISURSY + ISXY(2,IP)=ISURSX + ISXY(3,IP)=ISURB6 + ISXY(4,IP)=IDEBX+ISAUX-1 + ISXY(5,IP)=KSURBX + ISXY(6,IP)=ISAUX + ISAUX=ISURSY+1 + MSMAX=MSMAX+ISURSY-ISSXX + ISSXX=ISURSY + 501 CONTINUE + IXP=IXP+ISPZ(JP) + 500 CONTINUE + DEALLOCATE(KNUM,NUMG,ISPZ) + ENDIF + DEALLOCATE(ICELL) + NBASE=NCEL+NCEL + IF(LGTURN)NBASE=NBASE+NCEL + ALLOCATE(IBB(NBASE)) + CALL LCMSIX(IPTRK,'DATA_DUP',1) + CALL LCMGET(IPTRK,'GENERATING',IBB) + CALL LCMGET(IPTRK,'MERGE',IBB(NCEL+1)) + IF(LGTURN)CALL LCMGET(IPTRK,'TURN',IBB(2*NCEL+1)) + CALL LCMSIX(IPTRK,' ',2) + VOL1(:NCPHY)=0 + VTURN(:NCPHY)=0 + IAUX=IPOINT + IFVOL=1 + MVOL=0 + ICELC0=IFONC(NCOUR,0) + ICELC1=IFONC(NCOUR,1)-ICELC0 + JVOL=1 + IVOL=0 + ISURB=NSMIN + JSURB=0 + DO 100 I=1,NCEL + NVOL(I)=JVOL + IF(LG3D) THEN + DO 40 J=1,LZZ + NCC=J*LX + IF(I.LE.NCC) THEN + Z=ZZZ(J) + GO TO 42 + ENDIF + 40 CONTINUE + ENDIF + 42 CONTINUE + MCYL=ICC(IBB(I)) + IF(MCYL.GT.0) THEN +* +* STORAGE DES COORDONNEES DES CYLINDRES +* ==> ATTENTION: LES AXES DES CYLINDRES SONT SELON Z +* + DO 43 J=1,MCYL + IAUX=IAUX+1 + REMESH(IAUX)=IOF(IBB(I))%R(J+1) + 43 CONTINUE + ENDIF + NCYL(I)=MCYL + NZONE1=1+MCYL + NZONE=0 + DO 60 IA=1,NZONE1 + NZONE=NZONE+IOF(IBB(I))%I2(IA) + 60 CONTINUE + NSECTO=IOF(IBB(I))%I2(NZONE1) + MCPHY=IBB(NCEL+I) + IV1=VOL1(MCPHY) + IF(IV1.GT.0) THEN + IF(LGTURN) THEN + JVT=PHTURN(MCPHY) + IVTURN=VTURN(MCPHY) + ITURN=IBB(2*NCEL+I) + KAUX=NSECTO-1 + IF(ITURN.LE.6) THEN + IF(ITURN.NE.6)KAUX=KAUX*(ITURN+1) + ELSEIF(ITURN.GE.9) THEN + KAUX=(ITURN-8)*KAUX + ELSEIF(ITURN.EQ.7) THEN + KAUX=5*KAUX + ENDIF + ENDIF + ELSE + KVOL1=1 + IF(MCPHY.GT.1)KVOL1=VOL1(MCPHY-1) + KVOL2=KVOL1+NZONE-1 + IF(LGTURN) THEN + ITURN=IBB(2*NCEL+I) + PHTURN(MCPHY)=ITURN + IF(ITURN.LE.6) THEN + IF(ITURN.EQ.6) THEN + VTURN(MCPHY)=KVOL2+NSECTO-1 + ELSE + VTURN(MCPHY)=KVOL2+(NSECTO-1)*(ITURN+1) + ENDIF + ELSEIF(ITURN.GE.8) THEN + VTURN(MCPHY)=KVOL2+(NSECTO-1)*(ITURN-8)+1 + ELSE + VTURN(MCPHY)=KVOL2+(NSECTO-1)*5+1 + ENDIF + ENDIF + VOL1(MCPHY)=KVOL2+1 + ENDIF + VOLUM1=0. + IF(LG3D) THEN + IF(IPLANZ.GT.1) THEN + IF(I.LE.STAIRS(1)) THEN + FACB(I)=KSURF1 + ELSEIF(I.GT.STAIRS(IPLANZ-1)) THEN + ISUR=ISUR+1 + FACB(LX+ISUR)=KSURF2 + ENDIF + ELSE + FACB(I)=KSURF1 + FACB(LX+I)=KSURF2 + ENDIF + Z=REMESH(2*NCEL+I) + IF(I.GT.STAIRS(1)) THEN + IST=1 + DO 329 IY=2,LZZ + IF(I.LE.STAIRS(IY)) THEN + IST=IY-1 + GOTO 339 + ENDIF + 329 CONTINUE + 339 KZAUX=I-STAIRS(IST) + IF(IST.GT.1)KZAUX=KZAUX+STAIRS(IST-1) + Z=Z-REMESH(2*NCEL+KZAUX) + ENDIF + ENDIF + KSECTX=IOF(IBB(I))%I2(NZONE1) + NZZ=NZONE1 + IF(KSECTX.GT.3)NZZ=NZONE1-1 + DO 45 J=1,NZZ + MIXX=IOF(IBB(I))%I1(J) + KSECT=IOF(IBB(I))%I2(J) + NAUX=1 + IF(KSECT.GT.1) NAUX=6*(KSECT-1) + IVOL=IVOL+NAUX + MVOL=MVOL+1 + NSECT(MVOL)=KSECT + KREG=KREG+1 + IF(J.EQ.NZONE1) THEN + VOLUM2=VEX + ELSE + R=IOF(IBB(I))%R(J+1) + VOLUM2=PI*R*R + ENDIF + VOLUMS=0.0 + VOLUME=(VOLUM2-VOLUM1)/REAL(NAUX) + IF(LG3D) THEN + VOLUMS=VOLUME*.25 + VOLUME=VOLUME*Z +* +* SURFACES SUPERIEURES ET INFERIEURES (SELON L'AXE Z) +* + IF(IPLANZ.GT.1) THEN + IF(I.LE.STAIRS(1)) THEN + KSURF1=KSURF1+1 + NSURF1=NSURF1-1 + VOLSUR(NSURF1)=VOLUMS + ELSEIF(I.GT.STAIRS(IPLANZ-1)) THEN + KSURF2=KSURF2+1 + NSURF2=NSURF2-1 + VOLSUR(NSURF2)=VOLUMS + ENDIF + ELSE + KSURF1=KSURF1+1 + NSURF1=NSURF1-1 + VOLSUR(NSURF1)=VOLUMS + KSURF2=KSURF2+1 + NSURF2=NSURF2-1 + VOLSUR(NSURF2)=VOLUMS + ENDIF + ENDIF + VOLUM1=VOLUM2 + VOLSUR(KREG)=VOLUME + MATALB(KREG)=MIXX + DO 44 K=2,NAUX + KREG=KREG+1 + VOLSUR(KREG)=VOLUME + MATALB(KREG)=MIXX + IF(LG3D) THEN + IF(IPLANZ.GT.1) THEN + IF(I.LE.STAIRS(1)) THEN + KSURF1=KSURF1+1 + NSURF1=NSURF1-1 + VOLSUR(NSURF1)=VOLUMS + ELSEIF(I.GT.STAIRS(IPLANZ-1)) THEN + KSURF2=KSURF2+1 + NSURF2=NSURF2-1 + VOLSUR(NSURF2)=VOLUMS + ENDIF + ELSE + KSURF1=KSURF1+1 + NSURF1=NSURF1-1 + VOLSUR(NSURF1)=VOLUMS + KSURF2=KSURF2+1 + NSURF2=NSURF2-1 + VOLSUR(NSURF2)=VOLUMS + ENDIF + ENDIF + 44 CONTINUE + 45 CONTINUE + ICXX=LX*INT(AINT(REAL(I/(LX+1)))) + ICELC=ICELC0+ICXX + ICLIM=LX+ICXX + IF(KSECTX.GT.3) THEN +* +* TRAITEMENT DU VOLUME A BORDURE HEXAGONALE DANS LE CAS OU KSECT>3 +* + KSECT=KSECTX + MIXX=IOF(IBB(I))%I1(NZONE1+1) + NAUX=6*(KSECT-1) + IVOL=IVOL+NAUX + MVOL=MVOL+1 + NSECT(MVOL)=KSECT + VCYL=VOLUM1/REAL(NAUX) + SAUX=0. + IXX0=KREG + ISS0=NSURF1 + JSS0=NSURF2 + DO 445 M=1,KSECT-1 + IXX=IXX0 + ISS1=ISS0 + ISS2=JSS0 + XTAN=TAN(REAL(M)*PI/(3*(KSECT-1))) + SAUX1=XTAN/(1.+XTAN/SQRT3) + VOLUME=.5*SIDE*SIDE*(SAUX1-SAUX) + VOLUME=VOLUME-VCYL + VOLUMS=VOLUME + IF(LG3D) VOLUME=VOLUME*Z + DO 444 K=1,6 + IXX=IXX+1 + KREG=KREG+1 + VOLSUR(IXX)=VOLUME + MATALB(IXX)=MIXX + IF(LG3D) THEN + IF(IPLANZ.GT.1) THEN + IF(I.LE.STAIRS(1)) THEN + KSURF1=KSURF1+1 + NSURF1=NSURF1-1 + ISS1=ISS1-1 + VOLSUR(ISS1)=VOLUMS + ELSEIF(I.GT.STAIRS(IPLANZ-1)) THEN + KSURF2=KSURF2+1 + NSURF2=NSURF2-1 + ISS2=ISS2-1 + VOLSUR(ISS2)=VOLUMS + ENDIF + ELSE + KSURF1=KSURF1+1 + NSURF1=NSURF1-1 + ISS1=ISS1-1 + VOLSUR(ISS1)=VOLUMS + KSURF2=KSURF2+1 + NSURF2=NSURF2-1 + ISS2=ISS2-1 + VOLSUR(ISS2)=VOLUMS + ENDIF + ISS1=ISS1-KSECT+2 + ISS2=ISS2-KSECT+2 + ENDIF + IXX=IXX+KSECT-2 + 444 CONTINUE + IF(I.GE.ICELC.AND.I.LE.ICLIM) THEN + SURF=.5*SIDE*(SAUX1-SAUX)/SQRT3 + IF(LG3D)SURF=SURF*Z + JSUR=JSUR-1 + VOLSUR(JSUR)=SURF + IJSUR=JSUR-KSECT+1 + VOLSUR(IJSUR)=SURF + IF(MOD(I-ICELC,ICELC1).EQ.0) THEN + IJSUR=IJSUR-KSECT+1 + VOLSUR(IJSUR)=SURF + ENDIF + ENDIF + IXX0=IXX0+1 + ISS0=ISS0-1 + JSS0=JSS0-1 + SAUX=SAUX1 + 445 CONTINUE + IF(I.GE.ICELC.AND.I.LE.ICLIM) THEN + JSUR=JSUR-KSECT+1 + JSURB=JSURB+2 + SURB(JSURB-1)=ISURB + KKB=KSECT-1 + ISURB=ISURB+KKB+KKB + SURB(JSURB)=ISURB-KKB + IF(MOD(I-ICELC,ICELC1).EQ.0) THEN + JSUR=JSUR-KSECT+1 + JSURB=JSURB+1 + SURB(JSURB)=ISURB + ISURB=ISURB+KKB + ENDIF + ENDIF + ELSE + IF(I.GE.ICELC.AND.I.LE.ICLIM) THEN + SURF=SIDE*.25 + IF(LG3D)SURF=SURF*Z + KKB=1 + IF(KSECT.GT.1) THEN + KKB=KSECT-1 + SURF=SURF/KKB + ENDIF + DO 99 IXX=1,KKB + JSUR=JSUR-2 + VOLSUR(JSUR)=SURF + VOLSUR(JSUR+1)=SURF + IF(MOD(I-ICELC,ICELC1).EQ.0) THEN + JSUR=JSUR-1 + VOLSUR(JSUR)=SURF + ENDIF + 99 CONTINUE + JSURB=JSURB+2 + SURB(JSURB-1)=ISURB + ISURB=ISURB+KKB+KKB + SURB(JSURB)=ISURB-KKB + IF(MOD(I-ICELC,ICELC1).EQ.0) THEN + JSURB=JSURB+1 + SURB(JSURB)=ISURB + ISURB=ISURB+KKB + ENDIF + ENDIF + ENDIF + JVOL=IVOL+1 + FVOL(I)=IFVOL + IFVOL=IFVOL+NZONE1 + 100 CONTINUE + DO 110 I=1,ISTAT9 + DEALLOCATE(IOF(I)%I1,IOF(I)%I2) + IF(ICC(I).GT.0) DEALLOCATE(IOF(I)%R) + 110 CONTINUE + DEALLOCATE(IOF,ICC) + ELSE +* +* CAS DE CELLULE HOMOGENES +* + ALLOCATE(IBB(2*NCEL)) + CALL LCMSIX(IPTRK,'DATA_DUP',1) + CALL LCMGET(IPTRK,'MERGE',IBB) + CALL LCMGET(IPTRK,'MIX',IBB(NCEL+1)) + CALL LCMSIX(IPTRK,' ',2) + CALL LCMLEN(IPGEOM,'SECTOR',ILENS,ITP) + ALLOCATE(ICC(NCEL)) + IF(ILENS.GT.0) THEN + CALL XABORT('MESHST: SECTORS NOT IMPLEMENTED.') + ELSE + ICC(:NCEL)=1 + ENDIF + IF(LGTURN) THEN + CALL LCMSIX(IPTRK,'DATA_DUP',1) + ALLOCATE(ITT(NCEL)) + CALL LCMGET(IPTRK,'TURN',ITT) + CALL LCMSIX(IPTRK,' ',2) + ENDIF + VOL1(:NCPHY)=0 + IFVOL=1 + MVOL=0 + ICELC0=IFONC(NCOUR,0) + ICELC1=IFONC(NCOUR,1)-ICELC0 + JVOL=1 + IVOL=0 + ISURB=NSMIN + JSURB=0 + DO 200 I=1,NCEL + NVOL(I)=JVOL + NSECTO=ICC(I) + ICXX=LX*INT(AINT(REAL(I/(LX+1)))) + ICELC=ICELC0+ICXX + ICLIM=LX+ICXX + NSECT(I)=NSECTO + NCYL(I)=0 + NZONE=1 + IF(NSECTO.GT.1)NZONE=6*(NSECTO-1) + IVOL=IVOL+NZONE + JVOL=IVOL+1 + MCPHY=IBB(I) + IV1=VOL1(MCPHY) + IF(IV1.GT.0) THEN + IF(LGTURN) THEN + JVT=PHTURN(MCPHY) + IVTURN=VTURN(MCPHY) + KAUX=NSECTO-1 + ITURN=ITT(I) + IF(ITURN.LE.6) THEN + IF(ITURN.NE.6)KAUX=KAUX*(ITURN+1) + ELSEIF(ITURN.GE.9) THEN + KAUX=(ITURN-8)*KAUX + ELSEIF(ITURN.EQ.7) THEN + KAUX=5*KAUX + ENDIF + ENDIF + ELSE + KVOL1=1 + IF(MCPHY.GT.1)KVOL1=VOL1(MCPHY-1) + KVOL2=KVOL1+NZONE-1 + IF(LGTURN) THEN + ITURN=ITT(I) + PHTURN(MCPHY)=ITURN + IF(ITURN.LE.6) THEN + IF(ITURN.EQ.6) THEN + VTURN(MCPHY)=KVOL2+NSECTO-1 + ELSE + VTURN(MCPHY)=KVOL2+(NSECTO-1)*(ITURN+1) + ENDIF + ELSEIF(ITURN.GE.8) THEN + VTURN(MCPHY)=KVOL2+(NSECTO-1)*(ITURN-8)+1 + ELSE + VTURN(MCPHY)=KVOL2+(NSECTO-1)*5+1 + ENDIF + ENDIF + VOL1(MCPHY)=KVOL2+1 + ENDIF + IF(NSECTO.LE.3) THEN + IF(I.GE.ICELC.AND.I.LE.ICLIM) THEN + SURF=SIDE*.25 + IF(LG3D)SURF=SURF*Z + KKB=1 + IF(NSECTO.GT.1) THEN + KKB=NSECTO-1 + SURF=SURF/(NSECTO-1) + ENDIF + DO 556 IXX=1,KKB + JSUR=JSUR-2 + VOLSUR(JSUR)=SURF + VOLSUR(JSUR+1)=SURF + IF(MOD(I-ICELC,ICELC1).EQ.0) THEN + JSUR=JSUR-1 + VOLSUR(JSUR)=SURF + ENDIF + 556 CONTINUE + JSURB=JSURB+2 + SURB(JSURB-1)=ISURB + ISURB=ISURB+KKB+KKB + SURB(JSURB)=ISURB-KKB + IF(MOD(I-ICELC,ICELC1).EQ.0) THEN + JSURB=JSURB+1 + SURB(JSURB)=ISURB + ISURB=ISURB+KKB + ENDIF + ENDIF + VOLUMS=0.0 + VOLUME=VEX/NZONE + IF(LG3D) THEN + Z=REMESH(2*NCEL+I) + IF(I.GT.STAIRS(1)) THEN + IST=1 + DO 429 IY=2,LZZ + IF(I.LE.STAIRS(IY)) THEN + IST=IY-1 + GOTO 439 + ENDIF + 429 CONTINUE + 439 KZAUX=I-STAIRS(IST) + IF(IST.GT.1)KZAUX=KZAUX+STAIRS(IST-1) + Z=Z-REMESH(2*NCEL+KZAUX) + ENDIF + VOLUMS=VOLUME*.25 + VOLUME=VOLUME*Z +* +* SURFACES SUPERIEURES ET INFERIEURES (SELON L'AXE Z) +* + IF(IPLANZ.GT.1) THEN + IF(I.LE.STAIRS(1)) THEN + FACB(I)=KSURF1 + KSURF1=KSURF1+1 + NSURF1=NSURF1-1 + VOLSUR(NSURF1)=VOLUMS + ELSEIF(I.GT.STAIRS(IPLANZ-1)) THEN + ISUR=ISUR+1 + FACB(LX+ISUR)=KSURF2 + KSURF2=KSURF2+1 + NSURF2=NSURF2-1 + VOLSUR(NSURF2)=VOLUMS + ENDIF + ELSE + FACB(I)=KSURF1 + FACB(LX+I)=KSURF2 + KSURF1=KSURF1+1 + NSURF1=NSURF1-1 + VOLSUR(NSURF1)=VOLUMS + KSURF2=KSURF2+1 + NSURF2=NSURF2-1 + VOLSUR(NSURF2)=VOLUMS + ENDIF + ENDIF + MIXX=IBB(NCEL+I) + DO 65 J=1,NZONE + KREG=KREG+1 + VOLSUR(KREG)=VOLUME + MATALB(KREG)=MIXX + IF(LG3D) THEN + IF(IPLANZ.GT.1) THEN + IF(I.LE.STAIRS(1)) THEN + KSURF1=KSURF1+1 + NSURF1=NSURF1-1 + VOLSUR(NSURF1)=VOLUMS + ELSEIF(I.GT.STAIRS(IPLANZ-1)) THEN + KSURF2=KSURF2+1 + NSURF2=NSURF2-1 + VOLSUR(NSURF2)=VOLUMS + ENDIF + ELSE + KSURF1=KSURF1+1 + NSURF1=NSURF1-1 + VOLSUR(NSURF1)=VOLUMS + KSURF2=KSURF2+1 + NSURF2=NSURF2-1 + VOLSUR(NSURF2)=VOLUMS + ENDIF + ENDIF + 65 CONTINUE + ELSE +* +* TRAITEMENT DU CAS OU NSECTO>3 +* + KSECT=NSECTO + MIXX=IBB(NCEL+I) + NAUX=6*(KSECT-1) + IVOL=IVOL+NAUX + MVOL=MVOL+1 + NSECT(MVOL)=KSECT + SAUX=0. + IXX0=KREG + ISS0=NSURF1 + JSS0=NSURF2 + DO 555 M=1,KSECT-1 + IXX=IXX0 + ISS1=ISS0 + ISS2=JSS0 + XTAN=TAN(REAL(M)*PI/(3*(KSECT-1))) + SAUX1=XTAN/(1.+XTAN/SQRT3) + VOLUME=.5*SIDE*SIDE*(SAUX1-SAUX) + VOLUMS=VOLUME + IF(LG3D) VOLUME=VOLUME*Z + DO 554 K=1,6 + IXX=IXX+1 + KREG=KREG+1 + VOLSUR(IXX)=VOLUME + MATALB(IXX)=MIXX + IF(LG3D) THEN + IF(IPLANZ.GT.1) THEN + IF(I.LE.STAIRS(1)) THEN + KSURF1=KSURF1+1 + NSURF1=NSURF1-1 + ISS1=ISS1-1 + VOLSUR(ISS1)=VOLUMS + ELSEIF(I.GT.STAIRS(IPLANZ-1)) THEN + KSURF2=KSURF2+1 + NSURF2=NSURF2-1 + ISS2=ISS2-1 + VOLSUR(ISS2)=VOLUMS + ENDIF + ELSE + KSURF1=KSURF1+1 + NSURF1=NSURF1-1 + ISS1=ISS1-1 + VOLSUR(ISS1)=VOLUMS + KSURF2=KSURF2+1 + NSURF2=NSURF2-1 + ISS2=ISS2-1 + VOLSUR(ISS2)=VOLUMS + ENDIF + ISS1=ISS1-KSECT+2 + ISS2=ISS2-KSECT+2 + ENDIF + IXX=IXX+KSECT-2 + 554 CONTINUE + IF(I.GE.ICELC.AND.I.LE.ICLIM) THEN + SURF=.5*SIDE*(SAUX1-SAUX)/SQRT3 + IF(LG3D)SURF=SURF*Z + JSUR=JSUR-1 + VOLSUR(JSUR)=SURF + IJSUR=JSUR-KSECT+1 + VOLSUR(IJSUR)=SURF + IF(MOD(I-ICELC,ICELC1).EQ.0) THEN + IJSUR=IJSUR-KSECT+1 + VOLSUR(IJSUR)=SURF + ENDIF + ENDIF + IXX0=IXX0+1 + ISS0=ISS0-1 + JSS0=JSS0-1 + SAUX=SAUX1 + 555 CONTINUE + IF(I.GE.ICELC.AND.I.LE.ICLIM) THEN + JSUR=JSUR-KSECT+1 + JSURB=JSURB+2 + SURB(JSURB-1)=ISURB + KKB=KSECT-1 + ISURB=ISURB+KKB+KKB + SURB(JSURB)=ISURB-KKB + IF(MOD(I-ICELC,ICELC1).EQ.0) THEN + JSUR=JSUR-KSECT+1 + JSURB=JSURB+1 + SURB(JSURB)=ISURB + ISURB=ISURB+KKB + ENDIF + ENDIF + ENDIF + FVOL(I)=IFVOL + IFVOL=IFVOL+1 + 200 CONTINUE + DEALLOCATE(ICC) + IF(LGTURN) DEALLOCATE(ITT) + ENDIF + IF(LG3D) DEALLOCATE(ZZZ) +* +*--- CONSTRUCTION DU VECTEUR VSYM QUI CONTIENT POUR CHAQUE VOLUME DE +*--- DE L'ASSEMBLAGE SON EQUIVALENT DANS LA SYMETRIE D'ENTREE +* + IF(LGCELL.AND.(IHEX.LE.9)) THEN + ALLOCATE(IAA(NCEL)) + CALL LCMSIX(IPTRK,'DATA_DUP',1) + CALL LCMGET(IPTRK,'GENER0',IAA) + CALL LCMSIX(IPTRK,' ',2) + IXV=0 + DO 300 IC=1,NCEL + MCYL=NCYL(IC) + LFROT=ROT(IBB(2*NCEL+IC)) + IVFIN=KVOL(IAA(IC)) + IVORIN=ITRN(IAA(IC)) + IVMIN=IVFIN + IVSYM=NVOL(IC) + IXX=IXV + NZON=0 + DO 310 I=1,MCYL + IXX=IXX+1 + LSECT=NSECT(IXX) + IF(LSECT.GT.1) THEN + NZON=NZON+6*(LSECT-1) + ELSE + NZON=NZON+1 + ENDIF + 310 CONTINUE + LSECT=NSECT(IXX+1) + IF(LSECT.GT.1) THEN + IVAUX=INT(REAL(IVORIN-IVFIN-NZON+1)/REAL(LSECT-1)) + ELSE + IVAUX=IVORIN-IVFIN-NZON+1 + ENDIF + DO 320 K=1,MCYL+1 + IXV=IXV+1 + LSECT=NSECT(IXV) + IF(LSECT.EQ.1) THEN + VSYM(IVSYM)=IVMIN + IVMAX=IVMIN + ELSE + IVOR=IVMIN+IVAUX*(LSECT-1)-1 + IVV=LFROT-1 + IVSYM0=IVSYM + IVSYM=IVSYM+6*(LSECT-1)-1 + IVMAX=IVMIN+6*(LSECT-1)-1 + IF(IBB(2*NCEL+IC).LE.6) THEN + IVV1=LFROT*(LSECT-1) + IVV=(5-IVV)*(LSECT-1) + ELSE + IVV1=IVV*(LSECT-1)+1 + IVV=(6-IVV)*(LSECT-1)-1 + ENDIF + IF(IBB(2*NCEL+IC).LE.6) THEN + KVV=IVSYM-IVV + KVOR=IVOR + DO 315 L=KVV,IVSYM + VSYM(L)=KVOR + KVOR=KVOR+1 + IF(KVOR.GT.IVMAX)KVOR=IVMIN + 315 CONTINUE + DO 316 L=IVSYM0,KVV-1 + VSYM(L)=KVOR + KVOR=KVOR+1 + IF(KVOR.GT.IVMAX)KVOR=IVMIN + 316 CONTINUE + ELSE + KVV=IVSYM0+IVV1-1 + KVOR=IVOR + DO 317 L=KVV,IVSYM0,-1 + VSYM(L)=KVOR + KVOR=KVOR+1 + IF(KVOR.GT.IVMAX)KVOR=IVMIN + 317 CONTINUE + DO 318 L=IVSYM,KVV+1,-1 + VSYM(L)=KVOR + KVOR=KVOR+1 + IF(KVOR.GT.IVMAX)KVOR=IVMIN + 318 CONTINUE + ENDIF + ENDIF + IVMIN=IVMAX+1 + IVSYM=IVSYM+1 + 320 CONTINUE + 300 CONTINUE + DEALLOCATE(IAA) +*--- CONSTRUCTION DU VECTEUR SSYM QUI CONTIENT POUR CHAQUE SURFACE +*--- DE L'ASSEMBLAGE SON EQUIVALENT DANS LA SYMETRIE D'ENTREE + ISY=0 + MSAUX=NS + ISYX=NSMIN+1 + IVLMAX=0 + IF(LG3D) THEN + MSAUX=(NS-NSMIN-NSMAX)/IPLANZ +*--- CAS DE LA SYMETRIE Z- (MCODE=1) SSYM EST REMPLIT PLUS LOIN + IF(MCODE.NE.1) THEN + IF(IHEX.NE.9) THEN + DO 301 ISUR=1,NSMIN + SSYM(ISUR)=VSYM(ISUR) + IVLMAX=MAX(IVLMAX,VSYM(ISUR)) + 301 CONTINUE + ELSE + DO 311 ISUR=1,NSMIN + SSYM(ISUR)=ISUR + 311 CONTINUE + IVLMAX=NSMIN + ENDIF + ENDIF + ISY=NSMIN + ENDIF + IPPZ=IPP1 + NSAUX=0 + IF(MCODE.EQ.1) THEN + DO 302 IPPX=IPPZ+1,IPLANZ + NSAUX=NSAUX+(SURL(IPPX)-SURL(IPPX-1)) + 302 CONTINUE + ISYX=ISYX+NSAUX + ENDIF + MSAUX=0 + ISYAUX=ISYX + LSMAX=NSMIN+NSAUX + IF(MCODE.EQ.0) LSMAX=NS + LSPLZM=2*IPPZ-IPLANZ + DO 600 IP=1,IPPZ + IF(LG3D) THEN + IF(MCODE.EQ.1) THEN + LSMAX=LSMAX+(SURL(IPPZ-LSPLZM+IP)-SURL(IPPZ-LSPLZM-1+IP)) + ISYAUX=ISYAUX+MSAUX + MSAUX=SURL(IPPZ-LSPLZM+IP)-SURL(IPPZ-LSPLZM-1+IP) + ELSE + LSMAX=NSMIN+SURL(IP) + ISYAUX=ISYX+MSAUX + MSAUX=SURL(IP) + ENDIF + ENDIF + ISY=ISYAUX-1 + ISURSY=ISXY(1,IP) + ISURSX=ISXY(2,IP) + ISURB6=ISXY(3,IP) + IDEBX=ISXY(4,IP) + KSURBX=ISXY(5,IP) + ISAUX=ISXY(6,IP) + IDDX=ISURSX + KX2=ISURSY + KX1=ISURSY-ISURSX+1 + KXP=1 + IF(IHEX.GE.3) THEN + ISY=ISURB6+ISY + IF(IHEX.EQ.3.OR.IHEX.EQ.8) THEN + IDDX=0 + KX2=KX1 + KX1=ISURSY + KXP=-1 + ENDIF + IF(IHEX.EQ.4.OR.IHEX.EQ.7)ISY=ISY-KSURBX + ENDIF + IDEB=ISAUX + IF(IHEX.EQ.2.OR.IHEX.EQ.7)IDEB=IDEBX + IF(IHEX.EQ.5.OR.IHEX.EQ.6) THEN + IDDX=-ISURSY + ISURSX=0 + ISURSY=0 + KX1=0 + KX2=-1 + ENDIF + DO 400 I=1,MROT + DO 349 K=KX1,KX2,KXP + ISY=ISY+1 + IF(IHEX.GE.3) THEN + IF(ISY.GT.LSMAX) ISY=ISYAUX + ENDIF + SSYM(ISY)=K+IVLMAX + 349 CONTINUE + IF(IHEX.LT.9) THEN + DO 350 K=ISURSY-ISURSX,ISAUX,-1 + ISY=ISY+1 + IF(IHEX.GE.3) THEN + IF(ISY.GT.LSMAX) ISY=ISYAUX + ENDIF + SSYM(ISY)=K+IVLMAX + 350 CONTINUE + ENDIF + DO 351 K=IDEB,ISURSY-IDDX + ISY=ISY+1 + IF(IHEX.GE.3) THEN + IF(ISY.GT.LSMAX) ISY=ISYAUX + ENDIF + SSYM(ISY)=K+IVLMAX + 351 CONTINUE + 400 CONTINUE + 600 CONTINUE +* +*---SURFACE LATERALES SUPERIEURES DANS LE CAS 3D +* + IF(LG3D) THEN + IYAUX=0 + IF(MCODE.LE.1) THEN + IF(IPLANZ.GT.1) THEN + IYAUX=IVLMAX + DO 599 II=NSMIN+1,NV-NSMAX + IYAUX=MAX(VSYM(II),IYAUX) + 599 CONTINUE + ENDIF + IF(IHEX.NE.9) THEN + IAUX=NV-NSMAX + DO 601 II=NS-NSMAX+1,NS + IAUX=IAUX+1 + SSYM(II)=IVLMAX+MSMAX+VSYM(IAUX)-IYAUX + 601 CONTINUE + ELSE + IAUX=0 + IF(MCODE.GT.0) THEN + KSAUX=SURL(IPLANI) + ELSE + KSAUX=SSYM(NS-NSMAX) + ENDIF + DO 611 II=NS-NSMAX+1,NS + IAUX=IAUX+1 + SSYM(II)=IAUX+KSAUX + 611 CONTINUE + ENDIF + ENDIF +*--- CAS DE SYMETRIE Z- + IF(MCODE.EQ.1) THEN + IF(IHEX.NE.9) THEN + DO 602 IV=1,NSMAX + SSYM(IV)=IVLMAX+MSMAX+VSYM(IV)-IYAUX + 602 CONTINUE + ELSE + IVLAT=1 + IAUX=0 + JTX=NS-NSMAX + DO 612 IX1=1,NCOUR + DO 613 JX=JTX+VLAT(NCOUR+IX1),JTX+IVLAT,-1 + IAUX=IAUX+1 + SSYM(IAUX)=SSYM(JX) + 613 CONTINUE + DO 614 JX=JTX+VLAT(IX1),JTX+VLAT(NCOUR+IX1)+1,-1 + IAUX=IAUX+1 + SSYM(IAUX)=SSYM(JX) + 614 CONTINUE + IVLAT=VLAT(IX1)+1 + 612 CONTINUE + ENDIF + IFR=NSMIN + LSPLZM=2*IPLANI-IPLANZ + DO 605 IW=IPLANZ,IPPZ+1,-1 + DO 603 JW=SURL(IPLANZ+IW),SURL(IW-1)+1,-1 + IFR=IFR+1 + SSYM(IFR)=SSYM(NSMIN+JW) + 603 CONTINUE + DO 604 JW=SURL(IW),SURL(IPLANZ+IW)+1,-1 + IFR=IFR+1 + SSYM(IFR)=SSYM(NSMIN+JW) + 604 CONTINUE + 605 CONTINUE + ELSEIF(MCODE.EQ.2) THEN + IFR=NS-NSMAX+1 + MSUR=0 + LSPLZP=2*IPLANI-IPLANZ + DO 705 IW=1,IPPZ-LSPLZP + DO 704 JW=SURL(IPLANZ+IW)+1,SURL(IW) + IFR=IFR-1 + SSYM(IFR)=SSYM(NSMIN+JW) + 704 CONTINUE + DO 703 JW=MSUR+1,SURL(IPLANZ+IW) + IFR=IFR-1 + SSYM(IFR)=SSYM(NSMIN+JW) + 703 CONTINUE + MSUR=SURL(IW) + 705 CONTINUE + IF(IHEX.NE.9) THEN + IAUX=NV-NSMIN + DO 706 II=NS-NSMAX+1,NS + IAUX=IAUX+1 + SSYM(II)=VSYM(IAUX) + 706 CONTINUE + ELSE + IVLAT=1 + IAUX=NS-NSMAX + DO 712 IX1=1,NCOUR + DO 713 JX=VLAT(NCOUR+IX1),IVLAT,-1 + IAUX=IAUX+1 + SSYM(IAUX)=SSYM(JX) + 713 CONTINUE + DO 714 JX=VLAT(IX1),VLAT(NCOUR+IX1)+1,-1 + IAUX=IAUX+1 + SSYM(IAUX)=SSYM(JX) + 714 CONTINUE + IVLAT=VLAT(IX1)+1 + 712 CONTINUE + ENDIF + ENDIF + ENDIF + DEALLOCATE(IBB,KVOL,ITRN) + ELSE + DO 717 ISUR=1,NS + SSYM(ISUR)=ISUR + 717 CONTINUE + DO 718 IVOL=1,NV + VSYM(IVOL)=IVOL + 718 CONTINUE + ENDIF + DEALLOCATE(ISXY) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 800 DEALLOCATE(PHTURN,VTURN,VOL1) + RETURN + END diff --git a/Dragon/src/MOCCAL.f b/Dragon/src/MOCCAL.f new file mode 100644 index 0000000..2188bf1 --- /dev/null +++ b/Dragon/src/MOCCAL.f @@ -0,0 +1,71 @@ +*DECK MOCCAL + SUBROUTINE MOCCAL(N,NOMCEL,NREG,MCUW,MCUI,LMCU,LMXMCU) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of connection matrices. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): I. Suslov +* +*Parameters: input +* N number of segments on this track. +* NOMCEL integer tracking elements. +* NREG number of volumes. +* LMCU dimension (used) of MCUW. +* LMXMCU real dimension of MCUW MCUI. +* +*Parameters: input/output +* MCUW Suslov W correction matrix. +* MCUI Suslov I correction matrix. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,NOMCEL(N),NREG,MCUW(LMXMCU),MCUI(LMXMCU),LMCU,LMXMCU +* + CHARACTER HSMG*131 +* + DO 10 I=1,N + ICEL=NOMCEL(I) + IF (ICEL.LE.NREG) THEN + IF (I.EQ.N) THEN + ICEL1=NOMCEL(1) + ELSE + ICEL1=NOMCEL(I+1) + ENDIF + IF((ICEL.EQ.ICEL1).OR.(ICEL1.GT.NREG)) GOTO 6 +* IS THERE AREADY AN ELEMENT IN MATRIX FOR CELL ICEL ? + IF (MCUW(ICEL).NE.0) GOTO 5 +* NO : + MCUW(ICEL)=ICEL1 + GOTO 6 +* YES : + 5 II=ICEL + IF(MCUW(II).EQ.ICEL1) GOTO 6 + ICEL=MCUI(II) + IF(ICEL.NE.0) GOTO 5 +* ADD NEW ELEMENT + LMCU=LMCU+1 + IF(LMCU.GT.LMXMCU) THEN + WRITE(HSMG,'(42HMOCCAL: MEMORY OVERFLOW. INCREASE MCU. LMX, + 1 4HMCU=,I10,1H.)') LMXMCU + CALL XABORT(HSMG) + ENDIF + MCUW(LMCU)=ICEL1 + MCUI(II)=LMCU + 6 CONTINUE + ENDIF + 10 CONTINUE +* + RETURN + END diff --git a/Dragon/src/MOCCHR.f b/Dragon/src/MOCCHR.f new file mode 100644 index 0000000..dad21fb --- /dev/null +++ b/Dragon/src/MOCCHR.f @@ -0,0 +1,158 @@ +*DECK MOCCHR + SUBROUTINE MOCCHR(NDIM,NANI,NFUNL,NMU,XMUANG,PHI1,PHI2,R) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Generates all spherical harmonics R(L,M) at point (XMUANG,PHI1). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* NDIM number of dimensions for the geometry. +* NANI scattering anisotropy (=0 for isotropic scattering). +* NFUNL number of spherical harmonics per polar angle. +* NMU order of the polar quadrature in 2D and 1 in 3D. +* XMUANG cosines of the different tracking polar angles +* (polar quadrature in 2D and tracking angles in 3D). +* PHI1 first cosine of the tracking azimuthal angle. +* PHI2 second cosine of the tracking azimuthal angle. +* +*Parameters: output +* R spherical harmonics. +* +*Comments: +* for 0 <= L <= NANI (and for -L <= M <= L) +* and for all angles (for 1 <= IMU <= NMU). +* Definition of spherical harmonics R(L,M): +* R(L, M)= FACT(L,M)*P(L,M)*COS(M*PHI1) for 0 < M <= L +* R(L, 0)= P(L,0) +* R(L,-M)= FACT(L,M)*P(L,M)*SIN(M*PHI1) for 0 < M <= L +* where FACT(L,M)= SQRT( 2*(L-M)!/(L+M)! ) +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NDIM,NANI,NFUNL,NMU + REAL XMUANG(NMU),R(NMU,NFUNL) + DOUBLE PRECISION PHI1,PHI2 +*---- +* LOCAL VARIABLES +*---- + INTEGER IMU,L,M,LPM,LMMP1,IND,NSELEC + LOGICAL LROK + DOUBLE PRECISION DPHI,DCOP2,DSIP2,DL00,DL10,DL01,DL11,DM0,DM1, + > DM2,DCOS,DSIN,DCOT,DFAC,DZERO,DONE + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: RWORK + PARAMETER ( DZERO= 0.0D0, DONE= 1.0D0 ) +* +* INDEX FOR MATRIX 'RWORK' + IND(L,M)= L*(L+1) + M + 1 +* +***** FIRST, COMPUTES ALL SPHERICAL HARMONICS +* +* GENERATES ALL LEGENDRE POLYNOMIALS P(L,M) AT POINT XMU +* FOR 0 <= L <= NANI (AND FOR 0 <= M <= L) +* USING THE RECURENCE RELATIONS: +* P(L+1,M)= ((2*L+1)*XMU*P(L,M)-(L+M)*P(L-1,M))/(L-M+1) +* P(L,M+1)= 2*M*XMU*P(L,M)/SQRT(1-XMU**2)-(L+M)*(L-M+1)*P(L,M-1) +* +* ESTABLISH SIMPLE CASES + ALLOCATE(RWORK(NMU,(NANI+1)*(NANI+1))) + IF( NANI.GE.0 )THEN + DO 10 IMU= 1, NMU + RWORK(IMU,IND(0,0))= DONE + 10 CONTINUE + ELSE + CALL XABORT('MOCCHR: THE FIRST ARGUMENT MUST NON NEGATIVE') + ENDIF +* + IF( NANI.GE.1 )THEN + DPHI = SIGN(ACOS(PHI1),PHI2) + DO 40 IMU= 1, NMU + DCOS= DBLE(XMUANG(IMU)) + DSIN= SQRT( DONE - DCOS *DCOS ) + RWORK(IMU,IND(1,-1))= DSIN*PHI2 + RWORK(IMU,IND(1, 0))= DCOS + RWORK(IMU,IND(1, 1))= DSIN*PHI1 +* + IF( NANI.GE.2 )THEN +* RECURENCE PLG(IND(L,0)),PLG(IND(L,1) FOR 2 <= L <= NANI + DCOT= DCOS/DSIN + DL00= DONE + DL10= DCOS + DL01= DZERO + DL11= DSIN + DO 30 L= 1, NANI-1 +* IF M=1, L=L+1 THEN L+M=L+2, L-M+1=L+1 + LPM= L + 2 + LMMP1= L + 1 + DFAC= (DONE+DONE)/DBLE(LPM*LMMP1) + DM0=(DBLE(2*L+1)*DCOS*DL10 - DBLE(L)*DL00)/DBLE(L+1) + DM1=(DBLE(2*L+1)*DCOS*DL11 - DBLE(L+1)*DL01)/DBLE(L) +* ESTABLISH RELATIONS FOR L=L+1, ABS(M)<=1 + RWORK(IMU,IND(L+1,-1))= SQRT(DFAC)*DM1*PHI2 + RWORK(IMU,IND(L+1, 0))= DM0 + RWORK(IMU,IND(L+1, 1))= SQRT(DFAC)*DM1*PHI1 + DL00= DL10 + DL01= DL11 + DL10= DM0 + DL11= DM1 +* RECURENCE PLG(IND(L,M)) FOR 2 <= M <= L + DO 20 M= 1, L +* HERE DM0=PLG(L+1,0), DM1=PLG(L+1,1) +* ESTABLISH RELATIONS FOR L=L+1, ABS(M)>1 + DFAC= DFAC/DBLE((LMMP1-1)*(LPM+1)) + DCOP2= COS(DBLE(M+1)*DPHI) + DSIP2= SIN(DBLE(M+1)*DPHI) + DM2= DBLE(2*M)*DCOT*DM1 - DBLE(LPM*LMMP1)*DM0 + RWORK(IMU,IND(L+1,-(M+1)))= SQRT(DFAC)*DM2*DSIP2 + RWORK(IMU,IND(L+1, M+1 ))= SQRT(DFAC)*DM2*DCOP2 + DM0= DM1 + DM1= DM2 + LPM= LPM + 1 + LMMP1= LMMP1 - 1 + 20 CONTINUE + 30 CONTINUE + ENDIF + 40 CONTINUE + ENDIF +* +***** SELECTS THE GOOD SPHERICAL HARMONICS RWORK(L,M) FUNCTIONS +* FOR NDIM=1(SLAB),2(TWO-D RECT),3(THREE-D). +* COMPRESSES RWORK INTO R. +* + NSELEC= 0 + LROK= .FALSE. + DO 80 L= 0, NANI + DO 70 M= -L, L + IF( NDIM.EQ.1 )THEN + LROK= M.EQ.0 + ELSEIF( NDIM.EQ.2 )THEN + LROK= MOD(L+M,2).EQ.0 + ELSEIF( NDIM.EQ.3 )THEN + LROK= .TRUE. + ENDIF + IF( LROK )THEN + NSELEC= NSELEC+1 + DO 50 IMU= 1, NMU + R(IMU,NSELEC)= REAL(RWORK(IMU,IND(L,M))) + 50 CONTINUE + ENDIF + 70 CONTINUE + 80 CONTINUE + IF(NSELEC.NE.NFUNL) CALL XABORT('MOCCHR: INVALID NSELEC') + DEALLOCATE(RWORK) +* + RETURN + END diff --git a/Dragon/src/MOCDDF.f b/Dragon/src/MOCDDF.f new file mode 100644 index 0000000..96b61a2 --- /dev/null +++ b/Dragon/src/MOCDDF.f @@ -0,0 +1,84 @@ +*DECK MOCDDF + SUBROUTINE MOCDDF(N,NREG,NSOUT,M,NOM,NZON,H,SIGANG,EXPT,EXP2,NMU, + 1 ZMU) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculate coefficients of a track for the cyclic characteristics +* integration: Diamond-Differencing scheme without fix-up and +* 'source term isolation' option turned on. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy and R. Le Tellier +* +*Parameters: input +* N number of elements in the current track. +* NREG number of volumes. +* NSOUT number of surfaces. +* M number of material mixtures. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* H vector containing the lenght of the different segments of this +* track. +* SIGANG macroscopic total cross sections and albedos. +* NMU order of the polar quadrature set. +* ZMU inverse of polar quadrature cosines. +* +*Parameters: output +* EXPT track coefficient. +* EXP2 quadratic expansion of (1-exp(-a*L))/L with small argument. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,NREG,NSOUT,M,NOM(N),NZON(-NSOUT:NREG),NMU + REAL SIGANG(-6:M),ZMU(NMU) + DOUBLE PRECISION H(N),EXPT(NMU,N),EXP2(NMU,N) +*---- +* LOCAL VARIABLES +*---- + INTEGER I,NOMI,NUMOLD,NZI,IMU + DOUBLE PRECISION HID,TAUD,TEMP,TEMP2 +* + NUMOLD=NOM(1) + DO I=1,N + NOMI=NOM(I) + NZI=NZON(NOMI) + IF (NZI.LT.0) THEN + IF (NUMOLD.NE.NOMI) THEN + DO IMU=1,NMU + EXP2(IMU,I)=SIGANG(NZI) + EXPT(IMU,I)=EXP2(IMU,I) + ENDDO + ELSE + DO IMU=1,NMU + EXP2(IMU,I)=1.D0 + EXPT(IMU,I)=EXP2(IMU,I) + ENDDO + ENDIF + ELSE + DO IMU=1,NMU + HID=DBLE(H(I)*ZMU(IMU)) + TAUD=SIGANG(NZI)*HID + TEMP=1.D0/(2.D0+TAUD) + TEMP2=TEMP+TEMP + EXPT(IMU,I)=TEMP2-TAUD*TEMP + EXP2(IMU,I)=TEMP2*HID + ENDDO + ENDIF + NUMOLD=NOMI + ENDDO +* + RETURN + END diff --git a/Dragon/src/MOCDDFL.f b/Dragon/src/MOCDDFL.f new file mode 100644 index 0000000..e04ae8a --- /dev/null +++ b/Dragon/src/MOCDDFL.f @@ -0,0 +1,99 @@ +*DECK MOCDDFL + SUBROUTINE MOCDDFL(N,NREG,NSOUT,M,NOM,NZON,H,SIGANG,DSIG,EXPT, + 1 EXP2,NMU,ZMU) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculate coefficients of a track for the cyclic characteristics +* integration: DD1 Diamond-Differencing scheme without fix-up and +* 'source term isolation' option turned off. +* +*Copyright: +* Copyright (C) 2015 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* N number of elements in the current track. +* NREG number of volumes. +* NSOUT number of surfaces. +* M number of material mixtures. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* H vector containing the lenght of the different segments of this +* track. +* SIGANG macroscopic total cross sections and albedos. +* NMU order of the polar quadrature set. +* ZMU inverse of polar quadrature cosines. +* +*Parameters: output +* DSIG macroscopic total cross sections. +* EXPT track coefficient. +* EXP2 quadratic expansion of (1-exp(-a*L))/L with small argument. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,NREG,NSOUT,M,NOM(N),NZON(-NSOUT:NREG),NMU + REAL SIGANG(-6:M),ZMU(NMU) + DOUBLE PRECISION H(N),DSIG(N),EXPT(NMU,N),EXP2(5,NMU,N) +*---- +* LOCAL VARIABLES +*---- + INTEGER I,NOMI,NUMOLD,NZI,IMU + DOUBLE PRECISION SQ3,TAUD,HID,H2,H3,DEN +* + SQ3=SQRT(3.0D0) + NUMOLD=NOM(1) + DO I=1,N + NOMI=NOM(I) + NZI=NZON(NOMI) + DSIG(I)=SIGANG(NZI) + IF(NZI.LT.0) THEN + DO IMU=1,NMU + EXP2(2,IMU,I)=0.D0 + EXP2(3,IMU,I)=0.D0 + EXP2(5,IMU,I)=0.D0 + ENDDO + IF(NUMOLD.NE.NOMI) THEN + DO IMU=1,NMU + EXP2(1,IMU,I)=SIGANG(NZI) + EXP2(4,IMU,I)=EXP2(1,IMU,I) + EXPT(IMU,I)=EXP2(1,IMU,I) + ENDDO + ELSE + DO IMU=1,NMU + EXP2(1,IMU,I)=1.D0 + EXP2(4,IMU,I)=1.D0 + EXPT(IMU,I)=EXP2(1,IMU,I) + ENDDO + ENDIF + ELSE + DO IMU=1,NMU + HID=DBLE(H(I)*ZMU(IMU)) + TAUD=SIGANG(NZI)*HID + H2=HID*HID + H3=H2*HID + DEN=(TAUD+6.0D0)*TAUD+12.0D0 + EXPT(IMU,I)=((TAUD-6.0D0)*TAUD+12.0D0)/DEN + EXP2(1,IMU,I)=12.0D0*HID/DEN + EXP2(2,IMU,I)=H2*(TAUD+6.0D0)/DEN + EXP2(3,IMU,I)=-2.0D0*SQ3*H3/DEN + EXP2(4,IMU,I)=-2.0D0*SQ3*TAUD/DEN + EXP2(5,IMU,I)=H3/DEN + ENDDO + ENDIF + NUMOLD=NOMI + ENDDO +* + RETURN + END diff --git a/Dragon/src/MOCDDFS.f b/Dragon/src/MOCDDFS.f new file mode 100644 index 0000000..f2f2b99 --- /dev/null +++ b/Dragon/src/MOCDDFS.f @@ -0,0 +1,85 @@ +*DECK MOCDDFS + SUBROUTINE MOCDDFS(N,NREG,NSOUT,M,NOM,NZON,H,SIGANG,EXPT,EXP2, + 1 NMU,ZMU) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculate coefficients of a track for the cyclic characteristics +* integration: Diamond-Differencing scheme without fix-up and +* 'source term isolation' option turned off. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy and R. Le Tellier +* +*Parameters: input +* N number of elements in the current track. +* NREG number of volumes. +* NSOUT number of surfaces. +* M number of material mixtures. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* H vector containing the lenght of the different segments of this +* track. +* SIGANG macroscopic total cross sections and albedos. +* NMU order of the polar quadrature set. +* ZMU inverse of polar quadrature cosines. +* +*Parameters: output +* EXPT track coefficient. +* EXP2 quadratic expansion of (1-exp(-a*L))/L with small argument. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,NREG,NSOUT,M,NOM(N),NZON(-NSOUT:NREG),NMU + REAL SIGANG(-6:M),ZMU(NMU) + DOUBLE PRECISION H(N),EXPT(NMU,N),EXP2(2,NMU,N) +*---- +* LOCAL VARIABLES +*---- + INTEGER I,NOMI,NUMOLD,NZI,IMU + DOUBLE PRECISION HID,TAUD,TEMP,TEMP2 +* + NUMOLD=NOM(1) + DO I=1,N + NOMI=NOM(I) + NZI=NZON(NOMI) + IF (NZI.LT.0) THEN + IF (NUMOLD.NE.NOMI) THEN + DO IMU=1,NMU + EXP2(1,IMU,I)=SIGANG(NZI) + EXPT(IMU,I)=EXP2(1,IMU,I) + ENDDO + ELSE + DO IMU=1,NMU + EXP2(1,IMU,I)=1.D0 + EXPT(IMU,I)=EXP2(1,IMU,I) + ENDDO + ENDIF + ELSE + DO IMU=1,NMU + HID=DBLE(H(I)*ZMU(IMU)) + TAUD=SIGANG(NZI)*HID + TEMP=1.D0/(2.D0+TAUD) + TEMP2=TEMP+TEMP + EXPT(IMU,I)=TEMP2-TAUD*TEMP + EXP2(1,IMU,I)=TEMP2*HID + EXP2(2,IMU,I)=HID*HID*TEMP + ENDDO + ENDIF + NUMOLD=NOMI + ENDDO +* + RETURN + END diff --git a/Dragon/src/MOCDDFT.f b/Dragon/src/MOCDDFT.f new file mode 100644 index 0000000..14b5c2f --- /dev/null +++ b/Dragon/src/MOCDDFT.f @@ -0,0 +1,79 @@ +*DECK MOCDDFT + SUBROUTINE MOCDDFT(N,NREG,NSOUT,M,NOM,NZON,H,SIGANG,EXPT,EXP2, + 1 NMU,ZMU) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculate coefficients of a track for the cyclic characteristics +* integration: Diamond-Differencing scheme without fix-up and +* 'MOCC/MCI' integration strategy. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy and R. Le Tellier +* +*Parameters: input +* N number of elements in the current track. +* NREG number of volumes. +* NSOUT number of surfaces. +* M number of material mixtures. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* H vector containing the lenght of the different segments of this +* track. +* SIGANG macroscopic total cross sections and albedos. +* NMU order of the polar quadrature set. +* ZMU inverse of polar quadrature cosines. +* +*Parameters: output +* EXPT track coefficient. +* EXP2 quadratic expansion of (1-exp(-a*L))/L with small argument. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,NREG,NSOUT,M,NOM(N),NZON(-NSOUT:NREG),NMU + REAL SIGANG(-6:M),ZMU(NMU) + DOUBLE PRECISION H(N),EXPT(NMU,N),EXP2(NMU,N) +*---- +* LOCAL VARIABLES +*---- + INTEGER I,NOMI,NUMOLD,NZI,IMU + DOUBLE PRECISION TAUD +* + NUMOLD=NOM(1) + DO I=1,N + NOMI=NOM(I) + NZI=NZON(NOMI) + IF (NZI.LT.0)THEN + IF (NUMOLD.NE.NOMI)THEN + DO IMU=1,NMU + EXP2(IMU,I)=1.D0-SIGANG(NZI) + ENDDO + ELSE + DO IMU=1,NMU + EXP2(IMU,I)=0.D0 + ENDDO + ENDIF + ELSE + DO IMU=1,NMU + TAUD=SIGANG(NZI)*H(I)*ZMU(IMU) + EXP2(IMU,I)=2.D0*TAUD/(2.D0+TAUD) + ENDDO + ENDIF + NUMOLD=NOMI + ENDDO + EXPT(:NMU,:N)=0.0D0 +* + RETURN + END diff --git a/Dragon/src/MOCDS2.f b/Dragon/src/MOCDS2.f new file mode 100644 index 0000000..b6e72c8 --- /dev/null +++ b/Dragon/src/MOCDS2.f @@ -0,0 +1,207 @@ +*DECK MOCDS2 + SUBROUTINE MOCDS2(SUBDSC,LC,M,N,H,NOM,NZON,TR,SC,W,NFI,DIAGF, + 1 DIAGQ,CA,CQ,PREV,NEXT,DINV2,A2,B2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of contribution in second-order ACA coefficients on one +* track. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): I. Suslov and R. Le Tellier +* +*Parameters: input +* SUBDSC ACA coefficients calculation subroutine. +* LC dimension of vector MCU. +* M number of material mixtures. +* N number of elements for this track. +* H tracking widths. +* NOM integer tracking elements. +* NZON index-number of the mixture type assigned to each volume. +* TR macroscopic total cross section. +* SC macroscopic P0 scattering cross section. +* W weight associated with this track. +* NFI total number of volumes for which specific values +* of the neutron flux and reactions rates are required. +* +*Parameters: input/output +* CA undefined. +* CQ undefined. +* DIAGQ undefined. +* DIAGF undefined. +* +*Parameters: scratch +* PREV undefined. +* NEXT undefined. +* DINV2 undefined. +* A2 undefined. +* B2 undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +* +*--- +* SUBROUTINE ARGUMENTS +*--- + INTEGER LC,M,N,NFI,NZON(NFI),NOM(N),PREV(N),NEXT(N) + DOUBLE PRECISION W,H(N),CA(LC),DIAGF(NFI),DINV2(N),A2(N),B2(N) + REAL TR(0:M),SC(0:M),DIAGQ(NFI),CQ(LC) + EXTERNAL SUBDSC +*--- +* LOCAL VARIABLES +*--- + INTEGER IBCV + DOUBLE PRECISION DMINV,DMAX + PARAMETER(DMINV=2.D-2,IBCV=-7) + DOUBLE PRECISION WW,AAW,CAW,AQW,CQW,CAWP,CQWP,B,A,DINV,DH,DHP, + 1 BN,AN,DINVN,BP,AP,DINVP + INTEGER I,I1,NOMI,NZI,NOMIN,NZIN,NOMIP,NZIP,ICN,ICP +* + DMAX=1.D0/DMINV + WW=W +*--- +* CALCULATE COEFFICIENTS OF THIS TRACK +*--- +* MCGDS2A: Tabulated Exponentials +* MCGDS2E: Exact Exponentials + CALL SUBDSC(N,M,NFI,NOM,NZON,H,TR,SC,DINV2,B2,A2) +*---- +* CONSTRUCTION OF ACA MATRICES +*--- + NOMIN=0 + NZIN=0 + NOMI=0 + NZI=0 + DHP=0.0D0 + DH=0.0D0 + AN=0.0D0 + BN=0.0D0 + AP=0.0D0 + BP=0.0D0 + DO I=1,N + ICN=NEXT(I) + ICP=PREV(I) + IF (I.GT.1) THEN + NOMIP=NOMI + NZIP=NZI + NOMI=NOMIN + NZI=NZIN + ELSE + NOMIP=NOM(N) + NZIP=NZON(NOMIP) + NOMI=NOM(1) + NZI=NZON(NOMI) + ENDIF + IF (I.LT.N) THEN + NOMIN=NOM(I+1) + NZIN=NZON(NOMIN) + ELSE + NOMIN=NOM(1) + NZIN=NZON(NOMIN) + ENDIF + IF (NZI.GE.0) THEN +* ----------- +* Volume Cell +* ----------- + DINV=DINV2(I) + B=B2(I) + A=A2(I) + IF (NZIN.GE.0) THEN +* next cell is a volume + IF (I.EQ.N) THEN + I1=1 + ELSE + I1=I+1 + ENDIF + DINVN=DINV2(I1) + BN=B2(I1) + AN=A2(I1) + IF (ABS(DINV+DINVN).LT.DMINV) THEN + DH=DMAX + ELSE + DH=1.D0/(DINV+DINVN) + ENDIF + ELSEIF (NZIN.EQ.IBCV) THEN +* next cell is a fixed boundary condition + DH=1.D0/(1.D0+DINV) + ENDIF + IF (NZIP.GE.0) THEN +* previous cell is a volume + IF (I.EQ.1) THEN + I1=N + ELSE + I1=I-1 + ENDIF + DINVP=DINV2(I1) + BP=B2(I1) + AP=A2(I1) + IF (ABS(DINV+DINVP).LT.DMINV) THEN + DHP=DMAX + ELSE + DHP=1.D0/(DINV+DINVP) + ENDIF + ELSEIF (NZIP.EQ.IBCV) THEN +* previous cell is a fixed boundary condition + DHP=1.D0/(1.D0+DINV) + ENDIF +* +* assembling coefficients + AAW=DH*A + AQW=DH*B + IF(NZIN.GE.0) THEN +* next cell is a volume + CAW=DH*AN + CQW=DH*BN + ELSE +* next cell is a voided boundary condition + CAW=0.D0 + CQW=0.D0 + ENDIF +* + AAW=AAW+DHP*A + AQW=AQW+DHP*B + IF(NZIP.GE.0) THEN +* previous cell is a volume + CAWP=DHP*AP + CQWP=DHP*BP + ELSE +* previous cell is a voided boundary condition + CAWP=0.D0 + CQWP=0.D0 + ENDIF +* +* assembling matrices + DIAGF(NOMI)=DIAGF(NOMI)+AAW*WW + DIAGQ(NOMI)=DIAGQ(NOMI)-REAL(W*AQW) + IF(ICN.GT.0) THEN +* next cell is a volume different from this one + CA(ICN)=CA(ICN)-CAW*WW + CQ(ICN)=CQ(ICN)+REAL(W*CQW) + ELSE +* next cell is a voided boundary or a volume identical to this one + DIAGF(NOMI)=DIAGF(NOMI)-CAW*WW + DIAGQ(NOMI)=DIAGQ(NOMI)+REAL(W*CQW) + ENDIF + IF(ICP.GT.0) THEN +* previous cell is a volume different from this one + CA(ICP)=CA(ICP)-CAWP*WW + CQ(ICP)=CQ(ICP)+REAL(W*CQWP) + ELSE +* previous cell is a voided boundary or a volume identical to this one + DIAGF(NOMI)=DIAGF(NOMI)-CAWP*WW + DIAGQ(NOMI)=DIAGQ(NOMI)+REAL(W*CQWP) + ENDIF + ENDIF +* ----------- + ENDDO +* + RETURN + END diff --git a/Dragon/src/MOCDSP.f b/Dragon/src/MOCDSP.f new file mode 100644 index 0000000..687323b --- /dev/null +++ b/Dragon/src/MOCDSP.f @@ -0,0 +1,121 @@ +*DECK MOCDSP + SUBROUTINE MOCDSP(N,NFI,NLONG,LC,NZON,NOM,KM,MCU,IM,PREV,NEXT,H) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the position of the coefficients relative to a track +* in ACA matrices. Cyclic tracking version. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): I. Suslov and R. Le Tellier +* +*Parameters: input +* NFI total number of volumes and surfaces. +* NLONG total number of cells with unknowns quantities. +* LC dimension of vector MCU. +* NZON index-number of the mixture type assigned to each volume. +* KM used in CDD acceleration. +* MCU used in CDD acceleration. +* IM used in CDD acceleration. +* +*Parameters: output +* PREV PREV(I): location of non diagonal element (NOM(I),NOM(I-1)) +* of preconditioning matrices in vector CF and CQ. +* NEXT NEXT(I): location of non diagonal element (NOM(I),NOM(I+1)) +* of preconditioning matrices in vector CF and CQ. +* +*Parameters: input/output +* N number of elements in the current track. +* NOM integer tracking elements. +* H real tracking elements. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,NFI,NLONG,LC,NZON(NFI),NOM(N),KM(NLONG),MCU(LC), + 1 IM(NLONG),PREV(N),NEXT(N) + DOUBLE PRECISION H(N) +*---- +* LOCAL VARIABLES +*---- + INTEGER I,I1,I2,II,FOUN,FOUP,NOMI,NOMIN,NOMIP,NZI +*---- +* UNFOLD CYCLIC TRACKING LINE +*---- + CALL MCGTRK(NFI,NZON,N,NOM,H) +*---- +* CONSTRUCT PREV & NEXT +*---- + DO I=1,N + FOUN=-1 + FOUP=-1 +* current cell + NOMI=NOM(I) + IF((NOMI.LT.1).OR.(NOMI.GT.NFI)) THEN + WRITE(6,*) 'NFI= ',NFI,' NOMI= ',NOMI + CALL XABORT('MOCDSP: KM OVERFLOW.') + ENDIF + NZI=NZON(NOMI) + IF (NZI.LT.0) THEN + NEXT(I)=0 + PREV(I)=0 + ELSE + I1=IM(NOMI) +* next cell + IF (I.EQ.N) THEN + NOMIN=NOM(1) + ELSE + NOMIN=NOM(I+1) + ENDIF +* previous cell + IF(I.EQ.1) THEN + NOMIP=NOM(N) + ELSE + NOMIP=NOM(I-1) + ENDIF + IF ((NOMI.EQ.NOMIN).OR.(NZON(NOMIN).LT.0)) THEN + FOUN=0 + ENDIF + IF ((NOMI.EQ.NOMIP).OR.(NZON(NOMIP).LT.0)) THEN + FOUP=0 + ENDIF +* + I2=I1+KM(NOMI) + I1=I1+1 + DO II=I1,I2 + IF ((FOUN.LT.0).AND.(MCU(II).EQ.NOMIN)) THEN + FOUN=II + ENDIF + IF ((FOUP.LT.0).AND.(MCU(II).EQ.NOMIP)) THEN + FOUP=II + ENDIF + IF ((FOUN.GE.0).AND.(FOUP.GE.0)) GOTO 10 + ENDDO +* connectivity between NOMI and NOMIN and/or NOMIP not found + WRITE(6,100) I,NOMI,NOMIN,NOMIP + CALL PRINIM('NOM ',NOM(1),N) + CALL PRINIM('MCU ',MCU(I1),KM(NOMI)) + CALL XABORT('MOCDSP: FAILURE 1.') + 10 IF ((FOUN.LE.LC).AND.(FOUP.LE.LC)) THEN + PREV(I)=FOUP + NEXT(I)=FOUN + ELSE + CALL XABORT('MOCDSP: CQ/CF OVERFLOW.') + ENDIF + ENDIF + ENDDO +* + 100 FORMAT(1X,'I=',I3,' NOMI=',I5,' NOMIN=',I5,' NOMIP=',I5) +* + RETURN + END diff --git a/Dragon/src/MOCFCF.f b/Dragon/src/MOCFCF.f new file mode 100644 index 0000000..fdf9515 --- /dev/null +++ b/Dragon/src/MOCFCF.f @@ -0,0 +1,412 @@ +*DECK MOCFCF + SUBROUTINE MOCFCF(SUBFFI,SUBFFA,SUBLDC,SUBSCH,IFTRAK,NBTR,MXSUB, + 1 MXSEG,NDIM,KPN,NREG,NSOUT,NMAT,NALB,NGEFF,NPHI, + 2 NGSS,NLF,NFUNL,NMOD,NLFX,NLIN,NFUNLX,KEYFLX, + 3 MATALB,NCONV,SIGANG,CAZ1,CAZ2,XGSS,YGSS,WGSS, + 4 SOUR,ISGNR,IDIR,NBATCH,PHIOUT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Flux integration upon the cyclic tracking. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy and R. Le Tellier +* +*Parameters: input +* SUBFFI Isotropic flux integration subroutine. +* SUBFFA Anisotropic flux integration subroutine. +* SUBLDC flux integration subroutine with linear-discontinuous source. +* SUBSCH Track coefficients calculation subroutine. +* IFTRAK tracking file unit number. +* NGEFF number of groups to process. +* NMAT number of mixtures. +* NLF number of Legendre orders for the flux. +* NREG number of regions. +* KPN number of unknowns per energy group including spherical +* harmonic terms and fundamental currents. +* NGSS number of polar angles. +* NSOUT number of surfaces. +* MXSUB maximun number of subtracks in a track. +* MXSEG maximun number of segments in a track. +* NBTR number of tracks. +* NPHI number of angles in the plane. +* NFUNL number of moments of the flux (in 2D: NFUNL=NLF*(NLF+1)/2). +* NMOD first dimension of ISGNR. +* NLFX scattering anisotropy used to compute spherical harmonics. +* NLIN linear discontinuous flag (=1 SC/DD0; =3 LDC/DD1). +* NFUNLX number of spherical harmonics components. +* ISGNR array of spherical harmonics signs. +* KEYFLX position of flux elements in PHIIN vector. +* MATALB mixture and albedo indices. +* WGSS polar weights. +* XGSS polar angle cosines. +* YGSS polar angle sines. +* NALB number of albedos. +* SIGANG arrays of total cross-sections and albedos. +* CAZ1 first cosines of the different tracking azimuthal angles. +* CAZ2 second cosines of the different tracking azimuthal angles. +* SOUR total source vector components. +* NCONV logical array of convergence status for each group (.TRUE. for +* not converged). +* IDIR direction of fundamental current for TIBERE with MoC +* (=0,1,2,3). +* NBATCH number of tracks processed in each OpenMP core (default: =1). +* +*Parameters: output +* PHIOUT vector containing the zonal flux moments. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IFTRAK,NGEFF,NMAT,NLF,NREG,NDIM,KPN,NGSS,NSOUT,MXSUB, + 1 MXSEG,NBTR,NPHI,NFUNL,NMOD,NLFX,NLIN,NFUNLX,ISGNR(NMOD,NFUNLX), + 2 KEYFLX(NREG,NLIN,NFUNL),MATALB(-NSOUT:NREG),NALB,IDIR,NBATCH + REAL WGSS(NGSS),XGSS(NGSS),YGSS(NGSS), + 1 SIGANG(-NALB:NMAT,NGEFF) + DOUBLE PRECISION CAZ1(NPHI),CAZ2(NPHI),SOUR(KPN,NGEFF), + 1 PHIOUT(KPN,NGEFF) + LOGICAL NCONV(NGEFF) + EXTERNAL SUBFFI,SUBFFA,SUBLDC,SUBSCH +*---- +* LOCAL VARIABLES +*---- + INTEGER MXE + PARAMETER (MXE=64) + INTEGER ILINE,IANG,JANG,ISUB,I,IE,II,NOMI,NZI,IND,JF,INDX, + 1 INDY,IREG,I0,IL1,IBATCH,NDFUNLX + DOUBLE PRECISION DWEIG(MXE),Q0,Q1,Q0X,Q1X,Q0Y,Q1Y + LOGICAL LNEW +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NSUB,NSEG + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NRSEG,KANGL + REAL, ALLOCATABLE, DIMENSION(:,:) :: RHARM + REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: TRHAR + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DSIG,WEIGHT,EXPT, + 1 EXP2,FLUX + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: SEGLEN,COEFI, + 1 OMEGAX,OMEGAY,OMG2,FLM,FLP,CYM,CYP,DFLM,DFLP,CYM2,CYP2,FLUV, + 2 DFLUV + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: PHIV,DPHIV +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NSUB(NBATCH),NSEG(NBATCH),WEIGHT(NBATCH), + 1 KANGL(MXSUB,NBATCH),NRSEG(MXSEG,NBATCH),SEGLEN(MXSEG,NBATCH)) + ALLOCATE(FLM(NGSS,MXSEG),FLP(NGSS,MXSEG),CYM(NGSS,MXSEG), + 1 CYP(NGSS,MXSEG),EXPT(NGSS*MXSEG)) + ALLOCATE(OMEGAX(NPHI,NGSS),OMEGAY(NPHI,NGSS),OMG2(NGSS,3)) +*--- +* Compute flux and currents for this tracking line +*--- + PHIOUT(:KPN,:NGEFF)=0.0D0 + IF((NLF.EQ.1).AND.(NLIN.EQ.1)) THEN +*---- +* ISOTROPIC SCATTERING +*---- + ALLOCATE(FLUX(KPN),EXP2(2*NGSS*MXSEG)) + DO IE=1,NGSS + DO IANG=1,NPHI + OMEGAX(IANG,IE)=CAZ1(IANG)/YGSS(IE) + OMEGAY(IANG,IE)=CAZ2(IANG)/YGSS(IE) + ENDDO + ENDDO + DO IBATCH=1,(NBTR-1)/NBATCH+1 + DO ILINE=(IBATCH-1)*NBATCH+1,MIN(IBATCH*NBATCH,NBTR) + IL1=ILINE-(IBATCH-1)*NBATCH + READ(IFTRAK) NSUB(IL1),NSEG(IL1),WEIGHT(IL1), + 1 (KANGL(I,IL1),I=1,NSUB(IL1)),(NRSEG(I,IL1),I=1,NSEG(IL1)), + 2 (SEGLEN(I,IL1),I=1,NSEG(IL1)) + IF(NSUB(IL1).GT.MXSUB) CALL XABORT('MOCFCF: MXSUB OVERFLOW.') + ENDDO +*$OMP PARALLEL DO +*$OMP1 PRIVATE(IL1,IE,DWEIG,ISUB,LNEW,NOMI,NZI,IND,FLM,FLP,OMG2) +*$OMP2 PRIVATE(FLUX,I0,ILINE,EXPT,EXP2,CYM,CYP) + DO II=1,NGEFF + IF(NCONV(II)) THEN + FLUX(:KPN)=0.0D0 + DO ILINE=(IBATCH-1)*NBATCH+1,MIN(IBATCH*NBATCH,NBTR) + IL1=ILINE-(IBATCH-1)*NBATCH + OMG2(:NGSS,:3)=0.0D0 + DO IE=1,NGSS + DWEIG(IE)=WEIGHT(IL1)*WGSS(IE) + ENDDO + FLM(:NGSS,:MXSEG)=0.D0 + FLP(:NGSS,:MXSEG)=0.D0 + ISUB=0 + LNEW=.TRUE. + DO I0=1,NSEG(IL1) + NOMI=NRSEG(I0,IL1) + NZI=MATALB(NOMI) + IF(NZI.LE.0) THEN + LNEW=.TRUE. + ELSE + IF(LNEW) THEN + ISUB=ISUB+1 + LNEW=.FALSE. + ENDIF + IND=KEYFLX(NOMI,1,1) + IF(IDIR.EQ.0) THEN + DO IE=1,NGSS + FLM(IE,I0)=DWEIG(IE)*SOUR(IND,II) + FLP(IE,I0)=FLM(IE,I0) + ENDDO + ELSEIF(IDIR.EQ.1) THEN + DO IE=1,NGSS + OMG2(IE,1)=3.0D0*OMEGAX(KANGL(ISUB,IL1),IE)**2 + FLM(IE,I0)=DWEIG(IE)*SOUR(IND,II)*OMG2(IE,1) + FLP(IE,I0)=FLM(IE,I0) + ENDDO + ELSEIF(IDIR.EQ.2) THEN + DO IE=1,NGSS + OMG2(IE,2)=3.0D0*OMEGAY(KANGL(ISUB,IL1),IE)**2 + FLM(IE,I0)=DWEIG(IE)*SOUR(IND,II)*OMG2(IE,2) + FLP(IE,I0)=FLM(IE,I0) + ENDDO + ELSEIF(IDIR.EQ.3) THEN + DO IE=1,NGSS + OMG2(IE,3)=3.0D0*(1.0-1.0/YGSS(IE)**2) + FLM(IE,I0)=DWEIG(IE)*SOUR(IND,II)*OMG2(IE,3) + FLP(IE,I0)=FLM(IE,I0) + ENDDO + ENDIF + ENDIF + ENDDO +* MOCFFIR: 'Source Term Isolation' Strategy turned on +* MOCFFIS: 'Source Term Isolation' Strategy turned off +* MOCFFIT: 'MOCC/MCI' Iterative Strategy + CALL SUBFFI(SUBSCH,NREG,NSOUT,KPN,NMAT,NSEG(IL1), + 1 SEGLEN(1,IL1),NRSEG(1,IL1),NGSS,MATALB, + 2 SIGANG(-NALB,II),KEYFLX,YGSS,FLUX,EXPT, + 3 EXP2,FLM,FLP,CYM,CYP,IDIR,OMG2) + ENDDO ! ILINE + PHIOUT(:KPN,II)=PHIOUT(:KPN,II)+FLUX(:KPN) + ENDIF + ENDDO ! II +*$OMP END PARALLEL DO + ENDDO ! IBATCH + DEALLOCATE(OMG2,OMEGAY,OMEGAX) + DEALLOCATE(EXP2,FLUX) + ELSE IF(NLIN.EQ.1) THEN +*---- +* ANISOTROPIC SCATTERING +*---- + ALLOCATE(FLUX(KPN),EXP2(2*NGSS*MXSEG)) + ALLOCATE(TRHAR(NGSS,NFUNL,NPHI,2),RHARM(NGSS,NFUNL)) + DO IANG=1,NPHI + CALL MOCCHR(2,NLF-1,NFUNL,NGSS,XGSS,CAZ1(IANG),CAZ2(IANG), + 1 RHARM) + DO 15 JF=1,NFUNL + DO 10 IE=1,NGSS + TRHAR(IE,JF,IANG,1)=ISGNR(1,JF)*RHARM(IE,JF) + TRHAR(IE,JF,IANG,2)=ISGNR(NMOD,JF)*RHARM(IE,JF) + 10 CONTINUE + 15 CONTINUE + ENDDO + DEALLOCATE(RHARM) + DO IBATCH=1,(NBTR-1)/NBATCH+1 + DO ILINE=(IBATCH-1)*NBATCH+1,MIN(IBATCH*NBATCH,NBTR) + IL1=ILINE-(IBATCH-1)*NBATCH + READ(IFTRAK) NSUB(IL1),NSEG(IL1),WEIGHT(IL1), + 1 (KANGL(I,IL1),I=1,NSUB(IL1)),(NRSEG(I,IL1),I=1,NSEG(IL1)), + 1 (SEGLEN(I,IL1),I=1,NSEG(IL1)) + IF(NSUB(IL1).GT.MXSUB) CALL XABORT('MOCFCF: MXSUB OVERFLOW.') + ENDDO +*$OMP PARALLEL DO +*$OMP1 PRIVATE(IL1,IE,DWEIG,ISUB,LNEW,NOMI,NZI,Q0,Q1,FLM,FLP) +*$OMP2 PRIVATE(FLUX,I0,II,EXPT,EXP2,CYM,CYP) + DO II=1,NGEFF + IF(NCONV(II)) THEN + FLUX(:KPN)=0.0D0 + DO ILINE=(IBATCH-1)*NBATCH+1,MIN(IBATCH*NBATCH,NBTR) + IL1=ILINE-(IBATCH-1)*NBATCH + DO IE=1,NGSS + DWEIG(IE)=WEIGHT(IL1)*WGSS(IE) + ENDDO + FLM(:NGSS,:MXSEG)=0.0D0 + FLP(:NGSS,:MXSEG)=0.0D0 + ISUB=0 + LNEW=.TRUE. + DO I0=1,NSEG(IL1) + NOMI=NRSEG(I0,IL1) + NZI=MATALB(NOMI) + IF(NZI.LE.0) THEN + LNEW=.TRUE. + ELSE + IF(LNEW) THEN + ISUB=ISUB+1 + LNEW=.FALSE. + ENDIF + DO IE=1,NGSS + Q0=0.D0 + Q1=0.D0 + DO JF=1,NFUNL + IND=KEYFLX(NOMI,1,JF) + Q0=Q0+SOUR(IND,II)*TRHAR(IE,JF,KANGL(ISUB,IL1),2) + Q1=Q1+SOUR(IND,II)*TRHAR(IE,JF,KANGL(ISUB,IL1),1) + ENDDO + FLM(IE,I0)=DWEIG(IE)*Q0 + FLP(IE,I0)=DWEIG(IE)*Q1 + ENDDO + ENDIF + ENDDO + IF(ISUB.NE.NSUB(IL1)) CALL XABORT('MOCFCF: NSUB ERROR.') +* MOCFFAR: 'Source Term Isolation' Strategy turned on +* MOCFFAS: 'Source Term Isolation' Strategy turned off +* MOCFFAT: 'MOCC/MCI' Iterative Strategy + CALL SUBFFA(SUBSCH,NREG,NSOUT,KPN,NMAT,NSEG(IL1), + 1 SEGLEN(1,IL1),NRSEG(1,IL1),NGSS,NFUNL,MATALB, + 2 SIGANG(-NALB,II),KEYFLX,YGSS,FLUX,EXPT,EXP2,FLM, + 3 FLP,CYM,CYP,NPHI,NSUB(IL1),KANGL(1,IL1),TRHAR) + ENDDO ! ILINE + PHIOUT(:KPN,II)=PHIOUT(:KPN,II)+FLUX(:KPN) + ENDIF + ENDDO ! II +*$OMP END PARALLEL DO + ENDDO ! IBATCH + DEALLOCATE(EXP2,FLUX,TRHAR) + ELSE IF(NLIN.EQ.3) THEN +*---- +* LINEAR DISCONTINUOUS SOURCE APPROXIMATION +*---- + NDFUNLX=NDIM*NFUNLX + ALLOCATE(PHIV(NFUNLX,NREG,NGEFF),DPHIV(NDFUNLX,NREG,NGEFF)) + ALLOCATE(FLUV(NFUNLX,NREG),DFLUV(NDFUNLX,NREG)) + ALLOCATE(EXP2(5*NGSS*MXSEG)) + ALLOCATE(TRHAR(NGSS,NFUNLX,NPHI,2),RHARM(NGSS,NFUNLX)) + DO IANG=1,NPHI + CALL MOCCHR(2,NLFX-1,NFUNLX,NGSS,XGSS,CAZ1(IANG),CAZ2(IANG), + 1 RHARM) + DO 25 JF=1,NFUNLX + DO 20 IE=1,NGSS + TRHAR(IE,JF,IANG,1)=ISGNR(1,JF)*RHARM(IE,JF) + TRHAR(IE,JF,IANG,2)=ISGNR(NMOD,JF)*RHARM(IE,JF) + 20 CONTINUE + 25 CONTINUE + ENDDO + DEALLOCATE(RHARM) + DO II=1,NGEFF + IF(NCONV(II)) THEN + PHIV(:NFUNLX,:NREG,II)=0.0D0 + DPHIV(:NDFUNLX,:NREG,II)=0.0D0 + ENDIF + ENDDO + ALLOCATE(DFLM(NGSS,MXSEG),DFLP(NGSS,MXSEG),DSIG(MXSEG), + 1 CYM2(NGSS,MXSEG),CYP2(NGSS,MXSEG)) + DO IBATCH=1,(NBTR-1)/NBATCH+1 + DO ILINE=(IBATCH-1)*NBATCH+1,MIN(IBATCH*NBATCH,NBTR) + IL1=ILINE-(IBATCH-1)*NBATCH + READ(IFTRAK) NSUB(IL1),NSEG(IL1),WEIGHT(IL1), + 1 (KANGL(I,IL1),I=1,NSUB(IL1)),(NRSEG(I,IL1),I=1,NSEG(IL1)), + 1 (SEGLEN(I,IL1),I=1,NSEG(IL1)) + IF(NSUB(IL1).GT.MXSUB) CALL XABORT('MOCFCF: MXSUB OVERFLOW.') + ENDDO +*$OMP PARALLEL DO +*$OMP1 PRIVATE(IL1,IE,DWEIG,ISUB,JANG,LNEW,NOMI,NZI,Q0,Q1,Q0X,Q1X,Q0Y) +*$OMP2 PRIVATE(Q1Y,IND,INDX,INDY,FLM,FLP,DFLM,DFLP,FLUV,DFLUV,I0,ILINE) +*$OMP3 PRIVATE(DSIG,EXPT,EXP2,CYM,CYP,CYM2,CYP2) + DO II=1,NGEFF + IF(NCONV(II)) THEN + FLUV(:NFUNLX,:NREG)=0.0D0 + DFLUV(:NDFUNLX,:NREG)=0.0D0 + DO ILINE=(IBATCH-1)*NBATCH+1,MIN(IBATCH*NBATCH,NBTR) + IL1=ILINE-(IBATCH-1)*NBATCH + DO IE=1,NGSS + DWEIG(IE)=WEIGHT(IL1)*WGSS(IE) + ENDDO + FLM(:NGSS,:MXSEG)=0.0D0 + FLP(:NGSS,:MXSEG)=0.0D0 + DFLM(:NGSS,:MXSEG)=0.0D0 + DFLP(:NGSS,:MXSEG)=0.0D0 + ISUB=0 + JANG=0 + LNEW=.TRUE. + DO I0=1,NSEG(IL1) + NOMI=NRSEG(I0,IL1) + NZI=MATALB(NOMI) + IF(NZI.LE.0) THEN + LNEW=.TRUE. + ELSE + IF(LNEW) THEN + ISUB=ISUB+1 + JANG=KANGL(ISUB,IL1) + LNEW=.FALSE. + ENDIF + DO IE=1,NGSS + Q0=0.D0 + Q1=0.D0 + Q0X=0.0D0 + Q1X=0.0D0 + Q0Y=0.0D0 + Q1Y=0.0D0 + DO JF=1,NFUNL + IND=KEYFLX(NOMI,1,JF) + INDX=KEYFLX(NOMI,2,JF) + INDY=KEYFLX(NOMI,3,JF) + Q0=Q0+SOUR(IND,II)*TRHAR(IE,JF,JANG,2) + Q1=Q1+SOUR(IND,II)*TRHAR(IE,JF,JANG,1) + Q0X=Q0X+SOUR(INDX,II)*TRHAR(IE,JF,JANG,2) + Q1X=Q1X+SOUR(INDX,II)*TRHAR(IE,JF,JANG,1) + Q0Y=Q0Y+SOUR(INDY,II)*TRHAR(IE,JF,JANG,2) + Q1Y=Q1Y+SOUR(INDY,II)*TRHAR(IE,JF,JANG,1) + ENDDO + FLM(IE,I0)=Q0 + FLP(IE,I0)=Q1 + DFLM(IE,I0)=-Q0X*CAZ1(JANG)-Q0Y*CAZ2(JANG) + DFLP(IE,I0)=Q1X*CAZ1(JANG)+Q1Y*CAZ2(JANG) + ENDDO + ENDIF + ENDDO + IF(ISUB.NE.NSUB(IL1)) CALL XABORT('MOCFCF: NSUB ERROR.') +* MOCFFAL: 'Source Term Isolation' Strategy turned off + CALL SUBLDC(SUBSCH,NREG,NSOUT,NMAT,NSEG(IL1), + 1 SEGLEN(1,IL1),NRSEG(1,IL1),NGSS,NFUNLX,MATALB, + 2 DWEIG,SIGANG(-NALB,II),YGSS,FLM,FLP,DFLM,DFLP, + 3 NPHI,NSUB(IL1),KANGL(1,IL1),TRHAR,FLUV, + 4 DFLUV,DSIG,EXPT,EXP2,CYM,CYP,CYM2,CYP2) + ENDDO ! ILINE + PHIV(:NFUNLX,:NREG,II)=PHIV(:NFUNLX,:NREG,II)+ + 1 FLUV(:NFUNLX,:NREG) + DPHIV(:NDFUNLX,:NREG,II)=DPHIV(:NDFUNLX,:NREG,II)+ + 1 DFLUV(:NDFUNLX,:NREG) + ENDIF + ENDDO ! II +*$OMP END PARALLEL DO + ENDDO ! IBATCH + DEALLOCATE(CYP2,CYM2,DSIG,DFLP,DFLM) + DEALLOCATE(EXP2,TRHAR) + ALLOCATE(COEFI(2*NFUNLX,2*NFUNLX)) + CALL MCGCOEF(NFUNLX,NGSS,YGSS,WGSS,NPHI,CAZ1,CAZ2,COEFI) + DO II=1,NGEFF + IF(NCONV(II)) THEN + DO IREG=1,NREG + DPHIV(:,IREG,II)=MATMUL(COEFI,DPHIV(:,IREG,II)) + DO JF=1,NFUNL + PHIOUT(KEYFLX(IREG,1,JF),II)=PHIV(JF,IREG,II) + PHIOUT(KEYFLX(IREG,2,JF),II)=DPHIV(JF,IREG,II) + PHIOUT(KEYFLX(IREG,3,JF),II)=DPHIV(NFUNLX+JF,IREG,II) + ENDDO + ENDDO + ENDIF + ENDDO + DEALLOCATE(COEFI,DFLUV,FLUV,DPHIV,PHIV) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(EXPT,CYP,CYM,FLP,FLM) + DEALLOCATE(SEGLEN,NRSEG,KANGL,WEIGHT,NSEG,NSUB) +* + RETURN + END diff --git a/Dragon/src/MOCFFAL.f b/Dragon/src/MOCFFAL.f new file mode 100644 index 0000000..fb23dfe --- /dev/null +++ b/Dragon/src/MOCFFAL.f @@ -0,0 +1,190 @@ +*DECK MOCFFAL + SUBROUTINE MOCFFAL(SUBSCH,NR,NS,MT,LINE,SEGLEN,NRSEG,NE,NFX, + 1 MATALB,DWEIG,SIGANG,YG,FLM,FLP,DFLM,DFLP,NPHI,NSUB,KANGL,TRHAR, + 2 PHIV,DPHIV,DSIG,EXPT,EXP2,CYM1,CYP1,CYM2,CYP2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of transport equation on a cyclic track. +* Linear-discontinuous-characteristics approximation. +* Ray-tracing (anisotropic scattering case, 'source term isolation' +* off). +* +*Copyright: +* Copyright (C) 2015 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* SUBSCH track coefficients calculation subroutine. +* NR number of volumes. +* NS number of surfaces. +* MT number of material mixtures. +* LINE number of segments on this tracking line. +* SEGLEN vector containing the lenght of the different segments of this +* track. +* NRSEG vector containing the region number of the different segments +* of this track. +* NE order of the polar quadrature set. +* NFX number of moments of the spherical harmonics. +* MATALB index-number of the mixture assigned to each volume +* and the albedo to each surface. +* DWEIG track weight per polar angle. +* SIGANG total cross-sections and albedos. +* YG inverse of polar quadrature cosines. +* FLM total source vector for + direction. +* FLP total source vector for - direction. +* DFLM linear component of the total source vector for + direction. +* DFLP linear component of the total source vector for - direction. +* NPHI number of angles in the plane. +* NSUB number of subtracks. +* KANGL angle indices per subtrack. +* TRHAR spherical harmonics components for this angle in the plan. +* +*Parameters: output +* PHIV vector containing the zonal scalar flux (component 1). +* DPHIV vector containing the zonal scalar flux (components 2 and 3). +* +*Parameters: scratch +* DSIG undefined. +* EXPT track coefficient. +* EXP2 quadratic expansion of (1-exp(-a*L))/L with small argument. +* CYM1 undefined. +* CYP1 undefined. +* CYM2 undefined. +* CYP2 undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NR,NS,MT,LINE,NRSEG(LINE),NE,NFX,MATALB(-NS:NR),NPHI, + 1 NSUB,KANGL(NSUB) + REAL SIGANG(-6:MT),YG(NE),TRHAR(NE,NFX,NPHI,2) + DOUBLE PRECISION SEGLEN(LINE),DWEIG(NE),FLM(NE,LINE),FLP(NE,LINE), + 1 DFLM(NE,LINE),DFLP(NE,LINE),PHIV(NFX,NR),DPHIV(2*NFX,NR), + 2 DSIG(LINE),EXPT(NE,LINE),EXP2(5,NE,LINE),CYM1(NE,LINE), + 3 CYP1(NE,LINE),CYM2(NE,LINE),CYP2(NE,LINE) + EXTERNAL SUBSCH +*---- +* LOCAL VARIABLES +*---- + INTEGER MXE + PARAMETER (MXE=64) + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.D0,ZERO=0.D0) + INTEGER IE,NOIL,IL,JL,JF,ISUB,IANG + REAL ETA,XI + DOUBLE PRECISION TEMP1,TEMP2,TEMP3,FL0(MXE),CY0(MXE),FL1(MXE), + 1 CY1(MXE),DH + LOGICAL LNEW +* + FL0(:NE)= ZERO + FL1(:NE)= ZERO + CY0(:NE)= ONE + CY1(:NE)= ONE +*---- +* Calculation of the coefficients for this track. +*---- +* MOCSCAL: Linear discontinuous-Characteristics Scheme with +* Tabulated Exponentials +* MOCDDFL: Diamond-Differencing DD1 Scheme +* MOCSCEL: Linear discontinuous-Characteristics Scheme with +* Exact Exponentials + CALL SUBSCH(LINE,NR,NS,MT,NRSEG,MATALB,SEGLEN,SIGANG(-6),DSIG, + 1 EXPT,EXP2,NE,YG) +*---- +* Summation along the track in both directions +*---- + DO 2226 IL= 1, LINE + JL= LINE + 1 - IL + DO 2225 IE=1,NE +* + direction + NOIL = NRSEG(IL) + TEMP1 = FL1(IE) + TEMP2 = FLP(IE,IL) + TEMP3 = DFLP(IE,IL) + DH = SEGLEN(IL)*YG(IE) + FL1(IE) = TEMP1*EXPT(IE,IL) + TEMP2*EXP2(1,IE,IL) + 1 - TEMP3*EXP2(3,IE,IL)*DSIG(IL) + FLP(IE,IL) = TEMP1*EXP2(1,IE,IL) + TEMP2*EXP2(2,IE,IL) + 1 + TEMP3*EXP2(3,IE,IL) + DFLP(IE,IL)= TEMP1*EXP2(4,IE,IL)-TEMP2*EXP2(3,IE,IL)/(DH*DH) + 1 + TEMP3*EXP2(5,IE,IL)*DSIG(IL) + CYP1(IE,IL)= CY1(IE) * EXP2(1,IE,IL) + CYP2(IE,IL)= CY1(IE) * EXP2(4,IE,IL) + CY1(IE) = CY1(IE) * EXPT(IE,IL) +* +* - direction + TEMP1 = FL0(IE) + TEMP2 = FLM(IE,JL) + TEMP3 = DFLM(IE,JL) + DH = SEGLEN(JL)*YG(IE) + FL0(IE) = TEMP1*EXPT(IE,JL) + TEMP2*EXP2(1,IE,JL) + 1 - TEMP3*EXP2(3,IE,JL)*DSIG(JL) + FLM(IE,JL) = TEMP1*EXP2(1,IE,JL) + TEMP2*EXP2(2,IE,JL) + 1 + TEMP3*EXP2(3,IE,JL) + DFLM(IE,JL)= TEMP1*EXP2(4,IE,JL)-TEMP2*EXP2(3,IE,JL)/(DH*DH) + 1 + TEMP3*EXP2(5,IE,JL)*DSIG(JL) + CYM1(IE,JL)= CY0(IE) * EXP2(1,IE,JL) + CYM2(IE,JL)= CY0(IE) * EXP2(4,IE,JL) + CY0(IE) = CY0(IE) * EXPT(IE,JL) + 2225 CONTINUE + 2226 CONTINUE + DO 2230 IE=1,NE + TEMP1=ONE-CY0(IE) + IF (TEMP1.GT.ZERO) THEN + FL0(IE)= FL0(IE)/TEMP1 + ELSE + FL0(IE)= ZERO + ENDIF + TEMP1=ONE-CY1(IE) + IF (TEMP1.GT.ZERO) THEN + FL1(IE)= FL1(IE)/TEMP1 + ELSE + FL1(IE)= ZERO + ENDIF + 2230 CONTINUE + ISUB=0 + IANG=0 + LNEW=.TRUE. + DO 2240 IL= 1, LINE + NOIL = NRSEG(IL) + IF(NOIL.LE.0) THEN + LNEW=.TRUE. + ELSE + IF(LNEW) THEN + ISUB=ISUB+1 + IANG=KANGL(ISUB) + LNEW=.FALSE. + ENDIF + DO 2242 IE=1,NE + ETA=TRHAR(IE,3,IANG,1) + XI=TRHAR(IE,2,IANG,1) + DO 2241 JF=1,NFX + TEMP1=TRHAR(IE,JF,IANG,1) + TEMP2=TRHAR(IE,JF,IANG,2) + PHIV(JF,NOIL)=PHIV(JF,NOIL)+DWEIG(IE)* + > ((FLM(IE,IL)+FL0(IE)*CYM1(IE,IL))*TEMP2+ + > (FLP(IE,IL)+FL1(IE)*CYP1(IE,IL))*TEMP1) + DPHIV(JF,NOIL)=DPHIV(JF,NOIL)+DWEIG(IE)*ETA* + > (-(DFLM(IE,IL)+FL0(IE)*CYM2(IE,IL))*TEMP2+ + > (DFLP(IE,IL)+FL1(IE)*CYP2(IE,IL))*TEMP1) + DPHIV(NFX+JF,NOIL)=DPHIV(NFX+JF,NOIL)+DWEIG(IE)*XI* + > (-(DFLM(IE,IL)+FL0(IE)*CYM2(IE,IL))*TEMP2+ + > (DFLP(IE,IL)+FL1(IE)*CYP2(IE,IL))*TEMP1) + 2241 CONTINUE + 2242 CONTINUE + ENDIF + 2240 CONTINUE + IF(ISUB.NE.NSUB) CALL XABORT('MOCFFAL: NSUB INCONSISTENCY') +* + RETURN + END diff --git a/Dragon/src/MOCFFAR.f b/Dragon/src/MOCFFAR.f new file mode 100644 index 0000000..ff07776 --- /dev/null +++ b/Dragon/src/MOCFFAR.f @@ -0,0 +1,158 @@ +*DECK MOCFFAR + SUBROUTINE MOCFFAR(SUBSCH,NR,NS,NUN,MT,LINE,SEGLEN,NRSEG,NE,NF, + 1 MATALB,SIGANG,KEYFLX,YG,FLUX,EXPT,EXP2,FLM,FLP, + 2 CYM,CYP,NPHI,NSUB,KANGL,TRHAR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of transport equation on a cyclic track. +* Ray-tracing (anisotropic scattering case,'source term isolation' on). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy and R. Le Tellier +* +*Parameters: input +* SUBSCH track coefficients calculation subroutine. +* NR number of volumes. +* NS number of surfaces. +* NUN total number of unknowns in vectors FLUX. +* MT number of material mixtures. +* LINE number of segments on this tracking line. +* SEGLEN vector containing the lenght of the different segments of this +* track. +* NRSEG vector containing the region number of the different segments +* of this track. +* NE order of the polar quadrature set. +* NF number of moments of the flux (in 2D NFUNL=NLF*(NLF+1)/2). +* MATALB index-number of the mixture assigned to each volume +* and the albedo to each surface. +* SIGANG total cross-sections and albedos. +* KEYFLX position of flux elements in FLUX vector. +* YG inverse of polar quadrature cosines. +* FLM total source vector for + direction. +* FLP total source vector for - direction. +* NPHI number of angles in the plane. +* NSUB number of subtracks. +* KANGL angle indices per subtrack. +* TRHAR spherical harmonics components for this angle in the plan. +* +*Parameters: output +* FLUX vector containing the zonal flux moments. +* +*Parameters: scratch +* EXPT track coefficient. +* EXP2 quadratic expansion of (1-exp(-a*L))/L with small argument. +* CYM undefined. +* CYP endefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NR,NS,NUN,MT,LINE,NRSEG(LINE),NE,NF,MATALB(-NS:NR), + 1 KEYFLX(NR,NF),NPHI,NSUB,KANGL(NSUB) + REAL SIGANG(-6:MT),YG(NE),TRHAR(NE,NF,NPHI,2) + DOUBLE PRECISION SEGLEN(LINE),FLUX(NUN),EXPT(NE,LINE), + 1 EXP2(NE,LINE),FLM(NE,LINE),FLP(NE,LINE),CYM(NE,LINE), + 2 CYP(NE,LINE) + EXTERNAL SUBSCH +*---- +* LOCAL VARIABLES +*---- + INTEGER MXE + PARAMETER (MXE=64) + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.D0,ZERO=0.D0) + INTEGER IE,NOIL,IL,JL,JF,IND,ISUB,IANG + DOUBLE PRECISION TEMP,FL0(MXE),CY0(MXE),FL1(MXE),CY1(MXE) + LOGICAL LNEW +* + FL0(:NE)= ZERO + FL1(:NE)= ZERO + CY0(:NE)= ONE + CY1(:NE)= ONE +*---- +* Calculation of the coefficients for this track. +*---- +* MOCSCA: Step-Characteristics Scheme with Tabulated Exponentials +* MOCDDF: Diamond-Differencing Scheme +* MOCSCE: Step-Characteristics Scheme with Exact Exponentials + CALL SUBSCH(LINE,NR,NS,MT,NRSEG,MATALB,SEGLEN,SIGANG(-6),EXPT, + 1 EXP2,NE,YG) +*---- +* Summation along the track in both directions +*---- + DO 2226 IL= 1, LINE + JL= LINE + 1 - IL + DO 2225 IE=1,NE +* + direction +* phi_k + TEMP = FL1(IE) +* phi_{k+1} + FL1(IE) = TEMP * EXPT(IE,IL) + 1 + FLP(IE,IL) * EXP2(IE,IL) +* phi_k * ((1 - exp(-tau_k)) / tau_k) + FLP(IE,IL) = TEMP * EXP2(IE,IL) +* ((1 - exp(-tau_k)) / tau_k) * exp(-tau_1^{k-1}) + CYP(IE,IL) = CY1(IE) * EXP2(IE,IL) +* exp(-tau_1^{k}) + CY1(IE) = CY1(IE) * EXPT(IE,IL) +* +* - direction + TEMP = FL0(IE) + FL0(IE) = TEMP * EXPT(IE,JL) + 1 + FLM(IE,JL) * EXP2(IE,JL) + FLM(IE,JL) = TEMP * EXP2(IE,JL) + CYM(IE,JL) = CY0(IE) * EXP2(IE,JL) + CY0(IE) = CY0(IE) * EXPT(IE,JL) + 2225 CONTINUE + 2226 CONTINUE + DO 2230 IE=1,NE + TEMP=ONE-CY0(IE) + IF (TEMP.GT.ZERO) THEN + FL0(IE)= FL0(IE)/TEMP + ELSE + FL0(IE)= ZERO + ENDIF + TEMP=ONE-CY1(IE) + IF (TEMP.GT.ZERO) THEN + FL1(IE)= FL1(IE)/TEMP + ELSE + FL1(IE)= ZERO + ENDIF + 2230 CONTINUE + ISUB=0 + IANG=0 + LNEW=.TRUE. + DO 2240 IL= 1, LINE + NOIL = NRSEG(IL) + IF(NOIL.LE.0) THEN + LNEW=.TRUE. + ELSE + IF(LNEW) THEN + ISUB=ISUB+1 + IANG=KANGL(ISUB) + LNEW=.FALSE. + ENDIF + DO 2242 IE=1,NE + DO 2241 JF=1,NF + IND=KEYFLX(NOIL,JF) + FLUX(IND)= FLUX(IND) + > +(FLM(IE,IL)+FL0(IE)*CYM(IE,IL))*TRHAR(IE,JF,IANG,2) + > +(FLP(IE,IL)+FL1(IE)*CYP(IE,IL))*TRHAR(IE,JF,IANG,1) + 2241 CONTINUE + 2242 CONTINUE + ENDIF + 2240 CONTINUE +* + RETURN + END diff --git a/Dragon/src/MOCFFAS.f b/Dragon/src/MOCFFAS.f new file mode 100644 index 0000000..09b4509 --- /dev/null +++ b/Dragon/src/MOCFFAS.f @@ -0,0 +1,160 @@ +*DECK MOCFFAS + SUBROUTINE MOCFFAS(SUBSCH,NR,NS,NUN,MT,LINE,SEGLEN,NRSEG,NE,NF, + 1 MATALB,SIGANG,KEYFLX,YG,FLUX,EXPT,EXP2,FLM,FLP, + 2 CYM,CYP,NPHI,NSUB,KANGL,TRHAR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of transport equation on a cyclic track. +* Ray-tracing (anisotropic scattering case, 'source term isolation' +* off). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy and R. Le Tellier +* +*Parameters: input +* SUBSCH track coefficients calculation subroutine. +* NR number of volumes. +* NS number of surfaces. +* NUN total number of unknowns in vectors FLUX. +* MT number of material mixtures. +* LINE number of segments on this tracking line. +* SEGLEN vector containing the lenght of the different segments of this +* track. +* NRSEG vector containing the region number of the different segments +* of this track. +* NE order of the polar quadrature set. +* NF number of moments of the flux (in 2D NFUNL=NLF*(NLF+1)/2). +* MATALB index-number of the mixture assigned to each volume +* and the albedo to each surface. +* SIGANG total cross-sections and albedos. +* KEYFLX position of flux elements in FLUX vector. +* YG inverse of polar quadrature cosines. +* FLM total source vector for + direction. +* FLP total source vector for - direction. +* NPHI number of angles in the plane. +* NSUB number of subtracks. +* KANGL angle indices per subtrack. +* TRHAR spherical harmonics components for this angle in the plan. +* +*Parameters: output +* FLUX vector containing the zonal flux moments. +* +*Parameters: scratch +* EXPT track coefficient. +* EXP2 quadratic expansion of (1-exp(-a*L))/L with small argument. +* CYM undefined. +* CYP undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NR,NS,NUN,MT,LINE,NRSEG(LINE),NE,NF,MATALB(-NS:NR), + 1 KEYFLX(NR,NF),NPHI,NSUB,KANGL(NSUB) + REAL SIGANG(-6:MT),YG(NE),TRHAR(NE,NF,NPHI,2) + DOUBLE PRECISION SEGLEN(LINE),FLUX(NUN),EXPT(NE,LINE), + 1 EXP2(2,NE,LINE),FLM(NE,LINE),FLP(NE,LINE),CYM(NE,LINE), + 2 CYP(NE,LINE) + EXTERNAL SUBSCH +*---- +* LOCAL VARIABLES +*---- + INTEGER MXE + PARAMETER (MXE=64) + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.D0,ZERO=0.D0) + INTEGER IE,NOIL,IL,JL,JF,IND,ISUB,IANG + DOUBLE PRECISION TEMP,TEMP2,FL0(MXE),CY0(MXE),FL1(MXE),CY1(MXE) + LOGICAL LNEW +* + FL0(:NE)= ZERO + FL1(:NE)= ZERO + CY0(:NE)= ONE + CY1(:NE)= ONE +*---- +* Calculation of the coefficients for this track. +*---- +* MOCSCAS: Step-Characteristics Scheme with Tabulated Exponentials +* MOCDDFS: Diamond-Differencing Scheme +* MOCSCES: Step-Characteristics Scheme with Exact Exponentials + CALL SUBSCH(LINE,NR,NS,MT,NRSEG,MATALB,SEGLEN,SIGANG(-6),EXPT, + 1 EXP2,NE,YG) +*---- +* Summation along the track in both directions +*---- + DO 2226 IL= 1, LINE + JL= LINE + 1 - IL + DO 2225 IE=1,NE +* + direction +* phi_k + TEMP = FL1(IE) + TEMP2 = FLP(IE,IL) +* phi_{k+1} + FL1(IE) = TEMP*EXPT(IE,IL) + TEMP2*EXP2(1,IE,IL) +* phi_k * ((1 - exp(-tau_k)) / tau_k) + FLP(IE,IL) = TEMP*EXP2(1,IE,IL) + TEMP2*EXP2(2,IE,IL) +* ((1 - exp(-tau_k)) / tau_k) * exp(-tau_1^{k-1}) + CYP(IE,IL) = CY1(IE) * EXP2(1,IE,IL) +* exp(-tau_1^{k}) + CY1(IE) = CY1(IE) * EXPT(IE,IL) +* +* - direction + TEMP = FL0(IE) + TEMP2 = FLM(IE,JL) + FL0(IE) = TEMP*EXPT(IE,JL) + TEMP2*EXP2(1,IE,JL) + FLM(IE,JL) = TEMP*EXP2(1,IE,JL) + TEMP2*EXP2(2,IE,JL) + CYM(IE,JL) = CY0(IE) * EXP2(1,IE,JL) + CY0(IE) = CY0(IE) * EXPT(IE,JL) + 2225 CONTINUE + 2226 CONTINUE + DO 2230 IE=1,NE + TEMP=ONE-CY0(IE) + IF (TEMP.GT.ZERO) THEN + FL0(IE)= FL0(IE)/TEMP + ELSE + FL0(IE)= ZERO + ENDIF + TEMP=ONE-CY1(IE) + IF (TEMP.GT.ZERO) THEN + FL1(IE)= FL1(IE)/TEMP + ELSE + FL1(IE)= ZERO + ENDIF + 2230 CONTINUE + ISUB=0 + IANG=0 + LNEW=.TRUE. + DO 2240 IL= 1, LINE + NOIL = NRSEG(IL) + IF(NOIL.LE.0) THEN + LNEW=.TRUE. + ELSE + IF(LNEW) THEN + ISUB=ISUB+1 + IANG=KANGL(ISUB) + LNEW=.FALSE. + ENDIF + DO 2242 IE=1,NE + DO 2241 JF=1,NF + IND=KEYFLX(NOIL,JF) + FLUX(IND)= FLUX(IND) + > +(FLM(IE,IL)+FL0(IE)*CYM(IE,IL))*TRHAR(IE,JF,IANG,2) + > +(FLP(IE,IL)+FL1(IE)*CYP(IE,IL))*TRHAR(IE,JF,IANG,1) + 2241 CONTINUE + 2242 CONTINUE + ENDIF + 2240 CONTINUE + IF(ISUB.NE.NSUB) CALL XABORT('MOCFFAS: NSUB INCONSISTENCY') +* + RETURN + END diff --git a/Dragon/src/MOCFFAT.f b/Dragon/src/MOCFFAT.f new file mode 100644 index 0000000..b552fdd --- /dev/null +++ b/Dragon/src/MOCFFAT.f @@ -0,0 +1,140 @@ +*DECK MOCFFAT + SUBROUTINE MOCFFAT(SUBSCH,NR,NS,NUN,MT,LINE,SEGLEN,NRSEG,NE,NF, + 1 MATALB,SIGANG,KEYFLX,YG,FLUX,EXPT,EXP2,FLM,FLP, + 2 CYM,CYP,NPHI,NSUB,KANGL,TRHAR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of transport equation on a cyclic track. +* Ray-tracing (anisotropic scattering case, 'MOCC/MCI' integration +* strategy). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy and R. Le Tellier +* +*Parameters: input +* SUBSCH track coefficients calculation subroutine. +* NR number of volumes. +* NS number of surfaces. +* NUN total number of unknowns in vectors FLUX. +* MT number of material mixtures. +* LINE number of segments on this tracking line. +* SEGLEN vector containing the lenght of the different segments of +* this track. +* NRSEG vector containing the region number of the different segments +* of this track. +* NE order of the polar quadrature set. +* NF number of moments of the flux (in 2D NFUNL=NLF*(NLF+1)/2). +* MATALB index-number of the mixture assigned to each volume +* and the albedo to each surface. +* SIGANG total cross-sections and albedos. +* KEYFLX position of flux elements in FLUX vector. +* YG inverse of polar quadrature cosines. +* FLM total source vector for + direction. +* FLP total source vector for - direction. +* NPHI number of angles in the plane. +* NSUB number of subtracks. +* KANGL angle indices per subtrack. +* TRHAR spherical harmonics components for this angle in the plan. +* +*Parameters: output +* FLUX vector containing the zonal flux moments. +* +*Parameters: scratch +* EXPT track coefficient. +* EXP2 quadratic expansion of (1-exp(-a*L))/L with small argument. +* CYM undefined. +* CYP undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NR,NS,NUN,MT,LINE,NRSEG(LINE),NE,NF,MATALB(-NS:NR), + 1 KEYFLX(NR,NF),NPHI,NSUB,KANGL(NSUB) + REAL SIGANG(-6:MT),YG(NE),TRHAR(NE,NF,NPHI,2) + DOUBLE PRECISION SEGLEN(LINE),FLUX(NUN),EXPT(NE,LINE), + 1 EXP2(NE,LINE),FLM(NE,LINE),FLP(NE,LINE),CYM(NE,LINE), + 2 CYP(NE,LINE) + EXTERNAL SUBSCH +*---- +* LOCAL VARIABLES +*---- + INTEGER MXE + PARAMETER (MXE=64) + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.D0,ZERO=0.D0) + INTEGER IE,NOIL,IL,JL,JF,IND,ISUB,IANG + DOUBLE PRECISION FL0(MXE),CY0(MXE),FL1(MXE),CY1(MXE) + LOGICAL LNEW +* + FL0(:NE)= ZERO + FL1(:NE)= ZERO + CY0(:NE)= ONE + CY1(:NE)= ONE +*---- +* Calculation of the coefficients for this track. +*---- +* MOCSCAT: Step-Characteristics Scheme with Tabulated Exponentials +* MOCDDFT: Diamond-Differencing Scheme +* MOCSCET: Step-Characteristics Scheme with Exact Exponentials + CALL SUBSCH(LINE,NR,NS,MT,NRSEG,MATALB,SEGLEN,SIGANG(-6),EXPT, + 1 EXP2,NE,YG) +*---- +* Summation along the track in both directions +*---- + DO 2226 IL= 1, LINE + JL= LINE + 1 - IL + DO 2225 IE=1,NE +* + direction + FLP(IE,IL) = (FL1(IE) - FLP(IE,IL)) * EXP2(IE,IL) + CYP(IE,IL) = CY1(IE) * EXP2(IE,IL) + FL1(IE) = FL1(IE) - FLP(IE,IL) + CY1(IE) = CY1(IE) - CYP(IE,IL) +* +* - direction + FLM(IE,JL) = (FL0(IE) - FLM(IE,JL)) * EXP2(IE,JL) + CYM(IE,JL) = CY0(IE) * EXP2(IE,JL) + FL0(IE) = FL0(IE) - FLM(IE,JL) + CY0(IE) = CY0(IE) - CYM(IE,JL) + 2225 CONTINUE + 2226 CONTINUE + DO 2230 IE=1,NE + FL0(IE)= FL0(IE)/(ONE-CY0(IE)) + FL1(IE)= FL1(IE)/(ONE-CY1(IE)) + 2230 CONTINUE + ISUB=0 + IANG=0 + LNEW=.TRUE. + DO 2240 IL= 1, LINE + NOIL = NRSEG(IL) + IF(NOIL.LE.0) THEN + LNEW=.TRUE. + ELSE + IF(LNEW) THEN + ISUB=ISUB+1 + IANG=KANGL(ISUB) + LNEW=.FALSE. + ENDIF + DO 2242 IE=1,NE + DO 2241 JF=1,NF + IND=KEYFLX(NOIL,JF) + FLUX(IND)= FLUX(IND) + > +(FLM(IE,IL)+FL0(IE)*CYM(IE,IL))*TRHAR(IE,JF,IANG,2) + > +(FLP(IE,IL)+FL1(IE)*CYP(IE,IL))*TRHAR(IE,JF,IANG,1) + 2241 CONTINUE + 2242 CONTINUE + ENDIF + 2240 CONTINUE +* + RETURN + END diff --git a/Dragon/src/MOCFFIR.f b/Dragon/src/MOCFFIR.f new file mode 100644 index 0000000..9cb7760 --- /dev/null +++ b/Dragon/src/MOCFFIR.f @@ -0,0 +1,150 @@ +*DECK MOCFFIR + SUBROUTINE MOCFFIR(SUBSCH,NR,NS,NUN,MT,LINE,SEGLEN,NRSEG,NE, + 1 MATALB,SIGANG,KEYFLX,YG,FLUX,EXPT,EXP2,FLM, + 2 FLP,CYM,CYP,IDIR,OMG2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of transport equation on a cyclic track +* ray-tracing (isotropic scattering case and 'source term isolation' +* on). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy and R. Le Tellier +* +*Parameters: input +* SUBSCH track coefficients calculation subroutine. +* NR number of volumes. +* NS number of surfaces. +* NUN total number of unknowns in vectors FLUX. +* MT number of material mixtures. +* LINE number of segments on this tracking line. +* SEGLEN vector containing the lenght of the different segments of this +* track. +* NRSEG vector containing the region number of the different segments +* of this track. +* NE order of the polar quadrature set. +* MATALB index-number of the mixture assigned to each volume +* and the albedo to each surface. +* SIGANG total cross-sections and albedos. +* KEYFLX position of flux elements in FLUX vector. +* YG inverse of polar quadrature cosines. +* FLM total source vector for + direction. +* FLP total source vector for - direction. +* IDIR direction of fundamental current for TIBERE with MoC +* =0,1,2,3. +* OMG2 x, y and z components of the $3\\Omega^2$. +* +*Parameters: output +* FLUX vector containing the zonal flux moments. +* +*Parameters: scratch +* EXPT track coefficient. +* EXP2 quadratic expansion of (1-exp(-a*L))/L with small argument. +* CYM undefined. +* CYP undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NR,NS,NUN,MT,LINE,NRSEG(LINE),NE,MATALB(-NS:NR),KEYFLX(NR) + INTEGER IDIR + REAL SIGANG(-6:MT),YG(NE) + DOUBLE PRECISION SEGLEN(LINE),FLUX(NUN),EXPT(NE,LINE), + 1 EXP2(NE,LINE),FLM(NE,LINE),FLP(NE,LINE),CYM(NE,LINE), + 2 CYP(NE,LINE),OMG2(NE,3) + EXTERNAL SUBSCH +*---- +* LOCAL VARIABLES +*---- + INTEGER MXE + PARAMETER (MXE=64) + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.D0,ZERO=0.D0) + INTEGER IE,NOIL,IL,JL,IND,INDC + DOUBLE PRECISION TEMP,FL0(MXE),CY0(MXE),FL1(MXE),CY1(MXE) +* + FL0(:NE)= ZERO + FL1(:NE)= ZERO + CY0(:NE)= ONE + CY1(:NE)= ONE +*---- +* Calculation of the coefficients for this track. +*---- +* MOCSCA: Step-Characteristics Scheme with Tabulated Exponentials +* MOCDDF: Diamond-Differencing Scheme +* MOCSCE: Step-Characteristics Scheme with Exact Exponentials + CALL SUBSCH(LINE,NR,NS,MT,NRSEG,MATALB,SEGLEN,SIGANG(-6),EXPT, + 1 EXP2,NE,YG) +*---- +* Summation along the track in both directions +*---- + DO 4226 IL= 1, LINE + JL= LINE + 1 - IL + DO 4225 IE=1,NE +* phi_k + TEMP = FL0(IE) +* phi_{k+1} + FL0(IE) = TEMP * EXPT(IE,IL) + 1 + FLM(IE,IL) * EXP2(IE,IL) +* phi_k * ((1 - exp(-tau_k)) / tau_k) + FLM(IE,IL) = TEMP * EXP2(IE,IL) +* ((1 - exp(-tau_k)) / tau_k) * exp(-tau_1^{k-1}) + CYM(IE,IL) = CY0(IE) * EXP2(IE,IL) +* exp(-tau_1^{k}) + CY0(IE) = CY0(IE) * EXPT(IE,IL) +* + TEMP = FL1(IE) + FL1(IE) = TEMP * EXPT(IE,JL) + 1 + FLP(IE,JL) * EXP2(IE,JL) + FLP(IE,JL) = TEMP * EXP2(IE,JL) + CYP(IE,JL) = CY1(IE) * EXP2(IE,JL) + CY1(IE) = CY1(IE) * EXPT(IE,JL) + 4225 CONTINUE + 4226 CONTINUE + DO 4230 IE=1,NE + TEMP=ONE-CY0(IE) + IF (TEMP.GT.ZERO) THEN + FL0(IE)= FL0(IE)/TEMP + ELSE + FL0(IE)= ZERO + ENDIF + TEMP=ONE-CY1(IE) + IF (TEMP.GT.ZERO) THEN + FL1(IE)= FL1(IE)/TEMP + ELSE + FL1(IE)= ZERO + ENDIF + 4230 CONTINUE + DO 4240 IL= 1, LINE + NOIL = NRSEG(IL) + IF( NOIL.GT.0 )THEN + IND=KEYFLX(NOIL) + INDC=NUN/2+IND + DO 4241 IE=1,NE + FLUX(IND)= FLUX(IND) + > + ((FL0(IE)*CYM(IE,IL)+FLM(IE,IL)) + > +(FL1(IE)*CYP(IE,IL)+FLP(IE,IL))) +* CALCULATE XI, YI OR ZI FOR TIBERE + IF(IDIR.GT.0) THEN + FLUX(INDC)= FLUX(INDC) + > + ((FL0(IE)*CYM(IE,IL)+FLM(IE,IL)) + > +(FL1(IE)*CYP(IE,IL)+FLP(IE,IL))) + > *OMG2(IE,IDIR) + ENDIF + 4241 CONTINUE + ENDIF + 4240 CONTINUE +* + RETURN + END diff --git a/Dragon/src/MOCFFIS.f b/Dragon/src/MOCFFIS.f new file mode 100644 index 0000000..2483bd2 --- /dev/null +++ b/Dragon/src/MOCFFIS.f @@ -0,0 +1,149 @@ +*DECK MOCFFIS + SUBROUTINE MOCFFIS(SUBSCH,NR,NS,NUN,MT,LINE,SEGLEN,NRSEG,NE, + 1 MATALB,SIGANG,KEYFLX,YG,FLUX,EXPT,EXP2,FLM, + 2 FLP,CYM,CYP,IDIR,OMG2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of transport equation on a cyclic track +* ray-tracing (isotropic scattering case, 'source term isolation' off). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy and R. Le Tellier +* +*Parameters: input +* SUBSCH track coefficients calculation subroutine. +* NR number of volumes. +* NS number of surfaces. +* NUN total number of unknowns in vectors FLUX. +* MT number of material mixtures. +* LINE number of segments on this tracking line. +* SEGLEN vector containing the lenght of the different segments of this +* track. +* NRSEG vector containing the region number of the different segments +* of this track. +* NE order of the polar quadrature set. +* MATALB index-number of the mixture assigned to each volume +* and the albedo to each surface. +* SIGANG total cross-sections and albedos. +* KEYFLX position of flux elements in FLUX vector. +* YG inverse of polar quadrature cosines. +* FLM total source vector for + direction. +* FLP total source vector for - direction. +* IDIR direction of fundamental current for TIBERE with MoC +* =0,1,2,3. +* OMG2 x, y and z components of the $3\\Omega^2$. +* +*Parameters: output +* FLUX vector containing the zonal flux moments. +* +*Parameters: scratch +* EXPT track coefficient. +* EXP2 quadratic expansion of (1-exp(-a*L))/L with small argument. +* CYM undefined. +* CYP undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NR,NS,NUN,MT,LINE,NRSEG(LINE),NE,MATALB(-NS:NR),KEYFLX(NR) + INTEGER IDIR + REAL SIGANG(-6:MT),YG(NE) + DOUBLE PRECISION SEGLEN(LINE),FLUX(NUN),EXPT(NE,LINE), + 1 EXP2(2,NE,LINE),FLM(NE,LINE),FLP(NE,LINE),CYM(NE,LINE), + 2 CYP(NE,LINE),OMG2(NE,3) + EXTERNAL SUBSCH +*---- +* LOCAL VARIABLES +*---- + INTEGER MXE + PARAMETER (MXE=64) + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.D0,ZERO=0.D0) + INTEGER IE,NOIL,IL,JL,IND,INDC + DOUBLE PRECISION TEMP,TEMP2,FL0(MXE),CY0(MXE),FL1(MXE),CY1(MXE) +* + FL0(:NE)= ZERO + FL1(:NE)= ZERO + CY0(:NE)= ONE + CY1(:NE)= ONE +*---- +* Calculation of the coefficients for this track. +*---- +* MOCSCAS: Step-Characteristics Scheme with Tabulated Exponentials +* MOCDDFS: Diamond-Differencing Scheme +* MOCSCES: Step-Characteristics Scheme with Exact Exponentials + CALL SUBSCH(LINE,NR,NS,MT,NRSEG,MATALB,SEGLEN,SIGANG(-6), + 1 EXPT,EXP2,NE,YG) +*---- +* Summation along the track in both directions +*---- + DO 4226 IL= 1, LINE + JL= LINE + 1 - IL + DO 4225 IE=1,NE +* phi_k + TEMP = FL0(IE) + TEMP2 = FLM(IE,IL) +* phi_{k+1} + FL0(IE) = TEMP*EXPT(IE,IL) + TEMP2*EXP2(1,IE,IL) +* phi_k * ((1 - exp(-tau_k)) / tau_k) + FLM(IE,IL) = TEMP*EXP2(1,IE,IL) + TEMP2*EXP2(2,IE,IL) +* ((1 - exp(-tau_k)) / tau_k) * exp(-tau_1^{k-1}) + CYM(IE,IL) = CY0(IE) * EXP2(1,IE,IL) +* exp(-tau_1^{k}) + CY0(IE) = CY0(IE) * EXPT(IE,IL) +* + TEMP = FL1(IE) + TEMP2 = FLP(IE,JL) + FL1(IE) = TEMP*EXPT(IE,JL) + TEMP2*EXP2(1,IE,JL) + FLP(IE,JL) = TEMP*EXP2(1,IE,JL) + TEMP2*EXP2(2,IE,JL) + CYP(IE,JL) = CY1(IE) * EXP2(1,IE,JL) + CY1(IE) = CY1(IE) * EXPT(IE,JL) + 4225 CONTINUE + 4226 CONTINUE + DO 4230 IE=1,NE + TEMP=ONE-CY0(IE) + IF (TEMP.GT.ZERO) THEN + FL0(IE)= FL0(IE)/TEMP + ELSE + FL0(IE)= ZERO + ENDIF + TEMP=ONE-CY1(IE) + IF (TEMP.GT.ZERO) THEN + FL1(IE)= FL1(IE)/TEMP + ELSE + FL1(IE)= ZERO + ENDIF + 4230 CONTINUE + DO 4240 IL= 1, LINE + NOIL = NRSEG(IL) + IF( NOIL.GT.0 )THEN + IND=KEYFLX(NOIL) + INDC=NUN/2+IND + DO 4241 IE=1,NE + FLUX(IND)= FLUX(IND) + > + ((FL0(IE)*CYM(IE,IL)+FLM(IE,IL)) + > +(FL1(IE)*CYP(IE,IL)+FLP(IE,IL))) +* CALCULATE XI, YI OR ZI FOR TIBERE + IF(IDIR.GT.0) THEN + FLUX(INDC)= FLUX(INDC) + > + ((FL0(IE)*CYM(IE,IL)+FLM(IE,IL)) + > +(FL1(IE)*CYP(IE,IL)+FLP(IE,IL))) + > *OMG2(IE,IDIR) + ENDIF + 4241 CONTINUE + ENDIF + 4240 CONTINUE +* + RETURN + END diff --git a/Dragon/src/MOCFFIT.f b/Dragon/src/MOCFFIT.f new file mode 100644 index 0000000..3b8f669 --- /dev/null +++ b/Dragon/src/MOCFFIT.f @@ -0,0 +1,129 @@ +*DECK MOCFFIT + SUBROUTINE MOCFFIT(SUBSCH,NR,NS,NUN,MT,LINE,SEGLEN,NRSEG,NE, + 1 MATALB,SIGANG,KEYFLX,YG,FLUX,EXPT,EXP2,FLM, + 2 FLP,CYM,CYP,IDIR,OMG2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of transport equation on a cyclic track +* (isotropic scattering case, 'MOCC/MCI' integration strategy). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy and R. Le Tellier +* +*Parameters: input +* SUBSCH track coefficients calculation subroutine. +* NR number of volumes. +* NS number of surfaces. +* NUN total number of unknowns in vectors FLUX. +* MT number of material mixtures. +* LINE number of segments on this tracking line. +* SEGLEN vector containing the lenght of the different segments of this +* track. +* NRSEG vector containing the region number of the different segments +* of this track. +* NE order of the polar quadrature set. +* MATALB index-number of the mixture assigned to each volume +* and the albedo to each surface. +* SIGANG total cross-sections and albedos. +* KEYFLX position of flux elements in FLUX vector. +* YG inverse of polar quadrature cosines. +* FLM total source vector for + direction. +* FLP total source vector for - direction. +* IDIR direction of fundamental current for TIBERE with MoC +* =0,1,2,3. +* OMG2 x, y and z components of the $3\\Omega^2$. +* +*Parameters: output +* FLUX vector containing the zonal flux moments. +* +*Parameters: scratch +* EXPT track coefficient. +* EXP2 quadratic expansion of (1-exp(-a*L))/L with small argument. +* CYM undefined. +* CYP undefined. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NR,NS,NUN,MT,LINE,NRSEG(LINE),NE,MATALB(-NS:NR),KEYFLX(NR) + INTEGER IDIR + REAL SIGANG(-6:MT),YG(NE) + DOUBLE PRECISION SEGLEN(LINE),FLUX(NUN),EXPT(NE,LINE), + 1 EXP2(NE,LINE),FLM(NE,LINE),FLP(NE,LINE),CYM(NE,LINE), + 2 CYP(NE,LINE),OMG2(NE,3) + EXTERNAL SUBSCH +*---- +* LOCAL VARIABLES +*---- + INTEGER MXE + PARAMETER (MXE=64) + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.D0,ZERO=0.D0) + INTEGER IE,NOIL,IL,JL,IND,INDC + DOUBLE PRECISION FL0(MXE),CY0(MXE),FL1(MXE),CY1(MXE) +* + FL0(:NE)= ZERO + FL1(:NE)= ZERO + CY0(:NE)= ONE + CY1(:NE)= ONE +*---- +* Calculation of the coefficients for this track. +*---- +* MOCSCAT: Step-Characteristics Scheme with Tabulated Exponentials +* MOCDDFT: Diamond-Differencing Scheme +* MOCSCET: Step-Characteristics Scheme with Exact Exponentials + CALL SUBSCH(LINE,NR,NS,MT,NRSEG,MATALB,SEGLEN,SIGANG(-6),EXPT, + 1 EXP2,NE,YG) +*---- +* Summation along the track in both directions +*---- + DO 4226 IL= 1, LINE + JL= LINE + 1 - IL + DO 4225 IE=1,NE + FLM(IE,IL) = (FL0(IE) - FLM(IE,IL)) * EXP2(IE,IL) + CYM(IE,IL) = CY0(IE) * EXP2(IE,IL) + FLP(IE,JL) = (FL1(IE) - FLP(IE,JL)) * EXP2(IE,JL) + CYP(IE,JL) = CY1(IE) * EXP2(IE,JL) + FL0(IE) = FL0(IE) - FLM(IE,IL) + CY0(IE) = CY0(IE) - CYM(IE,IL) + FL1(IE) = FL1(IE) - FLP(IE,JL) + CY1(IE) = CY1(IE) - CYP(IE,JL) + 4225 CONTINUE + 4226 CONTINUE + DO 4230 IE=1,NE + FL0(IE)= FL0(IE)/(ONE-CY0(IE)) + FL1(IE)= FL1(IE)/(ONE-CY1(IE)) + 4230 CONTINUE + DO 4240 IL= 1, LINE + NOIL = NRSEG(IL) + IF( NOIL.GT.0 )THEN + IND=KEYFLX(NOIL) + INDC=NUN/2+IND + DO 4241 IE=1,NE + FLUX(IND)= FLUX(IND) + > + ((FL0(IE)*CYM(IE,IL)+FLM(IE,IL)) + > +(FL1(IE)*CYP(IE,IL)+FLP(IE,IL))) +* CALCULATE XI, YI OR ZI FOR TIBERE + IF(IDIR.GT.0) THEN + FLUX(INDC)= FLUX(INDC) + > + ((FL0(IE)*CYM(IE,IL)+FLM(IE,IL)) + > +(FL1(IE)*CYP(IE,IL)+FLP(IE,IL))) + > *OMG2(IE,IDIR) + ENDIF + 4241 CONTINUE + ENDIF + 4240 CONTINUE +* + RETURN + END diff --git a/Dragon/src/MOCIK3.f b/Dragon/src/MOCIK3.f new file mode 100644 index 0000000..a3851ee --- /dev/null +++ b/Dragon/src/MOCIK3.f @@ -0,0 +1,111 @@ +*DECK MOCIK3 + SUBROUTINE MOCIK3(NANI,NFUNL,NMOD,ISGNR,KEYANI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Generate all signs ISGNR(L,M,K) for spherical harmonics R(L,M) for +* $0 \\le L \\le$ NANI (and for $-L \\le M \\le L$) on the 8 +* octant angular modes for $1 \\le K \\le 8$. +* All these ISGNR values are compressed to be used according to the +* rectangular dimension. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* NANI scattering anisotropy (=0 for isotropic scattering). +* NFUNL number of moments of the flux. +* NMOD first dimension of ISGNR. +* +*Parameters: output +* ISGNR array of the spherical harmonics signs for the different +* reflections. +* KEYANI mode to l index: l=KEYANI(nu). +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NANI,NFUNL,NMOD,ISGNR(NMOD,NFUNL),KEYANI(NFUNL) +*---- +* LOCAL VARIABLES +*---- + INTEGER NEWMOD(8,4),K,L,M,IND3,KNEW,NSELEC + LOGICAL LROK + INTEGER, ALLOCATABLE, DIMENSION(:) :: ISIWRK + DATA NEWMOD / 1,0,0,0, 0,0,2,0, + > 1,2,3,4, 0,0,0,0, + > 0,0,0,0, 0,0,0,0, + > 1,2,3,4, 5,6,7,8 / +* +* INDEX FOR SIGN ISIWRK + IND3(L,M,K)= L*(L+1) + M + 1 + (K-1)*((NANI+1)*(NANI+1)) +* +* Definition of signs: +* ISIWRK(L,M,1)= +1 +* ISIWRK(L,M,2)= SIGN(M)*(-1)**M +* ISIWRK(L,M,3)= SIGN(M) +* ISIWRK(L,M,4)= (-1)**M +* ISIWRK(L,M,5)= (-1)**(L+M) +* ISIWRK(L,M,6)= SIGN(M)*(-1)**L +* ISIWRK(L,M,7)= SIGN(M)*(-1)**(L+M) +* ISIWRK(L,M,8)= (-1)**L +* where SIGN(M)= +1 for 0 <= M +* -1 for M < 0 +* + ALLOCATE(ISIWRK(8*(NANI+1)*(NANI+1))) + DO 20 L= 0, NANI + DO 10 M= -L, L + ISIWRK(IND3(L,M,1))= 1 + ISIWRK(IND3(L,M,2))= ISIGN(1,M)*(-1)**M + ISIWRK(IND3(L,M,3))= ISIGN(1,M) + ISIWRK(IND3(L,M,4))= (-1)**M + ISIWRK(IND3(L,M,5))= (-1)**(L+M) + ISIWRK(IND3(L,M,6))= ISIGN(1,M)*(-1)**L + ISIWRK(IND3(L,M,7))= ISIGN(1,M)*(-1)**(L+M) + ISIWRK(IND3(L,M,8))= (-1)**L + 10 CONTINUE + 20 CONTINUE +* +***** SELECTS THE GOOD SIGN ISIWRK(L,M) FUNCTIONS +* FOR NMOD=2(SLAB),4(TWO-D RECT),8(THREE-D). +* COMPRESSES ISIWRK INTO ISGNR. +* + DO 50 K= 1, 8 + NSELEC= 0 + KNEW= NEWMOD(K,NMOD/2) + IF(KNEW.GT.NMOD) CALL XABORT('MOCIK3: NMOD OVERFLOW') + IF( KNEW.NE.0 )THEN + DO 40 L= 0, NANI + DO 30 M= -L, L + LROK=.FALSE. + IF( NMOD.EQ.2 )THEN + LROK= M.EQ.0 + ELSEIF( NMOD.EQ.4 )THEN + LROK= MOD(L+M,2).EQ.0 + ELSEIF( NMOD.EQ.8 )THEN + LROK= .TRUE. + ENDIF + IF( LROK )THEN + NSELEC= NSELEC+1 + ISGNR(KNEW,NSELEC)= ISIWRK(IND3(L,M,K)) + KEYANI(NSELEC) = L + ENDIF + 30 CONTINUE + 40 CONTINUE + IF(NSELEC.NE.NFUNL) CALL XABORT('MOCIK3: INVALID NSELEC') + ENDIF + 50 CONTINUE + DEALLOCATE(ISIWRK) +* + RETURN + END diff --git a/Dragon/src/MOCSCA.f b/Dragon/src/MOCSCA.f new file mode 100644 index 0000000..ad4f8f4 --- /dev/null +++ b/Dragon/src/MOCSCA.f @@ -0,0 +1,98 @@ +*DECK MOCSCA + SUBROUTINE MOCSCA(N,NREG,NSOUT,M,NOM,NZON,H,SIGANG,EXPT,EXP2, + 1 NMU,ZMU) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculate coefficients of a track for the cyclic characteristics +* integration: Step-Characteristics scheme with tabulated exponential +* and 'source term isolation' option turned on. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy and R. Le Tellier +* +*Parameters: input +* N number of elements in the current track. +* NREG number of volumes. +* NSOUT number of surfaces. +* M number of material mixtures. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* H vector containing the lenght of the different segments of this +* track. +* SIGANG macroscopic total cross sections and albedos. +* NMU order of the polar quadrature set. +* ZMU inverse of polar quadrature cosines. +* +*Parameters: output +* EXPT track coefficient. +* EXP2 quadratic expansion of (1-exp(-a*L))/L with small argument. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,NREG,NSOUT,M,NOM(N),NZON(-NSOUT:NREG),NMU + REAL SIGANG(-6:M),ZMU(NMU) + DOUBLE PRECISION H(N),EXPT(NMU,N),EXP2(NMU,N) +*---- +* LOCAL VARIABLES +*---- + INTEGER I,NOMI,NUMOLD,NZI,IMU + REAL TAU + DOUBLE PRECISION HID,TAUD,TEMP +* tabulated exponential common block + REAL E0, E1, PAS1, DX1, XLIM1 + INTEGER MEX1, LAU + PARAMETER ( MEX1=7936 ) + COMMON /EXP1/ E0(0:MEX1),E1(0:MEX1),PAS1,DX1,XLIM1 +* + NUMOLD=NOM(1) + DO I=1,N + NOMI=NOM(I) + NZI=NZON(NOMI) + IF(NZI.LT.0) THEN + IF(NUMOLD.NE.NOMI) THEN + DO IMU=1,NMU + EXP2(IMU,I)=SIGANG(NZI) + EXPT(IMU,I)=EXP2(IMU,I) + ENDDO + ELSE + DO IMU=1,NMU + EXP2(IMU,I)=1.D0 + EXPT(IMU,I)=EXP2(IMU,I) + ENDDO + ENDIF + ELSE + DO IMU=1,NMU + HID=DBLE(H(I)*ZMU(IMU)) + TAUD=SIGANG(NZI)*HID + TAU=REAL(TAUD) + IF(TAU.GE.XLIM1) THEN +* Out of the table range + EXPT(IMU,I)=0.D0 + EXP2(IMU,I)=1.D0/DBLE(SIGANG(NZI)) + ELSE +* Linear interpolation in table of (1-exp(-x))/x + LAU=INT(TAU*PAS1) + TEMP=DBLE(E0(LAU)+E1(LAU)*TAU) + EXPT(IMU,I)=1.D0-TEMP*TAUD + EXP2(IMU,I)=TEMP*HID + ENDIF + ENDDO + ENDIF + NUMOLD=NOMI + ENDDO +* + RETURN + END diff --git a/Dragon/src/MOCSCAL.f b/Dragon/src/MOCSCAL.f new file mode 100644 index 0000000..65fb0df --- /dev/null +++ b/Dragon/src/MOCSCAL.f @@ -0,0 +1,133 @@ +*DECK MOCSCAL + SUBROUTINE MOCSCAL(N,NREG,NSOUT,M,NOM,NZON,H,SIGANG,DSIG,EXPT, + 1 EXP2,NMU,ZMU) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculate coefficients of a track for the cyclic characteristics +* integration: Linear-Discontinuous-Characteristics scheme with +* tabulated exponential and +* 'source term isolation' option turned off. +* +*Copyright: +* Copyright (C) 2015 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* N number of elements in the current track. +* NREG number of volumes. +* NSOUT number of surfaces. +* M number of material mixtures. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* H vector containing the lenght of the different segments of this +* track. +* SIGANG macroscopic total cross sections and albedos. +* NMU order of the polar quadrature set. +* ZMU inverse of polar quadrature cosines. +* +*Parameters: output +* DSIG macroscopic total cross sections. +* EXPT track coefficient. +* EXP2 quadratic expansion of (1-exp(-a*L))/L with small argument. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,NREG,NSOUT,M,NOM(N),NZON(-NSOUT:NREG),NMU + REAL SIGANG(-6:M),ZMU(NMU) + DOUBLE PRECISION H(N),DSIG(N),EXPT(NMU,N),EXP2(5,NMU,N) +*---- +* LOCAL VARIABLES +*---- + INTEGER I,NOMI,NUMOLD,NZI,IMU + DOUBLE PRECISION TAUDMIN,SQ3,HID,TAUD,TEMP,C1,C2,H2,H3 +* tabulated exponential common block + REAL E0, E1, PAS1, DX1, XLIM1 + INTEGER MEX1, LAU + PARAMETER ( MEX1=7936, TAUDMIN=2.0D-2 ) + COMMON /EXP1/ E0(0:MEX1),E1(0:MEX1),PAS1,DX1,XLIM1 +* + SQ3=SQRT(3.0D0) + NUMOLD=NOM(1) + DO I=1,N + NOMI=NOM(I) + NZI=NZON(NOMI) + DSIG(I)=SIGANG(NZI) + IF(NZI.LT.0) THEN + DO IMU=1,NMU + EXP2(2,IMU,I)=0.D0 + EXP2(3,IMU,I)=0.D0 + EXP2(5,IMU,I)=0.D0 + ENDDO + IF(NUMOLD.NE.NOMI) THEN + DO IMU=1,NMU + EXP2(1,IMU,I)=SIGANG(NZI) + EXP2(4,IMU,I)=EXP2(1,IMU,I) + EXPT(IMU,I)=EXP2(1,IMU,I) + ENDDO + ELSE + DO IMU=1,NMU + EXP2(1,IMU,I)=1.D0 + EXP2(4,IMU,I)=1.D0 + EXPT(IMU,I)=EXP2(1,IMU,I) + ENDDO + ENDIF + ELSE + DO IMU=1,NMU + HID=DBLE(H(I)*ZMU(IMU)) + TAUD=SIGANG(NZI)*HID + IF(TAUD.LE.TAUDMIN) THEN +* Use Taylor series expansions + H2=HID*HID + H3=H2*HID + EXPT(IMU,I)=TAUD*(0.5D0*TAUD-1.0D0)+1.0D0 + EXP2(1,IMU,I)=HID*(TAUD*(TAUD/6.0D0-0.5D0)+1.0D0) + EXP2(2,IMU,I)=H2*(TAUD*(TAUD-4.0D0)+12.0D0)/24.0D0 + EXP2(3,IMU,I)=-SQ3*H3*(TAUD*(TAUD-2.0D0)+4.0D0)/24.0D0 + EXP2(4,IMU,I)=-SQ3*TAUD*(TAUD*(TAUD-2.0D0)+4.0D0) + 1 /24.0D0 + EXP2(5,IMU,I)=H3*(TAUD*TAUD-TAUD+4.0D0)/40.0D0 + ELSE IF(TAUD.GE.XLIM1) THEN +* Out of the table range + EXPT(IMU,I)=0.D0 + TEMP=1.D0/TAUD + EXP2(1,IMU,I)=TEMP*HID + EXP2(2,IMU,I)=HID*(1.D0-TEMP)/DSIG(I) + EXP2(3,IMU,I)=-SQ3*HID*(2.0D0-(TAUD+2.0D0)*TEMP) + 1 /DSIG(I)**2 + EXP2(4,IMU,I)=-SQ3*(2.0D0-(TAUD+2.0D0)*TEMP)/TAUD + C1=TAUD*(TAUD-6.0D0)-12.0D0 + C2=TAUD*(3.0D0*TAUD+12.0D0)+12.0D0 + EXP2(5,IMU,I)=(C1+C2*TEMP)/(TAUD*DSIG(I)**3) + ELSE +* Use tabulated exponential + LAU=INT(REAL(TAUD)*PAS1) + TEMP=DBLE(E0(LAU)+E1(LAU)*TAUD) + EXPT(IMU,I)=1.0D0-TEMP*TAUD + EXP2(1,IMU,I)=TEMP*HID + EXP2(2,IMU,I)=HID*(1.D0-TEMP)/DSIG(I) + EXP2(3,IMU,I)=-SQ3*HID*(2.0D0-(TAUD+2.0D0)*TEMP) + 1 /DSIG(I)**2 + EXP2(4,IMU,I)=-SQ3*(2.0D0-(TAUD+2.0D0)*TEMP)/TAUD + C1=TAUD*(TAUD-6.0D0)-12.0D0 + C2=TAUD*(3.0D0*TAUD+12.0D0)+12.0D0 + EXP2(5,IMU,I)=(C1+C2*TEMP)/(TAUD*DSIG(I)**3) + ENDIF + ENDDO + ENDIF + NUMOLD=NOMI + ENDDO +* + RETURN + END diff --git a/Dragon/src/MOCSCAS.f b/Dragon/src/MOCSCAS.f new file mode 100644 index 0000000..cc536d3 --- /dev/null +++ b/Dragon/src/MOCSCAS.f @@ -0,0 +1,111 @@ +*DECK MOCSCAS + SUBROUTINE MOCSCAS(N,NREG,NSOUT,M,NOM,NZON,H,SIGANG,EXPT,EXP2, + 1 NMU,ZMU) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculate coefficients of a track for the cyclic characteristics +* integration: Step-Characteristics scheme with tabulated exponential +* and 'source term isolation' option turned off. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy and R. Le Tellier +* +*Parameters: input +* N number of elements in the current track. +* NREG number of volumes. +* NSOUT number of surfaces. +* M number of material mixtures. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* H vector containing the lenght of the different segments of this +* track. +* SIGANG macroscopic total cross sections and albedos. +* NMU order of the polar quadrature set. +* ZMU inverse of polar quadrature cosines. +* +*Parameters: output +* EXPT track coefficient. +* EXP2 quadratic expansion of (1-exp(-a*L))/L with small argument. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,NREG,NSOUT,M,NOM(N),NZON(-NSOUT:NREG),NMU + REAL SIGANG(-6:M),ZMU(NMU) + DOUBLE PRECISION H(N),EXPT(NMU,N),EXP2(2,NMU,N) +*---- +* LOCAL VARIABLES +*---- + INTEGER I,NOMI,NUMOLD,NZI,IMU + REAL TAU + DOUBLE PRECISION TAUDMIN,HID,TAUD,TEMP,HID2,TAUD3,TAUD4,TAUD5 +* tabulated exponential common block + REAL E0, E1, PAS1, DX1, XLIM1 + INTEGER MEX1, LAU + PARAMETER ( MEX1=7936, TAUDMIN=2.D-2 ) + COMMON /EXP1/ E0(0:MEX1),E1(0:MEX1),PAS1,DX1,XLIM1 +* + NUMOLD=NOM(1) + DO I=1,N + NOMI=NOM(I) + NZI=NZON(NOMI) + IF(NZI.LT.0) THEN + IF(NUMOLD.NE.NOMI) THEN + DO IMU=1,NMU + EXP2(1,IMU,I)=SIGANG(NZI) + EXPT(IMU,I)=EXP2(1,IMU,I) + ENDDO + ELSE + DO IMU=1,NMU + EXP2(1,IMU,I)=1.D0 + EXPT(IMU,I)=EXP2(1,IMU,I) + ENDDO + ENDIF + ELSE + DO IMU=1,NMU + HID=DBLE(H(I)*ZMU(IMU)) + TAUD=SIGANG(NZI)*HID + TAU=REAL(TAUD) + IF(TAU.GE.XLIM1) THEN +* Out of the table range + EXPT(IMU,I)=0.D0 + TEMP=1.D0/TAUD + EXP2(1,IMU,I)=TEMP*HID + EXP2(2,IMU,I)=HID*(1.D0-TEMP)/DBLE(SIGANG(NZI)) + ELSE +* Linear interpolation in table of (1-exp(-x))/x + LAU=INT(TAU*PAS1) + TEMP=DBLE(E0(LAU)+E1(LAU)*TAU) + EXPT(IMU,I)=1.D0-TEMP*TAUD + EXP2(1,IMU,I)=TEMP*HID + IF(TAUD.LE.TAUDMIN) THEN +* and expansion in Taylor serie in O(TAUD^3) + TAUD3=TAUD/3.D0 + TAUD4=0.125D0*TAUD + TAUD5=0.2D0*TAUD + HID2=HID*HID + EXP2(2,IMU,I)=HID2*(0.5D0-TAUD3*(0.5D0-TAUD4 + 1 *(1.D0-TAUD5))) + ELSE + EXP2(2,IMU,I)=HID*(1.D0-TEMP)/DBLE(SIGANG(NZI)) + ENDIF + ENDIF + ENDDO + ENDIF + NUMOLD=NOMI + ENDDO +* + RETURN + END diff --git a/Dragon/src/MOCSCAT.f b/Dragon/src/MOCSCAT.f new file mode 100644 index 0000000..bd3a9ed --- /dev/null +++ b/Dragon/src/MOCSCAT.f @@ -0,0 +1,85 @@ +*DECK MOCSCAT + SUBROUTINE MOCSCAT(N,NREG,NSOUT,M,NOM,NZON,H,SIGANG,EXPT,EXP2, + 1 NMU,ZMU) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculate coefficients of a track for the cyclic characteristics +* integration: Step-Characteristics scheme with tabulated exponential +* and 'MOCC/MCI' integration strategy. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy and R. Le Tellier +* +*Parameters: input +* N number of elements in the current track. +* NREG number of volumes. +* NSOUT number of surfaces. +* M number of material mixtures. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* H vector containing the lenght of the different segments of this +* track. +* SIGANG macroscopic total cross sections and albedos. +* NMU order of the polar quadrature set. +* ZMU inverse of polar quadrature cosines. +* +*Parameters: output +* EXPT track coefficient. +* EXP2 quadratic expansion of (1-exp(-a*L))/L with small argument. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,NREG,NSOUT,M,NOM(N),NZON(-NSOUT:NREG),NMU + REAL SIGANG(-6:M),ZMU(NMU) + DOUBLE PRECISION H(N),EXPT(NMU,N),EXP2(NMU,N) +*---- +* LOCAL VARIABLES +*---- + INTEGER I,NOMI,NUMOLD,NZI,IMU + REAL TAU +* tabulated exponential common block + REAL E0, E1, PAS1, DX1, XLIM1 + INTEGER MEX1, LAU + PARAMETER ( MEX1=7936 ) + COMMON /EXP0/ E0(0:MEX1),E1(0:MEX1),PAS1,DX1,XLIM1 +* + NUMOLD=NOM(1) + DO I=1,N + NOMI=NOM(I) + NZI=NZON(NOMI) + IF (NZI.LT.0) THEN + IF (NUMOLD.NE.NOMI) THEN + DO IMU=1,NMU + EXP2(IMU,I)=1.D0-SIGANG(NZI) + ENDDO + ELSE + DO IMU=1,NMU + EXP2(IMU,I)=0.D0 + ENDDO + ENDIF + ELSE + DO IMU=1,NMU + TAU=REAL(SIGANG(NZI)*H(I)*ZMU(IMU)) + LAU=MIN(INT(TAU*PAS1),MEX1) + EXP2(IMU,I)=DBLE(E0(LAU)+E1(LAU)*TAU) + ENDDO + ENDIF + NUMOLD=NOMI + ENDDO + EXPT(:NMU,:N)=0.0D0 +* + RETURN + END diff --git a/Dragon/src/MOCSCE.f b/Dragon/src/MOCSCE.f new file mode 100644 index 0000000..68eea4e --- /dev/null +++ b/Dragon/src/MOCSCE.f @@ -0,0 +1,98 @@ +*DECK MOCSCE + SUBROUTINE MOCSCE(N,NREG,NSOUT,M,NOM,NZON,H,SIGANG,EXPT,EXP2, + 1 NMU,ZMU) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculate coefficients of a track for the cyclic characteristics +* integration: Step-Characteristics scheme with exact exponential and +* 'source term isolation' option turned on. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy and R. Le Tellier +* +*Parameters: input +* N number of elements in the current track. +* NREG number of volumes. +* NSOUT number of surfaces. +* M number of material mixtures. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* H vector containing the lenght of the different segments of this +* track. +* SIGANG macroscopic total cross sections and albedos. +* NMU order of the polar quadrature set. +* ZMU inverse of polar quadrature cosines. +* +*Parameters: output +* EXPT track coefficient. +* EXP2 quadratic expansion of (1-exp(-a*L))/L with small argument. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,NREG,NSOUT,M,NOM(N),NZON(-NSOUT:NREG),NMU + REAL SIGANG(-6:M),ZMU(NMU) + DOUBLE PRECISION H(N),EXPT(NMU,N),EXP2(NMU,N) +*---- +* LOCAL VARIABLES +*---- + INTEGER I,NOMI,NUMOLD,NZI,IMU + REAL TAU + DOUBLE PRECISION TAUDMIN,HID,TAUD,TEMP +* tabulated exponential common block + REAL E0, E1, PAS1, DX1, XLIM1 + INTEGER MEX1, LAU + PARAMETER ( MEX1=7936, TAUDMIN=2.D-2 ) + COMMON /EXP1/ E0(0:MEX1),E1(0:MEX1),PAS1,DX1,XLIM1 +* + NUMOLD=NOM(1) + DO I=1,N + NOMI=NOM(I) + NZI=NZON(NOMI) + IF(NZI.LT.0) THEN + IF(NUMOLD.NE.NOMI) THEN + DO IMU=1,NMU + EXP2(IMU,I)=SIGANG(NZI) + EXPT(IMU,I)=EXP2(IMU,I) + ENDDO + ELSE + DO IMU=1,NMU + EXP2(IMU,I)=1.D0 + EXPT(IMU,I)=EXP2(IMU,I) + ENDDO + ENDIF + ELSE + DO IMU=1,NMU + HID=DBLE(H(I)*ZMU(IMU)) + TAUD=SIGANG(NZI)*HID + IF(TAUD.LE.TAUDMIN) THEN +* Linear interpolation in table of (1-exp(-x))/x + TAU=REAL(TAUD) + LAU=INT(TAU*PAS1) + TEMP=DBLE(E0(LAU)+E1(LAU)*TAU) + EXPT(IMU,I)=1.D0-TEMP*TAUD + EXP2(IMU,I)=TEMP*HID + ELSE +* Exact exponential + EXPT(IMU,I)=EXP(-TAUD) + EXP2(IMU,I)=(1.D0-EXPT(IMU,I))/DBLE(SIGANG(NZI)) + ENDIF + ENDDO + ENDIF + NUMOLD=NOMI + ENDDO +* + RETURN + END diff --git a/Dragon/src/MOCSCEL.f b/Dragon/src/MOCSCEL.f new file mode 100644 index 0000000..84403bd --- /dev/null +++ b/Dragon/src/MOCSCEL.f @@ -0,0 +1,116 @@ +*DECK MOCSCEL + SUBROUTINE MOCSCEL(N,NREG,NSOUT,M,NOM,NZON,H,SIGANG,DSIG,EXPT, + 1 EXP2,NMU,ZMU) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculate coefficients of a track for the cyclic characteristics +* integration: Linear-Discontinuous-Characteristics scheme with exact +* exponential and 'source term isolation' option turned off. +* +*Copyright: +* Copyright (C) 2015 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* N number of elements in the current track. +* NREG number of volumes. +* NSOUT number of surfaces. +* M number of material mixtures. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* H vector containing the lenght of the different segments of this +* track. +* SIGANG macroscopic total cross sections and albedos. +* NMU order of the polar quadrature set. +* ZMU inverse of polar quadrature cosines. +* +*Parameters: output +* DSIG macroscopic total cross sections. +* EXPT track coefficient. +* EXP2 quadratic expansion of (1-exp(-a*L))/L with small argument. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,NREG,NSOUT,M,NOM(N),NZON(-NSOUT:NREG),NMU + REAL SIGANG(-6:M),ZMU(NMU) + DOUBLE PRECISION H(N),DSIG(N),EXPT(NMU,N),EXP2(5,NMU,N) +*---- +* LOCAL VARIABLES +*---- + INTEGER I,NOMI,NUMOLD,NZI,IMU + DOUBLE PRECISION TAUDMIN,SQ3,HID,TAUD,TEMP,C1,C2,H2,H3 +* tabulated exponential common block + PARAMETER ( TAUDMIN=2.0D-2 ) +* + SQ3=SQRT(3.0D0) + NUMOLD=NOM(1) + DO I=1,N + NOMI=NOM(I) + NZI=NZON(NOMI) + DSIG(I)=SIGANG(NZI) + IF(NZI.LT.0) THEN + DO IMU=1,NMU + EXP2(2,IMU,I)=0.D0 + EXP2(3,IMU,I)=0.D0 + EXP2(5,IMU,I)=0.D0 + ENDDO + IF(NUMOLD.NE.NOMI) THEN + DO IMU=1,NMU + EXP2(1,IMU,I)=SIGANG(NZI) + EXP2(4,IMU,I)=EXP2(1,IMU,I) + EXPT(IMU,I)=EXP2(1,IMU,I) + ENDDO + ELSE + DO IMU=1,NMU + EXP2(1,IMU,I)=1.D0 + EXP2(4,IMU,I)=1.D0 + EXPT(IMU,I)=EXP2(1,IMU,I) + ENDDO + ENDIF + ELSE + DO IMU=1,NMU + HID=DBLE(H(I)*ZMU(IMU)) + TAUD=SIGANG(NZI)*HID + IF(TAUD.LE.TAUDMIN) THEN +* Use Taylor series expansions + H2=HID*HID + H3=H2*HID + EXPT(IMU,I)=TAUD*(0.5D0*TAUD-1.0D0)+1.0D0 + EXP2(1,IMU,I)=HID*(TAUD*(TAUD/6.0D0-0.5D0)+1.0D0) + EXP2(2,IMU,I)=H2*(TAUD*(TAUD-4.0D0)+12.0D0)/24.0D0 + EXP2(3,IMU,I)=-SQ3*H3*(TAUD*(TAUD-2.0D0)+4.0D0)/24.0D0 + EXP2(4,IMU,I)=-SQ3*TAUD*(TAUD*(TAUD-2.0D0)+4.0D0) + 1 /24.0D0 + EXP2(5,IMU,I)=H3*(TAUD*TAUD-TAUD+4.0D0)/40.0D0 + ELSE +* Use exact exponential + EXPT(IMU,I)=EXP(-TAUD) + TEMP=(1.D0-EXPT(IMU,I))/TAUD + EXP2(1,IMU,I)=TEMP*HID + EXP2(2,IMU,I)=HID*(1.D0-TEMP)/DSIG(I) + EXP2(3,IMU,I)=-SQ3*HID*(2.0D0-(TAUD+2.0D0)*TEMP) + 1 /DSIG(I)**2 + EXP2(4,IMU,I)=-SQ3*(2.0D0-(TAUD+2.0D0)*TEMP)/TAUD + C1=TAUD*(TAUD-6.0D0)-12.0D0 + C2=TAUD*(3.0D0*TAUD+12.0D0)+12.0D0 + EXP2(5,IMU,I)=(C1+C2*TEMP)/(TAUD*DSIG(I)**3) + ENDIF + ENDDO + ENDIF + NUMOLD=NOMI + ENDDO +* + RETURN + END diff --git a/Dragon/src/MOCSCES.f b/Dragon/src/MOCSCES.f new file mode 100644 index 0000000..314a7da --- /dev/null +++ b/Dragon/src/MOCSCES.f @@ -0,0 +1,107 @@ +*DECK MOCSCES + SUBROUTINE MOCSCES(N,NREG,NSOUT,M,NOM,NZON,H,SIGANG,EXPT,EXP2, + 1 NMU,ZMU) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculate coefficients of a track for the cyclic characteristics +* integration: Step-Characteristics scheme with exact exponential and +* 'source term isolation' option turned off. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy and R. Le Tellier +* +*Parameters: input +* N number of elements in the current track. +* NREG number of volumes. +* NSOUT number of surfaces. +* M number of material mixtures. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* H vector containing the lenght of the different segments of this +* track. +* SIGANG macroscopic total cross sections and albedos. +* NMU order of the polar quadrature set. +* ZMU inverse of polar quadrature cosines. +* +*Parameters: output +* EXPT track coefficient. +* EXP2 quadratic expansion of (1-exp(-a*L))/L with small argument. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,NREG,NSOUT,M,NOM(N),NZON(-NSOUT:NREG),NMU + REAL SIGANG(-6:M),ZMU(NMU) + DOUBLE PRECISION H(N),EXPT(NMU,N),EXP2(2,NMU,N) +*---- +* LOCAL VARIABLES +*---- + INTEGER I,NOMI,NUMOLD,NZI,IMU + REAL TAU + DOUBLE PRECISION TAUDMIN,HID,TAUD,TEMP,HID2,TAUD3,TAUD4,TAUD5 +* tabulated exponential common block + REAL E0, E1, PAS1, DX1, XLIM1 + INTEGER MEX1, LAU + PARAMETER ( MEX1=7936, TAUDMIN=2.D-2 ) + COMMON /EXP1/ E0(0:MEX1),E1(0:MEX1),PAS1,DX1,XLIM1 +* + NUMOLD=NOM(1) + DO I=1,N + NOMI=NOM(I) + NZI=NZON(NOMI) + IF(NZI.LT.0) THEN + IF(NUMOLD.NE.NOMI) THEN + DO IMU=1,NMU + EXP2(1,IMU,I)=SIGANG(NZI) + EXPT(IMU,I)=EXP2(1,IMU,I) + ENDDO + ELSE + DO IMU=1,NMU + EXP2(1,IMU,I)=1.D0 + EXPT(IMU,I)=EXP2(1,IMU,I) + ENDDO + ENDIF + ELSE + DO IMU=1,NMU + HID=DBLE(H(I)*ZMU(IMU)) + TAUD=SIGANG(NZI)*HID + IF(TAUD.LE.TAUDMIN) THEN +* Linear interpolation in table of (1-exp(-x))/x + TAU=REAL(TAUD) + LAU=INT(TAU*PAS1) + TEMP=DBLE(E0(LAU)+E1(LAU)*TAU) + EXPT(IMU,I)=1.D0-TEMP*TAUD + EXP2(1,IMU,I)=TEMP*HID +* and expansion in Taylor serie in O(TAUD^3) + TAUD3=TAUD/3.D0 + TAUD4=0.125D0*TAUD + TAUD5=0.2D0*TAUD + HID2=HID*HID + EXP2(2,IMU,I)=HID2*(0.5D0-TAUD3*(0.5D0-TAUD4 + 1 *(1.D0-TAUD5))) + ELSE +* Exact exponential + EXPT(IMU,I)=EXP(-TAUD) + TEMP=(1.D0-EXPT(IMU,I))/TAUD + EXP2(1,IMU,I)=TEMP*HID + EXP2(2,IMU,I)=HID*(1.D0-TEMP)/DBLE(SIGANG(NZI)) + ENDIF + ENDDO + ENDIF + NUMOLD=NOMI + ENDDO +* + RETURN + END diff --git a/Dragon/src/MOCSCET.f b/Dragon/src/MOCSCET.f new file mode 100644 index 0000000..bb8bcb4 --- /dev/null +++ b/Dragon/src/MOCSCET.f @@ -0,0 +1,79 @@ +*DECK MOCSCET + SUBROUTINE MOCSCET(N,NREG,NSOUT,M,NOM,NZON,H,SIGANG,EXPT,EXP2, + 1 NMU,ZMU) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculate coefficients of a track for the cyclic characteristics +* integration: Step-Characteristics scheme with exact exponential and +* 'MOCC/MCI' integration strategy. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy and R. Le Tellier +* +*Parameters: input +* N number of elements in the current track. +* NREG number of volumes. +* NSOUT number of surfaces. +* M number of material mixtures. +* NOM vector containing the region number of the different segments +* of this track. +* NZON index-number of the mixture type assigned to each volume. +* H vector containing the lenght of the different segments of this +* track. +* SIGANG macroscopic total cross sections and albedos. +* NMU order of the polar quadrature set. +* ZMU inverse of polar quadrature cosines. +* +*Parameters: output +* EXPT track coefficient. +* EXP2 quadratic expansion of (1-exp(-a*L))/L with small argument. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER N,NREG,NSOUT,M,NOM(N),NZON(-NSOUT:NREG),NMU + REAL SIGANG(-6:M),ZMU(NMU) + DOUBLE PRECISION H(N),EXPT(NMU,N),EXP2(NMU,N) +*---- +* LOCAL VARIABLES +*---- + INTEGER I,NOMI,NUMOLD,NZI,IMU + DOUBLE PRECISION TAUD +* + NUMOLD=NOM(1) + DO I=1,N + NOMI=NOM(I) + NZI=NZON(NOMI) + IF (NZI.LT.0) THEN + IF (NUMOLD.NE.NOMI) THEN + DO IMU=1,NMU + EXP2(IMU,I)=1.D0-SIGANG(NZI) + ENDDO + ELSE + DO IMU=1,NMU + EXP2(IMU,I)=0.D0 + ENDDO + ENDIF + ELSE + DO IMU=1,NMU + TAUD=SIGANG(NZI)*H(I)*ZMU(IMU) + EXP2(IMU,I)=(1.D0-DEXP(-TAUD)) + ENDDO + ENDIF + NUMOLD=NOMI + ENDDO + EXPT(:NMU,:N)=0.0D0 +* + RETURN + END diff --git a/Dragon/src/MPO.f b/Dragon/src/MPO.f new file mode 100644 index 0000000..0c77288 --- /dev/null +++ b/Dragon/src/MPO.f @@ -0,0 +1,700 @@ +*DECK MPO + SUBROUTINE MPO(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Creation and construction of a MPO database object. +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1) MPO database object; +* HENTRY(I) I>1 read-only type(L_BURNUP, L_LIBRARY, L_EDIT +* or MPO file). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file; =6 HDF5 file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40,MAXPAR=50,MAXISO=800,NKEYS=7,NREAK=10, + 1 MAXMAC=2,MAXREA=50,MAXCAD=153) + TYPE(C_PTR) IPMPO,IPLB1,IPLB2,IPDEPL,IPEDIT + CHARACTER TEXT24*24,TEXT8*8,TEXT12*12,TEXT20*20,HSMPO*132, + 1 HSMG*131,HEDIT*12,CDIRO*12,RECNAM*72,HSIGN*12,KEYWRD(NKEYS)*4, + 2 NOMISO(MAXISO)*20,NOMEVO(MAXISO)*12,REANAM(NREAK)*20, + 3 NOMREA(MAXREA)*20,REV*48,DATE*64 + DOUBLE PRECISION DFLOTT + LOGICAL LINIT,LWARN,LGNEW(MAXPAR) + INTEGER ISTATE(NSTATE),TYPISO(MAXISO),MUPLET(MAXPAR),DIMSR(5), + 1 RANK,TYPE +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NVALUE,PARADR,PARADL, + 1 REACTION,ISOTOPE,ADDRISO,DIMS_MPO + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: OUPUTID,OUPUTID2 + REAL, ALLOCATABLE, DIMENSION(:) :: TIMES,VOL,ENERG + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: PARFMT + CHARACTER(LEN=24), ALLOCATABLE, DIMENSION(:) :: PARTYP,PARKEY, + 1 PARCAD,PARTYL,PARKEL,PARCAL + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPRHS +*---- +* DATA STATEMENTS +*---- + DATA KEYWRD/'NOML','PARA','LOCA','ISOT','MACR','REAC','; '/ + DATA REANAM/'Total ','Absorption ', + 1 'Diffusion ','Fission ', + 2 'FissionSpectrum ','Nexcess ', + 3 'NuFission ','Scattering ', + 4 'CaptureEnergyCapture','FissionEnergyFission'/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IPRHS(NENTRY)) +*---- +* PARAMETER VALIDATION. +*---- + LINIT=.FALSE. + IF(NENTRY.EQ.0) CALL XABORT('MPO: PARAMETERS EXPECTED.') + IF((IENTRY(1).EQ.6).AND.(JENTRY(1).EQ.0)) THEN + IPMPO=KENTRY(1) + LINIT=.TRUE. + CALL KDRVER(REV,DATE) + HSMPO='DRAGON5 generated file' + CALL hdf5_create_group(IPMPO,"info") + CALL hdf5_write_data(IPMPO,"/info/DRAGON5_VERSION", + 1 TRIM(HSMPO)) + IVERS=1 + CALL hdf5_write_data(IPMPO,"/info/MPO_VERSION",IVERS) + HSMPO='MPO LIBRARY'//REV//DATE + CALL hdf5_write_data(IPMPO,"/info/MPO_CREATION_INFO", + 1 TRIM(HSMPO)) + ELSE IF(IENTRY(1).EQ.6) THEN + IPMPO=KENTRY(1) + CALL hdf5_info(IPMPO,"info/MPO_VERSION",RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.EQ.99) THEN + TEXT12=HENTRY(1) + CALL XABORT('MPO: HDF FILE '//TEXT12//' CANNOT BE READ.') + ENDIF + LINIT=.FALSE. + ELSE + CALL XABORT('MPO: MPO HDF5 OBJECT EXPECTED.') + ENDIF + TYPISO(:MAXISO)=0 + IPLB1=C_NULL_PTR + IPLB2=C_NULL_PTR + IPDEPL=C_NULL_PTR + IPEDIT=C_NULL_PTR + IPRHS(:NENTRY)=C_NULL_PTR + DO 10 I=2,NENTRY + IF(JENTRY(I).NE.2) CALL XABORT('MPO: READ-ONLY RHS EXPECTED.') + IF(IENTRY(I).LE.2) THEN + CALL LCMGTC(KENTRY(I),'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_LIBRARY') THEN + IF(.NOT.C_ASSOCIATED(IPLB1)) THEN + IPLB1=KENTRY(I) + ELSE + IF(.NOT.C_ASSOCIATED(IPLB2)) IPLB2=KENTRY(I) + ENDIF + ELSE IF(HSIGN.EQ.'L_BURNUP') THEN + IPDEPL=KENTRY(I) + ELSE IF(HSIGN.EQ.'L_EDIT') THEN + IPEDIT=KENTRY(I) + ENDIF + ELSE IF(IENTRY(I).EQ.6) THEN + IPRHS(I)=KENTRY(I) + ELSE + CALL XABORT('MPO: LCM OR HDF5 OBJECTS EXPECTED AT RHS.') + ENDIF + 10 CONTINUE +*---- +* READ THE INPUT DATA. +*---- +* DEFAULT OPTIONS: + ALLOCATE(PARADR(MAXPAR+1),PARCAD(MAXCAD),NVALUE(MAXPAR)) + ALLOCATE(PARKEL(MAXPAR),PARTYL(MAXPAR),PARADL(MAXPAR+1), + 1 PARCAL(MAXCAD)) + IMPX=1 + IF(LINIT) THEN + ALLOCATE(PARKEY(MAXPAR),PARFMT(MAXPAR),PARTYP(MAXPAR)) + NPAR=0 + NPCHR=0 + NLOC=0 + NPCHL=0 + NISO=0 + NMIL=0 + PARADR(1)=0 + PARADL(1)=0 + DO 15 IKEY=1,NREAK + NOMREA(IKEY)=REANAM(IKEY) + 15 CONTINUE + NREA=NREAK + ELSE + GO TO 300 + ENDIF + 20 CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('MPO: CHARACTER DATA EXPECTED(1).') + 30 IF(TEXT8.EQ.'EDIT') THEN +* READ THE PRINT INDEX. + CALL REDGET(INDIC,IMPX,FLOTT,TEXT24,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MPO: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT8.EQ.'COMM') THEN + CALL REDGET(INDIC,NITMA,FLOTT,HSMPO,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('MPO: COMMENTS EXPECTED.') + CALL hdf5_write_data(IPMPO,"info/MPO_CREATION_INFO", + 1 TRIM(HSMPO)) + ELSE IF(TEXT8.EQ.'PARA') THEN + NPAR=NPAR+1 + IF(NPAR.GT.MAXPAR) CALL XABORT('MPO: TOO MANY PARAMETERS.') + PARKEY(NPAR)=' ' + CALL REDGET(INDIC,NITMA,FLOTT,PARKEY(NPAR),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('MPO: CHARACTER DATA EXPECTED' + 1 //'(4).') + DO 50 I=1,NPAR-1 + IF(PARKEY(NPAR).EQ.PARKEY(I)) CALL XABORT('MPO: PARKEY '// + 1 PARKEY(NPAR)//' ALREADY DEFINED(1).') + 50 CONTINUE + CALL REDGET(INDIC,NITMA,FLOTT,TEXT24,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('MPO: CHARACTER DATA EXPECTED' + 1 //'(4).') + PARTYP(NPAR)=TEXT24 + IF(TEXT24.EQ.'TEMP') THEN + IF(NPCHR+2.GT.MAXCAD) CALL XABORT('MPO: MAXCAD OVERFLOW(1).') + NPCHR=NPCHR+1 + CALL REDGET(INDIC,NITMA,FLOTT,PARCAD(NPCHR),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('MPO: CHARACTER DATA EXPECTED' + 1 //'(5).') + NPCHR=NPCHR+1 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT24,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MPO: INTEGER DATA EXPECTE'// + 1 'D(2).') + WRITE(PARCAD(NPCHR),'(3HMIX,I9.9)') NITMA + PARFMT(NPAR)='FLOAT' + PARTYP(NPAR)='TEMPERATURE' + ELSE IF(TEXT24.EQ.'CONC') THEN + IF(NPCHR+3.GT.MAXCAD) CALL XABORT('MPO: MAXCAD OVERFLOW(2).') + NPCHR=NPCHR+1 + CALL REDGET(INDIC,NITMA,FLOTT,PARCAD(NPCHR),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('MPO: CHARACTER DATA EXPECTED' + 1 //'(6).') + NPCHR=NPCHR+1 + CALL REDGET(INDIC,NITMA,FLOTT,PARCAD(NPCHR),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('MPO: CHARACTER DATA EXPECTED' + 1 //'(7).') + NPCHR=NPCHR+1 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT24,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MPO: INTEGER DATA EXPECTE'// + 1 'D(3).') + WRITE(PARCAD(NPCHR),'(3HMIX,I9.9)') NITMA + PARFMT(NPAR)='FLOAT' + PARTYP(NPAR)='CONCENTRATION_MATERIAL' + ELSE IF(TEXT24.EQ.'IRRA') THEN + PARFMT(NPAR)='FLOAT' + PARTYP(NPAR)='BURNUP' + ELSE IF(TEXT24.EQ.'FLUX') THEN + PARFMT(NPAR)='FLOAT' + ELSE IF(TEXT24.EQ.'FLUB') THEN + PARFMT(NPAR)='FLOAT' + ELSE IF(TEXT24.EQ.'PUIS') THEN + PARFMT(NPAR)='FLOAT' + ELSE IF(TEXT24.EQ.'TIME') THEN + PARFMT(NPAR)='FLOAT' + PARTYP(NPAR)='TIME' + ELSE IF(TEXT24.EQ.'VALU') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('MPO: CHARACTER DATA EXPECTED' + 1 //'(8).') + IF(TEXT8.EQ.'REAL')THEN + PARFMT(NPAR)='FLOAT' + ELSEIF(TEXT8.EQ.'CHAR')THEN + PARFMT(NPAR)='STRING' + ELSEIF(TEXT8.EQ.'INTE')THEN + PARFMT(NPAR)='INTEGER' + ELSE + CALL XABORT('MPO: INVALID KEYWORD='//TEXT24//'(1).') + ENDIF + ELSE + CALL XABORT('MPO: INVALID KEYWORD='//TEXT24//'(2).') + ENDIF + NVALUE(NPAR)=0 + PARADR(NPAR+1)=NPCHR + ELSE IF(TEXT8.EQ.'LOCA') THEN + NLOC=NLOC+1 + IF(NLOC.GT.MAXPAR) CALL XABORT('MPO: TOO MANY LOCAL VAR'// + 1 'IABLES.') + CALL REDGET(INDIC,NITMA,FLOTT,PARKEL(NLOC),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('MPO: CHARACTER DATA EXPECTED' + 1 //'(10).') + DO 70 I=1,NLOC-1 + IF(PARKEL(NLOC).EQ.PARKEL(I)) CALL XABORT('MPO: PARKEY '// + 1 PARKEL(NLOC)//' ALREADY DEFINED(2).') + 70 CONTINUE + CALL REDGET(INDIC,NITMA,FLOTT,TEXT24,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('MPO: CHARACTER DATA EXPECTED' + 1 //'(11).') + IF(TEXT24.EQ.'CONC') THEN + IF(NPCHL+1.GT.MAXCAD) CALL XABORT('MPO: MAXCAD OVERFLOW(3).') + NPCHL=NPCHL+1 + CALL REDGET(INDIC,NITMA,FLOTT,PARCAL(NPCHL),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('MPO: CHARACTER DATA EXPECTED' + 1 //'(12).') + ELSE IF((TEXT24.NE.'IRRA').AND.(TEXT24.NE.'FLUG').AND. + 1 (TEXT24.NE.'FLUB').AND.(TEXT24.NE.'PUIS').AND. + 2 (TEXT24.NE.'MASL').AND.(TEXT24.NE.'FLUX').AND. + 3 (TEXT24.NE.'EQUI').AND.(TEXT24.NE.'TEMP')) THEN + CALL XABORT('MPO: INVALID KEYWORD='//TEXT24//'(3).') + ENDIF + PARTYL(NLOC)=TEXT24 + PARADL(NLOC+1)=NPCHL + ELSE IF(TEXT8.EQ.'ISOT') THEN + 80 CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('MPO: CHARACTER DATA EXPECTED' + 1 //'(13).') + DO 90 IKEY=1,NKEYS + IF(TEXT8.EQ.KEYWRD(IKEY)) GO TO 30 + 90 CONTINUE + IF(TEXT8.EQ.'TOUT') THEN + CALL COMISO(-1,MAXISO,IPLB1,NISO,NOMISO,NOMEVO,TYPISO) + GO TO 20 + ELSE IF(TEXT8.EQ.'FISS') THEN + CALL COMISO(-2,MAXISO,IPLB1,NISO,NOMISO,NOMEVO,TYPISO) + ELSE IF(TEXT8.EQ.'PF') THEN + CALL COMISO(-3,MAXISO,IPLB1,NISO,NOMISO,NOMEVO,TYPISO) + ELSE IF(TEXT8.EQ.'MILI') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT24,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MPO: INTEGER DATA EXPECTE'// + 1 'D(4).') + CALL COMISO(NITMA,MAXISO,IPLB1,NISO,NOMISO,NOMEVO,TYPISO) + ELSE + DO 100 IKEY=1,NKEYS + IF(TEXT8.EQ.KEYWRD(IKEY)) GO TO 30 + 100 CONTINUE + NISO=NISO+1 + IF(NISO.GT.MAXISO) CALL XABORT('MPO: TOO MANY ISOTOPES.') + NOMISO(NISO)=TEXT8 + TYPISO(NISO)=0 + ENDIF + GO TO 80 + ELSE IF(TEXT8.EQ.'REAC') THEN + 110 CALL REDGET(INDIC,NITMA,FLOTT,TEXT20,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('MPO: CHARACTER DATA EXPECTED' + 1 //'(16).') + IF(TEXT20.EQ.';') GO TO 160 + DO 120 IKEY=1,NKEYS + IF(TEXT20.EQ.KEYWRD(IKEY)) GO TO 30 + 120 CONTINUE + DO 130 IKEY=1,NREAK + IF(TEXT20.EQ.REANAM(IKEY)) GO TO 110 + 130 CONTINUE + NREA=NREA+1 + IF(NREA.GT.MAXREA) CALL XABORT('MPO: TOO MANY REACTIONS.') + NOMREA(NREA)=TEXT20 + GO TO 110 + ELSE IF(TEXT8.EQ.';') THEN + GO TO 160 + ELSE + CALL XABORT('MPO: INVALID KEYWORD='//TEXT8//'(4).') + ENDIF + GO TO 20 +* +* ADD MACROSCOPIC RESIDUAL TO ISOTOPES. + 160 NISO=NISO+1 + IF(NISO.GT.MAXISO) CALL XABORT('MPO: TOO MANY ISOTOPES.') + NOMISO(NISO)='TotalResidual_mix' + TYPISO(NISO)=0 + MUPLET(:NPAR)=-99 +* +* CREATE MPO GROUPS. + CALL hdf5_create_group(IPMPO,"/contents") + CALL hdf5_create_group(IPMPO,"/contents/isotopes") + CALL hdf5_create_group(IPMPO,"/contents/mixtures") + CALL hdf5_create_group(IPMPO,"/contents/reactions") + CALL hdf5_create_group(IPMPO,"/parameters") + CALL hdf5_create_group(IPMPO,"/parameters/info") + CALL hdf5_create_group(IPMPO,"/parameters/tree") + CALL hdf5_create_group(IPMPO,"/parameters/values") + CALL hdf5_create_group(IPMPO,"/energymesh") + CALL hdf5_create_group(IPMPO,"/geometry") + ICAL=0 + CALL hdf5_write_data(IPMPO,"/parameters/tree/NSTATEPOINT",ICAL) +* +* PRINT THE TITLE. + IF(IMPX.GT.0) THEN + CALL hdf5_read_data(IPMPO,"info/MPO_CREATION_INFO",HSMPO) + CALL hdf5_read_data(IPMPO,"info/MPO_VERSION",IVERS) + WRITE(6,400) HSMPO,IVERS + ENDIF +* +* ADD THE TIME PARAMETER. + DO 170 I=1,NPAR + IF((PARTYP(I).EQ.'BURNUP').OR.(PARTYP(I).EQ.'FLUB')) GO TO 180 + 170 CONTINUE + GO TO 220 + 180 DO 210 I=1,NPAR + IF(PARTYP(I).EQ.'TIME') GO TO 220 + 210 CONTINUE + NPAR=NPAR+1 + IF(NPAR.GT.MAXPAR) CALL XABORT('MPO: TOO MANY PARAMETERS.') + PARKEY(NPAR)='Time' + PARTYP(NPAR)='TIME' + PARFMT(NPAR)='FLOAT' + PARADR(NPAR+1)=NPCHR + NVALUE(NPAR)=0 +*---- +* STORE THE MPO INITIALIZATION INFORMATION. +*---- + 220 IF(NISO.GT.0) THEN + CALL COMISO(0,MAXISO,IPLB1,NISO-1,NOMISO,NOMEVO,TYPISO) + CALL hdf5_write_data(IPMPO,"/contents/isotopes/ISOTOPENAME", + 1 NOMISO(:NISO)) + ENDIF + IF(NREA.GT.0) THEN + CALL hdf5_write_data(IPMPO,"/contents/reactions/REACTIONAME", + 1 NOMREA(:NREA)) + ENDIF +* + IF(NPAR.GT.0) THEN + CALL hdf5_write_data(IPMPO,"/parameters/info/PARAMNAME", + 1 PARKEY(:NPAR)) + CALL hdf5_write_data(IPMPO,"/parameters/info/PARAMTYPE", + 1 PARTYP(:NPAR)) + CALL hdf5_write_data(IPMPO,"/parameters/info/PARAMFORM", + 1 PARFMT(:NPAR)) + IF(NPCHR.GT.0) THEN + CALL hdf5_write_data(IPMPO,"/parameters/info/PARAMINFO", + 1 PARCAD(:NPCHR)) + ENDIF + CALL hdf5_write_data(IPMPO,"/parameters/info/PARAMINFOADR", + 1 PARADR(:NPAR+1)) + CALL hdf5_write_data(IPMPO,"/parameters/info/NVALUE", + 1 NVALUE(:NPAR)) + ENDIF +* + IF(NLOC.GT.0) THEN + CALL hdf5_write_data(IPMPO,"/local_values/LOCVALNAME", + 1 PARKEL(:NLOC)) + CALL hdf5_write_data(IPMPO,"/local_values/LOCVALTYPE", + 1 PARTYL(:NLOC)) + CALL hdf5_write_data(IPMPO,"/local_values/LOCVALINFOADR", + 1 PARADL(:NLOC+1)) + CALL hdf5_write_data(IPMPO,"/local_values/NLOCVALINFO",NPCHL) + IF(NPCHL.GT.0) THEN + CALL hdf5_write_data(IPMPO,"/local_values/LOCVALINFO", + 1 PARCAL(:NPCHL)) + ENDIF + ENDIF + IF(NLOC.GT.0) DEALLOCATE(PARCAL,PARADL,PARTYL,PARKEL) + IF(NPAR.GT.0) DEALLOCATE(NVALUE,PARCAD,PARADR,PARTYP,PARFMT, + 1 PARKEY) + GO TO 390 +* END OF MPO INITIALIZATION. ********************************** +*---- +* INPUT AN ELEMENTARY CALCULATION. ******************************* +*---- + 300 CALL hdf5_read_data(IPMPO,"/info/MPO_VERSION",IVERS) + IF(IVERS.NE.1) CALL XABORT('MPO: INVALID VERSION OF MPO SPECIF'// + 1 'ICATION.') + NPAR=0 + IF(hdf5_group_exists(IPMPO,"/parameters/info/")) THEN + CALL hdf5_info(IPMPO,"/parameters/info/NVALUE",RANK,TYPE,NBYTE, + 1 DIMSR) + IF(RANK.GT.0) NPAR=DIMSR(1) + ENDIF + IF(NPAR.GT.0) THEN + CALL hdf5_read_data(IPMPO,"/parameters/info/PARAMNAME",PARKEY) + CALL hdf5_read_data(IPMPO,"/parameters/info/PARAMFORM",PARFMT) + CALL hdf5_read_data(IPMPO,"/parameters/info/PARAMTYPE",PARTYP) + ENDIF +* + ITIM=0 + LWARN=.FALSE. + HEDIT='output_0' + IMPX=0 + IPICK=0 + 310 CALL REDGET(INDIC,NITMA,FLOTT,TEXT24,DFLOTT) + IF(INDIC.EQ.10) GO TO 350 + IF(INDIC.NE.3) CALL XABORT('MPO: CHARACTER DATA EXPECTED(18).') + IF(TEXT24.EQ.'EDIT') THEN +* READ THE PRINT INDEX. + CALL REDGET(INDIC,IMPX,FLOTT,TEXT24,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MPO: INTEGER DATA EXPECTED(5).') + ELSE IF(TEXT24.EQ.'STEP') THEN +* SET THE NAME OF THE OUTPUT SET. + CALL REDGET(INDIC,NITMA,FLOTT,HEDIT,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('MPO: DIR-NAME EXPECTED.') + IF(HEDIT(:7).NE.'output_') CALL XABORT('MPO: output_ EXPECTED.') + IF(IMPX.GT.0) WRITE(6,'(/28H MPO: ACCESS A GROUP NAMED '',A, + 1 31H'' TO STORE THE MPO INFORMATION.)') TRIM(HEDIT) + ELSE IF(TEXT24.EQ.'SET') THEN + CALL REDGET(INDIC,NITMA,XT,TEXT24,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MPO: REAL DATA EXPECTED(1).') + CALL REDGET(INDIC,NITMA,FLOTT,TEXT24,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('MPO: CHARACTER DATA EXPECTED' + 1 //'(19).') + IF(TEXT24.EQ.'S') THEN + XT=XT*1.0E-8 + ELSE IF(TEXT24.EQ.'DAY') THEN + XT=XT*8.64E-4 + ELSE IF(TEXT24.EQ.'YEAR') THEN + XT=XT*3.1536E-1 + ELSE + CALL XABORT('MPO: S, DAY OR YEAR EXPECTED.') + ENDIF + IF(.NOT.C_ASSOCIATED(IPDEPL)) CALL XABORT('MPO: DEPLETION OBJ' + 1 //'ECT EXPECTED AT RHS.') + CALL LCMLEN(IPDEPL,'DEPL-TIMES',NTIM,ITYLCM) + IF(NTIM.EQ.0) CALL XABORT('MPO: NO DEPLETION TIME STEPS.') + ALLOCATE(TIMES(NTIM)) + CALL LCMGET(IPDEPL,'DEPL-TIMES',TIMES) + DO 320 I=1,NTIM + IF(ABS(TIMES(I)-XT).LE.1.0E-4*XT) ITIM=I + 320 CONTINUE + IF(ITIM.EQ.0) THEN + WRITE(HSMG,'(39HMPO: UNABLE TO FIND A DEPLETION DIRECTO, + 1 12HRY AT TIME =,1P,E12.4,5H DAY.)') XT/8.64E-4 + CALL XABORT(HSMG) + ENDIF + DEALLOCATE(TIMES) + IF(IMPX.GT.0) THEN + WRITE(TEXT12,'(8HDEPL-DAT,I4.4)') ITIM + WRITE(6,430) XT,XT/8.64E-4,TEXT12 + ENDIF + ELSE IF(TEXT24.EQ.';') THEN + GO TO 350 + ELSE IF(TEXT24.EQ.'ICAL') THEN + IPICK=1 + GO TO 350 + ELSE IF(TEXT24.EQ.'WARNING-ONLY') THEN + LWARN=.TRUE. + ELSE + DO 330 IKEY=1,NPAR + IF(TEXT24.EQ.PARKEY(IKEY)) THEN + IPAR=IKEY + GO TO 340 + ENDIF + 330 CONTINUE + CALL XABORT('MPO: INVALID KEYWORD='//TEXT24//'(5).') + 340 IF(PARTYP(IPAR).NE.'VALU') CALL XABORT('MPO: '//TEXT24// + 1 ' IS NOT OF VALU TYPE.') + CALL REDGET(INDIC,NITMA,FLOTT,TEXT24,DFLOTT) + IF(PARFMT(IPAR).EQ.'INTEGER') THEN + IF(INDIC.NE.1) CALL XABORT('MPO: INTEGER DATA EXPECTE'// + 1 'D(7).') + IF(IMPX.GT.0) WRITE(6,450) TRIM(PARKEY(IPAR)),NITMA + ELSE IF(PARFMT(IPAR).EQ.'FLOAT') THEN + IF(INDIC.NE.2) CALL XABORT('MPO: REAL DATA EXPECTED(2).') + IF(IMPX.GT.0) WRITE(6,440) TRIM(PARKEY(IPAR)),FLOTT + ELSE IF(PARFMT(IPAR).EQ.'STRING') THEN + IF(INDIC.NE.3) CALL XABORT('MPO: CHARACTER DATA EXPEC'// + 1 'TED(20).') + IF(IMPX.GT.0) WRITE(6,460) TRIM(PARKEY(IPAR)),TEXT24 + ENDIF + CALL MPOPAV(IPMPO,HEDIT,IPAR,NPAR,PARFMT(IPAR),FLOTT,NITMA, + 1 TEXT24,MUPLET(IPAR),LGNEW(IPAR)) + ENDIF + GO TO 310 +*---- +* RECOVER AN ELEMENTARY CALCULATION FROM EDITION. +*---- + 350 NCALS=0 + IF(hdf5_group_exists(IPMPO,"/parameters/tree")) THEN + CALL hdf5_read_data(IPMPO,"/parameters/tree/NSTATEPOINT",NCALS) + ENDIF + READ(HEDIT,'(7X,I2)') ID + IF(NENTRY.GE.2) THEN + IF(C_ASSOCIATED(IPRHS(2))) GO TO 370 ! concatenation + ENDIF + IF(hdf5_group_exists(IPMPO,"/output/")) THEN + CALL hdf5_read_data(IPMPO,"/output/NOUTPUT",NOUTPUT) + CALL hdf5_read_data(IPMPO,"/output/OUPUTID",OUPUTID) + CALL hdf5_read_data(IPMPO,"/energymesh/NENERGYMESH",NENERG) + CALL hdf5_read_data(IPMPO,"/geometry/NGEOMETRY",NGEOME) + DO I=1,NGEOME + DO J=1,NENERG + IF(OUPUTID(J,I).EQ.ID) GO TO 360 + ENDDO + ENDDO + ALLOCATE(OUPUTID2(NENERG+1,NGEOME+1)) + OUPUTID2(:NENERG+1,:NGEOME+1)=0 + OUPUTID2(:NENERG,:NGEOME)=OUPUTID(:NENERG,:NGEOME) + DEALLOCATE(OUPUTID) + ELSE + CALL hdf5_create_group(IPMPO,"/output") + ALLOCATE(OUPUTID2(1,1)) + OUPUTID2(1,1)=ID + NENERG=0 + NGEOME=0 + NOUTPUT=0 + ENDIF + NENERG=NENERG+1 + NGEOME=NGEOME+1 + CALL hdf5_write_data(IPMPO,"/energymesh/NENERGYMESH",NENERG) + CALL hdf5_write_data(IPMPO,"/geometry/NGEOMETRY",NGEOME) + OUPUTID2(NENERG,NGEOME)=ID + CALL hdf5_write_data(IPMPO,"/output/OUPUTID",OUPUTID2) + DEALLOCATE(OUPUTID2) + NOUTPUT=NOUTPUT+1 + CALL hdf5_write_data(IPMPO,"/output/NOUTPUT",NOUTPUT) +*---- +* RECOVER ENERGY GROUP AND VOLUME INFORMATION. +*---- + CALL LCMGTC(IPEDIT,'LAST-EDIT',12,CDIRO) + CALL LCMSIX(IPEDIT,CDIRO,1) + CALL LCMSIX(IPEDIT,'MACROLIB',1) + CALL LCMGET(IPEDIT,'STATE-VECTOR',ISTATE) + NG=ISTATE(1) + NMIL=ISTATE(2) + WRITE(RECNAM,'(23H/energymesh/energymesh_,I0,1H/)') NENERG-1 + CALL hdf5_create_group(IPMPO,TRIM(RECNAM)) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"NG",NG) + ALLOCATE(ENERG(NG+1)) + CALL LCMLEN(IPEDIT,'ENERGY',ILONG,ITYLCM) + IF(ILONG.NE.NG+1) CALL XABORT('MPO: BAD VALUE OF NG.') + CALL LCMGET(IPEDIT,'ENERGY',ENERG) + WRITE(RECNAM,'(23H/energymesh/energymesh_,I0,1H/)') NENERG-1 + DO IGR=1,NG+1 + ENERG(IGR)=ENERG(IGR)*1.0E-6 + ENDDO + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"ENERGY",ENERG) + DEALLOCATE(ENERG) + WRITE(RECNAM,'(19H/geometry/geometry_,I0,1H/)') NGEOME-1 + CALL hdf5_create_group(IPMPO,TRIM(RECNAM)) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"NZONE",NMIL) + ALLOCATE(VOL(NMIL)) + CALL LCMGET(IPEDIT,'VOLUME',VOL) + WRITE(RECNAM,'(18Hgeometry/geometry_,I0,1H/)') NGEOME-1 + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"ZONEVOLUME",VOL) + DEALLOCATE(VOL) + CALL LCMSIX(IPEDIT,' ',2) + CALL LCMSIX(IPEDIT,' ',2) +*---- +* CREATE DUMMY DATASETS REACTION, ADDRISO AND ISOTOPE +*---- + CALL hdf5_get_shape(IPMPO,"/contents/isotopes/ISOTOPENAME", + 1 DIMS_MPO) + NISO=DIMS_MPO(1) + DEALLOCATE(DIMS_MPO) + CALL hdf5_get_shape(IPMPO,"/contents/reactions/REACTIONAME", + 1 DIMS_MPO) + NREA=DIMS_MPO(1) + DEALLOCATE(DIMS_MPO) + ALLOCATE(REACTION(NREA),ADDRISO(2),ISOTOPE(NISO)) + ADDRISO(1)=0 + ADDRISO(2)=NISO + DO I=1,NREA + REACTION(I)=I-1 + ENDDO + DO I=1,NISO + ISOTOPE(I)=I-1 + ENDDO + WRITE(RECNAM,'(8H/output/,A)') TRIM(HEDIT) + CALL hdf5_create_group(IPMPO,TRIM(RECNAM)) + WRITE(RECNAM,'(8H/output/,A,6H/info/)') TRIM(HEDIT) + CALL hdf5_create_group(IPMPO,TRIM(RECNAM)) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"REACTION",REACTION) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"ISOTOPE",ISOTOPE) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"ADDRISO",ADDRISO) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"NISO",NISO) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"NREA",NREA) + DEALLOCATE(ISOTOPE,ADDRISO,REACTION) +*---- +* RECOVER CALCULATION. +*---- + 360 IF(IMPX.GT.0) WRITE(6,420) NCALS+1 + IF(ITIM.GT.0) THEN + WRITE(TEXT12,'(8HDEPL-DAT,I4.4)') ITIM + CALL LCMSIX(IPDEPL,TEXT12,1) + ENDIF +* ------------------------------------------- + CALL MPOCAL(IMPX,IPMPO,IPDEPL,IPEDIT,HEDIT) +* ------------------------------------------- + IF(ITIM.GT.0) CALL LCMSIX(IPDEPL,' ',2) + NG=0 + IF(IMPX.GT.0) THEN + CALL MPOTOC(IPMPO,HEDIT,IMPX,NREA,NBISO,NMIL,NPAR,NLOC,NISOF, + 1 NISOP,NISOS,NCALS,NG,NSURFD,NALBP,NPRC) + ENDIF +*---- +* RECOVER REMAINING GLOBAL PARAMETER AND LOCAL VALUES. +*---- + NCALS=NCALS+1 + CALL hdf5_write_data(IPMPO,"/parameters/tree/NSTATEPOINT",NCALS) + CALL MPOGEP(IPMPO,IPDEPL,IPLB1,IPLB2,IPEDIT,HEDIT,IMPX,ITIM,NPAR, + 1 NLOC,MUPLET,LGNEW,NMIL,NG,NCALS) + IF(NPAR.GT.0) DEALLOCATE(PARTYP,PARFMT,PARKEY) +*---- +* SAVE THE CALCULATION INDEX IN A CLE-2000 VARIABLE +*---- + IF(IPICK.EQ.1) THEN + CALL REDGET(ITYP,NITMA,FLOTT,TEXT24,DFLOTT) + IF(ITYP.NE.-1) CALL XABORT('MPO: OUTPUT INTEGER EXPECTED.') + ITYP=1 + CALL REDPUT(ITYP,NCALS,FLOTT,TEXT24,DFLOTT) + CALL REDGET(ITYP,NITMA,FLOTT,TEXT24,DFLOTT) + IF((ITYP.NE.3).OR.(TEXT24.NE.';')) THEN + CALL XABORT('MPO: ; CHARACTER EXPECTED.') + ENDIF + ENDIF + GO TO 390 +*---- +* MPO CONCATENATION. +*---- + 370 DO 380 I=2,NENTRY + IF(.NOT.C_ASSOCIATED(IPRHS(I))) GO TO 380 + NG=0 + CALL MPOTOC(IPRHS(I),HEDIT,IMPX,NREA,NBISO,NMIL,NPARR,NLOC,NISOF, + 1 NISOP,NISOS,NCALR,NG,NSURFD,NALBP,NPRC) + IF(IMPX.GT.0) WRITE(6,470) NCALS+1,NCALS+NCALR +* --------------------------------------------------------- + CALL MPOCAT(IPMPO,IPRHS(I),NPAR,MUPLET,LGNEW,LWARN,HEDIT) +* --------------------------------------------------------- + NCALS=NCALS+NCALR + 380 CONTINUE + IF(IMPX.GT.0) THEN + CALL MPOTOC(IPMPO,HEDIT,IMPX,NREA,NBISO,NMIL,NPAR,NLOC,NISOF, + 1 NISOP,NISOS,NCALS,NG,NSURFD,NALBP,NPRC) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 390 DEALLOCATE(IPRHS) + RETURN +* + 400 FORMAT(/6H MPO: ,A/6X,8HVERSION=,I3) + 420 FORMAT(/1X,43(1H*)/34H * MPO: ELEMENTARY CALCULATION NB.,I8, + 1 2H */1X,43(1H*)) + 430 FORMAT(/41H MPO: RECOVER INFORMATION RELATED TO TIME,1P,E12.4, + 1 8H E+8 S (,E12.4,32H DAY) FROM LCM DIRECTORY NAMED ',A12,2H'.) + 440 FORMAT(28H MPO: SET GLOBAL PARAMETER ',A,3H' =,1P,E12.4) + 450 FORMAT(28H MPO: SET GLOBAL PARAMETER ',A,3H' =,I10) + 460 FORMAT(28H MPO: SET GLOBAL PARAMETER ',A,5H' = ',A,1H') + 470 FORMAT(/1X,55(1H*)/35H * MPO: ELEMENTARY CALCULATIONS NB.,I8, + 1 3H TO,I8,2H */1X,55(1H*)) + END diff --git a/Dragon/src/MPOCA2.f b/Dragon/src/MPOCA2.f new file mode 100644 index 0000000..3fd0927 --- /dev/null +++ b/Dragon/src/MPOCA2.f @@ -0,0 +1,1012 @@ +*DECK MPOCA2 + SUBROUTINE MPOCA2(IPMPO,IPEDIT,HEDIT,NREA,NISO,NADRX,NED,NPRC, + 1 ILEAK,NG,NMIL,NL,ITRANC,NALBP,IMC,NBISO,ICAL,MAXRDA,MAXIDA, + 2 FNORM,IMPX,NISOTS,NISFS,NISPS,VOLMIL,FLXMIL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover the cross sections of an elementary calculation. +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMPO pointer to the MPO file. +* IPEDIT pointer to the edition object (L_EDIT signature). +* HEDIT name of output group for a (multigroup mesh, output geometry) +* couple (generally equal to 'output_0'). +* NREA number of requested reactions. +* NISO number of particularized isotopes. +* NADRX total number of ADRX sets. +* NED number of additional edition cross sections. +* NPRC number of delayed neutron precursors. +* ILEAK type of leakage (=0/1: off/diffusion coefficients). +* NG number of condensed energy groups. +* NMIL number of mixtures in the MPO file. +* NL number of Legendre orders. +* ITRANC type of transport correction. +* NALBP number of physical albedos per energy group. +* IMC type of macro-calculation (1 for diffusion or SPN; +* 2 other method). +* NBISO number of isotopes in the condensed microlib of the edition +* object. A given isotope may appear in many mixtures. +* ICAL index of the current elementary calculation. +* MAXRDA dimension of RDATAX array. +* MAXIDA dimension of IDATAP array. +* FNORM flux normalization factor. +* IMPX print parameter. +* +*Parameters: output +* NISOTS number of distinct isotopes. +* NISFS number of particularized fissile isotopes. +* NISPS number of particularized fission products. +* VOLMIL mixture volumes. +* FLXMIL averaged flux of mixtures. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMPO,IPEDIT + INTEGER NREA,NISO,NADRX,NED,NPRC,ILEAK,NG,NMIL,NL,ITRANC,NALBP, + 1 IMC,NBISO,ICAL,MAXRDA,MAXIDA,IMPX,NISOTS,NISFS,NISPS + REAL FNORM,VOLMIL(NMIL),FLXMIL(NMIL,NG) + CHARACTER(LEN=12) HEDIT +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NREAK=50,MAXISO=800) + TYPE(C_PTR) JPEDIT,KPEDIT,IPTEMP,KPTEMP + INTEGER FGYS(2),RANK,TYPE,NBYTE,DIMSR(5),ADDRZI + CHARACTER ISOTS(MAXISO)*8,CM*2,TEXT8*8,TEXT12*12,HSMG*131, + 1 RECNAM*80 + LOGICAL EXIST,LSPH + DOUBLE PRECISION CONV +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDATAP,IFD1,IAD1,IFD2, + 1 IAD2,IJJ1,NJJ1,IPOS,IJJ2,NJJ2,MIX,ITYPE,IDATAP_MIL,VINTE1D + INTEGER, ALLOCATABLE, DIMENSION(:) :: REACTION,ISOTOPE + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISONAM,OUPUTID + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: ADRX,VINTE3D + REAL, ALLOCATABLE, DIMENSION(:) :: RDATAX,OVERV,WORKD,WORK1, + 1 WORK2,DEN,DENISO,CONCES,DECAYC,ENERG,VREAL + REAL, ALLOCATABLE, DIMENSION(:,:) :: DNUSIG,DCHI,DATA1,DATA2, + 1 DATA4,SPH + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: DATA3 + CHARACTER(LEN=24), ALLOCATABLE, DIMENSION(:) :: TEXT24,NOMREA, + 1 NOMISO + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(ADRX(NREA+3,NISO,NADRX+NMIL),IDATAP(MAXIDA),IFD1(NG), + 1 IAD1(NG+1),IFD2(NG),IAD2(NG+1),IJJ1(NMIL),NJJ1(NMIL), + 2 IPOS(NMIL),IJJ2(NG),NJJ2(NG),ISONAM(3,NBISO),MIX(NBISO), + 3 ITYPE(NBISO),IDATAP_MIL((2*NG+1)*NISO)) + ALLOCATE(RDATAX(MAXRDA),OVERV(NG),DNUSIG(NG,NPRC+1), + 1 DCHI(NG,NPRC),WORKD(NPRC),WORK1(NG*NMIL+1),WORK2(NG), + 2 DATA1(NG,NREA),DATA2(NG,NL),DATA3(NG,NG,NL),DATA4(NG,NG), + 3 DEN(NBISO),DENISO(NISO),CONCES(NBISO)) +* + CONV=1.0D6 ! convert MeV to eV in H-FACTOR + IF(NREA.GT.NREAK) CALL XABORT('MPOCA2: NOMREA OVERFLOW.') +*---- +* SET ENERGY MESH AND ZONE VOLUMES +*---- + CALL hdf5_read_data(IPMPO,"/energymesh/NENERGYMESH",NENERG) + CALL hdf5_read_data(IPMPO,"/geometry/NGEOMETRY",NGEOME) + CALL hdf5_read_data(IPMPO,"/output/OUPUTID",OUPUTID) + READ(HEDIT,'(7X,I2)') ID + ID_G=-1 + ID_E=-1 + DO I=1,NGEOME + DO J=1,NENERG + IF(OUPUTID(J,I).EQ.ID) THEN + ID_G=I-1 + ID_E=J-1 + GO TO 10 + ENDIF + ENDDO + ENDDO + CALL XABORT('MPOCA2: no ID found in /output/OUPUTID.') + 10 WRITE(RECNAM,'(23H/energymesh/energymesh_,I0,1H/)') ID_E + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"NG",NG2) + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"ENERGY",ENERG) + IF(SIZE(ENERG,1)-1.NE.NG) CALL XABORT('MPOCA2: INVALID NG VALUE.') + DO 20 IGR=1,NG+1 + ENERG(IGR)=ENERG(IGR)/1.0E-6 + 20 CONTINUE + WRITE(RECNAM,'(19H/geometry/geometry_,I0,1H/)') ID_G + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"ZONEVOLUME",VREAL) + VOLMIL(:)=VREAL(:) + DEALLOCATE(VREAL) + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"NZONE",NMIL2) + IF(NMIL.NE.NMIL2) THEN + WRITE(HSMG,'(42HMPOCA2: ELEMENTARY CALCULATION WITH AN INV, + 1 22HALIB NB. OF MIXTURES =,I7,3H NE,I7,1H.)') NMIL2,NMIL + CALL XABORT(HSMG) + ELSE IF(NG.NE.NG2) THEN + WRITE(HSMG,'(42HMPOCA2: ELEMENTARY CALCULATION WITH AN INV, + 1 20HALIB NB. OF GROUPS =,I7,3H NE,I7,1H.)') NG2,NG + CALL XABORT(HSMG) + ENDIF +*---- +* CREATE DUMMY DAYASETS REACTION AND ISOTOPE +*---- + WRITE(RECNAM,'(8H/output/,A,6H/info/)') TRIM(HEDIT) + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"REACTION",REACTION) + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"ISOTOPE",ISOTOPE) +*---- +* RECOVER INFORMATION FROM THE info and contents GROUPS. +*---- + ALLOCATE(NOMREA(NREA+2),NOMISO(NISO)) + IF(NREA.GT.0) THEN + CALL hdf5_read_data(IPMPO,"/contents/reactions/REACTIONAME", + > TEXT24) + DO 30 I=1,NREA + NOMREA(I)=TEXT24(REACTION(I)+1) + 30 continue + DEALLOCATE(TEXT24,REACTION) + ENDIF + CALL hdf5_read_data(IPMPO,"/contents/isotopes/ISOTOPENAME",TEXT24) + DO 40 I=1,NISO + NOMISO(I)=TEXT24(ISOTOPE(I)+1) + 40 CONTINUE + DEALLOCATE(TEXT24,ISOTOPE) + IF(IMPX.GT.2) THEN + WRITE(6,'(/24H MPOCA2: reaction names:)') + DO 50 I=1,NREA + WRITE(6,'(5X,7HNOMREA(,I3,2H)=,A)') I,TRIM(NOMREA(I)) + 50 CONTINUE + WRITE(6,'(/23H MPOCA2: isotope names:)') + DO 60 I=1,NISO + WRITE(6,'(5X,7HNOMISO(,I3,2H)=,A)') I,TRIM(NOMISO(I)) + 60 CONTINUE + ENDIF +*---- +* RECOVER NADRI AND IDATAP. +* NADRI IS THE TOTAL NUMBER OF TRANSPROFILE SETS. +*---- + WRITE(RECNAM,'(8H/output/,A,6H/info/)') TRIM(HEDIT) + NADRI=0 + CALL hdf5_info(IPMPO,TRIM(RECNAM)//"TRANSPROFILE",RANK,TYPE,NBYTE, + 1 DIMSR) + IF(TYPE.NE.99) THEN + NADRI=DIMSR(1)/(2*NG+1) + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"TRANSPROFILE",VINTE1D) + IDATAP(:DIMSR(1))=VINTE1D(:DIMSR(1)) + DEALLOCATE(VINTE1D) + ENDIF +*---- +* RECOVER INFORMATION FROM THE output_id/info GROUP. +*---- + CALL hdf5_info(IPMPO,TRIM(RECNAM)//"ADDRXS",RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.NE.99) THEN + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"ADDRXS",VINTE3D) + IF(NADRX.NE.DIMSR(3)) CALL XABORT('MPOCA2: INVALID NADRX.') + ADRX(:,:,:NADRX)=VINTE3D(:,:,:NADRX) + DEALLOCATE(VINTE3D) + ENDIF +*---- +* SAVE INFORMATION TO THE /output/output_id/statept_id/zone_id/yields/ +* GROUP. +*---- + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0)') TRIM(HEDIT),ICAL-1 + CALL hdf5_create_group(IPMPO,TRIM(RECNAM)) + DO 70 IMIL=1,NMIL + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0,6H/zone_,I0,1H/)') + > TRIM(HEDIT),ICAL-1,IMIL-1 + NMGF=1 + CALL hdf5_create_group(IPMPO,TRIM(RECNAM)) + IF(NBISO.GT.0) THEN + FGYS(1)=0 + FGYS(2)=1 + CALL hdf5_create_group(IPMPO,TRIM(RECNAM)//"yields") + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"yields/NMGF",NMGF) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"yields/YIELDGROUP", + > FGYS) + ENDIF + 70 CONTINUE +*---- +* FIND THE NUMBER AND NAMES OF THE ISOTOPES IN THE OUTPUT TABLES. +*---- + IF(NBISO.GT.0) THEN + CALL LCMGET(IPEDIT,'ISOTOPESUSED',ISONAM) + CALL LCMGET(IPEDIT,'ISOTOPESMIX',MIX) + CALL LCMGET(IPEDIT,'ISOTOPESDENS',DEN) + CALL LCMGET(IPEDIT,'ISOTOPESTYPE',ITYPE) + ENDIF + NISOTS=0 + DO 90 IBISO=1,NBISO + IF(MIX(IBISO).EQ.0) GO TO 90 + WRITE(TEXT12,'(3A4)') (ISONAM(I0,IBISO),I0=1,3) + DO 80 ISO=1,NISOTS + IF(TEXT12(:8).EQ.ISOTS(ISO)) GO TO 90 + 80 CONTINUE + NISOTS=NISOTS+1 + IF(NISOTS.GT.MAXISO) CALL XABORT('MPOCA2: ISOTS OVERFLOW.') + IF(NISOTS.GT.NBISO) CALL XABORT('MPOCA2: CONCES OVERFLOW.') + ISOTS(NISOTS)=TEXT12(:8) + 90 CONTINUE +*---- +* RECOVER INVERSE OF SPH EQUIVALENCE FACTORS. +*---- + CALL LCMSIX(IPEDIT,'MACROLIB',1) + JPEDIT=LCMGID(IPEDIT,'GROUP') + LSPH=.FALSE. + ALLOCATE(SPH(NMIL,NG)) + DO 120 IGR=1,NG + KPEDIT=LCMGIL(JPEDIT,IGR) + CALL LCMLEN(KPEDIT,'NSPH',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + LSPH=.TRUE. + CALL LCMGET(KPEDIT,'NSPH',WORK1) + DO 100 IMIL=1,NMIL + SPH(IMIL,IGR)=1.0/WORK1(IMIL) + 100 CONTINUE + ELSE + DO 110 IMIL=1,NMIL + SPH(IMIL,IGR)=1.0 + 110 CONTINUE + ENDIF + 120 CONTINUE + CALL LCMSIX(IPEDIT,' ',2) +*---- +* CREATE A SPH-UNCORRECTED MICROLIB. +*---- + CALL LCMOP(IPTEMP,'*TEMPORARY*',0,1,0) + ALLOCATE(IPISO(NBISO)) + CALL LCMEQU(IPEDIT,IPTEMP) + IF(LSPH) THEN + IF(IMC.EQ.0) CALL XABORT('MPOCA2: UNDEFINED TYPE OF SPH.') + NW=1 ! NTOT1 cross section present + CALL SPHCMI(IPTEMP,0,IMC,NMIL,NBISO,NG,NL,NW,NED,NPRC,NALBP,SPH) + ENDIF + DEALLOCATE(SPH) +*---- +* FIND ISOTOPE POINTERS IN INPUT MICROLIB +*---- + IF(NBISO.GT.0) CALL LIBIPS(IPTEMP,NBISO,IPISO) +*---- +* RECOVER RADIOACTIVE DECAY CONSTANTS. +*---- + IF(ICAL.EQ.1) THEN + ALLOCATE(DECAYC(NISOTS)) + DECAYC(:NISOTS)=0.0 + DO 150 IBISO=1,NBISO + IF(MIX(IBISO).EQ.0) GO TO 150 + WRITE(TEXT12,'(3A4)') (ISONAM(I0,IBISO),I0=1,3) + IISOTS=0 + DO 130 ISO=1,NISOTS + IISOTS=ISO + IF(TEXT12(:8).EQ.ISOTS(ISO)) GO TO 140 + 130 CONTINUE + CALL XABORT('MPOCA2: UNABLE TO FIND ISOTOPE '//TEXT12//'.') + 140 DECAYC(IISOTS)=0.0 + JPEDIT=IPISO(IBISO) + IF(.NOT.C_ASSOCIATED(JPEDIT)) GO TO 150 + CALL LCMLEN(JPEDIT,'DECAY',ILONG,ITYLCM) + IF(ILONG.EQ.1) CALL LCMGET(JPEDIT,'DECAY',DECAYC(IISOTS)) + 150 CONTINUE + DO 160 ISO=1,NISOTS + DECAYC(ISO)=DECAYC(ISO)*1.0E-8 + 160 CONTINUE + CALL hdf5_write_data(IPMPO,"/contents/isotopes/DECAYCONST", + 1 DECAYC) + DEALLOCATE(DECAYC) + ENDIF +*---- +* STORE INFORMATION IN THE output_id/statept_id/addons GROUP. +*---- + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0,8H/addons/)') + & TRIM(HEDIT),ICAL-1 + CALL hdf5_create_group(IPMPO,TRIM(RECNAM)) + CALL LCMSIX(IPTEMP,'MACROLIB',1) + JPEDIT=LCMGID(IPTEMP,'GROUP') + CALL LCMLEN(IPTEMP,'K-EFFECTIVE',ILONG,ITYLCM) + IF(ILONG.EQ.1) THEN + CALL LCMGET(IPTEMP,'K-EFFECTIVE',FLOTT) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"KEFF",FLOTT) + ENDIF + CALL LCMLEN(IPTEMP,'K-INFINITY',ILONG,ITYLCM) + IF(ILONG.EQ.1) THEN + CALL LCMGET(IPTEMP,'K-INFINITY',FLOTT) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"KINF",FLOTT) + ENDIF + CALL LCMLEN(IPTEMP,'B2 B1HOM',ILONG,ITYLCM) + IF(ILONG.EQ.1) THEN + CALL LCMGET(IPTEMP,'B2 B1HOM',B2) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"B2",B2) + ENDIF + CALL LCMSIX(IPTEMP,' ',2) +*---- +* LOOP OVER MPO MIXTURES. +*---- + DO 920 IMIL=1,NMIL + IF(NADRX+1.GT.SIZE(ADRX,3)) CALL XABORT('MPOCA2: ADRX OVERFLOW.') + IOI=0 + IOR=0 + DO 165 IGR=1,NG + IFD1(IGR)=NG+1 + IAD1(IGR+1)=0 + 165 CONTINUE + DATA2(:NG,:NL)=0.0 + DATA3(:NG,:NG,:NL)=0.0 + CALL LCMSIX(IPTEMP,'MACROLIB',1) + DO 230 IGR=1,NG + KPEDIT=LCMGIL(JPEDIT,IGR) +*---- +* RECOVER THE NEUTRON FLUX. +*---- + CALL LCMGET(KPEDIT,'FLUX-INTG',WORK1) + IF(FNORM.NE.1.0) THEN + FLXMIL(IMIL,IGR)=WORK1(IMIL)*FNORM*1.0E13 + ELSE + FLXMIL(IMIL,IGR)=WORK1(IMIL) + ENDIF +*---- +* RECOVER DELAYED NEUTRON INFORMATION. +*---- + CALL LCMLEN(KPEDIT,'NUSIGF',ILONG,ITYLCM) + IF((NPRC.GT.0).AND.(ILONG.NE.0)) THEN + CALL LCMGET(KPEDIT,'NUSIGF',WORK1) + DNUSIG(IGR,NPRC+1)=WORK1(IMIL) + CALL LCMGET(KPEDIT,'OVERV',WORK1) + OVERV(IGR)=WORK1(IMIL) + DO 170 IPRC=1,NPRC + WRITE(TEXT12,'(6HNUSIGF,I2.2)') IPRC + CALL LCMGET(KPEDIT,TEXT12,WORK1) + DNUSIG(IGR,IPRC)=WORK1(IMIL) + WRITE(TEXT12,'(3HCHI,I2.2)') IPRC + CALL LCMGET(KPEDIT,TEXT12,WORK1) + DCHI(IGR,IPRC)=WORK1(IMIL) + 170 CONTINUE + ELSE + DNUSIG(:NG,:NPRC+1)=0.0 + ENDIF +* + DO 220 IREA=1,NREA + DATA1(IGR,IREA)=0.0 + IF(NOMREA(IREA).EQ.'Total') THEN + CALL LCMGET(KPEDIT,'NTOT0',WORK1) + DATA1(IGR,IREA)=WORK1(IMIL) + ELSE IF(NOMREA(IREA).EQ.'TotalP1') THEN + CALL LCMGET(KPEDIT,'NTOT1',WORK1) + DATA1(IGR,IREA)=WORK1(IMIL) + ELSE IF(NOMREA(IREA).EQ.'Absorption') THEN + CALL LCMGET(KPEDIT,'NTOT0',WORK1) + DATA1(IGR,IREA)=WORK1(IMIL) + CALL LCMLEN(KPEDIT,'SIGS00',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,'SIGS00',WORK1) + DATA1(IGR,IREA)=DATA1(IGR,IREA)-WORK1(IMIL) + ENDIF + CALL LCMLEN(KPEDIT,'N2N',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,'N2N',WORK1) + DATA1(IGR,IREA)=DATA1(IGR,IREA)+WORK1(IMIL) + ENDIF + CALL LCMLEN(KPEDIT,'N3N',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,'N3N',WORK1) + DATA1(IGR,IREA)=DATA1(IGR,IREA)+2.0*WORK1(IMIL) + ENDIF + ELSE IF(NOMREA(IREA).EQ.'Fission') THEN + CALL LCMLEN(KPEDIT,'NFTOT',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,'NFTOT',WORK1) + DATA1(IGR,IREA)=WORK1(IMIL) + ENDIF + ELSE IF(NOMREA(IREA).EQ.'FissionSpectrum') THEN + CALL LCMLEN(KPEDIT,'CHI',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,'CHI',WORK1) + DATA1(IGR,IREA)=WORK1(IMIL) + ENDIF + ELSE IF(NOMREA(IREA).EQ.'NuFission') THEN + CALL LCMLEN(KPEDIT,'NUSIGF',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,'NUSIGF',WORK1) + DATA1(IGR,IREA)=WORK1(IMIL) + ENDIF + ELSE IF(NOMREA(IREA).EQ.'Energy') THEN + CALL LCMLEN(KPEDIT,'H-FACTOR',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,'H-FACTOR',WORK1) + DATA1(IGR,IREA)=WORK1(IMIL)/REAL(CONV) + ENDIF + ELSE IF(NOMREA(IREA).EQ.'FUITES') THEN + CALL LCMLEN(KPEDIT,'DIFF',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + IF(B2.EQ.0.0) B2=1.0E-10 + CALL LCMGET(KPEDIT,'DIFF',WORK1) + DATA1(IGR,IREA)=WORK1(IMIL)*B2 + ENDIF + ELSE IF(NOMREA(IREA).EQ.'STRD') THEN + CALL LCMLEN(KPEDIT,'DIFF',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,'DIFF',WORK1) + DATA1(IGR,IREA)=1.0/(3.0*WORK1(IMIL)) + ENDIF + ELSE IF(NOMREA(IREA).EQ.'Diffusion') THEN + DO 180 IL=1,NL + WRITE (CM,'(I2.2)') IL-1 + CALL LCMGET(KPEDIT,'SIGS'//CM,WORK1) + DATA2(IGR,IL)=WORK1(IMIL) + 180 CONTINUE + CALL LCMLEN(KPEDIT,'N2N',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,'N2N',WORK1) + DATA2(IGR,1)=DATA2(IGR,1)-WORK1(IMIL) + ENDIF + CALL LCMLEN(KPEDIT,'N3N',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,'N3N',WORK1) + DATA2(IGR,1)=DATA2(IGR,1)-2.0*WORK1(IMIL) + ENDIF + ELSE IF(NOMREA(IREA).EQ.'Transport') THEN + IF((ITRANC.EQ.1).AND.(NL.GE.2)) THEN + CALL LCMGET(KPEDIT,'SIGS01',WORK1) + DATA1(IGR,IREA)=WORK1(IMIL) + ELSE IF(ITRANC.EQ.2) THEN + CALL LCMGET(KPEDIT,'TRANC',WORK1) + DATA1(IGR,IREA)=WORK1(IMIL) + ENDIF + ELSE IF(NOMREA(IREA).EQ.'Scattering') THEN + DO 190 IL=1,NL + WRITE (CM,'(I2.2)') IL-1 + CALL LCMLEN(KPEDIT,'IJJS'//CM,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 190 + CALL LCMGET(KPEDIT,'IJJS'//CM,IJJ1) + CALL LCMGET(KPEDIT,'NJJS'//CM,NJJ1) + DO 185 JGR=IJJ1(IMIL)-NJJ1(IMIL)+1,IJJ1(IMIL) ! IGR <-- JGR + IFD1(JGR)=MIN(IFD1(JGR),IGR) + IAD1(JGR+1)=MAX(IAD1(JGR+1),IGR) + 185 CONTINUE + 190 CONTINUE + DO 210 IL=1,NL + WRITE (CM,'(I2.2)') IL-1 + CALL LCMGET(KPEDIT,'IJJS'//CM,IJJ1) + CALL LCMGET(KPEDIT,'NJJS'//CM,NJJ1) + CALL LCMGET(KPEDIT,'IPOS'//CM,IPOS) + CALL LCMGET(KPEDIT,'SCAT'//CM,WORK1) + IPO=IPOS(IMIL) + J2=IJJ1(IMIL) + J1=IJJ1(IMIL)-NJJ1(IMIL)+1 + DO 200 JGR=J2,J1,-1 + DATA3(IGR,JGR,IL)=WORK1(IPO)*REAL(2*IL-1) + IPO=IPO+1 + 200 CONTINUE + 210 CONTINUE + ELSE + CALL LCMLEN(KPEDIT,NOMREA(IREA)(:12),ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,NOMREA(IREA),WORK1) + DATA1(IGR,IREA)=WORK1(IMIL) + ENDIF + ENDIF + 220 CONTINUE + 230 CONTINUE + IAD1(1)=0 + DO 235 IGR=1,NG + IAD1(IGR+1)=IAD1(IGR)+(IAD1(IGR+1)-IFD1(IGR)+1) + 235 CONTINUE + CALL LCMSIX(IPTEMP,' ',2) +*---- +* PROCESS PARTICULARIZED ISOTOPES +*---- + IF(NBISO.GT.0) THEN + DO 250 IISO=1,NISO + DO 240 IREA=1,NREA+3 + ADRX(IREA,IISO,NADRX+1)=-1 + 240 CONTINUE + 250 CONTINUE + CONCES(:NISOTS)=0.0 + DO 540 IBISO=1,NBISO + IF(MIX(IBISO).EQ.IMIL) THEN + WRITE(TEXT12,'(3A4)') (ISONAM(I0,IBISO),I0=1,3) + DO 260 ISO=1,NISO + IISO=ISO + IF(NOMISO(ISO).EQ.TEXT12(:8)) GO TO 270 + 260 CONTINUE + GO TO 540 + 270 IF(IISO.GT.NISO-1) CALL XABORT('MPOCA2: NISO OVERFLOW.') + KPTEMP=IPISO(IBISO) ! set IBISO-th isotope + IF(.NOT.C_ASSOCIATED(KPTEMP)) THEN + WRITE(HSMG,'(17HMPOCA2: ISOTOPE '',A12,7H'' (ISO=,I8,3H) I, + 1 32HS NOT AVAILABLE IN THE MICROLIB.)') TEXT12,IBISO + CALL XABORT(HSMG) + ENDIF + IISOTS=0 + DO 280 ISO=1,NISOTS + IISOTS=ISO + IF(ISOTS(ISO).EQ.TEXT12(:8)) GO TO 290 + 280 CONTINUE + CALL XABORT('MPOCA2: UNABLE TO FIND ISOTOPE '//TEXT12//'.') + 290 CONCES(IISOTS)=DEN(IBISO) + DENISO(IISO)=DEN(IBISO) + DO 530 IREA=1,NREA + WORK2(:NG)=0.0 + IF(NOMREA(IREA).EQ.'Total') THEN + CALL LCMGET(KPTEMP,'NTOT0',WORK2) + ELSE IF(NOMREA(IREA).EQ.'TotalP1') THEN + CALL LCMGET(KPTEMP,'NTOT1',WORK2) + ELSE IF(NOMREA(IREA).EQ.'Absorption') THEN + CALL LCMGET(KPTEMP,'NTOT0',WORK2) + CALL LCMLEN(KPTEMP,'SIGS00',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPTEMP,'SIGS00',WORK1) + DO 300 IGR=1,NG + WORK2(IGR)=WORK2(IGR)-WORK1(IGR) + 300 CONTINUE + ENDIF + CALL LCMLEN(KPTEMP,'N2N',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPTEMP,'N2N',WORK1) + DO 310 IGR=1,NG + WORK2(IGR)=WORK2(IGR)+WORK1(IGR) + 310 CONTINUE + ENDIF + CALL LCMLEN(KPTEMP,'N3N',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPTEMP,'N3N',WORK1) + DO 320 IGR=1,NG + WORK2(IGR)=WORK2(IGR)+2.0*WORK1(IGR) + 320 CONTINUE + ENDIF + ELSE IF(NOMREA(IREA).EQ.'Nexcess') THEN + CALL LCMLEN(KPTEMP,'N2N',ILONG,ITYLCM) + IF(ILONG.GT.0) CALL LCMGET(KPTEMP,'N2N',WORK2) + CALL LCMLEN(KPTEMP,'N3N',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPTEMP,'N3N',WORK1) + DO 330 IGR=1,NG + WORK2(IGR)=WORK2(IGR)+2.0*WORK1(IGR) + 330 CONTINUE + ENDIF + ELSE IF(NOMREA(IREA).EQ.'Fission') THEN + CALL LCMLEN(KPTEMP,'NFTOT',ILONG,ITYLCM) + IF(ILONG.GT.0) CALL LCMGET(KPTEMP,'NFTOT',WORK2) + ELSE IF(NOMREA(IREA).EQ.'FissionSpectrum') THEN + CALL LCMLEN(KPTEMP,'CHI',ILONG,ITYLCM) + IF(ILONG.GT.0) CALL LCMGET(KPTEMP,'CHI',WORK2) + ELSE IF(NOMREA(IREA).EQ.'NuFission') THEN + CALL LCMLEN(KPTEMP,'NUSIGF',ILONG,ITYLCM) + IF(ILONG.GT.0) CALL LCMGET(KPTEMP,'NUSIGF',WORK2) + ELSE IF(NOMREA(IREA).EQ.'Energy') THEN + CALL LCMLEN(KPTEMP,'MEVF',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPTEMP,'NFTOT',WORK2) + CALL LCMGET(KPTEMP,'MEVF',FLOTT) + DO 340 IGR=1,NG + WORK2(IGR)=WORK2(IGR)*FLOTT + 340 CONTINUE + ENDIF + CALL LCMLEN(KPTEMP,'MEVG',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPTEMP,'NG',WORK1) + CALL LCMGET(KPTEMP,'MEVG',FLOTT) + DO 350 IGR=1,NG + WORK2(IGR)=WORK2(IGR)+WORK1(IGR)*FLOTT + 350 CONTINUE + ENDIF + ELSE IF(NOMREA(IREA).EQ.'FissionEnergyFission') THEN + CALL LCMLEN(KPTEMP,'MEVF',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPTEMP,'NFTOT',WORK2) + CALL LCMGET(KPTEMP,'MEVF',FLOTT) + DO 360 IGR=1,NG + WORK2(IGR)=WORK2(IGR)*FLOTT + 360 CONTINUE + ENDIF + ELSE IF(NOMREA(IREA).EQ.'CaptureEnergyCapture') THEN + CALL LCMLEN(KPTEMP,'MEVG',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPTEMP,'NG',WORK2) + CALL LCMGET(KPTEMP,'MEVG',FLOTT) + DO 370 IGR=1,NG + WORK2(IGR)=WORK2(IGR)*FLOTT + 370 CONTINUE + ENDIF + ELSE IF(NOMREA(IREA).EQ.'STRD') THEN + CALL LCMLEN(KPTEMP,'STRD',ILONG,ITYLCM) + IF(ILONG.GT.0) CALL LCMGET(KPTEMP,'STRD',WORK2) + ELSE IF(NOMREA(IREA).EQ.'Diffusion') THEN + ADRX(IREA,IISO,NADRX+1)=IOR + ADRX(NREA+1,IISO,NADRX+1)=NL + IOR=IOR+NG*NL + IF(IOR.GT.MAXRDA) CALL XABORT('MPOCA2: RDATAX OVERFLOW(1)') + DO 420 IL=1,NL + WRITE (CM,'(I2.2)') IL-1 + CALL LCMLEN(KPTEMP,'SIGS'//CM,ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPTEMP,'SIGS'//CM,WORK2) + ELSE + WORK2(:NG)=0.0 + ENDIF + CALL LCMLEN(KPTEMP,'N2N',ILONG,ITYLCM) + IF((IL.EQ.1).AND.(ILONG.GT.0)) THEN + CALL LCMGET(KPTEMP,'N2N',WORK1) + DO 390 IGR=1,NG + WORK2(IGR)=WORK2(IGR)-WORK1(IGR) + 390 CONTINUE + ENDIF + CALL LCMLEN(KPTEMP,'N3N',ILONG,ITYLCM) + IF((IL.EQ.1).AND.(ILONG.GT.0)) THEN + CALL LCMGET(KPTEMP,'N3N',WORK1) + DO 400 IGR=1,NG + WORK2(IGR)=WORK2(IGR)-2.0*WORK1(IGR) + 400 CONTINUE + ENDIF + DO 410 IGR=1,NG + RDATAX(ADRX(IREA,IISO,NADRX+1)+(IL-1)*NG+IGR-1)=WORK2(IGR) + 410 CONTINUE + 420 CONTINUE + GO TO 530 + ELSE IF(NOMREA(IREA).EQ.'Transport') THEN + IF((ITRANC.EQ.1).AND.(NL.GE.2)) THEN + CALL LCMGET(KPTEMP,'SIGS01',WORK2) + ELSE IF(ITRANC.EQ.2) THEN + CALL LCMGET(KPTEMP,'TRANC',WORK2) + ENDIF + ELSE IF(NOMREA(IREA).EQ.'Scattering') THEN + DO 430 IGR=1,NG + IFD2(IGR)=NG+1 + IAD2(IGR+1)=0 + 430 CONTINUE + DO 450 IL=1,NL + WRITE (CM,'(I2.2)') IL-1 + CALL LCMLEN(KPTEMP,'IJJS'//CM,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 450 + CALL LCMGET(KPTEMP,'IJJS'//CM,IJJ2) + CALL LCMGET(KPTEMP,'NJJS'//CM,NJJ2) + DO 445 JGR=1,NG + DO 440 IGR=IJJ2(JGR)-NJJ2(JGR)+1,IJJ2(JGR) ! JGR <-- IGR + IFD2(IGR)=MIN(IFD2(IGR),JGR) + IAD2(IGR+1)=MAX(IAD2(IGR+1),JGR) + 440 CONTINUE + 445 CONTINUE + 450 CONTINUE + IAD2(1)=0 + DO 460 IGR=1,NG + IAD2(IGR+1)=IAD2(IGR)+(IAD2(IGR+1)-IFD2(IGR)+1) + 460 CONTINUE + ADRX(NREA+1,IISO,NADRX+1)=NL + ADRX(NREA+2,IISO,NADRX+1)=NL + ADRX(NREA+3,IISO,NADRX+1)=IOI + IF(IOI+2*NG+1.GT.(2*NG+1)*NISO) THEN + CALL XABORT('MPOCA2: IDATAP_MIL OVERFLOW(1).') + ENDIF + DO 470 IGR=1,NG + IDATAP_MIL(IOI+IGR)=IFD2(IGR)-1 + IDATAP_MIL(IOI+NG+IGR)=IAD2(IGR) + 470 CONTINUE + IDATAP_MIL(IOI+2*NG+1)=IAD2(NG+1) + ADRX(NREA+3,IISO,NADRX+1)=IOI + IOI=IOI+2*NG+1 +* + ADRX(IREA,IISO,NADRX+1)=IOR + IOR=IOR+IAD2(NG+1)*NL + IF(IOR.GT.MAXRDA) CALL XABORT('MPOCA2: RDATAX OVERFLOW(2)') + JOFS=0 + DO 500 IL=1,NL + CALL XDRLGS(KPTEMP,-1,0,IL-1,IL-1,1,NG,WORK2,DATA4,ITYPRO) + ZIL=REAL(2*IL-1) + DO 490 IGR=1,NG + DO 480 JGR=IFD2(IGR),IFD2(IGR)+(IAD2(IGR+1)-IAD2(IGR))-1 ! JGR <-- IGR + JOFS=JOFS+1 + RDATAX(ADRX(IREA,IISO,NADRX+1)+JOFS-1)=DATA4(JGR,IGR)*ZIL + 480 CONTINUE + 490 CONTINUE + 500 CONTINUE + GO TO 530 + ELSE + CALL LCMLEN(KPTEMP,NOMREA(IREA),ILONG,ITYLCM) + IF(ILONG.GT.0) CALL LCMGET(KPTEMP,NOMREA(IREA),WORK2) + ENDIF +* + EXIST=.FALSE. + DO 510 IGR=1,NG + EXIST=EXIST.OR.(WORK2(IGR).NE.0.0) + 510 CONTINUE + IF(EXIST) THEN + ADRX(IREA,IISO,NADRX+1)=IOR + IOR=IOR+NG + IF(IOR.GT.MAXRDA) CALL XABORT('MPOCA2: RDATAX OVERFLOW(3)') + DO 520 IGR=1,NG + RDATAX(ADRX(IREA,IISO,NADRX+1)+IGR)=WORK2(IGR) + 520 CONTINUE + ELSE + ADRX(IREA,IISO,NADRX+1)=-1 + ENDIF + 530 CONTINUE + ENDIF + 540 CONTINUE + ENDIF +*---- +* STORE MACROSCOPIC RESIDUAL (ISOTOPE NISO) CROSS SECTIONS IN RDATAX. +*---- + ADRX(NREA+1,NISO,NADRX+1)=0 + ADRX(NREA+2,NISO,NADRX+1)=0 + ADRX(NREA+3,NISO,NADRX+1)=0 + DO 680 IREA=1,NREA + IF(NOMREA(IREA).EQ.'Diffusion') THEN + ADRX(IREA,NISO,NADRX+1)=IOR + ADRX(NREA+1,NISO,NADRX+1)=NL + IOR=IOR+NG*NL + IF(IOR.GT.MAXRDA) CALL XABORT('MPOCA2: RDATAX OVERFLOW(4)') + JOFS=0 + DO 570 IL=1,NL + DO 560 IGR=1,NG + JOFS=JOFS+1 + RDATAX(ADRX(IREA,NISO,NADRX+1)+JOFS)=DATA2(IGR,IL) + 560 CONTINUE + 570 CONTINUE + ELSE IF(NOMREA(IREA).EQ.'Scattering') THEN + ADRX(NREA+2,NISO,NADRX+1)=NL + ADRX(NREA+3,NISO,NADRX+1)=IOI + IF(IOI+2*NG+1.GT.(2*NG+1)*NISO) THEN + CALL XABORT('MPOCA2: IDATAP_MIL OVERFLOW(2).') + ENDIF + DO 590 IGR=1,NG + IDATAP_MIL(IOI+IGR)=IFD1(IGR)-1 + IDATAP_MIL(IOI+NG+IGR)=IAD1(IGR) + 590 CONTINUE + IDATAP_MIL(IOI+2*NG+1)=IAD1(NG+1) + ADRX(NREA+3,NISO,NADRX+1)=IOI + IOI=IOI+2*NG+1 +* + ADRX(IREA,NISO,NADRX+1)=IOR + IOR=IOR+IAD1(NG+1)*NL + IF(IOR.GT.MAXRDA) CALL XABORT('MPOCA2: RDATAX OVERFLOW(5)') + JOFS=0 + DO 630 IL=1,NL + DO 620 IGR=1,NG + DO 610 JGR=IFD1(IGR),IFD1(IGR)+(IAD1(IGR+1)-IAD1(IGR))-1 ! JGR <-- IGR + JOFS=JOFS+1 + RDATAX(ADRX(IREA,NISO,NADRX+1)+JOFS)=DATA3(JGR,IGR,IL) + 610 CONTINUE + 620 CONTINUE + 630 CONTINUE + ELSE + EXIST=.FALSE. + DO 650 IGR=1,NG + EXIST=EXIST.OR.(DATA1(IGR,IREA).NE.0.0) + 650 CONTINUE + IF(EXIST) THEN + ADRX(IREA,NISO,NADRX+1)=IOR + IOR=IOR+NG + IF(IOR.GT.MAXRDA) CALL XABORT('MPOCA2: RDATAX OVERFLOW(6)') + DO 660 IGR=1,NG + RDATAX(ADRX(IREA,NISO,NADRX+1)+IGR)=DATA1(IGR,IREA) + 660 CONTINUE + ELSE + ADRX(IREA,NISO,NADRX+1)=-1 + ENDIF + ENDIF + 680 CONTINUE +*---- +* REMOVE PARTICULARIZED ISOTOPIC CONTRIBUTIONS FROM MACROS. +* ISOTOPE NISO IS THE MACROSCOPIC RESIDUAL. +*---- + IF(NBISO.GT.0) THEN + DO 750 IREA=1,NREA + IMACR=ADRX(IREA,NISO,NADRX+1) + IF(IMACR+(IAD1(NG+1)-1)*NL-1.GT.MAXRDA) THEN + CALL XABORT('MPOCA2: RDATAX OVERFLOW(6).') + ENDIF + IF(IMACR.EQ.-1) GO TO 750 + IGRTOT=NG + IF(NOMREA(IREA).EQ.'Diffusion') IGRTOT=NG*NL + IF(NOMREA(IREA).EQ.'FissionSpectrum') GO TO 750 + DO 740 IISO=1,NISO-1 + IF(DENISO(IISO).EQ.0.0) GO TO 740 + JMACR=ADRX(IREA,IISO,NADRX+1) + IF(JMACR.EQ.-1) GO TO 740 + IF(NOMREA(IREA).EQ.'Scattering') THEN + IOI=ADRX(NREA+3,IISO,NADRX+1) + DO 690 IGR=1,NG + IFD2(IGR)=IDATAP_MIL(IOI+IGR)+1 + IAD2(IGR)=IDATAP_MIL(IOI+NG+IGR) + 690 CONTINUE + IAD2(NG+1)=IDATAP_MIL(IOI+2*NG+1) + JOFS=0 + DO 720 IL=1,NL + DO 710 IGR=1,NG + DO 700 JGR=IFD2(IGR),IFD2(IGR)+(IAD2(IGR+1)-IAD2(IGR)) ! JGR <-- IGR + I=(IL-1)*(IAD1(NG+1)-1)+IAD1(IGR)+JGR-IFD1(IGR) + JOFS=JOFS+1 + RDATAX(IMACR+I-1)=RDATAX(IMACR+I-1)-DENISO(IISO)* + 1 RDATAX(JMACR+JOFS-1) + 700 CONTINUE + 710 CONTINUE + 720 CONTINUE + ELSE + DO 730 IGR=1,IGRTOT + RDATAX(IMACR+IGR-1)=RDATAX(IMACR+IGR-1)-DENISO(IISO)* + 1 RDATAX(JMACR+IGR-1) + 730 CONTINUE + ENDIF + 740 CONTINUE + 750 CONTINUE + ENDIF + DENISO(NISO)=1.0 +*---- +* TRY TO FIND AN EXISTING IDATAP SET. OTHERWISE, CREATE A NEW ONE. +* STORE INFORMATION IN THE ADRX(NREA+3,IISO,NADRX+1) DATASET. +* NADRI IS THE TOTAL NUMBER OF TRANSPROFILE SETS. +*---- + DO 780 IISO=1,NISO + IOI=ADRX(NREA+3,IISO,NADRX+1) + DO 770 IAD1X=0,NADRI-1 + DO 760 I=1,2*NG+1 + IF(IDATAP_MIL(IOI+I).NE.IDATAP(IAD1X*(2*NG+1)+I)) GO TO 770 + 760 CONTINUE + ADRX(NREA+3,IISO,NADRX+1)=IAD1X*(2*NG+1) + GO TO 780 + 770 CONTINUE + IF((NADRI+1)*(2*NG+1).GT.MAXIDA) THEN + CALL XABORT('MPOCA2: IDATAP OVERFLOW.') + ENDIF + DO I=1,2*NG+1 + IDATAP(NADRI*(2*NG+1)+I)=IDATAP_MIL(IOI+I) + ENDDO + ADRX(NREA+3,IISO,NADRX+1)=NADRI*(2*NG+1) + NADRI=NADRI+1 + 780 CONTINUE +*---- +* TRY TO FIND AN EXISTING ADRX SET. OTHERWISE, CREATE A NEW ONE. +* STORE INFORMATION IN THE output_id/statept_id/zone_id GROUP. +* "ADDRZI" is the index in ADDRISO[NADDRISO+1]-->ISOTOPE +* "ADDRZX" is the index in ADDRXS[NREA+3,NISO,NADRX+1]-->CROSSEXTION +*---- + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0,6H/zone_,I0,1H/)') + 1 TRIM(HEDIT),ICAL-1,IMIL-1 + DO 810 IAD1X=1,NADRX + DO 800 I=1,NREA+3 + DO 790 J=1,NISO + IF(ADRX(I,J,NADRX+1).NE.ADRX(I,J,IAD1X)) GO TO 810 + 790 CONTINUE + 800 CONTINUE + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"ADDRZX",IAD1X-1) + GO TO 820 + 810 CONTINUE + NADRX=NADRX+1 + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"ADDRZX",NADRX-1) + 820 ADDRZI=0 + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"ADDRZI",ADDRZI) +*---- +* STORE FLUX, CROSS SECTIONS AND NUMBER DENSITIES. +*---- + WORK2(:)=FLXMIL(IMIL,:) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"ZONEFLUX",WORK2) + IF(IOR.GT.0) THEN + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"CROSSECTION", + 1 RDATAX(:IOR)) + ENDIF + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"CONCENTRATION",DENISO) +*---- +* STORE INFORMATION IN THE output_id/statept_id/zone_id/leakage GROUP. +*---- + IF(ILEAK.EQ.1) THEN + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0,6H/zone_,I0, + 1 9H/leakage/)') TRIM(HEDIT),ICAL-1,IMIL-1 + DO 830 IGR=1,NG + KPEDIT=LCMGIL(JPEDIT,IGR) + CALL LCMLEN(KPEDIT,'DIFF',ILONG,ITYLCM) + IF(ILONG.EQ.0) CALL XABORT('MPOCA2: MISSING DIFF INFO.') + CALL LCMGET(KPEDIT,'DIFF',WORK1) + WORK2(IGR)=WORK1(IMIL) + 830 CONTINUE + CALL hdf5_create_group(IPMPO,TRIM(RECNAM)) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"BUCKLING",B2) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"DIFFCOEF",WORK2) + WORK2(:)=WORK2(:)*B2 + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"DB2",WORK2) + ENDIF +*---- +* STORE INFORMATION IN THE output_id/statept_id/zone_id/kinetics GROUP. +*---- + IF(NPRC.GT.0) THEN + EXIST=.FALSE. + DO 850 IPRC=1,NPRC + DO 840 IGR=1,NG + EXIST=EXIST.OR.(DNUSIG(IGR,IPRC).NE.0.0) + 840 CONTINUE + 850 CONTINUE + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0,6H/zone_,I0, + 1 10H/kinetics/)') TRIM(HEDIT),ICAL-1,IMIL-1 + IF(EXIST) THEN + CALL LCMSIX(IPTEMP,'MACROLIB',1) + CALL LCMGET(IPTEMP,'LAMBDA-D',WORKD) + CALL LCMSIX(IPTEMP,' ',2) + CALL hdf5_create_group(IPMPO,TRIM(RECNAM)) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"LAMBDAD",WORKD) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"CHID",DCHI) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"INVERSESPEED", + 1 OVERV) + TGENRS=0.0 + DENOM=0.0 + DO 860 IGR=1,NG + TGENRS=TGENRS+OVERV(IGR)*FLXMIL(IMIL,IGR) + DENOM=DENOM+DNUSIG(IGR,NPRC+1)*FLXMIL(IMIL,IGR) + 860 CONTINUE + TGENRS=TGENRS/DENOM + DO 880 IPRC=1,NPRC + WORKD(IPRC)=0.0 + DO 870 IGR=1,NG + WORKD(IPRC)=WORKD(IPRC)+DNUSIG(IGR,IPRC)*FLXMIL(IMIL,IGR) + 870 CONTINUE + WORKD(IPRC)=WORKD(IPRC)/DENOM + 880 CONTINUE + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"BETADF",WORKD) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"GENERATIONTIME", + 1 TGENRS) + ENDIF + ENDIF +*---- +* STORE INFORMATION IN THE output_id/statept_id/zone_id/yields GROUP. +*---- + NISFS=0 + NISPS=0 + IF(NBISO.GT.0) THEN + DO 910 ISO=1,NISO-1 + DO 890 IBISO=1,NBISO + WRITE(TEXT8,'(2A4)') (ISONAM(I0,IBISO),I0=1,2) + IF(NOMISO(ISO).EQ.TEXT8) THEN + ITY=ITYPE(IBISO) + GO TO 900 + ENDIF + 890 CONTINUE + GO TO 910 + 900 IF(ITY.EQ.2) THEN + NISFS=NISFS+1 + ELSE IF(ITY.EQ.3) THEN + NISPS=NISPS+1 + ENDIF + 910 CONTINUE + NISFS=NISFS+1 ! declare the residual as fissile + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0,6H/zone_,I0,1H/)') + > TRIM(HEDIT),ICAL-1,IMIL-1 + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"yields/NISF",NISFS) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"yields/NISP",NISPS) + ENDIF +*---- +* END OF LOOP OVER MPO MIXTURES. +*---- + 920 CONTINUE + DEALLOCATE(IPISO) + CALL LCMCL(IPTEMP,2) +*---- +* STORE INFORMATION IN THE output_id/info GROUP. +*---- + WRITE(RECNAM,'(8H/output/,A,6H/info/)') TRIM(HEDIT) + IF((ICAL.EQ.1).AND.(NADRI.GT.0)) THEN + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"TRANSPROFILE", + 1 IDATAP(:NADRI*(2*NG+1))) + ENDIF + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"NADDRXS",NADRX) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"ADDRXS", + 1 ADRX(:,:,:NADRX)) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(NOMISO,NOMREA) + DEALLOCATE(CONCES,DENISO,DEN,DATA4,DATA3,DATA2,DATA1,WORK2,WORK1, + 1 WORKD,DCHI,DNUSIG,OVERV,RDATAX) + DEALLOCATE(IDATAP_MIL,ITYPE,MIX,ISONAM,NJJ2,IJJ2,IPOS,NJJ1,IJJ1, + 1 IAD2,IFD2,IAD1,IFD1,IDATAP,ADRX) + RETURN + END diff --git a/Dragon/src/MPOCAL.f b/Dragon/src/MPOCAL.f new file mode 100644 index 0000000..66178d2 --- /dev/null +++ b/Dragon/src/MPOCAL.f @@ -0,0 +1,180 @@ +*DECK MPOCAL + SUBROUTINE MPOCAL(IMPX,IPMPO,IPDEPL,IPEDIT,HEDIT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Store the results of an elementary calculation in the MPO file. +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IMPX print parameter. +* IPMPO pointer to the MPO file. +* IPDEPL pointer to the burnup object (L_BURNUP signature). +* IPEDIT pointer to the edition object (L_EDIT signature). +* HEDIT name of output group for a (multigroup mesh, output geometry) +* couple (generally equal to 'output_0'). +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMPO,IPDEPL,IPEDIT,IPSPH + INTEGER IMPX + CHARACTER(LEN=12) HEDIT +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + INTEGER IPAR(NSTATE),RANK,TYPE,NBYTE,DIMSR(5) + REAL BIRRAD(2) + CHARACTER CDIRO*12,HSMG*131,RECNAM*80 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: DIMS_MPO + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: OUPUTID + REAL, ALLOCATABLE, DIMENSION(:) :: VOLMIL + REAL, ALLOCATABLE, DIMENSION(:,:) :: FLXMIL +*---- +* RECOVER MICROLIB AND MACROLIB INFORMATION +*---- + CALL LCMGTC(IPEDIT,'LAST-EDIT',12,CDIRO) + CALL LCMSIX(IPEDIT,CDIRO,1) + CALL LCMLEN(IPEDIT,'STATE-VECTOR',ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + CALL LCMGET(IPEDIT,'STATE-VECTOR',IPAR) + NBISO=IPAR(2) + NED=IPAR(13) + NPRC=IPAR(19) + NDFI=IPAR(20) + ELSE + NBISO=0 + NDFI=0 + ENDIF + CALL LCMSIX(IPEDIT,'MACROLIB',1) + CALL LCMGET(IPEDIT,'STATE-VECTOR',IPAR) + NG=IPAR(1) + NMIL=IPAR(2) + NL=IPAR(3) + IF(IPAR(4).GT.1) CALL XABORT('MPOCAL: CANNOT PROCESS MULTIPLE ' + 1 //'FISSION SPECTRA.') + NED=IPAR(5) + ITRANC=IPAR(6) + NPRC=IPAR(7) + NALBP=IPAR(8) + ILEAK=IPAR(9) + IDF=IPAR(12) + CALL LCMLEN(IPEDIT,'SPH',ILEN,ITYLCM) + IF(ILEN.NE.0) THEN + IPSPH=LCMGID(IPEDIT,'SPH') + CALL LCMGET(IPSPH,'STATE-VECTOR',IPAR) + IMC=IPAR(6) + ELSE + IMC=0 + ENDIF + CALL LCMSIX(IPEDIT,' ',2) +*---- +* RECOVER ENERGY ID_G AND ID_E +*---- + CALL hdf5_read_data(IPMPO,"/output/NOUTPUT",NOUTPUT) + ID_G=-1 + ID_E=-1 + CALL hdf5_read_data(IPMPO,"/output/OUPUTID",OUPUTID) + CALL hdf5_read_data(IPMPO,"/energymesh/NENERGYMESH",NENERG) + CALL hdf5_read_data(IPMPO,"/geometry/NGEOMETRY",NGEOME) + READ(HEDIT,'(7X,I2)') ID + DO I=1,NGEOME + DO J=1,NENERG + IF(OUPUTID(J,I).EQ.ID) THEN + ID_G=I-1 + ID_E=J-1 + GO TO 10 + ENDIF + ENDDO + ENDDO + CALL XABORT('MPOCAL: no ID found in /output/OUPUTID.') + 10 CALL hdf5_read_data(IPMPO,"/parameters/tree/NSTATEPOINT",NCALS) + ICAL=NCALS+1 +*---- +* RECOVER THE FLUX NORMALIZATION FACTOR. +*---- + IF(C_ASSOCIATED(IPDEPL)) THEN + CALL LCMGET(IPDEPL,'BURNUP-IRRAD',BIRRAD) + BURN=BIRRAD(1) + CALL LCMLEN(IPDEPL,'FLUX-NORM',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + WRITE(HSMG,'(40HMPOCAL: THE ''FLUX-NORM'' RECORD IS NOT SE, + 1 20HT FOR BURNUP STEP AT,E12.5,14H MW-DAY/TONNE.)') BURN + CALL XABORT(HSMG) + ENDIF + CALL LCMGET(IPDEPL,'FLUX-NORM',FNORM) + IF(IMPX.GT.0) WRITE(6,100) FNORM,BURN + ELSE + FNORM=1.0 + IF(IMPX.GT.0) WRITE(6,110) + ENDIF +*---- +* RECOVER THE NUMBER OF ADRX (NADRX) AND TRANSPROFILE (NADRI) SETS. +*---- + WRITE(RECNAM,'(8H/output/,A,6H/info/)') TRIM(HEDIT) + NADRX=0 + CALL hdf5_info(IPMPO,TRIM(RECNAM)//"ADDRXS",RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.NE.99) THEN + NADRX=DIMSR(3) + ENDIF + NADRI=0 + CALL hdf5_info(IPMPO,TRIM(RECNAM)//"TRANSPROFILE",RANK,TYPE,NBYTE, + 1 DIMSR) + IF(TYPE.NE.99) NADRI=DIMSR(1)/(2*NG+1) +*---- +* RECOVER THE CROSS SECTIONS. +*---- + CALL hdf5_get_shape(IPMPO,"/contents/isotopes/ISOTOPENAME", + 1 DIMS_MPO) + NISO=DIMS_MPO(1) + DEALLOCATE(DIMS_MPO) + CALL hdf5_get_shape(IPMPO,"/contents/reactions/REACTIONAME", + 1 DIMS_MPO) + NREA=DIMS_MPO(1) + DEALLOCATE(DIMS_MPO) + MAXRDA=(NREA*NG+NL*NG+NL*NG*NG)*NISO + MAXIDA=(2*NG+1)*(NADRI+NISO*NMIL) + ALLOCATE(VOLMIL(NMIL),FLXMIL(NMIL,NG)) + CALL MPOCA2(IPMPO,IPEDIT,HEDIT,NREA,NISO,NADRX,NED,NPRC,ILEAK, + 1 NG,NMIL,NL,ITRANC,NALBP,IMC,NBISO,ICAL,MAXRDA,MAXIDA,FNORM,IMPX, + 2 NISOTS,NISFS,NISPS,VOLMIL,FLXMIL) +*---- +* RECOVER DISCONTINUITY FACTOR INFORMATION. +*---- + IF((IDF.EQ.2).OR.(IDF.EQ.3).OR.(IDF.EQ.4).OR.(NALBP.GT.0)) THEN + CALL MPOIDF(IPMPO,IPEDIT,HEDIT,NG,NMIL,ICAL,IDF,NALBP,FNORM, + 1 VOLMIL,FLXMIL) + ENDIF + DEALLOCATE(FLXMIL,VOLMIL) +*---- +* RECOVER THE FISSION YIELDS. +*---- + IF(NISFS*NISPS.GT.0) THEN + CALL MPOGEY(IPMPO,IPEDIT,HEDIT,NISO,NG,NMIL,NBISO,ICAL,NDFI, + 1 NISFS,NISPS) + ENDIF +* + CALL LCMSIX(IPEDIT,' ',2) + RETURN +* + 100 FORMAT(45H MPOCAL: NORMALIZE THE FLUX WITH THE FACTOR =,1P,E12.5, + 1 26H TAKEN FROM BURNUP STEP AT,E12.5,14H MW-DAY/TONNE.) + 110 FORMAT(36H MPOCAL: THE FLUX IS NOT NORMALIZED.) + END diff --git a/Dragon/src/MPOCAT.f b/Dragon/src/MPOCAT.f new file mode 100644 index 0000000..5fd3704 --- /dev/null +++ b/Dragon/src/MPOCAT.f @@ -0,0 +1,218 @@ +*DECK MPOCAT + SUBROUTINE MPOCAT(IPMPO,IPRHS,NPAR,MUPCPO,LGNCPO,LWARN,HEDIT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To catenate a RHS MPO file into the output MPO file. +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMPO pointer to the output MPO file. +* IPRHS pointer to the rhs MPO file (contains the new calculations). +* NPAR number of global parameters in the output MPO file. +* MUPCPO tuple of the new global parameters in the output MPO file. +* LGNCPO LGNEW value of the new global parameters in the output MPO +* file. +* LWARN logical used in case if an elementary calculation in the RHS +* is already present in MPO file. If LWARN=.true. a warning is +* send and the MPO file values are kept otherwise XABORT is +* called (default). +* HEDIT name of output group for a (multigroup mesh, output geometry) +* couple (generally equal to 'output_0'). +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMPO,IPRHS + INTEGER NPAR,MUPCPO(NPAR) + LOGICAL LGNCPO(NPAR),LWARN + CHARACTER(LEN=12) HEDIT +*---- +* LOCAL VARIABLES +*---- + CHARACTER HSMG*131,RECNAM*72,RECNA2*72,TEXT24*24 + LOGICAL EQUAL +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: VINTE,NVALUE,MUPLET,MUPRHS, + 1 MUBASE + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: OUPUTID + REAL, ALLOCATABLE, DIMENSION(:) :: VREAL + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LGNEW + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: PARFMT + CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: VCHAR + CHARACTER(LEN=24), ALLOCATABLE, DIMENSION(:) :: PARCPO,PARKEY +*---- +* CHECK THE COMPATIBILITY OF THE NEW RHS MPO +* NCAL is the number of calculations in the output MPO file +* NCALR is the number of calculations in RHS MPO file +*---- + NGR=0 + CALL MPOTOC(IPRHS,HEDIT,IMPX,NREA,NBISO,NMILR,NPARR,NLOCR,NISOF, + 1 NISOP,NISOS,NCALR,NGR,NSURFD,NALBP,NPRC) + IF(NCALR.EQ.0) THEN + CALL XABORT('MPOCAT: NO CALCULATION IN RHS MPO.') + ELSE IF(NPARR.GT.NPAR) THEN + WRITE(HSMG,'(42HMPOCAT: ELEMENTARY CALCULATION WITH AN INV, + 1 31HALIB NB. OF GLOBAL PARAMETERS =,I7,3H GT,I7,1H.)') NPARR, + 2 NPAR + CALL XABORT(HSMG) + ENDIF + NCAL=0 + IF(hdf5_group_exists(IPMPO,"/parameters/tree")) THEN + CALL hdf5_read_data(IPMPO,"/parameters/tree/NSTATEPOINT",NCAL) + ENDIF + IF(NCAL.GT.0) THEN + NG=0 + CALL MPOTOC(IPMPO,HEDIT,0,NREA,NBISO,NMIL,NPAR1,NLOC,NISOF, + 1 NISOP,NISOS,NCAL,NG,NSURFD,NALBP,NPRC) + IF(NGR.NE.NG) THEN + WRITE(HSMG,'(42HMPOCAT: ELEMENTARY CALCULATION WITH AN INV, + 1 20HALIB NB. OF GROUPS =,I7,3H NE,I7,1H.)') NGR,NG + CALL XABORT(HSMG) + ELSE IF(NMILR.NE.NMIL) THEN + WRITE(HSMG,'(42HMPOCAT: ELEMENTARY CALCULATION WITH AN INV, + 1 22HALIB NB. OF MIXTURES =,I7,3H NE,I7,1H.)') NMILR,NMIL + CALL XABORT(HSMG) + ELSE IF(NPAR1.NE.NPAR) THEN + WRITE(HSMG,'(42HMPOCAT: ELEMENTARY CALCULATION WITH AN INV, + 1 31HALIB NB. OF GLOBAL PARAMETERS =,I7,3H NE,I7,1H.)') NPAR1, + 2 NPAR + CALL XABORT(HSMG) + ELSE IF(NLOCR.NE.NLOC) THEN + WRITE(HSMG,'(42HMPOCAT: ELEMENTARY CALCULATION WITH AN INV, + 1 30HALIB NB. OF LOCAL PARAMETERS =,I7,3H NE,I7,1H.)') NLOCR, + 2 NLOC + CALL XABORT(HSMG) + ENDIF + ENDIF +*---- +* MAIN LOOP OVER THE NCALR ELEMENTARY CALCULATIONS OF THE RHS MPO +*---- + IDEM=0 + NCALS=NCAL + DO 140 ICALR=1,NCALR +*---- +* COMPUTE THE MUPLET VECTOR FROM THE RHS MPO +*---- + ALLOCATE(MUPRHS(NPARR),MUPLET(NPAR),LGNEW(NPAR)) + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0)') TRIM(HEDIT),ICALR-1 + CALL hdf5_read_data(IPRHS,TRIM(RECNAM)//"/PARAMVALUEORD",VINTE) + IF(SIZE(VINTE).NE.NPARR) THEN + WRITE(HSMG,'(43HMPOCAT: INCONSISTENT PARAMVALUEORD LENGTH (, + 1 I5,3H VS,I5,2H).)') SIZE(VINTE),NPARR + CALL XABORT(HSMG) + ENDIF + DO 20 IPAR=1,NPARR + MUPRHS(IPAR)=VINTE(IPAR) + 20 CONTINUE + DEALLOCATE(VINTE) +*---- +* RECOVER THE GLOBAL PARAMETERS +*---- + DO 30 I=1,NPAR + MUPLET(I)=MUPCPO(I) + LGNEW(I)=LGNCPO(I) + 30 CONTINUE + IF(NPAR.GT.0) THEN + CALL hdf5_read_data(IPMPO,"/parameters/info/PARAMNAME",PARCPO) + ENDIF + CALL hdf5_read_data(IPRHS,"/parameters/info/PARAMNAME",PARKEY) + CALL hdf5_read_data(IPRHS,"/parameters/info/PARAMFORM",PARFMT) + CALL hdf5_read_data(IPRHS,"/parameters/info/NVALUE",NVALUE) + DO 100 IPAR=1,NPARR + DO 80 I0=1,NPAR + IF(PARKEY(IPAR).EQ.PARCPO(I0)) THEN + IPARN=I0 + GO TO 90 + ENDIF + 80 CONTINUE + CALL XABORT('MPOCAT: UNABLE TO FIND '//PARKEY(IPAR)//'.') + 90 WRITE(RECNAM,'(25H/parameters/values/PARAM_,I0)') IPAR-1 + IVAL=MUPRHS(IPAR)+1 + IF(PARFMT(IPAR).EQ.'FLOAT') THEN + CALL hdf5_read_data(IPRHS,RECNAM,VREAL) + FLOTT=VREAL(IVAL) + DEALLOCATE(VREAL) + ELSE IF(PARFMT(IPAR).EQ.'INTEGER') THEN + CALL hdf5_read_data(IPRHS,RECNAM,VINTE) + NITMA=VINTE(IVAL) + DEALLOCATE(VINTE) + ELSE IF(PARFMT(IPAR).EQ.'STRING') THEN + CALL hdf5_read_data(IPRHS,RECNAM,VCHAR) + TEXT24=VCHAR(IVAL) + DEALLOCATE(VCHAR) + ENDIF + CALL MPOPAV(IPMPO,HEDIT,IPARN,NPAR,PARFMT(IPAR),FLOTT,NITMA, + 1 TEXT24,MUPLET(IPARN),LGNEW(IPARN)) + 100 CONTINUE + IF(NPAR.GT.0) DEALLOCATE(PARCPO) +*---- +* CHECK IF THE NEW MUPLET ALREADY EXISTS IN THE MPO FILE +*---- + DO 120 ICAL=1,NCALS + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0,14H/PARAMVALUEORD)') + 1 TRIM(HEDIT),ICAL-1 + CALL hdf5_read_data(IPMPO,TRIM(RECNAM),MUBASE) + EQUAL=.FALSE. + DO 110 I=1,NPAR + EQUAL=(MUPLET(I).EQ.MUBASE(I)) + IF(.NOT.EQUAL) GO TO 115 + 110 CONTINUE + WRITE(6,'(/25H MPOCAT: ADD CALCULATION=,I8/8H MUPLET=,20I7:/ + 1 (8X,20I7))') ICALR-1,MUPLET(:) + WRITE(6,'(/48H MPOCAT: ELEMENTARY CALCULATION HAS THE SAME PAR, + 1 36HAMETERS AS ELEMENTARY CALCULATION NB,I8,1H.)') ICAL-1 + IF(LWARN) THEN + IDEM=IDEM+1 + DEALLOCATE(MUBASE) + GOTO 130 + ELSE + CALL XABORT('MPOCAT: WARNING-ONLY FLAG NOT SET.') + ENDIF + 115 DEALLOCATE(MUBASE) + 120 CONTINUE + NCALS=NCALS+1 + IF(NCALS.NE.NCAL+ICALR-IDEM) CALL XABORT('MPOCAT: INVALID NCALS.') +*---- +* RECOVER THE ELEMENTARY CALCULATION +*---- + IF(NCALS.EQ.1) THEN + CALL hdf5_create_group(IPMPO,"/output") + CALL hdf5_read_data(IPRHS,"/output/NOUTPUT",NOUTPUT) + CALL hdf5_write_data(IPMPO,"/output/NOUTPUT",NOUTPUT) + CALL hdf5_read_data(IPRHS,"/output/OUPUTID",OUPUTID) + CALL hdf5_write_data(IPMPO,"/output/OUPUTID",OUPUTID) + DEALLOCATE(OUPUTID) + WRITE(RECNAM,'(8H/output/,A)') TRIM(HEDIT) + CALL hdf5_create_group(IPMPO,TRIM(RECNAM)) + call hdf5_copy(IPRHS,"/energymesh",IPMPO,"/energymesh") ! IPRHS -> IPMPO + call hdf5_copy(IPRHS,"/geometry",IPMPO,"/geometry") ! IPRHS -> IPMPO + WRITE(RECNAM,'(8H/output/,A,5H/info)') TRIM(HEDIT) + call hdf5_copy(IPRHS,TRIM(RECNAM),IPMPO,TRIM(RECNAM)) ! IPRHS -> IPMPO + ENDIF + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0)') TRIM(HEDIT),NCALS-1 + WRITE(RECNA2,'(8H/output/,A,9H/statept_,I0)') TRIM(HEDIT),ICALR-1 + call hdf5_copy(IPRHS,RECNA2,IPMPO,RECNAM) ! IPRHS -> IPMPO + CALL hdf5_create_group(IPMPO,TRIM(RECNAM)) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"/PARAMVALUEORD",MUPLET) + CALL hdf5_write_data(IPMPO,"/parameters/tree/NSTATEPOINT",NCALS) + 130 DEALLOCATE(LGNEW,MUPLET,MUPRHS,NVALUE,PARFMT,PARKEY) + 140 CONTINUE +* END OF LOOP ON RHS ELEMENTARY CALCULATIONS. ******************** + RETURN + END diff --git a/Dragon/src/MPOGEP.f b/Dragon/src/MPOGEP.f new file mode 100644 index 0000000..238b580 --- /dev/null +++ b/Dragon/src/MPOGEP.f @@ -0,0 +1,256 @@ +*DECK MPOGEP + SUBROUTINE MPOGEP(IPMPO,IPDEPL,IPLB1,IPLB2,IPEDIT,HEDIT,IMPX, + 1 ITIM,NPAR,NLOC,MUPLET,LGNEW,NMIL,NG,NCALAR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To recover remaining global parameters and local values. Update the +* parameter tree for a new elementary calculation. +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMPO pointer to the MPO file. +* IPDEPL pointer to the burnup object. +* IPLB1 pointer to the first microlib object. +* IPLB2 pointer to the second (optional) microlib object. +* IPEDIT pointer to the edition object. +* HEDIT name of output group for a (multigroup mesh, output geometry) +* couple (generally equal to 'output_0'). +* IMPX print parameter. +* ITIM index of the current burnup step. +* NPAR number of global parameters. +* NLOC number of local parameters. +* MUPLET tuple of indices associated to each global parameter of the +* elementary calculation. +* LGNEW parameter modification flag (.TRUE. only if the I-th global +* parameter has changed in the new elementary calculation). +* NMIL number of mixtures in the MPO file +* NG number of energy groups. +* NCALAR index of the new elementary calculation. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMPO,IPDEPL,IPLB1,IPLB2,IPEDIT + INTEGER IMPX,ITIM,NPAR,NLOC,MUPLET(NPAR),NMIL,NG,NCALAR + LOGICAL LGNEW(NPAR) + CHARACTER(LEN=12) HEDIT +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPLB3 + PARAMETER (MAXPAR=50,NSTATE=40) + INTEGER ISTATE(NSTATE) + CHARACTER TEXT8*8,TEXT12*12,NAMLCM*12,NAMMY*12,HSMG*131,RECNAM*80 + LOGICAL EMPTY,LCM +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: PARADR,PARADL,LOCADR, + 1 DIMS_MPO + REAL, ALLOCATABLE, DIMENSION(:) :: RVALO + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: PARFMT + CHARACTER(LEN=24), ALLOCATABLE, DIMENSION(:) :: PARTYP,PARKEY, + 1 PARCAD,PARTYL,PARKEL,PARCAL +*---- +* VALIDATE NPAR +*---- + IF(NPAR.EQ.0) GO TO 45 + CALL hdf5_get_shape(IPMPO,"/parameters/info/PARAMNAME",DIMS_MPO) + IF(NPAR.NE.DIMS_MPO(1)) CALL XABORT('MPOGEP: INVALID NPAR.') + DEALLOCATE(DIMS_MPO) +*---- +* RECOVER INFORMATION FROM THE /parameters GROUP. +*---- + CALL hdf5_read_data(IPMPO,"/parameters/info/PARAMNAME",PARKEY) + CALL hdf5_read_data(IPMPO,"/parameters/info/PARAMFORM",PARFMT) + CALL hdf5_read_data(IPMPO,"/parameters/info/PARAMTYPE",PARTYP) + CALL hdf5_read_data(IPMPO,"/parameters/info/PARAMINFOADR",PARADR) + NPCHR=PARADR(NPAR+1) + IF(NPCHR.GT.0) THEN + CALL hdf5_read_data(IPMPO,"/parameters/info/PARAMINFO",PARCAD) + ENDIF +*---- +* RECOVER REMAINING GLOBAL PARAMETERS. +*---- + DO 10 IPAR=1,NPAR + IF(PARTYP(IPAR).EQ.'VALU') THEN + GO TO 10 + ELSE IF((PARTYP(IPAR).EQ.'BURNUP').OR.(PARTYP(IPAR).EQ.'TIME').OR. + 1 (PARTYP(IPAR).EQ.'PUIS').OR.(PARTYP(IPAR).EQ.'FLUB').OR. + 2 (PARTYP(IPAR).EQ.'FLUX').OR.(PARTYP(IPAR).EQ.'MASL')) THEN +* +* RECOVER GLOBAL PARAMETER VALUES FROM THE DEPLETION OBJECT. + IF(.NOT.C_ASSOCIATED(IPDEPL)) CALL XABORT('MPOGEP: NO DEPLETI' + 1 //'ON OBJECT AVAILABLE AMONG THE RHS LCM OBJECTS.') + CALL LCMGET(IPDEPL,'STATE-VECTOR',ISTATE) + NBURN=ISTATE(3) + NBISO=ISTATE(4) + NREAC=ISTATE(6) + NVAR=ISTATE(7) + NBMIX=ISTATE(8) + CALL COMGEM(IPDEPL,ITIM,PARTYP(IPAR),0,NBURN,NBMIX,NBISO, + 1 NREAC,NVAR,VALPAR) + ELSE IF((PARTYP(IPAR).EQ.'TEMP').OR.(PARTYP(IPAR).EQ.'CONC')) + 1 THEN +* +* RECOVER GLOBAL PARAMETER VALUES FROM A MICROLIB OBJECT. + IF(.NOT.C_ASSOCIATED(IPLB1)) CALL XABORT('MPOGEP: MICROLIB EX' + 1 //'PECTED AT RHS.') + IF(NPCHR.EQ.0) CALL XABORT('MPOGEP: MISSING PARAMINFO.') + TEXT8=' ' + TEXT12=' ' + IMILI=0 + IPCHR=PARADR(IPAR)+1 + IF(PARTYP(IPAR).EQ.'CONC') THEN + TEXT8=PARCAD(IPCHR)(:8) + IPCHR=IPCHR+1 + ENDIF + TEXT12=PARCAD(IPCHR)(:8) + IPCHR=IPCHR+1 + READ(PARCAD(IPCHR),'(3X,I9)') IMILI + CALL LCMGET(IPLB1,'STATE-VECTOR',ISTATE) + MAXNBI=ISTATE(2) + IF(C_ASSOCIATED(IPLB2)) THEN + CALL LCMGET(IPLB2,'STATE-VECTOR',ISTATE) + MAXNBI=MAX(MAXNBI,ISTATE(2)) + ENDIF + CALL COMBIB(IPLB1,IPLB2,PARTYP(IPAR),IMILI,TEXT12,TEXT8,MAXNBI, + 1 VALPAR) + ELSE + CALL XABORT('MPOGEP: '//PARTYP(IPAR)//' IS AN UNKNOWN PARAM'// + 1 'ETER TYPE.') + ENDIF + IF(IMPX.GT.0) WRITE(6,100) PARKEY(IPAR),VALPAR +* + CALL MPOPAV(IPMPO,HEDIT,IPAR,NPAR,PARFMT(IPAR),VALPAR,NITMA, + 1 TEXT12,MUPLET(IPAR),LGNEW(IPAR)) + 10 CONTINUE + IF(IMPX.GT.2) THEN + WRITE(6,110) (MUPLET(I),I=1,NPAR) + WRITE(6,'(/)') + ENDIF + DO 15 I=1,NPAR + IF(MUPLET(I).EQ.-99) THEN + WRITE(HSMG,'(33HMPOGEP: UNDEFINED MUPLET ELEMENT=,I6)') I + CALL XABORT(HSMG) + ENDIF + 15 CONTINUE + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0)') TRIM(HEDIT),NCALAR-1 + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"/PARAMVALUEORD",MUPLET) + IF(NPCHR.GT.0) DEALLOCATE(PARCAD) + DEALLOCATE(PARADR,PARTYP,PARFMT,PARKEY) +*---- +* RECOVER INFORMATION FROM THE 'varlocdescri' GROUP. +*---- + 45 IF(NLOC.EQ.0) RETURN + ALLOCATE(LOCADR(NLOC+1)) + CALL hdf5_read_data(IPMPO,"/local_values/LOCVALNAME",PARKEL) + CALL hdf5_read_data(IPMPO,"/local_values/LOCVALTYPE",PARTYL) + CALL hdf5_read_data(IPMPO,"/local_values/LOCVALINFOADR",PARADL) + CALL hdf5_read_data(IPMPO,"/local_values/NLOCVALINFO",NPCHL) + IF(NPCHL.GT.0) THEN + CALL hdf5_read_data(IPMPO,"/local_values/LOCVALINFO",PARCAL) + ENDIF +* + CALL LCMGTC(IPEDIT,'LAST-EDIT',12,TEXT12) +*---- +* INITIALIZE LOCADR AND ALLOCATE RVALO. +*---- + IADR=0 + LOCADR(1)=0 + DO 50 IPAR=1,NLOC + IF((PARTYL(IPAR).EQ.'EQUI').OR.(PARTYL(IPAR).EQ.'VITE')) THEN + IADR=IADR+NG + ELSE IF(PARTYL(IPAR).EQ.'COUR') THEN + IADR=IADR+2*NG + ELSE + IADR=IADR+1 + ENDIF + LOCADR(IPAR+1)=IADR + 50 CONTINUE + NVLC=LOCADR(NLOC+1) + ALLOCATE(RVALO(NVLC*NMIL)) +*---- +* RECOVER LOCAL VARIABLES. +*---- + DO 70 IPAR=1,NLOC + IF((PARTYL(IPAR).EQ.'BURNUP').OR.(PARTYL(IPAR).EQ.'TIME').OR. + 1 (PARTYL(IPAR).EQ.'PUIS').OR.(PARTYL(IPAR).EQ.'FLUG').OR. + 2 (PARTYL(IPAR).EQ.'FLUB').OR.(PARTYL(IPAR).EQ.'FLUX').OR. + 3 (PARTYL(IPAR).EQ.'MASL')) THEN +* +* RECOVER LOCAL VARIABLES FROM THE DEPLETION OBJECT. + IF(.NOT.C_ASSOCIATED(IPDEPL)) CALL XABORT('MPOGEP: NO DEPLET' + 1 //'ION OBJECT AVAILABLE AMONG THE RHS LCM OBJECTS.') + CALL LCMGET(IPDEPL,'STATE-VECTOR',ISTATE) + NBURN=ISTATE(3) + NBISO=ISTATE(4) + NREAC=ISTATE(6) + NVAR=ISTATE(7) + NBMIX=ISTATE(8) + CALL LCMGET(IPEDIT,'STATE-VECTOR',ISTATE) + NREG=ISTATE(17) + CALL COMGEN(IPDEPL,IPEDIT,NREG,NMIL,ITIM,PARTYL(IPAR),NBURN, + 1 NBMIX,NBISO,NREAC,NVAR,LOCADR(IPAR),NVLC,RVALO) + ELSE IF((PARTYL(IPAR).EQ.'TEMP').OR.(PARTYL(IPAR).EQ.'CONC')) + 1 THEN +* +* RECOVER LOCAL VARIABLES FROM THE MICROLIB IN EDIT OBJECT. + TEXT8=' ' + IF(PARTYL(IPAR).EQ.'CONC') THEN + IF(NPCHL.EQ.0) CALL XABORT('MPOGEP: MISSING LOCVALINFO.') + IPCHL=PARADL(IPAR)+1 + TEXT8=PARCAL(IPCHL)(:8) + ENDIF + CALL LCMSIX(IPEDIT,TEXT12,1) + CALL LCMGET(IPEDIT,'STATE-VECTOR',ISTATE) + MAXNBI=ISTATE(2) + CALL LCMINF(IPEDIT,NAMLCM,NAMMY,EMPTY,ILONG,LCM) + IPLB3=C_NULL_PTR + DO 60 IBM=1,NMIL + CALL COMBIB(IPEDIT,IPLB3,PARTYL(IPAR),IBM,NAMLCM,TEXT8,MAXNBI, + 1 VALPAR) + RVALO((IBM-1)*NVLC+LOCADR(IPAR))=VALPAR + 60 CONTINUE + CALL LCMSIX(IPEDIT,' ',2) + ELSE IF(PARTYL(IPAR).EQ.'EQUI') THEN +* RECOVER A SET OF SPH EQUIVALENCE FACTORS. + CALL SAPSPH(IPEDIT,NG,NMIL,LOCADR(IPAR),NVLC,RVALO) + ELSE + CALL XABORT('MPOGEP: '//PARTYL(IPAR)//' IS AN UNKNOWN LOCAL'// + 1 ' VARIABLE TYPE.') + ENDIF + IF(IMPX.GT.1) WRITE(6,120) PARKEY(IPAR), + 1 (RVALO((IBM-1)*NVLC+LOCADR(IPAR)),IBM=1,NMIL) + 70 CONTINUE + DO 80 IBM=1,NMIL + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0,6H/zone_,I0,1H/)') + 1 TRIM(HEDIT),NCALAR-1,IBM-1 + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"LOCALVALUE", + 1 RVALO((IBM-1)*NVLC+1:IBM*NVLC)) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"LOCALVALADDR",LOCADR) + 80 CONTINUE + DEALLOCATE(RVALO) + IF(NPCHL.GT.0) DEALLOCATE(PARCAL) + DEALLOCATE(PARADL,PARTYL,PARKEL,LOCADR) + RETURN +* + 100 FORMAT(31H MPOGEP: SET GLOBAL PARAMETER ',A,3H' =,1P,E12.4) + 110 FORMAT(/16H MPOGEP: MUPLET=,10I6:/(16X,10I6)) + 120 FORMAT(29H MPOGEP: SET LOCAL VARIABLE ',A,3H' =,1P,5E12.4/(36X, + 1 5E12.4)) + END diff --git a/Dragon/src/MPOGEY.f b/Dragon/src/MPOGEY.f new file mode 100644 index 0000000..3dccadf --- /dev/null +++ b/Dragon/src/MPOGEY.f @@ -0,0 +1,216 @@ +*DECK MPOGEY + SUBROUTINE MPOGEY(IPMPO,IPEDIT,HEDIT,NISO,NG,NMIL,NBISO,ICAL,NDFI, + 1 NISFS,NISPS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To recover the fission yields of an elementary calculation. +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMPO pointer to the MPO file. +* IPEDIT pointer to the edition object (L_EDIT signature). +* HEDIT name of output group for a (multigroup mesh, output geometry) +* couple (generally equal to 'output_0'). +* NISO number of particularized isotopes. +* NG number of condensed energy groups. +* NMIL number of mixtures in the MPO file. +* NBISO number of isotopes in the condensed microlib of the edition +* object. A given isotope may appear in many mixtures. +* ICAL index of the current elementary calculation. +* NDFI number of fissile isotopes producing fission products in +* the edition object. +* NISFS number of particularized fissile isotopes. +* NISPS number of particularized fission products. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMPO,IPEDIT + INTEGER NISO,NG,NMIL,NBISO,ICAL,NDFI,NISFS,NISPS + CHARACTER(LEN=12) HEDIT +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MAXISO=800) + TYPE(C_PTR) JPEDIT,KPEDIT + CHARACTER TEXT8*8,TEXT12*12,RECNAM*80 + LOGICAL LGIMF +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MIX,ITYPE,PIFI,ADRY + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISONAM + REAL, ALLOCATABLE, DIMENSION(:) :: DEN,PYIELD,SIG,PFIRA + REAL, ALLOCATABLE, DIMENSION(:,:) :: FLUXES + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: YLDS + CHARACTER(LEN=24), ALLOCATABLE, DIMENSION(:) :: NOMISO + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO +*---- +* SCRATCH STORAGE ALLOCATION +* PFIRA fission rate. +* ADRY offset in YLDS array for fissile isotopes (positive) and +* fission products (negative). +*---- + ALLOCATE(ISONAM(3,NBISO),MIX(NBISO),ITYPE(NBISO),PIFI(NDFI)) + ALLOCATE(YLDS(NISFS,NISPS,1),DEN(NBISO),PYIELD(NDFI), + 1 FLUXES(NMIL,NG),SIG(NG),PFIRA(NBISO),ADRY(NISO)) + ALLOCATE(IPISO(NBISO)) +*---- +* RECOVER INFORMATION FROM THE /contents/isotopes GROUP. +*---- + IF(NISO.GT.0) THEN + CALL hdf5_read_data(IPMPO,"/contents/isotopes/ISOTOPENAME", + 1 NOMISO) + ENDIF +* + CALL LCMGET(IPEDIT,'ISOTOPESUSED',ISONAM) + CALL LCMGET(IPEDIT,'ISOTOPESMIX',MIX) + CALL LCMGET(IPEDIT,'ISOTOPESDENS',DEN) + CALL LCMGET(IPEDIT,'ISOTOPESTYPE',ITYPE) + CALL LIBIPS(IPEDIT,NBISO,IPISO) +*---- +* COMPUTE ARRAY ADRY. +*---- + ISF=0 + ISP=0 + ADRY(:NISO)=0 + DO 30 ISO=1,NISO-1 + DO 10 IBISO=1,NBISO + WRITE(TEXT8,'(2A4)') (ISONAM(I0,IBISO),I0=1,2) + IF(NOMISO(ISO).EQ.TEXT8) GO TO 20 + 10 CONTINUE + GO TO 30 + 20 IF(ITYPE(IBISO).EQ.2) THEN + ISF=ISF+1 + ADRY(ISO)=ISF + ELSEIF(ITYPE(IBISO).EQ.3) THEN + ISP=ISP+1 + ADRY(ISO)=-ISP + ENDIF + 30 CONTINUE + LGIMF=NISFS.GT.0 + IF(LGIMF) THEN + ISF=ISF+1 + ADRY(NISO)=ISF ! declare the residual as fissile + ENDIF + IMF=0 + IF(LGIMF) IMF=ADRY(NISO) +*---- +* RECOVER THE NEUTRON FLUX. +*---- + CALL LCMSIX(IPEDIT,'MACROLIB',1) + JPEDIT=LCMGID(IPEDIT,'GROUP') + DO 40 IGR=1,NG + KPEDIT=LCMGIL(JPEDIT,IGR) + CALL LCMGET(KPEDIT,'FLUX-INTG',FLUXES(1,IGR)) + 40 CONTINUE + CALL LCMSIX(IPEDIT,' ',2) +*---- +* RECOVER THE FISSION RATES. +*---- + DO 65 IBISO=1,NBISO + GAR=0.0 + IF(MIX(IBISO).EQ.0) GO TO 60 + KPEDIT=IPISO(IBISO) + CALL LCMLEN(KPEDIT,'NFTOT',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,'NFTOT',SIG) + DO 50 IGR=1,NG + GAR=GAR+FLUXES(MIX(IBISO),IGR)*DEN(IBISO)*SIG(IGR) + 50 CONTINUE + ENDIF + 60 PFIRA(IBISO)=GAR + 65 CONTINUE +*---- +* LOOP OVER MPO MIXTURES TO RECOVER THE FISSION YIELDS. +*---- + DO 140 IMIL=1,NMIL + DO 75 IFP=1,NISPS + DO 70 IFI=1,NISFS + YLDS(IFI,IFP,1)=0.0 + 70 CONTINUE + 75 CONTINUE + DO 130 IBISO=1,NBISO + IF(MIX(IBISO).EQ.IMIL) THEN + WRITE(TEXT12,'(3A4)') (ISONAM(I0,IBISO),I0=1,3) + DO 80 ISO=1,NISO + IISO=ISO + IF(NOMISO(ISO).EQ.TEXT12(:8)) GO TO 90 + 80 CONTINUE + GO TO 130 + 90 KPEDIT=IPISO(IBISO) +* +* RECOVER THE FISSION YIELDS. + CALL LCMLEN(KPEDIT,'PYIELD',ILONG,ITYLCM) + IF((ILONG.GT.0).AND.(ILONG.EQ.NDFI)) THEN + CALL LCMGET(KPEDIT,'PIFI',PIFI) + CALL LCMGET(KPEDIT,'PYIELD',PYIELD) + ELSE + GO TO 130 + ENDIF + IFP=-ADRY(IISO) + IF(IFP.GT.0) THEN +* Particular fission product found. +* If exists in medium, find position in microlib +* and search all fissiles. + YLDW=0.0 + DO 120 IDFI=1,NDFI + JBISO=PIFI(IDFI) + IF(JBISO.GT.NBISO) CALL XABORT('MPOGEY: MIX OVERFLOW.') + IF(JBISO.EQ.0) GO TO 120 + IF(MIX(JBISO).NE.IMIL) GO TO 120 + WRITE(TEXT8,'(3A4)') (ISONAM(I0,JBISO),I0=1,2) + DO 100 JSO=1,NISO + JISO=JSO + IF(NOMISO(JSO).EQ.TEXT8) GO TO 110 + 100 CONTINUE +* Mother isotope is in residual macro. + YLDW=YLDW+PFIRA(JBISO) + IF(IMF.EQ.0) CALL XABORT('MPOGEY: LGIMF IS FALSE.') + YLDS(IMF,IFP,1)=YLDS(IMF,IFP,1)+PYIELD(IDFI)*PFIRA(JBISO) + GO TO 120 +* +* Yield for selected isotopes. + 110 IFI=ADRY(JISO) + IF(IFI.LE.0) CALL XABORT('MPOGEY: BAD ADRY.') + YLDS(IFI,IFP,1)=PYIELD(IDFI) + 120 CONTINUE + IF(LGIMF) THEN + IF(YLDW.NE.0.0) YLDS(IMF,IFP,1)=YLDS(IMF,IFP,1)/YLDW + ENDIF + ENDIF + ENDIF + 130 CONTINUE + IF(NISO.GT.0) DEALLOCATE(NOMISO) +*---- +* STORE INFORMATION IN THE statept_id/zone_id GROUP. +*---- + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0,6H/zone_,I0,1H/)') + > TRIM(HEDIT),ICAL-1,IMIL-1 + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"yields/YIELD",YLDS) + 140 CONTINUE +* + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"yields/ADDRY",ADRY) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IPISO) + DEALLOCATE(ADRY) + DEALLOCATE(PFIRA,SIG,FLUXES,PYIELD,DEN,YLDS) + DEALLOCATE(PIFI,ITYPE,MIX,ISONAM) + RETURN + END diff --git a/Dragon/src/MPOIDF.f b/Dragon/src/MPOIDF.f new file mode 100644 index 0000000..5a458e9 --- /dev/null +++ b/Dragon/src/MPOIDF.f @@ -0,0 +1,179 @@ +*DECK MPOIDF + SUBROUTINE MPOIDF(IPMPO,IPEDIT,HEDIT,NG,NMIL,ICAL,IDF,NALBP, + 1 FNORM,VOLMIL,FLXMIL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To store discontinuity factor and albedo information in the MPO file. +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMPO pointer to the MPO file. +* IPEDIT pointer to the edition object (L_EDIT signature). +* HEDIT name of output group for a (multigroup mesh, output geometry) +* couple (generally equal to 'output_0'). +* NG number of condensed energy groups. +* NMIL number of mixtures. +* ICAL index of the current elementary calculation. +* IDF type of surfacic information (2/3: boundary flux/DF). +* NALBP number of physical albedos per energy group. +* FNORM flux normalization factor. +* VOLMIL mixture volumes. +* FLXMIL averaged flux of mixtures. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMPO,IPEDIT + INTEGER NG,NMIL,ICAL,IDF,NALBP + REAL FNORM,VOLMIL(NMIL),FLXMIL(NMIL,NG) + CHARACTER(LEN=12) HEDIT +*---- +* LOCAL VARIABLES +*---- + CHARACTER HSMG*131,RECNAM*80 +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: SURF + REAL, ALLOCATABLE, DIMENSION(:,:) :: VREAL,ALBP + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: DISFAC,ALBP2 + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HADF +*---- +* RECOVER DISCONTINUITY FACTOR INFORMATION FROM MACROLIB +*---- + CALL LCMSIX(IPEDIT,'MACROLIB',1) + CALL LCMLEN(IPEDIT,'ADF',ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + CALL LCMSIX(IPEDIT,'ADF',1) + CALL LCMGET(IPEDIT,'NTYPE',NSURFD) + NGG=0 + IF((IDF.EQ.2).OR.(IDF.EQ.3)) THEN + NGG=NG + ELSE IF(IDF.EQ.4) THEN + NGG=NG*NG + ELSE + CALL XABORT('MPOIDF: INVALID ADF OPTION.') + ENDIF + ALLOCATE(DISFAC(NSURFD,NGG,NMIL),SURF(NMIL*NGG),HADF(NSURFD)) + CALL LCMGTC(IPEDIT,'HADF',8,NSURFD,HADF) + DO I=1,NSURFD + CALL LCMLEN(IPEDIT,HADF(I),ILONG,ITYLCM) + IF(IDF.EQ.2) THEN +* boundary flux information + IF(ILONG.NE.NMIL*NG) THEN + WRITE(HSMG,'(16HMPOIDF: INVALID ,A,8H LENGTH=,I5, + 1 10H EXPECTED=,I5,4H.(1))') HADF(I),ILONG,NMIL*NG + CALL XABORT(HSMG) + ENDIF + CALL LCMGET(IPEDIT,HADF(I),SURF) + DO IMIL=1,NMIL + DO IGR=1,NG + IF(FNORM.NE.1.0) THEN + DISFAC(I,IGR,IMIL)=SURF((IGR-1)*NMIL+IMIL)* + 1 FNORM*1.0E13*VOLMIL(IMIL)/FLXMIL(IMIL,IGR) + ELSE + DISFAC(I,IGR,IMIL)=SURF((IGR-1)*NMIL+IMIL)* + 1 VOLMIL(IMIL)/FLXMIL(IMIL,IGR) + ENDIF + ENDDO + ENDDO + ELSE IF(IDF.EQ.3) THEN +* discontinuity factor information + IF(ILONG.NE.NMIL*NG) THEN + WRITE(HSMG,'(16HMPOIDF: INVALID ,A,8H LENGTH=,I5, + 1 10H EXPECTED=,I5,4H.(2))') HADF(I),ILONG,NMIL*NG + CALL XABORT(HSMG) + ENDIF + CALL LCMGET(IPEDIT,HADF(I),SURF) + DO IMIL=1,NMIL + DO IGR=1,NG + IOF=(IGR-1)*NMIL+IMIL + DISFAC(I,IGR,IMIL)=SURF(IOF) + ENDDO + ENDDO + ELSE IF(IDF.EQ.4) THEN +* matrix discontinuity factor information + IF(ILONG.NE.NMIL*NG*NG) THEN + WRITE(HSMG,'(16HMPOIDF: INVALID ,A,8H LENGTH=,I5, + 1 10H EXPECTED=,I5,4H.(3))') HADF(I),ILONG,NMIL*NG*NG + CALL XABORT(HSMG) + ENDIF + CALL LCMGET(IPEDIT,HADF(I),SURF) + DO IMIL=1,NMIL + DO IGR=1,NG + DO JGR=1,NG + IOF=((JGR-1)*NG+IGR-1)*NMIL+IMIL + DISFAC(I,(JGR-1)*NG+IGR,IMIL)=SURF(IOF) + ENDDO + ENDDO + ENDDO + ENDIF + ENDDO + DEALLOCATE(HADF,SURF) + CALL LCMSIX(IPEDIT,' ',2) +*---- +* MOVE TO THE /statept_id/zone_id/discontinuity GROUP. +*---- + DO IMIL=1,NMIL + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0,6H/zone_,I0, + 1 15H/discontinuity/)') TRIM(HEDIT),ICAL-1,IMIL-1 + CALL hdf5_create_group(IPMPO,TRIM(RECNAM)) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"NSURF",NSURFD) + IF((IDF.EQ.2).OR.(IDF.EQ.3)) THEN + ALLOCATE(VREAL(NSURFD,NG)) + VREAL(:NSURFD,:NG)=DISFAC(:NSURFD,:NG,IMIL) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"DFACTOR",VREAL) + ELSE IF(IDF.EQ.4) THEN + ALLOCATE(VREAL(NSURFD,NG*NG)) + VREAL(:NSURFD,:NG*NG)=DISFAC(:NSURFD,:NG*NG,IMIL) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"DFACTORGxG",VREAL) + ENDIF + DEALLOCATE(VREAL) + ENDDO + DEALLOCATE(DISFAC) + ENDIF +*---- +* MOVE TO THE /statept_id/flux GROUP. +*---- + IF(NALBP.NE.0) THEN + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0,6H/flux/)') + 1 TRIM(HEDIT),ICAL-1 + CALL hdf5_create_group(IPMPO,TRIM(RECNAM)) +*---- +* RECOVER AND SAVE ALBEDO INFORMATION +*---- + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"NALBP",NALBP) + CALL LCMLEN(IPEDIT,'ALBEDO',ILONG,ITYLCM) + IF(ILONG.EQ.NALBP*NG) THEN +* diagonal physical albedos + ALLOCATE(ALBP(NALBP,NG)) + CALL LCMGET(IPEDIT,'ALBEDO',ALBP) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"ALBEDO",ALBP) + DEALLOCATE(ALBP) + ELSE IF(ILONG.EQ.NALBP*NG*NG) THEN +* matrix physical albedos + ALLOCATE(ALBP2(NALBP,NG,NG)) + CALL LCMGET(IPEDIT,'ALBEDO',ALBP2) + CALL hdf5_write_data(IPMPO,TRIM(RECNAM)//"ALBEDOGxG",ALBP2) + DEALLOCATE(ALBP2) + ELSE + CALL XABORT('MPOIDF: INCONSISTENT ALBEDO INFORMATION.') + ENDIF + ENDIF + CALL LCMSIX(IPEDIT,' ',2) + RETURN + END diff --git a/Dragon/src/MPOPAV.f b/Dragon/src/MPOPAV.f new file mode 100644 index 0000000..e331d99 --- /dev/null +++ b/Dragon/src/MPOPAV.f @@ -0,0 +1,192 @@ +*DECK MPOPAV + SUBROUTINE MPOPAV(IPMPO,HEDIT,IPAR,NPAR,TTYPE,RVAL,IVAL,CVAL,IV, + 1 LGNEW) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To return the index of a global parameter value. Reorganize the +* parameters group if required. +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMPO pointer to the MPO file. +* HEDIT name of output group for a (multigroup mesh, output geometry) +* couple (generally equal to 'output_0'). +* IPAR index of the global parameter. +* NPAR total number of global parameters. +* TTYPE type of the global parameter value. +* RVAL global parameter value if TTYPE='FLOAT'. +* IVAL global parameter value if TTYPE='INTEGER'. +* CVAL global parameter value if TTYPE='STRING'. +* +*Parameters: output +* IV index of the global parameter value (IV >= 0). +* LGNEW new parameter flag (=.true. if the parameter value is new). +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMPO + INTEGER IPAR,NPAR,IV,IVAL + REAL RVAL + LOGICAL LGNEW,LSHIFT + CHARACTER HEDIT*12,TTYPE*8,CVAL*(*) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (REPS=1.0E-5) + INTEGER RANK,TYPE,NBYTE,DIMSR(5) + CHARACTER RECNAM*72 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NVALUE,VINTE,VINTE_OLD, + 1 DIMS_MPO,MUPLET + REAL, ALLOCATABLE, DIMENSION(:) :: VREAL,VREAL_OLD + CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: VCHAR,VCHAR_OLD +* + IF(IPAR.GT.NPAR) CALL XABORT('MPOPAV: NPAR OVERFLOW.') + CALL hdf5_read_data(IPMPO,"/parameters/info/NVALUE",NVALUE) + WRITE(RECNAM,'(25H/parameters/values/PARAM_,I0)') IPAR-1 +* + LGNEW=.TRUE. + LSHIFT=.FALSE. + IF(TTYPE.EQ.'FLOAT') THEN + IF(NVALUE(IPAR).EQ.0) THEN + ALLOCATE(VREAL(1)) + IV=0 + VREAL(IV+1)=RVAL + NVALUE(IPAR)=1 + ELSE + CALL hdf5_get_shape(IPMPO,TRIM(RECNAM),DIMS_MPO) + ILONG=DIMS_MPO(1) + DEALLOCATE(DIMS_MPO) + IF(ILONG.GT.NVALUE(IPAR)) CALL XABORT('MPOPAV: NVALUE OVER' + 1 //'FLOW(1).') + CALL hdf5_read_data(IPMPO,TRIM(RECNAM),VREAL_OLD) + DO 10 I=1,NVALUE(IPAR) + IF(RVAL.LE.VREAL_OLD(I)*(1.+REPS))THEN + IV=I-1 + LGNEW=RVAL.LT.VREAL_OLD(IV+1)*(1.-REPS) + GO TO 20 + ENDIF + 10 CONTINUE + IV=NVALUE(IPAR) + 20 ALLOCATE(VREAL(NVALUE(IPAR)+1)) + VREAL(:NVALUE(IPAR))=VREAL_OLD(:NVALUE(IPAR)) + IF(LGNEW) THEN + LSHIFT=IV.LT.NVALUE(IPAR) + NVALUE(IPAR)=NVALUE(IPAR)+1 + DO 30 J=NVALUE(IPAR)-1,IV+1,-1 + VREAL(J+1)=VREAL_OLD(J) + 30 CONTINUE + VREAL(IV+1)=RVAL + ENDIF + DEALLOCATE(VREAL_OLD) + ENDIF + IF(LGNEW) CALL hdf5_write_data(IPMPO,TRIM(RECNAM),VREAL) + DEALLOCATE(VREAL) + ELSE IF(TTYPE.EQ.'INTEGER') THEN + IF(NVALUE(IPAR).EQ.0) THEN + ALLOCATE(VINTE(1)) + IV=0 + VINTE(IV+1)=IVAL + NVALUE(IPAR)=1 + ELSE + CALL hdf5_get_shape(IPMPO,TRIM(RECNAM),DIMS_MPO) + ILONG=DIMS_MPO(1) + DEALLOCATE(DIMS_MPO) + IF(ILONG.GT.NVALUE(IPAR)) CALL XABORT('MPOPAV: NVALUE OVER' + 1 //'FLOW(2).') + CALL hdf5_read_data(IPMPO,TRIM(RECNAM),VINTE_OLD) + DO 40 I=1,NVALUE(IPAR) + IF(IVAL.LE.VINTE_OLD(I))THEN + IV=I-1 + LGNEW=IVAL.LT.VINTE_OLD(IV+1) + GO TO 50 + ENDIF + 40 CONTINUE + IV=NVALUE(IPAR) + 50 ALLOCATE(VINTE(NVALUE(IPAR)+1)) + VINTE(:NVALUE(IPAR))=VINTE_OLD(:NVALUE(IPAR)) + IF(LGNEW) THEN + NVALUE(IPAR)=NVALUE(IPAR)+1 + DO 60 J=NVALUE(IPAR)-1,IV+1,-1 + VINTE(J+1)=VINTE_OLD(J) + 60 CONTINUE + VINTE(IV+1)=IVAL + ENDIF + DEALLOCATE(VINTE_OLD) + ENDIF + IF(LGNEW) CALL hdf5_write_data(IPMPO,TRIM(RECNAM),VINTE) + DEALLOCATE(VINTE) + ELSE IF(TTYPE.EQ.'STRING') THEN + IF(NVALUE(IPAR).EQ.0) THEN + ALLOCATE(VCHAR(1)) + IV=0 + VCHAR(IV+1)=CVAL + NVALUE(IPAR)=1 + ELSE + CALL hdf5_get_shape(IPMPO,TRIM(RECNAM),DIMS_MPO) + ILONG=DIMS_MPO(1) + DEALLOCATE(DIMS_MPO) + IF(ILONG.GT.NVALUE(IPAR)) CALL XABORT('MPOPAV: NVALUE OVER' + 1 //'FLOW(3).') + CALL hdf5_read_data(IPMPO,TRIM(RECNAM),VCHAR_OLD) + DO 70 I=1,NVALUE(IPAR) + IF(CVAL.EQ.VCHAR_OLD(I))THEN + IV=I-1 + LGNEW=.FALSE. + GO TO 80 + ENDIF + 70 CONTINUE + IV=NVALUE(IPAR) + 80 ALLOCATE(VCHAR(NVALUE(IPAR)+1)) + VCHAR(:NVALUE(IPAR))=VCHAR_OLD(:NVALUE(IPAR)) + IF(LGNEW) THEN + NVALUE(IPAR)=NVALUE(IPAR)+1 + VCHAR(NVALUE(IPAR))=CVAL + ENDIF + DEALLOCATE(VCHAR_OLD) + ENDIF + IF(LGNEW) CALL hdf5_write_data(IPMPO,TRIM(RECNAM),VCHAR) + DEALLOCATE(VCHAR) + ELSE + CALL XABORT('MPOPAV: UNKNOWN TYPE='//TTYPE//'.') + ENDIF +* + IF(LGNEW) THEN + CALL hdf5_write_data(IPMPO,"/parameters/info/NVALUE",NVALUE) + ENDIF + IF(LSHIFT) THEN + CALL hdf5_read_data(IPMPO,"/parameters/tree/NSTATEPOINT",NCALAR) + DO 90 ICAL=1,NCALAR + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0,14H/PARAMVALUEORD)') + 1 TRIM(HEDIT),ICAL-1 + CALL hdf5_info(IPMPO,TRIM(RECNAM),RANK,TYPE,NBYTE,DIMSR) + IF(RANK.EQ.1) THEN + CALL hdf5_read_data(IPMPO,TRIM(RECNAM),MUPLET) + IF(MUPLET(IPAR).GE.IV) THEN + MUPLET(IPAR)=MUPLET(IPAR)+1 + CALL hdf5_write_data(IPMPO,TRIM(RECNAM),MUPLET) + ENDIF + DEALLOCATE(MUPLET) + ENDIF + 90 CONTINUE + ENDIF + DEALLOCATE(NVALUE) + RETURN + END diff --git a/Dragon/src/MPOTOC.f b/Dragon/src/MPOTOC.f new file mode 100644 index 0000000..be1067e --- /dev/null +++ b/Dragon/src/MPOTOC.f @@ -0,0 +1,215 @@ +*DECK MPOTOC + SUBROUTINE MPOTOC(IPMPO,HEDIT,IMPX,NREA,NBISO,NMIL,NPAR,NLOC, + 1 NISOF,NISOP,NISOS,NCAL,NGRP,NSURFD,NALBP,NPRC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover the table of content of an MPO file. +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* +*Author(s): +* A. Hebert +* +*Parameters: input +* IPMPO address of the MPO file. +* HEDIT name of output group for a (multigroup mesh, output geometry) +* couple (generally equal to 'output_0'). +* IMPX print parameter (equal to zero for no print). +* +*Parameters: output +* NREA number of neutron-induced reaction +* NBISO number of particularized isotopes +* NMIL number of mixtures in the MPO file +* NPAR number of global parameters +* NLOC number of local parameters +* NISOF number of particularized fissile isotopes +* NISOP number of particularized fission products +* NISOS number of particularized stable isotopes +* NCAL number of elementary calculations +* NGRP number of energy groups +* NSURFD number of discontinuity factors values in the MPO file +* NALBP number of physical albedos per energy group +* NPRC number of precursors +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMPO + INTEGER IMPX,NREA,NBISO,NMIL,NPAR,NLOC,NISOF,NISOP,NISOS,NCAL, + 1 NGRP,NSURFD,NALBP,NPRC + CHARACTER(LEN=12) HEDIT +*---- +* LOCAL VARIABLES +*---- + INTEGER, PARAMETER::IOUT=6 + INTEGER I,J,NENERG,NGEOME,ID_G,ID_E,ID,IBM,NGRP2,RANK,TYPE,NBYTE, + 1 DIMSR(5) + CHARACTER HSMG*131,RECNAM*80,HFORMAT*132 + LOGICAL LNEW + CHARACTER(LEN=100), ALLOCATABLE, DIMENSION(:) :: LIST + INTEGER, ALLOCATABLE, DIMENSION(:) :: DIMS_MPO,ADDRISO + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: OUPUTID +*---- +* LIST GROUPS AND DATASETS ON THE ROOT FILE +*---- + IF(IMPX.GT.0) THEN + CALL hdf5_list_groups(IPMPO, '/', LIST) + WRITE(*,*) + WRITE(*,*) 'MPOTOC: GROUP TABLE OF CONTENTS' + DO I=1,SIZE(LIST) + WRITE(*,*) TRIM(LIST(I)) + ENDDO + DEALLOCATE(LIST) + ENDIF +*---- +* RECOVER MPO PARAMETERS +*---- + ID_G=-1 + ID_E=-1 + CALL hdf5_read_data(IPMPO,"/parameters/tree/NSTATEPOINT",NCAL) + CALL hdf5_read_data(IPMPO,"/energymesh/NENERGYMESH",NENERG) + CALL hdf5_read_data(IPMPO,"/geometry/NGEOMETRY",NGEOME) + IF((NENERG.GT.0).AND.(NGEOME.GT.0)) THEN + CALL hdf5_read_data(IPMPO,"/output/OUPUTID",OUPUTID) + READ(HEDIT,'(7X,I2)') ID + DO I=1,NGEOME + DO J=1,NENERG + IF(OUPUTID(J,I).EQ.ID) THEN + ID_G=I-1 + ID_E=J-1 + GO TO 10 + ENDIF + ENDDO + ENDDO + CALL XABORT('MPOTOC: no ID found in /output/OUPUTID.') + 10 WRITE(RECNAM,'(23H/energymesh/energymesh_,I0,1H/)') ID_E + IF(IMPX.GT.1) THEN + HFORMAT='(/42H MPOTOC: Process MPO multiparameter file o,'// + > '9Hn output=,A)' + WRITE(IOUT,HFORMAT) TRIM(HEDIT) + WRITE(IOUT,'(24H MPOTOC: energy group=,A)') TRIM(RECNAM) + ENDIF + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"NG",NGRP2) + IF(NGRP.EQ.0) THEN + NGRP=NGRP2 + ELSE IF(NGRP2.NE.NGRP) THEN + WRITE(HSMG,'(44H MPOTOC: THE MPO FILE HAS AN INVALID NUMBER , + 1 18HOF ENERGY GROUPS (,I4,3H VS,I5,2H).)') NGRP2,NGRP + CALL XABORT(HSMG) + ENDIF + DEALLOCATE(OUPUTID) + WRITE(RECNAM,'(19H/geometry/geometry_,I0,1H/)') ID_G + IF(IMPX.GT.1) THEN + WRITE(IOUT,'(24H MPOTOC: geometry group=,A)') TRIM(RECNAM) + ENDIF + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"NZONE",NMIL) + ENDIF + WRITE(RECNAM,'(8H/output/,A,6H/info/)') TRIM(HEDIT) + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"NREA",NREA) + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"ADDRISO",ADDRISO) + NBISO=ADDRISO(SIZE(ADDRISO,1)) +*---- +* SET NPAR +*---- + NPAR=0 + CALL hdf5_info(IPMPO,"/parameters/info/NVALUE",RANK,TYPE,NBYTE, + 1 DIMSR) + IF(RANK.GT.0) NPAR=DIMSR(1) +*---- +* SET NLOC +*---- + IF(hdf5_group_exists(IPMPO,"/local_values")) THEN + CALL hdf5_get_shape(IPMPO,"/local_values/LOCVALNAME",DIMS_MPO) + NLOC=DIMS_MPO(1) + DEALLOCATE(DIMS_MPO) + ELSE + NLOC=0 + ENDIF +*---- +* SET NISOF AND NISOP +*---- + NISOF=0 + NISOP=0 + IF(NBISO.GT.0) THEN + DO IBM=1,NMIL + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0,6H/zone_,I0,1H/)') + 1 TRIM(HEDIT),0,IBM-1 + IF(hdf5_group_exists(IPMPO,TRIM(RECNAM)//"yields")) THEN + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"yields/NISF",NISOF) + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"yields/NISP",NISOP) + EXIT + ENDIF + ENDDO + ENDIF + NISOS=NBISO-(NISOF+NISOP) + DEALLOCATE(ADDRISO) +*---- +* SET NSURFD +*---- + NSURFD=0 + WRITE(RECNAM,'(8H/output/,A,32H/statept_0/zone_0/discontinuity/)') + & TRIM(HEDIT) + LNEW=hdf5_group_exists(IPMPO,TRIM(RECNAM)) + IF(LNEW) THEN +* new specification + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"NSURF",NSURFD) + ELSE +* old specification + WRITE(RECNAM,'(8H/output/,A,22H/statept_0/flux/NSURF/)') + & TRIM(HEDIT) + CALL hdf5_info(IPMPO,TRIM(RECNAM),RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.NE.99) CALL hdf5_read_data(IPMPO,TRIM(RECNAM),NSURFD) + ENDIF +*---- +* SET NALBP +*---- + WRITE(RECNAM,'(8H/output/,A,16H/statept_0/flux/)') TRIM(HEDIT) + NALBP=0 + CALL hdf5_info(IPMPO,TRIM(RECNAM)//"NALBP",RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.NE.99) CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"NALBP", + 1 NALBP) +*---- +* SET NPRC +*---- + NPRC=0 + WRITE(RECNAM,'(8H/output/,A,27H/statept_0/zone_0/kinetics/)') + 1 TRIM(HEDIT) + IF(hdf5_group_exists(IPMPO,RECNAM)) THEN + CALL hdf5_get_shape(IPMPO,TRIM(RECNAM)//"LAMBDAD",DIMS_MPO) + NPRC=DIMS_MPO(1) + DEALLOCATE(DIMS_MPO) + ENDIF +*---- +* PRINT MPO PARAMETERS +*---- + IF(IMPX.GT.0) THEN + WRITE(IOUT,'(/38H MPOTOC: table of content information:)') + WRITE(IOUT,'(36H nb of neutron-induced reactions =,I3)') NREA + WRITE(IOUT,'(34H nb of particularized isotopes =,I4)') NBISO + WRITE(IOUT,'(19H nb of mixtures =,I5)') NMIL + WRITE(IOUT,'(28H nb of global parameters =,I4)') NPAR + WRITE(IOUT,'(27H nb of local parameters =,I4)') NLOC + WRITE(IOUT,'(42H nb of particularized fissile isotopes =,I4)') + 1 NISOF + WRITE(IOUT,'(42H nb of particularized fission products =,I4)') + 1 NISOP + WRITE(IOUT,'(41H nb of particularized stable isotopes =,I4)') + 1 NISOS + WRITE(IOUT,'(23H nb of calculations =,I9)') NCAL + WRITE(IOUT,'(24H nb of energy groups =,I4)') NGRP + WRITE(IOUT,'(38H nb of discontinuity factor values =,I4)') + 1 NSURFD + WRITE(IOUT,'(44H nb of physical albedos per energy group =, + 1 I4)') NALBP + WRITE(IOUT,'(21H nb of precursors =,I4/)') NPRC + ENDIF + RETURN + END diff --git a/Dragon/src/MRG.f b/Dragon/src/MRG.f new file mode 100644 index 0000000..6826075 --- /dev/null +++ b/Dragon/src/MRG.f @@ -0,0 +1,380 @@ +*DECK MRG + SUBROUTINE MRG(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*---------- +* +*Purpose: +* Merge EXCELT or NXT geometry. +* +*Copyright: +* Copyright (C) 1997 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1) creation type(L_MC); +* HENTRY(2) read-only or modification type(L_TRACK); +* HENTRY(3) read-only type(L_LIBRARY) or type(L_MACROLIB). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*Comments: +* LINKED LIST / XSM FILE: +* HENTRY(1) : CREATION OR UPDATE MODE LINKED LIST TYPE(L_TRACK) +* (CREATION only for EXCELT: type tracking). +* HENTRY(2) : CREATION MODE SEQUENTIAL BINARY TRACKING FILE +* (optionnal for NXT: type tracking). +* HENTRY(3) : READ-ONLY LINKED LIST TYPE(L_TRACK) +* (optionnal for NXT: type tracking). +* HENTRY(4) : READ-ONLY SEQUENTIAL BINARY TRACKING FILE +* (optionnal for NXT: type tracking). +* +*---------- +* + USE GANLIB + IMPLICIT NONE + INTEGER IOUT,NSTATE,NTC,NALB + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NSTATE=40,NTC=18,NALB=6, + > NAMSBR='MRG ') +*---- +* ROUTINE PARAMETERS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) +* INTEGER KENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* Function for inport/export DDS +*---- + INTEGER KDROPN,KDRCLS,IRC,IFILE +*---- +* LOCAL VARIABLES +*---- + INTEGER IDTRKO,IDTRKN,IDTRKE,IDSTRO,IDSTRN,IEN, + > IFTRKO,IFTRKN,IFTRKE +* INTEGER IPTRKN,IPTRKO + TYPE(C_PTR) IPTRKO,IPTRKN + INTEGER ISTATE(NSTATE),ISTATG(NSTATE) + INTEGER ITC + CHARACTER HSIGN*12 + INTEGER NREGO,NUNO,NUNN,NSURO,NUNF,ITROP, + > NSOUTO,NVOUTO,NSOUTN,NVOUTN,ILCMLN,ILCMTY, + > NETSUR,NETVOL,NETNUO,NETNUN,NELT,MAXMN + INTEGER IPRINT,IUPD(4),NDIM,INDBC + REAL ALBEDN(NALB) +*---- +* Tracking file variables +*---- + INTEGER IFMT,NCOMNT,NBTRK,NSCRP(9),NALBG,NANGL,MXSEG, + > MXSUB,NUNKNO,NUNKNN,IOPTT,MAXMIX + CHARACTER CTRK*4,COMENT*80 +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IMERGE,MIXN,MATO,MATRTO, + > MATN,KEYN,MATRTN,NEXMAT,NEXKEY,NEXMAN,NEXKEN + REAL, ALLOCATABLE, DIMENSION(:) :: VOLO,VOLN +*---- +* PARAMETER VALIDATION +*---- + IF(NENTRY .LT. 1 .OR. NENTRY .GT. 4) CALL XABORT(NAMSBR// + > ': From 1 to 4 data structures required') +*---- +* Find and validate structure types +*---- + IDTRKO=0 + IDTRKN=0 + IDTRKE=0 + IDSTRO=0 + IDSTRN=0 + IOPTT=0 + DO IEN=1,NENTRY + IF(IENTRY(IEN) .EQ. 1 .OR. IENTRY(IEN) .EQ. 2) THEN + IF(JENTRY(IEN) .EQ. 0) THEN + IDSTRN=IEN + ELSE IF(JENTRY(IEN) .EQ. 1) THEN + IDSTRN=IEN + IDSTRO=IEN + ELSE + IDSTRO=IEN + ENDIF + ELSE IF(IENTRY(IEN) .EQ. 3) THEN + IF(JENTRY(IEN) .EQ. 0) THEN + IF(IDTRKN .EQ. 0) THEN + IDTRKN=IEN + ELSE + IDTRKE=IEN + ENDIF + ELSE IF(JENTRY(IEN) .EQ. 2) THEN + IDTRKO=IEN + ENDIF + ELSE + CALL XABORT(NAMSBR//': One data structure has invalid type') + ENDIF + ENDDO + IF(IDSTRO .EQ. 0) CALL XABORT(NAMSBR// + >': Reference tracking data structure missing') + IF(IDSTRN .NE. IDSTRO) THEN +*---- +* Make a full copy of the old data structure to the new data structure +* we will update later +*---- + IPTRKO=KENTRY(IDSTRO) + IPTRKN=IPTRKO + IF(IDSTRN .NE. 0) THEN + IPTRKN=KENTRY(IDSTRN) + IFILE=KDROPN('DUMMYSQ',0,2,0,0) + IF(IFILE.LE.0) CALL XABORT(NAMSBR//': KDROPN FAILURE.') + CALL LCMEXP(IPTRKO,0,IFILE,1,1) + REWIND(IFILE) + CALL LCMEXP(IPTRKN,0,IFILE,1,2) + IRC=KDRCLS(IFILE,2) + ENDIF + ELSE + IPTRKN=KENTRY(IDSTRN) + ENDIF +*---- +* Test contents of the data structure to update +* Either old data structure or new data structure that now contains +* a copy of the old data structure +*---- + CALL LCMGTC(IPTRKN,'SIGNATURE ',12,HSIGN) + IF(HSIGN .NE. 'L_TRACK') CALL XABORT(NAMSBR// + > ': SIGNATURE OF '//HENTRY(3)//' IS '//HSIGN// + > '. L_TRACK EXPECTED.') + CALL LCMGTC(IPTRKN,'TRACK-TYPE ',12,HSIGN) + IF(HSIGN .NE. 'EXCELL') CALL XABORT(NAMSBR// + > ': ILLEGAL TRACKING FORMAT') + ISTATE(:NSTATE)=0 + CALL LCMGET(IPTRKN,'STATE-VECTOR',ISTATE) + NREGO=ISTATE(1) + NUNO=ISTATE(2) + NUNF=NUNO/NREGO + MAXMIX=ISTATE(4) + NSURO=ISTATE(5) + ITROP=ISTATE(7) +*---- +* Test if NXT: or EXCELT: tracking +* For EXCELT: -> tracking files are required +* For NXT: -> tracking files are optional +*---- + IF(ITROP .GE. 1 .AND. ITROP .LE. 3) THEN + IF(IDTRKO .EQ. 0 .OR. IDTRKN .EQ. 0) CALL XABORT(NAMSBR// + > ': Tracking files required for EXCELT: tracking') + IOPTT=1 + ELSE IF(ITROP .EQ. 4) THEN + IF(IDTRKO .EQ. 0 .AND. IDTRKN .EQ. 0) THEN + IOPTT=2 + ELSE IF(IDTRKO .GT. 0 .AND. IDTRKN .GT. 0) THEN + IOPTT=3 + IF(IDTRKE .GT. 0) IOPTT=4 + ELSE + CALL XABORT(NAMSBR// + > ': Either 0, 2 or 3 tracking files required for NXT: tracking') + ENDIF + ELSE + CALL XABORT(NAMSBR// + > ': Invalid tracking options on tracking data structure') + ENDIF + NVOUTO=NREGO + NSOUTO=NSURO +*---- +* READ MERGE INFORMATION +*---- + ALLOCATE(IMERGE(-NSOUTO:NVOUTO),MIXN(NVOUTO)) + CALL MRGGET(IPRINT,NSOUTO,NVOUTO,NSOUTN,NVOUTN, + > IUPD,IMERGE,MIXN,ALBEDN) + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + IF(IOPTT .NE. 4) THEN + NUNN=NUNF*NVOUTN + ISTATE(1)=NVOUTN + ISTATE(2)=NUNN + ISTATE(5)=NSOUTN +*---- +* Read global records to merge +*---- + ALLOCATE(MATN(NVOUTN),VOLN(NVOUTN),MATRTN(NSOUTN),KEYN(NREGO)) + ALLOCATE(MATO(NVOUTO),VOLO(NVOUTO),MATRTO(NSOUTO)) + CALL LCMGET(IPTRKN,'MATCOD ',MATO) + CALL LCMGET(IPTRKN,'VOLUME ',VOLO) + CALL LCMLEN(IPTRKN,'BC-REFL+TRAN',ILCMLN,ILCMTY) + IF(ILCMLN .EQ. NSOUTO) THEN + INDBC=1 + CALL LCMGET(IPTRKN,'BC-REFL+TRAN',MATRTO) + ELSE + INDBC=0 + MATRTO(:NSOUTO)=0 + ENDIF + NETNUN=NSOUTN+NVOUTN+1 + IF(ITROP .EQ. 4) THEN +*---- +* Process NXT: Records +*---- + CALL LCMSIX(IPTRKN,'NXTRecords ',1) + ISTATG(:NSTATE)=0 + CALL LCMGET(IPTRKN,'G00000001DIM',ISTATG) + NETSUR=ISTATG(22) + NETVOL=ISTATG(23) + NELT=NETSUR+NETVOL+1 + ALLOCATE(NEXMAT(NELT),NEXKEY(NELT)) + CALL LCMGET(IPTRKN,'MATALB ',NEXMAT) + CALL LCMGET(IPTRKN,'KEYMRG ',NEXKEY) + CALL MRGVON(IUPD ,NSOUTO,NVOUTO,NSOUTN,NVOUTN, + > NETSUR,NETVOL,NUNN ,MAXMN , + > IMERGE,MATO ,VOLO ,MATRTO, + > MATN ,VOLN ,KEYN ,MATRTN, + > NEXMAT,NEXKEY) +*---- +* Save NXT: specific records +*---- + CALL LCMPUT(IPTRKN,'MATALB ',NELT,1,NEXMAT) + CALL LCMPUT(IPTRKN,'KEYMRG ',NELT,1,NEXKEY) + CALL LCMSIX(IPTRKN,'NXTRecords ',2) + DEALLOCATE(NEXKEY,NEXMAT) + ELSE +*---- +* Process EXCELT: Records +*---- + CALL LCMSIX(IPTRKN,'EXCELL ',1) + ISTATG(:NSTATE)=0 + CALL LCMGET(IPTRKN,'STATE-VECTOR',ISTATG) + NETSUR=ISTATG(2) + NETVOL=ISTATG(3) + NETNUO=ISTATG(6) + ALLOCATE(NEXMAT(-NETSUR:NETVOL),NEXKEY(-NETSUR:NETVOL)) + ALLOCATE(NEXMAN(-NSOUTN:NVOUTN),NEXKEN(-NSOUTN:NVOUTN)) + CALL LCMGET(IPTRKO,'MATALB ',NEXMAT) + CALL LCMGET(IPTRKO,'KEYMRG ',NEXKEY) + CALL MRGVOL(IUPD ,NSOUTO,NVOUTO,NSOUTN,NVOUTN,NREGO , + > IMERGE,MIXN ,MATO ,VOLO ,MATN ,VOLN , + > KEYN ,MATRTO,MATRTN,MAXMN ,NETVOL,NETSUR, + > NEXMAT,NEXKEY,NEXMAN,NEXKEN) +*---- +* Save EXCELT: specific records +*---- + CALL LCMPUT(IPTRKN,'MATALB ',NETNUN,1,NEXMAN) + CALL LCMPUT(IPTRKN,'KEYMRG ',NETNUN,1,NEXKEN) + CALL LCMPUT(IPTRKN,'STATE-VECTOR',NSTATE,1,ISTATG) + CALL LCMSIX(IPTRKN,'EXCELL ',2) + DEALLOCATE(NEXKEN,NEXMAN) + DEALLOCATE(NEXKEY,NEXMAT) + ENDIF + ISTATE(1)=NVOUTN + ISTATE(2)=NUNN + ISTATE(4)=MAXMN + ISTATE(5)=NSOUTN +*---- +* Save global tracking records +*---- + CALL LCMPUT(IPTRKN,'STATE-VECTOR',NSTATE,1,ISTATE) + IF(IUPD(4). GT. 0 ) THEN + CALL LCMPUT(IPTRKN,'ALBEDO ',NALB,2,ALBEDN) + ENDIF + CALL LCMPUT(IPTRKN,'MATCOD ',NVOUTN,1,MATN) + CALL LCMPUT(IPTRKN,'VOLUME ',NVOUTN,2,VOLN) + IF(IUPD(1) .GT. 0) THEN + CALL LCMPUT(IPTRKN,'KEYFLX ',NVOUTN,1,KEYN) + ENDIF + CALL LCMPUT(IPTRKN,'BC-REFL+TRAN',NSOUTN,1,MATRTN) + DEALLOCATE(MATRTO,VOLO,MATO) + DEALLOCATE(MATN,VOLN,KEYN,MATRTN) +*---- +* Processing of tracking data structure finished +* Now process tracking file if required +*---- + IF(IDTRKN .GT. 0) THEN + IFTRKN=FILUNIT(KENTRY(IDTRKN)) + IFTRKO=FILUNIT(KENTRY(IDTRKO)) + READ (IFTRKO) CTRK,NCOMNT,NBTRK,IFMT + WRITE(IFTRKN) CTRK,NCOMNT,NBTRK,IFMT + DO ITC= 1, NCOMNT + READ (IFTRKO) COMENT + WRITE(IFTRKN) COMENT + ENDDO + READ (IFTRKO) (NSCRP(ITC),ITC=1,9) + NDIM =NSCRP(1) + IF(NVOUTO .NE. NSCRP(3)) CALL XABORT(NAMSBR// + > ': Number of regions on tracking file inconsistent with '// + > 'that on tracking data structure') + IF(NSOUTO .NE. NSCRP(4)) CALL XABORT(NAMSBR// + > ': Number of surfaces on tracking file inconsistent with '// + > 'that on tracking data structure') + NALBG= NSCRP(5) + NANGL= NSCRP(7) + MXSUB= NSCRP(8) + MXSEG= NSCRP(9) + NSCRP(3)=NVOUTN + NSCRP(4)=NSOUTN + WRITE(IFTRKN) (NSCRP(ITC),ITC=1,9) + NUNKNO=NSOUTO+NVOUTO + CALL MRGVST(IFTRKO,IFTRKN,IPRINT,IUPD ,NDIM ,NALBG,NANGL, + > NSOUTO,NVOUTO,NSOUTN,NVOUTN,IMERGE,MIXN ) + NUNKNN=NSOUTN+NVOUTN +*---- +* TRACKING LINE +*---- + CALL MRGLIN(IPRINT,IFTRKO,NSOUTO,NVOUTO,IFTRKN, + > IMERGE,NDIM,IFMT,MXSUB,MXSEG) + ENDIF + ELSE +*---- +* SPLIT TRACKING FILE +*--- + IF(IUPD(1) .GE. 0) CALL XABORT(NAMSBR// + > ': No region specified for EXTR') + IFTRKN=FILUNIT(KENTRY(IDTRKN)) + IFTRKO=FILUNIT(KENTRY(IDTRKO)) + IFTRKE=FILUNIT(KENTRY(IDTRKE)) + READ (IFTRKO) CTRK,NCOMNT,NBTRK + WRITE(IFTRKN) CTRK,NCOMNT,NBTRK + WRITE(IFTRKE) CTRK,NCOMNT,NBTRK + DO ITC= 1, NCOMNT + READ (IFTRKO) COMENT + IF(COMENT .EQ. 'OPTION : Extended ') IFMT=1 + WRITE(IFTRKN) COMENT + WRITE(IFTRKE) COMENT + ENDDO + READ (IFTRKO) (NSCRP(ITC),ITC=1,8) + NDIM =NSCRP(1) + IF(NVOUTO .NE. NSCRP(3)) CALL XABORT(NAMSBR// + > ': Number of regions on tracking file inconsistent with '// + > 'that on tracking data structure') + IF(NSOUTO .NE. NSCRP(4)) CALL XABORT(NAMSBR// + > ': Number of surfaces on tracking file inconsistent with '// + > 'that on tracking data structure') + NALBG= NSCRP(5) + NANGL= NSCRP(7) + MXSEG= NSCRP(8) + WRITE(IFTRKN) (NSCRP(ITC),ITC=1,8) + WRITE(IFTRKE) (NSCRP(ITC),ITC=1,8) + NUNKNO=NSOUTO+NVOUTO + CALL MRGXTC(IFTRKO,IFTRKN,IFTRKE,IPRINT,IUPD ,NDIM, + > NALBG ,NANGL ,NSOUTO,NVOUTO,MXSEG,IMERGE) + ENDIF + DEALLOCATE(MIXN,IMERGE) + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* FORMATS +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + END diff --git a/Dragon/src/MRGGET.f b/Dragon/src/MRGGET.f new file mode 100644 index 0000000..34a01e3 --- /dev/null +++ b/Dragon/src/MRGGET.f @@ -0,0 +1,248 @@ +*DECK MRGGET + SUBROUTINE MRGGET(IPRINT,NSOUTO,NVOUTO,NSOUTN,NVOUTN, + > IUPD,IMERGE,MIXN,ALBEDN) +* +*---------- +* +*Purpose: +* Read merge options. +* +*Copyright: +* Copyright (C) 1997 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPRINT print level. +* NSOUTO old number of surfaces. +* NVOUTO old number of regions. +* +*Parameters: output +* NSOUTN new number of surfaces. +* NVOUTN new number of regions. +* IUPD type of merge required: +* IUPD(1) for region merge and track splitting; +* IUPD(2) for surface merge; +* IUPD(3) for material modification; +* IUPD(4) for albedo modification. +* IMERGE merged position. +* MIXN new material for old regions. +* ALBEDN new surface albedo. +* +*Comments: +* Input options: +* [ EDIT iprint ] +* [ REGI (imerge(ii),ii=1,nvouto)] -> IUPD(1) > 0 +* [ EXTR (imerge(ii),ii=1,-IUPD(1))] -> IUPD(1) < 0 +* [ SURF (imerge(ii),ii=-1,-nsouto)] -> IUPD(2) < 0 +* [ { OLDM (mixn(ii),ii=1,nvouto) | -> IUPD(3) > 0 +* NEWM (mixn(ii),ii=1,nvouto) } ] -> IUPD(3) < 0 +* [ ALBE (albedn(ii),ii=1,6)] -> IUPD(4) > 0 +* +*---------- +* + IMPLICIT NONE + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='MRGGET') +*---- +* ROUTINE PARAMETERS +*---- + INTEGER IPRINT,NSOUTO,NVOUTO,NSOUTN,NVOUTN, + > IUPD(4), + > IMERGE(-NSOUTO:NVOUTO), + > MIXN(NVOUTO) + REAL ALBEDN(6) +*---- +* LOCAL VARIABLES +*---- + INTEGER IVSN,IVSO,ITYPLU,INTLIR + CHARACTER CARLIR*12 + REAL REALIR + DOUBLE PRECISION DBLINP +*---- +* INITIALIZE IMERGE +*---- + IUPD(:4)=0 + MIXN(:NVOUTO)=0 + ALBEDN(:6)=0.0 + DO IVSO=-NSOUTO,NVOUTO + IMERGE(IVSO)=IVSO + ENDDO + NSOUTN=0 + NVOUTN=0 + IPRINT = 1 +*---- +* READ OPTION NAME +*---- + 110 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) + 111 IF(ITYPLU.NE.3) CALL XABORT(NAMSBR// + > ': READ ERROR - CHARACTER VARIABLE EXPECTED') + IF(CARLIR(1:1) .EQ. ';') THEN + GO TO 115 + ELSE IF(CARLIR .EQ. 'EDIT') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) + IF(ITYPLU .NE. 1) GO TO 111 + IPRINT=INTLIR + ELSE IF(CARLIR(1:4) .EQ. 'REGI') THEN + IF(IUPD(1) .NE. 0 ) CALL XABORT(NAMSBR// + > ': A single REGI or EXTR permitted') + DO IVSO=1,NVOUTO + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) + IF(ITYPLU .NE. 1) GO TO 111 + IF(INTLIR .GT. NVOUTO) CALL XABORT(NAMSBR// + > ': FINAL REGION NUMBER MUST BE SMALLER '// + > 'THAN NUMBER OF ORIGINAL REGIONS') + IF(INTLIR .LE. 0) CALL XABORT(NAMSBR// + > ': FINAL REGION NUMBER MUST LARGER THAN 0 ') + IUPD(1)=IUPD(1)+1 + NVOUTN=MAX(NVOUTN,INTLIR) + IMERGE(IVSO)=INTLIR + ENDDO + ELSE IF(CARLIR(1:4) .EQ. 'EXTR') THEN + IF(IUPD(1) .NE. 0 ) CALL XABORT(NAMSBR// + > ': A single REGI or EXTR permitted') + DO IVSO=1,NVOUTO + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) + IF(ITYPLU .NE. 1) GO TO 111 + IF(INTLIR .GT. NVOUTO) CALL XABORT(NAMSBR// + > ': FINAL REGION NUMBER MUST BE SMALLER '// + > 'THAN NUMBER OF ORIGINAL REGIONS') + IF(INTLIR .LE. 0) CALL XABORT(NAMSBR// + > ': FINAL REGION NUMBER MUST LARGER THAN 0 ') + IUPD(1)=IUPD(1)-1 + NVOUTN=MAX(NVOUTN,INTLIR) + IMERGE(IVSO)=INTLIR + ENDDO + ELSE IF(CARLIR(1:4).EQ.'SURF') THEN + DO IVSO=1,NSOUTO + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) + IF(ITYPLU.NE.1) GO TO 111 + IF(INTLIR.GT.NSOUTO) CALL XABORT(NAMSBR// + > ': FINAL SURFACE NUMBER MUST BE SMALLER '// + > 'THAN NUMBER OF ORIGINAL SURFACES') + IF(INTLIR .LE. 0) CALL XABORT(NAMSBR// + > ': FINAL SURFACE NUMBER MUST LARGER THAN 0 ') + IUPD(2)=IUPD(2)-1 + NSOUTN=MAX(NSOUTN,INTLIR) + IMERGE(-IVSO)=-INTLIR + ENDDO + ELSE IF(CARLIR(1:4) .EQ. 'OLDM') THEN + DO IVSO=1,NVOUTO + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) + IF(ITYPLU .NE. 1) GO TO 111 + IF(INTLIR .LT. 0) CALL XABORT(NAMSBR// + > ': FINAL MIXTURE NUMBER MUST LARGER OR EQUAL TO 0 ') + IUPD(3)=IUPD(3)+1 + MIXN(IVSO)=INTLIR + ENDDO + ELSE IF(CARLIR(1:4) .EQ. 'NEWM') THEN + DO IVSO=1,NVOUTO + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) + IF(ITYPLU .NE. 1) GO TO 111 + IF(INTLIR .LT. 0) CALL XABORT(NAMSBR// + > ': FINAL MIXTURE NUMBER MUST LARGER OR EQUAL TO 0 ') + IUPD(3)=IUPD(3)-1 + MIXN(IVSO)=INTLIR + ENDDO + ELSE IF(CARLIR(1:4) .EQ. 'ALBE') THEN + DO IVSO=1,6 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) + IF(ITYPLU .NE. 3) GO TO 111 + IF(REALIR .LT. 0.0) CALL XABORT(NAMSBR// + > ': FINAL ALBEDO MUST LARGER THAN 0.0 ') + IUPD(4)=IUPD(4)+1 + ALBEDN(IVSO)=REALIR + ENDDO + ELSE + CALL XABORT(NAMSBR//': LEGAL KEYWORD '//CARLIR) + ENDIF + GO TO 110 + 115 CONTINUE +*---- +* CHECK IF ALL THE SUCCESSIVE REGIONS CONSIDERED +*---- + IF(IUPD(1) .EQ. 0) THEN + NVOUTN=NVOUTO + ENDIF + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6000) NAMSBR + IF(IUPD(1) .GT. 0) THEN + WRITE(IOUT,6010) + WRITE(IOUT,6020) (IVSO,IMERGE(IVSO),IVSO=1,IUPD(1)) + ELSE IF(IUPD(1) .LT. 0) THEN + WRITE(IOUT,6015) + WRITE(IOUT,6025) (IMERGE(IVSO),IVSO=1,-IUPD(1)) + ENDIF + IF(IUPD(2) .LT. 0) THEN + WRITE(IOUT,6011) + WRITE(IOUT,6020) (IVSO,IMERGE(IVSO),IVSO=-1,IUPD(2),-1) + ENDIF + IF(IUPD(3) .LT. 0) THEN + WRITE(IOUT,6012) + WRITE(IOUT,6020) (IVSO,MIXN(IVSO),IVSO=1,-IUPD(3)) + ELSE IF(IUPD(3) .GT. 0) THEN + WRITE(IOUT,6013) + WRITE(IOUT,6020) (IVSO,MIXN(IVSO),IVSO=1,IUPD(3)) + ENDIF + IF(IUPD(4) .GT. 0) THEN + WRITE(IOUT,6014) + WRITE(IOUT,6021) (IVSO,ALBEDN(IVSO),IVSO=1,6) + ENDIF + WRITE(IOUT,6001) + ENDIF + IF(IUPD(1) .GT. 0) THEN + DO IVSN=1,NVOUTN + DO IVSO=1,NVOUTO + IF(IMERGE(IVSO) .EQ. IVSN) GO TO 205 + ENDDO + CALL XABORT(NAMSBR// + > ': NEW REGION NUMBERS NOT SUCCESSIVE') + 205 CONTINUE + ENDDO + ENDIF +*---- +* CHECK IF ALL THE SUCCESSIVE SURFACE CONSIDERED +*---- + IF(IUPD(2) .EQ. 0) THEN + NSOUTN=NSOUTO + ENDIF + IF(IUPD(2) .GT. 0) THEN + DO IVSN=-NSOUTN,-1 + DO IVSO=-NSOUTO,-1 + IF(IMERGE(IVSO) .EQ. IVSN) GO TO 215 + ENDDO + CALL XABORT(NAMSBR// + > ': NEW SURFACE NUMBERS NOT SUCCESSIVE') + 215 CONTINUE + ENDDO + ENDIF +*---- +* RETURN +*---- + RETURN +*---- +* FORMAT +*---- + 6000 FORMAT(' ------ OUTPUT FROM ROUTINE = ',A6) + 6001 FORMAT(' --------------------------------------') + 6010 FORMAT(' REGIONAL MERGE ',/ + > 3(' OLD NUNBER -> NEW NUMBER ')) + 6011 FORMAT(' SURFACE MERGE ',/ + > 3(' OLD NUNBER -> NEW NUMBER')) + 6012 FORMAT(' MIXTURE MODIFICATION ',/ + > 3(' OLD REGION -> MIXTURE ')) + 6013 FORMAT(' MIXTURE MODIFICATION ',/ + > 3(' NEW REGION -> MIXTURE ')) + 6014 FORMAT(' ALBEDO MODIFICATION ',/ + > 3(' SURFACE -> ALBEDO ')) + 6015 FORMAT(' REGION EXTRACTED FROM TRACK FILE ') + 6020 FORMAT(3(1X,I10,4X,I10)) + 6021 FORMAT(3(1X,I10,4X,F10.7)) + 6025 FORMAT(6(1X,I10)) + END diff --git a/Dragon/src/MRGLIN.f b/Dragon/src/MRGLIN.f new file mode 100644 index 0000000..52956df --- /dev/null +++ b/Dragon/src/MRGLIN.f @@ -0,0 +1,142 @@ +*DECK MRGLIN + SUBROUTINE MRGLIN(IPRINT,IFTRKO,NSOUTO,NVOUTO,IFTRKN, + > IMERGE,NDIM,IFMT,MXSUB,MXSEG) +* +*---------- +* +*Purpose: +* Merge volume surface information on track file. +* +*Copyright: +* Copyright (C) 1997 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPRINT print level. +* IFTRKO old tracking file. +* NSOUTO old number of surfaces. +* NVOUTO old number of regions. +* IFTRKN new tracking file. +* IFMT file format +* IMERGE merged position. +* IFMT track format: =0 short; =1 long. +* MXSUB maximum number of subtracks in a track. +* MXSEG maximum number of segments. +* +*---------- +* + IMPLICIT NONE + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='MRGLIN') +*---- +* ROUTINE PARAMETERS +*---- + INTEGER IPRINT,IFTRKO,NSOUTO,NVOUTO,IFTRKN, + > NDIM,IFMT,MXSUB,MXSEG + INTEGER IMERGE(-NSOUTO:NVOUTO) +*---- +* LOCAL VARIABLES +*---- + INTEGER ITRAK,NLINEO,NLINEN,ILINE, + > ISEG,IVSO,NSUB,IADD(4),IRA,ISU + DOUBLE PRECISION WEIGHT +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NRSEG,IANGL + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: PATH + DOUBLE PRECISION , ALLOCATABLE, DIMENSION(:,:) :: DADD +*---- +* LOOP OVER TRACKS +*---- + ALLOCATE(NRSEG(MXSEG),PATH(MXSEG)) + ALLOCATE(IANGL(MXSUB),DADD(NDIM,MXSUB)) + ITRAK=0 + 1000 CONTINUE + IF(IFMT.EQ.1) THEN + READ (IFTRKO,END=1010) NSUB,NLINEO,WEIGHT, + > (IANGL(IRA),IRA=1,NSUB), + > (NRSEG(ILINE),ILINE=1,NLINEO), + > (PATH(ILINE),ILINE=1,NLINEO), + > (IADD(IRA),IRA=1,4), + > ((DADD(IRA,ISU),IRA=1,NDIM),ISU=1,NSUB) + ELSE + READ (IFTRKO,END=1010) NSUB,NLINEO,WEIGHT, + > (IANGL(IRA),IRA=1,NSUB), + > (NRSEG(ILINE),ILINE=1,NLINEO), + > (PATH(ILINE),ILINE=1,NLINEO) + ENDIF +*---- +* SCAN NRSEG AND RESET TO NEW VOLUME AND SURFACE NUMBER +*---- + ITRAK=ITRAK+1 + IF(IPRINT.GE.1000) THEN + WRITE(IOUT,6000) ITRAK,NLINEO,WEIGHT,IANGL + WRITE(IOUT,6010) + > (NRSEG(ILINE),PATH(ILINE),ILINE=1,NLINEO) + ENDIF + DO 100 ILINE=1,NLINEO + DO 110 IVSO=-NSOUTO,NVOUTO + IF(NRSEG(ILINE) .EQ. IVSO ) THEN + NRSEG(ILINE) = IMERGE(IVSO) + GO TO 115 + ENDIF + 110 CONTINUE + 115 CONTINUE + 100 CONTINUE +*---- +* COMPRESS REGION OF SUCCESSIVE IDENTICAL REGION +* EXCEPT FOR SURFACES +*---- + NLINEN=1 + ISEG=NRSEG(NLINEN) + DO 120 ILINE=2,NLINEO + IF(NRSEG(ILINE) .EQ. ISEG .AND. + > ISEG .GT. 0 ) THEN + PATH(NLINEN)=PATH(NLINEN)+PATH(ILINE) + ELSE + NLINEN=NLINEN+1 + NRSEG(NLINEN)=NRSEG(ILINE) + PATH(NLINEN)=PATH(ILINE) + ISEG=NRSEG(NLINEN) + ENDIF + 120 CONTINUE + IF(IFMT.EQ.1) THEN + WRITE(IFTRKN) NSUB,NLINEN,WEIGHT, + > (IANGL(IRA),IRA=1,NSUB), + > (NRSEG(ILINE),ILINE=1,NLINEN), + > (PATH(ILINE),ILINE=1,NLINEN), + > (IADD(IRA),IRA=1,4), + > ((DADD(IRA,ISU),IRA=1,NDIM),ISU=1,NSUB) + ELSE + WRITE(IFTRKN) NSUB,NLINEN,WEIGHT, + > (IANGL(IRA),IRA=1,NSUB), + > (NRSEG(ILINE),ILINE=1,NLINEN), + > (PATH(ILINE),ILINE=1,NLINEN) + ENDIF + IF(IPRINT.GE.1000) THEN + WRITE(IOUT,6001) ITRAK,NLINEN,WEIGHT,IANGL + WRITE(IOUT,6010) + > (NRSEG(ILINE),PATH(ILINE),ILINE=1,NLINEN) + ENDIF + GO TO 1000 + 1010 CONTINUE + DEALLOCATE(DADD,IANGL) + DEALLOCATE(PATH,NRSEG) +*---- +* FORMAT +*---- + 6000 FORMAT(' INITIAL LINE = ',I10/ + > ' PARAMETERS = ',I10,F15.7,10I10) + 6001 FORMAT(' FINAL LINE = ',I10/ + > ' PARAMETERS = ',I10,F15.7,10I10) + 6010 FORMAT(1P,5(I10,E15.7)) + RETURN + END diff --git a/Dragon/src/MRGVOL.f b/Dragon/src/MRGVOL.f new file mode 100644 index 0000000..1ff1152 --- /dev/null +++ b/Dragon/src/MRGVOL.f @@ -0,0 +1,199 @@ +*DECK MRGVOL + SUBROUTINE MRGVOL(IUPD ,NSOUTO,NVOUTO,NSOUTN,NVOUTN,NUNN , + > IMERGE,MIXN ,MATO ,VOLO ,MATN ,VOLN , + > KEYN ,MATRTO,MATRTN,MAXMN ,NETVOL,NETSUR, + > MATRO ,KEYRO ,MATRN ,KEYRN ) +* +*---------- +* +*Purpose: +* Merge information on data structure. +* +*Copyright: +* Copyright (C) 1997 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IUPD type of merge required: +* IUPD(1) for region merge; +* IUPD(2) for surface merge; +* IUPD(3) for material merge; +* IUPD(4) for albedo merge. +* NSOUTO old number of surfaces. +* NVOUTO old number of regions. +* NSOUTN new number of surfaces. +* NVOUTN new number of regions. +* NUNN new number of unknowns. +* IMERGE merged position. +* MIXN new material for old regions. +* MATO old material per region. +* VOLO old volumes. +* MATRTO old B.C. conditions. +* NETVOL number of original regions. +* NETSUR number of original surfaces. +* MATRO old regional MATALB. +* KEYRO old regional KEYMRG. +* +*Parameters: output +* MATN new material per region. +* VOLN new volumes. +* KEYN new keyflux. +* MATRTN new B.C. conditions. +* MAXMN new maximum number of mixture. +* MATRN new regional MATALB. +* KEYRN new regional KEYMRG. +* +*---------- +* + IMPLICIT NONE + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='MRGVOL') +*---- +* ROUTINE PARAMETERS +*---- + INTEGER IUPD(4),NSOUTO,NVOUTO,NSOUTN,NVOUTN,NUNN, + > MAXMN,NETVOL,NETSUR + INTEGER IMERGE(-NSOUTO:NVOUTO),MIXN(NVOUTO), + > MATO(NVOUTO),MATN(NVOUTN),KEYN(NUNN), + > MATRTO(NSOUTO),MATRTN(NSOUTN), + > MATRO(-NETSUR:NETVOL),KEYRO(-NETSUR:NETVOL), + > MATRN(-NSOUTN:NVOUTN),KEYRN(-NSOUTN:NVOUTN) + REAL VOLO(NVOUTO),VOLN(NVOUTN) +*---- +* LOCAL VARIABLES +*---- + INTEGER IVSN,IVSO + DOUBLE PRECISION DVOL +*---- +* TRANSFER OLD KEYMRG AND MATALB TO NEW VECTOR +*---- + DO 90 IVSN=-NETSUR,NETVOL + KEYRN(IVSN)=KEYRO(IVSN) + MATRN(IVSN)=MATRO(IVSN) + 90 CONTINUE +*---- +* CHANGE ORIGINAL MATERIAL IF REQUESTED +*---- + IF(IUPD(3) .GT. 0) THEN + DO 100 IVSN=1,IUPD(3) + MATO(IVSN)=MIXN(IVSN) + DO 101 IVSO=1,NETVOL + IF(KEYRO(IVSO) .EQ. IVSN) THEN + MATRN(IVSO)=MATO(IVSN) + ENDIF + 101 CONTINUE + 100 CONTINUE + ENDIF + IF(IUPD(1) .GT. 0) THEN +*---- +* MERGE MATERIAL VOLUME AND KEY +*---- + DO 110 IVSN=1,NVOUTN + MATN(IVSN)=0 + DVOL=0.0D0 + DO 111 IVSO=1,NVOUTO + IF(IMERGE(IVSO) .EQ. IVSN) THEN + IF(MATN(IVSN) .EQ. 0) THEN + MATN(IVSN)=MATO(IVSO) + ELSE IF(MATN(IVSN) .NE. MATO(IVSO))THEN + WRITE(IOUT,6000) NAMSBR,IVSN,MATN(IVSN),IVSO,MATO(IVSO) + CALL XABORT(NAMSBR// + > ': MATERIAL INCOMPATIBLE FOR MERGE') + ENDIF + DVOL=DVOL+DBLE(VOLO(IVSO)) + ENDIF + 111 CONTINUE + VOLN(IVSN)=REAL(DVOL) + KEYN(IVSN)=IVSN + 110 CONTINUE + DO 112 IVSN=NVOUTN+1,NUNN + KEYN(IVSN)=0 + 112 CONTINUE + DO 113 IVSO=1,NVOUTO + DO 114 IVSN=1,NETVOL + IF(KEYRO(IVSN) .EQ. IVSO) THEN + KEYRN(IVSN)=IMERGE(IVSO) + ENDIF + 114 CONTINUE + 113 CONTINUE + ELSE +*---- +* NO MERGE TRANSFER INFORMATION TO NEW VECTORS +*---- + DO 120 IVSO=1,NVOUTO + MATN(IVSO)=MATO(IVSO) + VOLN(IVSO)=VOLO(IVSO) + 120 CONTINUE + ENDIF +*---- +* CHANGE FINAL MATERIAL IF REQUESTED +*---- + IF(IUPD(3) .LT. 0) THEN + DO 130 IVSN=1,-IUPD(3) + MATN(IVSN)=MIXN(IVSN) + DO 131 IVSO=1,NETVOL + IF(KEYRO(IVSO) .EQ. IVSN) THEN + MATRN(IVSO)=MIXN(IVSN) + ENDIF + 131 CONTINUE + 130 CONTINUE + ENDIF +*---- +* FIND NEW MAXIMUM NUMBER OF MIXTURE +*---- + MAXMN=0 + DO 140 IVSN=1,NVOUTN + MAXMN=MAX(MAXMN,MATN(IVSN)) + 140 CONTINUE +*---- +* MERGE REFLECTION/TRANSMISSION MATRIX +*---- + IF(IUPD(2).EQ.0) THEN + DO 150 IVSN=1,NSOUTO + MATRTN(IVSN)=MATRTO(IVSN) + 150 CONTINUE + ELSE + DO 160 IVSN=-NSOUTN,-1,1 + DO 161 IVSO=-NSOUTO,-1,1 + IF(IMERGE(IVSO).EQ.IVSN) THEN + MATRTN(-IVSN)=-IMERGE(-MATRTO(-IVSO)) + GO TO 165 + ENDIF + 161 CONTINUE + 165 CONTINUE + 160 CONTINUE +*---- +* TEST IF MATRTN IS COHERENT +*---- + DO 162 IVSN=1,NSOUTN + IVSO=MATRTN(IVSN) + IF(MATRTN(IVSO).NE.IVSN) THEN + CALL XABORT(NAMSBR// + > ': SURFACES BC INCOMPATIBLE FOR MERGE') + ENDIF + 162 CONTINUE + DO 163 IVSO=-1,-NSOUTO,-1 + DO 164 IVSN=-1,-NETSUR,-1 + IF(KEYRO(IVSN) .EQ. IVSO) THEN + KEYRN(IVSN)=IMERGE(IVSO) + ENDIF + 164 CONTINUE + 163 CONTINUE + ENDIF + RETURN +*---- +* ABORT FORMATS +*---- + 6000 FORMAT(' ------ ABORT IN ROUTINE ',A6,' ------'/ + > ' MATERIAL INCOMPATIBLE FOR MERGE '/ + > ' NEW REGION = ',I10,5X,'MATERIAL =',I10/ + > ' OLD REGION = ',I10,5X,'MATERIAL =',I10/ + > ' ----------------------------------------') + END diff --git a/Dragon/src/MRGVON.f b/Dragon/src/MRGVON.f new file mode 100644 index 0000000..587c1fa --- /dev/null +++ b/Dragon/src/MRGVON.f @@ -0,0 +1,208 @@ +*DECK MRGVON + SUBROUTINE MRGVON(IUPD ,NSOUTO,NVOUTO,NSOUTN,NVOUTN, + > NETSUR,NETVOL,NUNN ,MAXMN , + > IMERGE,MATO ,VOLO ,MATRTO, + > MATN ,VOLN ,KEYN ,MATRTN, + > NEXMAT,NEXKEY) +* +*---------- +* +*Purpose: +* Merge volume and surface for NXT geometry. +* +*Copyright: +* Copyright (C) 2011 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Harrisson +* +*Parameters: input +* IUPD type of merge required: +* IUPD(1) for region merge; +* IUPD(2) for surface merge; +* IUPD(3) for material merge; +* IUPD(4) for albedo merge. +* NSOUTO old number of surfaces. +* NVOUTO old number of regions. +* NSOUTN new number of surfaces. +* NVOUTN new number of regions. +* NETVOL number of original regions. +* NETSUR number of original surfaces. +* NUNN new number of unknowns. +* IMERGE merged position. +* MATO old material per region. +* VOLO old volumes. +* MATRTO old B.C. conditions. +* +*Parameters: input/output +* NEXMAT old/new NXTRecord MATALB for albedo number modification. +* NEXKEY old/new KEYMRG index for NXT. +* +*Parameters: output +* MAXMN new maximum number of mixture. +* MATN new material per region. +* VOLN new volumes. +* KEYN new keyflux. +* MATRTN new B.C. conditions. +* +*---------- +* + IMPLICIT NONE + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='MRGVON') +*---- +* ROUTINE PARAMETERS +*---- + INTEGER IUPD(4),NSOUTO,NVOUTO,NSOUTN,NVOUTN, + > NETSUR,NETVOL,NUNN,MAXMN + INTEGER IMERGE(-NSOUTO:NVOUTO), + > MATO(NVOUTO),MATRTO(NSOUTO), + > MATN(NVOUTN),KEYN(NUNN),MATRTN(NSOUTN), + > NEXMAT(-NETSUR:NETVOL), + > NEXKEY(-NETSUR:NETVOL) + REAL VOLO(NVOUTO),VOLN(NVOUTN) +*---- +* LOCAL VARIABLES +*---- + INTEGER IVSN,IVSO + DOUBLE PRECISION DVOL +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDABL +*---- +* CHANGE ORIGINAL AND/OR FINAL MATERIAL AND ORIGINAL ALBEDO IF REQUESTED +*---- + IF(IUPD(3) .GT. 0) THEN + WRITE(IOUT,6300) + ELSE IF(IUPD(3) .LT. 0) THEN + WRITE(IOUT,6400) + ELSE IF(IUPD(4) .GT. 0) THEN + WRITE(IOUT,6500) + ENDIF +*---- +* MERGE MATERIAL VOLUME AND KEY +*---- + IF(IUPD(1) .GT. 0) THEN + DO IVSN=1,NVOUTN + MATN(IVSN)=0 + DVOL=0.0D0 + DO IVSO=1,NVOUTO + IF(IMERGE(IVSO) .EQ. IVSN) THEN + IF(MATN(IVSN) .EQ. 0) THEN + MATN(IVSN)=MATO(IVSO) + ELSE IF(MATN(IVSN) .NE. MATO(IVSO))THEN + WRITE(IOUT,6000) NAMSBR,IVSN,MATN(IVSN),IVSO,MATO(IVSO) + CALL XABORT(NAMSBR// + > ': MATERIAL INCOMPATIBLE FOR MERGE') + ENDIF + DVOL=DVOL+DBLE(VOLO(IVSO)) + ENDIF + ENDDO + VOLN(IVSN)=REAL(DVOL) + KEYN(IVSN)=IVSN + ENDDO + DO IVSN=NVOUTN+1,NUNN + KEYN(IVSN)=0 + ENDDO + DO IVSN=1,NETVOL + DO IVSO=1,NVOUTO + IF(NEXKEY(IVSN) .EQ. IVSO) THEN + NEXKEY(IVSN)=IMERGE(IVSO) + GO TO 100 + ENDIF + ENDDO + 100 CONTINUE + ENDDO + ELSE +*---- +* NO MERGE TRANSFER INFORMATION TO NEW VECTORS +*---- + DO IVSO=1,NVOUTO + MATN(IVSO)=MATO(IVSO) + VOLN(IVSO)=VOLO(IVSO) + ENDDO + ENDIF +*---- +* FIND NEW MAXIMUM NUMBER OF MIXTURE +*---- + MAXMN=0 + DO IVSN=1,NVOUTN + MAXMN=MAX(MAXMN,MATN(IVSN)) + ENDDO +*---- +* MERGE REFLECTION/TRANSMISSION MATRIX +*---- + IF(IUPD(2).EQ.0) THEN + DO IVSN=1,NSOUTO + MATRTN(IVSN)=MATRTO(IVSN) + ENDDO + ELSE + DO IVSN=-NSOUTN,-1,1 + DO IVSO=-NSOUTO,-1,1 + IF(IMERGE(IVSO).EQ.IVSN) THEN + MATRTN(-IVSN)=-IMERGE(-MATRTO(-IVSO)) + GO TO 110 + ENDIF + ENDDO + 110 CONTINUE + ENDDO +*---- +* TEST IF MATRTN IS COHERENT +*---- + DO IVSN=1,NSOUTN + IVSO=MATRTN(IVSN) + IF(MATRTN(IVSO).NE.IVSN) THEN + CALL XABORT(NAMSBR// + > ': SURFACES BC INCOMPATIBLE FOR MERGE') + ENDIF + ENDDO + DO IVSN=-1,-NETSUR,-1 + DO IVSO=-1,-NSOUTO,-1 + IF(NEXKEY(IVSN) .EQ. IVSO) THEN + NEXKEY(IVSN)=IMERGE(IVSO) + GO TO 120 + ENDIF + ENDDO + 120 CONTINUE + ENDDO +*---- +* MERGING SURFACES WITH DIFFERENT ALBEDO NUMBER +* USEFUL TO ACHIEVE SYME SYMMETRY +*---- + ALLOCATE(IDABL(NSOUTN)) + IDABL(:NSOUTN)=0 + DO IVSN=1,NSOUTN + DO IVSO=1,NETSUR + IF (IMERGE(-IVSO) .EQ. -IVSN) THEN + IF (IDABL(IVSN) .EQ. 0) THEN + IDABL(IVSN)=NEXMAT(-IVSO) + ELSE + NEXMAT(-IVSO)=IDABL(IVSN) + ENDIF + ENDIF + ENDDO + ENDDO + DEALLOCATE(IDABL) + ENDIF + RETURN +*---- +* FORMATS +*---- + 6000 FORMAT(' ------ ABORT IN ROUTINE ',A6,' ------'/ + > ' MATERIAL INCOMPATIBLE FOR MERGE '/ + > ' NEW REGION = ',I10,5X,'MATERIAL =',I10/ + > ' OLD REGION = ',I10,5X,'MATERIAL =',I10/ + > ' ----------------------------------------') + 6300 FORMAT(' ***** WARNING: OPTION OLDM IS INVALID FOR GEOMETRIES'/ + > ' TRACKED WITH NXT:. ORIGINAL MIXTURES ARE USED') + 6400 FORMAT(' ***** WARNING: OPTION NEWM IS INVALID FOR GEOMETRIES'/ + > ' TRACKED WITH NXT:. ORIGINAL MIXTURES ARE USED') + 6500 FORMAT(' ***** WARNING: OPTION ALBE IS INVALID FOR GEOMETRIES'/ + > ' TRACKED WITH NXT:. ORIGINAL ALBEDO ARE USED') + END diff --git a/Dragon/src/MRGVST.f b/Dragon/src/MRGVST.f new file mode 100644 index 0000000..42cda0a --- /dev/null +++ b/Dragon/src/MRGVST.f @@ -0,0 +1,227 @@ +*DECK MRGVST + SUBROUTINE MRGVST(IFTRKO,IFTRKN,IPRINT,IUPD ,NDIM ,NALBG,NANGL, + > NSOUTO,NVOUTO,NSOUTN,NVOUTN,IMERGE,MIXN) +* +*---------- +* +*Purpose: +* Merge volume and surface on track file and save. +* +*Copyright: +* Copyright (C) 2011 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IFTRKO old tracking file. +* IFTRKN new tracking file. +* IPRINT print level. +* IUPD type of merge required: +* IUPD(1) for region merge; +* IUPD(2) for surface merge; +* IUPD(3) for material merge; +* IUPD(4) for albedo merge. +* NDIM number of dimensions. +* NALBG number of albedos. +* NANGL number of track directions. +* NSOUTO old number of surfaces. +* NVOUTO old number of regions. +* NSOUTN new number of surfaces. +* NVOUTN new number of regions. +* IMERGE merging index. +* MIXN new albedos and material for old regions. +* +*---------- +* + IMPLICIT NONE + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='MRGVST') +*---- +* ROUTINE PARAMETERS +*---- + INTEGER IFTRKO,IFTRKN + INTEGER IPRINT,IUPD(4),NDIM,NALBG,NANGL, + > NSOUTO,NVOUTO,NSOUTN,NVOUTN + INTEGER IMERGE(-NSOUTO:NVOUTO),MIXN(NVOUTO) +*---- +* LOCAL VARIABLES +*---- + INTEGER IVSN,IVSO,IVST,ITC + DOUBLE PRECISION DVOL +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MATO,MATN,ICODE + REAL, ALLOCATABLE, DIMENSION(:) :: VOLO,VOLN + REAL, ALLOCATABLE, DIMENSION(:) :: ALBD + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: ANGLES,DENSTY +*---- +* Processing starts: +* print routine openning output header if required +*---- + IF(IPRINT.GE.10) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF +*---- +* Read old Volume/surface and albedo/material information +* and print if required +*---- + ALLOCATE(MATO(-NSOUTO:NVOUTO),VOLO(-NSOUTO:NVOUTO)) + ALLOCATE(MATN(-NSOUTN:NVOUTN),VOLN(-NSOUTN:NVOUTN)) + READ(IFTRKO) (VOLO(ITC),ITC=-NSOUTO,NVOUTO) + READ(IFTRKO) (MATO(ITC),ITC=-NSOUTO,NVOUTO) + IF(IPRINT.GE.10) THEN + WRITE(IOUT,6010) + WRITE(IOUT,6020) (MATO(IVSO),VOLO(IVSO),IVSO=-1,-NSOUTO,-1) + ENDIF +*---- +* VERIFY IF BOUNDARY CONDITIONS ARE ADEQUATE FOR MERGE VECTOR +*---- + IF(IUPD(2). LT. 0) THEN + DO 100 IVSN=-NSOUTN,-1 + MATN(IVSN)=0 + DVOL=0.0D0 + DO 101 IVSO=-NSOUTO,-1 + IF(IMERGE(IVSO) .EQ. IVSN) THEN + IF(MATN(IVSN) .EQ. 0) THEN + MATN(IVSN)=MATO(IVSO) + ELSE IF(MATN(IVSN) .NE. MATO(IVSO))THEN + WRITE(IOUT,6100) NAMSBR,IVSN,MATN(IVSN),IVSO,MATO(IVSO) + WRITE(IOUT,6101) + WRITE(IOUT,6102) (IVST,MATO(IVST),IVST=-NSOUTO,-1) + CALL XABORT(NAMSBR// + > ': BOUNDARY CONDITIONS INCOMPATIBLE FOR MERGE') + ENDIF + DVOL=DVOL+DBLE(VOLO(IVSO)) + ENDIF + 101 CONTINUE + VOLN(IVSN)=REAL(DVOL) + 100 CONTINUE + ELSE + DO 110 IVSO=-NSOUTO,-1 + MATN(IVSO)=MATO(IVSO) + VOLN(IVSO)=VOLO(IVSO) + 110 CONTINUE + ENDIF + IF(IPRINT.GE.10) THEN + WRITE(IOUT,6011) + WRITE(IOUT,6020) (MATN(IVSN),VOLN(IVSN),IVSN=-1,-NSOUTN,-1) + WRITE(IOUT,6012) + WRITE(IOUT,6020) (MATO(IVSO),VOLO(IVSO),IVSO=1,NVOUTO) + ENDIF +*---- +* CHANGE ORIGINAL MATERIAL IF REQUESTED +*---- + IF(IUPD(3) .GT. 0) THEN + DO 120 IVSO=1,IUPD(3) + MATO(IVSO)=MIXN(IVSO) + 120 CONTINUE + ENDIF +*---- +* VERIFY IF MATERIALS ARE ADEQUATE FOR MERGE VECTOR +*---- + IF(IUPD(1) .GT. 0) THEN + MATN(0)=0 + VOLN(0)=0.0 + DO 130 IVSN=1,NVOUTN + MATN(IVSN)=0 + DVOL=0.0D0 + DO 131 IVSO=1,NVOUTO + IF(IMERGE(IVSO) .EQ. IVSN) THEN + IF(MATN(IVSN) .EQ. 0) THEN + MATN(IVSN)=MATO(IVSO) + ELSE IF(MATN(IVSN) .NE. MATO(IVSO))THEN + WRITE(IOUT,6200) NAMSBR,IVSN,MATN(IVSN),IVSO,MATO(IVSO) + WRITE(IOUT,6201) + WRITE(IOUT,6202) (IVST,MATO(IVST),IVST=1,NVOUTO) + CALL XABORT(NAMSBR// + > ': MATERIALS INCOMPATIBLE FOR MERGE') + ENDIF + DVOL=DVOL+DBLE(VOLO(IVSO)) + ENDIF + 131 CONTINUE + VOLN(IVSN)=REAL(DVOL) + 130 CONTINUE + ELSE + DO 140 IVSO=1,NVOUTO + MATN(IVSO)=MATO(IVSO) + VOLN(IVSO)=VOLO(IVSO) + 140 CONTINUE + ENDIF +*---- +* CHANGE FINAL MATERIAL IF REQUESTED +*---- + IF(IUPD(3) .LT. 0) THEN + DO 150 IVSN=1,-IUPD(3) + MATN(IVSN)=MIXN(IVSN) + 150 CONTINUE + ENDIF + IF(IPRINT.GE.10) THEN + WRITE(IOUT,6013) + WRITE(IOUT,6020) (MATN(IVSN),VOLN(IVSN),IVSN=1,NVOUTN) + ENDIF +*---- +* Save new Volume/surface and albedo/material information +*---- + WRITE(IFTRKN) (VOLN(ITC),ITC=-NSOUTN,NVOUTN) + WRITE(IFTRKN) (MATN(ITC),ITC=-NSOUTN,NVOUTN) +*---- +* Read and save BC and tracking directions and density +*---- + ALLOCATE(ICODE(NALBG),ALBD(NALBG),ANGLES(NDIM*NANGL), + > DENSTY(NANGL)) + READ(IFTRKO) (ICODE(ITC),ITC=1,NALBG) + READ(IFTRKO) (ALBD(ITC),ITC=1,NALBG) + READ(IFTRKO) (ANGLES(ITC),ITC=1,NDIM*NANGL) + READ(IFTRKO) (DENSTY(ITC),ITC=1,NANGL) + WRITE(IFTRKN) (ICODE(ITC),ITC=1,NALBG) + WRITE(IFTRKN) (ALBD(ITC),ITC=1,NALBG) + WRITE(IFTRKN) (ANGLES(ITC),ITC=1,NDIM*NANGL) + WRITE(IFTRKN) (DENSTY(ITC),ITC=1,NANGL) + DEALLOCATE(DENSTY,ANGLES,ALBD,ICODE) + DEALLOCATE(MATN,VOLN) + DEALLOCATE(VOLO,MATO) +*---- +* Print output header if required +* and return +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* PRINT FORMATS +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(' Initial surfaces and albedos') + 6011 FORMAT(' Final surfaces and albedos') + 6012 FORMAT(' Initial volumes and materials') + 6013 FORMAT(' Final volumes and materials') + 6020 FORMAT(1P,5(I10,D15.7)) +*---- +* ABORT FORMATS +*---- + 6100 FORMAT(' ------ ABORT IN ROUTINE ',A6,' ------'/ + > ' BOUNDARY CONDITIONS INCOMPATIBLE FOR MERGE '/ + > ' NEW REGION = ',I10,5X,'SURFACE =',I10/ + > ' OLD REGION = ',I10,5X,'SURFACE =',I10/ + > ' ----------------------------------------') + 6101 FORMAT(' SURFACE DESCRIPTION '/ + > 4(' SURFACE -> ALBEDO')) + 6102 FORMAT(4(1X,I7,6X,I6)) + 6200 FORMAT(' ------ ABORT IN ROUTINE ',A6,' ------'/ + > ' MATERIAL INCOMPATIBLE FOR MERGE '/ + > ' NEW REGION = ',I10,5X,'MATERIAL =',I10/ + > ' OLD REGION = ',I10,5X,'MATERIAL =',I10/ + > ' ----------------------------------------') + 6201 FORMAT(' REGION DESCRIPTION '/ + > 4(' REGION -> MATERIAL')) + 6202 FORMAT(4(1X,I6,5X,I8)) + END diff --git a/Dragon/src/MRGXTC.f b/Dragon/src/MRGXTC.f new file mode 100644 index 0000000..a3161f3 --- /dev/null +++ b/Dragon/src/MRGXTC.f @@ -0,0 +1,170 @@ +*DECK MRGXTC + SUBROUTINE MRGXTC(IFTRKO,IFTRKN,IFTRKE,IPRINT,IUPD,NDIM, + > NALBG ,NANGL ,NSOUTO,NVOUTO,MXSEG,IMERGE) +* +*---------- +* +*Purpose: +* Subdivide tracking file into 2 sets. +* +*Copyright: +* Copyright (C) 1997 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IFTRKO old tracking file. +* IFTRKN new part r (residual) tracking file. +* IFTRKE new part e (extracted) tracking file. +* IPRINT print level. +* IUPD type of merge required: +* IUPD(1) for region merge; +* IUPD(2) for surface merge; +* IUPD(3) for material merge; +* IUPD(4) for albedo merge. +* NDIM number of dimensions. +* NALBG number of albedos. +* NANGL number of track directions. +* NSOUTO old number of surfaces. +* NVOUTO old number of regions. +* MXSEG maximum number of segments. +* IMERGE merged position. +* +*---------- +* + IMPLICIT NONE + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='MRGXTC') +*---- +* ROUTINE PARAMETERS +*---- + INTEGER IFTRKO,IFTRKN,IFTRKE + INTEGER IPRINT,IUPD(4),NDIM, + > NALBG,NANGL,NSOUTO,NVOUTO,MXSEG + INTEGER IMERGE(-NSOUTO:NVOUTO) +*---- +* LOCAL VARIABLES +*---- + INTEGER IVSO,ITRAK,IANG,ILINE,NLINE,IEXT + REAL WEIGHT +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MATO,ICODE,NRSEG + REAL, ALLOCATABLE, DIMENSION(:) :: VOLO,ALBD + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: ANGLES,DENSTY + REAL, ALLOCATABLE, DIMENSION(:) :: PATH +*---- +* Processing starts: +* print routine openning output header if required +*---- + ALLOCATE(MATO(-NSOUTO:NVOUTO),VOLO(-NSOUTO:NVOUTO)) + IF(IPRINT.GE.10) THEN + WRITE(IOUT,6000) + ENDIF +*---- +* Read old Volume/surface and albedo/material information +* and print if required +*---- + READ(IFTRKO) (VOLO(IVSO),IVSO=-NSOUTO,NVOUTO) + READ(IFTRKO) (MATO(IVSO),IVSO=-NSOUTO,NVOUTO) + IF(IPRINT.GE.10) THEN + WRITE(IOUT,6010) + WRITE(IOUT,6011) (MATO(IVSO),VOLO(IVSO),IVSO=-NSOUTO,NVOUTO) + ENDIF +*---- +* Save new Volume/surface and albedo/material information +*---- + WRITE(IFTRKN) (VOLO(IVSO),IVSO=-NSOUTO,NVOUTO) + WRITE(IFTRKE) (VOLO(IVSO),IVSO=-NSOUTO,NVOUTO) + WRITE(IFTRKN) (MATO(IVSO),IVSO=-NSOUTO,NVOUTO) + WRITE(IFTRKE) (MATO(IVSO),IVSO=-NSOUTO,NVOUTO) +*---- +* Read and save BC and tracking directions and density +*---- + ALLOCATE(ICODE(NALBG),ALBD(NALBG),ANGLES(NDIM*NANGL), + > DENSTY(NANGL)) + READ(IFTRKO) (ICODE(IVSO),IVSO=1,NALBG) + READ(IFTRKO) (ALBD(IVSO),IVSO=1,NALBG) + READ(IFTRKO) (ANGLES(IVSO),IVSO=1,NDIM*NANGL) + READ(IFTRKO) (DENSTY(IVSO),IVSO=1,NANGL) + WRITE(IFTRKN) (ICODE(IVSO),IVSO=1,NALBG) + WRITE(IFTRKN) (ALBD(IVSO),IVSO=1,NALBG) + WRITE(IFTRKN) (ANGLES(IVSO),IVSO=1,NDIM*NANGL) + WRITE(IFTRKN) (DENSTY(IVSO),IVSO=1,NANGL) + WRITE(IFTRKE) (ICODE(IVSO),IVSO=1,NALBG) + WRITE(IFTRKE) (ALBD(IVSO),IVSO=1,NALBG) + WRITE(IFTRKE) (ANGLES(IVSO),IVSO=1,NDIM*NANGL) + WRITE(IFTRKE) (DENSTY(IVSO),IVSO=1,NANGL) + DEALLOCATE(DENSTY,ANGLES,ALBD,ICODE) +*---- +* select track for tracking files + ALLOCATE(NRSEG(MXSEG),PATH(MXSEG)) + ITRAK=0 + 1000 CONTINUE + READ (IFTRKO,END=1010) IANG,NLINE,WEIGHT, + > (NRSEG(ILINE),ILINE=1,NLINE), + > (PATH(ILINE),ILINE=1,NLINE) +C---- +C SCAN NRSEG AND RESET TO NEW VOLUME AND SURFACE NUMBER +C---- + ITRAK=ITRAK+1 + IEXT=1 + DO ILINE=1,NLINE + DO IVSO=1,-IUPD(1) + IF(NRSEG(ILINE) .EQ. IMERGE(IVSO)) GO TO 1005 + ENDDO + ENDDO + IEXT=0 + 1005 CONTINUE + IF(IEXT .EQ. 1) THEN + WRITE(IFTRKE) IANG,NLINE,WEIGHT, + > (NRSEG(ILINE),ILINE=1,NLINE), + > (PATH(ILINE),ILINE=1,NLINE) + IF(IPRINT.GE.1000) THEN + WRITE(IOUT,6020) ITRAK,IANG,NLINE,WEIGHT + WRITE(IOUT,6025) + > (NRSEG(ILINE),PATH(ILINE),ILINE=1,NLINE) + ENDIF + ELSE + WRITE(IFTRKN) IANG,NLINE,WEIGHT, + > (NRSEG(ILINE),ILINE=1,NLINE), + > (PATH(ILINE),ILINE=1,NLINE) + IF(IPRINT.GE.1000) THEN + WRITE(IOUT,6021) ITRAK,IANG,NLINE,WEIGHT + WRITE(IOUT,6025) + > (NRSEG(ILINE),PATH(ILINE),ILINE=1,NLINE) + ENDIF + ENDIF + GO TO 1000 + 1010 CONTINUE + DEALLOCATE(PATH,NRSEG) + DEALLOCATE(VOLO,MATO) +*---- +* Print output header if required +* and return +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* PRINT FORMATS +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(' Region description '/ + > 4(' Region -> Volume')) + 6011 FORMAT(4(1X,I6,5X,F20.8)) + 6020 FORMAT(' Line = ',I10,' is extracted '/ + > ' Parameter = ',2I10,1P,E15.7) + 6021 FORMAT(' Line = ',I10,' is kept '/ + > ' Parameter = ',2I10,1P,E15.7) + 6025 FORMAT(1P,5(I10,E15.7)) + END diff --git a/Dragon/src/MUSA.f90 b/Dragon/src/MUSA.f90 new file mode 100644 index 0000000..aa650dd --- /dev/null +++ b/Dragon/src/MUSA.f90 @@ -0,0 +1,287 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Calculation of cellwise scattering-reduced collision, escape and +! transmission probabilities for the current iteration method in the +! multicell surfacic approximation. +! +!Copyright: +! Copyright (C) 2025 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version +! +!Author(s): A. Hebert +! +!Parameters: input +! IPSYS pointer to the system matrices. +! IPTRK pointer to the tracking (L_TRACK signature). +! IFTRAK tracking file unit. +! IMPX print flag (equal to zero for no print). +! NREG total number of merged regions for which specific values +! of the neutron flux and reactions rates are required. +! NBMIX number of mixtures. +! SIGT0 total macroscopic cross sections ordered by mixture. +! SIGW0 within-group scattering macroscopic cross section ordered +! by mixture. +! NBATCH number of tracks dispached in eack OpenMP core. +! TITREC title. +! NALBP number of multigroup physical albedos. +! ALBP multigroup physical albedos. +! +!----------------------------------------------------------------------- +! +SUBROUTINE MUSA(IPSYS,IPTRK,IFTRAK,IMPX,NREG,NBMIX,SIGT0,SIGW0,NBATCH, & + & TITREC,NALBP,ALBP) + USE GANLIB + !---- + ! SUBROUTINE ARGUMENTS + !---- + TYPE(C_PTR) IPSYS,IPTRK + INTEGER IFTRAK,IMPX,NREG,NBMIX,NBATCH,NALBP + REAL SIGT0(0:NBMIX),SIGW0(0:NBMIX),ALBP(NALBP) + CHARACTER TITREC*72 + !---- + ! LOCAL VARIABLES + !---- + PARAMETER (EPS1=1.0E-4,NSTATE=40) + TYPE(C_PTR) JPTRK,KPTRK + INTEGER ISTATT(NSTATE),NNPSYS(1) + CHARACTER TITRE2*72 + logical LSKIP + !---- + ! ALLOCATABLE ARRAYS + !---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MATALB,NMC_NODE,NMC_SURF,MAT2,IGEN,INUM + REAL, ALLOCATABLE, DIMENSION(:) :: SIGT2,SIGW2,WORK + REAL, ALLOCATABLE, DIMENSION(:,:) :: VOLSUR + REAL, POINTER, DIMENSION(:) :: PSSW,PSJW,PISW,PIJW + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: DPROB,DPROBX + TYPE(C_PTR) :: PSSW_PTR,PSJW_PTR,PISW_PTR,PIJW_PTR + ! + IND(I,J) = MAX(I+J3+1,J+J3+1)*(MAX(I+J3+1,J+J3+1)-1)/2 & + & + MIN(I+J3+1,J+J3+1) + ! + WPR(I,J)= REAL(DPROB( IND(I,J),1 ) / DPROB( IND(I,0),1 )) + !---- + ! BICKLEY FLAG + !---- + SAVE IBICKL + DATA IBICKL/0/ + !---- + ! RECOVER BICKLEY TABLES + !---- + IF(IBICKL.EQ.0) THEN + CALL XDRTA2 + IBICKL=1 + ENDIF + !---- + ! RECOVER SALT SPECIFIC PARAMETERS + !---- + REWIND IFTRAK + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATT) + IF(NREG.NE.ISTATT(1)) THEN + CALL XABORT('MUSA: STATE VECTOR HAS INVALID # OF ZONES.') + ENDIF + NMACRO=ISTATT(24) ! NGEN + NMCEL=NMACRO + NMERGE=NMACRO + NGEN=NMACRO + ALLOCATE(IGEN(NMERGE),INUM(NMCEL)) + DO IK=1,NMERGE + IGEN(IK)=IK + ENDDO + DO IK=1,NMCEL + INUM(IK)=IK + ENDDO + IF(NMACRO.EQ.0) CALL XABORT('MUSA: MUST MODULE TRACKING IS MANDATORY.') + ALLOCATE(NMC_NODE(NMACRO+1),NMC_SURF(NMACRO+1)) + JPTRK=LCMGID(IPTRK,'MACRO-TRACK') + CALL LCMGET(IPTRK,'NMC_NODE',NMC_NODE) + CALL LCMGET(IPTRK,'NMC_SURF',NMC_SURF) + NMIX=NMC_SURF(NMACRO+1) + NIFR=NMC_SURF(NMACRO+1) + !---- + ! LOOP OVER MACRO GEOMETRIES AND COMPUTE PIJ MATRICES USING EXCELP + !---- + J1=0 + NMIX=0 + NPIJ=0 + NPIS=0 + NPSS=0 + DO IMACRO=1,NMACRO + J2=NMC_NODE(IMACRO+1)-NMC_NODE(IMACRO) + J3=NMC_SURF(IMACRO+1)-NMC_SURF(IMACRO) + J1=J1+J2 + NMIX=NMIX+J3 + NPIJ=NPIJ+J2*J2 + NPIS=NPIS+J2*J3 + NPSS=NPSS+J3*J3 + ENDDO + IF(J1.NE.NREG) CALL XABORT('MUSA: INVALID NREG.') + IF(NMIX.NE.NMC_SURF(NMACRO+1)) CALL XABORT('MUSA: INVALID NMIX.') + PIJW_PTR=LCMARA(NPIJ) + PISW_PTR=LCMARA(NPIS) + PSJW_PTR=LCMARA(NPIS) + PSSW_PTR=LCMARA(NPSS) + CALL C_F_POINTER(PIJW_PTR,PIJW,(/ NPIJ /)) + CALL C_F_POINTER(PISW_PTR,PISW,(/ NPIS /)) + CALL C_F_POINTER(PSJW_PTR,PSJW,(/ NPIS /)) + CALL C_F_POINTER(PSSW_PTR,PSSW,(/ NPSS /)) + J1=0 + IPIJ=0 + IPIS=0 + IPSS=0 + DO IMACRO=1,NMACRO + J2=NMC_NODE(IMACRO+1)-NMC_NODE(IMACRO) + J3=NMC_SURF(IMACRO+1)-NMC_SURF(IMACRO) + N2PRO=(J2+J3+1)**2 + WRITE(TITRE2,'(A,9H -- MACRO,I5.5)') TRIM(TITREC),IMACRO + KPTRK=LCMGIL(JPTRK,IMACRO) + KNORM=4 ! use HELIOS-type normalization + NNPSYS(1)=1 + ALLOCATE(MAT2(J2),SIGT2(J2),SIGW2(J2)) + ALLOCATE(MATALB(-J3:J2),VOLSUR(-J3:J2,1),DPROB(N2PRO,1),DPROBX(N2PRO,1)) + CALL LCMGET(KPTRK,'MATCOD',MAT2) + CALL EXCELP(KPTRK,IFTRAK,IMPX,J3,J2,NBMIX,MAT2,KNORM,SIGT0,1,N2PRO, & + & 1,NNPSYS(1),NBATCH,TITRE2,NALBP,ALBP,MATALB,VOLSUR,DPROB,DPROBX) + !---- + ! CHECK IF SCATTERING REDUCTION IS REQUIRED + !---- + DO I=1,J2 + SIGT2(I)=SIGT0(MAT2(I)) ! sigt by node + SIGW2(I)=SIGW0(MAT2(I)) ! sigw by node + ENDDO + LSKIP=.TRUE. + DO I=1,J2 + LSKIP=LSKIP.AND.(SIGW2(I).EQ.0.0) + ENDDO + !---- + ! SCATTERING REDUCTION IF LSKIP=.FALSE. + !---- + IF(LSKIP) THEN + ! DO NOT PERFORM SCATTERING REDUCTION. + DO I=1,J2 + DO J=1,J2 + IF(SIGT2(J).EQ.0.0) THEN + PIJW(IPIJ+(J-1)*J2+I)=WPR(I,J) + ELSE + PIJW(IPIJ+(J-1)*J2+I)=WPR(I,J)/SIGT2(J) + ENDIF + ENDDO + ENDDO + DO I=1,J2 + DO JC=1,J3 + PISW(IPIS+(JC-1)*J2+I)=WPR(I,-JC) + IF(SIGT2(I).EQ.0.0) THEN + PSJW(IPIS+(I-1)*J3+JC)=WPR(-JC,I) + ELSE + PSJW(IPIS+(I-1)*J3+JC)=WPR(-JC,I)/SIGT2(I) + ENDIF + ENDDO + ENDDO + DO IC=1,J3 + DO JC=1,J3 + PSSW(IPSS+(JC-1)*J3+IC)=WPR(-IC,-JC) + ENDDO + ENDDO + ELSE + ! COMPUTE THE SCATTERING-REDUCED COLLISION AND ESCAPE MATRICES. + DO I=1,J2 + DO J=1,J2 + IF(SIGT2(J).EQ.0.0) THEN + PIJW(IPIJ+(J-1)*J2+I)=0.0 + ELSE + PIJW(IPIJ+(J-1)*J2+I)=-WPR(I,J)*SIGW2(J)/SIGT2(J) + ENDIF + ENDDO + PIJW(IPIJ+(I-1)*J2+I)=1.0+PIJW(IPIJ+(I-1)*J2+I) + ENDDO + CALL ALINV(J2,PIJW(IPIJ+1),J2,IER) + IF(IER.NE.0) CALL XABORT('MUSA: SINGULAR MATRIX.') + ALLOCATE(WORK(J2)) + DO I=1,J2 + DO K=1,J2 + WORK(K)=PIJW(IPIJ+(K-1)*J2+I) + ENDDO + DO J=1,J2 + WGAR=0.0 + DO K=1,J2 + IF(SIGT2(J).EQ.0.0) THEN + WGAR=WGAR+WORK(K)*WPR(K,J) + ELSE + WGAR=WGAR+WORK(K)*WPR(K,J)/SIGT2(J) + ENDIF + ENDDO + PIJW(IPIJ+(J-1)*J2+I)=WGAR + ENDDO + DO JC=1,J3 + WGAR=0.0 + DO K=1,J2 + WGAR=WGAR+WORK(K)*WPR(K,-JC) + ENDDO + PISW(IPIS+(JC-1)*J2+I)=WGAR + ENDDO + ENDDO + DEALLOCATE(WORK) + ! + ! COMPUTE THE SCATTERING-REDUCED COLLISION PROBABILITY MATRIX + ! FOR INCOMING NEUTRONS. + DO IC=1,J3 + DO J=1,J2 + IF(SIGT2(J).EQ.0.0) THEN + WGAR=WPR(-IC,J) + ELSE + WGAR=WPR(-IC,J)/SIGT2(J) + ENDIF + DO K=1,J2 + IF(SIGT2(K).NE.0.0) THEN + WGAR=WGAR+WPR(-IC,K)*PIJW(IPIJ+(J-1)*J2+K)*SIGW2(K)/SIGT2(K) + ENDIF + ENDDO + PSJW(IPIS+(J-1)*J3+IC)=WGAR + ENDDO + ENDDO + ! + ! COMPUTE THE SCATTERING-REDUCED TRANSMISSION PROBABILITY MATRIX. + DO IC=1,J3 + DO JC=1,J3 + WGAR=WPR(-IC,-JC) + DO K=1,J2 + IF(SIGT2(K).NE.0.0) THEN + WGAR=WGAR+WPR(-IC,K)*PISW(IPIS+(JC-1)*J2+K)*SIGW2(K)/SIGT2(K) + ENDIF + ENDDO + PSSW(IPSS+(JC-1)*J3+IC)=WGAR + ENDDO + ENDDO + ENDIF + DEALLOCATE(DPROBX,DPROB,VOLSUR,MATALB) + IF(IMPX.GE.8) THEN + IF(LSKIP) THEN + IN=1 + ELSE + IN=2 + ENDIF + CALL SYBPRX(IN,J3,J2,IMACRO,SIGT2,SIGW2,PIJW(IPIJ+1),PISW(IPIS+1), & + & PSJW(IPIS+1),PSSW(IPSS+1)) + ENDIF + DEALLOCATE(SIGW2,SIGT2,MAT2) + J1=J1+J2 + IPIJ=IPIJ+J2*J2 + IPIS=IPIS+J2*J3 + IPSS=IPSS+J3*J3 + ENDDO + ! end of SYB004 equivalent + CALL LCMPPD(IPSYS,'PSSW$SYBIL',NPSS,2,PSSW_PTR) + CALL LCMPPD(IPSYS,'PSJW$SYBIL',NPIS,2,PSJW_PTR) + CALL LCMPPD(IPSYS,'PISW$SYBIL',NPIS,2,PISW_PTR) + CALL LCMPPD(IPSYS,'PIJW$SYBIL',NPIJ,2,PIJW_PTR) + IF(IMPX.GT.1) THEN + WRITE(6,'(/31H MUSA: PIJ INFORMATION IN GROUP)') + CALL LCMLIB(IPSYS) + ENDIF + RETURN +END SUBROUTINE MUSA diff --git a/Dragon/src/MUSACG.f90 b/Dragon/src/MUSACG.f90 new file mode 100644 index 0000000..4f68a52 --- /dev/null +++ b/Dragon/src/MUSACG.f90 @@ -0,0 +1,723 @@ +! +!--------------------------------------------------------------------- +! +!Purpose: +! To extract a macro geometry and construct its geometry basic +! information. +! +!Copyright: +! Copyright (C) 2025 Ecole Polytechnique de Montreal. +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version +! +!Author(s): +! A. Hebert +! +!Parameters: input +! ITRACK pointer to the tracking in IMACROth macro geometry. +! IFTRK pointer to the TRACKING file in creation mode. +! IPRINT print level. +! IMACRO macro geometry index. +! NBSLIN maximum number of segments in a single tracking line. +! RCUTOF minimum distance between two surfacic elements. +! GG geometry basic information. +! +!Parameters: output +! LGINF leakage flag (=.true. if no leakage). +! NBNODE_MACRO number of nodes in macro IMACRO. +! NSURF_MACRO number of boundary surfaces in macro IMACRO. +! GG geometry basic information. +! +!--------------------------------------------------------------------- +! +SUBROUTINE MUSACG(ITRACK,IFTRK,IPRINT,IMACRO,NBSLIN,RCUTOF,GG,LGINF,NBNODE_MACRO,NSURF_MACRO) + USE GANLIB + USE PRECISION_AND_KINDS, ONLY : PDB, PI + USE SAL_GEOMETRY_TYPES, ONLY : T_G_BASIC,NIPAR,NRPAR,G_BC_TYPE,ISPEC,TYPGEO,NBFOLD,ALLSUR + USE SAL_GEOMETRY_MOD, ONLY : SAL130_2,SAL130_4,SAL130_6,SAL130_8,SAL130_10,SAL131_2, & + & SAL140,SAL160_2,SAL170,SALFOLD_0 + USE SAL_NUMERIC_MOD, ONLY : SAL141,FINDLC,DET_ROSETTA + USE SAL_TRACKING_TYPES, ONLY : PRTIND,NIPART,NRPART,EPS1 + !---- + ! Subroutine arguments + !---- + TYPE(C_PTR) ITRACK + INTEGER IFTRK,IPRINT,IMACRO + REAL(PDB) RCUTOF + LOGICAL LGINF,LGBC + TYPE(T_G_BASIC) :: GG + !---- + ! Local variables + !---- + INTEGER, PARAMETER :: NSTATE=40 + INTEGER, PARAMETER :: FOUT=6 + INTEGER, PARAMETER :: NDIM=2 ! NUMBER OF DIMENSIONS + INTEGER ELEM, OK, TYPE + REAL(PDB) :: X1,X2,Y1,Y2,DET1,DET2 + REAL(PDB) :: DGMESHX(2),DGMESHY(2) + INTEGER, DIMENSION(NSTATE) :: I_STATE,IEDIMG + CHARACTER(LEN=72) :: TEXT72 + !---- + ! Allocatable arrays + !---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ELEM_LIST,NODE_LIST,NODE_MACRO, & + & ELEM_MACRO,PERIM_MACRO,AUX_ARR,SURF_MACRO,ICODE,IFOLD,IFOLD_GLOB, & + & PERIM_SURF + INTEGER, DIMENSION(:) , ALLOCATABLE :: ITAB ! LOCAL ARRAY + REAL(PDB), ALLOCATABLE, DIMENSION(:) :: ANGLE,ALBEDO + REAL, ALLOCATABLE, DIMENSION(:) :: VOLUME,GALBED + INTEGER, ALLOCATABLE, DIMENSION(:) :: MATALB,KEYMRG,IBC + REAL(PDB), ALLOCATABLE, DIMENSION(:) :: VOLSUR + REAL(PDB), ALLOCATABLE, DIMENSION(:,:,:) :: ALIGN + TYPE(T_G_BASIC), ALLOCATABLE :: GG_MAC + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LFOLD + !---- + ! GG_MAC allocation + !---- + ALLOCATE(GG_MAC) + !---- + ! Set isotropic tracking + !---- + ISPEC=0 + !---- + ! List of nodes and surface elements in IMACRO + !---- + IF(IPRINT.GT.0) WRITE(FOUT,'(/A,I6,A)') ' ********** IMACRO=',IMACRO,' **********' + ALLOCATE(ELEM_LIST(GG%NB_ELEM),NODE_LIST(GG%NB_NODE)) + ELEM_LIST(:GG%NB_ELEM) = 0 + NODE_LIST(:GG%NB_NODE) = -9999 + I=0 + DO ELEM=1,GG%NB_ELEM + I2=GG%IPAR(2,ELEM) + I3=GG%IPAR(3,ELEM) + IF((I2.GT.0).AND.(ELEM_LIST(ELEM) == 0)) THEN + IF(GG%NUM_MACRO(GG%NUM_MERGE(I2)) == IMACRO) THEN + I=I+1 + ELEM_LIST(ELEM)=I + NODE_LIST(I2)=1 + ENDIF + ENDIF + IF((I3.GT.0).AND.(ELEM_LIST(ELEM) == 0)) THEN + IF(GG%NUM_MACRO(GG%NUM_MERGE(I3)) == IMACRO) THEN + I=I+1 + ELEM_LIST(ELEM)=I + NODE_LIST(I3)=1 + ENDIF + ENDIF + ENDDO ! ELEM + DO J=1,GG%NB_NODE + IF(NODE_LIST(J) /= -9999) THEN + NBNODE_MACRO = NBNODE_MACRO+1 + NODE_LIST(J) = NBNODE_MACRO + ENDIF + ENDDO + NELEM_MACRO=I + ALLOCATE(NODE_MACRO(NBNODE_MACRO),ELEM_MACRO(NELEM_MACRO)) + DO I=1,NELEM_MACRO + ELEM = FINDLC(ELEM_LIST,I) + ELEM_MACRO(I) = ELEM + ENDDO + DO I=1,NBNODE_MACRO + NODE_MACRO(I) = FINDLC(NODE_LIST,I) + ENDDO + DEALLOCATE(NODE_LIST,ELEM_LIST) + !---- + ! Find perimeter. Three points are colinear if the determinant is zero. + !---- + ALLOCATE(PERIM_MACRO(NELEM_MACRO),ANGLE(NELEM_MACRO),ALBEDO(NELEM_MACRO),LFOLD(NELEM_MACRO)) + ALLOCATE(ALIGN(3,3,NELEM_MACRO)) + ALIGN(:3,3,:NELEM_MACRO)=1.0_PDB + PERIM_MACRO(:NELEM_MACRO)=0 + NPERIM=0 + ITER0: DO I=1,NELEM_MACRO + ELEM = ELEM_MACRO(I) + DO J=1,NBNODE_MACRO + IF(GG%IPAR(2,ELEM).EQ.NODE_MACRO(J)) GO TO 10 + ENDDO + GO TO 20 + 10 DO J=1,NBNODE_MACRO + IF(GG%IPAR(3,ELEM).EQ.NODE_MACRO(J)) CYCLE ITER0 + ENDDO + 20 IF(GG%IPAR(1,ELEM)==1) THEN + X1=GG%RPAR(1,ELEM); Y1=GG%RPAR(2,ELEM); + X2=X1+GG%RPAR(3,ELEM); Y2=Y1+GG%RPAR(4,ELEM); + DO J=1,NPERIM + ALIGN(3,1,J)=X1; ALIGN(3,2,J)=Y1; + DET1 = DET_ROSETTA(ALIGN(1,1,J),3) + ALIGN(3,1,J)=X2; ALIGN(3,2,J)=Y2; + DET2 = DET_ROSETTA(ALIGN(1,1,J),3) + IF((ABS(DET1).LE.1.0E-4).AND.(ABS(DET2).LE.1.0E-4)) THEN + PERIM_MACRO(I) = J + CYCLE ITER0 + ENDIF + ENDDO + NPERIM=NPERIM+1 + PERIM_MACRO(I) = NPERIM + ANGLE(NPERIM)=ATAN((Y2-Y1)/(X2-X1)) + IF(ABS(ANGLE(NPERIM)).LE.1.0E-5) ANGLE(NPERIM)=0.0 + ALIGN(1,1,NPERIM)=X1; ALIGN(1,2,NPERIM)=Y1 + ALIGN(2,1,NPERIM)=X2; ALIGN(2,2,NPERIM)=Y2 + ! Recover albedo from global geometry + ALBEDO(NPERIM)=1.0 + DO IB=1,GG%NBBCDA + J = FINDLC(GG%BCDATAREAD(IB)%ELEMNB,ELEM) + IF(J.EQ.1) THEN + ALBEDO(NPERIM)=GG%BCDATAREAD(IB)%BCDATA(6) + EXIT + ENDIF + ENDDO + ENDIF + ENDDO ITER0 + !---- + ! Printouts + !---- + IF(IPRINT.GT.2) THEN + WRITE(FOUT,'(/39H MUSACG: IPAR VALUES IN GLOBAL GEOMETRY)') + WRITE(FOUT,'(5H ELEM,20I5/(5X,20I5))') ELEM_MACRO(:NELEM_MACRO) + WRITE(FOUT,'(5H TYPE,20I5/(5X,20I5))') GG%IPAR(1,ELEM_MACRO(:NELEM_MACRO)) + WRITE(FOUT,'(5H -,20I5/(5X,20I5))') GG%IPAR(2,ELEM_MACRO(:NELEM_MACRO)) + WRITE(FOUT,'(5H +,20I5/(5X,20I5))') GG%IPAR(3,ELEM_MACRO(:NELEM_MACRO)) + ENDIF + !---- + ! Create volume and merge information + !---- + ALLOCATE(GG_MAC%VOL_NODE(NBNODE_MACRO),GG_MAC%MED(NBNODE_MACRO),GG_MAC%NAME_MACRO(1), & + & GG_MAC%NUM_MERGE(NBNODE_MACRO), STAT=OK) + IF(OK/=0) CALL XABORT('MUSACG: not enough memory I,R') + GG_MAC%NAME_MACRO(1) = 'MACR000001' + DO I=1,NBNODE_MACRO + J = NODE_MACRO(I) + GG_MAC%VOL_NODE(I) = GG%VOL_NODE(J) + GG_MAC%MED(I) = GG%MED(J) + GG_MAC%NUM_MERGE(I) = GG%NUM_MERGE(J) + ENDDO + GG_MAC%NB_FLUX = GG%NB_FLUX + DO I=GG%NB_FLUX,1,-1 + J = FINDLC(GG_MAC%NUM_MERGE,I) + IF(J.GT.0) CYCLE + DO J=1,NBNODE_MACRO + IF(GG_MAC%NUM_MERGE(J).GT.I) GG_MAC%NUM_MERGE(J)=GG_MAC%NUM_MERGE(J)-1 + ENDDO + GG_MAC%NB_FLUX = GG_MAC%NB_FLUX-1 + ENDDO + IF(IPRINT.GT.1) THEN + WRITE(FOUT,'(/32H MUSACG: number of flux in macro,I6.6,1H=,I5)') IMACRO,GG_MAC%NB_FLUX + WRITE(FOUT,'(5H NODE,20I5/(5X,20I5))') (I,I=1,NBNODE_MACRO) + WRITE(FOUT,'(5H MERG,20I5/(5X,20I5))') (GG_MAC%NUM_MERGE(I),I=1,NBNODE_MACRO) + ENDIF + ALLOCATE(GG_MAC%NUM_MACRO(GG_MAC%NB_FLUX), STAT=OK) + IF(OK/=0) CALL XABORT('MUSACG: not enough memory NUM_MACRO') + GG_MAC%NUM_MACRO(:GG_MAC%NB_FLUX) = 1 + !---- + ! Fill the GG_MAC tracking structure + !---- + GG_MAC%NBBCDA = NPERIM + GG_MAC%NB_ELEM = NELEM_MACRO + GG_MAC%NB_NODE = NBNODE_MACRO + GG_MAC%NB_MACRO = 1 + GG_MAC%DEFAUL = GG%DEFAUL + ALLOCATE(GG_MAC%IPAR(NIPAR,NELEM_MACRO),GG_MAC%RPAR(NRPAR,NELEM_MACRO), STAT=OK) + IF(OK/=0) CALL XABORT('MUSACG: not enough memory I,R') + GG_MAC%IPAR(:3,:GG_MAC%NB_ELEM)=0 + GG_MAC%RPAR(:3,:GG_MAC%NB_ELEM)=0.0 + DO ELEM=1, GG_MAC%NB_ELEM + GG_MAC%IPAR(1,ELEM) = GG%IPAR(1,ELEM_MACRO(ELEM)) ! elem type + I = GG%IPAR(2,ELEM_MACRO(ELEM)) ! node- + J = FINDLC(NODE_MACRO,I) + IF(J.GT.0) THEN + GG_MAC%IPAR(2,ELEM) = J + ELSE + GG_MAC%IPAR(3,ELEM) = MIN(I,0) + ENDIF + I = GG%IPAR(3,ELEM_MACRO(ELEM)) ! node+ + J = FINDLC(NODE_MACRO,I) + IF(J.GT.0) THEN + GG_MAC%IPAR(3,ELEM) = J + ELSE + GG_MAC%IPAR(3,ELEM) = MIN(I,0) + ENDIF + GG_MAC%RPAR(:NRPAR,ELEM) = GG%RPAR(:NRPAR,ELEM_MACRO(ELEM)) + ENDDO + IF(IPRINT.GT.1) THEN + WRITE(FOUT,'(/38H MUSACG: IPAR VALUES IN MACRO GEOMETRY)') + WRITE(FOUT,'(5H ELEM,20I5/(5X,20I5))') (I,I=1,GG_MAC%NB_ELEM) + WRITE(FOUT,'(5H TYPE,20I5/(5X,20I5))') GG_MAC%IPAR(1,:GG_MAC%NB_ELEM) + WRITE(FOUT,'(5H -,20I5/(5X,20I5))') GG_MAC%IPAR(2,:GG_MAC%NB_ELEM) + WRITE(FOUT,'(5H +,20I5/(5X,20I5))') GG_MAC%IPAR(3,:GG_MAC%NB_ELEM) + ENDIF + GG_MAC%ALBEDO=GG%ALBEDO + ALLOCATE(GG_MAC%BCDATAREAD(NPERIM)) + DO IB=1, GG_MAC%NBBCDA + GG_MAC%BCDATAREAD(IB)%NBER = COUNT(PERIM_MACRO(:NELEM_MACRO) == IB) + ALLOCATE(GG_MAC%BCDATAREAD(IB)%ELEMNB(GG_MAC%BCDATAREAD(IB)%NBER)) + J=0 + DO I=1,NELEM_MACRO + IF(PERIM_MACRO(I) == IB) THEN + J=J+1 + GG_MAC%BCDATAREAD(IB)%ELEMNB(J) = I + ENDIF + ENDDO + GG_MAC%BCDATAREAD(IB)%BCDATA(1) = ALIGN(1,1,IB) + GG_MAC%BCDATAREAD(IB)%BCDATA(2) = ALIGN(1,2,IB) + GG_MAC%BCDATAREAD(IB)%BCDATA(3) = COS(ANGLE(IB)) + GG_MAC%BCDATAREAD(IB)%BCDATA(4) = SIN(ANGLE(IB)) + GG_MAC%BCDATAREAD(IB)%BCDATA(5) = ANGLE(IB) + GG_MAC%BCDATAREAD(IB)%BCDATA(6) = ALBEDO(IB) + GG_MAC%BCDATAREAD(IB)%SALTYPE = 0 + ENDDO + TYPGEO=0 ; NBFOLD=0 + !---- + ! Find if the perimeter contains an unfolding axis + !---- + ALLOCATE(IFOLD_GLOB((2**NPERIM)*GG_MAC%NB_ELEM)) + IFOLD_GLOB(:GG_MAC%NB_ELEM)=(/ (ELEM, ELEM=1,GG_MAC%NB_ELEM) /) + DO IPASS=1,2 ! two passes are required to get rid of unfolding axis + IF(IPRINT.GT.2) THEN + WRITE(FOUT,'(/45H MUSACG: PERIMETERS BEFORE UNFOLDING AT PASS=,I2)') IPASS + WRITE(FOUT,'(7H PERIM,10I12/(7X,10I12))') (IB,IB=1,GG_MAC%NBBCDA) + WRITE(FOUT,'(7H X,1P,10e12.4/(7X,10e12.4))') GG_MAC%BCDATAREAD(:GG_MAC%NBBCDA)%BCDATA(1) + WRITE(FOUT,'(7H Y,1P,10e12.4/(7X,10e12.4))') GG_MAC%BCDATAREAD(:GG_MAC%NBBCDA)%BCDATA(2) + WRITE(FOUT,'(7H ANGLE,1P,10e12.4/(7X,10e12.4))') GG_MAC%BCDATAREAD(:GG_MAC%NBBCDA)%BCDATA(5)*180._PDB/PI + WRITE(FOUT,'(7H ALBEDO,1P,10e12.4/(7X,10e12.4))') GG_MAC%BCDATAREAD(:GG_MAC%NBBCDA)%BCDATA(6) + ENDIF + OUT1: DO IB=1,GG_MAC%NBBCDA + ALIGN(:3,:3,IB)=1.0D0 + DO I=1,GG_MAC%BCDATAREAD(IB)%NBER + INDBC=GG_MAC%BCDATAREAD(IB)%ELEMNB(I) + IF(INDBC==0) CYCLE + X1=GG_MAC%RPAR(1,INDBC); Y1=GG_MAC%RPAR(2,INDBC) + X2=X1+GG_MAC%RPAR(3,INDBC); Y2=Y1+GG_MAC%RPAR(4,INDBC) + ALIGN(1,1,IB)=X1; ALIGN(1,2,IB)=Y1 + ALIGN(2,1,IB)=X2; ALIGN(2,2,IB)=Y2 + EXIT + ENDDO + LFOLD(IB)=.FALSE. + DO ELEM=1,GG_MAC%NB_ELEM + IF(GG_MAC%IPAR(1,ELEM)==3) THEN + CALL SAL141(3,GG_MAC%RPAR(:,ELEM),X1,Y1,1) + CALL SAL141(3,GG_MAC%RPAR(:,ELEM),X2,Y2,2) + ALIGN(3,1,IB)=X1; ALIGN(3,2,IB)=Y1; + DET1 = DET_ROSETTA(ALIGN(1,1,IB),3) + ALIGN(3,1,IB)=X2; ALIGN(3,2,IB)=Y2; + DET2 = DET_ROSETTA(ALIGN(1,1,IB),3) + LFOLD(IB)=((ABS(DET1).LE.1.0E-4).OR.(ABS(DET2).LE.1.0E-4)) + IF(LFOLD(IB)) CYCLE OUT1 + ENDIF + ENDDO + ENDDO OUT1 + IF(IPRINT.GT.2) THEN + WRITE(FOUT,'(7H UNFOLD,1P,10L12/(6X,10L12))') LFOLD(:GG_MAC%NBBCDA) + ENDIF + !---- + ! Unfold macro geometry (many times, if required) + !---- + DO IB=1,GG_MAC%NBBCDA + IF(LFOLD(IB)) THEN + ALLOCATE(IFOLD(2*GG_MAC%NB_ELEM)) + CALL SALFOLD_0(GG_MAC,IPASS,IB,GG_MAC%NBBCDA,ALIGN,LFOLD,IFOLD) + DO ELEM=1,GG_MAC%NB_ELEM + IF(IFOLD(ELEM).GT.SIZE(IFOLD_GLOB,1)) CALL XABORT('MUSACG: IFOLD overflow') + IFOLD(ELEM)=IFOLD_GLOB(IFOLD(ELEM)) + ENDDO + IFOLD_GLOB(:GG_MAC%NB_ELEM)=IFOLD(:GG_MAC%NB_ELEM) + DEALLOCATE(IFOLD) + ENDIF + ENDDO + ENDDO + IFOLD_GLOB(:GG_MAC%NB_ELEM)=ELEM_MACRO(IFOLD_GLOB(:GG_MAC%NB_ELEM)) + IF(PRTIND>2) WRITE(6,'(/15H MUSACG: IFOLD=,20I5/(15X,20I5))') IFOLD_GLOB(:GG_MAC%NB_ELEM) + DEALLOCATE(ALIGN,LFOLD) + IF(IPRINT>0) WRITE(FOUT,*) 'MUSACG: after unfolding -- NB_ELEM=',GG_MAC%NB_ELEM,' NB_PERIM=',GG_MAC%NBBCDA + IF(PRTIND>5) THEN + !* print surfacic file + WRITE(FOUT,'(5H--cut,70(1H-),I5)') IMACRO + WRITE(FOUT,'(5HBEGIN)') + WRITE(FOUT,'(42H* typgeo nbfold nbnode nbelem nbmacr nbreg)') + WRITE(FOUT,'(6I7)') TYPGEO,NBFOLD,GG_MAC%NB_NODE,GG_MAC%NB_ELEM,GG_MAC%NB_MACRO,GG_MAC%NB_NODE + WRITE(FOUT,'(20H* index kndex prec)') + WRITE(FOUT,'(4I7)') 0,0,1 + WRITE(FOUT,'(18H* eps eps0)') + WRITE(FOUT,'(1P,2E18.9)') 1.0E-03,1.0E-05 + WRITE(FOUT,'(20H* num_of_region/mesh)') + WRITE(FOUT,'(10I7)') (GG_MAC%NUM_MERGE(I),I=1,GG_MAC%NB_NODE) + WRITE(FOUT,'(13H* macro names)') + WRITE(FOUT,'(4(3x,a10,2x))') (GG_MAC%NAME_MACRO(I),I=1,GG_MAC%NB_MACRO) + WRITE(FOUT,'(35H* macro_order_index_per_flux_region)') + WRITE(FOUT,'(10I7)') (GG_MAC%NUM_MACRO(I),I=1,GG_MAC%NB_FLUX) + DO ELEM=1,GG_MAC%NB_ELEM + TYPE=GG_MAC%IPAR(1,ELEM) + WRITE(FOUT,'(7h elem =,I6)') ELEM + WRITE(FOUT,'(22H*type node- node+)') + WRITE(FOUT,'(3I6)') (GG_MAC%IPAR(I,ELEM),I=1,3) + WRITE(FOUT,'(63H*cx cy ex_or_R ey_or_theta1 theta2)') + IF(TYPE<=2) THEN + WRITE(FOUT,'(1P,5E18.9)') (GG_MAC%RPAR(I,ELEM),I=1,5) + ELSE IF(TYPE==3) THEN + WRITE(FOUT,'(1P,5E18.9)') (GG_MAC%RPAR(I,ELEM),I=1,3),GG_MAC%RPAR(4,ELEM)*180._PDB/PI, & + (GG_MAC%RPAR(5,ELEM)-GG_MAC%RPAR(4,ELEM))*180._PDB/PI + ENDIF + ENDDO + WRITE(FOUT,'(40H*defaul nbbcda allsur divsur ndivsur)') + WRITE(FOUT,'(1P,5I8)') GG_MAC%DEFAUL,GG_MAC%NBBCDA,ALLSUR,0,0 + WRITE(FOUT,'(17H*albedo deltasur)') + WRITE(FOUT,'(1P,2E18.9)') GG_MAC%ALBEDO,0.0 + DO IB=1,GG_MAC%NBBCDA + WRITE(FOUT,'(37H particular boundary condition number,i12)') IB + WRITE(FOUT,'(13H*type nber)') + WRITE(FOUT,'(1P,2I8)') GG_MAC%BCDATAREAD(IB)%SALTYPE,GG_MAC%BCDATAREAD(IB)%NBER + WRITE(FOUT,'(14H*elems(1,nber))') + WRITE(FOUT,'(1P,10I8)') (GG_MAC%BCDATAREAD(IB)%ELEMNB(I),I=1,GG_MAC%BCDATAREAD(IB)%NBER) + IF(GG_MAC%BCDATAREAD(IB)%SALTYPE/=0) CALL XABORT('MUSACG: SALTYPE=0 expected') + WRITE(FOUT,'(7H*albedo)') + WRITE(FOUT,'(1P,E18.9)') GG_MAC%BCDATAREAD(IB)%BCDATA(6) + ENDDO + WRITE(FOUT,'(12H* mil(nbreg))') + WRITE(FOUT,'(10I7)') (GG_MAC%MED(I),I=1,GG_MAC%NB_NODE) + WRITE(FOUT,'(3HEND)') + WRITE(FOUT,'(5H--cut,70(1H-),I5)') IMACRO + ENDIF + IF(GG_MAC%NBBCDA.GT.6) CALL XABORT('MUSACG: The unfolded geometry has more than 6 perimeters') + !**** + !* compute node perimeters for the macro + ALLOCATE (GG_MAC%PPERIM_NODE(GG_MAC%NB_NODE+1),STAT=OK) + IF(OK/=0) CALL XABORT('MUSACG: not enough memory PPERIM_NODE') + ALLOCATE(AUX_ARR(2*GG_MAC%NB_ELEM)) + CALL SAL130_2(GG_MAC%NB_ELEM,GG_MAC%NB_NODE,GG_MAC%IPAR,GG_MAC%PPERIM_NODE, & + GG_MAC%PERIM_NODE,AUX_ARR) + ! + !* - compute number of bc's per 2D macro, + ! NB_BC2 counts total nber of 2D bc's + ! - compute IBC2_ELEM, keep relative 2D bc nber to elements + ! - allocation : 2D bc structures + ! 2D perimeter structure for a macro + ! - get list of elements in 2d macro perimeter + ALLOCATE(GG_MAC%IBC2_ELEM(GG_MAC%NB_ELEM),GG_MAC%ISURF2_ELEM(GG_MAC%NB_ELEM)) + CALL SAL130_4(GG_MAC%NB_ELEM,NN,GG_MAC%IPAR,GG_MAC%IBC2_ELEM,AUX_ARR) + GG_MAC%NB_BC2 = NN + GG_MAC%NALBG = GG_MAC%NBBCDA + !* allocate bcdata + ALLOCATE (GG_MAC%BCDATA(6,GG_MAC%NALBG), STAT=OK) + IF(OK/=0) CALL XABORT('MUSACG: not enough memory R') + DO IB=1,GG_MAC%NALBG + GG_MAC%BCDATA(:6,IB)=GG_MAC%BCDATAREAD(IB)%BCDATA(:6) + ENDDO + ! + !* put default value in all bc elements: + ALLOCATE(GG_MAC%TYPE_BC2(NN),GG_MAC%IDATA_BC2(NN),GG_MAC%PERIM_MAC2(NN),STAT=OK) + IF(OK/=0) CALL XABORT('MUSACG: not enough memory I,R') + GG_MAC%PERIM_MAC2(1:NN) = AUX_ARR(1:NN) + GG_MAC%NPERIM_MAC2 = NN + DEALLOCATE(AUX_ARR) + GG_MAC%TYPE_BC2(:NN) = 0 + CALL SAL131_2(GG_MAC%NB_ELEM,GG_MAC%DEFAUL,GG_MAC%IPAR,GG_MAC%IBC2_ELEM,GG_MAC%TYPE_BC2, & + & GG_MAC%IDATA_BC2) + ITBC=0 + IF(GG_MAC%NBBCDA>0)THEN + DO I=1,GG%NBBCDA + ITBC=ITBC+1 + TYPE=GG_MAC%BCDATAREAD(I)%SALTYPE + IF(TYPE.NE.0) CALL XABORT('MUSACG: TYPE=0 EXPECTED.') + ! + ! modify notation for boundary conditions + NBER=GG_MAC%BCDATAREAD(I)%NBER + DO J=1,NBER + ELEM=GG_MAC%BCDATAREAD(I)%ELEMNB(J) + IF(ELEM>GG_MAC%NB_ELEM.OR.ELEM<=0) CALL XABORT('MUSACG: unknown bc element') + ! get local surface nber + IB=GG_MAC%IBC2_ELEM(ELEM) + LGBC=GG_MAC%IPAR(2,ELEM)<=0 + II=0 + IF(LGBC)THEN + II=2 + ELSE + LGBC=GG_MAC%IPAR(3,ELEM)<=0 + IF(LGBC) II=3 + ENDIF + IF(.NOT.LGBC) THEN + WRITE(*,*) 'elem :',ELEM + WRITE(*,*) 'GG_MAC%IPAR(:,ELEM) :',GG_MAC%IPAR(:,ELEM) + CALL XABORT('MUSACG: wrong bc element') + ENDIF + ! put bc type + GG_MAC%IPAR(II,ELEM)=G_BC_TYPE(TYPE) + GG_MAC%TYPE_BC2(IB)=G_BC_TYPE(TYPE) + ! put bc data position : + GG_MAC%IDATA_BC2(IB)=ITBC + ENDDO + ENDDO + ENDIF + ! + !* - set BCDATA position for surfaces of type G_BC_TYPE(-1) + ! - compute the nber of surfaces (type -1,0,-12,-13,-14,-15) : nbsur2 + ! - allocate structures for the surfaces + ! - compute surf_mac2 + ALLOCATE(AUX_ARR(GG_MAC%NB_ELEM)) + AUX_ARR(:GG_MAC%NB_ELEM)=0 + GG_MAC%ISURF2_ELEM(:GG_MAC%NB_ELEM)=0 + NELEM_MACRO=GG_MAC%NB_ELEM + NSURF_MACRO=0 + DO IB=1,GG_MAC%NB_BC2 + ! relative element nber + IELEM=GG_MAC%PERIM_MAC2(IB) + ! count 2D surfaces number + IF(GG_MAC%TYPE_BC2(IB)==G_BC_TYPE(-1) .OR. GG_MAC%TYPE_BC2(IB)==G_BC_TYPE(0) .OR. & + & GG_MAC%TYPE_BC2(IB)==G_BC_TYPE(1)) THEN + NSURF_MACRO=NSURF_MACRO+1 + AUX_ARR(NSURF_MACRO)=IB + GG_MAC%ISURF2_ELEM(IELEM)=NSURF_MACRO + ELSE + GG_MAC%ISURF2_ELEM(IELEM)=0 + ENDIF + ENDDO + GG_MAC%NB_SURF2 = NSURF_MACRO + ALLOCATE(SURF_MACRO(NSURF_MACRO)) + IF(NSURF_MACRO>0) THEN + DO I=1,NSURF_MACRO + ELEM = FINDLC(GG_MAC%ISURF2_ELEM,I) + IF(ELEM.GT.NELEM_MACRO) CALL XABORT('MUSACG: ELEM_MACRO OVERFLOW.') + SURF_MACRO(I) = IFOLD_GLOB(ELEM) + ENDDO + ALLOCATE (GG_MAC%IBC2_SURF2(NSURF_MACRO),GG_MAC%IELEM_SURF2(NSURF_MACRO),STAT=OK) + IF(OK/=0) CALL XABORT('MUSACG: NOT ENOUGH MEMORY I,R') + GG_MAC%IBC2_SURF2(1:NSURF_MACRO)=AUX_ARR(1:NSURF_MACRO) + ! + ! - define IELEM_SURF2 ??? + ALLOCATE(GG_MAC%SURF2(GG_MAC%NB_SURF2),STAT = OK) + IF(OK /= 0) CALL XABORT('MUSACG: not enough memory I,R') + CALL SAL130_6(GG_MAC%NB_SURF2,GG_MAC%IBC2_SURF2,GG_MAC%PERIM_MAC2, & + & GG_MAC%IELEM_SURF2) + ELSE + NULLIFY(GG_MAC%IBC2_SURF2,GG_MAC%IELEM_SURF2) + ENDIF + DO I=1,NBNODE_MACRO + NODE_MACRO(I)=GG%NUM_MERGE(NODE_MACRO(I)) + ENDDO + CALL LCMSIX(ITRACK,'SURFACIC_TMP',1) + IF(NSURF_MACRO>0) CALL LCMPUT(ITRACK,'SURF_MACRO',NSURF_MACRO,1,SURF_MACRO) + CALL LCMPUT(ITRACK,'MERGE_MACRO',NBNODE_MACRO,1,NODE_MACRO) + CALL LCMSIX(ITRACK,' ',2) + DEALLOCATE(IFOLD_GLOB,ELEM_MACRO,NODE_MACRO) + DEALLOCATE(AUX_ARR,ALBEDO,ANGLE,PERIM_MACRO,SURF_MACRO) + ! + !* topological check + ALLOCATE (GG_MAC%VOL_NODE(GG_MAC%NB_NODE), STAT=OK) + IF(OK/=0) CALL XABORT('MUSACG: not enough memory VOL') + CALL SAL140(GG_MAC%NB_NODE,GG_MAC%RPAR,GG_MAC%IPAR,GG_MAC%PPERIM_NODE,GG_MAC%PERIM_NODE) + ! + !* volumes, surfaces, put local nbers in node, and read media: + CALL SAL160_2(GG_MAC%NB_ELEM,GG_MAC%IPAR,GG_MAC%RPAR,GG_MAC%VOL_NODE,GG_MAC%ISURF2_ELEM, & + GG_MAC%NB_SURF2,GG_MAC%SURF2) + ! + !* printout basic domain + CALL SAL170(GG_MAC) + !---- + ! Save MUST tracking information on LCM + !---- + CALL LCMSIX(ITRACK,'GEOMETRY ',1) + CALL LCMPUT(ITRACK,'NB_ELEM ',1,1,GG_MAC%NB_ELEM) + CALL LCMPUT(ITRACK,'NIPAR ',1,1,SIZE(GG_MAC%IPAR,1)) + CALL LCMPUT(ITRACK,'IPAR ',SIZE(GG_MAC%IPAR),1,GG_MAC%IPAR) + CALL LCMPUT(ITRACK,'RPAR ',SIZE(GG_MAC%RPAR),4,GG_MAC%RPAR) + CALL LCMPUT(ITRACK,'ISURF2_ELEM ',SIZE(GG_MAC%ISURF2_ELEM),1,GG_MAC%ISURF2_ELEM) + CALL LCMPUT(ITRACK,'NB_NODE ',1,1,GG_MAC%NB_NODE) + CALL LCMPUT(ITRACK,'VOL_NOD ',GG_MAC%NB_NODE,4,GG_MAC%VOL_NODE) + CALL LCMPUT(ITRACK,'NB_SURF2 ',1,1,GG_MAC%NB_SURF2) + IF(GG_MAC%NBBCDA.GT.0) THEN + LGINF = .TRUE. + DO IB=1, GG_MAC%NBBCDA + LGINF = LGINF .AND. (GG_MAC%BCDATAREAD(IB)%BCDATA(6) == 1._PDB) + ENDDO + ELSE + LGINF = (GG_MAC%ALBEDO == 1._PDB) + ENDIF + IF(GG_MAC%NB_SURF2 > 0) THEN + CALL LCMPUT(ITRACK,'IBC2_SURF2 ',SIZE(GG_MAC%IBC2_SURF2),1,GG_MAC%IBC2_SURF2) + CALL LCMPUT(ITRACK,'IELEM_SURF2 ',SIZE(GG_MAC%IELEM_SURF2),1,GG_MAC%IELEM_SURF2) + CALL LCMPUT(ITRACK,'SURF2 ',SIZE(GG_MAC%SURF2),4,GG_MAC%SURF2) + ENDIF + CALL LCMPUT(ITRACK,'NPERIM_MAC2 ',1,1,GG_MAC%NPERIM_MAC2) + CALL LCMPUT(ITRACK,'PERIM_MAC2 ',SIZE(GG_MAC%PERIM_MAC2),1,GG_MAC%PERIM_MAC2) + CALL LCMPUT(ITRACK,'PERIM_NODE ',SIZE(GG_MAC%PERIM_NODE),1,GG_MAC%PERIM_NODE) + CALL LCMPUT(ITRACK,'PPERIM_NODE ',SIZE(GG_MAC%PPERIM_NODE),1,GG_MAC%PPERIM_NODE) + CALL LCMPUT(ITRACK,'BC_DATA_DIM2',1,1,SIZE(GG_MAC%BCDATA,2)) + CALL LCMPUT(ITRACK,'NB_BC2 ',1,1,GG_MAC%NB_BC2) + CALL LCMSIX(ITRACK,' ',2) ! come back to father directory + !---- + ! Print tracking object directory + !---- + IF(IPRINT.GT.4) THEN + WRITE(FOUT,'(/14H MUSACG: MACRO,I6.6,20H GEOMETRY DIRECTORY:)') IMACRO + CALL LCMLIB(ITRACK) + CALL LCMSIX(ITRACK,'GEOMETRY',1) + CALL LCMLIB(ITRACK) + CALL LCMSIX(ITRACK,' ',2) + ENDIF + !---- + ! store the STATE VECTOR + !---- + NREG=MAXVAL(GG_MAC%NUM_MERGE) + LEAK=1 + IF(.NOT.LGINF) LEAK=0 ! reset the leakage flag + CALL LCMGET(ITRACK,'STATE-VECTOR',I_STATE) + I_STATE(1) = NREG ! number of regions + I_STATE(2) = NREG ! number of unknowns in DRAGON + I_STATE(3) = LEAK ! 1 = absent leakage, 0 leakage + I_STATE(4) = MAXVAL(GG_MAC%MED(1:GG_MAC%NB_NODE)) ! maximum number of mixture + I_STATE(5) = GG_MAC%NB_SURF2 ! number of outer surface + I_STATE(9) = ISPEC + I_STATE(24)= 0 + NSOUT=GG_MAC%NB_SURF2 + CALL LCMPUT(ITRACK,'STATE-VECTOR',NSTATE,1,I_STATE) + ! + ! fill-in medium number per region + ALLOCATE(ITAB(NREG),VOLUME(NREG), STAT =OK) + IF(OK /= 0) CALL XABORT('MUSACG: failure to allocate integer ITAB') + ! fill in MATCOD + DO J=1,GG_MAC%NB_NODE + ITAB(GG_MAC%NUM_MERGE(J)) = GG_MAC%MED(J) + ENDDO + CALL LCMPUT(ITRACK,'MATCOD',NREG,1,ITAB(1:NREG) ) + ! fill-in KEYFLX per region + ITAB(1:NREG)=(/ (I,I=1,NREG) /) + CALL LCMPUT(ITRACK,'MERGE',NREG,1,ITAB) + CALL LCMPUT(ITRACK,'KEYFLX',NREG,1,ITAB) + ! fill-in volumes per region + VOLUME(:NREG) =0. + DO I=1,GG_MAC%NB_NODE + VOLUME(GG_MAC%NUM_MERGE(I)) = VOLUME(GG_MAC%NUM_MERGE(I)) + REAL(GG_MAC%VOL_NODE(I)) + ENDDO + CALL LCMPUT(ITRACK,'VOLUME',NREG,2,VOLUME) + DEALLOCATE(VOLUME,ITAB) + + ! useful values in SAL_TRACKING_TYPES module + NFREG=GG_MAC%NB_NODE + CALL LCMSIX(ITRACK,'NXTRecords',1) + DGMESHX=(/ 1.E10_PDB , -1.E10_PDB /) + DGMESHY=(/ 1.E10_PDB , -1.E10_PDB /) + DO ELEM=1,GG_MAC%NB_ELEM + DGMESHX(1)=MIN(DGMESHX(1),GG_MAC%RPAR(1,ELEM)) + DGMESHX(2)=MAX(DGMESHX(2),GG_MAC%RPAR(1,ELEM)) + DGMESHY(1)=MIN(DGMESHY(1),GG_MAC%RPAR(2,ELEM)) + DGMESHY(2)=MAX(DGMESHY(2),GG_MAC%RPAR(2,ELEM)) + ENDDO + CALL LCMPUT(ITRACK,'G00000001SMX',2,4,DGMESHX) + CALL LCMPUT(ITRACK,'G00000001SMY',2,4,DGMESHY) + IEDIMG(:NSTATE)=0 + IEDIMG(1)=NDIM + IEDIMG(2)=0 ! Cartesian geometry + IF(TYPGEO.EQ.8) IEDIMG(2)=2 ! Isocel geometry with specular reflection + IF(TYPGEO.EQ.9) IEDIMG(2)=3 ! Hexagonal geometry with translation + IF(TYPGEO.EQ.10) IEDIMG(2)=4 ! Isocel geometry with RA60 symmetry + IF(TYPGEO.EQ.11) IEDIMG(2)=5 ! Lozenge geometry with R120 rotation + IF(TYPGEO.EQ.12) IEDIMG(2)=6 ! S30 geometry with specular reflection + IEDIMG(5)=1 ! 1 cellule + IEDIMG(13)=1 ! 1 cellule + IEDIMG(14)=1 ! 1 cellule + IEDIMG(22)=NSOUT ! number of external surfaces for this geometry + IEDIMG(23)=NFREG ! number of regions for this geometry + IEDIMG(25)=GG_MAC%NB_NODE + CALL LCMPUT(ITRACK,'G00000001DIM',NSTATE,1,IEDIMG) + CALL LCMSIX(ITRACK,' ',2) ! come back to father directory + !---- + ! process boundary conditions + !---- + IF(IPRINT.GT.0) WRITE(FOUT,*) 'number of merged regions,surfaces,nodes',NREG,NSOUT,NFREG + ALLOCATE(MATALB(-NSOUT:NFREG),VOLSUR(-NSOUT:NFREG),KEYMRG(-NSOUT:NFREG)) + CALL LCMGET(ITRACK,'MATCOD',MATALB(1)) + ALLOCATE(VOLUME(NREG)) + CALL LCMGET(ITRACK,'VOLUME',VOLUME) + VOLSUR(1:NREG)=VOLUME(:NREG) + DEALLOCATE(VOLUME) + ! boundary conditions structures + ALLOCATE(ICODE(GG_MAC%NALBG),GALBED(GG_MAC%NALBG)) + ICODE(1:GG_MAC%NALBG)=(/ (-I,I=1,GG_MAC%NALBG) /) + GALBED(:GG_MAC%NALBG)=REAL(GG_MAC%ALBEDO) + DO I=1,NSOUT + KEYMRG(-I)=-I + VOLSUR(-I)=GG_MAC%SURF2(I) + INDEX=GG_MAC%IDATA_BC2(GG_MAC%IBC2_SURF2(I)) + IF(INDEX.EQ.0) THEN + ! Use the default albedo + MATALB(-I)=-1 + GALBED(1)=REAL(GG_MAC%ALBEDO) + ELSE + IF(INDEX.GT.6) CALL XABORT('MUSACG: SDIRE overflow.') + IF(INDEX > GG_MAC%NALBG) THEN + CALL XABORT('MUSACG: Albedo array overflow(2).') + ENDIF + MATALB(-I)=-INDEX + IF(SIZE(GG_MAC%BCDATA) > 0) THEN + GALBED(INDEX)=REAL(GG_MAC%BCDATA(6,INDEX)) + ELSE + GALBED(INDEX)=REAL(GG_MAC%ALBEDO) + ENDIF + ENDIF + ENDDO + MATALB(0)=0 + KEYMRG(0)=0 + VOLSUR(0)=0._PDB + KEYMRG(1:NREG)=(/ (I,I=1,NREG) /) + ! + IF(IPRINT.GT.1) THEN + CALL PRINDM('VOLUME',VOLSUR(-NSOUT),NREG+NSOUT+1) + CALL PRINIM('MATALB',MATALB(-NSOUT),NREG+NSOUT+1) + CALL PRINIM('KEYMRG',KEYMRG(-NSOUT),NREG+NSOUT+1) + ENDIF + IF(IPRINT.GT.0) THEN + CALL PRINIM('ICODE ',ICODE(1),GG_MAC%NALBG) + CALL PRINAM('GALBED',GALBED(1),GG_MAC%NALBG) + ENDIF + !---- + ! fill in tracking LCM object in excelt format + !---- + TEXT72='SAL TRACKING' + CALL LCMPTC(ITRACK,'TITLE',72,TEXT72) + CALL LCMPUT(ITRACK,'ICODE',GG_MAC%NALBG,1,ICODE) + CALL LCMSIX(ITRACK,'NXTRecords',1) + CALL LCMPUT(ITRACK,'SAreaRvolume',NREG+NSOUT+1,4,VOLSUR(-NSOUT)) + CALL LCMPUT(ITRACK,'MATALB',NREG+NSOUT+1,1,MATALB(-NSOUT)) + CALL LCMPUT(ITRACK,'KEYMRG',NREG+NSOUT+1,1,KEYMRG(-NSOUT)) + CALL LCMSIX(ITRACK,' ',2) + IF(NSOUT>0) THEN + ALLOCATE(IBC(NSOUT)) + IBC(1:NSOUT)=(/ (I,I=1,NSOUT) /) + CALL LCMPUT(ITRACK,'BC-REFL+TRAN',NSOUT,1,IBC) + DEALLOCATE(IBC) + ENDIF + ALLOCATE(PERIM_SURF(GG_MAC%NB_ELEM)) + PERIM_SURF(:GG_MAC%NB_ELEM)=0 + DO IB=1,GG_MAC%NBBCDA + DO I=1,GG_MAC%BCDATAREAD(IB)%NBER + ELEM=GG_MAC%BCDATAREAD(IB)%ELEMNB(I) + IF(ELEM.GT.GG_MAC%NB_ELEM) CALL XABORT('MUSACG: inconsistent perimeter(1)') + ISURF=GG_MAC%ISURF2_ELEM(ELEM) + IF(ISURF.GT.NSURF_MACRO) CALL XABORT('MUSACG: inconsistent perimeter(2)') + PERIM_SURF(ISURF)=IB + ENDDO + ENDDO + CALL LCMPUT(ITRACK,'MATCOD',NREG,1,MATALB(1)) + CALL LCMPUT(ITRACK,'ALBEDO',GG_MAC%NALBG,2,GALBED) + CALL LCMPUT(ITRACK,'PERIM_SURF',NSURF_MACRO,1,PERIM_SURF) + DEALLOCATE(PERIM_SURF,GALBED,ICODE) + DEALLOCATE(KEYMRG,VOLSUR,MATALB) + !---- + ! Track macro geometry IMACR + !---- + PRTIND=IPRINT + F_GEO=FGEO + EPS1=1.E-5_PDB + IF(RCUTOF>0._PDB) THEN + EPS1=RCUTOF + IF(PRTIND>0) WRITE(*,*) "MUSACG: set eps1 to ",EPS1 + ENDIF + IGTRK=1 + CALL SALTCG(ITRACK, IFTRK, IPRINT, IGTRK, NBSLIN, GG_MAC) + !---- + ! Release allocated memory for macro IMACR + !---- + CALL SALEND(GG_MAC) + DEALLOCATE(GG_MAC, STAT= OK) + IF(OK /= 0) CALL XABORT('MUSACG: failure to deallocate GG_MAC') +END SUBROUTINE MUSACG diff --git a/Dragon/src/MUSF.f90 b/Dragon/src/MUSF.f90 new file mode 100644 index 0000000..17b195f --- /dev/null +++ b/Dragon/src/MUSF.f90 @@ -0,0 +1,155 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Solve N-group transport equation for fluxes using the current iteration +! method for the multicell surfacic approximation. +! +!Copyright: +! Copyright (C) 2025 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version +! +!Author(s): A. Hebert +! +!Parameters: input +! KPSYS pointer to the assembly matrices (L_PIJ signature). KPSYS is +! an array of directories. +! IPTRK pointer to the tracking (L_TRACK signature). +! IFTRAK not used. +! IMPX print flag (equal to zero for no print). +! NGEFF number of energy groups processed in parallel. +! NGIND energy group indices assign to the NGEFF set. +! IDIR not used (=0 only for SYBIL). +! NREG total number of regions for which specific values of the +! neutron flux and reactions rates are required. +! NUNKNO total number of unknowns in vectors SUNKNO and FUNKNO. +! MAT index-number of the mixture type assigned to each volume. +! VOL volumes. +! SUNKNO input source vector. +! TITR title. +! +!Parameters: input/output +! FUNKNO unknown vector. +! +!----------------------------------------------------------------------- +! + SUBROUTINE MUSF(KPSYS,IPTRK,IMPX,NGEFF,NGIND,IDIR,NREG,NUNKNO,MAT,VOL, & + & FUNKNO,SUNKNO,TITR) + USE GANLIB + !---- + ! SUBROUTINE ARGUMENTS + !---- + TYPE(C_PTR) KPSYS(NGEFF),IPTRK + CHARACTER TITR*72 + INTEGER NGEFF,NGIND(NGEFF),IMPX,IDIR,NREG,NUNKNO,MAT(NREG) + REAL VOL(NREG),FUNKNO(NUNKNO,NGEFF),SUNKNO(NUNKNO,NGEFF) + !---- + ! LOCAL VARIABLES + !---- + PARAMETER (IUNOUT=6,NSTATE=40) + CHARACTER NAMLCM*12,NAMMY*12 + INTEGER ISTATE(NSTATE) + REAL RSTATE(NSTATE) + LOGICAL EMPTY,LCM + !---- + ! ALLOCATABLE ARRAYS + !---- + TYPE(C_PTR) PIJW_PTR,PISW_PTR,PSJW_PTR,PSSW_PTR + INTEGER, ALLOCATABLE, DIMENSION(:) :: NMC_NODE,NMC_SURF,IFR,MIX,INUM,IGEN,IMAC + REAL, ALLOCATABLE, DIMENSION(:) :: ALB,DVX + REAL, POINTER, DIMENSION(:) :: PIJW,PISW,PSJW,PSSW + ! + IF(IDIR.NE.0) CALL XABORT('MUSF: EXPECTING IDIR=0') + IF(MAT(1).LT.0) CALL XABORT('MUSF: EXPECTING MAT(1)>=0') + IF(VOL(1).LT.0.0) CALL XABORT('MUSF: EXPECTING VOL(1)>=0') + CALL LCMINF(KPSYS(1),NAMLCM,NAMMY,EMPTY,ILONG,LCM) + !---- + ! RECOVER MUST SPECIFIC PARAMETERS + !---- + IF(IMPX.GT.2) WRITE(IUNOUT,'(//7H MUSF: ,A72)') TITR + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + IF(NREG.NE.ISTATE(1)) THEN + CALL XABORT('MUSF: STATE VECTOR HAS INVALID # OF ZONES.') + ENDIF + NMACRO=ISTATE(24) ! NGEN + IF(NMACRO.EQ.0) CALL XABORT('MUSF: NO MACRO GEOMETRIES DEFINED.') + NMCEL=NMACRO + NMERGE=NMACRO + NGEN=NMACRO + ALLOCATE(IGEN(NMERGE),INUM(NMCEL)) + DO IK=1,NMERGE + IGEN(IK)=IK + ENDDO + DO IK=1,NMCEL + INUM(IK)=IK + ENDDO + IF(NMACRO.EQ.0) CALL XABORT('MUSF: MACRO OPTION IS MANDATORY.') + ALLOCATE(NMC_NODE(NMACRO+1),NMC_SURF(NMACRO+1),IMAC(NREG)) + CALL LCMGET(IPTRK,'NMC_NODE',NMC_NODE) + CALL LCMGET(IPTRK,'NMC_SURF',NMC_SURF) + CALL LCMGET(IPTRK,'MERGE_MACRO',IMAC) + CALL LCMGET(IPTRK,'EXCELTRACKOP',RSTATE) + EPSJ=RSTATE(12) + NMIX=NMC_SURF(NMACRO+1) + NIFR=NMC_SURF(NMACRO+1) + ALLOCATE(IFR(NIFR),ALB(NIFR),MIX(NMIX),DVX(NMIX)) + CALL LCMGET(IPTRK,'IFR',IFR) + CALL LCMGET(IPTRK,'ALB',ALB) + CALL LCMGET(IPTRK,'MIX',MIX) + CALL LCMGET(IPTRK,'DVX',DVX) + J1=0 + NMIX=0 + NPIJ=0 + NPIS=0 + NPSS=0 + DO IMACRO=1,NMACRO + J2=NMC_NODE(IMACRO+1)-NMC_NODE(IMACRO) + J3=NMC_SURF(IMACRO+1)-NMC_SURF(IMACRO) + J1=J1+J2 + NMIX=NMIX+J3 + NPIJ=NPIJ+J2*J2 + NPIS=NPIS+J2*J3 + NPSS=NPSS+J3*J3 + ENDDO + IF(J1.NE.NREG) CALL XABORT('MUSF: INVALID NREG.') + IF(NMIX.NE.NMC_SURF(NMACRO+1)) CALL XABORT('MUSF: INVALID NMIX.') + !---- + ! MAIN LOOP OVER ENERGY GROUPS. + !---- + DO II=1,NGEFF + IF(IMPX.GT.1) WRITE(IUNOUT,'(/23H MUSF: PROCESSING GROUP,I5, & + & 6H WITH ,A,1H.)') NGIND(II),'MUSF' + ! + IF(LCM) THEN + CALL LCMGPD(KPSYS(II),'PIJW$SYBIL',PIJW_PTR) + CALL LCMGPD(KPSYS(II),'PISW$SYBIL',PISW_PTR) + CALL LCMGPD(KPSYS(II),'PSJW$SYBIL',PSJW_PTR) + CALL LCMGPD(KPSYS(II),'PSSW$SYBIL',PSSW_PTR) + ! + CALL C_F_POINTER(PIJW_PTR,PIJW,(/ NPIJ /)) + CALL C_F_POINTER(PISW_PTR,PISW,(/ NPIS /)) + CALL C_F_POINTER(PSJW_PTR,PSJW,(/ NPIS /)) + CALL C_F_POINTER(PSSW_PTR,PSSW,(/ NPSS /)) + ELSE + ALLOCATE(PIJW(NPIJ),PISW(NPIS),PSJW(NPIS),PSSW(NPSS)) + CALL LCMGET(KPSYS(II),'PIJW$SYBIL',PIJW) + CALL LCMGET(KPSYS(II),'PISW$SYBIL',PISW) + CALL LCMGET(KPSYS(II),'PSJW$SYBIL',PSJW) + CALL LCMGET(KPSYS(II),'PSSW$SYBIL',PSSW) + ENDIF + IJAT=MAXVAL(MIX) + CALL MUSJJ2(NREG,NMCEL,NMERGE,NGEN,IJAT,NPIJ,NPIS,NPSS,EPSJ,NUNKNO, & + & NMIX,NIFR,FUNKNO(1,II),SUNKNO(1,II),IMPX,NMC_NODE,NMC_SURF,IFR,ALB, & + & INUM,MIX,DVX,IGEN,IMAC,PIJW,PISW,PSJW,PSSW) + IF(.NOT.LCM) DEALLOCATE(PSSW,PSJW,PISW,PIJW) + !---- + ! END OF LOOP OVER ENERGY GROUPS + !---- + ENDDO + DEALLOCATE(DVX,MIX,ALB,IFR) + DEALLOCATE(IMAC,NMC_SURF,NMC_NODE,INUM,IGEN) + RETURN + END diff --git a/Dragon/src/MUSJJ2.f90 b/Dragon/src/MUSJJ2.f90 new file mode 100644 index 0000000..7570bf1 --- /dev/null +++ b/Dragon/src/MUSJJ2.f90 @@ -0,0 +1,372 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Compute the neutron flux and interface currents using the current +! iteration method for the multicell surfacic approximation. +! +!Copyright: +! Copyright (C) 2025 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version +! +!Author(s): A. Hebert +! +!Parameters: input +! IPAS total number of regions. +! NMCEL total number of cells in the domain. +! NMERGE total number of merged cells for which specific values +! of the neutron flux and reactions rates are required. +! Many cells with different position in the domain can +! be merged before the neutron flux calculation if they +! own the same generating cell (NMERGE.le.NMCEL). +! NGEN total number of generating cells. A generating cell is +! defined by its material and dimensions, irrespective of +! its position in the domain (NGEN.le.NMERGE). +! IJAT total number of distinct out-currents. +! NPIJ size of cellwise scattering-reduced collision probability matrices. +! NPIS size of cellwise scattering-reduced escape probability matrices. +! NPSS size of cellwise scattering-reduced transmission probability matrices. +! EPSJ stopping criterion for flux-current iterations. +! NUNKNO total number of unknowns in vectors SUNKNO and FUNKNO. +! NMIX nmber of out-currents (dimension of arrays MIX and DVX). +! NIFR nmber of in-currents (dimension of arrays IFR and ALB). +! SUNKNO input source vector. +! IMPX print flag (equal to 0 for no print). +! NMC_NODE offset of the first volume in each generating cell. +! NMC_SURF offset of the first boundary surface in each generating cell. +! IFR index-number of in-currents. +! ALB transmission/albedo associated with each in-current. +! INUM index-number of the merged cell associated to each cell. +! MIX index-number of out-currents. +! DVX weight associated with each out-current. +! Note: IFR, ALB, MIX and DVX contains information to rebuild +! the geometrical 'A' matrix. +! IGEN index-number of the generating cell associated with each +! merged cell. +! IMAC global merge index assigned to each node in the surfacic +! geometry. +! PIJW cellwise scattering-reduced collision probability matrices. +! PISW cellwise scattering-reduced escape probability matrices. +! PSJW cellwise scattering-reduced collision probability matrices +! for incoming neutrons. +! PSSW cellwise scattering-reduced transmission probability matrices. +! +!Parameters: input/output +! FUNKNO unknown vector. +! +!----------------------------------------------------------------------- +! +SUBROUTINE MUSJJ2(IPAS,NMCEL,NMERGE,NGEN,IJAT,NPIJ,NPIS,NPSS,EPSJ,NUNKNO, & + & NMIX,NIFR,FUNKNO,SUNKNO,IMPX,NMC_NODE,NMC_SURF,IFR,ALB,INUM,MIX,DVX, & + & IGEN,IMAC,PIJW,PISW,PSJW,PSSW) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + !---- + ! SUBROUTINE ARGUMENTS + !---- + INTEGER IPAS,NMCEL,NMERGE,NGEN,IJAT,NPIJ,NPIS,NUNKNO,NMIX,NIFR,IMPX, & + & NMC_NODE(NGEN+1),NMC_SURF(NGEN+1),IFR(NIFR),INUM(NMCEL),MIX(NMIX), & + & IGEN(NMERGE),IMAC(IPAS) + REAL EPSJ,FUNKNO(NUNKNO),SUNKNO(NUNKNO),ALB(NIFR),DVX(NMIX),PIJW(NPIJ), & + & PISW(NPIS),PSJW(NPIS),PSSW(NPSS) + !---- + ! LOCAL VARIABLES + !---- + REAL PIJ,PIS + LOGICAL LOGTES + PARAMETER (MAXIT=400,LACCFC=2,ICL1=3,ICL2=3) + !---- + ! ALLOCATABLE ARRAYS + !---- + INTEGER, DIMENSION(:), POINTER :: INDNMC + DOUBLE PRECISION, DIMENSION(:), POINTER :: CIT0 + DOUBLE PRECISION, DIMENSION(:,:), POINTER :: CITR,AITR + DOUBLE PRECISION, DIMENSION(:), POINTER :: WCURR + !---- + ! SCRATCH STORAGE ALLOCATION + !---- + ALLOCATE(INDNMC(NMERGE)) + ALLOCATE(CITR(3,IJAT),CIT0(IJAT),AITR(2,IJAT)) + ALLOCATE(WCURR(IJAT)) + ! + KNMC=0 + DO JKK=1,NMERGE + JKG=IGEN(JKK) + J2=NMC_NODE(JKG+1)-NMC_NODE(JKG) + INDNMC(JKK)=KNMC + KNMC=KNMC+J2 + ENDDO + ! + DO I=1,IJAT + WCURR(I)=1.0D0 + CIT0(I)=0.0D0 + CITR(1,I)=FUNKNO(IPAS+I) + ENDDO + !---- + ! COMPUTE PSJW * Q(*) CONTRIBUTION + !---- + DO IKK=1,NMERGE + IKG=IGEN(IKK) + I2=NMC_NODE(IKG+1)-NMC_NODE(IKG) + I3=NMC_SURF(IKG+1)-NMC_SURF(IKG) + IT=0 + DO IK=1,IKK-1 + IT=IT+(NMC_SURF(IGEN(IK)+1)-NMC_SURF(IGEN(IK))) + ENDDO + IPSJ=0 + DO IK=1,IKG-1 + IPSJ=IPSJ+(NMC_NODE(IK+1)-NMC_NODE(IK))*(NMC_SURF(IK+1)-NMC_SURF(IK)) + ENDDO + KNMC=INDNMC(IKK) + DO I=1,I2 + DO IC=1,I3 + JCC=MIX(IT+IC) + PBJ=PSJW(IPSJ+(I-1)*I3+IC) + CIT0(JCC)=CIT0(JCC)+PBJ*DVX(IT+IC)*SUNKNO(IMAC(KNMC+I)) + ENDDO + ENDDO + ENDDO + !---- + ! COMPUTE NORMALIZATION VECTOR WCURR + !---- + DO ICEL=1,NMCEL + IKK=INUM(ICEL) + IKG=IGEN(IKK) + J3=NMC_SURF(IKG+1)-NMC_SURF(IKG) + IT=0 + DO IK=1,IKK-1 + IT=IT+(NMC_SURF(IGEN(IK)+1)-NMC_SURF(IGEN(IK))) + ENDDO + IS=0 + DO IK=1,ICEL-1 + IS=IS+(NMC_SURF(IGEN(INUM(IK))+1)-NMC_SURF(IGEN(INUM(IK)))) + ENDDO + IPSS=0 + DO IK=1,IKG-1 + IPSS=IPSS+(NMC_SURF(IK+1)-NMC_SURF(IK))**2 + ENDDO + DO JC=1,J3 + J1=IFR(IS+JC) + DO IC=1,J3 + PSS=PSSW(IPSS+(JC-1)*J3+IC) + WCURR(J1)=WCURR(J1)-PSS*ALB(IS+JC)*DVX(IT+IC) + ENDDO + ENDDO + ENDDO + ! + ISTART=1 + TEST=0.0D0 + ITER=0 + 10 ITER=ITER+1 + IF(ITER.GT.MAXIT) THEN + WRITE(6,'(/47H MUSJJ2: *** WARNING *** MAXIMUM NUMBER OF ITER, & + & 15HATIONS REACHED.)') + GO TO 190 + ENDIF + IT3=MOD(ITER,3)+1 + IT2=MOD(ITER-1,3)+1 + IT1=MOD(ITER-2,3)+1 + CITR(IT3,:IJAT)=CIT0(:IJAT) + !---- + ! COMPUTE PSSW * J(-) CONTRIBUTION + !---- + DO ICEL=1,NMCEL + IKK=INUM(ICEL) + IKG=IGEN(IKK) + J3=NMC_SURF(IKG+1)-NMC_SURF(IKG) + IT=0 + DO IK=1,IKK-1 + IT=IT+(NMC_SURF(IGEN(IK)+1)-NMC_SURF(IGEN(IK))) + ENDDO + IS=0 + DO IK=1,ICEL-1 + IS=IS+(NMC_SURF(IGEN(INUM(IK))+1)-NMC_SURF(IGEN(INUM(IK)))) + ENDDO + IPSS=0 + DO IK=1,IKG-1 + IPSS=IPSS+(NMC_SURF(IK+1)-NMC_SURF(IK))**2 + ENDDO + DO JC=1,J3 + J1=IFR(IS+JC) + DO IC=1,J3 + J2=MIX(IT+IC) + PSS=PSSW(IPSS+(JC-1)*J3+IC) + CITR(IT3,J2)=CITR(IT3,J2)+PSS*ALB(IS+JC)*DVX(IT+IC)*CITR(IT2,J1) + ENDDO + ENDDO + ENDDO + !---- + ! NORMALIZATION + !---- + S1=0.0D0 + S2=0.0D0 + DO I=1,IJAT + S1=S1+WCURR(I)*CITR(IT3,I) + S2=S2+CIT0(I) + ENDDO + ZNORM=S2/S1 + IF(ZNORM.LT.0.0D0) ZNORM=1.0D0 + CITR(IT3,:IJAT)=CITR(IT3,:IJAT)*ZNORM + !---- + ! ONE/TWO PARAMETER ACCELERATION + !---- + ALP=1.0D0 + BET=0.0D0 + LOGTES=(1+MOD(ITER-ISTART,ICL1+ICL2).GT.ICL1) + IF(LOGTES) THEN + AITR(1,:IJAT)=CITR(IT3,:IJAT)-CITR(IT2,:IJAT) + AITR(2,:IJAT)=CITR(IT2,:IJAT)-CITR(IT1,:IJAT) + DO ICEL=1,NMCEL + IKK=INUM(ICEL) + IKG=IGEN(IKK) + J3=NMC_SURF(IKG+1)-NMC_SURF(IKG) + IT=0 + DO IK=1,IKK-1 + IT=IT+(NMC_SURF(IGEN(IK)+1)-NMC_SURF(IGEN(IK))) + ENDDO + IS=0 + DO IK=1,ICEL-1 + IS=IS+(NMC_SURF(IGEN(INUM(IK))+1)-NMC_SURF(IGEN(INUM(IK)))) + ENDDO + IPSS=0 + DO IK=1,IKG-1 + IPSS=IPSS+(NMC_SURF(IK+1)-NMC_SURF(IK))**2 + ENDDO + DO JC=1,J3 + J1=IFR(IS+JC) + DO IC=1,J3 + J2=MIX(IT+IC) + PSS=PSSW(IPSS+(JC-1)*J3+IC)*ALB(IS+JC)*DVX(IT+IC) + AITR(1,J2)=AITR(1,J2)-PSS*(CITR(IT3,J1)-CITR(IT2,J1)) + AITR(2,J2)=AITR(2,J2)-PSS*(CITR(IT2,J1)-CITR(IT1,J1)) + ENDDO + ENDDO + ENDDO + IF((LACCFC.EQ.1).OR.(MOD(ITER-ISTART,ICL1+ICL2).EQ.ICL1)) THEN + S1=0.0D0 + S2=0.0D0 + DO I=1,IJAT + S1=S1+(CITR(IT3,I)-CITR(IT2,I))*AITR(1,I) + S2=S2+AITR(1,I)*AITR(1,I) + ENDDO + IF(S2.EQ.0.0D0) THEN + ISTART=ITER+1 + ELSE + ALP=S1/S2 + IF(ALP.LE.0.0D0) THEN + ISTART=ITER+1 + ALP=1.0D0 + ENDIF + ENDIF + DO I=1,IJAT + CITR(IT3,I)=CITR(IT2,I)+ALP*(CITR(IT3,I)-CITR(IT2,I)) + ENDDO + ELSE IF(LACCFC.EQ.2) THEN + S1=0.0D0 + S2=0.0D0 + S3=0.0D0 + S4=0.0D0 + S5=0.0D0 + DO I=1,IJAT + S1=S1+(CITR(IT3,I)-CITR(IT2,I))*AITR(1,I) + S2=S2+AITR(1,I)*AITR(1,I) + S3=S3+(CITR(IT3,I)-CITR(IT2,I))*AITR(2,I) + S4=S4+AITR(1,I)*AITR(2,I) + S5=S5+AITR(2,I)*AITR(2,I) + ENDDO + DET=S2*S5-S4*S4 + IF(DET.EQ.0.0D0) THEN + ISTART=ITER+1 + ELSE + ALP=(S5*S1-S4*S3)/DET + BET=(S2*S3-S4*S1)/DET + IF(ALP.LE.0.0D0) THEN + ISTART=ITER+1 + ALP=1.0D0 + BET=0.0D0 + ENDIF + ENDIF + DO I=1,IJAT + CITR(IT3,I)=CITR(IT2,I)+ALP*(CITR(IT3,I)-CITR(IT2,I))+ & + & BET*(CITR(IT2,I)-CITR(IT1,I)) + ENDDO + ENDIF + ENDIF + !---- + ! CHECK THE CONVERGENCE ERROR + !---- + ERR1=0.0D0 + ERR2=0.0D0 + DO I=1,IJAT + ERR1=MAX(ERR1,ABS(CITR(IT3,I)-CITR(IT2,I))) + ERR2=MAX(ERR2,ABS(CITR(IT3,I))) + ENDDO + IF(IMPX.GT.3) WRITE(6,'(30H MUSJJ2: CURRENT ITERATION NB.,I4, & + & 7H ERROR=,1P,E10.3,5H OVER,E10.3,15H NORMALIZATION=,E10.3, & + & 14H ACCELERATION=,2E11.3,1H.)') ITER,ERR1,ERR2,ZNORM,ALP,BET/ALP + IF(ITER.EQ.1) TEST=ERR1/ERR2 + IF((ITER.GT.20).AND.(ERR1/ERR2.GT.TEST)) THEN + WRITE(6,'(/50H MUSJJ2: *** WARNING *** CONVERGENCE DIFFICULTIES.)') + GO TO 190 + ENDIF + IF(LOGTES.OR.(ERR1.GT.EPSJ*ERR2)) GO TO 10 + IF(IMPX.GT.2) WRITE(6,'(40H MUSJJ2: CURRENT CONVERGENCE AT ITERATIO, & + & 5HN NB.,I4,7H ERROR=,1P,E10.3,5H OVER,E10.3,1H.)') ITER,ERR1,ERR2 + ! + 190 FUNKNO(:IPAS)=0.0 + DO I=1,IJAT + FUNKNO(IPAS+I)=REAL(CITR(IT3,I)) + ENDDO + !---- + ! COMPUTE PISW * J(-) CONTRIBUTION + !---- + DO ICEL=1,NMCEL + IKK=INUM(ICEL) + IKG=IGEN(IKK) + I2=NMC_NODE(IKG+1)-NMC_NODE(IKG) + I3=NMC_SURF(IKG+1)-NMC_SURF(IKG) + IS=0 + DO IK=1,ICEL-1 + IS=IS+(NMC_SURF(IGEN(INUM(IK))+1)-NMC_SURF(IGEN(INUM(IK)))) + ENDDO + IPIS=0 + DO IK=1,IKG-1 + IPIS=IPIS+(NMC_NODE(IK+1)-NMC_NODE(IK))*(NMC_SURF(IK+1)-NMC_SURF(IK)) + ENDDO + KNMC=INDNMC(IKK) + DO J=1,I2 + DO JC=1,I3 + J1=IFR(IS+JC) + PIS=PISW(IPIS+(JC-1)*I2+J) + FUNKNO(IMAC(KNMC+J))=FUNKNO(IMAC(KNMC+J))+PIS*ALB(IS+JC)*FUNKNO(IPAS+J1) + ENDDO + ENDDO + ENDDO + !---- + ! COMPUTE PIJW * Q(*) CONTRIBUTION + !---- + DO IKK=1,NMERGE + IKG=IGEN(IKK) + I2=NMC_NODE(IKG+1)-NMC_NODE(IKG) + IPIJ=0 + DO IK=1,IKG-1 + IPIJ=IPIJ+(NMC_NODE(IK+1)-NMC_NODE(IK))**2 + ENDDO + KNMC=INDNMC(IKK) + DO I=1,I2 + DO J=1,I2 + PIJ=PIJW(IPIJ+(I-1)*I2+J) + FUNKNO(IMAC(KNMC+J))=FUNKNO(IMAC(KNMC+J))+PIJ*SUNKNO(IMAC(KNMC+I)) + ENDDO + ENDDO + ENDDO +!---- +! SCRATCH STORAGE DEALLOCATION +!---- + DEALLOCATE(WCURR) + DEALLOCATE(AITR,CIT0,CITR) + DEALLOCATE(INDNMC) + RETURN + END diff --git a/Dragon/src/MUSP.f90 b/Dragon/src/MUSP.f90 new file mode 100644 index 0000000..6df0331 --- /dev/null +++ b/Dragon/src/MUSP.f90 @@ -0,0 +1,457 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Calculation of the collision probabilities for the multicell +! surfacic approximation. +! +!Copyright: +! Copyright (C) 2025 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version +! +!Author(s): A. Hebert +! +!Parameters: input +! IPTRK pointer to the tracking (L_TRACK signature). +! IFTRAK tracking file unit. +! IMPX print flag (equal to zero for no print). +! NREGIO total number of merged blocks for which specific values +! of the neutron flux and reactions rates are required. +! NBMIX number of mixtures (NBMIX=max(MAT(i))). +! MAT index-number of the mixture type assigned to each volume. +! VOL volumes. +! SIGT0 total macroscopic cross sections ordered by mixture. +! SIGW0 P0 within-group scattering macroscopic cross sections +! ordered by mixture. +! NELPIJ number of elements in pij matrix. +! ILK leakage flag (=.true. if neutron leakage through external +! boundary is present). +! NBATCH number of tracks dispached in eack OpenMP core. +! TITREC title. +! NALBP number of multigroup physical albedos. +! ALBP multigroup physical albedos. +! +!Parameters: output +! PIJ reduced and symmetrized collision probabilities. +! +!----------------------------------------------------------------------- +! +SUBROUTINE MUSP(IPTRK,IFTRAK,IMPX,NREGIO,NBMIX,MAT,VOL,SIGT0,SIGW0,NELPIJ, & + & ILK,NBATCH,TITREC,NALBP,ALBP,PIJ) + USE GANLIB + !---- + ! SUBROUTINE ARGUMENTS + !---- + LOGICAL ILK + TYPE(C_PTR) IPTRK + INTEGER IFTRAK,IMPX,NREGIO,NBMIX,MAT(NREGIO),NELPIJ,NBATCH,NALBP + REAL VOL(NREGIO),SIGT0(0:NBMIX),SIGW0(0:NBMIX),PIJ(NELPIJ),ALBP(NALBP) + CHARACTER TITREC*72 + !---- + ! LOCAL VARIABLES + !---- + PARAMETER (EPS1=1.0E-4,NSTATE=40) + TYPE(C_PTR) JPTRK,KPTRK + INTEGER ISTATT(NSTATE),NNPSYS(1) + CHARACTER TITRE2*72 + logical LSKIP + !---- + ! ALLOCATABLE ARRAYS + !---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MATALB,NMC_NODE,NMC_SURF,MAT2,IGEN,INUM, & + & IFR,MIX,IMAC + REAL, ALLOCATABLE, DIMENSION(:) :: SIGT2,SIGW2,PIJW,PISW,PSJW,PSSW,WORK,ALB,DVX + REAL, ALLOCATABLE, DIMENSION(:,:) :: VOLSUR,PP,PSSB + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: DPROB,DPROBX + ! + IND(I,J) = MAX(I+J3+1,J+J3+1)*(MAX(I+J3+1,J+J3+1)-1)/2 & + & + MIN(I+J3+1,J+J3+1) + ! + WPR(I,J)= REAL(DPROB( IND(I,J),1 ) / DPROB( IND(I,0),1 )) + !---- + ! BICKLEY FLAG + !---- + SAVE IBICKL + DATA IBICKL/0/ + !---- + ! RECOVER BICKLEY TABLES + !---- + IF(IBICKL.EQ.0) THEN + CALL XDRTA2 + IBICKL=1 + ENDIF + !---- + ! RECOVER SALT SPECIFIC PARAMETERS + !---- + REWIND IFTRAK + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATT) + IF(NREGIO.NE.ISTATT(1)) THEN + CALL XABORT('MUSP: STATE VECTOR HAS INVALID # OF ZONES.') + ENDIF + NMACRO=ISTATT(24) ! NGEN + NMCEL=NMACRO + NMERGE=NMACRO + NGEN=NMACRO + ALLOCATE(IGEN(NMERGE),INUM(NMCEL)) + DO IK=1,NMERGE + IGEN(IK)=IK + ENDDO + DO IK=1,NMCEL + INUM(IK)=IK + ENDDO + IF(NMACRO.EQ.0) CALL XABORT('MUSP: MUST MODULE TRACKING IS MANDATORY.') + ALLOCATE(NMC_NODE(NMACRO+1),NMC_SURF(NMACRO+1)) + JPTRK=LCMGID(IPTRK,'MACRO-TRACK') + CALL LCMGET(IPTRK,'NMC_NODE',NMC_NODE) + CALL LCMGET(IPTRK,'NMC_SURF',NMC_SURF) + NMIX=NMC_SURF(NMACRO+1) + NIFR=NMC_SURF(NMACRO+1) + !---- + ! LOOP OVER MACRO GEOMETRIES AND COMPUTE PIJ MATRICES USING EXCELP + !---- + J1=0 + NMIX=0 + NPIJ=0 + NPIS=0 + NPSS=0 + DO IMACRO=1,NMACRO + J2=NMC_NODE(IMACRO+1)-NMC_NODE(IMACRO) + J3=NMC_SURF(IMACRO+1)-NMC_SURF(IMACRO) + J1=J1+J2 + NMIX=NMIX+J3 + NPIJ=NPIJ+J2*J2 + NPIS=NPIS+J2*J3 + NPSS=NPSS+J3*J3 + ENDDO + IF(J1.NE.NREGIO) CALL XABORT('MUSP: INVALID NREGIO.') + IF(NMIX.NE.NMC_SURF(NMACRO+1)) CALL XABORT('MUSP: INVALID NMIX.') + ALLOCATE(PIJW(NPIJ),PISW(NPIS),PSJW(NPIS),PSSW(NPSS)) + J1=0 + IPIJ=0 + IPIS=0 + IPSS=0 + DO IMACRO=1,NMACRO + J2=NMC_NODE(IMACRO+1)-NMC_NODE(IMACRO) + J3=NMC_SURF(IMACRO+1)-NMC_SURF(IMACRO) + N2PRO=(J2+J3+1)**2 + WRITE(TITRE2,'(A,9H -- MACRO,I5.5)') TRIM(TITREC),IMACRO + KPTRK=LCMGIL(JPTRK,IMACRO) + KNORM=4 ! use HELIOS-type normalization + NNPSYS(1)=1 + ALLOCATE(MAT2(J2),SIGT2(J2),SIGW2(J2)) + ALLOCATE(MATALB(-J3:J2),VOLSUR(-J3:J2,1),DPROB(N2PRO,1),DPROBX(N2PRO,1)) + CALL LCMGET(KPTRK,'MATCOD',MAT2) + CALL EXCELP(KPTRK,IFTRAK,IMPX,J3,J2,NBMIX,MAT2,KNORM,SIGT0,1,N2PRO, & + & 1,NNPSYS(1),NBATCH,TITRE2,NALBP,ALBP,MATALB,VOLSUR,DPROB,DPROBX) + !---- + ! CHECK IF SCATTERING REDUCTION IS REQUIRED + !---- + DO I=1,J2 + SIGT2(I)=SIGT0(MAT2(I)) ! sigt by node + SIGW2(I)=SIGW0(MAT2(I)) ! sigw by node + ENDDO + LSKIP=.TRUE. + DO I=1,J2 + LSKIP=LSKIP.AND.(SIGW2(I).EQ.0.0) + ENDDO + !---- + ! SCATTERING REDUCTION IF LSKIP=.FALSE. + !---- + IF(LSKIP) THEN + ! DO NOT PERFORM SCATTERING REDUCTION. + DO I=1,J2 + DO J=1,J2 + IF(SIGT2(J).EQ.0.0) THEN + PIJW(IPIJ+(J-1)*J2+I)=WPR(I,J) + ELSE + PIJW(IPIJ+(J-1)*J2+I)=WPR(I,J)/SIGT2(J) + ENDIF + ENDDO + ENDDO + DO I=1,J2 + DO JC=1,J3 + PISW(IPIS+(JC-1)*J2+I)=WPR(I,-JC) + IF(SIGT2(I).EQ.0.0) THEN + PSJW(IPIS+(I-1)*J3+JC)=WPR(-JC,I) + ELSE + PSJW(IPIS+(I-1)*J3+JC)=WPR(-JC,I)/SIGT2(I) + ENDIF + ENDDO + ENDDO + DO IC=1,J3 + DO JC=1,J3 + PSSW(IPSS+(JC-1)*J3+IC)=WPR(-IC,-JC) + ENDDO + ENDDO + ELSE + ! COMPUTE THE SCATTERING-REDUCED COLLISION AND ESCAPE MATRICES. + DO I=1,J2 + DO J=1,J2 + IF(SIGT2(J).EQ.0.0) THEN + PIJW(IPIJ+(J-1)*J2+I)=0.0 + ELSE + PIJW(IPIJ+(J-1)*J2+I)=-WPR(I,J)*SIGW2(J)/SIGT2(J) + ENDIF + ENDDO + PIJW(IPIJ+(I-1)*J2+I)=1.0+PIJW(IPIJ+(I-1)*J2+I) + ENDDO + CALL ALINV(J2,PIJW(IPIJ+1),J2,IER) + IF(IER.NE.0) CALL XABORT('MUSP: SINGULAR MATRIX.') + ALLOCATE(WORK(J2)) + DO I=1,J2 + DO K=1,J2 + WORK(K)=PIJW(IPIJ+(K-1)*J2+I) + ENDDO + DO J=1,J2 + WGAR=0.0 + DO K=1,J2 + IF(SIGT2(J).EQ.0.0) THEN + WGAR=WGAR+WORK(K)*WPR(K,J) + ELSE + WGAR=WGAR+WORK(K)*WPR(K,J)/SIGT2(J) + ENDIF + ENDDO + PIJW(IPIJ+(J-1)*J2+I)=WGAR + ENDDO + DO JC=1,J3 + WGAR=0.0 + DO K=1,J2 + WGAR=WGAR+WORK(K)*WPR(K,-JC) + ENDDO + PISW(IPIS+(JC-1)*J2+I)=WGAR + ENDDO + ENDDO + DEALLOCATE(WORK) + ! + ! COMPUTE THE SCATTERING-REDUCED COLLISION PROBABILITY MATRIX + ! FOR INCOMING NEUTRONS. + DO IC=1,J3 + DO J=1,J2 + IF(SIGT2(J).EQ.0.0) THEN + WGAR=WPR(-IC,J) + ELSE + WGAR=WPR(-IC,J)/SIGT2(J) + ENDIF + DO K=1,J2 + IF(SIGT2(K).NE.0.0) THEN + WGAR=WGAR+WPR(-IC,K)*PIJW(IPIJ+(J-1)*J2+K)*SIGW2(K)/SIGT2(K) + ENDIF + ENDDO + PSJW(IPIS+(J-1)*J3+IC)=WGAR + ENDDO + ENDDO + ! + ! COMPUTE THE SCATTERING-REDUCED TRANSMISSION PROBABILITY MATRIX. + DO IC=1,J3 + DO JC=1,J3 + WGAR=WPR(-IC,-JC) + DO K=1,J2 + IF(SIGT2(K).NE.0.0) THEN + WGAR=WGAR+WPR(-IC,K)*PISW(IPIS+(JC-1)*J2+K)*SIGW2(K)/SIGT2(K) + ENDIF + ENDDO + PSSW(IPSS+(JC-1)*J3+IC)=WGAR + ENDDO + ENDDO + ENDIF + DEALLOCATE(DPROBX,DPROB,VOLSUR,MATALB) + IF(IMPX.GE.8) THEN + IF(LSKIP) THEN + IN=1 + ELSE + IN=2 + ENDIF + CALL SYBPRX(IN,J3,J2,IMACRO,SIGT2,SIGW2,PIJW(IPIJ+1),PISW(IPIS+1), & + & PSJW(IPIS+1),PSSW(IPSS+1)) + ENDIF + DEALLOCATE(SIGW2,SIGT2,MAT2) + J1=J1+J2 + IPIJ=IPIJ+J2*J2 + IPIS=IPIS+J2*J3 + IPSS=IPSS+J3*J3 + ENDDO + ! end of SYB004 equivalent + !---- + ! COMPUTE THE GLOBAL SCATTERING-REDUCED COLLISION PROBABILITY MATRIX + !---- + ALLOCATE(IMAC(NREGIO),PP(NREGIO,NREGIO)) + CALL LCMGET(IPTRK,'MERGE_MACRO',IMAC) + PP(:NREGIO,:NREGIO)=0.0 + IPIJ=0 + DO JKG=1,NGEN + J2=NMC_NODE(JKG+1)-NMC_NODE(JKG) + I1=0 + DO IKK=1,NMERGE + IKG=IGEN(IKK) + I2=NMC_NODE(IKG+1)-NMC_NODE(IKG) + IF(IKG.EQ.JKG) THEN + DO J=1,J2 + DO I=1,J2 + PP(IMAC(I1+I),IMAC(I1+J))=PIJW(IPIJ+(J-1)*J2+I) + ENDDO + ENDDO + ENDIF + I1=I1+I2 + ENDDO + IPIJ=IPIJ+J2*J2 + ENDDO + !---- + ! COMPUTE PSSB=A*(I-PSS*A)**-1 + !---- + ALLOCATE(IFR(NIFR),ALB(NIFR),MIX(NMIX),DVX(NMIX)) + CALL LCMGET(IPTRK,'IFR',IFR) + CALL LCMGET(IPTRK,'ALB',ALB) + CALL LCMGET(IPTRK,'MIX',MIX) + CALL LCMGET(IPTRK,'DVX',DVX) + IJAT=MAXVAL(MIX) + ALLOCATE(PSSB(IJAT,2*IJAT)) + PSSB(:IJAT,:2*IJAT)=0.0 + DO I=1,IJAT + PSSB(I,I)=1.0 + ENDDO + DO ICEL=1,NMCEL + IKK=INUM(ICEL) + IKG=IGEN(IKK) + J3=NMC_SURF(IKG+1)-NMC_SURF(IKG) + IT=0 + DO IK=1,IKK-1 + IT=IT+(NMC_SURF(IGEN(IK)+1)-NMC_SURF(IGEN(IK))) + ENDDO + IS=0 + DO IK=1,ICEL-1 + IS=IS+(NMC_SURF(IGEN(INUM(IK))+1)-NMC_SURF(IGEN(INUM(IK)))) + ENDDO + IPSS=0 + DO IK=1,IKG-1 + IPSS=IPSS+(NMC_SURF(IK+1)-NMC_SURF(IK))**2 + ENDDO + DO JC=1,J3 + J1=IFR(IS+JC) + J2=MIX(IT+JC) + ALBEDO=ALB(IS+JC) + PSSB(J1,IJAT+J2)=PSSB(J1,IJAT+J2)+ALBEDO*DVX(IT+JC) + DO IC=1,J3 + J2=MIX(IT+IC) + PSSB(J1,J2)=PSSB(J1,J2)-PSSW(IPSS+(JC-1)*J3+IC)*ALBEDO*DVX(IT+IC) + ENDDO + ENDDO + ENDDO + CALL ALSB(IJAT,IJAT,PSSB,IER,IJAT) + IF(IER.NE.0) CALL XABORT('MUSP: SINGULAR MATRIX.') + !---- + ! COMPUTATION OF PISW*PSSB*PSJW + !---- + I1=0 + DO IKK=1,NMERGE + IKG=IGEN(IKK) + I2=NMC_NODE(IKG+1)-NMC_NODE(IKG) + I3=NMC_SURF(IKG+1)-NMC_SURF(IKG) + IT=0 + DO IK=1,IKK-1 + IT=IT+(NMC_SURF(IGEN(IK)+1)-NMC_SURF(IGEN(IK))) + ENDDO + IPIS=0 + DO IK=1,IKG-1 + IPIS=IPIS+(NMC_NODE(IK+1)-NMC_NODE(IK))*(NMC_SURF(IK+1)-NMC_SURF(IK)) + ENDDO + DO I=1,I2 + DO IC=1,I3 + ICC=MIX(IT+IC) + ZZZ=PISW(IPIS+(IC-1)*I2+I)*SIGN(1.0,DVX(IT+IC)) + J1=0 + DO JKK=1,NMERGE + JKG=IGEN(JKK) + J2=NMC_NODE(JKG+1)-NMC_NODE(JKG) + J3=NMC_SURF(JKG+1)-NMC_SURF(JKG) + JT=0 + DO IK=1,JKK-1 + JT=JT+(NMC_SURF(IGEN(IK)+1)-NMC_SURF(IGEN(IK))) + ENDDO + IPSJ=0 + DO IK=1,JKG-1 + IPSJ=IPSJ+(NMC_NODE(IK+1)-NMC_NODE(IK))*(NMC_SURF(IK+1)-NMC_SURF(IK)) + ENDDO + DO J=1,J2 + DO JC=1,J3 + JCC=MIX(JT+JC) + PBJ=PSJW(IPSJ+(J-1)*J3+JC) + PP(IMAC(I1+I),IMAC(J1+J))=PP(IMAC(I1+I),IMAC(J1+J))+ZZZ*DVX(JT+JC)* & + & PSSB(JCC,IJAT+ICC)*PBJ + ENDDO + ENDDO + J1=J1+J2 + ENDDO + ENDDO + ENDDO + I1=I1+I2 + ENDDO + ! end of SYBRX3 equivalent + DEALLOCATE(PSSB,DVX,MIX,ALB,IFR) + DEALLOCATE(PSSW,PSJW,PISW,PIJW) + DEALLOCATE(NMC_SURF,NMC_NODE) + DEALLOCATE(INUM,IGEN) + ! + IF(IMPX.GE.7) THEN + WRITE (6,170) (J,J=1,NREGIO) + DO I=1,NREGIO + WRITE (6,180) I,(PP(I,J),J=1,NREGIO) + ENDDO + WRITE (6,'(//)') + ENDIF + IF((IMPX.GE.10).OR.(IMPX.LT.0)) THEN + ! CHECK THE RECIPROCITY CONDITIONS. + VOLTOT=0.0 + DO I=1,NREGIO + VOLTOT=VOLTOT+VOL(I) + ENDDO + VOLTOT=VOLTOT/REAL(NREGIO) + WRK=0.0 + DO I=1,NREGIO + DO J=1,NREGIO + AAA=PP(I,J)*VOL(I) + BBB=PP(J,I)*VOL(J) + WRK=MAX(WRK,ABS(AAA-BBB)/VOLTOT) + ENDDO + ENDDO + IF(WRK.GE.EPS1) WRITE (6,150) WRK + IF(WRK.GE.EPS1) CALL XABORT('MUSP: non symmetric matrices.') + ! CHECK THE CONSERVATION CONDITIONS. + IF(.NOT.ILK) THEN + WRK=0.0 + DO I=1,NREGIO + F1=1.0 + DO J=1,NREGIO + AAA=PP(I,J) + F1=F1-AAA*(SIGT0(MAT(J))-SIGW0(MAT(J))) + ENDDO + WRK=AMAX1(WRK,ABS(F1)) + ENDDO + IF(WRK.GE.EPS1) WRITE (6,160) WRK + IF(WRK.GE.EPS1) CALL XABORT('MUSP: non conservative matrices.') + ENDIF + ENDIF + ! + IC=0 + DO IKK=1,NREGIO + IOF=(IKK-1)*NREGIO + DO JKK=1,IKK + IC=IC+1 + PIJ(IC)=PP(JKK,IKK)*VOL(JKK) + ENDDO + ENDDO + DEALLOCATE(IMAC,PP) + RETURN + ! + 150 FORMAT (/56H MUSP: THE SCATTERING-REDUCED PIJ DO NOT MEET THE RECIPR, & + & 25HOCITY CONDITIONS. RECIP =,1P,E10.3/) + 160 FORMAT (/56H MUSP: THE SCATTERING-REDUCED PIJ DO NOT MEET THE CONSER, & + & 25HVATION CONDITIONS. LEAK =,1P,E10.3/) + 170 FORMAT (//47H MUSP: SCATTERING-REDUCED COLLISION PROBABILITY, & + & 9H MATRIX ://(11X,2HJ=,I4,:,5X,2HJ=,I4,:,5X,2HJ=,I4,:,5X,2HJ=, & + & I4,:,5X,2HJ=,I4,:,5X,2HJ=,I4,:,5X,2HJ=,I4,:,5X,2HJ=,I4,:,5X,2HJ=, & + & I4,:,5X,2HJ=,I4,:,5X,2HJ=,I4)) + 180 FORMAT (3H I=,I4,2H: ,1P,11E11.3/(9X,11E11.3)) +END SUBROUTINE MUSP diff --git a/Dragon/src/Makefile b/Dragon/src/Makefile new file mode 100644 index 0000000..c675c26 --- /dev/null +++ b/Dragon/src/Makefile @@ -0,0 +1,237 @@ +#--------------------------------------------------------------------------- +# +# Makefile for building the Dragon library and load module +# Author : A. Hebert (2018-5-10) +# +#--------------------------------------------------------------------------- +# +ARCH = $(shell uname -m) +ifneq (,$(filter $(ARCH),aarch64 arm64)) + nbit = +else + ifneq (,$(filter $(ARCH),i386 i686)) + nbit = -m32 + else + nbit = -m64 + endif +endif + +DIRNAME = $(shell uname -sm | sed 's/[ ]/_/') +OS = $(shell uname -s | cut -d"_" -f1) +opt = -O -g +PREPRO = cpp +ifeq ($(openmp),1) + COMP = -fopenmp + PREPRO = cpp -D_OPENMP +else + COMP = +endif + +ifeq ($(intel),1) + fcompiler = ifort + ccompiler = icc +else + ifeq ($(nvidia),1) + fcompiler = nvfortran + ccompiler = nvc + else + ifeq ($(llvm),1) + fcompiler = flang-new + ccompiler = clang + else + fcompiler = gfortran + ccompiler = gcc + endif + endif +endif + +ifeq ($(OS),AIX) + python_version_major := 2 +else + python_version_full := $(wordlist 2,4,$(subst ., ,$(shell python --version 2>&1))) + python_version_major := $(word 1,${python_version_full}) + ifneq ($(python_version_major),2) + python_version_major := 3 + endif +endif + +ifeq ($(OS),Darwin) + ifeq ($(openmp),1) + ccompiler = gcc-14 + endif + F90 = $(fcompiler) + C = $(ccompiler) + FLAGS = -DLinux -DUnix + CFLAGS = -Wall $(nbit) -fPIC + FFLAGS = $(nbit) -fPIC + FFLAG77 = $(nbit) -fPIC + LFLAGS = $(nbit) +else +ifeq ($(OS),Linux) + F90 = $(fcompiler) + C = $(ccompiler) + FLAGS = -DLinux -DUnix + CFLAGS = -Wall $(nbit) -fPIC + FFLAGS = $(nbit) -fPIC + FFLAG77 = $(nbit) -fPIC + LFLAGS = $(nbit) +else +ifeq ($(OS),CYGWIN) + F90 = $(fcompiler) + C = $(ccompiler) + FLAGS = -DLinux -DUnix + CFLAGS = -Wall $(nbit) -fPIC + FFLAGS = $(nbit) -fPIC + FFLAG77 = $(nbit) -fPIC + LFLAGS = $(nbit) +else +ifeq ($(OS),SunOS) + fcompiler = + MAKE = gmake + F90 = f90 + C = cc + PREPRO = /usr/lib/cpp + FLAGS = -DSunOS -DUnix + CFLAGS = $(nbit) + FFLAGS = $(nbit) -s -ftrap=%none + FFLAG77 = $(nbit) -s -ftrap=%none + LFLAGS = $(nbit) +else +ifeq ($(OS),AIX) + fcompiler = + opt = -O4 + MAKE = gmake + DIRNAME = AIX + F90 = xlf90 + C = cc + FLAGS = -DAIX -DUnix + CFLAGS = -qstrict + FFLAGS = -qstrict -qmaxmem=-1 -qsuffix=f=f90 + FFLAG77 = -qstrict -qmaxmem=-1 -qxlf77=leadzero -qfixed + LFLAGS = -qstrict -bmaxdata:0x80000000 -qipa +else + $(error $(OS) is not a valid OS) +endif +endif +endif +endif +endif +ifeq ($(fcompiler),gfortran) + ifneq (,$(filter $(ARCH),i386 i686 x86_64)) + summary = + else + summary = -ffpe-summary=none + endif + ifeq ($(OS),Darwin) + summary = -ffpe-summary=none + endif + FFLAGS += -Wall $(summary) + FFLAG77 += -Wall -frecord-marker=4 $(summary) +endif + +ifeq ($(intel),1) + FFLAGS = -fPIC + FFLAG77 = -fPIC + lib = ../lib/$(DIRNAME)_intel + libUtl = ../../Utilib/lib/$(DIRNAME)_intel + libGan = ../../Ganlib/lib/$(DIRNAME)_intel + libTri = ../../Trivac/lib/$(DIRNAME)_intel + bin = ../bin/$(DIRNAME)_intel + lib_module = ../lib/$(DIRNAME)_intel/modules + INCLUDE = -I../../Ganlib/lib/$(DIRNAME)_intel/modules/ +else + ifeq ($(nvidia),1) + lib = ../lib/$(DIRNAME)_nvidia + libUtl = ../../Utilib/lib/$(DIRNAME)_nvidia + libGan = ../../Ganlib/lib/$(DIRNAME)_nvidia + libTri = ../../Trivac/lib/$(DIRNAME)_nvidia + bin = ../bin/$(DIRNAME)_nvidia + lib_module = ../lib/$(DIRNAME)_nvidia/modules + INCLUDE = -I../../Ganlib/lib/$(DIRNAME)_nvidia/modules/ + else + ifeq ($(llvm),1) + lib = ../lib/$(DIRNAME)_llvm + libUtl = ../../Utilib/lib/$(DIRNAME)_llvm + libGan = ../../Ganlib/lib/$(DIRNAME)_llvm + libTri = ../../Trivac/lib/$(DIRNAME)_llvm + bin = ../bin/$(DIRNAME)_llvm + lib_module = ../lib/$(DIRNAME)_llvm/modules + INCLUDE = -I../../Ganlib/lib/$(DIRNAME)_llvm/modules/ + FFLAGS += -mmlir -fdynamic-heap-array + LFLAGS += -lclang_rt.osx + else + lib = ../lib/$(DIRNAME) + libUtl = ../../Utilib/lib/$(DIRNAME) + libGan = ../../Ganlib/lib/$(DIRNAME) + libTri = ../../Trivac/lib/$(DIRNAME) + bin = ../bin/$(DIRNAME) + lib_module = ../lib/$(DIRNAME)/modules + INCLUDE = -I../../Ganlib/lib/$(DIRNAME)/modules/ + endif +endif +endif + +ifeq ($(hdf5),1) + FLAGS += -DHDF5_LIB -I${HDF5_INC} + FFLAGS += -I${HDF5_INC} + LFLAGS += -L${HDF5_API} -lhdf5 +endif + +SRCC = $(shell ls *.c) +SRC77 = $(shell ls *.f) +SRCF77 = $(shell ls *.F) +ifeq ($(python_version_major),2) + SRC90 = $(shell python ../../script/make_depend.py *.f90) +else + SRC90 = $(shell python3 ../../script/make_depend_py3.py *.f90) +endif +OBJC = $(SRCC:.c=.o) +OBJ90 = $(SRC90:.f90=.o) +OBJ77 = $(SRC77:.f=.o) +OBJF77 = $(SRCF77:.F=.o) +all : sub-make Dragon +ifeq ($(openmp),1) + @echo 'Dragon: openmp is defined' +endif +ifeq ($(intel),1) + @echo 'Dragon: intel is defined' +endif +ifeq ($(nvidia),1) + @echo 'Dragon: nvidia is defined' +endif +ifeq ($(llvm),1) + @echo 'Dragon: llvm is defined' +endif +ifeq ($(hdf5),1) + @echo 'Dragon: hdf5 is defined' +endif +sub-make: + $(MAKE) openmp=$(openmp) intel=$(intel) nvidia=$(nvidia) llvm=$(llvm) hdf5=$(hdf5) -C ../../Trivac/src +%.o : %.c + $(C) $(CFLAGS) $(opt) $(COMP) -c $< -o $@ +%.o : %.f90 + $(F90) $(FFLAGS) $(opt) $(COMP) $(INCLUDE) -c $< -o $@ +%.o : %.f + @/bin/rm -f temp.f + $(F90) $(FFLAG77) $(opt) $(COMP) $(INCLUDE) -c $< -o $@ +%.o : %.F + $(PREPRO) -P -W -traditional $(FLAGS) $< temp.f + $(F90) $(FFLAG77) $(opt) $(COMP) $(INCLUDE) -c temp.f -o $@ + /bin/rm temp.f +$(lib_module)/: + mkdir -p $(lib_module)/ +$(lib)/: $(lib_module)/ + mkdir -p $(lib)/ +libDragon.a: $(OBJC) $(OBJ90) $(OBJ77) $(OBJF77) $(lib)/ + ar r $@ $(OBJC) $(OBJ90) $(OBJ77) $(OBJF77) + cp $@ $(lib)/$@ + cp *.mod $(lib_module) +$(bin)/: + mkdir -p $(bin)/ +Dragon: libDragon.a DRAGON.o $(bin)/ sub-make + $(F90) $(opt) $(COMP) DRAGON.o $(lib)/libDragon.a $(libTri)/libTrivac.a \ + $(libUtl)/libUtilib.a $(libGan)/libGanlib.a $(LFLAGS) -o Dragon + cp $@ $(bin)/$@ +clean: + $(MAKE) -C ../../Trivac/src clean + /bin/rm -f *.o *.mod *.a sub-make temp.* Dragon diff --git a/Dragon/src/NUMER3.f b/Dragon/src/NUMER3.f new file mode 100644 index 0000000..0d73db0 --- /dev/null +++ b/Dragon/src/NUMER3.f @@ -0,0 +1,745 @@ +*DECK NUMER3 + SUBROUTINE NUMER3 (NCOUR,MULTC,NCODE,ZCODE,LX,LY,LZ,IORI,ISM, + 1 POURCE,IMPX,NMBLK,IFR,ALB,SUR,NMERGE,INUM,MIX,DVX,NGEN,IGEN, + 2 XX,YY,ZZ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Surface renumbering algorithm for Cartesian geometry. +* The 3-D DP-1 approximation is not implemented. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NCOUR number of surfaces per block (input); number of out-currents +* per block (output). +* MULTC type of multicell approximation: +* =1 Roth; =2 Roth X ncour; =3 DP-0; =4 DP-1. +* NCODE type of boundary condition on each side of the domain: +* =0 not used; =1 VOID; =2 REFL; +* =3 DIAG; =4 TRAN; =5 SYME. +* ZCODE value of the albedo on each side of the domain. +* LX number of blocks along the X-axis. +* LY number of blocks along the Y-axis. +* LZ number of blocks along the Z-axis. +* IORI orientation of the blocks. +* ISM permutation index corresponding to each orientation +* (ISM(I,N)=I is the natural orientation). +* POURCE weight associated with each merged block. +* IMPX print flag (equal to 0 for no print). +* NMBLK total number of blocks in the domain. +* IFR index-number of in-currents. +* ALB transmission/albedo associated with each in-current. +* SUR surface associated with each in-current. +* NMERGE total number of merged cells for which specific values +* of the neutron flux and reactions rates are required. +* Many cells with different position in the domain can +* be merged before the neutron flux calculation if they +* own the same generating cell (NMERGE.le.NMBLK). +* INUM index-number of the merged cell associated to each cell. +* MIX index-number of out-currents. +* DVX weight associated with each out-current. +* Note: IFR, ALB, MIX and DVX contains information to rebuild +* the geometrical 'A' matrix. +* NGEN total number of generating blocks in the cartesian domain. +* IGEN index-number of the generating block associated with each +* merged block. +* XX X-thickness of the generating blocks. +* YY Y-thickness of the generating blocks. +* ZZ Z-thickness of the generating blocks. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NCOUR,MULTC,NCODE(6),LX,LY,LZ,IORI(NMBLK),ISM(6,8), + 1 IMPX,NMBLK,IFR(12*NMBLK),NMERGE,INUM(NMBLK),MIX(12*NMERGE), + 2 NGEN,IGEN(NMERGE) + REAL ZCODE(6),POURCE(NMERGE),ALB(12*NMBLK),SUR(12*NMBLK), + 1 DVX(12*NMERGE),XX(NGEN),YY(NGEN),ZZ(NGEN) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (EPS=1.0E-5) + LOGICAL LL1,LL2,LOG1,LOG2,LOG3 + CHARACTER DIRR(6)*2,DIRZ(12)*2,HSMG*131 + INTEGER IDDD(6),ISMZ(12) + REAL DDD(6) + INTEGER, ALLOCATABLE, DIMENSION(:) :: JF2 + REAL, ALLOCATABLE, DIMENSION(:) :: GG3 + SAVE DIRR + DATA DIRR/'X-','X+','Y-','Y+','Z-','Z+'/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(JF2(6*NMBLK),GG3(NMBLK)) +* + DO 100 I=1,NCOUR*NMERGE + MIX(I)=I + DVX(I)=1.0 +100 CONTINUE + IS1=0 + IS2=0 + LXY=LX*LY + LL1=((NCODE(2).EQ.3).AND.(NCODE(3).EQ.3)) + LL2=((NCODE(1).EQ.3).AND.(NCODE(4).EQ.3)) + IF (LL1) THEN + IS1=1 + LXY=LX*(LX+1)/2 + ELSE IF (LL2) THEN + IS2=1 + LXY=LX*(LX+1)/2 + ENDIF + IBLK=0 + DO 280 K0=1,LZ + DO 275 K1=1,LY + LXM=1 + LXP=LX + IF (LL1) LXP=K1 + IF (LL2) LXM=K1 + DO 270 K2=LXM,LXP + IBLK=IBLK+1 + IKK=INUM(IBLK) + FRX=1.0 + FRY=1.0 + FRZ=1.0 + IF (IKK.EQ.0) GO TO 265 + IS=NCOUR*(IBLK-1) + IT=NCOUR*(IKK-1) + II=IORI(IBLK) + DO 110 IC=1,6 + IDDD(IC)=-1 +110 CONTINUE + IF (K2.GT.1) IDDD(1)=IBLK-1 + IF (K2.LT.LX) IDDD(2)=IBLK+1 + IF (K1.GT.1) IDDD(3)=IBLK-(LXP-LXM+1)+IS1 + IF (K1.LT.LY) IDDD(4)=IBLK+(LXP-LXM+1)-IS2 + IF (K0.GT.1) IDDD(5)=IBLK-LXY + IF (K0.LT.LZ) IDDD(6)=IBLK+LXY +* + DO 120 IC=1,NCOUR + ALB(IS+IC)=1.0 + SUR(IS+IC)=0.0 + JBLK=IDDD(IC) + IF (JBLK.GT.0) THEN + JKK=INUM(JBLK) + JT=NCOUR*(JKK-1) + IF ((MOD(IC,2).EQ.1).AND.(JKK.GT.0)) THEN + IFR(IS+ISM(IC,II))=JT+ISM(IC+1,IORI(JBLK)) + ELSE IF ((MOD(IC,2).EQ.0).AND.(JKK.GT.0)) THEN + IFR(IS+ISM(IC,II))=JT+ISM(IC-1,IORI(JBLK)) + ELSE + IFR(IS+ISM(IC,II))=0 + ENDIF + IDDD(IC)=JKK + ELSE + IFR(IS+ISM(IC,II))=0 + ENDIF +120 CONTINUE +*---- +* VOID OR REFL BOUNDARY CONDITIONS +*---- + IKG=IGEN(IKK) + LOG1=(K2.EQ.1).OR.(IDDD(1).EQ.0) + LOG2=(NCODE(1).EQ.1).OR.(LL2.AND.(NCODE(3).EQ.1)) + LOG3=(NCODE(1).EQ.2).OR.(LL2.AND.(NCODE(3).EQ.2)) + IF (LOG1.AND.LOG2) THEN + ALB(IS+ISM(1,II))=-ZCODE(1) + IFR(IS+ISM(1,II))=IT+ISM(1,II) + ELSE IF (LOG1.AND.LOG3) THEN + ALB(IS+ISM(1,II))=-1.0 + IFR(IS+ISM(1,II))=IT+ISM(1,II) + ENDIF + IF(LOG1.AND.(NCODE(1).EQ.1)) SUR(IS+ISM(1,II))=YY(IKG)*ZZ(IKG) + IF(LOG1.AND.(NCODE(1).EQ.2)) SUR(IS+ISM(1,II))=YY(IKG)*ZZ(IKG) + LOG1=(K2.EQ.LX).OR.(IDDD(2).EQ.0) + LOG2=(NCODE(2).EQ.1).OR.(LL1.AND.(NCODE(4).EQ.1)) + LOG3=(NCODE(2).EQ.2).OR.(LL1.AND.(NCODE(4).EQ.2)) + IF (LOG1.AND.LOG2) THEN + ALB(IS+ISM(2,II))=-ZCODE(2) + IFR(IS+ISM(2,II))=IT+ISM(2,II) + ELSE IF (LOG1.AND.LOG3) THEN + ALB(IS+ISM(2,II))=-1.0 + IFR(IS+ISM(2,II))=IT+ISM(2,II) + ENDIF + IF(LOG1.AND.(NCODE(2).EQ.1)) SUR(IS+ISM(2,II))=YY(IKG)*ZZ(IKG) + IF(LOG1.AND.(NCODE(2).EQ.2)) SUR(IS+ISM(2,II))=YY(IKG)*ZZ(IKG) + LOG1=(K1.EQ.1).OR.(IDDD(3).EQ.0) + LOG2=(NCODE(3).EQ.1).OR.(LL1.AND.(NCODE(1).EQ.1)) + LOG3=(NCODE(3).EQ.2).OR.(LL1.AND.(NCODE(1).EQ.2)) + IF (LOG1.AND.LOG2) THEN + ALB(IS+ISM(3,II))=-ZCODE(3) + IFR(IS+ISM(3,II))=IT+ISM(3,II) + ELSE IF (LOG1.AND.LOG3) THEN + ALB(IS+ISM(3,II))=-1.0 + IFR(IS+ISM(3,II))=IT+ISM(3,II) + ENDIF + IF(LOG1.AND.(NCODE(3).EQ.1)) SUR(IS+ISM(3,II))=XX(IKG)*ZZ(IKG) + IF(LOG1.AND.(NCODE(3).EQ.2)) SUR(IS+ISM(3,II))=XX(IKG)*ZZ(IKG) + LOG1=(K1.EQ.LY).OR.(IDDD(4).EQ.0) + LOG2=(NCODE(4).EQ.1).OR.(LL2.AND.(NCODE(2).EQ.1)) + LOG3=(NCODE(4).EQ.2).OR.(LL2.AND.(NCODE(2).EQ.2)) + IF (LOG1.AND.LOG2) THEN + ALB(IS+ISM(4,II))=-ZCODE(4) + IFR(IS+ISM(4,II))=IT+ISM(4,II) + ELSE IF (LOG1.AND.LOG3) THEN + ALB(IS+ISM(4,II))=-1.0 + IFR(IS+ISM(4,II))=IT+ISM(4,II) + ENDIF + IF(LOG1.AND.(NCODE(4).EQ.1)) SUR(IS+ISM(4,II))=XX(IKG)*ZZ(IKG) + IF(LOG1.AND.(NCODE(4).EQ.2)) SUR(IS+ISM(4,II))=XX(IKG)*ZZ(IKG) + LOG1=(K0.EQ.1).OR.(IDDD(5).EQ.0) + IF (LOG1.AND.(NCODE(5).EQ.1)) THEN + ALB(IS+ISM(5,II))=-ZCODE(5) + IFR(IS+ISM(5,II))=IT+ISM(5,II) + ELSE IF (LOG1.AND.(NCODE(5).EQ.2)) THEN + ALB(IS+ISM(5,II))=-1.0 + IFR(IS+ISM(5,II))=IT+ISM(5,II) + ENDIF + IF(LOG1.AND.(NCODE(5).EQ.1)) SUR(IS+ISM(5,II))=XX(IKG)*YY(IKG) + IF(LOG1.AND.(NCODE(5).EQ.2)) SUR(IS+ISM(5,II))=XX(IKG)*YY(IKG) + LOG1=(K0.EQ.LZ).OR.(IDDD(6).EQ.0) + IF (LOG1.AND.(NCODE(6).EQ.1)) THEN + ALB(IS+ISM(6,II))=-ZCODE(6) + IFR(IS+ISM(6,II))=IT+ISM(6,II) + ELSE IF (LOG1.AND.(NCODE(6).EQ.2)) THEN + ALB(IS+ISM(6,II))=-1.0 + IFR(IS+ISM(6,II))=IT+ISM(6,II) + ENDIF + IF(LOG1.AND.(NCODE(6).EQ.1)) SUR(IS+ISM(6,II))=XX(IKG)*YY(IKG) + IF(LOG1.AND.(NCODE(6).EQ.2)) SUR(IS+ISM(6,II))=XX(IKG)*YY(IKG) +*---- +* CORRECT THE PARITY OF THE INTERFACE CURRENTS FOR DP-1 CASES WITH +* 'MIRROR' ORIENTATION +*---- + DO 125 IC=1,NCOUR + IF(II.GE.5) ALB(IS+IC)=-ALB(IS+IC) + JBLK=IBLK + IF((K2.GT.1).AND.(IC.EQ.1)) JBLK=IBLK-1 + IF((K2.LT.LX).AND.(IC.EQ.2)) JBLK=IBLK+1 + IF((K1.GT.1).AND.(IC.EQ.3)) JBLK=IBLK-(LXP-LXM+1)+IS1 + IF((K1.LT.LY).AND.(IC.EQ.4)) JBLK=IBLK+(LXP-LXM+1)-IS2 + IF((K0.GT.1).AND.(IC.EQ.5)) JBLK=IBLK-LXY + IF((K0.LT.LZ).AND.(IC.EQ.6)) JBLK=IBLK+LXY + IF(IORI(JBLK).GE.5) ALB(IS+ISM(IC,II))=-ALB(IS+ISM(IC,II)) +125 CONTINUE +*---- +* DIAG BOUNDARY CONDITION +*---- + IF (K1.EQ.K2) THEN + IF(LL1.OR.LL2) THEN + IKG=IGEN(IKK) + IF(XX(IKG).NE.YY(IKG)) CALL XABORT('NUMER3: A CELL ON THE ' + 1 //'DIAGONAL SYMMETRY AXIS IS NOT SQUARE.') + ENDIF + IF ((K1.EQ.1).AND.(NCODE(1).EQ.3).AND.(NCODE(3).EQ.5)) THEN + FRX=0.25 + ALB(IS+ISM(1,II))=-ALB(IS+ISM(2,II)) + IFR(IS+ISM(1,II))=IFR(IS+ISM(2,II)) + DVX(IT+ISM(1,II))=-DVX(IT+ISM(2,II)) + MIXNEW=MIX(IT+ISM(2,II)) + MIXOLD=MIX(IT+ISM(1,II)) + DO 130 KC=1,NCOUR + IF(MIX(IT+KC).EQ.MIXOLD) MIX(IT+KC)=MIXNEW +130 CONTINUE + ELSE IF (NCODE(1).EQ.3) THEN + FRX=0.5 + ALB(IS+ISM(1,II))=-ALB(IS+ISM(3,II)) + IFR(IS+ISM(1,II))=IFR(IS+ISM(3,II)) + DVX(IT+ISM(1,II))=-DVX(IT+ISM(3,II)) + MIXNEW=MIX(IT+ISM(3,II)) + MIXOLD=MIX(IT+ISM(1,II)) + DO 140 KC=1,NCOUR + IF(MIX(IT+KC).EQ.MIXOLD) MIX(IT+KC)=MIXNEW +140 CONTINUE + ENDIF + IF ((K1.EQ.LY).AND.(NCODE(2).EQ.3).AND.(NCODE(4).EQ.5)) THEN + FRX=0.25 + ALB(IS+ISM(2,II))=-ALB(IS+ISM(1,II)) + IFR(IS+ISM(2,II))=IFR(IS+ISM(1,II)) + DVX(IT+ISM(2,II))=-DVX(IT+ISM(1,II)) + MIXNEW=MIX(IT+ISM(1,II)) + MIXOLD=MIX(IT+ISM(2,II)) + DO 150 KC=1,NCOUR + IF(MIX(IT+KC).EQ.MIXOLD) MIX(IT+KC)=MIXNEW +150 CONTINUE + ELSE IF (NCODE(2).EQ.3) THEN + ALB(IS+ISM(2,II))=-ALB(IS+ISM(4,II)) + IFR(IS+ISM(2,II))=IFR(IS+ISM(4,II)) + DVX(IT+ISM(2,II))=-DVX(IT+ISM(4,II)) + MIXNEW=MIX(IT+ISM(4,II)) + MIXOLD=MIX(IT+ISM(2,II)) + DO 160 KC=1,NCOUR + IF(MIX(IT+KC).EQ.MIXOLD) MIX(IT+KC)=MIXNEW +160 CONTINUE + ENDIF + IF ((K1.EQ.1).AND.(NCODE(3).EQ.3).AND.(NCODE(1).EQ.5)) THEN + FRY=0.25 + ALB(IS+ISM(3,II))=-ALB(IS+ISM(4,II)) + IFR(IS+ISM(3,II))=IFR(IS+ISM(4,II)) + DVX(IT+ISM(3,II))=-DVX(IT+ISM(4,II)) + MIXNEW=MIX(IT+ISM(4,II)) + MIXOLD=MIX(IT+ISM(3,II)) + DO 170 KC=1,NCOUR + IF(MIX(IT+KC).EQ.MIXOLD) MIX(IT+KC)=MIXNEW +170 CONTINUE + ELSE IF (NCODE(3).EQ.3) THEN + FRY=0.5 + ALB(IS+ISM(3,II))=-ALB(IS+ISM(1,II)) + IFR(IS+ISM(3,II))=IFR(IS+ISM(1,II)) + DVX(IT+ISM(3,II))=-DVX(IT+ISM(1,II)) + MIXNEW=MIX(IT+ISM(1,II)) + MIXOLD=MIX(IT+ISM(3,II)) + DO 180 KC=1,NCOUR + IF(MIX(IT+KC).EQ.MIXOLD) MIX(IT+KC)=MIXNEW +180 CONTINUE + ENDIF + IF ((K1.EQ.LY).AND.(NCODE(4).EQ.3).AND.(NCODE(2).EQ.5)) THEN + FRY=0.25 + ALB(IS+ISM(4,II))=-ALB(IS+ISM(3,II)) + IFR(IS+ISM(4,II))=IFR(IS+ISM(3,II)) + DVX(IT+ISM(4,II))=-DVX(IT+ISM(3,II)) + MIXNEW=MIX(IT+ISM(3,II)) + MIXOLD=MIX(IT+ISM(4,II)) + DO 190 KC=1,NCOUR + IF(MIX(IT+KC).EQ.MIXOLD) MIX(IT+KC)=MIXNEW +190 CONTINUE + ELSE IF (NCODE(4).EQ.3) THEN + ALB(IS+ISM(4,II))=-ALB(IS+ISM(2,II)) + IFR(IS+ISM(4,II))=IFR(IS+ISM(2,II)) + DVX(IT+ISM(4,II))=-DVX(IT+ISM(2,II)) + MIXNEW=MIX(IT+ISM(2,II)) + MIXOLD=MIX(IT+ISM(4,II)) + DO 200 KC=1,NCOUR + IF(MIX(IT+KC).EQ.MIXOLD) MIX(IT+KC)=MIXNEW +200 CONTINUE + ENDIF + ENDIF +*---- +* TRAN BOUNDARY CONDITION +*---- + IF ((K2.EQ.1).AND.(NCODE(1).EQ.4)) THEN + JBLK=IBLK+LXP-LXM + IFR(IS+ISM(1,II))=NCOUR*(INUM(JBLK)-1)+ISM(2,IORI(JBLK)) + ENDIF + IF ((K2.EQ.LX).AND.(NCODE(2).EQ.4)) THEN + JBLK=IBLK+LXM-LXP + IFR(IS+ISM(2,II))=NCOUR*(INUM(JBLK)-1)+ISM(1,IORI(JBLK)) + ENDIF + IF ((K1.EQ.1).AND.(NCODE(3).EQ.4)) THEN + JBLK=IBLK+(LY-1)*LX + IFR(IS+ISM(3,II))=NCOUR*(INUM(JBLK)-1)+ISM(4,IORI(JBLK)) + ENDIF + IF ((K1.EQ.LY).AND.(NCODE(4).EQ.4)) THEN + JBLK=IBLK-(LY-1)*LX + IFR(IS+ISM(4,II))=NCOUR*(INUM(JBLK)-1)+ISM(3,IORI(JBLK)) + ENDIF + IF ((K0.EQ.1).AND.(NCODE(5).EQ.4)) THEN + JBLK=IBLK+(LZ-1)*LXY + IFR(IS+ISM(5,II))=NCOUR*(INUM(JBLK)-1)+ISM(6,IORI(JBLK)) + ENDIF + IF ((K0.EQ.LZ).AND.(NCODE(6).EQ.4)) THEN + JBLK=IBLK-(LZ-1)*LXY + IFR(IS+ISM(6,II))=NCOUR*(INUM(JBLK)-1)+ISM(5,IORI(JBLK)) + ENDIF +*---- +* SYME BOUNDARY CONDITION +*---- + IF ((K2.EQ.1).AND.(NCODE(1).EQ.5)) THEN + FRX=0.5 + ALB(IS+ISM(1,II))=-ALB(IS+ISM(2,II)) + IFR(IS+ISM(1,II))=IFR(IS+ISM(2,II)) + SUR(IS+ISM(3,II))=0.5*SUR(IS+ISM(3,II)) + SUR(IS+ISM(4,II))=0.5*SUR(IS+ISM(4,II)) + IF(ISM(5,II).NE.0) SUR(IS+ISM(5,II))=0.5*SUR(IS+ISM(5,II)) + IF(ISM(6,II).NE.0) SUR(IS+ISM(6,II))=0.5*SUR(IS+ISM(6,II)) + DVX(IT+ISM(1,II))=-DVX(IT+ISM(2,II)) + MIXNEW=MIX(IT+ISM(2,II)) + MIXOLD=MIX(IT+ISM(1,II)) + DO 210 KC=1,NCOUR + IF(MIX(IT+KC).EQ.MIXOLD) MIX(IT+KC)=MIXNEW +210 CONTINUE + ELSE IF ((K2.EQ.LX).AND.(NCODE(2).EQ.5)) THEN + FRX=0.5 + ALB(IS+ISM(2,II))=-ALB(IS+ISM(1,II)) + IFR(IS+ISM(2,II))=IFR(IS+ISM(1,II)) + SUR(IS+ISM(3,II))=0.5*SUR(IS+ISM(3,II)) + SUR(IS+ISM(4,II))=0.5*SUR(IS+ISM(4,II)) + IF(ISM(5,II).NE.0) SUR(IS+ISM(5,II))=0.5*SUR(IS+ISM(5,II)) + IF(ISM(6,II).NE.0) SUR(IS+ISM(6,II))=0.5*SUR(IS+ISM(6,II)) + DVX(IT+ISM(2,II))=-DVX(IT+ISM(1,II)) + MIXNEW=MIX(IT+ISM(1,II)) + MIXOLD=MIX(IT+ISM(2,II)) + DO 220 KC=1,NCOUR + IF(MIX(IT+KC).EQ.MIXOLD) MIX(IT+KC)=MIXNEW +220 CONTINUE + ENDIF + IF ((K1.EQ.1).AND.(NCODE(3).EQ.5)) THEN + FRY=0.5 + ALB(IS+ISM(3,II))=-ALB(IS+ISM(4,II)) + IFR(IS+ISM(3,II))=IFR(IS+ISM(4,II)) + SUR(IS+ISM(1,II))=0.5*SUR(IS+ISM(1,II)) + SUR(IS+ISM(2,II))=0.5*SUR(IS+ISM(2,II)) + IF(ISM(5,II).NE.0) SUR(IS+ISM(5,II))=0.5*SUR(IS+ISM(5,II)) + IF(ISM(6,II).NE.0) SUR(IS+ISM(6,II))=0.5*SUR(IS+ISM(6,II)) + DVX(IT+ISM(3,II))=-DVX(IT+ISM(4,II)) + MIXNEW=MIX(IT+ISM(4,II)) + MIXOLD=MIX(IT+ISM(3,II)) + DO 230 KC=1,NCOUR + IF(MIX(IT+KC).EQ.MIXOLD) MIX(IT+KC)=MIXNEW +230 CONTINUE + ELSE IF ((K1.EQ.LY).AND.(NCODE(4).EQ.5)) THEN + FRY=0.5 + ALB(IS+ISM(4,II))=-ALB(IS+ISM(3,II)) + IFR(IS+ISM(4,II))=IFR(IS+ISM(3,II)) + SUR(IS+ISM(1,II))=0.5*SUR(IS+ISM(1,II)) + SUR(IS+ISM(2,II))=0.5*SUR(IS+ISM(2,II)) + IF(ISM(5,II).NE.0) SUR(IS+ISM(5,II))=0.5*SUR(IS+ISM(5,II)) + IF(ISM(6,II).NE.0) SUR(IS+ISM(6,II))=0.5*SUR(IS+ISM(6,II)) + DVX(IT+ISM(4,II))=-DVX(IT+ISM(3,II)) + MIXNEW=MIX(IT+ISM(3,II)) + MIXOLD=MIX(IT+ISM(4,II)) + DO 240 KC=1,NCOUR + IF(MIX(IT+KC).EQ.MIXOLD) MIX(IT+KC)=MIXNEW +240 CONTINUE + ENDIF + IF ((K0.EQ.1).AND.(NCODE(5).EQ.5)) THEN + FRZ=0.5 + ALB(IS+ISM(5,II))=-ALB(IS+ISM(6,II)) + IFR(IS+ISM(5,II))=IFR(IS+ISM(6,II)) + SUR(IS+ISM(1,II))=0.5*SUR(IS+ISM(1,II)) + SUR(IS+ISM(2,II))=0.5*SUR(IS+ISM(2,II)) + SUR(IS+ISM(3,II))=0.5*SUR(IS+ISM(3,II)) + SUR(IS+ISM(4,II))=0.5*SUR(IS+ISM(4,II)) + DVX(IT+ISM(5,II))=-DVX(IT+ISM(6,II)) + MIXNEW=MIX(IT+ISM(6,II)) + MIXOLD=MIX(IT+ISM(5,II)) + DO 250 KC=1,NCOUR + IF(MIX(IT+KC).EQ.MIXOLD) MIX(IT+KC)=MIXNEW +250 CONTINUE + ELSE IF ((K0.EQ.LZ).AND.(NCODE(6).EQ.5)) THEN + FRZ=0.5 + ALB(IS+ISM(6,II))=-ALB(IS+ISM(5,II)) + IFR(IS+ISM(6,II))=IFR(IS+ISM(5,II)) + SUR(IS+ISM(1,II))=0.5*SUR(IS+ISM(1,II)) + SUR(IS+ISM(2,II))=0.5*SUR(IS+ISM(2,II)) + SUR(IS+ISM(3,II))=0.5*SUR(IS+ISM(3,II)) + SUR(IS+ISM(4,II))=0.5*SUR(IS+ISM(4,II)) + DVX(IT+ISM(6,II))=-DVX(IT+ISM(5,II)) + MIXNEW=MIX(IT+ISM(5,II)) + MIXOLD=MIX(IT+ISM(6,II)) + DO 260 KC=1,NCOUR + IF(MIX(IT+KC).EQ.MIXOLD) MIX(IT+KC)=MIXNEW +260 CONTINUE + ENDIF +* +265 GG3(IBLK)=FRX*FRY*FRZ +270 CONTINUE +275 CONTINUE +280 CONTINUE + DO 285 I=1,NCOUR*NMBLK + IFR(I)=MIX(IFR(I)) +285 CONTINUE +*---- +* ELIMINATION OF THE BLOCKS OUTSIDE THE DOMAIN +*---- + JBLK=0 + DO 300 IBLK=1,NMBLK + IKK=INUM(IBLK) + IF (IKK.GT.0) THEN + JBLK=JBLK+1 + INUM(JBLK)=IKK + IORI(JBLK)=IORI(IBLK) + GG3(JBLK)=GG3(IBLK) + IS=NCOUR*(IBLK-1) + JS=NCOUR*(JBLK-1) + DO 290 IC=1,NCOUR + IFR(JS+IC)=IFR(IS+IC) + ALB(JS+IC)=ALB(IS+IC) + SUR(JS+IC)=SUR(IS+IC) +290 CONTINUE + ENDIF +300 CONTINUE + NMBLK=JBLK +* + DO 310 IKK=1,NMERGE + POURCE(IKK)=0.0 +310 CONTINUE + DO 330 IBLK=1,NMBLK + IKK=INUM(IBLK) + POURCE(IKK)=POURCE(IKK)+GG3(IBLK) +330 CONTINUE +*---- +* VALIDATION OF VECTOR IFR +*---- + DO 345 IBLK=1,NMBLK + IS=NCOUR*(IBLK-1) + DO 340 IC=1,NCOUR + ISURF=IFR(IS+IC) + IF (ISURF.EQ.0) THEN + WRITE (HSMG,'(44HNUMER3: FAILURE OF THE SURFACE RENUMBERING A, + 1 12HLGORITHM(1).)') + GO TO 570 + ENDIF + JC=1+MOD(ISURF-1,NCOUR) + JT=NCOUR*((ISURF-1)/NCOUR) + IF (MIX(JT+JC).NE.ISURF) THEN + WRITE (HSMG,'(44HNUMER3: FAILURE OF THE SURFACE RENUMBERING A, + 1 12HLGORITHM(2).)') + GO TO 570 + ENDIF +340 CONTINUE +345 CONTINUE +*---- +* VALIDATION OF THE GEOMETRICAL RECIPROCITY AND MODIFICATION OF ALBEDOS +*---- + DO 355 IBLK=1,NMBLK + IKK=INUM(IBLK) + IKG=IGEN(IKK) + IS=NCOUR*(IBLK-1) + IT=NCOUR*(IKK-1) + DO 350 IC=1,NCOUR + ALB(IS+IC)=ALB(IS+IC)*GG3(IBLK)/POURCE(IKK) + IP=1+MOD(MIX(IT+IC)-1,NCOUR) + FR1=YY(IKG)*ZZ(IKG) + IF ((IP.EQ.3).OR.(IP.EQ.4)) FR1=XX(IKG)*ZZ(IKG) + IF ((IP.EQ.5).OR.(IP.EQ.6)) FR1=XX(IKG)*YY(IKG) + JP=1+MOD(IFR(IS+IC)-1,NCOUR) + JKG=IGEN(1+(IFR(IS+IC)-1)/NCOUR) + FR2=YY(JKG)*ZZ(JKG) + IF ((JP.EQ.3).OR.(JP.EQ.4)) FR2=XX(JKG)*ZZ(JKG) + IF ((JP.EQ.5).OR.(JP.EQ.6)) FR2=XX(JKG)*YY(JKG) + DELTA=ABS(FR1-FR2) + IF (ABS(FR1-FR2).GT.EPS) THEN + WRITE (HSMG,680) DIRR(IP),IKG,DIRR(JP),JKG + GO TO 570 + ENDIF +350 CONTINUE +355 CONTINUE +*---- +* COMPUTE VECTOR DVX +*---- + DO 395 IKK=1,NMERGE + IKG=IGEN(IKK) + IF (NCOUR.EQ.2) THEN + DDD(1)=0.5 + DDD(2)=0.5 + ELSE IF (NCOUR.EQ.4) THEN + SURFA=2.0*(XX(IKG)+YY(IKG)) + DO 360 IC=1,NCOUR + FR1=YY(IKG) + IF ((IC.EQ.3).OR.(IC.EQ.4)) FR1=XX(IKG) + DDD(IC)=FR1/SURFA +360 CONTINUE + ELSE IF (NCOUR.EQ.6) THEN + SURFA=2.0*(XX(IKG)*ZZ(IKG)+YY(IKG)*ZZ(IKG)+XX(IKG)*YY(IKG)) + DO 370 IC=1,NCOUR + FR1=YY(IKG)*ZZ(IKG) + IF ((IC.EQ.3).OR.(IC.EQ.4)) FR1=XX(IKG)*ZZ(IKG) + IF ((IC.EQ.5).OR.(IC.EQ.6)) FR1=XX(IKG)*YY(IKG) + DDD(IC)=FR1/SURFA +370 CONTINUE + ENDIF + IT=NCOUR*(IKK-1) + DO 390 IC=1,NCOUR + IF (MULTC.EQ.1) THEN +* ROTH APPROXIMATION. + DVX(IT+IC)=DDD(IC) + MIX(IT+IC)=IKK + ELSE + DELTA=0.0 + I1=MIX(IT+IC) + DO 380 JC=1,NCOUR + IF (MIX(IT+JC).EQ.I1) DELTA=DELTA+DDD(JC) +380 CONTINUE + ZSIGN=SIGN(1.0,DVX(IT+IC)) + DVX(IT+IC)=ZSIGN*DDD(IC)/DELTA + ENDIF +390 CONTINUE +395 CONTINUE + IJAS=NCOUR*NMBLK + IJAR=NCOUR*NMERGE +*---- +* RECOMPUTE VECTOR IFR FOR ROTH APPROXIMATION +*---- + IF (MULTC.EQ.1) THEN + DO 400 I=1,IJAS + IFR(I)=1+(IFR(I)-1)/NCOUR +400 CONTINUE + ENDIF +*---- +* REMOVE THE UNUSED SURFACE NUMBERS +*---- + DO 410 I=1,IJAS + JF2(I)=0 +410 CONTINUE + IJAT=0 + DO 420 I=1,IJAR + J=MIX(I) + IF (J.GT.IJAS) THEN + WRITE (HSMG,'(44HNUMER3: FAILURE OF THE SURFACE RENUMBERING A, + 1 12HLGORITHM(3).)') + GO TO 570 + ENDIF + IF (JF2(J).EQ.0) THEN + IJAT=IJAT+1 + JF2(J)=IJAT + ENDIF +420 CONTINUE + DO 430 I=1,IJAR + MIX(I)=JF2(MIX(I)) +430 CONTINUE + DO 440 I=1,IJAS + IFR(I)=JF2(IFR(I)) +440 CONTINUE +*---- +* INCLUDE THE DP-1 APPROXIMATION +*---- + IF ((MULTC.EQ.4).AND.(NCOUR.EQ.2)) THEN +* DP-1 APPROXIMATION IN 1-D. + DO 455 I1=IJAR,1,-1 + FR1=ABS(DVX(I1)) + JND=(MIX(I1)-1)*2 + DO 450 JCOUR=1,2 + JSURF=(I1-1)*2+JCOUR + DVX(JSURF)=FR1 + MIX(JSURF)=JND+JCOUR +450 CONTINUE +455 CONTINUE + DO 465 I1=IJAS,1,-1 + FR1=ABS(ALB(I1)) + FR2=SUR(I1) + JND=(IFR(I1)-1)*2 + DO 460 JCOUR=1,2 + JSURF=(I1-1)*2+JCOUR + ALB(JSURF)=FR1 + SUR(JSURF)=FR2 + IFR(JSURF)=JND+JCOUR +460 CONTINUE +465 CONTINUE + NCOUR=4 + ELSE IF ((MULTC.EQ.4).AND.(NCOUR.EQ.4)) THEN +* DP-1 APPROXIMATION IN 2-D. + DO 480 I1=IJAR,1,-1 + ZSIGN=SIGN(1.0,DVX(I1)) + FR1=ABS(DVX(I1)) + FR2=SUR(I1) + JND=(MIX(I1)-1)*3 + DO 470 JCOUR=1,3 + JSURF=(I1-1)*3+JCOUR + DVX(JSURF)=FR1 + MIX(JSURF)=JND+JCOUR +470 CONTINUE + DVX(JSURF)=ZSIGN*FR1 +480 CONTINUE + DO 500 I1=IJAS,1,-1 + ZSIGN=SIGN(1.0,ALB(I1)) + FR1=ABS(ALB(I1)) + FR2=SUR(I1) + JND=(IFR(I1)-1)*3 + DO 490 JCOUR=1,3 + JSURF=(I1-1)*3+JCOUR + ALB(JSURF)=FR1 + SUR(JSURF)=FR2 + IFR(JSURF)=JND+JCOUR +490 CONTINUE + ALB(JSURF)=ZSIGN*FR1 +500 CONTINUE + NCOUR=12 + ELSE IF ((MULTC.EQ.4).AND.(NCOUR.EQ.6)) THEN + CALL XABORT('NUMER3: INVALID OPTION.') + ELSE + DO 510 I=1,IJAS + ALB(I)=ABS(ALB(I)) +510 CONTINUE + DO 520 I=1,IJAR + DVX(I)=ABS(DVX(I)) +520 CONTINUE + ENDIF + IJAS=NCOUR*NMBLK + IJAR=NCOUR*NMERGE +*---- +* PRINT THE SURFACE NUMBERS AFTER MERGING +*---- + IF (IMPX.GT.2) THEN + WRITE (6,620) + MIN6=MIN(6,NCOUR) + WRITE (6,650) ('----------------',I=1,MIN6) + DO 560 IBLK=1,NMBLK + IKK=INUM(IBLK) + WRITE (6,630) IBLK,IKK,IGEN(IKK) + I1=IORI(IBLK) + IF ((MULTC.EQ.4).AND.(NCOUR.EQ.12)) THEN + DO 530 I=1,12 + ISMZ(I)=3*ISM(1+(I-1)/3,I1)+MOD(I-1,3)-2 + DIRZ(I)=DIRR(1+(I-1)/3) +530 CONTINUE + ELSE IF ((MULTC.EQ.4).AND.(NCOUR.EQ.4)) THEN + DO 540 I=1,4 + ISMZ(I)=2*ISM(1+(I-1)/2,I1)+MOD(I-1,2)-1 + DIRZ(I)=DIRR(1+(I-1)/2) +540 CONTINUE + ELSE + DO 550 I=1,NCOUR + ISMZ(I)=ISM(I,I1) + DIRZ(I)=DIRR(I) +550 CONTINUE + ENDIF + IT0=NCOUR*(IBLK-1) + IT1=NCOUR*(IKK-1) + WRITE (6,660) (DIRZ(I),I=1,MIN6) + WRITE (6,635) (MIX(IT1+ISMZ(I)),IFR(IT0+ISMZ(I)),I=1,MIN6) + WRITE (6,640) (ALB(IT0+ISMZ(I)),I=1,MIN6) + WRITE (6,645) (DVX(IT1+ISMZ(I)),I=1,MIN6) + IF (NCOUR.EQ.12) THEN + WRITE (6,660) (DIRZ(I),I=7,12) + WRITE (6,635) (MIX(IT1+ISMZ(I)),IFR(IT0+ISMZ(I)),I=7,12) + WRITE (6,640) (ALB(IT0+ISMZ(I)),I=7,12) + WRITE (6,645) (DVX(IT1+ISMZ(I)),I=7,12) + ENDIF + WRITE (6,650) ('----------------',I=1,MIN6) +560 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GG3,JF2) + RETURN +* +570 WRITE (6,620) + WRITE (6,650) ('----------------',I=1,NCOUR) + DO 580 IBLK=1,NMBLK + IKK=INUM(IBLK) + WRITE (6,630) IBLK,IKK,IGEN(IKK) + I1=IORI(IBLK) + IT0=NCOUR*(IBLK-1) + IT1=NCOUR*(IKK-1) + WRITE (6,660) (DIRR(I),I=1,NCOUR) + WRITE (6,635) (MIX(IT1+ISM(I,I1)),IFR(IT0+ISM(I,I1)),I=1,NCOUR) + WRITE (6,640) (ALB(IT0+ISM(I,I1)),I=1,NCOUR) + WRITE (6,645) (DVX(IT1+ISM(I,I1)),I=1,NCOUR) + WRITE (6,650) ('----------------',I=1,NCOUR) +580 CONTINUE + CALL XABORT(HSMG) +* +620 FORMAT (///31H SURFACE NUMBERS AFTER MERGING./) +630 FORMAT (7H BLOCK=,I5,5X,13HMERGED BLOCK=,I5,5X,12HGENERATING B, + 1 5HLOCK=,I5) +635 FORMAT (8H IN/OUT:,6(I6,2H /,I5,3H I)) +640 FORMAT (8H ALBEDO:,1P,6(E13.5,3H I)) +645 FORMAT (8H DVX:,1P,6(E13.5,3H I)) +650 FORMAT (8H -------,6(A16)) +660 FORMAT (/8H SIDE:,6(A9,6X,1HI)) +680 FORMAT (49HNUMER3: GEOMETRICAL RECIPROCITY CONDITION IS VIOL, + 1 10HATED (SIDE,A3,20H OF GENERATING BLOCK,I5,8H VS SIDE,A3, + 2 20H OF GENERATING BLOCK,I5,3H ).) + END diff --git a/Dragon/src/NUMERH.f b/Dragon/src/NUMERH.f new file mode 100644 index 0000000..73028eb --- /dev/null +++ b/Dragon/src/NUMERH.f @@ -0,0 +1,535 @@ +*DECK NUMERH + SUBROUTINE NUMERH (NCOUR,MULTC,NCODE,ZCODE,IHEX,LX,LZ,IORI,ISM, + 1 POURCE,IMPX,NMBLK,IFR,ALB,SUR,NMERGE,INUM,MIX,DVX,NGEN,IGEN,XX, + 2 ZZ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Surface renumbering algorithm for hexagonal geometry. +* The 3-D DP-1 approximation is not implemented. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NCOUR number of surfaces per block (input); number of out-currents +* per block (output). +* MULTC type of multicell approximation: +* =1 Roth; =2 Roth X ncour; =3 DP-0; =4 DP-1. +* NCODE type of boundary condition on each side of the domain: +* =0 not used; =1 VOID; =2 REFL; +* =3 not used; =4 TRAN; =5 SYME. +* ZCODE value of the albedo on each side of the domain (only +* components 1, 5 and 6 are used). +* IHEX type of symmetry: +* =1 S30; =2 SA60; =3 SB60; =4 S90; =5 R120; +* =6 R180; =7 SA180; =8 SB180; =9 COMPLETE. +* LX number of blocks in the X-Y (hexagonal) plane. +* LZ number of blocks along the Z-axis. +* IORI orientation of the blocks. +* ISM permutation index corresponding to each orientation +* (ISM(I,N)=I is the natural orientation). +* POURCE weight associated with each merged block. +* IMPX print flag (equal to 0 for no print). +* NMBLK total number of blocks in the domain. +* IFR index-number of in-currents. +* ALB transmission/albedo associated with each in-current. +* SUR surface associated with each in-current. +* NMERGE total number of merged cells for which specific values +* of the neutron flux and reactions rates are required. +* Many cells with different position in the domain can +* be merged before the neutron flux calculation if they +* own the same generating cell (NMERGE.le.NMBLK). +* INUM index-number of the merged cell associated to each cell. +* MIX index-number of out-currents. +* DVX weight associated with each out-current. +* Note: IFR, ALB, MIX and DVX contains information to rebuild +* the geometrical 'A' matrix. +* NGEN total number of generating blocks in the cartesian domain. +* IGEN index-number of the generating block associated with each +* merged block. +* XX side of the generating hexagons. +* ZZ Z-thickness of the generating blocks (hexagons). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NCOUR,MULTC,NCODE(6),IHEX,LX,LZ,IORI(NMBLK),ISM(8,12), + 1 IMPX,NMBLK,IFR(18*NMBLK),NMERGE,INUM(NMBLK),MIX(18*NMERGE), + 2 NGEN,IGEN(NMERGE) + REAL ZCODE(6),POURCE(NMERGE),ALB(18*NMBLK),SUR(18*NMBLK), + 1 DVX(18*NMERGE),XX(NGEN),ZZ(NGEN) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (EPS=1.0E-5) + LOGICAL LOG1,LTRAN + CHARACTER DIRR(8)*2,DIRZ(18)*2,HSMG*131 + INTEGER ICCC(6),IDDD(8),ISMZ(18) + REAL DDD(8) + INTEGER, ALLOCATABLE, DIMENSION(:) :: JF2 + REAL, ALLOCATABLE, DIMENSION(:) :: GG3 + SAVE DIRR + DATA DIRR/'H1','H2','H3','H4','H5','H6','Z-','Z+'/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(JF2(8*NMBLK),GG3(NMBLK)) +* + DO 5 I=1,NCOUR*NMERGE + MIX(I)=I + DVX(I)=1.0 +5 CONTINUE + LTRAN=(IHEX.EQ.5).OR.(IHEX.EQ.6) + ZALB=1.0 + IF(NCODE(1).EQ.1) ZALB=ZCODE(1) + IBLK=0 + DO 52 K0=1,LZ + DO 51 K1=1,LX + IBLK=IBLK+1 + IKK=INUM(IBLK) + FRZ=1.0 + IF(IKK.EQ.0) GO TO 50 + IS=NCOUR*(IBLK-1) + IT=NCOUR*(IKK-1) + II=IORI(IBLK) + DO 10 IC=1,NCOUR + IDDD(IC)=-1 + ALB(IS+IC)=1.0 + SUR(IS+IC)=0.0 + IF(IC.LE.6) THEN + ICCC(IC)=NEIGHB(K1,IC,IHEX,LX,FRX) + IF((ICCC(IC).GT.0).AND.(ICCC(IC).NE.K1).AND.(ICCC(IC).LE.LX)) + 1 IDDD(IC)=ICCC(IC)+(K0-1)*LX + ELSE IF((IC.EQ.7).AND.(K0.GT.1)) THEN + IDDD(7)=IBLK-LX + ELSE IF((IC.EQ.8).AND.(K0.LT.LZ)) THEN + IDDD(8)=IBLK+LX + ENDIF + JBLK=IDDD(IC) + IF(JBLK.GT.0) THEN + JKK=INUM(JBLK) + JT=NCOUR*(JKK-1) + IF((IC.LE.6).AND.(JKK.GT.0)) THEN + IFR(IS+ISM(IC,II))=JT+ISM(1+MOD(IC+2,6),IORI(JBLK)) + ELSE IF((IC.EQ.7).AND.(JKK.GT.0)) THEN + IFR(IS+ISM(7,II))=JT+ISM(8,IORI(JBLK)) + ELSE IF((IC.EQ.8).AND.(JKK.GT.0)) THEN + IFR(IS+ISM(8,II))=JT+ISM(7,IORI(JBLK)) + ELSE + IFR(IS+ISM(IC,II))=0 + ENDIF + IDDD(IC)=JKK + ELSE + IFR(IS+ISM(IC,II))=0 + ENDIF +10 CONTINUE + IF(IMPX.GT.10) WRITE(6,610) K1,(ICCC(IC),IC=1,6),FRX +*---- +* VOID OR REFL BOUNDARY CONDITIONS +*---- + IKG=IGEN(IKK) + DO 15 IC=1,6 + IF(ICCC(IC).GT.LX) THEN + ALB(IS+ISM(IC,II))=-ZALB + IFR(IS+ISM(IC,II))=IT+ISM(IC,II) + SUR(IS+ISM(IC,II))=XX(IKG)*ZZ(IKG) + ELSE IF(ICCC(IC).EQ.K1) THEN + ALB(IS+ISM(IC,II))=-1.0 + IFR(IS+ISM(IC,II))=IT+ISM(IC,II) + ENDIF +15 CONTINUE + SURFA=1.5*SQRT(3.0)*XX(IKG)*XX(IKG) + LOG1=(K0.EQ.1).OR.(IDDD(7).EQ.0) + IF(LOG1.AND.(NCODE(5).EQ.1)) THEN + ALB(IS+ISM(7,II))=-ZCODE(5) + IFR(IS+ISM(7,II))=IT+ISM(7,II) + ELSE IF(LOG1.AND.(NCODE(5).EQ.2)) THEN + ALB(IS+ISM(7,II))=-1.0 + IFR(IS+ISM(7,II))=IT+ISM(7,II) + ENDIF + IF(LOG1.AND.(NCODE(5).EQ.1)) SUR(IS+ISM(7,II))=SURFA + IF(LOG1.AND.(NCODE(5).EQ.2)) SUR(IS+ISM(7,II))=SURFA + LOG1=(K0.EQ.LZ).OR.(IDDD(8).EQ.0) + IF(LOG1.AND.(NCODE(6).EQ.1)) THEN + ALB(IS+ISM(8,II))=-ZCODE(6) + IFR(IS+ISM(8,II))=IT+ISM(8,II) + ELSE IF(LOG1.AND.(NCODE(6).EQ.2)) THEN + ALB(IS+ISM(8,II))=-1.0 + IFR(IS+ISM(8,II))=IT+ISM(8,II) + ENDIF + IF(LOG1.AND.(NCODE(6).EQ.1)) SUR(IS+ISM(8,II))=SURFA + IF(LOG1.AND.(NCODE(6).EQ.2)) SUR(IS+ISM(8,II))=SURFA +*---- +* CORRECT THE PARITY OF THE INTERFACE CURRENTS FOR DP-1 CASES WITH +* 'MIRROR' ORIENTATION +*---- + DO 20 IC=1,NCOUR + IF(II.GE.7) ALB(IS+IC)=-ALB(IS+IC) + JBLK=IBLK + IF(IC.LE.6) THEN + IF((ICCC(IC).GT.0).AND.(ICCC(IC).NE.K1).AND.(ICCC(IC).LE.LX)) + 1 JBLK=ICCC(IC)+(K0-1)*LX + ELSE IF((IC.EQ.7).AND.(K0.GT.1)) THEN + JBLK=IBLK-LX + ELSE IF((IC.EQ.8).AND.(K0.LT.LZ)) THEN + JBLK=IBLK+LX + ENDIF + IF(IORI(JBLK).GE.7) ALB(IS+ISM(IC,II))=-ALB(IS+ISM(IC,II)) +20 CONTINUE +*---- +* TRAN BOUNDARY CONDITION +*---- + DO 30 IC=1,6 + IF(LTRAN.AND.(ICCC(IC).LT.0)) THEN + JBLK=-ICCC(IC)+(K0-1)*LX + JT=NCOUR*(INUM(JBLK)-1) + K1M=-K1 + IF(K1.EQ.1) K1M=1 + JC=0 + DO 25 KC=1,6 + IF(NEIGHB(-ICCC(IC),KC,IHEX,LX,FRW).EQ.K1M) JC=KC +25 CONTINUE + IF(JC.EQ.0) CALL XABORT('NUMERH: FAILURE NB. 1.') + IFR(IS+ISM(IC,II))=JT+ISM(JC,IORI(JBLK)) + ENDIF +30 CONTINUE + IF((K0.EQ.1).AND.(NCODE(5).EQ.4)) THEN + JBLK=IBLK+(LZ-1)*LX + IFR(IS+ISM(7,II))=NCOUR*(INUM(JBLK)-1)+ISM(8,IORI(JBLK)) + ENDIF + IF((K0.EQ.LZ).AND.(NCODE(6).EQ.4)) THEN + JBLK=IBLK-(LZ-1)*LX + IFR(IS+ISM(8,II))=NCOUR*(INUM(JBLK)-1)+ISM(7,IORI(JBLK)) + ENDIF +*---- +* SYME BOUNDARY CONDITION +*---- + DO 40 IC=1,6 + IF((.NOT.LTRAN).AND.(ICCC(IC).LT.0)) THEN + JC=0 + DO 35 KC=1,6 + IF(-ICCC(IC).EQ.ICCC(KC)) JC=KC +35 CONTINUE + IF(JC.EQ.0) CALL XABORT('NUMERH: FAILURE NB. 2.') + ZSIGN=-1.0 + IF(K1.EQ.1) THEN + IF((IHEX.EQ.3).AND.(IC.EQ.3)) ZSIGN=1.0 + IF((IHEX.EQ.3).AND.(IC.EQ.5)) ZSIGN=1.0 + IF((IHEX.EQ.4).AND.(IC.EQ.4)) ZSIGN=1.0 + ENDIF + IF((IHEX.EQ.10).AND.(FRX.EQ.0.25).AND.(IC.EQ.6)) ZSIGN=1.0 + ALB(IS+ISM(IC,II))=ALB(IS+ISM(JC,II))*ZSIGN + IFR(IS+ISM(IC,II))=IFR(IS+ISM(JC,II)) + DVX(IT+ISM(IC,II))=DVX(IT+ISM(JC,II))*ZSIGN + MIXOLD=MIX(IT+ISM(IC,II)) + MIXNEW=MIX(IT+ISM(JC,II)) + DO 36 KC=1,NCOUR + IF(MIX(IT+KC).EQ.MIXOLD) MIX(IT+KC)=MIXNEW +36 CONTINUE + ENDIF +40 CONTINUE + IF((ICCC(2).EQ.-ICCC(6)).AND.(ICCC(3).EQ.-ICCC(5))) THEN + SUR(IS+ISM(1,II))=0.5*SUR(IS+ISM(1,II)) + SUR(IS+ISM(4,II))=0.5*SUR(IS+ISM(4,II)) + ELSE IF((ICCC(1).EQ.-ICCC(3)).AND.(ICCC(4).EQ.-ICCC(6))) THEN + SUR(IS+ISM(2,II))=0.5*SUR(IS+ISM(2,II)) + SUR(IS+ISM(5,II))=0.5*SUR(IS+ISM(5,II)) + ELSE IF((ICCC(1).EQ.-ICCC(5)).AND.(ICCC(2).EQ.-ICCC(4))) THEN + SUR(IS+ISM(3,II))=0.5*SUR(IS+ISM(3,II)) + SUR(IS+ISM(6,II))=0.5*SUR(IS+ISM(6,II)) + ENDIF + IF((K0.EQ.1).AND.(NCODE(5).EQ.5)) THEN + FRZ=0.5 + ALB(IS+ISM(7,II))=-ALB(IS+ISM(8,II)) + IFR(IS+ISM(7,II))=IFR(IS+ISM(8,II)) + SUR(IS+ISM(1:6,II))=0.5*SUR(IS+ISM(1:6,II)) + DVX(IT+ISM(7,II))=-DVX(IT+ISM(8,II)) + MIXOLD=MIX(IT+ISM(7,II)) + MIXNEW=MIX(IT+ISM(8,II)) + ELSE IF((K0.EQ.LZ).AND.(NCODE(6).EQ.5)) THEN + FRZ=0.5 + ALB(IS+ISM(8,II))=-ALB(IS+ISM(7,II)) + IFR(IS+ISM(8,II))=IFR(IS+ISM(7,II)) + SUR(IS+ISM(1:6,II))=0.5*SUR(IS+ISM(1:6,II)) + DVX(IT+ISM(8,II))=-DVX(IT+ISM(7,II)) + MIXOLD=MIX(IT+ISM(8,II)) + MIXNEW=MIX(IT+ISM(7,II)) + ENDIF + IF(FRZ.EQ.0.5) THEN + DO 45 KC=1,NCOUR + IF(MIX(IT+KC).EQ.MIXOLD) MIX(IT+KC)=MIXNEW +45 CONTINUE + ENDIF +50 GG3(IBLK)=FRX*FRZ +51 CONTINUE +52 CONTINUE + DO 60 I=1,NCOUR*NMBLK + IFR(I)=MIX(IFR(I)) +60 CONTINUE +*---- +* ELIMINATION OF THE BLOCKS OUTSIDE THE DOMAIN +*---- + JBLK=0 + DO 80 IBLK=1,NMBLK + IKK=INUM(IBLK) + IF(IKK.GT.0) THEN + JBLK=JBLK+1 + INUM(JBLK)=IKK + IORI(JBLK)=IORI(IBLK) + GG3(JBLK)=GG3(IBLK) + IS=NCOUR*(IBLK-1) + JS=NCOUR*(JBLK-1) + DO 70 IC=1,NCOUR + IFR(JS+IC)=IFR(IS+IC) + ALB(JS+IC)=ALB(IS+IC) + SUR(JS+IC)=SUR(IS+IC) +70 CONTINUE + ENDIF +80 CONTINUE + NMBLK=JBLK +* + DO 90 IKK=1,NMERGE + POURCE(IKK)=0.0 +90 CONTINUE + DO 110 IBLK=1,NMBLK + IKK=INUM(IBLK) + POURCE(IKK)=POURCE(IKK)+GG3(IBLK) +110 CONTINUE +*---- +* VALIDATION OF VECTOR IFR +*---- + DO 125 IBLK=1,NMBLK + IS=NCOUR*(IBLK-1) + DO 120 IC=1,NCOUR + ISURF=IFR(IS+IC) + IF(ISURF.EQ.0) THEN + GO TO 570 + ENDIF + JC=1+MOD(ISURF-1,NCOUR) + JT=NCOUR*((ISURF-1)/NCOUR) + IF(MIX(JT+JC).NE.ISURF) THEN + GO TO 570 + ENDIF +120 CONTINUE +125 CONTINUE +*---- +* VALIDATION OF THE GEOMETRICAL RECIPROCITY AND MODIFICATION OF ALBEDOS +*---- + DO 135 IBLK=1,NMBLK + IKK=INUM(IBLK) + IKG=IGEN(IKK) + IS=NCOUR*(IBLK-1) + IT=NCOUR*(IKK-1) + DO 130 IC=1,NCOUR + ALB(IS+IC)=ALB(IS+IC)*GG3(IBLK)/POURCE(IKK) + IP=1+MOD(MIX(IT+IC)-1,NCOUR) + FR1=XX(IKG)*ZZ(IKG) + IF((IP.EQ.7).OR.(IP.EQ.8)) FR1=1.5*SQRT(3.0)*XX(IKG)*XX(IKG) + JP=1+MOD(IFR(IS+IC)-1,NCOUR) + JKG=IGEN(1+(IFR(IS+IC)-1)/NCOUR) + FR2=XX(IKG)*ZZ(JKG) + IF((JP.EQ.7).OR.(JP.EQ.8)) FR2=1.5*SQRT(3.0)*XX(IKG)*XX(IKG) + DELTA=ABS(FR1-FR2) + IF(ABS(FR1-FR2).GT.EPS) THEN + WRITE (HSMG,680) DIRR(IP),IKG,DIRR(JP),JKG + CALL XABORT(HSMG) + ENDIF +130 CONTINUE +135 CONTINUE +*---- +* COMPUTE VECTOR DVX +*---- + DO 205 IKK=1,NMERGE + IKG=IGEN(IKK) + IF(NCOUR.EQ.6) THEN + DO 140 IC=1,NCOUR + DDD(IC)=1.0/6.0 +140 CONTINUE + ELSE IF(NCOUR.EQ.8) THEN + SURFA=1.5*SQRT(3.0)*XX(IKG)*XX(IKG) + DO 150 IC=1,6 + DDD(IC)=XX(IKG)*ZZ(IKG)/(2.0*SURFA+6.0*XX(IKG)*ZZ(IKG)) +150 CONTINUE + DDD(7)=SURFA/(2.0*SURFA+6.0*XX(IKG)*ZZ(IKG)) + DDD(8)=DDD(7) + ENDIF + IT=NCOUR*(IKK-1) + DO 200 IC=1,NCOUR + IF(MULTC.EQ.1) THEN +* ROTH APPROXIMATION. + DVX(IT+IC)=DDD(IC) + MIX(IT+IC)=IKK + ELSE + DELTA=0.0 + I1=MIX(IT+IC) + DO 180 JC=1,NCOUR + IF(MIX(IT+JC).EQ.I1) DELTA=DELTA+DDD(JC) +180 CONTINUE + ZSIGN=SIGN(1.0,DVX(IT+IC)) + DVX(IT+IC)=ZSIGN*DDD(IC)/DELTA + ENDIF +200 CONTINUE +205 CONTINUE + IJAS=NCOUR*NMBLK + IJAR=NCOUR*NMERGE +*---- +* RECOMPUTE VECTOR IFR FOR ROTH APPROXIMATION +*---- + IF(MULTC.EQ.1) THEN + DO 210 I=1,IJAS + IFR(I)=1+(IFR(I)-1)/NCOUR +210 CONTINUE + ENDIF +*---- +* REMOVE THE UNUSED SURFACE NUMBERS +*---- + DO 240 I=1,IJAS + JF2(I)=0 +240 CONTINUE + IJAT=0 + DO 250 I=1,IJAR + J=MIX(I) + IF(J.GT.IJAS) THEN + GO TO 570 + ENDIF + IF(JF2(J).EQ.0) THEN + IJAT=IJAT+1 + JF2(J)=IJAT + ENDIF +250 CONTINUE + DO 260 I=1,IJAR + MIX(I)=JF2(MIX(I)) +260 CONTINUE + DO 270 I=1,IJAS + IFR(I)=JF2(IFR(I)) +270 CONTINUE +*---- +* INCLUDE THE DP-1 APPROXIMATION +*---- + IF((MULTC.EQ.4).AND.(NCOUR.EQ.6)) THEN +* DP-1 APPROXIMATION IN 2-D. + DO 330 I1=IJAR,1,-1 + ZSIGN=SIGN(1.0,DVX(I1)) + FR1=ABS(DVX(I1)) + FR2=SUR(I1) + JND=(MIX(I1)-1)*3 + DO 320 JCOUR=1,3 + JSURF=(I1-1)*3+JCOUR + DVX(JSURF)=FR1 + MIX(JSURF)=JND+JCOUR +320 CONTINUE + DVX(JSURF)=ZSIGN*FR1 +330 CONTINUE + DO 350 I1=IJAS,1,-1 + ZSIGN=SIGN(1.0,ALB(I1)) + FR1=ABS(ALB(I1)) + FR2=SUR(I1) + JND=(IFR(I1)-1)*3 + DO 340 JCOUR=1,3 + JSURF=(I1-1)*3+JCOUR + ALB(JSURF)=FR1 + SUR(JSURF)=FR2 + IFR(JSURF)=JND+JCOUR +340 CONTINUE + ALB(JSURF)=ZSIGN*FR1 +350 CONTINUE + NCOUR=18 + ELSE IF((MULTC.EQ.4).AND.(NCOUR.EQ.8)) THEN + CALL XABORT('NUMERH: INVALID OPTION.') + ELSE + DO 360 I=1,IJAS + ALB(I)=ABS(ALB(I)) +360 CONTINUE + DO 370 I=1,IJAR + DVX(I)=ABS(DVX(I)) +370 CONTINUE + ENDIF + IJAS=NCOUR*NMBLK + IJAR=NCOUR*NMERGE +*---- +* PRINT THE SURFACE NUMBERS AFTER MERGING +*---- + IF(IMPX.GT.2) THEN + WRITE (6,620) + MIN8=MIN(8,NCOUR) + WRITE (6,650) ('---------------',I=1,MIN8) + DO 410 IBLK=1,NMBLK + IKK=INUM(IBLK) + WRITE (6,630) IBLK,IKK,IGEN(IKK),POURCE(IKK) + I1=IORI(IBLK) + IF((MULTC.EQ.4).AND.(NCOUR.EQ.18)) THEN + DO 380 I=1,18 + ISMZ(I)=3*ISM(1+(I-1)/3,I1)+MOD(I-1,3)-2 + DIRZ(I)=DIRR(1+(I-1)/3) +380 CONTINUE + ELSE + DO 400 I=1,NCOUR + ISMZ(I)=ISM(I,I1) + DIRZ(I)=DIRR(I) +400 CONTINUE + ENDIF + IT0=NCOUR*(IBLK-1) + IT1=NCOUR*(IKK-1) + WRITE (6,660) (DIRZ(I),I=1,MIN8) + WRITE (6,635) (MIX(IT1+ISMZ(I)),IFR(IT0+ISMZ(I)),I=1,MIN8) + WRITE (6,640) (ALB(IT0+ISMZ(I)),I=1,MIN8) + WRITE (6,645) (DVX(IT1+ISMZ(I)),I=1,MIN8) + IF(NCOUR.EQ.18) THEN + WRITE (6,660) (DIRZ(I),I=9,16) + WRITE (6,635) (MIX(IT1+ISMZ(I)),IFR(IT0+ISMZ(I)),I=9,16) + WRITE (6,640) (ALB(IT0+ISMZ(I)),I=9,16) + WRITE (6,645) (DVX(IT1+ISMZ(I)),I=9,16) + WRITE (6,660) (DIRZ(I),I=17,18) + WRITE (6,635) (MIX(IT1+ISMZ(I)),IFR(IT0+ISMZ(I)),I=17,18) + WRITE (6,640) (ALB(IT0+ISMZ(I)),I=17,18) + WRITE (6,645) (DVX(IT1+ISMZ(I)),I=17,18) + ENDIF + WRITE (6,650) ('---------------',I=1,MIN8) +410 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GG3,JF2) + RETURN +* +570 WRITE (6,620) + WRITE (6,650) ('---------------',I=1,NCOUR) + DO 580 IBLK=1,NMBLK + IKK=INUM(IBLK) + WRITE (6,630) IBLK,IKK,IGEN(IKK),POURCE(IKK) + I1=IORI(IBLK) + IT0=NCOUR*(IBLK-1) + IT1=NCOUR*(IKK-1) + WRITE (6,660) (DIRR(I),I=1,NCOUR) + WRITE (6,635) (MIX(IT1+ISM(I,I1)),IFR(IT0+ISM(I,I1)),I=1,NCOUR) + WRITE (6,640) (ALB(IT0+ISM(I,I1)),I=1,NCOUR) + WRITE (6,645) (DVX(IT1+ISM(I,I1)),I=1,NCOUR) + WRITE (6,650) ('---------------',I=1,NCOUR) +580 CONTINUE + CALL XABORT('NUMERH: FAILURE OF THE SURFACE RENUMBERING ALGORITH' + 1 //'M.') +* +610 FORMAT(9H HEXAGON=,I5,5X,11HNEIGHBOURS=,6I5,5X,7HWEIGHT=,F7.4) +620 FORMAT (///31H SURFACE NUMBERS AFTER MERGING./) +630 FORMAT (7H BLOCK=,I5,5X,13HMERGED BLOCK=,I5,5X,12HGENERATING B, + 1 5HLOCK=,I5,5X,7HPOURCE=,1P,E12.4) +635 FORMAT (8H IN/OUT:,8(I5,2H /,I5,3H I)) +640 FORMAT (8H ALBEDO:,1P,8(E12.4,3H I)) +645 FORMAT (8H DVX:,1P,8(E12.4,3H I)) +650 FORMAT (8H -------,8(A15)) +660 FORMAT (/8H SIDE:,8(A9,5X,1HI)) +680 FORMAT (49HNUMERH: GEOMETRICAL RECIPROCITY CONDITION IS VIOL, + 1 10HATED (SIDE,A3,20H OF GENERATING BLOCK,I5,8H VS SIDE,A3, + 2 20H OF GENERATING BLOCK,I5,3H ).) + END diff --git a/Dragon/src/NXT.f b/Dragon/src/NXT.f new file mode 100644 index 0000000..566250f --- /dev/null +++ b/Dragon/src/NXT.f @@ -0,0 +1,299 @@ +*DECK NXT + SUBROUTINE NXT(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Module used to analyze and track a geometry data structure based +* on the new EXCELL type procedure. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* NENTRY number of data structures transfered to this module. +* HENTRY name of the data structures. +* IENTRY data structure type where: +* =1 for LCM memory object; +* =2 for XSM file; +* =3 for sequential binary file; +* =4 for sequential ASCII file. +* JENTRY access permission for the data structure where: +* =0 for a data structure in creation mode; +* =1 for a data structure in modifications mode; +* =2 for a data structure in read-only mode. +* KENTRY data structure pointer. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*Comments: +* Instructions for the use of the NXT: module: +* Option 1 -- Analyze and optionnally track a basic geometry +* [ TRKFIL ] VOLTRK := NXT: GEOMETRY :: (nxtget) ; +* Option 2 -- Track a geometry already analyzed +* TRKFIL VOLTRK := NXT: VOLTRK :: (nxtget) ; +* where +* TRKFIL : sequential binary tracking file to be created +* VOLTRK : tracking data structure +* (signature L_TRACK) +* GEOMETRY : geometry data structure +* (signature L_GEOM) +* (nxtget) : Processing options +* (read from input using the NXTGET routine). +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXT ') + INTEGER ILCMUP,ILCMDN + PARAMETER (ILCMUP=1,ILCMDN=2) + INTEGER NSTATE,MAXENT + PARAMETER (NSTATE=40,MAXENT=2) + INTEGER IUTYPE + PARAMETER (IUTYPE=2) +*---- +* Local variables +*---- + TYPE(C_PTR) IPGEO,IPTRK + INTEGER IMGEO,IMTRK,IFTRK,IMFTRK + INTEGER IGANA,IGTRK + INTEGER IEN,ITC + INTEGER IQUA10,IBIHET + CHARACTER HSIGN*12 + CHARACTER TEXT12*12 + INTEGER ISTATT(NSTATE) + REAL RSTATT(NSTATE) + CHARACTER TITLE*72 + INTEGER IPRINT,ITITL(18) + INTEGER NBSLIN + INTEGER ILONG,ITYLCM +*---- +* Validate entry parameters +*---- + IF(NENTRY .LT. 2) CALL XABORT(NAMSBR// + > ': At least two data structures required') + IF(NENTRY .GT. 3) CALL XABORT(NAMSBR// + > ': Maximum of three data structures permitted') + IPGEO=C_NULL_PTR + IMGEO=0 + IPTRK=C_NULL_PTR + IMTRK=0 + IFTRK=0 + IMFTRK=0 + IGANA=0 + IGTRK=0 + NBSLIN=100000 +*---- +* Scan data structure to determine type and mode +*---- + DO IEN=1,NENTRY + IF(IENTRY(IEN) .EQ. 1 .OR. IENTRY(IEN) .EQ. 2) THEN + IF(JENTRY(IEN) .EQ. 0) THEN + IPTRK=KENTRY(IEN) + IMTRK=2 + HSIGN='L_TRACK ' + CALL LCMPTC(IPTRK,'SIGNATURE',12,HSIGN) + HSIGN='EXCELL' + CALL LCMPTC(IPTRK,'TRACK-TYPE',12,HSIGN) + ELSE + CALL LCMGTC(KENTRY(IEN),'SIGNATURE',12,HSIGN) + IF(HSIGN .EQ. 'L_GEOM') THEN + IPGEO=KENTRY(IEN) + IF(JENTRY(IEN) .NE. 2) CALL XABORT(NAMSBR// + > ': Geometry data structure not in read-only mode') + TEXT12=HENTRY(IEN) + CALL LCMPTC(IPTRK,'LINK.GEOM',12,TEXT12) + IMGEO=-1 + ELSE IF(HSIGN .EQ. 'L_TRACK') THEN + IPTRK=KENTRY(IEN) + IF(JENTRY(IEN) .NE. 1) CALL XABORT(NAMSBR// + > ': Tracking data structure not in update mode') + IMTRK=1 + CALL LCMGTC(IPTRK,'TRACK-TYPE',12,HSIGN) + IF(HSIGN .NE. 'EXCELL') CALL XABORT(NAMSBR// + > ': Tracking data structure type is invalid') + ELSE + CALL XABORT(NAMSBR// + > ': Invalid signature for '//HENTRY(IEN)) + ENDIF + ENDIF + ELSE IF(IENTRY(IEN) .EQ. 3) THEN + IF(JENTRY(IEN) .NE. 0) CALL XABORT(NAMSBR// + > ': Geometry data structure not in creation mode') + IFTRK=FILUNIT(KENTRY(IEN)) + IMFTRK=2 + ELSE + CALL XABORT(NAMSBR// + > ': Invalid data structure format for '//HENTRY(IEN)) + ENDIF + ENDDO +*---- +* Select processing option from data structures provided +*---- + IF(IMGEO .EQ. -1) THEN + IF(IMTRK .NE. 2) CALL XABORT(NAMSBR// + > ': Creation mode tracking data structure required') + IGANA=1 + IF(IMFTRK .EQ. 2) IGTRK=1 + ELSE IF(IMTRK .EQ. 1) THEN + IF(IMFTRK .NE. 2) CALL XABORT(NAMSBR// + > ': Creation mode tracking file required') + IGTRK=1 + ELSE + CALL XABORT(NAMSBR//': No processing option identified') + ENDIF +*---- +* Initialize tracking parameters to 0 +*---- + ISTATT(:NSTATE)=0 + RSTATT(:NSTATE)=0.0 +*---- +* Read state vectors available +*---- + IF(IMTRK .EQ. 1) THEN + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATT) + CALL LCMGET(IPTRK,'EXCELTRACKOP',RSTATT) + CALL LCMGET(IPTRK,'TITLE',ITITL) + WRITE(TITLE,'(18A4)') (ITITL(ITC),ITC=1,18) + IF(ISTATT(7) .NE. 4 ) CALL XABORT(NAMSBR// + > ': Tracking data structure incompatible with current module') + ISTATT(23)=1 + ELSE +*---- +* Define default tracking options that are different from 0 +*---- + ISTATT(6)=1 + ISTATT(7)=4 + ISTATT(11)=1 + ISTATT(12)=-1 + ISTATT(13)=1 + ISTATT(15)=1 + ISTATT(22)=0 + ISTATT(23)=1 + IF(IMFTRK .EQ. 0) ISTATT(22)=3 + IF(IMTRK .EQ. 2 .AND. IMGEO .EQ. -1) THEN + CALL LCMLEN(IPGEO,'BIHET',ILONG,ITYLCM) + IF(ILONG.NE.0) ISTATT(40)=1 + ENDIF + RSTATT(11)=1.0 + TITLE=' ' + HSIGN='EXCELL' + ENDIF +*---- +* Recover processing option +*---- + CALL NXTGET(NSTATE,IPRINT,TITLE ,ISTATT,RSTATT,NBSLIN,IQUA10, + > IBIHET) +*---- +* Save updated STATE-VECTOR, TITLE and EXCELL track options +* on tracking data structure +*---- + CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,ISTATT) + CALL LCMPUT(IPTRK,'EXCELTRACKOP',NSTATE,2,RSTATT) + READ(TITLE,'(18A4)') (ITITL(ITC),ITC=1,18) + CALL LCMPUT(IPTRK,'TITLE',18,3,ITITL) +*---- +* Analyse geometry if required +*---- + IF(IGANA .EQ. 1) THEN + CALL NXTACG(IPGEO ,IPTRK ,IPRINT) + ENDIF +*---- +* If a prismatic 3D tracking is requested, +* create 2D projected geometry analysis +*---- + IF(ISTATT(39) .NE. 0) THEN + CALL NXTPR3(IPTRK) + ENDIF +*---- +* Track geometry if required +*---- + IF(ISTATT(9) .GE. 0 .AND. ISTATT(23) .EQ. 1) THEN + IF(ISTATT(39) .NE. 0) CALL LCMSIX(IPTRK,'PROJECTION',1) + CALL NXTTCG(IPTRK ,IFTRK ,IPRINT,IGTRK ,NBSLIN) + IF(ISTATT(39) .NE. 0) CALL LCMSIX(IPTRK,' ',2) + ENDIF +*---- +* Add useful information for the Monte-Carlo method +*---- + IF(ISTATT(23) .EQ. -1) THEN + CALL NXTMCA(IPTRK) + ENDIF +*---- +* Process double heterogeneity (BIHET) data (if available) +*---- + IF(ISTATT(40) .NE. 0) THEN + CALL XDRTBH(IPGEO,IPTRK,IQUA10,IBIHET,IPRINT,RSTATT(39)) + ENDIF +*---- +* Processing finished, return +*---- + IF(IPRINT .GT. 1) THEN + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATT) + WRITE(IOUT,100) (ISTATT(ITC),ITC=1,10) + WRITE(IOUT,120) (ISTATT(ITC),ITC=11,22) + WRITE(IOUT,130) ISTATT(23),ISTATT(25:27),ISTATT(40) + ENDIF + RETURN +*---- +* Warning formats +*---- + 100 FORMAT(/ + 1 14H STATE VECTOR:/ + 2 7H NREG ,I9,22H (NUMBER OF REGIONS)/ + 3 7H KPN ,I9,23H (NUMBER OF UNKNOWNS)/ + 4 7H ILK ,I9,39H (0=LEAKAGE PRESENT/1=LEAKAGE ABSENT)/ + 5 7H NBMIX ,I9,36H (MAXIMUM NUMBER OF MIXTURES USED)/ + 6 7H NSURF ,I9,29H (NUMBER OF OUTER SURFACES)/ + 7 7H NANI ,I9,48H (1=P0 CROSS SECTIONS/2=P1 CROSS SECTIONS/...)/ + 8 7H GEOT ,I9,21H (TYPE OF GEOMETRY)/ + 9 7H NORM ,I9,48H (NORMALIZATION OPTION 1=ABSENT/0=GLOBAL/-1=NO, + 1 21HRMALIZATION BY ANGLE)/ + 2 7H TRKT ,I9,36H (TRACKING TYPE 0=FINITE/1=CYCLIC)/ + 3 7H BOUND ,I9,48H (BOUNDARY CONDITIONS TYPE 0=ISOTROPIC/1=SPECU, + 4 4HLAR)) + 120 FORMAT( + 1 7H NANG ,I9,30H (NUMBER OF TRACKING ANGLES)/ + 2 7H ASYM ,I9,28H (ANGULAR SYMMETRY FACTOR)/ + 3 7H POLQUA,I9,32H (POLAR ANGLE QUADRATURE TYPE)/ + 4 7H POLOAQ,I9,33H (POLAR ANGLE QUADRATURE ORDER)/ + 5 7H AZMQUA,I9,47H (AZIMUTHAL OR SOLID ANGULAR QUADRATURE TYPE)/ + 6 7H NDIM ,I9,25H (NUMBER OF DIMENSIONS)/ + 7 7H NPOINT,I9,40H (NUMBER OF TRACKING POINTS ON A LINE)/ + 8 7H MAXSGL,I9,30H (MAXIMUM LENGTH OF A TRACK)/ + 9 7H NTLINE,I9,37H (TOTAL NUMBER OF TRACKS GENERATED)/ + 1 7H NBTDIR,I9,47H (TOTAL NUMBER OF TRACK DIRECTIONS PROCESSED)/ + 2 7H NANGL ,I9,47H (NUMBER OF TRACK DIRECTION ANGLES CONSIDERED, + 3 20H IN THE INTEGRATION)/ + 4 7H INSB ,I9,25H (VECTORIZATION OPTION)) + 130 FORMAT( + 1 7H ITRACK,I9,47H (-1=MONTE-CARLO/0=DESACTIVATES TRACKING FILE, + 2 39H BUILD/1=ACTIVATES TRACKING FILE BUILD)/ + 3 7H NPLANE,I9,39H (NUMBER OF NORMAL PLANES CONSIDERED)/ + 4 7H MERGMX,I9,33H (0/1= MERGMIX ACTICATION FLAG)/ + 5 7H NBATCH,I9,41H (NUMBER OF TRACKS IN EACH OPENMP CORE)/ + 6 7H IBIHET,I9,46H (0/1=DOUBLE HETEROGENEITY IS NOT/IS ACTIVE)) + END diff --git a/Dragon/src/NXT3T2.f b/Dragon/src/NXT3T2.f new file mode 100644 index 0000000..f608d1e --- /dev/null +++ b/Dragon/src/NXT3T2.f @@ -0,0 +1,310 @@ +*DECK NXT3T2 + SUBROUTINE NXT3T2(IPTRK,JPTRK,IX,IY,IZ,NFREG,NFSUR,MAXMSH, + 1 NUCELL,NBUCEL,MXGSUR,MXGREG,MAXPIN,MATALB, + 2 SURVOL,IUNFLD,NZP,N2REG,N2SUR,N2CEL,N2PIN, + 3 IND2T3,ZCORD,MATALB2,SURVOL2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Create 2D projection (NXT geometry analysis) of a 3D prismatic +* geometry. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IPTRK pointer to the NXT 3D geometry analysis. +* JPTRK pointer to the NXT 2D projected geometry analysis. +* IX first direction perpendicular to the projection axis. +* IY second direction perpendicular to the projection axis. +* IZ projection axis. +* NFREG number of regions in the 3D geometry. +* NFSUR number of outer surfaces in the 3D geometry. +* MAXMSH maximum dimension of any mesh in any sub-geometry of the 3D +* geometry. +* NUCELL number of cells along the three axis in the 3D geometry. +* NBUCEL total number of cells in the 3D geometry. +* MXGSUR maximum number of surfaces for any sub-geometry of the 3D +* geometry. +* MXGREG maximum number of regions for any sub-geometry of the 3D +* geometry. +* MAXPIN maximum number of pins for any cell of the 3D geometry. +* MATALB mixtures/albedos array for the 3D geometry. +* SURVOL surfaces/volumes array for the 3D geometry. +* IUNFLD assembly description array for the 3D geometry (*,*,*,*,0) +* / projected 2D geometry (*,*,*,*,1). +* +*Parameters: output +* NZP number of plans in the 3D prismatic geometry. +* N2REG number of regions in the projected 2D geometry. +* N2SUR number of outer surfaces in the projected 2D geometry. +* N2CEL total number of cells in the projected 2D geometry. +* N2PIN total number of pin descriptions in the projected 2D geometry. +* IND2T3 mapping index between the 2D projected geometries (plan by +* plan) and the initial 3D geometry. +* ZCORD coordinates of the different plans of the 3D prismatic +* geometry. +* MATALB2 mixtures/albedos array for the projected 2D geometry. +* SURVOL2 surfaces/volumes array for the projected 2D geometry. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,JPTRK + INTEGER IX,IY,IZ,NFREG,NFSUR,MAXMSH,NUCELL(3),NBUCEL,MXGSUR, + 1 MXGREG,MAXPIN,MATALB(-NFSUR:NFREG), + 2 IUNFLD(2,NUCELL(1),NUCELL(2),NUCELL(3),0:1),NZP,N2REG,N2SUR, + 3 N2CEL,N2PIN,IND2T3(-NFSUR:NFREG,0:NUCELL(IZ)*MAXMSH+1), + 4 MATALB2(-NFSUR:NFREG) + DOUBLE PRECISION SURVOL(-NFSUR:NFREG),ZCORD(0:MAXMSH), + 1 SURVOL2(-NFSUR:NFREG) +*---- +* LOCAL VARIABLES +*---- + INTEGER NSTATE + DOUBLE PRECISION DEPS + PARAMETER(NSTATE=40,DEPS=1.D-7) + INTEGER ESTATE(NSTATE) + INTEGER I,J,ITRN,ICEL,K,JJ,II,NTPINR,N2SURC,N2REGC,IPIN,N2SURP, + 1 N2REGP,NUNK2 + DOUBLE PRECISION DELZ,HPIN,APIN,RPIN,RADP +!! CHARACTER SIZEX*5,FORM*30 + CHARACTER NAMCEL*9,NAMREC*12,NAMCE2*9 + LOGICAL LFIRST,XDDCOM,LPIN,LSTCEL,LSTPIN + CHARACTER CDIR(4)*1 + DATA CDIR /'X','Y','Z','R'/ +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NSURC,NREGC,IDIRC,NTPIN, + > REGI,CELID,PINID + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IDSUR,IDREG,MESHC + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: INDEX,ITPIN + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: DCMESH,DRAPIN +* +!!!! WRITE(SIZEX,*) NUCELL(1) +!!!! FORM='('//SIZEX//'(I2,1X,1H(,I2,1H),2X))' +!!!! WRITE(6,*) 'GLOBAL ASSEMBLY:' +!!!! DO K=1,MAX(NUCELL(3),1) +!!!! WRITE(6,*) K,' z-plan' +!!!! DO J=NUCELL(2),1,-1 +!!!! WRITE(6,FORM) ((IUNFLD(JJ,I,J,K,0),JJ=1,2),I=1,NUCELL(1)) +!!!! ENDDO +!!!! ENDDO +*---- +* Scratch storage allocation +*---- + ALLOCATE(INDEX(5,-MXGSUR:MXGREG,0:NUCELL(IZ)), + > IDSUR(MXGSUR,0:NUCELL(IZ)),IDREG(MXGREG,0:NUCELL(IZ)), + > MESHC(4,NUCELL(IZ)),NSURC(NUCELL(IZ)),NREGC(NUCELL(IZ)), + > IDIRC(NUCELL(IZ)),NTPIN(NUCELL(IZ)), + > ITPIN(3,MAXPIN,0:NUCELL(IZ))) + ALLOCATE(DCMESH(-1:MAXMSH,4,0:NUCELL(IZ)), + > DRAPIN(-1:4,MAXPIN,0:NUCELL(IZ)),REGI(-NFSUR:NFREG), + > CELID(NBUCEL),PINID(NBUCEL*MAXPIN)) +* + REGI(-NFSUR:NFREG)=0 + CELID(:NBUCEL)=0 + IND2T3(-NFSUR:NFREG,0:NUCELL(IZ)*MAXMSH+1)=0 + N2SUR=0 + N2REG=0 + N2CEL=0 + N2PIN=0 + LFIRST=.TRUE. + LSTCEL=.FALSE. + DO 15 J=1,NUCELL(IY) + DO 10 I=1,NUCELL(IX) +*---- +* LOOP OVER THE CELLS IN THE PLAN PERPENDICULAR TO THE PROJECTION AXIS +*---- +* ---- +* CELL LEVEL (1) +* ---- + !write(*,*) 'CELL LEVEL (',I,J,' )' + DO K=1,NUCELL(IZ) + ICEL=IUNFLD(1,I,J,K,0) + ITRN=IUNFLD(2,I,J,K,0) + IF (ITRN.NE.IUNFLD(2,I,J,1,0)) + 1 CALL XABORT('NXT3T2: INVALID PRISMATIC GEOMETRY (TURN).') +* LOAD THE CONTENTS OF THE DIFFERENT CELLS (I,J,K=1,NUCELL(IZ)) + CALL NXTLDC(IPTRK,MAXMSH,ICEL,IDIRC(K),MESHC(1,K),NSURC(K), + 1 NREGC(K),NTPIN(K),DCMESH(-1,1,K),INDEX(1,-MXGSUR,K), + 2 IDREG(1,K),IDSUR(1,K),ITPIN(1,1,K),DRAPIN(-1,1,K)) + !write(*,*) 'loading cell',ICEL,MESHC(1,K),MESHC(2,K),MESHC(4,K) + IF (K.EQ.1) THEN + IF (CELID(ICEL).EQ.0) THEN +* RECOVER DIM INFO FOR THE CORRESPONDING 2D CELL + LSTCEL=.TRUE. + N2CEL=N2CEL+1 + WRITE(NAMCEL,'(A1,I8.8)') 'C',ICEL + !write(*,*) 'copying from ',NAMCEL + NAMREC=NAMCEL//'DIM' + ESTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,NAMREC,ESTATE) + IF ((ESTATE(1).EQ.21).OR. + 1 (ESTATE(1).EQ.22).OR. + 2 (ESTATE(1).EQ.23)) THEN + ESTATE(1)=20 + ELSEIF(ESTATE(1).EQ.7) THEN + ESTATE(1)=5 + ENDIF + ESTATE(5)=0 + ESTATE(6)=0 + ESTATE(12)=N2REG+1 + ESTATE(14)=N2SUR+1 + CELID(ICEL)=N2CEL + ENDIF + IUNFLD(1,I,J,1,1)=CELID(ICEL) + IUNFLD(2,I,J,1,1)=ITRN + ENDIF + ENDDO +* CHECK CELLS COMPATIBILITY, UPDATE IND2T3 FOR THIS SET OF CELLS +* AND FILL-IN 2D CORRESPONDING CELL CONTENTS + NTPINR=NTPIN(1) + DO K=2,NUCELL(IZ) + IF (NTPIN(K).NE.NTPINR) + 1 CALL XABORT('NXT3T2: INVALID PRISMATIC GEOMETRY (NTPIN).') + ENDDO + CALL NXTPRI(IPTRK,JPTRK,IX,IY,IZ,NFREG,NFSUR,MAXMSH,NUCELL,MXGSUR, + 1 MXGREG,INDEX,IDSUR,IDREG,MESHC,NSURC,NREGC,IDIRC,NZP,N2REG, + 2 N2SUR,IND2T3,REGI,DEPS,DCMESH,ZCORD,LFIRST,LSTCEL,1, + 3 IUNFLD(1,I,J,1,0),N2CEL,N2SURC,N2REGC) + IF (LSTCEL) THEN +* STORE 2D CELL CONTENTS: DIM ARRAY + ESTATE(10)=N2REGC + ESTATE(11)=N2SURC + ESTATE(13)=N2REG + ESTATE(15)=N2SUR + !write(*,*) ESTATE(1),ESTATE(2) + WRITE(NAMCE2,'(A1,I8.8)') 'C',N2CEL + NAMREC=NAMCE2//'DIM' + CALL LCMPUT(JPTRK,NAMREC,NSTATE,1,ESTATE) + ENDIF +* ---- +* PIN LEVEL (2) +* ---- + PINID(:NTPINR)=0 + DO II=1,NTPINR + !write(*,*) 'PIN LEVEL ( ',II,')' +* LOAD THE CONTENTS OF THE DIFFERENT PINS (II,K=1,NUCELL(IZ)) + IDIRC(1)=ABS(ITPIN(3,II,1)) + IPIN=ITPIN(2,II,1) + HPIN=DRAPIN(IZ,II,1) + DELZ=DCMESH(MESHC(IZ,1),IZ,1)-DCMESH(0,IZ,1) + IF (.NOT.XDDCOM(DELZ,HPIN,DEPS)) + 1 CALL XABORT('NXT3T2: INVALID PRISMATIC GEOMETRY (HPIN).') + CALL NXTLDP(IPTRK,MAXMSH,IPIN,MESHC(1,1),NSURC(1),NREGC(1), + 1 DCMESH(-1,1,1),INDEX(1,-MXGSUR,1),IDREG(1,1),IDSUR(1,1)) + APIN=DRAPIN(-1,II,1) + RPIN=DRAPIN( 0,II,1) + RADP=DRAPIN( 4,II,1) + LSTPIN=.FALSE. + IF (PINID(IPIN).EQ.0) THEN +* RECOVER DIM INFO FOR THE CORRESPONDING 2D PIN + LSTPIN=.TRUE. + N2PIN=N2PIN+1 + WRITE(NAMCEL,'(A1,I8.8)') 'P',IPIN + !write(*,*) 'copying from ',NAMCEL + NAMREC=NAMCEL//'DIM' + ESTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,NAMREC,ESTATE) + IF ((ESTATE(1).EQ.6).OR. + 1 (ESTATE(1).EQ.10).OR. + 2 (ESTATE(1).EQ.11)) THEN + ESTATE(1)=3 + ENDIF + ESTATE(5)=0 + ESTATE(6)=0 + ESTATE(12)=N2REG+1 + ESTATE(14)=N2SUR+1 + PINID(IPIN)=N2PIN + ENDIF + ITPIN(1,II,0)=ITPIN(1,II,1) + ITPIN(2,II,0)=PINID(IPIN) + ITPIN(3,II,0)=3 + DRAPIN(-1,II,0)=APIN + DRAPIN( 0,II,0)=RPIN + DRAPIN( 1,II,0)=0.D0 + DRAPIN( 2,II,0)=0.D0 + DRAPIN( 3,II,0)=1.D0 + DRAPIN( 4,II,0)=RADP + DO K=2,NUCELL(IZ) + DO JJ=1,NTPINR + LPIN=.TRUE. + LPIN=LPIN.AND.(XDDCOM(HPIN,DRAPIN(IZ,JJ,K),DEPS)) + LPIN=LPIN.AND.(XDDCOM(APIN,DRAPIN(-1,JJ,K),DEPS)) + LPIN=LPIN.AND.(XDDCOM(RPIN,DRAPIN( 0,JJ,K),DEPS)) + LPIN=LPIN.AND.(XDDCOM(RADP,DRAPIN( 4,JJ,K),DEPS)) + IF (LPIN) THEN + IPIN=ITPIN(2,JJ,K) + IDIRC(K)=ABS(ITPIN(3,JJ,K)) + GOTO 20 + ENDIF + ENDDO + CALL XABORT('NXT3T2: INVALID PRISMATIC GEOMETRY (PIN).') + 20 CONTINUE + CALL NXTLDP(IPTRK,MAXMSH,IPIN,MESHC(1,K),NSURC(K),NREGC(K), + 1 DCMESH(-1,1,K),INDEX(1,-MXGSUR,K),IDREG(1,K), + 2 IDSUR(1,K)) + ENDDO +* CHECK PINS COMPATIBILITY AND UPDATE IND2T3 FOR THIS SET OF PINS + CALL NXTPRI(IPTRK,JPTRK,IX,IY,IZ,NFREG,NFSUR,MAXMSH,NUCELL, + 1 MXGSUR,MXGREG,INDEX,IDSUR,IDREG,MESHC,NSURC,NREGC,IDIRC, + 2 NZP,N2REG,N2SUR,IND2T3,REGI,DEPS,DCMESH,ZCORD,LFIRST, + 3 LSTPIN,2,ITPIN(2,II,1),N2PIN,N2SURP,N2REGP) + IF (LSTPIN) THEN +* STORE 2D PIN CONTENTS: DIM ARRAY + ESTATE(10)=N2REGP + ESTATE(11)=N2SURP + ESTATE(13)=N2REG + ESTATE(15)=N2SUR + WRITE(NAMCE2,'(A1,I8.8)') 'P',N2PIN + NAMREC=NAMCE2//'DIM' + CALL LCMPUT(JPTRK,NAMREC,NSTATE,1,ESTATE) + ENDIF + ENDDO + IF (LSTCEL) THEN +* STORE 2D CELL CONTENTS: PIN RELATED + IF (NTPINR.GT.0) THEN + WRITE(NAMCE2,'(A1,I8.8)') 'C',N2CEL + NAMREC=NAMCE2//'PIN' + CALL LCMPUT(JPTRK,NAMREC,6*NTPINR,4,DRAPIN(-1,1,0)) + NAMREC=NAMCE2//'PNT' + CALL LCMPUT(JPTRK,NAMREC,3*NTPINR,1,ITPIN(1,1,0)) + ENDIF + ENDIF + LSTCEL=.FALSE. + LFIRST=.FALSE. +*---- + 10 CONTINUE + 15 CONTINUE + N2SUR=-N2SUR +*---- +* FILL IN AND STORE MATALB AND SareaRvolume ARRAYS FOR THE 2D GEOMETRY +*---- + DELZ=ZCORD(1) + DO I=-N2SUR,N2REG + MATALB2(I)=MATALB(IND2T3(I,1)) + SURVOL2(I)=SURVOL(IND2T3(I,1))/DELZ + ENDDO + NUNK2=N2SUR+N2REG+1 + CALL LCMPUT(JPTRK,'MATALB ',NUNK2,1,MATALB2(-N2SUR)) + CALL LCMPUT(JPTRK,'SAreaRvolume',NUNK2,4,SURVOL2(-N2SUR)) +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(PINID,CELID,REGI,DRAPIN,DCMESH) + DEALLOCATE(ITPIN,NTPIN,IDIRC,NREGC,NSURC,MESHC,IDREG,IDSUR,INDEX) + RETURN + END diff --git a/Dragon/src/NXTACG.f b/Dragon/src/NXTACG.f new file mode 100644 index 0000000..858d8ef --- /dev/null +++ b/Dragon/src/NXTACG.f @@ -0,0 +1,409 @@ +*DECK NXTACG + SUBROUTINE NXTACG(IPGEO ,IPTRK ,IPRINT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To analyze an assembly of cells containing +* clusters using the new EXCELL tracking procedure. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPGEO pointer to the GEOMETRY data structure in +* read only mode. +* IPTRK pointer to the TRACKING data structure in +* update or creation mode. +* IPRINT print level. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPGEO,IPTRK + INTEGER IPRINT +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTACG') + INTEGER NSTATE + PARAMETER (NSTATE=40) +*---- +* Local variables +*---- + INTEGER NDIM,ITYPBC,ITYGEO,IDIRG + INTEGER ISTATG(NSTATE),ISTATT(NSTATE),IEDIMG(NSTATE) + INTEGER ILEAK,IDIAG,ISAXIS(3),NBOCEL,NBUCEL, + > NOCELL(3),NUCELL(3),MAXCEL + INTEGER IDIR,IMCELL,ILCELL,MAXPIN,MAXMSP, + > MAXMSH,MAXREG,NBTCLS + INTEGER NFSUR,NFREG,MXGSUR,MXGREG,IANIS,NBUNK + INTEGER NEREG,NESUR + CHARACTER NAMREC*12 +*---- +* Update for Hexagonal geometry +*---- + INTEGER IHSYM +*---- +* Update for prismatic geometry +*---- + INTEGER IPRISM +*---- +* Update for MERGMIX +*---- + INTEGER MRGMIX +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDIRR,ITURN,MERGE,KEYMRG, + > MATRT,MATRTN,KEYFLX + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IDFEX,IDFRT,ITSYM,IUNFLD, + > NAGGEO,MATALB,MATCOD + REAL, ALLOCATABLE, DIMENSION(:) :: VOLUME + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SURVOL + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: DGMESH + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: DCMESH +*---- +* Processing starts: +* print routine opening header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6010) + ENDIF +*---- +* Get state vectors +*---- + ISTATG(:NSTATE)=0 + CALL LCMGET(IPGEO,'STATE-VECTOR',ISTATG) + ISTATT(:NSTATE)=0 + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATT) +*---- +* Get geometry state vector and test if geometry +* is valid for NXT. +* Valid geometries are: +* Cartesian Boundary (ITYPBC=0): +* CAR2D (5), CAR3D (7), +* CARCEL (20), CARCELX (21), CARCELY (22), CARCELZ (23) +* Annular Boundary (ITYPBC=1): +* TUBE (3), TUBEX (10), TUBEY (11), TUBEZ (6) +* Hexagonal Boundary (ITYPBC=2): +* HEX (8) , HEXZ (9), HEXT (12) , HEXTZ (13) +* Initialize +* NDIM : number of dimensions for problem +* IDIRG : first direction to process +* ITYPBC : type of boundary +*---- + NDIM=2 + IDIRG=3 + ITYPBC=0 + ITYGEO=ISTATG(1) + IF(ITYGEO .EQ. 5) THEN + IDIRG=1 + ELSE IF(ITYGEO .EQ. 7) THEN + NDIM=3 + IDIRG=1 + ELSE IF(ITYGEO .EQ. 20) THEN + IDIRG=1 + ELSE IF(ITYGEO .EQ. 21) THEN + NDIM=3 + IDIRG=2 + ELSE IF(ITYGEO .EQ. 22) THEN + NDIM=3 + ELSE IF(ITYGEO .EQ. 23) THEN + NDIM=3 + IDIRG=1 + ELSE IF(ITYGEO .EQ. 3) THEN + IDIRG=1 + ITYPBC=1 + ELSE IF(ITYGEO .EQ. 6) THEN + NDIM=3 + IDIRG=1 + ITYPBC=1 + ELSE IF(ITYGEO .EQ. 10) THEN + NDIM=3 + IDIRG=2 + ITYPBC=1 + ELSE IF(ITYGEO .EQ. 11) THEN + NDIM=3 + ITYPBC=1 + ELSE IF(ITYGEO .EQ. 8) THEN + IDIRG=1 + ITYPBC=2 + ELSE IF(ITYGEO .EQ. 9) THEN + NDIM=3 + IDIRG=1 + ITYPBC=2 + ELSE IF(ITYGEO .EQ. 12) THEN + IDIRG=1 + ITYPBC=2 + ELSE IF(ITYGEO .EQ. 13) THEN + NDIM=3 + IDIRG=1 + ITYPBC=2 + ELSE IF(ITYGEO .EQ. 26) THEN + IDIRG=1 + ITYPBC=2 + ELSE IF(ITYGEO .EQ. 27) THEN + NDIM=3 + IDIRG=1 + ITYPBC=2 + ELSE + CALL XABORT(NAMSBR// + > ': Module cannot analyze this geometry') + ENDIF + IMCELL=ISTATG(8) + IF(IMCELL .EQ. 0) THEN +*---- +* Pure geometry +* Create assembly of one cell +*---- + NOCELL(1)=1 + NOCELL(2)=1 + NOCELL(3)=1 + IF(NDIM .LT. 3) NOCELL(3)=0 + ILCELL=0 + ELSE +*---- +* Assembly +*---- + NOCELL(1)=ISTATG(3) + NOCELL(2)=ISTATG(4) + NOCELL(3)=ISTATG(5) + ILCELL=1 + ENDIF + IPRISM=ISTATT(39) + MRGMIX=ISTATT(26) +*---- +* Read and analyze boundary conditions +*---- + CALL NXTBCG(IPGEO ,IPTRK ,IPRINT,NDIM ,ITYPBC,IDIRG , + > IDIAG ,ISAXIS,IHSYM ,ILEAK ,IPRISM) + IF(IDIAG .NE. 0) THEN + IF(NOCELL(1) .NE. NOCELL(2)) CALL XABORT(NAMSBR// + > ': DIAG requires symmetric X-Y mesh.') + ENDIF + IEDIMG(:NSTATE)=0 + IEDIMG(1)=NDIM + IEDIMG(2)=ITYPBC + IEDIMG(3)=IDIRG +*---- +* Compute global mesh in each direction and +* total number of cells after unfolding of geometry +*---- + IF(ITYPBC .EQ. 0) THEN +* Full Cartesian + IF(IDIAG .EQ. 0) THEN + NBOCEL=1 + DO IDIR=1,3 + NBOCEL=NBOCEL*MAX(NOCELL(IDIR),1) + ENDDO + ELSE + NBOCEL=MAX(NOCELL(1),1) + NBOCEL=(NBOCEL*(NBOCEL+1))/2 + NBOCEL=NBOCEL*MAX(NOCELL(3),1) + ENDIF + NBUCEL=1 + MAXCEL=1 + DO IDIR =1,3 + IF(ABS(ISAXIS(IDIR)) .EQ. 1) THEN + NUCELL(IDIR)=2*NOCELL(IDIR)-1 + ELSE IF (ABS(ISAXIS(IDIR)) .EQ. 2) THEN + NUCELL(IDIR)=2*NOCELL(IDIR) + ELSE + NUCELL(IDIR)=NOCELL(IDIR) + ENDIF + NBUCEL=NBUCEL*MAX(NUCELL(IDIR),1) + MAXCEL=MAX(MAXCEL,NUCELL(IDIR)) + ENDDO + ELSE IF(ITYPBC .EQ. 1) THEN +* Annular or cylindrical + IDIR=MOD(IDIRG+1,3)+1 + NBOCEL=MAX(NOCELL(IDIR),1) + NBUCEL=NBOCEL + MAXCEL=1 + DO IDIR =1,3 + NUCELL(IDIR)=NOCELL(IDIR) + MAXCEL=MAX(MAXCEL,NUCELL(IDIR)) + ENDDO + ELSE IF(ITYPBC .EQ. 2) THEN +* Hexagons + NBOCEL=MAX(NOCELL(3),1)*MAX(NOCELL(1),1) + NBUCEL=NBOCEL + MAXCEL=1 + DO IDIR =1,3 + NUCELL(IDIR)=NOCELL(IDIR) + MAXCEL=MAX(MAXCEL,NUCELL(IDIR)) + ENDDO + ENDIF +*---- +* Create Array for testing symmetry and unfolding the +* geometry according to symmetries +*---- + IEDIMG(4)=NBOCEL + IEDIMG(5)=NBUCEL + IEDIMG(6)=IDIAG + IEDIMG(7)=ISAXIS(1) + IEDIMG(8)=ISAXIS(2) + IEDIMG(9)=ISAXIS(3) + ALLOCATE(IDFEX(11,NBOCEL),IDFRT(8,NBOCEL),ITSYM(4,NBOCEL), + > IUNFLD(2,NBUCEL)) + IF(ITYPBC .EQ. 0) THEN + CALL NXTCUA(IPRINT,NDIM ,IDIAG ,ISAXIS, + > NBOCEL,NBUCEL,NOCELL,NUCELL,ITSYM , + > IDFEX ,IDFRT ,IUNFLD) + ELSE IF(ITYPBC .EQ. 1) THEN + CALL XABORT(NAMSBR// + > ': Annular boundary not programmed yet') +* CALL NXTAUA(IPRINT,NDIM ,IDIAG ,ISAXIS, +* > NBOCEL,NBUCEL,NOCELL,NUCELL,ITSYM , +* > IDFEX ,IDFRT ,IUNFLD) + ELSE IF(ITYPBC .EQ. 2) THEN + CALL NXTHUA(IPRINT,NDIM ,IHSYM ,ISAXIS, + > NBOCEL,NBUCEL,NOCELL,NUCELL,ITSYM , + > IDFEX ,IDFRT ,IUNFLD) + ENDIF +*---- +* Save cell unfolding and internal symmetrization +* vectors +*---- + CALL LCMSIX(IPTRK,'NXTRecords ',1) + NAMREC='G00000001CUF' + CALL LCMPUT(IPTRK,NAMREC,2*NBUCEL,1,IUNFLD) + NAMREC='G00000001CIS' + CALL LCMPUT(IPTRK,NAMREC,4*NBOCEL,1,ITSYM) + NAMREC='G00000001CFE' + CALL LCMPUT(IPTRK,NAMREC,11*NBOCEL,1,IDFEX) + IEDIMG(10)=NOCELL(1) + IEDIMG(11)=NOCELL(2) + IEDIMG(12)=NOCELL(3) + IEDIMG(13)=NUCELL(1) + IEDIMG(14)=NUCELL(2) + IEDIMG(15)=NUCELL(3) + IEDIMG(16)=MAXCEL +*---- +* Get maximum dimensions and geometry limits +* Test if assembly can be built and save global mesh for geometry. +* Test if cluster pins are valid. +*---- + ALLOCATE(NAGGEO(3,NBOCEL),IDIRR(NBOCEL),ITURN(NBOCEL), + > MERGE(NBOCEL)) + ALLOCATE(DCMESH(3,2,NBOCEL)) + ALLOCATE(DGMESH((MAXCEL+1),3)) + CALL NXTGMD(IPGEO ,IPTRK ,IPRINT,ITYPBC,ILCELL,NSTATE, + > NBOCEL,NBUCEL,MAXCEL,NUCELL,IUNFLD,IEDIMG, + > NAGGEO,ITURN ,MERGE ,IDIRR ,DCMESH,DGMESH) + DEALLOCATE(DGMESH) +*---- +* Allocate memory to read global information +* for each geometry and subgeometry +*---- + MAXMSH=IEDIMG(16) + MAXREG=IEDIMG(17) + NBTCLS=IEDIMG(18) + MAXPIN=IEDIMG(19) + MAXMSP=MAX(IEDIMG(20),IEDIMG(16),1) +*---- +* Create multicell description of geometry +*---- + CALL NXTMCD(IPGEO ,IPTRK ,IPRINT,NDIM ,ILCELL,NBOCEL, + > MAXMSH,MAXREG,MAXPIN,NBTCLS,ITSYM ,IDFEX , + > DCMESH,NAGGEO,ITURN ,IDIRR , + > NFSUR ,NFREG ,MXGSUR,MXGREG) + IEDIMG(22)=NFSUR + IEDIMG(23)=NFREG + IEDIMG(24)=MXGSUR + IEDIMG(25)=MXGREG + CALL LCMPUT(IPTRK,'G00000001DIM',NSTATE,1,IEDIMG) +*---- +* Compute surfaces and volumes and define MATALB +*---- + ALLOCATE(KEYMRG(-NFSUR:NFREG),MATALB(-NFSUR:NFREG,2)) + ALLOCATE(SURVOL(-NFSUR:NFREG)) + CALL NXTCVS(IPTRK ,IPRINT,NDIM ,ITYPBC,NBOCEL,NFSUR , + > NFREG ,MXGSUR,MXGREG,MRGMIX,KEYMRG,MATALB,SURVOL) +*---- +* Create BC-REFL+TRAN vector +*---- + ALLOCATE(MATRT(NFSUR)) + CALL NXTBRT(IPTRK ,IPRINT,NDIM ,ITYPBC,ISAXIS,NBOCEL, + > MAXMSP,MAXPIN,NFSUR ,MXGSUR,MXGREG,IDFRT , + > MATRT ) + CALL LCMSIX(IPTRK,'NXTRecords ',2) +*---- +* Save global tracking information +* Including KEYMRG +*---- + ALLOCATE(MATCOD(NFREG,2),KEYFLX(NFREG),VOLUME(NFREG), + > MATRTN(NFSUR)) + CALL NXTAGM(IPRINT,NFSUR ,NFREG ,NEREG ,NESUR ,KEYMRG, + > MATALB,MATRT ,SURVOL,KEYFLX,MATCOD,MATRTN, + > VOLUME) + CALL LCMPUT(IPTRK,'BC-REFL+TRAN',NESUR,1,MATRTN) + CALL LCMPUT(IPTRK,'MATCOD ',NEREG,1,MATCOD(1,1)) + CALL LCMPUT(IPTRK,'HOMMATCOD ',NEREG,1,MATCOD(1,2)) + CALL LCMPUT(IPTRK,'VOLUME ',NEREG,2,VOLUME) + CALL LCMPUT(IPTRK,'KEYFLX ',NEREG,1,KEYFLX) + DEALLOCATE(MATRTN,VOLUME,KEYFLX,MATCOD) + DEALLOCATE(MATRT) + DEALLOCATE(SURVOL,MATALB,KEYMRG) + NBUNK=0 + DO IANIS=0,ISTATT(6)-1 + NBUNK=NBUNK+2*IANIS+1 + ENDDO + NBUNK=NEREG*NBUNK + ISTATT(1)=NEREG + ISTATT(2)=NBUNK + ISTATT(3)=ILEAK + ISTATT(4)=ISTATG(7) + ISTATT(5)=NESUR + CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,ISTATT) +*---- +* Release memory +*---- + DEALLOCATE(DCMESH,MERGE,ITURN,IDIRR,NAGGEO) + DEALLOCATE(IUNFLD,ITSYM,IDFRT,IDFEX) +*---- +* Processing finished: +* print routine closing header if required +* and return +*---- + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6011) NFREG,NEREG,NFSUR,NESUR + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(/' Analysis of geometry begins'/) + 6011 FORMAT(' Number of regions before merge =',I10/ + > ' Number of regions after merge =',I10/ + > ' Number of surfaces before merge=',I10/ + > ' Number of surfaces after merge =',I10// + > ' Analysis of geometry completed:'/ + > ) + END diff --git a/Dragon/src/NXTAGM.f b/Dragon/src/NXTAGM.f new file mode 100644 index 0000000..0afef9a --- /dev/null +++ b/Dragon/src/NXTAGM.f @@ -0,0 +1,157 @@ +*DECK NXTAGM + SUBROUTINE NXTAGM(IPRINT,NFSUR ,NFREG ,NEREG ,NESUR , + > KEYMRG,MATALB,MATRT ,SURVOL, + > KEYFLX,MATCOD,MATRTN,VOLUME) +* +*---------- +* +*Purpose: +* To apply general merge vector to geometry +* and to create the L_TRACK data structure MATCOD VOLUME +* and KEYFLX vectors. +* +*Copyright: +* Copyright (C) 2011 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau. +* +*Parameters: input +* IPRINT print level. +* NFSUR final number of surfaces. +* NFREG final number of regions. +* KEYMRG global merging vector. +* MATALB global mixture/albedo identification vector (including HMIX). +* MATRT global BC-REFL+TRAN. +* SURVOL global surface volume vector. +* +*Parameters: output +* NEREG final number of regions after MERGE. +* NESUR final number of surfaces after MERGE. +* KEYFLX final flux index vector after MERGE. +* MATCOD final mixture vector after MERGE (including HMIX). +* MATRTN final BC-REFL+TRAN. +* VOLUME final volume vector after MERGE. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,NFSUR,NFREG,NEREG,NESUR + INTEGER KEYMRG(-NFSUR:NFREG),MATALB(-NFSUR:NFREG,2), + > MATRT(NFSUR) + DOUBLE PRECISION SURVOL(-NFSUR:NFREG) + INTEGER KEYFLX(NFREG),MATCOD(NFREG,2), + > MATRTN(NFSUR) + REAL VOLUME(NFREG) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTAGM') +*---- +* Local variables +*---- + INTEGER IREG,JREG,IMIX,ITST,KSUR,LSUR + INTEGER MIMIX,MTST + DOUBLE PRECISION DVR +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,'(A16,2X,I10)') 'Surface Merge ',NFSUR + WRITE(IOUT,'(3I10,E20.10)') + > (JREG,KEYMRG(JREG),MATALB(JREG,1),SURVOL(JREG),JREG=-1,-NFSUR,-1) + WRITE(IOUT,'(A16,2X,I10)') 'Region Merge ',NFREG + WRITE(IOUT,'(3I10,E20.10)') + > (JREG,KEYMRG(JREG),MATALB(JREG,1),SURVOL(JREG),JREG=1,NFREG) + ENDIF +*---- +* Determine number of merge regions +*---- + DVR=0.0D0 + IMIX=0 + MIMIX=0 + KSUR=0 + NEREG=0 + DO JREG=1,NFREG + NEREG=MAX(NEREG,KEYMRG(JREG)) + ENDDO + NESUR=0 + DO JREG=-1,-NFSUR,-1 + NESUR=MIN(NESUR,KEYMRG(JREG)) + ENDDO + NESUR=-NESUR + DO IREG=1,NEREG + ITST=-1 + MTST=-1 + DO JREG=1,NFREG + IF(KEYMRG(JREG) .EQ. IREG) THEN + IF(ITST .EQ. -1) THEN + IMIX=MATALB(JREG,1) + DVR=SURVOL(JREG) + ITST=1 + ELSE + IF(IMIX .NE. MATALB(JREG,1) ) CALL XABORT(NAMSBR// + >': Merging region with different mixtures not permitted') + DVR=DVR+SURVOL(JREG) + ENDIF + IF(MTST .EQ. -1) THEN + MIMIX=MATALB(JREG,2) + MTST=1 + ELSE + IF(MIMIX .NE. MATALB(JREG,2) ) CALL XABORT(NAMSBR// + >': Merging region with different mixtures not permitted') + ENDIF + ENDIF + ENDDO + IF(ITST .EQ. -1) CALL XABORT(NAMSBR// + >': One merge region not defined') + VOLUME(IREG)=REAL(DVR) + KEYFLX(IREG)=IREG + MATCOD(IREG,1)=IMIX + MATCOD(IREG,2)=MIMIX + ENDDO +*---- +* Compress MATRT to MATRTN +*---- + MATRTN(:NFSUR)=0 + DO IREG=1,NFSUR + KSUR=-KEYMRG(-IREG) + LSUR=-KEYMRG(-MATRT(IREG)) + IF(MATRTN(KSUR) .EQ. 0) THEN + MATRTN(KSUR)=LSUR + ELSE + IF(MATRTN(KSUR) .NE. LSUR) CALL XABORT(NAMSBR// + >': Merging BC-REFL+TRAN with different surface coupling '// + >'not permitted') + ENDIF + ENDDO + DO IREG=1,NESUR + IF(MATRTN(KSUR) .EQ. 0) CALL XABORT(NAMSBR// + >': Some surfaces in BC-REFL+TRAN have no coupling ') + ENDDO +*---- +* Print output header if required +* and return +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + END diff --git a/Dragon/src/NXTAVS.f b/Dragon/src/NXTAVS.f new file mode 100644 index 0000000..f1fe135 --- /dev/null +++ b/Dragon/src/NXTAVS.f @@ -0,0 +1,165 @@ +*DECK NXTAVS + SUBROUTINE NXTAVS(IPRINT,NDIM ,ITYPBC,NFSUR ,NFREG ,NSUR , + > NREG ,MIX ,MIXH ,INDXSR,IDSUR ,IDREG , + > SVSGEO,DFACC ,MATALB,SURVOL) +* +*---------- +* +*Purpose: +* To add current cell information to global +* surfaces and volumes for geometry. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau. +* +*Parameters: input +* IPRINT print level. +* NDIM problem dimensions. +* ITYPBC type of boundary conditions where +* =0 for geometry with Cartesianb oundaries; +* =1 for geometry with annular boundary; +* =2 for geometry with hexagonal boundary. +* NFSUR final number of surfaces. +* NFREG final number of regions. +* NSUR maximum number of surfaces in splitted geometry. +* NREG maximum number of regions in splitted geometry. +* MIX geometry mixtures . +* MIXH homogenization mixtures. +* INDXSR local indexing of surfaces/regions. +* IDSUR local surface identifier . +* IDREG local region identifier. +* SVSGEO area/volume of regions. +* DFACC multiplication factor for surface and volume. +* +*Parameters: input/output +* MATALB global mixture/albedo identification vector (including HMIX). +* SURVOL global surface volume vector. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,NDIM,ITYPBC,NFSUR,NFREG,NSUR,NREG + INTEGER MIX(NREG),MIXH(NREG),INDXSR(5,-NSUR:NREG), + > IDREG(NREG),IDSUR(NSUR) + DOUBLE PRECISION SVSGEO(-NSUR:NREG),DFACC + INTEGER MATALB(-NFSUR:NFREG,2) + DOUBLE PRECISION SURVOL(-NFSUR:NFREG) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTAVS') +*---- +* Local variables +*---- + INTEGER NDSCAN,ISV,IDSV,IFSV,ID,IDSA + INTEGER IDALB(10) +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + NDSCAN=NDIM + IF(ITYPBC .EQ. 2) THEN + NDSCAN=5 + DO ISV=1,4 + IDALB(ISV)=-1 + ENDDO + DO ISV=5,6 + IDALB(ISV)=-ISV + ENDDO + IDALB(7)= 0 + IDALB(8)=-2 + IDALB(9)=-1 + IDALB(10)=-1 + ELSE + DO ISV=1,6 + IDALB(ISV)=-ISV + ENDDO + IDALB(7)=-1 + IDALB(8)=-2 + IDALB(9)=-1 + IDALB(10)=-1 + ENDIF +*---- +* Add surface contributions +*---- + DO ISV=1,NSUR + IDSV=IDSUR(ISV) + IF(IDSV .NE. 0) THEN + IFSV=-ABS(IDSV) + SURVOL(IFSV)=SURVOL(IFSV)+DFACC*SVSGEO(-ISV) + IF(IDSV .GT. 0) THEN + DO ID=1,NDSCAN + IF(INDXSR(ID,-ISV) .LT. 0) THEN + IDSA=2*(ID-1)-INDXSR(ID,-ISV) + MATALB(IFSV,1)=IDALB(IDSA) + MATALB(IFSV,2)=IDALB(IDSA) + GO TO 105 + ENDIF + ENDDO +*---- +* Albedo type not found +*---- + CALL XABORT(NAMSBR//': Albedo type not found') + 105 CONTINUE + ENDIF + ENDIF + ENDDO +*---- +* Add volume contribution +*---- + DO ISV=1,NREG + IDSV=IDREG(ISV) + IF(IDSV .NE. 0) THEN + IFSV=ABS(IDSV) + SURVOL(IFSV)=SURVOL(IFSV)+DFACC*SVSGEO(ISV) + IF(IDSV .GT. 0) THEN + MATALB(IFSV,1)=MIX(ISV) + MATALB(IFSV,2)=MIXH(ISV) + ENDIF + ENDIF + ENDDO +*---- +* Processing finished: +* print routine closing output header if required +* and return +*---- + IF(IPRINT .GE. 100) THEN + IF(IPRINT .GE. 500) THEN + WRITE(IOUT,*) 'MATALB' + WRITE(IOUT,'(10I10)') (MATALB(ISV,1),ISV=-NFSUR,NFREG) + WRITE(IOUT,*) 'HOMMATALB' + WRITE(IOUT,'(10I10)') (MATALB(ISV,2),ISV=-NFSUR,NFREG) + WRITE(IOUT,*) 'SURVOL' + WRITE(IOUT,'(1P,5E20.10)') (SURVOL(ISV),ISV=-NFSUR,NFREG) + ENDIF + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + END diff --git a/Dragon/src/NXTBCG.f b/Dragon/src/NXTBCG.f new file mode 100644 index 0000000..eab77e3 --- /dev/null +++ b/Dragon/src/NXTBCG.f @@ -0,0 +1,386 @@ +*DECK NXTBCG + SUBROUTINE NXTBCG(IPGEO ,IPTRK ,IPRINT,NDIM ,ITYPBC,IDIRG , + > IDIAG ,ISAXIS,IHSYM ,ILEAK ,IPRISM ) +* +*---------- +* +*Purpose: +* To read boundary conditions and symmetries and verify +* if information is consistent. Also prepare axis for +* symmetry identification. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau. +* +*Parameters: input +* IPGEO pointer to the GEOMETRY data structure. +* IPTRK pointer to the TRACKING data structure in +* update or creation mode. +* IPRINT print level. +* NDIM problem dimensions. +* ITYPBC type of boundary conditions where: +* =0 for geometry with Cartesian +* boundaries; +* =1 for geometry with annular +* boundary; +* =2 for geometry with hexagonal +* boundary; +* IDIRG geometry main direction: +* =1 for $X-Y-Z$ geometry; +* =2 for $Y-Z-X$ geometry; +* =3 for $Z-X-Y$ geometry. +* IPRISM projection axis for prismatic tracking. +* +*Parameters: output +* IDIAG the diagonal symmetry flag where: +* =-1 indicates X- DIAG symmetry; +* = 1 indicates X+ Y- DIAG symmetry; +* = 0 indicates no DIAG symmetry. +* ISAXIS symmetry vector for each direction. +* IHSYM hexagonal symmetry option where: +* = 0 geometry is not hexagonal; +* = 1 for S30; +* = 2 for SA60; +* = 3 for SB60; +* = 4 for S90; +* = 5 for R120; +* = 6 for R180; +* = 7 for SA180; +* = 8 for SB180; +* = 9 for COMPLETE; +* =10 for R60. +* ILEAK leakage option where: +* =1 indicates that there is no out of cell leakage; +* =0 indicates that there no out of cell leakage. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPGEO,IPTRK + INTEGER IPRINT,NDIM,ITYPBC,IDIRG + INTEGER IDIAG,ISAXIS(3),IHSYM,ILEAK,IPRISM +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTBCG') + INTEGER MAXDIM,NGBC + PARAMETER (MAXDIM=3,NGBC=6) +*---- +* Local variables +*---- + INTEGER IDIRP,IT3,ISUR,IDIR,ISCOMP + INTEGER ICODE(NGBC),NCODE(NGBC),JCODE(NGBC) + REAL ZCODE(NGBC) + INTEGER IVBC(NGBC),MRGSUR(NGBC) +*---- +* Data +*---- + CHARACTER CDIR(MAXDIM)*1 + SAVE CDIR + DATA CDIR /'X','Y','Z'/ +*---- +* Processing starts: +* print routine opening header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + IHSYM=0 +*---- +* Read boundary conditions from geometry +*---- + DO ISUR=1,NGBC + ICODE(ISUR)=-ISUR + ENDDO + CALL LCMGET(IPGEO ,'ICODE',JCODE) + CALL LCMGET(IPGEO ,'NCODE',NCODE) + IF (IPRISM.NE.0) THEN +* special case of a prismatic tracking: +* the geometry is not unfolded for the symmetries along the projection axis + CALL LCMPUT(IPTRK,'NCODE',6,1,NCODE) + DO IDIRG=1,2 + IF ((NCODE(2*(IPRISM-1)+IDIRG).EQ.5).OR. + 1 (NCODE(2*(IPRISM-1)+IDIRG).EQ.10)) THEN + NCODE(2*(IPRISM-1)+IDIRG)=2 + ENDIF + ENDDO + ENDIF + CALL LCMGET(IPGEO ,'ZCODE',ZCODE) +*---- +* Validate boundary conditions to process +*---- + IDIRP=MOD(IDIRG+1,3)+1 + IT3=NDIM/3 + IF(ITYPBC .EQ. 0) THEN + DO ISUR=1,4 + IVBC(ISUR)=1 + MRGSUR( ISUR)=ISUR + ENDDO + DO ISUR=5,NGBC + IVBC(ISUR)=IT3 + MRGSUR( ISUR)=ISUR + ENDDO + ELSE IF(ITYPBC .EQ. 1) THEN + DO ISUR=1,NGBC + IVBC(ISUR)=0 + ENDDO + IF(IDIRG .EQ. 1) THEN + IVBC(2)=1 + IF(NDIM .EQ. 3) THEN + IVBC(5)=1 + IVBC(6)=1 + ENDIF + ELSE IF(IDIRG .EQ. 2) THEN + IVBC(4)=1 + IF(NDIM .EQ. 3) THEN + IVBC(1)=1 + IVBC(2)=1 + ENDIF + ELSE IF(IDIRG .EQ. 3) THEN + IVBC(6)=1 + IF(NDIM .EQ. 3) THEN + IVBC(3)=1 + IVBC(4)=1 + ENDIF + ENDIF + ELSE IF(ITYPBC .EQ. 2) THEN + CALL LCMGET(IPGEO ,'IHEX',IHSYM) + IF(IHSYM .NE. 9) CALL XABORT(NAMSBR//': only COMPLETE '// + > ' hexagonal symmetry option programed in NXT:.') + DO ISUR=1,NGBC + IVBC(ISUR)=0 + ENDDO + IVBC(1)=1 + IF(NDIM .EQ. 3) THEN + IVBC(5)=1 + IVBC(6)=1 + ENDIF + ENDIF + DO ISUR=1,NGBC + MRGSUR(ISUR)=ISUR + ENDDO +*---- +* Find pairs of diagonal and translation B.C. +*---- + IDIAG=0 + ISCOMP=0 + DO ISUR=1,NGBC + IF(IVBC(ISUR) .EQ. 1) THEN + IF(JCODE(ISUR) .NE. 0 ) THEN + ICODE(ISUR)=JCODE(ISUR) + ZCODE(ISUR)= 1.0 + ELSE IF(NCODE(ISUR) .EQ. 0) THEN + CALL XABORT(NAMSBR// + > ': A boundary condition is missing.') + ENDIF + IF(NCODE(ISUR) .EQ. 2) THEN + ZCODE(ISUR)= 1.0 + ELSE IF(NCODE(ISUR) .EQ. 3) THEN + IDIAG=IDIAG+1 + ELSE IF(NCODE(ISUR) .EQ. 4)THEN + ISCOMP=ISCOMP+1 + ZCODE(ISUR)=1.0 + ELSE IF(NCODE(ISUR) .EQ. 6 ) THEN + NCODE(ISUR)= 1 + ELSE IF(NCODE(ISUR) .EQ. 7 .OR. + > NCODE(ISUR) .EQ. 8 .OR. + > NCODE(ISUR) .EQ. 9 .OR. + > NCODE(ISUR) .GE. 11 ) THEN + CALL XABORT(NAMSBR// + > ': An invalid boundary condition detected.') + ENDIF + ENDIF + ENDDO +*---- +* Analyse DIAG boundary conditions +* Only X+ DIAG Y- DIAG or X- DIAG Y+ DIAG permitted +*---- + IF(IDIAG .GT. 0) THEN + IF(ITYPBC .NE. 0) CALL XABORT(NAMSBR// + > ': DIAG BC permitted only for Cartesian geometries') + IF(IDIAG .NE. 2) CALL XABORT(NAMSBR// + > ': Only one pair of DIAG boundary conditions permitted') + IF((NCODE(2) .EQ. 3) .AND. (NCODE(3) .EQ. 3)) THEN + MRGSUR(2)= 4 + MRGSUR(3)= 1 + NCODE(2)= NCODE(4) + NCODE(3)= NCODE(1) + ICODE(2)= ICODE(4) + ICODE(3)= ICODE(1) + ZCODE(2)= ZCODE(4) + ZCODE(3)= ZCODE(1) + IDIAG=1 + ELSE IF((NCODE(1) .EQ. 3) .AND. (NCODE(4) .EQ. 3)) THEN + MRGSUR(1)= 3 + MRGSUR(4)= 2 + NCODE(1)= NCODE(3) + NCODE(4)= NCODE(2) + ICODE(1)= ICODE(3) + ICODE(4)= ICODE(2) + ZCODE(1)= ZCODE(3) + ZCODE(4)= ZCODE(2) + IDIAG=-1 + ELSE + CALL XABORT(NAMSBR// + > ': Only (X+ DIAG Y- DIAG) or (X- DIAG Y+ DIAG) permitted') + ENDIF + ENDIF +*---- +* Analyse TRAN boundary conditions +* Only X- TRAN X+ TRAN, Y- TRAN Y+ TRAN and +* Z- TRAN Z+ TRAN permitted +*---- + DO IDIR=1,MAXDIM + ISAXIS(IDIR)=0 + ENDDO + IF(ISCOMP .GT. 0) THEN + IF(ITYPBC .NE. 0) CALL XABORT(NAMSBR// + > ': TRAN BC permitted only for Cartesian geometries') + IF(MOD(ISCOMP,2) .EQ. 1) CALL XABORT(NAMSBR// + > ': TRAN boundary conditions must come in pairs') + DO IDIR=1,MAXDIM + ISUR=2*IDIR + IF(IVBC(ISUR) .EQ. 1) THEN + IF(NCODE(ISUR) .EQ. 4 .AND. NCODE(ISUR-1) .EQ. 4) THEN + MRGSUR(ISUR )=ISUR-1 + MRGSUR(ISUR-1)=ISUR + ISCOMP=ISCOMP-2 + ISAXIS(IDIR)=3 + ENDIF + ENDIF + ENDDO + IF(ISCOMP .NE. 0) CALL XABORT(NAMSBR// + > ': Illegal pairing of TRAN boundary conditions') + ENDIF +*---- +* Analyse SYME and SSYM boundary conditions +*---- + DO ISUR=1,NGBC + IF(IVBC(ISUR) .EQ. 1) THEN + IDIR=(ISUR+1)/2 + IF(NCODE(ISUR) .EQ. 5)THEN + IF(MOD(ISUR,2) .EQ. 0) THEN + ISCOMP=ISUR-1 + ISAXIS(IDIR)=1 + ELSE + ISCOMP=ISUR+1 + ISAXIS(IDIR)=-1 + ENDIF + IF(NCODE(ISCOMP) .NE. 1 .AND. NCODE(ISCOMP) .NE. 2 .AND. + > NCODE(ISCOMP) .NE. 6) CALL XABORT(NAMSBR// + > ': Invalid combination for SYME or SSYM symmetry') + MRGSUR(ISUR)=ISCOMP + ZCODE(ISUR)=ZCODE(ISCOMP) + ICODE(ISUR)=ICODE(ISCOMP) + NCODE(ISUR)=NCODE(ISCOMP) + ELSE IF(NCODE(ISUR) .EQ. 10)THEN + IF(MOD(ISUR,2) .EQ. 0) THEN + ISCOMP=ISUR-1 + ISAXIS(IDIR)=2 + ELSE + ISCOMP=ISUR+1 + ISAXIS(IDIR)=-2 + ENDIF + IF(NCODE(ISCOMP) .NE. 1 .AND. NCODE(ISCOMP) .NE. 2 .AND. + > NCODE(ISCOMP) .NE. 6) CALL XABORT(NAMSBR// + > ': Invalid combination for SYME or SSYM symmetry') + MRGSUR(ISUR)=ISCOMP + ZCODE(ISUR)=ZCODE(ISCOMP) + ICODE(ISUR)=ICODE(ISCOMP) + NCODE(ISUR)=NCODE(ISCOMP) + ENDIF + ENDIF + ENDDO + ILEAK=1 + DO ISUR=1,NGBC + IF(IVBC(ISUR) .EQ. 1) THEN + IF(ICODE(ISUR) .GT. 0) THEN + ILEAK=0 + ELSE IF(ZCODE(ISUR) .NE. 1.0) THEN + ILEAK=0 + ENDIF + ENDIF + ENDDO +*---- +* For combined DIAG/SYME symmetry +* complete set of symmetry available +* X/Y SYME -> Y/X SYME +*---- +* IF(IDIAG .EQ. -1) THEN +* IF(ISAXIS(2) .EQ. -1) THEN +* ISAXIS(1)=1 +* ELSE IF(ISAXIS(1) .EQ. 1) THEN +* ISAXIS(2)=-1 +* ENDIF +* ELSE IF(IDIAG .EQ. 1) THEN +* IF(ISAXIS(2) .EQ. 1) THEN +* ISAXIS(1)=-1 +* ELSE IF(ISAXIS(1) .EQ. -1) THEN +* ISAXIS(2)=1 +* ENDIF +* ENDIF +*---- +* Save boundary conditions on tracking +*---- + CALL LCMPUT(IPTRK ,'ALBEDO ',NGBC,2,ZCODE) + CALL LCMPUT(IPTRK ,'ICODE ',NGBC,1,ICODE) +*---- +* Processing finished: +* print routine closing header if required +* and return +*---- + IF(IPRINT .GE. 10) THEN + IF(IDIAG .EQ. 1) THEN + WRITE(IOUT,6010) '(X+, Y-)' + ELSE IF(IDIAG .EQ. -1) THEN + WRITE(IOUT,6010) '(X+, Y-)' + ENDIF + DO ISUR=1,3 + IF(ISAXIS(ISUR) .EQ. -2) THEN + WRITE(IOUT,6011) 'SSYM',CDIR(ISUR),'-' + ELSE IF(ISAXIS(ISUR) .EQ. -1) THEN + WRITE(IOUT,6011) 'SYME',CDIR(ISUR),'-' + ELSE IF(ISAXIS(ISUR) .EQ. 1) THEN + WRITE(IOUT,6011) 'SYME',CDIR(ISUR),'+' + ELSE IF(ISAXIS(ISUR) .EQ. 2) THEN + WRITE(IOUT,6011) 'SSYM',CDIR(ISUR),'+' + ELSE IF(ISAXIS(ISUR) .EQ. 3) THEN + WRITE(IOUT,6011) 'TRAN',CDIR(ISUR),' ' + ENDIF + ENDDO + DO ISUR=1,NGBC + WRITE(IOUT,6012) ISUR,ICODE(ISUR),NCODE(ISUR),IVBC(ISUR), + > MRGSUR(ISUR),ZCODE(ISUR) + ENDDO + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT('Diagonal symmetry : ',A8) + 6011 FORMAT('Symmetry : ',A4,1X,'on surface ',2A1) + 6012 FORMAT('BC[[',I10,']]={',4(I5,','),F20.10,'}') + END diff --git a/Dragon/src/NXTBRT.f b/Dragon/src/NXTBRT.f new file mode 100644 index 0000000..49627a2 --- /dev/null +++ b/Dragon/src/NXTBRT.f @@ -0,0 +1,369 @@ +*DECK NXTBRT + SUBROUTINE NXTBRT(IPTRK ,IPRINT,NDIM ,ITYPBC,ISAXIS,NBOCEL, + > MAXMSP,MAXPIN,NFSUR ,MXGSUR,MXGREG,IDFRT , + > MATRT) +* +*---------- +* +*Purpose: +* To built the surface reflection/transmission coupling +* array. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau. +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure. +* IPRINT print level. +* NDIM problem dimensions. +* ITYPBC type of boundary conditions where: +* =0 for geometry with Cartesian boundaries; +* =1 for geometry with annular boundary; +* =2 for geometry with hexagonal boundary. +* ISAXIS symmetry vector for each direction. +* NBOCEL number of cells in original geometry. +* MAXMSP maximum number of elements in MESH array. +* MAXPIN maximum number of pins in clusters. +* IDFRT identify reflection/transmission faces. +* NFSUR final number of surfaces. +* MXGSUR maximum number of surfaces for any geometry. +* MXGREG maximum number of region for any geometry. +* +*Parameters: output +* MATRT reflection/transmission surface coupling array. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPTRK + INTEGER IPRINT,NDIM,ITYPBC,ISAXIS(3),NBOCEL, + > MAXMSP,MAXPIN,IDFRT(8,NBOCEL), + > NFSUR,MXGSUR,MXGREG + INTEGER MATRT(NFSUR) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTBRT') + INTEGER NSTATE + PARAMETER (NSTATE=40) +*---- +* Local variables +*---- + INTEGER ISV,IDT,IDIR,ICEL,IGEN(2),ILEV,IG,NBSD,NBST, + > NR1,NS1,NUNK1,IG1,ICL1,IPIN1,IFPIN1,ILPIN1, + > NR2,NS2,NUNK2,IG2,ICL2,IPIN2,IFPIN2,ILPIN2, + > MXRUNK,IDO + INTEGER IEDIMC(NSTATE,2),IEDIMP(NSTATE,2) + CHARACTER NAMREC*12 + INTEGER ILCMLN,ILCMTY +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ID1,ID2 + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IX1,IX2 + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SV1,SV2 + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: DAMESH,DRAPIN +*---- +* Data +*---- + CHARACTER CDIR(1:4)*1,CLEV(2)*1 + SAVE CDIR,CLEV + DATA CDIR /'X','Y','Z','R'/ + DATA CLEV /'C','P'/ +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + MXRUNK=MXGSUR+MXGREG+1 +*---- +* Scratch storage allocation +* DRAPIN temporary vector for storing global pin positions. +* DAMESH temporary vector for storing global mesh array. +*---- + ALLOCATE(ID1(MXGSUR),ID2(MXGSUR)) + ALLOCATE(IX1(5,MXRUNK),IX2(5,MXRUNK)) + ALLOCATE(SV1(MXRUNK),SV2(MXRUNK)) + ALLOCATE(DAMESH(-1:MAXMSP,4,2),DRAPIN(-1:4,MAXPIN,2)) +*---- +* Initialize MATRT assuming all surfaces are reflective +*---- + DO ISV=1,NFSUR + MATRT(ISV)=ISV + ENDDO +*---- +* X, Y, and Z translation +* Scan over cells and locate those with X- surface boundary +* Find X+ cell from which neutrons are generated +*---- + DO IDT=1,3 + IDO=2*IDT-1 + IF(ISAXIS(IDT) .EQ. 3) THEN + DO ICEL=1,NBOCEL + IGEN(1)=ICEL + ILEV=1 + IGEN(2)=IDFRT(IDO,ICEL) + IF(IGEN(2) .GT. 0) THEN +*---- +* Cells are identified: +* Extract dimensioning vectors. +*---- + IEDIMC(:NSTATE,:2)=0 + DO IG=1,2 + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEN(IG),'DIM' + CALL LCMGET(IPTRK,NAMREC,IEDIMC(1,IG)) +*---- +* Read meshes +*---- + IF(ITYPBC .EQ. 2) THEN +*---- +* Hexagons +*---- + IDIR=1 + WRITE(NAMREC,'(A1,I8.8,A3)') + > CLEV(ILEV),IGEN(IG),'SM'//CDIR(IDIR) + CALL LCMLEN(IPTRK,NAMREC,ILCMLN,ILCMTY) + IF(ILCMLN .GT. 0) + > CALL LCMGET(IPTRK,NAMREC,DAMESH(-1,IDIR,IG)) + IDIR=3 + WRITE(NAMREC,'(A1,I8.8,A3)') + > CLEV(ILEV),IGEN(IG),'SM'//CDIR(IDIR) + CALL LCMLEN(IPTRK,NAMREC,ILCMLN,ILCMTY) + IF(ILCMLN .GT. 0) THEN + CALL LCMGET(IPTRK,NAMREC,DAMESH(-1,IDIR,IG)) + ELSE + DAMESH(-1:MAXMSP,IDIR,IG)=0.0D0 + ENDIF + ELSE +*---- +* Cartesian, annluar or spherical +*---- + DO IDIR=1,4 + WRITE(NAMREC,'(A1,I8.8,A3)') + > CLEV(ILEV),IGEN(IG),'SM'//CDIR(IDIR) + CALL LCMLEN(IPTRK,NAMREC,ILCMLN,ILCMTY) + IF(ILCMLN .GT. 0) THEN + CALL LCMGET(IPTRK,NAMREC,DAMESH(-1,IDIR,IG)) + ELSE + DAMESH(-1:MAXMSP,IDIR,IG)=0.0D0 + ENDIF + ENDDO + ENDIF + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEN(IG),'PIN' + CALL LCMLEN(IPTRK,NAMREC,ILCMLN,ILCMTY) + IF(ILCMLN .GT. 0) THEN + CALL LCMGET(IPTRK,NAMREC,DRAPIN(-1,1,IG)) + ELSE + DRAPIN(-1:4,1,IG)=0.0D0 + ENDIF + ENDDO +*---- +* Find maximum surfaces and regions and retreive +* MESH, DRAPIN, INDXSR, IDSUR and SURVOL +*---- + NR1=IEDIMC(8,1) + NS1=IEDIMC(9,1) + NUNK1=NR1+NS1+1 + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEN(1),'VSE' + CALL LCMGET(IPTRK,NAMREC,SV1) + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEN(1),'VSI' + CALL LCMGET(IPTRK,NAMREC,IX1) + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEN(1),'SID' + CALL LCMGET(IPTRK,NAMREC,ID1) + NR2=IEDIMC(8,1) + NS2=IEDIMC(9,1) + NUNK2=NR2+NS2+1 + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEN(2),'VSE' + CALL LCMGET(IPTRK,NAMREC,SV2) + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEN(2),'VSI' + CALL LCMGET(IPTRK,NAMREC,IX2) + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEN(2),'SID' + CALL LCMGET(IPTRK,NAMREC,ID2) +*---- +* Find equivalent translated surface +*---- + IF(ITYPBC .EQ. 2) THEN + CALL NXTETH(IPRINT,IDT ,ILEV ,NFSUR ,MAXMSP, + > NS1 ,NR1 ,NS2 ,NR2 ,IEDIMC,DAMESH, + > IX1,ID1,SV1,IX2,ID2 ,SV2, + > MATRT ,NBSD ,NBST ) + ELSE + CALL NXTETS(IPRINT,IDT ,ILEV ,NFSUR ,MAXMSP, + > NS1 ,NR1 ,NS2 ,NR2 ,IEDIMC,DAMESH, + > IX1,ID1,SV1,IX2,ID2 ,SV2, + > MATRT ,NBSD ,NBST ) + ENDIF +*---- +* For EACH pin in first geometry, find if a pin at an equivalent position +* in second geometry can be found. +*---- +*---- +* Start correction 2010/11/10 +* Pin analysis not required in 3 dimensions + IF(NDIM .EQ. 3) THEN +* Start correction 2010/11/10 +*---- + ILEV=2 + IEDIMP(:NSTATE,:2)=0 + IG1=1 + IG2=2 + IGEN(IG1)=IEDIMC(17,IG1)-1 + DO ICL1=1,IEDIMC(16,IG1) + IGEN(IG1)=IGEN(IG1)+1 + IG=IG1 + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEN(IG),'DIM' + CALL LCMGET(IPTRK,NAMREC,IEDIMP(1,IG)) + IFPIN1=IEDIMP(16,IG) + ILPIN1=IFPIN1+IEDIMP(17,IG)-1 + DO IDIR=1,4 + WRITE(NAMREC,'(A1,I8.8,A3)') + > CLEV(ILEV),IGEN(IG),'SM'//CDIR(IDIR) + CALL LCMLEN(IPTRK,NAMREC,ILCMLN,ILCMTY) + IF(ILCMLN .GT. 0) THEN + CALL LCMGET(IPTRK,NAMREC,DAMESH(-1,IDIR,IG)) + ELSE + DAMESH(-1:MAXMSP,IDIR,IG)=0.0D0 + ENDIF + ENDDO + NR1=IEDIMP(8,1) + NS1=IEDIMP(9,1) + NUNK1=NR1+NS1+1 + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEN(1),'VSE' + CALL LCMGET(IPTRK,NAMREC,SV1) + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEN(1),'VSI' + CALL LCMGET(IPTRK,NAMREC,IX1) + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEN(1),'SID' + CALL LCMGET(IPTRK,NAMREC,ID1) + IGEN(IG2)=IEDIMC(17,IG2)-1 + DO ICL2=1,IEDIMC(16,IG2) + IGEN(IG2)=IGEN(IG2)+1 + IG=IG2 + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEN(IG),'DIM' + CALL LCMGET(IPTRK,NAMREC,IEDIMP(1,IG)) + IFPIN2=IEDIMP(16,IG) + ILPIN2=IFPIN2+IEDIMP(17,IG)-1 + DO IDIR=1,4 + WRITE(NAMREC,'(A1,I8.8,A3)') + > CLEV(ILEV),IGEN(IG),'SM'//CDIR(IDIR) + CALL LCMLEN(IPTRK,NAMREC,ILCMLN,ILCMTY) + IF(ILCMLN .GT. 0) THEN + CALL LCMGET(IPTRK,NAMREC,DAMESH(-1,IDIR,IG)) + ELSE + DAMESH(-1:MAXMSP,IDIR,IG)=0.0D0 + ENDIF + ENDDO + NR2=IEDIMP(8,IG2) + NS2=IEDIMP(9,IG2) + NUNK2=NR2+NS2+1 + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEN(2),'VSE' + CALL LCMGET(IPTRK,NAMREC,SV2) + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEN(2),'VSI' + CALL LCMGET(IPTRK,NAMREC,IX2) + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEN(2),'SID' + CALL LCMGET(IPTRK,NAMREC,ID2) +*---- +* Find equivalent translated surface +*---- + CALL NXTETS(IPRINT,IDT ,ILEV ,NFSUR ,MAXMSP, + > NS1 ,NR1 ,NS2 ,NR2 ,IEDIMP,DAMESH, + > IX1,ID1,SV1,IX2,ID2 ,SV2, + > MATRT ,NBSD ,NBST ) +*---- +* No IDT directed face for direct cluster +* go to next direct cluster +*---- + IF(NBSD .EQ. 0) GO TO 105 + IF(NBSD .EQ. NBST) THEN +*---- +* Test if pin position locations are adequate +*---- + DO IPIN1=IFPIN1,ILPIN1 + DO IPIN2=IFPIN2,ILPIN2 + IF(DRAPIN(-1,IPIN1,1) .EQ. DRAPIN(-1,IPIN2,2) + > .AND. DRAPIN( 0,IPIN1,1) .EQ. DRAPIN( 0,IPIN2,2) + > .AND. DRAPIN( 4,IPIN1,1) .EQ. DRAPIN( 4,IPIN2,2) + > ) THEN +*---- +* Pin positions are identical, select next pin +*---- + GO TO 125 + ENDIF + ENDDO +*---- +* Pin positions are not compatible +* go to next translated cluster +*---- + GO TO 115 + 125 CONTINUE + ENDDO +*---- +* Translation surfaces found here go to next direct cluster +*---- + GO TO 105 + ENDIF + 115 CONTINUE + ENDDO +*---- +* Translated surfaces for directed pin not found +* send warning signal and continue +*---- + WRITE(IOUT,9000) ICEL,ICL1 + 105 CONTINUE + ENDDO +*---- +* Start correction 2010/11/10 +* Pin analysis not required in 3 dimensions + ENDIF +* End correction 2010/11/10 +*---- + ENDIF + ENDDO + ENDIF + ENDDO +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(DRAPIN,DAMESH) + DEALLOCATE(SV2,SV1) + DEALLOCATE(IX2,IX1) + DEALLOCATE(ID2,ID1) +*---- +* Processing finished: +* print routine closing output header if required +* and return +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 9000 FORMAT(' ***** Warning ***** '/ + > ' Translated surface for CELL ',I5,1X, + > ' and PIN :',I5,' is absent') + END diff --git a/Dragon/src/NXTCUA.f b/Dragon/src/NXTCUA.f new file mode 100644 index 0000000..8d62236 --- /dev/null +++ b/Dragon/src/NXTCUA.f @@ -0,0 +1,875 @@ +*DECK NXTCUA + SUBROUTINE NXTCUA(IPRINT,NDIM ,IDIAG ,ISAXIS, + > NBOCEL,NBUCEL,NOCELL,NUCELL, + > ITSYM ,IDFEX ,IDFRT ,IUNFLD) +* +*---------- +* +*Purpose: +* To create the array for testing the geometry in +* a Cartesian assembly for internal symmetries and unfolding +* the assembly according to the symmetries. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau. +* +*Parameters: input +* IPRINT print level. +* NDIM problem dimensions. +* IDIAG the diagonal symmetry flag where: +* =-1 indicates X- Y+ DIAG symmetry; +* = 1 indicates X+ Y- DIAG symmetry; +* = 0 indicates no DIAG symmetry. +* ISAXIS symmetry vector for each direction. +* NBOCEL number of cells in original geometry. +* NBUCEL number of cells in unfolded geometry. +* NOCELL number of cell before unfolding in +* $X$, $Y$ and $Z$ directions. +* NUCELL number of cell after unfolding in +* $X$, $Y$ and $Z$ directions. +* +*Parameters: output +* ITSYM array to identify the symmetry to test for each original +* cell where: +* ITSYM(1,*) identify $X$ symmetry; +* ITSYM(2,*) identify $Y$ symmetry; +* ITSYM(3,*) identify $Z$ symmetry; +* ITSYM(4,*) identify $X-Y$ symmetry. +* A value of 0 indicate that the geometry does not need +* to be verified while a value of 1 implies a verification +* of the geometry. +* IDFEX identify faces associated with external boundary for a +* generating cell and number of times this cell is used. Here: +* IDFEX( 1,*) identify bottom $X$ hexagonal face; +* IDFEX( 2,*) identify top $X$ hexagonal face; +* IDFEX( 3,*) identify bottom $Y$ hexagonal face; +* IDFEX( 4,*) identify top $Y$ hexagonal face; +* IDFEX( 5,*) identify bottom $Z$ face; +* IDFEX( 6,*) identify top $Z$ face; +* IDFEX( 7,*) not used; +* IDFEX( 8,*) not used; +* IDFEX( 9,*) not used; +* IDFEX(10,*) not used. +* IDFRT identify reflection/transmission faces. +* IUNFLD array to identify the generating cell (IUNFLD(1,*)) +* and the rotation associated with this region in space. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,NDIM,IDIAG,ISAXIS(3) + INTEGER NBUCEL,NOCELL(3),NUCELL(3) + INTEGER NBOCEL,ITSYM(4,NBOCEL),IDFEX(0:10,NBOCEL), + > IDFRT(8,NBOCEL),IUNFLD(2,NBUCEL) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTCUA') +*---- +* Functions +*---- + INTEGER NXTTRS +*---- +* Local variables +*---- + INTEGER IDIR,NSCELL(3),NFCELL(3), + > NSUC(3), + > IGEN,IGENT,IX,IY,IZ,ILOCD, + > ILOCR,IOFYZ,IOFYZR,IOFZ,IOFZR +*---- +* Data +*---- + CHARACTER*2 CTRN(24) + SAVE CTRN + DATA CTRN + > /'+A','+B','+C','+D','+E','+F','+G','+H','+I','+J','+K','+L', + > '-A','-B','-C','-D','-E','-F','-G','-H','-I','-J','-K','-L'/ +*---- +* Processing starts: +* print routine opening header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + IDFEX(0:10,:NBOCEL)=0 + IDFRT(:8,:NBOCEL)=0 + ITSYM(:4,:NBOCEL)=0 +*---- +* Prepare direction control vector for +* original assembly +*---- + DO IDIR=1,3 + NSCELL(IDIR)=MAX(1,NOCELL(IDIR)) + NSUC(IDIR)=MAX(1,NUCELL(IDIR)) + IF(ISAXIS(IDIR) .EQ. -2) THEN + NFCELL(IDIR)=NOCELL(IDIR) + ELSE IF(ISAXIS(IDIR) .EQ. -1) THEN + NFCELL(IDIR)=NOCELL(IDIR)-1 + ELSE + NFCELL(IDIR)=0 + ENDIF +* WRITE(6,*) 'NSCELL =',IDIR,NSCELL(IDIR),NFCELL(IDIR) + ENDDO +*---- +* Position original cell and process diagonal +* symmetry +*---- + IGEN=0 + IF(IDIAG .EQ. -1) THEN +*---- +* Process X- Y+ diagonal symmetry +*---- + DO IZ=0,NSCELL(3)-1 + IOFZ=(IZ+NFCELL(3))*NUCELL(2) + DO IY=0,NSCELL(2)-1 + IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1) + IX=IY + IGEN=IGEN+1 + IF(IGEN .GT. NBOCEL) CALL XABORT(NAMSBR// + > ': Cell number exceeds number of cells permitted') + ILOCD=IOFYZ+IX+NFCELL(1)+1 + IUNFLD(1,ILOCD)=IGEN + IUNFLD(2,ILOCD)=1 + ITSYM(4,IGEN)=IDIAG + DO IX=IY+1,NSCELL(1)-1 + IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1) + IOFYZR=(IX+NFCELL(2)+IOFZ)*NUCELL(1) + IGEN=IGEN+1 + IF(IGEN .GT. NBOCEL) CALL XABORT(NAMSBR// + > ': Cell number exceeds number of cells permitted') + ILOCD=IOFYZ+IX+NFCELL(1)+1 + ILOCR=IOFYZR+IY+NFCELL(1)+1 + IUNFLD(1,ILOCD)=IGEN + IUNFLD(2,ILOCD)=1 + IUNFLD(1,ILOCR)=IGEN + IUNFLD(2,ILOCR)=NXTTRS(1,2) + ENDDO + ENDDO + ENDDO +*---- +* Identify cells to tests for X +* reflection symmetry +*---- + IF(ISAXIS(1) .EQ. 1) THEN + IX=NSCELL(1)-1 + DO IZ=0,NSCELL(3)-1 + IOFZ=(IZ+NFCELL(3))*NUCELL(2) + DO IY=0,NSCELL(2)-1 + IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1) + ILOCD=IOFYZ+IX+NFCELL(1)+1 + IGEN=IUNFLD(1,ILOCD) + ITSYM(1,IGEN)=ISAXIS(1) + ENDDO + ENDDO + ENDIF +*---- +* Identify cells to tests for Y +* reflection symmetry +*---- + IF(ISAXIS(2) .EQ. -1) THEN + IY=0 + DO IZ=0,NSCELL(3)-1 + IOFZ=(IZ+NFCELL(3))*NUCELL(2) + IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1) + DO IX=0,NSCELL(1)-1 + ILOCD=IOFYZ+IX+NFCELL(1)+1 + IGEN=IUNFLD(1,ILOCD) + ITSYM(2,IGEN)=ISAXIS(2) + ENDDO + ENDDO + ENDIF +*---- +* Identify cells to tests for Z +* reflection symmetry +*---- + IF(ABS(ISAXIS(3)) .EQ. 1) THEN + IF(ISAXIS(3) .EQ. -1) THEN + IZ=0 + ELSE IF(ISAXIS(3) .EQ. 1) THEN + IZ=NSCELL(3)-1 + ENDIF + IOFZ=(IZ+NFCELL(3))*NUCELL(2) + DO IY=0,NSCELL(2)-1 + IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1) + DO IX=IY,NSCELL(1)-1 + IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1) + ILOCD=IOFYZ+IX+NFCELL(1)+1 + IGEN=IUNFLD(1,ILOCD) + ITSYM(3,IGEN)=ISAXIS(3) + ENDDO + ENDDO + ENDIF + ELSE IF(IDIAG .EQ. 1) THEN +*---- +* Process X+ Y- diagonal symmetry +*---- + DO IZ=0,NSCELL(3)-1 + IOFZ=(IZ+NFCELL(3))*NUCELL(2) + DO IY=0,NSCELL(2)-1 + IGENT=IGEN+IY+2 + IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1) + IX=IY + IGEN=IGEN+1 + IF(IGEN .GT. NBOCEL) CALL XABORT(NAMSBR// + > ': Cell number exceeds number of cells permitted') + IGENT=IGENT-1 + ILOCD=IOFYZ+IX+NFCELL(1)+1 + IUNFLD(1,ILOCD)=IGENT + IUNFLD(2,ILOCD)=1 + ITSYM(4,IGENT)=IDIAG + DO IX=IY-1,0,-1 + IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1) + IOFYZR=(IX+NFCELL(2)+IOFZ)*NUCELL(1) + IGEN=IGEN+1 + IF(IGEN .GT. NBOCEL) CALL XABORT(NAMSBR// + > ': Cell number exceeds number of cells permitted') + IGENT=IGENT-1 + ILOCD=IOFYZ+IX+NFCELL(1)+1 + ILOCR=IOFYZR+IY+NFCELL(1)+1 + IUNFLD(1,ILOCD)=IGENT + IUNFLD(2,ILOCD)=1 + IUNFLD(1,ILOCR)=IGENT + IUNFLD(2,ILOCR)=NXTTRS(1,2) + ENDDO + ENDDO + ENDDO +*---- +* Identify cells to tests for X +* reflection symmetry +*---- + IF(ISAXIS(1) .EQ. -1) THEN + IX=0 + DO IZ=0,NSCELL(3)-1 + IOFZ=(IZ+NFCELL(3))*NUCELL(2) + DO IY=0,NSCELL(2)-1 + IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1) + ILOCD=IOFYZ+IX+NFCELL(1)+1 + IGEN=IUNFLD(1,ILOCD) + ITSYM(1,IGEN)=ISAXIS(1) + ENDDO + ENDDO + ENDIF +*---- +* Identify cells to tests for Y +* reflection symmetry +*---- + IF(ISAXIS(2) .EQ. 1) THEN + IY=NSCELL(2)-1 + DO IZ=0,NSCELL(3)-1 + IOFZ=(IZ+NFCELL(3))*NUCELL(2) + IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1) + DO IX=IY,0,-1 + IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1) + ILOCD=IOFYZ+IX+NFCELL(1)+1 + IGEN=IUNFLD(1,ILOCD) + ITSYM(2,IGEN)=ISAXIS(2) + ENDDO + ENDDO + ENDIF +*---- +* Identify cells to tests for Z +* reflection symmetry +*---- + IF(ABS(ISAXIS(3)) .EQ. 1) THEN + IF(ISAXIS(3) .EQ. -1) THEN + IZ=0 + ELSE IF(ISAXIS(3) .EQ. 1) THEN + IZ=NSCELL(3)-1 + ENDIF + IOFZ=(IZ+NFCELL(3))*NUCELL(2) + DO IY=0,NSCELL(2)-1 + IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1) + DO IX=IY,0,-1 + IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1) + ILOCD=IOFYZ+IX+NFCELL(1)+1 + IGEN=IUNFLD(1,ILOCD) + ITSYM(3,IGEN)=ISAXIS(3) + ENDDO + ENDDO + ENDIF + ELSE + DO IZ=0,NSCELL(3)-1 + IOFZ=(IZ+NFCELL(3))*NUCELL(2) + DO IY=0,NSCELL(2)-1 + IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1) + DO IX=0,NSCELL(1)-1 + IGEN=IGEN+1 + IF(IGEN .GT. NBOCEL) CALL XABORT(NAMSBR// + > ': Cell number exceeds number of cells permitted') + ILOCD=IOFYZ+IX+NFCELL(1)+1 + IUNFLD(1,ILOCD)=IGEN + IUNFLD(2,ILOCD)=1 + ENDDO + ENDDO + ENDDO +*---- +* Identify cells to tests for X +* reflection symmetry +*---- + IF(ABS(ISAXIS(1)) .EQ. 1) THEN + IF(ISAXIS(1) .EQ. -1) THEN + IX=0 + ELSE IF(ISAXIS(1) .EQ. 1) THEN + IX=NSCELL(1)-1 + ENDIF + DO IZ=0,NSCELL(3)-1 + IOFZ=(IZ+NFCELL(3))*NUCELL(2) + DO IY=0,NSCELL(2)-1 + IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1) + ILOCD=IOFYZ+IX+NFCELL(1)+1 + IGEN=IUNFLD(1,ILOCD) + ITSYM(1,IGEN)=ISAXIS(1) + ENDDO + ENDDO + ENDIF +*---- +* Identify cells to tests for Y +* reflection symmetry +*---- + IF(ABS(ISAXIS(2)) .EQ. 1) THEN + IF(ISAXIS(2) .EQ. -1) THEN + IY=0 + ELSE IF(ISAXIS(2) .EQ. 1) THEN + IY=NSCELL(2)-1 + ENDIF + DO IZ=0,NSCELL(3)-1 + IOFZ=(IZ+NFCELL(3))*NUCELL(2) + IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1) + DO IX=0,NSCELL(1)-1 + ILOCD=IOFYZ+IX+NFCELL(1)+1 + IGEN=IUNFLD(1,ILOCD) + ITSYM(2,IGEN)=ISAXIS(2) + ENDDO + ENDDO + ENDIF +*---- +* Identify cells to tests for Z +* reflection symmetry +*---- + IF(ABS(ISAXIS(3)) .EQ. 1) THEN + IF(ISAXIS(3) .EQ. -1) THEN + IZ=0 + ELSE IF(ISAXIS(3) .EQ. 1) THEN + IZ=NSCELL(3)-1 + ENDIF + IOFZ=(IZ+NFCELL(3))*NUCELL(2) + DO IY=0,NSCELL(2)-1 + IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1) + DO IX=0,NSCELL(1)-1 + ILOCD=IOFYZ+IX+NFCELL(1)+1 + IGEN=IUNFLD(1,ILOCD) + ITSYM(3,IGEN)=ISAXIS(3) + ENDDO + ENDDO + ENDIF + ENDIF + DO ILOCD=1,NBOCEL + IF(ITSYM(4,ILOCD) .EQ. -1) THEN + IF(ITSYM(2,ILOCD) .EQ. -1) THEN + ITSYM(1,ILOCD)=1 + ELSE IF(ITSYM(1,ILOCD) .EQ. 1) THEN + ITSYM(2,ILOCD)=-1 + ENDIF + ELSE IF(ITSYM(4,ILOCD) .EQ. 1) THEN + IF(ITSYM(2,ILOCD) .EQ. 1) THEN + ITSYM(1,ILOCD)=-1 + ELSE IF(ITSYM(1,ILOCD) .EQ. -1) THEN + ITSYM(2,ILOCD)=1 + ENDIF + ENDIF + ENDDO + IF(ISAXIS(1) .NE. 0) THEN + IF(ISAXIS(1) .EQ. -2) THEN +*---- +* SSYM X- +* Fill position IXR=1,NSCELL(1) with cells at +* position IXD=NUCELL(1)-IXR+1 +*---- + DO IZ=0,NSCELL(3)-1 + IOFZ=(IZ+NFCELL(3))*NUCELL(2) + DO IY=0,NSCELL(2)-1 + IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1) + DO IX=1,NSCELL(1) + ILOCD=IOFYZ+NUCELL(1)+1-IX + ILOCR=IOFYZ+IX + IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD) + IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),1) + ENDDO + ENDDO + ENDDO + ELSE IF(ISAXIS(1) .EQ. -1) THEN +*---- +* SYME X- +* Fill position IXR=1,NSCELL(1)-1 with cells at +* position IXD=NUCELL(1)-IXR+1 +* set test flag for IX=NSCELL(1) +*---- + DO IZ=0,NSCELL(3)-1 + IOFZ=(IZ+NFCELL(3))*NUCELL(2) + DO IY=0,NSCELL(2)-1 + IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1) + DO IX=1,NSCELL(1)-1 + ILOCD=IOFYZ+NUCELL(1)+1-IX + ILOCR=IOFYZ+IX + IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD) + IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),1) + ENDDO + ENDDO + ENDDO + ELSE IF(ISAXIS(1) .EQ. 1) THEN +*---- +* SYME X+ +* Fill position IXR=NUCELL(1)-IXD+1 with cell +* at position IXD=1,NSCELL(1)-1 +* set test flag for IX=NSCELL(1) +*---- + DO IZ=0,NSCELL(3)-1 + IOFZ=(IZ+NFCELL(3))*NUCELL(2) + DO IY=0,NSCELL(2)-1 + IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1) + DO IX=1,NSCELL(1)-1 + ILOCD=IOFYZ+IX + ILOCR=IOFYZ+NUCELL(1)-IX+1 + IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD) + IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),1) + ENDDO + ENDDO + ENDDO + ELSE IF(ISAXIS(1) .EQ. 2) THEN +*---- +* SSYM X+ +* Fill position IXR=NUCELL(1)-IXD+1 with cell +* at position IXD=1,NSCELL(1) +*---- + DO IZ=0,NSCELL(3)-1 + IOFZ=(IZ+NFCELL(3))*NUCELL(2) + DO IY=0,NSCELL(2)-1 + IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1) + DO IX=1,NSCELL(1) + ILOCD=IOFYZ+IX + ILOCR=IOFYZ+NUCELL(1)-IX+1 + IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD) + IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),1) + ENDDO + ENDDO + ENDDO + ENDIF + NSCELL(1)=MAX(1,NUCELL(1)) + ENDIF + IF(ISAXIS(2) .NE. 0) THEN + IF(ISAXIS(2) .EQ. -2) THEN +*---- +* SSYM Y- +* Fill position IYR=1,NSCELL(2) with cells at +* position IYD=NUCELL(2)-IYR+1 +*---- + DO IZ=0,NSCELL(3)-1 + IOFZ=(IZ+NFCELL(3))*NUCELL(2) + DO IY=1,NSCELL(2) + IOFYZ=(NUCELL(2)-IY+IOFZ)*NUCELL(1) + IOFYZR=(IY-1+IOFZ)*NUCELL(1) + DO IX=1,NSCELL(1) + ILOCD=IOFYZ+IX + ILOCR=IOFYZR+IX + IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD) + IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),3) + ENDDO + ENDDO + ENDDO + ELSE IF(ISAXIS(2) .EQ. -1) THEN +*---- +* SYME Y- +* Fill position IYR=1,NSCELL(2)-1 with cells at +* position IYD=NUCELL(2)-IYR+1 +* set test flag for IY=NSCELL(2) +*---- + DO IZ=0,NSCELL(3)-1 + IOFZ=(IZ+NFCELL(3))*NUCELL(2) + DO IY=1,NSCELL(2)-1 + IOFYZ=(NUCELL(2)-IY+IOFZ)*NUCELL(1) + IOFYZR=(IY-1+IOFZ)*NUCELL(1) + DO IX=1,NSCELL(1) + ILOCD=IOFYZ+IX + ILOCR=IOFYZR+IX + IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD) + IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),3) + ENDDO + ENDDO + ENDDO + ELSE IF(ISAXIS(2) .EQ. 1) THEN +*---- +* SYME Y+ +* Fill position IYR=NUCELL(2)-IYD+1 with cell +* at position IYD=1,NSCELL(2)-1 +* set test flag for IY=NSCELL(2) +*---- + DO IZ=0,NSCELL(3)-1 + IOFZ=(IZ+NFCELL(3))*NUCELL(2) + DO IY=1,NSCELL(2)-1 + IOFYZR=(NUCELL(2)-IY+IOFZ)*NUCELL(1) + IOFYZ=(IY-1+IOFZ)*NUCELL(1) + DO IX=1,NSCELL(1) + ILOCD=IOFYZ+IX + ILOCR=IOFYZR+IX + IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD) + IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),3) + ENDDO + ENDDO + ENDDO + ELSE IF(ISAXIS(2) .EQ. 2) THEN +*---- +* SSYM Y+ +* Fill position IYR=NUCELL(2)-IYD+1 with cell +* at position IYD=1,NSCELL(2) +*---- + DO IZ=0,NSCELL(3)-1 + IOFZ=(IZ+NFCELL(3))*NUCELL(2) + DO IY=1,NSCELL(2) + IOFYZR=(NUCELL(2)-IY+IOFZ)*NUCELL(1) + IOFYZ=(IY-1+IOFZ)*NUCELL(1) + DO IX=1,NSCELL(1) + ILOCD=IOFYZ+IX + ILOCR=IOFYZR+IX + IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD) + IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),3) + ENDDO + ENDDO + ENDDO + ENDIF + NSCELL(2)=MAX(1,NUCELL(2)) + ENDIF + IF(ISAXIS(3) .NE. 0) THEN + IF(ISAXIS(3) .EQ. -2) THEN +*---- +* SSYM Z- +* Fill position IZR=1,NSCELL(3) with cells at +* position IZD=NSUC(3)-IZR+1 +*---- + DO IZ=1,NSCELL(3) + IOFZR=(IZ-1)*NUCELL(2) + IOFZ=(NSUC(3)-IZ)*NUCELL(2) + DO IY=1,NSCELL(2) + IOFYZ=(IY-1+IOFZ)*NUCELL(1) + IOFYZR=(IY-1+IOFZR)*NUCELL(1) + DO IX=1,NSCELL(1) + ILOCD=IOFYZ+IX + ILOCR=IOFYZR+IX + IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD) + IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),-1) + ENDDO + ENDDO + ENDDO + ELSE IF(ISAXIS(3) .EQ. -1) THEN +*---- +* SYME Z- +* Fill position IZR=1,NSCELL(3)-1 with cells at +* position IZD=NSUC(3)-IZR+1 +* set test flag for IZ=NSCELL(3) +*---- + DO IZ=1,NSCELL(3)-1 + IOFZR=(IZ-1)*NUCELL(2) + IOFZ=(NSUC(3)-IZ)*NUCELL(2) + DO IY=1,NSCELL(2) + IOFYZ=(IY-1+IOFZ)*NUCELL(1) + IOFYZR=(IY-1+IOFZR)*NUCELL(1) + DO IX=1,NSCELL(1) + ILOCD=IOFYZ+IX + ILOCR=IOFYZR+IX + IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD) + IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),-1) + ENDDO + ENDDO + ENDDO + ELSE IF(ISAXIS(3) .EQ. 1) THEN +*---- +* SYME Z+ +* Fill position IZR=NSUC(3)-IZD+1 with cell +* at position IZD=1,NSCELL(3)-1 +* set test flag for IZ=NSCELL(3) +*---- + DO IZ=1,NSCELL(3)-1 + IOFZ=(IZ-1)*NUCELL(2) + IOFZR=(NSUC(3)-IZ)*NUCELL(2) + DO IY=1,NSCELL(2) + IOFYZ=(IY-1+IOFZ)*NUCELL(1) + IOFYZR=(IY-1+IOFZR)*NUCELL(1) + DO IX=1,NSCELL(1) + ILOCD=IOFYZ+IX + ILOCR=IOFYZR+IX + IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD) + IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),-1) + ENDDO + ENDDO + ENDDO + ELSE IF(ISAXIS(3) .EQ. 2) THEN +*---- +* SSYM Z+ +* Fill position IZR=NSUC(3)-IZD+1 with cell +* at position IZD=1,NSCELL(3) +*---- + DO IZ=1,NSCELL(3) + IOFZ=(IZ-1)*NUCELL(2) + IOFZR=(NSUC(3)-IZ)*NUCELL(2) + DO IY=1,NSCELL(2) + IOFYZ=(IY-1+IOFZ)*NUCELL(1) + IOFYZR=(IY-1+IOFZR)*NUCELL(1) + DO IX=1,NSCELL(1) + ILOCD=IOFYZ+IX + ILOCR=IOFYZR+IX + IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD) + IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),-1) + ENDDO + ENDDO + ENDDO + ENDIF + NSCELL(3)=MAX(1,NSUC(3)) + ENDIF +*---- +* Localize external faces +* 1. X- (1) AND X+ (2) +*---- + DO IZ=1,NSUC(3) + DO IY=1,NUCELL(2) +* write(6,*) ' X faces =',IY,IZ + ILOCD=NUCELL(1)*(IY-1+NUCELL(2)*(IZ-1))+1 + IF(IUNFLD(2,ILOCD) .EQ. 1) THEN + IGEN=IUNFLD(1,ILOCD) + IDFEX(1,IGEN)=1 + IDFRT(1,IGEN)=IGEN + ENDIF +* write(6,*) ' X - =',ILOCD,IUNFLD(2,ILOCD),IDFEX(1,IGEN) + ILOCD=NUCELL(1)*(IY-1+NUCELL(2)*(IZ-1))+NUCELL(1) + IF(IUNFLD(2,ILOCD) .EQ. 1) THEN + IGEN=IUNFLD(1,ILOCD) + IDFEX(2,IGEN)=1 + IDFRT(2,IGEN)=IGEN + ENDIF +* write(6,*) ' X + =',ILOCD,IUNFLD(2,ILOCD),IDFEX(2,IGEN) + ENDDO + ENDDO +*---- +* 2. Y- (3) Y+ (4) +*---- + DO IZ=1,NSUC(3) + DO IX=1,NUCELL(1) +* write(6,*) ' Y faces =',IX,IZ + ILOCD=NUCELL(1)*NUCELL(2)*(IZ-1)+IX + IF(IUNFLD(2,ILOCD) .EQ. 1) THEN + IGEN=IUNFLD(1,ILOCD) + IDFEX(3,IGEN)=1 + IDFRT(3,IGEN)=IGEN + ENDIF +* write(6,*) ' Y - =',ILOCD,IUNFLD(2,ILOCD),IDFEX(3,IGEN) + ILOCD=NUCELL(1)*(NUCELL(2)-1+NUCELL(2)*(IZ-1))+IX + IF(IUNFLD(2,ILOCD) .EQ. 1) THEN + IGEN=IUNFLD(1,ILOCD) + IDFEX(4,IGEN)=1 + IDFRT(4,IGEN)=IGEN + ENDIF +* write(6,*) ' Y + =',ILOCD,IUNFLD(2,ILOCD),IDFEX(4,IGEN) + ENDDO + ENDDO +*---- +* 3. Z- (5) Z+ (6) +*---- + DO IY=1,NUCELL(2) + DO IX=1,NUCELL(1) +* write(6,*) ' Z faces =',IX,IY + ILOCD=NUCELL(1)*(IY-1)+IX + IF(IUNFLD(2,ILOCD) .EQ. 1) THEN + IGEN=IUNFLD(1,ILOCD) + IDFEX(5,IGEN)=1 + IDFRT(5,IGEN)=IGEN + ENDIF +* write(6,*) ' Z - =',ILOCD,IUNFLD(2,ILOCD),IDFEX(5,IGEN) + ILOCD=NUCELL(1)*(IY-1+NUCELL(2)*(NSUC(3)-1))+IX + IF(IUNFLD(2,ILOCD) .EQ. 1) THEN + IGEN=IUNFLD(1,ILOCD) + IDFEX(6,IGEN)=1 + IDFRT(6,IGEN)=IGEN + ENDIF +* write(6,*) ' Z + =',ILOCD,IUNFLD(2,ILOCD),IDFEX(6,IGEN) + ENDDO + ENDDO +*---- +* For translation BC, find translated cell +* 1. X translation +*---- + IF(ISAXIS(1) .EQ. 3) THEN + DO IGEN=1,NBOCEL + IF(IDFEX(1,IGEN) .EQ. 1) THEN + DO IZ=1,NSUC(3) + DO IY=1,NUCELL(2) + ILOCD=NUCELL(1)*(IY-1+NUCELL(2)*(IZ-1))+1 + IF(IUNFLD(2,ILOCD) .EQ. 1) THEN + IF(IUNFLD(1,ILOCD) .EQ. IGEN) THEN + ILOCD=NUCELL(1)*(IY-1+NUCELL(2)*(IZ-1))+NUCELL(1) + IGENT=IUNFLD(1,ILOCD) + IDFRT(1,IGEN)=IGENT + IDFRT(2,IGENT)=IGEN + ENDIF + ENDIF + ENDDO + ENDDO + ENDIF + ENDDO + ENDIF +*---- +* 2. Y translation +*---- + IF(ISAXIS(2) .EQ. 3) THEN + DO IGEN=1,NBOCEL + IF(IDFEX(3,IGEN) .EQ. 1) THEN + DO IZ=1,NSUC(3) + DO IX=1,NUCELL(1) + ILOCD=NUCELL(1)*NUCELL(2)*(IZ-1)+IX + IF(IUNFLD(2,ILOCD) .EQ. 1) THEN + IF(IUNFLD(1,ILOCD) .EQ. IGEN) THEN + ILOCD=NUCELL(1)*(NUCELL(2)-1+NUCELL(2)*(IZ-1))+IX + IGENT=IUNFLD(1,ILOCD) + IDFRT(3,IGEN)=IGENT + IDFRT(4,IGENT)=IGEN + ENDIF + ENDIF + ENDDO + ENDDO + ENDIF + ENDDO + ENDIF +*---- +* 3. Z translation +*---- + IF(ISAXIS(3) .EQ. 3) THEN + DO IGEN=1,NBOCEL + IF(IDFEX(5,IGEN) .EQ. 1) THEN + DO IY=1,NUCELL(2) + DO IX=1,NUCELL(1) + ILOCD=NUCELL(1)*(IY-1)+IX + IF(IUNFLD(2,ILOCD) .EQ. 1) THEN + IF(IUNFLD(1,ILOCD) .EQ. IGEN) THEN + ILOCD=NUCELL(1)*(IY-1+NUCELL(2)*(NSUC(3)-1))+IX + IGENT=IUNFLD(1,ILOCD) + IDFRT(5,IGEN)=IGENT + IDFRT(6,IGENT)=IGEN + ENDIF + ENDIF + ENDDO + ENDDO + ENDIF + ENDDO + ENDIF +*---- +* Analyze translation boundary +*---- +*---- +* Compute the number of times each cell appears +* after unfolding +*---- + DO IGEN=1,NBOCEL + DO ILOCD=1,NBUCEL + IF(ABS(IUNFLD(1,ILOCD)) .EQ. IGEN) THEN + IDFEX(0,IGEN)=IDFEX(0,IGEN)+1 + ENDIF + ENDDO + ENDDO +*---- +* For 2-D cases reset components 5, 6 of IDFEX to 0 +*---- + IF(NDIM .EQ. 2) THEN + DO IGEN=1,NBOCEL + IDFEX(5,IGEN)=0 + IDFEX(6,IGEN)=0 + ENDDO + ENDIF +*---- +* Processing finished: +* print routine output and closing header if required +* and return +*---- + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6002) + DO IZ=1,NSUC(3) + IF(NDIM .EQ. 3) THEN + WRITE(IOUT,6003) IZ + ENDIF + WRITE(IOUT,6004) (IX,IX=1,NUCELL(1)) + WRITE(IOUT,6012) + DO IY=NUCELL(2),1,-1 + ILOCD=((IZ-1)*NUCELL(2)+(IY-1))*NUCELL(1) + WRITE(IOUT,6005) IY, + > (IUNFLD(1,IX),IX=ILOCD+1,ILOCD+NUCELL(1)) + ENDDO + ENDDO + WRITE(IOUT,6008) + DO IZ=1,NSUC(3) + IF(NDIM .EQ. 3) THEN + WRITE(IOUT,6003) IZ + ENDIF + WRITE(IOUT,6004) (IX,IX=1,NUCELL(1)) + WRITE(IOUT,6012) + DO IY=NUCELL(2),1,-1 + ILOCD=((IZ-1)*NUCELL(2)+(IY-1))*NUCELL(1) + WRITE(IOUT,6013) IY, + > (CTRN(IUNFLD(2,IX)),IX=ILOCD+1,ILOCD+NUCELL(1)) + ENDDO + ENDDO + WRITE(IOUT,6006) + DO ILOCD=1,NBOCEL + WRITE(IOUT,6007) + > ILOCD,(ITSYM(IX,ILOCD),IX=1,4) + ENDDO + WRITE(IOUT,6009) + DO ILOCD=1,NBOCEL + IF(NDIM .EQ. 3) THEN + WRITE(IOUT,6007) + > ILOCD,(IDFEX(IX,ILOCD),IX=1,6),IDFEX(0,ILOCD) + ELSE + WRITE(IOUT,6011) + > ILOCD,(IDFEX(IX,ILOCD),IX=1,4),IDFEX(0,ILOCD) + ENDIF + ENDDO + WRITE(IOUT,6010) + DO ILOCD=1,NBOCEL + WRITE(IOUT,6007) + > ILOCD,(IDFRT(IX,ILOCD),IX=1,2*NDIM) + ENDDO + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6002 FORMAT(' Cells in assembly') + 6003 FORMAT(' Plane IZ =',I6) + 6004 FORMAT(' IX=',8X,24(I7,1X)) + 6005 FORMAT(' IY=',I7,1X,24(I7.7,1X)) + 6006 FORMAT(/' Symmetrized cell X Y Z D') + 6007 FORMAT(' Cell ',I7.7,5X,20I5) + 6008 FORMAT(/' Cell rotations in assembly') + 6009 FORMAT(/' External faces -X +X -Y +Y -Z +Z ND') + 6010 FORMAT(/' Coupled faces -X +X -Y +Y -Z +Z ') + 6011 FORMAT(' Cell ',I7.7,5X,4I5,10X,14I5) + 6012 FORMAT('X/Y') + 6013 FORMAT(' IY=',I7,1X,24(5X,A2,1X)) + END diff --git a/Dragon/src/NXTCVM.f b/Dragon/src/NXTCVM.f new file mode 100644 index 0000000..fa45d3f --- /dev/null +++ b/Dragon/src/NXTCVM.f @@ -0,0 +1,154 @@ +*DECK NXTCVM + SUBROUTINE NXTCVM(IFTRK ,IPRINT,NFREG ,NFSUR ,NEREG ,NESUR , + > MATALB,SURVOL,KEYMRG) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To compress VOLSUR and MATALB according to KEYMRG +* and save on IFTRK. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IFTRK pointer to the TRACKING file in creation mode. +* IPRINT print level. +* NFREG number of regions (geometry). +* NFSUR number of surfaces (geometry). +* NEREG number of regions (compress). +* NESUR number of surfaces (compress). +* MATALB global mixture/albedo identification vector (geometry). +* SURVOL global surface volume vector (geometry). +* KEYMRG index array for surface and volume renumbering. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IFTRK,IPRINT + INTEGER NFREG,NFSUR,NEREG,NESUR + INTEGER MATALB(-NFSUR:NFREG),KEYMRG(-NFSUR:NFREG) + DOUBLE PRECISION SURVOL(-NFSUR:NFREG) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTCVM') +*---- +* Local variables +*---- + INTEGER IREG,JREG,IMIX,ITST,JJ + DOUBLE PRECISION DVR +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ALBMAT + REAL, ALLOCATABLE, DIMENSION(:) :: VOLSUR +*---- +* Scratch storage allocation +* ALBMAT global mixture/albedo identification vector (compress). +* VOLSUR global surface volume vector (compress). +*---- + ALLOCATE(ALBMAT(-NESUR:NEREG),VOLSUR(-NESUR:NEREG)) +*---- +* Processing starts: +* print routine opening header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,*) 'Surface Merge',NFSUR + WRITE(IOUT,'(5I10)') (KEYMRG(JREG),JREG=-1,-NFSUR,-1) + WRITE(IOUT,*) 'Region Merge',NFREG + WRITE(IOUT,'(5I10)') (KEYMRG(JREG),JREG=1,NFREG) + ENDIF +*---- +* Compress regions +*---- + ALBMAT(0)=0 + DVR=0.0D0 + IMIX=0 + VOLSUR(0)=0.0 + DO IREG=1,NEREG + ITST=-1 + DO JREG=1,NFREG +* write(6,*) 'Merging regions',IREG,JREG,KEYMRG(JREG) + IF(KEYMRG(JREG) .EQ. IREG) THEN + IF(ITST .EQ. -1) THEN + IMIX=MATALB(JREG) + DVR=SURVOL(JREG) + ITST=1 + ELSE + IF(IMIX .NE. MATALB(JREG) ) CALL XABORT(NAMSBR// + >': Merging region with different mixtures not permitted') + DVR=DVR+SURVOL(JREG) + ENDIF + ENDIF + ENDDO + IF(ITST .EQ. -1) CALL XABORT(NAMSBR// + >': One merge region not defined') + VOLSUR(IREG)=REAL(DVR) + ALBMAT(IREG)=IMIX + ENDDO +*---- +* Compress surfaces +*---- + DO IREG=-1,-NESUR,-1 + ITST=-1 + DO JREG=-1,-NFSUR,-1 +* write(6,*) 'Merging surfaces',IREG,JREG,KEYMRG(JREG) + IF(KEYMRG(JREG) .EQ. IREG) THEN + IF(ITST .EQ. -1) THEN + IMIX=MATALB(JREG) + DVR=SURVOL(JREG) + ITST=1 + ELSE + IF(IMIX .NE. MATALB(JREG) ) CALL XABORT(NAMSBR// + >': Merging surfaces with different albedos not permitted') + DVR=DVR+SURVOL(JREG) + ENDIF + ENDIF + ENDDO + IF(ITST .EQ. -1) CALL XABORT(NAMSBR// + >': One merge surface not defined') + VOLSUR(IREG)=REAL(DVR/4.0D0) + ALBMAT(IREG)=IMIX + ENDDO + WRITE(IFTRK) (VOLSUR(JJ),JJ=-NESUR,NEREG) + WRITE(IFTRK) (ALBMAT(JJ),JJ=-NESUR,NEREG) +*---- +* Processing finished: +* print routine closing output header if required +* and return +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(VOLSUR,ALBMAT) + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + END diff --git a/Dragon/src/NXTCVS.f b/Dragon/src/NXTCVS.f new file mode 100644 index 0000000..94f3e24 --- /dev/null +++ b/Dragon/src/NXTCVS.f @@ -0,0 +1,255 @@ +*DECK NXTCVS + SUBROUTINE NXTCVS(IPTRK ,IPRINT,NDIM ,ITYPBC,NBOCEL, + > NFSUR ,NFREG ,MXGSUR,MXGREG,MRGMIX, + > KEYMRG,MATALB,SURVOL) +* +*---------- +* +*Purpose: +* To compute final surfaces and volumes for geometry +* and to create the EXCELL type MATALB and KEYMRG vector. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau. +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure. +* IPRINT print level. +* NDIM problem dimensions. +* ITYPBC type of boundary conditions where: +* =0 for geometry with Cartesian boundaries; +* =1 for geometry with annular boundary; +* =2 for geometry with hexagonal boundary. +* NBOCEL number of cells in original geometry. +* NFSUR final number of surfaces. +* NFREG final number of regions. +* MXGSUR maximum number of surfaces for any geometry. +* MXGREG maximum number of region for any geometry. +* MRGMIX option to merge by mixtures. Activated when MRGMIX is 1. +* +*Parameters: output +* KEYMRG global merging vector. +* MATALB global mixture/albedo identification vector (including HMIX). +* SURVOL global surface volume vector. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPTRK +* INTEGER IPTRK + INTEGER IPRINT,NDIM,ITYPBC, + > NBOCEL,NFSUR,NFREG,MXGSUR,MXGREG + INTEGER KEYMRG(-NFSUR:NFREG),MATALB(-NFSUR:NFREG,2) + DOUBLE PRECISION SURVOL(-NFSUR:NFREG) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTCVS') + INTEGER NSTATE + PARAMETER (NSTATE=40) + DOUBLE PRECISION DZERO,DONE,DTWO + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Local variables +*---- + INTEGER ICEL,ICLS,ILEV,ISV,IGEO + INTEGER NREG,NSUR,NBGCLS,IGCLS,NUNK,MXRUNK + INTEGER IEDIMX(NSTATE),IEDIMP(NSTATE) + CHARACTER NAMREC*12 + DOUBLE PRECISION DFACC,DFACP +*---- +* Update for MERGMIX +*---- + INTEGER MRGMIX,MAXMIX,KMIX,IMIX + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDMER +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDREG,IDSUR,MIX,MIXH + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: INDXSR + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SVSGEO +*---- +* Data +*---- + CHARACTER CLEV(2)*1 + SAVE CLEV + DATA CLEV /'C','P'/ +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + NUNK=NFSUR+NFREG+1 + MXRUNK=MXGSUR+MXGREG+1 + SURVOL(-NFSUR:NFREG)=DZERO + MATALB(-NFSUR:NFREG,:2)=0 +*---- +* Here there are no merge +*---- + DO ICEL=1,NBOCEL + ILEV=1 + IGEO=ICEL + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'DIM' + IEDIMX(:NSTATE)=0 + CALL LCMGET(IPTRK,NAMREC,IEDIMX) + NREG=IEDIMX(8) + NSUR=IEDIMX(9) + NBGCLS=IEDIMX(16) + IGCLS=IEDIMX(17)-1 +*---- +* Get MIXTURE +*---- + ALLOCATE(MIX(NREG),MIXH(NREG),INDXSR(5,-NSUR:NREG)) + ALLOCATE(IDREG(NREG),IDSUR(NSUR)) + ALLOCATE(SVSGEO(2*(NSUR+NREG+1))) + + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'MIX' + CALL LCMGET(IPTRK,NAMREC,MIX) + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'HOM' + CALL LCMGET(IPTRK,NAMREC,MIXH) +*---- +* Get INDEX and SURVOL for pin +*---- + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'VSI' + CALL LCMGET(IPTRK,NAMREC,INDXSR) + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'VSE' + CALL LCMGET(IPTRK,NAMREC,SVSGEO) +*---- +* Get IDREG and IDSUR +*---- + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'RID' + CALL LCMGET(IPTRK,NAMREC,IDREG) + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'SID' + CALL LCMGET(IPTRK,NAMREC,IDSUR) + DFACC=DBLE(IEDIMX(19)) + CALL NXTAVS(IPRINT,NDIM ,ITYPBC,NFSUR ,NFREG ,NSUR , + > NREG ,MIX ,MIXH ,INDXSR,IDSUR ,IDREG , + > SVSGEO,DFACC ,MATALB,SURVOL) + DEALLOCATE(SVSGEO,IDSUR,IDREG,INDXSR,MIXH,MIX) + IF(NBGCLS .NE. 0) THEN + ILEV=2 + DO ICLS=1,NBGCLS + IGEO=IGCLS+ICLS + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'DIM' + IEDIMP(:NSTATE)=0 + CALL LCMGET(IPTRK,NAMREC,IEDIMP) + NREG=IEDIMP(8) + NSUR=IEDIMP(9) + ALLOCATE(MIX(NREG),MIXH(NREG),INDXSR(5,-NSUR:NREG)) + ALLOCATE(IDREG(NREG),IDSUR(NSUR)) + ALLOCATE(SVSGEO(2*(NSUR+NREG+1))) +*---- +* Get MIXTURE +*---- + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'MIX' + CALL LCMGET(IPTRK,NAMREC,MIX) + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'HOM' + CALL LCMGET(IPTRK,NAMREC,MIXH) +*---- +* Get INDEX and SURVOL for cell +*---- + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'VSI' + CALL LCMGET(IPTRK,NAMREC,INDXSR) + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'VSE' + CALL LCMGET(IPTRK,NAMREC,SVSGEO) +*---- +* Get IDREG and IDSUR +*---- + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'RID' + CALL LCMGET(IPTRK,NAMREC,IDREG) + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'SID' + CALL LCMGET(IPTRK,NAMREC,IDSUR) + DFACP=DFACC*DBLE(IEDIMP(17)) + CALL NXTAVS(IPRINT,NDIM ,ITYPBC,NFSUR ,NFREG ,NSUR , + > NREG ,MIX ,MIXH ,INDXSR,IDSUR ,IDREG , + > SVSGEO,DFACP ,MATALB,SURVOL) + DEALLOCATE(SVSGEO,IDSUR,IDREG,INDXSR,MIXH,MIX) + ENDDO + ENDIF + ENDDO +*---- +* Save records on IPTRK +*---- + IF(MRGMIX .EQ. 0 ) THEN + DO ISV=-NFSUR,NFREG + KEYMRG(ISV)=ISV + ENDDO + ELSE +* Find maximum MIXTURE number + MAXMIX=0 + DO ISV=1,NFREG + MAXMIX=MAX(MAXMIX,MATALB(ISV,1)) + ENDDO + ALLOCATE(IDMER(0:MAXMIX)) + IDMER(0:MAXMIX)=0 + KMIX=0 + DO IMIX=0,MAXMIX + DO ISV=1,NFREG + IF(MATALB(ISV,1) .EQ. IMIX) THEN + KMIX=KMIX+1 + IDMER(IMIX)=KMIX + GO TO 100 + ENDIF + ENDDO + 100 CONTINUE + ENDDO + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6100) + DO IMIX=0,MAXMIX + IF(IDMER(IMIX).NE.0) THEN + WRITE(IOUT,6101) IMIX,IDMER(IMIX) + ENDIF + ENDDO + ENDIF + DO ISV=-NFSUR,0 + KEYMRG(ISV)=ISV + ENDDO + DO ISV=1,NFREG + IMIX=MATALB(ISV,1) + KEYMRG(ISV)=IDMER(IMIX) + ENDDO + DEALLOCATE(IDMER) + ENDIF + CALL LCMPUT(IPTRK ,'KEYMRG ',NUNK ,1,KEYMRG) + CALL LCMPUT(IPTRK ,'MATALB ',NUNK ,1,MATALB(-NFSUR,1)) + CALL LCMPUT(IPTRK ,'HOMMATALB ',NUNK ,1,MATALB(-NFSUR,2)) + CALL LCMPUT(IPTRK ,'SAreaRvolume',NUNK,4,SURVOL) +*---- +* Processing finished: +* print routine closing output header if required +* and return +*---- + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6100 FORMAT('Relation between mixture and region indices for MERGMIX') + 6101 FORMAT(' Mixture ',I0,' is associated to region',I10) + END diff --git a/Dragon/src/NXTEGI.f b/Dragon/src/NXTEGI.f new file mode 100644 index 0000000..fc749e1 --- /dev/null +++ b/Dragon/src/NXTEGI.f @@ -0,0 +1,600 @@ +*DECK NXTEGI + SUBROUTINE NXTEGI(IPGEO ,IPRINT,ITYPG ,MAXMSH,NMIX ,NM , + > MAXMSS,NMS ,NREG ,NREGS ,NSUR ,NSURS , + > MIX ,ISPLT ,DAMESH, + > RMESH ,MIXC ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To extract cell or pin geometry information. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPGEO pointer to the reference geometry data structure. +* IPRINT intermediate printing level for output. +* ITYPG geometry type. +* MAXMSH maximum number of elements in MESH array. +* NMIX number of elements in MIX array. +* NM mesh size in all directions ($X$, $Y$, $Z$ and $R$). +* +*Parameters: output +* MAXMSS maximum number of elements in MESH array after split. +* NMS mesh size in all directions ($X$, $Y$, $Z$ and $R$) +* after split. +* NREG number of regions. +* NREGS number of regions after split. +* NSUR number of surfaces. +* NSURS number of surfaces after split. +* MIX final mixture description for geometry (including HMIX). +* ISPLT final split desctiption for geometry. +* DAMESH final mesh description for geometry. +* +*Parameters: temporary storage +* RMESH temporary vector for reading cell mesh array. +* MIXC temporary mixture for cell rotation (including HMIX). +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPGEO + INTEGER IPRINT,ITYPG,MAXMSH,NMIX,NM(4),MAXMSS, + > NMS(4),NREG,NREGS,NSUR,NSURS + INTEGER MIX(NMIX,2),ISPLT(MAXMSH,4) + DOUBLE PRECISION DAMESH(-1:MAXMSH,4) + REAL RMESH(0:MAXMSH) + INTEGER MIXC(NMIX,2,2) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTEGI') + DOUBLE PRECISION DZERO,DONE + PARAMETER (DZERO=0.0D0,DONE=1.0D0) + DOUBLE PRECISION DSQ3O2 + PARAMETER (DSQ3O2=0.86602540378444D0) +*---- +* Local variables +*---- + INTEGER IDIR,IR,IX,IY,IZ,IMTN,IMTO + INTEGER ILCMLN,ILCMTY,IMRGLN,IMRGTY + INTEGER NX,NY,NZ,NR,NRM,NXS,NYS,NZS,NRS,NRMS, + > NMREAD(4) + CHARACTER NAMREC*12,NAMMRG*12 + REAL OFFCEN(3) + REAL SIDE,SIDET + DOUBLE PRECISION DSIDE,DSIDET +*---- +* Data +*---- + CHARACTER CDIR(4)*1 + SAVE CDIR + DATA CDIR /'X','Y','Z','R'/ +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + NRM=0 + NRMS=0 + NX=MAX(1,NM(1)) + NY=MAX(1,NM(2)) + NZ=MAX(1,NM(3)) + NR=MAX(1,NM(4)) +*---- +* Read geometry information +* 1- Cartesian MESH +*---- + IF(ITYPG .EQ. 8 .OR. ITYPG .EQ. 9 .OR. + > ITYPG .EQ. 12 .OR. ITYPG .EQ. 13 .OR. + > ITYPG .EQ. 26 .OR. ITYPG .EQ. 27) THEN +*---- +* Hexagons +*---- + IDIR=1 + NAMREC='SIDE ' + CALL LCMGET(IPGEO,NAMREC,SIDE) + DSIDE=DBLE(SIDE)*DSQ3O2 + IF(ITYPG .EQ. 12 .OR. ITYPG .EQ. 13 .OR. + > ITYPG .EQ. 26 .OR. ITYPG .EQ. 27) THEN + NAMREC='SIDET ' + CALL LCMGET(IPGEO,NAMREC,SIDET) + DSIDET=DBLE(SIDET)*DSQ3O2 + DAMESH(0,IDIR)=-DSIDE + DAMESH(1,IDIR)=-DSIDET*(NM(1)-1) + DO IX=2,2*NM(1)-1 + DAMESH(IX,IDIR)=DAMESH(IX-1,IDIR)+DSIDET + ENDDO + DAMESH(2*NM(1),IDIR)=DSIDE + ELSE + DAMESH(-1,IDIR)=2*DSIDE + DAMESH(0,IDIR)=-DSIDE + DAMESH(1,IDIR)=DSIDE + ENDIF + IDIR=2 + DO IX=-1,2*NM(1) + DAMESH(IX,IDIR)=DAMESH(IX,IDIR-1) + ENDDO + IDIR=3 + NMREAD(IDIR)=0 + IF(NM(IDIR) .GT. 0) THEN + NAMREC='MESH'//CDIR(IDIR)//' ' + CALL LCMLEN(IPGEO,NAMREC,NMREAD(IDIR),ILCMTY) + IF(NMREAD(IDIR) .EQ. NM(IDIR)+1) THEN + CALL LCMGET(IPGEO,NAMREC,RMESH) + DO IX=0,NM(IDIR) + DAMESH(IX,IDIR)=DBLE(RMESH(IX)) + ENDDO + ISPLT(:NM(IDIR),IDIR)=1 + ENDIF + ELSE + DAMESH(0,IDIR)=DZERO + IX=1 + DAMESH(IX,IDIR)=DONE + ENDIF + ELSE +*---- +* Parallepiped +*---- + DO IDIR=1,3 + NMREAD(IDIR)=0 + IF(NM(IDIR) .GT. 0) THEN + NAMREC='MESH'//CDIR(IDIR)//' ' + CALL LCMLEN(IPGEO,NAMREC,NMREAD(IDIR),ILCMTY) + IF(NMREAD(IDIR) .EQ. NM(IDIR)+1) THEN + CALL LCMGET(IPGEO,NAMREC,RMESH) + DO IX=0,NM(IDIR) + DAMESH(IX,IDIR)=DBLE(RMESH(IX)) + ENDDO + ISPLT(:NM(IDIR),IDIR)=1 + ENDIF + ELSE + DAMESH(0,IDIR)=DZERO + IX=1 + DAMESH(IX,IDIR)=DONE + ENDIF + ENDDO + ENDIF +*---- +* 2- Read cell OFFCENTER and store in position -1 of DAMESH +*---- + OFFCEN(:3)=0.0 + CALL LCMLEN(IPGEO,'OFFCENTER ',ILCMLN,ILCMTY) + IF(ILCMLN .GT. 0) + > CALL LCMGET(IPGEO,'OFFCENTER ',OFFCEN) + DO IDIR=1,3 + DAMESH(-1,IDIR)=DBLE(OFFCEN(IDIR)) + ENDDO +*---- +* 3- Radial mesh +*---- + IDIR=4 + NMREAD(IDIR)=0 + NAMREC='RADIUS ' + CALL LCMLEN(IPGEO,NAMREC,NMREAD(IDIR),ILCMTY) + IF(NMREAD(IDIR) .EQ. NM(IDIR)+1) THEN + CALL LCMGET(IPGEO,NAMREC,RMESH) + DO IX=0,NM(IDIR) + DAMESH(IX,IDIR)=DBLE(RMESH(IX)) + ENDDO + ISPLT(:NM(IDIR),IDIR)=1 + ENDIF +*---- +* 4- Cartesian, radial and hexagonal split +*---- + DO IDIR=1,4 + IF(NM(IDIR) .GT. 0) THEN + NAMREC='SPLIT'//CDIR(IDIR)//' ' + ISPLT(:NM(IDIR),IDIR)=1 + CALL LCMLEN(IPGEO,NAMREC,ILCMLN,ILCMTY) + IF(ILCMLN .EQ. NM(IDIR)) + > CALL LCMGET(IPGEO,NAMREC,ISPLT(1,IDIR)) + NMS(IDIR)=0 + DO IR=1,NM(IDIR) + NMS(IDIR)=NMS(IDIR)+ABS(ISPLT(IR,IDIR)) + ENDDO + ELSE + NMS(IDIR)=NM(IDIR) + ENDIF + ENDDO + IF(ITYPG .EQ. 12 .OR. ITYPG .EQ. 13 .OR. + > ITYPG .EQ. 26 .OR. ITYPG .EQ. 27) THEN + NAMREC='SPLITH ' + IDIR=1 + CALL LCMLEN(IPGEO,NAMREC,ILCMLN,ILCMTY) + ISPLT(1,IDIR)=1 + IF(ILCMLN .EQ. NM(IDIR)) + > CALL LCMGET(IPGEO,NAMREC,ISPLT(1,IDIR)) + NMS(IDIR)=NM(IDIR)*ABS(ISPLT(1,IDIR)) + ENDIF + NXS=MAX(1,NMS(1)) + NYS=MAX(1,NMS(2)) + NZS=MAX(1,NMS(3)) + NRS=MAX(1,NMS(4)) + IF(IPRINT .GE. 100) THEN + IF(ITYPG .EQ. 8 .OR. ITYPG .EQ. 9 .OR. + > ITYPG .EQ. 12 .OR. ITYPG .EQ. 13 .OR. + > ITYPG .EQ. 26 .OR. ITYPG .EQ. 27) THEN + WRITE(IOUT,6015) ITYPG,NM(1),NMREAD(3),NMIX + IF(NM(1) .GT. 0) THEN + WRITE(IOUT,6011) 'MESHH =' + WRITE(IOUT,6012) (DAMESH(IX,1),IX=-1,2*NM(1)) + WRITE(IOUT,6011) 'SPLTH =' + WRITE(IOUT,6013) (ISPLT(1,1),IX=1,2*NM(1)) + ENDIF + IF(NMREAD(3) .GT. 0) THEN + WRITE(IOUT,6011) 'MESHZ =' + WRITE(IOUT,6012) (DAMESH(IX,3),IX=-1,NM(3)) + WRITE(IOUT,6011) 'SPLTZ =' + WRITE(IOUT,6013) (ISPLT(IX,3),IX=1,NM(3)) + ENDIF + ELSE + WRITE(IOUT,6010) ITYPG,(CDIR(IDIR),NM(IDIR),IDIR=1,4),NMIX + DO IDIR=1,3 + IF(NMREAD(IDIR) .GT. 0) THEN + WRITE(IOUT,6011) 'MESH'//CDIR(IDIR)//' =' + WRITE(IOUT,6012) (DAMESH(IX,IDIR),IX=-1,NM(IDIR)) + WRITE(IOUT,6011) 'SPLT'//CDIR(IDIR)//' =' + WRITE(IOUT,6013) (ISPLT(IX,IDIR),IX=1,NM(IDIR)) + ENDIF + ENDDO + ENDIF + IDIR=4 + IF(NMREAD(IDIR) .GT. 0) THEN + WRITE(IOUT,6011) 'RADIUS=' + WRITE(IOUT,6012) (DAMESH(IX,IDIR),IX=0,NM(IDIR)) + WRITE(IOUT,6011) 'SPLT'//CDIR(IDIR)//' =' + WRITE(IOUT,6013) (ISPLT(IX,IDIR),IX=1,NM(IDIR)) + ENDIF + ENDIF +*---- +* 5- Get MIX +*---- + NAMREC='MIX ' + CALL LCMLEN(IPGEO,NAMREC,ILCMLN,ILCMTY) + IF(ILCMLN .LT. 0 .OR. ILCMLN .GT. NMIX) CALL XABORT(NAMSBR// + >': Size of MIX vector is invalid') + NAMMRG='HMIX ' + CALL LCMLEN(IPGEO,NAMMRG,IMRGLN,IMRGTY) + IF(IMRGLN .LE. 0 ) THEN + NAMMRG=NAMREC + ELSE IF(IMRGLN .NE. ILCMLN) THEN + NAMMRG=NAMREC + WRITE(IOUT,8000) NAMSBR + ENDIF + IF(ILCMLN .GT. 0) THEN + IF (ITYPG .EQ. 3 ) THEN +*---- +* TUBE +*---- + NRM=NR + NSUR=NZ + NRMS=NRS + NSURS=NZS + IF(ILCMLN .LT. NY*NX*NRM) THEN + WRITE(IOUT,9000) NAMSBR,ILCMLN,NY*NX*NRM + CALL XABORT(NAMSBR// + > ': Invalid number of mixtures provided') + ENDIF + CALL LCMGET(IPGEO,NAMREC,MIX(1,1)) + CALL LCMGET(IPGEO,NAMMRG,MIX(1,2)) + ELSE IF(ITYPG .EQ. 6 ) THEN +*---- +* TUBEZ +*---- + NRM=NR + NSUR=2*(NRM*NX*NY)+NZ + NRMS=NRS + NSURS=2*(NRMS*NXS*NYS)+NZS + IF(ILCMLN .LT. NZ*NY*NX*NRM) THEN + WRITE(IOUT,9000) NAMSBR,ILCMLN,NZ*NY*NX*NRM + CALL XABORT(NAMSBR// + > ': Invalid number of mixtures provided') + ENDIF + CALL LCMGET(IPGEO,NAMREC,MIX(1,1)) + CALL LCMGET(IPGEO,NAMMRG,MIX(1,2)) + ELSE IF(ITYPG .EQ. 5) THEN +*---- +* CAR2D +*---- + NRM=1 + NSUR=2*(NY+NX) + NRMS=1 + NSURS=2*(NYS+NXS) + IF(ILCMLN .LT. NY*NX) THEN + WRITE(IOUT,9000) NAMSBR,ILCMLN,NY*NX + CALL XABORT(NAMSBR// + > ': Invalid number of mixtures provided') + ENDIF + CALL LCMGET(IPGEO,NAMREC,MIX(1,1)) + CALL LCMGET(IPGEO,NAMMRG,MIX(1,2)) + ELSE IF(ITYPG .EQ. 7 ) THEN +*---- +* CAR3D +*---- + NRM=1 + NSUR=2*(NX*NY+NY*NZ+NZ*NX) + NRMS=1 + NSURS=2*(NXS*NYS+NYS*NZS+NZS*NXS) + IF(ILCMLN .LT. NZ*NY*NX) THEN + WRITE(IOUT,9000) NAMSBR,ILCMLN,NZ*NY*NX + CALL XABORT(NAMSBR// + > ': Invalid number of mixtures provided') + ENDIF + CALL LCMGET(IPGEO,NAMREC,MIX(1,1)) + CALL LCMGET(IPGEO,NAMMRG,MIX(1,2)) + ELSE IF(ITYPG .EQ. 20) THEN +*---- +* CARCEL +*---- + NRM=NR+1 + NSUR=2*(NY+NX) + NRMS=NRS+1 + NSURS=2*(NYS+NXS) + IF(ILCMLN .LT. NY*NX*NRM) THEN + WRITE(IOUT,9000) NAMSBR,ILCMLN,NY*NX*NRM + CALL XABORT(NAMSBR// + > ': Invalid number of mixtures provided') + ENDIF + CALL LCMGET(IPGEO,NAMREC,MIX(1,1)) + CALL LCMGET(IPGEO,NAMMRG,MIX(1,2)) + ELSE IF(ITYPG .EQ. 23 ) THEN +*---- +* CARCELZ +*---- + NRM=NR+1 + NSUR=2*(NX*NY*NRM+NY*NZ+NZ*NX) + NRMS=NRS+1 + NSURS=2*(NXS*NYS*NRMS+NYS*NZS+NZS*NXS) + IF(ILCMLN .LT. NZ*NY*NX*NRM) THEN + WRITE(IOUT,9000) NAMSBR,ILCMLN,NZ*NY*NX*NRM + CALL XABORT(NAMSBR// + > ': Invalid number of mixtures provided') + ENDIF + CALL LCMGET(IPGEO,NAMREC,MIX(1,1)) + CALL LCMGET(IPGEO,NAMMRG,MIX(1,2)) + ELSE IF(ITYPG .EQ. 10 .OR. ITYPG .EQ. 21) THEN +*---- +* TUBEX and CARCELX +*---- + IF(ITYPG .EQ.21) THEN + NRM=NR+1 + NSUR=2*(NX*NY+NY*NZ*NRM+NZ*NX) + NRMS=NRS+1 + NSURS=2*(NXS*NYS+NYS*NZS*NRMS+NZS*NXS) + ELSE + NRM=NR + NSUR=NX+2*NY*NZ*NRM + NRMS=NRS + NSURS=NXS+2*NYS*NZS*NRMS + ENDIF +*---- +* For CARCELX reorder mixtures from $(R,Y,Z,X)$ to $(R,X,Y,Z)$ +*---- + IF(ILCMLN .LT. NZ*NY*NX*NRM) THEN + WRITE(IOUT,9000) NAMSBR,ILCMLN,NZ*NY*NX*NRM + CALL XABORT(NAMSBR// + > ': Invalid number of mixtures provided') + ENDIF + CALL LCMGET(IPGEO,NAMREC,MIXC(1,1,1)) + CALL LCMGET(IPGEO,NAMMRG,MIXC(1,2,1)) + IMTN=0 + DO 20 IZ=1,NZ + DO 21 IY=1,NY + DO 22 IX=1,NX + DO 23 IR=1,NRM + IMTN=IMTN+1 + IMTO=(IX-1)*NY*NZ*NRM + > +(IZ-1)*NY*NRM + > +(IY-1)*NRM+IR + MIX(IMTN,1)=MIXC(IMTO,1,1) + MIX(IMTN,2)=MIXC(IMTO,2,1) + 23 CONTINUE + 22 CONTINUE + 21 CONTINUE + 20 CONTINUE + ELSE IF(ITYPG .EQ. 11 .OR. ITYPG .EQ. 22) THEN +*---- +* TUBEY and CARCELY +*---- + IF(ITYPG .EQ.22) THEN + NRM=NR+1 + NSUR=2*(NX*NY+NY*NZ+NZ*NX*NRM) + NRMS=NRS+1 + NSURS=2*(NXS*NYS+NYS*NZS+NZS*NXS*NRMS) + ELSE + NRM=NR + NSUR=NY+2*NZ*NX*NRM + NRMS=NRS + NSURS=NYS+2*NZS*NXS*NRMS + ENDIF +*---- +* For CARCELX reorder mixtures from $(R,Z,X,Y)$ to $(R,X,Y,Z)$ +*---- + IF(ILCMLN .LT. NZ*NY*NX*NRM) THEN + WRITE(IOUT,9000) NAMSBR,ILCMLN,NZ*NY*NX*NRM + CALL XABORT(NAMSBR// + > ': Invalid number of mixtures provided') + ENDIF + CALL LCMGET(IPGEO,NAMREC,MIXC(1,1,1)) + CALL LCMGET(IPGEO,NAMMRG,MIXC(1,2,1)) + IMTN=0 + DO 30 IZ=1,NZ + DO 31 IY=1,NY + DO 32 IX=1,NX + DO 33 IR=1,NRM + IMTN=IMTN+1 + IMTO=(IY-1)*NZ*NX*NRM + > +(IX-1)*NZ*NRM + > +(IZ-1)*NRM+IR + MIX(IMTN,1)=MIXC(IMTO,1,1) + MIX(IMTN,2)=MIXC(IMTO,2,1) + 33 CONTINUE + 32 CONTINUE + 31 CONTINUE + 30 CONTINUE + ELSE IF(ITYPG .EQ. 8) THEN +*---- +* HEX +*---- + NRM=1 + NSUR=6 + NRMS=1 + NSURS=6 + IF(ILCMLN .LT. 1) THEN + WRITE(IOUT,9000) NAMSBR,ILCMLN,1 + CALL XABORT(NAMSBR// + > ': Invalid number of mixtures provided') + ENDIF + CALL LCMGET(IPGEO,NAMREC,MIX(1,1)) + CALL LCMGET(IPGEO,NAMMRG,MIX(1,2)) + ELSE IF(ITYPG .EQ. 9) THEN +*---- +* HEXZ +*---- + NRM=1 + NSUR=6*NZ+2 + NRMS=1 + NSURS=6*NX+2 + IF(ILCMLN .LT. NZ) THEN + WRITE(IOUT,9000) NAMSBR,ILCMLN,NZ + CALL XABORT(NAMSBR// + > ': Invalid number of mixtures provided') + ENDIF + ELSE IF(ITYPG .EQ. 12) THEN +*---- +* HEXT +*---- + NRM=1 + NSUR=6*(2*NX-1) + NRMS=1 + NSURS=6*(2*NXS-1) + IF(ILCMLN .LT. 6*NX*NX) THEN + WRITE(IOUT,9000) NAMSBR,ILCMLN,6*NX*NX + CALL XABORT(NAMSBR// + > ': Invalid number of mixtures provided') + ENDIF + CALL LCMGET(IPGEO,NAMREC,MIX(1,1)) + CALL LCMGET(IPGEO,NAMMRG,MIX(1,2)) + ELSE IF(ITYPG .EQ. 13) THEN +*---- +* HEXTZ +*---- + NRM=1 + NSUR=6*(2*NX-1)*NZ+12*NX*NX + NRMS=1 + NSURS=6*(2*NXS-1)*NZS+12*NXS*NXS + IF(ILCMLN .LT. 6*NX*NX*NZ) THEN + WRITE(IOUT,9000) NAMSBR,ILCMLN,6*NX*NX*NZ + CALL XABORT(NAMSBR// + > ': Invalid number of mixtures provided') + ENDIF + CALL LCMGET(IPGEO,NAMREC,MIX(1,1)) + CALL LCMGET(IPGEO,NAMMRG,MIX(1,2)) + ELSE IF(ITYPG .EQ. 26) THEN +*---- +* HEXTCEL +*---- + NRM=NR+1 + NSUR=6*(2*NX-1) + NRMS=NRS+1 + NSURS=6*(2*NXS-1) + IF(ILCMLN .LT. 6*NX*NX*NRM) THEN + WRITE(IOUT,9000) NAMSBR,ILCMLN,6*NX*NX*NRM + CALL XABORT(NAMSBR// + > ': Invalid number of mixtures provided') + ENDIF + CALL LCMGET(IPGEO,NAMREC,MIX(1,1)) + CALL LCMGET(IPGEO,NAMMRG,MIX(1,2)) + ELSE IF(ITYPG .EQ. 27) THEN +*---- +* HEXTCELZ +*---- + NRM=NR+1 + NSUR=6*(2*NX-1)*NZ+12*NX*NX*NRM + NRMS=NRS+1 + NSURS=6*(2*NXS-1)*NZS+12*NXS*NXS*NRMS + IF(ILCMLN .LT. 6*NX*NX*NZ*NRM) THEN + WRITE(IOUT,9000) NAMSBR,ILCMLN,6*NX*NX*NZ*NRM + CALL XABORT(NAMSBR// + > ': Invalid number of mixtures provided') + ENDIF + CALL LCMGET(IPGEO,NAMREC,MIX(1,1)) + CALL LCMGET(IPGEO,NAMMRG,MIX(1,2)) + ELSE + CALL XABORT(NAMSBR// + > ': Geometry type invalid for cell or pin') + ENDIF + ENDIF + IF(ITYPG .EQ. 12 .OR. ITYPG .EQ. 13 .OR. + > ITYPG .EQ. 26 .OR. ITYPG .EQ. 27) THEN + NREG=6*NX*NX*NZ*NRM + NREGS=6*NXS*NXS*NZS*NRMS + MAXMSS=MAX(NRMS,2*(NXS+1),2*(NYS+1),NZS,MAXMSH)+1 + ELSE + NREG=NRM*NX*NY*NZ + NREGS=NRMS*NXS*NYS*NZS + MAXMSS=MAX(NRMS,NXS,NYS,NZS,MAXMSH)+1 + ENDIF +*---- +* Print mesh if required +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6011) 'MIX =' + WRITE(IOUT,6013) (MIX(IX,1),IX=1,NMIX) + WRITE(IOUT,6011) 'HMIX =' + WRITE(IOUT,6013) (MIX(IX,2),IX=1,NMIX) + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* Processing finished: +* print routine closing output header if required +* and return +*---- + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(1X,'Geometry type =',I10/ + > 1X,'Original mesh dimensions ='/ + > 4(1X,A1,'=',1X,I8)/ + > 1X,'Number of regions =',i8) + 6011 FORMAT(1X,A7) + 6012 FORMAT(5F15.9) + 6013 FORMAT(5I15) + 6015 FORMAT(1X,'Geometry type =',I10/ + > 1X,'Original hexagonal mesh dimensions =',I10,/ + > 1X,'Original z mesh dimensions =',I10,/ + > 1X,'Number of regions =',i8) + 8000 FORMAT(' ***** Warning in ',A6,' *****'/ + > ' HMIX not compatible with MIX '/ + > ' HMIX mixture are replaced by MIX mixtures' ) + 9000 FORMAT(' ***** Error in ',A6,' *****'/ + > ' Number of mixtures provided = ',I10/ + > ' Number of mixtures required = ',I10) + END diff --git a/Dragon/src/NXTETH.f b/Dragon/src/NXTETH.f new file mode 100644 index 0000000..ca3aa83 --- /dev/null +++ b/Dragon/src/NXTETH.f @@ -0,0 +1,198 @@ +*DECK NXTETH + SUBROUTINE NXTETH(IPRINT,IDT ,ILEV ,NFSUR ,MAXMSP, + > NS1 ,NR1 ,NS2 ,NR2 ,IEDIMG,DAMESH, + > IX1 ,ID1 ,SV1 ,IX2 ,ID2 ,SV2 , + > MATRT ,NBSD ,NBST ) +* +*---------- +* +*Purpose: +* To built equivalent surface array for translational symmetry. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau. +* +*Parameters: input +* IPRINT print level. +* IDT translation direction. +* ILEV geometry level. +* NFSUR final number of surfaces. +* MAXMSP maximum number of elements in MESH array. +* NS1 maximum number of surfaces in splitted geometry 1. +* NR1 maximum number of regions in splitted geometry 1. +* NS2 maximum number of surfaces in splitted geometry 2. +* NR2 maximum number of regions in splitted geometry 2. +* IEDIMG geometries state vector. +* DAMESH final mesh description for geometry. +* IX1 local indexing of surfaces/regions for geometry 1. +* ID1 surface identifier after symmetry for geometry 1. +* SV1 area/volume of regions for geometry 1. +* IX2 local indexing of surfaces/regions for geometry 2. +* ID2 surface identifier after symmetry for geometry 2. +* SV2 area/volume of regions for geometry 2. +* +*Parameters: output +* MATRT reflection/transmission surface coupling array. +* NBSD number of direct surfaces considered. +* NBST number of translated surfaces found. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---------- +* + IMPLICIT NONE + INTEGER NSTATE + PARAMETER (NSTATE=40) +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,IDT,ILEV,NFSUR,MAXMSP,NS1,NR1,NS2,NR2, + > IEDIMG(NSTATE,2) + DOUBLE PRECISION DAMESH(-1:MAXMSP,4,2) + INTEGER IX1(5,-NS1:NR1),ID1(NS1) + DOUBLE PRECISION SV1(-NS1:NR1) + INTEGER IX2(5,-NS2:NR2),ID2(NS2) + DOUBLE PRECISION SV2(-NS2:NR2) + INTEGER MATRT(NFSUR),NBSD,NBST +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTETH') +*---- +* Local variables +*---- + INTEGER ISVD,ISVT, + > ISD,IST,IPU,IPV,IPW,IDIR + DOUBLE PRECISION D1B,D1T,D2B,D2T +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6010) ILEV + ENDIF +*---- +* Assume mesh in U, V and W identical and stored in element 1 +* of DAMESH +*---- + IDIR=1 + IF(IDT .EQ. 3) THEN +*---- +* Scan for bottom surfaces +*---- + DO ISVD=1,IEDIMG(9,1) + IF(IX1(IDT,-ISVD) .EQ. -1) THEN + NBSD=NBSD+1 +*---- +* This surface in the good direction +*---- + ISD=ID1(ISVD) + IF(ISD .GT. 0) THEN +*---- +* This is an external surface/locate mesh position +*---- + IPU=IX1(1,-ISVD) + IPV=IX1(2,-ISVD) + IPW=IX1(4,-ISVD) +*---- +* Scan IX2 for top surfaces +*---- + DO ISVT=1,IEDIMG(9,2) + IF(IX2(IDT,-ISVT) .EQ. -2) THEN + IST=ID2(ISVT) + IF(IST .GT. 0) THEN +*---- +* This is an external surface +* test if mesh position is compatible with +* direct geometry +*---- + IF(IPU .EQ. IX2(1,-ISVT) .AND. + > IPV .EQ. IX2(2,-ISVT) .AND. + > IPW .EQ. IX2(4,-ISVT) ) THEN +*---- +* This should be the translated surface we are seeking +* Test if area and dimensions are compatible +*---- + IF(SV1(-ISVD) .NE. SV2(-ISVT)) + >CALL XABORT(NAMSBR//': Translated surfaces are invalid') + IF(IPU .GT. 0) THEN + D1B=DAMESH(IPU-1,IDIR,1)-DAMESH(0,IDIR,1) + D1T=DAMESH(IPU,IDIR,1)-DAMESH(0,IDIR,1) + D2B=DAMESH(IPU-1,IDIR,2)-DAMESH(0,IDIR,2) + D2T=DAMESH(IPU,IDIR,2)-DAMESH(0,IDIR,2) + IF(D1B .NE. D2B .AND. D1T .NE. D2T) + >CALL XABORT(NAMSBR//': U mesh for translation is invalid') + ENDIF + IF(IPV .GT. 0) THEN + D1B=DAMESH(IPV-1,IDIR,1)-DAMESH(0,IDIR,1) + D1T=DAMESH(IPV,IDIR,1)-DAMESH(0,IDIR,1) + D2B=DAMESH(IPV-1,IDIR,2)-DAMESH(0,IDIR,2) + D2T=DAMESH(IPV,IDIR,2)-DAMESH(0,IDIR,2) + IF(D1B .NE. D2B .AND. D1T .NE. D2T) + >CALL XABORT(NAMSBR//': V mesh for translation is invalid') + ENDIF + IF(IPW .GT. 0) THEN + D1B=DAMESH(IPW-1,IDIR,1)-DAMESH(0,IDIR,1) + D1T=DAMESH(IPW,IDIR,1)-DAMESH(0,IDIR,1) + D2B=DAMESH(IPW-1,IDIR,2)-DAMESH(0,IDIR,2) + D2T=DAMESH(IPW,IDIR,2)-DAMESH(0,IDIR,2) + IF(D1B .NE. D2B .AND. D1T .NE. D2T) + >CALL XABORT(NAMSBR//': W mesh for translation is invalid') + ENDIF +*---- +* Everything seems all right +* couple surfaces +*---- + NBST=NBST+1 + MATRT(ISD)=IST + MATRT(IST)=ISD + GO TO 105 + ENDIF + ENDIF + ENDIF + ENDDO +*---- +* Could not find translated surface +*---- + WRITE(IOUT,9000) ISD + 105 CONTINUE + ENDIF + ENDIF + ENDDO + ELSE + CALL XABORT(NAMSBR//': Translation BC for hexagonal faces '// + >'not programmed yet ') + ENDIF +*---- +* Processing finished: +* print routine closing output header if required +* and return +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT('Geometry level = ',I5) + 9000 FORMAT(' ***** Warning ***** '/ + > ' Translated surface for ',I5,1X,'is absent') + END diff --git a/Dragon/src/NXTETS.f b/Dragon/src/NXTETS.f new file mode 100644 index 0000000..dfb7943 --- /dev/null +++ b/Dragon/src/NXTETS.f @@ -0,0 +1,209 @@ +*DECK NXTETS + SUBROUTINE NXTETS(IPRINT,IDT ,ILEV ,NFSUR ,MAXMSP, + > NS1 ,NR1 ,NS2 ,NR2 ,IEDIMG,DAMESH, + > IX1 ,ID1 ,SV1 ,IX2 ,ID2 ,SV2 , + > MATRT ,NBSD ,NBST ) +* +*---------- +* +*Purpose: +* To built equivalent surface array for translational symmetry. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau. +* +*Parameters: input +* IPRINT print level. +* IDT translation direction. +* ILEV geometry level. +* NFSUR final number of surfaces. +* MAXMSP maximum number of elements in MESH array. +* NS1 maximum number of surfaces in splitted geometry 1. +* NR1 maximum number of regions in splitted geometry 1. +* NS2 maximum number of surfaces in splitted geometry 2. +* NR2 maximum number of regions in splitted geometry 2. +* IEDIMG geometries state vector. +* DAMESH final mesh description for geometry. +* IX1 local indexing of surfaces/regions for geometry 1. +* ID1 surface identifier after symmetry for geometry 1. +* SV1 area/volume of regions for geometry 1. +* IX2 local indexing of surfaces/regions for geometry 2. +* ID2 surface identifier after symmetry for geometry 2. +* SV2 area/volume of regions for geometry 2. +* +*Parameters: output +* MATRT reflection/transmission surface coupling array. +* NBSD number of direct surfaces considered. +* NBST number of translated surfaces found. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---------- +* + IMPLICIT NONE + INTEGER NSTATE + PARAMETER (NSTATE=40) +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,IDT,ILEV,NFSUR,MAXMSP,NS1,NR1,NS2,NR2, + > IEDIMG(NSTATE,2) + DOUBLE PRECISION DAMESH(-1:MAXMSP,4,2) + INTEGER IX1(5,-NS1:NR1),ID1(NS1) + DOUBLE PRECISION SV1(-NS1:NR1) + INTEGER IX2(5,-NS2:NR2),ID2(NS2) + DOUBLE PRECISION SV2(-NS2:NR2) + INTEGER MATRT(NFSUR),NBSD,NBST +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTETS') +*---- +* Local variables +*---- + INTEGER IDP1,IDP2,IDPR,IGT,ISVD,ISVT, + > ISD,IST,IP1,IP2,IPR,KLEV + DOUBLE PRECISION D1B,D1T,D2B,D2T +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF +*---- +* Scan IX1 for bottom surfaces +*---- + IDP1=MOD(IDT,3)+1 + IDP2=MOD(IDT+1,3)+1 + IDPR=4 + IGT=2 + NBSD=0 + NBST=0 + KLEV=ILEV + DO ISVD=1,IEDIMG(9,1) + IF(IX1(IDT,-ISVD) .EQ. -1) THEN + NBSD=NBSD+1 +*---- +* This surface in the good direction +*---- + ISD=ID1(ISVD) + IF(ISD .GT. 0) THEN +*---- +* This is an external surface/locate mesh position +*---- + IP1=IX1(IDP1,-ISVD) + IP2=IX1(IDP2,-ISVD) + IPR=IX1(IDPR,-ISVD) +*---- +* Scan IX2 for top surfaces +*---- + DO ISVT=1,IEDIMG(9,2) + IF(IX2(IDT,-ISVT) .EQ. -2) THEN + IST=ID2(ISVT) + IF(IST .GT. 0) THEN +*---- +* This is an external surface +* test if mesh position is compatible with +* direct geometry +*---- + IF(IP1 .EQ. IX2(IDP1,-ISVT) .AND. + > IP2 .EQ. IX2(IDP2,-ISVT) .AND. + > IPR .EQ. IX2(IDPR,-ISVT) ) THEN +*---- +* This should be the translated surface we are seeking +* Test if area and dimensions are compatible +*---- + IF(SV1(-ISVD) .NE. SV2(-ISVT)) + >CALL XABORT(NAMSBR//': Translated surfaces are invalid') + IF(IP1 .GT. 0) THEN + D1B=DAMESH(IP1-1,IDP1,1)-DAMESH(0,IDP1,1) + D1T=DAMESH(IP1,IDP1,1)-DAMESH(0,IDP1,1) + D2B=DAMESH(IP1-1,IDP1,2)-DAMESH(0,IDP1,2) + D2T=DAMESH(IP1,IDP1,2)-DAMESH(0,IDP1,2) + IF(D1B .NE. D2B .AND. D1T .NE. D2T) THEN + WRITE(IOUT,9001) D1B,D1T,D2B,D2T, + > 50.D0*(D1B-D2B)/(D1B+D2B), + > 50.D0*(D1T-D2T)/(D1T+D2T) + CALL XABORT(NAMSBR// + > ': First mesh for translation is invalid') + ENDIF + ENDIF + IF(IP2 .GT. 0) THEN + D1B=DAMESH(IP2-1,IDP2,1)-DAMESH(0,IDP2,1) + D1T=DAMESH(IP2,IDP2,1)-DAMESH(0,IDP2,1) + D2B=DAMESH(IP2-1,IDP2,2)-DAMESH(0,IDP2,2) + D2T=DAMESH(IP2,IDP2,2)-DAMESH(0,IDP2,2) + IF(D1B .NE. D2B .AND. D1T .NE. D2T) THEN + WRITE(IOUT,9001) D1B,D1T,D2B,D2T, + > 50.D0*(D1B-D2B)/(D1B+D2B), + > 50.D0*(D1T-D2T)/(D1T+D2T) + CALL XABORT(NAMSBR// + > ': Second mesh for translation is invalid') + ENDIF + ENDIF + IF(IPR .GT. 0) THEN + D1B=DAMESH(IPR-1,IDPR,1) + D1T=DAMESH(IPR,IDPR,1) + D2B=DAMESH(IPR-1,IDPR,2) + D2T=DAMESH(IPR,IDPR,2) + IF(D1B .NE. D2B .AND. D1T .NE. D2T) THEN + WRITE(IOUT,9001) D1B,D1T,D2B,D2T, + > 50.D0*(D1B-D2B)/(D1B+D2B), + > 50.D0*(D1T-D2T)/(D1T+D2T) + CALL XABORT(NAMSBR// + > ': Radial mesh for translation is invalid') + ENDIF + ENDIF +*---- +* Everything seems all right +* couple surfaces +*---- + NBST=NBST+1 + MATRT(ISD)=IST + MATRT(IST)=ISD + GO TO 105 + ENDIF + ENDIF + ENDIF + ENDDO +*---- +* Could not find translated surface +*---- + WRITE(IOUT,9000) ISD + 105 CONTINUE + ENDIF + ENDIF + ENDDO +*---- +* Processing finished: +* print routine closing output header if required +* and return +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 9000 FORMAT(' ***** Warning ***** '/ + > ' Translated surface for ',I5,1X,'is absent') + 9001 FORMAT(6F20.10) + END diff --git a/Dragon/src/NXTFID.f b/Dragon/src/NXTFID.f new file mode 100644 index 0000000..ff0a87d --- /dev/null +++ b/Dragon/src/NXTFID.f @@ -0,0 +1,93 @@ +*DECK NXTFID + SUBROUTINE NXTFID(IX,IY,IZ,NSURC,NREGC,MESHCZ,IMX,IMY,IMR,INDEX, + 1 IDSUR,IDREG,IDZ,ITYP) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Locate all the regions/surfaces within a cell/pin corresponding +* to a certain x, y and r position along the projection axis. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IX first direction perpendicular to the projection axis. +* IY second direction perpendicular to the projection axis. +* IZ projection axis. +* NSURC number of surfaces for the cells/pins. +* NREGC number of regions for the cells/pins. +* MESHCZ number of meshes along the projection axis. +* IMX x index to locate. +* IMY y index to locate. +* IMR r index to locate. +* INDEX cell/pin index vector. +* IDSUR surface index array. +* IDREG region index array. +* +*Parameters: output +* IDZ regions/surfaces encountered along the projection axis. +* ITYP flag for "what was encountered?": +* = 0 non existing IMX,IMY,IMR combination; +* = 1 non-vanishing top/bottom surfaces and regions; +* = 2 vanishing region; +* =-1 non-vanishing lateral surface; +* =-2 vanishing lateral surface. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IX,IY,IZ,NSURC,NREGC,MESHCZ,IMX,IMY,IMR, + 1 INDEX(5,-NSURC:NREGC),IDSUR(NSURC),IDREG(NREGC),IDZ(0:MESHCZ+1), + 2 ITYP +*---- +* LOCAL VARIABLES +*---- + INTEGER II,IND +* + ITYP=0 + DO II=-NSURC,-1 +* surfaces + IF ((INDEX(IX,II).EQ.IMX).AND. + 1 (INDEX(IY,II).EQ.IMY).AND. + 2 (INDEX( 4,II).EQ.IMR)) THEN + IND=INDEX(IZ,II) + IF (IND.EQ.-1) THEN +* a top surface + IDZ(0)=-ABS(IDSUR(-II)) + IF (IDZ(0).NE.0) ITYP=1 + ELSEIF(IND.EQ.-2) THEN +* a bottom surface + IDZ(MESHCZ+1)=-ABS(IDSUR(-II)) + IF (IDZ(MESHCZ+1).NE.0) ITYP=1 + ELSE +* a lateral surface + IDZ(IND)=-ABS(IDSUR(-II)) + ITYP=-2 + IF (IDZ(IND).NE.0) ITYP=-1 + ENDIF + ENDIF + ENDDO + DO II=1,NREGC +* regions + IF ((INDEX(IX,II).EQ.IMX).AND. + 1 (INDEX(IY,II).EQ.IMY).AND. + 2 (INDEX( 4,II).EQ.IMR)) THEN + IND=INDEX(IZ,II) + IDZ(IND)=ABS(IDREG(II)) + ITYP=2 + IF (IDZ(IND).NE.0) ITYP=1 + ENDIF + ENDDO +* + RETURN + END diff --git a/Dragon/src/NXTGET.f b/Dragon/src/NXTGET.f new file mode 100644 index 0000000..2546f80 --- /dev/null +++ b/Dragon/src/NXTGET.f @@ -0,0 +1,422 @@ +*DECK NXTGET + SUBROUTINE NXTGET(NSTATE,IPRINT,TITLE,ISTATU,RSTATU,NBSLIN,IQUA10, + > IBIHET) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To read from the input file the NXT: module processing options. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* NSTATE dimensions of tracking state vectors. +* +*Parameters: input/output +* IPRINT print level. +* TITLE execution title. +* ISTATU integer parameters for tracking: +* ISTATU( 1) is the number of regions; +* ISTATU( 2) is the number of unknown; +* ISTATU( 3) is the leakage flag; +* ISTATU( 4) is the maximum number of mixture used; +* ISTATU( 5) is the number of outer surfaces; +* ISTATU( 6) is the flux anisotropy order; +* ISTATU( 7) is the solution method used; +* ISTATU( 8) is the track normalization option; +* ISTATU( 9) is the type of tracks considered; +* ISTATU(10) is the CP calculation option; +* ISTATU(11) is the azimuthal quadrature level; +* ISTATU(12) is the symmetry option; +* ISTATU(13) is the polar quadrature type; +* ISTATU(14) is the polar quadrature level; +* ISTATU(15) is the azimuthal quadrature type; +* ISTATU(16) is the number of dimensions; +* ISTATU(17) is the number of tracking points per line; +* ISTATU(18) is the maximum length of a track; +* ISTATU(19) is the total number of tracks; +* ISTATU(20) is the number of tracks directions; +* ISTATU(21) line format (by default a short +* format is considered but the complete format for TLM: +* can be generated using the keyword LONG); +* ISTATU(22) is the vectorization option; +* ISTATU(23) is the tracking flag (-1 MC; 0 NOTR; +* 1 tracking available). +* ISTATU(26) is the MERGE flag (0 no merge; 1 MERGMIX). +* ISTATU(27) is the number of tracks assigned to a OpenMP core. +* RSTATU real parameters for tracking: +* RSTATU( 1) is the track length cutoff for +* exponential functions; +* RSTATU( 2) is the 1D line or 2D plane +* quadrature line density; +* RSTATU( 3) is the corner identification cutoff; +* RSTATU( 4) is the axial quadrature line density; +* RSTATU( 5) contains the linear track spacing +* for general 2--D geometry and for 3--D Cartesian and +* geometries; +* RSTATU( 6) is the $X$ cell center; +* RSTATU( 7) is the $y$ cell center; +* RSTATU( 8) is the $Z$ cell center; +* RSTATU(11) is the spatial cutoff factor for tracking; +* RSTATU(12) is the stopping criterion for flux-current +* iterations of the interface current method; +* RSTATU(39) is the minimum volume fraction of the +* grain in the representative volume for She-Liu-Shi +* model. +* NBSLIN maximum number of segments in a single tracking line +* (computed by default in NXTTCG but limited to 100000 +* elements). This default value can be bypassed using +* keyword NBSLIN. +* IQUA10 quadrature parameter for micro-structures in Bihet. +* IBIHET type of double-heterogeneity method (=1 Sanchez-Pomraning +* model; =2 Hebert model; =3 She-Liu-Shi model (no shadow); +* =4 She-Liu-Shi model (with shadow)). +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*Comments: +* Input data is of the form: +* [ EDIT iprint ] +* [ TITLE trackt ] +* [ NBSLIN nbslin ] +* [ ANIS nanis ] +* [ { RENO | REND | NORE } ] +* [ { PISO | PSPC } ] +* [ { PRIX | PRIY | PRIZ } denspr ] +* [ { GAUS | CACA | CACB | LCMD | OPP1 | OGAU } npol ] +* [ { TISO [ { EQW | PNTN | SMS | GAUS | LSN | QRN } ] +* nangl dens [ densz ] | +* TSPC [ EQW | MEDI | EQW2 ] nangl dens [ densz ] } ] +* [ CORN cutofc ] +* [ CUT cutofx ] +* [ { SYMM isymm | NOSY } ] +* [ { NOTR | MC } ] +* [ MERGMIX ] +* [ BATCH nbatch ] +* [ { IC | NOIC } ] [ EPSJ epsj ] +* [ [ QUAB iqua10 ] [ { SAPO | HEBE | SLSI [frtm] | SLSS [frtm] } ] ] +* with frtm minimum volume fraction of the grain in the +* representative volume for She-Liu-Shi model. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NSTATE + INTEGER IPRINT,IQUA10,IBIHET + CHARACTER TITLE*72 + INTEGER ISTATU(NSTATE) + REAL RSTATU(NSTATE) + INTEGER NBSLIN +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTGET') +*---- +* Variables for input via REDGET +*---- + INTEGER ITYPLU,INTLIR + CHARACTER CARLIR*72 + REAL REALIR + DOUBLE PRECISION DBLLIR +*---- +* Local variables +*---- + INTEGER IRT,IRMXR,NBATCH + REAL EPSJ +*---- +* Initialize default values for IPRINT +*---- + IPRINT=1 + IRT=0 + IRMXR=0 + NBATCH=1 + IBIHET=2 + IQUA10=5 + EPSJ=0.5E-5 +*---- +* Get data from input file +*---- + 100 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + 101 CONTINUE + IF(ITYPLU .EQ. 10) GO TO 105 + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + >': Read error -- Character variable expected') + IF(CARLIR(1:4) .EQ. ';') THEN + GO TO 105 + ELSE IF(CARLIR(1:4) .EQ. 'EDIT') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': Read error -- print level expected after EDIT.') + IPRINT=INTLIR + ELSE IF(CARLIR(1:4) .EQ. 'TITL') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + > ': Read error -- title expected after TITL.') + TITLE=CARLIR + ELSE IF(CARLIR(1:4) .EQ. 'ANIS') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': Read error -- anisotropy level expected after ANIS.') + IF(INTLIR .LE. 0) WRITE(IOUT,9000) NAMSBR + ISTATU(6)=MAX(ISTATU(6),INTLIR) + ELSE IF(CARLIR(1:4) .EQ. 'RENO') THEN + ISTATU(8)=0 + ELSE IF(CARLIR(1:4) .EQ. 'REND') THEN + ISTATU(8)=-1 + ELSE IF(CARLIR(1:4) .EQ. 'NORE') THEN + ISTATU(8)=1 + ELSE IF(CARLIR(1:4) .EQ. 'PISO') THEN + ISTATU(10)=0 + ELSE IF(CARLIR(1:4) .EQ. 'PSPC') THEN + ISTATU(10)=-1 + ELSE IF(CARLIR(1:3) .EQ. 'PRI') THEN + IF (CARLIR(4:4).EQ.'Z') THEN + ISTATU(39)=3 + ELSEIF (CARLIR(4:4).EQ.'Y') THEN + ISTATU(39)=2 + ELSEIF (CARLIR(4:4).EQ.'X') THEN + ISTATU(39)=1 + ELSE + CALL XABORT('NXTGET: INVALID PROJECTION AXIS FOR 3D PRISM.') + ENDIF + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.2) THEN + CALL XABORT('NXTGET: REAL DATA EXPECTED') + ELSE + RSTATU(40)=1.0/REALIR + IF (RSTATU(40).LT.0.0) + > CALL XABORT('NXTGET: DELU > 0.0 EXPECTED') + ENDIF + ELSEIF(CARLIR(1:4) .EQ. 'GAUS') THEN + ISTATU(13)=0 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF (ITYPLU.NE.1) GOTO 101 + ISTATU(14)=MAX(ISTATU(14),INTLIR) + ELSEIF(CARLIR(1:4) .EQ. 'CACA') THEN + ISTATU(13)=1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF (ITYPLU.NE.1) GOTO 101 + ISTATU(14)=MAX(ISTATU(14),INTLIR) + ELSEIF(CARLIR(1:4) .EQ. 'CACB') THEN + ISTATU(13)=2 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF (ITYPLU.NE.1) GOTO 101 + ISTATU(14)=MAX(ISTATU(14),INTLIR) + ELSEIF(CARLIR(1:4) .EQ. 'LCMD') THEN + ISTATU(13)=3 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF (ITYPLU.NE.1) GOTO 101 + ISTATU(14)=MAX(ISTATU(14),INTLIR) + ELSEIF(CARLIR(1:4) .EQ. 'OPP1') THEN + ISTATU(13)=4 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF (ITYPLU.NE.1) GOTO 101 + ISTATU(14)=MAX(ISTATU(14),INTLIR) + ELSEIF(CARLIR(1:4) .EQ. 'OGAU') THEN + ISTATU(13)=5 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF (ITYPLU.NE.1) GOTO 101 + ISTATU(14)=MAX(ISTATU(14),INTLIR) + ELSE IF(CARLIR(1:4) .EQ. 'TISO' .OR. + > CARLIR(1:4) .EQ. 'TSPC' ) THEN + ISTATU(9)=0 + IF(CARLIR(1:4) .EQ. 'TSPC') THEN + ISTATU(9)=1 + ISTATU(10)=-1 + ENDIF +*---- +* Azimuthal or 3-D quadrature type +*---- + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .EQ. 3) THEN + IF(CARLIR(1:4) .EQ. 'EQW') THEN + ISTATU(15)=1 + ELSE IF(CARLIR(1:4) .EQ. 'GAUS') THEN + ISTATU(15)=2 + ELSE IF(CARLIR(1:4) .EQ. 'MEDI') THEN + ISTATU(15)=3 + ELSE IF(CARLIR(1:4) .EQ. 'PNTN') THEN + ISTATU(15)=4 + ELSE IF(CARLIR(1:3) .EQ. 'SMS') THEN + ISTATU(15)=5 + ELSE IF(CARLIR(1:3) .EQ. 'LSN') THEN + ISTATU(15)=6 + ELSE IF(CARLIR(1:3) .EQ. 'QRN') THEN + ISTATU(15)=7 + ELSE IF(CARLIR(1:4) .EQ. 'EQW2') THEN + ISTATU(15)=8 + ELSE + CALL XABORT(NAMSBR//':'//CARLIR(1:4)// + > ' is an invalid azimuthal or 3D quadrature type') + ENDIF + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + ENDIF + IF(ITYPLU .EQ. 1) THEN + IF(INTLIR .LE. 0) WRITE(IOUT,9001) NAMSBR + ISTATU(11)=MAX(ISTATU(11),INTLIR) + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + ENDIF + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': Real density number expected') + RSTATU(2)=REALIR + IF(REALIR .LE. 0.0) THEN + WRITE(IOUT,9010) NAMSBR + RSTATU(2)=1.0 + ENDIF + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .EQ. 2) THEN + RSTATU(4)=REALIR + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(REALIR .LE. 0.0) THEN + WRITE(IOUT,9011) NAMSBR + RSTATU(4)=1.0 + ENDIF + ENDIF + GO TO 101 + ELSE IF(CARLIR(1:4) .EQ. 'CORN') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': Real value expected for CORN') + RSTATU(3)=REALIR + IF(REALIR .LT. 0.0) THEN + WRITE(IOUT,9012) NAMSBR + RSTATU(3)=0.0 + ENDIF + ELSE IF(CARLIR(1:4) .EQ. 'CUT') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': Real value expected for CUT') + RSTATU(1)=REALIR + IF(REALIR .LT. 0.0) THEN + WRITE(IOUT,9013) NAMSBR + RSTATU(1)=0.0 + ENDIF + ELSE IF(CARLIR(1:4) .EQ. 'SYMM') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': Integer value expected for SYMM') + ISTATU(12)=INTLIR + ELSE IF(CARLIR(1:4) .EQ. 'NOSY') THEN + ISTATU(12)=0 + ELSE IF(CARLIR(1:4) .EQ. 'NOTR') THEN + ISTATU(23)=0 + ELSE IF(CARLIR(1:2) .EQ. 'MC') THEN + ISTATU(23)=-1 + ELSE IF(CARLIR(1:4) .EQ. 'TRAK') THEN + IRT=1 + ELSE IF(CARLIR(1:4) .EQ. 'MAXR') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': Integer value expected for MAXR') + IRMXR=MAX(INTLIR,1) + ELSE IF(CARLIR .EQ. 'NBSLIN') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': Read error -- nbslin value expected.') + NBSLIN=MAX(INTLIR,NBSLIN) + ELSE IF(CARLIR(1:4) .EQ. 'SCFT') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': Real value expected for SCFT') + RSTATU(11)=REALIR + IF(REALIR .LT. 0.0) THEN + WRITE(IOUT,9012) NAMSBR + RSTATU(11)=1.0 + ENDIF + ELSE IF(CARLIR(1:4) .EQ. 'ONEG') THEN + ISTATU(22)=0 + ELSE IF(CARLIR(1:4) .EQ. 'ALLG') THEN + ISTATU(22)=1 + ELSE IF(CARLIR(1:4) .EQ. 'XCLL') THEN + ISTATU(22)=2 + ELSE IF(CARLIR(1:4) .EQ. 'QUAB') THEN + CALL REDGET(ITYPLU,IQUA10,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': Integer value expected for QUAB') + ELSE IF(CARLIR .EQ. 'LONG') THEN + ISTATU(21)=1 + ELSE IF(CARLIR .EQ. 'BATCH') THEN + ! number of tracks processed in each OpenMP core (default: =1). + CALL REDGET(ITYPLU,NBATCH,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': Integer value expected for BATCH') + ISTATU(27)=NBATCH + ELSE IF(CARLIR(1:4) .EQ. 'SAPO') THEN + IBIHET=1 + ELSE IF(CARLIR(1:4) .EQ. 'HEBE') THEN + IBIHET=2 + ELSE IF(CARLIR(1:4) .EQ. 'SLSI') THEN + IBIHET=3 + RSTATU(39)=0.05 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF (ITYPLU.NE.2) GOTO 101 + RSTATU(39)=REALIR + ELSE IF(CARLIR(1:4) .EQ. 'SLSS') THEN + IBIHET=4 + RSTATU(39)=0.05 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF (ITYPLU.NE.2) GOTO 101 + RSTATU(39)=REALIR + ELSE IF(CARLIR(1:7) .EQ. 'MERGMIX') THEN + ISTATU(26)=1 + ELSE IF(CARLIR(1:2) .EQ. 'IC') THEN + ISTATU(7)=5 + ELSE IF(CARLIR(1:4) .EQ. 'NOIC') THEN + ISTATU(7)=4 + ELSE IF(CARLIR(1:4) .EQ. 'EPSJ') THEN + CALL REDGET(ITYPLU,INTLIR,EPSJ,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': Real value expected for EPSJ') + RSTATU(12)=EPSJ + ELSE + CALL XABORT(NAMSBR//': Keyword '//TRIM(CARLIR)//' is invalid.') + ENDIF + GO TO 100 + 105 CONTINUE + IF( ISTATU(9) .EQ. 0) THEN + ISTATU(13)=0 + ENDIF +*---- +* Processing finished, return +*---- + IF(IRT .GT. 0) WRITE(IOUT,9020) NAMSBR + IF(IRMXR .GT. 0) WRITE(IOUT,9021) NAMSBR + RETURN +*---- +* Warning formats +*---- + 9000 FORMAT(1X,'Warning from ',A6,2X,'Invalid anisotropy level'/ + >1X,'Use default value : nanis=1') + 9001 FORMAT(1X,'Warning from ',A6,2X,'Invalid number of angles'/ + >1X,'Use default value : nangle=1') + 9010 FORMAT(1X,'Warning from ',A6,2X,'Invalid tracking density'/ + >1X,'Use default value : dens=1.0') + 9011 FORMAT(1X,'Warning from ',A6,2X,'Invalid axial tracking density'/ + >1X,'Use default value : densz=1.0') + 9012 FORMAT(1X,'Warning from ',A6,2X,'Invalid corner proximity'/ + >1X,'Use default value : pcorn=0.0') + 9013 FORMAT(1X,'Warning from ',A6,2X,'Invalid exponential cutoff'/ + >1X,'Use default value : cutofx=0.0') + 9020 FORMAT(1X,'Warning from ',A6,1X,'-- Keyword TRAK not used ', + >'by module NXT: but kept for compatibility with module EXCELT:') + 9021 FORMAT(1X,'Warning from ',A6,1X,'-- Keyword MAXR not used ', + >'by module NXT: but kept for compatibility with module EXCELT:') + END diff --git a/Dragon/src/NXTGMD.f b/Dragon/src/NXTGMD.f new file mode 100644 index 0000000..4713e81 --- /dev/null +++ b/Dragon/src/NXTGMD.f @@ -0,0 +1,556 @@ +*DECK NXTGMD + SUBROUTINE NXTGMD(IPGEO ,IPTRK ,IPRINT,ITYPBC,ILCELL,NEDIM, + > NBOCEL,NBUCEL,MAXCEL,NUCELL,IUNFLD, + > IEDIMG,NAGGEO,ITURN ,MERGE ,IDIRR , + > DCMESH,DGMESH) +* +*---------- +* +*Purpose: +* To obtain general dimension vector for geometry. +* To evaluate global mesh for assembly. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPGEO pointer to the GEOMETRY data structure. +* IPTRK pointer to the TRACKING data structure. +* IPRINT print level. +* ITYPBC type of boundary conditions where: +* ITYPBC=0 for geometry with all Cartesian boundaries; +* ITYPBC=1 for geometry with one annular boundary; +* ITYPBC=2 for geometry with one hexagonal boundary. +* ILCELL cell level. +* NEDIM number of elements for general dimension vector. +* NBOCEL number of cells in original geometry. +* NBUCEL number of cells in unfolded geometry. +* MAXCEL maximum number of elements in mesh vector for +* each directions. +* NUCELL number of cell after unfolding in +* $X$, $Y$ and $Z$ directions. +* IUNFLD array to identify the generating cell (IUNFLD(1,*)) +* and the rotation associated with this region in space. +* +*Parameters: input/output +* IEDIMG general dimension vector for problem where +* NAGGEO geometry names. +* ITURN geometry turns. +* MERGE geometry merge. +* IDIRR direction of cell (1 for XYZ, 2 for YZX and 3 for ZXY). +* Note: for CAR3D without pins IDIRR=1 +* for CAR3D with pins IDIRR specified by pins direction. +* DCMESH global mesh for each cell. +* DGMESH meshing vector for global geometry. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* \\\\ +* This routine is based on the XELDCL routine written by +* R. Roy for the EXCELT: module. It contains an additional +* level for cluster subgeometry analysis. +* +*---------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPGEO,IPTRK +* INTEGER IPGEO,IPTRK + INTEGER IPRINT,ITYPBC,ILCELL,NEDIM,NBOCEL,NBUCEL,MAXCEL, + > NUCELL(3),IUNFLD(2,NBUCEL) + INTEGER IEDIMG(NEDIM),NAGGEO(3,NBOCEL), + > ITURN(NBOCEL),MERGE(NBOCEL),IDIRR(NBOCEL) + DOUBLE PRECISION DCMESH(3,2,NBOCEL),DGMESH(0:MAXCEL,3) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTGMD') + INTEGER NSTATE + PARAMETER (NSTATE=40) + DOUBLE PRECISION DCUT + PARAMETER (DCUT=1.0D-6) +*---- +* Local variables +*---- + INTEGER ISTATG(NSTATE) + INTEGER NDIM,NSDIM,NCDIM,IDIRC + INTEGER MAXMSH,MAXREG,NBTCLS, + > MAXPIN,MAXMSP,MAXRSP,NBGCLS, + > NTPIN,NPIN,NBSP,NBRSP,NZU + INTEGER ITC,IDIR,ICEL,ICN,ISPL,ICLS, + > IX,IY,IZ,IPOS,INTRN,IRTRN + INTEGER ILCMLN,ILCMTY + CHARACTER NAMGG*12,NAMREC*12,NAMCL*12 + REAL OFFCEN(3) + DOUBLE PRECISION DRW(3),DNW(3) + REAL SIDEH + DOUBLE PRECISION ARGS + INTEGER IH,IR,IS,ISS,NCH,NCR,NCS,NSS,ISPLTH +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IGEN,ISPLT + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NAGCEL,NAGCLS + REAL, ALLOCATABLE, DIMENSION(:) :: RMESH,XMESH +*---- +* Data +*---- + CHARACTER CDIR(4)*1 + SAVE CDIR + DATA CDIR /'X','Y','Z','R'/ +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + NDIM=IEDIMG(1) + MAXMSH=IEDIMG(16) + MAXREG=1 + NBTCLS=0 + MAXPIN=0 + MAXMSP=0 + MAXRSP=0 + DGMESH(0:MAXCEL,:3)=0.0D0 + IF(ILCELL .EQ. 1) THEN + ALLOCATE(IGEN(NBOCEL),NAGCEL(3,NBOCEL)) + CALL LCMGET(IPGEO,'CELL',NAGCEL) + CALL LCMLEN(IPGEO,'MIX',ILCMLN,ILCMTY) + IF(ILCMLN .GT. 0) THEN + CALL LCMGET(IPGEO,'MIX',IGEN) + DO ICEL=1,NBOCEL + ICN=-IGEN(ICEL) + DO ITC=1,3 + NAGGEO(ITC,ICEL)=NAGCEL(ITC,ICN) + ENDDO + ENDDO + ELSE + CALL LCMGET(IPGEO,'GENERATING',IGEN) + DO ICEL=1,NBOCEL + ICN=IGEN(ICEL) + DO ITC=1,3 + NAGGEO(ITC,ICEL)=NAGCEL(ITC,ICN) + ENDDO + ENDDO + ENDIF + DEALLOCATE(NAGCEL,IGEN) + CALL LCMLEN(IPGEO,'TURN',ILCMLN,ILCMTY) + IF(ILCMLN .GT. 0) THEN + CALL LCMGET(IPGEO,'TURN',ITURN) + ELSE + ITURN(:NBOCEL)=1 + ENDIF + CALL LCMLEN(IPGEO,'MERGE',ILCMLN,ILCMTY) + IF(ILCMLN .GT. 0) THEN +*---- +* Treatment of MERGE not yet implemented +*---- + CALL XABORT(NAMSBR// + > ': the module NXT cannot process geometry MERGE option') +* CALL LCMGET(IPGEO,'MERGE',MERGE) + ELSE + DO ICEL=1,NBOCEL + MERGE(ICEL)=ICEL + ENDDO + ENDIF + ELSE + NAMGG=' ' + READ(NAMGG,'(3A4)') (NAGGEO(ITC,1),ITC=1,3) + ITURN(1)=1 + MERGE(1)=1 + ENDIF + DO ICEL=1,NBOCEL + IF(ILCELL .EQ. 1) THEN + WRITE(NAMGG,'(3A4)') (NAGGEO(ITC,ICEL),ITC=1,3) + CALL LCMSIX(IPGEO,NAMGG,1) + ENDIF + ISTATG(:NSTATE)=0 + CALL LCMGET(IPGEO,'STATE-VECTOR',ISTATG) + IRTRN=ITURN(ICEL) +*---- +* Find cell dimension and direction +* Default is CAR3D +*---- + IDIRR(ICEL)=0 + NSDIM=3 + IF(ISTATG(1) .EQ. 5 .OR. + > ISTATG(1) .EQ. 8 .OR. + > ISTATG(1) .EQ. 12 .OR. + > ISTATG(1) .EQ. 20 .OR. + > ISTATG(1) .EQ. 26 ) THEN + IDIRR(ICEL)=1 + NSDIM=2 + ELSE IF(ISTATG(1) .EQ. 21) THEN + IDIRR(ICEL)=2 + ELSE IF(ISTATG(1) .EQ. 22) THEN + IDIRR(ICEL)=3 + ELSE IF(ISTATG(1) .EQ. 23 .OR. + > ISTATG(1) .EQ. 27 ) THEN + IDIRR(ICEL)=1 + ENDIF + IF(NDIM .NE. NSDIM) CALL XABORT(NAMSBR// + > ': Geometry and sub-geometry must have the same dimensions') + IF(ISTATG(1) .EQ. 12 .OR. + > ISTATG(1) .EQ. 13 ) THEN + MAXMSH=MAX(MAXMSH,ISTATG(2),2*ISTATG(3)+1,ISTATG(5)) + MAXREG=MAX(MAXREG,6*ISTATG(3)*ISTATG(3)*MAX(ISTATG(5),1)) + ALLOCATE(ISPLT(MAXMSH)) + MAXMSP=2*ISTATG(3)+1 + NBRSP=6*ISTATG(3)*ISTATG(3) + NAMREC='SPLITH ' + CALL LCMLEN(IPGEO,NAMREC,ILCMLN,ILCMTY) + IF(ILCMLN .GT. 0) THEN + CALL LCMGET(IPGEO,NAMREC,ISPLTH) + ISPLTH=ISPLTH*ISTATG(3) + MAXMSP=MAX(2*ISPLTH+1,MAXMSP) + NBRSP=MAX(6*ISPLTH*ISPLTH,NBRSP) + ENDIF + IDIR=3 + NAMREC='SPLIT'//CDIR(IDIR)//' ' + CALL LCMLEN(IPGEO,NAMREC,ILCMLN,ILCMTY) + IF(ILCMLN .GT. 0) THEN + CALL LCMGET(IPGEO,NAMREC,ISPLT) + NBSP=0 + DO ISPL=1,ILCMLN + NBSP=NBSP+ABS(ISPLT(ISPL)) + ENDDO + ELSE + NBSP=MAX(ISTATG(5),1) + ENDIF + NBRSP=NBRSP*NBSP + MAXMSP=MAX(MAXMSP,NBSP+1) + MAXRSP=MAX(MAXRSP,NBRSP) + ELSE IF(ISTATG(1) .EQ. 26 .OR. + > ISTATG(1) .EQ. 27 ) THEN + MAXMSH=MAX(MAXMSH,ISTATG(2)+1,2*ISTATG(3)+1,ISTATG(5)) + MAXREG=MAX(MAXREG,(ISTATG(2)+1)*(6*ISTATG(3)*ISTATG(3)) + > *MAX(ISTATG(5),1)) + ALLOCATE(ISPLT(MAXMSH)) + MAXMSP=2*ISTATG(3)+1 + NBRSP=6*ISTATG(3)*ISTATG(3) + NAMREC='SPLITH ' + CALL LCMLEN(IPGEO,NAMREC,ILCMLN,ILCMTY) + IF(ILCMLN .GT. 0) THEN + CALL LCMGET(IPGEO,NAMREC,ISPLTH) + ISPLTH=ISPLTH*ISTATG(3) + MAXMSP=MAX(2*ISPLTH+1,MAXMSP) + NBRSP=MAX(6*ISPLTH*ISPLTH,NBRSP) + ENDIF + IDIR=3 + NAMREC='SPLIT'//CDIR(IDIR)//' ' + CALL LCMLEN(IPGEO,NAMREC,ILCMLN,ILCMTY) + IF(ILCMLN .GT. 0) THEN + CALL LCMGET(IPGEO,NAMREC,ISPLT) + NBSP=0 + DO ISPL=1,ILCMLN + NBSP=NBSP+ABS(ISPLT(ISPL)) + ENDDO + ELSE + NBSP=MAX(ISTATG(5),1) + ENDIF + NBRSP=(ISTATG(2)+1)*NBRSP*NBSP + MAXMSP=MAX(MAXMSP,NBSP+1) + MAXRSP=MAX(MAXRSP,NBRSP) + ELSE + MAXMSH=MAX(MAXMSH,ISTATG(2),ISTATG(3),ISTATG(4),ISTATG(5)) + MAXREG=MAX(MAXREG,(ISTATG(2)+1)* + > MAX(ISTATG(3),1)*MAX(ISTATG(4),1)*MAX(ISTATG(5),1)) + ALLOCATE(ISPLT(MAXMSH)) + NBRSP=1 + DO IDIR=1,4 + NAMREC='SPLIT'//CDIR(IDIR)//' ' + CALL LCMLEN(IPGEO,NAMREC,ILCMLN,ILCMTY) + IF(ILCMLN .GT. 0) THEN + CALL LCMGET(IPGEO,NAMREC,ISPLT) + NBSP=0 + DO ISPL=1,ILCMLN + NBSP=NBSP+ABS(ISPLT(ISPL)) + ENDDO +* NBRSP=NBRSP*(NBSP+1) + IF(IDIR .EQ. 4) THEN + NBRSP=NBRSP*(NBSP+1) + ELSE + NBRSP=NBRSP*NBSP + ENDIF + MAXMSP=MAX(MAXMSP,NBSP+1) + ENDIF + ENDDO + MAXRSP=MAX(MAXRSP,NBRSP) + ENDIF + DEALLOCATE(ISPLT) +*---- +* Get off center +*---- + INTRN=1 + OFFCEN(:3)=0.0 + CALL LCMLEN(IPGEO,'OFFCENTER ',ILCMLN,ILCMTY) + IF(ILCMLN .GT. 0) + > CALL LCMGET(IPGEO,'OFFCENTER ',OFFCEN) + DO IDIR=1,3 + DRW(IDIR)=OFFCEN(IDIR) + ENDDO + CALL NXTTRM(IRTRN,INTRN,DRW,DCMESH(1,2,ICEL)) + IF(ITYPBC .EQ. 2) THEN +*---- +* Get H mesh +*---- + ALLOCATE(RMESH(MAXMSH+1)) + CALL LCMGET(IPGEO,'SIDE ',SIDEH) + DRW(1)=DBLE(SIDEH) +*---- +* Get z-mesh +*---- + IDIR=3 + NAMREC='MESH'//CDIR(IDIR)//' ' + CALL LCMLEN(IPGEO,NAMREC,ILCMLN,ILCMTY) + IF(ILCMLN .GT. 0) THEN + CALL LCMGET(IPGEO,NAMREC,RMESH) + DRW(IDIR)=DBLE(RMESH(ILCMLN))-DBLE(RMESH(1)) + ENDIF + DEALLOCATE(RMESH) + CALL NXTTRM(IRTRN,INTRN,DRW,DCMESH(1,1,ICEL)) +*---- +* Fill DGMESH according to IUNFLD +*---- + IPOS=0 + NZU=MAX(NUCELL(3),1) + NCH=NUCELL(1) + ARGS=DBLE(12*NCH-3) + NCR=(NINT(SQRT(ARGS))+3)/6 + DO IZ=1,MAX(NUCELL(3),1) + IH=0 + DO IR=1,NCR + NCS=6 + NSS=MAX(1,IR-1) + IF(IR.EQ.1) NCS=1 + DO IS=1,NCS + DO ISS=1,NSS + IH=IH+1 + IPOS=IPOS+1 +*---- +* Locate crown (IR), sector (IS) and hexagon number in sector (ISS) +*---- + IF(IUNFLD(1,IPOS) .EQ. ICEL) THEN +*---- +* cell is located at this position +* Turn width according to symmetry +*---- + INTRN=IUNFLD(2,IPOS) + CALL NXTTRM(IRTRN,INTRN,DRW,DNW(1)) + IF(DGMESH(0,1) .EQ. 0.0D0) THEN + DGMESH(0,1)=DRW(1) + DGMESH(0,2)=DRW(1) + ELSE IF(ABS(DGMESH(0,1)-DRW(1)) .GT. DCUT) THEN + CALL XABORT(NAMSBR// + > ': H- Mesh in assembly is not uniform') + ENDIF + CALL NXTHCL(IPRINT,IR,IS,ISS,DRW(1), + > DGMESH(IH,1),DGMESH(IH,2)) + IF(DGMESH(IZ,3) .EQ. 0.0D0) THEN + DGMESH(IZ,3)=DNW(3) + ELSE IF(ABS(DGMESH(IZ,3)-DNW(3)) .GT. DCUT) THEN + CALL XABORT(NAMSBR// + > ': Z Mesh in assembly is not uniform') + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + ELSE +*---- +* Get Cartesian mesh +*---- + ALLOCATE(XMESH(MAXMSH+1)) + DO IDIR=1,3 + NAMREC='MESH'//CDIR(IDIR)//' ' + CALL LCMLEN(IPGEO,NAMREC,ILCMLN,ILCMTY) + IF(ILCMLN .GT. 0) THEN + CALL LCMGET(IPGEO,NAMREC,XMESH) + DRW(IDIR)=DBLE(XMESH(ILCMLN))-DBLE(XMESH(1)) + ENDIF + ENDDO + DEALLOCATE(XMESH) + CALL NXTTRM(IRTRN,INTRN,DRW,DCMESH(1,1,ICEL)) +*---- +* Fill DGMESH according to IUNFLD +*---- + IPOS=0 + NZU=MAX(NUCELL(3),1) + DO IZ=1,MAX(NUCELL(3),1) + DO IY=1,NUCELL(2) + DO IX=1,NUCELL(1) + IPOS=IPOS+1 + IF(IUNFLD(1,IPOS) .EQ. ICEL) THEN +*---- +* cell is located at this position +* Turn width according to symmetry +*---- + INTRN=IUNFLD(2,IPOS) + CALL NXTTRM(IRTRN,INTRN,DRW,DNW(1)) + IF(DGMESH(IX,1) .EQ. 0.0D0) THEN + DGMESH(IX,1)=DNW(1) + ELSE IF(ABS(DGMESH(IX,1)-DNW(1)) .GT. DCUT) THEN + CALL XABORT(NAMSBR// + > ': X Mesh in assembly is not uniform') + ENDIF + IF(DGMESH(IY,2) .EQ. 0.0D0) THEN + DGMESH(IY,2)=DNW(2) + ELSE IF(ABS(DGMESH(IY,2)-DNW(2)) .GT. DCUT) THEN + CALL XABORT(NAMSBR// + > ': Y Mesh in assembly is not uniform') + ENDIF + IF(DGMESH(IZ,3) .EQ. 0.0D0) THEN + DGMESH(IZ,3)=DNW(3) + ELSE IF(ABS(DGMESH(IZ,3)-DNW(3)) .GT. DCUT) THEN + CALL XABORT(NAMSBR// + > ': Z Mesh in assembly is not uniform') + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF + IF(ISTATG(13) .GT. 0) THEN + NBGCLS=ISTATG(13) + NBTCLS=NBTCLS+NBGCLS + ALLOCATE(NAGCLS(3,NBGCLS)) + CALL LCMGET(IPGEO,'CLUSTER',NAGCLS) + NTPIN=0 + DO ICLS=1,NBGCLS + WRITE(NAMCL,'(3A4)') (NAGCLS(ITC,ICLS),ITC=1,3) + CALL LCMSIX(IPGEO,NAMCL,1) + ISTATG(:NSTATE)=0 + CALL LCMGET(IPGEO,'STATE-VECTOR',ISTATG) +*---- +* Find cluster dimension and direction +*---- + IDIRC=1 + NCDIM=3 + IF(ISTATG(1) .EQ. 3) THEN + NCDIM=2 + ELSE IF(ISTATG(1) .EQ. 10) THEN + IDIRC=2 + ELSE IF(ISTATG(1) .EQ. 11) THEN + IDIRC=3 + ELSE IF(ISTATG(1) .EQ. 6) THEN + IDIRC=1 + ELSE + CALL XABORT(NAMSBR//': Invalid pin geometry'// + >' -- Only TUBE* permitted') + ENDIF + IF(NSDIM .NE. NCDIM) CALL XABORT(NAMSBR// + >': Sub-geometry and clusters must have the same dimensions') + IF(IDIRC .NE. IDIRR(ICEL)) THEN + IF(IDIRR(ICEL) .NE. 0) CALL XABORT(NAMSBR// + >': Pin and geometry direction are incompatible') + IDIRR(ICEL)=IDIRC + ENDIF + MAXMSH=MAX(MAXMSH,ISTATG(2),ISTATG(3),ISTATG(4),ISTATG(5)) + MAXREG=MAX(MAXREG,ISTATG(6)) + CALL LCMGET(IPGEO,'NPIN',NPIN) + NTPIN=NTPIN+NPIN + ALLOCATE(ISPLT(MAXMSH)) + NBRSP=1 + DO IDIR=1,4 + NAMREC='SPLIT'//CDIR(IDIR)//' ' + CALL LCMLEN(IPGEO,NAMREC,ILCMLN,ILCMTY) + IF(ILCMLN .GT. 0) THEN + CALL LCMGET(IPGEO,NAMREC,ISPLT) + NBSP=0 + DO ISPL=1,ILCMLN + NBSP=NBSP+ABS(ISPLT(ISPL)) + ENDDO + IF(IDIR .EQ. 4) THEN + NBRSP=NBRSP*(NBSP+1) + ELSE + NBRSP=NBRSP*NBSP + ENDIF + MAXMSP=MAX(MAXMSP,NBSP+1) + ENDIF + ENDDO + MAXRSP=MAX(MAXRSP,NBRSP) + DEALLOCATE(ISPLT) + CALL LCMSIX(IPGEO,NAMCL,2) + ENDDO + MAXPIN=MAX(MAXPIN,NTPIN) +*---- +* Now test if pin overlapp +*---- + CALL NXTTPO(IPGEO ,IPRINT,ITYPBC,NBGCLS,NTPIN ,MAXMSH,NCDIM , + > IDIRR(ICEL) ,DRW ,OFFCEN,NAGCLS) + DEALLOCATE(NAGCLS) + ENDIF + IF(IDIRR(ICEL) .EQ. 0) IDIRR(ICEL)=1 + IF(ILCELL .EQ. 1) THEN + CALL LCMSIX(IPGEO,NAMGG,2) + ENDIF + ENDDO + IEDIMG(16)=MAXMSH + IEDIMG(17)=MAXREG + IEDIMG(18)=NBTCLS + IEDIMG(19)=MAX(MAXPIN,1) + IEDIMG(20)=MAXMSP+1 + IEDIMG(21)=MAXRSP + IF(ITYPBC .EQ. 2) THEN + IF(NUCELL(1) .GT. 0) THEN + DO IDIR=1,2 + NAMREC='G00000001SM'//CDIR(IDIR) + CALL LCMPUT(IPTRK,NAMREC,(NUCELL(1)+1),4, + > DGMESH(0,IDIR)) + ENDDO + ENDIF + IDIR=3 + IF(NUCELL(IDIR) .GT. 0) THEN + DO IX=1,NUCELL(IDIR) + DGMESH(IX,IDIR)=DGMESH(IX-1,IDIR)+DGMESH(IX,IDIR) + ENDDO + NAMREC='G00000001SM'//CDIR(IDIR) + CALL LCMPUT(IPTRK,NAMREC,(NUCELL(IDIR)+1),4, + > DGMESH(0,IDIR)) + ENDIF + ELSE + DO IDIR=1,3 + IF(NUCELL(IDIR) .GT. 0) THEN + DO IX=1,NUCELL(IDIR) + DGMESH(IX,IDIR)=DGMESH(IX-1,IDIR)+DGMESH(IX,IDIR) + ENDDO + NAMREC='G00000001SM'//CDIR(IDIR) + CALL LCMPUT(IPTRK,NAMREC,(NUCELL(IDIR)+1),4, + > DGMESH(0,IDIR)) + ENDIF + ENDDO + ENDIF + CALL LCMPUT(IPTRK,'G00000001DIM',NEDIM,1,IEDIMG) +*---- +* Processing finished: +* print routine closing output header if required +* and return +*---- + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + END diff --git a/Dragon/src/NXTHCL.f b/Dragon/src/NXTHCL.f new file mode 100644 index 0000000..b360679 --- /dev/null +++ b/Dragon/src/NXTHCL.f @@ -0,0 +1,136 @@ +*DECK NXTHCL + SUBROUTINE NXTHCL(IPRINT,IR ,IS ,ISS , + > SIDEH ,XLOC ,YLOC ) +* +*---------- +* +*Purpose: +* Locate spatial position of hexagon in assembly of cells. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau. +* +*Parameters: input +* IPRINT print level. +* IR crown number. +* IS cell sector. +* ISS cell in sector. +* SIDEH hexagon width. +* +*Parameters: output +* XLOC X location of cell center in assembly. +* YLOC Y location of cell center in assembly. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,IR,IS,ISS + DOUBLE PRECISION SIDEH,XLOC,YLOC +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTHCL') + DOUBLE PRECISION DZERO,DONE,DHALF,DSQ3O2 + PARAMETER (DZERO=0.0D0,DONE=1.0D0, + > DHALF=0.5D0,DSQ3O2=0.86602540378444D0) +*---- +* Local variables +*---- + DOUBLE PRECISION SQ32H,H3O2,XLOCR,YLOCR +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6000) NAMSBR + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6010) IR,IS,ISS,SIDEH + ENDIF + ENDIF + SQ32H=SIDEH*DSQ3O2 + H3O2=3.0D0*DHALF*SIDEH + IF(IR.EQ.1) THEN + XLOC=DZERO + YLOC=DZERO + ELSE + XLOCR=SQ32H*(2.0D0*DBLE(IR-1)-DBLE(ISS-1)) + YLOCR=H3O2*DBLE(ISS-1) + IF(IS .EQ. 1) THEN +*---- +* No rotation +*---- + XLOC=XLOCR + YLOC=YLOCR + ELSE IF(IS .EQ. 2) THEN +*---- +* Rotate by Pi/3 +*---- + XLOC=DHALF*XLOCR-DSQ3O2*YLOCR + YLOC=DSQ3O2*XLOCR+DHALF*YLOCR + ELSE IF(IS .EQ. 3) THEN +*---- +* Rotate by 2*Pi/3 +*---- + XLOC=-DHALF*XLOCR-DSQ3O2*YLOCR + YLOC=DSQ3O2*XLOCR-DHALF*YLOCR + ELSE IF(IS .EQ. 4) THEN +*---- +* Rotate by Pi +*---- + XLOC=-XLOCR + YLOC=-YLOCR + ELSE IF(IS .EQ. 5) THEN +*---- +* Rotate by 4*Pi/3 +*---- + XLOC=-DHALF*XLOCR+DSQ3O2*YLOCR + YLOC=-DSQ3O2*XLOCR-DHALF*YLOCR + ELSE IF(IS .EQ. 6) THEN +*---- +* Rotate by 5*Pi/3 +*---- + XLOC=DHALF*XLOCR+DSQ3O2*YLOCR + YLOC=-DSQ3O2*XLOCR+DHALF*YLOCR + ENDIF + ENDIF +*---- +* Processing finished: +* print routine closing output header if required +* and return +*---- + IF(IPRINT .GE. 10) THEN + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6011) XLOC,YLOC + ENDIF + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(' Location of cell in ', + >' Crown = ',I8,5X,'Sector =',I8,5X,' Cell =',I8,5X, + >' SIDE = ',F20.10) + 6011 FORMAT(' X =',F20.10,10X,'Y =',F20.10) + END diff --git a/Dragon/src/NXTHRS.f b/Dragon/src/NXTHRS.f new file mode 100644 index 0000000..7c6bb60 --- /dev/null +++ b/Dragon/src/NXTHRS.f @@ -0,0 +1,81 @@ +*DECK NXTHRS + FUNCTION NXTHRS(ITRCUR,ISYM) +* +*---------- +* +*Purpose: +* Find new DRAGON TURN factor after an hexagonal symmetry +* is applied on an old DRAGON TURN factor. +* +*Copyright: +* Copyright (C) 2004 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau. +* +* +*Parameters: input +* ITRCUR initial turn factor. +* ISYM symmetry to consider where: +* =-1 indicates $Z$ reflection symmetry; +* = i indicates $H$ reflection symmetry. +* +*Parameters: output +* NXTHRS turn factor after symmetry is applied. +* +*---- + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER ITRCUR,ISYM + INTEGER NXTHRS +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTHRS') + INTEGER MAXTUR + PARAMETER (MAXTUR=12) +*---- +* Local variables +*---- + INTEGER ISZ,ICTP,IRTR +*---- +* Test input data +* ITRCUR can be 1-8 or 13-20 +* ISYM can be 1-4 +*---- + IF((ITRCUR .LE. 0) .OR. + > (ITRCUR .GE. 9 .AND. ITRCUR .LE. 12) .OR. + > (ITRCUR .GE. 21)) CALL XABORT(NAMSBR// + > ': Invalid TURN') + IF(ISYM .LT. -1 .OR. + > ISYM .EQ. 0 .OR. + > ISYM .GT. 4 ) CALL XABORT(NAMSBR// + > ': Invalid symmetry') +*---- +* Find current symmetry factor in Z (ISZ) and current turn +* number in plane X-Y (ICTP) +*---- + ISZ=((ITRCUR-1)/MAXTUR) + ICTP=MOD(ITRCUR-1,MAXTUR)+1 + IF(ISYM .EQ. -1) THEN +*---- +* Z symmetry +*---- + ISZ=(1-ISZ) + ELSE +*---- +* X, X-Y AND Y symmetry +*---- + IRTR=((ICTP-1)/4)*4 + ICTP=MOD(4-ICTP+IRTR+ISYM,4)+5-IRTR + ENDIF + NXTHRS=ICTP+MAXTUR*ISZ + RETURN + END diff --git a/Dragon/src/NXTHUA.f b/Dragon/src/NXTHUA.f new file mode 100644 index 0000000..7a04eaf --- /dev/null +++ b/Dragon/src/NXTHUA.f @@ -0,0 +1,443 @@ +*DECK NXTHUA + SUBROUTINE NXTHUA(IPRINT,NDIM ,IHSYM ,ISAXIS, + > NBOCEL,NBUCEL,NOCELL,NUCELL, + > ITSYM ,IDFEX ,IDFRT ,IUNFLD) +* +*---------- +* +*Purpose: +* To create the array for testing the geometry in +* an hexagonal assembly for internal symmetries and unfolding +* the assembly according to the symmetries. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau. +* +*Parameters: input +* IPRINT print level. +* NDIM problem dimensions. +* IHSYM hexagonal symmetry option where: +* = 0 geometry is not hexagonal; +* = 1 for S30; +* = 2 for SA60; +* = 3 for SB60; +* = 4 for S90; +* = 5 for R120; +* = 6 for R180; +* = 7 for SA180; +* = 8 for SB180; +* = 9 for COMPLETE; +* =10 for R60. +* ISAXIS symmetry vector for each direction. +* NBOCEL number of cells in original geometry. +* NBUCEL number of cells in unfolded geometry. +* NOCELL number of cell before unfolding in +* $X$, $Y$ and $Z$ directions. +* NUCELL number of cell after unfolding in +* $X$, $Y$ and $Z$ directions. +* +*Parameters: output +* ITSYM array to identify the symmetry to test for each original +* cell where: +* ITSYM(1,*) identify hexagonal symmetry; +* ITSYM(2,*) not used; +* ITSYM(3,*) identify $Z$ symmetry; +* ITSYM(4,*) not used. +* A value of 0 indicate that the geometry does not need +* to be verified while a value of 1 implies a verification +* of the geometry. +* IDFEX identify faces associated with external boundary for a +* generating cell and number of times this cell is used. Here: +* IDFEX( 1,*) identify bottom $U$ hexagonal face; +* IDFEX( 2,*) identify top $U$ hexagonal face; +* IDFEX( 3,*) identify bottom $V$ hexagonal face; +* IDFEX( 4,*) identify top $V$ hexagonal face; +* IDFEX( 5,*) identify bottom $Z$ face; +* IDFEX( 6,*) identify top $Z$ face; +* IDFEX( 7,*) not used; +* IDFEX( 8,*) not used; +* IDFEX (9,*) identify bottom $W$ hexagonal face; +* IDFEX(10,*) identify top $W$ hexagonal face. +* IDFRT identify reflection/transmission faces. +* IUNFLD array to identify the generating cell (IUNFLD(1,*)) +* and the rotation associated with this region in space. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,NDIM,IHSYM,ISAXIS(3) + INTEGER NBUCEL,NOCELL(3),NUCELL(3) + INTEGER NBOCEL,ITSYM(4,NBOCEL),IDFEX(0:10,NBOCEL), + > IDFRT(8,NBOCEL),IUNFLD(2,NBUCEL) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTHUA') +*---- +* Functions +*---- + INTEGER NXTTRS +*---- +* Local variables +*---- + INTEGER IDIR,NSCELL(3),NFCELL(3), + > NSUC(3),ID1,ID2,ID3,ISECT, + > IGEN,IGENT,IX,IZ,ILOCD, + > ILOCR,IOFZ,IOFZR,NCR,NCILC,IDD,ICR + DOUBLE PRECISION ARGS +*---- +* Data +*---- + CHARACTER*2 CTRN(24) + INTEGER IDSEC(6) + SAVE CTRN,IDSEC + DATA CTRN + > /'+A','+B','+C','+D','+E','+F','+G','+H','+I','+J','+K','+L', + > '-A','-B','-C','-D','-E','-F','-G','-H','-I','-J','-K','-L'/ + DATA IDSEC + > /4,9,1,3,10,2/ +*---- +* Processing starts: +* print routine opening header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + IDFEX(0:10,:NBOCEL)=0 + IDFRT(:8,:NBOCEL)=0 + ITSYM(:4,:NBOCEL)=0 +*---- +* Prepare direction control vector for +* original assembly +*---- + IDIR=1 + NSCELL(IDIR)=MAX(1,NOCELL(IDIR)) + NSUC(IDIR)=MAX(1,NUCELL(IDIR)) + NFCELL(IDIR)=0 + IDIR=3 + NSCELL(IDIR)=MAX(1,NOCELL(IDIR)) + NSUC(IDIR)=MAX(1,NUCELL(IDIR)) + IF(ISAXIS(IDIR) .EQ. -2) THEN + NFCELL(IDIR)=NOCELL(IDIR) + ELSE IF(ISAXIS(IDIR) .EQ. -1) THEN + NFCELL(IDIR)=NOCELL(IDIR)-1 + ELSE + NFCELL(IDIR)=0 + ENDIF + IGEN=0 + IF(IHSYM .EQ. 9) THEN +*---- +* Process complete cell +*---- + DO IZ=0,NSCELL(3)-1 + IOFZ=(IZ+NFCELL(3))*NUCELL(1) + DO IX=0,NSCELL(1)-1 + IGEN=IGEN+1 + IF(IGEN .GT. NBOCEL) CALL XABORT(NAMSBR// + > ': Cell number exceeds number of cells permitted') + ILOCD=IOFZ+IX+NFCELL(1)+1 + IUNFLD(1,ILOCD)=IGEN + IUNFLD(2,ILOCD)=1 + ENDDO + ENDDO +*---- +* Identify cells to tests for Z +* reflection symmetry +*---- + IF(ABS(ISAXIS(3)) .EQ. 1) THEN + IF(ISAXIS(3) .EQ. -1) THEN + IZ=0 + ELSE IF(ISAXIS(3) .EQ. 1) THEN + IZ=NSCELL(3)-1 + ENDIF + IOFZ=(IZ+NFCELL(3))*NUCELL(1) + DO IX=0,NSCELL(1)-1 + ILOCD=IOFZ+IX+NFCELL(1)+1 + IGEN=IUNFLD(1,ILOCD) + ITSYM(3,IGEN)=ISAXIS(3) + ENDDO + ENDIF + ENDIF + IF(ISAXIS(3) .NE. 0) THEN + IF(ISAXIS(3) .EQ. -2) THEN +*---- +* SSYM Z- +* Fill position IZR=1,NSCELL(3) with cells at +* position IZD=NSUC(3)-IZR+1 +*---- + DO IZ=1,NSCELL(3) + IOFZR=(IZ-1)*NUCELL(1) + IOFZ=(NSUC(3)-IZ)*NUCELL(1) + DO IX=1,NSCELL(1) + ILOCD=IOFZ+IX + ILOCR=IOFZR+IX + IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD) + IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),-1) + ENDDO + ENDDO + ELSE IF(ISAXIS(3) .EQ. -1) THEN +*---- +* SYME Z- +* Fill position IZR=1,NSCELL(3)-1 with cells at +* position IZD=NSUC(3)-IZR+1 +* set test flag for IZ=NSCELL(3) +*---- + DO IZ=1,NSCELL(3)-1 + IOFZR=(IZ-1)*NUCELL(1) + IOFZ=(NSUC(3)-IZ)*NUCELL(1) + DO IX=1,NSCELL(1) + ILOCD=IOFZ+IX + ILOCR=IOFZR+IX + IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD) + IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),-1) + ENDDO + ENDDO + ELSE IF(ISAXIS(3) .EQ. 1) THEN +*---- +* SYME Z+ +* Fill position IZR=NSUC(3)-IZD+1 with cell +* at position IZD=1,NSCELL(3)-1 +* set test flag for IZ=NSCELL(3) +*---- + DO IZ=1,NSCELL(3)-1 + IOFZ=(IZ-1)*NUCELL(1) + IOFZR=(NSUC(3)-IZ)*NUCELL(1) + DO IX=1,NSCELL(1) + ILOCD=IOFZ+IX + ILOCR=IOFZR+IX + IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD) + IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),-1) + ENDDO + ENDDO + ELSE IF(ISAXIS(3) .EQ. 2) THEN +*---- +* SSYM Z+ +* Fill position IZR=NSUC(3)-IZD+1 with cell +* at position IZD=1,NSCELL(3) +*---- + DO IZ=1,NSCELL(3) + IOFZ=(IZ-1)*NUCELL(1) + IOFZR=(NSUC(3)-IZ)*NUCELL(1) + DO IX=1,NSCELL(1) + ILOCD=IOFZ+IX + ILOCR=IOFZR+IX + IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD) + IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),-1) + ENDDO + ENDDO + ENDIF + NSCELL(3)=MAX(1,NSUC(3)) + ENDIF +*---- +* 1. Localize external faces +* Find number of crown : NCR +* Find number of cell inside last crown : NCILC (no external faces) +* Only last crown has external faces +* Face notation: +* W=-1 /\ V=-2 +* U=-1 | | U=-2 +* V=-1 \/ W=-2 +* -/+ U -> IDFEX(1,*),IDFEX(2,*) +* -/+ V -> IDFEX(3,*),IDFEX(4,*) +* -/+ Z -> IDFEX(5,*),IDFEX(6,*) +* -/+ W -> IDFEX(9,*),IDFEX(10,*) +*---- + ARGS=DBLE(12*NUCELL(1)-3) + NCR=(NINT(SQRT(ARGS))+3)/6 + IF(NCR .EQ. 1) THEN + NCILC=1 + ELSE + NCILC=6*(NCR-1) + ENDIF + IF(NCILC .EQ. 1) THEN + ILOCD=0 + DO IZ=1,NSUC(3) + ILOCD=ILOCD+1 + IGEN=IUNFLD(1,ILOCD) + IDFEX(1,IGEN)=1 + IDFEX(2,IGEN)=1 + IDFEX(3,IGEN)=1 + IDFEX(4,IGEN)=1 + IDFEX(9,IGEN)=1 + IDFEX(10,IGEN)=1 + IDFRT(1,IGEN)=IGEN + IDFRT(2,IGEN)=IGEN + ENDDO + ELSE + DO IZ=1,NSUC(3) + ILOCD=NUCELL(1)*IZ-NCILC +*---- +* Scan over all sectors +*---- + ID1=10 + ID2=2 + DO ISECT=1,6 + ILOCD=ILOCD+1 + IGEN=IUNFLD(1,ILOCD) + ID3=IDSEC(ISECT) + IDFEX(ID1,IGEN)=1 + IDFEX(ID2,IGEN)=1 + IDFEX(ID3,IGEN)=1 + IDFRT(1,IGEN)=IGEN + IDFRT(2,IGEN)=IGEN + IDD=IDD+1 + DO ICR=1,NCR-2 + ILOCD=ILOCD+1 + IGEN=IUNFLD(1,ILOCD) + IDFEX(ID2,IGEN)=1 + IDFEX(ID3,IGEN)=1 + IDFRT(1,IGEN)=IGEN + IDFRT(2,IGEN)=IGEN + ENDDO + ID1=ID2 + ID2=ID3 + ENDDO + ENDDO + ENDIF +*---- +* 2. Z Faces +* IDFEX(5,*) for Z- +* IDFEX(6,*) FOR Z+ +*---- + DO IX=1,NUCELL(1) + ILOCD=IX + IF(IUNFLD(2,ILOCD) .EQ. 1) THEN + IGEN=IUNFLD(1,ILOCD) + IDFEX(5,IGEN)=1 + IDFRT(5,IGEN)=IGEN + ENDIF + ILOCD=NUCELL(1)*(NSUC(3)-1)+IX + IF(IUNFLD(2,ILOCD) .EQ. 1) THEN + IGEN=IUNFLD(1,ILOCD) + IDFEX(6,IGEN)=1 + IDFRT(6,IGEN)=IGEN + ENDIF + ENDDO +*---- +* Process. Z translation +*---- + IF(ISAXIS(3) .EQ. 3) THEN + DO IGEN=1,NBOCEL + IF(IDFEX(5,IGEN) .EQ. 1) THEN + DO IX=1,NUCELL(1) + ILOCD=IX + IF(IUNFLD(2,ILOCD) .EQ. 1) THEN + IF(IUNFLD(1,ILOCD) .EQ. IGEN) THEN + ILOCD=NUCELL(1)*(NSUC(3)-1)+IX + IGENT=IUNFLD(1,ILOCD) + IDFRT(5,IGEN)=IGENT + IDFRT(6,IGENT)=IGEN + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF +*---- +* Compute the number of times each cell appears +* after unfolding +*---- + DO IGEN=1,NBOCEL + DO ILOCD=1,NBUCEL + IF(ABS(IUNFLD(1,ILOCD)) .EQ. IGEN) THEN + IDFEX(0,IGEN)=IDFEX(0,IGEN)+1 + ENDIF + ENDDO + ENDDO +*---- +* For 2-D cases reset components 5, 6 of IDFEX to 0 +*---- + IF(NDIM .EQ. 2) THEN + DO IGEN=1,NBOCEL + IDFEX(5,IGEN)=0 + IDFEX(6,IGEN)=0 + ENDDO + ENDIF +*---- +* Processing finished: +* print routine output and +* closing header if required +* and return +*---- + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6002) + IF(NDIM .EQ. 3) THEN + DO IZ=1,NSUC(3) + WRITE(IOUT,6003) IZ + ILOCD=(IZ-1)*NUCELL(1) + WRITE(IOUT,6005) + > (IUNFLD(1,IX),IX=ILOCD+1,ILOCD+NUCELL(1)) + ENDDO + ELSE + WRITE(IOUT,6004) + WRITE(IOUT,6005) + > (IUNFLD(1,IX),IX=1,NUCELL(1)) + ENDIF + WRITE(IOUT,6008) + IF(NDIM .EQ. 3) THEN + DO IZ=1,NSUC(3) + WRITE(IOUT,6003) IZ + ILOCD=(IZ-1)*NUCELL(1) + WRITE(IOUT,6011) + > (CTRN(IUNFLD(2,IX)),IX=ILOCD+1,ILOCD+NUCELL(1)) + ENDDO + ELSE + WRITE(IOUT,6004) + WRITE(IOUT,6011) + > (CTRN(IUNFLD(2,IX)),IX=1,NUCELL(1)) + ENDIF + WRITE(IOUT,6006) + DO ILOCD=1,NBOCEL + WRITE(IOUT,6007) + > ILOCD,(ITSYM(IX,ILOCD),IX=1,4) + ENDDO + WRITE(IOUT,6009) + DO ILOCD=1,NBOCEL + WRITE(IOUT,6007) ILOCD, + > (IDFEX(IX,ILOCD),IX=1,4),(IDFEX(IX,ILOCD),IX=9,10), + > (IDFEX(IX,ILOCD),IX=5,6),IDFEX(0,ILOCD) + ENDDO + WRITE(IOUT,6010) + DO ILOCD=1,NBOCEL + WRITE(IOUT,6007) ILOCD,IDFRT(1,ILOCD),IDFRT(2,ILOCD), + > IDFRT(5,ILOCD),IDFRT(6,ILOCD) + ENDDO + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6002 FORMAT(' Cells in assembly') + 6003 FORMAT(' Hexagons for plane IZ =',I6) + 6004 FORMAT(' Hexagons ') + 6005 FORMAT(24(I7.7,1X)) + 6006 FORMAT(/' Symmetrized cell X Y Z D') + 6007 FORMAT(' Cell ',I7.7,5X,20I5) + 6008 FORMAT(/' Cell rotations in assembly') + 6009 FORMAT(/' External faces ', + > ' -U +U -V +V -W +W -Z +Z ND') + 6010 FORMAT(/' Coupled faces FH LH -Z +Z ') + 6011 FORMAT(24(5X,A2,1X)) + END diff --git a/Dragon/src/NXTIAA.f b/Dragon/src/NXTIAA.f new file mode 100644 index 0000000..a962ece --- /dev/null +++ b/Dragon/src/NXTIAA.f @@ -0,0 +1,188 @@ +*DECK NXTIAA + FUNCTION NXTIAA(POSANN ,POSPIN,VOLINT) +* +*---------- +* +*Purpose: +* Compute the volume of intersection between +* a 2--D annular region and an annular pin. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau. +* +*Parameters: input +* POSANN spatial description of the annular region with +* POSANN(0) the radius, POSANN(1) the $X$ position +* of center and POSANN(2) the $Y$ position +* of center. +* POSPIN spatial description of the annular pin region with +* POSPIN(0) the radius, POSPIN(1) the $X$ position +* of center and POSPIN(2) the $Y$ position +* of center. +* +*Parameters: output +* NXTIAA type of intersection between annular region and +* annular pin, where: +* = 0 means that there is no intersection +* between the two regions; +* = 1 means that the annular region +* is all located inside the annular pin; +* = 2 means that the annular pin +* is all located inside the annular region; +* =-1 means that the intersection between +* the annular region and the annular pin is partial. +* VOLINT 2-D volume of intersection (area) between annular region and +* annular pin. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NXTIAA + DOUBLE PRECISION POSANN(0:2),POSPIN(0:2) + DOUBLE PRECISION VOLINT +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTIAA') + INTEGER IPRINT + PARAMETER (IPRINT=100) + DOUBLE PRECISION DCUTOF + PARAMETER (DCUTOF=1.0D-8) + DOUBLE PRECISION DZERO + PARAMETER (DZERO=0.0D0) +*---- +* Functions +*---- + DOUBLE PRECISION XDRCST,PI +*---- +* Local variables +*---- + INTEGER IFACE + DOUBLE PRECISION PX,PY,PX2,PY2,RA2,RP2,DAP2,DAP,XINT,YINT, + > ANGLEP,ANGLEA,SP,SA,VOLANN,VOLPIN,ACARG + DOUBLE PRECISION DT1,DT2,DT3 +*---- +* Initialize NXTIAA and VOLINT +*---- + IF(IPRINT .GE. 200) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6010) (POSANN(IFACE),IFACE=0,2) + WRITE(IOUT,6011) (POSPIN(IFACE),IFACE=0,2) + ENDIF + PI=XDRCST('Pi',' ') + NXTIAA=0 + VOLINT=DZERO +*---- +* Find distance from center of annulus to pin center +* $d=\sqrt(y^{2}+y^{2})$ +* annular region/pin intersection if $d DHALF=0.5D0,DSQ3O2=0.86602540378444D0) +*---- +* Functions +*---- + INTEGER NXTITA + DOUBLE PRECISION XDRCST,PI +*---- +* Local variables +*---- + INTEGER IDIR,ICORN,IFACE,NFPINS,NCIN,ITRI,INTTRI + DOUBLE PRECISION POSTRI(2,3),RADC,DISTF,DISTC,RADP2, + > VTPINT +*---- +* Data +*---- + DOUBLE PRECISION CORNRH(2,6),DIRFAC(2,6) + SAVE CORNRH,DIRFAC + DATA CORNRH / 0.86602540378444D0,-0.5D0, + > 0.86602540378444D0, 0.5D0, + > 0.0D0 , 1.0D0, + > -0.86602540378444D0, 0.5D0, + > -0.86602540378444D0,-0.5D0, + > 0.0D0 ,-1.0D0/ + DATA DIRFAC /-1.0D0 , 0.0D0, + > -0.5D0 ,-0.86602540378444D0, + > 0.5D0 ,-0.86602540378444D0, + > 1.0D0 , 0.0D0, + > 0.5D0 , 0.86602540378444D0, + > -0.5D0 , 0.86602540378444D0/ +*---- +* Print header if required +*---- + IF(IPRLOC .GE. 200) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6010) (POSHEX(IFACE),IFACE=0,2) + WRITE(IOUT,6011) (PINPOS(IFACE),IFACE=0,2) + ENDIF +*---- +* Initialize PI, NXTIHA and VOLINT +*---- + PI=XDRCST('Pi',' ') + NXTIHA=0 + VOLINT=DZERO +*---- +* Evaluate distance from FACES to pin center +*---- + RADP2=PINPOS(0)**2 + NFPINS=0 + NCIN=0 + ICORN=1 + POSTRI(1,ICORN)=POSHEX(1) + POSTRI(2,ICORN)=POSHEX(2) + DO IFACE=1,6 + DISTF=DZERO + RADC=DZERO +* write(6,*) 'CORNRH',(CORNRH(IDIR,IFACE),IDIR=1,2) +* write(6,*) 'DIRFAC',(DIRFAC(IDIR,IFACE),IDIR=1,2) + DO IDIR=1,2 + DISTC=PINPOS(IDIR)-(POSHEX(IDIR)+POSHEX(0)*CORNRH(IDIR,IFACE)) + DISTF=DISTF+DISTC*DIRFAC(IDIR,IFACE) + RADC=RADC+DISTC**2 + ENDDO +* write(6,*) DISTC,DISTF,RADC,PINPOS(0) + IF(DISTF .LT. -PINPOS(0)) THEN +*---- +* Pin outside hexagon +* Return +*---- + NXTIHA=0 + VOLINT=DZERO + RETURN + ELSE IF(DISTF .GE. PINPOS(0)) THEN + NFPINS=NFPINS+1 + ENDIF + IF(RADC .LT. RADP2) THEN + NCIN=NCIN+1 + ENDIF + ENDDO + IF(NFPINS .EQ. 6) THEN + NXTIHA=2 + VOLINT=PI*RADP2 + ELSE IF(NCIN .EQ. 6) THEN + NXTIHA=1 + VOLINT=3.0D0*DSQ3O2*POSHEX(0)**2 + ELSE + NXTIHA=-1 +*---- +* First five triangles +*---- + DO ITRI=1,5 + DO ICORN=2,3 + DO IDIR=1,2 + POSTRI(IDIR,ICORN)=POSTRI(IDIR,ICORN) + > +POSHEX(0)*CORNRH(IDIR,IFACE+ICORN-2) + ENDDO + ENDDO + INTTRI=NXTITA(POSTRI,PINPOS,VTPINT) + VOLINT=VOLINT+VTPINT + ENDDO +*---- +* Last five triangles +*---- + DO IDIR=1,2 + POSTRI(IDIR,ICORN)=POSTRI(IDIR,ICORN) + > +POSHEX(0)*CORNRH(IDIR,6) + POSTRI(IDIR,ICORN)=POSTRI(IDIR,ICORN) + > +POSHEX(0)*CORNRH(IDIR,1) + ENDDO + ITRI=NXTITA(POSTRI,PINPOS,VTPINT) + VOLINT=VOLINT+VTPINT + ENDIF + IF(IPRLOC .GE. 200) THEN + WRITE(IOUT,6012) NAMSBR,NXTIHA,VOLINT + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT('POSHEX={',2(F20.10,','),F20.10,'};') + 6011 FORMAT('PINPOS={',2(F20.10,','),F20.10,'};') + 6012 FORMAT(A6,'={',I5,',',F20.10,'};') + END diff --git a/Dragon/src/NXTIND.f b/Dragon/src/NXTIND.f new file mode 100644 index 0000000..2ab2064 --- /dev/null +++ b/Dragon/src/NXTIND.f @@ -0,0 +1,161 @@ +*DECK NXTIND + SUBROUTINE NXTIND(IX,IY,IZ,NFSUR,NFREG,MXGSUR,MXGREG,MAXMSH,NZP, + 1 NUCELZ,MESHCZM,MESHC,NSURC,NREGC,INDEX,IDREG, + 2 IDSUR,N2REG,N2SUR,IND2T3,REGI,NZC,IDZ,LSTORE, + 3 I2SURC,N2REGC,II,JJ,LL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Locate the different regions corresponding to the same projection along +* an axis for a set of cells/pins. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IX first direction perpendicular to the projection axis. +* IY second direction perpendicular to the projection axis. +* IZ projection axis. +* NFSUR number of outer surfaces in the 3D geometry. +* NFREG number of regions in the 3D geometry. +* MXGSUR maximum number of surfaces for any sub-geometry of +* the 3D geometry. +* MXGREG maximum number of regions for any sub-geometry of +* the 3D geometry. +* MAXMSH maximum dimension of any mesh in any sub-geometry of +* the 3D geometry. +* NZP total number of plans in the 3D geometry. +* NUCELZ number of cells/pins along the projection axis. +* MESHCZM maximum number of meshes along the projection axis within +* any cell/pin. +* MESHC cells/pins meshes size. +* NSURC number of surfaces for the cells/pins. +* NREGC number of regions for the cells/pins. +* LSTORE 2D cell/pin storage flag. +* II x index to locate. +* JJ y index to locate. +* LL r index to locate. +* +*Parameters: input/output +* INDEX cells/pins index vector for 3D cells/pins and corresponding +* 2D cell/pin. +* IDSUR surface index array for 3D cells/pins and corresponding 2D +* cell/pin. +* IDREG region index array for 3D cells/pins and corresponding 2D +* cell/pin. +* N2REG number of regions in the projected 2D geometry. +* N2SUR number of outer surfaces in the projected 2D geometry. +* IND2T3 mapping index between the 2D projected geometries +* (plan by plan) and the initial 3D geometry. +* REGI region sweeping flag array. +* NZC array containing the number of meshes alon the projection +* axis for each cell/pin. +* I2SURC initial/final outer surface position in surface index array +* for corresponding 2D cell/pin. +* N2REGC initial/final outer surface position in region index array +* for corresponding 2D cell/pin. +* +*Parameters: temporary storage +* IDZ work vector. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IX,IY,IZ,NFSUR,NFREG,MXGSUR,MXGREG,MAXMSH,NZP, + 1 NUCELZ,MESHCZM,MESHC(4,NUCELZ),NSURC(NUCELZ),NREGC(NUCELZ), + 2 INDEX(5,-MXGSUR:MXGREG,0:NUCELZ),IDSUR(MXGSUR,0:NUCELZ), + 3 IDREG(MXGREG,0:NUCELZ),N2REG,N2SUR, + 4 IND2T3(-NFSUR:NFREG,0:NUCELZ*MAXMSH+1),REGI(-NFSUR:NFREG), + 5 NZC(NUCELZ),IDZ(0:MESHCZM+1,NUCELZ),I2SURC,N2REGC,II,JJ,LL + LOGICAL LSTORE +*---- +* LOCAL VARIABLES +*---- + INTEGER K,KK,MESHCZ,ITYP,ISUR,IREG +* + DO K=1,NUCELZ + MESHCZ=MESHC(IZ,K) + IDZ(0:MESHCZM+1,K)=0 + CALL NXTFID(IX,IY,IZ,NSURC(K),NREGC(K),MESHCZ,II,JJ,LL, + 1 INDEX(1,-MXGSUR,K),IDSUR(1,K),IDREG(1,K),IDZ(0,K),ITYP) + ENDDO + IF (ITYP.EQ.-1) THEN +* lateral surface found + IF (REGI(IDZ(1,1)).EQ.0) THEN + N2SUR=N2SUR-1 + DO 20 K=1,NUCELZ + MESHCZ=MESHC(IZ,K) + DO 10 KK=1,MESHCZ + ISUR=IDZ(KK,K) + IND2T3(N2SUR,NZC(K)+KK)=ISUR + REGI(ISUR)=N2SUR + 10 CONTINUE + 20 CONTINUE + ENDIF + ELSEIF (ITYP.EQ.1) THEN +* region and bottom/top surface found + IF (REGI(IDZ(1,1)).EQ.0) THEN + N2REG=N2REG+1 +* region + DO 40 K=1,NUCELZ + MESHCZ=MESHC(IZ,K) + DO 30 KK=1,MESHCZ + IREG=IDZ(KK,K) + IND2T3(N2REG,NZC(K)+KK)=IREG + REGI(IREG)=N2REG + 30 CONTINUE + 40 CONTINUE +* top surface + MESHCZ=MESHC(IZ,NUCELZ) + ISUR=IDZ(MESHCZ+1,NUCELZ) + IND2T3(N2REG,NZP+1)=ISUR + REGI(ISUR)=N2REG +* bottom surface + ISUR=IDZ(0,1) + IND2T3(N2REG,0)=ISUR + REGI(ISUR)=N2REG + ENDIF + ENDIF + IF (LSTORE) THEN !.AND.(ITYP.NE.0)) THEN +* STORE THE CORRESPONDING 2D CELL CONTENTS + IF (ITYP.LT.0) THEN +* a surface + I2SURC=I2SURC+1 + IF (ITYP.EQ.-1) THEN + IDSUR(-I2SURC,0)=ABS(REGI(IDZ(1,1))) + ELSE + IDSUR(-I2SURC,0)=0 + ENDIF + INDEX(1,I2SURC,0)=II + INDEX(2,I2SURC,0)=JJ + INDEX(3,I2SURC,0)=1 + INDEX(4,I2SURC,0)=LL + INDEX(5,I2SURC,0)=0 + ELSE +* a region + N2REGC=N2REGC+1 + IF (ITYP.EQ.1) THEN + IDREG(N2REGC,0)=ABS(REGI(IDZ(1,1))) + ELSE + IDREG(N2REGC,0)=0 + ENDIF + INDEX(1,N2REGC,0)=II + INDEX(2,N2REGC,0)=JJ + INDEX(3,N2REGC,0)=1 + INDEX(4,N2REGC,0)=LL + INDEX(5,N2REGC,0)=0 + ENDIF + ENDIF +* + RETURN + END diff --git a/Dragon/src/NXTIRA.f b/Dragon/src/NXTIRA.f new file mode 100644 index 0000000..0f2e2bd --- /dev/null +++ b/Dragon/src/NXTIRA.f @@ -0,0 +1,213 @@ +*DECK NXTIRA + FUNCTION NXTIRA(XYCAR ,POSPIN,VOLINT) +* +*---------- +* +*Purpose: +* Compute the volume of intersection between +* a rectangular region and an annular pin. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau. +* +*Parameters: input +* XYCAR spatial description of the Cartesian region with: +* XYCAR(1) for left face; XYCAR(2) for right face; +* XYCAR(3) for bottom face; XYCAR(4) for top face +* positions. +* POSPIN spatial description of the annular pin region with +* POSPIN(0) the radius; POSPIN(1) the $X$ position +* of center; POSPIN(2) the $Y$ position +* of center. +* +*Parameters: output +* NXTIRA type of intersection between Cartesian region and +* annular pin or annular region and Cartesian pin, where: +* = 0 means that there is no intersection +* between the two regions; +* = 1 means that the Cartesian region +* is all located inside the annular pin; +* = 2 means that the annular pin +* is all located inside the Cartesian region; +* =-1 means that the intersection between +* the annular pin and the Cartesian region is partial. +* VOLINT 2-D volume of intersection (area) between Cartesian region +* and annular pin. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NXTIRA + DOUBLE PRECISION XYCAR(4),POSPIN(0:2) + DOUBLE PRECISION VOLINT +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTIRA') + INTEGER IPRINT + PARAMETER (IPRINT=100) + DOUBLE PRECISION DCUTOF + PARAMETER (DCUTOF=1.0D-8) + DOUBLE PRECISION DZERO,DONE + PARAMETER (DZERO=0.0D0,DONE=1.0D0) +*---- +* Functions +*---- + DOUBLE PRECISION XDRCST,PI +*---- +* Local variables +*---- + INTEGER IFACE,ILOC(4),IDX,IDY + DOUBLE PRECISION XYFACE(4),RP2,VOLCAR,VOLPIN,FACDIR,VSUB(4), + > TRIANG,ALPHA,FACTX,FACTY, + > DIST,QUARTA,CARTV + DOUBLE PRECISION DT1,DT2,DT3 +*---- +* Initialize NXTIRA and VOLINT and PI +*---- + IF(IPRINT .GE. 200) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6010) (XYCAR(IFACE),IFACE=1,4) + WRITE(IOUT,6011) (POSPIN(IFACE),IFACE=0,2) + ENDIF + NXTIRA=0 + VOLINT=DZERO + PI=XDRCST('Pi',' ') +*---- +* Locate pin center at origin +*---- + XYFACE(1)=XYCAR(1)-POSPIN(1) + XYFACE(2)=XYCAR(2)-POSPIN(1) + XYFACE(3)=XYCAR(3)-POSPIN(2) + XYFACE(4)=XYCAR(4)-POSPIN(2) +*---- +* Find location of each face with respect to annular region +*---- + DO 100 IFACE=1,4 + IF(XYFACE(IFACE) .LE. -POSPIN(0)) THEN +*---- +* Plane to the left or under +*---- + ILOC(IFACE)=(-1)**IFACE + ELSE IF(XYFACE(IFACE) .GE. POSPIN(0)) THEN +*---- +* Plane to the right or above +*---- + ILOC(IFACE)=(-1)**(IFACE+1) + ELSE +*---- +* Plane croses annular region +*---- + ILOC(IFACE)=0 + ENDIF + 100 CONTINUE + IF(ILOC(1) .NE. 1 .AND. ILOC(2) .NE. 1 .AND. + > ILOC(3) .NE. 1 .AND. ILOC(4) .NE. 1 ) THEN + RP2=POSPIN(0)*POSPIN(0) + VOLPIN=PI*RP2 + VOLCAR=(XYFACE(2)-XYFACE(1))*(XYFACE(4)-XYFACE(3)) + VOLINT=VOLPIN +*---- +* Find annular surface +* 1- to the left of X- +* 2- to the right of X+ +* 3- below Y- +* 4- above Y+ +*---- + FACDIR=-DONE + DO 110 IFACE=1,4 + IF(ILOC(IFACE) .EQ. -1) THEN + VSUB(IFACE)=DZERO + ELSE + TRIANG=SQRT(RP2-XYFACE(IFACE)*XYFACE(IFACE)) + > *FACDIR*XYFACE(IFACE) + ALPHA=ACOS(FACDIR*XYFACE(IFACE)/POSPIN(0)) + VSUB(IFACE)=RP2*ALPHA-TRIANG + VOLINT=VOLINT-VSUB(IFACE) + ENDIF + FACDIR=-FACDIR + 110 CONTINUE +*---- +* For the case where two faces intersect inside annular region +* compute intersections between the two surfaces VSUB +* associated with each of these faces. +*---- + FACTX=DONE + DO 120 IDX=1,2 + FACTY=DONE + DO 130 IDY=3,4 + IF(ILOC(IDX) .EQ. 0 .AND. ILOC(IDY) .EQ. 0) THEN + DIST=XYFACE(IDX)*XYFACE(IDX)+XYFACE(IDY)*XYFACE(IDY) + IF(DIST .LT. RP2) THEN + QUARTA=0.25D0*PI*RP2 + CARTV=FACTX*XYFACE(IDY)*FACTY*XYFACE(IDX) + CARTV=CARTV+0.5D0*(VSUB(IDX)+VSUB(IDY))-QUARTA + ELSE + IF(FACTX*XYFACE(IDX) .LT. DZERO) THEN + IF(FACTY*XYFACE(IDY) .LT. DZERO) THEN + CARTV=0.0 + ELSE + CARTV=VSUB(IDX) + ENDIF + ELSE + IF(FACTY*XYFACE(IDY) .LT. DZERO) THEN + CARTV=VSUB(IDY) + ELSE + CARTV=-(VOLPIN-VSUB(IDX)-VSUB(IDY)) + ENDIF + ENDIF + ENDIF + VOLINT=VOLINT+CARTV + ENDIF + FACTY=-FACTY + 130 CONTINUE + FACTX=-FACTX + 120 CONTINUE + DT1=ABS(VOLINT-VOLPIN) + DT2=ABS(VOLINT-VOLCAR) + DT3=ABS(VOLINT) + IF(DT1 .LT. DCUTOF) THEN + VOLINT=VOLPIN + NXTIRA=2 + ELSE IF(DT2 .LT. DCUTOF) THEN + VOLINT=VOLCAR + NXTIRA=1 + ELSE IF(DT3 .LT. DCUTOF) THEN + VOLINT=DZERO + NXTIRA=0 + ELSE + NXTIRA=-1 + ENDIF + ENDIF +*---- + IF(IPRINT .GE. 200) THEN + WRITE(IOUT,6012) NAMSBR,NXTIRA,VOLINT + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT('XYCAR ={',3(F20.10,','),F20.10,'};') + 6011 FORMAT('POSPIN={',2(F20.10,','),F20.10,'};') + 6012 FORMAT(A6,'={',I5,',',F20.10,'};') + END diff --git a/Dragon/src/NXTIRR.f b/Dragon/src/NXTIRR.f new file mode 100644 index 0000000..7937630 --- /dev/null +++ b/Dragon/src/NXTIRR.f @@ -0,0 +1,132 @@ +*DECK NXTIRR + FUNCTION NXTIRR(XYCAR ,XYPIN ,VOLINT) +* +*---------- +* +*Purpose: +* Compute the volume of intersection between +* a rectangular region and a Cartesian pin. +* centered at the origin. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau. +* +*Parameters: input +* XYCAR spatial description of the Cartesian region with: +* XYCAR(1) for left face; XYCAR(2) for right face; +* XYCAR(3) for bottom face, XYCAR(4) for top face +* positions. +* XYPIN spatial description of the Cartesian pin region with +* XYPIN(1) for left face; XYPIN(2) for right face; +* XYPIN(3) for bottom face; XYPIN(4) for top face +* positions. +* +*Parameters: output +* NXTIRR type of intersection between Cartesian region and +* annular pin or annular region and Cartesian pin, where: +* =0 means that there is no intersection +* between the two regions; +* = 1 means that the Cartesian region +* is all located inside the Cartesian pin; +* = 2 means that the Cartesian pin +* is all located inside the Cartesian region; +* =-1 means that the intersection between +* the Cartesian region and the Cartesian pin is partial. +* VOLINT 2-D volume of intersection (area) between Cartesian region and +* Cartesian pin. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NXTIRR + DOUBLE PRECISION XYCAR(4),XYPIN(4) + DOUBLE PRECISION VOLINT +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTIRR') + INTEGER IPRINT + PARAMETER (IPRINT=100) + DOUBLE PRECISION DCUTOF + PARAMETER (DCUTOF=1.0D-8) + DOUBLE PRECISION DZERO + PARAMETER (DZERO=0.0D0) +*---- +* Functions +*---- + INTEGER NXTPRR,ITYPRR +*---- +* Local variables +*---- + INTEGER IFACE + DOUBLE PRECISION VOLCAR,VOLPIN,XYINT(4) + DOUBLE PRECISION DT1,DT2,DT3 +*---- +* Initialize NXTIRR and VOLINT +*---- + IF(IPRINT .GE. 200) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6010) (XYCAR(IFACE),IFACE=1,4) + WRITE(IOUT,6011) (XYPIN(IFACE),IFACE=1,4) + ENDIF + NXTIRR=0 + VOLINT=DZERO + VOLCAR=(XYCAR(2)-XYCAR(1))*(XYCAR(4)-XYCAR(3)) + VOLPIN=(XYPIN(2)-XYPIN(1))*(XYPIN(4)-XYPIN(3)) +*---- +* Find rectangle of intersection between the two rectangles. +*---- + ITYPRR=NXTPRR(XYCAR ,XYPIN ,XYINT ) +*---- +* For cases with intersection, compute volume of intersection +* and type of intersection +*---- + IF(ITYPRR .NE. 0) THEN + VOLINT=(XYINT(2)-XYINT(1))*(XYINT(4)-XYINT(3)) + DT1=ABS(VOLINT-VOLPIN) + DT2=ABS(VOLINT-VOLCAR) + DT3=ABS(VOLINT) + IF(DT1 .LT. DCUTOF) THEN + VOLINT=VOLPIN + NXTIRR=2 + ELSE IF(DT2 .LT. DCUTOF) THEN + VOLINT=VOLCAR + NXTIRR=1 + ELSE IF(DT3 .LT. DCUTOF) THEN + VOLINT=DZERO + NXTIRR=0 + ELSE + NXTIRR=-1 + ENDIF + ENDIF + IF(IPRINT .GE. 200) THEN + WRITE(IOUT,6012) NAMSBR,NXTIRR,VOLINT + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT('XYCAR ={',3(F20.10,','),F20.10,'};') + 6011 FORMAT('XYPIN ={',3(F20.10,','),F20.10,'};') + 6012 FORMAT(A6,'={',I5,',',F20.10,'};') + END diff --git a/Dragon/src/NXTITA.f b/Dragon/src/NXTITA.f new file mode 100644 index 0000000..235ef98 --- /dev/null +++ b/Dragon/src/NXTITA.f @@ -0,0 +1,308 @@ +*DECK NXTITA + FUNCTION NXTITA(POSTRI ,PINPOS,VOLINT) +* +*---------- +* +*Purpose: +* Compute the volume of intersection between +* a 2--D triangle and an annular pin. +* +*Copyright: +* Copyright (C) 2010 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau. +* +*Parameters: input +* POSTRI spatial description of the triangle with: +* POSTRI(1,J) $X$ location of corner $j$ of triangle; +* POSTRI(2,J) $Y$ location of corner $j$ of triangle. +* PINPOS spatial description of the annular pin region with: +* PINPOS(0) the radius of the annular pin; +* PINPOS(1) the $X$ position of the annular pin center; +* PINPOS(2) the $Y$ position of the annular pin center. +* +*Parameters: output +* NXTITA type of intersection between haxagon and annular pin, where: +* = 0 means that there is no intersection +* between the two regions; +* = 1 means that the hexagon +* is all located inside the annular pin; +* = 2 means that the annular pin +* is all located inside the hexagon; +* =-1 means that the intersection between +* the hexagon and the annular pin is partial. +* VOLINT 2-D volume of intersection (area) between hexagon and +* annular pin. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NXTITA + DOUBLE PRECISION POSTRI(2,3),PINPOS(0:2) + DOUBLE PRECISION VOLINT +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTITA') + INTEGER IPRINT + PARAMETER (IPRINT=100) + DOUBLE PRECISION DCUTOF + PARAMETER (DCUTOF=1.0D-8) + DOUBLE PRECISION DZERO,DONE,DHALF,DSQ3O2 + PARAMETER (DZERO=0.0D0,DONE=1.0D0, + > DHALF=0.5D0,DSQ3O2=0.86602540378444D0) +*---- +* Functions +*---- + DOUBLE PRECISION XDRCST,PI +*---- +* Local variables +*---- + INTEGER IDIR,IFACE,NFPINS,NCIN,NKPINS,ICOR,ICORIN(3),IC + DOUBLE PRECISION VOLOUT,RADP2,X1,Y1,X2,Y2,VOLTRI,ALPHA + DOUBLE PRECISION CPPP(2),CORPOS(2),DIRFAC(2,3),DIRLIN(2,3),RADC, + > DIRN,DISTM,DISTC,DNOR(3),DTAN(3), + > VT,AFPINT(3),XFPINT(3), + > YFPINT(3),TC1(2),TC2(2),DISTS,DISTF +*---- +* Print header if required +*---- + IF(IPRINT .GE. 200) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6010) (POSTRI(1,ICOR),POSTRI(2,ICOR),ICOR=1,3) + WRITE(IOUT,6011) (PINPOS(IFACE),IFACE=0,2) + ENDIF +*---- +* Initialize PI, NXTITA and VOLINT +*---- + PI=XDRCST('Pi',' ') + NXTITA=0 + VOLINT=DZERO + VOLOUT=DZERO +*---- +* Evaluate distance from FACES to pin center +*---- + RADP2=PINPOS(0)**2 + NFPINS=0 + NCIN=0 + NKPINS=0 +*---- +* Compute volume of triangle +*---- + X1=POSTRI(1,2)-POSTRI(1,1) + X2=POSTRI(1,3)-POSTRI(1,1) + Y1=POSTRI(2,2)-POSTRI(2,1) + Y2=POSTRI(2,3)-POSTRI(2,1) + VOLTRI=ABS(X1*Y2-X2*Y1)/2.0D0 +*---- +* Analyze each face +*---- + CPPP(1)=POSTRI(1,2) + CPPP(2)=POSTRI(2,2) + CORPOS(1)=POSTRI(1,3) + CORPOS(2)=POSTRI(2,3) + DO IFACE=1,3 + ICOR=IFACE + ICORIN(ICOR)=0 +* write(6,'(A6,5x,2i5)') 'FACE ',IFACE,ICOR + AFPINT(IFACE)=DZERO + XFPINT(IFACE)=DZERO + YFPINT(IFACE)=DZERO + DNOR(IFACE)=DZERO + DTAN(IFACE)=DZERO + RADC=DZERO + DISTM=DZERO +*---- +* Find direction of face and its normal directed inward +* the triangle +*---- + DIRLIN(1,IFACE)=(POSTRI(1,IFACE)-CORPOS(1)) + DIRLIN(2,IFACE)=(POSTRI(2,IFACE)-CORPOS(2)) + DIRN=SQRT(DIRLIN(1,IFACE)**2+DIRLIN(2,IFACE)**2) + DIRLIN(1,IFACE)=DIRLIN(1,IFACE)/DIRN + DIRLIN(2,IFACE)=DIRLIN(2,IFACE)/DIRN + DIRFAC(1,IFACE)=-DIRLIN(2,IFACE) + DIRFAC(2,IFACE)=DIRLIN(1,IFACE) +* write(6,*) 'Corner and pin position with respect to corner' +* write(6,'(4F20.10)') +* > CORPOS(1),CORPOS(2),PINPOS(1)-CORPOS(1), +* > PINPOS(2)-CORPOS(2) +* write(6,*) 'Face tangent and normal' +* write(6,'(4F20.10)') +* > DIRLIN(1,IFACE),DIRLIN(2,IFACE),DIRFAC(1,IFACE),DIRFAC(2,IFACE) + DO IDIR=1,2 + DISTC=PINPOS(IDIR)-CORPOS(IDIR) + DISTM=DISTM+(CPPP(IDIR)-CORPOS(IDIR))*DIRFAC(IDIR,IFACE) + DNOR(IFACE)=DNOR(IFACE)+DISTC*DIRFAC(IDIR,IFACE) + DTAN(IFACE)=DTAN(IFACE)+DISTC*DIRLIN(IDIR,IFACE) + RADC=RADC+DISTC**2 + ENDDO +* write(6,*) 'Distance of center to face',DNOR(IFACE) + IF(DNOR(IFACE) .GT. DISTM+PINPOS(0)) THEN + NXTITA=0 + VOLINT=DZERO + IF(IPRINT .GE. 200) THEN + WRITE(IOUT,6012) NAMSBR,NXTITA,VOLINT + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN + ELSE IF(DNOR(IFACE) .LT. -PINPOS(0)) THEN + NXTITA=0 + VOLINT=DZERO + IF(IPRINT .GE. 200) THEN + WRITE(IOUT,6012) NAMSBR,NXTITA,VOLINT + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN + ELSE IF(DNOR(IFACE) .GE. PINPOS(0)) THEN + NFPINS=NFPINS+1 + NKPINS=NKPINS+1 + ELSE +*---- +* Point of intersection of current face with pin +*---- + XFPINT(IFACE)=DNOR(IFACE) + YFPINT(IFACE)=SQRT(RADP2-XFPINT(IFACE)**2) + AFPINT(IFACE)=ACOS(XFPINT(IFACE)/PINPOS(0)) + VT=XFPINT(IFACE)*YFPINT(IFACE) + DISTS=DTAN(IFACE)-YFPINT(IFACE) + DISTF=DTAN(IFACE)+YFPINT(IFACE) +* write(6,*) 'DISTS/DISTF/DIRN=',DISTS,DISTF,DIRN + IF(DISTS .LE. DIRN .AND. DISTF .GT. DZERO) THEN +* write(6,'(A9,2X,7F20.10)') +* > 'Volout 1=',XFPINT(IFACE),YFPINT(IFACE), +* > AFPINT(IFACE),VT,VOLOUT, +* > RADP2*AFPINT(IFACE)-VT,VOLOUT+RADP2*AFPINT(IFACE)-VT + VOLOUT=VOLOUT+RADP2*AFPINT(IFACE)-VT + ELSE + NKPINS=NKPINS+1 +* write(6,'(A9,2X,7F20.10)') +* > 'Volout 3=',XFPINT(IFACE),YFPINT(IFACE), +* > AFPINT(IFACE),VT,VOLOUT, +* > RADP2*AFPINT(IFACE)-VT,VOLOUT + VOLOUT=VOLOUT + ENDIF + ENDIF + IF(RADC .LT. RADP2) THEN +*---- +* Identify corners in pin +*---- + ICORIN(ICOR)=1 + NCIN=NCIN+1 + ENDIF + CPPP(1)=CORPOS(1) + CPPP(2)=CORPOS(2) + CORPOS(1)=POSTRI(1,IFACE) + CORPOS(2)=POSTRI(2,IFACE) + ENDDO + IF(NFPINS .EQ. 3) THEN +*---- +* Pin completely inside triangle +*---- + NXTITA=2 + VOLINT=PI*RADP2 + ELSE IF(NCIN .EQ. 3) THEN +*---- +* Triangle completely inside pin +*---- + NXTITA=1 + VOLINT=VOLTRI + ELSE IF(NKPINS .EQ. 3) THEN +*---- +* No intersection between triangle and pin +*---- + NXTITA=0 + VOLINT=DZERO + ELSE +*---- +* For corners inside pin, find intersection of outside surfaces +* and remove from VOLOUT +*---- + NXTITA=-1 + DO ICOR=1,3 +* write(6,*) 'ICORIN=',ICOR,ICORIN(ICOR) + IF(ICORIN(ICOR) .EQ. 1) THEN +*---- +* Point of intersection of previous face with pin in the positive +* direction +*---- + IFACE=ICOR-1 + IF(IFACE .LE. 0) IFACE=3+IFACE + IC=ICOR-2 + IF(IC .LE. 0) IC=3+IC + DO IDIR=1,2 + TC2(IDIR)=POSTRI(IDIR,IC) + > +(DTAN(IFACE)+YFPINT(IFACE))*DIRLIN(IDIR,IFACE) + ENDDO +* write(6,*) 'TC2=',TC2(1),TC2(2) +*---- +* Point of intersection of current face with pin in the negative +* direction +*---- + IFACE=ICOR + IC=ICOR-1 + IF(IC .LE. 0) IC=3+IC + DO IDIR=1,2 + TC1(IDIR)=POSTRI(IDIR,IC) + > +(DTAN(IFACE)-YFPINT(IFACE))*DIRLIN(IDIR,IFACE) + ENDDO +* write(6,*) 'TC1=',TC1(1),TC1(2) +*---- +* Triangle outside is identified by CORPOS(*,IC),TC1,TC2 +* Compute its volume +*---- + X1=TC1(1)-POSTRI(1,IC) + X2=TC2(1)-POSTRI(1,IC) + Y1=TC1(2)-POSTRI(2,IC) + Y2=TC2(2)-POSTRI(2,IC) + VOLTRI=ABS(X1*Y2-X2*Y1)/2.0D0 +* write(6,*) 'Triangle 1=',X1,X2,Y1,Y2,VOLTRI +*---- +* Add contribution from annular sector between T1 and T2 +* Compute distance of T1 to T2 +*---- + Y2=DZERO + DO IDIR=1,2 + Y2=Y2+(TC1(IDIR)-TC2(IDIR))**2 + ENDDO + Y2=Y2/4.0D0 + X2=SQRT(RADP2-Y2) + Y2=SQRT(Y2) + ALPHA=ACOS(X2/PINPOS(0)) +* write(6,*) 'Triangle 2=',X2,Y2,ALPHA, +* > VOLOUT,RADP2*ALPHA,X2*Y2,RADP2*ALPHA-X2*Y2+VOLTRI + VOLOUT=VOLOUT-RADP2*ALPHA+X2*Y2-VOLTRI + ENDIF + ENDDO + VOLINT=PI*RADP2-VOLOUT +* write(6,*) 'Triangle 3=',VOLINT,PI*RADP2,VOLOUT + ENDIF + IF(IPRINT .GE. 200) THEN + WRITE(IOUT,6012) NAMSBR,NXTITA,VOLINT + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT('POSTRI={',5(F20.10,','),F20.10,'};') + 6011 FORMAT('PINPOS={',2(F20.10,','),F20.10,'};') + 6012 FORMAT(A6,'={',I5,',',F20.10,'};') + END diff --git a/Dragon/src/NXTLCA.f b/Dragon/src/NXTLCA.f new file mode 100644 index 0000000..9469b2c --- /dev/null +++ b/Dragon/src/NXTLCA.f @@ -0,0 +1,809 @@ +*DECK NXTLCA + FUNCTION NXTLCA(IPRINT,ITST ,NDIM ,MXMESH,LINMAX, + > MESH ,ORITRK,DIRTRK,DCMESH, + > NBCOR ,NBSINT,ISINT ,TRKLSI) +* +*---------- +* +*Purpose: +* To track a Cartesian 2-D or 3-D geometry +* using the NXT tracking procedure. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau. +* +*Parameters: input +* IPRINT print level. +* ITST type of tracking, where: +* =-1 only the exact geometry +* is considered taking into account the +* submesh in each direction; +* = 0 only the global geometry +* is considered without taking into account the +* submesh in each direction; +* = 1 both the global +* geometry (as a first step) and the exact geometry +* are considered taking into account the +* submesh in each direction. +* NDIM dimension of problem. +* MXMESH maximum number of spatial subdivision in +* $X$, $Y$ or $Z$. +* LINMAX maximum number of segments in a track. +* MESH effective number of spatial subdivision in +* each direction ($X$, $Y$ and $Z$). +* ORITRK a point on the track (origin). +* DIRTRK the track direction (director cosines). +* DCMESH spatial description of the parallepiped. +* +*Parameters: output +* NXTLCA number of surfaces intersected. +* NBCOR number of corner found for each external faces. +* NBSINT number of surface crossed by track. +* ISINT direction of plane intersected and +* the surfaces crossed by the track. +* TRKLSI the surface intersection distance. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,ITST,NDIM,MXMESH,LINMAX + INTEGER MESH(NDIM) + DOUBLE PRECISION ORITRK(NDIM), + > DIRTRK(NDIM), + > DCMESH(-1:MXMESH,5) + INTEGER NBCOR(2),NBSINT + INTEGER ISINT(0:5,LINMAX) + DOUBLE PRECISION TRKLSI(LINMAX) + INTEGER NXTLCA +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTLCA') + DOUBLE PRECISION DCUTOF,DZERO,DONE,DTWO + PARAMETER (DCUTOF=1.0D-8,DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Local variables +*---- + INTEGER IDIR,INEXT,IFRST,ILAST,IFACE,IOFF,NBTINT + INTEGER JDIR,JNEXT,JFRST,JLAST,JFACE,JOFF,JSUR + INTEGER KDIR,KNEXT,KFRST,KLAST,KFACE,KOFF,KSUR + INTEGER IC1,IDIRS,IDIRF,IDIRB,IRFIN(5) + INTEGER ISDIR,JSDIR,KSDIR + DOUBLE PRECISION DP1,DP2,TRKK,TRKJ + DOUBLE PRECISION TRKDIS,TRKOLD,DELTKD +*---- +* Data +*---- + CHARACTER CDIR(4)*1 + SAVE CDIR + DATA CDIR /'X','Y','Z','R'/ +*---- +* Verify ITST option and reset to default value if invalid +*---- + IF(ITST .LT. -1 .OR. ITST .GT. 1) THEN +*---- +* Reset ITST=1 (complete analysis) if the value of ITST is invalid +*---- + ITST=1 + ENDIF + KFRST=1 + KLAST=1 + KNEXT=1 + TRKK=DZERO + TRKOLD=DZERO + KOFF=1 +*---- +* Initialise output vectors +*---- + NBCOR(1)=0 + NBCOR(2)=0 + NBSINT=0 + ISINT(0:5,:LINMAX)=0 + TRKLSI(:LINMAX)=DZERO +*---- +* Print header if required +*---- + IF(IPRINT .GT. 1000) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6011) 'meshx={ ' + WRITE(IOUT,6012) (DCMESH(IC1,1),IC1=0,MESH(1)) + WRITE(IOUT,6013) + WRITE(IOUT,6011) 'meshy={ ' + WRITE(IOUT,6012) (DCMESH(IC1,2),IC1=0,MESH(2)) + WRITE(IOUT,6013) + IF(NDIM .EQ. 3) THEN + WRITE(IOUT,6011) 'meshz={ ' + WRITE(IOUT,6012) (DCMESH(IC1,3),IC1=0,MESH(3)) + WRITE(IOUT,6013) + ENDIF + WRITE(IOUT,6011) 'trackorigin={ ' + WRITE(IOUT,6012) ORITRK + WRITE(IOUT,6013) + WRITE(IOUT,6011) 'trackdirection={ ' + WRITE(IOUT,6012) DIRTRK + WRITE(IOUT,6013) + ENDIF +*---- +* For option ITST=0, 1, consider global geometry +* and test if line crosses this geometry. +*---- + IF(ITST .EQ. 0 .OR. ITST .EQ. 1) THEN +*---- +* Scan over Cartesian directions +*---- + DO 100 IDIR=1,NDIM +*---- +* IDIR is main planes direction ($X$, $Y$ or $Z$) +* JDIR is first direction of plane perpendicular +* to main direction ($Y, $Z$ or $X$). +* KDIR is second direction of plane perpendicular +* to main direction ($Z$, $X$ or $Y$). +*---- + JDIR=MOD(IDIR,NDIM)+1 + KDIR=MOD(IDIR+1,NDIM)+1 +*---- +* Select planes order in direction IDIR +*---- + IF(DIRTRK(IDIR) .LT. 0) THEN + INEXT=-1 + IFRST=MESH(IDIR)+1 + ILAST=1 + ELSE + INEXT=1 + IFRST=1 + ILAST=MESH(IDIR)+1 + ENDIF +*---- +* Select planes order in direction JDIR +*---- + IF(DIRTRK(JDIR) .LT. 0) THEN + JNEXT=-1 + JFRST=MESH(JDIR)+1 + JLAST=1 + ELSE + JNEXT=1 + JFRST=1 + JLAST=MESH(JDIR)+1 + ENDIF +*---- +* Select planes order in direction KDIR (if required) +*---- + IF(NDIM .EQ. 3) THEN + IF(DIRTRK(KDIR) .LT. 0) THEN + KNEXT=-1 + KFRST=MESH(KDIR)+1 + KLAST=1 + ELSE + KNEXT=1 + KFRST=1 + KLAST=MESH(KDIR)+1 + ENDIF + ENDIF +*---- +* Scan over planes in direction IDIR +*---- + DO 101 IFACE=IFRST,ILAST,ILAST-IFRST +*---- +* Compute track length required to reach a face +* and intersection point with infinite plane +*---- + TRKDIS=(DCMESH(IFACE-1,IDIR)-ORITRK(IDIR))/DIRTRK(IDIR) + TRKJ=DBLE(JNEXT)*(TRKDIS*DIRTRK(JDIR)+ORITRK(JDIR)) + IF(NDIM .EQ. 3) THEN + TRKK=DBLE(KNEXT)*(TRKDIS*DIRTRK(KDIR)+ORITRK(KDIR)) + ENDIF +*---- +* Test if point is in finite Cartesian plane (j,k) +*---- + DP1=DBLE(JNEXT)*DCMESH(JFRST-1,JDIR) + DP2=DBLE(JNEXT)*DCMESH(JLAST-1,JDIR) + IF(TRKJ .GE. DP1-DCUTOF + > .AND. TRKJ .LE. DP2+DCUTOF ) THEN + IF(NDIM .EQ. 3) THEN +*---- +* For 3-D, consider intersection with plane +*---- + DP1=DBLE(KNEXT)*DCMESH(KFRST-1,KDIR) + DP2=DBLE(KNEXT)*DCMESH(KLAST-1,KDIR) + IF(TRKK .GE. DP1-DCUTOF + > .AND. TRKK .LE. DP2+DCUTOF ) THEN +*---- +* If no point, save distance set NBSINT to 1 and continue +* if one point already known, check if this point is +* at a different distance exit, otherwise, this point +* is already identified (intersection of 2 or more planes) +* just continue +*---- + IF(NBSINT .EQ. 0) THEN + NBSINT=1 + TRKOLD=TRKDIS + ELSE IF(TRKOLD .NE. TRKDIS) THEN + NBSINT=2 + GO TO 105 + ENDIF + ENDIF + ELSE +*---- +* For 2-D, intersection with a line is sufficient +*---- + IF(NBSINT .EQ. 0) THEN + NBSINT=1 + TRKOLD=TRKDIS + ELSE IF(TRKOLD .NE. TRKDIS) THEN + NBSINT=2 + GO TO 105 + ENDIF + ENDIF + ENDIF + 101 CONTINUE + 100 CONTINUE + 105 CONTINUE + ELSE +*---- +* If ITST=-1, assume that 2 surface are intersected +* and continue +*---- + NBSINT=2 + ENDIF + NXTLCA=NBSINT +*---- +* If line does not intersect any surfaces, exit +*---- + IF(NXTLCA .EQ. 0) THEN + IF(IPRINT .GT. 1000) THEN + WRITE(IOUT,6002) NAMSBR + ENDIF + RETURN + ENDIF +*---- +* If line does not intersect 2 surfaces, abort +*---- + IF(NBSINT .NE. 2) THEN + IF(NBSINT .EQ. 1) CALL XABORT(NAMSBR// + > ': Invalid line since it intersects only 1 surface') + IF(IPRINT .GT. 1000) + > WRITE(IOUT,9000) NBSINT + ENDIF +*---- +* If ITST=0, return number of surfaces intersected by line +*---- + IF(ITST .EQ. 0) RETURN +*---- +* If ITST=1 and NXTLCA=2 or ITST=-1 +* track geometry with submesh +*---- + NBSINT=0 +*---- +* Scan over Cartesian directions +*---- + DO 110 IDIR=1,NDIM +*---- +* IDIR is main planes direction ($X$, $Y$ or $Z$) +* JDIR is first direction of plane perpendicular +* to main direction ($Y, $Z$ or $X$). +* KDIR is second direction of plane perpendicular +* to main direction ($Z$, $X$ or $Y$). +*---- + JDIR=MOD(IDIR,NDIM)+1 + KDIR=MOD(IDIR+1,NDIM)+1 +*---- +* Select planes order in direction IDIR +*---- + IF(DIRTRK(IDIR) .LT. 0) THEN + INEXT=-1 + IFRST=MESH(IDIR)+1 + ILAST=1 + IOFF=-1 + ELSE + INEXT=1 + IFRST=1 + ILAST=MESH(IDIR)+1 + IOFF=0 + ENDIF +*---- +* Select planes order in direction JDIR +*---- + IF(DIRTRK(JDIR) .LT. 0) THEN + JNEXT=-1 + JFRST=MESH(JDIR)+1 + JLAST=2 + JOFF=-1 + ELSE + JNEXT=1 + JFRST=1 + JLAST=MESH(JDIR) + JOFF=0 + ENDIF +*---- +* Select planes order in direction KDIR (if required) +*---- + IF(NDIM .EQ. 3) THEN + IF(DIRTRK(KDIR) .LT. 0) THEN + KNEXT=-1 + KFRST=MESH(KDIR)+1 + KLAST=2 + KOFF=-1 + ELSE + KNEXT=1 + KFRST=1 + KLAST=MESH(KDIR) + KOFF=0 + ENDIF + ENDIF +*---- +* Scan over planes in direction IDIR +*---- + DO 111 IFACE=IFRST,ILAST,INEXT + ISDIR=IDIR + IF(IFACE .EQ. IFRST .OR. IFACE .EQ. ILAST) + > ISDIR=-ISDIR +*---- +* Compute track length required to reach a face +* and intersection point with infinite plane +*---- + TRKDIS=(DCMESH(IFACE-1,IDIR)-ORITRK(IDIR))/DIRTRK(IDIR) + TRKJ=DBLE(JNEXT)*(TRKDIS*DIRTRK(JDIR)+ORITRK(JDIR)) + IF(NDIM .EQ. 3) THEN + TRKK=DBLE(KNEXT)*(TRKDIS*DIRTRK(KDIR)+ORITRK(KDIR)) + ENDIF +*---- +* Test if point is in finite Cartesian plane (j,k) and add to number +* of surfaces crossed if this is the case +* (j=1 or NPLJ+1 and k=1 or NPLK+1) +* For values of j=1,NPLJ and k=1,NPLK a volume was crossed +*---- + DO 112 JFACE=JFRST,JLAST,JNEXT + JSDIR=JDIR + IF(JFACE .EQ. JFRST .OR. JFACE .EQ. JLAST) + > JSDIR=-JSDIR + DP1=DBLE(JNEXT)*DCMESH(JFACE-1,JDIR) + DP2=DBLE(JNEXT)*DCMESH(JFACE+JNEXT-1,JDIR) + IF(TRKJ .GE. DP1-DCUTOF + > .AND. TRKJ .LE. DP2+DCUTOF ) THEN + IF(NDIM .EQ. 3) THEN +*---- +* For 3-D, consider intersection with plane +*---- + DO 113 KFACE=KFRST,KLAST,KNEXT + KSDIR=KDIR + IF(KFACE .EQ. KFRST .OR. KFACE .EQ. KLAST) + > KSDIR=-KSDIR + DP1=DBLE(KNEXT)*DCMESH(KFACE-1,KDIR) + DP2=DBLE(KNEXT)*DCMESH(KFACE+KNEXT-1,KDIR) + IF(TRKK .GE. DP1-DCUTOF + > .AND. TRKK .LE. DP2+DCUTOF ) THEN + NBSINT=NBSINT+1 + IF(IPRINT .GT. 1000) THEN + WRITE(IOUT,6011) 'Intersection at ' + WRITE(IOUT,6014) IDIR,IFACE, + > JDIR,JFACE+JOFF,KDIR,KFACE+KOFF + WRITE(IOUT,6015) TRKDIS,DIRTRK + ENDIF + IF(NBSINT .EQ. 1) THEN + ISINT(0,NBSINT)=ISDIR + ISINT(IDIR,NBSINT)=-IFACE + ISINT(JDIR,NBSINT)=JFACE+JOFF + ISINT(KDIR,NBSINT)=KFACE+KOFF + TRKLSI(NBSINT)=TRKDIS + ELSE +*---- +* Scan previous distances and reorder if necessary +*---- + NBTINT=NBSINT + DO 120 JSUR=NBTINT-1,1,-1 + DELTKD=TRKDIS-TRKLSI(JSUR) + IF(DELTKD .GE. -DCUTOF) THEN +*---- +* For more than one intersection at a given distance: +* a) if this is an external surface, store the distance +* for corner duplication +* b) if this is an internal surface select adequate next region +* to cross and reset NBSINT=NBSINT-1 +*---- + IF(ABS(DELTKD) .LE. DCUTOF) THEN + IF(ISDIR .GT. 0 ) THEN + IF(ISINT(0,JSUR) .GT. 0) THEN + ISINT(0,JSUR)=ISINT(0,JSUR)+10*ISDIR + ISINT(IDIR,JSUR)=-IFACE + ENDIF + NBSINT=NBSINT-1 +* IF(IPRINT .GT. 1000) +* >write(6,*) 'SurInt A =',JSUR,IFACE,JFACE,KFACE, +* >ISINT(0,JSUR),ISINT(IDIR,JSUR),ISINT(JDIR,JSUR), +* >ISINT(KDIR,JSUR), +* >TRKDIS,TRKLSI(JSUR) + GO TO 125 + ELSE + IF(ISINT(0,JSUR) .GT. 0) THEN + ISINT(0,JSUR)=ISDIR + ISINT(IDIR,JSUR)=-IFACE + ISINT(JDIR,JSUR)=JFACE+JOFF + ISINT(KDIR,JSUR)=KFACE+KOFF + NBSINT=NBSINT-1 + GO TO 125 + ENDIF +* IF(IPRINT .GT. 1000) +* >write(6,*) 'SurInt B =',JSUR,IFACE,JFACE,KFACE, +* >ISINT(0,JSUR),ISINT(IDIR,JSUR),ISINT(JDIR,JSUR), +* >ISINT(KDIR,JSUR), +* >TRKDIS,TRKLSI(JSUR) + ENDIF + ENDIF + DO 121 KSUR=NBTINT,JSUR+2,-1 + ISINT(0,KSUR)=ISINT(0,KSUR-1) + ISINT(IDIR,KSUR)=ISINT(IDIR,KSUR-1) + ISINT(JDIR,KSUR)=ISINT(JDIR,KSUR-1) + ISINT(KDIR,KSUR)=ISINT(KDIR,KSUR-1) + TRKLSI(KSUR)=TRKLSI(KSUR-1) + 121 CONTINUE + ISINT(0,JSUR+1)=ISDIR + ISINT(IDIR,JSUR+1)=-IFACE + ISINT(JDIR,JSUR+1)=JFACE+JOFF + ISINT(KDIR,JSUR+1)=KFACE+KOFF + TRKLSI(JSUR+1)=TRKDIS +* IF(IPRINT .GT. 1000) +* >write(6,*) 'SurInt C =',JSUR,IFACE,JFACE,KFACE, +* >ISINT(0,JSUR),ISINT(IDIR,JSUR),ISINT(JDIR,JSUR), +* >ISINT(KDIR,JSUR), +* >TRKDIS,TRKLSI(JSUR) + GO TO 125 + ENDIF + 120 CONTINUE + DO 122 KSUR=NBTINT,2,-1 + ISINT(0,KSUR)=ISINT(0,KSUR-1) + ISINT(IDIR,KSUR)=ISINT(IDIR,KSUR-1) + ISINT(JDIR,KSUR)=ISINT(JDIR,KSUR-1) + ISINT(KDIR,KSUR)=ISINT(KDIR,KSUR-1) + TRKLSI(KSUR)=TRKLSI(KSUR-1) + 122 CONTINUE + ISINT(0,1)=ISDIR + ISINT(IDIR,1)=-IFACE + ISINT(JDIR,1)=JFACE+JOFF + ISINT(KDIR,1)=KFACE+KOFF + TRKLSI(1)=TRKDIS + 125 CONTINUE + ENDIF + ENDIF + 113 CONTINUE + ELSE +*---- +* For 2-D, intersection with a line is sufficient +*---- + NBSINT=NBSINT+1 + IF(IPRINT .GT. 1000) THEN + WRITE(IOUT,6011) 'Intersection at ' + WRITE(IOUT,6014) IDIR,IFACE,JDIR,JFACE + WRITE(IOUT,6015) TRKDIS,DIRTRK + ENDIF + IF(NBSINT .EQ. 1) THEN + ISINT(0,NBSINT)=ISDIR + ISINT(IDIR,NBSINT)=-IFACE + ISINT(JDIR,NBSINT)=JFACE+JOFF + TRKLSI(NBSINT)=TRKDIS +* IF(IPRINT .GT. 1000) +* >write(6,*) 'Int sur A =',NBSINT, +* >ISINT(IDIR,NBSINT),ISINT(JDIR,NBSINT),TRKLSI(NBSINT) + ELSE +*---- +* Scan previous distances and reorder if necessary +*---- + NBTINT=NBSINT + DO 130 JSUR=NBTINT-1,1,-1 + DELTKD=TRKDIS-TRKLSI(JSUR) + IF(DELTKD .GE. -DCUTOF) THEN +*---- +* For more than one intersection at a given distance: +* a) if this is an external surface, store the distance +* for corner duplication +* b) if this is an internal surface select adequate next region +* to cross and reset NBSINT=NBSINT-1 +*---- + IF(ABS(DELTKD) .LE. DCUTOF) THEN + IF(ISDIR .GT. 0 ) THEN + IF(ISINT(0,JSUR) .GT. 0) THEN + ISINT(0,JSUR)=ISINT(0,JSUR)+10*ISDIR + ISINT(IDIR,JSUR)=-IFACE + ENDIF + NBSINT=NBSINT-1 +* IF(IPRINT .GT. 1000) +* >write(6,*) 'Int sur A =',JSUR, +* >ISINT(IDIR,JSUR),ISINT(JDIR,JSUR),TRKLSI(JSUR) + GO TO 135 + ELSE + IF(ISINT(0,JSUR) .GT. 0) THEN + ISINT(0,JSUR)=ISDIR + ISINT(IDIR,JSUR)=-IFACE + ISINT(JDIR,JSUR)=JFACE+JOFF + NBSINT=NBSINT-1 +* IF(IPRINT .GT. 1000) +* >write(6,*) 'Int sur B =',JSUR, +* >ISINT(IDIR,JSUR),ISINT(JDIR,JSUR),TRKLSI(JSUR) + GO TO 135 + ENDIF + ENDIF + ENDIF + DO 131 KSUR=NBTINT,JSUR+2,-1 + ISINT(0,KSUR)=ISINT(0,KSUR-1) + ISINT(IDIR,KSUR)=ISINT(IDIR,KSUR-1) + ISINT(JDIR,KSUR)=ISINT(JDIR,KSUR-1) + TRKLSI(KSUR)=TRKLSI(KSUR-1) + 131 CONTINUE + ISINT(0,JSUR+1)=ISDIR + ISINT(IDIR,JSUR+1)=-IFACE + ISINT(JDIR,JSUR+1)=JFACE+JOFF + TRKLSI(JSUR+1)=TRKDIS +* IF(IPRINT .GT. 1000) +* >write(6,*) 'Int sur C =',JSUR+1, +* >ISINT(IDIR,JSUR+1),ISINT(JDIR,JSUR+1),TRKLSI(JSUR+1) + GO TO 135 + ENDIF + 130 CONTINUE + DO 132 KSUR=NBTINT,2,-1 + ISINT(0,KSUR)=ISINT(0,KSUR-1) + ISINT(IDIR,KSUR)=ISINT(IDIR,KSUR-1) + ISINT(JDIR,KSUR)=ISINT(JDIR,KSUR-1) + TRKLSI(KSUR)=TRKLSI(KSUR-1) + 132 CONTINUE + ISINT(0,1)=ISDIR + ISINT(IDIR,1)=-IFACE + ISINT(JDIR,1)=JFACE+JOFF + TRKLSI(1)=TRKDIS +* IF(IPRINT .GT. 1000) +* >write(6,*) 'Int sur D =',1, +* >ISINT(IDIR,1),ISINT(JDIR,1),TRKLSI(1) + 135 CONTINUE + ENDIF + ENDIF + ENDIF + 112 CONTINUE + 111 CONTINUE + 110 CONTINUE + IF(IPRINT .GT. 1000) THEN + WRITE(IOUT,6011) 'Intersections' + DO 210 JSUR=1,NBSINT + WRITE(IOUT,6010) TRKLSI(JSUR), + > (ISINT(IDIR,JSUR),IDIR=0,5) + 210 CONTINUE + ENDIF + IF(NBSINT .GE. 2) THEN +*---- +* Find number of corners for initial surface intersections +*---- + TRKDIS=TRKLSI(1) + NBCOR(1)=1 + DO 140 JSUR=2,NBSINT + DELTKD=TRKLSI(JSUR)-TRKDIS + IF(DELTKD .GT. DCUTOF) GO TO 145 + NBCOR(1)=NBCOR(1)+1 + 140 CONTINUE + 145 CONTINUE +*---- +* Find number of corners for final surface intersections +*---- + TRKDIS=TRKLSI(NBSINT) + NBCOR(2)=1 + DO 150 JSUR=NBSINT-1,1,-1 + DELTKD=TRKDIS-TRKLSI(JSUR) + IF(DELTKD .GT. DCUTOF) GO TO 155 + NBCOR(2)=NBCOR(2)+1 + 150 CONTINUE + 155 CONTINUE + ENDIF +*---- +* Print intersection points +*---- + IF(IPRINT .GT. 1000) THEN + WRITE(IOUT,6011) 'Initial planes ' + DO JSUR=1,NBCOR(1) + WRITE(IOUT,6010) TRKLSI(JSUR), + > (ISINT(IDIR,JSUR),IDIR=0,5) + ENDDO + IF(NBCOR(1)+1 .LE. NBSINT-NBCOR(2)) THEN + WRITE(IOUT,6011) 'Intermediate planes ' + DO JSUR=NBCOR(1)+1,NBSINT-NBCOR(2) + WRITE(IOUT,6010) TRKLSI(JSUR), + > (ISINT(IDIR,JSUR),IDIR=0,5) + ENDDO + ENDIF + WRITE(IOUT,6011) 'Final planes ' + DO JSUR=NBSINT-NBCOR(2)+1,NBSINT + WRITE(IOUT,6010) TRKLSI(JSUR), + > (ISINT(IDIR,JSUR),IDIR=0,5) + ENDDO + ENDIF +*---- +* Identify final faces +*---- + DO JSUR=NBSINT,NBSINT-NBCOR(2)+1,-1 + DO IDIRS=0,5 + ISINT(IDIRS,JSUR+1)=ISINT(IDIRS,JSUR) + ENDDO + TRKLSI(JSUR+1)=TRKLSI(JSUR) + IDIRS=ABS(ISINT(0,JSUR+1)) + IF(IDIRS .GT. 10) CALL XABORT(NAMSBR// + >': Final outer surface identified as an internal corner') + IDIRF=ABS(ISINT(IDIRS,JSUR+1)) + IF(IDIRF .EQ. 1) THEN + ISINT(IDIRS,JSUR+1)=-1 + ELSE IF(IDIRF .EQ. MESH(IDIRS)+1) THEN + ISINT(IDIRS,JSUR+1)=-2 + ELSE +*---- +* Print information for debug +*---- + WRITE(IOUT,6011) 'meshx={ ' + WRITE(IOUT,6012) (DCMESH(IC1,1),IC1=0,MESH(1)) + WRITE(IOUT,6013) + WRITE(IOUT,6011) 'meshy={ ' + WRITE(IOUT,6012) (DCMESH(IC1,2),IC1=0,MESH(2)) + WRITE(IOUT,6013) + IF(NDIM .EQ. 3) THEN + WRITE(IOUT,6011) 'meshz={ ' + WRITE(IOUT,6012) (DCMESH(IC1,3),IC1=0,MESH(3)) + WRITE(IOUT,6013) + ENDIF + WRITE(IOUT,6011) 'trackorigin={ ' + WRITE(IOUT,6012) ORITRK + WRITE(IOUT,6013) + WRITE(IOUT,6011) 'trackdirection={ ' + WRITE(IOUT,6012) DIRTRK + WRITE(IOUT,6013) + WRITE(IOUT,6011) 'Initial planes ' + DO KSUR=1,NBCOR(1) + WRITE(IOUT,6010) TRKLSI(KSUR), + > (ISINT(IDIR,KSUR),IDIR=0,5) + ENDDO + IF(NBCOR(1)+1 .LE. NBSINT-NBCOR(2)) THEN + WRITE(IOUT,6011) 'Intermediate planes ' + DO KSUR=NBCOR(1)+1,NBSINT-NBCOR(2) + WRITE(IOUT,6010) TRKLSI(KSUR), + > (ISINT(IDIR,KSUR),IDIR=0,5) + ENDDO + ENDIF + WRITE(IOUT,6011) 'Final planes ' + DO KSUR=NBSINT-NBCOR(2)+1,NBSINT + WRITE(IOUT,6010) TRKLSI(KSUR), + > (ISINT(IDIR,KSUR),IDIR=0,5) + ENDDO + WRITE(IOUT,9001) TRKLSI(JSUR), + > (ISINT(IDIR,JSUR),IDIR=0,5),IDIRF + CALL XABORT(NAMSBR//': Invalid final '//CDIR(IDIRS)// + >' directed surface') + ENDIF + ENDDO +*---- +* Identify regions +*---- + DO JSUR=NBSINT-NBCOR(2)+1,NBCOR(1)+1,-1 + DO IDIRS=1,5 + IRFIN(IDIRS)=ABS(ISINT(IDIRS,JSUR-1)) + IF(ISINT(IDIRS,JSUR) .LT. 0 ) THEN + IF(ISINT(IDIRS,JSUR-1) .LT. 0 ) THEN + IRFIN(IDIRS)=-MAX(ISINT(IDIRS,JSUR-1),ISINT(IDIRS,JSUR)) + ENDIF + ELSE + IF(ISINT(IDIRS,JSUR-1) .LT. 0 ) THEN + IRFIN(IDIRS)=ISINT(IDIRS,JSUR) + ENDIF + ENDIF + ENDDO + TRKLSI(JSUR)=TRKLSI(JSUR)-TRKLSI(JSUR-1) + DO IDIRS=1,5 + IF(ISINT(IDIRS,JSUR) .LT. 0 ) THEN + ISINT(IDIRS,JSUR)=IRFIN(IDIRS) + ELSE + ISINT(IDIRS,JSUR)=ISINT(IDIRS,JSUR) + ENDIF + ENDDO + ENDDO +*---- +* Identify initial face +*---- + DO JSUR=1,NBCOR(1) + IDIRS=ABS(ISINT(0,JSUR)) + IF(IDIRS .GT. 10) CALL XABORT(NAMSBR// + >': Initial outer surface identified as an internal corner') + IDIRB=ABS(ISINT(IDIRS,JSUR)) + IF(IDIRB .EQ. 1) THEN + ISINT(IDIRS,JSUR)=-1 + ELSE IF(IDIRB .EQ. MESH(IDIRS)+1) THEN + ISINT(IDIRS,JSUR)=-2 + ELSE +*---- +* Print information for debug +*---- + WRITE(IOUT,6011) 'meshx={ ' + WRITE(IOUT,6012) (DCMESH(IC1,1),IC1=0,MESH(1)) + WRITE(IOUT,6013) + WRITE(IOUT,6011) 'meshy={ ' + WRITE(IOUT,6012) (DCMESH(IC1,2),IC1=0,MESH(2)) + WRITE(IOUT,6013) + IF(NDIM .EQ. 3) THEN + WRITE(IOUT,6011) 'meshz={ ' + WRITE(IOUT,6012) (DCMESH(IC1,3),IC1=0,MESH(3)) + WRITE(IOUT,6013) + ENDIF + WRITE(IOUT,6011) 'trackorigin={ ' + WRITE(IOUT,6012) ORITRK + WRITE(IOUT,6013) + WRITE(IOUT,6011) 'trackdirection={ ' + WRITE(IOUT,6012) DIRTRK + WRITE(IOUT,6013) + WRITE(IOUT,6011) 'Initial planes ' + DO KSUR=1,NBCOR(1) + WRITE(IOUT,6010) TRKLSI(KSUR), + > (ISINT(IDIR,KSUR),IDIR=0,5) + ENDDO + IF(NBCOR(1)+1 .LE. NBSINT-NBCOR(2)) THEN + WRITE(IOUT,6011) 'Intermediate planes ' + DO KSUR=NBCOR(1)+1,NBSINT-NBCOR(2) + WRITE(IOUT,6010) TRKLSI(KSUR), + > (ISINT(IDIR,KSUR),IDIR=0,5) + ENDDO + ENDIF + WRITE(IOUT,6011) 'Final planes ' + DO KSUR=NBSINT-NBCOR(2)+1,NBSINT + WRITE(IOUT,6010) TRKLSI(KSUR), + > (ISINT(IDIR,KSUR),IDIR=0,5) + ENDDO + WRITE(IOUT,9001) TRKLSI(JSUR), + > (ISINT(IDIR,JSUR),IDIR=0,5),IDIRB + CALL XABORT(NAMSBR//': Invalid initial '//CDIR(IDIRS)// + >' directed surface') + ENDIF + ENDDO +*---- +* Print final track information +*---- + IF(IPRINT .GT. 1000) THEN + WRITE(IOUT,6011) 'Initial face ' + DO JSUR=1,NBCOR(1) + WRITE(IOUT,6010) TRKLSI(JSUR), + > (ISINT(IDIR,JSUR),IDIR=0,5) + ENDDO + WRITE(IOUT,6011) 'Regions ' + DO JSUR=NBCOR(1)+1,NBSINT-NBCOR(2)+1 + WRITE(IOUT,6010) TRKLSI(JSUR), + > (ISINT(IDIR,JSUR),IDIR=0,5) + ENDDO + WRITE(IOUT,6011) 'Final face ' + DO JSUR=NBSINT-NBCOR(2)+2,NBSINT+1 + WRITE(IOUT,6010) TRKLSI(JSUR), + > (ISINT(IDIR,JSUR),IDIR=0,5) + ENDDO + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6002 FORMAT(' No region crossed'/ + > ' Output from --',A6,'-- completed *)') + 6010 FORMAT(1X,F25.16,6I10) + 6011 FORMAT(A20) + 6012 FORMAT(6(1X,F25.16,:,',')) + 6013 FORMAT('};') + 6014 FORMAT(6I10) + 6015 FORMAT(6(F25.16,2X)) + 9000 FORMAT(' Warning : ',I10,' surfaces crossed') + 9001 FORMAT(1X,F25.16,7I10) + END diff --git a/Dragon/src/NXTLCU.f b/Dragon/src/NXTLCU.f new file mode 100644 index 0000000..b6d43bc --- /dev/null +++ b/Dragon/src/NXTLCU.f @@ -0,0 +1,619 @@ +*DECK NXTLCU + SUBROUTINE NXTLCU(IPRINT,MXSLIN,ICOMB , + > NBCOR ,NBSINT,ISINT ,TRKLSI) +* +*---------- +* +*Purpose: +* To merge two sets of tracks and store the result in tracking +* vector with adequate region identification. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau. +* +*Parameters: input +* IPRINT print level. +* MXSLIN maximum number of segments in a subgeometry track. +* ICOMB flag for combination if two sets of tracks with: +* ICOMB=-1 one considers only the first +* track set (Cartesian); ICOMB=-2 one considers +* only the second track set (annular); ICOMB=1, +* the Cartesian and annular regions are super imposed while +* preserving the outer Cartesian boundary; +* ICOMB=2 the Cartesian and annular regions +* are super imposed while +* preserving the outer annular boundary. +* +*Parameters: input/output +* NBCOR number of corner found for each external faces. +* NBSINT number of surface crossed by track. +* ISINT direction of plane intersected and +* the surfaces crossed by the track. +* TRKLSI the surface intersection distance. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,MXSLIN,ICOMB,NBCOR(2,3),NBSINT(3) + INTEGER ISINT(0:5,MXSLIN,3) + DOUBLE PRECISION TRKLSI(MXSLIN,3) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTLCU') + DOUBLE PRECISION DCUTOF,DZERO,DONE,DTWO + PARAMETER (DCUTOF=1.0D-7,DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Local variables +*---- + INTEGER IT,IC,IA,IG,ISURC,JSURC,ISURA,ISURG,JSURG, + > IFIC,ILIC,ITIC,IFIA,ILIA,ITIA,ISUR,JSUR,ITB,ITE + INTEGER IDIR,KDIR,JDIR,LDIR,IRADG,IFSG + DOUBLE PRECISION REFLOC,REFLOA,REFLOG,CURLOC,CURLOA, + > THICK,DELCUR +*---- +* Data +*---- + CHARACTER NAMTYP(3)*12 + SAVE NAMTYP + DATA NAMTYP + > /'Cartesian ','Annular ','Combined '/ +*---- +* Print header if required +*---- + IF(IPRINT .GT. 1000) THEN + WRITE(IOUT,6000) NAMSBR + ITB=1 + ITE=2 + IF(ICOMB .EQ. -1) ITE=1 + IF(ICOMB .EQ. -2) ITB=2 + DO IT=ITB,ITE + WRITE(IOUT,6016) NAMTYP(IT) + WRITE(IOUT,6011) 'Initial face' + DO JSUR=1,NBCOR(1,IT) + WRITE(IOUT,6010) TRKLSI(JSUR,IT), + > (ISINT(IDIR,JSUR,IT),IDIR=1,5) + ENDDO + WRITE(IOUT,6011) 'Regions ' + DO JSUR=NBCOR(1,IT)+1,NBSINT(IT)-NBCOR(2,IT)+1 + WRITE(IOUT,6010) TRKLSI(JSUR,IT), + > (ISINT(IDIR,JSUR,IT),IDIR=1,5) + ENDDO + WRITE(IOUT,6011) 'Final face' + DO JSUR=NBSINT(IT)-NBCOR(2,IT)+2,NBSINT(IT)+1 + WRITE(IOUT,6010) TRKLSI(JSUR,IT), + > (ISINT(IDIR,JSUR,IT),IDIR=1,5) + ENDDO + ENDDO + ENDIF + IFIA=1 + ILIA=1 + LDIR=1 + JSURC=0 + ISURG=0 +*---- +* Create combined tracking +*---- + IC=1 + IA=2 + IG=3 + NBCOR(1,IG)=0 + NBCOR(2,IG)=0 + IF(ABS(ICOMB) .EQ. 1) THEN +*---- +* Save startup Cartesian face +*---- + ISURG=0 + IFIC=1 + ILIC=NBCOR(1,IC) + DO ISURC=IFIC,ILIC + ISURG=ISURG+1 + TRKLSI(ISURG,IG)=TRKLSI(ISURC,IC) + DO IDIR=1,5 + ISINT(IDIR,ISURG,IG)=ISINT(IDIR,ISURC,IC) + ENDDO + ENDDO + NBCOR(1,IG)=ISURG + ISURC=NBCOR(1,IC) + REFLOC=TRKLSI(ISURC,IC) + ISURA=NBCOR(1,2) + REFLOA=TRKLSI(ISURA,IA) + KDIR=0 + IRADG=0 + IFIC=NBCOR(1,IC)+1 + ILIC=NBSINT(IC)-NBCOR(2,IC)+1 + REFLOG=REFLOC + DELCUR=ABS(REFLOC-REFLOA) + IF(ICOMB .EQ. 1) THEN +*---- +* Find radial surface direction +*---- + DO IDIR=1,5 + IF(ISINT(IDIR,ISURA,IA) .LT. 0) THEN + KDIR=IDIR + ENDIF + ENDDO + IF(KDIR .EQ. 4) THEN +*---- +* It is an inner face, +* Scan Cartesian regions +*---- + ITIC=0 + DO ISURC=IFIC,ILIC + CURLOC=REFLOC+TRKLSI(ISURC,IC) + ISURG=ISURG+1 + DO JDIR=1,5 + ISINT(JDIR,ISURG,IG)=ISINT(JDIR,ISURC,IC) + ENDDO + TRKLSI(ISURG,IG)=CURLOC-REFLOG + ISINT(4,ISURG,IG)=IRADG + IF(ICOMB .EQ. 1) THEN + IF(REFLOA .LE. CURLOC) THEN + IRADG=ISINT(4,ISURA+1,IA) + THICK=REFLOA-REFLOG + TRKLSI(ISURG,IG)=THICK + REFLOG=REFLOA + GO TO 205 + ENDIF + ENDIF + ITIC=ITIC+1 + REFLOC=CURLOC + REFLOG=REFLOC + ENDDO + 205 CONTINUE + IFIC=IFIC+ITIC + ELSE IF(DELCUR .LT. DCUTOF) THEN +*---- +* It is an outer face, +* reset radial id for Cartesian face +*---- + REFLOG=REFLOC + IRADG=ISINT(4,1,IA) + DO ISURC=1,NBCOR(1,IC) + IF(ISINT(KDIR,ISURC,IC) .LT. 0) GO TO 105 + ENDDO + CALL XABORT (NAMSBR// + > ': Cartesian and annular face not coherent') + 105 CONTINUE + DO JSURG=1,NBCOR(1,IG) + ISINT(4,JSURG,IG)=IRADG + ENDDO + ELSE + CALL XABORT(NAMSBR// + > ': Initial Cartesian and annular faces are incoherent') + ENDIF + IFIA=NBCOR(1,IA)+1 + ILIA=NBSINT(IA)-NBCOR(2,IA)+1 + ELSE + REFLOG=REFLOC + ENDIF +*---- +* Scan Cartesian regions +*---- + DO ISURC=IFIC,ILIC + CURLOC=REFLOC+TRKLSI(ISURC,IC) +* IF(IPRINT .GT. 1000) +* > write(6,7000) 'ISURC=',ISURC,CURLOC, +* > (ISINT(JDIR,ISURC,IC),JDIR=1,5) + ISURG=ISURG+1 + DO JDIR=1,5 + ISINT(JDIR,ISURG,IG)=ISINT(JDIR,ISURC,IC) + ENDDO + TRKLSI(ISURG,IG)=CURLOC-REFLOG + ISINT(4,ISURG,IG)=IRADG + IF(ICOMB .EQ. 1) THEN + ITIA=0 +*---- +* Scan annular regions for intermediate mesh +*---- + DO ISURA=IFIA,ILIA + CURLOA=REFLOA+TRKLSI(ISURA,IA) + DELCUR=ABS(CURLOC-CURLOA) +* IF(IPRINT .GT. 1000) +* > write(6,7000) 'ISURA=',ISURA,CURLOA, +* > (ISINT(JDIR,ISURA,IA),JDIR=0,5) + IF(DELCUR .LT. DCUTOF) THEN + ITIA=ITIA+1 + IF(ISURA .EQ. ILIA) THEN + IRADG=0 + ELSE + IRADG=ISINT(4,ISURA+1,IA) + ENDIF +* IRADG=ISINT(4,ISURA,IA) + DO JDIR=1,3 + IF(ISINT(JDIR,ISURA,IA) .NE. 0) THEN + ISINT(JDIR,ISURG,IG)=ISINT(JDIR,ISURA,IA) + ENDIF + ENDDO + IF(ISINT(5,ISURA,IA) .NE. 0) THEN + ISINT(5,ISURG,IG)=ISINT(5,ISURA,IA) + ENDIF +* IF(IPRINT .GT. 1000) +* > write(6,7001) 'CURLOA .EQ. CURLOC',ISURG, +* > (ISINT(JDIR,ISURG,IG),JDIR=1,5) + THICK=CURLOA-REFLOG + REFLOA=CURLOA + REFLOG=REFLOA + GO TO 115 + ELSE IF(CURLOA .GT. CURLOC) THEN +* IF(IPRINT .GT. 1000) +* > write(6,7001) 'CURLOA .GT. CURLOC=',ISURG, +* > (ISINT(JDIR,ISURG,IG),JDIR=1,5) + GO TO 115 + ELSE + ITIA=ITIA+1 + IF(ISURA .EQ. ILIA) THEN + IRADG=0 + ELSE + IRADG=ISINT(4,ISURA+1,IA) + ENDIF + DO JDIR=1,3 + ISINT(JDIR,ISURG+1,IG)=ISINT(JDIR,ISURG,IG) + ENDDO + ISINT(5,ISURG+1,IG)=ISINT(5,ISURG,IG) + ENDIF + THICK=CURLOA-REFLOG + ISINT(4,ISURG+1,IG)=IRADG + TRKLSI(ISURG+1,IG)=TRKLSI(ISURG,IG)-THICK + TRKLSI(ISURG,IG)=THICK + ISURG=ISURG+1 + REFLOA=CURLOA + REFLOG=REFLOA +* IF(IPRINT .GT. 1000) +* > write(6,7001) 'CURLOA .LT. CURLOC',ISURG, +* > (ISINT(JDIR,ISURG,IG),JDIR=1,5) + ENDDO + 115 CONTINUE + IFIA=IFIA+ITIA + ENDIF + REFLOC=CURLOC + REFLOG=REFLOC + ENDDO +*---- +* Save final Cartesian faces +*---- + IFIC=NBSINT(IC)-NBCOR(2,IC)+2 + ILIC=NBSINT(IC)+1 + IFSG=ISURG + DO ISURC=IFIC,ILIC + ISURG=ISURG+1 + TRKLSI(ISURG,IG)=TRKLSI(ISURC,IC) + DO IDIR=1,5 + ISINT(IDIR,ISURG,IG)=ISINT(IDIR,ISURC,IC) + ENDDO + ISINT(4,ISURG,IG)=IRADG + ENDDO + NBCOR(2,IG)=NBCOR(2,IC) +*---- +* Find radial zone associated with final Cartesian face +* when cylinder face coincides with final face +*---- + IF(ICOMB .EQ. 1) THEN +*---- +* Find radial surface direction +*---- + ISURC=NBSINT(IC)+1 + REFLOC=TRKLSI(ISURC,IC) + ISURA=NBSINT(IA)+1 + REFLOA=TRKLSI(ISURA,IA) + DELCUR=ABS(REFLOC-REFLOA) + DO IDIR=1,5 + IF(ISINT(IDIR,ISURA,IA) .LT. 0) THEN + KDIR=IDIR + ENDIF + ENDDO + IF(KDIR .NE. 4) THEN +*---- +* It is an inner face, +* Scan Cartesian regions +*---- + IF(DELCUR .LT. DCUTOF) THEN +*---- +* It is an outer face, +* reset radial id for Cartesian face +*---- + REFLOG=REFLOC + IRADG=ISINT(4,ISURA,IA) + JSURG=IFSG + DO ISURC=IFIC,ILIC + JSURG=JSURG+1 + ISINT(4,JSURG,IG)=IRADG + ENDDO + ELSE + WRITE(IOUT,9002) ISURA,KDIR,REFLOC,REFLOA + CALL XABORT(NAMSBR// + > ': Final Cartesian and annular faces are incoherent') + ENDIF + ENDIF + IFIA=NBCOR(1,IA)+1 + ILIA=NBSINT(IA)-NBCOR(2,IA)+1 + ELSE + REFLOG=REFLOC + ENDIF + ELSE IF(ABS(ICOMB) .EQ. 2) THEN +*---- +* Find radial surface direction +*---- + ISURG=0 + ISURA=NBCOR(1,IA) + REFLOA=TRKLSI(ISURA,IA) + REFLOG=REFLOA + IF(ICOMB .EQ. 2) THEN + DO IDIR=1,5 + IF(ISINT(IDIR,ISURA,IA) .LT. 0) THEN + KDIR=IDIR + ELSE IF(ISINT(IDIR,ISURA,IA) .GT. 0) THEN + LDIR=IDIR + ENDIF + ENDDO + IF(KDIR .EQ. 4) THEN +*---- +* It is an outer radial face, +* Determine Cartesian region location for +* this point +*---- + ISURC=NBCOR(1,IC) + REFLOC=TRKLSI(ISURC,IC) + IF(REFLOC .GT. REFLOA) THEN + WRITE(IOUT,9000) ISURA,ISURC,REFLOA,REFLOC + CALL XABORT(NAMSBR// + >': No Cartesian region found for this annulus') + ENDIF + IFIC=NBCOR(1,IC)+1 + ILIC=NBSINT(IC)-NBCOR(2,IC)+1 + DO JSURC=IFIC,ILIC + CURLOC=REFLOC+TRKLSI(JSURC,IC) + IF(REFLOA .LT. CURLOC) THEN + ISURC=JSURC + GO TO 125 + ENDIF + REFLOC=CURLOC + ENDDO + CALL XABORT(NAMSBR// + >': Impossible to find Cartesian region containing annulus') + 125 CONTINUE + IFIC=ISURC + ELSE +*---- +* It is an outer Cartesian face, +* Determine Cartesian region location for +* this face +*---- + ISURC=NBCOR(1,IC) + REFLOC=TRKLSI(ISURC,IC) + IF(REFLOC .NE. REFLOA) CALL XABORT(NAMSBR// + >': No compatible Cartesian face found for this annulus') + IFIC=ISURC+1 + ENDIF + IFIA=1 + ILIA=NBCOR(1,IA) + DO ISURA=IFIA,ILIA + ISURG=ISURG+1 + TRKLSI(ISURG,IG)=TRKLSI(ISURA,IA) + DO IDIR=1,5 + IF(IDIR .EQ. KDIR .OR. IDIR .EQ. LDIR ) THEN + ISINT(IDIR,ISURG,IG)=ISINT(IDIR,ISURA,IA) + ELSE + ISINT(IDIR,ISURG,IG)=ISINT(IDIR,ISURC,IC) + ENDIF + ENDDO + ISINT(4,ISURG,IG)=ISINT(4,ISURA,IA) + ENDDO + NBCOR(1,IG)=ISURG + IFIA=NBCOR(1,IA)+1 + IRADG=ISINT(4,IFIA,IA) + ILIA=NBSINT(IA)-NBCOR(2,IA)+1 +*---- +* Scan Cartesian regions +*---- + ILIC=NBSINT(IC)-NBCOR(2,IC)+1 + DO ISURC=IFIC,ILIC + CURLOC=REFLOC+TRKLSI(ISURC,IC) + ISURG=ISURG+1 + DO JDIR=1,5 + ISINT(JDIR,ISURG,IG)=ISINT(JDIR,ISURC,IC) + ENDDO + ISINT(4,ISURG,IG)=IRADG + THICK=CURLOC-REFLOG + TRKLSI(ISURG,IG)=THICK + ITIA=0 + JSURC=ISURC +*---- +* Scan annular regions for intermediate mesh +*---- + DO ISURA=IFIA,ILIA + CURLOA=REFLOA+TRKLSI(ISURA,IA) + IF(CURLOA .GT. CURLOC) THEN + GO TO 145 + ELSE IF(CURLOA .EQ. CURLOC) THEN + ITIA=ITIA+1 + IRADG=ISINT(4,ISURA,IA) + DO JDIR=1,5 + IF(ISINT(JDIR,ISURA,IA) .NE. 0) THEN + ISINT(JDIR,ISURG,IG)=ISINT(JDIR,ISURA,IA) + ENDIF + ENDDO + ISINT(4,ISURG,IG)=IRADG +* IF(IPRINT .GT. 1000) +* > write(6,7001) 'CURLOA .EQ. CURLOC',ISURG, +* > (ISINT(JDIR,ISURG,IG),JDIR=1,5) + THICK=CURLOA-REFLOG + REFLOA=CURLOA + REFLOG=REFLOA + GO TO 145 + ELSE + IF(ISURA .EQ. ILIA) THEN + THICK=CURLOA-REFLOG + TRKLSI(ISURG,IG)=THICK + IRADG=0 + GO TO 155 + ELSE + ITIA=ITIA+1 + IRADG=ISINT(4,ISURA+1,IA) + THICK=CURLOA-REFLOG + DO JDIR=1,5 + ISINT(JDIR,ISURG+1,IG)=ISINT(JDIR,ISURG,IG) + ENDDO + ISINT(4,ISURG+1,IG)=IRADG + TRKLSI(ISURG+1,IG)=TRKLSI(ISURG,IG)-THICK + TRKLSI(ISURG,IG)=THICK + ISURG=ISURG+1 + ENDIF + REFLOA=CURLOA + REFLOG=REFLOA + ENDIF + ENDDO + 145 CONTINUE + IFIA=IFIA+ITIA + REFLOC=CURLOC + REFLOG=REFLOC + ENDDO + 155 CONTINUE +*---- +* Save final annular faces +*---- + IFIA=NBSINT(IA)-NBCOR(2,IA)+2 + ILIA=NBSINT(IA)+1 + ISURA=IFIA + DO IDIR=1,5 + IF(ISINT(IDIR,ISURA,IA) .LT. 0) THEN + KDIR=IDIR + ELSE IF(ISINT(IDIR,ISURA,IA) .GT. 0) THEN + LDIR=IDIR + ENDIF + ENDDO + ISURC=JSURC + IFIA=NBSINT(IA)-NBCOR(2,IA)+2 + ILIA=NBSINT(IA)+1 + DO ISURA=IFIA,ILIA + ISURG=ISURG+1 + TRKLSI(ISURG,IG)=TRKLSI(ISURA,IA) + DO IDIR=1,5 + IF(IDIR .EQ. KDIR .OR. IDIR .EQ. LDIR ) THEN + ISINT(IDIR,ISURG,IG)=ISINT(IDIR,ISURA,IA) + ELSE + ISINT(IDIR,ISURG,IG)=ISINT(IDIR,ISURC,IC) + ENDIF + ENDDO + ISINT(4,ISURG,IG)=ISINT(4,ISURA,IA) + ENDDO + NBCOR(2,IG)=NBCOR(2,IA) + ELSE + IFIA=1 + ILIA=NBCOR(1,IA) + DO ISURA=IFIA,ILIA + ISURG=ISURG+1 + TRKLSI(ISURG,IG)=TRKLSI(ISURA,IA) + DO IDIR=1,5 + ISINT(IDIR,ISURG,IG)=ISINT(IDIR,ISURA,IA) + ENDDO + ENDDO + NBCOR(1,IG)=NBCOR(1,IA) +*---- +* Scan annular regions for intermediate mesh +*---- + IFIA=NBCOR(1,IA)+1 + ILIA=NBSINT(IA)-NBCOR(2,IA)+1 + DO ISURA=IFIA,ILIA + ISURG=ISURG+1 + CURLOA=REFLOA+TRKLSI(ISURA,IA) + DO JDIR=1,5 + ISINT(JDIR,ISURG,IG)=ISINT(JDIR,ISURA,IA) + ENDDO + TRKLSI(ISURG,IG)=TRKLSI(ISURA,IA) + REFLOA=CURLOA + ENDDO + IFIA=NBSINT(IA)-NBCOR(2,IA)+2 + ILIA=NBSINT(IA)+1 + DO ISURA=IFIA,ILIA + ISURG=ISURG+1 + TRKLSI(ISURG,IG)=TRKLSI(ISURA,IA) + DO IDIR=1,5 + ISINT(IDIR,ISURG,IG)=ISINT(IDIR,ISURA,IA) + ENDDO + ENDDO + NBCOR(2,IG)=NBCOR(2,IA) + NBSINT(IG)=ISURG-1 + ENDIF + ENDIF +*---- +* Remove track segment with vanishing distance +*---- + IT=3 + NBSINT(IT)=ISURG-1 + ISUR=NBCOR(1,IT) + DO JSUR=NBCOR(1,IT)+1,NBSINT(IT)-NBCOR(2,IT)+1 + IF(TRKLSI(JSUR,IT) .GT. DCUTOF) THEN + ISUR=ISUR+1 + TRKLSI(ISUR,IT)=TRKLSI(JSUR,IT) + DO IDIR=1,5 + ISINT(IDIR,ISUR,IT)=ISINT(IDIR,JSUR,IT) + ENDDO + ELSE + IF(IPRINT .GT. 1000) + > WRITE(IOUT,9001) JSUR,IT,ISUR + ENDIF + ENDDO + IF(ISUR .LT. NBSINT(IT)-NBCOR(2,IT)+1) THEN + DO JSUR=NBSINT(IT)-NBCOR(2,IT)+2,NBSINT(IT)+1 + ISUR=ISUR+1 + TRKLSI(ISUR,IT)=TRKLSI(JSUR,IT) + DO IDIR=1,5 + ISINT(IDIR,ISUR,IT)=ISINT(IDIR,JSUR,IT) + ENDDO + ENDDO + NBSINT(IT)=ISUR-1 + ENDIF + IF(IPRINT .GT. 1000) THEN + WRITE(IOUT,6016) NAMTYP(IT) + WRITE(IOUT,6011) 'Initial face' + DO JSUR=1,NBCOR(1,IT) + WRITE(IOUT,6010) TRKLSI(JSUR,IT), + > (ISINT(IDIR,JSUR,IT),IDIR=1,5) + ENDDO + WRITE(IOUT,6011) 'Regions ' + DO JSUR=NBCOR(1,IT)+1,NBSINT(IT)-NBCOR(2,IT)+1 + WRITE(IOUT,6010) TRKLSI(JSUR,IT), + > (ISINT(IDIR,JSUR,IT),IDIR=1,5) + ENDDO + WRITE(IOUT,6011) 'Final face' + DO JSUR=NBSINT(IT)-NBCOR(2,IT)+2,NBSINT(IT)+1 + WRITE(IOUT,6010) TRKLSI(JSUR,IT), + > (ISINT(IDIR,JSUR,IT),IDIR=1,5) + ENDDO + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(1X,F25.16,5I10) + 6011 FORMAT(A20) + 6016 FORMAT(1X,A12) +* 7000 FORMAT('Verify ',A6,I10,F25.16,6I10) +* 7001 FORMAT('Verify ',A18,I10,6I10) + 9000 FORMAT(' Problem with surface ',2I10,2F20.10) + 9001 FORMAT(' Warning : region with vanishing distance found ', + > 3I10) + 9002 FORMAT('Final Cartesian and annular faces are incoherent', + > 2(2X,I10),2(2X,F20.10)) + END diff --git a/Dragon/src/NXTLCY.f b/Dragon/src/NXTLCY.f new file mode 100644 index 0000000..a9f6018 --- /dev/null +++ b/Dragon/src/NXTLCY.f @@ -0,0 +1,784 @@ +*DECK NXTLCY + FUNCTION NXTLCY(IPRINT,ITST ,NDIM ,MXMESH,LINMAX, + > MESH ,ORITRK,DIRTRK,DCMESH,IDIRC , + > NBCOR ,NBSINT,ISINT ,TRKLSI) +* +*---------- +* +*Purpose: +* To track an annular 2-D or 3-D geometry +* using the NXT tracking procedure. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau. +* +*Parameters: input +* IPRINT print level. +* ITST type of tracking, where: +* =-1 only the exact geometry +* is considered taking into account the +* submesh in each direction; +* = 0 only the global geometry +* is considered without taking into account the +* submesh in each direction; +* = 1 both the global +* geometry (as a first step) and the exact geometry +* are considered taking into account the +* submesh in each direction. +* NDIM dimension of problem. +* MXMESH maximum number of spatial subdivision in +* $R$ and $X$, $Y$ or $Z$. +* LINMAX maximum number of segments in a track. +* MESH effective number of spatial subdivision in $X$ +* $Y$, $Z$ and $R$. +* ORITRK a point on the track (origin). +* DIRTRK the track direction (director cosines). +* DCMESH spatial description of the cylinder. +* IDIRC the direction of the cylinder axis. +* +*Parameters: output +* NXTLCY number of surfaces intersected. +* NBCOR number of corner found for each external faces. +* NBSINT number of surface crossed by track. +* ISINT the surfaces crossed by the track. +* TRKLSI the surface intersection distance. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,ITST,NDIM,MXMESH,LINMAX + INTEGER MESH(5) + DOUBLE PRECISION ORITRK(NDIM), + > DIRTRK(NDIM), + > DCMESH(-1:MXMESH,5) + INTEGER IDIRC + INTEGER NBCOR(2),NBSINT + INTEGER ISINT(0:5,LINMAX) + DOUBLE PRECISION TRKLSI(LINMAX) + INTEGER NXTLCY +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTLCY') + INTEGER MXDIM + PARAMETER (MXDIM=3) + DOUBLE PRECISION DZERO,DONE,DTWO + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) + DOUBLE PRECISION DCUTOL + PARAMETER (DCUTOL=1.0D-11) +*---- +* Local variables +*---- + INTEGER IDIR,INDIR,INEXT,IFRST,ILAST,IFACE, + > IDGR,IDG1,IDG2,IDGP,NR,NP + INTEGER JFACE,JSUR,KNEXT,KSFRST,KSLAST, + > KVFRST,KVLAST,KFACE,KSUR,KSUB + INTEGER IC1,IDIRS,IDIRF,IDIRB,IRFIN,IDIRFS + DOUBLE PRECISION DP1,DP2,TRKK + DOUBLE PRECISION TRKDIS,TRKOLD,TRKTMP + DOUBLE PRECISION TORI(MXDIM),ROTANG(MXDIM) + DOUBLE PRECISION XYCEN(2),RADIUS,CYLLIM(2),PROJ,PROJN, + > YLOC,XORI,XLOC(2),CYLINT,TCINTD,XXINTD + DOUBLE PRECISION DCUTOF +*---- +* Data +*---- + CHARACTER CDIR(4)*1 + SAVE CDIR + DATA CDIR /'X','Y','Z','R'/ +*---- +* Verify ITST option and reset to default value if invalid +*---- + IF(ITST .LT. -1 .OR. ITST .GT. 1) THEN +*---- +* Reset ITST=1 (complete analysis) if the value of ITST is invalid +*---- + ITST=1 + ENDIF +*---- +* Initialise output vectors +*---- + KSFRST=1 + KSLAST=1 + KVFRST=1 + KVLAST=1 + KNEXT=1 + KSUB=1 + TRKOLD=DZERO + NBCOR(1)=0 + NBCOR(2)=0 + NBSINT=0 + ISINT(0:5,:LINMAX)=0 + TRKLSI(:LINMAX)=DZERO +*---- +* IDG1 is first direction of plane perpendicular +* to main direction ($Y, $Z$ or $X$). +* IDG2 is second direction of plane perpendicular +* to main direction ($Z$, $X$ or $Y$). +* IDGP is main cylinder direction ($X$, $Y$ or $Z$) +* for 2D case IDGP=3 +*---- + IDGR=4 + IDGP=IDIRC + IDG1=MOD(IDGP,3)+1 + IDG2=MOD(IDGP+1,3)+1 + NR=MESH(4) + NP=MESH(IDGP) +*---- +* Print header if required +*---- + IF(IPRINT .GT. 1000) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6011) 'radial'//CDIR(IDG1)//CDIR(IDG2)// + > '={ ' + WRITE(IOUT,6012) (DCMESH(IC1,IDGR),IC1=1,NR) + WRITE(IOUT,6013) + WRITE(IOUT,6011) 'center'//CDIR(IDG1)//CDIR(IDG2)// + > '={ ' + WRITE(IOUT,6012) DCMESH(-1,IDG1),DCMESH(-1,IDG2) + WRITE(IOUT,6013) + IF(NDIM .EQ. 3) THEN + WRITE(IOUT,6011) 'axial'//CDIR(IDGP)//'={ ' + WRITE(IOUT,6012) (DCMESH(IC1,IDGP),IC1=0,NP) + WRITE(IOUT,6013) + ENDIF + WRITE(IOUT,6011) 'trackorigin={ ' + WRITE(IOUT,6012) ORITRK + WRITE(IOUT,6013) + WRITE(IOUT,6011) 'trackdirection={ ' + WRITE(IOUT,6012) DIRTRK + WRITE(IOUT,6013) + ENDIF +*---- +* Select planes order in direction IDIR +*---- + IFRST=NR+1 + INEXT=-1 + ILAST=2 +*---- +* Select planes order in direction KDIR (if required) +*---- + DCUTOF=DCUTOL*DCUTOL + IF(NDIM .EQ. 3) THEN + DCUTOF=DCUTOF*DCUTOL + IF(DIRTRK(IDGP) .LT. 0) THEN + KNEXT=-1 + KSFRST=NP+1 + KSLAST=1 + KVFRST=NP+1 + KVLAST=2 + KSUB=-1 + ELSE + KNEXT=1 + KSFRST=1 + KSLAST=NP+1 + KVFRST=1 + KVLAST=NP + KSUB=0 + ENDIF + ENDIF +*---- +* Projection on 2-D plane +* and translation to origin of circle +*---- + XYCEN(1)=DCMESH(-1,IDG1) + XYCEN(2)=DCMESH(-1,IDG2) + TORI(1)=ORITRK(IDG1) + TORI(2)=ORITRK(IDG2) + IF(NDIM .EQ. 3) THEN + TORI(3)=ORITRK(IDGP) + ROTANG(3)=DIRTRK(IDGP) + ELSE + ROTANG(3)=DZERO + TORI(3)=DZERO + ENDIF + PROJ=DONE/SQRT(DONE-ROTANG(3)**2) + ROTANG(1)=DIRTRK(IDG1)*PROJ + ROTANG(2)=DIRTRK(IDG2)*PROJ + PROJN=DONE/SQRT(ROTANG(1)*ROTANG(1)+ROTANG(2)*ROTANG(2)) + ROTANG(1)=ROTANG(1)*PROJN + ROTANG(2)=ROTANG(2)*PROJN +*---- +* Translate (x,y) coordinates to circle center and +* rotate y coordinate in such a way that tracking +* line parallel to the x-axis +*---- + XORI= (TORI(1)-XYCEN(1))*ROTANG(1) + > +(TORI(2)-XYCEN(2))*ROTANG(2) + YLOC=-(TORI(1)-XYCEN(1))*ROTANG(2) + > +(TORI(2)-XYCEN(2))*ROTANG(1) +* IF(IPRINT .GT. 1000) THEN +* write(6,*) 'XYCEN =',XYCEN +* write(6,*) 'TORI =',TORI +* write(6,*) 'ROTANG=',ROTANG +* write(6,*) 'RotOri=',XORI,YLOC +* ENDIF +*---- +* For option ITST=0, 1, consider global geometry +* and test if line crosses this geometry. +*---- + IF(ITST .EQ. 0 .OR. ITST .EQ. 1) THEN + NBSINT=0 + RADIUS=DCMESH(NR,IDGR) +* IF(IPRINT .GT. 1000) +* > write(6,*) 'YLOC, RADIUS=',YLOC,RADIUS + IF(NDIM .EQ. 3) THEN + CYLLIM(1)=DCMESH(0,IDGP) + CYLLIM(2)=DCMESH(NP,IDGP) +* IF(IPRINT .GT. 1000) +* > write(6,*)'CYLLIM ',CYLLIM + ENDIF +*---- +* Test if coordinate is inside circle. +*---- + IF(ABS(YLOC) .LT. RADIUS) THEN +*---- +* Line crosses circle (infinite cylinder) +*---- + XLOC(2)=SQRT(RADIUS**2-YLOC**2) + XLOC(1)=-XLOC(2) + IF(NDIM .EQ. 3) THEN +*---- +* Find intersection points for finite cylinders in 3D +*---- +* IF(IPRINT .GT. 1000) +* > write(6,*) 'XLOC ',XLOC(1),XLOC(2) + DO 100 IFACE=1,2 + TCINTD=YLOC*ROTANG(1)+ + > XLOC(IFACE)*ROTANG(2)+XYCEN(2)-TORI(2) + XXINTD=XLOC(IFACE)*ROTANG(1)- + > YLOC*ROTANG(2)+XYCEN(1)-TORI(1) + TRKTMP=(TCINTD*PROJ)/ROTANG(2) + TRKDIS=SQRT(XXINTD*XXINTD+TCINTD*TCINTD)*PROJ +* IF(IPRINT .GT. 1000) +* > write(6,*) 'Changedir=',TRKDIS,TCINTD,ROTANG(2) + IF(ROTANG(2)*TCINTD .LT. DZERO) TRKDIS=-TRKDIS +* IF(IPRINT .GT. 1000) +* > write(6,*) 'TRKDIS=',TRKDIS,TRKTMP,ROTANG(2) + CYLINT=TRKDIS*ROTANG(3)+TORI(3) +* IF(IPRINT .GT. 1000) +* > write(6,*) 'CYLINT= ',CYLINT + IF(CYLINT .GE. CYLLIM(1) .AND. CYLINT .LE. CYLLIM(2)) THEN +* IF(IPRINT .GT. 1000) +* > write(6,*) 'iface r ',IFACE + IF(NBSINT .EQ. 0) THEN + NBSINT=1 + TRKOLD=TRKDIS + ELSE IF(TRKOLD .NE. TRKDIS) THEN + NBSINT=2 + GO TO 105 + ENDIF + ENDIF + 100 CONTINUE + ELSE + NBSINT=2 +* IF(IPRINT .GT. 1000) +* > write(6,*) 'Intersected in 2D' + GO TO 105 + ENDIF + ENDIF +*---- +* For 3-D geometry look for intersection with bottom +* and top of cylinder +*---- + IF(NDIM .EQ. 3) THEN + DO 102 IFACE=1,2 + TRKDIS=(CYLLIM(IFACE)-TORI(3))/ROTANG(3) + XLOC(1)=TORI(1)+TRKDIS*ROTANG(1)/PROJ-XYCEN(1) + XLOC(2)=TORI(2)+TRKDIS*ROTANG(2)/PROJ-XYCEN(2) + TCINTD=SQRT(XLOC(1)**2+XLOC(2)**2) +* IF(IPRINT .GT. 1000) +* > write(6,*) 'dir 3 int ', XLOC(1),XLOC(2),TRKDIS + IF(TCINTD .LT. RADIUS) THEN +* IF(IPRINT .GT. 1000) +* > write(6,*) 'iface z ',IFACE +* IF(IPRINT .GT. 1000) +* > write(6,*) TORI(1)+TRKDIS*ROTANG(1)/PROJ, +* > TORI(2)+TRKDIS*ROTANG(2)/PROJ, +* > TORI(3)+TRKDIS*ROTANG(3) + IF(NBSINT .EQ. 0) THEN + NBSINT=1 + TRKOLD=TRKDIS + ELSE IF(TRKOLD .NE. TRKDIS) THEN + NBSINT=2 + GO TO 105 + ENDIF + ENDIF + 102 CONTINUE + ENDIF + 105 CONTINUE + ELSE +*---- +* If ITST=-1, assume that 2 surface are intersected +* and continue +*---- + NBSINT=2 + ENDIF +* IF(IPRINT .GT. 1000) +* > write(6,*) 'Nb sur=',NBSINT + NXTLCY=NBSINT +*---- +* If line does not intersect any surfaces, exit +*---- + IF(NXTLCY .EQ. 0) THEN + IF(IPRINT .GT. 1000) THEN + WRITE(IOUT,6002) NAMSBR + ENDIF + RETURN + ENDIF +*---- +* If line does not intersect 2 surfaces, abort +*---- + IF(NBSINT .NE. 2) CALL XABORT(NAMSBR// + >': Invalid line since it did not intersect 0 or 2 surfaces') +*---- +* If ITST=0, return number of surfaces intersected by line +*---- + IF(ITST .EQ. 0) RETURN +*---- +* If ITST=1 or -1 +* track geometry with submesh +*---- + NBSINT=0 +*---- +* Loop over radial regions from maximal radius +* from outer to inner +*---- + DO 110 IFACE=IFRST,ILAST,INEXT + RADIUS=DCMESH(IFACE-1,IDGR) +* IF(IPRINT .GT. 1000) +* > write(6,*) 'YLOC, RADIUS=',YLOC,RADIUS + IF(ABS(YLOC) .LE. RADIUS) THEN + XLOC(2)=SQRT(RADIUS**2-YLOC**2) + XLOC(1)=-XLOC(2) +* IF(IPRINT .GT. 1000) +* > write(6,*) 'XLOC',XLOC +*---- +* Scan over two possible cylinder intersections +*---- + INDIR=1 + DO 111 JFACE=1,2 + TCINTD=YLOC*ROTANG(1)+XLOC(JFACE)*ROTANG(2)+XYCEN(2)-TORI(2) + XXINTD=XLOC(JFACE)*ROTANG(1)-YLOC*ROTANG(2)+XYCEN(1)-TORI(1) + TRKDIS=SQRT(XXINTD*XXINTD+TCINTD*TCINTD)*PROJ +* IF(IPRINT .GT. 1000) +* > TRKTMP=(TCINTD*PROJ)/ROTANG(2) + IF(ROTANG(2)*TCINTD .LT. -DCUTOF) TRKDIS=-TRKDIS +* IF(IPRINT .GT. 1000) +* > write(6,*) 'Distances',XXINTD,TCINTD,ROTANG(2),TRKDIS,TRKTMP + IF(NDIM .EQ. 3) THEN +*---- +* Scan over planes in axial cylinder direction +*---- + TRKK=DBLE(KNEXT)*(TRKDIS*ROTANG(3)+TORI(3)) + DO 112 KFACE=KVFRST,KVLAST,KNEXT + DP1=DBLE(KNEXT)*DCMESH(KFACE-1,IDGP) + DP2=DBLE(KNEXT)*DCMESH(KFACE-1+KNEXT,IDGP) +* IF(IPRINT .GT. 1000) +* > write(6,*) 'DP1,DP2 ',DP1,DP2,TRKK + IF(TRKK .GE. DP1 .AND. + > TRKK .LE. DP2 ) THEN + NBSINT=NBSINT+1 + IF(IPRINT .GT. 1000) THEN + WRITE(IOUT,6011) 'Intersection at ' + WRITE(IOUT,6014) IFACE,JFACE,KFACE + WRITE(IOUT,6015) TRKDIS + ENDIF + IF(NBSINT .EQ. 1) THEN + ISINT(0,NBSINT)=(IDG1+3)*INDIR + ISINT(IDGR,NBSINT)=IFACE-1 + ISINT(IDGP,NBSINT)=KFACE+KSUB + TRKLSI(NBSINT)=TRKDIS + ELSE +*---- +* Scan previous distances and reorder if necessary +*---- + DO 120 JSUR=NBSINT-1,1,-1 + IF(TRKDIS .GE. TRKLSI(JSUR)) THEN +*---- +* For more than one intersection at a given distance: +* a) if this is an external surface, store the distance +* for corner duplication +* b) if this is an internal surface select adequate next region +* to cross and reset NBSINT=NBSINT-1 +*---- + IF(TRKDIS .EQ. TRKLSI(JSUR) .AND. + > IFACE .NE. IFRST ) THEN + ISINT(IDGR,JSUR)=IFACE-1 + ISINT(IDGP,JSUR)=KFACE+KSUB + NBSINT=NBSINT-1 + GO TO 125 + ENDIF + DO 121 KSUR=NBSINT,JSUR+2,-1 + ISINT(0,KSUR)=ISINT(0,KSUR-1) + ISINT(IDGR,KSUR)=ISINT(IDGR,KSUR-1) + ISINT(IDGP,KSUR)=ISINT(IDGP,KSUR-1) + TRKLSI(KSUR)=TRKLSI(KSUR-1) + 121 CONTINUE + ISINT(0,JSUR+1)=(IDG1+3)*INDIR + ISINT(IDGR,JSUR+1)=IFACE-1 + ISINT(IDGP,JSUR+1)=KFACE+KSUB + TRKLSI(JSUR+1)=TRKDIS + GO TO 125 + ENDIF + 120 CONTINUE + DO 122 KSUR=NBSINT,2,-1 + ISINT(0,KSUR)=ISINT(0,KSUR-1) + ISINT(IDGR,KSUR)=ISINT(IDGR,KSUR-1) + ISINT(IDGP,KSUR)=ISINT(IDGP,KSUR-1) + TRKLSI(KSUR)=TRKLSI(KSUR-1) + 122 CONTINUE + ISINT(0,1)=(IDG1+3)*INDIR + ISINT(IDGR,1)=IFACE-1 + ISINT(IDGP,1)=KFACE+KSUB + TRKLSI(1)=TRKDIS + 125 CONTINUE + ENDIF + ENDIF + 112 CONTINUE + ELSE +*---- +* For 2-D, intersection with a circle +*---- + NBSINT=NBSINT+1 + IF(IPRINT .GT. 1000) THEN + WRITE(IOUT,6011) 'Intersection at ' + WRITE(IOUT,6014) IFACE,JFACE + WRITE(IOUT,6015) TRKDIS + ENDIF + IF(NBSINT .EQ. 1) THEN + ISINT(0,NBSINT)=(IDG1+3)*INDIR + ISINT(IDGR,NBSINT)=IFACE-1 + TRKLSI(NBSINT)=TRKDIS + ELSE +*---- +* Scan previous distances and reorder if necessary +*---- + DO 130 JSUR=NBSINT-1,1,-1 + IF(TRKDIS .GE. TRKLSI(JSUR)) THEN +*---- +* For more than one intersection at a given distance: +* a) if this is an external surface, store the distance +* for corner duplication +* b) if this is an internal surface select adequate next region +* to cross and reset NBSINT=NBSINT-1 +*---- + IF(TRKDIS .EQ. TRKLSI(JSUR) .AND. + > IFACE .NE. IFRST ) THEN + ISINT(IDGR,JSUR)=IFACE-1 + NBSINT=NBSINT-1 + GO TO 135 + ENDIF + DO 131 KSUR=NBSINT,JSUR+2,-1 + ISINT(0,KSUR)=ISINT(0,KSUR-1) + ISINT(IDGR,KSUR)=ISINT(IDGR,KSUR-1) + TRKLSI(KSUR)=TRKLSI(KSUR-1) + 131 CONTINUE + ISINT(0,JSUR+1)=(IDG1+3)*INDIR + ISINT(IDGR,JSUR+1)=IFACE-1 + TRKLSI(JSUR+1)=TRKDIS + GO TO 135 + ENDIF + 130 CONTINUE + DO 132 KSUR=NBSINT,2,-1 + ISINT(0,KSUR)=ISINT(0,KSUR-1) + ISINT(IDGR,KSUR)=ISINT(IDGR,KSUR-1) + TRKLSI(KSUR)=TRKLSI(KSUR-1) + 132 CONTINUE + ISINT(0,1)=(IDG1+3)*INDIR + ISINT(IDGR,1)=IFACE-1 + TRKLSI(1)=TRKDIS + 135 CONTINUE + ENDIF + ENDIF + INDIR=-1 + 111 CONTINUE + ENDIF + 110 CONTINUE + IF(NDIM .EQ. 3) THEN +*---- +* Loop over axial regions from Top to bottom or +* vice versa +*---- + DO 140 KFACE=KSFRST,KSLAST,KNEXT + TRKDIS=(DCMESH(KFACE-1,IDGP)-TORI(3))/ROTANG(3) + DP1=TORI(1)+TRKDIS*ROTANG(1)/PROJ-XYCEN(1) + DP2=TORI(2)+TRKDIS*ROTANG(2)/PROJ-XYCEN(2) + TCINTD=SQRT(DP1**2+DP2**2) +*---- +* Loop over radial regions from inner to outer +*---- + DO 141 IFACE=ILAST,IFRST,-INEXT + RADIUS=DCMESH(IFACE-1,IDGR) +* IF(IPRINT .GT. 1000) +* > write(6,*) 'zz= ',DP1,DP2,TCINTD,RADIUS + IF(TCINTD .LE. RADIUS) THEN + IF(IPRINT .GT. 1000) THEN + WRITE(IOUT,6011) 'Intersection at ' + WRITE(IOUT,6014) KFACE,IFACE + WRITE(IOUT,6015) TRKDIS + ENDIF + NBSINT=NBSINT+1 + IF(NBSINT .EQ. 1) THEN + ISINT(0,NBSINT)=IDGP + ISINT(IDGR,NBSINT)=IFACE-1 + ISINT(IDGP,NBSINT)=KFACE + TRKLSI(NBSINT)=TRKDIS + ELSE +*---- +* Scan previous distances and reorder if necessary +*---- + DO 150 JSUR=NBSINT-1,1,-1 + IF(TRKDIS .GE. TRKLSI(JSUR)) THEN +*---- +* For more than one intersection at a given distance: +* a) if this is an external surface, store the distance +* for corner duplication +* b) if this is an internal surface select adequate next region +* to cross and reset NBSINT=NBSINT-1 +*---- + IF(TRKDIS .EQ. TRKLSI(JSUR) .AND. + > KFACE .NE. KSFRST .AND. + > KFACE .NE. KSLAST ) THEN + ISINT(IDGR,JSUR)=IFACE-1 + ISINT(IDGP,JSUR)=KFACE + NBSINT=NBSINT-1 + GO TO 155 + ENDIF + DO 151 KSUR=NBSINT,JSUR+2,-1 + ISINT(0,KSUR)=ISINT(0,KSUR-1) + ISINT(IDGR,KSUR)=ISINT(IDGR,KSUR-1) + ISINT(IDGP,KSUR)=ISINT(IDGP,KSUR-1) + TRKLSI(KSUR)=TRKLSI(KSUR-1) + 151 CONTINUE + ISINT(0,JSUR+1)=IDGP + ISINT(IDGR,JSUR+1)=IFACE-1 + ISINT(IDGP,JSUR+1)=KFACE + TRKLSI(JSUR+1)=TRKDIS + GO TO 155 + ENDIF + 150 CONTINUE + DO 152 KSUR=NBSINT,2,-1 + ISINT(0,KSUR)=ISINT(0,KSUR-1) + ISINT(IDGR,KSUR)=ISINT(IDGR,KSUR-1) + ISINT(IDGP,KSUR)=ISINT(IDGP,KSUR-1) + TRKLSI(KSUR)=TRKLSI(KSUR-1) + 152 CONTINUE + ISINT(0,1)=IDGP + ISINT(IDGR,1)=IFACE-1 + ISINT(IDGP,1)=KFACE + TRKLSI(1)=TRKDIS + 155 CONTINUE + ENDIF + GO TO 145 + ENDIF + 141 CONTINUE + 145 CONTINUE + 140 CONTINUE + ENDIF + IF(NBSINT .GE. 2) THEN +*---- +* Find number of corners for initial surface intersections +*---- + TRKDIS=TRKLSI(1) + NBCOR(1)=1 + DO 160 JSUR=2,NBSINT + IF(TRKLSI(JSUR) .GT. TRKDIS) GO TO 165 + NBCOR(1)=NBCOR(1)+1 + 160 CONTINUE + 165 CONTINUE +*---- +* Find number of corners for final surface intersections +*---- + TRKDIS=TRKLSI(NBSINT) + NBCOR(2)=1 + DO 170 JSUR=NBSINT-1,1,-1 + IF(TRKLSI(JSUR) .LT. TRKDIS) GO TO 175 + NBCOR(2)=NBCOR(2)+1 + 170 CONTINUE + 175 CONTINUE + ENDIF +*---- +* Print intersection points +*---- + IF(IPRINT .GT. 1000) THEN + WRITE(IOUT,6011) 'Initial planes ' + DO 200 JSUR=1,NBCOR(1) + WRITE(IOUT,6010) TRKLSI(JSUR), + > (ISINT(IDIR,JSUR),IDIR=0,5) + 200 CONTINUE + IF(NBCOR(1)+1 .LE. NBSINT-NBCOR(2)) THEN + WRITE(IOUT,6011) 'Intermediate planes ' + DO 201 JSUR=NBCOR(1)+1,NBSINT-NBCOR(2) + WRITE(IOUT,6010) TRKLSI(JSUR), + > (ISINT(IDIR,JSUR),IDIR=0,5) + 201 CONTINUE + ENDIF + WRITE(IOUT,6011) 'Final planes ' + DO 202 JSUR=NBSINT-NBCOR(2)+1,NBSINT + WRITE(IOUT,6010) TRKLSI(JSUR), + > (ISINT(IDIR,JSUR),IDIR=0,5) + 202 CONTINUE + ENDIF +*---- +* Identify final faces +*---- + DO JSUR=NBSINT,NBSINT-NBCOR(2)+1,-1 + DO IDIRS=0,5 + ISINT(IDIRS,JSUR+1)=ISINT(IDIRS,JSUR) + ENDDO + TRKLSI(JSUR+1)=TRKLSI(JSUR) + IDIRS=ABS(ISINT(0,JSUR+1)) + IF(IDIRS .GE. 4) THEN + IDIRF=ISINT(4,JSUR+1) + IF(IDIRF .NE. MESH(4)) THEN + WRITE(IOUT,9001) NAMSBR,'final ', + > JSUR,4,IDIRF,MESH(4) + CALL XABORT(NAMSBR// + > ': Invalid '//CDIR(4)//' directed surface') + ENDIF + ISINT(4,JSUR+1)=-2 + ELSE + IDIRF=ISINT(IDIRS,JSUR+1) + IF(IDIRF .EQ. 1) THEN + ISINT(IDIRS,JSUR+1)=-1 + ELSE IF(IDIRF .EQ. MESH(IDIRS)+1) THEN + ISINT(IDIRS,JSUR+1)=-2 + ELSE + WRITE(IOUT,9001) NAMSBR,'final ', + > JSUR,IDIRS,IDIRF,MESH(IDIRS) + CALL XABORT(NAMSBR//': Invalid '//CDIR(IDIRS)// + > ' directed surface') + ENDIF + ENDIF + ENDDO +*---- +* Identify regions +*---- + DO JSUR=NBSINT-NBCOR(2)+1,NBCOR(1)+1,-1 + IDIRFS=ISINT(0,JSUR) + IF(IDIRFS .GE. 4) THEN + IDIRFS=1 + ELSE + IDIRFS=0 + ENDIF + IDIRB=ABS(ISINT(0,JSUR-1)) + IF(IDIRB .GE. 4) IDIRB=4 + IDIRF=ABS(ISINT(0,JSUR)) + IF(IDIRF .GE. 4) IDIRF=4 + IF(IDIRB .EQ. IDIRF) THEN + IF(IDIRB .EQ. 4) THEN + IRFIN=MAX(ISINT(4,JSUR-1),ISINT(4,JSUR)) + ELSE + IRFIN=MIN(ISINT(IDIRF,JSUR-1),ISINT(IDIRF,JSUR)) + ENDIF + ELSE + IF(IDIRF .EQ. 4) THEN + IF(IDIRFS .EQ. 1) THEN + IRFIN=ISINT(4,JSUR-1) + ELSE + IRFIN=ISINT(4,JSUR) + ENDIF + ELSE + IRFIN=ISINT(IDIRF,JSUR-1) + ENDIF + ENDIF + IF(IPRINT .GT. 1000) THEN + WRITE(IOUT,*) 'JSUR =',JSUR,ISINT(0,JSUR-1),ISINT(0,JSUR), + > IDIRB,IDIRF,IRFIN + ENDIF + TRKLSI(JSUR)=TRKLSI(JSUR)-TRKLSI(JSUR-1) + DO IDIRS=1,5 + IF(IDIRS .EQ. IDIRF) THEN + ISINT(IDIRS,JSUR)=IRFIN + ELSE + ISINT(IDIRS,JSUR)=ISINT(IDIRS,JSUR) + ENDIF + ENDDO + ENDDO +*---- +* Identify initial face +*---- + DO JSUR=1,NBCOR(1) + IDIRS=ABS(ISINT(0,JSUR)) + IF(IDIRS .GE. 4) THEN + IDIRB=ISINT(4,JSUR) + IF(IDIRB .NE. MESH(4)) THEN + WRITE(IOUT,9001) NAMSBR,'initial ', + > JSUR,4,IDIRB,MESH(4) + CALL XABORT(NAMSBR// + > ': Invalid '//CDIR(4)//' directed surface') + ENDIF + ISINT(4,JSUR)=-2 + ELSE + IDIRB=ISINT(IDIRS,JSUR) + IF(IDIRB .EQ. 1) THEN + ISINT(IDIRS,JSUR)=-1 + ELSE IF(IDIRB .EQ. MESH(IDIRS)+1) THEN + ISINT(IDIRS,JSUR)=-2 + ELSE + WRITE(IOUT,9001) NAMSBR,'initial ', + > JSUR,IDIRS,IDIRB,MESH(IDIRS) + CALL XABORT(NAMSBR//': Invalid '//CDIR(IDIRS)// + > ' directed surface') + ENDIF + ENDIF + ENDDO +*---- +* Print final track information +*---- + IF(IPRINT .GT. 1000) THEN + WRITE(IOUT,6011) 'Initial face ' + DO JSUR=1,NBCOR(1) + WRITE(IOUT,6010) TRKLSI(JSUR), + > (ISINT(IDIR,JSUR),IDIR=0,5) + ENDDO + WRITE(IOUT,6011) 'Regions ' + DO JSUR=NBCOR(1)+1,NBSINT-NBCOR(2)+1 + WRITE(IOUT,6010) TRKLSI(JSUR), + > (ISINT(IDIR,JSUR),IDIR=0,5) + ENDDO + WRITE(IOUT,6011) 'Final face ' + DO JSUR=NBSINT-NBCOR(2)+2,NBSINT+1 + WRITE(IOUT,6010) TRKLSI(JSUR), + > (ISINT(IDIR,JSUR),IDIR=0,5) + ENDDO + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6002 FORMAT(' No region crossed'/ + > ' Output from --',A6,'-- completed *)') + 6010 FORMAT(1X,F25.16,6I10) + 6011 FORMAT(A20) + 6012 FORMAT(6(1X,F25.16,:,',')) + 6013 FORMAT('};') + 6014 FORMAT(6I10) + 6015 FORMAT(6(1X,F25.16)) +*---- +* Warning formats +*---- + 9001 FORMAT(1X,'Error in --',A6,' --'/ + > 1X,'invalid ',A8,' surface identification ',4I10) + END diff --git a/Dragon/src/NXTLDC.f b/Dragon/src/NXTLDC.f new file mode 100644 index 0000000..9f2c6c5 --- /dev/null +++ b/Dragon/src/NXTLDC.f @@ -0,0 +1,104 @@ +*DECK NXTLDC + SUBROUTINE NXTLDC(IPTRK,MAXMSH,ICEL,IDIRC,MESHC,NSURC,NREGC, + 1 NTPIN,DCMESH,INDEX,IDREG,IDSUR,ITPIN,DRAPIN) +*----------------------------------------------------------------------- +* +*Purpose: +* Load cell contents. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure. +* MAXMSH maximum number of elements in MESH array. +* ICEL requested cell index. +* +*Parameters: output +* IDIRC cylinders orientation. +* MESHC cell meshes size. +* NSURC number of surfaces for the cell. +* NREGC number of regions for the cell. +* NTPIN number of pins within the cell. +* DCMESH cell meshing vector. +* INDEX cell index vector. +* IDREG region index array. +* IDSUR surface index array. +* ITPIN pin integer descriptor. +* DRAPIN pin double descriptor. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER MAXMSH,ICEL,IDIRC,MESHC(4),NSURC,NREGC,NTPIN, + 1 INDEX(5,-NSURC:NREGC),IDREG(NREGC),IDSUR(NSURC),ITPIN(3,NTPIN) + DOUBLE PRECISION DCMESH(-1:MAXMSH,4),DRAPIN(-1:4,NTPIN) +*---- +* LOCAL VARIABLES +*---- + INTEGER NSTATE,IOUT + PARAMETER(NSTATE=40,IOUT=6) + INTEGER ESTATE(NSTATE) + INTEGER IDIR,ITYPG + CHARACTER NAMCEL*9,NAMREC*12 + CHARACTER CDIR(4)*1 + DATA CDIR /'X','Y','Z','R'/ +*---- +* LOAD CELL RECORDS +*---- + WRITE(NAMCEL,'(A1,I8.8)') 'C',ICEL + NAMREC=NAMCEL//'DIM' + ESTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,NAMREC,ESTATE) + ITYPG=ESTATE(1) + MESHC(1)=ESTATE(3) + MESHC(2)=ESTATE(4) + MESHC(3)=ESTATE(5) + MESHC(4)=ESTATE(2) + NREGC=ESTATE(8) + NSURC=ESTATE(9) + NTPIN=ESTATE(18) + NAMREC=NAMCEL//'RID' + CALL LCMGET(IPTRK,NAMREC,IDREG) + NAMREC=NAMCEL//'SID' + CALL LCMGET(IPTRK,NAMREC,IDSUR) + NAMREC=NAMCEL//'VSI' + CALL LCMGET(IPTRK,NAMREC,INDEX) + DO IDIR=1,4 + NAMREC=NAMCEL//'SM'//CDIR(IDIR) + IF(MESHC(IDIR).GT.0) THEN + CALL LCMGET(IPTRK,NAMREC,DCMESH(-1,IDIR)) + ENDIF + ENDDO + IF(NTPIN.GT.0) THEN + NAMREC=NAMCEL//'PIN' + CALL LCMGET(IPTRK,NAMREC,DRAPIN) + NAMREC=NAMCEL//'PNT' + CALL LCMGET(IPTRK,NAMREC,ITPIN) + ENDIF + IF(ITYPG .EQ. 20 .OR. ITYPG .EQ. 21 .OR. + > ITYPG .EQ. 22 .OR. ITYPG .EQ. 23) THEN + IF(ITYPG .EQ. 21 ) THEN + IDIRC=1 + ELSE IF(ITYPG .EQ. 22) THEN + IDIRC=2 + ELSE + IDIRC=3 + ENDIF + ELSE + IDIRC=0 + ENDIF +* + RETURN + END diff --git a/Dragon/src/NXTLDP.f b/Dragon/src/NXTLDP.f new file mode 100644 index 0000000..51be22f --- /dev/null +++ b/Dragon/src/NXTLDP.f @@ -0,0 +1,80 @@ +*DECK NXTLDP + SUBROUTINE NXTLDP(IPTRK,MAXMSH,IPIN,MESHP,NSURP,NREGP,DPMESH, + 1 INDEX,IDREG,IDSUR) +*----------------------------------------------------------------------- +* +*Purpose: +* Load pin contents. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure. +* MAXMSH maximum number of elements in MESH array. +* IPIN requested pin index. +* +*Parameters: output +* MESHP pin meshes size. +* NSURP number of surfaces for the pin. +* NREGP number of regions for the pin. +* DPMESH pin meshing vector. +* INDEX pin index vector. +* IDREG region index array. +* IDSUR surface index array. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER MAXMSH,IPIN,MESHP(4),NSURP,NREGP, + 1 INDEX(5,-NSURP:NREGP),IDREG(NREGP),IDSUR(NSURP) + DOUBLE PRECISION DPMESH(-1:MAXMSH,4) +*---- +* LOCAL VARIABLES +*---- + INTEGER NSTATE,IOUT + PARAMETER(NSTATE=40,IOUT=6) + INTEGER ESTATE(NSTATE) + INTEGER IDIR + CHARACTER NAMPIN*9,NAMREC*12 + CHARACTER CDIR(4)*1 + DATA CDIR /'X','Y','Z','R'/ +*---- +* LOAD PIN RECORDS +*---- + WRITE(NAMPIN,'(A1,I8.8)') 'P',IPIN + NAMREC=NAMPIN//'DIM' + ESTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,NAMREC,ESTATE) + MESHP(1)=ESTATE(3) + MESHP(2)=ESTATE(4) + MESHP(3)=ESTATE(5) + MESHP(4)=ESTATE(2) + NREGP=ESTATE(8) + NSURP=ESTATE(9) + NAMREC=NAMPIN//'RID' + CALL LCMGET(IPTRK,NAMREC,IDREG) + NAMREC=NAMPIN//'SID' + CALL LCMGET(IPTRK,NAMREC,IDSUR) + NAMREC=NAMPIN//'VSI' + CALL LCMGET(IPTRK,NAMREC,INDEX) + DO IDIR=1,4 + NAMREC=NAMPIN//'SM'//CDIR(IDIR) + IF(MESHP(IDIR) .GT. 0) THEN + CALL LCMGET(IPTRK,NAMREC,DPMESH(-1,IDIR)) + ENDIF + ENDDO +* + RETURN + END diff --git a/Dragon/src/NXTLHA.f b/Dragon/src/NXTLHA.f new file mode 100644 index 0000000..318a4fe --- /dev/null +++ b/Dragon/src/NXTLHA.f @@ -0,0 +1,691 @@ +*DECK NXTLHA + FUNCTION NXTLHA(IPRINT,ITST ,NDIM ,MXMESH,LINMAX, + > MESH ,ORITRK,DIRTRK,DCMESH, + > NBCOR ,NBSINT,ISINT ,TRKLSI) +* +*---------- +* +*Purpose: +* To track an hexagonal assembly in 2-D or 3-D geometry +* using the NXT tracking procedure. +* +*Copyright: +* Copyright (C) 2010 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau. +* +*Parameters: input +* IPRINT print level. +* ITST type of tracking, where: +* =-1 only the exact geometry +* is considered taking into account the +* submesh in each direction; +* = 0 only the global geometry +* is considered without taking into account the +* submesh in each direction; +* = 1 both the global +* geometry (as a first step) and the exact geometry +* are considered taking into account the +* submesh in each direction. +* NDIM dimension of problem. +* MXMESH maximum number of spatial subdivision in +* $X$, $Y$ or $Z$. +* LINMAX maximum number of segments in a track. +* MESH effective number of spatial subdivision in +* each direction ($X$, $Y$ and $Z$). +* ORITRK a point on the track (origin). +* DIRTRK the track direction (director cosines). +* DCMESH spatial description of the assembly. +* +*Parameters: output +* NXTLHA number of side intersections. +* NBCOR number of corner found for each external faces. +* NBSINT number of surface crossed by track. +* ISINT direction of plane intersected and +* the surfaces crossed by the track. +* TRKLSI the surface intersection distance. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,ITST,NDIM,MXMESH,LINMAX + INTEGER MESH(NDIM) + DOUBLE PRECISION ORITRK(NDIM), + > DIRTRK(NDIM), + > DCMESH(-1:MXMESH,5) + INTEGER NBCOR(2),NBSINT + INTEGER ISINT(0:5,LINMAX) + DOUBLE PRECISION TRKLSI(LINMAX) + INTEGER NXTLHA +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTLHA') + DOUBLE PRECISION DCUTOF,DZERO,DONE,DTWO + PARAMETER (DCUTOF=1.0D-9,DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Local variables +*---- + INTEGER IC1,IH,IDIR,IZ,ITF,ILF,ICELL + DOUBLE PRECISION SQ3,SO2,SQ3S,SQ3O2S,HO2,OT(3) + DOUBLE PRECISION PUX,PUY,PVX,PVY,PWX,PWY,PZ, + > SLPUX,SLPUY,SLPVX,SLPVY,SLPWX,SLPWY,SLPZ + DOUBLE PRECISION TINT(2,4),XY(4,12) + INTEGER IS,NS,IKS(8),IBL,IEL,ITL,IIS + DOUBLE PRECISION DK(8),DDK + INTEGER NSETL,IB,IC,NTTP,NMOVE +*---- +* Verify ITST option and reset to default value if invalid +*---- + IF(ITST .LT. -1 .OR. ITST .GT. 1) THEN +*---- +* Reset ITST=1 (complete analysis) if the value of ITST is invalid +*---- + ITST=1 + ENDIF + NBCOR(1)=1 + NBCOR(2)=1 + NBSINT=0 +*---- +* Initialise output vectors +*---- + ISINT(0:5,:LINMAX)=0 + TRKLSI(:LINMAX)=DZERO +*---- +* Print header if required +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6011) 'HexagonSIDE={ ' + WRITE(IOUT,6012) DCMESH(0,1) + WRITE(IOUT,6013) + WRITE(IOUT,6011) 'HexagonX={ ' + WRITE(IOUT,6012) (DCMESH(IC1,1),IC1=1,MESH(1)) + WRITE(IOUT,6013) + WRITE(IOUT,6011) 'HexagonY={ ' + WRITE(IOUT,6012) (DCMESH(IC1,2),IC1=1,MESH(1)) + WRITE(IOUT,6013) + IF(NDIM .EQ. 3) THEN + WRITE(IOUT,6011) 'HexagonZ={ ' + WRITE(IOUT,6012) (DCMESH(IC1,3),IC1=0,MESH(3)) + WRITE(IOUT,6013) + ENDIF + WRITE(IOUT,6011) 'trackorigin={ ' + WRITE(IOUT,6012) (ORITRK(IC1),IC1=1,NDIM) + WRITE(IOUT,6013) + WRITE(IOUT,6011) 'trackdirection={ ' + WRITE(IOUT,6012) (DIRTRK(IC1),IC1=1,NDIM) + WRITE(IOUT,6013) + ENDIF + SQ3=SQRT(3.0D0) + SO2=DCMESH(0,1)/DTWO + SQ3S=SQ3*DCMESH(0,1) + SQ3O2S=SQ3*SO2 + IEL=0 +*---- +* Scan over each hexagon in assembly +*---- + DO IH=1,MESH(1) +*---- +* Move origin to the (x,y) cell center +*---- + DO IDIR=1,2 + OT(IDIR)=ORITRK(IDIR)-DCMESH(IH,IDIR) + ENDDO +*---- +* Find intersection distance of U faces +*---- + PUX=OT(1) + PUY=OT(2) + SLPUX=DIRTRK(1) + SLPUY=DIRTRK(2) + TINT(1,1)=-(SQ3O2S+PUX)/SLPUX + TINT(2,1)= (SQ3O2S-PUX)/SLPUX +*---- +* Find intersection distance of V faces +*---- + PVX=(OT(1)-SQ3*OT(2))/DTWO + PVY=(OT(2)+SQ3*OT(1))/DTWO + SLPVX=(DIRTRK(1)-SQ3*DIRTRK(2))/DTWO + SLPVY=(DIRTRK(2)+SQ3*DIRTRK(1))/DTWO + TINT(1,2)=-(SQ3O2S+PVX)/SLPVX + TINT(2,2)= (SQ3O2S-PVX)/SLPVX +*---- +* Find intersection distance of W faces +*---- + PWX=(OT(1)+SQ3*OT(2))/DTWO + PWY=(OT(2)-SQ3*OT(1))/DTWO + SLPWX=(DIRTRK(1)+SQ3*DIRTRK(2))/DTWO + SLPWY=(DIRTRK(2)-SQ3*DIRTRK(1))/DTWO + TINT(1,3)=-(SQ3O2S+PWX)/SLPWX + TINT(2,3)= (SQ3O2S-PWX)/SLPWX + IF(NDIM .EQ. 2) THEN +*---- +* Test for U faces +*---- + NS=0 + DO ITF=1,2 + XY(ITF,1)=PUY+SLPUY*TINT(ITF,1) + IF(ABS(XY(ITF,1)) .LE. SO2) THEN + NS=NS+1 + DK(NS)=TINT(ITF,1) + IKS(NS)=3*(2-ITF)+1 + ENDIF + ENDDO +*---- +* Test for V faces +*---- + DO ITF=1,2 + XY(ITF,2)=PVY+SLPVY*TINT(ITF,2) + IF(ABS(XY(ITF,2)) .LE. SO2) THEN + NS=NS+1 + DK(NS)=TINT(ITF,2) + IKS(NS)=3+3*(ITF-1) + ENDIF + ENDDO +*---- +* Test for W faces +*---- + DO ITF=1,2 + XY(ITF,3)=PWY+SLPWY*TINT(ITF,3) + IF(ABS(XY(ITF,3)) .LE. SO2) THEN + NS=NS+1 + DK(NS)=TINT(ITF,3) + IKS(NS)=3*(2-ITF)+2 + ENDIF + ENDDO + IF( NS .EQ. 2 ) THEN +*---- +* Save cell crossing info +*---- + IF(DK(1) .GT. DK(2)) THEN + ITF=IKS(1) + IKS(1)=IKS(2) + IKS(2)=ITF + DDK=DK(1) + DK(1)=DK(2) + DK(2)=DDK + ENDIF +*---- +* Combine segments in ISINT and TRKLSI +*---- + IF(IEL .EQ. 0) THEN +*---- +* First segment +*---- + DO IS=1,NS + IEL=IEL+1 +*---- +* HEX-FACE +*---- + ISINT(0,IEL)=IH + ISINT(1,IEL)=IH + ISINT(2,IEL)=-IKS(IS) + ISINT(3,IEL)=1 + ISINT(4,IEL)=0 + TRKLSI(IEL)=DK(IS) + ENDDO + ELSE +*---- +* Remaining segments +*---- + IBL=IEL + DO ITL=1,IEL + DDK=TRKLSI(ITL)-DK(2) +* write(6,*) IEL,ITL,IBL,TRKLSI(ITL),ISINT(0,ITL), +* > DK(2),IH,DDK + IF(DDK .GT. -DCUTOF) THEN + DO IBL=IEL,ITL,-1 + TRKLSI(IBL+2)=TRKLSI(IBL) + ISINT(0,IBL+2)=ISINT(0,IBL) + ISINT(1,IBL+2)=ISINT(1,IBL) + ISINT(2,IBL+2)=ISINT(2,IBL) + ISINT(3,IBL+2)=ISINT(3,IBL) + ISINT(4,IBL+2)=ISINT(4,IBL) + ENDDO + IBL=ITL-1 + GO TO 100 + ENDIF + ENDDO + 100 CONTINUE + IEL=IEL+2 + DO IS=1,NS + IBL=IBL+1 +*---- +* HEX-FACE +*---- + ISINT(0,IBL)=IH + ISINT(1,IBL)=IH + ISINT(2,IBL)=-IKS(IS) + ISINT(3,IBL)=1 + ISINT(4,IBL)=0 + TRKLSI(IBL)=DK(IS) + ENDDO + ENDIF +* WRITE(IOUT,*) '2-D tracking for cell= ',IH +* WRITE(IOUT,'(2I10,F20.15)') +* > (ITF,IKS(ITF),DK(ITF),ITF=1,NS) + ELSE IF( NS .GE. 1) THEN + WRITE(IOUT,9000) IH,NS + WRITE(IOUT,9001) (ITF,IKS(ITF),IH,DK(ITF),ITF=1,NS) + WRITE(IOUT,9002) (XY(ITF,1),XY(ITF,2),XY(ITF,3),ITF=1,2) + WRITE(IOUT,9003) IH + WRITE(IOUT,9004) + > 'U ',PUX,SLPUX,PUY,SLPUY,TINT(1,1),TINT(2,1) + WRITE(IOUT,9004) + > 'V ',PVX,SLPVX,PVY,SLPVY,TINT(1,2),TINT(2,2) + WRITE(IOUT,9004) + > 'W ',PWX,SLPWX,PWY,SLPWY,TINT(1,3),TINT(2,3) + CALL XABORT(NAMSBR// + > ': Problem with 2-D tracking -> '// + > ' line can only cross 0 or 2 surfaces in a cell') + ENDIF + ELSE +*---- +* scan over Z planes +*---- + DO IZ=1,MESH(3) + ICELL=IH+(IZ-1)*MESH(1) +*---- +* Move origin to center of the plane in Z +*---- + OT(3)=ORITRK(3)-(DCMESH(IZ,IDIR)+DCMESH(IZ-1,IDIR))/DTWO + HO2=(DCMESH(IZ,IDIR)-DCMESH(IZ-1,IDIR))/DTWO +*---- +* Find intersection distance of Z faces +*---- + PZ=OT(3) + SLPZ=DIRTRK(3) + TINT(1,4)=-(HO2+PZ)/SLPZ + TINT(2,4)=(HO2-PZ)/SLPZ +*---- +* Test for U faces +*---- + NS=0 + DO ITF=1,2 + XY(ITF,1)=PUY+SLPUY*TINT(ITF,1) + XY(ITF,2)=PZ+SLPZ*TINT(ITF,1) + IF( (ABS(XY(ITF,1)) .LE. SO2) .AND. + > (ABS(XY(ITF,2)) .LE. HO2 ) ) THEN + NS=NS+1 + DK(NS)=TINT(ITF,1) + IKS(NS)=3*(2-ITF)+1 + ENDIF + ENDDO +*---- +* Test for V faces +*---- + DO ITF=1,2 + XY(ITF,3)=PVY+SLPVY*TINT(ITF,2) + XY(ITF,4)=PZ+SLPZ*TINT(ITF,2) + IF( (ABS(XY(ITF,3)) .LE. SO2) .AND. + > (ABS(XY(ITF,4)) .LE. HO2 ) ) THEN + NS=NS+1 + DK(NS)=TINT(ITF,2) + IKS(NS)=3+3*(ITF-1) + ENDIF + ENDDO +*---- +* Test for W faces +*---- + DO ITF=1,2 + XY(ITF,5)=PWY+SLPWY*TINT(ITF,3) + XY(ITF,6)=PZ+SLPZ*TINT(ITF,3) + IF( (ABS(XY(ITF,5)) .LE. SO2) .AND. + > (ABS(XY(ITF,6)) .LE. HO2 ) ) THEN + NS=NS+1 + DK(NS)=TINT(ITF,3) + IKS(NS)=3*(2-ITF)+2 + ENDIF + ENDDO +*---- +* Test for Z faces +*---- + DO ITF=1,2 + XY(ITF,7)=PUX+SLPUX*TINT(ITF,4) + XY(ITF,8)=PUY+SLPUY*TINT(ITF,4) + XY(ITF,9)=PVX+SLPVX*TINT(ITF,4) + XY(ITF,10)=PVY+SLPVY*TINT(ITF,4) + XY(ITF,11)=PWX+SLPWX*TINT(ITF,4) + XY(ITF,12)=PWY+SLPWY*TINT(ITF,4) + IF( ((ABS(XY(ITF,7)) .LE. SQ3O2S) .AND. + > (ABS(XY(ITF,8)) .LE. SO2 ) ) .OR. + > ((ABS(XY(ITF,9)) .LE. SQ3O2S) .AND. + > (ABS(XY(ITF,10)) .LE. SO2 ) ) .OR. + > ((ABS(XY(ITF,11)) .LE. SQ3O2S) .AND. + > (ABS(XY(ITF,12)) .LE. SO2 ) ) ) THEN + NS=NS+1 + DK(NS)=TINT(ITF,4) + IKS(NS)=6+ITF + ENDIF + ENDDO +**** +* remove ENDDO and put at the end of loop. +**** +* ENDDO + IF( NS .EQ. 2 ) THEN +*---- +* Save cell crossing info +*---- + IF(DK(1) .GT. DK(2)) THEN + ITF=IKS(1) + IKS(1)=IKS(2) + IKS(2)=ITF + DDK=DK(1) + DK(1)=DK(2) + DK(2)=DDK + ENDIF +*---- +* Combine segments in ISINT and TRKLSI +*---- + IF(IEL .EQ. 0) THEN +*---- +* First segment +*---- + DO IS=1,NS + IEL=IEL+1 + ISINT(0,IEL)=(IZ-1)*MESH(1)+IH + IF(IKS(IS) .GT. 6) THEN +*---- +* Z-FACE +*---- + ISINT(1,IEL)=IH + ISINT(2,IEL)=0 + ISINT(3,IEL)=IZ + ISINT(4,IEL)=-IKS(IS) + ELSE +*---- +* HEX-FACE +*---- + ISINT(1,IEL)=IH + ISINT(2,IEL)=-IKS(IS) + ISINT(3,IEL)=IZ + ISINT(4,IEL)=0 + ENDIF + TRKLSI(IEL)=DK(IS) + ENDDO + ELSE +*---- +* Remaining segments +*---- + IBL=IEL + DO ITL=1,IEL + IF(DK(2) .LE. TRKLSI(ITL) ) THEN + DO IBL=IEL,ITL,-1 + TRKLSI(IBL+2)=TRKLSI(IBL) + ISINT(0,IBL+2)=ISINT(0,IBL) + ISINT(1,IBL+2)=ISINT(1,IBL) + ISINT(2,IBL+2)=ISINT(2,IBL) + ISINT(3,IBL+2)=ISINT(3,IBL) + ISINT(4,IBL+2)=ISINT(4,IBL) + ENDDO + IBL=ITL-1 + GO TO 110 + ENDIF + ENDDO + 110 CONTINUE + IEL=IEL+2 + DO IS=1,NS + IBL=IBL+1 + ISINT(0,IBL)=(IZ-1)*MESH(1)+IH + IF(IKS(IS) .GT. 6) THEN +*---- +* Z-FACE +*---- + ISINT(1,IBL)=IH + ISINT(2,IBL)=0 + ISINT(3,IBL)=IZ + ISINT(4,IBL)=-IKS(IS) + ELSE +*---- +* HEX-FACE +*---- + ISINT(1,IBL)=IH + ISINT(2,IBL)=-IKS(IS) + ISINT(3,IBL)=IZ + ISINT(4,IBL)=0 + ENDIF + TRKLSI(IBL)=DK(IS) + ENDDO + ENDIF +* write(IOUT,*) '3-D tracking results' +* write(IOUT,'(2I10/(2I10,F20.15))') IH,IZ, +* > (ITF,IKS(ITF),DK(ITF),ITF=1,2) + ELSE IF( NS .GE. 1) THEN + WRITE(IOUT,9010) IH,IZ,NS + WRITE(IOUT,9011) (ITF,IKS(ITF),IH,IZ,DK(ITF),ITF=1,NS) + WRITE(IOUT,9002) ((XY(ITF,ILF),ITF=1,2),ILF=1,12) + WRITE(IOUT,9003) IH + WRITE(IOUT,9004) + > 'U ',PUX,SLPUX,PUY,SLPUY,TINT(1,1),TINT(2,1) + WRITE(IOUT,9004) + > 'V ',PVX,SLPVX,PVY,SLPVY,TINT(1,2),TINT(2,2) + WRITE(IOUT,9004) + > 'W ',PWX,SLPWX,PWY,SLPWY,TINT(1,3),TINT(2,3) + WRITE(IOUT,9004) + > 'Z ',PZ,SLPZ,TINT(1,4),TINT(2,4) + CALL XABORT(NAMSBR// + > ': Problem with 3-D tracking -> '// + > ' line can only cross 0 or 2 surfaces in a cell') + ENDIF +**** +* ENDDO inserted here. +**** + ENDDO + ENDIF + ENDDO + NXTLHA=IEL + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6030) + DO IS=1,NXTLHA + IF(ISINT(0,IS) .EQ. 0) THEN + WRITE(IOUT,6020) IS, + > (ISINT(IDIR,IS),IDIR=0,5),TRKLSI(IS) + ELSE + WRITE(IOUT,6022) IS, + > (ISINT(IDIR,IS),IDIR=0,5),TRKLSI(IS) + ENDIF + ENDDO + ENDIF +*---- +* Test if all faces are consecutive otherwise +* Add intermediate region containing a cell with +* id=0 +*---- + NSETL=0 + ITL=IEL-1 + DO IS=IEL/2,2,-1 + DDK=TRKLSI(ITL)-TRKLSI(ITL-1) +* DCUT=DCUTOF*ABS(TRKLSI(ITL)+TRKLSI(ITL-1))/DTWO + IF(ABS(DDK) .GT. DCUTOF) THEN + NMOVE=NXTLHA+NSETL + NSETL=NSETL+1 + DO IBL=NMOVE,ITL,-1 + TRKLSI(IBL+1)=TRKLSI(IBL) + DO IIS=0,4 + ISINT(IIS,IBL+1)=ISINT(IIS,IBL) + ENDDO + ENDDO + DO IIS=0,4 + ISINT(IIS,ITL)=0 + ENDDO + TRKLSI(ITL)=DDK + ENDIF + ITL=ITL-2 + ENDDO + NXTLHA=NXTLHA+NSETL + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6032) + DO IS=1,NXTLHA + IF(ISINT(0,IS) .EQ. 0) THEN + WRITE(IOUT,6020) IS, + > (ISINT(IDIR,IS),IDIR=0,5),TRKLSI(IS) + ELSE + WRITE(IOUT,6022) IS, + > (ISINT(IDIR,IS),IDIR=0,5),TRKLSI(IS) + ENDIF + ENDDO + ENDIF + NBSINT=NXTLHA+NSETL+1 + ITL=NBSINT + IBL=0 + NTTP=0 + DO IS=NXTLHA,2,-1 + IC=ISINT(0,IS) + IF(IC .EQ. 0) THEN +*---- +* Block outside cell +*---- +* write(6,*) IS,ITL,'Block outside cell' + TRKLSI(ITL)=TRKLSI(IS) + DO IIS=0,4 + ISINT(IIS,ITL)=ISINT(IIS,IS) + ENDDO + ITL=ITL-1 + IBL=0 + NTTP=NTTP+1 + ELSE + IF(IBL .EQ. 0) THEN +*---- +* Block last face +*---- +* write(6,*) IS,ITL,'Block last face' + TRKLSI(ITL)=TRKLSI(IS) + ISINT(0,ITL)=-ISINT(0,IS) + DO IIS=1,4 + ISINT(IIS,ITL)=ISINT(IIS,IS) + ENDDO + ITL=ITL-1 +*---- +* Block last region +*---- +* write(6,*) IS,ITL,'Block last region' + TRKLSI(ITL)=TRKLSI(IS)-TRKLSI(IS-1) + DO IIS=0,4 + ISINT(IIS,ITL)=ISINT(IIS,IS-1) + ENDDO + ISINT(2,ITL)=ISINT(1,IS-1) + ITL=ITL-1 + IBL=1 + NTTP=NTTP+2 + ELSE + IB=ISINT(0,IS-1) + IF(IB .EQ. 0) THEN +*---- +* Block initial face +*---- +* write(6,*) IS,ITL,'Block initial face' + TRKLSI(ITL)=TRKLSI(IS) + ISINT(0,ITL)=-ISINT(0,IS) + DO IIS=1,4 + ISINT(IIS,ITL)=ISINT(IIS,IS) + ENDDO + ITL=ITL-1 + NTTP=NTTP+1 + ELSE +*---- +* Block region +*---- +* write(6,*) IS,ITL,'Block region' + TRKLSI(ITL)=TRKLSI(IS)-TRKLSI(IS-1) + DO IIS=0,4 + ISINT(IIS,ITL)=ISINT(IIS,IS-1) + ENDDO + ISINT(2,ITL)=ISINT(1,IS-1) + ITL=ITL-1 + NTTP=NTTP+1 + ENDIF + ENDIF + ENDIF + ENDDO +*---- +* Initial face +*---- + IS=1 +* write(6,*) IS,ITL,'Line initial face' + TRKLSI(ITL)=TRKLSI(IS) + ISINT(0,ITL)=-ISINT(0,IS) + DO IIS=1,4 + ISINT(IIS,ITL)=ISINT(IIS,IS) + ENDDO + NBSINT=NTTP +*---- +* Compress file for successive regions +*---- + IIS=0 + DO IS=1,NBSINT+1 + IF(ISINT(0,IS) .GT. 0) THEN + DDK=ABS(TRKLSI(IS)) + IF(DDK .GT. DCUTOF) THEN + IIS=IIS+1 + TRKLSI(IIS)=TRKLSI(IS) + DO IDIR=0,4 + ISINT(IDIR,IIS)=ISINT(IDIR,IS) + ENDDO + ENDIF + ELSE + IIS=IIS+1 + TRKLSI(IIS)=TRKLSI(IS) + DO IDIR=0,4 + ISINT(IDIR,IIS)=ISINT(IDIR,IS) + ENDDO + ENDIF + ENDDO + NBSINT=IIS-1 +*---- +* Print final track information +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6031) NBSINT+1 + DO IS=1,NBSINT+1 + IF(ISINT(0,IS) .EQ. 0) THEN + WRITE(IOUT,6020) IS, + > (ISINT(IDIR,IS),IDIR=0,5),TRKLSI(IS) + ELSE IF(ISINT(0,IS) .GT. 0) THEN + WRITE(IOUT,6021) IS, + > (ISINT(IDIR,IS),IDIR=0,5),TRKLSI(IS) + ELSE + WRITE(IOUT,6022) IS, + > (ISINT(IDIR,IS),IDIR=0,5),TRKLSI(IS) + ENDIF + ENDDO + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6011 FORMAT(A20) + 6012 FORMAT(6(1X,F25.16,:,',')) + 6013 FORMAT('};') + 6020 FORMAT('Tracks point =',I10,' is outside cell :',6I10,F25.16) + 6021 FORMAT('Tracks segment=',I10,' is in region :',6I10,F25.16) + 6022 FORMAT('Tracks point =',I10,' is on cell surface:',6I10,F25.16) + 6030 FORMAT('Intersection point with hexagonal faces') + 6031 FORMAT('Final ',I10,' track segments ') + 6032 FORMAT('Intersection point plus outside cells') + 9000 FORMAT(' Problem in 2-D tracking for cell= ',2I10) + 9001 FORMAT(3I10,F25.16) + 9002 FORMAT(2F25.16) + 9003 FORMAT('Cell = ',I10) + 9004 FORMAT(A3,1X,6F25.16) + 9010 FORMAT(' Problem in 3-D tracking for cell= ',3I10) + 9011 FORMAT(4I10,F25.16) + END diff --git a/Dragon/src/NXTLHT.f b/Dragon/src/NXTLHT.f new file mode 100644 index 0000000..9c449d7 --- /dev/null +++ b/Dragon/src/NXTLHT.f @@ -0,0 +1,415 @@ +*DECK NXTLHT + FUNCTION NXTLHT(IPRINT,ITST ,NDIM ,MXMESH,LINMAX, + > MESH ,ORITRK,DIRTRK,DCMESH,TRKLIM, + > NBCOR ,NBSINT,ISINT ,TRKLSI) +* +*---------- +* +*Purpose: +* To track a triangular hexagon in 2-D or 3-D geometry +* using the NXT tracking procedure. +* +*Copyright: +* Copyright (C) 2010 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau. +* +*Parameters: input +* IPRINT print level. +* ITST type of tracking, where: +* =-1 only the exact geometry +* is considered taking into account the +* submesh in each direction; +* = 0 only the global geometry +* is considered without taking into account the +* submesh in each direction; +* = 1 both the global +* geometry (as a first step) and the exact geometry +* are considered taking into account the +* submesh in each direction. +* NDIM dimension of problem. +* MXMESH maximum number of spatial subdivision in +* $U$, $V$, $Z$ and $W$. +* LINMAX maximum number of segments in a track. +* MESH effective number of spatial subdivision in +* each direction ($U$, $W$, $Z$ and $W$). +* ORITRK a point on the track (origin). The triangular hexagon is +* assumed centered at the origin. +* DIRTRK the track direction (director cosines). +* DCMESH spatial description of the triangular hexagon. +* TRKLIM beginning and end of track in this cell. +* +*Parameters: output +* NXTLHT number of side intersections. +* NBCOR number of corner found for each external faces. +* NBSINT number of surface crossed by track. +* ISINT direction of plane intersected and +* the surfaces crossed by the track. +* TRKLSI the surface intersection distance. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,ITST,NDIM,MXMESH,LINMAX + INTEGER MESH(NDIM) + DOUBLE PRECISION ORITRK(NDIM),DIRTRK(NDIM), + > DCMESH(-1:MXMESH,5),TRKLIM(2) + INTEGER NBCOR(2),NBSINT + INTEGER ISINT(0:5,LINMAX) + DOUBLE PRECISION TRKLSI(LINMAX) + INTEGER NXTLHT +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTLHT') + DOUBLE PRECISION DCUTOF,DZERO,DONE + PARAMETER (DCUTOF=1.0D-9,DZERO=0.0D0,DONE=1.0D0) +*---- +* Local variables +*---- + INTEGER ITC,IEL,KDIR,IDIR,IFRST,ILAST,INEXT(5),IFACE, + > ISF(5),ISL(5),KEL,JEL,IDIRS,MESHL(5) + DOUBLE PRECISION DEP,SLP,TRKDIS,DISF,DISL + DOUBLE PRECISION XXX,YYY +*---- +* Data +*---- + CHARACTER CDIR(5)*1 + DOUBLE PRECISION VNORMD(3,5) + SAVE CDIR,VNORMD + DATA CDIR /'U','V','Z','R','W'/ + DATA VNORMD / + > 1.0D0,0.0D0 ,0.0D0, + > 0.5D0,0.866025403784439D0 ,0.0D0, + > 0.0D0,0.0D0 ,1.0D0, + > 1.0D0,0.0D0 ,0.0D0, + > 0.5D0,-0.866025403784439D0,0.0D0/ + +*---- +* Verify ITST option and reset to default value if invalid +*---- + IF(ITST .LT. -1 .OR. ITST .GT. 1) THEN +*---- +* Reset ITST=1 (complete analysis) if the value of ITST is invalid +*---- + ITST=1 + ENDIF +*---- +* Initialise output vectors +*---- + NBCOR(1)=0 + NBCOR(2)=0 + MESHL(1)=MESH(1) + MESHL(2)=MESH(1) + MESHL(3)=MESH(3) + MESHL(5)=MESH(1) + DISF=0.0D0 + DISL=0.0D0 + ISINT(0:5,:LINMAX)=0 + TRKLSI(:LINMAX)=DZERO +*---- +* U,V and W MESH identical +*---- + DO ITC=0,MESH(1) + DCMESH(ITC,2)=DCMESH(ITC,1) + DCMESH(ITC,5)=DCMESH(ITC,1) + ENDDO +*---- +* Print header if required +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6011) 'mesh'//CDIR(1)//'={ ' + WRITE(IOUT,6012) (DCMESH(ITC,1),ITC=0,MESHL(1)) + WRITE(IOUT,6013) + WRITE(IOUT,6011) 'mesh'//CDIR(2)//'={ ' + WRITE(IOUT,6012) (DCMESH(ITC,2),ITC=0,MESHL(2)) + WRITE(IOUT,6013) + WRITE(IOUT,6011) 'mesh'//CDIR(5)//'={ ' + WRITE(IOUT,6012) (DCMESH(ITC,5),ITC=0,MESHL(5)) + WRITE(IOUT,6013) + IF(NDIM .EQ. 3) THEN + WRITE(IOUT,6011) 'mesh'//CDIR(3)//'={ ' + WRITE(IOUT,6012) (DCMESH(ITC,3),ITC=0,MESHL(3)) + WRITE(IOUT,6013) + ENDIF + WRITE(IOUT,6016) 'Htrackorigin={ ' + WRITE(IOUT,6012) ORITRK + WRITE(IOUT,6013) + WRITE(IOUT,6016) 'Htrackdirection={ ' + WRITE(IOUT,6012) DIRTRK + WRITE(IOUT,6013) + ENDIF +* write(6,*) 'TRKLIM = ',TRKLIM(1),TRKLIM(2) +*---- +* Scan over directions +*---- + IEL=0 + DO IDIR=1,5 + ISF(IDIR)=0 + ISL(IDIR)=0 + IF(IDIR .EQ. 4) GO TO 100 + DEP=DZERO + SLP=DZERO + DO ITC=1,3 + DEP=DEP+ORITRK(ITC)*VNORMD(ITC,IDIR) + SLP=SLP+DIRTRK(ITC)*VNORMD(ITC,IDIR) + ENDDO + IF(IDIR .EQ. 3 .AND. NDIM .NE. 3) GO TO 100 +*---- +* Select planes order in direction IDIR (forward or backward) +*---- + IF(SLP .LT. 0) THEN + INEXT(IDIR)=-1 + IFRST=MESHL(IDIR)+1 + ILAST=1 + ELSE + INEXT(IDIR)=1 + IFRST=1 + ILAST=MESHL(IDIR)+1 + ENDIF +*---- +* Scan over planes in direction IDIR +*---- +* write(6,'(A10,5X,4I10,2F20.10)')' Direction=',IDIR,IFRST,ILAST, +* > INEXT(IDIR),DEP,SLP + DO IFACE=IFRST,ILAST,INEXT(IDIR) +*---- +* Compute track length required to reach a face +*---- + IF(ABS(SLP) .LT. DCUTOF) CALL XABORT(NAMSBR// + > ': line parallel to face not yet programmed') + TRKDIS=(DCMESH(IFACE-1,IDIR)-DEP)/SLP + XXX=ABS(TRKLIM(1)-TRKDIS) + YYY=ABS(TRKLIM(2)-TRKDIS) +* write(6,'(A10,I10,4F20.10)') +* > 'Face ',IFACE,DCMESH(IFACE-1,IDIR),TRKDIS,XXX,YYY +*---- +* Store point only if it is inside cell +*---- + IF(XXX .LT. DCUTOF .OR. YYY .LT. DCUTOF) THEN +* write(6,*) 'Intersection at ',TRKDIS,' for outer face' + KEL=IEL + DO JEL=1,IEL + IF(TRKDIS .LT. TRKLSI(JEL)) THEN + DO KEL=IEL,JEL,-1 + TRKLSI(KEL+1)=TRKLSI(KEL) + DO ITC=0,5 + ISINT(ITC,KEL+1)=ISINT(ITC,KEL) + ISINT(ITC,KEL)=0 + ENDDO + ENDDO + KEL=JEL-1 + GO TO 111 + ENDIF + ENDDO + 111 CONTINUE + TRKLSI(KEL+1)=TRKDIS + ISINT(0,KEL+1)=INEXT(IDIR)*IDIR + ISINT(IDIR,KEL+1)=IFACE +* write(6,*) KEL+1,ISINT(0,KEL+1),ISINT(IDIR,KEL+1) + IEL=IEL+1 + ELSE IF(TRKDIS .LT. TRKLIM(1) ) THEN +*---- +*GMC Corriger pour direction de la ligne +*---- + IF(ISF(IDIR) .EQ. 0) THEN + ISF(IDIR)=IFACE+MIN(INEXT(IDIR),0) + DISF=TRKDIS + ELSE IF(TRKDIS .GT. DISF) THEN + ISF(IDIR)=IFACE+MIN(INEXT(IDIR),0) + DISF=TRKDIS + ENDIF +* write(6,*) 'Before 1 ',ISF(IDIR),DISF + ELSE IF(TRKDIS .GT. TRKLIM(2) ) THEN +*---- +*GMC Corriger pour direction de la ligne +*---- + IF(ISL(IDIR) .EQ. 0) THEN + ISL(IDIR)=IFACE-MAX(INEXT(IDIR),0) + DISL=TRKDIS + ELSE IF(TRKDIS .LT. DISL) THEN + ISL(IDIR)=IFACE-MAX(INEXT(IDIR),0) + DISL=TRKDIS + ENDIF +* write(6,*) 'After 2 ',ISL(IDIR),DISF + ELSE +*---- +* Store point in adequate order in TRKLIS +*---- +* write(6,*) 'Intersection at ',TRKDIS,' inside cell' + KEL=IEL + DO JEL=1,IEL + IF(TRKDIS .LT. TRKLSI(JEL)) THEN + DO KEL=IEL,JEL,-1 + TRKLSI(KEL+1)=TRKLSI(KEL) + DO ITC=0,5 + ISINT(ITC,KEL+1)=ISINT(ITC,KEL) + ISINT(ITC,KEL)=0 + ENDDO + ENDDO + KEL=JEL-1 + GO TO 110 + ENDIF + ENDDO + 110 CONTINUE + TRKLSI(KEL+1)=TRKDIS + ISINT(0,KEL+1)=INEXT(IDIR)*IDIR + ISINT(IDIR,KEL+1)=IFACE +* write(6,*) KEL+1,ISINT(0,KEL+1),ISINT(IDIR,KEL+1) + IEL=IEL+1 + ENDIF + ENDDO + 100 CONTINUE + ENDDO + NBSINT=IEL + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6016) 'HtrackIntA={ ' + DO JEL=1,NBSINT-1 + WRITE(IOUT,6014) TRKLSI(JEL), + > (ISINT(IDIR,JEL),IDIR=0,5) + ENDDO + JEL=NBSINT + WRITE(IOUT,6015) TRKLSI(JEL), + > (ISINT(IDIR,JEL),IDIR=0,5) + ENDIF +*---- +* Process corners inside cell +*---- + KEL=1 + DO JEL=2,NBSINT + XXX=ABS(TRKLSI(JEL)-TRKLSI(KEL)) + IF(XXX .LT. DCUTOF) THEN + ISINT(0,KEL)=5 + IDIR=ABS(ISINT(0,JEL)) + ISINT(IDIR,KEL)=ISINT(IDIR,JEL) + ELSE + KEL=KEL+1 + TRKLSI(KEL)=TRKLSI(JEL) + DO IDIR=0,5 + ISINT(IDIR,KEL)=ISINT(IDIR,JEL) + ENDDO + ENDIF + ENDDO + NBSINT=KEL + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6016) 'HtrackIntB={ ' + DO JEL=1,NBSINT-1 + WRITE(IOUT,6014) TRKLSI(JEL), + > (ISINT(IDIR,JEL),IDIR=0,5) + ENDDO + JEL=NBSINT + WRITE(IOUT,6015) TRKLSI(JEL), + > (ISINT(IDIR,JEL),IDIR=0,5) + ENDIF +*---- +* Identify final faces +*---- + JEL=NBSINT + IDIR=ABS(ISINT(0,JEL)) + ISINT(0,JEL+1)=ISINT(0,JEL) + TRKLSI(JEL+1)=TRKLSI(JEL) + NBCOR(2)=1 + DO IDIRS=1,5 + IF(IDIRS .EQ. IDIR) THEN + IF(ISINT(IDIRS,JEL) .EQ. 1) THEN + ISINT(IDIRS,JEL+1)=-1 + ELSE + ISINT(IDIRS,JEL+1)=-2 + ENDIF + ELSE + ISINT(IDIRS,JEL+1)=ISL(IDIRS) + ENDIF + ENDDO +*---- +* Regions +*---- + DO JEL=NBSINT,2,-1 + TRKLSI(JEL)=TRKLSI(JEL)-TRKLSI(JEL-1) + IDIR=ABS(ISINT(0,JEL)) + IF(IDIR .EQ. 5) THEN + DO IDIRS=1,5 + KDIR=ISINT(IDIRS,JEL) + IF(KDIR .NE. 0) THEN + ISINT(IDIRS,JEL)=KDIR-MAX(INEXT(IDIRS),0) + ELSE + ISINT(IDIRS,JEL)=ISINT(IDIRS,JEL+1) + ENDIF + ENDDO + ELSE + DO IDIRS=1,5 + IF(IDIRS .EQ. IDIR) THEN + ISINT(IDIRS,JEL)=ISINT(IDIRS,JEL)-MAX(INEXT(IDIR),0) + ELSE + ISINT(IDIRS,JEL)=ISINT(IDIRS,JEL+1) + ENDIF + ENDDO + ENDIF + ENDDO +*---- +* Identify initial faces +*---- + JEL=1 + IDIR=ABS(ISINT(0,JEL)) + NBCOR(1)=1 + DO IDIRS=1,5 + IF(IDIRS .EQ. IDIR) THEN + IF(ISINT(IDIRS,JEL) .EQ. 1) THEN + ISINT(IDIRS,JEL)=-1 + ELSE + ISINT(IDIRS,JEL)=-2 + ENDIF + ELSE + ISINT(IDIRS,JEL)=ISF(IDIRS) + ENDIF + ENDDO + NBSINT=NBSINT +*---- +* Print final track information +*---- + IF(IPRINT .GT. 100) THEN + WRITE(IOUT,6011) 'Initial face ' + JEL=1 + WRITE(IOUT,6010) TRKLSI(JEL), + > (ISINT(IDIR,JEL),IDIR=1,5) + WRITE(IOUT,6011) 'Regions ' + DO JEL=2,NBSINT + WRITE(IOUT,6010) TRKLSI(JEL), + > (ISINT(IDIR,JEL),IDIR=1,5) + ENDDO + WRITE(IOUT,6011) 'Final face ' + JEL=NBSINT+1 + WRITE(IOUT,6010) TRKLSI(JEL), + > (ISINT(IDIR,JEL),IDIR=1,5) + WRITE(IOUT,6001) NAMSBR + ENDIF + NXTLHT=NBSINT + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(1X,F25.16,6I10) + 6011 FORMAT(A20) + 6012 FORMAT(6(1X,F25.16,:,',')) + 6013 FORMAT('};') + 6014 FORMAT(('{',F25.16,6(',',I5),'},')) + 6015 FORMAT(('{',F25.16,9(',',I5),'}};')) + 6016 FORMAT(A20) + END diff --git a/Dragon/src/NXTLRH.f b/Dragon/src/NXTLRH.f new file mode 100644 index 0000000..0c7393a --- /dev/null +++ b/Dragon/src/NXTLRH.f @@ -0,0 +1,377 @@ +*DECK NXTLRH + SUBROUTINE NXTLRH(IPRINT,IOVER ,ITYPG ,LINMAX,MXSLIN, + > NREG ,NSUR ,MESH ,IDSUR ,IDREG , + > NBCOR ,NBSINT,ISINT ,TRKLSI, + > IBLIN ,IELIN ,NUMERO,DLENGT,VSI) +* +*---------- +* +*Purpose: +* To store line segments in tracking +* vector for HEXT or HEXTZ geometry +* with global region and surface identification. +* +*Copyright: +* Copyright (C) 2012 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau. +* +*Parameters: input +* IPRINT print level. +* IOVER flag to everlap tracks on current lines. Here only the case +* IOVER=0 is permitted and the tracks are only stored +* after the current tracks. +* ITYPG type of geometry. +* LINMAX maximum number of segments in a complete track. +* MXSLIN maximum number of segments in a subgeometry track. +* NREG maximum number of regions in geometry. +* NSUR maximum number of surfaces in geometry. +* MESH effective number of spatial subdivision in $X$ +* $Y$, $Z$ and $R$. +* IDSUR local surface identifier. +* IDREG local region identifier. +* NBCOR number of corner found for each external faces. +* NBSINT number of surface crossed by track. +* ISINT direction of plane intersected and +* the surfaces crossed by the track: +* ISINT(0,I) not used here; +* IU=ISINT(1,I); +* IV=ISINT(2,I); +* IZ=ISINT(3,I); +* IR=ISINT(4,I); +* IW=ISINT(5,I). +* For global HEXT or HEXTZ geometry +* a) Internal regions +* (IU,IV,IZ,IW) is location of region. +* b) External surfaces. +* One and only one of IX, IY, IZ or IW is negative +* with: +* IU=-1 for U- face with position (IV,IZ,IW); +* IU=-2 for U+ face with position (IV,IZ.IW); +* IV=-1 for V- face with position (IU,IZ,IW); +* IV=-2 for V+ face with position (IU,IZ,IW); +* IZ=-1 for Z- face with position (IX,IY,IW); +* IZ=-2 for Z+ face with position (IX,IY,IW); +* IW=-1 for W- face with position (IX,IY,IZ); +* IW=-2 for W+ face with position (IX,IY,IZ). +* TRKLSI the surface intersection distance. +* IBLIN start position for tracking line. +* +*Parameters: input/output +* IELIN end position for tracking line. +* NUMERO region/surface identification number +* for segment. +* DLENGT spatial location of each line segment. +* VSI region-surfaces identifier. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,IOVER,ITYPG,LINMAX,MXSLIN,NREG,NSUR + INTEGER MESH(4),IDSUR(NSUR),IDREG(NREG), + > NBCOR(2),NBSINT,ISINT(0:5,MXSLIN) + DOUBLE PRECISION TRKLSI(MXSLIN) + INTEGER IBLIN,IELIN,NUMERO(LINMAX) + DOUBLE PRECISION DLENGT(LINMAX) + INTEGER VSI(5,-NSUR:NREG) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTLRH') + DOUBLE PRECISION DCUTOF,DZERO,DONE,DTWO + PARAMETER (DCUTOF=1.0D-8,DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Local variables +*---- + INTEGER IKLIN,IKWLIN,INELIN,IDIR,NXYZ, + > NSBADD,NSEADD,NRGADD + INTEGER JSUR,ISUR,KSUR,JREG,IREG,KREG + DOUBLE PRECISION BEGERR + DOUBLE PRECISION DELLOC +*---- +* Print header if required +*---- + NXYZ=MESH(1) + INELIN=0 + ISUR=0 + NSBADD=NBCOR(1) + NSEADD=NBCOR(2) + NRGADD=NBSINT+1-NBCOR(2) +* write(6,*) 'NBSINT,NSBADD,NSEADD,NRGADD', +* >NBSINT,NSBADD,NSEADD,NRGADD + IF(IOVER .NE. 0) CALL XABORT(NAMSBR// + > ': Invalid option for overlapping geometry') + IF(IPRINT .GT. 1000) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6022) ITYPG + WRITE(IOUT,6020) 'Initial face' + DO JSUR=1,NBCOR(1) + WRITE(IOUT,6021) TRKLSI(JSUR), + > (ISINT(IDIR,JSUR),IDIR=1,5) + ENDDO + WRITE(IOUT,6020) 'Regions ' + DO JREG=NBCOR(1)+1,NRGADD + WRITE(IOUT,6021) TRKLSI(JREG), + > (ISINT(IDIR,JREG),IDIR=1,5) + ENDDO + WRITE(IOUT,6020) 'Final face' + DO JSUR=NRGADD+1,NBSINT+1 + WRITE(IOUT,6021) TRKLSI(JSUR), + > (ISINT(IDIR,JSUR),IDIR=1,5) + ENDDO + IF(IELIN .GT. 0) THEN + WRITE(IOUT,6010) + WRITE(IOUT,6011) (NUMERO(IKWLIN),IKWLIN=IBLIN-1,IELIN) + WRITE(IOUT,'(A16)') 'LinePosBefore={ ' + WRITE(IOUT,6012) (DLENGT(IKWLIN),IKWLIN=IBLIN-1,IELIN) + WRITE(IOUT,'(11X,A2)')'};' + ENDIF + ENDIF +*---- +* Initial faces +*---- + IKLIN=IBLIN-1 + NSBADD=NBCOR(1) + BEGERR=ABS(TRKLSI(1)-DLENGT(IKLIN)) + IF(BEGERR .GT. DCUTOF) THEN + WRITE(IOUT,9000) NAMSBR,IKLIN,TRKLSI(1),DLENGT(IKLIN) + CALL XABORT(NAMSBR// + > ': Initial tracking position is not nalid') + ENDIF +*---- +* Initial position +*---- +* JSUR=0 + DO JSUR=1,NSBADD +* JSUR=JSUR+1 + IF(IPRINT .GT. 200) + > WRITE(IOUT,*) 'Initial face id',JSUR,ISINT(1,JSUR), + > ISINT(2,JSUR),ISINT(3,JSUR),ISINT(4,JSUR),ISINT(5,JSUR) + ISUR=0 + DO KSUR=1,NSUR + IF(ISINT(1,JSUR) .EQ. VSI(1,-KSUR) .AND. + > ISINT(2,JSUR) .EQ. VSI(2,-KSUR) .AND. + > ISINT(3,JSUR) .EQ. VSI(3,-KSUR) .AND. + > ISINT(4,JSUR) .EQ. VSI(4,-KSUR) .AND. + > ISINT(5,JSUR) .EQ. VSI(5,-KSUR) ) THEN + ISUR=KSUR + GO TO 100 + ENDIF + ENDDO + WRITE(IOUT,*) 'Surface ',JSUR,' not found' + WRITE(IOUT,'(4I10)') ISINT(1,JSUR),ISINT(2,JSUR), + > ISINT(3,JSUR),ISINT(4,JSUR),ISINT(5,JSUR) + CALL XABORT(NAMSBR//': unable to identify surface') + 100 CONTINUE +* WRITE(IOUT,*) 'Surface associated with ',JSUR,' is ',ISUR + IF(IPRINT .GT. 200) THEN + IF(ISINT(1,JSUR) .EQ. -1) THEN +*---- +* U- faces +*---- + WRITE(IOUT,*) 'U- faces' + ELSE IF(ISINT(1,JSUR) .EQ. -2) THEN +*---- +* U+ faces +*---- + WRITE(IOUT,*) 'U+ faces' + ELSE IF(ISINT(2,JSUR) .EQ. -1) THEN +*---- +* V- faces +*---- + WRITE(IOUT,*) 'V- faces' + ELSE IF(ISINT(2,JSUR) .EQ. -2) THEN +*---- +* V+ faces +*---- + WRITE(IOUT,*) 'V+ faces' + ELSE IF(ISINT(3,JSUR) .EQ. -1) THEN +*---- +* Z- faces +*---- + WRITE(IOUT,*) 'Z- faces' + ELSE IF(ISINT(3,JSUR) .EQ. -2) THEN +*---- +* Z+ faces +*---- + WRITE(IOUT,*) 'Z+ faces' + ELSE IF(ISINT(5,JSUR) .EQ. -1) THEN +*---- +* W- faces +*---- + WRITE(IOUT,*) 'W- faces' + ELSE IF(ISINT(5,JSUR) .EQ. -2) THEN +*---- +* W+ faces +*---- + WRITE(IOUT,*) 'W+ faces' + ENDIF + ENDIF + IF(IDSUR(ISUR) .NE. 0) THEN + IKLIN=IKLIN+1 + NUMERO(IKLIN)=-ABS(IDSUR(ISUR)) + DLENGT(IKLIN)=DONE/DBLE(NSBADD) + ENDIF + ENDDO +*---- +* Regions +*---- +* JREG=NBCOR(1) + DELLOC=DZERO + DO JREG=NBCOR(1)+1,NRGADD +* JREG=JREG+1 + IREG=0 + DO KREG=1,NREG + IF(ISINT(1,JREG) .EQ. VSI(1,KREG) .AND. + > ISINT(2,JREG) .EQ. VSI(2,KREG) .AND. + > ISINT(3,JREG) .EQ. VSI(3,KREG) .AND. + > ISINT(4,JREG) .EQ. VSI(4,KREG) .AND. + > ISINT(5,JREG) .EQ. VSI(5,KREG) ) THEN + IREG=KREG + GO TO 110 + ENDIF + ENDDO + WRITE(IOUT,*) 'Region ',JREG,' not found' + WRITE(IOUT,'(4I10)') ISINT(1,JREG),ISINT(2,JREG), + > ISINT(3,JREG),ISINT(4,JREG),ISINT(5,JREG) + CALL XABORT(NAMSBR//': unable to identify region') + 110 CONTINUE +* WRITE(IOUT,*) 'Region associated with ',JREG,' is ',IREG + IF(IDREG(IREG) .NE. 0) THEN + IKLIN=IKLIN+1 + NUMERO(IKLIN)=ABS(IDREG(IREG)) + DLENGT(IKLIN)=TRKLSI(JREG)+DELLOC + DELLOC=DZERO + ELSE +*---- +* Add distance to DELLOC. This will be added to the next +* track with non zero region. +*---- + DELLOC=DELLOC+TRKLSI(JREG) + ENDIF + ENDDO +*---- +* Final face +*---- + NSEADD=NBCOR(2) + INELIN=IKLIN+NSEADD+1 + DLENGT(INELIN)=TRKLSI(NBSINT+1) + NUMERO(INELIN)=0 +*---- +* Final position +*---- +* JSUR=NBSINT+1-NBCOR(2) + DO JSUR=NRGADD+1,NBSINT+1 +* JSUR=JSUR+1 + IF(IPRINT .GT. 200) + > WRITE(IOUT,*) 'Final face id',JSUR,ISINT(1,JSUR), + > ISINT(2,JSUR),ISINT(3,JSUR),ISINT(4,JSUR),ISINT(5,JSUR) + ISUR=0 + DO KSUR=1,NSUR + IF(ISINT(1,JSUR) .EQ. VSI(1,-KSUR) .AND. + > ISINT(2,JSUR) .EQ. VSI(2,-KSUR) .AND. + > ISINT(3,JSUR) .EQ. VSI(3,-KSUR) .AND. + > ISINT(4,JSUR) .EQ. VSI(4,-KSUR) .AND. + > ISINT(5,JSUR) .EQ. VSI(5,-KSUR) ) THEN + ISUR=KSUR + GO TO 120 + ENDIF + ENDDO + WRITE(IOUT,*) 'Surface ',JSUR,' not found' + WRITE(IOUT,'(4I10)') ISINT(1,JSUR),ISINT(2,JSUR), + > ISINT(3,JSUR),ISINT(4,JSUR),ISINT(5,JSUR) + CALL XABORT(NAMSBR//': unable to identify surface') + 120 CONTINUE +* WRITE(IOUT,*) 'Surface associated with ',JSUR,' is ',ISUR + IF(IPRINT .GT. 200) THEN + IF(ISINT(1,JSUR) .EQ. -1) THEN +*---- +* U- faces +*---- + WRITE(IOUT,*) 'U- faces' + ELSE IF(ISINT(1,JSUR) .EQ. -2) THEN +*---- +* U+ faces +*---- + WRITE(IOUT,*) 'U+ faces' + ELSE IF(ISINT(2,JSUR) .EQ. -1) THEN +*---- +* V- faces +*---- + WRITE(IOUT,*) 'V- faces' + ELSE IF(ISINT(2,JSUR) .EQ. -2) THEN +*---- +* V+ faces +*---- + WRITE(IOUT,*) 'V+ faces' + ELSE IF(ISINT(3,JSUR) .EQ. -1) THEN +*---- +* Z- faces +*---- + WRITE(IOUT,*) 'Z- faces' + ELSE IF(ISINT(3,JSUR) .EQ. -2) THEN +*---- +* Z+ faces +*---- + WRITE(IOUT,*) 'Z+ faces' + ELSE IF(ISINT(5,JSUR) .EQ. -1) THEN +*---- +* W- faces +*---- + WRITE(IOUT,*) 'W- faces' + ELSE IF(ISINT(5,JSUR) .EQ. -2) THEN +*---- +* W+ faces +*---- + WRITE(IOUT,*) 'W+ faces' + ENDIF + ENDIF + IF(IDSUR(ISUR) .NE. 0) THEN + IKLIN=IKLIN+1 + NUMERO(IKLIN)=-ABS(IDSUR(ISUR)) + DLENGT(IKLIN)=DONE/DBLE(NSEADD) + ENDIF + ENDDO + IKLIN=IKLIN+1 + DLENGT(IKLIN)=TRKLSI(NBSINT+1) + NUMERO(IKLIN)=0 + IELIN=IKLIN + IF(IPRINT .GT. 1000) THEN + WRITE(IOUT,6010) + WRITE(IOUT,6011) (NUMERO(IKWLIN),IKWLIN=IBLIN-1,IELIN) + WRITE(IOUT,'(A10)') 'LinePos={ ' + WRITE(IOUT,6012) (DLENGT(IKWLIN),IKWLIN=IBLIN-1,IELIN) + WRITE(IOUT,'(11X,A2)')'};' + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(' Integration line :') + 6011 FORMAT(6(I25,:,',')) + 6012 FORMAT(6(F25.16,:,',')) + 6020 FORMAT(A20) + 6021 FORMAT(1X,F25.16,6I10) + 6022 FORMAT('Geometry type ',I5) + 9000 FORMAT(' **** Error in ',A6,' ****'/ + > ' Initial face location is invalid :', + > I10,1P,2(2X,D20.10)) + END diff --git a/Dragon/src/NXTLRS.f b/Dragon/src/NXTLRS.f new file mode 100644 index 0000000..971ad72 --- /dev/null +++ b/Dragon/src/NXTLRS.f @@ -0,0 +1,692 @@ +*DECK NXTLRS + SUBROUTINE NXTLRS(IPRINT,IOVER ,ITYPG ,LINMAX,MXSLIN, + > NREG ,NSUR ,MESH ,IDSUR ,IDREG , + > NBCOR ,NBSINT,ISINT ,TRKLSI, + > IBLIN ,IELIN ,NUMERO,DLENGT) +* +*---------- +* +*Purpose: +* To store line segments in tracking +* vector with global region and surface identification. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau. +* +*Parameters: input +* IPRINT print level. +* IOVER flag to everlap tracks on current lines. In the case where +* IOVER=0, the tracks are only stored after the current +* tracks. When IOVER=1, the new tracks segments are +* overlapped over the existing tracks. +* ITYPG type of geometry. +* LINMAX maximum number of segments in a complete track. +* MXSLIN maximum number of segments in a subgeometry track. +* NREG maximum number of regions in geometry. +* NSUR maximum number of surfaces in geometry. +* MESH effective number of spatial subdivision in $X$ +* $Y$, $Z$ and $R$. +* IDSUR local surface identifier. +* IDREG local region identifier. +* NBCOR number of corner found for each external faces. +* NBSINT number of surface crossed by track. +* ISINT direction of plane intersected and +* the surfaces crossed by the track: +* ISINT(0,I) not used here +* IX=ISINT(1,I) +* IY=ISINT(2,I) +* IZ=ISINT(3,I) +* IR=ISINT(4,I) +* IW=ISINT(5,I) not used. +* For global Cartesian geometry +* a) Internal regions +* (IX,IY,IZ,IR) is location of region. +* b) External surfaces. +* One and only one of IX, IY or IZ is negative +* with: +* IX=-1 for X- face with position (IY,IZ,IR); +* IX=-2 for X+ face with position (IY,IZ.IR); +* IY=-1 for Y- face with position (IX,IZ,IR); +* IY=-2 for Y+ face with position (IX,IZ,IR); +* IZ=-1 for Z- face with position (IX,IY,IR); +* IZ=-2 for Z+ face with position (IX,IY,IR). +* For global annular geometry +* a) Internal regions +* (IX,IY,IZ,IR) is location of region. +* b) External surfaces. +* One and only one of IX, IY, IZ or IR is negative +* with: +* IX=-1 for X- face with position (IY,IZ,IR); +* IX=-2 for X+ face with position (IY,IZ,IR); +* IY=-1 for Y- face with position (IX,IZ,IR); +* IY=-2 for Y+ face with position (IX,IZ,IR); +* IZ=-1 for Z- face with position (IX,IY,IR); +* IZ=-2 for Z+ face with position (IX,IY,IR); +* IR=-2 for R+ face with position (IX,IY,IZ). +* For hexagonal geometry +* a) Internal regions +* (IH,IZ,IR) is location of region +* IH=IX=IY=1 permitted only. +* b) External surfaces. +* Pair IH=IX=IY < 0 or IZ< 10 +* with +* IH=-1 for hexagonal face 1 in plane IZ; +* IH=-2 for hexagonal face 2 in plane IZ; +* IH=-3 for hexagonal face 3 in plane IZ; +* IH=-4 for hexagonal face 4 in plane IZ; +* IH=-5 for hexagonal face 5 in plane IZ; +* IH=-6 for hexagonal face 6 in plane IZ. +* TRKLSI the surface intersection distance. +* IBLIN start position for tracking line. +* +*Parameters: input/output +* IELIN end position for tracking line. +* NUMERO region/surface identification number +* for segment. +* DLENGT spatial location of each line segment. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,IOVER,ITYPG,LINMAX,MXSLIN,NREG,NSUR + INTEGER MESH(4),IDSUR(NSUR),IDREG(NREG), + > NBCOR(2),NBSINT,ISINT(0:5,MXSLIN) + DOUBLE PRECISION TRKLSI(MXSLIN) + INTEGER IBLIN,IELIN,NUMERO(LINMAX) + DOUBLE PRECISION DLENGT(LINMAX) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTLRS') + DOUBLE PRECISION DCUTOF,DZERO,DONE,DTWO + PARAMETER (DCUTOF=1.0D-8,DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Local variables +*---- + INTEGER NXO,NYO,NZO,NRO,IKLIN,IKWLIN,INELIN, + > IOFXM,IOFXP,IOFYM,IOFYP,IOFZM,IOFZP,IOFRP,ISEG, + > IXR,IYR,IZR,IRR,IDIR, + > NROX,NROY,NROZ,NDIM + INTEGER NSBADD,NSEADD,NRGADD,NDISP,IKB,IKE,IPB,IPE + INTEGER JSUR,ISUR,KSUR,JREG,IREG,KREG + DOUBLE PRECISION BEGO1,BEGO2,ENDO1,ENDO2,BEGNEW,ENDNEW,BEGERR + DOUBLE PRECISION DELLOC + INTEGER ILINI + INTEGER IHEX,IOFHP +*---- +* Print header if required +*---- + INELIN=0 + IOFXP=0 + IOFYM=0 + IOFYP=0 + ISUR=0 + NSBADD=NBCOR(1) + NRGADD=NBSINT+1-NBCOR(1)-NBCOR(2) + NSEADD=NBCOR(2) + IF(IPRINT .GT. 1000) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6020) 'Initial face' + DO JSUR=1,NBCOR(1) + WRITE(IOUT,6021) TRKLSI(JSUR), + > (ISINT(IDIR,JSUR),IDIR=1,5) + ENDDO + WRITE(IOUT,6020) 'Regions ' + DO JSUR=NBCOR(1)+1,NBSINT-NBCOR(2)+1 + WRITE(IOUT,6021) TRKLSI(JSUR), + > (ISINT(IDIR,JSUR),IDIR=1,5) + ENDDO + WRITE(IOUT,6020) 'Final face' + DO JSUR=NBSINT-NBCOR(2)+2,NBSINT+1 + WRITE(IOUT,6021) TRKLSI(JSUR), + > (ISINT(IDIR,JSUR),IDIR=1,5) + ENDDO + WRITE(IOUT,6010) + WRITE(IOUT,6011) (NUMERO(IKWLIN),IKWLIN=IBLIN-1,IELIN) + WRITE(IOUT,'(A16)') 'LinePosBefore={ ' + WRITE(IOUT,6012) (DLENGT(IKWLIN),IKWLIN=IBLIN-1,IELIN) + WRITE(IOUT,'(11X,A2)')'};' + ENDIF + IKB=0 + IPB=-1 + IKE=0 + IPE=0 + IF(IOVER .EQ. 1) THEN +*---- +* Find initial and final track locations where line +* starts to overlapp +*---- + INELIN=IELIN + BEGNEW=TRKLSI(1) + BEGO1=DLENGT(IBLIN-1) + DELLOC=ABS(BEGNEW-BEGO1) + IF(IPRINT .GT. 2000) + > WRITE(IOUT,*) ' Begin ->',BEGNEW,BEGO1,DELLOC + IKB=0 +* IF(BEGNEW .GT. BEGO1) THEN + IF(DELLOC .GT. DCUTOF) THEN + DO ISEG=IBLIN,IELIN-1 + IKB=IKB+1 +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) ' + Segment ',ISEG,' ->',IKB, +* > NUMERO(ISEG),DLENGT(ISEG) + IF(NUMERO(ISEG) .GT. 0) THEN + BEGO2=BEGO1+DLENGT(ISEG) + DELLOC=ABS(BEGNEW-BEGO2) +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) BEGO1,BEGO2,DELLOC + IF(DELLOC .LT. DCUTOF) THEN + BEGO1=BEGNEW-BEGO1 + BEGO2=DZERO + IPB=ISEG + GO TO 105 + ELSE IF(BEGNEW .LE. BEGO2) THEN + BEGO1=BEGNEW-BEGO1 + BEGO2=BEGO2-BEGNEW + IPB=ISEG + GO TO 105 + ENDIF + BEGO1=BEGO2 + ENDIF + ENDDO +*---- +* Abort: Overlapping for first points is impossible +*---- + BEGO1=DLENGT(IBLIN-1) + WRITE(IOUT,*) ' Begin ->',BEGNEW,BEGO1 + IKB=0 + DO ISEG=IBLIN,IELIN-1 + IKB=IKB+1 + WRITE(IOUT,*) ' + Segment ',ISEG,' ->',IKB, + > NUMERO(ISEG),DLENGT(ISEG) + IF(NUMERO(ISEG) .GT. 0) THEN + BEGO2=BEGO1+DLENGT(ISEG) + WRITE(IOUT,*) BEGO1,BEGO2 + BEGO1=BEGO2 + ENDIF + ENDDO + CALL XABORT(NAMSBR//': Overlapping for first point '// + > ' is impossible') + 105 CONTINUE + NSBADD=0 + ELSE + DO ISEG=IBLIN,IELIN + IF(NUMERO(ISEG) .GT. 0) GO TO 115 + NSBADD=NSBADD-1 + ENDDO + 115 CONTINUE + NSBADD=MAX(NSBADD,0) + ENDIF + ENDNEW=TRKLSI(NBSINT+1) + ENDO2=DLENGT(IELIN) + DELLOC=ABS(ENDNEW-ENDO2) + IF(IPRINT .GT. 2000) + > WRITE(IOUT,*) ' Ends ->',ENDNEW,ENDO2,DELLOC + IKE=0 +* IF(ENDNEW .LT. ENDO2) THEN + IF(DELLOC .GT. DCUTOF) THEN + DO ISEG=IELIN,IBLIN,-1 + IKE=IKE+1 +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) ' - Segment ',ISEG,' ->',IKE + IF(NUMERO(ISEG) .GT. 0) THEN + ENDO1=ENDO2-DLENGT(ISEG) + DELLOC=ABS(ENDNEW-ENDO1) +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) DLENGT(ISEG),ENDO1,ENDO2,DELLOC + IF(DELLOC .LT. DCUTOF) THEN + ENDO1=DZERO + ENDO2=ENDO2-ENDNEW + IPB=ISEG + GO TO 125 + ELSE IF(ENDNEW .GE. ENDO1) THEN + ENDO1=ENDNEW-ENDO1 + ENDO2=ENDO2-ENDNEW + IPB=ISEG + GO TO 125 + ENDIF + ENDO2=ENDO1 + ENDIF + ENDDO +*---- +* Abort: Overlapping for last points is impossible +*---- + ENDO2=DLENGT(IELIN) + WRITE(IOUT,*) ' Ends ->',ENDNEW,ENDO2 + IKE=0 + DO ISEG=IELIN,IBLIN,-1 + IKE=IKE+1 + WRITE(IOUT,*) ' - Segment ',ISEG,' ->',IKE + IF(NUMERO(ISEG) .GT. 0) THEN + ENDO1=ENDO2-DLENGT(ISEG) + WRITE(IOUT,*) DLENGT(ISEG),ENDO1,ENDO2 + ENDO2=ENDO1 + ENDIF + ENDDO + CALL XABORT(NAMSBR//': Overlapping for last point '// + > ' is impossible') + 125 CONTINUE + ENDIF +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) 'IKB,IKE =',IKB,IKE + IF(IKE .EQ. 0) THEN +*---- +* Last surface is overlapped +* Next segment position avalable is IBLIN+IKB +*---- + IF(IKB .GT. 0) THEN +*---- +* Cut line segment at IBLIN+IKB-1 if region intersection +*---- + ISEG=IBLIN+IKB-1 + DLENGT(ISEG)=BEGO1 + ENDIF + ELSE +*---- +* Displace segments starting at IELIN-IKE+1 +* towards end, the displacement is of NRGADD+NSBADD +*---- + NDISP=NRGADD+NSBADD+1 + IF(IPB .EQ. IPE) NDISP=NDISP+1 + DO ISEG=IELIN,IELIN-IKE+1,-1 +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) 'Displace =',ISEG,ISEG+NDISP + DLENGT(ISEG+NDISP)=DLENGT(ISEG) + NUMERO(ISEG+NDISP)=NUMERO(ISEG) + DLENGT(ISEG)=DZERO + ENDDO + ILINI=IELIN+1 + IF(IKB .GT. 0) THEN + ILINI=IBLIN+IKB + ELSE + ILINI=IBLIN+1 + ENDIF + DO ISEG=IELIN-IKE+NDISP,ILINI,-1 +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) 'Re-initialize =',ISEG + DLENGT(ISEG)=DZERO + ENDDO + INELIN=INELIN+NDISP +*---- +* Cut line segment at IELIN-IKE+1 for region intersection +*---- + ISEG=IELIN-IKE+1+NDISP + DLENGT(ISEG)=ENDO2 +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) 'End cut at =',ISEG,ENDO2 + IF(IKB .GT. 0) THEN +*---- +* Cut line segment at IBLIN+IKB-1 if region intersection +*---- + ISEG=IBLIN+IKB-1 + DLENGT(ISEG)=BEGO1 +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) 'start cut at =',ISEG,BEGO1 + ENDIF + ENDIF + ENDIF + NDIM=3 + IF(ITYPG .EQ. 3 .OR. ITYPG .EQ. 5 .OR. + > ITYPG .EQ. 8 .OR. ITYPG .EQ. 20 .OR. + > ITYPG .EQ. 24) NDIM=2 + NXO=MESH(1) + NYO=MESH(2) + NZO=MESH(3) + IF(NDIM .EQ. 2) NZO=1 + NRO=MESH(4) + NROX=1 + NROY=1 + NROZ=1 + IHEX=0 + IF(ITYPG .GE. 20) NRO=NRO+1 + IF(ITYPG .EQ. 6) THEN + NROX=0 + NROY=0 + NROZ=NRO + ELSE IF(ITYPG .EQ. 8) THEN + NROY=0 + NROZ=NRO + IHEX=1 + ELSE IF(ITYPG .EQ. 9) THEN + NROY=0 + IHEX=1 + ELSE IF(ITYPG .EQ. 10) THEN + NROX=NRO + NROY=0 + NROZ=0 + ELSE IF(ITYPG .EQ. 11) THEN + NROX=0 + NROY=NRO + NROZ=0 + ELSE IF(ITYPG .EQ. 21) THEN + NROX=NRO + ELSE IF(ITYPG .EQ. 22) THEN + NROY=NRO + ELSE IF(ITYPG .EQ. 23) THEN + NROZ=NRO + ELSE IF(ITYPG .EQ. 24) THEN + NROY=0 + NROZ=NRO + IHEX=1 + ELSE IF(ITYPG .EQ. 25) THEN + NROY=0 + IHEX=1 + NROZ=NRO + ENDIF + IF(IHEX .EQ. 0) THEN + IOFXM=0 + IOFXP=IOFXM+NYO*NZO*NROX + IOFYM=IOFXP+NYO*NZO*NROX + IOFYP=IOFYM+NXO*NZO*NROY + IOFZM=IOFYP+NXO*NZO*NROY + IOFZP=IOFZM+NXO*NYO*NROZ + IOFRP=IOFZP+NXO*NYO*NROZ + ELSE + IOFHP=0 + IOFZM=IOFHP+6*NZO + IOFZP=IOFZM+NROZ + IOFRP=IOFZP+NROZ + ENDIF +* IF(IPRINT .GT. 2000) +* >WRITE(IOUT,*) 'IOF=',NXO,NYO,NZO,NRO,NROX,NROY,NROZ, +* >IOFXM,IOFXP,IOFYM,IOFYP,IOFZM,IOFZP,IOFRP +*---- +* Initial faces +*---- + IF(IKB .EQ. 0) THEN + IKLIN=IBLIN+IKB-1 + NSBADD=NBCOR(1) + BEGERR=ABS(TRKLSI(1)-DLENGT(IKLIN)) + IF(BEGERR .GT. DCUTOF) THEN + WRITE(IOUT,9000) NAMSBR,IKLIN,TRKLSI(1),DLENGT(IKLIN) + CALL XABORT(NAMSBR// + > ': Initial tracking position is not valid') + ENDIF + ELSE + IKLIN=IBLIN+IKB-1 + NSBADD=0 + ENDIF +*---- +* Initial position +*---- + JSUR=0 +* IF(IPRINT .GT. 2000) +* >WRITE(IOUT,*) IOFXM,IOFXP,IOFYM,IOFYP,IOFZM,IOFZP +* IF(IPRINT .GT. 2000) +* >WRITE(IOUT,*) NRO,NXO,NYO,NZO + DO KSUR=1,NSBADD + JSUR=JSUR+1 +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) 'Initial face id',JSUR,ISINT(1,JSUR), +* > ISINT(2,JSUR),ISINT(3,JSUR),ISINT(4,JSUR) + IXR=MAX(1,ISINT(1,JSUR)) + IYR=MAX(1,ISINT(2,JSUR)) + IZR=MAX(1,ISINT(3,JSUR)) + IF(ISINT(1,JSUR) .LT. 0 .AND. ISINT(2,JSUR) .LT. 0) THEN +*---- +* H+ faces +*---- +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) 'H- faces' + IF(ISINT(1,JSUR) .NE. ISINT(2,JSUR)) CALL XABORT(NAMSBR// + >': X and Y face id must be identical for hexagons') + ISUR=6*(IZR-1)-ISINT(1,JSUR)+IOFHP + ELSE IF(ISINT(1,JSUR) .EQ. -1) THEN +*---- +* X- faces +*---- +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) 'X- faces' + IRR=NROX + IF(ISINT(4,JSUR) .GT. 0) IRR=ISINT(4,JSUR) + ISUR=IRR+((IZR-1)*NYO+IYR-1)*NROX+IOFXM + ELSE IF(ISINT(1,JSUR) .EQ. -2) THEN +*---- +* X+ faces +*---- +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) 'X+ faces' + IRR=NROX + IF(ISINT(4,JSUR) .GT. 0) IRR=ISINT(4,JSUR) + ISUR=IRR+((IZR-1)*NYO+IYR-1)*NROX+IOFXP + ELSE IF(ISINT(2,JSUR) .EQ. -1) THEN +*---- +* Y- faces +*---- +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) 'Y- faces',IZR,IXR,((IXR-1)*NZO+IZR-1) + IRR=NROY + IF(ISINT(4,JSUR) .GT. 0) IRR=ISINT(4,JSUR) + ISUR=IRR+((IXR-1)*NZO+IZR-1)*NROY+IOFYM + ELSE IF(ISINT(2,JSUR) .EQ. -2) THEN +*---- +* Y+ faces +*---- +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) 'Y+ faces',IZR,IXR,((IXR-1)*NZO+IZR-1) + IRR=NROY + IF(ISINT(4,JSUR) .GT. 0) IRR=ISINT(4,JSUR) + ISUR=IRR+((IXR-1)*NZO+IZR-1)*NROY+IOFYP + ELSE IF(ISINT(3,JSUR) .EQ. -1) THEN +*---- +* Z- faces +*---- +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) 'Z- faces' + IRR=NROZ + IF(ISINT(4,JSUR) .GT. 0) IRR=ISINT(4,JSUR) + ISUR=IRR+((IYR-1)*NXO+IXR-1)*NROZ+IOFZM + ELSE IF(ISINT(3,JSUR) .EQ. -2) THEN +*---- +* Z+ faces +*---- +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) 'Z+ faces' + IRR=NROZ + IF(ISINT(4,JSUR) .GT. 0) IRR=ISINT(4,JSUR) + ISUR=IRR+((IYR-1)*NXO+IXR-1)*NROZ+IOFZP + ELSE IF(ISINT(4,JSUR) .EQ. -2) THEN +*---- +* R+ faces +*---- +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) 'R+ faces' + IRR=NRO + IF(ISINT(4,JSUR) .GT. 0) IRR=ISINT(4,JSUR) + ISUR=((IZR-1)*NYO+IYR-1)*NXO+IXR+IOFRP + ENDIF +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) 'Surface ',ISUR,' =', +* > IXR,IYR,IZR,IRR,IDSUR(ISUR),IKLIN+1 + IF(IDSUR(ISUR) .NE. 0) THEN + IKLIN=IKLIN+1 + NUMERO(IKLIN)=-ABS(IDSUR(ISUR)) + DLENGT(IKLIN)=DONE/DBLE(NSBADD) + ENDIF + ENDDO +*---- +* Regions +*---- + JREG=NBCOR(1) + DELLOC=DZERO + DO KREG=1,NRGADD + JREG=JREG+1 + IXR=MAX(1,ISINT(1,JREG)) + IYR=MAX(1,ISINT(2,JREG)) + IZR=MAX(1,ISINT(3,JREG)) + IRR=NRO + IF(ISINT(4,JREG) .GT. 0) IRR=ISINT(4,JREG) + IF(NRO .GT. 0) THEN + IREG=IRR+((IXR-1)+((IYR-1)+(IZR-1)*NYO)*NXO)*NRO + ELSE + IREG=IXR+((IYR-1)+(IZR-1)*NYO)*NXO + ENDIF + IF(IPRINT .GT. 2000) + > WRITE(IOUT,*) 'Region ',IREG,' =', + > IXR,IYR,IZR,IRR,IREG,JREG,IDREG(IREG),TRKLSI(JREG),IKLIN+1 + IF(IDREG(IREG) .NE. 0) THEN + IKLIN=IKLIN+1 + NUMERO(IKLIN)=ABS(IDREG(IREG)) + DLENGT(IKLIN)=TRKLSI(JREG)+DELLOC + DELLOC=DZERO + ELSE +*---- +* Add distance to DELLOC. This will be added to the next +* track with non zero region. +*---- + DELLOC=DELLOC+TRKLSI(JREG) + ENDIF + ENDDO +*---- +* Final faces +*---- + IF(IKE .EQ. 0) THEN + NSEADD=NBCOR(2) + INELIN=IKLIN+NSEADD+1 + DLENGT(INELIN)=TRKLSI(NBSINT+1) + NUMERO(INELIN)=0 + ELSE + NSEADD=0 + ENDIF + JSUR=NBSINT+1-NBCOR(2) + DO KSUR=1,NSEADD + JSUR=JSUR+1 +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) 'Final face id',JSUR,ISINT(1,JSUR), +* > ISINT(2,JSUR),ISINT(3,JSUR),ISINT(4,JSUR) + IXR=MAX(1,ISINT(1,JSUR)) + IYR=MAX(1,ISINT(2,JSUR)) + IZR=MAX(1,ISINT(3,JSUR)) + IF(ISINT(1,JSUR) .LT. 0 .AND. ISINT(2,JSUR) .LT. 0) THEN +*---- +* H+ faces +*---- +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) 'H- faces' + IF(ISINT(1,JSUR) .NE. ISINT(2,JSUR)) CALL XABORT(NAMSBR// + >': X and Y face id must be identical for hexagons') + ISUR=6*(IZR-1)-ISINT(1,JSUR)+IOFHP + ELSE IF(ISINT(1,JSUR) .EQ. -1) THEN +*---- +* X- faces +*---- +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) 'X- faces' + IRR=NROX + IF(ISINT(4,JSUR) .GT. 0) IRR=ISINT(4,JSUR) + ISUR=IRR+((IZR-1)*NYO+IYR-1)*NROX+IOFXM + ELSE IF(ISINT(1,JSUR) .EQ. -2) THEN +*---- +* X+ faces +*---- +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) 'X+ faces' + IRR=NROX + IF(ISINT(4,JSUR) .GT. 0) IRR=ISINT(4,JSUR) + ISUR=IRR+((IZR-1)*NYO+IYR-1)*NROX+IOFXP + ELSE IF(ISINT(2,JSUR) .EQ. -1) THEN +*---- +* Y- faces +*---- +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) 'Y- faces' + IRR=NROY + IF(ISINT(4,JSUR) .GT. 0) IRR=ISINT(4,JSUR) + ISUR=IRR+((IXR-1)*NZO+IZR-1)*NROY+IOFYM + ELSE IF(ISINT(2,JSUR) .EQ. -2) THEN +*---- +* Y+ faces +*---- +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) 'Y+ faces' + IRR=NROY + IF(ISINT(4,JSUR) .GT. 0) IRR=ISINT(4,JSUR) + ISUR=IRR+((IXR-1)*NZO+IZR-1)*NROY+IOFYP + ELSE IF(ISINT(3,JSUR) .EQ. -1) THEN +*---- +* Z- faces +*---- +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) 'Z- faces' + IRR=NROZ + IF(ISINT(4,JSUR) .GT. 0) IRR=ISINT(4,JSUR) + ISUR=IRR+((IYR-1)*NXO+IXR-1)*NROZ+IOFZM + ELSE IF(ISINT(3,JSUR) .EQ. -2) THEN +*---- +* Z+ faces +*---- +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) 'Z+ faces' + IRR=NROZ + IF(ISINT(4,JSUR) .GT. 0) IRR=ISINT(4,JSUR) + ISUR=IRR+((IYR-1)*NXO+IXR-1)*NROZ+IOFZP + ELSE IF(ISINT(4,JSUR) .EQ. -2) THEN +*---- +* R+ faces +*---- +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) 'R+ faces' + IRR=NRO + IF(ISINT(4,JSUR) .GT. 0) IRR=ISINT(4,JSUR) + ISUR=((IZR-1)*NYO+IYR-1)*NXO+IXR+IOFRP + ENDIF +* IF(IPRINT .GT. 2000) +* > WRITE(IOUT,*) 'Surface ',ISUR,' =', +* > IXR,IYR,IZR,IRR,IDSUR(ISUR),IKLIN+1 + IKLIN=IKLIN+1 + IF(IDSUR(ISUR) .NE. 0) THEN + NUMERO(IKLIN)=-ABS(IDSUR(ISUR)) + DLENGT(IKLIN)=DONE/DBLE(NSEADD) + ELSE + NUMERO(IKLIN)=0 + DLENGT(IKLIN)=DZERO + ENDIF + ENDDO + IF(IOVER .EQ. 0) THEN + IKLIN=IKLIN+1 + DLENGT(IKLIN)=TRKLSI(NBSINT+1) + NUMERO(IKLIN)=0 + IELIN=IKLIN + ELSE + IELIN=INELIN + ENDIF + IF(IPRINT .GT. 1000) THEN + WRITE(IOUT,6010) + WRITE(IOUT,6011) (NUMERO(IKWLIN),IKWLIN=IBLIN-1,IELIN) + WRITE(IOUT,'(A10)') 'LinePos={ ' + WRITE(IOUT,6012) (DLENGT(IKWLIN),IKWLIN=IBLIN-1,IELIN) + WRITE(IOUT,'(11X,A2)')'};' + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(' Integration line :') + 6011 FORMAT(6(I25,:,',')) + 6012 FORMAT(6(F25.16,:,',')) + 6020 FORMAT(A20) + 6021 FORMAT(1X,F25.16,6I10) + 9000 FORMAT(' **** Error in ',A6,' ****'/ + > ' Initial face location is invalid :', + > I10,1P,2(2X,D20.10)) + END diff --git a/Dragon/src/NXTLSN.f b/Dragon/src/NXTLSN.f new file mode 100644 index 0000000..cd91aa7 --- /dev/null +++ b/Dragon/src/NXTLSN.f @@ -0,0 +1,200 @@ +*DECK NXTLSN + SUBROUTINE NXTLSN(NDIM ,ORDRE ,NQUAD ,NBANGL,DQUAD ,DANGLT, + > DDENWT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To define level-symmetric (type 2) quadrature angles. +* +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* A. Hebert and R. Le Tellier +* +*Parameters: input +* NDIM number of dimensions for geometry. +* ORDRE quadrature order. +* NQUAD number of quadrant (in 3-D) and quarter (in 2-D). +* NBANGL number of angles. +* DQUAD relative density of each quadrant. +* +*Parameters: output +* DANGLT director cosines of angles. +* DDENWT angular density for each angle. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NDIM,ORDRE,NQUAD,NBANGL + DOUBLE PRECISION DQUAD(NQUAD),DANGLT(NDIM,NQUAD,NBANGL), + > DDENWT(NQUAD,NBANGL) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTLSN') + DOUBLE PRECISION DZERO,DONE,DTWO + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) + INTEGER MAXORD,MAXNBA,MAXEQ,MAXW + PARAMETER (MAXORD=20,MAXNBA=55,MAXEQ=64,MAXW=12) +*---- +* Functions +*---- + DOUBLE PRECISION XDRCST,PI +*---- +* Local variables +*---- + INTEGER I,IP,IQ,IS,IW,IANG,JOP(MAXORD/2),M2,NPQ,NW,IPR, + > IPL,IPK,INMAX,IPQ,NW0,II,KK,LL,NEQ + REAL U(MAXORD/2),TPQ(MAXNBA),UPQ(MAXNBA), + > VPQ(MAXNBA),WPQ(MAXNBA) + DOUBLE PRECISION FAC,ZMU,ZETA,ZMU1,ZMU2,DDA,X,Y,Z,REF + INTEGER INWEI(MAXNBA) + DOUBLE PRECISION WEI(MAXW),ZMAT(MAXEQ,MAXW+1),UD(MAXW) +*---- +* Set the unique quadrature values +*---- + IF(ORDRE.GT.MAXORD) CALL XABORT(NAMSBR//': MAXORD OVERFLOW.') + M2=ORDRE/2 + NPQ=M2*(M2+1)/2 + ZMU1=1.0D0/(3.0D0*DBLE(ORDRE-1)) + NW=1+(ORDRE*(ORDRE+8)-1)/48 + IF(NW.GT.MAXW) CALL XABORT('NXTLSN: MAXW OVERFLOW.') + IF(ORDRE.EQ.2) THEN + ZMU1=0.33333333 + ELSE IF(ORDRE.EQ.4) THEN + ZMU1=0.12251480 + ELSE IF(ORDRE.EQ.6) THEN + ZMU1=0.07109447 + ELSE IF(ORDRE.EQ.8) THEN + ZMU1=0.04761903 + ELSE IF(ORDRE.EQ.10) THEN + ZMU1=0.03584310 + ELSE IF(ORDRE.EQ.12) THEN + ZMU1=0.02796615 + ELSE IF(ORDRE.EQ.14) THEN + ZMU1=0.02310250 + ELSE IF(ORDRE.EQ.16) THEN + ZMU1=0.01931398 + ELSE IF(ORDRE.EQ.18) THEN + ZMU1=0.01692067 + ELSE IF(ORDRE.EQ.20) THEN + ZMU1=0.01455253 + ELSE + CALL XABORT(NAMSBR//': ORDER NOT AVAILABLE.') + ENDIF + U(1)=REAL(SQRT(ZMU1)) + DO I=2,M2 + ZMU2=ZMU1+2.0D0*DBLE(I-1)*(1.0D0-3.0D0*ZMU1)/DBLE(ORDRE-2) + U(I)=REAL(SQRT(ZMU2)) + ENDDO +*---- +* Compute the position of weights +*---- + IPR=0 + INMAX=0 + DO IP=1,M2 + JOP(IP)=M2-IP+1 + DO IQ=1,JOP(IP) + IPR=IPR+1 + IF(IPR.GT.MAXNBA) CALL XABORT('NXTLSN: MAXNBA OVERFLOW.') + TPQ(IPR)=U(IP) + UPQ(IPR)=U(M2+2-IP-IQ) + VPQ(IPR)=U(IQ) + IS=MIN(IP,IQ,M2+2-IP-IQ) + NW0=0 + DO II=1,IS-1 + NW0=NW0+(M2-3*(II-1)+1)/2 + ENDDO + KK=IP-IS+1 + LL=IQ-IS+1 + IF(KK.EQ.1)THEN + INWEI(IPR)=NW0+MIN(LL,M2-3*(IS-1)+1-LL) + ELSEIF(LL.EQ.1)THEN + INWEI(IPR)=NW0+MIN(KK,M2-3*(IS-1)+1-KK) + ELSE + INWEI(IPR)=NW0+MIN(KK,LL) + ENDIF + INMAX=MAX(INMAX,INWEI(IPR)) + ENDDO + ENDDO + IF(INMAX.NE.NW) CALL XABORT(NAMSBR//': INVALID VALUE OD NW.') + IF(IPR.NE.NPQ) CALL XABORT(NAMSBR//': BAD VALUE ON NPQ.') +*---- +* Set the rectangular system and solve it using the QR method +*---- + NEQ=0 + DO IPL=0,ORDRE,2 + DO IPK=IPL,ORDRE-IPL,2 + IF(MOD(IPL+IPK,2).EQ.1) CYCLE + NEQ=NEQ+1 + IF(NEQ.GT.MAXEQ) CALL XABORT(NAMSBR//': MAXEQ OVERFLOW.') + DO IW=1,NW + ZMAT(NEQ,IW)=0.0D0 + ENDDO + DO IPQ=1,NPQ + ZMU=TPQ(IPQ) + ZETA=UPQ(IPQ) + IW=INWEI(IPQ) + ZMAT(NEQ,IW)=ZMAT(NEQ,IW)+(ZMU**IPK)*(ZETA**IPL) + ENDDO + REF=1.0D0/DBLE(IPK+IPL+1) + DO I=1,IPL-1,2 + REF=REF*DBLE(I)/DBLE(IPK+I) + ENDDO + ZMAT(NEQ,NW+1)=REF + ENDDO + ENDDO + CALL ALST2F(MAXEQ,NEQ,NW,ZMAT,UD) + CALL ALST2S(MAXEQ,NEQ,NW,ZMAT,UD,ZMAT(1,NW+1),WEI) +*---- +* Set the level-symmetric quadratures +*---- + PI=XDRCST('Pi',' ') + IPQ=0 + DO IP=1,M2 + DO IQ=1,JOP(IP) + IPQ=IPQ+1 + WPQ(IPQ)=REAL(WEI(INWEI(IPQ))*PI)/2.0 + ENDDO + ENDDO +*---- +* Fill-in DANGLT and DDENWT array +*---- + FAC=4.0*PI + DO IANG=1,NBANGL + X = DBLE(TPQ(IANG)) + Y = DBLE(UPQ(IANG)) + Z = DBLE(VPQ(IANG)) + DDA=DBLE(FAC/WPQ(IANG)) + DANGLT(1,1,IANG)=X + DANGLT(2,1,IANG)=Y + DANGLT(3,1,IANG)=Z + DDENWT(1,IANG)=DQUAD(1)*DDA + DANGLT(1,2,IANG)=-X + DANGLT(2,2,IANG)=Y + DANGLT(3,2,IANG)=Z + DDENWT(2,IANG)=DQUAD(2)*DDA + DANGLT(1,3,IANG)=X + DANGLT(2,3,IANG)=-Y + DANGLT(3,3,IANG)=Z + DDENWT(3,IANG)=DQUAD(3)*DDA + DANGLT(1,4,IANG)=-X + DANGLT(2,4,IANG)=-Y + DANGLT(3,4,IANG)=Z + DDENWT(4,IANG)=DQUAD(4)*DDA + ENDDO +* + RETURN + END diff --git a/Dragon/src/NXTMCA.f b/Dragon/src/NXTMCA.f new file mode 100644 index 0000000..33dbaf9 --- /dev/null +++ b/Dragon/src/NXTMCA.f @@ -0,0 +1,90 @@ +*DECK NXTMCA + SUBROUTINE NXTMCA(IPTRK) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Add MC: specific geometry analysis info to NXTRecords. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): Romain Le Tellier +* +*Parameters: input +* IPTRK pointer to the Tracking data structure. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK +*---- +* LOCAL VARIABLES +*---- + INTEGER NSTATE + PARAMETER(NSTATE=40) + INTEGER NFREG,NMIX,NFSUR,NDIM,NBUCEL,NUCELL(3),MAXREG,NBTCLS, + 1 MAXPIN,MAXMSP,MAXRSP,MXGSUR,MXGREG,NUNK + INTEGER GSTATE(NSTATE),ESTATE(NSTATE) + CHARACTER NAMREC*12,CDIR(4)*1 + DATA CDIR /'X','Y','Z','R'/ +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IUNFLD +*---- +* RECOVER SOME BASIC NXT GEOMETRY ANALYSIS INFO AND ALLOCATE RELATED +* MEMORY +*---- + GSTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,'STATE-VECTOR',GSTATE) + NFREG =GSTATE( 1) + NMIX =GSTATE( 4) + NFSUR =GSTATE( 5) + IF (GSTATE(7).NE.4) + 1 CALL XABORT('NXTMCA: ONLY NXT: GEOMETRY ANALYSIS IS PERMITTED') + CALL LCMSIX(IPTRK,'NXTRecords',1) + ESTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,'G00000001DIM',ESTATE) + NDIM =ESTATE( 1) + NBUCEL =ESTATE( 5) + NUCELL(1)=ESTATE(13) + NUCELL(2)=ESTATE(14) + NUCELL(3)=ESTATE(15) + MAXREG =ESTATE(17) + NBTCLS =ESTATE(18) + MAXPIN =ESTATE(19) + MAXMSP =ESTATE(20) + MAXRSP =ESTATE(21) + IF (NFSUR.NE.ESTATE(22)) + 1 CALL XABORT('NXTMCA: INCONSISTENT NUMBER OF OUTER SURFACES') + IF (NFREG.NE.ESTATE(23)) + 1 CALL XABORT('NXTMCA: INCONSISTENT NUMBER OF REGIONS') + MXGSUR =ESTATE(24) + MXGREG =ESTATE(25) + NUNK=NFSUR+NFREG+1 +* cell index and orientation for the cells filling the geometry + ALLOCATE(IUNFLD(2*NBUCEL)) + NAMREC='G00000001CUF' + CALL LCMGET(IPTRK,NAMREC,IUNFLD) +*---- +* ADD MCA: SPECIFIC GEOMETRY ANALYSIS INFO TO NXTRecords +*---- + CALL NXTMCB(IPTRK,NUCELL,MXGSUR,MXGREG,MAXPIN,IUNFLD) +*---- +* RELEASE MEMORY +*---- + DEALLOCATE(IUNFLD) +* + CALL LCMSIX(IPTRK,' ',2) + + RETURN + END diff --git a/Dragon/src/NXTMCB.f b/Dragon/src/NXTMCB.f new file mode 100644 index 0000000..6ea326e --- /dev/null +++ b/Dragon/src/NXTMCB.f @@ -0,0 +1,112 @@ +*DECK NXTMCB + SUBROUTINE NXTMCB(IPTRK,NUCELL,MXGSUR,MXGREG,MAXPIN,IUNFLD) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Add MC: specific geometry analysis info to NXTRecords. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): Romain Le Tellier +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure. +* NUCELL number of cell after unfolding in +* $X$, $Y$ and $Z$ directions. +* MXGSUR maximum number of surfaces for any geometry. +* MXGREG maximum number of region for any geometry. +* MAXPIN maximum number of pins in a cell. +* IUNFLD description of unfolded geometry. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER NUCELL(3),MXGSUR,MXGREG,MAXPIN,IUNFLD(2,NUCELL(1), + > NUCELL(2),NUCELL(3)) +*---- +* LOCAL VARIABLES +*---- + INTEGER NSTATE,IOUT + PARAMETER(NSTATE=40,IOUT=6) + INTEGER ESTATE(NSTATE) + INTEGER K,J,I,ICEL,NREGC,NSURC,NTPIN,NREGF,NSURF,JJ,IPINO,IPIN + CHARACTER NAMCEL*9,NAMREC*12 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IDSUR,IDREG,ITPIN + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: INDEX +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(INDEX(5,-MXGSUR:MXGREG,2),IDSUR(MXGSUR,2), + 1 IDREG(MXGREG,2),ITPIN(3,MAXPIN)) +*---- +* CREATE COMPRESSED INDEX FOR ALL THE CELLS/PINS +*---- + DO 12 K=1,MAX(NUCELL(3),1) + DO 11 J=1,NUCELL(2) + DO 10 I=1,NUCELL(1) + IF (IUNFLD(2,I,J,K).NE.1) GOTO 10 +* CELL LEVEL (1) + ICEL=IUNFLD(1,I,J,K) + WRITE(NAMCEL,'(A1,I8.8)') 'C',ICEL + NAMREC=NAMCEL//'DIM' + ESTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,NAMREC,ESTATE) + NREGC=ESTATE(8) + NSURC=ESTATE(9) + NTPIN=ESTATE(18) + NAMREC=NAMCEL//'VSI' + CALL LCMGET(IPTRK,NAMREC,INDEX) + NAMREC=NAMCEL//'SID' + CALL LCMGET(IPTRK,NAMREC,IDSUR) + NAMREC=NAMCEL//'RID' + CALL LCMGET(IPTRK,NAMREC,IDREG) + CALL NXTMCC(IPTRK,NAMCEL,NREGC,NSURC,NREGF,NSURF,INDEX,IDSUR, + 1 IDREG) + IF(NTPIN.GT.0) THEN +* PIN LEVEL (2) + NAMREC=NAMCEL//'PNT' + CALL LCMGET(IPTRK,NAMREC,ITPIN) + IPINO=0 + DO 20 JJ=1,NTPIN + IPIN=ITPIN(2,JJ) + IF (IPIN.EQ.IPINO) GOTO 20 + WRITE(NAMCEL,'(A1,I8.8)') 'P',IPIN + NAMREC=NAMCEL//'DIM' + ESTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,NAMREC,ESTATE) + NREGC=ESTATE(8) + NSURC=ESTATE(9) + NAMREC=NAMCEL//'VSI' + CALL LCMGET(IPTRK,NAMREC,INDEX) + NAMREC=NAMCEL//'SID' + CALL LCMGET(IPTRK,NAMREC,IDSUR) + NAMREC=NAMCEL//'RID' + CALL LCMGET(IPTRK,NAMREC,IDREG) + CALL NXTMCC(IPTRK,NAMCEL,NREGC,NSURC,NREGF,NSURF,INDEX, + 1 IDSUR,IDREG) + IPINO=IPIN + 20 CONTINUE + ENDIF + 10 CONTINUE + 11 CONTINUE + 12 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(ITPIN,IDREG,IDSUR,INDEX) + RETURN + END diff --git a/Dragon/src/NXTMCC.f b/Dragon/src/NXTMCC.f new file mode 100644 index 0000000..f5aad08 --- /dev/null +++ b/Dragon/src/NXTMCC.f @@ -0,0 +1,123 @@ +*DECK NXTMCC + SUBROUTINE NXTMCC(IPTRK,NAMCEL,NREGC,NSURC,NREGF,NSURF,INDEX, + 1 IDSUR,IDREG) +*----------------------------------------------------------------------- +* +*Purpose: +* Calculate and store the compressed index and region/surface ids for +* an elementary geometry. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): Romain Le Tellier +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure. +* NAMCEL name of the elementary geometry to be treated. +* NREGC number of regions (uncompressed). +* NSURC number of surfaces (uncompressed). +* +*Parameters: output +* NREGF number of regions (compressed). +* NSURF number of surfaces (compressed). +* +*Parameters: input/output +* INDEX index vector (uncompressed and compressed). +* IDSUR surface identificator (uncompressed and compressed). +* IDREG region identificator (uncompressed and compressed). +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK +* INTEGER IPTRK + INTEGER NREGC,NSURC,NREGF,NSURF,INDEX(5,-NSURC:NREGC,2), + 1 IDSUR(NSURC,2),IDREG(NREGC,2) + CHARACTER NAMCEL*9 +*---- +* LOCAL VARIABLES +*---- + INTEGER NSTATE,IOUT + PARAMETER(NSTATE=40,IOUT=6) + INTEGER ESTATE(NSTATE) + INTEGER I,ISUR,INDF,JJ,ITMP,IREG + CHARACTER NAMREC*12 +*---- +* SCAN THE SURFACES AND FILL IN THE SURFACE ID AND CORREPONDING INDEX +*---- + NSURF=0 + INDF=-NSURC-1 + DO I=NSURC,1,-1 + ISUR=IDSUR(I,1) + IF (IDSUR(I,1).NE.0) THEN + NSURF=NSURF+1 + IDSUR(NSURF,2)=ABS(ISUR) + INDF=INDF+1 + DO JJ=1,4 + INDEX(JJ,INDF,2)=INDEX(JJ,-I,1) + ENDDO + ENDIF + ENDDO +*---- +* REVERSE SURFACE ID IN SUCH A WAY THAT +* IDSUR(I,2) CORRESPONDS TO INDEX(:,-NSURC+NSURF-I,2) +*---- + DO I=1,NSURF/2 + ITMP=IDSUR(NSURF+1-I,2) + IDSUR(NSURF+1-I,2)=IDSUR(I,2) + IDSUR(I,2)=ITMP + ENDDO + INDF=INDF+1 + DO JJ=1,4 + INDEX(JJ,INDF,2)=0 + ENDDO +*---- +* SCAN THE REGIONS AND FILL IN THE SURFACE ID AND CORREPONDING INDEX +*---- + NREGF=0 + DO I=1,NREGC + IREG=IDREG(I,1) + IF (IDREG(I,1).NE.0) THEN + NREGF=NREGF+1 + IDREG(NREGF,2)=ABS(IREG) + INDF=INDF+1 + DO JJ=1,4 + INDEX(JJ,INDF,2)=INDEX(JJ,I,1) + ENDDO + ENDIF + ENDDO +*---- +* STORE THE FINAL NUMBER OF REGIONS/SURFACES +* AND THE COMPRESSED IDS AND INDEX +*---- + NAMREC=NAMCEL//'DIM' + ESTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,NAMREC,ESTATE) + ESTATE(39)=NREGF + ESTATE(40)=NSURF + CALL LCMPUT(IPTRK,NAMREC,NSTATE,1,ESTATE) + IF (NREGF.GT.0) THEN + NAMREC=NAMCEL//'RIC' + CALL LCMPUT(IPTRK,NAMREC,NREGF,1,IDREG(1,2)) + ENDIF + IF (NSURF.GT.0) THEN + NAMREC=NAMCEL//'SIC' + CALL LCMPUT(IPTRK,NAMREC,NSURF,1,IDSUR(1,2)) + ENDIF + INDF=NREGF+NSURF+1 + IF (INDF.GT.0) THEN + NAMREC=NAMCEL//'VSC' + CALL LCMPUT(IPTRK,NAMREC,5*INDF,1,INDEX(1,-NSURC,2)) + ENDIF +* + RETURN + END diff --git a/Dragon/src/NXTMCD.f b/Dragon/src/NXTMCD.f new file mode 100644 index 0000000..ead72ed --- /dev/null +++ b/Dragon/src/NXTMCD.f @@ -0,0 +1,667 @@ +*DECK NXTMCD + SUBROUTINE NXTMCD(IPGEO ,IPTRK ,IPRINT,NDIM ,ILCELL,NBOCEL, + > MAXMSH,MAXREG,MAXPIN,NBTCLS,ITSYM ,IDFEX , + > DCMESH,NAGGEO,ITURN ,IDIRR ,NFSUR ,NFREG , + > MXGSUR,MXGREG) +* +*---------- +* +*Purpose: +* Create a multicell description for the geometry and verify +* if intrinsic cell symmetry required by boundary conditions +* are satisfied. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau. +* +*Parameters: input +* IPGEO pointer to the GEOMETRY data structure. +* IPTRK pointer to the TRACKING data structure. +* IPRINT print level. +* NDIM problem dimensions. +* ILCELL cell level. +* NBOCEL number of cells in original geometry. +* MAXMSH maximum number of elements in MESH array. +* MAXREG maximum number of elements in MIX array. +* MAXPIN maximum number of pins in clusters. +* NBTCLS total number of cluster geometry. +* ITSYM array to identify the symmetry to test for each original +* cell where: +* ITSYM(1,*) identify $X$ symmetry; +* ITSYM(2,*) identify $Y$ symmetry; +* ITSYM(3,*) identify $Z$ symmetry; +* ITSYM(4,*) identify $X-Y$ symmetry. +* A value of 0 indicate that the geometry does not need +* to be verified while a value of 1 implies a verification +* of the geometry. +* IDFEX identify faces associated with external boundary for a +* generating cell and number of times this cell is used. Here: +* IDFEX( 1,*) identify bottom $U$ hexagonal face; +* IDFEX( 2,*) identify top $U$ hexagonal face; +* IDFEX( 3,*) identify bottom $V$ hexagonal face; +* IDFEX( 4,*) identify top $V$ hexagonal face; +* IDFEX( 5,*) identify bottom $Z$ face; +* IDFEX( 6,*) identify top $Z$ face; +* IDFEX( 7,*) not used; +* IDFEX( 8,*) not used; +* IDFEX( 9,*) identify bottom $W$ hexagonal face; +* IDFEX(10,*) identify top $W$ hexagonal face. +* DCMESH global mesh for each cell. +* NAGGEO names of generating geometries. +* ITURN geometry turns. +* IDIRR direction of cell (1 for XYZ, 2 for YZX and 3 for ZXY). +* Note: for CAR3D without pins IDIRR=1 +* for CAR3D with pins IDIRR specified by pins direction. +* +*Parameters: output +* NFSUR final number of surfaces. +* NFREG final number of regions. +* MXGSUR maximum number of surfaces for any geometry. +* MXGREG maximum number of region for any geometry. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPGEO,IPTRK +* INTEGER IPGEO,IPTRK + INTEGER IPRINT,NDIM, + > ILCELL,NBOCEL, + > MAXMSH,MAXREG,MAXPIN,NBTCLS, + > ITSYM(4,NBOCEL),IDFEX(0:10,NBOCEL) + DOUBLE PRECISION DCMESH(3,2,NBOCEL) + INTEGER NAGGEO(3,NBOCEL),ITURN(NBOCEL), + > IDIRR(NBOCEL),NFSUR,NFREG,MXGSUR,MXGREG +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTMCD') + INTEGER NSTATE + PARAMETER (NSTATE=40) + DOUBLE PRECISION DCUTOF,DZERO,DONE,DTWO + PARAMETER (DCUTOF=1.0D-8,DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Functions +*---- + DOUBLE PRECISION XDRCST,PI +*---- +* Local variables +*---- + INTEGER IOFNAC,ICEL,ITC,ITYPG,ITRN,IDIRC,ITST,MAXMSS, + > NBGCLS,ICLS,ITYPC,IGCLS,ILEV, + > NMIX,NMIXS,NMIXC,NMIXCS, + > NREG,NSUR,NREGS,NSURS,NREGC,NSURC,NREGCS,NSURCS, + > NREGN,NSURN,NREGCN,NSURCN + INTEGER ISTATG(NSTATE),ISTATC(NSTATE), + > IEDIMX(NSTATE),IEDIMP(NSTATE) + INTEGER NM(4),NMC(4),NMS(4),NMCS(4), + > ITSYMC(4),IGSYM,IDSYM + CHARACTER NAMGG*12,NAMCL*12,NAMREC*12 + INTEGER ILCMLN,ILCMTY,ILCMLX,ILCMLY + INTEGER NAREG,NASUR,NEREN + INTEGER NPIN,IP,IPINT,ICPIN,NPIR,IDGPP,NBPIN + DOUBLE PRECISION DELTA,TWOPI,DROUT,DHPIN +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ITPIN,ISPLT,MIX + REAL, ALLOCATABLE, DIMENSION(:) :: RMESH,RPIN,APIN,CPINX,CPINY + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: DAMESH,DRAPIN +* + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: MIXC,ISPLTR + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NAGCLS,INDXSR + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDSUR,IDREG + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: DAMESR +*---- +* Data +*---- + CHARACTER CLEV(2)*1 + SAVE CLEV + DATA CLEV /'C','P'/ +*---- +* Scratch storage allocation +* ITPIN temporary array for reading pin type. +* ISPLT temporary array for reading cell mesh split. +* MIX temporary array for reading cell mixture (including HMIX). +* RMESH temporary vector for reading cell mesh array. +* RPIN temporary vector for reading pin positions. +* APIN temporary vector for reading pin angles. +* DAMESH temporary vector for storing global mesh array. +* DRAPIN temporary vector for storing global pin positions. +*---- + ALLOCATE(ITPIN(3,MAXPIN),ISPLT(MAXMSH,4),MIX(MAXREG,2)) + ALLOCATE(RMESH(0:MAXMSH),RPIN(MAXPIN),APIN(MAXPIN), + > CPINX(MAXPIN),CPINY(MAXPIN)) + ALLOCATE(DAMESH(-1:MAXMSH,4),DRAPIN(-1:4,MAXPIN)) +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + PI=XDRCST('Pi',' ') + TWOPI=DTWO*PI + ALLOCATE(MIXC(MAXREG,2,2),NAGCLS(3,NBTCLS),ISPLTR(MAXMSH,4,2)) + MXGSUR=0 + MXGREG=0 + IOFNAC=0 + IGCLS=0 + ICPIN=0 + NAREG=0 + NASUR=0 + DO ICEL=1,NBOCEL + IF(ILCELL .EQ. 1) THEN + WRITE(NAMGG,'(3A4)') (NAGGEO(ITC,ICEL),ITC=1,3) + CALL LCMSIX(IPGEO,NAMGG,1) + ELSE + NAMGG='/ ' + ENDIF + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6010) ICEL,NAMGG + ENDIF + ISTATG(:NSTATE)=0 + CALL LCMGET(IPGEO,'STATE-VECTOR',ISTATG) + ITYPG=ISTATG(1) + IF(ITYPG .EQ. 20) THEN + IF(ISTATG(2) .EQ. 0) ITYPG=5 + ELSE IF(ITYPG .EQ. 21 .OR. ITYPG .EQ. 22 .OR. + > ITYPG .EQ. 23) THEN + IF(ISTATG(2) .EQ. 0) ITYPG=7 + ELSE IF(ITYPG .EQ. 26) THEN + IF(ISTATG(2) .EQ. 0) ITYPG=12 + ELSE IF(ITYPG .EQ. 27) THEN + IF(ISTATG(2) .EQ. 0) ITYPG=13 + ENDIF + NM(4)=ISTATG(2) + NM(1)=ISTATG(3) + NM(2)=ISTATG(4) + NM(3)=ISTATG(5) + NMIX=ISTATG(6) + ITRN=ITURN(ICEL) + IDIRC=IDIRR(ICEL) + NBGCLS=ISTATG(13) + ILEV=1 + ITPIN(:3,:MAXPIN)=0 + ICPIN=0 + IGSYM=0 + DO IDSYM=1,4 + ITSYMC(IDSYM)=0 + IGSYM=IGSYM+ABS(ITSYM(IDSYM,ICEL)) + ENDDO + IF(NBGCLS .NE. 0) THEN +*---- +* Get pin cluster geometry information +*---- + DRAPIN(-1:4,:MAXPIN)=DZERO + ILEV=2 + CALL LCMGET(IPGEO,'CLUSTER',NAGCLS(1,IOFNAC+1)) + DO ICLS=1,NBGCLS + IGCLS=IGCLS+1 + WRITE(NAMCL,'(3A4)') (NAGCLS(ITC,IOFNAC+ICLS),ITC=1,3) + CALL LCMSIX(IPGEO,NAMCL,1) + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6011) ICLS,NAMCL + ENDIF + ISTATC(:NSTATE)=0 + CALL LCMGET(IPGEO,'STATE-VECTOR',ISTATC) + ITYPC=ISTATC(1) + IF(ITYPC .EQ. 20) THEN + IF(ISTATC(2) .EQ. 0) ITYPC=5 + ELSE IF(ITYPC .EQ. 21 .OR. ITYPC .EQ. 22 .OR. + > ITYPC .EQ. 23) THEN + IF(ISTATC(2) .EQ. 0) ITYPC=7 + ENDIF +*---- +* Cartesian or Annular pin +*---- + IPINT=0 + IF(ITYPC .EQ. 5 .OR. ITYPC .EQ. 7 .OR. + > ITYPC .EQ. 20 .OR. ITYPC .EQ. 23 ) THEN + IPINT=-3 + ELSE IF(ITYPC .EQ. 3 .OR. ITYPC .EQ. 6 ) THEN + IPINT=3 + ELSE IF(ITYPC .EQ. 21) THEN + IPINT=-1 + ELSE IF(ITYPC .EQ. 10) THEN + IPINT=1 + ELSE IF(ITYPC .EQ. 22) THEN + IPINT=-2 + ELSE IF(ITYPC .EQ. 11 ) THEN + IPINT=2 + ENDIF + NMC(4)=ISTATC(2) + NMC(1)=ISTATC(3) + NMC(2)=ISTATC(4) + NMC(3)=ISTATC(5) + NMIXC=ISTATC(6) + DAMESH(-1:MAXMSH,:4)=DZERO + ISPLT(:MAXMSH,:4)=1 + MIX(:MAXREG,:2)=0 + MIXC(:MAXREG,:2,:2)=0 + CALL NXTEGI(IPGEO ,IPRINT,ITYPC ,MAXMSH,NMIXC ,NMC , + > MAXMSS,NMCS ,NREGC ,NREGCS,NSURC ,NSURCS, + > MIX ,ISPLT ,DAMESH,RMESH ,MIXC ) + ALLOCATE(IDSUR(NSURCS),IDREG(NREGCS)) + IDSUR(:NSURCS)=0 + IDREG(:NREGCS)=0 + NEREN=NREGCS+NSURCS + ALLOCATE(DAMESR(MAXMSS+2,4,2)) + DAMESR(:MAXMSS+2,:4,:2)=DZERO + NMIXCS=NREGCS + DROUT=DAMESH(NMC(4),4) + IF(ABS(IPINT) .EQ. 3) THEN +*---- +* For pins rotate symmetry by pi/2 around z axis +*---- + IF(ITSYM(1,ICEL) .NE. 0) THEN + ITSYMC(2)=ITSYM(1,ICEL) + ENDIF + IF(ITSYM(2,ICEL) .NE. 0) THEN + ITSYMC(1)=ITSYM(2,ICEL) + ENDIF + ITSYMC(3)=ITSYM(3,ICEL) + ITSYMC(4)=4*ITSYM(4,ICEL) + ELSE IF(ABS(IPINT) .EQ. 2) THEN +*---- +* For pins rotate symmetry by pi/2 around y axis +*---- + IF(ITSYM(1,ICEL) .NE. 0) THEN + ITSYMC(3)=ITSYM(1,ICEL) + ENDIF + IF(ITSYM(3,ICEL) .NE. 0) THEN + ITSYMC(1)=ITSYM(3,ICEL) + ENDIF + ITSYMC(2)=ITSYM(2,ICEL) + ITSYMC(4)=4*ITSYM(4,ICEL) + ELSE IF(ABS(IPINT) .EQ. 1) THEN +*---- +* For pins rotate symmetry by pi/2 around x axis +*---- + IF(ITSYM(3,ICEL) .NE. 0) THEN + ITSYMC(2)=ITSYM(3,ICEL) + ENDIF + IF(ITSYM(2,ICEL) .NE. 0) THEN + ITSYMC(3)=ITSYM(2,ICEL) + ENDIF + ITSYMC(1)=ITSYM(1,ICEL) + ITSYMC(4)=4*ITSYM(4,ICEL) + ENDIF +*---- +* Test if pin cells satisfy symmetry options +*---- + IF(IGSYM .GT. 0) THEN +*---- +* Rotate pin cells and test for intrinsic symmetry +*---- + ITST=1 + CALL NXTRIS(IPRINT,ITYPC ,MAXMSH,NREGC ,ITRN ,ITST , + > ITSYMC(1) ,NMC ,MIX ,ISPLT ,DAMESH, + > NMCS ,MIXC ,ISPLTR, + > DAMESR) + ELSE +*---- +* Rotate pin cells +*---- + ITST=0 + CALL NXTRIS(IPRINT,ITYPC ,MAXMSH,NREGC ,ITRN ,ITST , + > ITSYMC(1) ,NMC ,MIX ,ISPLT ,DAMESH, + > NMCS ,MIXC ,ISPLTR,DAMESR) + ENDIF +*---- +* Final mesh after unfolding +*---- + IF(MOD(ITRN,2) .EQ. 0) THEN +*---- +* First turn geometry type if required +*---- + IF(ITYPC .EQ. 10) THEN + ITYPC=11 + ELSE IF(ITYPC .EQ.11) THEN + ITYPC=10 + ELSE IF(ITYPC .EQ.21) THEN + ITYPC=22 + ELSE IF(ITYPC .EQ.22) THEN + ITYPC=21 + ENDIF + ENDIF +*---- +* Then create new mesh +*---- + CALL NXTSGI(IPTRK ,IPRINT,MAXMSH,ITYPC ,IGCLS ,ILEV , + > MAXMSS,NMIXC ,NMC ,MIX ,DAMESH,ISPLT , + > NMIXCS,NMCS ,DAMESR,ITSYMC(1), + > NREGCS,NSURCS,NREGCN,NSURCN,NEREN , + > IDREG ,IDSUR ) + ALLOCATE(INDXSR(5,NREGCS+NSURCS+1)) + INDXSR(:5,:NREGCS+NSURCS+1)=0 + NBPIN=0 + MXGSUR=MAX(MXGSUR,NSURCS) + MXGREG=MAX(MXGREG,NREGCS) + IEDIMP(:NSTATE)=0 + IEDIMP(1)=ITYPC + IEDIMP(2)=NMCS(4) + IEDIMP(3)=NMCS(1) + IEDIMP(4)=NMCS(2) + IEDIMP(5)=NMCS(3) + IEDIMP(6)=NMIXCS + IEDIMP(7)=ILEV + IEDIMP(8)=NREGCS + IEDIMP(9)=NSURCS + IEDIMP(10)=NREGCN + IEDIMP(11)=NSURCN + IEDIMP(12)=NAREG+1 + CALL NXTVOL(IPTRK ,IPRINT,MAXMSS,ITYPC ,IDIRC ,IGCLS , + > ILEV ,NMCS ,NREGCS,NSURCS,NREGCN,NSURCN, + > MAXPIN,NBPIN ,ITPIN ,DRAPIN, IDREG,IDSUR , + > DAMESR,INDXSR,NAREG ) + IEDIMP(13)=NAREG + DEALLOCATE(DAMESR) +*---- +* Read pin locations +*---- + CALL LCMGET(IPGEO,'NPIN',NPIN) + CALL LCMLEN(IPGEO,'RPIN',ILCMLN,ILCMTY) + IF(ILCMLN .GE. 1) THEN + IF(ILCMLN .EQ. 1) THEN + CALL LCMGET(IPGEO,'RPIN',RPIN) + DO IP=1,NPIN + DRAPIN(0,ICPIN+IP)=DBLE(RPIN(1)) + ENDDO + ELSE IF(ILCMLN .EQ. NPIN) THEN + CALL LCMGET(IPGEO,'RPIN',RPIN) + DO IP=1,NPIN + DRAPIN(0,ICPIN+IP)=DBLE(RPIN(IP)) + ENDDO + ELSE + CALL XABORT(NAMSBR// + > ': Length of RPIN vector is invalid') + ENDIF + CALL LCMLEN(IPGEO,'APIN',ILCMLN,ILCMTY) + IF(ILCMLN .EQ. 0) THEN + DRAPIN(-1,ICPIN+1)=DZERO + DELTA=(DTWO*PI)/DBLE(NPIN) + DO IP=2,NPIN + DRAPIN(-1,ICPIN+IP)=DRAPIN(-1,ICPIN+IP-1)+DELTA + ENDDO + ELSE IF(ILCMLN .EQ. 1) THEN + CALL LCMGET(IPGEO,'APIN',APIN) + DRAPIN(-1,ICPIN+1)=DBLE(APIN(1)) + DELTA=(DTWO*PI)/DBLE(NPIN) + DO IP=2,NPIN + DRAPIN(-1,ICPIN+IP)=DRAPIN(-1,ICPIN+IP-1)+DELTA + ENDDO + ELSE IF(ILCMLN .EQ. NPIN) THEN + CALL LCMGET(IPGEO,'APIN',APIN) + DO IP=1,NPIN + DRAPIN(-1,ICPIN+IP)=DBLE(APIN(IP)) + ENDDO + ELSE + CALL XABORT(NAMSBR// + > ': Length of APIN vector is invalid') + ENDIF + ELSE + CALL LCMLEN(IPGEO,'CPINX',ILCMLX,ILCMTY) + CALL LCMLEN(IPGEO,'CPINY',ILCMLY,ILCMTY) + IF(ILCMLX .EQ. NPIN .AND. ILCMLY .EQ. NPIN) THEN + CALL LCMGET(IPGEO,'CPINX',CPINX) + CALL LCMGET(IPGEO,'CPINY',CPINY) + ELSE + CALL XABORT(NAMSBR// + >': (RPIN,APIN) or (CPINX,CPINY) are absent for pin cluster') + ENDIF + DO IP=1,NPIN + DRAPIN(0,ICPIN+IP)=DBLE(SQRT(CPINX(IP)**2+CPINY(IP)**2)) + DRAPIN(-1,ICPIN+IP)=DBLE(ATAN2(CPINY(IP),CPINX(IP))) + ENDDO + ENDIF +*---- +* Find pin height +*---- + IDGPP=MOD(IDIRC+1,3)+1 + IF(NDIM .EQ. 3) THEN + DHPIN=DAMESH(NMC(IDGPP),IDGPP)-DAMESH(0,IDGPP) + ELSE + DHPIN=DONE + ENDIF +*---- +* Replace angles in range 0 to 2*Pi +*---- + DO IP=1,NPIN + IF(DRAPIN(-1,ICPIN+IP) .GE. DZERO) THEN + NPIR=INT((DRAPIN(-1,ICPIN+IP)+DCUTOF)/TWOPI) + DRAPIN(-1,ICPIN+IP)=DRAPIN(-1,ICPIN+IP) + > -DBLE(NPIR)*TWOPI + ELSE + NPIR=INT((DRAPIN(-1,ICPIN+IP)-DCUTOF)/TWOPI) + DRAPIN(-1,ICPIN+IP)=DRAPIN(-1,ICPIN+IP) + > -DBLE(NPIR-1)*TWOPI + ENDIF + DRAPIN(IDGPP,ICPIN+IP)=DHPIN + DRAPIN(4,ICPIN+IP)=DROUT + ITPIN(1,ICPIN+IP)=ICEL + ITPIN(2,ICPIN+IP)=IGCLS + ITPIN(3,ICPIN+IP)=IPINT + ENDDO + IF(IGSYM .GT. 0) THEN +*---- +* Test pin in cluster for symmetry +*---- + CALL NXTTPS(IPRINT,NPIN ,IDGPP ,ITSYM(1,ICEL), + > DRAPIN(-1,ICPIN+1)) + ENDIF +*---- +* Renumber pin surfaces +*---- + IEDIMP(14)=NASUR+1 + CALL NXTRPS(IPTRK ,IPRINT,ITYPC ,IGCLS ,ILEV , + > NREGCS,NSURCS,NSURCN,IDFEX(0,ICEL), + > INDXSR,DHPIN ,DCMESH(1,1,ICEL), + > NASUR ,IDSUR ) + DEALLOCATE(INDXSR) + DEALLOCATE(IDSUR,IDREG) + IEDIMP(15)=NASUR + IEDIMP(16)=ICPIN+1 + IEDIMP(17)=NPIN + IEDIMP(20)=IDIRC + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGCLS,'DIM' + CALL LCMPUT(IPTRK,NAMREC,NSTATE,1,IEDIMP) + ICPIN=ICPIN+NPIN + CALL LCMSIX(IPGEO,NAMCL,2) + ENDDO +*---- +* Save cluster information for this cell +*---- + ILEV=1 + IOFNAC=IOFNAC+NBGCLS + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),ICEL,'PIN' + CALL LCMPUT(IPTRK,NAMREC,6*ICPIN,4,DRAPIN) + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),ICEL,'PNT' + CALL LCMPUT(IPTRK,NAMREC,3*ICPIN,1,ITPIN) + ENDIF + DAMESH(-1:MAXMSH,:4)=DZERO + ISPLT(:MAXMSH,:4)=1 + MIX(:MAXREG,:2)=0 + MIXC(:MAXREG,:2,:2)=0 + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6012) + ENDIF +*---- +* Get main geometry information +*---- + CALL NXTEGI(IPGEO ,IPRINT,ITYPG ,MAXMSH,NMIX ,NM , + > MAXMSS,NMS ,NREG ,NREGS ,NSUR ,NSURS , + > MIX ,ISPLT ,DAMESH, + > RMESH ,MIXC ) + NMIXS=NREGS + ALLOCATE(IDREG(NREGS),IDSUR(NSURS)) + IDREG(:NREGS)=0 + IDSUR(:NSURS)=0 + NEREN=NREGS+NSURS + ALLOCATE(DAMESR(MAXMSS+2,4,2)) + DAMESR(:MAXMSS+2,:4,:2)=DZERO + IF(ITYPG .EQ. 12 .OR. ITYPG .EQ. 13 .OR. + > ITYPG .EQ. 26 .OR. ITYPG .EQ. 27) THEN + IF(IGSYM .GT. 0) THEN +*---- +* Rotate global geometry and test for intrinsic symmetry +*---- + ITST=1 + CALL NXTRTS(IPRINT,ITYPG ,MAXMSH,NREG ,ITRN ,ITST, + > ITSYM(1,ICEL),NM ,MIX ,ISPLT ,DAMESH, + > NMS ,MIXC ,ISPLTR,DAMESR) + ELSE +*---- +* Rotate global geometry +*---- + ITST=0 + CALL NXTRTS(IPRINT,ITYPG ,MAXMSH,NREG ,ITRN ,ITST, + > ITSYM(1,ICEL),NM ,MIX ,ISPLT ,DAMESH, + > NMS ,MIXC ,ISPLTR,DAMESR) + ENDIF + ELSE + IF(IGSYM .GT. 0) THEN +*---- +* Rotate global geometry and test for intrinsic symmetry +*---- + ITST=1 + CALL NXTRIS(IPRINT,ITYPG ,MAXMSH,NREG ,ITRN ,ITST, + > ITSYM(1,ICEL),NM ,MIX ,ISPLT ,DAMESH, + > NMS ,MIXC ,ISPLTR,DAMESR) + ELSE +*---- +* Rotate global geometry +*---- + ITST=0 + CALL NXTRIS(IPRINT,ITYPG ,MAXMSH,NREG ,ITRN ,ITST, + > ITSYM(1,ICEL),NM ,MIX ,ISPLT ,DAMESH, + > NMS ,MIXC ,ISPLTR,DAMESR) + ENDIF + ENDIF +*---- +* Final mesh after unfolding +*---- + IF(MOD(ITRN,2) .EQ. 0) THEN +*---- +* First turn geometry type if required +*---- + IF(ITYPG .EQ. 10) THEN + ITYPG=11 + ELSE IF(ITYPG .EQ.11) THEN + ITYPG=10 + ELSE IF(ITYPG .EQ.21) THEN + ITYPG=22 + ELSE IF(ITYPG .EQ.22) THEN + ITYPG=21 + ENDIF + ENDIF +*---- +* Then create new mesh +*---- + IF(ITYPG .EQ. 12 .OR. ITYPG .EQ. 13 .OR. + > ITYPG .EQ. 26 .OR. ITYPG .EQ. 27) THEN + CALL NXTSGT(IPTRK ,IPRINT,MAXMSH,ITYPG ,ICEL ,ILEV , + > MAXMSS,NMIX ,NM ,MIX ,DAMESH,ISPLT , + > NMIXS ,NMS ,DAMESR, + > ITSYM(1,ICEL), + > NREGS ,NSURS ,NREGN ,NSURN ,NEREN , + > IDREG ,IDSUR ) + ELSE + CALL NXTSGI(IPTRK ,IPRINT,MAXMSH,ITYPG ,ICEL ,ILEV , + > MAXMSS,NMIX ,NM ,MIX ,DAMESH,ISPLT , + > NMIXS ,NMS ,DAMESR, + > ITSYM(1,ICEL), + > NREGS ,NSURS ,NREGN ,NSURN ,NEREN , + > IDREG ,IDSUR ) + ENDIF + ALLOCATE(INDXSR(5,NREGS+NSURS+1)) + INDXSR(:5,:NREGS+NSURS+1)=0 + NBPIN=ICPIN + MXGSUR=MAX(MXGSUR,NSURS) + MXGREG=MAX(MXGREG,NREGS) + IEDIMX(:NSTATE)=0 + IEDIMX(1)=ITYPG + IEDIMX(2)=NMS(4) + IEDIMX(3)=NMS(1) + IEDIMX(4)=NMS(2) + IEDIMX(5)=NMS(3) + IEDIMX(6)=NMIXS + IEDIMX(7)=ILEV + IEDIMX(8)=NREGS + IEDIMX(9)=NSURS + IEDIMX(10)=NREGN + IEDIMX(11)=NSURN + IEDIMX(12)=NAREG+1 + CALL NXTVOL(IPTRK ,IPRINT,MAXMSS,ITYPG ,IDIRC ,ICEL , + > ILEV ,NMS ,NREGS ,NSURS ,NREGN ,NSURN , + > MAXPIN,NBPIN ,ITPIN ,DRAPIN,IDREG ,IDSUR , + > DAMESR,INDXSR,NAREG ) +*---- +* Renumber cell surfaces +*---- + IEDIMX(13)=NAREG + IEDIMX(14)=NASUR+1 + CALL NXTRCS(IPTRK ,IPRINT,ICEL ,ILEV , + > NREGS ,NSURS ,NSURN ,IDFEX(0,ICEL), + > INDXSR,NASUR ,IDSUR ) + IEDIMX(15)=NASUR + IEDIMX(16)=NBGCLS + IEDIMX(17)=IGCLS-NBGCLS+1 + IEDIMX(18)=NBPIN + IEDIMX(19)=IDFEX(0,ICEL) + IEDIMX(20)=IDIRC + DEALLOCATE(INDXSR) + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),ICEL,'DIM' + CALL LCMPUT(IPTRK,NAMREC,NSTATE,1,IEDIMX) + DEALLOCATE(DAMESR) + DEALLOCATE(IDSUR,IDREG) + IF(ILCELL .EQ. 1) THEN + CALL LCMSIX(IPGEO,NAMGG,2) + ENDIF + ENDDO +*---- +* Processing finished: +* print routine closing output header if required +* and return +*---- + DEALLOCATE(ISPLTR,NAGCLS,MIXC) + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF + NFSUR=NASUR + NFREG=NAREG +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(DRAPIN,DAMESH) + DEALLOCATE(CPINY,CPINX,APIN,RPIN,RMESH) + DEALLOCATE(MIX,ISPLT) + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(' Processing CELL = ',I5.4,5X,A12) + 6011 FORMAT(' Processing CLUSTER = ',I5.4,5X,A12) + 6012 FORMAT(' Global cell processing ') + END diff --git a/Dragon/src/NXTPCA.f b/Dragon/src/NXTPCA.f new file mode 100644 index 0000000..ac77f36 --- /dev/null +++ b/Dragon/src/NXTPCA.f @@ -0,0 +1,399 @@ +*DECK NXTPCA + SUBROUTINE NXTPCA(IPRINT,NDIM ,IDIRC ,MXMESH,MAXSUR,MAXREG, + > MESH ,DMESH ,NPIN ,ITPIN ,DPIN , + > NBSUR ,NBREG ,INDXSR,SURVOL) +* +*---------- +* +*Purpose: +* Remove from the volumes or surfaces +* associated with a Cartesian 2-D or 3-D geometry +* the volumes or surfaces of the overlapping pins. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau. +* +*Parameters: input +* IPRINT print level. +* NDIM dimension of problem. +* IDIRC the direction of the first axis of a Cartesian geometry +* assuming the axis are in a cyclic rotation. +* MXMESH maximum number of spatial subdivision in +* $X$, $Y$ and $Z$. +* MAXSUR maximum number of surfaces in the geometry. +* MAXREG maximum number of regions in the geometry. +* MESH effective number of spatial subdivision in +* each direction ($X$, $Y$ and $Z$). +* DMESH spatial description of the Cartesian geometry. +* NPIN number of pins to superimpose on geometry. +* ITPIN type of pin. +* DPIN pin location and dimensions. +* NBSUR number of surfaces in the geometry. +* NBREG final number of non void regions in the geometry. +* +*Parameters: input/output +* INDXSR local indexing of regions. +* SURVOL volume of regions. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*Comments: +* 1- Meaning of IDIRC: +* IDIRC axes in 1-D axes in 2-D axes in 3-D +* 1 x (x,y) (x,y,z) +* 2 y (y,z) (y,z,x) +* 3 z (z,x) (z,x,y) +* 2- Contents of the DMESH array: +* mesh in $X$ is x(i)=DMESH(i,1) for i=0,MESH(1); +* mesh in $Y$ is y(j)=DMESH(j,2) for j=0,MESH(2); +* mesh in $Z$ is z(k)=DMESH(k,3) for k=0,MESH(3); +* 3- Contents of the DPIN array for pin IPIN: +* if(ITPIN(3,IPIN) = 1) then +* -> annular pin +* if(IDIRC = 1) then +* ->annular regions in the $X-Y$ plane +* centre (x,y,z)=(DPIN(0,IPIN)*COS(DPIN(-1,IPIN)) +* DPIN(0,IPIN)*SIN(DPIN(-1,IPIN)),0.0D0) +* outer pin radius r=DPIN(4,IPIN) +* pin height dz(iz)=DPIN(3,IPIN) +* else if(IDIRC = 2) then +* ->annular regions in the $Y-Z$ plane +* centre (y,z,x)=(DPIN(0,IPIN)*COS(DPIN(-1,IPIN)) +* DPIN(0,IPIN)*SIN(DPIN(-1,IPIN)),0.0D0) +* outer pin radius r=DPIN(4,IPIN) +* pin height dx(ix)=DPIN(1,IPIN) +* else if(IDIRC = 3) then +* ->annular regions in the $Z-X$ plane +* centre (z,x,y)=(DPIN(0,IPIN)*COS(DPIN(-1,IPIN)) +* DPIN(0,IPIN)*SIN(DPIN(-1,IPIN)),0.0D0) +* outer pin radius r=DPIN(4,IPIN) +* pin height dy(iy)=DPIN(2,IPIN) +* endif +* else if(ITPIN(3,IPIN) = 2) then +* -> Cartesian pin +* if(IDIRC = 1) then +* ->Cartesian region in the $X-Y$ plane +* centre (x,y,z)=(DPIN(0,IPIN)*COS(DPIN(-1,IPIN)) +* DPIN(0,IPIN)*SIN(DPIN(-1,IPIN)),0.0D0) +* pin width in $X$ dx=DPIN(1,IPIN) +* pin width in $Y$ dy=DPIN(2,IPIN) +* pin height dz(iz)=DPIN(3,IPIN) +* else if(IDIRC = 2) then +* ->Cartesian region in the $Y-Z$ plane +* centre (y,z,x)=(DPIN(0,IPIN)*COS(DPIN(-1,IPIN)) +* DPIN(0,IPIN)*SIN(DPIN(-1,IPIN)),0.0D0) +* pin width in $Y$ dy=DPIN(2,IPIN) +* pin width in $Z$ dz=DPIN(3,IPIN) +* pin height dx(ix)=DPIN(1,IPIN) +* else if(IDIRC = 3) then +* ->Cartesian region in the $Z-X$ plane +* centre (z,x,y)=(DPIN(0,IPIN)*COS(DPIN(-1,IPIN)) +* DPIN(0,IPIN)*SIN(DPIN(-1,IPIN)),0.0D0) +* pin width in $Z$ dz=DPIN(3,IPIN) +* pin width in $X$ dx=DPIN(1,IPIN) +* pin height dy(iy)=DPIN(2,IPIN) +* endif +* endif +* 4- Contents of the INDXSR array: +* For i>0 +* INDXSR(1,i)= ix is the $X$ location of region i +* INDXSR(2,i)= iy is the $Y$ location of region i +* INDXSR(3,i)= iz is the $Z$ location of region i +* INDXSR(4,i)= ir =0 is the $R$ location of region i. +* INDXSR(5,i)= not used. +* For i<0 +* INDXSR(1,i)= ix is the $X$ location of surface i +* INDXSR(2,i)= iy is the $Y$ location of surface i +* INDXSR(3,i)= iz is the $Z$ location of surface i +* INDXSR(4,i)= ir =0 is the $R$ location of surface i. +* INDXSR(5,i)= not used. +* with INDXSR(n,i)=-1 for surface associated with +* location 0 in direction n. +* with INDXSR(n,i)=-2 for surface associated with +* location MESH(n) in direction n. +* Note that for radial regions INDXSR(n,i)=-1 does not +* exists. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,NDIM,IDIRC,MXMESH,MAXSUR,MAXREG + INTEGER MESH(4) + DOUBLE PRECISION DMESH(-1:MXMESH,4) + INTEGER NPIN,ITPIN(3,NPIN) + DOUBLE PRECISION DPIN(-1:4,NPIN) + INTEGER NBSUR,NBREG,INDXSR(5,-MAXSUR:MAXREG) + DOUBLE PRECISION SURVOL(-MAXSUR:MAXREG) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTPCA') + INTEGER MAXDIM + PARAMETER (MAXDIM=4) + DOUBLE PRECISION DCUTOF + PARAMETER (DCUTOF=1.0D-8) + DOUBLE PRECISION DZERO,DONE,DTWO + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Functions +*---- + DOUBLE PRECISION XDRCST,PI + INTEGER NXTIRA,NXTIRR + INTEGER ITYIRP + DOUBLE PRECISION VOLINT +*---- +* Local variables +*---- + INTEGER ID,IDG,IDIR(MAXDIM),NM(MAXDIM),IDM(MAXDIM), + > IDGP1,IDGP2,IDGPP,NSOZB,NSOZT + INTEGER IPIN,IXYZ,IZ,IY,IX,ISUR,IVOL,IR,ILOC + DOUBLE PRECISION ZB,ZT + DOUBLE PRECISION POSPIN(0:2),XYPIN(4),XYCAR(4) + DOUBLE PRECISION VOLPIN,PPRMIN,PPRMAX,PPPMIN,PPPMAX,DPP +*---- +* Data +*---- + CHARACTER CDIR(MAXDIM)*1 + SAVE CDIR + DATA CDIR /'X','Y','Z','R'/ +*---- +* Prepare loops over spatial directions as a function +* of IDIRC and NDIM for Cartesian mesh. +*---- + IF(NDIM .LT. 2) CALL XABORT(NAMSBR// + >': Problem must be 2-D or 3-D') + ITYIRP=0 + VOLPIN=DZERO + ZB=DZERO + ZT=DZERO + PI=XDRCST('Pi',' ') + DO 100 ID=1,NDIM + IDG=MOD(IDIRC+ID-2,3)+1 + IDIR(ID)=IDG + NM(IDG)=MESH(IDG) + IDM(IDG)=1 + 100 CONTINUE + DO 101 ID=NDIM+1,3 + IDG=MOD(IDIRC+ID-2,3)+1 + IDIR(ID)=IDG + NM(IDG)=1 + IDM(IDG)=0 + 101 CONTINUE + IDGP1=IDIR(1) + IDGP2=IDIR(2) + IDGPP=IDIR(3) + NSOZB=2*NM(IDGPP)*(NM(IDGP1)+NM(IDGP2)) + NSOZT=NSOZB+NM(IDGP1)*NM(IDGP2) +*---- +* Print mesh if required +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR +*---- +* Cartesian mesh +*---- + DO 600 ID=1,NDIM + IDG=IDIR(ID) + WRITE(IOUT,6002) 'MESH'//CDIR(IDG) + WRITE(IOUT,6006) (DMESH(IXYZ,IDG),IXYZ=0,NM(IDG)) + WRITE(IOUT,6003) + 600 CONTINUE +*---- +* Pin description +*---- + WRITE(IOUT,6007) 'PINDIR',IDGPP + DO 610 IPIN=1,NPIN + WRITE(IOUT,6017) 'PinTyp',IPIN,ITPIN(3,IPIN) + IF(ITPIN(3,IPIN) .GE. 1) THEN + WRITE(IOUT,6019) 'PinC'//CDIR(IDGP1)//CDIR(IDGP2),IPIN, + > DPIN(0,IPIN)*COS(DPIN(-1,IPIN)), + > DPIN(0,IPIN)*SIN(DPIN(-1,IPIN)) + WRITE(IOUT,6018) 'PinRad',IPIN,DPIN(4,IPIN) + ELSE IF(ITPIN(3,IPIN) .LE. -1) THEN + WRITE(IOUT,6019) 'PinC'//CDIR(IDGP1)//CDIR(IDGP2),IPIN, + > DPIN(0,IPIN)*COS(DPIN(-1,IPIN)), + > DPIN(0,IPIN)*SIN(DPIN(-1,IPIN)) + WRITE(IOUT,6019) 'PinW'//CDIR(IDGP1)//CDIR(IDGP2),IPIN, + > DPIN(IDGP1,IPIN),DPIN(IDGP2,IPIN) + ENDIF + IF(NDIM .EQ. 3) THEN + WRITE(IOUT,6019) 'PinPo'//CDIR(IDGPP),IPIN, + > DMESH(-1,IDGPP)-DPIN(IDGPP,IPIN)/DTWO, + > DMESH(-1,IDGPP)+DPIN(IDGPP,IPIN)/DTWO + ENDIF + 610 CONTINUE + ENDIF +*---- +* Loop over pins +*---- + DO 110 IPIN=1,NPIN +*---- +* for 3-D problem, +* Find pin bottom (ZB) and top (ZT) z location. +*---- + IF(NDIM .EQ. 3) THEN + ZB=DMESH(-1,IDGPP)-DPIN(IDGPP,IPIN)/DTWO + ZT=ZB+DPIN(IDGPP,IPIN) + ENDIF + IF(ITPIN(3,IPIN) .GE. 1) THEN +*---- +* Annular pin properties +*---- + POSPIN(0)=DPIN(4,IPIN) + POSPIN(1)=DPIN(0,IPIN)*COS(DPIN(-1,IPIN)) + POSPIN(2)=DPIN(0,IPIN)*SIN(DPIN(-1,IPIN)) + VOLPIN=PI*POSPIN(0)*POSPIN(0) + ELSE IF (ITPIN(3,IPIN) .LE. -1) THEN +*---- +* Rectangular pin properties +*---- + XYPIN(1)=DMESH(-1,IDGP1)-DPIN(IDGP1,IPIN)/DTWO + XYPIN(2)=DMESH(-1,IDGP1)+DPIN(IDGP1,IPIN)/DTWO + XYPIN(3)=DMESH(-1,IDGP2)-DPIN(IDGP2,IPIN)/DTWO + XYPIN(4)=DMESH(-1,IDGP2)+DPIN(IDGP2,IPIN)/DTWO + VOLPIN=DPIN(IDGP2,IPIN)*DPIN(IDGP1,IPIN) + ENDIF +*---- +* 1- Loop over second normal direction +*---- + DO 120 IY=1,NM(IDGP2) + XYCAR(3)=DMESH(IY-1,IDGP2) + XYCAR(4)=DMESH(IY,IDGP2) +*---- +* 2- Loop over first normal direction +*---- + DO 121 IX=1,NM(IDGP1) + XYCAR(1)=DMESH(IX-1,IDGP1) + XYCAR(2)=DMESH(IX,IDGP1) + IF(ITPIN(3,IPIN) .GE. 1) THEN +*---- +* Find rectangle/annular pin intersection +*---- + ITYIRP=NXTIRA(XYCAR ,POSPIN,VOLINT) + ELSE IF (ITPIN(3,IPIN) .LE. -1) THEN +*---- +* Find rectangle/rectangular pin intersection +*---- + ITYIRP=NXTIRR(XYCAR ,XYPIN ,VOLINT) + ENDIF + IF(ITYIRP .NE. 0) THEN + VOLPIN=VOLPIN-VOLINT +*---- +* There is an intersection possible between the pin and +* the rectangle. +* 1- Look for botton and top surface in 3-D +*---- + IF(NDIM .EQ. 3) THEN + ILOC=(IY-1)*NM(IDGP1)+IX + IF(ZB .LE. DMESH(0,IDGPP) .AND. + > ZT .GE. DMESH(0,IDGPP)) THEN +*---- +* Remove area contribution from bottom surface +*---- + ISUR=NSOZB+ILOC + SURVOL(-ISUR)=SURVOL(-ISUR)-VOLINT + ENDIF + IF(ZB .LE. DMESH(NM(IDGPP),IDGPP) .AND. + > ZT .GE. DMESH(NM(IDGPP),IDGPP)) THEN +*---- +* Remove area contribution from top surface +*---- + ISUR=NSOZT+ILOC + SURVOL(-ISUR)=SURVOL(-ISUR)-VOLINT + ENDIF + PPPMIN=ZB + PPPMAX=PPPMIN+DPIN(IDGPP,IPIN) + DO 130 IZ=1,NM(IDGPP) + PPRMIN=MAX(DMESH(IZ-1,IDGPP),PPPMIN) + PPRMAX=MIN(DMESH(IZ,IDGPP),PPPMAX) + IF(PPRMIN .LT. PPRMAX) THEN + DPP=VOLINT*(PPRMAX-PPRMIN) + IVOL=((IZ-1)*NM(IDGP2)+(IY-1))*NM(IDGP1)+IX + SURVOL(IVOL)=SURVOL(IVOL)-DPP + ENDIF + 130 CONTINUE + ELSE + IVOL=(IY-1)*NM(IDGP1)+IX + SURVOL(IVOL)=SURVOL(IVOL)-VOLINT + ENDIF + ENDIF +*---- +* If pin all extracted, go to next pin +*---- + IF(VOLPIN .LE. DZERO) GO TO 115 + 121 CONTINUE + 120 CONTINUE + 115 CONTINUE + 110 CONTINUE +*---- +* Test for negative surface area and volumes +*---- + DO 140 ISUR=1,NBSUR + IF(SURVOL(-ISUR) .LT. -DCUTOF) THEN + WRITE(IOUT,9000) NAMSBR,-ISUR + WRITE(IOUT,9002) (INDXSR(IR,-ISUR),IR=1,5),SURVOL(-ISUR) + CALL XABORT(NAMSBR// + > ': Region with negative surface area detected') + ELSE IF(SURVOL(-ISUR) .LT. DCUTOF) THEN + SURVOL(-ISUR)=DZERO + ENDIF + 140 CONTINUE + DO 141 IVOL=1,NBREG + IF(SURVOL(IVOL) .LT. -DCUTOF) THEN + WRITE(IOUT,9001) NAMSBR,IVOL + WRITE(IOUT,9002) (INDXSR(IR,IVOL),IR=1,5),SURVOL(IVOL) + CALL XABORT(NAMSBR// + > ': Region with negative volume detected') + ELSE IF(SURVOL(IVOL) .LT. DCUTOF) THEN + SURVOL(IVOL)=DZERO + ENDIF + 141 CONTINUE +*---- +* Print volumes if required +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6002) 'SurVol' + WRITE(IOUT,6005) (IVOL,(INDXSR(IR,IVOL),IR=1,5),SURVOL(IVOL), + > IVOL=-NBSUR,NBREG) + WRITE(IOUT,6003) + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6002 FORMAT(A12,'={') + 6003 FORMAT('};') + 6005 FORMAT((6(I10,','),F20.10,:,',')) + 6006 FORMAT(6(F20.10,:,',')) + 6007 FORMAT(A6,'=',I10,';') + 6017 FORMAT(A6,I4.4,'=',I10,';') + 6018 FORMAT(A6,I4.4,'=',F20.10,';') + 6019 FORMAT(A6,I4.4,'={',F20.10,',',F20.10,'};') +*---- +* Error and Warning formats +*---- + 9000 FORMAT('**** ERROR in -- ',A6,'-- found'/ + > ' Area of region ',I5,' is negative') + 9001 FORMAT('**** ERROR in -- ',A6,'-- found'/ + > ' Volume of region ',I5,' is negative') + 9002 FORMAT(5I10,F20.10) + END diff --git a/Dragon/src/NXTPCC.f b/Dragon/src/NXTPCC.f new file mode 100644 index 0000000..97194d0 --- /dev/null +++ b/Dragon/src/NXTPCC.f @@ -0,0 +1,609 @@ +*DECK NXTPCC + SUBROUTINE NXTPCC(IPRINT,NDIM ,IDIRC ,MXMESH,MAXSUR,MAXREG, + > MESH ,DMESH ,NPIN ,ITPIN ,DPIN , + > NBSUR ,NBREG ,INDXSR,SURVOL) +* +*---------- +* +*Purpose: +* Remove from the volumes or surfaces associated with +* a mixed Cartesian/annular 2-D or 3-D geometry the volumes +* or surfaces of the overlapping pins. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau. +* +*Parameters: input +* IPRINT print level. +* NDIM dimension of problem. +* IDIRC the direction of the first axis of a Cartesian geometry +* assuming the axis are in a cyclic rotation. +* MXMESH maximum number of spatial subdivision in +* $X$, $Y$ and $Z$. +* MAXSUR maximum number of surfaces in the geometry. +* MAXREG maximum number of regions in the geometry. +* MESH effective number of spatial subdivision in +* each direction ($X$, $Y$ and $Z$). +* DMESH spatial description of the Cartesian geometry. +* NPIN number of pins to superimpose on geometry. +* ITPIN type of pin. +* DPIN pin location and dimensions. +* NBSUR number of surfaces in the geometry. +* NBREG final number of non void regions in the geometry. +* +*Parameters: input/output +* INDXSR local indexing of regions. +* SURVOL volume of regions. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*Comments: +* 1- Meaning of IDIRC: +* IDIRC axes in 1-D axes in 2-D axes in 3-D +* 1 x (x,y) (x,y,z) +* 2 y (y,z) (y,z,x) +* 3 z (z,x) (z,x,y) +* 2- Contents of the DMESH array: +* mesh in $X$ is x(i)=DMESH(i,1) for i=0,MESH(1); +* mesh in $Y$ is y(j)=DMESH(j,2) for j=0,MESH(2); +* mesh in $Z$ is z(k)=DMESH(k,3) for k=0,MESH(3); +* 3- Contents of the DPIN array for pin IPIN: +* if(ITPIN(3,IPIN) = 1) then +* -> annular pin +* if(IDIRC = 1) then +* ->annular regions in the $X-Y$ plane +* centre (x,y,z)=(DPIN(0,IPIN)*COS(DPIN(-1,IPIN)) +* DPIN(0,IPIN)*SIN(DPIN(-1,IPIN)),0.0D0) +* outer pin radius r=DPIN(4,IPIN) +* pin height dz(iz)=DPIN(3,IPIN) +* else if(IDIRC = 2) then +* ->annular regions in the $Y-Z$ plane +* centre (y,z,x)=(DPIN(0,IPIN)*COS(DPIN(-1,IPIN)) +* DPIN(0,IPIN)*SIN(DPIN(-1,IPIN)),0.0D0) +* outer pin radius r=DPIN(4,IPIN) +* pin height dx(ix)=DPIN(1,IPIN) +* else if(IDIRC = 3) then +* ->annular regions in the $Z-X$ plane +* centre (z,x,y)=(DPIN(0,IPIN)*COS(DPIN(-1,IPIN)) +* DPIN(0,IPIN)*SIN(DPIN(-1,IPIN)),0.0D0) +* outer pin radius r=DPIN(4,IPIN) +* pin height dy(iy)=DPIN(2,IPIN) +* endif +* else if(ITPIN(3,IPIN) = 2) then +* -> Cartesian pin +* if(IDIRC = 1) then +* ->Cartesian region in the $X-Y$ plane +* centre (x,y,z)=(DPIN(0,IPIN)*COS(DPIN(-1,IPIN)) +* DPIN(0,IPIN)*SIN(DPIN(-1,IPIN)),0.0D0) +* pin width in $X$ dx=DPIN(1,IPIN) +* pin width in $Y$ dy=DPIN(2,IPIN) +* pin height dz(iz)=DPIN(3,IPIN) +* else if(IDIRC = 2) then +* ->Cartesian region in the $Y-Z$ plane +* centre (y,z,x)=(DPIN(0,IPIN)*COS(DPIN(-1,IPIN)) +* DPIN(0,IPIN)*SIN(DPIN(-1,IPIN)),0.0D0) +* pin width in $Y$ dy=DPIN(2,IPIN) +* pin width in $Z$ dz=DPIN(3,IPIN) +* pin height dx(ix)=DPIN(1,IPIN) +* else if(IDIRC = 3) then +* ->Cartesian region in the $Z-X$ plane +* centre (z,x,y)=(DPIN(0,IPIN)*COS(DPIN(-1,IPIN)) +* DPIN(0,IPIN)*SIN(DPIN(-1,IPIN)),0.0D0) +* pin width in $Z$ dz=DPIN(3,IPIN) +* pin width in $X$ dx=DPIN(1,IPIN) +* pin height dy(iy)=DPIN(2,IPIN) +* endif +* endif +* 4- Contents of the INDXSR array: +* For i>0 +* INDXSR(1,i)= ix is the $X$ location of region i +* INDXSR(2,i)= iy is the $Y$ location of region i +* INDXSR(3,i)= iz is the $Z$ location of region i +* INDXSR(4,i)= ir =0 is the $R$ location of region i. +* INDXSR(5,i)= not used. +* For i<0 +* INDXSR(1,i)= ix is the $X$ location of surface i +* INDXSR(2,i)= iy is the $Y$ location of surface i +* INDXSR(3,i)= iz is the $Z$ location of surface i +* INDXSR(4,i)= ir =0 is the $R$ location of surface i. +* INDXSR(5,i)= not used. +* with INDXSR(n,i)=-1 for surface associated with +* location 0 in direction n. +* with INDXSR(n,i)=-2 for surface associated with +* location MESH(n) in direction n. +* Note that for radial regions INDXSR(n,i)=-1 does not +* exists. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,NDIM,IDIRC,MXMESH,MAXSUR,MAXREG + INTEGER MESH(4) + DOUBLE PRECISION DMESH(-1:MXMESH,4) + INTEGER NPIN,ITPIN(3,NPIN) + DOUBLE PRECISION DPIN(-1:4,NPIN) + INTEGER NBSUR,NBREG,INDXSR(5,-MAXSUR:MAXREG) + DOUBLE PRECISION SURVOL(-MAXSUR:MAXREG) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTPCC') + INTEGER MAXDIM + PARAMETER (MAXDIM=4) + DOUBLE PRECISION DCUTOF + PARAMETER (DCUTOF=1.0D-8) + DOUBLE PRECISION DZERO,DONE,DTWO + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Functions +*---- + DOUBLE PRECISION XDRCST,PI + INTEGER NXTIAA,NXTIRA,NXTIRR,NXTPRR,NXTPRA + INTEGER ITYIRP,ITYIRA,ITYIRR,ITYRAP + DOUBLE PRECISION VOLIRP,VOLIRA,VOLRAP +*---- +* Local variables +*---- + INTEGER ID,IDG,IDIR(MAXDIM),NM(MAXDIM),IDM(MAXDIM), + > NANN,IDGP1,IDGP2,IDGPP,NSOZB,NSOZT,NRP1 + INTEGER IA,IX,IY,IZ,IPIN,ILOC,ISUR,IVOL + DOUBLE PRECISION ZB,ZT + DOUBLE PRECISION POSPIN(0:2),XYPIN(4),POSANN(0:2),XYCAR(4), + > XYCARP(4),POSCAR(2,4) + DOUBLE PRECISION VOLPIN,VOLIAO,VOLIAI + DOUBLE PRECISION PPPMIN,PPPMAX,PPRMIN,PPRMAX,DPP + INTEGER NFACES +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYIAP + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: VOLIAP +*---- +* Data +*---- + CHARACTER CDIR(MAXDIM)*1 + SAVE CDIR + DATA CDIR /'X','Y','Z','R'/ +*---- +* Prepare radial and axial loops +* as a function of IDIRC and NDIM. +*---- + ALLOCATE(ITYIAP(MXMESH),VOLIAP(MXMESH)) + IF(NDIM .LT. 2) CALL XABORT(NAMSBR// + >': Problem must be 2-D or 3-D') + NFACES=4 + NSOZB=0 + ITYIRP=0 + VOLPIN=DZERO + ZB=DZERO + ZT=DZERO + PI=XDRCST('Pi',' ') + DO ID=1,NDIM + IDG=MOD(IDIRC+ID-2,3)+1 + IDIR(ID)=IDG + NM(IDG)=MESH(IDG) + IDM(IDG)=1 + ENDDO + DO ID=NDIM+1,3 + IDG=MOD(IDIRC+ID-2,3)+1 + IDIR(ID)=IDG + NM(IDG)=1 + IDM(IDG)=0 + ENDDO + NANN=MESH(4) + IDGP1=IDIR(1) + IDGP2=IDIR(2) + IDGPP=IDIR(3) + IF(IDIRC .EQ. 1) THEN + NSOZB=2*NM(IDGPP)*(NM(IDGP1)+NM(IDGP2)) + ELSE IF(IDIRC .EQ. 2) THEN + NSOZB=0 + ELSE IF(IDIRC .EQ. 3) THEN + NSOZB=2*NM(IDGPP)*NM(IDGP1) + ENDIF + NRP1=NANN+1 + NSOZT=NSOZB+NM(IDGP1)*NM(IDGP2)*NRP1 + POSANN(1)=DMESH(-1,IDGP1) + POSANN(2)=DMESH(-1,IDGP2) +*---- +* Print mesh if required +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6002) 'CENTER'//CDIR(IDGP1)//CDIR(IDGP2) + WRITE(IOUT,6006) (DMESH(-1,IDIR(IA)),IA=1,2) + WRITE(IOUT,6003) + WRITE(IOUT,6002) 'RADIAL'//CDIR(IDGP1)//CDIR(IDGP2) + WRITE(IOUT,6006) (DMESH(IA,4),IA=1,NANN) + WRITE(IOUT,6003) + DO ID=1,NDIM + IDG=IDIR(ID) + WRITE(IOUT,6002) 'MESH'//CDIR(IDG) + WRITE(IOUT,6006) (DMESH(IA,IDG),IA=0,NM(IDG)) + WRITE(IOUT,6003) + ENDDO +*---- +* Pin description +*---- + DO IPIN=1,NPIN + WRITE(IOUT,6017) 'PinTyp',IPIN,ITPIN(3,IPIN) + IF(ITPIN(3,IPIN) .GE. 1) THEN + WRITE(IOUT,6019) 'PinC'//CDIR(IDGP1)//CDIR(IDGP2),IPIN, + > DPIN(0,IPIN)*COS(DPIN(-1,IPIN))+DMESH(-1,IDGP1), + > DPIN(0,IPIN)*SIN(DPIN(-1,IPIN))+DMESH(-1,IDGP2) + WRITE(IOUT,6018) 'PinRad',IPIN,DPIN(4,IPIN) + ELSE IF(ITPIN(3,IPIN) .LE. -1) THEN + WRITE(IOUT,6019) 'PinC'//CDIR(IDGP1)//CDIR(IDGP2),IPIN, + > DPIN(0,IPIN)*COS(DPIN(-1,IPIN))+DMESH(-1,IDGP1), + > DPIN(0,IPIN)*SIN(DPIN(-1,IPIN))+DMESH(-1,IDGP2) + WRITE(IOUT,6019) 'PinW'//CDIR(IDGP1)//CDIR(IDGP2),IPIN, + > DPIN(IDGP1,IPIN),DPIN(IDGP2,IPIN) + ENDIF + IF(NDIM .EQ. 3) THEN + WRITE(IOUT,6019) 'PinPo'//CDIR(IDGPP),IPIN, + > DMESH(-1,IDGPP)-DPIN(IDGPP,IPIN)/DTWO, + > DMESH(-1,IDGPP)+DPIN(IDGPP,IPIN)/DTWO + ENDIF + ENDDO + ENDIF +*---- +* Loop over pins +*---- + DO IPIN=1,NPIN +*---- +* for 3-D problem, +* Find pin bottom (ZB) and top (ZT) z location. +*---- + IF(NDIM .EQ. 3) THEN + ZB=DMESH(-1,IDGPP)-DPIN(IDGPP,IPIN)/DTWO + ZT=ZB+DPIN(IDGPP,IPIN) + ENDIF + IF(ITPIN(3,IPIN) .GE. 1) THEN +*---- +* Annular pin properties +*---- + POSPIN(0)=DPIN(4,IPIN) + POSPIN(1)=DPIN(0,IPIN)*COS(DPIN(-1,IPIN))+DMESH(-1,IDGP1) + POSPIN(2)=DPIN(0,IPIN)*SIN(DPIN(-1,IPIN))+DMESH(-1,IDGP2) + VOLPIN=PI*POSPIN(0)*POSPIN(0) + ELSE IF (ITPIN(3,IPIN) .LE. -1) THEN +*---- +* Rectangular pin properties +*---- + XYPIN(1)=DMESH(-1,IDGP1)-DPIN(IDGP1,IPIN)/DTWO + XYPIN(2)=DMESH(-1,IDGP1)+DPIN(IDGP1,IPIN)/DTWO + XYPIN(3)=DMESH(-1,IDGP2)-DPIN(IDGP2,IPIN)/DTWO + XYPIN(4)=DMESH(-1,IDGP2)+DPIN(IDGP2,IPIN)/DTWO + VOLPIN=DPIN(IDGP2,IPIN)*DPIN(IDGP1,IPIN) + ENDIF +*---- +* Determine pin-annular regions intersections +*---- + DO IA=1,NANN + POSANN(0)=DMESH(IA,4) + ITYIAP(IA)=0 + VOLIAP(IA)=0.0D0 + IF(ITPIN(3,IPIN) .GE. 1) THEN +*---- +* Find 2-D annular region/annular pin intersection +*---- + ITYIAP(IA)=NXTIAA(POSANN,POSPIN,VOLIAP(IA)) + ELSE IF (ITPIN(3,IPIN) .LE. -1) THEN +*---- +* Find 2-D annular region/rectangular pin intersection +*---- + ITYIAP(IA)=NXTIRA(XYPIN ,POSANN,VOLIAP(IA)) + ENDIF + ENDDO +*---- +* 1- Loop over second normal direction +*---- + DO IY=1,NM(IDGP2) + XYCAR(3)=DMESH(IY-1,IDGP2) + XYCAR(4)=DMESH(IY,IDGP2) + POSCAR(2,1)=XYCAR(3) + POSCAR(2,2)=XYCAR(3) + POSCAR(2,3)=XYCAR(4) + POSCAR(2,4)=XYCAR(4) +*---- +* 2- Loop over first normal direction +*---- + DO IX=1,NM(IDGP1) + XYCAR(1)=DMESH(IX-1,IDGP1) + XYCAR(2)=DMESH(IX,IDGP1) + POSCAR(1,1)=XYCAR(1) + POSCAR(1,2)=XYCAR(2) + POSCAR(1,3)=XYCAR(2) + POSCAR(1,4)=XYCAR(1) + IF(ITPIN(3,IPIN) .GE. 1) THEN +*---- +* Find rectangle/annular pin intersection +*---- + ITYIRP=NXTIRA(XYCAR ,POSPIN,VOLIRP) + ELSE IF (ITPIN(3,IPIN) .LE. -1) THEN +*---- +* Find rectangle/rectangular pin intersection +*---- + ITYIRP=NXTIRR(XYCAR ,XYPIN ,VOLIRP) + ENDIF + IF(ITYIRP .NE. 0) THEN + VOLIAO=DZERO + VOLIAI=DZERO + DO IA=1,NANN + POSANN(0)=DMESH(IA,4) + VOLIAI=VOLIAO + IF(ITYIAP(IA) .NE. 0) THEN + ITYIRA=NXTIRA(XYCAR ,POSANN,VOLIRA) +*---- +* See file PRA.xls for analysis of 3 regions intersection +*---- + IF(ITYIRA .EQ. -1) THEN +*---- +* Partial Cartesian/annular region intersection +* Examine Rectangle/pin intersection +* Note: ITYIRP=0 already considered above +*---- + IF(ITYIRP .EQ. -1) THEN +*---- +* Partial Cartesian/pin intersection +* Examine Annular/pin intersection +* Note: ITYIAP=0 already considered above +*---- + IF(ITYIAP(IA) .EQ. -1) THEN +*---- +* Partial Annular/pin intersection +* Find intersection volume of three regions +*---- + IF(ITPIN(3,IPIN) .GE. 1) THEN +*---- +* Find rectangle/annular region/annular pin intersection +*---- + ITYRAP=NXTPRA(NFACES,POSCAR, + > POSANN,POSPIN,VOLRAP) + ELSE IF (ITPIN(3,IPIN) .LE. -1) THEN +*---- +* Find rectangle for intersection of rectangle with rectangular pin +*---- + ITYIRR=NXTPRR(XYCAR,XYPIN,XYCARP) +*---- +* Find intersection rectangle/annular region intersection +*---- + ITYRAP=NXTIRA(XYCARP,POSANN,VOLRAP) + ENDIF + VOLIAO=VOLRAP + VOLIAI=VOLIAO-VOLIAI + ELSE IF(ITYIAP(IA) .EQ. 1) THEN +*---- +* Annular region in pin +* Volume is given by Rectangle/annular intersection +*---- + VOLIAO=VOLIRA + VOLIAI=VOLIAO-VOLIAI + ELSE IF(ITYIAP(IA) .EQ. 2) THEN +*---- +* Annular region contains pin +* Volume is given by Annular/pin intersection +*---- + VOLIAO=VOLIRP + VOLIAI=VOLIAO-VOLIAI + ENDIF + ELSE IF(ITYIRP .EQ. 1) THEN +*---- +* Cartesian region in pin +* Volume is given by Rectangle/annular intersection +*---- + VOLIAO=VOLIRA + VOLIAI=VOLIAO-VOLIAI + ELSE IF(ITYIRP .EQ. 2) THEN +*---- +* Cartesian region contains pin +* Volume is given by Annular/pin intersection +*---- + VOLIAO=VOLIAP(IA) + VOLIAI=VOLIAO-VOLIAI + ENDIF + ELSE IF(ITYIRA .EQ. 0) THEN +*---- +* No Cartesian/annular region intersection +* go to next annular region. +*---- + GO TO 125 + ELSE IF(ITYIRA .EQ. 1) THEN +*---- +* Cartesian region in annular region +* Volume is given by Rectangle/pin intersection +*---- + VOLIAO=VOLIRP + VOLIAI=VOLIAO-VOLIAI + ELSE IF(ITYIRA .EQ. 2) THEN +*---- +* Cartesian region contains annular region +* Volume is given by Annular/pin intersection +*---- + VOLIAO=VOLIAP(IA) + VOLIAI=VOLIAO-VOLIAI + ENDIF + ENDIF + 125 CONTINUE +*---- +* Use DELV to correct volumes and surface area for +* regions inside a rectangle and an annular ring +*---- + IF(NDIM .EQ. 3) THEN + ILOC=IA+NRP1*(IX-1+NM(IDGP1)*(IY-1)) + IF(ZB .LE. DMESH(0,IDGPP) .AND. + > ZT .GE. DMESH(0,IDGPP)) THEN +*---- +* Remove area contribution from bottom surface +*---- + ISUR=NSOZB+ILOC + SURVOL(-ISUR)=SURVOL(-ISUR)-VOLIAI + ENDIF + IF(ZB .LE. DMESH(NM(IDGPP),IDGPP) .AND. + > ZT .GE. DMESH(NM(IDGPP),IDGPP)) THEN +*---- +* Remove area contribution from top surface +*---- + ISUR=NSOZT+ILOC + SURVOL(-ISUR)=SURVOL(-ISUR)-VOLIAI + ENDIF + PPPMIN=ZB + PPPMAX=PPPMIN+DPIN(IDGPP,IPIN) + DO IZ=1,NM(IDGPP) + PPRMIN=MAX(DMESH(IZ-1,IDGPP),PPPMIN) + PPRMAX=MIN(DMESH(IZ,IDGPP),PPPMAX) + IF(PPRMIN .LT. PPRMAX) THEN + DPP=VOLIAI*(PPRMAX-PPRMIN) + IF(IDIRC .EQ. 1) THEN + IVOL=IA+NRP1*(IX-1 + > +NM(IDGP1)*(IY-1+(IZ-1)*NM(IDGP2))) + ELSE IF(IDIRC .EQ. 2) THEN + IVOL=IA+NRP1*(IZ-1 + > +NM(IDGPP)*(IX-1+(IY-1)*NM(IDGP1))) + ELSE + IVOL=IA+NRP1*(IY-1 + > +NM(IDGP2)*(IZ-1+(IX-1)*NM(IDGPP))) + ENDIF + SURVOL(IVOL)=SURVOL(IVOL)-DPP + ENDIF + ENDDO + ELSE + IVOL=IA+NRP1*(IX-1+NM(IDGP1)*(IY-1)) + SURVOL(IVOL)=SURVOL(IVOL)-VOLIAI + ENDIF +*---- +* If pin all extracted, go to next pin +*---- + IF(VOLPIN .EQ. VOLIAO) GO TO 115 + ENDDO +*---- +* Use DELV to correct volumes and surface area for +* regions inside a rectangle but outside annular ring +*---- + VOLIAI=VOLIAO + VOLIAO=VOLIRP + VOLIAI=VOLIAO-VOLIAI + IA=NRP1 + IF(NDIM .EQ. 3) THEN +* IF(IDIRC .EQ. 3) THEN +* ILOC=IA+NRP1*(IY-1+NM(IDGP2)*(IX-1)) +* ELSE + ILOC=IA+NRP1*(IX-1+NM(IDGP1)*(IY-1)) +* ENDIF + IF(ZB .LE. DMESH(0,IDGPP) .AND. + > ZT .GE. DMESH(0,IDGPP)) THEN +*---- +* Remove area contribution from bottom surface +*---- + ISUR=NSOZB+ILOC + SURVOL(-ISUR)=SURVOL(-ISUR)-VOLIAI + ENDIF + IF(ZB .LE. DMESH(NM(IDGPP),IDGPP) .AND. + > ZT .GE. DMESH(NM(IDGPP),IDGPP)) THEN +*---- +* Remove area contribution from top surface +*---- + ISUR=NSOZT+ILOC + SURVOL(-ISUR)=SURVOL(-ISUR)-VOLIAI + ENDIF + PPPMIN=ZB + PPPMAX=PPPMIN+DPIN(IDGPP,IPIN) + DO IZ=1,NM(IDGPP) + PPRMIN=MAX(DMESH(IZ-1,IDGPP),PPPMIN) + PPRMAX=MIN(DMESH(IZ,IDGPP),PPPMAX) + IF(PPRMIN .LT. PPRMAX) THEN + DPP=VOLIAI*(PPRMAX-PPRMIN) + IF(IDIRC .EQ. 1) THEN + IVOL=IA+NRP1*(IX-1 + > +NM(IDGP1)*(IY-1+(IZ-1)*NM(IDGP2))) + ELSE IF(IDIRC .EQ. 2) THEN + IVOL=IA+NRP1*(IZ-1 + > +NM(IDGPP)*(IX-1+(IY-1)*NM(IDGP1))) + ELSE + IVOL=IA+NRP1*(IY-1 + > +NM(IDGP2)*(IZ-1+(IX-1)*NM(IDGPP))) + ENDIF + SURVOL(IVOL)=SURVOL(IVOL)-DPP + ENDIF + ENDDO + ELSE + IVOL=IA+NRP1*(IX-1+NM(IDGP1)*(IY-1)) + SURVOL(IVOL)=SURVOL(IVOL)-VOLIAI + ENDIF + ENDIF + ENDDO + ENDDO + 115 CONTINUE + ENDDO +*---- +* Test for negative surface area and volumes +*---- + DO ISUR=1,NBSUR + IF(SURVOL(-ISUR) .LT. -DCUTOF) THEN + WRITE(IOUT,9000) NAMSBR,-ISUR + WRITE(IOUT,9002) (INDXSR(IA,-ISUR),IA=1,5),SURVOL(-ISUR) + CALL XABORT(NAMSBR// + > ': Region with negative surface area detected') + ELSE IF(SURVOL(-ISUR) .LT. DCUTOF) THEN + SURVOL(-ISUR)=DZERO + ENDIF + ENDDO + DO IVOL=1,NBREG + IF(SURVOL(IVOL) .LT. -DCUTOF) THEN + WRITE(IOUT,9001) NAMSBR,IVOL + WRITE(IOUT,9002) (INDXSR(IA,IVOL),IA=1,5),SURVOL(IVOL) + CALL XABORT(NAMSBR// + > ': Region with negative volume detected') + ELSE IF(SURVOL(IVOL) .LT. DCUTOF) THEN + SURVOL(IVOL)=DZERO + ENDIF + ENDDO +*---- +* Print volumes if required +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6002) 'SurVol' + WRITE(IOUT,6005) (IVOL,(INDXSR(IA,IVOL),IA=1,5),SURVOL(IVOL), + > IVOL=-NBSUR,NBREG) + WRITE(IOUT,6003) + WRITE(IOUT,6001) NAMSBR + ENDIF + DEALLOCATE(VOLIAP,ITYIAP) + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6002 FORMAT(A12,'={') + 6003 FORMAT('};') + 6005 FORMAT((6(I10,','),F20.10,:,',')) + 6006 FORMAT(6(F20.10,:,',')) + 6017 FORMAT(A6,I4.4,'=',I10,';') + 6018 FORMAT(A6,I4.4,'=',F20.10,';') + 6019 FORMAT(A6,I4.4,'={',F20.10,',',F20.10,'};') +*---- +* Error and Warning formats +*---- + 9000 FORMAT('**** ERROR in -- ',A6,'-- found'/ + > ' Area of region ',I5,' is negative') + 9001 FORMAT('**** ERROR in -- ',A6,'-- found'/ + > ' Volume of region ',I5,' is negative') + 9002 FORMAT(5I10,F20.10) + END diff --git a/Dragon/src/NXTPHC.f b/Dragon/src/NXTPHC.f new file mode 100644 index 0000000..5840756 --- /dev/null +++ b/Dragon/src/NXTPHC.f @@ -0,0 +1,484 @@ +*DECK NXTPHC + SUBROUTINE NXTPHC(IPRINT,NDIM ,MXMESH,MAXSUR,MAXREG, + > MESH ,DAMESH,NPIN ,ITPIN ,DPIN , + > NBSUR ,NBREG ,INDXSR,SURVOL,POSTRI) +* +*---------- +* +*Purpose: +* Remove from the volumes or surfaces +* associated with an annular/hexagonal 2-D or 3-D geometry +* the volumes or surfaces of the overlapping pins. +* +*Copyright: +* Copyright (C) 2010 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau. +* +*Parameters: input +* IPRINT print level. +* NDIM dimension of problem. +* MXMESH maximum number of spatial subdivision in +* $X$, $Y$ and $Z$. +* MAXSUR maximum number of surfaces in the geometry. +* MAXREG maximum number of regions in the geometry. +* MESH effective number of spatial subdivision in +* each direction ($X$, $Y$ and $Z$). +* DAMESH spatial description of the Cartesian geometry. +* NPIN number of pins to superimpose on geometry. +* ITPIN type of pin. +* DPIN pin location and dimensions. +* NBSUR number of surfaces in the geometry. +* NBREG final number of non void regions in the geometry. +* POSTRI triangle position: +* POSTRI(1,*,*,*) is X position; +* POSTRI(2,*,*,*) is Y position; +* POSTRI(*,1,*,*) is location of first corner; +* POSTRI(*,2,*,*) is location of second corner; +* POSTRI(*,3,*,*) is location of third corner; +* POSTRI(*,*,i,j) is location of triangle i in cector j. +* +*Parameters: input/output +* INDXSR local indexing of regions. +* SURVOL volume of regions. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*Comments: +* 1- Contents of the DAMESH array: +* hexagonal mesh is DAMESH(i,1) for i=0,MESH(1); +* mesh in $Z$ is z(k)=DAMESH(k,3) for k=0,MESH(3); +* 2- Contents of the DPIN array for pin IPIN: +* -> annular pin +* ->annular regions in the $X-Y$ plane +* centre (x,y,z)=(DPIN(0,IPIN)*COS(DPIN(-1,IPIN)) +* DPIN(0,IPIN)*SIN(DPIN(-1,IPIN)),0.0D0) +* outer pin radius r=DPIN(4,IPIN) +* pin height dz(iz)=DPIN(3,IPIN) +* 3- Contents of the INDXSR array: +* For i>0 +* INDXSR(1,i)= iu is the $U$ location of region i +* INDXSR(2,i)= iv is the $V$ location of region i +* INDXSR(3,i)= iz is the $Z$ location of region i +* INDXSR(4,i)= ir is the $R$ location of region i +* INDXSR(5,i)= iw is the $W$ location of region i +* For i<0 +* INDXSR(1,i)= iu is the $U$ location of surface i +* INDXSR(2,i)= iv is the $V$ location of surface i +* INDXSR(3,i)= iz is the $Z$ location of surface i +* INDXSR(4,i)= ir is the $R$ location of surface i +* INDXSR(5,i)= iw is the $W$ location of surface i +* with INDXSR(n,i)=-1 for surface associated with +* location 0 in direction n. +* with INDXSR(n,i)=-2 for surface associated with +* location MESH(n) in direction n. +* Note that for radial regions INDXSR(n,i)=-1 does not exists. +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,NDIM,MXMESH,MAXSUR,MAXREG + INTEGER MESH(4) + DOUBLE PRECISION DAMESH(-1:MXMESH,4) + INTEGER NPIN,ITPIN(3,NPIN) + DOUBLE PRECISION DPIN(-1:4,NPIN) + INTEGER NBSUR,NBREG,INDXSR(5,-MAXSUR:MAXREG) + DOUBLE PRECISION SURVOL(-MAXSUR:MAXREG) + DOUBLE PRECISION POSTRI(2,3,MXMESH*MXMESH,6) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTPHC') + INTEGER MAXDIM + PARAMETER (MAXDIM=4) + DOUBLE PRECISION DCUTOF + PARAMETER (DCUTOF=1.0D-8) + DOUBLE PRECISION DZERO,DONE,DTWO,DHALF,DSQ3O2 + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0, + > DHALF=0.5D0,DSQ3O2=0.86602540378444D0) +*---- +* Functions +*---- + DOUBLE PRECISION XDRCST,PI + INTEGER NXTIAA,NXTITA,NXTPRA + INTEGER ITYITP,ITYITA,ITYTAP + DOUBLE PRECISION VOLITP,VOLITA,VOLTAP +*---- +* Local variables +*---- + INTEGER NX,NZ,NANN,NRTP,NRP,NSTP,NSP,NRP1,NRTPP,NRTPS, + > ISBOT,ISTOP,IX,IZ,IR,ISECT,IPIN,ISUR,IVOL,ILOCT + DOUBLE PRECISION ZB,ZT,PPRMIN,PPRMAX,PPPMIN,PPPMAX,DPP + DOUBLE PRECISION VOLPIN,VOLIAO,VOLIAI + DOUBLE PRECISION POSPIN(0:2),POSANN(0:2) + INTEGER NFACES + INTEGER IA +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYIAP + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: VOLIAP +*---- +* Get dimensioning information +*---- + ALLOCATE(ITYIAP(MXMESH),VOLIAP(MXMESH)) + NFACES=3 + PI=XDRCST('Pi',' ') + NX=MESH(1) + NZ=MESH(3) + NANN=MESH(4) + NRTP=NX**2 + NRP=6*NRTP + NSTP=2*NX-1 + NSP=6*NSTP + NRP1=NANN+1 + NRTPP=NRP*NRP1 + NRTPS=NRTP*NRP1 + ZB=0.0D0 + ZT=0.0D0 + IF(NDIM .EQ. 3) THEN + ISBOT=-NSP*NZ + ISTOP=ISBOT-NRTPP + ELSE + ISBOT=0 + ISTOP=0 + ENDIF + POSANN(1)=0.0D0 + POSANN(2)=0.0D0 +*---- +* Print mesh if required +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6010) 'H',NX + WRITE(IOUT,6011) 'MESHH =' + WRITE(IOUT,6012) (DAMESH(IX,1),IX=-1,2*NX) + IF(NZ .GT. 0) THEN + WRITE(IOUT,6010) 'Z',NZ + WRITE(IOUT,6011) 'MESHZ =' + WRITE(IOUT,6012) (DAMESH(IZ,3),IZ=-1,NZ) + ENDIF + WRITE(IOUT,6010) 'R',NANN + WRITE(IOUT,6011) 'MESHR =' + WRITE(IOUT,6012) (DAMESH(IR,4),IR=-1,NANN) +*---- +* Pin description +*---- + DO IPIN=1,NPIN + WRITE(IOUT,6017) 'PinTyp',IPIN,ITPIN(3,IPIN) + IF(ITPIN(3,IPIN) .EQ. 3) THEN + WRITE(IOUT,6019) 'PinCXY',IPIN, + > DPIN(0,IPIN)*COS(DPIN(-1,IPIN)), + > DPIN(0,IPIN)*SIN(DPIN(-1,IPIN)) + WRITE(IOUT,6018) 'PinRad',IPIN,DPIN(4,IPIN) + ENDIF + IF(NDIM .EQ. 3) THEN + WRITE(IOUT,6019) 'PinPoZ',IPIN, + > DAMESH(-1,3)-DPIN(3,IPIN)/DTWO, + > DAMESH(-1,3)+DPIN(3,IPIN)/DTWO + ENDIF + ENDDO + ENDIF +*---- +* Loop over pins +*---- + DO IPIN=1,NPIN +*---- +* For 3-D problem, +* Find pin bottom (ZB) and top (ZT) z location. +*---- + IF(NDIM .EQ. 3) THEN + ZB=DAMESH(-1,3)-DPIN(3,IPIN)/DTWO + ZT=ZB+DPIN(3,IPIN) + ENDIF +*---- +* Annular pin properties +*---- + POSPIN(0)=DPIN(4,IPIN) + POSPIN(1)=DPIN(0,IPIN)*COS(DPIN(-1,IPIN)) + POSPIN(2)=DPIN(0,IPIN)*SIN(DPIN(-1,IPIN)) + VOLPIN=PI*POSPIN(0)*POSPIN(0) +*---- +* Determine pin-annular regions intersections +*---- + DO IA=1,NANN + POSANN(0)=DAMESH(IA,4) + ITYIAP(IA)=0 + VOLIAP(IA)=0.0D0 +*---- +* Find 2-D annular region/annular pin intersection +*---- + ITYIAP(IA)=NXTIAA(POSANN,POSPIN,VOLIAP(IA)) + ENDDO +* IF(NANN .GE. 0) THEN +* WRITE(IOUT,*) 'Pin-Annular intersection for pin =',IPIN +* WRITE(IOUT,'(2I10,F20.10)') +* > (IA,ITYIAP(IA),VOLIAP(IA),IA=1,NANN) +* ENDIF +*---- +* 1- Loop over sectors +*---- + DO ISECT=1,6 +*---- +* Loop over region in sector +*---- + DO IR=1,NRTP + ITYITP=NXTITA(POSTRI(1,1,IR,ISECT),POSPIN,VOLITP) +* WRITE(IOUT,'(A25,3I10,F20.10)') 'Pin-Triangle intersection', +* > ISECT,IR,ITYITP,VOLITP + ILOCT=(ISECT-1)*NRTPS+(IR-1)*NRP1 + IF(ITYITP .NE. 0) THEN + VOLIAO=DZERO + VOLIAI=DZERO + DO IA=1,NANN +* IF(IPRINT .GE. 100) THEN +* WRITE(IOUT,6022) IPIN,ISECT,IR,IA,ITYIAP(IA) +* ENDIF + POSANN(0)=DAMESH(IA,4) + VOLIAI=VOLIAO + IF(ITYIAP(IA) .NE. 0) THEN + ITYITA=NXTITA(POSTRI(1,1,IR,ISECT),POSANN,VOLITA) +* WRITE(IOUT,*) 'NXTITA ',ITYITA,VOLITA + IF(ITYITA .EQ. -1) THEN +*---- +* Partial Cartesian/annular region intersection +* Examine Rectangle/pin intersection +* Note: ITYITA=0 already considered above +*---- + IF(ITYITP .EQ. -1) THEN +*---- +* Partial Cartesian/pin intersection +* Examine Annular/pin intersection +* Note: ITYIAP=0 already considered above +*---- + IF(ITYIAP(IA) .EQ. -1) THEN +*---- +* Partial Annular/pin intersection +* Find intersection volume of three regions +*---- + ITYTAP=NXTPRA(NFACES,POSTRI(1,1,IR,ISECT), + > POSANN,POSPIN,VOLTAP) + VOLIAO=VOLTAP + VOLIAI=VOLIAO-VOLIAI + ELSE IF(ITYIAP(IA) .EQ. 1) THEN +*---- +* Annular region in pin +* Volume is given by Rectangle/annular intersection +*---- + VOLIAO=VOLITA + VOLIAI=VOLIAO-VOLIAI + ELSE IF(ITYIAP(IA) .EQ. 2) THEN +*---- +* Annular region contains pin +* Volume is given by Annular/pin intersection +*---- + VOLIAO=VOLITP + VOLIAI=VOLIAO-VOLIAI + ENDIF + ELSE IF(ITYITP .EQ. 1) THEN +*---- +* Cartesian region in pin +* Volume is given by Rectangle/annular intersection +*---- + VOLIAO=VOLITA + VOLIAI=VOLIAO-VOLIAI + ELSE IF(ITYITP .EQ. 2) THEN +*---- +* Cartesian region contains pin +* Volume is given by Annular/pin intersection +*---- + VOLIAO=VOLIAP(IA) + VOLIAI=VOLIAO-VOLIAI + ENDIF + ELSE IF(ITYITA .EQ. 0) THEN +*---- +* No Cartesian/annular region intersection +* go to next annular region. +*---- + GO TO 125 + ELSE IF(ITYITA .EQ. 1) THEN +*---- +* Cartesian region in annular region +* Volume is given by Rectangle/pin intersection +*---- + VOLIAO=VOLITP + VOLIAI=VOLIAO-VOLIAI + ELSE IF(ITYITA .EQ. 2) THEN +*---- +* Cartesian region contains annular region +* Volume is given by Annular/pin intersection +*---- + VOLIAO=VOLIAP(IA) + VOLIAI=VOLIAO-VOLIAI + ENDIF + ENDIF + 125 CONTINUE +*---- +* There is an intersection possible between the pin and +* the triangle. +* 1- Look for botton and top surface in 3-D +*---- +* IF(IPRINT .GE. 100) THEN +* WRITE(IOUT,6023) VOLIAI,VOLIAO +* ENDIF + IF(NDIM .EQ. 3) THEN + IF(ZB .LE. DAMESH(0,3) .AND. + > ZT .GE. DAMESH(0,3)) THEN +*---- +* Remove area contribution from bottom surface +*---- + ISUR=ISBOT-ILOCT-IA + SURVOL(ISUR)=SURVOL(ISUR)-VOLIAI + ENDIF + IF(ZB .LE. DAMESH(MESH(3),3) .AND. + > ZT .GE. DAMESH(MESH(3),3)) THEN +*---- +* Remove area contribution from top surface +*---- + ISUR=ISTOP-ILOCT-IA + SURVOL(ISUR)=SURVOL(ISUR)-VOLIAI + ENDIF + PPPMIN=ZB + PPPMAX=PPPMIN+DPIN(3,IPIN) + DO IZ=1,MESH(3) + PPRMIN=MAX(DAMESH(IZ-1,3),PPPMIN) + PPRMAX=MIN(DAMESH(IZ,3),PPPMAX) + IF(PPRMIN .LT. PPRMAX) THEN + DPP=VOLIAI*(PPRMAX-PPRMIN) + IVOL=(IZ-1)*NRTPP+ILOCT+IA + SURVOL(IVOL)=SURVOL(IVOL)-DPP + ENDIF + ENDDO + ELSE +* WRITE(IOUT,'(A12,4I10,3F20.10)') 'Volume id', +* >ISECT,IR,IA,ILOCT+IA,SURVOL(IVOL),VOLIAI, +* >SURVOL(IVOL)-VOLIAI + IVOL=ILOCT+IA + SURVOL(IVOL)=SURVOL(IVOL)-VOLIAI + ENDIF +*---- +* If pin all extracted, go to next pin +*---- + IF(VOLPIN .EQ. VOLIAO) GO TO 115 +* IF(VOLPIN .LE. DZERO) GO TO 115 + ENDDO +*---- +* Use DELV to correct volumes and surface area for +* regions inside a rectangle but outside annular ring +*---- +* write(6,*) VOLIAI,VOLIAO,VOLITP,VOLITP-VOLIAI + VOLIAI=VOLIAO + VOLIAO=VOLITP + VOLIAI=VOLIAO-VOLIAI + IA=NRP1 + IF(NDIM .EQ. 3) THEN + IF(ZB .LE. DAMESH(0,3) .AND. + > ZT .GE. DAMESH(0,3)) THEN +*---- +* Remove area contribution from bottom surface +*---- + ISUR=ISBOT-ILOCT-IA + SURVOL(ISUR)=SURVOL(ISUR)-VOLIAI + ENDIF + IF(ZB .LE. DAMESH(NZ,3) .AND. + > ZT .GE. DAMESH(NZ,3)) THEN +*---- +* Remove area contribution from top surface +*---- + ISUR=ISTOP-ILOCT-IA + SURVOL(ISUR)=SURVOL(ISUR)-VOLIAI + ENDIF + PPPMIN=ZB + PPPMAX=PPPMIN+DPIN(3,IPIN) + DO IZ=1,NZ + PPRMIN=MAX(DAMESH(IZ-1,3),PPPMIN) + PPRMAX=MIN(DAMESH(IZ,3),PPPMAX) + IF(PPRMIN .LT. PPRMAX) THEN + DPP=VOLIAI*(PPRMAX-PPRMIN) + IVOL=(IZ-1)*NRTPP+ILOCT+IA + SURVOL(IVOL)=SURVOL(IVOL)-DPP + ENDIF + ENDDO + ELSE + IVOL=ILOCT+IA + SURVOL(IVOL)=SURVOL(IVOL)-VOLIAI + ENDIF + ENDIF + ENDDO + ENDDO + 115 CONTINUE + ENDDO +*---- +* Test for negative surface area and volumes +*---- + DO ISUR=1,NBSUR + IF(SURVOL(-ISUR) .LT. -DCUTOF) THEN + WRITE(IOUT,9000) NAMSBR,-ISUR + WRITE(IOUT,9002) (INDXSR(IR,-ISUR),IR=1,5),SURVOL(-ISUR) + CALL XABORT(NAMSBR// + > ': Region with negative surface area detected') + ELSE IF(SURVOL(-ISUR) .LT. DCUTOF) THEN + SURVOL(-ISUR)=DZERO + ENDIF + ENDDO + DO IVOL=1,NBREG + IF(SURVOL(IVOL) .LT. -DCUTOF) THEN + WRITE(IOUT,9001) NAMSBR,IVOL + WRITE(IOUT,9002) (INDXSR(IR,IVOL),IR=1,5),SURVOL(IVOL) + CALL XABORT(NAMSBR// + > ': Region with negative volume detected') + ELSE IF(SURVOL(IVOL) .LT. DCUTOF) THEN + SURVOL(IVOL)=DZERO + ENDIF + ENDDO +*---- +* Print volumes if required +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6002) 'SurVol' + WRITE(IOUT,6005) (IVOL,(INDXSR(IR,IVOL),IR=1,5),SURVOL(IVOL), + > IVOL=-NBSUR,NBREG) + WRITE(IOUT,6003) + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6002 FORMAT(A12,'={') + 6003 FORMAT('};') + 6005 FORMAT((6(I10,','),F20.10,:,',')) + 6010 FORMAT(1X,'MESH DIMENSIONS IN ',A1,' =',I10) + 6011 FORMAT(1X,A7) + 6012 FORMAT(5F20.10) + 6017 FORMAT(A6,I4.4,'=',I10,';') + 6018 FORMAT(A6,I4.4,'=',F20.10,';') + 6019 FORMAT(A6,I4.4,'={',F20.10,',',F20.10,'};') +* 6022 FORMAT('Pin =',I10,' Sector = ',I10,' Region = ',I10, +* > ' Annulus =',I10,' Intersection type',I10) +* 6023 FORMAT(20X,' Volume of intersection= ',F20.10, +* > ' Volume remaining= ',F20.10) +*---- +* Error and Warning formats +*---- + 9000 FORMAT('**** ERROR in -- ',A6,'-- found'/ + > ' Area of region ',I5,' is negative') + 9001 FORMAT('**** ERROR in -- ',A6,'-- found'/ + > ' Volume of region ',I5,' is negative') + 9002 FORMAT(5I10,F20.10) + END diff --git a/Dragon/src/NXTPHT.f b/Dragon/src/NXTPHT.f new file mode 100644 index 0000000..fea6ac9 --- /dev/null +++ b/Dragon/src/NXTPHT.f @@ -0,0 +1,326 @@ +*DECK NXTPHT + SUBROUTINE NXTPHT(IPRINT,NDIM ,IDIRC ,MXMESH,MAXSUR,MAXREG, + > MESH ,DAMESH,NPIN ,ITPIN ,DPIN , + > NBSUR ,NBREG ,INDXSR,SURVOL,POSTRI) +* +*---------- +* +*Purpose: +* Remove from the volumes or surfaces +* associated with a hexagonal 2-D or 3-D geometry +* the volumes or surfaces of the overlapping pins. +* +*Copyright: +* Copyright (C) 2010 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau. +* +*Parameters: input +* IPRINT print level. +* NDIM dimension of problem. +* IDIRC the direction of the first axis of a Cartesian geometry +* assuming the axis are in a cyclic rotation. +* MXMESH maximum number of spatial subdivision in +* $X$, $Y$ and $Z$. +* MAXSUR maximum number of surfaces in the geometry. +* MAXREG maximum number of regions in the geometry. +* MESH effective number of spatial subdivision in +* each direction ($X$, $Y$ and $Z$). +* DAMESH spatial description of the Cartesian geometry. +* NPIN number of pins to superimpose on geometry. +* ITPIN type of pin. +* DPIN pin location and dimensions. +* NBSUR number of surfaces in the geometry. +* NBREG final number of non void regions in the geometry. +* POSTRI triangle position: +* POSTRI(1,*,*,*) is X position; +* POSTRI(2,*,*,*) is Y position; +* POSTRI(*,1,*,*) is location of first corner; +* POSTRI(*,2,*,*) is location of second corner; +* POSTRI(*,3,*,*) is location of third corner; +* POSTRI(*,*,i,j) is location of triangle i in cector j. +* +*Parameters: input/output +* INDXSR local indexing of regions. +* SURVOL volume of regions. +* +*Comments: +* 1- Contents of IDIRC: +* IDIRC axes in 1-D axes in 2-D axes in 3-D +* 1 x (x,y) (x,y,z) +* 2 y (y,z) (y,z,x) +* 3 z (z,x) (z,x,y) +* 2- Contents of the DAMESH array: +* hexagonal mesh is DAMESH(i,1) for i=0,MESH(1); +* mesh in $Z$ is z(k)=DAMESH(k,3) for k=0,MESH(3); +* 3- Contents of the DPIN array for pin IPIN: +* -> annular pin +* ->annular regions in the $X-Y$ plane +* centre (x,y,z)=(DPIN(0,IPIN)*COS(DPIN(-1,IPIN)) +* DPIN(0,IPIN)*SIN(DPIN(-1,IPIN)),0.0D0) +* outer pin radius r=DPIN(4,IPIN) +* pin height dz(iz)=DPIN(3,IPIN) +* 4- Contents of the INDXSR array: +* For i>0 +* INDXSR(1,i)= iu is the $U$ location of region i +* INDXSR(2,i)= iv is the $V$ location of region i +* INDXSR(3,i)= iz is the $Z$ location of region i +* INDXSR(4,i)= ir is the $R$ location of region i +* INDXSR(5,i)= iw is the $W$ location of region i +* For i<0 +* INDXSR(1,i)= iu is the $U$ location of surface i +* INDXSR(2,i)= iv is the $V$ location of surface i +* INDXSR(3,i)= iz is the $Z$ location of surface i +* INDXSR(4,i)= ir is the $R$ location of surface i +* INDXSR(5,i)= iw is the $W$ location of surface i +* with INDXSR(n,i)=-1 for surface associated with +* location 0 in direction n. +* with INDXSR(n,i)=-2 for surface associated with +* location MESH(n) in direction n. +* Note that for radial regions INDXSR(n,i)=-1 does not +* exists. +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,NDIM,IDIRC,MXMESH,MAXSUR,MAXREG + INTEGER MESH(4) + DOUBLE PRECISION DAMESH(-1:MXMESH,4) + INTEGER NPIN,ITPIN(3,NPIN) + DOUBLE PRECISION DPIN(-1:4,NPIN) + INTEGER NBSUR,NBREG,INDXSR(5,-MAXSUR:MAXREG) + DOUBLE PRECISION SURVOL(-MAXSUR:MAXREG) + DOUBLE PRECISION POSTRI(2,3,MXMESH*MXMESH,6) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTPHT') + INTEGER MAXDIM + PARAMETER (MAXDIM=4) + DOUBLE PRECISION DCUTOF + PARAMETER (DCUTOF=1.0D-8) + DOUBLE PRECISION DZERO,DTWO + PARAMETER (DZERO=0.0D0,DTWO=2.0D0) +*---- +* Functions +*---- + DOUBLE PRECISION XDRCST,PI + INTEGER NXTITA + INTEGER ITYITA + DOUBLE PRECISION VOLINT +*---- +* Local variables +*---- + INTEGER NX,NZ,NRTP,NRP,NSTP,NSP,ISBOT,ISTOP,NRTPP,NRTPS, + > NRP1,IZ,IR,ISECT,IPIN,ISUR,IVOL + DOUBLE PRECISION ZB,ZT,VOLPIN,PPRMIN,PPRMAX,PPPMIN,PPPMAX,DPP + DOUBLE PRECISION POSPIN(0:2) +*---- +* Prepare loops over spatial directions as a function +* of IDIRC and NDIM. +*---- + PI=XDRCST('Pi',' ') + NX=MESH(1) + NZ=MESH(3) + NRTP=NX**2 + NRP=6*NRTP + NSTP=2*NX-1 + NSP=6*NSTP + NRP1=1 + NRTPP=NRP*NRP1 + NRTPS=NRTP*NRP1 + ZB=0.0D0 + ZT=0.0D0 + IF(NZ .EQ. 0) THEN + ISBOT=0 + ISTOP=0 + ELSE + ISBOT=-NSP*NZ + ISTOP=ISBOT-NRP + ENDIF +* write(6,*) 'MXMESH,MAXSUR,MAXREG',MXMESH,MAXSUR,MAXREG +*---- +* Print mesh if required +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6010) NX,NZ + WRITE(IOUT,6011) 'MESHH =' + WRITE(IOUT,6012) (DAMESH(IR,1),IR=-1,2*NX) + IF(NZ .GT. 0) THEN + WRITE(IOUT,6011) 'MESHZ =' + WRITE(IOUT,6012) (DAMESH(IZ,3),IZ=-1,NZ) + ENDIF +*---- +* Pin description +*---- + DO 610 IPIN=1,NPIN + WRITE(IOUT,6017) 'PinTyp',IPIN,ITPIN(3,IPIN) + IF(ITPIN(3,IPIN) .EQ. 3) THEN + WRITE(IOUT,6019) 'PinCXY',IPIN, + > DPIN(0,IPIN)*COS(DPIN(-1,IPIN)), + > DPIN(0,IPIN)*SIN(DPIN(-1,IPIN)) + WRITE(IOUT,6018) 'PinRad',IPIN,DPIN(4,IPIN) + ENDIF + IF(NDIM .EQ. 3) THEN + WRITE(IOUT,6019) 'PinPoZ',IPIN, + > DAMESH(-1,3)-DPIN(3,IPIN)/DTWO, + > DAMESH(-1,3)+DPIN(3,IPIN)/DTWO + ENDIF + 610 CONTINUE + ENDIF + IF(IDIRC .NE. 1) CALL XABORT(NAMSBR// + >': Only z-directed pins permitted in hexagons') +*---- +* Loop over pins +*---- + DO IPIN=1,NPIN +*---- +* For 3-D problem, +* Find pin bottom (ZB) and top (ZT) z location. +*---- + IF(NDIM .EQ. 3) THEN + ZB=DAMESH(-1,3)-DPIN(3,IPIN)/DTWO + ZT=ZB+DPIN(3,IPIN) + ENDIF +*---- +* Annular pin properties +*---- + POSPIN(0)=DPIN(4,IPIN) + POSPIN(1)=DPIN(0,IPIN)*COS(DPIN(-1,IPIN)) + POSPIN(2)=DPIN(0,IPIN)*SIN(DPIN(-1,IPIN)) + VOLPIN=PI*POSPIN(0)*POSPIN(0) +*---- +* 1- Loop over sectors +*---- + DO ISECT=1,6 +*---- +* Loop over region in sector +*---- + DO IR=1,NRTP +* write(6,*) 'ANALYSE IPIN,ISECT,IR', IPIN,ISECT,IR + ITYITA=NXTITA(POSTRI(1,1,IR,ISECT),POSPIN,VOLINT) + IF(ITYITA .NE. 0) THEN + VOLPIN=VOLPIN-VOLINT + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6022) IPIN,ISECT,IR,ITYITA,VOLINT,VOLPIN + ENDIF +*---- +* There is an intersection possible between the pin and +* the triangle. +* 1- Look for botton and top surface in 3-D +*---- + IF(NDIM .EQ. 3) THEN + IF(ZB .LE. DAMESH(0,3) .AND. + > ZT .GE. DAMESH(0,3)) THEN +*---- +* Remove area contribution from bottom surface +*---- + ISUR=ISBOT-(ISECT-1)*NRTPS-IR + SURVOL(ISUR)=SURVOL(ISUR)-VOLINT + ENDIF + IF(ZB .LE. DAMESH(MESH(3),3) .AND. + > ZT .GE. DAMESH(MESH(3),3)) THEN +*---- +* Remove area contribution from top surface +*---- + ISUR=ISTOP-(ISECT-1)*NRTPS-IR + SURVOL(ISUR)=SURVOL(ISUR)-VOLINT + ENDIF + PPPMIN=ZB + PPPMAX=PPPMIN+DPIN(3,IPIN) + DO IZ=1,MESH(3) + PPRMIN=MAX(DAMESH(IZ-1,3),PPPMIN) + PPRMAX=MIN(DAMESH(IZ,3),PPPMAX) + IF(PPRMIN .LT. PPRMAX) THEN + DPP=VOLINT*(PPRMAX-PPRMIN) + IVOL=(IZ-1)*NRTPP+(ISECT-1)*NRTPS+IR*NRP1 + SURVOL(IVOL)=SURVOL(IVOL)-DPP + ENDIF + ENDDO + ELSE + IVOL=(ISECT-1)*NRTPS+IR*NRP1 +* WRITE(IOUT,'(A12,3I10,3F20.10)') 'Volume id', +* >ISECT,IR,(ISECT-1)*NRTPS+IR*NRP1,SURVOL(IVOL),VOLINT, +* >SURVOL(IVOL)-VOLINT + SURVOL(IVOL)=SURVOL(IVOL)-VOLINT + ENDIF + ENDIF +*---- +* If pin all extracted, go to next pin +*---- + IF(VOLPIN .LE. DZERO) GO TO 115 + ENDDO + ENDDO + 115 CONTINUE + ENDDO +*---- +* Test for negative surface area and volumes +*---- + DO ISUR=1,NBSUR + IF(SURVOL(-ISUR) .LT. -DCUTOF) THEN + WRITE(IOUT,9000) NAMSBR,-ISUR + WRITE(IOUT,9002) (INDXSR(IR,-ISUR),IR=1,5),SURVOL(-ISUR) + CALL XABORT(NAMSBR// + > ': Region with negative surface area detected') + ELSE IF(SURVOL(-ISUR) .LT. DCUTOF) THEN + SURVOL(-ISUR)=DZERO + ENDIF + ENDDO + DO IVOL=1,NBREG + IF(SURVOL(IVOL) .LT. -DCUTOF) THEN + WRITE(IOUT,9001) NAMSBR,IVOL + WRITE(IOUT,9002) (INDXSR(IR,IVOL),IR=1,5),SURVOL(IVOL) + CALL XABORT(NAMSBR// + > ': Region with negative volume detected') + ELSE IF(SURVOL(IVOL) .LT. DCUTOF) THEN + SURVOL(IVOL)=DZERO + ENDIF + ENDDO +*---- +* Print volumes if required +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6002) 'SurVol' + WRITE(IOUT,6005) (IVOL,(INDXSR(IR,IVOL),IR=1,5),SURVOL(IVOL), + > IVOL=-NBSUR,NBREG) + WRITE(IOUT,6003) + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6002 FORMAT(A12,'={') + 6003 FORMAT('};') + 6005 FORMAT((6(I10,','),F20.10,:,',')) + 6010 FORMAT(1X,'MESH DIMENSIONS =',2I10) + 6011 FORMAT(1X,A7) + 6012 FORMAT(5F20.10) + 6017 FORMAT(A6,I4.4,'=',I10,';') + 6018 FORMAT(A6,I4.4,'=',F20.10,';') + 6019 FORMAT(A6,I4.4,'={',F20.10,',',F20.10,'};') + 6022 FORMAT('Pin =',I10,' Sector = ',I10,' Region = ',I10, + > ' Intersection =',I10, + > ' Volume of intersection= ',F20.10, + > ' Volume remaining= ',F20.10) +*---- +* Error and Warning formats +*---- + 9000 FORMAT('**** ERROR in -- ',A6,'-- found'/ + > ' Area of region ',I5,' is negative') + 9001 FORMAT('**** ERROR in -- ',A6,'-- found'/ + > ' Volume of region ',I5,' is negative') + 9002 FORMAT(5I10,F20.10) + END diff --git a/Dragon/src/NXTPR3.f b/Dragon/src/NXTPR3.f new file mode 100644 index 0000000..bfeb8e2 --- /dev/null +++ b/Dragon/src/NXTPR3.f @@ -0,0 +1,292 @@ +*DECK NXTPR3 + SUBROUTINE NXTPR3(IPTRK) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To analyse a 3D prismatic geometry from a general +* 3D geometry analysis. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IPTRK pointer to the nxt tracking (L_TRACK). +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK +*---- +* LOCAL VARIABLES +*---- + INTEGER NSTATE,IOUT + PARAMETER(NSTATE=40,IOUT=6) + INTEGER GSTATE(NSTATE),ESTATE(NSTATE),KSIGN(3),ICODE(6),NCODE(6), + 1 KTYPE(3) + INTEGER IZ,IX,IY,NFREG,NFSUR,NDIM,IDIRG,NBOCEL,NBUCEL,IDIAG, + 1 ISAXIS(3),NOCELL(3),NUCELL(3),MAXMSH,MAXMDH,MAXREG,NBTCLS, + 2 MAXPIN,MAXMSP,MAXRSP,MXGSUR,MXGREG,NUNK,IDIR,JJ,NUCELZ,NZP, + 3 N2REG,N2SUR,N2CEL,N2PIN,I,K,NUNK2,NFSURO,ISUR,NUNKO,ITEMP, + 4 ILON,ITYLCM + REAL RSTATT(NSTATE),ALBEDO(6) + DOUBLE PRECISION DZ1,DZ2 + CHARACTER NAMASG*9,NAMREC*12 + LOGICAL HALFS(2),SSYM(2),INVER + CHARACTER CDIR(4)*1 + DATA CDIR /'X','Y','Z','R'/ + TYPE(C_PTR) JPTRK +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MATALB,IUNFLD,MATALB2, + 1 IND2T3,KEYMRG,IND2T3F,MATALBF + REAL, ALLOCATABLE, DIMENSION(:) :: SURVOL1,SURVOLF,ZCORF + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SURVOL,ZCOR, + 1 SURVOL2,SM +*---- +* RECOVER STATE-VECTOR +*---- + GSTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,'STATE-VECTOR',GSTATE) + NFREG=GSTATE(1) + NFSUR=GSTATE(5) + IZ=GSTATE(39) +*--- + IF (IZ.EQ.3) THEN + IX=1 + IY=2 + ELSEIF (IZ.EQ.2) THEN + IX=3 + IY=1 + CALL XABORT('NXTPR3: ONLY PRIZ IMPLEMENTED WITH NXT.') + ELSEIF (IZ.EQ.1) THEN + IX=2 + IY=3 + CALL XABORT('NXTPR3: ONLY PRIZ IMPLEMENTED WITH NXT.') + ELSE + CALL XABORT('NXTPR3: ILLEGAL PROJECTION AXIS') + ENDIF +*---- +* RECOVER INFORMATION FROM NXT 3D GEOMETRY ANALYSIS +*---- + CALL LCMGET(IPTRK,'EXCELTRACKOP',RSTATT) + CALL LCMGET(IPTRK,'SIGNATURE',KSIGN) + CALL LCMGET(IPTRK,'TRACK-TYPE',KTYPE) + CALL LCMGET(IPTRK,'ICODE',ICODE) + CALL LCMGET(IPTRK,'NCODE',NCODE) + CALL LCMGET(IPTRK,'ALBEDO',ALBEDO) + JPTRK=LCMDID(IPTRK,'PROJECTION') + CALL LCMSIX(JPTRK,'NXTRecords',1) + CALL LCMSIX(IPTRK,'NXTRecords',1) + WRITE(NAMASG,'(A1,I8.8)') 'G',1 + NAMREC=NAMASG//'DIM' + ESTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,NAMREC,ESTATE) + NDIM =ESTATE( 1) + IF (NDIM.NE.3) + 1 CALL XABORT('NXTPR3: NON 3D GEOMETRY') + IDIRG =ESTATE( 3) + NBOCEL =ESTATE( 4) + NBUCEL =ESTATE( 5) + IDIAG =ESTATE( 6) + ISAXIS(1)=ESTATE( 7) + ISAXIS(2)=ESTATE( 8) + ISAXIS(3)=ESTATE( 9) + IF (ISAXIS(IZ).NE.0) + 1 CALL XABORT('NXTPR3: Z+- SYMMETRIES NOT YET TREATED') + NOCELL(1)=ESTATE(10) + NOCELL(2)=ESTATE(11) + NOCELL(3)=ESTATE(12) + NUCELL(1)=ESTATE(13) + NUCELL(2)=ESTATE(14) + NUCELL(3)=ESTATE(15) + MAXMSH =ESTATE(16) + MAXREG =ESTATE(17) + NBTCLS =ESTATE(18) + MAXPIN =ESTATE(19) + MAXMSP =ESTATE(20) + MAXRSP =ESTATE(21) + IF (NFSUR.NE.ESTATE(22)) + 1 CALL XABORT('NXTPR3: INCONSISTENT NUMBER OF OUTER SURFACES') + IF (NFREG.NE.ESTATE(23)) + 1 CALL XABORT('NXTPR3: INCONSISTENT NUMBER OF REGIONS') + MXGSUR =ESTATE(24) + MXGREG =ESTATE(25) + NUNK=NFSUR+NFREG+1 + MAXMDH=MAX(MAXMSH,MAXMSP,MAXREG) +* surface-volumes and mixture indexes + ALLOCATE(MATALB(NUNK),SURVOL(NUNK),SURVOL1(NUNK)) + CALL LCMGET(IPTRK,'MATALB ',MATALB) + CALL LCMGET(IPTRK,'SAreaRvolume',SURVOL) + CALL XDRSDB(NUNK,SURVOL1,SURVOL,1) +* cell index and orientation for the cells filling the geometry + ALLOCATE(IUNFLD(2*2*NBUCEL)) + NAMREC=NAMASG//'CUF' + CALL LCMGET(IPTRK,NAMREC,IUNFLD) + NUCELZ=NUCELL(IZ) + ALLOCATE(IND2T3(NUNK*(MAXMDH*NUCELZ+2)),ZCOR(MAXMDH*NUCELZ+2), + 1 MATALB2(NUNK),SURVOL2(NUNK)) +*---- +* CONSTRUCT 2D GEOMETRY ANALYSIS +*---- +* CONSTRUCT (2D,Z)->3D INDEX AND FILL IN LEVEL 1-2 DESCRIPTION + CALL NXT3T2(IPTRK,JPTRK,IX,IY,IZ,NFREG,NFSUR,MAXMDH,NUCELL, + 1 NBUCEL,MXGSUR,MXGREG,MAXPIN,MATALB,SURVOL,IUNFLD,NZP, + 2 N2REG,N2SUR,N2CEL,N2PIN,IND2T3,ZCOR,MATALB2,SURVOL2) +* NXT LEVEL 0 DESCRIPTION +* record DIM + ESTATE(1)=2 + ESTATE(4)=ESTATE(4)/NUCELL(3) + ESTATE(5)=ESTATE(5)/NUCELL(3) + ESTATE(9)=0 + ESTATE(12)=0 + ESTATE(13)=NUCELL(IX) + ESTATE(14)=NUCELL(IY) + ESTATE(15)=0 + ESTATE(16)=N2CEL + ESTATE(22)=N2SUR + ESTATE(23)=N2REG + NAMREC=NAMASG//'DIM' + CALL LCMPUT(JPTRK,NAMREC,NSTATE,1,ESTATE) +* record CUF + NAMREC=NAMASG//'CUF' + CALL LCMPUT(JPTRK,NAMREC,2*ESTATE(5),1,IUNFLD(2*NBUCEL+1)) +* record SMX,SMY + ALLOCATE(SM(NUCELL(IX)+1)) + NAMREC=NAMASG//'SM'//CDIR(IX) + CALL LCMGET(IPTRK,NAMREC,SM) + NAMREC=NAMASG//'SM'//CDIR(1) + CALL LCMPUT(JPTRK,NAMREC,(NUCELL(IX)+1),4,SM) + DEALLOCATE(SM) + ALLOCATE(SM(NUCELL(IY)+1)) + NAMREC=NAMASG//'SM'//CDIR(IY) + CALL LCMGET(IPTRK,NAMREC,SM) + NAMREC=NAMASG//'SM'//CDIR(2) + CALL LCMPUT(JPTRK,NAMREC,(NUCELL(IY)+1),4,SM) + DEALLOCATE(SM) +*--- +* ADDITIONAL RECORDS TO MODIFY/ADD IN /PROJECTION/ +*--- +* KEYMRG ARRAY + CALL LCMLEN(IPTRK,'KEYMRG ',ILON,ITYLCM) + ALLOCATE(KEYMRG(ILON)) + CALL LCMGET(IPTRK,'KEYMRG ',KEYMRG) + CALL LCMPUT(JPTRK,'KEYMRG ',N2SUR+N2REG+1,1, + 1 KEYMRG(NFSUR-N2SUR+1)) + DEALLOCATE(KEYMRG) +* NXT SPECIFIC STATE-VECTOR + CALL LCMSIX(JPTRK,' ',2) + GSTATE(1)=N2REG + GSTATE(2)=N2REG + GSTATE(5)=N2SUR + GSTATE(8)=1 + GSTATE(9)=0 + GSTATE(10)=0 + GSTATE(13)=1 + CALL LCMPUT(JPTRK,'STATE-VECTOR',NSTATE,1,GSTATE) + CALL LCMPUT(JPTRK,'EXCELTRACKOP',NSTATE,2,RSTATT) + CALL LCMPUT(JPTRK,'SIGNATURE ',3,3,KSIGN) + CALL LCMPUT(JPTRK,'TRACK-TYPE ',3,3,KTYPE) + CALL LCMPUT(JPTRK,'ICODE ',6,1,ICODE) + CALL LCMPUT(JPTRK,'ALBEDO ',6,2,ALBEDO) +*--- +* TAKE CARE OF SYMMETRIES ALONG THE PROJECTION AXIS +* UPDATE RECORDS ACCORDINGLY +*--- +* MAIN STATE-VECTOR: store the number of z-plan in the prismatic geometry + CALL LCMSIX(IPTRK,' ',2) + GSTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,'STATE-VECTOR',GSTATE) + GSTATE(39)=NZP +* NCODE ARRAY + DO JJ=1,2 + HALFS(JJ)=(NCODE(2*(IZ-1)+JJ).EQ.5) + SSYM(JJ)=((NCODE(2*(IZ-1)+JJ).EQ.10).OR.(HALFS(JJ))) + ENDDO + INVER=(SSYM(1).AND.(.NOT.SSYM(2))) + IF (SSYM(1).OR.SSYM(2)) NCODE(2*IZ)=30 + IF (SSYM(1).AND.SSYM(2)) NCODE(2*IZ-1)=30 + IF (HALFS(1).OR.HALFS(2)) + 1 CALL XABORT('NXTPR3: SYME NOT SUPPORTED IN PRISMATIC, USE SSYM.') + CALL LCMPUT(IPTRK,'NCODE ',6,1,NCODE) +* + IF (SSYM(1)) IND2T3(NFSUR+2:NFSUR+1+N2REG)=0 + IF (SSYM(2)) THEN + IND2T3((NZP+1)*NUNK+NFSUR+2:(NZP+1)*NUNK+NFSUR+1+N2REG)=0 + ENDIF + NFSURO=NFSUR + NUNKO=NUNK + IF (SSYM(1)) NFSUR=NFSUR-N2REG + IF (SSYM(2)) NFSUR=NFSUR-N2REG + NUNK=NFSUR+NFREG+1 +* + NUNK2=N2SUR+N2REG+1 + ALLOCATE(IND2T3F(NUNK2*(NZP+2)),SURVOLF(NUNK),MATALBF(NUNK)) + DO JJ=0,NFREG + SURVOLF(NFSUR+JJ+1)=SURVOL1(NFSURO+JJ+1) + MATALBF(NFSUR+JJ+1)=MATALB(NFSURO+JJ+1) + ENDDO + JJ=-1 + ISUR=0 + DO 15 K=0,NZP+1 + DO 10 I=0,NUNK2-1 + JJ=JJ+1 + IDIR=IND2T3(K*NUNKO+I+NFSURO-N2SUR+1) + IF (IDIR.LT.0) THEN + ISUR=ISUR+1 + IND2T3F(JJ+1)=-ISUR + SURVOLF(NFSUR-ISUR+1)=0.25*SURVOL1(NFSURO+IDIR+1) + MATALBF(NFSUR-ISUR+1)=MATALB(NFSURO+IDIR+1) + ELSE + IND2T3F(JJ+1)=IDIR + ENDIF + 10 CONTINUE + 15 CONTINUE + IF (ISUR.NE.NFSUR) THEN + write(*,*) ISUR,NFSUR,NFSURO,N2REG + CALL XABORT('NXTPR3: NFSUR OVERFLOW.') + ENDIF + GSTATE(5)=NFSUR + ALLOCATE(ZCORF(NZP+1)) + IF (INVER) THEN + DO K=0,(NZP+1)/2 + DO I=0,NUNK2-1 + ITEMP=IND2T3F(K*NUNK2+I+1) + IND2T3F(K*NUNK2+I+1)=IND2T3F((NZP+1-K)*NUNK2+I+1) + IND2T3F((NZP+1-K)*NUNK2+I+1)=ITEMP + ENDDO + ENDDO + ZCORF=0.0 + DO K=1,NZP + DZ1=ZCOR(NZP-K+1) + DZ2=ZCOR(NZP-K+2) + ZCORF(K+1)=ZCORF(K)+REAL(DZ2-DZ1) + ENDDO + ELSE + CALL XDRSDB(NZP+1,ZCORF,ZCOR,1) + ENDIF + CALL LCMPUT(JPTRK,'MATALB ',NUNK,1,MATALBF) + CALL LCMPUT(JPTRK,'VOLSUR ',NUNK,2,SURVOLF) + CALL LCMPUT(JPTRK,'IND2T3 ',NUNK2*(NZP+2),1,IND2T3F) + CALL LCMPUT(JPTRK,'ZCOORD ',(NZP+1),2,ZCORF) + CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,GSTATE) + DEALLOCATE(ZCORF,MATALBF,SURVOLF,IND2T3F) +*---- +* DEALLOCATE MEMORY +*---- + DEALLOCATE(SURVOL2,MATALB2,ZCOR,IND2T3,IUNFLD,SURVOL1,SURVOL, + 1 MATALB) +* + RETURN + END diff --git a/Dragon/src/NXTPRA.f b/Dragon/src/NXTPRA.f new file mode 100644 index 0000000..092b65a --- /dev/null +++ b/Dragon/src/NXTPRA.f @@ -0,0 +1,789 @@ +*DECK NXTPRA + FUNCTION NXTPRA(NFACES,POSCAR,POSANN,POSPIN,VOLINT) +* +*---------- +* +*Purpose: +* Compute the volume of intersection between +* a 2-D Cartesian region defined by N planes +* an 2-D annular region and +* an annular pin centered at the origin. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau. +* +*Parameters: input +* NFACES number of planes for Cartesian geometre (3 for triangles, +* 4 for rectangle s and 6 for hexagones). +* POSCAR Cartesian region corner definition: +* POSCAR(1,*) is X position; +* POSCAR(2,*) is Y position; +* POSCAR(*,IPLANE) is location of first corner of +* plane IPLANE; +* POSCAR(*,IPLANE+1) is location of second corner of +* plane IPLANE. +* For last plane, the position of the +* second corner is POSCAR(*,1) +* POSANN spatial description of the annular region with +* POSANN(0) the radius, POSANN(1) the $X$ position +* of center and POSANN(2) the $Y$ position +* of center. +* POSPIN spatial description of the annular pin region with +* POSPIN(0) the radius, POSPIN(1) the $X$ position +* of center and POSPIN(2) the $Y$ position +* of center. +* +*Parameters: output +* NXTPRA type of intersection between the three regions, where: +* = 0 means that the volume of intersection +* between the three regions vanishes; +* =-1 means that the volume of intersection +* between the three regions was computed. +* VOLINT 2-D volume of intersection (area) between the three regions. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NXTPRA + INTEGER NFACES + DOUBLE PRECISION POSCAR(2,NFACES),POSANN(0:2),POSPIN(0:2),VOLINT +*---- +* Functions +*---- + DOUBLE PRECISION XDRCST,PI,PIO2,TPIO2,FPIO2 +*---- +* Local parameters +*---- + INTEGER IOUT,IPRINT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,IPRINT=1,NAMSBR='NXTPRA') + DOUBLE PRECISION DZERO,DONE,DTWO,DHALF,CUTOFF + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0,DHALF=0.5D0, + > CUTOFF=1.0D-10) +*---- +* Local variables +*---- + DOUBLE PRECISION PX,PY,RADAN2,RACEN2,RACEN,RADPI2, + > COSA,SINA,XIAPR,YIAPR,TRANX,TRANY, + > XYIAPD(2,2) + INTEGER IPOINT,IFACE,IPLIN,JPLIN,NPLIN,ICYL, + > INT,INTT + DOUBLE PRECISION XLOC,YLOC,XMIN,XMAX,COSR,SINR,ACARG + DOUBLE PRECISION POSCYL(2),RADCYL,R2CYL,YBOT,SOL, + > XINT(2),XLOCR,YLOCR + DOUBLE PRECISION XYBEG(2),RADBEG,THBEG,XYEND(2),RADEND,THEND, + > XYADD(2,2),HDT,FACT,DVOL + INTEGER NPOINT,NBPTS,NADSEG,TYADD(2,2),ISEG + DOUBLE PRECISION PNTINT(6),POINTS(2,24) + INTEGER TYPINT(6),TYPES(2,24) + DOUBLE PRECISION X1,Y1,X2,Y2,VLEN,DP1,DP2,DDP + INTEGER NPIN,IP1,IP2 + DOUBLE PRECISION ANGR + +*---- +* Initialize NXTPRA to no intersection +* Initialize PI and multiples +*---- + IF(IPRINT .GE. 200) THEN + WRITE(IOUT,6000) NAMSBR + write(IOUT,6100) + WRITE(IOUT,6101) (POSCAR(1,IP1),POSCAR(2,IP1),IP1=1,NFACES) + WRITE(IOUT,6102) POSCAR(1,1),POSCAR(2,1) + WRITE(IOUT,6103) POSANN(0), + > POSANN(1),POSANN(2) + WRITE(IOUT,6104) POSPIN(0), + > POSPIN(1),POSPIN(2) + ENDIF + COSR=DZERO + SINR=DZERO + XMAX=DZERO + XMIN=DZERO + YLOC=DZERO + NXTPRA=0 + PI=XDRCST('Pi',' ') + PIO2=PI/DTWO + TPIO2=3.0D0*PIO2 + FPIO2=5.0D0*PIO2 +*---- +* Locate annular region/annular pin intersection points +* and find transformation matrix to locate intersection points with +* respect to center of annular region/annular pin intersection. +* In this system of reference the intersection points are located at +* $(0,y_{i})$ and $(0,y_{i})$ or $\theta=\pm \pi/2$ respectively. +* This will become usefull when all the intersection points between +* the rectangular region, the annular region and the annular pins +* must be classified according to a counter-clockwise order. +* See validation in mathematica file: PRA.nb +*---- + RADAN2=POSANN(0)*POSANN(0) + PX=POSANN(1)-POSPIN(1) + PY=POSANN(2)-POSPIN(2) + RACEN2=PX*PX+PY*PY + RACEN=SQRT(RACEN2) + COSA=PX/RACEN + SINA=PY/RACEN + RADPI2=POSPIN(0)*POSPIN(0) + XIAPR=(RADPI2+RACEN2-RADAN2)/(DTWO*RACEN) + YIAPR=SQRT(RADPI2-XIAPR*XIAPR) + TRANX=-XIAPR + TRANY=DZERO +*---- +* Rotate points back to local frame of reference +* XYIAPD(*,1) is at $\theta = \pi/2$ +* XYIAPD(*,2) is at $\theta = -\pi/2$ +*---- + XYIAPD(1,1)=COSA*XIAPR-SINA*YIAPR+POSPIN(1) + XYIAPD(2,1)=SINA*XIAPR+COSA*YIAPR+POSPIN(2) + XYIAPD(1,2)=COSA*XIAPR+SINA*YIAPR+POSPIN(1) + XYIAPD(2,2)=SINA*XIAPR-COSA*YIAPR+POSPIN(2) +*---- +* For each of the faces of the Cartesian region, +* classify the intersection between the annular region, +* annular pins and corners in +* increasing order in a counter-clockwise fashion. +* A maximum of 6 intersection points can be found. +* Note that the first and last corners are identified by $\pm 3$ +* respectively, the first and last intersection point with the +* annular region are indicated by $\pm 1$ respectively +* and the first and last intersection point with the +* annular pin are indicated by $\pm 2$ respectively. +* Procedure to classify the intersection points: +* 1 - Rotate faces in such a way that they are parallel to the +* $X$ axis and below the Cartesian region. +* 2 - Fill in corner locations in increasing order +* 3 - Locate intersection with annular region (after rotation) and +* insert at adequate location in intersection point vector. +* 4 - Locate intersection with annular pin (after rotation) and +* insert at adequate location in intersection point vector. +*---- + IPOINT=0 + DO IFACE=1,NFACES + IP1=IFACE + IP2=MOD(IFACE,NFACES)+1 + ANGR=ATAN2(POSCAR(2,IP2)-POSCAR(2,IP1), + > POSCAR(1,IP2)-POSCAR(1,IP1)) + COSR=COS(-ANGR) + SINR=SIN(-ANGR) +*---- +* Left triangles +*---- +* write(6,'(A20,4F20.15)') +* > 'Angles de rotation ',ANGR,180.0*ANGR/PI,COSR,SINR + XMIN=COSR*POSCAR(1,IP1)-SINR*POSCAR(2,IP1) + XMAX=COSR*POSCAR(1,IP2)-SINR*POSCAR(2,IP2) + YLOC=SINR*POSCAR(1,IP1)+COSR*POSCAR(2,IP1) +* write(6,'(3F20.15)') XMIN,XMAX,YLOC +*---- +* Save corner location +*---- + IPLIN=1 + PNTINT(IPLIN)=XMIN + TYPINT(IPLIN)=4 + IPLIN=2 + PNTINT(IPLIN)=XMAX + TYPINT(IPLIN)=4 + NPLIN=IPLIN +*---- +* Loop over cylinder +* 1- annular region +* 2- annular pin +*---- + DO ICYL=1,2 +*---- +* Extract cylinder information +*---- + IF(ICYL .EQ. 1) THEN +*---- +* Cylinder is annular region +* Rotate as required. +*---- + POSCYL(1)=COSR*POSANN(1)-SINR*POSANN(2) + POSCYL(2)=SINR*POSANN(1)+COSR*POSANN(2) + RADCYL=POSANN(0) + ELSE +*---- +* Cylinder is annular pin +*---- + POSCYL(1)=COSR*POSPIN(1)-SINR*POSPIN(2) + POSCYL(2)=SINR*POSPIN(1)+COSR*POSPIN(2) + RADCYL=POSPIN(0) + ENDIF +*---- +* Find intersection points between Cartesian face and +* cylindrical region +*---- + R2CYL=RADCYL*RADCYL + YBOT=YLOC-POSCYL(2) + SOL=R2CYL-YBOT*YBOT + IF(SOL .GE. DZERO) THEN + XINT(1)=POSCYL(1)-SQRT(SOL) + XINT(2)=POSCYL(1)+SQRT(SOL) +*---- +* Classify intersection points per order of increasing +* x location for annular region and annular pin +*---- + DO INT=1,2 + DO IPLIN=1,NPLIN + IF(XINT(INT) .LE. PNTINT(IPLIN)) THEN + DO JPLIN=NPLIN,IPLIN,-1 + PNTINT(JPLIN+1)=PNTINT(JPLIN) + TYPINT(JPLIN+1)=TYPINT(JPLIN) + ENDDO + PNTINT(IPLIN)=XINT(INT) + TYPINT(IPLIN)=ICYL + GO TO 100 + ENDIF + ENDDO + IPLIN=NPLIN+1 + PNTINT(IPLIN)=XINT(INT) + TYPINT(IPLIN)=ICYL + 100 CONTINUE + NPLIN=NPLIN+1 + ENDDO + ENDIF + ENDDO +*---- +* All intersection points located and ordered for this face +* of the Cartesian region. +* Scan and locate those defining the intersection of three +* regions +* sum of TYPINT = 7 namely: +* +1 -> one annular region +* +2 -> one pin crossing +* +4 -> inside rectangle +* TYPES(1,*) is type of line segment before point +* TYPES(2,*) is type of line segment after point +* Here +* TYPES=1 means annular region, +* TYPES=2 means annular pin and +* TYPES=4 means rectangle side +*---- +* write(6,*) 'AVANT NPLIN',NPLIN +* write(6,'(F20.15,I10)') +* > (PNTINT(IPLIN),TYPINT(IPLIN),IPLIN=1,NPLIN) + INTT=0 + DO IPLIN=1,NPLIN +*---- +* Rotate back line to original location. +*---- + XLOC=PNTINT(IPLIN) + XLOCR=XLOC*COSR+YLOC*SINR + YLOCR=-XLOC*SINR+YLOC*COSR + IF(INTT .EQ. 7) THEN +*---- +* Already in 3 region intersection +* find the point at which one leaves this region +*---- + IPOINT=IPOINT+1 + POINTS(1,IPOINT)=XLOCR + POINTS(2,IPOINT)=YLOCR + TYPES(1,IPOINT)=4 + TYPES(2,IPOINT)=TYPINT(IPLIN) + ENDIF + INTT=INTT+TYPINT(IPLIN) + IF(INTT .EQ. 7) THEN + IPOINT=IPOINT+1 + POINTS(1,IPOINT)=XLOCR + POINTS(2,IPOINT)=YLOCR + TYPES(1,IPOINT)=TYPINT(IPLIN) + TYPES(2,IPOINT)=4 +*---- +* Test if new point is at the same location as previous point +* for rectangle corners and get rid of duplicates +*---- + IF(IPOINT .GE. 2) THEN +* write(6,'(A8,I10)') 'IPOINT ',IPOINT +* write(6,'(A8,2I10,2F20.15)') 'CURRENT ', +* > TYPES(1,IPOINT),TYPES(2,IPOINT), +* > POINTS(1,IPOINT),POINTS(2,IPOINT) +* write(6,'(A8,2I10,2F20.15)') 'PREVIOUS', +* > TYPES(1,IPOINT-1),TYPES(2,IPOINT-1), +* > POINTS(1,IPOINT-1),POINTS(2,IPOINT-1) + IF(TYPES(1,IPOINT) .EQ. 4) THEN + IF(TYPES(1,IPOINT-1) .EQ. 4 .AND. + > TYPES(2,IPOINT-1) .EQ. 4) THEN + DP1=POINTS(1,IPOINT-1)-POINTS(1,IPOINT) + DP2=POINTS(2,IPOINT-1)-POINTS(2,IPOINT) + DDP=SQRT(DP1*DP1+DP2*DP2) +* write(6,*) 'DP1,DP2,DDP',DP1,DP2,DDP + IF(DDP .LT. CUTOFF) THEN +* IF(POINTS(1,IPOINT-1) .EQ. POINTS(1,IPOINT) .AND. +* > POINTS(2,IPOINT-1) .EQ. POINTS(2,IPOINT) ) THEN + IPOINT=IPOINT-1 + ELSE + CALL XABORT(NAMSBR// + > ': Problem with corner position') + ENDIF + ELSE + CALL XABORT(NAMSBR// + > ': Problem with corner order') + ENDIF + ENDIF + ENDIF + ENDIF + ENDDO +* write(6,*) 'APRES NPLIN',NPLIN +* write(6,'(F20.15,I10)') +* > (PNTINT(IPLIN),TYPINT(IPLIN),IPLIN=1,NPLIN) + ENDDO + NPOINT=IPOINT +*---- +* Complete segment for geometry +*---- +* write(6,*) 'NPOINT',NPOINT + IF(NPOINT .LE. 1) THEN +*---- +* Path is empty or contain a single point for intersections with +* sides of the Cartesian region: +* A- Add annular/pin intersection points (XYIAPD) if both inside +* Cartesian region and create path with two arc segments +* 1- From pin to annulus with arc in annular region (1) +* 2- From annulus to pin with arc in pin region (2) +* 3- Closed loop (0) +* B- otherwise, there is no intersection +*---- + NPIN=0 + DO IPOINT=1,2 + DO IFACE=1,NFACES + IP1=IFACE + IP2=MOD(IP1,NFACES)+1 + X1=POSCAR(1,IP2)-POSCAR(1,IP1) + Y1=POSCAR(2,IP2)-POSCAR(2,IP1) + VLEN=SQRT(X1*X1+Y1*Y1) + X2=-Y1/VLEN + Y2=X1/VLEN + VLEN=(XYIAPD(1,IPOINT)-POSCAR(1,IP1))*X2+ + > (XYIAPD(2,IPOINT)-POSCAR(2,IP1))*Y2 + IF(VLEN. LT. DZERO) GO TO 101 + ENDDO + NPIN=NPIN+1 + 101 CONTINUE + ENDDO + IF(NPIN .EQ. 2) THEN +*---- +* TYPES(1,*) is type of line segment before point +* TYPES(2,*) is type of line segment after point +* where TYPES=1 means annular region and +* TYPES=2 means annular pin +*---- + NPOINT=NPOINT+3 + POINTS(1,1)=XYIAPD(1,1) + POINTS(2,1)=XYIAPD(2,1) + TYPES(1,1) =2 + TYPES(2,1) =1 + POINTS(1,2)=XYIAPD(1,2) + POINTS(2,2)=XYIAPD(2,2) + TYPES(1,2) =1 + TYPES(2,2) =2 + POINTS(1,3)=XYIAPD(1,1) + POINTS(2,3)=XYIAPD(2,1) + TYPES(1,2) =2 + TYPES(2,3) =1 + ELSE + NPOINT=0 + ENDIF + ELSE +*---- +* Test for cyclic track if first point is a corner +*---- + IPOINT=1 +* write(6,'(A8,I10)') 'IPOINT ',IPOINT +* write(6,'(A8,2I10,2F20.15)') 'CURRENT ', +* > TYPES(1,IPOINT),TYPES(2,IPOINT), +* > POINTS(1,IPOINT),POINTS(2,IPOINT) +* write(6,'(A8,2I10,2F20.15)') 'LAST ', +* > TYPES(1,NPOINT),TYPES(2,NPOINT), +* > POINTS(1,NPOINT),POINTS(2,NPOINT) + IF(TYPES(1,IPOINT) .EQ. 4 .AND. + > TYPES(2,IPOINT) .EQ. 4) THEN + IF(TYPES(1,NPOINT) .EQ. 4 .AND. + > TYPES(2,NPOINT) .EQ. 4) THEN + DP1=POINTS(1,NPOINT)-POINTS(1,IPOINT) + DP2=POINTS(2,NPOINT)-POINTS(2,IPOINT) + DDP=SQRT(DP1*DP1+DP2*DP2) +* write(6,*) 'DP1,DP2,DDP',DP1,DP2,DDP + IF(DDP .GE. CUTOFF) THEN +* IF(POINTS(1,NPOINT) .NE. POINTS(1,IPOINT) .OR. +* > POINTS(2,NPOINT) .NE. POINTS(2,IPOINT) ) THEN + CALL XABORT(NAMSBR// + > ': Problem with end corner position') + ENDIF + ELSE + CALL XABORT(NAMSBR// + > ': Problem with end corner order') + ENDIF + ELSE +*---- +* Duplicate first point for cyclic track +*---- + NPOINT=NPOINT+1 + POINTS(1,NPOINT)=POINTS(1,IPOINT) + POINTS(2,NPOINT)=POINTS(2,IPOINT) + TYPES(1,NPOINT)=TYPES(1,IPOINT) + TYPES(2,NPOINT)=TYPES(2,IPOINT) + ENDIF + IF(IPRINT .GE. 200) THEN + WRITE(IOUT,6015) + DO IPOINT=1,NPOINT + IF(IPOINT .EQ. NPOINT) THEN + WRITE(IOUT,6011) POINTS(1,IPOINT),POINTS(2,IPOINT), + > TYPES(1,IPOINT),TYPES(2,IPOINT) + ELSE + WRITE(IOUT,6012) POINTS(1,IPOINT),POINTS(2,IPOINT), + > TYPES(1,IPOINT),TYPES(2,IPOINT) + ENDIF + ENDDO + ENDIF +*---- +* Add missing arc segment if required +*---- + NBPTS=NPOINT + DO IPOINT=NPOINT,2,-1 + NADSEG=0 + IF(TYPES(1,IPOINT) .NE. 4) THEN +*---- +* This point finishes an arc segment +* previous point must begin an arc +*---- + IF(TYPES(2,IPOINT-1) .EQ. 4) CALL XABORT(NAMSBR// + > ': Starting point for arc not found') +*---- +* Find position of intersection points with respect to +* annular/pin center location and angular location +* Rotate to center annular region on $X_{+}$ axis (COSA,SINA) +* and translate by (-XIAPR,0) to center +* annular region/annular pin at $x=0$ +*---- + X1=POINTS(1,IPOINT-1)-POSPIN(1) + Y1=POINTS(2,IPOINT-1)-POSPIN(2) +* XYBEG(1)=COSA*POINTS(1,IPOINT-1)+SINA*POINTS(2,IPOINT-1) +* > -XIAPR +* XYBEG(2)=-SINA*POINTS(1,IPOINT-1)+COSA*POINTS(2,IPOINT-1) + XYBEG(1)=COSA*X1+SINA*Y1-XIAPR + XYBEG(2)=-SINA*X1+COSA*Y1 + RADBEG=SQRT(XYBEG(1)*XYBEG(1)+XYBEG(2)*XYBEG(2)) + X2=POINTS(1,IPOINT)-POSPIN(1) + Y2=POINTS(2,IPOINT)-POSPIN(2) +* XYEND(1)=COSA*POINTS(1,IPOINT)+SINA*POINTS(2,IPOINT) +* > -XIAPR +* XYEND(2)=-SINA*POINTS(1,IPOINT)+COSA*POINTS(2,IPOINT) + XYEND(1)=COSA*X2+SINA*Y2-XIAPR + XYEND(2)=-SINA*X2+COSA*Y2 + RADEND=SQRT(XYEND(1)*XYEND(1)+XYEND(2)*XYEND(2)) +*---- +* Find angular location of points +*---- + ACARG=XYBEG(1)/RADBEG + IF(ACARG .GE. 1.0D0) THEN + THBEG=ACOS(1.0D0) + ELSE IF(ACARG .LE. -1.0D0) THEN + THBEG=ACOS(-1.0D0) + ELSE + THBEG=ACOS(ACARG) + ENDIF + IF(XYBEG(2) .LT. DZERO) THBEG=-THBEG + ACARG=XYEND(1)/RADEND + IF(ACARG .GE. 1.0D0) THEN + THEND=ACOS(1.0D0) + ELSE IF(ACARG .LE. -1.0D0) THEN + THEND=ACOS(-1.0D0) + ELSE + THEND=ACOS(ACARG) + ENDIF + IF(XYEND(2) .LT. DZERO) THEND=-THEND + IF(THEND .LT. THBEG) THEND=DTWO*PI+THEND + IF(THBEG .LT. -PIO2) THEN +*---- +* For $\theta_{i}\le -\pi/2$ the segment must be of +* type 1 (annular region) +*---- + IF(TYPES(2,IPOINT-1) .NE. 1) CALL XABORT(NAMSBR// + >': Error -> Initial line segment must be an annular region') +*---- +* For $\theta_{f}\le -\pi/2$ the segment must be of +* type 1 (annular region) and there is no segment +* to add +* For $-\pi/2 < \theta_{f}\le \pi/2$ the segment must be of +* type 2 (annular region) and there is 1 segment +* to add +* For $\pi/2 < \theta_{f}$ the segment must be of +* type 1 (annular region) and there are 2 segments +* to add +*---- + IF(THEND .LT. -PIO2) THEN + IF(TYPES(1,IPOINT) .NE. 1) CALL XABORT(NAMSBR// + >': Error -> Final line segment must be an annular region') + NADSEG=0 + ELSE IF(THEND .LT. PIO2) THEN + IF(TYPES(1,IPOINT) .NE. 2) CALL XABORT(NAMSBR// + >': Error -> Final line segment must be a pin region') + NADSEG=1 + XYADD(1,1)=XYIAPD(1,2) + XYADD(2,1)=XYIAPD(2,2) + TYADD(1,1)=1 + TYADD(2,1)=2 + ELSE + IF(TYPES(1,IPOINT) .NE. 1) CALL XABORT(NAMSBR// + >': Error -> Final line segment must be an annular region') + NADSEG=2 + XYADD(1,1)=XYIAPD(1,2) + XYADD(2,1)=XYIAPD(2,2) + TYADD(1,1)=1 + TYADD(2,1)=2 + XYADD(1,2)=XYIAPD(1,1) + XYADD(2,2)=XYIAPD(2,1) + TYADD(1,2)=2 + TYADD(2,2)=1 + ENDIF + ELSE IF(THBEG .LT. PIO2) THEN +*---- +* For $-\pi/2 < \theta_{i}\le \pi/2$ the segment must be of +* type 2 (pin region) +*---- + IF(TYPES(2,IPOINT-1) .NE. 2) CALL XABORT(NAMSBR// + >': Error -> Initial line segment must be a pin region') +*---- +* For $-\pi/2 < \theta_{f}\le \pi/2$ the segment must be of +* type 2 (pin region) and there is no segment +* to add +* For $\pi/2 < \theta_{f}\le 3\pi/2$ the segment must be of +* type 1 (annular region) and there is 1 segment +* to add +* For $3\pi/2< \theta_{f}$ the segment must be of +* type 2 (pin region) and there are 2 segments +* to add +*---- + IF(THEND .LT. PIO2) THEN + IF(TYPES(1,IPOINT) .NE. 2) CALL XABORT(NAMSBR// + >': Error -> Final line segment must be a pin region') + NADSEG=0 + ELSE IF(THEND .LT. TPIO2) THEN + IF(TYPES(1,IPOINT) .NE. 1) CALL XABORT(NAMSBR// + >': Error -> Final line segment must be an annular region') + NADSEG=1 + XYADD(1,1)=XYIAPD(1,1) + XYADD(2,1)=XYIAPD(2,1) + TYADD(1,1)=2 + TYADD(2,1)=1 + ELSE + IF(TYPES(1,IPOINT) .NE. 2) CALL XABORT(NAMSBR// + >': Error -> Final line segment must be a pin region') + NADSEG=2 + XYADD(1,1)=XYIAPD(1,1) + XYADD(2,1)=XYIAPD(2,1) + TYADD(1,1)=2 + TYADD(2,1)=1 + XYADD(1,2)=XYIAPD(1,2) + XYADD(2,2)=XYIAPD(2,2) + TYADD(1,2)=1 + TYADD(2,2)=2 + ENDIF + ELSE +*---- +* For $\pi/2 < \theta_{i}$ the segment must be of +* type 1 (annular region) +*---- + IF(TYPES(2,IPOINT-1) .NE. 1) CALL XABORT(NAMSBR// + >': Error -> Initial line segment must be an annular region') +*---- +* For $\pi/2 < \theta_{f}\le 3\pi/2$ the segment must be of +* type 1 (annular region) and there is no segment +* to add +* For $3\pi/2< \theta_{f}\le 5*\pi/2$ the segment must be of +* type 2 (pin region) and there is 1 segment +* to add +* For $5*\pi/2 < \theta_{f}$ the segment must be of +* type 1 (annular region) and there are 2 segments +* to add +*---- + IF(THEND .LT. TPIO2) THEN + IF(TYPES(1,IPOINT) .NE. 1) CALL XABORT(NAMSBR// + >': Error -> Final line segment must be an annular region') + NADSEG=0 + ELSE IF(THEND .LT. FPIO2) THEN + IF(TYPES(1,IPOINT) .NE. 2) CALL XABORT(NAMSBR// + >': Error -> Final line segment must be a pin region') + NADSEG=1 + XYADD(1,1)=XYIAPD(1,2) + XYADD(2,1)=XYIAPD(2,2) + TYADD(1,1)=1 + TYADD(2,1)=2 + ELSE + IF(TYPES(1,IPOINT) .NE. 1) CALL XABORT(NAMSBR// + >': Error -> Final line segment must be an annular region') + NADSEG=2 + XYADD(1,1)=XYIAPD(1,2) + XYADD(2,1)=XYIAPD(2,2) + TYADD(1,1)=1 + TYADD(2,1)=2 + XYADD(1,2)=XYIAPD(1,1) + XYADD(2,2)=XYIAPD(2,1) + TYADD(1,2)=2 + TYADD(2,2)=1 + ENDIF + ENDIF + ENDIF +*---- +* Move end segments to create place for new segments +*---- + IF(NADSEG .GT. 0) THEN + DO ISEG=NBPTS,IPOINT,-1 + POINTS(1,ISEG+NADSEG)=POINTS(1,ISEG) + POINTS(2,ISEG+NADSEG)=POINTS(2,ISEG) + TYPES(1,ISEG+NADSEG)=TYPES(1,ISEG) + TYPES(2,ISEG+NADSEG)=TYPES(2,ISEG) + ENDDO +*---- +* Insert new segments +*---- + DO ISEG=NADSEG,1,-1 + POINTS(1,IPOINT+ISEG-1)=XYADD(1,ISEG) + POINTS(2,IPOINT+ISEG-1)=XYADD(2,ISEG) + TYPES(1,IPOINT+ISEG-1)=TYADD(1,ISEG) + TYPES(2,IPOINT+ISEG-1)=TYADD(2,ISEG) + ENDDO + NBPTS=NBPTS+NADSEG + ENDIF + ENDDO + NPOINT=NBPTS + ENDIF + IF(NPOINT .EQ. 0) THEN + NXTPRA=0 + VOLINT=DZERO + ELSE + VOLINT=DZERO + IF(IPRINT .GE. 200) THEN +*---- +* Print cell description if required +*---- + WRITE(IOUT,6010) + DO IPOINT=1,NPOINT + IF(IPOINT .EQ. NPOINT) THEN + WRITE(IOUT,6011) POINTS(1,IPOINT),POINTS(2,IPOINT), + > TYPES(1,IPOINT),TYPES(2,IPOINT) + ELSE + WRITE(IOUT,6012) POINTS(1,IPOINT),POINTS(2,IPOINT), + > TYPES(1,IPOINT),TYPES(2,IPOINT) + ENDIF + ENDDO + ENDIF + DO IPOINT=1,NPOINT-1 +*---- +* Add contribution under line segments +*---- + DVOL=(POINTS(1,IPOINT)-POINTS(1,IPOINT+1)) + > *(POINTS(2,IPOINT)+POINTS(2,IPOINT+1))/DTWO + VOLINT=VOLINT+DVOL + IF(TYPES(2,IPOINT) .EQ. 1) THEN +*---- +* Add annular region contribution (annular region is not centered) +* 1- Find angular width for two points +* 2- Compute volume above line joining the two points +*---- + XYBEG(1)=POINTS(1,IPOINT)-POSANN(1) + XYBEG(2)=POINTS(2,IPOINT)-POSANN(2) + XYEND(1)=POINTS(1,IPOINT+1)-POSANN(1) + XYEND(2)=POINTS(2,IPOINT+1)-POSANN(2) +*---- +* Find angular location of points +*---- + ACARG=XYBEG(1)/POSANN(0) + IF(ACARG .GE. 1.0D0) THEN + THBEG=ACOS(1.0D0) + ELSE IF(ACARG .LE. -1.0D0) THEN + THBEG=ACOS(-1.0D0) + ELSE + THBEG=ACOS(ACARG) + ENDIF + IF(XYBEG(2) .LT. DZERO) THBEG=-THBEG + ACARG=XYEND(1)/POSANN(0) + IF(ACARG .GE. 1.0D0) THEN + THEND=ACOS(1.0D0) + ELSE IF(ACARG .LE. -1.0D0) THEN + THEND=ACOS(-1.0D0) + ELSE + THEND=ACOS(ACARG) + ENDIF + IF(XYEND(2) .LT. DZERO) THEND=-THEND + IF(THEND .LT. THBEG) THEND=DTWO*PI+THEND + HDT=(THEND-THBEG)/DTWO + FACT=COS(HDT)*SIN(HDT) + DVOL=RADAN2*(HDT-FACT) + VOLINT=VOLINT+DVOL + ELSE IF (TYPES(2,IPOINT) .EQ. 2) THEN +*---- +* Add pin region contribution (pin is centered) +* 1- Find angular width for the two points +* 2- Compute volume above line joining the two points +*---- + XYBEG(1)=POINTS(1,IPOINT)-POSPIN(1) + XYBEG(2)=POINTS(2,IPOINT)-POSPIN(2) + XYEND(1)=POINTS(1,IPOINT+1)-POSPIN(1) + XYEND(2)=POINTS(2,IPOINT+1)-POSPIN(2) +*---- +* Find angular location of points +*---- + ACARG=XYBEG(1)/POSPIN(0) + IF(ACARG .GE. 1.0D0) THEN + THBEG=ACOS(1.0D0) + ELSE IF(ACARG .LE. -1.0D0) THEN + THBEG=ACOS(-1.0D0) + ELSE + THBEG=ACOS(ACARG) + ENDIF + IF(XYBEG(2) .LT. DZERO) THBEG=-THBEG + ACARG=XYEND(1)/POSPIN(0) + IF(ACARG .GE. 1.0D0) THEN + THEND=ACOS(1.0D0) + ELSE IF(ACARG .LE. -1.0D0) THEN + THEND=ACOS(-1.0D0) + ELSE + THEND=ACOS(ACARG) + ENDIF + IF(XYEND(2) .LT. DZERO) THEND=-THEND + IF(THEND .LT. THBEG) THEND=DTWO*PI+THEND + HDT=(THEND-THBEG)/DTWO + FACT=COS(HDT)*SIN(HDT) + DVOL=RADPI2*(HDT-FACT) + VOLINT=VOLINT+DVOL + ENDIF + ENDDO + ENDIF + IF(IPRINT .GE. 200) THEN + WRITE(IOUT,6020) VOLINT + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT('FinalSegments={') + 6011 FORMAT('{',F20.10,',',F20.10,',',I10,',',I10,'}};') + 6012 FORMAT('{',F20.10,',',F20.10,',',I10,',',I10,'},') + 6015 FORMAT('OriginalSegments={') + 6020 FORMAT('Volint=',F20.10,';') + 6100 FORMAT('CartesianRegion={') + 6101 FORMAT(('{',F15.10,',',F15.10,'}',','/)) + 6102 FORMAT('{',F15.10,',',F15.10,'}','};') + 6103 FORMAT('RADAN = ',F15.10,';'/ + > 'POSANN={',F15.10,',',F15.10,'};') + 6104 FORMAT('RADIUS= ',F15.10,';'/ + > 'xypin={',F15.10,',',F15.10,'};') + END diff --git a/Dragon/src/NXTPRI.f b/Dragon/src/NXTPRI.f new file mode 100644 index 0000000..eb45b2e --- /dev/null +++ b/Dragon/src/NXTPRI.f @@ -0,0 +1,294 @@ +*DECK NXTPRI + SUBROUTINE NXTPRI(IPTRK,JPTRK,IX,IY,IZ,NFREG,NFSUR,MAXMSH,NUCELL, + 1 MXGSUR,MXGREG,INDEX,IDSUR,IDREG,MESHC,NSURC, + 2 NREGC,IDIRC,NZP,N2REG,N2SUR,IND2T3,REGI, + 3 DEPS,DCMESH,ZCORD,LFIRST,LSTORE,ILEV,IEL,N2EL, + 4 N2SURC,N2REGC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Check compatibility of cells/pins along the projection axis for a +* 3D prismatic treatment and generate corresponding 2D cell/pin. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IPTRK pointer to the NXT 3D geometry analysis. +* JPTRK pointer to the NXT 2D projected geometry analysis. +* IX first direction perpendicular to the projection axis. +* IY second direction perpendicular to the projection axis. +* IZ projection axis. +* NFREG number of regions in the 3D geometry. +* NFSUR number of outer surfaces in the 3D geometry. +* MAXMSH maximum dimension of any mesh in any sub-geometry of the 3D +* geometry. +* NUCELL number of cells along the three axis in the 3D geometry. +* MXGSUR maximum number of surfaces for any sub-geometry of the 3D +* geometry. +* MXGREG maximum number of regions for any sub-geometry of the 3D +* geometry. +* INDEX cells/pins index vector. +* IDSUR surface index array. +* IDREG region index array. +* MESHC cells/pins meshes size. +* NSURC number of surfaces for the cells/pins. +* NREGC number of regions for the cells/pins. +* IDIRC cylinders orientations. +* DEPS comparison criterion for double precision values. +* DCMESH cells/pins meshing vector. +* LFIRST first cell/pin processed flag. +* LSTORE 2D cell/pin storage flag. +* ILEV geometry level 1:cells / 2:pins. +* IEL index of the first 3D cell/pin considered. +* N2EL index of the corresponding 2D cell. +* +*Parameters: input/output +* NZP number of plans in the 3D prismatic geometry. +* N2REG number of regions in the projected 2D geometry. +* N2SUR number of outer surfaces in the projected 2D geometry. +* IND2T3 mapping index between the 2D projected geometries (plan by +* plan) and the initial 3D geometry. +* REGI region sweeping flag array. +* ZCORD coordinates of the different plans of the 3D prismatic +* geometry. +* N2SURC number of outer surfaces in the 2D corresponding cell/pin. +* N2REGC number of outer regions in the 2D corresponding cell/pin. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,JPTRK + INTEGER IX,IY,IZ,NFREG,NFSUR,MAXMSH,NUCELL(3),MXGSUR, + 1 MXGREG,INDEX(5,-MXGSUR:MXGREG,0:NUCELL(IZ)), + 2 IDSUR(MXGSUR,0:NUCELL(IZ)),IDREG(MXGREG,0:NUCELL(IZ)), + 3 MESHC(4,NUCELL(IZ)),NSURC(NUCELL(IZ)),NREGC(NUCELL(IZ)), + 4 IDIRC(NUCELL(IZ)),NZP,N2REG,N2SUR, + 7 IND2T3(-NFSUR:NFREG,0:NUCELL(IZ)*MAXMSH+1),REGI(-NFSUR:NFREG), + 8 ILEV,IEL,N2EL,N2SURC,N2REGC + DOUBLE PRECISION DEPS,DCMESH(-1:MAXMSH,4,0:NUCELL(IZ)), + 1 ZCORD(0:MAXMSH) + LOGICAL LFIRST,LSTORE +*---- +* LOCAL VARIABLES +*---- + INTEGER K,JJ,MESHR(4),MESHCZM,I2SURC,II,LL + DOUBLE PRECISION DELZ + LOGICAL XDDCOM + CHARACTER NAMCEL*9,NAMREC*12,NAMCE2*9 + CHARACTER CDIR(4)*1,CLEV(2)*1 + DATA CDIR /'X','Y','Z','R'/ + DATA CLEV /'C','P'/ +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NZC,IDZ + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SM +*---- +* Scratch storage allocation +*---- + ALLOCATE(NZC(NUCELL(IZ))) +*---- +* TEST THE CELL/PIN DIMENSIONS COMPATIBILITY +*---- + IF ((IDIRC(1).NE.IZ).AND.(IDIRC(1).NE.0)) + 1 CALL XABORT('NXTPRI: INVALID PRISMATIC GEOMETRY (IDIRC).') + MESHR(1)=MESHC(IX,1) + MESHR(2)=MESHC(IY,1) + MESHR(4)=MESHC(4,1) + NZC(1)=0 + MESHCZM=MESHC(IZ,1) + DO K=2,NUCELL(IZ) + IF ((IDIRC(K).NE.IZ).AND.(IDIRC(K).NE.0)) THEN + WRITE(6,*) IDIRC(K),IZ + CALL XABORT('NXTPRI: INVALID PRISMATIC GEOMETRY (IDIRC).') + ENDIF + IF (MESHC(IX,K).NE.MESHR(1)) THEN + WRITE(6,*) MESHC(IX,K),MESHR(1) + CALL XABORT('NXTPRI: INVALID PRISMATIC GEOMETRY (MESHC(1)).') + ENDIF + IF (MESHC(IY,K).NE.MESHR(2)) THEN + WRITE(6,*) MESHC(IY,K),MESHR(2) + CALL XABORT('NXTPRI: INVALID PRISMATIC GEOMETRY (MESHC(2)).') + ENDIF + IF (MESHC(4,K).NE.MESHR(4)) THEN + WRITE(6,*) MESHC(4,K),MESHR(4) + CALL XABORT('NXTPRI: INVALID PRISMATIC GEOMETRY (MESHC(4)).') + ENDIF + NZC(K)=NZC(K-1)+MESHC(IZ,K) + MESHCZM=MAX(MESHCZM,MESHC(IZ,K)) + ENDDO +*---- +* TEST THE CELL/PIN MESHES COMPATIBILITY +*---- + DO K=2,NUCELL(IZ) + DO JJ=-1,MESHR(1) + IF (.NOT.XDDCOM(DCMESH(JJ,IX,K),DCMESH(JJ,IX,1),DEPS)) THEN + WRITE(6,*) IX,DCMESH(JJ,IX,K),DCMESH(JJ,IX,1) + CALL XABORT('NXTPRI: INVALID PRISMATIC GEOMETRY (DCMESH).') + ENDIF + ENDDO + DO JJ=-1,MESHR(2) + IF (.NOT.XDDCOM(DCMESH(JJ,IY,K),DCMESH(JJ,IY,1),DEPS)) THEN + WRITE(6,*) IY,DCMESH(JJ,IY,K),DCMESH(JJ,IY,1) + CALL XABORT('NXTPRI: INVALID PRISMATIC GEOMETRY (DCMESH).') + ENDIF + ENDDO + IF (MESHR(4).GT.0) THEN + DO JJ=-1,MESHR(4) + IF (.NOT.XDDCOM(DCMESH(JJ,4,K),DCMESH(JJ,4,1),DEPS)) THEN + WRITE(6,*) 4,DCMESH(JJ,4,K),DCMESH(JJ,4,1) + CALL XABORT('NXTPRI: INVALID PRISMATIC GEOMETRY (DCMESH).') + ENDIF + ENDDO + ENDIF + ENDDO + IF (LFIRST) THEN +*---- +* CALCULATE GLOBAL MESH ALONG THE PROJECTION AXIS +*---- + NZP=0 + ZCORD(0)=0.0 + DO 20 K=1,NUCELL(IZ) + DO 10 JJ=1,MESHC(IZ,K) + NZP=NZP+1 + ZCORD(NZP)=ZCORD(NZP-1)+(DCMESH(JJ,IZ,K)-DCMESH(JJ-1,IZ,K)) + 10 CONTINUE + 20 CONTINUE + ELSE +*---- +* TEST THE COMPATIBILITY OF THE GLOBAL MESH ALONG THE PROJECTION AXIS +*---- + NZP=0 + DELZ=0.D0 + DO 40 K=1,NUCELL(IZ) + DO 30 JJ=1,MESHC(IZ,K) + NZP=NZP+1 + DELZ=DELZ+(DCMESH(JJ,IZ,K)-DCMESH(JJ-1,IZ,K)) + IF (.NOT.XDDCOM(DELZ,ZCORD(NZP),DEPS)) + 1 CALL XABORT('NXTPRI: INVALID PRISMATIC GEOMETRY (ZCORD).') + + 30 CONTINUE + 40 CONTINUE + ENDIF + IF (LSTORE) THEN +*---- +* STORE THE CORRESPONDING 2D CELL/PIN CONTENTS +*---- + WRITE(NAMCEL,'(A1,I8.8)') CLEV(ILEV),IEL + WRITE(NAMCE2,'(A1,I8.8)') CLEV(ILEV),N2EL + !write(*,*) 'storing ',NAMCE2,MESHR(1),MESHR(2),MESHR(4) + ALLOCATE(SM(MESHR(1)+2)) + NAMREC=NAMCEL//'SM'//CDIR(IX) + CALL LCMGET(IPTRK,NAMREC,SM) + NAMREC=NAMCE2//'SM'//CDIR(1) + CALL LCMPUT(JPTRK,NAMREC,(MESHR(1)+2),4,SM) + DEALLOCATE(SM) + ALLOCATE(SM(MESHR(2)+2)) + NAMREC=NAMCEL//'SM'//CDIR(IY) + CALL LCMGET(IPTRK,NAMREC,SM) + NAMREC=NAMCE2//'SM'//CDIR(2) + CALL LCMPUT(JPTRK,NAMREC,(MESHR(2)+2),4,SM) + DEALLOCATE(SM) + IF (MESHR(4).GT.0) THEN + ALLOCATE(SM(MESHR(4)+2)) + NAMREC=NAMCEL//'SM'//CDIR(4) + CALL LCMGET(IPTRK,NAMREC,SM) + NAMREC=NAMCE2//'SM'//CDIR(4) + CALL LCMPUT(JPTRK,NAMREC,(MESHR(4)+2),4,SM) + DEALLOCATE(SM) + ENDIF + ENDIF +*---- +* UPDATE IND2T3 FOR THIS SET OF CELLS/PINS +*---- + ALLOCATE(IDZ(NUCELL(IZ)*(MESHCZM+3))) + N2SURC=(NSURC(1)-2*NREGC(1)/MESHC(IZ,1))/MESHC(IZ,1) + I2SURC=-N2SURC-1 + N2REGC=0 + IF (ILEV.EQ.2) THEN +* R+ surface + CALL NXTIND(IX,IY,IZ,NFSUR,NFREG,MXGSUR,MXGREG,MAXMSH,NZP, + 1 NUCELL(IZ),MESHCZM,MESHC,NSURC,NREGC,INDEX,IDREG,IDSUR, + 2 N2REG,N2SUR,IND2T3,REGI,NZC,IDZ,LSTORE,I2SURC, + 3 N2REGC,0,0,-2) + ELSE +* Y- Y+ surfaces + DO 60 JJ=-2,-1 + DO 50 II=MESHC(IX,1),1,-1 + LL=0 + CALL NXTIND(IX,IY,IZ,NFSUR,NFREG,MXGSUR,MXGREG,MAXMSH,NZP, + 1 NUCELL(IZ),MESHCZM,MESHC,NSURC,NREGC,INDEX,IDREG,IDSUR, + 2 N2REG,N2SUR,IND2T3,REGI,NZC,IDZ,LSTORE,I2SURC, + 3 N2REGC,II,JJ,LL) + 50 CONTINUE + 60 CONTINUE +* X- X+ surfaces + DO 80 II=-2,-1 + DO 70 JJ=MESHC(IY,1),1,-1 + LL=0 + CALL NXTIND(IX,IY,IZ,NFSUR,NFREG,MXGSUR,MXGREG,MAXMSH,NZP, + 1 NUCELL(IZ),MESHCZM,MESHC,NSURC,NREGC,INDEX,IDREG,IDSUR, + 2 N2REG,N2SUR,IND2T3,REGI,NZC,IDZ,LSTORE,I2SURC, + 3 N2REGC,II,JJ,LL) + 70 CONTINUE + 80 CONTINUE + ENDIF +* regions + DO 100 JJ=1,MESHC(IY,1) + DO 90 II=1,MESHC(IX,1) + DO LL=1,MESHC(4,1) + CALL NXTIND(IX,IY,IZ,NFSUR,NFREG,MXGSUR,MXGREG,MAXMSH,NZP, + 1 NUCELL(IZ),MESHCZM,MESHC,NSURC,NREGC,INDEX,IDREG,IDSUR, + 2 N2REG,N2SUR,IND2T3,REGI,NZC,IDZ,LSTORE,I2SURC, + 3 N2REGC,II,JJ,LL) + ENDDO + IF (ILEV.EQ.1) THEN + LL=0 + CALL NXTIND(IX,IY,IZ,NFSUR,NFREG,MXGSUR,MXGREG,MAXMSH,NZP, + 1 NUCELL(IZ),MESHCZM,MESHC,NSURC,NREGC,INDEX,IDREG,IDSUR, + 2 N2REG,N2SUR,IND2T3,REGI,NZC,IDZ,LSTORE,I2SURC, + 3 N2REGC,II,JJ,LL) + ENDIF + 90 CONTINUE +100 CONTINUE + DEALLOCATE(IDZ) + IF (LSTORE) THEN +*---- +* STORE THE CORRESPONDING 2D CELL/PIN CONTENTS +*---- + IF ((I2SURC.NE.-1).OR.(N2REGC.NE.NREGC(1)/MESHC(IZ,1))) THEN + WRITE(6,*) I2SURC,-1,' OR', N2REGC,NREGC(1)/MESHC(IZ,1) + CALL XABORT('NXTPRI: INVALID NUMBER OF SURFACES/REGIONS') + ENDIF + WRITE(NAMCEL,'(A1,I8.8)') CLEV(ILEV),N2EL + NAMREC=NAMCEL//'VSI' + INDEX(1,0,0)=0 + INDEX(2,0,0)=0 + INDEX(3,0,0)=0 + INDEX(4,0,0)=0 + INDEX(5,0,0)=0 + CALL LCMPUT(JPTRK,NAMREC,5*(N2SURC+N2REGC+1),1, + 1 INDEX(1,-N2SURC,0)) + NAMREC=NAMCEL//'RID' + CALL LCMPUT(JPTRK,NAMREC,N2REGC,1,IDREG(1,0)) + NAMREC=NAMCEL//'SID' + CALL LCMPUT(JPTRK,NAMREC,N2SURC,1,IDSUR(1,0)) + ENDIF +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(NZC) + RETURN + END diff --git a/Dragon/src/NXTPRR.f b/Dragon/src/NXTPRR.f new file mode 100644 index 0000000..06fb2f2 --- /dev/null +++ b/Dragon/src/NXTPRR.f @@ -0,0 +1,81 @@ +*DECK NXTPRR + FUNCTION NXTPRR(XYREC1,XYREC2,XYRECI) +* +*---------- +* +*Purpose: +* Find the rectangle representing the intersection of two rectangles. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau. +* +*Parameters: input +* XYREC1 spatial description of the first rectangle with: +* XYREC1(1) for left face; XYREC1(2) for right face; +* XYREC1(3) for bottom face; XYREC1(4) for top face +* positions. +* XYREC2 spatial description of the second rectangle with: +* XYREC2(1) for left face; XYREC2(2) for right face; +* XYREC2(3) for bottom face; XYREC2(4) for top face +* positions. +*Parameters: output +* NXTPRR type of intersection between rectangles where +* =0 means that there is no intersection +* between the two regions; +* =1 means that there is an intersection between +* between the two regions. +* XYRECI spatial description of the intersection rectangle with: +* XYRECI(1) for left face; XYRECI(2) for right face; +* XYRECI(3) for bottom face; XYRECI(4) for top face +* positions. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NXTPRR + DOUBLE PRECISION XYREC1(4),XYREC2(4) + DOUBLE PRECISION XYRECI(4) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTPRR') +*---- +* Local variables +*---- + INTEGER IFACE +*---- +* Find position of surface of intersection +* -> for left and bottom faces, maximum $X$ and $Y$ location. +* -> for right and top faces, minimum $X$ and $Y$ location. +*---- + NXTPRR=1 + DO 100 IFACE=1,3,2 + XYRECI(IFACE)=MAX(XYREC2(IFACE),XYREC1(IFACE)) + 100 CONTINUE + DO 101 IFACE=2,4,2 + XYRECI(IFACE)=MIN(XYREC2(IFACE),XYREC1(IFACE)) + 101 CONTINUE +*---- +* Test if intersection is valid +*---- + IF(XYRECI(1) .GE. XYRECI(2) .OR. + > XYRECI(3) .GE. XYRECI(4)) NXTPRR=0 + RETURN + END diff --git a/Dragon/src/NXTQAC.f b/Dragon/src/NXTQAC.f new file mode 100644 index 0000000..f125e21 --- /dev/null +++ b/Dragon/src/NXTQAC.f @@ -0,0 +1,249 @@ +*DECK NXTQAC + SUBROUTINE NXTQAC(IPRINT,NDIM ,NANGL ,NBANGL,ITYPBC,DENUSR, + > ABSC ,RCIRC ,AZMQUA,IPER , + > DANGLT,DDENWT,DNSANG,NBSANG,DDANG ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To define quadrature angles for cyclic tracking. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau, R. Roy +* +*Parameters: input +* IPRINT print level. +* NDIM number of dimensions for geometry. +* NANGL quadrature order. +* NBANGL number of angles. +* ITYPBC type of boundary condition (=0/.ge.2: Cartesian/hexagonal). +* DENUSR requested density for spatial tracking. +* ABSC multidimensional width of the cell. +* RCIRC radius of circle surrounding geometry. +* AZMQUA tracking type. +* IPER cell periodicity factor in each direction. +* +*Parameters: output +* DANGLT director cosines of angles. +* DDENWT angular density for each angle. +* DNSANG spatial density required. +* NBSANG number of segments for each angles. +* DDANG angles. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* Extracted from the subroutine XELTS2 of EXCELL. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,NDIM,NANGL,NBANGL,ITYPBC + DOUBLE PRECISION DENUSR,ABSC(NDIM),RCIRC + INTEGER AZMQUA,IPER(3) + DOUBLE PRECISION DANGLT(NDIM,NBANGL,4),DDENWT(NBANGL,4), + > DNSANG(NBANGL) + INTEGER NBSANG(5,NBANGL) + DOUBLE PRECISION DDANG(NBANGL) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTQAC') + DOUBLE PRECISION DZERO,DONE,DTWO + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Local variables +*---- + INTEGER ISUM,IDEB,ISTRID,IANG,ITX,ITY,INDC(2),NTRAC,IOF, + > IA,IB,IC,IPERG,IDIR + DOUBLE PRECISION DENLIN + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: DDAX + INTEGER, DIMENSION(2,3), PARAMETER :: + > INDC_HEX3 = RESHAPE([1,5, 2,4, 3,1],[2,3]) + INTEGER, DIMENSION(2,6), PARAMETER :: + > INDC_HEX6 = RESHAPE([1,7,1,5, 2,4,3,5, 4,2,3,1],[2,6]) + INTEGER, DIMENSION(2,12), PARAMETER :: + > INDC_HEX12 = RESHAPE([1,9,1,7,1,5,2,8, 3,7,2,4,3,5,4,6, 5,3, + > 4,2,3,1,5,1],[2,12]) + INTEGER, DIMENSION(2,18), PARAMETER :: + > INDC_HEX18 = RESHAPE([1,15,1,9,1,7,1,5,2,8,4,14, + > 5,13,3,7,2,4,3,5,4,6,7,9, 8,6,5,3,4,2,3,1,5,1,9,1],[2,18]) +*---- +* Start processing +*---- + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6010) NDIM,AZMQUA,NANGL,NBANGL,ITYPBC + ENDIF + IF(NDIM .NE. 2) CALL XABORT(NAMSBR// + >': Cyclic tracking works only in 2-D') +* + ALLOCATE(DDAX(NDIM,NDIM)) + IF(ITYPBC.EQ.0) THEN +*---- +* CARTESIAN GEOMETRY +*---- +*---- +* 1. Define angles +* IWT option is: +* 0<= theta <= Pi/2 +* ITX=0,NBANGL-1 +* ITY=NBANGL-ITX +* MEDI option is +* 0< theta < Pi/2 +* ITX=1,2*NBANGL,2 +* ITY=2*NBANGL-ITX +* EQW2 option is +* 0< theta < Pi/2 +* ITX=1,NBANGL +* ITY=NBANGL-ITX+1 +*---- + ISUM=0 + IDEB=0 + ISTRID=0 + IOF=0 + IF(AZMQUA .EQ. 1) THEN + ISUM=NBANGL-1 + IDEB=0 + ISTRID=1 + ELSE IF(AZMQUA .EQ. 3) THEN + ISUM=2*NBANGL-1 + IDEB=1 + ISTRID=2 + IOF=1 + ELSE IF(AZMQUA .EQ. 8) THEN + ISUM=NBANGL + IDEB=1 + ISTRID=1 + IOF=1 + ELSE + CALL XABORT(NAMSBR//': Invalid quadrature') + ENDIF + IPERG=MIN(IPER(1)*IPER(2),2) + IANG=0 + DO ITX=IDEB,ISUM,ISTRID + INDC(1)=ITX + ITY=ISUM-ITX+IOF + INDC(2)=ITY +*---- +* Read angle +*---- + IANG=IANG+1 + CALL XELTSA(NDIM ,ITYPBC, ABSC ,INDC ,DNSANG(IANG) ,DDAX) + DANGLT(:NDIM,IANG,1)=DDAX(:NDIM,1) + DENLIN=DNSANG(IANG)/RCIRC + IF(ITX .EQ. 0 .OR. ITY .EQ. 0) THEN + DNSANG(IANG)= DENUSR + ELSE + NTRAC=MAX(1,INT(DENUSR/DENLIN+0.5D0)) + DNSANG(IANG)=DBLE(NTRAC)*DENLIN + ENDIF + DDANG(IANG)=DANGLT(1,IANG,1) + NBSANG(1,IANG)=ITX + NBSANG(2,IANG)=ITY + NBSANG(3,IANG)=IPERG + NBSANG(4,IANG)=1 + NBSANG(5,IANG)=0 + IF((AZMQUA .EQ. 1).AND.(ITX .EQ. ISUM)) THEN + NBSANG(3,IANG)=IPER(1) + ELSE IF((AZMQUA .EQ. 1).AND.(ITY .EQ. ISUM)) THEN + NBSANG(3,IANG)=IPER(2) + ELSE +* Find the least common multiple of ITX and ITY + IA=ITX + IB=ITY + DO WHILE (IB.NE.0) + IC = MOD(IA,IB) + IA = IB + IB = IC + ENDDO + IC=ABS(IA) + NBSANG(1,IANG)=ITX/IC + NBSANG(2,IANG)=ITY/IC + NBSANG(4,IANG)=(ITX+ITY)/IC + ENDIF + NBSANG(4,IANG)=NBSANG(4,IANG)*NBSANG(3,IANG) + ENDDO + ELSE IF(ITYPBC.GE.2) THEN +*---- +* HEXAGONAL GEOMETRY +*---- + DO IANG=1,NBANGL + IF(NBANGL.EQ.3) THEN + INDC(1)=INDC_HEX3(1,IANG) + INDC(2)=INDC_HEX3(2,IANG) + ELSE IF(NBANGL.EQ.6) THEN + INDC(1)=INDC_HEX6(1,IANG) + INDC(2)=INDC_HEX6(2,IANG) + ELSE IF(NBANGL.EQ.12) THEN + INDC(1)=INDC_HEX12(1,IANG) + INDC(2)=INDC_HEX12(2,IANG) + ELSE IF(NBANGL.EQ.18) THEN + INDC(1)=INDC_HEX18(1,IANG) + INDC(2)=INDC_HEX18(2,IANG) + ELSE + CALL XABORT(NAMSBR//': NBANGL=3/6/12/18 mandatory') + ENDIF + CALL XELTSA(NDIM ,ITYPBC, ABSC ,INDC ,DNSANG(IANG) ,DDAX) + DANGLT(:NDIM,IANG,1)=DDAX(:NDIM,1) + DENLIN=DNSANG(IANG)/RCIRC + IF(INDC(1) .EQ. 0 .OR. INDC(2) .EQ. 0) THEN + DNSANG(IANG)= DENUSR + ELSE + NTRAC=MAX(1,INT(DENUSR/DENLIN+0.5D0)) + DNSANG(IANG)=DBLE(NTRAC)*DENLIN + ENDIF + DDANG(IANG)=DANGLT(1,IANG,1) + NBSANG(:2,IANG)=INDC(:2) + NBSANG(3:5,IANG)=0 + ENDDO + ENDIF + DEALLOCATE(DDAX) +*---- +* 2. Get weights +*---- + CALL XELTCW(NBANGL,DDANG,DDENWT) + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6011) + DO IANG=1,NBANGL + IF(DDENWT(IANG,1) .GT. DZERO) THEN + WRITE(IOUT,6012) IANG,(NBSANG(IDIR,IANG),IDIR=1,4), + > (DANGLT(IDIR,IANG,1),IDIR=1,NDIM), + > DDENWT(IANG,1) + ENDIF + ENDDO + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* 3. Compute density +*---- + DO IANG=1,NBANGL + DDENWT(IANG,1)=DTWO/DDENWT(IANG,1) + ENDDO + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(1X,' NDIM =',I8,1X,'AZMQUA=',I8,1X,'NANGL =',I8 + > ,1X,'NBANGL=',I8,1X,'ITYPBC=',I8) + 6011 FORMAT(' NXTQAC: Tracking directions and weights '/ + > 1X,' Angle',1X,' Segments',33X, + > 1X,' Directions and weight') + 6012 FORMAT(5(1X,I10),4(2X,F24.14)) + END diff --git a/Dragon/src/NXTQAS.f b/Dragon/src/NXTQAS.f new file mode 100644 index 0000000..7bebadf --- /dev/null +++ b/Dragon/src/NXTQAS.f @@ -0,0 +1,150 @@ +*DECK NXTQAS + SUBROUTINE NXTQAS(IPRINT,NDIM ,AZMQUA,NANGL ,NQUAD ,NBANGL, + > DQUAD ,DANGLT,DDENWT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To define quadrature angles for a given tracking option. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau, R. Roy, M. Hampartzounian +* +*Parameters: input +* IPRINT print level. +* NDIM number of dimensions for geometry. +* AZMQUA quadrature type. +* NANGL quadrature order. +* NQUAD number of quadrant (in 3-D) and quarter (in 2-D). +* NBANGL number of angles. +* DQUAD relative density of each quadrant. +* +*Parameters: output +* DANGLT angles. +* DDENWT angular density for each angle. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* Extracted from the subroutine XELTS2 of EXCELL. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,NDIM,AZMQUA,NANGL,NQUAD,NBANGL + DOUBLE PRECISION DQUAD(NQUAD) + DOUBLE PRECISION DANGLT(NDIM,NQUAD,NBANGL),DDENWT(NQUAD,NBANGL) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTQAS') + DOUBLE PRECISION DZERO,DONE,DTWO + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Functions +*---- + DOUBLE PRECISION XDRCST,PI +*---- +* Local variables +*---- + INTEGER IANG,IQUAD,IDIR + DOUBLE PRECISION DTHETA,THETA,DDA,COST,SINT +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6010) NDIM,AZMQUA,NANGL,NQUAD + ENDIF + PI=XDRCST('Pi',' ') + IF(NDIM .EQ. 2) THEN + IF(AZMQUA .EQ. 1) THEN +*---- +* Trapezoidal quadrature +* NBANGL point quadrature for both: +* (1/2*Pi)*Integral(0,Pi/2) and (1/2*Pi)*Integral(Pi/2,Pi) +* Quadrature weight = Pi/(2*NBANGL) +* DENSITY=(2*Pi)/weight=4*NBANGL +*---- + THETA =PI/DBLE(4*NANGL) + DTHETA=DTWO*THETA + DDA=DBLE(4*NBANGL) + DO IANG=1,NBANGL + COST=COS(THETA) + SINT=SIN(THETA) + DANGLT(1,1,IANG)=COS(THETA) + DANGLT(2,1,IANG)=SIN(THETA) + DDENWT(1,IANG)=DQUAD(1)*DDA + DANGLT(1,2,IANG)=-SIN(THETA) + DANGLT(2,2,IANG)=COS(THETA) + DDENWT(2,IANG)=DQUAD(2)*DDA + THETA=THETA+DTHETA + ENDDO + ELSE + WRITE(IOUT,9000) NAMSBR,AZMQUA + CALL XABORT(NAMSBR//': INVALID QUADRATURE OPTION IN 2D') + ENDIF + ELSE IF(NDIM .EQ. 3) THEN + IF(AZMQUA .EQ. 1) THEN + CALL NXTQEW(NDIM ,NANGL ,NQUAD ,NBANGL,DQUAD , + > DANGLT,DDENWT) + ELSE IF(AZMQUA .EQ. 4) THEN + CALL NXTQLC(NDIM ,NANGL ,NQUAD ,NBANGL,DQUAD , + > DANGLT,DDENWT) + ELSE IF(AZMQUA .EQ. 5) THEN + CALL NXTQLT(NDIM ,NANGL ,NQUAD ,NBANGL,DQUAD , + > DANGLT,DDENWT) + ELSE IF(AZMQUA .EQ. 6) THEN + CALL NXTLSN(NDIM ,NANGL ,NQUAD ,NBANGL,DQUAD , + > DANGLT,DDENWT) + ELSE IF(AZMQUA .EQ. 7) THEN + CALL NXTQRN(NDIM ,NANGL ,NQUAD ,NBANGL,DQUAD , + > DANGLT,DDENWT) + ENDIF + ENDIF +*---- +* Processing finished: return +*---- + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6011) + DO IANG=1,NBANGL + DO IQUAD=1,NQUAD + IF(DDENWT(IQUAD,IANG) .GT. DZERO) THEN + WRITE(IOUT,6012) IANG,IQUAD, + > (DANGLT(IDIR,IQUAD,IANG),IDIR=1,NDIM), + > DDENWT(IQUAD,IANG) + ENDIF + ENDDO + ENDDO + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(1X,'NDIM =',I8,1X,'AZMQUA=',I8, + > 1X,'NANGL =',I8,1X,'NQUAD =',I8) + 6011 FORMAT(' Tracking directions and weights '/ + > 1X,' Angle',1X,' Quadrant', + > 1X,' Directions and weight') + 6012 FORMAT(2(1X,I10),4(2X,F24.14)) + 9000 FORMAT(A6,': AZMQUA=',I5,' is invalid in 2D') + END diff --git a/Dragon/src/NXTQEW.f b/Dragon/src/NXTQEW.f new file mode 100644 index 0000000..22a9efd --- /dev/null +++ b/Dragon/src/NXTQEW.f @@ -0,0 +1,168 @@ +*DECK NXTQEW + SUBROUTINE NXTQEW(NDIM ,NANGL ,NQUAD ,NBANGL,DQUAD, + > DANGLT,DDENWT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To define quadrature angles for a given tracking option. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau, R. Roy, M. Hampartzounian +* +*Parameters: input +* NDIM number of dimensions for geometry. +* NANGL quadrature order. +* NQUAD number of quadrant (in 3-D) and quarter (in 2-D). +* NBANGL number of angles. +* DQUAD relative density of each quadrant. +* +*Parameters: output +* DANGLT director cosines of angles. +* DDENWT angular density for each angle. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* \\\\ +* Extracted from the subroutine XELTS2 of EXCELL. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NDIM,NANGL,NQUAD,NBANGL + DOUBLE PRECISION DQUAD(NQUAD) + DOUBLE PRECISION DANGLT(NDIM,NQUAD,NBANGL),DDENWT(NQUAD,NBANGL) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTQEW') + DOUBLE PRECISION DZERO,DONE,DTWO + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Local variables +*---- + INTEGER IANG,NO2,IPOS,ICUR,IEND + DOUBLE PRECISION DDA,X,Y,Z +*---- +* Data +*---- + INTEGER INSN( 9),JNMU( 9),MUT(120), ETT(120),XHT(120) + REAL SNT (63) + SAVE INSN,JNMU,MUT,ETT,XHT,SNT + DATA INSN/ 0, 1, 3, 7, 13, 21, 32, 46, 63/ + DATA JNMU/ 0, 1, 4, 10, 20, 35, 56, 84,120/ + DATA MUT / 1, + > 1, 1, 2, + > 1, 3, 1, 4, 4, 2, + > 1, 3, 3, 1, 4, 6, 4, 5, 5, 2, + > 1, 3, 3, 3, 1, 5, 7, 7, 5, 4, + > 8, 4, 6, 6, 2, + > 1, 3, 3, 3, 3, 1, 4, 8, 10, 8, + > 4, 6, 11, 11, 6, 7, 9, 7, 5, 5, + > 2, + > 1, 3, 3, 3, 3, 3, 1, 4, 9, 11, + > 11, 9, 4, 6, 12, 14, 12, 6, 8, 13, + > 13, 8, 7, 10, 7, 5, 5, 2, + > 1, 3, 3, 3, 3, 3, 3, 1, 4, 10, + > 12, 12, 12, 10, 4, 6, 13, 16, 16, 13, + > 6, 8, 15, 17, 15, 8, 9, 14, 14, 9, + > 7, 11, 7, 5, 5, 2/ + DATA ETT / 1, + > 1, 2, 1, + > 1, 4, 2, 3, 4, 1, + > 1, 4, 5, 2, 3, 6, 5, 3, 4, 1, + > 1, 5, 4, 6, 2, 3, 7, 8, 6, 3, + > 7, 4, 3, 5, 1, + > 1, 4, 6, 7, 5, 2, 3, 8, 11, 9, + > 5, 3, 10, 11, 7, 3, 8, 6, 3, 4, + > 1, + > 1, 4, 6, 8, 7, 5, 2, 3, 9, 12, + > 13, 10, 5, 3, 11, 14, 13, 7, 3, 11, + > 12, 8, 3, 9, 6, 3, 4, 1, + > 1, 4, 6, 8, 9, 7, 5, 2, 3, 10, + > 13, 15, 14, 11, 5, 3, 12, 16, 17, 14, + > 7, 3, 12, 16, 15, 9, 3, 12, 13, 8, + > 3, 10, 6, 3, 4, 1/ + DATA XHT / 1, + > 2, 1, 1, + > 2, 4, 1, 4, 3, 1, + > 2, 5, 4, 1, 5, 6, 3, 4, 3, 1, + > 2, 6, 4, 5, 1, 6, 8, 7, 3, 4, + > 7, 3, 5, 3, 1, + > 2, 5, 7, 6, 4, 1, 5, 9, 11, 8, + > 3, 7, 11, 10, 3, 6, 8, 3, 4, 3, + > 1, + > 2, 5, 7, 8, 6, 4, 1, 5, 10, 13, + > 12, 9, 3, 7, 13, 14, 11, 3, 8, 12, + > 11, 3, 6, 9, 3, 4, 3, 1, + > 2, 5, 7, 9, 8, 6, 4, 1, 5, 11, + > 14, 15, 13, 10, 3, 7, 14, 17, 16, 12, + > 3, 9, 15, 16, 12, 3, 8, 13, 12, 3, + > 6, 10, 3, 4, 3, 1/ + DATA SNT / .577350269, + > .350021174, .868890300, + > .2561429, .9320846, .2663443, .6815646, + > .1971380, .9603506, .2133981, .5512958, .8065570, .5773503, + > .1631408, .9730212, .1755273, .6961286, .4567576, .8721024, + > .4897749, .7212773, .1370611, .9810344, .1497456, .3911744, + > .9080522, .6040252, .7827706, .4213515, .8030727, .4249785, + > .6400755, + > .1196230, .9855865, .1301510, .3399238, .9314035, .5326134, + > .8362916, .7010923, .3700559, .8521252, .3736108, .5691823, + > .7324250, .577350269, + > .1050159, .9889102, .1152880, .3016701, .9464163, .4743525, + > .8727534, .6327389, .7657351, .3284315, .8855877, .3332906, + > .5107319, .7925089, .6666774, .5215431, .6752671/ +*---- +* Start processing +*---- + DDA=DBLE(8*NBANGL) + NO2 = NANGL/2 + IPOS = INSN( NO2 ) + ICUR = JNMU( NO2 ) + IEND = JNMU( NO2 + 1) + DO IANG=1,NBANGL + ICUR=ICUR+1 + X = DBLE(SNT( MUT(ICUR) + IPOS )) + Y = DBLE(SNT( ETT(ICUR) + IPOS )) + Z = DBLE(SNT( XHT(ICUR) + IPOS )) + DANGLT(1,1,IANG)=X + DANGLT(2,1,IANG)=Y + DANGLT(3,1,IANG)=Z + DDENWT(1,IANG)=DQUAD(1)*DDA + DANGLT(1,2,IANG)=-X + DANGLT(2,2,IANG)=Y + DANGLT(3,2,IANG)=Z + DDENWT(2,IANG)=DQUAD(2)*DDA + DANGLT(1,3,IANG)=X + DANGLT(2,3,IANG)=-Y + DANGLT(3,3,IANG)=Z + DDENWT(3,IANG)=DQUAD(3)*DDA + DANGLT(1,4,IANG)=-X + DANGLT(2,4,IANG)=-Y + DANGLT(3,4,IANG)=Z + DDENWT(4,IANG)=DQUAD(4)*DDA + ENDDO +*---- +* Processing finished: return +*---- + RETURN +*---- +* Output formats +*---- + END diff --git a/Dragon/src/NXTQLC.f b/Dragon/src/NXTQLC.f new file mode 100644 index 0000000..a12f62f --- /dev/null +++ b/Dragon/src/NXTQLC.f @@ -0,0 +1,388 @@ +*DECK NXTQLC + SUBROUTINE NXTQLC(NDIM ,ORDRE ,NQUAD ,NBANGL,DQUAD , + > DANGLT,DDENWT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To define Legendre-Chebyshev quadrature angles. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* M. Hampartzounian +* +*Parameters: input +* NDIM number of dimensions for geometry. +* ORDRE quadrature order. +* NQUAD number of quadrant (in 3-D) and quarter (in 2-D). +* NBANGL number of angles. +* DQUAD relative density of each quadrant. +* +*Parameters: output +* DANGLT director cosines of angles. +* DDENWT angular density for each angle. +* +*Reference: +* G. Longoni, A. Haghighat, +* Development of New Quadrature Sets with the +* Ordinate Splitting Technique, +* M+C 2001, Salt Lake City, September 2001. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NDIM,ORDRE,NQUAD,NBANGL + DOUBLE PRECISION DQUAD(NQUAD),DANGLT(NDIM,NQUAD,NBANGL), + > DDENWT(NQUAD,NBANGL) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTQLC') + DOUBLE PRECISION DZERO,DONE,DTWO + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Functions +*---- + DOUBLE PRECISION XDRCST,PI +*---- +* Local variables +*---- + INTEGER NBPT,ILEVEL,JLEVEL,NLEVEL,KLEVEL,IPOINT, + > IPT,IROT,IDIR1,IDIR2,IDIR3 + DOUBLE PRECISION ALPHA,XI,ROTXI,COSA,SINA,WGTINV +*---- +* Data +*---- + INTEGER IS,IA + DOUBLE PRECISION SYST(2,253) + SAVE SYST +*---- +* Order = 2 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 1, 1)/ + > 0.577350269189626D0,1.0D0/ +*---- +* Order = 4 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 2, 3)/ + > 0.33998104358486D0,0.32607257743127D0,0.86113631159405D0, + > 0.34785484513745D0/ +*---- +* Order = 6 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 4, 6)/ + > 0.23861918608320D0,0.15597131152423D0,0.66120938646626D0, + > 0.18038078652407D0,0.93246951420315D0,0.17132449237917D0/ +*---- +* Order = 8 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 7, 10)/ + > 0.18343464249565D0,0.09067094584459D0,0.52553240991633D0, + > 0.10456888195930D0,0.79666647741362D0,0.11119051722669D0, + > 0.96028985649754D0,0.10122853629037D0/ +*---- +* Order = 10 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 11, 15)/ + > 0.14887433898163D0,0.05910484494295D0,0.43339539412925D0, + > 0.06731667982750D0,0.67940956829902D0,0.07302878750533D0, + > 0.86506336668898D0,0.07472567457529D0,0.97390652851718D0, + > 0.06667134430868D0/ +*---- +* Order = 12 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 16, 21)/ + > 0.12523340851147D0,0.04152450763557D0,0.36783149899818D0, + > 0.04669850730767D0,0.58731795428663D0,0.05079185668077D0, + > 0.76990267419428D0,0.05335944284779D0,0.90411725637050D0, + > 0.05346966299765D0,0.98156063424671D0,0.04717533638653D0/ +*---- +* Order = 14 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 22, 28)/ + > 0.10805494870734D0,0.03075197906617D0,0.31911236892789D0, + > 0.03419974395355D0,0.51524863635816D0,0.03710767949559D0, + > 0.68729290481172D0,0.03930079178955D0,0.82720131506965D0, + > 0.04050619022934D0,0.92843488366371D0,0.04007904357982D0, + > 0.98628380869675D0,0.03511946033190D0/ +*---- +* Order = 16 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 29, 36)/ + > 0.09501250983764D0,0.02368132630688D0,0.28160355077926D0, + > 0.02608620214927D0,0.45801677765726D0,0.02819275323250D0, + > 0.61787624440245D0,0.02991919776332D0,0.75540440835553D0, + > 0.03115724281390D0,0.86563120238710D0,0.03171950389411D0, + > 0.94457502307371D0,0.03112676196937D0,0.98940093499154D0, + > 0.02715245941196D0/ +*---- +* Order = 18 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 37, 45)/ + > 0.08477501304174D0,0.01879359810702D0,0.25188622569150D0, + > 0.02053456046823D0,0.41175116146291D0,0.02209781073233D0, + > 0.55977083107372D0,0.02344048577842D0,0.69168704306110D0, + > 0.02451104134236D0,0.80370495897046D0,0.02523551102634D0, + > 0.89260246650148D0,0.02547524341783D0,0.95582394956707D0, + > 0.02485727444991D0,0.99156516842283D0,0.02161601352180D0/ +*---- +* Order = 20 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 46, 55)/ + > 0.07652652113350D0,0.01527533871307D0,0.22778585114165D0, + > 0.01657477627473D0,0.37370608871523D0,0.01776201366480D0, + > 0.51086700195199D0,0.01881266263554D0,0.63605368072293D0, + > 0.01969908866072D0,0.74633190646642D0,0.02038602396117D0, + > 0.83911697181714D0,0.02081918540086D0,0.91223442824898D0, + > 0.02089068276635D0,0.96397192728679D0,0.02030071490687D0, + > 0.99312859917998D0,0.01761400714924D0/ +*---- +* Order = 22 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 56, 66)/ + > 0.06973927331972D0,0.01265926116869D0,0.20786042668821D0, + > 0.01365414983460D0,0.34193582089230D0,0.01457483386523D0, + > 0.46935583798525D0,0.01540654710137D0,0.58764040351215D0, + > 0.01613318515391D0,0.69448726317471D0,0.01673569074235D0, + > 0.78781680600113D0,0.01718832124013D0,0.86581257768321D0, + > 0.01744911712470D0,0.92695677224150D0,0.01743111170530D0, + > 0.97006049778158D0,0.01688745083050D0,0.99429458550512D0, + > 0.01462799524418D0/ +*---- +* Order = 24 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 67, 78)/ + > 0.06405689286261D0,0.01066151627890D0,0.19111886747361D0, + > 0.01143976875880D0,0.31504267969640D0,0.01216704729278D0, + > 0.43379350762497D0,0.01283396311708D0,0.54542147138999D0, + > 0.01343053376483D0,0.64809365193896D0,0.01394552172544D0, + > 0.74012419158451D0,0.01436502694016D0,0.82000198588723D0, + > 0.01466929621748D0,0.88641552731297D0,0.01482464636908D0, + > 0.93827455142585D0,0.01475914616380D0,0.97472855656607D0, + > 0.01426569422080D0,0.99518721974900D0,0.01234123034267D0/ +*---- +* Order = 26 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 79, 91)/ + > 0.05923009342931D0,0.00910164732917D0,0.17685882035693D0, + > 0.00972170362377D0,0.29200483948558D0,0.01030561968603D0, + > 0.40305175512448D0,0.01084718405284D0,0.50844071482581D0, + > 0.01133990678847D0,0.60669229300123D0,0.01177672504332D0, + > 0.69642726048349D0,0.01214941348255D0,0.77638594865137D0, + > 0.01244735829575D0,0.84544594311257D0,0.01265480931773D0, + > 0.90263786157297D0,0.01274395622539D0,0.94715906696364D0, + > 0.01265412770351D0,0.97838544586603D0,0.01220892547636D0, + > 0.99588570114160D0,0.01055137268743D0/ +*---- +* Order = 28 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 92,105)/ + > 0.05507928988403D0,0.00786050092975D0,0.16456928213333D0, + > 0.00836239940448D0,0.27206162763654D0,0.00883798049356D0, + > 0.37625151607709D0,0.00928299705271D0,0.47587422501394D0, + > 0.00969306579864D0,0.56972047161791D0,0.01006352716248D0, + > 0.65665109450180D0,0.01038917711347D0,0.73561087718791D0, + > 0.01066374513244D0,0.80564137195850D0,0.01087881964355D0, + > 0.86589252190936D0,0.01102147166953D0,0.91563302581684D0, + > 0.01106822904179D0,0.95425928269356D0,0.01096714930000D0, + > 0.98130316299531D0,0.01056605251579D0,0.99644249859202D0, + > 0.00912428140132D0/ +*---- +* Order = 30 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=106,120)/ + > 0.05147184255532D0,0.00685684352624D0,0.15386991360868D0, + > 0.00726874212489D0,0.25463692616461D0,0.00766103235284D0, + > 0.35270472554884D0,0.00803072809779D0,0.44703376949342D0, + > 0.00837477474924D0,0.53662414821306D0,0.00868997871608D0, + > 0.62052618288637D0,0.00897287728847D0,0.69785049482498D0, + > 0.00921949657093D0,0.76777743319354D0,0.00942489107957D0, + > 0.82956575621336D0,0.00958219000643D0,0.88256055526296D0, + > 0.00968054393272D0,0.92620000651698D0,0.00969978543893D0, + > 0.96002192312100D0,0.00959491170268D0,0.98366807161209D0, + > 0.00923324554691D0,0.99689350414176D0,0.00796814638786D0/ +*---- +* Order = 32 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=121,136)/ + > 0.04830766568774D0,0.00603375553217D0,0.14447196158186D0, + > 0.00637591467195D0,0.23928736227279D0,0.00670317136284D0, + > 0.33186860213190D0,0.00701337528509D0,0.42135127674309D0, + > 0.00730434107922D0,0.50689990719947D0,0.00757381130805D0, + > 0.58771576112490D0,0.00781938956129D0,0.66304425908752D0, + > 0.00803842135657D0,0.73218213532892D0,0.00822777972086D0, + > 0.79448375640681D0,0.00838343484386D0,0.84936770896391D0, + > 0.00849970145691D0,0.89632095843854D0,0.00856713191057D0, + > 0.93490639505449D0,0.00856850293792D0,0.96476187795073D0, + > 0.00846401442985D0,0.98561180730897D0,0.00813711928812D0, + > 0.99726375488382D0,0.00701885042221D0/ +*---- +* Order = 34 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=137,153)/ + > 0.04550982195310D0,0.00535039649002D0,0.13615235725880D0, + > 0.00563769027317D0,0.22566669163722D0,0.00591345985566D0, + > 0.31331108104631D0,0.00617612426888D0,0.39835927975331D0, + > 0.00642408458066D0,0.48010653651464D0,0.00665570376058D0, + > 0.55787552837148D0,0.00686927018743D0,0.63102165671823D0, + > 0.00706293794571D0,0.69893926435390D0,0.00723461457806D0, + > 0.76106458437911D0,0.00738175933892D0,0.81688476588987D0, + > 0.00750110078301D0,0.86593368730159D0,0.00758751425230D0, + > 0.90781120740225D0,0.00763351850909D0,0.94216032905008D0, + > 0.00762273892258D0,0.96871043413727D0,0.00752113249273D0, + > 0.98722623909002D0,0.00722576516252D0,0.99757230194591D0, + > 0.00622779370687D0/ +*---- +* Order = 36 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=154,171)/ + > 0.04301819847371D0,0.00477684864836D0,0.12873610380802D0, + > 0.00502039327879D0,0.21350089236042D0,0.00525488868613D0, + > 0.29668499489157D0,0.00547915111524D0,0.37767254966703D0, + > 0.00569198776656D0,0.45586393486895D0,0.00589218549996D0, + > 0.53068031264856D0,0.00607849018656D0,0.60156759861950D0, + > 0.00624957522881D0,0.66800134713266D0,0.00640398037611D0, + > 0.72948900231201D0,0.00654000932504D0,0.78557638994910D0, + > 0.00665561122424D0,0.83584737503067D0,0.00674782531543D0, + > 0.87992821829261D0,0.00681274160010D0,0.91750240344171D0, + > 0.00684271263501D0,0.94826416091557D0,0.00682558556827D0, + > 0.97203921707055D0,0.00672476115101D0,0.98857686223253D0, + > 0.00646291222847D0,0.99783406138946D0,0.00555667184560D0/ +*---- +* Order = 38 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=172,190)/ + > 0.04078514790459D0,0.00429079101476D0,0.12208402533452D0, + > 0.00449902743170D0,0.20257045398628D0,0.00470006077885D0, + > 0.28170880888511D0,0.00489299029385D0,0.35897244495443D0, + > 0.00507691088444D0,0.43384715631935D0,0.00525090669126D0, + > 0.50583473801940D0,0.00541403881989D0,0.57445603748646D0, + > 0.00556532827760D0,0.63925418826503D0,0.00570372124187D0, + > 0.69979962680485D0,0.00582803437120D0,0.75568295130273D0, + > 0.00593692197056D0,0.80655201425815D0,0.00602847883995D0, + > 0.85201700089545D0,0.00610101854081D0,0.89189086124464D0, + > 0.00614733110727D0,0.92568500732863D0,0.00617630505125D0, + > 0.95353898729968D0,0.00613319286783D0,0.97477439677976D0, + > 0.00607355513150D0,0.98978922946055D0,0.00577832504734D0, + > 0.99803301416225D0,0.00504805879326D0/ +*---- +* Order = 40 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=191,210)/ + > 0.03877241750606D0,0.00387529739892D0,0.11608407067269D0, + > 0.00405472727181D0,0.19269758075384D0,0.00422835343883D0, + > 0.26815218442225D0,0.00439548053431D0,0.34199409501760D0, + > 0.00455541138509D0,0.41377918521708D0,0.00470744324502D0, + > 0.48307585742886D0,0.00485086018626D0,0.54946703621944D0, + > 0.00498492376041D0,0.61255384817576D0,0.00510886273005D0, + > 0.67195746920806D0,0.00522174107642D0,0.72731518674779D0, + > 0.00532302904828D0,0.77831437316505D0,0.00540964292729D0, + > 0.82459057917465D0,0.00548656553689D0,0.86600919232031D0, + > 0.00553340517150D0,0.90199639822285D0,0.00558997462627D0, + > 0.93299517738927D0,0.00556748623087D0,0.95765721118329D0, + > 0.00561397264950D0,0.97754603471325D0,0.00541857778427D0, + > 0.99051106402526D0,0.00539644941610D0,0.99831206210441D0, + > 0.00434333104876D0/ +*---- +* Order = 42 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=211,231)/ + > 0.03694894316534D0,0.00351734448725D0,0.11064502720743D0, + > 0.00367304067267D0,0.18373680686444D0,0.00382400922292D0, + > 0.25582507379698D0,0.00396970636014D0,0.32651616975104D0, + > 0.00410958765725D0,0.39542362251945D0,0.00424310738074D0, + > 0.46217274386666D0,0.00436970393775D0,0.52639343800021D0, + > 0.00448884199956D0,0.58774968956786D0,0.00459981369037D0, + > 0.64587456004057D0,0.00470237199319D0,0.70050533824065D0, + > 0.00479452034217D0,0.75127821879747D0,0.00488025174105D0, + > 0.79791981602651D0,0.00494337495192D0,0.84045950845072D0, + > 0.00502154054607D0,0.87755806345153D0,0.00503689455872D0, + > 0.91197509273697D0,0.00517770715670D0,0.93729218041353D0, + > 0.00526592418727D0,0.96414624148124D0,0.00570793259377D0, + > 0.97695704453476D0,0.00690539560442D0,0.99322113425436D0, + > 0.00541384107796D0,0.99769796354612D0,0.00754180253610D0/ +*---- +* Order = 44 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=232,253)/ + > 0.03528923696410D0,0.00320677989952D0,0.10569190169021D0, + > 0.00334274692733D0,0.17556801710226D0,0.00347482459015D0, + > 0.24456941646933D0,0.00360258272163D0,0.31235278934078D0, + > 0.00372559021852D0,0.37857772181427D0,0.00384342407853D0, + > 0.44292618820931D0,0.00395560422690D0,0.50503688871692D0, + > 0.00406188071758D0,0.56471466385375D0,0.00416116332728D0, + > 0.62139067754562D0,0.00425481282618D0,0.67534196136471D0, + > 0.00433842941591D0,0.72528399895512D0,0.00441848009213D0, + > 0.77261708065981D0,0.00448920279793D0,0.81468343050057D0, + > 0.00453553695561D0,0.85451710591231D0,0.00462393394081D0, + > 0.88796251449581D0,0.00457908321421D0,0.91913386326312D0, + > 0.00479985160516D0,0.94407409289036D0,0.00460697658507D0, + > 0.96484471190689D0,0.00431337311996D0,0.98174671963958D0, + > 0.00476874072667D0,0.99175403861920D0,0.00484009055849D0, + > 0.99874459587735D0,0.00339611207931D0/ +*---- +* Start processing +*---- + PI=XDRCST('Pi',' ') + NBPT=(ORDRE*(ORDRE+2))/8 + IF(3*NBPT .NE. NBANGL) CALL XABORT(NAMSBR// + >': Number of quadrature points is invalid') + ILEVEL=1 + JLEVEL=0 + NLEVEL=ORDRE/2 + KLEVEL=(NLEVEL*(NLEVEL-1))/2 + IPOINT=0 + DO IPT=1,NBPT + JLEVEL = JLEVEL + 1 + ALPHA =PI*(DBLE(NLEVEL-ILEVEL+1-JLEVEL)+DONE/DTWO) + > /(DTWO*DBLE(NLEVEL-ILEVEL+1)) + XI=SYST(1,KLEVEL+ILEVEL) + ROTXI=SQRT(DONE-XI**2) + COSA=COS(ALPHA) + SINA=SIN(ALPHA) + WGTINV=24.0D0/SYST(2,KLEVEL+ILEVEL) + DO IROT=1,3 +*---- +* \xi direction (3) +* \mu direction (2) +* \eta direction (1) +*---- + IDIR1=MOD(IROT-1,3)+1 + IDIR2=MOD(IROT,3)+1 + IDIR3=MOD(IROT+1,3)+1 + IPOINT=IPOINT+1 + DDENWT(1,IPOINT)=DQUAD(1)*WGTINV + DANGLT(IDIR1,1,IPOINT)=COSA*ROTXI + DANGLT(IDIR2,1,IPOINT)=SINA*ROTXI + DANGLT(IDIR3,1,IPOINT)=XI + DDENWT(2,IPOINT)=DQUAD(2)*WGTINV + DANGLT(1,2,IPOINT)=-DANGLT(1,1,IPOINT) + DANGLT(2,2,IPOINT)=DANGLT(2,1,IPOINT) + DANGLT(3,2,IPOINT)=DANGLT(3,1,IPOINT) + DDENWT(3,IPOINT)=DQUAD(3)*WGTINV + DANGLT(1,3,IPOINT)=DANGLT(1,1,IPOINT) + DANGLT(2,3,IPOINT)=-DANGLT(2,1,IPOINT) + DANGLT(3,3,IPOINT)=DANGLT(3,1,IPOINT) + DDENWT(4,IPOINT)=DQUAD(4)*WGTINV + DANGLT(1,4,IPOINT)=-DANGLT(1,1,IPOINT) + DANGLT(2,4,IPOINT)=-DANGLT(2,1,IPOINT) + DANGLT(3,4,IPOINT)=DANGLT(3,1,IPOINT) + ENDDO + IF(JLEVEL .EQ. NLEVEL-ILEVEL+1) THEN + ILEVEL = ILEVEL + 1 + JLEVEL = 0 + ENDIF + ENDDO + RETURN + END diff --git a/Dragon/src/NXTQLT.f b/Dragon/src/NXTQLT.f new file mode 100644 index 0000000..7ac1ed1 --- /dev/null +++ b/Dragon/src/NXTQLT.f @@ -0,0 +1,560 @@ +*DECK NXTQLT + SUBROUTINE NXTQLT(NDIM ,ORDRE ,NQUAD ,NBANGL,DQUAD , + > DANGLT,DDENWT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To define Sanchez-Mao-Santandrea (Legendre-Trapezoidal) +* quadrature angles. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* M. Hampartzounian +* +*Parameters: input +* NDIM number of dimensions for geometry. +* ORDRE quadrature order. +* NQUAD number of quadrant (in 3-D) and quarter (in 2-D). +* NBANGL number of angles. +* DQUAD relative density of each quadrant. +* +*Parameters: output +* DANGLT director cosines of angles. +* DDENWT angular density for each angle. +* +*Reference: +* R. Sanchez, L. Mao, S. Santandrea +* Treatment of boundary conditions in trajectory-based deterministic +* transport methods, +* Nucl. Sci. Eng. 140, 23-50 (2002), +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NDIM,ORDRE,NQUAD,NBANGL + DOUBLE PRECISION DQUAD(NQUAD),DANGLT(NDIM,NQUAD,NBANGL), + > DDENWT(NQUAD,NBANGL) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTQLT') + DOUBLE PRECISION DZERO,DONE,DTWO + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Functions +*---- + DOUBLE PRECISION XDRCST,PI +*---- +* Local variables +*---- + INTEGER NBPT,ILEVEL,JLEVEL,NLEVEL,KLEVEL,IPOINT, + > IPT,IROT,IDIR1,IDIR2,IDIR3 + DOUBLE PRECISION ALPHA,XI,ROTXI,COSA,SINA,WGTINV +*---- +* Data +*---- + INTEGER IS,IA + DOUBLE PRECISION SYST(2,504) + SAVE SYST +*---- +* Order = 4 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 1, 4)/ + > 6.9431844202970D-02,3.4785484513745D-01,3.3000947820757D-01, + > 6.5214515486255D-01,6.6999052179243D-01,6.5214515486255D-01, + > 9.3056815579703D-01,3.4785484513745D-01/ +*---- +* Order = 6 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 5, 10)/ + > 3.3765242898420D-02,1.7132449237917D-01,1.6939530676687D-01, + > 3.6076157304814D-01,3.8069040695840D-01,4.6791393457269D-01, + > 6.1930959304160D-01,4.6791393457269D-01,8.3060469323313D-01, + > 3.6076157304814D-01,9.6623475710158D-01,1.7132449237917D-01/ +*---- +* Order = 8 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 11, 18)/ + > 1.9855071751230D-02,1.0122853629036D-01,1.0166676129319D-01, + > 2.2238103445338D-01,2.3723379504183D-01,3.1370664587789D-01, + > 4.0828267875218D-01,3.6268378337836D-01,5.9171732124782D-01, + > 3.6268378337836D-01,7.6276620495816D-01,3.1370664587789D-01, + > 8.9833323870681D-01,2.2238103445338D-01,9.8014492824877D-01, + > 1.0122853629037D-01/ +*---- +* Order = 10 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 19, 28)/ + > 1.3046735741410D-02,6.6671344308670D-02,6.7468316655510D-02, + > 1.4945134915058D-01,1.6029521585049D-01,2.1908636251599D-01, + > 2.8330230293538D-01,2.6926671931000D-01,4.2556283050918D-01, + > 2.9552422471475D-01,5.7443716949082D-01,2.9552422471475D-01, + > 7.1669769706462D-01,2.6926671931000D-01,8.3970478414951D-01, + > 2.1908636251598D-01,9.3253168334449D-01,1.4945134915059D-01, + > 9.8695326425859D-01,6.6671344308680D-02/ +*---- +* Order = 12 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 29, 40)/ + > 9.2196828766400D-03,4.7175336386520D-02,4.7941371814760D-02, + > 1.0693932599530D-01,1.1504866290286D-01,1.6007832854335D-01, + > 2.0634102285669D-01,2.0316742672306D-01,3.1608425050091D-01, + > 2.3349253653836D-01,4.3738329574427D-01,2.4914704581340D-01, + > 5.6261670425573D-01,2.4914704581340D-01,6.8391574949909D-01, + > 2.3349253653836D-01,7.9365897714331D-01,2.0316742672306D-01, + > 8.8495133709714D-01,1.6007832854336D-01,9.5205862818525D-01, + > 1.0693932599531D-01,9.9078031712336D-01,4.7175336386530D-02/ +*---- +* Order = 14 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 41, 54)/ + > 6.8580956516300D-03,3.5119460331920D-02,3.5782558168140D-02, + > 8.0158087159560D-02,8.6399342465180D-02,1.2151857068798D-01, + > 1.5635354759414D-01,1.5720316715816D-01,2.4237568182092D-01, + > 1.8553839747794D-01,3.4044381553606D-01,2.0519846372130D-01, + > 4.4597252564633D-01,2.1526385346316D-01,5.5402747435367D-01, + > 2.1526385346316D-01,6.5955618446394D-01,2.0519846372130D-01, + > 7.5762431817908D-01,1.8553839747794D-01,8.4364645240586D-01, + > 1.5720316715820D-01,9.1360065753483D-01,1.2151857068801D-01, + > 9.6421744183186D-01,8.0158087159640D-02,9.9314190434838D-01, + > 3.5119460331900D-02/ +*---- +* Order = 16 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 55, 70)/ + > 5.2995325042800D-03,2.7152459412220D-02,2.7712488463060D-02, + > 6.2253523938620D-02,6.7184398806490D-02,9.5158511682620D-02, + > 1.2229779582222D-01,1.2462897125565D-01,1.9106187779878D-01, + > 1.4959598881651D-01,2.7099161117137D-01,1.6915651939500D-01, + > 3.5919822461037D-01,1.8260341504492D-01,4.5249374508118D-01, + > 1.8945061045507D-01,5.4750625491882D-01,1.8945061045507D-01, + > 6.4080177538963D-01,1.8260341504492D-01,7.2900838882863D-01, + > 1.6915651939500D-01,8.0893812220122D-01,1.4959598881659D-01, + > 8.7770220417776D-01,1.2462897125559D-01,9.3281560119355D-01, + > 9.5158511682330D-02,9.7228751153686D-01,6.2253523938730D-02, + > 9.9470046749577D-01,2.7152459411960D-02/ +*---- +* Order = 18 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 71, 88)/ + > 4.2174157887900D-03,2.1616013522700D-02,2.2088025216130D-02, + > 4.9714548897730D-02,5.3698766749330D-02,7.6425730253100D-02, + > 9.8147520514900D-02,1.0094204410623D-01,1.5415647846934D-01, + > 1.2255520671199D-01,2.2011458446318D-01,1.4064291467052D-01, + > 2.9412441926854D-01,1.5468467512628D-01,3.7405688715425D-01, + > 1.6427648374583D-01,4.5761249347913D-01,1.6914238296314D-01, + > 5.4238750652087D-01,1.6914238296314D-01,6.2594311284575D-01, + > 1.6427648374583D-01,7.0587558073145D-01,1.5468467512629D-01, + > 7.7988541553686D-01,1.4064291467049D-01,8.4584352153055D-01, + > 1.2255520671182D-01,9.0185247948523D-01,1.0094204410536D-01, + > 9.4630123325074D-01,7.6425730253490D-02,9.7791197478354D-01, + > 4.9714548899820D-02,9.9578258421141D-01,2.1616013521800D-02/ +*---- +* Order = 20 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 89,108)/ + > 3.4357004104500D-03,1.7614007150210D-02,1.8014036355580D-02, + > 4.0601429811420D-02,4.3882785876460D-02,6.2672048300040D-02, + > 8.0441514090900D-02,8.3276741600820D-02,1.2683404676701D-01, + > 1.0193011980500D-01,1.8197315963847D-01,1.1819453196387D-01, + > 2.4456649902402D-01,1.3168863844884D-01,3.1314695564238D-01, + > 1.4209610931841D-01,3.8610707442917D-01,1.4917298647260D-01, + > 4.6173673943325D-01,1.5275338713073D-01,5.3826326056675D-01, + > 1.5275338713073D-01,6.1389292557083D-01,1.4917298647260D-01, + > 6.8685304435761D-01,1.4209610931841D-01,7.5543350097599D-01, + > 1.3168863844881D-01,8.1802684036147D-01,1.1819453196430D-01, + > 8.7316595323321D-01,1.0193011980587D-01,9.1955848590857D-01, + > 8.3276741603440D-02,9.5611721412449D-01,6.2672048299060D-02, + > 9.8198596364340D-01,4.0601429813730D-02,9.9656429958999D-01, + > 1.7614007149240D-02/ +*---- +* Order = 22 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=109,130)/ + > 2.8527072492200D-03,1.4627995247010D-02,1.4969751104280D-02, + > 3.3774901643520D-02,3.6521613885420D-02,5.2293335095080D-02, + > 6.7093711153550D-02,6.9796468469830D-02,1.0609159700204D-01, + > 8.5941606188540D-02,1.5275636841161D-01,1.0041414445572D-01, + > 2.0617979824426D-01,1.1293229607784D-01,2.6532208100729D-01, + > 1.2325237681093D-01,3.2903208955386D-01,1.3117350478704D-01, + > 3.9606978665589D-01,1.3654149834601D-01,4.6513036334014D-01, + > 1.3925187285563D-01,5.3486963665986D-01,1.3925187285563D-01, + > 6.0393021334411D-01,1.3654149834601D-01,6.7096791044615D-01, + > 1.3117350478703D-01,7.3467791899263D-01,1.2325237681097D-01, + > 7.9382020175607D-01,1.1293229607735D-01,8.4724363158736D-01, + > 1.0041414445407D-01,8.9390840300056D-01,8.5941606200660D-02, + > 9.3290628884161D-01,6.9796468498780D-02,9.6347838612075D-01, + > 5.2293335115910D-02,9.8503024889079D-01,3.3774901660990D-02, + > 9.9714729275256D-01,1.4627995244180D-02/ +*---- +* Order = 24 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=131,154)/ + > 2.4063901291700D-03,1.2341230372000D-02,1.2635721706040D-02, + > 2.8531388386830D-02,3.0862724302950D-02,4.4277438382250D-02, + > 5.6792236327600D-02,5.9298585401410D-02,8.9999007068280D-02, + > 7.3346481049510D-02,1.2993790420103D-01,8.6190161662710D-02, + > 1.7595317403327D-01,9.7618652078700D-02,2.2728926430427D-01, + > 1.0744427011825D-01,2.8310324618762D-01,1.1550566805371D-01, + > 3.4247866015179D-01,1.2167047292779D-01,4.0444056626320D-01, + > 1.2583745634683D-01,4.6797155356870D-01,1.2793819534675D-01, + > 5.3202844643130D-01,1.2793819534675D-01,5.9555943373680D-01, + > 1.2583745634683D-01,6.5752133984820D-01,1.2167047292778D-01, + > 7.1689675381249D-01,1.1550566805375D-01,7.7271073569499D-01, + > 1.0744427011862D-01,8.2404682596948D-01,9.7618652078090D-02, + > 8.7006209579226D-01,8.6190161640980D-02,9.1000099294361D-01, + > 7.3346481087380D-02,9.4320776365649D-01,5.9298585476300D-02, + > 9.6913727571292D-01,4.4277438491390D-02,9.8736427828303D-01, + > 2.8531388441590D-02,9.9759360987450D-01,1.2341230342670D-02/ +*---- +* Order = 26 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=155,180)/ + > 2.0571493979300D-03,1.0551372478230D-02,1.0807277149000D-02, + > 2.4417851310870D-02,2.6420466420930D-02,3.7962382661490D-02, + > 4.8681069290240D-02,5.0975824567110D-02,7.7277028398650D-02, + > 6.3274046733270D-02,1.1180702569448D-01,7.4684149647260D-02, + > 1.5178636975174D-01,8.5045894374660D-02,1.9665385350063D-01, + > 9.4213800342660D-02,2.4577964258707D-01,1.0205916109701D-01, + > 2.9847412243771D-01,1.0847184052832D-01,3.5399758025722D-01, + > 1.1336181654635D-01,4.1157058982154D-01,1.1666044348530D-01, + > 4.7038495328534D-01,1.1832141527926D-01,5.2961504671466D-01, + > 1.1832141527926D-01,5.8842941017846D-01,1.1666044348530D-01, + > 6.4600241974279D-01,1.1336181654634D-01,7.0152587756224D-01, + > 1.0847184052835D-01,7.5422035741290D-01,1.0205916109622D-01, + > 8.0334614650062D-01,9.4213800346540D-02,8.4821363024175D-01, + > 8.5045894377860D-02,8.8819297432568D-01,7.4684149774490D-02, + > 9.2272297155629D-01,6.3274046588660D-02,9.5131893078649D-01, + > 5.0975824901560D-02,9.7357953348182D-01,3.7962383110530D-02, + > 9.8919272293301D-01,2.4417850952720D-02,9.9794285057080D-01, + > 1.0551372687430D-02/ +*---- +* Order = 28 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=181,208)/ + > 1.7787507361200D-03,9.1242819013200D-03,9.3484183945100D-03, + > 2.1132105642860D-02,2.2870358829010D-02,3.2901447004060D-02, + > 4.2183486909730D-02,4.4272911704630D-02,6.7053739163560D-02, + > 5.5107356859860D-02,9.7179313984470D-02,6.5272918351540D-02, + > 1.3219456139385D-01,7.4646216042780D-02,1.7167445276944D-01, + > 8.3113416845760D-02,2.1513976417981D-01,9.0571744471660D-02, + > 2.6206288749644D-01,9.6930657986830D-02,3.1187424196090D-01, + > 1.0211296757971D-01,3.6396918618177D-01,1.0605576592271D-01, + > 4.1771535893334D-01,1.0871119225830D-01,4.7246035505798D-01, + > 1.1004701301648D-01,5.2753964494202D-01,1.1004701301648D-01, + > 5.8228464106666D-01,1.0871119225830D-01,6.3603081381827D-01, + > 1.0605576592271D-01,6.8812575803855D-01,1.0211296757984D-01, + > 7.3793711250697D-01,9.6930657986390D-02,7.8486023580895D-01, + > 9.0571744462330D-02,8.2832554725090D-01,8.3113416907730D-02, + > 8.6780543859396D-01,7.4646215927060D-02,9.0282068597925D-01, + > 6.5272917861280D-02,9.3294626095468D-01,5.5107358347670D-02, + > 9.5781651290842D-01,4.4272916167160D-02,9.7712964134678D-01, + > 3.2901447900010D-02,9.9065158149766D-01,2.1132105031590D-02, + > 9.9822124929601D-01,9.1242814013200D-03/ +*---- +* Order = 30 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=209,238)/ + > 1.5532485245000D-03,7.9681492978800D-03,8.1659624471000D-03, + > 1.8466488024340D-02,1.9989040923200D-02,2.8784730112930D-02, + > 3.6899994297500D-02,3.8799132805590D-02,5.8719724174400D-02, + > 4.8402711046290D-02,8.5217120885420D-02,5.7493137284820D-02, + > 1.1611128380469D-01,6.5974238311800D-02,1.5107475249786D-01, + > 7.3755972731830D-02,1.8973690854755D-01,8.0755895518740D-02, + > 2.3168792591022D-01,8.6899787157000D-02,2.7648311524657D-01, + > 9.2122522243050D-02,3.2364763722693D-01,9.6368737173560D-02, + > 3.7268153691758D-01,9.9593420586940D-02,4.2306504319566D-01, + > 1.0176238974840D-01,4.7426407872234D-01,1.0285265289356D-01, + > 5.2573592127766D-01,1.0285265289356D-01,5.7693495680434D-01, + > 1.0176238974840D-01,6.2731846308230D-01,9.9593420586970D-02, + > 6.7635236277442D-01,9.6368737173430D-02,7.2351688474671D-01, + > 9.2122522241670D-02,7.6831207410653D-01,8.6899787160750D-02, + > 8.1026309144319D-01,8.0755895596270D-02,8.4892524741249D-01, + > 7.3755972567420D-02,8.8388871659677D-01,6.5974237557010D-02, + > 9.1478287810668D-01,5.7493140038600D-02,9.4128027763148D-01, + > 4.8402719663580D-02,9.6310000325849D-01,3.8799141755710D-02, + > 9.8001096156050D-01,2.8784735108050D-02,9.9183403580605D-01, + > 1.8466491093820D-02,9.9844675207088D-01,7.9681463878600D-03/ +*---- +* Order = 32 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=239,268)/ + > 1.3681250584000D-03,7.0188717221400D-03,7.1940901808000D-03, + > 1.6274246803780D-02,1.7619066947310D-02,2.5391984208800D-02, + > 3.2546800454970D-02,3.4274064691520D-02,5.1839518680800D-02, + > 4.2835695461780D-02,7.5316149383150D-02,5.0998194564650D-02, + > 1.0275811846581D-01,5.8684027928990D-02,1.3390893427120D-01, + > 6.5822235161410D-02,1.6847786965079D-01,7.2345792029120D-02, + > 2.0614211967012D-01,7.8193895594530D-02,2.4655004636084D-01, + > 8.3311924380730D-02,2.8932436162924D-01,8.7652092950870D-02, + > 3.3406569893521D-01,9.1173878706320D-02,3.8035631886341D-01, + > 9.3844399079790D-02,4.2776401920908D-01,9.5638720079300D-02, + > 4.7584616715613D-01,9.6540088514730D-02,5.2415383284387D-01, + > 9.6540088514730D-02,5.7223598079093D-01,9.5638720079300D-02, + > 6.1964368113639D-01,9.3844399079810D-02,6.6593430106595D-01, + > 9.1173878706150D-02,7.1067563837155D-01,8.7652092950640D-02, + > 7.5344995359973D-01,8.3311924388570D-02,7.9385788056245D-01, + > 7.8193895612890D-02,8.3152212954376D-01,7.2345792209150D-02, + > 8.6609106766446D-01,6.5822237766910D-02,8.9724187820340D-01, + > 5.8684043907040D-02,9.2468385448196D-01,5.0998208741440D-02, + > 9.4816047921927D-01,4.2835659552840D-02,9.6745319752725D-01, + > 3.4274011751680D-02,9.8238093897537D-01,2.5392043289540D-02/ + DATA ((SYST(IS,IA),IS=1,2),IA=269,270)/ + > 9.9280590365448D-01,1.6274238576240D-02,9.9863187744191D-01, + > 7.0188504222100D-03/ +*---- +* Order = 34 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=271,300)/ + > 1.2138349013000D-03,6.2277307558600D-03,6.3869192516100D-03, + > 1.4451724561770D-02,1.5644733690910D-02,2.2563235943270D-02, + > 2.8919877166600D-02,3.0490602921410D-02,4.6094370278800D-02, + > 3.8167281273000D-02,6.7033168791730D-02,4.5525083917960D-02, + > 9.1557612404410D-02,5.2507708601320D-02,1.1946770920314D-01, + > 5.9054059156070D-02,1.5053036746507D-01,6.5111530978600D-02, + > 1.8448917173306D-01,7.0629380155610D-02,2.2106223578649D-01, + > 7.5561972048180D-02,2.5994673175191D-01,7.9868445124360D-02, + > 3.0082036012065D-01,8.3513099547360D-02,3.4334445947741D-01, + > 8.6465739764320D-02,3.8716665418132D-01,8.8701897834840D-02, + > 4.3192382137060D-01,9.0203044370650D-02,4.7724508902345D-01, + > 9.0956740330260D-02,5.2275491097655D-01,9.0956740330260D-02, + > 5.6807617862940D-01,9.0203044370650D-02,6.1283334581861D-01, + > 8.8701897834850D-02,6.5665554052315D-01,8.6465739764290D-02, + > 6.9917963987666D-01,8.3513099548570D-02,7.4005326825732D-01, + > 7.9868445126930D-02,7.7893776418574D-01,7.5561972061710D-02, + > 8.1551082835912D-01,7.0629379457120D-02,8.4946963217695D-01, + > 6.5111531202520D-02,8.8053229218955D-01,5.9054074711360D-02, + > 9.0844238294494D-01,5.2507705481050D-02,9.3296684365079D-01, + > 4.5525085513800D-02,9.5390560370112D-01,3.8167592545450D-02/ + DATA ((SYST(IS,IA),IS=1,2),IA=301,304)/ + > 9.7108016452504D-01,3.0490955690320D-02,9.8435521706864D-01, + > 2.2563397478200D-02,9.9361311954501D-01,1.4451530325050D-02, + > 9.9878615097296D-01,6.2277937068700D-03/ +*---- +* Order = 36 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=305,334)/ + > 1.0829067579700D-03,5.5561674764700D-03,5.7117396663200D-03, + > 1.2926691357470D-02,1.3980178693510D-02,2.0174270127740D-02, + > 2.5868093384500D-02,2.7303499741840D-02,4.1248694560440D-02, + > 3.4211392743280D-02,6.0035940483070D-02,4.0876996272730D-02, + > 8.2076289217610D-02,4.7234439323640D-02,1.0721181826147D-01, + > 5.3244759709300D-02,1.3525549056623D-01,5.8860097418630D-02, + > 1.6599933099976D-01,6.4039804677380D-02,1.9921619867238D-01, + > 6.8745328039500D-02,2.3465984437212D-01,7.2941882378020D-02, + > 2.7206803238074D-01,7.6598411448030D-02,3.1116372520315D-01, + > 7.9687828738550D-02,3.5165750254906D-01,8.2187266728070D-02, + > 3.9324955382024D-01,8.4078218978050D-02,4.3563194809598D-01, + > 8.5346685739370D-02,4.7849090076315D-01,8.5983275670390D-02, + > 5.2150909923685D-01,8.5983275670390D-02,5.6436805190401D-01, + > 8.5346685739370D-02,6.0675044618021D-01,8.4078218978020D-02, + > 6.4834249744579D-01,8.2187266728640D-02,6.8883627483352D-01, + > 7.9687828731840D-02,7.2793196743448D-01,7.6598411499530D-02, + > 7.6534015632428D-01,7.2941882238710D-02,8.0078379930975D-01, + > 6.8745327516900D-02,8.3400067356633D-01,6.4039803761070D-02, + > 8.6474450115600D-01,5.8860083925380D-02,8.9278819497455D-01, + > 5.3244889793900D-02,9.1792368751533D-01,4.7234777207990D-02/ + DATA ((SYST(IS,IA),IS=1,2),IA=335,340)/ + > 9.3996410914631D-01,4.0876449600600D-02,9.5875120172086D-01, + > 3.4213563175030D-02,9.7413208045779D-01,2.7302342273080D-02, + > 9.8601960853527D-01,2.0174283453030D-02,9.9428843111626D-01, + > 1.2925824456940D-02,9.9891703069473D-01,5.5566718456000D-03/ +*---- +* Order = 38 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=341,370)/ + > 9.8333441339000D-04,5.0468854656500D-03,5.1058481717700D-03, + > 1.1552522428980D-02,1.2612131316970D-02,1.8215585706410D-02, + > 2.3231189561830D-02,2.4539013893040D-02,3.7156958802540D-02, + > 3.0864036728520D-02,5.4054909599560D-02,3.6884309301240D-02, + > 7.3991329170220D-02,4.2705164437670D-02,9.6724056867560D-02, + > 4.8226693951550D-02,1.2215851106735D-01,5.3432300845900D-02, + > 1.5010018315296D-01,5.8280339673470D-02,1.8037291120576D-01, + > 6.2740931378560D-02,2.1277197798854D-01,6.6783939165420D-02, + > 2.4708263238329D-01,7.0382504806650D-02,2.8307642139671D-01, + > 7.3512693597450D-02,3.2051377762467D-01,7.6153663277810D-02, + > 3.5914559554259D-01,7.8287844700040D-02,3.9871477300792D-01, + > 7.9901033240430D-02,4.3895798733272D-01,8.0982493770660D-02, + > 4.7960742604771D-01,8.1525029280390D-02,5.2039257395229D-01, + > 8.1525029280390D-02,5.6104201266726D-01,8.0982493770660D-02, + > 6.0128522699314D-01,7.9901033240370D-02,6.4085440444255D-01, + > 7.8287844701560D-02,6.7948622247722D-01,7.6153663266610D-02, + > 7.1692357815967D-01,7.3512693677670D-02,7.5291736900970D-01, + > 7.0382504658540D-02,7.8722801874323D-01,6.6783939331140D-02, + > 8.1962709413251D-01,6.2740933660550D-02,8.4989981340243D-01, + > 5.8280343712020D-02,8.7784147565137D-01,5.3432297735040D-02/ + DATA ((SYST(IS,IA),IS=1,2),IA=371,378)/ + > 9.0327600712907D-01,4.8227830719590D-02,9.2600850044772D-01, + > 4.2707129785660D-02,9.4594543062232D-01,3.6883986643610D-02, + > 9.6284250366432D-01,3.0881525256230D-02,9.7676949364984D-01, + > 2.4532771471320D-02,9.8738719838988D-01,1.8220665394490D-02, + > 9.9489461473028D-01,1.1556650094680D-02,9.9901650708112D-01, + > 5.0480587932600D-03/ +*---- +* Order = 40 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=379,408)/ + > 8.4438396773000D-04,4.3415791982100D-03,4.7433504658700D-03, + > 1.0790955034670D-02,1.1228207956250D-02,1.6252231945380D-02, + > 2.1170648774260D-02,2.2441559704590D-02,3.3502617823100D-02, + > 2.7835664062340D-02,4.9001917634790D-02,3.3549469533650D-02, + > 6.6995203524880D-02,3.8737706303810D-02,8.7704890024170D-02, + > 4.3893720107290D-02,1.1084267582009D-01,4.8686848283500D-02, + > 1.3634250098496D-01,5.3230489383970D-02,1.6402121010617D-01, + > 5.7439109098950D-02,1.9372310228905D-01,6.1306338991240D-02, + > 2.2526647199449D-01,6.4804006556460D-02,2.5846207409080D-01, + > 6.7912042829150D-02,2.9311040683116D-01,7.0611648558400D-02, + > 3.2900295255883D-01,7.2886582168900D-02,3.6592390778598D-01, + > 7.4723169083110D-02,4.0365120962290D-01,7.6110361899000D-02, + > 4.4195796466366D-01,7.7039818164300D-02,4.8061379124697D-01, + > 7.7505947978420D-02,5.1938620875303D-01,7.7505947978420D-02, + > 5.5804203533634D-01,7.7039818164300D-02,5.9634879037692D-01, + > 7.6110361899020D-02,6.3407609221112D-01,7.4723169083260D-02, + > 6.7099704750880D-01,7.2886582161390D-02,7.0688959260854D-01, + > 7.0611648675350D-02,7.4153792871443D-01,6.7912042607660D-02, + > 7.7473351810972D-01,6.4804008885300D-02,8.0627692408788D-01, + > 6.1306352760610D-02,8.3597873460403D-01,5.7439151840670D-02/ + DATA ((SYST(IS,IA),IS=1,2),IA=409,418)/ + > 8.6365759337389D-01,5.3230290482760D-02,8.8915718658253D-01, + > 4.8686786345600D-02,9.1229528958732D-01,4.3892524295090D-02, + > 9.3300459616015D-01,3.8733836200490D-02,9.5099819911142D-01, + > 3.3539847757640D-02,9.6649758869464D-01,2.7837431154340D-02, + > 9.7882860559165D-01,2.2455890598010D-02,9.8877301735663D-01, + > 1.6255733352800D-02,9.9525553201263D-01,1.0792898832200D-02, + > 9.9915603105220D-01,4.3433310487600D-03/ +*---- +* Order = 42 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=419,448)/ + > 1.1436307923000D-03,7.4186665285700D-03,3.4042259466900D-03, + > 1.0831832268370D-02,1.1496376931880D-02,1.9947942667490D-02, + > 1.7955662648690D-02,2.2741693977000D-02,3.1330579337640D-02, + > 2.6763625138290D-02,4.4032756116860D-02,3.1014207506350D-02, + > 6.1207239976840D-02,3.5215101677740D-02,7.9779208818870D-02, + > 4.0214419269220D-02,1.0103507239758D-01,4.4488387736430D-02, + > 1.2436340070041D-01,4.8802057832060D-02,1.4974623669676D-01, + > 5.2739442801020D-02,1.7706313243465D-01,5.6428613653020D-02, + > 2.0612502181083D-01,5.9797538031390D-02,2.3680331784740D-01, + > 6.2843794751680D-02,2.6891361931961D-01,6.5545557530370D-02, + > 3.0228819052088D-01,6.7889718324440D-02,3.3674191483102D-01, + > 6.9862990142650D-02,3.7208746313458D-01,7.1454714485220D-02, + > 4.0813159656596D-01,7.2656175235390D-02,4.4467748639631D-01, + > 7.3460813453490D-02,4.8152552841733D-01,7.3864234232170D-02, + > 5.1847447158267D-01,7.3864234232170D-02,5.5532251360371D-01, + > 7.3460813453490D-02,5.9186840343222D-01,7.2656175235500D-02, + > 6.2791253689849D-01,7.1454714482610D-02,6.6325808487552D-01, + > 6.9862990173320D-02,6.9771181125973D-01,6.7889718091910D-02, + > 7.3108637193333D-01,6.5545559066180D-02,7.6319671900011D-01, + > 6.2843787993900D-02,7.9387484478393D-01,5.9797577974870D-02/ + DATA ((SYST(IS,IA),IS=1,2),IA=449,460)/ + > 8.2293728002029D-01,5.6428463918250D-02,8.5025266912033D-01, + > 5.2739723763830D-02,8.7563910939874D-01,4.8802517410530D-02, + > 8.9895990801325D-01,4.4490374567250D-02,9.2022975422536D-01, + > 4.0172324368590D-02,9.3877903172577D-01,3.5258261911020D-02, + > 9.5598754636848D-01,3.1066242940220D-02,9.6864609020677D-01, + > 2.6329620936360D-02,9.8207312074062D-01,2.2831730375060D-02, + > 9.8847852226738D-01,2.0716186813260D-02,9.9661056712718D-01, + > 1.0827682155930D-02,9.9884898177306D-01,7.5418025361000D-03/ +*---- +* Order = 44 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=461,490)/ + > 6.1252206042000D-04,3.3140554230300D-03,4.1720931122600D-03, + > 9.2651070517900D-03,9.0669071405200D-03,1.3576563197170D-02, + > 1.7615803993250D-02,1.8912297449420D-02,2.7955617624090D-02, + > 2.3395928365090D-02,4.0412230027940D-02,2.8425424168950D-02, + > 5.6055103315820D-02,3.2836252919920D-02,7.2703919502150D-02, + > 3.7296156992010D-02,9.2688130969150D-02,4.0885547703750D-02, + > 1.1367090301189D-01,4.4885591782210D-02,1.3736990564741D-01, + > 4.8609514192960D-02,1.6232287944645D-01,5.2059853714740D-02, + > 1.8930735363830D-01,5.5313358960350D-02,2.1764165334825D-01, + > 5.8256109292030D-02,2.4748186983961D-01,6.0928266329370D-02, + > 2.7853682871557D-01,6.3289657305750D-02,3.1071115303397D-01, + > 6.5338210957320D-02,3.4382360369818D-01,6.7060623782030D-02, + > 3.7771529185760D-01,6.8449071717460D-02,4.1221599144869D-01, + > 6.9496491802960D-02,4.4715404915482D-01,7.0197685473830D-02, + > 4.8235538151795D-01,7.0549157789350D-02,5.1764461848205D-01, + > 7.0549157789350D-02,5.5284595084511D-01,7.0197685473840D-02, + > 5.8778400855113D-01,6.9496491802960D-02,6.2228470823467D-01, + > 6.8449071711000D-02,6.5617639467039D-01,6.7060623933340D-02, + > 6.8928886090713D-01,6.5338209334940D-02,7.2146309410466D-01, + > 6.3289667630390D-02,7.5251844435846D-01,6.0928210763750D-02/ + DATA ((SYST(IS,IA),IS=1,2),IA=491,504)/ + > 7.8235733192687D-01,5.8256286581880D-02,8.1069533877281D-01, + > 5.5312566740350D-02,8.3767098068236D-01,5.2061152990920D-02, + > 8.6264199947756D-01,4.8603281013420D-02,8.8630854032991D-01, + > 4.4892027979270D-02,9.0734171525029D-01,4.0819832600500D-02, + > 9.2725855295616D-01,3.6991471526480D-02,9.4398125724790D-01, + > 3.2053582499500D-02,9.5956693163156D-01,2.8799109630940D-02, + > 9.7203704644518D-01,2.3034882925340D-02,9.8242235595345D-01, + > 1.7253492479830D-02,9.9087335981979D-01,1.4306222180000D-02, + > 9.9587701930960D-01,9.6801811169800D-03,9.9937229793867D-01, + > 3.3961120793100D-03/ +*---- +* Start processing +*---- + PI=XDRCST('Pi',' ') + NBPT=(ORDRE*ORDRE)/2 + IF(3*NBPT .NE. NBANGL) CALL XABORT(NAMSBR// + >': Number of quadrature points is invalid') + ILEVEL=1 + JLEVEL=0 + NLEVEL=ORDRE/2 + KLEVEL=(NLEVEL*(NLEVEL-1))-2 + IPOINT=0 +* write(6,*) KLEVEL + DO IPT=1,NBPT + JLEVEL = JLEVEL + 1 + ALPHA =(PI/DBLE(2*NLEVEL))*(DBLE(2*JLEVEL-1)/DTWO) +* write(6,*) ALPHA,KLEVEL+ILEVEL,XI,SYST(2,KLEVEL+ILEVEL) + XI=SYST(1,KLEVEL+ILEVEL) + ROTXI=SQRT(DONE-XI**2) + COSA=COS(ALPHA) + SINA=SIN(ALPHA) + WGTINV=DBLE(48*NLEVEL)/SYST(2,KLEVEL+ILEVEL) + DO IROT=1,3 +*---- +* \xi direction (3) +* \mu direction (2) +* \eta direction (1) +*---- + IDIR1=MOD(IROT-1,3)+1 + IDIR2=MOD(IROT,3)+1 + IDIR3=MOD(IROT+1,3)+1 + IPOINT=IPOINT+1 + DDENWT(1,IPOINT)=DQUAD(1)*WGTINV + DANGLT(IDIR1,1,IPOINT)=COSA*ROTXI + DANGLT(IDIR2,1,IPOINT)=SINA*ROTXI + DANGLT(IDIR3,1,IPOINT)=XI + DDENWT(2,IPOINT)=DQUAD(2)*WGTINV + DANGLT(1,2,IPOINT)=-DANGLT(1,1,IPOINT) + DANGLT(2,2,IPOINT)=DANGLT(2,1,IPOINT) + DANGLT(3,2,IPOINT)=DANGLT(3,1,IPOINT) + DDENWT(3,IPOINT)=DQUAD(3)*WGTINV + DANGLT(1,3,IPOINT)=DANGLT(1,1,IPOINT) + DANGLT(2,3,IPOINT)=-DANGLT(2,1,IPOINT) + DANGLT(3,3,IPOINT)=DANGLT(3,1,IPOINT) + DDENWT(4,IPOINT)=DQUAD(4)*WGTINV + DANGLT(1,4,IPOINT)=-DANGLT(1,1,IPOINT) + DANGLT(2,4,IPOINT)=-DANGLT(2,1,IPOINT) + DANGLT(3,4,IPOINT)=DANGLT(3,1,IPOINT) + ENDDO + IF(JLEVEL .EQ. NLEVEL) THEN + ILEVEL = ILEVEL + 1 + JLEVEL = 0 + ENDIF + ENDDO + RETURN + END diff --git a/Dragon/src/NXTQPS.f b/Dragon/src/NXTQPS.f new file mode 100644 index 0000000..21e6e81 --- /dev/null +++ b/Dragon/src/NXTQPS.f @@ -0,0 +1,108 @@ +*DECK NXTQPS + SUBROUTINE NXTQPS(NDIM ,DANGLT,DNPDIR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To generate direction defining the planes normal to a solid angle. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau, R. Roy, M. Hampartzounian +* +*Parameters: input +* NDIM number of dimensions for geometry. +* DANGLT direction of track. +* +*Parameters: output +* DNPDIR directions defining plane normal to track. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* \\\\ +* Extracted from the subroutine XELEQN of EXCELL. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NDIM + DOUBLE PRECISION DANGLT(3) + DOUBLE PRECISION DNPDIR(3,2,3) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTQPS') + DOUBLE PRECISION DZERO,DONE + PARAMETER (DZERO=0.0D0,DONE=1.0D0) +*---- +* Local variables +*---- + INTEGER IPL + DOUBLE PRECISION X,Y,Z,SUPX,SUPY,SUPZ,OOSUPX,OOSUPY,OOSUPZ, + > XOSUPX,YOSUPY,ZOSUPZ +*---- +* Define reference position +*---- + X = DANGLT(1) + Y = DANGLT(2) + IF(NDIM .EQ. 2) THEN + DNPDIR(1,1,1)=-Y + DNPDIR(2,1,1)=X + ELSE IF(NDIM .EQ. 3) THEN + SUPX = SQRT( DONE - X * X ) + SUPY = SQRT( DONE - Y * Y ) + OOSUPX= DONE / SUPX + OOSUPY= DONE / SUPY + XOSUPX= X / SUPX + YOSUPY= Y / SUPY + Z = DANGLT(3) + SUPZ = SQRT( DONE - Z * Z ) + OOSUPZ= DONE / SUPZ + ZOSUPZ= Z / SUPZ + DO IPL=1,2*NDIM-3 + IF(IPL .EQ. 1) THEN + DNPDIR( 1, 1 ,IPL)= -Y * OOSUPZ + DNPDIR( 2, 1 ,IPL)= X * OOSUPZ + DNPDIR( 3, 1 ,IPL)= DZERO + DNPDIR( 1, 2 ,IPL)= X * ZOSUPZ + DNPDIR( 2, 2 ,IPL)= Y * ZOSUPZ + DNPDIR( 3, 2 ,IPL)= - SUPZ + ELSE IF(IPL .EQ. 2) THEN + DNPDIR( 1, 1 ,IPL)= -Z * OOSUPY + DNPDIR( 2, 1 ,IPL)= DZERO + DNPDIR( 3, 1 ,IPL)= X * OOSUPY + DNPDIR( 1, 2 ,IPL)= X * YOSUPY + DNPDIR( 2, 2 ,IPL)= - SUPY + DNPDIR( 3, 2 ,IPL)= Z * YOSUPY + ELSE IF(IPL .EQ. 3) THEN + DNPDIR( 1, 1 ,IPL)= DZERO + DNPDIR( 2, 1 ,IPL)= -Z * OOSUPX + DNPDIR( 3, 1 ,IPL)= Y * OOSUPX + DNPDIR( 1, 2 ,IPL)= - SUPX + DNPDIR( 2, 2 ,IPL)= Y * XOSUPX + DNPDIR( 3, 2 ,IPL)= Z * XOSUPX + ENDIF + ENDDO + ENDIF +*---- +* Processing finished: return +*---- + RETURN +*---- +* Output formats +*---- + END diff --git a/Dragon/src/NXTQRN.f b/Dragon/src/NXTQRN.f new file mode 100644 index 0000000..f25b00d --- /dev/null +++ b/Dragon/src/NXTQRN.f @@ -0,0 +1,976 @@ +*DECK NXTQRN + SUBROUTINE NXTQRN(NDIM ,ORDRE ,NQUAD ,NBANGL,DQUAD , + > DANGLT,DDENWT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To define quadruple range (QR) quadrature angles. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* N. Martin +* +*Parameters: input +* NDIM number of dimensions for geometry. +* ORDRE quadrature order. +* NQUAD number of quadrant (in 3-D) and quarter (in 2-D). +* NBANGL number of angles. +* DQUAD relative density of each quadrant. +* +*Parameters: output +* DANGLT director cosines of angles. +* DDENWT angular density for each angle. +* +*References: +* I. K. Abu-Shumays, Angular quadratures for improved transport +* computations, Transport Theory and Statistical Physics, 30:2, +* 169 - 204 (2001). +* \\\\ +* E. M. Baker, Quadruple range quadrature verification and extention, +* Los Alamos documentation LA-UR-07-8050 (2006). +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NDIM,ORDRE,NQUAD,NBANGL + DOUBLE PRECISION DQUAD(NQUAD),DANGLT(NDIM,NQUAD,NBANGL), + > DDENWT(NQUAD,NBANGL) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTQRN') + DOUBLE PRECISION DZERO,DONE,DTWO + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Functions +*---- + DOUBLE PRECISION XDRCST,PI +*---- +* Local variables +*---- + INTEGER NBPT,ILEVEL,JLEVEL,NLEVEL,KLEVEL,IPOINT, + > IPT,IROT,IDIR1,IDIR2,IDIR3 + DOUBLE PRECISION ALPHA,XI,ROTXI,COSA,SINA,WGTINV +*---- +* Data +*---- + INTEGER IS,IA + DOUBLE PRECISION SYST(2,703) + SAVE SYST +*---- +* Order = 2 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 1, 1)/ + > 0.7071067811865475D0,1.570796326794897D0/ +*---- +* Order = 4 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 2, 3)/ + > 3.288613193063390D-1,7.853981633974483D-1,9.443782254288237D-1, + > 0.7853981633974483D0/ +*---- +* Order = 6 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 4, 6)/ + > 1.797057505503707D-1, 4.414924088048230D-1,7.071067811865475D-1, + > 6.878115091852507D-1, 9.837204090691257D-1, 4.414924088048230D-1/ +*---- +* Order = 8 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 7, 10)/ + > 1.119194178021025D-1, 2.790495092691071D-1, + > 4.990088153604911D-1, 5.063486541283412D-1, + > 8.665969087139183D-1, 5.063486541283412D-1, + > 9.937172857099943D-1, 2.790495092691071D-1/ +*---- +* Order = 10 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 11, 15)/ + > 7.608393410010900D-2, 1.913207247027131D-1, + > 3.599152552241242D-1, 3.748555766138863D-1, + > 7.071067811865475D-1, 4.384437241616979D-1, + > 9.329849993740272D-1, 3.748555766138863D-1, + > 9.971014165930416D-1, 1.913207247027131D-1/ +*---- +* Order = 12 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 16, 21)/ + > 5.498238339818787D-2, 1.389912271015858D-1, + > 2.686450605979331D-1, 2.849847975948065D-1, + > 5.658713393447228D-1, 3.614221387010560D-1, + > 8.244935580756284D-1, 3.614221387010560D-1, + > 9.632392389309796D-1, 2.849847975948065D-1, + > 9.984873246645922D-1, 1.389912271015858D-1/ +*---- +* Order = 14 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 22, 28)/ + > 4.155046739519842D-2, 1.054032627117009D-1, + > 2.070312681580549D-1, 2.225734192425536D-1, + > 4.548121603136229D-1, 2.966594661924317D-1, + > 7.071067811865475D-1, 3.215240305015243D-1, + > 8.905873897775868D-1, 2.966594661924317D-1, + > 9.783343262938634D-1, 2.225734192425536D-1, + > 9.991364064326955D-1, 1.054032627117009D-1/ +*---- +* Order = 16 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 29, 36)/ + > 3.248697884632087D-2, 8.261058789185801D-2, + > 1.639512569400686D-1, 1.780108196819361D-1, + > 3.700379385471330D-1, 2.453650131486301D-1, + > 6.006186663088213D-1, 2.794117426750241D-1, + > 7.995356262740346D-1, 2.794117426750241D-1, + > 9.290166435730784D-1, 2.453650131486301D-1, + > 9.864684411311756D-1, 1.780108196819361D-1, + > 9.994721587945503D-1, 8.261058789185801D-2/ +*---- +* Order = 18 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 37, 45)/ + > 2.608861776207381D-2, 6.645559945847256D-2, + > 1.328246569072209D-1, 1.452965934855972D-1, + > 3.053252347988094D-1, 2.051444864132550D-1, + > 5.104236819705835D-1, 2.416159520924252D-1, + > 7.071067811865475D-1, 2.537710638953967D-1, + > 8.599230575368895D-1, 2.416159520924252D-1, + > 9.522481299509345D-1, 2.051444864132550D-1, + > 9.911395514847942D-1, 1.452965934855972D-1, + > 9.996596340871549D-1, 6.645559945847256D-2/ +*---- +* Order = 20 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 46, 55)/ + > 2.140636649836879D-2, 5.459883427719590D-2, + > 1.096782080789725D-1, 1.206689353273136D-1, + > 2.554062770706209D-1, 1.734506495359569D-1, + > 4.359965790249476D-1, 2.093517367248734D-1, + > 6.217587837057514D-1, 2.273280075321085D-1, + > 7.832087939271013D-1, 2.273280075321085D-1, + > 8.999483224488741D-1, 2.093517367248734D-1, + > 9.668338190366146D-1, 1.734506495359569D-1, + > 9.939671476827519D-1, 1.206689353273136D-1, + > 9.997708574835223D-1, 5.459883427719590D-2/ +*---- +* Order = 22 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 56, 66)/ + > 1.787818127983761D-2, 4.564471367918457D-2, + > 9.203377352741595D-2, 1.017137272660963D-1, + > 2.163635206471488D-1, 1.482265633964675D-1, + > 3.750373673684837D-1, 1.822612531818470D-1, + > 5.464247324681954D-1, 2.027611569667827D-1, + > 7.071067811865475D-1, 2.095814978141405D-1, + > 8.375082159280953D-1, 2.027611569667827D-1, + > 9.270096941657714D-1, 1.822612531818470D-1, + > 9.763128734853243D-1, 1.482265633964675D-1, + > 9.957558860133865D-1, 1.017137272660963D-1, + > 9.998401725446549D-1, 4.564471367918457D-2/ +*---- +* Order = 24 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 67, 78)/ + > 1.515427633810212D-2, 3.871995573990722D-2, + > 7.829331784823644D-2, 8.683898824818842D-2, + > 1.853856824160965D-1, 1.279220161079748D-1, + > 3.250513900479526D-1, 1.595962888003237D-1, + > 4.813341017203090D-1, 1.808538704864877D-1, + > 6.359378348511013D-1, 1.914670440145664D-1, + > 7.717402867577236D-1, 1.914670440145664D-1, + > 8.765372111445716D-1, 1.808538704864877D-1, + > 9.456963539254520D-1, 1.595962888003237D-1, + > 9.826658377877590D-1, 1.279220161079748D-1, + > 9.969303668663700D-1, 8.683898824818842D-2, + > 9.998851673610667D-1, 3.871995573990722D-2/ +*---- +* Order = 26 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 79, 91)/ + > 1.300784260340052D-2, 3.325591619718422D-2, + > 6.739381484979049D-2, 7.496658920041428D-2, + > 1.604653826023372D-1, 1.113898480184530D-1, + > 2.838506265695340D-1, 1.405952903244943D-1, + > 4.256053496742027D-1, 1.616563247494470D-1, + > 5.714795978613439D-1, 1.742889475411106D-1, + > 7.071067811865475D-1, 1.784904947326901D-1, + > 8.206162740454497D-1, 1.742889475411106D-1, + > 9.049088828874981D-1, 1.616563247494470D-1, + > 9.588685112131292D-1, 1.405952903244943D-1, + > 9.870414687267630D-1, 1.113898480184530D-1, + > 9.977264523505389D-1, 7.496658920041428D-2, + > 9.999153944363519D-1, 3.325591619718422D-2/ +*---- +* Order = 28 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 92,105)/ + > 1.128664599103795D-2, 2.886965398857025D-2, + > 5.860802825933166D-2, 6.534816595720066D-2, + > 1.401592977980301D-1, 9.778151915986106D-2, + > 2.496535423349043D-1, 1.245928602207950D-1, + > 3.780145294131805D-1, 1.449498625863828D-1, + > 5.141044083621162D-1, 1.585386998315389D-1, + > 6.460952816893911D-1, 1.653174016530996D-1, + > 7.632567634673841D-1, 1.653174016530996D-1, + > 8.577276125336286D-1, 1.585386998315389D-1, + > 9.257996627524400D-1, 1.449498625863828D-1, + > 9.683352254253865D-1, 1.245928602207950D-1, + > 9.901289669738802D-1, 9.778151915986106D-2, + > 9.982810721553091D-1, 6.534816595720066D-2, + > 9.999363037825324D-1, 2.886965398857025D-2/ +*---- +* Order = 30 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=106,120)/ + > 9.885454799950707D-3, 2.529575708608393D-2, + > 5.142584271456661D-2, 5.745247946520937D-2, + > 1.234174526540014D-1, 8.646511772502708D-2, + > 2.210520064292830D-1, 1.110388326617575D-1, + > 3.373313406305213D-1, 1.304366407688838D-1, + > 4.634907863833664D-1, 1.443355921311845D-1, + > 5.898656904335448D-1, 1.526595716146173D-1, + > 7.071067811865475D-1, 1.554283438893696D-1, + > 8.075013729086518D-1, 1.526595716146173D-1, + > 8.861017384802541D-1, 1.443355921311845D-1, + > 9.413859817462841D-1, 1.304366407688838D-1, + > 9.752620214350542D-1, 1.110388326617575D-1, + > 9.923548419695433D-1, 8.646511772502708D-2, + > 9.986768159425233D-1, 5.745247946520937D-2, + > 9.999511376979368D-1, 2.529575708608393D-2/ +*---- +* Order = 32 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=121,136)/ + > 8.729657082861998D-3, 2.234563433970334D-2, + > 4.548138640446708D-2, 5.089471201185089D-2, + > 1.094657179495637D-1, 7.696546183192337D-2, + > 1.969448911359501D-1, 9.948832189094168D-2, + > 3.024482742232713D-1, 1.178163725528086D-1, + > 4.190211144820449D-1, 1.316318495967909D-1, + > 5.387770134090762D-1, 1.408332013024988D-1, + > 6.537245138927594D-1, 1.454226098709307D-1, + > 7.567326211652801D-1, 1.454226098709307D-1, + > 8.424484137453142D-1, 1.408332013024988D-1, + > 9.079764895735049D-1, 1.316318495967909D-1, + > 9.531657995434818D-1, 1.178163725528086D-1, + > 9.804145602016775D-1, 9.948832189094168D-2, + > 9.939905716825420D-1, 7.696546183192337D-2, + > 9.989651863256935D-1, 5.089471201185089D-2, + > 9.999618958176435D-1, 2.234563433970334D-2/ +*---- +* Order = 34 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=137,153)/ + > 7.765167550594897D-3, 1.988233444736077D-2, + > 4.050698458787639D-2, 4.539097865607717D-2, + > 9.772547366646427D-2, 6.892134946532859D-2, + > 1.764725073896891D-1, 8.958447192452450D-2, + > 2.724164548901113D-1, 1.068152712507604D-1, + > 3.799892988394926D-1, 1.203101631042851D-1, + > 4.927420326833888D-1, 1.299509173542970D-1, + > 6.039089138656826D-1, 1.357218046104536D-1, + > 7.071067811865475D-1, 1.376417451687221D-1, + > 7.970533380857090D-1, 1.357218046104536D-1, + > 8.701754358903969D-1, 1.299509173542970D-1, + > 9.249908825320770D-1, 1.203101631042851D-1, + > 9.621794401800030D-1, 1.068152712507604D-1, + > 9.843055694933338D-1, 8.958447192452450D-2, + > 9.952134101772671D-1, 6.892134946532859D-2, + > 9.991792552888583D-1, 4.539097865607717D-2, + > 9.999698506319634D-1, 1.988233444736077D-2/ +*---- +* Order = 36 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=154,171)/ + > 6.952010366745025D-3, 1.780448256851573D-2, + > 3.630329822321955D-2, 4.072837739441321D-2, + > 8.775842996404620D-2, 6.205518747222860D-2, + > 1.589616059026264D-1, 8.104138647658412D-2, + > 2.464422434563339D-1, 9.719456818914889D-2, + > 3.457022371739597D-1, 1.102303994594047D-1, + > 4.514464196113868D-1, 1.200213906455903D-1, + > 5.579698061333865D-1, 1.265362696526889D-1, + > 6.596626820591664D-1, 1.297861015388739D-1, + > 7.515618044435914D-1, 1.297861015388739D-1, + > 8.298612507181373D-1, 1.265362696526889D-1, + > 8.922982294166338D-1, 1.200213906455903D-1, + > 9.383442668940432D-1, 1.102303994594047D-1, + > 9.691574797937686D-1, 9.719456818914889D-2, + > 9.872847653280476D-1, 8.104138647658412D-2, + > 9.961417860777880D-1, 6.205518747222860D-2, + > 9.993408180086091D-1, 4.072837739441321D-2, + > 9.999758344839443D-1, 1.780448256851573D-2/ +*---- +* Order = 38 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=172,190)/ + > 6.260124726824094D-3, 1.603575186530219D-2, + > 3.271949450064389D-2, 3.674484447429247D-2, + > 7.922836042016190D-2, 5.615133571572357D-2, + > 1.438820502560538D-1, 7.362948392130560D-2, + > 2.238694254490736D-1, 8.875049346501127D-2, + > 3.155245603429847D-1, 1.012516526819094D-1, + > 4.144771888783680D-1, 1.110019513021974D-1, + > 5.159200804329141D-1, 1.179578982613787D-1, + > 6.149740744496668D-1, 1.221213481438653D-1, + > 7.071067811865475D-1, 1.235068071329247D-1, + > 7.885473275300447D-1, 1.221213481438653D-1, + > 8.566367203232041D-1, 1.179578982613787D-1, + > 9.100597012831003D-1, 1.110019513021974D-1, + > 9.489174104316804D-1, 1.012516526819094D-1, + > 9.746191463074700D-1, 8.875049346501127D-2, + > 9.895948441731669D-1, 7.362948392130560D-2, + > 9.968564926332842D-1, 5.615133571572357D-2, + > 9.994645739993101D-1, 3.674484447429247D-2, + > 9.999804052272247D-1, 1.603575186530219D-2/ +*---- +* Order = 40 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=191,210)/ + > 5.666555435801935D-3, 1.451779509317350D-2, + > 2.963979274695100D-2, 3.331533618587398D-2, + > 7.187424763201411D-2, 5.104054858395153D-2, + > 1.308135974586322D-1, 6.716362589103700D-2, + > 2.041579376098809D-1, 8.131097620559026D-2, + > 2.888941786344192D-1, 9.324211470049753D-2, + > 3.813947484262091D-1, 1.028266819400935D-1, + > 4.776033421571356D-1, 1.100123318316945D-1, + > 5.732994237606388D-1, 1.147920152181985D-1, + > 6.644147983089062D-1, 1.171767377473380D-1, + > 7.473640182589308D-1, 1.171767377473380D-1, + > 8.193459408062747D-1, 1.147920152181985D-1, + > 8.785755787411428D-1, 1.100123318316945D-1, + > 9.244122705118689D-1, 1.028266819400935D-1, + > 9.573610361567596D-1, 9.324211470049753D-2, + > 9.789379635660678D-1, 8.131097620559026D-2, + > 9.914069813754243D-1, 6.716362589103700D-2, + > 9.974137017944620D-1, 5.104054858395153D-2, + > 9.995606448264746D-1, 3.331533618587398D-2, + > 9.999839449458641D-1, 1.451779509317350D-2/ +*---- +* Order = 42 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=211,231)/ + > 5.153529715794118D-3, 1.320539632418366D-2, + > 2.697415577591218D-2, 3.034217800698840D-2, + > 6.549119792630967D-2, 4.658869227256107D-2, + > 1.194207057461457D-1, 6.149373560761037D-2, + > 1.868636355236370D-1, 7.473138541437220D-2, + > 2.653234848709176D-1, 8.608289338331400D-2, + > 3.517712327776513D-1, 9.542142388267645D-2, + > 4.427751437470710D-1, 1.026887640907876D-1, + > 5.346931294496370D-1, 1.078700892228989D-1, + > 6.239117782235315D-1, 1.109716362868715D-1, + > 7.071067811865475D-1, 1.120039378103684D-1, + > 7.814947811687234D-1, 1.109716362868715D-1, + > 8.450463048374058D-1, 1.078700892228989D-1, + > 8.966326851502574D-1, 1.026887640907876D-1, + > 9.360860002104996D-1, 9.542142388267645D-2, + > 9.641594517381199D-1, 8.608289338331400D-2, + > 9.823858619294607D-1, 7.473138541437220D-2, + > 9.928437415016990D-1, 6.149373560761037D-2, + > 9.978531470082043D-1, 4.658869227256107D-2, + > 9.996361312598584D-1, 3.034217800698840D-2, + > 9.999867204775614D-1, 1.320539632418366D-2/ +*---- +* Order = 44 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=232,253)/ + > 4.707114717103505D-3, 1.206308084642689D-2, + > 2.465173376735076D-2, 2.774821193462954D-2, + > 5.991670409568439D-2, 4.268848001641819D-2, + > 1.094334822143285D-1, 5.649746567994538D-2, + > 1.716206775350476D-1, 6.889030401909524D-2, + > 2.443940481368066D-1, 7.966885558279603D-2, + > 3.252092377487526D-1, 8.871167329713092D-2, + > 4.111529714803756D-1, 9.595714699102763D-2, + > 4.990835442262655D-1, 1.013841131358227D-1, + > 5.858114200649882D-1, 1.049937517313658D-1, + > 6.683033272342810D-1, 1.067950801627900D-1, + > 7.438888779969691D-1, 1.067950801627900D-1, + > 8.104473950364958D-1, 1.049937517313658D-1, + > 8.665538736181088D-1, 1.013841131358227D-1, + > 9.115663629395599D-1, 9.595714699102763D-2, + > 9.456420843442170D-1, 8.871167329713092D-2, + > 9.696760021962513D-1, 7.966885558279603D-2, + > 9.851631047914915D-1, 6.889030401909524D-2, + > 9.939941211951136D-1, 5.649746567994538D-2, + > 9.982033803640970D-1, 4.268848001641819D-2, + > 9.996960998334762D-1, 2.774821193462954D-2, + > 9.999889214741531D-1, 1.206308084642689D-2/ +*---- +* Order = 46 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=254,276)/ + > 4.316263740076508D-3, 1.106270311640170D-2, + > 2.261617115926903D-2, 2.547185620354161D-2, + > 5.502063421109040D-2, 3.925335576844175D-2, + > 1.006332490304859D-1, 5.207448910676365D-2, + > 1.581268223158908D-1, 6.368572226347834D-2, + > 2.257488308236949D-1, 7.390806352099788D-2, + > 3.013494595288169D-1, 8.262656871717886D-2, + > 3.824459703834832D-1, 8.977817435489181D-2, + > 4.663257595606548D-1, 9.533683737852415D-2, + > 5.501830693329847D-1, 9.929896064532817D-2, + > 6.312785125450332D-1, 1.016710684725573D-1, + > 7.071067811865475D-1, 1.024607276986862D-1, + > 7.755562130490158D-1, 1.016710684725573D-1, + > 8.350440648369020D-1, 9.929896064532817D-2, + > 8.846130713312902D-1, 9.533683737852415D-2, + > 9.239778567354501D-1, 8.977817435489181D-2, + > 9.535137666765435D-1, 8.262656871717886D-2, + > 9.741855395055578D-1, 7.390806352099788D-2, + > 9.874188108722047D-1, 6.368572226347834D-2, + > 9.949235896236294D-1, 5.207448910676365D-2, + > 9.984852176226794D-1, 3.925335576844175D-2, + > 9.997442216897753D-1, 2.547185620354161D-2, + > 9.999906848902774D-1, 1.106270311640170D-2/ +*---- +* Order = 48 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=277,300)/ + > 3.972127715469235D-3, 1.018170331312922D-2, + > 2.082219684210920D-2, 2.346349353303599D-2, + > 5.069784852121022D-2, 3.621292193062666D-2, + > 9.284156235089204D-2, 4.814205277021821D-2, + > 1.461314233398479D-1, 5.903176230890425D-2, + > 2.090839313632731D-1, 6.872060753743357D-2, + > 2.798722573569018D-1, 7.710072080607362D-2, + > 3.563718475936031D-1, 8.410905852056142D-2, + > 4.362363542057792D-1, 8.971603507554962D-2, + > 5.170013989086162D-1, 9.391384633073917D-2, + > 5.962091754811982D-1, 9.670612366917621D-2, + > 6.715437180389010D-1, 9.809983760200038D-2, + > 7.409649349075090D-1, 9.809983760200038D-2, + > 8.028291344190430D-1, 9.670612366917621D-2, + > 8.559845521541460D-1, 9.391384633073917D-2, + > 8.998321194918805D-1, 8.971603507554962D-2, + > 9.343442118634447D-1, 8.410905852056142D-2, + > 9.600372490491982D-1, 7.710072080607362D-2, + > 9.778976989673706D-1, 6.872060753743357D-2, + > 9.892651854344568D-1, 5.903176230890425D-2, + > 9.956808948153246D-1, 4.814205277021821D-2, + > 9.987140372275341D-1, 3.621292193062666D-2, + > 9.997831945570342D-1, 2.346349353303599D-2, + > 9.999921110695884D-1, 1.018170331312922D-2/ +*---- +* Order = 50 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=301,325)/ + > 3.667550894412352D-3, 9.401828916276707D-3, + > 1.923311271050877D-2, 2.168279634366668D-2, + > 4.686269256303738D-2, 3.350948773339766D-2, + > 8.591181096521539D-2, 4.463150509293552D-2, + > 1.354257349069718D-1, 5.485592665859271D-2, + > 1.941407846601355D-1, 6.403724294009948D-2, + > 2.604960566070634D-1, 7.207485785563070D-2, + > 3.326658203805228D-1, 7.890682566302415D-2, + > 4.086156970191086D-1, 8.450117205318058D-2, + > 4.861816572020138D-1, 8.884657138646223D-2, + > 5.631674054600955D-1, 9.194373283617630D-2, + > 6.374531035792810D-1, 9.379831926574879D-2, + > 7.071067811865475D-1, 9.441579330451362D-2, + > 7.704891567940086D-1, 9.379831926574879D-2, + > 8.263428304446916D-1, 9.194373283617630D-2, + > 8.738577665732013D-1, 8.884657138646223D-2, + > 9.127065312298296D-1, 8.450117205318058D-2, + > 9.430447772775977D-1, 7.890682566302415D-2, + > 9.654749113737599D-1, 7.207485785563070D-2, + > 9.809736773897386D-1, 6.403724294009948D-2, + > 9.907875000851124D-1, 5.485592665859271D-2, + > 9.963027455230047D-1, 4.463150509293552D-2, + > 9.989013404965188D-1, 3.350948773339766D-2, + > 9.998150265801494D-1, 2.168279634366668D-2, + > 9.999932745126024D-1, 9.401828916276707D-3/ +*---- +* Order = 52 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=326,351)/ + > 3.396696521564986D-3, 8.708184858650910D-3, + > 1.781892050929334D-2, 2.009672209559701D-2, + > 4.344484549656114D-2, 3.109543899569998D-2, + > 7.972274758288012D-2, 4.148557359431433D-2, + > 1.258351250930473D-1, 5.109681624694140D-2, + > 1.806991980219270D-1, 5.979803209497304D-2, + > 2.429742598458005D-1, 6.749583467970308D-2, + > 3.110847255339362D-1, 7.413013546424966D-2, + > 3.832618562348258D-1, 7.966752788841578D-2, + > 4.576040998675997D-1, 8.409386224353523D-2, + > 5.321533124724104D-1, 8.740711539780842D-2, + > 6.049820056372407D-1, 8.961127788931235D-2, + > 6.742853437025943D-1, 9.071164194824712D-2, + > 7.384709034673433D-1, 9.071164194824712D-2, + > 7.962391430061333D-1, 8.961127788931235D-2, + > 8.466480095202735D-1, 8.740711539780842D-2, + > 8.891560536735741D-1, 8.409386224353523D-2, + > 9.236397293076104D-1, 7.966752788841578D-2, + > 9.503821828819580D-1, 7.413013546424966D-2, + > 9.700327360725438D-1, 6.749583467970308D-2, + > 9.835384079100482D-1, 5.979803209497304D-2, + > 9.920511686867856D-1, 5.109681624694140D-2, + > 9.968170762571418D-1, 4.148557359431433D-2, + > 9.990558269685333D-1, 3.109543899569998D-2, + > 9.998412304320539D-1, 2.009672209559701D-2, + > 9.999942312097307D-1, 8.708184858650910D-3/ +*---- +* Order = 54 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=352,378)/ + > 3.154765578452475D-3, 8.088519222518445D-3, + > 1.655490845630564D-2, 1.867799415496943D-2, + > 4.038615839476834D-2, 2.893121574263062D-2, + > 7.417347458492733D-2, 3.865622019474338D-2, + > 1.172128302266212D-1, 4.770225064114276D-2, + > 1.685713218507331D-1, 5.595108446790947D-2, + > 2.270915986436383D-1, 6.331631488632194D-2, + > 2.914082582079124D-1, 6.974022040259096D-2, + > 3.599789431577641D-1, 7.518873114594296D-2, + > 4.311305838436490D-1, 7.964552607244304D-2, + > 5.031191739976250D-1, 8.310615532185532D-2, + > 5.741997608797084D-1, 8.557281096997747D-2, + > 6.427021081394999D-1, 8.705010633284512D-2, + > 7.071067811865475D-1, 8.754202768311478D-2, + > 7.661161793050990D-1, 8.705010633284512D-2, + > 8.187152341355850D-1, 8.557281096997747D-2, + > 8.642170426206298D-1, 8.310615532185532D-2, + > 9.022895431482260D-1, 7.964552607244304D-2, + > 9.329604281442055D-1, 7.518873114594296D-2, + > 9.565987806014759D-1, 6.974022040259096D-2, + > 9.738734033874612D-1, 6.331631488632194D-2, + > 9.856894589319176D-1, 5.595108446790947D-2, + > 9.931068182377288D-1, 4.770225064114276D-2, + > 9.972453537961454D-1, 3.865622019474338D-2, + > 9.991841462964235D-1, 2.893121574263062D-2, + > 9.998629581127622D-1, 1.867799415496943D-2, + > 9.999950237146908D-1, 8.088519222518445D-3/ +*---- +* Order = 56 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=379,406)/ + > 2.937783068161103D-3, 7.532680050608221D-3, + > 1.542057328035316D-2, 1.740393870836662D-2, + > 3.763822344160284D-2, 2.698374387900945D-2, + > 6.917953054276372D-2, 3.610294286409177D-2, + > 1.094349422308658D-1, 4.462772409676748D-2, + > 1.575965218033132D-1, 5.245143079823476D-2, + > 2.126604305088603D-1, 5.949430183433835D-2, + > 2.734385687346029D-1, 6.570130151997985D-2, + > 3.385818199466888D-1, 7.103829899589742D-2, + > 4.066156050266695D-1, 7.548738262548303D-2, + > 4.759868689664975D-1, 7.904202969199018D-2, + > 5.451202571507631D-1, 8.170266224145589D-2, + > 6.124802047142074D-1, 8.347291855738130D-2, + > 6.766350014909858D-1, 8.435680753384398D-2, + > 7.363185959605350D-1, 8.435680753384398D-2, + > 7.904859257654386D-1, 8.347291855738130D-2, + > 8.383578622783268D-1, 8.170266224145589D-2, + > 8.794523867563669D-1, 7.904202969199018D-2, + > 9.135993376468678D-1, 7.548738262548303D-2, + > 9.409369538930799D-1, 7.103829899589742D-2, + > 9.618894682490145D-1, 6.570130151997985D-2, + > 9.771261644720124D-1, 5.949430183433835D-2, + > 9.875035880013286D-1, 5.245143079823476D-2, + > 9.939939604539492D-1, 4.462772409676748D-2, + > 9.976042264113975D-1, 3.610294286409177D-2, + > 9.992914310330896D-1, 2.698374387900945D-2, + > 9.998810958907590D-1, 1.740393870836662D-2, + > 9.999956847060113D-1, 7.532680050608221D-3/ +*---- +* Order = 58 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=407,435)/ + > 2.742433926349367D-3, 7.032198002138893D-3, + > 1.439878984638582D-2, 1.625558572095192D-2, + > 3.516048827839076D-2, 2.522520908746962D-2, + > 6.466981500411214D-2, 3.379142344706885D-2, + > 1.023963769013716D-1, 4.183513829563056D-2, + > 1.476370627578143D-1, 4.926003874337995D-2, + > 1.995172380704506D-1, 5.599261639569382D-2, + > 2.569989752795515D-1, 6.198069665978488D-2, + > 3.188984690691561D-1, 6.719054793752873D-2, + > 3.839134581171505D-1, 7.160316710825960D-2, + > 4.506602512451940D-1, 7.521031896392870D-2, + > 5.177188670869931D-1, 7.801077736827083D-2, + > 5.836839333174925D-1, 8.000706366604473D-2, + > 6.472183977592858D-1, 8.120284618700015D-2, + > 7.071067811865475D-1, 8.160107162859419D-2, + > 7.623046278240104D-1, 8.120284618700015D-2, + > 8.119809517390300D-1, 8.000706366604473D-2, + > 8.555508019177823D-1, 7.801077736827083D-2, + > 8.926955460556631D-1, 7.521031896392870D-2, + > 9.233690793374722D-1, 7.160316710825960D-2, + > 9.477888828348582D-1, 6.719054793752873D-2, + > 9.664116755840962D-1, 6.198069665978488D-2, + > 9.798943166039586D-1, 5.599261639569382D-2, + > 9.890416056467216D-1, 4.926003874337995D-2, + > 9.947436765305283D-1, 4.183513829563056D-2, + > 9.979067165959621D-1, 3.379142344706885D-2, + > 9.993816788715036D-1, 2.522520908746962D-2, + > 9.998963320519581D-1, 1.625558572095192D-2, + > 9.999962395210092D-1, 7.032198002138893D-3/ +*---- +* Order = 60 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=436,465)/ + > 2.565935816040464D-3, 6.579962619041378D-3, + > 1.347516554782726D-2, 1.521696776845086D-2, + > 3.291878087349994D-2, 2.363209088631991D-2, + > 6.058415580193666D-2, 3.169244521291083D-2, + > 9.600762130781930D-2, 3.929176131897425D-2, + > 1.385744973107413D-1, 4.634296332807871D-2, + > 1.875194470293309D-1, 5.277837509680457D-2, + > 2.419322530851564D-1, 5.854875269926412D-2, + > 3.007708877829240D-1, 6.362110627094798D-2, + > 3.628827241348177D-1, 6.797575914341677D-2, + > 4.270337881301431D-1, 7.160310605662001D-2, + > 4.919450854898168D-1, 7.450044532753710D-2, + > 5.563343213452209D-1, 7.666914603657626D-2, + > 6.189608105599492D-1, 7.811230591489950D-2, + > 6.786710589083211D-1, 7.883297571760606D-2, + > 7.344423692845193D-1, 7.883297571760606D-2, + > 7.854218707108751D-1, 7.811230591489950D-2, + > 8.309585566641411D-1, 7.666914603657626D-2, + > 8.706262302862330D-1, 7.450044532753710D-2, + > 9.042356682830091D-1, 7.160310605662001D-2, + > 9.318348182615274D-1, 6.797575914341677D-2, + > 9.536964260509063D-1, 6.362110627094798D-2, + > 9.702931438061076D-1, 5.854875269926412D-2, + > 9.822608904897995D-1, 5.277837509680457D-2, + > 9.903520125162948D-1, 4.634296332807871D-2, + > 9.953805988921094D-1, 3.929176131897425D-2, + > 9.981630929190713D-1, 3.169244521291083D-2, + > 9.994580300671972D-1, 2.363209088631991D-2, + > 9.999092058349391D-1, 1.521696776845086D-2, + > 9.999967079812753D-1, 6.579962619041378D-3/ +*---- +* Order = 62 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=466,496)/ + > 2.405939628907848D-3, 6.169968963546275D-3, + > 1.263753399803356D-2, 1.427456861312436D-2, + > 3.088414635685555D-2, 2.218439608809088D-2, + > 5.687137210380912D-2, 2.978102161065714D-2, + > 9.019210028251855D-2, 3.696937092634360D-2, + > 1.303066527232758D-1, 4.367061943331126D-2, + > 1.765426012600548D-1, 4.982249645060048D-2, + > 2.280987746820670D-1, 5.537868201403226D-2, + > 2.840550769938310D-1, 6.030717484633422D-2, + > 3.433889379342239D-1, 6.458796732100688D-2, + > 4.049984831103632D-1, 6.821039566414624D-2, + > 4.677318207524097D-1, 7.117047743682441D-2, + > 5.304212533007296D-1, 7.346846419828167D-2, + > 5.919207725381885D-1, 7.510675391195046D-2, + > 6.511448995883448D-1, 7.608824036260866D-2, + > 7.071067811865475D-1, 7.641513111317905D-2, + > 7.589534371356944D-1, 7.608824036260866D-2, + > 8.059961532400723D-1, 7.510675391195046D-2, + > 8.477342119124858D-1, 7.346846419828167D-2, + > 8.838704338621333D-1, 7.117047743682441D-2, + > 9.143173566537523D-1, 6.821039566414624D-2, + > 9.391932907045310D-1, 6.458796732100688D-2, + > 9.588079647322652D-1, 6.030717484633422D-2, + > 9.736379968902917D-1, 5.537868201403226D-2, + > 9.842930000463954D-1, 4.982249645060048D-2, + > 9.914737395695640D-1, 4.367061943331126D-2, + > 9.959243872135214D-1, 3.696937092634360D-2, + > 9.983815137686745D-1, 2.978102161065714D-2, + > 9.995229709735581D-1, 2.218439608809088D-2, + > 9.999201431786683D-1, 1.427456861312436D-2, + > 9.999971057230626D-1, 6.169968963546275D-3/ +*---- +* Order = 64 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=497,528)/ + > 2.260451006401776D-3, 5.797117680017662D-3, + > 1.187555474628660D-2, 1.341688614356055D-2, + > 2.903192296767898D-2, 2.086504628721960D-2, + > 5.348772246647195D-2, 2.803569126620853D-2, + > 8.488403572313128D-2, 3.484354779039823D-2, + > 1.227451197406277D-1, 4.121716160665880D-2, + > 1.664778916763791D-1, 4.709924845926102D-2, + > 2.153746593423551D-1, 5.244635195862705D-2, + > 2.686204966167571D-1, 5.722762992459373D-2, + > 3.253060318502849D-1, 6.142301931103583D-2, + > 3.844458467127314D-1, 6.502107279693194D-2, + > 4.450021333238041D-1, 6.801672562809563D-2, + > 5.059127742515483D-1, 7.040918982162950D-2, + > 5.661226261485058D-1, 7.220010760651431D-2, + > 6.246165176514237D-1, 7.339204014218695D-2, + > 6.804523156165483D-1, 7.398732697450898D-2, + > 7.327923622500970D-1, 7.398732697450898D-2, + > 7.809316268899658D-1, 7.339204014218695D-2, + > 8.243210370739783D-1, 7.220010760651431D-2, + > 8.625846421361221D-1, 7.040918982162950D-2, + > 8.955295089148449D-1, 6.801672562809563D-2, + > 9.231475455989314D-1, 6.502107279693194D-2, + > 9.456087910133986D-1, 6.142301931103583D-2, + > 9.632460894274976D-1, 5.722762992459373D-2, + > 9.765314926376745D-1, 5.244635195862705D-2, + > 9.860451873940605D-1, 4.709924845926102D-2, + > 9.924382275889311D-1, 4.121716160665880D-2, + > 9.963908372116607D-1, 3.484354779039823D-2, + > 9.985685071868378D-1, 2.803569126620853D-2, + > 9.995784848869041D-1, 2.086504628721960D-2, + > 9.999294831134183D-1, 1.341688614356055D-2, + > 9.999974451773603D-1, 5.797117680017662D-3/ +*---- +* Order = 66 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=529,561)/ + > 2.127767955855947D-3, 5.457055989066269D-3, + > 1.118039441421181D-2, 1.263408341121632D-2, + > 2.734100277100129D-2, 1.965938521651337D-2, + > 5.039565382935335D-2, 2.643794451890077D-2, + > 8.002669926187768D-2, 3.289309077657504D-2, + > 1.158131591183225D-1, 3.895995661650402D-2, + > 1.572300146684183D-1, 4.458584184375271D-2, + > 2.036500183342073D-1, 4.973005671396442D-2, + > 2.543492281175076D-1, 5.436302857337294D-2, + > 3.085169689930697D-1, 5.846485650012917D-2, + > 3.652704783006284D-1, 6.202354684819099D-2, + > 4.236740543125242D-1, 6.503314324601964D-2, + > 4.827621314188725D-1, 6.749192029021972D-2, + > 5.415653801336422D-1, 6.940075957307684D-2, + > 5.991386896375901D-1, 7.076178092149795D-2, + > 6.545897375326029D-1, 7.157726645471736D-2, + > 7.071067811865475D-1, 7.184889180746158D-2, + > 7.559843090415290D-1, 7.157726645471736D-2, + > 8.006452588876996D-1, 7.076178092149795D-2, + > 8.406586340725370D-1, 6.940075957307684D-2, + > 8.757515198204952D-1, 6.749192029021972D-2, + > 9.058147137811288D-1, 6.503314324601964D-2, + > 9.309014328499179D-1, 6.202354684819099D-2, + > 9.512188390918934D-1, 5.846485650012917D-2, + > 9.671124392520386D-1, 5.436302857337294D-2, + > 9.790437528693378D-1, 4.973005671396442D-2, + > 9.875620094390878D-1, 4.458584184375271D-2, + > 9.932710164778967D-1, 3.895995661650402D-2, + > 9.967927203813484D-1, 3.289309077657504D-2, + > 9.987293317386408D-1, 2.643794451890077D-2, + > 9.996261649073998D-1, 1.965938521651337D-2, + > 9.999374974370861D-1, 1.263408341121632D-2, + > 9.999977362992008D-1, 5.457055989066269D-3/ +*---- +* Order = 68 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=562,595)/ + > 2.006430897540039D-3, 5.146050313292597D-3, + > 1.054447088264912D-2, 1.191770807990189D-2, + > 2.579323625075468D-2, 1.855478004998946D-2, + > 4.756278722072234D-2, 2.497175458640582D-2, + > 7.557097996402496D-2, 3.109953168579275D-2, + > 1.094439543367078D-1, 3.687913529406050D-2, + > 1.487153270030891D-1, 4.226206890226890D-2, + > 1.928273387808641D-1, 4.721028879193994D-2, + > 2.411349977536837D-1, 5.169555561856539D-2, + > 2.929138510155265D-1, 5.569829899210566D-2, + > 3.473716688709153D-1, 5.920617987876196D-2, + > 4.036639760910661D-1, 6.221252672611230D-2, + > 4.609130411977627D-1, 6.471478978336624D-2, + > 5.182296606197990D-1, 6.671311918267942D-2, + > 5.747368634369850D-1, 6.820913521902009D-2, + > 6.295945185532131D-1, 6.920492910010646D-2, + > 6.820237474599884D-1, 6.970231119307893D-2, + > 7.313300266641826D-1, 6.970231119307893D-2, + > 7.769238973076757D-1, 6.920492910010646D-2, + > 8.183382783461961D-1, 6.820913521902009D-2, + > 8.552414973876606D-1, 6.671311918267942D-2, + > 8.874453044857635D-1, 6.471478978336624D-2, + > 9.149073146534305D-1, 6.221252672611230D-2, + > 9.377275316774245D-1, 5.920617987876196D-2, + > 9.561388371378154D-1, 5.569829899210566D-2, + > 9.704915830950472D-1, 5.169555561856539D-2, + > 9.812327029908297D-1, 4.721028879193994D-2, + > 9.888800491032086D-1, 4.226206890226890D-2, + > 9.939929682141341D-1, 3.687913529406050D-2, + > 9.971404249087873D-1, 3.109953168579275D-2, + > 9.988682502071013D-1, 2.497175458640582D-2, + > 9.996672991369242D-1, 1.855478004998946D-2, + > 9.999444055215295D-1, 1.191770807990189D-2, + > 9.999979871155008D-1, 5.146050313292597D-3/ +*---- +* Order = 70 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=596,630)/ + > 1.895182390808144D-3, 4.860883544830628D-3, + > 9.961246688281479D-3, 1.126046540783217D-2, + > 2.437294975502797D-2, 1.754029683264231D-2, + > 4.496109079691220D-2, 2.362319238448706D-2, + > 7.147420525157438D-2, 2.944673122343525D-2, + > 1.035791506531498D-1, 3.495721171268495D-2, + > 1.408602617289225D-1, 4.010998546152185D-2, + > 1.828200227142416D-1, 4.486951999487671D-2, + > 2.288821565254979D-1, 4.920893733923423D-2, + > 2.783976951621312D-1, 5.310912506931291D-2, + > 3.306543210696288D-1, 5.655756629702146D-2, + > 3.848889902593347D-1, 5.954703320530382D-2, + > 4.403035834865983D-1, 6.207426689302348D-2, + > 4.960831016113237D-1, 6.413873664427702D-2, + > 5.514157377272589D-1, 6.574154187441527D-2, + > 6.055140267651983D-1, 6.688449453259325D-2, + > 6.576361927484648D-1, 6.756940076441969D-2, + > 7.071067811865475D-1, 6.779754843107255D-2, + > 7.533356741767272D-1, 6.756940076441969D-2, + > 7.958346331937275D-1, 6.688449453259325D-2, + > 8.342305941325233D-1, 6.574154187441527D-2, + > 8.682750464545719D-1, 6.413873664427702D-2, + > 8.978489596635172D-1, 6.207426689302348D-2, + > 9.229628731304146D-1, 5.954703320530382D-2, + > 9.437519377240943D-1, 5.655756629702146D-2, + > 9.604658886854926D-1, 5.310912506931291D-2, + > 9.734541378124793D-1, 4.920893733923423D-2, + > 9.831463976920040D-1, 4.486951999487671D-2, + > 9.900294877758235D-1, 4.010998546152185D-2, + > 9.946212141061401D-1, 3.495721171268495D-2, + > 9.974424484568801D-1, 2.944673122343525D-2, + > 9.989887388326016D-1, 2.362319238448706D-2, + > 9.997029355364717D-1, 1.754029683264231D-2, + > 9.999503855514108D-1, 1.126046540783217D-2, + > 9.999982041402402D-1, 4.860883544830628D-3/ +*---- +* Order = 72 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=631,666)/ + > 1.792934454202931D-3, 4.598771655133457D-3, + > 9.425061112313890D-3, 1.065603341978431D-2, + > 2.306655207082563D-2, 1.660643477465490D-2, + > 4.256620201285560D-2, 2.238010857286012D-2, + > 6.769916617188922D-2, 2.792054146952203D-2, + > 9.816763086953637D-2, 3.317875933222189D-2, + > 1.335999707374397D-1, 3.811363223988677D-2, + > 1.735510826588126D-1, 4.269199698797202D-2, + > 2.175046751209386D-1, 4.688833809218218D-2, + > 2.648780127840390D-1, 5.068409479675100D-2, + > 3.150293990097726D-1, 5.406671002171079D-2, + > 3.672684559193769D-1, 5.702853994383097D-2, + > 4.208690454062535D-1, 5.956572815765240D-2, + > 4.750844817568741D-1, 6.167712597050399D-2, + > 5.291645281141019D-1, 6.336331655665649D-2, + > 5.823735501979260D-1, 6.462577941116331D-2, + > 6.340091223112186D-1, 6.546621488177129D-2, + > 6.834203406787824D-1, 6.588603711319039D-2, + > 7.300250940525928D-1, 6.588603711319039D-2, + > 7.733255671618250D-1, 6.546621488177129D-2, + > 8.129213049427747D-1, 6.462577941116331D-2, + > 8.485192409048718D-1, 6.336331655665649D-2, + > 8.799401884183961D-1, 6.167712597050399D-2, + > 9.071214067691430D-1, 5.956572815765240D-2, + > 9.301149828309383D-1, 5.702853994383097D-2, + > 9.490819130926168D-1, 5.406671002171079D-2, + > 9.642819288691345D-1, 5.068409479675100D-2, + > 9.760592790914571D-1, 4.688833809218218D-2, + > 9.848248685466640D-1, 4.269199698797202D-2, + > 9.910353413571865D-1, 3.811363223988677D-2, + > 9.951698931586820D-1, 3.317875933222189D-2, + > 9.977057797264838D-1, 2.792054146952203D-2, + > 9.990936484865674D-1, 2.238010857286012D-2, + > 9.997339316916096D-1, 1.660643477465490D-2, + > 9.999555831250852D-1, 1.065603341978431D-2, + > 9.999983926917297D-1, 4.598771655133457D-3/ +*---- +* Order = 74 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=667,703)/ + > 1.698741886354622D-3, 4.357295595609470D-3, + > 8.930992904023735D-3, 1.009891155595077D-2, + > 2.186221185368514D-2, 1.574490757594847D-2, + > 4.035686918939289D-2, 2.123186989304243D-2, + > 6.421330823399199D-2, 2.650852294936087D-2, + > 9.316448689887876D-2, 3.153013523379523D-2, + > 1.268771624175196D-1, 3.625879153931750D-2, + > 1.649519866208174D-1, 4.066355379567878D-2, + > 2.069251875729949D-1, 4.472025016442803D-2, + > 2.522722781263537D-1, 4.841093781051414D-2, + > 3.004140595738183D-1, 5.172313096383708D-2, + > 3.507250096820162D-1, 5.464889158975430D-2, + > 4.025439676980595D-1, 5.718387043152167D-2, + > 4.551868677602700D-1, 5.932636945044961D-2, + > 5.079611361117360D-1, 6.107647781254220D-2, + > 5.601812617687321D-1, 6.243531594168673D-2, + > 6.111849763541508D-1, 6.340440772608052D-2, + > 6.603494357038005D-1, 6.398519049059308D-2, + > 7.071067811865475D-1, 6.417866575467489D-2, + > 7.509584694013859D-1, 6.398519049059308D-2, + > 7.914877918698279D-1, 6.340440772608052D-2, + > 8.283700585868560D-1, 6.243531594168673D-2, + > 8.613799882746722D-1, 6.107647781254220D-2, + > 8.903959318295398D-1, 5.932636945044961D-2, + > 9.154006522118627D-1, 5.718387043152167D-2, + > 9.364784928569100D-1, 5.464889158975430D-2, + > 9.538088869424411D-1, 5.172313096383708D-2, + > 9.676562910914906D-1, 4.841093781051414D-2, + > 9.783567686421354D-1, 4.472025016442803D-2, + > 9.863015979454995D-1, 4.066355379567878D-2, + > 9.919184369981628D-1, 3.625879153931750D-2, + > 9.956507311205414D-1, 3.153013523379523D-2, + > 9.979361958790984D-1, 2.650852294936087D-2, + > 9.991853297107750D-1, 2.123186989304243D-2, + > 9.997609932843272D-1, 1.574490757594847D-2, + > 9.999601178875827D-1, 1.009891155595077D-2, + > 9.999985571369608D-1, 4.357295595609470D-3/ +*---- +* Start processing +*---- + PI=XDRCST('Pi',' ') + NBPT=(ORDRE*(ORDRE+2))/8 + IF(3*NBPT .NE. NBANGL) CALL XABORT(NAMSBR// + >': Number of quadrature points is invalid') + ILEVEL=1 + JLEVEL=0 + NLEVEL=ORDRE/2 + KLEVEL=(NLEVEL*(NLEVEL-1))/2 + IPOINT=0 + DO IPT=1,NBPT + JLEVEL = JLEVEL + 1 + ALPHA =PI*(DBLE(NLEVEL-ILEVEL+1-JLEVEL)+DONE/DTWO) + > /(DTWO*DBLE(NLEVEL-ILEVEL+1)) + XI=SYST(1,KLEVEL+ILEVEL) + ROTXI=SQRT(DONE-XI**2) + COSA=COS(ALPHA) + SINA=SIN(ALPHA) + WGTINV=3.0D0*PI*DBLE(ORDRE+2.0D0)/SYST(2,KLEVEL+ILEVEL) + DO IROT=1,3 +*---- +* \xi direction (3) +* \mu direction (2) +* \eta direction (1) +*---- + IDIR1=MOD(IROT-1,3)+1 + IDIR2=MOD(IROT,3)+1 + IDIR3=MOD(IROT+1,3)+1 + IPOINT=IPOINT+1 + DDENWT(1,IPOINT)=DQUAD(1)*WGTINV + DANGLT(IDIR1,1,IPOINT)=COSA*ROTXI + DANGLT(IDIR2,1,IPOINT)=SINA*ROTXI + DANGLT(IDIR3,1,IPOINT)=XI + DDENWT(2,IPOINT)=DQUAD(2)*WGTINV + DANGLT(1,2,IPOINT)=-DANGLT(1,1,IPOINT) + DANGLT(2,2,IPOINT)=DANGLT(2,1,IPOINT) + DANGLT(3,2,IPOINT)=DANGLT(3,1,IPOINT) + DDENWT(3,IPOINT)=DQUAD(3)*WGTINV + DANGLT(1,3,IPOINT)=DANGLT(1,1,IPOINT) + DANGLT(2,3,IPOINT)=-DANGLT(2,1,IPOINT) + DANGLT(3,3,IPOINT)=DANGLT(3,1,IPOINT) + DDENWT(4,IPOINT)=DQUAD(4)*WGTINV + DANGLT(1,4,IPOINT)=-DANGLT(1,1,IPOINT) + DANGLT(2,4,IPOINT)=-DANGLT(2,1,IPOINT) + DANGLT(3,4,IPOINT)=DANGLT(3,1,IPOINT) + ENDDO + IF(JLEVEL .EQ. NLEVEL-ILEVEL+1) THEN + ILEVEL = ILEVEL + 1 + JLEVEL = 0 + ENDIF + ENDDO + RETURN + END diff --git a/Dragon/src/NXTQSC.f b/Dragon/src/NXTQSC.f new file mode 100644 index 0000000..2b038a3 --- /dev/null +++ b/Dragon/src/NXTQSC.f @@ -0,0 +1,134 @@ +*DECK NXTQSC + SUBROUTINE NXTQSC(IPRINT,NDIM ,NBANGL,MAXMSH,NUCELL, + > DGMESH,DANGLT,DDENWT,DNSANG,NBSANG,DEPART) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To define spatial quadrature for cyclic tracking. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau, R.Roy +* +*Parameters: input +* IPRINT print level. +* NDIM number of dimensions for geometry. +* NBANGL number of angles. +* MAXMSH maximum number of elements in mesh vector for +* each directions. +* NUCELL number of cell after unfolding in +* $X$, $Y$ and $Z$ directions. +* DGMESH meshing vector for global geometry. +* DANGLT director cosines of angles. +* DDENWT angular density for each angle. +* +*Parameters: input/output +* DNSANG spatial density required. +* NBSANG number of segments for each angles. +* +*Parameters: output +* DEPART track starting point. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* \\\\ +* Extracted from the subroutine XELTS2. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,NDIM,NBANGL,MAXMSH,NUCELL(3) + DOUBLE PRECISION DGMESH(-1:MAXMSH,3),DANGLT(NDIM,NBANGL), + > DDENWT(NBANGL),DNSANG(NBANGL) + INTEGER NBSANG(5,NBANGL) + DOUBLE PRECISION DEPART(NDIM,2,NBANGL) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTQSC') + DOUBLE PRECISION DZERO,DONE,DTWO,DHALF + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0, + > DHALF=DONE/DTWO) +*---- +* Local variables +*---- + INTEGER IANG,IGEN,IX,IY + DOUBLE PRECISION PROJ(4),PMIN,PMAX,DP +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6002) + ENDIF +*---- +* Find the radius of the sphere (3-D) or circle surrounding +* the cell. +* Also find the true center of the cell +*---- + DO IANG=1,NBANGL + IGEN=0 + DP=DONE/DNSANG(IANG) + DO IX=0,NUCELL(1),NUCELL(1) + DO IY=0,NUCELL(2),NUCELL(2) + IGEN=IGEN+1 + PROJ(IGEN)=DGMESH(IX,1)*DANGLT(2,IANG) + > -DGMESH(IY,2)*DANGLT(1,IANG) + ENDDO + ENDDO + PMIN=PROJ(1) + PMAX=PROJ(1) + DO IGEN=2,4 + PMIN=MIN(PMIN,PROJ(IGEN)) + PMAX=MAX(PMAX,PROJ(IGEN)) + ENDDO + NBSANG(5,IANG)=NINT((PMAX-PMIN)*DNSANG(IANG))+1 + PMIN=PMIN+DHALF*DP + DEPART(1,1,IANG)=PMIN*DANGLT(2,IANG) + DEPART(2,1,IANG)=-PMIN*DANGLT(1,IANG) + DEPART(1,2,IANG)=DP*DANGLT(2,IANG) + DEPART(2,2,IANG)=-DP*DANGLT(1,IANG) + DNSANG(IANG)=DP/(DTWO*DDENWT(IANG)) + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6003) IANG,DNSANG(IANG),NBSANG(5,IANG) + WRITE(IOUT,6004) (DANGLT(IGEN,IANG),IGEN=1,NDIM) + WRITE(IOUT,6005) (DEPART(IGEN,1,IANG),IGEN=1,NDIM) + WRITE(IOUT,6006) (DEPART(IGEN,2,IANG),IGEN=1,NDIM) + ENDIF + ENDDO + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* Processing finished: return +*---- + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6002 FORMAT(' Spatial tracking information :') + 6003 FORMAT(' Tracking density and number of points=', + > I10,1X,F20.15,1X,I10) + 6004 FORMAT(' Track direction =',3(F20.15,2X)) + 6005 FORMAT(' Track starting point =',3(F20.15,2X)) + 6006 FORMAT(' Track displacement =',3(F20.15,2X)) + END diff --git a/Dragon/src/NXTQSS.f b/Dragon/src/NXTQSS.f new file mode 100644 index 0000000..6336ec9 --- /dev/null +++ b/Dragon/src/NXTQSS.f @@ -0,0 +1,173 @@ +*DECK NXTQSS + SUBROUTINE NXTQSS(IPRINT,NDIM ,ITYPBC,MAXMSH,NUCELL,DENUSR, + > DGMESH,NPLANE,NPOINT,DENLIN,SPACLN, + > WEIGHT,RADIUS,CENTER) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To define standard spatial quadrature. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau, R.Roy +* +*Parameters: input +* IPRINT print level. +* NDIM number of dimensions for geometry. +* ITYPBC type of boundary conditions ( +* +/- 2 for hexagones; +* +/- 1 for annular; +* 0 for Cartesian). +* MAXMSH maximum number of elements in mesh vector for +* each directions. +* NUCELL number of cell after unfolding in +* $X$, $Y$ and $Z$ directions. +* DENUSR user defined track density. +* DGMESH meshing vector for global geometry. +* +*Parameters: output +* NPLANE number of normal planes considered. +* NPOINT number of integration points along each axis +* in a plane mormal to track direction. +* DENLIN effective track density in plane. +* SPACLN linear track spacing in the plane. +* WEIGHT weight associated with each line in the plane. +* RADIUS radius of circle (2-D) or sphere (3-D) surrounding +* the geometry. +* CENTER center of circle (2-D) or sphere (3-D) surrounding +* the geometry. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* \\\\ +* Extracted from the subroutine XELTI2 and XELTI3. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,NDIM,ITYPBC,MAXMSH,NUCELL(3) + DOUBLE PRECISION DENUSR,DGMESH(-1:MAXMSH,3) + INTEGER NPLANE,NPOINT + DOUBLE PRECISION DENLIN,SPACLN,WEIGHT + DOUBLE PRECISION RADIUS,CENTER(NDIM) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTQSS') + DOUBLE PRECISION DZERO,DONE,DTWO + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Local variables +*---- + INTEGER IDIR,LSTCEL,NPO2,IX + DOUBLE PRECISION DM,XD +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF +*---- +* Find the radius of the sphere (3-D) or circle surrounding +* the cell. +* Also find the true center of the cell +*---- + IF(NDIM .EQ. 3) THEN + NPLANE=3 + DENLIN=SQRT(DENUSR) + ELSE IF(NDIM .EQ. 2) THEN + NPLANE=1 + DENLIN=DENUSR + ENDIF + IF(ABS(ITYPBC) .EQ. 2) THEN +*---- +* HEXAGONAL +*---- + RADIUS=DZERO + DO IDIR=1,2 + LSTCEL=NUCELL(IDIR) + CENTER(IDIR)=DGMESH(1,IDIR) + DM=DZERO + DO IX=1,LSTCEL + XD=DGMESH(IX,IDIR)-DGMESH(1,IDIR)+DGMESH(0,IDIR) + DM=MAX(DM,XD*XD) + ENDDO + RADIUS=RADIUS+DM + ENDDO + DM=DZERO + DO IDIR=3,NDIM + LSTCEL=NUCELL(IDIR) + CENTER(IDIR)=(DGMESH(LSTCEL,IDIR)+DGMESH(0,IDIR))/DTWO + DM=((DGMESH(LSTCEL,IDIR)-DGMESH(0,IDIR))/DTWO)**2 + ENDDO + RADIUS=SQRT(RADIUS+DM) + ELSE IF(ABS(ITYPBC) .EQ. 1) THEN +*---- +* RADIAL +*---- + RADIUS=DZERO + DO IDIR=1,NDIM + LSTCEL=NUCELL(IDIR) + CENTER(IDIR)=(DGMESH(LSTCEL,IDIR)+DGMESH(0,IDIR))/DTWO + RADIUS=RADIUS+(DGMESH(LSTCEL,IDIR)-DGMESH(0,IDIR))**2 + ENDDO + RADIUS=SQRT(RADIUS)/DTWO + ELSE +*---- +* CARTESIAN +*---- + RADIUS=DZERO + DO IDIR=1,NDIM + LSTCEL=NUCELL(IDIR) + CENTER(IDIR)=(DGMESH(LSTCEL,IDIR)+DGMESH(0,IDIR))/DTWO + RADIUS=RADIUS+(DGMESH(LSTCEL,IDIR)-DGMESH(0,IDIR))**2 + ENDDO + RADIUS=SQRT(RADIUS)/DTWO + ENDIF + NPOINT=INT(DTWO*RADIUS*DENLIN)+1 + NPO2=NPOINT/2 + NPOINT=2*NPO2+1 + SPACLN=DTWO*RADIUS/DBLE(NPOINT) + DENLIN=DONE/SPACLN + IF(NDIM .EQ. 3) DENLIN=DENLIN*DENLIN + WEIGHT=DONE/(DBLE(NPLANE)*DENLIN) + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6002) DENUSR,DENLIN,WEIGHT,NPOINT,SPACLN + WRITE(IOUT,6010) RADIUS,(CENTER(IDIR),IDIR=1,NDIM) + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* Processing finished: return +*---- + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6002 FORMAT(' Spatial tracking information :'/ + > ' Minimum tracking density requested =',1P,E15.7/ + > ' Effective tracking density selected=',E15.7/ + > ' Effective tracking weight =',E15.7/ + > ' Number of points per direction =',I15/ + > ' Linear track spacing =',E15.7) + 6010 FORMAT(' RADIUS = ',1P,E20.12/ + > ' CENTER = ',3E20.12) + END diff --git a/Dragon/src/NXTRCS.f b/Dragon/src/NXTRCS.f new file mode 100644 index 0000000..f2b2b31 --- /dev/null +++ b/Dragon/src/NXTRCS.f @@ -0,0 +1,155 @@ +*DECK NXTRCS + SUBROUTINE NXTRCS(IPTRK ,IPRINT,IGEO ,ILEV , + > NREG ,NSUR ,NSURN ,IDFEX , + > INDXSR,NASUR ,IDSUR ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Renumber cell surfaces. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure. +* IPRINT intermediate printing level for output. +* IGEO geometry number. +* ILEV geometry level. +* NREG maximum number of regions in splitted geometry. +* NSUR maximum number of surfaces in splitted geometry. +* NSURN number of surfaces in splitted geometry after symmetry. +* IDFEX flag to identify surface to consider +* (see NXTCUA for Cartesion geometry +* and NXTHUA for hexagonal geometry). +* INDXSR local indexing of surfaces/regions. +* +*Parameters: input/output +* NASUR last surcace number considered. +* IDSUR surface identifier after symmetry. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPTRK + INTEGER IPRINT,IGEO,ILEV, + > NREG,NSUR,NSURN + INTEGER IDFEX(0:10),INDXSR(5,-NSUR:NREG) + INTEGER NASUR,IDSUR(NSUR) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTRCS') + DOUBLE PRECISION DZERO,DONE,DTWO + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Local variables +*---- + INTEGER IDGPP,ISUR,ID,IND,INV,LSTSUR,IDS,INS + CHARACTER NAMREC*12 +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: INREN +*---- +* Data +*---- + CHARACTER CLEV(2)*1 + SAVE CLEV + DATA CLEV /'C','P'/ +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + ALLOCATE(INREN(NSURN)) + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6012) + WRITE(IOUT,6014) (IDSUR(IDS),IDS=1,NSUR) + ENDIF +*---- +* Get rid of surfaces not used +*---- + DO ID=1,10 + IF(IDFEX(ID) .EQ. 0) THEN + IDGPP=(ID+1)/2 + IND=-(MOD(ID-1,2)+1) + DO ISUR=1,NSUR + IF(INDXSR(IDGPP,-ISUR) .EQ. IND) THEN + IDSUR(ISUR)=0 + ENDIF + ENDDO + ENDIF + ENDDO +*---- +* Renumber surfaces +*---- + INREN(:NSURN)=0 + INV=0 + DO ISUR=1,NSUR + IND=IDSUR(ISUR) + IF(IND .GT. 0) THEN + INV=INV+1 + INREN(IND)=INV + ENDIF + ENDDO + LSTSUR=INV+NASUR + DO ISUR=1,NSUR + IDS=IDSUR(ISUR) + IF(IDS .NE. 0) THEN + INS=INREN(ABS(IDS)) + IF(INS .NE. 0) INS=INS+NASUR + IF(IDS .LT. 0) THEN + IDSUR(ISUR)=-INS + ELSE + IDSUR(ISUR)=INS + ENDIF + ENDIF + ENDDO + NASUR=LSTSUR + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'SID' + CALL LCMPUT(IPTRK,NAMREC,NSUR,1,IDSUR) +*---- +* Processing finished: +* print routine closing output header if required +* and return +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6013) + WRITE(IOUT,6014) (IDSUR(IDS),IDS=1,NSUR) + WRITE(IOUT,6001) NAMSBR + ENDIF + DEALLOCATE(INREN) + RETURN +*---- +* FORMATS +*---- +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6012 FORMAT(' Original surfaces ID') + 6013 FORMAT(' Final surfaces ID') + 6014 FORMAT(5I15) + END diff --git a/Dragon/src/NXTRIS.f b/Dragon/src/NXTRIS.f new file mode 100644 index 0000000..a413b81 --- /dev/null +++ b/Dragon/src/NXTRIS.f @@ -0,0 +1,740 @@ +*DECK NXTRIS + SUBROUTINE NXTRIS(IPRINT,ITYPG ,MAXMSH,NREG ,ITRN ,ITST , + > ITSYM ,NM ,MIX ,ISPLT ,DAMESH, + > NMS ,MIXR ,ISPLTR,DAMESR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Rotate geometry according to reference turn and test, if required, +* in such a way that it satisfies intrinsic symmetries. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPRINT intermediate printing level for output. +* ITYPG geometry type. +* MAXMSH maximum number of elements in MESH array. +* NREG number of elements in MIX array. +* ITRN geometry original turn number. +* ITST flag for testing symmetry. +* ITSYM flag for symmetries to test. +* +*Parameters: input/output +* NM mesh size in all directions ($X$, $Y$, $Z$ and $R$). +* MIX final mixture description for geometry (including HMIX). +* ISPLT final split desctiption for geometry. +* DAMESH final mesh description for geometry. +* NMS mesh size after splitting. +* +*Parameters: temporary storage +* MIXR mixture description for rotated geometry (including HMIX). +* ISPLTR split desctiption for rotated geometry. +* DAMESR mesh description for rotated geometry. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,ITYPG,MAXMSH,NREG,ITRN,ITST, + > NM(4),ITSYM(4) + INTEGER ISPLT(0:MAXMSH-1,4),MIX(0:NREG-1,2) + DOUBLE PRECISION DAMESH(-1:MAXMSH,4) + INTEGER NMS(4),ISPLTR(0:MAXMSH-1,4,2), + > MIXR(0:NREG-1,2,2) + DOUBLE PRECISION DAMESR(-1:MAXMSH,4,2) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTRIS') + DOUBLE PRECISION DCUTOF,DZERO,DONE,DTWO + PARAMETER (DCUTOF=1.0D-6,DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Functions +*---- + INTEGER NXTTRS +*---- +* Local variables +*---- + INTEGER NR,NX,NY,NZ,ITM(4,2),NPG,IPG,IG,ICT,ITG, + > IDIR,IKT,IDMI,ITMI,IX,IY,IZ,IR,NRP1,NMR, + > NMT(4),NMTS(4),NMTMP + DOUBLE PRECISION DDD +*---- +* Data +*---- + CHARACTER CDIR(1:4)*1 + SAVE CDIR + DATA CDIR /'X','Y','Z','R'/ +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF +*---- +* Turn reference geometry (IPG=1) +* and symmetric geometries (IPG=2,3,4,5) +*---- + ICT=0 + NX=NM(1) + NY=NM(2) + NZ=MAX(NM(3),1) + NR=NM(4) + NRP1=NR+1 + NMR=NR + IF(ITYPG .EQ. 3 .OR. ITYPG .EQ. 6 .OR. + > ITYPG .EQ. 10 .OR. ITYPG .EQ. 11 ) THEN + NRP1=NR + NMR=NR-1 + ENDIF + ITM(3,1)=3 + ITM(3,2)=3 + ITM(4,1)=4 + ITM(4,2)=4 + NPG=1 + IF(ITST .EQ. 1) NPG=5 + DO IPG=1,NPG + IF(IPG .EQ. 1) THEN + IG=1 + ICT=ITRN + DO IX=0,NR-1 + DAMESR(IX,4,IG)=DAMESH(IX,4) + ISPLTR(IX,4,IG)=ISPLT(IX,4) + ENDDO + DAMESR(NR,4,IG)=DAMESH(NR,4) + ELSE + IG=2 + ITG=IPG-1 + IF(ABS(ITSYM(ITG)) .GE. 1) THEN +*---- +* Symmetry is valid +* Determine final turn after applying symmetry on +* current turn +*---- + IF(ITG .EQ. 1) THEN +*---- +* Symmetry in X +*---- + ICT=NXTTRS(ITRN,1) + ELSE IF(ITG .EQ. 2) THEN +*---- +* Symmetry in Y +*---- + ICT=NXTTRS(ITRN,3) + ELSE IF(ITG .EQ. 3) THEN +*---- +* Symmetry in Z +*---- + ICT=NXTTRS(ITRN,-1) + ELSE IF(ITG .EQ. 4) THEN +*---- +* Symmetry in X=Y or X=-Y +*---- + IF(ABS(ITSYM(ITG)) .EQ. 1) THEN + ICT=NXTTRS(ITRN,2) + ELSE + ICT=NXTTRS(ITRN,4) + ENDIF + ENDIF + ELSE +*---- +* No need to test the geometry for this +* intrinsic symmetry. +*---- + GO TO 1005 + ENDIF + ENDIF + IF(ICT .GT. 12 ) THEN + IKT=12-ICT + ELSE + IKT=ICT + ENDIF + DO IX=0,NR-1 + DAMESR(IX,4,IG)=DAMESH(IX,4) + ISPLTR(IX,4,IG)=ISPLT(IX,4) + ENDDO + DAMESR(NR,4,IG)=DAMESH(NR,4) + IF(IKT .LT. 0) THEN + DAMESR(-1,3,IG)=-DAMESH(-1,3) + DAMESR(-1,4,IG)=-DAMESH(-1,4) + ELSE + DAMESR(-1,3,IG)=DAMESH(-1,3) + DAMESR(-1,4,IG)=DAMESH(-1,4) + ENDIF + IF (ABS(IKT) .EQ. 1) THEN + ITM(1,IG)=1 + ITM(2,IG)=2 + DO 100 IX=0,NX-1 + DAMESR(IX,1,IG)=DAMESH(IX+1,1)-DAMESH(IX,1) + ISPLTR(IX,1,IG)=ISPLT(IX,1) + 100 CONTINUE + DAMESR(-1,1,IG)=DAMESH(-1,1) + DO 110 IY=0,NY-1 + DAMESR(IY,2,IG)=DAMESH(IY+1,2)-DAMESH(IY,2) + ISPLTR(IY,2,IG)=ISPLT(IY,2) + 110 CONTINUE + DAMESR(-1,2,IG)=DAMESH(-1,2) + IF(IKT .LT. 0) THEN + DO 120 IZ=0,NZ-1 + DAMESR(IZ,3,IG)=DAMESH(NZ-IZ,3)-DAMESH(NZ-IZ-1,3) + ISPLTR(IZ,3,IG)=ISPLT(NZ-IZ-1,3) + ITMI=IZ*NX*NY*NRP1 + IDMI=(NZ-IZ-1)*NX*NY*NRP1 + DO 121 IY=0,NY-1 + DO 122 IX=0,NX-1 + DO 123 IR=0,NMR + MIXR(ITMI,IG,1)=MIX(IDMI,1) + MIXR(ITMI,IG,2)=MIX(IDMI,2) + ITMI=ITMI+1 + IDMI=IDMI+1 + 123 CONTINUE + 122 CONTINUE + 121 CONTINUE + 120 CONTINUE + ELSE + DO 130 IZ=0,NZ-1 + DAMESR(IZ,3,IG)=DAMESH(IZ+1,3)-DAMESH(IZ,3) + ISPLTR(IZ,3,IG)=ISPLT(IZ,3) + ITMI=IZ*NX*NY*NRP1 + IDMI=ITMI + DO 131 IY=0,NY-1 + DO 132 IX=0,NX-1 + DO 133 IR=0,NMR + MIXR(ITMI,IG,1)=MIX(IDMI,1) + MIXR(ITMI,IG,2)=MIX(IDMI,2) + ITMI=ITMI+1 + IDMI=IDMI+1 + 133 CONTINUE + 132 CONTINUE + 131 CONTINUE + 130 CONTINUE + ENDIF + ELSE IF(ABS(IKT) .EQ. 2) THEN +*---- +* ROTATION OF PI/2 +*---- + ITM(1,IG)=2 + ITM(2,IG)=1 + DO 200 IX=0,NY-1 + DAMESR(IX,1,IG)=DAMESH(IX+1,2)-DAMESH(IX,2) + ISPLTR(IX,1,IG)=ISPLT(IX,2) + 200 CONTINUE + DAMESR(-1,1,IG)=DAMESH(-1,2) + DO 210 IY=0,NX-1 + DAMESR(IY,2,IG)=DAMESH(NX-IY,1)-DAMESH(NX-IY-1,1) + ISPLTR(IY,2,IG)=ISPLT(NX-IY-1,1) + 210 CONTINUE + DAMESR(-1,2,IG)=-DAMESH(-1,1) + IF(IKT .LT. 0) THEN + DO 220 IZ=0,NZ-1 + DAMESR(IZ,3,IG)=DAMESH(NZ-IZ,3)-DAMESH(NZ-IZ-1,3) + ISPLTR(IZ,3,IG)=ISPLT(NZ-IZ-1,3) + DO 221 IY=0,NX-1 + DO 222 IX=0,NY-1 + ITMI=IZ*NX*NY*NRP1+IY*NY*NRP1+ + > IX*NRP1 + IDMI=(NZ-IZ-1)*NX*NY*NRP1+(NY-IX-1)*NX*NRP1+ + > IY*NRP1 + DO 223 IR=0,NMR + MIXR(ITMI,IG,1)=MIX(IDMI,1) + MIXR(ITMI,IG,2)=MIX(IDMI,2) + ITMI=ITMI+1 + IDMI=IDMI+1 + 223 CONTINUE + 222 CONTINUE + 221 CONTINUE + 220 CONTINUE + ELSE + DO 230 IZ=0,NZ-1 + DAMESR(IZ,3,IG)=DAMESH(IZ+1,3)-DAMESH(IZ,3) + ISPLTR(IZ,3,IG)=ISPLT(IZ,3) + DO 231 IY=0,NX-1 + DO 232 IX=0,NY-1 + ITMI=IZ*NX*NY*NRP1+IY*NY*NRP1+ + > IX*NRP1 + IDMI=IZ*NX*NY*NRP1+IX*NX*NRP1+ + > (NX-IY-1)*NRP1 + DO 233 IR=0,NMR + MIXR(ITMI,IG,1)=MIX(IDMI,1) + MIXR(ITMI,IG,2)=MIX(IDMI,2) + ITMI=ITMI+1 + IDMI=IDMI+1 + 233 CONTINUE + 232 CONTINUE + 231 CONTINUE + 230 CONTINUE + ENDIF + ELSE IF(ABS(IKT) .EQ. 3) THEN +*---- +* ROTATION OF PI +*---- + ITM(1,IG)=1 + ITM(2,IG)=2 + DO 300 IX=0,NX-1 + DAMESR(IX,1,IG)=DAMESH(NX-IX,1)-DAMESH(NX-IX-1,1) + ISPLTR(IX,1,IG)=ISPLT(NX-IX-1,1) + 300 CONTINUE + DAMESR(-1,1,IG)=-DAMESH(-1,1) + DO 310 IY=0,NY-1 + DAMESR(IY,2,IG)=DAMESH(NY-IY,2)-DAMESH(NY-IY-1,2) + ISPLTR(IY,2,IG)=ISPLT(NY-IY-1,2) + 310 CONTINUE + DAMESR(-1,2,IG)=-DAMESH(-1,2) + IF(IKT .LT. 0) THEN + DO 320 IZ=0,NZ-1 + DAMESR(IZ,3,IG)=DAMESH(NZ-IZ,3)-DAMESH(NZ-IZ-1,3) + ISPLTR(IZ,3,IG)=ISPLT(NZ-IZ-1,3) + DO 321 IY=0,NY-1 + DO 322 IX=0,NX-1 + ITMI=IZ*NX*NY*NRP1+IY*NX*NRP1+ + > IX*NRP1 + IDMI=(NZ-IZ-1)*NX*NY*NRP1+(NY-IY-1)*NX*NRP1+ + > (NX-IX-1)*NRP1 + DO 323 IR=0,NMR + MIXR(ITMI,IG,1)=MIX(IDMI,1) + MIXR(ITMI,IG,2)=MIX(IDMI,2) + ITMI=ITMI+1 + IDMI=IDMI+1 + 323 CONTINUE + 322 CONTINUE + 321 CONTINUE + 320 CONTINUE + ELSE + DO 330 IZ=0,NZ-1 + DAMESR(IZ,3,IG)=DAMESH(IZ+1,3)-DAMESH(IZ,3) + ISPLTR(IZ,3,IG)=ISPLT(IZ,3) + DO 331 IY=0,NY-1 + DO 332 IX=0,NX-1 + ITMI=IZ*NX*NY*NRP1+IY*NX*NRP1+ + > IX*NRP1 + IDMI=IZ*NX*NY*NRP1+(NY-IY-1)*NX*NRP1+ + > (NX-IX-1)*NRP1 + DO 333 IR=0,NMR + MIXR(ITMI,IG,1)=MIX(IDMI,1) + MIXR(ITMI,IG,2)=MIX(IDMI,2) + ITMI=ITMI+1 + IDMI=IDMI+1 + 333 CONTINUE + 332 CONTINUE + 331 CONTINUE + 330 CONTINUE + ENDIF + ELSE IF(ABS(IKT) .EQ. 4) THEN +*---- +* ROTATION OF 3*PI/2 +*---- + ITM(1,IG)=2 + ITM(2,IG)=1 + DO 400 IX=0,NY-1 + DAMESR(IX,1,IG)=DAMESH(NY-IX,2)-DAMESH(NY-IX-1,2) + ISPLTR(IX,1,IG)=ISPLT(NY-IX-1,2) + 400 CONTINUE + DAMESR(-1,1,IG)=-DAMESH(-1,2) + DO 410 IY=0,NX-1 + DAMESR(IY,2,IG)=DAMESH(IY+1,1)-DAMESH(IY,1) + ISPLTR(IY,2,IG)=ISPLT(IY,1) + 410 CONTINUE + DAMESR(-1,2,IG)=DAMESH(-1,1) + IF(IKT .LT. 0) THEN + DO 420 IZ=0,NZ-1 + DAMESR(IZ,3,IG)=DAMESH(NZ-IZ,3)-DAMESH(NZ-IZ-1,3) + ISPLTR(IZ,3,IG)=ISPLT(NZ-IZ-1,3) + DO 421 IY=0,NX-1 + DO 422 IX=0,NY-1 + ITMI=IZ*NX*NY*NRP1+IY*NY*NRP1+ + > IX*NRP1 + IDMI=(NZ-IZ-1)*NX*NY*NRP1+(NY-IX-1)*NX*NRP1+ + > IY*NRP1 + DO 423 IR=0,NMR + MIXR(ITMI,IG,1)=MIX(IDMI,1) + MIXR(ITMI,IG,2)=MIX(IDMI,2) + ITMI=ITMI+1 + IDMI=IDMI+1 + 423 CONTINUE + 422 CONTINUE + 421 CONTINUE + 420 CONTINUE + ELSE + DO 430 IZ=0,NZ-1 + DAMESR(IZ,3,IG)=DAMESH(IZ+1,3)-DAMESH(IZ,3) + ISPLTR(IZ,3,IG)=ISPLT(IZ,3) + DO 431 IY=0,NX-1 + DO 432 IX=0,NY-1 + ITMI=IZ*NX*NY*NRP1+IY*NY*NRP1+ + > IX*NRP1 + IDMI=IZ*NX*NY*NRP1+(NY-IX-1)*NX*NRP1+ + > IY*NRP1 + DO 433 IR=0,NMR + MIXR(ITMI,IG,1)=MIX(IDMI,1) + MIXR(ITMI,IG,2)=MIX(IDMI,2) + ITMI=ITMI+1 + IDMI=IDMI+1 + 433 CONTINUE + 432 CONTINUE + 431 CONTINUE + 430 CONTINUE + ENDIF + ELSE IF(ABS(IKT) .EQ. 5) THEN +*---- +* REFLECTION WITH RESPECT TO AXIS // TO Y +*---- + ITM(1,IG)=1 + ITM(2,IG)=2 + DO 500 IX=0,NX-1 + DAMESR(IX,1,IG)=DAMESH(NX-IX,1)-DAMESH(NX-IX-1,1) + ISPLTR(IX,1,IG)=ISPLT(NX-IX-1,1) + 500 CONTINUE + DAMESR(-1,1,IG)=-DAMESH(-1,1) + DO 510 IY=0,NY-1 + DAMESR(IY,2,IG)=DAMESH(IY+1,2)-DAMESH(IY,2) + ISPLTR(IY,2,IG)=ISPLT(IY,2) + 510 CONTINUE + DAMESR(-1,2,IG)=DAMESH(-1,2) + IF(IKT .LT. 0) THEN + DO 520 IZ=0,NZ-1 + DAMESR(IZ,3,IG)=DAMESH(NZ-IZ,3)-DAMESH(NZ-IZ-1,3) + ISPLTR(IZ,3,IG)=ISPLT(NZ-IZ-1,3) + DO 521 IY=0,NY-1 + DO 522 IX=0,NX-1 + ITMI=IZ*NX*NY*NRP1+IY*NX*NRP1+ + > IX*NRP1 + IDMI=(NZ-IZ-1)*NX*NY*NRP1+IY*NX*NRP1+ + > (NX-IX-1)*NRP1 + DO 523 IR=0,NMR + MIXR(ITMI,IG,1)=MIX(IDMI,1) + MIXR(ITMI,IG,2)=MIX(IDMI,2) + ITMI=ITMI+1 + IDMI=IDMI+1 + 523 CONTINUE + 522 CONTINUE + 521 CONTINUE + 520 CONTINUE + ELSE + DO 530 IZ=0,NZ-1 + DAMESR(IZ,3,IG)=DAMESH(IZ+1,3)-DAMESH(IZ,3) + ISPLTR(IZ,3,IG)=ISPLT(IZ,3) + DO 531 IY=0,NY-1 + DO 532 IX=0,NX-1 + ITMI=IZ*NX*NY*NRP1+IY*NX*NRP1+ + > IX*NRP1 + IDMI=IZ*NX*NY*NRP1+IY*NX*NRP1+ + > (NX-IX-1)*NRP1 + DO 533 IR=0,NMR + MIXR(ITMI,IG,1)=MIX(IDMI,1) + MIXR(ITMI,IG,2)=MIX(IDMI,2) + ITMI=ITMI+1 + IDMI=IDMI+1 + 533 CONTINUE + 532 CONTINUE + 531 CONTINUE + 530 CONTINUE + ENDIF + ELSE IF(ABS(IKT) .EQ. 6) THEN +*---- +* ROTATION OF PI/2 FOLLOWED BY +* REFLECTION WITH RESPECT TO AXIS // TO Y +*---- + ITM(1,IG)=2 + ITM(2,IG)=1 + DO 600 IX=0,NY-1 + DAMESR(IX,1,IG)=DAMESH(IX+1,2)-DAMESH(IX,2) + ISPLTR(IX,1,IG)=ISPLT(IX,2) + 600 CONTINUE + DAMESR(-1,1,IG)=DAMESH(-1,2) + DO 610 IY=0,NX-1 + DAMESR(IY,2,IG)=DAMESH(IY+1,1)-DAMESH(IY,1) + ISPLTR(IY,2,IG)=ISPLT(IY,1) + 610 CONTINUE + DAMESR(-1,2,IG)=DAMESH(-1,1) + IF(IKT .LT. 0) THEN + DO 620 IZ=0,NZ-1 + DAMESR(IZ,3,IG)=DAMESH(NZ-IZ,3)-DAMESH(NZ-IZ-1,3) + ISPLTR(IZ,3,IG)=ISPLT(NZ-IZ-1,3) + DO 621 IY=0,NX-1 + DO 622 IX=0,NY-1 + ITMI=IZ*NX*NY*NRP1+IY*NY*NRP1+ + > IX*NRP1 + IDMI=(NZ-IZ-1)*NX*NY*NRP1+IX*NX*NRP1+ + > IY*NRP1 + DO 623 IR=0,NMR + MIXR(ITMI,IG,1)=MIX(IDMI,1) + MIXR(ITMI,IG,2)=MIX(IDMI,2) + ITMI=ITMI+1 + IDMI=IDMI+1 + 623 CONTINUE + 622 CONTINUE + 621 CONTINUE + 620 CONTINUE + ELSE + DO 630 IZ=0,NZ-1 + DAMESR(IZ,3,IG)=DAMESH(IZ+1,3)-DAMESH(IZ,3) + ISPLTR(IZ,3,IG)=ISPLT(IZ,3) + DO 631 IY=0,NX-1 + DO 632 IX=0,NY-1 + ITMI=IZ*NX*NY*NRP1+IY*NY*NRP1+ + > IX*NRP1 + IDMI=IZ*NX*NY*NRP1+IX*NX*NRP1+ + > IY*NRP1 + DO 633 IR=0,NMR + MIXR(ITMI,IG,1)=MIX(IDMI,1) + MIXR(ITMI,IG,2)=MIX(IDMI,2) + ITMI=ITMI+1 + IDMI=IDMI+1 + 633 CONTINUE + 632 CONTINUE + 631 CONTINUE + 630 CONTINUE + ENDIF + ELSE IF(ABS(IKT) .EQ. 7) THEN +*---- +* REFLECTION WITH RESPECT TO AXIS // TO X +*---- + ITM(1,IG)=1 + ITM(2,IG)=2 + DO 700 IX=0,NX-1 + DAMESR(IX,1,IG)=DAMESH(IX+1,1)-DAMESH(IX,1) + ISPLTR(IX,1,IG)=ISPLT(IX,1) + 700 CONTINUE + DAMESR(-1,1,IG)=DAMESH(-1,1) + DO 710 IY=0,NY-1 + DAMESR(IY,2,IG)=DAMESH(NY-IY,2)-DAMESH(NY-IY-1,2) + ISPLTR(IY,2,IG)=ISPLT(NY-IY-1,2) + 710 CONTINUE + DAMESR(-1,2,IG)=-DAMESH(-1,2) + IF(IKT .LT. 0) THEN + DO 720 IZ=0,NZ-1 + DAMESR(IZ,3,IG)=DAMESH(NZ-IZ,3)-DAMESH(NZ-IZ-1,3) + ISPLTR(IZ,3,IG)=ISPLT(NZ-IZ-1,3) + DO 721 IY=0,NY-1 + ITMI=IZ*NX*NY*NRP1+IY*NX*NRP1 + IDMI=(NZ-IZ-1)*NX*NY*NRP1+(NY-IY-1)*NX*NRP1 + DO 722 IX=0,NX-1 + DO 723 IR=0,NMR + MIXR(ITMI,IG,1)=MIX(IDMI,1) + MIXR(ITMI,IG,2)=MIX(IDMI,2) + ITMI=ITMI+1 + IDMI=IDMI+1 + 723 CONTINUE + 722 CONTINUE + 721 CONTINUE + 720 CONTINUE + ELSE + DO 730 IZ=0,NZ-1 + DAMESR(IZ,3,IG)=DAMESH(IZ+1,3)-DAMESH(IZ,3) + ISPLTR(IZ,3,IG)=ISPLT(IZ,3) + DO 731 IY=0,NY-1 + ITMI=IZ*NX*NY*NRP1+IY*NX*NRP1 + IDMI=IZ*NX*NY*NRP1+(NY-IY-1)*NX*NRP1 + DO 732 IX=0,NX-1 + DO 733 IR=0,NMR + MIXR(ITMI,IG,1)=MIX(IDMI,1) + MIXR(ITMI,IG,2)=MIX(IDMI,2) + ITMI=ITMI+1 + IDMI=IDMI+1 + 733 CONTINUE + 732 CONTINUE + 731 CONTINUE + 730 CONTINUE + ENDIF + ELSE IF(ABS(IKT) .EQ. 8) THEN +*---- +* ROTATION OF PI/2 FOLLOWED BY +* REFLECTION WITH RESPECT TO AXIS // TO X +*---- + ITM(1,IG)=2 + ITM(2,IG)=1 + DO 800 IX=0,NY-1 + DAMESR(IX,1,IG)=DAMESH(NY-IX,2)-DAMESH(NY-IX-1,2) + ISPLTR(IX,1,IG)=ISPLT(NY-IX-1,2) + 800 CONTINUE + DAMESR(-1,1,IG)=-DAMESH(-1,2) + DO 810 IY=0,NX-1 + DAMESR(IY,2,IG)=DAMESH(NX-IY,1)-DAMESH(NX-IY-1,1) + ISPLTR(IY,2,IG)=ISPLT(NX-IY-1,1) + 810 CONTINUE + DAMESR(-1,2,IG)=-DAMESH(-1,1) + IF(IKT .LT. 0) THEN + DO 820 IZ=0,NZ-1 + DAMESR(IZ,3,IG)=DAMESH(NZ-IZ,3)-DAMESH(NZ-IZ-1,3) + ISPLTR(IZ,3,IG)=ISPLT(NZ-IZ-1,3) + DO 821 IY=0,NX-1 + DO 822 IX=0,NY-1 + ITMI=IZ*NX*NY*NRP1+IY*NY*NRP1+ + > IX*NRP1 + IDMI=(NZ-IZ-1)*NX*NY*NRP1+(NY-IX-1)*NX*NRP1+ + > (NX-IY-1)*NRP1 + DO 823 IR=0,NMR + MIXR(ITMI,IG,1)=MIX(IDMI,1) + MIXR(ITMI,IG,2)=MIX(IDMI,2) + ITMI=ITMI+1 + IDMI=IDMI+1 + 823 CONTINUE + 822 CONTINUE + 821 CONTINUE + 820 CONTINUE + ELSE + DO 830 IZ=0,NZ-1 + DAMESR(IZ,3,IG)=DAMESH(IZ+1,3)-DAMESH(IZ,3) + ISPLTR(IZ,3,IG)=ISPLT(IZ,3) + DO 831 IY=0,NX-1 + DO 832 IX=0,NY-1 + ITMI=IZ*NX*NY*NRP1+IY*NY*NRP1+ + > IX*NRP1 + IDMI=IZ*NX*NY*NRP1+(NY-IX-1)*NX*NRP1+ + > (NX-IY-1)*NRP1 + DO 833 IR=0,NMR + MIXR(ITMI,IG,1)=MIX(IDMI,1) + MIXR(ITMI,IG,2)=MIX(IDMI,2) + ITMI=ITMI+1 + IDMI=IDMI+1 + 833 CONTINUE + 832 CONTINUE + 831 CONTINUE + 830 CONTINUE + ENDIF + ENDIF + IF(IPRINT .GE. 100) THEN +*---- +* Print turned mesh if required +*---- + WRITE(IOUT,6010) (NM(ITM(IDIR,IG)),IDIR=1,3),NREG + DO IDIR=1,4 + NMTMP=NM(ITM(IDIR,IG)) + IF(NMTMP .GT. 0) THEN + WRITE(IOUT,6011) 'MESH'//CDIR(IDIR)//' =' + WRITE(IOUT,6012) (DAMESR(IX,IDIR,IG),IX=-1,NMTMP) + WRITE(IOUT,6011) 'SPLT'//CDIR(IDIR)//' =' + WRITE(IOUT,6013) (ISPLTR(IX-1,IDIR,IG),IX=1,NMTMP) + ENDIF + ENDDO + WRITE(IOUT,6011) 'MIX =' + WRITE(IOUT,6013) (MIXR(IX,IG,1),IX=0,NREG-1) + WRITE(IOUT,6011) 'HMIX =' + WRITE(IOUT,6013) (MIXR(IX,IG,2),IX=0,NREG-1) + ENDIF + IF(IPG .GT. 1) THEN +*---- +* COMPARE GEOMETRY +* 1- MESH AND SPLIT IN X, Y AND Z +* 2- MIXTURES +* 3- OFFCENTER +*---- + DO 900 IDIR=1,3 + NMTMP=NM(ITM(IDIR,1)) + IF(NMTMP .NE. NM(ITM(IDIR,2))) CALL XABORT(NAMSBR// + > ': Symmetry invalid with this mesh') + DO 910 IX=0,NMTMP-1 + DDD=ABS(DAMESR(IX,IDIR,1)-DAMESR(IX,IDIR,2)) + IF(DDD .GT. DCUTOF) CALL XABORT(NAMSBR// + > ': Symmetry invalid with this mesh') + IF(ISPLTR(IX,IDIR,1) .NE. ISPLTR(IX,IDIR,2) ) + > CALL XABORT(NAMSBR// + > ': Symmetry invalid with this split') + 910 CONTINUE + 900 CONTINUE + DO 920 IX=0,NREG-1 + IF(MIXR(IX,1,1) .NE. MIXR(IX,2,1) ) CALL XABORT(NAMSBR// + > ': Symmetry invalid with this mixture') + IF(MIXR(IX,1,2) .NE. MIXR(IX,2,2) ) CALL XABORT(NAMSBR// + > ': Symmetry invalid with this merging mixture') + 920 CONTINUE + IF(DAMESR(-1,1,1) .NE. DAMESR(-1,1,2) .OR. + > DAMESR(-1,2,1) .NE. DAMESR(-1,2,2) .OR. + > DAMESR(-1,3,1) .NE. DAMESR(-1,3,2) ) CALL XABORT(NAMSBR// + > ': Symmetry invalid with this off center') + ELSE +*---- +* Reset reference geometry for turn +*---- + DO IX=0,NR-1 + DAMESH(IX,4)=DAMESR(IX,4,IG) + ISPLT(IX,4)=ISPLTR(IX,4,IG) + ENDDO + DAMESH(NR,4)=DAMESR(NR,4,IG) + DAMESH(-1,4)=DAMESR(-1,4,IG) +*---- +* Find splitted mesh dimensions +*---- + DO 930 IDIR=1,4 + NMTMP=NM(ITM(IDIR,1)) + NMT(IDIR)=NMTMP + NMTS(IDIR)=0 + DO 931 IX=0,NMTMP-1 + NMTS(IDIR)=NMTS(IDIR)+ABS(ISPLTR(IX,IDIR,1)) + 931 CONTINUE + IF(NMTS(IDIR) .NE. NMS(ITM(IDIR,1))) CALL XABORT(NAMSBR// + > ': Global symmetry invalid with this split') + 930 CONTINUE + ENDIF + 1005 CONTINUE + ENDDO +*---- +* Reset final mesh (center+original turn) +*---- + DO IDIR=1,3 + NMTMP=NMT(IDIR) + DAMESH(-1:NM(IDIR),IDIR)=DZERO + NM(IDIR)=NMTMP + DDD=DZERO + DO IX=0,NMTMP-1 + DDD=DDD+DAMESR(IX,IDIR,1) + ENDDO + DDD=DDD/DTWO + DAMESH(-1,IDIR)=DAMESR(-1,IDIR,1) + DAMESH(0,IDIR)=-DDD + DO IX=1,NMTMP + DAMESH(IX,IDIR)=DAMESH(IX-1,IDIR)+DAMESR(IX-1,IDIR,1) + ENDDO + DO IX=0,NMTMP + ISPLT(IX,IDIR)=ISPLTR(IX,IDIR,1) + ENDDO + ENDDO + DO IDIR=1,4 + NMTMP=NM(IDIR) + NMS(IDIR)=0 + DO IX=0,NMTMP-1 + NMS(IDIR)=NMS(IDIR)+ABS(ISPLT(IX,IDIR)) + ENDDO + ENDDO +*---- +* Processing finished: +* print routine closing output header if required +* and return +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* FORMATS +*---- +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(1X,' DIMENSIONS =',5I10/1X,' ORIGINAL MESH ') + 6011 FORMAT(1X,A7) + 6012 FORMAT(5F15.9) + 6013 FORMAT(5I15) + END diff --git a/Dragon/src/NXTRPS.f b/Dragon/src/NXTRPS.f new file mode 100644 index 0000000..8770e26 --- /dev/null +++ b/Dragon/src/NXTRPS.f @@ -0,0 +1,190 @@ +*DECK NXTRPS + SUBROUTINE NXTRPS(IPTRK ,IPRINT,ITYPG ,IGEO ,ILEV , + > NREG ,NSUR ,NSURN ,IDFEX , + > INDXSR,DHPIN ,DCMESH,NASUR ,IDSUR ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Renumber pin cluster surfaces. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure. +* IPRINT intermediate printing level for output. +* ITYPG type of geometry. +* IGEO geometry number. +* ILEV geometry level. +* NREG maximum number of regions in split geometry. +* NSUR maximum number of surfaces in split geometry. +* NSURN number of surfaces in splitted geometry after symmetry. +* IDFEX flag to identify surface to consider. +* INDXSR local indexing of surfaces/regions. +* DHPIN pins height. +* DCMESH cell dimensions. +* +*Parameters: input/output +* NASUR last surcace number considered. +* IDSUR surface identifier after symmetry. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPTRK + INTEGER IPRINT,ITYPG,IGEO,ILEV, + > NREG,NSUR,NSURN + INTEGER IDFEX(0:8),INDXSR(5,-NSUR:NREG) + DOUBLE PRECISION DHPIN,DCMESH(3,2) + INTEGER NASUR,IDSUR(NSUR) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTRPS') + DOUBLE PRECISION DZERO,DONE,DTWO + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Local variables +*---- + INTEGER IDGPP,IAS(2),IDIRS(2),ISUR,ID,IND, + > IDIRC,INV,LSTSUR,IDS,INS + CHARACTER NAMREC*12 + DOUBLE PRECISION DCTOP,DCBOT,DOFF,DPBOT,DPTOP +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: INREN +*---- +* Data +*---- + CHARACTER CLEV(2)*1 + SAVE CLEV + DATA CLEV /'C','P'/ +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + ALLOCATE(INREN(NSURN)) + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6012) + WRITE(IOUT,6014) (IDSUR(IDS),IDS=1,NSUR) + ENDIF +*---- +* Select main pin direction +*---- + IDGPP=3 + IF(ITYPG .EQ. 10 .OR. ITYPG .EQ. 21) THEN + IDGPP=1 + ELSE IF(ITYPG .EQ. 11 .OR. ITYPG .EQ. 22) THEN + IDGPP=2 + ENDIF +*---- +* Find if pin reaches bottom or top surface +*---- + DCTOP=DCMESH(IDGPP,1)/DTWO + DCBOT=-DCTOP + DOFF=DCMESH(IDGPP,2) + DPBOT=DCMESH(IDGPP,2)-DHPIN/DTWO + DPTOP=DPBOT+DHPIN + IAS(1)=0 + IF(DPBOT .LE. DCBOT .AND. DPTOP .GE. DCBOT) IAS(1)=1 + IAS(2)=0 + IF(DPBOT .LE. DCTOP .AND. DPTOP .GE. DCTOP) IAS(2)=1 + IDIRS(2)=2*IDGPP + IDIRS(1)=IDIRS(2)-1 +*---- +* get rid of radial surfaces +*---- + DO ISUR=1,NSUR + IF(INDXSR(4,-ISUR) .EQ. -2) THEN + IDSUR(ISUR)=0 + ENDIF + ENDDO +*---- +* Get rid of botton and top surfaces if not used +*---- + DO ID=1,2 + IND=-ID + IDIRC=IDIRS(ID) + IF(IAS(ID) .EQ. 0 .OR. IDFEX(IDIRC) .EQ. 0) THEN + DO ISUR=1,NSUR + IF(INDXSR(IDGPP,-ISUR) .EQ. IND) THEN + IDSUR(ISUR)=0 + ENDIF + ENDDO + ENDIF + ENDDO +*---- +* Renumber surfaces +*---- + INREN(:NSURN)=0 + INV=0 + DO ISUR=1,NSUR + IND=IDSUR(ISUR) + IF(IND .GT. 0) THEN + INV=INV+1 + INREN(IND)=INV + ENDIF + ENDDO + LSTSUR=INV+NASUR + DO ISUR=1,NSUR + IDS=IDSUR(ISUR) + IF(IDS .NE. 0) THEN + INS=INREN(ABS(IDS)) + IF(INS .NE. 0) INS=INS+NASUR + IF(IDS .LT. 0) THEN + IDSUR(ISUR)=-INS + ELSE + IDSUR(ISUR)=INS + ENDIF + ENDIF + ENDDO + NASUR=LSTSUR + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'SID' + CALL LCMPUT(IPTRK,NAMREC,NSUR,1,IDSUR) +*---- +* Processing finished: +* print routine closing output header if required +* and return +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6013) + WRITE(IOUT,6014) (IDSUR(IDS),IDS=1,NSUR) + WRITE(IOUT,6001) NAMSBR + ENDIF + DEALLOCATE(INREN) + RETURN +*---- +* FORMATS +*---- +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6012 FORMAT(' Original surfaces ID') + 6013 FORMAT(' Final surfaces ID') + 6014 FORMAT(5I15) + END diff --git a/Dragon/src/NXTRTL.f b/Dragon/src/NXTRTL.f new file mode 100644 index 0000000..d76c9a9 --- /dev/null +++ b/Dragon/src/NXTRTL.f @@ -0,0 +1,176 @@ +*DECK NXTRTL + SUBROUTINE NXTRTL(IPRINT,NDIM ,ITRN ,TRKORI,ANGLES, + > TRKORR,ANGROT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Rotate tracking line according to reference turn. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPRINT print level. +* NDIM dimensions of problem. +* ITRN geometry original turn number. +* TRKORI original track origin. +* ANGLES original track direction. +* +*Parameters: output +* TRKORR rotated geometry track origin. +* ANGROT rotated geometry track direction. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,NDIM,ITRN + DOUBLE PRECISION TRKORI(NDIM),ANGLES(NDIM), + > TRKORR(NDIM),ANGROT(NDIM) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTRTL') + DOUBLE PRECISION DZERO,DONE,DTWO + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Local variables +*---- + INTEGER IKT,IDIR +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GT. 1000) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6011) 'Initial starting point ', + > (TRKORI(IDIR),IDIR=1,NDIM) + WRITE(IOUT,6011) 'Initial direction ', + > (ANGLES(IDIR),IDIR=1,NDIM) + ENDIF +*---- +* Z axis reflection for 3-D problems +*---- + IKT=ITRN + IF(NDIM .EQ. 3) THEN + IF(ITRN .GT. 12 ) THEN + IKT=IKT-12 + TRKORR(NDIM)=-TRKORI(NDIM) + ANGROT(NDIM)=-ANGLES(NDIM) + ELSE + TRKORR(NDIM)=TRKORI(NDIM) + ANGROT(NDIM)=ANGLES(NDIM) + ENDIF + ENDIF + IF(IKT .EQ. 1) THEN +*---- +* no turn in $X-Y$ plane +*---- + DO IDIR=1,2 + TRKORR(IDIR)=TRKORI(IDIR) + ANGROT(IDIR)=ANGLES(IDIR) + ENDDO + ELSE IF(IKT .EQ. 2) THEN +*---- +* ROTATION OF -PI/2 OF GEOMETRY IMPLIES A ROTATION +* OF PI/2 OF LINE. +*---- + TRKORR(1)=-TRKORI(2) + TRKORR(2)= TRKORI(1) + ANGROT(1)=-ANGLES(2) + ANGROT(2)= ANGLES(1) + ELSE IF(IKT .EQ. 3) THEN +*---- +* ROTATION OF PI OF GEOMETRY IMPLIES A ROTATION +* OF -PI OF LINE. +*---- + TRKORR(1)=-TRKORI(1) + TRKORR(2)=-TRKORI(2) + ANGROT(1)=-ANGLES(1) + ANGROT(2)=-ANGLES(2) + ELSE IF(IKT .EQ. 4) THEN +*---- +* ROTATION OF -3*PI/2 OF GEOMETRY IMPLIES A ROTATION +* OF 3PI/2 OF LINE. +*---- + TRKORR(1)= TRKORI(2) + TRKORR(2)=-TRKORI(1) + ANGROT(1)= ANGLES(2) + ANGROT(2)=-ANGLES(1) + ELSE IF(IKT .EQ. 5) THEN +*---- +* REFLECTION WITH RESPECT TO AXIS // TO Y +*---- + TRKORR(1)=-TRKORI(1) + TRKORR(2)= TRKORI(2) + ANGROT(1)=-ANGLES(1) + ANGROT(2)= ANGLES(2) + ELSE IF(IKT .EQ. 6) THEN +*---- +* ROTATION OF PI/2 FOLLOWED BY +* REFLECTION WITH RESPECT TO AXIS // TO Y +* IMPLIES REFLECTION WITH RESPECT TO AXIS // TO Y +* FOLLOWED BY A ROTATION OF -PI/2 OF LINE. +*---- + TRKORR(1)= TRKORI(2) + TRKORR(2)= TRKORI(1) + ANGROT(1)= ANGLES(2) + ANGROT(2)= ANGLES(1) + ELSE IF(IKT .EQ. 7) THEN +*---- +* REFLECTION WITH RESPECT TO AXIS // TO X +*---- + TRKORR(1)= TRKORI(1) + TRKORR(2)=-TRKORI(2) + ANGROT(1)= ANGLES(1) + ANGROT(2)=-ANGLES(2) + ELSE IF(IKT .EQ. 8) THEN +*---- +* ROTATION OF PI/2 FOLLOWED BY +* REFLECTION WITH RESPECT TO AXIS // TO X +* IMPLIES REFLECTION WITH RESPECT TO AXIS // TO X +* FOLLOWED BY A ROTATION OF -PI/2 OF LINE. +*---- + TRKORR(1)=-TRKORI(2) + TRKORR(2)=-TRKORI(1) + ANGROT(1)=-ANGLES(2) + ANGROT(2)=-ANGLES(1) + ENDIF +*---- +* Processing finished: +* print routine closing output header if required +* and return +*---- + IF(IPRINT .GT. 1000) THEN + WRITE(IOUT,6011) 'Final starting point ', + > (TRKORR(IDIR),IDIR=1,NDIM) + WRITE(IOUT,6011) 'Final direction ', + > (ANGROT(IDIR),IDIR=1,NDIM) + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6011 FORMAT(2X,A24,1P,3E20.12) + END diff --git a/Dragon/src/NXTRTS.f b/Dragon/src/NXTRTS.f new file mode 100644 index 0000000..dfe4973 --- /dev/null +++ b/Dragon/src/NXTRTS.f @@ -0,0 +1,314 @@ +*DECK NXTRTS + SUBROUTINE NXTRTS(IPRINT,ITYPG ,MAXMSH,NREG ,ITRN ,ITST , + > ITSYM ,NM ,MIX ,ISPLT ,DAMESH, + > NMS ,MIXR ,ISPLTR,DAMESR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Rotate heagon with triangles according to reference turn and test, +* if required, in such a way that it satisfies intrinsic symmetries. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPRINT intermediate printing level for output. +* ITYPG geometry type. +* MAXMSH maximum number of elements in MESH array. +* NREG number of elements in MIX array. +* ITRN geometry original turn number. +* ITST flag for testing symmetry. +* ITSYM flag for symmetries to test. +* +*Parameters: input/output +* NM mesh size in all directions ($X$, $Y$, $Z$ and $R$). +* MIX final mixture description for geometry (including HMIX). +* ISPLT final split desctiption for geometry. +* DAMESH final mesh description for geometry. +* NMS mesh size after splitting. +* +*Parameters: temporary storage +* MIXR mixture description for rotated geometry (including HMIX). +* ISPLTR split desctiption for rotated geometry. +* DAMESR mesh description for rotated geometry. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,ITYPG,MAXMSH,NREG,ITRN,ITST, + > NM(4),ITSYM(4) + INTEGER ISPLT(0:MAXMSH-1,4),MIX(0:NREG-1,2) + DOUBLE PRECISION DAMESH(-1:MAXMSH,4) + INTEGER NMS(4),ISPLTR(0:MAXMSH-1,4,2), + > MIXR(0:NREG-1,2,2) + DOUBLE PRECISION DAMESR(-1:MAXMSH,4,2) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTRTS') + DOUBLE PRECISION DCUTOF,DZERO,DONE,DTWO + PARAMETER (DCUTOF=1.0D-6,DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Functions +*---- + INTEGER NXTHRS +*---- +* Local variables +*---- + INTEGER NX,NZ,NRP,NPG,IPG,IG,ICT,ITG,IKT,IX,IZ,IREG, + > ITMI,IDMI,NNZ,NMT,NMTS + INTEGER ITM(3,2) + DOUBLE PRECISION DDD +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF +*---- +* Turn reference geometry (IPG=1) +* and symmetric geometries (IPG=2,3,4,5) +*---- + NX=NM(1) + NZ=MAX(NM(3),1) + NRP=6*NX*NX + NPG=1 + ITM(1,1)=1 + ITM(1,2)=1 + ITM(2,1)=2 + ITM(2,2)=2 + ITM(3,1)=3 + ITM(3,2)=3 + ICT=0 + NMT=0 + IF(ITST .EQ. 1) NPG=4 + DO IPG=1,NPG + IF(IPG .EQ. 1) THEN + IG=1 + ICT=ITRN + DO IX=0,2*NX + DAMESR(IX,1,IG)=DAMESH(IX,1) + ENDDO + ISPLTR(1,1,IG)=ISPLT(1,1) + DAMESR(-1,1,IG)=DAMESH(-1,1) + ELSE + IG=2 + ITG=IPG-1 + IF(ABS(ITSYM(ITG)) .GE. 1) THEN +*---- +* Symmetry is valid +* Determine final turn after applying symmetry on +* current turn +*---- + IF(ITG .EQ. 1) THEN +*---- +* Hexagonal symetry +*---- + ICT=NXTHRS(ITRN,1) + ELSE IF(ITG .EQ. 3) THEN +*---- +* Symmetry in Z +*---- + ICT=NXTHRS(ITRN,-1) + ENDIF + ELSE +*---- +* No need to test the geometry for this +* intrinsic symmetry. +*---- + GO TO 1005 + ENDIF + ENDIF + IF(ICT .GT. 12 ) THEN + IKT=12-ICT + ELSE + IKT=ICT + ENDIF + IF(IKT .LT. 0) THEN + DAMESR(-1,3,IG)=-DAMESH(-1,3) + ELSE + DAMESR(-1,3,IG)=DAMESH(-1,3) + ENDIF + DO IX=0,2*NX + DAMESR(IX,1,IG)=DAMESH(IX,1) + ENDDO + ISPLTR(1,1,IG)=ISPLT(1,1) + DAMESR(-1,1,IG)=DAMESH(-1,1) + IF (ABS(IKT) .EQ. 1) THEN + IF(IKT .LT. 0) THEN + DO IZ=0,NZ-1 + DAMESR(IZ,3,IG)=DAMESH(NZ-IZ,3)-DAMESH(NZ-IZ-1,3) + ISPLTR(IZ,3,IG)=ISPLT(NZ-IZ-1,3) + ITMI=IZ*NRP + IDMI=(NZ-IZ-1)*NRP + DO IX=0,NX-1 + MIXR(ITMI,IG,1)=MIX(IDMI,1) + MIXR(ITMI,IG,2)=MIX(IDMI,2) + ITMI=ITMI+1 + IDMI=IDMI+1 + ENDDO + ENDDO + ELSE + DO IZ=0,NZ-1 + DAMESR(IZ,3,IG)=DAMESH(IZ+1,3)-DAMESH(IZ,3) + ISPLTR(IZ,3,IG)=ISPLT(IZ,3) + ITMI=IZ*NRP + IDMI=ITMI + DO IX=0,NRP + MIXR(ITMI,IG,1)=MIX(IDMI,1) + MIXR(ITMI,IG,2)=MIX(IDMI,2) + ITMI=ITMI+1 + IDMI=IDMI+1 + ENDDO + ENDDO + ENDIF + ELSE + CALL XABORT(NAMSBR// + > ': Symmetry not yet programmed') + ENDIF + IF(IPRINT .GE. 100) THEN +*---- +* Print turned mesh if required +*---- + WRITE(IOUT,6010) NX,NZ,NREG + WRITE(IOUT,6011) 'MESHH =' + WRITE(IOUT,6012) (DAMESR(IX,1,IG),IX=-1,2*NX) + WRITE(IOUT,6011) 'SPLTH =' + WRITE(IOUT,6013) ISPLTR(1,1,IG) + IF(ITYPG .EQ. 13) THEN + WRITE(IOUT,6011) 'MESHZ =' + WRITE(IOUT,6012) (DAMESR(IZ,3,IG),IZ=-1,NZ) + WRITE(IOUT,6011) 'SPLTZ =' + WRITE(IOUT,6013) (ISPLTR(IZ,3,IG),IZ=0,NZ) + ENDIF + WRITE(IOUT,6011) 'MIX =' + WRITE(IOUT,6013) (MIXR(IREG,IG,1),IREG=0,NREG-1) + WRITE(IOUT,6011) 'HMIX =' + WRITE(IOUT,6013) (MIXR(IREG,IG,2),IREG=0,NREG-1) + ENDIF + IF(IPG .GT. 1) THEN +*---- +* COMPARE GEOMETRY +* 1- MESH AND SPLIT IN Z +* 2- MIXTURES +* 3- OFFCENTER +*---- + NNZ=NM(ITM(3,1)) + IF(NNZ .NE. NM(ITM(3,2))) CALL XABORT(NAMSBR// + > ': Symmetry invalid with this mesh') + DO IZ=0,NNZ-1 + DDD=ABS(DAMESR(IZ,3,1)-DAMESR(IZ,3,2)) + IF(DDD .GT. DCUTOF) CALL XABORT(NAMSBR// + > ': Symmetry invalid with this mesh') + IF(ISPLTR(IZ,3,1) .NE. ISPLTR(IZ,3,2) ) + > CALL XABORT(NAMSBR// + > ': Symmetry invalid with this split') + ENDDO + DO IREG=0,NREG-1 + IF(MIXR(IREG,1,1) .NE. MIXR(IREG,2,1)) CALL XABORT(NAMSBR// + > ': Symmetry invalid with this mixtures') + IF(MIXR(IREG,1,2) .NE. MIXR(IREG,2,2)) CALL XABORT(NAMSBR// + > ': Symmetry invalid with this merging mixtures') + ENDDO + IF(DAMESR(-1,3,1) .NE. DAMESR(-1,3,2)) CALL XABORT(NAMSBR// + > ': Symmetry invalid with this off center') + ELSE +*---- +* Reset reference geometry for turn +*---- + DO IX=0,2*NX + DAMESH(IX,1)=DAMESR(IX,1,IG) + ENDDO + ISPLT(1,1)=ISPLTR(1,1,IG) + DAMESH(-1,1)=DAMESR(-1,1,IG) + NNZ=NM(ITM(3,1)) + NMT=NNZ + NMTS=0 + DO IZ=0,NNZ-1 + NMTS=NMTS+ABS(ISPLTR(IZ,3,1)) + ENDDO + IF(NMTS .NE. NMS(ITM(3,1))) CALL XABORT(NAMSBR// + > ': Global symmetry invalid with this split') + ENDIF + 1005 CONTINUE + ENDDO +*---- +* Reset final mesh (center+original turn) +*---- + NZ=NMT + DAMESH(-1:NM(3),3)=DZERO + NM(3)=NZ + DDD=DZERO + DO IZ=0,NZ-1 + DDD=DDD+DAMESR(IZ,3,1) + ENDDO + DDD=DDD/DTWO + DAMESH(-1,3)=DAMESR(-1,3,1) + DAMESH(0,3)=-DDD + DO IZ=1,NZ + DAMESH(IZ,3)=DAMESH(IZ-1,3)+DAMESR(IZ-1,3,1) + ENDDO + DO IZ=0,NZ + ISPLT(IZ,3)=ISPLTR(IZ,3,1) + ENDDO + NMS(3)=0 + DO IZ=0,NZ-1 + NMS(3)=NMS(3)+ABS(ISPLT(IZ,3)) + ENDDO +*---- +* Processing finished: +* print routine closing output header if required +* and return +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6010) NX,NZ,NREG + WRITE(IOUT,6011) 'MESHH =' + WRITE(IOUT,6012) (DAMESH(IX,1),IX=-1,2*NX) + WRITE(IOUT,6011) 'SPLTH =' + WRITE(IOUT,6013) ISPLT(1,1) + IF(ITYPG .EQ. 13) THEN + WRITE(IOUT,6011) 'MESHZ =' + WRITE(IOUT,6012) (DAMESH(IZ,3),IZ=-1,NZ) + WRITE(IOUT,6011) 'SPLTZ =' + WRITE(IOUT,6013) (ISPLT(IZ,3),IZ=0,NZ) + ENDIF + WRITE(IOUT,6011) 'MIX =' + WRITE(IOUT,6013) (MIX(IREG,1),IREG=0,NREG-1) + WRITE(IOUT,6011) 'HMIX =' + WRITE(IOUT,6013) (MIX(IREG,2),IREG=0,NREG-1) + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* FORMATS +*---- +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(1X,' DIMENSIONS =',5I10/1X,' ORIGINAL MESH ') + 6011 FORMAT(1X,A7) + 6012 FORMAT(5F15.9) + 6013 FORMAT(5I15) + END diff --git a/Dragon/src/NXTSGI.f b/Dragon/src/NXTSGI.f new file mode 100644 index 0000000..8aff7e8 --- /dev/null +++ b/Dragon/src/NXTSGI.f @@ -0,0 +1,885 @@ +*DECK NXTSGI + SUBROUTINE NXTSGI(IPTRK ,IPRINT,MAXMSH,ITYPG ,IGEO ,ILEV , + > MAXMSS,NMIX ,NM ,MIX ,DAMESH,ISPLT , + > NMIXS ,NMS ,DAMESS, + > ITSYM ,NREGS ,NSURS ,NREGN ,NSURN ,NEREN , + > IDREG ,IDSUR ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Discretize geometry according to splitting options. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure. +* IPRINT intermediate printing level for output. +* MAXMSH maximum number of elements in MESH array. +* ITYPG type of geometry. +* IGEO geometry number. +* ILEV geometry level. +* MAXMSS maximum number of elements in MESH array after split. +* NMIX number of elements in MIX array. +* NM mesh size in all directions ($X$, $Y$, $Z$ and $R$). +* MIX final mixture description for geometry (including MMIX). +* DAMESH final mesh description for geometry. +* NMIXS number of regional mixtures. +* ISPLT final split desctiption for geometry. +* NMS mesh size after splitting. +* ITSYM flag for symmetries to test. +* NREGS maximum number of regions in splitted geometry. +* NSURS maximum number of surfaces in splitted geometry. +* NREGN number of regions in splitted geometry after symmetry. +* NSURN number of surfaces in splitted geometry after symmetry. +* NEREN maximum number of elements in IREN. +* +*Parameters: input/output +* DAMESS mesh description for rotated geometry. +* IDREG region identifier after symmetry. +* IDSUR surface identifier after symmetry. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPTRK + INTEGER IPRINT,MAXMSH,ITYPG,IGEO,ILEV,MAXMSS,NMIX,NM(4) + INTEGER MIX(NMIX,2) + DOUBLE PRECISION DAMESH(-1:MAXMSH,4) + INTEGER ISPLT(MAXMSH,4) + INTEGER NMIXS,NMS(4) + DOUBLE PRECISION DAMESS(-1:MAXMSS,4,2) + INTEGER ITSYM(4),NREGS,NSURS,NREGN,NSURN,NEREN + INTEGER IDREG(NREGS),IDSUR(NSURS) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTSGI') + DOUBLE PRECISION DZERO,DONE,DDC,DCAOF + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DDC=1.0D-3, + > DCAOF=DONE+DDC) +*---- +* Local variables +*---- + INTEGER IDIR,NMTMP,IGEN,IGENS,NBS,IS, + > NX,NY,NZ,NR,IX,IY,IZ,IR, + > NXS,NYS,NZS,NRS,IXS,IYS,IZS,IRS, + > NXX,NYY,NZZ,NRR,IXX,IYY,IZZ,IRR, + > NRX,NRY,NRZ,NRXS,NRYS,NRZS,NZSR,NYSR,NXSR, + > NSXS,NSYS,NSZS,IMIX,IMIXS,ISBOT,ISTOP + INTEGER IOFZ,IOFYZ,IOFXYZ,IOSZ,IOSYZ,IOSXYZ, + > IODZ,IODYZ,IODXYZ,IORZ,IORYZ,IORXYZ + INTEGER IRO,IRN,IRT,IDS,IDV,NDIM,IPLOC + DOUBLE PRECISION DDD,DDI,DDO + CHARACTER NAMREC*12 +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IREN + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: MIXS +*---- +* Data +*---- + CHARACTER CDIR(1:4)*1,CLEV(2)*1 + SAVE CDIR,CLEV + DATA CDIR /'X','Y','Z','R'/ + DATA CLEV /'C','P'/ +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + ALLOCATE(IREN(NEREN),MIXS(NMIXS,2)) + MIXS(:NMIXS,:2)=0 + IPLOC=IPRINT + IF(IPLOC .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6010) (NM(IDIR),IDIR=1,4) + DO IDIR=1,4 + NMTMP=NM(IDIR) + IF(NMTMP .GT. 0) THEN + WRITE(IOUT,6011) 'MESH'//CDIR(IDIR)//' =' + WRITE(IOUT,6012) (DAMESH(IX,IDIR),IX=-1,NMTMP) + WRITE(IOUT,6011) 'SPLT'//CDIR(IDIR)//' =' + WRITE(IOUT,6013) (ISPLT(IX,IDIR),IX=1,NMTMP) + ENDIF + ENDDO + ENDIF + NR=0 + NRS=0 +*---- +* Cartesian mesh +*---- + DO IDIR=1,3 + DAMESS(-1,IDIR,1)=DAMESH(-1,IDIR) + DAMESS(0,IDIR,1)=DAMESH(0,IDIR) + IGENS=0 + DO IGEN=1,NM(IDIR) + NBS=ABS(ISPLT(IGEN,IDIR)) + DDD=(DAMESH(IGEN,IDIR)-DAMESH(IGEN-1,IDIR))/DBLE(NBS) + DO IS=1,NBS + IGENS=IGENS+1 + DAMESS(IGENS,IDIR,1)=DAMESS(IGENS-1,IDIR,1)+DDD + ENDDO + ENDDO + ENDDO +*---- +* Radial mesh +*---- + IDIR=4 + DAMESS(-1,IDIR,1)=DAMESH(-1,IDIR) + DAMESS(0,IDIR,1)=DAMESH(0,IDIR) + IGENS=0 + DO IGEN=1,NM(IDIR) + NBS=ISPLT(IGEN,IDIR) + IF(NBS .LT. 0) THEN + NBS=-NBS + DDI=DAMESH(IGEN-1,IDIR)*DAMESH(IGEN-1,IDIR) + DDO=DAMESH(IGEN,IDIR)*DAMESH(IGEN,IDIR) + DDD=(DDO-DDI)/DBLE(NBS) + DO IS=1,NBS + IGENS=IGENS+1 + DDO=DDI+DDD + DAMESS(IGENS,IDIR,1)=SQRT(DDO) + DDI=DDO + ENDDO + ELSE + DDD=(DAMESH(IGEN,IDIR)-DAMESH(IGEN-1,IDIR))/DBLE(NBS) + DO IS=1,NBS + IGENS=IGENS+1 + DAMESS(IGENS,IDIR,1)=DAMESS(IGENS-1,IDIR,1)+DDD + ENDDO + ENDIF + ENDDO + IF(IPLOC .GE. 100) THEN + WRITE(IOUT,6020) (NMS(IDIR),IDIR=1,4) + DO IDIR=1,4 + NMTMP=NMS(IDIR) + IF(NMTMP .GT. 0) THEN + WRITE(IOUT,6011) 'MESH'//CDIR(IDIR)//' =' + WRITE(IOUT,6012) (DAMESS(IX,IDIR,1),IX=-1,NMTMP) + ENDIF + ENDDO + ENDIF + NX=MAX(1,NM(1)) + NXS=MAX(1,NMS(1)) + NY=MAX(1,NM(2)) + NYS=MAX(1,NMS(2)) + NZ=MAX(1,NM(3)) + NZS=MAX(1,NMS(3)) + NRX=1 + NRXS=1 + NRY=1 + NRYS=1 + NRZ=1 + NRZS=1 + NSXS=NXS + NSYS=NYS + NSZS=NZS + NDIM=3 + IF(ITYPG .EQ. 3 .OR. ITYPG .EQ. 5 .OR. ITYPG .EQ. 20) + > NDIM=2 + IF(ITYPG .EQ. 5 .OR. ITYPG .EQ. 7) THEN + NR=1 + NRS=1 + ELSE IF(ITYPG .EQ. 3 .OR. ITYPG .EQ. 6) THEN + NR=NM(4) + NRS=NMS(4) + NRZ=NR + NRZS=NRS + NSZS=0 + ELSE IF(ITYPG .EQ. 10 ) THEN + NR=NM(4) + NRS=NMS(4) + NRX=NR + NRXS=NRS + NSXS=0 + ELSE IF(ITYPG .EQ. 11 ) THEN + NR=NM(4) + NRS=NMS(4) + NRY=NR + NRYS=NRS + NSYS=0 + ELSE IF(ITYPG .EQ. 20 .OR. ITYPG .EQ. 23 ) THEN + NR=NM(4)+1 + NRS=NMS(4)+1 + NRZ=NR + NRZS=NRS + IF(DAMESH(-1,4) .NE. DZERO) NRXS=NRS + ELSE IF(ITYPG .EQ. 21 ) THEN + NR=NM(4)+1 + NRS=NMS(4)+1 + NRX=NR + NRXS=NRS + ELSE IF(ITYPG .EQ. 22) THEN + NR=NM(4)+1 + NRS=NMS(4)+1 + NRY=NR + NRYS=NRS + ENDIF + IDREG(:NREGS)=0 + IDSUR(:NSURS)=0 +*---- +* Regions +* Mixture and global numbering +*---- + IZS=0 + DO IZ=1,NZ + NZZ=MAX(1,ISPLT(IZ,3)) + IOFZ=(IZ-1)*NY + DO IZZ=1,NZZ + IZS=IZS+1 + IOSZ=(IZS-1)*NYS + IYS=0 + DO IY=1,NY + NYY=MAX(1,ISPLT(IY,2)) + IOFYZ=(IOFZ+(IY-1))*NX + DO IYY=1,NYY + IYS=IYS+1 + IOSYZ=(IOSZ+(IYS-1))*NXS + IXS=0 + DO IX=1,NX + NXX=MAX(1,ISPLT(IX,1)) + IOFXYZ=(IOFYZ+(IX-1))*NR + DO IXX=1,NXX + IXS=IXS+1 + IOSXYZ=(IOSYZ+(IXS-1))*NRS + IRS=0 + DO IR=1,NM(4) + NRR=MAX(1,ABS(ISPLT(IR,4))) + IMIX=IOFXYZ+IR + DO IRR=1,NRR + IRS=IRS+1 + IMIXS=IOSXYZ+IRS + MIXS(IMIXS,1)=MIX(IMIX,1) + MIXS(IMIXS,2)=MIX(IMIX,2) + IDREG(IMIXS)=IMIXS + ENDDO + ENDDO + DO IR=NM(4)+1,NR + NRR=1 + IMIX=IOFXYZ+IR + DO IRR=1,NRR + IRS=IRS+1 + IMIXS=IOSXYZ+IRS + MIXS(IMIXS,1)=MIX(IMIX,1) + MIXS(IMIXS,2)=MIX(IMIX,2) + IDREG(IMIXS)=IMIXS + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO +*---- +* Surfaces (X- and X+) +*---- + ISBOT=0 + ISTOP=ISBOT+NSZS*NSYS*NRXS + DO IZS=1,NSZS + DO IYS=1,NSYS + DO IRS=1,NRXS + ISBOT=ISBOT+1 + IDSUR(ISBOT)=ISBOT + ISTOP=ISTOP+1 + IDSUR(ISTOP)=ISTOP + ENDDO + ENDDO + ENDDO +*---- +* Surfaces (Y- and Y+) +*---- + ISBOT=ISTOP + ISTOP=ISBOT+NSZS*NSXS*NRYS + DO IXS=1,NSXS + DO IZS=1,NSZS + DO IRS=1,NRYS + ISBOT=ISBOT+1 + IDSUR(ISBOT)=ISBOT + ISTOP=ISTOP+1 + IDSUR(ISTOP)=ISTOP + ENDDO + ENDDO + ENDDO + IF(NDIM .EQ. 3) THEN +*---- +* Surfaces (Z- and Z+) +*---- + ISBOT=ISTOP + ISTOP=ISBOT+NSYS*NSXS*NRZS + DO IYS=1,NSYS + DO IXS=1,NSXS + DO IRS=1,NRZS + ISBOT=ISBOT+1 + IDSUR(ISBOT)=ISBOT + ISTOP=ISTOP+1 + IDSUR(ISTOP)=ISTOP + ENDDO + ENDDO + ENDDO + ENDIF + IF(NSXS .EQ. 0 .OR. NSYS .EQ. 0 .OR. NSZS .EQ. 0) THEN + ISBOT=ISTOP+1 + IDSUR(ISBOT)=ISBOT + ENDIF +*---- +* For tubes reset outer Cartesian mesh limits in normal plane +*---- + IF(ITYPG .EQ. 3 .OR. ITYPG .EQ. 6) THEN + DAMESS(0,1,1)=-DAMESS(-1,1,1)-DAMESS(NMS(4),4,1)*DCAOF + DAMESS(NMS(1),1,1)=-DAMESS(-1,1,1)+DAMESS(NMS(4),4,1)*DCAOF + DAMESS(0,2,1)=-DAMESS(-1,2,1)-DAMESS(NMS(4),4,1)*DCAOF + DAMESS(NMS(2),2,1)=-DAMESS(-1,2,1)+DAMESS(NMS(4),4,1)*DCAOF + ELSE IF(ITYPG .EQ. 10) THEN + DAMESS(0,2,1)=-DAMESS(-1,2,1)-DAMESS(NMS(4),4,1)*DCAOF + DAMESS(NMS(2),2,1)=-DAMESS(-1,2,1)+DAMESS(NMS(4),4,1)*DCAOF + DAMESS(0,3,1)=-DAMESS(-1,3,1)-DAMESS(NMS(4),4,1)*DCAOF + DAMESS(NMS(3),3,1)=-DAMESS(-1,3,1)+DAMESS(NMS(4),4,1)*DCAOF + ELSE IF(ITYPG .EQ. 11) THEN + DAMESS(0,3,1)=-DAMESS(-1,3,1)-DAMESS(NMS(4),4,1)*DCAOF + DAMESS(NMS(3),3,1)=-DAMESS(-1,3,1)+DAMESS(NMS(4),4,1)*DCAOF + DAMESS(0,1,1)=-DAMESS(-1,1,1)-DAMESS(NMS(4),4,1)*DCAOF + DAMESS(NMS(1),1,1)=-DAMESS(-1,1,1)+DAMESS(NMS(4),4,1)*DCAOF + ENDIF +*---- +* Save MESH and mixture information on IPTRK +*---- + DO IDIR=1,4 + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'SM'//CDIR(IDIR) + IF(NMS(IDIR) .GT. 0) THEN + CALL LCMPUT(IPTRK,NAMREC,(NMS(IDIR)+2),4,DAMESS(-1,IDIR,1)) + ENDIF + ENDDO + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'MIX' + CALL LCMPUT(IPTRK,NAMREC,NMIXS,1,MIXS(1,1)) + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'HOM' + CALL LCMPUT(IPTRK,NAMREC,NMIXS,1,MIXS(1,2)) + IF(IPLOC .GE. 100) THEN + WRITE(IOUT,'(A38)') 'Regions and surfaces before symmetries' + WRITE(IOUT,6030) + WRITE(IOUT,6034) (IDREG(IDV),IDV=1,NREGS) + WRITE(IOUT,6032) + WRITE(IOUT,6034) (IDSUR(IDS),IDS=1,NSURS) + WRITE(IOUT,6035) ITSYM + ENDIF +*---- +* Diagonal X=Y symmetry +*---- + IF(ABS(ITSYM(4)) .EQ. 1) THEN +*---- +* 1- Eliminate reflected regions +*---- + DO IZS=1,NZS + IODZ=(IZS-1)*NYS + IORZ=(IZS-1)*NYS + DO IYS=1,NYS + DO IXS=IYS+1,NYS + IODXYZ=((IODZ+(IYS-1))*NXS+(IXS-1))*NRS + IORXYZ=((IODZ+(IXS-1))*NXS+(IYS-1))*NRS + DO IRS=1,NRS + IDREG(IORXYZ+IRS)=-ABS(IDREG(IODXYZ+IRS)) + ENDDO + ENDDO + ENDDO + ENDDO +*---- +* 2- Eliminate reflected Y- surfaces +*---- + ISBOT=0 + ISTOP=2*NSZS*NSYS*NRYS + DO IZS=1,NSZS + DO IYS=1,NSYS + IXS=IYS +*---- +* X face +*---- + IODYZ=((IZS-1)*NSYS+(IYS-1))*NRYS +*---- +* Y face +*---- + IORYZ=((IXS-1)*NSZS+(IZS-1))*NRYS + DO IRS=1,NRYS + IDSUR(ISTOP+IORYZ+IRS)=-ABS(IDSUR(ISBOT+IODYZ+IRS)) + ENDDO + ENDDO + ENDDO +*---- +* 3- Eliminate reflected Y+ surfaces +*---- + ISBOT=NSZS*NSYS*NRYS + ISTOP=ISBOT+2*NSZS*NSYS*NRYS + DO IZS=1,NSZS + DO IYS=1,NSYS + IXS=IYS +*---- +* X face +*---- + IODYZ=((IZS-1)*NSYS+(IYS-1))*NRYS +*---- +* Y face +*---- + IORYZ=((IXS-1)*NSZS+(IZS-1))*NRYS + DO IRS=1,NRYS + IDSUR(ISTOP+IORYZ+IRS)=-ABS(IDSUR(ISBOT+IODYZ+IRS)) + ENDDO + ENDDO + ENDDO + IF(NDIM .EQ. 3) THEN +*---- +* 4- Eliminate reflected Z+ surfaces +*---- + ISBOT=4*NSZS*NSYS*NRYS + ISTOP=ISBOT+NSYS*NSXS*NRZS + DO IYS=1,NSYS + DO IXS=IYS+1,NSXS + IODYZ=((IYS-1)*NSXS+(IXS-1))*NRS + IORYZ=((IXS-1)*NSXS+(IYS-1))*NRS + DO IRS=1,NRZS + IDSUR(ISBOT+IORYZ+IRS)=-ABS(IDSUR(ISBOT+IODYZ+IRS)) + IDSUR(ISTOP+IORYZ+IRS)=-ABS(IDSUR(ISTOP+IODYZ+IRS)) + ENDDO + ENDDO + ENDDO + ENDIF +*---- +* Diagonal X=-Y symmetry +*---- + ELSE IF(ABS(ITSYM(4)) .EQ. 4) THEN +*---- +* 1- Eliminate reflected regions +*---- + DO IZS=1,NZS + IODZ=(IZS-1)*NYS + IORZ=(IZS-1)*NYS + DO IYS=1,NYS + DO IXS=NYS-IYS,1,-1 + IODXYZ=((IODZ+(IYS-1))*NXS+(IXS-1))*NRS + IORXYZ=((IODZ+(NYS-IXS))*NXS+(NYS-IYS))*NRS + DO IRS=1,NRS + IDREG(IORXYZ+IRS)=-ABS(IDREG(IODXYZ+IRS)) + ENDDO + ENDDO + ENDDO + ENDDO +*---- +* 2- Eliminate reflected Y+ surfaces +*---- + ISBOT=0 + ISTOP=ISBOT+3*NSZS*NSYS*NRYS + DO IZS=1,NSZS + DO IYS=1,NSYS + IXS=IYS +*---- +* X face +*---- + IODYZ=((IZS-1)*NSYS+(IYS-1))*NRYS +*---- +* Y face +*---- + IORYZ=((NSYS-IXS)*NSZS+(IZS-1))*NRYS + DO IRS=1,NRYS + IDSUR(ISTOP+IORYZ+IRS)=-ABS(IDSUR(ISBOT+IODYZ+IRS)) + ENDDO + ENDDO + ENDDO +*---- +* 3- Eliminate reflected Y- surfaces +*---- + ISBOT=NSZS*NSYS*NRYS + ISTOP=ISBOT+NSZS*NSYS*NRYS + DO IZS=1,NSZS + DO IYS=1,NSYS + IXS=IYS +*---- +* X face +*---- + IODYZ=((IZS-1)*NSYS+(IYS-1))*NRYS +*---- +* Y face +*---- + IORYZ=((NYS-IXS)*NSZS+(IZS-1))*NRYS + DO IRS=1,NRYS + IDSUR(ISTOP+IORYZ+IRS)=-ABS(IDSUR(ISBOT+IODYZ+IRS)) + ENDDO + ENDDO + ENDDO + IF(NDIM .EQ. 3) THEN +*---- +* 4- Eliminate reflected Z+ surfaces +*---- + ISBOT=4*NSZS*NSYS*NRYS + ISTOP=ISBOT+NSYS*NSXS*NRZS + DO IYS=1,NSYS + DO IXS=NYS-IYS,1,-1 + IODYZ=((IYS-1)*NSXS+(IXS-1))*NRS + IORYZ=((NYS-IXS)*NSXS+(NYS-IYS))*NRS + DO IRS=1,NRZS + IDSUR(ISBOT+IORYZ+IRS)=-ABS(IDSUR(ISBOT+IODYZ+IRS)) + IDSUR(ISTOP+IORYZ+IRS)=-ABS(IDSUR(ISTOP+IODYZ+IRS)) + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF +*---- +* Axial Z+ or Z- symmetry +*---- + IF(ABS(ITSYM(3)) .EQ. 1) THEN +*---- +* 1- Eliminate reflected regions +*---- + NZSR=NZS/2 + DO IZS=1,NZSR + IODZ=(IZS-1)*NYS + IORZ=(NZS-IZS)*NYS + DO IYS=1,NYS + IODYZ=(IODZ+(IYS-1))*NXS + IORYZ=(IORZ+(IYS-1))*NXS + DO IXS=1,NXS + IODXYZ=(IODYZ+(IXS-1))*NRS + IORXYZ=(IORYZ+(IXS-1))*NRS + DO IRS=1,NRS + IDREG(IORXYZ+IRS)=-ABS(IDREG(IODXYZ+IRS)) + ENDDO + ENDDO + ENDDO + ENDDO +*---- +* 2- Eliminate reflected X- and X+ surfaces +*---- + ISBOT=0 + ISTOP=ISBOT+NSZS*NSYS*NRXS + DO IZS=1,NSZS/2 + IODZ=(IZS-1)*NSYS + IORZ=(NSZS-IZS)*NSYS + DO IYS=1,NSYS + IODYZ=(IODZ+(IYS-1))*NRXS + IORYZ=(IORZ+(IYS-1))*NRXS + DO IRS=1,NRXS + IDSUR(ISBOT+IORYZ+IRS)=-ABS(IDSUR(ISBOT+IODYZ+IRS)) + IDSUR(ISTOP+IORYZ+IRS)=-ABS(IDSUR(ISTOP+IODYZ+IRS)) + ENDDO + ENDDO + ENDDO +*---- +* 3- Eliminate reflected Y- and Y+ surfaces +*---- + ISBOT=ISTOP+NSZS*NSYS*NRXS + ISTOP=ISBOT+NSZS*NSXS*NRYS + DO IXS=1,NSXS + IODZ=(IXS-1)*NSZS + IORZ=(IXS-1)*NSZS + DO IZS=1,NSZS/2 + IODYZ=(IODZ+(IZS-1))*NRYS + IORYZ=(IORZ+(NSZS-IZS))*NRYS + DO IRS=1,NRYS + IDSUR(ISBOT+IORYZ+IRS)=-ABS(IDSUR(ISBOT+IODYZ+IRS)) + IDSUR(ISTOP+IORYZ+IRS)=-ABS(IDSUR(ISTOP+IODYZ+IRS)) + ENDDO + ENDDO + ENDDO +*---- +* 4- Eliminate reflected Z- surfaces +*---- + ISBOT=ISTOP+NSZS*NSXS*NRYS + ISTOP=ISBOT+NSYS*NSXS*NRZS + DO IYS=1,NSYS + IODZ=(IYS-1)*NSXS + DO IXS=1,NSXS + IODYZ=(IODZ+(IXS-1))*NRZS + DO IRS=1,NRZS + IDSUR(ISTOP+IODYZ+IRS)=-ABS(IDSUR(ISBOT+IODYZ+IRS)) + ENDDO + ENDDO + ENDDO + ENDIF +*---- +* Axial Y+ or Y- symmetry +*---- + IF(ABS(ITSYM(2)) .EQ. 1) THEN +*---- +* 1- Eliminate reflected regions +*---- + NYSR=NYS/2 + DO IZS=1,NZS + IODZ=(IZS-1)*NYS + IORZ=(IZS-1)*NYS + DO IYS=1,NYSR + IODYZ=(IODZ+(IYS-1))*NXS + IORYZ=(IORZ+(NYS-IYS))*NXS + DO IXS=1,NXS + IODXYZ=(IODYZ+(IXS-1))*NRS + IORXYZ=(IORYZ+(IXS-1))*NRS + DO IRS=1,NRS + IDREG(IORXYZ+IRS)=-ABS(IDREG(IODXYZ+IRS)) + ENDDO + ENDDO + ENDDO + ENDDO +*---- +* 2- Eliminate reflected X- and X+ surfaces +*---- + ISBOT=0 + ISTOP=ISBOT+NSZS*NSYS*NRXS + DO IZS=1,NSZS + IODZ=(IZS-1)*NSYS + IORZ=(IZS-1)*NSYS + DO IYS=1,NSYS/2 + IODYZ=(IODZ+(IYS-1))*NRXS + IORYZ=(IORZ+(NSYS-IYS))*NRXS + DO IRS=1,NRXS + IDSUR(ISBOT+IORYZ+IRS)=-ABS(IDSUR(ISBOT+IODYZ+IRS)) + IDSUR(ISTOP+IORYZ+IRS)=-ABS(IDSUR(ISTOP+IODYZ+IRS)) + ENDDO + ENDDO + ENDDO +*---- +* 3- Eliminate reflected Y+ surfaces +*---- + ISBOT=ISTOP+NSZS*NSYS*NRXS + ISTOP=ISBOT+NSZS*NSXS*NRYS + DO IXS=1,NSXS + IODZ=(IXS-1)*NSZS + DO IZS=1,NSZS + IODYZ=(IODZ+(IZS-1))*NRYS + DO IRS=1,NRYS + IDSUR(ISTOP+IODYZ+IRS)=-ABS(IDSUR(ISBOT+IODYZ+IRS)) + ENDDO + ENDDO + ENDDO + IF(NDIM .EQ. 3) THEN +*---- +* 4- Eliminate reflected Z- and Z+ surfaces +*---- + ISBOT=ISTOP+NSZS*NSXS*NRYS + ISTOP=ISBOT+NSYS*NSXS*NRZS + DO IYS=1,NSYS/2 + IODZ=(IYS-1)*NSXS + IORZ=(NSYS-IYS)*NSXS + DO IXS=1,NSXS + IODYZ=(IODZ+(IXS-1))*NRZS + IORYZ=(IORZ+(IXS-1))*NRZS + DO IRS=1,NRZS + IDSUR(ISBOT+IORYZ+IRS)=-ABS(IDSUR(ISBOT+IODYZ+IRS)) + IDSUR(ISTOP+IORYZ+IRS)=-ABS(IDSUR(ISTOP+IODYZ+IRS)) + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF +*---- +* Axial X+ or X- symmetry +*---- + IF(ABS(ITSYM(1)) .EQ. 1) THEN +*---- +* 1- Eliminate reflected regions +*---- + NXSR=NXS/2 + DO IZS=1,NZS + IODZ=(IZS-1)*NYS + IORZ=(IZS-1)*NYS + DO IYS=1,NYS + IODYZ=(IODZ+(IYS-1))*NXS + IORYZ=(IORZ+(IYS-1))*NXS + DO IXS=1,NXSR + IODXYZ=(IODYZ+(IXS-1))*NRS + IORXYZ=(IORYZ+(NXS-IXS))*NRS + DO IRS=1,NRS + IDREG(IORXYZ+IRS)=-ABS(IDREG(IODXYZ+IRS)) + ENDDO + ENDDO + ENDDO + ENDDO +*---- +* 2- Eliminate reflected X+ surfaces +*---- + ISBOT=0 + ISTOP=ISBOT+NSZS*NSYS*NRXS + DO IZS=1,NSZS + IODZ=(IZS-1)*NSYS + DO IYS=1,NSYS + IODYZ=(IODZ+(IYS-1))*NRXS + DO IRS=1,NRXS + IDSUR(ISTOP+IODYZ+IRS)=-ABS(IDSUR(ISBOT+IODYZ+IRS)) + ENDDO + ENDDO + ENDDO +*---- +* 3- Eliminate reflected Y- and Y+ surfaces +*---- + ISBOT=ISTOP+NSZS*NSYS*NRXS + ISTOP=ISBOT+NSZS*NSXS*NRYS + DO IXS=1,NSXS/2 + IODZ=(IXS-1)*NSZS + IORZ=(NSXS-IXS)*NSZS + DO IZS=1,NSZS + IODYZ=(IODZ+(IZS-1))*NRYS + IORYZ=(IORZ+(IZS-1))*NRYS + DO IRS=1,NRYS + IDSUR(ISBOT+IORYZ+IRS)=-ABS(IDSUR(ISBOT+IODYZ+IRS)) + IDSUR(ISTOP+IORYZ+IRS)=-ABS(IDSUR(ISTOP+IODYZ+IRS)) + ENDDO + ENDDO + ENDDO + IF(NDIM .EQ. 3) THEN +*---- +* 4- Eliminate reflected Z- and Z+ surfaces +*---- + ISBOT=ISTOP+NSZS*NSXS*NRYS + ISTOP=ISBOT+NSYS*NSXS*NRZS + DO IYS=1,NSYS + IODZ=(IYS-1)*NSXS + IORZ=(IYS-1)*NSXS + DO IXS=1,NSXS/2 + IODYZ=(IODZ+(IXS-1))*NRZS + IORYZ=(IORZ+(NSXS-IXS))*NRZS + DO IRS=1,NRZS + IDSUR(ISBOT+IORYZ+IRS)=-ABS(IDSUR(ISBOT+IODYZ+IRS)) + IDSUR(ISTOP+IORYZ+IRS)=-ABS(IDSUR(ISTOP+IODYZ+IRS)) + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF +*---- +* For annular geometry eliminate Cartesian boundary +*---- + IF(ITYPG .EQ. 6) THEN + NR=NM(4) + NRS=NMS(4) + NRZ=NR + NRZS=NRS + ELSE IF(ITYPG .EQ. 10 ) THEN + NR=NM(4) + NRS=NMS(4) + NRX=NR + NRXS=NRS + ELSE IF(ITYPG .EQ. 11 ) THEN + NR=NM(4) + NRS=NMS(4) + NRY=NR + NRYS=NRS + ENDIF +*---- +* Renumber regions +*---- + IRN=0 + DO IRO=1,NREGS + IDV=IDREG(IRO) + IF(IDV .GT. 0) THEN + IRN=IRN+1 + IREN(IRN)=IDV + DO IRT=1,IRN-1 + IF(IDV .LT. IREN(IRT)) THEN + DO IRR=IRN-1,IRT,-1 + IREN(IRR+1)=IREN(IRR) + ENDDO + IREN(IRT)=IDV + ENDIF + ENDDO + ENDIF + ENDDO + NREGN=IRN + DO IRN=1,NREGN + IDV=IREN(IRN) + DO IRT=1,NREGS + IF(IDREG(IRT) .EQ. IDV ) THEN + IDREG(IRT)=IRN + ELSE IF(IDREG(IRT) .EQ. -IDV ) THEN + IDREG(IRT)=-IRN + ENDIF + ENDDO + ENDDO +*---- +* Renumber surfaces +*---- + IRN=0 + DO IRO=1,NSURS + IDS=IDSUR(IRO) + IF(IDS .GT. 0) THEN + IRN=IRN+1 + IREN(IRN)=IDS + DO IRT=1,IRN-1 + IF(IDS .LT. IREN(IRT)) THEN + DO IRR=IRN-1,IRT,-1 + IREN(IRR+1)=IREN(IRR) + ENDDO + IREN(IRT)=IDS + ENDIF + ENDDO + ENDIF + ENDDO + NSURN=IRN + DO IRN=1,NSURN + IDS=IREN(IRN) + DO IRT=1,NSURS + IF(IDSUR(IRT) .EQ. IDS ) THEN + IDSUR(IRT)=IRN + ELSE IF(IDSUR(IRT) .EQ. -IDS ) THEN + IDSUR(IRT)=-IRN + ENDIF + ENDDO + ENDDO +*---- +* Processing finished: +* print routine closing output header if required +* and return +*---- + IF(IPLOC .GE. 100) THEN + WRITE(IOUT,6010) (NMS(IDIR),IDIR=1,4) + DO IDIR=1,4 + NMTMP=NMS(IDIR) + IF(NMTMP .GT. 0) THEN + WRITE(IOUT,6011) 'MESH'//CDIR(IDIR)//' =' + WRITE(IOUT,6012) (DAMESS(IX,IDIR,1),IX=-1,NMTMP) + ENDIF + ENDDO + WRITE(IOUT,'(A37)') 'Regions and surfaces after symmetries' + WRITE(IOUT,6030) + WRITE(IOUT,6034) (IDREG(IDV),IDV=1,NREGS) + WRITE(IOUT,6032) + WRITE(IOUT,6034) (IDSUR(IDS),IDS=1,NSURS) + WRITE(IOUT,6001) NAMSBR + ENDIF + DEALLOCATE(MIXS,IREN) + RETURN +*---- +* FORMATS +*---- +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(1X,' DIMENSIONS =',5I10/1X,' ORIGINAL MESH ') + 6011 FORMAT(1X,A7) + 6012 FORMAT(5F15.9) + 6013 FORMAT(5I15) + 6020 FORMAT(1X,' DIMENSIONS =',5I10/1X,' SPLITTED MESH ') + 6030 FORMAT(' Regions ID') + 6032 FORMAT(' Surfaces ID') + 6034 FORMAT(5I15) + 6035 FORMAT('Symmetries =',4I15) + END diff --git a/Dragon/src/NXTSGT.f b/Dragon/src/NXTSGT.f new file mode 100644 index 0000000..7fc0b45 --- /dev/null +++ b/Dragon/src/NXTSGT.f @@ -0,0 +1,636 @@ +*DECK NXTSGT + SUBROUTINE NXTSGT(IPTRK ,IPRINT,MAXMSH,ITYPG ,IGEO ,ILEV , + > MAXMSS,NMIX ,NM ,MIX ,DAMESH,ISPLT , + > NMIXS ,NMS ,DAMESS, + > ITSYM ,NREGS ,NSURS ,NREGN ,NSURN ,NEREN , + > IDREG ,IDSUR ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Discretize geometry according to splitting options for +* HEXT, HEXCELT, HEXTZ and HEXTCELZ geometry. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure. +* IPRINT intermediate printing level for output. +* MAXMSH maximum number of elements in MESH array. +* ITYPG type of geometry. +* IGEO geometry number. +* ILEV geometry level. +* MAXMSS maximum number of elements in MESH array after split. +* NMIX number of elements in MIX array. +* NM mesh size in all directions ($X$, $Y$, $Z$ and $R$). +* MIX final mixture description for geometry (including MMIX). +* DAMESH final mesh description for geometry. +* ISPLT final split desctiption for geometry. +* NMIXS number of regional mixtures. +* NMS mesh size after splitting. +* ITSYM flag for symmetries to test. +* NREGS maximum number of regions in splitted geometry. +* NSURS maximum number of surfaces in splitted geometry. +* NREGN number of regions in splitted geometry after symmetry. +* NSURN number of surfaces in splitted geometry after symmetry. +* NEREN maximum number of elements in IREN. +* +*Parameters: input/output +* DAMESS mesh description for rotated geometry. +* IDREG region identifier after symmetry. +* IDSUR surface identifier after symmetry. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPTRK + INTEGER IPRINT,MAXMSH,ITYPG,IGEO,ILEV,MAXMSS,NMIX,NM(4) + INTEGER MIX(NMIX,2) + DOUBLE PRECISION DAMESH(-1:MAXMSH,4) + INTEGER ISPLT(MAXMSH,4) + INTEGER NMIXS,NMS(4) + DOUBLE PRECISION DAMESS(-1:MAXMSS,4,2) + INTEGER ITSYM(4),NREGS,NSURS,NREGN,NSURN,NEREN + INTEGER IDREG(NREGS),IDSUR(NSURS) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTSGT') + DOUBLE PRECISION DZERO,DONE,DDC,DCAOF + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DDC=1.0D-3, + > DCAOF=DONE+DDC) +*---- +* Local variables +*---- + INTEGER NX ,NZ ,NRTP ,NRP ,NSTP ,NSP , + > NXS,NZS,NRTPS,NRPS,NSTPS,NSPS, + > NZMX1,NZSMX1,NBSX,NBSZ,NZSR,NSPLAN + INTEGER IPLOC,IX,IXS,IZ,IZS,III,JJJ, + > ISECT,IDMIX + INTEGER IOFZ,IOFZS,IOFS,IOFSS + INTEGER IODZ,IODHZ,IORHZ,IORZ,IRN,IRO,IRR,IRT, + > ISTOP,ISBOT,IDS,IDV + DOUBLE PRECISION DELTH,DELTH0,DDD + CHARACTER NAMREC*12 + INTEGER IDIRR,IR,NR,NRS + INTEGER IDTRI,IGEN,IGENS,IOFT,IOFTS,IS,ISPZ,ITID,ITIDS, + > NBS,NRR,NTL + DOUBLE PRECISION DDI,DDO +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IREN,MIXS +*---- +* Data +*---- + CHARACTER CLEV(2)*1 + SAVE CLEV + DATA CLEV /'C','P'/ +*---- +* Static variables used +* before split +* NX = mesh in x (from 0 to SIDE) +* NZ = mesh in z (from zmin to zmax) +* NR = radial mesh +* NRTP = number of region in a triangle for each z plane +* NRP = number of region in a z plane +* NSTP = number of surfaces in a triangle for each z plane +* NSP = number of surfaces in a z plane +* after split +* NXS = mesh in x (from 0 to SIDE) +* NZS = mesh in z (from zmin to zmax) +* NRS = radial mesh +* NRTPS = number of region in a triangle for each z plane +* NRPS = number of region in a z plane +* NSTPS = number of surfaces in a triangle for each z plane +* NSPS = number of surfaces in a z plane +*---- + ALLOCATE(IREN(2,NEREN),MIXS(NMIXS,2)) + MIXS(:NMIXS,:2)=0 + NR=NM(4)+1 + NRS=NMS(4)+1 + IDIRR=-99 + IF(ITYPG .EQ. 12 .OR. ITYPG .EQ. 13) THEN + IDIRR=0 + ELSE IF(ITYPG .EQ. 26 .OR. ITYPG .EQ. 27) THEN + IDIRR=4 + ENDIF + NX=NM(1) + NZ=NM(3) + NRTP=NX**2 + NRP=6*NRTP*NR + NSTP=2*NX-1 + NSP=6*NSTP + NXS=NMS(1) + NZS=NMS(3) + NRTPS=NXS**2 + NRPS=6*NRTPS*NRS + NSTPS=2*NXS-1 + NSPS=6*NSTPS +* write(6,*) 'NX,NZ,NRTP,NRP,NSTP,NSP,NXS,NZS,NRTPS,NRPS,NSTPS,NSPS' +* >,NX,NZ,NRTP,NRP,NSTP,NSP,NXS,NZS,NRTPS,NRPS,NSTPS,NSPS +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IPLOC=IPRINT + IF(IPLOC .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6002) ITYPG + WRITE(IOUT,6010) NX,NZ + WRITE(IOUT,6011) 'MESHH =' + WRITE(IOUT,6012) (DAMESH(IX,1),IX=-1,2*NX) + WRITE(IOUT,6011) 'SPLTH =' + WRITE(IOUT,6013) ISPLT(1,1) + IF(NZ .GT. 0) THEN + WRITE(IOUT,6011) 'MESHZ =' + WRITE(IOUT,6012) (DAMESH(IZ,3),IZ=-1,NZ) + WRITE(IOUT,6011) 'SPLTZ =' + WRITE(IOUT,6013) (ISPLT(IZ,3),IZ=1,NZ) + ENDIF + IF(IDIRR .EQ. 4) THEN + WRITE(IOUT,6011) 'MESHR =' + WRITE(IOUT,6012) (DAMESH(IR,4),IR=-1,NR) + WRITE(IOUT,6011) 'SPLTR =' + WRITE(IOUT,6013) (ISPLT(IR,4),IR=1,NR) + ENDIF + WRITE(IOUT,6033) + WRITE(IOUT,6034) (MIX(III,1),III=1,NMIX) + WRITE(IOUT,6036) + WRITE(IOUT,6034) (MIX(III,2),III=1,NMIX) + ENDIF +* write(6,*) 'NX,NZ,NXS,NZS',NX,NZ,NXS,NZS +* write(6,*) 'NREGS,NSURS',NREGS,NSURS +*---- +* Triangular mesh +*---- + NBSX=ABS(ISPLT(1,1)) +*---- +* Note : last crown may have a width different +* from the other crowns +* Splitting is with respect to width of internal crowns +* unless only one crown considered +*---- + IF(NX .EQ. 1) THEN + DELTH0=(DAMESH(1,1)-DAMESH(0,1))/DBLE(NBSX) + DELTH=DELTH0 + ELSE + DELTH0=DAMESH(1,1)-DAMESH(0,1) + DELTH=DAMESH(2,1)-DAMESH(1,1) + DDD=DELTH-DELTH0 + DELTH=DELTH/DBLE(NBSX) + IF(DDD .GT. DELTH) THEN + WRITE(IOUT,9000) DELTH0,DELTH,DDD + CALL XABORT(NAMSBR// + > ': Invalid SPLIT for HEXT and HEXTZ geometries') + ENDIF + DELTH0=DELTH-DDD + ENDIF + DAMESS(-1,1,1)=DAMESH(-1,1) + DAMESS(0,1,1)=DAMESH(0,1) + DAMESS(1,1,1)=DAMESS(0,1,1)+DELTH0 + III=1 + DO IXS=1,NBSX-1 + III=III+1 + DAMESS(III,1,1)=DAMESS(III-1,1,1)+DELTH + ENDDO + DO JJJ=2,2*NX-1 + DO IXS=1,NBSX + III=III+1 + DAMESS(III,1,1)=DAMESS(III-1,1,1)+DELTH + ENDDO + ENDDO + DO IXS=1,NBSX-1 + III=III+1 + DAMESS(III,1,1)=DAMESS(III-1,1,1)+DELTH + ENDDO + III=III+1 + DAMESS(III,1,1)=DAMESS(III-1,1,1)+DELTH0 +*---- +* Y mesh identical to X mesh except for off center +*---- + DO IXS=-1,2*NXS + DAMESS(IXS,2,1)=DAMESS(IXS,1,1) + ENDDO +*---- +* Z mesh +*---- + IF(NZ .EQ. 0) THEN + DAMESS(-1,3,1)=DZERO + DAMESS(0,3,1)=DZERO + ELSE + DAMESS(-1,3,1)=DAMESH(-1,3) + DAMESS(0,3,1)=DAMESH(0,3) + III=0 + DO IZ=1,NZ + NBSZ=ABS(ISPLT(IZ,3)) + DDD=(DAMESH(IZ,3)-DAMESH(IZ-1,3))/DBLE(NBSZ) + DO IZS=1,NBSZ + III=III+1 + DAMESS(III,3,1)=DAMESS(III-1,3,1)+DDD + ENDDO + ENDDO + ENDIF +*---- +* Radial mesh +*---- + IF(IDIRR .EQ. 4) THEN + DAMESS(-1,IDIRR,1)=DAMESH(-1,IDIRR) + DAMESS(0,IDIRR,1)=DAMESH(0,IDIRR) + IGENS=0 + DO IGEN=1,NM(IDIRR) + NBS=ISPLT(IGEN,IDIRR) + IF(NBS .LT. 0) THEN + NBS=-NBS + DDI=DAMESH(IGEN-1,IDIRR)*DAMESH(IGEN-1,IDIRR) + DDO=DAMESH(IGEN,IDIRR)*DAMESH(IGEN,IDIRR) + DDD=(DDO-DDI)/DBLE(NBS) + DO IS=1,NBS + IGENS=IGENS+1 + DDO=DDI+DDD + DAMESS(IGENS,IDIRR,1)=SQRT(DDO) + DDI=DDO + ENDDO + ELSE + DDD=(DAMESH(IGEN,IDIRR)-DAMESH(IGEN-1,IDIRR))/DBLE(NBS) + DO IS=1,NBS + IGENS=IGENS+1 + DAMESS(IGENS,IDIRR,1)=DAMESS(IGENS-1,IDIRR,1)+DDD + ENDDO + ENDIF + ENDDO + ENDIF + IF(IPLOC .GE. 100) THEN + WRITE(IOUT,6020) NXS,NZS + WRITE(IOUT,6011) 'MESHH =' + WRITE(IOUT,6012) (DAMESS(IX,1,1),IX=-1,2*NXS) + IF(NZS .GT. 0) THEN + WRITE(IOUT,6011) 'MESHZ =' + WRITE(IOUT,6012) (DAMESS(IZ,3,1),IZ=-1,NZS) + ENDIF + IF(IDIRR .EQ. 4) THEN + WRITE(IOUT,6011) 'MESHR =' + WRITE(IOUT,6012) (DAMESS(IR,4,1),IR=-1,NR) + ENDIF + ENDIF + IDREG(:NREGS)=0 + IDSUR(:NSURS)=0 +*---- +* Loop over planes (3D) +*---- + NZMX1=MAX(1,NZ) + NZSMX1=MAX(1,NZS) +*---- +* Regions +* Mixture and global numbering +*---- + IZS=0 + DO IZ=1,NZMX1 + IF(NZ .EQ. 0) THEN + NBSZ=1 + ELSE + NBSZ=MAX(1,ISPLT(IZ,3)) + ENDIF + DO ISPZ=1,NBSZ + IOFZ=(IZ-1)*NRP + IOFZS=IZS*NRPS + IZS=IZS+1 +*---- +* Loop over sectors +*---- + DO ISECT=1,6 + IOFS=(ISECT-1)*NRTP*NR + IOFSS=(ISECT-1)*NRTPS*NRS +*---- +* Loop over lines +*---- + IOFT=IOFZ+IOFS + IOFTS=IOFZS+IOFSS + ITID=0 + ITIDS=0 + DO IX=1,NX + NTL=2*IX-1 +*---- +* For remaining lines +* IREN(1,*) is original cell position on line +* IREN(2,*) is number of times this cell is used on +* each initial splitted mesh +* (NBSX for right triangle and 0 for left triangle) +*---- +* Loop over all right triangles in line +*---- + DO III=2,2*IX-2,2 + IREN(1,III)=IOFT + IREN(2,III)=NBSX + IOFT=IOFT+NR + ENDDO +*---- +* Loop over all left triangles in line +*---- + DO III=1,2*IX-1,2 + IREN(1,III)=IOFT + IREN(2,III)=0 + IOFT=IOFT+NR + ENDDO +* write(6,'(A6,2X,3I10)') +* > ('IREN =',III,IREN(1,III),IREN(2,III),III=1,2*IX-1) + DO IXS=1,NBSX +*---- +* Process all triangles on coarse line +* Extract only new (discretized) right triangles on sub-line +* In first step (IXS=1), only coarse right triangles considered +*---- + DO III=1,2*IX-1 + IDTRI=IREN(1,III) + DO JJJ=1,IREN(2,III) + DO IR=1,NM(4) + NRR=MAX(1,ABS(ISPLT(IR,4))) + IDMIX=IDTRI+IR + DO IRR=1,NRR + IOFTS=IOFTS+1 +* write(6,*) 'SPLITTING R',IZ,ISPZ,ISECT,IX,IXS,IR,IRR,IOFTS + MIXS(IOFTS,1)=MIX(IDMIX,1) + MIXS(IOFTS,2)=MIX(IDMIX,2) + IDREG(IOFTS)=IOFTS + ENDDO + ENDDO + IDMIX=IDTRI+NM(4)+1 + IOFTS=IOFTS+1 +* write(6,*) 'SPLITTING R',IZ,ISPZ,ISECT,IX,IXS,NM(4),NRR+1,IOFTS + MIXS(IOFTS,1)=MIX(IDMIX,1) + MIXS(IOFTS,2)=MIX(IDMIX,2) + IDREG(IOFTS)=IOFTS + ENDDO + ENDDO +*---- +* Prepare for right triangles on sub-line +* 1) Coarse right triangles +* 2) Coarse left triangles +*---- + DO III=2,2*IX-2,2 + IREN(2,III)=NBSX-1 + ENDDO + DO III=1,2*IX-1,2 + IREN(2,III)=IREN(2,III)+1 + ENDDO +* write(6,'(A6,2X,3I10)') +* > ('IREN =',III,IREN(1,III),IREN(2,III),III=1,2*IX-1) +*---- +* Process again all triangles on coarse line +* Extract only new (discretized) left triangles on sub-line +* In last step (IXS=NBXS), only coarse left triangles considered +*---- + DO III=1,2*IX-1 + IDTRI=IREN(1,III) + DO JJJ=1,IREN(2,III) + DO IR=1,NM(4) + NRR=MAX(1,ABS(ISPLT(IR,4))) + IDMIX=IDTRI+IR + DO IRR=1,NRR + IOFTS=IOFTS+1 +* write(6,*) 'SPLITTING L',IZ,ISPZ,ISECT,IX,IXS,IR,IRR,IOFTS + MIXS(IOFTS,1)=MIX(IDMIX,1) + MIXS(IOFTS,2)=MIX(IDMIX,2) + IDREG(IOFTS)=IOFTS + ENDDO + ENDDO + IDMIX=IDTRI+NM(4)+1 + IOFTS=IOFTS+1 +* write(6,*) 'SPLITTING L',IZ,ISPZ,ISECT,IX,IXS,NM(4),NRR+1,IOFTS + MIXS(IOFTS,1)=MIX(IDMIX,1) + MIXS(IOFTS,2)=MIX(IDMIX,2) + IDREG(IOFTS)=IOFTS + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO +*---- +* Save MESH and mixture information on IPTRK +*---- + IF(NXS .GT. 0) THEN + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'SMX' + CALL LCMPUT(IPTRK,NAMREC,(2*NXS+2),4,DAMESS(-1,1,1)) + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'SMY' + CALL LCMPUT(IPTRK,NAMREC,(2*NXS+2),4,DAMESS(-1,2,1)) + ENDIF + IF(NZS .GT. 0) THEN + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'SMZ' + CALL LCMPUT(IPTRK,NAMREC,(NZS+2),4,DAMESS(-1,3,1)) + ENDIF + IF(IDIRR .EQ. 4) THEN + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'SMR' + CALL LCMPUT(IPTRK,NAMREC,(NMS(4)+2),4,DAMESS(-1,4,1)) + ENDIF + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'MIX' + CALL LCMPUT(IPTRK,NAMREC,NMIXS,1,MIXS(1,1)) + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'HOM' + CALL LCMPUT(IPTRK,NAMREC,NMIXS,1,MIXS(1,2)) + IF(IPLOC .GE. 100) THEN + WRITE(IOUT,6033) + WRITE(IOUT,6034) (MIXS(III,1),III=1,NREGS) + WRITE(IOUT,6036) + WRITE(IOUT,6034) (MIXS(III,2),III=1,NREGS) + WRITE(IOUT,6030) 'before symmetries ' + WRITE(IOUT,6034) (IDREG(III),III=1,NREGS) + ENDIF +*---- +* Hexagnal surfaces +*---- + ISBOT=0 + DO IZS=1,NZSMX1 + DO ISECT=1,6 + DO III=1,NXS-1 + ISBOT=ISBOT+1 + IDSUR(ISBOT)=ISBOT + ENDDO + DO III=1,NXS + ISBOT=ISBOT+1 + IDSUR(ISBOT)=ISBOT + ENDDO + ENDDO + ENDDO + IF(NZ .GT. 0) THEN +*---- +* Z- and Z+ surfaces +*---- + ISTOP=ISBOT+NRPS + DO III=1,NRPS + ISBOT=ISBOT+1 + IDSUR(ISBOT)=ISBOT + ISTOP=ISTOP+1 + IDSUR(ISTOP)=ISTOP + ENDDO + ENDIF + IF(IPLOC .GE. 100) THEN + WRITE(IOUT,6032) 'before symmetries ' + WRITE(IOUT,6034) (IDSUR(III),III=1,NSURS) + WRITE(IOUT,6035) ITSYM + ENDIF +*---- +* Z symmetry +*---- + IF(ABS(ITSYM(3)) .EQ. 1) THEN +*---- +* 1- Eliminate reflected regions +*---- + NZSR=NZS/2 + DO IZS=1,NZSR + IODZ=(IZS-1)*NRPS + IORZ=(NZS-IZS)*NRPS + DO III=1,NRPS + IODHZ=IODZ+III + IORHZ=IORZ+III + IDREG(IORHZ)=-ABS(IDREG(IODHZ)) + ENDDO + ENDDO +*---- +* 2- Eliminate reflected hexagonal surfaces +*---- + NSPLAN=12*NXS-6 + DO IZS=1,NZSR + IODZ=(IZS-1)*NSPLAN + IORZ=(NZS-IZS)*NSPLAN + DO III=1,NSPLAN + IODHZ=IODZ+III + IORHZ=IORZ+III + IDSUR(IORHZ)=-ABS(IDSUR(IODHZ)) + ENDDO + ENDDO +*---- +* 4- Eliminate reflected Z- surfaces +*---- + ISBOT=NSPLAN*NZSR + ISTOP=ISBOT+NRPS + DO III=1,NRPS + ISBOT=ISBOT+1 + ISTOP=ISTOP+1 + IDSUR(ISTOP)=-ABS(IDSUR(ISBOT)) + ENDDO + ENDIF +*---- +* Renumber regions +*---- + IRN=0 + DO IRO=1,NREGS + IDV=IDREG(IRO) + IF(IDV .GT. 0) THEN + IRN=IRN+1 + IREN(1,IRN)=IDV + DO IRT=1,IRN-1 + IF(IDV .LT. IREN(1,IRT)) THEN + DO IRR=IRN-1,IRT,-1 + IREN(1,IRR+1)=IREN(1,IRR) + ENDDO + IREN(1,IRT)=IDV + ENDIF + ENDDO + ENDIF + ENDDO + NREGN=IRN + DO IRN=1,NREGN + IDV=IREN(1,IRN) + DO IRT=1,NREGS + IF(IDREG(IRT) .EQ. IDV ) THEN + IDREG(IRT)=IRN + ELSE IF(IDREG(IRT) .EQ. -IDV ) THEN + IDREG(IRT)=-IRN + ENDIF + ENDDO + ENDDO +*---- +* Renumber surfaces +*---- + IRN=0 + DO IRO=1,NSURS + IDS=IDSUR(IRO) + IF(IDS .GT. 0) THEN + IRN=IRN+1 + IREN(1,IRN)=IDS + DO IRT=1,IRN-1 + IF(IDS .LT. IREN(1,IRT)) THEN + DO IRR=IRN-1,IRT,-1 + IREN(1,IRR+1)=IREN(1,IRR) + ENDDO + IREN(1,IRT)=IDS + ENDIF + ENDDO + ENDIF + ENDDO + NSURN=IRN + DO IRN=1,NSURN + IDS=IREN(1,IRN) + DO IRT=1,NSURS + IF(IDSUR(IRT) .EQ. IDS ) THEN + IDSUR(IRT)=IRN + ELSE IF(IDSUR(IRT) .EQ. -IDS ) THEN + IDSUR(IRT)=-IRN + ENDIF + ENDDO + ENDDO +*---- +* Processing finished: +* print routine closing output header if required +* and return +*---- + IF(IPLOC .GE. 100) THEN + WRITE(IOUT,6010) NXS,NZS + IF(NXS .GT. 0) THEN + WRITE(IOUT,6011) 'MESHH =' + WRITE(IOUT,6012) (DAMESS(IX,1,1),IX=-1,2*NXS) + ENDIF + IF(NZS .GT. 0) THEN + WRITE(IOUT,6011) 'MESHZ =' + WRITE(IOUT,6012) (DAMESS(IX,3,1),IX=-1,NZS) + ENDIF + WRITE(IOUT,6030) 'after symmetries ' + WRITE(IOUT,6034) (IDREG(IDV),IDV=1,NREGS) + WRITE(IOUT,6032) 'after symmetries ' + WRITE(IOUT,6034) (IDSUR(IDS),IDS=1,NSURS) + WRITE(IOUT,6001) NAMSBR + ENDIF + DEALLOCATE(MIXS,IREN) + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6002 FORMAT(' Type of geometry = ',I5) + 6010 FORMAT(1X,'DIMENSIONS =',2I10/1X,'ORIGINAL MESH ') + 6011 FORMAT(1X,A7) + 6012 FORMAT(5F20.10) + 6013 FORMAT(5I20) + 6020 FORMAT(1X,'DIMENSIONS =',2I10/1X,'SPLITTED MESH ') + 6030 FORMAT(' Regions ID ',A20) + 6032 FORMAT(' Surfaces ID ',A20) + 6033 FORMAT(' Mixtures ') + 6034 FORMAT(5I15) + 6035 FORMAT('Symmetries =',4I15) + 6036 FORMAT(' Virtual mixtures ') + 9000 FORMAT(' Problem with split in HEXT or HEXTZ geometry'// + >3F20.10) + END diff --git a/Dragon/src/NXTSQD.f b/Dragon/src/NXTSQD.f new file mode 100644 index 0000000..edd6a55 --- /dev/null +++ b/Dragon/src/NXTSQD.f @@ -0,0 +1,109 @@ +*DECK NXTSQD + SUBROUTINE NXTSQD(IFTRK ,IPRINT,NDIM ,NQUAD ,NBANGL, + > DANGLT,DDENWT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To transform double precision to simple precision +* quadrature and save on IFTRK. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IFTRK pointer to the TRACKING file in creation mode. +* IPRINT print level. +* NDIM number of dimensions for geometry. +* NQUAD number of quadrant (in 3-D) and quarter (in 2-D). +* NBANGL number of angles. +* DANGLT angles (double precision). +* DDENWT angular density for each angle (double precision). +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IFTRK,IPRINT + INTEGER NDIM,NQUAD,NBANGL + DOUBLE PRECISION DANGLT(NDIM,NQUAD,NBANGL),DDENWT(NQUAD,NBANGL) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTSQD') +*---- +* Local variables +*---- + INTEGER II,IJ,IK,JJ +*---- +* Allocatable arrays +*---- + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: ANGLT,DENWT +*---- +* Scratch storage allocation +* ANGLT angles. +* DENWT angular density for each angle. +*---- + ALLOCATE(ANGLT(NDIM*NQUAD*NBANGL),DENWT(NQUAD*NBANGL)) +*---- +* Processing starts: +* print routine opening header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + JJ=0 + DO IK=1,NBANGL + DO IJ=1,NQUAD + DO II=1,NDIM + JJ=JJ+1 + ANGLT(JJ)=DANGLT(II,IJ,IK) + ENDDO + ENDDO + ENDDO + JJ=0 + DO IK=1,NBANGL + DO IJ=1,NQUAD + JJ=JJ+1 + DENWT(JJ)=DDENWT(IJ,IK) + ENDDO + ENDDO + WRITE(IFTRK) (ANGLT(JJ),JJ=1,NQUAD*NBANGL*NDIM) + WRITE(IFTRK) (DENWT(JJ),JJ=1,NQUAD*NBANGL) +*---- +* Processing finished: +* print routine closing output header if required +* and return +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(DENWT,ANGLT) + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + END diff --git a/Dragon/src/NXTTCG.f b/Dragon/src/NXTTCG.f new file mode 100644 index 0000000..9a0fe71 --- /dev/null +++ b/Dragon/src/NXTTCG.f @@ -0,0 +1,614 @@ +*DECK NXTTCG + SUBROUTINE NXTTCG(IPTRK ,IFTRK ,IPRINT,IGTRK ,NBSLIN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To track an assembly of cells containing +* clusters using the new EXCELL tracking procedure. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure in +* update or creation mode. +* IFTRK pointer to the TRACKING file in +* creation mode. +* IPRINT print level. +* IGTRK flag to generate the tracking file. In the case where: +* IGTRK=1, the tracking is performed and +* used to evaluate the track normalisation factor and the +* tracking file is generated; when IGTRK=0, the tracking is +* still performed and used to evaluate the +* track normalisation factor but the tracking file is not +* generated. +* NBSLIN maximum number of segments in a single tracking line +* computed by default in NXTTCG but limited to 100000 +* elements. This default value can be bypassed using +* keyword NBSLIN. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPTRK + INTEGER IFTRK + INTEGER IPRINT,IGTRK + INTEGER NBSLIN +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTTCG') + INTEGER NSTATE + PARAMETER (NSTATE=40) + DOUBLE PRECISION DZERO,DONE,DTWO + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) + INTEGER MXGAUS + PARAMETER (MXGAUS=64) +*---- +* Functions +*---- + INTEGER KDROPN,IFTEMP,KDRCLS,ICLS +*---- +* Local variables +*---- + INTEGER ISTATE(NSTATE),IEDIMG(NSTATE),ICODE(6) + REAL RSTATT(NSTATE),ALBEDO(6) + INTEGER RENO,LTRK,AZMOAQ,ISYMM,POLQUA,POLOAQ,AZMQUA, + > AZMNBA,IMU + DOUBLE PRECISION DENUSR,RCUTOF,DENLIN,SPACLN + DOUBLE PRECISION WEIGHT + DOUBLE PRECISION RADIUS,CENTER(3) + INTEGER NDIM,ITYPBC,IDIRG,NBOCEL,NBUCEL,IDIAG, + > ISAXIS(3),NOCELL(3),NUCELL(3),MXMSH,MAXMSH, + > MAXREG,NBTCLS,MAXPIN,MAXMSP,MAXRSP,NFSUR, + > NFREG,MXGSUR,MXGREG,NUNK,NPLANE,NPOINT, + > NTLINE,NBTDIR,MAXSUB,MAXSGL,NBDR + INTEGER IPER(3) + INTEGER JJ,NCOR,NQUAD,NANGL,NBANGL,LINMAX + DOUBLE PRECISION DQUAD(4),ABSC(3,2),RCIRC + CHARACTER CTRK*4,COMENT*80,NAMREC*12 + REAL XGSS(MXGAUS),WGSS(MXGAUS),XGSS0(2*MXGAUS), + > WGSS0(2*MXGAUS) + INTEGER IFMT + INTEGER NEREG,NESUR,NUNKC,NNBANG +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KEYMRG,MATALB + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IUNFLD,NBSANG + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SURVOL,DNSANG, + > DDANG,DSNOR + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: DGMESH,DDENWT, + > DVNOR + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: DANGLT,DEPART +*---- +* Processing starts: +* print routine opening header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF +*---- +* Open temporary tracking file if required +*---- + IF(IGTRK .EQ. 1) THEN + IFTEMP= KDROPN('DUMMYSQ',0,2,0) + IF(IFTEMP .LE. 0) WRITE(IOUT,9010) NAMSBR + ENDIF +*---- +* Get state vectors +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + CALL LCMGET(IPTRK,'EXCELTRACKOP',RSTATT) + NEREG=ISTATE(1) + NESUR=ISTATE(5) + NUNKC=NEREG+NESUR+1 + RENO =ISTATE(8) + LTRK =ISTATE(9) + AZMOAQ=ISTATE(11) + ISYMM =ISTATE(12) + POLQUA=ISTATE(13) + POLOAQ=ISTATE(14) + AZMQUA=ISTATE(15) + AZMNBA=ISTATE(16) + IFMT=ISTATE(21) + DENUSR=DBLE(RSTATT(2)) + RCUTOF=DBLE(RSTATT(3)) + DENLIN=DBLE(RSTATT(4)) + SPACLN=DBLE(RSTATT(5)) + WEIGHT=DBLE(RSTATT(6)) +*---- +* Get main tracking records +*---- + CALL LCMGET(IPTRK,'ICODE ',ICODE ) + CALL LCMGET(IPTRK,'ALBEDO ',ALBEDO) + CALL LCMSIX(IPTRK,'NXTRecords ',1) +*---- +* Get general dimensioning vector for geometry tracking +*---- + IEDIMG(:NSTATE)=0 + CALL LCMGET(IPTRK,'G00000001DIM',IEDIMG) + NDIM =IEDIMG( 1) + ITYPBC =IEDIMG( 2) + IDIRG =IEDIMG( 3) + NBOCEL =IEDIMG( 4) + NBUCEL =IEDIMG( 5) + IDIAG =IEDIMG( 6) + ISAXIS(1)=IEDIMG( 7) + ISAXIS(2)=IEDIMG( 8) + ISAXIS(3)=IEDIMG( 9) + NOCELL(1)=IEDIMG(10) + NOCELL(2)=IEDIMG(11) + NOCELL(3)=IEDIMG(12) + NUCELL(1)=IEDIMG(13) + NUCELL(2)=IEDIMG(14) + NUCELL(3)=IEDIMG(15) + MXMSH =IEDIMG(16) + MAXREG =IEDIMG(17) + NBTCLS =IEDIMG(18) + MAXPIN =IEDIMG(19) + MAXMSP =IEDIMG(20) + MAXRSP =IEDIMG(21) + NFSUR =IEDIMG(22) + NFREG =IEDIMG(23) + MXGSUR =IEDIMG(24) + MXGREG =IEDIMG(25) + NUNK=NFSUR+NFREG+1 + MAXMSH=MAX(MXMSH,MAXMSP,MAXREG) + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6011) NFREG,NEREG,NFSUR,NESUR + ENDIF + IF(ITYPBC .EQ. 0) THEN +*---- +* Define Cell for periodicity +* Cartesian Boundary +*---- + IPER(1)=2 + IF(ABS(ISAXIS(1)) .EQ. 3) IPER(1)=1 + IPER(2)=2 + IF(ABS(ISAXIS(2)) .EQ. 3) IPER(2)=1 + IPER(3)=2 + IF(ABS(ISAXIS(3)) .EQ. 3) IPER(3)=1 +*---- +* Use intrinsic geometry symmetries +* to simplify tracking unless +* NOSY tracking option activated +*---- + IF(ISYMM .NE. 0) THEN + ISYMM=0 + IF(ABS(ISAXIS(1)) .EQ. 1 .OR. ABS(ISAXIS(1)) .EQ. 2) THEN +*---- +* X SYMMETRY +*---- + ISYMM=2 + ENDIF + IF(ABS(ISAXIS(2)) .EQ. 1 .OR. ABS(ISAXIS(2)) .EQ. 2) THEN +*---- +* Y SYMMETRY +*---- + ISYMM=4+2*ISYMM + ENDIF + IF(NDIM .EQ. 3) THEN + IF(ABS(ISAXIS(3)) .EQ. 1 .OR. ABS(ISAXIS(3)) .EQ. 2) THEN +*---- +* Z SYMMETRY +*---- + ISYMM=16+ISYMM + ENDIF + ENDIF + IF(ISYMM .EQ. 0) ISYMM=1 + ENDIF + ENDIF +*---- +* Get cell description of geometry +*---- + ALLOCATE(IUNFLD(2,NBUCEL)) + NAMREC='G00000001CUF' + CALL LCMGET(IPTRK,NAMREC,IUNFLD) + ALLOCATE(KEYMRG(-NFSUR:NFREG),MATALB(-NFSUR:NFREG), + > SURVOL(-NFSUR:NFREG)) + CALL LCMGET(IPTRK,'KEYMRG ',KEYMRG) + CALL LCMGET(IPTRK,'MATALB ',MATALB) + CALL LCMGET(IPTRK,'SAreaRvolume',SURVOL) +*---- +* Read global mesh for geometry +*---- + ALLOCATE(DGMESH(-1:MAXMSH,4)) + CALL NXTXYZ(IPTRK ,IPRINT,NDIM ,ITYPBC,MAXMSH,NUCELL, + > ABSC,DGMESH) +*---- +* Verify tracking parameters and compute number of angles +* associated with angular order +* and spatial quadrature parameters +* 1. Isotropic tracking +*---- + NCOR= 1 + NPLANE=1 + IF(LTRK .EQ. 0) THEN + IF(NDIM .EQ. 2) THEN + NQUAD=2 + DQUAD(1)=DONE + DQUAD(2)=DONE + NANGL=AZMOAQ + NBANGL=NANGL + IF(ISYMM .EQ. 2 .OR. ISYMM .EQ. 8) THEN + DQUAD(1)=DONE/DTWO + DQUAD(2)=DZERO + ENDIF + ALLOCATE(DANGLT(NDIM,NQUAD,NBANGL),DDENWT(NBANGL,NQUAD)) + CALL NXTQAS(IPRINT,NDIM ,AZMQUA,NANGL ,NQUAD ,NBANGL, + > DQUAD ,DANGLT,DDENWT) + ELSE IF(NDIM .EQ. 3) THEN + NQUAD=4 + NANGL=AZMOAQ + IF(MOD(AZMOAQ,2) .EQ. 1)THEN + WRITE(IOUT,9000) NAMSBR,NANGL,NANGL+1 + NANGL=NANGL+1 + ENDIF + IF(AZMQUA .EQ. 1) THEN + IF(AZMOAQ .GT. 16) THEN + WRITE(IOUT,9001) NAMSBR + AZMQUA=4 + ENDIF + NBANGL=(NANGL * (NANGL+2)) / 8 + ENDIF + IF(AZMQUA .EQ. 4) THEN + IF(NANGL .GT. 44) THEN + WRITE(IOUT,9004) NAMSBR,NANGL + NANGL=44 + ENDIF + NBANGL=3*(NANGL * (NANGL+2)) / 8 + ELSE IF(AZMQUA .EQ. 5) THEN + IF(NANGL .GT. 44) THEN + WRITE(IOUT,9004) NAMSBR,NANGL + NANGL=44 + ENDIF + NBANGL=3*(NANGL*NANGL)/2 + ELSE IF(AZMQUA .EQ. 6) THEN + IF(NANGL .GT. 20) THEN + WRITE(IOUT,9005) NAMSBR,NANGL + NANGL=20 + ENDIF + NBANGL=(NANGL * (NANGL+2)) / 8 + ELSE IF(AZMQUA .EQ. 7) THEN + IF(NANGL .GT. 74) THEN + WRITE(IOUT,9006) NAMSBR,NANGL + NANGL=74 + ENDIF + NBANGL=3*(NANGL * (NANGL+2)) / 8 + ENDIF + AZMOAQ=NANGL + DQUAD(1)=DONE + DQUAD(2)=DONE + DQUAD(3)=DONE + DQUAD(4)=DONE + IF( ISYMM .EQ. 8 .OR. ISYMM .EQ. 24 )THEN + DQUAD(1)=DQUAD(1)/(DTWO*DTWO) + DQUAD(2)=DZERO + DQUAD(3)=DZERO + DQUAD(4)=DZERO + ELSE IF( ISYMM .EQ. 4 .OR. ISYMM .EQ. 20 )THEN + DQUAD(1)=DQUAD(1)/DTWO + DQUAD(2)=DZERO + DQUAD(3)=DQUAD(3)/DTWO + DQUAD(4)=DZERO + ELSE IF( ISYMM .EQ. 2 .OR. ISYMM .EQ. 18 )THEN + DQUAD(1)=DQUAD(1)/DTWO + DQUAD(2)=DQUAD(2)/DTWO + DQUAD(3)=DZERO + DQUAD(4)=DZERO + ENDIF + ALLOCATE(DANGLT(NDIM,NQUAD,NBANGL),DDENWT(NQUAD,NBANGL)) + CALL NXTQAS(IPRINT,NDIM ,AZMQUA,NANGL ,NQUAD ,NBANGL, + > DQUAD ,DANGLT,DDENWT) + ENDIF + LINMAX=NBUCEL* + > ((MAXPIN+1)*(2*MXGREG+2)+MXGSUR+16) +*---- +* Select standard spatial tracking parameters +*---- + CALL NXTQSS(IPRINT,NDIM ,ITYPBC,MAXMSH,NUCELL,DENUSR, + > DGMESH,NPLANE,NPOINT,DENLIN,SPACLN, + > WEIGHT,RADIUS,CENTER) + NNBANG=NBANGL + ELSE IF( LTRK.EQ.1 )THEN +*---- +* 2. Specular tracking +*---- + NPOINT=0 + NQUAD=1 + IF(NDIM .EQ. 3) CALL XABORT(NAMSBR// + > ': TSPC option not valid for 3-D geometries') + IF(AZMOAQ .GT. 24) THEN + WRITE(IOUT,9002) NAMSBR,AZMOAQ,24,30 + AZMOAQ=30 + ELSE IF(AZMOAQ .GT. 20) THEN + IF(AZMOAQ .NE. 24) THEN + WRITE(IOUT,9003) NAMSBR,AZMOAQ,20,24,24 + AZMOAQ=24 + ENDIF + ELSE IF(AZMOAQ .GT. 18) THEN + IF(AZMOAQ .NE. 20) THEN + WRITE(IOUT,9003) NAMSBR,AZMOAQ,18,20,20 + AZMOAQ=20 + ENDIF + ELSE IF(AZMOAQ .GT. 14) THEN + IF(AZMOAQ .NE. 18) THEN + WRITE(IOUT,9003) NAMSBR,AZMOAQ,14,18,18 + AZMOAQ=18 + ENDIF + ELSE IF(AZMOAQ .GT. 12) THEN + IF(AZMOAQ .NE. 14) THEN + WRITE(IOUT,9003) NAMSBR,AZMOAQ,12,14,14 + AZMOAQ=14 + ENDIF + ELSE IF(AZMOAQ .GT. 8) THEN + IF(AZMOAQ .NE. 12) THEN + WRITE(IOUT,9003) NAMSBR,AZMOAQ,8,12,12 + AZMOAQ=12 + ENDIF + ELSE IF(AZMOAQ .GT. 2) THEN + IF(AZMOAQ .NE. 8) THEN + WRITE(IOUT,9003) NAMSBR,AZMOAQ,2,8,8 + AZMOAQ=8 + ENDIF + ELSE IF(AZMOAQ .GE. 0) THEN + IF(AZMOAQ .NE. 2) THEN + WRITE(IOUT,9003) NAMSBR,AZMOAQ,-1,2,2 + AZMOAQ=2 + ENDIF + ENDIF + NBANGL=AZMOAQ + NANGL =AZMOAQ + ALLOCATE(NBSANG(5,NBANGL)) + ALLOCATE(DANGLT(NDIM,NBANGL,4),DDENWT(NBANGL,4), + > DNSANG(NBANGL),DDANG(NBANGL)) + LINMAX=8*NANGL*NBUCEL* + > ((MAXPIN+1)*(2*MXGREG+2)+MXGSUR+16) + RCIRC=SQRT(ABSC(1,1)**2+ABSC(2,1)**2) + ABSC(1,1)= ABSC(1,1)/RCIRC + ABSC(2,1)= ABSC(2,1)/RCIRC + CALL NXTQAC(IPRINT,NDIM ,NANGL ,NBANGL,ITYPBC,DENUSR, + > ABSC ,RCIRC ,AZMQUA,IPER ,DANGLT,DDENWT, + > DNSANG,NBSANG,DDANG) + DEALLOCATE(DDANG) + DO JJ=1,NBANGL + DANGLT(1,NBANGL-JJ+1,2)=-DANGLT(1,JJ,1) + DANGLT(2,NBANGL-JJ+1,2)=DANGLT(2,JJ,1) + DDENWT(NBANGL-JJ+1,2)=DDENWT(JJ,1) + ENDDO + DO JJ=1,NBANGL + DANGLT(1,NBANGL-JJ+1,4)=DANGLT(1,JJ,1) + DANGLT(2,NBANGL-JJ+1,4)=-DANGLT(2,JJ,1) + DDENWT(NBANGL-JJ+1,4)=DDENWT(JJ,1) + DANGLT(1,NBANGL-JJ+1,3)=DANGLT(1,JJ,2) + DANGLT(2,NBANGL-JJ+1,3)=-DANGLT(2,JJ,2) + DDENWT(NBANGL-JJ+1,3)=DDENWT(JJ,2) + ENDDO + NNBANG=4*NBANGL + CALL LCMPUT(IPTRK,'TrackingDirc',NDIM*NNBANG,4,DANGLT) + CALL LCMPUT(IPTRK,'TrackingTrkW',NNBANG,4,DDENWT) + CALL LCMPUT(IPTRK,'TrackingSpaD',NBANGL,4,DNSANG) +*---- +* Select cyclic spatial tracking parameters +*---- + ALLOCATE(DEPART(NDIM,2,NBANGL)) + CALL NXTQSC(IPRINT,NDIM ,NBANGL,MAXMSH,NUCELL, + > DGMESH,DANGLT,DDENWT, + > DNSANG,NBSANG,DEPART) + CALL LCMPUT(IPTRK,'TrackingNbST',5*NBANGL,1,NBSANG) + CALL LCMPUT(IPTRK,'TrackinDepT',NDIM*2*NBANGL,4,DEPART) + IF(POLQUA .GT. 0) THEN + IF(POLOAQ .LE. 0) THEN + IF(ISYMM.LE.1) THEN + POLOAQ=(AZMOAQ+1)/2 + ELSE IF(ISYMM.GE.2) THEN + POLOAQ=AZMOAQ + ENDIF + ENDIF + IF( POLQUA.EQ.0 )THEN + CALL ALGPT(2*POLOAQ, -1.0, 1.0, XGSS0, WGSS0) + DO IMU=1,POLOAQ + XGSS(POLOAQ-IMU+1)=XGSS0(IMU) + WGSS(POLOAQ-IMU+1)=WGSS0(IMU) + ENDDO + ELSE + CALL ALCACT(POLQUA, POLOAQ, XGSS, WGSS) + ENDIF + CALL LCMPUT(IPTRK,'POLAR MU ',POLOAQ,2,XGSS) + CALL LCMPUT(IPTRK,'POLAR WEIGHT',POLOAQ,2,WGSS) + ENDIF + ENDIF + RSTATT(4)=REAL(DENLIN) + RSTATT(5)=REAL(SPACLN) + RSTATT(6)=REAL(WEIGHT) + RSTATT(7)=REAL(RADIUS) + RSTATT(8)=REAL(CENTER(1)) + RSTATT(9)=REAL(CENTER(2)) + IF(NDIM .EQ. 3) RSTATT(10)=REAL(CENTER(3)) +*---- +* Track +*---- + LINMAX=MIN(LINMAX,NBSLIN) + IF(IPRINT .GE. 1) WRITE(IOUT,6010) LINMAX + NBDR=1 + IF(RENO .EQ. -1) THEN + NBDR=NQUAD*NNBANG+1 + ENDIF + ALLOCATE(DVNOR(NFREG,NBDR),DSNOR(NFSUR)) + NBTDIR=0 + IF(LTRK .EQ. 0) THEN +*---- +* Standard (isotropic) tracking (white boundary conditions) +*---- + IF(IPRINT .GE. 1) THEN + IF(NDIM .EQ.2 ) THEN + WRITE(IOUT,6030) NBANGL*NQUAD,NPOINT + ELSE + WRITE(IOUT,6030) NBANGL*NQUAD,NPOINT*NPOINT*NPLANE + ENDIF + ENDIF + MAXSUB=1 + CALL NXTTLS(IPTRK ,IFTEMP,IPRINT,IGTRK ,NDIM ,MAXMSH, + > NFSUR ,NFREG ,NUCELL,NBUCEL,NBANGL,NQUAD , + > NPLANE,NPOINT,LINMAX,MXGSUR,MXGREG,RENO , + > MAXPIN,NBTDIR,NBDR ,ITYPBC,IFMT , + > RCUTOF,SPACLN,WEIGHT,RADIUS,CENTER, + > IUNFLD,SURVOL,DGMESH,DANGLT,DDENWT, + > MAXSGL,NTLINE,DVNOR ,DSNOR) + ELSE +*---- +* Cyclic (specular) tracking (mirror like boundary conditions) +*---- + CALL NXTTLC(IPTRK ,IFTEMP,IPRINT,IGTRK ,NDIM ,MAXMSH, + > NFSUR ,NFREG ,NUCELL,NBUCEL,NBANGL, + > LINMAX,MXGSUR,MXGREG,RENO ,NBDR ,ITYPBC, + > IFMT ,MAXPIN,AZMQUA,IPER ,IUNFLD,SURVOL, + > DGMESH,DANGLT,DDENWT,DNSANG,NBSANG,DEPART, + > MAXSUB,MAXSGL,NTLINE,DVNOR ,DSNOR) + ENDIF +*---- +* Save track normalisation vector +*---- + CALL LCMPUT(IPTRK,'VTNormalize ',NFREG,4,DVNOR) + IF(NBDR .GT. 1) THEN + CALL LCMPUT(IPTRK,'VTNormalizeD',NFREG*(NBDR-1),4, + > DVNOR(1,2)) + ENDIF + CALL LCMSIX(IPTRK,'NXTRecords ',2) + ISTATE(12)=ISYMM + ISTATE(14)=POLOAQ + ISTATE(17)=NPOINT + ISTATE(18)=LINMAX + ISTATE(19)=NTLINE + ISTATE(20)=NBTDIR + ISTATE(25)=NPLANE + CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMPUT(IPTRK,'EXCELTRACKOP',NSTATE,2,RSTATT) +*---- +* Renormalize tracks if required and transfer to final tracking file +*---- + IF(IGTRK .EQ. 1) THEN + CTRK = '$TRK' + WRITE(IFTRK) CTRK,5,NTLINE,IFMT + COMENT='CREATOR : DRAGON' + WRITE(IFTRK) COMENT + COMENT='MODULE : NXTTCG' + WRITE(IFTRK) COMENT + COMENT='TYPE : CARTESIAN' + WRITE(IFTRK) COMENT + IF(RENO .EQ. -1) THEN + COMENT='TRKNOR : Directional ' + ELSE IF(RENO .EQ. 0) THEN + COMENT='TRKNOR : Global ' + ELSE + COMENT='TRKNOR : Off ' + ENDIF + WRITE(IFTRK) COMENT + IF(IFMT .EQ. 1) THEN + COMENT='OPTION : Extended ' + WRITE(IFTRK) COMENT + ELSE + COMENT='OPTION : Short ' + WRITE(IFTRK) COMENT + ENDIF +*---- +* Compress VOLSUR and MATALB according to KEYMRG +* and save on IFTRK +*---- + WRITE(IFTRK) NDIM,LTRK,NEREG,NESUR,6,NCOR,NQUAD*NNBANG,MAXSUB, + > MAXSGL + CALL NXTCVM(IFTRK,IPRINT,NFREG,NFSUR,NEREG,NESUR,MATALB,SURVOL, + > KEYMRG) + WRITE(IFTRK) ( ICODE(JJ),JJ=1,6) + WRITE(IFTRK) (ALBEDO(JJ),JJ=1,6) + CALL NXTSQD(IFTRK,IPRINT,NDIM,NQUAD,NNBANG,DANGLT,DDENWT) + REWIND IFTEMP + CALL NXTTNS(IFTRK ,IFTEMP,IPRINT,RENO ,NFSUR ,NFREG , + > NDIM ,MAXSUB,MAXSGL,NTLINE,NBDR ,IFMT , + > KEYMRG,DVNOR) +*---- +* Close temporary tracking file if required +*---- + ICLS=KDRCLS(IFTEMP,2) + IF(ICLS .NE. 0) WRITE(IOUT,9011) NAMSBR + ENDIF +*---- +* Deallocate memory +*---- + DEALLOCATE(DSNOR,DVNOR) + IF(LTRK .EQ. 1) DEALLOCATE(DEPART,NBSANG,DNSANG) + DEALLOCATE(DDENWT,DANGLT) + DEALLOCATE(DGMESH,SURVOL,MATALB,KEYMRG,IUNFLD) +*---- +* Processing finished: +* print routine closing output header if required +* and return +*---- + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6012) + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(' Maximum length of a line =',I10) + 6011 FORMAT(/' Tracking of geometry begins:'// + > ' Number of regions before merge =',I10/ + > ' Number of regions after merge =',I10/ + > ' Number of surfaces before merge=',I10/ + > ' Number of surfaces after merge =',I10) + 6012 FORMAT(/' Tracking of geometry completed'/) + 6030 FORMAT(' Number of directions for tracking = ',I10/ + > ' Number of lines per direction = ',I10) + 9000 FORMAT(' ***** Warning in ',A6,' *****'/ + > ' Order of quadrature must be even '/ + > ' Order ',I10,' replaced by ',I10) + 9001 FORMAT(' ***** Warning in ',A6,' *****'/ + > ' Order of quadrature for EQW limited to 16'/ + > ' Use PNTN quadrature instead') + 9002 FORMAT(' ***** Warning in ',A6,' *****'/ + > ' Number of speculular angles requested :',I10/ + > ' For values > ',I10,' use ',I10) + 9003 FORMAT(' ***** Warning in ',A6,' *****'/ + > ' Number of speculular angles requested :',I10/ + > ' For values > ',I10,' and < ',I10,' use ',I10) + 9004 FORMAT(' ***** Warning in ',A6,' *****'/ + > ' Order of quadrature for PNTN limited to 44'/ + > ' Order ',I10,' replaced by 44') + 9005 FORMAT(' ***** Warning in ',A6,' *****'/ + > ' Order of quadrature for LSN limited to 20'/ + > ' Order ',I10,' replaced by 20') + 9006 FORMAT(' ***** Warning in ',A6,' *****'/ + > ' Order of quadrature for QRN limited to 74'/ + > ' Order ',I10,' replaced by 74') + 9010 FORMAT(' ***** Warning in ',A6,' *****'/ + > ' Impossible to open temporary tracking file ') + 9011 FORMAT(' ***** Warning in ',A6,' *****'/ + > ' Impossible to close temporary tracking file ') + END diff --git a/Dragon/src/NXTTCR.f b/Dragon/src/NXTTCR.f new file mode 100644 index 0000000..3643ff7 --- /dev/null +++ b/Dragon/src/NXTTCR.f @@ -0,0 +1,513 @@ +*DECK NXTTCR + SUBROUTINE NXTTCR(IPTRK ,IPRINT,ICEL ,ITRN ,IFSUR , + > NDIM ,MAXMSH,LINMAX,MXGSUR,MXGREG, + > MAXPIN,CELLPO,TRKLIM,TRKORI,ANGLES, + > IBLIN ,IELIN ,NUMERO,DLENGT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To track a cell rotated according to its explicit +* position in the assembly. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure in +* update or creation mode. +* IPRINT print level. +* ICEL cell number. +* ITRN cell rotation. +* IFSUR surface treatment with: +* IFSUR=-1 or +1 surfaces located +* at the beginning or end of the track are considered; +* IFSUR=0 no surface is considered. +* NDIM problem dimensions. +* MAXMSH maximum number of elements in MESH array. +* LINMAX maximum number of segments in a track. +* MXGSUR maximum number of surfaces for any geometry. +* MXGREG maximum number of region for any geometry. +* MAXPIN maximum number of pins in a cell. +* CELLPO global cell position in space. +* TRKLIM beginning and end of track in this cell. +* TRKORI track origin. +* ANGLES track direction. +* IBLIN track line starting point. +* +*Parameters: output +* IELIN track line ending point. +* NUMERO region/surface identification number +* for segment. +* DLENGT spatial location of each line segment. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPTRK + INTEGER IPRINT,ICEL,ITRN,IFSUR, + > NDIM,MAXMSH,LINMAX,MXGSUR,MXGREG,MAXPIN + DOUBLE PRECISION CELLPO(3,2),TRKLIM(2),TRKORI(NDIM), + > ANGLES(NDIM) + INTEGER IBLIN,IELIN,NUMERO(LINMAX) + DOUBLE PRECISION DLENGT(LINMAX) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTTCR') + INTEGER NSTATE + PARAMETER (NSTATE=40) + DOUBLE PRECISION DZERO,DONE,DTWO + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Functions +*---- + DOUBLE PRECISION XDRCST,PI + INTEGER NXTLCA,NXTLHA,NXTLHT,IRLA,NXTLCY,IRLCY +*---- +* Local variables +*---- + INTEGER ITST,ILEV,IEDIMC(NSTATE),IEDIMP(NSTATE), + > ITYPG,MESHC(5),MXSLIN,NTPIN,IPIN,MESHP(5), + > IDIR,IDIRC,IDIRP,MXM1,NREGC,NSURC,NREGP,NSURP, + > ICOMB,ITL,IOVER,MESHSP(5) + INTEGER NBCOR(2,3),NBSINT(3) + DOUBLE PRECISION TRKORT(3),ANGROT(3),TRKORR(3), + > TRKORP(3),COSDIR(3), + > PINPOS(-1:1,5),ROTAX,COSR,SINR, + > TRKROF(3),ANGROF(3),ENDNEW + CHARACTER NAMCEL*9,NAMREC*12 + INTEGER IPRLOC,IKLIN,KFSUR +*---- +* Allocatable arrays +* IDSUR local surface identifier. +* IDREG local region identifier. +* ITPIN pin type identifier. +* DCMESH meshing vector for geometries. +* DRAPIN pin position identifier. +* ICSINT identification of spatial position for each +* line segment in cell description of geometry. +* DCSINT position of each intersection point for each +* line segment in cell description of geometry. +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDSUR,IDREG + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ITPIN + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: ICSINT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: DCMESH,DRAPIN, + > DCSINT + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: VSI +*---- +* Data +*---- + CHARACTER CDIR(4)*1 + SAVE CDIR + CHARACTER CLEV(2)*1 + SAVE CLEV + DATA CDIR /'X','Y','Z','R'/ + DATA CLEV /'C','P'/ +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IPRLOC=IPRINT + IF(IPRLOC .GT. 1000) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + ALLOCATE(IDSUR(MXGSUR),IDREG(MXGREG),ITPIN(3,MAXPIN+1), + > ICSINT(0:5,4*(MXGREG+4),3)) + ALLOCATE(DCMESH(-1:MAXMSH,5),DRAPIN(-1:4,MAXPIN+1), + > DCSINT(4*(MXGREG+4),3)) + PI=XDRCST('Pi',' ') + ITST=1 + ILEV=1 + KFSUR=IFSUR +*---- +* Read cell information +*---- + WRITE(NAMCEL,'(A1,I8.8)') CLEV(ILEV),ICEL + NAMREC=NAMCEL//'DIM' + IEDIMC(:NSTATE)=0 + DCMESH(-1:MAXMSH,:5)=DZERO + CALL LCMGET(IPTRK,NAMREC,IEDIMC) + ITYPG=IEDIMC(1) + MESHC(1)=IEDIMC(3) + MESHC(2)=IEDIMC(4) + MESHC(3)=IEDIMC(5) + MESHC(4)=IEDIMC(2) + MESHC(5)=IEDIMC(3) + NREGC=IEDIMC(8) + NSURC=IEDIMC(9) + MXSLIN=4*(MXGREG+4) + NTPIN=IEDIMC(18) + NAMREC=NAMCEL//'RID' + CALL LCMGET(IPTRK,NAMREC,IDREG) + NAMREC=NAMCEL//'SID' + CALL LCMGET(IPTRK,NAMREC,IDSUR) + DO IDIR=1,4 + NAMREC=NAMCEL//'SM'//CDIR(IDIR) + IF(MESHC(IDIR) .GT. 0) THEN + CALL LCMGET(IPTRK,NAMREC,DCMESH(-1,IDIR)) + ENDIf + ENDDO + IF(NTPIN .GT. 0) THEN + NAMREC=NAMCEL//'PIN' + CALL LCMGET(IPTRK,NAMREC,DRAPIN) + NAMREC=NAMCEL//'PNT' + CALL LCMGET(IPTRK,NAMREC,ITPIN) + ENDIF +*---- +* Translate TRKORI in such a way that it is now defined with +* respect to the cell center. +*---- + DO IDIR=1,NDIM + TRKORT(IDIR)=TRKORI(IDIR) + > -(CELLPO(IDIR,1)+CELLPO(IDIR,2))/DTWO + ENDDO +*---- +* Rotate tracking line according to ITRN provided +*---- + IF(IPRLOC .GT. 1000) THEN + WRITE(IOUT,6030) ICEL,ITRN + ENDIF + TRKORR(:3)=DZERO + ANGROT(:3)=DZERO + CALL NXTRTL(IPRLOC,NDIM ,ITRN ,TRKORT,ANGLES, + > TRKORR,ANGROT) + ITL=1 + IF(ITYPG .EQ. 5 .OR. ITYPG .EQ. 7 .OR. + > ITYPG .EQ. 20 .OR. ITYPG .EQ. 21 .OR. + > ITYPG .EQ. 22 .OR. ITYPG .EQ. 23) THEN +*---- +* Track Cartesian cell +*---- + IRLA=NXTLCA(IPRLOC ,ITST ,NDIM ,MAXMSH,MXSLIN, + > MESHC ,TRKORR,ANGROT,DCMESH, + > NBCOR(1,ITL) ,NBSINT(ITL) , + > ICSINT(0,1,ITL),DCSINT(1,ITL) ) +*---- +* If required, track annular mesh +* and combine with Cartesian mesh. +*---- + IRLCY=0 + IDIRC=MOD(IEDIMC(20)+1,3)+1 + IF(ITYPG .EQ. 20 .OR. ITYPG .EQ. 21 .OR. + > ITYPG .EQ. 22 .OR. ITYPG .EQ. 23) THEN + ITL=2 + IRLCY=NXTLCY(IPRLOC,ITST ,NDIM ,MAXMSH,MXSLIN, + > MESHC ,TRKORR,ANGROT,DCMESH,IDIRC , + > NBCOR(1,ITL) ,NBSINT(ITL) , + > ICSINT(0,1,ITL),DCSINT(1,ITL) ) + IF(IRLCY .EQ. 2) THEN + ICOMB=1 + CALL NXTLCU(IPRLOC,MXSLIN,ICOMB , + > NBCOR ,NBSINT,ICSINT,DCSINT) + ITL=3 + ELSE + ITL=1 + ENDIF + ENDIF + ELSE IF(ITYPG .EQ. 8 .OR. ITYPG .EQ. 9 .OR. + > ITYPG .EQ. 24 .OR. ITYPG .EQ. 25) THEN +*---- +* Track hexagonal cell +*---- + IRLA=NXTLHA(IPRLOC ,ITST ,NDIM ,MAXMSH,MXSLIN, + > MESHC ,TRKORR,ANGROT,DCMESH, + > NBCOR(1,ITL) ,NBSINT(ITL) , + > ICSINT(0,1,ITL),DCSINT(1,ITL) ) +*---- +* If required, track annular mesh +* and combine with Cartesian mesh. +*---- + IRLCY=0 + IF(ITYPG .EQ. 24 .OR. ITYPG .EQ. 25) THEN + ITL=2 + IDIRC=3 + IRLCY=NXTLCY(IPRLOC,ITST ,NDIM ,MAXMSH,MXSLIN, + > MESHC ,TRKORR,ANGROT,DCMESH,IDIRC , + > NBCOR(1,ITL) ,NBSINT(ITL) , + > ICSINT(0,1,ITL),DCSINT(1,ITL) ) + IF(IRLCY .EQ. 2) THEN + ICOMB=1 + CALL NXTLCU(IPRLOC,MXSLIN,ICOMB , + > NBCOR ,NBSINT,ICSINT,DCSINT) + ITL=3 + ELSE + ITL=1 + ENDIF + ENDIF + ELSE IF(ITYPG .EQ. 12 .OR. ITYPG .EQ. 13 .OR. + > ITYPG .EQ. 26 .OR. ITYPG .EQ. 27 ) THEN +*---- +* Track hexagonal cell with triangular mesh +*---- + MESHC(1)=2*MESHC(1) + IRLA=NXTLHT(IPRLOC ,ITST ,NDIM ,MAXMSH,MXSLIN, + > MESHC ,TRKORR,ANGROT,DCMESH,TRKLIM, + > NBCOR(1,ITL) ,NBSINT(ITL) , + > ICSINT(0,1,ITL),DCSINT(1,ITL) ) + IRLCY=0 + IF(ITYPG .EQ. 26 .OR. ITYPG .EQ. 27) THEN + ITL=2 + IDIRC=3 + IRLCY=NXTLCY(IPRLOC,ITST ,NDIM ,MAXMSH,MXSLIN, + > MESHC ,TRKORR,ANGROT,DCMESH,IDIRC , + > NBCOR(1,ITL) ,NBSINT(ITL) , + > ICSINT(0,1,ITL),DCSINT(1,ITL) ) + IF(IRLCY .EQ. 2) THEN + ICOMB=1 + CALL NXTLCU(IPRLOC,MXSLIN,ICOMB , + > NBCOR ,NBSINT,ICSINT,DCSINT) + ITL=3 + ELSE + ITL=1 + ENDIF + ENDIF + ENDIF +*---- +* Add tracking lines at the end of current tracking vector +*---- + IOVER=0 + IF(ITYPG .EQ. 12 .OR. ITYPG .EQ. 13 .OR. + > ITYPG .EQ. 26 .OR. ITYPG .EQ. 27) THEN + ALLOCATE(VSI(5,-NSURC:NREGC)) + NAMREC=NAMCEL//'VSI' + CALL LCMGET(IPTRK,NAMREC,VSI) + CALL NXTLRH(IPRLOC,IOVER ,ITYPG ,LINMAX,MXSLIN, + > NREGC ,NSURC ,MESHC ,IDSUR ,IDREG , + > NBCOR(1,ITL) ,NBSINT(ITL) , + > ICSINT(0,1,ITL),DCSINT(1,ITL) , + > IBLIN ,IELIN ,NUMERO,DLENGT,VSI) + DEALLOCATE(VSI) + ELSE + CALL NXTLRS(IPRLOC,IOVER ,ITYPG ,LINMAX,MXSLIN, + > NREGC ,NSURC ,MESHC ,IDSUR ,IDREG , + > NBCOR(1,ITL) ,NBSINT(ITL) , + > ICSINT(0,1,ITL),DCSINT(1,ITL) , + > IBLIN ,IELIN ,NUMERO,DLENGT) + ENDIF + IF(IELIN .GT. LINMAX) THEN + CALL XABORT(NAMSBR// + > ': Tracking vector dimensions too small') + ENDIF +*---- +* Translate TRKORR to take into account OFFCEN for cylinders +* and pins. +*---- + IF(NTPIN .GT. 0) THEN + DO IDIR=1,NDIM + TRKORR(IDIR)=TRKORR(IDIR)-DCMESH(-1,IDIR) + ENDDO +*---- +* Scan PINS for intersection with LINE +*---- + ILEV=2 + MESHP(1)=1 + MESHP(2)=1 + MESHP(3)=1 + MESHP(4)=1 + MESHP(5)=1 + MXM1=1 + IOVER=1 + DO IPIN=1,NTPIN + IF(IPRLOC .GT. 1000) THEN + WRITE(IOUT,6010) IPIN + ENDIF +*---- +* Translate TRKORT in such a way that it is now defined with +* respect to the pin center. +*---- + PINPOS(-1:1,:5)=DZERO + IDIRP=ABS(ITPIN(3,IPIN)) + PINPOS(1,4)=DRAPIN(4,IPIN) + IF(IDIRP .EQ. 3) THEN +*---- +* 2-D or Z directed pins +*---- + COSDIR(1)=DRAPIN(0,IPIN)*COS(DRAPIN(-1,IPIN)) + COSDIR(2)=DRAPIN(0,IPIN)*SIN(DRAPIN(-1,IPIN)) + COSDIR(3)=DZERO + PINPOS(0,3)=-DRAPIN(3,IPIN)/DTWO + PINPOS(1,3)=DRAPIN(3,IPIN)/DTWO + DO IDIR=1,NDIM + TRKORP(IDIR)=TRKORR(IDIR)-COSDIR(IDIR) + ENDDO + ELSE IF(IDIRP .EQ. 2) THEN +*---- +* Y directed pins +*---- + COSDIR(3)=DRAPIN(0,IPIN)*COS(DRAPIN(-1,IPIN)) + COSDIR(1)=DRAPIN(0,IPIN)*SIN(DRAPIN(-1,IPIN)) + COSDIR(2)=DZERO + PINPOS(0,2)=-DRAPIN(2,IPIN)/DTWO + PINPOS(1,2)=DRAPIN(2,IPIN)/DTWO + DO IDIR=1,NDIM + TRKORP(IDIR)=TRKORR(IDIR)-COSDIR(IDIR) + ENDDO + ELSE +*---- +* X directed pins +*---- + COSDIR(2)=DRAPIN(0,IPIN)*COS(DRAPIN(-1,IPIN)) + COSDIR(3)=DRAPIN(0,IPIN)*SIN(DRAPIN(-1,IPIN)) + COSDIR(1)=DZERO + PINPOS(0,1)=-DRAPIN(1,IPIN)/DTWO + PINPOS(1,1)=DRAPIN(1,IPIN)/DTWO + DO IDIR=1,NDIM + TRKORP(IDIR)=TRKORR(IDIR)-COSDIR(IDIR) + ENDDO + ENDIF + ITL=2 + IRLCY=NXTLCY(IPRLOC,ITST ,NDIM ,MXM1 ,MXSLIN, + > MESHP ,TRKORP,ANGROT,PINPOS,IDIRP , + > NBCOR(1,ITL) ,NBSINT(ITL) , + > ICSINT(0,1,ITL),DCSINT(1,ITL) ) + IF(IRLCY .EQ. 2) THEN +*---- +* Rotate geometry by (Pi/2-alpha) +* for pin at alpha. +*---- + ROTAX=PI/DTWO-DRAPIN(-1,IPIN) + COSR=COS(ROTAX) + SINR=SIN(ROTAX) + IF(IDIRP .EQ. 3) THEN +*---- +* 2-D or Z directed pins +*---- + TRKROF(1)=TRKORP(1)*COSR-TRKORP(2)*SINR + TRKROF(2)=TRKORP(1)*SINR+TRKORP(2)*COSR + TRKROF(3)=TRKORP(3) + ANGROF(1)=ANGROT(1)*COSR-ANGROT(2)*SINR + ANGROF(2)=ANGROT(1)*SINR+ANGROT(2)*COSR + ANGROF(3)=ANGROT(3) + ELSE IF(IDIRP .EQ. 2) THEN + TRKROF(3)=TRKORP(3)*COSR-TRKORP(1)*SINR + TRKROF(1)=TRKORP(3)*SINR+TRKORP(1)*COSR + TRKROF(2)=TRKORP(2) + ANGROF(3)=ANGROT(3)*COSR-ANGROT(1)*SINR + ANGROF(1)=ANGROT(3)*SINR+ANGROT(1)*COSR + ANGROF(2)=ANGROT(2) + ELSE + TRKROF(2)=TRKORP(2)*COSR-TRKORP(3)*SINR + TRKROF(3)=TRKORP(2)*SINR+TRKORP(3)*COSR + TRKROF(1)=TRKORP(1) + ANGROF(2)=ANGROT(2)*COSR-ANGROT(3)*SINR + ANGROF(3)=ANGROT(2)*SINR+ANGROT(3)*COSR + ANGROF(1)=ANGROT(1) + ENDIF +*---- +* Read pin information +*---- + WRITE(NAMCEL,'(A1,I8.8)') CLEV(ILEV),ITPIN(2,IPIN) + NAMREC=NAMCEL//'DIM' + IEDIMP(:NSTATE)=0 + CALL LCMGET(IPTRK,NAMREC,IEDIMP) + ITYPG=IEDIMP(1) + MESHSP(1)=IEDIMP(3) + MESHSP(2)=IEDIMP(4) + MESHSP(3)=IEDIMP(5) + MESHSP(4)=IEDIMP(2) + MESHSP(5)=IEDIMP(3) + NREGP=IEDIMP(8) + NSURP=IEDIMP(9) + NAMREC=NAMCEL//'RID' + CALL LCMGET(IPTRK,NAMREC,IDREG) + NAMREC=NAMCEL//'SID' + CALL LCMGET(IPTRK,NAMREC,IDSUR) + DO IDIR=1,4 + NAMREC=NAMCEL//'SM'//CDIR(IDIR) + IF(MESHSP(IDIR) .GT. 0) THEN + CALL LCMGET(IPTRK,NAMREC,DCMESH(-1,IDIR)) + ENDIF + ENDDO +*---- +* Track annular mesh +*---- + ITL=2 + IRLCY=NXTLCY(IPRLOC,ITST ,NDIM ,MAXMSH,MXSLIN, + > MESHSP,TRKORP,ANGROT,DCMESH,IDIRP , + > NBCOR(1,ITL) ,NBSINT(ITL) , + > ICSINT(0,1,ITL),DCSINT(1,ITL) ) +*---- +* Track Cartesian mesh +*---- + ITL=1 +* > +500 + IRLA=NXTLCA(IPRLOC ,ITST ,NDIM ,MAXMSH,MXSLIN, + > MESHSP,TRKROF,ANGROF,DCMESH, + > NBCOR(1,ITL) ,NBSINT(ITL) , + > ICSINT(0,1,ITL),DCSINT(1,ITL) ) + IF(IRLA .EQ. 2) THEN + ICOMB=2 + CALL NXTLCU(IPRLOC,MXSLIN,ICOMB , + > NBCOR ,NBSINT,ICSINT,DCSINT) + ITL=3 + ELSE + ITL=2 + ENDIF +*---- +* Insert tracking lines inside the current tracking vector +*---- + CALL NXTLRS(IPRLOC,IOVER ,ITYPG ,LINMAX,MXSLIN, + > NREGP ,NSURP ,MESHSP,IDSUR ,IDREG , + > NBCOR(1,ITL) ,NBSINT(ITL) , + > ICSINT(0,1,ITL),DCSINT(1,ITL) , + > IBLIN ,IELIN ,NUMERO,DLENGT) + IF(IELIN .GT. LINMAX) THEN + CALL XABORT(NAMSBR// + > ': Tracking vector dimensions too small') + ENDIF + ENDIF + ENDDO + ENDIF +*---- +* Processing finished: +* print routine closing output header if required +* and return +*---- + ENDNEW=DLENGT(1) + IF(IPRLOC .GT. 1000) THEN + WRITE(IOUT,6020) NUMERO(1),ENDNEW + DO IKLIN=1,IELIN-1 + IF(NUMERO(IKLIN) .GT. 0) THEN + ENDNEW=ENDNEW+DLENGT(IKLIN) + WRITE(IOUT,6021) NUMERO(IKLIN),ENDNEW + ENDIF + ENDDO + WRITE(IOUT,6022) NUMERO(IELIN),DLENGT(IELIN) + WRITE(IOUT,6001) NAMSBR + ENDIF + DEALLOCATE(DCSINT,DRAPIN,DCMESH) + DEALLOCATE(ICSINT,ITPIN,IDREG,IDSUR) + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(' Processing PIN = ',I8) + 6020 FORMAT('LinePos ={ {',I10,',',F19.10,'},') + 6021 FORMAT(' {',I10,',',F19.10,'},') + 6022 FORMAT(' {',I10,',',F19.10,'}}') + 6030 FORMAT(' Processing CELL = ',I8,' with turn =',I8) + END diff --git a/Dragon/src/NXTTGC.f b/Dragon/src/NXTTGC.f new file mode 100644 index 0000000..8a4e337 --- /dev/null +++ b/Dragon/src/NXTTGC.f @@ -0,0 +1,457 @@ +*DECK NXTTGC + SUBROUTINE NXTTGC(IPTRK ,IPRINT,NDIM ,NBTDIR,NPOINT,NTRK , + > ITRAK ,MAXMSH,NFSUR ,NFREG ,NUCELL,NBUCEL, + > MXGSUR,MXGREG,MAXPIN,LINMAX,ITYPBC,IUNFLD, + > MATALB,SURVOL,DGMESH,DANGLT,DVNOR ,DWGTRK, + > DORITR,NSLINE,NCOR ,WEIGHT,NUMERO,LENGTH) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To generate a specific cyclic tracking line (specular tracking) +* for a geometry. This routine is used for line by line integration of +* the collision probability matrix without tracking file. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure in +* update or creation mode. +* IPRINT print level. +* NDIM problem dimensions. +* NBTDIR number of tracks directions considered. +* NPOINT number of integration points along each axis +* in a plane mormal to track direction. +* NTRK maximum number of track that can be generated. +* ITRAK track number considered. For 3-D problems +* ITRAK=(ITDIR-1)*(3*NPOINT**2) +* +(IPLANE-1)*NPOINT**2 +* +(IPA2-1)*NPOINT +* +IPA3 +* while for 2-D problems +* ITRAK=(ITDIR-1)*(NPOINT) +* +IPA3 +* will be used. +* MAXMSH maximum number of elements in MESH array. +* NFSUR number of surfaces. +* NFREG number of regions. +* NUCELL number of cell after unfolding in +* $X$, $Y$ and $Z$ directions. +* NBUCEL number of cells in unfolded geometry. +* MXGSUR maximum number of surfaces for any geometry. +* MXGREG maximum number of region for any geometry. +* MAXPIN maximum number of pins in a cell. +* LINMAX maximum number of segments in a track. +* ITYPBC type of boundary conditions where: +* =0 for geometry with Cartesian boundaries; +* =1 for geometry with annular boundary; +* =2 for geometry with hexagonal boundary. +* IUNFLD description of unfolded geometry. +* MATALB global mixture/albedo identification vector. +* SURVOL global surface volume vector. +* DGMESH meshing vector for global geometry. +* DANGLT angles. +* DVNOR ratio of analytic to tracked volume. +* DWGTRK weight of tracking lines. +* DORITR origin of tracking lines. +* +*Parameters: output +* NSLINE number of segments for this track. +* NCOR number of start/end surfaces. +* WEIGHT weight associated with each line. +* NUMERO region/surface identification number +* for segment. +* LENGTH segment length. +* +*References: +* This routine represent a simplified version of NXTTLC where +* the track origin, direction and weights are already known. +* Moreover, instead of computing the track normalization +* fators, one assume that they are available and the +* track are renormalized directly in this module. +* +*---------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPTRK +* INTEGER IPTRK + INTEGER IPRINT,NDIM,NBTDIR,NPOINT,NTRK,ITRAK,MAXMSH, + > NFSUR,NFREG,NUCELL(3),NBUCEL,MXGSUR,MXGREG, + > MAXPIN,LINMAX,ITYPBC + INTEGER IUNFLD(2,NBUCEL),MATALB(-NFSUR:NFREG) + DOUBLE PRECISION SURVOL(-NFSUR:NFREG),DGMESH(-1:MAXMSH,4), + > DANGLT(NDIM,NBTDIR),DVNOR(NFREG) + DOUBLE PRECISION DWGTRK(NBTDIR), + > DORITR(NDIM*(NDIM+1),2*NDIM-3,NBTDIR) + INTEGER NSLINE,NCOR + DOUBLE PRECISION WEIGHT + INTEGER NUMERO(LINMAX) + DOUBLE PRECISION LENGTH(LINMAX) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTTGC') + DOUBLE PRECISION DCUTOF,DZERO,DONE,DTWO + PARAMETER (DCUTOF=1.0D-8,DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Functions +*---- + DOUBLE PRECISION XDRCST,PI + INTEGER NXTLCA,NXTLHA,IRLA +*---- +* Local variables +*---- + INTEGER ITDIR,NPLANE,IPLANE,IPTA2,IPTA3,IDIR,ITST, + > NBCOR(2),NBSINT,ITLOC + INTEGER ITRN,ICEL,ICI,JLINE,IBLIN,IELIN,ISURF, + > IX,IY,IZ,IOX,IOY,IOZ,IOC,LMAXT + DOUBLE PRECISION ANGLES(3,3), + > TRKORI(3),TRKOR2(3),TRKLIM(2), + > CELLPO(3,2),DSTART + INTEGER ISEG,JSEG,IREG,ILREG,IPRINL,NBREG,IOFF + INTEGER NSDEB,NSFIN + REAL FACSC +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ICINT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DLENGT,DCINT +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 200) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + NSLINE=0 + NCOR=0 + ITST=NTRK + ITST=MATALB(0) + FACSC=REAL(SURVOL(0)) + PI=XDRCST('Pi',' ') + LMAXT=4*(NBUCEL+4) + ITST=1 + NPLANE=2*NDIM-3 +*---- +* Scratch storage allocation +* DLENGT spatial location of each line segment. +* ICINT identification of spatial position for each +* line segment in cell description of geometry. +* DCINT position of each intersection point for each +* line segment in cell description of geometry. +*---- + ALLOCATE(ICINT(0:5,LMAXT)) + ALLOCATE(DLENGT(LINMAX),DCINT(LMAXT)) +*---- +* Identify track direction plane number and point. +* For 3-D: +* ITRAK=(ITDIR-1)*(3*NPOINT**2) +* +(IPLANE-1)*NPOINT**2 +* +(IPA2-1)*NPOINT +* +IPA3 +* For 2-D: +* ITRAK=(ITDIR-1)*(NPOINT) +* +IPA2 +* will be used. +*---- + ITLOC=ITRAK + IF(NDIM .EQ. 3) THEN + IPTA3=MOD(ITLOC-1,NPOINT)+1 + ITLOC=ITLOC/NPOINT + IPTA2=MOD(ITLOC,NPOINT)+1 + ITLOC=ITLOC/NPOINT + IPLANE=MOD(ITLOC,NPLANE)+1 + ITLOC=ITLOC/NPLANE + ITDIR=MOD(ITLOC,NBTDIR)+1 + ELSE + IPTA3=1 + IPTA2=MOD(ITLOC-1,NPOINT)+1 + IPLANE=1 + ITLOC=ITLOC/NPOINT + ITDIR=MOD(ITLOC,NBTDIR)+1 + ENDIF + WEIGHT=DWGTRK(ITDIR) +*---- +* Find planes mormal to selected direction +*---- + ANGLES(:3,:3)=DZERO + DO IDIR=1,NDIM + ANGLES(IDIR,1)=DANGLT(IDIR,ITDIR) + TRKOR2(IDIR)=DORITR(IDIR,IPLANE,ITDIR) + ENDDO + IOFF=NDIM + DO JLINE=1,NDIM + DO IDIR=1,NDIM + ANGLES(IDIR,JLINE)=DORITR(IDIR+IOFF,IPLANE,ITDIR) + ENDDO + IOFF=IOFF+NDIM + ENDDO +*---- +* Position TRKORI with respect to IPTA2 +*---- + DO IDIR=1,NDIM + TRKORI(IDIR)=TRKOR2(IDIR)+DBLE(IPTA2)*ANGLES(IDIR,2) + ENDDO +*---- +* Position TRKORI with respect to IPTA3 +*---- + DO IDIR=1,NDIM + TRKORI(IDIR)=TRKORI(IDIR)+DBLE(IPTA3)*ANGLES(IDIR,3) + ENDDO + IPRINL=IPRINT + IRLA=-1 + IF(ITYPBC .EQ. 0) THEN +*---- +* Cartesian assembly +*---- + IRLA=NXTLCA(IPRINL,ITST ,NDIM ,MAXMSH,LMAXT, + > NUCELL,TRKORI,ANGLES,DGMESH, + > NBCOR ,NBSINT,ICINT ,DCINT) + ELSE IF(ITYPBC .EQ. 2) THEN +*---- +* Hexagonal assembly +*---- + IRLA=NXTLHA(IPRINL,ITST ,NDIM ,MAXMSH,LMAXT, + > NUCELL,TRKORI,ANGLES,DGMESH, + > NBCOR ,NBSINT,ICINT ,DCINT) + ENDIF +*---- +* When no external face crossed go to next line +*---- + IF(IRLA .EQ. -1) CALL XABORT(NAMSBR// + >': This type of cell cannot be tracked by NXT:') + IF(IRLA .EQ. 0) GO TO 115 +*---- +* For each region crossed loop track geometry +* present in this region +*---- +* IF( ITRAK .EQ. 4 +* >.OR. ITRAK .EQ. 5 +* >.OR. ITRAK .EQ. 5040815 +* >.OR. ITRAK .EQ. 595 +* >.OR. ITRAK .EQ. 344 +* >.OR. ITRAK .EQ. 290 +* >.OR. ITRAK .EQ. 401 +* >.OR. ITRAK .EQ. 452 +* >.OR. ITRAK .EQ. 499 +* > ) IPRINL=IPRINT+2000 + IF(IPRINL .GE. 500) THEN + WRITE(IOUT,6045) + WRITE(IOUT,6040) ITRAK,ITDIR,IPLANE, + > IPTA2,IPTA3,WEIGHT + WRITE(IOUT,6041) ITRAK,TRKORI + WRITE(IOUT,6042) ITRAK,ANGLES + WRITE(IOUT,6043) ITRAK,DCINT(1) + ELSE IF(IPRINL .GE. 50) THEN + WRITE(IOUT,6040) ITRAK,ITDIR,IPLANE, + > IPTA2,IPTA3,WEIGHT + ENDIF + IBLIN=1 + IELIN=0 + NUMERO(IBLIN)=0 + DLENGT(IBLIN)=DCINT(1) + DSTART=DCINT(1) + IBLIN=IBLIN+1 + DO ICI=NBCOR(1)+1,NBSINT-NBCOR(2)+1 + IX=ICINT(1,ICI) + IY=ICINT(2,ICI) + IOX=IX + CELLPO(1,2)=DGMESH(IX,1) + CELLPO(1,1)=DGMESH(IX-1,1) + CELLPO(2,2)=DGMESH(IY,2) + CELLPO(2,1)=DGMESH(IY-1,2) + IOY=(IY-1)*NUCELL(1) + IOZ=0 + IF(NDIM .EQ. 3) THEN + IZ=ICINT(3,ICI) + IOZ=(IZ-1)*NUCELL(1)*NUCELL(2) + CELLPO(3,2)=DGMESH(IZ,3) + CELLPO(3,1)=DGMESH(IZ-1,3) + ENDIF + IOC=IOX+IOY+IOZ + ICEL=IUNFLD(1,IOC) + ITRN=IUNFLD(2,IOC) + TRKLIM(1)=DSTART + DSTART=DSTART+DCINT(ICI) + TRKLIM(2)=DSTART + IF(ICI .EQ. NBCOR(1)+1) THEN +*---- +* initial surfaces (at TRKLIM(1)) considered +*---- + ISURF=-1 + ELSE IF(ICI .EQ. NBSINT-NBCOR(2)) THEN +*---- +* final surfaces (at TRKLIM(2)) considered +*---- + ISURF=1 + ELSE +*---- +* no surface considered +*---- + ISURF=0 + ENDIF +*---- +* Track turned Cell +*---- + CALL NXTTCR(IPTRK ,IPRINL,ICEL ,ITRN ,ISURF , + > NDIM ,MAXMSH,LINMAX,MXGSUR,MXGREG, + > MAXPIN,CELLPO,TRKLIM,TRKORI,ANGLES, + > IBLIN ,IELIN ,NUMERO,DLENGT) + IBLIN=IELIN+1 + ENDDO + NSLINE=IELIN +*---- +* Compress tracking vector for region with DLENGT=0.0 and +* for successive segments in the same region. +*---- + JSEG=0 + ILREG=-1 + NBREG=0 + DO ISEG=1,NSLINE + IREG=NUMERO(ISEG) + IF(DLENGT(ISEG) .GT. DZERO) THEN + IF(IREG .GT. 0) THEN + IF(IREG .EQ. ILREG) THEN + DLENGT(JSEG)=DLENGT(JSEG)+DLENGT(ISEG) + ELSE + JSEG=JSEG+1 + DLENGT(JSEG)=DLENGT(ISEG) + NUMERO(JSEG)=IREG + ILREG=IREG + ENDIF + ELSE + JSEG=JSEG+1 + DLENGT(JSEG)=DLENGT(ISEG) + NUMERO(JSEG)=IREG + ILREG=-1 + ENDIF + ENDIF + ENDDO + NSLINE=JSEG +*---- +* Add contribution of track to volume integration for this angle +* in this quadrant and compress tracking line by removing +* segments with NUMERO=0. +*---- + JSEG=0 + NSDEB=0 + NSFIN=0 + NBREG=0 + DO ISEG=1,NSLINE + IREG=NUMERO(ISEG) + IF(DLENGT(ISEG) .GT. DZERO) THEN + IF(IREG .GT. 0) THEN + NBREG=NBREG+1 + JSEG=JSEG+1 + LENGTH(JSEG)=DLENGT(ISEG)*DVNOR(IREG) + NUMERO(JSEG)=IREG + ELSE IF(IREG .LT. 0) THEN + IF(NBREG .EQ. 0) THEN + NSDEB=NSDEB+1 + ELSE + NSFIN=NSFIN+1 + ENDIF + JSEG=JSEG+1 + LENGTH(JSEG)=DLENGT(ISEG) + NUMERO(JSEG)=IREG + ENDIF + ENDIF + ENDDO + NSLINE=JSEG + NCOR=MAX(NSDEB,NSFIN) + FACSC=1.0/REAL(NCOR) + IF(NCOR .GT. 1) THEN + IF(NSDEB .EQ. 2*NSFIN) THEN +*---- +* Duplicate final surfaces +* And change their weight +*---- + DO ISEG=NSLINE-NSFIN+1,NSLINE + LENGTH(ISEG)=LENGTH(ISEG)*FACSC + LENGTH(ISEG+NSFIN)=LENGTH(ISEG) + NUMERO(ISEG+NSFIN)=NUMERO(ISEG) + ENDDO + NSLINE=NSLINE+NSFIN + DO ISEG=1,NSDEB + LENGTH(ISEG)=LENGTH(ISEG)*FACSC + ENDDO + ELSE IF(2*NSDEB .EQ. NSFIN) THEN +*---- +* Displace tracks by NSDEB places +* This automatically double the NSDEB first faces. +*---- + DO ISEG=NSLINE,1,-1 + LENGTH(ISEG+NSDEB)=LENGTH(ISEG) + NUMERO(ISEG+NSDEB)=NUMERO(ISEG) + ENDDO + NSLINE=NSLINE+NSDEB +*---- +* Duplicate surface weights +*---- + DO ISEG=NSLINE-NSFIN+1,NSLINE + LENGTH(ISEG)=LENGTH(ISEG)*FACSC + ENDDO + DO ISEG=1,NSFIN + LENGTH(ISEG)=LENGTH(ISEG)*FACSC + ENDDO + ELSE IF(NSDEB .EQ. NSFIN) THEN +*---- +* Duplicate surface weights +*---- + DO ISEG=NSLINE-NSFIN+1,NSLINE + LENGTH(ISEG)=LENGTH(ISEG)*FACSC + ENDDO + DO ISEG=1,NSDEB + LENGTH(ISEG)=LENGTH(ISEG)*FACSC + ENDDO + ELSE + CALL XABORT(NAMSBR// + > ': Number of begin and end surfaces not compatible') + ENDIF + ENDIF +*---- +* Exit because line is outside circle or sphere surrounding geometry +*---- + 115 CONTINUE +*---- +* Processing finished: +* print track normalization vector. +* and routine closing output header if required +* and return +*---- + IF(IPRINT .GE. 200) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(DCINT,DLENGT) + DEALLOCATE(ICINT) + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6040 FORMAT('Track',I10.10,'={',4(I10,','), + >F15.8,'};') + 6041 FORMAT('Torig',I10.10,'={',2(F15.8,','),F15.8,'};') + 6042 FORMAT('Tdire',I10.10,'={',8(F15.8,','),F15.8,'};') + 6043 FORMAT('Tstrt',I10.10,'={',F15.8,'};') + 6045 FORMAT(1X) + END diff --git a/Dragon/src/NXTTGS.f b/Dragon/src/NXTTGS.f new file mode 100644 index 0000000..c442c06 --- /dev/null +++ b/Dragon/src/NXTTGS.f @@ -0,0 +1,510 @@ +*DECK NXTTGS + SUBROUTINE NXTTGS(IPTRK ,IPRINT,NDIM ,NBTDIR,NPOINT,NTRK , + > ITRAK ,MAXMSH,NFSUR ,NFREG ,NUCELL,NBUCEL, + > MXGSUR,MXGREG,MAXPIN,LINMAX,ITYPBC,IUNFLD, + > MATALB,SURVOL,DGMESH,DANGLT,DVNOR ,DWGTRK, + > DORITR,NSLINE,NCOR ,WEIGHT,NUMERO,LENGTH) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To generate a specific standard tracking line (isotropic tracking) +* for a geometry. This routine is used for line by line integration of +* the collision probability matrix without tracking file. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure in +* update or creation mode. +* IPRINT print level. +* NDIM problem dimensions. +* NBTDIR number of tracks directions considered. +* NPOINT number of integration points along each axis +* in a plane mormal to track direction. +* NTRK maximum number of track that can be generated. +* ITRAK track number considered. For 3-D problems +* ITRAK=(ITDIR-1)*(3*NPOINT**2) +* +(IPLANE-1)*NPOINT**2 +* +(IPA2-1)*NPOINT +* +IPA3 +* while for 2-D problems +* ITRAK=(ITDIR-1)*(NPOINT) +* +IPA3 +* will be used. +* MAXMSH maximum number of elements in MESH array. +* NFSUR number of surfaces. +* NFREG number of regions. +* NUCELL number of cell after unfolding in +* $X$, $Y$ and $Z$ directions. +* NBUCEL number of cells in unfolded geometry. +* MXGSUR maximum number of surfaces for any geometry. +* MXGREG maximum number of region for any geometry. +* MAXPIN maximum number of pins in a cell. +* LINMAX maximum number of segments in a track. +* ITYPBC type of boundary conditions where: +* =0 for geometry with Cartesian boundaries; +* =1 for geometry with annular boundary; +* =2 for geometry with hexagonal boundary. +* IUNFLD description of unfolded geometry. +* MATALB global mixture/albedo identification vector. +* SURVOL global surface volume vector. +* DGMESH meshing vector for global geometry. +* DANGLT angles. +* DVNOR ratio of analytic to tracked volume. +* DWGTRK weight of tracking lines. +* DORITR origin of tracking lines. +* +*Parameters: output +* NSLINE number of segments for this track. +* NCOR number of start/end surfaces. +* WEIGHT weight associated with each line. +* NUMERO region/surface identification number +* for segment. +* LENGTH segment length. +* +*References: +* This routine represent a simplified version of NXTTLS where +* the track origin, direction and weights are already known. +* Moreover, instead of computing the track normalization +* fators, one assume that they are available and the +* track are renormalized directly in this module. +* +*---------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPTRK +* INTEGER IPTRK + INTEGER IPRINT,NDIM,NBTDIR,NPOINT,NTRK,ITRAK,MAXMSH, + > NFSUR,NFREG,NUCELL(3),NBUCEL,MXGSUR,MXGREG, + > MAXPIN,LINMAX,ITYPBC + INTEGER IUNFLD(2,NBUCEL),MATALB(-NFSUR:NFREG) + DOUBLE PRECISION SURVOL(-NFSUR:NFREG),DGMESH(-1:MAXMSH,4), + > DANGLT(NDIM,NBTDIR),DVNOR(NFREG) + DOUBLE PRECISION DWGTRK(NBTDIR), + > DORITR(NDIM*(NDIM+1),2*NDIM-3,NBTDIR) + INTEGER NSLINE,NCOR + DOUBLE PRECISION WEIGHT + INTEGER NUMERO(LINMAX) + DOUBLE PRECISION LENGTH(LINMAX) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTTGS') + DOUBLE PRECISION DCUTOF,DZERO,DONE,DTWO + PARAMETER (DCUTOF=1.0D-8,DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Functions +*---- + DOUBLE PRECISION XDRCST,PI + INTEGER NXTLCA,NXTLHA,IRLA +*---- +* Local variables +*---- + INTEGER ITDIR,NPLANE,IPLANE,IPTA2,IPTA3,IDIR,ITST, + > NBCOR(2),NBSINT,ITLOC + INTEGER ITRN,ICEL,ICI,JLINE,IBLIN,IELIN,ISURF, + > IX,IY,IZ,IOX,IOY,IOZ,IOC,LMAXT + DOUBLE PRECISION ANGLES(3,3), + > TRKORI(3),TRKOR2(3),TRKLIM(2), + > CELLPO(3,2),DSTART,DERR + INTEGER ISEG,JSEG,IREG,ILREG,IPRINL,NBREG,IOFF + INTEGER NSDEB,NSFIN + REAL FACSC + INTEGER NICSS,ICISS,ICSR,ICSRR +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ICINT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DLENGT,DCINT +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 200) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + NSLINE=0 + NCOR=0 + ITST=NTRK + ITST=MATALB(0) + FACSC=REAL(SURVOL(0)) + PI=XDRCST('Pi',' ') + LMAXT=4*(NBUCEL+4) + ITST=1 + NPLANE=2*NDIM-3 + IOC=0 +*---- +* Scratch storage allocation +* DLENGT spatial location of each line segment. +* ICINT identification of spatial position for each +* line segment in cell description of geometry. +* DCINT position of each intersection point for each +* line segment in cell description of geometry. +*---- + ALLOCATE(ICINT(0:5,LMAXT)) + ALLOCATE(DLENGT(LINMAX),DCINT(LMAXT)) +*---- +* Identify track direction plane number and point. +* For 3-D: +* ITRAK=(ITDIR-1)*(3*NPOINT**2) +* +(IPLANE-1)*NPOINT**2 +* +(IPA2-1)*NPOINT +* +IPA3 +* For 2-D: +* ITRAK=(ITDIR-1)*(NPOINT) +* +IPA2 +* will be used. +*---- + ITLOC=ITRAK + IF(NDIM .EQ. 3) THEN + IPTA3=MOD(ITLOC-1,NPOINT)+1 + ITLOC=ITLOC/NPOINT + IPTA2=MOD(ITLOC,NPOINT)+1 + ITLOC=ITLOC/NPOINT + IPLANE=MOD(ITLOC,NPLANE)+1 + ITLOC=ITLOC/NPLANE + ITDIR=MOD(ITLOC,NBTDIR)+1 + ELSE + IPTA3=1 + IPTA2=MOD(ITLOC-1,NPOINT)+1 + IPLANE=1 + ITLOC=ITLOC/NPOINT + ITDIR=MOD(ITLOC,NBTDIR)+1 + ENDIF + WEIGHT=DWGTRK(ITDIR) +*---- +* Find planes mormal to selected direction +*---- + ANGLES(:3,:3)=DZERO + DO IDIR=1,NDIM + ANGLES(IDIR,1)=DANGLT(IDIR,ITDIR) + TRKOR2(IDIR)=DORITR(IDIR,IPLANE,ITDIR) + ENDDO + IOFF=NDIM + DO JLINE=1,NDIM + DO IDIR=1,NDIM + ANGLES(IDIR,JLINE)=DORITR(IDIR+IOFF,IPLANE,ITDIR) + ENDDO + IOFF=IOFF+NDIM + ENDDO +*---- +* Position TRKORI with respect to IPTA2 +*---- + DO IDIR=1,NDIM + TRKORI(IDIR)=TRKOR2(IDIR)+DBLE(IPTA2)*ANGLES(IDIR,2) + ENDDO +*---- +* Position TRKORI with respect to IPTA3 +*---- + DO IDIR=1,NDIM + TRKORI(IDIR)=TRKORI(IDIR)+DBLE(IPTA3)*ANGLES(IDIR,3) + ENDDO + IPRINL=IPRINT + IRLA=-1 + IF(ITYPBC .EQ. 0) THEN + IRLA=NXTLCA(IPRINL,ITST ,NDIM ,MAXMSH,LMAXT, + > NUCELL,TRKORI,ANGLES,DGMESH, + > NBCOR ,NBSINT,ICINT ,DCINT) + ELSE IF(ITYPBC .EQ. 1) THEN +*---- +* Annular assembly +*---- + CALL XABORT(NAMSBR//': Circular BC not implemented') + ELSE IF(ITYPBC .EQ. 2) THEN +*---- +* Hexagonal assembly +*---- + IRLA=NXTLHA(IPRINL,ITST ,NDIM ,MAXMSH,LMAXT, + > NUCELL,TRKORI,ANGLES,DGMESH, + > NBCOR ,NBSINT,ICINT ,DCINT) + ENDIF +*---- +* When no external face crossed go to next line +*---- + IF(IRLA .EQ. -1) CALL XABORT(NAMSBR// + >': This type of cell cannot be tracked by NXT:') + IF(IRLA .EQ. 0) GO TO 115 +*---- +* Test for multiple line segments in hexagonal assemblies +* +*---- + NICSS=1 + IF(ITYPBC .EQ. 2) THEN + DO ICI=2,NBSINT + IF(ICINT(0,ICI) .EQ. 0) THEN + NICSS=NICSS+1 + ENDIF + ENDDO + ICSRR=NBCOR(1)+1 + ELSE + ICSRR=NBCOR(1)+1 + ENDIF +*---- +* For each region crossed loop track geometry +* present in this region +*---- + DO ICISS=1,NICSS + ICSR=ICSRR + IF(IPRINL .GE. 500) THEN + WRITE(IOUT,6045) + WRITE(IOUT,6040) ITRAK,ITDIR,IPLANE, + > IPTA2,IPTA3,WEIGHT + WRITE(IOUT,6041) ITRAK,TRKORI + WRITE(IOUT,6042) ITRAK,ANGLES + WRITE(IOUT,6043) ITRAK,DCINT(1) + ELSE IF(IPRINL .GE. 50) THEN + WRITE(IOUT,6040) ITRAK,ITDIR,IPLANE, + > IPTA2,IPTA3,WEIGHT + ENDIF + IBLIN=1 + IELIN=0 + NUMERO(IBLIN)=0 + DLENGT(IBLIN)=DCINT(ICSR-1) + DSTART=DCINT(ICSR-1) + IBLIN=IBLIN+1 + DO ICI=ICSR,NBSINT-NBCOR(2)+1 + ICSRR=ICSRR+1 + IF(ITYPBC .EQ. 0) THEN + IX=ICINT(1,ICI) + IY=ICINT(2,ICI) + IOX=IX + CELLPO(1,2)=DGMESH(IX,1) + CELLPO(1,1)=DGMESH(IX-1,1) + CELLPO(2,2)=DGMESH(IY,2) + CELLPO(2,1)=DGMESH(IY-1,2) + IOY=(IY-1)*NUCELL(1) + IOZ=0 + IF(NDIM .EQ. 3) THEN + IZ=ICINT(3,ICI) + IOZ=(IZ-1)*NUCELL(1)*NUCELL(2) + CELLPO(3,2)=DGMESH(IZ,3) + CELLPO(3,1)=DGMESH(IZ-1,3) + ENDIF + IOC=IOX+IOY+IOZ + ELSE IF(ITYPBC .EQ. 2) THEN + IOC=ICINT(0,ICI+1) +*---- +* For multiple track segment IOC=0 indicates that the current +* segment is completed and that a new track segment should be +* started at ICI+2 +*---- + IF(IOC .EQ. 0) THEN + ICSRR=ICSRR+2 + GO TO 125 + ENDIF + IOC=ICINT(0,ICI) + IX=ICINT(1,ICI) + IY=ICINT(1,ICI) + CELLPO(1,2)=DGMESH(IX,1) + CELLPO(1,1)=DGMESH(IX,1) + CELLPO(2,2)=DGMESH(IY,2) + CELLPO(2,1)=DGMESH(IY,2) + IOZ=0 + IF(NDIM .EQ. 3) THEN + IZ=ICINT(3,ICI) + IOZ=(IZ-1)*NUCELL(1) + CELLPO(3,2)=DGMESH(IZ,3) + CELLPO(3,1)=DGMESH(IZ-1,3) + ENDIF + IOC=IOZ+IX + ENDIF + ICEL=IUNFLD(1,IOC) + ITRN=IUNFLD(2,IOC) + TRKLIM(1)=DSTART + DSTART=DSTART+DCINT(ICI) + TRKLIM(2)=DSTART + IF(ICI .EQ. NBCOR(1)+1) THEN +*---- +* initial surfaces (at TRKLIM(1)) considered +*---- + ISURF=-1 + ELSE IF(ICI .EQ. NBSINT-NBCOR(2)) THEN +*---- +* final surfaces (at TRKLIM(2)) considered +*---- + ISURF=1 + ELSE +*---- +* no surface considered +*---- + ISURF=0 + ENDIF +*---- +* Track turned Cell +*---- + CALL NXTTCR(IPTRK ,IPRINL,ICEL ,ITRN ,ISURF , + > NDIM ,MAXMSH,LINMAX,MXGSUR,MXGREG, + > MAXPIN,CELLPO,TRKLIM,TRKORI,ANGLES, + > IBLIN ,IELIN ,NUMERO,DLENGT) + DERR=MAX(ABS(TRKLIM(1)),ABS(TRKLIM(2))) + DERR=(DLENGT(IELIN)-DSTART)/DERR + IF(DERR .GT. DCUTOF) THEN + WRITE(IOUT,9100) NAMSBR,IELIN, + > DLENGT(IELIN),DSTART,DERR + CALL XABORT(NAMSBR// + >': End of track does not coincide with end of cell') + ENDIF + IBLIN=IELIN+1 + ENDDO + NSLINE=IELIN +*---- +* Compress tracking vector for region with DLENGT=0.0 and +* for successive segments in the same region. +*---- + JSEG=0 + ILREG=-1 + NBREG=0 + DO ISEG=1,NSLINE + IREG=NUMERO(ISEG) + IF(DLENGT(ISEG) .GT. DZERO) THEN + IF(IREG .GT. 0) THEN + IF(IREG .EQ. ILREG) THEN + DLENGT(JSEG)=DLENGT(JSEG)+DLENGT(ISEG) + ELSE + JSEG=JSEG+1 + DLENGT(JSEG)=DLENGT(ISEG) + NUMERO(JSEG)=IREG + ILREG=IREG + ENDIF + ELSE + JSEG=JSEG+1 + DLENGT(JSEG)=DLENGT(ISEG) + NUMERO(JSEG)=IREG + ILREG=-1 + ENDIF + ENDIF + ENDDO + NSLINE=JSEG +*---- +* Add contribution of track to volume integration for this angle +* in this quadrant and compress tracking line by removing +* segments with NUMERO=0. +*---- + JSEG=0 + NSDEB=0 + NSFIN=0 + NBREG=0 + DO ISEG=1,NSLINE + IREG=NUMERO(ISEG) + IF(DLENGT(ISEG) .GT. DZERO) THEN + IF(IREG .GT. 0) THEN + NBREG=NBREG+1 + JSEG=JSEG+1 + LENGTH(JSEG)=DLENGT(ISEG)*DVNOR(IREG) + NUMERO(JSEG)=IREG + ELSE IF(IREG .LT. 0) THEN + IF(NBREG .EQ. 0) THEN + NSDEB=NSDEB+1 + ELSE + NSFIN=NSFIN+1 + ENDIF + JSEG=JSEG+1 + LENGTH(JSEG)=DLENGT(ISEG) + NUMERO(JSEG)=IREG + ENDIF + ENDIF + ENDDO + NSLINE=JSEG + NCOR=MAX(NSDEB,NSFIN) + FACSC=1.0/REAL(NCOR) + IF(NCOR .GT. 1) THEN + IF(NSDEB .EQ. 2*NSFIN) THEN +*---- +* Duplicate final surfaces +* And change their weight +*---- + DO ISEG=NSLINE-NSFIN+1,NSLINE + LENGTH(ISEG)=LENGTH(ISEG)*FACSC + LENGTH(ISEG+NSFIN)=LENGTH(ISEG) + NUMERO(ISEG+NSFIN)=NUMERO(ISEG) + ENDDO + NSLINE=NSLINE+NSFIN + DO ISEG=1,NSDEB + LENGTH(ISEG)=LENGTH(ISEG)*FACSC + ENDDO + ELSE IF(2*NSDEB .EQ. NSFIN) THEN +*---- +* Displace tracks by NSDEB places +* This automatically double the NSDEB first faces. +*---- + DO ISEG=NSLINE,1,-1 + LENGTH(ISEG+NSDEB)=LENGTH(ISEG) + NUMERO(ISEG+NSDEB)=NUMERO(ISEG) + ENDDO + NSLINE=NSLINE+NSDEB +*---- +* Duplicate surface weights +*---- + DO ISEG=NSLINE-NSFIN+1,NSLINE + LENGTH(ISEG)=LENGTH(ISEG)*FACSC + ENDDO + DO ISEG=1,NSFIN + LENGTH(ISEG)=LENGTH(ISEG)*FACSC + ENDDO + ELSE IF(NSDEB .EQ. NSFIN) THEN +*---- +* Duplicate surface weights +*---- + DO ISEG=NSLINE-NSFIN+1,NSLINE + LENGTH(ISEG)=LENGTH(ISEG)*FACSC + ENDDO + DO ISEG=1,NSDEB + LENGTH(ISEG)=LENGTH(ISEG)*FACSC + ENDDO + ELSE + CALL XABORT(NAMSBR// + > ': Number of begin and end surfaces not compatible') + ENDIF + ENDIF + 125 CONTINUE + ENDDO +*---- +* Exit because line is outside circle or sphere surrounding geometry +*---- + 115 CONTINUE +*---- +* Processing finished: +* print track normalization vector. +* and routine closing output header if required +* and return +*---- + IF(IPRINT .GE. 200) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(DCINT,DLENGT) + DEALLOCATE(ICINT) + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6040 FORMAT('Track',I10.10,'={',4(I10,','), + >F15.8,'};') + 6041 FORMAT('Torig',I10.10,'={',2(F15.8,','),F15.8,'};') + 6042 FORMAT('Tdire',I10.10,'={',8(F15.8,','),F15.8,'};') + 6043 FORMAT('Tstrt',I10.10,'={',F15.8,'};') + 6045 FORMAT(1X) + 9100 FORMAT(1X,' ***** Error in ',A6,'***** for line ',I8/ + > 7X,'Positions (current and reference ) =',1P,2D21.14/ + > 7X,'Relative error = ',D21.14) + END diff --git a/Dragon/src/NXTTLC.f b/Dragon/src/NXTTLC.f new file mode 100644 index 0000000..51dc74c --- /dev/null +++ b/Dragon/src/NXTTLC.f @@ -0,0 +1,1046 @@ +*DECK NXTTLC + SUBROUTINE NXTTLC(IPTRK ,IFTEMP,IPRINT,IGTRK ,NDIM ,MAXMSH, + > NFSUR ,NFREG ,NUCELL,NBUCEL,NBANGL, + > LINMAX,MXGSUR,MXGREG,RENO ,NBDR ,ITYPBC, + > IFMT ,MAXPIN,AZMQUA,IPER ,IUNFLD,SURVOL, + > DGMESH,DANGLT,DDENWT,DNSANG,NBSANG,DEPART, + > MAXSUB,MAXSGL,NTLINE,DVNOR ,DSNOR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To generate the cyclic tracking lines (specular tracking) +* for a geometry. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure in +* update or creation mode. +* IFTEMP pointer to a temporary TRACKING file in +* update or creation mode. +* IPRINT print level. +* IGTRK flag to generate the tracking file. In the case where +* IGTRK=1, the tracking is performed and +* used to evaluate the track normalisation factor and the +* tracking file is generated. When IGTRK=0, the tracking is +* still performed and used to evaluate the +* track normalisation factor but the tracking file is not +* generated. +* NDIM problem dimensions. +* MAXMSH maximum number of elements in MESH array. +* NFSUR number of surfaces. +* NFREG number of regions. +* NUCELL number of cell after unfolding in +* $X$, $Y$ and $Z$ directions. +* NBUCEL number of cells in unfolded geometry. +* NBANGL number of angles. +* LINMAX maximum number of segments in a track. +* MXGSUR maximum number of surfaces for any geometry. +* MXGREG maximum number of region for any geometry. +* RENO track normalisation option. A value RENO=-1 implies +* a direction dependent normalization of the tracks +* for the volume while a value RENO=0, implies +* a global normalisation. +* NBDR number of directions for track normalization. +* ITYPBC type of boundary conditions where: +* =0 for geometry with Cartesianb oundaries; +* =1 for geometry with annular boundary; +* =2 for geometry with hexagonal boundary. +* IFMT tracking file format: +* =0 for short file; +* =1 long file required by TLM:. +* MAXPIN maximum number of pins in a cell. +* AZMQUA tracking type. +* IPER cell periodicity factor in each direction. +* IUNFLD description of unfolded geometry. +* SURVOL global surface volume vector. +* DGMESH meshing vector for global geometry. +* DANGLT angles. +* DDENWT angular density for each angle. +* DNSANG spatial density required. +* NBSANG number of segments for each angles. +* DEPART track starting point. +* +*Parameters: output +* MAXSUB maximum number of subtracks in a line. +* MAXSGL maximum number of segments in a line. +* NTLINE total number of lines generated. +* DVNOR ratio of analytic to tracked volume. +* DSNOR ratio of analytic to tracked surface area. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* \\\\ +* Based on the XELTI2 and XELTI3 routines. +* +*---------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPTRK + INTEGER IFTEMP + INTEGER IPRINT,IGTRK,NDIM,MAXMSH,NFSUR,NFREG, + > NUCELL(3),NBUCEL,NBANGL,LINMAX,MXGSUR,MXGREG, + > RENO,NBDR,ITYPBC,IFMT,MAXPIN,AZMQUA,IPER(3), + > MAXSUB,MAXSGL,NTLINE + INTEGER IUNFLD(2,NBUCEL) + DOUBLE PRECISION SURVOL(-NFSUR:NFREG),DGMESH(-1:MAXMSH,4), + > DANGLT(NDIM,NBANGL),DDENWT(NBANGL), + > DNSANG(NBANGL) + INTEGER NBSANG(5,NBANGL) + DOUBLE PRECISION DEPART(NDIM,2,NBANGL) + DOUBLE PRECISION DVNOR(NFREG,NBDR), + > DSNOR(NFSUR) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTTLC') + DOUBLE PRECISION DCUTOF,DZERO,DONE,DTWO + PARAMETER (DCUTOF=1.0D-8,DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Functions +*---- + DOUBLE PRECISION XDRCST,PI + INTEGER NXTLCA,NXTLHA,IRLA +*---- +* Local variables +*---- + INTEGER LMAXT,ITST,IANGL,NGLINE,IDIR,ITXY(3), + > NSCAN,NUMANG,NPOINT,NBPTS,ISCAN, + > ISTART,ISUM,NBCOR(2),IFREF + INTEGER NBSINT,ISDIR,IBLIN,IELIN,ICI,IX,IY,IZ, + > IOX,IOY,IOZ,IOC,ICEL,ITRN,ISURF + DOUBLE PRECISION FACVOL,FACSUR,DWGT,WGTFAC,DAWGT,PMAX,PMIN, + > DSTART,RADT2,ANGT2 + DOUBLE PRECISION ANGLED(3),ANGLES(3),ANGLEN(3),ANGLER(3), + > TRKORI(3),TRKOR2(3),TRKORD(3),TRKORN(3), + > TRKLIM(2),CELLPO(3,2) + DOUBLE PRECISION DERR,DCERR,DSVERR,DMVERR,DAVERR,DSSERR, + > DMSERR,DASERR,VCONTA,VCONT + INTEGER ISEG,JSEG,IREG,ILREG,ISUR,NBVERR,NBSERR, + > NBV0,NBV1,NBS0,IPRINL,IPRINC + INTEGER ISD,NSDEB,ISF,NSFIN,NBREG,ISBL,NTSEG + INTEGER ISINT,NBSEG,IPT,JSDIR,ISDIRX,IPTN + DOUBLE PRECISION DHALF + DOUBLE PRECISION AAA + INTEGER IND,II,JJ + LOGICAL LNEW +*---- +* Allocatable arrays (local) +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NUMERO + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ICINT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: LENGTH,DLENGT, + > DCINT + INTEGER, ALLOCATABLE, DIMENSION(:) :: KANGL + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: TORIG +*---- +* Data +*---- + CHARACTER CDIR(4)*1 + SAVE CDIR + DATA CDIR /'X','Y','Z','R'/ +*---- +* Allocate: temporary storage (local) +* NUMERO region/surface identification number +* for segment. +* LENGTH segment length. +* DLENGT spatial location of each line segment. +* ICINT identification of spatial position for each +* line segment in cell description of geometry. +* DCINT position of each intersection point for each +* line segment in cell description of geometry. +* TORIG track origin +* KANGL angle index (quadrant) +*---- + ALLOCATE(NUMERO(LINMAX),LENGTH(LINMAX),DLENGT(LINMAX), + > ICINT(0:5,2*(NBUCEL+4)),DCINT(2*(NBUCEL+4))) +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 2) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + PI=XDRCST('Pi',' ') + DHALF=DONE/DTWO + MAXSUB=0 + MAXSGL=0 + NTLINE=0 + LMAXT=2*(NBUCEL+4) + ITST=RENO + AAA=AZMQUA + ITST=1 + DVNOR(:NFREG,:NBDR)=DZERO + DSNOR(:NFSUR)=DZERO + FACVOL=DTWO + IF(NDIM .EQ. 2) THEN + FACSUR=DTWO*PI + ELSE + FACSUR=DTWO*DTWO + ENDIF + IF(IPRINT .GT. 1000) THEN + DO IDIR=1,NDIM + WRITE(IOUT,6070) 'DGMESH '//CDIR(IDIR),NUCELL(IDIR) + WRITE(IOUT,6071) (DGMESH(IX,IDIR),IX=1,NUCELL(IDIR)) + ENDDO + ENDIF +*---- +* Loop over directions +*---- + IPRINL=IPRINT + IPRINC=IPRINT + NGLINE=0 + DO IANGL=1,NBANGL + DO IDIR=1,NDIM + ITXY(IDIR)=NBSANG(IDIR,IANGL) + ENDDO + ITXY(3)=ITXY(1)*ITXY(2) + NSCAN=NBSANG(3,IANGL) + NUMANG=NBSANG(4,IANGL) + NPOINT=NBSANG(5,IANGL) + ALLOCATE(TORIG(NDIM,NUMANG),KANGL(NUMANG)) +*---- +* Loop over quadrant if both quadrant not scanned simultaneously +* If NSCAN = 2 0 TO PI/2 AND PI/2 TO PI are scanned simultaneously +* If NSCAN = 1 0 TO PI/2 AND PI/2 TO PI are scanned independently +*---- + NBPTS=NSCAN*NPOINT + DO ISCAN=2,NSCAN,-1 +*---- +* Initialize weight +* Store track direction in ANGLES +* and track starting point in TRKOR2 +*---- + DWGT=DNSANG(IANGL) + DAWGT=2.0D0*DWGT*DDENWT(IANGL) + DO IDIR=1,NDIM + ANGLED(IDIR)=DANGLT(IDIR,IANGL) + TRKOR2(IDIR)=DEPART(IDIR,1,IANGL) + ENDDO + IF(ISCAN .EQ. 1) THEN + IF(ITXY(1) .EQ. 0) THEN + ANGLED(2)=-ANGLED(2) + ELSE IF(ITXY(2) .EQ. 0) THEN + ANGLED(1)=-ANGLED(1) + ENDIF + ENDIF + DO IDIR=1,NDIM + ANGLES(IDIR)=ANGLED(IDIR) + ANGLEN(IDIR)=ANGLED(IDIR) + ANGLER(IDIR)=ANGLED(IDIR) + TRKORD(IDIR)=TRKOR2(IDIR) + TRKORI(IDIR)=TRKORD(IDIR) + TRKORN(IDIR)=TRKORD(IDIR) + ENDDO +*---- +* Loop over points +*---- + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6050) IANGL,ISCAN,ITXY,DWGT, + > (DANGLT(IDIR,IANGL),IDIR=1,NDIM), + > (DEPART(IDIR,1,IANGL),IDIR=1,NDIM) + ENDIF + ISTART=0 + ISUM=ISTART + IFREF=1 + DO IPT=1,NBPTS +*---- +* Find if this track crosses geometry +*---- + IF(ISTART .EQ. 0) THEN + IF(IFREF .EQ. 1) THEN + DO IDIR=1,NDIM + ANGLES(IDIR)=ANGLER(IDIR) + ANGLED(IDIR)=ANGLER(IDIR) + ENDDO + ENDIF + ENDIF + ISINT=1 + DCINT(ISINT)=DZERO + IRLA=-1 + IF(ITYPBC .EQ. 0) THEN +*---- +* Cartesian assembly +*---- + IRLA=NXTLCA(IPRINC,ITST ,NDIM ,MAXMSH,LMAXT, + > NUCELL,TRKORI,ANGLES,DGMESH, + > NBCOR ,NBSINT,ICINT ,DCINT) + ELSE IF(ITYPBC .EQ. 1) THEN +*---- +* Annular assembly +*---- + CALL XABORT(NAMSBR//': Circular BC not implemented') + ELSE IF(ITYPBC .EQ. 2) THEN +*---- +* Hexagonal assembly +*---- + IRLA=NXTLHA(IPRINC,ITST ,NDIM ,MAXMSH,LMAXT, + > NUCELL,TRKORI,ANGLES,DGMESH, + > NBCOR ,NBSINT,ICINT ,DCINT) + ENDIF + IF(IRLA .EQ. -1) CALL XABORT(NAMSBR// + >': This type of cell cannot be tracked by NXT:') +*---- +* When no external face crossed go to next line +*---- + IF(IRLA .EQ. 0) GO TO 105 + ISDIRX=ABS(ICINT(0,1)) + ISDIR=ABS(ICINT(0,NBSINT)) + JSDIR=MOD(ISDIR,2)+1 + IF(ISTART .EQ. 0) THEN +*---- +* Define position of cyclic starting point +*---- + NGLINE=NGLINE+1 + DO IDIR=1,NDIM + TRKORD(IDIR)=TRKORD(IDIR)+DCINT(ISINT)*ANGLES(IDIR) + TRKORI(IDIR)=TRKORD(IDIR) + ENDDO + DO IDIR=1,NBCOR(1) + DCINT(IDIR)=DZERO + ENDDO + IF(ISCAN .EQ. 1 .AND. ITXY(3) .NE. 0) THEN + ANGLED(ISDIRX)=-ANGLED(ISDIRX) + DO IDIR=1,NDIM + ANGLES(IDIR)=ANGLED(IDIR) + ENDDO + IF(ITYPBC .EQ. 0) THEN +*---- +* Cartesian assembly +*---- + IRLA=NXTLCA(IPRINL,ITST ,NDIM ,MAXMSH,LMAXT, + > NUCELL,TRKORI,ANGLES,DGMESH, + > NBCOR ,NBSINT,ICINT ,DCINT) + ELSE IF(ITYPBC .EQ. 1) THEN +*---- +* Annular assembly +*---- + CALL XABORT(NAMSBR//': Circular BC not implemented') + ELSE IF(ITYPBC .EQ. 2) THEN +*---- +* Hexagonal assembly +*---- + IRLA=NXTLHA(IPRINL,ITST ,NDIM ,MAXMSH,LMAXT, + > NUCELL,TRKORI,ANGLES,DGMESH, + > NBCOR ,NBSINT,ICINT ,DCINT) + ELSE + CALL XABORT(NAMSBR// + >': This type of cell cannot be tracked by NXT:') + ENDIF + IF(IRLA .EQ. 0) GO TO 105 + DO IDIR=1,NDIM + TRKORD(IDIR)=TRKORD(IDIR)+DCINT(ISINT)*ANGLES(IDIR) + TRKORI(IDIR)=TRKORD(IDIR) + ENDDO + DO IDIR=1,NBCOR(1) + DCINT(IDIR)=DZERO + ENDDO + ISDIR=ABS(ICINT(0,NBSINT)) + JSDIR=MOD(ISDIR,2)+1 + ENDIF + DO IDIR=1,NDIM + ANGLES(IDIR)=ANGLED(IDIR) + ANGLEN(IDIR)=ANGLED(IDIR) + ENDDO + ENDIF +*---- +* For track crossing geometry, end find surface direction +* and end of track location +*---- + DO IDIR=1,NDIM + AAA=DZERO + DO ISINT=NBCOR(1),NBSINT-NBCOR(2)+1 + AAA=AAA+DCINT(ISINT)*ANGLES(IDIR) + ENDDO + TRKORN(IDIR)=TRKORI(IDIR)+AAA + TORIG(IDIR,ISTART+1)=TRKORI(IDIR) + ENDDO + KANGL(ISTART+1)=0 + DO II=1,4*NBANGL + IF((ANGLEN(1).EQ.DANGLT(1,II)).AND. + > (ANGLEN(2).EQ.DANGLT(2,II))) THEN + KANGL(ISTART+1)=II + GO TO 10 + ENDIF + ENDDO + CALL XABORT(NAMSBR// + >': Unable to find an angular index for a subtrack') + 10 CONTINUE + IPRINL=IPRINT +* IF(NTLINE+1 .EQ. 1411 +* > .OR. NTLINE+1 .EQ. 1414 +* > .OR. NTLINE+1 .EQ. 1415 +* > ) IPRINL=IPRINT+4000 + IF(ISTART.EQ.0) THEN + IF(IPRINL .GE. 500) THEN + WRITE(IOUT,6051) NTLINE+1 + ENDIF + ENDIF + IF(IPRINL .GE. 500) THEN + WRITE(IOUT,6052) TRKORI,ANGLEN + ENDIF +*---- +* Find location with respect to end surfaces positions +*---- + PMAX=ABS(TRKORN(ISDIR)-DGMESH(NUCELL(ISDIR),ISDIR)) + PMIN=ABS(TRKORN(ISDIR)-DGMESH(0,ISDIR)) + IF(IPER(ISDIR) .EQ. 1) THEN +*---- +* Translate next initial starting point if possible +*---- + IF(PMAX .LT. DCUTOF) THEN + TRKORN(ISDIR)=DGMESH(0,ISDIR) + ELSE IF(PMIN .LT. DCUTOF) THEN + TRKORN(ISDIR)=DGMESH(NUCELL(ISDIR),ISDIR) + ELSE + WRITE(IOUT,9100) NAMSBR,ISDIR,NUCELL(ISDIR), + > TRKORI(ISDIR),DGMESH(NUCELL(ISDIR),ISDIR),PMAX + CALL XABORT(NAMSBR// + > ': Translation before cell limit attempted') + ENDIF + ELSE +*---- +* Change track direction upon reflexion if possible +*---- + IF(PMAX .GT. DCUTOF .AND. PMIN .GT. DCUTOF) THEN + CALL XABORT(NAMSBR// + > ': Reflexion before cell limit attempted') + ENDIF + ANGLEN(ISDIR)=-ANGLEN(ISDIR) + ENDIF +*---- +* Track seems ok, locate track segments for geometry +*---- + IF(ISTART .EQ. 0) THEN +*---- +* For first series of line segments initialize track information +*---- + IBLIN=1 + IELIN=0 + ELSE +*---- +* Next series of line segments, add at the end of +* current line +*---- + IBLIN=IELIN+1 + DLENGT(IBLIN)=DZERO + ENDIF + ISTART=ISTART+1 + ISUM=ISUM+1 + NUMERO(IBLIN)=0 + DLENGT(IBLIN)=DCINT(1) + DSTART=DCINT(1) + IBLIN=IBLIN+1 +*---- +* Find line segments for this track series +*---- + DO ICI=NBCOR(1)+1,NBSINT-NBCOR(2)+1 + IX=ICINT(1,ICI) + IY=ICINT(2,ICI) + IOX=IX + CELLPO(1,2)=DGMESH(IX,1) + CELLPO(1,1)=DGMESH(IX-1,1) + CELLPO(2,2)=DGMESH(IY,2) + CELLPO(2,1)=DGMESH(IY-1,2) + IOY=(IY-1)*NUCELL(1) + IOZ=0 + IF(NDIM .EQ. 3) THEN + IZ=ICINT(3,ICI) + IOZ=(IZ-1)*NUCELL(1)*NUCELL(2) + CELLPO(3,2)=DGMESH(IZ,3) + CELLPO(3,1)=DGMESH(IZ-1,3) + ENDIF + IOC=IOX+IOY+IOZ + ICEL=IUNFLD(1,IOC) + ITRN=IUNFLD(2,IOC) + TRKLIM(1)=DSTART + DSTART=DSTART+DCINT(ICI) + TRKLIM(2)=DSTART + IF(ICI .EQ. NBCOR(1)+1) THEN +*---- +* initial surfaces (at TRKLIM(1)) considered +*---- + ISURF=-1 + ELSE IF(ICI .EQ. NBSINT-NBCOR(2)) THEN +*---- +* final surfaces (at TRKLIM(2)) considered +*---- + ISURF=1 + ELSE +*---- +* no surface considered +*---- + ISURF=0 + ENDIF +*---- +* Track turned Cell +*---- + CALL NXTTCR(IPTRK ,IPRINL,ICEL ,ITRN ,ISURF , + > NDIM ,MAXMSH,LINMAX,MXGSUR,MXGREG, + > MAXPIN,CELLPO,TRKLIM,TRKORI,ANGLES, + > IBLIN ,IELIN ,NUMERO,DLENGT) + IPRINL=IPRINT + AAA=MAX(ABS(TRKLIM(1)),ABS(TRKLIM(2))) + DERR=ABS(DLENGT(IELIN)-DSTART) + IF(AAA .GT. DONE) DERR=DERR/AAA + IF(DERR .GT. DCUTOF) THEN + IF(AAA .GT. DONE) THEN + WRITE(IOUT,9101) NAMSBR,NGLINE, + > DLENGT(IELIN),DSTART,DERR + ELSE + WRITE(IOUT,9102) NAMSBR,NGLINE, + > DLENGT(IELIN),DSTART,DERR + ENDIF + CALL XABORT(NAMSBR// + >': End of track does not coincide with end of cell') + ENDIF + IBLIN=IELIN+1 +*---- +* End of tracking for this line segment +*---- + ENDDO + IPRINL=IPRINT +*---- +* This series of line segments completed +* Test if the cycle is back to starting point +*---- + RADT2=DZERO + ANGT2=DZERO + DO IDIR=1,NDIM + RADT2=RADT2+(TRKORD(IDIR)-TRKORN(IDIR))**2 + ANGT2=ANGT2+(ANGLED(IDIR)-ANGLEN(IDIR))**2 + ENDDO + RADT2=SQRT(RADT2) + ANGT2=SQRT(ANGT2) + IF(RADT2 .GT. DCUTOF .OR. ANGT2 .GT. DCUTOF) THEN +*---- +* Cycle is incomplete +* Check if period is higher than predicted +* reset starting point and direction +*---- + IF(ISTART .GE. NUMANG) CALL XABORT(NAMSBR// + > ': Cyclic period is too long') + IF(IPRINL .GE. 500) THEN + IF(IPT .EQ. NBPTS) WRITE(IOUT,6064) + ENDIF + DO IDIR=1,NDIM + TRKORI(IDIR)=TRKORN(IDIR) + ANGLES(IDIR)=ANGLEN(IDIR) + ENDDO + ELSE +*---- +* Cycle is complete +* Check if period is ok +*---- + NTLINE=NTLINE+1 +*---- +* Process tracking line and save +*---- + NBSEG=IELIN +*---- +* Compress tracking vector for region with DLENGT=0.0, +* for multiple surface of intersection and +* for successive segments in the same region. +*---- + ISD=-1 + JSEG=0 + ILREG=-1 + DO ISEG=1,NBSEG + IREG=NUMERO(ISEG) + IF(DLENGT(ISEG) .GT. DZERO) THEN + IF(IREG .GT. 0) THEN + IF(IREG .EQ. ILREG) THEN + DLENGT(JSEG)=DLENGT(JSEG)+DLENGT(ISEG) + ELSE + JSEG=JSEG+1 + DLENGT(JSEG)=DLENGT(ISEG) + NUMERO(JSEG)=IREG + ILREG=IREG + ENDIF + ISD=IREG + ELSE + ISF=NUMERO(ISEG+1) + IF(ISD .LT. 0) THEN + IF(ISF .GT. 0) THEN + JSEG=JSEG+1 + DLENGT(JSEG)=DLENGT(ISEG)*DHALF + NUMERO(JSEG)=IREG + ILREG=-1 + ENDIF + ELSE + JSEG=JSEG+1 + DLENGT(JSEG)=DLENGT(ISEG)*DHALF + NUMERO(JSEG)=IREG + ILREG=-1 + ENDIF + ISD=IREG + ENDIF + ENDIF + ENDDO + NBSEG=JSEG +*---- +* Add contribution of track to volume integration for this angle +* in this quadrant and compress tracking line by removing +* segments with NUMERO=0. +*---- + JSEG=0 + NSDEB=0 + NBREG=0 + IND=0 + LNEW=.TRUE. + DO ISEG=1,NBSEG + IREG=NUMERO(ISEG) + IF(DLENGT(ISEG) .GT. DZERO) THEN + IF(IREG .GT. 0) THEN + IF(LNEW) THEN + IND=IND+1 + IF(IND.GT.ISTART) CALL XABORT(NAMSBR// + > ': ISTART overflow') + LNEW=.FALSE. + ENDIF + NBREG=NBREG+1 + VCONT=DLENGT(ISEG)*DWGT*FACVOL + DVNOR(IREG,1)=DVNOR(IREG,1)+VCONT + IF(NBDR .GT. 1) THEN + II=KANGL(IND) + IF(II .GT. 2*NBANGL) THEN + JJ=II-2*NBANGL + ELSE + JJ=II+2*NBANGL + ENDIF + IF(DANGLT(1,II).EQ.DZERO) THEN + VCONTA=DHALF*DLENGT(ISEG)*DAWGT + ELSE + VCONTA=DLENGT(ISEG)*DAWGT + ENDIF + DVNOR(IREG,II+1)=DVNOR(IREG,II+1)+VCONTA + DVNOR(IREG,JJ+1)=DVNOR(IREG,JJ+1)+VCONTA + ENDIF + JSEG=JSEG+1 + LENGTH(JSEG)=DLENGT(ISEG) + NUMERO(JSEG)=IREG + ELSE IF(IREG .LT. 0) THEN + LNEW=.TRUE. + IF(NBREG .EQ. 0) THEN + NSDEB=NSDEB+1 + ENDIF + DSNOR(-IREG)=DSNOR(-IREG)+DLENGT(ISEG)*DWGT*FACSUR + JSEG=JSEG+1 + LENGTH(JSEG)=DLENGT(ISEG) + NUMERO(JSEG)=IREG + ENDIF + ENDIF + ENDDO + NBSEG=JSEG + NSFIN=0 + DO ISEG=NBSEG,1,-1 + IREG=NUMERO(ISEG) + IF(DLENGT(ISEG) .GT. DZERO) THEN + IF(IREG .GT. 0) THEN + GO TO 115 + ELSE IF(IREG .LT. 0) THEN + NSFIN=NSFIN+1 + ENDIF + ENDIF + ENDDO + 115 CONTINUE +*---- +* Matlab commands to create a simili-TLM plot +*---- + IF(IPRINL .GE. 2000) THEN + WRITE(IOUT,6064) + WRITE(IOUT,6063) NTLINE,'LineReg' + WRITE(IOUT,6061) (NUMERO(ISEG),ISEG=1,NBSEG) + WRITE(IOUT,6064) + WRITE(IOUT,6063) NTLINE,'LinePos' + WRITE(IOUT,6062) (LENGTH(ISEG),ISEG=1,NBSEG) + WRITE(IOUT,6064) + WRITE(IOUT,6065) + ENDIF +*---- +* Store line on temporary tracking file if required +*---- + WGTFAC=DONE/DBLE(NSDEB*NSFIN) + MAXSUB=MAX(MAXSUB,ISTART) + MAXSGL=MAX(MAXSGL,NBSEG) + NTSEG=NBSEG-NSDEB-NSFIN+2 + ISBL=0 + DO ISD=1,NSDEB + DO ISF=0,NSFIN-1 + ISBL=ISBL+1 + IF(NSDEB*NSFIN .GT. 1 .AND. IPRINL .GE. 1000) + > WRITE(IOUT,6026) NTLINE-1+ISBL,NTLINE,ISBL + IF(IGTRK .EQ. 1) THEN + IF(IFMT == 1) THEN + WRITE(IFTEMP) ISTART,NTSEG,DWGT*WGTFAC, + > (KANGL(II),II=1,ISTART), + > NUMERO(ISD), + > (NUMERO(ISEG),ISEG=NSDEB+1,NBSEG-NSFIN), + > NUMERO(NBSEG-ISF), + > LENGTH(ISD), + > (LENGTH(ISEG),ISEG=NSDEB+1,NBSEG-NSFIN), + > LENGTH(NBSEG-ISF), + > NTLINE,1,1,1, + > ((TORIG(IDIR,II),IDIR=1,NDIM),II=1,ISTART) + ELSE + WRITE(IFTEMP) ISTART,NTSEG,DWGT*WGTFAC, + > (KANGL(II),II=1,ISTART), + > NUMERO(ISD), + > (NUMERO(ISEG),ISEG=NSDEB+1,NBSEG-NSFIN), + > NUMERO(NBSEG-ISF), + > LENGTH(ISD), + > (LENGTH(ISEG),ISEG=NSDEB+1,NBSEG-NSFIN), + > LENGTH(NBSEG-ISF) + ENDIF + ENDIF + ENDDO + ENDDO + IF(ISBL .EQ. 0) THEN + WRITE(IOUT,6027) NTLINE,IANGL,NBSEG, + > NSDEB,NSFIN,NBREG, + > NUMERO(1),DLENGT(1), + > NUMERO(NBSEG),DLENGT(NBSEG) + ISBL=1 + IF(IFMT == 1) THEN + WRITE(IFTEMP) ISTART,NTSEG,DWGT*WGTFAC, + > (KANGL(II),II=1,ISTART), + > NUMERO(1), + > (NUMERO(ISEG),ISEG=NSDEB+1,NBSEG-NSFIN), + > NUMERO(NBSEG), + > LENGTH(1), + > (LENGTH(ISEG),ISEG=NSDEB+1,NBSEG-NSFIN), + > LENGTH(NBSEG), + > NTLINE,1,1,1, + > ((TORIG(IDIR,II),IDIR=1,NDIM),II=1,ISTART) + ELSE + WRITE(IFTEMP) ISTART,NTSEG,DWGT*WGTFAC, + > (KANGL(II),II=1,ISTART), + > NUMERO(1), + > (NUMERO(ISEG),ISEG=NSDEB+1,NBSEG-NSFIN), + > NUMERO(NBSEG), + > LENGTH(1), + > (LENGTH(ISEG),ISEG=NSDEB+1,NBSEG-NSFIN), + > LENGTH(NBSEG) + ENDIF + ENDIF + NTLINE=NTLINE-1+ISBL + IF(ISTART .EQ. NUMANG) THEN +*---- +* Displace line to next starting point +*---- + DO IDIR=1,NDIM + ANGLES(IDIR)=ANGLED(IDIR) + ANGLEN(IDIR)=ANGLED(IDIR) + TRKOR2(IDIR)=TRKOR2(IDIR)+DEPART(IDIR,2,IANGL) + TRKORD(IDIR)=TRKOR2(IDIR) + TRKORI(IDIR)=TRKORD(IDIR) + TRKORN(IDIR)=TRKORD(IDIR) + ENDDO + ELSE + IF(NSCAN .EQ. 2) THEN + IF(IPER(ISDIR) .EQ. 1) THEN + IF(IFREF .EQ. -1) THEN + IFREF=1 + DO IDIR=1,NDIM + ANGLES(IDIR)=ANGLED(IDIR) + ANGLEN(IDIR)=ANGLED(IDIR) + TRKOR2(IDIR)=TRKOR2(IDIR)+DEPART(IDIR,2,IANGL) + TRKORD(IDIR)=TRKOR2(IDIR) + TRKORI(IDIR)=TRKORD(IDIR) + TRKORN(IDIR)=TRKORD(IDIR) + ENDDO + ELSE + ANGLED(ISDIR)=-ANGLED(ISDIR) + IFREF=-1 + ENDIF + ELSE IF(IPER(JSDIR) .EQ. 1) THEN + IF(IFREF .EQ. 1) THEN + DO IPTN=1,NBPTS + DO IDIR=1,NDIM + TRKORI(IDIR)=TRKORN(IDIR) + ANGLES(IDIR)=ANGLEN(IDIR) + ENDDO +*---- +* Find next surface intersection track crosses geometry +*---- + IF(ITYPBC .EQ. 0) THEN +*---- +* Cartesian assembly +*---- + IRLA=NXTLCA(IPRINL,ITST ,NDIM ,MAXMSH,LMAXT, + > NUCELL,TRKORI,ANGLES,DGMESH, + > NBCOR ,NBSINT,ICINT ,DCINT) + ELSE IF(ITYPBC .EQ. 1) THEN + CALL XABORT(NAMSBR// + > ': Circular BC not implemented') + ELSE IF(ITYPBC .EQ. 2) THEN +*---- +* Hexagonal assembly +*---- + IRLA=NXTLHA(IPRINL,ITST ,NDIM ,MAXMSH,LMAXT, + > NUCELL,TRKORI,ANGLES,DGMESH, + > NBCOR ,NBSINT,ICINT ,DCINT) + ELSE + CALL XABORT(NAMSBR// + >': This type of cell cannot be tracked by NXT:') + ENDIF +*---- +* Define position of cyclic starting point +*---- + DO IDIR=1,NDIM + AAA=DZERO + DO ISINT=NBCOR(1),NBSINT-NBCOR(2)+1 + AAA=AAA+DCINT(ISINT)*ANGLES(IDIR) + ENDDO + TRKORN(IDIR)=TRKORI(IDIR)+AAA + ENDDO + ISDIRX=ABS(ICINT(0,NBSINT)) + IF(ISDIRX .EQ. JSDIR) THEN + DO IDIR=1,NDIM + ANGLED(IDIR)=ANGLES(IDIR) + ENDDO + ANGLED(JSDIR)=-ANGLED(JSDIR) + GO TO 125 + ENDIF + IF(IPER(ISDIRX) .EQ. 1) THEN + ANGLEN(ISDIRX)=-ANGLEN(ISDIRX) + ENDIF + ENDDO + 125 CONTINUE + IFREF=-1 + ELSE + DO IDIR=1,NDIM + ANGLES(IDIR)=ANGLED(IDIR) + ANGLEN(IDIR)=ANGLED(IDIR) + TRKOR2(IDIR)=TRKOR2(IDIR)+DEPART(IDIR,2,IANGL) + TRKORD(IDIR)=TRKOR2(IDIR) + TRKORI(IDIR)=TRKORD(IDIR) + TRKORN(IDIR)=TRKORD(IDIR) + ENDDO + IFREF=1 + ENDIF + ENDIF + ENDIF + DO IDIR=1,NDIM + ANGLES(IDIR)=ANGLED(IDIR) + ANGLEN(IDIR)=ANGLED(IDIR) + TRKORD(IDIR)=TRKORN(IDIR) + TRKORI(IDIR)=TRKORD(IDIR) + TRKORN(IDIR)=TRKORD(IDIR) + ENDDO + ENDIF + ISTART=0 + ENDIF +*---- +* End of tracking for this direction +*---- + 105 CONTINUE + ENDDO +*---- +* End of tracking for this set of quadrant +*---- + ENDDO + DEALLOCATE(KANGL,TORIG) +*---- +* End of tracking for this set of angles +*---- + ENDDO +*---- +* Compute DVNOR and DSNOR by comparing ratio of analytical +* to numerically integrated volume or surfaces. +*---- + NBVERR=0 + DSVERR=DZERO + DMVERR=DZERO + DAVERR=DZERO + NBV0=0 + NBV1=0 + DO IREG=1,NFREG + IF(IPRINT .GE. 20 ) THEN + WRITE(IOUT,6030) IREG,SURVOL(IREG),DVNOR(IREG,1) + ENDIF + DO IDIR=1,NBDR + IF(DVNOR(IREG,IDIR) .EQ. DZERO) THEN + IF(IPRINT .GE. 10) THEN + IANGL=NBDR-1 + WRITE(IOUT,9000) NAMSBR,IREG,IDIR + ENDIF + DVNOR(IREG,IDIR)=DONE + IF(IDIR .EQ. 1) THEN + NBV0=NBV0+1 + ELSE + NBV1=NBV1+1 + ENDIF + ELSE + DVNOR(IREG,IDIR)=SURVOL(IREG)/DVNOR(IREG,IDIR) + IF(IDIR .EQ. 1) THEN + NBVERR=NBVERR+1 + ENDIF + ENDIF + ENDDO + DCERR=100.0D0*(DONE-DVNOR(IREG,1)) + DMVERR=MAX(DMVERR,ABS(DCERR)) + DSVERR=DSVERR+DCERR*DCERR + DAVERR=DAVERR+DCERR + ENDDO + IF(NBV0 .GT. 0) THEN + WRITE(IOUT,9002) NAMSBR + ENDIF + IF(NBV1 .GT. 0) THEN + WRITE(IOUT,9005) NAMSBR + ENDIF + DSVERR=SQRT(DSVERR/DBLE(NBVERR)) + DAVERR=DAVERR/DBLE(NBVERR) + NBSERR=0 + DSSERR=DZERO + DMSERR=DZERO + DASERR=DZERO + NBS0=0 + DO ISUR=1,NFSUR + IF(IPRINT .GE. 20 ) THEN + WRITE(IOUT,6031) ISUR, + > SURVOL(-ISUR),DSNOR(ISUR) + ENDIF + IF(DSNOR(ISUR) .EQ. DZERO) THEN + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,9001) NAMSBR,-ISUR + ENDIF + NBS0=NBS0+1 + DSNOR(ISUR)=DONE + ELSE + DSNOR(ISUR)=SURVOL(-ISUR) + > /DSNOR(ISUR) + NBSERR=NBSERR+1 + ENDIF + DCERR=100.0D0*(DONE-DSNOR(ISUR)) + DMSERR=MAX(DMSERR,ABS(DCERR)) + DSSERR=DSSERR+DCERR*DCERR + DASERR=DASERR+DCERR + ENDDO + IF(NBS0 .GT. 0) THEN + WRITE(IOUT,9003) NAMSBR,NBS0 + ENDIF + DSSERR=SQRT(DSSERR/DBLE(NBSERR)) + DASERR=DASERR/DBLE(NBSERR) +*---- +* Processing finished: +* print track normalization vector. +* and routine closing output header if required +* and return +*---- + IF(ABS(IPRINT) .GE. 1) THEN + WRITE(IOUT,6005) DSVERR,DMVERR,DAVERR + IF(IPRINT .GE. 10) THEN + DO IREG=1,NFREG + WRITE(IOUT,6010) IREG,SURVOL(IREG) + WRITE(IOUT,6012) DVNOR(IREG,1), + > 100.0D0*(DONE-DVNOR(IREG,1)) + ENDDO + ENDIF + WRITE(IOUT,6006) DSSERR,DMSERR,DASERR + IF(IPRINT .GE. 10) THEN + DO ISUR=1,NFSUR + WRITE(IOUT,6011) -ISUR,SURVOL(-ISUR) + WRITE(IOUT,6012) DSNOR(ISUR), + > 100.0D0*(DONE-DSNOR(ISUR)) + ENDDO + ENDIF + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* Save track normalisation vector +*---- + IF(MAXSGL .EQ. 0) THEN + WRITE(IOUT,9004) NAMSBR + MAXSGL=LINMAX + ENDIF +*---- +* Deallocate temporary records +*---- + DEALLOCATE(DCINT,ICINT,DLENGT,LENGTH,NUMERO) + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6005 FORMAT(' Global RMS, maximum and average errors (%) ', + > 'on region volumes :',3(2X,F10.5)) + 6006 FORMAT(' Global RMS, maximum and average errors (%) ', + > 'on surface areas :',3(2X,F10.5)) + 6010 FORMAT(' Normalisation factors and relative errors (%) ', + > 'for region ',I8,' with volume ',F19.10) + 6011 FORMAT(' Normalisation factors and relative error (%) ', + > 'for surface ',I8,' with area ',F19.10) + 6012 FORMAT((2X,F15.10,2X,F10.5)) + 6026 FORMAT('Line',I10.10,'={',I10,',',I10,'};') + 6027 FORMAT('Problem with Line',I10.10,'={',5(I10,','), + > I10,',',F18.10,',',I10,',',F18.10,'};') + 6030 FORMAT(' Normalization volumes =',I10,1P,2D20.10) + 6031 FORMAT(' Normalization surfaces =',I10,1P,2D20.10) + 6050 FORMAT(' Direction = ',I5,2X,'Scan =',4I5,2x,'Weight =',F20.15/ + >' Directions and starting point =',6F20.15) + 6051 FORMAT('% Torig',I10.10,/'Torig=[') + 6052 FORMAT(9F15.8) + 6061 FORMAT(I10) + 6062 FORMAT(F18.10) + 6063 FORMAT('% ',I10.10,/A7,'=[') + 6064 FORMAT(18X,'];') + 6065 FORMAT( + >'xcol=jet( 2);'/ + >'lls=length(Torig);'/'lli=length(LinePos);'/ + >'is=-1;'/'nums=0;'/ + >'for i=1:lli'/' if LineReg(i) < 0'/' if is == -1'/ + >' nums=nums+1;'/' is=0;'/ + >' xi=Torig(nums,1);'/' yi=Torig(nums,2);'/ + >' tx=Torig(nums,4);'/' ty=Torig(nums,5);'/ + >' elseif is == 0'/' is=-1;'/' end'/' else'/ + >' xf=xi+tx*LinePos(i);'/' yf=yi+ty*LinePos(i);'/ + >' xxx=line([xi,xf],[yi,yf]);'/ + >' xi=xf;'/' yi=yf;'/' reg=LineReg(i);'/ + >' set(xxx,''Color'',[xcol(reg,:)]);'/ + >' end'/'end'/'clear Torig LinePosLineReg'/'pause ;') + 6070 FORMAT(1X,A8,5X,I10) + 6071 FORMAT(5F18.10) + 9000 FORMAT(1X,'***** Warning in ',A6,'*****'/ + > 7X,'For region ',I8, + > 1X,'no crossing by angle ',I8) + 9001 FORMAT(1X,'***** Warning in ',A6,'*****'/ + > 7X,'For surface ',I8, + > 1X,'no crossing by any angle ') + 9002 FORMAT(1X,'***** Warning in ',A6,'*****'/ + > 7X,' regions not tracked for any direction ') + 9003 FORMAT(1X,' ***** Warning in ',A6,'*****'/ + > 7X,I8,' surfaces not tracked for direction ',I8) + 9004 FORMAT(1X,' ***** Warning in ',A6,'*****'/ + > 7X,' no line segments detected in tracking ') + 9005 FORMAT(1X,'***** Warning in ',A6,'*****'/ + > 7X,' regions not tracked for some directions') + 9100 FORMAT(1X,' ***** Error in ',A6,'***** for line ',2I10/ + > 3F20.15) + 9101 FORMAT(1X,' ***** Error in ',A6,'***** for line ',I8/ + > 7X,'Positions (current and reference ) =',1P,2D21.14/ + > 7X,'Relative error = ',D21.14) + 9102 FORMAT(1X,' ***** Error in ',A6,'***** for line ',I8/ + > 7X,'Positions (current and reference ) =',1P,2D20.12/ + > 7X,'Absolute error = ',D21.14) + END diff --git a/Dragon/src/NXTTLO.f b/Dragon/src/NXTTLO.f new file mode 100644 index 0000000..5991936 --- /dev/null +++ b/Dragon/src/NXTTLO.f @@ -0,0 +1,147 @@ +*DECK NXTTLO + SUBROUTINE NXTTLO(IPRINT,MXMESH, + > MESH ,DMESH ,POSTRI) +* +*---------- +* +*Purpose: +* Locate triangles positions for HEXT, HEXTZ, HEXTCEL and HEXTCELZ. +* +*Copyright: +* Copyright (C) 2013 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau. +* +*Parameters: input +* IPRINT print level. +* MXMESH maximum number of spatial subdivision in +* $X$, $Y$ and $Z$. +* MESH effective number of spatial subdivision in +* each direction ($X$, $Y$ and $Z$). +* DMESH spatial description of the Cartesian geometry. +* POSTRI triangle position: +* POSTRI(1,*,*,*) is X position; +* POSTRI(2,*,*,*) is Y position; +* POSTRI(*,1,*,*) is location of first corner; +* POSTRI(*,2,*,*) is location of second corner; +* POSTRI(*,3,*,*) is location of third corner; +* POSTRI(*,*,i,j) is location of triangle i in cector j. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,MXMESH + INTEGER MESH(4) + DOUBLE PRECISION DMESH(-1:MXMESH,4) + DOUBLE PRECISION POSTRI(2,3,MXMESH*MXMESH,6) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTTLO') + DOUBLE PRECISION DZERO,DHALF,DSQ3O2 + PARAMETER (DZERO=0.0D0,DHALF=0.5D0, + > DSQ3O2=0.86602540378444D0) +*---- +* Local variables +*---- + INTEGER NX,IREG,IX,IR,ISECT,ITRI + DOUBLE PRECISION SIDET,SIDEL,SIDEH, + > POSCX,POSCXD,POSCY,POSCYD +*---- +* Initialize POSTRI and get triangle side +*---- + IF(IPRINT .GE. 500) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + POSTRI(:2,:3,:MXMESH*MXMESH,:6)=DZERO + NX=MESH(1) + IF(NX .EQ. 1) THEN + SIDET=DMESH(1,1)-DMESH(0,1) + ELSE + SIDET=DMESH(2,1)-DMESH(1,1) + ENDIF + SIDEL=SIDET/DSQ3O2 + SIDEH=DHALF*SIDEL +*---- +* 1- First sector +*---- + IREG=0 + POSCXD=DZERO + POSCYD=SIDEH + DO IX=1,NX +*---- +* Loop over right triangles on the line +*---- + POSCX=POSCXD + POSCY=POSCYD + DO IR=1,IX-1 + IREG=IREG+1 + POSTRI(1,1,IREG,1)=POSCX+SIDET + POSTRI(2,1,IREG,1)=POSCY + POSTRI(1,2,IREG,1)=POSCXD + POSTRI(2,2,IREG,1)=POSCY+SIDEH + POSTRI(1,3,IREG,1)=POSCXD + POSTRI(2,3,IREG,1)=POSCY-SIDEH + POSCY=POSCY+SIDEL + ENDDO +*---- +* Loop over left triangles on the line +*---- + POSCYD=POSCYD-SIDEH + POSCX=POSCXD + POSCY=POSCYD + DO IR=1,IX + IREG=IREG+1 + POSTRI(1,1,IREG,1)=POSCX + POSTRI(2,1,IREG,1)=POSCY + POSTRI(1,2,IREG,1)=POSCX+SIDET + POSTRI(2,2,IREG,1)=POSCY-SIDEH + POSTRI(1,3,IREG,1)=POSCX+SIDET + POSTRI(2,3,IREG,1)=POSCY+SIDEH + POSCY=POSCY+SIDEL + ENDDO + POSCXD=POSCXD+SIDET + ENDDO +*---- +* Five other sectors are just Pi/3 rotations of first sectors +* triangles +*---- + DO ISECT=2,6 + DO IR=1,NX*NX + DO ITRI=1,3 + POSTRI(1,ITRI,IR,ISECT)=DHALF*POSTRI(1,ITRI,IR,ISECT-1) + > -DSQ3O2*POSTRI(2,ITRI,IR,ISECT-1) + POSTRI(2,ITRI,IR,ISECT)=DSQ3O2*POSTRI(1,ITRI,IR,ISECT-1) + > +DHALF*POSTRI(2,ITRI,IR,ISECT-1) + ENDDO + ENDDO + ENDDO + IF(IPRINT .GE. 500) THEN + WRITE(IOUT,6020) + DO ISECT=1,6 + DO IR=1,NX*NX + WRITE(IOUT,6021) ISECT,IR, + > (POSTRI(1,ITRI,IR,ISECT),POSTRI(2,ITRI,IR,ISECT),ITRI=1,3) + ENDDO + ENDDO + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6020 FORMAT('X-Y location of triangle corners') + 6021 FORMAT(2I5,6F20.10) + END diff --git a/Dragon/src/NXTTLS.f b/Dragon/src/NXTTLS.f new file mode 100644 index 0000000..8613301 --- /dev/null +++ b/Dragon/src/NXTTLS.f @@ -0,0 +1,901 @@ +*DECK NXTTLS + SUBROUTINE NXTTLS(IPTRK ,IFTEMP,IPRINT,IGTRK ,NDIM ,MAXMSH, + > NFSUR ,NFREG ,NUCELL,NBUCEL,NBANGL,NQUAD , + > NPLANE,NPOINT,LINMAX,MXGSUR,MXGREG,RENO , + > MAXPIN,NBTDIR,NBDR ,ITYPBC,IFMT , + > RCUTOF,SPACLN,WEIGHT,RADIUS,CENTER, + > IUNFLD,SURVOL,DGMESH,DANGLT,DDENWT, + > MAXSGL,NTLINE,DVNOR ,DSNOR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To generate the standard tracking lines (isotropic tracking) +* for a geometry. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure in +* update or creation mode. +* IFTEMP pointer to a temporary TRACKING data structure in +* update or creation mode. +* IPRINT print level. +* IGTRK flag to generate the tracking file. In the case where +* IGTRK=1, the tracking is performed and +* used to evaluate the track normalisation factor and the +* tracking file is generated. When IGTRK=0, the tracking is +* still performed and used to evaluate the +* track normalisation factor but the tracking file is not +* generated. +* NDIM problem dimensions. +* MAXMSH maximum number of elements in MESH array. +* NFSUR number of surfaces. +* NFREG number of regions. +* NUCELL number of cell after unfolding in +* $X$, $Y$ and $Z$ directions. +* NBUCEL number of cells in unfolded geometry. +* NBANGL number of angles. +* NQUAD number of quadrant (in 3-D) and quarter (in 2-D). +* NPLANE number of normal planes considered. +* NPOINT number of integration points along each axis +* in a plane mormal to track direction. +* LINMAX maximum number of segments in a track. +* MXGSUR maximum number of surfaces for any geometry. +* MXGREG maximum number of region for any geometry. +* RENO track normalisation option. A value RENO=-1 implies +* a direction dependent normalization of the tracks +* for the volume while a value RENO=0, implies +* a global normalisation. +* MAXPIN maximum number of pins in a cell. +* NBTDIR number of tracks directions considered. +* NBDR number of directions for track normalization. +* ITYPBC type of boundary conditions where: +* =0 for geometry with Cartesianb oundaries; +* =1 for geometry with annular boundary; +* =2 for geometry with hexagonal boundary. +* IFMT tracking file format: +* =0 for short file; +* =1 long file required by TLM:. +* RCUTOF corner cutoff. +* SPACLN linear track spacing in the plane. +* WEIGHT weight associated with each line in the plane. +* RADIUS radius of circle (2-D) or sphere (3-D) surrounding +* the geometry. +* CENTER center of circle (2-D) or sphere (3-D) surrounding +* the geometry. +* IUNFLD description of unfolded geometry. +* SURVOL global surface volume vector. +* DGMESH meshing vector for global geometry. +* DANGLT angles. +* DDENWT angular density for each angle. +* +*Parameters: output +* MAXSGL maximum number of segments in a line. +* NTLINE total number of lines generated. +* DVNOR ratio of analytic to tracked volume. +* DSNOR ratio of analytic to tracked surface area. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* \\\\ +* Based on the XELTI2 and XELTI3 routines. +* +*---------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPTRK + INTEGER IFTEMP + INTEGER IPRINT,IGTRK,NDIM,MAXMSH,NFSUR,NFREG, + > NUCELL(3),NQUAD,NBANGL,NBUCEL, + > NPLANE,NPOINT,LINMAX,MXGSUR,MXGREG,RENO, + > MAXPIN,NTLINE,NBTDIR,NBDR,ITYPBC,IFMT,MAXSGL + DOUBLE PRECISION RCUTOF,SPACLN,WEIGHT + DOUBLE PRECISION RADIUS,CENTER(NDIM) + INTEGER IUNFLD(2,NBUCEL) + DOUBLE PRECISION SURVOL(-NFSUR:NFREG),DGMESH(-1:MAXMSH,5), + > DANGLT(NDIM,NQUAD,NBANGL),DDENWT(NQUAD,NBANGL), + > DVNOR(NFREG,NBDR), + > DSNOR(NFSUR) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTTLS') + DOUBLE PRECISION DCUTOF,DZERO,DONE,DTWO + PARAMETER (DCUTOF=1.0D-8,DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Functions +*---- + DOUBLE PRECISION XDRCST,PI + INTEGER NXTLCA,NXTLHA,IRLA +*---- +* Local variables +*---- + INTEGER NPO2,NCUTOF, + > ITDIR,IANGL,IQUAD,IPLANE,IDIR, + > NPTA2,NPTA3,IPTA2,IPTA3,ITST,NBCOR(2),NBSINT, + > ITRN,ICEL,ICI,JLINE,IBLIN,IELIN,NBSEG,ISURF, + > IX,IY,IZ,IOX,IOY,IOZ,IOC,LMAXT + DOUBLE PRECISION RAD2G,RAD2T,ANGLES(3,3),DNPDIR(3,2,3), + > TRKORI(3),TRKOR2(3),TCUTOF(3,2,2),TRKLIM(2), + > CELLPO(3,2),DSTART,DCERR,FACVOL,FACSUR, + > DSVERR,DMVERR,DAVERR,DSSERR,DMSERR,DASERR,DERR + DOUBLE PRECISION DWGT,DAWGT,VCONT,VCONTA,WGTFAC,TORIG(3) + INTEGER ISEG,JSEG,IREG,ILREG,ISUR,NBVERR,NBSERR, + > NBV0,NBV1,NBS0,IPRINL + INTEGER ISD,NSDEB,ISF,NSFIN,NBREG,ISBL,NTSEG,IST + INTEGER IOFF,NGLINE + DOUBLE PRECISION TOTVE,TOTVA,TOTVD,TOTVDR,DELV, + > TOTSE,TOTSA,TOTSD,TOTSDR,DELS + INTEGER NICSS,ICISS,ICSR,ICSRR +*---- +* Allocatable arrays (local) +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NUMERO + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ICINT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: LENGTH,DLENGT, + > DCINT,DWGTRK + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: DDIRET + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: DORITR +*---- +* Data +*---- + CHARACTER CDIR(4)*1 + SAVE CDIR + DATA CDIR /'X','Y','Z','R'/ +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + LMAXT=4*(NBUCEL+4) + WGTFAC=DONE + PI=XDRCST('Pi',' ') + MAXSGL=0 + ITST=RENO + ITST=1 + NPTA2=NPOINT + NPTA3=1 + RAD2G=RADIUS*RADIUS + IF(NDIM .EQ. 3) NPTA3=NPOINT + DVNOR(:NFREG,:NBDR)=DZERO + DSNOR(:NFSUR)=DZERO + NPO2=NPOINT/2 + IF(RCUTOF .EQ. DZERO) THEN + NCUTOF= 1 + ELSE + NCUTOF= 4 + ENDIF + IOC=0 +*---- +* Allocate: temporary storage (local) +* NUMERO region/surface identification number for segment. +* LENGTH segment length. +* DLENGT spatial location of each line segment. +* ICINT identification of spatial position for each +* line segment in cell description of geometry. +* DCINT position of each intersection point for each +* line segment in cell description of geometry. +* DDIRET direction of tracking lines. +* DWGTRK weight of tracking lines. +* DORITR origin of tracking lines. +*---- + ALLOCATE(NUMERO(LINMAX),ICINT(0:5,LMAXT)) + ALLOCATE(LENGTH(LINMAX),DLENGT(LINMAX),DCINT(LMAXT), + > DDIRET(NDIM,NQUAD*NBANGL),DWGTRK(NQUAD*NBANGL), + > DORITR(NDIM*(NDIM+1),NPLANE,NQUAD*NBANGL)) +*---- +* Compute number of track directions +*---- + NBTDIR=0 + DO IANGL=1,NBANGL + DO IQUAD=1,NQUAD + IF(DDENWT(IQUAD,IANGL) .GT. DZERO) THEN + NBTDIR=NBTDIR+1 + ENDIF + ENDDO + ENDDO + FACVOL=DTWO + IF(NDIM .EQ. 2) THEN + FACSUR=PI + ELSE + FACSUR=DTWO*DTWO + ENDIF + IF(IPRINT .GT. 1000) THEN + IF(ITYPBC .EQ. 2) THEN + WRITE(IOUT,6070) 'DGMESH X',NUCELL(1) + WRITE(IOUT,6071) (DGMESH(IX,1),IX=-1,NUCELL(1)) + WRITE(IOUT,6070) 'DGMESH Y',NUCELL(1) + WRITE(IOUT,6071) (DGMESH(IX,2),IX=-1,NUCELL(1)) + IF(NDIM .EQ.3) THEN + WRITE(IOUT,6070) 'DGMESH Z',NUCELL(3) + WRITE(IOUT,6071) (DGMESH(IX,3),IX=-1,NUCELL(3)) + ENDIF + ELSE + DO IDIR=1,NDIM + WRITE(IOUT,6070) 'DGMESH '//CDIR(IDIR),NUCELL(IDIR) + WRITE(IOUT,6071) (DGMESH(IX,IDIR),IX=-1,NUCELL(IDIR)) + ENDDO + ENDIF + ENDIF + DDIRET(:NDIM,:NQUAD*NBANGL)=DZERO + DWGTRK(:NQUAD*NBANGL)=DZERO + DORITR(:NDIM*(NDIM+1),:NPLANE,:NQUAD*NBANGL)=DZERO +*---- +* Loop over angles in a quarter (2-D) or a quadrant (3-D) +*---- + NGLINE=0 + NTLINE=0 + ITDIR=0 + DO IANGL=1,NBANGL +*---- +* Loop over 2 quarters (2-D) or 4 quadrants (3-D) +*---- + DO IQUAD=1,NQUAD +*---- +* Do not track angle with 0 density +* because of the problem symmetry +*---- + IF(DDENWT(IQUAD,IANGL) .EQ. DZERO) GO TO 105 + DWGT=WEIGHT/DDENWT(IQUAD,IANGL) + DAWGT=WEIGHT +*---- +* Track this angle +*---- + ITDIR=ITDIR+1 + DWGTRK(ITDIR)=DWGT +*---- +* Find planes mormal to selected direction +*---- + TRKORI(:3)=DZERO + TRKOR2(:3)=DZERO + ANGLES(:3,:3)=DZERO + DNPDIR(:3,:2,:3)=DZERO + DO IDIR=1,NDIM + ANGLES(IDIR,1)=DANGLT(IDIR,IQUAD,IANGL) + DDIRET(IDIR,ITDIR)=ANGLES(IDIR,1) + ENDDO + CALL NXTQPS(NDIM,ANGLES,DNPDIR) +*---- +* Loop over planes normal to direction +* 1 in 2-D and 3 in 3-D +*---- + DO IPLANE=1,NPLANE + DO IDIR=1,NDIM + DO JLINE=2,NDIM + ANGLES(IDIR,JLINE)=SPACLN*DNPDIR(IDIR,JLINE-1,IPLANE) + ENDDO + IF(NCUTOF .NE. 1)THEN + TCUTOF(IDIR,1,1)=RCUTOF*(ANGLES(IDIR,2)+ANGLES(IDIR,3)) + TCUTOF(IDIR,1,2)=RCUTOF*(ANGLES(IDIR,2)-ANGLES(IDIR,3)) + TCUTOF(IDIR,2,1)=-TCUTOF(IDIR,1,2) + TCUTOF(IDIR,2,2)=-TCUTOF(IDIR,1,1) + ENDIF + TRKOR2(IDIR)=CENTER(IDIR) + > -DBLE(NPO2+1)*(ANGLES(IDIR,2)+ANGLES(IDIR,3)) + ENDDO +*---- +* Fill array for localisation of integration lines +*---- + DO IDIR=1,NDIM + DORITR(IDIR,IPLANE,ITDIR)=TRKOR2(IDIR) + ENDDO + IOFF=NDIM + DO JLINE=1,NDIM + DO IDIR=1,NDIM + DORITR(IDIR+IOFF,IPLANE,ITDIR)=ANGLES(IDIR,JLINE) + ENDDO + IOFF=IOFF+NDIM + ENDDO +*---- +* Loop over lines on first normal axis (direction 2) +*---- + DO IPTA2=1,NPTA2 +*---- +* Displace starting point by an additional value of SPALLN +* along first normal axis (direction 2) +*---- + DO IDIR=1,NDIM + TRKOR2(IDIR)=TRKOR2(IDIR)+ANGLES(IDIR,2) + TRKORI(IDIR)=TRKOR2(IDIR) + ENDDO +*---- +* For 3-D models: +* Loop over lines on second normal axis (direction 3) +* For 2-D models: +* NPTA3=1 +*---- + DO IPTA3=1,NPTA3 + RAD2T=0.0 +*---- +* For 3-D models: +* Displace starting point by an additional value of SPALLN +* along second normal axis (direction 3) +* For 2-D models: +* No displacement since ANGLES(IDIR,3)=0 +*---- + NGLINE=NGLINE+1 + DO IDIR=1,NDIM + TRKORI(IDIR)=TRKORI(IDIR)+ANGLES(IDIR,3) + RAD2T=RAD2T+(TRKORI(IDIR)-CENTER(IDIR))**2 + ENDDO +*---- +* Eliminate tracks outside circle or sphere surrounding geometry +*---- + IF(RAD2T .GT. RAD2G) GO TO 115 +*---- +* Find cells crossed by track +*---- + IPRINL=IPRINT +* IF(NTLINE+1 .EQ. 676 +* > .OR. NTLINE+1 .EQ. 1814 +* > .OR. NTLINE+1 .EQ. 1831 +* > ) IPRINL=IPRINT+4000 + IRLA=-1 + IF(ITYPBC .EQ. 0) THEN +*---- +* Cartesian assembly +*---- + IRLA=NXTLCA(IPRINL,ITST ,NDIM ,MAXMSH,LMAXT, + > NUCELL,TRKORI,ANGLES,DGMESH, + > NBCOR ,NBSINT,ICINT ,DCINT) + ELSE IF(ITYPBC .EQ. 1) THEN +*---- +* Annular assembly +*---- + CALL XABORT(NAMSBR//': Circular BC not implemented') + ELSE IF(ITYPBC .EQ. 2) THEN +*---- +* Hexagonal assembly +*---- + IRLA=NXTLHA(IPRINL,ITST ,NDIM ,MAXMSH,LMAXT, + > NUCELL,TRKORI,ANGLES,DGMESH, + > NBCOR ,NBSINT,ICINT ,DCINT) + ENDIF + IF(IRLA .EQ. -1) CALL XABORT(NAMSBR// + >': This type of cell cannot be tracked by NXT:') +*---- +* When no external face crossed go to next line +*---- + IF(IRLA .EQ. 0) GO TO 115 +*---- +* Test for multiple line segments in hexagonal assemblies +* +*---- + NICSS=1 + IF(ITYPBC .EQ. 2) THEN + DO ICI=2,NBSINT + IF(ICINT(0,ICI) .EQ. 0) THEN + NICSS=NICSS+1 + ENDIF + ENDDO + ICSRR=NBCOR(1)+1 + ELSE + ICSRR=NBCOR(1)+1 + ENDIF +*---- +* For each region crossed loop track geometry +* present in this region +*---- +* write(6,*) 'NICSS,ICSRR=',NICSS,ICSRR + DO ICISS=1,NICSS + ICSR=ICSRR + NTLINE=NTLINE+1 + IF(IPRINL .GE. 500) THEN + WRITE(IOUT,6039) + WRITE(IOUT,6040) NTLINE,ITDIR,IPLANE, + > IPTA2,IPTA3,WEIGHT,SPACLN + WRITE(IOUT,6041) NTLINE,TRKORI + WRITE(IOUT,6042) NTLINE,ANGLES + WRITE(IOUT,6043) NTLINE,DCINT(ICSR-1) + ELSE IF(IPRINL .GE. 50) THEN + WRITE(IOUT,6040) NTLINE,ITDIR,IPLANE, + > IPTA2,IPTA3,WEIGHT,SPACLN + ENDIF + IBLIN=1 + IELIN=0 + NUMERO(IBLIN)=0 + DLENGT(IBLIN)=DCINT(ICSR-1) + DSTART=DCINT(ICSR-1) + IBLIN=IBLIN+1 + DO ICI=ICSR,NBSINT-NBCOR(2)+1 + ICSRR=ICSRR+1 + IF(ITYPBC .EQ. 0) THEN + IX=ICINT(1,ICI) + IY=ICINT(2,ICI) + IOX=IX + CELLPO(1,2)=DGMESH(IX,1) + CELLPO(1,1)=DGMESH(IX-1,1) + CELLPO(2,2)=DGMESH(IY,2) + CELLPO(2,1)=DGMESH(IY-1,2) + IOY=(IY-1)*NUCELL(1) + IOZ=0 + IF(NDIM .EQ. 3) THEN + IZ=ICINT(3,ICI) + IOZ=(IZ-1)*NUCELL(1)*NUCELL(2) + CELLPO(3,2)=DGMESH(IZ,3) + CELLPO(3,1)=DGMESH(IZ-1,3) + ENDIF + IOC=IOX+IOY+IOZ + ELSE IF(ITYPBC .EQ. 2) THEN + IOC=ICINT(0,ICI+1) +*---- +* For multiple track segment IOC=0 indicates that the current +* segment is completed and that a new track segment should be +* started at ICI+2 +*---- + IF(IOC .EQ. 0) THEN + ICSRR=ICSRR+2 + GO TO 125 + ENDIF + IOC=ICINT(0,ICI) + IX=ICINT(1,ICI) + IY=ICINT(1,ICI) + CELLPO(1,2)=DGMESH(IX,1) + CELLPO(1,1)=DGMESH(IX,1) + CELLPO(2,2)=DGMESH(IY,2) + CELLPO(2,1)=DGMESH(IY,2) + IF(NDIM .EQ. 3) THEN + IZ=ICINT(3,ICI) + IOZ=(IZ-1)*NUCELL(1) + CELLPO(3,2)=DGMESH(IZ,3) + CELLPO(3,1)=DGMESH(IZ-1,3) + IOC=IOZ+IX + ENDIF + ENDIF + ICEL=IUNFLD(1,IOC) + ITRN=IUNFLD(2,IOC) + TRKLIM(1)=DSTART + DSTART=DSTART+DCINT(ICI) + TRKLIM(2)=DSTART + IF(ICI .EQ. NBCOR(1)+1) THEN +*---- +* initial surfaces (at TRKLIM(1)) considered +*---- + ISURF=-1 + ELSE IF(ICI .EQ. NBSINT-NBCOR(2)) THEN +*---- +* final surfaces (at TRKLIM(2)) considered +*---- + ISURF=1 + ELSE +*---- +* no surface considered +*---- + ISURF=0 + ENDIF +*---- +* Track turned Cell +*---- + CALL NXTTCR(IPTRK ,IPRINL,ICEL ,ITRN ,ISURF , + > NDIM ,MAXMSH,LINMAX,MXGSUR,MXGREG, + > MAXPIN,CELLPO,TRKLIM,TRKORI,ANGLES, + > IBLIN ,IELIN ,NUMERO,DLENGT) + DERR=MAX(ABS(TRKLIM(1)),ABS(TRKLIM(2))) + DERR=(DLENGT(IELIN)-DSTART)/DERR + IF(DERR .GT. DCUTOF) THEN + WRITE(IOUT,9100) NAMSBR,NTLINE, + > DLENGT(IELIN),DSTART,DERR + CALL XABORT(NAMSBR// + >': End of track does not coincide with end of cell') + ENDIF + IBLIN=IELIN+1 + ENDDO + 125 CONTINUE + NBSEG=IELIN +*---- +* Compress tracking vector for region with DLENGT=0.0 and +* for successive segments in the same region. +*---- + JSEG=0 + ILREG=-1 + NBREG=0 + DO ISEG=1,NBSEG + IREG=NUMERO(ISEG) + IF(DLENGT(ISEG) .GT. DZERO) THEN + IF(IREG .GT. 0) THEN + IF(IREG .EQ. ILREG) THEN + DLENGT(JSEG)=DLENGT(JSEG)+DLENGT(ISEG) + ELSE + JSEG=JSEG+1 + DLENGT(JSEG)=DLENGT(ISEG) + NUMERO(JSEG)=IREG + ILREG=IREG + ENDIF + ELSE + JSEG=JSEG+1 + DLENGT(JSEG)=DLENGT(ISEG) + NUMERO(JSEG)=IREG + ILREG=-1 + ENDIF + ENDIF + ENDDO + NBSEG=JSEG +*---- +* Add contribution of track to volume integration for this angle +* in this quadrant and compress tracking line by removing +* segments with NUMERO=0. +*---- + JSEG=0 + NSDEB=0 + NSFIN=0 + NBREG=0 + DO ISEG=1,NBSEG + IREG=NUMERO(ISEG) + IF(DLENGT(ISEG) .GT. DZERO) THEN + IF(IREG .GT. 0) THEN + NBREG=NBREG+1 + VCONT=DLENGT(ISEG)*DWGT*FACVOL + DVNOR(IREG,1)=DVNOR(IREG,1)+VCONT + IF(NBDR .GT. 1) THEN + VCONTA=DLENGT(ISEG)*DAWGT + DVNOR(IREG,ITDIR+1)=DVNOR(IREG,ITDIR+1)+VCONTA + ENDIF + JSEG=JSEG+1 + LENGTH(JSEG)=DLENGT(ISEG) + NUMERO(JSEG)=IREG + ELSE IF(IREG .LT. 0) THEN + IF(NBREG .EQ. 0) THEN + NSDEB=NSDEB+1 + ELSE + NSFIN=NSFIN+1 + ENDIF + DSNOR(-IREG)=DSNOR(-IREG) + > +DLENGT(ISEG)*DWGT*FACSUR + JSEG=JSEG+1 + LENGTH(JSEG)=DLENGT(ISEG) + NUMERO(JSEG)=IREG + ENDIF + ENDIF + ENDDO + NBSEG=JSEG + IF(NSDEB .GT. 1 .OR. NSFIN .GT. 1) THEN + IF(IPRINL .GE. 500) THEN + WRITE(IOUT,6025) NTLINE,ITDIR,NBSEG, + > NSDEB,NSFIN,NBREG, + > DLENGT(1),DLENGT(NBSEG) + WRITE(IOUT,6023) 'LineReg',NTLINE + WRITE(IOUT,6021) (NUMERO(ISEG),ISEG=1,NBSEG) + WRITE(IOUT,6024) + WRITE(IOUT,6023) 'LinePos',NTLINE + WRITE(IOUT,6022) (LENGTH(ISEG),ISEG=1,NBSEG) + WRITE(IOUT,6024) + ENDIF + ENDIF + MAXSGL=MAX(MAXSGL,NBSEG) + IF(NSDEB*NSFIN .EQ. 0) THEN +*---- +* Missing outer or inner surface +* Skip track and return warning +*---- + WRITE(IOUT,9006) NAMSBR + WRITE(IOUT,9026) NTLINE,ITDIR,NBSEG,NSDEB,NSFIN, + > DLENGT(1),DLENGT(NBSEG) + ELSE +*---- +* Store line on temporary tracking file if required +*---- + WGTFAC=DONE/DBLE(NSDEB*NSFIN) + IF(IPRINL .GE. 500) THEN + WRITE(IOUT,6020) NTLINE,ITDIR,NBSEG,DWGT*WGTFAC, + > DLENGT(1),DLENGT(NBSEG) +* WRITE(6,*) IPLANE,IPTA2,IPTA3, +* > (TRKORI(IST),IST=1,NDIM),DCINT(ICSR-1) + WRITE(IOUT,6023) 'LineReg',NTLINE + WRITE(IOUT,6021) (NUMERO(ISEG),ISEG=1,NBSEG) + WRITE(IOUT,6024) + WRITE(IOUT,6023) 'LinePos',NTLINE + WRITE(IOUT,6022) (LENGTH(ISEG),ISEG=1,NBSEG) + WRITE(IOUT,6024) + ENDIF + NTSEG=NBSEG-NSDEB-NSFIN+2 + ISBL=0 + DO ISD=1,NSDEB + DO ISF=0,NSFIN-1 + ISBL=ISBL+1 + IF(NSDEB*NSFIN .GT. 1 .AND. IPRINL .GE. 500) + > WRITE(IOUT,6026) NTLINE-1+ISBL,NTLINE,ISBL + IF(IGTRK .EQ. 1) THEN + IF(IFMT .EQ. 1) THEN + DO IST=1,NDIM + TORIG(IST)=TRKORI(IST)+DCINT(ICSR-1)* + > DANGLT(IST,IQUAD,IANGL) + ENDDO + WRITE(IFTEMP) 1,NTSEG,DWGT*WGTFAC,ITDIR, + > NUMERO(ISD), + > (NUMERO(ISEG),ISEG=NSDEB+1,NBSEG-NSFIN), + > NUMERO(NBSEG-ISF), + > DONE, + > (LENGTH(ISEG),ISEG=NSDEB+1,NBSEG-NSFIN), + > DONE, + > NTLINE-1+ISBL,IPLANE,IPTA2,IPTA3, + > (TORIG(IST),IST=1,NDIM) + ELSE + WRITE(IFTEMP) 1,NTSEG,DWGT*WGTFAC,ITDIR, + > NUMERO(ISD), + > (NUMERO(ISEG),ISEG=NSDEB+1,NBSEG-NSFIN), + > NUMERO(NBSEG-ISF), + > DONE, + > (LENGTH(ISEG),ISEG=NSDEB+1,NBSEG-NSFIN), + > DONE + ENDIF + ENDIF + ENDDO + ENDDO + ENDIF + IF(ISBL .EQ. 0) THEN + WRITE(IOUT,6027) NTLINE,ITDIR,NBSEG, + > NSDEB,NSFIN,NBREG, + > NUMERO(1),DLENGT(1), + > NUMERO(NBSEG),DLENGT(NBSEG) + ISBL=1 + IF(IGTRK .EQ. 1) THEN + WRITE(IFTEMP) 1,NTSEG,DWGT*WGTFAC,ITDIR, + > NUMERO(1), + > (NUMERO(ISEG),ISEG=NSDEB+1,NBSEG-NSFIN), + > NUMERO(NBSEG), + > DONE, + > (LENGTH(ISEG),ISEG=NSDEB+1,NBSEG-NSFIN), + > DONE + ENDIF + ENDIF + NTLINE=NTLINE-1+ISBL + ENDDO +*---- +* Exit because line is outside circle or sphere surrounding geometry +*---- + 115 CONTINUE +*---- +* END loop over points on second normal axis +*---- + ENDDO +*---- +* END loop over points on first normal axis +*---- + ENDDO +*---- +* END loop over planes +*---- + ENDDO +*---- +* Exit because angle with 0 density not tracked +*---- + 105 CONTINUE +*---- +* END loop over quarter or quadrant +*---- + ENDDO +*---- +* END loop over angles +*---- + ENDDO +*---- +* Save general tracking information +*---- + CALL LCMPUT(IPTRK,'TrackingOrig', + > NDIM*(NDIM+1)*NPLANE*NBTDIR,4,DORITR) + CALL LCMPUT(IPTRK,'TrackingWgtD',NBTDIR,4,DWGTRK) + CALL LCMPUT(IPTRK,'TrackingDirc',NDIM*NBTDIR,4,DDIRET) +*---- +* Compute DVNOR and DSNOR by comparing ratio of analytical +* to numerically integrated volume or surfaces. +*---- + NBVERR=0 + DSVERR=DZERO + DMVERR=DZERO + DAVERR=DZERO + NBV0=0 + NBV1=0 + TOTVE=DZERO + TOTVA=DZERO + TOTVD=DZERO + TOTVDR=DZERO + DO IREG=1,NFREG + IF(IPRINT .GE. 20 ) THEN + WRITE(IOUT,6030) IREG, + > SURVOL(IREG),DVNOR(IREG,1) + ENDIF + TOTVE=TOTVE+SURVOL(IREG) + TOTVA=TOTVA+DVNOR(IREG,1) + DELV=SURVOL(IREG)-DVNOR(IREG,1) + TOTVDR=TOTVDR+DELV*DELV + DO IDIR=1,NBDR + IF(DVNOR(IREG,IDIR) .EQ. DZERO) THEN + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,9000) NAMSBR,IREG,ITDIR + ENDIF + DVNOR(IREG,IDIR)=DONE + IF(IDIR .EQ. 1) THEN + NBV0=NBV0+1 + ELSE + NBV1=NBV1+1 + ENDIF + ELSE + DVNOR(IREG,IDIR)=SURVOL(IREG) + > /DVNOR(IREG,IDIR) + IF(IDIR .EQ. 1) THEN + NBVERR=NBVERR+1 + ENDIF + ENDIF + ENDDO + DCERR=100.0D0*(DONE-DVNOR(IREG,1)) + DMVERR=MAX(DMVERR,ABS(DCERR)) + DSVERR=DSVERR+DCERR*DCERR + DAVERR=DAVERR+DCERR + ENDDO + TOTVD=100.0D0*(TOTVE-TOTVA)/TOTVE + TOTVDR=100.0D0*SQRT(TOTVDR/DBLE(NBVERR))/TOTVE + IF(NBV0 .GT. 0) THEN + WRITE(IOUT,9002) NAMSBR + ENDIF + IF(NBV1 .GT. 0) THEN + WRITE(IOUT,9005) NAMSBR + ENDIF + DSVERR=SQRT(DSVERR/DBLE(NBVERR)) + DAVERR=DAVERR/DBLE(NBVERR) + NBSERR=0 + DSSERR=DZERO + DMSERR=DZERO + DASERR=DZERO + NBS0=0 + TOTSE=DZERO + TOTSA=DZERO + TOTSD=DZERO + TOTSDR=DZERO + DO ISUR=1,NFSUR + IF(IPRINT .GE. 20 ) THEN + WRITE(IOUT,6031) ISUR, + > SURVOL(-ISUR),DSNOR(ISUR) + ENDIF + TOTSE=TOTSE+SURVOL(-ISUR) + TOTSA=TOTSA+DSNOR(ISUR) + DELS=SURVOL(-ISUR)-DSNOR(ISUR) + TOTSDR=TOTSDR+DELS*DELS + IF(DSNOR(ISUR) .EQ. DZERO) THEN + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,9001) NAMSBR,-ISUR + ENDIF + NBS0=NBS0+1 + DSNOR(ISUR)=DONE + ELSE + DSNOR(ISUR)=SURVOL(-ISUR) + > /DSNOR(ISUR) + NBSERR=NBSERR+1 + ENDIF + DCERR=100.0D0*(DONE-DSNOR(ISUR)) + DMSERR=MAX(DMSERR,ABS(DCERR)) + DSSERR=DSSERR+DCERR*DCERR + DASERR=DASERR+DCERR + ENDDO + TOTSD=100.0D0*(TOTSE-TOTSA)/TOTSE + TOTSDR=100.0D0*SQRT(TOTSDR/DBLE(NBSERR))/TOTSE + IF(NBS0 .GT. 0) THEN + WRITE(IOUT,9003) NAMSBR,NBS0 + ENDIF + DSSERR=SQRT(DSSERR/DBLE(NBSERR)) + DASERR=DASERR/DBLE(NBSERR) +*---- +* Processing finished: +* print track normalization vector. +* and routine closing output header if required +* and return +*---- + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6007) TOTVE,TOTVA,TOTVD,TOTVDR + WRITE(IOUT,6005) DSVERR,DMVERR,DAVERR + IF(IPRINT .GE. 10) THEN + DO IREG=1,NFREG + WRITE(IOUT,6010) IREG,SURVOL(IREG) + WRITE(IOUT,6012) DVNOR(IREG,1), + > 100.0D0*(DONE-DVNOR(IREG,1)) + ENDDO + ENDIF + WRITE(IOUT,6008) TOTSE,TOTSA,TOTSD,TOTSDR + WRITE(IOUT,6006) DSSERR,DMSERR,DASERR + IF(IPRINT .GE. 10) THEN + DO ISUR=1,NFSUR + WRITE(IOUT,6011) -ISUR,SURVOL(-ISUR) + WRITE(IOUT,6012) DSNOR(ISUR), + > 100.0D0*(DONE-DSNOR(ISUR)) + ENDDO + ENDIF + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* Save track normalisation vector +*---- + IF(MAXSGL .EQ. 0) THEN + WRITE(IOUT,9004) NAMSBR + MAXSGL=LINMAX + ENDIF +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(DORITR,DWGTRK,DDIRET,DCINT,DLENGT,LENGTH) + DEALLOCATE(ICINT,NUMERO) + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6005 FORMAT(' Global RMS, maximum and average errors (%) ', + > 'on region volumes :',3(2X,F10.5)) + 6006 FORMAT(' Global RMS, maximum and average errors (%) ', + > 'on surface areas :',3(2X,F10.5)) + 6007 FORMAT(' Total exact volume = ',F19.10/ + > ' Total approximate volume = ',F19.10/ + > ' Error on total volume = ',4X,F10.5/ + > ' RMS Error on total volume= ',4X,F10.5) + 6008 FORMAT(' Total exact surface area = ',F19.10/ + > ' Total approximate surface area = ',F19.10/ + > ' Error on total surface area = ',4X,F10.5/ + > ' RMS Error on total surface area= ',4X,F10.5) + 6010 FORMAT(' Normalisation factors and relative errors (%) ', + > 'for region ',I8,' with volume ',F19.10) + 6011 FORMAT(' Normalisation factors and relative error (%) ', + > 'for surface ',I8,' with area ',F19.10) + 6012 FORMAT((2X,F15.10,2X,F10.5)) + 6020 FORMAT('Line',I10.10,'={',2(I10,','), + > F18.10,',',F18.10,',',F18.10,'};') + 6021 FORMAT(6(I10,:,',',9X)) + 6022 FORMAT(6(F18.10,:,',')) + 6023 FORMAT(A7,I10.10,'={') + 6024 FORMAT(18X,'};') + 6025 FORMAT('Line',I10.10,'={',5(I10,','), + > F18.10,',',F18.10,'};') + 6026 FORMAT('Line',I10.10,'={',I10,',',I10,'};') + 6027 FORMAT('Problem with Line',I10.10,'={',5(I10,','), + > I10,',',F18.10,',',I10,',',F18.10,'};') + 6030 FORMAT(' Normalization volumes =',I10,1P,2D20.10) + 6031 FORMAT(' Normalization surfaces =',I10,1P,2D20.10) + 6039 FORMAT(1X) + 6040 FORMAT('Track',I10.10,'={',4(I10,','), + >F15.8,',',F15.8,'};') + 6041 FORMAT('Torig',I10.10,'={',2(F15.8,','),F15.8,'};') + 6042 FORMAT('Tdire',I10.10,'={',8(F15.8,','),F15.8,'};') + 6043 FORMAT('Tstrt',I10.10,'={',F15.8,'};') + 6070 FORMAT(1X,A8,5X,I10) + 6071 FORMAT(5F18.10) + 9000 FORMAT(1X,'***** Warning in ',A6,'*****'/ + > 7X,'For region ',I8, + > 1X,'no crossing by angle ',I8) + 9001 FORMAT(1X,'***** Warning in ',A6,'*****'/ + > 7X,'For surface ',I8, + > 1X,'no crossing by any angle ') + 9002 FORMAT(1X,'***** Warning in ',A6,'*****'/ + > 7X,' regions not tracked for any direction ') + 9003 FORMAT(1X,' ***** Warning in ',A6,'*****'/ + > 7X,I8,' surfaces not tracked for direction ',I8) + 9004 FORMAT(1X,' ***** Warning in ',A6,'*****'/ + > 7X,' no line segments detected in tracking ') + 9005 FORMAT(1X,'***** Warning in ',A6,'*****'/ + > 7X,' regions not tracked for some directions') + 9006 FORMAT(1X,'***** Warning in ',A6,'*****'/ + > 7X,' Final or initial surface could not be identified') + 9026 FORMAT('Line',I10.10,'={',4(I10,','), + > F18.10,',',F18.10,'};') + 9100 FORMAT(1X,' ***** Error in ',A6,'***** for line ',I8/ + > 7X,'Positions (current and reference ) =',1P,2D21.14/ + > 7X,'Relative error = ',D21.14) + END diff --git a/Dragon/src/NXTTNS.f b/Dragon/src/NXTTNS.f new file mode 100644 index 0000000..c0c093f --- /dev/null +++ b/Dragon/src/NXTTNS.f @@ -0,0 +1,214 @@ +*DECK NXTTNS + SUBROUTINE NXTTNS(IFTRK ,IFTEMP,IPRINT,RENO ,NFSUR ,NFREG , + > NDIM ,MAXSUB, MAXSGL,NTLINE,NBDR ,IFMT , + > KEYMRG,DVNOR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To normalize tracking lines and save track volume +* normalisation factors on tracking data structure. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IFTRK pointer to the TRACKING file in +* creation mode. +* IFTEMP pointer to a temporary TRACKING data structure in +* update or creation mode. +* IPRINT print level. +* RENO track normalisation option. A value RENO=-1 implies +* a direction dependent normalization of the tracks +* for the volume while a value RENO=0, implies +* a global normalisation. +* NFSUR number of surfaces. +* NFREG number of regions. +* NDIM problem dimensions. +* MAXSUB maximum number of subtracks in a track. +* MAXSGL maximum number of segments in a track. +* NTLINE number of track generated. +* NBDR number of directions for track normalization. +* IFMT track format: =0 short; =1 long. +* KEYMRG index array for surface and volume renumbering. +* DVNOR track volume normalisation factors. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* \\\\ +* Based on the XELTI2 and XELTI3 routines. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IFTRK,IFTEMP + INTEGER IPRINT,RENO,NFSUR,NFREG,NDIM,MAXSUB, + > MAXSGL,NTLINE,NBDR,IFMT + INTEGER KEYMRG(-NFSUR:NFREG) + DOUBLE PRECISION DVNOR(NFREG,NBDR) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTTNS') +*---- +* Local variables +*---- + INTEGER IRLINE,NSUB,NBSEG,ISEG,IREG,JSEG,JREG,II + DOUBLE PRECISION WEIGHT + INTEGER IRA,IADD(4),INREG,JNREG,ITDIR,IND + LOGICAL LNEW +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NUMERO,IANGL + DOUBLE PRECISION , ALLOCATABLE, DIMENSION(:) :: LENGTH + DOUBLE PRECISION , ALLOCATABLE, DIMENSION(:,:) :: DADD +*---- +* Scratch storage allocation +* NUMERO region/surface identification number for segment. +* LENGTH segment length. +*---- + ALLOCATE(NUMERO(MAXSGL),LENGTH(MAXSGL),IANGL(MAXSUB), + > DADD(NDIM,MAXSUB)) +*---- +* Processing starts: +* print routine opening output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + IRLINE=0 + 100 CONTINUE + IF(IFMT .EQ. 1) THEN + READ(IFTEMP,END=105) NSUB,NBSEG,WEIGHT, + > (IANGL(II),II=1,NSUB), + > (NUMERO(ISEG),ISEG=1,NBSEG), + > (LENGTH(ISEG),ISEG=1,NBSEG), + > (IADD(IRA),IRA=1,4), + > ((DADD(IRA,II),IRA=1,NDIM),II=1,NSUB) + ELSE + READ(IFTEMP,END=105) NSUB,NBSEG,WEIGHT, + > (IANGL(II),II=1,NSUB), + > (NUMERO(ISEG),ISEG=1,NBSEG), + > (LENGTH(ISEG),ISEG=1,NBSEG) + ENDIF + IRLINE=IRLINE+1 +*---- +* Normalize track LENGTH globally +*---- + IF((RENO .EQ. -1) .AND. (NSUB .GT. 1)) THEN +* Angular-dependent normalization of a cyclic multi-track + IND=0 + LNEW=.TRUE. + DO ISEG=1,NBSEG + IREG=NUMERO(ISEG) + IF(IREG .GT. NFREG) THEN + WRITE(IOUT,9001) NAMSBR,(NUMERO(JSEG),JSEG=1,NBSEG) + CALL XABORT(NAMSBR// + > ': Region number larger than maximum permitted') + ELSE IF(IREG .GT. 0) THEN + IF(LNEW) THEN + IND=IND+1 + IF(IND.GT.NSUB) CALL XABORT(NAMSBR//': NSUB overflow') + LNEW=.FALSE. + ENDIF + ITDIR=IANGL(IND) + LENGTH(ISEG)=LENGTH(ISEG)*DVNOR(IREG,ITDIR+1) + ELSE + LNEW=.TRUE. + ENDIF + ENDDO + IF(IND.NE.NSUB) CALL XABORT(NAMSBR//': Algorithm failure') + ELSE IF(RENO .LE. 0) THEN + DO ISEG=1,NBSEG + IREG=NUMERO(ISEG) + IF(IREG .GT. NFREG) THEN + WRITE(IOUT,9001) NAMSBR,(NUMERO(JSEG),JSEG=1,NBSEG) + CALL XABORT(NAMSBR// + > ': Region number larger than maximum permitted') + ELSE IF(IREG .GT. 0) THEN + IF(RENO .EQ. -1) THEN + ITDIR=IANGL(1) + LENGTH(ISEG)=LENGTH(ISEG)*DVNOR(IREG,ITDIR+1) + ELSE + LENGTH(ISEG)=LENGTH(ISEG)*DVNOR(IREG,1) + ENDIF + ENDIF + ENDDO + ENDIF +*---- +* Change region and surface numbering and +* compress track line for successive segment with same region +*---- + JSEG=1 + JREG=NUMERO(1) + JNREG=KEYMRG(JREG) + NUMERO(1)=JNREG + DO ISEG=2,NBSEG + IREG=NUMERO(ISEG) + INREG=KEYMRG(IREG) + NUMERO(ISEG)=INREG + IF(INREG .LT. 0 .OR. INREG .NE. JNREG) THEN + JSEG=JSEG+1 + NUMERO(JSEG)=NUMERO(ISEG) + LENGTH(JSEG)=LENGTH(ISEG) + JNREG=INREG + ELSE + LENGTH(JSEG)=LENGTH(JSEG)+LENGTH(ISEG) + ENDIF + ENDDO + NBSEG=JSEG + IF(IFMT .EQ. 1) THEN + WRITE(IFTRK) NSUB,NBSEG,WEIGHT, + > (IANGL(II),II=1,NSUB), + > (NUMERO(ISEG),ISEG=1,NBSEG), + > (LENGTH(ISEG),ISEG=1,NBSEG), + > (IADD(IRA),IRA=1,4), + > ((DADD(IRA,II),IRA=1,NDIM),II=1,NSUB) + ELSE + WRITE(IFTRK) NSUB,NBSEG,WEIGHT, + > (IANGL(II),II=1,NSUB), + > (NUMERO(ISEG),ISEG=1,NBSEG), + > (LENGTH(ISEG),ISEG=1,NBSEG) + ENDIF + GO TO 100 + 105 CONTINUE + IF(IRLINE .NE. NTLINE) THEN + WRITE(IOUT,9000) NAMSBR,IRLINE,NTLINE + CALL XABORT(NAMSBR// + >': Problem with number of lines on tracking file') + ENDIF + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(DADD,IANGL,LENGTH,NUMERO) + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 9000 FORMAT(' ***** Error in ',A6,' *****'/, + > ' Number of lines : ',I10,' and ',I10) + 9001 FORMAT(' ***** Error in ',A6,' *****'/, + > ' Regions crossed by line segment :'/10I10) + END diff --git a/Dragon/src/NXTTPO.f b/Dragon/src/NXTTPO.f new file mode 100644 index 0000000..ae789d7 --- /dev/null +++ b/Dragon/src/NXTTPO.f @@ -0,0 +1,315 @@ +*DECK NXTTPO + SUBROUTINE NXTTPO(IPGEO ,IPRINT,ITYPBC,NBGCLS,NTPIN ,MAXMSH, + > NCDIM ,IDIRR ,DRW ,OFFCEN,NAGCLS) +* +*---------- +* +*Purpose: +* To test that cluster pins do not overlapp. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau. +* +*Parameters: input +* IPGEO pointer to the GEOMETRY data structure. +* IPRINT print level. +* ITYPBC type of boundary conditions where: +* =0 for geometry with Cartesianb oundaries; +* =1 for geometry with annular boundary; +* =2 for geometry with hexagonal boundary. +* NBGCLS number of cluster sets. +* NTPIN total number of pins. +* MAXMSH maximum mesh dimension. +* NCDIM number of dimensions. +* IDIRR mesh direction. +* DRW cell dimensions. +* OFFCEN off centering of pin and annular regions in cell. +* NAGCLS the cluster names in an integer format. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* \\\\ +* This routine is based on the XELDCL routine written by +* R. Roy for the EXCELT: module. It contains an additional +* level for cluster subgeometry analysis. +* +*---------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPGEO + INTEGER IPRINT,ITYPBC,NBGCLS,NTPIN ,MAXMSH,IDIRR,NCDIM + DOUBLE PRECISION DRW(3) + REAL OFFCEN(3) + INTEGER NAGCLS(3,NBGCLS) +*---- +* Functions +*---- + DOUBLE PRECISION XDRCST,PI + INTEGER NXTIRA,NXTIAA,NXTIHA,INTTYP + DOUBLE PRECISION VOLINT +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTTPO') + DOUBLE PRECISION DZERO,DONE,DTWO + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Local variables +*---- + INTEGER ICLS,NPIN,IX,IY,IZ,IP,JP,ITPIN,ICN,ITC + INTEGER ILCMLN,ILCMTY,ILCMLX,ILCMLY + CHARACTER NAMCL*12,NAMREC*12 + REAL DELTA + DOUBLE PRECISION ZPIN(2),XYZCAR(6),POSAH(0:2) +*---- +* Allocatable arrays +*---- + REAL, ALLOCATABLE, DIMENSION(:,:) :: PINDIM + REAL, ALLOCATABLE, DIMENSION(:) :: RPIN,APIN,CPINX,CPINY + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: PINPOS +*---- +* Data +*---- + CHARACTER CDIR(4)*1 + SAVE CDIR + DATA CDIR /'X','Y','Z','R'/ +*---- +* Scratch storage allocation +* PINDIM temporary storage for pin radius. +* RPIN pin radius. +* APIN pin angles. +* PINPOS pin position and outer radius. +*---- + ALLOCATE(PINDIM(0:MAXMSH,2),RPIN(NTPIN),APIN(NTPIN), + > CPINX(NTPIN),CPINY(NTPIN)) + ALLOCATE(PINPOS(0:4,NTPIN)) +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 500) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + PI=XDRCST('Pi',' ') +*---- +* Define cell limits +*---- + IX=MOD(IDIRR-1,3)+1 + IY=MOD(IDIRR,3)+1 + IZ=MOD(IDIRR+1,3)+1 + IF(ITYPBC .EQ. 0) THEN + XYZCAR(1)=-DRW(IX)/DTWO-DBLE(OFFCEN(IX)) + XYZCAR(2)=DRW(IX)/DTWO-DBLE(OFFCEN(IX)) + XYZCAR(3)=-DRW(IY)/DTWO-DBLE(OFFCEN(IY)) + XYZCAR(4)=DRW(IY)/DTWO-DBLE(OFFCEN(IY)) + ELSE IF(ITYPBC .EQ. 1) THEN + POSAH(0)=DRW(IX) + POSAH(1)=-DBLE(OFFCEN(IX)) + POSAH(2)=-DBLE(OFFCEN(IY)) + ELSE IF(ITYPBC .EQ. 2) THEN + POSAH(0)=DRW(IX) + POSAH(1)=-DBLE(OFFCEN(IX)) + POSAH(2)=-DBLE(OFFCEN(IY)) + ENDIF + IF(NCDIM .EQ. 3) THEN + XYZCAR(5)=-DRW(IZ)/DTWO-DBLE(OFFCEN(IZ)) + XYZCAR(6)=DRW(IZ)/DTWO-DBLE(OFFCEN(IZ)) + NAMREC='MESH'//CDIR(IZ)//' ' + ENDIF +*---- +* Find pin locations +*---- + ITPIN=0 + DO ICLS=1,NBGCLS + ICN=3*(ICLS-1) + WRITE(NAMCL,'(3A4)') (NAGCLS(ITC,ICLS),ITC=1,3) + CALL LCMSIX(IPGEO,NAMCL,1) + CALL LCMGET(IPGEO,'NPIN',NPIN) + CALL LCMLEN(IPGEO,'RPIN',ILCMLN,ILCMTY) + CALL LCMLEN(IPGEO,'CPINX',ILCMLX,ILCMTY) + CALL LCMLEN(IPGEO,'CPINY',ILCMLY,ILCMTY) + IF(ILCMLN .GE. 1) THEN + IF(ILCMLN .EQ. 1) THEN + CALL LCMGET(IPGEO,'RPIN',RPIN) + DO IP=2,NPIN + RPIN(IP)=RPIN(1) + ENDDO + ELSE IF(ILCMLN .EQ. NPIN) THEN + CALL LCMGET(IPGEO,'RPIN',RPIN) + ELSE + CALL XABORT(NAMSBR// + > ': Length of RPIN vector is invalid') + ENDIF + CALL LCMLEN(IPGEO,'APIN',ILCMLN,ILCMTY) + IF(ILCMLN .EQ. 0) THEN + APIN(1)=0.0 + DELTA=REAL((DTWO*PI)/DBLE(NPIN)) + DO IP=2,NPIN + APIN(IP)=APIN(IP-1)+DELTA + ENDDO + ELSE IF(ILCMLN .EQ. 1) THEN + CALL LCMGET(IPGEO,'APIN',APIN) + DELTA=REAL((DTWO*PI)/DBLE(NPIN)) + DO IP=2,NPIN + APIN(IP)=APIN(IP-1)+DELTA + ENDDO + ELSE IF(ILCMLN .EQ. NPIN) THEN + CALL LCMGET(IPGEO,'APIN',APIN) + ELSE + CALL XABORT(NAMSBR// + > ': Length of APIN vector is invalid') + ENDIF + DO IP=1,NPIN + CPINX(IP)=RPIN(IP)*COS(APIN(IP)) + CPINY(IP)=RPIN(IP)*SIN(APIN(IP)) + ENDDO + ELSE + IF(ILCMLX .EQ. NPIN .AND. ILCMLY .EQ. NPIN) THEN + CALL LCMGET(IPGEO,'CPINX',CPINX) + CALL LCMGET(IPGEO,'CPINY',CPINY) + ELSE + CALL XABORT(NAMSBR// + > ': (RPIN,APIN) or (CPINX,CPINY) are absent for pin cluster') + ENDIF + ENDIF + CALL LCMLEN(IPGEO,'RADIUS',ILCMLN,ILCMTY) + IF(ILCMLN .EQ. 0) CALL XABORT(NAMSBR// + > ': RADIUS vector for pin is missing') + CALL LCMGET(IPGEO,'RADIUS',PINDIM(0,1)) + IF(NCDIM .EQ. 3) THEN + CALL LCMLEN(IPGEO,NAMREC,ILCMLN,ILCMTY) + IF(ILCMLN .EQ. 0) CALL XABORT(NAMSBR// + > ': '//NAMREC//' vector for pin is missing') + CALL LCMGET(IPGEO,NAMREC,PINDIM(0,2)) + ZPIN(2)=DBLE(PINDIM(ILCMLN-1,2)-PINDIM(0,2))/DTWO + ZPIN(1)=-ZPIN(2) + IF(ZPIN(1) .LT. XYZCAR(5) .OR. + > ZPIN(1) .GT. XYZCAR(6) .OR. + > ZPIN(2) .LT. XYZCAR(5) .OR. + > ZPIN(2) .GT. XYZCAR(6) ) CALL XABORT(NAMSBR// + > ': '//NAMREC//' pin extend outside cell') + ELSE + ZPIN(2)=DZERO + ZPIN(1)=-ZPIN(2) + ENDIF +*---- +* Store information in PINPOS +*---- + DO IP=1,NPIN + ITPIN=ITPIN+1 + PINPOS(0,ITPIN)=DBLE(PINDIM(ILCMLN-1,1)) + PINPOS(1,ITPIN)=DBLE(CPINX(IP)) + PINPOS(2,ITPIN)=DBLE(CPINY(IP)) + PINPOS(3,ITPIN)=ZPIN(1) + PINPOS(4,ITPIN)=ZPIN(2) + ENDDO + CALL LCMSIX(IPGEO,NAMCL,2) + ENDDO +*---- +* All pin localized, test for overlapp +*---- + NPIN=ITPIN + IF(IPRINT .GE. 500) THEN + IF(ITYPBC .EQ. 0) THEN + WRITE(IOUT,6010) (XYZCAR(IX),IX=1,4) + ELSE IF(ITYPBC .EQ. 1) THEN + WRITE(IOUT,6011) (POSAH(IX),IX=0,2) + ELSE IF(ITYPBC .EQ. 2) THEN + WRITE(IOUT,6012) (POSAH(IX),IX=0,2) + ENDIF + IF(NCDIM .EQ. 3) THEN + DO IP=1,NPIN + WRITE(IOUT,6014) IP,(PINPOS(IX,IP),IX=0,4) + ENDDO + ELSE + DO IP=1,NPIN + WRITE(IOUT,6013) IP,(PINPOS(IX,IP),IX=0,2) + ENDDO + ENDIF + ENDIF + DO IP=1,NPIN +*---- +* Test if pin inside cell +*---- + INTTYP=-1 + IF(ITYPBC .EQ. 0) THEN +*---- +* Cell is a rectangle +*---- + INTTYP=NXTIRA(XYZCAR,PINPOS(0,IP),VOLINT) + IF(INTTYP .NE. 2) CALL XABORT(NAMSBR// + > ': Rectangular cell does not contain completely the pin') + ELSE IF(ITYPBC .EQ. 1) THEN +*---- +* Cell is a circle +*---- + INTTYP=NXTIAA(POSAH,PINPOS(0,IP),VOLINT) + IF(INTTYP .NE. 2) CALL XABORT(NAMSBR// + > ': Annular cell does not contain completely the pin') + ELSE IF(ITYPBC .EQ. 2) THEN +*---- +* Cell is an hexagon +*---- + INTTYP=NXTIHA(POSAH,PINPOS(0,IP),VOLINT) + IF(INTTYP .NE. 2) CALL XABORT(NAMSBR// + > ': Hexagonal cell does not contain completely the pin') + ENDIF + IF(INTTYP .NE. 2) CALL XABORT(NAMSBR// + > ': Pin outside rectangular cell') + DO JP=IP+1,NPIN + IF(NCDIM .EQ. 3) THEN +*---- +* check for z-overlapp if required +*---- + IF(PINPOS(4,JP) .LT. PINPOS(3,IP) .OR. + > PINPOS(4,IP) .LT. PINPOS(3,JP) ) GO TO 100 + ENDIF + INTTYP=NXTIAA(PINPOS(0,IP),PINPOS(0,JP),VOLINT) + IF(INTTYP .NE. 0) CALL XABORT(NAMSBR// + > ': two pins overlapp') + 100 CONTINUE + ENDDO + ENDDO +*---- +* Processing finished: +* print routine output header if required +* and return +*---- + IF(IPRINT .GE. 500) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(PINPOS) + DEALLOCATE(CPINY,CPINX,APIN,RPIN,PINDIM) + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(' XYCAR= ',4F20.10) + 6011 FORMAT(' Annular cell -> radius and x-y center= ',3F20.10) + 6012 FORMAT(' Hexagonal cell -> side and x-y center = ',3F20.10) + 6013 FORMAT(' PIN ',I10,' -> radius and x-y center= ',3F20.10) + 6014 FORMAT(' PIN ',I10,' -> radius, x-y center and z location= ', + > 5F20.10) + END diff --git a/Dragon/src/NXTTPS.f b/Dragon/src/NXTTPS.f new file mode 100644 index 0000000..cc526b6 --- /dev/null +++ b/Dragon/src/NXTTPS.f @@ -0,0 +1,218 @@ +*DECK NXTTPS + SUBROUTINE NXTTPS(IPRINT,NPIN ,IDGPP ,ITSYM ,DRAPIN) +* +*---------- +* +*Purpose: +* To test if pins satisfy required symmetry. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau. +* +*Parameters: input +* IPRINT print level. +* NPIN number of pins. +* IDGPP pin direction. +* ITSYM flag for symmetries to test. +* DRAPIN pin position/angle/height/radius. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,NPIN,IDGPP,ITSYM(4) + DOUBLE PRECISION DRAPIN(-1:4,NPIN) +*---- +* Functions +*---- + DOUBLE PRECISION XDRCST,PI +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTTPS') + DOUBLE PRECISION DCUTOF,DZERO,DONE,DTWO + PARAMETER (DCUTOF=1.0D-6,DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Local variables +*---- + INTEGER IPLOC + INTEGER IS,IP,JP,NPIR + DOUBLE PRECISION DNAP,PIO2,TWOPI + INTEGER ITSYR(4) +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IPLOC=IPRINT + IF(IPLOC .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + IF(IPLOC .GE. 1000) THEN + WRITE(IOUT,*) 'Symmetry =',ITSYM + WRITE(IOUT,*) 'Npin =',NPIN + DO IP=1,NPIN + WRITE(IOUT,'(6F20.12)') (DRAPIN(JP,IP),JP=-1,4) + ENDDO + ENDIF + ENDIF +*---- +* Rotate symmetry factors for cell directions +*---- + DO IS=1,4 + ITSYR(IS)=ITSYM(IS) + ENDDO + IF(IDGPP .EQ. 1) THEN + ITSYR(1)=ITSYM(2) + ITSYR(2)=ITSYM(3) + ITSYR(3)=ITSYM(1) + ITSYR(4)=ITSYM(4) + IF(ITSYR(4) .EQ. 1) CALL XABORT(NAMSBR// + > ': X=Y symmetry invalid for pin in direction X') + ELSE IF(IDGPP .EQ. 2) THEN + ITSYR(1)=ITSYM(3) + ITSYR(2)=ITSYM(1) + ITSYR(3)=ITSYM(2) + ITSYR(4)=ITSYM(4) + IF(ITSYR(4) .EQ. 1) CALL XABORT(NAMSBR// + > ': X=Y symmetry invalid for pin in direction Y') + ENDIF + PI=XDRCST('Pi',' ') + PIO2=PI/DTWO + TWOPI=DTWO*PI +*---- +* Scan over symmetrization options (in plane only) +*---- + DO 100 IS=1,3 + IF(ITSYR(IS) .EQ. 1) THEN +*---- +* Scan over symmetrized pin +*---- + IF(IPLOC .GE. 1000) THEN + WRITE(IOUT,'(A3,1X,I8,I8)') 'IS=',IS,ITSYR(IS) + ENDIF + DO 110 IP=1,NPIN +*---- +* Find location of pin after symmetrisation +*---- + IF(IS .EQ. 1) THEN +*---- +* X symmetry +* Symmetric pin should be at \pi-\varphi +*---- + DNAP=PI-DRAPIN(-1,IP) + ELSE IF(IS .EQ. 2) THEN +*---- +* Y symmetry +* Symmetric pin should be at -\varphi +*---- + DNAP=-DRAPIN(-1,IP) + ELSE IF(IS .EQ. 3) THEN +*---- +* Z symmetry +* Symmetric pin should be at \varphi +*---- + DNAP=DRAPIN(-1,IP) + ELSE IF(IS .EQ. 4) THEN +*---- +* X=Y symmetry +* Symmetric pin should be at \pi/2-\varphi +*---- + DNAP=PIO2-DRAPIN(-1,IP) + ENDIF +*---- +* Position angle in range 0 to 2*Pi +*---- + IF(ABS(DNAP) .LE. DCUTOF) THEN + DNAP=DZERO + ELSE IF(DNAP .GT. DCUTOF) THEN + NPIR=INT((DNAP+DCUTOF)/TWOPI) + DNAP=DNAP-DBLE(NPIR)*TWOPI + ELSE + NPIR=INT((DNAP-DCUTOF)/TWOPI) + DNAP=DNAP-DBLE(NPIR-1)*TWOPI + ENDIF + IF(IPLOC .GE. 1000) THEN + WRITE(IOUT,'(A3,1X,I8,2F20.12)') + > 'IP=',IP,DRAPIN(0,IP),DNAP + ENDIF + IF(DRAPIN(0,IP) .LT. DCUTOF) THEN +*---- +* For centered pin, test for radial position only +*---- + DO JP=1,NPIN +*---- +* Verify if pin coincide +* with symmetrized pin +*---- + IF(IPLOC .GE. 1000) THEN + WRITE(IOUT,'(A3,1X,I8,3F20.12)') + > 'JP=',JP,DRAPIN(0,JP),DRAPIN(-1,JP), + > ABS(DRAPIN(0,IP)-DRAPIN(0,JP)) + ENDIF + IF(ABS(DRAPIN(0,IP)-DRAPIN(0,JP)) .LT. DCUTOF) + > GO TO 115 + ENDDO +*---- +* no pin coincide, symmetry not satisfied, abort +*---- + CALL XABORT(NAMSBR//': Symmetric pin not found (C)') + ELSE +*---- +* For pin not centered, test for angular and radial position +*---- + DO JP=1,NPIN +*---- +* Verify if pin coincide +* with symmetrized pin +*---- + IF(IPLOC .GE. 1000) THEN + WRITE(IOUT,'(A3,1X,I8,4F20.8)') + > 'JP=',JP,DRAPIN(0,JP),DRAPIN(-1,JP), + > ABS(DRAPIN(0,IP)-DRAPIN(0,JP)), + > ABS(DNAP-DRAPIN(-1,JP)) + ENDIF + IF(ABS(DRAPIN(0,IP)-DRAPIN(0,JP)) .LT. DCUTOF) THEN + IF(ABS(DNAP-DRAPIN(-1,JP)) .LT. DCUTOF) GO TO 115 + ENDIF + ENDDO +*---- +* no pin coincide, symmetry not satisfied, abort +*---- + CALL XABORT(NAMSBR//': Symmetric pin not found (O-C)') + ENDIF + 115 CONTINUE + 110 CONTINUE + ENDIF + 100 CONTINUE +*---- +* Processing finished: +* print routine closing output header if required +* and return +*---- + IF(IPLOC .GE. 100) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + END diff --git a/Dragon/src/NXTTRM.f b/Dragon/src/NXTTRM.f new file mode 100644 index 0000000..f156114 --- /dev/null +++ b/Dragon/src/NXTTRM.f @@ -0,0 +1,93 @@ +*DECK NXTTRM + SUBROUTINE NXTTRM(ICTRN ,INTRN ,DRW ,DNW ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To determine the final mesh of a cell after turn. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* ICTRN turn of geometry. +* INTRN turn of cell. +* DRW mesh of geometry before turn. +* +*Parameters: output +* DNW mesh of cell after turns. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* \\\\ +* This routine is based on the LELCSY routine written by +* R. Roy and G. Marleau for the EXCELT: module. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER ICTRN,INTRN + DOUBLE PRECISION DRW(3),DNW(3) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTTRM') +*---- +* Local variables +*---- + INTEGER IDIR,IKT,IRXY + DOUBLE PRECISION DTW(3) +*---- +* 1) turn geometry +*---- + DO IDIR=1,3 + DTW(IDIR)=DRW(IDIR) + ENDDO + IKT=MOD(ICTRN-1,12)+1 + IRXY=MOD(IKT,2) + IF(IRXY .EQ. 0) THEN +*---- +* These rotations inply interchange of $X$ and $Y$ +*---- + DTW(2)=DRW(1) + DTW(1)=DRW(2) + ENDIF + DO IDIR=1,3 + DNW(IDIR)=DTW(IDIR) + ENDDO +*---- +* 2) turn cell +*---- + IKT=MOD(INTRN-1,12)+1 + IRXY=MOD(IKT,2) + IF(IRXY .EQ. 0) THEN +*---- +* These rotations inply interchange of $X$ and $Y$ +*---- + DTW(2)=DNW(1) + DTW(1)=DNW(2) + ENDIF + DO IDIR=1,3 + DNW(IDIR)=DTW(IDIR) + ENDDO +*---- +* Processing finished: +* and return +*---- + RETURN + END diff --git a/Dragon/src/NXTTRS.f b/Dragon/src/NXTTRS.f new file mode 100644 index 0000000..1beba30 --- /dev/null +++ b/Dragon/src/NXTTRS.f @@ -0,0 +1,83 @@ +*DECK NXTTRS + FUNCTION NXTTRS(ITRCUR,ISYM) +* +*---------- +* +*Purpose: +* Find new DRAGON TURN factor associated after a Cartesian symmetry +* is applied on an old DRAGON TURN factor. +* +*Copyright: +* Copyright (C) 2004 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau. +* +*Parameters: input +* ITRCUR initial turn factor. +* ISYM symmetry to consider where: +* =-1 indicates $Z$ reflection symmetry; +* = 1 indicates $X$ reflection symmetry; +* = 2 indicates $X=Y$ diagonal symmetry; +* = 3 indicates $Y$ reflection symmetry; +* = 4 indicates $X=-Y$ diagonal symmetry. +* +*Parameters: output +* NXTTRS turn factor after symmetry is applied. +* +*---- + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER ITRCUR,ISYM + INTEGER NXTTRS +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTTRS') + INTEGER MAXTUR + PARAMETER (MAXTUR=12) +*---- +* Local variables +*---- + INTEGER ISZ,ICTP,IRTR +*---- +* Test input data +* ITRCUR can be 1-8 or 13-20 +* ISYM can be 1-4 +*---- + IF((ITRCUR .LE. 0) .OR. + > (ITRCUR .GE. 9 .AND. ITRCUR .LE. 12) .OR. + > (ITRCUR .GE. 21)) CALL XABORT(NAMSBR// + > ': Invalid TURN') + IF(ISYM .LT. -1 .OR. + > ISYM .EQ. 0 .OR. + > ISYM .GT. 4 ) CALL XABORT(NAMSBR// + > ': Invalid symmetry') +*---- +* Find current symmetry factor in Z (ISZ) and current turn +* number in plane X-Y (ICTP) +*---- + ISZ=((ITRCUR-1)/MAXTUR) + ICTP=MOD(ITRCUR-1,MAXTUR)+1 + IF(ISYM .EQ. -1) THEN +*---- +* Z symmetry +*---- + ISZ=(1-ISZ) + ELSE +*---- +* X, X-Y AND Y symmetry +*---- + IRTR=((ICTP-1)/4)*4 + ICTP=MOD(4-ICTP+IRTR+ISYM,4)+5-IRTR + ENDIF + NXTTRS=ICTP+MAXTUR*ISZ + RETURN + END diff --git a/Dragon/src/NXTVCA.f b/Dragon/src/NXTVCA.f new file mode 100644 index 0000000..449ee79 --- /dev/null +++ b/Dragon/src/NXTVCA.f @@ -0,0 +1,277 @@ +*DECK NXTVCA + SUBROUTINE NXTVCA(IPRINT,NDIM ,IDIRC ,MXMESH,MAXSUR,MAXREG, + > MESH ,DMESH ,NBSUR ,NBREG ,INDXSR,SURVOL) +* +*---------- +* +*Purpose: +* Compute the volume and area associated with each region +* or surface for a Cartesian 1-D, 2-D or 3-D geometry. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau. +* +*Parameters: input +* IPRINT print level. +* NDIM dimension of problem. +* IDIRC the direction of the first axis of a Cartesian geometry +* assuming the axis are in a cyclic rotation. +* MXMESH maximum number of spatial subdivision in +* $X$, $Y$ and $Z$. +* MAXSUR maximum number of surfaces in the geometry. +* MAXREG maximum number of regions in the geometry. +* MESH effective number of spatial subdivision in +* each direction ($X$, $Y$ and $Z$). +* DMESH spatial description of the parallepiped. +* +*Parameters: output +* NBSUR number of surfaces in the geometry. +* NBREG number of regions in the geometry. +* INDXSR local indexing of surfaces/regions. +* SURVOL area/volume of regions. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*Comments: +* 1- Contents of IDIRC: +* IDIRC axes in 1-D axes in 2-D axes in 3-D +* 1 x (x,y) (x,y,z) +* 2 y (y,z) (y,z,x) +* 3 z (z,x) (z,x,y) +* 2- Contents of the DMESH array: +* mesh in $X$ is x(i)=DMESH(i,1) for i=0,MESH(1); +* mesh in $Y$ is y(j)=DMESH(j,2) for j=0,MESH(2); +* mesh in $Z$ is z(k)=DMESH(k,3) for k=0,MESH(3); +* if(IDIRC = 1) then +* ->annular regions in the $X-Y$ plane +* centre of cylinder in (x,y)=(DMESH(-1,1),DMESH(-1,2)) +* radius of shells r(l)=DMESH(l,4), l=1,MESH(4) +* else if(IDIRC = 2) then +* ->annular regions in the $Y-Z$ plane +* centre of cylinder in (y,z)=(DMESH(-1,2),DMESH(-1,3)) +* radius of shells r(l)=DMESH(l,4), l=1,MESH(4) +* else if(IDIRC = 3) then +* ->annular regions in the $Z-X$ plane +* centre of cylinder in (z,x)=(DMESH(-1,3),DMESH(-1,1)) +* radius of shells r(l)=DMESH(l,4), l=1,MESH(4) +* endif +* 3- Contents of the INDXSR array: +* For i>0 +* INDXSR(1,i)= ix is the $X$ location of region i +* INDXSR(2,i)= iy is the $Y$ location of region i +* INDXSR(3,i)= iz is the $Z$ location of region i +* INDXSR(4,i)= ir =0 is the $R$ location of region i. +* INDXSR(5,i)= not used. +* For i<0 +* INDXSR(1,i)= ix is the $X$ location of surface i +* INDXSR(2,i)= iy is the $Y$ location of surface i +* INDXSR(3,i)= iz is the $Z$ location of surface i +* INDXSR(4,i)= ir is the $R$ location of surface i. +* INDXSR(5,i)= not used. +* with INDXSR(n,i)=-1 for surface associated with +* location 0 in direction n. +* with INDXSR(n,i)=-2 for surface associated with +* location MESH(n) in direction n. +* Note that for radial regions INDXSR(n,i)=-1 does not +* exists. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,NDIM,IDIRC,MXMESH,MAXSUR,MAXREG + INTEGER MESH(4) + DOUBLE PRECISION DMESH(-1:MXMESH,4) + INTEGER NBSUR,NBREG,INDXSR(5,-MAXSUR:MAXREG) + DOUBLE PRECISION SURVOL(-MAXSUR:MAXREG) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTVCA') + INTEGER MAXDIM + PARAMETER (MAXDIM=4) + DOUBLE PRECISION DZERO,DONE + PARAMETER (DZERO=0.0D0,DONE=1.0D0) +*---- +* Local variables +*---- + INTEGER IDIR(MAXDIM),NM(MAXDIM),IDM(MAXDIM) + INTEGER ID,IDG,IDGP1,IDGP2,IDGPP,IX,IY,IZ,IXYZ,IR, + > ISUR,ISUR2,IVOL,IDIRCX + DOUBLE PRECISION DX,DY,DZ +*---- +* Data +*---- + CHARACTER CDIR(MAXDIM)*1 + SAVE CDIR + DATA CDIR /'X','Y','Z','R'/ +*---- +* Prepare loops over spatial directions as a function +* of IDIRC and NDIM. +*---- + SURVOL(-MAXSUR:MAXREG)=DZERO + IDG=0 + IDGP1=0 + IDGP2=0 + IR=0 + NBREG=1 + DO 100 ID=1,NDIM + IDG=MOD(IDIRC+ID-2,3)+1 + IDIR(ID)=IDG + NM(IDG)=MESH(IDG) + NBREG=NBREG*NM(IDG) + IDM(IDG)=1 + 100 CONTINUE + DO 101 ID=NDIM+1,3 + IDG=MOD(IDIRC+ID-2,3)+1 + IDIR(ID)=IDG + NM(IDG)=1 + IDM(IDG)=0 + 101 CONTINUE + IF(MAXREG .LT. NBREG) CALL XABORT(NAMSBR// + >': Insufficient space to store region volumes') +*---- +* number of surfaces +*---- + NBSUR=0 + DO 102 ID=1,NDIM + IDG=MOD(IDIRC+ID-2,3)+1 + NBSUR=NBSUR+2*NBREG/NM(IDG) + 102 CONTINUE + IF(MAXSUR .LT. NBSUR) CALL XABORT(NAMSBR// + >': Insufficient space to store surface areas') +*---- +* Print mesh if required +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + DO 600 ID=1,NDIM + IDG=IDIR(ID) + WRITE(IOUT,6002) 'MESH'//CDIR(IDG) + WRITE(IOUT,6006) (DMESH(IXYZ,IDG),IXYZ=0,NM(IDG)) + WRITE(IOUT,6003) + 600 CONTINUE + ENDIF +*---- +* Compute surface area +* 1- Loop over directions (110) +*---- + ISUR=0 + IDIRCX=1 + DO 110 ID=1,NDIM + IDG=MOD(IDIRCX+ID-2,3)+1 + IF(IDM(IDG) .EQ. 1) THEN + IDGP1=MOD(IDIRCX+ID-1,3)+1 + IDGP2=MOD(IDIRCX+ID,3)+1 +*---- +* 2- Loop over second normal direction (111) +*---- + ISUR2=ISUR+NM(IDGP2)*NM(IDGP1) + DO 111 IY=1,NM(IDGP2) + DY=DONE + IF(IDM(IDGP2) .EQ. 1) + > DY=DMESH(IY,IDGP2)-DMESH(IY-1,IDGP2) +*---- +* 3- Loop over first normal direction (112) +*---- + DO 112 IX=1,NM(IDGP1) + DX=DONE + IF(IDM(IDGP1) .EQ. 1) + > DX=DMESH(IX,IDGP1)-DMESH(IX-1,IDGP1) + ISUR=ISUR+1 + SURVOL(-ISUR)=DX*DY + INDXSR(IDGP1,-ISUR)=IX + INDXSR(IDGP2,-ISUR)=IY + INDXSR(IDG,-ISUR)=-1 + INDXSR(4,-ISUR)=IR + ISUR2=ISUR2+1 + SURVOL(-ISUR2)=DX*DY + INDXSR(IDGP1,-ISUR2)=IX + INDXSR(IDGP2,-ISUR2)=IY + INDXSR(IDG,-ISUR2)=-2 + INDXSR(4,-ISUR2)=IR + 112 CONTINUE + 111 CONTINUE + ISUR=ISUR2 + ENDIF + 110 CONTINUE +*---- +* Computes regional volumes +* 1- Loop on $Z$ (120) +*---- + IR=0 + IVOL=0 + SURVOL(IVOL)=DZERO + INDXSR(IDGP1,IVOL)=0 + INDXSR(IDGP2,IVOL)=0 + INDXSR(IDG,IVOL)=0 + INDXSR(4,IVOL)=0 + IDGPP=IDIR(3) + IDGP2=IDIR(2) + IDGP1=IDIR(1) + IDGPP=3 + IDGP2=2 + IDGP1=1 + DO 120 IZ=1,NM(IDGPP) + DZ=DONE + IF(IDM(IDGPP) .EQ. 1) + > DZ=DMESH(IZ,IDGPP)-DMESH(IZ-1,IDGPP) +*---- +* 2- Loop on $Y$ (121) +*---- + DO 121 IY=1,NM(IDGP2) + DY=DONE + IF(IDM(IDGP2) .EQ. 1) + > DY=DMESH(IY,IDGP2)-DMESH(IY-1,IDGP2) +*---- +* 3- Loop on $X$ (122) +*---- + DO 122 IX=1,NM(IDGP1) + DX=DONE + IF(IDM(IDGP1) .EQ. 1) + > DX=DMESH(IX,IDGP1)-DMESH(IX-1,IDGP1) + IVOL=IVOL+1 + SURVOL(IVOL)=DX*DY*DZ + INDXSR(IDGP1,IVOL)=IX + INDXSR(IDGP2,IVOL)=IY + INDXSR(IDGPP,IVOL)=IZ + INDXSR(4,IVOL)=IR + 122 CONTINUE + 121 CONTINUE + 120 CONTINUE +*---- +* Print volumes if required +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6002) 'SurVol' + WRITE(IOUT,6005) (IVOL,(INDXSR(IR,IVOL),IR=1,4),SURVOL(IVOL), + > IVOL=-NBSUR,NBREG) + WRITE(IOUT,6003) + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6002 FORMAT(A12,'={') + 6003 FORMAT('};') + 6005 FORMAT((5(I10,','),F20.10,:,',')) + 6006 FORMAT(4(F20.10,:,',')) + END diff --git a/Dragon/src/NXTVCC.f b/Dragon/src/NXTVCC.f new file mode 100644 index 0000000..12caf4b --- /dev/null +++ b/Dragon/src/NXTVCC.f @@ -0,0 +1,467 @@ +*DECK NXTVCC + SUBROUTINE NXTVCC(IPRINT,NDIM ,IDIRCX,MXMESH,MAXSUR,MAXREG, + > MESH ,DMESH ,NBSUR ,NBREG ,INDXSR,SURVOL) +* +*---------- +* +*Purpose: +* Compute the volume of each region for a mixed annular/Cartesian +* 2-D or 3-D geometry using the NXT tracking procedure. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau. +* +*Parameters: input +* IPRINT print level. +* NDIM dimension of problem. +* IDIRCX the direction of the first axis of an annular geometry +* assuming the axis are in a cyclic rotation. +* A negative value means that the external boundary is +* annular while a positive boundary implies that the +* external boundaries are Cartesian. +* MXMESH maximum number of spatial subdivision in +* $R$ and $X$, $Y$ or $Z$. +* MAXSUR maximum number of surfaces in the geometry. +* MAXREG maximum number of regions in the geometry. +* MESH effective number of spatial subdivision in $R$ +* and $X$, $Y$ or $Z$. +* DMESH spatial description of the cylinder. +* +*Parameters: output +* NBSUR number of surfaces in the geometry. +* NBREG number of regions in the geometry. +* INDXSR local indexing of surfaces/regions. +* SURVOL area/volume of regions. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*Comments: +* 1- Contents of IDIRCX: +* IDIRCX Annulus in 2-D plane Cylinder directions in 3-D +* +/- 1 (x,y) z +* +/- 2 (y,z) x +* +/- 3 (z,x) y +* 2- Contents of the DMESH array: +* mesh in $X$ is x(i)=DMESH(i,1) for i=0,MESH(1); +* mesh in $Y$ is y(j)=DMESH(j,2) for j=0,MESH(2); +* mesh in $Z$ is z(k)=DMESH(k,3) for k=0,MESH(3); +* if(IDIRC = 1) then +* ->annular regions in the $X-Y$ plane +* centre of cylinder in (x,y)=(DMESH(-1,1),DMESH(-1,2)) +* radius of shells r(l)=DMESH(l,4), l=1,MESH(4) +* else if(IDIRC = 2) then +* ->annular regions in the $Y-Z$ plane +* centre of cylinder in (y,z)=(DMESH(-1,2),DMESH(-1,3)) +* radius of shells r(l)=DMESH(l,4), l=1,MESH(4) +* else if(IDIRC = 3) then +* ->annular regions in the $Z-X$ plane +* centre of cylinder in (z,x)=(DMESH(-1,3),DMESH(-1,1)) +* radius of shells r(l)=DMESH(l,4), l=1,MESH(4) +* endif +* 3- Contents of the INDXSR array: +* For i>0 +* INDXSR(1,i)= ix is the $X$ location of region i +* INDXSR(2,i)= iy is the $Y$ location of region i +* INDXSR(3,i)= iz is the $Z$ location of region i +* INDXSR(4,i)= ir is the $R$ location of region i. +* INDXSR(5,i)= not used. +* For i<0 +* INDXSR(1,i)= ix is the $X$ location of surface i +* INDXSR(2,i)= iy is the $Y$ location of surface i +* INDXSR(3,i)= iz is the $Z$ location of surface i +* INDXSR(4,i)= ir is the $R$ location of surface i. +* INDXSR(5,i)= not used. +* with INDXSR(n,i)=-1 for surface associated with +* location 0 in direction n. +* with INDXSR(n,i)=-2 for surface associated with +* location MESH(n) in direction n. +* Note that for radial regions INDXSR(n,i)=-1 does not +* exists. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,NDIM,IDIRCX,MXMESH,MAXSUR,MAXREG + INTEGER MESH(4) + DOUBLE PRECISION DMESH(-1:MXMESH,4) + INTEGER NBSUR,NBREG,INDXSR(5,-MAXSUR:MAXREG) + DOUBLE PRECISION SURVOL(-MAXSUR:MAXREG) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTVCC') + INTEGER MAXDIM + PARAMETER (MAXDIM=4) + DOUBLE PRECISION DCUTOF + PARAMETER (DCUTOF=1.0D-8) + DOUBLE PRECISION DZERO,DONE,DTWO + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Functions +*---- + DOUBLE PRECISION XDRCST,PI + INTEGER NXTIRA,ITYIRA + DOUBLE PRECISION VOLINT +*---- +* Local variables +*---- + INTEGER NBVCAR,ID,IDG,IDIR(MAXDIM), + > NM(MAXDIM),IDM(MAXDIM) + INTEGER IDIRC,IDGP1,IDGP2,IDGPP,NBSCAR,NSKPI,NSKPF + INTEGER NBSURT,NBREGT,NRP1 + INTEGER ISURTF,ISURBF,ISURTI,ISURBI,IS,IN,IVOLF,IVOLI + INTEGER IR,IX,IY,IZ,IXYZ,ISURTN,ISURBN,ILVI,ILVT,IOF + INTEGER IDX,IDY,IDZ,IDR,NOFSUR + DOUBLE PRECISION XYCAR(4),POSANN(0:2),DZ + INTEGER IPRNT2 +*---- +* Data +*---- + CHARACTER CDIR(MAXDIM)*1 + SAVE CDIR + DATA CDIR /'X','Y','Z','R'/ +*---- +* Prepare radial and axial loops over spatial directions +* as a function of IDIRC and NDIM. +*---- + DZ=DONE + IDIRC=ABS(IDIRCX) + IF(IDIRC .EQ. 1) THEN + IDX=1 + IDY=2 + IDZ=3 + ELSE IF(IDIRC .EQ. 2) THEN + IDX=2 + IDY=3 + IDZ=1 + ELSE + IDX=3 + IDY=1 + IDZ=2 + ENDIF + IDR=4 + IPRNT2=IPRINT/2 + PI=XDRCST('Pi',' ') + IF(NDIM .EQ. 1) CALL XABORT(NAMSBR// + >': Only 2-D and 3-D problems permitted') + SURVOL(-MAXSUR:MAXREG)=DZERO +*---- +* Prepare loops over spatial directions as a function +* of IDIRC and NDIM. +* Compute number of Cartesian surfaces. +*---- + NBVCAR=1 + DO 100 ID=1,NDIM + IDG=MOD(IDIRC+ID-2,3)+1 + IDIR(ID)=IDG + NM(IDG)=MESH(IDG) + NBVCAR=NBVCAR*NM(IDG) + IDM(IDG)=1 + 100 CONTINUE + DO 101 ID=NDIM+1,3 + IDG=MOD(IDIRC+ID-2,3)+1 + IDIR(ID)=IDG + NM(IDG)=1 + IDM(IDG)=0 + 101 CONTINUE + IDG=4 + IDIR(4)=IDG + NM(IDG)=MESH(IDG) + IDM(IDG)=1 + NBREG=NBVCAR*NM(IDG) + NRP1=NM(4) + IF(IDIRCX .GT. 0) THEN + NRP1=NRP1+1 + NBREG=NBREG+NBVCAR + ENDIF + IDGP1=IDIR(1) + IDGP2=IDIR(2) + IDGPP=IDIR(3) + IF(MAXREG .LT. NBREG) CALL XABORT(NAMSBR// + >': Insufficient space to store region volumes') +*---- +* Compute number of Cartesian surfaces +* 1- Surface parallel to cylinder axis +*---- + IF(IDIRCX .GT. 0) THEN + NBSCAR=0 + NBSUR=0 + DO 102 ID=1,2 + IDG=IDIR(ID) + NBSCAR=NBSCAR+2*NBVCAR/NM(IDG) + NBSUR=NBSUR+2*NBVCAR/NM(IDG) + 102 CONTINUE + ELSE + NBSUR=0 + NBSCAR=0 + ENDIF +*---- +* 2- Surface normal to cylinder axis (if any) +*---- + NSKPI=0 + NSKPF=0 + DO 103 ID=3,NDIM + IDG=IDIR(ID) + NSKPI=NBVCAR/NM(IDG) + NSKPF=NM(4)*NSKPI + IF(IDIRCX .GT. 0) THEN + NSKPF=NSKPF+NSKPI + ENDIF + NBSCAR=NBSCAR+2*NSKPI + NBSUR=NBSUR+2*NSKPF + 103 CONTINUE + IF(MAXSUR .LT. NBSUR) CALL XABORT(NAMSBR// + >': Insufficient space to store surface areas') +*---- +* Print mesh if required +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6002) 'CENTER'//CDIR(IDGP1)//CDIR(IDGP2) + WRITE(IOUT,6006) (DMESH(-1,IDIR(ID)),ID=1,2) + WRITE(IOUT,6003) + WRITE(IOUT,6002) 'RADIAL' + WRITE(IOUT,6006) (DMESH(IR,4),IR=1,MESH(4)) + WRITE(IOUT,6003) + DO 600 ID=1,NDIM + IDG=IDIR(ID) + WRITE(IOUT,6002) 'MESH'//CDIR(IDG) + WRITE(IOUT,6006) (DMESH(IXYZ,IDG),IXYZ=0,NM(IDG)) + WRITE(IOUT,6003) + 600 CONTINUE + ENDIF + NOFSUR=NBSUR + IF(IDIRCX .GT. 0) THEN +*---- +* Compute volumes and surfaces associated with +* Cartesian regions. +*---- + CALL NXTVCA(IPRNT2,NDIM ,IDIRC ,MXMESH, + > NBSCAR,NBVCAR,MESH ,DMESH , + > NBSURT,NBREGT, + > INDXSR(1,-NBSCAR),SURVOL(-NBSCAR)) +*---- +* For 3-D case, displace Cartesian surfaces towards +* the end of SURVOL leaving space for the possible +* annular sub-surfaces. +*---- + IF(NDIM .EQ. 3) THEN + ISURTF=NBSUR + ISURTI=NBSURT + IF(IDIRC .GT. 1) THEN +*---- +* Displace Z faces +*---- + DO IZ=1,2 + DO IY=1,NM(2) + DO IX=1,NM(1) + SURVOL(-ISURTF)=SURVOL(-ISURTI) + SURVOL(-ISURTI)=DZERO + DO IN=1,5 + INDXSR(IN,-ISURTF)=INDXSR(IN,-ISURTI) + INDXSR(IN,-ISURTI)=0 + ENDDO + ISURTF=ISURTF-1 + ISURTI=ISURTI-1 + ENDDO + ENDDO + ENDDO + ENDIF + IF(IDIRC .EQ. 2) THEN +*---- +* Displace Y faces +*---- + DO IY=1,2 + DO IX=1,NM(1) + DO IZ=1,NM(3) + SURVOL(-ISURTF)=SURVOL(-ISURTI) + SURVOL(-ISURTI)=DZERO + DO IN=1,5 + INDXSR(IN,-ISURTF)=INDXSR(IN,-ISURTI) + INDXSR(IN,-ISURTI)=0 + ENDDO + ISURTF=ISURTF-1 + ISURTI=ISURTI-1 + ENDDO + ENDDO + ENDDO + ENDIF +*---- +* Displace (X (2), Y (3) , or Z (1)) and leave space for annular +*---- + NOFSUR=ISURTF + DO IS=NSKPI,1,-1 + SURVOL(-ISURTF)=SURVOL(-ISURTI) + SURVOL(-ISURTI)=DZERO + DO IN=1,5 + INDXSR(IN,-ISURTF)=INDXSR(IN,-ISURTI) + INDXSR(IN,-ISURTI)=0 + ENDDO + ISURTF=ISURTF-NRP1 + ISURTI=ISURTI-1 + ENDDO + DO IS=NSKPI,1,-1 + SURVOL(-ISURTF)=SURVOL(-ISURTI) + SURVOL(-ISURTI)=DZERO + DO IN=1,5 + INDXSR(IN,-ISURTF)=INDXSR(IN,-ISURTI) + INDXSR(IN,-ISURTI)=0 + ENDDO + ISURTF=ISURTF-NRP1 + ISURTI=ISURTI-1 + ENDDO + ENDIF +*---- +* Displace Cartesian volumes towards the end of vector +* SURVOL leaving space for the possible annular sub-regions. +*---- + IVOLF=NBREG + DO IVOLI=NBREGT,1,-1 + SURVOL(IVOLF)=SURVOL(IVOLI) + SURVOL(IVOLI)=DZERO + DO IN=1,5 + INDXSR(IN,IVOLF)=INDXSR(IN,IVOLI) + INDXSR(IN,IVOLI)=0 + ENDDO + IVOLF=IVOLF-NRP1 + ENDDO + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6002) 'SurVol' + WRITE(IOUT,6005) (ILVT,(INDXSR(IR,ILVT),IR=1,5),SURVOL(ILVT), + > ILVT=-NBSUR,NBREG) + WRITE(IOUT,6003) + ENDIF + ENDIF +*---- +* Loop over radial regions for Cartesian/annular region +* intersection. +*---- + ISURTF=NOFSUR-NSKPF+1 + ISURBF=NOFSUR-2*NSKPF+1 + DO 120 IR=NM(4),1,-1 + POSANN(0)=DMESH(IR,4) + POSANN(1)=DMESH(-1,IDGP1) + POSANN(2)=DMESH(-1,IDGP2) +*---- +* Loop over second normal direction +*---- + DO 121 IY=1,NM(IDGP2) + XYCAR(3)=DMESH(IY-1,IDGP2) + XYCAR(4)=DMESH(IY,IDGP2) +*---- +* Loop over first normal direction +*---- + DO 122 IX=1,NM(IDGP1) + XYCAR(1)=DMESH(IX-1,IDGP1) + XYCAR(2)=DMESH(IX,IDGP1) +*---- +* Rectangle/annular region intersection +*---- + ITYIRA=NXTIRA(XYCAR,POSANN,VOLINT) + IF(ITYIRA .NE. 0) THEN + IF(NDIM .EQ. 3) THEN +*---- +* For 3-D problem when +* rectangle and annular regions intersect: +* Correct top and bottom surfaces +*---- + ISURTI=ISURTF+NRP1*(IX-1+NM(IDGP1)*(IY-1)) + ISURBI=ISURBF+NRP1*(IX-1+NM(IDGP1)*(IY-1)) + ISURTN=ISURTI+IR-1 + ISURTI=ISURTI+IR + ISURBN=ISURBI+IR-1 + ISURBI=ISURBI+IR + IF(IR .NE. NM(4) .OR. IDIRCX .GT. 0) THEN + SURVOL(-ISURTI)=SURVOL(-ISURTI)-VOLINT + SURVOL(-ISURBI)=SURVOL(-ISURBI)-VOLINT + ENDIF + SURVOL(-ISURTN)=VOLINT + SURVOL(-ISURBN)=VOLINT + INDXSR(IDX,-ISURTN)=IX + INDXSR(IDX,-ISURBN)=IX + INDXSR(IDY,-ISURTN)=IY + INDXSR(IDY,-ISURBN)=IY + INDXSR(IDZ,-ISURTN)=-2 + INDXSR(IDZ,-ISURBN)=-1 + INDXSR(IDR,-ISURTN)=IR + INDXSR(IDR,-ISURBN)=IR + ENDIF +*---- +* 2- Volumes +*---- + DO 124 IZ=1,NM(IDGPP) + IF(IDIRC .EQ. 1) THEN + IOF=NRP1*(IX-1+NM(IDGP1)*((IY-1)+(IZ-1)*NM(IDGP2))) + ELSE IF(IDIRC .EQ. 2) THEN + IOF=NRP1*(IZ-1+NM(IDGPP)*((IX-1)+(IY-1)*NM(IDGP1))) + ELSE + IOF=NRP1*(IY-1+NM(IDGP2)*((IZ-1)+(IX-1)*NM(IDGPP))) + ENDIF + ILVT=IR+IOF + ILVI=ILVT+1 + DZ=DONE + IF(IDM(IDGPP) .EQ. 1) + > DZ=DMESH(IZ,IDGPP)-DMESH(IZ-1,IDGPP) + IF(IR .NE. NM(4) .OR. IDIRCX .GT. 0) THEN + SURVOL(ILVI)=SURVOL(ILVI)-VOLINT*DZ + ENDIF + SURVOL(ILVT)=VOLINT*DZ + INDXSR(IDX,ILVT)=IX + INDXSR(IDY,ILVT)=IY + INDXSR(IDZ,ILVT)=IZ + INDXSR(IDR,ILVT)=IR + 124 CONTINUE + ENDIF + 122 CONTINUE + 121 CONTINUE + 120 CONTINUE + IF(IDIRCX .LT. 0) THEN +*---- +* Add radial surfaces +*---- + ISURTN=NBSUR + DO 130 IZ=1,NM(IDGPP) + ISURTN=ISURTN+1 + IF(IDM(IDGPP) .EQ. 1) DZ=DMESH(IZ,IDGPP)-DMESH(IZ-1,IDGPP) + SURVOL(-ISURTN)=DZ*DTWO*PI*DMESH(NM(4),4) + INDXSR(IDX,-ISURTN)=0 + INDXSR(IDY,-ISURTN)=0 + INDXSR(IDZ,-ISURTN)=IZ + INDXSR(IDR,-ISURTN)=-2 + 130 CONTINUE + NBSUR=ISURTN + ENDIF + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6002) 'SurVol' + WRITE(IOUT,6005) (ILVT,(INDXSR(IR,ILVT),IR=1,5),SURVOL(ILVT), + > ILVT=-NBSUR,NBREG) + WRITE(IOUT,6003) + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6002 FORMAT(A12,'={') + 6003 FORMAT('};') + 6005 FORMAT((6(I10,','),D20.10,:,',')) + 6006 FORMAT(4(F20.10,:,',')) + END diff --git a/Dragon/src/NXTVHC.f b/Dragon/src/NXTVHC.f new file mode 100644 index 0000000..60e18c7 --- /dev/null +++ b/Dragon/src/NXTVHC.f @@ -0,0 +1,310 @@ +*DECK NXTVHC + SUBROUTINE NXTVHC(IPRINT,NDIM ,MXMESH,MAXSUR,MAXREG, + > MESH ,DMESH ,NBSUR ,NBREG ,INDXSR,SURVOL, + > POSTRI) +* +*---------- +* +*Purpose: +* Compute the volume and area associated with each region +* or surface for a annular/hexagon with triangular mesh +* in 2-D or 3-D geometry. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau. +* +*Parameters: input +* IPRINT print level. +* NDIM dimension of problem. +* MXMESH maximum number of spatial subdivision in +* $X$, $Y$ and $Z$. +* MAXSUR maximum number of surfaces in the geometry. +* MAXREG maximum number of regions in the geometry. +* MESH effective number of spatial subdivision in +* each direction ($X$, $Y$ and $Z$). +* DMESH spatial description of the parallepiped. +* POSTRI triangle position: +* POSTRI(1,*,*,*) is X position; +* POSTRI(2,*,*,*) is Y position; +* POSTRI(*,1,*,*) is location of first corner; +* POSTRI(*,2,*,*) is location of second corner; +* POSTRI(*,3,*,*) is location of third corner; +* POSTRI(*,*,i,j) is location of triangle i in cector j. +* +*Parameters: output +* NBSUR number of surfaces in the geometry. +* NBREG number of regions in the geometry. +* INDXSR local indexing of surfaces/regions. +* SURVOL area/volume of regions. +* +*Comments: +* 1- Contents of the DMESH array: +* hexagonal mesh is DMESH(i,1) for i=0,MESH(1); +* mesh in $Z$ is z(k)=DMESH(k,3) for k=0,MESH(3); +* annular regions in the $X-Y$ plane +* centre of cylinder in (x,y)=(DMESH(-1,1),DMESH(-1,2)) +* radius of shells r(l)=DMESH(l,4), l=1,MESH(4) +* 2- Contents of the INDXSR array: +* For i>0 +* INDXSR(1,i)= iu is the $U$ location of region i +* INDXSR(2,i)= iv is the $V$ location of region i +* INDXSR(3,i)= iz is the $Z$ location of region i +* INDXSR(4,i)= ir is the $R$ location of region i +* INDXSR(5,i)= iw is the $W$ location of region i +* For i<0 +* INDXSR(1,i)= iu is the $U$ location of surface i +* INDXSR(2,i)= iv is the $V$ location of surface i +* INDXSR(3,i)= iz is the $Z$ location of surface i +* INDXSR(4,i)= ir is the $R$ location of surface i +* INDXSR(5,i)= iw is the $W$ location of surface i +* with INDXSR(n,i)=-1 for surface associated with +* location 0 in direction n. +* with INDXSR(n,i)=-2 for surface associated with +* location MESH(n) in direction n. +* Note that for radial regions INDXSR(n,i)=-1 does not +* exists. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,NDIM,MXMESH,MAXSUR,MAXREG + INTEGER MESH(4) + DOUBLE PRECISION DMESH(-1:MXMESH,4) + INTEGER NBSUR,NBREG,INDXSR(5,-MAXSUR:MAXREG) + DOUBLE PRECISION SURVOL(-MAXSUR:MAXREG) + DOUBLE PRECISION POSTRI(2,3,MXMESH*MXMESH,6) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTVHC') + INTEGER MAXDIM + PARAMETER (MAXDIM=4) + DOUBLE PRECISION DZERO + PARAMETER (DZERO=0.0D0) +*---- +* Functions +*---- + INTEGER NXTITA,ITYITA + DOUBLE PRECISION VOLINT +*---- +* Local variables +*---- + INTEGER NX,NZ,NR,NRTP,NRP,NSTP,NSP,NRTPP,NRP1, + > IT,IZ,IR,ISECT,IOFS,IVSI,NBVHEX,NBSHEX + DOUBLE PRECISION POSANN(0:2),VOLZ + INTEGER ILVI,ILVT,IDIR,IOFZ,IS1,ISURTF,ISURTI, + > IVOLF,IVOLI,NBREGT, + > NSKPF,NSKPI,NBSURT +*---- +* Prepare loop over Z-direction. +*---- + NX=MESH(1) + NZ=MESH(3) + NR=MESH(4) + NRTP=NX**2 + NRP=6*NRTP + NSTP=2*NX-1 + NSP=6*NSTP + NRP1=NR+1 + NRTPP=NRP*NRP1 +*---- +* Compute number of surfaces +* 1- Surface parallel to cylinder axis +*---- + NBVHEX=NRP + NBREG=NRTPP + NBSUR=NSP + NBSHEX=NSP + IF(NDIM .EQ. 3) THEN + NBREG=NBREG*NZ + NBSUR=NBSHEX*NZ+2*NRTPP + NBVHEX=NBVHEX*NZ + NBSHEX=NBSHEX*NZ+2*NRP + ENDIF + NBREGT=NBVHEX + NBSURT=NBSHEX +*---- +* 2- Surface normal to cylinder axis (if any) +*---- + NSKPI=0 + NSKPF=0 + IF(NDIM .NE. 3) THEN + NSKPI=NRP + NSKPF=(NR+1)*NSKPI + ENDIF + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6010) 'H',NX + WRITE(IOUT,6011) 'MESHH =' + WRITE(IOUT,6012) (DMESH(IT,1),IT=-1,2*NX) + IF(NDIM .EQ. 3) THEN + WRITE(IOUT,6010) 'Z',NZ + WRITE(IOUT,6011) 'MESHZ =' + WRITE(IOUT,6012) (DMESH(IZ,3),IZ=-1,NZ) + ENDIF + WRITE(IOUT,6010) 'R',NR + WRITE(IOUT,6011) 'MESHR =' + WRITE(IOUT,6012) (DMESH(IR,4),IR=-1,NR) + ENDIF + SURVOL(-MAXSUR:MAXREG)=DZERO +*---- +* Call NXTVHT to obtain the triangles volumes and external surfaces +*---- + CALL NXTVHT(IPRINT,NDIM ,MXMESH,NBSHEX,NBVHEX, + > MESH ,DMESH ,NBSURT,NBREGT, + > INDXSR(1,-NBSHEX),SURVOL(-NBSHEX)) +*---- +* For 3-D case, displace hexagonal surfaces towards +* the end of SURVOL leaving space for the possible +* annular sub-surfaces (skip NR spaces for radial volumes). +*---- + ISURTF=NBSUR + ISURTI=NBSURT + IF(NDIM .EQ. 3) THEN + DO IZ=1,2 + DO IT=1,NRP + SURVOL(-ISURTF)=SURVOL(-ISURTI) + SURVOL(-ISURTI)=DZERO + DO IDIR=1,5 + INDXSR(IDIR,-ISURTF)=INDXSR(IDIR,-ISURTI) + INDXSR(IDIR,-ISURTI)=0 + ENDDO + ISURTF=ISURTF-NRP1 + ISURTI=ISURTI-1 + ENDDO + ENDDO + ENDIF +*---- +* Displace triangular volumes towards the end of vector +* SURVOL leaving space for the possible annular sub-regions. +*---- + IVOLF=NBREG + DO IVOLI=NBREGT,1,-1 + SURVOL(IVOLF)=SURVOL(IVOLI) + SURVOL(IVOLI)=DZERO + DO IDIR=1,5 + INDXSR(IDIR,IVOLF)=INDXSR(IDIR,IVOLI) + INDXSR(IDIR,IVOLI)=0 + ENDDO + IVOLF=IVOLF-NRP1 + ENDDO + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6002) 'SurVolTri' + WRITE(IOUT,6005) (ILVT,(INDXSR(IDIR,ILVT),IDIR=1,5), + > SURVOL(ILVT),ILVT=-NBSUR,NBREG) + WRITE(IOUT,6003) + ENDIF +*---- +* Loop over radial regions for triangular region +* intersection. +*---- + POSANN(1)=0.0 + POSANN(2)=0.0 + DO IR=NR,1,-1 + POSANN(0)=DMESH(IR,4) +*---- +* Loop over a single sector of triangle since centered annular +* region +*---- + ISECT=1 + DO IT=1,NRTP + ITYITA=NXTITA(POSTRI(1,1,IT,ISECT),POSANN,VOLINT) + IF(ITYITA .NE. 0) THEN +* WRITE(IOUT,*) 'IR,ISECT,IT,ITYITA,VOLINT', +* > IR,ISECT,IT,ITYITA,VOLINT + IF(NDIM .EQ. 3) THEN +*---- +* Remove contribution from top and bottom surfaces +*---- + IOFZ=NSP*NZ + DO IZ=1,2 + IOFS=(IT-1)*NRP1+IR + DO IS1=1,6 + ISURTF=IOFZ+IOFS + ISURTI=ISURTF+1 + SURVOL(-ISURTI)=SURVOL(-ISURTI)-VOLINT + SURVOL(-ISURTF)=VOLINT + INDXSR(1,-ISURTF)=INDXSR(1,-ISURTI) + INDXSR(2,-ISURTF)=INDXSR(2,-ISURTI) + INDXSR(3,-ISURTF)=INDXSR(3,-ISURTI) + INDXSR(4,-ISURTF)=IR + INDXSR(5,-ISURTF)=INDXSR(5,-ISURTI) + IOFS=IOFS+NRP1*NRTP + ENDDO + IOFZ=IOFZ+NRTPP + ENDDO +*---- +* Remove contributions to volumes +*---- + IOFZ=0 + DO IZ=1,NZ + IOFS=(IT-1)*NRP1+IR + VOLZ=VOLINT*(DMESH(IZ,3)-DMESH(IZ-1,3)) + DO IS1=1,6 + ILVT=IOFZ+IOFS + ILVI=ILVT+1 + SURVOL(ILVI)=SURVOL(ILVI)-VOLZ + SURVOL(ILVT)=VOLZ + INDXSR(1,ILVT)=INDXSR(1,ILVI) + INDXSR(2,ILVT)=INDXSR(2,ILVI) + INDXSR(3,ILVT)=INDXSR(3,ILVI) + INDXSR(4,ILVT)=IR + INDXSR(5,ILVT)=INDXSR(5,ILVI) + IOFS=IOFS+NRP1*NRTP + ENDDO + IOFZ=IOFZ+NRTPP + ENDDO + ELSE + IOFS=(IT-1)*NRP1+IR + VOLZ=VOLINT + DO IS1=1,6 + ILVT=IOFS + ILVI=ILVT+1 + SURVOL(ILVI)=SURVOL(ILVI)-VOLZ + SURVOL(ILVT)=VOLZ + INDXSR(1,ILVT)=INDXSR(1,ILVI) + INDXSR(2,ILVT)=INDXSR(2,ILVI) + INDXSR(3,ILVT)=INDXSR(3,ILVI) + INDXSR(4,ILVT)=IR + INDXSR(5,ILVT)=INDXSR(5,ILVI) + IOFS=IOFS+NRP1*NRTP + ENDDO + ENDIF + ENDIF + ENDDO + ENDDO +*---- +* Print surfaces and volumes if required and return +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6002) 'SurVolTriAnn' + WRITE(IOUT,6005) (IVSI,(INDXSR(IR,IVSI),IR=1,5),SURVOL(IVSI), + > IVSI=-NBSUR,NBREG) + WRITE(IOUT,6003) + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6002 FORMAT(A12,'={') + 6003 FORMAT('};') + 6005 FORMAT((6(I10,','),F20.10,:,',')) + 6010 FORMAT(1X,'MESH DIMENSIONS IN ',A1,' =',I10) + 6011 FORMAT(1X,A7) + 6012 FORMAT(5F20.10) + END diff --git a/Dragon/src/NXTVHT.f b/Dragon/src/NXTVHT.f new file mode 100644 index 0000000..ac8ba4d --- /dev/null +++ b/Dragon/src/NXTVHT.f @@ -0,0 +1,449 @@ +*DECK NXTVHT + SUBROUTINE NXTVHT(IPRINT,NDIM ,MXMESH,MAXSUR,MAXREG, + > MESH ,DMESH ,NBSUR ,NBREG ,INDXSR,SURVOL) +* +*---------- +* +*Purpose: +* Compute the volume and area associated with each region +* or surface for an hexagon with triangular mesh +* in 2-D or 3-D geometry. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau. +* +*Parameters: input +* IPRINT print level. +* NDIM dimension of problem. +* MXMESH maximum number of spatial subdivision in +* $X$, $Y$ and $Z$. +* MAXSUR maximum number of surfaces in the geometry. +* MAXREG maximum number of regions in the geometry. +* MESH effective number of spatial subdivision in +* each direction ($X$, $Y$ and $Z$). +* DMESH spatial description of the parallepiped. +* +*Parameters: output +* NBSUR number of surfaces in the geometry. +* NBREG number of regions in the geometry. +* INDXSR local indexing of surfaces/regions. +* SURVOL area/volume of regions. +* +*Comments: +* 1- Contents of the DMESH array: +* hexagonal mesh is DMESH(i,1) for i=0,MESH(1); +* mesh in $Z$ is z(k)=DMESH(k,3) for k=0,MESH(3); +* annular regions in the $X-Y$ plane +* centre of cylinder in (x,y)=(DMESH(-1,1),DMESH(-1,2)) +* radius of shells r(l)=DMESH(l,4), l=1,MESH(4) +* 2- Contents of the INDXSR array: +* For i>0 +* INDXSR(1,i)= iu is the $U$ location of region i +* INDXSR(2,i)= iv is the $V$ location of region i +* INDXSR(3,i)= iz is the $Z$ location of region i +* INDXSR(4,i)= ir is the $R$ location of region i +* INDXSR(5,i)= iw is the $W$ location of region i +* For i<0 +* INDXSR(1,i)= iu is the $U$ location of surface i +* INDXSR(2,i)= iv is the $V$ location of surface i +* INDXSR(3,i)= iz is the $Z$ location of surface i +* INDXSR(4,i)= ir is the $R$ location of surface i +* INDXSR(5,i)= iw is the $W$ location of surface i +* with INDXSR(n,i)=-1 for surface associated with +* location 0 in direction n. +* with INDXSR(n,i)=-2 for surface associated with +* location MESH(n) in direction n. +* Note that for radial regions INDXSR(n,i)=-1 does not +* exists. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,NDIM,MXMESH,MAXSUR,MAXREG + INTEGER MESH(4) + DOUBLE PRECISION DMESH(-1:MXMESH,4) + INTEGER NBSUR,NBREG,INDXSR(5,-MAXSUR:MAXREG) + DOUBLE PRECISION SURVOL(-MAXSUR:MAXREG) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTVHT') + INTEGER MAXDIM + PARAMETER (MAXDIM=4) + DOUBLE PRECISION DZERO,DONE,DHALF,DSQ3O2 + PARAMETER (DZERO=0.0D0,DONE=1.0D0, + > DHALF=0.5D0,DSQ3O2=0.86602540378444D0) +*---- +* Local variables +*---- + INTEGER NX,NZ,NRTP,NRP,NSTP,NSP,IX,IZ,ISECT,IR,IS, + > IOFS,IVSI,JVSI,IVSIR,NVSIR,ISUVW,IZ1 + DOUBLE PRECISION SIDEU,SIDEUP,SIDER,SIDERP,SIDEL,SIDELP, + > AREAT,AREAL,AREAR,DZ +*---- +* Prepare loop over Z-direction. +*---- + NX=MESH(1) + NZ=MESH(3) + NRTP=NX**2 + NRP=6*NRTP + NSTP=2*NX-1 + NSP=6*NSTP + IF(NDIM .EQ. 3) THEN + NBREG=NRP*NZ + NBSUR=NSP*NZ+2*NRP + ELSE + NBREG=NRP + NBSUR=NSP + ENDIF + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6010) NX,NZ + WRITE(IOUT,6011) 'MESHH =' + WRITE(IOUT,6012) (DMESH(IX,1),IX=-1,2*NX) + IF(NDIM .EQ. 3) THEN + WRITE(IOUT,6011) 'MESHZ =' + WRITE(IOUT,6012) (DMESH(IZ,3),IZ=-1,NZ) + ENDIF + WRITE(IOUT,6002) 'SurVol init' + WRITE(IOUT,6005) (IVSI,(INDXSR(IR,IVSI),IR=1,5),SURVOL(IVSI), + > IVSI=-NBSUR,NBREG) + WRITE(IOUT,6003) + ENDIF + SURVOL(-MAXSUR:MAXREG)=DZERO +*---- +* All the triangles are equilateral and have the same surface area +* except possibly those in the last crown because this last crown +* may be thinner than the other +* 1) Find first the area of generic triangle +*---- + SIDEU=DMESH(NX+1,1)-DMESH(NX,1) + SIDEUP=SIDEU/DSQ3O2 + AREAT=DHALF*SIDEU*SIDEUP + SURVOL(1:NRP)=AREAT +*---- +* Process last crown +* for right triangle remove volume past last cell boundary +* for left triangle volume extends only to cell boundary +* Add surfaces +*---- + SIDEL=DMESH(1,1)-DMESH(0,1) + SIDELP=SIDEL/DSQ3O2 + SIDER=SIDEU-SIDEL + SIDERP=SIDER/DSQ3O2 + AREAL=DHALF*SIDEL*SIDELP + AREAR=AREAT-DHALF*SIDER*SIDERP +*---- +* Finish filling first plan with AREA +*---- + IS=0 + IOFS=NRTP-NSTP + DO ISECT=1,6 +*---- +* right triangles +*---- + DO IX=1,NX-1 + IR=IX+IOFS + IS=IS-1 + SURVOL(IR)=AREAR + SURVOL(IS)=SIDERP + ENDDO +*---- +* Left triangles +*---- + DO IX=NX,NSTP + IR=IX+IOFS + IS=IS-1 + SURVOL(IR)=AREAL + SURVOL(IS)=SIDELP + ENDDO + IOFS=IOFS+NRTP + ENDDO + IF(NDIM .EQ. 3) THEN +*---- +* Hexagonal Surfaces +*---- + DO IZ=NZ,1,-1 + DZ=DMESH(IZ,3)-DMESH(IZ-1,3) + IX=-NSP*(IZ-1) + DO IS=-1,-NSP,-1 + SURVOL(IX+IS)=DZ*SURVOL(IS) + ENDDO + ENDDO +*---- +* Fill bottom face and top face +*---- + IS=-NSP*NZ + DO IR=1,NRP + IS=IS-1 + SURVOL(IS)=SURVOL(IR) + SURVOL(IS-NRP)=SURVOL(IR) + ENDDO +*---- +* Fill all planes with volumes +*---- + DO IZ=NZ,1,-1 + DZ=DMESH(IZ,3)-DMESH(IZ-1,3) + IX=NRP*(IZ-1) +*---- +* Volumes +*---- + DO IR=1,NRP + SURVOL(IX+IR)=DZ*SURVOL(IR) + ENDDO + ENDDO + ENDIF +*---- +* Fill INDXSR to identify regions and volumes +* Process first sector (-pi/6 to pi/6) for volume +* First plane or 2-D +*---- + IF(NDIM .EQ. 3) THEN + IZ1=1 + ELSE + IZ1=0 + ENDIF + IVSI=0 + DO IX=1,NX +*---- +* First line of triangle in the crown +*---- + DO IR=1,IX-1 + IVSI=IVSI+1 + INDXSR(1,IVSI)=NX+IX + INDXSR(5,IVSI)=NX+IX-IR + INDXSR(3,IVSI)=IZ1 + INDXSR(2,IVSI)=NX+IR + ENDDO +*---- +* Second line of triangle in the crown +*---- + DO IR=1,IX + IVSI=IVSI+1 + INDXSR(1,IVSI)=NX+IX + INDXSR(5,IVSI)=NX+IX-IR+1 + INDXSR(3,IVSI)=IZ1 + INDXSR(2,IVSI)=NX+IR + ENDDO + ENDDO +*---- +* Complete for sectors 2-6 on first plane +*---- + NVSIR=IVSI + IVSIR=NVSIR + ISUVW=2*NX+1 + DO ISECT=2,6 + IF(ISECT .EQ. 6) THEN + DO JVSI=1,NVSIR + IVSIR=IVSIR+1 + INDXSR(1,IVSIR)=INDXSR(2,JVSI) + INDXSR(2,IVSIR)=ISUVW-INDXSR(5,JVSI) + INDXSR(3,IVSIR)=IZ1 + INDXSR(5,IVSIR)=INDXSR(1,JVSI) + ENDDO + ELSE IF (ISECT.EQ.5) THEN + DO JVSI=1,NVSIR + IVSIR=IVSIR+1 + INDXSR(1,IVSIR)=ISUVW-INDXSR(5,JVSI) + INDXSR(2,IVSIR)=ISUVW-INDXSR(1,JVSI) + INDXSR(3,IVSIR)=IZ1 + INDXSR(5,IVSIR)=INDXSR(2,JVSI) + ENDDO + ELSE IF (ISECT.EQ.4) THEN + DO JVSI=1,NVSIR + IVSIR=IVSIR+1 + INDXSR(1,IVSIR)=ISUVW-INDXSR(1,JVSI) + INDXSR(2,IVSIR)=ISUVW-INDXSR(2,JVSI) + INDXSR(3,IVSIR)=IZ1 + INDXSR(5,IVSIR)=ISUVW-INDXSR(5,JVSI) + ENDDO + ELSE IF (ISECT.EQ.3) THEN + DO JVSI=1,NVSIR + IVSIR=IVSIR+1 + INDXSR(1,IVSIR)=ISUVW-INDXSR(2,JVSI) + INDXSR(2,IVSIR)=INDXSR(5,JVSI) + INDXSR(3,IVSIR)=IZ1 + INDXSR(5,IVSIR)=ISUVW-INDXSR(1,JVSI) + ENDDO + ELSE IF (ISECT.EQ.2) THEN + DO JVSI=1,NVSIR + IVSIR=IVSIR+1 + INDXSR(1,IVSIR)=INDXSR(5,JVSI) + INDXSR(2,IVSIR)=INDXSR(1,JVSI) + INDXSR(3,IVSIR)=IZ1 + INDXSR(5,IVSIR)=ISUVW-INDXSR(2,JVSI) + ENDDO + ENDIF + ENDDO +*---- +* Process other planes in 3-D +*---- + IVSI=NRP + DO IZ=2,NZ + DO IR=1,NRP + IVSI=IVSI+1 + INDXSR(1,IVSI)=INDXSR(1,IR) + INDXSR(2,IVSI)=INDXSR(2,IR) + INDXSR(3,IVSI)=IZ + INDXSR(5,IVSI)=INDXSR(5,IR) + ENDDO + ENDDO +*---- +* Process surfaces +* First plane or 2-D +*---- + IVSI=0 + IOFS=3-6*NX + IX=NX +*---- +* Sector 1 and 4 +* First line of triangle on the last crown +*---- + DO IR=1,IX-1 + IVSI=IVSI-1 + INDXSR(1,IVSI+IOFS)=-1 + INDXSR(5,IVSI+IOFS)=IR+1 + INDXSR(3,IVSI+IOFS)=IZ1 + INDXSR(2,IVSI+IOFS)=NX+1-IR + INDXSR(1,IVSI)=-2 + INDXSR(5,IVSI)=NX+IX-IR + INDXSR(3,IVSI)=IZ1 + INDXSR(2,IVSI)=NX+IR + ENDDO +*---- +* Second line of triangle on the last crown +*---- + DO IR=1,IX + IVSI=IVSI-1 + INDXSR(1,IVSI+IOFS)=-1 + INDXSR(5,IVSI+IOFS)=IR + INDXSR(3,IVSI+IOFS)=IZ1 + INDXSR(2,IVSI+IOFS)=NX+1-IR + INDXSR(1,IVSI)=-2 + INDXSR(5,IVSI)=NX+IX-IR+1 + INDXSR(3,IVSI)=IZ1 + INDXSR(2,IVSI)=NX+IR + ENDDO +*---- +* Sector 2 and 5 +* First line of triangle on the last crown +*---- + DO IR=1,IX-1 + IVSI=IVSI-1 + INDXSR(1,IVSI+IOFS)=IR+1 + INDXSR(5,IVSI+IOFS)=NX+IR + INDXSR(3,IVSI+IOFS)=IZ1 + INDXSR(2,IVSI+IOFS)=-1 + INDXSR(1,IVSI)=2*NX-IR + INDXSR(5,IVSI)=NX+1-IR + INDXSR(3,IVSI)=IZ1 + INDXSR(2,IVSI)=-2 + ENDDO +*---- +* Second line of triangle on the last crown +*---- + DO IR=1,IX + IVSI=IVSI-1 + INDXSR(1,IVSI+IOFS)=IR + INDXSR(5,IVSI+IOFS)=NX+IR + INDXSR(3,IVSI+IOFS)=IZ1 + INDXSR(2,IVSI+IOFS)=-1 + INDXSR(1,IVSI)=2*NX+1-IR + INDXSR(5,IVSI)=NX+1-IR + INDXSR(3,IVSI)=IZ1 + INDXSR(2,IVSI)=-2 + ENDDO +*---- +* Sector 3 and 6 +* First line of triangle on the last crown +*---- + DO IR=1,IX-1 + IVSI=IVSI-1 + INDXSR(1,IVSI)=NX+1-IR + INDXSR(5,IVSI)=-1 + INDXSR(3,IVSI)=IZ1 + INDXSR(2,IVSI)=2*NX-IR + INDXSR(1,IVSI+IOFS)=NX+IR + INDXSR(5,IVSI+IOFS)=-2 + INDXSR(3,IVSI+IOFS)=IZ1 + INDXSR(2,IVSI+IOFS)=IR+1 + ENDDO +*---- +* Second line of triangle on the last crown +*---- + DO IR=1,IX + IVSI=IVSI-1 + INDXSR(1,IVSI)=NX+1-IR + INDXSR(5,IVSI)=-1 + INDXSR(3,IVSI)=IZ1 + INDXSR(2,IVSI)=2*NX+1-IR + INDXSR(1,IVSI+IOFS)=NX+IR + INDXSR(5,IVSI+IOFS)=-2 + INDXSR(3,IVSI+IOFS)=IZ1 + INDXSR(2,IVSI+IOFS)=IR + ENDDO + IF(NDIM .EQ. 3) THEN +*---- +* Process other planes in 3-D +*---- + IVSI=IVSI-6*NX+3 + DO IZ=2,NZ + DO IR=-1,-NSP,-1 + IVSI=IVSI-1 + INDXSR(1,IVSI)=INDXSR(1,IR) + INDXSR(2,IVSI)=INDXSR(2,IR) + INDXSR(3,IVSI)=IZ + INDXSR(5,IVSI)=INDXSR(5,IR) + ENDDO + ENDDO +*---- +* Process bottom and top faces if required +*---- + DO IR=1,NRP + IVSI=IVSI-1 + IVSIR=IVSI-NRP + INDXSR(1,IVSI)=INDXSR(1,IR) + INDXSR(2,IVSI)=INDXSR(2,IR) + INDXSR(3,IVSI)=-1 + INDXSR(5,IVSI)=INDXSR(5,IR) + INDXSR(1,IVSIR)=INDXSR(1,IR) + INDXSR(2,IVSIR)=INDXSR(2,IR) + INDXSR(3,IVSIR)=-2 + INDXSR(5,IVSIR)=INDXSR(5,IR) + ENDDO + ENDIF +*---- +* Print surfaces and volumes if required and return +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6002) 'SurVol' + WRITE(IOUT,6005) (IVSI,(INDXSR(IR,IVSI),IR=1,5),SURVOL(IVSI), + > IVSI=-NBSUR,NBREG) + WRITE(IOUT,6003) + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6002 FORMAT(A12,'={') + 6003 FORMAT('};') + 6005 FORMAT((6(I10,','),F20.10,:,',')) + 6010 FORMAT(1X,'MESH DIMENSIONS =',2I10) + 6011 FORMAT(1X,A7) + 6012 FORMAT(5F20.10) + END diff --git a/Dragon/src/NXTVOL.f b/Dragon/src/NXTVOL.f new file mode 100644 index 0000000..66ff77f --- /dev/null +++ b/Dragon/src/NXTVOL.f @@ -0,0 +1,333 @@ +*DECK NXTVOL + SUBROUTINE NXTVOL(IPTRK ,IPRINT,MAXMSS,ITYPG ,IDIRC ,IGEO , + > ILEV ,NM ,NREG ,NSUR ,NREGN ,NSURN , + > MAXPIN,NBPIN ,ITPIN ,DRAPIN,IDREG ,IDSUR , + > DAMESH,INDXSR,NAREG ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute regional volumes. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure. +* IPRINT intermediate printing level for output. +* MAXMSS maximum number of elements in MESH array after split. +* ITYPG type of geometry. +* IDIRC direction of cell (1 for XYZ, 2 for YZX and 3 for ZXY). +* Note that for CAR3D without pins IDIRC=1 while for +* for CAR3D with pins IDIRC specified by pins direction. +* IGEO geometry number. +* ILEV geometry level. +* NM mesh size in all directions ($X$, $Y$, $Z$ and $R$). +* NREG maximum number of regions in splitted geometry. +* NSUR maximum number of surfaces in splitted geometry. +* NREGN number of regions in splitted geometry after symmetry. +* NSURN number of surfaces in splitted geometry after symmetry. +* MAXPIN maximum number of pins. +* NBPIN number of pins. +* ITPIN pins identification. +* DRAPIN pins position. +* IDREG region identifier after symmetry. +* IDSUR surface identifier after symmetry. +* DAMESH final mesh description for geometry. +* +*Parameters: input/output +* NAREG last region number considered. +* +*Parameters: output +* INDXSR local indexing of surfaces/regions. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPTRK + INTEGER IPRINT,MAXMSS,ITYPG,IGEO,ILEV,NM(4), + > NREG,NSUR,NREGN,NSURN + INTEGER MAXPIN,NBPIN + DOUBLE PRECISION DRAPIN(-1:4,MAXPIN) + INTEGER IDREG(NREG),IDSUR(NSUR),ITPIN(3,MAXPIN) + DOUBLE PRECISION DAMESH(-1:MAXMSS,4) + INTEGER NAREG + INTEGER INDXSR(5,-NSUR:NREG) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTVOL') + DOUBLE PRECISION DCUTOF,DCUTOS,DZERO,DONE + PARAMETER (DCUTOF=1.0D-8,DCUTOS=1.0D-6,DZERO=0.0D0, + > DONE=1.0D0) +*---- +* Local variables +*---- + INTEGER NDIM,IDIRC,IDIRCX,NBSUR,NBREG + CHARACTER NAMREC*12 + INTEGER IREG,IDV,ISUR,IDS,INV,INS,LSTREG + DOUBLE PRECISION VMAX,SMAX +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: INREN + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SURVOL,SVT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:) :: POSTRI +*---- +* Data +*---- + CHARACTER CLEV(2)*1 + SAVE CLEV + DATA CLEV /'C','P'/ +*---- +* Scratch storage allocation +* SURVOL area/volume of regions. +* SVT temporary area/volume of regions. +* INREN temporary vector for new region/surfaces identification. +*---- + ALLOCATE(INREN(-NSURN:NREGN)) + ALLOCATE(SURVOL(-NSUR:NREG),SVT(-NSURN:NREGN)) + SURVOL(-NSUR:NREG)=DZERO +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6010) + WRITE(IOUT,6014) (IDREG(IDV),IDV=1,NREG) + WRITE(IOUT,6012) + WRITE(IOUT,6014) (IDSUR(IDS),IDS=1,NSUR) + ENDIF + NDIM=3 + IF(ITYPG .EQ. 5 .OR. ITYPG .EQ. 7) THEN + IF(ITYPG .EQ. 5) NDIM=2 + CALL NXTVCA(IPRINT,NDIM ,IDIRC ,MAXMSS,NSUR ,NREG , + > NM ,DAMESH,NBSUR ,NBREG ,INDXSR,SURVOL) + IF(NBPIN .GT. 0) THEN +*---- +* Remove pin contributions +*---- + CALL NXTPCA(IPRINT,NDIM ,IDIRC ,MAXMSS,NSUR ,NREG , + > NM ,DAMESH,NBPIN ,ITPIN ,DRAPIN, + > NBSUR ,NBREG ,INDXSR,SURVOL) + ENDIF + ELSE IF(ITYPG .EQ. 3 .OR. ITYPG .EQ. 6) THEN + IF(ITYPG .EQ. 3) NDIM=2 + IDIRCX=-IDIRC + DAMESH(0,1)=-DAMESH(-1,1)-DAMESH(NM(4),4) + DAMESH(NM(1),1)=-DAMESH(-1,1)+DAMESH(NM(4),4) + DAMESH(0,2)=-DAMESH(-1,2)-DAMESH(NM(4),4) + DAMESH(NM(2),2)=-DAMESH(-1,2)+DAMESH(NM(4),4) + CALL NXTVCC(IPRINT,NDIM ,IDIRCX,MAXMSS,NSUR ,NREG , + > NM ,DAMESH,NBSUR ,NBREG ,INDXSR,SURVOL) + IF(NBPIN .GT. 0) THEN +*---- +* Remove pin contributions +*---- + CALL NXTPCC(IPRINT,NDIM ,IDIRCX,MAXMSS,NSUR ,NREG , + > NM ,DAMESH,NBPIN ,ITPIN ,DRAPIN, + > NBSUR ,NBREG ,INDXSR,SURVOL) + ENDIF + ELSE IF(ITYPG .EQ. 10 ) THEN + NDIM=3 + IDIRCX=-IDIRC + DAMESH(0,2)=-DAMESH(-1,2)-DAMESH(NM(4),4) + DAMESH(NM(2),2)=-DAMESH(-1,2)+DAMESH(NM(4),4) + DAMESH(0,3)=-DAMESH(-1,3)-DAMESH(NM(4),4) + DAMESH(NM(3),3)=-DAMESH(-1,3)+DAMESH(NM(4),4) + CALL NXTVCC(IPRINT,NDIM ,IDIRCX,MAXMSS,NSUR ,NREG , + > NM ,DAMESH,NBSUR ,NBREG ,INDXSR,SURVOL) + IF(NBPIN .GT. 0) THEN +*---- +* Remove pin contributions +*---- + CALL NXTPCC(IPRINT,NDIM ,IDIRCX,MAXMSS,NSUR ,NREG , + > NM ,DAMESH,NBPIN ,ITPIN ,DRAPIN, + > NBSUR ,NBREG ,INDXSR,SURVOL) + ENDIF + ELSE IF(ITYPG .EQ. 11 ) THEN + NDIM=3 + IDIRCX=-IDIRC + DAMESH(0,3)=-DAMESH(-1,3)-DAMESH(NM(4),4) + DAMESH(NM(3),3)=-DAMESH(-1,3)+DAMESH(NM(4),4) + DAMESH(0,1)=-DAMESH(-1,1)-DAMESH(NM(4),4) + DAMESH(NM(1),1)=-DAMESH(-1,1)+DAMESH(NM(4),4) + CALL NXTVCC(IPRINT,NDIM ,IDIRCX,MAXMSS,NSUR ,NREG , + > NM ,DAMESH,NBSUR ,NBREG ,INDXSR,SURVOL) + IF(NBPIN .GT. 0) THEN +*---- +* Remove pin contributions +*---- + CALL NXTPCC(IPRINT,NDIM ,IDIRCX,MAXMSS,NSUR ,NREG , + > NM ,DAMESH,NBPIN ,ITPIN ,DRAPIN, + > NBSUR ,NBREG ,INDXSR,SURVOL) + ENDIF + ELSE IF(ITYPG .EQ. 12 .OR. ITYPG .EQ. 13 ) THEN + IF(ITYPG .EQ. 12) NDIM=2 + CALL NXTVHT(IPRINT,NDIM ,MAXMSS,NSUR ,NREG , + > NM ,DAMESH,NBSUR ,NBREG ,INDXSR,SURVOL) + IF(NBPIN .GT. 0) THEN +*---- +* Remove pin contributions +*---- + ALLOCATE(POSTRI(2,3,MAXMSS*MAXMSS,6)) + CALL NXTTLO(IPRINT,MAXMSS,NM ,DAMESH,POSTRI) + CALL NXTPHT(IPRINT,NDIM ,IDIRC ,MAXMSS,NSUR ,NREG , + > NM ,DAMESH,NBPIN ,ITPIN ,DRAPIN, + > NBSUR ,NBREG ,INDXSR,SURVOL,POSTRI) + DEALLOCATE(POSTRI) + ENDIF + ELSE IF(ITYPG .EQ. 20 .OR. ITYPG .EQ. 21 .OR. + > ITYPG .EQ. 22 .OR. ITYPG .EQ. 23) THEN + IF(ITYPG .EQ. 20) NDIM=2 + CALL NXTVCC(IPRINT,NDIM ,IDIRC ,MAXMSS,NSUR ,NREG , + > NM ,DAMESH,NBSUR ,NBREG ,INDXSR,SURVOL) + IF(NBPIN .GT. 0) THEN +*---- +* Remove pin contributions +*---- + CALL NXTPCC(IPRINT,NDIM ,IDIRC ,MAXMSS,NSUR ,NREG , + > NM ,DAMESH,NBPIN ,ITPIN ,DRAPIN, + > NBSUR ,NBREG ,INDXSR,SURVOL) + ENDIF + ELSE IF(ITYPG .EQ. 26 .OR. ITYPG .EQ. 27 ) THEN + IF(ITYPG .EQ. 26) NDIM=2 + ALLOCATE(POSTRI(2,3,MAXMSS*MAXMSS,6)) + CALL NXTTLO(IPRINT,MAXMSS,NM ,DAMESH,POSTRI) + CALL NXTVHC(IPRINT,NDIM ,MAXMSS,NSUR ,NREG , + > NM ,DAMESH,NBSUR ,NBREG ,INDXSR,SURVOL, + > POSTRI) + IF(NBPIN .GT. 0) THEN +*---- +* Remove pin contributions +*---- + CALL NXTPHC(IPRINT,NDIM ,MAXMSS,NSUR ,NREG , + > NM ,DAMESH,NBPIN ,ITPIN ,DRAPIN, + > NBSUR ,NBREG ,INDXSR,SURVOL,POSTRI) + ENDIF + DEALLOCATE(POSTRI) + ENDIF +*---- +* Save surface and region identification on IPTRK +*---- + SVT(-NSURN:NREGN)=DZERO + VMAX=0.0D0 + DO IREG=1,NBREG + VMAX=MAX(VMAX,SURVOL(IREG)) + IDV=ABS(IDREG(IREG)) + IF(IDV .GT. NREGN) CALL XABORT(NAMSBR// + > ': Number of regions insufficient') + IF(IDV .NE. 0) THEN + SVT(IDV)=SVT(IDV)+SURVOL(IREG) + ENDIF + ENDDO + SMAX=0.0D0 + DO ISUR=1,NBSUR + SMAX=MAX(SMAX,SURVOL(-ISUR)) + IDS=ABS(IDSUR(ISUR)) + IF(IDS .GT. NSURN) CALL XABORT(NAMSBR// + > ': Number of surfaces insufficient') + IF(IDS .NE. 0) THEN + SVT(-IDS)=SVT(-IDS)+SURVOL(-ISUR) + ENDIF + ENDDO +*---- +* Remove region/surfaces with 0 volumes +*---- + INV=0 + INREN(0)=0 + DO IDV=1,NREGN + IF(SVT(IDV)/VMAX .GT. DCUTOF) THEN + INV=INV+1 + INREN(IDV)=INV + ELSE + INREN(IDV)=0 + ENDIF + ENDDO + LSTREG=INV+NAREG + DO IREG=1,NBREG + IDV=IDREG(IREG) + INV=INREN(ABS(IDV)) + IF(INV .NE. 0) INV=INV+NAREG + IF(IDV .LT. 0) THEN + IDREG(IREG)=-INV + ELSE + IDREG(IREG)=INV + ENDIF + ENDDO + INS=0 + DO IDS=1,NSURN + IF(SVT(-IDS)/SMAX .GT. DCUTOS) THEN + INS=INS+1 + INREN(-IDS)=INS + ELSE + INREN(-IDS)=0 + ENDIF + ENDDO + DO ISUR=1,NBSUR + IDS=IDSUR(ISUR) + INS=INREN(-ABS(IDS)) + IF(INS .NE. 0) INS=INS + IF(IDS .LT. 0) THEN + IDSUR(ISUR)=-INS + ELSE + IDSUR(ISUR)=INS + ENDIF + ENDDO + NAREG=LSTREG + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'VSE' + CALL LCMPUT(IPTRK,NAMREC,(NBSUR+NBREG+1),4,SURVOL) + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'VSI' + CALL LCMPUT(IPTRK,NAMREC,(NBSUR+NBREG+1)*5,1,INDXSR) + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'RID' + CALL LCMPUT(IPTRK,NAMREC,NBREG,1,IDREG) +*---- +* Processing finished: +* print routine closing output header if required +* and return +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6011) + WRITE(IOUT,6014) (IDREG(IDV),IDV=1,NREG) + WRITE(IOUT,6013) + WRITE(IOUT,6014) (IDSUR(IDS),IDS=1,NBSUR) + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(SVT,SURVOL) + DEALLOCATE(INREN) + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(' Original regions ID') + 6011 FORMAT(' Final regions ID') + 6012 FORMAT(' Original surfaces ID') + 6013 FORMAT(' Final surfaces ID') + 6014 FORMAT(5I15) + END diff --git a/Dragon/src/NXTXYZ.f b/Dragon/src/NXTXYZ.f new file mode 100644 index 0000000..a9ac28b --- /dev/null +++ b/Dragon/src/NXTXYZ.f @@ -0,0 +1,169 @@ +*DECK NXTXYZ + SUBROUTINE NXTXYZ(IPTRK ,IPRINT,NDIM ,ITYPBC,MAXMSH,NUCELL, + > ABSC,DGMESH) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find global cell limits. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): +* G. Marleau, R.Roy +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure in +* update or creation mode. +* IPRINT print level. +* NDIM number of dimensions for geometry. +* ITYPBC type of boundary conditions where: +* =0 for geometry with Cartesian boundaries; +* =1 for geometry with annular boundary; +* =2 for geometry with hexagonal boundary. +* MAXMSH maximum number of elements in mesh vector for +* each directions. +* NUCELL number of cell after unfolding in +* $X$, $Y$ and $Z$ directions. +* +*Parameters: output +* ABSC cell width and upper limit. +* DGMESH meshing vector for global geometry. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* \\\\ +* Extracted from the subroutine XELTI2 and XELTI3. +* +*---------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPTRK + INTEGER IPRINT,NDIM,ITYPBC,MAXMSH,NUCELL(3) + DOUBLE PRECISION ABSC(3,2),DGMESH(-1:MAXMSH,4) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTXYZ') + DOUBLE PRECISION DZERO,DONE + PARAMETER (DZERO=0.0D0,DONE=1.0D0) +*---- +* Local variables +*---- + INTEGER IDIR,ICELL + CHARACTER NAMREC*12 + DOUBLE PRECISION SIDEH,CENTH,DHMAX +*---- +* Data +*---- + CHARACTER CDIR(4)*1 + SAVE CDIR + DATA CDIR /'X','Y','Z','R'/ +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 20) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + DGMESH(-1:MAXMSH,:4)=DZERO + IF(ITYPBC .EQ. 0) THEN + DO IDIR=1,NDIM + NAMREC='G00000001SM'//CDIR(IDIR) + CALL LCMGET(IPTRK,NAMREC,DGMESH(0,IDIR)) + ABSC(IDIR,2)=DGMESH(NUCELL(IDIR),IDIR) + ABSC(IDIR,1)=ABSC(IDIR,2)-DGMESH(0,IDIR) + IF(IPRINT .GE. 20) THEN + WRITE(IOUT,6010) CDIR(IDIR),ABSC(IDIR,1) + ENDIF + ENDDO + DO IDIR=NDIM+1,3 + ABSC(IDIR,1)=DONE + ABSC(IDIR,2)=DONE + ENDDO + ELSE IF(ITYPBC .EQ. 1) THEN +*---- +* Find Cartesian box surrounding circle in plane +*---- + IDIR=4 + NAMREC='G00000001SM'//CDIR(IDIR) + CALL LCMGET(IPTRK,NAMREC,DGMESH(0,IDIR)) + ABSC(1,2)=DGMESH(NUCELL(IDIR),IDIR) + ABSC(1,1)=ABSC(1,2) + ABSC(2,1)=ABSC(1,1) + ABSC(2,2)=ABSC(1,2) + IF(IPRINT .GE. 20) THEN + WRITE(IOUT,6010) CDIR(IDIR),ABSC(IDIR,1) + ENDIF + IDIR=3 + IF(NDIM .EQ. 3) THEN + NAMREC='G00000001SM'//CDIR(IDIR) + CALL LCMGET(IPTRK,NAMREC,DGMESH(0,IDIR)) + ABSC(IDIR,2)=DGMESH(NUCELL(IDIR),IDIR) + ABSC(IDIR,1)=ABSC(IDIR,2)-DGMESH(0,IDIR) + IF(IPRINT .GE. 20) THEN + WRITE(IOUT,6010) CDIR(IDIR),ABSC(IDIR,1) + ENDIF + ELSE + ABSC(IDIR,1)=DONE + ABSC(IDIR,2)=DONE + ENDIF + ELSE +*---- +* Find Cartesian box surrounding hexagons in plane +*---- + DO IDIR=1,2 + NAMREC='G00000001SM'//CDIR(IDIR) + CALL LCMGET(IPTRK,NAMREC,DGMESH(0,IDIR)) + SIDEH=DGMESH(0,IDIR) + CENTH=DGMESH(1,IDIR) + DHMAX=DZERO + DO ICELL=2,NUCELL(IDIR) + DHMAX=MAX(DHMAX,ABS(DGMESH(NUCELL(IDIR),IDIR)-CENTH)) + ENDDO + ABSC(IDIR,2)=DHMAX+SIDEH + ABSC(IDIR,1)=2.0*ABSC(IDIR,2) + ENDDO + IDIR=3 + IF(NDIM .EQ. 3) THEN + NAMREC='G00000001SM'//CDIR(IDIR) + CALL LCMGET(IPTRK,NAMREC,DGMESH(0,IDIR)) + ABSC(IDIR,2)=DGMESH(NUCELL(IDIR),IDIR) + ABSC(IDIR,1)=ABSC(IDIR,2)-DGMESH(0,IDIR) + IF(IPRINT .GE. 20) THEN + WRITE(IOUT,6010) CDIR(IDIR),ABSC(IDIR,1) + ENDIF + ELSE + ABSC(IDIR,1)=DONE + ABSC(IDIR,2)=DONE + ENDIF + ENDIF + IF(IPRINT .GE. 20) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* Processing finished: return +*---- + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(' Geometry width in ',A1,' = ',F20.15) + END diff --git a/Dragon/src/PIJAAA.f b/Dragon/src/PIJAAA.f new file mode 100644 index 0000000..b6646c7 --- /dev/null +++ b/Dragon/src/PIJAAA.f @@ -0,0 +1,74 @@ +*DECK PIJAAA + SUBROUTINE PIJAAA(NREG,NSOUT,SIGTAL,PROB,PSVT,PROBS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculates directional collision probabilities for all zones +* eliminating surfaces from the system: +* PIJK=PIJK+PISK*((1-PSS)**(-1))*PSJ. +* +*Copyright: +* Copyright (C) 1994 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): I. petrovic +* +*Parameters: input +* NREG number of zones for geometry. +* NSOUT number of surfaces for geometry. +* SIGTAL albedo-sigt vector. +* PROB directional cp matrix for all types. +* PSVT PSST matrix: +* PSVT=(A**(-1)-PSS)**(-1)*PSV. +* +*Parameters: output +* PROBS directional CP matrix +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* INTERFACE VARIABLES +*---- + INTEGER NREG,NSOUT + REAL SIGTAL(-NSOUT:NREG),PROBS(*) + DOUBLE PRECISION PROB(*),PSVT(NSOUT,NREG) +*---- +* LOCAL VARIABLES +*---- + INTEGER NSP1,IVSI,IDPSV,IV,IPRL,IPRU,JV,ISV,IPSV,IVS,ISU +* + NSP1=NSOUT+1 + IVSI=(NSP1*(NSP1+1))/2 + IDPSV=IVSI + DO 100 IV=1,NREG + IPRL=NREG*(IV-1)+1 + IPRU=IV + IPSV=IDPSV + DO 110 JV=1,IV + ISV=0 + IVS=IVSI + DO 120 ISU=-NSOUT,-1,1 + ISV=ISV+1 + IVS=IVS+1 + IPSV=IPSV+1 + IF(SIGTAL(ISU).NE.0.0) THEN + PROBS(IPRL)=PROBS(IPRL)+REAL(PROB(IVS)*PSVT(ISV,JV)) + IF(IPRL.NE.IPRU) THEN + PROBS(IPRU)=PROBS(IPRU)+REAL(PROB(IPSV)*PSVT(ISV,IV)) + ENDIF + ENDIF + 120 CONTINUE + IPSV=IPSV+JV+1 + IPRL=IPRL+1 + IPRU=NREG*JV+IV + 110 CONTINUE + IVSI=IVSI+NSP1+IV + 100 CONTINUE +* + RETURN + END diff --git a/Dragon/src/PIJABC.f b/Dragon/src/PIJABC.f new file mode 100644 index 0000000..1b31e1b --- /dev/null +++ b/Dragon/src/PIJABC.f @@ -0,0 +1,122 @@ +*DECK PIJABC + SUBROUTINE PIJABC(NREG,NSOUT,NPRB,SIGTAL,MATRT,PROB,PSST,PSVT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Reconstruct collision probabilities (CP) for all zones eliminating +* surfaces from the system. +* +*Copyright: +* Copyright (C) 1991 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau, R. Roy, I. petrovic +* +*Parameters: input +* NREG number of zones for geometry. +* NSOUT number of surfaces for geometry. +* NPRB number of probabilities. +* SIGTAL albedo-sigt vector. +* MATRT reflection/transmission vector. +* PROB directional cp matrix for all types. +* +*Parameters: output +* PROB directional cp matrix for all types. +* PSST PSST=(A**(-1)-PSS)**(-1). +* PSVT PSVT=PSST*PSV. +* +*----------------------------------------------------------------------- +* + + IMPLICIT NONE +*---- +* VARIABLES +*----- + INTEGER NREG,NSOUT,NPRB,NSP1,IPSS,ISUR,ISX,IS,JSX,JS,IER, + 1 IV,JV,IVSI,IVVI,ISV,IVS,IVV + INTEGER MATRT(NSOUT) +* + REAL SIGTAL(-NSOUT:NREG) + DOUBLE PRECISION PROB(NPRB),PSST(NSOUT,NSOUT),PSVT(NSOUT,NREG) +*---- +* EVALUATE MATRIX (A**(-1)-PSS) +*---- + NSP1=NSOUT+1 + IPSS=0 + ISUR=(NSOUT*NSP1)/2 + ISX=0 + DO 100 IS=-NSOUT,-1,1 + ISX=ISX+1 + JSX=0 + ISUR=ISUR+1 + DO 101 JS=-NSOUT,IS,1 + JSX=JSX+1 + IPSS=IPSS+1 + IF((SIGTAL(IS).EQ.0.0).OR.(SIGTAL(JS).EQ.0.0)) THEN + PSST(ISX,JSX)= 0.0D0 + ELSE + PSST(ISX,JSX)=-PROB(IPSS) + ENDIF + IF(JS.NE.IS) THEN + PSST(JSX,ISX)=PSST(ISX,JSX) + ENDIF + 101 CONTINUE + IF(SIGTAL(IS) .EQ. 0.0)THEN + PSST(ISX,ISX)=PROB(ISUR) + ELSE + JS=-MATRT(-IS) + IF(JS .EQ. IS) THEN + PSST(ISX,ISX)=PSST(ISX,ISX)+PROB(ISUR)/SIGTAL(IS) + ELSE IF(JS .LT. IS) THEN + JSX=NSOUT+JS+1 + PSST(ISX,JSX)=PSST(ISX,JSX)+PROB(ISUR)/SIGTAL(IS) + PSST(JSX,ISX)=PSST(ISX,JSX) + ENDIF + ENDIF + 100 CONTINUE +*---- +* INVERSE MATRIX PSST=(A**(-1)-PSS) +*---- + CALL ALINVD(NSOUT,PSST,NSOUT,IER) +*---- +* CHECK IF INVERSE IS VALID +*---- + IF(IER .NE. 0 ) CALL XABORT + > ('PIJABC: IMPOSSIBLE TO INVERT PSS COUPLING MATRIX') + IVSI=(NSP1*(NSP1+1))/2 + IVVI=IVSI+NSP1 + DO 110 IV=1,NREG +*---- +* PSVT(IS,IV)=SUM(JSS) PSST(ISS,JSS)*PSV(JSS,IV) +*---- + DO 111 IS=1,NSOUT + PSVT(IS,IV)=0.0D0 + 111 CONTINUE + DO 120 IS=1,NSOUT + DO 121 JS=1,NSOUT + ISV=IVSI+JS + PSVT(IS,IV)=PSVT(IS,IV)+PSST(IS,JS)*PROB(ISV) + 121 CONTINUE + 120 CONTINUE + IVV=IVVI + DO 130 JV=1,IV + IVV=IVV+1 + ISV=0 + IVS=IVSI + DO 131 IS=-NSOUT,-1,1 + ISV=ISV+1 + IVS=IVS+1 + IF(SIGTAL(IS).NE.0.0) THEN + PROB(IVV)=PROB(IVV)+PROB(IVS)*PSVT(ISV,JV) + ENDIF + 131 CONTINUE + 130 CONTINUE + IVSI=IVSI+NSP1+IV + IVVI=IVVI+NSP1+IV + 110 CONTINUE + RETURN + END diff --git a/Dragon/src/PIJCMP.f b/Dragon/src/PIJCMP.f new file mode 100644 index 0000000..f62fb2e --- /dev/null +++ b/Dragon/src/PIJCMP.f @@ -0,0 +1,121 @@ +*DECK PIJCMP + SUBROUTINE PIJCMP(NREG,NSOUT,NCOR,DPR,VOLSUR,LPIJK,PROB) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compression of PIJ matrices in symmetric format. +* +*Copyright: +* Copyright (C) 1994 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* NREG number of zones for geometry. +* NSOUT number of surfaces for geometry. +* NCOR maximum number of corners. +* DPR collision probabilities. +* VOLSUR volumes. +* LPIJK pijk flag. +* +*Parameters: output +* PROB compress probability matrix. +* +*Comments: +* Format of compress probability matrix +* NPLEN=(NREG+NSOUT+2)*(NREG+NSOUT+1)/2 +* IND(I,J)=MAX(I+NSOUT+1,J+NSOUT+1) +* *(MAX(I+NSOUT+1,J+NSOUT+1)-1)/2 +* +MIN(I+NSOUT+1,J+NSOUT+1) +* IS=-NSOUT,-1; JS=-NSOUT,IS; I=IND(IS,JS) +* PROB(I)=VOLSUR(IS)*PSS(IS,JS) +* IV=1,NREG; JS=-NSOUT,-1; I=IND(IV,JS) +* SIGT(IV).GT.0.0 +* PROB(I)=SIGT(IV)*VOLSUR(IV)*PVS(IV,JS) +* SIGT(IV).EQ.0.0 +* PROB(I)=VOLSUR(IV)*PVS(IV,JS) +* IV=1,NREG; JV=1,IV; I=IND(IV,JV) +* SIGT(IV).GT.0.0 AND SIGT(JV).GT.0.0 +* PROB(I)=SIGT(IV)*SIGT(JV)*VOLSUR(IV)*PVV(IV,JV) +* SIGT(IV).GT.0.0 AND SIGT(JV).EQ.0.0 +* PROB(I)=SIGT(IV)*VOLSUR(IV)*PVV(IV,JV) +* SIGT(IV).EQ.0.0 AND SIGT(JV).GT.0.0 +* PROB(I)=SIGT(JV)*VOLSUR(IV)*PVV(IV,JV) +* SIGT(IV).EQ.0.0 AND SIGT(JV).EQ.0.0 +* PROB(I)=VOLSUR(IV)*PVV(IV,JV) +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* VARIABLES +*---- + INTEGER NREG,NSOUT,NCOR,IPR,IL,JL,IVOL,IUN + DOUBLE PRECISION DPR(-NSOUT:NREG,-NSOUT:NREG),PROB(*),ZCOR,ZCOR1 + REAL VOLSUR(-NSOUT:NREG),COEF + LOGICAL LPIJK + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: WORK +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(WORK((NREG+NSOUT+2)*(NREG+NSOUT+1)/2)) +*---- +* SYMMETRIZE AND STORE IN PROB +*---- + IPR= 0 + DO 150 IL = -NSOUT, NREG + DO 160 JL = -NSOUT, IL + IPR= IPR+1 + WORK(IPR)= DPR(IL,JL) + DPR(JL,IL) + 160 CONTINUE + 150 CONTINUE + IF( NCOR.EQ.1 )THEN + IPR= 0 + DO 250 IL = -NSOUT, NREG + DO 260 JL = -NSOUT, IL + IPR= IPR+1 + PROB(IPR)= WORK(IPR) + 260 CONTINUE + 250 CONTINUE + ELSE + IPR= 0 + ZCOR1= 1.0D0/DBLE(NCOR) + ZCOR= 1.0D0/DBLE(NCOR*NCOR) + DO 251 IL = -NSOUT, NREG + IF( IL.GT.0 ) ZCOR= ZCOR1 + DO 261 JL = -NSOUT, IL + IPR= IPR+1 + IF( JL.GT.0 ) ZCOR= 1.0D0 + PROB(IPR)= ZCOR * WORK(IPR) + 261 CONTINUE + 251 CONTINUE + ENDIF +*---- +* CHARGE VOLUMES IN THE PROB MATRIX +*---- + COEF=1.0 + IVOL= NSOUT*(NSOUT+1)/2 + DO 300 IUN= -NSOUT, NREG + IF( IUN.LE.0 )THEN + IVOL= IVOL+1 + IF(LPIJK) COEF= 3./4. + ELSE + IVOL= IVOL+NSOUT+IUN + IF(LPIJK) COEF= 2./3. + ENDIF + IF( PROB(IVOL).NE.0.0 )THEN + CALL XABORT( 'PIJCMP: UNEXPECTED VALUE IN PROB MATRIX' ) + ENDIF + PROB(IVOL) = VOLSUR(IUN)*COEF + 300 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(WORK) + RETURN + END diff --git a/Dragon/src/PIJD2R.f b/Dragon/src/PIJD2R.f new file mode 100644 index 0000000..6508d5b --- /dev/null +++ b/Dragon/src/PIJD2R.f @@ -0,0 +1,57 @@ +*DECK PIJD2R + SUBROUTINE PIJD2R(NREG,NSOUT,PROB,FACTOR,LPIJK,NELPIJ,N2PROB,PIJ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Charge PIJ matrices in the DRAGON symmetrized format. +* +*Copyright: +* Copyright (C) 1994 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NREG number of zones for geometry. +* NSOUT number of surfaces for geometry. +* PROB collision probabilities. +* FACTOR one over total xs. +* LPIJK PIJK flag. +* NELPIJ number of terms in PIJ. +* N2PROB number of terms in PROB. +* +*Parameters: output +* PIJ symmetric probability matrix. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* VARIABLES +*---- + INTEGER NREG,NSOUT,NELPIJ,N2PROB,IUN,JUN,KPRB,IVV + DOUBLE PRECISION PROB(N2PROB) + REAL FACTOR(NREG),PIJ(NELPIJ),COEF + LOGICAL LPIJK +*---- +* STORE IN SYMMETRIC FORMAT +*---- + IVV=0 + COEF=1.0 + IF(LPIJK) COEF=1.5 + KPRB=(NSOUT+1)*(NSOUT+2)/2+NSOUT+1 + DO 20 IUN=1,NREG + DO 10 JUN=1,IUN + KPRB=KPRB+1 + IVV=IVV+1 + PIJ(IVV)=COEF*REAL(PROB(KPRB))*FACTOR(IUN)*FACTOR(JUN) + 10 CONTINUE + KPRB=KPRB+NSOUT+1 + 20 CONTINUE +* + RETURN + END diff --git a/Dragon/src/PIJD2S.f b/Dragon/src/PIJD2S.f new file mode 100644 index 0000000..0b81674 --- /dev/null +++ b/Dragon/src/PIJD2S.f @@ -0,0 +1,53 @@ +*DECK PIJD2S + SUBROUTINE PIJD2S(NREG,NSOUT,PROB,PROBKS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Charge PROBKS matrices in the DRAGON square format. +* +*Copyright: +* Copyright (C) 1994 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NREG number of zones for geometry. +* NSOUT number of surfaces for geometry. +* PROB collision probabilities. +* +*Parameters: output +* PROBKS square probability matrix. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +C---- +C VARIABLES +C---- + INTEGER NREG,NSOUT,KPRB,IIU,IIL,II,JJ + DOUBLE PRECISION PROB(((NSOUT+NREG+2)*(NSOUT+NREG+1))/2) + REAL PROBKS(NREG*NREG) +C---- +C STORE IN SQUARE FORMAT +C---- + KPRB=(NSOUT+1)*(NSOUT+2)/2+NSOUT+1 + DO 20 JJ=1,NREG + IIU=JJ + IIL=(JJ-1)*NREG+1 + DO 10 II=1,JJ + KPRB=KPRB+1 + PROBKS(IIL)=REAL(PROB(KPRB)) + PROBKS(IIU)=PROBKS(IIL) + IIU=JJ+II*NREG + IIL=IIL+1 + 10 CONTINUE + KPRB=KPRB+NSOUT+1 + 20 CONTINUE +C + RETURN + END diff --git a/Dragon/src/PIJI2D.f b/Dragon/src/PIJI2D.f new file mode 100644 index 0000000..86f4472 --- /dev/null +++ b/Dragon/src/PIJI2D.f @@ -0,0 +1,271 @@ +*DECK PIJI2D + SUBROUTINE PIJI2D(NREG,NSOUT,NSLINE,NCOR,SWVOID,SIGTAL,WEIGHT, + > SEGLEN,NRSEG,SEGPAT,DPR, + > MKI0,BIN0,PAS0,L0, + > MKI1,BIN1,PAS1,XLM1,L1, + > MKI2,BIN2,PAS2,XLM2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Integration for general 2D isotropic tracking. +* +*Copyright: +* Copyright (C) 1991 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* NREG total number of regions. +* NSOUT number of outer surface. +* NSLINE number of segemnts on line. +* NCOR maximum number of corners. +* SWVOID flag to indicate if there are voids. +* SIGTAL albedo-cross section vector. +* WEIGHT line weight. +* SEGLEN length of track. +* NRSEG region crossed by track. +* MKI0 nb element quadratic BICKLEY table order N. +* BIN0 elements quadratic BICKLEY table order N. +* PAS0 step quadratic BICKLEY table order N. +* L0 log divergence quadratic BICKLEY table order N. +* MKI1 nb element quadratic BICKLEY table order N+1. +* BIN1 elements quadratic BICKLEY table order N+1. +* PAS1 step quadratic BICKLEY table order N+1. +* XLM1 upper limit quadratic BICKLEY table order N+1. +* L1 log divergence quadratic BICKLEY table order N+1. +* MKI2 nb element quadratic BICKLEY table order N+2. +* BIN2 elements quadratic BICKLEY table order N+2. +* PAS2 step quadratic BICKLEY table order N+2. +* XLM2 upper limit quadratic BICKLEY table order N+2. +* +*Parameters: output +* DPR CP matrix. +* +*Parameters: scratch +* SEGPAT optical path. +* +*Comments: +* PIJ => WITH BICKLEY FUNCTIONS OF ORDER 1,2,3 +* PIJK => WITH BICKLEY FUNCTIONS OF ORDER 3,4,5 +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* PARAMETERS +*---- + REAL PI + PARAMETER (PI=3.1415926535897932) +*---- +* INTERNAL FUNCTIONS +*---- + DOUBLE PRECISION CBIN0,CBIN1,CBIN2 +*---- +* VARIABLES +*---- + INTEGER NREG,NSOUT,NSLINE,NCOR,NRSEG(NSLINE) + LOGICAL SWVOID + REAL SIGTAL(-NSOUT:NREG),SEGPAT(NSLINE) + DOUBLE PRECISION WEIGHT,SEGLEN(NSLINE) + DOUBLE PRECISION DPR(-NSOUT:NREG,-NSOUT:NREG) + INTEGER MKI0,L0,MKI1,L1,MKI2 + REAL BIN0(0:MKI0,3),PAS0, + > BIN1(0:MKI1,3),PAS1,XLM1, + > BIN2(0:MKI2,3),PAS2,XLM2 +*---- +* Local variables +*---- + INTEGER IL,ISD,ISF,NSEG,ISEG,IREG,LPOS,ICSEG,JCSEG, + > JSEG,IR1 + DOUBLE PRECISION FLOG0,FLOG1,ZREF1,ZREF2,ZREF3,XPOS,ZINTP, + > X3,ZI,X +*---- +* QUADRATIC INTERPOLATION IN BICKLEY TABLES +*---- + CBIN0(IL,X)= BIN0(IL,1)+X*(BIN0(IL,2)+X*BIN0(IL,3)) + CBIN1(IL,X)= BIN1(IL,1)+X*(BIN1(IL,2)+X*BIN1(IL,3)) + CBIN2(IL,X)= BIN2(IL,1)+X*(BIN2(IL,2)+X*BIN2(IL,3)) +*---- +* LOGARITHMIC DIVERGENCE FOR KI1 AND KI2 +* FOR KI1 -> X*LOG(X) FOR K0 +* FOR KI2 -> -X**2*LOG(X)/2. FOR K0 +*---- + FLOG0=FLOAT(L0/MAX(1,L0)) + FLOG1=-0.5*FLOAT(L1/MAX(1,L1)) +*---- +* Process track required +*---- + NSEG=NSLINE-2*NCOR + ZI=0.0D0 + ZREF3=CBIN2(0,0.0D0)*WEIGHT + ZREF2=CBIN1(0,0.0D0)*WEIGHT + ZREF1=CBIN0(0,0.0D0)*WEIGHT +*---- +* CONVERT SEGMENT LENGHT TO PATH LENGTH +*---- + ICSEG=NCOR + DO 210 ISEG=1,NSEG + ICSEG=ICSEG+1 + IREG=NRSEG(ICSEG) + SEGPAT(ISEG)=REAL(SEGLEN(ICSEG)*SIGTAL(IREG)) + DPR(IREG,IREG)=DPR(IREG,IREG)+ZREF2*SEGPAT(ISEG) + 210 CONTINUE +*---- +* INTEGRATION +*---- + XPOS=0.0D0 + ZINTP=ZREF3 +*---- +* INTEGRATE OVER FIRST REGION AND COMPUTE PVS, PSS +*---- + ICSEG=NCOR+1 + DO 220 ISEG=1,NSEG + IREG=NRSEG(ICSEG) + IR1=NRSEG(NCOR+1) + XPOS=XPOS+SEGPAT(ISEG) + LPOS=MIN(NINT(XPOS*PAS2),MKI2) + ZI=WEIGHT*CBIN2(LPOS,XPOS) + X3=ZI-ZINTP + DPR(IR1,IREG)=DPR(IR1,IREG)+X3 + DO 225 ISD=1,NCOR + DPR(IREG,NRSEG(ISD))=DPR(IREG,NRSEG(ISD))-X3 + 225 CONTINUE + IF(XPOS.GT.XLM2) GO TO 221 + ZINTP=ZI + ICSEG=ICSEG+1 + 220 CONTINUE + 221 CONTINUE + IR1=NRSEG(NCOR+1) + DO 226 ISF=NSLINE-NCOR+1,NSLINE + DPR(IR1,NRSEG(ISF))=DPR(IR1,NRSEG(ISF))-ZI + DO 227 ISD=1,NCOR + DPR(NRSEG(ISD),NRSEG(ISF))= + > DPR(NRSEG(ISD),NRSEG(ISF))+ZI + 227 CONTINUE + 226 CONTINUE + ICSEG=NCOR+2 + DO 230 ISEG=2,NSEG + XPOS=0.0D0 + ZINTP=ZREF3 + JCSEG=ICSEG + DO 240 JSEG=ISEG,NSEG + XPOS=XPOS+SEGPAT(JSEG) + LPOS=MIN(NINT(XPOS*PAS2),MKI2) + ZI=WEIGHT*CBIN2(LPOS,XPOS) + X3=ZI-ZINTP + DPR(NRSEG(ICSEG-1),NRSEG(JCSEG))= + > DPR(NRSEG(ICSEG-1),NRSEG(JCSEG))-X3 + DPR(NRSEG(ICSEG),NRSEG(JCSEG))= + > DPR(NRSEG(ICSEG),NRSEG(JCSEG))+X3 + IF(XPOS.GT.XLM2) GO TO 241 + ZINTP=ZI + JCSEG=JCSEG+1 + 240 CONTINUE + 241 CONTINUE + DO 235 ISF=NSLINE-NCOR+1,NSLINE + DPR(NRSEG(ICSEG),NRSEG(ISF))= + > DPR(NRSEG(ICSEG),NRSEG(ISF))-ZI + DPR(NRSEG(ICSEG-1),NRSEG(ISF))= + > DPR(NRSEG(ICSEG-1),NRSEG(ISF))+ZI + 235 CONTINUE + ICSEG=ICSEG+1 + 230 CONTINUE + ICSEG=NCOR+NSEG + DO 236 ISF=NSLINE-NCOR+1,NSLINE + DPR(NRSEG(ICSEG),NRSEG(ISF))= + > DPR(NRSEG(ICSEG),NRSEG(ISF))+ZREF3 + 236 CONTINUE +*---- +* FOR VOID REGIONS RESET PROBABILITIES +*---- + IF(SWVOID) THEN + ICSEG=NCOR+1 + DO 300 ISEG=1,NSEG + IF(SIGTAL(NRSEG(ICSEG)).NE.0.0) GO TO 301 + XPOS=0.0D0 + DPR(NRSEG(ICSEG),NRSEG(ICSEG))= + > DPR(NRSEG(ICSEG),NRSEG(ICSEG)) + > + 0.5*ZREF1*SEGLEN(ICSEG)*SEGLEN(ICSEG) + ZINTP=ZREF2*SEGLEN(ICSEG) + JCSEG=ICSEG+1 + DO 310 JSEG=ISEG+1,NSEG + IF(SIGTAL(NRSEG(JCSEG)).EQ.0.0) THEN + LPOS=MIN(NINT(XPOS*PAS0),MKI0) + IF(LPOS.LT.L0.AND.XPOS.NE.0.0) THEN + ZI=WEIGHT*SEGLEN(ICSEG)*SEGLEN(JCSEG)* + > (CBIN0(LPOS,XPOS)+FLOG0*XPOS*LOG(XPOS)) + ELSE + ZI=WEIGHT*SEGLEN(ICSEG)*SEGLEN(JCSEG)*CBIN0(LPOS,XPOS) + ENDIF + X3=0.5*ZI + ELSE + XPOS=XPOS+SEGPAT(JSEG) + LPOS=MIN(NINT(XPOS*PAS1),MKI1) + IF(LPOS.LT.L1.AND.XPOS.NE.0.0) THEN + ZI=WEIGHT*SEGLEN(ICSEG)* + > (CBIN1(LPOS,XPOS)+FLOG1*XPOS*XPOS*LOG(XPOS)) + ELSE + ZI=WEIGHT*SEGLEN(ICSEG)*CBIN1(LPOS,XPOS) + ENDIF + X3=ZINTP-ZI + ZINTP=ZI + ENDIF + DPR(NRSEG(ICSEG),NRSEG(JCSEG))= + > DPR(NRSEG(ICSEG),NRSEG(JCSEG))+X3 + IF(XPOS.GT.XLM1) GO TO 311 + JCSEG=JCSEG+1 + 310 CONTINUE + 311 CONTINUE + DO 320 ISF=NSLINE-NCOR+1,NSLINE + DPR(NRSEG(ICSEG),NRSEG(ISF))= + > DPR(NRSEG(ICSEG),NRSEG(ISF))+ZINTP + 320 CONTINUE + XPOS=0.0D0 + ZINTP=ZREF2*SEGLEN(ICSEG) + JCSEG=ICSEG-1 + DO 330 JSEG=ISEG-1,1,-1 + IF(SIGTAL(NRSEG(JCSEG)).EQ.0.0) THEN + LPOS=MIN(NINT(XPOS*PAS0),MKI0) + IF(LPOS.LT.L0.AND.XPOS.NE.0.0) THEN + ZI=WEIGHT*SEGLEN(ICSEG)*SEGLEN(JCSEG)* + > (CBIN0(LPOS,XPOS)+FLOG0*XPOS*LOG(XPOS)) + ELSE + ZI=WEIGHT*SEGLEN(ICSEG)*SEGLEN(JCSEG)*CBIN0(LPOS,XPOS) + ENDIF + X3=0.5*ZI + ELSE + XPOS=XPOS+SEGPAT(JSEG) + LPOS=MIN(NINT(XPOS*PAS1),MKI1) + IF(LPOS.LT.L1.AND.XPOS.NE.0.0) THEN + ZI=WEIGHT*SEGLEN(ICSEG)* + > (CBIN1(LPOS,XPOS)+FLOG1*XPOS*XPOS*LOG(XPOS)) + ELSE + ZI=WEIGHT*SEGLEN(ICSEG)*CBIN1(LPOS,XPOS) + ENDIF + X3=ZINTP-ZI + ZINTP=ZI + ENDIF + DPR(NRSEG(ICSEG),NRSEG(JCSEG))= + > DPR(NRSEG(ICSEG),NRSEG(JCSEG))+X3 + IF(XPOS.GT.XLM1) GO TO 331 + JCSEG=JCSEG-1 + 330 CONTINUE + 331 CONTINUE + DO 340 ISD=1,NCOR + DPR(NRSEG(ICSEG),NRSEG(ISD))= + > DPR(NRSEG(ICSEG),NRSEG(ISD))+ZINTP + 340 CONTINUE + 301 CONTINUE + ICSEG=ICSEG+1 + 300 CONTINUE + ENDIF +*---- +* RETURN +*---- + RETURN + END diff --git a/Dragon/src/PIJI3D.f b/Dragon/src/PIJI3D.f new file mode 100644 index 0000000..2e5264f --- /dev/null +++ b/Dragon/src/PIJI3D.f @@ -0,0 +1,277 @@ +*DECK PIJI3D + SUBROUTINE PIJI3D(NREG,NSOUT,NSLINE,NCOR, + > SWVOID,SIGTAL,WEIGHT, + > SEGLEN,NRSEG, + > STAYIN,GOSOUT,DPR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Integration for general 3D isotropic tracking. +* +*Copyright: +* Copyright (C) 1991 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* NREG total number of regions. +* NSOUT number of outer surface. +* NSLINE number of segemnts on line. +* NCOR maximum number of corners. +* SWVOID flag to indicate if there are voids. +* SIGTAL albedo-cross section vector. +* WEIGHT line weight. +* SEGLEN length of track. +* NRSEG region crossed by track. +* +*Parameters: output +* DPR CP matrix. +* +*Parameters: scratch +* STAYIN stay-in zone probability. +* GOSOUT goes-out zone probability. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* VARIABLES +*---- + INTEGER NREG,NSOUT,NSLINE,NCOR,NRSEG(NSLINE) + LOGICAL SWVOID + REAL SIGTAL(-NSOUT:NREG) + DOUBLE PRECISION WEIGHT,SEGLEN(NSLINE),STAYIN(NSLINE), + > GOSOUT(NSLINE) + DOUBLE PRECISION DPR(-NSOUT:NREG,-NSOUT:NREG) +*---- +* Local variables +*---- + INTEGER IL,JL,NOIL + REAL ZERO, ONE, HALF + DOUBLE PRECISION XSIL, PRODUC, DSCBEG, DSCEND, ZCOR, ZCOR2 + INTEGER ICSEG,JCSEG,ISD,ISF + PARAMETER (ZERO=0.0E0, ONE=1.0E0, HALF=0.5E0 ) + REAL SIXT,CUTEXP + PARAMETER (SIXT=HALF/3.0,CUTEXP=0.02) + DOUBLE PRECISION EXSIL,XSIL2 +*---- +* Process track required +*---- + IF( NCOR.EQ.1 )THEN +* +*1) ONLY ONE EXTERNAL SURFACE AT END -------------------------------- + ISD=NRSEG(1) + ISF=NRSEG(NSLINE) + IF( SWVOID )THEN + PRODUC= WEIGHT +* PII CALCULATION AND ESCAPE + DO 40 IL = 1,NSLINE-2 + ICSEG=IL+1 + NOIL = NRSEG(ICSEG) + XSIL = SIGTAL(NOIL)*SEGLEN(ICSEG) + IF( XSIL.EQ.ZERO )THEN + GOSOUT(IL)= ONE + STAYIN(IL)= SEGLEN(ICSEG) + DPR(NOIL,NOIL)= DPR(NOIL,NOIL) + > + HALF*WEIGHT*SEGLEN(ICSEG)*SEGLEN(ICSEG) + ELSE IF(XSIL .LT. CUTEXP) THEN + XSIL2=XSIL*XSIL + EXSIL=XSIL2*(HALF-SIXT*XSIL) + STAYIN(IL)=XSIL-EXSIL + GOSOUT(IL)=ONE-STAYIN(IL) + PRODUC= PRODUC * GOSOUT(IL) + DPR(NOIL,NOIL)= DPR(NOIL,NOIL) + WEIGHT*EXSIL + ELSE + EXSIL=EXP( - XSIL ) + STAYIN(IL)= ONE - EXSIL + GOSOUT(IL)= EXSIL + PRODUC= PRODUC * GOSOUT(IL) + DPR(NOIL,NOIL)= DPR(NOIL,NOIL) + WEIGHT*(XSIL-STAYIN(IL)) + ENDIF + 40 CONTINUE +* PIJ CALCULATION + DSCBEG= WEIGHT + DO 60 IL = 1, NSLINE-2 + ICSEG=IL+1 + NOIL = NRSEG(ICSEG) + DSCEND= WEIGHT*STAYIN(IL) + DO 50 JL = IL+1, NSLINE-2 + JCSEG=JL+1 + DPR(NRSEG(JCSEG),NOIL)= + > DPR(NRSEG(JCSEG),NOIL) + STAYIN(JL)*DSCEND + DSCEND= DSCEND*GOSOUT(JL) + 50 CONTINUE +* PIS CALCULATION + DPR(ISD,NOIL)= DPR(ISD,NOIL)+DSCBEG*STAYIN(IL) + DPR(ISF,NOIL)= DPR(ISF,NOIL)+DSCEND + DSCBEG= DSCBEG * GOSOUT(IL) + 60 CONTINUE +* PSS CALCULATION + DPR(ISD,ISF)= DPR(ISD,ISF) + PRODUC + ELSE +* +*1.2) NO VOID REGION + PRODUC= WEIGHT +* PII CALCULATION AND ESCAPE + DO 140 IL = 1,NSLINE-2 + ICSEG=IL+1 + NOIL = NRSEG(ICSEG) + XSIL = SIGTAL(NOIL)*SEGLEN(ICSEG) + IF(XSIL .LT. CUTEXP) THEN + XSIL2=XSIL*XSIL + EXSIL=XSIL2*(HALF-SIXT*XSIL) + STAYIN(IL)=XSIL-EXSIL + GOSOUT(IL)=ONE-STAYIN(IL) + PRODUC= PRODUC * GOSOUT(IL) + DPR(NOIL,NOIL)= DPR(NOIL,NOIL) + WEIGHT*EXSIL + ELSE + EXSIL=EXP( - XSIL ) + STAYIN(IL)= ONE - EXSIL + GOSOUT(IL)= EXSIL + PRODUC= PRODUC * GOSOUT(IL) + DPR(NOIL,NOIL)= DPR(NOIL,NOIL) + WEIGHT*(XSIL-STAYIN(IL)) + ENDIF + 140 CONTINUE +* PIJ CALCULATION + DSCBEG= WEIGHT + DO 160 IL = 1, NSLINE-2 + ICSEG=IL+1 + NOIL = NRSEG(ICSEG) + DSCEND= WEIGHT*STAYIN(IL) + DO 150 JL = IL+1, NSLINE-2 + JCSEG=JL+1 + DPR(NRSEG(JCSEG),NOIL)= + > DPR(NRSEG(JCSEG),NOIL)+ STAYIN(JL)*DSCEND + DSCEND= DSCEND*GOSOUT(JL) + 150 CONTINUE +* PIS CALCULATION + DPR(ISD,NOIL)= DPR(ISD,NOIL)+DSCBEG*STAYIN(IL) + DPR(ISF,NOIL)= DPR(ISF,NOIL)+DSCEND + DSCBEG= DSCBEG * GOSOUT(IL) + 160 CONTINUE +* PSS CALCULATION + DPR(ISD,ISF)= DPR(ISD,ISF) + PRODUC + ENDIF + ELSE +* +*2) MORE THAN ONE SURFACE PER LINE ---------------------------------- + ZCOR= 1./FLOAT(NCOR) + ZCOR2= ZCOR*ZCOR + IF( SWVOID )THEN +* +*2.1) VOIDS ARE POSSIBLE + PRODUC= WEIGHT*ZCOR2 +* PII CALCULATION AND ESCAPE + DO 240 IL = 1,NSLINE-2*NCOR + ICSEG=IL+NCOR + NOIL = NRSEG(ICSEG) + XSIL = SIGTAL(NOIL)*SEGLEN(ICSEG) + IF( XSIL.EQ.ZERO )THEN + GOSOUT(IL)= ONE + STAYIN(IL)= SEGLEN(ICSEG) + DPR(NOIL,NOIL)= DPR(NOIL,NOIL) + > + HALF*WEIGHT*SEGLEN(ICSEG)*SEGLEN(ICSEG) + ELSE IF(XSIL .LT. CUTEXP) THEN + XSIL2=XSIL*XSIL + STAYIN(IL)=XSIL-XSIL2*(HALF-SIXT*XSIL) + GOSOUT(IL)=ONE-STAYIN(IL) + PRODUC= PRODUC * GOSOUT(IL) + DPR(NOIL,NOIL)= DPR(NOIL,NOIL) + > + WEIGHT*XSIL2*(HALF-SIXT*XSIL) + ELSE + GOSOUT(IL)= EXP( - XSIL ) + STAYIN(IL)= (ONE - GOSOUT(IL)) + PRODUC= PRODUC * GOSOUT(IL) + DPR(NOIL,NOIL)= DPR(NOIL,NOIL) + WEIGHT*(XSIL-STAYIN(IL)) + ENDIF + 240 CONTINUE +* PIJ CALCULATION + DSCBEG= WEIGHT*ZCOR + DO 260 IL = 1, NSLINE-2*NCOR + ICSEG=IL+NCOR + NOIL = NRSEG(ICSEG) + DSCEND= WEIGHT*STAYIN(IL) + DO 250 JL = IL+1, NSLINE-2*NCOR + JCSEG=JL+NCOR + DPR(NRSEG(JCSEG),NOIL)= + > DPR(NRSEG(JCSEG),NOIL)+ STAYIN(JL)*DSCEND + DSCEND= DSCEND*GOSOUT(JL) + 250 CONTINUE +* PIS CALCULATION + DO 261 JL = 1, NCOR + ISD=NRSEG(JL) + ISF=NRSEG(NSLINE-NCOR+JL) + DPR(ISD,NOIL)= DPR(ISD,NOIL)+DSCBEG*STAYIN(IL) + DPR(ISF,NOIL)= DPR(ISF,NOIL)+DSCEND*ZCOR + 261 CONTINUE + DSCBEG= DSCBEG*GOSOUT(IL) + 260 CONTINUE +* PSS CALCULATION + DO 270 IL = 1, NCOR + ISD=NRSEG(IL) + DO 265 JL = 1, NCOR + ISF=NRSEG(NSLINE-NCOR+JL) + DPR(ISD,ISF)= DPR(ISD,ISF) + PRODUC + 265 CONTINUE + 270 CONTINUE + ELSE +* +*2.2) NO VOID REGION + PRODUC= WEIGHT*ZCOR2 +* PII CALCULATION AND ESCAPE + DO 340 IL = 1,NSLINE-2*NCOR + ICSEG=IL+NCOR + NOIL = NRSEG(ICSEG) + XSIL = SIGTAL(NOIL)*SEGLEN(ICSEG) + IF(XSIL .LT. CUTEXP) THEN + XSIL2=XSIL*XSIL + STAYIN(IL)=XSIL-XSIL2*(HALF-SIXT*XSIL) + GOSOUT(IL)=ONE-STAYIN(IL) + PRODUC= PRODUC * GOSOUT(IL) + DPR(NOIL,NOIL)= DPR(NOIL,NOIL) + > + WEIGHT*XSIL2*(HALF-SIXT*XSIL) + ELSE + GOSOUT(IL)= EXP( - XSIL ) + STAYIN(IL)= (ONE - GOSOUT(IL)) + PRODUC= PRODUC * GOSOUT(IL) + DPR(NOIL,NOIL)= DPR(NOIL,NOIL) + WEIGHT*(XSIL-STAYIN(IL)) + ENDIF + 340 CONTINUE +* PIJ CALCULATION + DSCBEG= WEIGHT*ZCOR + DO 360 IL = 1, NSLINE-2*NCOR + ICSEG=IL+NCOR + NOIL = NRSEG(ICSEG) + DSCEND= WEIGHT*STAYIN(IL) + DO 350 JL = IL+1, NSLINE-2*NCOR + JCSEG=JL+NCOR + DPR(NRSEG(JCSEG),NOIL)= + > DPR(NRSEG(JCSEG),NOIL)+ STAYIN(JL)*DSCEND + DSCEND= DSCEND*GOSOUT(JL) + 350 CONTINUE +* PIS CALCULATION + DO 361 JL = 1, NCOR + ISD=NRSEG(JL) + ISF=NRSEG(NSLINE-NCOR+JL) + DPR(ISD,NOIL)= DPR(ISD,NOIL)+DSCBEG*STAYIN(IL) + DPR(ISF,NOIL)= DPR(ISF,NOIL)+DSCEND*ZCOR + 361 CONTINUE + DSCBEG= DSCBEG * GOSOUT(IL) + 360 CONTINUE +* PSS CALCULATION + DO 370 IL = 1, NCOR + ISD=NRSEG(IL) + DO 365 JL = 1, NCOR + ISF=NRSEG(NSLINE-NCOR+JL) + DPR(ISD,ISF)= DPR(ISD,ISF) + PRODUC + 365 CONTINUE + 370 CONTINUE + ENDIF + ENDIF + RETURN + END diff --git a/Dragon/src/PIJKST.f b/Dragon/src/PIJKST.f new file mode 100644 index 0000000..1acc75c --- /dev/null +++ b/Dragon/src/PIJKST.f @@ -0,0 +1,90 @@ +*DECK PIJKST + SUBROUTINE PIJKST(IMPX,NREGIO,PIJSYM,PIJKS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Evaluate PIJK*=PIJ**(-1)*PIJK. +* +*Copyright: +* Copyright (C) 1994 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau, I. Petrovic +* +*Parameters: input +* IMPX print/check flag. +* NREGIO number of regions considered. +* PIJSYM group condensed reduce/symmetric PIJ. +* +*Parameters: output +* PIJKS group condensed PIJK*. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* PARAMETERS +*---- + INTEGER IUNOUT + PARAMETER (IUNOUT=6) +*---- +* INTERNAL FUNCTIONS +*---- + INTEGER INDPOS +*---- +* LOCAL VARIABLES +*---- + INTEGER IMPX,NREGIO,IDIR,I,J,INDPIJ,IERROR + REAL PIJSYM(*),PIJKS(NREGIO,NREGIO,3) + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: PIJSCT +* +*----- INTRINSIC FUNCTION FOR POSITION IN CONDENSE PIJ MATRIX +* + INDPOS(I,J)=MAX(I,J)*(MAX(I,J)-1)/2+MIN(I,J) +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(PIJSCT(NREGIO,2*NREGIO)) +*---- +* FILL SYSTEM MATRIX WITH PIJ +*---- + DO 100 IDIR=1,3 + DO 110 I=1,NREGIO + DO 120 J=1,NREGIO + INDPIJ=INDPOS(I,J) + PIJSCT(I,J)=DBLE(PIJSYM(INDPIJ)) + PIJSCT(J,NREGIO+I)=DBLE(PIJKS(I,J,IDIR)) + 120 CONTINUE + 110 CONTINUE + CALL ALSBD(NREGIO,NREGIO,PIJSCT,IERROR,NREGIO) + IF(IERROR.NE.0) CALL XABORT('PIJKST: SINGULAR MATRIX.') + DO 130 I=1,NREGIO + DO 140 J=1,NREGIO + PIJKS(I,J,IDIR)=REAL(PIJSCT(I,NREGIO+J)) + 140 CONTINUE + 130 CONTINUE + IF (IMPX.GE.8) THEN + WRITE(IUNOUT,6000) (J,J=1,NREGIO) + DO 150 I=1,NREGIO + WRITE(IUNOUT,6001) I,(PIJKS(I,J,IDIR),J=1,NREGIO) + 150 CONTINUE + WRITE(IUNOUT,'(//)') + ENDIF + 100 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(PIJSCT) + RETURN +* + 6000 FORMAT (//'COLLISION PROBAB. MATRIX PIJK*=((PIJ)**(-1))*PIJK:'// + 1 (11X,2HJ=,I4,:,5X,2HJ=,I4,:,5X,2HJ=,I4,:,5X,2HJ=,I4,:,5X,2HJ=, + 2 I4,:,5X,2HJ=,I4,:,5X,2HJ=,I4,:,5X,2HJ=,I4,:,5X,2HJ=,I4,:,5X, + 3 2HJ=,I4,:,5X,2HJ=,I4)) + 6001 FORMAT (3H I=,I4,2H: ,1P,11E11.3/(9X,11E11.3)) + END + diff --git a/Dragon/src/PIJRDG.f b/Dragon/src/PIJRDG.f new file mode 100644 index 0000000..bb6c0a5 --- /dev/null +++ b/Dragon/src/PIJRDG.f @@ -0,0 +1,91 @@ +*DECK PIJRDG + SUBROUTINE PIJRDG(IPRT,NREG,NSOUT,SIGTAL,PROB) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Diagonal normalization of collision probs (CP). +* +*Copyright: +* Copyright (C) 1991 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPRT print level. +* NREG number of zones for geometry. +* NSOUT number of surfaces for geometry. +* SIGTAL albedo-sigt vector. +* +*Parameters: input/output +* PROB CP matrix for all types. +* +*References: +* R. Roy and G. Marleau, +* Normalization Techniques for CP Matrices, +* CONF/PHYSOR-90, Marseille/France, V 2, P IX-40 (1990). +*----------------------------------------------------------------------- +* + IMPLICIT NONE + INTEGER IPRT,NREG,NSOUT,IR,JR,IPRB,IPRF,IUNK,JUNK,IVOL + REAL SIGTAL(-NSOUT:NREG) + INTEGER IUNOUT,IPRINT + PARAMETER (IUNOUT=6, IPRINT=4) + DOUBLE PRECISION PROB(*),BILAN + IPRB= 0 + IUNK= 0 + IVOL= NSOUT*(NSOUT+1)/2 +* +* RENORMALIZE ALL DIAGONAL ELEMENTS OF MATRIX *PROB* + IF( IPRT.GE.IPRINT )THEN + WRITE(IUNOUT,9000) 'PIJRDG' + ENDIF + DO 100 IR = -NSOUT, NREG + IUNK= IUNK+1 + BILAN=0.0 + DO 10 JR= -NSOUT, IR-1 + IPRB= IPRB+1 + IF( JR.LT.0.OR.SIGTAL(JR).GT.0.0 )THEN + BILAN=BILAN + PROB(IPRB) + ENDIF + 10 CONTINUE + IPRB= IPRB+1 + IPRF= IPRB + JUNK= IUNK + DO 20 JR= IR+1 , NREG + IPRF= IPRF+JUNK + JUNK= JUNK+1 + IF( JR.LT.0.OR.SIGTAL(JR).GT.0.0 )THEN + BILAN=BILAN + PROB(IPRF) + ENDIF + 20 CONTINUE + IF( IR.LT.0 )THEN + IVOL= IVOL+1 + PROB(IPRB)= PROB(IVOL)-BILAN + IF( IPRT.GE.IPRINT )THEN + WRITE(IUNOUT,9001) -IR,BILAN + ENDIF + ELSEIF( IR.GT.0 )THEN + IVOL= IVOL+IUNK-1 + IF( SIGTAL(IR).GT.0.0 )THEN +* +* VOIDS ARE NOT BE RENORMALIZED + PROB(IPRB)= PROB(IVOL)-BILAN + IF( IPRT.GE.IPRINT )THEN + WRITE(IUNOUT,9002) IR,BILAN + ENDIF + ENDIF + ELSE + IVOL= IVOL+1 + ENDIF + 100 CONTINUE +* +9000 FORMAT('Diagonal correction factors for CP in ',A6) +9001 FORMAT('Surface ',I10,5X,E15.6) +9002 FORMAT('Region ',I10,5X,E15.6) + RETURN + END diff --git a/Dragon/src/PIJRGL.f b/Dragon/src/PIJRGL.f new file mode 100644 index 0000000..ed5dfe8 --- /dev/null +++ b/Dragon/src/PIJRGL.f @@ -0,0 +1,151 @@ +*DECK PIJRGL + SUBROUTINE PIJRGL(IPRT,NREG,NSOUT,SIGTAL,PROB) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Gelbard normalization of collision probs (CP). +* +*Copyright: +* Copyright (C) 1991 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy, G. Marleau +* +*Parameters: input +* IPRT print level. +* NREG number of zones for geometry. +* NSOUT number of surfaces for geometry. +* SIGTAL albedo-sigt vector. +* +*Parameters: input/output +* PROB CP matrix for all types. +* +*References: +* R. Roy and G. Marleau, +* Normalization Techniques for CP Matrices, +* CONF/PHYSOR-90, Marseille/France, V 2, P IX-40 (1990). +*----------------------------------------------------------------------- +* + IMPLICIT NONE + INTEGER IPRT,NREG,NSOUT,IUNOUT,IPRINT, + > IPRB,IPRF,IUNK,JUNK,IVOL,JVOL,IR,JR, + > NSURM,NSURC,NVOLM,NVOLC,IP + PARAMETER (IUNOUT=6, IPRINT=4) + REAL SIGTAL(-NSOUT:NREG) + DOUBLE PRECISION PROB(*),RBARRE,GBARRE + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: RI +C---- +C SCRATCH STORAGE ALLOCATION +C---- + ALLOCATE(RI(-NSOUT:NREG)) +C + RBARRE=0.0 + GBARRE=0.0 + IPRB= 0 + IUNK= 0 + IVOL= NSOUT*(NSOUT+1)/2 +C +C COMPUTE R-SUB(I) FACTORS AND: GBARRE, RBARRE + DO 30 IR=-NSOUT, NREG + IUNK= IUNK+1 + RI(IR)=0.0 + DO 10 JR=-NSOUT, IR + IPRB= IPRB+1 + IF( JR.LT.0.OR.SIGTAL(JR).GT.0.0 )THEN + RI(IR)=RI(IR)+PROB(IPRB) + ENDIF + 10 CONTINUE + IPRF= IPRB + JUNK= IUNK + DO 20 JR= IR+1 , NREG + IPRF= IPRF+JUNK + JUNK= JUNK+1 + IF( JR.LT.0.OR.SIGTAL(JR).GT.0.0 )THEN + RI(IR)=RI(IR)+PROB(IPRF) + ENDIF + 20 CONTINUE + IF( IR.LT.0 )THEN + IVOL= IVOL+1 + RI(IR)= PROB(IVOL)-RI(IR) + GBARRE= GBARRE+PROB(IVOL) + RBARRE= RBARRE+RI(IR) + ELSEIF( IR.GT.0 )THEN + IVOL= IVOL+IUNK-1 + RI(IR)= PROB(IVOL)-RI(IR) + IF( SIGTAL(IR).GT.0.0 )THEN + GBARRE= GBARRE+PROB(IVOL) + RBARRE= RBARRE+RI(IR) + ENDIF + ELSE + IVOL= IVOL+1 + RI(IR)=0.0 + ENDIF + 30 CONTINUE + GBARRE=1.0/GBARRE + RBARRE=RBARRE*GBARRE +C +C RENORMALIZE PROB MATRIX + IVOL= NSOUT*(NSOUT+1)/2 + IPRB= 0 + IUNK= 0 + DO 210 IR = -NSOUT, NREG + IF( IR.LE.0 )THEN + IVOL= IVOL+1 + ELSE + IVOL= IVOL+IUNK + ENDIF + IUNK= IUNK+1 + JVOL= NSOUT*(NSOUT+1)/2 + JUNK= 0 + DO 200 JR= -NSOUT, IR + IF( JR.LE.0 )THEN + JVOL= JVOL+1 + ELSE + JVOL= JVOL+JUNK + ENDIF + JUNK= JUNK+1 + IPRB= IPRB+1 + IF( IR.NE.0.AND.JR.NE.0 )THEN + PROB(IPRB)= PROB(IPRB)+(PROB(JVOL)*RI(IR) + > +PROB(IVOL)*RI(JR)-PROB(IVOL)*PROB(JVOL)*RBARRE)*GBARRE + ENDIF + 200 CONTINUE + 210 CONTINUE +C +C PRINT IF REQUESTED + IF( IPRT.GE.IPRINT )THEN + WRITE(IUNOUT,'(19H0 GLOBAL FACTORS: , + > 8H RBARRE=,1P,F11.5,5X,7HGBARRE=,F11.5)') + > RBARRE, GBARRE + WRITE(IUNOUT,'(30H0 SURFACE ADJUSTMENT FACTORS /)') + NSURC = -1 + DO 300 IP = 1, (9 +NSOUT) / 10 + NSURM= MAX( -NSOUT, NSURC-9 ) + WRITE(IUNOUT,'(10X,10( A5, I6)/)') + > (' SUR ',-IR,IR= NSURC, NSURM, -1) + WRITE(IUNOUT,'(10H R-SUB(I) ,10F11.5)') + > (RI(IR),IR=NSURC,NSURM,-1) + NSURC = NSURC - 10 + 300 CONTINUE + WRITE(IUNOUT,'(30H0 VOLUME ADJUSTMENT FACTORS /)') + NVOLC = 1 + DO 310 IP = 1, (9 + NREG) / 10 + NVOLM= MIN( NREG, NVOLC+9 ) + WRITE(IUNOUT,'(10X,10( A5 , I6)/)') + > (' VOL ',IR,IR=NVOLC,NVOLM, 1) + WRITE(IUNOUT,'(10H R-SUB(I) ,10F11.5)') + > (RI(IR),IR=NVOLC,NVOLM, 1) + NVOLC = NVOLC + 10 + 310 CONTINUE + ENDIF +C---- +C SCRATCH STORAGE DEALLOCATION +C---- + DEALLOCATE(RI) +C + RETURN + END diff --git a/Dragon/src/PIJRHL.f b/Dragon/src/PIJRHL.f new file mode 100644 index 0000000..9e2040b --- /dev/null +++ b/Dragon/src/PIJRHL.f @@ -0,0 +1,194 @@ +*DECK PIJRHL + SUBROUTINE PIJRHL(IPRT,NREG,NSOUT,SIGTAL,PROB) +* +*----------------------------------------------------------------------- +* +*Purpose: +* HELIOS type normalization of collision probs (CP). +* +*Copyright: +* Copyright (C) 1994 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy, E. Varin +* +*Parameters: input +* IPRT print level. +* NREG number of zones for geometry. +* NSOUT number of surfaces for geometry. +* SIGTAL albedo-sigt vector. +* +*Parameters: input/output +* PROB CP matrix for all types. +* +*References: +* R. Roy and G. Marleau, +* Normalization Techniques for CP Matrices, +* CONF/PHYSOR-90, Marseille/France, V 2, P IX-40 (1990). +* \\\\ +* E.A. Villarino, R.J.J. Stamm'ler, A.A. Ferri and J.J. Casal +* HELIOS: Angularly Dependent Collision Probabilities. +* Nucl.Sci.Eng. 112,16-31, 1992. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IPRT,NREG,NSOUT + REAL SIGTAL(-NSOUT:NREG) + DOUBLE PRECISION PROB(*) +*---- +* LOCAL VARIABLES +*---- + INTEGER IUNOUT,NITMAX,NIT,IPRINT,IR,JR,IP,IPRB,IND,I,J,CPTLB, + > CPTAC,CTOT,NSURC,NSURM,NVOLC,NVOLM + LOGICAL NOTCON + DOUBLE PRECISION NOM,DENOM,DMU,WFSPAD,WFSP,EPSCON,R1,R2,TOTCON, + > TMPCON + CHARACTER HSMG*131 + PARAMETER (IUNOUT=6, IPRINT=10, EPSCON=1.0E-6, NITMAX=20) +*---- +* ALLOCATABLE ARRAYS +*---- + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: CHI + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: WEIG +* +*----- INTRINSIC FUNCTION FOR POSITION IN CONDENSE PIJ MATRIX +* + IND(I,J)=(MAX(I+NSOUT+1,J+NSOUT+1)* + > (MAX(I+NSOUT+1,J+NSOUT+1)-1))/2 + > +MIN(I+NSOUT+1,J+NSOUT+1) +*---- +* SCRATCH STORAGE ALLOCATION +* WEIG : ADDITIVE WEIGHT +*---- + ALLOCATE(WEIG(-NSOUT:NREG,3),CHI(-NSOUT:NREG)) +* + NOTCON= .FALSE. + CPTLB = 3 + CPTAC = 3 + CTOT = CPTAC+CPTLB +* +* INITIALISATION OF WEIGHTS + DO 60 IR=-NSOUT, NREG + WEIG(IR,1)=0.0D0 + WEIG(IR,2)=0.5D0 + WEIG(IR,3)=0.5D0 + 60 CONTINUE + DO 50 IR=-NSOUT, NREG + CHI(IR)= 1.0D0 + IF( IR.GE.0.AND.SIGTAL(IR).EQ.0.0D0 )THEN + CHI(IR)= 0.0D0 + ENDIF + 50 CONTINUE +* +* MAIN ITERATION LOOP + IF(IPRT.GT.2) WRITE(IUNOUT,'(A24)') + > 'ITER. MU ERROR ' + DO 110 NIT=1,NITMAX +* + DO 220 IR= -NSOUT, NREG + WFSPAD = PROB(IND(IR,0)) + > + CHI(IR)*PROB(IND(IR,IR))*WEIG(IR,3) + WFSP = CHI(IR)*PROB(IND(IR,IR)) + DO 200 JR=-NSOUT, NREG + WFSPAD = WFSPAD - CHI(JR)*WEIG(JR,3)*PROB(IND(IR,JR)) + WFSP = WFSP + CHI(JR)*PROB(IND(IR,JR)) + 200 CONTINUE + IF(WFSP.NE.0.0) WEIG(IR,3) = WFSPAD / WFSP + 220 CONTINUE +* +* ACCELERATION TECHNIQUE + IF( MOD(NIT-1,CTOT).GE.CPTAC )THEN + NOM = 0.0D0 + DENOM = 0.0D0 + DO 10 IR=-NSOUT, NREG + R1= WEIG(IR,2) - WEIG(IR,1) + R2= WEIG(IR,3) - WEIG(IR,2) + NOM = NOM + R1*(R2-R1) + DENOM = DENOM + (R2-R1)*(R2-R1) + 10 CONTINUE + IF(DENOM.EQ.0.0D0) THEN + DMU = 1.0D0 + ELSE + DMU = - NOM / DENOM + ENDIF + IF( DMU.GT.50.0D0 .OR. DMU.LT.0.0D0 ) THEN + WRITE(HSMG,'(37HPIJRHL: PROBLEM OF ACCELERATION (DMU=,1P, + > E11.4,2H).)') DMU + CALL XABORT(HSMG) + ENDIF + DO 20 IR=-NSOUT, NREG + WEIG(IR,3) = WEIG(IR,2) + DMU * + > (WEIG(IR,3) - WEIG(IR,2)) + WEIG(IR,2) = WEIG(IR,1) + DMU * + > (WEIG(IR,2) - WEIG(IR,1)) + 20 CONTINUE + ELSE + DMU = 1.0D0 + ENDIF +* +* CALCULATIONS OF SQUARE DISTANCE BETWEEN 2 ITERATIONS +* AND UPDATING THE SOLUTION + TOTCON = 0.0D0 + DO 100 IR=-NSOUT, NREG + TMPCON=ABS(WEIG(IR,3)-WEIG(IR,2))/WEIG(IR,3) + TOTCON=MAX(TMPCON,TOTCON) + WEIG(IR,1)= WEIG(IR,2) + WEIG(IR,2)= WEIG(IR,3) + 100 CONTINUE + IF( IPRT.GT.2 ) WRITE(IUNOUT,'(I3,F9.5,E15.7)') NIT,DMU,TOTCON +* +* CONVERGENCE TEST + IF( TOTCON.LT.EPSCON )GO TO 120 +* + 110 CONTINUE + NOTCON=.TRUE. + WRITE(IUNOUT,'(35H PIJRHL: WEIGHTS NOT CONVERGED )') + 120 CONTINUE +* +* RENORMALIZE "PIJ" SYMMETRIC MATRIX + IPRB = 0 + DO 240 IR = -NSOUT, NREG + DO 230 JR= -NSOUT, IR + IPRB= IPRB+1 + IF( IR.NE.0.AND.JR.NE.0 )THEN + PROB(IPRB)=PROB(IPRB)*(WEIG(IR,1)+WEIG(JR,1)) + ENDIF + 230 CONTINUE + 240 CONTINUE +* +* PRINT WEIGHT FACTORS IF THERE IS A PROBLEM... + IF( NOTCON .OR. IPRT.GE.IPRINT )THEN + WRITE(IUNOUT,'(30H0 SURFACE WEIGHTS FACTORS /)') + NSURC = -1 + DO 300 IP = 1, (9 +NSOUT) / 10 + NSURM= MAX( -NSOUT, NSURC-9 ) + WRITE(IUNOUT,'(10X,10( A5, I6)/)') + > (' SUR ',-IR,IR= NSURC, NSURM, -1) + WRITE(IUNOUT,'(10H WEIGHT ,10F11.5)') + > (WEIG(IR,1),IR=NSURC,NSURM,-1) + NSURC = NSURC - 10 + 300 CONTINUE + WRITE(IUNOUT,'(30H0 VOLUME WEIGHTS FACTORS /)') + NVOLC = 1 + DO 310 IP = 1, (9 + NREG) / 10 + NVOLM= MIN( NREG, NVOLC+9 ) + WRITE(IUNOUT,'(10X,10( A5 , I6)/)') + > (' VOL ',IR,IR=NVOLC,NVOLM, 1) + WRITE(IUNOUT,'(10H WEIGHT ,10F11.5)') + > (WEIG(IR,1),IR=NVOLC,NVOLM, 1) + NVOLC = NVOLC + 10 + 310 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(CHI,WEIG) + RETURN + END diff --git a/Dragon/src/PIJRNL.f b/Dragon/src/PIJRNL.f new file mode 100644 index 0000000..262bae8 --- /dev/null +++ b/Dragon/src/PIJRNL.f @@ -0,0 +1,285 @@ +*DECK PIJRNL + SUBROUTINE PIJRNL(IPRT,NREG,NSOUT,SIGTAL,PROB) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Non-linear type normalization of collision probs (CP). +* +*Copyright: +* Copyright (C) 1994 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy, G. Marleau +* +*Parameters: input +* IPRT print level. +* NREG number of zones for geometry. +* NSOUT number of surfaces for geometry. +* SIGTAL albedo-sigt vector. +* +*Parameters: input/output +* PROB CP matrix for all types. +* +*References: +* R. Roy and G. Marleau, +* Normalization Techniques for CP Matrices, +* CONF/PHYSOR-90, Marseille/France, V 2, P IX-40 (1990). +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE + INTEGER IPRT,NREG,NSOUT,IUNOUT,NITMAX,NIT, + > NUNKNO,IPRB,IPRF,IVOL,IDIA,IUNK,JUNK,IR,JR, + > NSURC,NSURM,NVOLC,NVOLM,IP,NPR + REAL SIGTAL(-NSOUT:NREG) + DOUBLE PRECISION PROB(*),EPSCON,TOTCON,WFSPAD + PARAMETER (IUNOUT=6, EPSCON=1.0E-8, NITMAX=10) + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDL + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: CIJ,WSPACE,WFSP, + > WEIG +C---- +C SCRATCH STORAGE ALLOCATION +C CIJ : MODIFIED CP PROB MATRIX +C WSPACE: NON-LINEAR SYSTEM MATRIX +C WFSP : NON LINEAR SYSTEM SOLUTION +C IDL : WSPACE DIAGONAL LOCATION +C WEIG : NON-LINEAR WEIGHT +C---- + NPR=(NSOUT+NREG+1)*(NSOUT+NREG+2)/2 + ALLOCATE(IDL(NSOUT+NREG+1)) + ALLOCATE(CIJ(NPR),WSPACE(NPR),WFSP(-NSOUT:NREG),WEIG(-NSOUT:NREG)) +C +C CHARGE MATRIX "CIJ" + NUNKNO=NREG+NSOUT+1 + IPRB= 0 + IUNK= 0 + IVOL= NSOUT*(NSOUT+1)/2 + DO 20 IR = -NSOUT, NREG + IUNK= IUNK+1 + IF( IR.LT.0.OR.SIGTAL(IR).GT.0.0 )THEN + DO 10 JR= -NSOUT, IR-1 + IPRB= IPRB+1 + IF( JR.LT.0.OR.SIGTAL(JR).GT.0.0 )THEN + CIJ(IPRB)= PROB(IPRB) + ELSE + CIJ(IPRB)= 0.0D0 + ENDIF + 10 CONTINUE + ELSE + DO 15 JR= -NSOUT, IR-1 + IPRB= IPRB+1 + CIJ(IPRB)= 0.0D0 + 15 CONTINUE + ENDIF + IPRB= IPRB+1 + IDL(IUNK)= IPRB + IF( IR.LT.0 )THEN + IVOL= IVOL+1 + CIJ(IPRB)= PROB(IPRB) + ELSEIF( IR.GT.0 )THEN + IVOL= IVOL+IUNK-1 + IF( SIGTAL(IR).GT.0.0 )THEN + CIJ(IPRB)= PROB(IPRB) + ELSE + CIJ(IPRB)= PROB(IVOL) + ENDIF + ELSE + IVOL= IVOL+1 + CIJ(IPRB)= 1.0D0 + ENDIF + 20 CONTINUE +C +C COPY MATRIX "CIJ" IN THE "WSPACE" ARRAY FOR INVERSION +C AND ADD TO THE DIAGONAL ALL TERMS OF A LINE + IPRB= 0 + IUNK= 0 + IDIA= 0 + DO 50 IR = -NSOUT, NREG + IUNK= IUNK+1 + IDIA= IDIA+IUNK + WSPACE(IDIA)= CIJ(IDIA) + CIJ(IDIA) + DO 30 JR= -NSOUT, IR-1 + IPRB= IPRB+1 + WSPACE(IPRB)= CIJ(IPRB) + WSPACE(IDIA)= WSPACE(IDIA) + CIJ(IPRB) + 30 CONTINUE + IPRB= IPRB+1 + IPRF= IPRB + JUNK= IUNK + DO 40 JR= IR+1 , NREG + IPRF= IPRF+JUNK + JUNK= JUNK+1 + WSPACE(IDIA)= WSPACE(IDIA) + CIJ(IPRF) + 40 CONTINUE + 50 CONTINUE + IF( IPRT.GT.100 )THEN + WRITE(IUNOUT,8002) + IPRB= 0 + DO 55 IR= -NSOUT, NREG + DO 52 JR= -NSOUT, IR + IPRB= IPRB+1 + WRITE(IUNOUT,8003) IR, JR, CIJ(IPRB), + > WSPACE(IPRB),PROB(IPRB) + 52 CONTINUE + 55 CONTINUE + ENDIF +C +C INVERSION OF THE INITIAL SYSTEM JACOBIAN MATRIX + CALL ALDDLF(NUNKNO,WSPACE,IDL) +C +C INITIALISATION OF WEIGHTS + DO 60 IR=-NSOUT, NREG + WEIG(IR)=1.0D0 + 60 CONTINUE + WEIG(0)= 0.0D0 +C +C THE NON-LINEAR SYSTEM FOR WEIGHTS IS: +C F1(W1, W2, ... WN)= W1*(W1*C11+W2*C12+ ... +WN*C1N) - TRUE1 +C F2(W1, W2, ... WN)= W2*(W1*C21+W2*C22+ ... +WN*C2N) - TRUE2 +C ... +C FN(W1, W2, ... WN)= WN*(W1*CN1+W2*CN2+ ... +WN*CNN) - TRUEN +C FORMING THE SYSTEM USING WEIGHTS "WEIG" & CONTRIBUTIONS "CIJ" +C +C MAIN ITERATION LOOP + DO 110 NIT=1,NITMAX +C + IPRB= 0 + IUNK= 0 + IVOL= NSOUT*(NSOUT+1)/2 + DO 90 IR=-NSOUT, NREG + IF( IR.LE.0 )THEN + IVOL= IVOL+1 + ELSE + IVOL= IVOL+IUNK + ENDIF + IUNK= IUNK+1 + WFSPAD= 0.0D0 + DO 70 JR=-NSOUT, IR + IPRB= IPRB+1 + WFSPAD=WFSPAD+WEIG(JR)*CIJ(IPRB) + 70 CONTINUE + IPRF= IPRB + JUNK= IUNK + DO 80 JR= IR+1 , NREG + IPRF= IPRF+JUNK + JUNK= JUNK+1 + WFSPAD=WFSPAD+WEIG(JR)*CIJ(IPRF) + 80 CONTINUE + WFSP(IR)=WEIG(IR)*WFSPAD-PROB(IVOL) + 90 CONTINUE + IF( IPRT.GT.100 )THEN + WRITE(IUNOUT,9000) + DO 92 IR= -NSOUT, NREG + WRITE(IUNOUT,9001) IR, WFSP(IR) + 92 CONTINUE + ENDIF + CALL ALDDLS(NUNKNO,IDL,WSPACE,WFSP) +C +C CALCULATIONS OF SQUARE DISTANCE BETWEEN 2 ITERATIONS +C AND UPDATING THE SOLUTION + TOTCON = 0.0D0 + DO 100 IR=-NSOUT, NREG + TOTCON= TOTCON + WFSP(IR)**2 + WEIG(IR)= WEIG(IR) - WFSP(IR) + 100 CONTINUE + IF( IPRT.GT.100 )THEN + WRITE(IUNOUT,9004) + DO 102 IR= -NSOUT, NREG + WRITE(IUNOUT,9005) IR, WEIG(IR) + 102 CONTINUE + WRITE(IUNOUT,'( 8H TOTCON: ,E15.7)') TOTCON + ENDIF +C +C CONVERGENCE TEST + IF( TOTCON.LT.EPSCON )GO TO 120 +C + 110 CONTINUE + WRITE(IUNOUT,'(35H PIJRNL: WEIGHTS NOT CONVERGED )') + 120 CONTINUE +C +C RECOMPUTE WEIGHTS FOR VOID REGIONS + IPRB= (NSOUT+1)*(NSOUT+2)/2 + IVOL= IPRB + IUNK= NSOUT+1 + DO 220 IR= 1, NREG + IVOL= IVOL+IUNK + IUNK= IUNK+1 + IF( SIGTAL(IR).EQ.0.0 )THEN + WFSPAD= 0.0D0 + DO 200 JR=-NSOUT, IR + IPRB= IPRB+1 + IF( JR.LT.0.OR.SIGTAL(JR).GT.0.0 )THEN + WFSPAD=WFSPAD+WEIG(JR)*PROB(IPRB) + ENDIF + 200 CONTINUE + IPRF= IPRB + JUNK= IUNK + DO 210 JR= IR+1 , NREG + IPRF= IPRF+JUNK + JUNK= JUNK+1 + IF( JR.LT.0.OR.SIGTAL(JR).GT.0.0 )THEN + WFSPAD=WFSPAD+WEIG(JR)*PROB(IPRF) + ENDIF + 210 CONTINUE + WEIG(IR)=PROB(IVOL)/WFSPAD + ELSE + IPRB= IPRB+IUNK + ENDIF + 220 CONTINUE +C +C RENORMALIZE "PIJ" SYMMETRIC MATRIX + IPRB = 0 + DO 240 IR = -NSOUT, NREG + DO 230 JR= -NSOUT, IR + IPRB= IPRB+1 + IF( IR.NE.0.AND.JR.NE.0 )THEN + PROB(IPRB)=PROB(IPRB)*WEIG(IR)*WEIG(JR) + ENDIF + 230 CONTINUE + 240 CONTINUE +C +C PRINT WEIGHT FACTORS IF REQUESTED + IF( IPRT .GE. 100 )THEN + WRITE(IUNOUT,'(30H0 SURFACE WEIGHTS FACTORS /)') + NSURC = -1 + DO 300 IP = 1, (9 +NSOUT) / 10 + NSURM= MAX( -NSOUT, NSURC-9 ) + WRITE(IUNOUT,'(10X,10( A5, I6)/)') + > (' SUR ',-IR,IR= NSURC, NSURM, -1) + WRITE(IUNOUT,'(10H WEIGHT ,10F11.5)') + > (WEIG(IR),IR=NSURC,NSURM,-1) + NSURC = NSURC - 10 + 300 CONTINUE + WRITE(IUNOUT,'(30H0 VOLUME WEIGHTS FACTORS /)') + NVOLC = 1 + DO 310 IP = 1, (9 + NREG) / 10 + NVOLM= MIN( NREG, NVOLC+9 ) + WRITE(IUNOUT,'(10X,10( A5 , I6)/)') + > (' VOL ',IR,IR=NVOLC,NVOLM, 1) + WRITE(IUNOUT,'(10H WEIGHT ,10F11.5)') + > (WEIG(IR),IR=NVOLC,NVOLM, 1) + NVOLC = NVOLC + 10 + 310 CONTINUE + ENDIF +C---- +C SCRATCH STORAGE DEALLOCATION +C---- + DEALLOCATE(WEIG,WFSP,WSPACE,CIJ) + DEALLOCATE(IDL) + RETURN +C + 8002 FORMAT(//' S U R F / S U R F C O N T R I B U T I O N S'// + >9X,'BEGIN S',6X,'END S ',11X,'CIJ. ',11X, 'WSPACE ', + > 11X,'PROBS. ') + 8003 FORMAT(6X,I10,5X,I10,5X,1P,E15.7,5X,E15.7,5X,E15.7 ) + 9000 FORMAT(//' F U N C T I O N V A L U E S'// + >9X,'VOL/SUR',6X,'VALUE') + 9001 FORMAT(6X,I10,5X,F10.4) + 9004 FORMAT(//' W E I G H T E D V A L U E S'// + >9X,'VOL/SUR',6X,'VALUE') + 9005 FORMAT(6X,I10,5X,F10.4) + END diff --git a/Dragon/src/PIJS2D.f b/Dragon/src/PIJS2D.f new file mode 100644 index 0000000..7fd56df --- /dev/null +++ b/Dragon/src/PIJS2D.f @@ -0,0 +1,222 @@ +*DECK PIJS2D + SUBROUTINE PIJS2D(NREG,NSOUT,NSLINE,WEIGHT,RCUTOF,NGSS,SIGANG, + > XGSS,WGSS,SEGLEN,NRSEG,STAYIN,GOSOUT,DPR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Integration for general 2D specular tracking. +* +*Copyright: +* Copyright (C) 1991 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy, G. Marleau +* +*Parameters: input +* NREG total number of regions. +* NSOUT number of outer surface. +* NSLINE number of segemnts on line. +* WEIGHT line weight. +* RCUTOF MFP cut-off factor (truncate lines). +* NGSS number of Gauss points. +* SIGANG 3D albedo-cross section vector. +* XGSS 2D->3D conversion for integration. +* WGSS 2D->3D conversion for integration. +* SEGLEN length of track. +* NRSEG region crossed by track. +* +*Parameters: output +* DPR collision probabilities. +* +*Parameters: scratch +* STAYIN stay-in zone probability. +* GOSOUT goes-out zone probability. +* +*References: +* R. Roy et al., +* A Cyclic Tracking Procedure for CP Calculations in 2-D Lattices +* Conf/Advances in Math, Comp & Reactor Physics, +* Pittsburgh, V 1, P 2.2 4-1 (1991). +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* VARIABLES +*---- + INTEGER NREG,NSOUT,NSLINE,NGSS,NRSEG(NSLINE) + DOUBLE PRECISION WEIGHT,SEGLEN(NSLINE),STAYIN(NGSS,NSLINE), + > GOSOUT(NGSS,NSLINE) + REAL RCUTOF,SIGANG(NGSS,-NSOUT:NREG) + DOUBLE PRECISION DPR(-NSOUT:NREG,-NSOUT:NREG) +*---- +* Local variables +*---- + INTEGER IL,JL,NOIL,NOJL,ISODD,JSODD,IJDEL,MXGAUS,IGSS + PARAMETER (MXGAUS= 64 ) + REAL WGSS(MXGAUS),FINV(MXGAUS),XGSS(MXGAUS), + > ZERO,ONE,HALF,XSIL,CUTOF + DOUBLE PRECISION TTOT(MXGAUS),OPATH + PARAMETER (ZERO=0.0E0, ONE=1.0E0, HALF=0.5E0 ) + REAL SIXT,CUTEXP + PARAMETER (SIXT=HALF/3.0,CUTEXP=0.02) + DOUBLE PRECISION EXSIL,XSIL2 + DO 20 IGSS= 1,NGSS + TTOT(IGSS)= ONE + 20 CONTINUE +* +*1.1) CHANGE PATHS => GOSOUT AND STAYIN PATHS, INCLUDING ALBEDOS +* ADD *PII* LOCAL NON-CYCLIC CONTRIBUTIONS + ISODD=0 + DO 30 IL= 1, NSLINE + NOIL = NRSEG(IL) + IF( NOIL .LT. 0 )THEN + IF(ISODD .EQ. 1) THEN + ISODD=0 + DO 31 IGSS= 1,NGSS +*---- +* FOR SURFACES: +* OLD VERSION BEFORE SURFACE DOUBLING +* GOSOUT= ALBEDO * SURFACE WEIGHT +* WHERE ALL SURFACE WEIGHTS WERE 1.0 +* NEW VERSION WITH SURFACE DOUBLING +* GOSOUT= ALBEDO +* STAYIN = 1- ALBEDO * SURFACE WEIGHT +* TTOT = PRODUCT OF GOSOUT +*---- + GOSOUT(IGSS,IL)= SIGANG(1,NOIL) + STAYIN(IGSS,IL)= ONE - GOSOUT(IGSS,IL) + TTOT(IGSS)= TTOT(IGSS) * GOSOUT(IGSS,IL) + 31 CONTINUE + ELSE + ISODD=1 + DO 32 IGSS= 1,NGSS +*---- +* FOR SURFACES: +* OLD VERSION BEFORE SURFACE DOUBLING +* GOSOUT= ALBEDO * SURFACE WEIGHT +* WHERE ALL SURFACE WEIGHTS WERE 1.0 +* NEW VERSION WITH SURFACE DOUBLING +* GOSOUT= ALBEDO +* STAYIN = 1- ALBEDO * SURFACE WEIGHT +* TTOT = PRODUCT OF GOSOUT +*---- + GOSOUT(IGSS,IL)= SIGANG(1,NOIL) + STAYIN(IGSS,IL)= ONE +* TTOT(IGSS)= TTOT(IGSS) * GOSOUT(IGSS,IL) + 32 CONTINUE + ENDIF + ELSE IF(NOIL .GT. 0) THEN +*---- +* FOR REGIONS +* STAYIN = 1 - EXP[ -CROSS SECTION * LENGTH OF NSLINE] +* GOSOUT = 1 - STAYIN +* TTOT = PRODUCT OF GOSOUT +*---- + XSIL = SIGANG(1,NOIL) + IF( XSIL .EQ. ZERO) THEN + DO 33 IGSS= 1,NGSS + GOSOUT(IGSS,IL)= ONE + STAYIN(IGSS,IL)= SEGLEN(IL)*XGSS(IGSS) + DPR(NOIL,NOIL)= DPR(NOIL,NOIL)+HALF*WEIGHT* + > WGSS(IGSS)*STAYIN(IGSS,IL)*STAYIN(IGSS,IL) + 33 CONTINUE + ELSE IF( XSIL .LT. CUTEXP) THEN + DO 333 IGSS= 1,NGSS + OPATH= SIGANG(IGSS,NOIL)*SEGLEN(IL) + XSIL2=OPATH*OPATH + EXSIL=XSIL2*(HALF-SIXT*OPATH+XSIL2/24.0) + STAYIN(IGSS,IL)=OPATH-EXSIL + GOSOUT(IGSS,IL)= ONE - STAYIN(IGSS,IL) + TTOT(IGSS)= TTOT(IGSS) * GOSOUT(IGSS,IL) + DPR(NOIL,NOIL)= DPR(NOIL,NOIL) + WEIGHT*WGSS(IGSS)*EXSIL + 333 CONTINUE + ELSE + DO 34 IGSS=1,NGSS + OPATH= SIGANG(IGSS,NOIL)*SEGLEN(IL) + EXSIL= EXP(-OPATH) + STAYIN(IGSS,IL)= ONE - EXSIL + GOSOUT(IGSS,IL)= EXSIL + TTOT(IGSS)= TTOT(IGSS) * GOSOUT(IGSS,IL) + DPR(NOIL,NOIL)= DPR(NOIL,NOIL) + > + WEIGHT*WGSS(IGSS)*(OPATH-STAYIN(IGSS,IL)) + 34 CONTINUE + ENDIF + ENDIF + 30 CONTINUE +* +*1.2) COMPUTE CYCLIC FACTORS BY ANGLE +* USING GLOBAL TRACK ATTENUATION: BETA(TOT)*EXP(-MFP(TOT)) + DO 40 IGSS= 1,NGSS + IF( TTOT(IGSS).GE.ONE )THEN + CALL XABORT( 'PIJS2D: ALBEDOS ARE NOT COMPATIBLE') + ENDIF + FINV(IGSS)= REAL(WEIGHT * WGSS(IGSS) / (ONE-TTOT(IGSS))) + 40 CONTINUE +* +*1.3) ADD *PIJ* CONTRIBUTIONS FOR FORWARD SOURCES + ISODD=0 + DO 50 IL= 1, NSLINE + NOIL = NRSEG(IL) + DO 60 IGSS= 1, NGSS + TTOT(IGSS)= FINV(IGSS) * STAYIN(IGSS,IL) + 60 CONTINUE + CUTOF= REAL(RCUTOF*TTOT(1)) + IF( NOIL .LT. 0) THEN + ISODD=MOD(ISODD+1,2) + JSODD=ISODD + DO 70 IJDEL= 1, NSLINE + JL= MOD(IL+IJDEL-1,NSLINE) + 1 + NOJL=NRSEG(JL) + IF( NOJL .LT. 0 ) THEN + JSODD=MOD(JSODD+1,2) + IF( ISODD.EQ.1 .AND. JSODD .EQ.0) THEN + DO 71 IGSS= 1, NGSS + DPR(NOJL,NOIL)= DPR(NOJL,NOIL) + > + TTOT(IGSS) * STAYIN(IGSS,JL) + TTOT(IGSS)= TTOT(IGSS) * GOSOUT(IGSS,JL) + 71 CONTINUE + IF( TTOT(1).LE.CUTOF ) GO TO 55 + ENDIF + ELSE IF((ISODD.EQ.1).AND.( NOJL .GT. 0 )) THEN + DO 72 IGSS= 1, NGSS + DPR(NOJL,NOIL)= DPR(NOJL,NOIL) + > + TTOT(IGSS) * STAYIN(IGSS,JL) + TTOT(IGSS)= TTOT(IGSS) * GOSOUT(IGSS,JL) + 72 CONTINUE + IF( TTOT(1).LE.CUTOF ) GO TO 55 + ENDIF + 70 CONTINUE + ELSE IF( NOIL .GT. 0) THEN + JSODD=ISODD + DO 80 IJDEL= 1, NSLINE + JL= MOD(IL+IJDEL-1,NSLINE) + 1 + NOJL=NRSEG(JL) + IF( NOJL .LT. 0 ) THEN + JSODD=MOD(JSODD+1,2) + IF( JSODD .EQ.0) THEN + DO 81 IGSS= 1, NGSS + DPR(NOJL,NOIL)= DPR(NOJL,NOIL) + > + TTOT(IGSS) * STAYIN(IGSS,JL) + TTOT(IGSS)= TTOT(IGSS) * GOSOUT(IGSS,JL) + 81 CONTINUE + IF( TTOT(1).LE.CUTOF ) GO TO 55 + ENDIF + ELSE IF( NOJL .GT. 0 ) THEN + DO 82 IGSS= 1, NGSS + DPR(NOJL,NOIL)= DPR(NOJL,NOIL) + > + TTOT(IGSS) * STAYIN(IGSS,JL) + TTOT(IGSS)= TTOT(IGSS) * GOSOUT(IGSS,JL) + 82 CONTINUE + IF( TTOT(1).LE.CUTOF ) GO TO 55 + ENDIF + 80 CONTINUE + ENDIF + 55 CONTINUE + 50 CONTINUE + RETURN + END diff --git a/Dragon/src/PIJS3D.f b/Dragon/src/PIJS3D.f new file mode 100644 index 0000000..9f3ded5 --- /dev/null +++ b/Dragon/src/PIJS3D.f @@ -0,0 +1,188 @@ +*DECK PIJS3D + SUBROUTINE PIJS3D(NREG,NSOUT,NSLINE,WEIGHT,RCUTOF,SIGTAL, + > SEGLEN,NRSEG,STAYIN,GOSOUT,DPR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Integration for general 3D specular tracking. +* +*Copyright: +* Copyright (C) 1991 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy, G. Marleau +* +*Parameters: input +* NREG total number of regions. +* NSOUT number of outer surface. +* NSLINE number of segemnts on line. +* WEIGHT line weight. +* RCUTOF MFP cut-off factor (truncate lines). +* SIGTAL albedo-cross section vector. +* SEGLEN length of track. +* NRSEG region crossed by track. +* +*Parameters: output +* DPR collision probabilities. +* +*Parameters: scratch +* STAYIN stay-in zone probability. +* GOSOUT goes-out zone probability. +* +*References: +* R. Roy et al., +* A Cyclic Tracking Procedure for CP Calculations in 2-D Lattices +* Conf/Advances in Math, Comp & Reactor Physics, +* Pittsburgh, V 1, P 2.2 4-1 (1991). +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* VARIABLES +*---- + INTEGER NREG,NSOUT,NSLINE,NRSEG(NSLINE) + REAL RCUTOF,SIGTAL(-NSOUT:NREG) + DOUBLE PRECISION WEIGHT,SEGLEN(NSLINE),STAYIN(NSLINE), + > GOSOUT(NSLINE) + DOUBLE PRECISION DPR(-NSOUT:NREG,-NSOUT:NREG) +*---- +* Local variables +*---- + INTEGER IL,JL,NOIL,NOJL,ISODD,JSODD,IJDEL + DOUBLE PRECISION TTOT,XSIL,OPATH,FINV,CUTOF + REAL ZERO,ONE,HALF + PARAMETER (ZERO=0.0E0, ONE=1.0E0, HALF=0.5E0 ) + REAL SIXT,CUTEXP + PARAMETER (SIXT=HALF/3.0,CUTEXP=0.02) + DOUBLE PRECISION EXSIL,XSIL2 + TTOT= ONE +* +*1.1) CHANGE PATHS => GOSOUT AND STAYIN PATHS, INCLUDING ALBEDOS +* ADD *PII* LOCAL NON-CYCLIC CONTRIBUTIONS + ISODD=0 + DO 30 IL= 1, NSLINE + NOIL = NRSEG(IL) + IF( NOIL.LT.0 )THEN + IF(ISODD .EQ. 1) THEN + ISODD=0 +*---- +* FOR SURFACES: +* OLD VERSION BEFORE SURFACE DOUBLING +* GOSOUT= ALBEDO * SURFACE WEIGHT +* WHERE ALL SURFACE WEIGHTS WERE 1.0 +* NEW VERSION WITH SURFACE DOUBLING +* GOSOUT= ALBEDO +* STAYIN = 1- ALBEDO * SURFACE WEIGHT +* TTOT = PRODUCT OF GOSOUT +*---- + GOSOUT(IL)= SIGTAL(NOIL) + STAYIN(IL)= ONE - GOSOUT(IL) + TTOT= TTOT * GOSOUT(IL) + ELSE + ISODD=1 +*---- +* FOR SURFACES: +* OLD VERSION BEFORE SURFACE DOUBLING +* GOSOUT= ALBEDO * SURFACE WEIGHT +* WHERE ALL SURFACE WEIGHTS WERE 1.0 +* NEW VERSION WITH SURFACE DOUBLING +* GOSOUT= ALBEDO +* STAYIN = 1- ALBEDO * SURFACE WEIGHT +* TTOT = PRODUCT OF GOSOUT +*---- + GOSOUT(IL)= SIGTAL(NOIL) + STAYIN(IL)= ONE + ENDIF + ELSE +*---- +* FOR REGIONS +* STAYIN = 1 - EXP[ -CROSS SECTION * LENGTH OF NSLINE] +* GOSOUT = 1 - STAYIN +* TTOT = PRODUCT OF GOSOUT +*---- + XSIL = SIGTAL(NOIL) + IF( XSIL .EQ. ZERO) THEN + GOSOUT(IL)= ONE + STAYIN(IL)= SEGLEN(IL) + DPR(NOIL,NOIL)= DPR(NOIL,NOIL) + > + HALF*WEIGHT*STAYIN(IL)*STAYIN(IL) + ELSE IF( XSIL .LT. CUTEXP) THEN + OPATH= SIGTAL(NOIL)*SEGLEN(IL) + XSIL2=OPATH*OPATH + EXSIL=XSIL2*(HALF-SIXT*OPATH+XSIL2/24.0) + STAYIN(IL)=OPATH-EXSIL + GOSOUT(IL)= ONE - STAYIN(IL) + TTOT= TTOT * GOSOUT(IL) + DPR(NOIL,NOIL)= DPR(NOIL,NOIL) + WEIGHT*EXSIL + ELSE + OPATH= SIGTAL(NOIL)*SEGLEN(IL) + EXSIL= EXP(-OPATH) + STAYIN(IL)= ONE - EXSIL + GOSOUT(IL)= EXSIL + TTOT= TTOT * GOSOUT(IL) + DPR(NOIL,NOIL)= DPR(NOIL,NOIL) + > + WEIGHT*(OPATH-STAYIN(IL)) + ENDIF + ENDIF + 30 CONTINUE +* +*1.2) COMPUTE CYCLIC FACTORS BY ANGLE +* USING GLOBAL TRACK ATTENUATION: BETA(TOT)*EXP(-MFP(TOT)) + IF(TTOT .GE. ONE )THEN + CALL XABORT( 'PIJS3D: ALBEDOS ARE NOT COMPATIBLE') + ENDIF + FINV= WEIGHT / (ONE-TTOT) +* +*1.3) ADD *PIJ* CONTRIBUTIONS FOR FORWARD SOURCES + ISODD=0 + DO 50 IL= 1, NSLINE + NOIL = NRSEG(IL) + TTOT= FINV * STAYIN(IL) + CUTOF= RCUTOF*TTOT + IF( NOIL .LT. 0) THEN + ISODD=MOD(ISODD+1,2) + JSODD=ISODD + DO 70 IJDEL= 1, NSLINE + JL= MOD(IL+IJDEL-1,NSLINE) + 1 + NOJL=NRSEG(JL) + IF( NOJL .LT. 0 ) THEN + JSODD=MOD(JSODD+1,2) + IF( ISODD.EQ.1 .AND. JSODD .EQ.0) THEN + DPR(NOJL,NOIL)= DPR(NOJL,NOIL) + TTOT * STAYIN(JL) + TTOT= TTOT * GOSOUT(JL) + IF( TTOT.LE.CUTOF ) GO TO 55 + ENDIF + ELSE IF(ISODD.EQ.1) THEN + DPR(NOJL,NOIL)= DPR(NOJL,NOIL) + TTOT * STAYIN(JL) + TTOT= TTOT * GOSOUT(JL) + IF( TTOT.LE.CUTOF ) GO TO 55 + ENDIF + 70 CONTINUE + ELSE + JSODD=ISODD + DO 80 IJDEL= 1, NSLINE + JL= MOD(IL+IJDEL-1,NSLINE) + 1 + NOJL=NRSEG(JL) + IF( NOJL .LT. 0 ) THEN + JSODD=MOD(JSODD+1,2) + IF( JSODD .EQ.0) THEN + DPR(NOJL,NOIL)= DPR(NOJL,NOIL) + TTOT * STAYIN(JL) + TTOT= TTOT * GOSOUT(JL) + IF( TTOT.LE.CUTOF ) GO TO 55 + ENDIF + ELSE + DPR(NOJL,NOIL)= DPR(NOJL,NOIL) + TTOT * STAYIN(JL) + TTOT= TTOT * GOSOUT(JL) + IF( TTOT.LE.CUTOF ) GO TO 55 + ENDIF + 80 CONTINUE + ENDIF + 55 CONTINUE + 50 CONTINUE + RETURN + END diff --git a/Dragon/src/PIJSMD.f b/Dragon/src/PIJSMD.f new file mode 100644 index 0000000..7978381 --- /dev/null +++ b/Dragon/src/PIJSMD.f @@ -0,0 +1,152 @@ +*DECK PIJSMD + SUBROUTINE PIJSMD(IMPX,NBMIX,NREGIO,MATCOD,VOLUME,XSSIGW,XSSIGT, + > ILK,PIJSYM,PIJSCT,IOP) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Evaluate scattering modified cp matrix. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IMPX print/check flag (equal to 0 for no print). +* NBMIX number of mixtures considered. +* NREGIO number of regions considered. +* MATCOD material code in region. +* VOLUME volume of region. +* XSSIGW within group scattering 0 or 1 harmonic. +* XSSIGT total macroscopic cross sections. +* ILK leakage flag (ILK=.true. if leakage exists). +* PIJSYM group condensed reduced/symmetric pij or pijk matrix. +* IOP pij (=1) or pijk (=4) collision probability flag. +* +*Parameters: output +* PIJSCT XSSIGW-modified cp matrix (pij or pijk). +* +*----------------------------------------------------------------------- +* + INTEGER IMPX,NBMIX,NREGIO,MATCOD(NREGIO),IOP + REAL VOLUME(NREGIO),XSSIGW(0:NBMIX),XSSIGT(0:NBMIX), + > PIJSYM(NREGIO*(NREGIO+1)/2) + DOUBLE PRECISION PIJSCT(NREGIO,2*NREGIO) + LOGICAL ILK +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6,EPS1=1.0E-4) + DOUBLE PRECISION WRK,F1 +*---- +* INTRINSIC FUNCTION FOR POSITION IN CONDENSE PIJ MATRIX +*---- + INDPOS(I,J)=MAX(I,J)*(MAX(I,J)-1)/2+MIN(I,J) +*---- +* PRINT REDUCED PIJ MATRIX BEFORE SCATTERING REDUCTION +*---- + IF(IMPX.GE.8) THEN + WRITE(IUNOUT,'(/22H MACROSCOPIC TOTAL XS:/(9X,1P,11E11.3))') + > (XSSIGT(MATCOD(I)),I=1,NREGIO) + WRITE(IUNOUT,'(/40H MACROSCOPIC WITHIN-GROUP SCATTERING XS:/ + > (9X,1P,11E11.3))') (XSSIGW(MATCOD(I)),I=1,NREGIO) + ENDIF + IF(IMPX.GE.10) THEN + IF(IOP.EQ.1) THEN + WRITE(IUNOUT,200) + ELSE + WRITE(IUNOUT,210) + ENDIF + WRITE(IUNOUT,240) (J,J=1,NREGIO) + DO 10 I=1,NREGIO + WRITE(IUNOUT,250) I,(PIJSYM(INDPOS(I,J))/VOLUME(I),J=1,NREGIO) + 10 CONTINUE + WRITE(IUNOUT,'(//)') + ENDIF +*---- +* COMPUTE SCATTERING MODIFIED PIJ +*---- + DO 30 I=1,NREGIO + DO 20 J=1,NREGIO + INDPIJ=INDPOS(I,J) + PIJSCT(I,J)=-XSSIGW(MATCOD(J))*PIJSYM(INDPIJ) + PIJSCT(I,NREGIO+J)=PIJSYM(INDPIJ) + 20 CONTINUE + PIJSCT(I,I)=VOLUME(I)+PIJSCT(I,I) + 30 CONTINUE + CALL ALSBD(NREGIO,NREGIO,PIJSCT,IERROR,NREGIO) + IF(IERROR.NE.0) CALL XABORT('PIJSMD: SINGULAR MATRIX.') + DO 50 I=1,NREGIO + DO 40 J=1,NREGIO + PIJSCT(I,J)=PIJSCT(I,NREGIO+J) + 40 CONTINUE + 50 CONTINUE + IF(IMPX.GE.8) THEN + IF(IOP.EQ.1) THEN + WRITE(IUNOUT,220) + ELSE + WRITE(IUNOUT,230) + ENDIF + WRITE(IUNOUT,240) (J,J=1,NREGIO) + DO 60 I=1,NREGIO + WRITE(IUNOUT,250) I,(PIJSCT(I,J),J=1,NREGIO) + 60 CONTINUE + WRITE(IUNOUT,'(//)') + ENDIF + IF((IMPX.GE.10).OR.(IMPX.LT.0).AND.(IOP.EQ.1)) THEN +*---- +* CHECK THE RECIPROCITY CONDITIONS +*---- + VOLTOT=0.0 + DO 70 I=1,NREGIO + VOLTOT=VOLTOT+VOLUME(I) + 70 CONTINUE + VOLTOT=VOLTOT/REAL(NREGIO) + WRK=0.0D0 + DO 90 I=1,NREGIO + DO 80 J=1,NREGIO + WRK=MAX(WRK,ABS(PIJSCT(I,J)*VOLUME(I) + > -PIJSCT(J,I)*VOLUME(J))/VOLTOT) + 80 CONTINUE + 90 CONTINUE + IF(WRK.GE.EPS1) WRITE(IUNOUT,260) WRK +*---- +* CHECK THE CONSERVATION CONDITIONS +*---- + IF(.NOT.ILK) THEN + WRK=0.0D0 + DO 110 I=1,NREGIO + F1=1.0D0 + DO 100 J=1,NREGIO + IBM=MATCOD(J) + F1=F1-PIJSCT(I,J)*(XSSIGT(IBM)-XSSIGW(IBM)) + 100 CONTINUE + WRK=MAX(WRK,ABS(F1)) + 110 CONTINUE + IF(WRK.GE.EPS1) WRITE(IUNOUT,270) WRK + ENDIF + ENDIF + RETURN +* + 200 FORMAT (//51H PIJSMD: REDUCED COLLISION PROBABILITY MATRIX (I --, + 1 6H> J) :/) + 210 FORMAT (//51H PIJSMD: REDUCED DIRECTIONAL COLLISION PROBABILITY , + 1 18HMATRIX (I --> J) :/) + 220 FORMAT (//51H PIJSMD: SCATTERING-REDUCED COLLISION PROBABILITY M, + 1 17HATRIX (I --> J) :/) + 230 FORMAT (//51H PIJSMD: SCATTERING-REDUCED DIRECTIONAL COLLISION P, + 1 29HROBABILITY MATRIX (I --> J) :/) + 240 FORMAT (11X,2HJ=,I4,:,5X,2HJ=,I4,:,5X,2HJ=,I4,:,5X,2HJ=,I4,:,5X, + 1 2HJ=,I4,:,5X,2HJ=,I4,:,5X,2HJ=,I4,:,5X,2HJ=,I4,:,5X,2HJ=,I4,:, + 2 5X,2HJ=,I4,:,5X,2HJ=,I4) + 250 FORMAT (3H I=,I4,2H: ,1P,11E11.3/(9X,11E11.3)) + 260 FORMAT (/50H PIJSMD: THE SCATTERING MODIFIED CP MATRIX DO NOT , + 1 40HMEET THE RECIPROCITY CONDITIONS. RECIP =,1P,E10.3/) + 270 FORMAT (/50H PIJSMD: THE SCATTERING MODIFIED CP MATRIX DO NOT , + 1 40HMEET THE CONSERVATION CONDITIONS. LEAK =,1P,E10.3/) + END diff --git a/Dragon/src/PIJWIJ.f b/Dragon/src/PIJWIJ.f new file mode 100644 index 0000000..c4d9e11 --- /dev/null +++ b/Dragon/src/PIJWIJ.f @@ -0,0 +1,330 @@ +*DECK PIJWIJ + SUBROUTINE PIJWIJ( IPTRK, IPRT, NSOUT, NREG, NBMIX, NANI, + > MATCOD, VOLUME, XSSIGT, XSSIGW, NELPIJ, IPIJK, + > LEAKSW, N2PRO, NSBG, NPSYS, NPST, NALBP, + > ALBP, MATALB, VOLSUR, DPROB, DPROBX, PIJ, + > PROBKS ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the scattering-reduced collision probabilities for +* EXCELL. All surfaces will disappear from the system using external +* boundary conditions. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPTRK pointer to the tracking (L_TRACK signature). +* IPRT print flag (equal to zero for no print). +* NSOUT number of surfaces. +* NREG total number of merged blocks for which specific values +* of the neutron flux and reactions rates are required. +* NBMIX number of mixtures (NBMIX=max(MATCOD(i))). +* NANI number of Legendre orders. +* MATCOD index number of the mixture type assigned to each volume. +* VOLUME volumes. +* XSSIGT total macroscopic cross sections ordered by mixture. +* XSSIGW P0 within-group scattering macroscopic cross sections +* ordered by mixture. +* NELPIJ number of elements in symmetrized pij matrix. +* IPIJK pij option (=1 pij, =4 pijk). +* LEAKSW leakage flag (=.true. if neutron leakage through external +* boundary is present). +* N2PRO number of terms in collision probability matrices, including +* surface and volume contributions. +* NSBG number of energy groups. +* NPSYS non-converged energy group indices. +* NPST first dimension of matrix PROBKS. +* NALBP number of multigroup physical albedos. +* ALBP multigroup physical albedos. +* MATALB global mixture/albedo identification vector. +* VOLSUR global surface volume vector. +* DPROB collision probabilities from EXCELP. +* DPROBX directional collision probabilities from EXCELP. +* +*Parameters: output +* PIJ reduced and symmetrized collision probabilities. +* PROBKS directional collision probabilities. +* +*----------------------------------------------------------------------- +*--------+---------------- R O U T I N E S -------------+--+-----------* +* NAME / DESCRIPTION * +*--------+-------------------------------------------------------------* +* Boundary conditions +* PIJABC / TO ELIMINATE SURFACES USING B.C. OF THE SYSTEM +* PIJAAA / TO ELIMINATE SURFACES FOR PIJKS USING B.C. OF THE SYSTEM +* Various functions +* PIJWPR / TO PRINT CP MATRICES IN SUM FORMAT +* PIJSMD / TO EVALUATE SCATTERING-MODIFIED CP MATRIX +* PIJCMP / COMPRESS CP MATRIX TO SYMETRIC FORMAT +* PIJD2S / CHARGE PROBKS MATRICES IN THE DRAGON SQUARE FORMAT +* PIJD2R / CHARGE PIJ MATRICES IN THE DRAGON SYMMETRIZED FORMAT +* PIJKST / COMPUTE PIJK* MATRICES +*--------+-------------------------------------------------------------* +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + LOGICAL LEAKSW + TYPE(C_PTR) IPTRK + INTEGER IPRT, NSOUT, NREG, NBMIX, NANI, MATCOD(NREG), + > NELPIJ, IPIJK, N2PRO, NSBG, NPSYS(NSBG), NPST, + > NALBP, MATALB(-NSOUT:NREG) + REAL VOLUME(NREG), XSSIGT(0:NBMIX,NSBG), + > XSSIGW(0:NBMIX,NANI,NSBG),ALBP(NALBP,NSBG), + > VOLSUR(-NSOUT:NREG,NSBG),PIJ(NELPIJ,IPIJK,NSBG), + > PROBKS(NPST,NSBG) + DOUBLE PRECISION DPROB(N2PRO,NSBG),DPROBX(N2PRO,NSBG) +*---- +* LOCAL VARIABLES +*---- + INTEGER IOUT, ICPALL, ICPEND, MXGAUS, NSTATE + PARAMETER ( IOUT=6, ICPALL=4, ICPEND=3, MXGAUS=64, + > NSTATE=40 ) + CHARACTER NAMSBR*6 + PARAMETER ( NAMSBR='PIJWIJ') + INTEGER ILONG,ITYPE,NPROB,ISBG,ISTATE(NSTATE),ICODE(6) + REAL FACT,ALBEDO(6),ALBG(6) + LOGICAL LSKIP,SWNZBC,SWVOID +* + INTEGER MSYM,IU,IL,ISOUT,IIN,I,J,IBM,IOP,INDPIJ,IJKS, + > IUN,KSPEC,LOPT,NNREG,IVV,JUN,ISA +*---- +* Variables for NXT: inline tracking +*---- + INTEGER ILCMUP,ILCMDN + PARAMETER (ILCMUP=1,ILCMDN=2) + DOUBLE PRECISION DZERO,DONE,DTWO + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MATRT + REAL, ALLOCATABLE, DIMENSION(:) :: FFACT + REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGTAL + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: PSST,PSVT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: PCSCT +*---- +* INTRINSIC FUNCTION FOR POSITION IN CONDENSE PIJ MATRIX +*---- + INTEGER INDPOS + INDPOS(I,J)=MAX(I,J)*(MAX(I,J)-1)/2+MIN(I,J) +*---- +* RECOVER TRACKING INFORMATION +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + KSPEC=ISTATE(10) + CALL LCMGET(IPTRK,'ICODE',ICODE) + CALL LCMGET(IPTRK,'ALBEDO',ALBG) +*---- +* PREPARE FOR MULTIGROUP CALCULATION +*---- + ALLOCATE(SIGTAL(-NSOUT:NREG,NSBG)) + SWNZBC= .FALSE. + SWVOID= .FALSE. + DO ISBG=1,NSBG + IF(NPSYS(ISBG).NE.0) THEN + DO ISA=1,6 + ALBEDO(ISA)=ALBG(ISA) + ENDDO + IF(NALBP .GT. 0) THEN + DO ISA=1,6 + IF(ICODE(ISA).GT.0) ALBEDO(ISA)=ALBP(ICODE(ISA),ISBG) + ENDDO + ENDIF + DO IUN= -NSOUT, -1 + SIGTAL(IUN,ISBG)= ALBEDO(-MATALB(IUN)) + SWNZBC= SWNZBC.OR.(SIGTAL(IUN,ISBG).NE.0.0) + ENDDO + IUN=0 + SIGTAL(IUN,ISBG)= 0.0 + DO IUN= 1, NREG + SIGTAL(IUN,ISBG)= XSSIGT(MATCOD(IUN),ISBG) + IF( SIGTAL(IUN,ISBG) .EQ. 0.0 ) SWVOID= .TRUE. + ENDDO + ENDIF + ENDDO +*---- +* DOUBLE PRECISION TO REAL FOR DIRECTIONAL PIJ MATRICES +*---- + IF(IPIJK.EQ.4) THEN + DO 2070 ISBG=1,NSBG + IF(NPSYS(ISBG).EQ.0) GO TO 2070 + CALL PIJD2S(NREG,NSOUT,DPROBX(1,ISBG),PROBKS(1,ISBG)) + 2070 CONTINUE + ENDIF + IF( KSPEC.EQ.0 )THEN +*---- +* ELIMINATION OF SURFACES FOR PIJ +*---- + IF( SWNZBC )THEN + ALLOCATE(PSST(NSOUT*NSOUT),PSVT(NSOUT*NREG),MATRT(NSOUT)) + CALL LCMLEN(IPTRK,'BC-REFL+TRAN',ILONG,ITYPE) + IF(ILONG.EQ.NSOUT) THEN + CALL LCMGET(IPTRK,'BC-REFL+TRAN',MATRT) + ELSE + WRITE(IOUT,9000) NAMSBR + DO 130 ISOUT=1,NSOUT + MATRT(ISOUT)=ISOUT + 130 CONTINUE + ENDIF + DO 2080 ISBG=1,NSBG + IF(NPSYS(ISBG).EQ.0) GO TO 2080 + CALL PIJABC(NREG,NSOUT,NPROB,SIGTAL(-NSOUT,ISBG),MATRT, + > DPROB(1,ISBG),PSST,PSVT) +*---- +* ELIMINATION OF SURFACES FOR PIJX AND CREATION OF PIJXX +*---- + IF(IPIJK.EQ.4) THEN + CALL PIJAAA(NREG,NSOUT,SIGTAL(-NSOUT,ISBG), + > DPROBX(1,ISBG),PSVT,PROBKS(1,ISBG)) + CALL PIJABC(NREG,NSOUT,NPROB,SIGTAL(-NSOUT,ISBG),MATRT, + > DPROBX(1,ISBG),PSST,PSVT) + ENDIF + 2080 CONTINUE +* + DEALLOCATE(MATRT,PSVT,PSST) + ENDIF + ENDIF +* + ALLOCATE(FFACT(NREG)) + DO 2090 ISBG=1,NSBG + IF(NPSYS(ISBG).EQ.0) GO TO 2090 + IF( IPRT.GE.ICPEND )THEN + LOPT= +1 + MSYM=1 + WRITE(IOUT,'(1H )') + WRITE(IOUT,'(35H COLLISION PROBABILITIES OUTPUT: , + > 35H *AFTER* ALBEDO REDUCTION )') + CALL PIJWPR(LOPT,NREG,NSOUT,SIGTAL(-NSOUT,ISBG), + > DPROB(1,ISBG),VOLSUR(1,ISBG),MSYM) +* + IF(IPIJK.EQ.4) THEN + WRITE(IOUT,'(35H X-DIRECT. COLL. PROBAB. OUTPUT: , + > 35H *AFTER* ALBEDO REDUCTION )') + CALL PIJWPR(LOPT,NREG,NSOUT,SIGTAL(-NSOUT,ISBG), + > DPROBX(1,ISBG),VOLSUR(1,ISBG),MSYM) + WRITE(IOUT,'(35H0 X-DIRECT. COLL. PROBAB." OUTPUT: , + > 35H PIJX"=PIJX+PISX*(1/(1-PSS))*PSJ )') + MSYM=0 + CALL PIJWPR(LOPT,NREG,NSOUT,SIGTAL(-NSOUT,ISBG), + > DPROBX(1,ISBG),VOLSUR(1,ISBG),MSYM) + ENDIF +* + ENDIF +*---- +* CHARGE PIJ MATRIX IN THE DRAGON SYMMETRIZED FORMAT +*---- + DO 160 IIN=1,NREG + IF(SIGTAL(IIN,ISBG).EQ.0.0) THEN + FFACT(IIN)=1.0 + ELSE + FFACT(IIN)=1.0/SIGTAL(IIN,ISBG) + ENDIF + 160 CONTINUE + CALL PIJD2R(NREG,NSOUT,DPROB(1,ISBG),FFACT,.FALSE.,NELPIJ, + > N2PRO,PIJ(1,1,ISBG)) +*---- +* CHARGE PIJX AND PIJY MATRICES IN THE DRAGON SYMMETRIZED FORMAT +* ( PIJX=PIJY ), AND PIJZ CALCULATION ( PIJZ=3*PIJ-PIJX-PIJY ) +* AND THE SAME FOR FULL MATRICES OF PIJX", PIJY" AND PIJZ" +*---- + IF(IPIJK.EQ.4) THEN + NNREG=NREG*NREG + CALL PIJD2R(NREG,NSOUT,DPROBX(1,ISBG),FFACT,.TRUE.,NELPIJ, + > N2PRO,PIJ(1,2,ISBG)) + IVV=0 + DO 181 IUN=1,NREG + IU=IUN + IL=(IUN-1)*NREG+1 + DO 191 JUN=1,IUN + IVV=IVV+1 + PROBKS(IL,ISBG)=1.5*PROBKS(IL,ISBG)*FFACT(IUN)*FFACT(JUN) + IF(IL.NE.IU)PROBKS(IU,ISBG)=1.5*PROBKS(IU,ISBG)* + > FFACT(IUN)*FFACT(JUN) + PIJ(IVV,3,ISBG)=PIJ(IVV,2,ISBG) + PROBKS(NNREG+IL,ISBG)=PROBKS(IL,ISBG) + PROBKS(NNREG+IU,ISBG)=PROBKS(IU,ISBG) + PIJ(IVV,4,ISBG)=3*PIJ(IVV,1,ISBG)-PIJ(IVV,2,ISBG) + > -PIJ(IVV,3,ISBG) + PROBKS(2*NNREG+IL,ISBG)=3*PIJ(IVV,1,ISBG) + > -PROBKS(IL,ISBG)-PROBKS(NNREG+IL,ISBG) + PROBKS(2*NNREG+IU,ISBG)=3*PIJ(IVV,1,ISBG) + > -PROBKS(IU,ISBG)-PROBKS(NNREG+IU,ISBG) + IU=IUN+JUN*NREG + IL=IL+1 + 191 CONTINUE + 181 CONTINUE +*---- +* COMPUTE PIJ**(-1)*PIJK* +*---- + CALL PIJKST(IPRT,NREG,PIJ(1,1,ISBG),PROBKS(1,ISBG)) + ENDIF + 2090 CONTINUE + DEALLOCATE(FFACT) +* + DEALLOCATE(SIGTAL) +*---- +* CHECK IF SCATTERING REDUCTION IS REQUIRED +*---- + ALLOCATE(PCSCT(NREG,2*NREG)) + DO 3000 ISBG=1,NSBG + IF(NPSYS(ISBG).EQ.0) GO TO 3000 + LSKIP=.TRUE. + DO 200 IBM=1,NBMIX + LSKIP=LSKIP.AND.(XSSIGW(IBM,1,ISBG).EQ.0.0) + 200 CONTINUE +*---- +* COMPUTE THE SCATTERING-REDUCED CP MATRICES +*---- + IOP=1 + IF(.NOT.LSKIP) THEN + CALL PIJSMD(IPRT,NBMIX,NREG,MATCOD,VOLUME,XSSIGW(0,1,ISBG), + > XSSIGT(0,ISBG),LEAKSW,PIJ(1,1,ISBG),PCSCT,IOP) + DO 220 I=1,NREG + FACT=VOLUME(I) + DO 210 J=1,NREG + INDPIJ=INDPOS(I,J) + PIJ(INDPIJ,1,ISBG)=REAL(PCSCT(I,J))*FACT + 210 CONTINUE + 220 CONTINUE + ENDIF +*------- + IF(IPIJK.EQ.4) THEN + IOP=4 + IF(.NOT.LSKIP) THEN +* P1 SCATTERING REDUCTION OF THE DIRECTIONNAL CP MATRICES. + IF(NANI.LT.2) CALL XABORT('PIJWIJ: ANISOTROPIC SCAT MISSING.') + DO 250 IJKS=1,3 + CALL PIJSMD(IPRT,NBMIX,NREG,MATCOD,VOLUME,XSSIGW(0,2,ISBG), + > XSSIGT(0,ISBG),LEAKSW,PIJ(1,IJKS+1,ISBG),PCSCT, + > IOP) + DO 240 I=1,NREG + FACT=VOLUME(I) + DO 230 J=1,NREG + INDPIJ=INDPOS(I,J) + PIJ(INDPIJ,IJKS+1,ISBG)=REAL(PCSCT(I,J))*FACT + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + ENDIF + ENDIF + 3000 CONTINUE + DEALLOCATE(PCSCT) + RETURN +* + 9000 FORMAT(1X,A6,': *** WARNING *** '/ + > ' REFLECTION/TRANSMISSION MATRIX MISSING'/ + > ' USE IDENTITY REFLECTION MATRIX') + END diff --git a/Dragon/src/PIJWPR.f b/Dragon/src/PIJWPR.f new file mode 100644 index 0000000..b5bf2bc --- /dev/null +++ b/Dragon/src/PIJWPR.f @@ -0,0 +1,222 @@ +*DECK PIJWPR + SUBROUTINE PIJWPR(LOPT,NREG,NSOUT,SIGTAL,PROB,SIGVOL,MSYM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Print-out for probability matrices. +* +*Copyright: +* Copyright (C) 1991 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy, G. Marleau +* +*Parameters: input +* LOPT print-out form: +* <= 0 print all PSS/PVS/PVV; +* > 0 print only PVV. +* NREG total number of regions. +* NSOUT number of outer surface. +* SIGTAL albedo-cross section vector. +* PROB collision probabilities. +* SIGVOL region volumes. +* MSYM matrix format: +* = 1 symmetric matrix; +* = 0 non-symmetric full matrix. +* +*Comments: +* Format of compress probability matrix +* NPLEN=(NREG+NSOUT+2)*(NREG+NSOUT+1)/2 +* IND(I,J)=MAX(I+NSOUT+1,J+NSOUT+1) +* *(MAX(I+NSOUT+1,J+NSOUT+1)-1)/2 +* +MIN(I+NSOUT+1,J+NSOUT+1) +* IS=-NSOUT,-1; JS=-NSOUT,IS; I=IND(IS,JS) +* PROB(I)=VOLSUR(IS)*PSS(IS,JS) +* IV=1,NREG; JS=-NSOUT,-1; I=IND(IV,JS) +* SIGT(IV).GT.0.0 +* PROB(I)=SIGT(IV)*VOLSUR(IV)*PVS(IV,JS) +* SIGT(IV).EQ.0.0 +* PROB(I)=VOLSUR(IV)*PVS(IV,JS) +* IV=1,NREG; JV=1,IV; I=IND(IV,JV) +* SIGT(IV).GT.0.0 AND SIGT(JV).GT.0.0 +* PROB(I)=SIGT(IV)*SIGT(JV)*VOLSUR(IV)*PVV(IV,JV) +* SIGT(IV).GT.0.0 AND SIGT(JV).EQ.0.0 +* PROB(I)=SIGT(IV)*VOLSUR(IV)*PVV(IV,JV) +* SIGT(IV).EQ.0.0 AND SIGT(JV).GT.0.0 +* PROB(I)=SIGT(JV)*VOLSUR(IV)*PVV(IV,JV) +* SIGT(IV).EQ.0.0 AND SIGT(JV).EQ.0.0 +* PROB(I)=VOLSUR(IV)*PVV(IV,JV) +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE + INTEGER IUNOUT, LOPT, NREG, NSOUT, MSYM, + > IND, I, J, NSUR, NVOL, + > NSURC, NSURM, NVOLC, NVOLM, IP, IR, + > JR, III + PARAMETER (IUNOUT=6) + REAL SIGTAL(-NSOUT:NREG), BILANP(10), XSJR, WPR, + > VPR(10), SIGVOL(NREG), COF + DOUBLE PRECISION PROB(*) +* + IND(I,J) = MAX(I+NSOUT+1,J+NSOUT+1)*(MAX(I+NSOUT+1,J+NSOUT+1)-1)/2 + > + MIN(I+NSOUT+1,J+NSOUT+1) +* + WPR(I,J)= REAL(PROB( IND(I,J) ) / PROB( IND(I,0) )) +* +*NOTE: +* IF( SIGT(I).NE.0.0 )THEN +* PROB(IND(I,0))= SIGT(I) * VOLSUR(I) +* ELSE +* PROB(IND(I,0))= VOLSUR(I) +* ENDIF +* + NSUR= -NSOUT + NVOL= NREG +* + WRITE(IUNOUT,'(24H REGIONAL CROSS SECTIONS)') + WRITE(IUNOUT,'(5(1X,6HREGION,5X,16HCROSS SECTION ))') + WRITE(IUNOUT,'(5(1X,I6,3X,E15.7))') (JR,SIGTAL(JR),JR=1,NVOL) + IF(MSYM .EQ. 0) THEN + WRITE(IUNOUT,'(5(1X,6HREGION,5X,16HVOLUMES ))') + WRITE(IUNOUT,'(5(1X,I6,3X,E15.7))') + > (JR,SIGVOL(JR),JR=1,NVOL) + ELSE + WRITE(IUNOUT,'(5(1X,6HREGION,5X,16HSURFACE/VOLUMES ))') + WRITE(IUNOUT,'(5(1X,I6,3X,E15.7))') + > (JR,PROB(IND(JR,0)),JR=-NSOUT,NVOL) + ENDIF + IF( LOPT.LE.0 )THEN + NSURC = -1 + DO 40 IP = 1, (9 - NSUR) / 10 + NSURM= MAX( NSUR, NSURC-9 ) + WRITE(IUNOUT,'(30H0 SURFACE CONSERVATION LAWS: , + > 31H( P.S<-S + P.V<-S = 1 + ERR.S ) , + > 31H FOR XS.TOTAL=0, REDUCED P.V<-S , + > 11H IS PRINTED )') + WRITE(IUNOUT,'(1X,8H(P.S<-S),1X,10( A5, I6,:)/)') + > (' SUR ',-IR,IR= NSURC, NSURM, -1) + DO 10 IR =NSURC, NSURM, -1 + BILANP(IR-NSURM+1)= 0.0 + 10 CONTINUE + DO 25 JR = -1, NSUR, -1 + WRITE(IUNOUT,'(5H SUR ,I4,1X,10F11.8)') + > -JR, (WPR(IR,JR),IR=NSURC,NSURM,-1) + DO 20 IR = NSURC, NSURM, -1 + BILANP(IR-NSURM+1)= BILANP(IR-NSURM+1) + > + WPR(IR,JR) + 20 CONTINUE + 25 CONTINUE + WRITE(IUNOUT,'(1X,8H(P.V<-S) )') + DO 35 JR = 1, NVOL, 1 + IF( SIGTAL(JR).EQ.0.0 ) THEN + WRITE(IUNOUT,'(5H VOL ,I4,1X,3H 0*,10(F8.5,:,3H 0*))') + > JR,(WPR(IR,JR),IR=NSURC,NSURM,-1) + XSJR= 0.0 + ELSE + WRITE(IUNOUT,'(5H VOL ,I4,1X,10F11.8)') + > JR,(WPR(IR,JR),IR=NSURC,NSURM,-1) + XSJR= 1.0 + ENDIF + DO 30 IR = NSURC, NSURM, -1 + BILANP(IR-NSURM+1)= BILANP(IR-NSURM+1) + > + XSJR * WPR(IR,JR) + 30 CONTINUE + 35 CONTINUE + WRITE(IUNOUT,'(1H )') + WRITE(IUNOUT,'(5H SUM ,5X,10F11.8)') + > (BILANP(IR-NSURM+1),IR=NSURC,NSURM,-1) + NSURC = NSURC - 10 + 40 CONTINUE + ENDIF + NVOLC = 1 + DO 90 IP = 1, (9 + NVOL) / 10 + NVOLM= MIN( NVOL, NVOLC+9 ) + IF( LOPT.LE.0 )THEN + WRITE(IUNOUT,'(30H0 VOLUME CONSERVATION LAWS: , + > 31H( P.S<-V + P.V<-V = 1 + ERR.V ) , + > 31H FOR XS.TOTAL=0, REDUCED P.V<-V , + > 11H IS PRINTED )') + ELSE + WRITE(IUNOUT,'(30H0 VOLUME CONSERVATION LAWS: , + > 32H( SUM OF P.V<-V = 1 + ESCAPE.V ) , + > 31H FOR XS.TOTAL=0, REDUCED P.V<-V , + > 11H IS PRINTED )') + ENDIF + DO 50 IR = NVOLC, NVOLM, 1 + BILANP(IR-NVOLC+1)= 0.0 + 50 CONTINUE + IF( LOPT.LE.0 )THEN + WRITE(IUNOUT,'(1X,8H(P.S<-V),1X,10( A5 , I6,:)/)') + > (' VOL ',IR,IR=NVOLC,NVOLM, 1) + DO 65 JR = -1, NSUR, -1 + WRITE(IUNOUT,'(5H SUR ,I4,1X,10F11.8)') + > -JR, (WPR(IR,JR),IR=NVOLC,NVOLM, 1) + DO 60 IR = NVOLC, NVOLM, 1 + BILANP(IR-NVOLC+1)= BILANP(IR-NVOLC+1) + > + WPR(IR,JR) + 60 CONTINUE + 65 CONTINUE + WRITE(IUNOUT,'(1X,8H(P.V<-V) )') + ELSE + WRITE(IUNOUT,'(1X,8H(P.V<-V),1X,10( A5 , I6,:)/)') + > (' VOL ',IR,IR=NVOLC,NVOLM, 1) + ENDIF +* + IF(LOPT.GT.0.AND.MSYM.EQ.0)THEN +* +* PRINTING OF PIJK" FULL MATRIX +* + COF=1.5 + DO 70 JR = 1, NVOL, 1 + IF( SIGTAL(JR).EQ.0.0 )THEN + DO 75 IR=NVOLC, NVOLM, 1 + III=JR+NREG*(IR-1) + VPR(IR-NVOLC+1)=COF*REAL(PROB(III))/SIGVOL(IR) + 75 CONTINUE + WRITE(IUNOUT,'(5H VOL ,I4,1X,3H 0*,10(F8.5,:,3H 0*))') + > JR,(VPR(IR-NVOLC+1),IR=NVOLC,NVOLM,1) + ELSE + DO 76 IR=NVOLC, NVOLM, 1 + III=JR+NREG*(IR-1) + VPR(IR-NVOLC+1)=COF*REAL(PROB(III))/SIGVOL(IR) + BILANP(IR-NVOLC+1)=BILANP(IR-NVOLC+1)+VPR(IR-NVOLC+1) + 76 CONTINUE + WRITE(IUNOUT,'(5H VOL ,I4,1X,10F11.8)') + > JR,(VPR(IR-NVOLC+1),IR=NVOLC,NVOLM,1) + ENDIF + 70 CONTINUE + WRITE(IUNOUT,'(1H )') + WRITE(IUNOUT,'(5H SUM ,5X,10F11.8)') + > (BILANP(IR-NVOLC+1),IR=NVOLC,NVOLM, 1) +* + ELSE +* + DO 85 JR = 1, NVOL, 1 + IF( SIGTAL(JR).EQ.0.0 )THEN + WRITE(IUNOUT,'(5H VOL ,I4,1X,3H 0*,10(F8.5,:,3H 0*))') + > JR,(WPR(IR,JR),IR=NVOLC,NVOLM,1) + XSJR= 0.0 + ELSE + WRITE(IUNOUT,'(5H VOL ,I4,1X,10F11.8)') + > JR,(WPR(IR,JR),IR=NVOLC,NVOLM,1) + XSJR= 1.0 + ENDIF + DO 80 IR = NVOLC, NVOLM, 1 + BILANP(IR-NVOLC+1)= BILANP(IR-NVOLC+1) + > + XSJR*WPR(IR,JR) + 80 CONTINUE + 85 CONTINUE + WRITE(IUNOUT,'(1H )') + WRITE(IUNOUT,'(5H SUM ,5X,10F11.8)') + > (BILANP(IR-NVOLC+1),IR=NVOLC,NVOLM, 1) + ENDIF + NVOLC = NVOLC + 10 + 90 CONTINUE +* + RETURN + END diff --git a/Dragon/src/PIJXL3.f b/Dragon/src/PIJXL3.f new file mode 100644 index 0000000..1d79b45 --- /dev/null +++ b/Dragon/src/PIJXL3.f @@ -0,0 +1,449 @@ +*DECK PIJXL3 + SUBROUTINE PIJXL3(IPTRK,IPRT,NGRP,NANI,NBMIX,NPSYS,NRENOR,LEAKSW, + > XSSIGT,XSSIGW,NELPIJ,PIJ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the collision probabilities in EXCELL without producing +* a tracking file. Based on subroutine XL3TRK in DRAGON 3.4. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy and A. Hebert +* +*Parameters: input +* IPTRK pointer to the tracking (L_TRACK signature). +* IPRT print flag (equal to zero for no print). +* NGRP number of energy groups. +* NANI number of Legendre orders (usually equal to one). +* NBMIX number of mixtures. +* NPSYS index set to zero if a group is not to be processed. Usually, +* NPSYS(I)=I. +* NRENOR normalization scheme for PIJ matrices. +* LEAKSW leakage flag (=.true. if neutron leakage through external +* boundary is present). +* XSSIGT total macroscopic cross sections ordered by mixture. +* XSSIGW P0 within-group scattering macroscopic cross sections +* ordered by mixture. +* NELPIJ number of elements in symmetrized pij matrix. +* +*Parameters: output +* PIJ reduced and symmetrized collision probabilities. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + LOGICAL LEAKSW + TYPE(C_PTR) IPTRK + INTEGER IPRT,NGRP,NANI,NBMIX,NPSYS(NGRP),NRENOR,NELPIJ + REAL XSSIGT(0:NBMIX,NGRP),XSSIGW(0:NBMIX,NANI,NGRP), + > PIJ(NELPIJ,NGRP) +*---- +* LOCAL VARIABLES +*---- + INTEGER IOUT,NALB,NSTATE,ICPALL,ICPEND + PARAMETER (IOUT=6,NALB=6,NSTATE=40,ICPALL=4,ICPEND=3) + INTEGER NDIM ,ISPEC ,NANGLE,NANGL ,ISYMM, NORE + INTEGER NALBG ,NC ,NTR ,NTZ ,ICL ,NSOUT , + > ITGEO ,NRMV ,NTY ,LTRK ,LINMAX,NUNK , + > MAXR ,NEXTGE,NTX ,NCOR ,NSUR ,NTOTCL, + > NVOL ,NV ,NS ,IGRP ,ISOUT ,ILONG , + > ITYPE ,INDPIJ,IIN ,IBM ,I ,J , + > NPIJ ,NREG ,NUNKMR + INTEGER ISTATE(NSTATE),LCLSYM(3) + INTEGER MXANGL,ICODE(NALB) + LOGICAL SWVOID,SWNZBC,LSKIP + REAL ALBOLD(NALB),EXTKOP(NSTATE),DENUSR, RCUTOF, + > CUTOFX, FACT +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MINDIM,MAXDIM,ICORD,INDEL, + > KEYMRG,MATALB,MATMRG,ICUR,INCR,NUMERO,MATRT + REAL, ALLOCATABLE, DIMENSION(:) :: REMESH,VOLSUR,VOLMRG,CONV, + > TRKBEG,TRKDIR,FFACT,ANGLES,DENSTY + REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGVOL,SIGTAL + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: LENGHT,VOLTRK, + > PSST,PSVT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: DBLPIJ,PCSCT +*---- +* INTRINSIC FUNCTION FOR POSITION IN CONDENSE PIJ MATRIX +*---- + INTEGER INDPOS + INDPOS(I,J)=MAX(I,J)*(MAX(I,J)-1)/2+MIN(I,J) +*---- +* READ THE GEOMETRY INFORMATION STORED ON IPTRK +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + NORE=ISTATE(8) + LTRK=ISTATE(9)+1 + NANGLE=ISTATE(11) + ISYMM=ISTATE(12) + CALL LCMGET(IPTRK,'EXCELTRACKOP',EXTKOP) + CUTOFX=EXTKOP(1) + DENUSR=EXTKOP(2) + RCUTOF=EXTKOP(3) + CALL LCMSIX(IPTRK,'EXCELL',1) + ISTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + NDIM =ISTATE(1) + NSUR =-ISTATE(2) + NVOL =ISTATE(3) + NTOTCL =ISTATE(4) + MAXR =ISTATE(5) + NUNK =ISTATE(6) + NEXTGE =ISTATE(7) +*---- +* Intrinsic symmetries used in geometry +* Use these to simplify tracking unless +* NOSYMM tracking option activated +*---- + LCLSYM(1) =ISTATE(8) + LCLSYM(2) =ISTATE(9) + LCLSYM(3) =ISTATE(10) + IF(ISYMM .NE. 0) THEN + ISYMM=0 + IF(NDIM .EQ. 2) THEN + IF(LCLSYM(1) .NE. 0) THEN +*---- +* X SYMMETRY +*---- + ISYMM=2 + ENDIF + IF(LCLSYM(2) .NE. 0) THEN + IF(ISYMM .EQ. 0) THEN +*---- +* Y SYMMETRY +*---- + ISYMM=4 + ELSE +*---- +* X AND Y SYMMETRY +*---- + ISYMM=8 + ENDIF + ENDIF +*---- +* X-Y DIAGONAL SYMMETRY +*---- + ELSE + IF(LCLSYM(1) .NE. 0) THEN +*---- +* X SYMMETRY +*---- + ISYMM=2 + ENDIF + IF(LCLSYM(2) .NE. 0) THEN + IF(ISYMM .EQ. 0) THEN +*---- +* Y SYMMETRY +*---- + ISYMM=4 + ELSE +*---- +* X AND Y SYMMETRY +*---- + ISYMM=8 + ENDIF + ENDIF + IF(LCLSYM(3) .NE. 0) THEN +*---- +* Z SYMMETRY +*---- + ISYMM=ISYMM+16 + ENDIF + ENDIF + IF(ISYMM .EQ. 0) ISYMM=1 + ENDIF + ALLOCATE(MINDIM(NTOTCL),MAXDIM(NTOTCL),ICORD(NTOTCL), + > INDEL(4*NUNK),KEYMRG(NUNK),MATALB(NUNK)) + ALLOCATE(REMESH(MAXR),VOLSUR(NUNK)) + CALL LCMGET(IPTRK,'MINDIM ',MINDIM) + CALL LCMGET(IPTRK,'MAXDIM ',MAXDIM) + CALL LCMGET(IPTRK,'ICORD ',ICORD ) + CALL LCMGET(IPTRK,'INDEX ',INDEL ) + CALL LCMGET(IPTRK,'REMESH ',REMESH) + CALL LCMGET(IPTRK,'KEYMRG ',KEYMRG) + CALL LCMGET(IPTRK,'MATALB ',MATALB) + CALL LCMGET(IPTRK,'VOLSUR ',VOLSUR) + CALL LCMSIX(IPTRK,'EXCELL ',2) + CALL LCMGET(IPTRK,'ICODE ',ICODE ) + CALL LCMGET(IPTRK,'ALBEDO ',ALBOLD) +*---- +* VERIFY SYMMETRY AND STUDY TRACKING PARAMETERS. ARE THEY BASICALLY +* POSSIBLE ? +*---- + MXANGL=0 + IF(LTRK .EQ. 1)THEN + NCOR= 1 + IF(NDIM .EQ. 2) THEN + MXANGL=NANGLE + IF(ISYMM .GE. 2) THEN + NANGL = (NANGLE+1)/2 + ELSE + NANGL = NANGLE + ENDIF + IF( RCUTOF.GT.0.0 ) NCOR= 2 + ELSE IF(NDIM .EQ. 3) THEN + IF(MOD(NANGLE,2) .EQ. 1)THEN + NANGLE=NANGLE+1 + WRITE(IOUT,'(/31H MESS = ONLY EVEN # EQN ANGLES )') + ENDIF + IF(NANGLE .GT. 16)THEN + NANGLE=16 + WRITE(IOUT,'(/31H MESS = 16 IS MAX # EQN ANGLES )') + ENDIF + MXANGL=(NANGLE * (NANGLE+2)) / 2 + IF(NEXTGE .EQ. 1) THEN + NANGL = (NANGLE * (NANGLE+2)) / 8 + ELSE + IF(ISYMM .EQ. 8 .OR. ISYMM .EQ. 24) THEN + NANGL = (NANGLE * (NANGLE+2)) / 8 + ELSE IF(ISYMM .EQ. 2 .OR. ISYMM .EQ. 4 .OR. + > ISYMM .EQ. 18 .OR. ISYMM .EQ. 20 ) THEN + NANGL = (NANGLE * (NANGLE+2)) / 4 + ELSE + NANGL = (NANGLE * (NANGLE+2)) / 2 + ENDIF + ENDIF + IF(RCUTOF .GT. 0.0) NCOR= 4 + ENDIF + ELSEIF( LTRK.EQ.2 )THEN + NCOR = 1 + MXANGL=NANGLE + IF( NDIM.EQ.2 )THEN + NANGL = NANGLE + ELSEIF( NDIM.EQ.3 )THEN + CALL XABORT('PIJXL3: *TSPC* NOT AVAILABLE FOR 3-D GEOMETRY') + ENDIF + CUTOFX= RCUTOF + ENDIF + IF( IPRT.GE.1 ) THEN + WRITE(IOUT,6002) NANGL,ISYMM,CUTOFX,DENUSR,RCUTOF + ENDIF + IF( IPRT.GT.1 .AND. NEXTGE.EQ.0 )THEN +* +* IF PRINT REQUIRED AND OVERALL CARTESIAN GEOMETRY +* PRINT CARTESIAN REGION MAP + NTX= MAXDIM(1)-MINDIM(1) + NTY= MAXDIM(2)-MINDIM(2) + NTZ= MAXDIM(3)-MINDIM(3) + NTR=0 + DO 103 ICL=4,NTOTCL + NTR= MAX(NTR,MAXDIM(ICL)-MINDIM(ICL)+1) + 103 CONTINUE + CALL XELGPR(NDIM,NTX,NTY,NTZ,NTR,ISYMM, + > NSUR,NVOL,NTOTCL,MINDIM,MAXDIM, + > KEYMRG,INDEL,MATALB) + ENDIF + ALLOCATE(VOLTRK((NANGL+1)*NUNK)) +* + NV= NVOL + NS= -NSUR + ALLOCATE(VOLMRG(NUNK),MATMRG(NUNK)) + ITGEO=3 + CALL XELCMP( NS, NV, VOLSUR, MATALB, KEYMRG, + > NSOUT, NREG, VOLMRG, MATMRG, ITGEO,ICODE) + NUNKMR= NREG+NSOUT+1 + NPIJ= (NUNKMR*(NUNKMR+1))/2 + IF( IPRT .GT. 1 ) WRITE(IOUT,6000) (NGRP*NPIJ/128) + ALLOCATE(DBLPIJ(NPIJ,NGRP)) + IF( IPRT .GT. 1 ) WRITE(IOUT,6001) +* +* ALLOCATE AND CHARGE TOTAL XS PER REGION + ALLOCATE(SIGTAL(NUNKMR,NGRP),SIGVOL(NREG,NGRP)) +* +* 3) DO THE TRACKING OF THE EXACT GEOMETRY FOR *NEWT* OPTION. + IF( LTRK.NE.0 )THEN + NC= NTOTCL - 3 + IF( IPRT.GE.1 )THEN + WRITE(IOUT,'(1H )') + IF( NC.EQ.0 )THEN + WRITE(IOUT,'(/38H NOW, TRACKING GEOMETRY WITH NO CYLIND, + > 2HER/)') + ELSEIF( NC.EQ.1 )THEN + WRITE(IOUT,'(/38H NOW, TRACKING GEOMETRY WITH ONE CYLIN, + > 3HDER/)') + ELSE + WRITE(IOUT,'(/28H NOW, TRACKING GEOMETRY WITH,I4, + > 10H CYLINDERS/)') NC + ENDIF + ENDIF + ALLOCATE(ICUR(NTOTCL),INCR(NTOTCL)) + ALLOCATE(CONV(NTOTCL),TRKBEG(NTOTCL),TRKDIR(NTOTCL)) +* +* 3.0) WRITE FIRST RECORDS OF THE UNNORMALIZED TRACKING FILE + IF( LTRK.EQ.1 )THEN + LINMAX= 2*NVOL + 10 + ELSE + LINMAX= 8*NANGL*(2*NVOL + 8) + ENDIF + ISPEC = LTRK-1 + NALBG = 6 + ALLOCATE(NUMERO(LINMAX)) + ALLOCATE(LENGHT(LINMAX),ANGLES(3*MXANGL),DENSTY(MXANGL)) +* + NRMV=1 + CALL XL3TI3( IPRT, NANGLE, DENUSR, ISYMM, ANGLES, DENSTY, + > NTOTCL, NEXTGE, MAXR, REMESH, LINMAX, RCUTOF, + > NSUR, NVOL, INDEL, MINDIM, MAXDIM, ICORD, + > INCR, ICUR, TRKBEG, CONV, TRKDIR, LENGHT, + > NUMERO, NPIJ, NGRP, SIGTAL, SWVOID, NORE, + > NRMV, VOLTRK, KEYMRG,-NSOUT, NREG, NPSYS, + > DBLPIJ ) +* + CALL XL3NTR( IPRT, NDIM, ISPEC, NS, NV, NORE, VOLSUR, KEYMRG, + > MATALB, NANGL, VOLTRK, DENSTY ) +* + CALL XL3SIG( NGRP, NBMIX, XSSIGT, ALBOLD, NPSYS, NGRP, -NSOUT, + > NREG, MATMRG, VOLMRG(NSOUT+2), SIGTAL, SIGVOL, + > SWVOID, SWNZBC) +* + NRMV=0 + CALL XL3TI3( IPRT, NANGLE, DENUSR, ISYMM, ANGLES, DENSTY, + > NTOTCL, NEXTGE, MAXR, REMESH, LINMAX, RCUTOF, + > NSUR, NVOL, INDEL, MINDIM, MAXDIM, ICORD , + > INCR, ICUR, TRKBEG, CONV, TRKDIR, LENGHT, + > NUMERO, NPIJ, NGRP, SIGTAL, SWVOID, NORE, + > NRMV, VOLTRK, KEYMRG, -NSOUT, NREG , NPSYS, + > DBLPIJ ) +* + CALL QIJCMP(NREG,-NSOUT,NPIJ,NGRP,NCOR,VOLMRG,SIGTAL,DBLPIJ, + > NPSYS) +*---- +* RENORMALIZE ALL ISOTROPIC PROBS WITH VARIOUS OPTIONS +*---- + DO 2060 IGRP=1,NGRP + IF(NPSYS(IGRP).EQ.0) GO TO 2060 + IF( NRENOR.EQ.1 )THEN +* +* NORMALIZATION USING GELBARD SCHEME + CALL PIJRGL(IPRT,NREG,NSOUT,SIGTAL(1,IGRP),DBLPIJ(1,IGRP)) + ELSEIF( NRENOR.EQ.2 )THEN +* +* NORMALIZATION WORKING ON DIAGONAL COEFFICIENTS + CALL PIJRDG(NREG,NSOUT,SIGTAL(1,IGRP),DBLPIJ(1,IGRP) ) + ELSEIF( NRENOR.EQ.3 )THEN +* +* NORMALIZATION WORKING ON WEIGHT FACTORS TO KEEP DIAG = 0.0 + CALL PIJRNL(IPRT,NREG,NSOUT,SIGTAL(1,IGRP),DBLPIJ(1,IGRP)) + ELSEIF( NRENOR .EQ. 4 )THEN ! ATTENTION +* +* NORMALIZATION WORKING ON WEIGHT FACTORS ADDITIVE (HELIOS) + CALL PIJRHL(IPRT,NREG,NSOUT,SIGTAL(1,IGRP),DBLPIJ(1,IGRP)) + ENDIF + IF( IPRT.GE.ICPALL )THEN + WRITE(IOUT,'(1H )') + WRITE(IOUT,'(35H COLLISION PROBABILITIES OUTPUT: , + > 35H *BEFORE* ALBEDO REDUCTION )') + CALL PIJWPR(0,NREG,NSOUT,SIGTAL(1,IGRP),DBLPIJ(1,IGRP), + > SIGVOL(1,IGRP),1) + ENDIF + 2060 CONTINUE +*---- +* ELIMINATION OF SURFACES FOR PIJ +*---- + IF( SWNZBC )THEN + ALLOCATE(PSST(NSOUT*NSOUT),PSVT(NSOUT*NREG)) + ALLOCATE(MATRT(NSOUT)) + CALL LCMLEN(IPTRK,'BC-REFL+TRAN',ILONG,ITYPE) + IF(ILONG.EQ.NSOUT) THEN + CALL LCMGET(IPTRK,'BC-REFL+TRAN',MATRT) + ELSE + DO 130 ISOUT=1,NSOUT + MATRT(ISOUT)=ISOUT + 130 CONTINUE + ENDIF + DO 2080 IGRP=1,NGRP + IF(NPSYS(IGRP).EQ.0) GO TO 2080 + CALL PIJABC(NREG,NSOUT,NPIJ,SIGTAL(1,IGRP),MATRT, + > DBLPIJ(1,IGRP),PSST,PSVT) + 2080 CONTINUE +* + DEALLOCATE(MATRT) + DEALLOCATE(PSVT,PSST) + ENDIF +* + ALLOCATE(FFACT(NREG)) + DO 2090 IGRP=1,NGRP + IF(NPSYS(IGRP).EQ.0) GO TO 2090 + IF( IPRT.GE.ICPEND )THEN + WRITE(IOUT,'(1H )') + WRITE(IOUT,'(35H COLLISION PROBABILITIES OUTPUT: , + > 35H *AFTER* ALBEDO REDUCTION )') + CALL PIJWPR(1,NREG,NSOUT,SIGTAL(1,IGRP),DBLPIJ(1,IGRP), + > SIGVOL(1,IGRP),1) + ENDIF +*---- +* CHARGE PIJ MATRIX IN THE DRAGON SYMMETRIZED FORMAT +*---- + DO 160 IIN=1,NREG + IF(SIGTAL(NSOUT+IIN+1,IGRP).EQ.0.0) THEN + FFACT(IIN)=1.0 + ELSE + FFACT(IIN)=1.0/SIGTAL(NSOUT+IIN+1,IGRP) + ENDIF + 160 CONTINUE + CALL PIJD2R(NREG,NSOUT,DBLPIJ(1,IGRP),FFACT,.FALSE.,NELPIJ, + > NPIJ,PIJ(1,IGRP)) + 2090 CONTINUE + DEALLOCATE(FFACT) +* + DEALLOCATE(DENSTY,ANGLES,LENGHT,NUMERO,TRKDIR,TRKBEG,CONV, + > INCR,ICUR) + ENDIF + DEALLOCATE(INDEL,ICORD,MAXDIM,MINDIM,REMESH,DBLPIJ,SIGTAL,SIGVOL, + > VOLSUR,VOLTRK,KEYMRG,MATALB) +*---- +* CHECK IF SCATTERING REDUCTION IS REQUIRED +*---- + ALLOCATE(PCSCT(NREG,2*NREG)) + DO 3000 IGRP=1,NGRP + IF(NPSYS(IGRP).EQ.0) GO TO 3000 + LSKIP=.TRUE. + DO 200 IBM=1,NBMIX + LSKIP=LSKIP.AND.(XSSIGW(IBM,1,IGRP).EQ.0.0) + 200 CONTINUE +*---- +* COMPUTE THE SCATTERING-REDUCED CP MATRICES +*---- + IF(.NOT.LSKIP) THEN + CALL PIJSMD(IPRT,NBMIX,NREG,MATMRG(NSOUT+2),VOLMRG(NSOUT+2), + > XSSIGW(0,1,IGRP),XSSIGT(0,IGRP),LEAKSW,PIJ(1,IGRP), + > PCSCT,1) + DO 220 I=1,NREG + FACT=VOLMRG(NSOUT+I+1) + DO 210 J=1,NREG + INDPIJ=INDPOS(I,J) + PIJ(INDPIJ,IGRP)=REAL(PCSCT(I,J))*FACT + 210 CONTINUE + 220 CONTINUE + ENDIF + 3000 CONTINUE + DEALLOCATE(PCSCT,VOLMRG,MATMRG) + RETURN +*---- +* FORMAT +*---- + 6000 FORMAT(' *** SPACE REQUIRED FOR CP MATRICES = ',I10,' K ***') + 6001 FORMAT(' *** CP MATRICES ALLOCATED ',10X,' ***') + 6002 FORMAT( + > ' -----------------'/' RECOMPUTED PARAMETERS '/ + > ' NANGL =',I10 ,' (NUMBER OF TRACKING ANGLES)'/ + > ' ISYMM =',I10 ,' (TRACKING SYMMETRY FACTOR)'/ + > ' CUTOFX =',F10.5,' (CUTOFF FOR TRACK LENGTH)'/ + > ' DENS =',F10.5,' (TRACK DENSITY)'/ + > ' PCORN =',F10.5,' (CORNER DUPLICATION DISTANCE)'/ + > ' -----------------'/) + END diff --git a/Dragon/src/PNFLV.f b/Dragon/src/PNFLV.f new file mode 100644 index 0000000..d716737 --- /dev/null +++ b/Dragon/src/PNFLV.f @@ -0,0 +1,207 @@ +*DECK PNFLV + SUBROUTINE PNFLV(KPSYS,INCONV,NGIND,IPTRK,IMPX,MAXIT,NGEFF,NREG, + 1 NBMIX,NUN,MAT,VOL,KEYFLX,FUNKNO,SUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solve N-group transport equation for fluxes using the spherical +* harmonics (PN) method in BIVAC. +* +*Copyright: +* Copyright (C) 2004 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* KPSYS pointer to the assembly matrices. KPSYS is an array of +* directories. +* INCONV energy group convergence flag (set to .false. if converged). +* NGIND energy group indices assign to the NGEFF set. +* IPTRK pointer to the tracking (L_TRACK signature). +* IMPX print flag (equal to zero for no print). +* NGEFF number of energy groups processed in parallel. +* NREG total number of regions for which specific values of the +* neutron flux and reactions rates are required. +* NBMIX number of mixtures. +* NUN total number of unknowns in vectors SUNKNO and FUNKNO. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX position of averaged flux elements in FUNKNO vector. +* SUNKNO input source vector. +* +*Parameters: input/output +* FUNKNO unknown vector. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) KPSYS(NGEFF),IPTRK + INTEGER MAXIT,NGEFF,NGIND(NGEFF),IMPX,NREG,NBMIX,NUN, + 1 MAT(NREG),KEYFLX(NREG) + LOGICAL INCONV(NGEFF) + REAL VOL(NREG),FUNKNO(NUN,NGEFF),SUNKNO(NUN,NGEFF) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6,NSTATE=40,EPSINR=1.0E-5,ICL1=3, + 1 ICL2=3) + INTEGER IPAR(NSTATE) + DOUBLE PRECISION F1,F2,R1,R2,DMU + CHARACTER NAMP*12 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MU,KN,IPERT + REAL, ALLOCATABLE, DIMENSION(:) :: QFR,SGDI,RR,VV,SYS,OLD1,OLD2, + 1 XX,YY +*---- +* RECOVER PN SPECIFIC PARAMETERS. +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',IPAR) + IF(NREG.NE.IPAR(1)) CALL XABORT('PNFLV: INVALID VALUE OF NREG.') + IF(NUN.NE.IPAR(2)) CALL XABORT('PNFLV: INVALID VALUE OF NUN.') + ITYPE=IPAR(6) + IELEM=IPAR(8) + ICOL=IPAR(9) + ISPLH=IPAR(10) + L4=IPAR(11) + LX=IPAR(12) + NLF=IPAR(14) + ISPN=IPAR(15) + ISCAT=IPAR(16) + NVD=IPAR(17) +*---- +* RECOVER TRACKING INFORMATION. +*---- + ALLOCATE(MU(L4)) + CALL LCMGET(IPTRK,'MU',MU) + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + CALL LCMLEN(IPTRK,'QFR',MAXQF,ITYLCM) + ALLOCATE(KN(MAXKN),QFR(MAXQF)) + CALL LCMGET(IPTRK,'KN',KN) + CALL LCMGET(IPTRK,'QFR',QFR) + IIMAX=MU(L4)*(NLF/2) + ALLOCATE(SYS(IIMAX)) +*---- +* RECOVER THE FINITE ELEMENT UNIT STIFFNESS MATRIX. +*---- + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMLEN(IPTRK,'T',LC,ITYLCM) + ALLOCATE(RR(LC*LC),VV(LC*(LC-1))) + CALL LCMGET(IPTRK,'R',RR) + CALL LCMGET(IPTRK,'V',VV) + CALL LCMSIX(IPTRK,' ',2) +*---- +* MAIN LOOP OVER ENERGY GROUPS. +*---- + ALLOCATE(OLD1(NUN),OLD2(NUN)) + DO 140 II=1,NGEFF + IF(.NOT.INCONV(II)) GO TO 140 + IF(IMPX.GT.1) WRITE(IUNOUT,'(/24H PNFLV: PROCESSING GROUP,I5, + 1 6H WITH ,A,1H.)') NGIND(II),'BIVAC/PN' +*---- +* RECOVER CROSS SECTIONS. +*---- + CALL LCMGET(KPSYS(II),'STATE-VECTOR',IPAR) + NAN=IPAR(8) + ALLOCATE(SGDI(NBMIX*NAN)) + DO 10 IL=0,NAN-1 + WRITE(NAMP,'(4HSCAI,I2.2,6H001001)') IL + CALL LCMGET(KPSYS(II),NAMP,SGDI(IL*NBMIX+1)) + 10 CONTINUE +*---- +* INNER ITERATION LOOP FOR ONE-GROUP TRANSPORT EQUATION. +*---- + CALL LCMGET(KPSYS(II),'IA001001',SYS) + OLD2(:NUN)=0.0 + TEST=0.0 + ITER=0 + 30 ITER=ITER+1 + IF(ITER.GT.MAXIT) THEN + WRITE(IUNOUT,'(43H PNFLV: MAXIMUM NUMBER OF ONE-SPEED ITERATI, + 1 11HON REACHED.)') + GO TO 100 + ENDIF + DO 40 I=1,NUN + OLD1(I)=OLD2(I) + OLD2(I)=FUNKNO(I,II) + 40 CONTINUE + IF((ITYPE.EQ.2).OR.((ITYPE.EQ.5).AND.(ISPN.EQ.1))) THEN + ALLOCATE(XX(NREG),YY(NREG)) + CALL LCMGET(IPTRK,'XX',XX) + CALL LCMGET(IPTRK,'YY',YY) + CALL PNFL2E(NREG,IELEM,ICOL,XX,YY,MAT,VOL,NBMIX,NLF,NVD, + 1 NAN,SGDI,L4,KN,QFR,MU,IIMAX,LC,RR,VV,SYS,SUNKNO(1,II), + 2 FUNKNO(1,II),1) + DEALLOCATE(YY,XX) + ELSE IF((ITYPE.EQ.2).OR.((ITYPE.EQ.8).AND.(ISPN.EQ.1))) THEN + NBLOS=LX/3 + ALLOCATE(IPERT(NBLOS)) + CALL LCMGET(IPTRK,'SIDE',SIDE) + CALL LCMGET(IPTRK,'IPERT',IPERT) + CALL PNFH2E(IELEM,ICOL,NBLOS,SIDE,NLF,NVD,L4,IPERT,KN,QFR,MU, + 1 IIMAX,LC,VV,SYS,SUNKNO(1,II),FUNKNO(1,II),1) + DEALLOCATE(IPERT) + ELSE + CALL XABORT('PNFLV: TYPE OF DISCRETIZATION NOT IMPLEMENTED.') + ENDIF + IF(NLF.EQ.2) GO TO 100 +*---- +* VARIATIONAL ACCELERATION. +*---- + DMU=1.0D0 + IF(MOD(ITER-1,ICL1+ICL2).GE.ICL1) THEN + F1=0.0 + F2=0.0 + DO 70 I=1,NUN + R1=OLD2(I)-OLD1(I) + R2=FUNKNO(I,II)-OLD2(I) + F1=F1+R1*(R2-R1) + F2=F2+(R2-R1)*(R2-R1) + 70 CONTINUE + DMU=-F1/F2 + IF(DMU.GT.0.0) THEN + DO 80 I=1,NUN + FUNKNO(I,II)=OLD2(I)+REAL(DMU)*(FUNKNO(I,II)-OLD2(I)) + OLD2(I)=OLD1(I)+REAL(DMU)*(OLD2(I)-OLD1(I)) + 80 CONTINUE + ENDIF + ENDIF +*--- CALCULATE ERROR AND TEST FOR CONVERGENCE. + AAA=0.0 + BBB=0.0 + DO 90 I=1,NREG + IF(KEYFLX(I).EQ.0) GO TO 90 + AAA=MAX(AAA,ABS(FUNKNO(KEYFLX(I),II)-OLD2(KEYFLX(I)))) + BBB=MAX(BBB,ABS(FUNKNO(KEYFLX(I),II))) + 90 CONTINUE + IF(IMPX.GT.2) WRITE(IUNOUT,300) ITER,AAA,BBB,DMU + IF(AAA.LE.EPSINR*BBB) GO TO 100 + IF(ITER.EQ.1) TEST=AAA + IF((ITER.GE.10).AND.(AAA.GT.TEST)) THEN + WRITE(IUNOUT,'(43H PNFLV: UNABLE TO CONVERGE ONE-SPEED ITERAT, + 1 5HIONS.)') + GO TO 100 + ENDIF + GO TO 30 + 100 DEALLOCATE(SGDI) +*---- +* END OF LOOP OVER ENERGY GROUPS. +*---- + 140 CONTINUE + DEALLOCATE(OLD2,OLD1,SYS,VV,RR,QFR,KN,MU) + IF((IMPX.GT.0).AND.(NLF.GT.2)) WRITE(IUNOUT,'(15H PNFLV: NUMBER , + 1 24HOF ONE-SPEED ITERATIONS=,I5,1H.)') ITER + RETURN +* + 300 FORMAT(27H PNFLV: ONE-SPEED ITERATION,I3,8H ERROR=,1P,E11.4, + 1 5H OVER,E11.4,22H ACCELERATION FACTOR=,0P,F7.3) + END diff --git a/Dragon/src/PNSH.f90 b/Dragon/src/PNSH.f90 new file mode 100644 index 0000000..39a7cf0 --- /dev/null +++ b/Dragon/src/PNSH.f90 @@ -0,0 +1,149 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Return the real spherical harmonics corresponding to a set of +! direction cosines. +! +!Copyright: +! Copyright (C) 2004 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version +! +!Author(s): A. Hebert +! +!Parameters: input +! L Legendre order. +! M azimuthal order. +! ZMU X-directed direction cosine. +! ETA Y-directed direction cosine. +! XI Z-directed direction cosine. +! +!Parameters: output +! PNOUT value of the spherical harmonics. +! +!----------------------------------------------------------------------- +! +REAL FUNCTION PNSH(L,M,ZMU,ETA,XI) RESULT(PNOUT) + !---- + ! FUNCTION ARGUMENTS + !---- + INTEGER L,M + REAL ZMU,ETA,XI + !---- + ! LOCAL VARIABLES + !---- + PARAMETER (PI=3.141592653589793) + DOUBLE PRECISION FACTOR,PHI,PNL,DZMU,COEF,ALPLGN + ! + TEST=ZMU*ZMU+ETA*ETA+XI*XI + IF(ABS(TEST-1.0).GT.1.0E-5) THEN + CALL XABORT('PNSH: INVALID DIRECTION COSINES.') + ENDIF + PNOUT=0.0 + IF((L.EQ.0).AND.(M.EQ.0)) THEN + PNOUT=1.0 + ELSE IF((L.EQ.1).AND.(M.EQ.-1)) THEN + PNOUT=XI + ELSE IF((L.EQ.1).AND.(M.EQ.0)) THEN + PNOUT=ZMU + ELSE IF((L.EQ.1).AND.(M.EQ.1)) THEN + PNOUT=ETA + ELSE IF((L.EQ.2).AND.(M.EQ.-2)) THEN + PNOUT=SQRT(3.0)*ETA*XI + ELSE IF((L.EQ.2).AND.(M.EQ.-1)) THEN + PNOUT=SQRT(3.0)*ZMU*XI + ELSE IF((L.EQ.2).AND.(M.EQ.0)) THEN + PNOUT=0.5*(3.0*ZMU*ZMU-1.0) + ELSE IF((L.EQ.2).AND.(M.EQ.1)) THEN + PNOUT=SQRT(3.0)*ZMU*ETA + ELSE IF((L.EQ.2).AND.(M.EQ.2)) THEN + PNOUT=0.5*SQRT(3.0)*(ETA*ETA-XI*XI) + ELSE IF((L.EQ.3).AND.(M.EQ.-3)) THEN + PNOUT=SQRT(5./8.)*XI*(3.0*ETA*ETA-XI*XI) + ELSE IF((L.EQ.3).AND.(M.EQ.-2)) THEN + PNOUT=SQRT(15.0)*ETA*XI*ZMU + ELSE IF((L.EQ.3).AND.(M.EQ.-1)) THEN + PNOUT=SQRT(3./8.)*XI*(5.0*ZMU*ZMU-1.0) + ELSE IF((L.EQ.3).AND.(M.EQ.0)) THEN + PNOUT=0.5*ZMU*(5.0*ZMU*ZMU-3.0) + ELSE IF((L.EQ.3).AND.(M.EQ.1)) THEN + PNOUT=SQRT(3./8.)*ETA*(5.0*ZMU*ZMU-1.0) + ELSE IF((L.EQ.3).AND.(M.EQ.2)) THEN + PNOUT=SQRT(15.0/4.0)*ZMU*(ETA*ETA-XI*XI) + ELSE IF((L.EQ.3).AND.(M.EQ.3)) THEN + PNOUT=SQRT(5./8.)*ETA*(ETA*ETA-3.0*XI*XI) + ELSE IF((L.EQ.4).AND.(M.EQ.-4)) THEN + PNOUT=0.5*SQRT(35.)*ETA*XI*(ETA*ETA-XI*XI) + ELSE IF((L.EQ.4).AND.(M.EQ.-3)) THEN + PNOUT=0.5*SQRT(0.5*35.)*ZMU*XI*(3.*ETA*ETA-XI*XI) + ELSE IF((L.EQ.4).AND.(M.EQ.-2)) THEN + PNOUT=SQRT(5.)*(21.*ZMU*ZMU-3.)*ETA*XI/6. + ELSE IF((L.EQ.4).AND.(M.EQ.-1)) THEN + PNOUT=0.5*SQRT(2.5)*ZMU*XI*(7.*ZMU*ZMU-3.) + ELSE IF((L.EQ.4).AND.(M.EQ.0)) THEN + PNOUT=(35.*ZMU**4-30.*ZMU*ZMU+3.)/8. + ELSE IF((L.EQ.4).AND.(M.EQ.1)) THEN + PNOUT=0.5*SQRT(2.5)*ZMU*ETA*(7.*ZMU*ZMU-3.) + ELSE IF((L.EQ.4).AND.(M.EQ.2)) THEN + PNOUT=SQRT(5.)*(21.*ZMU*ZMU-3.)*(ETA*ETA-XI*XI)/12. + ELSE IF((L.EQ.4).AND.(M.EQ.3)) THEN + PNOUT=0.5*SQRT(0.5*35.)*ZMU*ETA*(ETA*ETA-3.*XI*XI) + ELSE IF((L.EQ.4).AND.(M.EQ.4)) THEN + PNOUT=SQRT(35.)*(ETA**4-6.*(ETA*XI)**2+XI**4)/8. + ELSE IF((L.EQ.5).AND.(M.EQ.-5)) THEN + PNOUT=21.*XI*(5.*ETA**4-10.*(ETA*XI)**2+XI**4)/(8.*SQRT(14.)) + ELSE IF((L.EQ.5).AND.(M.EQ.-4)) THEN + PNOUT=0.5*105.*ZMU*ETA*XI*(ETA*ETA-XI*XI)/SQRT(35.) + ELSE IF((L.EQ.5).AND.(M.EQ.-3)) THEN + PNOUT=35.*(9*ZMU*ZMU-1.)*XI*(3.*ETA*ETA-XI*XI)/(8.*SQRT(70.)) + ELSE IF((L.EQ.5).AND.(M.EQ.-2)) THEN + PNOUT=0.5*SQRT(105.)*ZMU*(3.*ZMU*ZMU-1.)*ETA*XI + ELSE IF((L.EQ.5).AND.(M.EQ.-1)) THEN + PNOUT=SQRT(15.)*XI*(21.*ZMU**4-14.*ZMU*ZMU+1.)/8. + ELSE IF((L.EQ.5).AND.(M.EQ.0)) THEN + PNOUT=ZMU*(63.*ZMU**4-70.*ZMU*ZMU+15.)/8. + ELSE IF((L.EQ.5).AND.(M.EQ.1)) THEN + PNOUT=SQRT(15.)*ETA*(21.*ZMU**4-14.*ZMU*ZMU+1.)/8. + ELSE IF((L.EQ.5).AND.(M.EQ.2)) THEN + PNOUT=0.25*SQRT(105.)*ZMU*(3.*ZMU*ZMU-1.)*(ETA*ETA-XI*XI) + ELSE IF((L.EQ.5).AND.(M.EQ.3)) THEN + PNOUT=35.*(9*ZMU*ZMU-1.)*ETA*(ETA*ETA-3.*XI*XI)/(8.*SQRT(70.)) + ELSE IF((L.EQ.5).AND.(M.EQ.4)) THEN + PNOUT=105.*ZMU*(ETA**4-6.*(ETA*XI)**2+XI**4)/(8.*SQRT(35.)) + ELSE IF((L.EQ.5).AND.(M.EQ.5)) THEN + PNOUT=21.*ETA*(ETA**4-10.*(ETA*XI)**2+5.*XI**4)/(8.*SQRT(14.)) + ELSE + FACTOR=SQRT(1.0D0-ZMU*ZMU) + PHI=0.0D0 + IF(XI.GE.0) THEN + PHI=ACOS(ETA/FACTOR) + ELSE IF(XI.LT.0) THEN + PHI=2.0D0*PI-ACOS(ETA/FACTOR) + ENDIF + COEF=SQRT(2.0D0*ALFACT(L-ABS(M))/ALFACT(L+ABS(M))) + DZMU=ZMU + PNL=ALPLGN(L,ABS(M),DZMU) + IF(M.GT.0) THEN + PNOUT=REAL(COEF*PNL*COS(M*PHI)) + ELSE IF(M.EQ.0) THEN + PNOUT=REAL(PNL) + ELSE IF(M.LT.0) THEN + PNOUT=REAL(COEF*PNL*SIN(-M*PHI)) + ENDIF + ENDIF + RETURN + ! + CONTAINS + RECURSIVE DOUBLE PRECISION FUNCTION ALFACT(N) RESULT(OUT) + ! return the factorial of N + INTEGER N + IF(N.LE.1) THEN + OUT=1.0D0 + ELSE + OUT=N*ALFACT(N-1) + ENDIF + END FUNCTION ALFACT +END FUNCTION PNSH diff --git a/Dragon/src/PRECISION_AND_KINDS.f90 b/Dragon/src/PRECISION_AND_KINDS.f90 new file mode 100644 index 0000000..b807c12 --- /dev/null +++ b/Dragon/src/PRECISION_AND_KINDS.f90 @@ -0,0 +1,20 @@ +! +!--------------------------------------------------------------------- +! +!Purpose: +! To store common constants relarive to accuracy or to mathematics. +! +!Copyright: +! Copyright (C) 2001 Ecole Polytechnique de Montreal. +! +!Author(s): +! X. Warin +! +!--------------------------------------------------------------------- +! +MODULE PRECISION_AND_KINDS + INTEGER, PARAMETER :: PDB = SELECTED_REAL_KIND(8) + REAL(PDB), PARAMETER :: PI=3.14159265358979, TWOPI=2.*PI, & + HALFPI=PI/2., SMALL=1.E-20,INFINITY=1.E20 + REAL(PDB) :: HUGE_PDB,LOG10_HUGE_PDB,TINY_PDB,LOG10_TINY_PDB +END MODULE PRECISION_AND_KINDS diff --git a/Dragon/src/PSOISO.f b/Dragon/src/PSOISO.f new file mode 100644 index 0000000..9782bcf --- /dev/null +++ b/Dragon/src/PSOISO.f @@ -0,0 +1,295 @@ +*DECK PSOISO + SUBROUTINE PSOISO(IPTRK,IPGEOM,NREG,LX,LY,LZ,NG,NUNS,NDIM, + 1 NSOUR,ISOUR,XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,XXX,YYY,ZZZ,MESHL, + 2 SUNKNO,NORM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute moments of fixed isotropic sources. +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): C. Bienvenue +* +*Parameters: input +* IPTRK pointer to the tracking LCM object. +* IPGEOM pointer to the geometry LCM object. +* NREG number of regions. +* LX number of meshes along X axis. +* LY number of meshes along Y axis. +* LZ number of meshes along Z axis. +* NG number of energy groups. +* NUNS number of unknowns in vector SUNKNO. +* NDIM geometry dimension. +* NSOUR number of sources defined. +* ISOUR intensity of the sources. +* XMIN lower boundaries of the sources along X axis. +* XMAX upper boundaries of the sources along X axis. +* YMIN lower boundaries of the sources along Y axis. +* YMAX upper boundaries of the sources along Y axis. +* ZMIN lower boundaries of the sources along Z axis. +* ZMAX upper boundaries of the sources along Z axis. +* XXX regions boundaries along X axis. +* YYY regions boundaries along Y axis. +* ZZZ regions boundaries along Z axis. +* MESHL number of regions along X-, Y- and Z-axis +* +*Parameters: output +* SUNKNO source vector. +* NORM normalization factor. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPGEOM + INTEGER NREG,LX,LY,LZ,NG,NUNS,NDIM,NSOUR,MESHL(3) + REAL XMIN(NSOUR),XMAX(NSOUR),YMIN(NSOUR),YMAX(NSOUR),ZMIN(NSOUR), + 1 ZMAX(NSOUR),ISOUR(NG),SUNKNO(NUNS,NG),XXX(MESHL(1)), + 2 YYY(MESHL(2)),ZZZ(MESHL(3)),NORM +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + INTEGER ISTATE(NSTATE),SPLIT_LEN(3),XP(NREG),YP(NREG),ZP(NREG), + 1 EELEM + REAL X(LX),Y(LY),Z(LZ) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER,ALLOCATABLE,DIMENSION(:) :: SPLITX,SPLITY,SPLITZ +*---- +* RECOVER TRACKING INFORMATION +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + ITYPE=ISTATE(6) + NSCT=ISTATE(7) + IELEM=ISTATE(8) + ISCAT=ISTATE(16) + EELEM=ISTATE(35) +*---- +* RECOVER GEOMETRY INFORMATION +*---- + IF(NDIM.EQ.1) THEN + CALL LCMLEN(IPGEOM,'SPLITX',SPLIT_LEN(1),ITYLCM) + ALLOCATE(SPLITX(SPLIT_LEN(1))) + CALL LCMGET(IPGEOM,'SPLITX',SPLITX) + ELSE IF(NDIM.EQ.2) THEN + CALL LCMLEN(IPGEOM,'SPLITX',SPLIT_LEN(1),ITYLCM) + CALL LCMLEN(IPGEOM,'SPLITY',SPLIT_LEN(2),ITYLCM) + ALLOCATE(SPLITX(SPLIT_LEN(1)),SPLITY(SPLIT_LEN(2))) + CALL LCMGET(IPGEOM,'SPLITX',SPLITX) + CALL LCMGET(IPGEOM,'SPLITY',SPLITY) + ELSE IF(NDIM.EQ.3) THEN + CALL LCMLEN(IPGEOM,'SPLITX',SPLIT_LEN(1),ITYLCM) + CALL LCMLEN(IPGEOM,'SPLITY',SPLIT_LEN(2),ITYLCM) + CALL LCMLEN(IPGEOM,'SPLITZ',SPLIT_LEN(3),ITYLCM) + ALLOCATE(SPLITX(SPLIT_LEN(1)),SPLITY(SPLIT_LEN(2)), + 1 SPLITZ(SPLIT_LEN(3))) + CALL LCMGET(IPGEOM,'SPLITX',SPLITX) + CALL LCMGET(IPGEOM,'SPLITY',SPLITY) + CALL LCMGET(IPGEOM,'SPLITZ',SPLITZ) + ENDIF +*---- +* 1D CARTESIAN CASE +*---- + + IF(NDIM.EQ.1) THEN + + ! CALCULATE X-COORDINATES OF EACH VOXELS + K=1 + DO I=1,SPLIT_LEN(1) + DO J=1,SPLITX(I) + XP(K)=I + K=K+1 + ENDDO + ENDDO + + DO 10 IX=1,LX + STEPX=(XXX(XP(IX)+1)-XXX(XP(IX)))/SPLITX(XP(IX)) + IF(XP(IX).EQ.1) THEN + X(IX)=XXX(XP(IX))+0.5*STEPX+STEPX*(IX-1) + ELSE + X(IX)=XXX(XP(IX))+0.5*STEPX+STEPX*(IX-SUM(SPLITX(1:XP(IX)-1))-1) + ENDIF + 10 CONTINUE + + ! CALCULATE THE SOURCE DENSITY + NORM=0.0 + DO 40 IX=1,LX + IR=IX + DO 30 N=1,NSOUR + IF(XMIN(N).LE.X(IX).AND.XMAX(N).GE.X(IX)) THEN + IND=(IR-1)*NSCT*IELEM*EELEM+1 + DO 20 IG=1,NG + SUNKNO(IND,IG)=SUNKNO(IND,IG)+ISOUR(IG) + IF(N.EQ.NSOUR) THEN + NORM=NORM+(XXX(XP(IX)+1)-XXX(XP(IX)))/SPLITX(XP(IX))* + 1 SUNKNO(IND,IG) + ENDIF + 20 CONTINUE + ENDIF + 30 CONTINUE + 40 CONTINUE + +*---- +* 2D CARTESIAN CASE +*---- + + ELSE IF(NDIM.EQ.2) THEN + + ! CALCULATE XY-COORDINATES OF EACH VOXELS + K=1 + DO I=1,SPLIT_LEN(1) + DO J=1,SPLITX(I) + XP(K)=I + K=K+1 + ENDDO + ENDDO + K=1 + DO I=1,SPLIT_LEN(2) + DO J=1,SPLITY(I) + YP(K)=I + K=K+1 + ENDDO + ENDDO + + DO 100 IX=1,LX + STEPX=(XXX(XP(IX)+1)-XXX(XP(IX)))/SPLITX(XP(IX)) + IF(XP(IX).EQ.1) THEN + X(IX)=XXX(XP(IX))+0.5*STEPX+STEPX*(IX-1) + ELSE + X(IX)=XXX(XP(IX))+0.5*STEPX+STEPX*(IX-SUM(SPLITX(1:XP(IX)-1))-1) + ENDIF + 100 CONTINUE + + DO 110 IY=1,LY + STEPY=(YYY(YP(IY)+1)-YYY(YP(IY)))/SPLITY(YP(IY)) + IF(YP(IY).EQ.1) THEN + Y(IY)=YYY(YP(IY))+0.5*STEPY+STEPY*(IY-1) + ELSE + Y(IY)=YYY(YP(IY))+0.5*STEPY+STEPY*(IY-SUM(SPLITY(1:YP(IY)-1))-1) + ENDIF + 110 CONTINUE + + ! CALCULATE THE SOURCE DENSITY + NORM=0.0 + DO 150 IY=1,LY + DO 140 IX=1,LX + IR=IX+(IY-1)*LX + DO 130 N=1,NSOUR + IF(XMIN(N).LE.X(IX).AND.XMAX(N).GE.X(IX).AND. + 1 YMIN(N).LE.Y(IY).AND.YMAX(N).GE.Y(IY)) THEN + IND=(IR-1)*NSCT*IELEM*IELEM*EELEM+1 + DO 120 IG=1,NG + SUNKNO(IND,IG)=SUNKNO(IND,IG)+ISOUR(IG) + IF(N.EQ.NSOUR) THEN + NORM=NORM+( (XXX(XP(IX)+1)-XXX(XP(IX)))/SPLITX(XP(IX))* + 1 (YYY(YP(IY)+1)-YYY(YP(IY)))/SPLITY(YP(IY)))*SUNKNO(IND,IG) + ENDIF + 120 CONTINUE + ENDIF + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE + +*---- +* 3D CARTESIAN CASE +*---- + + ELSE IF(NDIM.EQ.3) THEN + + ! CALCULATE XYZ-COORDINATES OF EACH VOXELS + K=1 + DO I=1,SPLIT_LEN(1) + DO J=1,SPLITX(I) + XP(K)=I + K=K+1 + ENDDO + ENDDO + K=1 + DO I=1,SPLIT_LEN(2) + DO J=1,SPLITY(I) + YP(K)=I + K=K+1 + ENDDO + ENDDO + K=1 + DO I=1,SPLIT_LEN(3) + DO J=1,SPLITZ(I) + ZP(K)=I + K=K+1 + ENDDO + ENDDO + + DO 200 IX=1,LX + STEPX=(XXX(XP(IX)+1)-XXX(XP(IX)))/SPLITX(XP(IX)) + IF(XP(IX).EQ.1) THEN + X(IX)=XXX(XP(IX))+0.5*STEPX+STEPX*(IX-1) + ELSE + X(IX)=XXX(XP(IX))+0.5*STEPX+STEPX*(IX-SUM(SPLITX(1:XP(IX)-1))-1) + ENDIF + 200 CONTINUE + + DO 210 IY=1,LY + STEPY=(YYY(YP(IY)+1)-YYY(YP(IY)))/SPLITY(YP(IY)) + IF(YP(IY).EQ.1) THEN + Y(IY)=YYY(YP(IY))+0.5*STEPY+STEPY*(IY-1) + ELSE + Y(IY)=YYY(YP(IY))+0.5*STEPY+STEPY*(IY-SUM(SPLITY(1:YP(IY)-1))-1) + ENDIF + 210 CONTINUE + + DO 220 IZ=1,LZ + STEPZ=(ZZZ(ZP(IZ)+1)-ZZZ(ZP(IZ)))/SPLITZ(ZP(IZ)) + IF(ZP(IZ).EQ.1) THEN + Z(IZ)=ZZZ(ZP(IZ))+0.5*STEPZ+STEPZ*(IZ-1) + ELSE + Z(IZ)=ZZZ(ZP(IZ))+0.5*STEPZ+STEPZ*(IZ-SUM(SPLITZ(1:ZP(IZ)-1))-1) + ENDIF + 220 CONTINUE + + ! CALCULATE THE SOURCE DENSITY + NORM=0.0 + DO 270 IZ=1,LZ + DO 260 IY=1,LY + DO 250 IX=1,LX + IR=IX+(IY-1)*LX+(IZ-1)*LX*LY + DO 240 N=1,NSOUR + IF(XMIN(N).LE.X(IX).AND.XMAX(N).GE.X(IX).AND. + 1 YMIN(N).LE.Y(IY).AND.YMAX(N).GE.Y(IY).AND. + 2 ZMIN(N).LE.Z(IZ).AND.ZMAX(N).GE.Z(IZ)) THEN + IND=(IR-1)*NSCT*IELEM*IELEM*IELEM*EELEM+1 + DO 230 IG=1,NG + SUNKNO(IND,IG)=SUNKNO(IND,IG)+ISOUR(IG) + IF(N.EQ.NSOUR) THEN + NORM=NORM+((XXX(XP(IX)+1)-XXX(XP(IX)))/SPLITX(XP(IX))* + 1 (YYY(YP(IY)+1)-YYY(YP(IY)))/SPLITY(YP(IY))* + 2 (ZZZ(ZP(IZ)+1)-ZZZ(ZP(IZ)))/SPLITZ(ZP(IZ)))*SUNKNO(IND,IG) + ENDIF + 230 CONTINUE + ENDIF + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE + 270 CONTINUE + + ELSE + CALL XABORT('SOUR: INVALID GEOMETRY, ONLY 1D, 2D AND 3D CARTESIAN' + 1 //' GEOMETRY ARE ACTUALLY IMPLEMENTED.') + ENDIF + + IF(ALLOCATED(SPLITX)) DEALLOCATE(SPLITX) + IF(ALLOCATED(SPLITY)) DEALLOCATE(SPLITY) + IF(ALLOCATED(SPLITZ)) DEALLOCATE(SPLITZ) + + RETURN + END diff --git a/Dragon/src/PSOMON.f b/Dragon/src/PSOMON.f new file mode 100644 index 0000000..8f4ea9e --- /dev/null +++ b/Dragon/src/PSOMON.f @@ -0,0 +1,523 @@ +*DECK PSOMON + SUBROUTINE PSOMON(IPTRK,IPGEOM,NREG,LX,LY,LZ,NG,NDIM, + 1 NSOUR,ISOUR,ISISOUR,XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,XXX,YYY,ZZZ, + 2 MESHL,BSINFO,BS,MAXL,NORM,DIR,MONOP,NBST,NBS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute moments of fixed boundary monodirectionnal sources. +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): C. Bienvenue +* +*Parameters: input +* IPTRK pointer to the tracking LCM object. +* IPGEOM porinter to the geometry LCM object. +* NREG number of regions. +* LX number of meshes along X axis. +* LY number of meshes along Y axis. +* LZ number of meshes along Z axis. +* NG number of energy groups. +* NDIM geometry dimension. +* NSOUR number of sources defined. +* ISOUR intensity of the sources. +* ISISOUR array with 0/1 values to indicate if energy group contain +* sources +* XMIN lower boundaries of the source along X axis. +* XMAX upper boundaries of the source along X axis. +* YMIN lower boundaries of the source along Y axis. +* YMAX upper boundaries of the source along Y axis. +* ZMIN lower boundaries of the source along Z axis. +* ZMAX upper boundaries of the source along Z axis. +* XXX regions boundaries along X axis. +* YYY regions boundaries along Y axis. +* ZZZ regions boundaries along Z axis. +* MESHL number of regions along X-, Y- and Z-axis +* MAXL number of intensity values needed to fully described each +* boundary source. +* DIR direction of the source particles. +* MONOP value describing the boundary source location. +* NBST total number of sources. +* +*Parameters: output +* NORM normalization factor. +* BS intensity values for each sources. +* BSINFO energy group, discrete ordinate and location corresponding to +* each sources. +* NBS number of sources in each energy group. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPGEOM + INTEGER NREG,NBST,LX,LY,LZ,NG,NDIM,NSOUR,MESHL(3),MONOP, + 1 ISISOUR(NG),BSINFO(2,NG,NBST),NBS(NG) + REAL XMIN(NSOUR),XMAX(NSOUR),YMIN(NSOUR),YMAX(NSOUR),ZMIN(NSOUR), + 1 ZMAX(NSOUR),ISOUR(NG),XXX(MESHL(1)), + 2 YYY(MESHL(2)),ZZZ(MESHL(3)),NORM,DIR(3),BS(MAXL,NG,NBST) +*---- +* LOCAL VARIABLES +*---- + INTEGER SPLIT_LEN(3),XP(NREG),YP(NREG),ZP(NREG), + 1 IPN,MONOP2 + REAL X(LX),Y(LY),Z(LZ),IPVAL,S +*---- +* ALLOCATABLE ARRAYS +*---- + TYPE(C_PTR) U_PTR,DU_PTR,DE_PTR,DZ_PTR,W_PTR + INTEGER,ALLOCATABLE,DIMENSION(:) :: SPLITX,SPLITY,SPLITZ,MN + REAL, POINTER, DIMENSION(:) :: U,DU,DE,DZ,W + REAL,ALLOCATABLE,DIMENSION(:) :: P +*---- +* RECOVER GEOMETRY INFORMATION +*---- + IF(ABS(MONOP).NE.1) THEN + CALL LCMLEN(IPGEOM,'SPLITX',SPLIT_LEN(1),ITYLCM) + ALLOCATE(SPLITX(SPLIT_LEN(1))) + CALL LCMGET(IPGEOM,'SPLITX',SPLITX) + ENDIF + IF(ABS(MONOP).NE.2.AND.NDIM.GE.2) THEN + CALL LCMLEN(IPGEOM,'SPLITY',SPLIT_LEN(2),ITYLCM) + ALLOCATE(SPLITY(SPLIT_LEN(2))) + CALL LCMGET(IPGEOM,'SPLITY',SPLITY) + ENDIF + IF(ABS(MONOP).NE.3.AND.NDIM.GE.3) THEN + CALL LCMLEN(IPGEOM,'SPLITZ',SPLIT_LEN(3),ITYLCM) + ALLOCATE(SPLITZ(SPLIT_LEN(3))) + CALL LCMGET(IPGEOM,'SPLITZ',SPLITZ) + ENDIF + + ! CALCULATE X- OR Y- COORDINATES OF EACH VOXELS + IF(ABS(MONOP).NE.1) THEN + K=1 + DO I=1,SPLIT_LEN(1) + DO J=1,SPLITX(I) + XP(K)=I + K=K+1 + ENDDO + ENDDO + DO 10 IX=1,LX + STEPX=(XXX(XP(IX)+1)-XXX(XP(IX)))/SPLITX(XP(IX)) + IF(XP(IX).EQ.1) THEN + X(IX)=XXX(XP(IX))+0.5*STEPX+STEPX*(IX-1) + ELSE + X(IX)=XXX(XP(IX))+0.5*STEPX+STEPX*(IX-SUM(SPLITX(1:XP(IX)-1))-1) + ENDIF + 10 CONTINUE + ENDIF + IF(ABS(MONOP).NE.2.AND.NDIM.GE.2) THEN + K=1 + DO I=1,SPLIT_LEN(2) + DO J=1,SPLITY(I) + YP(K)=I + K=K+1 + ENDDO + ENDDO + DO 110 IY=1,LY + STEPY=(YYY(YP(IY)+1)-YYY(YP(IY)))/SPLITY(YP(IY)) + IF(YP(IY).EQ.1) THEN + Y(IY)=YYY(YP(IY))+0.5*STEPY+STEPY*(IY-1) + ELSE + Y(IY)=YYY(YP(IY))+0.5*STEPY+STEPY*(IY-SUM(SPLITY(1:YP(IY)-1))-1) + ENDIF + 110 CONTINUE + ENDIF + IF(ABS(MONOP).NE.3.AND.NDIM.GE.3) THEN + K=1 + DO I=1,SPLIT_LEN(3) + DO J=1,SPLITZ(I) + ZP(K)=I + K=K+1 + ENDDO + ENDDO + DO 220 IZ=1,LZ + STEPZ=(ZZZ(ZP(IZ)+1)-ZZZ(ZP(IZ)))/SPLITZ(ZP(IZ)) + IF(ZP(IZ).EQ.1) THEN + Z(IZ)=ZZZ(ZP(IZ))+0.5*STEPZ+STEPZ*(IZ-1) + ELSE + Z(IZ)=ZZZ(ZP(IZ))+0.5*STEPZ+STEPZ*(IZ-SUM(SPLITZ(1:ZP(IZ)-1))-1) + ENDIF + 220 CONTINUE + ENDIF + + IF(MONOP.EQ.-1) THEN + MONOP2=1 + ELSE IF(MONOP.EQ.1) THEN + MONOP2=2 + ELSE IF(MONOP.EQ.-2) THEN + MONOP2=3 + ELSE IF(MONOP.EQ.2) THEN + MONOP2=4 + ELSE IF(MONOP.EQ.-3) THEN + MONOP2=5 + ELSE IF(MONOP.EQ.3) THEN + MONOP2=6 + ELSE + MONOP2=0 + ENDIF + +*---- +* 1D CARTESIAN CASE +*---- + + IF(NDIM.EQ.1) THEN + + ! Define the corresponding discrete ordinate + + CALL LCMLEN(IPTRK,'U',NLF,ITYLCM) + CALL LCMGPD(IPTRK,'U',U_PTR) + CALL LCMGPD(IPTRK,'W',W_PTR) + CALL C_F_POINTER(U_PTR,U,(/ NLF /)) + CALL C_F_POINTER(W_PTR,W,(/ NLF /)) + + IPN=1 + IPVAL=(U(1)-DIR(1))**2 + DO IP=2,NLF + IF((U(IP)-DIR(1))**2.LT.IPVAL) THEN + IPN=IP + IPVAL=(U(IP)-DIR(1))**2 + ENDIF + ENDDO + + IF(U(IPN).LT.0.0.AND.MONOP.EQ.-1) THEN + CALL XABORT('PSOMON: X- AND BACKWARD ORIENTED SOURCE.') + ELSEIF(U(IPN).GT.0.0.AND.MONOP.EQ.1) THEN + CALL XABORT('PSOMON: X+ AND FOWARD ORIENTED SOURCE.') + ENDIF + + ! Normalization + NORM=SUM(ISOUR) + + ! Save source information + DO IG=1,NG + IND=1 + IF(ISISOUR(IG).EQ.1) THEN + BSINFO(1,IG,IND)=MONOP2 + BSINFO(2,IG,IND)=IPN + BS(1,IG,IND)=ISOUR(IG)/W(IPN) + IND=IND+1 + ENDIF + NBS(IG)=IND-1 + ENDDO + +*---- +* 2D CARTESIAN CASE +*---- + + ELSE IF(NDIM.EQ.2) THEN + + ! Define the corresponding discrete ordinate + + CALL LCMLEN(IPTRK,'DU',NPQ,ITYLCM) + CALL LCMGPD(IPTRK,'DU',DU_PTR) + CALL LCMGPD(IPTRK,'DE',DE_PTR) + CALL LCMGPD(IPTRK,'W',W_PTR) + CALL C_F_POINTER(DU_PTR,DU,(/ NPQ /)) + CALL C_F_POINTER(DE_PTR,DE,(/ NPQ /)) + CALL C_F_POINTER(W_PTR,W,(/ NPQ /)) + + ALLOCATE(MN(2),P(2)) + INIT1=0 + VAL1=8.0 + VAL2=8.0 + DO 300 M=1,NPQ + IF(W(M).EQ.0.0) GO TO 300 + IF(INIT1.EQ.0) THEN + MN(1)=M + VAL1=(DU(M)-DIR(1))**2+(DE(M)-DIR(2))**2 + INIT1=1 + ELSE + VAL=(DU(M)-DIR(1))**2+(DE(M)-DIR(2))**2 + IF(VAL1.GT.VAL) THEN + MN(2)=MN(1) + MN(1)=M + VAL2=VAL1 + VAL1=VAL + ELSEIF(VAL2.GT.VAL) THEN + MN(2)=M + VAL2=VAL + ENDIF + ENDIF + 300 CONTINUE + + VALTOT=VAL1+VAL2 + P(1)=VAL1/VALTOT + P(2)=VAL2/VALTOT + + IF(DU(MN(1)).LT.0.0.AND.DU(MN(2)).LT.0.0.AND.MONOP.EQ.-1) THEN + CALL XABORT('PSOMON: X- AND BACKWARD ORIENTED SOURCE.') + ELSEIF(DU(MN(1)).GT.0.0.AND.DU(MN(2)).GT.0.0.AND.MONOP.EQ.1) THEN + CALL XABORT('PSOMON: X+ AND FOWARD ORIENTED SOURCE.') + ELSEIF(DE(MN(1)).LT.0.0.AND.DE(MN(2)).LT.0.0.AND.MONOP.EQ.-2) THEN + CALL XABORT('PSOMON: Y- AND BACKWARD ORIENTED SOURCE.') + ELSEIF(DE(MN(1)).GT.0.0.AND.DE(MN(2)).GT.0.0.AND.MONOP.EQ.2) THEN + CALL XABORT('PSOMON: Y+ AND FOWARD ORIENTED SOURCE.') + ENDIF + + ! Normalization + S=0.0 + IF(ABS(MONOP).EQ.1) THEN + DO NS=1,NSOUR + S=S+(YMAX(NS)-YMIN(NS)) + ENDDO + ENDIF + IF(ABS(MONOP).EQ.2) THEN + DO NS=1,NSOUR + S=S+(XMAX(NS)-XMIN(NS)) + ENDDO + ENDIF + NORM=SUM(ISOUR)*S + + ! Save source information + DO IG=1,NG + IND=1 + DO IDIR=1,2 + IF(ISISOUR(IG).EQ.1) THEN + BSINFO(1,IG,IND)=MONOP2 + BSINFO(2,IG,IND)=MN(IDIR) + IF(ABS(MONOP).EQ.1) THEN + DO IY=1,LY + DO NS=1,NSOUR + IF(YMIN(NS).LE.Y(IY).AND.YMAX(NS).GE.Y(IY)) THEN + BS(IY,IG,IND)=ISOUR(IG)/W(MN(IDIR))*P(IDIR) + ELSE + BS(IY,IG,IND)=0.0 + ENDIF + ENDDO + ENDDO + ELSEIF(ABS(MONOP).EQ.2) THEN + DO IX=1,LX + DO NS=1,NSOUR + IF(XMIN(NS).LE.X(IX).AND.XMAX(NS).GE.X(IX)) THEN + BS(IX,IG,IND)=ISOUR(IG)/W(MN(IDIR))*P(IDIR) + ELSE + BS(IX,IG,IND)=0.0 + ENDIF + ENDDO + ENDDO + ENDIF + IND=IND+1 + ENDIF + ENDDO + NBS(IG)=IND-1 + ENDDO + + DEALLOCATE(MN,P) + IF(ALLOCATED(SPLITX)) DEALLOCATE(SPLITX) + IF(ALLOCATED(SPLITY)) DEALLOCATE(SPLITY) + +*---- +* 3D CARTESIAN CASE +*---- + + ELSE IF(NDIM.EQ.3) THEN + + ! Define the corresponding discrete ordinate + + CALL LCMLEN(IPTRK,'DU',NPQ,ITYLCM) + CALL LCMGPD(IPTRK,'DU',DU_PTR) + CALL LCMGPD(IPTRK,'DE',DE_PTR) + CALL LCMGPD(IPTRK,'DZ',DZ_PTR) + CALL LCMGPD(IPTRK,'W',W_PTR) + CALL C_F_POINTER(DU_PTR,DU,(/ NPQ /)) + CALL C_F_POINTER(DE_PTR,DE,(/ NPQ /)) + CALL C_F_POINTER(DZ_PTR,DZ,(/ NPQ /)) + CALL C_F_POINTER(W_PTR,W,(/ NPQ /)) + + ALLOCATE(MN(4),P(4)) + INIT1=0 + INIT2=0 + INIT3=0 + VAL1=12.0 + VAL2=12.0 + VAL3=12.0 + VAL4=12.0 + DO 400 M=1,NPQ + IF(W(M).EQ.0.0) GO TO 400 + IF(INIT1.EQ.0) THEN + MN(1)=M + VAL1=(DU(M)-DIR(1))**2+(DE(M)-DIR(2))**2+(DZ(M)-DIR(3))**2 + INIT1=1 + ELSEIF(INIT2.EQ.0) THEN + VAL=(DU(M)-DIR(1))**2+(DE(M)-DIR(2))**2+(DZ(M)-DIR(3))**2 + IF(VAL1.GT.VAL) THEN + MN(2)=MN(1) + MN(1)=M + VAL2=VAL1 + VAL1=VAL + ELSE + MN(2)=M + VAL2=VAL + ENDIF + INIT2=1 + ELSEIF(INIT3.EQ.0) THEN + VAL=(DU(M)-DIR(1))**2+(DE(M)-DIR(2))**2+(DZ(M)-DIR(3))**2 + IF(VAL1.GT.VAL) THEN + MN(3)=MN(2) + MN(2)=MN(1) + MN(1)=M + VAL3=VAL2 + VAL2=VAL1 + VAL1=VAL + ELSEIF(VAL2.GT.VAL) THEN + MN(3)=MN(2) + MN(2)=M + VAL3=VAL2 + VAL2=VAL + ELSE + MN(3)=M + VAL3=VAL + ENDIF + INIT3=1 + ELSE + VAL=(DU(M)-DIR(1))**2+(DE(M)-DIR(2))**2+(DZ(M)-DIR(3))**2 + IF(VAL1.GT.VAL) THEN + MN(4)=MN(3) + MN(3)=MN(2) + MN(2)=MN(1) + MN(1)=M + VAL4=VAL3 + VAL3=VAL2 + VAL2=VAL1 + VAL1=VAL + ELSEIF(VAL2.GT.VAL) THEN + MN(4)=MN(3) + MN(3)=MN(2) + MN(2)=M + VAL4=VAL3 + VAL3=VAL2 + VAL2=VAL + ELSEIF(VAL3.GT.VAL) THEN + MN(4)=MN(3) + MN(3)=M + VAL4=VAL3 + VAL3=VAL + ELSEIF(VAL4.GT.VAL) THEN + MN(4)=M + VAL4=VAL + ENDIF + ENDIF + 400 CONTINUE + + VALTOT=VAL1+VAL2+VAL3+VAL4 + P(1)=VAL1/VALTOT + P(2)=VAL2/VALTOT + P(3)=VAL3/VALTOT + P(4)=VAL4/VALTOT + + IF(DU(MN(1)).LT.0.0.AND.DU(MN(2)).LT.0.0.AND. + 1 DU(MN(3)).LT.0.0.AND.DU(MN(4)).LT.0.0.AND.MONOP.EQ.-1) THEN + CALL XABORT('PSOMON: X- AND BACKWARD X-ORIENTED SOURCE.') + ELSEIF(DU(MN(1)).GT.0.0.AND.DU(MN(2)).GT.0.0.AND. + 1 DU(MN(3)).GT.0.0.AND.DU(MN(4)).GT.0.0.AND.MONOP.EQ.1) THEN + CALL XABORT('PSOMON: X+ AND FOWARD X-ORIENTED SOURCE.') + ELSEIF(DE(MN(1)).LT.0.0.AND.DE(MN(2)).LT.0.0.AND. + 1 DE(MN(3)).LT.0.0.AND.DE(MN(4)).LT.0.0.AND.MONOP.EQ.-2) THEN + CALL XABORT('PSOMON: Y- AND BACKWARD Y-ORIENTED SOURCE.') + ELSEIF(DE(MN(1)).GT.0.0.AND.DE(MN(2)).GT.0.0.AND. + 1 DE(MN(3)).GT.0.0.AND.DE(MN(4)).GT.0.0.AND.MONOP.EQ.2) THEN + CALL XABORT('PSOMON: Y+ AND FOWARD Y-ORIENTED SOURCE.') + ELSEIF(DZ(MN(1)).LT.0.0.AND.DZ(MN(2)).LT.0.0.AND. + 1 DZ(MN(3)).LT.0.0.AND.DZ(MN(4)).LT.0.0.AND.MONOP.EQ.-3) THEN + CALL XABORT('PSOMON: Z- AND BACKWARD Z-ORIENTED SOURCE.') + ELSEIF(DZ(MN(1)).GT.0.0.AND.DZ(MN(2)).GT.0.0.AND. + 1 DZ(MN(3)).GT.0.0.AND.DZ(MN(4)).GT.0.0.AND.MONOP.EQ.3) THEN + CALL XABORT('PSOMON: Z+ AND FOWARD Z-ORIENTED SOURCE.') + ENDIF + + ! Normalization + S=0.0 + IF(ABS(MONOP).EQ.1) THEN + DO NS=1,NSOUR + S=S+(YMAX(NS)-YMIN(NS))*(ZMAX(NS)-ZMIN(NS)) + ENDDO + ENDIF + IF(ABS(MONOP).EQ.2) THEN + DO NS=1,NSOUR + S=S+(XMAX(NS)-XMIN(NS))*(ZMAX(NS)-ZMIN(NS)) + ENDDO + ENDIF + IF(ABS(MONOP).EQ.3) THEN + DO NS=1,NSOUR + S=S+(XMAX(NS)-XMIN(NS))*(YMAX(NS)-YMIN(NS)) + ENDDO + ENDIF + NORM=SUM(ISOUR)*S + + ! Save source information + DO IG=1,NG + IND=1 + DO IDIR=1,4 + IF(ISISOUR(IG).EQ.1) THEN + BSINFO(1,IG,IND)=MONOP2 + BSINFO(2,IG,IND)=MN(IDIR) + IF(ABS(MONOP).EQ.1) THEN + DO IY=1,LY + DO IZ=1,LZ + IPOS=(IY-1)*LZ+IZ + DO NS=1,NSOUR + IF(YMIN(NS).LE.Y(IY).AND.YMAX(NS).GE.Y(IY).AND. + 1 ZMIN(NS).LE.Z(IZ).AND.ZMAX(NS).GE.Z(IZ)) THEN + BS(IPOS,IG,IND)=ISOUR(IG)/W(MN(IDIR))*P(IDIR) + ELSE + BS(IPOS,IG,IND)=0.0 + ENDIF + ENDDO + ENDDO + ENDDO + ELSEIF(ABS(MONOP).EQ.2) THEN + DO IX=1,LX + DO IZ=1,LZ + IPOS=(IX-1)*LZ+IZ + DO NS=1,NSOUR + IF(XMIN(NS).LE.X(IX).AND.XMAX(NS).GE.X(IX).AND. + 1 ZMIN(NS).LE.Z(IZ).AND.ZMAX(NS).GE.Z(IZ)) THEN + BS(IPOS,IG,IND)=ISOUR(IG)/W(MN(IDIR))*P(IDIR) + ELSE + BS(IPOS,IG,IND)=0.0 + ENDIF + ENDDO + ENDDO + ENDDO + ELSEIF(ABS(MONOP).EQ.3) THEN + DO IX=1,LX + DO IY=1,LY + IPOS=(IX-1)*LY+IY + DO NS=1,NSOUR + IF(XMIN(NS).LE.X(IX).AND.XMAX(NS).GE.X(IX).AND. + 1 YMIN(NS).LE.Y(IY).AND.YMAX(NS).GE.Y(IY)) THEN + BS(IPOS,IG,IND)=ISOUR(IG)/W(MN(IDIR))*P(IDIR) + ELSE + BS(IPOS,IG,IND)=0.0 + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF + IND=IND+1 + ENDIF + ENDDO + NBS(IG)=IND-1 + ENDDO + + DEALLOCATE(MN,P) + IF(ALLOCATED(SPLITX)) DEALLOCATE(SPLITX) + IF(ALLOCATED(SPLITY)) DEALLOCATE(SPLITY) + IF(ALLOCATED(SPLITZ)) DEALLOCATE(SPLITZ) + + ELSE + CALL XABORT('SOUR: INVALID GEOMETRY, ONLY 1D, 2D AND 3D CARTESIAN' + 1 //' GEOMETRY ARE ACTUALLY IMPLEMENTED.') + ENDIF + RETURN + END diff --git a/Dragon/src/PSOUR.f b/Dragon/src/PSOUR.f new file mode 100644 index 0000000..688c5dd --- /dev/null +++ b/Dragon/src/PSOUR.f @@ -0,0 +1,706 @@ +*DECK PSOUR + SUBROUTINE PSOUR(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Set the transition source from companion particles in a coupled- +* particle problem or the isotropic/monodirectional boundary sources. +* +*Copyright: +* Copyright (C) 2020 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert and C. Bienvenue +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): creation/modification type(L_SOURCE); +* HENTRY(2): read-only type(L_MACROLIB) for the source; +* HENTRY(3): read-only type(L_TRACKING); +* HENTRY(4): read-only type(L_FLUX) for companion particle 1; +* HENTRY(5): read-only type(L_FLUX) for companion particle 1; +* HENTRY(6): read-only type(L_FLUX) for companion particle 2; +* ... +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IOUT=6,NSTATE=40,MAXPAR=10) + TYPE(C_PTR) IPSOUR,JPSOUR,KPSOUR,IPTRK,IPGEOM,IPMAC,JPMAC,KPMAC, + 1 IPFLX(MAXPAR),IPSOUR2(MAXPAR),JPFLX,JPTRK + TYPE(C_PTR) JPSOURA,JPSOURB,KPSOURA,KPSOURB + CHARACTER HSIGN*12,TEXT12*12,CMODUL*12,HPART*6,HSMG*131 + CHARACTER(LEN=12) HPFLX(MAXPAR) + CHARACTER(LEN=1) HPARTC(MAXPAR) + INTEGER ISTATE(NSTATE),MESH_LEN(3),GN,STYPE,CPT + DOUBLE PRECISION DFLOTT + REAL DIR(3),ZNORM,BSNORM +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: NORM,SOURTEMP + INTEGER, ALLOCATABLE, DIMENSION(:) :: MATCOD + REAL, ALLOCATABLE, DIMENSION(:,:) :: FUNKNO,SUNKNO,BS + INTEGER, ALLOCATABLE, DIMENSION(:) :: ISISOUR,NBS1,NBS2,NBS + REAL, ALLOCATABLE, DIMENSION(:) :: XXX,YYY,ZZZ,ISOUR,XMIN,XMAX, + 1 YMIN,YMAX,ZMIN,ZMAX + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: BSINFO + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: BSINFO1,BSINFO2 + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: BS1,BS2 +*---- +* PARAMETER VALIDATION. +*---- + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('PSOUR: LI' + 1 //'NKED LIST OR XSM FILE EXPECTED AT LHS.') + IF(JENTRY(1).NE.0.AND.JENTRY(1).NE.1) CALL XABORT('PSOUR: ENTRY ' + 1 //'IN CREATE OR MODIFICATION MODE EXPECTED.') + IPSOUR=KENTRY(1) + IPMAC=C_NULL_PTR + IPTRK=C_NULL_PTR + JPTRK=C_NULL_PTR + IPGEOM=C_NULL_PTR + IPFLX(:)=C_NULL_PTR + NPART0=0 + NSOUR2=0 + NTRK=0 + DO I=2,NENTRY + IF((IENTRY(I).NE.1).AND.(IENTRY(I).NE.2)) CALL XABORT('PSOUR: ' + 1 //'LINKED LIST OR XSM FILE EXPECTED AT RHS.') + IF(JENTRY(I).NE.2) CALL XABORT('PSOUR: ENTRY IN READ-ONLY MODE' + 1 //' EXPECTED.') + CALL LCMGTC(KENTRY(I),'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_MACROLIB') THEN + IPMAC=KENTRY(I) + ELSE IF(HSIGN.EQ.'L_LIBRARY') THEN + IPMAC=LCMGID(KENTRY(I),'MACROLIB') + ELSE IF(HSIGN.EQ.'L_TRACK') THEN + IF(NTRK.EQ.0) THEN + IPTRK=KENTRY(I) + ELSE IF(NTRK.EQ.1) THEN + JPTRK=KENTRY(I) + ELSE + CALL XABORT('PSOUR: TOO MUCH TRACKING OBJECTS DEFINED.') + ENDIF + NTRK=NTRK+1 + ELSE IF(HSIGN.EQ.'L_GEOM') THEN + IPGEOM=KENTRY(I) + ELSE IF(HSIGN.EQ.'L_FLUX') THEN + NPART0=NPART0+1 + IF(NPART0.GT.MAXPAR) CALL XABORT('PSOUR: MAXPAR OVERFLOW.') + IPFLX(NPART0)=KENTRY(I) + HPFLX(NPART0)=HENTRY(I) + ELSE IF(HSIGN.EQ.'L_SOURCE') THEN + NSOUR2=NSOUR2+1 + IF(NSOUR2.GT.MAXPAR) CALL XABORT('PSOUR: MAXPAR OVERFLOW.') + IPSOUR2(NSOUR2)=KENTRY(I) + ELSE + TEXT12=HENTRY(I) + CALL XABORT('PSOUR: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. NON EXPECTED TYPE.') + ENDIF + ENDDO +*---- +* RECOVER MACROLIB INFORMATION FOR THE SOURCE +*---- + IF(.NOT.C_ASSOCIATED(IPMAC)) CALL XABORT('PSOUR: NO MACROLIB.') + CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE) + NG2=ISTATE(1) + NMAT=ISTATE(2) + NANIS=ISTATE(3)-1 + IADJ=ISTATE(13) + CALL LCMGTC(IPMAC,'PARTICLE',6,HPART) +*---- +* RECOVER TRACKING INFORMATION +*---- + IF(.NOT.C_ASSOCIATED(IPTRK)) CALL XABORT('PSOUR: NO TRACKING.') + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + NREG=ISTATE(1) + NUNS=ISTATE(2) + NDIM=ISTATE(9) + LX=ISTATE(12) + LY=ISTATE(13) + LZ=ISTATE(14) + NLF=ISTATE(15) + ALLOCATE(MATCOD(NREG)) + CALL LCMGET(IPTRK,'MATCOD',MATCOD) + CALL LCMGTC(IPTRK,'TRACK-TYPE',12,CMODUL) +*---- +* RECOVER GEOMETRY INFORMATION +*---- + IF(C_ASSOCIATED(IPGEOM)) THEN + IF(NDIM.EQ.1) THEN + CALL LCMLEN(IPGEOM,'MESHX',MESH_LEN(1),ITYLCM) + ALLOCATE(XXX(MESH_LEN(1)),YYY(0),ZZZ(0)) + CALL LCMGET(IPGEOM,'MESHX',XXX) + ELSE IF(NDIM.EQ.2) THEN + CALL LCMLEN(IPGEOM,'MESHX',MESH_LEN(1),ITYLCM) + CALL LCMLEN(IPGEOM,'MESHY',MESH_LEN(2),ITYLCM) + ALLOCATE(XXX(MESH_LEN(1)),YYY(MESH_LEN(2)),ZZZ(0)) + CALL LCMGET(IPGEOM,'MESHX',XXX) + CALL LCMGET(IPGEOM,'MESHY',YYY) + ELSE IF(NDIM.EQ.3) THEN + CALL LCMLEN(IPGEOM,'MESHX',MESH_LEN(1),ITYLCM) + CALL LCMLEN(IPGEOM,'MESHY',MESH_LEN(2),ITYLCM) + CALL LCMLEN(IPGEOM,'MESHZ',MESH_LEN(3),ITYLCM) + ALLOCATE(XXX(MESH_LEN(1)),YYY(MESH_LEN(2)),ZZZ(MESH_LEN(3))) + CALL LCMGET(IPGEOM,'MESHX',XXX) + CALL LCMGET(IPGEOM,'MESHY',YYY) + CALL LCMGET(IPGEOM,'MESHZ',ZZZ) + ENDIF + ENDIF +*---- +* RECOVER ADDITIONAL SOURCE INFORMATION +*---- + ALLOCATE(SUNKNO(NUNS,NG2),SOURTEMP(NUNS)) + SUNKNO(:NUNS,:NG2)=0.0 + DO NSOURIN=1,NSOUR2 + ! VOLUMIC SOURCES + IF(IADJ.EQ.0) THEN + JPSOUR=LCMGID(IPSOUR2(NSOURIN),'DSOUR') + ELSE IF(IADJ.EQ.1) THEN + JPSOUR=LCMGID(IPSOUR2(NSOURIN),'ASOUR') + ENDIF + KPSOUR=LCMGIL(JPSOUR,1) + DO IG=1,NG2 + CALL LCMGDL(KPSOUR,IG,SOURTEMP(:NUNS)) + SUNKNO(:NUNS,IG)=SUNKNO(:NUNS,IG)+SOURTEMP(:NUNS) + ENDDO + ENDDO +*---- +* INITIALIZATION FLUX AND RECOVER INPUT SOURCE INFORMATION IF AVAILABLE +*---- + ALLOCATE(NBS1(NG2),BS1(1,1,1),BSINFO1(1,1,1)) + NBS1(:)=0 + BSNORM=-1.0 + ISBS=0 + BS1(:,:,:)=0.0 + BSINFO1(:,:,:)=0 + + IF(NDIM.EQ.1) THEN + MAXL=1 + ELSE IF(NDIM.EQ.2) THEN + MAXL=MAX(LX,LY) + ELSE + MAXL=MAX(LX*LY,LX*LZ,LY*LZ) + ENDIF + + IF(JENTRY(1).EQ.1) THEN + CALL LCMGTC(IPSOUR,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_SOURCE') THEN + TEXT12=HENTRY(1) + CALL XABORT('SOUR: SIGNATURE OF'//TEXT12//' IS '//HSIGN// + 1 '. L_SOURCE EXPECTED.') + ENDIF + ! VOLUMIC SOURCES + IF(IADJ.EQ.0) THEN + JPSOUR=LCMGID(IPSOUR,'DSOUR') + ELSE IF(IADJ.EQ.1) THEN + JPSOUR=LCMGID(IPSOUR,'ASOUR') + ENDIF + KPSOUR=LCMGIL(JPSOUR,1) + DO IG=1,NG2 + CALL LCMGDL(KPSOUR,IG,SOURTEMP(:NUNS)) + SUNKNO(:NUNS,IG)=SUNKNO(:NUNS,IG)+SOURTEMP(:NUNS) + ENDDO + ! BOUNDARY SOURCES + CALL LCMLEN(IPSOUR,'NBS',ILEN,ITYLCM) + IF(ILEN.GT.0) THEN + ISBS=1 + CALL LCMGET(IPSOUR,'NBS',NBS1) + DEALLOCATE(BS1,BSINFO1) + ALLOCATE(BS1(MAXL,NG2,SUM(NBS1)),BSINFO1(2,IG,SUM(NBS1))) + JPSOURA=LCMGID(IPSOUR,'BS') + JPSOURB=LCMGID(IPSOUR,'BSINFO') + DO IG=1,NG2 + IF(NBS1(IG).GT.0) THEN + KPSOURA=LCMGIL(JPSOURA,IG) + KPSOURB=LCMGIL(JPSOURB,IG) + DO N=1,NBS1(IG) + CALL LCMGDL(KPSOURA,N,BS1(1,IG,N)) + CALL LCMGDL(KPSOURB,N,BSINFO1(1,IG,N)) + ENDDO + ENDIF + ENDDO + ENDIF + CALL LCMLEN(IPSOUR,'NORM-FS',ILEN,ITYLCM) + IF(ILEN.NE.0) CALL LCMGET(IPSOUR,'NORM-FS',BSNORM) + ENDIF + DEALLOCATE(SOURTEMP) +*---- +* READ THE INPUT DATA +*---- + IMPX=1 + NPART=0 + STYPE=-1 + NSOUR=-1 + ALLOCATE(ISOUR(NG2),ISISOUR(NG2)) + ISISOUR=0 + ISOUR=0.0 + ISIDEF=0 + ISXDEF=0 + ISYDEF=0 + ISZDEF=0 + MONOP=0 + ISDIRDEF=0 + 10 CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + 11 IF(INDIC.NE.3) CALL XABORT('PSOUR: CHARACTER DATA EXPECTED.') + IF(TEXT12.EQ.'EDIT') THEN +* READ THE PRINT INDEX. + CALL REDGET(INDIC,IMPX,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('PSOUR: INTEGER DATA EXPECTED.') + ELSE IF(TEXT12.EQ.'PARTICLE') THEN +* READ THE PARTICLE TYPE ('N', 'G', 'B', 'C', 'P') + NPART=NPART+1 + IF(NPART.GT.NPART0) CALL XABORT('PSOUR: NPART0 OVERFLOW.') + CALL REDGET(INDIC,NITMA,FLOTT,HPARTC(NPART),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('PSOUR: CHARACTER DATA EXPECTED.') + TEXT12='GROUP-'//HPARTC(NPART) + CALL LCMLEN(IPMAC,TEXT12,ILENG,ITYLCM) + IF(ILENG.EQ.0) THEN + WRITE(HSMG,'(14HPSOUR: RECORD ,A12,22H IS NOT AVAILABLE IN T, + 1 12HHE MACROLIB.)') TEXT12 + CALL LCMLIB(IPMAC) + CALL XABORT(HSMG) + ENDIF + ELSE IF(TEXT12.EQ.'ISO') THEN + ! ISOTROPIC SOURCE KEYWORD + IF(STYPE.NE.-1) CALL XABORT('PSOUR: ONLY ONE SOURCE TYPE ALLOW' + 1 //'ED.') + STYPE=0 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('PSOUR: INTEGER DATA EXPECTED' + 1 //' (NUMBER OF SOURCES).') + NSOUR=NITMA + IF(NSOUR.LE.0) CALL XABORT('PSOUR: INVALID NUMBER OF SOURCES.') + ALLOCATE(XMIN(NSOUR),XMAX(NSOUR),YMIN(NSOUR),YMAX(NSOUR), + 1 ZMIN(NSOUR),ZMAX(NSOUR)) + ELSE IF(TEXT12.EQ.'MONO') THEN + ! MONODIRECTIONNAL BOUNDARY SOURCE KEYWORD + IF(STYPE.NE.-1) CALL XABORT('PSOUR: ONLY ONE SOURCE TYPE ALLOW' + 1 //'ED.') + STYPE=1 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('PSOUR: INTEGER DATA EXPECTED' + 1 //' (NUMBER OF SOURCES).') + NSOUR=NITMA + IF(NSOUR.LE.0) CALL XABORT('PSOUR: INVALID NUMBER OF SOURCES.') + ALLOCATE(XMIN(NSOUR),XMAX(NSOUR),YMIN(NSOUR),YMAX(NSOUR), + 1 ZMIN(NSOUR),ZMAX(NSOUR)) +! SOURCE INTENSITY PER ENERGY GROUP KEYWORD + ELSE IF(TEXT12.EQ.'INTG') THEN + ISIDEF=1 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.EQ.2) THEN + ISOUR(1)=FLOTT + IF(ISOUR(1).LT.0.0) CALL XABORT('PSOUR: INVALID INTENSITY.') + DO I=2,NG2 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('PSOUR: REAL DATA EXPECTED.') + ISOUR(I)=FLOTT + IF(ISOUR(I).LT.0.0) CALL XABORT('PSOUR: INVALID INTENSITY.') + ENDDO + ISISOUR(1:NG2)=1 + ELSE IF(INDIC.EQ.1) THEN + GN=NITMA + IF(GN.GT.NG2.OR.GN.LT.1) CALL XABORT('PSOUR: INVALID GROUP' + 1 //' NUMBER.') + ISISOUR(GN)=1 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('PSOUR: REAL DATA EXPECTED.') + ISOUR(GN)=FLOTT + IF(ISOUR(I).LT.0.0) CALL XABORT('PSOUR: INVALID INTENSITY.') + 12 CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.EQ.1) THEN + GN=NITMA + IF(GN.GT.NG2.OR.GN.LT.1) CALL XABORT('PSOUR: INVALID GROUP' + 1 //' NUMBER.') + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('PSOUR: REAL DATA EXPECTED.') + ISOUR(GN)=FLOTT + IF(ISOUR(I).LT.0.0) CALL XABORT('PSOUR: INVALID INTENSITY.') + GO TO 12 + ELSE + GO TO 11 + ENDIF + ELSE + CALL XABORT('PSOUR: REAL OR INTEGER DATA EXPECTED.') + ENDIF +! (X,Y,Z) LIMITS KEYWORDS + ELSE IF(TEXT12.EQ.'XLIM') THEN + DO I=1,NSOUR + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('PSOUR: REAL DATA EXPECTED.') + XMIN(I)=FLOTT + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('PSOUR: REAL DATA EXPECTED.') + XMAX(I)=FLOTT + ISXDEF=1 + ENDDO + ELSE IF(TEXT12.EQ.'YLIM') THEN + IF(NDIM.LT.2) CALL XABORT('PSOUR: INVALID USE OF YLIM, DIM < 2') + DO I=1,NSOUR + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('PSOUR: REAL DATA EXPECTED.') + YMIN(I)=FLOTT + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('PSOUR: REAL DATA EXPECTED.') + YMAX(I)=FLOTT + ISYDEF=1 + ENDDO + ELSE IF(TEXT12.EQ.'ZLIM') THEN + IF(NDIM.LT.3) CALL XABORT('PSOUR: INVALID USE OF YLIM, DIM < 3') + DO I=1,NSOUR + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('PSOUR: REAL DATA EXPECTED.') + ZMIN(I)=FLOTT + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('PSOUR: REAL DATA EXPECTED.') + ZMAX(I)=FLOTT + ISZDEF=1 + ENDDO +! BOUNDARY SOURCE LOCATION KEYWORD + ELSE IF(TEXT12.EQ.'X-') THEN + IF(MONOP.NE.0) CALL XABORT('PSOUR: BOUNDARY SOURCE ALREADY' + 1 //'DEFINED') + MONOP=-1 + ELSE IF(TEXT12.EQ.'X+') THEN + IF(MONOP.NE.0) CALL XABORT('PSOUR: BOUNDARY SOURCE ALREADY' + 1 //'DEFINED') + MONOP=1 + ELSE IF(TEXT12.EQ.'Y-') THEN + IF(NDIM.LT.2) CALL XABORT('PSOUR: INVALID USE OF YLIM, DIM < 2') + IF(MONOP.NE.0) CALL XABORT('PSOUR: BOUNDARY SOURCE ALREADY' + 1 //'DEFINED') + MONOP=-2 + ELSE IF(TEXT12.EQ.'Y+') THEN + IF(NDIM.LT.2) CALL XABORT('PSOUR: INVALID USE OF YLIM, DIM < 2') + IF(MONOP.NE.0) CALL XABORT('PSOUR: BOUNDARY SOURCE ALREADY' + 1 //'DEFINED') + MONOP=2 + ELSE IF(TEXT12.EQ.'Z-') THEN + IF(NDIM.LT.3) CALL XABORT('PSOUR: INVALID USE OF YLIM, DIM < 3') + IF(MONOP.NE.0) CALL XABORT('PSOUR: BOUNDARY SOURCE ALREADY' + 1 //'DEFINED') + MONOP=-3 + ELSE IF(TEXT12.EQ.'Z+') THEN + IF(NDIM.LT.3) CALL XABORT('PSOUR: INVALID USE OF YLIM, DIM < 3') + IF(MONOP.NE.0) CALL XABORT('PSOUR: BOUNDARY SOURCE ALREADY' + 1 //'DEFINED') + MONOP=3 + ELSE IF(TEXT12.EQ.'DIR') THEN + ! MONODIRECTIONAL SOURCE DIRCTION (2 ANGLES) + ISDIRDEF=1 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('PSOUR: REAL DATA EXPECTED.') + TEMP1=FLOTT + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('PSOUR: REAL DATA EXPECTED.') + TEMP2=FLOTT + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.EQ.2) THEN + DIR(1)=TEMP1 !MU + DIR(2)=TEMP2 !ETA + DIR(3)=FLOTT !XI + IF(DIR(1).GT.1.0.OR.DIR(1).LT.-1.0.OR.DIR(2).GT.1.0.OR. + 1 DIR(2).LT.-1.0.OR.DIR(3).GT.1.0.OR.DIR(3).LT.-1.0.OR. + 2 DIR(1)**2+DIR(2)**2+DIR(3)**2.GT.1.0) CALL XABORT('PSOUR:' + 3 //' INVALID DIRECTION COSINES VALUES.') + ELSE + IF(TEMP1.GT.180.0.OR.TEMP1.LT.0.0.OR.TEMP2.GT.90.0.OR. + 1 TEMP2.LT.0.0) CALL XABORT('PSOUR: INVALID POLAR OR AZIMUTAL' + 2 //' ANGLE.') + DIR(1)=COS(TEMP1*3.1416/180) !MU + DIR(2)=SQRT(1-DIR(1)**2)*COS(TEMP2*3.1416/180) !ETA + DIR(3)=SQRT(1-DIR(1)**2)*SIN(TEMP2*3.1416/180) !XI + GO TO 11 + ENDIF + ELSE IF(TEXT12.EQ.';') THEN + GO TO 20 + ELSE + CALL XABORT('PSOUR: '//TEXT12//' IS AN INVALID KEYWORD.') + ENDIF + GO TO 10 +*---- +* COMPUTE THE TRANSITION SOURCE +*---- + 20 IF(NPART.GT.0) THEN + IF(NPART.NE.NPART0) THEN + WRITE(HSMG,'(30HPSOUR: INVALID NUMBER OF RHS (,I2,8H) NUMBER, + 1 25H OF COMPANION PARTICLES =,I2,1H.)') NENTRY,NPART + CALL XABORT(HSMG) + ELSE IF(STYPE.GE.0) THEN + CALL XABORT('PSOUR: TRANSITION AND BOUNDARY SOURCES PRESENT.') + ENDIF + IF(IMPX.GT.0) WRITE(IOUT,100) + IF(.NOT.C_ASSOCIATED(JPTRK)) CALL XABORT('PSOUR: NO TRACKING' + 1 //' ASSOCIATED WITH THE COMPANION PARTICLE.') + DO IPART=1,NPART + CALL LCMGET(IPFLX(IPART),'STATE-VECTOR',ISTATE) + NG1=ISTATE(1) + NUNF=ISTATE(2) + ALLOCATE(FUNKNO(NUNF,NG1)) + IF(IMPX.GT.0) WRITE(IOUT,110) IPART,HPARTC(NPART),HPFLX(NPART) + TEXT12='GROUP-'//HPARTC(IPART) + JPMAC=LCMGID(IPMAC,TEXT12) + IF(IADJ.EQ.0) THEN + JPFLX=LCMGID(IPFLX(IPART),'FLUX') + ELSE IF(IADJ.EQ.1) THEN + JPFLX=LCMGID(IPFLX(IPART),'AFLUX') + ENDIF + DO IG=1,NG1 + IF(IADJ.EQ.0) THEN + CALL LCMGDL(JPFLX,IG,FUNKNO(1,IG)) + ELSE IF(IADJ.EQ.1) THEN + CALL LCMGDL(JPFLX,NG1-IG+1,FUNKNO(1,IG)) + ENDIF + ENDDO + DO IG=1,NG2 + KPMAC=LCMGIL(JPMAC,IG) + CALL PSOUSN(NUNF,NUNS,IG,IPTRK,JPTRK,KPMAC,NANIS,NREG, + 1 NMAT,NG1,NG2,MATCOD,FUNKNO,SUNKNO) + ENDDO + DEALLOCATE(FUNKNO) + ENDDO + ALLOCATE(NORM(NPART)) + DO IPART=1,NPART + CALL LCMLEN(IPFLX(IPART),'NORM-FS',ILEN,ITYLCM) + IF(ILEN.GT.0) CALL LCMGET(IPFLX(IPART),'NORM-FS',NORM(IPART)) + ENDDO + CALL LCMPUT(IPSOUR,'NORM-FS',1,2,SUM(NORM)) + DEALLOCATE(MATCOD,NORM) +*---- +* BOUNDARY SOURCES +*---- + ELSE IF(STYPE.GE.0) THEN + IF(ISIDEF.EQ.0) CALL XABORT('PSOUR: SOURCE INTENSITY NOT DEFIN' + 1 //'ED.') + IF(MONOP.EQ.0.AND.STYPE.EQ.1) CALL XABORT('PSOUR: BOUNDARY SOU' + 1 //'RCE POSITION NOT DEFINED.') + IF(ISDIRDEF.EQ.0.AND.STYPE.EQ.1) CALL XABORT('PSOUR:' + 1 //' MONODIRECTIONAL SOURCE DIRECTION NOT DEFINED.') + IF(IMPX.GT.0) THEN + IF(STYPE.EQ.0) THEN + WRITE(IOUT,'(/34H PSOUR: ISOTROPIC BOUNDARY SOURCE.)') + ELSE IF(STYPE.EQ.1) THEN + WRITE(IOUT,'(/40H PSOUR: MONODIRECTIONAL BOUNDARY SOURCE.)') + ENDIF + ENDIF + + ! X-BOUNDARY + IF(ISXDEF.EQ.1) THEN + IF(ABS(MONOP).EQ.1) CALL XABORT('PSOUR: BOUNDARY SOURCE' + 1 //' X- OR X+ : XLIM SHOULD NOT BE DEFINED.') + DO I=1,NSOUR + IF(XMIN(I).LT.XXX(1).OR.XMAX(I).GT.XXX(MESH_LEN(1))) + 1 CALL XABORT('PSOUR: SOURCE X-LIMITS OUTSIDE THE GEOMETRY.') + IF(XMIN(I).GE.XMAX(I)) CALL XABORT('PSOUR: SOURCE X-LIMITS' + 1 //' INVALID.') + ENDDO + ELSE + IF(STYPE.EQ.0) CALL XABORT('PSOUR: SOURCE X-LIMITS NOT DEFIN' + 1 //'ED.') + ENDIF + + ! Y-BOUNDARY + IF(ISYDEF.EQ.1) THEN + IF(ABS(MONOP).EQ.2) CALL XABORT('PSOUR: BOUNDARY SOURCE' + 1 //' Y- OR Y+ : YLIM SHOULD NOT BE DEFINED.') + DO I=1,NSOUR + IF(YMIN(I).LT.YYY(1).OR.YMAX(I).GT.YYY(MESH_LEN(2))) + 1 CALL XABORT('PSOUR: SOURCE Y-LIMITS OUTSIDE THE GEOMETRY.') + IF(YMIN(I).GE.YMAX(I)) CALL XABORT('PSOUR: SOURCE Y-LIMITS' + 1 //' INVALID.') + ENDDO + ELSE + IF(NDIM.GE.2.AND.STYPE.EQ.0) CALL XABORT('PSOUR: SOURCE Y-LI' + 1 //'MITS NOT DEFINED.') + IF(NDIM.GE.2.AND.STYPE.EQ.1.AND.(ABS(MONOP).NE.2)) + 1 CALL XABORT('PSOUR: SOURCE Y-LIMITS NOT DEFINED.') + ENDIF + + ! Z-BOUNDARY + IF(ISZDEF.EQ.1) THEN + IF(ABS(MONOP).EQ.3) CALL XABORT('PSOUR: BOUNDARY SOURCE' + 1 //' Z- OR Z+ : ZLIM SHOULD NOT BE DEFINED.') + DO I=1,NSOUR + IF(ZMIN(I).LT.ZZZ(1).OR.ZMAX(I).GT.ZZZ(MESH_LEN(3))) + 1 CALL XABORT('PSOUR: SOURCE Z-LIMITS OUTSIDE THE GEOMETRY.') + IF(ZMIN(I).GE.ZMAX(I)) CALL XABORT('PSOUR: SOURCE Z-LIMITS' + 1 //' INVALID.') + ENDDO + ELSE + IF(NDIM.GE.3.AND.STYPE.EQ.0) CALL XABORT('PSOUR: SOURCE Z-LI' + 1 //'MITS NOT DEFINED.') + IF(NDIM.GE.3.AND.STYPE.EQ.1.AND.(ABS(MONOP).NE.3)) + 1 CALL XABORT('PSOUR: SOURCE Z-LIMITS NOT DEFINED.') + ENDIF +*---- +* COMPUTE THE FIXED EXTERNAL SOURCES +*---- + IF(NDIM.EQ.1) THEN + NBST=SUM(ISISOUR) + ELSEIF(NDIM.EQ.2) THEN + NBST=SUM(ISISOUR)*2 + ELSE + NBST=SUM(ISISOUR)*4 + ENDIF + + ALLOCATE(BSINFO2(2,NG2,NBST),BS2(MAXL,NG2,NBST),NBS2(NG2)) + NBS2=0 + + IF(STYPE.EQ.0) THEN + CALL PSOISO(IPTRK,IPGEOM,NREG,LX,LY,LZ,NG2,NUNS,NDIM, + 1 NSOUR,ISOUR,XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,XXX,YYY,ZZZ, + 2 MESH_LEN,SUNKNO,ZNORM) + ELSE IF(STYPE.EQ.1) THEN + CALL PSOMON(IPTRK,IPGEOM,NREG,LX,LY,LZ,NG2,NDIM,NSOUR, + 1 ISOUR,ISISOUR,XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,XXX,YYY, + 2 ZZZ,MESH_LEN,BSINFO2,BS2,MAXL,ZNORM,DIR,MONOP,NBST,NBS2) + ELSE + CALL XABORT('PSOUR: SOURCE TYPE EXPECTED.') + ENDIF + + DEALLOCATE(XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,XXX,YYY,ZZZ,ISOUR, + 1 ISISOUR) + + ! SAVE BOUNDARY SOURCE + IF(STYPE.EQ.0.AND.ISBS.EQ.1) THEN + JPSOURA=LCMLID(IPSOUR,'BS',NG2) + JPSOURB=LCMLID(IPSOUR,'BSINFO',NG2) + DO IG=1,NG2 + IF(NBS1(IG).GT.0) THEN + KPSOURA=LCMLIL(JPSOURA,IG,NBS1(IG)) + KPSOURB=LCMLIL(JPSOURB,IG,NBS1(IG)) + DO N=1,NBS1(IG) + CALL LCMPDL(KPSOURA,N,MAXL,2,BS1(1,IG,N)) + CALL LCMPDL(KPSOURB,N,2,1,BSINFO1(1,IG,N)) + ENDDO + ENDIF + ENDDO + CALL LCMPUT(IPSOUR,'NBS',NG2,1,NBS1) + ELSE IF(STYPE.EQ.1.AND.ISBS.EQ.0) THEN + JPSOURA=LCMLID(IPSOUR,'BS',NG2) + JPSOURB=LCMLID(IPSOUR,'BSINFO',NG2) + DO IG=1,NG2 + IF(NBS2(IG).GT.0) THEN + KPSOURA=LCMLIL(JPSOURA,IG,NBS2(IG)) + KPSOURB=LCMLIL(JPSOURB,IG,NBS2(IG)) + DO N=1,NBS2(IG) + CALL LCMPDL(KPSOURA,N,MAXL,2,BS2(1,IG,N)) + CALL LCMPDL(KPSOURB,N,2,1,BSINFO2(1,IG,N)) + ENDDO + ENDIF + ENDDO + CALL LCMPUT(IPSOUR,'NBS',NG2,1,NBS2) + DEALLOCATE(BS2,BSINFO2) + ELSE IF(STYPE.EQ.1.AND.ISBS.EQ.1) THEN + JPSOURA=LCMLID(IPSOUR,'BS',NG2) + JPSOURB=LCMLID(IPSOUR,'BSINFO',NG2) + ALLOCATE(NBS(NG2)) + NBS(:NG2)=NBS1(:NG2)+NBS2(:NG2) + DO IG=1,NG2 + ALLOCATE(BS(MAXL,NBS(IG)),BSINFO(2,NBS(IG))) + BSINFO(:2,:NBS1(IG))=BSINFO1(:2,IG,:NBS1(IG)) + BS(:MAXL,:NBS1(IG))=BS1(:MAXL,IG,:NBS1(IG)) + CPT=1 + DO N2=1,NBS2(IG) + ISD=0 + DO N1=1,NBS1(IG) + IF(BSINFO2(1,IG,N2).EQ.BSINFO(1,N1).AND. + 1 BSINFO2(2,IG,N2).EQ.BSINFO(2,N1)) THEN + BS(:MAXL,N1) = BS(:MAXL,N1) + BS2(:MAXL,IG,N2) + NBS(IG)=NBS(IG)-1 + ISD=1 + ENDIF + ENDDO + IF(ISD.EQ.0) THEN + BSINFO(:2,NBS1(IG)+CPT)=BSINFO2(:2,IG,N2) + BS(:MAXL,NBS1(IG)+CPT)=BS2(:MAXL,IG,N2) + CPT=CPT+1 + ENDIF + ENDDO + IF(NBS(IG).GT.0) THEN + KPSOURA=LCMLIL(JPSOURA,IG,NBS(IG)) + KPSOURB=LCMLIL(JPSOURB,IG,NBS(IG)) + DO N=1,NBS(IG) + CALL LCMPDL(KPSOURA,N,MAXL,2,BS(1,N)) + CALL LCMPDL(KPSOURB,N,2,1,BSINFO(1,N)) + ENDDO + ENDIF + DEALLOCATE(BS,BSINFO) + ENDDO + CALL LCMPUT(IPSOUR,'NBS',NG2,1,NBS) + DEALLOCATE(BS2,BSINFO2,NBS,NBS1,NBS2) + ENDIF + + ! Save the source normalization factor + IF(BSNORM.LT.0) THEN + CALL LCMPUT(IPSOUR,'NORM-FS',1,2,ZNORM) + ELSE + CALL LCMPUT(IPSOUR,'NORM-FS',1,2,ZNORM+BSNORM) + ENDIF + ENDIF + DEALLOCATE(BS1,BSINFO1) +*---- +* SAVE THE TRANSITION SOURCE ON LCM +*---- + IOF=1 + NDIR=0 + NCST=0 + IF(IADJ.EQ.0) THEN + NDIR=1 + JPSOUR=LCMLID(IPSOUR,'DSOUR',NDIR) + ELSE IF(IADJ.EQ.1) THEN + NCST=1 + JPSOUR=LCMLID(IPSOUR,'ASOUR',NCST) + ENDIF + KPSOUR=LCMLIL(JPSOUR,IOF,NG2) + DO IG=1,NG2 + CALL LCMPDL(KPSOUR,IG,NUNS,2,SUNKNO(1,IG)) + ENDDO + DEALLOCATE(SUNKNO) +*---- +* SAVE THE SIGNATURE AND STATE VECTOR +*---- + HSIGN='L_SOURCE' + CALL LCMPTC(IPSOUR,'SIGNATURE',12,HSIGN) + ISTATE(:NSTATE)=0 + ISTATE(1)=NG2 + ISTATE(2)=NUNS + ISTATE(3)=NDIR + ISTATE(4)=NCST + IF(IMPX.GT.0) WRITE(6,120) (ISTATE(I),I=1,4) + CALL LCMPUT(IPSOUR,'STATE-VECTOR',NSTATE,1,ISTATE) + RETURN +* + 100 FORMAT(/44H PSOUR: TRANSITIONS FROM COMPANION PARTICLES/4X, + 1 14HPARTICLE......, 3X,13H PRIMARY_FLUX) + 110 FORMAT(1X,I4,A13,4X,A12) + 120 FORMAT(/8H OPTIONS/8H -------/ + 1 7H NG ,I8,28H (NUMBER OF ENERGY GROUPS)/ + 2 7H NUN ,I8,40H (NUMBER OF UNKNOWNS PER ENERGY GROUP)/ + 3 7H NDIR ,I8,35H (NUMBER OF DIRECT FIXED SOURCES)/ + 4 7H NCST ,I8,36H (NUMBER OF ADJOINT FIXED SOURCES)) + END diff --git a/Dragon/src/PSOUSN.f b/Dragon/src/PSOUSN.f new file mode 100644 index 0000000..e2a2e3b --- /dev/null +++ b/Dragon/src/PSOUSN.f @@ -0,0 +1,241 @@ +*DECK PSOUSN + SUBROUTINE PSOUSN(NUNF,NUNS,IG,IPTRK,JPTRK,KPMACR,NANIS,NREG,NMAT, + > NGRP1,NGRP2,MATCOD,FLUX,SOURCE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the source from companion particle for the solution of SN +* equations. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NUNF first dimension of FLUX arrays. +* NUNS first dimension of SOURCE arrays. +* IG secondary group. +* IPTRK pointer to the tracking LCM object (from main particle). +* JPTRK pointer to the tracking LCM object (from companion particle). +* KPMACR pointer to the secondary-group related macrolib information. +* NANIS maximum cross section Legendre order. +* NREG number of regions. +* NMAT number of mixtures. +* NGRP1 number of primary energy groups. +* NGRP2 number of secondary energy groups. +* MATCOD mixture indices. +* FLUX fluxes. +* +*Parameters: output +* SOURCE sources. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,JPTRK,KPMACR + INTEGER NUNF,NUNS,IG,NANIS,NREG,NMAT,NGRP1,NGRP2,MATCOD(NREG) + REAL FLUX(NUNF,NGRP1),SOURCE(NUNS,NGRP2) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40,PI4=12.5663706144) + INTEGER IPAR(NSTATE),JPAR(NSTATE),P,P2,IELEM,EELEM,IELEM2,EELEM2, + 1 NM,NM2,EEL,IEL,IND,IND2,EL,EL2 + CHARACTER CANIL*2 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS,MAP + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: M_INDEXES + REAL, ALLOCATABLE, DIMENSION(:) :: XSCAT + TYPE(C_PTR) IL_PTR,IM_PTR,IL2_PTR,IM2_PTR + INTEGER, POINTER, DIMENSION(:) :: IL,IM,IL2,IM2 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IJJ(0:NMAT),NJJ(0:NMAT),IPOS(0:NMAT)) + ALLOCATE(XSCAT(0:NMAT*NGRP1)) +*---- +* RECOVER SNT SPECIFIC PARAMETERS. +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',IPAR) + IF(IPAR(1).NE.NREG) CALL XABORT('PSOUSN: INCONSISTENT NREG.') + ITYPE=IPAR(6) + NSCT=IPAR(7) + IELEM=IPAR(8) + ISCAT=IPAR(16) + EELEM=IPAR(35) + CALL LCMGPD(IPTRK,'IL',IL_PTR) + CALL LCMGPD(IPTRK,'IM',IM_PTR) + CALL C_F_POINTER(IL_PTR,IL,(/ NSCT /)) + CALL C_F_POINTER(IM_PTR,IM,(/ NSCT /)) + CALL LCMGET(JPTRK,'STATE-VECTOR',JPAR) + IF(JPAR(1).NE.NREG) CALL XABORT('PSOUSN: INCONSISTENT NREG.') + ITYPE2=IPAR(6) + NSCT2=JPAR(7) + IELEM2=JPAR(8) + ISCAT2=JPAR(16) + EELEM2=JPAR(35) + CALL LCMGPD(JPTRK,'IL',IL2_PTR) + CALL LCMGPD(JPTRK,'IM',IM2_PTR) + CALL C_F_POINTER(IL2_PTR,IL2,(/ NSCT2 /)) + CALL C_F_POINTER(IM2_PTR,IM2,(/ NSCT2 /)) + IF(ITYPE.NE.ITYPE2.OR.NSCT.NE.NSCT2.OR.ISCAT.NE.ISCAT2) + 1 CALL XABORT('PSOUSN: INCONSISTENCE OF ANGULAR DISCRETISATION' + 2 //'BETWEEN THE PARTICLE AND ITS COMPANION PARTICLE.') +*---- +* MAPPING BETWEEN SPACE-ENERGY MOMENTS +*---- + NMX=IELEM + NMX2=IELEM2 + IF((ITYPE.EQ.5).OR.(ITYPE.EQ.6).OR.(ITYPE.EQ.8)) THEN + NMX=IELEM**2 + NMX2=IELEM2**2 + ELSEIF((ITYPE.EQ.7).OR.(ITYPE.EQ.9)) THEN + NMX=IELEM**3 + NMX2=IELEM2**3 + ENDIF + ALLOCATE(M_INDEXES(MAX(NMX,NMX2),MAX(EELEM,EELEM2))) + ALLOCATE(MAP(NMX*EELEM)) + M_INDEXES=0 + MAP=0 + DO IEL=1,NMX2 + DO EEL=1,EELEM2 + M_INDEXES(IEL,EEL)=EELEM2*(IEL-1)+EEL + ENDDO + ENDDO + DO IEL=1,NMX + DO EEL=1,EELEM + IF(IEL.LE.NMX2.AND.EEL.LE.EELEM2) THEN + IND=EELEM*(IEL-1)+EEL + MAP(IND)=M_INDEXES(IEL,EEL) + ENDIF + ENDDO + ENDDO + DEALLOCATE(M_INDEXES) +*---- +* CONSTRUCT THE SOURCE. +*---- + IJJ(0)=0 + NJJ(0)=0 + IPOS(0)=0 + XSCAT(0)=0.0 + IOF0=0 + DO 100 P=1,NSCT + ILP = IL(P) + IF(ILP.GT.NANIS-1) GO TO 100 + WRITE(CANIL,'(I2.2)') ILP + CALL LCMGET(KPMACR,'NJJS'//CANIL,NJJ(1)) + CALL LCMGET(KPMACR,'IJJS'//CANIL,IJJ(1)) + CALL LCMGET(KPMACR,'IPOS'//CANIL,IPOS(1)) + CALL LCMGET(KPMACR,'SCAT'//CANIL,XSCAT(1)) + IF((ITYPE.EQ.2).OR.(ITYPE.EQ.4)) THEN +*---- +* SLAB OR SPHERICAL 1D CASE. +*---- + NM=IELEM*EELEM + NM2=IELEM2*EELEM2 + DO 20 IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) GO TO 20 + DO 15 IEL=1,NM + IF(MAP(IEL).EQ.0) CONTINUE + IND=(IR-1)*NSCT*NM+NM*(P-1)+IEL + IND2=(IR-1)*NSCT*NM2+NM2*(P-1)+MAP(IEL) + JG=IJJ(IBM) + DO 10 JND=1,NJJ(IBM) + SOURCE(IND,IG)=SOURCE(IND,IG)+FLUX(IND2,JG)* + > XSCAT(IPOS(IBM)+JND-1) + JG=JG-1 + 10 CONTINUE + 15 CONTINUE + 20 CONTINUE + ELSE IF(ITYPE.EQ.3) THEN +*---- +* CYLINDRICAL 1D CASE. +*---- + DO 50 P2=0,(P-1) + IF(MOD(P-1+P2,2).EQ.1) GO TO 50 + IOF0=IOF0+1 + DO 40 IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) GO TO 40 + IND=(IR-1)*NSCT+IOF0 + JG=IJJ(IBM) + DO 30 JND=1,NJJ(IBM) + SOURCE(IND,IG)=SOURCE(IND,IG)+FLUX(IND,JG)* + > XSCAT(IPOS(IBM)+JND-1) + JG=JG-1 + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + ELSE IF((ITYPE.EQ.5).OR.(ITYPE.EQ.6).OR.(ITYPE.EQ.8)) THEN +*---- +* 2D CASES (CARTESIAN OR R-Z). +*---- + NM=IELEM*IELEM*EELEM + NM2=IELEM2*IELEM2*EELEM2 + DO 70 IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) GO TO 70 + DO 65 IEL=1,IELEM**2 + DO 64 EEL=1,EELEM + IF(IEL.GT.IELEM2**2.OR.EEL.GT.EELEM2) CONTINUE + EL=EELEM*(IEL-1)+EEL + EL2=EELEM2*(IEL-1)+EEL + IND=(IR-1)*NSCT*NM+NM*(P-1)+EL + IND2=(IR-1)*NSCT*NM2+NM2*(P-1)+EL2 + JG=IJJ(IBM) + DO 60 JND=1,NJJ(IBM) + SOURCE(IND,IG)=SOURCE(IND,IG)+FLUX(IND2,JG)* + > XSCAT(IPOS(IBM)+JND-1) + JG=JG-1 + 60 CONTINUE + 64 CONTINUE + 65 CONTINUE + 70 CONTINUE + ELSE IF((ITYPE.EQ.7).OR.(ITYPE.EQ.9)) THEN +*---- +* 3D CARTESIAN CASE +*---- + NM=IELEM*IELEM*IELEM*EELEM + NM2=IELEM2*IELEM2*IELEM2*EELEM2 + DO 90 IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) GO TO 90 + DO 85 IEL=1,IELEM**3 + DO 84 EEL=1,EELEM + IF(IEL.GT.IELEM2**3.OR.EEL.GT.EELEM2) CONTINUE + EL=EELEM*(IEL-1)+EEL + EL2=EELEM2*(IEL-1)+EEL + IND=(IR-1)*NSCT*NM+NM*(P-1)+EL + IND2=(IR-1)*NSCT*NM2+NM2*(P-1)+EL2 + JG=IJJ(IBM) + DO 80 JND=1,NJJ(IBM) + SOURCE(IND,IG)=SOURCE(IND,IG)+FLUX(IND2,JG)* + > XSCAT(IPOS(IBM)+JND-1) + JG=JG-1 + 80 CONTINUE + 84 CONTINUE + 85 CONTINUE + 90 CONTINUE + ELSE + CALL XABORT('PSOUSN: TYPE OF DISCRETIZATION NOT IMPLEMENTED.') + ENDIF + 100 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XSCAT,MAP) + DEALLOCATE(IPOS,NJJ,IJJ) + RETURN + END diff --git a/Dragon/src/PSP.f b/Dragon/src/PSP.f new file mode 100644 index 0000000..ef3475c --- /dev/null +++ b/Dragon/src/PSP.f @@ -0,0 +1,292 @@ +*DECK PSP + SUBROUTINE PSP(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* POSTSCRIPT plot utility module. +* +*Copyright: +* Copyright (C) 1999 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* NENTRY number of data structures transfered to this module. +* HENTRY name of the data structures. +* IENTRY data structure type where: +* =1 for LCM memory object; +* =2 for XSM file; +* =3 for sequential binary file; +* =4 for sequential ASCII file. +* JENTRY access permission for the data structure where: +* =0 for a data structure in creation mode; +* =1 for a data structure in modifications mode; +* =2 for a data structure in read-only mode. +* KENTRY data structure pointer. +* +*Comments: +* Input requirements +* NENTRY >= 2 +* IEN = 1 : structure is a sequential ascii file +* containing the output POSTSCRIPT. this can be A +* new file or a file to update. +* IENTRY(ien) = 4, JENTRY(ien) <= 1 +* FOR PSP BY Mixture or region +* IEN > 1 : structure is a valid dragon geometry +* for excelt stored in a linked list or XSM file. +* this structure must be in read-only mode +* IENTRY(ien)<= 2, JENTRY(ien) = 2 +* FOR PSP BY Flux +* IEN = 2 : structure is a valid dragon geometry +* for excelt stored in a linked list or XSM file. +* this structure must be in read-only mode +* IENTRY(ien)<= 2, JENTRY(ien) = 2 +* IEN = 3 : structure is a valid flux structure +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE + INTEGER IOUT,NSTATE,ILCMUP,ILCMDN + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NSTATE=40,ILCMUP=1,ILCMDN=2, + > NAMSBR='PSP ') +*---- +* ROUTINE PARAMTERS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + INTEGER ISTATE(NSTATE),IPRINT,IEN, + > IENGT,IENFL,ISPSP,ITYPE,ICOLR, + > NPAGE,ITRK,NGROUP,NUNKNO,IGR,NGT + CHARACTER HSIGN*12,NAMGT*12,NAMLEG*24 + REAL XYPOS(2) + CHARACTER NAMTR2*12,NAMGEO*12 + TYPE(C_PTR) IPTRK2,IPFL,IPGT + INTEGER IMODT2,IMEDT2,ICLST2,IPRIN2 + LOGICAL LASS,LDRASS + INTEGER IMODE,NMODE + TYPE(C_PTR) JPFL,KPFL +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ICOND + REAL, ALLOCATABLE, DIMENSION(:) :: FLUX,TFLX +*---- + NAMTR2='PSPGEOIPTRK2' + IMODT2=0 + IMEDT2=1 + IPRIN2=0 + ICLST2=2 +*---- +* INPUT PARAMETER VALIDATION +*---- + XYPOS(1)=0.5 + XYPOS(2)=0.5 + IF(NENTRY .LT. 2 ) CALL XABORT(NAMSBR// + > ': AT LEAST TWO DATA STRUCTURES REQUIRED') + ISPSP=FILUNIT(KENTRY(1)) + IF(IENTRY(1) .NE. 4 ) CALL XABORT(NAMSBR// + > ': POSTSCRIPT DATA STRUCTURE NOT AN ASCII FILE') + IF(JENTRY(1) .NE. 0 .AND. + > JENTRY(1) .NE. 1 ) CALL XABORT(NAMSBR// + > ': POSTSCRIPT DATA STRUCTURE NOT IN CREATE OR MODIFY MODE') +*---- +* Find if one of the structures is a flux +* and get number of groups if required +*---- + NGROUP=1 + IENFL=0 + DO IEN=1,NENTRY + IF(IENTRY(IEN) .EQ. 1 .OR. IENTRY(IEN) .EQ. 2 ) THEN + IF(JENTRY(IEN) .GT. 0 ) THEN + IPFL=KENTRY(IEN) + CALL LCMGTC(IPFL,'SIGNATURE',12,HSIGN) + IF(HSIGN .EQ. 'L_FLUX ') THEN + IENFL=IEN + ISTATE(:NSTATE)=0 + CALL LCMGET(IPFL,'STATE-VECTOR',ISTATE) + NGROUP=ISTATE(1) + NUNKNO=ISTATE(2) + ENDIF + ENDIF + ENDIF + ENDDO +*---- +* READ PSP OPTIONS +* IPRINT : EDIT LEVEL +* = 0 NO EDIT +* = 1 NORMAL EDIT (DEFAULT) +* > 1 EDIT FOR DEBUG +*---- + ALLOCATE(ICOND(NGROUP)) + CALL PSPGET(IPRINT,ITYPE,ICOLR,NGROUP,NGT,ICOND) +*---- +* OPEN POSTSCRIPT OUTPUT FILE +* 1) IF THE FIRST DATA STRUCTURE IS IN UPDATE +* TEST IF IT IS A POSTSCRIPT FILE CREATED BY DRAGON +* AND PREPARE FILE FOR OUTPUT +*---- + CALL PSPFIL(ISPSP,JENTRY(1),HENTRY(1),NPAGE) +*---- +* SCAN OVER DATA STRUCTURES AND PROCESS STRUCTURE ONE AFTER THE OTHER +*---- + IF(ITYPE .EQ. 0 .OR. ITYPE .EQ. 1 .OR. ITYPE .EQ. 4) THEN + NUNKNO=1 + IF(ITYPE .EQ. 0) THEN + NAMLEG='Region' + ELSE IF(ITYPE .EQ. 1) THEN + NAMLEG='Mixture' + ELSE IF(ITYPE .EQ. 4) THEN + NAMLEG='HMIX' + ENDIF + ALLOCATE(FLUX(NUNKNO)) + FLUX=0.0 + DO 100 IENGT=2,NENTRY +*---- +* READ SIGNATURE OF NEXT DATA STRUCTURE AND TEST IF +* PSP CAN BE USED TO PROCESS THIS DATA STRUCTURE +*---- + IF(IENTRY(IENGT) .NE. 1 .AND. + > IENTRY(IENGT) .NE. 2 ) CALL XABORT(NAMSBR// + > ': NEXT DATA STRUCTURE NOT A LINKED LIST OR XSM FILE') + IF(JENTRY(IENGT) .NE. 2 ) CALL XABORT(NAMSBR// + > ': NEXT DATA STRUCTURE NOT IN READ-ONLY MODE') + IPGT=KENTRY(IENGT) + NAMGT=HENTRY(IENGT) + CALL LCMGTC(IPGT,'SIGNATURE',12,HSIGN) + ITRK=1 +*---- +* TEST IF GEOMETRY OR EXCELL TRACK DATA STRUCTURE +*---- + IF(HSIGN .EQ. 'L_GEOM ') THEN + ITRK=0 + NAMGEO=HENTRY(IENGT) + ELSE IF(HSIGN .EQ. 'L_TRACK ') THEN + CALL LCMGTC(IPGT,'TRACK-TYPE',12,HSIGN) + IF(HSIGN .NE. 'EXCELL') ITRK=-1 + ELSE + GO TO 115 + ENDIF +*---- +* FOR GEOMETRY OPTION CALL AXGGEO +* TO GENERATE TEMPORARY TRACKING STRUCTURE +*---- + IF(ITRK .EQ. 0) THEN + LASS=LDRASS(IPGT,IPRINT) + CALL LCMOP(IPTRK2,NAMTR2,IMODT2,IMEDT2,IPRIN2) + CALL AXGGEO(IPGT ,IPTRK2,IPRINT,NAMGEO) + IPGT=IPTRK2 + ENDIF +*---- +* CALL PSPTRK TO GENERATE POSTSCRIPT +*---- + CALL PSPTRK(IPRINT,ISPSP ,ITYPE ,ICOLR ,IPGT ,NAMGT , + > NAMLEG,NUNKNO,FLUX ) + IF(ITRK .EQ. 0) THEN + CALL LCMCL(IPTRK2,ICLST2) + ENDIF + CALL PSCUTP(ISPSP) + IF(IENGT .NE. NENTRY) THEN + NPAGE=NPAGE+1 + CALL PSPAGE(ISPSP,NPAGE,XYPOS) + ENDIF + 115 CONTINUE + 100 CONTINUE + DEALLOCATE(FLUX) + ELSE IF(ITYPE .EQ. 2 .OR. ITYPE .EQ. 3 .OR. + > ITYPE .EQ. 5 .OR. ITYPE .EQ. 6 ) THEN +*---- +* TEST SECOND DATA STRUCTURE +*---- + IENGT=2 + IF(IENTRY(IENGT) .NE. 1 .AND. + > IENTRY(IENGT) .NE. 2 ) CALL XABORT(NAMSBR// + > ': SECOND DATA STRUCTURE NOT A LINKED LIST OR XSM FILE') + IF(JENTRY(IENGT) .NE. 2 ) CALL XABORT(NAMSBR// + > ': SECOND DATA STRUCTURE NOT IN READ-ONLY MODE') + IPGT=KENTRY(IENGT) + NAMGT=HENTRY(IENGT) + CALL LCMGTC(IPGT,'SIGNATURE',12,HSIGN) + ITRK=1 +*---- +* TEST IF GEOMETRY OR EXCELL TRACK DATA STRUCTURE +*---- + IF(HSIGN .EQ. 'L_GEOM ') THEN + ITRK=0 + NAMGEO=HENTRY(IENGT) + ELSE IF(HSIGN .EQ. 'L_TRACK ') THEN + CALL LCMGTC(IPGT,'TRACK-TYPE',12,HSIGN) + IF(HSIGN .NE. 'EXCELL') ITRK=-1 + ENDIF +*---- +* TEST IF FLUX DATA STRUCTURE EXISTS +*---- + IF(IENFL .EQ. 0) CALL XABORT(NAMSBR// + > ': No flux data structure available') + ALLOCATE(FLUX(NUNKNO),TFLX(NUNKNO)) + IF(ITYPE .EQ. 5 .OR. ITYPE .EQ. 6) THEN + NMODE=ISTATE(4) + JPFL=LCMGID(IPFL,'MODE') + ELSE + NMODE=1 + JPFL=IPFL + ENDIF + DO IMODE=1,NMODE + IF(ITYPE .EQ. 5 .OR. ITYPE .EQ. 6) THEN + KPFL=LCMGIL(JPFL,IMODE) + ELSE + KPFL=JPFL + ENDIF + DO IGR=1,NGT +*---- +* Compute condensed flux +*---- + CALL PSPFCD(KPFL,NGROUP,NUNKNO,IGR,ICOND,FLUX,TFLX) +*---- +* FOR GEOMETRY OPTION CALL AXGGEO +* TO GENERATE TEMPORARY TRACKING STRUCTURE +*---- + IF(NGT .EQ. 1) THEN + WRITE(NAMLEG,'(A21)') 'Flux: fully condensed' + ELSE IF(NGT .EQ. NGROUP) THEN + WRITE(NAMLEG,'(A18,I5)') 'Flux: tran. group ',IGR + ELSE + WRITE(NAMLEG,'(A18,I5)') 'Flux: cond. group ',IGR + ENDIF + IF(ITRK .EQ. 0) THEN + CALL LCMOP(IPTRK2,NAMTR2,IMODT2,IMEDT2,IPRIN2) + CALL AXGGEO(IPGT ,IPTRK2,IPRINT,NAMGEO) + IPGT=IPTRK2 + ENDIF +*---- +* CALL PSPTRK TO GENERATE POSTSCRIPT +*---- + CALL PSPTRK(IPRINT,ISPSP ,ITYPE ,ICOLR ,IPGT ,NAMGT , + > NAMLEG,NUNKNO,FLUX ) + IF(ITRK .EQ. 0) THEN + CALL LCMCL(IPTRK2,ICLST2) + ENDIF + CALL PSCUTP(ISPSP) + IF(IGR .NE. NGT) THEN + NPAGE=NPAGE+1 + CALL PSPAGE(ISPSP,NPAGE,XYPOS) + ENDIF + ENDDO + ENDDO + DEALLOCATE(TFLX,FLUX) + ENDIF + WRITE(ISPSP,'(1X)') + DEALLOCATE(ICOND) + RETURN + END diff --git a/Dragon/src/PSPCOL.f b/Dragon/src/PSPCOL.f new file mode 100644 index 0000000..60bac8b --- /dev/null +++ b/Dragon/src/PSPCOL.f @@ -0,0 +1,156 @@ +*DECK PSPCOL + SUBROUTINE PSPCOL(ITCOL,NCOL,ICOL,RGB) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Pick a color number from a N-color set. +* +*Copyright: +* Copyright (C) 1999 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* ITCOL type of color set: +* = 1 gray; +* = 2 rgb; +* = 3 cmyk; +* = 4 hsb. +* NCOL maximum number of color in set. +* ICOL requested color number. +* +*Parameters: input +* RGB color intensity: +* for gray use only RGB(1); +* for rgb use only RGB(1),RGB(2),RGB(3); +* for cmyk use all; +* for hsb use only RGB(1),RGB(2),RGB(3). +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='PSPCOL') +*---- +* ROUTINE PARAMETERS +*---- + INTEGER ITCOL,NCOL,ICOL + REAL RGB(4) +*---- +* LOCAL PARAMETERS +*---- + INTEGER IDC,JCOL + REAL DELCOL,DELSAT,DELBLK +*---- +* LOCAL VARIABLES +*---- + IF(ITCOL .EQ. 4) THEN + RGB(4)=0.0 + IF(ICOL .LE. 0 ) THEN + RGB(1)=0.0 + RGB(2)=0.0 + RGB(3)=1.0 + ELSE + DELCOL=0.6667/FLOAT(NCOL-1) + DELSAT=0.5/FLOAT(NCOL-1) + DELBLK=0.5/FLOAT(NCOL-1) + JCOL=ICOL-1 + RGB(1)=0.6667-DELCOL*FLOAT(JCOL) + RGB(2)=0.5+DELSAT*FLOAT(JCOL) + RGB(3)=0.5+DELBLK*FLOAT(JCOL) + ENDIF + ELSE IF(ITCOL .EQ. 3) THEN + RGB(4)=0.0 + IF(ICOL .LE. 0 ) THEN + RGB(1)=0.0 + RGB(2)=0.0 + RGB(3)=0.0 + ELSE + IF (NCOL .LE. 8) THEN + IDC=2 + ELSE IF(NCOL .LE. 64) THEN + IDC=4 + ELSE IF(NCOL .LE. 512) THEN + IDC=8 + ELSE IF(NCOL .LE. 4096) THEN + IDC=16 + ELSE IF(NCOL .LE. 32768) THEN + IDC=32 + ELSE IF(NCOL .LE. 262144) THEN + IDC=64 + ELSE + IDC=128 + ENDIF + JCOL=ICOL-1 + DELCOL=1.0/FLOAT(IDC) + RGB(1)=1.0-DELCOL*FLOAT(MOD(JCOL,IDC)) + JCOL=JCOL/IDC + RGB(2)=1.0-DELCOL*FLOAT(MOD(JCOL,IDC)) + JCOL=JCOL/IDC + RGB(3)=1.0-DELCOL*FLOAT(MOD(JCOL,IDC)) + ENDIF + ELSE IF(ITCOL .EQ. 2) THEN + RGB(4)=0.0 + IF(ICOL .LE. 0 ) THEN + RGB(1)=1.0 + RGB(2)=1.0 + RGB(3)=1.0 + ELSE + IF (NCOL .LE. 8) THEN + IDC=2 + ELSE IF(NCOL .LE. 64) THEN + IDC=4 + ELSE IF(NCOL .LE. 512) THEN + IDC=8 + ELSE IF(NCOL .LE. 4096) THEN + IDC=16 + ELSE IF(NCOL .LE. 32768) THEN + IDC=32 + ELSE IF(NCOL .LE. 262144) THEN + IDC=64 + ELSE + IDC=128 + ENDIF + JCOL=ICOL-1 + DELCOL=1.0/FLOAT(IDC) + RGB(1)=1.0-DELCOL*FLOAT(MOD(JCOL,IDC)+1) + JCOL=JCOL/IDC + RGB(2)=1.0-DELCOL*FLOAT(MOD(JCOL,IDC)+1) + JCOL=JCOL/IDC + RGB(3)=1.0-DELCOL*FLOAT(MOD(JCOL,IDC)+1) + ENDIF + ELSE + IF(ICOL .LE. 0 ) THEN + RGB(1)=0.0 + RGB(2)=0.0 + RGB(3)=0.0 + ELSE + IF (NCOL .LE. 8) THEN + IDC=8 + ELSE IF(NCOL .LE. 64) THEN + IDC=64 + ELSE IF(NCOL .LE. 512) THEN + IDC=512 + ELSE IF(NCOL .LE. 4096) THEN + IDC=4096 + ELSE IF(NCOL .LE. 32768) THEN + IDC=32768 + ELSE + IDC=262144 + ENDIF + JCOL=ICOL-1 + DELCOL=1.0/FLOAT(IDC) + RGB(1)=1.0-DELCOL*FLOAT(MOD(JCOL,IDC)) + RGB(2)=RGB(1) + RGB(3)=RGB(1) + ENDIF + ENDIF + RETURN + END diff --git a/Dragon/src/PSPFCD.f b/Dragon/src/PSPFCD.f new file mode 100644 index 0000000..bfcf494 --- /dev/null +++ b/Dragon/src/PSPFCD.f @@ -0,0 +1,69 @@ +*DECK PSPFCD + SUBROUTINE PSPFCD(IPFL,NGROUP,NUNKNO,IGR,ICOND, + > FLUXC,FLUXR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To condense flux for PSP. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPFL pointer to the FLUX data structure. +* NGROUP number of groups. +* NUNKNO number of flux unknowns. +* IGR condensed group number. +* ICOND group limit for condensed group. +* +*Parameters: output +* FLUXC condensed flux. +* FLUXR multigroup flux read. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='PSPFCD') +*---- +* ROUTINE PARAMETERS +*---- + TYPE(C_PTR) IPFL + INTEGER NGROUP,NUNKNO,IGR + INTEGER ICOND(NGROUP) + REAL FLUXC(NUNKNO),FLUXR(NUNKNO) +*---- +* LOCAL PARAMETERS +*---- + TYPE(C_PTR) JPFL + INTEGER IGC,IGD,IGF,IUN +* + FLUXC(:NUNKNO)=0.0 + IGF=ICOND(IGR) + IF(IGR .EQ. 1) THEN + IGD=1 + ELSE + IGD=ICOND(IGR-1)+1 + ENDIF + JPFL=LCMGID(IPFL,'FLUX') + DO IGC=IGD,IGF + CALL LCMGDL(JPFL,IGC,FLUXR) + DO IUN=1,NUNKNO + FLUXC(IUN)=FLUXC(IUN)+FLUXR(IUN) + ENDDO + ENDDO +*---- +* RETURN +*---- + RETURN + END diff --git a/Dragon/src/PSPFIL.f b/Dragon/src/PSPFIL.f new file mode 100644 index 0000000..0938b0b --- /dev/null +++ b/Dragon/src/PSPFIL.f @@ -0,0 +1,89 @@ +*DECK PSPFIL + SUBROUTINE PSPFIL(ISPSP,JSPSP,NAMPSP,NPAGE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* PSP file analysis. +* +*Copyright: +* Copyright (C) 1999 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input/output +* ISPSP PSP file unit. +* JSPSP PSP file mode: +* = 0 new; +* = 1 update. +* NAMPSP PSP file name. +* NPAGE page number. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE + INTEGER IOUT + CHARACTER NAMSBR*6,PROGNM*6 + PARAMETER (IOUT=6,NAMSBR='PSPFIL',PROGNM='DRAGON') +*---- +* ROUTINE PARAMETERS +*---- + INTEGER JSPSP,ISPSP,NPAGE + CHARACTER NAMPSP*12 +*---- +* LOCAL VARIABLES +*---- + INTEGER IRL,IDR,ILINE,IPF,IPN + CHARACTER CMDSTR*132,CFMT*16 + REAL XYPOS(2) + NPAGE=0 + IF(JSPSP .EQ. 1) THEN +*---- +* TEST IF ADEQUATE DRAGON PS FILE TYPE +*---- + DO 100 IRL=1,3 + READ(ISPSP,'(A132)') CMDSTR + 100 CONTINUE + READ(ISPSP,'(A132)') CMDSTR + IDR=INDEX(CMDSTR,PROGNM) + IF(IDR .EQ. 0) CALL XABORT(NAMSBR// + > ': NOT A DRAGON GENERATED POSTSCRIPT FILE') + ILINE=0 + IPF=1 +*---- +* LOCATE LAST PAGE NUMBER +*---- + 110 CONTINUE + READ(ISPSP,'(A132)',END=115) CMDSTR + IPN=INDEX(CMDSTR,'%%Page') + IF(IPN .NE. 0) THEN + IPN=INDEX(CMDSTR,' ') + IPF=INDEX(CMDSTR(IPN+1:132),' ')-1 + CFMT=' ' + WRITE(CFMT,'(2H(I,I1,1H))') IPF + READ(CMDSTR(IPN+1:IPN+IPF),CFMT) NPAGE + ENDIF + GO TO 110 + 115 CONTINUE + BACKSPACE ISPSP +*---- +* SET NEXT PAGE NUMBER AND PREPARE FOR OUTPUT +*---- + NPAGE=NPAGE+1 + XYPOS(1)=0.5 + XYPOS(2)=0.5 + CALL PSPAGE(ISPSP,NPAGE,XYPOS) + ELSE + CALL PSHEAD(ISPSP,NAMPSP,PROGNM) + NPAGE=NPAGE+1 + XYPOS(1)=0.5 + XYPOS(2)=0.5 + CALL PSPAGE(ISPSP,NPAGE,XYPOS) + ENDIF + RETURN + END diff --git a/Dragon/src/PSPGET.f b/Dragon/src/PSPGET.f new file mode 100644 index 0000000..17d417e --- /dev/null +++ b/Dragon/src/PSPGET.f @@ -0,0 +1,237 @@ +*DECK PSPGET + SUBROUTINE PSPGET(IPRINT,ITYPE,ICOLR,NGROUP,NGT,ICOND) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read PSP: module input data. +* +*Copyright: +* Copyright (C) 1999 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPRINT print level. +* ITYPE type of graphic: +* =0 color per region number; +* =1 color per material; +* =2 color for flux (one group); +* =3 color for flux (multigroup); +* =4 color per material for homogenizatION (HMIX); +* =5 color for mode (one group); +* =6 color for mode (multigroup). +* ICOLR color set used: +* = -4 fill hsb with no-contour; +* = -3 fill cmyk with no-contour; +* = -2 fill rgb with no-contour; +* = -1 fill bw with no-contour; +* = 0 no fill contour only; +* = 1 fill bw and contour; +* = 2 fill rgb and contour; +* = 3 fill cmyk and contour; +* = 4 fill hsb and contour. +* NGROUP number of groups for flux. +* NGT number of condensed groups for flux. +* ICOND upper group condensation limit. +* +*Comments: +* Input instructions: +* [ EDIT iprint ] +* [ FILL { NONE | GRAY | RGB | CMYK | HSB } [ NOCONTOUR ] ] +* [ TYPE { REGION | MIXTURE | FLUX | HMIX | +* MGFLUX (icond(i),i=1,ngt) } ] ; +* DEFAULT: +* IPRINT = 1 -> EDIT 1 +* ITYPE = 0 -> PER REGION NUMBER +* ICOLR = 4 -> FILL HSB WITH CONTOUR +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='PSPGET') +*---- +* ROUTINE PARAMETERS +*---- + INTEGER IPRINT,ITYPE,ICOLR,NGROUP,NGT + INTEGER ICOND(NGROUP) +*---- +* REDGET INPUT VARIABLES +*---- + INTEGER ITYPLU,INTLIR + CHARACTER CARLIR*12 + REAL REALIR + DOUBLE PRECISION DBLLIR +*---- +* LOCAL PARAMETERS +*---- + INTEGER ICOL,ITY,ICONT,IGT +*---- +* READ OPTIONS +*---- + IPRINT=1 + ICOL=4 + ITY=0 + ICONT=1 + 100 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + 101 CONTINUE + IF(ITYPLU .EQ. 10) THEN + GO TO 105 + ELSE IF(ITYPLU .NE. 3) THEN + CALL XABORT(NAMSBR//': ERROR -> CHARACTER VARIABLE EXPECTED') + ENDIF + IF(CARLIR(1:1) .EQ. ';' ) THEN + GO TO 105 + ELSE IF(CARLIR .EQ. 'EDIT' ) THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1 ) GO TO 101 + IPRINT=INTLIR + ELSE IF(CARLIR(1:4) .EQ. 'FILL' ) THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 3 ) GO TO 101 + IF(CARLIR .EQ. 'NONE') THEN + ICOL=0 + ELSE IF(CARLIR .EQ. 'GRAY') THEN + ICOL=1 + ELSE IF(CARLIR .EQ. 'RGB') THEN + ICOL=2 + ELSE IF(CARLIR .EQ. 'CMYK') THEN + ICOL=3 + ELSE IF(CARLIR .EQ. 'HSB') THEN + ICOL=4 + ELSE + CALL XABORT(NAMSBR//': ILEGAL FILL KEYWORD '//CARLIR// + > 'KEYWORD EXPECTED: NONE, GRAY, RGB, CMYK, HSB') + ENDIF + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 3 ) GO TO 101 + IF(CARLIR(1:4) .EQ. 'NOCO') THEN + ICONT=0 + ELSE + GO TO 101 + ENDIF + ELSE IF(CARLIR(1:4) .EQ. 'TYPE' ) THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(CARLIR(1:4) .EQ. 'REGI') THEN + ITY=0 + ELSE IF(CARLIR(1:4) .EQ. 'MIXT') THEN + ITY=1 + ELSE IF(CARLIR(1:4) .EQ. 'FLUX') THEN + ITY=2 + NGT=1 + ICOND(NGT)=NGROUP + ELSE IF(CARLIR(1:4) .EQ. 'MODE') THEN + ITY=5 + NGT=1 + ICOND(NGT)=NGROUP + ELSE IF(CARLIR(1:4) .EQ. 'MGFL') THEN + ITY=3 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) THEN + NGT=NGROUP + DO IGT=1,NGT + ICOND(IGT)=IGT + ENDDO + GO TO 101 + ENDIF + NGT=0 + DO IGT=1,NGROUP + NGT=NGT+1 + IF(INTLIR .LT. 1 .OR. INTLIR .GT. NGROUP) + >CALL XABORT(NAMSBR//': illegal group condensation number') + IF(IGT .GT. 1) THEN + IF(INTLIR .LE. ICOND(IGT-1)) + >CALL XABORT(NAMSBR//': group numbers must be increasing') + ENDIF + ICOND(IGT)=INTLIR + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1 ) THEN + IF(ICOND(IGT) .NE. NGROUP) THEN + NGT=NGT+1 + ICOND(NGT)=NGROUP + ENDIF + GO TO 101 + ENDIF + ENDDO + ELSE IF(CARLIR(1:4) .EQ. 'MGMD') THEN + ITY=6 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) THEN + NGT=NGROUP + DO IGT=1,NGT + ICOND(IGT)=IGT + ENDDO + GO TO 101 + ENDIF + NGT=0 + DO IGT=1,NGROUP + NGT=NGT+1 + IF(INTLIR .LT. 1 .OR. INTLIR .GT. NGROUP) + >CALL XABORT(NAMSBR//': illegal group condensation number') + IF(IGT .GT. 1) THEN + IF(INTLIR .LE. ICOND(IGT-1)) + >CALL XABORT(NAMSBR//': group numbers must be increasing') + ENDIF + ICOND(IGT)=INTLIR + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1 ) THEN + IF(ICOND(IGT) .NE. NGROUP) THEN + NGT=NGT+1 + ICOND(NGT)=NGROUP + ENDIF + GO TO 101 + ENDIF + ENDDO + ELSE IF(CARLIR(1:4) .EQ. 'HMIX') THEN + ITY=4 + ELSE + CALL XABORT(NAMSBR//': ILEGAL TYPE KEYWORD '//CARLIR// + > 'KEYWORD EXPECTED: REGION, MIXTURE, FLUX, MGFLUX') + ENDIF + ELSE +*---- +* INVALID OPTION +*---- + CALL XABORT(NAMSBR//': ILEGAL MAIN KEYWORD '//CARLIR// + > 'KEYWORD EXPECTED: FILL, TYPE, EDIT OR ; ') + ENDIF + GO TO 100 + 105 CONTINUE +*---- +* TEST READ OPTIONS +* IF FILL = NONE (ICOL = 0) IMPOSE CONTOUR +*---- + IF(ICONT .EQ. 0) THEN + ICOLR=-ICOL + ELSE + ICOLR=ICOL + ENDIF + ITYPE=ITY +*---- +* PRINT ECHO OF PSP OPTIONS THAT WILL BE USED +*---- + IF(IPRINT .GE. 1 ) THEN + WRITE(IOUT,6000) IPRINT,ICOL,ITY,ICONT + ENDIF +*---- +* RETURN +*---- + RETURN +*---- +* FORMAT +*---- + 6000 FORMAT(' ------ PSP EXECUTION OPTIONS --------'/ + > ' PRINT LEVEL = ',I8 / + > ' COLOR = ',I8 / + > ' TYPE = ',I8 / + > ' CONTOUR = ',I8 / + > ' --------------------------------------') + END diff --git a/Dragon/src/PSPLEG.f b/Dragon/src/PSPLEG.f new file mode 100644 index 0000000..f445106 --- /dev/null +++ b/Dragon/src/PSPLEG.f @@ -0,0 +1,311 @@ +*DECK PSPLEG + SUBROUTINE PSPLEG(IPRINT,ISPSP ,ITYPE ,ICOLR ,NSUR ,NVOL , + > NAMLEG,NUNKNO,FLUX ,NREGT , + > MATALB,KEYMRG,KEYFLX,COLREG) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Associate a color to a region and print legend. +* +*Copyright: +* Copyright (C) 1999 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPRINT print level. +* ISPSP PSP file unit. +* ITYPE type of graphic: +* = 0 color per region number; +* = 1 color per material; +* = 2 color for flux (one group); +* = 3 color for flux (multigroup); +* = 4 color per material for homogenization (HMIX). +* ICOLR color set used: +* = -4 fill hsb with no-contour; +* = -3 fill cmyk with no-contour; +* = -2 fill rgb with no-contour; +* = -1 fill bw with no-contour; +* = 0 no fill contour only; +* = 1 fill bw and contour; +* = 2 fill rgb and contour; +* = 3 fill cmyk and contour; +* = 4 fill hsb and contour. +* NSUR number of outer surface. +* NVOL maximum number of regions. +* NAMLEG legend name. +* NUNKNO number of unknowns. +* FLUX unknown vector. +* NREGT dimension of KEYFLX vector. +* MATALB albedo-material of regions. +* KEYMRG merge index. +* KEYFLX flux location. +* COLREG region color. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE + INTEGER IOUT + CHARACTER NAMSBR*6 + REAL WLINE + PARAMETER (IOUT=6,WLINE=0.002,NAMSBR='PSPLEG') +*---- +* ROUTINE PARAMETERS +*---- + INTEGER IPRINT,ISPSP,ITYPE,ICOLR,NSUR,NVOL, + > NUNKNO,NREGT + INTEGER MATALB(NSUR:NVOL),KEYMRG(NSUR:NVOL), + > KEYFLX(NVOL) + REAL FLUX(NUNKNO),COLREG(4,NVOL) + REAL COLTMP(4) + CHARACTER NAMLEG*24 +*---- +* LOCAL PARAMETERS +*---- + CHARACTER COLNAM*4,LEGTXT*48,FLXTXT*80 + INTEGER MXMIX,MREG,IVOL,IMX,IRG,ICOLA, + > ILEG,IFRM,MXCOL,ICOLF,IKEY + INTEGER KMX,ICT + REAL XYPOS(2),POSL,POSB,DELX,DELY,DELXC,DELYC, + > XYPTS(2,4),FLXMIN,FLXMAX,DELFLX,COLFLX(4) + INTEGER KFS,KFR,KSS,KSR +*---- +* INITIALIZE LEGEND +*---- + KFS=0 + KFR=0 + KSS=0 + KSR=0 + ICOLA=ABS(ICOLR) + IF(ICOLA .GT. 0) THEN + KFS=1 + KSR=1 + ENDIF + IF(ICOLA .GE. 2) THEN + LEGTXT='Color by '//NAMLEG + ELSE + LEGTXT='Graylevel by '//NAMLEG + ENDIF + ILEG=1 + IF(IPRINT .LE. 0) THEN + ILEG=0 + ENDIF +*---- +* GENERATE RANDOM COLOR +* FOR RGB USE ALL THREE COLORS +* FOR BW USE ONLY FIRST COLOR +* SKIP FOR NONE +*---- + IF(ICOLA .GT. 0) THEN + POSL=0.0 + POSB=10.0 + XYPOS(1)=POSL + XYPOS(2)=POSB + IF(ILEG .EQ. 1) THEN + CALL PSTEXT(ISPSP,6,'Legend', + > XYPOS,0.1,0,0.0) + ENDIF + IF(ITYPE .EQ. 0) THEN +*---- +* COMPUTE NUMBER OF REGIONS AFTER MERGE +*---- + MREG=0 + DO 100 IVOL=1,NVOL + MREG=MAX(MREG,KEYMRG(IVOL)) + 100 CONTINUE +*---- +* GENERATE ONE COLOR PER REGION +*---- + POSB=POSB-0.2 + XYPOS(2)=POSB + IF(ILEG .EQ. 1) THEN + CALL PSTEXT(ISPSP,48,LEGTXT,XYPOS,0.1,0,0.0) + ENDIF + POSB=POSB-0.2 + IF(MREG .GT. 10000) THEN + ILEG=0 + ENDIF + DELX=0.2 + DELY=DELX/2.0 + DELXC=DELY + DELYC=DELXC/4.0 + DO 110 IRG=1,MREG + IFRM=0 + IF(MOD(IRG-1,30) .EQ. 0 .AND. ILEG .EQ. 1) THEN + POSB=POSB-DELY + ENDIF + DO 111 IVOL=1,NVOL + IF(KEYMRG(IVOL) .EQ. IRG) THEN + CALL PSPCOL(ICOLA,MREG,IRG,COLREG(1,IVOL)) + IF(IFRM .EQ. 0 .AND. ILEG .EQ.1) THEN + IFRM=IFRM+1 + POSL=MOD(IRG-1,30)*DELX + XYPTS(1,1)=POSL + XYPTS(2,1)=POSB + XYPTS(1,2)=POSL+DELX + XYPTS(2,2)=POSB + XYPTS(1,3)=POSL+DELX + XYPTS(2,3)=POSB+DELY + XYPTS(1,4)=POSL + XYPTS(2,4)=POSB+DELY + CALL PSDREG(ISPSP,4,XYPTS) + IF(ICOLA .GT. 0) THEN + CALL PSFILL(ISPSP,ICOLA,COLREG(1,IVOL),KFS,KFR) + ENDIF + CALL PSSTRK(ISPSP,WLINE,KSS,KSR) + WRITE(COLNAM,'(I4)') IRG + XYPOS(1)=POSL+DELXC + XYPOS(2)=POSB+DELYC + CALL PSTEXT(ISPSP,4,COLNAM,XYPOS,0.05,1,0.0) + ENDIF + ENDIF + 111 CONTINUE + 110 CONTINUE + ELSE IF(ITYPE .EQ. 1 .OR. ITYPE .EQ. 4) THEN +*---- +* COMPUTE NUMBER OF MIXTURES +*---- + MXMIX=0 + DO 120 IVOL=1,NVOL + MXMIX=MAX(MXMIX,MATALB(IVOL)) + 120 CONTINUE + POSB=POSB-0.2 + XYPOS(2)=POSB + IF(ILEG .EQ. 1) THEN + CALL PSTEXT(ISPSP,32,LEGTXT,XYPOS,0.1,0,0.0) + ENDIF + POSB=POSB-0.2 + IF(MXMIX .GT. 10000) THEN + ILEG=0 + ENDIF + KMX=0 + DELX=0.2 + DELY=DELX/2.0 + DELXC=DELY + DELYC=DELXC/4.0 +*---- +* GENERATE ONE COLOR PER MIXTURE +*---- + DO 130 IMX=0,MXMIX + KMX=KMX+1 + IFRM=0 + IF(MOD(KMX-1,30).EQ.0 .AND. ILEG .EQ. 1) THEN + POSB=POSB-DELY + ENDIF + CALL PSPCOL(ICOLA,MXMIX,IMX,COLTMP(1)) + IF (ILEG.EQ.1) THEN + POSL=MOD(KMX-1,30)*DELX + XYPTS(1,1)=POSL + XYPTS(2,1)=POSB + XYPTS(1,2)=POSL+DELX + XYPTS(2,2)=POSB + XYPTS(1,3)=POSL+DELX + XYPTS(2,3)=POSB+DELY + XYPTS(1,4)=POSL + XYPTS(2,4)=POSB+DELY + CALL PSDREG(ISPSP,4,XYPTS) + IF(ICOLA .GT. 0) THEN + CALL PSFILL(ISPSP,ICOLA,COLTMP(1),KFS,KFR) + ENDIF + CALL PSSTRK(ISPSP,WLINE,KSS,KSR) + WRITE(COLNAM,'(I4)') IMX + XYPOS(1)=POSL+DELXC + XYPOS(2)=POSB+DELYC + CALL PSTEXT(ISPSP,4,COLNAM,XYPOS,0.05,1,0.0) + ENDIF +*---- +* ASSOCIATE MIXTURE COLOR WITH REGION +*---- + DO 131 IVOL=1,NVOL + IF(MATALB(IVOL) .EQ. IMX) THEN + DO 132 ICT=1,4 + COLREG(ICT,IVOL)=COLTMP(ICT) + 132 CONTINUE + ENDIF + 131 CONTINUE + 130 CONTINUE + ELSE IF(ITYPE .EQ. 2 .OR. ITYPE .EQ. 3 .OR. + > ITYPE .EQ. 5 .OR. ITYPE .EQ. 6) THEN +*---- +* COMPUTE NUMBER OF REGIONS AFTER MERGE +*---- + POSB=POSB-0.2 + XYPOS(2)=POSB + IF(ILEG .EQ. 1) THEN + CALL PSTEXT(ISPSP,32,LEGTXT,XYPOS,0.1,0,0.0) + ENDIF + POSB=POSB-0.2 +*---- +* FIND MAXIMUM AND MINIMUM FLUX +*---- + FLXMAX=FLUX(KEYFLX(1)) + FLXMIN=FLUX(KEYFLX(1)) + DO 150 IRG=2,NREGT + IKEY=KEYFLX(IRG) + FLXMAX=MAX(FLXMAX,FLUX(IKEY)) + FLXMIN=MIN(FLXMIN,FLUX(IKEY)) + 150 CONTINUE + MXCOL=20 + DELFLX=(FLXMAX-FLXMIN)/REAL(MXCOL) + WRITE(FLXTXT,5000) FLXMIN,DELFLX,FLXMIN,DELFLX + XYPOS(2)=POSB + IF(ILEG .EQ. 1) THEN + CALL PSTEXT(ISPSP,80,FLXTXT,XYPOS,0.1,0,0.0) + ENDIF + POSB=POSB-0.2 + DELX=0.2 + DELY=DELX/2.0 + DELXC=DELY + DELYC=DELXC/4.0 +*---- +* GENERATE ONE COLOR PER FLUX LEVEL +* COLOR I IS GIVEN BY: +* I=MIN(INT((FLUX-FLXMIN)/DELFLX)+1,MXCOL) +*---- + POSB=POSB-DELY + DO 160 ICOLF=1,MXCOL + CALL PSPCOL(ICOLA,MXCOL,ICOLF,COLFLX(1)) + POSL=MOD(ICOLF-1,30)*DELX + XYPTS(1,1)=POSL + XYPTS(2,1)=POSB + XYPTS(1,2)=POSL+DELX + XYPTS(2,2)=POSB + XYPTS(1,3)=POSL+DELX + XYPTS(2,3)=POSB+DELY + XYPTS(1,4)=POSL + XYPTS(2,4)=POSB+DELY + CALL PSDREG(ISPSP,4,XYPTS) + IF(ICOLA .GT. 0) THEN + CALL PSFILL(ISPSP,ICOLA,COLFLX(1),KFS,KFR) + ENDIF + CALL PSSTRK(ISPSP,WLINE,KSS,KSR) + WRITE(COLNAM,'(I4)') ICOLF + XYPOS(1)=POSL+DELXC + XYPOS(2)=POSB+DELYC + CALL PSTEXT(ISPSP,4,COLNAM,XYPOS,0.05,1,0.0) + 160 CONTINUE + DO 170 IRG=1,NREGT + IKEY=KEYFLX(IRG) + ICOLF=INT((FLUX(IKEY)-FLXMIN)/DELFLX)+1 + ICOLF=MIN(ICOLF,MXCOL) + DO 171 IVOL=1,NVOL + IF(KEYMRG(IVOL) .EQ. IRG) THEN + CALL PSPCOL(ICOLA,MXCOL,ICOLF,COLREG(1,IVOL)) + ENDIF + 171 CONTINUE + 170 CONTINUE + ENDIF + ENDIF + RETURN +*---- +* FORMAT +*---- + 5000 FORMAT(1P,E9.2,'+(i-1)*',E9.2, + > ' < Flux(i) <= ',E9.2,'+i*',E9.2) + END diff --git a/Dragon/src/PSPMCP.f b/Dragon/src/PSPMCP.f new file mode 100644 index 0000000..16c2df3 --- /dev/null +++ b/Dragon/src/PSPMCP.f @@ -0,0 +1,139 @@ +*DECK PSPMCP + SUBROUTINE PSPMCP(ISPSP,OFFC,FACT,N,COORD,REGI,EVENT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Add MC: neutron paths to the graphics of a 2-D NXT geometry. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* ISPSP pointer to the POSTSCRIPT file. +* OFFC offset vector. +* FACT scaling factor. +* N number of points. +* COORD points coordinates. +* REGI regions indexes. +* EVENT event indexes. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ISPSP,N,REGI(N),EVENT(N) + DOUBLE PRECISION COORD(3,N),OFFC(2),FACT +*---- +* LOCAL VARIABLES +*---- + REAL WLINE,HTEX,HCRO + PARAMETER(WLINE=0.002,HTEX=0.11,HCRO=0.03) + INTEGER I,IDIR,NCHAR,IREG + REAL POS(2),POSO(2),SEG(2,2),CENTER(2),RADANG(2,2) + CHARACTER TEXT*5,FORM*4 + LOGICAL START + INTEGER IORDER(2) + DATA IORDER /-2,-1 / +* + START=.TRUE. + DO I=1,N +* CALCULATE POSITION IN GRAPHICS COORDINATES + POS(1)=REAL(FACT*(COORD(1,I)-OFFC(1))) + POS(2)=REAL(FACT*(COORD(2,I)-OFFC(2))) + IF (START) THEN +* STARTING POINT: DRAW A CIRCLE + CALL PSMOVE(ISPSP,POS,-3) + RADANG(1,1)=HCRO + RADANG(2,1)=0.0 + RADANG(1,2)=HCRO + RADANG(2,2)=6.30 + CALL PSDRAI(ISPSP,2,IORDER,POS,RADANG) + CALL PSSTRK(ISPSP,WLINE,0,0) + CENTER(1)=-POS(1) + CENTER(2)=-POS(2) + CALL PSMOVE(ISPSP,CENTER,-3) + ELSE +* DRAW A SEGMENT FROM PREVIOUS POINT TO THIS ONE + DO IDIR=1,2 + SEG(IDIR,1)=POSO(IDIR) + SEG(IDIR,2)=POS(IDIR) + ENDDO + CALL PSDREG(ISPSP,2,SEG) + CALL PSSTRK(ISPSP,WLINE,0,0) + ENDIF + IF (REGI(I).GT.0) THEN + IREG=REGI(I) + START=.FALSE. + ELSE + IREG=-REGI(I) +* ENDING POINT: DRAW A CROSS + DO IDIR=1,2 + SEG(IDIR,1)=POS(IDIR)-HCRO + SEG(IDIR,2)=POS(IDIR)+HCRO + ENDDO + CALL PSDREG(ISPSP,2,SEG) + CALL PSSTRK(ISPSP,WLINE,0,0) + SEG(1,1)=SEG(1,1)+2.0*HCRO + SEG(1,2)=SEG(1,2)-2.0*HCRO + CALL PSDREG(ISPSP,2,SEG) + CALL PSSTRK(ISPSP,WLINE,0,0) + START=.TRUE. + ENDIF +* SAVE PREVIOUS POSITION + POSO(1)=POS(1) + POSO(2)=POS(2) +* INDICATE REGION/SURFACE INDEX + NCHAR=1 + IF ((IREG.GE.10.).AND.(IREG.LT.100)) THEN + NCHAR=2 + ELSEIF ((IREG.GE.100.).AND.(IREG.LT.1000)) THEN + NCHAR=3 + ELSEIF ((IREG.GE.1000.).AND.(IREG.LT.10000)) THEN + NCHAR=4 + ELSEIF ((IREG.GE.10000.).AND.(IREG.LT.100000)) THEN + NCHAR=5 + ENDIF +* WHICH EVENT TOOK PLACE? + IF (EVENT(I).LT.0) THEN +* ENCOUNTERING A SURFACE: indicated by a minus in front of the +* region index + NCHAR=NCHAR+1 + IREG=-IREG + IF (EVENT(I).EQ.-1) THEN +* X- surface + POS(1)=POS(1)-0.5*NCHAR*HTEX + POS(2)=POS(2)-0.5*HTEX + ELSEIF (EVENT(I).EQ.-2) THEN +* X+ surface + POS(1)=POS(1)+0.5*NCHAR*HTEX + POS(2)=POS(2)-0.5*HTEX + ELSEIF (EVENT(I).EQ.-3) THEN +* Y- surface + POS(2)=POS(2)-1.2*HTEX + ELSEIF (EVENT(I).EQ.-4) THEN +* Y+ surface + POS(2)=POS(2)+0.2*HTEX + ENDIF + ELSE +* INTERACTION IN REGION +* +* etc ... +* + POS(2)=POS(2)+0.2*HTEX + ENDIF + WRITE(FORM,'(1H(,A1,I1,1H))') 'I',NCHAR + WRITE(TEXT,FORM) IREG + CALL PSTEXT(ISPSP,NCHAR,TEXT(1:NCHAR),POS,HTEX,1,0) + ENDDO +* + RETURN + END diff --git a/Dragon/src/PSPNXT.f b/Dragon/src/PSPNXT.f new file mode 100644 index 0000000..5b940f5 --- /dev/null +++ b/Dragon/src/PSPNXT.f @@ -0,0 +1,276 @@ +*DECK PSPNXT + SUBROUTINE PSPNXT(IPRINT,ISPSP ,ICOLR ,IPTRK ,ITYPBC,MAXMSH, + > NDIM ,NFSUR ,NFREG ,NUCELL,NBUCEL, + > MXGREG,MAXPIN,COLREG,IUNFLD,MATALB,DGMESH) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To generate the graphics for a 2-D NXT geometry. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal. +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPRINT print level. +* ISPSP pointer to the POSTSCRIPT file. +* ICOLR color set used where: +* =-4 HSB filling with no contour; +* =-3 CYMK filling with no contour; +* =-2 RGB filling with no contour; +* =-1 BW filling with no contour; +* = 0 no filling with contour; +* = 1 BW filling with contour; +* = 2 RGB filling with contour; +* = 3 CMYK filling with contour; +* = 4 HSB filling with contour. +* IPTRK pointer to the TRACKING data structure in +* update or creation mode. +* ITYPBC type of cell boundary. +* MAXMSH maximum number of elements in MESH array. +* NDIM dimension of the problem. +* NFSUR number of surfaces. +* NFREG number of regions. +* NUCELL number of cell after unfolding in +* $X$, $Y$ and $Z$ directions. +* NBUCEL number of cells in unfolded geometry. +* MXGREG maximum number of region for any geometry. +* MAXPIN maximum number of pins in a cell. +* COLREG region color. +* IUNFLD description of unfolded geometry. +* MATALB global mixture/albedo identification vector. +* DGMESH meshing vector for global geometry. +* +*---------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPTRK + INTEGER IPRINT,ISPSP,ICOLR,ITYPBC,MAXMSH, + > NDIM,NFSUR,NFREG,NUCELL(3),NBUCEL, + > MXGREG,MAXPIN + REAL COLREG(4,NFREG) + INTEGER IUNFLD(2,NBUCEL), + > MATALB(-NFSUR:NFREG) + DOUBLE PRECISION DGMESH(0:MAXMSH,4) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='PSPNXT') + DOUBLE PRECISION DZERO,DONE,DTWO + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) + DOUBLE PRECISION DIMX,DIMY + PARAMETER (DIMX=3.5D0,DIMY=3.5D0) +*---- +* Local variables +*---- + INTEGER KPSP(7) + CHARACTER NAMREC*12 + INTEGER IDIR,ILPD,IX,IY,ICELL,ICEL,ITRN,ILONG,ITYLCM + DOUBLE PRECISION RCIRC,ABSC(2),OFFC(2),FACT,CELLPO(2,2) + REAL XYPOS(2,4) + DOUBLE PRECISION SIDEH,CENTH,DHMAX +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDREG,ITPIN,NBPTS,REGI,EVENT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DCMESH,DRAPIN, + > POSTRI,COOR +*---- +* Data +*---- + CHARACTER CDIR(4)*1 + SAVE CDIR + DATA CDIR /'X','Y','Z','R'/ +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF +*---- +* Initialize ICOL for color treatment +* and ICONT for contour +* KPSP(1)=ICONT +* KPSP(2)=ICOL +* KPSP(3)=IWLFAC (0->1.0,1->2.5) +* KPSP(4)=KFS +* KPSP(5)=KFR +* KPSP(6)=KSS +* KPSP(7)=KSR +*----- + ILPD=MATALB(0) + KPSP(1)=1 + KPSP(2)=ABS(ICOLR) + KPSP(3)=0 + KPSP(4)=0 + KPSP(5)=0 + KPSP(6)=0 + KPSP(7)=0 + IF(ICOLR .EQ. 0) THEN + KPSP(3)=1 + ELSE IF(ICOLR .LT. 0) THEN + KPSP(1)=0 + ELSE + KPSP(4)=1 + KPSP(7)=1 + ENDIF + RCIRC=1.0D0 +*---- +* Read global mesh for geometry +* and determine graphics size +*---- + IF(ITYPBC .EQ. 0) THEN +*---- +* Cartesian +*---- + DO IDIR=1,NDIM + NAMREC='G00000001SM'//CDIR(IDIR) + ILPD=NUCELL(IDIR) + CALL LCMGET(IPTRK,NAMREC,DGMESH(0,IDIR)) + ABSC(IDIR)=0.5D0*(DGMESH(ILPD,IDIR)-DGMESH(0,IDIR)) + OFFC(IDIR)=0.5D0*(DGMESH(ILPD,IDIR)+DGMESH(0,IDIR)) + ENDDO + RCIRC=DZERO + DO IDIR=1,NDIM + RCIRC=MAX(RCIRC,ABSC(IDIR)) + ENDDO + ELSE IF(ITYPBC .EQ. 1) THEN +*---- +* Annular +*---- + DO IDIR=1,NDIM + NAMREC='G00000001SM'//CDIR(IDIR) + ILPD=NUCELL(IDIR) + CALL LCMGET(IPTRK,NAMREC,DGMESH(0,IDIR)) + ABSC(IDIR)=0.5D0*(DGMESH(ILPD,IDIR)-DGMESH(0,IDIR)) + OFFC(IDIR)=0.5D0*(DGMESH(ILPD,IDIR)+DGMESH(0,IDIR)) + ENDDO + IDIR=4 + NAMREC='G00000001SM'//CDIR(IDIR) + CALL LCMGET(IPTRK,NAMREC,DGMESH(0,IDIR)) + RCIRC=DGMESH(1,IDIR) + ELSE IF(ITYPBC .EQ. 2) THEN +*---- +* Hexagonal +*---- + DO IDIR=1,2 + NAMREC='G00000001SM'//CDIR(IDIR) + CALL LCMGET(IPTRK,NAMREC,DGMESH(0,IDIR)) + SIDEH=DGMESH(0,IDIR) + CENTH=DGMESH(1,IDIR) + OFFC(IDIR)=CENTH + DHMAX=DZERO + DO ICELL=2,NUCELL(IDIR) + DHMAX=MAX(DHMAX,ABS(DGMESH(ICELL,IDIR)-CENTH)) + ENDDO + ABSC(IDIR)=DHMAX+SIDEH + ENDDO + RCIRC=DZERO + DO IDIR=1,NDIM + RCIRC=MAX(RCIRC,ABSC(IDIR)) + ENDDO + ELSE + CALL XABORT(NAMSBR// + > ': Invalid geometry boundary types for PSP') + ENDIF +*---- +* Locate pen at center of page +*---- + XYPOS(1,1)=DIMX + XYPOS(2,1)=DIMY + CALL PSMOVE(ISPSP,XYPOS,-3) + FACT=DIMX/RCIRC + ALLOCATE(IDREG(MXGREG),ITPIN(3*(MAXPIN))) + ALLOCATE(DCMESH(4*(MAXMSH+2)),DRAPIN(6*(MAXPIN))) +*---- +* Scan over all Cartesian cells +* 1) Mesh in $Y$ direction +*---- + IF(ITYPBC .EQ. 0) THEN + ICELL=0 + DO IY=1,NUCELL(2) + CELLPO(2,1)=(DGMESH(IY-1,2)-OFFC(2)) + CELLPO(2,2)=(DGMESH(IY,2)-OFFC(2)) +*---- +* 2) Mesh in $X$ direction +*---- + DO IX=1,NUCELL(1) + CELLPO(1,1)=(DGMESH(IX-1,1)-OFFC(1)) + CELLPO(1,2)=(DGMESH(IX,1)-OFFC(1)) + ICELL=ICELL+1 + ICEL=IUNFLD(1,ICELL) + ITRN=IUNFLD(2,ICELL) + IF(ITRN .EQ. 1) THEN + CALL PSPTCR(IPTRK ,ISPSP ,IPRINT,ICEL ,NDIM ,NFREG , + > MAXMSH,MXGREG,MAXPIN,KPSP ,COLREG,FACT , + > CELLPO,IDREG ,ITPIN ,DCMESH,DRAPIN) + ENDIF + ENDDO + ENDDO + ELSE IF(ITYPBC .EQ. 2) THEN + ALLOCATE(NBPTS(MXGREG),POSTRI(2*4*MXGREG)) + DO ICELL=1,NUCELL(1) +*---- +* Scan over all hexagonal cells +*---- + CELLPO(2,1)=(DGMESH(ICELL,2)-OFFC(2)) + CELLPO(2,2)=(DGMESH(ICELL,2)-OFFC(2)) + CELLPO(1,1)=(DGMESH(ICELL,1)-OFFC(1)) + CELLPO(1,2)=(DGMESH(ICELL,1)-OFFC(1)) + ICEL=IUNFLD(1,ICELL) + ITRN=IUNFLD(2,ICELL) + IF(ITRN .EQ. 1) THEN + CALL PSPTHR(IPTRK ,ISPSP ,IPRINT,ICEL ,NDIM ,NFREG , + > MAXMSH,MXGREG,MAXPIN,KPSP ,COLREG,FACT , + > CELLPO,IDREG ,ITPIN , + > DCMESH,DRAPIN,NBPTS ,POSTRI) + ENDIF + ENDDO + DEALLOCATE(POSTRI,NBPTS) + ENDIF + DEALLOCATE(DRAPIN,ITPIN,DCMESH,IDREG) + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* plot MC: neutron paths if present +*---- + CALL LCMLEN(IPTRK,'MCpoints',ILONG,ITYLCM) + IF (ITYLCM.EQ.0) THEN + CALL LCMSIX(IPTRK,'MCpoints',1) + CALL LCMLEN(IPTRK,'REGI',ILONG,ITYLCM) + ALLOCATE(REGI(ILONG),EVENT(ILONG)) + ALLOCATE(COOR(3*ILONG)) + CALL LCMGET(IPTRK,'COORD',COOR) + CALL LCMGET(IPTRK,'REGI',REGI) + CALL LCMGET(IPTRK,'EVENT',EVENT) + CALL PSPMCP(ISPSP,OFFC,FACT,ILONG,COOR,REGI,EVENT) + DEALLOCATE(EVENT,REGI) + DEALLOCATE(COOR) + CALL LCMSIX(IPTRK,' ',2) + ENDIF +*---- +* Save track normalisation vector +*---- + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + END diff --git a/Dragon/src/PSPRAI.f b/Dragon/src/PSPRAI.f new file mode 100644 index 0000000..6dd379e --- /dev/null +++ b/Dragon/src/PSPRAI.f @@ -0,0 +1,185 @@ +*DECK PSPRAI + SUBROUTINE PSPRAI(MXSEG ,NPTS ,XYPOS ,CENTER,RCIRC , + > NSEG ,IORDER,RADANG) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find general closed Cartesian region intersections +* with annular region and order points for plotting. +* +*Copyright: +* Copyright (C) 2014 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* MXSEG maximum number of segments. +* NPTS number of corners. +* XYPOS X and Y position of corners. +* CENTER X and Y position of annulus center. +* RCIRC annulus radius. +* +*Parameters: output +* NSEG number of region intersection. +* number of segments is NSEG-1 +* IORDER type of region: +* = -2 arc segment begins; +* = -1 arc segment ends; +* = 0 close path; +* > 0 corner. +* RADANG segments intersection points +* with respect to annular region center: +* RADANG(1) = radial position; +* RADANG(2) = angular position. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE + INTEGER IOUT + CHARACTER NAMSBR*6 + REAL PI + PARAMETER (IOUT=6,PI=3.1415926535897932,NAMSBR='PSPRAI') +*---- +* ROUTINE PARAMETERS +*---- + INTEGER MXSEG,NPTS,NSEG + INTEGER IORDER(MXSEG) + REAL XYPOS(2,NPTS),CENTER(2),RCIRC, + > RADANG(2,MXSEG) +*---- +* LOCAL PARAMETERS +*---- + INTEGER IPT,ICUR,INXT + REAL XYCUR(2),XYNXT(2),RADCUR,RADNXT, + > XANN,XANNI,XANNF,XANNT,YANNI,YANNF,YANNT, + > DELX,DELY,DELL,RCIRCM +*---- +* SCAN OVER CORNERS AND SIDES +*---- +* write(6,*) ' Circle ',MXSEG ,NPTS ,CENTER(1),CENTER(2),RCIRC + NSEG=1 + IORDER(NSEG)=0 + RCIRCM=0.0 + DO IPT=1,NPTS + ICUR=IPT + INXT=MOD(IPT,NPTS)+1 + XYCUR(1)=XYPOS(1,ICUR)-CENTER(1) + XYCUR(2)=XYPOS(2,ICUR)-CENTER(2) + XYNXT(1)=XYPOS(1,INXT)-CENTER(1) + XYNXT(2)=XYPOS(2,INXT)-CENTER(2) + RADCUR=SQRT(XYCUR(1)*XYCUR(1)+XYCUR(2)*XYCUR(2)) + RADNXT=SQRT(XYNXT(1)*XYNXT(1)+XYNXT(2)*XYNXT(2)) +* write(6,*) ' Point ',IPT ,ICUR ,XYCUR(1),XYCUR(2), +* > XYNXT(1),XYNXT(2),RADCUR,RADNXT,RADCUR-RCIRC + RCIRCM=RCIRC + IF(RADCUR .EQ. RCIRC) RCIRCM=RCIRCM+0.00001 +*---- +* WRITE(6,6002) IPT,XYCUR,XYNXT +* 6002 FORMAT('Line ',I5,5X,'Starts =',2F20.10,5X,'Ends =',2F20.10) +*---- +* CHECK IF CURRENT CORNER IS LOCATED INSIDE +* ANNULAR REGIONS +*---- + IF(RADCUR .LE. RCIRCM) THEN + IF(IORDER(NSEG) .NE. ICUR) THEN +*---- +* IT IS LOCATED INSIDE +* SET IORDER TO IPT TO SPECIFY THIS POINT TO CORRESPOND TO +* CORNER IPT +*---- + NSEG=NSEG+1 + IORDER(NSEG)=ICUR + RADANG(1,NSEG)=RADCUR + IF(RADCUR .EQ. 0.0) THEN + RADANG(2,NSEG)=0.0 + ELSE + RADANG(2,NSEG)=ATAN2(XYCUR(2),XYCUR(1)) + ENDIF + ENDIF + ENDIF +*---- +* Find line direction +*---- + DELY=XYNXT(2)-XYCUR(2) + DELX=XYNXT(1)-XYCUR(1) + DELL=SQRT(DELY*DELY+DELX*DELX) + DELY=DELY/DELL + DELX=DELX/DELL + XANNI=XYCUR(1)*DELX+XYCUR(2)*DELY + YANNI=-XYCUR(1)*DELY+XYCUR(2)*DELX + XANNF=XYNXT(1)*DELX+XYNXT(2)*DELY + YANNF=-XYNXT(1)*DELY+XYNXT(2)*DELX +*---- +* WRITE(6,6003) DELX,DELY,XANNI,YANNI,XANNF,YANNF +* 6003 FORMAT('Rotation ',2F20.10,5X, +* > 'Starts =',2F20.10,5X,'Ends =',2F20.10) +*---- + IF(YANNI .GE. -RCIRCM .AND. YANNI .LE. RCIRCM) THEN + XANN=-SQRT(RCIRCM*RCIRCM-YANNI*YANNI) + IF(XANN .GE. XANNI .AND. + > XANN .LE. XANNF) THEN + NSEG=NSEG+1 + IORDER(NSEG)=-1 + RADANG(1,NSEG)=RCIRCM + XANNT=XANN*DELX-YANNI*DELY + YANNT=XANN*DELY+YANNI*DELX + RADANG(2,NSEG)=ATAN2(YANNT,XANNT) + ENDIF + XANN=-XANN + IF(XANN .GE. XANNI .AND. + > XANN .LE. XANNF) THEN + NSEG=NSEG+1 + IORDER(NSEG)=-2 + RADANG(1,NSEG)=RCIRCM + XANNT=XANN*DELX-YANNI*DELY + YANNT=XANN*DELY+YANNI*DELX + RADANG(2,NSEG)=ATAN2(YANNT,XANNT) + ENDIF + ENDIF +*---- +* CHECK IF NEXT CORNER OF THE RECTANGLE IS LOCATED INSIDE +* ANNULAR REGIONS +*---- + IF(RADNXT .LE. RCIRCM) THEN +*---- +* IT IS LOCATED INSIDE +* SET IORDER TO IPT TO SPECIFY THIS POINT TO CORRESPOND TO +* CORNER IPT +*---- + NSEG=NSEG+1 + IORDER(NSEG) =INXT + RADANG(1,NSEG)=RADNXT + IF(RADNXT .EQ. 0.0) THEN + RADANG(2,NSEG)=0.0 + ELSE + RADANG(2,NSEG)=ATAN2(XYNXT(2),XYNXT(1)) + ENDIF + ENDIF + ENDDO +*---- +* STORE LAST SEGMENT ALSO AT FIRST POSITION +* FOR CYCLIC TRACKING +*---- + IF(NSEG .EQ. 1) THEN + NSEG=2 + IORDER(1)=-2 + RADANG(1,1)=RCIRCM + RADANG(2,1)=0.0 + IORDER(2)=-1 + RADANG(1,2)=RCIRCM + RADANG(2,2)=2.0*PI + ELSE + IORDER(1) =IORDER(NSEG) + RADANG(1,1)=RADANG(1,NSEG) + RADANG(2,1)=RADANG(2,NSEG) + ENDIF +* write(6,'(I5,2F20.10)') (IORDER(IPT),RADANG(1,IPT),RADANG(2,IPT), +* > IPT=1,NSEG) + RETURN + END diff --git a/Dragon/src/PSPTCR.f b/Dragon/src/PSPTCR.f new file mode 100644 index 0000000..d9e6968 --- /dev/null +++ b/Dragon/src/PSPTCR.f @@ -0,0 +1,331 @@ +*DECK PSPTCR + SUBROUTINE PSPTCR(IPTRK ,ISPSP ,IPRINT,ICEL ,NDIM ,NFREG , + > MAXMSH,MXGREG,MAXPIN,KPSP ,COLREG,FACT , + > CELLPO,IDREG ,ITPIN ,DCMESH,DRAPIN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To draw a Cartesian cell according to its explicit +* position in the assembly. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal. +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure in +* update or creation mode. +* ISPSP POSTSCRIPT file index. +* IPRINT print level. +* ICEL cell number. +* NDIM problem dimensions. +* NFREG number of regions. +* MAXMSH maximum number of elements in MESH array. +* MXGREG maximum number of region for any geometry. +* MAXPIN maximum number of pins in a cell. +* KPSP PSP plot options. +* FACT scale factor for drawing. +* CELLPO global cell position in space. +* COLREG region color. +* +*Parameters: temporary storage +* IDREG local region identifier. +* ITPIN pin type identifier. +* DCMESH meshing vector for geometries. +* DRAPIN pin position identifier. +* +*---------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPTRK + INTEGER ISPSP + INTEGER IPRINT,ICEL,NDIM,NFREG,MAXMSH,MXGREG,MAXPIN + INTEGER KPSP(7) + REAL COLREG(4,NFREG) + DOUBLE PRECISION FACT,CELLPO(2,2) + INTEGER IDREG(MXGREG),ITPIN(3,MAXPIN) + DOUBLE PRECISION DCMESH(-1:MAXMSH,4),DRAPIN(-1:4,MAXPIN) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='PSPTCR') + INTEGER NSTATE + PARAMETER (NSTATE=40) + REAL WLINE + PARAMETER (WLINE=0.002) + DOUBLE PRECISION DZERO,DONE,DTWO + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Functions +*---- + DOUBLE PRECISION XDRCST,PI +*---- +* Local variables +*---- + INTEGER ILEV,ICONT,ICOL,KFS,KFR,KSS,KSR,NPTS,NSEG,NINT + INTEGER IEDIMC(NSTATE),IEDIMP(NSTATE) + INTEGER ITYPG,MESHC(4),NREGC,NTPIN + INTEGER IDIR,ILXY,NBR,IY,IX,IR,ILOC,IREG,IORDER(16) + REAL WLFAC,XYPOS(2,4),CENTER(2),RCIRC,RADANG(2,16), + > OFFX,OFFY + CHARACTER NAMCEL*9,NAMREC*12 + REAL COLWHI(4),CENTEP(2),CENTED(2),CENTEB(2) + INTEGER IWCOL,IPIN,ISEG,NBRP,MESHP(4) + DOUBLE PRECISION ROTAX,COSDIR(3) +*---- +* Data +*---- + CHARACTER CDIR(4)*1 + SAVE CDIR + CHARACTER CLEV(2)*1 + SAVE CLEV + DATA CDIR /'X','Y','Z','R'/ + DATA CLEV /'C','P'/ +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + IF(NDIM .GE. 3) CALL XABORT(NAMSBR// + >': PSP cannot treat 3D geometries') + PI=XDRCST('Pi',' ') + IDIR=NDIM + ILEV=1 + IWCOL=1 + COLWHI(:4)=1.0 +*---- +* PSP print control +*---- + WLFAC=1.0 + ICONT=KPSP(1) + ICOL=KPSP(2) + IF(KPSP(3) .EQ. 1) WLFAC=2.5 + KFS=KPSP(4) + KFR=KPSP(5) + KSS=KPSP(6) + KSR=KPSP(7) + NPTS=4 + NINT=16 +*---- +* Read cell information +*---- + WRITE(NAMCEL,'(A1,I8.8)') CLEV(ILEV),ICEL + NAMREC=NAMCEL//'DIM' + IEDIMC(:NSTATE)=0 + CALL LCMGET(IPTRK,NAMREC,IEDIMC) + ITYPG=IEDIMC(1) + MESHC(1)=IEDIMC(3) + MESHC(2)=IEDIMC(4) + MESHC(3)=IEDIMC(5) + MESHC(4)=IEDIMC(2) + NREGC=IEDIMC(8) + NTPIN=IEDIMC(18) + NAMREC=NAMCEL//'RID' + CALL LCMGET(IPTRK,NAMREC,IDREG) + DO IDIR=1,4 + NAMREC=NAMCEL//'SM'//CDIR(IDIR) + IF(MESHC(IDIR) .GT. 0) THEN + CALL LCMGET(IPTRK,NAMREC,DCMESH(-1,IDIR)) + ENDIF + ENDDO + IF(NTPIN .GT .0) THEN + NAMREC=NAMCEL//'PIN' + CALL LCMGET(IPTRK,NAMREC,DRAPIN) + NAMREC=NAMCEL//'PNT' + CALL LCMGET(IPTRK,NAMREC,ITPIN) + ENDIF +*---- +* Plot each region +*---- + ILXY=0 + NBR=MESHC(4)+1 + OFFX=-REAL(CELLPO(1,1)-DCMESH(0,1)) + OFFY=-REAL(CELLPO(2,1)-DCMESH(0,2)) + CENTER(1)=REAL(FACT*(DCMESH(-1,1)-OFFX)) + CENTER(2)=REAL(FACT*(DCMESH(-1,2)-OFFY)) + CENTEB(1)=-CENTER(1) + CENTEB(2)=-CENTER(2) + DO IY=MESHC(2),1,-1 + DO IX=MESHC(1),1,-1 + ILXY=((IY-1)*MESHC(1)+(IX-1))*NBR + ILOC=ILXY+NBR + IREG=ABS(IDREG(ILOC)) +*---- +* Cartesian region +*---- + XYPOS(1,1)=REAL(FACT*(DCMESH(IX-1,1)-OFFX)) + XYPOS(2,1)=REAL(FACT*(DCMESH(IY-1,2)-OFFY)) + XYPOS(1,2)=REAL(FACT*(DCMESH(IX,1)-OFFX)) + XYPOS(2,2)=XYPOS(2,1) + XYPOS(1,3)=XYPOS(1,2) + XYPOS(2,3)=REAL(FACT*(DCMESH(IY,2)-OFFY)) + XYPOS(1,4)=XYPOS(1,1) + XYPOS(2,4)=XYPOS(2,3) + IF(IREG .NE. 0) THEN +*---- +* Color and trace result +*---- + CALL PSDREG(ISPSP,4,XYPOS) + IF(ICOL. GT. 0) THEN + CALL PSFILL(ISPSP,ICOL,COLREG(1,IREG),KFS,KFR) + ENDIF + IF(ICONT.EQ.1) THEN + CALL PSSTRK(ISPSP,WLFAC*WLINE,KSS,KSR) + ENDIF + ENDIF + DO IR=MESHC(4),1,-1 + ILOC=ILXY+IR + IREG=ABS(IDREG(ILOC)) +*---- +* Annular region +*---- + IF(IREG .NE. 0) THEN + RCIRC=REAL(FACT*DCMESH(IR,4)) +*---- +* Move cursor to center of annulus +*---- + CALL PSMOVE(ISPSP,CENTER,-3) +*---- +* Color and trace result +*---- + CALL PSPRAI(NINT,NPTS,XYPOS,CENTER,RCIRC, + > NSEG,IORDER,RADANG) + CALL PSDRAI(ISPSP,NSEG,IORDER,CENTER,RADANG) + IF(ICOL. GT. 0) THEN + CALL PSFILL(ISPSP,ICOL,COLREG(1,IREG),KFS,KFR) + ENDIF + IF(ICONT.EQ.1) THEN + CALL PSSTRK(ISPSP,WLFAC*WLINE,KSS,KSR) + ENDIF +*---- +* Return cursor to original position +*---- + CALL PSMOVE(ISPSP,CENTEB,-3) + ENDIF + ENDDO + ENDDO + ENDDO +*---- +* Pins +*---- + IF(NTPIN .GT. 0) THEN + ILEV=2 + MESHP(1)=1 + MESHP(2)=1 + MESHP(3)=1 + MESHP(4)=1 + CENTEP(1)=0.0 + CENTEP(2)=0.0 + DO IPIN=1,NTPIN +*---- +* Locate pin position +*---- + COSDIR(1)=DRAPIN(0,IPIN)*COS(DRAPIN(-1,IPIN)) + COSDIR(2)=DRAPIN(0,IPIN)*SIN(DRAPIN(-1,IPIN)) + CENTED(1)=REAL(CENTER(1)+FACT*COSDIR(1)) + CENTED(2)=REAL(CENTER(2)+FACT*COSDIR(2)) + RCIRC=REAL(FACT*DRAPIN(4,IPIN)) + ROTAX=PI/DTWO-DRAPIN(-1,IPIN) +*---- +* Move cursor to center of pin +*---- + CALL PSMOVE(ISPSP,CENTED,-3) +*---- +* Read pin information +*---- + WRITE(NAMCEL,'(A1,I8.8)') CLEV(ILEV),ITPIN(2,IPIN) + NAMREC=NAMCEL//'DIM' + IEDIMP(:NSTATE)=0 + CALL LCMGET(IPTRK,NAMREC,IEDIMP) + ITYPG=IEDIMP(1) + MESHP(1)=IEDIMP(3) + MESHP(2)=IEDIMP(4) + MESHP(3)=IEDIMP(5) + MESHP(4)=IEDIMP(2) + NBRP=MESHP(4) + NAMREC=NAMCEL//'RID' + CALL LCMGET(IPTRK,NAMREC,IDREG) + DO IDIR=1,4 + NAMREC=NAMCEL//'SM'//CDIR(IDIR) + IF(MESHP(IDIR) .GT. 0) THEN + CALL LCMGET(IPTRK,NAMREC,DCMESH(-1,IDIR)) + ENDIF + ENDDO + DO IY=MESHP(2),1,-1 + DO IX=MESHP(1),1,-1 + ILXY=((IY-1)*MESHP(1)+(IX-1))*NBRP +*---- +* Cartesian region +*---- + XYPOS(1,1)=REAL(FACT*(DCMESH(IX-1,1))) + XYPOS(2,1)=REAL(FACT*(DCMESH(IY-1,2))) + XYPOS(1,2)=REAL(FACT*(DCMESH(IX,1))) + XYPOS(2,2)=XYPOS(2,1) + XYPOS(1,3)=XYPOS(1,2) + XYPOS(2,3)=REAL(FACT*(DCMESH(IY,2))) + XYPOS(1,4)=XYPOS(1,1) + XYPOS(2,4)=XYPOS(2,3) + DO IR=MESHP(4),1,-1 + ILOC=ILXY+IR + IREG=ABS(IDREG(ILOC)) + RCIRC=REAL(FACT*DCMESH(IR,4)) +*---- +* Annular pin regions +*---- + IF(IREG .NE. 0) THEN + CALL PSPRAI(NINT,NPTS,XYPOS,CENTEP,RCIRC, + > NSEG,IORDER,RADANG) +*---- +* Rotate pins intersection points +*---- + DO ISEG=1,NSEG + RADANG(2,ISEG)=RADANG(2,ISEG)-REAL(ROTAX) + ENDDO +*---- +* Color and trace result +*---- + CALL PSDRAI(ISPSP,NSEG,IORDER,CENTEP,RADANG) + IF(ICOL. GT. 0) THEN + CALL PSFILL(ISPSP,ICOL,COLREG(1,IREG),KFS,KFR) + ENDIF + IF(ICONT.EQ.1) THEN + CALL PSSTRK(ISPSP,WLFAC*WLINE,KSS,KSR) + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO +*---- +* Return cursor to original position +*---- + CENTED(1)=-CENTED(1) + CENTED(2)=-CENTED(2) + CALL PSMOVE(ISPSP,CENTED,-3) + ENDDO + ENDIF + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + END diff --git a/Dragon/src/PSPTHR.f b/Dragon/src/PSPTHR.f new file mode 100644 index 0000000..9abdbd7 --- /dev/null +++ b/Dragon/src/PSPTHR.f @@ -0,0 +1,503 @@ +*DECK PSPTHR + SUBROUTINE PSPTHR(IPTRK ,ISPSP ,IPRINT,ICEL ,NDIM ,NFREG , + > MAXMSH,MXGREG,MAXPIN,KPSP ,COLREG,FACT , + > CELLPO,IDREG ,ITPIN ,DCMESH,DRAPIN, + > NBPTS ,POSTRI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To draw an hexagonal cell with triangular mesh according +* to its explicit position in the assembly. +* +*Copyright: +* Copyright (C) 2012 Ecole Polytechnique de Montreal. +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure in +* update or creation mode. +* ISPSP POSTSCRIPT file index. +* IPRINT print level. +* ICEL cell number. +* NDIM problem dimensions. +* NFREG number of regions. +* MAXMSH maximum number of elements in MESH array. +* MXGREG maximum number of region for any geometry. +* MAXPIN maximum number of pins in a cell. +* KPSP PSP plot options. +* FACT scale factor for drawing. +* CELLPO global cell position in space. +* COLREG region color. +* +*Parameters: temporary storage +* IDREG local region identifier. +* ITPIN pin type identifier. +* DCMESH meshing vector for geometries. +* DRAPIN pin position identifier. +* NBPTS number of corners for regions in first sector. +* POSTRI positions of corners for regions in first sector. +* +*---------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPTRK,ISPSP + INTEGER IPRINT,ICEL,NDIM,NFREG,MAXMSH,MXGREG,MAXPIN + INTEGER KPSP(7) + REAL COLREG(4,NFREG) + DOUBLE PRECISION FACT,CELLPO(2,2) + INTEGER IDREG(MXGREG),ITPIN(3,MAXPIN) + DOUBLE PRECISION DCMESH(-1:MAXMSH,4),DRAPIN(-1:4,MAXPIN) + INTEGER NBPTS(MXGREG) + DOUBLE PRECISION POSTRI(2,4,MXGREG) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='PSPTHR') + INTEGER NSTATE + PARAMETER (NSTATE=40) + REAL WLINE + PARAMETER (WLINE=0.002) + DOUBLE PRECISION DZERO,DONE,DTWO,DHALF,DSQ3O2 + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0, + > DHALF=0.5D0,DSQ3O2=0.86602540378444D0) + INTEGER MAXDIM + PARAMETER (MAXDIM=4) +*---- +* Functions +*---- + DOUBLE PRECISION XDRCST,PI +*---- +* Local variables +*---- + INTEGER ILEV,ICONT,ICOL,KFS,KFR,KSS,KSR,NPTS,NSEG,NINT + INTEGER IEDIMC(NSTATE),IEDIMP(NSTATE) + INTEGER NX,MESHC(4),NREGC,NTPIN,NRTP + INTEGER IDIR,ILXY,IREG,IR,IY,IX,ILOC,IORDER(16) + INTEGER JR,NAR,ITREG,IAREG,JREG + REAL WLFAC,XYPOS(2,4),CENTER(2),RCIRC,RADANG(2,16) + CHARACTER NAMCEL*9,NAMREC*12 + REAL COLWHI(4),CENTEP(2),CENTED(2),CENTEB(2) + INTEGER IWCOL,IPIN,ISEG,NBRP,MESHP(4) + DOUBLE PRECISION ROTAX,COSDIR(3) + INTEGER ISECT,ITRI,KREG,NCPT + DOUBLE PRECISION SIDET,SIDEL,SIDEH,POSCXD,POSCYD,POSCX,POSCY, + > SIDEU,SIDEUH,DTMPX,DTMPY +*---- +* Data +*---- + CHARACTER CDIR(MAXDIM)*1 + SAVE CDIR + CHARACTER CLEV(2)*1 + SAVE CLEV + DATA CDIR /'X','Y','Z','R'/ + DATA CLEV /'C','P'/ +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + IF(NDIM .GE. 3) CALL XABORT(NAMSBR// + >': PSP cannot treat 3D geometries') + PI=XDRCST('Pi',' ') + ILEV=1 + IWCOL=1 + COLWHI(:4)=1.0 +*---- +* PSP print control +*---- + WLFAC=1.0 + ICONT=KPSP(1) + ICOL=KPSP(2) + IF(KPSP(3) .EQ. 1) WLFAC=2.5 + KFS=KPSP(4) + KFR=KPSP(5) + KSS=KPSP(6) + KSR=KPSP(7) + NPTS=3 + NINT=16 +*---- +* Read cell information +*---- + WRITE(NAMCEL,'(A1,I8.8)') CLEV(ILEV),ICEL + NAMREC=NAMCEL//'DIM' + IEDIMC(:NSTATE)=0 + CALL LCMGET(IPTRK,NAMREC,IEDIMC) + NX=IEDIMC(3) + NAR=IEDIMC(2) + MESHC(1)=NX + MESHC(2)=NX + MESHC(3)=IEDIMC(5) + MESHC(4)=NAR + NREGC=IEDIMC(8) + NTPIN=IEDIMC(18) + NAMREC=NAMCEL//'RID' + CALL LCMGET(IPTRK,NAMREC,IDREG) + DO IDIR=1,4 + NAMREC=NAMCEL//'SM'//CDIR(IDIR) + IF(MESHC(IDIR) .GT. 0) THEN + CALL LCMGET(IPTRK,NAMREC,DCMESH(-1,IDIR)) + ENDIF + ENDDO + IF(NTPIN .GT .0) THEN + NAMREC=NAMCEL//'PIN' + CALL LCMGET(IPTRK,NAMREC,DRAPIN) + NAMREC=NAMCEL//'PNT' + CALL LCMGET(IPTRK,NAMREC,ITPIN) + ENDIF + CENTER(1)=REAL(FACT*(DCMESH(-1,1)+CELLPO(1,1))) + CENTER(2)=REAL(FACT*(DCMESH(-1,2)+CELLPO(2,1))) + CENTEB(1)=-CENTER(1) + CENTEB(2)=-CENTER(2) + NRTP=NX**2 + SIDEU=DCMESH(1,1)-DCMESH(0,1) + SIDET=SIDEU + IF(NX .GT. 1) THEN + SIDET=DCMESH(2,1)-DCMESH(1,1) + ENDIF + SIDEL=SIDET/DSQ3O2 + SIDEH=DHALF*SIDEL +*---- +* Find triangle corners +* 1- First sectors +* All crown +*---- + IREG=0 + POSCXD=DZERO + POSCYD=SIDEH + DO IX=1,NX + POSCX=POSCXD + POSCY=POSCYD +*---- +* right triangles +*---- + DO IR=1,IX-1 + IREG=IREG+1 + POSTRI(1,1,IREG)=POSCX+SIDET + POSTRI(2,1,IREG)=POSCY + POSTRI(1,2,IREG)=POSCXD + POSTRI(2,2,IREG)=POSCY+SIDEH + POSTRI(1,3,IREG)=POSCXD + POSTRI(2,3,IREG)=POSCY-SIDEH + NBPTS(IREG)=3 + POSCY=POSCY+SIDEL + ENDDO +*---- +* Loop over Left triangles on the line +*---- + POSCYD=POSCYD-SIDEH + POSCX=POSCXD + POSCY=POSCYD + DO IR=1,IX + IREG=IREG+1 + POSTRI(1,1,IREG)=POSCX + POSTRI(2,1,IREG)=POSCY + POSTRI(1,2,IREG)=POSCX+SIDET + POSTRI(2,2,IREG)=POSCY-SIDEH + POSTRI(1,3,IREG)=POSCX+SIDET + POSTRI(2,3,IREG)=POSCY+SIDEH + POSCY=POSCY+SIDEL + NBPTS(IREG)=3 + ENDDO + POSCXD=POSCXD+SIDET + ENDDO +*---- +* Replace right triangles in last crown by +* Isosceles trapezoid when required +*---- + IF(SIDEU .LT. SIDET) THEN + SIDEU=SIDET-SIDEU + SIDEUH=DHALF*SIDEU/DSQ3O2 + IX=NX + IREG=IREG-2*IX+1 +*---- +* Cut left triangle in last crown when required +*---- + DO IR=1,IX-1 + IREG=IREG+1 + POSTRI(1,4,IREG)=POSTRI(1,1,IREG)-SIDEU + POSTRI(2,4,IREG)=POSTRI(2,1,IREG)-SIDEUH + POSTRI(1,1,IREG)=POSTRI(1,1,IREG)-SIDEU + POSTRI(2,1,IREG)=POSTRI(2,1,IREG)+SIDEUH + NBPTS(IREG)=4 + ENDDO +*---- +* Loop over Left triangles on the line +*---- + DO IR=1,IX + IREG=IREG+1 + POSTRI(1,2,IREG)=POSTRI(1,2,IREG)-SIDEU + POSTRI(2,2,IREG)=POSTRI(2,2,IREG)+SIDEUH + POSTRI(1,3,IREG)=POSTRI(1,3,IREG)-SIDEU + POSTRI(2,3,IREG)=POSTRI(2,3,IREG)-SIDEUH + ENDDO + ENDIF +*---- +* General location of regions in first sector with respect to +* cell center are now known +* Draw all regions in first sector +*---- + IREG=0 + ISECT=1 + DO IR=1,NRTP + IREG=IREG+1 + ITREG=IREG*(NAR+1) + NCPT=NBPTS(IR) + KREG=ABS(IDREG(ITREG)) + DO ITRI=1,NCPT + XYPOS(1,ITRI)=REAL(FACT*(POSTRI(1,ITRI,IR)+CELLPO(1,1))) + XYPOS(2,ITRI)=REAL(FACT*(POSTRI(2,ITRI,IR)+CELLPO(2,1))) + ENDDO + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6010) ISECT,IR,IREG,ITREG,KREG,NCPT + WRITE(IOUT,6011) (XYPOS(1,ITRI),XYPOS(2,ITRI),ITRI=1,NCPT) + ENDIF + IF(KREG .NE. 0) THEN +*---- +* Color and trace result +*---- + CALL PSDREG(ISPSP,NCPT,XYPOS) + IF(ICOL. GT. 0) THEN + CALL PSFILL(ISPSP,ICOL,COLREG(1,KREG),KFS,KFR) + ENDIF + IF(ICONT.EQ.1) THEN + CALL PSSTRK(ISPSP,WLFAC*WLINE,KSS,KSR) + ENDIF + ENDIF + DO JR=NAR,1,-1 + IAREG=(NAR+1)*(IREG-1)+JR + JREG=ABS(IDREG(IAREG)) + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6020) JR,IAREG,JREG,FACT*DCMESH(JR,4) + ENDIF +*---- +* Annular region +*---- + IF(JREG .NE. 0) THEN + RCIRC=REAL(FACT*DCMESH(JR,4)) +*---- +* Move cursor to center of annulus +*---- + CALL PSMOVE(ISPSP,CENTER,-3) +*---- +* Color and trace result +*---- + CALL PSPRAI(NINT,NPTS,XYPOS,CENTER,RCIRC, + > NSEG,IORDER,RADANG) + CALL PSDRAI(ISPSP,NSEG,IORDER,CENTER,RADANG) + IF(ICOL. GT. 0) THEN + CALL PSFILL(ISPSP,ICOL,COLREG(1,JREG),KFS,KFR) + ENDIF + IF(ICONT.EQ.1) THEN + CALL PSSTRK(ISPSP,WLFAC*WLINE,KSS,KSR) + ENDIF +*---- +* Return cursor to original position +*---- + CALL PSMOVE(ISPSP,CENTEB,-3) + ENDIF + ENDDO + ENDDO +*---- +* 2) Rotate regions for remaining sectors +* and draw +*---- + DO ISECT=2,6 + DO IR=1,NRTP + IREG=IREG+1 + ITREG=IREG*(NAR+1) + NCPT=NBPTS(IR) + KREG=ABS(IDREG(ITREG)) + DO ITRI=1,NCPT +*---- +* rotation by pi/3 from previous sector +*---- + DTMPX=DHALF*POSTRI(1,ITRI,IR) + > -DSQ3O2*POSTRI(2,ITRI,IR) + DTMPY=DSQ3O2*POSTRI(1,ITRI,IR) + > +DHALF*POSTRI(2,ITRI,IR) + POSTRI(1,ITRI,IR)=DTMPX + POSTRI(2,ITRI,IR)=DTMPY + XYPOS(1,ITRI)=REAL(FACT*(POSTRI(1,ITRI,IR)+CELLPO(1,1))) + XYPOS(2,ITRI)=REAL(FACT*(POSTRI(2,ITRI,IR)+CELLPO(2,1))) + ENDDO + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6010) ISECT,IR,IREG,ITREG,KREG,NCPT + WRITE(IOUT,6011) (XYPOS(1,ITRI),XYPOS(2,ITRI),ITRI=1,NCPT) + ENDIF + IF(KREG .NE. 0) THEN +*---- +* Color and trace result +*---- + CALL PSDREG(ISPSP,NCPT,XYPOS) + IF(ICOL. GT. 0) THEN + CALL PSFILL(ISPSP,ICOL,COLREG(1,KREG),KFS,KFR) + ENDIF + IF(ICONT.EQ.1) THEN + CALL PSSTRK(ISPSP,WLFAC*WLINE,KSS,KSR) + ENDIF + ENDIF + DO JR=NAR,1,-1 + IAREG=(NAR+1)*(IREG-1)+JR + JREG=ABS(IDREG(IAREG)) + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6020) JR,IAREG,JREG,DCMESH(JR,4) + ENDIF +*---- +* Annular region +*---- + IF(JREG .NE. 0) THEN + RCIRC=REAL(FACT*DCMESH(JR,4)) +*---- +* Move cursor to center of annulus +*---- + CALL PSMOVE(ISPSP,CENTER,-3) +*---- +* Color and trace result +*---- + CALL PSPRAI(NINT,NPTS,XYPOS,CENTER,RCIRC, + > NSEG,IORDER,RADANG) + CALL PSDRAI(ISPSP,NSEG,IORDER,CENTER,RADANG) + IF(ICOL. GT. 0) THEN + CALL PSFILL(ISPSP,ICOL,COLREG(1,JREG),KFS,KFR) + ENDIF + IF(ICONT.EQ.1) THEN + CALL PSSTRK(ISPSP,WLFAC*WLINE,KSS,KSR) + ENDIF +*---- +* Return cursor to original position +*---- + CALL PSMOVE(ISPSP,CENTEB,-3) + ENDIF + ENDDO + ENDDO + ENDDO +*---- +* Pins +*---- + IF(NTPIN .GT. 0) THEN + NPTS=4 + ILEV=2 + MESHP(1)=1 + MESHP(2)=1 + MESHP(3)=1 + MESHP(4)=1 + CENTEP(1)=0.0 + CENTEP(2)=0.0 + DO IPIN=1,NTPIN +*---- +* Locate pin position +*---- + COSDIR(1)=DRAPIN(0,IPIN)*COS(DRAPIN(-1,IPIN)) + COSDIR(2)=DRAPIN(0,IPIN)*SIN(DRAPIN(-1,IPIN)) + CENTED(1)=CENTER(1)+REAL(FACT*COSDIR(1)) + CENTED(2)=CENTER(2)+REAL(FACT*COSDIR(2)) + RCIRC=REAL(FACT*DRAPIN(4,IPIN)) + ROTAX=PI/DTWO-DRAPIN(-1,IPIN) +*---- +* Move cursor to center of pin +*---- + CALL PSMOVE(ISPSP,CENTED,-3) +*---- +* Read pin information +*---- + WRITE(NAMCEL,'(A1,I8.8)') CLEV(ILEV),ITPIN(2,IPIN) + NAMREC=NAMCEL//'DIM' + IEDIMP(:NSTATE)=0 + CALL LCMGET(IPTRK,NAMREC,IEDIMP) + MESHP(1)=IEDIMP(3) + MESHP(2)=IEDIMP(4) + MESHP(3)=IEDIMP(5) + MESHP(4)=IEDIMP(2) + NBRP=MESHP(4) + NAMREC=NAMCEL//'RID' + CALL LCMGET(IPTRK,NAMREC,IDREG) + DO IDIR=1,4 + NAMREC=NAMCEL//'SM'//CDIR(IDIR) + IF(MESHP(IDIR) .GT. 0) THEN + CALL LCMGET(IPTRK,NAMREC,DCMESH(-1,IDIR)) + ENDIF + ENDDO + DO IY=MESHP(2),1,-1 + DO IX=MESHP(1),1,-1 + ILXY=((IY-1)*MESHP(1)+(IX-1))*NBRP +*---- +* Cartesian region +*---- + XYPOS(1,1)=REAL(FACT*(DCMESH(IX-1,1))) + XYPOS(2,1)=REAL(FACT*(DCMESH(IY-1,2))) + XYPOS(1,2)=REAL(FACT*(DCMESH(IX,1))) + XYPOS(2,2)=XYPOS(2,1) + XYPOS(1,3)=XYPOS(1,2) + XYPOS(2,3)=REAL(FACT*(DCMESH(IY,2))) + XYPOS(1,4)=XYPOS(1,1) + XYPOS(2,4)=XYPOS(2,3) + DO IR=MESHP(4),1,-1 + ILOC=ILXY+IR + IREG=ABS(IDREG(ILOC)) + RCIRC=REAL(FACT*DCMESH(IR,4)) +*---- +* Annular pin regions +*---- + IF(IREG .NE. 0) THEN + CALL PSPRAI(NINT,NPTS,XYPOS,CENTEP,RCIRC, + > NSEG,IORDER,RADANG) +*---- +* Rotate pins intersection points +*---- + DO ISEG=1,NSEG + RADANG(2,ISEG)=RADANG(2,ISEG)-REAL(ROTAX) + ENDDO +*---- +* Color and trace result +*---- + CALL PSDRAI(ISPSP,NSEG,IORDER,CENTEP,RADANG) + IF(ICOL. GT. 0) THEN + CALL PSFILL(ISPSP,ICOL,COLREG(1,IREG),KFS,KFR) + ENDIF + IF(ICONT.EQ.1) THEN + CALL PSSTRK(ISPSP,WLFAC*WLINE,KSS,KSR) + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO +*---- +* Return cursor to original position +*---- + CENTED(1)=-CENTED(1) + CENTED(2)=-CENTED(2) + CALL PSMOVE(ISPSP,CENTED,-3) + ENDDO + ENDIF + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(' Sector ',I5,3X,'Triangle ',I5,5X,'T region ',I5,5X, + >'G region ',I5,5X, + >'Region number',I5,5X,'Number of corners ',I5) + 6011 FORMAT(2F20.7) + 6020 FORMAT(' Annulus ',I5,3X,'A Region ',I5,5X, + >'Region number',I5,5X,'radius ',F20.10) + END diff --git a/Dragon/src/PSPTRK.f b/Dragon/src/PSPTRK.f new file mode 100644 index 0000000..4f6b059 --- /dev/null +++ b/Dragon/src/PSPTRK.f @@ -0,0 +1,283 @@ +*DECK PSPTRK + SUBROUTINE PSPTRK(IPRINT,ISPSP ,ITYPE ,ICOLR ,IPTRKT,NAMFIL, + > NAMLEG,NUNKNO,FLUX ) +* +*---------- +* +*Purpose: +* To generate a POSTSCRIPT file containing a graphical description +* of a 2-D geometry from an EXCELL generated +* tracking data structure. +* +*Copyright: +* Copyright (C) 1999 Ecole Polytechnique de Montreal. +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau. +* +*Parameters: input +* IPRINT print level. +* ISPSP POSTSCRIPT file index. +* ITYPE identifier for the type of graphics where: +* =0 when the geometry is colored by region; +* =1 when the geometry is colored by mixture; +* =2 when the geometry is colored by flux +* (one group); +* =3 when the geometry is colored by flux +* (multigroup); +* =4 when the geometry is colored by mixture for +* homogenization. +* ICOLR color set used where: +* =-4 HSB filling with no contour; +* =-3 CYMK filling with no contour; +* =-2 RGB filling with no contour; +* =-1 BW filling with no contour; +* = 0 no filling with contour; +* = 1 BW filling with contour; +* = 2 RGB filling with contour; +* = 3 CMYK filling with contour; +* = 4 HSB filling with contour. +* IPTRKT pointer to the TRACKING data structure. +* NAMFIL geometry file name. +* NAMLEG legend name. +* NUNKNO number of flux unknowns. +* +*Parameters: temporary storage +* FLUX flux storage array. +* +*---------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPTRKT + INTEGER IPRINT,ISPSP,ITYPE,ICOLR,NUNKNO + CHARACTER NAMFIL*12,NAMLEG*24 + REAL FLUX(NUNKNO) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='PSPTRK') + INTEGER NSTATE + PARAMETER (NSTATE=40) + INTEGER ILCMUP,ILCMDN + PARAMETER (ILCMUP=1,ILCMDN=2) +*---- +* Local variables +*---- + INTEGER ISTATE(NSTATE),IPARAM(NSTATE),ITROP, + > NDIM,NVOL,NSUR,NSURX,NBAN,NUNK,NRT,MSROD, + > MAROD,NTOTCL,MAXR,NUNKT,NREGT,NNSUR + REAL COTE + INTEGER IEDIMG(NSTATE),ITYPBC,NBUCEL,NUCELL(3), + > MAXMSH,MAXMDH,MAXREG,NBTCLS,MAXPIN,MAXMSP, + > MAXRSP,NFSUR,NFREG,MXGREG +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KEYFLX,KEYMRG,MATALB,IUNFLD, + > NRODS,NRODR,NRINFO,NXRI,MINDIM,MAXDIM,INDEX + REAL, ALLOCATABLE, DIMENSION(:) :: COLRG,RAN,RODS,RODR,REMSH + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DGMESH +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6002) NAMFIL + ENDIF +*---- +* Get state vector from tracking +* and check if a graphical description +* of the geometry is possible. +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(IPTRKT,'STATE-VECTOR',ISTATE) + IF(ITYPE .EQ. 2 .OR. ITYPE .EQ. 3 .OR. + > ITYPE .EQ. 5 .OR. ITYPE .EQ. 6) THEN + NREGT=ISTATE(1) + NUNKT=ISTATE(2) + IF(NUNKNO .NE. NUNKT) CALL XABORT(NAMSBR// + > ': Tracking is not consistent with fluxes') + ALLOCATE(KEYFLX(NREGT)) + CALL LCMGET(IPTRKT,'KEYFLX ',KEYFLX) + ELSE + NREGT=1 + ALLOCATE(KEYFLX(NREGT)) + KEYFLX=0 + ENDIF + ITROP=ISTATE(7) + IF(ITROP .EQ. 4) THEN +*---- +* NXT processed geometry +*---- + CALL LCMSIX(IPTRKT,'NXTRecords ',ILCMUP) + CALL LCMGET(IPTRKT,'G00000001DIM',IEDIMG) + NDIM=IEDIMG( 1) + ITYPBC =IEDIMG( 2) + NBUCEL =IEDIMG( 5) + NUCELL(1)=IEDIMG(13) + NUCELL(2)=IEDIMG(14) + NUCELL(3)=IEDIMG(15) + MAXMSH =IEDIMG(16) + MAXREG =IEDIMG(17) + NBTCLS =IEDIMG(18) + MAXPIN =IEDIMG(19) + MAXMSP =IEDIMG(20) + MAXRSP =IEDIMG(21) + NFSUR =IEDIMG(22) + NFREG =IEDIMG(23) + MXGREG =IEDIMG(25) + NSUR=NFSUR + NVOL=NFREG + NNSUR=-NSUR + NUNK=NSUR+NVOL+1 + ALLOCATE(COLRG(4*NVOL)) + ALLOCATE(KEYMRG(NUNK),MATALB(NUNK)) + IEDIMG(:NSTATE)=0 + IF(NDIM .EQ. 2) THEN + IF(ITYPE .EQ. 4) THEN + CALL LCMGET(IPTRKT,'HOMMATALB ',MATALB) + ELSE + CALL LCMGET(IPTRKT,'MATALB ',MATALB) + ENDIF + CALL LCMGET(IPTRKT,'KEYMRG ',KEYMRG) +*---- +* Produce legend +*---- + CALL PSPLEG(IPRINT,ISPSP ,ITYPE ,ICOLR ,NNSUR ,NVOL , + > NAMLEG,NUNKNO,FLUX ,NREGT , + > MATALB,KEYMRG,KEYFLX, + > COLRG) +*---- +* Produce graphical description of geometry +*---- + NUNK=NFSUR+NFREG+1 + MAXMDH=MAX(MAXMSH,MAXMSP,MAXREG) + ALLOCATE(IUNFLD(2*NBUCEL),DGMESH((MAXMDH+2)*4)) + CALL LCMGET(IPTRKT,'G00000001CUF',IUNFLD) + CALL PSPNXT(IPRINT,ISPSP ,ICOLR ,IPTRKT,ITYPBC,MAXMDH, + > NDIM ,NFSUR ,NFREG ,NUCELL,NBUCEL, + > MXGREG,MAXPIN,COLRG, IUNFLD,MATALB,DGMESH) + DEALLOCATE(DGMESH,IUNFLD) + ELSE + WRITE(IOUT,9000) + ENDIF + CALL LCMSIX(IPTRKT,'NXTRecords ',ILCMDN) + ELSE + CALL LCMSIX(IPTRKT,'EXCELL ',1) + IPARAM(:NSTATE)=0 + CALL LCMGET(IPTRKT,'STATE-VECTOR',IPARAM) + NDIM=IPARAM(1) + NSUR=-IPARAM(2) + NVOL=IPARAM(3) + NSURX=IPARAM(4) + NBAN=IPARAM(5) + NUNK=IPARAM(6) + ALLOCATE(COLRG(4*NVOL)) + ALLOCATE(KEYMRG(NUNK),MATALB(NUNK)) + CALL LCMGET(IPTRKT,'MATALB ',MATALB) + CALL LCMGET(IPTRKT,'KEYMRG ',KEYMRG) + IF(ITROP .EQ. 3) THEN +*---- +* EXCELL based CLUSTER geometries +*---- + NRT=IPARAM(7) + MSROD=IPARAM(8) + MAROD=IPARAM(9) + ALLOCATE(NRODS(3*NRT),NRODR(NRT),NRINFO(2*NBAN), + > NXRI(NRT*NBAN)) + ALLOCATE(RAN(NBAN),RODS(2*NRT),RODR(MSROD*NRT)) + CALL LCMGET(IPTRKT,'RAN ',RAN) + IF(NSURX .EQ. 4) + > CALL LCMGET(IPTRKT,'COTE ',COTE) + CALL LCMGET(IPTRKT,'NRODS ',NRODS) + CALL LCMGET(IPTRKT,'RODS ',RODS) + CALL LCMGET(IPTRKT,'NRODR ',NRODR) + CALL LCMGET(IPTRKT,'RODR ',RODR) + CALL LCMGET(IPTRKT,'NRINFO ',NRINFO) + CALL LCMGET(IPTRKT,'NXRI ',NXRI) +*---- +* Produce legend +*---- + CALL PSPLEG(IPRINT,ISPSP ,ITYPE ,ICOLR ,NSUR ,NVOL , + > NAMLEG,NUNKNO,FLUX ,NREGT , + > MATALB,KEYMRG,KEYFLX,COLRG) +*---- +* Produce graphical description of geometry +*---- + CALL PSPXCG(IPRINT,ISPSP ,ICOLR ,NBAN ,NRT ,MSROD , + > NSURX ,NSUR ,NVOL ,COTE , + > RAN ,NRODS ,RODS ,RODR ,NRINFO,NRODR , + > NXRI ,KEYMRG,COLRG) + DEALLOCATE(RODR,RODS,RAN) + DEALLOCATE(NXRI,NRINFO,NRODR,NRODS) + ELSE IF(ITROP .EQ. 2 ) THEN +*---- +* EXCELL based hexagonal geometries +* Not available yet +*---- +* CALL PSPXHX(IPRINT,IPTRKT,TITREC) + WRITE(IOUT,6001) + ELSE IF(ITROP .EQ. 1 ) THEN +*---- +* EXCELL based Cartesian geometries +*---- + NTOTCL=NSURX + MAXR=NBAN + ALLOCATE(MINDIM(NTOTCL),MAXDIM(NTOTCL),INDEX(4*NUNK)) + ALLOCATE(REMSH(MAXR)) + CALL LCMGET(IPTRKT,'MINDIM ',MINDIM) + CALL LCMGET(IPTRKT,'MAXDIM ',MAXDIM) + CALL LCMGET(IPTRKT,'INDEX ',INDEX) + CALL LCMGET(IPTRKT,'REMESH ',REMSH) + IF(NDIM .EQ. 2) THEN +*---- +* Produce legend +*---- + CALL PSPLEG(IPRINT,ISPSP ,ITYPE ,ICOLR ,NSUR ,NVOL , + > NAMLEG,NUNKNO,FLUX ,NREGT , + > MATALB,KEYMRG,KEYFLX,COLRG) +*---- +* Produce graphical description of geometry +*---- + CALL PSPXEL(IPRINT,ISPSP ,ICOLR ,NDIM ,NSUR ,NVOL , + > NTOTCL,MAXR ,MINDIM,MAXDIM,KEYMRG, + > INDEX ,REMSH,COLRG) + ELSE + WRITE(IOUT,9000) + ENDIF + DEALLOCATE(REMSH) + DEALLOCATE(INDEX,MAXDIM,MINDIM) + ENDIF + CALL LCMSIX(IPTRKT,'EXCELL ',2) + ENDIF + DEALLOCATE(MATALB,KEYMRG,COLRG,KEYFLX) +*---- +* Processing finished: +* print routine closing output header if required +* and return +*---- + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6002 FORMAT(' Processing geometry ',A12) + 9000 FORMAT(' PSP: does not work yet for 3-D', + > ' Cartesian geometries') + END diff --git a/Dragon/src/PSPXCG.f b/Dragon/src/PSPXCG.f new file mode 100644 index 0000000..7b64d4f --- /dev/null +++ b/Dragon/src/PSPXCG.f @@ -0,0 +1,295 @@ +*DECK PSPXCG + SUBROUTINE PSPXCG(IPRINT,ISPSP ,ICOLR ,NBAN ,NRT ,MSROD , + > NSURX ,NSUR ,NVOL ,COTE , + > RAN ,NRODS ,RODS ,RODR ,NRINFO,NRODR , + > NXRI ,KEYMRG,COLREG) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Graphics for 2-D cluster geometry. +* +*Copyright: +* Copyright (C) 1999 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPRINT print level. +* ISPSP psp file unit. +* ICOLR color set used: +* = -4 fill hsb with no-contour; +* = -3 fill cmyk with no-contour; +* = -2 fill rgb with no-contour; +* = -1 fill bw with no-contour; +* = 0 no fill contour only; +* = 1 fill bw and contour; +* = 2 fill rgb and contour; +* = 3 fill cmyk and contour; +* = 4 fill hsb and contour. +* NBAN number of concentric regions. +* NRT number of rod types. +* MSROD maximum number of subrods per rod. +* NSURX number of surfaces. +* NSUR number of surfaces. +* NVOL number of regions. +* COTE Y dimension for rectangle. +* RAN radius/lattice side of region. +* NRODS integer description of rod type: +* NRODS(1,IRT) = number of rod; +* NRODS(2,IRT) = number of subrods in rod; +* NRODS(3,IRT) = associated annulus. +* RODS description of rod of a given type: +* RODS(1,IRT) = rod center radius; +* RODS(2,IRT) = angle position of one rod. +* RODR subrod radii. +* NRINFO annular region content: +* NRINFO(1,IAN) = new region number; +* NRINFO(2,IAN) = associated cluster; +* = 0 no cluster. +* NRODR subrod region. +* NXRI annular region content multi-rod. +* KEYMRG merge index. +* COLREG region color. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE + INTEGER IOUT,NPTS + REAL PI,DIMX,DIMY,WLINE + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NPTS=6,PI=3.1415926535897932, + > DIMX=3.5,DIMY=3.5,WLINE=0.002,NAMSBR='PSPXCG') +*---- +* ROUTINE PARAMETERS +*---- + INTEGER IPRINT,ISPSP,ICOLR,NBAN,NRT,MSROD,NSURX, + > NSUR,NVOL + INTEGER NRODS(3,NRT),NRINFO(2,NBAN),NRODR(NRT), + > NXRI(NRT,NBAN),KEYMRG(NSUR:NVOL) + REAL COTE,RAN(NBAN),RODS(2,NRT), + > RODR(MSROD,NRT),COLREG(4,NVOL) +*---- +* LOCAL PARAMETERS +*---- + INTEGER ICOL,ICONT,IVOL,IMRG,NTAN,IPT,IRT, + > NPROD,NINRD,IROD,ISBR,IAN,NSEG,KRT,JRT + REAL XYPOS(2,NPTS),RADEQ,FACT,ANGD,ANGR(2), + > DANGR,RPIN,RROD,XINT,ANGA, + > WLFAC + INTEGER KFS,KFR,KSS,KSR +*---- +* INITIALIZE +* ICOL FOR COLOR (NONE, BW, RGB) +* ICONT FOR CONTOUR (WITH OR WITHOUT CONTOUR) +*---- + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + KFS=0 + KFR=0 + KSS=0 + KSR=0 + ICONT=1 + WLFAC=1.0 + ICOL=ABS(ICOLR) + IF(ICOLR .EQ. 0) THEN + WLFAC=2.5 + ELSE IF(ICOLR .LT. 0) THEN + ICONT=0 + ELSE + KFS=1 + KSR=1 + ENDIF +*---- +* LOCATE PEN AT CENTER OF CELL +* DETERMINE DIMENSION OF GRAPH USING CELL LIMIT +* FOR HEXAGONAL CELL PRINT HEXAGONAL REGION +* FOR CARTESIAN CELL PRINT CARTESIAN REGION +*---- + XYPOS(1,1)=DIMX + XYPOS(2,1)=DIMY + CALL PSMOVE(ISPSP,XYPOS,-3) + IF(NSURX.EQ.6) THEN + RADEQ=RAN(NBAN) + FACT=DIMX/RADEQ + RADEQ=DIMX + NTAN=NBAN-1 +*---- +* POSITION OF POINTS DEFINING THE HEXAGONAL SHAPE TO FILL +*---- + ANGD=0.0 + DO 100 IPT=1,NSURX + XYPOS(1,IPT)=COS(ANGD)*RADEQ + XYPOS(2,IPT)=SIN(ANGD)*RADEQ + ANGD=ANGD+PI/3.0 + 100 CONTINUE + IVOL=NRINFO(1,NBAN) + IMRG=KEYMRG(IVOL) +*---- +* FILL IF REQUIRED +*---- + CALL PSDREG(ISPSP,NSURX,XYPOS) + IF(ICOL. GT. 0) THEN + CALL PSFILL(ISPSP,ICOL,COLREG(1,IVOL),KFS,KFR) + ENDIF +*---- +* STROKE CONTOUR IF REQUIRED +*---- + IF(ICONT .EQ. 1) THEN + CALL PSSTRK(ISPSP,WLFAC*WLINE,KSS,KSR) + ENDIF + ELSE IF(NSURX.EQ.4) THEN + RADEQ=0.5*MAX(RAN(NBAN),COTE) + FACT=DIMX/RADEQ + NTAN=NBAN-1 + XYPOS(1,1)=FACT*RAN(NBAN)/2 + XYPOS(2,1)=FACT*COTE/2 + XYPOS(1,2)=-XYPOS(1,1) + XYPOS(2,2)=XYPOS(2,1) + XYPOS(1,3)=XYPOS(1,2) + XYPOS(2,3)=-XYPOS(2,2) + XYPOS(1,4)=XYPOS(1,1) + XYPOS(2,4)=XYPOS(2,3) + IVOL=NRINFO(1,NBAN) + IMRG=KEYMRG(IVOL) +*---- +* FILL IF REQUIRED +*---- + CALL PSDREG(ISPSP,NSURX,XYPOS) + IF(ICOL. GT. 0) THEN + CALL PSFILL(ISPSP,ICOL,COLREG(1,IVOL),KFS,KFR) + ENDIF +*---- +* STROKE CONTOUR IF REQUIRED +*---- + IF(ICONT .EQ. 1) THEN + CALL PSSTRK(ISPSP,WLFAC*WLINE,KSS,KSR) + ENDIF + ELSE + FACT=DIMX/RAN(NBAN) + NTAN=NBAN + ENDIF +*---- +* ANNULAR REGIONS +*---- + DO 110 IAN=NTAN,1,-1 + RADEQ=FACT*RAN(IAN) + XYPOS(1,1)=0.0 + XYPOS(2,1)=0.0 + IVOL=NRINFO(1,IAN) + IMRG=KEYMRG(IVOL) +*---- +* FILL IF REQUIRED +*---- + IF(ICOL. GT. 0) THEN + CALL PSDCIR(ISPSP,XYPOS,RADEQ) + CALL PSFILL(ISPSP,ICOL,COLREG(1,IVOL),0,0) + ENDIF +*---- +* STROKE CONTOUR IF REQUIRED +*---- + IF(ICONT .EQ. 1) THEN + IF(NRINFO(2,IAN) .NE. 0) THEN + NSEG=0 + DO 111 KRT=NRINFO(2,IAN),1,-1 + JRT=NXRI(KRT,IAN) + IF(JRT .GT. 1000000 .AND. JRT .LT. 3000000) THEN + IRT=MOD(JRT,1000000) + NSEG=NSEG+1 +*---- +* IF ANNULAR REGION CUT BY PINS +* DRAW ARC SEGMENT +*---- + NPROD=NRODS(1,IRT) + NINRD=NRODS(2,IRT) + DANGR=2.*PI/FLOAT(NPROD) + ANGD=RODS(2,IRT) + RROD=FACT*RODR(NINRD,IRT) + RPIN=FACT*RODS(1,IRT) +*---- +* ANNULUS INTERSECT RODS +* 1) FIND X (XINT) AND Y (YINT) INTERSECTION +* XINT=(RADEQ**2+RPIN**2-RROD**2)/(2*RPIN) +* YINT=SQRT(RAN**2-XINT**2) +* 2) FIND OPENNING ANGLE FOR VOLUME LIMITED BY +* ANNULUS (ANGA) +* ANGA=ACOS(XINT/RADEQ) +*---- + XINT=(RADEQ**2+RPIN**2-RROD**2) + > /(2.0*RPIN) + ANGA=ACOS(XINT/RADEQ) + DO 112 IROD=1,NPROD + ANGR(1)=180.0*(ANGD+ANGA)/PI + ANGD=ANGD+DANGR + ANGR(2)=180.0*(ANGD-ANGA)/PI + CALL PSLINW(ISPSP,WLFAC*WLINE) + CALL PSSARC(ISPSP,XYPOS,RADEQ,ANGR) + 112 CONTINUE + ENDIF + 111 CONTINUE + IF(NSEG .EQ. 0) THEN + CALL PSDCIR(ISPSP,XYPOS,RADEQ) + CALL PSSTRK(ISPSP,WLFAC*WLINE,0,0) + ENDIF + ELSE +*---- +* IF ANNULAR REGION NOT CUT BY PINS +* STROKE CIRCLES +*---- + CALL PSDCIR(ISPSP,XYPOS,RADEQ) + CALL PSSTRK(ISPSP,WLFAC*WLINE,0,0) + ENDIF + ENDIF + 110 CONTINUE +*---- +* ROD CLUSTER +*---- + DO 120 IRT=NRT,1,-1 + NPROD=NRODS(1,IRT) + NINRD=NRODS(2,IRT) + DANGR=2.*PI/FLOAT(NPROD) + ANGD=RODS(2,IRT) + RPIN=FACT*RODS(1,IRT) + DO 121 IROD=1,NPROD + XYPOS(1,1)=RPIN*COS(ANGD) + XYPOS(2,1)=RPIN*SIN(ANGD) + ANGD=ANGD+DANGR + DO 122 ISBR=NINRD,1,-1 + IVOL=NRODR(IRT)-NINRD+ISBR + IMRG=KEYMRG(IVOL) + RADEQ=FACT*RODR(ISBR,IRT) +*---- +* FILL IF REQUIRED +*---- + CALL PSDCIR(ISPSP,XYPOS,RADEQ) + IF(ICOL. GT. 0) THEN + CALL PSFILL(ISPSP,ICOL,COLREG(1,IVOL),KFS,KFR) + ENDIF +*---- +* STROKE IF REQUIRED +*---- + IF(ICONT .EQ. 1) THEN + CALL PSSTRK(ISPSP,WLFAC*WLINE,KSS,KSR) + ENDIF + 122 CONTINUE + 121 CONTINUE + 120 CONTINUE + XYPOS(1,1)=-DIMX + XYPOS(2,1)=-DIMY + CALL PSMOVE(ISPSP,XYPOS,-3) + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + END diff --git a/Dragon/src/PSPXEL.f b/Dragon/src/PSPXEL.f new file mode 100644 index 0000000..c09c113 --- /dev/null +++ b/Dragon/src/PSPXEL.f @@ -0,0 +1,200 @@ +*DECK PSPXEL + SUBROUTINE PSPXEL(IPRINT,ISPSP ,ICOLR ,NDIM ,NSUR ,NVOL , + > NTOTCL,MAXR , + > MINDIM,MAXDIM,KEYMRG,INDEX ,REMESH,COLREG) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Graphics for 2-D cluster geometry. +* +*Copyright: +* Copyright (C) 1999 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPRINT print level. +* ISPSP psp file unit. +* ICOLR color set used: +* = -4 fill hsb with no-contour; +* = -3 fill cmyk with no-contour; +* = -2 fill rgb with no-contour; +* = -1 fill bw with no-contour; +* = 0 no fill contour only; +* = 1 fill bw and contour; +* = 2 fill rgb and contour; +* = 3 fill cmyk and contour; +* = 4 fill hsb and contour. +* NDIM number of dimensions. +* NSUR number of surfaces. +* NVOL number of regions. +* NTOTCL number of cylinders. +* MAXR dimension of REMESH vector. +* MINDIM min index values for axes. +* MAXDIM max index values for axes. +* KEYMRG merge index. +* INDEX numbering of surfaces and zones. +* REMESH meshing. +* COLREG region color. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE + INTEGER IOUT,NPTS,MXDIM,NXY,NINT + CHARACTER NAMSBR*6 + REAL PI,DIMX,DIMY,WLINE + PARAMETER (IOUT=6,NPTS=4,MXDIM=3,NXY=2,NINT=16, + > PI=3.1415926535897932, + > DIMX=3.5,DIMY=3.5,WLINE=0.002,NAMSBR='PSPXEL') +*---- +* ROUTINE PARAMETERS +*---- + INTEGER IPRINT,ISPSP,ICOLR,NDIM, + > NSUR,NVOL,NTOTCL,MAXR + INTEGER MINDIM(NTOTCL),MAXDIM(NTOTCL), + > KEYMRG(NSUR:NVOL),INDEX(4,NSUR:NVOL) + REAL REMESH(MAXR),COLREG(4,NVOL) +*---- +* LOCAL PARAMETERS +*---- + INTEGER ICOL,ICONT,IDIR,IVOL,IMRG, + > IX,IY,IR,ICL,NSEG,IORDER(NINT) + REAL WLFAC,RCIRC,OFFDIR(MXDIM),XYPOS(NXY,NPTS), + > FACT,CENTER(NXY),RADANG(NXY,NINT) + INTEGER KFS,KFR,KSS,KSR +*---- +* INITIALIZE +* ICOL FOR COLOR (NONE, BW, RGB) +* ICONT FOR CONTOUR (WITH OR WITHOUT CONTOUR) +*---- + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + KFS=0 + KFR=0 + KSS=0 + KSR=0 + ICONT=1 + WLFAC=1.0 + ICOL=ABS(ICOLR) + IF(ICOLR .EQ. 0) THEN + WLFAC=2.5 + ELSE IF(ICOLR .LT. 0) THEN + ICONT=0 + ELSE + KFS=1 + KSR=1 + ENDIF +*---- +* COMPUTE THE CIRCUMSCRIBED RADIUS +* THE COORDINATE FOR THE TRUE CENTER OF THE CELL +*---- + RCIRC= 0.0 + DO 100 IDIR=1,NDIM + OFFDIR(IDIR)=0.5 + > *(REMESH(MAXDIM(IDIR))+REMESH(MINDIM(IDIR))) + RCIRC=MAX(RCIRC, + > 0.5*(REMESH(MAXDIM(IDIR))-REMESH(MINDIM(IDIR)))) + 100 CONTINUE +*---- +* LOCATE PEN AT CENTER OF CELL +* DETERMINE DIMENSION OF GRAPH USING CELL LIMIT +* FOR HEXAGONAL CELL PRINT HEXAGONAL REGION +* FOR CARTESIAN CELL PRINT CARTESIAN REGION +*---- + XYPOS(1,1)=DIMX + XYPOS(2,1)=DIMY + CALL PSMOVE(ISPSP,XYPOS(1,1),-3) + FACT=DIMX/RCIRC +*---- +* SCAN ALL REGIONS AND LOCATE POSITION +* REGION NUMBER FROM INSIDE ANNULUS +* TO EXTERIOR CARTESIAN +*---- + DO 110 IVOL=NVOL,1,-1 + IMRG=KEYMRG(IVOL) + IF(IMRG .NE. 0) THEN +*---- +* CARTESIAN CELL POSITION IN X AND Y +*---- + IX=INDEX(1,IVOL) + IY=INDEX(2,IVOL) + XYPOS(1,1)=FACT*(REMESH(IX)-OFFDIR(1)) + XYPOS(2,1)=FACT*(REMESH(IY)-OFFDIR(2)) + XYPOS(1,2)=FACT*(REMESH(IX+1)-OFFDIR(1)) + XYPOS(2,2)=XYPOS(2,1) + XYPOS(1,3)=XYPOS(1,2) + XYPOS(2,3)=FACT*(REMESH(IY+1)-OFFDIR(2)) + XYPOS(1,4)=XYPOS(1,1) + XYPOS(2,4)=XYPOS(2,3) + IF(INDEX(4,IVOL) .EQ. 0) THEN +*---- +* CARTESIAN POSITION GEOMETRY LOCATED +* COLOR AND TRACE IT +*---- + CALL PSDREG(ISPSP,NPTS,XYPOS) + IF(ICOL. GT. 0) THEN + CALL PSFILL(ISPSP,ICOL,COLREG(1,IVOL),KFS,KFR) + ENDIF + IF(ICONT.EQ.1) THEN + CALL PSSTRK(ISPSP,WLFAC*WLINE,KSS,KSR) + ENDIF + ELSE +*---- +* CARTESIAN GEOMETRY CONTAINS ANNULAR SUBDIVISION +* DETERMINE WHICH ANNULUS +*---- + DO 111 ICL=4,NTOTCL + IR=INDEX(4,IVOL) + IF( IR .GE. MINDIM(ICL)-1 .AND. + > IR .LT. MAXDIM(ICL) ) THEN +*---- +* ANNULUS IS DETERMINED +* LOCATE ANNULAR/CARTESIAN AND ORDER CARTESIAN POINTS +* FOR GEOMETRY TRACING +*---- + CENTER(1)=FACT*(REMESH(MINDIM(ICL)-2)-OFFDIR(1)) + CENTER(2)=FACT*(REMESH(MINDIM(ICL)-1)-OFFDIR(2)) + RCIRC=FACT*SQRT(REMESH(IR+1)) + CALL PSPRAI(NINT,NPTS,XYPOS,CENTER,RCIRC, + > NSEG,IORDER,RADANG) +*---- +* COLOR AND TRACE RESULT +*---- + CALL PSMOVE(ISPSP,CENTER(1),-3) + CALL PSDRAI(ISPSP,NSEG,IORDER,CENTER,RADANG) + IF(ICOL. GT. 0) THEN + CALL PSFILL(ISPSP,ICOL,COLREG(1,IVOL),KFS,KFR) + ENDIF + IF(ICONT.EQ.1) THEN + CALL PSSTRK(ISPSP,WLFAC*WLINE,KSS,KSR) + ENDIF + CENTER(1)=-CENTER(1) + CENTER(2)=-CENTER(2) + CALL PSMOVE(ISPSP,CENTER(1),-3) + GO TO 115 + ENDIF + 111 CONTINUE + 115 CONTINUE + ENDIF + ENDIF + 110 CONTINUE + XYPOS(1,1)=-DIMX + XYPOS(2,1)=-DIMY + CALL PSMOVE(ISPSP,XYPOS(1,1),-3) + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + END diff --git a/Dragon/src/QIJCMP.f b/Dragon/src/QIJCMP.f new file mode 100644 index 0000000..2e67e04 --- /dev/null +++ b/Dragon/src/QIJCMP.f @@ -0,0 +1,115 @@ +*DECK QIJCMP + SUBROUTINE QIJCMP(NREG,NSOUT,NPIJ,NGRP,NCOR,VOLSUR,SIGTAL,DPR, + > NPSYS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compression of PIJ matrices in symmetric format. +* +*Copyright: +* Copyright (C) 1994 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* NREG number of zones for geometry. +* NSOUT number of surfaces for geometry. +* NPIJ number of probabilities in one group. +* NGRP number of groups. +* NCOR maximum number of corners. +* VOLSUR volumes. +* SIGTAL materials and albedos. +* NPSYS non-converged energy group indices. +* +*Parameters: input/output +* DPR collision probabilities on input and +* compress probability matrix at output. +* +*Comments: +* Format of compress probability matrix +* NPLEN=(NREG+NSOUT+2)*(NREG+NSOUT+1)/2 +* IND(I,J)=MAX(I+NSOUT+1,J+NSOUT+1) +* *(MAX(I+NSOUT+1,J+NSOUT+1)-1)/2 +* +MIN(I+NSOUT+1,J+NSOUT+1) +* IS=-NSOUT,-1; JS=-NSOUT,IS; I=IND(IS,JS) +* PROB(I)=VOLSUR(IS)*PSS(IS,JS) +* IV=1,NREG; JS=-NSOUT,-1; I=IND(IV,JS) +* SIGT(IV).GT.0.0 +* PROB(I)=SIGT(IV)*VOLSUR(IV)*PVS(IV,JS) +* SIGT(IV).EQ.0.0 +* PROB(I)=VOLSUR(IV)*PVS(IV,JS) +* IV=1,NREG; JV=1,IV; I=IND(IV,JV) +* SIGT(IV).GT.0.0 AND SIGT(JV).GT.0.0 +* PROB(I)=SIGT(IV)*SIGT(JV)*VOLSUR(IV)*PVV(IV,JV) +* SIGT(IV).GT.0.0 AND SIGT(JV).EQ.0.0 +* PROB(I)=SIGT(IV)*VOLSUR(IV)*PVV(IV,JV) +* SIGT(IV).EQ.0.0 AND SIGT(JV).GT.0.0 +* PROB(I)=SIGT(JV)*VOLSUR(IV)*PVV(IV,JV) +* SIGT(IV).EQ.0.0 AND SIGT(JV).EQ.0.0 +* PROB(I)=VOLSUR(IV)*PVV(IV,JV) +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE + INTEGER NREG,NSOUT,NPIJ,NGRP,NCOR,NPSYS(NGRP) + INTEGER IPR,IL,JL,IG,INDIJ + REAL VOLSUR(NSOUT:NREG),SIGTAL(NSOUT:NREG,NGRP),ZERO + DOUBLE PRECISION DPR(NPIJ,NGRP),ZCOR,ZCOR1,DZERO + PARAMETER ( ZERO=0.0, DZERO=0.0D0 ) +C---- +C SYMMETRIZE AND STORE IN PROB +C---- + INDIJ= 0 + DO 5 IL = 1, NREG-NSOUT+1 + INDIJ= INDIJ + IL + DO 1 IG= 1, NGRP + IF(NPSYS(IG).NE.0) + > DPR(INDIJ,IG)= DPR(INDIJ,IG) + DPR(INDIJ,IG) + 1 CONTINUE + 5 CONTINUE + IF( NCOR.NE.1 )THEN + ZCOR1= 1.0D0/DBLE(NCOR) + ZCOR= 1.0D0/DBLE(NCOR*NCOR) + INDIJ= 0 + DO 35 IL = NSOUT, NREG + IF( IL.GT.0 ) ZCOR= ZCOR1 + DO 25 JL = NSOUT, IL + INDIJ= INDIJ + 1 + IF( JL.GT.0 ) ZCOR= 1.0D0 + DO 15 IG= 1, NGRP + IF(NPSYS(IG).NE.0) + > DPR(INDIJ,IG)= ZCOR * DPR(INDIJ,IG) + 15 CONTINUE + 25 CONTINUE + 35 CONTINUE + ENDIF + IPR=-((1-NSOUT)*NSOUT)/2 + DO 80 IL= NSOUT,-1 + IPR= IPR+1 + DO 70 IG= 1, NGRP + IF(NPSYS(IG).NE.0) DPR(IPR,IG)= DBLE(VOLSUR(IL)) + 70 CONTINUE + 80 CONTINUE + IPR= IPR+1 + DO 90 IG= 1, NGRP + DPR(IPR,IG)= DZERO + 90 CONTINUE + DO 110 IL= 1,NREG + IPR= IPR-NSOUT+IL + DO 100 IG= 1, NGRP + IF(NPSYS(IG).EQ.0) GO TO 100 + IF( SIGTAL(IL,IG).EQ.ZERO )THEN + DPR(IPR,IG)= DBLE(VOLSUR(IL)) + ELSE + DPR(IPR,IG)= DBLE(VOLSUR(IL)*SIGTAL(IL,IG)) + ENDIF + 100 CONTINUE + 110 CONTINUE +C + RETURN + END diff --git a/Dragon/src/QIJI3D.f b/Dragon/src/QIJI3D.f new file mode 100644 index 0000000..59dde2c --- /dev/null +++ b/Dragon/src/QIJI3D.f @@ -0,0 +1,188 @@ +*DECK QIJI3D + SUBROUTINE QIJI3D(NREG,NSOUT,NPIJ,NGRP,MXSEG,NCOR,SWVOID,LINE, + > WEIGHT,NUMERO,LENGHT,SIGTAL,NPSYS,DPR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Integration for general 3D isotropic tracking. +* +*Copyright: +* Copyright (C) 1991 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* NREG total number of regions. +* NSOUT number of outer surface. +* NPIJ number of probabilities in one group. +* NGRP number of groups. +* MXSEG number of segemnts on line. +* NCOR maximum number of corners. +* SWVOID flag to indicate if there are voids. +* LINE line number. +* WEIGHT line weight. +* NUMERO region crossed by track. +* LENGHT length of track. +* SIGTAL albedo-cross section vector. +* NPSYS non-converged energy group indices. +* +*Parameters: output +* DPR CP matrix. +* +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE + INTEGER NREG,NSOUT,NPIJ,NGRP,MXSEG,NCOR, NUMERO(*), + > ISD(6),ISF(6),LIN2C,IL,JL,IG,LINE,NOIL,IND1, + > IND2,I,J,IN0,IN1,IN2,NPSYS(NGRP),NUNK + REAL WEIGHT, SIGTAL(-NSOUT:NREG,NGRP) + DOUBLE PRECISION LENGHT(*), DPR(NPIJ,NGRP), XSIL, XSIL2 + LOGICAL SWVOID + REAL ZERO, ONE, HALF + PARAMETER ( ZERO=0.0E0, ONE=1.0E0, HALF=0.5E0) + REAL SIXT,CUTEXP + PARAMETER ( CUTEXP=0.02) +* +* Allocated arrays + INTEGER, ALLOCATABLE, DIMENSION(:) :: NRSEG + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DSCBEG, DSCEND, + > SEGLEN, PRODUC + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: STAYIN, GOSOUT + + IN0(I) = ((I+NSOUT+1)*(I+NSOUT+2))/2 + IN1(I,J) = ((I+NSOUT+1)*(I+NSOUT))/2 + (J+NSOUT+1) + IN2(I,J) = (MAX(I+NSOUT+1,J+NSOUT+1)* + > (MAX(I+NSOUT+1,J+NSOUT+1)-1))/2 + > + MIN(I+NSOUT+1,J+NSOUT+1) +* +* Scratch storage allocation + ALLOCATE(NRSEG(MXSEG)) + ALLOCATE(DSCBEG(NGRP), DSCEND(NGRP), SEGLEN(MXSEG), PRODUC(NGRP)) + ALLOCATE(STAYIN(NGRP,MXSEG),GOSOUT(NGRP,MXSEG)) +* + SIXT=HALF/3.0 + NUNK=NSOUT+NREG+1 +* +* 0) REFORMAT TRACKING LINE + LIN2C= LINE-2*NCOR + DO 10 JL= 1, NCOR + ISD(JL)= NUMERO(JL) + ISF(JL)= NUMERO(NCOR+LIN2C+JL) + 10 CONTINUE + DO 20 IL= 1, LIN2C + NRSEG(IL)= NUMERO(NCOR+IL) + SEGLEN(IL)= LENGHT(NCOR+IL) + 20 CONTINUE + DO 90 IG= 1, NGRP + PRODUC(IG)= WEIGHT + 90 CONTINUE +* + IF( SWVOID )THEN +* +* 1) VOIDS ARE POSSIBLE +* PII CALCULATION AND ESCAPE + DO 240 IL = 1,LINE-2*NCOR + NOIL = NRSEG(IL) + IND1 = IN0(NOIL) + DO 100 IG= 1, NGRP + IF(NPSYS(IG).EQ.0) GO TO 100 + XSIL=SIGTAL(NOIL,IG)*SEGLEN(IL) + IF( XSIL.EQ.ZERO )THEN + GOSOUT(IG,IL)= ONE + STAYIN(IG,IL)= SEGLEN(IL) + DPR(IND1,IG)= DPR(IND1,IG) + > + HALF*WEIGHT*SEGLEN(IL)*SEGLEN(IL) + ELSE IF(XSIL .LT. CUTEXP) THEN + XSIL2=XSIL*XSIL + STAYIN(IG,IL)=XSIL-XSIL2*(HALF-SIXT*XSIL) + GOSOUT(IG,IL)=ONE-STAYIN(IG,IL) + PRODUC(IG)= PRODUC(IG) * GOSOUT(IG,IL) + DPR(IND1,IG)= DPR(IND1,IG) + > + WEIGHT*XSIL2*(HALF-SIXT*XSIL) + ELSE + GOSOUT(IG,IL)= EXP( -XSIL ) + STAYIN(IG,IL)= (ONE - GOSOUT(IG,IL)) + PRODUC(IG)= PRODUC(IG) * GOSOUT(IG,IL) + DPR(IND1,IG)= DPR(IND1,IG) + > + WEIGHT*(XSIL-STAYIN(IG,IL)) + ENDIF + 100 CONTINUE + 240 CONTINUE + ELSE + DO 241 IL = 1,LINE-2*NCOR + NOIL = NRSEG(IL) + IND1 = IN0(NOIL) + DO 101 IG= 1, NGRP + IF(NPSYS(IG).EQ.0) GO TO 101 + XSIL=SIGTAL(NOIL,IG)*SEGLEN(IL) + IF(XSIL .LT. CUTEXP) THEN + XSIL2=XSIL*XSIL + STAYIN(IG,IL)=XSIL-XSIL2*(HALF-SIXT*XSIL) + GOSOUT(IG,IL)=ONE-STAYIN(IG,IL) + PRODUC(IG)= PRODUC(IG) * GOSOUT(IG,IL) + DPR(IND1,IG)= DPR(IND1,IG) + > + WEIGHT*XSIL2*(HALF-SIXT*XSIL) + ELSE + GOSOUT(IG,IL)= EXP( -XSIL ) + STAYIN(IG,IL)= (ONE - GOSOUT(IG,IL)) + PRODUC(IG)= PRODUC(IG) * GOSOUT(IG,IL) + DPR(IND1,IG)= DPR(IND1,IG) + > + WEIGHT*(XSIL-STAYIN(IG,IL)) + ENDIF + 101 CONTINUE + 241 CONTINUE + ENDIF +* PIJ CALCULATION + DO 120 IG= 1, NGRP + DSCBEG(IG)= WEIGHT + 120 CONTINUE + DO 260 IL = 1, LINE-2*NCOR + NOIL = NRSEG(IL) + DO 130 IG= 1, NGRP + IF(NPSYS(IG).NE.0) DSCEND(IG)= WEIGHT*STAYIN(IG,IL) + 130 CONTINUE + DO 250 JL = IL+1, LINE-2*NCOR + IND2= IN2(NRSEG(JL),NOIL) + DO 140 IG= 1, NGRP + IF(NPSYS(IG).EQ.0) GO TO 140 + DPR(IND2,IG)= DPR(IND2,IG) + STAYIN(IG,JL)*DSCEND(IG) + DSCEND(IG)= DSCEND(IG)*GOSOUT(IG,JL) + 140 CONTINUE + 250 CONTINUE +* PIS CALCULATION + DO 261 JL = 1, NCOR + IND1= IN1(NOIL,ISD(JL)) + IND2= IN1(NOIL,ISF(JL)) + DO 150 IG= 1, NGRP + IF(NPSYS(IG).EQ.0) GO TO 150 + DPR(IND1,IG)= DPR(IND1,IG) + DSCBEG(IG)*STAYIN(IG,IL) + DPR(IND2,IG)= DPR(IND2,IG) + DSCEND(IG) + 150 CONTINUE + 261 CONTINUE + DO 160 IG= 1, NGRP + IF(NPSYS(IG).NE.0) DSCBEG(IG)= DSCBEG(IG)*GOSOUT(IG,IL) + 160 CONTINUE + 260 CONTINUE +* PSS CALCULATION + DO 265 IL = 1, NCOR + DO 264 JL = 1, NCOR + IND2= IN2(ISD(IL),ISF(JL)) + DO 170 IG = 1, NGRP + IF(NPSYS(IG).NE.0) DPR(IND2,IG)= DPR(IND2,IG) + PRODUC(IG) + 170 CONTINUE + 264 CONTINUE + 265 CONTINUE +* +* Scratch storage deallocation + DEALLOCATE(GOSOUT,STAYIN) + DEALLOCATE(PRODUC,SEGLEN,DSCEND,DSCBEG) + DEALLOCATE(NRSEG) +* + RETURN + END diff --git a/Dragon/src/READBH.f b/Dragon/src/READBH.f new file mode 100644 index 0000000..51496bf --- /dev/null +++ b/Dragon/src/READBH.f @@ -0,0 +1,220 @@ +*DECK READBH + SUBROUTINE READBH (MAXPTS,IPGEOM,IR,IR2,NREG,NREG2,MAT,VOL,NG, + 1 NSMAX,MICRO,NS,IBI,RS,FRACT,VOLK,IMPX,IDIL,MIXGR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover the input data for the double heterogeneity option (Bihet). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXPTS allocated storage for arrays of dimension NREG. +* IPGEOM pointer to the geometry LCM object (L_GEOM signature). +* IR2 number of ordinary and composite mixtures (a mixture that +* include a micro structure). +* NREG2 number of volumes in the macro geometry. +* NG number of different kind of micro structures. A kind of +* micro structure is characterized by the radius of its +* tubes or shells. All the micro volumes of the same kind +* should own the same nuclear properties in a given volume +* of the macro geometry. +* NSMAX maximum number of volumes (tubes or shells) in each kind +* of micro structure). +* IBI type of composite mixture in each volume of the macro +* geometry. If IBI(IKK) is greater than IR, the volume IKK +* contains a micro structure. +* IMPX print flag (equal to zero for no print). +* +*Parameters: input/output +* VOL volumes of the macro geometry on input and +* volumes of the composite geometry at output. +* +*Parameters: output +* IR number of ordinary mixtures. +* NREG number of volumes in the composite geometry. +* MAT index-number of the mixture type assigned to each volume +* of the composite geometry. +* MICRO type of micro volumes: =3 cylinder; =4 sphere. +* NS number of tubes or shells in each kind of micro structure. +* RS radius of the micro volumes. +* FRACT volumic fractions of each type of micro volumes in each +* ordinary or composite mixture. +* VOLK volumic fractions of the tubes or shells in the micro volumes. +* IDIL elementary mixture indices in the diluent of the composite +* mixtures. +* MIXGR elementary mixture indices in the micro structures. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPGEOM + INTEGER MAXPTS,IR,IR2,NREG,NREG2,MAT(MAXPTS),NG,NSMAX,MICRO, + 1 NS(NG),IBI(NREG2),IMPX,IDIL(IR2),MIXGR(NSMAX,NG,IR2) + REAL VOL(MAXPTS),RS(NSMAX+1,NG),FRACT(NG,IR2),VOLK(NG,NSMAX) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + CHARACTER GEONAM*12,HSMG*131,TEXT12*12 + LOGICAL EMPTY,LCM + INTEGER ISTATE(NSTATE) + INTEGER, ALLOCATABLE, DIMENSION(:) :: MILIEU + REAL, ALLOCATABLE, DIMENSION(:) :: FTEMP +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(MILIEU(IR2)) + ALLOCATE(FTEMP(IR2)) +* + IDIL(:IR2)=0 + MIXGR(:NSMAX,:NG,:IR2)=0 + CALL LCMINF(IPGEOM,GEONAM,TEXT12,EMPTY,ILONG,LCM) + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) + NMILG=ISTATE(3) + MICRO=ISTATE(5) + IF(NMILG.GT.IR2) CALL XABORT('READBH: INVALID VALUE FOR IR2.') + CALL LCMGET(IPGEOM,'NS',NS) + CALL LCMGET(IPGEOM,'RS',RS) + CALL LCMGET(IPGEOM,'FRACT',FRACT) + CALL LCMGET(IPGEOM,'MILIE',MILIEU) + CALL LCMGET(IPGEOM,'MIXDIL',IDIL) + CALL LCMGET(IPGEOM,'MIXGR',MIXGR) +* + DO 30 J=1,NG + FACT=RS(NS(J)+1,J)**(MICRO-1) + W=0.0 + DO 20 K=1,NS(J) + ZZZ=RS(K+1,J)**(MICRO-1)/FACT + VOLK(J,K)=ZZZ-W + W=ZZZ + 20 CONTINUE + 30 CONTINUE +* + IND1=IR2 + DO 40 I=1,NMILG + IF(MILIEU(I).GT.IR2) THEN + WRITE (HSMG,390) MILIEU(I),IR2 + CALL XABORT(HSMG) + ENDIF + IND1=MIN(IND1,MILIEU(I)) + 40 CONTINUE +*---- +* SET-UP THE NEW VOLUMES +*---- + NREG=NREG2 + DO 90 IKK=1,NREG2 + MAT(IKK)=IBI(IKK) + IF(IBI(IKK).GE.IND1) THEN + IND=0 + DO 50 I=1,NMILG + IF(MILIEU(I).EQ.IBI(IKK)) IND=I + 50 CONTINUE + IF(IND.EQ.0) THEN + WRITE(HSMG,'(29HREADBH: A COMPOSITE MIXTURE (,I5,7H) IS NO, + 1 10HT DEFINED.)') IBI(IKK) + CALL XABORT(HSMG) + ENDIF + DILF=1.0 + DO 60 J=1,NG + DILF=DILF-FRACT(J,IND) + 60 CONTINUE + VHET=VOL(IKK) + MAT(IKK)=IDIL(IND) + VOL(IKK)=VHET*DILF + DO 80 J=1,NG + FRT=FRACT(J,IND) + IF(FRT.GT.0.00001) THEN + FACT=RS(NS(J)+1,J)**(MICRO-1) + W=0.0 + DO 70 K=1,NS(J) + ZZZ=RS(K+1,J)**(MICRO-1)/FACT + NREG=NREG+1 + MAT(NREG)=MIXGR(K,J,IND) + VOL(NREG)=VHET*FRT*(ZZZ-W) + W=ZZZ + 70 CONTINUE + ENDIF + 80 CONTINUE + ENDIF + 90 CONTINUE + IF(NREG.GT.MAXPTS) CALL XABORT('READBH: MAXPTS IS TOO SMALL.') + IR=0 + DO 100 I=1,NREG + IR=MAX(IR,MAT(I)) + 100 CONTINUE + IF(IR+1.GT.IR2) CALL XABORT('READBH: INVALID MIX NUMBERS.') + DO IND=1,IR2-IR + IF(IDIL(IND).EQ.0) THEN + WRITE(HSMG,'(15HREADBH: MIXTURE,I5,22H IS NOT USED IN THE GE, + 1 7HOMETRY.)') IR+IND-1 + CALL XABORT(HSMG) + ENDIF + ENDDO + DO 135 J=1,NG + DO 110 IND=1,NMILG + FTEMP(IND)=FRACT(J,IND) + 110 CONTINUE + DO 120 IND=1,IR2 + FRACT(J,IND)=0.0 + 120 CONTINUE + DO 130 IND=1,NMILG + FRACT(J,MILIEU(IND))=FTEMP(IND) + 130 CONTINUE + 135 CONTINUE +* + IF(IMPX.GE.1) THEN + WRITE (6,300) GEONAM + IF(MICRO.EQ.3) THEN + WRITE (6,'(44H THE MICRO STRUCTURE IS MADE OF TUBES OR CYL, + 1 7HINDERS./)') + ELSE IF(MICRO.EQ.4) THEN + WRITE (6,'(44H THE MICRO STRUCTURE IS MADE OF SPHERES OR S, + 1 16HPHERICAL SHELLS./)') + ENDIF + WRITE (6,360) NREG2,NG,NSMAX + WRITE (6,370) IR+1,IR2 + DO 140 J=1,NG + WRITE (6,310) J + WRITE (6,320) (RS(K,J),K=1,NS(J)+1) + WRITE (6,330) + WRITE (6,320) (FRACT(J,IBI(IKK)),IKK=1,NREG2) + 140 CONTINUE + WRITE (6,'(///)') + WRITE (6,400) NREG,MAXPTS,IR + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(FTEMP) + DEALLOCATE(MILIEU) + RETURN +* + 300 FORMAT (///50H BIHET: INTRODUCTION OF A MICRO STRUCTURE IN THE M, + 1 26HACRO GEOMETRY LOCATED IN ',A12,2H'./) + 310 FORMAT (//23H MICRO STRUCTURE NUMBER,I4//20H RADIUS OF THE MICRO, + 1 17H TUBES OR SHELLS:) + 320 FORMAT (1X,1P,10E12.5) + 330 FORMAT (/53H VOLUMIC CONCENTRATIONS OF THE MICRO STRUCTURE IN EAC, + 1 31HH VOLUME OF THE MACRO GEOMETRY:) + 360 FORMAT (/42H NUMBER OF VOLUMES IN THE MACRO GEOMETRY =,I6/ + 1 38H NUMBER OF KINDS OF MICRO STRUCTURES =,I6/ + 2 49H MAXIMUM NUMBER OF VOLUMES IN A MICRO STRUCTURE =,I6/) + 370 FORMAT (/51H THE INDEX-NUMBERS OF THE MIXTURES WITH A MICRO STR, + 1 21HUCTURE VARIES BETWEEN,I6,4H AND,I6,1H.) + 390 FORMAT (34HREADBH: THE INPUT MIXTURE NUMBER (,I6,12H) IS GREATER, + 1 10H THAN IR (,I6,2H )) + 400 FORMAT (/20H NUMBER OF VOLUMES =,I6,5X,22HAVAILABLE STORAGE: MAX, + 1 5HPTS =,I6/21H NUMBER OF MIXTURES =,I6/) + END diff --git a/Dragon/src/READEU.f b/Dragon/src/READEU.f new file mode 100644 index 0000000..00bea68 --- /dev/null +++ b/Dragon/src/READEU.f @@ -0,0 +1,693 @@ +*DECK READEU + SUBROUTINE READEU (MAXPTS,MAXCEL,IPGEOM,IR,MAT,ILK,NMCEL,NMERGE, + 1 NGEN,INUM,IGEN,NMBLK,LX,LY,XX,YY,LSECT,RAYRE,NMC,NMCR,IORI,NCODE, + 2 ZCODE,IHEX,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover input data for the description of a 2-D assembly (Eurydice-2). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* MAXPTS allocated storage for arrays of dimension NREG. +* MAXCEL allocated storage for arrays of dimension NMCEL, NMERGE or +* NGEN. +* IPGEOM pointer to the geometry LCM object (L_GEOM signature). +* IR number of mixtures. +* MAT index-number of the mixture type assigned to each volume. +* ILK leakage flag (ILK=.true. if neutron leakage through external +* boundary is present). +* NMCEL total number of cells in the domain. +* NMERGE total number of merged cells for which specific values +* of the neutron flux and reactions rates are required. +* Many cells with different position in the domain can +* be merged before the neutron flux calculation if they +* own the same generating cell (NMERGE.le.NMCEL). +* NGEN total number of generating cells. A generating cell is +* defined by its material and dimensions, irrespective of +* its position in the domain (NGEN.le.NMERGE). +* INUM index-number of the merged cell associated to each cell. +* IGEN index-number of the generating cell associated with each +* merged cell. +* NMBLK total number of volumes in all the merged cells. +* LX number of cells along the X-axis. +* LY number of cells along the Y-axis. +* XX X-thickness of the generating cells or side of the hexagons. +* YY Y-thickness of the generating cells. +* LSECT type of sectorization: +* =0 no sectorization / specialized treatment; +* =-999 no sectorization / processed as a sectorized cell; +* =-101 X-type sectorization of the coolant; +* =-1 X-type sectorization of the cell; +* =101 +-type sectorization of the coolant; +* =1 +-type sectorization of the cell; +* =102 + and X-type sectorization of the coolant; +* =2 + and X-type sectorization of the cell. +* RAYRE radius of the tubes in the generating cells. +* NMC offsets of the first zone index in each generating cell. +* NMCR offsets of the first radius index in each generating cell. +* IORI orientation of the cells. +* NCODE boundary condition relative to each side of the domain: +* =0 not used; =1 VOID; =2 REFL; +* =3 DIAG; =4: TRAN =5: SYME. +* ZCODE albedo relative to each side of the domain. +* IHEX type of symmetry for hexagonal geometry: +* =0 Cartesian geometry; +* =1 S30; =2 SA60; =3 SB60; =4 S90; =5 R120; +* =6 R180; =7 SA180; =8 SB180; =9 COMPLETE. +* IMPX print flag (equal to 0 for no print). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPGEOM + INTEGER MAXPTS,MAXCEL,IR,MAT(MAXPTS),NMCEL,NMERGE,NGEN, + 1 INUM(MAXCEL),IGEN(MAXCEL),NMBLK,LX,LY,LSECT(MAXCEL), + 2 NMC(MAXCEL+1),NMCR(MAXCEL+1),IORI(MAXCEL),NCODE(6),IHEX,IMPX + REAL XX(MAXCEL),YY(MAXCEL),RAYRE(MAXPTS),ZCODE(6) + LOGICAL ILK +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + LOGICAL LL1,LL2,EMPTY,LCM + CHARACTER GEONAM*12,TEXT12*12,HSMG*131 + INTEGER ISTATE(NSTATE),ISTAT2(NSTATE),ICODE(6) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MILIE,NBREG,MILIEU + CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: CELL + REAL, ALLOCATABLE, DIMENSION(:) :: RAYON,XXX,YYY +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(MILIE(MAXPTS),NBREG(MAXPTS),MILIEU(MAXPTS), + 1 CELL(MAXPTS)) + ALLOCATE(RAYON(MAXPTS),XXX(MAXPTS+1),YYY(MAXPTS+1)) +* + CALL LCMINF(IPGEOM,GEONAM,TEXT12,EMPTY,ILONG,LCM) + IHEX=0 + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) + IF((ISTATE(1).EQ.8).OR.(ISTATE(1).EQ.24)) THEN + CALL LCMGET(IPGEOM,'IHEX',IHEX) + ENDIF + IF((ISTATE(5).NE.0).OR.((ISTATE(11).NE.0).AND.(ISTATE(1).EQ.5)) + 1 .OR.((ISTATE(11).NE.0).AND.(ISTATE(1).EQ.8)).OR.(ISTATE(13).NE.0) + 2 ) CALL XABORT('READEU: UNABLE TO PROCESS THE GEOMETRY.') + LX=ISTATE(3) + LY=ISTATE(4) + IF(LX.GT.MAXPTS) CALL XABORT('READEU: INSUFFICIENT STORAGE(1).') + IF(LY.GT.MAXPTS) CALL XABORT('READEU: INSUFFICIENT STORAGE(2).') + IF(ISTATE(6).GT.MAXPTS) CALL XABORT('READEU: INSUFFICIENT STORA' + 1 //'GE(3).') +*---- +* RECOVER THE BOUNDARY CONDITIONS +*---- + CALL LCMGET(IPGEOM,'NCODE',NCODE) + CALL LCMGET(IPGEOM,'ZCODE',ZCODE) + CALL LCMGET(IPGEOM,'ICODE',ICODE) + I2=0 + DO 10 IC=1,4 + IF(ICODE(IC).NE.0) THEN + CALL XABORT('READEU: MACROLIB DEFINED ALBEDOS ARE NOT IMPLEMEN' + 1 //'TED.') + ENDIF + IF(NCODE(IC).EQ.10) NCODE(IC)=2 + IF(NCODE(IC).EQ.2) ZCODE(IC)=1.0 + IF(NCODE(IC).EQ.6) NCODE(IC)=1 + IF(NCODE(IC).GE.7) CALL XABORT('READEU: INVALID TYPE OF B.C.') + IF(NCODE(IC).EQ.3) I2=I2+1 + 10 CONTINUE + IF(NCODE(1).EQ.0) GO TO 550 + LL1=.FALSE. + LL2=.FALSE. + IF(IHEX.EQ.0) THEN + IF((NCODE(2).EQ.0).OR.(NCODE(3).EQ.0).OR.(NCODE(4).EQ.0)) + 1 GO TO 550 + NSUPCE=LX*LY + IF(I2.GT.0) THEN + IF(I2.NE.2) GO TO 560 + IF(LX.NE.LY) CALL XABORT('READEU: LX=LY WITH A DIAGONAL S' + 1 //'YMMETRY.') + NSUPCE=(LX+1)*LX/2 + LL1=((NCODE(2).EQ.3).AND.(NCODE(3).EQ.3)) + LL2=((NCODE(1).EQ.3).AND.(NCODE(4).EQ.3)) + IF((.NOT.LL1).AND.(.NOT.LL2)) GO TO 560 + ENDIF + DO 20 IC=1,4,2 + IF((NCODE(IC).EQ.4).AND.(NCODE(IC+1).NE.4)) + 1 CALL XABORT('READEU: THE TRANSLATION CONDITIONS X- TRAN X+' + 2 //' TRAN AND Y- TRAN Y+ TRAN ARE THE ONLY PERMITTED.') + 20 CONTINUE + ELSE + NSUPCE=LX + IF((NCODE(2).NE.0).OR.(NCODE(3).NE.0).OR.(NCODE(4).NE.0)) + 1 CALL XABORT('READEU: INVALID TYPE OF HEXAGONAL B.C.') + IF(NCODE(1).EQ.5) THEN + IF(IHEX.EQ.1) THEN + IHEX=10 + ELSE IF(IHEX.EQ.2) THEN + IHEX=11 + ELSE + CALL XABORT('READEU: BOUNDARY CONDITION HBC WITH OPTION' + 1 //' SYME CAN ONLY BE USED WITH OPTION S30 OR SA60.') + ENDIF + ELSE IF(NCODE(1).GT.2) THEN + CALL XABORT('READEU: BOUNDARY CONDITION HBC CAN ONLY BE US' + 1 //'ED WITH OPTIONS VOID, REFL, SYME OR ALBE.') + ENDIF + ENDIF +* + NMC(1)=0 + NMCR(1)=0 + IG=0 + IGR=0 + IR=0 + NMERGE=1 + NGEN=1 + IF((ISTATE(1).EQ.5).OR.(ISTATE(1).EQ.8)) THEN + NMCEL=ISTATE(6) + IF(NMCEL.GT.MAXPTS) THEN + WRITE(HSMG,'(36HREADEU: INSUFFICIENT STORAGE. NMCEL=,I8, + 1 8H MAXPTS=,I8)') NMCEL,MAXPTS + CALL XABORT(HSMG) + ENDIF + DO 30 IKK=1,NMCEL + IGEN(IKK)=0 + INUM(IKK)=IKK + IORI(IKK)=1 + 30 CONTINUE + IF(ISTATE(8).EQ.1) THEN +* MIXED GEOMETRY. + CALL LCMLEN(IPGEOM,'MERGE',ILEN,ITYLCM) + IF(ILEN.GT.0) CALL LCMGET(IPGEOM,'MERGE',INUM) + CALL LCMLEN(IPGEOM,'TURN',ILEN,ITYLCM) + IF(ILEN.GT.0) CALL LCMGET(IPGEOM,'TURN',IORI) + CALL LCMLEN(IPGEOM,'CELL',ILEN,ITYLCM) + CALL LCMGTC(IPGEOM,'CELL',12,ILEN/3,CELL) + CALL LCMGET(IPGEOM,'MIX',NBREG) + DO 36 IKK=1,NMCEL + IF(-NBREG(IKK).LT.0) CALL XABORT('READEU: GENERATING CELL ' + 1 //'EXPECTED.') + IGEN(INUM(IKK))=-NBREG(IKK) + NGEN=MAX(NGEN,-NBREG(IKK)) + NMERGE=MAX(NMERGE,INUM(IKK)) + DO 35 JKK=1,NMCEL + IF(INUM(IKK).EQ.INUM(JKK)) THEN + IF(NBREG(IKK).NE.NBREG(JKK)) THEN + WRITE(HSMG,'(38HREADEU: TWO CELLS WITH THE SAME MERGED, + 1 46H NUMBER DO NOT HAVE THE SAME GENERATING CELL (,2I7, + 2 2H).)') IKK,JKK + CALL XABORT(HSMG) + ENDIF + ENDIF + 35 CONTINUE + 36 CONTINUE + IF(NGEN.GT.ISTATE(9)) CALL XABORT('READEU: INVALID NUMBER' + 1 //' OF SUB GEOMETRIES.') + DO 70 IKG=1,NGEN + TEXT12=CELL(IKG) + CALL LCMLEN(IPGEOM,TEXT12,ILEN,ITYLCM) + IF((ILEN.EQ.0).OR.(ITYLCM.NE.0)) CALL XABORT('READEU: SUB' + 1 //' GEOMETRY '//TEXT12//' IS MISSING FROM L_GEOM.') + CALL LCMSIX(IPGEOM,TEXT12,1) + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTAT2) + IF(ISTAT2(6).GT.MAXPTS) CALL XABORT('READEU: INSUFFICI' + 1 //'ENT STORAGE(4).') + ISECTO=ISTAT2(14) + JSECTO=ISTAT2(15) + IF((IHEX.EQ.0).OR.(IHEX.NE.0)) THEN + NZONE=ISTAT2(2)+1 + CALL LCMLEN(IPGEOM,'SPLITR',ILENN,ITYLCM) + IF(ILENN.GT.0) THEN + CALL LCMGET(IPGEOM,'SPLITR',NBREG) + ELSE + DO 40 I=1,NZONE + NBREG(I)=1 + 40 CONTINUE + ENDIF + IF(NZONE.GT.1) CALL LCMGET(IPGEOM,'RADIUS',RAYON) + ELSE IF(((ISTAT2(1).EQ.5).OR.(ISTAT2(1).EQ.8)).AND. + 1 (ISTAT2(6).EQ.1)) THEN + NZONE=1 + NBREG(1)=1 + ELSE + CALL XABORT('READEU: INVALID SUB GEOMETRY.') + ENDIF + LS1=0 + LS2=0 + NZONES=0 + LSECT(IKG)=ISECTO + IF((ISECTO.EQ.0).OR.(ISECTO.EQ.-999)) THEN +* NO SECTORIZATION. + LS1=1 + LS2=1 + NZONES=NZONE + ELSE IF((IHEX.EQ.0).AND.(ISECTO.EQ.-1).AND. + 1 (JSECTO.EQ.0)) THEN +* X-TYPE SECTORIZATION IN CARTESIAN CELL. + LS1=4 + LS2=4 + NZONES=4*NZONE + ELSE IF((IHEX.EQ.0).AND.(ISECTO.EQ.-1).AND. + 1 (JSECTO.EQ.NZONE-1)) THEN +* X-TYPE COOLANT SECTORIZATION IN CARTESIAN CELL. + LSECT(IKG)=-101 + LS1=1 + LS2=4 + NZONES=NZONE+3 + ELSE IF((IHEX.EQ.0).AND.(ISECTO.EQ.1).AND. + 1 (JSECTO.EQ.0)) THEN +* +-TYPE SECTORIZATION IN CARTESIAN CELL. + LS1=4 + LS2=4 + NZONES=4*NZONE + ELSE IF((IHEX.EQ.0).AND.(ISECTO.EQ.1).AND. + 1 (JSECTO.EQ.NZONE-1)) THEN +* +-TYPE COOLANT SECTORIZATION IN CARTESIAN CELL. + LSECT(IKG)=101 + LS1=1 + LS2=4 + NZONES=NZONE+3 + ELSE IF((IHEX.EQ.0).AND.(ISECTO.EQ.2).AND. + 1 (JSECTO.EQ.0)) THEN +* +-TYPE SECTORIZATION IN CARTESIAN CELL. + LS1=8 + LS2=8 + NZONES=8*NZONE + ELSE IF((IHEX.EQ.0).AND.(ISECTO.EQ.2).AND. + 1 (JSECTO.EQ.NZONE-1)) THEN +* +-TYPE COOLANT SECTORIZATION IN CARTESIAN CELL. + LSECT(IKG)=102 + LS1=1 + LS2=8 + NZONES=NZONE+7 + ELSE IF((IHEX.GT.0).AND.(ISECTO.EQ.-1).AND. + 1 (JSECTO.EQ.0)) THEN +* X-TYPE SECTORIZATION IN HEXAGONAL CELL. + LS1=6 + LS2=6 + NZONES=6*NZONE + ELSE IF((IHEX.GT.0).AND.(ISECTO.EQ.-1).AND. + 1 (JSECTO.EQ.NZONE-1)) THEN +* X-TYPE COOLANT SECTORIZATION IN HEXAGONAL CELL. + LSECT(IKG)=-101 + LS1=1 + LS2=6 + NZONES=NZONE+5 + ELSE + CALL XABORT('READEU: INVALID TYPE OF SECTORIZATION.') + ENDIF + IF(NZONES.GT.MAXPTS) CALL XABORT('READEU: MAXPTS OVERFLOW.') + CALL LCMLEN(IPGEOM,'MIX',ILENG,ITYLCM) + IF(ILENG.NE.NZONES) CALL XABORT('READEU: BAD MIX LENGTH.') + CALL LCMGET(IPGEOM,'MIX',MILIEU) + IF(IHEX.EQ.0) THEN + CALL LCMGET(IPGEOM,'MESHX',XXX) + CALL LCMGET(IPGEOM,'MESHY',YYY) + ELSE + CALL LCMGET(IPGEOM,'SIDE',SIDE) + ENDIF + CALL LCMSIX(IPGEOM,' ',2) +* + RJ=0.0 + RAYRE(IGR+1)=0.0 + DO 60 I=1,NZONE-1 + IF(RAYON(I+1).LE.RJ) GO TO 520 + PAS=(RAYON(I+1)-RJ)/REAL(ABS(NBREG(I))) + IF(NBREG(I).LT.0) PAS=PAS*(RAYON(I+1)+RJ) + DO 50 J=1,ABS(NBREG(I)) + IGR=IGR+1 + DO 45 ISEC=1,LS1 + IG=IG+1 + IF(IG.GT.MAXPTS) THEN + WRITE(HSMG,'(28HREADEU: INCREASE MAXPTS FROM,I7,3H TO, + 1 I7,5H (1).)') MAXPTS,IG + CALL XABORT(HSMG) + ENDIF + MILIE(IG)=MILIEU((I-1)*LS1+ISEC) + IR=MAX(IR,MILIE(IG)) + 45 CONTINUE + IF(NBREG(I).GT.0) THEN + RJ=RJ+PAS + ELSE + RJ=SQRT(RJ*RJ+PAS) + ENDIF + RAYRE(IGR+1)=RJ + 50 CONTINUE + RJ=RAYON(I+1) + 60 CONTINUE + IGR=IGR+1 + DO 65 ISEC=1,LS2 + IG=IG+1 + IF(IG.GT.MAXPTS) THEN + WRITE(HSMG,'(28HREADEU: INCREASE MAXPTS FROM,I7,3H TO, + 1 I7,5H (2).)') MAXPTS,IG + CALL XABORT(HSMG) + ENDIF + MILIE(IG)=MILIEU((NZONE-1)*LS1+ISEC) + IR=MAX(IR,MILIE(IG)) + 65 CONTINUE + IF(IHEX.EQ.0) THEN + XX(IKG)=XXX(2)-XXX(1) + YY(IKG)=YYY(2)-YYY(1) + TEST=2.0*RAYRE(IGR) + IF(SQRT(XX(IKG)**2+YY(IKG)**2).LE.TEST) GO TO 520 + ELSE + XX(IKG)=SIDE + YY(IKG)=0.0 + IF(SIDE.LE.RAYRE(IGR)) GO TO 520 + ENDIF + NMC(IKG+1)=IG + NMCR(IKG+1)=IGR + 70 CONTINUE +* COMPUTE THE MIXTURE NUMBERS IN THE MERGED CELLS. + NMBLK=0 + DO 90 IKK=1,NMERGE + IKG=IGEN(IKK) + IF(IKG.EQ.0) THEN + WRITE(HSMG,'(14HREADEU: VOLUME,I5,16H NOT DEFINED(1).)') + 1 IKK + CALL XABORT(HSMG) + ENDIF + I1=NMC(IKG) + I2=NMC(IKG+1)-I1 + IF(NMBLK+I2.GT.MAXPTS) THEN + WRITE(HSMG,'(28HREADEU: INCREASE MAXPTS FROM,I7,3H TO, + 1 I7,5H (3).)') MAXPTS,NMBLK+I2 + CALL XABORT(HSMG) + ENDIF + DO 80 I=1,I2 + MAT(NMBLK+I)=MILIE(I1+I) + 80 CONTINUE + NMBLK=NMBLK+I2 + 90 CONTINUE + ELSE IF(IHEX.EQ.0) THEN +* PURE CARTESIAN GEOMETRY. + CALL LCMGET(IPGEOM,'MIX',MILIEU) + DO 100 I=1,NMCEL + MAT(INUM(I))=MILIEU(I) + 100 CONTINUE + CALL LCMGET(IPGEOM,'MESHX',XXX) + IF(LL1.OR.LL2) THEN + CALL LCMGET(IPGEOM,'MESHX',YYY) + ELSE + CALL LCMGET(IPGEOM,'MESHY',YYY) + ENDIF + NGEN=0 + IBLK=0 + DO 125 K1=1,LY + LXM=1 + LXP=LX + IF(LL1) LXP=K1 + IF(LL2) LXM=K1 + DO 120 K2=LXM,LXP + IBLK=IBLK+1 + IF(MAT(INUM(IBLK)).EQ.0) GO TO 120 + IKK=INUM(IBLK) + NMERGE=MAX(NMERGE,IKK) + A=XXX(K2+1)-XXX(K2) + B=YYY(K1+1)-YYY(K1) + DO 110 JBLK=1,IBLK-1 + JKG=IGEN(INUM(JBLK)) + IF(MAT(INUM(IBLK)).EQ.MAT(INUM(JBLK))) THEN + IF((A.EQ.XX(JKG)).AND.(B.EQ.YY(JKG))) THEN + IGEN(IKK)=JKG + GO TO 120 + ELSE IF((B.EQ.XX(JKG)).AND.(A.EQ.YY(JKG))) THEN + IGEN(IKK)=JKG + IORI(IBLK)=2 + GO TO 120 + ENDIF + ENDIF + 110 CONTINUE + NGEN=NGEN+1 + IGEN(IKK)=NGEN + XX(NGEN)=A + YY(NGEN)=B + LSECT(NGEN)=0 + NMC(NGEN+1)=NMC(NGEN)+1 + NMCR(NGEN+1)=NMCR(NGEN)+1 + RAYRE(NGEN)=0.0 + 120 CONTINUE + 125 CONTINUE + NMBLK=NMERGE + ELSE IF(IHEX.GT.0) THEN +* PURE HEXAGONAL GEOMETRY. + CALL LCMGET(IPGEOM,'MIX',MILIEU) + DO 130 I=1,NMCEL + MAT(INUM(I))=MILIEU(I) + 130 CONTINUE + CALL LCMGET(IPGEOM,'SIDE',SIDE) + NGEN=0 + DO 140 IBLK=1,LX + IF(MAT(INUM(IBLK)).EQ.0) GO TO 140 + IKK=INUM(IBLK) + NMERGE=MAX(NMERGE,IKK) + DO 135 JBLK=1,IBLK-1 + IF(MAT(INUM(IBLK)).EQ.MAT(INUM(JBLK))) THEN + IGEN(IKK)=IGEN(INUM(JBLK)) + GO TO 140 + ENDIF + 135 CONTINUE + NGEN=NGEN+1 + IGEN(IKK)=NGEN + XX(NGEN)=SIDE + YY(NGEN)=0.0 + LSECT(NGEN)=0 + NMC(NGEN+1)=NMC(NGEN)+1 + NMCR(NGEN+1)=NMCR(NGEN)+1 + RAYRE(NGEN)=0.0 + 140 CONTINUE + NMBLK=NMERGE + ENDIF + ELSE IF((ISTATE(1).EQ.20).OR.(ISTATE(1).EQ.24)) THEN + NZONE=ISTATE(2)+1 + ISECTO=ISTATE(14) + JSECTO=ISTATE(15) + NMCEL=1 + IGEN(1)=1 + INUM(1)=1 + IORI(1)=1 + CALL LCMLEN(IPGEOM,'SPLITR',ILENN,ITYLCM) + IF(ILENN.GT.0) THEN + CALL LCMGET(IPGEOM,'SPLITR',NBREG) + ELSE + DO 150 I=1,NZONE + NBREG(I)=1 + 150 CONTINUE + ENDIF + IF(NZONE.GT.1) CALL LCMGET(IPGEOM,'RADIUS',RAYON) + LS1=0 + LS2=0 + NZONES=0 + LSECT(1)=ISECTO + IF((ISECTO.EQ.0).OR.(ISECTO.EQ.-999)) THEN +* NO SECTORIZATION. + LS1=1 + LS2=1 + NZONES=NZONE + ELSE IF((IHEX.EQ.0).AND.(ISECTO.EQ.-1).AND.(JSECTO.EQ.0)) THEN +* X-TYPE SECTORIZATION IN CARTESIAN CELL. + LS1=4 + LS2=4 + NZONES=4*NZONE + ELSE IF((IHEX.EQ.0).AND.(ISECTO.EQ.-1).AND. + 1 (JSECTO.EQ.NZONE-1)) THEN +* X-TYPE COOLANT SECTORIZATION IN CARTESIAN CELL. + LSECT(1)=-101 + LS1=1 + LS2=4 + NZONES=NZONE+3 + ELSE IF((IHEX.EQ.0).AND.(ISECTO.EQ.1).AND.(JSECTO.EQ.0)) THEN +* +-TYPE SECTORIZATION IN CARTESIAN CELL. + LS1=4 + LS2=4 + NZONES=4*NZONE + ELSE IF((IHEX.EQ.0).AND.(ISECTO.EQ.1).AND. + 1 (JSECTO.EQ.NZONE-1)) THEN +* +-TYPE COOLANT SECTORIZATION IN CARTESIAN CELL. + LSECT(1)=101 + LS1=1 + LS2=4 + NZONES=NZONE+3 + ELSE IF((IHEX.EQ.0).AND.(ISECTO.EQ.2).AND.(JSECTO.EQ.0)) THEN +* +-TYPE SECTORIZATION IN CARTESIAN CELL. + LS1=8 + LS2=8 + NZONES=8*NZONE + ELSE IF((IHEX.EQ.0).AND.(ISECTO.EQ.2).AND. + 1 (JSECTO.EQ.NZONE-1)) THEN +* +-TYPE COOLANT SECTORIZATION IN CARTESIAN CELL. + LSECT(1)=102 + LS1=1 + LS2=8 + NZONES=NZONE+7 + ELSE IF((IHEX.GT.0).AND.(ISECTO.EQ.-1).AND.(JSECTO.EQ.0)) THEN +* X-TYPE SECTORIZATION IN HEXAGONAL CELL. + LS1=6 + LS2=6 + NZONES=6*NZONE + ELSE IF((IHEX.GT.0).AND.(ISECTO.EQ.-1).AND. + 1 (JSECTO.EQ.NZONE-1)) THEN +* X-TYPE COOLANT SECTORIZATION IN HEXAGONAL CELL. + LSECT(1)=-101 + LS1=1 + LS2=6 + NZONES=NZONE+5 + ELSE + CALL XABORT('READEU: INVALID TYPE OF SECTORIZATION(2).') + ENDIF + IF(NZONES.GT.MAXPTS) CALL XABORT('READEU: MAXPTS OVERFLOW(2).') + CALL LCMLEN(IPGEOM,'MIX',ILENG,ITYLCM) + IF(ILENG.NE.NZONES) CALL XABORT('READEU: BAD MIX LENGTH(2).') + CALL LCMGET(IPGEOM,'MIX',MILIEU) + IF(IHEX.EQ.0) THEN + CALL LCMGET(IPGEOM,'MESHX',XXX) + CALL LCMGET(IPGEOM,'MESHY',YYY) + ELSE + CALL LCMGET(IPGEOM,'SIDE',SIDE) + ENDIF +* + RJ=0.0 + RAYRE(1)=0.0 + DO 170 I=1,NZONE-1 + IF(RAYON(I+1).LE.RJ) GO TO 520 + PAS=(RAYON(I+1)-RJ)/REAL(ABS(NBREG(I))) + IF(NBREG(I).LT.0) PAS=PAS*(RAYON(I+1)+RJ) + DO 160 J=1,ABS(NBREG(I)) + IGR=IGR+1 + DO 155 ISEC=1,LS1 + IG=IG+1 + IF(IG.GT.MAXPTS) THEN + WRITE(HSMG,'(28HREADEU: INCREASE MAXPTS FROM,I7,3H TO, + 1 I7,5H (4).)') MAXPTS,IG + CALL XABORT(HSMG) + ENDIF + MAT(IG)=MILIEU((I-1)*LS1+ISEC) + IR=MAX(IR,MAT(IG)) + 155 CONTINUE + IF(NBREG(I).GT.0) THEN + RJ=RJ+PAS + ELSE + RJ=SQRT(RJ*RJ+PAS) + ENDIF + RAYRE(IGR+1)=RJ + 160 CONTINUE + RJ=RAYON(I+1) + 170 CONTINUE + IGR=IGR+1 + DO 180 ISEC=1,LS2 + IG=IG+1 + IF(IG.GT.MAXPTS) THEN + WRITE(HSMG,'(28HREADEU: INCREASE MAXPTS FROM,I7,3H TO, + 1 I7,5H (5).)') MAXPTS,IG + CALL XABORT(HSMG) + ENDIF + MAT(IG)=MILIEU((NZONE-1)*LS1+ISEC) + IR=MAX(IR,MAT(IG)) + 180 CONTINUE + IF(IHEX.EQ.0) THEN + XX(1)=XXX(2)-XXX(1) + YY(1)=YYY(2)-YYY(1) + TEST=2.0*RAYRE(IGR) + IF(SQRT(XX(1)**2+YY(1)**2).LE.TEST) GO TO 520 + ELSE + XX(1)=SIDE + YY(1)=0.0 + IF(SIDE.LE.RAYRE(IGR)) GO TO 520 + ENDIF + NMC(2)=IG + NMCR(2)=IGR + NMBLK=IG + ELSE + CALL XABORT('READEU: INVALID PRIMARY GEOMETRY.') + ENDIF + IF(NSUPCE.NE.NMCEL) CALL XABORT('READEU: THE CALCULATED NUMBER O' + 1 //'F CELLS IS INCONSISTENT.') +* + ILK=((NCODE(1).EQ.1).AND.(ZCODE(1).NE.1.0)).OR. + 1 ((NCODE(2).EQ.1).AND.(ZCODE(2).NE.1.0)).OR. + 2 ((NCODE(3).EQ.1).AND.(ZCODE(3).NE.1.0)).OR. + 3 ((NCODE(4).EQ.1).AND.(ZCODE(4).NE.1.0)) + IF(IMPX.GT.0) THEN + IF(IHEX.EQ.0) THEN + WRITE (6,'(/43H CARTESIAN MULTICELL OPTION (EURYDICE-2) BA, + 1 28HSED ON GEOMETRY LOCATED IN '',A12,2H''./)') GEONAM + ELSE + WRITE (6,'(/43H HEXAGONAL MULTICELL OPTION (EURYDICE-2) BA, + 1 28HSED ON GEOMETRY LOCATED IN '',A12,2H''./)') GEONAM + ENDIF + IF(IHEX.EQ.0) THEN + WRITE (6,670) LX,LY,MAXPTS,NMBLK,IR + ELSE + WRITE (6,680) LX,MAXPTS,NMBLK,IR + ENDIF + WRITE (6,630) + DO 190 IKG=1,NGEN + IF((ISTATE(1).EQ.20).OR.(ISTATE(1).EQ.24)) THEN + TEXT12=GEONAM + ELSE IF(ISTATE(8).EQ.1) THEN + TEXT12=CELL(IKG) + ELSE + WRITE (TEXT12,'(4HCELL,I5)') IKG + ENDIF + I1=NMCR(IKG)+1 + I2=NMCR(IKG+1) + IF(I1.EQ.I2) THEN + IF(IHEX.EQ.0) THEN + WRITE (6,660) IKG,TEXT12,XX(IKG),YY(IKG) + ELSE + WRITE (6,665) IKG,TEXT12,XX(IKG) + ENDIF + ELSE + WRITE (6,640) IKG,TEXT12,(RAYRE(I),I=I1,I2) + IF(IHEX.EQ.0) THEN + WRITE (6,650) XX(IKG),YY(IKG) + ELSE + WRITE (6,655) XX(IKG) + ENDIF + ENDIF + 190 CONTINUE + WRITE (6,'(/)') + IF(.NOT.ILK) WRITE (6,'(17H INFINITE DOMAIN./)') + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(YYY,XXX,RAYON) + DEALLOCATE(CELL,MILIEU,NBREG,MILIE) + RETURN +* + 520 CALL XABORT('READEU: RADIUS ARE INCONSISTENTS.') + 550 CALL XABORT('READEU: A BOUNDARY CONDITION IS MISSING.') + 560 CALL XABORT('READEU: THE DIAGONAL CONDITIONS X+ DIAG Y- DIAG AND' + 1 //' X- DIAG Y+ DIAG ARE THE ONLY PERMITTED.') +* + 630 FORMAT (/5X,24HGENERATING CELL RADIUS) + 640 FORMAT (/1X,I4,2H ',A12,3H' ,1P,9E12.5/(22X,9E12.5)) + 650 FORMAT (23X,3HA =,1P,E12.5,6H B =,E12.5) + 655 FORMAT (23X,6HSIDE =,1P,E12.5) + 660 FORMAT (/1X,I4,2H ',A12,1H',3X,3HA =,1P,E12.5,6H B =,E12.5) + 665 FORMAT (/1X,I4,2H ',A12,1H',3X,6HSIDE =,1P,E12.5) + 670 FORMAT (/35H NUMBER OF CELLS ALONG THE X-AXIS =,I4/17X, + 1 18HALONG THE Y-AXIS =,I4,5X,26HAVAILABLE STORAGE MAXPTS =,I4/ + 2 27H NUMBER OF MERGED VOLUMES =,I5/ + 3 39H NUMBER OF DISTINCT PHYSICAL MIXTURES =,I5/) + 680 FORMAT (/34H NUMBER OF HEXAGONS IN ONE PLANE =,I4,5X,9HAVAILABLE, + 1 17H STORAGE MAXPTS =,I4/27H NUMBER OF MERGED VOLUMES =,I5/ + 2 39H NUMBER OF DISTINCT PHYSICAL MIXTURES =,I5/) + END diff --git a/Dragon/src/READMT.f b/Dragon/src/READMT.f new file mode 100644 index 0000000..46d1007 --- /dev/null +++ b/Dragon/src/READMT.f @@ -0,0 +1,220 @@ +*DECK READMT + SUBROUTINE READMT (MAXPTS,IPGEOM,IR,MAT,VOL,ILK,ISTAT,NSUPCE,IPAS, + 1 NMC,RAYRE,PROCEL,POURCE,SURFA,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover the input data for the description of an arbitrary multicell +* using the 'do-it-yourself' approach. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* MAXPTS allocated storage for arrays of dimension NSUPCE or IPAS. +* IPGEOM pointer to the geometry L_GEOM signature). +* IR number of mixtures. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* ILK leakage flag (ILK=.true. if neutron leakage through external +* boundary is present). +* ISTAT statistical approximation flag (set with ISTAT=1). +* NSUPCE number of cells. +* IPAS number of volumes. +* NMC offset of the first volume in each cell. +* RAYRE radius of the tubes in each cell. +* PROCEL user supplied geometrical matrix. +* POURCE weight assign to each cell. +* SURFA surface assign to each cell. +* IMPX print flag (equal to 0 for no print). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPGEOM + INTEGER MAXPTS,IR,ISTAT,NSUPCE,IPAS,MAT(IPAS),NMC(NSUPCE+1),IMPX + REAL VOL(IPAS),RAYRE(NSUPCE+IPAS),PROCEL(NSUPCE**2), + 1 POURCE(NSUPCE),SURFA(NSUPCE) + LOGICAL ILK +*---- +* LOCAL VARIABLES +*---- + PARAMETER (PI=3.141592654,EPS1=1.0E-5,EPS2=1.0E-4,NSTATE=40) + LOGICAL EMPTY,LCM + CHARACTER GEONAM*12,TEXT12*12,HSMG*131 + DOUBLE PRECISION RRINT,RRZON,PAS,RJ,RJ1,RJN,RJN1 + INTEGER ISTATE(NSTATE),ISTAT2(NSTATE) + INTEGER, ALLOCATABLE, DIMENSION(:) :: NBREG,MILIEU,CELL,IGEN + REAL, ALLOCATABLE, DIMENSION(:) :: RAYZON +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NBREG(MAXPTS),MILIEU(MAXPTS),CELL(3*MAXPTS),IGEN(MAXPTS)) + ALLOCATE(RAYZON(MAXPTS)) +* + CALL LCMINF(IPGEOM,GEONAM,TEXT12,EMPTY,ILONG,LCM) + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) + NSUPCE=ISTATE(3) + IF(NSUPCE.GT.MAXPTS) CALL XABORT('READMT: INSUFFICIENT STORAGE.') + CALL LCMLEN(IPGEOM,'PROCEL',ILEN,ITYLCM) + IF(ILEN.EQ.0) THEN + ISTAT=1 + ELSE + ISTAT=0 + CALL LCMGET(IPGEOM,'PROCEL',PROCEL) + ENDIF + CALL LCMGET(IPGEOM,'POURCE',POURCE) +* + SURFAT=0.0 + IPAS=0 + NMC(1)=0 + PTOT=1.0 + CALL LCMLEN(IPGEOM,'MIX',ILON,ITYLCM) + IF(ILON.NE.NSUPCE) CALL XABORT('READMT: INVALID NUMBER OF SUB' + 1 //' GEOMETRIES.') + CALL LCMGET(IPGEOM,'CELL',CELL) + CALL LCMGET(IPGEOM,'MIX',IGEN) + DO 50 IKK=1,NSUPCE + PTOT=PTOT-POURCE(IKK) + IKG=-IGEN(IKK) + IF(IKG.LT.0) CALL XABORT('READMT: GENERATING CELLS EXPECTED.') + WRITE (TEXT12(:4),'(A4)') CELL(3*(IKG-1)+1) + WRITE (TEXT12(5:8),'(A4)') CELL(3*(IKG-1)+2) + WRITE (TEXT12(9:),'(A4)') CELL(3*(IKG-1)+3) + CALL LCMLEN(IPGEOM,TEXT12,ILEN,ITYLCM) + IF((ILEN.EQ.0).OR.(ITYLCM.NE.0)) CALL XABORT('READMT: SUB GEOME' + 1 //'TRY '//TEXT12//' IS MISSING FROM GEOMETRY '//GEONAM//'.') + CALL LCMSIX(IPGEOM,TEXT12,1) + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTAT2) + IF(ISTAT2(1).NE.3) CALL XABORT('READMT: A SUB GEOMETRY IS N' + 1 //'OT A TUBE.') + NZONE=ISTAT2(2) + CALL LCMLEN(IPGEOM,'SPLITR',ILEN,ITYLCM) + IF(ILEN.GT.0) THEN + CALL LCMGET(IPGEOM,'SPLITR',NBREG) + ELSE + DO 10 I=1,NZONE + NBREG(I)=1 + 10 CONTINUE + ENDIF + CALL LCMGET(IPGEOM,'MIX',MILIEU) + CALL LCMGET(IPGEOM,'RADIUS',RAYZON) + CALL LCMSIX(IPGEOM,' ',2) + RAYRE(IPAS+IKK)=0.0 + RINT=0.0 + RRINT=0.0D0 + RJN=0.0D0 + RJ=0.0D0 + DO 40 N=1,NZONE + RRZON=RAYZON(N+1) + PAS=(RRZON-RRINT)/DBLE(ABS(NBREG(N))) + IF(NBREG(N).LT.0) PAS=PAS*(RRZON+RRINT) + DO 30 I=1,ABS(NBREG(N)) + J=I+IPAS + IF(J.GT.MAXPTS) THEN + WRITE (HSMG,200) J,MAXPTS + CALL XABORT(HSMG) + ENDIF + IF(NBREG(N).GT.0) THEN + RJ1=RJ+PAS + RJN1=RJ1**2 + ELSE + RJN1=RJ*RJ+PAS + RJ1=SQRT(RJN1) + ENDIF + VOL(J)=PI*REAL(RJN1-RJN)*POURCE(IKK) + RAYRE(J+IKK)=REAL(RJ1) + RJ=RJ1 + RJN=RJN1 + MAT(J)=MILIEU(N) + 30 CONTINUE + IPAS=IPAS+ABS(NBREG(N)) + RRINT=RRZON + RINT=RAYZON(N+1) + 40 CONTINUE + NMC(IKK+1)=IPAS + RINT=RAYRE(IPAS+IKK) + SURFA(IKK)=2.0*PI*RINT*POURCE(IKK) + SURFAT=SURFAT+SURFA(IKK) + 50 CONTINUE +* + IF(ABS(PTOT).GT.EPS1) CALL XABORT('READMT: INVALID CELL PROPORT' + 1 //'IONS.') + IF(ISTAT.EQ.1) THEN +* STATISTICAL OPTION. + DO 70 IKK=1,NSUPCE + DO 60 JKK=1,NSUPCE + PROCEL((JKK-1)*NSUPCE+IKK)=SURFA(JKK)/SURFAT + 60 CONTINUE + 70 CONTINUE + ENDIF + DO 85 IKK=1,NSUPCE + DO 80 JKK=1,IKK-1 + X1=SURFA(IKK)*PROCEL((JKK-1)*NSUPCE+IKK) + X2=SURFA(JKK)*PROCEL((IKK-1)*NSUPCE+JKK) + IF(ABS(X1-X2).GT.EPS2) THEN + WRITE (HSMG,210) ABS(X1-X2),IKK,JKK + CALL XABORT(HSMG) + ENDIF + 80 CONTINUE + 85 CONTINUE +* + IR=0 + DO 90 I=1,IPAS + IR=MAX(IR,MAT(I)) + 90 CONTINUE + ILK=.FALSE. +* + IF(IMPX.GT.0) THEN + WRITE (6,'(/46H DO-IT-YOURSELF MULTICELL OPTION BASED ON GEOM, + 1 5HETRY ,A12,1H./)') GEONAM + WRITE (6,'(/34H USER SUPPLIED GEOMETRICAL MATRIX:/)') + DO 100 I=1,NSUPCE + WRITE (6,'(1X,1P,10E12.4)') (PROCEL((J-1)*NSUPCE+I),J=1,NSUPCE) + 100 CONTINUE + I1=0 + DO 120 IKK=1,NSUPCE + I2=NMC(IKK+1)-NMC(IKK) + WRITE (6,'(//)') + WRITE (6,230) IKK + J1=I1+1 + DO 110 I=1,1+(I2-1)/8 + J2=MIN0(J1+7,I1+I2) + WRITE (6,240) (J,J=J1,J2) + WRITE (6,250) (RAYRE(J+IKK),J=J1,J2) + J1=J1+8 + 110 CONTINUE + I1=I1+I2 + 120 CONTINUE + WRITE (6,'(//)') + WRITE (6,260) IPAS,MAXPTS,IR + WRITE (6,'(17H INFINITE DOMAIN./)') + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(RAYZON) + DEALLOCATE(IGEN,CELL,MILIEU,NBREG) + RETURN +* + 200 FORMAT (24HREADMT: A CELL NUMBER (=,I4,18H) EXCEED MAXPTS (=, + 1 I4,1H)) + 210 FORMAT (53HREADMT: THE USER SUPPLIED GEOMETRICAL MATRIX DO NOT M, + 1 31HEET THE RECIPROCITY CONDITION (,1P,E10.1,7H); CELL,I5,4H <->, + 2 5H CELL,I5,1H.) + 230 FORMAT (1X,11(1H*)/7H * CELL,I3,2H */1X,11(1H*)) + 240 FORMAT (/11H VOLUME ,8(4X,I4,6X,1HI)) + 250 FORMAT ( 11H ABSCISSA ,8(F12.6,2X,1HI)) + 260 FORMAT (/20H NUMBER OF VOLUMES =,I4,5X,23HAVAILABLE STORAGE: MAXB, + 1 4HLK =,I4/21H NUMBER OF MIXTURES =,I4/) + END diff --git a/Dragon/src/RECT1.f b/Dragon/src/RECT1.f new file mode 100644 index 0000000..63e1615 --- /dev/null +++ b/Dragon/src/RECT1.f @@ -0,0 +1,195 @@ +*DECK RECT1 + SUBROUTINE RECT1 (NA,A,B,SIGT,TRONC,PII,PVS,PSS,ALPA,PWA) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Integration of the collision probabilities of an homogeneous 2-D +* rectangle (DP-0 surface angular flux approximation). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NA number of Gauss-Legendre base points. +* A X-thickness of the rectangle. +* B Y-thickness of the rectangle. +* SIGT cross section. +* TRONC voided block criterion. +* ALPA Gauss-Legendre base points. +* PWA Gauss-Legendre weights. +* +*Parameters: output +* PII volume to volume reduced probability. +* PVS volume to surface probabilities: +* XINF surface 1; XSUP surface 2; +* YINF surface 3; YSUP surface 4. +* PSS surface to surface probabilities in the following order: +* PSS(i,j) is the probability from surface i to surface j. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NA + REAL A,B,SIGT,TRONC,PII,PVS(4),PSS(4,4),ALPA(NA),PWA(NA) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MKI3=600,MKI4=600) + PARAMETER (PI=3.141592654,ZI40=0.6666666667) + DOUBLE PRECISION Y1,Y2,AOB,BOA,R,PHI,PHJ,RM,CO,SI,Z1,Z2,POP,ZI3, + 1 ZI4,GAR(4),QUOT(2),PHIB(2),ABSC(2),PBB(5) + INTEGER ISL(4,4) + COMMON /BICKL3/BI3(0:MKI3),BI31(0:MKI3),BI32(0:MKI3),PAS3,XLIM3,L3 + COMMON /BICKL4/BI4(0:MKI4),BI41(0:MKI4),BI42(0:MKI4),PAS4,XLIM4,L4 + SAVE ISL + DATA ISL/5,4,1,1, + 1 4,5,1,1, + 2 3,3,5,2, + 3 3,3,2,5/ +* + AOB=A/B + BOA=B/A + X=2.0*A*B/(A+B) + IF(X*SIGT.LE.TRONC) GO TO 120 + SIG=1.0/SIGT + IF(A.EQ.B) GO TO 60 +*---- +* RECTANGULAR CELL +*---- + QUOT(1)=BOA + QUOT(2)=AOB + PHIB(1)=ATAN(AOB) + PHIB(2)=ATAN(BOA) + ABSC(1)=B + ABSC(2)=A + DO 10 I=1,4 + GAR(I)=0.0 +10 CONTINUE + DO 55 IL=1,NA + X=0.5*(ALPA(IL)+1.0) + WA=PWA(IL) + L=0 + DO 50 IZ=1,2 + PHI=PHIB(IZ)*X + CO=COS(PHI) + SI=SIN(PHI) + Z1=PHIB(IZ)*WA*CO*SI/(PI*A) + Z2=PHIB(IZ)*WA*(CO-QUOT(IZ)*SI)*2.0/PI + POP=SIGT*ABSC(IZ)/CO + ZI3=0.0 + ZI4=0.0 + IF(POP.GE.XLIM3) GO TO 40 + K=NINT(POP*PAS3) + ZI3=BI3(K)+POP*(BI31(K)+POP*BI32(K)) + ZI4=BI4(K)+POP*(BI41(K)+POP*BI42(K)) +40 GAR(L+1)=GAR(L+1)+(ZI40-ZI4)*Z1 + GAR(L+2)=GAR(L+2)+ZI3*Z2 + L=L+2 +50 CONTINUE +55 CONTINUE + PBB(1)=(GAR(1)+GAR(3))*SIG + PBB(2)=GAR(2) + PBB(4)=GAR(4) + GO TO 110 +*---- +* SQUARE CELL +*---- +60 PHI1=0.25*PI + GAR(1)=0.0 + GAR(2)=0.0 + DO 100 IL=1,NA + X=0.5*(ALPA(IL)+1.0) + WA=PWA(IL) + PHI=PHI1*X + CO=COS(PHI) + SI=SIN(PHI) + Z1=0.25*WA*CO*SI/A + Z2=0.5*WA*(CO-SI) + POP=SIGT*A/CO + ZI3=0.0 + ZI4=0.0 + IF(POP.GE.XLIM3) GO TO 90 + K=NINT(POP*PAS3) + ZI3=BI3(K)+POP*(BI31(K)+POP*BI32(K)) + ZI4=BI4(K)+POP*(BI41(K)+POP*BI42(K)) +90 GAR(1)=GAR(1)+(ZI40-ZI4)*Z1 + GAR(2)=GAR(2)+ZI3*Z2 +100 CONTINUE + PBB(1)=2.0*GAR(1)*SIG + PBB(2)=GAR(2) + PBB(4)=PBB(2) +* +110 PBB(3)=PBB(1)*AOB + PVS(3)=REAL(0.25*SIG*(1.0-2.0*PBB(1)-PBB(2))/B) + PVS(1)=REAL(0.25*SIG*(1.0-2.0*PBB(3)-PBB(4))/A) + PII=REAL(SIG*(1.0-2.0*(PVS(3)+PVS(1)))) + GO TO 130 +*---- +* VOIDED CELL +*---- +120 IF(A.GT.1.0E2*B) THEN + PHI=0.5D0*PI + R=A*(1.0D0+BOA*BOA*(0.5D0-0.125D0*BOA*BOA)) + RM=BOA*(0.5D0-0.125D0*BOA*BOA) + Y1=LOG(DBLE((R+A)/B)) + PBB(3)=0.5D0*(1.0D0-RM)+SIGT*B*LOG(B/R)/PI + PBB(1)=PBB(3)*BOA + PBB(2)=(R-B)/A-4.0D0*SIGT*(B*PHI+B*BOA*LOG(B/R))/PI + 1 +SIGT*SIGT*B*B*(Y1-(R-B)/A) + PBB(4)=RM + PVS(3)=REAL((PHI+0.5D0*BOA*LOG(B/R))/PI-0.25D0*SIGT*(B*Y1- + 1 BOA*(R-B))) + PVS(1)=REAL(-0.5D0*BOA*LOG(B/R)/PI) + PII=REAL(0.5D0*B*Y1-0.5D0*BOA*(R-B)) + ELSE IF(B.GT.1.0E2*A) THEN + PHJ=0.5D0*PI + R=B*(1.0D0+AOB*AOB*(0.5D0-0.125D0*AOB*AOB)) + RM=AOB*(0.5D0-0.125D0*AOB*AOB) + Y2=LOG(DBLE((R+B)/A)) + PBB(1)=0.5D0*(1.0D0-RM)+SIGT*A*LOG(A/R)/PI + PBB(3)=PBB(1)*AOB + PBB(2)=RM + PBB(4)=(R-A)/B-4.0D0*SIGT*(A*PHJ+A*AOB*LOG(A/R))/PI + 1 +SIGT*SIGT*A*A*(Y2-(R-A)/B) + PVS(3)=REAL(-0.5D0*AOB*LOG(A/R)/PI) + PVS(1)=REAL((PHJ+0.5D0*AOB*LOG(A/R))/PI-0.25D0*SIGT*(A*Y2- + 1 AOB*(R-A))) + PII=REAL(0.5D0*A*Y2-0.5D0*AOB*(R-A)) + ELSE + PHI=ATAN(AOB) + PHJ=ATAN(BOA) + R=SQRT(A*A+B*B) + Y1=LOG(DBLE((R+A)/B)) + Y2=LOG(DBLE((R+B)/A)) + PBB(1)=(A+B-R)/(A+A)+SIGT*(A*LOG(A/R)+B*BOA*LOG(B/R))/PI + 1 +SIGT*SIGT*(R*R*R-A*A*A-B*B*B)/(6.0D0*A) + PBB(3)=PBB(1)*AOB + PBB(2)=(R-B)/A-4.0D0*SIGT*(B*PHI+B*BOA*LOG(B/R))/PI + 1 +SIGT*SIGT*B*B*(Y1-(R-B)/A) + PBB(4)=(R-A)/B-4.0D0*SIGT*(A*PHJ+A*AOB*LOG(A/R))/PI + 1 +SIGT*SIGT*A*A*(Y2-(R-A)/B) + PVS(3)=REAL((0.5D0*BOA*LOG(B/R)-0.5D0*AOB*LOG(A/R)+PHI)/PI + 1 -0.25D0*SIGT*((R*R*R-A*A*A-B*B*B)/(3.0D0*A*B)-(R-B)*BOA+B*Y1)) + PVS(1)=REAL((0.5D0*AOB*LOG(A/R)-0.5D0*BOA*LOG(B/R)+PHJ)/PI + 1 -0.25D0*SIGT*((R*R*R-A*A*A-B*B*B)/(3.0D0*A*B)-(R-A)*AOB+A*Y2)) + PII=REAL((A*A*A+B*B*B-R*R*R)/6.0D0*A*B+0.5D0*B*Y1+0.5D0*A*Y2) + ENDIF + 130 PVS(2)=PVS(1) + PVS(4)=PVS(3) + PBB(5)=0.0 + DO 150 JC=1,4 + DO 140 IC=1,4 + PSS(IC,JC)=REAL(PBB(ISL(IC,JC))) + 140 CONTINUE + 150 CONTINUE + RETURN + END diff --git a/Dragon/src/RECT2.f b/Dragon/src/RECT2.f new file mode 100644 index 0000000..4e95e43 --- /dev/null +++ b/Dragon/src/RECT2.f @@ -0,0 +1,371 @@ +*DECK RECT2 + SUBROUTINE RECT2 (NA,A,B,SIGT,TRONC,PVV,PVS,PSS,ALPA,PWA) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Integration of the collision probabilities of an homogeneous 2-D +* rectangle (DP-0 surface angular flux approximation). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NA number of Gauss-Legendre base points. +* A X-thickness of the rectangle. +* B Y-thickness of the rectangle. +* SIGT cross section. +* TRONC voided block criterion. +* ALPA Gauss-Legendre base points. +* PWA Gauss-Legendre weights. +* +*Parameters: output +* PVV volume to volume reduced probability. +* PVS volume to surface probabilities: +* XINF surfaces 1, 2 and 3; XSUP surfaces 4, 5 and 6; +* YINF surfaces 7, 8 and 9; YSUP surfaces 10, 11 and 12. +* PSS surface to surface probabilities in the following order: +* PSS(i,j) is the probability from surface i to surface j. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NA + REAL A,B,SIGT,TRONC,PVV,PVS(12),PSS(12,12),ALPA(NA),PWA(NA) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MKI3=600,MKI4=600,MKI5=600) + PARAMETER (PI=3.141592654,ZI40=0.6666666667,ZI50=0.589048623, + 1 ZI60=0.533333333,COEF1=4.24264069,COEF2=2.82842712) + LOGICAL VOID + DOUBLE PRECISION Y1,Y2,AOB,BOA,R,DPREC2,DPREC5,PHI,PHJ,RM,CO,SI, + 1 Z1,Z2,POP,COSI,CO2,ZI3,ZI4,ZI5,ZI6,DEN1,DEN2,GAR(20),QUOT(2), + 2 PHIB(2),ABSC(2),PBB(28) + INTEGER ISN(12,12) + COMMON /BICKL3/BI3(0:MKI3),BI31(0:MKI3),BI32(0:MKI3),PAS3,XLIM3,L3 + COMMON /BICKL4/BI4(0:MKI4),BI41(0:MKI4),BI42(0:MKI4),PAS4,XLIM4,L4 + COMMON /BICKL5/BI5(0:MKI5),BI51(0:MKI5),BI52(0:MKI5),PAS5,XLIM5,L5 + SAVE ISN + DATA ISN/ 0, 0, 0, 4, 12, 0, 1, 9,-19, 1, 9, 19, + 1 0, 0, 0, 8, 16, 0, 5, 13,-23, 5, 13, 23, + 2 0, 0, 0, 0, 0, 28, 17, 21,-25,-17,-21,-25, + 3 4, 12, 0, 0, 0, 0, 1, 9, 19, 1, 9,-19, + 4 8, 16, 0, 0, 0, 0, 5, 13, 23, 5, 13,-23, + 5 0, 0, 28, 0, 0, 0,-17,-21,-25, 17, 21,-25, + 6 3, 11, 20, 3, 11,-20, 0, 0, 0, 2, 10, 0, + 7 7, 15, 24, 7, 15,-24, 0, 0, 0, 6, 14, 0, + 8 -18,-22,-27, 18, 22,-27, 0, 0, 0, 0, 0, 26, + 9 3, 11,-20, 3, 11, 20, 2, 10, 0, 0, 0, 0, + 1 7, 15,-24, 7, 15, 24, 6, 14, 0, 0, 0, 0, + 2 18, 22,-27,-18,-22,-27, 0, 0, 26, 0, 0, 0/ +* + AOB=A/B + BOA=B/A + X=2.0*A*B/(A+B) + VOID=(X*SIGT.LE.TRONC) + SIG=1.0E10 + IF(VOID) GO TO 105 + SIG=1.0/SIGT + IF(A.EQ.B) GO TO 60 +*---- +* RECTANGULAR CELL +*---- + QUOT(1)=BOA + QUOT(2)=AOB + PHIB(1)=ATAN(AOB) + PHIB(2)=ATAN(BOA) + ABSC(1)=B + ABSC(2)=A + DO 10 I=1,20 + GAR(I)=0.0 +10 CONTINUE + DO 55 IL=1,NA + X=0.5*(ALPA(IL)+1.0) + WA=PWA(IL) + L=0 + DO 50 IZ=1,2 + PHI=PHIB(IZ)*X + CO=COS(PHI) + SI=SIN(PHI) + COSI=CO*SI + CO2=CO*CO + Z1=PHIB(IZ)*WA*COSI/(PI*A) + Z2=PHIB(IZ)*WA*(CO-QUOT(IZ)*SI)*2.0/PI + POP=SIGT*ABSC(IZ)/CO + ZI3=0.0 + ZI4=0.0 + ZI5=0.0 + IF(POP.GE.XLIM3) GO TO 40 + K=NINT(POP*PAS3) + ZI3=BI3(K)+POP*(BI31(K)+POP*BI32(K)) + ZI4=BI4(K)+POP*(BI41(K)+POP*BI42(K)) + ZI5=BI5(K)+POP*(BI51(K)+POP*BI52(K)) +40 ZI6=0.8*ZI4+0.2*POP*(ZI3-ZI5) + GAR(L+1)=GAR(L+1)+(ZI40-ZI4)*Z1 + GAR(L+2)=GAR(L+2)+(ZI50-ZI5)*Z1*CO + GAR(L+3)=GAR(L+3)+(ZI50-ZI5)*Z1*SI + GAR(L+4)=GAR(L+4)+(ZI60-ZI6)*Z1*COSI + GAR(L+5)=GAR(L+5)+(ZI60-ZI6)*Z1*CO2 + GAR(L+6)=GAR(L+6)+(ZI60-ZI6)*Z1 + GAR(L+7)=GAR(L+7)+ZI3*Z2 + GAR(L+8)=GAR(L+8)+ZI4*Z2*CO + GAR(L+9)=GAR(L+9)+ZI5*Z2*CO2 + GAR(L+10)=GAR(L+10)+ZI5*Z2 + L=L+10 +50 CONTINUE +55 CONTINUE + PBB(1)=(GAR(1)+GAR(11))*SIG + PBB(2)=GAR(7) + PBB(4)=GAR(17) + PBB(5)=(GAR(3)+GAR(12))*SIG + PBB(6)=GAR(8) + PBB(8)=GAR(18) + PBB(9)=(GAR(2)+GAR(13))*SIG + PBB(10)=GAR(8) + PBB(12)=GAR(18) + PBB(13)=(GAR(4)+GAR(14))*SIG + PBB(14)=GAR(9) + PBB(16)=GAR(19) + PBB(17)=PBB(9) + PBB(19)=PBB(5) + PBB(21)=(GAR(5)+GAR(16)-GAR(15))*SIG + PBB(23)=(GAR(6)-GAR(5)+GAR(15))*SIG + PBB(25)=PBB(13) + PBB(26)=GAR(10)-GAR(9) + PBB(28)=GAR(20)-GAR(19) + GO TO 110 +*---- +* SQUARE CELL +*---- +60 PHI1=0.25*PI + DO 65 I=1,8 + GAR(I)=0.0 +65 CONTINUE + DO 100 IL=1,NA + X=0.5*(ALPA(IL)+1.0) + WA=PWA(IL) + PHI=PHI1*X + CO=COS(PHI) + SI=SIN(PHI) + COSI=CO*SI + Z1=0.25*WA*COSI/A + Z2=0.5*WA*(CO-SI) + POP=SIGT*A/CO + ZI3=0.0 + ZI4=0.0 + ZI5=0.0 + IF(POP.GE.XLIM3) GO TO 90 + K=NINT(POP*PAS3) + ZI3=BI3(K)+POP*(BI31(K)+POP*BI32(K)) + ZI4=BI4(K)+POP*(BI41(K)+POP*BI42(K)) + ZI5=BI5(K)+POP*(BI51(K)+POP*BI52(K)) +90 ZI6=0.8*ZI4+0.2*POP*(ZI3-ZI5) + GAR(1)=GAR(1)+(ZI40-ZI4)*Z1 + GAR(2)=GAR(2)+(ZI50-ZI5)*Z1*(CO+SI) + GAR(3)=GAR(3)+(ZI60-ZI6)*Z1*COSI + GAR(4)=GAR(4)+(ZI60-ZI6)*Z1 + GAR(5)=GAR(5)+ZI3*Z2 + GAR(6)=GAR(6)+ZI4*Z2*CO + GAR(7)=GAR(7)+ZI5*Z2*CO*CO + GAR(8)=GAR(8)+ZI5*Z2 +100 CONTINUE + PBB(1)=2.0*GAR(1)*SIG + PBB(2)=GAR(5) + PBB(4)=PBB(2) + PBB(5)=GAR(2)*SIG + PBB(6)=GAR(6) + PBB(8)=PBB(6) + PBB(9)=PBB(5) + PBB(10)=PBB(6) + PBB(12)=PBB(6) + PBB(13)=2.0*GAR(3)*SIG + PBB(14)=GAR(7) + PBB(16)=PBB(14) + PBB(17)=GAR(2)*SIG + PBB(19)=PBB(17) + PBB(21)=GAR(4)*SIG + PBB(23)=PBB(21) + PBB(25)=2.0*GAR(3)*SIG + PBB(26)=GAR(8)-GAR(7) + PBB(28)=PBB(26) + GO TO 110 +*---- +* VOIDED CELL +*---- +105 Z1=1.0/(8.0*A*B) + IF(A.GT.1.0E2*B) THEN + PHI=0.5D0*PI + R=A*(1.0D0+BOA*BOA*(0.5D0-0.125D0*BOA*BOA)) + RM=BOA*(0.5D0-0.125D0*BOA*BOA) + Y1=LOG(DBLE((R+A)/B)) + PBB(1)=(0.5D0*(1.0D0-RM)+SIGT*B*LOG(B/R)/PI)*BOA + PBB(2)=(R-B)/A-4.0D0*SIGT*(B*PHI+B*BOA*LOG(B/R))/PI + 1 +SIGT*SIGT*B*B*(Y1-(R-B)/A) + PBB(4)=RM + PBB(5)=((1.0-RM)/3.0-0.25*SIGT*B*Y1)*BOA + PBB(6)=4.0*PHI/(3.0*PI)-SIGT*BOA*(R-B) + 1 +2.0*SIGT*SIGT*(B*B*PHI+B*B*BOA*LOG(B/R))/PI + PBB(8)=RM*2.0/3.0 + PBB(9)=(-0.25*SIGT*B*(1.0-BOA*2.0/3.0))*BOA + PBB(13)=(0.125*A/R-SIGT*B/6.0)*BOA + PBB(14)=(R*(R-B)+A*A)/(4.0*A*R)-4.0*SIGT*B*PHI/(3.0*PI) + 1 +0.5*SIGT*SIGT*B*BOA*(R-B) + PBB(16)=RM*4.0/9.0 + PBB(21)=0.125*(1.0-RM*RM*B/R)*BOA + PBB(23)=0.125*((B+B-B*B/R)/B-RM)*BOA + PBB(26)=0.25*PBB(2)*(R-B)/R + PBB(28)=0.25*RM*RM*B/R + PVS(1)=REAL(-0.5D0*BOA*LOG(B/R)/PI) + PVS(7)=REAL((PHI+0.5D0*BOA*LOG(B/R))/PI-0.25D0*SIGT*(B*Y1- + 1 BOA*(R-B))) + DPREC2=Z1*B*(2.0*(R-B)+B*(1.0-BOA*2.0/3.0)) + 1 -0.5*SIGT*B*(PHI+BOA*LOG(B/R))/PI + DPREC5=Z1*B*B*Y1 + PVV=REAL(0.5D0*B*Y1-0.5D0*BOA*(R-B)) + ELSE IF(B.GT.1.0E2*A) THEN + PHJ=0.5D0*PI + R=B*(1.0D0+AOB*AOB*(0.5D0-0.125D0*AOB*AOB)) + RM=AOB*(0.5D0-0.125D0*AOB*AOB) + Y2=LOG(DBLE((R+B)/A)) + PBB(1)=0.5D0*(1.0D0-RM)+SIGT*A*LOG(A/R)/PI + PBB(2)=RM + PBB(4)=(R-A)/B-4.0D0*SIGT*(A*PHJ+A*AOB*LOG(A/R))/PI + 1 +SIGT*SIGT*A*A*(Y2-(R-A)/B) + PBB(5)=-0.25*SIGT*A*(1.0-AOB*2.0/3.0) + PBB(6)=RM*2.0/3.0 + PBB(8)=4.0*PHJ/(3.0*PI)-SIGT*AOB*(R-A) + 1 +2.0*SIGT*SIGT*(A*A*PHJ+A*A*AOB*LOG(A/R))/PI + PBB(9)=(1.0-RM)/3.0-0.25*SIGT*A*Y2 + PBB(13)=0.125*B/R-SIGT*A/6.0 + PBB(14)=RM*4.0/9.0 + PBB(16)=(R*(R-A)+B*B)/(4.0*B*R)-4.0*SIGT*A*PHJ/(3.0*PI) + 1 +0.5*SIGT*SIGT*A*AOB*(R-A) + PBB(21)=0.125*((A+A-A*A/R)/A-RM) + PBB(23)=0.125*(1.0-RM*RM*A/R) + PBB(26)=0.25*RM*RM*A/R + PBB(28)=0.25*PBB(4)*(R-A)/R + PVS(1)=REAL((PHJ+0.5D0*AOB*LOG(A/R))/PI-0.25D0*SIGT*(A*Y2- + 1 AOB*(R-A))) + PVS(7)=REAL(-0.5D0*AOB*LOG(A/R)/PI) + DPREC2=Z1*A*A*Y2 + DPREC5=Z1*A*(2.0*(R-A)+A*(1.0-AOB*2.0/3.0)) + 1 -0.5*SIGT*A*(PHJ+AOB*LOG(A/R))/PI + PVV=REAL(0.5D0*A*Y2-0.5D0*AOB*(R-A)) + ELSE + PHI=ATAN(AOB) + PHJ=ATAN(BOA) + R=SQRT(A*A+B*B) + Y1=LOG(DBLE((R+A)/B)) + Y2=LOG(DBLE((R+B)/A)) + PBB(1)=(A+B-R)/(A+A)+SIGT*(A*LOG(A/R)+B*BOA*LOG(B/R))/PI + 1 +SIGT*SIGT*(R*R*R-A*A*A-B*B*B)/(6.0*A) + PBB(2)=(R-B)/A-4.0*SIGT*(B*PHI+B*BOA*LOG(B/R))/PI + 1 +SIGT*SIGT*B*B*(Y1-(R-B)/A) + PBB(4)=(R-A)/B-4.0*SIGT*A*(PHJ+AOB*LOG(A/R))/PI + 1 +SIGT*SIGT*A*A*(Y2-(R-A)/B) + PBB(5)=(2.0*PHI*B)/(3.0*PI*A)+0.25*SIGT*(-B*BOA*Y1+R-A) + 1 +SIGT*SIGT*(B*B-B*B*BOA*PHI-A*A*LOG(A/R))/(3.0*PI) + PBB(6)=4.0*PHI/(3.0*PI)-SIGT*BOA*(R-B) + 1 +2.0*SIGT*SIGT*(B*B*PHI+B*B*BOA*LOG(B/R))/PI + PBB(8)=4.0*PHJ/(3.0*PI)-SIGT*AOB*(R-A) + 1 +2.0*SIGT*SIGT*A*A*(PHJ+AOB*LOG(A/R))/PI + PBB(9)=2.0*PHJ/(3.0*PI)+0.25*SIGT*(-A*Y2+BOA*(R-B)) + 1 +SIGT*SIGT*(-B*B*BOA*LOG(B/R)+A*B-A*A*PHJ)/(3.0*PI) + PBB(13)=B/(8.0*R)-SIGT*(B*BOA*PHI+A*PHJ-B)/(3.0*PI) + 1 +SIGT*SIGT*(B*B*BOA*Y1+A*A*Y2-B*R)/12.0 + PBB(14)=(R*(R-B)+A*A)/(4.0*A*R)-4.0*SIGT*B*PHI/(3.0*PI) + 1 +0.5*SIGT*SIGT*B*BOA*(R-B) + PBB(16)=(R*(R-A)+B*B)/(4.0*B*R)-4.0*SIGT*A*PHJ/(3.0*PI) + 1 +0.5*SIGT*SIGT*A*AOB*(R-A) + PBB(21)=(A+A+B-A*A/R-R)/(8.0*A)+2.0*SIGT*A*LOG(A/R)/(3.0*PI) + 1 +SIGT*SIGT*(2.0*A*(R-A)+B*BOA*(R-B))/12.0 + PBB(23)=(A+B+B-B*B/R-R)/(8.0*A)+2.0*SIGT*B*BOA*LOG(B/R)/ + 1 (3.0*PI)+SIGT*SIGT*(2.0*B*BOA*(R-B)-A*(R-A))/12.0 + PBB(26)=0.25*PBB(2)*(R-B)/R + PBB(28)=0.25*PBB(4)*(R-A)/R + PVS(1)=REAL((0.5*AOB*LOG(A/R)-0.5*BOA*LOG(B/R)+PHJ)/PI + 1 -0.25*SIGT*((R*R*R-A*A*A-B*B*B)/(3.0*A*B)-(R-A)*AOB+A*Y2)) + PVS(7)=REAL((0.5*BOA*LOG(B/R)-0.5*AOB*LOG(A/R)+PHI)/PI + 1 -0.25*SIGT*((R*R*R-A*A*A-B*B*B)/(3.0*A*B)-(R-B)*BOA+B*Y1)) + DPREC2=Z1*(B*(R-B)+A*A*Y2)-SIGT*(A+2.0*B*BOA*LOG(B/R) + 1 +3.0*B*PHI-A*AOB*PHJ)/(6.0*PI) + DPREC5=Z1*(A*(R-A)+B*B*Y1)-SIGT*(B+2.0*A*AOB*LOG(A/R) + 1 +3.0*A*PHJ-B*BOA*PHI)/(6.0*PI) + PVV=REAL((A*A*A+B*B*B-R*R*R)/(6.0*A*B)+0.5*B*Y1+0.5*A*Y2) + ENDIF + PBB(10)=PBB(6) + PBB(12)=PBB(8) + PBB(17)=PBB(9) + PBB(19)=PBB(5) + PBB(25)=PBB(13) + PVS(2)=REAL(COEF1*DPREC5-COEF2*PVS(1)) + PVS(3)=0.0 + PVS(8)=REAL(COEF1*DPREC2-COEF2*PVS(7)) + PVS(9)=0.0 +* +110 PBB(3)=PBB(1)*AOB + PBB(7)=PBB(9)*AOB + PBB(11)=PBB(5)*AOB + PBB(15)=PBB(13)*AOB + PBB(18)=PBB(19)*AOB + PBB(20)=PBB(17)*AOB + PBB(22)=PBB(23)*AOB + PBB(24)=PBB(21)*AOB + PBB(27)=PBB(25)*AOB +*---- +* ORTHONORMALIZATION +*---- + DO 120 I=1,4 + DEN1=PBB(4+I) + DEN2=PBB(8+I) + PBB(4+I)=COEF1*DEN1-COEF2*PBB(I) + PBB(8+I)=COEF1*DEN2-COEF2*PBB(I) + PBB(12+I)=18.0*PBB(12+I)-12.0*(DEN1+DEN2)+8.0*PBB(I) + PBB(24+I)=4.0*PBB(24+I) +120 CONTINUE + DO 130 I=1,2 + DEN1=PBB(16+I) + DEN2=PBB(18+I) + PBB(16+I)=2.0*DEN1 + PBB(18+I)=2.0*DEN2 + PBB(20+I)=2.0*(COEF1*PBB(20+I)-COEF2*DEN1) + PBB(22+I)=2.0*(COEF1*PBB(22+I)-COEF2*DEN2) +130 CONTINUE +* + IF(.NOT.VOID) THEN + PVS(7)=REAL(0.25*SIG*(1.0-2.0*PBB(1)-PBB(2))/B) + PVS(8)=REAL(-0.25*SIG*(2.0*PBB(9)+PBB(10))/B) + PVS(9)=0.0 + PVS(1)=REAL(0.25*SIG*(1.0-2.0*PBB(3)-PBB(4))/A) + PVS(2)=REAL(-0.25*SIG*(2.0*PBB(11)+PBB(12))/A) + PVS(3)=0.0 + PVV=REAL(SIG*(1.0-2.0*(PVS(7)+PVS(1)))) + ENDIF + PVS(4)=PVS(1) + PVS(5)=PVS(2) + PVS(6)=PVS(3) + PVS(10)=PVS(7) + PVS(11)=PVS(8) + PVS(12)=PVS(9) + DO 150 JC=1,12 + DO 140 IC=1,12 + PSS(IC,JC)=0.0 + IB=ISN(IC,JC) + IF(IB.LT.0) THEN + PSS(IC,JC)=REAL(-PBB(-IB)) + ELSE IF(IB.GT.0) THEN + PSS(IC,JC)=REAL(PBB(IB)) + ENDIF + 140 CONTINUE + 150 CONTINUE + RETURN + END diff --git a/Dragon/src/S2M.f b/Dragon/src/S2M.f new file mode 100644 index 0000000..61b927e --- /dev/null +++ b/Dragon/src/S2M.f @@ -0,0 +1,191 @@ +*DECK S2M + SUBROUTINE S2M(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To recover information from a SERPENT output file and translate the +* requested data towards a macrolib. +* +*Copyright: +* Copyright (C) 2014 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1) create or modification ascii file containing +* Apotrim data; +* HENTRY(2) read-only type(L_MACROLIB). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPMAC,JPMAC,KPMAC + PARAMETER (NSTATE=40,IOUT=6) + CHARACTER TEXT12*12,HSIGN*12,HLINE*512,CM*2 + LOGICAL LB1,LFIS + DOUBLE PRECISION DFLOTT + INTEGER ISTATE(NSTATE) + PARAMETER(CM='00') +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: XS,FLUX,FISS,CHI,DIFF,GAR3 + REAL, ALLOCATABLE, DIMENSION(:,:) :: SCAT +* + IF(NENTRY.LE.1) CALL XABORT('S2M: MINIMUM OF 2 OBJECTS EXPECTED.') + TEXT12=HENTRY(1) + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.4)) CALL XABORT('S2M: LCM ' + 1 //'OBJECT EXPECTED AT LHS.') + IF(JENTRY(1).EQ.2) CALL XABORT('S2M: LCM OBJECT IN CREATE OR MOD' + 1 //'IFICATION MODE EXPECTED AT LHS.') + IPMAC=KENTRY(1) + IF(IENTRY(2).NE.4) CALL XABORT('S2M: ASCII FILE NAMED '//TEXT12 + 1 //' EXPECTED AT RHS.') + IF(JENTRY(2).NE.2) CALL XABORT('S2M: ASCII FILE IN READ-ONLY MOD' + 1 //'E EXPECTED AT RHS.') + IFIN=FILUNIT(KENTRY(2)) + HSIGN='L_MACROLIB' + CALL LCMPTC(IPMAC,'SIGNATURE',12,HSIGN) +*---- +* READ THE INPUT DATA +*---- + IMPX=1 + IDX=1 + NGRP=0 + LB1=.FALSE. + 20 CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('S2M: CHARACTER DATA EXPECTED(1).') + IF(TEXT12.EQ.'EDIT') THEN +* READ THE PRINT INDEX. + CALL REDGET(INDIC,IMPX,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('S2M: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT12.EQ.'IDX') THEN +* READ THE INSTANCE INDEX. + CALL REDGET(INDIC,IDX,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('S2M: INTEGER DATA EXPECTED(2).') + IF(IDX.LE.0) CALL XABORT('S2M: INVALID VALUE OF IDX.') + ELSE IF(TEXT12.EQ.'B1') THEN + LB1=.TRUE. + ELSE IF(TEXT12.EQ.';') THEN + GO TO 30 + ELSE + CALL XABORT('S2M: '//TEXT12//' IS AN INVALID KEYWORD.') + ENDIF + GO TO 20 +*---- +* FIND THE NUMBER OF ENERGY GROUPS +*---- + 30 DO + READ(IFIN,'(A)',END=40) HLINE + IND1=INDEX(HLINE,'GC_NE (idx, 1)') + IF(IND1.GT.0) THEN + IND2=INDEX(HLINE,';') + READ(HLINE(45:IND2-1),'(I5)') NGRP + GO TO 50 + ENDIF + ENDDO + 40 CALL XABORT('S2M: UNABLE TO FING NUMBER OF ENERGY GROUPS.') + 50 IF(IMPX.GT.0) WRITE(IOUT,100) NGRP +*---- +* DETERMINE IF THE ISOTOPE IS FISSILE +*---- + LFIS=.FALSE. + DO + READ(IFIN,'(A)',END=40) HLINE + IND1=INDEX(HLINE,'CHI') + IF(IND1.GT.0) THEN + LFIS=.TRUE. + GO TO 60 + ENDIF + ENDDO + 60 IF(IMPX.GT.0) WRITE(IOUT,110) LFIS +*---- +* RECOVER CROSS SECTIONS +*---- + ALLOCATE(XS(NGRP+1),FLUX(NGRP+1),CHI(NGRP),FISS(NGRP+1), + > SCAT(NGRP,NGRP),DIFF(NGRP),GAR3(NGRP*NGRP)) + CALL S2MGET(IFIN,'GC_BOUNDS',IDX,.FALSE.,NGRP+1,XS(1)) + DO IGRP=1,NGRP+1 + XS(IGRP)=XS(IGRP)*1.0E6 + ENDDO + CALL LCMPUT(IPMAC,'ENERGY',NGRP+1,2,XS) + CALL S2MGET(IFIN,'TOTXS',IDX,.TRUE.,NGRP+1,XS(1)) + CALL S2MGET(IFIN,'FLUX',IDX,.TRUE.,NGRP+1,FLUX(1)) + CALL S2MGET(IFIN,'GTRANSFXS',IDX,.TRUE.,NGRP*NGRP,SCAT(1,1)) ! I -> J + IF(LFIS) THEN + CALL S2MGET(IFIN,'CHI ',IDX,.TRUE.,NGRP,CHI(1)) + CALL S2MGET(IFIN,'NSF ',IDX,.TRUE.,NGRP+1,FISS(1)) + ENDIF + IF(LB1) THEN + CALL S2MGET(IFIN,'B1_DIFFCOEF',IDX,.TRUE.,NGRP,DIFF(1)) + ENDIF + JPMAC=LCMLID(IPMAC,'GROUP',NGRP) + DO IGRP=1,NGRP + KPMAC=LCMDIL(JPMAC,IGRP) + CALL LCMPUT(KPMAC,'NTOT0',1,2,XS(IGRP+1)) + CALL LCMPUT(KPMAC,'NWT0',1,2,FLUX(IGRP+1)) + IF(LFIS) THEN + CALL LCMPUT(KPMAC,'CHI',1,2,CHI(IGRP)) + CALL LCMPUT(KPMAC,'NUSIGF',1,2,FISS(IGRP+1)) + ENDIF + IF(LB1) THEN + CALL LCMPUT(KPMAC,'DIFF',1,2,DIFF(IGRP)) + ENDIF + IPOSDE=0 + IPOS=1 + IGMIN=IGRP + IGMAX=IGRP + DO JGRP=1,NGRP + IF(SCAT(JGRP,IGRP).NE.0.0) THEN + IGMIN=MIN(IGMIN,JGRP) + IGMAX=MAX(IGMAX,JGRP) + ENDIF + ENDDO + IJJ=IGMAX + NJJ=IGMAX-IGMIN+1 + DO JGRP=IGMAX,IGMIN,-1 + IPOSDE=IPOSDE+1 + GAR3(IPOSDE)=SCAT(JGRP,IGRP) + ENDDO + CALL LCMPUT(KPMAC,'SCAT'//CM,IPOSDE,2,GAR3) + CALL LCMPUT(KPMAC,'SIGW'//CM,1,2,SCAT(IGRP,IGRP)) + CALL LCMPUT(KPMAC,'NJJS'//CM,1,1,NJJ) + CALL LCMPUT(KPMAC,'IJJS'//CM,1,1,IJJ) + CALL LCMPUT(KPMAC,'IPOS'//CM,1,1,IPOS) + ENDDO + ISTATE(:NSTATE)=0 + ISTATE(1)=NGRP + ISTATE(2)=1 + ISTATE(3)=1 + IF(LFIS) ISTATE(4)=1 + CALL LCMPUT(IPMAC,'STATE-VECTOR',NSTATE,1,ISTATE) + DEALLOCATE(GAR3,DIFF,SCAT,FISS,CHI,FLUX,XS) + RETURN +* + 100 FORMAT(/30H S2M: NUMBER OF ENERGY GROUPS=,I5) + 110 FORMAT(/19H S2M: FISSILE FLAG=,L1) + END diff --git a/Dragon/src/S2MGET.f b/Dragon/src/S2MGET.f new file mode 100644 index 0000000..35fa231 --- /dev/null +++ b/Dragon/src/S2MGET.f @@ -0,0 +1,67 @@ +*DECK S2MGET + SUBROUTINE S2MGET(IFIN,HNAME,IDX,LRMS,NGRP,XS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To read a record in the Matlab-formatted SERPENT output file. +* +*Copyright: +* Copyright (C) 2014 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IFIN SERPENT unit number. +* HNAME record name. +* IDX instance index on the record (generally equal to the burnup +* step). +* LRMS standard deviation flag (.TRUE. if the standard deviation is +* present). +* NGRP number of energy groups. +* +*Parameters: output +* XS record recovered from SERPENT file. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IFIN,IDX,NGRP + LOGICAL LRMS + CHARACTER*(*) HNAME + REAL XS(NGRP) +*---- +* LOCAL VARIABLES +*---- + CHARACTER HLINE*50000,PREFIX*26,HSMG*131 +* + REWIND(IFIN) + IF(LEN(HNAME).GT.26) CALL XABORT('LCMGET: PREFIX OVERFLOW.') + PREFIX=HNAME + N=0 + DO + READ(IFIN,'(A)',END=10) HLINE + IND1=INDEX(HLINE,PREFIX) + IF(IND1.GT.0) N=N+1 + IF(N.EQ.IDX) GO TO 20 + ENDDO + 10 WRITE(HSMG,'(22HS2MGET: UNABLE TO FIND,I5,14H INSTANCES OF ,A, + > 9H RECORD (,I5,8H FOUND).)') IDX,HNAME,N + CALL XABORT(HSMG) + 20 IND1=47 + DO IGR=1,NGRP + READ(HLINE(IND1:IND1+11),'(E12.0)') XS(IGR) + IF(LRMS) THEN + IND1=IND1+21 + ELSE + IND1=IND1+13 + ENDIF + ENDDO + RETURN + END diff --git a/Dragon/src/SALACG.f90 b/Dragon/src/SALACG.f90 new file mode 100644 index 0000000..0dbc708 --- /dev/null +++ b/Dragon/src/SALACG.f90 @@ -0,0 +1,309 @@ +! +!--------------------------------------------------------------------- +! +!Purpose: +! To analyze a geometry made of surfacic element using the SALT +! tracking procedure. +! +!Copyright: +! Copyright (C) 2014 Ecole Polytechnique de Montreal. +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version +! +!Author(s): +! A. Hebert +! +!Parameters: input +! FGEO unit file number of the surfacic file in read only mode. +! ITRACK pointer to the TRACKING data structure in creation mode. +! RCUTOF minimum distance between two surfacic elements. +! IPRINT print level. +! +!Parameters: output +! GG geometry basic information. +! +!--------------------------------------------------------------------- +! +SUBROUTINE SALACG(FGEO ,ITRACK, RCUTOF, IPRINT, GG) + USE GANLIB + USE PRECISION_AND_KINDS, ONLY : PDB + USE SAL_GEOMETRY_TYPES, ONLY : T_G_BASIC,TYPGEO,NBFOLD,NBMED,F_GEO,ISPEC, & + & LGSPEC,LMERGM + USE SAL_TRACKING_TYPES, ONLY : PRTIND,EPS1 + USE SAL_GEOMETRY_MOD, ONLY : SAL100 + IMPLICIT NONE + !---- + ! Subroutine arguments + !---- + TYPE(C_PTR) ITRACK + INTEGER FGEO,IPRINT + REAL(PDB) RCUTOF + TYPE(T_G_BASIC) :: GG + !---- + ! Local variables + !---- + INTEGER, PARAMETER :: NSTATE=40 + INTEGER, PARAMETER :: NDIM=2 ! NUMBER OF DIMENSIONS + INTEGER, PARAMETER :: NALBG=6 ! NUMBER OF ALBEDOS + LOGICAL LGINF + INTEGER, DIMENSION(NSTATE) :: I_STATE,IEDIMG + INTEGER OK,I,J,NREG,ELEM,NFREG,LEAK,NSOUT,ICODE(NALBG),INDEX,MMAX + REAL GALBED(NALBG) + CHARACTER(LEN=72) TEXT72 + REAL(PDB) :: DGMESHX(2),DGMESHY(2) + !---- + ! Allocatable arrays + !---- + INTEGER, DIMENSION(:) , ALLOCATABLE :: ITAB ! LOCAL ARRAY + REAL, DIMENSION(:), ALLOCATABLE :: VOLUME ! LOCAL VOLUME SINGLE PRECISION + INTEGER, ALLOCATABLE, DIMENSION(:) :: MATALB,KEYMRG,IBC + REAL(PDB), ALLOCATABLE, DIMENSION(:) :: VOLSUR + !---- + ! Recover options from state vector + !---- + CALL LCMGET(ITRACK,'STATE-VECTOR',I_STATE) + !---- + ! Read the surfacic file and fill GG object + !---- + PRTIND=IPRINT + F_GEO=FGEO + EPS1=1.E-5_PDB + IF(RCUTOF>0._PDB) THEN + EPS1=RCUTOF + IF(PRTIND>0) WRITE(*,*) "SALACG: set eps1 to ",EPS1 + ENDIF + !------------ + call SAL100(GG) + !------------ + IF(IPRINT > 0) WRITE(6,'(/" SALACG: TYPGEO=",I5," NBFOLD=",I5)') TYPGEO,NBFOLD + !---- + ! Perform optional MERGE MIX + !---- + IF(LMERGM) THEN + GG%NUM_MERGE(:)=GG%MED(:) + MMAX=MAXVAL(GG%NUM_MERGE(:)) + DO I=1,MMAX + 10 IF(I.GT.MAXVAL(GG%NUM_MERGE(:))) EXIT + DO J=1,GG%NB_NODE + IF(GG%NUM_MERGE(J).EQ.I) GO TO 20 + ENDDO + DO J=1,GG%NB_NODE + IF(GG%NUM_MERGE(J).GE.I) GG%NUM_MERGE(J)=GG%NUM_MERGE(J)-1 + ENDDO + GO TO 10 + 20 CONTINUE + ENDDO + ENDIF + !---- + ! Store GG object in geometry directory on LCM + !---- + CALL LCMSIX(ITRACK,'GEOMETRY ',1) + CALL LCMPUT(ITRACK,'NB_ELEM ',1,1,GG%NB_ELEM) + CALL LCMPUT(ITRACK,'NIPAR ',1,1,SIZE(GG%IPAR,1)) + CALL LCMPUT(ITRACK,'IPAR ',SIZE(GG%IPAR),1,GG%IPAR) + CALL LCMPUT(ITRACK,'RPAR ',SIZE(GG%RPAR),4,GG%RPAR) + CALL LCMPUT(ITRACK,'ISURF2_ELEM ',SIZE(GG%ISURF2_ELEM),1,GG%ISURF2_ELEM) + CALL LCMPUT(ITRACK,'NB_NODE ',1,1,GG%NB_NODE) + CALL LCMPUT(ITRACK,'VOL_NODE ',GG%NB_NODE,4,GG%VOL_NODE) + CALL LCMPUT(ITRACK,'NB_SURF2 ',1,1,GG%NB_SURF2) + IF(GG%NBBCDA.GT.0) THEN + LGINF = .TRUE. + DO I=1, GG%NBBCDA + LGINF = LGINF .AND. (GG%BCDATAREAD(I)%BCDATA(6) == 1._PDB) + ENDDO + ELSE + LGINF = (GG%ALBEDO == 1._PDB) + ENDIF + IF(GG%NB_SURF2 > 0) THEN + CALL LCMPUT(ITRACK,'IBC2_SURF2 ',SIZE(GG%IBC2_SURF2),1,GG%IBC2_SURF2) + CALL LCMPUT(ITRACK,'IELEM_SURF2 ',SIZE(GG%IELEM_SURF2),1,GG%IELEM_SURF2) + CALL LCMPUT(ITRACK,'SURF2 ',SIZE(GG%SURF2),4,GG%SURF2) + ENDIF + CALL LCMPUT(ITRACK,'NPERIM_MAC2 ',1,1,GG%NPERIM_MAC2) + CALL LCMPUT(ITRACK,'PERIM_MAC2 ',SIZE(GG%PERIM_MAC2),1,GG%PERIM_MAC2) + CALL LCMPUT(ITRACK,'PPERIM_MAC2 ',SIZE(GG%PPERIM_MAC2),1,GG%PPERIM_MAC2) + CALL LCMPUT(ITRACK,'PERIM_NODE ',SIZE(GG%PERIM_NODE),1,GG%PERIM_NODE) + CALL LCMPUT(ITRACK,'PPERIM_NODE ',SIZE(GG%PPERIM_NODE),1,GG%PPERIM_NODE) + CALL LCMPUT(ITRACK,'BC_DATA_DIM2',1,1,SIZE(GG%BCDATA,2)) + IF(SIZE(GG%BCDATA) > 0) THEN + CALL LCMPUT(ITRACK,'BC_DATA ',SIZE(GG%BCDATA),4,GG%BCDATA) + ENDIF + CALL LCMPUT(ITRACK,'NB_BC2 ',1,1,GG%NB_BC2) + CALL LCMPUT(ITRACK,'TYPE_BC2 ',SIZE(GG%TYPE_BC2),1,GG%TYPE_BC2) + CALL LCMPUT(ITRACK,'IDATA_BC2 ',SIZE(GG%IDATA_BC2),1,GG%IDATA_BC2) + CALL LCMSIX(ITRACK,' ',2) ! come back to father directory + !---- + ! Print tracking object directory + !---- + IF(IPRINT > 1) THEN + CALL LCMLIB(ITRACK) + CALL LCMSIX(ITRACK,'GEOMETRY',1) + CALL LCMLIB(ITRACK) + CALL LCMSIX(ITRACK,' ',2) + ENDIF + !---- + ! store the STATE VECTOR + !---- + NREG=MAXVAL(GG%NUM_MERGE) + LEAK=1 + IF(.NOT.LGINF) LEAK=0 ! reset the leakage flag + I_STATE(1) = NREG ! number of regions + I_STATE(2) = NREG ! number of unknowns in DRAGON + I_STATE(3) = LEAK ! 1 = absent leakage, 0 leakage + I_STATE(4) = NBMED ! maximum number of mixture + IF(ISPEC == 0) THEN + I_STATE(5)=GG%NB_SURF2 ! number of outer surface + NSOUT=GG%NB_SURF2 + ELSE IF((TYPGEO == 7).OR.(TYPGEO == 8).OR.(TYPGEO == 10).OR.(TYPGEO == 12)) THEN + I_STATE(5)=3 + NSOUT=3 + ELSE IF(TYPGEO == 9) THEN + I_STATE(5)=6 + NSOUT=6 + ELSE + I_STATE(5)=4 + NSOUT=4 + ENDIF + CALL LCMPUT(ITRACK,'STATE-VECTOR',NSTATE,1,I_STATE) + ! + ! fill-in medium number per region + ALLOCATE(ITAB(NREG),VOLUME(NREG), STAT =OK) + IF(OK /= 0) CALL XABORT('SALACG: failure to allocate integer ITAB') + ! fill in MATCOD + DO J=1,GG%NB_NODE + ITAB(GG%NUM_MERGE(J)) = GG%MED(J) + ENDDO + CALL LCMPUT(ITRACK,'MATCOD',NREG,1,ITAB(1:NREG) ) + ! fill-in KEYFLX per region + DO I=1,NREG + ITAB(I) = I + ENDDO + CALL LCMPUT(ITRACK,'MERGE',NREG,1,ITAB) + CALL LCMPUT(ITRACK,'KEYFLX',NREG,1,ITAB) + ! fill-in volumes per region + VOLUME(:NREG) =0. + DO I=1,GG%NB_NODE + VOLUME(GG%NUM_MERGE(I)) = VOLUME(GG%NUM_MERGE(I)) + REAL(GG%VOL_NODE(I)) + ENDDO + CALL LCMPUT(ITRACK,'VOLUME',NREG,2,VOLUME) + DEALLOCATE(VOLUME,ITAB) + + ! useful values in SAL_TRACKING_TYPES module + NFREG=GG%NB_NODE + CALL LCMSIX(ITRACK,'NXTRecords',1) + DGMESHX=(/ 1.E10_PDB , -1.E10_PDB /) + DGMESHY=(/ 1.E10_PDB , -1.E10_PDB /) + DO ELEM=1,GG%NB_ELEM + DGMESHX(1)=MIN(DGMESHX(1),GG%RPAR(1,ELEM)) + DGMESHX(2)=MAX(DGMESHX(2),GG%RPAR(1,ELEM)) + DGMESHY(1)=MIN(DGMESHY(1),GG%RPAR(2,ELEM)) + DGMESHY(2)=MAX(DGMESHY(2),GG%RPAR(2,ELEM)) + ENDDO + CALL LCMPUT(ITRACK,'G00000001SMX',2,4,DGMESHX) + CALL LCMPUT(ITRACK,'G00000001SMY',2,4,DGMESHY) + IEDIMG(:NSTATE)=0 + IEDIMG(1)=NDIM + IEDIMG(2)=0 ! Cartesian geometry + IF(TYPGEO.EQ.8) IEDIMG(2)=2 ! Isocel geometry with specular reflection + IF(TYPGEO.EQ.9) IEDIMG(2)=3 ! Hexagonal geometry with translation + IF(TYPGEO.EQ.10) IEDIMG(2)=4 ! Isocel geometry with RA60 symmetry + IF(TYPGEO.EQ.11) IEDIMG(2)=5 ! Lozenge geometry with R120 rotation + IF(TYPGEO.EQ.12) IEDIMG(2)=6 ! S30 geometry with specular reflection + IEDIMG(5)=1 ! 1 cellule + IEDIMG(13)=1 ! 1 cellule + IEDIMG(14)=1 ! 1 cellule + IEDIMG(22)=NSOUT ! number of external surfaces for this geometry + IEDIMG(23)=NFREG ! number of regions for this geometry + IEDIMG(25)=GG%NB_NODE + CALL LCMPUT(ITRACK,'G00000001DIM',NSTATE,1,IEDIMG) + CALL LCMSIX(ITRACK,' ',2) ! come back to father directory + !---- + ! process boundary conditions + !---- + IF(LGSPEC) THEN + IF(ISPEC/=1) CALL XABORT('SALACG: the surfacic file can only be used with' & + //' cyclic tracking') + ENDIF + IF(IPRINT>0) WRITE(6,*) 'number of merged regions,surfaces,nodes',NREG,NSOUT,NFREG + ALLOCATE(MATALB(-NSOUT:NFREG),VOLSUR(-NSOUT:NFREG),KEYMRG(-NSOUT:NFREG)) + CALL LCMGET(ITRACK,'MATCOD',MATALB(1)) + ALLOCATE(VOLUME(NREG)) + CALL LCMGET(ITRACK,'VOLUME',VOLUME) + VOLSUR(1:NREG)=VOLUME(:NREG) + DEALLOCATE(VOLUME) + ! boundary conditions structures + ICODE(:NALBG)=(/ (-I,I=1,NALBG) /) + GALBED(:NALBG)=REAL(GG%ALBEDO) + IF(ISPEC == 0) THEN + IF(GG%NALBG > 6) CALL XABORT('SALACG: Albedo array overflow(1).') + DO I=1,NSOUT + KEYMRG(-I)=-I + VOLSUR(-I)=GG%SURF2(I) + INDEX=GG%IDATA_BC2(GG%IBC2_SURF2(I)) + IF(INDEX.EQ.0) THEN + ! Use the default albedo + MATALB(-I)=-1 + GALBED(1)=REAL(GG%ALBEDO) + ELSE + IF(INDEX.GT.6) CALL XABORT('SALACG: SDIRE overflow.') + IF(INDEX > GG%NALBG) THEN + CALL XABORT('SALACG: Albedo array overflow(2).') + ENDIF + MATALB(-I)=-INDEX + IF(SIZE(GG%BCDATA) > 0) THEN + GALBED(INDEX)=REAL(GG%BCDATA(6,INDEX)) + ELSE + GALBED(INDEX)=REAL(GG%ALBEDO) + ENDIF + ENDIF + ENDDO + ELSE + DO I=1,NSOUT + VOLSUR(-I)=0.0 + KEYMRG(-I)=-I + MATALB(-I)=-1 + ENDDO + GALBED(:NALBG)=1.0 + ENDIF + MATALB(0)=0 + KEYMRG(0)=0 + VOLSUR(0)=0._PDB + DO I=1,NREG + KEYMRG(I)=I + ENDDO + ! + IF(IPRINT>1) THEN + CALL PRINDM('VOLUME',VOLSUR(-NSOUT),NREG+NSOUT+1) + CALL PRINIM('MATALB',MATALB(-NSOUT),NREG+NSOUT+1) + CALL PRINIM('KEYMRG',KEYMRG(-NSOUT),NREG+NSOUT+1) + ENDIF + IF(IPRINT>0) THEN + CALL PRINIM('ICODE ',ICODE(1),NALBG) + CALL PRINAM('GALBED',GALBED(1),NALBG) + ENDIF + !---- + ! fill in tracking LCM object in excelt format + !---- + TEXT72='SAL TRACKING' + CALL LCMPTC(ITRACK,'TITLE',72,TEXT72) + CALL LCMPUT(ITRACK,'ICODE',NALBG,1,ICODE) + CALL LCMSIX(ITRACK,'NXTRecords',1) + CALL LCMPUT(ITRACK,'SAreaRvolume',NREG+NSOUT+1,4,VOLSUR(-NSOUT)) + CALL LCMPUT(ITRACK,'MATALB',NREG+NSOUT+1,1,MATALB(-NSOUT)) + CALL LCMPUT(ITRACK,'KEYMRG',NREG+NSOUT+1,1,KEYMRG(-NSOUT)) + CALL LCMSIX(ITRACK,' ',2) + IF(NSOUT>0) THEN + ALLOCATE(IBC(NSOUT)) + DO I=1,NSOUT + IBC(I)=I + ENDDO + CALL LCMPUT(ITRACK,'BC-REFL+TRAN',NSOUT,1,IBC) + DEALLOCATE(IBC) + ENDIF + CALL LCMPUT(ITRACK,'MATCOD',NREG,1,MATALB(1)) + CALL LCMPUT(ITRACK,'ALBEDO',NALBG,2,GALBED) + DEALLOCATE(KEYMRG,VOLSUR,MATALB) + RETURN +END SUBROUTINE SALACG diff --git a/Dragon/src/SALEND.f90 b/Dragon/src/SALEND.f90 new file mode 100644 index 0000000..f1a6ffc --- /dev/null +++ b/Dragon/src/SALEND.f90 @@ -0,0 +1,47 @@ +! +!--------------------------------------------------------------------- +! +!Purpose: +! To release allocated T_G_BASIC in SALT: module. +! +!Copyright: +! Copyright (C) 2014 Ecole Polytechnique de Montreal. +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version +! +!Author(s): +! A. Hebert +! +!--------------------------------------------------------------------- +! +SUBROUTINE SALEND(GG) + USE SAL_GEOMETRY_TYPES, ONLY : T_G_BASIC + TYPE(T_G_BASIC) :: GG + INTEGER :: OK,ELEM + !---- + ! Release geometry allocated memory + !---- + DEALLOCATE(GG%IPAR,GG%RPAR,GG%IBC2_ELEM,GG%ISURF2_ELEM,GG%VOL_NODE,GG%PPERIM_NODE, & + GG%TYPE_BC2,GG%IDATA_BC2,GG%PERIM_MAC2,GG%MED,GG%PERIM_NODE,STAT =OK) + IF(OK /= 0) CALL XABORT('SALEND: failure to deallocate GG members(1)') + IF(GG%NB_SURF2>0) THEN + DEALLOCATE(GG%IBC2_SURF2,GG%IELEM_SURF2,GG%SURF2,STAT =OK) + IF(OK /= 0) CALL XABORT('SALEND: failure to deallocate GG surf members') + ENDIF + DEALLOCATE(GG%NUM_MERGE,STAT =OK) + IF(OK /= 0) CALL XABORT('SALEND: failure to deallocate GG%NUM_MERGE') + DEALLOCATE(GG%NAME_MACRO,STAT =OK) + IF(OK /= 0) CALL XABORT('SALEND: failure to deallocate GG%NAME_MACRO') + DEALLOCATE(GG%NUM_MACRO,STAT =OK) + IF(OK /= 0) CALL XABORT('SALEND: failure to deallocate GG%NUM_MACRO') + IF(GG%NBBCDA>0) THEN + DO ELEM=1,GG%NBBCDA + DEALLOCATE(GG%BCDATAREAD(ELEM)%ELEMNB,STAT =OK) + IF(OK /= 0) CALL XABORT('SALEND: failure to deallocate GG%BCDATAREAD(ELEM)%ELEMNB') + ENDDO + DEALLOCATE(GG%BCDATAREAD,STAT =OK) + IF(OK /= 0) CALL XABORT('SALEND: FAILURE TO DEALLOCATE GG%BCDATAREAD') + ENDIF +END SUBROUTINE SALEND diff --git a/Dragon/src/SALGET_FUNS_MOD.f90 b/Dragon/src/SALGET_FUNS_MOD.f90 new file mode 100644 index 0000000..704e693 --- /dev/null +++ b/Dragon/src/SALGET_FUNS_MOD.f90 @@ -0,0 +1,373 @@ +! +!--------------------------------------------------------------------- +! +!Purpose: +! To read surfacic file. +! +!Copyright: +! Copyright (C) 2001 Ecole Polytechnique de Montreal. +! +!Author(s): +! X. Warin +! +!--------------------------------------------------------------------- +! +MODULE SALGET_FUNS_MOD + + USE CONSTUTILES, ONLY : FORMATR,FORMATI + ! + ! GENERIC INTERFACES + ! + INTERFACE SALGET + MODULE PROCEDURE & + SALRIN, SALRIN_0, & + SALRRE, SALRRE_0, & + SALRDB, SALRDB_0, & + SALRCH, SALRCH_0 + END INTERFACE + ! +CONTAINS + ! + SUBROUTINE SALRIN(DATAIN,N,FIN,FOUT,TEXT) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! reading text comment cards followed by N integers + ! first card before integer data must have a '*' in first column + ! + !Parameters: input + ! N number of integer to be read + ! FOUT index of output file (if =0 no printing) + ! TEXT description of sought input (for debug) + ! + !Parameters: input/output + ! FIN index of input file (FIN < 0 => do not call SALTIT) + ! + !Parameters: output + ! DATAIN integer array of dimension >= N + ! + !--------------------------------------------------------------------- + ! + INTEGER, INTENT(IN) :: N,FOUT + INTEGER, INTENT(INOUT) :: FIN + INTEGER, INTENT(OUT), DIMENSION(N) :: DATAIN + CHARACTER (LEN=*), INTENT(IN) :: TEXT + !** + INTEGER :: I + LOGICAL :: LGFIN + !** + LGFIN=FIN.LT.0 + IF(LGFIN)THEN + FIN=-FIN + ELSE + CALL SALTIT('*',FIN,FOUT,TEXT) + ENDIF + READ(FIN,*)(DATAIN(I),I=1,N) + IF(FOUT.NE.0)WRITE(FOUT,'(1X,10I8)')(DATAIN(I),I=1,N) + IF(LGFIN)FIN=-FIN + ! + END SUBROUTINE SALRIN + ! + SUBROUTINE SALRIN_0(DATAIN,FIN,FOUT,TEXT) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! reading text comment cards followed by a single integer + ! first card before integer data must have a '*' in first column + ! + !Parameters: input + ! FOUT index of output file (if =0 no printing) + ! TEXT description of sought input (for debug) + ! + !Parameters: input/output + ! FIN index of input file (FIN < 0 => do not call SALTIT) + ! + !Parameters: output + ! DATAIN integer value + ! + !--------------------------------------------------------------------- + ! + INTEGER, INTENT(IN) :: FOUT + INTEGER, INTENT(INOUT) :: FIN + INTEGER, INTENT(INOUT) :: DATAIN + CHARACTER (LEN=*), INTENT(IN) :: TEXT + !**** + LOGICAL :: LGFIN + !**** + LGFIN=FIN.LT.0 + IF(LGFIN)THEN + FIN=-FIN + ELSE + CALL SALTIT('*',FIN,FOUT,TEXT) + ENDIF + READ(FIN,*) DATAIN + IF(FOUT.NE.0)WRITE(FOUT,'(1X,10I8)') DATAIN + IF(LGFIN)FIN=-FIN + ! + END SUBROUTINE SALRIN_0 + ! + SUBROUTINE SALRRE(DATAIN,N,FIN,FOUT,TEXT) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! reading text comment cards followed by N reals + ! first card before integer data must have a '*' in first column + ! + !Parameters: input + ! N number of integer to be read (format 1P5E15.6) + ! FOUT index of output file (if =0 no printing) + ! TEXT description of sought input (for debug) + ! + !Parameters: input/output + ! FIN index of input file (FIN < 0 => do not call SALTIT) + ! + !Parameters: output + ! DATAIN real array of dimension >= N + ! + !--------------------------------------------------------------------- + ! + INTEGER, INTENT(IN) :: N,FIN,FOUT + REAL, INTENT(OUT), DIMENSION(N) :: DATAIN + CHARACTER (LEN=*), INTENT(IN) :: TEXT + !**** + INTEGER :: I + !**** + CALL SALTIT('*',FIN,FOUT,TEXT) + READ(FIN,*)(DATAIN(I),I=1,N) + IF(FOUT.NE.0)WRITE(FOUT,'(1X,1P,5'//FORMATR//')')(DATAIN(I),I=1,N) + ! + END SUBROUTINE SALRRE + ! + SUBROUTINE SALRRE_0(DATAIN,FIN,FOUT,TEXT) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! reading text comment cards followed by a single real + ! first card before integer data must have a '*' in first column + ! + !Parameters: input + ! FOUT index of output file (if =0 no printing) + ! TEXT description of sought input (for debug) + ! + !Parameters: input/output + ! FIN index of input file (FIN < 0 => do not call SALTIT) + ! + !Parameters: output + ! DATAIN real value + ! + !--------------------------------------------------------------------- + ! + INTEGER, INTENT(IN) :: FIN,FOUT + REAL, INTENT(OUT) :: DATAIN + CHARACTER (LEN=*), INTENT(IN) :: TEXT + !**** + CALL SALTIT('*',FIN,FOUT,TEXT) + READ(FIN,*)DATAIN + IF(FOUT.NE.0)WRITE(FOUT,'(1X,1P,5'//FORMATR//')')DATAIN + ! + END SUBROUTINE SALRRE_0 + ! + SUBROUTINE SALRDB(DATAIN,N,FIN,FOUT,PREC,TEXT) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! reading text comment cards followed by N reals*8 + ! first card before integer data must have a '*' in first column + ! + !Parameters: input + ! N number of real*8 to be read + ! FOUT index of output file (if =0 no printing) + ! PREC = 0 read with 4E20.12, otherwise use 5E12.6 + ! TEXT description of sought input (for debug) + ! + !Parameters: input/output + ! FIN index of input file (FIN < 0 => do not call SALTIT) + ! + !Parameters: output + ! DATAIN real*8 array of dimension >= N + ! + !--------------------------------------------------------------------- + ! + USE PRECISION_AND_KINDS, ONLY : PDB + !**** + INTEGER, INTENT(IN) :: N,FIN,FOUT,PREC + REAL(PDB), INTENT(OUT), DIMENSION(N) :: DATAIN + CHARACTER (LEN=*), INTENT(IN) :: TEXT + !**** + INTEGER :: I + !**** + CALL SALTIT('*',FIN,FOUT,TEXT) + IF(PREC.EQ.0)THEN + READ(FIN,'(4E20.12)')(DATAIN(I),I=1,N) + IF(FOUT.NE.0)WRITE(FOUT,'(1X,1P,4E20.12)')(DATAIN(I),I=1,N) + ELSE + READ(FIN,*)(DATAIN(I),I=1,N) + IF(FOUT.NE.0)WRITE(FOUT,'(1X,1P,5'//FORMATR//')')(DATAIN(I),I=1,N) + ENDIF + ! + END SUBROUTINE SALRDB + ! + SUBROUTINE SALRDB_0(DATAIN,FIN,FOUT,PREC,TEXT) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! reading text comment cards followed by a single real*8 + ! first card before integer data must have a '*' in first column + ! + !Parameters: input + ! FOUT index of output file (if =0 no printing) + ! PREC = 0 read with 4E20.12, otherwise use 5E12.6 + ! TEXT description of sought input (for debug) + ! + !Parameters: input/output + ! FIN index of input file (FIN < 0 => do not call SALTIT) + ! + !Parameters: output + ! DATAIN real*8 value + ! + !--------------------------------------------------------------------- + ! + USE PRECISION_AND_KINDS, ONLY : PDB + !**** + INTEGER, INTENT(IN) :: FIN,FOUT,PREC + REAL(PDB), INTENT(OUT) :: DATAIN + CHARACTER (LEN=*), INTENT(IN) :: TEXT + !**** + !**** + CALL SALTIT('*',FIN,FOUT,TEXT) + IF(PREC.EQ.0)THEN + READ(FIN,'(4E20.12)')DATAIN + IF(FOUT.NE.0)WRITE(FOUT,'(1X,1P,4E20.12)')DATAIN + ELSE + READ(FIN,*)DATAIN + IF(FOUT.NE.0)WRITE(FOUT,'(1X,1P,5'//FORMATR//')')DATAIN + ENDIF + ! + END SUBROUTINE SALRDB_0 + ! + SUBROUTINE SALRCH(DATAIN,N,FIN,FOUT,TEXT) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! reading text comment cards followed by N chains + ! first card before integer datain must have a '*' in first column + ! + !Parameters: input + ! N number of strings to be read (3X,A12) + ! FOUT index of output file (if =0 no printing) + ! TEXT description of sought input (for debug) + ! + !Parameters: input/output + ! FIN index of input file (FIN < 0 => do not call SALTIT) + ! + !Parameters: output + ! DATAIN character array of dimension >= N + ! + !--------------------------------------------------------------------- + ! + INTEGER, INTENT(IN) :: N,FIN,FOUT + CHARACTER (LEN=*), INTENT(OUT), DIMENSION(N) :: DATAIN + CHARACTER (LEN=*), INTENT(IN) :: TEXT + !**** + INTEGER :: I + !**** + CALL SALTIT('*',FIN,FOUT,TEXT) + READ(FIN,'(4(3X,A12))')(DATAIN(I),I=1,N) + IF(FOUT.NE.0)WRITE(FOUT,'(1X,4(3X,A12))')(DATAIN(I),I=1,N) + ! + END SUBROUTINE SALRCH + ! + SUBROUTINE SALRCH_0(DATAIN,FIN,FOUT,TEXT) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! reading a single chain of characters. + ! first card before integer datain must have a '*' in first column + ! + !Parameters: input + ! FOUT index of output file (if =0 no printing) + ! TEXT description of sought input (for debug) + ! + !Parameters: input/output + ! FIN index of input file (FIN < 0 => do not call SALTIT) + ! + !Parameters: output + ! DATAIN character chain + ! + !--------------------------------------------------------------------- + ! + INTEGER, INTENT(IN) :: FIN,FOUT + CHARACTER (LEN=*), INTENT(OUT) :: DATAIN + CHARACTER (LEN=*), INTENT(IN) :: TEXT + !**** + !**** + CALL SALTIT('*',FIN,FOUT,TEXT) + READ(FIN,'(4(3X,A12))')DATAIN + IF(FOUT.NE.0)WRITE(FOUT,'(1X,4(3X,A12))')DATAIN + ! + END SUBROUTINE SALRCH_0 + ! + SUBROUTINE SALTIT(WORD,FIN,FOUT,SEEK) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! reads and prints lines of length 80 char until the line that + ! begins with word or with 'end' + ! + !Parameters: input + ! WORD character string (mask) + ! FIN logical number of input file + ! FOUT logical number of output file (if =0 no printing) + ! SEEK description of sought input (for debug) + ! + !--------------------------------------------------------------------- + ! + !** reads and prints lines of length 80 char until the line that + ! begins with word or with 'end' + !> WORD = character string (mask) + !> FIN = logical number of input file + !> FOUT = logical number of output file (if =0 no printing) + !> SEEK = description of sought input (for debug) + !** + INTEGER, INTENT(IN) :: FOUT,FIN + CHARACTER (LEN=*), INTENT(IN) :: WORD,SEEK + !** + CHARACTER (LEN=80) :: TEXT + INTEGER :: LL + LOGICAL :: LGOUT + !** + LL=LEN(WORD) + DO + READ(FIN,'(A80)')TEXT + IF(TEXT(1:3).EQ.'END')THEN + IF(FOUT.NE.0)WRITE(FOUT,'(1X,''SEEKS => '',A)')SEEK + WRITE(FOUT,'(5X,''READ END AND STOP IN TITLE'')') + CALL XABORT('SALTIT: FAILURE') + ENDIF + IF(TEXT(1:5).EQ.'%SKIP')THEN + DO + READ(FIN,'(A80)')TEXT + IF(FOUT.NE.0)WRITE(FOUT,'(1X,A80)')TEXT + IF(TEXT(1:5).EQ.'%SKIP')EXIT + ENDDO + ELSE + LGOUT=TEXT(1:LL).EQ.WORD + IF(FOUT.NE.0)THEN + IF(LGOUT)WRITE(FOUT,'(1X,''SEEKS => '',A)')SEEK + WRITE(FOUT,'(1X,A80)')TEXT + ENDIF + IF(LGOUT)EXIT + ENDIF + ENDDO + ! + END SUBROUTINE SALTIT +END MODULE SALGET_FUNS_MOD diff --git a/Dragon/src/SALMUS.f90 b/Dragon/src/SALMUS.f90 new file mode 100644 index 0000000..df30a61 --- /dev/null +++ b/Dragon/src/SALMUS.f90 @@ -0,0 +1,282 @@ +!--------------------------------------------------------------------- +! +!Purpose: +! To analyze and track a geometry data structure using the Sanchez +! algorithm for the multicell surfacic approximation. +! +!Copyright: +! Copyright (C) 2025 Ecole Polytechnique de Montreal. +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version +! +!Author(s): +! A. Hebert +! +!Parameters: input +! FGEO unit file number of the surfacic file in read only mode. +! IPTRK pointer to the TRACKING data structure in creation mode. +! IFTRK pointer to the TRACKING file in creation mode. +! RCUTOF minimum distance between two surfacic elements. +! IPRINT print level. +! NBSLIN maximum number of segments in a single tracking line. +! computed by default in SALTCG but limited to 100000 +! elements. This default value can be bypassed using +! keyword NBSLIN. +! +!Parameters: output +! GG geometry basic information. +! +!----------------------------------------------------------------------- +! +SUBROUTINE SALMUS(FGEO ,IPTRK, IFTRK, RCUTOF, IPRINT, NBSLIN, GG) + USE GANLIB + USE PRECISION_AND_KINDS, ONLY : PDB + USE SAL_GEOMETRY_TYPES, ONLY : T_G_BASIC,LMERGM,TYPGEO,NBFOLD,F_GEO + USE SAL_TRACKING_TYPES, ONLY : PRTIND,EPS1 + USE SAL_GEOMETRY_MOD, ONLY : SAL100 + IMPLICIT NONE + !---- + ! Subroutine arguments + !---- + TYPE(C_PTR) IPTRK + INTEGER FGEO,IFTRK,IPRINT,NBSLIN + REAL(PDB) RCUTOF + TYPE(T_G_BASIC) :: GG + !---- + ! Local parameters + !---- + INTEGER IOUT + PARAMETER (IOUT=6) + INTEGER NSTATE + PARAMETER (NSTATE=40) + !---- + ! Local variables + !---- + TYPE(C_PTR) JPTRK,KPTRK + INTEGER ISTATT(NSTATE),I,J,I1,I2,J1,J2,IMACRO,J3,NMIX,IMIX,NREG,OK, & + & NINST,ILONG,ITYLCM + REAL RSTATT(NSTATE) + LOGICAL LGINF + CHARACTER(LEN=131) HSMG + !---- + ! Allocatable arrays + !---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NSURF_MACRO,NBNODE_MACRO,ITAB, & + & NMC_NODE,NMC_SURF,IFR,MIX,ICNT,MERGE_MACRO,SURF_MACRO,PERIM,IDMA,IMAC + REAL, ALLOCATABLE, DIMENSION(:) :: VOLUME,ALB,DVX,SUR,GALBED + REAL(PDB), ALLOCATABLE, DIMENSION(:) :: SURF2 + !---- + ! Read the surfacic file and fill GG object + !---- + PRTIND=IPRINT + F_GEO=FGEO + EPS1=1.E-5_PDB + IF(RCUTOF>0._PDB) THEN + EPS1=RCUTOF + IF(PRTIND>0) WRITE(*,*) "SALMUS: set eps1 to ",EPS1 + ENDIF + CALL SAL100(GG) + !------------ + IF(IPRINT > 0) WRITE(IOUT,'(/" SALMUS: TYPGEO=",I5," NBFOLD=",I5," NMACRO=",I5)') & + & TYPGEO,NBFOLD,GG%NB_MACRO + !---- + ! Perform optional MERGE MIX + !---- + IF(LMERGM) THEN + GG%NUM_MERGE(:)=GG%MED(:) + DO I=1,MAXVAL(GG%NUM_MERGE(:)) + 1000 IF(I.GT.MAXVAL(GG%NUM_MERGE(:))) EXIT + DO J=1,GG%NB_NODE + IF(GG%NUM_MERGE(J).EQ.I) GO TO 2000 + ENDDO + DO J=1,GG%NB_NODE + IF(GG%NUM_MERGE(J).GE.I) GG%NUM_MERGE(J)=GG%NUM_MERGE(J)-1 + ENDDO + GO TO 1000 + 2000 CONTINUE + ENDDO + ENDIF + !---- + ! store the STATE VECTOR for the global geometry + !---- + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATT) + CALL LCMGET(IPTRK,'EXCELTRACKOP',RSTATT) + NREG=MAXVAL(GG%NUM_MERGE) + ISTATT(1) = NREG ! number of regions + ISTATT(2) = NREG ! number of flux unknowns + ISTATT(7) = 5 ! set the multicell surfacic approximation + LGINF = .TRUE. + DO I=1,GG%NBBCDA + LGINF = LGINF .AND. (GG%BCDATAREAD(I)%BCDATA(6) == 1._PDB) + ENDDO + ISTATT(3)=1 + IF(.NOT.LGINF) ISTATT(3)=0 ! reset the leakage flag + ISTATT(4) = MAXVAL(GG%MED(1:GG%NB_NODE)) ! maximum number of mixture + CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,ISTATT) + ! + ! fill-in medium number per region + ALLOCATE(ITAB(NREG),VOLUME(NREG), STAT =OK) + IF(OK /= 0) CALL XABORT('SALMUS: failure to allocate integer ITAB') + ! fill in MATCOD + DO J=1,GG%NB_NODE + ITAB(GG%NUM_MERGE(J)) = GG%MED(J) + ENDDO + CALL LCMPUT(IPTRK,'MATCOD',NREG,1,ITAB(1:NREG) ) + ! fill-in KEYFLX per region + ITAB(:NREG) = (/ (I,I=1,NREG) /) + CALL LCMPUT(IPTRK,'MERGE',NREG,1,ITAB) + CALL LCMPUT(IPTRK,'KEYFLX',NREG,1,ITAB) + ! fill-in volumes per region + VOLUME(:NREG) =0. + DO I=1,GG%NB_NODE + VOLUME(GG%NUM_MERGE(I)) = VOLUME(GG%NUM_MERGE(I)) + REAL(GG%VOL_NODE(I)) + ENDDO + CALL LCMPUT(IPTRK,'VOLUME',NREG,2,VOLUME) + IF(IPRINT .GT. 5) THEN + I1=1 + DO I=1,(NREG-1)/8+1 + I2=I1+7 + IF(I2.GT.NREG) I2=NREG + WRITE (IOUT,20) (J,J=I1,I2) + DO J=1,GG%NB_NODE + ITAB(GG%NUM_MERGE(J)) = GG%MED(J) + ENDDO + WRITE (IOUT,30) (ITAB(J),J=I1,I2) + WRITE (IOUT,40) (VOLUME(J),J=I1,I2) + I1=I1+8 + ENDDO + ENDIF + DEALLOCATE(VOLUME,ITAB) + !---- + ! Extract the surfacic elements belonging to each macro geometry and + ! perform tracking + !---- + ALLOCATE(NSURF_MACRO(GG%NB_MACRO),NBNODE_MACRO(GG%NB_MACRO)) + ALLOCATE(NMC_NODE(GG%NB_MACRO+1),NMC_SURF(GG%NB_MACRO+1)) + NSURF_MACRO(:GG%NB_MACRO) = 0 + NBNODE_MACRO(:GG%NB_MACRO) = 0 + JPTRK=LCMLID(IPTRK,'MACRO-TRACK',GG%NB_MACRO) + NMC_NODE(1)=0 + NMC_SURF(1)=0 + DO IMACRO=1,GG%NB_MACRO + KPTRK=LCMDIL(JPTRK,IMACRO) + CALL LCMPUT(KPTRK,'STATE-VECTOR',NSTATE,1,ISTATT) + CALL LCMPUT(KPTRK,'EXCELTRACKOP',NSTATE,2,RSTATT) + CALL MUSACG(KPTRK,IFTRK,IPRINT,IMACRO,NBSLIN,RCUTOF,GG,LGINF, & + & NBNODE_MACRO(IMACRO),NSURF_MACRO(IMACRO)) + NMC_NODE(IMACRO+1)=NMC_NODE(IMACRO)+NBNODE_MACRO(IMACRO) + NMC_SURF(IMACRO+1)=NMC_SURF(IMACRO)+NSURF_MACRO(IMACRO) + ENDDO + CALL LCMPUT(IPTRK,'NMC_NODE',GG%NB_MACRO+1,1,NMC_NODE) + CALL LCMPUT(IPTRK,'NMC_SURF',GG%NB_MACRO+1,1,NMC_SURF) + !---- + ! Create connectivity data + !---- + NMIX=NMC_SURF(GG%NB_MACRO+1) + ALLOCATE(IFR(NMIX),ALB(NMIX),MIX(NMIX),DVX(NMIX),SUR(NMIX),ICNT(NMIX),IDMA(NMIX)) + ALLOCATE(IMAC(NREG)) + J1=0 + NMIX=0 + IMIX=0 + DO IMACRO=1,GG%NB_MACRO + KPTRK=LCMDIL(JPTRK,IMACRO) + J2=NBNODE_MACRO(IMACRO) + J3=NSURF_MACRO(IMACRO) + ALLOCATE(MERGE_MACRO(J2),SURF_MACRO(J3),SURF2(J3)) + CALL LCMSIX(KPTRK,'SURFACIC_TMP',1) + CALL LCMGET(KPTRK,'MERGE_MACRO',MERGE_MACRO) + CALL LCMGET(KPTRK,'SURF_MACRO',SURF_MACRO) + CALL LCMSIX(KPTRK,' ',2) + CALL LCMSIX(KPTRK,'GEOMETRY',1) + CALL LCMLEN(KPTRK,'SURF2',ILONG,ITYLCM) + IF(ILONG.NE.J3) CALL XABORT('SALMUS: wrong number of surfaces') + CALL LCMGET(KPTRK,'SURF2',SURF2) + CALL LCMSIX(KPTRK,' ',2) + IF(J1+J2.GT.NREG) CALL XABORT('SALMUS: NREG overflow') + IMAC(J1+1:J1+J2)=MERGE_MACRO(:J2) + ICNT(NMIX+1:NMIX+J3)=SURF_MACRO(:J3) + DEALLOCATE(SURF_MACRO,MERGE_MACRO) + CALL LCMLEN(KPTRK,'ALBEDO',ILONG,ITYLCM) + ALLOCATE(GALBED(ILONG),PERIM(J3)) + CALL LCMGET(KPTRK,'ALBEDO',GALBED) + CALL LCMGET(KPTRK,'PERIM_SURF',PERIM) + DO I=1,J3 + IF(PERIM(I).GT.ILONG) THEN + WRITE(HSMG,'(51H SALMUS: inconsistent albedo info in macro geometry,I5)') IMACRO + CALL XABORT(HSMG) + ENDIF + ALB(NMIX+I)=GALBED(PERIM(I)) + SUR(NMIX+I)=REAL(SURF2(I)) + ENDDO + DEALLOCATE(PERIM,GALBED,SURF2) + OUT1: DO I=NMIX+1,NMIX+J3 + DO J=NMIX+1,I-1 + IF(ICNT(I).EQ.ICNT(J)) THEN + MIX(I)=MIX(J) + CYCLE OUT1 + ENDIF + ENDDO + IMIX=IMIX+1 + MIX(I)=IMIX + ENDDO OUT1 + DO I=NMIX+1,NMIX+J3 + NINST=COUNT(MIX(NMIX+1:NMIX+J3) == MIX(I)) + DVX(I)=1.0/REAL(NINST) + IDMA(I)=IMACRO + ENDDO + J1=J1+J2 + NMIX=NMIX+J3 + ENDDO + CALL LCMPUT(IPTRK,'MERGE_MACRO',NREG,1,IMAC) + DEALLOCATE(IMAC) + OUT2: DO I=1,NMIX + DO J=1,NMIX + IF(IDMA(J).EQ.IDMA(I)) CYCLE + IF(ICNT(J).EQ.ICNT(I)) THEN + IFR(I)=MIX(J) + CYCLE OUT2 + ENDIF + ENDDO + IFR(I)=MIX(I) + ENDDO OUT2 + DEALLOCATE(IDMA) + ISTATT(24)=GG%NB_MACRO + ISTATT(28)=MAXVAL(IFR) ! number of current unknowns + ISTATT(29)=NMIX ! number of perimeter elements + CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,ISTATT) + CALL LCMPUT(IPTRK,'IFR',NMIX,1,IFR) + CALL LCMPUT(IPTRK,'ALB',NMIX,2,ALB) + CALL LCMPUT(IPTRK,'MIX',NMIX,1,MIX) + CALL LCMPUT(IPTRK,'DVX',NMIX,2,DVX) + CALL LCMPUT(IPTRK,'SUR',NMIX,2,SUR) + IF(IPRINT .GT. 1) THEN + NMIX=0 + DO IMACRO=1,GG%NB_MACRO + J3=NSURF_MACRO(IMACRO) + WRITE (IOUT,50) IMACRO,(ICNT(I),I=NMIX+1,NMIX+J3) + WRITE (IOUT,60) (MIX(I),IFR(I),I=NMIX+1,NMIX+J3) + WRITE (IOUT,70) (ALB(I),I=NMIX+1,NMIX+J3) + WRITE (IOUT,80) (DVX(I),I=NMIX+1,NMIX+J3) + WRITE (IOUT,90) (SUR(I),I=NMIX+1,NMIX+J3) + WRITE (IOUT,100) ('----------------',I=1,MIN(8,J3)) + NMIX=NMIX+J3 + ENDDO + ENDIF + DEALLOCATE(ICNT,SUR,DVX,MIX,ALB,IFR) + DEALLOCATE(NMC_SURF,NMC_NODE) + DEALLOCATE(NBNODE_MACRO,NSURF_MACRO) + !---- + ! Formats + !---- + 20 FORMAT (/9H REGION:,8(I8,6X,1HI)) + 30 FORMAT (9H MIXTURE:,8(I8,6X,1HI)) + 40 FORMAT (9H VOLUME:,1P,8(E13.6,2H I)) + 50 FORMAT (6H MACRO,I6.6/9H ELEMENT:,8(3H S,I6.6,6X,1HI,:)/(9X,8(3H S,I6.6,6X,1HI,:))) + 60 FORMAT (9H IN/OUT:,8(I6,2H /,I5,3H I,:)/(9X,8(I6,2H /,I5,3H I,:))) + 70 FORMAT (9H ALBEDO:,1P,8(E13.5,3H I,:)/(9X,8(E13.5,3H I,:))) + 80 FORMAT (9H DVX:,1P,8(E13.5,3H I,:)/(9X,8(E13.5,3H I,:))) + 90 FORMAT (9H SUR:,1P,8(E13.5,3H I,:)/(9X,8(E13.5,3H I,:))) + 100 FORMAT (9H --------,8(A16)) +END SUBROUTINE SALMUS diff --git a/Dragon/src/SALT.f90 b/Dragon/src/SALT.f90 new file mode 100644 index 0000000..f046d2c --- /dev/null +++ b/Dragon/src/SALT.f90 @@ -0,0 +1,292 @@ +SUBROUTINE SALT(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +! +!----------------------------------------------------------------------- +! +!Purpose: +! To analyze and track a geometry data structure using the Sanchez +! algorithm for a PIJ, MOC or multicell surfacic solution of the flux. +!Copyright: +! Copyright (C) 2014 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version +! +!Author(s): +! A. Hebert +! +!Parameters: input +! NENTRY number of data structures transfered to this module. +! HENTRY name of the data structures. +! IENTRY data structure type where: +! IENTRY=1 for LCM memory object; +! IENTRY=2 for XSM file; +! IENTRY=3 for sequential binary file; +! IENTRY=4 for sequential ASCII file. +! JENTRY access permission for the data structure where: +! =0 for a data structure in creation mode; +! =1 for a data structure in modifications mode; +! =2 for a data structure in read-only mode. +! KENTRY data structure pointer. +! +!Comments: +! Instructions for the use of the SALT: module: +! TRKFIL VOLTRK := SALT: SURFIL [ GEOMETRY ] :: (saltget) ; +! where +! TRKFIL : sequential binary tracking file to be created +! VOLTRK : tracking data structure (signature L_TRACK) +! SURFIL : sequential ascii file used to store the surfacic +! elements of the geometry. +! GEOMETRY : optional geometry data structure used if BIHET is set +! (signature L_GEOM) +! (saltget): Processing options +! (read from input using the NXTGET routine). +! +!----------------------------------------------------------------------- +! + USE GANLIB + USE SAL_GEOMETRY_TYPES, ONLY : T_G_BASIC,LMERGM,IC,ISPEC,NANIS + USE SALGET_FUNS_MOD + IMPLICIT NONE + !---- + ! Subroutine arguments + !---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 + !---- + ! Local parameters + !---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='SALT ') + INTEGER ILCMUP,ILCMDN + PARAMETER (ILCMUP=1,ILCMDN=2) + INTEGER NSTATE,MAXENT + PARAMETER (NSTATE=40,MAXENT=2) + INTEGER N_DATAIN + PARAMETER (N_DATAIN=25) + INTEGER IUTYPE + PARAMETER (IUTYPE=2) + !---- + ! Local variables + !---- + TYPE(C_PTR) IPGEO,IPTRK + INTEGER IMGEO,IFTRK,FGEO,NMACRO + INTEGER IGTRK + INTEGER IEN,ITC + INTEGER IQUA10,IBIHET + CHARACTER HSIGN*12 + INTEGER ISTATT(NSTATE),DATAIN(N_DATAIN) + REAL RSTATT(NSTATE) + CHARACTER TITLE*72 + INTEGER IPRINT + INTEGER NBSLIN + INTEGER ILONG,ITYLCM + DOUBLE PRECISION RCUTOF + INTEGER OK + !---- + ! Allocatable types + !---- + TYPE(T_G_BASIC), ALLOCATABLE :: GG + !---- + ! Validate entry parameters + !---- + IF((NENTRY.LT.3).OR.(NENTRY.GT.4)) CALL XABORT(NAMSBR// & + & ': Three or four data structures permitted') + IPGEO=C_NULL_PTR + FGEO=0 + IMGEO=0 + NBSLIN=100000 + !---- + ! Scan data structure to determine type and mode + !---- + DO IEN=1,2 + IF(JENTRY(IEN).NE.0) CALL XABORT(NAMSBR// & + & ': Object in creation mode expected') + IF((IENTRY(IEN).EQ.1).OR.(IENTRY(IEN).EQ.2)) THEN + IPTRK=KENTRY(IEN) + HSIGN='L_TRACK ' + CALL LCMPTC(IPTRK,'SIGNATURE',12,HSIGN) + HSIGN='EXCELL' + CALL LCMPTC(IPTRK,'TRACK-TYPE',12,HSIGN) + ELSE IF(IENTRY(IEN).EQ.3) THEN + IFTRK=FILUNIT(KENTRY(IEN)) + ENDIF + ENDDO + DO IEN=3,NENTRY + IF(JENTRY(IEN).NE.2) CALL XABORT(NAMSBR// & + & ': Object in read-only mode expected') + IF((IENTRY(IEN).EQ.1).OR.(IENTRY(IEN).EQ.2)) THEN + CALL LCMGTC(KENTRY(IEN),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_GEOM') CALL XABORT(NAMSBR// & + & ': L_GEOM signature expected for '//HENTRY(IEN)) + IPGEO=KENTRY(IEN) + IMGEO=-1 + ELSE IF(IENTRY(IEN).EQ.4) THEN + FGEO=FILUNIT(KENTRY(IEN)) + ENDIF + ENDDO + IF(FGEO.EQ.0) CALL XABORT(NAMSBR// & + & ': The surfacic file is not defined') + !---- + ! Initialize tracking parameters to 0 + !---- + ISTATT(:NSTATE)=0 + RSTATT(:NSTATE)=0.0 + !---- + ! Define default tracking options that are different from 0 + !---- + ISTATT(6)=1 + ISTATT(7)=4 + ISTATT(11)=1 + ISTATT(12)=-1 + ISTATT(13)=1 + ISTATT(15)=1 + ISTATT(16)=2 + ISTATT(22)=0 + ISTATT(23)=1 + IF(IMGEO .EQ. -1) THEN + CALL LCMLEN(IPGEO,'BIHET',ILONG,ITYLCM) + IF(ILONG.NE.0) ISTATT(40)=1 + ENDIF + !---- + ! Recover processing method + !---- + CALL SALGET(DATAIN,6,FGEO,IOUT,'dimensions for geometry') + NMACRO=DATAIN(5) + REWIND(FGEO) + RSTATT(11)=1.0 + TITLE=' ' + IF(NMACRO.LE.1) THEN + ISTATT(7)=4 + ELSE + ISTATT(7)=5 + ENDIF + CALL NXTGET(NSTATE,IPRINT,TITLE ,ISTATT,RSTATT,NBSLIN,IQUA10,IBIHET) + IF((ISTATT(9).EQ.1).AND.(ISTATT(15).EQ.1)) THEN + ISTATT(15)=8 ! replace EQW by EQW2 + ENDIF + LMERGM=(ISTATT(26)==1) + IF(IPRINT.GT.0) WRITE(IOUT,90) TITLE + !---- + ! Save updated STATE-VECTOR, TITLE and EXCELL track options + ! on tracking data structure + !---- + CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,ISTATT) + CALL LCMPUT(IPTRK,'EXCELTRACKOP',NSTATE,2,RSTATT) + CALL LCMPTC(IPTRK,'TITLE',72,TITLE) + !---- + ! Analyse geometry if required + !---- + ALLOCATE(GG, STAT= OK) + IF(OK /= 0) CALL XABORT('SALT: failure to allocate GG') + RCUTOF=DBLE(RSTATT(3)) + !---- + ! Recover options from state vector + !---- + NANIS=ISTATT(6) + IC=ISTATT(7) + ISPEC=ISTATT(9) + IF(IPRINT>0) THEN + IF(ISPEC==0) THEN + WRITE(IOUT,*) 'SALT: isotropic boundary conditions' + ELSE IF(ISPEC==1) THEN + WRITE(IOUT,*) 'SALT: specular boundary conditions' + ENDIF + ENDIF + !---- + ! Perform tracking + !---- + IF(ISTATT(7).EQ.4) THEN + !---- + ! Track geometry for a PIJ or MOC solution + !---- + IF(IPRINT>0) WRITE(IOUT,*) 'SALT: PIJ or MOC tracking' + CALL SALACG(FGEO ,IPTRK, RCUTOF, IPRINT, GG) + IF(ISTATT(9) .GE. 0 .AND. ISTATT(23) .EQ. 1) THEN + IGTRK=1 + CALL SALTCG(IPTRK, IFTRK, IPRINT, IGTRK, NBSLIN, GG) + ENDIF + ELSE IF(ISTATT(7).EQ.5) THEN + !---- + ! Track geometry for a multicell surfacic solution + !---- + IF(IPRINT>0) WRITE(IOUT,*) 'SALT: multicell surfacic tracking' + IF(ISPEC.EQ.1) CALL XABORT('SALT: TSPC is forbidden with multicell surfacic tracking.') + CALL SALMUS(FGEO ,IPTRK, IFTRK, RCUTOF, IPRINT, NBSLIN, GG) + ELSE + CALL XABORT('SALT: INVALID PROCESSING METHOD.') + ENDIF + !---- + ! Release allocated memory in SALT module + !---- + CALL SALEND(GG) + DEALLOCATE(GG, STAT= OK) + IF(OK /= 0) CALL XABORT('SALT: failure to deallocate GG') + !---- + ! Process double heterogeneity (BIHET) data (if available) + !---- + IF(ISTATT(40) .NE. 0) THEN + CALL XDRTBH(IPGEO,IPTRK,IQUA10,IBIHET,IPRINT,RSTATT(39)) + ENDIF + !---- + ! Processing finished, return + !---- + IF(IPRINT .GT. 1) THEN + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATT) + WRITE(IOUT,100) (ISTATT(ITC),ITC=1,10) + WRITE(IOUT,120) (ISTATT(ITC),ITC=11,22) + WRITE(IOUT,130) ISTATT(23:24),ISTATT(26:29),ISTATT(40) + IF(ISTATT(7).EQ.5) WRITE(IOUT,140) RSTATT(12) + ENDIF + RETURN + !---- + ! Formats + !---- + 90 FORMAT(/1H1,31H SSSSS AA LL TTTTTTTT ,95(1H*)/ & + & 32H SSSSSSS AAAA LL TTTTTTTT ,58(1H*), & + & 37H MULTIGROUP VERSION. X. WARIN (2001)/ & + & 28H SS SS AAAA LL TT/ & + & 28H SS AA AA LL TT/ & + & 28H SS AAAAAA LL TT/ & + & 28H SS SS AAAAAA LL TT/ & + & 28H SSSSSSS AA AA LLLLLLL TT/ & + & 28H SSSSS AA AA LLLLLLL TT//1X,A72/) + 100 FORMAT(/14H STATE VECTOR:/ & + & 7H NREG ,I9,22H (NUMBER OF REGIONS)/ & + & 7H KPN ,I9,23H (NUMBER OF UNKNOWNS)/ & + & 7H ILK ,I9,39H (0=LEAKAGE PRESENT/1=LEAKAGE ABSENT)/ & + & 7H NBMIX ,I9,36H (MAXIMUM NUMBER OF MIXTURES USED)/ & + & 7H NSURF ,I9,29H (NUMBER OF OUTER SURFACES)/ & + & 7H NANI ,I9,48H (1=P0 CROSS SECTIONS/2=P1 CROSS SECTIONS/...)/ & + & 7H METHOD,I9,38H (4=PIJ OR MOC/5=MULTICELL SURFACIC)/ & + & 7H NORM ,I9,48H (NORMALIZATION OPTION 1=ABSENT/0=GLOBAL/-1=NO, & + & 21HRMALIZATION BY ANGLE)/ & + & 7H TRKT ,I9,36H (TRACKING TYPE 0=FINITE/1=CYCLIC)/ & + & 7H BOUND ,I9,52H (BOUNDARY CONDITIONS TYPE 0=ISOTROPIC/1=SPECULAR)) + 120 FORMAT( & + & 7H NANG ,I9,30H (NUMBER OF TRACKING ANGLES)/ & + & 7H ASYM ,I9,28H (ANGULAR SYMMETRY FACTOR)/ & + & 7H POLQUA,I9,32H (POLAR ANGLE QUADRATURE TYPE)/ & + & 7H POLOAQ,I9,33H (POLAR ANGLE QUADRATURE ORDER)/ & + & 7H AZMQUA,I9,47H (AZIMUTHAL OR SOLID ANGULAR QUADRATURE TYPE)/ & + & 7H NDIM ,I9,25H (NUMBER OF DIMENSIONS)/ & + & 7H NPOINT,I9,40H (NUMBER OF TRACKING POINTS ON A LINE)/ & + & 7H MAXSGL,I9,30H (MAXIMUM LENGTH OF A TRACK)/ & + & 7H NTLINE,I9,37H (TOTAL NUMBER OF TRACKS GENERATED)/ & + & 7H NBTDIR,I9,47H (TOTAL NUMBER OF TRACK DIRECTIONS PROCESSED)/ & + & 7H NANGL ,I9,47H (NUMBER OF TRACK DIRECTION ANGLES CONSIDERED, & + & 20H IN THE INTEGRATION)/ & + & 7H INSB ,I9,25H (VECTORIZATION OPTION)) + 130 FORMAT( & + & 7H ITRACK,I9,47H (-1=MONTE-CARLO/0=DESACTIVATES TRACKING FILE, & + & 39H BUILD/1=ACTIVATES TRACKING FILE BUILD)/ & + & 7H NMACRO,I9,31H (NUMBER OF MACRO GEOMETRIES)/ & + & 7H MERGMX,I9,32H (0/1=MERGMIX ACTIVATION FLAG)/ & + & 7H NBATCH,I9,41H (NUMBER OF TRACKS IN EACH OPENMP CORE)/ & + & 7H IJAT ,I9,54H (NUMBER OF ADDITIONAL INTERFACE CURRENT COMPONENTS)/ & + & 7H NMIX ,I9,53H (NUMBER OF PERIMETER ELEMENTS IN MACRO GEOMETRIES)/ & + & 7H IBIHET,I9,46H (0/1=DOUBLE HETEROGENEITY IS NOT/IS ACTIVE)) + 140 FORMAT(5H EPSJ,1P,E11.2,3X,32H(FLUX-CURRENT ITERATION EPSILON)) +END SUBROUTINE SALT diff --git a/Dragon/src/SALTCG.f b/Dragon/src/SALTCG.f new file mode 100644 index 0000000..123a288 --- /dev/null +++ b/Dragon/src/SALTCG.f @@ -0,0 +1,606 @@ +*DECK SALTCG + SUBROUTINE SALTCG(IPTRK ,IFTRK ,IPRINT,IGTRK ,NBSLIN, GG) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To track an assembly of cells containing clusters using the new SALT +* tracking procedure (based on NXTTCG.f). +* +*Copyright: +* Copyright (C) 2014 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* A. Hebert and G. Marleau +* +*Parameters: input +* IPTRK pointer to the TRACKING data structure in +* update or creation mode. +* IFTRK pointer to the TRACKING file in creation mode. +* IPRINT print level. +* IGTRK flag to generate the tracking file. In the case where +* IGTRK=1, the tracking is performed and +* used to evaluate the track normalisation factor and the +* tracking file is generated. When IGTRK=0, the tracking is +* still performed and used to evaluate the track normalisation +* factor but the tracking file is not generated. +* NBSLIN maximum number of segments in a single tracking line. +* computed by default in SALTCG but limited to 100000 +* elements. This default value can be bypassed using +* keyword NBSLIN. +* GG geometry basic information. +* +*---------- +* + USE GANLIB + USE SAL_GEOMETRY_TYPES, ONLY : T_G_BASIC,ISPEC + USE SAL_TRACKING_TYPES, ONLY : NMAX2,ITRAC2,RTRAC2,IPART,RPART, + > NIPART,NRPART + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPTRK + INTEGER IFTRK + INTEGER IPRINT,IGTRK + INTEGER NBSLIN + TYPE(T_G_BASIC) GG +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='SALTCG') + INTEGER NSTATE + PARAMETER (NSTATE=40) + INTEGER NMAX0 + DOUBLE PRECISION PI,DZERO,DONE,DTWO,DSUM + PARAMETER (PI=3.14159265358979, DZERO=0.0D0,DONE=1.0D0, + > DTWO=2.0D0,NMAX0=100000) +*---- +* Functions +*---- + INTEGER KDROPN,IFTEMP,KDRCLS,ICLS +*---- +* Local variables +*---- + INTEGER ISTATE(NSTATE),IEDIMG(NSTATE),ICODE(6) + REAL RSTATT(NSTATE),ALBEDO(6) + INTEGER RENO,LTRK,AZMOAQ,ISYMM,POLQUA,POLOAQ,AZMQUA, + > AZMNBA,OK + DOUBLE PRECISION DENUSR,RCUTOF,DENLIN,SPACLN,WEIGHT + DOUBLE PRECISION RADIUS,CENTER(3) + INTEGER NDIM,ITYPBC,IDIRG,NBOCEL,NBUCEL,IDIAG, + > ISAXIS(3),NOCELL(3),NUCELL(3),MXMSH,MAXMSH, + > MAXREG,NBTCLS,MAXMSP,MAXRSP,NFSUR,NFREG, + > MXGSUR,NUNK,NPLANE,NPOINT,NTLINE,NBTDIR, + > MAXSUB,MAXSGL,NBDR,ILONG,ITYLCM,IPER(3) + INTEGER JJ,KK,NCOR,NQUAD,NANGL,NBANGL,LINMAX + DOUBLE PRECISION DQUAD(4),ABSC(3,2),RCIRC,SIDEH,ANGLE + CHARACTER CTRK*4,COMENT*80 + INTEGER IFMT,NEREG,NESUR +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KEYMRG,MATALB + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NBSANG + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SURVOL,DGMESH, + > DNSANG,DDANG,DVNOR,DSNOR + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: DDENWT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: DANGLT +*---- +* Processing starts: +* print routine opening header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 1) WRITE(IOUT,6000) NAMSBR +*---- +* Open temporary tracking file if required +*---- + IF(IGTRK .EQ. 1) THEN + IFTEMP= KDROPN('DUMMYSQ',0,2,0) + IF(IFTEMP .LE. 0) WRITE(IOUT,9010) NAMSBR + ENDIF +*---- +* Get state vectors +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + CALL LCMGET(IPTRK,'EXCELTRACKOP',RSTATT) + NEREG=ISTATE(1) + NESUR=ISTATE(5) + NUNK=NEREG+NESUR+1 + RENO =ISTATE(8) + LTRK =ISTATE(9) + AZMOAQ=ISTATE(11) + ISYMM =ISTATE(12) + POLQUA=ISTATE(13) + POLOAQ=ISTATE(14) + AZMQUA=ISTATE(15) + AZMNBA=ISTATE(16) + IFMT=ISTATE(21) + DENUSR=DBLE(RSTATT(2)) + RCUTOF=DBLE(RSTATT(3)) + DENLIN=DBLE(RSTATT(4)) + SPACLN=DBLE(RSTATT(5)) + WEIGHT=RSTATT(6) +*---- +* Get main tracking records +*---- + CALL LCMLEN(IPTRK,'ICODE ',ILONG,ITYLCM) + IF(ILONG.GT.6) CALL XABORT('SALTCG: ALBEDO OVERFLOW.') + CALL LCMGET(IPTRK,'ICODE ',ICODE ) + CALL LCMGET(IPTRK,'ALBEDO ',ALBEDO) + CALL LCMSIX(IPTRK,'NXTRecords ',1) +*---- +* Get general dimensioning vector for geometry tracking +*---- + IEDIMG(:NSTATE)=0 + CALL LCMGET(IPTRK,'G00000001DIM',IEDIMG) + NDIM =IEDIMG( 1) + ITYPBC =IEDIMG( 2) + IDIRG =IEDIMG( 3) + NBOCEL =IEDIMG( 4) + NBUCEL =IEDIMG( 5) + IDIAG =IEDIMG( 6) + ISAXIS(1)=IEDIMG( 7) + ISAXIS(2)=IEDIMG( 8) + ISAXIS(3)=IEDIMG( 9) + NOCELL(1)=IEDIMG(10) + NOCELL(2)=IEDIMG(11) + NOCELL(3)=IEDIMG(12) + NUCELL(1)=IEDIMG(13) + NUCELL(2)=IEDIMG(14) + NUCELL(3)=IEDIMG(15) + MXMSH =IEDIMG(16) + MAXREG =IEDIMG(17) + NBTCLS =IEDIMG(18) + MAXMSP =IEDIMG(20) + MAXRSP =IEDIMG(21) + NFSUR =IEDIMG(22) + NFREG =IEDIMG(23) + MXGSUR =IEDIMG(24) + MAXMSH=MAX(1,MXMSH,MAXMSP,MAXREG) + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6011) NFREG,NEREG,NFSUR,NESUR + ENDIF + IF((ITYPBC .EQ. 0).OR.(ITYPBC .EQ. 2)) THEN +*---- +* Define Cell for periodicity +* Cartesian Boundary +*---- + IPER(1)=2 + IF(ABS(ISAXIS(1)) .EQ. 3) IPER(1)=1 + IPER(2)=2 + IF(ABS(ISAXIS(2)) .EQ. 3) IPER(2)=1 + IPER(3)=2 + IF(ABS(ISAXIS(3)) .EQ. 3) IPER(3)=1 +*---- +* Use intrinsic geometry symmetries +* to simplify tracking unless +* NOSY tracking option activated +*---- + IF(ISYMM .NE. 0) THEN + ISYMM=0 + IF(ABS(ISAXIS(1)) .EQ. 1 .OR. ABS(ISAXIS(1)) .EQ. 2) THEN +*---- +* X SYMMETRY +*---- + ISYMM=2 + ENDIF + IF(ABS(ISAXIS(2)) .EQ. 1 .OR. ABS(ISAXIS(2)) .EQ. 2) THEN +*---- +* Y SYMMETRY +*---- + ISYMM=4+2*ISYMM + ENDIF + IF(NDIM .EQ. 3) THEN + IF(ABS(ISAXIS(3)) .EQ. 1 .OR. ABS(ISAXIS(3)) .EQ. 2) THEN +*---- +* Z SYMMETRY +*---- + ISYMM=16+ISYMM + ENDIF + ENDIF + IF(ISYMM .EQ. 0) ISYMM=1 + ENDIF + ENDIF +*---- +* Read global mesh for geometry +*---- + ALLOCATE(DGMESH((MAXMSH+2)*4)) + IF(ITYPBC.EQ.0) THEN + CALL NXTXYZ(IPTRK ,IPRINT,NDIM ,ITYPBC,MAXMSH,NUCELL, + > ABSC,DGMESH) + ELSE IF(ITYPBC.GE.2) THEN + ! hexagonal geometry + CALL LCMGET(IPTRK,'G00000001SMX',DGMESH) + SIDEH=DGMESH(2)-DGMESH(1) + ABSC(:2,1)=SIDEH*SQRT(3.0) + ABSC(:2,2)=ABSC(:2,1) + ELSE + CALL XABORT(NAMSBR//': geometry not implemented') + ENDIF +*---- +* Verify tracking parameters and compute number of angles +* associated with angular order and spatial quadrature parameters +* 1. Isotropic tracking +*---- + NCOR= 1 + NPLANE=1 + IF(LTRK .EQ. 0) THEN + IF(NDIM .EQ. 3) THEN + CALL XABORT(NAMSBR//': 3-D geometry is not allowed') + ENDIF + NQUAD=2 + DQUAD(1)=DONE + DQUAD(2)=DONE + NANGL=AZMOAQ + NBANGL=NANGL + IF(ISYMM .EQ. 2 .OR. ISYMM .EQ. 8) THEN + DQUAD(1)=DONE/DTWO + DQUAD(2)=DZERO + ENDIF + ALLOCATE(DANGLT(NDIM,NBANGL,NQUAD),DDENWT(NBANGL,NQUAD)) + CALL NXTQAS(IPRINT,NDIM ,AZMQUA,NANGL ,NQUAD ,NBANGL, + > DQUAD ,DANGLT,DDENWT) + LINMAX=NBUCEL*(4+MXGSUR+16) +*---- +* Select standard spatial tracking parameters +*---- + CALL NXTQSS(IPRINT,NDIM ,ITYPBC,MAXMSH,NUCELL,DENUSR, + > DGMESH,NPLANE,NPOINT,DENLIN,SPACLN,WEIGHT, + > RADIUS,CENTER) + CALL LCMPUT(IPTRK,'TrackingDirc',NDIM*NBANGL*NQUAD,4,DANGLT) + ELSE +*---- +* 2. Specular tracking +*---- + NPOINT=0 + NQUAD=2 + IF(NDIM .EQ. 3) CALL XABORT(NAMSBR// + > ': TSPC option not valid for 3-D geometries') + IF(ITYPBC .EQ. 0) THEN + ! Cartesian geometries + IF(AZMOAQ .GT. 24) THEN + WRITE(IOUT,9002) NAMSBR,AZMOAQ,24,30 + AZMOAQ=30 + ELSE IF(AZMOAQ .GT. 20) THEN + IF(AZMOAQ .NE. 24) THEN + WRITE(IOUT,9003) NAMSBR,AZMOAQ,20,24,24 + AZMOAQ=24 + ENDIF + ELSE IF(AZMOAQ .GT. 18) THEN + IF(AZMOAQ .NE. 20) THEN + WRITE(IOUT,9003) NAMSBR,AZMOAQ,18,20,20 + AZMOAQ=20 + ENDIF + ELSE IF(AZMOAQ .GT. 14) THEN + IF(AZMOAQ .NE. 18) THEN + WRITE(IOUT,9003) NAMSBR,AZMOAQ,14,18,18 + AZMOAQ=18 + ENDIF + ELSE IF(AZMOAQ .GT. 12) THEN + IF(AZMOAQ .NE. 14) THEN + WRITE(IOUT,9003) NAMSBR,AZMOAQ,12,14,14 + AZMOAQ=14 + ENDIF + ELSE IF(AZMOAQ .GT. 8) THEN + IF(AZMOAQ .NE. 12) THEN + WRITE(IOUT,9003) NAMSBR,AZMOAQ,8,12,12 + AZMOAQ=12 + ENDIF + ELSE IF(AZMOAQ .GT. 6) THEN + IF(AZMOAQ .NE. 8) THEN + WRITE(IOUT,9003) NAMSBR,AZMOAQ,6,8,8 + AZMOAQ=8 + ENDIF + ELSE IF(AZMOAQ .GT. 2) THEN + IF(AZMOAQ .NE. 6) THEN + WRITE(IOUT,9003) NAMSBR,AZMOAQ,2,6,6 + AZMOAQ=6 + ENDIF + ELSE IF(AZMOAQ .GE. 0) THEN + IF(AZMOAQ .NE. 2) THEN + WRITE(IOUT,9003) NAMSBR,AZMOAQ,-1,2,2 + AZMOAQ=2 + ENDIF + ENDIF + ELSE IF(ITYPBC .GE.2) THEN + ! hexagonal geometries + IF(AZMOAQ .GT. 12) THEN + WRITE(IOUT,9002) NAMSBR,AZMOAQ,12,18 + AZMOAQ=18 + ELSE IF(AZMOAQ .GT. 6) THEN + IF(AZMOAQ .NE. 12) THEN + WRITE(IOUT,9003) NAMSBR,AZMOAQ,6,12,12 + AZMOAQ=12 + ENDIF + ELSE IF(AZMOAQ .GT. 3) THEN + IF(AZMOAQ .NE. 6) THEN + WRITE(IOUT,9003) NAMSBR,AZMOAQ,3,6,6 + AZMOAQ=6 + ENDIF + ELSE IF(AZMOAQ .GT. 1) THEN + IF(AZMOAQ .NE. 3) THEN + WRITE(IOUT,9003) NAMSBR,AZMOAQ,1,3,3 + AZMOAQ=3 + ENDIF + ELSE IF(AZMOAQ .GE. 0) THEN + IF(AZMOAQ .NE. 1) THEN + WRITE(IOUT,9003) NAMSBR,AZMOAQ,-1,1,1 + AZMOAQ=1 + ENDIF + ENDIF + ENDIF + NBANGL=AZMOAQ + NANGL =AZMOAQ + ALLOCATE(NBSANG(5,NBANGL)) + ALLOCATE(DANGLT(NDIM,NBANGL,4),DDENWT(NBANGL,4),DNSANG(NBANGL), + > DDANG(NBANGL)) + LINMAX=8*NANGL*NBUCEL*(4+MXGSUR+16) + RCIRC=SQRT(ABSC(1,1)**2+ABSC(2,1)**2) + ABSC(1,1)= ABSC(1,1)/RCIRC + ABSC(2,1)= ABSC(2,1)/RCIRC + CALL NXTQAC(IPRINT,NDIM ,NANGL ,NBANGL,ITYPBC,DENUSR, + > ABSC ,RCIRC ,AZMQUA,IPER ,DANGLT,DDENWT, + > DNSANG,NBSANG,DDANG) + DEALLOCATE(DDANG) + DO JJ=1,NBANGL + DANGLT(1,NBANGL-JJ+1,2)=-DANGLT(1,JJ,1) + DANGLT(2,NBANGL-JJ+1,2)=DANGLT(2,JJ,1) + DDENWT(NBANGL-JJ+1,2)=DDENWT(JJ,1) + ENDDO + DO JJ=1,NBANGL + DANGLT(1,NBANGL-JJ+1,4)=DANGLT(1,JJ,1) + DANGLT(2,NBANGL-JJ+1,4)=-DANGLT(2,JJ,1) + DDENWT(NBANGL-JJ+1,4)=DDENWT(JJ,1) + DANGLT(1,NBANGL-JJ+1,3)=DANGLT(1,JJ,2) + DANGLT(2,NBANGL-JJ+1,3)=-DANGLT(2,JJ,2) + DDENWT(NBANGL-JJ+1,3)=DDENWT(JJ,2) + ENDDO + IF(IPRINT.GT.1) THEN + WRITE(IOUT,'(/34H SALTCG: CYCLIC ANGULAR QUADRATURE/8X, + > 5HANGLE,8X,7HCOSINES,16(1h-),3X,6HWEIGHT,11X, + > 17HCYCLIC PARAMETERS)') + DSUM=0.D0 + DO KK=1,4 + DO JJ=1,NANGL + ANGLE=SIGN(ACOS(DANGLT(1,JJ,KK))/PI*180.0,DANGLT(2,JJ,KK)) + WRITE(IOUT,'(1X,I4,1P,4E13.4,5X,2I4)') (KK-1)*NANGL+JJ, + > ANGLE,DANGLT(:2,JJ,KK),0.5D0/DDENWT(JJ,KK),NBSANG(:2,JJ) + DSUM=DSUM+0.5D0/DDENWT(JJ,KK) + ENDDO + ENDDO + WRITE(IOUT,'(39X,5HDSUM=,1P,E13.4)') DSUM + ENDIF + CALL LCMPUT(IPTRK,'TrackingDirc',NDIM*NBANGL*4,4,DANGLT) + CALL LCMPUT(IPTRK,'TrackingTrkW',NBANGL*4,4,DDENWT) + CALL LCMPUT(IPTRK,'TrackingSpaD',NBANGL,4,DNSANG) + CALL LCMPUT(IPTRK,'TrackingNbST',5*NBANGL,1,NBSANG) + ENDIF + RSTATT(4)=REAL(DENLIN) + RSTATT(5)=REAL(SPACLN) + RSTATT(6)=REAL(WEIGHT) + RSTATT(7)=REAL(RADIUS) + RSTATT(8)=REAL(CENTER(1)) + RSTATT(9)=REAL(CENTER(2)) +*---- +* Allocate memory to hold tracking data +*---- +** tracking data buffer: +* integers +* ITRAC2(NMAX OR 2*NMAX) = integer tracking array +* +* *integer descriptors in itrac2: +* 1 = address of last data +* 2 = total number of sub-trajectories +* 3 = +* 4 = phi for trajectory (2D) +* +* reals +* RTRAC2(nmax or 2*nmax) = real tracking array +* +* *real descriptors: +* 1 = +* 2 = cos phi entering basic +* 3 = sin phi left surface +* 4 = sin phi right surface +* 5 = cos phi left surface +* 6 = cos phi right surface +* 7 = total weight (DELR*WPHI) +* 8 = radial weight (DELR) +* +* IPART(NIPART,MXELEM) = to store integer intersection data +* RPART(NRPART,MXELEM) = to store real intersection data +* + IF(NBSLIN <= 0)THEN + NMAX2=NMAX0 + ELSE + NMAX2=NBSLIN + ENDIF + IF(ISPEC == 1) NMAX2=NMAX2*100 + ALLOCATE(ITRAC2(2*NMAX2),IPART(NIPART,GG%NB_ELEM),RTRAC2(NMAX2), + 1 RPART(NRPART,GG%NB_ELEM),STAT=OK) + IF(OK/=0) CALL XABORT('SALTCG: not enough memory IRD') +*---- +* Track +*---- + LINMAX=MAX(LINMAX,NBSLIN) + IF(IPRINT .GE. 10) WRITE(IOUT,6010) LINMAX + NBDR=1 + IF(RENO .EQ. -1) THEN + IF(LTRK .EQ. 0) THEN + NBDR=NQUAD*NBANGL+1 + ELSE IF(LTRK .EQ. 1) THEN + NBDR=4*NBANGL+1 + ENDIF + ENDIF + ALLOCATE(DVNOR(NFREG*NBDR),DSNOR(NFSUR*NQUAD*NBANGL)) + IF(LTRK .EQ. 0) THEN +*---- +* Standard (isotropic) tracking (white boundary conditions) +*---- + IF(IPRINT .GE. 1) WRITE(IOUT,6030) NBANGL*NQUAD,NPOINT + MAXSUB=1 + CALL SALTLS(IFTEMP,IPRINT,IGTRK ,NFREG ,NBANGL, NQUAD , + > RENO ,NBDR ,IFMT ,DENUSR,DANGLT, DDENWT, + > GG ,NBTDIR,MAXSGL,NTLINE,DVNOR ) + ELSE +*---- +* Cyclic (specular) tracking (mirror like boundary conditions) +*---- + NBTDIR=0 + CALL SALTLC(IFTEMP,IPRINT,IGTRK,NDIM,NFREG,NBANGL,RENO,NBDR, + > IFMT,DENUSR,DANGLT,DDENWT,NBSANG,GG,MAXSUB,MAXSGL, + > NTLINE,DVNOR ) + ENDIF +*---- +* Release allocated memory for SALT tracking +*---- + DEALLOCATE(RPART,RTRAC2,IPART,ITRAC2,STAT =OK) + IF(OK /= 0) CALL XABORT('SALTCG: failure to deallocate storage') +*---- +* Save track normalisation vector +*---- + CALL LCMPUT(IPTRK,'NumMerge ',NFREG,1,GG%NUM_MERGE) + CALL LCMPUT(IPTRK,'VolMerge ',NFREG,4,GG%VOL_NODE) + CALL LCMPUT(IPTRK,'VTNormalize ',NFREG,4,DVNOR) + IF(NBDR .GT. 1) THEN + CALL LCMPUT(IPTRK,'VTNormalizeD',NFREG*(NBDR-1),4, + > DVNOR(NFREG+1)) + ENDIF +*---- +* Get cell description of geometry +*---- + ALLOCATE(KEYMRG(-NFSUR:NFREG),MATALB(-NFSUR:NFREG), + > SURVOL(-NFSUR:NFREG)) + CALL LCMLEN(IPTRK,'KEYMRG ',ILONG,ITYLCM) + IF(ILONG>NFREG+NFSUR+1) CALL XABORT('SALTCG: KEYMRG OVERLOW.') + CALL LCMGET(IPTRK,'KEYMRG ',KEYMRG) + CALL LCMGET(IPTRK,'MATALB ',MATALB) + CALL LCMGET(IPTRK,'SAreaRvolume',SURVOL) +*---- +* Build NXTRecords directory +*---- + CALL LCMSIX(IPTRK,'NXTRecords ',2) + ISTATE(12)=ISYMM + ISTATE(14)=POLOAQ + ISTATE(17)=NPOINT + ISTATE(18)=LINMAX + ISTATE(19)=NTLINE + ISTATE(20)=NBTDIR + IF(LTRK .EQ. 0) THEN + ISTATE(21)=NQUAD*NBANGL + ELSE IF(LTRK .EQ. 1) THEN + ISTATE(21)=4*NBANGL + ENDIF + ISTATE(22)=NPLANE + CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMPUT(IPTRK,'EXCELTRACKOP',NSTATE,2,RSTATT) +*---- +* Renormalize tracks if required and transfer to final tracking file +*---- + IF(IGTRK .EQ. 1) THEN + CTRK = '$TRK' + WRITE(IFTRK) CTRK,5,NTLINE,IFMT + COMENT='CREATOR : DRAGON' + WRITE(IFTRK) COMENT + COMENT='MODULE : SALTCG' + WRITE(IFTRK) COMENT + COMENT='TYPE : CARTESIAN' + WRITE(IFTRK) COMENT + IF(RENO .EQ. -1) THEN + COMENT='TRKNOR : Directional ' + ELSE IF(RENO .EQ. 0) THEN + COMENT='TRKNOR : Global ' + ELSE + COMENT='TRKNOR : Off ' + ENDIF + WRITE(IFTRK) COMENT + IF(IFMT .EQ. 1) THEN + COMENT='OPTION : Extended ' + WRITE(IFTRK) COMENT + ELSE + COMENT='OPTION : Short ' + WRITE(IFTRK) COMENT + ENDIF +*---- +* Compress VOLSUR and MATALB according to KEYMRG and save on IFTRK +*---- + IF(LTRK .EQ. 0) THEN + WRITE(IFTRK) NDIM,LTRK,NEREG,NESUR,6,NCOR,NQUAD*NBANGL,MAXSUB, + > MAXSGL + ELSE IF(LTRK .EQ. 1) THEN + WRITE(IFTRK) NDIM,LTRK,NEREG,NESUR,6,NCOR,4*NBANGL,MAXSUB, + > MAXSGL + ENDIF + KEYMRG(1:NFREG)=GG%NUM_MERGE(:NFREG) + SURVOL(1:NFREG)=GG%VOL_NODE(:NFREG) + MATALB(1:NFREG)=GG%MED(:NFREG) + CALL NXTCVM(IFTRK,IPRINT,NFREG,NFSUR,NEREG,NESUR,MATALB,SURVOL, + > KEYMRG) + WRITE(IFTRK) ( ICODE(JJ),JJ=1,6) + WRITE(IFTRK) (ALBEDO(JJ),JJ=1,6) + IF(LTRK .EQ. 0) THEN + CALL NXTSQD(IFTRK,IPRINT,NDIM,NQUAD,NBANGL,DANGLT,DDENWT) + ELSE IF(LTRK .EQ. 1) THEN + WRITE(IFTRK) ((DANGLT(1,JJ,KK),DANGLT(2,JJ,KK),JJ=1,NBANGL), + > KK=1,4) + WRITE(IFTRK) ((DDENWT(JJ,KK),JJ=1,NBANGL),KK=1,4) + ENDIF + REWIND IFTEMP + CALL NXTTNS(IFTRK ,IFTEMP,IPRINT,RENO ,NFSUR ,NFREG ,NDIM , + > MAXSUB,MAXSGL,NTLINE,NBDR ,IFMT ,KEYMRG,DVNOR) +*---- +* Close temporary tracking file if required +*---- + ICLS=KDRCLS(IFTEMP,2) + IF(ICLS .NE. 0) WRITE(IOUT,9011) NAMSBR + ENDIF +*---- +* Deallocate memory +*---- + DEALLOCATE(DSNOR,DVNOR) + IF(LTRK .EQ. 1) DEALLOCATE(NBSANG,DNSANG) + DEALLOCATE(DDENWT,DANGLT) + DEALLOCATE(DGMESH,SURVOL,MATALB,KEYMRG) +*---- +* Processing finished: +* print routine closing output header if required +* and return +*---- + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6012) + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(' Maximum length of a line =',I10) + 6011 FORMAT(' Tracking of geometry begins:'/ + > ' Number of regions before merge =',I10/ + > ' Number of regions after merge =',I10/ + > ' Number of surfaces before merge=',I10/ + > ' Number of surfaces after merge =',I10) + 6012 FORMAT(' Tracking of geometry completed') + 6030 FORMAT(' Number of directions for tracking = ',I10/ + > ' Number of lines per direction = ',I10) + 9002 FORMAT(' ***** Warning in ',A6,' *****'/ + > ' Number of specular angles requested :',I10/ + > ' For values > ',I10,' use ',I10) + 9003 FORMAT(' ***** Warning in ',A6,' *****'/ + > ' Number of specular angles requested :',I10/ + > ' For values > ',I10,' and < ',I10,' use ',I10) + 9010 FORMAT(' ***** Warning in ',A6,' *****'/ + > ' Impossible to open temporary tracking file ') + 9011 FORMAT(' ***** Warning in ',A6,' *****'/ + > ' Impossible to close temporary tracking file ') + END diff --git a/Dragon/src/SALTLC.f90 b/Dragon/src/SALTLC.f90 new file mode 100644 index 0000000..1e6023e --- /dev/null +++ b/Dragon/src/SALTLC.f90 @@ -0,0 +1,360 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! To generate the cyclic tracking lines (specular tracking) for a +! geometry using the SALT algorithm. +! +!Copyright: +! Copyright (C) 2015 Ecole Polytechnique de Montreal. +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version +! +!Author(s): +! A. Hebert +! +!Parameters: input +! IFTEMP pointer to a temporary TRACKING file in update or creation +! mode. +! IPRINT print level. +! IGTRK flag to generate the tracking file. In the case where +! IGTRK=1, the tracking is performed and +! used to evaluate the track normalisation factor and the +! tracking file is generated. When IGTRK=0, the tracking is +! still performed and used to evaluate the +! track normalisation factor but the tracking file is not +! generated. +! NDIM problem dimensions. +! NFREG number of regions. +! NBANGL number of angles. +! RENO track normalisation option. A value RENO=-1 implies +! a direction dependent normalization of the tracks +! for the volume while a value RENO=0, implies +! a global normalisation. +! NBDR number of directions for track normalization. +! IFMT tracking file format: +! IFMT=0 for short file; +! IFMT=1 long file required by TLM: module. +! DENUSR user defined track density. +! DANGLT angle cosines. +! DDENWT angular density for each angle. +! NBSANG number of subtracks for each angles. +! GG geometry basic information. +! +!Parameters: output +! MAXSUB maximum number of subtracks in a line. +! MAXSGL maximum number of segments in a line. +! NTLINE total number of lines generated. +! DVNOR ratio of analytic to tracked volume. +! +!----------------------------------------------------------------------- +! +SUBROUTINE SALTLC(IFTEMP,IPRINT,IGTRK,NDIM,NFREG,NBANGL,RENO,NBDR,IFMT,DENUSR,DANGLT, & + DDENWT,NBSANG,GG,MAXSUB,MAXSGL,NTLINE,DVNOR) + USE PRECISION_AND_KINDS, ONLY : PDB,INFINITY,SMALL + USE SAL_GEOMETRY_TYPES, ONLY : T_G_BASIC,ANGGEO,TYPGEO + USE SAL_TRACKING_TYPES, ONLY : NMAX2,MINLEN,NNN,ITRAC2,RTRAC2,DELR,CNT,CNT0,NBTRAC,IERR,DD0,EX0, & + EY0,DELX,DINIT,EX,ANGTAB,ELMTAB,TORIG,DNEW,N_AXIS,NB_TOT,NB_MAX, & + N_AXIS_KEEP,IMPX + USE SAL_AUX_MOD, ONLY : SAL231,SAL232,SAL237,SAL220_1 + USE SAL_TRAJECTORY_MOD, ONLY : SALTRA + IMPLICIT NONE + !---- + ! Subroutine arguments + !---- + INTEGER :: IFTEMP,IPRINT,IGTRK,NDIM,NFREG,NBANGL,MAXSUB,MAXSGL,NTLINE,RENO,NBDR,IFMT, & + NBSANG(5,NBANGL) + REAL(PDB) :: DENUSR,DANGLT(NDIM,4*NBANGL),DDENWT(4*NBANGL),DVNOR(NFREG,NBDR) + TYPE(T_G_BASIC) :: GG + !---- + INTEGER :: AXIS(2),PIECE,NPIECE,IANGL,II0,II,KEEP_NAXIS,NN,MM,IPHI,P1,P2,INODE,OK,ISURF, & + JCURR,IJK1,ITR,ITRS,JPHI,NA,NAOLD,NEST,NSEG,NTRACK,NTSEG,IAVERR,NMAX3, & + ICYCL,NCYCLE + REAL(PDB) :: WR,WT,PROJTAB(6),KEEP_DELX,MOV_DELX,XFACT,ANGLE,COSSURF,DCERR,DAVERR,DMVERR, & + DSVERR,EPS0 + REAL :: X + REAL(PDB), ALLOCATABLE, DIMENSION(:) :: VOLN + REAL(PDB), ALLOCATABLE, DIMENSION(:,:) :: FACNRM ! aux for normalisation + INTEGER, PARAMETER :: FOUT =6 + INTEGER, ALLOCATABLE, DIMENSION(:) :: ITRACK_TMP + REAL(PDB), ALLOCATABLE, DIMENSION(:) :: RTRACK_TMP + INTEGER, POINTER, DIMENSION(:) :: ITRAC3 + REAL(PDB), POINTER, DIMENSION(:) :: RTRAC3 + ! + IMPX=IPRINT + CALL SAL220_1(ANGGEO) + ! + DELR=1.0D0/DENUSR + NB_MAX=2*MAXVAL(NBSANG(1,:)+NBSANG(2,:)) + IF((TYPGEO.EQ.7).OR.(TYPGEO.EQ.12)) NB_MAX=2*NB_MAX + ALLOCATE(ANGTAB(2*NB_MAX),ELMTAB(2*NB_MAX),TORIG(2,NB_MAX),N_AXIS_KEEP(NB_MAX),STAT=OK) + IF(OK.NE.0) CALL XABORT('SALTLC: Not enough memory ird') + MAXSUB=0 + MAXSGL=0 + NBTRAC=0 + CNT0=0 + CNT=CNT0+NNN + ALLOCATE(VOLN(GG%NB_NODE),FACNRM(GG%NB_NODE,2*NBANGL),STAT=OK) + IF(OK/=0) CALL XABORT('SALTLC: NOT ENOUGH MEMORY R') + FACNRM(:GG%NB_NODE,:2*NBANGL)=0._PDB + ! initialize entering distance + DD0=-INFINITY + EPS0=REAL(10.*SQRT(EPSILON(X))) + NCYCLE=1 + IF((TYPGEO == 5).OR.((TYPGEO == 9))) NCYCLE=2 + DO ICYCL=1,NCYCLE + DO IANGL=1,NBANGL + ! keep IANGL + NN=NBSANG(2,IANGL) ; MM=NBSANG(1,IANGL) + IF(ICYCL == 1) THEN + EX0=DANGLT(1,IANGL) ; EY0=DANGLT(2,IANGL) + ELSE IF(ICYCL == 2) THEN + EX0=-DANGLT(1,IANGL) ; EY0=DANGLT(2,IANGL) + ELSE IF(ICYCL == 3) THEN + EX0=-DANGLT(1,IANGL) ; EY0=-DANGLT(2,IANGL) + ELSE IF(ICYCL == 4) THEN + EX0=DANGLT(1,IANGL) ; EY0=-DANGLT(2,IANGL) + ENDIF + IF(EX0 < 0.0) MM=-MM + IF(EY0 < 0.0) NN=-NN + ! projections of geometry outline onto the two rotation or symmetry axis + P1=GG%PPERIM_MAC2(3); P2=GG%PPERIM_MAC2(4)-1 + CALL SAL237(EX0,EY0,MM,NN,PROJTAB,AXIS) + ! track in direction IANGL and its relative directions + NPIECE=AXIS(1) + ! tracking vector + DO PIECE=1,NPIECE + ! axis nber, position on the axis + N_AXIS=AXIS(2) + DELX=PROJTAB(3)+PROJTAB(5)*(REAL(PIECE)-0.5) + KEEP_NAXIS=N_AXIS + KEEP_DELX=DELX + ! radial weight of the track + WR=PROJTAB(6) + IERR=0 + MOV_DELX=0. + DO WHILE (IERR==0) + ! compute one trajectory: + ! (1) compute one trajectory + ! (2) keep entering points if we have more trajectories + CALL SALTRA(DANGLT(:,:2*NBANGL),GG%NPERIM_MAC2,GG%PERIM_MAC2,GG%ISURF2_ELEM,GG%IPAR, & + GG%RPAR,GG%PPERIM_NODE,GG%PERIM_NODE,GG%IBC2_ELEM,GG%IDATA_BC2,GG%BCDATA, & + GG%PPERIM_MAC2,GG%DIST_AXIS) + IF(IERR==1) DINIT=DNEW + IF(IERR==0) THEN + ! if ierr=0,trajectory has entered into the seam of element joint, + ! moves delx -> delx+epsilon_pdb*n + MOV_DELX=MOV_DELX+EPS0 + DELX=KEEP_DELX+MOV_DELX + N_AXIS=KEEP_NAXIS + CNT=CNT0+NNN + ENDIF + ENDDO + ! if ierr=-1,tracking have not re-entering point=no trajectory + IF(IERR/=-1) THEN + ! a trajectory has been completed: store angle order nber, total weight and WR + ANGLE=DACOS(EX) + ITRAC2(CNT0+4)=IANGL + RTRAC2(CNT0+7)=0.5_PDB*WR/DDENWT(IANGL) + RTRAC2(CNT0+8)=WR + II0=CNT0+1 + IF(IPRINT > 3) CALL SAL231(RTRAC2(II0:),ITRAC2(II0:),DELX,EX0,EY0,ANGLE) + DO II=1,ITRAC2(II0) + IF(RTRAC2(II0+II+NNN-1) <= 0.0) CALL XABORT('SALTLC: INVALID SEGMENT LENGTH') + ENDDO + ! compute volumes + CALL SAL232(ITRAC2(II0:),RTRAC2(II0:),FACNRM,GG) + ! next line + IF(CNT+NNN+MINLEN>=NMAX2) THEN + NMAX3=CNT+NNN+MINLEN+1000 + ALLOCATE(ITRAC3(2*NMAX3),RTRAC3(NMAX3),STAT=OK) + IF(OK/=0) CALL XABORT('SALTLC: NMAX2 overflow.') + RTRAC3(:NMAX2)=RTRAC2(:NMAX2) + ITRAC3(:2*NMAX2)=ITRAC2(:2*NMAX2) + DEALLOCATE(RTRAC2,ITRAC2) + RTRAC2=>RTRAC3 + ITRAC2=>ITRAC3 + NMAX2=CNT+NNN+MINLEN+1000 + ENDIF + NBTRAC=NBTRAC+1 + ! + ! total weight and space weight + COSSURF=RTRAC2(II0+1) + WT=RTRAC2(II0-1+7) + NTRACK=ITRAC2(II0) + NB_TOT=ITRAC2(II0+1) + IF(NB_TOT > NB_MAX) CALL XABORT('SALTLC: NB_MAX overflow.') + ! + ! identify entering end leaving surfaces + JCURR=0 + IJK1=NNN+NTRACK + NTSEG=NTRACK+2*NB_TOT + ! + MAXSGL=MAX(MAXSGL,NTSEG) + MAXSUB=MAX(MAXSUB,NB_TOT) + ALLOCATE(ITRACK_TMP(NTSEG),RTRACK_TMP(NTSEG)) + ! + ! loop over sub-trajectories + NSEG=0 + NAOLD=0 + ITR=NNN + DO ITRS=1,NB_TOT + IJK1=IJK1+1 + NEST=ITRAC2(II0-1+IJK1) + IJK1=IJK1+1 + JPHI=ITRAC2(II0-1+IJK1) + IF(IPRINT > 5) WRITE(FOUT,'(I6,"*",6X,I6,5X,I6)') ITRS,NEST,JPHI + IF(TYPGEO <= 7) NA=(JPHI-1)/NBANGL+1 ! Cartesian + ISURF=N_AXIS_KEEP(ITRS) + IF(ITRS == 1) THEN + ITRACK_TMP(1)=-ISURF + RTRACK_TMP(1)=0.5 + IF(IPRINT > 5) WRITE(FOUT,*) ' -> surface',ISURF + ENDIF + IF(ISURF == 0) THEN + WRITE(FOUT,*) ' JPHI=',JPHI,' -> surface',ISURF + CALL XABORT('SALTLC: symmetry not implemented.') + ENDIF + IF(IPRINT > 5) THEN + IF(TYPGEO <= 7) THEN + WRITE(FOUT,*) ' JPHI=',JPHI,' NAOLD=',NAOLD,' NA=',NA,' -> surface',ISURF + ELSE + WRITE(FOUT,*) ' JPHI=',JPHI,' -> surface',ISURF + ENDIF + ENDIF + NSEG=NSEG+1 + ITRACK_TMP(NSEG)=-ISURF + RTRACK_TMP(NSEG)=0.5 + IF(ITRS > 1) THEN + NSEG=NSEG+1 + ITRACK_TMP(NSEG)=-ISURF + RTRACK_TMP(NSEG)=0.5 + ENDIF + DO II=1,NEST + ITR=ITR+1 + IF(IPRINT > 5) THEN + WRITE(FOUT,'(5X,I6,"*",3(1P,I6,1P,E10.2,I7))') II, & + ITRAC2(II0-1+ITR),RTRAC2(II0-1+ITR),ITRAC2(II0-1+ITR+NMAX2) + ENDIF + NSEG=NSEG+1 + ITRACK_TMP(NSEG)=ITRAC2(II0-1+ITR) + RTRACK_TMP(NSEG)=RTRAC2(II0-1+ITR) + ENDDO + NAOLD=NA + ENDDO + ! case of a geometry with specular reflective condition which is not a + ! rectangular -> anisotropy treatment not supported + IF(JCURR == 0) JCURR=1 + NSEG=NSEG+1 + IF(NSEG /= NTSEG) CALL XABORT('SALTLC: NTSEG inconsistency') + ITRACK_TMP(NSEG)=-JCURR + RTRACK_TMP(NSEG)=0.5 + IF(IPRINT > 5) THEN + WRITE(FOUT,*) 'SALTLC: EXCELT entry with',NSEG,'segments:' + WRITE(FOUT,*) (ITRACK_TMP(II),II=1,NSEG) + WRITE(FOUT,*) (RTRACK_TMP(II),II=1,NSEG) + ENDIF + IF(IGTRK == 1) THEN + IF(IFMT == 1) THEN + WRITE(IFTEMP) NB_TOT,NTSEG,WT,(ANGTAB(II),II=2,2*NB_TOT,2),(ITRACK_TMP(II),II=1,NTSEG), & + (RTRACK_TMP(II),II=1,NTSEG),NBTRAC,1,1,1,((TORIG(II0,II),II0=1,NDIM),II=1,NB_TOT) + ELSE + WRITE(IFTEMP) NB_TOT,NTSEG,WT,(ANGTAB(II),II=2,2*NB_TOT,2),(ITRACK_TMP(II),II=1,NTSEG), & + (RTRACK_TMP(II),II=1,NTSEG) + ENDIF + ENDIF + ! + DEALLOCATE(RTRACK_TMP,ITRACK_TMP) + CNT0=CNT + IF(CNT0+NNN+MINLEN >= NMAX2) THEN + CALL XABORT('SALTLC: NMAX2 overflow(2)') + ELSE + CNT=CNT0+NNN + ENDIF + ENDIF + ENDDO + ! end of trajectories for this angle + IF(IPRINT > 5) THEN + WRITE(FOUT,'('' SALTLC: ANGLE EX EY = '',1P,3E12.4/)') ANGLE,EX0,EY0 + ENDIF + ENDDO + ENDDO + NTLINE=NBTRAC + !---- + ! Compute merged normalization factors + !---- + IF(RENO/=1) THEN + DO INODE=1,GG%NB_NODE + VOLN(INODE)=0._PDB + DO IANGL=1,NBANGL + VOLN(INODE)=VOLN(INODE)+(FACNRM(INODE,IANGL)+FACNRM(INODE,NBANGL+IANGL)) & + /DDENWT(IANGL) + ENDDO + ENDDO + DMVERR=0.0D0 + DSVERR=0.0D0 + DAVERR=0.0D0 + IAVERR=0 + DO INODE=1,GG%NB_NODE + DO IPHI=1,2*NBANGL + IF(RENO==0) THEN + IF(ABS(VOLN(INODE))>SMALL) THEN + FACNRM(INODE,IPHI)=GG%VOL_NODE(INODE)/VOLN(INODE) + ENDIF + ELSE IF(RENO==-1) THEN + IF(ABS(FACNRM(INODE,IPHI))>SMALL) THEN + FACNRM(INODE,IPHI)=GG%VOL_NODE(INODE)/FACNRM(INODE,IPHI) + ENDIF + ENDIF + ENDDO + IF(ABS(VOLN(INODE))>SMALL) THEN + IAVERR=IAVERR+1 + DCERR=100.0D0*(1.0D0-GG%VOL_NODE(INODE)/VOLN(INODE)) + DMVERR=MAX(DMVERR,ABS(DCERR)) + DSVERR=DSVERR+DCERR*DCERR + DAVERR=DAVERR+DCERR + ENDIF + ENDDO + DSVERR=SQRT(DSVERR/DBLE(IAVERR)) + DAVERR=DAVERR/DBLE(IAVERR) + IF(IPRINT > 0) WRITE(FOUT,6005) DSVERR,DMVERR,DAVERR + IF(IPRINT > 5) THEN + DO IPHI=1,2*NBANGL + WRITE(*,*) 'iphi=',IPHI + WRITE(*,*) 'facnrm : ',(FACNRM(INODE,IPHI),INODE=1,MIN(10,GG%NB_NODE)) + ENDDO + ENDIF + IF(GG%NB_NODE > NFREG) CALL XABORT('SALTLC: bug.') + DVNOR(:,:)=0._PDB + DO INODE=1,GG%NB_NODE + IF(RENO==0) THEN + DVNOR(INODE,1)=DVNOR(INODE,1)+FACNRM(INODE,1)*GG%VOL_NODE(INODE) + ELSE IF(RENO==-1) THEN + DO IPHI=1,2*NBANGL + XFACT=FACNRM(INODE,IPHI) + DVNOR(INODE,IPHI+1)=DVNOR(INODE,IPHI+1)+XFACT*GG%VOL_NODE(INODE) + DVNOR(INODE,2*NBANGL+IPHI+1)=DVNOR(INODE,IPHI+1) + ENDDO + ENDIF + ENDDO + DO IPHI=1,NBDR + DVNOR(:,IPHI)=DVNOR(:,IPHI)/GG%VOL_NODE(:) + ENDDO + IF(IPRINT > 4) THEN + DO IPHI=1,NBDR + WRITE(*,*) 'iphi=',IPHI + WRITE(*,*) 'dvnor : ',(DVNOR(INODE,IPHI),INODE=1,MIN(10,NFREG)) + ENDDO + ENDIF + ENDIF + !---- + ! Scratch storage deallocation + !---- + DEALLOCATE(FACNRM,VOLN) + DEALLOCATE(N_AXIS_KEEP,TORIG,ELMTAB,ANGTAB) + RETURN + 6005 FORMAT(' SALTLC: Global RMS, maximum and average errors (%) ', & + 'on region volumes :',3(2X,F10.5)) +END SUBROUTINE SALTLC diff --git a/Dragon/src/SALTLS.f90 b/Dragon/src/SALTLS.f90 new file mode 100644 index 0000000..32a4500 --- /dev/null +++ b/Dragon/src/SALTLS.f90 @@ -0,0 +1,299 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! To generate the standard tracking lines (isotropic tracking) for a +! geometry using the SALT algorithm. +! +!Copyright: +! Copyright (C) 2014 Ecole Polytechnique de Montreal. +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version +! +!Author(s): +! A. Hebert +! +!Parameters: input +! IFTEMP pointer to a temporary tracking data structure in creation +! mode. +! IPRINT print level. +! IGTRK flag to generate the tracking file. In the case where IGTRK=1, +! the tracking is performed and used to evaluate the track +! normalisation factor and the tracking file is generated. +! When IGTRK=0, the tracking is still performed and used to +! evaluate the track normalisation factor but the tracking file +! is not generated. +! NFREG number of regions. +! NBANGL number of angles. +! NQUAD number of quarter (in 2-D). +! RENO track normalisation option. A value RENO=-1 implies +! a direction dependent normalization of the tracks for +! the volume. A value reno=0, implies a global normalisation. +! NBDR number of directions for track normalization (no normalization +! when reno=1). +! IFMT tracking file format: +! IFMT=0 for short file; +! IFMT=1 long file required by TLM: module. +! DENUSR user defined track density. +! DANGLT angle cosines. +! DDENWT angular density for each angle. +! GG geometry basic information. +! +!Parameters: output +! NBTDIR number of tracks directions considered. +! MAXSGL maximum number of segments in a line. +! NTLINE total number of lines generated. +! DVNOR ratio of analytic to tracked volume. +! +!----------------------------------------------------------------------- +! +SUBROUTINE SALTLS(IFTEMP,IPRINT,IGTRK,NFREG,NBANGL,NQUAD,RENO,NBDR,IFMT,DENUSR, & + DANGLT,DDENWT,GG,NBTDIR,MAXSGL,NTLINE,DVNOR) + USE PRECISION_AND_KINDS, ONLY : PDB,SMALL,PI,TWOPI,HALFPI,INFINITY + USE SAL_GEOMETRY_TYPES, ONLY : T_G_BASIC + USE SAL_TRACKING_TYPES, ONLY : NMAX2,MINLEN,NNN,ITRAC2,RTRAC2,DPIECE,CNT,CNT0,NBTRAC,LGMORE, & + LGMORE,IERR,DD0,EX0,EY0,DELX,AX,AY,DINIT,ANGTAB,ELMTAB,NB_MAX,IMPX + USE SAL_AUX_MOD, ONLY : SAL231,SAL232,SAL235 + USE SAL_TRAJECTORY_MOD, ONLY : SALTRA + IMPLICIT NONE + !---- + ! subroutine arguments + !---- + INTEGER :: IFTEMP,IPRINT,IGTRK,NFREG,NBANGL,NQUAD,RENO,NBDR,IFMT,MAXSGL,NBTDIR,NTLINE,OK + REAL(PDB) :: DENUSR,DANGLT(2,NQUAD*NBANGL),DDENWT(NQUAD,NBANGL),DVNOR(NFREG,NBDR) + TYPE(T_G_BASIC) :: GG + !---- + ! local parameters + !---- + INTEGER :: II0,IPHI,MQ,MQUAD,NPIECE,INODE,IANGL,II,IQUAD,FIRST,ICURR, & + JCURR,LASTI,NTSEG,IAVERR + LOGICAL :: LGON + REAL :: EPS0,X + REAL(PDB) :: WT,WR,DEL0,DEL2,DNEW,DOLD,ANGLE,DELM,KEEP_DELX, & + MOV_DELX,SUMM,NORM,XFACT,EPSILON_PDB,DCERR,DAVERR, & + DMVERR,DSVERR,TORIG(2) + REAL(PDB), DIMENSION(2) :: THETA0 + REAL(PDB), ALLOCATABLE, DIMENSION(:) :: VOLN,SURFN,CURRN + REAL(PDB), ALLOCATABLE, DIMENSION(:,:) :: FACNRM ! aux for normalisation + REAL, PARAMETER :: EPS3 = 1E-3 + INTEGER, PARAMETER :: FOUT =6 + ! + IMPX=IPRINT + !---- + ! recompute weights + !---- + NBTDIR=0 + SUMM=0._PDB + DO IANGL=1,NBANGL + DO IQUAD=1,NQUAD + IF(DDENWT(IQUAD,IANGL).GT.0._PDB) NBTDIR=NBTDIR+1 + SUMM=SUMM+DDENWT(IQUAD,IANGL) + ENDDO + ENDDO + NORM=0.5_PDB/SUMM + NB_MAX=1 + ALLOCATE(ANGTAB(2),ELMTAB(2)) + !---- + ! isotropic tracking loop + !---- + ! define quadrature + ! get limit intervals for radial quadrature + ! minimum radial interval to contain one trajectory + EPSILON_PDB=SQRT(EPSILON(X)) + EPS0=REAL(10.*EPSILON_PDB) + DEL0=REAL(EPS3,PDB)/DENUSR + DEL2=-1._PDB + ! start a set of tracks + ! CNT0 = address of beginning of trajectory - 1 + ! CNT = address for trajectory data - 1 + ! NBTRAC = number of trajectories in a record + NBTRAC=0 + MAXSGL=0 + IPHI=0 + ALLOCATE(VOLN(GG%NB_NODE),SURFN(GG%NB_SURF2), & + CURRN(GG%NB_SURF2),FACNRM(GG%NB_NODE,NBANGL*NQUAD),STAT=OK) + IF(OK/=0) CALL XABORT('SALTLS: NOT ENOUGH MEMORY R') + FACNRM(:GG%NB_NODE,:NBANGL*NQUAD)=0._PDB + DO IANGL=1,NBANGL + DO IQUAD=1,NQUAD + IPHI=IPHI+1 + ! KEEP IPHI + EX0=DANGLT(1,(IANGL-1)*NQUAD+IQUAD) + EY0=DANGLT(2,(IANGL-1)*NQUAD+IQUAD) + ANGLE=DACOS(EX0) + ! get theta- and theta+ from angle (to be used in SAL235 to + ! decide whether to include projections of tangents to arcs): + THETA0(1)=ANGLE+HALFPI + THETA0(2)=THETA0(1)+PI + IF(THETA0(2)>TWOPI)THETA0(2)=THETA0(2)-TWOPI + ! get projection of points onto axis orthogonal to tracking: + ! only first and last points from macro perimeter + CALL SAL235(NPIECE,THETA0,EX0,EY0,GG%IPAR,GG%RPAR,GG%PERIM_MAC2,GG%NPERIM_MAC2) + ! integrate on each piece + DOLD=DPIECE(1) + DNEW=DPIECE(2) + DELM=DNEW-DOLD + IF(DELM>DEL0)THEN + ! compute nber of intervals for step =< 1/denusr + MQUAD=1+INT(DELM*DENUSR) + DELM=DELM/MQUAD + DO MQ=1,MQUAD + DELX=DOLD+0.5_PDB*DELM + KEEP_DELX=DELX + WR=REAL(DELM) + ! initialize entering distance + DD0=-INFINITY + LGON=.TRUE. + DO WHILE (LGON) + CNT0=0 + CNT=CNT0+NNN + IERR=0 + MOV_DELX=0. + DO WHILE (IERR==0) + ! compute one trajectory: + AX=DELX*EY0 + AY=-DELX*EX0 + CALL SALTRA(DANGLT,GG%NPERIM_MAC2,GG%PERIM_MAC2,GG%ISURF2_ELEM,GG%IPAR, & + GG%RPAR,GG%PPERIM_NODE,GG%PERIM_NODE) + IF(IERR==0)THEN + ! if IERR=0,trajectory has entered into the element joint, moves + ! DELX -> DELX+EPSILON_PDB*N + MOV_DELX=MOV_DELX+EPS0 + DELX=KEEP_DELX+MOV_DELX + CNT=CNT0+NNN + ENDIF + ENDDO + ! a trajectory has been completed: store angle order nber, total weight and wr + !!! corrected by A. Hebert in ev3874 + !!! ITRAC2(CNT0+4)=IPHI + ITRAC2(CNT0+7)=IPHI + RTRAC2(CNT0+7)=DDENWT(IQUAD,IANGL)*WR*NORM + RTRAC2(CNT0+8)=WR + II0=CNT0+1 + IF(IPRINT > 3) CALL SAL231(RTRAC2(II0:),ITRAC2(II0:),DELX,EX0,EY0,ANGLE) + DO II=1,ITRAC2(II0) + IF(RTRAC2(II0+II+NNN-1) <= 0.0) CALL XABORT('SALTLS: INVALID SEGMENT LENGTH') + ENDDO + ! compute volumes + CALL SAL232(ITRAC2(II0:),RTRAC2(II0:),FACNRM,GG,SURFN,CURRN) + ! next line + IF(CNT+NNN+MINLEN>=NMAX2) CALL XABORT('SALTLS: BUFFER OVERFLOW') + NBTRAC=NBTRAC+1 + WT=RTRAC2(II0+7-1) + WR=RTRAC2(II0+8-1) + FIRST=1 + LASTI=ITRAC2(II0) + IF(GG%NB_SURF2/=0)THEN + ICURR=ITRAC2(II0+5-1) + JCURR=ITRAC2(II0+6-1) + ELSE + ICURR=0 + JCURR=0 + ENDIF + NTSEG=LASTI-FIRST+3 + MAXSGL=MAX(MAXSGL,NTSEG) + IF(IGTRK == 1) THEN + IF(IFMT == 1) THEN + TORIG(1)=AX+DANGLT(1,IPHI)*DINIT ; TORIG(2)=AY+DANGLT(2,IPHI)*DINIT ; + WRITE(IFTEMP) 1,NTSEG,WT,IPHI, & + -ICURR,(ITRAC2(II0+II-1),II=FIRST+NNN,LASTI+NNN),-JCURR, & + 0.5D0,(RTRAC2(II0+II-1),II=FIRST+NNN,LASTI+NNN),0.5D0, & + NBTRAC,1,MQ,1,TORIG(1),TORIG(2) + ELSE + WRITE(IFTEMP) 1,NTSEG,WT,IPHI, & + -ICURR,(ITRAC2(II0+II-1),II=FIRST+NNN,LASTI+NNN),-JCURR, & + 0.5D0,(RTRAC2(II0+II-1),II=FIRST+NNN,LASTI+NNN),0.5D0 + ENDIF + IF(IPRINT>5) WRITE(FOUT,'(2X,''TRAJ# DELX '',''IERR = '',I6,3X,1P,E12.4,I5)') & + NBTRAC,DELX,IERR + ENDIF + LGON=LGMORE + ENDDO + ! end of one interval: move into beginning of next + DOLD=DOLD+DELM + ENDDO + ! end of one piece + ENDIF + ! end of trajectories for this angle + IF(IPRINT > 5) THEN + WRITE(FOUT,'('' ANGLE EX EY NTRA = '',1P,3E12.4,I8,/)') ANGLE,EX0,EY0,NBTRAC + ENDIF + ENDDO + ENDDO + NTLINE=NBTRAC + !---- + ! Compute merged normalization factors + !---- + IF(RENO/=1) THEN + DO INODE=1,GG%NB_NODE + VOLN(INODE)=0._PDB + DO IANGL=1,NBANGL + DO IQUAD=1,NQUAD + VOLN(INODE)=VOLN(INODE)+2._PDB*FACNRM(INODE,IANGL+(IQUAD-1)*NBANGL)* & + DDENWT(IQUAD,IANGL)*NORM + ENDDO + ENDDO + ENDDO + DMVERR=0.0D0 + DSVERR=0.0D0 + DAVERR=0.0D0 + IAVERR=0 + DO INODE=1,GG%NB_NODE + DO IPHI=1,NBANGL*NQUAD + IF(RENO==0) THEN + IF(ABS(VOLN(INODE))>SMALL) THEN + FACNRM(INODE,IPHI)=GG%VOL_NODE(INODE)/VOLN(INODE) + ENDIF + ELSE IF(RENO==-1) THEN + IF(ABS(FACNRM(INODE,IPHI))>SMALL) THEN + FACNRM(INODE,IPHI)=GG%VOL_NODE(INODE)/FACNRM(INODE,IPHI) + ENDIF + ENDIF + ENDDO + IF(ABS(VOLN(INODE))>SMALL) THEN + IAVERR=IAVERR+1 + DCERR=100.0D0*(1.0D0-GG%VOL_NODE(INODE)/VOLN(INODE)) + DMVERR=MAX(DMVERR,ABS(DCERR)) + DSVERR=DSVERR+DCERR*DCERR + DAVERR=DAVERR+DCERR + ENDIF + ENDDO + DSVERR=SQRT(DSVERR/DBLE(IAVERR)) + DAVERR=DAVERR/DBLE(IAVERR) + IF(IPRINT > 0) WRITE(FOUT,6005) DSVERR,DMVERR,DAVERR + IF(IPRINT > 5) THEN + DO IPHI=1,NBANGL*NQUAD + WRITE(*,*) 'iphi=',IPHI + WRITE(*,*) 'facnrm : ',(FACNRM(INODE,IPHI),INODE=1,MIN(10,GG%NB_NODE)) + ENDDO + ENDIF + IF(GG%NB_NODE > NFREG) CALL XABORT('SALTLS: bug.') + DVNOR(:,:)=0._PDB + DO INODE=1,GG%NB_NODE + IF(RENO==0) THEN + DVNOR(INODE,1)=DVNOR(INODE,1)+FACNRM(INODE,1)*GG%VOL_NODE(INODE) + ELSE IF(RENO==-1) THEN + DO IPHI=1,NBANGL*NQUAD + XFACT=FACNRM(INODE,IPHI) + DVNOR(INODE,IPHI+1)=DVNOR(INODE,IPHI+1)+XFACT*GG%VOL_NODE(INODE) + ENDDO + ENDIF + ENDDO + DO IPHI=1,NBDR + DVNOR(:,IPHI)=DVNOR(:,IPHI)/GG%VOL_NODE(:) + ENDDO + IF(IPRINT > 4) THEN + DO IPHI=1,NBDR + WRITE(*,*) 'iphi=',IPHI + WRITE(*,*) 'dvnor : ',(DVNOR(INODE,IPHI),INODE=1,MIN(10,NFREG)) + ENDDO + ENDIF + ENDIF + DEALLOCATE(FACNRM,CURRN,SURFN,VOLN) + DEALLOCATE(ELMTAB,ANGTAB) + RETURN + 6005 FORMAT(' SALTLS: Global RMS, maximum and average errors (%) ', & + 'on region volumes :',3(2X,F10.5)) +END SUBROUTINE SALTLS diff --git a/Dragon/src/SAL_AUX_MOD.f90 b/Dragon/src/SAL_AUX_MOD.f90 new file mode 100644 index 0000000..e64416a --- /dev/null +++ b/Dragon/src/SAL_AUX_MOD.f90 @@ -0,0 +1,496 @@ +! +!--------------------------------------------------------------------- +! +!Purpose: +! Support subroutines for isotropic and specular boundary conditions cases +! +!Copyright: +! Copyright (C) 2001 Ecole Polytechnique de Montreal. +! +!Author(s): +! X. Warin +! +!--------------------------------------------------------------------- +! +MODULE SAL_AUX_MOD + + USE PRECISION_AND_KINDS, ONLY : PDB,SMALL,PI,TWOPI,HALFPI,INFINITY + USE SAL_NUMERIC_MOD, ONLY : SAL141 + +CONTAINS + SUBROUTINE SAL231(RTRACK,ITRACK,DELX,EX0,EY0,ANGLE) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! print out trajectory information + ! + !Parameters: input + ! RTRACK floating point vectors to store trajectory information + ! ITRACK integer vectors to store trajectory information + ! DELX initial point of trajectory (D=0) + ! EX0 first direction cosine + ! EY0 second direction cosine + ! ANGLE track angle + ! + !--------------------------------------------------------------------- + ! + USE PRECISION_AND_KINDS, ONLY : PDB + USE SAL_TRACKING_TYPES, ONLY : NNN,NMAX2 + !** + IMPLICIT NONE + INTEGER, INTENT(IN), DIMENSION(:) :: ITRACK + REAL(PDB), INTENT(IN), DIMENSION(:) :: RTRACK + REAL(PDB), INTENT(IN) :: DELX,EX0,EY0 + REAL(PDB), INTENT(IN) :: ANGLE + !** + INTEGER :: I,KM,K,II,JSURF,JPHI,JPSI,NTRACK,NBTOT,I0 + REAL(PDB) :: ANG0 + REAL(PDB), PARAMETER :: SMALLT=1.E-10 + INTEGER, PARAMETER :: FOUT =6 + !** + ANG0=ANGLE + NTRACK=ITRACK(1) + NBTOT=ITRACK(2) + WRITE(FOUT,'(//,3X,"TRAJECTORY",/,3X,"==========", & + & //3X,"DELX = ",1P,E12.4,6X,"EX EY = ",1P,2E12.4, & + & /,3X,"WITH SMALL = ",1P,E12.4,5X,"(",1P,E12.4," DEGREES )", & + & /,3X,"ANGLE # AND WEIGHT ",I6,1P,E12.4, & + & /,3X,"NBER OF SUB-TRAJ = ",I6, & + & /,3X,"NBER OF ELEM IN TRAJ = ",I6,/)') & + DELX,EX0,EY0,SMALLT,ANG0,ITRACK(7),RTRACK(7),NBTOT,NTRACK + WRITE(FOUT,'(/,20X,"SURF",3X,"PHI",3X,"PSI",5X,"SINPHI",7X, & + & "COSPHI",/,20X,4("-"),2(3X,3("-")),5X,6("-"),7X,6("-"))') + IF(ITRACK(5)/=0)THEN + JSURF=1 + JPHI=ITRACK(5) + JPSI=JPHI + WRITE(FOUT,'(3X,A14,3I6,2X,1P,2E13.4)')'LEFT SURFACE',JSURF,JPHI,JPSI, & + RTRACK(3),RTRACK(5) + ENDIF + IF(ITRACK(6)/=0)THEN + JSURF=1 + JPHI=ITRACK(6) + JPSI=JPHI + WRITE(FOUT,'(3X,A14,3I6,2X,1P,2E13.4)')'RIGHT SURFACE',JSURF,JPHI,JPSI, & + RTRACK(4),RTRACK(6) + ENDIF + IF(NTRACK/=0)THEN + I0=NTRACK+NNN + ! print sub-trajectories information + WRITE(FOUT,'(/," SUB-TRAJECTORIES:")') + WRITE(FOUT,'(/," NBER",2X,"NBER OF ELEM",2X," ANGLE", & + &/," ----",2X,"------------",2X," -----")') + DO I=1,NBTOT + WRITE(FOUT,'(I6,"*",4X,I6,5X,I6)')I,ITRACK(I0+2*I-1),ITRACK(I0+2*I) + ENDDO + ! print trajectory + WRITE(FOUT,'(/," TRAJECTORY:",/," NBER",3(5X,"REG",2X," LENGTH",3X,"ELEM"),/, & + & 3X,"----",3(5X,"---",3X,"------",3X,"----"),1X,/)') + DO I=1,NTRACK,3 + II=I+NNN + KM=MIN(I+2,NTRACK)+NNN + WRITE(FOUT,'(1P,I6,"*",3(I7,E10.2,I7))')I, & + (ITRACK(K),RTRACK(K),ITRACK(K+NMAX2),K=II,KM) + ENDDO + ELSE + WRITE(FOUT,'(1X,"==> Track without intersections")') + ENDIF + WRITE(FOUT,'(/)') + ! + END SUBROUTINE SAL231 + ! + SUBROUTINE SAL232(ITRACK,RTRACK,FACNRM,GG,SURFN,CURRN) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! computes numerical volumes: uses local macro arrays + ! + !Parameters: input + ! ITRACK integer vectors to store trajectory information + ! RTRACK floating point vectors to store trajectory information + ! + !Parameters: input/output + ! FACNRM numerical volumes per direction + ! SURFN numerical areas + ! CURRN numerical currents + ! GG geometry basic information. + ! + !--------------------------------------------------------------------- + ! + USE SAL_GEOMETRY_TYPES, ONLY : T_G_BASIC + USE SAL_TRACKING_TYPES, ONLY : NNN + !*** + IMPLICIT NONE + INTEGER, INTENT(IN), DIMENSION(:) :: ITRACK + REAL(PDB), INTENT(IN), DIMENSION(:) :: RTRACK + REAL(PDB), INTENT(INOUT), DIMENSION(:), OPTIONAL :: SURFN,CURRN + REAL(PDB), INTENT(INOUT), DIMENSION(:,:) :: FACNRM + TYPE(T_G_BASIC) :: GG + ! DIMENSION ITRACK(*),RTRACK(*),FACNRM(NBREG,NPHI), + ! SURFN(NCURR,2),CURRN(NCURR,2) + !*** + INTEGER :: LASTI,II,I,ICURR,NPHI,IPHI,C,P + REAL :: WT,WR + !*** + ! total weight and space weight + NPHI=SIZE(FACNRM,2) + WT=REAL(RTRACK(7)) ; WR=REAL(RTRACK(8)) + LASTI=ITRACK(1) + C=0; P=LASTI+NNN; IPHI=0 + DO II=1+NNN,LASTI+NNN + IF((II-NNN)>C) THEN + C=C+ITRACK(P+1) + IPHI=ITRACK(P+2) + IF(IPHI>NPHI) IPHI=IPHI-NPHI + P=P+2 + ENDIF + I=ITRACK(II) + IF(IPHI==0) CALL XABORT('SAL232: invalid IPHI') + FACNRM(I,IPHI)=FACNRM(I,IPHI)+RTRACK(II)*WR + ENDDO + IF(GG%NB_SURF2/=0)THEN + ICURR=ITRACK(5) + IF(ICURR>0) THEN + ! left surface: convert into 2d horizontal currents: + SURFN(ICURR)=SURFN(ICURR)+WT/RTRACK(5) + CURRN(ICURR)=CURRN(ICURR)+WT + ENDIF + ICURR=ITRACK(6) + IF(ICURR>0) THEN + ! right surface: convert into 2d horizontal currents: + SURFN(ICURR)=SURFN(ICURR)+WT/RTRACK(6) + CURRN(ICURR)=CURRN(ICURR)+WT + ENDIF + ENDIF + ! + END SUBROUTINE SAL232 + ! + SUBROUTINE SAL235(NPIECE,THETA0,EX0,EY0,IPAR,RPAR,PEREXT,NPERIM) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! computes total perimeter projection on line orthogonal to + ! trajectory and with origin the center of coordinates + ! + !Parameters: input + ! THETA0 THETA- and THETA+ for this trajectory + ! EX0 first direction cosine + ! EY0 second direction cosine + ! IPAR integer element data + ! RPAR floating point element data + ! PEREXT macro perimeter + ! NPERIM number of elements in perimeter + ! + !Parameters: output + ! NPIECE number of pieces + ! + !--------------------------------------------------------------------- + ! + USE SAL_GEOMETRY_TYPES, ONLY : NIPAR,NRPAR,G_ELE_TYPE + USE SAL_TRACKING_TYPES, ONLY : DPIECE + !*** + IMPLICIT NONE + REAL(PDB), INTENT(IN) :: EX0,EY0 + REAL(PDB), INTENT(IN), DIMENSION(:) :: THETA0 + INTEGER, INTENT(OUT) :: NPIECE + INTEGER, INTENT(IN), DIMENSION(:,:) :: IPAR + REAL(PDB), INTENT(IN), DIMENSION(:,:) :: RPAR + INTEGER, INTENT(IN), DIMENSION(:) :: PEREXT + INTEGER, INTENT(IN) :: NPERIM + !*** + REAL(PDB) :: X,Y,RAD,DCENT,THETA1,THETA2,THETAM,THETA,DAUX,DMIN,DMAX + INTEGER :: L,ELEM,TYPE,IEND,ISIDE + LOGICAL :: LGONE + REAL(PDB), PARAMETER, DIMENSION(2) :: SIGNV = (/-1._PDB,1._PDB/) + INTEGER, PARAMETER :: FOUT =6 + !*** + LGONE=.TRUE. + DMIN=0._PDB; DMAX=0._PDB; + DO L=1,NPERIM + ELEM=PEREXT(L) + ! treat element + TYPE=IPAR(1,ELEM) + IF(TYPE==G_ELE_TYPE(2))THEN + ! circle: + RAD=RPAR(3,ELEM) + DCENT=RPAR(1,ELEM)*EY0-RPAR(2,ELEM)*EX0 + ! project tangents to circle + IF(LGONE)THEN + DMIN=DCENT-RAD + DMAX=DCENT+RAD + LGONE=.FALSE. + ELSE + DMIN=MIN(DMIN,DCENT-RAD) + DMAX=MAX(DMAX,DCENT+RAD) + ENDIF + ELSE + DO IEND=1,2 + CALL SAL141(TYPE,RPAR(:,ELEM),X,Y,IEND) + ! project end of element + DAUX=X*EY0-Y*EX0 + IF(LGONE)THEN + DMIN=DAUX + DMAX=DAUX + LGONE=.FALSE. + ELSEIF(DAUXDMAX)THEN + DMAX=DAUX + ENDIF + ENDDO + IF(TYPE==G_ELE_TYPE(3))THEN + ! treat tangent to arc of circles + RAD=RPAR(3,ELEM) + DCENT=RPAR(1,ELEM)*EY0-RPAR(2,ELEM)*EX0 + THETA1=RPAR(4,ELEM) + THETA2=RPAR(5,ELEM) + THETAM=THETA2-TWOPI + DO ISIDE=1,2 + THETA=THETA0(ISIDE) + IF((THETA>THETA1.AND.THETADMAX)THEN + DMAX=DAUX + ENDIF + ENDIF + ENDDO + ELSE + IF(TYPE/=G_ELE_TYPE(1)) CALL XABORT('SAL235: not implemented') + ENDIF + ENDIF + ENDDO + NPIECE=2 + DPIECE(1)=DMIN + DPIECE(2)=DMAX + ! + END SUBROUTINE SAL235 + ! + SUBROUTINE SAL237(EX0,EY0,MQ,NQ,PROJTAB,AXIS) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! computes geometry outline projections on the two symmetrical axis + ! + !Parameters: input + ! EX0,EY0 horizontal tracking angle cosines + ! MQ,NQ cyclic tracking: for a rectangular geometry, + ! the length of track is SQRT((MQ*A)**2+(NQ*B)**2) + ! where A and B are rectangular sides. + ! + !--------------------------------------------------------------------- + ! + USE PRECISION_AND_KINDS, ONLY : PDB + USE SAL_GEOMETRY_TYPES, ONLY : LENGTHX,LENGTHY,TYPGEO + USE SAL_TRACKING_TYPES, ONLY : DELR,LENGTH_INV_CYCL + !*** + IMPLICIT NONE + REAL(PDB), INTENT(IN) :: EX0,EY0 + INTEGER, INTENT(IN) :: MQ,NQ + !*** + INTEGER :: IAXIS,NPIECE,AXIS(2),IMQ + REAL(PDB) :: X1,X2,DX,DR,R1,R2,PROJTAB(6),NNQ + REAL, PARAMETER :: EPS3 = 1.0E-3 + !*** + ! minimum radial interval to contain one trajectory + IF(TYPGEO.LE.7) THEN + ! Cartesian geometry + IF(NQ>0) THEN ! angle different from 0 + X2=LENGTHX/NQ + IF(MQ>0) THEN + X1=0. + ELSE + X1=LENGTHX-X2; X2=LENGTHX + ENDIF + R1=X1*EY0; R2=X2*EY0 + NPIECE=INT((R2-R1)/DELR) + IF(NPIECE==0) NPIECE=1 + DR=(R2-R1)/NPIECE + DX=DR/EY0 + IAXIS=1 + ELSE ! angle equal to 0 + X1=LENGTHY-LENGTHY/ABS(MQ) + X2=LENGTHY + R1=X1*EX0; R2=X2*EX0 + NPIECE=INT((R2-R1)/DELR) + IF(NPIECE==0) NPIECE=1 + DR=(R2-R1)/NPIECE + DX=DR/EX0 + IF(TYPGEO.EQ.7) DX=DX*SQRT(2.0) + IAXIS=2 + ENDIF + IF(TYPGEO.EQ.7) DR=DR/2.0 + PROJTAB(:)=(/EX0,EY0,X1,X2,DX,DR/) + ! cyclical track length + IF(TYPGEO.EQ.5) THEN + ! translation + X1=LENGTHX*ABS(MQ); X2=LENGTHY*ABS(NQ) + ELSE + ! specular reflexion + X1=2.*LENGTHX*ABS(MQ); X2=2.*LENGTHY*ABS(NQ) + ENDIF + ELSE IF(TYPGEO.GE.8) THEN + ! hexagonal geometry + NNQ=(NQ-ABS(MQ))/2 + X2=3.*LENGTHX/REAL(ABS(MQ)+2*NNQ) + IF(X2<=LENGTHX+EPS3) THEN + IAXIS=1 + IF(MQ>0) THEN + X1=0. + ELSE + X1=LENGTHX-X2; X2=LENGTHX + ENDIF + ELSE + X1=0. + IF((TYPGEO==8).OR.(TYPGEO==10).OR.(TYPGEO==12)) THEN + ! MQ must be positive + IAXIS=2 + X2=3.*LENGTHX/(MQ-NNQ) + ELSE + IF(MQ>0) THEN + IAXIS=2 + X2=3.*LENGTHX/(2*MQ+NNQ) + ELSE + IAXIS=6 + X2=3.*LENGTHX/(2*ABS(MQ)+NNQ) + ENDIF + ENDIF + ENDIF + R1=X1*EY0; R2=X2*EY0 + NPIECE=INT((R2-R1)/DELR) + IF(NPIECE==0) NPIECE=1 + DR=(R2-R1)/NPIECE + DX=DR/EY0 + ! empirical correction of track weight in hexagonal cases (don't ask why) + IF(TYPGEO==8) THEN + IMQ=ABS(MQ) + IF(((IMQ==1).AND.(NQ==15)).OR.((IMQ==7).AND.(NQ==9)).OR.((IMQ==8).AND.(NQ==6))) THEN + DR=DR/3.0 + ELSE IF(((IMQ==1).AND.(NQ==9)).OR.((IMQ==4).AND.(NQ==6)).OR.((IMQ==5).AND.(NQ==3))) THEN + DR=DR/3.0 + ELSE IF(((IMQ==1).AND.(NQ==7)).OR.((IMQ==3).AND.(NQ==5)).OR.((IMQ==4).AND.(NQ==2))) THEN + DR=DR*5.0/12.0 + ELSE IF(((IMQ==1).AND.(NQ==5)).OR.((IMQ==2).AND.(NQ==4)).OR.((IMQ==3).AND.(NQ==1))) THEN + DR=DR*4.0/9.0 + ELSE IF(((IMQ==2).AND.(NQ==8)).OR.((IMQ==3).AND.(NQ==7)).OR.((IMQ==5).AND.(NQ==1))) THEN + DR=DR*7.0/15.0 + ELSE IF(((IMQ==4).AND.(NQ==14)).OR.((IMQ==5).AND.(NQ==13)).OR.((IMQ==9).AND.(NQ==1))) THEN + DR=13.0*DR/27.0 + ENDIF + ELSE IF(TYPGEO==9) THEN + IF(ABS(MQ)/NQ > 1) DR=(0.5+1.5*ABS(MQ)/NQ)*DR + ELSE IF(TYPGEO==10) THEN + IMQ=ABS(MQ) + IF(((IMQ==1).AND.(NQ==15)).OR.((IMQ==8).AND.(NQ==6))) THEN + DR=0.25*DR + ELSE IF(((IMQ==1).AND.(NQ==9)).OR.((IMQ==5).AND.(NQ==3))) THEN + DR=0.25*DR + ELSE IF(((IMQ==1).AND.(NQ==7)).OR.((IMQ==4).AND.(NQ==2))) THEN + DR=DR*5.0/14.0 + ELSE IF(((IMQ==1).AND.(NQ==5)).OR.((IMQ==3).AND.(NQ==1))) THEN + DR=DR*2.0/5.0 + ELSE IF(((IMQ==2).AND.(NQ==8)).OR.((IMQ==5).AND.(NQ==1))) THEN + DR=DR*7.0/16.0 + ELSE IF(((IMQ==4).AND.(NQ==14)).OR.((IMQ==9).AND.(NQ==1))) THEN + DR=13.0*DR/28.0 + ELSE + DR=0.5*DR + ENDIF + ELSE IF(TYPGEO==11) THEN + IMQ=ABS(MQ) + IF(((IMQ==1).AND.(NQ==15)).OR.((IMQ==8).AND.(NQ==6))) THEN + DR=0.5*DR + ELSE IF(((IMQ==1).AND.(NQ==9)).OR.((IMQ==5).AND.(NQ==3))) THEN + DR=0.5*DR + ELSE IF(((IMQ==1).AND.(NQ==7)).OR.((IMQ==4).AND.(NQ==2))) THEN + DR=0.7742663247*DR + ELSE IF(((IMQ==1).AND.(NQ==5)).OR.((IMQ==3).AND.(NQ==1))) THEN + DR=0.8257638060*DR + ELSE IF(((IMQ==2).AND.(NQ==8)).OR.((IMQ==5).AND.(NQ==1))) THEN + DR=0.8863607851*DR + ELSE IF(((IMQ==4).AND.(NQ==14)).OR.((IMQ==9).AND.(NQ==1))) THEN + DR=0.9327596923*DR + ENDIF + ELSE IF(TYPGEO==12) THEN + IMQ=ABS(MQ) + IF(((IMQ==1).AND.(NQ==15)).OR.((IMQ==7).AND.(NQ==9)).OR.((IMQ==8).AND.(NQ==6))) THEN + DR=DR/6.0 + ELSE IF(((IMQ==1).AND.(NQ==9)).OR.((IMQ==4).AND.(NQ==6)).OR.((IMQ==5).AND.(NQ==3))) THEN + DR=DR/6.0 + ELSE IF(((IMQ==1).AND.(NQ==7)).OR.((IMQ==3).AND.(NQ==5)).OR.((IMQ==4).AND.(NQ==2))) THEN + DR=DR*5.0/24.0 + ELSE IF(((IMQ==1).AND.(NQ==5)).OR.((IMQ==2).AND.(NQ==4)).OR.((IMQ==3).AND.(NQ==1))) THEN + DR=DR*2.0/9.0 + ELSE IF(((IMQ==2).AND.(NQ==8)).OR.((IMQ==3).AND.(NQ==7)).OR.((IMQ==5).AND.(NQ==1))) THEN + DR=0.232645602188*DR + ELSE IF(((IMQ==4).AND.(NQ==14)).OR.((IMQ==5).AND.(NQ==13)).OR.((IMQ==9).AND.(NQ==1))) THEN + DR=13.0*DR/54.0 + ENDIF + ENDIF + PROJTAB(:)=(/EX0,EY0,X1,X2,DX,DR/) + ! cyclical track length + X1=LENGTHX*ABS(MQ)*1.5D0; X2=LENGTHX*(2*NNQ+ABS(MQ))*SQRT(3.D0)/2.D0 + ENDIF + AXIS(:)=(/NPIECE,IAXIS/) + LENGTH_INV_CYCL=1./SQRT(X1*X1+X2*X2) + END SUBROUTINE SAL237 + ! + SUBROUTINE SAL220_1(ANGLE) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! computes unit vectors for the two rotative axis + ! + !Parameters: input + ! ANGLE angle between the two rotative axis + ! + !--------------------------------------------------------------------- + ! + USE PRECISION_AND_KINDS, ONLY : PDB + USE SAL_GEOMETRY_TYPES, ONLY : LENGTHX,LENGTHY,TYPGEO + USE SAL_TRACKING_TYPES, ONLY : HX,HY,BX,BY + !**** + IMPLICIT NONE + REAL(PDB), INTENT(IN) :: ANGLE + !**** + ! unit vector for the axis 1: + HX(1)=1.; HY(1)=0. + ! unit vector for the axis 2: + HX(2)=COS(ANGLE); HY(2)=SIN(ANGLE) + BX(:)=0.; BY(:)=0. + IF((TYPGEO.EQ.5).OR.(TYPGEO.EQ.6)) THEN + HX(3:4)=HX(1:2); HY(3:4)=HY(1:2) + BX(4)=LENGTHX + BY(3)=LENGTHY + ELSE IF(TYPGEO.EQ.7) THEN + HX(3)=0.; HY(3)=1. + BX(3)=LENGTHX + ELSE IF((TYPGEO.EQ.8).OR.(TYPGEO.EQ.10)) THEN + HX(3)=COS(ANGLE*2.); HY(3)=SIN(ANGLE*2.) + BX(3)=LENGTHX + ELSE IF(TYPGEO.EQ.9) THEN + HX(1)=1.; HY(1)=0.; BX(1)=-LENGTHX*0.5; BY(1)=-LENGTHY + HX(4)=1.; HY(4)=0.; BX(4)=-LENGTHX*0.5; BY(4)=LENGTHY + HX(2)=COS(ANGLE*2.); HY(2)=SIN(ANGLE*2.); BX(2)=BX(1); BY(2)=BY(1) + HX(5)=HX(2); HY(5)=HY(2); BX(5)=LENGTHX; BY(5)=0. + HX(3)=COS(ANGLE); HY(3)=SIN(ANGLE); BX(3)=-LENGTHX; BY(3)=0. + HX(6)=HX(3); HY(6)=HY(3); BX(6)=LENGTHX*0.5; BY(6)=-LENGTHY + ELSE IF(TYPGEO.EQ.11) THEN + BX(3)=LENGTHX*0.5; BY(3)=LENGTHY + HX(3)=1.; HY(3)=0. + BX(4)=LENGTHX + HX(4)=COS(ANGLE); HY(4)=SIN(ANGLE) + ELSE IF(TYPGEO.EQ.12) THEN + HX(3)=COS(PI/2.0+ANGLE); HY(3)=SIN(PI/2.0+ANGLE) + BX(3)=LENGTHX + ENDIF + ! + END SUBROUTINE SAL220_1 +END MODULE SAL_AUX_MOD diff --git a/Dragon/src/SAL_GEOMETRY_MOD.f90 b/Dragon/src/SAL_GEOMETRY_MOD.f90 new file mode 100644 index 0000000..373c95d --- /dev/null +++ b/Dragon/src/SAL_GEOMETRY_MOD.f90 @@ -0,0 +1,3756 @@ +! +!--------------------------------------------------------------------- +! +!Purpose: +! Support module used to create a 2D geometry. +! +!Copyright: +! Copyright (C) 2001 Ecole Polytechnique de Montreal. +! +!Author(s): +! X. Warin +! +!--------------------------------------------------------------------- +! +MODULE SAL_GEOMETRY_MOD + + USE SAL_GEOMETRY_TYPES + USE PRECISION_AND_KINDS, ONLY : PDB, PI,TWOPI,HALFPI + USE SAL_NUMERIC_MOD, ONLY : SAL141 + USE SALGET_FUNS_MOD + +CONTAINS + + SUBROUTINE SAL100(GG) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! perform input data and first allocation for geometry OBJECT T_G_BASIC + ! + !Parameters: input/output + ! GG geometry basic information. + ! + !--------------------------------------------------------------------- + ! + USE SAL_GEOMETRY_TYPES, ONLY : T_G_BASIC,TYPGEO,NBFOLD,EPS,ANGGEO, & + INDEX,KNDEX,PREC,ISPEC,LGSPEC + USE SAL_TRACKING_TYPES, ONLY : PRTIND + IMPLICIT NONE + TYPE(T_G_BASIC) :: GG + !***** + ! local variable + ! ************** + INTEGER, PARAMETER :: N_DATAIN=25, N_DATARE=20 + INTEGER, DIMENSION (N_DATAIN) :: DATAIN + REAL, DIMENSION (N_DATARE) :: DATARE + INTEGER :: OK + INTEGER, PARAMETER :: FOUT =6 + !***** + ! TYPGEO = type of geometry: + ! NBFOLD = n in angle definition of rotation or symmetry geometry + ! NB_NODE = number of nodes + ! NBELEM = number of elements + ! + CALL SALGET(DATAIN,6,F_GEO,FOUT0,'dimensions for geometry') + TYPGEO=DATAIN(1) + NBFOLD=DATAIN(2) + GG%NB_NODE=DATAIN(3) + GG%NB_ELEM=DATAIN(4) + GG%NB_MACRO=DATAIN(5) + GG%NB_FLUX=DATAIN(6) + ANGGEO=0.0D0 + SELECT CASE(TYPGEO) + CASE(1) + IF(NBFOLD.EQ.3) THEN + ANGGEO=TWOPI/8.0D0 ! half diagonal symmetry case + ELSE + ANGGEO=TWOPI/NBFOLD + ENDIF + CASE(2) + ANGGEO=TWOPI/NBFOLD + CASE(5:6) + ANGGEO=HALFPI + CASE(7) + ANGGEO=PI*0.25 + CASE(8:11) + ANGGEO=PI/3. + CASE(12) + ANGGEO=PI/6. + END SELECT + IF((PRTIND >= 1).AND.(TYPGEO.EQ.0)) THEN + WRITE(FOUT,*) 'SAL100: TYPGEO=',TYPGEO,' NBFOLD=',NBFOLD + ELSE IF(PRTIND >= 1) THEN + WRITE(FOUT,*) 'SAL100: TYPGEO=',TYPGEO,' NBFOLD=',NBFOLD, & + & ' ANGGEO=',ANGGEO,' radians' + ENDIF + LGSPEC=(TYPGEO/=0).AND.(NBFOLD==0) + IF(LGSPEC) THEN + IF(ISPEC==0) THEN + WRITE(*,*) 'SAL100: TYPGEO=',TYPGEO,' NBFOLD=',NBFOLD + CALL XABORT('SAL100: TISO option is incompatible with the surfacic file') + ENDIF + ELSE + IF(ISPEC==1) THEN + WRITE(*,*) 'SAL100: TYPGEO=',TYPGEO,' NBFOLD=',NBFOLD + CALL XABORT('SAL100: TSPC option is incompatible with the surfacic file') + ENDIF + ENDIF + ! + !* read printing indexes for general domain data and topological deformations + ! INDEX = to print general domain data + ! KNDEX = to print motions of topological adjustment + ! PREC = if 0 then read RPAR & BCDATA with e20.12) + CALL SALGET(DATAIN,3,F_GEO,FOUT0,'index kndex prec') + INDEX=DATAIN(1) + KNDEX=DATAIN(2) + PREC=DATAIN(3) + ! + !* read epsilons for topological deformations + ! EPS = if the distance of two ends of elements < eps, + ! they will be united to one point + CALL SALGET(DATARE,1,F_GEO,FOUT0,'eps') + EPS=DATARE(1) + ! + IF(PRTIND >= 1) THEN + WRITE(FOUT,'(//,5X,''domain checkout:'',/, & + & 5X,''elements are in contact for distance < '',1P,E12.4,//)') EPS + ENDIF + ! + ALLOCATE(GG%NUM_MERGE(GG%NB_NODE),STAT =OK) + IF(OK /= 0) CALL XABORT('SAL100: failure to allocate NB_NODE') + CALL SALGET(GG%NUM_MERGE,GG%NB_NODE,F_GEO,FOUT0,'FLUX INDEX PER NODE') + IF(MAXVAL(GG%NUM_MERGE) /= GG%NB_FLUX) CALL XABORT('SAL100: inconsistent NBFLUX') + ALLOCATE(GG%NAME_MACRO(GG%NB_MACRO),STAT =OK) + IF(OK /= 0) CALL XABORT('SAL100: failure to allocate NB_MACRO') + CALL SALGET(GG%NAME_MACRO,GG%NB_MACRO,F_GEO,FOUT0,'NAMES OF MACROS') + ALLOCATE(GG%NUM_MACRO(GG%NB_FLUX)) + CALL SALGET(GG%NUM_MACRO,GG%NB_FLUX,F_GEO,FOUT0,'macro order number per flux region') + !* do the work (SAL100_2 is called here!): + CALL SAL110(GG) + ! + END SUBROUTINE SAL100 + ! + SUBROUTINE SAL110(GG) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! constructs geometrical domain + ! + !Parameters: input/output + ! GG geometry basic information. + ! + !--------------------------------------------------------------------- + ! + USE SAL_GEOMETRY_TYPES, ONLY : TYPGEO,NBFOLD,NIPAR,NRPAR,ALLSUR,NANIS,IC,ISPEC,ANGGEO + USE SAL_TRACKING_TYPES, ONLY : PRTIND + !**** + IMPLICIT NONE + ! in variable + ! ************ + TYPE(T_G_BASIC), INTENT(INOUT) :: GG + + ! local variable + ! *************** + INTEGER :: ELEM,OK,I,TYPE + CHARACTER(LEN=4) :: HSYM + REAL(PDB),PARAMETER :: CONV=PI/180._PDB + INTEGER, PARAMETER :: FOUT =6 + !**** + ! allocate node arrays + HSYM=' ' + IF((TYPGEO==0).OR.((TYPGEO==6).AND.(NBFOLD==0))) THEN + CONTINUE + ELSE IF((TYPGEO==1).AND.(NBFOLD==3)) THEN + HSYM='QUAR' + ELSE IF(((TYPGEO==1).AND.(NBFOLD==8)).OR.((TYPGEO==7).AND.(NBFOLD==0))) THEN + HSYM='EIGH' + ELSE IF(((TYPGEO==1).AND.(NBFOLD==6)).OR.((TYPGEO==8).AND.(NBFOLD==0))) THEN + HSYM='SIXT' + ELSE IF(((TYPGEO==1).AND.(NBFOLD==12)).OR.((TYPGEO==12).AND.(NBFOLD==0))) THEN + HSYM='S30' + ELSE IF(((TYPGEO==1).AND.(NBFOLD==4)).OR.((TYPGEO==3).AND.(NBFOLD==0))) THEN + HSYM='SYME' + ELSE IF((TYPGEO==1).AND.(NBFOLD==2)) THEN + HSYM='SY1D' + ELSE IF(((TYPGEO==2).AND.(NBFOLD==6)).OR.((TYPGEO==10).AND.(NBFOLD==0))) THEN + HSYM='RA60' + ELSE IF((TYPGEO==5).AND.(NBFOLD==0)) THEN + HSYM='TRAN' + ELSE IF((TYPGEO==9).AND.(NBFOLD==0)) THEN + HSYM='TRAN' + ELSE IF(((TYPGEO==2).AND.(NBFOLD==3)).OR.(TYPGEO==11).AND.(NBFOLD==0)) THEN + HSYM='R120' + ELSE + WRITE(*,*) "TYPGEO=",TYPGEO," NBFOLD=",NBFOLD + CALL XABORT('SAL110: non supported type of symmetry') + ENDIF + ALLOCATE (GG%IPAR(NIPAR,GG%NB_ELEM), GG%RPAR(NRPAR,GG%NB_ELEM), STAT=OK) + IF(OK/=0) CALL XABORT('SAL110: not enough memory I,R') + + !* read surfacic file + CALL SALINP(GG) + ! + !* unite the ends of elements, redefine elements + CALL SAL128(GG%RPAR,GG%IPAR,GG%NB_ELEM) + ! + IF((ISPEC==0).AND.(IC.EQ.4)) THEN + !* unfold domain + IF(HSYM=='QUAR') THEN + IF(PRTIND>0) WRITE(*,*) "SAL110: DIAG unfold" + IF(NANIS>1) CALL XABORT('SAL110: unfold unsupported with NANIS>1') + ANGGEO=2.0*ANGGEO + CALL SALFOLD_1('DIAG',GG) + ELSE IF(HSYM=='EIGH') THEN + IF(PRTIND>0) WRITE(*,*) "SAL110: DIAG + SYME unfold" + IF(NANIS>1) CALL XABORT('SAL110: unfold unsupported with NANIS>1') + ANGGEO=2.0*ANGGEO + CALL SALFOLD_1('DIAG',GG) + CALL SALFOLD_1('SYMX',GG) + CALL SALFOLD_1('SYMY',GG) + ELSE IF(HSYM=='SYME') THEN + IF(PRTIND>0) WRITE(*,*) "SAL110: SYME unfold" + IF(NANIS>1) CALL XABORT('SAL110: unfold unsupported with NANIS>1') + CALL SALFOLD_1('SYMX',GG) + CALL SALFOLD_1('SYMY',GG) + ELSE IF(HSYM=='SY1D') THEN + IF(PRTIND>0) WRITE(*,*) "SAL110: SY1D unfold" + IF(NANIS>1) CALL XABORT('SAL110: unfold unsupported with NANIS>1') + CALL SALFOLD_1('SYMX',GG) + ELSE IF(HSYM=='SIXT') THEN + IF(PRTIND>0) WRITE(*,*) "SAL110: SA60 unfold" + IF(NANIS>1) CALL XABORT('SAL110: unfold unsupported with NANIS>1') + CALL SALFOLD_1('SA60',GG) + CALL SALFOLD_1('SYMH',GG) + ELSE IF(HSYM=='S30') THEN + IF(PRTIND>0) WRITE(*,*) "SAL110: S30 unfold" + IF(NANIS>1) CALL XABORT('SAL110: unfold unsupported with NANIS>1') + CALL SALFOLD_1('S30 ',GG) + CALL SALFOLD_1('SB60',GG) + CALL SALFOLD_1('SYMX',GG) + ELSE IF(HSYM=='RA60') THEN + IF(PRTIND>0) WRITE(*,*) "SAL110: SR60 unfold with rotation" + IF(NANIS>1) CALL XABORT('SAL110: unfold unsupported with NANIS>1') + CALL SALFOLD_2('SR60',GG) + CALL SALFOLD_2('R180',GG) + ELSE IF(HSYM=='R120') THEN + IF(PRTIND>0) WRITE(*,*) "SAL110: SR120 unfold with rotation" + IF(NANIS>1) CALL XABORT('SAL110: unfold unsupported with NANIS>1') + CALL SALFOLD_2('R120',GG) + ELSE + IF(PRTIND>0) WRITE(*,*) "SAL110: no unfold" + ENDIF + IF((TYPGEO/=0).AND.(NBFOLD==0)) THEN + TYPGEO=6 + ELSE + TYPGEO=0; NBFOLD=0 + ENDIF + ENDIF + IF(PRTIND>0) WRITE(FOUT,*) 'SAL110: after unfolding -- NB_ELEM=',GG%NB_ELEM, & + & ' NB_PERIM=',GG%NBBCDA + + IF(PRTIND>5) THEN + !* print surfacic file + WRITE(FOUT,'(5H--cut,75(1H-))') + WRITE(FOUT,'(5HBEGIN)') + WRITE(FOUT,'(42H* typgeo nbfold nbnode nbelem nbmacr nbreg)') + WRITE(FOUT,'(6I7)') TYPGEO,NBFOLD,GG%NB_NODE,GG%NB_ELEM,GG%NB_MACRO,GG%NB_NODE + WRITE(FOUT,'(20H* index kndex prec)') + WRITE(FOUT,'(4I7)') 0,0,1 + WRITE(FOUT,'(18H* eps eps0)') + WRITE(FOUT,'(1P,2E18.9)') 1.0E-03,1.0E-05 + WRITE(FOUT,'(20H* num_of_region/mesh)') + WRITE(FOUT,'(10I7)') (GG%NUM_MERGE(I),I=1,GG%NB_NODE) + WRITE(FOUT,'(13H* macro names)') + WRITE(FOUT,'(4(3x,a10,2x))') (GG%NAME_MACRO(I),I=1,GG%NB_MACRO) + WRITE(FOUT,'(35H* macro_order_index_per_flux_region)') + WRITE(FOUT,'(10I7)') (GG%NUM_MACRO(I),I=1,GG%NB_FLUX) + DO ELEM=1,GG%NB_ELEM + TYPE=GG%IPAR(1,ELEM) + WRITE(FOUT,'(7h elem =,I6)') ELEM + WRITE(FOUT,'(22H*type node- node+)') + WRITE(FOUT,'(3I6)') (GG%IPAR(I,ELEM),I=1,3) + WRITE(FOUT,'(63H*cx cy ex_or_R ey_or_theta1 theta2)') + IF(TYPE<=2) THEN + WRITE(FOUT,'(1P,5E18.9)') (GG%RPAR(I,ELEM),I=1,5) + ELSE IF(TYPE==3) THEN + WRITE(FOUT,'(1P,5E18.9)') (GG%RPAR(I,ELEM),I=1,3),GG%RPAR(4,ELEM)/CONV, & + (GG%RPAR(5,ELEM)-GG%RPAR(4,ELEM))/CONV + ENDIF + ENDDO + WRITE(FOUT,'(40H*defaul nbbcda allsur divsur ndivsur)') + WRITE(FOUT,'(1P,5I8)') GG%DEFAUL,GG%NBBCDA,ALLSUR,0,0 + WRITE(FOUT,'(17H*albedo deltasur)') + WRITE(FOUT,'(1P,2E18.9)') GG%ALBEDO,0.0 + DO ELEM=1,GG%NBBCDA + WRITE(FOUT,'(37H particular boundary condition number,i12)') ELEM + WRITE(FOUT,'(13H*type nber)') + WRITE(FOUT,'(1P,2I8)') GG%BCDATAREAD(ELEM)%SALTYPE,GG%BCDATAREAD(ELEM)%NBER + WRITE(FOUT,'(14H*elems(1,nber))') + WRITE(FOUT,'(1P,10I8)') (GG%BCDATAREAD(ELEM)%ELEMNB(I),I=1,GG%BCDATAREAD(ELEM)%NBER) + IF(GG%BCDATAREAD(ELEM)%SALTYPE==0) THEN + WRITE(FOUT,'(7H*albedo)') + WRITE(FOUT,'(1P,E18.9)') GG%BCDATAREAD(ELEM)%BCDATA(6) + ELSE + WRITE(FOUT,'(22H*cx cy angle)') + WRITE(FOUT,'(1P,3E18.9)') GG%BCDATAREAD(ELEM)%BCDATA(1:2),GG%BCDATAREAD(ELEM)%BCDATA(5)*180._PDB/PI + ENDIF + ENDDO + ENDIF + + ! allocate media and element arrays + ALLOCATE (GG%VOL_NODE(GG%NB_NODE),GG%PPERIM_NODE(GG%NB_NODE+1),GG%IBC2_ELEM(GG%NB_ELEM), & + GG%ISURF2_ELEM(GG%NB_ELEM),GG%MED(GG%NB_NODE), STAT=OK) + IF(OK/=0) CALL XABORT('SAL110: not enough memory VOL') + GG%ISURF2_ELEM(:GG%NB_ELEM)=0 + + !* 2D boundary conditions and macro contacts: + ! - defines NB_BC2, NBSUR2 + ! - defines surface strctures for each 2D macro + ! - defines perimeter structure for each 2D macro + ! - read 2D boundary conditions + CALL SAL130(GG) + ! + !* topological check + CALL SAL140(GG%NB_NODE,GG%RPAR,GG%IPAR,GG%PPERIM_NODE,GG%PERIM_NODE) + ! + !* volumes, surfaces, put local nbers in node, and read media: + CALL SAL160(GG) + IF(PRTIND>5) THEN + WRITE(FOUT,'(12H* mil(nbreg))') + WRITE(FOUT,'(10I7)') (GG%MED(I),I=1,GG%NB_NODE) + WRITE(FOUT,'(3HEND)') + WRITE(FOUT,'(5H--cut,75(1H-))') + ENDIF + ! + !* printout basic domain + CALL SAL170(GG) + ! + END SUBROUTINE SAL110 + ! + SUBROUTINE SALINP(GG) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! read surfacic file + ! + !Parameters: input/output + ! GG geometry descriptor + ! + !--------------------------------------------------------------------- + ! + USE SAL_GEOMETRY_TYPES, ONLY : ALLSUR,PREC + !**** + IMPLICIT NONE + ! in variable + ! ************ + TYPE(T_G_BASIC), INTENT(INOUT) :: GG + !**** + INTEGER, PARAMETER :: N_DATAIN=25 + INTEGER, DIMENSION (N_DATAIN) :: DATAIN + INTEGER :: ELEM,I,TYPE,NBER + INTEGER, PARAMETER, DIMENSION(0:4) :: READ_BC_LEN=(/1,1,3,3,3/) + INTEGER, PARAMETER :: FOUT =6 + REAL(PDB) :: ANGLE,BCDATA_TDT(3) + ! + !* read element data + DO ELEM=1,GG%NB_ELEM + CALL SAL126(GG%RPAR(:,ELEM),GG%IPAR(:,ELEM)) + ENDDO + !* read + ! DEFAUL = default bc condition + ! 0 = all external surfaces are isotropically reflected + ! with the same ALBEDO = ALBED0 + ! 1 = all external surfaces are reflected + ! NBBCDA = number of groups of bc conditions + ! + CALL SALGET(DATAIN,3,F_GEO,FOUT0,'general bc data') + GG%DEFAUL=DATAIN(1) + GG%NBBCDA=DATAIN(2) + ALLSUR=DATAIN(3) + ! we can define only two default bc's + IF(GG%DEFAUL>4.OR.GG%DEFAUL<0) THEN + WRITE(FOUT,'(8H defaul=,I5)') GG%DEFAUL + CALL XABORT('SALINP: wrong default bc type') + ENDIF + !* read albedo : defaul bcdata + CALL SALGET(GG%ALBEDO,F_GEO,FOUT0,PREC,'GENERAL ALBEDO') + ! + !* read detailed bcdata if required (motions) + LBCDIAG=.FALSE. + IF(GG%NBBCDA>0)THEN + ALLOCATE(GG%BCDATAREAD(GG%NBBCDA)) + DO I=1,GG%NBBCDA + GG%BCDATAREAD(I)%BCDATA(:6)=0.0 + CALL SALGET(DATAIN,2,F_GEO,FOUT0,'SPECIFIC BC: TYPE NBER') + TYPE=DATAIN(1) + NBER=DATAIN(2) + GG%BCDATAREAD(I)%SALTYPE=TYPE + GG%BCDATAREAD(I)%NBER=NBER + IF(TYPE>5.OR.TYPE<0) CALL XABORT('SALINP: wrong bc type') + IF(NBER>GG%NB_ELEM) CALL XABORT('SALINP: bc def exceeds nber of elements') + ! + ! read order numbers of elements affected + ALLOCATE(GG%BCDATAREAD(I)%ELEMNB(NBER)) + CALL SALGET(GG%BCDATAREAD(I)%ELEMNB,NBER,F_GEO,FOUT0,'BC ELEMENTS') + ! read bc motion + CALL SALGET(BCDATA_TDT,READ_BC_LEN(TYPE),F_GEO,FOUT0,PREC,'data for specific bc condition') + IF(READ_BC_LEN(TYPE).EQ.1) THEN + GG%BCDATAREAD(I)%BCDATA(1:5)=0._PDB + GG%BCDATAREAD(I)%BCDATA(6)=BCDATA_TDT(1) + ELSE + GG%BCDATAREAD(I)%BCDATA(1:2)=BCDATA_TDT(1:2) + ANGLE=BCDATA_TDT(3)*PI/180._PDB + GG%BCDATAREAD(I)%BCDATA(3)=COS(ANGLE) + GG%BCDATAREAD(I)%BCDATA(4)=SIN(ANGLE) + GG%BCDATAREAD(I)%BCDATA(5)=ANGLE + GG%BCDATAREAD(I)%BCDATA(6)=1._PDB + LBCDIAG=LBCDIAG.OR.((GG%BCDATAREAD(I)%BCDATA(1)==0._PDB).AND.(GG%BCDATAREAD(I)%BCDATA(2)==0._PDB) & + .AND.(GG%BCDATAREAD(I)%BCDATA(5)==PI/4._PDB)) + ENDIF + ENDDO + ENDIF + END SUBROUTINE SALINP + ! + SUBROUTINE SAL126(RPAR,IPAR) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! reads one element data + ! + !Parameters: input/output + ! RPAR floating point geometry descriptors + ! IPAR integer geometry descriptors + ! + !--------------------------------------------------------------------- + ! + !**** + USE SAL_GEOMETRY_TYPES, ONLY : PREC,G_ELE_TYPE + !**** + IMPLICIT NONE + ! in variable + INTEGER, INTENT(OUT), DIMENSION(:) :: IPAR + REAL(PDB), INTENT(INOUT), DIMENSION(:) :: RPAR + !**** + ! local variable + INTEGER :: TYPE,NBER,IAUX + REAL(PDB) :: PHI1,PHI2,ANGMAX,DELPHI + !**** + ! IPAR(1) = 1 (segment), 2 (circle), 3(arc of circle) + ! IPAR(2) = order nber of node in - side + ! IPAR(3) = order nber of node in + side + ! + !* read integer element data + CALL SALGET(IPAR,3,F_GEO,FOUT0,'integer descriptors') + TYPE=IPAR(1) + ! + ! ** segment: + ! R = C+T*F with T in (0,1) + ! RPAR(1~5) = CX CY FX FY F + ! + ! ** arc of circle: + ! R = C+R*F(THETA) with + ! THETA in (THETA1 < THETA2) + ! with THETA1 in (0,360) + ! RPAR(1~5) = CX CY R THETA1 THETA2 (in degrees) + ! + !* read real element data + + IF(TYPE == G_ELE_TYPE(1)) THEN + NBER=4 + ELSE IF(TYPE == G_ELE_TYPE(2)) THEN + NBER=3 + ELSE IF(TYPE == G_ELE_TYPE(3)) THEN + NBER=5 + ANGMAX=360._PDB + ELSE + WRITE(FOUT0,'(1X,''==> SAL126: unknown type '',I3)') TYPE + CALL XABORT('SAL126: unknown element type') + ENDIF + + CALL SALGET(RPAR,NBER,F_GEO,FOUT0,PREC,'real descriptors') + + IF(TYPE == G_ELE_TYPE(1)) THEN + ! segment: compute length + RPAR(5)=SQRT(RPAR(3)*RPAR(3)+RPAR(4)*RPAR(4)) + RPAR(6)=0._PDB + ELSE IF(TYPE == G_ELE_TYPE(2)) THEN + ! full circle: set angles + RPAR(4)=0._PDB + RPAR(5)=TWOPI + RPAR(6)=0._PDB + ELSE IF((TYPE == G_ELE_TYPE(3)).OR.(TYPE == G_ELE_TYPE(4))) THEN + ! check angles + PHI1=RPAR(NBER-1) + DELPHI=RPAR(NBER) + ! order angles in increasing values: + IF(DELPHI>0._PDB)THEN + IF(DELPHI>ANGMAX)THEN + WRITE(FOUT0,'(1X,''==> SAL126: DELPHI = '',1P,E12.4, & + &'' > '',1P,E12.4,'' FOR TYPE'',I3)')DELPHI,ANGMAX,TYPE + CALL XABORT('SAL126: invalid value of delphi') + ENDIF + PHI2=PHI1+DELPHI + ELSE + IF(DELPHI<-ANGMAX)THEN + WRITE(FOUT0,'(1X,''==> SAL126: DELPHI = '',1P,E12.4, & + &'' < '',1P,E12.4,'' FOR TYPE'',I3)')DELPHI,-ANGMAX,TYPE + CALL XABORT('SAL126: invalid value of delphi') + ENDIF + PHI2=PHI1 + PHI1=PHI1+DELPHI + ENDIF + IF(TYPE==G_ELE_TYPE(3))THEN + ! arc of circle: put phi1 within 0 and 360. + IF(PHI1>360._PDB)THEN + IAUX=INT(PHI1/360._PDB) + DELPHI=360._PDB*IAUX + PHI2=PHI2-DELPHI + PHI1=PHI1-DELPHI + ELSEIF(PHI1<0._PDB)THEN + IAUX=INT((-PHI1+1.D-7)/360._PDB)+1 + DELPHI=360._PDB*IAUX + PHI2=PHI2+DELPHI + PHI1=PHI1+DELPHI + ENDIF + RPAR(6)=0._PDB + ELSE + CALL XABORT('SAL126: unsupported option') + ENDIF + ! convert to radians + RPAR(NBER-1)=PHI1*(TWOPI/360._PDB) + RPAR(NBER)=PHI2*(TWOPI/360._PDB) + ENDIF + ! + END SUBROUTINE SAL126 + ! + SUBROUTINE SAL128(RPAR,IPAR,NB_ELEM) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! create library of ends of elements and redefine element discriptors + ! + !Parameters: input/output + ! RPAR floating point geometry descriptors + ! IPAR integer geometry descriptors + ! NB_ELEM number of surfacic elements + ! + !--------------------------------------------------------------------- + ! + !**** + USE SAL_GEOMETRY_TYPES, ONLY : G_ELE_TYPE,EPS,KNDEX,TYPGEO + ! in variable + !************ + IMPLICIT NONE + INTEGER, INTENT(IN), DIMENSION(:,:) :: IPAR + REAL(PDB), INTENT(INOUT), DIMENSION(:,:) :: RPAR + INTEGER , INTENT(IN) :: NB_ELEM + ! local variable + ! *************** + REAL(PDB), DIMENSION (:,:), ALLOCATABLE :: POINT ! coordinates of the ends of elements + INTEGER, DIMENSION (:,:), ALLOCATABLE :: ELEM_NEW ! point nbers of two ends of elements + !**** + ! NN = total number of points + ! NBP = count of number of ends having the same coordinates + INTEGER :: TYPE,NN,ELEM,I,P,POS,I1,I2,OK + REAL(PDB) :: X(2),Y(2),D,DX,DY + REAL :: EPS2 + LOGICAL :: LGONE + INTEGER, DIMENSION(NB_ELEM) :: NBP + INTEGER, PARAMETER :: FOUT =6 + !**** + ! - POINT(2,NB_ELEM) = coordinates of the ends of elements + ! - ELEM_NEW(2,NB_ELEM) = point nbers of two ends of elements + ! + ALLOCATE(POINT(2,NB_ELEM),ELEM_NEW(2,NB_ELEM),STAT=OK) + IF(OK/=0) CALL XABORT('SAL100_3_1: not enough memory I,CH') + + EPS2=EPS*EPS + IF(KNDEX/=0)WRITE(FOUT,'(//,& + &" reunite the ends of elements of distance less than ",E13.4)') EPS + ! + !* nn counts the nber of points + NBP(1:NB_ELEM)=0 + NN=0 + DO ELEM=1,NB_ELEM + TYPE=IPAR(1,ELEM) + IF(TYPE/=G_ELE_TYPE(2)) THEN + DO I=1,2 + ! get coordinates of end + CALL SAL141(TYPE,RPAR(:,ELEM),X(I),Y(I),I) + ! find if there is a defined neighbouring point + LGONE=.FALSE. + DO P=1,NN + DX=POINT(1,P)-X(I) + DY=POINT(2,P)-Y(I) + D=DX*DX+DY*DY + IF(D NB_ELEM) CALL XABORT('SAL128: point overflow') + POS=NN + ENDIF + POINT(1,POS)=X(I) + POINT(2,POS)=Y(I) + NBP(POS)=NBP(POS)+1 + ! define the end of element + ELEM_NEW(I,ELEM)=POS + ENDDO + ELSE + ELEM_NEW(1:2,ELEM)=0 + ENDIF + ENDDO + !* adjust points on the axes + SELECT CASE(TYPGEO) + CASE(5:6) + CALL SAL128_3(NN,POINT,EPS,EPS2) + CASE(7) + CALL SAL128_4(NN,POINT,EPS,EPS2) + CASE(8,12) + CALL SAL128_5(NN,POINT,EPS,EPS2) + CASE(9) + CALL SAL128_6(NN,POINT,EPS,EPS2) + CASE(10) + CALL SAL128_7(NN,POINT,EPS,EPS2) + CASE(11) + CALL SAL128_8(NN,POINT,EPS,EPS2) + END SELECT + + !* redefine the elements in rpar + IF(KNDEX/=0)WRITE(FOUT,'(/," redefine elements : ",/)') + DO ELEM=1,NB_ELEM + TYPE=IPAR(1,ELEM) + IF(TYPE/=G_ELE_TYPE(2)) THEN + I1=ELEM_NEW(1,ELEM) + I2=ELEM_NEW(2,ELEM) + CALL SAL129(POINT(1,I1),POINT(2,I1),POINT(1,I2),POINT(2,I2), & + TYPE,RPAR(:,ELEM),ELEM,KNDEX,FOUT) + ENDIF + ENDDO + ! + DEALLOCATE(POINT,ELEM_NEW) + ! + END SUBROUTINE SAL128 + ! + SUBROUTINE SAL128_3(NN,POINT,EPS,EPS2) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! process retangular geometry with translation or symmetry boundary condition + ! (TYPGEO=5,6): adjusts points on the axes, computes the lengths of the + ! retangle sides; in case of with translation,element lengths on the opposite + ! axes will be adjusted to be the same + ! + !Parameters: input + ! NN total number of points + ! EPS when distance of points to axes less than EPS, displace + ! the points onto the axes + ! EPS2 variable set to EPS*EPS + ! + !Parameters: input/output + ! POINT coordinates of points + ! + !--------------------------------------------------------------------- + ! + USE PRECISION_AND_KINDS, ONLY : PDB + USE SAL_GEOMETRY_TYPES, ONLY : TYPGEO,KNDEX,LX=>LENGTHX,LY=>LENGTHY + !**** + IMPLICIT NONE + INTEGER, INTENT(IN) :: NN + REAL, INTENT(IN) :: EPS,EPS2 + REAL(PDB), INTENT(INOUT), DIMENSION(:,:) :: POINT + ! DIMENSION POINT(2,NN) + !**** + INTEGER :: NP,NAXIS,I,J,K,M,P,IPOINT(4,NN),BP(4),IP(4) + LOGICAL :: LGADJUST + REAL(PDB) :: D,AUX,EX(4),EY(4),DIS(4),AX(4),AY(4),D_AXIS(4,NN) + INTEGER, PARAMETER :: FOUT =6 + !**** + ! flag to adjust the element lengths on the opposite axes + LGADJUST=TYPGEO==5 + ! compute sides of the rectangle + LX=0.; LY=0. + DO P=1,NN + IF(ABS(POINT(1,P))0,the point is near the half axis + AUX=POINT(1,P)*EX(I)+POINT(2,P)*EY(I) + IF(ABS(D).LT.EPS.AND.AUX>=0) THEN + ! move point to the axis + POINT(1,P)=POINT(1,P)-D*EY(I) + POINT(2,P)=POINT(2,P)+D*EX(I) + IF(LGADJUST) THEN + ! compute distance to the axis origin + D=SQRT((POINT(1,P)-AX(BP(I)))**2+(POINT(2,P)-AY(BP(I)))**2) + IP(I)=IP(I)+1 + D_AXIS(I,IP(I))=D + IPOINT(I,IP(I))=P + ENDIF + CYCLE ITER0 + ENDIF + ENDDO + ENDDO ITER0 + ! + IF(LGADJUST) THEN + DO I=1,NAXIS,2 + IF(IP(I)/=IP(I+1)) & + CALL XABORT('SAL128_3: axial points nber not the same,axis') + ! sort the 'd_axis' table + DO J=I,I+1 + DO P=1,IP(J) + DO K=P+1,IP(J) + IF(D_AXIS(J,P)>D_AXIS(J,K)) THEN + D=D_AXIS(J,P) + D_AXIS(J,P)=D_AXIS(J,K) + D_AXIS(J,K)=D + M=IPOINT(J,P) + IPOINT(J,P)=IPOINT(J,K) + IPOINT(J,K)=M + ENDIF + ENDDO + ENDDO + ENDDO + DO P=1,IP(I) + IF(ABS(D_AXIS(I,P)-D_AXIS(I+1,P))>EPS) THEN + IF(KNDEX/=0) & + WRITE(FOUT,'(" warning: too great axial length difference",& + & 2(/,2X,"axis = ",I3," point = ",I3," d = ",E13.6))')& + I,P,D_AXIS(I,P),I+1,P,D_AXIS(I+1,P) + ENDIF + D=(D_AXIS(I,P)+D_AXIS(I+1,P))*0.5 + DO J=I,I+1 + K=IPOINT(J,P) + POINT(1,K)=D*EX(J)+AX(BP(J)) + POINT(2,K)=D*EY(J)+AY(BP(J)) + ENDDO + ENDDO + ENDDO + ENDIF + ! + END SUBROUTINE SAL128_3 + ! + SUBROUTINE SAL128_4(NN,POINT,EPS,EPS2) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! process a 1/8 square geometry (typgeo=7): adjusts points on the axes, + ! computes the square side length + ! + !Parameters: input + ! NN total number of points + ! EPS when distance of points to axes less than EPS, displace + ! the points onto the axes + ! EPS2 variable set to EPS*EPS + ! + !Parameters: input/output + ! POINT coordinates of points + ! + !--------------------------------------------------------------------- + ! + USE PRECISION_AND_KINDS, ONLY : PDB + USE SAL_GEOMETRY_TYPES, ONLY : ANGGEO,KNDEX,LX=>LENGTHX,LY=>LENGTHY + !**** + IMPLICIT NONE + INTEGER, INTENT(IN) :: NN + REAL, INTENT(IN) :: EPS,EPS2 + REAL(PDB), INTENT(INOUT), DIMENSION(:,:) :: POINT + !**** + INTEGER :: NP,NAXIS,I,P + REAL(PDB) :: D,AUX,EX(3),EY(3),DIS(3),AX(3),AY(3) + INTEGER, PARAMETER :: FOUT =6 + !**** + ! compute the square sides + LX=0.; LY=0. + DO P=1,NN + IF(LY0.AND.ABS(LY-LX)>EPS) & + WRITE(FOUT,'(" warning: the square sides are not the same!", & + & " lx = ",E12.4," ly = ",E12.4)')LX,LY + LX=(LX+LY)*0.5 + LY=LX + !* adjust points on the axes + NAXIS=3 + ! axis directions + EX(1)=1.; EY(1)=0.; DIS(1)=0. + EX(2)=COS(ANGGEO); EY(2)=SIN(ANGGEO); DIS(2)=0. + EX(3)=0.; EY(3)=1.; DIS(3)=LX + NP=3 + ! axis ends + AX(1)=0.; AY(1)=0. + AX(2)=LX; AY(2)=0. + AX(3)=LX; AY(3)=LY + ITER0:DO P=1,NN + DO I=1,NP + D=(POINT(1,P)-AX(I))**2+(POINT(2,P)-AY(I))**2 + IF(D.LT.EPS2) THEN + ! move point to the axis origin + POINT(1,P)=AX(I) ; POINT(2,P)=AY(I) + CYCLE ITER0 + ENDIF + ENDDO + DO I=1,NAXIS + ! distance to the axis + D=POINT(1,P)*EY(I)-POINT(2,P)*EX(I)-DIS(I) + ! when aux>0,the point is near the half axis + AUX=POINT(1,P)*EX(I)+POINT(2,P)*EY(I) + IF(ABS(D).LT.EPS.AND.AUX>=0) THEN + ! move point to the axis + POINT(1,P)=POINT(1,P)-D*EY(I) + POINT(2,P)=POINT(2,P)+D*EX(I) + CYCLE ITER0 + ENDIF + ENDDO + ENDDO ITER0 + ! + END SUBROUTINE SAL128_4 + ! + SUBROUTINE SAL128_5(NN,POINT,EPS,EPS2) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! process a trianglar geometry (TYPGEO=8 or 12) with specular reflection: + ! adjusts points on the axes, computes the triangular side length + ! + !Parameters: input + ! NN total number of points + ! EPS when distance of points to axes less than EPS, displace + ! the points onto the axes + ! EPS2 variable set to EPS*EPS + ! + !Parameters: input/output + ! POINT coordinates of points + ! + !--------------------------------------------------------------------- + ! + USE PRECISION_AND_KINDS, ONLY : PDB + USE SAL_GEOMETRY_TYPES, ONLY : ANGGEO,KNDEX,LX=>LENGTHX,LY=>LENGTHY + !**** + IMPLICIT NONE + INTEGER, INTENT(IN) :: NN + REAL, INTENT(IN) :: EPS,EPS2 + REAL(PDB), INTENT(INOUT), DIMENSION(:,:) :: POINT + !**** + INTEGER :: NP,NAXIS,I,P + REAL(PDB) :: D,AUX,EX(3),EY(3),DIS(3),AX(3),AY(3) + INTEGER, PARAMETER :: FOUT =6 + !**** + ! compute the triangular side + LX=0.; LY=0. + DO P=1,NN + IF(ABS(POINT(2,P))0.AND.ABS(LY-LX*SIN(ANGGEO))>EPS) & + WRITE(FOUT,'(" warning: h is different from a*sin(anggeo)!", & + & " a = ",E12.4," h = ",E12.4)')LX,LY + ! adjust h according a + LY=LX*SIN(ANGGEO) + !* adjust points on the axes + NAXIS=3 + ! axis directions + EX(1)=1.; EY(1)=0.; DIS(1)=0. + EX(2)=COS(ANGGEO); EY(2)=SIN(ANGGEO); DIS(2)=0. + EX(3)=COS(ANGGEO*2.); EY(3)=SIN(ANGGEO*2.); DIS(3)=LY + NP=3 + ! axis ends + AX(1)=0.; AY(1)=0. + AX(2)=LX; AY(2)=0. + AX(3)=LX*0.5; AY(3)=LY + ITER0:DO P=1,NN + DO I=1,NP + D=(POINT(1,P)-AX(I))**2+(POINT(2,P)-AY(I))**2 + IF(D.LT.EPS2) THEN + ! move point to the axis origin + POINT(1,P)=AX(I) ; POINT(2,P)=AY(I) + CYCLE ITER0 + ENDIF + ENDDO + DO I=1,NAXIS + ! distance to the axis + D=POINT(1,P)*EY(I)-POINT(2,P)*EX(I)-DIS(I) + ! when aux>0,the point is near the half axis + AUX=POINT(1,P)*EX(I)+POINT(2,P)*EY(I) + IF(ABS(D).LT.EPS.AND.AUX>=0) THEN + ! move point to the axis + POINT(1,P)=POINT(1,P)-D*EY(I) + POINT(2,P)=POINT(2,P)+D*EX(I) + CYCLE ITER0 + ENDIF + ENDDO + ENDDO ITER0 + ! + END SUBROUTINE SAL128_5 + ! + SUBROUTINE SAL128_6(NN,POINT,EPS,EPS2) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! process a hexagonal geometry with translations on all sides (typgeo=9): + ! adjusts points on the axes, computes the lengths of hexagon sides; + ! element lengths on the opposite axes will be adjusted to be the same + ! + !Parameters: input + ! NN total number of points + ! EPS when distance of points to axes less than EPS, displace + ! the points onto the axes + ! EPS2 variable set to EPS*EPS + ! + !Parameters: input/output + ! POINT coordinates of points + ! + !--------------------------------------------------------------------- + ! + USE PRECISION_AND_KINDS, ONLY : PDB + USE SAL_GEOMETRY_TYPES, ONLY : ANGGEO,KNDEX,LX=>LENGTHX,LY=>LENGTHY + !**** + IMPLICIT NONE + INTEGER, INTENT(IN) :: NN + REAL, INTENT(IN) :: EPS,EPS2 + REAL(PDB), INTENT(INOUT), DIMENSION(:,:) :: POINT + !**** + INTEGER :: NP,NAXIS,I,J,K,M,P,IPOINT(6,NN),BP(6),IP(6) + REAL(PDB) :: D,AUX,EX(6),EY(6),DIS(6),AX(6),AY(6),D_AXIS(6,NN) + INTEGER, PARAMETER :: FOUT =6 + !**** + ! compute sides of the hexagon: LX=SIDE LENGTH,LY=LX*SIN(A) + LX=0.; LY=0. + DO P=1,NN + IF(ABS(POINT(2,P))0.AND.ABS(LY-LX*SIN(ANGGEO))>EPS) & + WRITE(FOUT,'(" warning: h is different from A*SIN(ANGGEO)!", & + & " a = ",E12.4," h = ",E12.4)')LX,LY + !* axis directions and their distance to (0,0) + NAXIS=6 + EX(1)=1.; EY(1)=0.; DIS(1)=LY + EX(2)=1.; EY(2)=0.; DIS(2)=-LY + EX(3)=COS(ANGGEO); EY(3)=SIN(ANGGEO); DIS(3)=LY + EX(4)=EX(3); EY(4)=EY(3); DIS(4)=-LY + EX(5)=COS(2.*ANGGEO); EY(5)=SIN(2.*ANGGEO); DIS(5)=LY + EX(6)=EX(5); EY(6)=EY(5); DIS(6)=-LY + NP=6 + AX(1)=-LX*0.5; AY(1)=-LY + AX(2)=LX*0.5; AY(2)=-LY + AX(3)=LX; AY(3)=0. + AX(4)=LX*0.5; AY(4)=LY + AX(5)=-LX*0.5; AY(5)=LY + AX(6)=-LX; AY(6)=0. + ! axis numbering: + ! M=2 + ! ***** + ! M=4 * * M=5 + ! * * * + ! M=6 * * M=3 + ! ***** + ! M=1 + ! + BP(1)=1; BP(2)=5; BP(3)=2; BP(4)=6; BP(5)=3; BP(6)=1 + IP=0 + ITER0:DO P=1,NN + DO I=1,NP + ! if it is the 6 corners of the hexagon + D=(POINT(1,P)-AX(I))**2+(POINT(2,P)-AY(I))**2 + IF(D.LT.EPS2) THEN + ! move point to the corner + POINT(1,P)=AX(I) ; POINT(2,P)=AY(I) + ! put distance to the axis origin + J=0 + SELECT CASE(I) + CASE(1) + CYCLE ITER0 + CASE(2) + ! END OF AXIS 1 + J=1 + CASE(3) + ! END OF AXIS 3 + J=3 + CASE(4) + ! END OF AXES 2&5 + J=2 + CASE(5) + ! END OF AXIS 4 + J=4 + CASE(6) + ! END OF AXIS 6 + J=6 + END SELECT + ! keep its distance and number +10 IP(J)=IP(J)+1 + D_AXIS(J,IP(J))=LX + IPOINT(J,IP(J))=P + IF(J==2) THEN + J=5 + GOTO 10 + ENDIF + CYCLE ITER0 + ENDIF + ENDDO + DO I=1,NAXIS + ! distance to the axis + D=POINT(1,P)*EY(I)-POINT(2,P)*EX(I)-DIS(I) + ! when aux>0,the point is near the half axis + AUX=(POINT(1,P)-AX(BP(I)))*EX(I)+(POINT(2,P)-AY(BP(I)))*EY(I) + IF(ABS(D).LT.EPS.AND.AUX>=0) THEN + ! move point to the axis + POINT(1,P)=POINT(1,P)-D*EY(I) + POINT(2,P)=POINT(2,P)+D*EX(I) + ! compute distance to the axis origin + D=SQRT((POINT(1,P)-AX(BP(I)))**2+(POINT(2,P)-AY(BP(I)))**2) + IP(I)=IP(I)+1 + D_AXIS(I,IP(I))=D + IPOINT(I,IP(I))=P + CYCLE ITER0 + ENDIF + ENDDO + ENDDO ITER0 + ! + DO I=1,NAXIS,2 + IF(IP(I)/=IP(I+1)) & + CALL XABORT('SAL128_6: axial points nber not the same,axis') + ! sort the 'd_axis' table + DO J=I,I+1 + DO P=1,IP(J) + DO K=P+1,IP(J) + IF(D_AXIS(J,P)>D_AXIS(J,K)) THEN + D=D_AXIS(J,P) + D_AXIS(J,P)=D_AXIS(J,K) + D_AXIS(J,K)=D + M=IPOINT(J,P) + IPOINT(J,P)=IPOINT(J,K) + IPOINT(J,K)=M + ENDIF + ENDDO + ENDDO + ENDDO + DO P=1,IP(I) + IF(ABS(D_AXIS(I,P)-D_AXIS(I+1,P))>EPS) THEN + IF(KNDEX/=0) & + WRITE(FOUT,'(" warning: too great axial length difference",& + & 2(/,2X,"axis = ",I3," point = ",I3," d = ",E13.6))')& + I,P,D_AXIS(I,P),I+1,P,D_AXIS(I+1,P) + ENDIF + D=(D_AXIS(I,P)+D_AXIS(I+1,P))*0.5 + DO J=I,I+1 + K=IPOINT(J,P) + POINT(1,K)=D*EX(J)+AX(BP(J)) + POINT(2,K)=D*EY(J)+AY(BP(J)) + ENDDO + ENDDO + ENDDO + ! + END SUBROUTINE SAL128_6 + ! + SUBROUTINE SAL128_7(NN,POINT,EPS,EPS2) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! process an isocel trianglar geometry (TYPGEO=10) with RA60 rotation: + ! adjusts points on the axes, computes the triangular side length + ! + !Parameters: input + ! NN total number of points + ! EPS when distance of points to axes less than EPS, displace + ! the points onto the axes + ! EPS2 variable set to EPS*EPS + ! + !Parameters: input/output + ! POINT coordinates of points + ! + !--------------------------------------------------------------------- + ! + USE PRECISION_AND_KINDS, ONLY : PDB + USE SAL_GEOMETRY_TYPES, ONLY : ANGGEO,LX=>LENGTHX,LY=>LENGTHY + !**** + IMPLICIT NONE + INTEGER, INTENT(IN) :: NN + REAL, INTENT(IN) :: EPS,EPS2 + REAL(PDB), INTENT(INOUT), DIMENSION(:,:) :: POINT + !**** + INTEGER :: NP,NAXIS,I,P + REAL(PDB) :: D,AUX,EX(3),EY(3),DIS(3),AX(3),AY(3) + INTEGER, PARAMETER :: FOUT =6 + !**** + ! compute the triangular side + LX=0.; LY=0. + DO P=1,NN + IF(ABS(POINT(2,P))0.AND.ABS(LY-LX*SIN(ANGGEO))>EPS) & + WRITE(FOUT,'(" warning: h is different from a*sin(anggeo)!", & + & " a = ",E12.4," h = ",E12.4)')LX,LY + ! adjust h according a + LY=LX*SIN(ANGGEO) + !* adjust points on the axes + NAXIS=3 + ! axis directions + EX(1)=1.; EY(1)=0.; DIS(1)=0. + EX(2)=COS(ANGGEO); EY(2)=SIN(ANGGEO); DIS(2)=0. + EX(3)=COS(ANGGEO*2.); EY(3)=SIN(ANGGEO*2.); DIS(3)=LY + NP=3 + ! axis ends + AX(1)=0.; AY(1)=0. + AX(2)=LX; AY(2)=0. + AX(3)=LX*0.5; AY(3)=LY + ITER0:DO P=1,NN + DO I=1,NP + D=(POINT(1,P)-AX(I))**2+(POINT(2,P)-AY(I))**2 + IF(D.LT.EPS2) THEN + ! move point to the axis origin + POINT(1,P)=AX(I) ; POINT(2,P)=AY(I) + CYCLE ITER0 + ENDIF + ENDDO + DO I=1,NAXIS + ! distance to the axis + D=POINT(1,P)*EY(I)-POINT(2,P)*EX(I)-DIS(I) + ! when aux>0,the point is near the half axis + AUX=POINT(1,P)*EX(I)+POINT(2,P)*EY(I) + IF(ABS(D).LT.EPS.AND.AUX>=0) THEN + ! move point to the axis + POINT(1,P)=POINT(1,P)-D*EY(I) + POINT(2,P)=POINT(2,P)+D*EX(I) + CYCLE ITER0 + ENDIF + ENDDO + ENDDO ITER0 + ! + END SUBROUTINE SAL128_7 + ! + SUBROUTINE SAL128_8(NN,POINT,EPS,EPS2) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! process R120 lozenge geometry (TYPGEO=11): adjusts points on the axes, + ! computes the lozenge side length + ! + !Parameters: input + ! NN total number of points + ! EPS when distance of points to axes less than EPS, displace + ! the points onto the axes + ! EPS2 variable set to EPS*EPS + ! + !Parameters: input/output + ! POINT coordinates of points + ! + !--------------------------------------------------------------------- + ! + USE PRECISION_AND_KINDS, ONLY : PDB + USE SAL_GEOMETRY_TYPES, ONLY : ANGGEO,LX=>LENGTHX,LY=>LENGTHY + !**** + IMPLICIT NONE + INTEGER, INTENT(IN) :: NN + REAL, INTENT(IN) :: EPS,EPS2 + REAL(PDB), INTENT(INOUT), DIMENSION(:,:) :: POINT + !**** + INTEGER :: NP,NAXIS,I,P + REAL(PDB) :: D,AUX,EX(4),EY(4),DIS(4),AX(4),AY(4) + INTEGER, PARAMETER :: FOUT =6 + !**** + ! compute the triangular side + LX=0.; LY=0. + DO P=1,NN + IF(ABS(POINT(2,P))EPS) & + WRITE(FOUT,'(" warning: h is different from a*sin(anggeo)!", & + & " a = ",E12.4," h = ",E12.4)') LX,LY + ! adjust h according to base + LY=LX*SIN(ANGGEO) + !* adjust points on the axes + NAXIS=4 + ! axis directions + EX(1)=1.; EY(1)=0.; DIS(1)=0. + EX(2)=1.; EY(2)=0.; DIS(2)=-LY + EX(3)=COS(ANGGEO); EY(3)=SIN(ANGGEO); DIS(3)=0. + EX(4)=COS(ANGGEO); EY(4)=SIN(ANGGEO); DIS(4)=LY + NP=4 + ! axis ends + AX(1)=0. ; AY(1)=0. + AX(2)=LX*0.5; AY(2)=LY + AX(3)=LX ; AY(3)=0. + AX(4)=LX*1.5; AY(4)=LY + ITER0:DO P=1,NN + DO I=1,NP + D=(POINT(1,P)-AX(I))**2+(POINT(2,P)-AY(I))**2 + IF(D.LT.EPS2) THEN + ! move point to the axis origin + POINT(1,P)=AX(I) ; POINT(2,P)=AY(I) + CYCLE ITER0 + ENDIF + ENDDO + DO I=1,NAXIS + ! distance to the axis + D=POINT(1,P)*EY(I)-POINT(2,P)*EX(I)-DIS(I) + ! when aux>0,the point is near the half axis + AUX=POINT(1,P)*EX(I)+POINT(2,P)*EY(I) + IF(ABS(D).LT.EPS.AND.AUX>=0) THEN + ! move point to the axis + POINT(1,P)=POINT(1,P)-D*EY(I) + POINT(2,P)=POINT(2,P)+D*EX(I) + CYCLE ITER0 + ENDIF + ENDDO + ENDDO ITER0 + ! + END SUBROUTINE SAL128_8 + ! + SUBROUTINE SAL129(X1,Y1,X2,Y2,TYPE,RPAR,II,KNDEX,FOUT) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! recompute element data by giving two ends of the element + ! + !Parameters: input + ! X1 new position in X for the end 1 + ! Y1 new position in Y for the end 1 + ! X2 new position in X for the end 2 + ! Y2 new position in Y for the end 2 + ! TYPE type of element 1 (segment) 3 (arc of circle) + ! II element to be changed + ! KNDEX if not 0 print out data when motion>EPS + ! FOUT printout file + ! + !Parameters: input/output + ! RPAR descriptors of the element + ! + !--------------------------------------------------------------------- + ! + USE SAL_GEOMETRY_TYPES, ONLY : NRPAR,EPS,G_ELE_TYPE,G_ELE_LEN + USE SAL_NUMERIC_MOD, ONLY : SALACO + !**** + IMPLICIT NONE + ! in variable + ! *********** + INTEGER, INTENT(IN) :: TYPE,KNDEX,FOUT,II + REAL(PDB), INTENT(IN) :: X1,Y1,X2,Y2 + REAL(PDB), INTENT(INOUT), DIMENSION(:) :: RPAR + !**** + + ! local variable + ! ************** + REAL(PDB) :: CX,CY,DELX,DELY,R,THETA,SX,SY,VX,VY,V2,DIST,MOV1,MOV2 + INTEGER :: I + REAL(PDB) :: RPAR_OLD(NRPAR) + !**** + ! keep old parameters: + RPAR_OLD(1:NRPAR)=RPAR(1:NRPAR) + ! + MOV1=0._PDB; MOV2=0._PDB; + IF(TYPE == G_ELE_TYPE(1)) THEN + !* segment : + ! compute the motions of two ends + DELX=X1-RPAR(1) + DELY=Y1-RPAR(2) + MOV1=SQRT(DELX*DELX+DELY*DELY) + DELX=X2-(RPAR(1)+RPAR(3)) + DELY=Y2-(RPAR(2)+RPAR(4)) + MOV2=SQRT(DELX*DELX+DELY*DELY) + ! set new ends, compute direction + RPAR(1)=X1 + RPAR(2)=Y1 + RPAR(3)=X2-X1 + RPAR(4)=Y2-Y1 + RPAR(5)=SQRT(RPAR(3)*RPAR(3)+RPAR(4)*RPAR(4)) + ELSE IF(TYPE == G_ELE_TYPE(3)) THEN + !* arc of circle : + ! get old radius + CX=RPAR(1); CY=RPAR(2) + ! compute the motion of two ends + R=RPAR(3) + THETA=RPAR(4) + DELX=CX+R*COS(THETA)-X1 + DELY=CY+R*SIN(THETA)-Y1 + MOV1=SQRT(DELX*DELX+DELY*DELY) + THETA=RPAR(5) + DELX=CX+R*COS(THETA)-X2 + DELY=CY+R*SIN(THETA)-Y2 + MOV2=SQRT(DELX*DELX+DELY*DELY) + ! compute new radius, new center and new angles + SX=X1-CX + SY=Y1-CY + ! get demi-vector from (x1,y1) to (x2,y2) + VX=(X2-X1)/2.0 + VY=(Y2-Y1)/2.0 + V2=VX*VX+VY*VY + ! get center closest to old center, change radius + ! compute new r + R=SQRT(V2+(SX*VY-SY*VX)**2/V2) + RPAR(3)=R + ! compute new center + DIST=1.0_PDB+(VX*SX+VY*SY)/V2 + ! get new center and compute angles + CX=CX+VX*DIST + CY=CY+VY*DIST + RPAR(1)=CX + RPAR(2)=CY + THETA=SALACO((X1-CX)/R,Y1-CY) + RPAR(4)=THETA + THETA=SALACO((X2-CX)/R,Y2-CY) + RPAR(5)=THETA + ! if phi1 > phi2 put phi2 equal to phi2+twopi + IF(RPAR(4)>RPAR(5)) RPAR(5)=RPAR(5)+TWOPI + ENDIF + IF(KNDEX/=0) THEN + IF(MOV1>EPS.OR.MOV2>EPS) THEN + WRITE(FOUT,'(/," old element ",I4," : ",6(1P,E13.4))') & + II,(RPAR_OLD(I),I=1,G_ELE_LEN(TYPE)) + WRITE(FOUT,'(" new element ",I4," : ",6(1P,E13.4))') & + II,(RPAR(I),I=1,G_ELE_LEN(TYPE)) + ENDIF + ENDIF + ! + END SUBROUTINE SAL129 + ! + SUBROUTINE SAL130(GG) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! perform domain definition and set boundary conditions + ! - computes node perimeters per 2d macro + ! - reads boundary conditions + ! - computes external perimeters + ! + !Parameters: input/output + ! GG geometry descriptor + ! + !--------------------------------------------------------------------- + ! + USE SAL_GEOMETRY_TYPES, ONLY : G_BC_TYPE,TYPGEO + !**** + IMPLICIT NONE + ! in variable + ! ************ + TYPE(T_G_BASIC), INTENT(INOUT):: GG + ! local variable + !**** + INTEGER :: NN,OK + INTEGER, DIMENSION(GG%NB_ELEM*2) :: AUX_ARR + !**** + !* compute node perimeters for the macro + CALL SAL130_2(GG%NB_ELEM,GG%NB_NODE,GG%IPAR,GG%PPERIM_NODE, & + GG%PERIM_NODE,AUX_ARR) + ! + !* - compute number of bc's per 2D macro, + ! NB_BC2 counts total nber of 2D bc's + ! - compute IBC2_ELEM, keep relative 2D bc nber to elements + ! - allocation : 2D bc structures + ! 2D perimeter structure for a macro + ! - get list of elements in 2d macro perimeter + + CALL SAL130_4(GG%NB_ELEM,NN,GG%IPAR,GG%IBC2_ELEM,AUX_ARR) + + GG%NB_BC2=NN + + ALLOCATE (GG%TYPE_BC2(NN),GG%IDATA_BC2(NN),GG%PERIM_MAC2(NN), & + GG%PPERIM_MAC2(7),STAT=OK) + IF(OK/=0) CALL XABORT('SAL130: not enough memory I,R') + GG%PPERIM_MAC2(:7)=0 + GG%PERIM_MAC2(1:NN)=AUX_ARR(1:NN) + GG%NPERIM_MAC2=NN + ! + !* read boundary conditions: + CALL SAL131(GG) + ! + ! - define IELEM_SURF2 + IF(GG%NB_SURF2>0) THEN + ! allocate + ALLOCATE(GG%SURF2(GG%NB_SURF2),STAT = OK) + IF(OK /= 0) CALL XABORT('SAL130: not enough memory I,R') + CALL SAL130_6(GG%NB_SURF2,GG%IBC2_SURF2,GG%PERIM_MAC2,GG%IELEM_SURF2) + ENDIF + ! + !* construct perimeter structures for rotative or symmetrical geometry + SELECT CASE(TYPGEO) + CASE(1:2) + CALL SAL130_8(GG%NPERIM_MAC2,GG%PERIM_MAC2,GG%PPERIM_MAC2,GG%DIST_AXIS, & + GG%IBC2_ELEM,GG%TYPE_BC2,GG%IDATA_BC2,GG%BCDATA,GG%IPAR,GG%RPAR) + CASE(5:12) + CALL SAL130_10(GG%NPERIM_MAC2,GG%PERIM_MAC2,GG%PPERIM_MAC2,GG%DIST_AXIS, & + GG%IBC2_ELEM,GG%TYPE_BC2,GG%IDATA_BC2,GG%BCDATA,GG%IPAR,GG%RPAR) + END SELECT + ! + END SUBROUTINE SAL130 + ! + SUBROUTINE SAL130_2(NB_ELEM,NB_NODE,IPAR,PPERIM,PERIM,LIST) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! compute node perimeters for one 2D macro + ! + !Parameters: input + ! NB_ELEM number of elements + ! NB_NODE number of nodes + ! IPAR integer descriptors for elements + ! + !Parameters: output + ! PPERIM array pointer to list of elements in perimeter per node + ! PERIM elements in perimeters per node + ! LIST temporary array + ! + !--------------------------------------------------------------------- + ! + IMPLICIT NONE + INTEGER, INTENT(IN) :: NB_ELEM,NB_NODE + INTEGER, INTENT(IN), DIMENSION(:,:) :: IPAR + INTEGER, INTENT(OUT), DIMENSION(:) :: LIST + INTEGER, INTENT(OUT), DIMENSION(:) :: PPERIM + INTEGER, POINTER, DIMENSION(:) :: PERIM + !**** + INTEGER :: NT,NN,NODE,ELEM,OK + CHARACTER(LEN=131) :: HSMG + !**** + NT=0 + PPERIM(1)=1 + DO NODE=1,NB_NODE + DO ELEM=1, NB_ELEM + IF(IPAR(2,ELEM)==NODE.OR.IPAR(3,ELEM)==NODE) THEN + NT=NT+1 + LIST(NT)=ELEM + ENDIF + ENDDO + NN=NT+1-PPERIM(NODE) + IF(NN>0) THEN + PPERIM(NODE+1)=NT+1 + ELSE + WRITE(HSMG,'(15HSAL130_2: node=,i5,19H without perimeter.)') NODE + CALL XABORT(HSMG) + ENDIF + ENDDO + IF(NT>0) THEN + ALLOCATE (PERIM(NT), STAT=OK) + IF(OK/=0) CALL XABORT('SAL130_2: not enough memory I') + PERIM(1:NT)=LIST(1:NT) + ENDIF + ! + END SUBROUTINE SAL130_2 + ! + SUBROUTINE SAL130_4(NB_ELEM,NB_BC,IPAR,IBC2_ELEM,LIST_BC) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! count number of bc's in a 2D macro + ! + !Parameters: input + ! NB_ELEM number of elements + ! + !Parameters: input/output + ! IPAR integer descriptors for elements + ! + !Parameters: output + ! NB_BC nber of bc's + ! IBC2_ELEM relative 2D bc index per element + ! LIST_BC list of elements in boundary + ! + !--------------------------------------------------------------------- + ! + IMPLICIT NONE + INTEGER, INTENT(IN) :: NB_ELEM + INTEGER, INTENT(OUT) :: NB_BC + INTEGER, INTENT(IN), DIMENSION(:,:) :: IPAR + INTEGER, INTENT(OUT), DIMENSION(:) :: IBC2_ELEM,LIST_BC + !**** + INTEGER :: ELEM + !**** + ! initiation + IBC2_ELEM(:)=0 + NB_BC=0 + DO ELEM=1, NB_ELEM + IF(IPAR(2,ELEM)<=0.AND.IPAR(3,ELEM)<=0) THEN + CALL XABORT('SAL130_4: two boundaries for element') + ELSE IF(IPAR(2,ELEM)<=0.OR.IPAR(3,ELEM)<=0) THEN + NB_BC=NB_BC+1 + LIST_BC(NB_BC)=ELEM + IF(IBC2_ELEM(ELEM)/=0) CALL XABORT('SAL130_4: two surfaces to element') + IBC2_ELEM(ELEM)=NB_BC + ! set mark for the macro connection surface : + ENDIF + ENDDO + ! + END SUBROUTINE SAL130_4 + ! + SUBROUTINE SAL130_6(NSURF,IBC2_SURF2,IELEM_BC2,IELEM_SURF2) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! get element order indices per surface + ! + !Parameters: input + ! NSURF number of surfaces + ! IBC2_SURF2 2D bc order index per surface + ! IELEM_BC2 element order index per bc + ! + !Parameters: output + ! IELEM_SURF2 element order index per surface + ! + !--------------------------------------------------------------------- + ! + !**** + USE SAL_GEOMETRY_TYPES, ONLY : G_BC_TYPE + !**** + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSURF + INTEGER, INTENT(IN), DIMENSION(:) :: IBC2_SURF2,IELEM_BC2 + INTEGER, INTENT(OUT), DIMENSION(:) :: IELEM_SURF2 + !**** + INTEGER :: SURF,IBC,ELEM + !**** + IF(NSURF > 0) THEN + DO SURF=1, NSURF + ! get relative bc order number + IBC=IBC2_SURF2(SURF) + ! get relative element + ELEM=IELEM_BC2(IBC) + ! define ielem_surf2 + IELEM_SURF2(SURF)=ELEM + ENDDO + ENDIF + ! + END SUBROUTINE SAL130_6 + ! + SUBROUTINE SAL130_8(NPERIM,PERIM,PPERIM,DIST_AXIS,IBC2_ELEM,TYPE_BC2,IDATA_BC2, & + BCDATA,IPAR,RPAR) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! calculate PERIM_MAC2,DIST_AXIS for rotative or symmetrical geometry + ! (TYPGEO=1 & 2) + ! + !Parameters: input + ! NPERIM number of elements in perimeter + ! IBC2_ELEM 2D bc order number per element + ! TYPE_BC2 type of boundary conditions per 2D bc + ! IDATA_BC2 position in the 'bcdata' table for each 2D bc + ! BCDATA table of boundary conditions data + ! IPAR integer element descriptor table + ! RPAR floating point element descriptor table + ! + !Parameters: input/output + ! PERIM list of elements in perimeter,in return it will be in following + ! order: (elems on axis 1)+(elems on axis 2)+(other elems) + ! + !Parameters: output + ! PPERIM pointers to the table 'perim': + ! (1): first elem on axis 1 (2): first elem on axis 2 + ! (3): first of other elems (4): NPERIM + 1 + ! DIST_AXIS distance of points on axis to the center (0,0),in order of: + ! (distances of points on axis 1)+(distances of points on axis 2) + ! + !--------------------------------------------------------------------- + ! + USE SAL_GEOMETRY_TYPES, ONLY : ANGGEO,EPS,G_BC_TYPE + USE SAL_NUMERIC_MOD, ONLY : SAL141 + !**** + IMPLICIT NONE + INTEGER, INTENT(IN) :: NPERIM + INTEGER, INTENT(IN), DIMENSION(:) :: IBC2_ELEM,TYPE_BC2,IDATA_BC2 + INTEGER, INTENT(INOUT), DIMENSION(:) :: PERIM + INTEGER, INTENT(OUT), DIMENSION(:) :: PPERIM + REAL(PDB), POINTER, DIMENSION(:) :: DIST_AXIS + INTEGER, INTENT(IN), DIMENSION(:,:) :: IPAR + REAL(PDB), INTENT(INOUT),DIMENSION(:,:) :: RPAR + REAL(PDB), INTENT(IN),DIMENSION(:,:) :: BCDATA + !**** + ! LIST_ELEMS = table of elements,elements on axis are in increasing order + ! of distance to (0,0): + ! 1=elements on axis 1; 2=elements on axis 2; 3=other elements + ! AUX_DIST = max distance of element ends to the beginnings of the axes: + ! 1=distances on axis 1; 2=distances on axis 2 + INTEGER, DIMENSION(NPERIM,3) :: LIST_ELEMS + REAL(PDB), DIMENSION(NPERIM,2) :: AUX_DIST + INTEGER :: I,J,K,M,ELEM,TYPBC,IBC,IDATA,NBE(3),OK,NAXES + REAL(PDB) :: ANGLE,X,Y,D + !**** + NAXES=2 + !* calculate number of elements on axis 1 & 2 + ! and their distances to the beginning of the axes + NBE=0 + DO I=1,NPERIM + ELEM=PERIM(I) + IBC=IBC2_ELEM(ELEM) + TYPBC=TYPE_BC2(IBC) + IDATA=IDATA_BC2(IBC) + ! default is the elements not on axis + M=NAXES+1 + IF(TYPBC==G_BC_TYPE(3)) THEN + !* rotation: + ANGLE=BCDATA(5,IDATA) + IF(ABS(ANGLE-ANGGEO)1) THEN + DO K=1,NBE(M)-1 + IF(AUX_DIST(NBE(M),M)0) THEN + ALLOCATE(DIST_AXIS(PPERIM(NAXES+1)-1),STAT=OK) + IF(OK.NE.0) CALL XABORT('SAL130_8: not enough memory R') + DO I=1,NAXES + DIST_AXIS(PPERIM(I):PPERIM(I+1)-1)=AUX_DIST(1:NBE(I),I) + ENDDO + ELSE + NULLIFY(DIST_AXIS) + ENDIF + ! + end subroutine sal130_8 + ! + SUBROUTINE SAL130_10(NPERIM,PERIM,PPERIM,DIST_AXIS,IBC2_ELEM,TYPE_BC2,IDATA_BC2, & + BCDATA,IPAR,RPAR) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! calculate PERIM_MAC2 and DIST_AXIS for the cyclical geometries: + ! type 5&6: retangle with translations or symmetries on all sides + ! type 7 : 1/8 assembly with symmetries on all sides + ! type 8 : equilateral triangle with symmetries on all sides + ! type 9 : hexagon with translations on all sides + ! type 10 : hexagon with RA60 rotation + ! type 11 : hexagon with R120 rotation + ! type 12 : rectangular S30 triangle geometry + ! + !Parameters: input + ! NPERIM number of elements in perimeter + ! IBC2_ELEM 2D bc order number per element + ! TYPE_BC2 type of boundary conditions per 2D bc + ! IDATA_BC2 position in the 'bcdata' table for each 2D bc + ! BCDATA table of boundary conditions data + ! IPAR integer element descriptor table + ! RPAR floating point element descriptor table + ! + !Parameters: input/output + ! PERIM list of elements in perimeter,in return it will be in following + ! order: (elems on axis 1)+(elems on axis 2)+(other elems) + ! + !Parameters: output + ! PPERIM pointers to the table 'perim': + ! DIST_AXIS distance of points on axis to the axis origin + ! + !--------------------------------------------------------------------- + ! + USE SAL_GEOMETRY_TYPES, ONLY : TYPGEO,ANGGEO,EPS,LX=>LENGTHX,LY=>LENGTHY,G_BC_TYPE + USE SAL_NUMERIC_MOD, ONLY : SAL141 + !**** + IMPLICIT NONE + INTEGER, INTENT(IN) :: NPERIM + INTEGER, INTENT(IN), DIMENSION(:) :: IBC2_ELEM,TYPE_BC2,IDATA_BC2 + INTEGER, INTENT(INOUT), DIMENSION(:) :: PERIM + INTEGER, INTENT(OUT), DIMENSION(:) :: PPERIM + REAL(PDB), POINTER, DIMENSION(:) :: DIST_AXIS + INTEGER, INTENT(IN), DIMENSION(:,:) :: IPAR + REAL(PDB), INTENT(INOUT),DIMENSION(:,:) :: RPAR + REAL(PDB), INTENT(IN),DIMENSION(:,:) :: BCDATA + !**** + ! LIST_ELEMS = table of elements,elements on axis are in increasing order + ! of distance to axis origin: + ! 1=elements on axis 1; 2=elements on axis 2; ... + ! AUX_DIST = max distance of element ends to axis origin: + ! 1=distances on axis 1; 2=distances on axis 2; ... + INTEGER, DIMENSION(NPERIM,6) :: LIST_ELEMS + REAL(PDB), DIMENSION(NPERIM,6) :: AUX_DIST + INTEGER :: I,J,K,M,ELEM,TYPBC,IBC,IDATA,NBE(6),OK,NAXES + REAL(PDB) :: ANGLE,X,Y,D + !**** + NAXES=0 + IF((TYPGEO==5).OR.(TYPGEO==6).OR.(TYPGEO==11)) THEN + NAXES=4 + ELSEIF((TYPGEO==7).OR.(TYPGEO==8).OR.(TYPGEO==10).OR.(TYPGEO==12)) THEN + NAXES=3 + ELSEIF(TYPGEO==9) THEN + NAXES=6 + ENDIF + !* calculate number of elements on axes, + ! and their distances to the origin of the axis + NBE=0 + + DO I=1,NPERIM + ELEM=PERIM(I) + IBC=IBC2_ELEM(ELEM) + TYPBC=TYPE_BC2(IBC) + IDATA=IDATA_BC2(IBC) + ENDDO + DO I=1,NPERIM + ELEM=PERIM(I) + IBC=IBC2_ELEM(ELEM) + TYPBC=TYPE_BC2(IBC) + IDATA=IDATA_BC2(IBC) + ANGLE=BCDATA(5,IDATA) + ! default is the elements not on axis + M=NAXES+1 + SELECT CASE(TYPGEO) + CASE(5) + !* rectangle with translations: + ! axes definition: + ! M=3 + ! ************ + ! * * + ! M=2 * * M=4 + ! ************ + ! M=1 + IF(TYPBC==G_BC_TYPE(2)) THEN + IF(BCDATA(2,IDATA)>0) THEN + M=1 + ELSEIF(BCDATA(2,IDATA)<0) THEN + M=3 + ELSEIF(BCDATA(1,IDATA)>0) THEN + M=2 + ELSEIF(BCDATA(1,IDATA)<0) THEN + M=4 + ENDIF + ELSE + CALL XABORT('SAL130_10: wrong boundary condition for TYPGEO=5.') + ENDIF + CASE(6) + !* rectangle with symmetries: + ! axes definition: + ! M=3 + ! ************ + ! * * + ! M=2 * * M=4 + ! ************ + ! M=1 + IF(TYPBC==G_BC_TYPE(4)) THEN + IF(ABS(ANGLE)0) THEN + ! cy>0: element is on the axis 3 (angle=0) + M=3 + ELSE + ! cy=0: element is on the axis 1 (angle=0) + M=1 + ENDIF + ELSEIF(ABS(ANGLE-ANGGEO)0) THEN + ! cx>0: element is on the axis 4 (angle=anggeo) + M=4 + ELSE + ! cx=0: element is on the axis 2 (angle=anggeo) + M=2 + ENDIF + ENDIF + ELSE + CALL XABORT('SAL130_10: wrong boundary condition for TYPGEO=6.') + ENDIF + CASE(7,8,12) + !* triangles with symmetries: + ! typgeo=7 axes definition: + ! * + ! M=2 * * M=3 + ! * * + ! ******* + ! M=1 + ! typgeo=8 axes definition: + ! * + ! M=2 * * M=3 + ! * * + ! ************* + ! M=1 + IF(TYPBC==G_BC_TYPE(4)) THEN + IF(ABS(ANGLE)0) THEN + M=1 + ELSE + M=4 + ENDIF + ELSEIF(BCDATA(1,IDATA)>0.AND.BCDATA(2,IDATA)>0) THEN + M=2 + ELSEIF(BCDATA(1,IDATA)>0.AND.BCDATA(2,IDATA)<0) THEN + M=3 + ELSEIF(BCDATA(1,IDATA)<0.AND.BCDATA(2,IDATA)>0) THEN + M=6 + ELSEIF(BCDATA(1,IDATA)<0.AND.BCDATA(2,IDATA)<0) THEN + M=5 + ENDIF + ELSE + CALL XABORT('SAL130_10: wrong boundary condition for TYPGEO=9.') + ENDIF + CASE(10) + !* triangles with rotations and translations: + ! typgeo=10 axes definition: + ! * + ! M=2 * * M=3 + ! * * + ! ************* + ! M=1 + IF((TYPBC==G_BC_TYPE(2)).OR.(TYPBC==G_BC_TYPE(3))) THEN + IF(ABS(ANGLE)0) THEN + ! cy>0: element is on the axis 3 (angle=0) + M=3 + ELSE + ! cy=0: element is on the axis 1 (angle=0) + M=1 + ENDIF + ELSE + IF(BCDATA(1,IDATA)>0) THEN + ! cx>0: element is on the axis 4 (angle>0) + M=4 + ELSE + ! cx=0: element is on the axis 2 (angle>0) + M=2 + ENDIF + ENDIF + ELSE + CALL XABORT('SAL130_10: TYPGEO=11:wrong boundary condition type.') + ENDIF + CASE DEFAULT + CALL XABORT('SAL130_10: boundary condition not implemented.') + END SELECT + IF(M>=NAXES+1) CALL XABORT('SAL130_10: element not on axes') + NBE(M)=NBE(M)+1 + LIST_ELEMS(NBE(M),M)=ELEM + ! sort the element list according their distance to + ! the origins of the axes + D=0. + SELECT CASE(TYPGEO) + CASE(5:6) + SELECT CASE(M) + CASE(1:2) + DO K=1,2 + CALL SAL141(IPAR(1,ELEM),RPAR(:,ELEM),X,Y,K) + D=MAX(D,SQRT(X*X+Y*Y)) + ENDDO + CASE(3) + DO K=1,2 + CALL SAL141(IPAR(1,ELEM),RPAR(:,ELEM),X,Y,K) + D=MAX(D,X) + ENDDO + CASE(4) + DO K=1,2 + CALL SAL141(IPAR(1,ELEM),RPAR(:,ELEM),X,Y,K) + D=MAX(D,Y) + ENDDO + END SELECT + CASE(7) + SELECT CASE(M) + CASE(1:2) + DO K=1,2 + CALL SAL141(IPAR(1,ELEM),RPAR(:,ELEM),X,Y,K) + D=MAX(D,SQRT(X*X+Y*Y)) + ENDDO + CASE(3) + DO K=1,2 + CALL SAL141(IPAR(1,ELEM),RPAR(:,ELEM),X,Y,K) + D=MAX(D,Y) + ENDDO + END SELECT + CASE(8,10,12) + SELECT CASE(M) + CASE(1:2) + DO K=1,2 + CALL SAL141(IPAR(1,ELEM),RPAR(:,ELEM),X,Y,K) + D=MAX(D,SQRT(X*X+Y*Y)) + ENDDO + CASE(3) + DO K=1,2 + CALL SAL141(IPAR(1,ELEM),RPAR(:,ELEM),X,Y,K) + ! axis origin is (lx,0) + D=MAX(D,SQRT((X-LX)*(X-LX)+Y*Y)) + ENDDO + END SELECT + CASE(9) + ! origins of axes: + ! axis 1&2: (-lx/2,-ly) + ! axis 3: (-lx , 0) + ! axis 4: (-lx/2, ly) + ! axis 5: ( lx , 0) + ! axis 6: ( lx/2,-ly) + SELECT CASE(M) + CASE(1:2) + DO K=1,2 + CALL SAL141(IPAR(1,ELEM),RPAR(:,ELEM),X,Y,K) + D=MAX(D,SQRT((X+LX*0.5)*(X+LX*0.5)+(Y+LY)*(Y+LY))) + ENDDO + CASE(3) + DO K=1,2 + CALL SAL141(IPAR(1,ELEM),RPAR(:,ELEM),X,Y,K) + D=MAX(D,SQRT((X+LX)*(X+LX)+Y*Y)) + ENDDO + CASE(4) + DO K=1,2 + CALL SAL141(IPAR(1,ELEM),RPAR(:,ELEM),X,Y,K) + D=MAX(D,SQRT((X+LX*0.5)*(X+LX*0.5)+(Y-LY)*(Y-LY))) + ENDDO + CASE(5) + DO K=1,2 + CALL SAL141(IPAR(1,ELEM),RPAR(:,ELEM),X,Y,K) + D=MAX(D,SQRT((X-LX)*(X-LX)+Y*Y)) + ENDDO + CASE(6) + DO K=1,2 + CALL SAL141(IPAR(1,ELEM),RPAR(:,ELEM),X,Y,K) + D=MAX(D,SQRT((X-LX*0.5)*(X-LX*0.5)+(Y+LY)*(Y+LY))) + ENDDO + END SELECT + CASE(11) + SELECT CASE(M) + CASE(1:2) + DO K=1,2 + CALL SAL141(IPAR(1,ELEM),RPAR(:,ELEM),X,Y,K) + D=MAX(D,SQRT(X*X+Y*Y)) + ENDDO + CASE(3) + DO K=1,2 + CALL SAL141(IPAR(1,ELEM),RPAR(:,ELEM),X,Y,K) + D=MAX(D,SQRT((X-LX*0.5)*(X-LX*0.5)+(Y-LY)*(Y-LY))) + ENDDO + CASE(4) + DO K=1,2 + CALL SAL141(IPAR(1,ELEM),RPAR(:,ELEM),X,Y,K) + D=MAX(D,SQRT((X-LX)*(X-LX)+Y*Y)) + ENDDO + END SELECT + END SELECT + AUX_DIST(NBE(M),M)=D + IF(NBE(M)>1) THEN + DO K=1,NBE(M)-1 + IF(AUX_DIST(NBE(M),M)0) THEN + ALLOCATE(DIST_AXIS(PPERIM(NAXES+1)-1),STAT=OK) + IF(OK.NE.0) CALL XABORT('SAL130_10: not enough memory R') + DO I=1,NAXES + DIST_AXIS(PPERIM(I):PPERIM(I+1)-1)=AUX_DIST(1:NBE(I),I) + ENDDO + ELSE + NULLIFY(DIST_AXIS) + ENDIF + ! + END SUBROUTINE SAL130_10 + ! + SUBROUTINE SAL131(GG) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! modifies GG%IPAR and constructs bcdata (modifies GG%IPAR and + ! constructs BCDATA) + ! + !Parameters: input/output + ! GG geometry descriptor + ! + !--------------------------------------------------------------------- + ! + USE SAL_GEOMETRY_TYPES, ONLY : G_BC_MAX_LEN,G_BC_LEN,G_BC_TYPE,NIPAR,EPS, & + ANGGEO,TYPGEO,LENGTHX,LENGTHY,ALLSUR + !**** + IMPLICIT NONE + ! in variable + ! ************ + TYPE(T_G_BASIC), INTENT(INOUT) :: GG + !**** + LOGICAL :: LGBC,LGALLS + INTEGER :: TYPE,II,NN,NBER,I,J,ITBC,IELEM + REAL(PDB) :: ANGLE + INTEGER :: ELEM,IBC,OK,IDATA(2) + INTEGER, POINTER, DIMENSION(:) :: TYPE_BC2,ISURF2_ELEM,IELEM_BC2 + !***** + !** TMP_BCDATA = description of motions at the boundary + !** IPAR = pointer to geometry descriptors + INTEGER, DIMENSION(GG%NB_ELEM) :: AUX_ARR + REAL(PDB), DIMENSION(G_BC_MAX_LEN,GG%NB_ELEM+5) :: TMP_BCDATA + !***** + !* initialization + IF(TYPGEO==1.OR.TYPGEO==2) IDATA(:)=0 + !* BCDATA for surfaces of type G_BC_TYPE(-1) + ! + LGALLS=ALLSUR/=0 + ITBC=0 ! the first bc data + ! + !* treat approximate boundary condictions + IF(LGALLS)THEN + ITBC=1 + ! ALL BC'S PRODUIT SURFACES + IF(GG%DEFAUL==1)THEN + ! SPECULAR REFLEXION -> ISOTROPIC REFLEXION WITH ALBEDO=1 + GG%DEFAUL=0 ; TMP_BCDATA(6,ITBC)=1._PDB + ENDIF + ENDIF + ! + !* put default value in all bc elements: + CALL SAL131_2(GG%NB_ELEM,GG%DEFAUL,GG%IPAR,GG%IBC2_ELEM,GG%TYPE_BC2,GG%IDATA_BC2) + ! + IF(GG%NBBCDA>0)THEN + ANGLE=0._PDB + DO I=1,GG%NBBCDA + ITBC=ITBC+1 + IF(ITBC.GT.GG%NB_ELEM+5) CALL XABORT('SAL131: BCDATA overflow') + TMP_BCDATA(:,ITBC)=GG%BCDATAREAD(I)%BCDATA(:) + TYPE=GG%BCDATAREAD(I)%SALTYPE + SELECT CASE(TYPE) + CASE(1) + IF(LGALLS)THEN + ! specular reflexion -> isotropic reflexion with albedo=1 + TYPE=0 ; TMP_BCDATA(6,ITBC)=1._PDB + ENDIF + CASE(2) + ANGLE=TMP_BCDATA(5,ITBC) + SELECT CASE(TYPGEO) + CASE(5) + ! adjust translation data according to the sides of rectangle + IF(TMP_BCDATA(1,ITBC)/=0) TMP_BCDATA(1,ITBC)=SIGN(LENGTHX,TMP_BCDATA(1,ITBC)) + IF(TMP_BCDATA(2,ITBC)/=0) TMP_BCDATA(2,ITBC)=SIGN(LENGTHY,TMP_BCDATA(2,ITBC)) + CASE(9) + ! adjust translation data according to the hexagonal sides + IF(ABS(TMP_BCDATA(1,ITBC))0.) THEN + ! cy>0 and angle=0 + TMP_BCDATA(1,ITBC)=LENGTHX/2.0 + TMP_BCDATA(2,ITBC)=LENGTHY + ELSE + ! cy=0 and angle=0 + TMP_BCDATA(1,ITBC)=0.0 + TMP_BCDATA(2,ITBC)=0.0 + ENDIF + ELSE + IF(TMP_BCDATA(1,ITBC)>0.) THEN + ! cx>0 and angle=pi/3 rad + TMP_BCDATA(1,ITBC)=LENGTHX + TMP_BCDATA(2,ITBC)=0.0 + ELSE + ! cx=0 and angle=pi/3 rad + TMP_BCDATA(1,ITBC)=0.0 + TMP_BCDATA(2,ITBC)=0.0 + ENDIF + ENDIF + TMP_BCDATA(3,ITBC)=COS(ANGLE) + TMP_BCDATA(4,ITBC)=SIN(ANGLE) + TMP_BCDATA(5,ITBC)=ANGLE + END SELECT + IF(LGALLS)THEN + ! translation -> isotropic translation with albedo=1 + TYPE=TYPE+4 + ! perform array shift + TMP_BCDATA(:,ITBC)=CSHIFT(TMP_BCDATA(:,ITBC),1) + ! albedo=1 + TMP_BCDATA(6,ITBC)=1._PDB + ENDIF + CASE(3) + ! cases of rotation: + ! read angle, compute cos and sin + ANGLE=TMP_BCDATA(5,ITBC) + IF(TYPGEO==1.OR.TYPGEO==2) THEN + IF(ABS(ANGLE-ANGGEO) isotropic rotation with albedo=1 + ! axial symmetry -> isotropic axial symmetry with albedo=1 + TYPE=TYPE+4 + ! perform array shift + TMP_BCDATA(:,ITBC)=CSHIFT(TMP_BCDATA(:,ITBC),1) + ! albedo=1 + TMP_BCDATA(6,ITBC)=1._PDB + ENDIF + CASE(4) + ! cases of specular symmetry: + ! read center and angle, compute cos and sin + ANGLE=TMP_BCDATA(5,ITBC) + SELECT CASE(TYPGEO) + CASE(1,2) + IF(ABS(ANGLE-0.) isotropic rotation with albedo=1 + ! axial symmetry -> isotropic axial symmetry with albedo=1 + TYPE=TYPE+4 + ! perform array shift + TMP_BCDATA(:,ITBC)=CSHIFT(TMP_BCDATA(:,ITBC),1) + ! albedo=1 + TMP_BCDATA(6,ITBC)=1._PDB + ENDIF + END SELECT + ! + ! modify notation for boundary conditions + NBER=GG%BCDATAREAD(I)%NBER + DO J=1,NBER + ELEM=GG%BCDATAREAD(I)%ELEMNB(J) + IF(ELEM>GG%NB_ELEM.OR.ELEM<=0) CALL XABORT('SAL131: unknown bc element') + ! get local surface nber + IBC=GG%IBC2_ELEM(ELEM) + LGBC=GG%IPAR(2,ELEM)<=0 + II=0 + IF(LGBC)THEN + II=2 + ELSE + LGBC=GG%IPAR(3,ELEM)<=0 + IF(LGBC) II=3 + ENDIF + IF(.NOT.LGBC) THEN + WRITE(*,*) 'elem :',ELEM + WRITE(*,*) 'GG%IPAR(:,ELEM) :',GG%IPAR(:,ELEM) + CALL XABORT('SAL131: wrong bc element') + ENDIF + ! put bc type + GG%IPAR(II,ELEM)=G_BC_TYPE(TYPE) + GG%TYPE_BC2(IBC)=G_BC_TYPE(TYPE) + ! put bc data position : + GG%IDATA_BC2(IBC)=ITBC + ENDDO + ENDDO + ENDIF + ! + !* - set BCDATA position for surfaces of type G_BC_TYPE(-1) + ! - compute the nber of surfaces (type -1,0,-12,-13,-14,-15) : nbsur2 + ! - allocate structures for the surfaces + ! - compute surf_mac2 + TYPE_BC2=>GG%TYPE_BC2 + ISURF2_ELEM=>GG%ISURF2_ELEM + IELEM_BC2=>GG%PERIM_MAC2 + NN=0 + DO IBC=1,GG%NB_BC2 + IF(TYPE_BC2(IBC)==G_BC_TYPE(-1)) THEN + ! macro contact surfaces : set bcdata position to 1 + GG%IDATA_BC2(IBC)=1 + ENDIF + ! relative element nber + IELEM=IELEM_BC2(IBC) + ! count 2D surfaces number + IF(TYPE_BC2(IBC)==G_BC_TYPE(-1) .OR. TYPE_BC2(IBC)==G_BC_TYPE(0) .OR. & + TYPE_BC2(IBC)==G_BC_TYPE(1)) THEN + NN=NN+1 + AUX_ARR(NN)=IBC + ISURF2_ELEM(IELEM)=NN + ELSE + ISURF2_ELEM(IELEM)=0 + ENDIF + ENDDO + GG%NB_SURF2=NN + IF(NN>0) THEN + ALLOCATE (GG%IBC2_SURF2(NN),GG%IELEM_SURF2(NN),STAT=OK) + IF(OK/=0) CALL XABORT('SAL131: NOT ENOUGH MEMORY I,R') + GG%IBC2_SURF2(1:NN)=AUX_ARR(1:NN) + ELSE + NULLIFY(GG%IBC2_SURF2,GG%IELEM_SURF2) + ENDIF + ! + !* allocate idata_axis + IF(TYPGEO==1.OR.TYPGEO==2) THEN + DO I=1,2 + IF(IDATA(I)==0) THEN + ! there is no elements on this axis,add a bcdata for this axis + ITBC=ITBC+1 + ANGLE=0._PDB + IF(TYPGEO==1) THEN + ! symmetry + IF(I==1) THEN + ANGLE=0._PDB + ELSE + ANGLE=ANGGEO + ENDIF + ELSEIF(TYPGEO==2) THEN + ! rotation + IF(I==1) THEN + ANGLE=ANGGEO + ELSE + ANGLE=-ANGGEO + ENDIF + ENDIF + TMP_BCDATA(1,ITBC)=0._PDB + TMP_BCDATA(2,ITBC)=0._PDB + TMP_BCDATA(3,ITBC)=COS(ANGLE) + TMP_BCDATA(4,ITBC)=SIN(ANGLE) + TMP_BCDATA(5,ITBC)=ANGLE + IDATA(I)=ITBC + ENDIF + ENDDO + ALLOCATE(GG%IDATA_AXIS(2), STAT=OK) + IF(OK.NE.0) CALL XABORT('SAL131: not enough memory I') + GG%IDATA_AXIS=IDATA + ENDIF + !* allocate bcdata + ALLOCATE (GG%BCDATA(G_BC_MAX_LEN,ITBC), STAT=OK) + IF(OK/=0) CALL XABORT('SAL131: not enough memory R') + GG%BCDATA(:,1:ITBC)=TMP_BCDATA(:,1:ITBC) + GG%NALBG=ITBC + ! + END SUBROUTINE SAL131 + ! + SUBROUTINE SAL131_2(NB_ELEM,DEFAUL,IPAR,IBC2_ELEM,TYPE_BC2,IDATA_BC2) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! put default bc type and BCDATA to a 2D macro + ! + !Parameters: input + ! NB_ELEM nber of elements + ! DEFAUL default bc type + ! IBC2_ELEM relative 2D bc number per element + ! + !Parameters: input/output + ! IPAR integer descriptors for elements + ! + !Parameters: input + ! TYPE_BC2 2D boundary condiction type + ! IDATA_BC2 position in bcdata par 2D bc + ! + !--------------------------------------------------------------------- + ! + USE SAL_GEOMETRY_TYPES, ONLY : G_BC_TYPE + !**** + IMPLICIT NONE + INTEGER, INTENT(IN) :: NB_ELEM,DEFAUL + INTEGER, INTENT(INOUT), DIMENSION(:,:) :: IPAR + INTEGER, INTENT(IN), DIMENSION(:) :: IBC2_ELEM + INTEGER, INTENT(OUT), DIMENSION(:) :: TYPE_BC2 + INTEGER, INTENT(OUT), DIMENSION(:) :: IDATA_BC2 + !**** + INTEGER :: ELEM,II,IBC + LOGICAL :: LGBC + !**** + ! initiation + TYPE_BC2=G_BC_TYPE(-1) + ! + DO ELEM=1,NB_ELEM + LGBC=IPAR(2,ELEM)==0 + II=0 + IF(LGBC) THEN + II=2 + IF(IPAR(3,ELEM)<=0) CALL XABORT('SAL131_2: element with 2 bc''s') + ELSE + LGBC=IPAR(3,ELEM)==0 + IF(LGBC) II=3 + ENDIF + IF(LGBC) THEN + ! put bc type value to ipar + IPAR(II,ELEM)=G_BC_TYPE(DEFAUL) + ! put bc type value to bc type structure + IBC=IBC2_ELEM(ELEM) + IF(IBC==0) CALL XABORT('SAL131_2: surf-element relation error') + IF(TYPE_BC2(IBC)/=G_BC_TYPE(-1)) CALL XABORT('SAL131_2: two elements to a surface') + TYPE_BC2(IBC)=G_BC_TYPE(DEFAUL) + ! put position of "defaul" in bcdata table (use default albedo) + IDATA_BC2(IBC)=0 + ENDIF + ENDDO + ! + END SUBROUTINE SAL131_2 + ! + SUBROUTINE SAL140(NB_NODE,RPAR,IPAR,PPERIM,PERIM) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! checks domain topology in a 2D macro + ! + !Parameters: input + ! NB_NODE number of nodes in macro + ! + !Parameters: input/output + ! RPAR floating point geometry descriptors + ! IPAR integer descriptors for elements + ! PPERIM pointer to list of elements in perimeter + ! PERIM list of perimeters + ! + !--------------------------------------------------------------------- + ! + USE SAL_GEOMETRY_TYPES, ONLY : NRPAR,NIPAR + !**** + IMPLICIT NONE + INTEGER, INTENT(IN) :: NB_NODE + INTEGER, INTENT(IN), DIMENSION (:) :: PPERIM + INTEGER, INTENT(INOUT), DIMENSION (:,:) :: IPAR + INTEGER, INTENT(INOUT), DIMENSION (:) :: PERIM + REAL(PDB), INTENT(INOUT), DIMENSION (:,:) :: RPAR + !**** + INTEGER :: ELEM,NODE,ID,L,FIRST,LAST,NEXT,NLOOP, & + NEWEND,KEEP,IEND,I1,I2 + REAL(PDB) :: X,Y,XNEW,YNEW,DIST + LOGICAL :: LGOPEN,LGON,LGERR + INTEGER, PARAMETER :: MXKEEP = 20 + REAL, DIMENSION(MXKEEP) :: KEEPD + INTEGER, PARAMETER :: FOUT =6 + REAL(PDB),PARAMETER :: EPS2=1.0E-7_PDB + !***** + NEXT=0 + !* checks topology of each node + DO NODE=1,NB_NODE + I1=PPERIM(NODE) + ! ID counts elements in the perimeter already treated + ID=I1-1 + I2=PPERIM(NODE+1)-1 + IF(I2 cannot close node '',i5, & + &'' AT ELEMENT'',I5,/)')NODE,LAST + LGERR=.TRUE. + ELSEIF(FIRST==LAST)THEN + WRITE(FOUT,'(//,''==> node '',i5,'' with '', & + &''isolated element'',i5,/)')NODE,LAST + LGERR=.TRUE. + ENDIF + IF(LGERR) CALL XABORT('SAL140: node not closed') + NEXT=FIRST + ENDIF + ! define last = next element and proceed + LAST=NEXT + IEND=3-NEWEND + ENDDO + ID=ID+1 + ENDDO + ENDDO + ! + END SUBROUTINE SAL140 + ! + SUBROUTINE SAL142(X,Y,XNEW,YNEW,TYPE,RPAR,IEND,EPS2,DIST) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! checks whether element is very close to point (X,Y) + ! + !Parameters: input + ! X abscissa coordinate + ! Y ordinate coordinate + ! TYPE type of element 1 (segment), 3 (arc of circle) + ! EPS2 criterium for closeness + ! + !Parameters: input/output + ! XNEW abscissa coordinate of end of element close to point + ! YNEW ordinate coordinate of end of element close to point + ! RPAR floating point geometry descriptors + ! IEND = 1 (beginning is close to point dist < EPS2) + ! 2 (end is close to point DIST < EPS2) + ! -1 (beginning is close to point dist > EPS2) + ! -2 (end is close to point DIST > EPS2) + ! DIST distance from end of element to point (X,Y) + ! + !--------------------------------------------------------------------- + ! + USE SAL_GEOMETRY_TYPES, ONLY : G_ELE_TYPE + !**** + IMPLICIT NONE + INTEGER, INTENT(IN) :: TYPE + INTEGER, INTENT(OUT) :: IEND + REAL(PDB), INTENT(IN) :: X,Y,EPS2 + REAL(PDB), INTENT(OUT) :: XNEW,YNEW,DIST + REAL(PDB), INTENT(IN), DIMENSION(:) :: RPAR + ! DIMENSION RPAR(NRPAR) + !**** + REAL(PDB) :: CX,CY,THETA,R,DIST2 + !**** + !* function giving distance between two points: + REAL(PDB) :: FUNC,X1,Y1,X2,Y2 + FUNC(X1,Y1,X2,Y2)=(X1-X2)**2+(Y1-Y2)**2 + !**** + CX=RPAR(1) + CY=RPAR(2) + DIST2=0._PDB + IF(TYPE==G_ELE_TYPE(1))THEN + !* segment + XNEW=CX + YNEW=CY + DIST=FUNC(XNEW,YNEW,X,Y) + IF(DIST<=EPS2)THEN + IEND=1 + RETURN + ELSE + XNEW=CX+RPAR(3) + YNEW=CY+RPAR(4) + DIST2=FUNC(XNEW,YNEW,X,Y) + ENDIF + ELSEIF(TYPE<=G_ELE_TYPE(3))THEN + !* arc of circle + R=RPAR(3) + THETA=RPAR(4) + XNEW=CX+R*COS(THETA) + YNEW=CY+R*SIN(THETA) + DIST=FUNC(XNEW,YNEW,X,Y) + IF(DIST<=EPS2)THEN + IEND=1 + RETURN + ELSE + THETA=RPAR(5) + XNEW=CX+R*COS(THETA) + YNEW=CY+R*SIN(THETA) + DIST2=FUNC(XNEW,YNEW,X,Y) + ENDIF + ELSE + CALL XABORT('SAL142: not implemented') + ENDIF + ! + IF(DIST2<=EPS2)THEN + DIST=DIST2 + IEND=2 + RETURN + ELSE + IF(DIST<=DIST2)THEN + IEND=-1 + ELSE + DIST=DIST2 + IEND=-2 + ENDIF + ENDIF + ! + END SUBROUTINE SAL142 + ! + SUBROUTINE SAL160(GG) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! analyse domain definition: 2D volumes, surfaces + ! - compute node volumes + ! - compute areas of 2d surfaces + ! - read medium data + ! + !Parameters: input/output + ! GG geometry descriptor + ! + !--------------------------------------------------------------------- + ! + USE SAL_GEOMETRY_TYPES, ONLY : G_BC_TYPE,NBMED + !**** + IMPLICIT NONE + TYPE(T_G_BASIC), INTENT(INOUT) :: GG + !**** + INTEGER :: INB,IMED + INTEGER, DIMENSION(GG%NB_NODE) :: DATAIN + !**** + ! SUBROUTINE SAL160_2(NB_ELEM,IPAR,RPAR,VOL2,ISURF2_ELEM,NB_SURF2,SURF2) + IF(GG%NB_SURF2==0) THEN + CALL SAL160_2(GG%NB_ELEM,GG%IPAR,GG%RPAR,GG%VOL_NODE,GG%ISURF2_ELEM, & + GG%NB_SURF2) + ELSE + CALL SAL160_2(GG%NB_ELEM,GG%IPAR,GG%RPAR,GG%VOL_NODE,GG%ISURF2_ELEM, & + GG%NB_SURF2,GG%SURF2) + ENDIF + ! + !* read medium per region + CALL SALGET(DATAIN,GG%NB_NODE,F_GEO,FOUT0,'media per node') + + ! number of media fixed to maximum of datain + NBMED = MAXVAL(DATAIN(1:GG%NB_NODE)) + ! + !* check and define med for code regions + DO INB=1,GG%NB_NODE + IMED=DATAIN(INB) + IF(IMED>NBMED.OR.IMED<0)THEN + WRITE(*,*) 'medium : ',IMED + WRITE(*,*) 'inb, nbmed, nbnode : ',INB,NBMED,GG%NB_NODE + CALL XABORT('SAL160: wrong medium in a region') + ENDIF + GG%MED(INB)=IMED + ENDDO + ! + END SUBROUTINE SAL160 + ! + SUBROUTINE SAL160_2(NB_ELEM,IPAR,RPAR,VOL2,ISURF2_ELEM,NB_SURF2,SURF2) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! compute 2D volumes and surfaces + ! - compute node volumes + ! - compute 2D surface areas + ! + !Parameters: input + ! NB_ELEM number of elements + ! NB_NODE number of nodes + ! IPAR integer descriptors for elements + ! RPAR floating point descriptors for elements + ! ISURF2_ELEM 2D surface nber per elem + ! NB_SURF2 number of 2D surface + ! + !Parameters: output + ! VOL2 2D volumes of node + ! SURF2 2D areas of node + ! + !--------------------------------------------------------------------- + ! + USE PRECISION_AND_KINDS, ONLY : PDB + USE SAL_GEOMETRY_TYPES, ONLY : G_BC_TYPE + !**** + IMPLICIT NONE + INTEGER, INTENT(IN) :: NB_ELEM + INTEGER, INTENT(IN), DIMENSION(:,:) :: IPAR + REAL(PDB), INTENT(IN), DIMENSION(:,:) :: RPAR + REAL(PDB), INTENT(OUT), DIMENSION(:) :: VOL2 + INTEGER, INTENT(IN), DIMENSION(:) :: ISURF2_ELEM + INTEGER, INTENT(IN) :: NB_SURF2 + REAL(PDB), INTENT(OUT), OPTIONAL, DIMENSION(:) :: SURF2 + !**** + INTEGER :: ELEM,NODEBC,NODE,ISURF + LOGICAL :: LGBC + REAL(PDB) :: AUX + !**** + ! initiation + VOL2=0._PDB + IF(NB_SURF2 > 0) SURF2=0._PDB + DO ELEM=1,NB_ELEM + !* compute volume of node and add to volume of region (local) + CALL SAL161(IPAR(1,ELEM),RPAR(:,ELEM),AUX) + NODEBC=IPAR(2,ELEM) + LGBC=NODEBC<=0 + IF(.NOT.LGBC) VOL2(NODEBC)=VOL2(NODEBC)+AUX + NODE=IPAR(3,ELEM) + IF(NODE>0)THEN + VOL2(NODE)=VOL2(NODE)-AUX + ELSE + IF(LGBC) CALL XABORT('SAL160_2: isolated element') + LGBC=.TRUE. + NODEBC=NODE + ENDIF + IF(LGBC) THEN + IF(NODEBC==G_BC_TYPE(-1).OR.NODEBC==G_BC_TYPE(0).OR.NODEBC==G_BC_TYPE(1))THEN + ! compute external surface (loaded in total order number) + ISURF=ISURF2_ELEM(ELEM) + IF(ISURF==0) CALL XABORT('SAL160_2: wrong relation of element - surf ') + CALL SAL162(IPAR(1,ELEM),RPAR(:,ELEM),SURF2(ISURF)) + ENDIF + ENDIF + ENDDO + ! + END SUBROUTINE SAL160_2 + ! + SUBROUTINE SAL161(TYPE,RPAR,VOL2) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! computes 'volume' between an element and the x axis + ! + !Parameters: input + ! TYPE type of element + ! RPAR floating point descriptors for elements + ! + !Parameters: output + ! VOL2 '2D area' between the element and the horizontal axis + ! + !--------------------------------------------------------------------- + ! + IMPLICIT NONE + INTEGER, INTENT(IN) :: TYPE + REAL(PDB), INTENT(IN), DIMENSION (:) :: RPAR + REAL(PDB), INTENT(OUT) :: VOL2 + ! DIMENSION RPAR(*) + !**** + REAL(PDB) :: YC,EX,EY,R,PHI1,PHI2,COS1,COS2 + !**** + ! volume is added to node- and substracted from node+ + YC=RPAR(2) + IF(TYPE==1)THEN + ! segment: + EX=RPAR(3) + EY=RPAR(4) + VOL2=EX*(YC+EY/2.) + ELSEIF(TYPE==2)THEN + ! whole circle + VOL2=PI*RPAR(3)*RPAR(3) + ELSEIF(TYPE==3)THEN + ! arc of circle: + R=RPAR(3) + PHI1=RPAR(4) + PHI2=RPAR(5) + COS1=COS(PHI1) + COS2=COS(PHI2) + VOL2=R*(YC*(COS1-COS2)+(R/2.0)*(PHI2-PHI1+ & + & (SIN(PHI1)*COS1-SIN(PHI2)*COS2))) + ELSE + CALL XABORT('SAL161: not implemented') + ENDIF + ! + END SUBROUTINE SAL161 + ! + SUBROUTINE SAL162(TYPE,RPAR,SURF2) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! computes surface of a boundary element + ! + !Parameters: input + ! TYPE type of element + ! RPAR floating point descriptors for elements + ! + !Parameters: output + ! SURF2 '2D length' of element + ! + !--------------------------------------------------------------------- + ! + IMPLICIT NONE + INTEGER, INTENT(IN) :: TYPE + REAL(PDB), INTENT(IN), DIMENSION (:) :: RPAR + REAL(PDB), INTENT(OUT) :: SURF2 + !**** + IF(TYPE==1)THEN + ! segment + SURF2=RPAR(5) + ELSEIF(TYPE<=3)THEN + ! arc of circle + SURF2=(RPAR(5)-RPAR(4))*RPAR(3) + ELSE + CALL XABORT('SAL162: not implemented') + ENDIF + ! + END SUBROUTINE SAL162 + ! + SUBROUTINE SAL170(GG) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! prints out volume, surface and medium info for 2D macros + ! + !Parameters: input/output + ! GG geometry descriptor + ! + !--------------------------------------------------------------------- + ! + USE SAL_GEOMETRY_TYPES, ONLY : G_BC_TYPE + USE SAL_TRACKING_TYPES, ONLY : PRTIND + !**** + IMPLICIT NONE + TYPE(T_G_BASIC), INTENT(INOUT) :: GG + INTEGER, PARAMETER :: FOUT =6 + + !**** + IF(PRTIND == 1) THEN + WRITE(FOUT,'(//,10x,''2D geometry'',/,10X,11(''=''),//, & + &I8,'' regions'',/, & + &I8,'' external surfaces'',//)') GG%NB_NODE,GG%NB_SURF2 + ENDIF + ! + END SUBROUTINE SAL170 + ! + SUBROUTINE SALSYM(X1,Y1,X2,Y2,X0,Y0,X4,Y4) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! set the symmetric point (x4,y4) of (x0,y0) relative to symmetry axis + ! (x1,y1)->(x2,y2) + ! + !Parameters: input + ! X1 abscissa coordinate of a point on the symmetry axis + ! Y1 ordinate coordinate of a point on the symmetry axis + ! X2 abscissa coordinate of a point on the symmetry axis + ! Y2 ordinate coordinate of a point on the symmetry axis + ! X0 abscissa coordinate of the point to mirror + ! Y0 ordinate coordinate of the point to mirror + ! + !Parameters: output + ! X4 abscissa coordinate of the symmetric point + ! Y4 ordinate coordinate of the symmetric point + ! + !--------------------------------------------------------------------- + ! + IMPLICIT NONE + REAL(PDB),INTENT(IN) :: X1,Y1,X2,Y2,X0,Y0 + REAL(PDB),INTENT(OUT) :: X4,Y4 + + REAL(PDB) :: A,B,C,DEN,X3,Y3 + A=Y2-Y1; B=X1-X2; C=X2*Y1-X1*Y2; + DEN=A*A+B*B; + IF(DEN==0._PDB) CALL XABORT('SALSYM: division by zero') + X3=(B*(B*X0-A*Y0)-A*C)/DEN; + Y3=(A*(-B*X0+A*Y0)-B*C)/DEN; + X4=X0+2._PDB*(X3-X0); Y4=Y0+2._PDB*(Y3-Y0); + END SUBROUTINE SALSYM + ! + SUBROUTINE SALROT(X0,Y0,THETA,X3,Y3,X4,Y4) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! set the symmetric point (x4,y4) of (x3,y3) relative to the rotation + ! center (x1,y1) with angle theta. + ! + !Parameters: input + ! X0 abscissa coordinate of the rotation center + ! Y0 ordinate coordinate of the rotation center + ! THETA rotation angle + ! X3 abscissa coordinate of the point to mirror + ! Y3 ordinate coordinate of the point to mirror + ! + !Parameters: output + ! X4 abscissa coordinate of the symmetric point + ! Y4 ordinate coordinate of the symmetric point + ! + !--------------------------------------------------------------------- + ! + IMPLICIT NONE + REAL(PDB),INTENT(IN) :: X0,Y0,THETA,X3,Y3 + REAL(PDB),INTENT(OUT) :: X4,Y4 + + REAL(PDB) :: A,B + IF(THETA==0.0_PDB) THEN + X4=X3; Y4=Y3 + ELSE + A=X3-X0; B=Y3-Y0 + X4=X0+A*COS(THETA)-B*SIN(THETA); Y4=Y0+A*SIN(THETA)+B*COS(THETA) + ENDIF + END SUBROUTINE SALROT + ! + SUBROUTINE SALFOLD_0(GG,IPASS,IB,NBBCDA,ALIGN,LFOLD,IFOLD) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! unfold the domain with reflection relative to axis AXIS_XY + ! + !Parameters: input + ! IB actual unfolding axis + ! NBBCDA number of perimeters before unfolding + ! ALIGN unfolding axes + ! LFOLD identification flag to all unfolding axes + ! + !Parameters: input/output + ! GG geometry descriptor + ! + !Parameters: output + ! IFOLD folded element indices corresponding to unfolded ones + ! + !--------------------------------------------------------------------- + ! + USE SAL_GEOMETRY_TYPES, ONLY : NIPAR,NRPAR,LENGTHX,LENGTHY + USE SAL_NUMERIC_MOD, ONLY : FINDLC,DET_ROSETTA + IMPLICIT NONE + INTEGER, INTENT(IN) :: IPASS,IB,NBBCDA + LOGICAL, DIMENSION(NBBCDA), INTENT(IN) :: LFOLD + REAL(PDB), DIMENSION(3,3,NBBCDA), INTENT(INOUT) :: ALIGN + TYPE(T_G_BASIC), INTENT(INOUT) :: GG + INTEGER, DIMENSION(:), INTENT(OUT) :: IFOLD + ! + ! AXIS_XY values of AXIS_X1, AXIS_Y1, AXIS_X2 and AXIS_Y2 for the + ! reflecting axis + INTEGER :: ELEM,TYPE,OK,TMP_NB_ELEM,TMP_NBBCDA,I,J,IBC,INDBC,IAUX + INTEGER, DIMENSION(3) :: IPAR_TMP + REAL(PDB), DIMENSION(4) :: AXIS_XY + REAL(PDB), DIMENSION(6) :: RPAR_TMP + REAL(PDB),PARAMETER :: EPS=1.0E-5_PDB + REAL(PDB) :: X1,X2,X4,Y1,Y2,Y4,DX4,DY4,RAD,THETA1,THETA2,X1B,Y1B,X4B, & + Y4B,XMIN,YMIN,XMAX,YMAX,PHI1,PHI2,DELPHI,DET1,DET2 + ! + ! allocatable arrays + INTEGER, ALLOCATABLE, DIMENSION(:) :: PERIM_ELEM + LOGICAL, ALLOCATABLE, DIMENSION(:) :: ISPERIM + INTEGER, POINTER, DIMENSION(:,:) :: TMP_IPAR + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: I2 + REAL(PDB), ALLOCATABLE, DIMENSION(:) :: ANGLE,ALBEDO + REAL(PDB), POINTER, DIMENSION(:,:) :: TMP_RPAR + REAL(PDB), ALLOCATABLE, DIMENSION(:,:,:) :: ALIGN2 + TYPE(T_SALBCDATA), POINTER, DIMENSION(:) :: TMP_BCDATAREAD + ! + ! compute size of the unfold geometry + XMIN=1.E10_PDB; YMIN=1.E10_PDB; XMAX=-1.E10_PDB; YMAX=-1.E10_PDB; + DO ELEM=1,GG%NB_ELEM + TYPE=GG%IPAR(1,ELEM) + IF(TYPE==1) THEN + X1=GG%RPAR(1,ELEM); Y1=GG%RPAR(2,ELEM); + XMIN=MIN(XMIN,X1); YMIN=MIN(YMIN,Y1); XMAX=MAX(XMAX,X1); YMAX=MAX(YMAX,Y1); + X2=X1+GG%RPAR(3,ELEM); Y2=Y1+GG%RPAR(4,ELEM); + XMIN=MIN(XMIN,X2); YMIN=MIN(YMIN,Y2); XMAX=MAX(XMAX,X2); YMAX=MAX(YMAX,Y2); + ENDIF + ENDDO + LENGTHX=XMAX-XMIN; LENGTHY=YMAX-YMIN; + ! + ! allocate new surfacic element containers + XMIN=1.E10_PDB; YMIN=1.E10_PDB; XMAX=-1.E10_PDB; YMAX=-1.E10_PDB; + ALLOCATE(TMP_IPAR(NIPAR,3*GG%NB_ELEM), TMP_RPAR(NRPAR,3*GG%NB_ELEM), & + I2(2,GG%NB_ELEM), STAT=OK) + IF(OK/=0) CALL XABORT('SALFOLD_0: not enough memory') + TMP_IPAR(:,:)=0; TMP_RPAR(:,:)=0._PDB; + ! + ! loop over old elements + TMP_NB_ELEM=0 + THETA1=0._PDB; THETA2=0._PDB; + I2(:2,:GG%NB_ELEM)=0 + AXIS_XY(1)=ALIGN(1,1,IB) ; AXIS_XY(2)=ALIGN(1,2,IB) + AXIS_XY(3)=ALIGN(2,1,IB) ; AXIS_XY(4)=ALIGN(2,2,IB) + OUT1: DO ELEM=1,GG%NB_ELEM + TYPE=GG%IPAR(1,ELEM) + X1=GG%RPAR(1,ELEM); Y1=GG%RPAR(2,ELEM); RAD=GG%RPAR(3,ELEM) + IF(TYPE==1) THEN + XMIN=MIN(XMIN,X1); YMIN=MIN(YMIN,Y1); XMAX=MAX(XMAX,X1); YMAX=MAX(YMAX,Y1); + X2=X1+GG%RPAR(3,ELEM); Y2=Y1+GG%RPAR(4,ELEM) + ! Cycle if this element is sitting on an unfolding axe + DO IBC=1,NBBCDA + IF(.NOT.LFOLD(IBC)) CYCLE + IF((IPASS.EQ.1).AND.(IBC.NE.IB)) CYCLE + ALIGN(3,1,IBC)=X1; ALIGN(3,2,IBC)=Y1 + DET1 = DET_ROSETTA(ALIGN(1,1,IBC),3) + ALIGN(3,1,IBC)=X2; ALIGN(3,2,IBC)=Y2; + DET2 = DET_ROSETTA(ALIGN(1,1,IBC),3) + IF((ABS(DET1).LE.1.0E-4).AND.(ABS(DET2).LE.1.0E-4)) CYCLE OUT1 + ENDDO + ! + CALL SALSYM(AXIS_XY(1),AXIS_XY(2),AXIS_XY(3),AXIS_XY(4),X1,Y1,X4,Y4) + CALL SALSYM(AXIS_XY(1),AXIS_XY(2),AXIS_XY(3),AXIS_XY(4),X2,Y2,DX4,DY4) + ELSE IF(TYPE==2) THEN + CALL SALSYM(AXIS_XY(1),AXIS_XY(2),AXIS_XY(3),AXIS_XY(4),X1,Y1,X4,Y4) + THETA1=0._PDB; THETA2=0._PDB; + ELSE IF(TYPE==3) THEN + CALL SALSYM(AXIS_XY(1),AXIS_XY(2),AXIS_XY(3),AXIS_XY(4),X1,Y1,X4,Y4) + X1B=X1+RAD*COS(GG%RPAR(4,ELEM)); Y1B=Y1+RAD*SIN(GG%RPAR(4,ELEM)); + CALL SALSYM(AXIS_XY(1),AXIS_XY(2),AXIS_XY(3),AXIS_XY(4),X1B,Y1B,X4B,Y4B) + IF((ABS(X4B-X4) 0._PDB)) THEN + THETA1=PI/2._PDB + ELSE IF((ABS(X4B-X4) 0._PDB) THEN + THETA1=ATAN((Y4B-Y4)/(X4B-X4)) + ELSE + THETA1=ATAN((Y4B-Y4)/(X4B-X4))+PI + ENDIF + X1B=X1+RAD*COS(GG%RPAR(5,ELEM)); Y1B=Y1+RAD*SIN(GG%RPAR(5,ELEM)); + CALL SALSYM(AXIS_XY(1),AXIS_XY(2),AXIS_XY(3),AXIS_XY(4),X1B,Y1B,X4B,Y4B) + IF((ABS(X4B-X4) 0._PDB)) THEN + THETA2=PI/2._PDB + ELSE IF((ABS(X4B-X4) 0._PDB) THEN + THETA2=ATAN((Y4B-Y4)/(X4B-X4)) + ELSE + THETA2=ATAN((Y4B-Y4)/(X4B-X4))+PI + ENDIF + ELSE + WRITE(*,*) " elem=",ELEM," type=",TYPE + CALL XABORT('SALFOLD_0: invalid type of surfacic element') + ENDIF + IPAR_TMP(:3)=0 + RPAR_TMP(:6)=0_PDB + RPAR_TMP(1)=X4; RPAR_TMP(2)=Y4; + IPAR_TMP(1)=TYPE; + IF(TYPE==1) THEN + RPAR_TMP(3)=DX4-X4; RPAR_TMP(4)=DY4-Y4; + RPAR_TMP(5)=SQRT(RPAR_TMP(3)**2+RPAR_TMP(4)**2) + XMIN=MIN(XMIN,X4); YMIN=MIN(YMIN,Y4); XMAX=MAX(XMAX,X4); YMAX=MAX(YMAX,Y4); + XMIN=MIN(XMIN,DX4); YMIN=MIN(YMIN,DY4); XMAX=MAX(XMAX,DX4); YMAX=MAX(YMAX,DY4); + IPAR_TMP(2)=GG%IPAR(3,ELEM); IPAR_TMP(3)=GG%IPAR(2,ELEM); + ELSE IF((TYPE==2).OR.(TYPE==3)) THEN + RPAR_TMP(3)=GG%RPAR(3,ELEM) ! RADIUS + IF(THETA2>THETA1) THETA1=THETA1+2._PDB*PI + PHI1=THETA2; DELPHI=THETA1-THETA2; + IF(DELPHI>0._PDB)THEN + PHI2=PHI1+DELPHI + ELSE + PHI2=PHI1 + PHI1=PHI1+DELPHI + ENDIF + IF(TYPE==3)THEN + ! arc of circle: put phi1 within 0 and 2*pi + IF(PHI1>2._PDB*PI)THEN + IAUX=INT(PHI1/(2._PDB*PI)) + DELPHI=(2._PDB*PI)*IAUX + PHI1=PHI1-DELPHI ; PHI2=PHI2-DELPHI + ELSEIF(PHI1<0._PDB)THEN + IAUX=INT((-PHI1+1.D-7)/(2._PDB*PI))+1 + DELPHI=(2._PDB*PI)*IAUX + PHI1=PHI1+DELPHI ; PHI2=PHI2+DELPHI + ENDIF + ENDIF + RPAR_TMP(4)=PHI1; RPAR_TMP(5)=PHI2; ! ANGLES + IPAR_TMP(2)=GG%IPAR(2,ELEM); IPAR_TMP(3)=GG%IPAR(3,ELEM) + ENDIF + RPAR_TMP(6)=0._PDB + IF(IPASS==2) THEN + ! remove identical elements at pass 2 + DO I=1,TMP_NB_ELEM + IF((ABS(TMP_RPAR(1,I)-RPAR_TMP(1))<=10.0*EPS).AND. & + (ABS(TMP_RPAR(2,I)-RPAR_TMP(2))<=10.0*EPS).AND. & + (ABS(TMP_RPAR(3,I)-RPAR_TMP(3))<=10.0*EPS).AND. & + (ABS(TMP_RPAR(4,I)-RPAR_TMP(4))<=10.0*EPS).AND. & + (ABS(TMP_RPAR(5,I)-RPAR_TMP(5))<=10.0*EPS)) THEN + CYCLE OUT1 + ENDIF + ENDDO + ENDIF + TMP_NB_ELEM=TMP_NB_ELEM+1 + IF(TMP_NB_ELEM>3*GG%NB_ELEM) CALL XABORT('SALFOLD_0: tmp_nb_elem overflow(1)') + TMP_IPAR(:3,TMP_NB_ELEM)=IPAR_TMP(:3) + TMP_RPAR(:6,TMP_NB_ELEM)=RPAR_TMP(:6) + I2(2,ELEM)=TMP_NB_ELEM + IF(IPASS==2) THEN + ! remove identical elements at pass 2 + DO I=1,TMP_NB_ELEM + IF((ABS(TMP_RPAR(1,I)-GG%RPAR(1,ELEM))<=10.0*EPS).AND. & + (ABS(TMP_RPAR(2,I)-GG%RPAR(2,ELEM))<=10.0*EPS).AND. & + (ABS(TMP_RPAR(3,I)-GG%RPAR(3,ELEM))<=10.0*EPS).AND. & + (ABS(TMP_RPAR(4,I)-GG%RPAR(4,ELEM))<=10.0*EPS).AND. & + (ABS(TMP_RPAR(5,I)-GG%RPAR(5,ELEM))<=10.0*EPS)) THEN + CYCLE OUT1 + ENDIF + ENDDO + ENDIF + TMP_NB_ELEM=TMP_NB_ELEM+1 + IF(TMP_NB_ELEM>3*GG%NB_ELEM) CALL XABORT('SALFOLD_0: tmp_nb_elem overflow(2)') + TMP_IPAR(:,TMP_NB_ELEM)=GG%IPAR(:,ELEM) + TMP_RPAR(:,TMP_NB_ELEM)=GG%RPAR(:,ELEM) + I2(1,ELEM)=TMP_NB_ELEM + ENDDO OUT1 + DEALLOCATE(GG%IPAR,GG%RPAR) + DO ELEM=1,GG%NB_ELEM + IF(I2(1,ELEM).GT.2*GG%NB_ELEM) CALL XABORT('SALFOLD_0: IFOLD overflow') + IF(I2(1,ELEM).NE.0) IFOLD(I2(1,ELEM))=ELEM + IF(I2(2,ELEM).NE.0) IFOLD(I2(2,ELEM))=ELEM + ENDDO + GG%IPAR=>TMP_IPAR; GG%RPAR=>TMP_RPAR; + GG%NB_ELEM=TMP_NB_ELEM + ! + ! loop over boundary conditions + ALLOCATE(ISPERIM(GG%NB_ELEM),ALIGN2(3,3,GG%NB_ELEM),ANGLE(GG%NB_ELEM), & + & ALBEDO(GG%NB_ELEM),PERIM_ELEM(GG%NB_ELEM)) + ALIGN2(:3,3,:GG%NB_ELEM)=1.0_PDB + PERIM_ELEM(:GG%NB_ELEM)=0 + ISPERIM(:GG%NB_ELEM)=.FALSE. + TMP_NBBCDA=0 + DO IBC=1,GG%NBBCDA + DO I=1,GG%BCDATAREAD(IBC)%NBER + INDBC=GG%BCDATAREAD(IBC)%ELEMNB(I) + IF(INDBC==0) CYCLE + IF(I2(1,INDBC)/=0) ISPERIM(I2(1,INDBC))=.TRUE. + IF(I2(2,INDBC)/=0) ISPERIM(I2(2,INDBC))=.TRUE. + ENDDO + ENDDO + ITER0: DO ELEM=1,GG%NB_ELEM + IF(.NOT.ISPERIM(ELEM)) CYCLE + X1=GG%RPAR(1,ELEM); Y1=GG%RPAR(2,ELEM); + X2=X1+GG%RPAR(3,ELEM); Y2=Y1+GG%RPAR(4,ELEM); + DO J=1,TMP_NBBCDA + ALIGN2(3,1,J)=X1; ALIGN2(3,2,J)=Y1; + DET1 = DET_ROSETTA(ALIGN2(1,1,J),3) + ALIGN2(3,1,J)=X2; ALIGN2(3,2,J)=Y2; + DET2 = DET_ROSETTA(ALIGN2(1,1,J),3) + IF((ABS(DET1).LE.1.0E-4).AND.(ABS(DET2).LE.1.0E-4)) THEN + PERIM_ELEM(ELEM) = J + CYCLE ITER0 + ENDIF + ENDDO + TMP_NBBCDA=TMP_NBBCDA+1 + PERIM_ELEM(ELEM) = TMP_NBBCDA + ANGLE(TMP_NBBCDA)=ATAN((Y2-Y1)/(X2-X1)) + IF(ABS(ANGLE(TMP_NBBCDA)).LE.1.0E-5) ANGLE(TMP_NBBCDA)=0.0 + ALIGN2(1,1,TMP_NBBCDA)=X1; ALIGN2(1,2,TMP_NBBCDA)=Y1 + ALIGN2(2,1,TMP_NBBCDA)=X2; ALIGN2(2,2,TMP_NBBCDA)=Y2 + ! Recover albedo from folded geometry + ALBEDO(TMP_NBBCDA)=1.0 + DO IBC=1,GG%NBBCDA + J = FINDLC(GG%BCDATAREAD(IBC)%ELEMNB,ELEM) + IF(J.EQ.1) THEN + ALBEDO(TMP_NBBCDA)=GG%BCDATAREAD(IBC)%BCDATA(6) + EXIT + ENDIF + ENDDO + ENDDO ITER0 + ALLOCATE(TMP_BCDATAREAD(TMP_NBBCDA)) + DO IBC=1,TMP_NBBCDA + TMP_BCDATAREAD(IBC)%NBER = COUNT(PERIM_ELEM(:GG%NB_ELEM) == IBC) + ALLOCATE(TMP_BCDATAREAD(IBC)%ELEMNB(TMP_BCDATAREAD(IBC)%NBER)) + TMP_BCDATAREAD(IBC)%SALTYPE = 0 + J=0 + DO I=1,GG%NB_ELEM + IF(PERIM_ELEM(I) == IBC) THEN + J=J+1 + TMP_BCDATAREAD(IBC)%ELEMNB(J) = I + ENDIF + ENDDO + TMP_BCDATAREAD(IBC)%BCDATA(1) = ALIGN2(1,1,IBC) + TMP_BCDATAREAD(IBC)%BCDATA(2) = ALIGN2(1,2,IBC) + TMP_BCDATAREAD(IBC)%BCDATA(3) = COS(ANGLE(IBC)) + TMP_BCDATAREAD(IBC)%BCDATA(4) = SIN(ANGLE(IBC)) + TMP_BCDATAREAD(IBC)%BCDATA(5) = ANGLE(IBC) + TMP_BCDATAREAD(IBC)%BCDATA(6) = ALBEDO(IBC) + ENDDO + DEALLOCATE(I2,PERIM_ELEM,ALBEDO,ANGLE,ALIGN2,ISPERIM) + DEALLOCATE(GG%BCDATAREAD) + GG%BCDATAREAD=>TMP_BCDATAREAD + GG%NBBCDA=TMP_NBBCDA + GG%ALBEDO=1.D0 + END SUBROUTINE SALFOLD_0 + ! + SUBROUTINE SALFOLD_1(HSYM,GG) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! unfold the domain with reflection + ! + !Parameters: input + ! HSYM: type of symmetry: 'DIAG': diagonal symmetry; 'SYMX': symmetry + ! relative to X axis; 'SYMY': symmetry relative to Y axis; + ! 'SA60': SA60 symmetry; 'S30': S30 symmetry + ! + !Parameters: input/output + ! GG geometry descriptor + ! + !--------------------------------------------------------------------- + ! + USE SAL_GEOMETRY_TYPES, ONLY : NIPAR,NRPAR,LENGTHX,LENGTHY + USE SAL_NUMERIC_MOD, ONLY : FINDLC,DET_ROSETTA + IMPLICIT NONE + CHARACTER(LEN=4),INTENT(IN) :: HSYM + TYPE(T_G_BASIC), INTENT(INOUT) :: GG + ! + INTEGER :: ELEM,TYPE,OK,TMP_NB_ELEM,TMP_NBBCDA,I,J,IBC,INDBC,IAUX,ISYM,NSYM + REAL(PDB),PARAMETER :: EPS=1.0E-5_PDB + REAL(PDB) :: AXIS_X1(2),AXIS_X2(2),AXIS_Y1(2),AXIS_Y2(2) + REAL(PDB) :: X1,X2,X4,Y1,Y2,Y4,DX4,DY4,RAD,THETA1,THETA2,X1B,Y1B,X4B, & + Y4B,XMIN,YMIN,XMAX,YMAX,PHI1,PHI2,DELPHI,DET1,DET2 + LOGICAL :: NOCOPY(2) + ! + ! allocatable arrays + INTEGER, ALLOCATABLE, DIMENSION(:) :: PERIM_ELEM + LOGICAL, ALLOCATABLE, DIMENSION(:) :: ISPERIM + INTEGER, POINTER, DIMENSION(:,:) :: TMP_IPAR + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: I2 + REAL(PDB), ALLOCATABLE, DIMENSION(:) :: ANGLE,ALBEDO + REAL(PDB), POINTER, DIMENSION(:,:) :: TMP_RPAR + REAL(PDB), ALLOCATABLE, DIMENSION(:,:,:) :: ALIGN + TYPE(T_SALBCDATA), POINTER, DIMENSION(:) :: TMP_BCDATAREAD + ! + ! compute size of the unfold geometry + XMIN=1.E10_PDB; YMIN=1.E10_PDB; XMAX=-1.E10_PDB; YMAX=-1.E10_PDB; + DO ELEM=1,GG%NB_ELEM + TYPE=GG%IPAR(1,ELEM) + IF(TYPE==1) THEN + X1=GG%RPAR(1,ELEM); Y1=GG%RPAR(2,ELEM); + XMIN=MIN(XMIN,X1); YMIN=MIN(YMIN,Y1); XMAX=MAX(XMAX,X1); YMAX=MAX(YMAX,Y1); + X2=X1+GG%RPAR(3,ELEM); Y2=Y1+GG%RPAR(4,ELEM); + XMIN=MIN(XMIN,X2); YMIN=MIN(YMIN,Y2); XMAX=MAX(XMAX,X2); YMAX=MAX(YMAX,Y2); + ENDIF + ENDDO + LENGTHX=XMAX-XMIN; LENGTHY=YMAX-YMIN; + ! + NSYM=1 + IF(HSYM=='SYMX') THEN ! define symmetry axis + AXIS_X1(1)=0._PDB; AXIS_X2(1)=100._PDB; AXIS_Y1(1)=0._PDB; AXIS_Y2(1)=0._PDB; + ELSE IF(HSYM=='SYMY') THEN + AXIS_X1(1)=0._PDB; AXIS_X2(1)=0._PDB; AXIS_Y1(1)=0._PDB; AXIS_Y2(1)=100._PDB; + ELSE IF(HSYM=='DIAG') THEN + AXIS_X1(1)=0._PDB; AXIS_X2(1)=100._PDB; AXIS_Y1(1)=0._PDB; AXIS_Y2(1)=100._PDB; + ELSE IF(HSYM=='SA60') THEN + ! the hexagon side is on south + NSYM=2 + AXIS_X1(1)=XMIN; AXIS_Y1(1)=YMIN; AXIS_X2(1)=XMIN+0.5_PDB*LENGTHX + AXIS_Y2(1)=YMIN+0.5_PDB*SQRT(3._PDB)*LENGTHX + AXIS_X1(2)=XMIN+LENGTHX; AXIS_Y1(2)=YMIN; AXIS_X2(2)=XMIN+0.5_PDB*LENGTHX + AXIS_Y2(2)=YMIN+0.5_PDB*SQRT(3._PDB)*LENGTHX + ELSE IF(HSYM=='SB60') THEN + ! the hexagon side is on north-east + NSYM=2 + AXIS_X1(1)=XMIN; AXIS_Y1(1)=YMIN; AXIS_X2(1)=XMIN+0.5_PDB*LENGTHX + AXIS_Y2(1)=YMIN+0.5_PDB*SQRT(3._PDB)*LENGTHX + AXIS_X1(2)=XMIN; AXIS_Y1(2)=YMIN; AXIS_X2(2)=XMIN + AXIS_Y2(2)=YMIN+0.5_PDB*SQRT(3._PDB)*LENGTHX + ELSE IF(HSYM=='S30') THEN + AXIS_X1(1)=XMIN; AXIS_Y1(1)=YMIN; AXIS_X2(1)=XMIN+0.75_PDB*LENGTHX + AXIS_Y2(1)=YMIN+0.25_PDB*SQRT(3._PDB)*LENGTHX + ELSE IF(HSYM=='SYMH') THEN + AXIS_X1(1)=XMIN ; AXIS_Y1(1)=YMIN+0.25_PDB*SQRT(3._PDB)*LENGTHX + AXIS_X2(1)=XMIN+LENGTHX ; AXIS_Y2(1)=AXIS_Y1(1) + ELSE + CALL XABORT('SALFOLD_1: invalid type of symmetry axis') + ENDIF + XMIN=1.E10_PDB; YMIN=1.E10_PDB; XMAX=-1.E10_PDB; YMAX=-1.E10_PDB; + ! + ! allocate new surfacic element containers + ALLOCATE(TMP_IPAR(NIPAR,3*GG%NB_ELEM), TMP_RPAR(NRPAR,3*GG%NB_ELEM), & + I2(3,GG%NB_ELEM), STAT=OK) + IF(OK/=0) CALL XABORT('SALFOLD_1: not enough memory') + TMP_IPAR(:,:)=0; TMP_RPAR(:,:)=0._PDB; + ! + ! loop over old elements + TMP_NB_ELEM=0 + THETA1=0._PDB; THETA2=0._PDB; + DO ELEM=1,GG%NB_ELEM + I2(:,ELEM)=0 + TYPE=GG%IPAR(1,ELEM) + NOCOPY(:2)=.FALSE. + DO ISYM=1,NSYM + X1=GG%RPAR(1,ELEM); Y1=GG%RPAR(2,ELEM); RAD=GG%RPAR(3,ELEM) + IF(TYPE==1) THEN + XMIN=MIN(XMIN,X1); YMIN=MIN(YMIN,Y1); XMAX=MAX(XMAX,X1); YMAX=MAX(YMAX,Y1); + X2=X1+GG%RPAR(3,ELEM); Y2=Y1+GG%RPAR(4,ELEM); + CALL SALSYM(AXIS_X1(ISYM),AXIS_Y1(ISYM),AXIS_X2(ISYM),AXIS_Y2(ISYM),X1,Y1,X4,Y4) + CALL SALSYM(AXIS_X1(ISYM),AXIS_Y1(ISYM),AXIS_X2(ISYM),AXIS_Y2(ISYM),X2,Y2,DX4,DY4) + NOCOPY(ISYM)=ABS(X1-X4)<10.0*EPS .AND. ABS(Y1-Y4)<10.0*EPS .AND. & + ABS(X2-DX4)<10.0*EPS .AND. ABS(Y2-DY4)<10.0*EPS + IF((HSYM=='SB60').AND.(ISYM==2)) THEN + NOCOPY(2)=(ABS(2._PDB*ABS(Y1-YMIN)-ABS(X4-X1)*SQRT(3._PDB))<10.0*EPS .AND. & + ABS(Y1-Y4)<10.0*EPS .AND. ABS(2._PDB*ABS(Y2-YMIN)-ABS(DX4-X2)*SQRT(3._PDB))<10.0*EPS & + .AND. ABS(Y2-DY4)<10.0*EPS) + ENDIF + IF(NOCOPY(ISYM)) CYCLE + ELSE IF(TYPE==2) THEN + CALL SALSYM(AXIS_X1(ISYM),AXIS_Y1(ISYM),AXIS_X2(ISYM),AXIS_Y2(ISYM),X1,Y1,X4,Y4) + THETA1=0._PDB; THETA2=0._PDB; + ELSE IF(TYPE==3) THEN + CALL SALSYM(AXIS_X1(ISYM),AXIS_Y1(ISYM),AXIS_X2(ISYM),AXIS_Y2(ISYM),X1,Y1,X4,Y4) + X1B=X1+RAD*COS(GG%RPAR(4,ELEM)); Y1B=Y1+RAD*SIN(GG%RPAR(4,ELEM)); + CALL SALSYM(AXIS_X1(ISYM),AXIS_Y1(ISYM),AXIS_X2(ISYM),AXIS_Y2(ISYM),X1B,Y1B,X4B,Y4B) + IF((ABS(X4B-X4) 0._PDB)) THEN + THETA1=PI/2._PDB + ELSE IF((ABS(X4B-X4) 0._PDB) THEN + THETA1=ATAN((Y4B-Y4)/(X4B-X4)) + ELSE + THETA1=ATAN((Y4B-Y4)/(X4B-X4))+PI + ENDIF + X1B=X1+RAD*COS(GG%RPAR(5,ELEM)); Y1B=Y1+RAD*SIN(GG%RPAR(5,ELEM)); + CALL SALSYM(AXIS_X1(ISYM),AXIS_Y1(ISYM),AXIS_X2(ISYM),AXIS_Y2(ISYM),X1B,Y1B,X4B,Y4B) + IF((ABS(X4B-X4) 0._PDB)) THEN + THETA2=PI/2._PDB + ELSE IF((ABS(X4B-X4) 0._PDB) THEN + THETA2=ATAN((Y4B-Y4)/(X4B-X4)) + ELSE + THETA2=ATAN((Y4B-Y4)/(X4B-X4))+PI + ENDIF + ELSE + WRITE(*,*) " elem=",ELEM," type=",TYPE," isym=",ISYM + CALL XABORT('SALFOLD_1: invalid type of surfacic element') + ENDIF + IF((TYPE==1).AND.(HSYM=='SB60').AND.(ISYM==1).AND.(ABS(Y1)<10.0*EPS).AND.(ABS(Y2)<10.0*EPS)) CYCLE + TMP_NB_ELEM=TMP_NB_ELEM+1 + IF(TMP_NB_ELEM>3*GG%NB_ELEM) CALL XABORT('SALFOLD_1: tmp_nb_elem overflow(1)') + I2(ISYM+1,ELEM)=TMP_NB_ELEM + TMP_RPAR(1,TMP_NB_ELEM)=X4; TMP_RPAR(2,TMP_NB_ELEM)=Y4; + TMP_IPAR(1,TMP_NB_ELEM)=TYPE; + IF(TYPE==1) THEN + TMP_RPAR(3,TMP_NB_ELEM)=DX4-X4; TMP_RPAR(4,TMP_NB_ELEM)=DY4-Y4; + TMP_RPAR(5,TMP_NB_ELEM)=SQRT(TMP_RPAR(3,TMP_NB_ELEM)**2+TMP_RPAR(4,TMP_NB_ELEM)**2) + XMIN=MIN(XMIN,X4); YMIN=MIN(YMIN,Y4); XMAX=MAX(XMAX,X4); YMAX=MAX(YMAX,Y4); + XMIN=MIN(XMIN,DX4); YMIN=MIN(YMIN,DY4); XMAX=MAX(XMAX,DX4); YMAX=MAX(YMAX,DY4); + TMP_IPAR(2,TMP_NB_ELEM)=GG%IPAR(3,ELEM); TMP_IPAR(3,TMP_NB_ELEM)=GG%IPAR(2,ELEM); + ELSE IF((TYPE==2).OR.(TYPE==3)) THEN + TMP_RPAR(3,TMP_NB_ELEM)=GG%RPAR(3,ELEM) ! RADIUS + IF(THETA2>THETA1) THETA1=THETA1+2._PDB*PI + PHI1=THETA2; DELPHI=THETA1-THETA2; + IF(DELPHI>0._PDB)THEN + PHI2=PHI1+DELPHI + ELSE + PHI2=PHI1 + PHI1=PHI1+DELPHI + ENDIF + IF(TYPE==3)THEN + ! arc of circle: put phi1 within 0 and 2*pi + IF(PHI1>2._PDB*PI)THEN + IAUX=INT(PHI1/(2._PDB*PI)) + DELPHI=(2._PDB*PI)*IAUX + PHI1=PHI1-DELPHI ; PHI2=PHI2-DELPHI + ELSEIF(PHI1<0._PDB)THEN + IAUX=INT((-PHI1+1.D-7)/(2._PDB*PI))+1 + DELPHI=(2._PDB*PI)*IAUX + PHI1=PHI1+DELPHI ; PHI2=PHI2+DELPHI + ENDIF + ENDIF + TMP_RPAR(4,TMP_NB_ELEM)=PHI1; TMP_RPAR(5,TMP_NB_ELEM)=PHI2; ! ANGLES + TMP_IPAR(2,TMP_NB_ELEM)=GG%IPAR(2,ELEM); TMP_IPAR(3,TMP_NB_ELEM)=GG%IPAR(3,ELEM) + ENDIF + TMP_RPAR(6,TMP_NB_ELEM)=0._PDB + ENDDO + IF((.NOT.NOCOPY(1)).AND.(.NOT.NOCOPY(2))) THEN + TMP_NB_ELEM=TMP_NB_ELEM+1 + IF(TMP_NB_ELEM>3*GG%NB_ELEM) CALL XABORT('SALFOLD_1: tmp_nb_elem overflow(2)') + TMP_IPAR(:,TMP_NB_ELEM)=GG%IPAR(:,ELEM) + TMP_RPAR(:,TMP_NB_ELEM)=GG%RPAR(:,ELEM) + I2(1,ELEM)=TMP_NB_ELEM + ENDIF + ENDDO + DEALLOCATE(GG%IPAR,GG%RPAR) + GG%IPAR=>TMP_IPAR; GG%RPAR=>TMP_RPAR; + GG%NB_ELEM=TMP_NB_ELEM + ! + ! translate the domain + DO ELEM=1,GG%NB_ELEM + GG%RPAR(1,ELEM)=GG%RPAR(1,ELEM)-XMIN + GG%RPAR(2,ELEM)=GG%RPAR(2,ELEM)-YMIN + ENDDO + LENGTHX=XMAX-XMIN ; LENGTHY=YMAX-YMIN ; + ! + ! loop over boundary conditions + TMP_NBBCDA=0 + ALLOCATE(ISPERIM(GG%NB_ELEM),ALIGN(3,3,GG%NB_ELEM),ANGLE(GG%NB_ELEM), & + & ALBEDO(GG%NB_ELEM),PERIM_ELEM(GG%NB_ELEM)) + ALIGN(:3,3,:GG%NB_ELEM)=1.0_PDB + PERIM_ELEM(:GG%NB_ELEM)=0 + ISPERIM(:GG%NB_ELEM)=.FALSE. + DO IBC=1,GG%NBBCDA + DO I=1,GG%BCDATAREAD(IBC)%NBER + INDBC=GG%BCDATAREAD(IBC)%ELEMNB(I) + IF(INDBC==0) CYCLE + DO ISYM=1,NSYM+1 + IF(I2(ISYM,INDBC)/=0) ISPERIM(I2(ISYM,INDBC))=.TRUE. + ENDDO + ENDDO + ENDDO + ITER0: DO ELEM=1,GG%NB_ELEM + IF(.NOT.ISPERIM(ELEM)) CYCLE + X1=GG%RPAR(1,ELEM); Y1=GG%RPAR(2,ELEM); + X2=X1+GG%RPAR(3,ELEM); Y2=Y1+GG%RPAR(4,ELEM); + DO J=1,TMP_NBBCDA + ALIGN(3,1,J)=X1; ALIGN(3,2,J)=Y1; + DET1 = DET_ROSETTA(ALIGN(1,1,J),3) + ALIGN(3,1,J)=X2; ALIGN(3,2,J)=Y2; + DET2 = DET_ROSETTA(ALIGN(1,1,J),3) + IF((ABS(DET1).LE.1.0E-4).AND.(ABS(DET2).LE.1.0E-4)) THEN + PERIM_ELEM(ELEM) = J + CYCLE ITER0 + ENDIF + ENDDO + TMP_NBBCDA=TMP_NBBCDA+1 + PERIM_ELEM(ELEM) = TMP_NBBCDA + ANGLE(TMP_NBBCDA)=ATAN((Y2-Y1)/(X2-X1)) + IF(ABS(ANGLE(TMP_NBBCDA)).LE.1.0E-5) ANGLE(TMP_NBBCDA)=0.0 + ALIGN(1,1,TMP_NBBCDA)=X1; ALIGN(1,2,TMP_NBBCDA)=Y1 + ALIGN(2,1,TMP_NBBCDA)=X2; ALIGN(2,2,TMP_NBBCDA)=Y2 + ! Recover albedo from folded geometry + ALBEDO(TMP_NBBCDA)=1.0 + DO IBC=1,GG%NBBCDA + J = FINDLC(GG%BCDATAREAD(IBC)%ELEMNB,ELEM) + IF(J.EQ.1) THEN + ALBEDO(TMP_NBBCDA)=GG%BCDATAREAD(IBC)%BCDATA(6) + EXIT + ENDIF + ENDDO + ENDDO ITER0 + ALLOCATE(TMP_BCDATAREAD(TMP_NBBCDA)) + DO IBC=1,TMP_NBBCDA + TMP_BCDATAREAD(IBC)%NBER = COUNT(PERIM_ELEM(:GG%NB_ELEM) == IBC) + ALLOCATE(TMP_BCDATAREAD(IBC)%ELEMNB(TMP_BCDATAREAD(IBC)%NBER)) + TMP_BCDATAREAD(IBC)%SALTYPE = 0 + J=0 + DO I=1,GG%NB_ELEM + IF(PERIM_ELEM(I) == IBC) THEN + J=J+1 + TMP_BCDATAREAD(IBC)%ELEMNB(J) = I + ENDIF + ENDDO + TMP_BCDATAREAD(IBC)%BCDATA(1) = ALIGN(1,1,IBC) + TMP_BCDATAREAD(IBC)%BCDATA(2) = ALIGN(1,2,IBC) + TMP_BCDATAREAD(IBC)%BCDATA(3) = COS(ANGLE(IBC)) + TMP_BCDATAREAD(IBC)%BCDATA(4) = SIN(ANGLE(IBC)) + TMP_BCDATAREAD(IBC)%BCDATA(5) = ANGLE(IBC) + TMP_BCDATAREAD(IBC)%BCDATA(6) = ALBEDO(IBC) + ENDDO + DEALLOCATE(I2,PERIM_ELEM,ALBEDO,ANGLE,ALIGN,ISPERIM) + DEALLOCATE(GG%BCDATAREAD) + GG%BCDATAREAD=>TMP_BCDATAREAD + GG%NBBCDA=TMP_NBBCDA + GG%ALBEDO=1.D0 + END SUBROUTINE SALFOLD_1 + ! + SUBROUTINE SALFOLD_2(HSYM,GG) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! unfold the domain with rotation + ! + !Parameters: input + ! HSYM: type of symmetry: SR60': dual 60-degree rotation; R180: 180-degree + ! rotation; R120: dual 120-degree rotation + ! + !Parameters: input/output + ! GG geometry descriptor + ! + !--------------------------------------------------------------------- + ! + USE SAL_GEOMETRY_TYPES, ONLY : NIPAR,NRPAR,LENGTHX,LENGTHY + IMPLICIT NONE + CHARACTER(LEN=4),INTENT(IN) :: HSYM + TYPE(T_G_BASIC), INTENT(INOUT) :: GG + ! + INTEGER :: ELEM,ELEM2,TYPE,OK,TMP_NB_ELEM,ISYM,NSYM,IAUX + REAL(PDB) :: THROT(3),X1,X2,X4,Y1,Y2,Y4,DX4,DY4,RAD,THETA1,THETA2,X1B,Y1B,X4B, & + Y4B,XMIN,YMIN,XMAX,YMAX,CENTER_X,CENTER_Y,DELPHI + REAL(PDB),PARAMETER :: EPS=1.0E-5_PDB + ! + ! allocatable arrays + LOGICAL, ALLOCATABLE, DIMENSION(:) :: ELEM_DUP + INTEGER, POINTER, DIMENSION(:,:) :: TMP_IPAR + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: I2 + REAL(PDB), POINTER, DIMENSION(:,:) :: TMP_RPAR + ! + ! compute size of the unfold geometry + XMIN=1.E10_PDB; YMIN=1.E10_PDB; XMAX=-1.E10_PDB; YMAX=-1.E10_PDB; + DO ELEM=1,GG%NB_ELEM + TYPE=GG%IPAR(1,ELEM) + IF(TYPE==1) THEN + X1=GG%RPAR(1,ELEM); Y1=GG%RPAR(2,ELEM); + XMIN=MIN(XMIN,X1); YMIN=MIN(YMIN,Y1); XMAX=MAX(XMAX,X1); YMAX=MAX(YMAX,Y1); + X2=X1+GG%RPAR(3,ELEM); Y2=Y1+GG%RPAR(4,ELEM); + XMIN=MIN(XMIN,X2); YMIN=MIN(YMIN,Y2); XMAX=MAX(XMAX,X2); YMAX=MAX(YMAX,Y2); + ENDIF + ENDDO + LENGTHX=XMAX-XMIN; LENGTHY=YMAX-YMIN; + ! + NSYM=0 + IF(HSYM=='SR60') THEN ! define rotation center + NSYM=3 + CENTER_X=XMIN+0.5_PDB*LENGTHX; CENTER_Y=YMIN+0.5_PDB*SQRT(3._PDB)*LENGTHX + THROT(1)=0.0_PDB; THROT(2)=-PI/3.0_PDB; THROT(3)=PI/3.0_PDB + ELSE IF(HSYM=='R180') THEN + NSYM=2 + CENTER_X=XMIN+0.5_PDB*LENGTHX; CENTER_Y=YMIN+0.25_PDB*SQRT(3._PDB)*LENGTHX + THROT(1)=0.0_PDB; THROT(2)=PI; + ELSE IF(HSYM=='R120') THEN + NSYM=3 + CENTER_X=XMIN+0.5_PDB*LENGTHX/1.5_PDB; CENTER_Y=YMIN+0.5_PDB*SQRT(3._PDB)*LENGTHX/1.5_PDB + THROT(1)=0.0_PDB; THROT(2)=-2.0_PDB*PI/3.0_PDB; THROT(3)=2.0_PDB*PI/3.0_PDB + ELSE + CALL XABORT('SALFOLD_2: invalid type of symmetry axis') + ENDIF + XMIN=1.E10_PDB; YMIN=1.E10_PDB; XMAX=-1.E10_PDB; YMAX=-1.E10_PDB; + ! + ! allocate new surfacic element containers + ALLOCATE(I2(NSYM,GG%NB_ELEM)) + ALLOCATE(TMP_IPAR(NIPAR,3*GG%NB_ELEM), TMP_RPAR(NRPAR,3*GG%NB_ELEM), STAT=OK) + IF(OK/=0) CALL XABORT('SALFOLD_2: not enough memory') + I2(:NSYM,:GG%NB_ELEM)=0 + TMP_IPAR(:,:)=0; TMP_RPAR(:,:)=0._PDB; + ! + ! loop over old elements + TMP_NB_ELEM=0 + THETA1=0._PDB; THETA2=0._PDB; + DO ELEM=1,GG%NB_ELEM + TYPE=GG%IPAR(1,ELEM) + DO ISYM=1,NSYM + X1=GG%RPAR(1,ELEM); Y1=GG%RPAR(2,ELEM); RAD=GG%RPAR(3,ELEM) + IF(TYPE==1) THEN + XMIN=MIN(XMIN,X1); YMIN=MIN(YMIN,Y1); XMAX=MAX(XMAX,X1); YMAX=MAX(YMAX,Y1); + X2=X1+GG%RPAR(3,ELEM); Y2=Y1+GG%RPAR(4,ELEM); + CALL SALROT(CENTER_X,CENTER_Y,THROT(ISYM),X1,Y1,X4,Y4) + CALL SALROT(CENTER_X,CENTER_Y,THROT(ISYM),X2,Y2,DX4,DY4) + ELSE IF(TYPE==2) THEN + CALL SALROT(CENTER_X,CENTER_Y,THROT(ISYM),X1,Y1,X4,Y4) + THETA1=0._PDB; THETA2=0._PDB; + ELSE IF(TYPE==3) THEN + DELPHI=GG%RPAR(5,ELEM)-GG%RPAR(4,ELEM) + X1B=X1+RAD*COS(GG%RPAR(4,ELEM)); Y1B=Y1+RAD*SIN(GG%RPAR(4,ELEM)); + CALL SALROT(CENTER_X,CENTER_Y,THROT(ISYM),X1,Y1,X4,Y4) + CALL SALROT(CENTER_X,CENTER_Y,THROT(ISYM),X1B,Y1B,X4B,Y4B) + IF((ABS(X4B-X4) 0._PDB)) THEN + THETA1=PI/2._PDB + ELSE IF((ABS(X4B-X4) 0._PDB) THEN + THETA1=ATAN((Y4B-Y4)/(X4B-X4)) + ELSE + THETA1=ATAN((Y4B-Y4)/(X4B-X4))+PI + ENDIF + THETA2=THETA1+DELPHI + ! put THETA1 within 0 and 2*pi + IF(THETA1>2._PDB*PI)THEN + IAUX=INT(THETA1/(2._PDB*PI)) + DELPHI=(2._PDB*PI)*IAUX + THETA1=THETA1-DELPHI ; THETA2=THETA2-DELPHI + ELSEIF(THETA1<0._PDB)THEN + IAUX=INT((-THETA1+1.D-7)/(2._PDB*PI))+1 + DELPHI=(2._PDB*PI)*IAUX + THETA1=THETA1+DELPHI ; THETA2=THETA2+DELPHI + ENDIF + ELSE + WRITE(*,*) " elem=",ELEM," type=",TYPE," isym=",ISYM + CALL XABORT('SALFOLD_2: invalid type of surfacic element') + ENDIF + TMP_NB_ELEM=TMP_NB_ELEM+1 + IF(TMP_NB_ELEM>3*GG%NB_ELEM) CALL XABORT('SALFOLD_2: TMP_NB_ELEM overflow') + I2(ISYM,ELEM)=TMP_NB_ELEM + TMP_RPAR(1,TMP_NB_ELEM)=X4; TMP_RPAR(2,TMP_NB_ELEM)=Y4; + TMP_IPAR(1,TMP_NB_ELEM)=TYPE; + IF(TYPE==1) THEN + TMP_RPAR(3,TMP_NB_ELEM)=DX4-X4; TMP_RPAR(4,TMP_NB_ELEM)=DY4-Y4; + TMP_RPAR(5,TMP_NB_ELEM)=SQRT(TMP_RPAR(3,TMP_NB_ELEM)**2+TMP_RPAR(4,TMP_NB_ELEM)**2) + XMIN=MIN(XMIN,X4); YMIN=MIN(YMIN,Y4); XMAX=MAX(XMAX,X4); YMAX=MAX(YMAX,Y4); + XMIN=MIN(XMIN,DX4); YMIN=MIN(YMIN,DY4); XMAX=MAX(XMAX,DX4); YMAX=MAX(YMAX,DY4); + TMP_IPAR(2,TMP_NB_ELEM)=GG%IPAR(2,ELEM); TMP_IPAR(3,TMP_NB_ELEM)=GG%IPAR(3,ELEM) + ELSE IF((TYPE==2).OR.(TYPE==3)) THEN + TMP_RPAR(3,TMP_NB_ELEM)=GG%RPAR(3,ELEM) ! RADIUS + TMP_RPAR(4,TMP_NB_ELEM)=THETA1; TMP_RPAR(5,TMP_NB_ELEM)=THETA2; ! ANGLES + TMP_IPAR(2,TMP_NB_ELEM)=GG%IPAR(2,ELEM); TMP_IPAR(3,TMP_NB_ELEM)=GG%IPAR(3,ELEM) + ENDIF + TMP_RPAR(6,TMP_NB_ELEM)=0._PDB + ENDDO + ENDDO + DEALLOCATE(GG%IPAR,GG%RPAR) + ! + ! eliminate duplicate elements + ALLOCATE(ELEM_DUP(TMP_NB_ELEM)) + ELEM_DUP(:TMP_NB_ELEM)=.FALSE. + DO ELEM=1,TMP_NB_ELEM + TYPE=TMP_IPAR(1,ELEM) + IF((TYPE==1).AND.((TMP_IPAR(2,ELEM)==0).OR.(TMP_IPAR(3,ELEM)==0))) THEN + X4=TMP_RPAR(1,ELEM); Y4=TMP_RPAR(2,ELEM) + DX4=X4+TMP_RPAR(3,ELEM); DY4=Y4+TMP_RPAR(4,ELEM) + DO ELEM2=ELEM+1,TMP_NB_ELEM + IF(TMP_IPAR(1,ELEM2)/=1) CYCLE + X1=TMP_RPAR(1,ELEM2); Y1=TMP_RPAR(2,ELEM2) + X2=X1+TMP_RPAR(3,ELEM2); Y2=Y1+TMP_RPAR(4,ELEM2) + IF(((ABS(X1-X4)<10.0*EPS .AND. ABS(Y1-Y4)<10.0*EPS .AND. & + ABS(X2-DX4)<10.0*EPS .AND. ABS(Y2-DY4)<10.0*EPS)).OR. & + ((ABS(X1-DX4)<10.0*EPS .AND. ABS(Y1-DY4)<10.0*EPS .AND. & + ABS(X2-X4)<10.0*EPS .AND. ABS(Y2-Y4)<10.0*EPS))) THEN + ELEM_DUP(ELEM2)=.TRUE. + IF(TMP_IPAR(2,ELEM)==0) TMP_IPAR(2,ELEM)=MAX(TMP_IPAR(2,ELEM2),TMP_IPAR(3,ELEM2)) + IF(TMP_IPAR(3,ELEM)==0) TMP_IPAR(3,ELEM)=MAX(TMP_IPAR(2,ELEM2),TMP_IPAR(3,ELEM2)) + IF(TMP_IPAR(2,ELEM)==TMP_IPAR(3,ELEM)) ELEM_DUP(ELEM)=.TRUE. + EXIT + ENDIF + ENDDO + ENDIF + ENDDO + ! + ELEM=1 + DO WHILE(ELEM<=TMP_NB_ELEM) + IF(ELEM_DUP(ELEM)) THEN + TMP_NB_ELEM=TMP_NB_ELEM-1 + DO ELEM2=ELEM,TMP_NB_ELEM + TMP_IPAR(:,ELEM2)=TMP_IPAR(:,ELEM2+1); TMP_RPAR(:,ELEM2)=TMP_RPAR(:,ELEM2+1) + ELEM_DUP(ELEM2)=ELEM_DUP(ELEM2+1) + ENDDO + ELSE + ELEM=ELEM+1 + ENDIF + ENDDO + GG%IPAR=>TMP_IPAR; GG%RPAR=>TMP_RPAR; + GG%NB_ELEM=TMP_NB_ELEM + ! + ! translate the domain + DO ELEM=1,GG%NB_ELEM + GG%RPAR(1,ELEM)=GG%RPAR(1,ELEM)-XMIN + GG%RPAR(2,ELEM)=GG%RPAR(2,ELEM)-YMIN + ENDDO + LENGTHX=XMAX-XMIN ; LENGTHY=YMAX-YMIN ; + GG%NBBCDA=0; GG%ALBEDO=1.D0 + ! + DEALLOCATE(ELEM_DUP,I2) + END SUBROUTINE SALFOLD_2 +END MODULE SAL_GEOMETRY_MOD diff --git a/Dragon/src/SAL_GEOMETRY_TYPES.f90 b/Dragon/src/SAL_GEOMETRY_TYPES.f90 new file mode 100644 index 0000000..c2503bd --- /dev/null +++ b/Dragon/src/SAL_GEOMETRY_TYPES.f90 @@ -0,0 +1,227 @@ +! +!--------------------------------------------------------------------- +! +!Purpose: +! To store common variables for the geometry analysis in SALT: +! module. +! +!Copyright: +! Copyright (C) 2001 Ecole Polytechnique de Montreal. +! +!Author(s): +! X. Warin +! +!--------------------------------------------------------------------- +! +MODULE SAL_GEOMETRY_TYPES + USE PRECISION_AND_KINDS, ONLY : PDB + IMPLICIT NONE + INTEGER :: ITYPE + INTEGER, PARAMETER :: N_IN=29,N_LG=4,N_RE=6 + INTEGER :: FOUT0,F_GEO + ! + ! types of elements + INTEGER, PARAMETER, DIMENSION(1:4) :: G_ELE_TYPE=(/1,2,3,4/) + ! 1 : segment element + ! 2 : circle element + ! 3 : arc of circle element + ! length of element discription data + INTEGER, PARAMETER, DIMENSION(1:4) :: G_ELE_LEN=(/5,5,6,6/) + ! 1 : segment element + ! 2 : circle element + ! 3 : arc of circle element + ! types of boundary conditions + INTEGER, PARAMETER, DIMENSION(-1:7) :: G_BC_TYPE=(/-99,0,-1,-2,-3,-4,-5,-6,-7/) + !-99 : internal surface: macro contact surface + ! 0 : external: vacuum or albedo (isotropic reflexion) + ! -1 : external: specular reflexion + ! (approx. specular reflexion => G_BC_TYPE(0)) + ! -2 : external: translation + ! -3 : external: rotation + ! -4 : external: axial symmetry + ! -5 : external: central symetry + ! boundary condition length definition + INTEGER, PARAMETER, DIMENSION(-1:5) :: G_BC_LEN=(/1,1,1,2,5,5,2/) + ! internal : albedo + ! vacuum surface : albedo + ! specular reflexion : none + ! translation : tx ty (t=translation vector) + ! rotation : cx cy cos(theta) sin(theta) theta + ! (c= center,theta= axis angle) + ! axial symmetry : cx cy cos(theta) sin(theta) theta + ! (c= center,theta= axis angle) + ! central symetry : cx cy (c= center) + INTEGER, PARAMETER :: G_BC_MAX_LEN=6 + ! max bc data length + INTEGER, PARAMETER :: NRPAR=6, NIPAR=3 + ! TYPGEO = type of geometry: + ! 0 = geometry with vacuum or isotropic reflexion + ! 1 = geometry with symmetries of two axis of angle pi/n,n>0 + ! 2 = geometry with rotation of angle 2*pi/n,n>1 + ! 3 = 1/4 assembly with symmetries on all sides + ! 5 = rectangular geometry with translation on all sides + ! 6 = rectangular geometry with symmetry on all sides + ! 7 = 1/8 assembly with symmetries on all sides + ! 8 = equilateral triangle geometry with symmetries on all sides + ! 9 = hexagonal geometry with translations on all sides + ! 10 = equilateral triangle geometry with RA60 rotation and translation + ! 11 = lozenge geometry with R120 rotation and translation + ! 12 = S30 triangle geometry with symmetries on all sides + ! NBFOLD = n in angle definition of rotation or symmetry geometry + ! NBMED = nber of media in library file + ! ALLSUR = (have not been programmed!) + INTEGER :: TYPGEO,NBFOLD,ALLSUR + ! NANIS = 0: isotropic scattering in the laboratory system/ >1: anisotropic + INTEGER :: NANIS + ! IC = 4: PIJ or MOC/ 5: multicell surfacic or short characteristics + INTEGER :: IC + ! ISPEC = 0: isotropic boundary condition/ 1: specular boundary condition + INTEGER :: ISPEC + ! LGALLS = TRUE, if 'allsur' equal to 1 + LOGICAL :: LGALLS + ! EPS = max. distance for two points to be considered as one point + ! in the topological geometric change + REAL :: EPS + ! ANGGEO = angle of rotation or symmetry geometry + ! LENGTHX = length in x direction of a rectangular geometry + ! LENGTHY = length in y direction of a rectangular geometry + REAL(PDB) :: ANGGEO,LENGTHX,LENGTHY + ! INDEX = when >0, impression of geometry data + ! KNDEX = when >0, impression of changes of geometry data in topological test + ! PREC = 0: geometry data is in format 4e20.12, + ! 1: geometry data is in format 5e12.6 + INTEGER :: INDEX,KNDEX,PREC + ! NBMED = nber of physical media + INTEGER :: NBMED + ! LBCDIAG = detection of diagonal symmetry in Cartesian geometry cases + ! LGSPEC = detection of a surfacic file limited to cyclic tracking + ! LMERGM = flag to perform a merge mix on nodes + LOGICAL :: LBCDIAG,LGSPEC,LMERGM + TYPE T_SALBCDATA + INTEGER :: SALTYPE + ! read type of bc and nber of elements affected + ! - TYPE of bc = 0 ~ 5 + ! 0 (vacuum + albedo), 1 (specular reflexion), + ! 2 (translation), 3 (rotation), + ! 4 (axial symmetry), 5 (central symmetry) + ! - NBER = number of elements affected + ! + INTEGER :: NBER + INTEGER,DIMENSION(:),POINTER :: ELEMNB + ! BCDATA(1:2) : perimeter origin + ! BCDATA(3) : perimeter cos(angle) + ! BCDATA(4) : perimeter sin(angle) + ! BCDATA(5) : perimeter angle (radians) + ! BCDATA(6) : perimeter albedo + REAL(PDB),DIMENSION(G_BC_MAX_LEN) :: BCDATA + END TYPE T_SALBCDATA + ! + ! geometry basic + TYPE T_G_BASIC + INTEGER, DIMENSION (N_IN) :: V_IN + LOGICAL, DIMENSION (N_LG) :: V_LG + REAL, DIMENSION (N_RE) :: V_RE + ! + INTEGER :: NB_ELEM ! NUMBER OF SURFACIC ELEMENTS + INTEGER :: NB_MACRO ! NUMBER OF MACROS + INTEGER :: NB_FLUX ! NUMBER OF FLUX VALUES + ! definition of elements in a macro + INTEGER, POINTER, DIMENSION(:,:) & + :: IPAR ! descriptors for elements + ! dim: IPAR(NIPAR, NB_ELEM) + REAL(PDB), POINTER, DIMENSION(:,:) & + :: RPAR ! DESCRIPTORS FOR ELEMENTS + ! dim: RPAR(NRPAR, NB_ELEM) + TYPE(T_SALBCDATA), POINTER, DIMENSION(:) & + :: BCDATAREAD ! BC DATA RECOVERED FROM SALGET + REAL(PDB) :: ALBEDO + INTEGER :: DEFAUL,NBBCDA + ! dim: BCDATA(NBBCDA) + INTEGER, POINTER, DIMENSION(:) & + :: IBC2_ELEM ! RELATIVE 2D BC NBER + ! 0: is not a bc + ! else: order number of bc + ! dim: IBC2_ELEM(NB_ELEM) + INTEGER, POINTER, DIMENSION(:) & + :: ISURF2_ELEM ! RELATIVE 2D SURFACE NBER + ! 0: is not a surface + ! else: order number of surface + ! dim: ISURF2_ELEM(NB_ELEM) + ! def: + ! definition of nodes in a macro + INTEGER & + :: NB_NODE ! NUMBER OF NODES + REAL(PDB), POINTER, DIMENSION(:) & + :: VOL_NODE ! VOLUME OF NODES, ALLOCATED ONLY IN 2D + ! dim: VOL_NODE(NB_NODE) + INTEGER, POINTER, DIMENSION(:) & + :: PPERIM_NODE ! POINTER TO LIST OF ELEMENTS OF PERIMETER + ! dim: pperim_node(nb_node+1) + INTEGER, POINTER, DIMENSION(:) & + :: PERIM_NODE ! ARRAY OF ELEMENTS IN PERIMETER OF NODES + ! dim: perim_node(pperim_node(nb_node+1)-1) + ! definition of boundary conditions of a macro + INTEGER & + :: NB_BC2 ! NUMBER OF 2D BOUNDARY CONDITIONS + INTEGER, POINTER, DIMENSION(:) & + :: TYPE_BC2 ! 2D BOUNDARY CONDITION TYPE + ! dim: TYPE_BC2(NB_BC2) + INTEGER, POINTER, DIMENSION(:) & + :: IDATA_BC2 ! POSITION OF 2D BC DATA PER 2D BC + ! dim: IDATA_BC2(NB_BC2) + ! definition of surfaces of a macro + INTEGER & + :: NB_SURF2 ! NUMBER OF 2D SURFACES + ! macro contacting bc (type -1) + ! or external vacuum bc (type 0) + INTEGER, POINTER, DIMENSION(:) & + :: IBC2_SURF2 ! RELATIVE 2D BC ORDER NBER + ! dim: IBC2_SURF2(NB_SURF2) + INTEGER, POINTER, DIMENSION(:) & + :: IELEM_SURF2 ! RELATIVE ELEM ORDER NBER + ! dim: IELEM_SURF2(NB_SURF2) + REAL(PDB), POINTER, DIMENSION(:) & + :: SURF2 ! LOCAL 2D AREAS (POINTER TO SURF2_TAB) + ! dim: SURF2(NB_SURF2) + ! definition of perimeter of a macro + INTEGER & + :: NPERIM_MAC2 ! NUMBER OF ELEMENTS IN PERIMETER OF 2D MACRO + INTEGER, POINTER, DIMENSION(:) & + :: PERIM_MAC2 ! ELEMENTS IN PERIMETER OF 2D MACRO + ! in case of geometry with rotation or symmetry,order of elems is: + ! (elems on axis 1)+(elems on axis 2)+(other elems) + ! dim: PERIM_MAC2(NPERIM_MAC2) + INTEGER, POINTER, DIMENSION(:) & + :: PPERIM_MAC2 ! POINTER TO TABLE 'PERIM_MAC2'&'DIST_AXIS' (ONLY FOR TYPGEO=1,2,5) + ! for TYPGEO=1,2: + ! (1): first elem on axis 1 (2): first elem on axis 2 + ! (3): first of other elems (4): nperim_mac2 + 1 + ! for TYPGEO=5: + ! (1): first elem on axis 1 (2): first elem on axis 2 + ! (3): first elem on axis 3 (4): first elem on axis 4 + ! (5): NPERIM_MAC2 + 1 + ! dim: PPERIM_MAC2(5) + INTEGER, POINTER, DIMENSION(:) & + :: IDATA_AXIS ! POSITION OF AXIAL BC DATA IN 'BCDATA' (ONLY FOR TYPGEO=1,2) + ! (1): data position for axis 1 (2): data position for axis 2 + REAL(PDB), POINTER, DIMENSION(:) & + :: DIST_AXIS ! DISTANCE OF POINTS ON AXIS TO THE CENTER (0,0) (ONLY FOR TYPGEO=1,2) + ! order of elems is: + ! (distances of points on axis 1)+(distances of points on axis 2) + ! dim: DIST_AXIS(1:PPERIM_MAC2(3)-1) + INTEGER, POINTER, DIMENSION(:) & + :: MED ! (:): MEDIUM PER LOCAL NODE + ! dim: MED(NBNODE) + REAL(PDB), POINTER, DIMENSION(:,:) & + :: BCDATA ! TABLE OF BC DATA + ! dim: BCDATA(G_BC_MAX_LEN,NT_BC) + CHARACTER(LEN=12), POINTER, DIMENSION(:) :: NAME_MACRO + INTEGER, POINTER, DIMENSION(:) :: NUM_MERGE + ! NUM_MERGE : merge index per node + INTEGER, POINTER, DIMENSION(:) :: NUM_MACRO + ! NUM_MACRO : macro index per flux region + INTEGER :: NALBG + ! NALBG : number of boundary condition types in BCDATA + END TYPE T_G_BASIC + ! +END MODULE SAL_GEOMETRY_TYPES diff --git a/Dragon/src/SAL_NUMERIC_MOD.f90 b/Dragon/src/SAL_NUMERIC_MOD.f90 new file mode 100644 index 0000000..5b8670e --- /dev/null +++ b/Dragon/src/SAL_NUMERIC_MOD.f90 @@ -0,0 +1,151 @@ +! +!--------------------------------------------------------------------- +! +!Purpose: +! Support module for numerical functions. +! +!Copyright: +! Copyright (C) 2001 Ecole Polytechnique de Montreal. +! +!Author(s): +! X. Warin +! +!--------------------------------------------------------------------- +! +MODULE SAL_NUMERIC_MOD + + USE PRECISION_AND_KINDS, ONLY : PDB + +CONTAINS + ! + FUNCTION SALACO(COSANG,Y) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! computes angle in radians for given cosinus and y component + ! + !Parameters: input + ! COSANG cosinus of angle + ! Y component (to give sign) + ! + !Parameters: output + ! SALACO angle in radiants + ! + !--------------------------------------------------------------------- + ! + USE PRECISION_AND_KINDS, ONLY : PDB,PI,TWOPI + !** + REAL(PDB) :: SALACO + REAL(PDB),INTENT(IN) :: COSANG,Y + !***** + IF(ABS(COSANG).LT.1.0_PDB) THEN + SALACO=ACOS(COSANG) + ELSEIF(COSANG.GE.1.0_PDB) THEN + SALACO=0.0_PDB + ELSE + SALACO=PI + ENDIF + IF(Y.LT.0.0_PDB) SALACO=TWOPI-SALACO + ! + END FUNCTION SALACO + ! + SUBROUTINE SAL141(TYPE,RPAR,X,Y,IEND) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! computes coordinates of end of an element + ! + !Parameters: input + ! TYPE type of element 1 (segment) 3 (arc of circle) + ! RPAR floating-point descriptors of the element + ! IEND = 1 (end is origin of element) + ! 2 (end is end of the element) + ! + !Parameters: output + ! X abscissa coordinates of end + ! Y ordinate coordinates of end + ! + !--------------------------------------------------------------------- + ! + IMPLICIT NONE + INTEGER, INTENT(IN) :: TYPE,IEND + REAL(PDB), INTENT(OUT) :: X,Y + REAL(PDB), INTENT(IN), DIMENSION(:) :: RPAR + ! DIMENSION RPAR(*) + !**** + REAL(PDB) :: THETA,R + !**** + X=RPAR(1) + Y=RPAR(2) + IF(TYPE.EQ.1)THEN + ! segment + IF(IEND.EQ.2)THEN + X=X+RPAR(3) + Y=Y+RPAR(4) + ENDIF + ELSEIF(TYPE.LE.3)THEN + ! arc of circle + IF(IEND.EQ.1)THEN + THETA=RPAR(4) + ELSE + THETA=RPAR(5) + ENDIF + R=RPAR(3) + X=X+R*COS(THETA) + Y=Y+R*SIN(THETA) + ELSE + CALL XABORT('SAL141: not implemented') + ENDIF + ! + END SUBROUTINE SAL141 + ! + RECURSIVE FUNCTION DET_ROSETTA(MAT, N) RESULT(ACCUM) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! compute the determinant of matrix MAT(N, N) + ! + !--------------------------------------------------------------------- + ! + INTEGER, INTENT(IN) :: N + REAL(PDB), INTENT(IN) :: MAT(N, N) + REAL(PDB) :: SUBMAT(N-1, N-1), ACCUM + INTEGER :: I, SGN + IF(N == 1) THEN + ACCUM = MAT(1,1) + ELSE + ACCUM = 0.0 + SGN = 1 + DO I = 1, N + SUBMAT(1:N-1, 1:I-1) = MAT(2:N, 1:I-1) + SUBMAT(1:N-1, I:N-1) = MAT(2:N, I+1:N) + ACCUM = ACCUM + SGN * MAT(1, I) * DET_ROSETTA(SUBMAT, N-1) + SGN = - SGN + ENDDO + ENDIF + END FUNCTION DET_ROSETTA + ! + FUNCTION FINDLC(ISET,ITEST) RESULT(II) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! function emulating the findloc function in fortran 2008 + ! + !--------------------------------------------------------------------- + ! + INTEGER, DIMENSION(:), INTENT(IN) :: ISET + INTEGER, INTENT(IN) :: ITEST + INTEGER :: II + II=0 + DO J=1,SIZE(ISET) + IF(ISET(J) == ITEST) THEN + II=J + EXIT + ENDIF + ENDDO + END FUNCTION FINDLC +END MODULE SAL_NUMERIC_MOD diff --git a/Dragon/src/SAL_TRACKING_TYPES.f90 b/Dragon/src/SAL_TRACKING_TYPES.f90 new file mode 100644 index 0000000..18c456d --- /dev/null +++ b/Dragon/src/SAL_TRACKING_TYPES.f90 @@ -0,0 +1,113 @@ +! +!--------------------------------------------------------------------- +! +!Purpose: +! To store common variables for the tracking calculation in SALT: +! module. +! +!Copyright: +! Copyright (C) 2001 Ecole Polytechnique de Montreal. +! +!Author(s): +! X. Warin +! +!--------------------------------------------------------------------- +! +MODULE SAL_TRACKING_TYPES + USE PRECISION_AND_KINDS, ONLY : PDB + IMPLICIT NONE + ! NBINT = max number of intersections trajectory-element + ! NIPART = number of intersections + one index = effective nber of + ! intersections to be analyzed + ! NRPART = 2 * nbe of intersections + ! NNN = length of header in a trajectory + ! MINLEN = smallest length for a trajectory before emptying buffer + !* general angular quadrature formula + ! LGSN = .true. : use sn formulae + ! ND_TURN= in case of symmetrical geometry, number of directions obtained + ! from an angle by application of symmetry conditions. + ! ND_TURN=1 in case of TISO tracking. + ! + INTEGER, PARAMETER :: NBINT=2, NIPART=1+NBINT, NRPART=2*NBINT, NNN=8, MINLEN=20 + INTEGER :: NMAX2 + INTEGER :: PRTIND + !* tracking data buffer: + ! integers + ! itrac2(nmax or 2*nmax) = integer tracking array + ! itrac3(nmax or 2*nmax) = integer tracking array + ! + ! *integer descriptors in itrac2 or itrac3 : + ! 1 = address of last data + ! 2 = total nber of sub-trajectories + ! 3 = + ! 4 = phi for trajectory + ! 2d pca : 2d rac : + ! 5 = left cone 5 = left surface + ! 6 = right cone 6 = left horizontal ray + ! 7 = left phi (2D) 7 = right surface + ! 8 = right phi (2D) 8 = right horizontal ray + ! + ! reals + ! RTRAC2(NMAX OR 2*NMAX) = real tracking array (2d, with 3d geo) + ! RTRAC3(NMAX OR 2*NMAX) = real tracking array + ! + ! *real descriptors: + ! 1 = + ! 2 = cos phi entering basic + ! 3 = sin phi left surface + ! 4 = sin phi right surface + ! 5 = cos phi left surface + ! 6 = cos phi right surface + ! 7 = total weight (delr*wphi for 2D) + ! 8 = radial weight (DELR for 2D) + ! + ! *contents of each piece of trajectory descriptor arrays: + ! ITRACK: (small buffer)+(i1 i2 i3 ... in)*nt+(n_1 a_1 ... n_i a_i) + ! RTRACK: (small buffer)+(l1 l2 l3 ... ln)*nt+(free space) + ! where NT = total subpieces of trajectories + ! N_I = nber of regions intersected by horizontal angle a_i + ! A_I = horizontal angle number for ith (1=NMAX2) THEN + CALL XABORT('SALTRA: Buffer overflow') + ELSE + ITRAC2(CNT+1:CNT+LEN)=ANGTAB(1:LEN) + ITRAC2(CNT+NMAX2+1:CNT+NMAX2+LEN)=ELMTAB(1:LEN) + CNT=CNT+LEN + ENDIF + ! + END SUBROUTINE SALTRA + + SUBROUTINE SAL241_2(NPERIM,PERIM,DIST_AXIS,IPAR) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! compute an entry point on the axial element + ! + !Parameters: input + ! NPERIM = number of elements on this axis + ! PERIM = elements on this axis in perimeter + ! DIST_AXIS = distance of points on this axis to the center (0,0) + ! IPAR = integer descriptor of elements + ! + !--------------------------------------------------------------------- + ! + USE SAL_TRACKING_TYPES, ONLY : IPART,N_AXIS,DNEW,DELX,NNEW,LNEW,COSINE,AX, & + AY,HX,HY,BX,BY,EX,EY + INTEGER, INTENT(IN) :: NPERIM + INTEGER, INTENT(IN), DIMENSION(:) :: PERIM + REAL(PDB), INTENT(IN), DIMENSION(:) :: DIST_AXIS + INTEGER, INTENT(IN), DIMENSION(:,:) :: IPAR + INTEGER :: I,J + !*** + LNEW=0 + !* compute crossed element + DO I=1,NPERIM + IF(DELX<=DIST_AXIS(I)) THEN + LNEW=PERIM(I) + EXIT + ENDIF + ENDDO + IF(LNEW==0) CALL XABORT('SAL241_2: Error of distances on the axis') + !* get entered node + NNEW=IPAR(2,LNEW) + IF(NNEW<0) NNEW=IPAR(3,LNEW) + IF(NNEW<0) CALL XABORT('SAL241_2: Error of element data') + !* compute DNEW at entry point + DNEW=DELX*(EX*HX(N_AXIS)+EY*HY(N_AXIS)) + IF(N_AXIS>2) DNEW=DNEW+BX(N_AXIS)*EX+BY(N_AXIS)*EY + !* compute COSINE + COSINE=ABS(HX(N_AXIS)*EY-HY(N_AXIS)*EX) + !* set all elements in this axis to be 'treated (0)' + ! others are 'untreated' + IPART(1,:)=-1 + DO I=1,NPERIM + J=PERIM(I) + IPART(1,J)=0 + ENDDO + !* initial point + AX=BX(N_AXIS)+DELX*HX(N_AXIS)-DNEW*EX + AY=BY(N_AXIS)+DELX*HY(N_AXIS)-DNEW*EY + ! + END SUBROUTINE SAL241_2 + ! + SUBROUTINE SAL240_3(PERIM_MAC2,NPERIM_MAC2,IPAR,RPAR) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! compute entry point for a basic trajectory + ! + !Parameters: input + ! PERIM_MAC2 elements composing perimeter of domain + ! NPERIM_MAC2 number of elements composing perimeter of domain + ! IPAR integer geometry descriptors + ! RPAR floating point geometry descriptors + ! + !--------------------------------------------------------------------- + ! + USE SAL_TRACKING_TYPES, ONLY : IPART,EX0,EY0,EX,EY,DD0,LGOK,LGMORE,NBER, & + DNEW,NNEW,LNEW,DINIT + IMPLICIT NONE + INTEGER, INTENT(IN) :: NPERIM_MAC2 + INTEGER, INTENT(IN), DIMENSION(:) :: PERIM_MAC2 + REAL(PDB), INTENT(IN), DIMENSION(:,:) :: RPAR + INTEGER, INTENT(IN), DIMENSION(:,:) :: IPAR + !*** + EX=EX0; EY=EY0 + ! enter trajectory with vectors a and e and initial distance dd0 + ! initiate all elements status to untreated + IPART(1,:)=-1 + CALL SAL241(PERIM_MAC2,NPERIM_MAC2,IPAR,RPAR,DD0,-100,DNEW,NNEW,LNEW) + DINIT=DNEW + ! if we have sevaral entry points + LGMORE=NBER>3 + !* if not succeed + IF(.NOT.LGOK) CALL XABORT('SAL240_3: Could not enter domain') + ! + END SUBROUTINE SAL240_3 + ! + SUBROUTINE SAL245(ISURF2_ELEM,IPAR,RPAR,IOUT,LOLD,NOLD,DOLD,LGLEFT) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! boundary condition treatment at entry point + ! + !Parameters: input + ! ISURF2_ELEM relative 2D surf nber per elem + ! IPAR integer geometry descriptors + ! RPAR floating point geometry descriptors + ! + !Parameters: input/output + ! LOLD entry point + ! NOLD node index + ! DOLD distance + ! LGLEFT flag set to TRUE if there is a left domain + ! + !Parameters: output + ! IOUT (to load outside surface) = 5 (left trajectory) + ! 6 (right trajectory) + ! + !--------------------------------------------------------------------- + ! + USE SAL_TRACKING_TYPES, ONLY : ITRAC2,RTRAC2,CNT0,COSINE,EX,EY + USE SAL_GEOMETRY_TYPES, ONLY : G_BC_TYPE,ISPEC + IMPLICIT NONE + INTEGER, INTENT(IN), DIMENSION(:,:) :: IPAR + INTEGER, INTENT(IN), DIMENSION(:) :: ISURF2_ELEM + REAL(PDB), INTENT(IN), DIMENSION(:,:) :: RPAR + INTEGER, INTENT(INOUT) :: LOLD,NOLD + REAL(PDB), INTENT(INOUT) :: DOLD + LOGICAL, INTENT(INOUT) :: LGLEFT + INTEGER, INTENT(OUT) :: IOUT + !*** + INTEGER :: BCIN,SURF + !*** + ! initiate surface info + ITRAC2(CNT0+5)=0 + ITRAC2(CNT0+6)=0 + !* get boundary condition at entry surface + BCIN=IPAR(2,LOLD) + IF(NOLD==BCIN)BCIN=IPAR(3,LOLD) + ! add entry cosine anyhow (for characteristics) + RTRAC2(CNT0+2)=COSINE + LGLEFT=.FALSE. + IF(ISPEC == 1) RETURN + IF(BCIN>=G_BC_TYPE(0).OR.BCIN==G_BC_TYPE(-1).OR.BCIN==G_BC_TYPE(1))THEN + !* trajectory enters through vacuum: + ! - compute angle, trajectory-normal and store cos and sin + ! (inverse vector E in order to pass outgoing direction) + CALL SAL247_1(RPAR(:,LOLD),IPAR(:,LOLD),DOLD,RTRAC2(CNT0+3),RTRAC2(CNT0+5),-EX,-EY) + !* get index of the entry surface + SURF=ISURF2_ELEM(LOLD) + IF(SURF/=0) ITRAC2(CNT0+5)=SURF ! store 2D surface index + IOUT=6 + ELSE + CALL XABORT('SAL245: Reversed direction') + ENDIF + ! + END SUBROUTINE SAL245 + ! + SUBROUTINE SAL240_4(PERIM,PPERIM,IPAR,RPAR,IPHI,ISURF2_ELEM,IOUT) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! track a trajectory until leaving the domain + ! begin: having (nnew,dnew,lnew) + ! | + ! (1)write horizontal angle information + ! | + ! (2)compute successive crossed nodes + ! | + ! (3)boundary condition: + ! re-entry: get re-entry point,go to (1) + ! go out: compute surface number,end + ! + !Parameters: input + ! PERIM array of elements in perimeter of nodes + ! PPERIM array pointer to elements in the perimeter of nodes + ! IPAR integer geometry descriptors + ! RPAR floating point geometry descriptors + ! IPHI angular index of the track + ! ISURF2_ELEM relative 2D surf number per elem + ! IOUT (to load outside surface) = 5 (left trajectory) + ! + !--------------------------------------------------------------------- + ! + USE SAL_TRACKING_TYPES, ONLY : NNN,NMAX2,ITRAC2,RTRAC2,ANGTAB,ELMTAB,PRTIND,CNT, & + CNT0,EX,EY,LGOK,NB_TOT,NB_MAX,DNEW,NNEW,LNEW,IERR + USE SAL_GEOMETRY_TYPES, ONLY : G_BC_TYPE + IMPLICIT NONE + ! IN VARIABLE + INTEGER, INTENT(IN) :: IPHI + INTEGER, INTENT(IN), DIMENSION(:) :: PPERIM,PERIM + INTEGER, INTENT(IN), DIMENSION(:,:) :: IPAR + REAL(PDB), INTENT(IN), DIMENSION(:,:) :: RPAR + INTEGER, INTENT(IN), DIMENSION(:) :: ISURF2_ELEM + INTEGER, INTENT(IN) :: IOUT + !*** + INTEGER :: NOLD,LOLD,P1,P2,CNT1,SURF + REAL(PDB) :: DOLD,LENGTH + LOGICAL :: LGON + INTEGER, PARAMETER :: FOUT =6 + !*** + LGON = .TRUE. + ! initiate counter + CNT1=CNT + EXTERIOR : DO WHILE(LGON) + NB_TOT=NB_TOT+1 + IF(NB_TOT > NB_MAX) CALL XABORT('SAL240_4: NB_TOT overflow') + ! keep horizontal phi nber in angtab + IF(NB_TOT>1) CALL XABORT('SAL240_4: Angtab overflow') + ANGTAB(2*NB_TOT)=IPHI + ELMTAB(2*NB_TOT-1)=LNEW ; ELMTAB(2*NB_TOT)=0 ; + ! + !* track a sub-trajectory + INTERIOR: DO WHILE(NNEW>0) + ! UPDATE DATA TO COMPUTE NEXT NODE: + DOLD=DNEW + LOLD=LNEW + NOLD=NNEW + ! crossing NODE NOLD + ! input: trajectory (T):R=A+D*E => A = (AX,AY), E = (EX,EY) + ! DOLD = D at last intersection + ! NOLD = NODE just entered + P1=PPERIM(NOLD); P2=PPERIM(NOLD+1)-1 + CALL SAL241(PERIM(P1:P2),P2-P1+1,IPAR,RPAR,DOLD,NOLD,DNEW,NNEW,LNEW) + ! at return from SAL241: + ! DNEW = D at point exiting node + ! COSINE = cosine of trajectory with exiting normal + ! NNEW = new node entered + ! LNEW = element crossed when exiting node + ! NBER = number of intersections with perimeter + ! LGOK = .TRUE. if trajectory exits the node + IF(.NOT.LGOK) THEN + IERR=0 + IF(PRTIND>0)WRITE(FOUT,'("SAL240_4 ==> couldnt exit node ",I5)') NOLD + RETURN + ENDIF + ! store data + LENGTH=DNEW-DOLD + ! store new length in track arrays + CNT=CNT+1 + IF(CNT>=NMAX2) CALL XABORT('SAL240_4: NMAX2 overflow') + RTRAC2(CNT)=LENGTH + ITRAC2(CNT+NMAX2)=LNEW + ITRAC2(CNT)=NOLD + END DO INTERIOR + ! + !* exiting motif and analyzing bc condition + LGON =(NNEW=G_BC_TYPE(5)) + ! STORE NBER OF REGIONS TO ANGTAB + ANGTAB(2*NB_TOT-1)=CNT-CNT1 + CNT1=CNT + IF(LGON) THEN + CALL XABORT('SAL240_4: Lgon is true') + ELSE + ! compute leaving surface + IF(NNEW<=0)THEN + ! we got a surface: end of trajectory + ! vacuum bd condition. put a marker (surface number) to allow + ! psi and pss computation + ! store exiting surface, cosphi and sinphi + ! compute angle trajectory-normal + CALL SAL247_1(RPAR(:,LNEW),IPAR(:,LNEW),DNEW, & + RTRAC2(CNT0+IOUT-2),RTRAC2(CNT0+IOUT),EX,EY) + ! store 2D surface-cone nber + SURF=ISURF2_ELEM(LNEW) + IF(SURF/=0) ITRAC2(CNT0+IOUT)=SURF + ENDIF + ENDIF + ! + ENDDO EXTERIOR + ! set success flag + IERR=1 + ! + END SUBROUTINE SAL240_4 + ! + SUBROUTINE SAL240_4_2(DANGLT,PPERIM,PERIM,IPAR,RPAR,IDATA_BC2,BCDATA, & + PERIM_MAC2,PPERIM_MAC2,DIST_AXIS,IBC2_ELEM) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! track a cyclic trajectory until the track length equal to the predefined + ! length of this trajectory + ! begin: having (nnew,dnew,lnew) + ! | + ! (1)write horizontal angle information + ! | + ! (2)compute successive crossed nodes + ! | + ! (3)if abs(total_length*length_inv_cycl-1)>eps1 : + ! yes:continue, get re-entry point,go to (1) + ! no: end of tracking + ! + !Parameters: input + ! DANGLT angle cosines + ! PERIM array of elements in perimeter of nodes + ! PPERIM array pointer to elements in the perimeter of nodes + ! IPAR integer geometry descriptors + ! RPAR real geometry descriptors + ! IDATA_BC2 position of bc data per 2D boundary conditions + ! PERIM_MAC2 elements composing perimeter of domain + ! PPERIM_MAC2 pointer to 'PERIM' and 'DIST_AXIS': + ! PPERIM_MAC2(1):beginning of elements on axis 1 + ! PPERIM_MAC2(2):beginning of elements on axis 2 + ! PPERIM_MAC2(3):beginning of elements not on axis + ! DIST_AXIS distance of points on this axis to the center (0,0) + ! BCDATA table of bc descriptor + ! IBC2_ELEM relative 2D bc nber per elem + ! + !Parameters: output + ! NB_TOT total number of sub-trajectories + ! ANGTAB table of {N_K,ANGLE_K} (1 NB_MAX) CALL XABORT('SAL240_4_2: NB_TOT overflow') + N_AXIS_KEEP(NB_TOT)=N_AXIS + ! set horizontal angle index in angtab + ANGTAB(2*NB_TOT)=ANGLE_TO_NUMBER(EX,EY,DANGLT) + ELMTAB(2*NB_TOT-1)=LNEW ; ELMTAB(2*NB_TOT)=0 ; + TORIG(1,NB_TOT)=AX+DNEW*EX ; TORIG(2,NB_TOT)=AY+DNEW*EY ; + IF(IMPX > 4) WRITE(6,*) 'SAL240_4_2: beginning of track=',TORIG(:2,NB_TOT) + ! + !* track a sub-trajectory + INTERIOR: DO WHILE(NNEW.GT.0) + ! update data to compute next node: + DOLD=DNEW + LOLD=LNEW + NOLD=NNEW + ! crossing node NOLD + ! input: trajectory (t):r=a+d*e => a = (ax,ay), e = (ex,ey) + ! DOLD = d at last intersection + ! NOLD = node just entered + P1=PPERIM(NOLD); P2=PPERIM(NOLD+1)-1 + CALL SAL241(PERIM(P1:P2),P2-P1+1,IPAR,RPAR,DOLD,NOLD,DNEW,NNEW,LNEW) + ! at return from SAL241: + ! DNEW = d at point exiting node + ! COSINE = cosine of trajectory with exiting normal + ! NNEW = new node entered + ! LNEW = element crossed when exiting node + ! NBER = nber of intersections with perimeter + ! LGOK = .true. if trajectory exits the node + IF(.NOT.LGOK) THEN + IERR=0 + WRITE(FOUT,'(" SAL240_4_2 ==> couldnt exit node ",I5)') NOLD + RETURN + ENDIF + ! store data + LENGTH=DNEW-DOLD + ! add to total length + LENGTH_TOT=LENGTH_TOT+LENGTH + CNT=CNT+1 + IF(CNT>=NMAX2) THEN + ALLOCATE(ITRAC3(4*NMAX2),RTRAC3(2*NMAX2),STAT=OK) + IF(OK/=0) CALL XABORT('SAL240_4_2: NMAX2 overflow.') + RTRAC3(:NMAX2)=RTRAC2(:NMAX2) + ITRAC3(:2*NMAX2)=ITRAC2(:2*NMAX2) + DEALLOCATE(RTRAC2,ITRAC2) + RTRAC2=>RTRAC3 + ITRAC2=>ITRAC3 + NMAX2=2*NMAX2 + ENDIF + RTRAC2(CNT)=LENGTH + ITRAC2(CNT+NMAX2)=LNEW + ITRAC2(CNT)=NOLD + ENDDO INTERIOR + ! + !* exiting motif and analyzing bc condition + LGON=NNEW<=G_BC_TYPE(1).AND.NNEW>=G_BC_TYPE(5).AND.(ABS(LENGTH_TOT*LENGTH_INV_CYCL-1.)>EPS1) + ! store nber of regions to angtab + ANGTAB(2*NB_TOT-1)=CNT-CNT1 + CNT1=CNT + IF(LGON)THEN + ! treat boundary condition and get new entry point + IF(PRESENT(IDATA_BC2).AND.PRESENT(DIST_AXIS)) THEN + IDATA=IDATA_BC2(IBC2_ELEM(LNEW)) + ! treat bondary condition + CALL SAL247_3(BCDATA(:,IDATA)) + ! at return from SAL247_3: + ! AX AY = entry point at boundary + ! EX EY = new direction + ! compute entry point + IF(NNEW==G_BC_TYPE(3).OR.NNEW==G_BC_TYPE(4).OR.NNEW==G_BC_TYPE(2)) THEN + P1=PPERIM_MAC2(N_AXIS); P2=PPERIM_MAC2(N_AXIS+1)-1 + ! re-entry point is on the axis + CALL SAL241_2(P2-P1+1,PERIM_MAC2(P1:P2),DIST_AXIS(P1:P2),IPAR) + ENDIF + ELSE + CALL XABORT('SAL240_4_2: missing IDATA_BC2 or DIST_AXIS argument') + ENDIF + ENDIF + ! + ENDDO EXTERIOR + ! set success flag + IERR=1 + ! + END SUBROUTINE SAL240_4_2 + ! + SUBROUTINE SAL247_3(BCDATA) + ! + !---------------------------------------------------------------------- + ! + !Purpose: + ! Treatment of boundary conditions for the cyclic cases + ! side 4 + ! side 3 ------ + ! ---------- /\ side 3 / \ side 5 + ! | | / \ / \ + ! side 2 | | side 4 side 2 / \ side 3 \ / + ! | | / \ side 2 \ / side 6 + ! ---------- -------- ------ + ! side 1 side 1 side 1 + ! + !Parameters: input + ! BCDATA boundary condition descriptor + ! + !---------------------------------------------------------------------- + ! + USE SAL_TRACKING_TYPES, ONLY : NNEW,DNEW,AX,AY,BX,BY,EX,EY,DELX,N_AXIS + USE SAL_GEOMETRY_TYPES, ONLY : TYPGEO,EPS,LX=>LENGTHX + IMPLICIT NONE + REAL(PDB), INTENT(IN), DIMENSION(:) :: BCDATA + !*** + REAL(PDB) :: AUX,ACX,ACY,COSTHE,SINTHE,CX,CY,EX0 + !*** + ! boundary point: + AX=AX+DNEW*EX + AY=AY+DNEW*EY + CX=BCDATA(1) ; CY=BCDATA(2) + COSTHE=BCDATA(3) + SINTHE=BCDATA(4) + SELECT CASE(NNEW) + CASE(-2,-3) + ! translation/rotation for a segment (get displacement data) + ! a = displacement vector + ! new axis + SELECT CASE(TYPGEO) + CASE(5) + IF (CY<0) THEN ! end axe 2 + N_AXIS=1 + DELX=AX + ELSEIF (CY>0) THEN ! end axe 1 + N_AXIS=3 + DELX=AX + ELSEIF (CX<0) THEN ! end axe 4 + N_AXIS=2 + DELX=AY + ELSEIF (CX>0) THEN ! end axe 3 + N_AXIS=4 + DELX=AY + ENDIF + CASE(9) + IF (ABS(BCDATA(1))0) THEN + IF (CY>0) THEN + N_AXIS=5 + ELSE + N_AXIS=6 + ENDIF + ELSEIF (CX<0) THEN + IF (CY>0) THEN + N_AXIS=3 + ELSE + N_AXIS=2 + ENDIF + ENDIF + ACX=AX+CX ; ACY=AY+CY + DELX=SQRT((ACX-BX(N_AXIS))**2+(ACY-BY(N_AXIS))**2) + CASE(10) + ACX=LX-AX + EX0=EX + IF(CX>0) THEN + ! cx>0: axis 3 + EX=0.5*EX+0.5*SQRT(3.)*EY + EY=0.5*EY-0.5*SQRT(3.)*EX0 + N_AXIS=2 + DELX=SQRT((AX-CX)*(AX-CX)+AY*AY) + ELSEIF(BCDATA(5)>0.) THEN + ! cx=0, angle>0: axis 2 (axis of angle pi/3) + EX=0.5*EX-0.5*SQRT(3.)*EY + EY=0.5*EY+0.5*SQRT(3.)*EX0 + N_AXIS=3 + DELX=SQRT(AX*AX+AY*AY) + ELSE + ! cx=0, angle=0: axis 1 (axis X) + EX=-EX + EY=-EY + N_AXIS=1 + DELX=ACX + ENDIF + CASE(11) + ACX=AX-CX ; ACY=AY-CY + AUX=2._PDB*(ACX*COSTHE+ACY*SINTHE) + AX=AUX*COSTHE-ACX+CX + AY=AUX*SINTHE-ACY+CY + DELX=LX-SQRT((AX-CX)*(AX-CX)+(AY-CY)*(AY-CY)) + EX0=EX + IF(ABS(BCDATA(5))0.) THEN + N_AXIS=2 ! cy>0: exit element is on axis 3 (angle=0) + ELSE + N_AXIS=4 ! cy=0: exit element is on axis 1 (angle=0) + ENDIF + ELSE ! exit side is on axes 2 or 4 + EX=-0.5*EX-0.5*SQRT(3.)*EY + EY=-0.5*EY+0.5*SQRT(3.)*EX0 + AX=AX-1.5*(LX-DELX) + AY=AY-0.5*SQRT(3.)*(LX-DELX) + IF(CX>0.) THEN + N_AXIS=1 ! cx>0: exit element is on axis 4 (angle>0) + ELSE + N_AXIS=3 ! cx=0: exit element is on axis 2 (angle>0) + ENDIF + ENDIF + CASE DEFAULT + CALL XABORT('SAL247_3: option not available(1)') + END SELECT + CASE(-4) + ! symmetry with respect an axis (get axis data) + ! axis: r=c+t*f (f unit vector of angle theta) + ACX=AX-CX ; ACY=AY-CY + AUX=2._PDB*(ACX*COSTHE+ACY*SINTHE) + AX=AUX*COSTHE-ACX+CX + AY=AUX*SINTHE-ACY+CY + AUX=2._PDB*(EX*COSTHE+EY*SINTHE) + EX=AUX*COSTHE-EX + EY=AUX*SINTHE-EY + SELECT CASE(TYPGEO) + CASE(6) + IF(BCDATA(5)>0.) THEN + ! vertical axes + IF(CX>0.) THEN + N_AXIS=4 + ELSE + N_AXIS=2 + ENDIF + DELX=AY + ELSE + ! horizontal axes + IF(CY>0.) THEN + N_AXIS=3 + ELSE + N_AXIS=1 + ENDIF + DELX=AX + ENDIF + CASE(7) + IF(CX>0) THEN + ! cx>0: axis 3 (vertical axis) + N_AXIS=3 + DELX=AY + ELSEIF(BCDATA(5)>0.) THEN + ! cx=0, angle>0: axis 2 (axis of angle pi/4) + N_AXIS=2 + DELX=SQRT(AX*AX+AY*AY) + ELSE + ! cx=0, angle=0: axis 1 (axis x) + N_AXIS=1 + DELX=SQRT(AX*AX+AY*AY) + ENDIF + CASE(8,12) + IF(CX>0) THEN + ! cx>0: axis 3 + N_AXIS=3 + DELX=SQRT((AX-CX)*(AX-CX)+AY*AY) + ELSEIF(BCDATA(5)>0.) THEN + ! cx=0, angle>0: axis 2 (axis of angle pi/3 or 2*pi/3) + N_AXIS=2 + DELX=SQRT(AX*AX+AY*AY) + ELSE + ! cx=0, angle=0: axis 1 (axis X) + N_AXIS=1 + DELX=AX + ENDIF + CASE DEFAULT + CALL XABORT('SAL247_3: option not available(2)') + END SELECT + CASE DEFAULT + CALL XABORT('SAL247_3: option not available(3)') + END SELECT + ! + END SUBROUTINE SAL247_3 + ! + INTEGER FUNCTION ANGLE_TO_NUMBER(EX,EY,DANGLT) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! search order number of a horizontal angle in the angular quadrature + ! formula set + ! + !Parameters: input + ! EX angle cosine + ! EY angle sine + ! DANGLT angle cosines table + ! + !--------------------------------------------------------------------- + ! + IMPLICIT NONE + REAL(PDB), INTENT(IN) :: EX,EY + REAL(PDB), INTENT(IN), DIMENSION(:,:) :: DANGLT + !*** + INTEGER :: I,NPHI + REAL(PDB) :: EXREF,EYREF + CHARACTER(LEN=131) :: HSMG + !*** + NPHI=SIZE(DANGLT,2) + ANGLE_TO_NUMBER=0 + DO I=1,NPHI + EXREF=DANGLT(1,I) ; EYREF=DANGLT(2,I) ; + IF((ABS(EX-EXREF)<1.E-3).AND.(ABS(EY-EYREF)<1.E-3)) THEN + ANGLE_TO_NUMBER=I + GO TO 10 + ELSE IF((ABS(EX-EXREF)<1.E-3).AND.(ABS(EY+EYREF)<1.E-3)) THEN + ANGLE_TO_NUMBER=2*NPHI-I+1 + GO TO 10 + ENDIF + ENDDO + WRITE(6,'(/29H ANGLE_TO_NUMBER: QUADRATURE:)') + DO I=1,2*NPHI + WRITE(6,'(1X,I5,1P,2E12.4)') I,DANGLT(:2,I) + ENDDO + WRITE(HSMG,'(47HANGLE_TO_NUMBER: UNABLE TO FIND ANGULAR COSINES,1P,2E12.4, & + & 26H INTO QUADRATURE SELECTED.)') EX,EY + CALL XABORT(HSMG) + 10 RETURN + ! + END FUNCTION ANGLE_TO_NUMBER + ! + SUBROUTINE SAL247_1(RPAR,IPAR,D,SINPHI,COSPHI,EX,EY) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! computes COSPHI and SINPHI for the intersection of the trajectory + ! with element LNEW of descriptors RPAR and IPAR. SINPHI is + ! computed with respect to directions outgoing with the trajectory + ! + !Parameters: input + ! RPAR floating point geometry descriptors + ! IPAR integer geometry descriptors + ! D distance measured along the trajectory + ! EX first exiting unit vector in along trajectory + ! EY second exiting unit vector in along trajectory + ! + !Parameters: output + ! SINPHI cosine at intersection + ! COSPHI sine at intersection + ! + !--------------------------------------------------------------------- + ! + USE SAL_TRACKING_TYPES, ONLY : AX,AY + IMPLICIT NONE + INTEGER, INTENT(IN), DIMENSION(:) :: IPAR + REAL(PDB), INTENT(IN), DIMENSION(:) :: RPAR + REAL(PDB), INTENT(IN) :: D,EX,EY + REAL(PDB), INTENT(OUT) :: SINPHI,COSPHI + !> AX AY = components of origin of trajectory + !*** + INTEGER :: TYPE + REAL(PDB) :: NX,NY + !*** + NX=0._PDB + NY=0._PDB + TYPE=IPAR(1) + SELECT CASE(TYPE) + CASE(1) + ! TYPE=1=> segment (s): R=C+T*F with T in (0,1) + ! RPAR(1),RPAR(2) = C = (CX,CY) + ! RPAR(3),RPAR(4) = F = (FX,FY) + ! components of normal + NX=RPAR(4)/RPAR(5) + NY=-RPAR(3)/RPAR(5) + CASE(2,3) + ! TYPE=2,3=> arc of circle + NX=(AX+D*EX-RPAR(1))/RPAR(3) + NY=(AY+D*EY-RPAR(2))/RPAR(3) + END SELECT + SINPHI=NX*EY-NY*EX + IF((EX*NX+EY*NY)<0._PDB) SINPHI=-SINPHI + COSPHI=SQRT(1._PDB-SINPHI*SINPHI) + ! + END SUBROUTINE SAL247_1 + ! + SUBROUTINE SAL241(PERIM,NPERIM,IPAR,RPAR,DOLD,NOLD,DNEW,NNEW,LNEW) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! computes intersection of trajectory (t): R=A+D*E with a perimeter + ! composed of the elements given in array perim + ! + !Parameters: input + ! PERIM elements in the perimeter of a node + ! NPERIM number of elements in the perimeter + ! RPAR floating point geometry descriptors + ! IPAR integer geometry descriptors + ! DOLD value of D at current position + ! NOLD current entered node + ! + !Parameters: output + ! DNEW value of D at the intersection + ! NNEW node index that is enter after intersection + ! LNEW element index that is intersected + ! + !--------------------------------------------------------------------- + ! + USE SAL_GEOMETRY_TYPES, ONLY : NRPAR,NIPAR + USE SAL_TRACKING_TYPES, ONLY : NRPART,NIPART,RPART,IPART,EPS1 + !*** + IMPLICIT NONE + INTEGER, INTENT(IN), DIMENSION(:) :: PERIM + INTEGER, INTENT(IN), DIMENSION(:,:) :: IPAR + REAL(PDB), INTENT(IN), DIMENSION(:,:) :: RPAR + INTEGER, INTENT(IN) :: NPERIM,NOLD + INTEGER, INTENT(OUT) :: NNEW,LNEW + REAL(PDB), INTENT(IN) :: DOLD + REAL(PDB), INTENT(OUT) :: DNEW + !*** + REAL(PDB) :: D + INTEGER :: I,L,INDEX,N,TYPE,NBINTE + ! INFTY is used to initialize search for minimum distance + REAL(PDB), PARAMETER :: INFTY=1.E+10 + INTEGER, PARAMETER :: FOUT =6 + !**** + ! initialize distance for intersection + DNEW=INFTY + NBER=0 + ! intersection: + DO I=1,NPERIM + L=PERIM(I) + ! get order nber of element in the perimeter + NBINTE=IPART(1,L) + IF(NBINTE<0)THEN + ! compute and store intersections + TYPE=IPAR(1,L) + IF(TYPE==1)THEN + ! segment + CALL SAL242(RPAR(:,L),IPAR(:,L),RPART(:,L),IPART(2:,L),NBINTE) + ELSEIF(TYPE<=3)THEN + ! arc of circle or circle + CALL SAL243(RPAR(:,L),IPAR(:,L),RPART(:,L),IPART(2:,L),NBINTE) + ELSE + CALL XABORT('SAL241: Not implemented') + ENDIF + IPART(1,L)=NBINTE + ENDIF + ! + IF(NBINTE/=0)THEN + DO INDEX=1,NBINTE + D=RPART(INDEX,L) + N=IPART(1+INDEX,L) + ! analyzes feasability of intersection to eliminate conflicts due + ! to concavities and crossing of mesh points + IF(N/=NOLD.AND.D>(DOLD-EPS1))THEN + NBER=NBER+1 + IF(D<(DNEW-EPS1))THEN + DNEW=D + COSINE=RPART(INDEX+2,L) + NNEW=N + LNEW=L + ELSEIF(D<(DNEW+EPS1))THEN + ! case of two close intersections : liquidate smaller + NBER=NBER-1 + IF(D>DNEW)THEN + DNEW=D + COSINE=RPART(INDEX+2,L) + NNEW=N + LNEW=L + ENDIF + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + ! + LGOK=DNEW/=INFTY + IF(LGOK)THEN + ! eliminate intersection + IPART(1,LNEW)=IPART(1,LNEW)-1 + IF(IPART(1,LNEW)==1.AND.RPART(1,LNEW)==DNEW)THEN + ! FOR AN ELEMENT WITH TWO INTERSECTIONS, MOVE 2ND + ! INTERSECTION INTO FIRST IF FIRST HAS BEEN TAKEN + RPART(1,LNEW)=RPART(2,LNEW) + RPART(3,LNEW)=RPART(4,LNEW) + IPART(2,LNEW)=IPART(3,LNEW) + ENDIF + ELSE + ! print out problem + IF(NOLD/=-100) THEN + WRITE(FOUT,*)'Problem in SAL241: NOLD, DOLD, NBINTE ',NOLD,DOLD,NBINTE + ENDIF + ENDIF + END SUBROUTINE SAL241 + ! + SUBROUTINE SAL242(RPAR,IPAR,D,NODE,NBINTE) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! analysis of the intersection of the trajectory (T):R=A+D*E and + ! a segment + ! + !Parameters: input + ! RPAR floating point geometry descriptors + ! IPAR integer geometry descriptors + ! + !Parameters: output + ! D value of D at intersection + ! NODE order nber of node entered after intersection + ! NBINTE number of intersections + ! + !--------------------------------------------------------------------- + ! + IMPLICIT NONE + INTEGER, INTENT(IN), DIMENSION(:) :: IPAR + INTEGER, INTENT(OUT), DIMENSION(:) :: NODE + INTEGER, INTENT(OUT) :: NBINTE + REAL(PDB), INTENT(IN), DIMENSION(:) :: RPAR + REAL(PDB), INTENT(OUT), DIMENSION(:) :: D + ! DIMENSION RPAR(*),IPAR(*),NODE(*),D(*) + !*** + REAL(PDB) :: CAX,CAY,FX,FY,A,DELTAM,DELTA + REAL(PDB), PARAMETER :: EPS2=0. + !*** + ! TYPE=1=> segment (S): R=C+T*F with T in (0,1) + ! RPAR(1),RPAR(2) = C = (CX,CY) + ! RPAR(3),RPAR(4) = F = (FX,FY) + ! components of vector F + FX=RPAR(3) + FY=RPAR(4) + ! DELTA=F X E + DELTA=FX*EY-FY*EX + IF(DELTA/=0._PDB)THEN + ! components of vector CA=C-A + CAX=RPAR(1)-AX + CAY=RPAR(2)-AY + ! A=AC X E + A=CAY*EX-CAX*EY + DELTAM=DELTA-A + IF(DELTAM>(-EPS2).AND.A>(-EPS2))THEN + ! crossing into + halfspace + NODE(1)=IPAR(3) + ELSEIF(DELTAM<=EPS2.AND.A<=EPS2)THEN + ! crossing into - halfspace + NODE(1)=IPAR(2) + ELSE + ! out-of-range crossing + NBINTE=0 + RETURN + ENDIF + ! compute distance to intersection along trajectory + ! D = (AC X F)/DELTA + D(1)=(CAY*FX-CAX*FY)/DELTA + D(3)=ABS(DELTA) + NBINTE=1 + ELSE + ! A/=0 => out-of-range crossing (infinity) + ! A==0 => trajectory coincides with segment + ! in any case neglect intersection + NBINTE=0 + ENDIF + END SUBROUTINE SAL242 + ! + SUBROUTINE SAL243(RPAR,IPAR,D,NODE,NBINTE) + ! + !--------------------------------------------------------------------- + ! + !Purpose: + ! analysis of the intersection of the trajectory (T):R=A+D*E and + ! a circle or arc of circle + ! + !Parameters: input + ! RPAR floating point geometry descriptors + ! IPAR integer geometry descriptors + ! + !Parameters: output + ! D value of D at intersection + ! NODE order nber of node entered after intersection + ! NBINTE number of intersections + ! + !--------------------------------------------------------------------- + ! + IMPLICIT NONE + INTEGER, INTENT(IN), DIMENSION(:) :: IPAR + INTEGER, INTENT(OUT), DIMENSION(:) :: NODE + INTEGER, INTENT(OUT) :: NBINTE + REAL(PDB), INTENT(IN), DIMENSION(:) :: RPAR + REAL(PDB), INTENT(OUT), DIMENSION(:) :: D + ! DIMENSION RPAR(*),IPAR(*),NODE(*),D(*) + !*** + INTEGER :: TYPE,I + REAL(PDB) :: CAX,CAY,RAD,RAD2,RHOMI2,DMIN,THETA,THETA1,THETA2, & + COSTHE,DELTA + REAL(PDB), PARAMETER :: EPS2=0._PDB + !*** + ! TYPE=2,3=> arc of circle (C): R=C+R*F(THETA), + ! THETA in (THETA1,THETA2) + ! RPAR(1),RPAR(2) = C = (CX,CY) + ! RPAR(3) = R = RADIUS + ! RPAR(4),RPAR(5) = (THETA1,THETA2) in (0,2PI) with THETA1 THETA1 > 0 + ! = .FALSE. => THETA1 < 0 + ! components of vector CA=C-A + CAX=RPAR(1)-AX + CAY=RPAR(2)-AY + TYPE=IPAR(1) + ! value of R2 + RAD=RPAR(3) + RAD2=RAD**2 + ! RHOMI2=(CA X E)**2 + RHOMI2=(CAX*EY-CAY*EX)**2 + IF(RAD2>=RHOMI2)THEN + DELTA=SQRT(RAD2-RHOMI2) + ! tangent point = two very close points (to avoid infinite loop) + if(delta==0._pdb) delta=small + ! DMIN=CA*E + DMIN=CAX*EX+CAY*EY + ! D(1) D(2) = min and max distances for the two intersections + D(1)=DMIN-DELTA + D(2)=DMIN+DELTA + D(3)=DELTA/RAD + D(4)=D(3) + IF(TYPE==2)THEN + ! full circle. both intersections are possible + NODE(1)=IPAR(2) + NODE(2)=IPAR(3) + NBINTE=2 + ELSE + ! analysis for arc of circle: + THETA1=RPAR(4) + THETA2=RPAR(5) + NBINTE=0 + ! compute angles for closest and farthest intersections + ! and check feasability + DO I=1,2 + COSTHE=(D(I)*EX-CAX)/RAD + THETA=SALACO(COSTHE,D(I)*EY-CAY) + IF( (((THETA1-THETA)1 read-only type(L_BURNUP, L_LIBRARY, L_EDIT +* or L_FLUX). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NDIMSA=50,MAXPAR=50,MAXISO=800,NKEYS=8,NREAK=20, + 1 MAXLIN=50,MAXMAC=2) + TYPE(C_PTR) IPSAP,IPLB1,IPLB2,IPDEPL,IPEDIT,IPFLUX + CHARACTER TEXT4*4,TEXT8*8,TEXT12*12,TEXT20*20,HSSAP*80,HSIGN*12, + 1 KEYWRD(NKEYS)*4,PARNAM(MAXPAR)*80,PARKEY(MAXPAR)*4, + 2 PARCHR(MAXPAR)*8,PARTYP(MAXPAR)*4,PARFMT(MAXPAR)*8, + 3 PARBIB(MAXPAR)*12,PARNAL(MAXPAR)*80,PARKEL(MAXPAR)*4, + 4 PARCHL(MAXPAR)*8,PARTYL(MAXPAR)*4,PARFML(MAXPAR)*8, + 5 NOMISO(MAXISO)*8,NOMEVO(MAXISO)*12,REAKEY(NREAK)*4, + 6 REANAM(NREAK)*10,NOMREA(NREAK)*12,HSMG*131,COMMEN(MAXLIN)*80, + 7 NOMMAC(MAXMAC)*8 + DOUBLE PRECISION DFLOTT + LOGICAL LINIT,LWARN,LCRON,LGNEW(MAXPAR) + INTEGER IDATA(NDIMSA),PARMIL(MAXPAR),NVALUE(MAXPAR), + 1 PARCAD(MAXPAR+1),PARPAD(MAXPAR+1),PARCAL(MAXPAR+1), + 2 PARPAL(MAXPAR+1),TYPISO(MAXISO),MUPLET(MAXPAR),TYPMAC(MAXMAC) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, POINTER, DIMENSION(:) :: HMIX + INTEGER, ALLOCATABLE, TARGET, DIMENSION(:) :: HMIX2 + REAL, ALLOCATABLE, DIMENSION(:) :: TIMES + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LOG + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPRHS +*---- +* DATA STATEMENTS +*---- + DATA KEYWRD/'NOML','PARA','LOCA','ISOT','MACR','REAC','NAME', + 1 '; '/ + DATA REAKEY/'TOTA','ABSO','SNNN','FISS','CHI ','NUFI','ENER', + 1 'EFIS','EGAM','FUIT','SELF','DIFF','PROF','TRAN', + 2 'FUIR','FUIZ','NP ','NT ','NA ','TOP1'/ + DATA REANAM/'TOTALE ','ABSORPTION','EXCESS ','FISSION ', + 1 'SPECTRE ','NU*FISSION','ENERGIE ','ENERGIE F.', + 2 'ENERGIE G.','FUITES ','SELF ','DIFFUSION ', + 3 'PROFIL ','TRANSFERT ','FUITES R ','FUITES Z ', + 4 'NP ','NT ','NA ','TOTALE P1 '/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IPRHS(NENTRY)) +*---- +* PARAMETER VALIDATION. +*---- + LINIT=.FALSE. + IF(NENTRY.EQ.0) CALL XABORT('SAP: PARAMETERS EXPECTED.') + IF((IENTRY(1).LE.2).AND.(JENTRY(1).EQ.0)) THEN + IPSAP=KENTRY(1) + LINIT=.TRUE. + HSSAP='SAPHYB LIBRARY VER. 0.02' + CALL LCMPTC(IPSAP,'TITLE',80,HSSAP) + TEXT12='L_SAPHYB' + CALL LCMPTC(IPSAP,'SIGNATURE',12,TEXT12) + ELSE IF(IENTRY(1).LE.2) THEN + IPSAP=KENTRY(1) + CALL LCMGTC(IPSAP,'TITLE',80,HSSAP) + IF(HSSAP(:6).NE.'SAPHYB') THEN + TEXT12=HENTRY(1) + CALL XABORT('SAP: SIGNATURE OF '//TEXT12//' IS '// + 1 HSSAP(:6)//'. SAPHYB EXPECTED.') + ENDIF + LINIT=.FALSE. + ELSE + CALL XABORT('SAP: SAPHYB LCM OBJECT EXPECTED.') + ENDIF + TYPISO(:MAXISO)=0 + IPLB1=C_NULL_PTR + IPLB2=C_NULL_PTR + IPDEPL=C_NULL_PTR + IPEDIT=C_NULL_PTR + IPFLUX=C_NULL_PTR + IPRHS(:NENTRY)=C_NULL_PTR + DO 10 I=2,NENTRY + IF(IENTRY(I).LE.2) THEN + IF(JENTRY(I).NE.2) CALL XABORT('SAP: READ-ONLY RHS EXPECTE' + 1 //'D.') + CALL LCMGTC(KENTRY(I),'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_LIBRARY') THEN + IF(.NOT.C_ASSOCIATED(IPLB1)) THEN + IPLB1=KENTRY(I) + ELSE + IF(.NOT.C_ASSOCIATED(IPLB2)) IPLB2=KENTRY(I) + ENDIF + ELSE IF(HSIGN.EQ.'L_BURNUP') THEN + IPDEPL=KENTRY(I) + ELSE IF(HSIGN.EQ.'L_EDIT') THEN + IPEDIT=KENTRY(I) + ELSE IF(HSIGN.EQ.'L_FLUX') THEN + IPFLUX=KENTRY(I) + ELSE IF(HSIGN.EQ.'L_SAPHYB') THEN + IPRHS(I)=KENTRY(I) + ENDIF + ELSE + CALL XABORT('SAP: LCM OBJECT EXPECTED AT RHS.') + ENDIF + 10 CONTINUE +*---- +* READ THE INPUT DATA. +*---- +* DEFAULT OPTIONS: + IMPX=1 + IF(LINIT) THEN + NCOMLI=0 + NPAR=0 + NPCHR=0 + NPPNT=0 + NLOC=0 + NPPNTL=0 + NPCHRL=0 + NISO=0 + NMAC=0 + NMIL=0 + NREA=0 + NISOF=0 + NISOP=0 + PARCAD(1)=1 + PARPAD(1)=1 + PARCAL(1)=1 + PARPAL(1)=1 + ELSE + GO TO 300 + ENDIF + 20 CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED(1).') + 30 IF(TEXT8.EQ.'EDIT') THEN +* READ THE PRINT INDEX. + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SAP: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT8.EQ.'COMM') THEN + 35 CALL REDGET(INDIC,NITMA,FLOTT,HSSAP(:72),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('SAP: COMMENTS EXPECTED.') + IF(HSSAP(:4).EQ.'ENDC') THEN + CALL LCMPTC(IPSAP,'COMMEN',80,NCOMLI,COMMEN) + GO TO 20 + ENDIF + NCOMLI=NCOMLI+1 + IF(NCOMLI.GT.MAXLIN) CALL XABORT('SAP: TITLE OVERFLOW.') + COMMEN(NCOMLI)=HSSAP(:72) + GO TO 35 + ELSE IF(TEXT8.EQ.'NOML') THEN + HSSAP=' ' + CALL REDGET(INDIC,NITMA,FLOTT,HSSAP(:72),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' + 1 //'(2).') + CALL LCMPTC(IPSAP,'NOMLIB',80,HSSAP) + ELSE IF(TEXT8.EQ.'PARA') THEN + NPAR=NPAR+1 + IF(NPAR.GT.MAXPAR) CALL XABORT('SAP: TOO MANY PARAMETERS.') + PARNAM(NPAR)=' ' + CALL REDGET(INDIC,NITMA,FLOTT,PARNAM(NPAR)(:72),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' + 1 //'(3).') + DO 40 I=1,NPAR-1 + IF(PARNAM(NPAR).EQ.PARNAM(I)) CALL XABORT('SAP: PARNAM '// + 1 PARNAM(NPAR)//' ALREADY DEFINED(1).') + 40 CONTINUE + CALL REDGET(INDIC,NITMA,FLOTT,PARKEY(NPAR),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' + 1 //'(4).') + DO 50 I=1,NPAR-1 + IF(PARKEY(NPAR).EQ.PARKEY(I)) CALL XABORT('SAP: PARKEY '// + 1 PARKEY(NPAR)//' ALREADY DEFINED(1).') + 50 CONTINUE + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' + 1 //'(4).') + IF(TEXT4.EQ.'TEMP') THEN + NPPNT=NPPNT+1 + CALL REDGET(INDIC,NITMA,FLOTT,PARBIB(NPPNT),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' + 1 //'(5).') + CALL REDGET(INDIC,PARMIL(NPPNT),FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SAP: INTEGER DATA EXPECTE'// + 1 'D(2).') + PARFMT(NPAR)='FLOTTANT' + ELSE IF(TEXT4.EQ.'CONC') THEN + NPCHR=NPCHR+1 + CALL REDGET(INDIC,NITMA,FLOTT,PARCHR(NPCHR),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' + 1 //'(6).') + NPPNT=NPPNT+1 + CALL REDGET(INDIC,NITMA,FLOTT,PARBIB(NPPNT),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' + 1 //'(7).') + CALL REDGET(INDIC,PARMIL(NPPNT),FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SAP: INTEGER DATA EXPECTE'// + 1 'D(3).') + PARFMT(NPAR)='FLOTTANT' + ELSE IF(TEXT4.EQ.'IRRA') THEN + PARFMT(NPAR)='FLOTTANT' + ELSE IF(TEXT4.EQ.'FLUX') THEN + PARFMT(NPAR)='FLOTTANT' + ELSE IF(TEXT4.EQ.'FLUB') THEN + PARFMT(NPAR)='FLOTTANT' + ELSE IF(TEXT4.EQ.'PUIS') THEN + PARFMT(NPAR)='FLOTTANT' + ELSE IF(TEXT4.EQ.'TIME') THEN + PARFMT(NPAR)='FLOTTANT' + ELSE IF(TEXT4.EQ.'VALE') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' + 1 //'(8).') + IF(TEXT8.EQ.'FLOT')THEN + PARFMT(NPAR)='FLOTTANT' + ELSEIF(TEXT8.EQ.'CHAI')THEN + PARFMT(NPAR)='CHAINE' + ELSEIF(TEXT8.EQ.'ENTI')THEN + PARFMT(NPAR)='ENTIER' + ELSE + CALL XABORT('SAP: INVALID KEYWORD='//TEXT4//'(1).') + ENDIF + ELSE + CALL XABORT('SAP: INVALID KEYWORD='//TEXT4//'(2).') + ENDIF + NVALUE(NPAR)=0 + PARTYP(NPAR)=TEXT4 + PARCAD(NPAR+1)=NPCHR+1 + PARPAD(NPAR+1)=NPPNT+1 + ELSE IF(TEXT8.EQ.'LOCA') THEN + NLOC=NLOC+1 + IF(NLOC.GT.MAXPAR) CALL XABORT('SAP: TOO MANY LOCAL VAR'// + 1 'IABLES.') + PARNAL(NLOC)=' ' + CALL REDGET(INDIC,NITMA,FLOTT,PARNAL(NLOC)(:72),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' + 1 //'(9).') + DO 60 I=1,NLOC-1 + IF(PARNAL(NLOC).EQ.PARNAL(I)) CALL XABORT('SAP: PARNAM '// + 1 PARNAL(NLOC)//' ALREADY DEFINED(2).') + 60 CONTINUE + CALL REDGET(INDIC,NITMA,FLOTT,PARKEL(NLOC),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' + 1 //'(10).') + DO 70 I=1,NLOC-1 + IF(PARKEL(NLOC).EQ.PARKEL(I)) CALL XABORT('SAP: PARKEY '// + 1 PARKEL(NLOC)//' ALREADY DEFINED(2).') + 70 CONTINUE + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' + 1 //'(11).') + IF(TEXT4.EQ.'CONC') THEN + NPCHRL=NPCHRL+1 + CALL REDGET(INDIC,NITMA,FLOTT,PARCHL(NPCHRL),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' + 1 //'(12).') + ELSE IF((TEXT4.NE.'IRRA').AND.(TEXT4.NE.'FLUG').AND. + 1 (TEXT4.NE.'FLUB').AND.(TEXT4.NE.'PUIS').AND. + 2 (TEXT4.NE.'MASL').AND.(TEXT4.NE.'FLUX').AND. + 3 (TEXT4.NE.'EQUI').AND.(TEXT4.NE.'TEMP')) THEN + CALL XABORT('SAP: INVALID KEYWORD='//TEXT4//'(3).') + ENDIF + PARFML(NLOC)='FLOTTANT' + PARTYL(NLOC)=TEXT4 + PARCAL(NLOC+1)=NPCHRL+1 + PARPAL(NLOC+1)=NPPNTL+1 + ELSE IF(TEXT8.EQ.'ISOT') THEN + 80 CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' + 1 //'(13).') + DO 90 IKEY=1,NKEYS + IF(TEXT8.EQ.KEYWRD(IKEY)) GO TO 30 + 90 CONTINUE + IF(TEXT8.EQ.'TOUT') THEN + CALL COMISO(-1,MAXISO,IPLB1,NISO,NOMISO,NOMEVO,TYPISO) + GO TO 20 + ELSE IF(TEXT8.EQ.'FISS') THEN + CALL COMISO(-2,MAXISO,IPLB1,NISO,NOMISO,NOMEVO,TYPISO) + ELSE IF(TEXT8.EQ.'PF') THEN + CALL COMISO(-3,MAXISO,IPLB1,NISO,NOMISO,NOMEVO,TYPISO) + ELSE IF(TEXT8.EQ.'MILI') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SAP: INTEGER DATA EXPECTE'// + 1 'D(4).') + CALL COMISO(NITMA,MAXISO,IPLB1,NISO,NOMISO,NOMEVO,TYPISO) + ELSE + DO 100 IKEY=1,NKEYS + IF(TEXT8.EQ.KEYWRD(IKEY)) GO TO 30 + 100 CONTINUE + NISO=NISO+1 + IF(NISO.GT.MAXISO) CALL XABORT('SAP: TOO MANY ISOTOPES.') + NOMISO(NISO)=TEXT8 + TYPISO(NISO)=0 + ENDIF + GO TO 80 + ELSE IF(TEXT8.EQ.'MACR') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' + 1 //'(14).') + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' + 1 //'(15).') + NMACRT=0 + IF(TEXT4.EQ.'TOUT') THEN + NMACRT=1 + ELSE IF(TEXT4.EQ.'REST') THEN + NMACRT=2 + ELSE + CALL XABORT('SAP: INVALID KEYWORD='//TEXT4//'(3).') + ENDIF + CALL LCMSIX(IPSAP,'contenu',1) + IF(NMAC.GT.0) THEN + CALL LCMGTC(IPSAP,'NOMMAC',8,NMAC,NOMMAC) + CALL LCMGET(IPSAP,'TYPMAC',TYPMAC) + ENDIF + NMAC=NMAC+1 + IF(NMAC.GT.MAXMAC) CALL XABORT('SAP: MAXMAC OVERFLOW.') + NOMMAC(NMAC)=TEXT8 + TYPMAC(NMAC)=NMACRT + CALL LCMPTC(IPSAP,'NOMMAC',8,NMAC,NOMMAC) + CALL LCMPUT(IPSAP,'TYPMAC',NMAC,1,TYPMAC) + CALL LCMSIX(IPSAP,' ',2) + ELSE IF(TEXT8.EQ.'REAC') THEN + 110 CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' + 1 //'(16).') + DO 120 IKEY=1,NKEYS + IF(TEXT8.EQ.KEYWRD(IKEY)) GO TO 30 + 120 CONTINUE + NREA=NREA+1 + IF(NREA.GT.NREAK) CALL XABORT('SAP: TOO MANY REACTIONS.') + DO 130 IKEY=1,NREAK + NOMREA(NREA)=REANAM(IKEY) + IF(TEXT8.EQ.REAKEY(IKEY)) GO TO 110 + 130 CONTINUE + NOMREA(NREA)=TEXT8 + GO TO 110 + ELSE IF(TEXT8.EQ.'NAME') THEN +* READ MIXTURE NAMES. + MAXMIL=30 + ALLOCATE(HMIX(5*MAXMIL)) + 140 CALL REDGET(INDIC,NITMA,FLOTT,TEXT20,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED'// + 1 '(17).') + IF(TEXT20.EQ.';') THEN + CALL LCMSIX(IPSAP,'geom',1) + IF(NMIL.GT.0) CALL LCMPUT(IPSAP,'NOMMIL',5*NMIL,3,HMIX) + CALL LCMSIX(IPSAP,' ',2) + DEALLOCATE(HMIX) + GO TO 160 + ENDIF + NMIL=NMIL+1 + IF(NMIL.GT.MAXMIL) THEN + ALLOCATE(HMIX2(5*(MAXMIL+30))) + DO 150 I=1,5*MAXMIL + HMIX2(I)=HMIX(I) + 150 CONTINUE + DEALLOCATE(HMIX) + MAXMIL=MAXMIL+30 + HMIX=>HMIX2 + ENDIF + READ(TEXT20,'(5A4)') (HMIX((NMIL-1)*5+I0),I0=1,5) + GO TO 140 + ELSE IF(TEXT8.EQ.';') THEN + GO TO 160 + ELSE + CALL XABORT('SAP: INVALID KEYWORD='//TEXT8//'(4).') + ENDIF + GO TO 20 +* +* ADD THE TIME PARAMETER. + 160 DO 170 I=1,NPAR + IF((PARTYP(I).EQ.'IRRA').OR.(PARTYP(I).EQ.'FLUB')) GO TO 180 + 170 CONTINUE + GO TO 220 + 180 DO 210 I=1,NPAR + IF(PARTYP(I).EQ.'TIME') GO TO 220 + 210 CONTINUE + NPAR=NPAR+1 + IF(NPAR.GT.MAXPAR) CALL XABORT('SAP: TOO MANY PARAMETERS.') + PARNAM(NPAR)='TEMPS' + PARKEY(NPAR)='TIME' + PARTYP(NPAR)='TIME' + PARFMT(NPAR)='FLOTTANT' + NVALUE(NPAR)=0 + PARCAD(NPAR+1)=PARCAD(1)+NPCHR + PARPAD(NPAR+1)=PARPAD(1)+NPPNT +*---- +* STORE THE SAPHYB INITIALIZATION INFORMATION. +*---- + 220 CALL LCMSIX(IPSAP,'contenu',1) + IF(NISO.GT.0) THEN + CALL COMISO(0,MAXISO,IPLB1,NISO,NOMISO,NOMEVO,TYPISO) + CALL LCMPTC(IPSAP,'NOMISO',8,NISO,NOMISO) + DO 230 I=1,NISO + IF(TYPISO(I).EQ.2) NISOF=NISOF+1 + IF(TYPISO(I).EQ.3) NISOP=NISOP+1 + 230 CONTINUE + ENDIF + IF(NREA.GT.0) CALL LCMPTC(IPSAP,'NOMREA',12,NREA,NOMREA) + CALL LCMSIX(IPSAP,' ',2) +* + IF(NPAR.GT.0) THEN + CALL LCMSIX(IPSAP,'paramdescrip',1) + CALL LCMPUT(IPSAP,'NPAR',1,1,NPAR) + CALL LCMPUT(IPSAP,'NPCHR',1,1,NPCHR) + CALL LCMPTC(IPSAP,'PARNAM',80,NPAR,PARNAM) + CALL LCMPTC(IPSAP,'PARKEY',4,NPAR,PARKEY) + CALL LCMPTC(IPSAP,'PARTYP',4,NPAR,PARTYP) + CALL LCMPTC(IPSAP,'PARFMT',8,NPAR,PARFMT) + IF(NPCHR.GT.0) THEN + CALL LCMPTC(IPSAP,'PARCHR',8,NPCHR,PARCHR) + ELSE +* dummy record to make Lisaph happy + PARCHR(1)=' ' + PARCHR(2)=' ' + CALL LCMPTC(IPSAP,'PARCHR',8,2,PARCHR) + ENDIF + CALL LCMPUT(IPSAP,'NVALUE',NPAR,1,NVALUE) + CALL LCMPUT(IPSAP,'PARCAD',NPAR+1,1,PARCAD) + CALL LCMPUT(IPSAP,'PARPAD',NPAR+1,1,PARPAD) + IF(NPPNT.GT.0) CALL LCMPUT(IPSAP,'PARMIL',NPPNT,1,PARMIL) + IF(NPPNT.GT.0) CALL LCMPTC(IPSAP,'PARBIB',12,NPPNT,PARBIB) + CALL LCMSIX(IPSAP,' ',2) + ENDIF +* + IF(NLOC.GT.0) THEN + CALL LCMSIX(IPSAP,'varlocdescri',1) + CALL LCMPUT(IPSAP,'NPAR',1,1,NLOC) + CALL LCMPUT(IPSAP,'NPCHR',1,1,NPCHRL) + CALL LCMPTC(IPSAP,'PARNAM',80,NLOC,PARNAL) + CALL LCMPTC(IPSAP,'PARKEY',4,NLOC,PARKEL) + CALL LCMPTC(IPSAP,'PARTYP',4,NLOC,PARTYL) + CALL LCMPTC(IPSAP,'PARFMT',8,NLOC,PARFML) + IF(NPCHRL.GT.0) THEN + CALL LCMPTC(IPSAP,'PARCHR',8,NPCHRL,PARCHL) + ELSE +* dummy record to make Lisaph happy + PARCHL(1)=' ' + PARCHL(2)=' ' + CALL LCMPTC(IPSAP,'PARCHR',8,2,PARCHL) + ENDIF + CALL LCMPUT(IPSAP,'PARCAD',NLOC+1,1,PARCAL) + CALL LCMPUT(IPSAP,'PARPAD',NLOC+1,1,PARPAL) + CALL LCMSIX(IPSAP,' ',2) + ENDIF +*---- +* FILL THE 'constphysiq' DIRECTORY. +*---- + IF(C_ASSOCIATED(IPLB1)) THEN + CALL LCMGET(IPLB1,'STATE-VECTOR',IDATA) + NBISO=IDATA(2) + NGA=IDATA(3) + CALL SAPFWC(IPSAP,IPLB1,MAXISO,NBISO,NGA,NISOTA) + ELSE + NBISO=0 + NGA=0 + NISOTA=0 + ENDIF +*---- +* CREATE A dummy 'geom' DIRECTORY TO MAKE LISAPH HAPPY. +*---- + CALL LCMSIX(IPSAP,'geom',1) + IDATA(1)=4040200 + CALL LCMPUT(IPSAP,'GEOTYP',1,1,IDATA) + IDATA(1)=1 + IDATA(2)=2 + IDATA(3)=3 + IDATA(4)=4 + IDATA(5)=5 + CALL LCMPUT(IPSAP,'FIRSTS',5,1,IDATA) + IDATA(1)=1 + IDATA(2)=3 + CALL LCMPUT(IPSAP,'XNP',2,1,IDATA) + FLOTT=1.0 + CALL LCMPUT(IPSAP,'XVOLMR',1,2,FLOTT) + FLOTT=1.0 + CALL LCMPUT(IPSAP,'XNUR',1,2,FLOTT) + CALL LCMSIX(IPSAP,' ',2) +*---- +* FILL THE 'contenu' DIRECTORY WITH LOGICAL INFORMATION. +*---- + CALL LCMSIX(IPSAP,'contenu',1) + IF(NISOTA*NMAC.GT.0) THEN + ALLOCATE(LOG(NISOTA*NMAC)) + LOG(:NISOTA*NMAC)=.FALSE. + CALL LCMPUT(IPSAP,'LISMAC',NISOTA*NMAC,5,LOG) + DEALLOCATE(LOG) + ENDIF + IF(NMIL*NISO.GT.0) THEN + ALLOCATE(LOG(NMIL*NISO)) + LOG(:NMIL*NISO)=.TRUE. + CALL LCMPUT(IPSAP,'LISMIL',NMIL*NISO,5,LOG) + DEALLOCATE(LOG) + ENDIF + IF(NMIL*NMAC.GT.0) THEN + ALLOCATE(LOG(NMIL*NMAC)) + LOG(:NMIL*NMAC)=.TRUE. + CALL LCMPUT(IPSAP,'LMAMIL',NMIL*NMAC,5,LOG) + DEALLOCATE(LOG) + ENDIF + IF(NREA*NISO.GT.0) THEN + ALLOCATE(LOG(NREA*NISO)) + LOG(:NREA*NISO)=.TRUE. + CALL LCMPUT(IPSAP,'LISREA',NREA*NISO,5,LOG) + DEALLOCATE(LOG) + ENDIF + IF(NREA*NMAC.GT.0) THEN + ALLOCATE(LOG(NREA*NMAC)) + LOG(:NREA*NMAC)=.TRUE. + CALL LCMPUT(IPSAP,'LMAREA',NREA*NMAC,5,LOG) + DEALLOCATE(LOG) + ENDIF + CALL LCMSIX(IPSAP,' ',2) +* + IDATA(:NDIMSA)=0 + IDATA(1)=NCOMLI + IDATA(2)=NISOTA + IDATA(4)=NREA + IDATA(5)=NISO + IDATA(6)=NMAC + IDATA(7)=NMIL + IDATA(8)=NPAR + IDATA(9)=NPCHR + IDATA(10)=NPPNT + IDATA(11)=NLOC + IDATA(12)=NPCHRL + IDATA(13)=NPPNTL + IDATA(14)=NISOF + IDATA(15)=NISOP + IDATA(16)=1 + IDATA(22)=2 + IDATA(30)=NGA + CALL LCMPUT(IPSAP,'DIMSAP',NDIMSA,1,IDATA) + IF(IMPX.GT.0) THEN + WRITE(6,400) IMPX,(IDATA(I),I=1,17) + WRITE(6,410) (IDATA(I),I=18,33) + ENDIF + GO TO 390 +* END OF SAPHYB INITIALIZATION. ********************************** +*---- +* INPUT AN ELEMENTARY CALCULATION. ******************************* +*---- + 300 CALL LCMGET(IPSAP,'DIMSAP',IDATA) + IF(IDATA(22).NE.2) CALL XABORT('SAP: INVALID VERSION OF SAP'// + 1 'HYB SPECIFICATION.') + NPAR=IDATA(8) + IF(NPAR.GT.MAXPAR) CALL XABORT('SAP: TOO MANY PARAMETERS(3).') + NPCHR=IDATA(9) + NPPNT=IDATA(10) + NCALS=IDATA(19) + NORIG=NCALS + IF(NPAR.GT.0) THEN + CALL LCMSIX(IPSAP,'paramdescrip',1) + CALL LCMGTC(IPSAP,'PARKEY',4,NPAR,PARKEY) + CALL LCMGTC(IPSAP,'PARTYP',4,NPAR,PARTYP) + CALL LCMGTC(IPSAP,'PARFMT',8,NPAR,PARFMT) + CALL LCMSIX(IPSAP,' ',2) + ENDIF +* + ITIM=0 + LWARN=.FALSE. + LCRON=.FALSE. + IMPX=1 + IPICK=0 + 310 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.10) GO TO 350 + IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED(18).') + IF(TEXT4.EQ.'EDIT') THEN +* READ THE PRINT INDEX. + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SAP: INTEGER DATA EXPECTED(5).') + ELSE IF(TEXT4.EQ.'SET') THEN + CALL REDGET(INDIC,NITMA,XT,TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('SAP: REAL DATA EXPECTED(1).') + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' + 1 //'(19).') + IF(TEXT4.EQ.'S') THEN + XT=XT*1.0E-8 + ELSE IF(TEXT4.EQ.'DAY') THEN + XT=XT*8.64E-4 + ELSE IF(TEXT4.EQ.'YEAR') THEN + XT=XT*3.1536E-1 + ELSE + CALL XABORT('SAP: S, DAY OR YEAR EXPECTED.') + ENDIF + IF(.NOT.C_ASSOCIATED(IPDEPL)) CALL XABORT('SAP: DEPLETION OBJ' + 1 //'ECT EXPECTED AT RHS.') + CALL LCMLEN(IPDEPL,'DEPL-TIMES',NTIM,ITYLCM) + IF(NTIM.EQ.0) CALL XABORT('SAP: NO DEPLETION TIME STEPS.') + ALLOCATE(TIMES(NTIM)) + CALL LCMGET(IPDEPL,'DEPL-TIMES',TIMES) + DO 320 I=1,NTIM + IF(ABS(TIMES(I)-XT).LE.1.0E-4*XT) ITIM=I + 320 CONTINUE + IF(ITIM.EQ.0) THEN + WRITE(HSMG,'(39HSAP: UNABLE TO FIND A DEPLETION DIRECTO, + 1 12HRY AT TIME =,1P,E12.4,5H DAY.)') XT/8.64E-4 + CALL XABORT(HSMG) + ENDIF + DEALLOCATE(TIMES) + IF(IMPX.GT.0) THEN + WRITE(TEXT12,'(8HDEPL-DAT,I4.4)') ITIM + WRITE(6,430) XT,XT/8.64E-4,TEXT12 + ENDIF + ELSE IF(TEXT4.EQ.'ORIG') THEN + CALL REDGET(INDIC,NORIG,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SAP: INTEGER DATA EXPECTED(6).') + ELSE IF(TEXT4.EQ.';') THEN + GO TO 350 + ELSE IF(TEXT4.EQ.'ICAL') THEN + IPICK=1 + GO TO 350 + ELSE IF(TEXT4.EQ.'WARN') THEN + LWARN=.TRUE. + ELSE IF(TEXT4.EQ.'CRON') THEN + LCRON=.TRUE. + ELSE + DO 330 IKEY=1,NPAR + IF(TEXT4.EQ.PARKEY(IKEY)) THEN + IPAR=IKEY + GO TO 340 + ENDIF + 330 CONTINUE + CALL XABORT('SAP: INVALID KEYWORD='//TEXT4//'(5).') + 340 IF(PARTYP(IPAR).NE.'VALE') CALL XABORT('SAP: '//TEXT4// + 1 ' IS NOT OF VALE TYPE.') + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(PARFMT(IPAR).EQ.'ENTIER') THEN + IF(INDIC.NE.1) CALL XABORT('SAP: INTEGER DATA EXPECTE'// + 1 'D(7).') + IF(IMPX.GT.0) WRITE(6,450) PARKEY(IPAR),NITMA + ELSE IF(PARFMT(IPAR).EQ.'FLOTTANT') THEN + IF(INDIC.NE.2) CALL XABORT('SAP: REAL DATA EXPECTED(2).') + IF(IMPX.GT.0) WRITE(6,440) PARKEY(IPAR),FLOTT + ELSE IF(PARFMT(IPAR).EQ.'CHAINE') THEN + IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPEC'// + 1 'TED(20).') + IF(IMPX.GT.0) WRITE(6,460) PARKEY(IPAR),TEXT12 + ENDIF + CALL SAPPAV(IPSAP,IPAR,NPAR,PARFMT(IPAR),FLOTT,NITMA,TEXT12, + 1 MUPLET(IPAR),LGNEW(IPAR)) + ENDIF + GO TO 310 +*---- +* RECOVER AN ELEMENTARY CALCULATION FROM EDITION. +*---- + 350 IF(NENTRY.GE.2) THEN + IF(C_ASSOCIATED(IPRHS(2))) GO TO 360 + ENDIF + IF(IMPX.GT.0) WRITE(6,420) NCALS+1 + IF(ITIM.GT.0) THEN + WRITE(TEXT12,'(8HDEPL-DAT,I4.4)') ITIM + CALL LCMSIX(IPDEPL,TEXT12,1) + ENDIF +* ------------------------------------------- + CALL SAPCAL(IMPX,IPSAP,IPDEPL,IPEDIT,LCRON) +* ------------------------------------------- +*---- +* RECOVER THE FLUX OF THE REFERENCE CALCULATION. +*---- + IF(C_ASSOCIATED(IPFLUX)) THEN + CALL LCMGET(IPFLUX,'STATE-VECTOR',IDATA) + NGA=IDATA(1) + NRT=IDATA(2) + CALL SAPFLU(IMPX,NCALS+1,IPSAP,IPFLUX,IPDEPL,NGA,NRT) + ELSE + NGA=0 + NRT=0 + ENDIF + IF(ITIM.GT.0) CALL LCMSIX(IPDEPL,' ',2) +*---- +* RECOVER REMAINING GLOBAL PARAMETER AND LOCAL VALUES. +*---- + CALL SAPGEP(IPSAP,IPDEPL,IPLB1,IPLB2,IPEDIT,IMPX,ITIM,NORIG,NPAR, + 1 MUPLET,LGNEW,NVPNEW,NCALAR) + CALL LCMGET(IPSAP,'DIMSAP',IDATA) + IF((C_ASSOCIATED(IPDEPL)).AND.(IDATA(3).EQ.0)) THEN + IDATA(3)=1 + CALL LCMSIX(IPSAP,'constphysiq',1) + WRITE(TEXT8,'(8HDECAY )') + CALL LCMPTC(IPSAP,'NOMLAM',8,TEXT8) + CALL LCMSIX(IPSAP,' ',2) + ENDIF + IDATA(17)=NVPNEW + IDATA(19)=NCALAR + IF(IDATA(28).EQ.0) THEN + IDATA(28)=NRT + ELSE + IF(NRT.NE.IDATA(28)) CALL XABORT('SAP: BAD VALUE OF NRT.') + ENDIF + IF(NGA.NE.0) THEN + IF(NGA.NE.IDATA(30)) CALL XABORT('SAP: BAD VALUE OF NGA.') + ENDIF + CALL LCMPUT(IPSAP,'DIMSAP',NDIMSA,1,IDATA) +* + NISO=IDATA(5) + NMAC=IDATA(6) + NMIL=IDATA(7) + CALL LCMSIX(IPSAP,'contenu',1) + CALL LCMLEN(IPSAP,'LISMIL',ILONG,ITYLCM) + IF((ILONG.EQ.0).AND.(NMIL*NISO.GT.0)) THEN + ALLOCATE(LOG(NMIL*NISO)) + LOG(:NMIL*NISO)=.TRUE. + CALL LCMPUT(IPSAP,'LISMIL',NMIL*NISO,5,LOG) + DEALLOCATE(LOG) + ENDIF + CALL LCMLEN(IPSAP,'LMAMIL',ILONG,ITYLCM) + IF((ILONG.EQ.0).AND.(NMIL*NMAC.GT.0)) THEN + ALLOCATE(LOG(NMIL*NMAC)) + LOG(:NMIL*NMAC)=.TRUE. + CALL LCMPUT(IPSAP,'LMAMIL',NMIL*NMAC,5,LOG) + DEALLOCATE(LOG) + ENDIF + CALL LCMSIX(IPSAP,' ',2) +* + IF(IMPX.GT.0) THEN + WRITE(6,400) IMPX,(IDATA(I),I=1,17) + WRITE(6,410) (IDATA(I),I=18,33) + ENDIF +*---- +* SAVE THE CALCULATION INDEX IN A CLE-2000 VARIABLE +*---- + IF(IPICK.EQ.1) THEN + CALL REDGET(ITYP,NITMA,FLOTT,TEXT4,DFLOTT) + IF(ITYP.NE.-1) CALL XABORT('SAP: OUTPUT INTEGER EXPECTED.') + ITYP=1 + CALL REDPUT(ITYP,NCALAR,FLOTT,TEXT4,DFLOTT) + CALL REDGET(ITYP,NITMA,FLOTT,TEXT4,DFLOTT) + IF((ITYP.NE.3).OR.(TEXT4.NE.';')) THEN + CALL XABORT('SAP: ; CHARACTER EXPECTED.') + ENDIF + ENDIF + GO TO 390 +*---- +* SAPHYB CONCATENATION. +*---- + 360 DO 370 I=2,NENTRY + IF(.NOT.C_ASSOCIATED(IPRHS(I))) GO TO 370 + CALL LCMGET(IPRHS(I),'DIMSAP',IDATA) + IF(IMPX.GT.0) WRITE(6,470) NCALS+1,NCALS+IDATA(19) +* --------------------------------------------------------- + CALL SAPCAT(IPSAP,IPRHS(I),NORIG,NPAR,MUPLET,LGNEW,LWARN) +* --------------------------------------------------------- + NCALS=NCALS+IDATA(19) + 370 CONTINUE +* + IF(IMPX.GT.0) THEN + CALL LCMGET(IPSAP,'DIMSAP',IDATA) + WRITE(6,400) IMPX,(IDATA(I),I=1,17) + WRITE(6,410) (IDATA(I),I=18,33) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 390 DEALLOCATE(IPRHS) + RETURN +* + 400 FORMAT(/19H SAP: DIMSAP VALUES/1X,19(1H-)/ + 1 7H IMPX ,I7,22H (0=NO PRINT/1=SHORT)/ + 2 7H NCOMLI,I7,43H (NB. OF COMMENT LINES IN RECORD 'COMMEN')/ + 3 7H NISOTA,I7,48H (NB. OF ISOTOPES IN THE REFERENCE CALCULATION)/ + 4 7H NCHANN,I7,34H (NB. OF RADIOACTIVE DECAY TYPES)/ + 5 7H NREA ,I7,43H (NB. OF REQUESTED NUCLEAR REACTION TYPES)/ + 6 7H NISO ,I7,44H (NB. OF PARTICULARIZED ISOTOPES IN SAPHYB)/ + 7 7H NMAC ,I7,40H (NB. OF MACROSCOPIC XS SETS IN SAPHYB)/ + 8 7H NMIL ,I7,29H (NB. OF MIXTURES IN SAPHYB)/ + 9 7H NPAR ,I7,28H (NB. OF GLOBAL PARAMETERS)/ + 1 7H NPCHR ,I7,47H (NB. OF GLOBAL PARAMETERS LINKED TO ISOTOPES)/ + 2 7H NPPNT ,I7,48H (NB. OF GLOBAL PARAMETERS LINKED TO LIBRARIES)/ + 3 7H NLOC ,I7,26H (NB. OF LOCAL VARIABLES)/ + 4 7H NPCHRL,I7,45H (NB. OF LOCAL VARIABLES LINKED TO ISOTOPES)/ + 5 7H NPPNTL,I7,46H (NB. OF LOCAL VARIABLES LINKED TO LIBRARIES)/ + 6 7H NISOF ,I7,42H (NB. OF PARTICULARIZED FISSILE ISOTOPES)/ + 7 7H NISOP ,I7,42H (NB. OF PARTICULARIZED FISSION PRODUCTS)/ + 8 7H NMGY ,I7,36H (NB. OF FISSION YIELD MACROGROUPS)/ + 9 7H NVP ,I7,45H (NB. OF NODES IN THE GLOBAL PARAMETER TREE)) + 410 FORMAT(7H NADRX ,I7,31H (NB. OF ADDRESS SETS IN ADRX)/ + 1 7H NCALS ,I7,34H (NB. OF ELEMENTARY CALCULATIONS)/ + 2 7H NG ,I7,34H (NB. OF ENERGY GROUPS IN SAPHYB)/ + 3 7H NISOY ,I7,42H (NB. OF FISSION YIELDS SETS PER MIXTURE)/ + 4 7H NVERS ,I7,40H (VERSION OF SAPHYB SPECIFICATION USED)/ + 5 7H NFACES,I7,44H (NB. OF SURFACES SURROUNDING THE GEOMETRY)/ + 6 7H NSURFS,I7,35H (NB. OF SURFACES IN THE GEOMETRY)/ + 7 7H NRINGS,I7,27H (RELATED TO THE GEOMETRY)/ + 8 7H NCASE ,I7,27H (RELATED TO THE GEOMETRY)/ + 9 7H NCOORD,I7,33H (NB. OF MESHES IN THE GEOMETRY)/ + 1 7H NRT ,I7,45H (NB. OF UNKNOWNS IN THE REFERENCE GEOMETRY)/ + 2 7H NSURFT,I7,47H (NB. OF SURFACES IN THE HOMOGENIZED GEOMETRY)/ + 3 7H NGA ,I7,43H (NB. OF GROUPS IN THE REFERENCE GEOMETRY)/ + 4 7H NPRC ,I7,43H (NB. OF DELAYED NEUTRON PRECURSOR GROUPS)/ + 5 7H NISOTS,I7,36H (NB. OF ISOTOPES IN OUTPUT TABLES)/ + 6 7H NMINLR,I7,47H (NB. OF OUTPUT MIXTURES WITH DELAYED NEUTRON , + 7 5HDATA)) + 420 FORMAT(/1X,43(1H*)/34H * SAP: ELEMENTARY CALCULATION NB.,I8, + 1 2H */1X,43(1H*)) + 430 FORMAT(/41H SAP: RECOVER INFORMATION RELATED TO TIME,1P,E12.4, + 1 8H E+8 S (,E12.4,32H DAY) FROM LCM DIRECTORY NAMED ',A12,2H'.) + 440 FORMAT(28H SAP: SET GLOBAL PARAMETER ',A,3H' =,1P,E12.4) + 450 FORMAT(28H SAP: SET GLOBAL PARAMETER ',A,3H' =,I10) + 460 FORMAT(28H SAP: SET GLOBAL PARAMETER ',A,5H' = ',A12,1H') + 470 FORMAT(/1X,55(1H*)/35H * SAP: ELEMENTARY CALCULATIONS NB.,I8, + 1 3H TO,I8,2H */1X,55(1H*)) + END diff --git a/Dragon/src/SAPCA2.f b/Dragon/src/SAPCA2.f new file mode 100644 index 0000000..b7e071a --- /dev/null +++ b/Dragon/src/SAPCA2.f @@ -0,0 +1,956 @@ +*DECK SAPCA2 + SUBROUTINE SAPCA2(IPSAP,IPEDIT,NREA,NISO,NMAC,NADRX,NED,NPRC,NG, + 1 NL,ITRANC,IMC,NMIL,NBISO,ICAL,MAXRDA,MAXIDA,FNORM,LCRON,NISOTS, + 2 NMILNR,NISFS,NISPS,NISYS,REGFLX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover the cross sections of an elementary calculation. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPSAP pointer to the Saphyb. +* IPEDIT pointer to the edition object (L_EDIT signature). +* NREA number of requested reactions. +* NISO number of particularized isotopes. +* NMAC number of macros. +* NADRX total number of ADRX sets. +* NED number of additional edition cross sections. +* NPRC number of delayed neutron precursors. +* NG number of condensed energy groups. +* NL number of Legendre orders. +* ITRANC type of transport correction. +* IMC type of macro-calculation (1 for diffusion or SPN; +* 2 other method). +* NMIL number of mixtures in the Saphyb. +* NBISO number of isotopes in the condensed microlib of the edition +* object. A given isotope may appear in many mixtures. +* ICAL index of the current elementary calculation. +* MAXRDA dimension of RDATAX array. +* MAXIDA dimension of IDATAP array. +* FNORM flux normalization factor. +* LCRON flag set to .TRUE. to put kinetics data into divers directory. +* +*Parameters: output +* NISOTS number of distinct isotopes. +* NMILNR number of mixtures with delayed neutron data. +* NISFS number of particularized fissile isotopes. +* NISPS number of particularized fission products. +* NISYS number of particularized fissile isotopes, fission products +* and macros. +* REGFLX averaged flux in the complete geometry. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSAP,IPEDIT + INTEGER NREA,NISO,NMAC,NADRX,NED,NPRC,NG,NL,ITRANC,IMC,NMIL,NBISO, + 1 ICAL,MAXRDA,MAXIDA,NISOTS,NMILNR,NISFS,NISPS,NISYS + REAL FNORM,REGFLX(NG) + LOGICAL LCRON +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NREAK=20,MAXISO=800) + TYPE(C_PTR) JPEDIT,KPEDIT,IPTEMP,KPTEMP + INTEGER FGYS(2) + REAL VALDIV(3) + CHARACTER NOMREA(NREAK)*12,NOMISO(MAXISO)*8,ISOTS(MAXISO)*8, + 1 DIRNAM*12,CM*2,TEXT8*8,TEXT12*12,IDVAL(3)*4,HSMG*131 + LOGICAL EXIST,LSPH + DOUBLE PRECISION CONV +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: RESMAC,NISOMN,ISADRX,LENGDX, + 1 LENGDP,IDATAP,IFDG,IADR,IFDG2,IADR2,IJJ1,NJJ1,IPOS,IJJ2,NJJ2,MIX, + 2 ITYPE + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISOMIL,ISONAM + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: ADRX + REAL, ALLOCATABLE, DIMENSION(:) :: RDATAX,FLUX,OVERV,WORKD,WORK1, + 1 WORK2,VOL,DEN,DENISO,CONCES,DECAYC + REAL, ALLOCATABLE, DIMENSION(:,:) :: DNUSIG,DCHI,DATA1,DATA2, + 1 DATA4,SPH + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: DATA3 + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(RESMAC(NMIL),ADRX(NREA+2,NISO+NMAC,NADRX+NMIL), + 1 ISOMIL(NISO+NMAC,NMIL),NISOMN(NMIL),ISADRX(NMIL),LENGDX(NMIL), + 2 LENGDP(NMIL),IDATAP(MAXIDA),IFDG(NG),IADR(NG+1),IFDG2(NG), + 3 IADR2(NG+1),IJJ1(NMIL),NJJ1(NMIL),IPOS(NMIL),IJJ2(NG),NJJ2(NG), + 4 ISONAM(3,NBISO),MIX(NBISO),ITYPE(NBISO)) + ALLOCATE(RDATAX(MAXRDA),FLUX(NG),OVERV(NG),DNUSIG(NG,NPRC+1), + 1 DCHI(NG,NPRC),WORKD(NPRC),WORK1(NG*NMIL+1),WORK2(NG),VOL(NMIL), + 2 DATA1(NG,NREA),DATA2(NG,NL),DATA3(NG,NG,NL),DATA4(NG,NG), + 3 DEN(NBISO),DENISO(NISO),CONCES(NBISO),DECAYC(NBISO)) +* + CONV=1.0D6 ! convert MeV to eV in H-FACTOR + IF(NREA.GT.NREAK) CALL XABORT('SAPCA2: NOMREA OVERFLOW.') +*---- +* RECOVER INFORMATION FROM THE 'contenu' DIRECTORY. +*---- + CALL LCMSIX(IPSAP,'contenu',1) + IF(NREA.GT.0) CALL LCMGTC(IPSAP,'NOMREA',12,NREA,NOMREA) + IF(NISO.GT.0) CALL LCMGTC(IPSAP,'NOMISO',8,NISO,NOMISO) + CALL LCMGET(IPSAP,'RESMAC',RESMAC) + CALL LCMSIX(IPSAP,' ',2) +*---- +* RECOVER INFORMATION FROM THE 'geom' DIRECTORY. +*---- + CALL LCMSIX(IPSAP,'geom',1) + CALL LCMGET(IPSAP,'XVOLMT',VOL) + CALL LCMSIX(IPSAP,' ',2) +*---- +* RECOVER INFORMATION FROM THE 'adresses' DIRECTORY. +*---- + CALL LCMSIX(IPSAP,'adresses',1) + CALL LCMLEN(IPSAP,'ADRX',ILONG,ITYLCM) + IF(ILONG.GT.0) CALL LCMGET(IPSAP,'ADRX',ADRX) + CALL LCMLEN(IPSAP,'NISOMN',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(IPSAP,'NISOMN',NISOMN) + ELSE + NISOMN(:NMIL)=0 + ENDIF + CALL LCMSIX(IPSAP,' ',2) +*---- +* SAVE INFORMATION TO THE 'constphysiq' DIRECTORY. +*---- + IF(ICAL.EQ.1) THEN + CALL LCMLEN(IPEDIT,'ENERGY',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + CALL LCMSIX(IPEDIT,'MACROLIB',1) + CALL LCMLEN(IPEDIT,'ENERGY',ILONG,ITYLCM) + IF(ILONG.NE.NG+1) CALL XABORT('SAPCA2: BAD VALUE OF NG(1).') + CALL LCMGET(IPEDIT,'ENERGY',WORK1) + CALL LCMSIX(IPEDIT,' ',2) + ELSE + IF(ILONG.NE.NG+1) CALL XABORT('SAPCA2: BAD VALUE OF NG(2).') + CALL LCMGET(IPEDIT,'ENERGY',WORK1) + ENDIF + CALL LCMSIX(IPSAP,'constphysiq',1) + DO 10 I=1,NG+1 + WORK1(I)=WORK1(I)*1.0E-6 + 10 CONTINUE + CALL LCMPUT(IPSAP,'ENRGS',NG+1,2,WORK1) + FGYS(1)=1 + FGYS(2)=NG+1 + CALL LCMPUT(IPSAP,'FGYS',2,1,FGYS) + CALL LCMSIX(IPSAP,' ',2) + ENDIF +*---- +* MOVE TO THE 'calc' DIRECTORY. +*---- + WRITE(DIRNAM,'(''calc'',I8)') ICAL + CALL LCMSIX(IPSAP,DIRNAM,1) +*---- +* FIND THE NUMBER AND NAMES OF THE ISOTOPES IN THE OUTPUT TABLES. +*---- + IF(NBISO.GT.0) THEN + CALL LCMGET(IPEDIT,'ISOTOPESUSED',ISONAM) + CALL LCMGET(IPEDIT,'ISOTOPESMIX',MIX) + CALL LCMGET(IPEDIT,'ISOTOPESDENS',DEN) + CALL LCMGET(IPEDIT,'ISOTOPESTYPE',ITYPE) + ENDIF + NISOTS=0 + DO 30 IBISO=1,NBISO + IF(MIX(IBISO).EQ.0) GO TO 30 + WRITE(TEXT12,'(3A4)') (ISONAM(I0,IBISO),I0=1,3) + DO 20 ISO=1,NISOTS + IF(TEXT12(:8).EQ.ISOTS(ISO)) GO TO 30 + 20 CONTINUE + NISOTS=NISOTS+1 + IF(NISOTS.GT.MAXISO) CALL XABORT('SAPCA2: ISOTS OVERFLOW.') + IF(NISOTS.GT.NBISO) CALL XABORT('SAPCA2: CONCES OVERFLOW.') + ISOTS(NISOTS)=TEXT12(:8) + 30 CONTINUE +*---- +* RECOVER INVERSE OF SPH EQUIVALENCE FACTORS. +*---- + CALL LCMSIX(IPEDIT,'MACROLIB',1) + JPEDIT=LCMGID(IPEDIT,'GROUP') + LSPH=.FALSE. + ALLOCATE(SPH(NMIL,NG)) + DO 35 IGR=1,NG + KPEDIT=LCMGIL(JPEDIT,IGR) + CALL LCMLEN(KPEDIT,'NSPH',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + LSPH=.TRUE. + CALL LCMGET(KPEDIT,'NSPH',WORK1) + DO 33 IMIL=1,NMIL + SPH(IMIL,IGR)=1.0/WORK1(IMIL) + 33 CONTINUE + ELSE + DO 34 IMIL=1,NMIL + SPH(IMIL,IGR)=1.0 + 34 CONTINUE + ENDIF + 35 CONTINUE + CALL LCMSIX(IPEDIT,' ',2) +*---- +* CREATE A SPH-UNCORRECTED MICROLIB. +*---- + CALL LCMOP(IPTEMP,'*TEMPORARY*',0,1,0) + ALLOCATE(IPISO(NBISO)) + CALL LCMEQU(IPEDIT,IPTEMP) + IF(LSPH) THEN + IF(IMC.EQ.0) CALL XABORT('SAPCA2: UNDEFINED TYPE OF SPH.') + NW=1 ! NTOT1 cross section present + NALBP=0 ! no albedo correction + CALL SPHCMI(IPTEMP,0,IMC,NMIL,NBISO,NG,NL,NW,NED,NPRC,NALBP,SPH) + ENDIF + DEALLOCATE(SPH) +*---- +* LOOP OVER SAPHYB MIXTURES. +*---- + NMILNR=0 + REGFLX(1:NG)=0.0 + VOLTOT=0.0 + DO 500 IMIL=1,NMIL + VOLTOT=VOLTOT+VOL(IMIL) + IOR=0 + IOI=0 + IIS=0 + NISMAX=NMAC + ISOMIL(:NISO+NMAC,IMIL)=0 + IADR(1)=1 +*---- +* PROCESS MACROS. +*---- + CALL LCMSIX(IPTEMP,'MACROLIB',1) + JPEDIT=LCMGID(IPTEMP,'GROUP') + NVDIV=0 + CALL LCMLEN(IPTEMP,'K-EFFECTIVE',ILONG,ITYLCM) + IF(ILONG.EQ.1) THEN + CALL LCMGET(IPTEMP,'K-EFFECTIVE',FLOTT) + NVDIV=NVDIV+1 + IDVAL(NVDIV)='KEFF' + VALDIV(NVDIV)=FLOTT + ENDIF + CALL LCMLEN(IPTEMP,'K-INFINITY',ILONG,ITYLCM) + IF(ILONG.EQ.1) THEN + CALL LCMGET(IPTEMP,'K-INFINITY',FLOTT) + NVDIV=NVDIV+1 + IDVAL(NVDIV)='KINF' + VALDIV(NVDIV)=FLOTT + ENDIF + CALL LCMLEN(IPTEMP,'B2 B1HOM',ILONG,ITYLCM) + IF(ILONG.EQ.1) THEN + CALL LCMGET(IPTEMP,'B2 B1HOM',B2) + IF(B2.EQ.0.0) B2=1.0E-10 + NVDIV=NVDIV+1 + IDVAL(NVDIV)='B2 ' + VALDIV(NVDIV)=B2 + ELSE + B2=0.0 + ENDIF + DATA2(:NG,:NL)=0.0 + DATA3(:NG,:NG,:NL)=0.0 +* + DO 90 IGR=1,NG + KPEDIT=LCMGIL(JPEDIT,IGR) +*---- +* RECOVER THE NEUTRON FLUX. +*---- + CALL LCMGET(KPEDIT,'FLUX-INTG',WORK1) + FLUX(IGR)=WORK1(IMIL)*FNORM*1.0E13 + REGFLX(IGR)=REGFLX(IGR)+FLUX(IGR) +*---- +* RECOVER DELAYED NEUTRON INFORMATION. +*---- + CALL LCMLEN(KPEDIT,'NUSIGF',ILONG,ITYLCM) + IF((NPRC.GT.0).AND.(ILONG.NE.0)) THEN + CALL LCMGET(KPEDIT,'NUSIGF',WORK1) + DNUSIG(IGR,NPRC+1)=WORK1(IMIL) + CALL LCMGET(KPEDIT,'OVERV',WORK1) + OVERV(IGR)=WORK1(IMIL) + DO 40 IPRC=1,NPRC + WRITE(TEXT12,'(6HNUSIGF,I2.2)') IPRC + CALL LCMGET(KPEDIT,TEXT12,WORK1) + DNUSIG(IGR,IPRC)=WORK1(IMIL) + WRITE(TEXT12,'(3HCHI,I2.2)') IPRC + CALL LCMGET(KPEDIT,TEXT12,WORK1) + DCHI(IGR,IPRC)=WORK1(IMIL) + 40 CONTINUE + ELSE + DNUSIG(IGR,:NPRC+1)=0.0 + ENDIF +* + DO 80 IREA=1,NREA + DATA1(IGR,IREA)=0.0 + IF(NOMREA(IREA).EQ.'TOTALE') THEN + CALL LCMGET(KPEDIT,'NTOT0',WORK1) + DATA1(IGR,IREA)=WORK1(IMIL) + ELSE IF(NOMREA(IREA).EQ.'TOTALE P1') THEN + CALL LCMGET(KPEDIT,'NTOT1',WORK1) + DATA1(IGR,IREA)=WORK1(IMIL) + ELSE IF(NOMREA(IREA).EQ.'ABSORPTION') THEN + CALL LCMGET(KPEDIT,'NTOT0',WORK1) + DATA1(IGR,IREA)=WORK1(IMIL) + CALL LCMLEN(KPEDIT,'SIGS00',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,'SIGS00',WORK1) + DATA1(IGR,IREA)=DATA1(IGR,IREA)-WORK1(IMIL) + ENDIF + CALL LCMLEN(KPEDIT,'N2N',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,'N2N',WORK1) + DATA1(IGR,IREA)=DATA1(IGR,IREA)+WORK1(IMIL) + ENDIF + CALL LCMLEN(KPEDIT,'N3N',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,'N3N',WORK1) + DATA1(IGR,IREA)=DATA1(IGR,IREA)+2.0*WORK1(IMIL) + ENDIF + ELSE IF(NOMREA(IREA).EQ.'EXCESS') THEN + CALL LCMLEN(KPEDIT,'N2N',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,'N2N',WORK1) + DATA1(IGR,IREA)=WORK1(IMIL) + ENDIF + CALL LCMLEN(KPEDIT,'N3N',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,'N3N',WORK1) + DATA1(IGR,IREA)=DATA1(IGR,IREA)+2.0*WORK1(IMIL) + ENDIF + ELSE IF(NOMREA(IREA).EQ.'FISSION') THEN + CALL LCMLEN(KPEDIT,'NFTOT',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,'NFTOT',WORK1) + DATA1(IGR,IREA)=WORK1(IMIL) + ENDIF + ELSE IF(NOMREA(IREA).EQ.'SPECTRE') THEN + CALL LCMLEN(KPEDIT,'CHI',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,'CHI',WORK1) + DATA1(IGR,IREA)=WORK1(IMIL) + ENDIF + ELSE IF(NOMREA(IREA).EQ.'NU*FISSION') THEN + CALL LCMLEN(KPEDIT,'NUSIGF',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,'NUSIGF',WORK1) + DATA1(IGR,IREA)=WORK1(IMIL) + ENDIF + ELSE IF(NOMREA(IREA).EQ.'ENERGIE') THEN + CALL LCMLEN(KPEDIT,'H-FACTOR',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,'H-FACTOR',WORK1) + DATA1(IGR,IREA)=WORK1(IMIL)/REAL(CONV) + ENDIF + ELSE IF(NOMREA(IREA).EQ.'FUITES') THEN + CALL LCMLEN(KPEDIT,'DIFF',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + IF(B2.EQ.0.0) B2=1.0E-10 + CALL LCMGET(KPEDIT,'DIFF',WORK1) + DATA1(IGR,IREA)=WORK1(IMIL)*B2 + ENDIF + ELSE IF(NOMREA(IREA).EQ.'STRD') THEN + CALL LCMLEN(KPEDIT,'DIFF',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,'DIFF',WORK1) + DATA1(IGR,IREA)=1.0/(3.0*WORK1(IMIL)) + ENDIF + ELSE IF(NOMREA(IREA).EQ.'SELF') THEN + CALL LCMGET(KPEDIT,'SIGW00',WORK1) + DATA1(IGR,IREA)=WORK1(IMIL) + ELSE IF(NOMREA(IREA).EQ.'DIFFUSION') THEN + DO 50 IL=1,NL + WRITE (CM,'(I2.2)') IL-1 + CALL LCMGET(KPEDIT,'SIGS'//CM,WORK1) + DATA2(IGR,IL)=WORK1(IMIL) + 50 CONTINUE + CALL LCMLEN(KPEDIT,'N2N',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,'N2N',WORK1) + DATA2(IGR,1)=DATA2(IGR,1)-WORK1(IMIL) + ENDIF + CALL LCMLEN(KPEDIT,'N3N',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,'N3N',WORK1) + DATA2(IGR,1)=DATA2(IGR,1)-2.0*WORK1(IMIL) + ENDIF + ELSE IF(NOMREA(IREA).EQ.'TRANSP-CORR') THEN + IF((ITRANC.EQ.1).AND.(NL.GE.2)) THEN + CALL LCMGET(KPEDIT,'SIGS01',WORK1) + DATA1(IGR,IREA)=WORK1(IMIL) + ELSE IF(ITRANC.EQ.2) THEN + CALL LCMGET(KPEDIT,'TRANC',WORK1) + DATA1(IGR,IREA)=WORK1(IMIL) + ENDIF + ELSE IF(NOMREA(IREA).EQ.'PROFIL') THEN + IFDG(IGR)=NG+1 + ILDG=0 + DO 60 IL=1,NL + WRITE (CM,'(I2.2)') IL-1 + CALL LCMGET(KPEDIT,'IJJS'//CM,IJJ1) + CALL LCMGET(KPEDIT,'NJJS'//CM,NJJ1) + IFDG(IGR)=MIN(IFDG(IGR),IJJ1(IMIL)-NJJ1(IMIL)+1) + ILDG=MAX(ILDG,IJJ1(IMIL)) + 60 CONTINUE + IADR(IGR+1)=IADR(IGR)+(ILDG-IFDG(IGR)+1) + ELSE IF(NOMREA(IREA).EQ.'TRANSFERT') THEN + DO 75 IL=1,NL + WRITE (CM,'(I2.2)') IL-1 + CALL LCMGET(KPEDIT,'IJJS'//CM,IJJ1) + CALL LCMGET(KPEDIT,'NJJS'//CM,NJJ1) + CALL LCMGET(KPEDIT,'IPOS'//CM,IPOS) + CALL LCMGET(KPEDIT,'SCAT'//CM,WORK1) + IPO=IPOS(IMIL) + J2=IJJ1(IMIL) + J1=IJJ1(IMIL)-NJJ1(IMIL)+1 + DO 70 JGR=J2,J1,-1 + DATA3(JGR,IGR,IL)=WORK1(IPO)*REAL(2*IL-1) + IPO=IPO+1 + 70 CONTINUE + 75 CONTINUE + ELSE + CALL LCMLEN(KPEDIT,NOMREA(IREA),ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,NOMREA(IREA),WORK1) + DATA1(IGR,IREA)=WORK1(IMIL) + ENDIF + ENDIF + 80 CONTINUE + 90 CONTINUE + CALL LCMSIX(IPTEMP,' ',2) +*---- +* FIND ISOTOPE POINTERS IN INPUT MICROLIB +*---- + CALL LIBIPS(IPTEMP,NBISO,IPISO) +*---- +* PROCESS PARTICULARIZED ISOTOPES +*---- + DO 105 IISO=1,NISO + DO 100 IREA=1,NREA+2 + ADRX(IREA,IISO,NADRX+1)=0 + 100 CONTINUE + 105 CONTINUE + CONCES(:NISOTS)=0.0 + DECAYC(:NISOTS)=0.0 + DO 250 IBISO=1,NBISO + IF(MIX(IBISO).EQ.IMIL) THEN + WRITE(TEXT12,'(3A4)') (ISONAM(I0,IBISO),I0=1,3) + DO 110 ISO=1,NISO + IISO=ISO + IF(NOMISO(ISO).EQ.TEXT12(:8)) GO TO 120 + 110 CONTINUE + GO TO 250 + 120 KPTEMP=IPISO(IBISO) ! set IBISO-th isotope + IF(.NOT.C_ASSOCIATED(KPTEMP)) THEN + WRITE(HSMG,'(17HSAPCA2: ISOTOPE '',A12,7H'' (ISO=,I8,3H) I, + 1 32HS NOT AVAILABLE IN THE MICROLIB.)') TEXT12,IBISO + CALL XABORT(HSMG) + ENDIF + IISOTS=0 + DO 130 ISO=1,NISOTS + IISOTS=ISO + IF(ISOTS(ISO).EQ.TEXT12(:8)) GO TO 135 + 130 CONTINUE + CALL XABORT('SAPCA2: UNABLE TO FIND ISOTOPE '//TEXT12//'.') + 135 CALL LCMLEN(KPTEMP,'DECAY',ILONG,ITYLCM) + IF(ILONG.EQ.1) THEN + CALL LCMGET(KPTEMP,'DECAY',DECAYC(IISOTS)) + ELSE + DECAYC(IISOTS)=0.0 + ENDIF + CONCES(IISOTS)=DEN(IBISO) + DENISO(IISO)=DEN(IBISO) + NISMAX=NISMAX+1 + IIS=IIS+1 + ISOMIL(IIS,IMIL)=IISO + DO 240 IREA=1,NREA + WORK2(:NG)=0.0 + IF(NOMREA(IREA).EQ.'TOTALE') THEN + CALL LCMGET(KPTEMP,'NTOT0',WORK2) + ELSE IF(NOMREA(IREA).EQ.'TOTALE P1') THEN + CALL LCMGET(KPTEMP,'NTOT1',WORK2) + ELSE IF(NOMREA(IREA).EQ.'ABSORPTION') THEN + CALL LCMGET(KPTEMP,'NTOT0',WORK2) + CALL LCMLEN(KPTEMP,'SIGS00',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPTEMP,'SIGS00',WORK1) + DO 140 IGR=1,NG + WORK2(IGR)=WORK2(IGR)-WORK1(IGR) + 140 CONTINUE + ENDIF + CALL LCMLEN(KPTEMP,'N2N',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPTEMP,'N2N',WORK1) + DO 150 IGR=1,NG + WORK2(IGR)=WORK2(IGR)+WORK1(IGR) + 150 CONTINUE + ENDIF + CALL LCMLEN(KPTEMP,'N3N',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPTEMP,'N3N',WORK1) + DO 151 IGR=1,NG + WORK2(IGR)=WORK2(IGR)+2.0*WORK1(IGR) + 151 CONTINUE + ENDIF + ELSE IF(NOMREA(IREA).EQ.'EXCESS') THEN + CALL LCMLEN(KPTEMP,'N2N',ILONG,ITYLCM) + IF(ILONG.GT.0) CALL LCMGET(KPTEMP,'N2N',WORK2) + CALL LCMLEN(KPTEMP,'N3N',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPTEMP,'N3N',WORK1) + DO 152 IGR=1,NG + WORK2(IGR)=WORK2(IGR)+2.0*WORK1(IGR) + 152 CONTINUE + ENDIF + ELSE IF(NOMREA(IREA).EQ.'FISSION') THEN + CALL LCMLEN(KPTEMP,'NFTOT',ILONG,ITYLCM) + IF(ILONG.GT.0) CALL LCMGET(KPTEMP,'NFTOT',WORK2) + ELSE IF(NOMREA(IREA).EQ.'SPECTRE') THEN + CALL LCMLEN(KPTEMP,'CHI',ILONG,ITYLCM) + IF(ILONG.GT.0) CALL LCMGET(KPTEMP,'CHI',WORK2) + ELSE IF(NOMREA(IREA).EQ.'NU*FISSION') THEN + CALL LCMLEN(KPTEMP,'NUSIGF',ILONG,ITYLCM) + IF(ILONG.GT.0) CALL LCMGET(KPTEMP,'NUSIGF',WORK2) + ELSE IF(NOMREA(IREA).EQ.'ENERGIE') THEN + CALL LCMLEN(KPTEMP,'MEVF',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPTEMP,'NFTOT',WORK2) + CALL LCMGET(KPTEMP,'MEVF',FLOTT) + DO 155 IGR=1,NG + WORK2(IGR)=WORK2(IGR)*FLOTT + 155 CONTINUE + ENDIF + CALL LCMLEN(KPTEMP,'MEVG',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPTEMP,'NG',WORK1) + CALL LCMGET(KPTEMP,'MEVG',FLOTT) + DO 160 IGR=1,NG + WORK2(IGR)=WORK2(IGR)+WORK1(IGR)*FLOTT + 160 CONTINUE + ENDIF + ELSE IF(NOMREA(IREA).EQ.'ENERGIE F.') THEN + CALL LCMLEN(KPTEMP,'MEVF',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPTEMP,'NFTOT',WORK2) + CALL LCMGET(KPTEMP,'MEVF',FLOTT) + DO 165 IGR=1,NG + WORK2(IGR)=WORK2(IGR)*FLOTT + 165 CONTINUE + ENDIF + ELSE IF(NOMREA(IREA).EQ.'ENERGIE G.') THEN + CALL LCMLEN(KPTEMP,'MEVG',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPTEMP,'NG',WORK2) + CALL LCMGET(KPTEMP,'MEVG',FLOTT) + DO 170 IGR=1,NG + WORK2(IGR)=WORK2(IGR)*FLOTT + 170 CONTINUE + ENDIF + ELSE IF(NOMREA(IREA).EQ.'STRD') THEN + CALL LCMLEN(KPTEMP,'STRD',ILONG,ITYLCM) + IF(ILONG.GT.0) CALL LCMGET(KPTEMP,'STRD',WORK2) + ELSE IF(NOMREA(IREA).EQ.'SELF') THEN + IMPX=0 + CALL XDRLGS(KPTEMP,-1,IMPX,0,0,1,NG,WORK2,DATA4,ITYPRO) + DO 175 IGR=1,NG + WORK2(IGR)=DATA4(IGR,IGR) + 175 CONTINUE + ELSE IF(NOMREA(IREA).EQ.'DIFFUSION') THEN + ADRX(IREA,IISO,NADRX+1)=IOR+1 + ADRX(NREA+1,IISO,NADRX+1)=NL + IOR=IOR+NG*NL + IF(IOR.GT.MAXRDA) CALL XABORT('SAPCA2: RDATAX OVERFLOW(1).') + DO 181 IL=1,NL + WRITE (CM,'(I2.2)') IL-1 + CALL LCMLEN(KPTEMP,'SIGS'//CM,ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPTEMP,'SIGS'//CM,WORK2) + ELSE + WORK2(:NG)=0.0 + ENDIF + CALL LCMLEN(KPTEMP,'N2N',ILONG,ITYLCM) + IF((IL.EQ.1).AND.(ILONG.GT.0)) THEN + CALL LCMGET(KPTEMP,'N2N',WORK1) + DO 176 IGR=1,NG + WORK2(IGR)=WORK2(IGR)-WORK1(IGR) + 176 CONTINUE + ENDIF + CALL LCMLEN(KPTEMP,'N3N',ILONG,ITYLCM) + IF((IL.EQ.1).AND.(ILONG.GT.0)) THEN + CALL LCMGET(KPTEMP,'N3N',WORK1) + DO 177 IGR=1,NG + WORK2(IGR)=WORK2(IGR)-2.0*WORK1(IGR) + 177 CONTINUE + ENDIF + DO 180 IGR=1,NG + RDATAX(ADRX(IREA,IISO,NADRX+1)+(IL-1)*NG+IGR-1)=WORK2(IGR) + 180 CONTINUE + 181 CONTINUE + GO TO 240 + ELSE IF(NOMREA(IREA).EQ.'TRANSP-CORR') THEN + IF((ITRANC.EQ.1).AND.(NL.GE.2)) THEN + CALL LCMGET(KPTEMP,'SIGS01',WORK2) + ELSE IF(ITRANC.EQ.2) THEN + CALL LCMGET(KPTEMP,'TRANC',WORK2) + ENDIF + ELSE IF(NOMREA(IREA).EQ.'PROFIL') THEN + DO 185 IGR=1,NG + IFDG2(IGR)=NG+1 + IADR2(IGR+1)=0 + 185 CONTINUE + DO 190 IL=1,NL + WRITE (CM,'(I2.2)') IL-1 + CALL LCMLEN(KPTEMP,'IJJS'//CM,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 190 + CALL LCMGET(KPTEMP,'IJJS'//CM,IJJ2) + CALL LCMGET(KPTEMP,'NJJS'//CM,NJJ2) + DO 186 IGR=1,NG + IFDG2(IGR)=MIN(IFDG2(IGR),IJJ2(IGR)-NJJ2(IGR)+1) + IADR2(IGR+1)=MAX(IADR2(IGR+1),IJJ2(IGR)) + 186 CONTINUE + 190 CONTINUE + IADR2(1)=1 + DO 195 IGR=1,NG + IADR2(IGR+1)=IADR2(IGR)+(IADR2(IGR+1)-IFDG2(IGR)+1) + 195 CONTINUE + ADRX(IREA,IISO,NADRX+1)=IOI+1 + ADRX(NREA+2,IISO,NADRX+1)=NL + IOI=IOI+2*NG+7 + IF(IOI.GT.MAXIDA) CALL XABORT('SAPCA2: IDATAP OVERFLOW(1).') + IDATAP(ADRX(IREA,IISO,NADRX+1))=0 + IDATAP(ADRX(IREA,IISO,NADRX+1)+1)=0 + IDATAP(ADRX(IREA,IISO,NADRX+1)+2)=0 + IDATAP(ADRX(IREA,IISO,NADRX+1)+3)=0 + IDATAP(ADRX(IREA,IISO,NADRX+1)+4)=1 + IDATAP(ADRX(IREA,IISO,NADRX+1)+5)=NG + DO 200 IGR=1,NG + IDATAP(ADRX(IREA,IISO,NADRX+1)+5+IGR)=IFDG2(IGR) + IDATAP(ADRX(IREA,IISO,NADRX+1)+5+NG+IGR)=IADR2(IGR) + 200 CONTINUE + IDATAP(ADRX(IREA,IISO,NADRX+1)+6+2*NG)=IADR2(NG+1) + GO TO 240 + ELSE IF(NOMREA(IREA).EQ.'TRANSFERT') THEN + IF(IOI.EQ.0) CALL XABORT('SAPCA2: MUST FIRST DEFINE PROF.') + ADRX(IREA,IISO,NADRX+1)=IOR+1 + IOR=IOR+(IADR2(NG+1)-1)*NL + IF(IOR.GT.MAXRDA) CALL XABORT('SAPCA2: RDATAX OVERFLOW(2).') + JOFS=0 + DO 212 IL=1,NL + IMPX=0 + CALL XDRLGS(KPTEMP,-1,IMPX,IL-1,IL-1,1,NG,WORK2,DATA4, + 1 ITYPRO) + ZIL=REAL(2*IL-1) + DO 211 IGR=1,NG + DO 210 JGR=IFDG2(IGR),IFDG2(IGR)+(IADR2(IGR+1)-IADR2(IGR))-1 + JOFS=JOFS+1 + RDATAX(ADRX(IREA,IISO,NADRX+1)+JOFS-1)=DATA4(IGR,JGR)*ZIL + 210 CONTINUE + 211 CONTINUE + 212 CONTINUE + GO TO 240 + ELSE + CALL LCMLEN(KPTEMP,NOMREA(IREA),ILONG,ITYLCM) + IF(ILONG.GT.0) CALL LCMGET(KPTEMP,NOMREA(IREA),WORK2) + ENDIF +* + EXIST=.FALSE. + DO 220 IGR=1,NG + EXIST=EXIST.OR.(WORK2(IGR).NE.0.0) + 220 CONTINUE + IF(EXIST) THEN + ADRX(IREA,IISO,NADRX+1)=IOR+1 + IOR=IOR+NG + IF(IOR.GT.MAXRDA) CALL XABORT('SAPCA2: RDATAX OVERFLOW(3).') + DO 230 IGR=1,NG + RDATAX(ADRX(IREA,IISO,NADRX+1)+IGR-1)=WORK2(IGR) + 230 CONTINUE + ELSE + ADRX(IREA,IISO,NADRX+1)=0 + ENDIF + 240 CONTINUE + ENDIF + 250 CONTINUE +*---- +* STORE MACROSCOPIC CROSS SECTIONS IN RDATAX. +*---- + DO 260 IMAC=1,NMAC + ADRX(NREA+1,NISO+IMAC,NADRX+1)=0 + ADRX(NREA+2,NISO+IMAC,NADRX+1)=0 + 260 CONTINUE + DO 340 IREA=1,NREA + IF(NOMREA(IREA).EQ.'DIFFUSION') THEN + DO 272 IMAC=1,NMAC + ADRX(IREA,NISO+IMAC,NADRX+1)=IOR+1 + ADRX(NREA+1,NISO+IMAC,NADRX+1)=NL + IOR=IOR+NG*NL + IF(IOR.GT.MAXRDA) CALL XABORT('SAPCA2: RDATAX OVERFLOW(4).') + JOFS=0 + DO 271 IL=1,NL + DO 270 IGR=1,NG + JOFS=JOFS+1 + RDATAX(ADRX(IREA,NISO+IMAC,NADRX+1)+JOFS-1)=DATA2(IGR,IL) + 270 CONTINUE + 271 CONTINUE + 272 CONTINUE + ELSE IF(NOMREA(IREA).EQ.'PROFIL') THEN + DO 290 IMAC=1,NMAC + ADRX(IREA,NISO+IMAC,NADRX+1)=IOI+1 + ADRX(NREA+2,NISO+IMAC,NADRX+1)=NL + IOI=IOI+2*NG+7 + IF(IOI.GT.MAXIDA) CALL XABORT('SAPCA2: IDATAP OVERFLOW(2).') + IDATAP(ADRX(IREA,NISO+IMAC,NADRX+1))=0 + IDATAP(ADRX(IREA,NISO+IMAC,NADRX+1)+1)=0 + IDATAP(ADRX(IREA,NISO+IMAC,NADRX+1)+2)=0 + IDATAP(ADRX(IREA,NISO+IMAC,NADRX+1)+3)=0 + IDATAP(ADRX(IREA,NISO+IMAC,NADRX+1)+4)=1 + IDATAP(ADRX(IREA,NISO+IMAC,NADRX+1)+5)=NG + DO 280 IGR=1,NG + IDATAP(ADRX(IREA,NISO+IMAC,NADRX+1)+5+IGR)=IFDG(IGR) + IDATAP(ADRX(IREA,NISO+IMAC,NADRX+1)+5+NG+IGR)=IADR(IGR) + 280 CONTINUE + IDATAP(ADRX(IREA,NISO+IMAC,NADRX+1)+6+2*NG)=IADR(NG+1) + 290 CONTINUE + ELSE IF(NOMREA(IREA).EQ.'TRANSFERT') THEN + IF(IOI.EQ.0) CALL XABORT('SAPCA2: MUST FIRST DEFINE PROF.') + DO 303 IMAC=1,NMAC + ADRX(IREA,NISO+IMAC,NADRX+1)=IOR+1 + IOR=IOR+(IADR(NG+1)-1)*NL + IF(IOR.GT.MAXRDA) CALL XABORT('SAPCA2: RDATAX OVERFLOW(5).') + JOFS=0 + DO 302 IL=1,NL + DO 301 IGR=1,NG + DO 300 JGR=IFDG(IGR),IFDG(IGR)+(IADR(IGR+1)-IADR(IGR))-1 + JOFS=JOFS+1 + RDATAX(ADRX(IREA,NISO+IMAC,NADRX+1)+JOFS-1)=DATA3(JGR,IGR,IL) + 300 CONTINUE + 301 CONTINUE + 302 CONTINUE + 303 CONTINUE + ELSE + EXIST=.FALSE. + DO 310 IGR=1,NG + EXIST=EXIST.OR.(DATA1(IGR,IREA).NE.0.0) + 310 CONTINUE + DO 330 IMAC=1,NMAC + IF(EXIST) THEN + ADRX(IREA,NISO+IMAC,NADRX+1)=IOR+1 + IOR=IOR+NG + IF(IOR.GT.MAXRDA) CALL XABORT('SAPCA2: RDATAX OVERFLOW(6).') + DO 320 IGR=1,NG + RDATAX(ADRX(IREA,NISO+IMAC,NADRX+1)+IGR-1)=DATA1(IGR,IREA) + 320 CONTINUE + ELSE + ADRX(IREA,NISO+IMAC,NADRX+1)=0 + ENDIF + 330 CONTINUE + ENDIF + 340 CONTINUE + DO 350 IMAC=1,NMAC + IIS=IIS+1 + ISOMIL(IIS,IMIL)=NISO+IMAC + 350 CONTINUE +*---- +* REMOVE PARTICULARIZED ISOTOPIC CONTRIBUTIONS FROM MACROS. +*---- + IF(RESMAC(IMIL).GT.0) THEN + DO 410 IREA=1,NREA + IMACR=ADRX(IREA,NISO+RESMAC(IMIL),NADRX+1) + IF(IMACR.EQ.0) GO TO 410 + IGRTOT=NG + IF(NOMREA(IREA).EQ.'DIFFUSION') IGRTOT=NG*NL + IF(NOMREA(IREA).EQ.'SPECTRE') GO TO 410 + IF(NOMREA(IREA).EQ.'PROFIL') GO TO 410 + DO 400 IISO=1,NISO + IF(DENISO(IISO).EQ.0.0) GO TO 400 + JMACR=ADRX(IREA,IISO,NADRX+1) + IF(JMACR.EQ.0) GO TO 400 + IF(NOMREA(IREA).EQ.'TRANSFERT') THEN + DO 370 IGR=1,NG + IFDG2(IGR)=IDATAP(ADRX(IREA-1,IISO,NADRX+1)+5+IGR) + IADR2(IGR)=IDATAP(ADRX(IREA-1,IISO,NADRX+1)+5+NG+IGR) + 370 CONTINUE + IADR2(NG+1)=IDATAP(ADRX(IREA-1,IISO,NADRX+1)+6+2*NG) + JOFS=0 + DO 382 IL=1,NL + DO 381 IGR=1,NG + DO 380 JGR=IFDG2(IGR),IFDG2(IGR)+(IADR2(IGR+1)-IADR2(IGR))-1 + I=(IL-1)*(IADR(NG+1)-1)+IADR(IGR)+JGR-IFDG(IGR) + JOFS=JOFS+1 + RDATAX(IMACR+I-1)=RDATAX(IMACR+I-1)-DENISO(IISO)* + 1 RDATAX(JMACR+JOFS-1) + 380 CONTINUE + 381 CONTINUE + 382 CONTINUE + ELSE + DO 390 IGR=1,IGRTOT + RDATAX(IMACR+IGR-1)=RDATAX(IMACR+IGR-1)-DENISO(IISO)* + 1 RDATAX(JMACR+IGR-1) + 390 CONTINUE + ENDIF + 400 CONTINUE + 410 CONTINUE + ENDIF +* + LENGDX(IMIL)=IOR + LENGDP(IMIL)=IOI + DO 430 IADRX=1,NADRX + DO 425 I=1,NREA+2 + DO 420 J=1,NISO+NMAC + IF(ADRX(I,J,NADRX+1).NE.ADRX(I,J,IADRX)) GO TO 430 + 420 CONTINUE + 425 CONTINUE + ISADRX(IMIL)=IADRX + GO TO 440 + 430 CONTINUE + NADRX=NADRX+1 + ISADRX(IMIL)=NADRX +*---- +* STORE INFORMATION IN THE MIXTURE DIRECTORY. +*---- + 440 WRITE(DIRNAM,'(''mili'',I8)') IMIL + CALL LCMSIX(IPSAP,DIRNAM,1) + CALL LCMPUT(IPSAP,'FLUXS',NG,2,FLUX) + IF(LENGDX(IMIL).GT.0) THEN + CALL LCMPUT(IPSAP,'RDATAX',LENGDX(IMIL),2,RDATAX) + ENDIF + IF(LENGDP(IMIL).GT.0) THEN + CALL LCMPUT(IPSAP,'IDATAP',LENGDP(IMIL),1,IDATAP) + ENDIF + IF(NISOTS.GT.0) THEN + CALL LCMPUT(IPSAP,'CONCES',NISOTS,2,CONCES) + DO 445 ISO=1,NISOTS + DECAYC(ISO)=DECAYC(ISO)*1.0E-8 + 445 CONTINUE + CALL LCMPUT(IPSAP,'DECAYC',NISOTS,2,DECAYC) + ENDIF + CALL LCMSIX(IPSAP,' ',2) +* + NISOMN(IMIL)=MAX(NISOMN(IMIL),NISMAX) + IF(NPRC.GT.0) THEN + EXIST=.FALSE. + DO 455 IPRC=1,NPRC + DO 450 IGR=1,NG + EXIST=EXIST.OR.(DNUSIG(IGR,IPRC).NE.0.0) + 450 CONTINUE + 455 CONTINUE + IF(EXIST) THEN + NMILNR=NMILNR+1 + IF(LCRON) THEN + IF(NMIL.NE.1) CALL XABORT('SAPCA2: NMIL=1 MANDATORY WITH' + 1 //' CRONOS OPTION.') + CALL LCMSIX(IPSAP,'divers',1) + ELSE + CALL LCMSIX(IPSAP,DIRNAM,1) + CALL LCMSIX(IPSAP,'cinetique',1) + ENDIF + CALL LCMPUT(IPSAP,'NPR',1,1,NPRC) + CALL LCMPUT(IPSAP,'CHIRS',NG*NPRC,2,DCHI) + CALL LCMPUT(IPSAP,'INVELS',NG,2,OVERV) + CALL LCMSIX(IPTEMP,'MACROLIB',1) + CALL LCMGET(IPTEMP,'LAMBDA-D',WORKD) + CALL LCMSIX(IPTEMP,' ',2) + CALL LCMPUT(IPSAP,'LAMBRS',NPRC,2,WORKD) + TGENRS=0.0 + DENOM=0.0 + DO 460 IGR=1,NG + TGENRS=TGENRS+OVERV(IGR)*FLUX(IGR) + DENOM=DENOM+DNUSIG(IGR,NPRC+1)*FLUX(IGR) + 460 CONTINUE + TGENRS=TGENRS/DENOM + DO 480 IPRC=1,NPRC + WORKD(IPRC)=0.0 + DO 470 IGR=1,NG + WORKD(IPRC)=WORKD(IPRC)+DNUSIG(IGR,IPRC)*FLUX(IGR) + 470 CONTINUE + WORKD(IPRC)=WORKD(IPRC)/DENOM + 480 CONTINUE + CALL LCMPUT(IPSAP,'BETARS',NPRC,2,WORKD) + CALL LCMPUT(IPSAP,'TGENRS',1,2,TGENRS) + IF(LCRON) THEN + CALL LCMSIX(IPSAP,' ',2) + ELSE + CALL LCMSIX(IPSAP,' ',2) + CALL LCMSIX(IPSAP,' ',2) + ENDIF + ENDIF + ENDIF + 500 CONTINUE + DO IGR=1,NG + REGFLX(IGR)=REGFLX(IGR)/VOLTOT + ENDDO + DEALLOCATE(IPISO) + CALL LCMCL(IPTEMP,2) +*---- +* STORE INFORMATION IN THE ELEMENTARY CALCULATION DIRECTORIES. +*---- + NISFS=0 + NISPS=0 + DO 530 ISO=1,NISO + DO 510 IBISO=1,NBISO + WRITE(TEXT8,'(2A4)') (ISONAM(I0,IBISO),I0=1,2) + IF(NOMISO(ISO).EQ.TEXT8) THEN + ITY=ITYPE(IBISO) + GO TO 520 + ENDIF + 510 CONTINUE + GO TO 530 + 520 IF(ITY.EQ.2) THEN + NISFS=NISFS+1 + ELSE IF(ITY.EQ.3) THEN + NISPS=NISPS+1 + ENDIF + 530 CONTINUE + IF(NISPS.EQ.0) THEN + NISYS=0 + ELSE + NISYS=NISO+NMAC + ENDIF + CALL LCMSIX(IPSAP,'info',1) + CALL LCMPUT(IPSAP,'NISOTS',1,1,NISOTS) + CALL LCMPUT(IPSAP,'NISF',1,1,NISFS) + CALL LCMPUT(IPSAP,'NISP',1,1,NISPS) + CALL LCMPUT(IPSAP,'NISY',1,1,NISYS) + IF(NISOTS.GT.0) CALL LCMPTC(IPSAP,'ISOTS',8,NISOTS,ISOTS) + CALL LCMPUT(IPSAP,'ISADRX',NMIL,1,ISADRX) + CALL LCMPUT(IPSAP,'LENGDX',NMIL,1,LENGDX) + CALL LCMPUT(IPSAP,'LENGDP',NMIL,1,LENGDP) + CALL LCMSIX(IPSAP,' ',2) +* + IF(NVDIV.GT.0) THEN + CALL LCMSIX(IPSAP,'divers',1) + CALL LCMPUT(IPSAP,'NVDIV',1,1,NVDIV) + CALL LCMPTC(IPSAP,'IDVAL',4,NVDIV,IDVAL) + CALL LCMPUT(IPSAP,'VALDIV',NVDIV,2,VALDIV) + CALL LCMSIX(IPSAP,' ',2) + ENDIF +*---- +* MOVE TO THE SAPHYB ROOT DIRECTORY. +*---- + CALL LCMSIX(IPSAP,' ',2) +*---- +* STORE INFORMATION IN THE 'adresses' DIRECTORY. +*---- + CALL LCMSIX(IPSAP,'adresses',1) + CALL LCMPUT(IPSAP,'ADRX',(NREA+2)*(NISO+NMAC)*NADRX,1,ADRX) + CALL LCMPUT(IPSAP,'ISOMIL',(NISO+NMAC)*NMIL,1,ISOMIL) + CALL LCMPUT(IPSAP,'NISOMN',NMIL,1,NISOMN) + CALL LCMPUT(IPSAP,'ISADRC',NMIL,1,ISADRX) + CALL LCMSIX(IPSAP,' ',2) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(DECAYC,CONCES,DENISO,DEN,DATA4,DATA3,DATA2,DATA1,VOL, + 1 WORK2,WORK1,WORKD,DCHI,DNUSIG,OVERV,FLUX,RDATAX) + DEALLOCATE(ITYPE,MIX,ISONAM,NJJ2,IJJ2,IPOS,NJJ1,IJJ1,IADR2,IFDG2, + 1 IADR,IFDG,IDATAP,LENGDP,LENGDX,ISADRX,NISOMN,ISOMIL,ADRX,RESMAC) + RETURN + END diff --git a/Dragon/src/SAPCAL.f b/Dragon/src/SAPCAL.f new file mode 100644 index 0000000..5cb8f69 --- /dev/null +++ b/Dragon/src/SAPCAL.f @@ -0,0 +1,213 @@ +*DECK SAPCAL + SUBROUTINE SAPCAL(IMPX,IPSAP,IPDEPL,IPEDIT,LCRON) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Store the results of an elementary calculation in the Saphyb. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IMPX print parameter. +* IPSAP pointer to the Saphyb. +* IPDEPL pointer to the burnup object (L_BURNUP signature). +* IPEDIT pointer to the edition object (L_EDIT signature). +* LCRON flag set to .TRUE. to put kinetics data into divers directory. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSAP,IPDEPL,IPEDIT,IPSPH + INTEGER IMPX + LOGICAL LCRON +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NDIMSA=50,NSTATE=40,MAXMAC=2) + INTEGER IDATA(NDIMSA),IPAR(NSTATE),TYPMAC(MAXMAC) + REAL BIRRAD(2) + CHARACTER CDIRO*12,HSMG*131,TEXT20*20 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: HMIX,IWORKT,IWORKR + REAL, ALLOCATABLE, DIMENSION(:) :: VOL,REGFLX +* + CALL LCMGTC(IPEDIT,'LAST-EDIT',12,CDIRO) + CALL LCMSIX(IPEDIT,CDIRO,1) + CALL LCMLEN(IPEDIT,'STATE-VECTOR',ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + CALL LCMGET(IPEDIT,'STATE-VECTOR',IPAR) + NBISO=IPAR(2) + NED=IPAR(13) + NPRC=IPAR(19) + NDFI=IPAR(20) + ELSE + NBISO=0 + NDFI=0 + ENDIF + CALL LCMSIX(IPEDIT,'MACROLIB',1) + CALL LCMGET(IPEDIT,'STATE-VECTOR',IPAR) + NG=IPAR(1) + NMIL=IPAR(2) + NL=IPAR(3) + IF(IPAR(4).GT.1) CALL XABORT('SAPCAL: CANNOT PROCESS MULTIPLE FI' + 1 //'SSION SPECTRA.') + NED=IPAR(5) + ITRANC=IPAR(6) + NPRC=IPAR(7) + IDF=IPAR(12) + CALL LCMLEN(IPEDIT,'SPH',ILEN,ITYLCM) + IF(ILEN.NE.0) THEN + IPSPH=LCMGID(IPEDIT,'SPH') + CALL LCMGET(IPSPH,'STATE-VECTOR',IPAR) + IMC=IPAR(6) + ELSE + IMC=0 + ENDIF +* + CALL LCMGET(IPSAP,'DIMSAP',IDATA) + NREA=IDATA(4) + NISO=IDATA(5) + NMAC=IDATA(6) + NADRX=IDATA(18) + ICAL=IDATA(19)+1 + IF(IDATA(19).EQ.0) THEN +* COMPLETE DIMSAP AND CONTENU DIRECTORY. + IF(IDATA(7).EQ.0) THEN + IDATA(7)=NMIL + ALLOCATE(HMIX(5*NMIL)) + DO 10 IMIL=1,NMIL + TEXT20=' ' + WRITE(TEXT20,'(3HMIX,I5.5)') IMIL + READ(TEXT20,'(5A4)') (HMIX((IMIL-1)*5+I0),I0=1,5) + 10 CONTINUE + CALL LCMSIX(IPSAP,'geom',1) + CALL LCMPUT(IPSAP,'NOMMIL',5*NMIL,3,HMIX) + CALL LCMSIX(IPSAP,' ',2) + DEALLOCATE(HMIX) + ELSE IF(NMIL.NE.IDATA(7)) THEN + WRITE(HSMG,'(42HSAPCAL: ELEMENTARY CALCULATION WITH AN INV, + 1 22HALIB NB. OF MIXTURES =,I7,3H NE,I7,1H.)') NMIL,IDATA(7) + CALL XABORT(HSMG) + ENDIF + IDATA(20)=NG + IDATA(31)=NPRC + CALL LCMSIX(IPSAP,'contenu',1) + ALLOCATE(IWORKT(NMIL),IWORKR(NMIL)) + IWORKT(:NMIL)=0 + IWORKR(:NMIL)=0 + IF(NMAC.GT.0) CALL LCMGET(IPSAP,'TYPMAC',TYPMAC) + DO 20 IMAC=1,NMAC + IF(TYPMAC(IMAC).EQ.1) IWORKT(:NMIL)=IMAC + IF(TYPMAC(IMAC).EQ.2) IWORKR(:NMIL)=IMAC + 20 CONTINUE + CALL LCMPUT(IPSAP,'TOTMAC',NMIL,1,IWORKT) + CALL LCMPUT(IPSAP,'RESMAC',NMIL,1,IWORKR) + DEALLOCATE(IWORKR,IWORKT) + CALL LCMSIX(IPSAP,' ',2) +* +* RECOVER MIXTURE VOLUMES. + ALLOCATE(VOL(NMIL)) + CALL LCMGET(IPEDIT,'VOLUME',VOL) + CALL LCMSIX(IPSAP,'geom',1) + CALL LCMPUT(IPSAP,'XVOLMT',NMIL,2,VOL) + DEALLOCATE(VOL) + CALL LCMSIX(IPSAP,' ',2) + ELSE + IF(NMIL.NE.IDATA(7)) THEN + WRITE(HSMG,'(42HSAPCAL: ELEMENTARY CALCULATION WITH AN INV, + 1 22HALIB NB. OF MIXTURES =,I7,3H NE,I7,1H.)') NMIL,IDATA(7) + CALL XABORT(HSMG) + ELSE IF(NG.NE.IDATA(20)) THEN + WRITE(HSMG,'(42HSAPCAL: ELEMENTARY CALCULATION WITH AN INV, + 1 20HALIB NB. OF GROUPS =,I7,3H NE,I7,1H.)') NG,IDATA(20) + CALL XABORT(HSMG) + ENDIF + ENDIF + CALL LCMSIX(IPEDIT,' ',2) +*---- +* RECOVER THE FLUX NORMALIZATION FACTOR. +*---- + IF(C_ASSOCIATED(IPDEPL)) THEN + CALL LCMGET(IPDEPL,'BURNUP-IRRAD',BIRRAD) + BURN=BIRRAD(1) + CALL LCMLEN(IPDEPL,'FLUX-NORM',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + WRITE(HSMG,'(40HSAPCAL: THE ''FLUX-NORM'' RECORD IS NOT SE, + 1 20HT FOR BURNUP STEP AT,E12.5,14H MW-DAY/TONNE.)') BURN + CALL XABORT(HSMG) + ENDIF + CALL LCMGET(IPDEPL,'FLUX-NORM',FNORM) + IF(IMPX.GT.0) WRITE(6,100) FNORM,BURN + ELSE + FNORM=1.0 + IF(IMPX.GT.0) WRITE(6,110) + ENDIF +*---- +* RECOVER THE CROSS SECTIONS. +*---- + ALLOCATE(REGFLX(NG)) + MAXRDA=(NREA*NG+NL*NG+NL*NG*NG)*(NISO+NMAC) + MAXIDA=(2*NG+7)*NL*(NISO+NMAC) + CALL SAPCA2(IPSAP,IPEDIT,NREA,NISO,NMAC,NADRX,NED,NPRC,NG,NL, + 1 ITRANC,IMC,NMIL,NBISO,ICAL,MAXRDA,MAXIDA,FNORM,LCRON,NISOTS, + 2 NMILNR,NISFS,NISPS,NISYS,REGFLX) +*---- +* RECOVER DISCONTINUITY FACTOR INFORMATION. +*---- + IF((IDF.EQ.2).OR.(IDF.EQ.3)) THEN + CALL SAPIDF(IPSAP,IPEDIT,NG,NMIL,ICAL,IDF,FNORM,REGFLX) + ENDIF + DEALLOCATE(REGFLX) +*---- +* COMPLETE DIMSAP. +*---- + IDATA(18)=NADRX + IF(IDATA(21).EQ.0) THEN + IDATA(21)=NISYS + IDATA(32)=NISOTS + IDATA(33)=NMILNR + ELSE + IF(NISYS.NE.IDATA(21)) THEN + WRITE(HSMG,'(42HSAPCAL: ELEMENTARY CALCULATION WITH AN INV, + 1 21HALIB VALUE OF NISOY =,I7,3H NE,I7,1H.)') NISYS,IDATA(21) + CALL XABORT(HSMG) + ELSE IF(NISOTS.NE.IDATA(32)) THEN + WRITE(HSMG,'(43HSAPCAL: ELEMENTARY CALCULATION WITH AN INVA, + 1 21HLIB NB. OF ISOTOPES =,I7,3H NE,I7,1H.)') NISOTS,IDATA(32) + CALL XABORT(HSMG) + ELSE IF(NMILNR.NE.IDATA(33)) THEN + WRITE(HSMG,'(43HSAPCAL: ELEMENTARY CALCULATION WITH AN INVA, + 1 47HLIB NB. OF MIXTURES WITH DELAYED NEUTRON DATA =,I7,3H NE, + 2 I7,1H.)') NMILNR,IDATA(33) + CALL XABORT(HSMG) + ENDIF + ENDIF +*---- +* RECOVER THE FISSION YIELDS. +*---- + IF(NISYS.GT.0) THEN + CALL SAPGEY(IPSAP,IPEDIT,NISO,NMAC,NG,NMIL,NBISO,ICAL,NDFI, + 1 NISFS,NISPS,NISYS) + ENDIF +* + CALL LCMSIX(IPEDIT,' ',2) + CALL LCMPUT(IPSAP,'DIMSAP',NDIMSA,1,IDATA) + RETURN +* + 100 FORMAT(45H SAPCAL: NORMALIZE THE FLUX WITH THE FACTOR =,1P,E12.5, + 1 26H TAKEN FROM BURNUP STEP AT,E12.5,14H MW-DAY/TONNE.) + 110 FORMAT(36H SAPCAL: THE FLUX IS NOT NORMALIZED.) + END diff --git a/Dragon/src/SAPCAT.f b/Dragon/src/SAPCAT.f new file mode 100644 index 0000000..26da358 --- /dev/null +++ b/Dragon/src/SAPCAT.f @@ -0,0 +1,295 @@ +*DECK SAPCAT + SUBROUTINE SAPCAT(IPSAP,IPRHS,NORIG,NPARN,MUPCPO,LGNCPO,LWARN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To catenate a RHS saphyb into the output saphyb. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPSAP pointer to the output saphyb. +* IPRHS pointer to the rhs saphyb (contains the new calculations). +* NORIG index of the elementary calculation associated to the +* father node in the parameter tree. +* NPARN number of global parameters in the output saphyb. +* MUPCPO tuple of the new global parameters in the output saphyb. +* LGNCPO LGNEW value of the new global parameters in the output +* saphyb. +* LWARN logical used in case if an elementary calculation in the RHS +* is already present in saphyb. If LWARN=.true. a warning is +* send and the saphyb values are kept otherwise XABORT is +* called (default). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSAP,IPRHS + INTEGER NORIG,NPARN,MUPCPO(NPARN) + LOGICAL LGNCPO(NPARN),LWARN +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NDIMSA=50,MAXPAR=50,MAXVAL=1000) + INTEGER IDATA(NDIMSA),NVALUE(2*MAXPAR),MUPLET(2*MAXPAR), + 1 MUPRHS(2*MAXPAR) + CHARACTER HSMG*131,RECNAM*12,TEXT4*4,TEXT12*12,PARFMT(MAXPAR)*8, + 1 VCHAR(MAXVAL)*12,PARKEY(MAXPAR)*4,PARCPO(MAXPAR)*4,DIRNAM*12 + LOGICAL COMTRE,LGERR,LGNEW(MAXPAR) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IORRHS,JDEBAR,JARBVA,VINTE, + 1 IDEBAR,IARBVA,IORIGI + REAL, ALLOCATABLE, DIMENSION(:) :: VREAL +* + CALL LCMGET(IPRHS,'DIMSAP',IDATA) + NMIL=IDATA(7) + NPAR=IDATA(8) + NLOC=IDATA(11) + NVPR=IDATA(17) ! number of nodes in RHS + NCALR=IDATA(19) ! number of calculations in RHS + NG=IDATA(20) + IF(NCALR.EQ.0) CALL XABORT('SAPCAT: NO CALCULATION IN RHS SAPHYB' + 1 //'.') +* + CALL LCMGET(IPSAP,'DIMSAP',IDATA) + NVPO=IDATA(17) ! initial number of nodes in LHS SAPHYB + NCAL=IDATA(19) ! initial number of calculations in LHS SAPHYB + IF(NPARN.GT.MAXPAR) CALL XABORT('SAPCAT: MAXPAR OVERFLOW.') + IF(NCAL.EQ.0) THEN +* COMPLETE STATE-VECTOR. + IF(IDATA(7).EQ.0) THEN + IDATA(7)=NMIL + ELSE IF(NMIL.NE.IDATA(7)) THEN + WRITE(HSMG,'(42HSAPCAT: ELEMENTARY CALCULATION WITH AN INV, + 1 22HALIB NB. OF MIXTURES =,I7,3H NE,I7,1H.)') NMIL,IDATA(7) + CALL XABORT(HSMG) + ENDIF + IDATA(20)=NG + ELSE + IF(NMIL.NE.IDATA(7)) THEN + WRITE(HSMG,'(42HSAPCAT: ELEMENTARY CALCULATION WITH AN INV, + 1 22HALIB NB. OF MIXTURES =,I7,3H NE,I7,1H.)') NMIL,IDATA(7) + CALL XABORT(HSMG) + ELSE IF(NG.NE.IDATA(20)) THEN + WRITE(HSMG,'(42HSAPCAT: ELEMENTARY CALCULATION WITH AN INV, + 1 20HALIB NB. OF GROUPS =,I7,3H NE,I7,1H.)') NG,IDATA(20) + CALL XABORT(HSMG) + ENDIF + ENDIF + IF(NPAR.GT.NPARN) THEN + WRITE(HSMG,'(42HSAPCAT: ELEMENTARY CALCULATION WITH AN INV, + 1 31HALIB NB. OF GLOBAL PARAMETERS =,I7,3H NE,I7,1H.)') NPAR, + 2 NPARN + CALL XABORT(HSMG) + ELSE IF(NLOC.NE.IDATA(11)) THEN + WRITE(HSMG,'(42HSAPCAT: ELEMENTARY CALCULATION WITH AN INV, + 1 30HALIB NB. OF LOCAL PARAMETERS =,I7,3H NE,I7,1H.)') NLOC, + 2 IDATA(11) + CALL XABORT(HSMG) + ENDIF +*---- +* ADJUST THE SIZE OF THE OUTPUT SAPHYB AND UPDATE THE STATE-VECTOR +*---- + IDATA(19)=IDATA(19)+NCALR + CALL LCMPUT(IPSAP,'DIMSAP',NDIMSA,1,IDATA) +*---- +* MAIN LOOP OVER THE NCALR ELEMENTARY CALCULATIONS OF THE RHS SAPHYB +*---- + NIDEM=0 + NCALS=NCAL + DO 170 ICAL=1,NCALR +*---- +* COMPUTE THE MUPLET VECTOR FROM THE RHS SAPHYB +*---- + CALL LCMSIX(IPRHS,'paramarbre',1) + CALL LCMLEN(IPRHS,'ARBVAL',MAXNVP,ITYLCM) + CALL LCMLEN(IPRHS,'ORIGIN',MAXNCA,ITYLCM) + ALLOCATE(IORRHS(MAXNCA)) + CALL LCMGET(IPRHS,'ORIGIN',IORRHS) + ALLOCATE(JDEBAR(MAXNVP+1),JARBVA(MAXNVP)) + CALL LCMGET(IPRHS,'DEBARB',JDEBAR) + CALL LCMGET(IPRHS,'ARBVAL',JARBVA) + CALL LCMSIX(IPRHS,' ',2) + DO 30 I=NVPR-NCALR+1,NVPR + IF(JDEBAR(I+1).EQ.ICAL) THEN + I0=I + GO TO 40 + ENDIF + 30 CONTINUE + CALL XABORT('SAPCAT: MUPLET ALGORITHM FAILURE 1.') + 40 MUPRHS(NPAR)=JARBVA(I0) + DO 65 IPAR=NPAR-1,1,-1 + DO 50 I=1,NVPR-NCALR + IF(JDEBAR(I+1).GT.I0) THEN + I0=I + GO TO 60 + ENDIF + 50 ENDDO + CALL XABORT('SAPCAT: MUPLET ALGORITHM FAILURE 2.') + 60 MUPRHS(IPAR)=JARBVA(I0) + 65 CONTINUE + DEALLOCATE(JARBVA,JDEBAR) +*---- +* RECOVER THE GLOBAL PARAMETERS +*---- + DO 70 I=1,NPARN + MUPLET(I)=MUPCPO(I) + LGNEW(I)=LGNCPO(I) + 70 CONTINUE + CALL LCMSIX(IPSAP,'paramdescrip',1) + CALL LCMGTC(IPSAP,'PARKEY',4,NPARN,PARCPO) + CALL LCMSIX(IPSAP,' ',2) + CALL LCMSIX(IPRHS,'paramdescrip',1) + CALL LCMGTC(IPRHS,'PARKEY',4,NPAR,PARKEY) + CALL LCMGTC(IPRHS,'PARFMT',8,NPAR,PARFMT) + CALL LCMGET(IPRHS,'NVALUE',NVALUE) + CALL LCMSIX(IPRHS,' ',2) + DO 100 IPAR=1,NPAR + DO 80 I0=1,NPARN + IF(PARKEY(IPAR).EQ.PARCPO(I0)) THEN + IPARN=I0 + GO TO 90 + ENDIF + 80 CONTINUE + CALL XABORT('SAPCAT: UNABLE TO FIND '//PARKEY(IPAR)//'.') + 90 WRITE(RECNAM,'(''pval'',I8)') IPAR + IVAL=MUPRHS(IPAR) + CALL LCMSIX(IPRHS,'paramvaleurs',1) + IF(PARFMT(IPAR).EQ.'FLOTTANT') THEN + ALLOCATE(VREAL(NVALUE(IPAR))) + CALL LCMGET(IPRHS,RECNAM,VREAL) + FLOTT=VREAL(IVAL) + DEALLOCATE(VREAL) + ELSE IF(PARFMT(IPAR).EQ.'ENTIER') THEN + ALLOCATE(VINTE(NVALUE(IPAR))) + CALL LCMGET(IPRHS,RECNAM,VINTE) + NITMA=VINTE(IVAL) + DEALLOCATE(VINTE) + ELSE IF(PARFMT(IPAR).EQ.'CHAINE') THEN + IF(NVALUE(IPAR).GT.MAXVAL) CALL XABORT('SAPCAT: MAXVAL OVE' + 1 //'RFLOW.') + CALL LCMGTC(IPRHS,RECNAM,12,NVALUE(IPAR),VCHAR) + TEXT12=VCHAR(IVAL) + ENDIF + CALL LCMSIX(IPRHS,' ',2) + CALL SAPPAV(IPSAP,IPARN,NPARN,PARFMT(IPAR),FLOTT,NITMA,TEXT12, + 1 MUPLET(IPARN),LGNEW(IPARN)) + 100 CONTINUE +*---- +* UPDATE THE PARAMETER TREE IN THE OUTPUT SAPHYB +*---- + CALL LCMSIX(IPSAP,'paramarbre',1) + CALL LCMLEN(IPSAP,'ARBVAL',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + MAXNVP=20*(NPARN+1) + ALLOCATE(IDEBAR(MAXNVP+1),IARBVA(MAXNVP)) + IDEBAR(:MAXNVP+1)=0 + IARBVA(:MAXNVP)=0 + IARBVA=0 + DO 140 I=1,NPARN + IDEBAR(I)=I+1 + IARBVA(I+1)=1 + 140 CONTINUE + IDEBAR(NPARN+1)=NPARN+2 + IDEBAR(NPARN+2)=1 + NCALS=1 + NVPNEW=NPARN+1 + ELSE + CALL LCMLEN(IPSAP,'ARBVAL',JLONG,ITYLCM) + ALLOCATE(JDEBAR(JLONG+1),JARBVA(JLONG)) + CALL LCMGET(IPSAP,'DEBARB',JDEBAR) + CALL LCMGET(IPSAP,'ARBVAL',JARBVA) + DO 150 IPAR=1,NPARN + IF(LGNEW(IPAR)) THEN + II=IPAR + GO TO 160 + ENDIF + 150 CONTINUE + II=NPARN+1 + 160 LGERR=COMTRE(NPARN,NVPO,JARBVA,JDEBAR,MUPLET,KK,I0,IORD,JJ, + 1 LAST) + IF((II.GT.NPARN).AND.LGERR) THEN + WRITE(TEXT4,'(I4)') IORD + IF(LWARN) THEN + WRITE(6,*)'SAPCAT: ELEMENTARY CALCULATION HAS THE ', + 1 'SAME PARAMETERS AS ELEMENTARY CALCULATION NB ',TEXT4 + DEALLOCATE(JARBVA,JDEBAR,IORRHS) + CALL LCMSIX(IPSAP,' ',2) + NIDEM=NIDEM+1 + GOTO 170 + ELSE + CALL XABORT('SAPCAT: ELEMENTARY CALCULATION HAS THE '// + 1 'SAME PARAMETERS AS ELEMENTARY CALCULATION NB '//TEXT4) + ENDIF + ENDIF +* +* Size of the new tree. +* + NVPNEW=NVPO+NPARN+1-MIN(II,KK) + IF(NVPNEW.GT.MAXNVP) MAXNVP=NVPNEW+MAXNVP + ALLOCATE(IDEBAR(MAXNVP+1),IARBVA(MAXNVP)) + IDEBAR(NVPNEW+2:MAXNVP+1)=0 + IARBVA(NVPNEW+1:MAXNVP)=0 +* +* Update values and suppress old PARBRE. +* + CALL COMARB(NPARN,NVPO,NVPNEW,JDEBAR,JARBVA,LGNEW,MUPLET, + 1 NCALS,IDEBAR,IARBVA) + DEALLOCATE(JARBVA,JDEBAR) + ENDIF + IF(NCALS.NE.NCAL+ICAL-NIDEM) CALL XABORT('SAPCAT: INVALID NCALS.') + NVPO=NVPNEW + CALL LCMPUT(IPSAP,'NCALS',1,1,NCALS) + CALL LCMPUT(IPSAP,'DEBARB',NVPNEW+1,1,IDEBAR) + CALL LCMPUT(IPSAP,'ARBVAL',NVPNEW,1,IARBVA) + DEALLOCATE(IARBVA,IDEBAR) + IF(NCALS.EQ.1) THEN + MAXNCA=1000 + ALLOCATE(IORIGI(MAXNCA)) + IORIGI(:MAXNCA)=0 + ELSE + CALL LCMLEN(IPSAP,'ORIGIN',MAXNCA,ITYLCM) + IF(NCALS.GT.MAXNCA) MAXNCA=NCALS+MAXNCA + ALLOCATE(IORIGI(MAXNCA)) + IORIGI(:MAXNCA)=0 + CALL LCMGET(IPSAP,'ORIGIN',IORIGI) + ENDIF + IF(IORRHS(ICAL).EQ.0) THEN + IORIGI(NCALS)=NORIG + ELSE + IORIGI(NCALS)=NCAL+IORRHS(ICAL) + ENDIF + CALL LCMPUT(IPSAP,'ORIGIN',NCALS,1,IORIGI) + DEALLOCATE(IORIGI) + CALL LCMSIX(IPSAP,' ',2) + DEALLOCATE(IORRHS) +*---- +* RECOVER THE ELEMENTARY CALCULATION +*---- + WRITE(DIRNAM,'(''calc'',I8)') NCAL+ICAL-NIDEM + CALL LCMSIX(IPSAP,DIRNAM,1) + WRITE(DIRNAM,'(''calc'',I8)') ICAL + CALL LCMSIX(IPRHS,DIRNAM,1) + CALL LCMEQU(IPRHS,IPSAP) + CALL LCMSIX(IPRHS,' ',2) + CALL LCMSIX(IPSAP,' ',2) + 170 CONTINUE +* END OF LOOP ON ELEMENTARY CALCULATIONS. ******************** + IDATA(17)=NVPO + IDATA(19)=NCALS + CALL LCMPUT(IPSAP,'DIMSAP',NDIMSA,1,IDATA) + RETURN + END diff --git a/Dragon/src/SAPFLU.f b/Dragon/src/SAPFLU.f new file mode 100644 index 0000000..c5a3363 --- /dev/null +++ b/Dragon/src/SAPFLU.f @@ -0,0 +1,88 @@ +*DECK SAPFLU + SUBROUTINE SAPFLU(IMPX,NCALS,IPSAP,IPFLUX,IPDEPL,NGA,NRT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To recover the flux of the reference calculation. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IMPX print parameter. +* NCALS index of the elementary calculation. +* IPSAP pointer to the Saphyb. +* IPFLUX pointer to the reference flux (L_FLUX signature). +* IPDEPL pointer to the burnup object (L_BURNUP signature). +* NGA number of groups in the reference calculation. +* NRT number of unknowns per group in the reference calculation. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSAP,IPFLUX,IPDEPL + INTEGER IMPX,NCALS,NGA,NRT +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPFLUX + REAL BIRRAD(2) + CHARACTER TEXT12*12,HSMG*131 + REAL, ALLOCATABLE, DIMENSION(:,:) :: FLXREF +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(FLXREF(NRT,NGA)) +*---- +* RECOVER THE FLUX NORMATIZATION FACTOR. +*---- + IF(C_ASSOCIATED(IPDEPL)) THEN + CALL LCMGET(IPDEPL,'BURNUP-IRRAD',BIRRAD) + BURN=BIRRAD(1) + CALL LCMLEN(IPDEPL,'FLUX-NORM',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + WRITE(HSMG,'(40HSAPFLU: THE ''FLUX-NORM'' RECORD IS NOT SE, + 1 20HT FOR BURNUP STEP AT,E12.5,14H MW-DAY/TONNE.)') BURN + CALL XABORT(HSMG) + ENDIF + CALL LCMGET(IPDEPL,'FLUX-NORM',FNORM) + IF(IMPX.GT.0) WRITE(6,100) FNORM,BURN + ELSE + FNORM=1.0 + IF(IMPX.GT.0) WRITE(6,110) + ENDIF +* + JPFLUX=LCMGID(IPFLUX,'FLUX') + DO 20 IGR=1,NGA + CALL LCMGDL(JPFLUX,IGR,FLXREF(1,IGR)) + DO 10 IRT=1,NRT + FLXREF(IRT,IGR)=FLXREF(IRT,IGR)*FNORM*1.0E13 + 10 CONTINUE + 20 CONTINUE +* + WRITE(TEXT12,'(''calc'',I8)') NCALS + CALL LCMSIX(IPSAP,TEXT12,1) + CALL LCMSIX(IPSAP,'divers',1) + CALL LCMPUT(IPSAP,'FLXREF',NRT*NGA,2,FLXREF) + CALL LCMSIX(IPSAP,' ',2) + CALL LCMSIX(IPSAP,' ',2) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(FLXREF) + RETURN +* + 100 FORMAT(45H SAPFLU: NORMALIZE THE FLUX WITH THE FACTOR =,1P,E12.5, + 1 26H TAKEN FROM BURNUP STEP AT,E12.5,14H MW-DAY/TONNE.) + 110 FORMAT(36H SAPFLU: THE FLUX IS NOT NORMALIZED.) + END diff --git a/Dragon/src/SAPFWC.f b/Dragon/src/SAPFWC.f new file mode 100644 index 0000000..0644ac6 --- /dev/null +++ b/Dragon/src/SAPFWC.f @@ -0,0 +1,93 @@ +*DECK SAPFWC + SUBROUTINE SAPFWC(IPSAP,IPLB1,MAXISO,NBISO,NGA,NISOTA) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To fill the 'constphysiq' directory. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPSAP pointer to the Saphyb. +* IPLB1 pointer to the reference microlib. +* MAXISO allocated length of arrays ISOTA and ISOTYP. +* NBISO number of isotopic definitions in the reference microlib. +* NGA number of energy groups in the reference microlib. +* +*Parameters: output +* NISOTA number of distinct isotopes. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSAP,IPLB1 + INTEGER MAXISO,NBISO,NGA,NISOTA +*---- +* LOCAL VARIABLES +*---- + CHARACTER TEXT12*12 +*---- +* ALLOCATABLE ARRAYS +*---- + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: ISOTA + CHARACTER(LEN=4), ALLOCATABLE, DIMENSION(:) :: ISOTYP + INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYP + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISONAM + REAL, ALLOCATABLE, DIMENSION(:) :: ENRGA +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(ISONAM(3,NBISO),ITYP(NBISO)) + ALLOCATE(ENRGA(NGA+1)) + ALLOCATE(ISOTA(MAXISO),ISOTYP(MAXISO)) +* + CALL LCMSIX(IPSAP,'constphysiq',1) +* + CALL LCMGET(IPLB1,'ENERGY',ENRGA) + DO 10 I=1,NGA+1 + ENRGA(I)=ENRGA(I)*1.0E-6 + 10 CONTINUE + CALL LCMPUT(IPSAP,'ENRGA',NGA+1,2,ENRGA) +* + CALL LCMGET(IPLB1,'ISOTOPESUSED',ISONAM) + CALL LCMGET(IPLB1,'ISOTOPESTYPE',ITYP) + NISOTA=0 + DO 30 IBISO=1,NBISO + WRITE(TEXT12,'(3A4)') (ISONAM(I0,IBISO),I0=1,3) + DO 20 ISO=1,NISOTA + IF(TEXT12(:8).EQ.ISOTA(ISO)) GO TO 30 + 20 CONTINUE + NISOTA=NISOTA+1 + IF(NISOTA.GT.MAXISO) CALL XABORT('SAPFWC: ISOTA OVERFLOW.') + ISOTA(NISOTA)=TEXT12(:8) + IF(ITYP(IBISO).EQ.2) THEN + ISOTYP(NISOTA)='FISS' + ELSE IF(ITYP(IBISO).EQ.3) THEN + ISOTYP(NISOTA)='F.P.' + ELSE + ISOTYP(NISOTA)=' ' + ENDIF + 30 CONTINUE + CALL LCMPTC(IPSAP,'ISOTA',8,NISOTA,ISOTA) + CALL LCMPTC(IPSAP,'ISOTYP',4,NISOTA,ISOTYP) +* + CALL LCMSIX(IPSAP,' ',2) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(ISOTYP,ISOTA) + DEALLOCATE(ENRGA) + DEALLOCATE(ITYP,ISONAM) + RETURN + END diff --git a/Dragon/src/SAPGEP.f b/Dragon/src/SAPGEP.f new file mode 100644 index 0000000..45cbbde --- /dev/null +++ b/Dragon/src/SAPGEP.f @@ -0,0 +1,378 @@ +*DECK SAPGEP + SUBROUTINE SAPGEP(IPSAP,IPDEPL,IPLB1,IPLB2,IPEDIT,IMPX,ITIM,NORIG, + 1 NPAR,MUPLET,LGNEW,NVPNEW,NCALAR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To recover remaining global parameters and local values. Update the +* parameter tree for a new elementary calculation. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPSAP pointer to the Saphyb. +* IPDEPL pointer to the burnup object. +* IPLB1 pointer to the first microlib object. +* IPLB2 pointer to the second (optional) microlib object. +* IPEDIT pointer to the edition object. +* IMPX print parameter. +* ITIM index of the current burnup step. +* NORIG index of the elementary calculation associated to the +* father node in the parameter tree. +* NPAR number of global parameters. +* MUPLET tuple of indices associated to each global parameter of the +* elementary calculation. +* LGNEW parameter modification flag (.TRUE. only if the I-th global +* parameter has changed in the new elementary calculation). +* +*Parameters: output +* NVPNEW number of nodes in the global parameter tree. +* NCALAR index of the new elementary calculation. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSAP,IPDEPL,IPLB1,IPLB2,IPEDIT + INTEGER IMPX,ITIM,NORIG,NPAR,MUPLET(NPAR),NVPNEW,NCALAR + LOGICAL LGNEW(NPAR) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPLB3 + PARAMETER (NDIMSA=50,MAXPAR=50) + INTEGER IDATA(NDIMSA),PARMIL(MAXPAR), + 1 PARCAD(MAXPAR+1),PARPAD(MAXPAR+1),LOCADR(MAXPAR+1) + CHARACTER PARKEY(MAXPAR)*4,PARCHR(MAXPAR)*8,PARTYP(MAXPAR)*4, + 1 PARFMT(MAXPAR)*8,PARBIB(MAXPAR)*12,PARNAM(MAXPAR)*80,TEXT4*4, + 2 TEXT8*8,TEXT12*12,NAMLCM*12,NAMMY*12,HSMG*131 + LOGICAL LGERR,EMPTY,LCM,COMTRE,LAST +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDEBAR,IARBVA,JDEBAR,JARBVA, + 1 IORIGI + REAL, ALLOCATABLE, DIMENSION(:) :: RVALO +*---- +* RECOVER INFORMATION FROM THE 'DIMSAP' PARAMETER LIST. +*---- + NVPNEW=0 + CALL LCMGET(IPSAP,'DIMSAP',IDATA) + IF(NPAR.NE.IDATA(8)) CALL XABORT('SAPGEP: WRONG VALUE OF NPAR.') + NMIL=IDATA(7) + NPCHR=IDATA(9) + NPPNT=IDATA(10) + NLOC=IDATA(11) + NPCHRL=IDATA(12) + NPPNTL=IDATA(13) + NVPO=IDATA(17) + NCALAR=IDATA(19) + NG=IDATA(20) +*---- +* RECOVER INFORMATION FROM THE 'paramdescrip' DIRECTORY. +*---- + IF(NPAR.EQ.0) GO TO 45 + CALL LCMSIX(IPSAP,'paramdescrip',1) + CALL LCMGTC(IPSAP,'PARKEY',4,NPAR,PARKEY) + CALL LCMGTC(IPSAP,'PARTYP',4,NPAR,PARTYP) + CALL LCMGTC(IPSAP,'PARFMT',8,NPAR,PARFMT) + CALL LCMGET(IPSAP,'PARCAD',PARCAD) + CALL LCMGET(IPSAP,'PARPAD',PARPAD) + IF(NPCHR.GT.0) CALL LCMGTC(IPSAP,'PARCHR',8,NPCHR,PARCHR) + IF(NPPNT.GT.0) CALL LCMGET(IPSAP,'PARMIL',PARMIL) + IF(NPPNT.GT.0) CALL LCMGTC(IPSAP,'PARBIB',12,NPPNT,PARBIB) + CALL LCMSIX(IPSAP,' ',2) +*---- +* RECOVER REMAINING GLOBAL PARAMETERS. +*---- + DO 10 IPAR=1,NPAR + IF(PARTYP(IPAR).EQ.'VALE') THEN + GO TO 10 + ELSE IF((PARTYP(IPAR).EQ.'IRRA').OR.(PARTYP(IPAR).EQ.'TIME').OR. + 1 (PARTYP(IPAR).EQ.'PUIS').OR.(PARTYP(IPAR).EQ.'FLUB').OR. + 2 (PARTYP(IPAR).EQ.'FLUX').OR.(PARTYP(IPAR).EQ.'MASL')) THEN +* +* RECOVER GLOBAL PARAMETER VALUES FROM THE DEPLETION OBJECT. + IF(.NOT.C_ASSOCIATED(IPDEPL)) CALL XABORT('SAPGEP: NO DEPLETI' + 1 //'ON OBJECT AVAILABLE AMONG THE RHS LCM OBJECTS.') + CALL LCMGET(IPDEPL,'STATE-VECTOR',IDATA) + NBURN=IDATA(3) + NBISO=IDATA(4) + NREAC=IDATA(6) + NVAR=IDATA(7) + NBMIX=IDATA(8) + CALL COMGEM(IPDEPL,ITIM,PARTYP(IPAR),0,NBURN,NBMIX,NBISO, + 1 NREAC,NVAR,VALPAR) + ELSE IF((PARTYP(IPAR).EQ.'TEMP').OR.(PARTYP(IPAR).EQ.'CONC')) + 1 THEN +* +* RECOVER GLOBAL PARAMETER VALUES FROM A MICROLIB OBJECT. + IF(.NOT.C_ASSOCIATED(IPLB1)) CALL XABORT('SAPGEP: MICROLIB EX' + 1 //'PECTED AT RHS.') + IPCAD=PARCAD(IPAR+1)-PARCAD(IPAR) + IPPAD=PARPAD(IPAR+1)-PARPAD(IPAR) + IF(IPCAD.EQ.1) IPCAD=PARCAD(IPAR+1)-PARCAD(1) + IF(IPPAD.EQ.1) IPPAD=PARPAD(IPAR+1)-PARPAD(1) + TEXT8=' ' + TEXT12=' ' + IMILI=0 + IF(IPCAD.GT.0) TEXT8=PARCHR(IPCAD) + IF(IPPAD.GT.0) TEXT12=PARBIB(IPPAD) + IF(IPPAD.GT.0) IMILI=PARMIL(IPPAD) + CALL LCMGET(IPLB1,'STATE-VECTOR',IDATA) + MAXNBI=IDATA(2) + IF(C_ASSOCIATED(IPLB2)) THEN + CALL LCMGET(IPLB2,'STATE-VECTOR',IDATA) + MAXNBI=MAX(MAXNBI,IDATA(2)) + ENDIF + CALL COMBIB(IPLB1,IPLB2,PARTYP(IPAR),IMILI,TEXT12,TEXT8,MAXNBI, + 1 VALPAR) + IF(PARTYP(IPAR).EQ.'TEMP') VALPAR=VALPAR-273.16 + ELSE + CALL XABORT('SAPGEP: '//PARTYP(IPAR)//' IS AN UNKNOWN PARAM'// + 1 'ETER TYPE.') + ENDIF + IF(IMPX.GT.0) WRITE(6,100) PARKEY(IPAR),VALPAR +* + CALL SAPPAV(IPSAP,IPAR,NPAR,'FLOTTANT',VALPAR,NITMA,TEXT12, + 1 MUPLET(IPAR),LGNEW(IPAR)) + 10 CONTINUE + IF(IMPX.GT.2) THEN + WRITE(6,110) (MUPLET(I),I=1,NPAR) + WRITE(6,'(/)') + ENDIF + DO 15 I=1,NPAR + IF(MUPLET(I).EQ.0) THEN + WRITE(HSMG,'(33HSAPGEP: UNDEFINED MUPLET ELEMENT=,I6)') I + CALL XABORT(HSMG) + ENDIF + 15 CONTINUE +*---- +* INTRODUCE VALUES INTO GLOBAL PARAMETER TREE. +*---- +** +** Parameter tree: this tree has a number of stages equal to the +** number of parameters. For each value of the i-th parameter, we +** find the position in the tree corresponding to the value of the +** (i+1)-th parameter. +** NCALAR Number of elementary calculations stored in the tree. +** NVP Number of nodes in the parameter tree, including the root. +** The value corresponding to the root is not used. +** DEBARB - If the node does not correspond to the last parameter: +** index in DEBARB of the first daughter of the node. +** - If the node correspond to the last parameter: index in +** DEBARB where we recover the index of an elementary +** calculation. +** ARBVAL Index of the corresponding parameter in the 'pval'//n +** record. +* +** EXEMPLE: dn = value in DEBARB, (m) = value in ARBVAL +** +** Root *(0) +** ! +** Param. Nb 1 d2(1) +** ------------------- +** ! ! +** Param. Nb 2 d3(1) 4(2) +** --------- --------- +** ! ! ! ! ! +** Param. Nb 3 d5(1) 6(3) d7(1) 8(2) 9(3) d10 +** +** Calculation Nb: 4 5 1 2 3 +** +** DEBARB: 2 3 5 7 10 4 5 1 2 3 +** ARBVAL: 0 1 1 2 1 3 1 2 3 +* + CALL LCMSIX(IPSAP,'paramarbre',1) + CALL LCMLEN(IPSAP,'ARBVAL',MAXNVP,ITYLCM) + IF(MAXNVP.EQ.0) THEN + MAXNVP=100*(NPAR+1) + ALLOCATE(IDEBAR(MAXNVP+1),IARBVA(MAXNVP)) + IDEBAR(:MAXNVP+1)=0 + IARBVA(:MAXNVP)=0 + IARBVA=0 + DO 20 I=1,NPAR + IDEBAR(I)=I+1 + IARBVA(I+1)=1 + 20 CONTINUE + IDEBAR(NPAR+1)=NPAR+2 + IDEBAR(NPAR+2)=1 + NCALAR=1 + NVPNEW=NPAR+1 + ELSE +* +* Find position of the new point and create new PARBRE. +* +* "II" is the order number of first parameter which recives a +* "brand new" value. +* COMTRE returns .TRUE. if the sweep throught the tree reaches +* its bottom, otherwise it returns "KK" value: level of the +* first new node to be introduced. +* + ALLOCATE(JDEBAR(MAXNVP+1),JARBVA(MAXNVP)) + CALL LCMGET(IPSAP,'DEBARB',JDEBAR) + CALL LCMGET(IPSAP,'ARBVAL',JARBVA) + DO 30 IPAR=1,NPAR + IF(LGNEW(IPAR)) THEN + II=IPAR + GO TO 40 + ENDIF + 30 CONTINUE + II=NPAR+1 + 40 LGERR=COMTRE(NPAR,NVPO,JARBVA,JDEBAR,MUPLET,KK,I0,IORD,JJ,LAST) + IF((II.GT.NPAR).AND.LGERR) THEN + WRITE(TEXT4,'(I4)') IORD + CALL XABORT('SAPGEP: ELEMENTARY CALCULATION HAS THE SAME'// + 1 ' GLOBAL PARAMETERS AS ELEMENTARY CALCULATION NB '//TEXT4) + ENDIF +* +* Size of the new tree. +* + NVPNEW=NVPO+NPAR+1-MIN(II,KK) + IF(NVPNEW.GT.MAXNVP) MAXNVP=NVPNEW+MAXNVP + ALLOCATE(IDEBAR(MAXNVP+1),IARBVA(MAXNVP)) + IDEBAR(NVPNEW+2:MAXNVP+1)=0 + IARBVA(NVPNEW+1:MAXNVP)=0 +* +* Update values and suppress old PARBRE. +* + CALL COMARB(NPAR,NVPO,NVPNEW,JDEBAR,JARBVA,LGNEW,MUPLET,NCALAR, + 1 IDEBAR,IARBVA) + DEALLOCATE(JARBVA,JDEBAR) + ENDIF + CALL LCMPUT(IPSAP,'NCALS',1,1,NCALAR) + CALL LCMPUT(IPSAP,'DEBARB',NVPNEW+1,1,IDEBAR) + CALL LCMPUT(IPSAP,'ARBVAL',NVPNEW,1,IARBVA) + DEALLOCATE(IARBVA,IDEBAR) + IF(NCALAR.EQ.1) THEN + MAXNCA=1000 + ALLOCATE(IORIGI(MAXNCA)) + IORIGI(:MAXNCA)=0 + ELSE + CALL LCMLEN(IPSAP,'ORIGIN',MAXNCA,ITYLCM) + IF(NCALAR.GT.MAXNCA) MAXNCA=NCALAR+MAXNCA + ALLOCATE(IORIGI(MAXNCA)) + IORIGI(:MAXNCA)=0 + CALL LCMGET(IPSAP,'ORIGIN',IORIGI) + ENDIF + IORIGI(NCALAR)=NORIG + CALL LCMPUT(IPSAP,'ORIGIN',NCALAR,1,IORIGI) + DEALLOCATE(IORIGI) + CALL LCMSIX(IPSAP,' ',2) +*---- +* RECOVER INFORMATION FROM THE 'varlocdescri' DIRECTORY. +*---- + 45 IF(NLOC.EQ.0) RETURN + CALL LCMSIX(IPSAP,'varlocdescri',1) + CALL LCMGTC(IPSAP,'PARNAM',80,NPAR,PARNAM) + CALL LCMGTC(IPSAP,'PARKEY',4,NLOC,PARKEY) + CALL LCMGTC(IPSAP,'PARTYP',4,NLOC,PARTYP) + CALL LCMGTC(IPSAP,'PARFMT',8,NLOC,PARFMT) + CALL LCMGET(IPSAP,'PARCAD',PARCAD) + IF(NPCHRL.GT.0) CALL LCMGTC(IPSAP,'PARCHR',8,NPCHRL,PARCHR) + CALL LCMSIX(IPSAP,' ',2) +* + CALL LCMGTC(IPEDIT,'LAST-EDIT',12,TEXT12) +*---- +* INITIALIZE LOCADR AND ALLOCATE RVALO. +*---- + IADR=1 + LOCADR(1)=1 + DO 50 IPAR=1,NLOC + IF((PARTYP(IPAR).EQ.'EQUI').OR.(PARTYP(IPAR).EQ.'VITE')) THEN + IADR=IADR+NG + ELSE IF(PARTYP(IPAR).EQ.'COUR') THEN + IADR=IADR+2*NG + ELSE + IADR=IADR+1 + ENDIF + LOCADR(IPAR+1)=IADR + 50 CONTINUE + NVLC=LOCADR(NLOC+1)-1 + ALLOCATE(RVALO(NVLC*NMIL)) +*---- +* RECOVER LOCAL VARIABLES. +*---- + DO 70 IPAR=1,NLOC + IF((PARTYP(IPAR).EQ.'IRRA').OR.(PARTYP(IPAR).EQ.'TIME').OR. + 1 (PARTYP(IPAR).EQ.'PUIS').OR.(PARTYP(IPAR).EQ.'FLUG').OR. + 2 (PARTYP(IPAR).EQ.'FLUB').OR.(PARTYP(IPAR).EQ.'FLUX').OR. + 3 (PARTYP(IPAR).EQ.'MASL')) THEN +* +* RECOVER LOCAL VARIABLES FROM THE DEPLETION OBJECT. + IF(.NOT.C_ASSOCIATED(IPDEPL)) CALL XABORT('SAPGEP: NO DEPLET' + 1 //'ION OBJECT AVAILABLE AMONG THE RHS LCM OBJECTS.') + CALL LCMGET(IPDEPL,'STATE-VECTOR',IDATA) + NBURN=IDATA(3) + NBISO=IDATA(4) + NREAC=IDATA(6) + NVAR=IDATA(7) + NBMIX=IDATA(8) + CALL LCMGET(IPEDIT,'STATE-VECTOR',IDATA) + NREG=IDATA(17) + CALL COMGEN(IPDEPL,IPEDIT,NREG,NMIL,ITIM,PARTYP(IPAR),NBURN, + 1 NBMIX,NBISO,NREAC,NVAR,LOCADR(IPAR),NVLC,RVALO) + ELSE IF((PARTYP(IPAR).EQ.'TEMP').OR.(PARTYP(IPAR).EQ.'CONC')) + 1 THEN +* +* RECOVER LOCAL VARIABLES FROM THE MICROLIB IN EDIT OBJECT. + IPCAD=PARCAD(IPAR+1)-PARCAD(IPAR) + IF(IPCAD.EQ.1) IPCAD=PARCAD(IPAR+1)-PARCAD(1) + TEXT8=' ' + IF(IPCAD.GT.0) TEXT8=PARCHR(IPCAD) + CALL LCMSIX(IPEDIT,TEXT12,1) + CALL LCMGET(IPEDIT,'STATE-VECTOR',IDATA) + MAXNBI=IDATA(2) + CALL LCMINF(IPEDIT,NAMLCM,NAMMY,EMPTY,ILONG,LCM) + IPLB3=C_NULL_PTR + DO 60 IBM=1,NMIL + CALL COMBIB(IPEDIT,IPLB3,PARTYP(IPAR),IBM,NAMLCM,TEXT8,MAXNBI, + 1 VALPAR) + IF(PARTYP(IPAR).EQ.'TEMP') VALPAR=VALPAR-273.16 + RVALO((IBM-1)*NVLC+LOCADR(IPAR))=VALPAR + 60 CONTINUE + CALL LCMSIX(IPEDIT,' ',2) + ELSE IF(PARTYP(IPAR).EQ.'EQUI') THEN +* RECOVER A SET OF SPH EQUIVALENCE FACTORS. + CALL SAPSPH(IPEDIT,NG,NMIL,LOCADR(IPAR),NVLC,RVALO) + ELSE + CALL XABORT('SAPGEP: '//PARTYP(IPAR)//' IS AN UNKNOWN LOCAL'// + 1 ' VARIABLE TYPE.') + ENDIF + IF(IMPX.GT.1) WRITE(6,120) PARKEY(IPAR), + 1 (RVALO((IBM-1)*NVLC+LOCADR(IPAR)),IBM=1,NMIL) + 70 CONTINUE + WRITE(TEXT12,'(''calc'',I8)') NCALAR + CALL LCMSIX(IPSAP,TEXT12,1) + CALL LCMSIX(IPSAP,'info',1) + CALL LCMPUT(IPSAP,'NLOC',1,1,NLOC) + CALL LCMPTC(IPSAP,'LOCNAM',80,NLOC,PARNAM) + CALL LCMPTC(IPSAP,'LOCKEY',4,NLOC,PARKEY) + CALL LCMPTC(IPSAP,'LOCTYP',4,NLOC,PARTYP) + CALL LCMPUT(IPSAP,'LOCADR',NLOC+1,1,LOCADR) + CALL LCMSIX(IPSAP,' ',2) + DO 80 IBM=1,NMIL + WRITE(TEXT12,'(''mili'',I8)') IBM + CALL LCMSIX(IPSAP,TEXT12,1) + CALL LCMPUT(IPSAP,'RVALOC',NVLC,2,RVALO((IBM-1)*NVLC+1)) + CALL LCMSIX(IPSAP,' ',2) + 80 CONTINUE + CALL LCMSIX(IPSAP,' ',2) + DEALLOCATE(RVALO) + RETURN +* + 100 FORMAT(31H SAPGEP: SET GLOBAL PARAMETER ',A,3H' =,1P,E12.4) + 110 FORMAT(/16H SAPGEP: MUPLET=,10I6:/(16X,10I6)) + 120 FORMAT(29H SAPGEP: SET LOCAL VARIABLE ',A,3H' =,1P,5E12.4/(36X, + 1 5E12.4)) + END diff --git a/Dragon/src/SAPGEY.f b/Dragon/src/SAPGEY.f new file mode 100644 index 0000000..ac0f3c3 --- /dev/null +++ b/Dragon/src/SAPGEY.f @@ -0,0 +1,219 @@ +*DECK SAPGEY + SUBROUTINE SAPGEY(IPSAP,IPEDIT,NISO,NMAC,NG,NMIL,NBISO,ICAL,NDFI, + 1 NISFS,NISPS,NISYS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To recover the fission yields of an elementary calculation. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPSAP pointer to the Saphyb. +* IPEDIT pointer to the edition object (L_EDIT signature). +* NISO number of particularized isotopes. +* NMAC number of macros. +* NG number of condensed energy groups. +* NMIL number of mixtures in the Saphyb. +* NBISO number of isotopes in the condensed microlib of the edition +* object. A given isotope may appear in many mixtures. +* ICAL index of the current elementary calculation. +* NDFI number of fissile isotopes producing fission products in +* the edition object. +* NISFS number of particularized fissile isotopes. +* NISPS number of particularized fission products. +* NISYS number of particularized fissile isotopes, fission products +* and macros. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSAP,IPEDIT + INTEGER NISO,NMAC,NG,NMIL,NBISO,ICAL,NDFI,NISFS,NISPS,NISYS +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MAXISO=800) + TYPE(C_PTR) JPEDIT,KPEDIT + CHARACTER TEXT8*8,TEXT12*12,DIRNAM*12,NOMISO(MAXISO)*8 + LOGICAL LGIMF +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MIX,ITYPE,PIFI,ADRY + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISONAM + REAL, ALLOCATABLE, DIMENSION(:) :: DEN,PYIELD,SIG,PFIRA + REAL, ALLOCATABLE, DIMENSION(:,:) :: YLDS,FLUXES + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO +*---- +* SCRATCH STORAGE ALLOCATION +* PFIRA fission rate. +* ADRY offset in YLDS array for fissile isotopes (positive) and +* fission products (negative). +*---- + ALLOCATE(ISONAM(3,NBISO),MIX(NBISO),ITYPE(NBISO),PIFI(NDFI)) + ALLOCATE(YLDS(NISFS+NMAC,NISPS),DEN(NBISO),PYIELD(NDFI), + 1 FLUXES(NMIL,NG),SIG(NG),PFIRA(NBISO),ADRY(NISYS)) + ALLOCATE(IPISO(NBISO)) +*---- +* RECOVER INFORMATION FROM THE 'CONTENU' DIRECTORY. +*---- + CALL LCMSIX(IPSAP,'contenu',1) + IF(NISO.GT.0) CALL LCMGTC(IPSAP,'NOMISO',8,NISO,NOMISO) + CALL LCMSIX(IPSAP,' ',2) +*---- +* MOVE TO THE 'CALC' DIRECTORY. +*---- + WRITE(DIRNAM,'(''calc'',I8)') ICAL + CALL LCMSIX(IPSAP,DIRNAM,1) +* + CALL LCMGET(IPEDIT,'ISOTOPESUSED',ISONAM) + CALL LCMGET(IPEDIT,'ISOTOPESMIX',MIX) + CALL LCMGET(IPEDIT,'ISOTOPESDENS',DEN) + CALL LCMGET(IPEDIT,'ISOTOPESTYPE',ITYPE) + CALL LIBIPS(IPEDIT,NBISO,IPISO) +*---- +* COMPUTE ARRAY ADRY. +*---- + ISF=0 + ISP=0 + ADRY(:NISYS)=0 + DO 30 ISO=1,NISO + DO 10 IBISO=1,NBISO + WRITE(TEXT8,'(2A4)') (ISONAM(I0,IBISO),I0=1,2) + IF(NOMISO(ISO).EQ.TEXT8) GO TO 20 + 10 CONTINUE + GO TO 30 + 20 IF(ITYPE(IBISO).EQ.2) THEN + ISF=ISF+1 + ADRY(ISO)=ISF + ELSEIF(ITYPE(IBISO).EQ.3) THEN + ISP=ISP+1 + ADRY(ISO)=-ISP + ENDIF + 30 CONTINUE + IF(NMAC.GT.0) ADRY(NISO+1)=ISF+1 + LGIMF=NISYS.GT.NISO + IMF=0 + IF(LGIMF) IMF=ADRY(NISO+1) +*---- +* RECOVER THE NEUTRON FLUX. +*---- + CALL LCMSIX(IPEDIT,'MACROLIB',1) + JPEDIT=LCMGID(IPEDIT,'GROUP') + DO 40 IGR=1,NG + KPEDIT=LCMGIL(JPEDIT,IGR) + CALL LCMGET(KPEDIT,'FLUX-INTG',FLUXES(1,IGR)) + 40 CONTINUE + CALL LCMSIX(IPEDIT,' ',2) +*---- +* RECOVER THE FISSION RATES. +*---- + DO 65 IBISO=1,NBISO + GAR=0.0 + IF(MIX(IBISO).EQ.0) GO TO 60 + KPEDIT=IPISO(IBISO) + CALL LCMLEN(KPEDIT,'NFTOT',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,'NFTOT',SIG) + DO 50 IGR=1,NG + GAR=GAR+FLUXES(MIX(IBISO),IGR)*DEN(IBISO)*SIG(IGR) + 50 CONTINUE + ENDIF + 60 PFIRA(IBISO)=GAR + 65 CONTINUE +*---- +* LOOP OVER SAPHYB MIXTURES TO RECOVER THE FISSION YIELDS. +*---- + DO 140 IMIL=1,NMIL + DO 75 IFP=1,NISPS + DO 70 IFI=1,NISFS+NMAC + YLDS(IFI,IFP)=0.0 + 70 CONTINUE + 75 CONTINUE + DO 130 IBISO=1,NBISO + IF(MIX(IBISO).EQ.IMIL) THEN + WRITE(TEXT12,'(3A4)') (ISONAM(I0,IBISO),I0=1,3) + DO 80 ISO=1,NISO + IISO=ISO + IF(NOMISO(ISO).EQ.TEXT12(:8)) GO TO 90 + 80 CONTINUE + GO TO 130 + 90 KPEDIT=IPISO(IBISO) +* +* RECOVER THE FISSION YIELDS. + CALL LCMLEN(KPEDIT,'PYIELD',ILONG,ITYLCM) + IF((ILONG.GT.0).AND.(ILONG.EQ.NDFI)) THEN + CALL LCMGET(KPEDIT,'PIFI',PIFI) + CALL LCMGET(KPEDIT,'PYIELD',PYIELD) + ELSE + GO TO 130 + ENDIF + IFP=-ADRY(IISO) + IF(IFP.GT.0) THEN +* Particular fission product found. +* If exists in medium, find position in microlib +* and search all fissiles. + YLDW=0.0 + DO 120 IDFI=1,NDFI + JBISO=PIFI(IDFI) + IF(JBISO.GT.NBISO) CALL XABORT('SAPGEY: MIX OVERFLOW.') + IF(JBISO.EQ.0) GO TO 120 + IF(MIX(JBISO).NE.IMIL) GO TO 120 + WRITE(TEXT8,'(3A4)') (ISONAM(I0,JBISO),I0=1,2) + DO 100 JSO=1,NISO + JISO=JSO + IF(NOMISO(JSO).EQ.TEXT8) GO TO 110 + 100 CONTINUE +* Mother isotope is in residual macro. + YLDW=YLDW+PFIRA(JBISO) + IF(IMF.EQ.0) CALL XABORT('SAPGEY: LGIMF IS FALSE.') + YLDS(IMF,IFP)=YLDS(IMF,IFP)+PYIELD(IDFI)*PFIRA(JBISO) + GO TO 120 +* +* Yield for selected isotopes. + 110 IFI=ADRY(JISO) + IF(IFI.LE.0) CALL XABORT('SAPGEY: BAD ADRY.') + YLDS(IFI,IFP)=PYIELD(IDFI) + 120 CONTINUE + IF(LGIMF) THEN + IF(YLDW.NE.0.0) YLDS(IMF,IFP)=YLDS(IMF,IFP)/YLDW + ENDIF + ENDIF + ENDIF + 130 CONTINUE +*---- +* STORE INFORMATION IN THE MIXTURE DIRECTORY. +*---- + WRITE(DIRNAM,'(''mili'',I8)') IMIL + CALL LCMSIX(IPSAP,DIRNAM,1) + CALL LCMPUT(IPSAP,'YLDS',(NISFS+NMAC)*NISPS,2,YLDS) + CALL LCMSIX(IPSAP,' ',2) + 140 CONTINUE +* + CALL LCMSIX(IPSAP,'info',1) + CALL LCMPUT(IPSAP,'ADRY',NISYS,1,ADRY) + CALL LCMSIX(IPSAP,' ',2) +*---- +* MOVE TO THE SAPHYB ROOT DIRECTORY. +*---- + CALL LCMSIX(IPSAP,' ',2) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IPISO) + DEALLOCATE(ADRY,PFIRA,SIG,FLUXES,PYIELD,DEN,YLDS) + DEALLOCATE(PIFI,ITYPE,MIX,ISONAM) + RETURN + END diff --git a/Dragon/src/SAPIDF.f b/Dragon/src/SAPIDF.f new file mode 100644 index 0000000..6f1ea42 --- /dev/null +++ b/Dragon/src/SAPIDF.f @@ -0,0 +1,104 @@ +*DECK SAPIDF + SUBROUTINE SAPIDF(IPSAP,IPEDIT,NG,NMIL,ICAL,IDF,FNORM,REGFLX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To store discontinuity factor information in the Saphyb. +* +*Copyright: +* Copyright (C) 2015 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPSAP pointer to the Saphyb. +* IPEDIT pointer to the edition object (L_EDIT signature). +* NG number of condensed energy groups. +* NMIL number of mixtures. +* ICAL index of the current elementary calculation. +* IDF type of surfacic information (2/3: boundary flux/DF). +* FNORM flux normalization factor. +* REGFLX averaged flux in the complete geometry. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSAP,IPEDIT + INTEGER NG,NMIL,ICAL,IDF + REAL FNORM,REGFLX(NG) +*---- +* LOCAL VARIABLES +*---- + CHARACTER DIRNAM*12,HSMG*131 +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: SURF + REAL, ALLOCATABLE, DIMENSION(:,:) :: SURFLX + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HADF +*---- +* RECOVER DISCONTINUITY FACTOR INFORMATION FROM MACROLIB +*---- + IF(NMIL.NE.1) CALL XABORT('SAPIDF: NMIL=1 EXPECTED.') + CALL LCMSIX(IPEDIT,'MACROLIB',1) + CALL LCMLEN(IPEDIT,'ADF',ILONG,ITYLCM) + IF(ILONG.EQ.0) CALL XABORT('SAPIDF: MISSING ADF DIRECTORY IN EDI' + 1 //'TION OBJECT.') + CALL LCMSIX(IPEDIT,'ADF',1) + CALL LCMGET(IPEDIT,'NTYPE',NSURFD) + ALLOCATE(SURFLX(NSURFD,NG),SURF(NG),HADF(NSURFD)) + CALL LCMGTC(IPEDIT,'HADF',8,NSURFD,HADF) + DO I=1,NSURFD + CALL LCMLEN(IPEDIT,HADF(I),ILONG,ITYLCM) + IF(ILONG.NE.NG) THEN + WRITE(HSMG,'(12HSAPIDF: BAD ,A,8H LENGTH=,I5,10H EXPECTED=, + 1 I5,1H.)') HADF(I),ILONG,NG + CALL XABORT(HSMG) + ENDIF + CALL LCMGET(IPEDIT,HADF(I),SURF) + IF(IDF.EQ.2) THEN + DO IGR=1,NG + SURFLX(I,IGR)=SURF(IGR)*FNORM*1.0E13 + ENDDO + ELSE IF(IDF.EQ.3) THEN +* discontinuity factor information + DO IGR=1,NG + SURFLX(I,IGR)=SURF(IGR)*REGFLX(IGR) + ENDDO + ENDIF + ENDDO + DEALLOCATE(HADF,SURF) + CALL LCMSIX(IPEDIT,' ',2) + CALL LCMSIX(IPEDIT,' ',2) +*---- +* MOVE TO THE 'calc' DIRECTORY. +*---- + WRITE(DIRNAM,'(''calc'',I8)') ICAL + CALL LCMSIX(IPSAP,DIRNAM,1) + CALL LCMSIX(IPSAP,'outflx',1) + CALL LCMPUT(IPSAP,'REGFLX',NG,2,REGFLX) + CALL LCMPUT(IPSAP,'SURFLX',NSURFD*NG,2,SURFLX) + CALL LCMSIX(IPSAP,' ',2) + CALL LCMSIX(IPSAP,' ',2) + DEALLOCATE(SURFLX) +*---- +* CREATE dummy 'outgeom' DIRECTORY. +*---- + CALL LCMSIX(IPSAP,'geom',1) + CALL LCMSIX(IPSAP,'outgeom',1) + ALLOCATE(SURF(NSURFD)) + SURF(:)=1.0 + CALL LCMPUT(IPSAP,'SURF',NSURFD,2,SURF) + DEALLOCATE(SURF) + CALL LCMSIX(IPSAP,' ',2) + CALL LCMSIX(IPSAP,' ',2) + RETURN + END diff --git a/Dragon/src/SAPPAV.f b/Dragon/src/SAPPAV.f new file mode 100644 index 0000000..bd1ea79 --- /dev/null +++ b/Dragon/src/SAPPAV.f @@ -0,0 +1,152 @@ +*DECK SAPPAV + SUBROUTINE SAPPAV(IPSAP,IPAR,NPAR,TYPE,RVAL,IVAL,CVAL,IV,LGNEW) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To return the index of a global parameter value. Reorganize the +* 'paramvaleur' directory if required. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPSAP pointer to the Saphyb. +* IPAR index of the global parameter. +* NPAR total number of global parameters. +* TYPE type of the global parameter value. +* RVAL global parameter value if TYPE='FLOTTANT'. +* IVAL global parameter value if TYPE='ENTIER'. +* CVAL global parameter value if TYPE='CHAINE'. +* +*Parameters: output +* IV index of the global parameter value. +* LGNEW new parameter flag (=.true. if the parameter value is new). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSAP + INTEGER IPAR,NPAR,IV,IVAL + REAL RVAL + LOGICAL LGNEW + CHARACTER TYPE*8,CVAL*(*) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (REPS=1.0E-5,MAXPAR=50,MAXVAL=1000) + CHARACTER RECNAM*12,VCHAR(MAXVAL)*12 + INTEGER NVALUE(MAXPAR) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: VINTE + REAL, ALLOCATABLE, DIMENSION(:) :: VREAL +* + CALL LCMSIX(IPSAP,'paramdescrip',1) + CALL LCMGET(IPSAP,'NVALUE',NVALUE) + CALL LCMSIX(IPSAP,' ',2) + CALL LCMSIX(IPSAP,'paramvaleurs',1) + WRITE(RECNAM,'(''pval'',I8)') IPAR +* + LGNEW=.TRUE. + IF(TYPE.EQ.'FLOTTANT') THEN + ALLOCATE(VREAL(NVALUE(IPAR)+1)) + IF(NVALUE(IPAR).EQ.0) THEN + IV=1 + VREAL(IV)=RVAL + NVALUE(IPAR)=1 + ELSE + CALL LCMLEN(IPSAP,RECNAM,ILONG,ITYLCM) + IF(ILONG.GT.NVALUE(IPAR)) CALL XABORT('SAPPAV: NVALUE OVER' + 1 //'FLOW(1).') + CALL LCMGET(IPSAP,RECNAM,VREAL) + DO 10 I=1,NVALUE(IPAR) + IF(RVAL.LE.VREAL(I)*(1.+REPS))THEN + IV=I + LGNEW=RVAL.LT.VREAL(IV)*(1.-REPS) + GO TO 20 + ENDIF + 10 CONTINUE + IV=NVALUE(IPAR)+1 + 20 IF(LGNEW) THEN + NVALUE(IPAR)=NVALUE(IPAR)+1 + DO 30 J=NVALUE(IPAR)-1,IV,-1 + VREAL(J+1)=VREAL(J) + 30 CONTINUE + VREAL(IV)=RVAL + ENDIF + ENDIF + IF(LGNEW) CALL LCMPUT(IPSAP,RECNAM,NVALUE(IPAR),2,VREAL) + DEALLOCATE(VREAL) + ELSE IF(TYPE.EQ.'ENTIER') THEN + ALLOCATE(VINTE(NVALUE(IPAR)+1)) + IF(NVALUE(IPAR).EQ.0) THEN + IV=1 + VINTE(IV)=IVAL + NVALUE(IPAR)=1 + ELSE + CALL LCMLEN(IPSAP,RECNAM,ILONG,ITYLCM) + IF(ILONG.GT.NVALUE(IPAR)) CALL XABORT('SAPPAV: NVALUE OVER' + 1 //'FLOW(2).') + CALL LCMGET(IPSAP,RECNAM,VINTE) + DO 40 I=1,NVALUE(IPAR) + IF(IVAL.LE.VINTE(I))THEN + IV=I + LGNEW=IVAL.LT.VINTE(IV) + GO TO 50 + ENDIF + 40 CONTINUE + IV=NVALUE(IPAR)+1 + 50 IF(LGNEW) THEN + NVALUE(IPAR)=NVALUE(IPAR)+1 + DO 60 J=NVALUE(IPAR)-1,IV,-1 + VINTE(J+1)=VINTE(J) + 60 CONTINUE + VINTE(IV)=IVAL + ENDIF + ENDIF + IF(LGNEW) CALL LCMPUT(IPSAP,RECNAM,NVALUE(IPAR),1,VINTE) + DEALLOCATE(VINTE) + ELSE IF(TYPE.EQ.'CHAINE') THEN + IF(NVALUE(IPAR).EQ.0) THEN + IV=1 + VCHAR(IV)=CVAL + NVALUE(IPAR)=1 + ELSE + CALL LCMGTC(IPSAP,RECNAM,12,NVALUE(IPAR),VCHAR) + DO 70 I=1,NVALUE(IPAR) + IF(CVAL.EQ.VCHAR(I))THEN + IV=I + LGNEW=.FALSE. + GO TO 80 + ENDIF + 70 CONTINUE + IV=NVALUE(IPAR)+1 + 80 IF(LGNEW) THEN + NVALUE(IPAR)=NVALUE(IPAR)+1 + IF(NVALUE(IPAR).GT.MAXVAL) CALL XABORT('SAPPAV: MAXVAL ' + 1 //'OVERFLOW.') + VCHAR(IV)=CVAL + ENDIF + ENDIF + IF(LGNEW) CALL LCMPTC(IPSAP,RECNAM,12,NVALUE(IPAR),VCHAR) + ENDIF + CALL LCMSIX(IPSAP,' ',2) +* + IF(LGNEW) THEN + CALL LCMSIX(IPSAP,'paramdescrip',1) + CALL LCMPUT(IPSAP,'NVALUE',NPAR,1,NVALUE) + CALL LCMSIX(IPSAP,' ',2) + ENDIF + RETURN + END diff --git a/Dragon/src/SAPSPH.f b/Dragon/src/SAPSPH.f new file mode 100644 index 0000000..ceb9672 --- /dev/null +++ b/Dragon/src/SAPSPH.f @@ -0,0 +1,82 @@ +*DECK SAPSPH + SUBROUTINE SAPSPH(IPEDIT,NG,NMIL,ILOC,NLOC,RVALOC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To recover a set of sph equivalence factors and store them as local +* variables. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPEDIT pointer to the edition object (L_EDIT signature). +* NG number of condensed energy groups. +* NMIL number of mixtures in the Saphyb. +* ILOC position of local parameter in RVALOC. +* NLOC first dimension of matrix RVALOC. +* +*Parameters: output +* RVALOC local variable values in mixtures located in RVALOC(ILOC,:). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPEDIT + INTEGER NG,NMIL,ILOC,NLOC + REAL RVALOC(NLOC,NMIL) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + TYPE(C_PTR) JPEDIT,KPEDIT + INTEGER ISTATE(NSTATE) + CHARACTER TEXT12*12 + REAL, ALLOCATABLE, DIMENSION(:) :: WORK +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(WORK(NMIL)) +* + CALL LCMGTC(IPEDIT,'LAST-EDIT',12,TEXT12) + CALL LCMSIX(IPEDIT,TEXT12,1) + CALL LCMSIX(IPEDIT,'MACROLIB',1) + CALL LCMGET(IPEDIT,'STATE-VECTOR',ISTATE) + IF(ISTATE(1).NE.NG) CALL XABORT('SAPSPH: BAD VALUE OF NG.') + IF(ISTATE(2).NE.NMIL) CALL XABORT('SAPSPH: BAD VALUE OF NMIL.') +*---- +* RECOVER SPH EQUIVALENCE FACTORS. +*---- + JPEDIT=LCMGID(IPEDIT,'GROUP') + DO 30 IGR=1,NG + KPEDIT=LCMGIL(JPEDIT,IGR) + CALL LCMLEN(KPEDIT,'NSPH',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPEDIT,'NSPH',WORK) + DO 10 IMIL=1,NMIL + RVALOC(ILOC+IGR-1,IMIL)=WORK(IMIL) + 10 CONTINUE + ELSE + DO 20 IMIL=1,NMIL + RVALOC(ILOC+IGR-1,IMIL)=1.0 + 20 CONTINUE + ENDIF + 30 CONTINUE + CALL LCMSIX(IPEDIT,' ',2) + CALL LCMSIX(IPEDIT,' ',2) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(WORK) + RETURN + END diff --git a/Dragon/src/SEN.f b/Dragon/src/SEN.f new file mode 100644 index 0000000..8c93411 --- /dev/null +++ b/Dragon/src/SEN.f @@ -0,0 +1,206 @@ +*DECK SEN + SUBROUTINE SEN(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To create sensitivity profiles to cross-section on the reactivity +* using first order perturbation method based on the +* adjoint calculation. +* +*Copyright: +* Copyright (C) 2011 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): C. Laville, G. Marleau +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1) create or modification type(L_SENS); +* HENTRY(2) read-only type(L_MACROLIB or L_LIBRARY); +* HENTRY(3) read-only type(L_TRACK); +* HENTRY(4) read-only type(L_FLUX); +* HENTRY(5) read only type(L_AFLUX). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*Comments: +* Call format: +* File.sdf := SENS: Flux Adjoint Biblio Track +* :: [ EDIT iprint ANIS nanis ] ; +* with +* File.sdf = sdf (SEQ_ASCII) file in creation mode +* Flux = Flux (LINKED_LIST or XSM_FILE) in read only mode +* Adjoint = Adjoint (LINKED_LIST or XSM_FILE) in read only mode +* Biblio = Biblio (LINKED_LIST or XSM_FILE) in read only mode +* Track = Track (LINKED_LIST or XSM_FILE) in read only mode +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Routine arguments +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* Parameters +*---- + INTEGER NCAR,NSTATE,IOUT + CHARACTER NAMSBR*6,HSIGN*12,SDF*12 + PARAMETER (NSTATE=40,IOUT=6,NAMSBR='SEN ') + PARAMETER (NCAR=3) +*---- +* Local variables +*---- + TYPE(C_PTR) IPLIB,IPTRACK,IPFLUX,IPAFLUX + INTEGER IPSENS,NR,NU,NM,NI,NG,NGD,NGA,NUD,NUA,NMT,NL,IFMT + INTEGER I,IEN,ISDF,IADJ,ITYPE,ISTATE(NSTATE),IPRINT, + > NANIS,NLTERM +*---- +* Verify if call format is adequate +*---- + IF(NENTRY .NE. 5) CALL XABORT(NAMSBR// + > ': FIVE data structure EXPECTED.') +*---- +* First data structure .sdf file +*---- + IEN=1 + IF(IENTRY(IEN) .NE. 4 ) CALL XABORT(NAMSBR// + > ': SEQ_ASCII format expected for .sdf file') + IF(JENTRY(IEN) .NE. 0 ) CALL XABORT(NAMSBR// + > ': .sdf file must be in creation mode') + SDF=HENTRY(IEN) + ISDF=0 + DO I=1,9 + IF(SDF(I:I+3).EQ.'.sdf') ISDF=1 + ENDDO + IF(ISDF.NE.1) CALL XABORT(NAMSBR// + > ': The extension of the first structure has be ".sdf"') + IPSENS=FILUNIT(KENTRY(IEN)) +*---- +* Process the other 4 data structures (arbitrary order) +*---- + IPLIB=C_NULL_PTR + IPTRACK=C_NULL_PTR + IPFLUX=C_NULL_PTR + IPAFLUX=C_NULL_PTR + NUD=0 + NUA=0 + NMT=0 + NGD=0 + NGA=0 + DO IEN=2,5 + IF((IENTRY(IEN).NE.1).AND.(IENTRY(IEN).NE.2)) + > CALL XABORT(NAMSBR// + > ': LINKED_LIST or XSM_FILE expected') + IF(JENTRY(IEN).NE.2) CALL XABORT(NAMSBR// + > ': data structure must be in READ_ONLY mode') + CALL LCMGTC(KENTRY(IEN),'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_FLUX') THEN + CALL LCMGET(KENTRY(IEN),'STATE-VECTOR',ISTATE) + ITYPE=ISTATE(3) + IF((ITYPE.NE.1).AND.(ITYPE.NE.10)) CALL XABORT(NAMSBR// + > ': Keff problem required') + IADJ=MOD(ISTATE(3)/10,10) + IF(IADJ .EQ. 1) THEN + IPAFLUX=KENTRY(IEN) + NGA=ISTATE(1) + NUA=ISTATE(2) + ELSE + IPFLUX=KENTRY(IEN) + NGD=ISTATE(1) + NUD=ISTATE(2) + ENDIF + ELSE IF(HSIGN.EQ.'L_TRACK') THEN + CALL LCMGET(KENTRY(IEN),'STATE-VECTOR',ISTATE) + IPTRACK=KENTRY(IEN) + NR=ISTATE(1) + NU=ISTATE(2) + NMT=ISTATE(4) + ELSE IF(HSIGN.EQ.'L_LIBRARY') THEN + CALL LCMGET(KENTRY(IEN),'STATE-VECTOR',ISTATE) + IPLIB=KENTRY(IEN) + NM=ISTATE(1) + NI=ISTATE(2) + NG=ISTATE(3) + NL=ISTATE(4) + IFMT=ISTATE(5) + ELSE + CALL XABORT(NAMSBR//': '//HSIGN//' is an invalid signature ') + ENDIF + ENDDO +*---- +* Test if all data structures required are available +*---- + IF(.NOT.C_ASSOCIATED(IPLIB)) CALL XABORT(NAMSBR// + > ': No microlib data structure found') + IF(.NOT.C_ASSOCIATED(IPTRACK)) CALL XABORT(NAMSBR// + > ': No tracking data structure found') + IF(.NOT.C_ASSOCIATED(IPFLUX)) CALL XABORT(NAMSBR// + > ': No direct flux data structure found') + IF(.NOT.C_ASSOCIATED(IPAFLUX)) CALL XABORT(NAMSBR// + > ': No adjoint flux data structure found') +*---- +* Test if parameters are compatibles +* NR Number of region in Tracking object. +* NU Number of unkwnow in Tracking/Flux objects. +* NM Number of mixture in Library object. +* NI Number of isotopes in Library object. +* NG Number of energy group in Library object. +*---- + IF(NGD .NE. NG) CALL XABORT(NAMSBR// + > ': Number of groups in flux and microlib not identical') + IF(NGA .NE. NG) CALL XABORT(NAMSBR// + > ': Number of groups in adjoint and microlib not identical') + IF(NUD .NE. NU) CALL XABORT(NAMSBR// + > ': Number of unknowns in flux and tracking not identical') + IF(NUA .NE. NU) CALL XABORT(NAMSBR// + > ': Number of unknowns in adjoint and tracking not identical') + IF(NMT .GT. NM) CALL XABORT(NAMSBR// + > ': Number of mixtures in tracking larger that microlib') +*---- +* Read input parameters +*---- + NANIS=1 + CALL SENGET(IPRINT,NL,NANIS) + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6000) NG,NR,NU,NM,NI,NL,NANIS + ENDIF +*---- +* Launch sensitivity analysis main routine. +*---- +* ! A 1D calculation have to use NANIS=1 +* IF(NDIM .EQ. 3) THEN ! It is necessary to introduce the parameter NDIM +* NLTERM=NANIS*NANIS ! 3D calculation +* ELSEIF(NDIM .EQ. 2) THEN + NLTERM=(NANIS*(NANIS+1))/2 ! 2D calculation +* ELSE +* NLTERM=NANIS ! 1D calculation +* ENDIF + CALL SENDRV(IPSENS,IPTRACK,IPLIB,IPFLUX,IPAFLUX,IPRINT, + > NR,NU,NI,NG,NANIS,NLTERM) + RETURN +*---- +* Format +*---- + 6000 FORMAT(' Number of groups =',I10/ + > ' Number of regions =',I10/ + > ' Number of unknowns =',I10/ + > ' Maximum number of mixtures =',I10/ + > ' Number of isotopes =',I10/ + > ' Number anisotropy order =',I10/ + > ' Anisotropy order kept =',I10) + END diff --git a/Dragon/src/SENCAL.f b/Dragon/src/SENCAL.f new file mode 100644 index 0000000..fca8a0a --- /dev/null +++ b/Dragon/src/SENCAL.f @@ -0,0 +1,620 @@ +*DECK SENCAL + SUBROUTINE SENCAL(IPSENS,IPLIB,IPRINT,NR,NG,NI,NANIS,NAMISO, + > MELISO,MAT,DENISO,KEFF,P,D,NAMISC,ISOC,NIC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute sensitivity profiles. +* +*Copyright: +* Copyright (C) 2011 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): C. Laville, G. Marleau +* +*Parameters: input/output +* IPSENS LCM Sensitivity object address. +* IPLIB LCM Library object address. +* IPRINT print level. +* NR number of region in Tracking object. +* NG number of energy group in Library object. +* NI number of isotope/mixture. +* NANIS anisotropy order kept. +* NAMISO name of the isotope/mixture. +* MELISO mixture associated with the isotope/mixture. +* MAT mixture of each region. +* DENISO density of each mixtures. +* KEFF keff. +* P matrix calcution for sensitivity analysis. +* D weighting coefficient for sensitivity analysis. +* NAMISC independent isotopes names. +* ISOC independent isotope number associated with isotope/mixture. +* NIC number of independent isotopes names. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Parameters +*---- + INTEGER IOUT,NS + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NS=9,NAMSBR='SENCAL') +*---- +* Suboutine arguements +*---- + TYPE(C_PTR) IPLIB + INTEGER IPSENS,IPRINT,NR,NG,NI,NANIS,NAMISO(3,NI), + > MELISO(NI),MAT(NR) + REAL DENISO(NI),KEFF,P(NR,NANIS,NG,NG),D + INTEGER NAMISC(2,NI),ISOC(NI),NIC +*---- +* Local variables +*---- + TYPE(C_PTR) KPISO + REAL ZERO + CHARACTER ISONAM*12,ISONAC*8,CL*2,HSMG*131 + INTEGER ILENG,ITYLCM,IR,IS,IG,IP,JG,ISF,ISN,ISC,IL,II, + > ISOMEL,IIC,NGG + DOUBLE PRECISION DD,DDD,SENRIG +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IDS + REAL, ALLOCATABLE, DIMENSION(:) :: NUSIGF,CHI,CAPT,SIGS,SCAT, + > NUBAR,NFTOT,SIGD,SIGA,SIGG,SIGP + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SENT,SENC + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: SENG,SENTI + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: SENRG,SENGI + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO +*---- +* Scratch storage allocation +* NUSIGF Vector for nubar multiplied by the fission cross-section +* CHI Vector for fission spectra. +* SENRG Sensitivities for each region and group. +* SENG Sensitivities for each group integrated on each region. +* SENT Integrated sensitivities. +* CAPT Vector for capture cross-sections. +* SIGS Vector for scattering cross-sections. +* SCAT Vector for transfter sections. +* NUBAR Vector for nubar. +* NFTOT Vector for fission cross-sections. +* SIGD Vector for (n,d) cross-sections. +* SIGA Vector for (n,a) cross-sections. +* SIGG Vector for (n,g) cross-sections. +* SIGP Vector for (n,p) cross-sections. +* SENC Vector used for sensitivities to the fission spectra CHI. +* IJJ Highest energy group for which the scattering does no +* vanish. +* NJJ Number of energy group for which the scattering does not +* vanish. +* IDS Used to compute integrated isotope sensitivities. +* SENGI Sensitivities for integrated isotope for each group. +* SENTI Sensitivities for integrated isotope. +*---- + ALLOCATE(IJJ(NG),NJJ(NG),IDS(NS,NIC)) + ALLOCATE(CAPT(NG),NUSIGF(NG),CHI(NG),SIGS(NG),SCAT(NG*NG), + < NUBAR(NG),NFTOT(NG),SIGD(NG),SIGA(NG),SIGG(NG),SIGP(NG)) + ALLOCATE(SENRG(NR,NG,NS),SENG(NG,NS),SENT(NS),SENC(NR), + < SENGI(NG,NS,NIC),SENTI(NS,NIC)) + ALLOCATE(IPISO(NI)) +*---- +* Initialize the directory of the isotope/mixture +* in the library and initialize the SEN information +* support and the cross section support for the isotope +*---- + ZERO=0.0 + NGG=NG*NG +*---- +* Loop over isotopes +*---- + IDS(:NS,:NIC)=0 + SENGI(:NG,:NS,:NIC)=0.0D0 + SENTI(:NS,:NIC)=0.0D0 + CALL LIBIPS(IPLIB,NI,IPISO) + DO II=1,NI + WRITE(ISONAM,'(3A4)') NAMISO(1,II),NAMISO(2,II),NAMISO(3,II) + KPISO=IPISO(II) ! set II-th isotope + IF(.NOT.C_ASSOCIATED(KPISO)) THEN + WRITE(HSMG,'(17HSENCAL: ISOTOPE '',A12,7H'' (ISO=,I8,5H) IS , + 1 30HNOT AVAILABLE IN THE MICROLIB.)') ISONAM,II + CALL XABORT(HSMG) + ENDIF + IIC=ABS(ISOC(II)) + ISOMEL=MELISO(II) + DD=DBLE(DENISO(II)/D) + DDD=DBLE(DD/KEFF) +*---- +* Process isotope +*---- + SENRG(:NR,:NG,:NS)=0.0 + SENG(:NG,:NS)=0.0 + SENT(:NS)=0.0 + SENC(:NR)=0.0 + SIGD(:NG)=0.0 + NUSIGF(:NG)=0.0 + NUBAR(:NG)=0.0 + NFTOT(:NG)=0.0 + CHI(:NG)=0.0 + SIGA(:NG)=0.0 + SIGP(:NG)=0.0 + SIGG(:NG)=0.0 + CAPT(:NG)=0.0 + SIGS(:NG)=0.0 + SCAT(:NG*NG)=0.0 + IJJ(:NG)=0 + NJJ(:NG)=0 +*---- +* (n,g) sensitivity calculation +*---- + IS=1 + CALL LCMLEN(KPISO,'NG',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGET(KPISO,'NG',SIGG) + DO IR=1,NR + IF(MAT(IR).EQ.ISOMEL) THEN + DO IG=1,NG + DO IL=0,NANIS-1 + SENRG(IR,IG,IS)=SENRG(IR,IG,IS)-DD* + > DBLE(((2*IL)+1)*SIGG(IG)*P(IR,IL+1,IG,IG)) + ENDDO + SENG(IG,IS)=SENG(IG,IS)+SENRG(IR,IG,IS) + SENT(IS)=SENT(IS)+SENRG(IR,IG,IS) + ENDDO + ENDIF + ENDDO +*---- +* Add contribution to integrated isotope +*---- + DO IG=1,NG + SENGI(IG,IS,IIC)=SENGI(IG,IS,IIC)+SENG(IG,IS) + ENDDO + SENTI(IS,IIC)=SENTI(IS,IIC)+SENT(IS) + IDS(IS,IIC)=IDS(IS,IIC)+1 +*---- +* Send to IPSENS +*---- + WRITE(IPSENS,7000) ISONAM(1:8),'n,g ',102,-ISOMEL,ZERO + WRITE(IPSENS,7001) SENT(IS),ZERO,ZERO + WRITE(IPSENS,7002) (SENG(IG,IS),IG=1,NG) +*---- +* Print information if required for (n,g) +*---- + IF(IPRINT .GE. 5) THEN + WRITE(IOUT,6000) ' (n,g)',ISONAM,SENT(IS) + WRITE(IOUT,6001) (SENG(IG,IS),IG=1,NG) + ENDIF + ENDIF +*---- +* (n,p) sensitivity calculation +*---- + IS=2 + CALL LCMLEN(KPISO,'NP',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGET(KPISO,'NP',SIGP) + DO IR=1,NR + IF(MAT(IR).EQ.ISOMEL) THEN + DO IG=1,NG + DO IL=0,NANIS-1 + SENRG(IR,IG,IS)=SENRG(IR,IG,IS)-DD* + > DBLE(((2*IL)+1)*SIGP(IG)*P(IR,IL+1,IG,IG)) + ENDDO + SENG(IG,IS)=SENG(IG,IS)+SENRG(IR,IG,IS) + SENT(IS)=SENT(IS)+SENRG(IR,IG,IS) + ENDDO + ENDIF + ENDDO +*---- +* Add contribution to integrated isotope +*---- + DO IG=1,NG + SENGI(IG,IS,IIC)=SENGI(IG,IS,IIC)+SENG(IG,IS) + ENDDO + SENTI(IS,IIC)=SENTI(IS,IIC)+SENT(IS) + IDS(IS,IIC)=IDS(IS,IIC)+1 +*---- +* Send to IPSENS +*---- + WRITE(IPSENS,7000) ISONAM(1:8),'n,p ',103,-ISOMEL,ZERO + WRITE(IPSENS,7001) SENT(IS),ZERO,ZERO + WRITE(IPSENS,7002) (SENG(IG,IS),IG=1,NG) +*---- +* Print information if required for (n,p) +*---- + IF(IPRINT .GE. 5) THEN + WRITE(IOUT,6000) ' (n,p)',ISONAM,SENT(IS) + WRITE(IOUT,6001) (SENG(IG,IS),IG=1,NG) + ENDIF + ENDIF +*---- +* (n,d) sensitivity calculation +*---- + IS=3 + CALL LCMLEN(KPISO,'ND',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGET(KPISO,'ND',SIGD) + DO IR=1,NR + IF(MAT(IR).EQ.ISOMEL) THEN + DO IG=1,NG + DO IL=0,NANIS-1 + SENRG(IR,IG,IS)=SENRG(IR,IG,IS)-DD* + > DBLE(((2*IL)+1)*SIGD(IG)*P(IR,IL+1,IG,IG)) + ENDDO + SENG(IG,IS)=SENG(IG,IS)+SENRG(IR,IG,IS) + SENT(IS)=SENT(IS)+SENRG(IR,IG,IS) + ENDDO + ENDIF + ENDDO +*---- +* Add contribution to integrated isotope +*---- + DO IG=1,NG + SENGI(IG,IS,IIC)=SENGI(IG,IS,IIC)+SENG(IG,IS) + ENDDO + SENTI(IS,IIC)=SENTI(IS,IIC)+SENT(IS) + IDS(IS,IIC)=IDS(IS,IIC)+1 +*---- +* Send to IPSENS +*---- + WRITE(IPSENS,7000) ISONAM(1:8),'n,d ',104,-ISOMEL,ZERO + WRITE(IPSENS,7001) SENT(IS),ZERO,ZERO + WRITE(IPSENS,7002) (SENG(IG,IS),IG=1,NG) +*---- +* Print information if required for (n,d) +*---- + IF(IPRINT .GE. 5) THEN + WRITE(IOUT,6000) ' (n,d)',ISONAM,SENT(IS) + WRITE(IOUT,6001) (SENG(IG,IS),IG=1,NG) + ENDIF + ENDIF +*---- +* (n,a) sensitivity calculation +*---- + IS=4 + CALL LCMLEN(KPISO,'NA',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGET(KPISO,'NA',SIGA) + DO IR=1,NR + IF(MAT(IR).EQ.ISOMEL) THEN + DO IG=1,NG + DO IL=0,NANIS-1 + SENRG(IR,IG,IS)=SENRG(IR,IG,IS)-DD* + > DBLE(((2*IL)+1)*SIGA(IG)*P(IR,IL+1,IG,IG)) + ENDDO + SENG(IG,IS)=SENG(IG,IS)+SENRG(IR,IG,IS) + SENT(IS)=SENT(IS)+SENRG(IR,IG,IS) + ENDDO + ENDIF + ENDDO +*---- +* Add contribution to integrated isotope +*---- + DO IG=1,NG + SENGI(IG,IS,IIC)=SENGI(IG,IS,IIC)+SENG(IG,IS) + ENDDO + SENTI(IS,IIC)=SENTI(IS,IIC)+SENT(IS) + IDS(IS,IIC)=IDS(IS,IIC)+1 +*---- +* Send to IPSENS +*---- + WRITE(IPSENS,7000) ISONAM(1:8),'n,a ',107,-ISOMEL,ZERO + WRITE(IPSENS,7001) SENT(IS),ZERO,ZERO + WRITE(IPSENS,7002) (SENG(IG,IS),IG=1,NG) +*---- +* Print information if required for (n,a) +*---- + IF(IPRINT .GE. 5) THEN + WRITE(IOUT,6000) ' (n,a)',ISONAM,SENT(IS) + WRITE(IOUT,6001) (SENG(IG,IS),IG=1,NG) + ENDIF + ENDIF +*---- +* Capture sensitivity calculation +*---- + IS=5 + DO IG=1,NG + CAPT(IG)=SIGD(IG)+SIGA(IG)+SIGP(IG)+SIGG(IG) + ENDDO + DO IR=1,NR + IF(MAT(IR).EQ.ISOMEL) THEN + DO IG=1,NG + DO IL=0,NANIS-1 + SENRG(IR,IG,IS)=SENRG(IR,IG,IS)-DD* + > DBLE(((2*IL)+1)*CAPT(IG)*P(IR,IL+1,IG,IG)) + ENDDO + SENG(IG,IS)=SENG(IG,IS)+SENRG(IR,IG,IS) + SENT(IS)=SENT(IS)+SENRG(IR,IG,IS) + ENDDO + ENDIF + ENDDO +*---- +* Add contribution to integrated isotope +*---- + DO IG=1,NG + SENGI(IG,IS,IIC)=SENGI(IG,IS,IIC)+SENG(IG,IS) + ENDDO + SENTI(IS,IIC)=SENTI(IS,IIC)+SENT(IS) + IDS(IS,IIC)=IDS(IS,IIC)+1 +*---- +* Send to IPSENS +*---- + WRITE(IPSENS,7000) ISONAM(1:8),'capture',101,-ISOMEL,ZERO + WRITE(IPSENS,7001) SENT(IS),ZERO,ZERO + WRITE(IPSENS,7002) (SENG(IG,IS),IG=1,NG) +*---- +* Print information if required for capture +*---- + IF(IPRINT .GE. 5) THEN + WRITE(IOUT,6000) 'capture',ISONAM,SENT(IS) + WRITE(IOUT,6001) (SENG(IG,IS),IG=1,NG) + ENDIF +*---- +* Scattering sensitivity calculation +*---- + IS=6 + DO IL=1,NANIS + WRITE(CL,'(I2.2)') IL-1 + CALL LCMLEN(KPISO,'SIGS'//CL,ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + IF( IL .EQ. 1) THEN + CALL LCMGET(KPISO,'SIGS'//CL,SIGS) + ENDIF + CALL LCMGET(KPISO,'SCAT'//CL,SCAT) + CALL LCMGET(KPISO,'NJJS'//CL,NJJ) + CALL LCMGET(KPISO,'IJJS'//CL,IJJ) +*---- +* Decompress scattering matrix +* SCAT(JG,IG) is from IG to JG +*---- + DO IR=1,NR + IF(MAT(IR).EQ.ISOMEL) THEN + IP=1 + DO JG=1,NG + DO IG=IJJ(JG),IJJ(JG)-NJJ(JG)+1,-1 + IF(IG .EQ. JG) THEN + SENRIG=DBLE(SCAT(IP)*P(IR,IL,IG,JG))- + > DBLE(((2*IL)-1)*SIGS(IG)*P(IR,IL,IG,IG)) + SENRG(IR,IG,IS)=SENRG(IR,IG,IS)+SENRIG + ELSE + SENRG(IR,IG,IS)=SENRG(IR,IG,IS)+ + > DBLE(SCAT(IP)*P(IR,IL,IG,JG)) + ENDIF + IP=IP+1 + ENDDO + ENDDO + ENDIF + ENDDO + ENDIF + ENDDO + DO IR=1,NR + IF(MAT(IR).EQ.ISOMEL) THEN + DO IG=1,NG + SENRG(IR,IG,IS)=DD*SENRG(IR,IG,IS) + SENG(IG,IS)=SENG(IG,IS)+SENRG(IR,IG,IS) + SENT(IS)=SENT(IS)+SENRG(IR,IG,IS) + ENDDO + ENDIF + ENDDO +*---- +* Add contribution to integrated isotope +*---- + DO IG=1,NG + SENGI(IG,IS,IIC)=SENGI(IG,IS,IIC)+SENG(IG,IS) + ENDDO + SENTI(IS,IIC)=SENTI(IS,IIC)+SENT(IS) + IDS(IS,IIC)=IDS(IS,IIC)+1 +*---- +* Send to IPSENS +*---- + WRITE(IPSENS,7000) ISONAM(1:8),'scatter',0,-ISOMEL,ZERO + WRITE(IPSENS,7001) SENT(IS),ZERO,ZERO + WRITE(IPSENS,7002) (SENG(IG,IS),IG=1,NG) +*---- +* Print information if required for scattering +*---- + IF(IPRINT .GE. 5) THEN + WRITE(IOUT,6000) 'scatter',ISONAM,SENT(IS) + WRITE(IOUT,6001) (SENG(IG,IS),IG=1,NG) + ENDIF +*---- +* Check if the isotope is fissile and get the +* cross section informations +*---- + CALL LCMLEN(KPISO,'NUSIGF',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGET(KPISO,'NUSIGF',NUSIGF) + CALL LCMGET(KPISO,'CHI',CHI) + CALL LCMGET(KPISO,'NFTOT',NFTOT) + DO IG=1,NG + IF(NFTOT(IG).NE.0.0) THEN + NUBAR(IG)=NUSIGF(IG)/NFTOT(IG) + ENDIF + ENDDO +*---- +* Fission sensitivity calculation if fissile isotope +* Fission (ISF), nubar (ISN) and chi (ISC) +*---- + ISF=7 + ISN=8 + ISC=9 + DO IR=1,NR + IF(MAT(IR).EQ.ISOMEL) THEN + DO IG=1,NG + DO IL=0,NANIS-1 +* Fission + SENRG(IR,IG,ISF)=SENRG(IR,IG,ISF)-DD* + > DBLE(((2*IL)+1)*NFTOT(IG)*P(IR,IL+1,IG,IG)) + ENDDO + DO JG=1,NG +* Fission + SENRG(IR,IG,ISF)=SENRG(IR,IG,ISF)+DDD* + > DBLE(NUSIGF(IG)*CHI(JG)*P(IR,1,IG,JG)) +* Nubar + SENRG(IR,IG,ISN)=SENRG(IR,IG,ISN)+ + > DBLE(NUSIGF(IG)*CHI(JG)*P(IR,1,IG,JG)) +* Chi + SENRG(IR,IG,ISC)=SENRG(IR,IG,ISC)+ + > DBLE(NUSIGF(JG)*CHI(IG)*P(IR,1,JG,IG)) + ENDDO +* Fission + SENG(IG,ISF)=SENG(IG,ISF)+SENRG(IR,IG,ISF) + SENT(ISF)=SENT(ISF)+SENRG(IR,IG,ISF) +* Nubar + SENRG(IR,IG,ISN)=DDD*SENRG(IR,IG,ISN) + SENG(IG,ISN)=SENG(IG,ISN)+SENRG(IR,IG,ISN) + SENT(ISN)=SENT(ISN)+SENRG(IR,IG,ISN) +* Chi + SENRG(IR,IG,ISC)=DDD*SENRG(IR,IG,ISC) + SENC(IR)=SENC(IR)+SENRG(IR,IG,ISC) + ENDDO + ENDIF + ENDDO +*---- +* Modification of sensitivty to Chi +*---- + DO IR=1,NR + IF(MAT(IR).EQ.ISOMEL) THEN + DO IG=1,NG + SENRG(IR,IG,ISC)=SENRG(IR,IG,ISC)- + > DBLE(CHI(IG))*SENC(IR) + SENG(IG,ISC)=SENG(IG,ISC)+SENRG(IR,IG,ISC) + SENT(ISC)=SENT(ISC)+SENRG(IR,IG,ISC) + ENDDO + ENDIF + ENDDO +*---- +* Add contribution to integrated isotope +*---- + DO IG=1,NG + SENGI(IG,ISF,IIC)=SENGI(IG,ISF,IIC)+SENG(IG,ISF) + SENGI(IG,ISN,IIC)=SENGI(IG,ISN,IIC)+SENG(IG,ISN) + SENGI(IG,ISC,IIC)=SENGI(IG,ISC,IIC)+SENG(IG,ISC) + ENDDO + SENTI(ISF,IIC)=SENTI(ISF,IIC)+SENT(ISF) + SENTI(ISN,IIC)=SENTI(ISN,IIC)+SENT(ISN) + SENTI(ISC,IIC)=SENTI(ISC,IIC)+SENT(ISC) + IDS(ISF,IIC)=IDS(ISF,IIC)+1 + IDS(ISN,IIC)=IDS(ISN,IIC)+1 + IDS(ISC,IIC)=IDS(ISC,IIC)+1 +*---- +* Send to IPSENS +*---- + WRITE(IPSENS,7000) ISONAM(1:8),'fission',18,-ISOMEL,ZERO + WRITE(IPSENS,7001) SENT(ISF),ZERO,ZERO + WRITE(IPSENS,7002) (SENG(IG,ISF),IG=1,NG) + WRITE(IPSENS,7000) ISONAM(1:8),'nubar ',452,-ISOMEL,ZERO + WRITE(IPSENS,7001) SENT(ISN),ZERO,ZERO + WRITE(IPSENS,7002) (SENG(IG,ISN),IG=1,NG) + WRITE(IPSENS,7000) ISONAM(1:8),'chi ',1018,-ISOMEL,ZERO + WRITE(IPSENS,7001) SENT(ISC),ZERO,ZERO + WRITE(IPSENS,7002) (SENG(IG,ISC),IG=1,NG) +*---- +* Print information if required +*---- + IF(IPRINT .GE. 5) THEN + WRITE(IOUT,6000) 'fission',ISONAM,SENT(ISF) + WRITE(IOUT,6001) (SENG(IG,ISF),IG=1,NG) + WRITE(IOUT,6000) ' nubar',ISONAM,SENT(ISN) + WRITE(IOUT,6001) (SENG(IG,ISN),IG=1,NG) + WRITE(IOUT,6000) ' chi',ISONAM,SENT(ISC) + WRITE(IOUT,6001) (SENG(IG,ISC),IG=1,NG) + ENDIF +*---- +* End of the loop for fissile isotope +*---- + ENDIF +*---- +* End loop for isotopes +*---- + ENDDO +*---- +* Save integrated contributions +*---- + DO IIC=1,NIC + WRITE(ISONAC,'(2A4)') NAMISC(1,IIC),NAMISC(2,IIC) +*---- +* (n,g) sensitivity calculation +*---- + DO IS=1,NS + IF(IDS(IS,IIC).GT.0) THEN + IF(IS .EQ.1) THEN + WRITE(IPSENS,7000) ISONAC,'n,g ', 102,0,ZERO + ELSE IF(IS .EQ.2) THEN + WRITE(IPSENS,7000) ISONAC,'n,p ', 103,0,ZERO + ELSE IF(IS .EQ.3) THEN + WRITE(IPSENS,7000) ISONAC,'n,d ', 104,0,ZERO + ELSE IF(IS .EQ.4) THEN + WRITE(IPSENS,7000) ISONAC,'n,a ', 107,0,ZERO + ELSE IF(IS .EQ.5) THEN + WRITE(IPSENS,7000) ISONAC,'capture', 101,0,ZERO + ELSE IF(IS .EQ.6) THEN + WRITE(IPSENS,7000) ISONAC,'scatter', 0,0,ZERO + ELSE IF(IS .EQ.7) THEN + WRITE(IPSENS,7000) ISONAC,'fission', 18,0,ZERO + ELSE IF(IS .EQ.8) THEN + WRITE(IPSENS,7000) ISONAC,'nubar ', 452,0,ZERO + ELSE IF(IS .EQ.9) THEN + WRITE(IPSENS,7000) ISONAC,'chi ',1018,0,ZERO + ENDIF + WRITE(IPSENS,7001) SENTI(IS,IIC),ZERO,ZERO + WRITE(IPSENS,7002) (SENGI(IG,IS,IIC),IG=1,NG) +*---- +* Print information if required for (n,g) +*---- + IF(IPRINT .GE. 5) THEN + IF(IS .EQ.1) THEN + WRITE(IOUT,6005) ' (n,g)',ISONAC,SENTI(IS,IIC) + ELSE IF(IS .EQ.2) THEN + WRITE(IOUT,6005) ' (n,p)',ISONAC,SENTI(IS,IIC) + ELSE IF(IS .EQ.3) THEN + WRITE(IOUT,6005) ' (n,d)',ISONAC,SENTI(IS,IIC) + ELSE IF(IS .EQ.4) THEN + WRITE(IOUT,6005) ' (n,a)',ISONAC,SENTI(IS,IIC) + ELSE IF(IS .EQ.5) THEN + WRITE(IOUT,6005) 'capture',ISONAC,SENTI(IS,IIC) + ELSE IF(IS .EQ.6) THEN + WRITE(IOUT,6005) 'scatter',ISONAC,SENTI(IS,IIC) + ELSE IF(IS .EQ.7) THEN + WRITE(IOUT,6005) 'fission',ISONAC,SENTI(ISF,IIC) + ELSE IF(IS .EQ.8) THEN + WRITE(IOUT,6005) ' nubar',ISONAC,SENTI(ISN,IIC) + ELSE IF(IS .EQ.9) THEN + WRITE(IOUT,6005) ' chi',ISONAC,SENTI(ISC,IIC) + ENDIF + WRITE(IOUT,6001) (SENGI(IG,IS,IIC),IG=1,NG) + ENDIF + ENDIF + ENDDO +*---- +* End loop for isotopes +*---- + ENDDO +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(IPISO) + DEALLOCATE(SENTI,SENGI,SENC,SENT,SENG,SENRG) + DEALLOCATE(SIGP,SIGG,SIGA,SIGD,NFTOT,NUBAR,SCAT,SIGS,CHI,NUSIGF, + < CAPT) + DEALLOCATE(IDS,NJJ,IJJ) + RETURN +*---- +* Formats +*---- + 6000 FORMAT('Name of the isotope/mixture: ',7X, + > 'Integrated sensitivity to :', + >A7/A12,44X,1P,E14.6/'Sensitivity profiles') + 6001 FORMAT(1P,5E14.6) + 6005 FORMAT('Name of the isotope/mixture: ',7X, + > 'Integrated sensitivity to :', + >A7/A8,48X,1P,E14.6/'Sensitivity profiles') + 7000 FORMAT(A8,4X,1X,A7,' -0000',I7,I7,1P,E14.6) + 7001 FORMAT(1P,3E14.6) + 7002 FORMAT(1P,5E14.6) + END diff --git a/Dragon/src/SENCNT.f b/Dragon/src/SENCNT.f new file mode 100644 index 0000000..e712e41 --- /dev/null +++ b/Dragon/src/SENCNT.f @@ -0,0 +1,148 @@ +*DECK SENCNT + SUBROUTINE SENCNT(IPLIB,NI,NAMISO,MELISO,NSENS,NSENI,NAMISC,ISOC, + > NIC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Count the number of sensitivity coefficients. +* +*Copyright: +* Copyright (C) 2011 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): C. Laville, G. Marleau +* +*Parameters: input/output +* IPLIB LCM Library object address. +* NI number of isotope/mixture. +* NAMISO name of the isotope/mixture. +* MELISO mixture associated with the isotope/mixture. +* NSENS number of sensitivity profiles. +* NSENI number of integrated sensitivity profiles. +* NAMISC independent isotopes names. +* ISOC independent isotope number associated with isotope/mixture. +* NIC number of independent isotopes names. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* Suboutine arguements +*---- + IMPLICIT NONE + TYPE(C_PTR) IPLIB + INTEGER NI + INTEGER NAMISO(3,NI),MELISO(NI) + INTEGER NSENS,NSENI + INTEGER NAMISC(2,NI),ISOC(NI),NIC +*---- +* Parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='SENCNT') +*---- +* Local variables +*---- + TYPE(C_PTR) KPISO + CHARACTER ISONAM*12,HSMG*131 + INTEGER ILENG,ITYLCM,II,IJ,ISOMEL + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO +*---- +* Initialize the directory of the isotope/mixture +* in the library and initialize the SEN information +* support and the cross section support for the isotope +*---- + NIC=0 + NSENS=0 + NSENI=0 + ISOC(:NI)=0 +*---- +* Find independent isotopes names NAMISC +* Associate isotope in mixture to +* independant isotopes names ISOC +*---- + DO II=1,NI + IF(ISOC(II) .EQ. 0) THEN + NIC=NIC+1 + NAMISC(1,NIC)=NAMISO(1,II) + NAMISC(2,NIC)=NAMISO(2,II) + ISOC(II)=NIC + DO IJ=II+1,NI + IF(NAMISC(1,NIC) .EQ. NAMISO(1,IJ) .AND. + > NAMISC(2,NIC) .EQ. NAMISO(2,IJ)) THEN + ISOC(IJ)=-NIC + ENDIF + ENDDO + ENDIF + ENDDO +* + ALLOCATE(IPISO(NI)) + CALL LIBIPS(IPLIB,NI,IPISO) + DO II=1,NI + KPISO=IPISO(II) ! set II-th isotope + IF(.NOT.C_ASSOCIATED(KPISO)) THEN + WRITE(ISONAM,'(3A4)') NAMISO(1,II),NAMISO(2,II),NAMISO(3,II) + WRITE(HSMG,'(17HSENCNT: ISOTOPE '',A12,7H'' (ISO=,I8,5H) IS , + 1 30HNOT AVAILABLE IN THE MICROLIB.)') ISONAM,II + CALL XABORT(HSMG) + ENDIF + ISOMEL=MELISO(II) +*---- +* number of (n,g) sensitivity +*---- + CALL LCMLEN(KPISO,'NG',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + NSENS=NSENS+1 + IF(ISOC(II) .GT. 0) NSENI=NSENI+1 + ENDIF +*---- +* number of (n,p) sensitivity +*---- + CALL LCMLEN(KPISO,'NP',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + NSENS=NSENS+1 + IF(ISOC(II) .GT. 0) NSENI=NSENI+1 + ENDIF +*---- +* number of (n,d) sensitivity +*---- + CALL LCMLEN(KPISO,'ND',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + NSENS=NSENS+1 + IF(ISOC(II) .GT. 0) NSENI=NSENI+1 + ENDIF +*---- +* number of (n,a) sensitivity +*---- + CALL LCMLEN(KPISO,'NA',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + NSENS=NSENS+1 + IF(ISOC(II) .GT. 0) NSENI=NSENI+1 + ENDIF +*---- +* number of Capture sensitivity +*---- + NSENS=NSENS+1 + IF(ISOC(II) .GT. 0) NSENI=NSENI+1 +*---- +* number of Scattering sensitivity +*---- + NSENS=NSENS+1 + IF(ISOC(II) .GT. 0) NSENI=NSENI+1 +*---- +* number of Fissile related sensitivity +*---- + CALL LCMLEN(KPISO,'NUSIGF',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + NSENS=NSENS+3 + IF(ISOC(II) .GT. 0) NSENI=NSENI+3 + ENDIF + ENDDO + DEALLOCATE(IPISO) + RETURN + END diff --git a/Dragon/src/SENDRV.f b/Dragon/src/SENDRV.f new file mode 100644 index 0000000..1397332 --- /dev/null +++ b/Dragon/src/SENDRV.f @@ -0,0 +1,302 @@ +*DECK SENDRV + SUBROUTINE SENDRV(IPSENS,IPTRACK,IPLIB,IPFLUX,IPAFLUX,IPRINT, + > NR,NU,NI,NG,NANIS,NLTERM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Creation of sensitivity profiles to +* cross-section on the reactivity using first order perturbation +* method using the adjoint calculation. +* +*Copyright: +* Copyright (C) 2011 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): C. Laville, G. Marleau +* +*Parameters: input/output +* IPSENS LCM Sensitivity object address. +* IPTRACK LCM Tracking object address. +* IPLIB LCM Library object address. +* IPFLUX LCM Flux object address. +* IPAFLUX LCM Adjoin flux object address. +* IPRINT print level. +* NR number of region in Tracking object. +* NU number of unkwnow in Tracking/Flux objects. +* NI number of isotopes in Library object. +* NG number of energy group in Library object. +* NANIS anisotropy order kept. +* NLTERM total number of term of the flux. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Suboutine arguements +*---- + TYPE(C_PTR) IPTRACK,IPLIB,IPFLUX,IPAFLUX + INTEGER IPSENS,NR,NU,NI,NG,IPRINT,NANIS,NLTERM +*---- +* Local variables +*---- + TYPE(C_PTR) KPISO,JPFLUX,JPAFLUX + INTEGER IG,JG,IR,KL,KKEYL,IL,IM,II + INTEGER ILENG,ILON,ITYLCM,NSENI,NSENS,NIC + REAL KEFF,D + CHARACTER ISONAM*12,REV*48,DATE*64,HSMG*131 +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MAT,KEY,MELISO,ISOC + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NAMISO,NAMISC + REAL, ALLOCATABLE, DIMENSION(:) :: VOL,ENERG,DENISO,SOLFLU,NUSIGF, + > CHI + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: FLUXI,AFLUX + REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: P + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO +*---- +* Parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='SENDRV') +*---- +* Scratch storage allocation +* MAT Mixture of each region in Tracking object. +* KEY Localisation of the flux/aflux for each region in Tracking +* object. +* MELISO Mixture of each isotope/region in Library object. +* NAMISO Alias of each isotope/region in Library object. +* NAMISC Independent isotopes names. +* ISOC Independent isotope number associated with isotope/mixture. +* VOL Volume of each region in Tracking object. +* ENERG Energy boundaries in Library object. +* DENISO Density of each isotope/region in Library object. +* SOLFLU Flux solution of each region in Flux object. +* FLUXI Flux of each region multiplied by the volume of the region. +* AFLUX Adjoint flux of each region. +* P Matrix calcution for sensitivity analysis. +* NUSIGF Vector for nubar multiplied by the fission cross-section +* CHI Vector for fission spectra. +*---- + ALLOCATE(MAT(NR),KEY(NU),MELISO(NI),NAMISO(3,NI),NAMISC(2,NI), + > ISOC(NI)) + ALLOCATE(VOL(NR),ENERG(NG+1),DENISO(NI),SOLFLU(NU), + > FLUXI(NR,NLTERM,NG),AFLUX(NR,NLTERM,NG),P(NR,NANIS,NG,NG), + > NUSIGF(NG),CHI(NG)) +*-------- +* Step 1: +* Recover Tracking informations +* a) VOLUME +* b) MATCOL +* c) KEYFLX +*---- + VOL(:NR)=0.0 + CALL LCMGET(IPTRACK,'VOLUME',VOL) +*---- + MAT(:NR)=0 + CALL LCMGET(IPTRACK,'MATCOD',MAT) +*---- + KEY(:NU)=0 + CALL LCMGET(IPTRACK,'KEYFLX',KEY) +*---- +* Print information if required +*---- + IF(IPRINT .GE. 5) THEN + WRITE(IOUT,'(3(A12,8X))') 'Region # ','VOLUMES ', + > 'MATCOD ' + WRITE(IOUT,'(I10,10X,E16.7,4X,I8)') + > (IR,VOL(IR),MAT(IR),IR=1,NR) + ENDIF +*-------- +* Step 2: +* Recover library informations +* a) ENERGY GROUP BOUNDARIES +* b) MIXTURE ASSOCIATED WITH ISOTOPE +* c) ISOTOPES ALIAS +* d) ISOTOPES DENSITIES +*---- + ENERG(:NG+1)=0.0 + CALL LCMGET(IPLIB,'ENERGY',ENERG) +*---- + MELISO(:NI)=0 + CALL LCMGET(IPLIB,'ISOTOPESMIX',MELISO) +*---- + CALL LCMGET(IPLIB,'ISOTOPESUSED',NAMISO) +*---- + DENISO(:NI)=0.0 + CALL LCMGET(IPLIB,'ISOTOPESDENS',DENISO) +*---- +* Scan library to determine number of sensitivity profiles: +* NIC is number of independent isotopes +* ISOC is the independent isotope number associated with +* each isotope/mixture +* NAMISC is the independent isotope name +*---- + CALL SENCNT(IPLIB,NI,NAMISO,MELISO, + > NSENS,NSENI,NAMISC,ISOC,NIC) + IF(IPRINT.GE.1) THEN + WRITE(IOUT,6000) NSENS+NSENI,NSENI + ENDIF +*---- +* Print information if required +*---- + IF(IPRINT .GE. 5) THEN + WRITE(IOUT,'(A12)') 'ENERGY ' + WRITE(IOUT,'(5E14.6)') (ENERG(IG),IG=1,NG+1) + WRITE(IOUT,'(6(A12,8X))') 'Isotope # ','ISOTOPESMIX ', + > 'ISOTOPESUSED','ISOTOPESDENS', + > 'Name Int Sen','IsoComb ' + WRITE(IOUT,'(I8,12X,I8,12X,3A4,8X,E16.7,4X,2A4,12X,I8)') + > (II,MELISO(II),NAMISO(1,II),NAMISO(2,II),NAMISO(3,II), + > DENISO(II),NAMISC(1,ABS(ISOC(II))),NAMISC(2,ABS(ISOC(II))), + > ISOC(II),II=1,NI) + ENDIF +*-------- +* Step 3: +* Recover K-effective, flux and adjoint, +* and compute integrated flux. +*---- + KEFF=0 + CALL LCMGET(IPFLUX,'K-EFFECTIVE',KEFF) +*---- + FLUXI(:NR,:NLTERM,:NG)=0.0 + AFLUX(:NR,:NLTERM,:NG)=0.0 + CALL LCMLEN(IPFLUX,'FLUX',ILON,ITYLCM) + IF(ILON.EQ.0) CALL XABORT(NAMSBR//': MISSING FLUX INFO.') + JPFLUX=LCMGID(IPFLUX,'FLUX') + DO IG=1,NG + CALL LCMGDL(JPFLUX,IG,SOLFLU) + KL=0 + KKEYL=0 + DO IL=1,NANIS + DO IM=1,IL ! 2*IL-1 in 3D + KL=KL+1 + DO IR=1,NR + FLUXI(IR,KL,IG)=SOLFLU(KEY(IR+KKEYL))*VOL(IR) + ENDDO + KKEYL=KKEYL+NR + ENDDO + ENDDO + ENDDO + CALL LCMLEN(IPAFLUX,'AFLUX',ILON,ITYLCM) + IF(ILON.EQ.0) CALL XABORT(NAMSBR//': MISSING AFLUX INFO.') + JPAFLUX=LCMGID(IPAFLUX,'AFLUX') + DO IG=1,NG + CALL LCMGDL(JPAFLUX,IG,SOLFLU) + KL=0 + KKEYL=0 + DO IL=1,NANIS + DO IM=1,IL ! 2*IL-1 in 3D + KL=KL+1 + DO IR=1,NR + AFLUX(IR,KL,IG)=SOLFLU(KEY(IR+KKEYL)) + ENDDO + KKEYL=KKEYL+NR + ENDDO + ENDDO + ENDDO +*-------- +* Step 4: +* Computation of the P matrix used for sensitivity calculation +*---- + P(:NR,:NANIS,:NG,:NG)=0.0 + DO IG=1,NG + DO JG=1,NG + KL=0 + DO IL=1,NANIS + DO IM=1,IL ! 2*IL-1 en 3D + KL=KL+1 + DO IR=1,NR + P(IR,IL,IG,JG)=P(IR,IL,IG,JG)+ + > FLUXI(IR,KL,IG)*AFLUX(IR,KL,JG) + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO +*-------- +* Step 5: +* Computation of the D factor +*---- + D=0 + ALLOCATE(IPISO(NI)) + CALL LIBIPS(IPLIB,NI,IPISO) + DO II=1,NI + KPISO=IPISO(II) ! set II-th isotope + IF(.NOT.C_ASSOCIATED(KPISO)) THEN + WRITE(ISONAM,'(3A4)') NAMISO(1,II),NAMISO(2,II),NAMISO(3,II) + WRITE(HSMG,'(17HSENDRV: ISOTOPE '',A12,7H'' (ISO=,I8,5H) IS , + 1 30HNOT AVAILABLE IN THE MICROLIB.)') ISONAM,II + CALL XABORT(HSMG) + ENDIF + CALL LCMLEN(KPISO,'NUSIGF',ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + NUSIGF(:NG)=0.0 + CHI(:NG)=0.0 + CALL LCMGET(KPISO,'NUSIGF',NUSIGF) + CALL LCMGET(KPISO,'CHI',CHI) + DO IR=1,NR + IF(MAT(IR).EQ.MELISO(II)) THEN + DO IG=1,NG + DO JG=1,NG + D=D+FLUXI(IR,1,IG)*DENISO(II) + > *NUSIGF(IG)*CHI(JG)*AFLUX(IR,1,JG) + ENDDO + ENDDO + ENDIF + ENDDO + ENDIF + ENDDO + DEALLOCATE(IPISO) +*-------- +* Step 6: +* Initialize the top of the .sdf file +*---- + WRITE(IPSENS,7000) NG,NSENS+NSENI,NSENI,KEFF + WRITE(IPSENS,7001) + WRITE(IPSENS,7002) (ENERG(IG),IG=1,NG+1) +*-------- +* Step 7: +* Sensitivity analysis for each isotope/mixture +*---- + CALL SENCAL(IPSENS,IPLIB,IPRINT,NR,NG,NI,NANIS,NAMISO,MELISO, + > MAT,DENISO,KEFF,P,D,NAMISC,ISOC,NIC) +*-------- +* Step 9: +* Finish the creation of the .sdf file +*---- + CALL KDRVER(REV,DATE) + WRITE(IPSENS,7010) REV,DATE +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(CHI,NUSIGF,P,AFLUX,FLUXI,SOLFLU,DENISO,ENERG,VOL) + DEALLOCATE(ISOC,NAMISC,NAMISO,MELISO,KEY,MAT) + RETURN +*---- +* Formats +*---- + 6000 FORMAT('Total number of profils (reactions,isotopes,mixtures) :', + >5X,I10/'Total number of integrated profiles ', + >'(reactions,isotopes) :',3X,I10) + 7000 FORMAT( + >I10,3X,'number of neutron groups'/ + >I10,3X,'number of sensitivity profiles ', + >I10,3X,'are region integrated'/ + >F10.6,3X,'k-eff from the forward case') + 7001 FORMAT('energy boundaries:') + 7002 FORMAT(1P,5E14.6) + 7010 FORMAT(//1X,'file verification information'/ + >1X,'code system: DRAGON'/ + >1X,'Version: ',A48/ + >1X,'program: SENS:'/ + >3X,'creation date: ',A64/ + >3X,'library: UNKWNOW'/ + >3X,'this is not a scale configuration controlled code') + END diff --git a/Dragon/src/SENGET.f b/Dragon/src/SENGET.f new file mode 100644 index 0000000..c2e8b99 --- /dev/null +++ b/Dragon/src/SENGET.f @@ -0,0 +1,89 @@ +*DECK SENGET + SUBROUTINE SENGET(IPRINT,NL,NANIS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To read from the input instructions for the SENS: module. +* +*Copyright: +* Copyright (C) 2011 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: output +* IPRINT print level. +* NL Legendre contribution in scattering on library. +* NANIS Legendre contribution in scattering for SENS: +* = 1 only isotropic contribution; +* = ilana contribution up to ilana=NL considered +* (default is ilana=1). +* +*Comments: +* Input data is of the form: +* [ EDIT iprint ] +* [ ANIS ilana ] +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPRINT,NL,NANIS +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='SENGET') +*---- +* Variables for input via REDGET +*---- + INTEGER ITYPLU,INTLIR + CHARACTER CARLIR*72 + REAL REALIR + DOUBLE PRECISION DBLLIR +*---- +* Initialize default values for IPRINT +*---- + IPRINT=1 +*---- +* Get data from input file +*---- + 100 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .EQ. 10) GO TO 105 + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + >': Read error -- Character variable expected') + IF(CARLIR(1:4) .EQ. ';') THEN + GO TO 105 + ELSE IF(CARLIR(1:4) .EQ. 'EDIT') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': Read error -- print level expected after EDIT.') + IPRINT=INTLIR + ELSE IF(CARLIR(1:5) .EQ. 'ANIS') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': Read error -- scattering order expected') + IF(INTLIR .LE. 1) THEN + NANIS=1 + ELSE + NANIS=MIN(NL,INTLIR) + ENDIF + ELSE + CALL XABORT(NAMSBR//': Keyword '//CARLIR(1:5)//' is invalid.') + ENDIF + GO TO 100 + 105 CONTINUE +*---- +* Processing finished, return +*---- + RETURN + END diff --git a/Dragon/src/SHI.f b/Dragon/src/SHI.f new file mode 100644 index 0000000..168bf29 --- /dev/null +++ b/Dragon/src/SHI.f @@ -0,0 +1,285 @@ +*DECK SHI + SUBROUTINE SHI(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Interpolation of nuclear properties in a lattice code library using +* the generalized Stamm'ler method. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file. The first option is: +* HENTRY(1) modification type(L_LIBRARY); +* HENTRY(2) read-only type(L_TRACK); +* HENTRY(3) read-only sequential binary tracking file. +* The second option is: +* HENTRY(1) creation type(L_LIBRARY); +* HENTRY(2) read-only type(L_LIBRARY); +* HENTRY(3) read-only type(L_TRACK); +* HENTRY(4) read-only sequential binary tracking file. +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + CHARACTER HSMG*131,TEXT12*12,HSIGN*12,TEXT4*4,CDOOR*12,TITLE*72 + INTEGER IPAR(NSTATE),IGP(NSTATE) + DOUBLE PRECISION DFLOTT + LOGICAL LEAKSW + TYPE(C_PTR) IPLIB,IPTRK +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MAT,IDL,MIX,LSHI,ISONR,ISONA + REAL, ALLOCATABLE, DIMENSION(:) :: VOL,DEN,SNGAR,SBGAR +*---- +* PARAMETER VALIDATION +*---- + IENT=1 + IF(NENTRY.LE.1) CALL XABORT('SHI: TWO PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('SHI: LCM ' + 1 //'OBJECT EXPECTED AT LHS.') + IF(JENTRY(1).EQ.0) THEN +* INTERNAL LIBRARY CREATION. COPY THE FIRST RHS ON THIS LHS. + IF(NENTRY.LE.2) CALL XABORT('SHI: THREE PARAMETERS EXPECTED.') + IF((JENTRY(2).NE.2).OR.((IENTRY(2).NE.1).AND. + 1 (IENTRY(2).NE.2))) CALL XABORT('SHI: LCM OBJECT IN READ-ONLY' + 2 //'MODE EXPECTED AT FIRST RHS.') + CALL LCMEQU(KENTRY(2),KENTRY(1)) + IENT=3 + ELSE IF(JENTRY(1).EQ.1) THEN +* INTERNAL LIBRARY MODIFICATION. + IENT=2 + ELSE + CALL XABORT('SHI: INTERNAL LIBRARY IN CREATE OR MODIFICATION M' + 1 //'ODE EXPECTED.') + ENDIF + IPLIB=KENTRY(1) +*---- +* RECOVER THE TRACKING OBJECT +*---- + DO 10 I=IENT,NENTRY + IF((JENTRY(I).EQ.2).AND.(IENTRY(I).LE.2)) THEN + CALL LCMGTC(KENTRY(I),'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_TRACK') THEN + IPTRK=KENTRY(I) + GO TO 20 + ENDIF + ENDIF + 10 CONTINUE + CALL XABORT('SHI: UNABLE TO FIND A TRACKING OBJECT.') + 20 CALL LCMGTC(IPTRK,'TRACK-TYPE',12,CDOOR) +*---- +* RECOVER TRACKING FILE INFORMATION +*---- + IFTRAK=0 + DO 40 I=IENT+1,NENTRY + IF(IENTRY(I).EQ.3) THEN + IFTRAK=FILUNIT(KENTRY(I)) + TEXT12=HENTRY(I) + IF(JENTRY(I).NE.2) CALL XABORT('SHI: TRACKING FILE '//TEXT12// + 1 ' NOT IN READ-ONLY MODE.') + GO TO 50 + ENDIF + 40 CONTINUE +*---- +* RECOVER TABULATED FUNCTIONS +*---- + 50 CALL XDRTA2 +*---- +* RECOVER GENERAL TRACKING INFORMATION +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',IGP) + NREG=IGP(1) + NUN=IGP(2) + LEAKSW=IGP(3).EQ.0 + IF(CDOOR.EQ.'MCCG') THEN + CALL LCMLEN(IPTRK,'KEYFLX',LKFL,ITYLCM) + NFUNL=LKFL/NREG + ELSE + NFUNL=1 + ENDIF + ALLOCATE(MAT(NREG),VOL(NREG),IDL(NREG*NFUNL)) + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'VOLUME',VOL) + CALL LCMGET(IPTRK,'KEYFLX',IDL) + CALL LCMLEN(IPTRK,'TITLE',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGTC(IPTRK,'TITLE',72,TITLE) + ELSE + TITLE='*** NO TITLE PROVIDED ***' + ENDIF +*---- +* RECOVER GENERAL INTERNAL LIBRARY INFORMATION +*---- + CALL LCMGTC(IPLIB,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_LIBRARY') THEN + TEXT12=HENTRY(1) + CALL XABORT('SHI: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_LIBRARY EXPECTED.') + ENDIF + CALL LCMGET(IPLIB,'STATE-VECTOR',IPAR) + NBISO=IPAR(2) + NGRO=IPAR(3) + ITRANC=IPAR(5) + IPROB=IPAR(6) + IGRMIN=IPAR(9)+1 + IGRMAX=IPAR(10) + NBMIX=IPAR(14) + NRES=IPAR(15) + IF(IGP(4).GT.NBMIX) THEN + WRITE(HSMG,'(43HSHI: THE NUMBER OF MIXTURES IN THE TRACKING, + 1 2H (,I5,50H) IS GREATER THAN THE NUMBER OF MIXTURES IN THE IN, + 2 16HTERNAL LIBRARY (,I5,2H).)') IGP(4),NBMIX + CALL XABORT(HSMG) + ENDIF + ALLOCATE(MIX(NBISO),DEN(NBISO),LSHI(NBISO),SNGAR(NGRO*NBISO), + 1 SBGAR(NGRO*NBISO)) + CALL LCMGET(IPLIB,'ISOTOPESMIX',MIX) + CALL LCMGET(IPLIB,'ISOTOPESDENS',DEN) + CALL LCMGET(IPLIB,'ISOTOPESSHI',LSHI) + CALL LCMGET(IPLIB,'ISOTOPESDSB',SBGAR) + CALL LCMGET(IPLIB,'ISOTOPESDSN',SNGAR) +*---- +* RECOVER REFERENCE AND ALIAS ISOTOPES NAMES +*---- + ALLOCATE(ISONR(3*NBISO),ISONA(3*NBISO)) + CALL LCMGET(IPLIB,'ISOTOPERNAME',ISONR) + CALL LCMGET(IPLIB,'ISOTOPESUSED',ISONA) +*---- +* READ THE INPUT DATA +*---- +* DEFAULT OPTIONS: + IMPX=1 + CALL LCMLEN(IPLIB,'SHIBA',LENLCM,ITYLCM) + IF(LENLCM.NE.0) THEN + CALL LCMSIX(IPLIB,'SHIBA',1) + CALL LCMGET(IPLIB,'STATE-VECTOR',IPAR) + CALL LCMGET(IPLIB,'EPS-SHIBA',EPS) + CALL LCMSIX(IPLIB,' ',2) + IGRMIN=IPAR(1) + IGRMAX=IPAR(2) + MAXX0=IPAR(3) + IBIEFF=IPAR(4) + IGC=IPAR(5) + ITRANZ=IPAR(6) + LEVEL=IPAR(7) + IPHASE=IPAR(8) + ELSE + MAXX0=20 + IBIEFF=0 + IGC=1 + ITRANZ=ITRANC + LEVEL=0 + EPS=1.0E-4 + IF(CDOOR.EQ.'SYBIL') THEN + IPHASE=2 + ELSE IF(CDOOR.EQ.'EXCELL') THEN + IPHASE=2 + ELSE + IPHASE=1 + ENDIF + ENDIF +*---- +* READ LIBRARY DATA +*---- + 60 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.10) GO TO 100 + IF(INDIC.NE.3) CALL XABORT('SHI: CHARACTER DATA EXPECTED.') + IF(TEXT4.EQ.'EDIT') THEN +* READ THE PRINT INDEX. + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SHI: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT4.EQ.'GRMI') THEN + CALL REDGET(ITYPLU,IGRMIN,FLOTT,TEXT4,DFLOTT) + IF(ITYPLU.NE.1) CALL XABORT('SHI: INTEGER DATA EXPECTED(2).') + ELSE IF(TEXT4.EQ.'GRMA') THEN + CALL REDGET(ITYPLU,IGRMAX,FLOTT,TEXT4,DFLOTT) + IF(ITYPLU.NE.1) CALL XABORT('SHI: INTEGER DATA EXPECTED(3).') + IF(IGRMAX.GT.NGRO) THEN + CALL XABORT('SHI: ILLEGAL NUMBER OF GROUP IN LIBRARY.') + ENDIF + ELSE IF(TEXT4.EQ.'MXIT') THEN + CALL REDGET(ITYPLU,MAXX0,FLOTT,TEXT4,DFLOTT) + IF(ITYPLU.NE.1) CALL XABORT('SHI: INTEGER DATA EXPECTED(4).') + ELSE IF(TEXT4.EQ.'EPS') THEN + CALL REDGET(ITYPLU,NITMA,EPS,TEXT4,DFLOTT) + IF(ITYPLU.NE.2) CALL XABORT('SHI: REAL DATA EXPECTED.') + ELSE IF(TEXT4.EQ.'NOLJ') THEN + IBIEFF=0 + ELSE IF(TEXT4.EQ.'LJ') THEN + IBIEFF=1 + ELSE IF(TEXT4.EQ.'NOGC') THEN + IGC=0 + ELSE IF(TEXT4.EQ.'GC') THEN + IGC=1 + ELSE IF(TEXT4.EQ.'NOTR') THEN + ITRANZ=0 + ELSE IF(TEXT4.EQ.'TRAN') THEN + ITRANZ=ITRANC + ELSE IF(TEXT4.EQ.'LEVE') THEN + CALL REDGET(ITYPLU,LEVEL,FLOTT,TEXT4,DFLOTT) + IF(ITYPLU.NE.1) CALL XABORT('SHI: INTEGER DATA EXPECTED(5).') + IF((LEVEL.LT.0).OR.(LEVEL.GT.2)) CALL XABORT('SHI: BAD LEVEL.') + ELSE IF(TEXT4.EQ.'ARM') THEN + IPHASE=1 + ELSE IF(TEXT4.EQ.'PIJ') THEN + IPHASE=2 + ELSE IF(TEXT4.EQ.';') THEN + GO TO 100 + ELSE + CALL XABORT('SHI: '//TEXT4//' IS AN INVALID KEY-WORD.') + ENDIF + GO TO 60 +*---- +* THE NUMBER OF UNKNOWNS OF A CURRENT-BASED MULTICELL ITERATION IS +* INCREASED TO HOLD INTERFACE CURRENT COMPONENTS. +*---- + 100 IF(IPHASE.EQ.1) THEN + IF(CDOOR.EQ.'SYBIL') NUN=NUN+IGP(9) + IF((CDOOR.EQ.'EXCELL').AND.(IGP(7).EQ.5)) NUN=NUN+IGP(28) + ENDIF + IF(NBMIX.EQ.0) CALL XABORT('SHI: NBMIX NOT YET DEFINED.') + IF(NRES.EQ.0) CALL XABORT('SHI: THERE IS NO RESONANT ISOTOPES.') + IF(NREG.EQ.0) CALL XABORT('SHI: NREG = 0') + CALL SHIDRV(IPLIB,IPTRK,IFTRAK,LEVEL,NGRO,NBISO,NBMIX,NREG,NUN, + 1 CDOOR,NRES,IMPX,ISONR,ISONA,MIX,DEN,SNGAR,SBGAR,LSHI,IPHASE, + 2 IPROB,MAT,VOL,IDL,LEAKSW,TITLE,IGRMIN,IGRMAX,MAXX0,IBIEFF,IGC, + 3 ITRANZ,EPS) +*---- +* RELEASE GENERAL TRACKING INFORMATION +*---- + DEALLOCATE(IDL,VOL,MAT) +*---- +* RELEASE GENERAL INTERNAL LIBRARY INFORMATION +*---- + DEALLOCATE(ISONA,ISONR,SBGAR,SNGAR,LSHI,DEN,MIX) + RETURN + END diff --git a/Dragon/src/SHIDIL.f b/Dragon/src/SHIDIL.f new file mode 100644 index 0000000..d6f50f8 --- /dev/null +++ b/Dragon/src/SHIDIL.f @@ -0,0 +1,235 @@ +*DECK SHIDIL + SUBROUTINE SHIDIL(NRAT,NALPHA,NBNRS,COEF,DENOM,DILUT,PICX,SIGX, + 1 DIST,VST,IMPX,LLL,XCOEF,XDENO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the zone-dependent weights and base points for a N-term +* rational approximation. +* +*Copyright: +* Copyright (C) 2004 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NRAT number of terms in the pij rational approximation. +* NALPHA number of available dilutions (NALPHA.ge.2*NRAT-1). +* NBNRS number of totally correlated fuel regions. +* COEF numerator for the fuel-to-fuel cp rational expansion. +* DENOM base points for the fuel-to-fuel cp rational expansion. +* DILUT average dilution. +* PICX pic values. +* SIGX resonant cross sections. +* DIST number density ratio of the resonant isotope. +* VST volumes of the resonant regions. +* IMPX print flag (equal to zero for no print). +* LLL energy group index. +* +*Parameters: output +* XCOEF zone-dependent weights. +* XDENO zone-dependent base points. +* +*----------------------------------------------------------------------- +* + IMPLICIT DOUBLE PRECISION(A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NRAT,NALPHA,NBNRS,IMPX,LLL + REAL DILUT(NALPHA),SIGX(NALPHA),DIST(NBNRS),VST(NBNRS) + DOUBLE PRECISION PICX(NALPHA,NBNRS) + COMPLEX COEF(NRAT),DENOM(NRAT) + COMPLEX*16 XCOEF(NRAT,NBNRS),XDENO(NRAT,NBNRS) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NMAX=11,NORIN=(NMAX-1)/2) + DOUBLE PRECISION TOFIT(NMAX,2),SDDK(NMAX),SDDK2(NMAX), + 1 DA(0:NORIN),DB(0:NORIN),DC(0:NORIN),C(0:NORIN+1) + COMPLEX*16 DD,E1,E2,AAA,SQRTM3,SIGXI,CDENOM(NORIN+1),DDC(0:NORIN) + CHARACTER HSMG*131 + LOGICAL LFAIL + PARAMETER (SQRTM3=(0.0,1.73205080756888)) +* + IF(NBNRS.EQ.1) THEN + DO 10 I=1,NRAT + XCOEF(I,1)=COEF(I) + XDENO(I,1)=DENOM(I) + 10 CONTINUE + RETURN + ENDIF + NORS=0 + DO 20 I=1,NRAT + IF(COEF(I).NE.(0.0,0.0)) NORS=NORS+1 + 20 CONTINUE + IF(NORS.EQ.1) THEN + DO 30 I=1,NBNRS + XCOEF(1,I)=1.0D0 + 30 CONTINUE + GO TO 170 + ENDIF + IF(NORS.GT.NORIN+1) CALL XABORT('SHIDIL: NORIN OVERFLOW.') +*---- +* TRANSFORM THE RATIONAL APPROXIMATION INTO A PADE REPRESENTATION +*---- + DO 40 I=0,NRAT-1 + DA(I)=0.0D0 + DB(I)=0.0D0 + 40 CONTINUE + DO 75 N=1,NRAT + DDC(0)=(1.0D0,0.0D0) + I0=0 + DO 60 I=1,NRAT + IF((I.NE.N).AND.(COEF(I).NE.(0.0,0.0))) THEN + I0=I0+1 + DDC(I0)=DDC(I0-1) + DO 50 J=I0-1,1,-1 + DDC(J)=DDC(J-1)+DDC(J)*DENOM(I) + 50 CONTINUE + DDC(0)=DDC(0)*DENOM(I) + ENDIF + 60 CONTINUE + DO 70 I=0,NRAT-1 + DA(I)=DA(I)+DBLE(COEF(N)*DENOM(N)*DDC(I)) + DB(I)=DB(I)+DBLE(COEF(N)*DDC(I)) + 70 CONTINUE + 75 CONTINUE + DO 80 I=0,NORS-1 + DA(I)=DA(I)/DB(NORS-1) + DB(I)=DB(I)/DB(NORS-1) + 80 CONTINUE +* + DO 100 IALP=1,2*NRAT-1 + GAR1=DA(NORS-1) + DO 90 I=NORS-2,0,-1 + GAR1=DA(I)+GAR1*SIGX(IALP) + 90 CONTINUE + SDDK(IALP)=DILUT(IALP)/GAR1 + SDDK2(IALP)=SDDK(IALP)*SDDK(IALP) + 100 CONTINUE +*---- +* PROCESS THE DISTRIBUTED DILUTIONS +*---- + DO 160 K=1,NBNRS + DO 110 IALP=1,2*NRAT-1 + TOFIT(IALP,1)=SIGX(IALP)*DIST(K) + DILUTM=1.0D0/PICX(IALP,K)-SIGX(IALP)*DIST(K) + TOFIT(IALP,2)=DILUTM/SDDK(IALP) + 110 CONTINUE + CALL ALDFIT(NALPHA,NORS-1,TOFIT(1,1),TOFIT(1,2),SDDK2,DC) +* + QQ=DC(1)+DB(0) + RR=DC(0) + IF(NORS-1.EQ.0) THEN +* 1-TERM RATIONAL APPROXIMATION. + XCOEF(1,K)=1.0D0 + XDENO(1,K)=DC(0) + ELSE IF(NORS-1.EQ.1) THEN +* 2-TERMS RATIONAL APPROXIMATION. + AAA=QQ*QQ-4.0D0*RR + AAA=SQRT(AAA) + E1=0.5D0*(QQ+AAA) + E2=0.5D0*(QQ-AAA) + IF(ABS(DBLE(E1*E2)-RR).GT.5.0E-3*ABS(RR)) THEN + WRITE (HSMG,'(42HSHIDIL: INTERPOLATION ALGORITHM FAILURE 1,, + 1 6H COEF=,1P,3E11.3)') QQ,RR,DBLE(E1*E2) + CALL XABORT(HSMG) + ENDIF +* + XCOEF(1,K)=(DB(0)-E1)/(E2-E1) + XCOEF(2,K)=(DB(0)-E2)/(E1-E2) + XDENO(1,K)=E1 + XDENO(2,K)=E2 + ELSE IF(NORS-1.GE.2) THEN +* NORS-TERMS RATIONAL APPROXIMATION. + SGN=1.0D0 + C(0)=DC(0) + DO 120 I=2,NORS + SGN=-SGN + C(I-1)=SGN*(DB(I-2)/DIST(K)**(I-2)+DC(I-1)) + 120 CONTINUE + C(NORS)=-SGN + CALL ALROOT(C,NORS,CDENOM,LFAIL) + IF(LFAIL) CALL XABORT('SHIDIL: ROOT FINDING FAILURE.') + DO 150 I=1,NORS + SIGXI=CDENOM(I) + XDENO(I,K)=CMPLX(SIGXI) + DD=SIGXI**(NORS-1) + SGN=1.0D0 + DO 130 J=NORS-1,1,-1 + SGN=-SGN + DD=DD+SGN*DB(J-1)*SIGXI**(J-1)/DIST(K)**(J-1) + 130 CONTINUE + DO 140 J=1,NORS + IF(J.NE.I) DD=DD/(SIGXI-CDENOM(J)) + 140 CONTINUE + XCOEF(I,K)=CMPLX(DD) + 150 CONTINUE + ELSE + CALL XABORT('SHIDIL: PADE COLLOCATION FAILURE.') + ENDIF + 160 CONTINUE +* + 170 DO 185 J=1,NBNRS + DO 180 I=NORS+1,NRAT + XCOEF(I,J)=(0.0,0.0) + 180 CONTINUE + 185 CONTINUE + IF(IMPX.GE.10) THEN + WRITE(6,'(/40H SHIDIL: ZONE-DEPENDENT WEIGHTS IN GROUP,I5)') + 1 LLL + DO 190 I=1,NRAT + WRITE(6,'(9H TERM NB.,I2,3X,1P,1H(,2E12.4,1H),:,2H (,2E12.4, + 1 1H),2H (,2E12.4,1H),:,2H (,2E12.4,1H),:/(14X,1H(,2E12.4,1H), + 2 :,2H (,2E12.4,1H),:,2H (,2E12.4,1H),:,2H (,2E12.4,1H)))') + 3 I,(XCOEF(I,J),J=1,NBNRS) + 190 CONTINUE + WRITE(6,'(/36H SHIDIL: ZONE-DEPENDENT BASE POINTS:)') + DO 200 I=1,NRAT + WRITE(6,'(9H TERM NB.,I2,3X,1P,1H(,2E12.4,1H),:,2H (,2E12.4, + 1 1H),2H (,2E12.4,1H),:,2H (,2E12.4,1H),:/(14X,1H(,2E12.4,1H), + 2 :,2H (,2E12.4,1H),:,2H (,2E12.4,1H),:,2H (,2E12.4,1H)))') + 3 I,(XDENO(I,J),J=1,NBNRS) + 200 CONTINUE + ENDIF + IF(IMPX.GE.100) THEN + DO 225 K=1,NBNRS + WRITE(6,'(24H SHIDIL: RESONANT REGION,I4,1H:/14X,3HPIC,8X, + 1 3HFIT)') K + DO 220 IALP=1,NALPHA + E1=0.0 + DO 210 I=1,NRAT + DD=SIGX(IALP)*DIST(K)+XDENO(I,K) + E1=E1+XCOEF(I,K)/DD + 210 CONTINUE + WRITE(6,'(3X,I3,1P,2E11.3,F10.2,1H%)') IALP,PICX(IALP,K), + 1 DBLE(E1),100.0*(DBLE(E1)-PICX(IALP,K))/ABS(PICX(IALP,K)) + 220 CONTINUE + 225 CONTINUE + WRITE(6,'(22H SHIDIL: OVERALL FUEL:/14X,3HPXX,8X,3HFIT)') + GAR1=0.0 + DO 230 K=1,NBNRS + GAR1=GAR1+VST(K) + 230 CONTINUE + DO 260 IALP=1,NALPHA + GAR2=0.0 + E1=0.0 + DO 250 K=1,NBNRS + DO 240 I=1,NRAT + DD=SIGX(IALP)*DIST(K)+XDENO(I,K) + E1=E1+XCOEF(I,K)*VST(K)/(GAR1*DD) + 240 CONTINUE + GAR2=GAR2+PICX(IALP,K)*VST(K)/GAR1 + 250 CONTINUE + WRITE(6,'(3X,I3,1P,2E11.3,F10.2,1H%)') IALP,GAR2,DBLE(E1), + 1 100.0*(DBLE(E1)-GAR2)/ABS(GAR2) + 260 CONTINUE + ENDIF + RETURN + END diff --git a/Dragon/src/SHIDRV.f b/Dragon/src/SHIDRV.f new file mode 100644 index 0000000..be16d07 --- /dev/null +++ b/Dragon/src/SHIDRV.f @@ -0,0 +1,443 @@ +*DECK SHIDRV + SUBROUTINE SHIDRV (IPLIB,IPTRK,IFTRAK,LEVEL,NGRO,NBISO,NBMIX, + 1 NREG,NUN,CDOOR,NRES,IMPX,ISONRF,ISONAM,MIX,DEN,SN,SB,LSHI, + 2 IPHASE,IPROB,MAT,VOL,KEYFLX,LEAKSW,TITR,IGRMIN,IGRMAX,MAXX0, + 3 IBIEFF,IGC,ITRANZ,EPS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform a multidimensional self-shielding calculation in order to +* compute the dilution cross section of each resonant isotope present +* in the domain. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the internal microscopic cross section library +* (L_LIBRARY signature). +* IPTRK pointer to the tracking. (L_TRACK signature). +* IFTRAK unit number of the sequential binary tracking file. +* LEVEL type of self-shielding model (=0 original Stamm'ler model; +* =1 original Stamm'ler model with Nordheim approximation; +* =2 Stamm'ler model with Nordheim approximation and Riemann +* integration method). +* NGRO number of energy groups. +* NBISO number of isotopes present in the calculation domain. +* NBMIX number of mixtures in the macrolib. +* NREG number of regions. +* NUN number of unknowns in the flux or source vector in one +* energy group. +* CDOOR name of the geometry/solution module. +* NRES number of resonant mixtures. +* IMPX print flag. +* ISONRF reference name of isotopes. +* ISONAM alias name of isotopes. +* MIX mix number of each isotope (can be zero). +* DEN density of each isotope. +* LSHI resonant region number associated with each isotope. +* Infinite dilution will be assumed if LSHI(i)=0. +* IPHASE type of flux solution (=1 use a native flux solution door; +* =2 use collision probabilities). +* IPROB adjoint macrolib flag (=0 direct; =1 adjoint). +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX pointers of fluxes in unknown vector. +* LEAKSW leakage flag (=.TRUE. only if leakage is present on the outer +* surface). +* TITR title. +* IGRMIN first group where the self-shielding is applied. +* IGRMAX most thermal group where the self-shielding is applied. +* MAXX0 maximum number of self-shielding iterations. +* IBIEFF Livolant-Jeanpierre normalization flag (=1 to activate). +* IGC Goldstein-Cohen approximation flag (=1 to activate). +* The Goldstein-Cohen approximation is activated only in cases +* where they are available in the internal library. +* ITRANZ type of transport correction used in the self-shielding +* calculations. +* EPS convergence criterion for the self-shielding iterations. +* +*Parameters: input/output +* SN on input, estimate of the dilution cross section in each +* energy group of each isotope. A value of 1.0e10 is used +* for infinite dilution and; +* on output, computed dilution cross section in each energy +* group of each isotope. +* +*Parameters: output +* SB dilution cross section as used in Livolant-Jeanpierre +* normalization. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB,IPTRK + INTEGER IFTRAK,LEVEL,NGRO,NBISO,NBMIX,NREG,NUN,NRES,IMPX, + 1 ISONRF(3,NBISO),ISONAM(3,NBISO),MIX(NBISO),LSHI(NBISO), + 2 IPHASE,IPROB,MAT(NREG),KEYFLX(NREG),IGRMIN,IGRMAX,MAXX0,IBIEFF, + 3 IGC,ITRANZ + REAL DEN(NBISO),SN(NGRO,NBISO),SB(NGRO,NBISO),VOL(NREG),EPS + LOGICAL LEAKSW + CHARACTER CDOOR*12,TITR*72 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NALPHA=9,NRAT=(NALPHA+1)/2,NSTATE=40) + TYPE(C_PTR) JPLIB,KPLIB + INTEGER IPAR(NSTATE) + REAL TMPDAY(3) + CHARACTER HSMG*130 + LOGICAL START,BIEFF,LGC,LOGDO +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: LSHI2 + REAL, ALLOCATABLE, DIMENSION(:) :: SIGE + REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGT1,SIGT2,SIGT3 + LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASK,MASKL + LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: NOCONV +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(SIGT1(NBMIX,NGRO),SIGT2(NBMIX,NGRO),SIGT3(NBMIX,NGRO)) + ALLOCATE(MASK(NBMIX),MASKL(NGRO),NOCONV(NBMIX,NGRO)) +* + IF(IMPX.GE.5) THEN + WRITE (6,'(//23H SHIDRV: VALUES OF MAT:)') + I1=1 + KI=(NREG-1)/11+1 + DO 10 I=1,KI + I2=I1+10 + IF(I2.GT.NREG) I2=NREG + WRITE (6,340) (J,J=I1,I2) + WRITE (6,350) (MAT(J),J=I1,I2) + I1=I1+11 + 10 CONTINUE + WRITE (6,'(//)') + ENDIF +*---- +* RECOVER SELF SHIELDING DATA +*---- + IF(LEAKSW) CALL XABORT('SHIDRV: NEUTRON LEAKAGE IS FORBIDDEN.') + IF(CDOOR.EQ.' ') CALL XABORT('SHIDRV: THE GEOMETRY IS NOT YET ' + 1 //'DEFINED.') + BIEFF=(IBIEFF.EQ.1) + LGC=(IGC.EQ.1) +* + IF(IMPX.GT.0) THEN + WRITE (6,400) TITR,CDOOR + WRITE (6,'(25H STAMM''LER APPROXIMATION./)') + WRITE (6,405) IGRMIN,IGRMAX,MAXX0,IBIEFF,IGC,ITRANZ,LEVEL, + 1 IPHASE,EPS + ENDIF + IF(NRES.EQ.0) THEN + WRITE (6,410) + RETURN + ENDIF + DO 30 I=1,NREG + IF(MAT(I).GT.NBMIX) THEN + WRITE (HSMG,380) NBMIX + CALL XABORT(HSMG) + ENDIF + 30 CONTINUE + IGRMAX=MIN(IGRMAX,NGRO) + DO 55 LLL=1,NGRO + DO 40 I=1,NBISO + SB(LLL,I)=SN(LLL,I) + 40 CONTINUE + DO 50 IBM=1,NBMIX + NOCONV(IBM,LLL)=.FALSE. + 50 CONTINUE + 55 CONTINUE + CALL LCMSIX(IPLIB,'MACROLIB',1) + JPLIB=LCMGID(IPLIB,'GROUP') + DO 70 LLL=IGRMIN,IGRMAX + IF(IPROB.EQ.0) LL=LLL + IF(IPROB.EQ.1) LL=NGRO-LLL+1 + KPLIB=LCMGIL(JPLIB,LL) + CALL LCMGET(KPLIB,'NTOT0',SIGT2(1,LLL)) +*---- +* TRANSPORT CORRECTION +*---- + IF(ITRANZ.NE.0) THEN + CALL LCMGET(KPLIB,'TRANC',SIGT3(1,LLL)) + ELSE + SIGT3(:NBMIX,LLL)=0.0 + ENDIF +* + NOCONV(:NBMIX,LLL)=.TRUE. + 70 CONTINUE + CALL LCMSIX(IPLIB,' ',2) + IF(IMPX.GE.5) THEN + WRITE (6,'(/20H SHIBA INPUT VALUES:/)') + DO 80 L=IGRMIN,IGRMAX + WRITE(6,420) L + WRITE(6,460) (SN(L,J),J=1,NBISO) + WRITE(6,480) (SIGT2(IBM,L),IBM=1,NBMIX) + 80 CONTINUE + WRITE(6,490) + ENDIF +*---- +* ELIMINATE ISOTOPE ABSENT FROM GEOMETRY +*---- + DO IBM=1,NBMIX + DO IREG=1,NREG + IF(MAT(IREG).EQ.IBM) GO TO 85 + ENDDO + DO ISO=1,NBISO + IF(MIX(ISO).EQ.IBM) LSHI(ISO)=0 + ENDDO + 85 CONTINUE + ENDDO +*---- +* RECOMPUTE THE VECTOR LSHI +*---- + IF(LEVEL.EQ.0) THEN + NRES2=NRES + ELSE + ALLOCATE(LSHI2(NBISO)) + NRES1=0 + NRES2=0 + DO 90 ISO=1,NBISO + LSHI2(ISO)=0 + 90 CONTINUE + DO 140 INRS=1,NRES + 100 DENMAX=0.0 + KSOT=0 + DO 120 ISO=1,NBISO + IF(LSHI2(ISO).EQ.0) THEN + VOLISO=0.0 + DO 110 I=1,NREG + IF(MAT(I).EQ.MIX(ISO)) VOLISO=VOLISO+VOL(I) + 110 CONTINUE + IF((LSHI(ISO).EQ.INRS).AND.(DEN(ISO)*VOLISO.GT.DENMAX)) THEN + KSOT=ISO + DENMAX=DEN(ISO)*VOLISO + ENDIF + ENDIF + 120 CONTINUE + IF(KSOT.GT.0) THEN + NRES2=NRES2+1 + DO 130 ISO=1,NBISO + IF((ISONRF(1,ISO).EQ.ISONRF(1,KSOT)).AND. + 1 (ISONRF(2,ISO).EQ.ISONRF(2,KSOT)).AND. + 2 (ISONRF(3,ISO).EQ.ISONRF(3,KSOT)).AND. + 3 (LSHI(ISO).EQ.INRS)) LSHI2(ISO)=NRES2 + IF((ISONAM(1,ISO).EQ.ISONAM(1,KSOT)).AND. + 1 (ISONAM(2,ISO).EQ.ISONAM(2,KSOT)).AND. + 2 (LSHI(ISO).EQ.INRS)) LSHI2(ISO)=NRES2 + 130 CONTINUE + GO TO 100 + ENDIF + IF(NRES2.EQ.NRES1) THEN + WRITE(HSMG,'(43HSHIDRV: NO RESONANT ISOTOPES IN RESONANT RE, + 1 11HGION NUMBER,I4,5H (1).)') INRS + CALL XABORT(HSMG) + ENDIF + NRES1=NRES2 + 140 CONTINUE + ENDIF +*---- +* DETERMINE THE AMOUNT OF SCRATCH STORAGE REQUIRED +*---- + NBMIX2=0 + DO 150 ISO=1,NBISO + IF(LSHI(ISO).GT.0) NBMIX2=NBMIX2+1 + 150 CONTINUE +*---- +* ITERATION LOOP +*---- + IF(LEVEL.EQ.0) ALLOCATE(SIGE(NRES2*NGRO)) + NITER=0 + 160 NITER=NITER+1 + START=(NITER.EQ.1) + IF(IMPX.GT.5) WRITE (6,430) NITER + DO 175 L=IGRMIN,IGRMAX + DO 170 IBM=1,NBMIX + SIGT1(IBM,L)=SIGT2(IBM,L) + 170 CONTINUE + 175 CONTINUE + IF(LEVEL.EQ.0) THEN + CALL SHISN2 (IPLIB,IPTRK,IFTRAK,NGRO,NBISO,NBMIX,NREG,NUN, + 1 CDOOR,NRES,NBMIX2,IMPX,ISONAM,MIX,DEN,SN,SB,LSHI,IPHASE, + 2 MAT,VOL,KEYFLX,LEAKSW,TITR,START,SIGT2,SIGT3,NOCONV,BIEFF, + 3 LGC,SIGE) + ELSE + DO 210 INRS=1,NRES2 + NBNRS=0 + DO 200 IBM=1,NBMIX + LOGDO=.FALSE. + DO 180 I=1,NREG + LOGDO=LOGDO.OR.(MAT(I).EQ.IBM) + 180 CONTINUE + IF(.NOT.LOGDO) GO TO 200 + DO 190 ISO=1,NBISO + IF((MIX(ISO).EQ.IBM).AND.(LSHI2(ISO).EQ.INRS)) THEN + NBNRS=NBNRS+1 + GO TO 200 + ENDIF + 190 CONTINUE + 200 CONTINUE + IF(NBNRS.EQ.0) THEN + IF(START.AND.(IMPX.GE.1)) WRITE(6,385) 'SHIDRV',INRS + GO TO 210 + ELSE IF(START.AND.(NBNRS.GT.1).AND.(IMPX.GE.1)) THEN + WRITE (6,370) NBNRS,INRS + ENDIF + CALL SHISN3 (IPLIB,IPTRK,IFTRAK,LEVEL,NGRO,NBISO,NBMIX,NREG, + 1 NUN,CDOOR,INRS,NBNRS,IMPX,ISONAM,MIX,DEN,SN,SB,LSHI2,IPHASE, + 2 MAT,VOL,KEYFLX,LEAKSW,TITR,START,SIGT2,SIGT3,NOCONV,BIEFF,LGC) + 210 CONTINUE + ENDIF + ZZMAX=0.0 + LNGRO=0 + ICOUNT=0 + DO 240 L=IGRMIN,IGRMAX + ZNORM=0.0 + DO 220 IBM=1,NBMIX + ZNORM=MAX(ZNORM,ABS(SIGT2(IBM,L))) + 220 CONTINUE + ZMAX=0.0 + MASKL(L)=.FALSE. + DO 230 IBM=1,NBMIX + YMAX=ABS(SIGT1(IBM,L)-SIGT2(IBM,L))/ZNORM + ZMAX=MAX(ZMAX,YMAX) + NOCONV(IBM,L)=(NOCONV(IBM,L).AND.(YMAX.GT.EPS)) + MASKL(L)=MASKL(L).OR.NOCONV(IBM,L) + 230 CONTINUE + IF(MASKL(L)) ICOUNT=ICOUNT+1 + IF(ZMAX.GT.ZZMAX) THEN + ZZMAX=ZMAX + LNGRO=L + ENDIF + 240 CONTINUE + IF(IMPX.GE.2) WRITE (6,440) NITER,ICOUNT,ZZMAX,LNGRO + IF(IMPX.GE.10) THEN + WRITE (6,450) (L,MASKL(L),L=IGRMIN,IGRMAX) + WRITE (6,'(/31H INPUT MACROSCOPIC X-S IN GROUP,I4,1H:)') LNGRO + WRITE (6,'(1X,1P,10E12.4)') (SIGT1(IBM,LNGRO),IBM=1,NBMIX) + WRITE (6,'(/32H OUTPUT MACROSCOPIC X-S IN GROUP,I4,1H:)') LNGRO + WRITE (6,'(1X,1P,10E12.4)') (SIGT2(IBM,LNGRO),IBM=1,NBMIX) + ENDIF + IF(IMPX.GT.3) THEN + WRITE (6,'(/29H OUTPUT DILUTION X-S IN GROUP,I4,1H:)') LNGRO + WRITE (6,'(1X,1P,10E12.4)') (SN(LNGRO,J),J=1,NBISO) + ENDIF + IF((NITER.GE.MAXX0).AND.(ICOUNT.GT.0)) THEN + WRITE (6,390) + GO TO 250 + ELSE IF(ICOUNT.GT.0) THEN + GO TO 160 + ENDIF +*---- +* CONVERGENCE IS OBTAINED +*---- + 250 IF(LEVEL.GT.0) DEALLOCATE(LSHI2) + IF(LEVEL.EQ.0) DEALLOCATE(SIGE) + IF(IMPX.GE.3) THEN + WRITE (6,'(/21H SHIBA OUTPUT VALUES:/)') + DO 260 L=IGRMIN,IGRMAX + WRITE(6,420) L + WRITE(6,460) (SN(L,J),J=1,NBISO) + IF(BIEFF) WRITE(6,470) (SB(L,J),J=1,NBISO) + IF(IMPX.GE.5) WRITE(6,480) (SIGT2(IBM,L),IBM=1,NBMIX) + 260 CONTINUE + WRITE(6,490) + ENDIF +*---- +* COMPUTE THE NEW SELF-SHIELDED MACROSCOPIC CROSS SECTIONS +*---- + MASKL(:NGRO)=.FALSE. + DO 280 LLL=IGRMIN,IGRMAX + MASKL(LLL)=.TRUE. + 280 CONTINUE + DO 300 IBM=1,NBMIX + DO 290 ISO=1,NBISO + MASK(IBM)=(MIX(ISO).EQ.IBM).AND.(LSHI(ISO).GT.0) + IF(MASK(IBM)) GO TO 300 + 290 CONTINUE + 300 CONTINUE + ITSTMP=0 + TMPDAY(1)=0.0 + TMPDAY(2)=0.0 + TMPDAY(3)=0.0 + CALL LIBMIX(IPLIB,NBMIX,NGRO,NBISO,ISONAM,MIX,DEN,MASK,MASKL, + > ITSTMP,TMPDAY) + IF(IMPX.GT.0) WRITE (6,500) NITER,ZZMAX +*---- +* STORE THE GENERAL SHIBA PARAMETERS +*---- + IPAR(:NSTATE)=0 + IPAR(1)=IGRMIN + IPAR(2)=IGRMAX + IPAR(3)=MAXX0 + IPAR(4)=IBIEFF + IPAR(5)=IGC + IPAR(6)=ITRANZ + IPAR(7)=LEVEL + IPAR(8)=IPHASE + CALL LCMSIX(IPLIB,'SHIBA',1) + CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,IPAR) + CALL LCMPUT(IPLIB,'EPS-SHIBA',1,2,EPS) + CALL LCMSIX(IPLIB,' ',2) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(NOCONV,MASKL,MASK) + DEALLOCATE(SIGT3,SIGT2,SIGT1) + RETURN +* + 340 FORMAT(//26H VOLUME NB. :,11(I5,3X,1HI)) + 350 FORMAT( 26H MIXTURE (MAT) :,11(I5,3X,1HI)) + 370 FORMAT(/42H SHIDRV: USE THE NORDHEIM MODEL TO PROCESS,I3,5H RESO, + 1 39HNANT MIXTURES IN RESONANT REGION NUMBER,I3,1H.) + 380 FORMAT(32HSHIDRV: INVALID VALUE OF NBMIX (,I5,2H).) + 385 FORMAT(A6,1X,': RESONANT REGION =',I10,1X,'NOT USED.') + 390 FORMAT(/1X,61(1H*)/42H SHIDRV: MAXIMUM NUMBER OF SELF-SHIELDING , + 1 20HITERATIONS EXCEEDED./1X,61(1H*)/) + 400 FORMAT( + > 1X,'SHIBA MULTIDIMENSIONAL SELF-SHIELDING CALCULATION', + > 1X,'-> A. HEBERT'/ + > 1X,A72/ + > 1X,'COLLISION PROBABILITY MODULE: ',A12/) + 405 FORMAT(/8H OPTIONS/8H -------/ + 1 7H IGRMIN,I8,27H (FIRST GROUP TO PROCESS)/ + 2 7H IGRMAX,I8,34H (MOST THERMAL GROUP TO PROCESS)/ + 3 7H MAXX0 ,I8,33H (MAXIMUM NUMBER OF ITERATIONS)/ + 4 7H IBIEFF,I8,46H (=1: USE LIVOLANT-JEANPIERRE NORMALIZATION)/ + 5 7H IGC ,I8,42H (=1: USE GOLDSTEIN-COHEN APPROXIMATION)/ + 6 7H ITRANZ,I8,45H (0=NO TRANSPORT CORRECTION/1=APOLLO TYPE/2, + 7 57H=RECOVER FROM LIBRARY/3=WIMS-D TYPE/4=LEAKAGE CORRECTION)/ + 8 7H LEVEL ,I8,46H (=0: STAMM'LER; =1: STAMM'LER/NORDHEIM; =2:, + 9 18H RIEMANN/NORDHEIM)/ + 1 7H IPHASE,I8,37H (=1: NATIVE ASSEMBLY; =2: USE PIJ)/ + 2 7H EPS ,1P,E8.1,22H (STOPING CRITERION)/) + 410 FORMAT(/52H SHIDRV: THERE IS NO REQUEST TO PROCESS ANY RESONANT, + 1 9H ISOTOPE./) + 420 FORMAT(/1X,131(1H-)//8H GROUP =,I4/) + 430 FORMAT(/40H PERFORMING SELF-SHIELDING ITERATION NB.,I5) + 440 FORMAT(/27H SELF-SHIELDING ITERATION =,I4,5X,14HNUMBER OF NON , + 1 18HCONVERGED GROUPS =,I4,5X,7HERROR =,1P,E13.4,0P,9H IN GROUP, + 2 I4/) + 450 FORMAT(7H MASKL(,I3,2H)=,L1,:,8H MASKL(,I3,2H)=,L1,:,8H MASKL(, + 1 I3,2H)=,L1,:,8H MASKL(,I3,2H)=,L1,:,8H MASKL(,I3,2H)=,L1,:, + 2 8H MASKL(,I3,2H)=,L1,:,8H MASKL(,I3,2H)=,L1,:,8H MASKL(,I3, + 3 2H)=,L1,:,8H MASKL(,I3,2H)=,L1) + 460 FORMAT(/37H MICROSCOPIC DILUTION CROSS SECTIONS:/(9X,1P,11E11.3)) + 470 FORMAT(/53H LIVOLANT AND JEANPIERRE MICROSCOPIC DILUTION CROSS S, + 1 8HECTIONS:/(9X,1P,11E11.3)) + 480 FORMAT(/34H MACROSCOPIC TOTAL CROSS SECTIONS:/(9X,1P,11E11.3)) + 490 FORMAT(/1X,131(1H-)/) + 500 FORMAT(/41H CONVERGENCE REACHED AT SHIBA ITERATION =,I4,7H ERROR, + 1 2H =,1P,E11.3/) + END diff --git a/Dragon/src/SHIDST.f b/Dragon/src/SHIDST.f new file mode 100644 index 0000000..7dda8a2 --- /dev/null +++ b/Dragon/src/SHIDST.f @@ -0,0 +1,199 @@ +*DECK SHIDST + SUBROUTINE SHIDST (IPSYS,NPSYS,IPTRK,IFTRAK,CDOOR,IMPX,NBM,NREG, + 1 NUN,NGRO,IPHASE,MAT,VOL,KEYFLX,LEAKSW,IRES,SIG0,SIG1,SIG2,TITR, + 2 FUNKNO,DILAV) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of escape probability information. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPSYS pointer to the pij (L_PIJ signature). +* NPSYS index array pointing to the IPSYS list component corresponding +* to each energy group. Set to zero if a group is not to be +* processed. Usually, NPSYS(I)=I. +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK unit number of the sequential binary tracking file. +* CDOOR name of the geometry/solution module. +* IMPX print flag (equal to zero for no print). +* NBM number of mixtures. +* NREG total number of merged blocks for which specific values +* of the neutron flux and reactions rates are required. +* NUN number of unknowns in the flux or source vector in one +* energy group. +* NGRO number of energy groups. +* IPHASE type of flux solution (=1 use a native flux solution door; +* =2 use collision probabilities). +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX pointers of fluxes in unknown vector. +* LEAKSW leakage flag (.TRUE. only if leakage is present on the outer +* surface). +* IRES resonant mixture number assigned to each mixture. +* SIG0 total macroscopic cross sections of the resonant materials +* in each mixture. +* SIG1 total macroscopic cross sections of the light materials in +* each mixture. +* SIG2 transport correction in each mixture. +* TITR title. +* +*Parameters: output +* FUNKNO information used for computing escape information for the +* Nordheim method. +* DILAV average dilution. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE DOORS_MOD +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSYS,IPTRK + CHARACTER CDOOR*12,TITR*72 + LOGICAL LEAKSW + INTEGER NPSYS(NGRO),IFTRAK,IMPX,NBM,NREG,NUN,NGRO,IPHASE, + 1 MAT(NREG),KEYFLX(NREG),IRES(NBM) + REAL VOL(NREG),SIG0(NBM,NGRO),SIG1(NBM,NGRO),SIG2(NBM,NGRO), + 1 FUNKNO(NUN,NGRO),DILAV(NGRO) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPSYS,KPSYS,IPMACR,IPSOU + DOUBLE PRECISION TOT1,TOT2 + LOGICAL LNORM,LEXAC,REBFLG + REAL, ALLOCATABLE, DIMENSION(:) :: SSIGT,SSIGW,SIGG + REAL, ALLOCATABLE, DIMENSION(:,:) :: SUN,FUN + INTEGER NALBP +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(SSIGT(0:NBM),SSIGW(0:NBM),SIGG(0:NBM)) +*---- +* INITIALIZATIONS. +*---- + NALBP=0 + ISTRM=1 + NANI=1 + NW=0 + IPIJK=1 + ITPIJ=1 + KNORM=1 + LNORM=.FALSE. + IDIR=0 + LEXAC=.FALSE. + JPSYS=LCMLID(IPSYS,'GROUP',NGRO) +*---- +* SELECT THE MACROSCOPIC CROSS SECTIONS. +*---- + SSIGT(0)=0.0 + SSIGW(0)=0.0 + DO 20 LLL=1,NGRO + IF(NPSYS(LLL).NE.0) THEN + DO 10 IBM=1,NBM + SSIGT(IBM)=SIG0(IBM,LLL)+SIG1(IBM,LLL)-SIG2(IBM,LLL) + SSIGW(IBM)=-SIG2(IBM,LLL) + 10 CONTINUE + KPSYS=LCMDIL(JPSYS,LLL) + CALL LCMPUT(KPSYS,'DRAGON-TXSC',NBM+1,2,SSIGT(0)) + CALL LCMPUT(KPSYS,'DRAGON-S0XSC',NBM+1,2,SSIGW(0)) + ENDIF + 20 CONTINUE +*---- +* ASSEMBLY MATRIX OR REDUCED COLLISION PROBABILITIES CALCULATION. +*---- + IF(IPHASE.EQ.1) THEN +* USE A NATIVE DOOR. + CALL DOORAV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IMPX,NGRO,NREG, + 1 NBM,NANI,NW,MAT,VOL,KNORM,LEAKSW,TITR,NALBP,ISTRM) + ELSE IF(IPHASE.EQ.2) THEN +* USE A COLLISION PROBABILITY DOOR. + CALL DOORPV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IMPX,NGRO,NREG, + 1 NBM,NANI,MAT,VOL,KNORM,IPIJK,LEAKSW,ITPIJ,LNORM,TITR,NALBP) + ENDIF +*---- +* ALLOCATE MEMORY. +*---- + ALLOCATE(SUN(NUN,NGRO),FUN(NUN,NGRO)) +*---- +* SOLVE FOR THE FLUX AND SET UP VECTORS DILAV AND FUNKNO. +*---- + SUN(:NUN,:NGRO)=0.0 + DO 40 LLL=1,NGRO + IF(NPSYS(LLL).NE.0) THEN + SIGG(0:NBM)=0.0 + DO 30 IBM=1,NBM + IF(IRES(IBM).GT.0) SIGG(IBM)=SIG0(IBM,LLL) + 30 CONTINUE + CALL DOORS(CDOOR,IPTRK,NBM,0,NUN,SIGG,SUN(1,LLL)) + ENDIF + 40 CONTINUE + CALL LCMLEN(IPSYS,'FLUX1',ILON1,ITYLCM) + IF(ILON1.EQ.NUN*NGRO) THEN + CALL LCMGET(IPSYS,'FLUX1',FUNKNO) + ELSE + FUNKNO(:NUN,:NGRO)=0.0 + ENDIF + IPMACR=C_NULL_PTR + IPSOU=C_NULL_PTR + REBFLG=.FALSE. + CALL DOORFV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IMPX,NGRO,NBM,IDIR, + 1 NREG,NUN,IPHASE,LEXAC,MAT,VOL,KEYFLX,TITR,SUN,FUNKNO(1,1),IPMACR, + 2 IPSOU,REBFLG) + CALL LCMPUT(IPSYS,'FLUX1',NUN*NGRO,2,FUNKNO) +* + SUN(:NUN,:NGRO)=0.0 + DO 60 LLL=1,NGRO + IF(NPSYS(LLL).NE.0) THEN + SIGG(0:NBM)=0.0 + DO 50 IBM=1,NBM + IF(IRES(IBM).GT.0) SIGG(IBM)=1.0 + 50 CONTINUE + CALL DOORS(CDOOR,IPTRK,NBM,0,NUN,SIGG,SUN(1,LLL)) + ENDIF + 60 CONTINUE + CALL LCMLEN(IPSYS,'FLUX2',ILON2,ITYLCM) + IF(ILON2.EQ.NUN*NGRO) THEN + CALL LCMGET(IPSYS,'FLUX2',FUN) + ELSE + FUN(:NUN,:NGRO)=0.0 + ENDIF + IPMACR=C_NULL_PTR + IPSOU=C_NULL_PTR + REBFLG=.FALSE. + CALL DOORFV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IMPX,NGRO,NBM,IDIR, + 1 NREG,NUN,IPHASE,LEXAC,MAT,VOL,KEYFLX,TITR,SUN,FUN(1,1),IPMACR, + 2 IPSOU,REBFLG) + CALL LCMPUT(IPSYS,'FLUX2',NUN*NGRO,2,FUN) + DO 80 LLL=1,NGRO + IF(NPSYS(LLL).NE.0) THEN + TOT1=0.0D0 + TOT2=0.0D0 + DO 70 I=1,NREG + IBM=MAT(I) + IF(IBM.EQ.0) GO TO 70 + IF(IRES(IBM).GT.0) THEN + TOT2=TOT2+(1.0D0-FUNKNO(KEYFLX(I),LLL))*VOL(I) + TOT1=TOT1+FUN(KEYFLX(I),LLL)*VOL(I) + ENDIF + 70 CONTINUE + DILAV(LLL)=REAL(TOT2/TOT1) + ENDIF + 80 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SUN,FUN) + DEALLOCATE(SIGG,SSIGW,SSIGT) + RETURN + END diff --git a/Dragon/src/SHIEQU.f b/Dragon/src/SHIEQU.f new file mode 100644 index 0000000..f36d1bc --- /dev/null +++ b/Dragon/src/SHIEQU.f @@ -0,0 +1,244 @@ +*DECK SHIEQU + SUBROUTINE SHIEQU(IPLIB,LEVEL,NGRO,NBISO,NBM,NBNRS,NRAT,MIX, + 1 ISONAM,NOCONV,ISONR,GC,COEF,DENOM,XCOEF,XDENO,DEN,IMPX,SN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the equivalent dilution. +* +*Copyright: +* Copyright (C) 2004 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the internal microscopic cross section library +* (L_LIBRARY signature). +* LEVEL type of approximation (=1 use original Stamm'ler and +* Nordheim approximations; =2 use Riemann integration method +* with Nordheim approximation). +* NGRO number of energy groups. +* NBISO number of isotopes present in the calculation domain. +* NBM number of mixtures in the macrolib. +* NBNRS number of totally correlated resonant regions. +* NRAT number of terms in the rational pij expansion. +* MIX mix number of each isotope. +* ISONAM alias name of isotopes. +* NOCONV mixture convergence flag (.TRUE. if mixture IBM +* is not converged in group L). +* ISONR resonant isotope indices. +* GC Goldstein-Cohen parameters. +* COEF zone-independent weights. +* DENOM zone-independent base points. +* XCOEF zone-dependent weights. +* XDENO zone-dependent base points. +* DEN isotopic number density. +* IMPX print flag (equal to zero for no print). +* +*Parameters: output +* SN equivalent dilution. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT DOUBLE PRECISION(A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + LOGICAL NOCONV(NBM,NGRO) + INTEGER LEVEL,NGRO,NBISO,NBM,NBNRS,NRAT,MIX(NBISO), + 1 ISONAM(3,NBISO),ISONR(NBNRS),IMPX + REAL GC(NGRO,NBNRS),DEN(NBISO),SN(NGRO,NBISO) + COMPLEX COEF(NRAT,NGRO),DENOM(NRAT,NGRO) + COMPLEX*16 XCOEF(NRAT,NBNRS,NGRO),XDENO(NRAT,NBNRS,NGRO) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(MAXRAT=9) + TYPE(C_PTR) JPLIB,KPLIB + LOGICAL LD + CHARACTER HNAMIS*12,HSMG*131 + COMPLEX*16 EAV,TTT,CBS(MAXRAT) + INTEGER, ALLOCATABLE, DIMENSION(:) :: NFS + REAL, ALLOCATABLE, DIMENSION(:) :: EBIN,TBIN,SBIN +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NFS(NGRO)) +* + IF(NRAT.GT.MAXRAT) CALL XABORT('SHIEQU: MAXRAT OVERFLOW.') + JPLIB=LCMGID(IPLIB,'ISOTOPESLIST') + DO 200 IRS=1,NBNRS + ISO=ISONR(IRS) + KPLIB=LCMGIL(JPLIB,ISO) ! set ISO-th isotope + WRITE(HNAMIS,'(3A4)') (ISONAM(I0,ISO),I0=1,3) + CALL LCMLEN(KPLIB,'BIN-NFS',LENBIN,ITYLCM) + IF((LENBIN.GT.0).AND.(LEVEL.EQ.2)) THEN + CALL LCMGET(KPLIB,'BIN-NFS',NFS) + LBIN=0 + DO 10 IGRP=1,NGRO + LBIN=LBIN+NFS(IGRP) + 10 CONTINUE + ALLOCATE(EBIN(LBIN+1),TBIN(LBIN),SBIN(LBIN)) + CALL LCMGET(KPLIB,'BIN-ENERGY',EBIN) + CALL LCMGET(KPLIB,'BIN-NTOT0',TBIN) + CALL LCMGET(KPLIB,'BIN-SIGS00',SBIN) + ELSE + NFS(:NGRO)=0 + ENDIF + LBIN=0 + DO 110 IGRP=1,NGRO + IF(NOCONV(MIX(ISO),IGRP)) THEN + EAV=0.0 + IF(NFS(IGRP).GT.0) THEN +* RIEMANN INTEGRATION METHOD WITH NEWTON-RAPHSON ACCELERATION. + IF(IMPX.GE.10) THEN + WRITE(6,'(/17H SHIEQU: WEIGHTS:)') + WRITE(6,290) IGRP,(COEF(I,IGRP),I=1,NRAT) + WRITE(6,'(/21H SHIEQU: BASE POINTS:)') + WRITE(6,290) IGRP,(DENOM(I,IGRP),I=1,NRAT) + ENDIF + DO 20 I=1,NRAT + EAV=EAV+COEF(I,IGRP)*SQRT(DENOM(I,IGRP)) + 20 CONTINUE + SNI=(DBLE(EAV)**2)/DEN(ISO) + UG=0.0 + BA=0.0 + BS=0.0 + DO 30 IGF=1,NFS(IGRP) + DELM=LOG(EBIN(LBIN+IGF)/EBIN(LBIN+IGF+1)) + UG=UG+DELM + SIGA=MAX(0.0,TBIN(LBIN+IGF)-SBIN(LBIN+IGF)) + SIGS=GC(IGRP,IRS)*MAX(0.0,SBIN(LBIN+IGF)) + BA=BA+DELM*SIGA/(SIGA+SIGS+SNI) + BS=BS+DELM*SIGS/(SIGA+SIGS+SNI) + 30 CONTINUE + BA=BA/UG + BS=BS/UG + ZCAL=SNI*BA/(1.0D0-BS) + DO 50 I=1,NRAT + CBS(I)=0.0 + IF(XCOEF(I,IRS,IGRP).EQ.0.0) GO TO 50 + EAV=XDENO(I,IRS,IGRP)/DEN(ISO) + DO 40 IGF=1,NFS(IGRP) + DELM=LOG(EBIN(LBIN+IGF)/EBIN(LBIN+IGF+1)) + SIGA=MAX(0.0,TBIN(LBIN+IGF)-SBIN(LBIN+IGF)) + SIGS=GC(IGRP,IRS)*MAX(0.0,SBIN(LBIN+IGF)) + CBS(I)=CBS(I)+DELM*SIGS/(SIGA+SIGS+EAV) + 40 CONTINUE + CBS(I)=CBS(I)/UG + CBS(I)=1.0D0/(1.0D0-CBS(I)) + 50 CONTINUE + TAUXA=0.0D0 + DO 60 IGF=1,NFS(IGRP) + DELM=LOG(EBIN(LBIN+IGF)/EBIN(LBIN+IGF+1)) + SIGA=MAX(0.0,TBIN(LBIN+IGF)-SBIN(LBIN+IGF)) + SIGS=GC(IGRP,IRS)*MAX(0.0,SBIN(LBIN+IGF)) + TTT=0.0D0 + DO 55 I=1,NRAT + IF(XCOEF(I,IRS,IGRP).EQ.0.0) GO TO 55 + EAV=XDENO(I,IRS,IGRP)/DEN(ISO) + TTT=TTT+XCOEF(I,IRS,IGRP)*EAV*CBS(I)/(SIGA+SIGS+EAV) + 55 CONTINUE + TAUXA=TAUXA+DELM*SIGA*MAX(0.0D0,DBLE(TTT)) + 60 CONTINUE + IF(TAUXA.EQ.0.0) THEN + SNI=1.0E10 + GO TO 90 + ENDIF + TAUXA=TAUXA/UG + ITER=0 + 70 ITER=ITER+1 + IF(IMPX.GE.10) THEN + WRITE(6,'(15H SHIEQU: GROUP=,I4,11H ITERATION=,I3, + 1 10H DILUTION=,1P,E11.4,16H REFERENCE RATE=,E11.4, + 2 13H APPROXIMATE=,E11.4)') IGRP,ITER,SNI,TAUXA,ZCAL + ENDIF + IF(ABS(TAUXA-ZCAL).LE.1.0D-5*ABS(TAUXA)) GO TO 90 + IF(ITER.GT.20) THEN + WRITE(6,'(15H SHIEQU: GROUP=,I4,10H DILUTION=,1P,E11.4, + 1 16H REFERENCE RATE=,E11.4,13H APPROXIMATE=,E11.4, + 2 9H ISOTOPE=,A12,1H.)') IGRP,SNI,TAUXA,ZCAL,HNAMIS + IF(ABS(TAUXA-ZCAL).LE.5.0E-2*ABS(TAUXA)) THEN + WRITE(6,'(24H SHIEQU: *** WARNING ***)') + GO TO 90 + ENDIF + CALL XABORT('SHIEQU: CONVERGENCE FAILURE.') + ENDIF + BA=0.0 + BS=0.0 + DBA=0.0 + DBS=0.0 + DO 80 IGF=1,NFS(IGRP) + DELM=LOG(EBIN(LBIN+IGF)/EBIN(LBIN+IGF+1)) + SIGA=MAX(0.0,TBIN(LBIN+IGF)-SBIN(LBIN+IGF)) + SIGS=GC(IGRP,IRS)*MAX(0.0,SBIN(LBIN+IGF)) + BA=BA+DELM*SIGA/(SIGA+SIGS+SNI) + BS=BS+DELM*SIGS/(SIGA+SIGS+SNI) + DBA=DBA-DELM*SIGA/(SIGA+SIGS+SNI)**2 + DBS=DBS-DELM*SIGS/(SIGA+SIGS+SNI)**2 + 80 CONTINUE + BA=BA/UG + BS=BS/UG + DBA=DBA/UG + DBS=DBS/UG + ZCAL=SNI*BA/(1.0D0-BS) + DZCAL=BA/(1.0D0-BS)+SNI*DBA/(1.0D0-BS)+SNI*BA*DBS/ + 1 (1.0D0-BS)**2 + IF(DZCAL.LT.1.0D-15*ZCAL) GO TO 90 + SNI=MAX(1.0D0,SNI-REAL((ZCAL-TAUXA)/DZCAL)) + IF(SNI.GE.1.0E10) THEN + SNI=1.0E10 + GO TO 90 + ENDIF + GO TO 70 + 90 IF(IMPX.GE.5) THEN + WRITE(6,'(16H SHIEQU: REGION=,I3,7H GROUP=,I5,7H ISOTOP, + 1 3HE='',A12,19H'' NB.OF ITERATIONS=,I3,1H.)') IRS,IGRP, + 2 HNAMIS,ITER + ENDIF + ELSE +* ORIGINAL STAMM'LER APPROXIMATION. + DO 100 I=1,NRAT + EAV=EAV+XCOEF(I,IRS,IGRP)*SQRT(XDENO(I,IRS,IGRP)) + 100 CONTINUE + SNI=MAX(1.0D0,(DBLE(EAV)**2)/DEN(ISO)) + ENDIF + SN(IGRP,ISO)=REAL(SNI) + IF(SN(IGRP,ISO).LE.0.0) THEN + WRITE (HSMG,300) HNAMIS,SN(IGRP,ISO),IGRP + CALL XABORT(HSMG) + ENDIF + ENDIF + LBIN=LBIN+NFS(IGRP) + 110 CONTINUE + IF((LENBIN.GT.0).AND.(LEVEL.EQ.2)) THEN + DEALLOCATE(SBIN,TBIN,EBIN) + ENDIF + IF(IMPX.GE.5) THEN + LD=.FALSE. + DO 120 IGRP=1,NGRO + LD=LD.OR.NOCONV(MIX(ISO),IGRP) + 120 CONTINUE + IF(LD) WRITE(6,310) HNAMIS,(SN(IGRP,ISO),IGRP=1,NGRO) + ENDIF + 200 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(NFS) + RETURN +* + 290 FORMAT(10H GROUP NB.,I4,3X,1P,1H(,2E12.4,1H),:,2H (,2E12.4,1H), + 1 2H (,2E12.4,1H),:,2H (,2E12.4,1H),:/(15X,1H(,2E12.4,1H),:,2H (, + 2 2E12.4,1H),:,2H (,2E12.4,1H),:,2H (,2E12.4,1H))) + 300 FORMAT(30HSHIEQU: THE RESONANT ISOTOPE ',A12,16H' HAS A NEGATIVE, + 1 25H DILUTION CROSS-SECTION (,1P,E14.4,0P,10H) IN GROUP,I4,1H.) + 310 FORMAT(/31H SHIEQU: DILUTIONS OF ISOTOPE ',A12,2H':/(1P,10E12.4)) + END diff --git a/Dragon/src/SHIRAT.f b/Dragon/src/SHIRAT.f new file mode 100644 index 0000000..7388478 --- /dev/null +++ b/Dragon/src/SHIRAT.f @@ -0,0 +1,222 @@ +*DECK SHIRAT + SUBROUTINE SHIRAT(IMPX,NRAT,SIGX,DILUT,IGRP,SA,COEF,DENOM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the NRAT-terms rational approximation coefficients for +* the SIGX-dependent fuel-to-fuel reduced collision probability in a +* closed cell. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IMPX print flag (no print if IMPX.lt.10). +* NRAT number of terms in the pij rational approximation. +* SIGX interpolation values for the resonant cross section of +* the heavy nuclide. +* DILUT interpolated macroscopic escape cross sections corresponding +* to SIGX values. +* IGRP group index. +* +*Parameters: output +* SA asymptotic macroscopic escape cross section. +* COEF numerator coefficients for the rational approximation +* of fuel-to-fuel reduced collision probability. +* DENOM denominator coefficients for the rational approximation +* of fuel-to-fuel reduced collision probability. +* +*----------------------------------------------------------------------- +* + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IMPX,NRAT,IGRP + REAL SIGX(2*NRAT-1),DILUT(2*NRAT-1),SA + COMPLEX COEF(NRAT),DENOM(NRAT) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NMAX=11,EPSRID=1.0D-5,NORIN=(NMAX-1)/2) + COMPLEX*16 E1,E2,E3,AAA,BBB,SQ1,TEST,D,E,SQRTM3,SIGXI,DD, + 1 CDENOM(NORIN+1) + PARAMETER (SQRTM3=(0.0,1.73205080756888)) + DOUBLE PRECISION A(0:NORIN),B(0:NORIN),C(0:NORIN+1) + CHARACTER HSMG*131 + REAL EPS,PREC + COMPLEX EAV + LOGICAL LFAIL +* + IF(2*NRAT-1.GT.NMAX) CALL XABORT('SHIRAT: INCREASE NMAX.') + DO 10 I=2,NRAT + COEF(I)=0.0 + DENOM(I)=1.0 + 10 CONTINUE + EPS=0.0 + DO 15 I=1,2*NRAT-1,2 + EPS=MAX(EPS,ABS(DILUT(I)-DILUT(NRAT))/ABS(DILUT(I))) + 15 CONTINUE + IF(EPS.LT.5.0E-4) THEN + SA=DILUT(NRAT) + COEF(1)=1.0 + DENOM(1)=DILUT(NRAT) + IF(IMPX.GE.10) WRITE (6,110) SA + RETURN + ENDIF +* + CALL ALPLSF(1,2*NRAT-1,SIGX,DILUT,EPSRID,.FALSE.,NOR,A,B,PREC) + SA=REAL(A(NOR)) + QQ=A(1)+B(0) + RR=A(0) + IF(NOR.EQ.0) THEN +* 1-TERM RATIONAL APPROXIMATION. + COEF(1)=1.0 + DENOM(1)=CMPLX(A(0),KIND=KIND(DENOM)) + ELSE IF(NOR.EQ.1) THEN +* 2-TERMS RATIONAL APPROXIMATION. + AAA=QQ*QQ-4.0D0*RR + AAA=SQRT(AAA) + E1=0.5D0*(QQ+AAA) + E2=0.5D0*(QQ-AAA) + IF(ABS(DBLE(E1*E2)-RR).GT.1.0E-3*ABS(RR)) THEN + WRITE (HSMG,'(42HSHIRAT: INTERPOLATION ALGORITHM FAILURE 1,, + 1 6H COEF=,1P,3E11.3)') QQ,RR,DBLE(E1*E2) + CALL XABORT(HSMG) + ENDIF +* + COEF(1)=CMPLX((B(0)-E1)/(E2-E1)) + COEF(2)=CMPLX((B(0)-E2)/(E1-E2)) + DENOM(1)=CMPLX(E1) + DENOM(2)=CMPLX(E2) + ELSE IF(NOR.EQ.2) THEN +* 3-TERMS RATIONAL APPROXIMATION. + PP=A(2)+B(1) + AA=(3.0D0*QQ-PP**2)/3.0D0 + BB=(2.0D0*PP**3-9.0D0*PP*QQ+27.0D0*RR)/27.0D0 + SQ1=BB**2/4.0D0+AA**3/27.0D0 + TEST=BB/2.0D0-SQRT(SQ1) + IF(DBLE(TEST).EQ.0.0) THEN + AAA=0.0D0 + ELSE IF(DBLE(TEST).GT.0.0) THEN + AAA=-(TEST)**(1.0D0/3.0D0) + ELSE + AAA=(-TEST)**(1.0D0/3.0D0) + ENDIF + TEST=BB/2.0D0+SQRT(SQ1) + IF(DBLE(TEST).EQ.0.0) THEN + BBB=0.0D0 + ELSE IF(DBLE(TEST).GT.0.0) THEN + BBB=-(TEST)**(1.0D0/3.0D0) + ELSE + BBB=(-TEST)**(1.0D0/3.0D0) + ENDIF + E1=-(AAA+BBB-PP/3.0D0) + E2=-(-(AAA+BBB)/2.0D0+(AAA-BBB)*SQRTM3/2.0D0-PP/3.0D0) + E3=-(-(AAA+BBB)/2.0D0-(AAA-BBB)*SQRTM3/2.0D0-PP/3.0D0) + IF(ABS(DBLE(E1*E2*E3)-RR).GT.1.0E-3*ABS(RR)) THEN + WRITE (HSMG,'(42HSHIRAT: INTERPOLATION ALGORITHM FAILURE 2,, + 1 6H COEF=,1P,4E11.3)') PP,QQ,RR,DBLE(E1*E2*E3) + CALL XABORT(HSMG) + ENDIF +* + SQ1=(0.5D0*B(1))**2-B(0) + D=0.5D0*B(1)+SQRT(SQ1) + E=0.5D0*B(1)-SQRT(SQ1) + COEF(1)=CMPLX((D-E1)*(E-E1)/(E2-E1)/(E3-E1)) + COEF(2)=CMPLX((D-E2)*(E-E2)/(E1-E2)/(E3-E2)) + COEF(3)=CMPLX((D-E3)*(E-E3)/(E1-E3)/(E2-E3)) + DENOM(1)=CMPLX(E1) + DENOM(2)=CMPLX(E2) + DENOM(3)=CMPLX(E3) + ELSE IF(NOR.GE.3) THEN +* (NOR+1) TERMS RATIONAL APPROXIMATION. + NORP1=NOR+1 + SGN=1.0D0 + C(0)=A(0) + DO 25 I=2,NORP1 + SGN=-SGN + C(I-1)=SGN*(B(I-2)+A(I-1)) + 25 CONTINUE + C(NORP1)=-SGN + CALL ALROOT(C,NORP1,CDENOM,LFAIL) + IF(LFAIL) CALL XABORT('SHIRAT: ROOT FINDING FAILURE.') + DO 50 I=1,NORP1 + SIGXI=CDENOM(I) + DENOM(I)=CMPLX(SIGXI) + DD=SIGXI**(NORP1-1) + SGN=1.0D0 + DO 30 J=NORP1-1,1,-1 + SGN=-SGN + DD=DD+SGN*B(J-1)*SIGXI**(J-1) + 30 CONTINUE + DO 40 J=1,NORP1 + IF(J.NE.I) DD=DD/(SIGXI-CDENOM(J)) + 40 CONTINUE + COEF(I)=CMPLX(DD) + 50 CONTINUE + ELSE + CALL XABORT('SHIRAT: PADE COLLOCATION FAILURE.') + ENDIF + IF(IMPX.GE.10) THEN + WRITE (6,80) IGRP,(COEF(I),I=1,NOR+1) + WRITE (6,90) (DENOM(I),I=1,NOR+1) + WRITE (6,100) + X=1.0D0 + DO 70 I=1,2*NRAT-1 + Z1=0.0D0 + Z2=0.0D0 + DO 60 J=0,NOR + Z1=Z1+A(J)*X + Z2=Z2+B(J)*X + X=X*SIGX(I) + 60 CONTINUE + WRITE (6,'(1X,I5,1P,3E13.5)') I,SIGX(I),DILUT(I),Z1/Z2 + 70 CONTINUE + WRITE (6,110) SA + ENDIF + EAV=0.0 + DO 75 I=1,NRAT + EAV=EAV+COEF(I)*SQRT(DENOM(I)) + 75 CONTINUE + EAV=EAV*EAV + IF(REAL(EAV).LT.0.0) THEN + NALPHA=2*NRAT-1 + WRITE (6,120) (SIGX(I),I=1,NALPHA) + WRITE (6,130) (DILUT(I),I=1,NALPHA) + WRITE (6,80) IGRP,(COEF(I),I=1,NRAT) + WRITE (6,90) (DENOM(I),I=1,NRAT) + WRITE (HSMG,'(41HSHIRAT: RATIONAL EXPANSION FAILURE. EAV=(, + 1 1P,E10.3,1H,,E10.3,33H) HAS NEGATIVE REAL PART IN GROUP,I4, + 2 1H.)') EAV,IGRP + CALL XABORT(HSMG) + ELSE IF(ABS(AIMAG(EAV)).GT.5.0E-3*REAL(EAV)) THEN + NALPHA=2*NRAT-1 + WRITE (6,120) (SIGX(I),I=1,NALPHA) + WRITE (6,130) (DILUT(I),I=1,NALPHA) + WRITE (6,80) IGRP,(COEF(I),I=1,NRAT) + WRITE (6,90) (DENOM(I),I=1,NRAT) + WRITE (6,'(/42H SHIRAT: RATIONAL EXPANSION WARNING. EAV=(, + 1 1P,E10.3,1H,,E10.3,35H) HAS LARGE IMAGINARY PART IN GROUP, + 2 I4,1H.)') EAV,IGRP + ENDIF + RETURN +* + 80 FORMAT(//52H RATIONAL APPROXIMATION COEFFICIENTS FOR FUEL-TO-FUE, + 1 59HL REDUCED COLLISION PROBABILITIES OF THE CLOSED CELL (GROUP, + 2 I5,2H):/1P,9X,10HNUMERATOR ,3(2H (,E11.4,1H,,E11.4,1H),:)/19X, + 3 3(2H (,E11.4,1H,,E11.4,1H),:)) + 90 FORMAT(7X,12HDENOMINATOR ,3(2H (,E11.4,1H,,E11.4,1H),:)/19X, + 1 3(2H (,E11.4,1H,,E11.4,1H),:)) + 100 FORMAT(/5X,1HI,9X,4HSIGX,8X,5HDILUT,10X,3HFIT) + 110 FORMAT(11X,8HINFINITE,1P,E13.5) + 120 FORMAT(//7H SIGX:,1P,7E11.4) + 130 FORMAT(7H DILUT:,7E11.4/) + END diff --git a/Dragon/src/SHISN2.f b/Dragon/src/SHISN2.f new file mode 100644 index 0000000..edd4fee --- /dev/null +++ b/Dragon/src/SHISN2.f @@ -0,0 +1,435 @@ +*DECK SHISN2 + SUBROUTINE SHISN2 (IPLIB,IPTRK,IFTRAK,NGRO,NBISO,NBM,NREG,NUN, + 1 CDOOR,NRES,NBM2,IMPX,ISONAM,MIX,DEN,SN,SB,LSHI,IPHASE,MAT,VOL, + 2 KEYFLX,LEAKSW,TITR,START,SIGT,SIGT3,NOCONV,BIEFF,LGC,SIGE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform one multidimensional self-shielding iteration using the +* generalized Stamm'ler algorithm without Nordheim (PIC) approximation. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the internal microscopic cross section library +* (L_LIBRARY signature). +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK unit number of the sequential binary tracking file. +* NGRO number of energy groups. +* NBISO number of isotopes present in the calculation domain. +* NBM number of mixtures in the macrolib. +* NREG number of volumes. +* NUN number of unknowns in the flux or source vector in one +* energy group. +* CDOOR name of the geometry/solution module. +* NRES number of resonant mixtures. +* NBM2 number of resonant isotopes. +* IMPX print flag. +* ISONAM alias name of isotopes. +* MIX mix number of each isotope (can be zero). +* DEN density of each isotope. +* LSHI resonant region number associated with each isotope. +* Infinite dilution will be assumed if LSHI(i)=0. +* IPHASE type of flux solution (=1 use a native flux solution door; +* =2 use collision probabilities). +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX pointers of fluxes in unknown vector. +* LEAKSW leakage flag (.TRUE. only if leakage is present on the outer +* surface). +* TITR title. +* START beginning-of-iteration flag (.TRUE. if SHISN2 is called +* for the first time). +* SIGT3 transport correction. +* NOCONV mixture convergence flag (.TRUE. if mixture IBM +* is not converged in group L). +* BIEFF Livolant-Jeanpierre normalization flag (.TRUE. to +* activate). +* LGC Goldstein-Cohen approximation flag (.TRUE. to activate). +* +*Parameters: output +* SN on input, estimate of the dilution cross section in each +* energy group of each isotope. A value of 1.0e10 is used +* for infinite dilution. +* On output, computed dilution cross section in each energy +* group of each isotope. +* SIGT total macroscopic cross sections as modified by Shiba. +* +*Parameters: output +* SB dilution cross section as used in Livolant-Jeanpierre +* normalization. +* SIGE computed macroscopic dilution cross section in each resonant +* mixture and each energy group. +* +*Reference: +* A. Hebert and G. Marleau, Generalization of the Stamm'ler Method +* for the Self-Shielding of Resonant isotopes in Arbitrary Geometries, +* Nucl. Sci. Eng. 108, 230 (1991). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + PARAMETER (NALPHA=5) + TYPE(C_PTR) IPLIB,IPTRK + INTEGER IFTRAK,NGRO,NBISO,NBM,NREG,NUN,NRES,NBM2,IMPX, + 1 ISONAM(3,NBISO),MIX(NBISO),LSHI(NBISO),IPHASE,MAT(NREG), + 2 KEYFLX(NREG) + REAL DEN(NBISO),SN(NGRO,NBISO),SB(NGRO,NBISO),VOL(NREG), + 1 SIGT(NBM,NGRO),SIGT3(NBM,NGRO),SIGE(NRES,NGRO) + CHARACTER CDOOR*12,TITR*72,CGRPNM*12 + LOGICAL LEAKSW,START,NOCONV(NBM,NGRO),BIEFF,LGC +*---- +* LOCAL VARIABLES +*---- + CHARACTER HSMG*131 + LOGICAL LOGDO + COMPLEX COEF(3),DENOM(3),EAV + PARAMETER (NRAT=(NALPHA+1)/2) + TYPE(C_PTR) KPLIB + REAL FACT(NALPHA),SIGX(NALPHA) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IRES,MIX2,IRNBM,NPSYS + REAL, ALLOCATABLE, DIMENSION(:) :: GAR,SIGRES,DILAV,FUN + REAL, ALLOCATABLE, DIMENSION(:,:) :: SIG0,SIG1,SIG3,TOTAL,SIGOLD, + 1 DILUT + LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASKI + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO +*---- +* DATA STATEMENTS +*---- + DATA FACT/0.01,0.1,1.0,10.0,100.0/ +*---- +* SCRATCH STORAGE ALLOCATION +* SIG0 macroscopic xs of the resonant isotopes as interpolated. +* SIG1 macroscopic xs of the resonant isotopes at various SIGX. +* SIG3 macroscopic transport correction. +*---- + ALLOCATE(IRES(NBM),MIX2(NBISO),IRNBM(NBM),NPSYS(NGRO)) + ALLOCATE(SIG0(NBM,NGRO),SIG1(NBM,NGRO),SIG3(NBM,NGRO), + 1 TOTAL(NGRO,NBM2),SIGOLD(NGRO,NBM2),GAR(NGRO),SIGRES(NBM), + 2 DILAV(NGRO),DILUT(NALPHA,NGRO)) + ALLOCATE(MASKI(NBISO)) + ALLOCATE(IPISO(NBISO)) +*---- +* SET THE LCM MICROLIB ISOTOPEWISE DIRECTORIES. +*---- + CALL LIBIPS(IPLIB,NBISO,IPISO) +*---- +* UNLOAD MICROSCOPIC X-S FROM LCM TO SCRATCH STORAGE +*---- + IBM=0 + DO 20 ISO=1,NBISO + MIX2(ISO)=0 + IF(LSHI(ISO).GT.0) THEN + IBM=IBM+1 + MIX2(ISO)=IBM + KPLIB=IPISO(ISO) ! set ISO-th isotope + CALL LCMGET(KPLIB,'NTOT0',TOTAL(1,IBM)) + CALL LCMLEN(KPLIB,'NGOLD',LENGT,ITYLCM) + IF((LENGT.EQ.NGRO).AND.(.NOT.START).AND.LGC) THEN + IF(IMPX.GE.5) WRITE (6,390) (ISONAM(I0,ISO),I0=1,3) + CALL LCMGET(KPLIB,'SIGS00',SIGOLD(1,IBM)) + CALL LCMGET(KPLIB,'NGOLD',GAR) + DO 10 LLL=1,NGRO + SIGOLD(LLL,IBM)=(1.0-GAR(LLL))*SIGOLD(LLL,IBM) + 10 CONTINUE + ELSE + SIGOLD(:NGRO,IBM)=0.0 + ENDIF + ENDIF + 20 CONTINUE +*---- +* LOOP OVER RESONANT REGIONS. THE CP ARE STORED ON DIRECTORY SHIBA +*---- + CALL LCMSIX(IPLIB,'SHIBA',1) + DO 260 INRS=1,NRES +*---- +* FIND THE RESONANT MIXTURE NUMBERS (IRNBM) ASSOCIATED WITH REGION INRS +*---- + NBNRS=0 + DO 50 IBM=1,NBM + IRES(IBM)=0 + DO 40 ISO=1,NBISO + IF((MIX(ISO).EQ.IBM).AND.(LSHI(ISO).EQ.INRS)) THEN + NBNRS=NBNRS+1 + IRNBM(NBNRS)=IBM + IRES(IBM)=1 + GO TO 50 + ENDIF + 40 CONTINUE + 50 CONTINUE + IF(NBNRS.EQ.0) THEN + IF(START.AND.(IMPX.GE.1)) WRITE(6,385) 'SHISN2',INRS + GO TO 260 + ELSE IF(START.AND.(NBNRS.GT.1).AND.(IMPX.GE.5)) THEN + WRITE (6,380) NBNRS,INRS + ENDIF +* + NPSYS(:NGRO)=0 + DO 120 LLL=1,NGRO + LOGDO=.FALSE. + DO 60 I=1,NBNRS + LOGDO=LOGDO.OR.NOCONV(IRNBM(I),LLL) + 60 CONTINUE + IF(LOGDO) THEN + NPSYS(LLL)=LLL +* +* COMPUTE THE LIGHT AND RESONANT COMPONENTS OF THE MACROSCOPIC +* CROSS SECTIONS IN EACH RESONANT MIXTURE. + DO 80 I=1,NBNRS + SIGRES(I)=0.0 + DO 70 ISO=1,NBISO + IF((MIX(ISO).EQ.IRNBM(I)).AND.(LSHI(ISO).EQ.INRS)) THEN + SIGRES(I)=SIGRES(I)+TOTAL(LLL,MIX2(ISO))*DEN(ISO) + ENDIF + 70 CONTINUE + SIGT(IRNBM(I),LLL)=SIGT(IRNBM(I),LLL)-SIGRES(I) + 80 CONTINUE + DO 90 IBM=1,NBM + SIG0(IBM,LLL)=0.0 + SIG1(IBM,LLL)=0.0 + SIG3(IBM,LLL)=SIGT3(IBM,LLL) + 90 CONTINUE + DO 110 I=1,NBNRS + SIG0(IRNBM(I),LLL)=SIGRES(I) + SIG3(IRNBM(I),LLL)=0.0 + 110 CONTINUE + IF(IMPX.GE.10) THEN + WRITE (6,400) LLL,(SIG0(I,LLL),I=1,NBM) + WRITE (6,410) LLL,(SIGT(I,LLL),I=1,NBM) + WRITE (6,420) LLL,(SIGT3(I,LLL),I=1,NBM) + ENDIF + ENDIF + 120 CONTINUE +*---- +* SET UP VECTORS DILUT AND SIGX. +*---- + DILAV(:NGRO)=0.0 + IF(START) THEN +* USE A VERY CHEAP APPROXIMATION TO START ITERATIONS. + ALLOCATE(FUN(NUN*NGRO)) + CALL LCMSIX(IPLIB,'--AVERAGE--',1) + CALL SHIDST (IPLIB,NPSYS,IPTRK,IFTRAK,CDOOR,IMPX,NBM,NREG, + 1 NUN,NGRO,IPHASE,MAT,VOL,KEYFLX,LEAKSW,IRES,SIG0,SIGT, + 2 SIGT3(1,1),TITR,FUN,DILAV) + CALL LCMSIX(IPLIB,' ',2) + DEALLOCATE(FUN) + DO 135 LLL=1,NGRO + DO 130 IALP=1,NALPHA + DILUT(IALP,LLL)=DILAV(LLL) + 130 CONTINUE + 135 CONTINUE + ELSE + DO 165 IALP=1,NALPHA + DO 150 LLL=1,NGRO + IF(NPSYS(LLL).NE.0) THEN + DO 140 I=1,NBNRS + SIG1(IRNBM(I),LLL)=FACT(IALP)*SIGE(INRS,LLL) + 140 CONTINUE + ENDIF + 150 CONTINUE + ALLOCATE(FUN(NUN*NGRO)) + WRITE(CGRPNM,'(8H--BAND--,I4.4)') IALP + CALL LCMSIX(IPLIB,CGRPNM,1) + CALL SHIDST (IPLIB,NPSYS,IPTRK,IFTRAK,CDOOR,IMPX,NBM,NREG, + 1 NUN,NGRO,IPHASE,MAT,VOL,KEYFLX,LEAKSW,IRES,SIG1,SIGT, + 2 SIG3(1,1),TITR,FUN,DILAV) + CALL LCMSIX(IPLIB,' ',2) + DEALLOCATE(FUN) + DO 160 LLL=1,NGRO + DILUT(IALP,LLL)=DILAV(LLL) + 160 CONTINUE + 165 CONTINUE + ENDIF +*---- +* COMPUTE AVERAGE MACROSCOPIC DILUTION X-S (SIGE) USING A THREE-TERM +* RATIONAL APPROXIMATION. +*---- + DO 200 LLL=1,NGRO + IF(NPSYS(LLL).NE.0) THEN + DO 170 IALP=1,NALPHA + SIGX(IALP)=FACT(IALP)*SIGE(INRS,LLL) + 170 CONTINUE + IMPX2=IMPX + IF(START) IMPX2=MAX(0,IMPX-10) +* ********************************************************** + CALL SHIRAT(IMPX2,NRAT,SIGX,DILUT(1,LLL),LLL,A,COEF,DENOM) +* ********************************************************** + EAV=(COEF(1)*SQRT(DENOM(1))+COEF(2)*SQRT(DENOM(2))+ + 1 COEF(3)*SQRT(DENOM(3)))**2 + SIGE(INRS,LLL)=REAL(EAV) + IF((.NOT.START).AND.(BIEFF).AND.(NBNRS.EQ.1)) THEN +* COMPUTE DILAV FOR THE L-J NORMALIZATION. + SIGXX=SIG0(IRNBM(1),LLL) + PXX=REAL(COEF(1)/(SIGXX+DENOM(1))+COEF(2)/(SIGXX+DENOM(2)) + 1 +COEF(3)/(SIGXX+DENOM(3))) + DILAV(LLL)=1.0/PXX-SIGXX + ENDIF +*---- +* COMPUTE THE ISOTOPE DILUTION MICROSCOPIC CROSS SECTIONS (SN) USED +* FOR LIBRARY INTERPOLATION. +*---- + DO 190 ISO=1,NBISO + IF((LSHI(ISO).EQ.INRS).AND.(IRES(MIX(ISO)).EQ.1).AND. + 1 (DEN(ISO).NE.0.)) THEN + SUM=0.0 + DO 180 JSO=1,NBISO + IBM=MIX(JSO) + IF((LSHI(JSO).EQ.INRS).AND.(IBM.EQ.MIX(ISO)).AND. + 1 (ISO.NE.JSO)) SUM=SUM+(TOTAL(LLL,MIX2(JSO))- + 2 SIGOLD(LLL,MIX2(JSO)))*DEN(JSO) + 180 CONTINUE + SN(LLL,ISO)=REAL(COEF(1)*SQRT(DENOM(1)+SUM)+COEF(2)* + 1 SQRT(DENOM(2)+SUM)+COEF(3)*SQRT(DENOM(3)+SUM))**2/DEN(ISO) + IF(SN(LLL,ISO).LE.0.0) THEN + WRITE (HSMG,510) (ISONAM(I0,ISO),I0=1,3),SN(LLL,ISO),LLL + CALL XABORT(HSMG) + ENDIF + ELSE IF((LSHI(ISO).EQ.INRS).AND.(IRES(MIX(ISO)).EQ.1).AND. + 1 (DEN(ISO).EQ.0.)) THEN + SN(LLL,ISO)=1.0E10 + ENDIF + 190 CONTINUE + IF((.NOT.START).AND.(IMPX.GE.10)) THEN + DO 195 I=1,NBNRS + PP=A-SIGT(IRNBM(I),LLL) + QQ=SIGE(INRS,LLL)-SIGT(IRNBM(I),LLL) + IF(ABS(PP).GT.1.0E-4*SIGT(IRNBM(I),LLL)) THEN + BEL=QQ/PP + ELSE + BEL=0.0 + ENDIF + WRITE (6,610) I,SIGE(INRS,LLL),BEL + 195 CONTINUE + ENDIF + ENDIF + 200 CONTINUE +*---- +* COMPUTE THE ISOTOPE DILUTION MICROSCOPIC CROSS SECTIONS (SB) USED +* IN L-J NORMALIZATION. +*---- + IF((.NOT.START).AND.(BIEFF).AND.(NBNRS.GT.1)) THEN +* COMPUTE DILAV FOR THE L-J NORMALIZATION. + ALLOCATE(FUN(NUN*NGRO)) + CALL LCMSIX(IPLIB,'--AVERAGE--',1) + CALL SHIDST (IPLIB,NPSYS,IPTRK,IFTRAK,CDOOR,IMPX,NBM,NREG, + 1 NUN,NGRO,IPHASE,MAT,VOL,KEYFLX,LEAKSW,IRES,SIG0,SIGT, + 2 SIGT3(1,1),TITR,FUN,DILAV) + CALL LCMSIX(IPLIB,' ',2) + DEALLOCATE(FUN) + ENDIF + DO 250 LLL=1,NGRO + IF(NPSYS(LLL).NE.0) THEN + DO 220 ISO=1,NBISO + IF((LSHI(ISO).EQ.INRS).AND.(IRES(MIX(ISO)).EQ.1).AND. + 1 (DEN(ISO).NE.0.)) THEN + SUM=0.0 + DO 210 JSO=1,NBISO + IBM=MIX(JSO) + IF((LSHI(JSO).EQ.INRS).AND.(IBM.EQ.MIX(ISO)).AND. + 1 (ISO.NE.JSO)) SUM=SUM+TOTAL(LLL,MIX2(JSO))*DEN(JSO) + 210 CONTINUE + IF(START.OR.(.NOT.BIEFF)) THEN + SB(LLL,ISO)=SN(LLL,ISO) + ELSE + SB(LLL,ISO)=(DILAV(LLL)+SUM)/DEN(ISO) + IF(SB(LLL,ISO).LT.0.0) THEN + WRITE (HSMG,515) (ISONAM(I0,ISO),I0=1,3),SB(LLL,ISO), + 1 LLL + CALL XABORT(HSMG) + ELSE IF(SB(LLL,ISO).LT.SN(LLL,ISO)) THEN + IF(SB(LLL,ISO).LT.0.99*SN(LLL,ISO)) WRITE (6,520) + 1 (ISONAM(I0,ISO),I0=1,3),SB(LLL,ISO)/SN(LLL,ISO),LLL + SB(LLL,ISO)=SN(LLL,ISO) + ENDIF + ENDIF + ELSE IF((LSHI(ISO).EQ.INRS).AND.(IRES(MIX(ISO)).EQ.1).AND. + 1 (DEN(ISO).EQ.0.)) THEN + SB(LLL,ISO)=1.0E10 + ENDIF + 220 CONTINUE +* +* RESTORE SIGT ARRAY. + DO 240 I=1,NBNRS + SIGRES(I)=0.0 + DO 230 ISO=1,NBISO + IF((MIX(ISO).EQ.IRNBM(I)).AND.(LSHI(ISO).EQ.INRS)) THEN + SIGRES(I)=SIGRES(I)+TOTAL(LLL,MIX2(ISO))*DEN(ISO) + ENDIF + 230 CONTINUE + SIGT(IRNBM(I),LLL)=SIGT(IRNBM(I),LLL)+SIGRES(I) + 240 CONTINUE + ENDIF + 250 CONTINUE + 260 CONTINUE + CALL LCMSIX(IPLIB,' ',2) +*---- +* SAVE THE GROUP- AND ISOTOPE-DEPENDENT DILUTIONS +*---- + CALL LCMPUT(IPLIB,'ISOTOPESDSB',NBISO*NGRO,2,SB) + CALL LCMPUT(IPLIB,'ISOTOPESDSN',NBISO*NGRO,2,SN) +*---- +* COMPUTE THE SELF-SHIELDED MICROSCOPIC CROSS SECTIONS AND UPDATE +* VECTOR SIGT +*---- + DO 290 ISO=1,NBISO + LOGDO=START.OR.(DEN(ISO).NE.0.) + MASKI(ISO)=(LSHI(ISO).GT.0).AND.LOGDO + 290 CONTINUE + IMPX2=MAX(0,IMPX-1) + CALL LIBLIB (IPLIB,NBISO,MASKI,IMPX2) + DO 320 ISO=1,NBISO + IBM=MIX(ISO) + IF((LSHI(ISO).GT.0).AND.(IBM.GT.0).AND.(DEN(ISO).NE.0.)) THEN + KPLIB=IPISO(ISO) ! set ISO-th isotope + CALL LCMGET(KPLIB,'NTOT0',GAR) + DO 300 LLL=1,NGRO + TOTAL(LLL,MIX2(ISO))=TOTAL(LLL,MIX2(ISO))-GAR(LLL) + 300 CONTINUE + DO 310 LLL=1,NGRO + IF(NOCONV(IBM,LLL)) SIGT(IBM,LLL)=SIGT(IBM,LLL)-DEN(ISO)* + 1 TOTAL(LLL,MIX2(ISO)) + 310 CONTINUE + ENDIF + 320 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IPISO) + DEALLOCATE(MASKI) + DEALLOCATE(DILUT,DILAV,SIGRES,GAR,SIGOLD,TOTAL,SIG3,SIG1,SIG0) + DEALLOCATE(NPSYS,IRNBM,MIX2,IRES) + RETURN +* + 380 FORMAT(/16H SHISN2: MERGING,I3,30H RESONANT MIXTURES IN RESONANT, + 1 14H REGION NUMBER,I3,1H.) + 385 FORMAT(A6,1X,': RESONANT REGION =',I10,1X,'NOT USED.') + 390 FORMAT(/53H SHISN2: GOLDSTEIN AND COHEN APPROXIMATION USED FOR I, + 1 8HSOTOPE ',3A4,2H'.) + 400 FORMAT(1X,'TOTAL MACROSCOPIC CROSS SECTIONS OF THE RESONANT ', + 1'MATERIALS IN EACH MIXTURE (GROUP',I5,'):'/(1X,1P,11E11.3)) + 410 FORMAT(1X,'TOTAL MACROSCOPIC CROSS SECTIONS OF THE OTHER ', + 1'MATERIALS IN EACH MIXTURE (GROUP',I5,'):'/(1X,1P,11E11.3)) + 420 FORMAT(//1X,'TRANSPORT CORRECTION CROSS SECTIONS OF THE OTHER ', + 1'MATERIALS IN EACH MIXTURE (GROUP',I5,'):'/(1X,1P,11E11.3)) + 510 FORMAT(30HSHISN2: THE RESONANT ISOTOPE ',3A4,14H' HAS A NEGATI, + 1 27HVE DILUTION CROSS-SECTION (,1P,E14.4,0P,10H) IN GROUP,I4,1H.) + 515 FORMAT(30HSHISN2: THE RESONANT ISOTOPE ',3A4,14H' HAS A NEGATI, + 1 22HVE L-J CROSS-SECTION (,1P,E14.4,0P,10H) IN GROUP,I4,1H.) + 520 FORMAT(54H SHISN2: THE L-J EQUIVALENCE FACTOR OF RESONANT ISOTOP, + 1 3HE ',3A4,18H' WAS CHANGED FROM,F6.3,16H TO 1.0 IN GROUP,I4,1H.) + 610 FORMAT(8X,8HAVERAGE(,I2,1H),1P,E13.5/8X,11HBELL FACTOR,E13.5) + END diff --git a/Dragon/src/SHISN3.f b/Dragon/src/SHISN3.f new file mode 100644 index 0000000..c82e61c --- /dev/null +++ b/Dragon/src/SHISN3.f @@ -0,0 +1,464 @@ +*DECK SHISN3 + SUBROUTINE SHISN3 (IPLIB,IPTRK,IFTRAK,LEVEL,NGRO,NBISO,NBM,NREG, + 1 NUN,CDOOR,INRS,NBNRS,IMPX,ISONAM,MIX,DEN,SN,SB,LSHI,IPHASE,MAT, + 2 VOL,KEYFLX,LEAKSW,TITR,START,SIGT,SIGT3,NOCONV,BIEFF,LGC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform one multidimensional self-shielding iteration using the +* generalized Stamm'ler algorithm with Nordheim (PIC) approximation. +* +*Copyright: +* Copyright (C) 2004 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the internal microscopic cross section library +* (L_LIBRARY signature). +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK unit number of the sequential binary tracking file. +* LEVEL type of self-shielding model (=1 original Stamm'ler model +* with Nordheim approximation; =2 Stamm'ler model with Nordheim +* approximation and Riemann integration method). +* NGRO number of energy groups. +* NBISO number of isotopes present in the calculation domain. +* NBM number of mixtures in the macrolib. +* NREG number of volumes. +* NUN number of unknowns in the flux or source vector in one +* energy group. +* CDOOR name of the geometry/solution module. +* INRS index of the resonant isotope under consideration. +* NBNRS number of totaly correlated resonant regions. +* IMPX print flag. +* ISONAM alias name of isotopes. +* MIX mix number of each isotope (can be zero). +* DEN density of each isotope. +* LSHI resonant region number associated with each isotope. +* Infinite dilution will be assumed if LSHI(i)=0. +* IPHASE type of flux solution (=1 use a native flux solution door; +* =2 use collision probabilities). +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX pointers of fluxes in unknown vector. +* LEAKSW leakage flag (.TRUE. only if leakage is present on the outer +* surface). +* TITR title. +* START beginning-of-iteration flag (.TRUE. if SHISN3 is called +* for the first time). +* SIGT3 transport correction. +* NOCONV mixture convergence flag. (.TRUE. if mixture IBM +* is not converged in group L). +* BIEFF Livolant-Jeanpierre normalization flag (.TRUE. to +* activate). +* LGC Goldstein-Cohen approximation flag (.TRUE. to activate). +* +*Parameters: input/output +* SN on input, estimate of the dilution cross section in each +* energy group of each isotope. A value of 1.0e10 is used +* for infinitedilution. +* On output, computed dilution cross section in each energy +* group of each isotope. +* SIGT total macroscopic cross sections as modified by Shiba. +* +*Parameters: output +* SB dilution cross section as used in Livolant-Jeanpierre +* normalization. +* +*Reference: +* A. Hebert, Revisiting the Stamm'ler Self-Shielding Method, Presented +* at the 25th CNS annnual conference, June 6-9, Toronto, 2004. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + PARAMETER (NALPHA=9,NRAT=(NALPHA+1)/2) + TYPE(C_PTR) IPLIB,IPTRK + INTEGER IFTRAK,LEVEL,NGRO,NBISO,NBM,NREG,NUN,INRS,NBNRS,IMPX, + 1 ISONAM(3,NBISO),MIX(NBISO),LSHI(NBISO),IPHASE,MAT(NREG), + 2 KEYFLX(NREG) + REAL DEN(NBISO),SN(NGRO,NBISO),SB(NGRO,NBISO),VOL(NREG), + 1 SIGT(NBM,NGRO),SIGT3(NBM,NGRO) + CHARACTER CDOOR*12,TITR*72 + LOGICAL LEAKSW,START,NOCONV(NBM,NGRO),BIEFF,LGC +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) KPLIB + CHARACTER HSMG*131,CGRPNM*12 + LOGICAL LOGDO + REAL FACT(NALPHA),SIGX(NALPHA) + COMPLEX SUM +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IRES,ISONR,NPSYS + REAL, ALLOCATABLE, DIMENSION(:) :: GAR,GAS,SIGE,VST,DIST,FUN,DILG + REAL, ALLOCATABLE, DIMENSION(:,:) :: SIG0,SIG3,TOTAL,DILUT,GC + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: PICX + LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASKI + COMPLEX, ALLOCATABLE, DIMENSION(:,:) :: COEF,DENOM + COMPLEX*16, ALLOCATABLE, DIMENSION(:,:,:) :: XCOEF,XDENO + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO +*---- +* DATA STATEMENTS +*---- + DATA FACT/0.01,0.03162278,0.1,0.3162278,1.0,3.162278,10.0, + 1 31.62278,100.0/ +*---- +* SCRATCH STORAGE ALLOCATION +* SIG0 macroscopic xs of the resonant isotopes as interpolated. +* SIG3 macroscopic transport correction. +*---- + ALLOCATE(IRES(NBM),ISONR(NBNRS),NPSYS(NGRO)) + ALLOCATE(SIG0(NBM,NGRO),SIG3(NBM,NGRO),TOTAL(NGRO,NBNRS), + 1 GAR(NGRO),GAS(NGRO),SIGE(NGRO),DILUT(NALPHA,NGRO), + 2 GC(NGRO,NBNRS),VST(NBNRS),DIST(NBNRS)) + ALLOCATE(PICX(NALPHA,NBNRS,NGRO)) + ALLOCATE(MASKI(NBISO)) + ALLOCATE(COEF(NRAT,NGRO),DENOM(NRAT,NGRO)) + ALLOCATE(XCOEF(NRAT,NBNRS,NGRO),XDENO(NRAT,NBNRS,NGRO)) + ALLOCATE(IPISO(NBISO)) +*---- +* FIND THE RESONANT MIXTURE NUMBERS AND THE CORRELATED ISOTOPES +* ASSOCIATED WITH REGION INRS +*---- + IRS=0 + DO 30 IBM=1,NBM + LOGDO=.FALSE. + DO 10 I=1,NREG + LOGDO=LOGDO.OR.(MAT(I).EQ.IBM) + 10 CONTINUE + IF(.NOT.LOGDO) GO TO 30 + DO 20 ISO=1,NBISO + IF((MIX(ISO).EQ.IBM).AND.(LSHI(ISO).EQ.INRS)) THEN + IRS=IRS+1 + ISONR(IRS)=ISO + GO TO 30 + ENDIF + 20 CONTINUE + 30 CONTINUE + IF(IRS.NE.NBNRS) CALL XABORT('SHISN3: INVALID VALUE OF NBNRS.') + IRES(:NBM)=0 + DO 40 IRS=1,NBNRS + ISO=ISONR(IRS) + IRES(MIX(ISO))=IRS + 40 CONTINUE +*---- +* SET THE LCM MICROLIB ISOTOPEWISE DIRECTORIES. +*---- + CALL LIBIPS(IPLIB,NBISO,IPISO) +*---- +* UNLOAD MICROSCOPIC X-S FROM LCM TO SCRATCH STORAGE. SET THE +* GOLDSTEIN-COHEN TO ONE IN LEVEL 2 CALCULATIONS. +*---- + DO 50 IRS=1,NBNRS + ISO=ISONR(IRS) + KPLIB=IPISO(ISO) ! set ISO-th isotope + CALL LCMGET(KPLIB,'NTOT0',TOTAL(1,IRS)) + GC(:NGRO,IRS)=1.0 + 50 CONTINUE +* + VST(:NBNRS)=0.0 + DO 60 I=1,NREG + IF(MAT(I).EQ.0) GO TO 60 + IND=IRES(MAT(I)) + IF(IND.GT.0) VST(IND)=VST(IND)+VOL(I) + 60 CONTINUE +* + NPSYS(:NGRO)=0 + DO 110 LLL=1,NGRO + LOGDO=.FALSE. + DO 70 IRS=1,NBNRS + LOGDO=LOGDO.OR.NOCONV(MIX(ISONR(IRS)),LLL) + 70 CONTINUE + IF(LOGDO) THEN + NPSYS(LLL)=LLL +* +* COMPUTE THE LIGHT AND RESONANT COMPONENTS OF THE MACROSCOPIC +* CROSS SECTIONS IN EACH RESONANT MIXTURE. + DO 80 IRS=1,NBNRS + ISO=ISONR(IRS) + IBM=MIX(ISO) + SIGT(IBM,LLL)=SIGT(IBM,LLL)-TOTAL(LLL,IRS)*DEN(ISO) + 80 CONTINUE + DO 90 IBM=1,NBM + SIG0(IBM,LLL)=0.0 + SIG3(IBM,LLL)=SIGT3(IBM,LLL) + 90 CONTINUE + DO 100 IRS=1,NBNRS + ISO=ISONR(IRS) + SIG0(MIX(ISO),LLL)=TOTAL(LLL,IRS)*DEN(ISO) + SIG3(MIX(ISO),LLL)=0.0 + 100 CONTINUE + IF(IMPX.GE.10) THEN + WRITE (6,400) LLL,(SIG0(I,LLL),I=1,NBM) + WRITE (6,410) LLL,(SIGT(I,LLL),I=1,NBM) + WRITE (6,420) LLL,(SIGT3(I,LLL),I=1,NBM) + ENDIF + ENDIF + 110 CONTINUE +*---- +* SET UP VECTORS SIGE AND SB. +*---- + CALL LCMSIX(IPLIB,'SHIBA',1) +* + SIGE(:NGRO)=0.0 + ALLOCATE(FUN(NUN*NGRO)) + CALL LCMSIX(IPLIB,'--AVERAGE--',1) + CALL SHIDST(IPLIB,NPSYS,IPTRK,IFTRAK,CDOOR,IMPX,NBM,NREG,NUN, + 1 NGRO,IPHASE,MAT,VOL,KEYFLX,LEAKSW,IRES,SIG0,SIGT,SIGT3(1,1), + 2 TITR,FUN,SIGE) + CALL LCMSIX(IPLIB,' ',2) + DO 130 LLL=1,NGRO + IF(NPSYS(LLL).NE.0) THEN + DO 120 I=1,NREG + IBM=MAT(I) + IF(IBM.EQ.0) GO TO 120 + IND=IRES(IBM) + IF(IND.GT.0) THEN + IOF=(LLL-1)*NUN+KEYFLX(I) + ISO=ISONR(IND) + IF(NOCONV(IBM,LLL)) SB(LLL,ISO)=FUN(IOF)/ + 1 SIG0(IBM,LLL) + ENDIF + 120 CONTINUE + ENDIF + 130 CONTINUE + DEALLOCATE(FUN) +*---- +* SET UP VECTORS DILUT AND SIGX. +*---- + IF(START) THEN +* USE A VERY CHEAP APPROXIMATION TO START ITERATIONS. + DO 145 LLL=1,NGRO + DO 140 IALP=1,NALPHA + SIGX(IALP)=0.0 + DILUT(IALP,LLL)=SIGE(LLL) + 140 CONTINUE + 145 CONTINUE + ELSE + AVDEN=0.0 + VOLTOT=0.0 + DO 150 IRS=1,NBNRS + AVDEN=AVDEN+DEN(ISONR(IRS))*VST(IRS) + VOLTOT=VOLTOT+VST(IRS) + 150 CONTINUE + AVDEN=AVDEN/VOLTOT + DO 160 IRS=1,NBNRS + ISO=ISONR(IRS) + DIST(IRS)=DEN(ISO)/AVDEN + 160 CONTINUE + DO 220 IALP=1,NALPHA + DO 190 LLL=1,NGRO + IF(NPSYS(LLL).NE.0) THEN + SIGX(IALP)=FACT(IALP)*SIGE(LLL) + DO 170 IBM=1,NBM + SIG0(IBM,LLL)=0.0 + SIG3(IBM,LLL)=SIGT3(IBM,LLL) + 170 CONTINUE + DO 180 IRS=1,NBNRS + ISO=ISONR(IRS) + SIG0(MIX(ISO),LLL)=SIGX(IALP)*DIST(IRS) + SIG3(MIX(ISO),LLL)=0.0 + 180 CONTINUE + ENDIF + 190 CONTINUE + ALLOCATE(DILG(NGRO),FUN(NUN*NGRO)) + WRITE(CGRPNM,'(8H--BAND--,I4.4)') IALP + CALL LCMSIX(IPLIB,CGRPNM,1) + CALL SHIDST(IPLIB,NPSYS,IPTRK,IFTRAK,CDOOR,IMPX,NBM,NREG,NUN, + 1 NGRO,IPHASE,MAT,VOL,KEYFLX,LEAKSW,IRES,SIG0,SIGT,SIG3(1,1), + 2 TITR,FUN,DILG) + CALL LCMSIX(IPLIB,' ',2) + DO 210 LLL=1,NGRO + IF(NPSYS(LLL).NE.0) THEN + DILUT(IALP,LLL)=DILG(LLL) + DO 200 I=1,NREG + IBM=MAT(I) + IF(IBM.EQ.0) GO TO 200 + IND=IRES(IBM) + IF(IND.GT.0) THEN + IOF=(LLL-1)*NUN+KEYFLX(I) + PICX(IALP,IND,LLL)=FUN(IOF)/SIG0(IBM,LLL) + ENDIF + 200 CONTINUE + ENDIF + 210 CONTINUE + DEALLOCATE(FUN,DILG) + 220 CONTINUE + ENDIF + CALL LCMSIX(IPLIB,' ',2) +*---- +* COMPUTE AVERAGE MACROSCOPIC DILUTION X-S USING A N-TERM RATIONAL +* APPROXIMATION. +*---- + DO 260 LLL=1,NGRO + IF(NPSYS(LLL).NE.0) THEN + DO 230 IALP=1,NALPHA + SIGX(IALP)=FACT(IALP)*SIGE(LLL) + 230 CONTINUE +* ********************************************************** + CALL SHIRAT(IMPX,NRAT,SIGX,DILUT(1,LLL),LLL,A,COEF(1,LLL), + 1 DENOM(1,LLL)) +* ********************************************************** +* +* COMPUTE THE PIC BASE POINTS FOR A N-TERM RATIONAL APPROXIMATION + IF(START) THEN + DO 245 IRS=1,NBNRS + DO 240 I=1,NRAT + XCOEF(I,IRS,LLL)=COEF(I,LLL) + XDENO(I,IRS,LLL)=DENOM(I,LLL) + 240 CONTINUE + 245 CONTINUE + ELSE + CALL SHIDIL(NRAT,NALPHA,NBNRS,COEF(1,LLL),DENOM(1,LLL), + 1 DILUT(1,LLL),PICX(1,1,LLL),SIGX,DIST,VST,IMPX,LLL, + 2 XCOEF(1,1,LLL),XDENO(1,1,LLL)) + ENDIF + IF(.NOT.START.AND.BIEFF) THEN + DO 255 IRS=1,NBNRS + ISO=ISONR(IRS) + IF(NOCONV(MIX(ISO),LLL)) THEN + SIGRES=TOTAL(LLL,IRS)*DEN(ISO) + IF(NBNRS.EQ.1) THEN + SUM=0.0 + DO 250 I=1,NRAT + SUM=SUM+COEF(I,LLL)/(SIGRES+DENOM(I,LLL)) + 250 CONTINUE + PX0=REAL(SUM) + ELSE + PX0=SB(LLL,ISO) + ENDIF + SB(LLL,ISO)=(1.0/PX0-SIGRES)/DEN(ISO) + IF(SB(LLL,ISO).LT.0.0) THEN + WRITE (HSMG,515) (ISONAM(I0,ISO),I0=1,3),SB(LLL,ISO), + 1 LLL + CALL XABORT(HSMG) + ENDIF + ENDIF + 255 CONTINUE + ENDIF + ENDIF + 260 CONTINUE +*---- +* APPLY A GOLDSTEIN-COHEN CORRECTION SIMILAR TO THE CORRECTION USED +* IN SHISN2. +*---- + IF((.NOT.START).AND.LGC) THEN + DO 295 IRS=1,NBNRS + ISO=ISONR(IRS) + KPLIB=IPISO(ISO) ! set ISO-th isotope + CALL LCMLEN(KPLIB,'NGOLD',LENGT,ITYLCM) + IF(LENGT.EQ.NGRO) THEN + IF(IMPX.GE.5) WRITE (6,390) (ISONAM(I0,ISO),I0=1,3) + CALL LCMGET(KPLIB,'NGOLD',GC(1,IRS)) + ENDIF + IF(LEVEL.EQ.2) GO TO 295 + DO 290 JSO=1,NBISO + IF((MIX(JSO).EQ.MIX(ISO)).AND.(JSO.NE.ISO).AND. + 1 (LSHI(JSO).NE.0)) THEN + KPLIB=IPISO(JSO) ! set JSO-th isotope + CALL LCMLEN(KPLIB,'NGOLD',LENGT,ITYLCM) + IF(LENGT.EQ.NGRO) THEN + CALL LCMGET(KPLIB,'SIGS00',GAS) + CALL LCMGET(KPLIB,'NGOLD',GAR) + DO 280 LLL=1,NGRO + IF((NOCONV(MIX(JSO),LLL)).AND.(GAR(LLL).NE.1.0)) THEN + DDD=(1.0-GAR(LLL))*GAS(LLL)*DEN(JSO) + DO 270 I=1,NRAT + XDENO(I,IRS,LLL)=XDENO(I,IRS,LLL)-DDD + 270 CONTINUE + ENDIF + 280 CONTINUE + ENDIF + ENDIF + 290 CONTINUE + 295 CONTINUE + ENDIF +*---- +* COMPUTE THE DILUTION PARAMETERS (BARN) FOR EACH RESONANT ISOTOPE IN +* RESONANT MIXTURE INRS +*---- + CALL SHIEQU(IPLIB,LEVEL,NGRO,NBISO,NBM,NBNRS,NRAT,MIX,ISONAM, + 1 NOCONV,ISONR,GC,COEF,DENOM,XCOEF,XDENO,DEN,IMPX,SN) +* + DO 320 LLL=1,NGRO + LOGDO=.FALSE. + DO 300 IRS=1,NBNRS + LOGDO=LOGDO.OR.NOCONV(MIX(ISONR(IRS)),LLL) + 300 CONTINUE + IF(LOGDO) THEN + DO 310 IRS=1,NBNRS + ISO=ISONR(IRS) + IBM=MIX(ISO) + IF(START.OR.(.NOT.BIEFF)) THEN + SB(LLL,ISO)=SN(LLL,ISO) + ELSE IF(SB(LLL,ISO).LT.0.97*SN(LLL,ISO)) THEN + WRITE (6,520)(ISONAM(I0,ISO),I0=1,3),SB(LLL,ISO)/ + 1 SN(LLL,ISO),0.97,LLL + SB(LLL,ISO)=0.97*SN(LLL,ISO) + ENDIF + SIGT(IBM,LLL)=SIGT(IBM,LLL)+TOTAL(LLL,IRS)*DEN(ISO) + 310 CONTINUE + ENDIF + 320 CONTINUE +*---- +* SAVE THE GROUP- AND ISOTOPE-DEPENDENT DILUTIONS +*---- + CALL LCMPUT(IPLIB,'ISOTOPESDSB',NBISO*NGRO,2,SB) + CALL LCMPUT(IPLIB,'ISOTOPESDSN',NBISO*NGRO,2,SN) +*---- +* COMPUTE THE SELF-SHIELDED MICROSCOPIC CROSS SECTIONS AND UPDATE +* VECTOR SIGT +*---- + DO 330 ISO=1,NBISO + LOGDO=START.OR.(DEN(ISO).NE.0.) + MASKI(ISO)=(LSHI(ISO).EQ.INRS).AND.LOGDO + 330 CONTINUE + IMPX2=MAX(0,IMPX-1) + CALL LIBLIB (IPLIB,NBISO,MASKI,IMPX2) + DO 345 IRS=1,NBNRS + ISO=ISONR(IRS) + IBM=MIX(ISO) + KPLIB=IPISO(ISO) ! set ISO-th isotope + CALL LCMGET(KPLIB,'NTOT0',GAR) + DO 340 LLL=1,NGRO + TOTAL(LLL,IRS)=TOTAL(LLL,IRS)-GAR(LLL) + SIGT(IBM,LLL)=SIGT(IBM,LLL)-DEN(ISO)*TOTAL(LLL,IRS) + 340 CONTINUE + 345 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IPISO) + DEALLOCATE(XDENO,XCOEF) + DEALLOCATE(DENOM,COEF) + DEALLOCATE(MASKI) + DEALLOCATE(PICX) + DEALLOCATE(DIST,VST,GC,DILUT,SIGE,GAS,GAR,TOTAL,SIG3,SIG0) + DEALLOCATE(NPSYS,ISONR,IRES) + RETURN +* + 390 FORMAT(/53H SHISN3: GOLDSTEIN AND COHEN APPROXIMATION USED FOR I, + 1 8HSOTOPE ',3A4,2H'.) + 400 FORMAT(//51H TOTAL MACROSCOPIC CROSS SECTIONS OF THE RESONANT M, + 1 31HATERIALS IN EACH MIXTURE (GROUP,I5,2H):/(1X,1P,11E11.3)) + 410 FORMAT(//51H TOTAL MACROSCOPIC CROSS SECTIONS OF THE OTHER MATE, + 1 28HRIALS IN EACH MIXTURE (GROUP,I5,2H):/(1X,1P,11E11.3)) + 420 FORMAT(//1X,'TRANSPORT CORRECTION CROSS SECTIONS OF THE OTHER ', + 1'MATERIALS IN EACH MIXTURE (GROUP',I5,'):'/(1X,1P,11E11.3)) + 515 FORMAT(30HSHISN3: THE RESONANT ISOTOPE ',3A4,14H' HAS A NEGATI, + 1 22HVE L-J CROSS-SECTION (,1P,E14.4,0P,10H) IN GROUP,I4,1H.) + 520 FORMAT(54H SHISN3: THE L-J EQUIVALENCE FACTOR OF RESONANT ISOTOP, + 1 3HE ',3A4,18H' WAS CHANGED FROM,F6.3,3H TO,F5.2,9H IN GROUP,I4, + 2 1H.) + END diff --git a/Dragon/src/SNADPT.f b/Dragon/src/SNADPT.f new file mode 100644 index 0000000..86c3abc --- /dev/null +++ b/Dragon/src/SNADPT.f @@ -0,0 +1,90 @@ +*DECK SNADPT + SUBROUTINE SNADPT(IELEM,NM,NMX,M,MX,TB,W,ISFIX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the weighting parameters for SN adaptive flux calculation, +* based on flux variation in the cell. +* +*Copyright: +* Copyright (C) 2020 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): C. Bienvenue +* +*Parameters: input +* IELEM measure of order of the closure relation. +* NM number of flux moments. +* NMX number of incoming flux moments. +* M moments of the flux. +* MX incoming flux moments. +* TB ratio (space=1, energy=ratio of boundary stopping powers). +* +*Parameters: input and output +* W weighting parameters of the closure relation. +* ISFIX flag indicating if moments sould be recalculated. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IELEM,NM,NMX + REAL W(IELEM+1),TB + DOUBLE PRECISION M(NM),MX(NMX) + LOGICAL ISFIX +*---- +* LOCAL VARIABLES +*---- + REAL P,U1,F1 + PARAMETER(EPS=1.0E-8,B=2.0) +*---- +* CONSTANT ORDER ADAPTIVE CALCULATIONS +*---- + IF(IELEM.EQ.1) THEN + + ! EXTRACT P + P=-W(1)/TB + + ! CASE P = 1 + IF(ABS(P-1).LE.EPS) THEN + IF(M(1).NE.0) THEN + U1=REAL((MX(1)-M(1))/M(1)) ! FLUX VARIATION IN CELL + F1=2.0*B*ABS(U1) + IF(F1.LE.1) THEN + P=1.0 + ISFIX=.TRUE. + ELSE + P=1.0/F1 + ISFIX=.FALSE. + ENDIF + ELSE + P=0.0 + ISFIX=.FALSE. + ENDIF + + ! CASE 0 <= P < 1 + ELSE + ISFIX=.TRUE. + ENDIF + + ! COMPUTE WEIGHTING FACTORS + W(1)=-P*TB + W(2)=1+P*TB +*---- +* LINEAR ORDER ADAPTIVE CALCULATIONS +*---- + ELSEIF(IELEM.EQ.2) THEN + CALL XABORT('SNADPT: LINEAR ORDER ADAPTIVE CALCULATIONS NOT' + 1 //'IMPLEMENTED YET') + ELSE + CALL XABORT('SNADPT: QUADRATIC AND HIGHER ORDER ADAPTIVE' + 1 //'CALCULATIONS NOT IMPLEMENTED YET') + ENDIF + + RETURN + END diff --git a/Dragon/src/SNDSA.f b/Dragon/src/SNDSA.f new file mode 100644 index 0000000..39da9f3 --- /dev/null +++ b/Dragon/src/SNDSA.f @@ -0,0 +1,936 @@ +*DECK SNDSA + SUBROUTINE SNDSA (KPSYS,INCONV,NGIND,IPTRK,IMPX,NGEFF,NREG, + 1 NBMIX,NUN,MAT,VOL,KEYFLX,KEYSPN,NUNSA,IELEMSA,ZCODE, + 2 FUNOLD,FUNKNO,NHEX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform a synthetic acceleration using BIVAC (2D) or TRIVAC (3D) +* for the discrete ordinates (SN) method using an SPn approximation. +* +*Copyright: +* Copyright (C) 2020 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. A. Calloo, A. Hebert and N. Martin +* +*Parameters: input +* KPSYS pointer to the assembly matrices. KPSYS is an array of +* directories. +* INCONV energy group convergence flag (set to .FALSE. if converged). +* NGIND energy group indices assign to the NGEFF set. +* IPTRK pointer to the tracking (L_TRACK signature). +* IMPX print flag (equal to zero for no print). +* NGEFF number of energy groups processed in parallel. +* NREG total number of regions for which specific values of the +* neutron flux and reactions rates are required. +* NBMIX number of mixtures. +* NUN total number of unknowns in vectors FUNKNO. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX position of averaged flux elements in FUNKNO vector. +* KEYSPN position of averaged flux elements for DSA correction. +* NUNSA number of unknowns in BIVAC/TRIVAC. +* IELEMSA degree of the RT spatial approximation for the DSA. +* ZCODE albedos. +* FUNOLD SN unknown vector at iteration kappa. +* NHEX number of hexagon. +* +*Parameters: input/output +* FUNKNO SN unknown vector at iteration kappa+1/2 (IN) and at +* iteration kappa+1,i.e., with DSA correction (OUT). +* +*Comments: +* FUNHLF is SN unknown vector at iteration kappa+1/2. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) KPSYS(NGEFF),IPTRK + INTEGER NGEFF,NGIND(NGEFF),IMPX,NREG,NBMIX,NUN, + > MAT(NREG),KEYFLX(NREG),KEYSPN(NREG),NUNSA,NHEX, + > IELEMSA + LOGICAL INCONV(NGEFF) + REAL VOL(NREG),ZCODE(6),FUNOLD(NUN,NGEFF),FUNKNO(NUN,NGEFF) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6,NSTATE=40,PI=3.141592654) + INTEGER IPAR(NSTATE),NLOZH,SPLTL,REM,SBMSH + LOGICAL LSHOOT + REAL RAT0 +* + INTEGER, ALLOCATABLE, DIMENSION(:) :: TMPKEY,ORIKEY + REAL, ALLOCATABLE, DIMENSION(:) :: SGAS + REAL, ALLOCATABLE, DIMENSION(:,:) :: FUNSA,SUNSA,FUNHLF +* + TYPE(C_PTR) DU_PTR,DE_PTR,W_PTR,DZ_PTR,U_PTR + REAL, POINTER, DIMENSION(:) :: DU,DE,W,DZ,U +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(FUNSA(NUNSA,NGEFF),SUNSA(NUNSA,NGEFF),FUNHLF(NUN,NGEFF)) +*---- +* RECOVER TRACKING INFORMATION +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',IPAR) + ITYPE=IPAR(6) + NSCT=IPAR(7) + IELEM=IPAR(8) + NDIM=IPAR(9) + LX=IPAR(12) + LY=IPAR(13) + LZ=IPAR(14) + ISOLVSA=IPAR(33) + ISPLH=1 + IF((ITYPE.EQ.8).OR.(ITYPE.EQ.9)) ISPLH=IPAR(26) + NLEG=0 + LL4=0 + IF(ITYPE.EQ.2) THEN + NLEG=IELEM + LL4 =LX*NSCT*NLEG + ELSE IF((ITYPE.EQ.5).OR.(ITYPE.EQ.8)) THEN + NLEG=IELEM*IELEM + LL4 =LY*LX*NSCT*NLEG + ELSE IF((ITYPE.EQ.7).OR.(ITYPE.EQ.9)) THEN + NLEG=IELEM*IELEM*IELEM + LL4 =LZ*LY*LX*NSCT*NLEG + ELSE + CALL XABORT('SNDSA: TYPE OF DISCRETIZATION NOT IMPLEMENTED.') + ENDIF +*---- +* INITIALISE DSA FLUX AND SOURCE ARRAYS. +*---- + FUNSA(:NUNSA,:NGEFF)=0.0 + SUNSA(:NUNSA,:NGEFF)=0.0 +*---- +* LOOP OVER ENERGY GROUPS. +*---- + DO 30 IING=1,NGEFF + IF(.NOT.INCONV(IING)) GO TO 30 + IF(IMPX.GT.1) WRITE(IUNOUT,'(/24H SNDSA: PROCESSING GROUP,I5, + 1 6H WITH ,A,1H.)') NGIND(IING),'SN/DSA' +*---- +* RECOVER WITHIN-GROUP SCATTERING CROSS SECTION. +*---- + CALL LCMLEN(KPSYS(IING),'DRAGON-TXSC',ILONG,ITYLCM) + IF(ILONG.NE.NBMIX+1) CALL XABORT('SNDSA: INVALID TXSC LENGTH.') + CALL LCMLEN(KPSYS(IING),'DRAGON-S0XSC',ILONG,ITYLCM) + NANI=ILONG/(NBMIX+1) + ALLOCATE(SGAS(ILONG)) + CALL LCMGET(KPSYS(IING),'DRAGON-S0XSC',SGAS) +*---- +* REBUILD KEYFLX FOR HEXAGONAL CASES +*---- + ! NLOZH - num. of loz. per hexagon + ! SBMSH - num. of submeshes per lozenge (integer) + ! SPLTL - split of the lozenge (ISPLH) + IF((ITYPE.EQ.8).OR.(ITYPE.EQ.9))THEN + ALLOCATE(TMPKEY(NREG),ORIKEY(NREG)) + TMPKEY(:) = 0 + ORIKEY(1:NREG) = KEYFLX(1:NREG) + IND = 0 + JND = 0 + NLOZH = 3*ISPLH**2 + SBMSH = NLOZH/3 + SPLTL = ISPLH + DO IZ=1,LZ + DO IH=1,NHEX + DO IM=1,SBMSH + REM=MOD(IM-1,SPLTL) + IF((REM.EQ.0).AND.(SBMSH.NE.1))THEN + JND = (IH-1)*NLOZH + SBMSH - (IM/SPLTL) + JND = JND + (IZ-1)*LX + ELSEIF((REM.NE.0).AND.(SBMSH.NE.1))THEN + JND = JND - (SBMSH*3) - SPLTL + ENDIF + DO ILZ=1,3 + IND = (IZ-1)*LX +(IH-1)*NLOZH +(IM-1)*3 +(ILZ-1) +1 + IF(SBMSH.EQ.1) JND = IND + TMPKEY(IND) = KEYFLX(JND) + JND = JND + SBMSH + ENDDO + ENDDO + ENDDO + ENDDO + KEYFLX(:) = TMPKEY(:) + DEALLOCATE(TMPKEY) + ENDIF +*---- +* COMPUTE THE SOURCE OF THE DSA EQUATION. +* Equivalency between moments of the flux for SN and SPn needs to be +* verified. +*---- + DO 20 IR=1,NREG + IBM=MAT(IR) + IF(IBM.LE.0) GO TO 20 + SIGS=SGAS(IBM+1) + DO 10 IEL=1,(IELEMSA**NDIM) + IND=KEYFLX(IR)+IEL-1 + JND=KEYSPN(IR)+IEL-1 + SUNSA(JND,IING)=SUNSA(JND,IING)+SIGS*(FUNKNO(IND,IING)- + > FUNOLD(IND,IING)) + 10 CONTINUE + 20 CONTINUE + DEALLOCATE(SGAS) + 30 CONTINUE +*---- +* SOLVE THE SA EQUATION USING A P1 METHOD. +*---- + CALL LCMSIX(IPTRK,'DSA',1) + + IF((ITYPE.EQ.7).OR.(ITYPE.EQ.9)) THEN + CALL TRIFLV(KPSYS,INCONV,NGIND,IPTRK,IMPX,1,NGEFF,NREG,NUNSA, + > KEYSPN,FUNSA,SUNSA) + ELSE + IF(ISOLVSA.EQ.1)THEN + CALL PNFLV(KPSYS,INCONV,NGIND,IPTRK,IMPX,1,NGEFF,NREG,NBMIX, + > NUNSA,MAT,VOL,KEYSPN,FUNSA,SUNSA) + ELSEIF(ISOLVSA.EQ.2)THEN + CALL TRIFLV(KPSYS,INCONV,NGIND,IPTRK,IMPX,1,NGEFF,NREG, + > NUNSA,KEYSPN,FUNSA,SUNSA) + ENDIF + ENDIF + CALL LCMSIX(IPTRK,' ',2) +*---- +* LOOP OVER ENERGY GROUPS. +*---- + RAT0=0.0 + DO 400 IING=1,NGEFF + IF(.NOT.INCONV(IING)) GO TO 400 +*-------- +* Upgrade zeroth and higher moments of the P0 SN solution, +* ie, isotropic fluxes + FUNHLF(:,IING)=FUNKNO(:,IING) + DO 171 IR=1,NREG + IF(MAT(IR).LE.0) GO TO 171 + DO IEL=1,NLEG + RAT0=0.0 + IF(IEL.EQ.1)THEN + INDSN=KEYFLX(IR) + INDPN=KEYSPN(IR) + FUNKNO(INDSN,IING)=FUNKNO(INDSN,IING)+FUNSA(INDPN,IING) + IF(FUNHLF(INDSN,IING).LT.1.0E-7)THEN + RAT0 =0.0 + ELSE + RAT0 =FUNSA(INDPN,IING)/FUNHLF(INDSN,IING) + ENDIF + ELSE + INDSN=KEYFLX(IR)+IEL-1 + FUNKNO(INDSN,IING)=(1+RAT0)*FUNHLF(INDSN,IING) + ENDIF + ENDDO + 171 CONTINUE +*-------- +* Upgrade zeroth and higher moments of the non-P0 SN solution, +* ie, anisotropic fluxes + DO 172 IR=1,NREG + IF(MAT(IR).LE.0) GO TO 172 + DO IEL=1,NLEG + DO IK =1,NSCT + IF(IK.EQ.1)THEN + INDSN=KEYFLX(IR) + INDPN=KEYSPN(IR) + IF(FUNHLF(INDSN,IING).LT.1.0E-7)THEN + RAT0 =0.0 + ELSE + RAT0 =FUNSA(INDPN,IING)/FUNHLF(INDSN,IING) + ENDIF + ELSE + INDSN=KEYFLX(IR)+IEL-1 + ((IK-1)*NLEG) + FUNKNO(INDSN,IING)=(1+RAT0)*FUNHLF(INDSN,IING) + ENDIF + ENDDO + ENDDO + 172 CONTINUE +*-------- +* UPGRADE BOUNDARY SURFACE FLUX IN 1D CARTESIAN CASES +*-------- + LSHOOT=.TRUE. + IF(IPAR(30).EQ.0) LSHOOT=.FALSE. + IF((ITYPE.EQ.2).AND.(.NOT.LSHOOT)) THEN + CALL LCMLEN(IPTRK,'U',NLF,ITYLCM) + CALL LCMGPD(IPTRK,'U',U_PTR) + CALL LCMGPD(IPTRK,'W',W_PTR) + CALL C_F_POINTER(U_PTR,U,(/ NPQ /)) + CALL C_F_POINTER(W_PTR,W,(/ NPQ /)) + IR=0 + DO II=1,LX + IR=IR+1 + IF(MAT(IR).EQ.0) GO TO 950 + IF(VOL(IR).EQ.0.0) GO TO 950 +*******XNEI- + IF((II.EQ.1).AND.(ZCODE(1).NE.0.0)) THEN + FHLF=0.0 + FONE=0.0 + SG=1.0 + DO IE=1,IELEM + INDSN=KEYFLX(IR)+IE-1 + FHLF = FHLF+SG*SQRT(REAL(2*IE-1))*FUNHLF(INDSN,IING) + FONE = FONE+SG*SQRT(REAL(2*IE-1))*FUNKNO(INDSN,IING) + SG=-SG + ENDDO + BHLF=0.0 + BONE=0.0 + TOTW=0.0 + DO M=1,NLF + IF(U(M).LT.0.0) THEN + IND1=LX*NSCT*IELEM + 1 + INDB=LX*NSCT*IELEM + M + BHLF=BHLF+W(M)*FUNHLF(INDB,IING)*1.0*(ZCODE(1)) + IF(FUNHLF(IND1,IING).NE.0.0) + > TOTW=TOTW+(W(M) * FUNHLF(INDB,IING)/FUNHLF(IND1,IING) ) + ENDIF + ENDDO + + IF(FHLF.NE.0.0) BONE=FONE*(BHLF/FHLF) + + DO M=1,NLF + IF(U(M).LT.0.0) THEN + IND1=LX*NSCT*IELEM + 1 + INDB=LX*NSCT*IELEM + M + IF(FUNHLF(INDB,IING).EQ.0.0)THEN + FUNKNO(INDB,IING)=0.0 + ELSE + IF(FUNHLF(IND1,IING).NE.0.0)THEN + FUNKNO(INDB,IING)= (BONE/TOTW)* + > FUNHLF(INDB,IING)/FUNHLF(IND1,IING) + ELSE + FUNKNO(INDB,IING)=FUNHLF(INDB,IING) + ENDIF + ENDIF + ENDIF + ENDDO + ENDIF +*******XNEI+ + IF((II.EQ.LX).AND.(ZCODE(2).NE.0.0)) THEN + FHLF=0.0 + FONE=0.0 + DO IE=1,IELEM + INDSN=KEYFLX(IR)+IE-1 + FHLF = FHLF+SQRT(REAL(2*IE-1))*FUNHLF(INDSN,IING) + FONE = FONE+SQRT(REAL(2*IE-1))*FUNKNO(INDSN,IING) + ENDDO + BHLF=0.0 + BONE=0.0 + TOTW=0.0 + DO M=1,NLF + IF(U(M).GT.0.0) THEN + IND1=LX*NSCT*IELEM + NLF + INDB=LX*NSCT*IELEM + M + BHLF=BHLF+W(M)*FUNHLF(INDB,IING)*1.0*(ZCODE(2)) + IF(FUNHLF(IND1,IING).NE.0.0) + > TOTW=TOTW+(W(M) * FUNHLF(INDB,IING)/FUNHLF(IND1,IING) ) + ! TOTW=TOTW+ABS(W(M)) + ENDIF + ENDDO + + IF(FHLF.NE.0.0) BONE=FONE*(BHLF/FHLF) + + DO M=1,NLF + IF(U(M).GT.0.0) THEN + IND1=LX*NSCT*IELEM + NLF + INDB=LX*NSCT*IELEM + M + IF(FUNHLF(INDB,IING).EQ.0.0)THEN + FUNKNO(INDB,IING)=0.0 + ELSE + IF(FUNHLF(IND1,IING).NE.0.0)THEN + FUNKNO(INDB,IING)= (BONE/TOTW)* + > FUNHLF(INDB,IING)/FUNHLF(IND1,IING) + ELSE + FUNKNO(INDB,IING)=FUNHLF(INDB,IING) + ENDIF + ENDIF + ENDIF + ENDDO + ENDIF + 950 CONTINUE + ENDDO +*-------- +* UPGRADE BOUNDARY SURFACE FLUX IN 2D CARTESIAN CASES +*-------- + ELSEIF(ITYPE.EQ.5) THEN + CALL LCMLEN(IPTRK,'DU',NPQ,ITYLCM) + CALL LCMGPD(IPTRK,'DU',DU_PTR) + CALL LCMGPD(IPTRK,'DE',DE_PTR) + CALL LCMGPD(IPTRK,'W',W_PTR) + CALL C_F_POINTER(DU_PTR,DU,(/ NPQ /)) + CALL C_F_POINTER(DE_PTR,DE,(/ NPQ /)) + CALL C_F_POINTER(W_PTR,W,(/ NPQ /)) + IR=0 + DO 161 JJ=1,LY + DO 160 II=1,LX + IR=IR+1 + IF(MAT(IR).EQ.0) GO TO 160 + IF(VOL(IR).EQ.0.0) GO TO 150 +*******XNEI- + IF((II.EQ.1).AND.(ZCODE(1).NE.0.0)) THEN + DO JE=1,IELEM + FHLF=0.0 + FONE=0.0 + SG=1.0 + DO IE=1,IELEM + INDSN=KEYFLX(IR)+(JE-1)*IELEM+IE-1 + FHLF = FHLF+SG*SQRT(REAL(2*IE-1))*FUNHLF(INDSN,IING) + FONE = FONE+SG*SQRT(REAL(2*IE-1))*FUNKNO(INDSN,IING) + SG=-SG + ENDDO + BHLF=0.0 + BONE=0.0 + TOTW=0.0 + ICNT=0 + DO M=1,NPQ + IF((DU(M).LT.0.0).AND.(W(M).NE.0.0)) THEN + IF(ICNT.EQ.0) ICNT=M + IND1 = LL4 + (ICNT-1)*LY*IELEM + (JJ-1)*IELEM + JE + INDB = LL4 + (M-1)*LY*IELEM + (JJ-1)*IELEM + JE + BHLF=BHLF + 2.0*W(M)*FUNHLF(INDB,IING)*1.0*(ZCODE(1)) + IF(FUNHLF(IND1,IING).NE.0.0) + > TOTW=TOTW+(2.0*W(M)*FUNHLF(INDB,IING)/FUNHLF(IND1,IING)) + ENDIF + ENDDO + + IF(FHLF.NE.0.0) BONE=FONE*(BHLF/FHLF) + + DO M=1,NPQ + IF((DU(M).LT.0.0).AND.(W(M).NE.0.0)) THEN + IND1 = LL4 + (ICNT-1)*LY*IELEM + (JJ-1)*IELEM + JE + INDB = LL4 + (M-1)*LY*IELEM + (JJ-1)*IELEM + JE + IF(FUNHLF(INDB,IING).EQ.0.0)THEN + FUNKNO(INDB,IING)=0.0 + ELSE + IF(FUNHLF(IND1,IING).NE.0.0)THEN + FUNKNO(INDB,IING)= (BONE/TOTW)* + > FUNHLF(INDB,IING)/FUNHLF(IND1,IING) + ELSE + FUNKNO(INDB,IING)=FUNHLF(INDB,IING) + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + ENDIF +*******XNEI+ + IF((II.EQ.LX).AND.(ZCODE(2).NE.0.0)) THEN + DO JE=1,IELEM + FHLF=0.0 + FONE=0.0 + DO IE=1,IELEM + INDSN=KEYFLX(IR)+(JE-1)*IELEM+IE-1 + FHLF = FHLF+SQRT(REAL(2*IE-1))*FUNHLF(INDSN,IING) + FONE = FONE+SQRT(REAL(2*IE-1))*FUNKNO(INDSN,IING) + ENDDO + BHLF=0.0 + BONE=0.0 + TOTW=0.0 + ICNT=0 + DO M=1,NPQ + IF((DU(M).GT.0.0).AND.(W(M).NE.0.0)) THEN + IF(ICNT.EQ.0) ICNT=M + IND1 = LL4 + (ICNT-1)*LY*IELEM + (JJ-1)*IELEM + JE + INDB = LL4 + (M-1)*LY*IELEM + (JJ-1)*IELEM + JE + BHLF=BHLF + 2.0*W(M)*FUNHLF(INDB,IING)*1.0*(ZCODE(2)) + IF(FUNHLF(IND1,IING).NE.0.0) + > TOTW=TOTW+(2.0*W(M)*FUNHLF(INDB,IING)/FUNHLF(IND1,IING)) + ENDIF + ENDDO + + IF(FHLF.NE.0.0) BONE=FONE*(BHLF/FHLF) + + DO M=1,NPQ + IF((DU(M).GT.0.0).AND.(W(M).NE.0.0)) THEN + IND1 = LL4 + (ICNT-1)*LY*IELEM + (JJ-1)*IELEM + JE + INDB = LL4 + (M-1)*LY*IELEM + (JJ-1)*IELEM + JE + IF(FUNHLF(INDB,IING).EQ.0.0)THEN + FUNKNO(INDB,IING)=0.0 + ELSE + IF(FUNHLF(IND1,IING).NE.0.0)THEN + FUNKNO(INDB,IING)= (BONE/TOTW)* + > FUNHLF(INDB,IING)/FUNHLF(IND1,IING) + ELSE + FUNKNO(INDB,IING)=FUNHLF(INDB,IING) + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + ENDIF +******XNEJ- + IF((JJ.EQ.1).AND.(ZCODE(3).NE.0.0)) THEN + DO IE=1,IELEM + FHLF=0.0 + FONE=0.0 + SG=1.0 + DO JE=1,IELEM + INDSN=KEYFLX(IR)+(JE-1)*IELEM+IE-1 + FHLF = FHLF+SG*SQRT(REAL(2*JE-1))*FUNHLF(INDSN,IING) + FONE = FONE+SG*SQRT(REAL(2*JE-1))*FUNKNO(INDSN,IING) + SG=-SG + ENDDO + BHLF=0.0 + BONE=0.0 + TOTW=0.0 + ICNT=0 + DO M=1,NPQ + IF((DE(M).LT.0.0).AND.(W(M).NE.0.0)) THEN + IF(ICNT.EQ.0) ICNT=M + IND1=LL4+IELEM*LY*NPQ+(ICNT-1)*LX*IELEM+(II-1)*IELEM+IE + INDB=LL4+IELEM*LY*NPQ+ (M-1)*LX*IELEM+(II-1)*IELEM+IE + BHLF=BHLF + 2.0*W(M)*FUNHLF(INDB,IING)*1.0*(ZCODE(3)) + IF(FUNHLF(IND1,IING).NE.0.0) + > TOTW=TOTW+(2.0*W(M)*FUNHLF(INDB,IING)/FUNHLF(IND1,IING)) + ENDIF + ENDDO + + IF(FHLF.NE.0.0) BONE=FONE*(BHLF/FHLF) + + DO M=1,NPQ + IF((DE(M).LT.0.0).AND.(W(M).NE.0.0)) THEN + IND1=LL4+IELEM*LY*NPQ+(ICNT-1)*LX*IELEM+(II-1)*IELEM+IE + INDB=LL4+IELEM*LY*NPQ+ (M-1)*LX*IELEM+(II-1)*IELEM+IE + IF(FUNHLF(INDB,IING).EQ.0.0)THEN + FUNKNO(INDB,IING)=0.0 + ELSE + IF(FUNHLF(IND1,IING).NE.0.0)THEN + FUNKNO(INDB,IING)= (BONE/TOTW)* + > FUNHLF(INDB,IING)/FUNHLF(IND1,IING) + ELSE + FUNKNO(INDB,IING)=FUNHLF(INDB,IING) + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + ENDIF +*****XNEJ+ + IF((JJ.EQ.LY).AND.(ZCODE(4).NE.0.0)) THEN + DO IE=1,IELEM + FHLF=0.0 + FONE=0.0 + DO JE=1,IELEM + INDSN=KEYFLX(IR)+(JE-1)*IELEM+IE-1 + FHLF = FHLF+SQRT(REAL(2*JE-1))*FUNHLF(INDSN,IING) + FONE = FONE+SQRT(REAL(2*JE-1))*FUNKNO(INDSN,IING) + ENDDO + BHLF=0.0 + BONE=0.0 + TOTW=0.0 + ICNT=0 + DO M=1,NPQ + IF((DE(M).GT.0.0).AND.(W(M).NE.0.0)) THEN + IF(ICNT.EQ.0) ICNT=M + IND1=LL4+IELEM*LY*NPQ+(ICNT-1)*LX*IELEM+(II-1)*IELEM+IE + INDB=LL4+IELEM*LY*NPQ+ (M-1)*LX*IELEM+(II-1)*IELEM+IE + BHLF=BHLF + 2.0*W(M)*FUNHLF(INDB,IING)*1.0*(ZCODE(4)) + IF(FUNHLF(IND1,IING).NE.0.0) + > TOTW=TOTW+(2.0*W(M)*FUNHLF(INDB,IING)/FUNHLF(IND1,IING)) + ENDIF + ENDDO + + IF(FHLF.NE.0.0) BONE=FONE*(BHLF/FHLF) + + DO M=1,NPQ + IF((DE(M).GT.0.0).AND.(W(M).NE.0.0)) THEN + IND1=LL4+IELEM*LY*NPQ+(ICNT-1)*LX*IELEM+(II-1)*IELEM+IE + INDB=LL4+IELEM*LY*NPQ+ (M-1)*LX*IELEM+(II-1)*IELEM+IE + IF(FUNHLF(INDB,IING).EQ.0.0)THEN + FUNKNO(INDB,IING)=0.0 + ELSE + IF(FUNHLF(IND1,IING).NE.0.0)THEN + FUNKNO(INDB,IING)= (BONE/TOTW)* + > FUNHLF(INDB,IING)/FUNHLF(IND1,IING) + ELSE + FUNKNO(INDB,IING)=FUNHLF(INDB,IING) + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + ENDIF + 150 CONTINUE + 160 CONTINUE + 161 CONTINUE +*-------- +* UPGRADE BOUNDARY SURFACE FLUX IN 3D CARTESIAN CASES +*-------- + ELSE IF(ITYPE.EQ.7) THEN + CALL LCMLEN(IPTRK,'DU',NPQ,ITYLCM) + CALL LCMGPD(IPTRK,'DU',DU_PTR) + CALL LCMGPD(IPTRK,'DE',DE_PTR) + CALL LCMGPD(IPTRK,'DZ',DZ_PTR) + CALL LCMGPD(IPTRK,'W',W_PTR) + CALL C_F_POINTER(DU_PTR,DU,(/ NPQ /)) + CALL C_F_POINTER(DE_PTR,DE,(/ NPQ /)) + CALL C_F_POINTER(W_PTR,W,(/ NPQ /)) + CALL C_F_POINTER(DZ_PTR,DZ,(/ NPQ /)) + IR=0 + DO 182 KK=1,LZ + DO 181 JJ=1,LY + DO 180 II=1,LX + IR=IR+1 + IF(MAT(IR).EQ.0) GO TO 180 + IF(VOL(IR).EQ.0.0) GO TO 180 +******** XNEI- + IF((II.EQ.1).AND.(ZCODE(1).NE.0.0)) THEN + DO KE=1,IELEM + DO JE=1,IELEM + FHLF=0.0 + FONE=0.0 + SG=1.0 + DO IE=1,IELEM + INDSN=KEYFLX(IR)+(KE-1)*IELEM**2+(JE-1)*IELEM+IE-1 + FHLF = FHLF+SG*SQRT(REAL(2*IE-1))*FUNHLF(INDSN,IING) + FONE = FONE+SG*SQRT(REAL(2*IE-1))*FUNKNO(INDSN,IING) + SG=-SG + ENDDO + BHLF=0.0 + BONE=0.0 + TOTW=0.0 + ICNT=0 + DO M=1,NPQ + IF((DU(M).LT.0.0).AND.(W(M).NE.0.0)) THEN + IF(ICNT.EQ.0) ICNT=M + IND1=LL4+ (ICNT-1)*LY*LZ*IELEM**2 + (KK-1)*LY*IELEM**2 + > + (JJ-1)*IELEM**2 + (KE-1)*IELEM + JE + INDB=LL4+ (M-1)*LY*LZ*IELEM**2 + (KK-1)*LY*IELEM**2 + > + (JJ-1)*IELEM**2 + (KE-1)*IELEM + JE + BHLF=BHLF + W(M)*FUNHLF(INDB,IING)*1.0*(ZCODE(1)) + IF(FUNHLF(IND1,IING).NE.0.0) + > TOTW=TOTW+(W(M)*FUNHLF(INDB,IING)/FUNHLF(IND1,IING)) + ENDIF + ENDDO + + IF(FHLF.NE.0.0) BONE=FONE*(BHLF/FHLF) + + DO M=1,NPQ + IF((DU(M).LT.0.0).AND.(W(M).NE.0.0)) THEN + IND1=LL4+ (ICNT-1)*LY*LZ*IELEM**2 + (KK-1)*LY*IELEM**2 + > + (JJ-1)*IELEM**2 + (KE-1)*IELEM + JE + INDB=LL4+ (M-1)*LY*LZ*IELEM**2 + (KK-1)*LY*IELEM**2 + > + (JJ-1)*IELEM**2 + (KE-1)*IELEM + JE + IF(FUNHLF(INDB,IING).EQ.0.0)THEN + FUNKNO(INDB,IING)=0.0 + ELSE + IF(FUNHLF(IND1,IING).NE.0.0)THEN + FUNKNO(INDB,IING)= (BONE/TOTW)* + > FUNHLF(INDB,IING)/FUNHLF(IND1,IING) + ELSE + FUNKNO(INDB,IING)=FUNHLF(INDB,IING) + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF +******** XNEI+ + IF((II.EQ.LX).AND.(ZCODE(2).NE.0.0)) THEN + DO KE=1,IELEM + DO JE=1,IELEM + FHLF=0.0 + FONE=0.0 + DO IE=1,IELEM + INDSN=KEYFLX(IR)+(KE-1)*IELEM**2+(JE-1)*IELEM+IE-1 + FHLF = FHLF+SQRT(REAL(2*IE-1))*FUNHLF(INDSN,IING) + FONE = FONE+SQRT(REAL(2*IE-1))*FUNKNO(INDSN,IING) + ENDDO + BHLF=0.0 + BONE=0.0 + TOTW=0.0 + ICNT=0 + DO M=1,NPQ + IF((DU(M).GT.0.0).AND.(W(M).NE.0.0)) THEN + IF(ICNT.EQ.0) ICNT=M + IND1=LL4+ (ICNT-1)*LY*LZ*IELEM**2 + (KK-1)*LY*IELEM**2 + > + (JJ-1)*IELEM**2 + (KE-1)*IELEM + JE + INDB=LL4+ (M-1)*LY*LZ*IELEM**2 + (KK-1)*LY*IELEM**2 + > + (JJ-1)*IELEM**2 + (KE-1)*IELEM + JE + BHLF=BHLF + W(M)*FUNHLF(INDB,IING)*1.0*(ZCODE(2)) + IF(FUNHLF(IND1,IING).NE.0.0) + > TOTW=TOTW+(W(M)*FUNHLF(INDB,IING)/FUNHLF(IND1,IING)) + ENDIF + ENDDO + + IF(FHLF.NE.0.0) BONE=FONE*(BHLF/FHLF) + + DO M=1,NPQ + IF((DU(M).GT.0.0).AND.(W(M).NE.0.0)) THEN + IND1=LL4+ (ICNT-1)*LY*LZ*IELEM**2 + (KK-1)*LY*IELEM**2 + > + (JJ-1)*IELEM**2 + (KE-1)*IELEM + JE + INDB=LL4+ (M-1)*LY*LZ*IELEM**2 + (KK-1)*LY*IELEM**2 + > + (JJ-1)*IELEM**2 + (KE-1)*IELEM + JE + IF(FUNHLF(INDB,IING).EQ.0.0)THEN + FUNKNO(INDB,IING)=0.0 + ELSE + IF(FUNHLF(IND1,IING).NE.0.0)THEN + FUNKNO(INDB,IING)= (BONE/TOTW)* + > FUNHLF(INDB,IING)/FUNHLF(IND1,IING) + ELSE + FUNKNO(INDB,IING)=FUNHLF(INDB,IING) + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF +***********XNEJ- + IF((JJ.EQ.1).AND.(ZCODE(3).NE.0.0)) THEN + DO KE=1,IELEM + DO IE=1,IELEM + FHLF=0.0 + FONE=0.0 + SG=1.0 + DO JE=1,IELEM + INDSN=KEYFLX(IR)+(KE-1)*IELEM**2+(JE-1)*IELEM+IE-1 + FHLF = FHLF+SG*SQRT(REAL(2*IE-1))*FUNHLF(INDSN,IING) + FONE = FONE+SG*SQRT(REAL(2*IE-1))*FUNKNO(INDSN,IING) + SG=-SG + ENDDO + BHLF=0.0 + BONE=0.0 + TOTW=0.0 + ICNT=0 + DO M=1,NPQ + IF((DE(M).LT.0.0).AND.(W(M).NE.0.0)) THEN + IF(ICNT.EQ.0) ICNT=M + IND1=LL4+ LY*LZ*NPQ*IELEM**2 + (ICNT-1)*LX*LZ*IELEM**2 + > + (KK-1)*LX*IELEM**2 + (II-1)*IELEM**2 + (KE-1)*IELEM + > + IE + INDB=LL4+ LY*LZ*NPQ*IELEM**2 + (M-1)*LX*LZ*IELEM**2 + > + (KK-1)*LX*IELEM**2 + (II-1)*IELEM**2 + (KE-1)*IELEM + > + IE + BHLF=BHLF + W(M)*FUNHLF(INDB,IING)*1.0*(ZCODE(3)) + IF(FUNHLF(IND1,IING).NE.0.0) + > TOTW=TOTW+(W(M)*FUNHLF(INDB,IING)/FUNHLF(IND1,IING)) + ENDIF + ENDDO + + IF(FHLF.NE.0.0) BONE=FONE*(BHLF/FHLF) + + DO M=1,NPQ + IF((DE(M).LT.0.0).AND.(W(M).NE.0.0)) THEN + IND1=LL4+ LY*LZ*NPQ*IELEM**2 + (ICNT-1)*LX*LZ*IELEM**2 + > + (KK-1)*LX*IELEM**2 + (II-1)*IELEM**2 + (KE-1)*IELEM + > + IE + INDB=LL4+ LY*LZ*NPQ*IELEM**2 + (M-1)*LX*LZ*IELEM**2 + > + (KK-1)*LX*IELEM**2 + (II-1)*IELEM**2 + (KE-1)*IELEM + > + IE + IF(FUNHLF(INDB,IING).EQ.0.0)THEN + FUNKNO(INDB,IING)=0.0 + ELSE + IF(FUNHLF(IND1,IING).NE.0.0)THEN + FUNKNO(INDB,IING)= (BONE/TOTW)* + > FUNHLF(INDB,IING)/FUNHLF(IND1,IING) + ELSE + FUNKNO(INDB,IING)=FUNHLF(INDB,IING) + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF +*******XNEJ + + IF((JJ.EQ.LY).AND.(ZCODE(4).NE.0.0)) THEN + DO KE=1,IELEM + DO IE=1,IELEM + FHLF=0.0 + FONE=0.0 + DO JE=1,IELEM + INDSN=KEYFLX(IR)+(KE-1)*IELEM**2+(JE-1)*IELEM+IE-1 + FHLF = FHLF+SQRT(REAL(2*IE-1))*FUNHLF(INDSN,IING) + FONE = FONE+SQRT(REAL(2*IE-1))*FUNKNO(INDSN,IING) + ENDDO + BHLF=0.0 + BONE=0.0 + TOTW=0.0 + ICNT=0 + DO M=1,NPQ + IF((DE(M).GT.0.0).AND.(W(M).NE.0.0)) THEN + IF(ICNT.EQ.0) ICNT=M + IND1=LL4+ LY*LZ*NPQ*IELEM**2 + (ICNT-1)*LX*LZ*IELEM**2 + > + (KK-1)*LX*IELEM**2 + (II-1)*IELEM**2 + (KE-1)*IELEM + > + IE + INDB=LL4+ LY*LZ*NPQ*IELEM**2 + (M-1)*LX*LZ*IELEM**2 + > + (KK-1)*LX*IELEM**2 + (II-1)*IELEM**2 + (KE-1)*IELEM + > + IE + BHLF=BHLF + W(M)*FUNHLF(INDB,IING)*1.0*(ZCODE(4)) + IF(FUNHLF(IND1,IING).NE.0.0) + > TOTW=TOTW+(W(M)*FUNHLF(INDB,IING)/FUNHLF(IND1,IING)) + ENDIF + ENDDO + + IF(FHLF.NE.0.0) BONE=FONE*(BHLF/FHLF) + + DO M=1,NPQ + IF((DE(M).GT.0.0).AND.(W(M).NE.0.0)) THEN + IND1=LL4+ LY*LZ*NPQ*IELEM**2 + (ICNT-1)*LX*LZ*IELEM**2 + > + (KK-1)*LX*IELEM**2 + (II-1)*IELEM**2 + (KE-1)*IELEM + > + IE + INDB=LL4+ LY*LZ*NPQ*IELEM**2 + (M-1)*LX*LZ*IELEM**2 + > + (KK-1)*LX*IELEM**2 + (II-1)*IELEM**2 + (KE-1)*IELEM + > + IE + IF(FUNHLF(INDB,IING).EQ.0.0)THEN + FUNKNO(INDB,IING)=0.0 + ELSE + IF(FUNHLF(IND1,IING).NE.0.0)THEN + FUNKNO(INDB,IING)= (BONE/TOTW)* + > FUNHLF(INDB,IING)/FUNHLF(IND1,IING) + ELSE + FUNKNO(INDB,IING)=FUNHLF(INDB,IING) + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF +********* XNEK - + IF((KK.EQ.1).AND.(ZCODE(5).NE.0.0)) THEN + DO JE=1,IELEM + DO IE=1,IELEM + FHLF=0.0 + FONE=0.0 + SG=1.0 + DO KE=1,IELEM + INDSN=KEYFLX(IR)+(KE-1)*IELEM**2+(JE-1)*IELEM+IE-1 + FHLF = FHLF+SG*SQRT(REAL(2*IE-1))*FUNHLF(INDSN,IING) + FONE = FONE+SG*SQRT(REAL(2*IE-1))*FUNKNO(INDSN,IING) + SG=-SG + ENDDO + BHLF=0.0 + BONE=0.0 + TOTW=0.0 + ICNT=0 + + DO M=1,NPQ + IF((DZ(M).LT.0.0).AND.(W(M).NE.0.0)) THEN + IF(ICNT.EQ.0) ICNT=M + IND1=LL4+ LY*LZ*NPQ*IELEM**2 + LX*LZ*NPQ*IELEM**2 + > + (ICNT-1)*LX*LY*IELEM**2 + (JJ-1)*LX*IELEM**2 + > + (II-1)*IELEM**2 + (JE-1)*IELEM + IE + INDB=LL4+ LY*LZ*NPQ*IELEM**2 + LX*LZ*NPQ*IELEM**2 + > + (M-1)*LX*LY*IELEM**2 + (JJ-1)*LX*IELEM**2 + > + (II-1)*IELEM**2 + (JE-1)*IELEM + IE + BHLF=BHLF + W(M)*FUNHLF(INDB,IING)*1.0*(ZCODE(5)) + IF(FUNHLF(IND1,IING).NE.0.0) + > TOTW=TOTW+(W(M)*FUNHLF(INDB,IING)/FUNHLF(IND1,IING)) + ENDIF + ENDDO + + IF(FHLF.NE.0.0) BONE=FONE*(BHLF/FHLF) + + DO M=1,NPQ + IF((DZ(M).LT.0.0).AND.(W(M).NE.0.0)) THEN + IND1=LL4+ LY*LZ*NPQ*IELEM**2 + LX*LZ*NPQ*IELEM**2 + > + (ICNT-1)*LX*LY*IELEM**2 + (JJ-1)*LX*IELEM**2 + > + (II-1)*IELEM**2 + (JE-1)*IELEM + IE + INDB=LL4+ LY*LZ*NPQ*IELEM**2 + LX*LZ*NPQ*IELEM**2 + > + (M-1)*LX*LY*IELEM**2 + (JJ-1)*LX*IELEM**2 + > + (II-1)*IELEM**2 + (JE-1)*IELEM + IE + IF(FUNHLF(INDB,IING).EQ.0.0)THEN + FUNKNO(INDB,IING)=0.0 + ELSE + IF(FUNHLF(IND1,IING).NE.0.0)THEN + FUNKNO(INDB,IING)= (BONE/TOTW)* + > FUNHLF(INDB,IING)/FUNHLF(IND1,IING) + ELSE + FUNKNO(INDB,IING)=FUNHLF(INDB,IING) + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF +********** XNEK + + IF((KK.EQ.LZ).AND.(ZCODE(6).NE.0.0)) THEN + DO JE=1,IELEM + DO IE=1,IELEM + FHLF=0.0 + FONE=0.0 + DO KE=1,IELEM + INDSN=KEYFLX(IR)+(KE-1)*IELEM**2+(JE-1)*IELEM+IE-1 + FHLF = FHLF+SQRT(REAL(2*IE-1))*FUNHLF(INDSN,IING) + FONE = FONE+SQRT(REAL(2*IE-1))*FUNKNO(INDSN,IING) + ENDDO + BHLF=0.0 + BONE=0.0 + TOTW=0.0 + ICNT=0 + + DO M=1,NPQ + IF((DZ(M).GT.0.0).AND.(W(M).NE.0.0)) THEN + IF(ICNT.EQ.0) ICNT=M + IND1=LL4+ LY*LZ*NPQ*IELEM**2 + LX*LZ*NPQ*IELEM**2 + > + (ICNT-1)*LX*LY*IELEM**2 + (JJ-1)*LX*IELEM**2 + > + (II-1)*IELEM**2 + (JE-1)*IELEM + IE + INDB=LL4+ LY*LZ*NPQ*IELEM**2 + LX*LZ*NPQ*IELEM**2 + > + (M-1)*LX*LY*IELEM**2 + (JJ-1)*LX*IELEM**2 + > + (II-1)*IELEM**2 + (JE-1)*IELEM + IE + BHLF=BHLF + W(M)*FUNHLF(INDB,IING)*1.0*(ZCODE(6)) + IF(FUNHLF(IND1,IING).NE.0.0) + > TOTW=TOTW+(W(M)*FUNHLF(INDB,IING)/FUNHLF(IND1,IING)) + ENDIF + ENDDO + + IF(FHLF.NE.0.0) BONE=FONE*(BHLF/FHLF) + + DO M=1,NPQ + IF((DZ(M).GT.0.0).AND.(W(M).NE.0.0)) THEN + IND1=LL4+ LY*LZ*NPQ*IELEM**2 + LX*LZ*NPQ*IELEM**2 + > + (ICNT-1)*LX*LY*IELEM**2 + (JJ-1)*LX*IELEM**2 + > + (II-1)*IELEM**2 + (JE-1)*IELEM + IE + INDB=LL4+ LY*LZ*NPQ*IELEM**2 + LX*LZ*NPQ*IELEM**2 + > + (M-1)*LX*LY*IELEM**2 + (JJ-1)*LX*IELEM**2 + > + (II-1)*IELEM**2 + (JE-1)*IELEM + IE + IF(FUNHLF(INDB,IING).EQ.0.0)THEN + FUNKNO(INDB,IING)=0.0 + ELSE + IF(FUNHLF(IND1,IING).NE.0.0)THEN + FUNKNO(INDB,IING)= (BONE/TOTW)* + > FUNHLF(INDB,IING)/FUNHLF(IND1,IING) + ELSE + FUNKNO(INDB,IING)=FUNHLF(INDB,IING) + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF + 180 CONTINUE + 181 CONTINUE + 182 CONTINUE + ENDIF +*-------- +* PRINT COMPLETE UNKNOWN VECTOR. +*-------- + IF(IMPX.GT.4) THEN + WRITE(IUNOUT,700) IING + WRITE(IUNOUT,'(1P,4(5X,E15.7))') (FUNKNO(:,IING)) + ENDIF +* + 400 CONTINUE +*---- +* RECUPERATE ORIGINAL KEYFLX FOR HEXAGONAL CASES +*---- + IF((ITYPE.EQ.8).OR.(ITYPE.EQ.9))THEN + KEYFLX(1:NREG) = ORIKEY(1:NREG) + DEALLOCATE(ORIKEY) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SUNSA,FUNSA,FUNHLF) + RETURN + 700 FORMAT(//40H SNDSA: A F T E R D S A C O R R. (,I5,3H ):) + END diff --git a/Dragon/src/SNEST.f b/Dragon/src/SNEST.f new file mode 100644 index 0000000..0f3f52a --- /dev/null +++ b/Dragon/src/SNEST.f @@ -0,0 +1,169 @@ +*DECK SNEST + SUBROUTINE SNEST (IPTRK,IMPX,NREG,NUN,MAT,IG,KEYFLX,KEYSPN, + 1 FUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Rearrange SPn flux in the Sn order so that SPn can be used to +* initialise Sn calculation. Use SPn flux to obtain rough estimate +* of boundary fluxes. +* +*Copyright: +* Copyright (C) 2020 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. A. Calloo +* +*Parameters: input +* IPTRK pointer to the tracking (L_TRACK signature). +* IMPX print level. +* NREG total number of regions for which specific values of the +* neutron flux and reactions rates are required. +* NUN total number of unknowns in vectors SUNKNO and FUNKNO. +* MAT index-number of the mixture type assigned to each volume. +* IG group number. +* KEYFLX position of averaged flux elements in FUNKNO vector. +* KEYSPN position of SPn unknowns in FUNKNO vector. +* +*Parameters: input/output +* FUNKNO SPn (in) / SN (out) unknown vector. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER IMPX,NREG,NUN,MAT(NREG),IG,KEYFLX(NREG),KEYSPN(NREG) + REAL FUNKNO(NUN) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6,NSTATE=40) + INTEGER ISTRK(NSTATE),NLOZH,SPLTL,SBMSH,REM,ISPLH + REAL ZCODE(6) +* + INTEGER, ALLOCATABLE, DIMENSION(:) :: TMPKEY,ORIKEY + REAL, ALLOCATABLE, DIMENSION(:) :: FUNSPN +* +*---- +* RECOVER TRACKING INFORMATION +*---- + CALL LCMGET(IPTRK,'ZCODE',ZCODE) + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTRK) + ITYPE=ISTRK(6) + NSCT=ISTRK(7) + IELEM=ISTRK(8) + NDIM=ISTRK(9) + LL4=ISTRK(11) + LX=ISTRK(12) + LY=ISTRK(13) + LZ=ISTRK(14) + ISPLH=1 + NHEX=1 + IF((ITYPE.EQ.8).OR.(ITYPE.EQ.9)) THEN + ISPLH=ISTRK(26) + NHEX =LX/(3*ISPLH**2) + ENDIF +*---- +* PARAMETER VALIDATION +*---- + IF((KEYSPN(NREG)).GT.LL4)THEN + CALL XABORT('SNEST: MORE SPN UNKNOWNS THAN SN UNKNOWNS. ' + 1 //'CANNOT GUARANTEE INTEGRITY OF IMPORTED SOLUTION. ' + 2 //'CONSIDER INCREASING SPATIAL ORDER FOR SN OR DECREASING ' + 3 //'SPATIAL ORDER FOR SPN/DIFF.') + ENDIF + IF((ITYPE.NE.2).AND.(ITYPE.NE.5).AND.(ITYPE.NE.7).AND. + 1 (ITYPE.NE.8).AND.(ITYPE.NE.9))CALL XABORT('SNEST: TYPE ' + 2 //'OF DISCRETIZATION NOT IMPLEMENTED.') +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(FUNSPN(NUN)) +*---- +* PRINT IMPORTED FLUX +*---- + IF(IMPX.GT.5) THEN + WRITE(IUNOUT,'(//33H I M P O R T E D F L U X E S (,I5, + 1 3H ):)') IG + WRITE(IUNOUT,'(1P,4(5X,E15.7))') (FUNKNO(I),I=1,NUN) + ENDIF +* +*---- +* REBUILD KEYFLX FOR 2D HEXAGONAL CASE +*---- + ! NLOZH - num. of loz. per hexagon + ! SBMSH - num. of submeshes per lozenge (integer) + ! SPLTL - split of the lozenge (ISPLH) + IF((ITYPE.EQ.8).OR.(ITYPE.EQ.9))THEN + ALLOCATE(TMPKEY(NREG),ORIKEY(NREG)) + TMPKEY(:) = 0 + ORIKEY(1:NREG) = KEYFLX(1:NREG) + IND = 0 + JND = 0 + NLOZH = 3*ISPLH**2 + SBMSH = NLOZH/3 + SPLTL = ISPLH + DO IZ=1,LZ + DO IH=1,NHEX + DO IM=1,SBMSH + REM=MOD(IM-1,SPLTL) + IF((REM.EQ.0).AND.(SBMSH.NE.1))THEN + JND = (IH-1)*NLOZH + SBMSH - (IM/SPLTL) + JND = JND + (IZ-1)*LX + ELSEIF((REM.NE.0).AND.(SBMSH.NE.1))THEN + JND = JND - (SBMSH*3) - SPLTL + ENDIF + DO ILZ=1,3 + IND = (IZ-1)*LX +(IH-1)*NLOZH +(IM-1)*3 +(ILZ-1) +1 + IF(SBMSH.EQ.1) JND = IND + TMPKEY(IND) = KEYFLX(JND) + JND = JND + SBMSH + ENDDO + ENDDO + ENDDO + ENDDO + KEYFLX(:) = TMPKEY(:) + DEALLOCATE(TMPKEY) + ENDIF +* +*---- +* REARRANGE SPN FLUX IN SN ORDER, FOR P0 ISOTROPIC FLUX ONLY +*---- + FUNSPN(1:NUN) = FUNKNO(1:NUN) + FUNKNO(1:NUN) = 0.0 + + DO 100 IR=1,NREG + IF(MAT(IR).LE.0) GO TO 100 + INDSN=KEYFLX(IR) + INDPN=KEYSPN(IR) + FUNKNO(INDSN)=FUNSPN(INDPN) + 100 CONTINUE +* +*---- +* RECUPERATE ORIGINAL KEYFLX FOR HEXAGONAL CASES +*---- + IF((ITYPE.EQ.8).OR.(ITYPE.EQ.9))THEN + KEYFLX(1:NREG) = ORIKEY(1:NREG) + DEALLOCATE(ORIKEY) + ENDIF +*---- +* PRINT REARRANGED FLUX +*---- + IF(IMPX.GT.3) THEN + WRITE(IUNOUT,'(//37H R E A R R A N G E D F L U X E S (,I5, + 1 3H ):)') IG + WRITE(IUNOUT,'(1P,4(5X,E15.7))') (FUNKNO(I),I=1,NUN) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(FUNSPN) + RETURN + END diff --git a/Dragon/src/SNF.f b/Dragon/src/SNF.f new file mode 100644 index 0000000..f8a1c90 --- /dev/null +++ b/Dragon/src/SNF.f @@ -0,0 +1,257 @@ +*DECK SNF + SUBROUTINE SNF(KPSYS,IPTRK,IFTRAK,IMPX,NGEFF,NGIND,IDIR,NREG, + 1 NBMIX,NUN,MAT,VOL,KEYFLX,FUNKNO,SUNKNO,TITR,NBS,KPSOU1,KPSOU2, + 2 FLUXC,EVALRHO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solve N-group transport equation for fluxes using the discrete +* ordinates (SN) method. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* KPSYS pointer to the assembly LCM object (L_PIJ signature). KPSYS is +* an array of directories. +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK not used. +* IMPX print flag (equal to zero for no print). +* NGEFF number of energy groups processed in parallel. +* NGIND energy group indices assign to the NGEFF set. +* IDIR not used. +* NREG total number of regions for which specific values of the +* neutron flux and reactions rates are required. +* NBMIX number of mixtures. +* NUN total number of unknowns in vectors SUNKNO and FUNKNO. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX position of averaged flux elements in FUNKNO vector. +* SUNKNO input source vector. +* TITR title. +* NBS +* KPSOU1 +* KPSOU2 +* +*Parameters: input/output +* FUNKNO unknown vector. +* FLUXC flux at the cutoff energy. +* EVALRHO dominance ratio. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER TITR*72 + TYPE(C_PTR) KPSYS(NGEFF),IPTRK,KPSOU1(NGEFF),KPSOU2(NGEFF) + INTEGER NGEFF,NGIND(NGEFF),IFTRAK,IMPX,IDIR,NREG,NBMIX,NUN, + 1 MAT(NREG),KEYFLX(NREG),NBS(NGEFF) + REAL VOL(NREG),FUNKNO(NUN,NGEFF),SUNKNO(NUN,NGEFF) + REAL,OPTIONAL :: FLUXC(NREG) + REAL,OPTIONAL :: EVALRHO +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6,NSTATE=40) + INTEGER IPAR(NSTATE) + LOGICAL LIVO + DOUBLE PRECISION F1,F2,R1,R2,DMU +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: FGAR,TEST + REAL, ALLOCATABLE, DIMENSION(:,:) :: OLD1,OLD2,OLD3 + LOGICAL, ALLOCATABLE, DIMENSION(:) :: INCONV +*---- +* RECOVER SN SPECIFIC PARAMETERS +*---- + IF(IMPX.GT.2) THEN + WRITE(IUNOUT,'(//6H SNF: ,A72)') TITR + CALL KDRCPU(TK1) + ENDIF + IF(IDIR.NE.0) CALL XABORT('SNF: EXPECTING IDIR=0') + IF(IFTRAK.NE.0) CALL XABORT('SNF: EXPECTING IFTRAK=0') + CALL LCMGET(IPTRK,'STATE-VECTOR',IPAR) + NSTART=IPAR(20) + MAXIT=IPAR(22) + LIVO=(IPAR(23).EQ.1) + ICL1=IPAR(24) + ICL2=IPAR(25) + IBFP=IPAR(31) + NFOU=IPAR(34) + CALL LCMGET(IPTRK,'EPSI',EPSINR) + IF(IMPX.GT.3) THEN + ALLOCATE(FGAR(NREG)) + DO II=1,NGEFF + FGAR(:NREG)=0.0 + DO I=1,NREG + IF(KEYFLX(I).NE.0) FGAR(I)=SUNKNO(KEYFLX(I),II) + ENDDO + WRITE(IUNOUT,'(/33H N E U T R O N S O U R C E S (,I5, + 1 3H ):)') NGIND(II) + WRITE(IUNOUT,'(1P,6(5X,E15.7))') (FGAR(I),I=1,NREG) + ENDDO + DEALLOCATE(FGAR) + ENDIF +* + IF(NSTART.GT.0) THEN +*---- +* GMRES(M) INNER ITERATION LOOP FOR ONE-SPEED TRANSPORT EQUATION +*---- + CALL SNGMRE (KPSYS,NGIND,IPTRK,IMPX,NGEFF,NREG,NBMIX,NUN, + 1 NSTART,MAXIT,EPSINR,MAT,VOL,KEYFLX,FUNKNO,SUNKNO,NBS,KPSOU1, + 2 KPSOU2,FLUXC) + ELSE +*---- +* LIVOLANT INNER ITERATION LOOP FOR ONE-SPEED TRANSPORT EQUATION +*---- + LNCONV=NGEFF + ALLOCATE(INCONV(NGEFF),OLD1(NUN,NGEFF),OLD2(NUN,NGEFF), + 1 TEST(NGEFF),OLD3(NUN,NGEFF)) +* + INCONV(:NGEFF)=.TRUE. + TEST(:NGEFF)=0.0 +* + OLD1(:NUN,:NGEFF)=0.0 + OLD2(:NUN,:NGEFF)=0.0 + IF(NFOU.GT.0) OLD3(:NUN,:NGEFF)=0.0 +* + ITER=0 + 10 ITER=ITER+1 + IF(ITER.GT.MAXIT) THEN + WRITE(IUNOUT,'(40H SNF: MAXIMUM NUMBER OF ONE-SPEED ITERAT, + 1 12HION REACHED.)') + IF(NFOU.GT.0) WRITE(6,310) TRHO1 + GO TO 70 + ENDIF +* + IF(NFOU.GT.0)THEN + OLD1(:NUN,:NGEFF)= OLD2(:NUN,:NGEFF) + OLD2(:NUN,:NGEFF)= OLD3(:NUN,:NGEFF) + OLD3(:NUN,:NGEFF)=FUNKNO(:NUN,:NGEFF) + ELSE + OLD1(:NUN,:NGEFF)= OLD2(:NUN,:NGEFF) + OLD2(:NUN,:NGEFF)=FUNKNO(:NUN,:NGEFF) + ENDIF +*---- +* UPDATE THE FIXED SOURCE AND COMPUTE THE FLUX +*---- + CALL SNFLUX(KPSYS,INCONV,NGIND,IPTRK,IMPX,NGEFF,NREG, + 1 NBMIX,NUN,MAT,VOL,KEYFLX,FUNKNO,SUNKNO,ITER,NBS,KPSOU1, + 2 KPSOU2,FLUXC) +*---- +* LOOP OVER ENERGY GROUPS +*---- + DO 60 II=1,NGEFF + IF(INCONV(II)) THEN +*---- +* FOURIER ANALYSIS NUMERICAL EIGENVALUE CALCULATION +*---- + IF(NFOU.GT.0)THEN + TRHO1=0.0 + IF(ITER.GT.3)THEN + TOT1=0.0 + TOT2=0.0 + DO IR=1,NREG + IND=KEYFLX(IR) + IF(IND.GT.0)THEN + TOT1=TOT1+(FUNKNO(IND,II)-OLD3(IND,II))**2 + TOT2=TOT2+( OLD2(IND,II)-OLD1(IND,II))**2 + ENDIF + ENDDO + TOT1 = SQRT(TOT1) + TOT2 = SQRT(TOT2) + TRHO1 = SQRT(TOT1/TOT2) + EVALRHO=TRHO1 + ENDIF + ENDIF +*---- +* VARIATIONAL ACCELERATION. LIVOLANT INNER ITERATION LOOP FOR ONE-GROUP +* TRANSPORT EQUATION. +*---- + DMU=1.0D0 + IF(LIVO.AND.(MOD(ITER-1,ICL1+ICL2).GE.ICL1)) THEN + F1=0.0 + F2=0.0 + DO 30 I=1,NUN + R1=OLD2(I,II)-OLD1(I,II) + R2=FUNKNO(I,II)-OLD2(I,II) + F1=F1+R1*(R2-R1) + F2=F2+(R2-R1)*(R2-R1) + 30 CONTINUE + DMU=-F1/F2 + IF(DMU.GT.0.0) THEN + RDMU=REAL(DMU) + DO 40 I=1,NUN + FUNKNO(I,II)=OLD2(I,II)+RDMU*(FUNKNO(I,II)-OLD2(I,II)) + OLD2(I,II)=OLD1(I,II)+RDMU*(OLD2(I,II)-OLD1(I,II)) + 40 CONTINUE + ENDIF + ENDIF +*---- +* CALCULATE ERROR AND TEST FOR CONVERGENCE +*---- + AAA=0.0 + BBB=0.0 + DO 50 I=1,NREG + IF(KEYFLX(I).EQ.0) GO TO 50 + AAA=MAX(AAA,ABS(FUNKNO(KEYFLX(I),II)-OLD2(KEYFLX(I),II))) + BBB=MAX(BBB,ABS(FUNKNO(KEYFLX(I),II))) + 50 CONTINUE + IF(IMPX.GT.2) WRITE(IUNOUT,300) NGIND(II),ITER,AAA,BBB, + 1 AAA/BBB,DMU + IF(IMPX.GT.5) THEN + ALLOCATE(FGAR(NREG)) + FGAR(:NREG)=0.0 + DO I=1,NREG + IF(KEYFLX(I).NE.0) FGAR(I)=FUNKNO(KEYFLX(I),II) + ENDDO + WRITE(IUNOUT,'(//33H N E U T R O N F L U X E S :)') + WRITE(IUNOUT,'(1P,6(5X,E15.7))') (FGAR(I),I=1,NREG) + DEALLOCATE(FGAR) + ENDIF + IF(AAA.LE.0.1*EPSINR*BBB) THEN + LNCONV=LNCONV-1 + INCONV(II)=.FALSE. + ENDIF + IF(ITER.EQ.1) TEST(II)=AAA +! Be careful if the value of ITER is changed below. + IF((ITER.GE.10).AND.(AAA.GT.TEST(II))) THEN + WRITE(IUNOUT,'(39H SNF: UNABLE TO CONVERGE ONE-SPEED ITER, + 1 15HATIONS IN GROUP,I5,1H.)') NGIND(II) + LNCONV=LNCONV-1 + INCONV(II)=.FALSE. + ENDIF + ENDIF + 60 CONTINUE + IF((NFOU.GT.0).AND.(LNCONV.EQ.0)) WRITE(6,310) TRHO1 + IF(LNCONV.EQ.0) GO TO 70 + GO TO 10 +*---- +* CONVERGENCE OF ONE-SPEED ITERATIONS IN ALL NGEFF GROUPS +*---- + 70 IF(IMPX.GT.1) WRITE(IUNOUT,'(29H SNF: NUMBER OF ONE-SPEED ITE, + 1 8HRATIONS=,I5,1H.)') ITER + DEALLOCATE(OLD3,TEST,OLD2,OLD1,INCONV) + ENDIF + IF(IMPX.GT.2) THEN + CALL KDRCPU(TK2) + WRITE(IUNOUT,'(15H SNF: CPU TIME=,1P,E11.3,8H SECOND./)') + 1 TK2-TK1 + ENDIF + RETURN +* + 300 FORMAT(11H SNF: GROUP,I5,20H ONE-SPEED ITERATION,I4,8H ERROR=, + 1 1P,E11.4,5H OVER,E11.4,5H PREC,E12.4,22H ACCELERATION FACTOR=, + 2 0P,F7.3) + 310 FORMAT (44H SNF: EIGENVALUE FOR FOURIER ANALYSIS, RHO= ,E13.6) + END diff --git a/Dragon/src/SNFBC1.f b/Dragon/src/SNFBC1.f new file mode 100644 index 0000000..fa89ac3 --- /dev/null +++ b/Dragon/src/SNFBC1.f @@ -0,0 +1,304 @@ +*DECK SNFBC1 + SUBROUTINE SNFBC1(LX,NMAT,IELEM,NLF,NSCT,U,MAT,VOL,TOTAL, + 1 NCODE,ZCODE,QEXT,LFIXUP,LSHOOT,ISBS,NBS,ISBSM,BS,WX,CST, + 2 ISADPTX,NUN,FUNKNO,MN,DN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform one inner iteration for solving SN equations in 1D slab +* geometry. Albedo boundary conditions. +* +*Copyright: +* Copyright (C) 2020 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert, A. A. Calloo and C. Bienvenue +* +*Parameters: input +* LX number of regions. +* NMAT number of material mixtures. +* IELEM measure of order of the spatial approximation polynomial: +* =1 constant - default for HODD; +* =2 linear - default for DG; +* >3 higher orders. +* NLF number of $\\mu$ levels. +* NSCT number of Legendre components in the flux: +* =1: isotropic sources; +* =2: linearly anisotropic sources. +* U base points in $\\mu$ of the SN quadrature. +* W weights of the SN quadrature. +* MN moment-to-discrete matrix. +* DN discrete-to-moment matrix. +* MAT material mixture index in each region. +* VOL volumes of each region. +* TOTAL macroscopic total cross sections. +* NCODE boundary condition indices. +* ZCODE albedos. +* QEXT Legendre components of the fixed source. +* LFIXUP flag to enable negative flux fixup. +* LSHOOT flag to enable/disable shooting method. +* ISBS flag to indicate the presence or not of boundary fixed +* sources. +* NBS number of boundary fixed sources. +* ISBSM flag array to indicate the presence or not of boundary fixed +* source in each unit surface. +* BS boundary source array with their intensities. +* WX spatial closure relation weighting factors. +* CST constants for the polynomial approximations. +* ISADPTX flag to enable/disable spatial adaptive flux calculations. +* NUN total number of unknowns in vector FUNKNO +* +*Parameters: input/output +* FUNKNO Legendre components of the flux and boundary fluxes. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER LX,NMAT,IELEM,NLF,NSCT,MAT(LX),NCODE(2),ISBS,NBS, + 1 ISBSM(2*ISBS,NLF*ISBS),NUN + LOGICAL LFIXUP,LSHOOT,ISADPTX + REAL U(NLF),VOL(LX),TOTAL(0:NMAT),ZCODE(2),QEXT(IELEM,NSCT,LX), + 1 FUNKNO(NUN),BS(NBS*ISBS),WX(IELEM+1),CST(IELEM),MN(NLF,NSCT), + 2 DN(NSCT,NLF) +*---- +* LOCAL VARIABLES +*---- + REAL WX0(IELEM+1) + DOUBLE PRECISION XNI,XNI1,XNI2,XNIA,XNIB,XNIA1,XNIA2,XNIB1,XNIB2 + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: Q + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: Q2 + PARAMETER(RLOG=1.0E-8) + LOGICAL ISSHOOT,ISFIX +*---- +* ALLOCATABLE ARRAYS +*---- + ALLOCATE(Q(IELEM),Q2(IELEM,IELEM+1)) +*---- +* LENGTH OF FUNKNO COMPONENTS (IN ORDER) +*---- + LFLX=IELEM*LX*NSCT + LXNI=NLF +*---- +* INNER ITERATION +*---- + + FUNKNO(1:LFLX)=0.0 + XNI=0.0D0 + XNI1=0.0D0 + XNI2=0.0D0 + XNIA=0.0D0 + XNIA2=0.0D0 + WX0=WX + + ! SHOOTING METHOD (ONLY IF THERE IS A NON-VACUUM RIGHT + ! BOUNDARY CONDITION. + ISSHOOT=(ZCODE(2).NE.0.0).AND.LSHOOT + IF(ISSHOOT) THEN + NS=6 + ELSE + NS=2 + ENDIF + + ! LOOP OVER ALL DIRECTIONS + DO 200 M0=1,NLF/2 + + ! LOOP FOR SHOOTING METHOD + DO 500 IS=1,NS + + ! CHOOSE DIRECTION + IF(MOD(IS,2).EQ.0) THEN + M=NLF-M0+1 ! FORWARD + ELSE + M=M0 ! BACKWARD + ENDIF + + ! SHOOTING METHOD BOUNDARY CONDITIONS. + IF(ISSHOOT) THEN + ! 1ST BACKWARD SWEEP + IF(IS.EQ.1) THEN + XNI=0.0D0 + XNI1=0.0D0 + XNI2=0.0D0 + ! 1ST FORWARD SWEEP + ELSEIF(IS.EQ.2) THEN + XNIA1=0.0D0 + IF(NCODE(1).EQ.4) THEN + XNIA1=REAL(XNI) + XNI=0.0D0 + ELSE + XNI=ZCODE(1)*REAL(XNI) + ENDIF + ! 2ND BACKWARD SWEEP + ELSEIF(IS.EQ.3) THEN + XNIA2=0.0D0 + XNIA=0.0D0 + IF(NCODE(1).EQ.4) THEN + XNIA2=REAL(XNI) + ELSE + XNIA=REAL(XNI) + ENDIF + XNI=1.0D0 + ! 2ND FORWARD SWEEP + ELSEIF(IS.EQ.4) THEN + IF(NCODE(1).EQ.4) THEN + XNIB1=REAL(XNI) + XNI1=XNIA1/(1.0D0+XNIA1-XNIB1) + XNI=1.0D0 + ELSE + XNI=ZCODE(1)*REAL(XNI) + ENDIF + ! 3RD BACKWARD SWEEP + ELSEIF(IS.EQ.5) THEN + IF(NCODE(1).EQ.4) THEN + XNIB2=REAL(XNI) + XNI2=XNIA2/(1.0D0+XNIA2-XNIB2) + XNI=XNI1 + ELSE + XNIB=REAL(XNI) + XNI=ZCODE(2)*XNIA/(1.0D0+ZCODE(2)*(XNIA-XNIB)) + ENDIF + ! 3RD FORWARD SWEEP + ELSEIF(IS.EQ.6) THEN + XNI=ZCODE(1)*XNI + IF(NCODE(1).EQ.4) XNI=XNI2 + ENDIF + ! NO SHOOTING METHOD BOUNDARY CONDITIONS + ELSE + IF(.NOT.LSHOOT) THEN + IF(U(M).GT.0.0) THEN + IF(NCODE(1).NE.4) FUNKNO(LFLX+M)=FUNKNO(LFLX+NLF-M+1) + ELSE + IF(NCODE(2).NE.4) FUNKNO(LFLX+M)=FUNKNO(LFLX+NLF-M+1) + ENDIF + XNI=0.0D0 + ELSE + IF(IS.EQ.1) THEN + XNI=0.0D0 + ELSE + XNI=ZCODE(1)*XNI + ENDIF + ENDIF + ENDIF + + ! X-BOUNDARIES CONDITIONS (NO SHOOTING) + IF(.NOT.LSHOOT) THEN + IF(U(M).GT.0.0) THEN + XNI=FUNKNO(LFLX+M)*ZCODE(1) + ELSE + XNI=FUNKNO(LFLX+M)*ZCODE(2) + ENDIF + ENDIF + + ! BOUNDARY FIXED SOURCES + IF(U(M).GT.0.0) THEN + IF(ISBS.EQ.1.AND.ISBSM(1,M).NE.0) XNI=XNI+BS(ISBSM(1,M)) + ELSE + IF(ISBS.EQ.1.AND.ISBSM(2,M).NE.0) XNI=XNI+BS(ISBSM(2,M)) + ENDIF + + ! SWEEPING OVER ALL VOXELS + DO 30 I0=1,LX + I=I0 + IF(U(M).LT.0.0) I=LX+1-I0 + + ! DATA + IBM=MAT(I) + SIGMA=TOTAL(IBM) + + ! SOURCE DENSITY TERM + DO IEL=1,IELEM + Q(IEL)=0.0 + DO L=1,NSCT + Q(IEL)=Q(IEL)+QEXT(IEL,L,I)*MN(M,L) + ENDDO + ENDDO + + ISFIX=.FALSE. + DO WHILE (.NOT.ISFIX) ! LOOP FOR ADAPTIVE CALCULATION + + ! FLUX MOMENTS CALCULATIONS + Q2(:IELEM,:IELEM+1)=0.0D0 + DO II=1,IELEM + DO JJ=1,IELEM + + ! MOMENT COEFFICIENTS + IF(II.EQ.JJ) THEN + Q2(II,JJ)=SIGMA*VOL(I)+CST(II)**2*WX(JJ+1)*ABS(U(M)) + ELSEIF(II.LT.JJ) THEN + IF(MOD(II+JJ,2).EQ.1) THEN + Q2(II,JJ)=CST(II)*CST(JJ)*WX(JJ+1)*U(M) + ELSE + Q2(II,JJ)=CST(II)*CST(JJ)*WX(JJ+1)*ABS(U(M)) + ENDIF + ELSE + IF(MOD(II+JJ,2).EQ.1) THEN + Q2(II,JJ)=CST(II)*CST(JJ)*(WX(JJ+1)-2.0D0)*U(M) + ELSE + Q2(II,JJ)=CST(II)*CST(JJ)*WX(JJ+1)*ABS(U(M)) + ENDIF + ENDIF + ENDDO + ENDDO + + ! SOURCE TERMS + DO II=1,IELEM + IF(MOD(II,2).EQ.1) THEN + Q2(II,IELEM+1)=Q(II)*VOL(I)+CST(II)*(1-WX(1))*ABS(U(M))*XNI + ELSE + Q2(II,IELEM+1)=Q(II)*VOL(I)-CST(II)*(1+WX(1))*U(M)*XNI + ENDIF + ENDDO + + CALL ALSBD(IELEM,1,Q2,IER,IELEM) + IF(IER.NE.0) CALL XABORT('SNFBC1: SINGULAR MATRIX.') + + ! ADAPTIVE CORRECTION OF WEIGHTING PARAMETERS + IF(ISADPTX) THEN + CALL SNADPT(IELEM,IELEM,1,Q2(:IELEM,IELEM+1),XNI, + 1 1.0,WX,ISFIX) + ELSE + ISFIX=.TRUE. + ENDIF + + END DO ! END OF ADAPTIVE LOOP + + ! CLOSURE RELATIONS + IF(IELEM.EQ.1.AND.LFIXUP.AND.(Q2(1,2).LE.RLOG)) Q2(1,2)=0.0D0 + XNI=WX(1)*XNI + DO II=1,IELEM + IF(MOD(II,2).EQ.1) THEN + XNI=XNI+CST(II)*WX(II+1)*Q2(II,IELEM+1) + ELSE + XNI=XNI+CST(II)*WX(II+1)*Q2(II,IELEM+1)*SIGN(1.0,U(M)) + ENDIF + ENDDO + IF(IELEM.EQ.1.AND.LFIXUP.AND.(XNI.LE.RLOG)) XNI=0.0D0 + WX=WX0 + + IF(ISSHOOT.AND.IS.LT.5) GO TO 30 + + ! SAVE LEGENDRE MOMENT OF THE FLUX + DO L=1,NSCT + DO IEL=1,IELEM + IOF=(I-1)*NSCT*IELEM+(L-1)*IELEM+IEL + FUNKNO(IOF)=FUNKNO(IOF)+REAL(Q2(IEL,IELEM+1))*DN(L,M) + ENDDO + ENDDO + + 30 CONTINUE ! END OF X-LOOP + + ! SAVE BOUNDARIES FLUX + IF(.NOT.LSHOOT) FUNKNO(LFLX+M)=REAL(XNI) + + 500 CONTINUE ! END OF SHOOTING METHOD LOOP + 200 CONTINUE ! END OF DIRECTION LOOP + + DEALLOCATE(Q,Q2) + RETURN + END diff --git a/Dragon/src/SNFBC2.F b/Dragon/src/SNFBC2.F new file mode 100644 index 0000000..a269925 --- /dev/null +++ b/Dragon/src/SNFBC2.F @@ -0,0 +1,512 @@ +*DECK SNFBC2 + SUBROUTINE SNFBC2(NUN,NGEFF,IMPX,INCONV,NGIND,LX,LY,IELEM,NM,NMX, + 1 NMY,NMAT,NPQ,NSCT,MAT,VOL,TOTAL,NCODE,ZCODE,QEXT,LFIXUP,DU,DE,W, + 2 MRM,MRMY,DB,DA,MN,DN,WX,WY,CST,ISADPT,ISBS,NBS,ISBSM,BS,MAXL, + 3 FUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform one inner iteration for solving SN equations in 2D Cartesian +* geometry for the HODD method. Energy-angle multithreading. Albedo +* boundary conditions. Boltzmann (BTE) discretization. +* +*Copyright: +* Copyright (C) 2025 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert, A. A. Calloo and C. Bienvenue +* +*Parameters: input +* NUN total number of unknowns in vector FUNKNO. +* NGEFF number of energy groups processed in parallel. +* IMPX print flag (equal to zero for no print). +* INCONV energy group convergence flag (set to .FALSE. if converged). +* NGIND energy group indices assign to the NGEFF set. +* LX number of meshes along X axis. +* LY number of meshes along Y axis. +* IELEM measure of order of the spatial approximation polynomial: +* =1 constant - default for HODD; +* =2 linear - default for DG; +* >3 higher orders. +* NM number of moments in space and energy for flux components +* NMX number of moments for X axis boundaries components +* NMY number of moments for Y axis boundaries components +* NMAT number of material mixtures. +* NPQ number of SN directions in four octants (including zero-weight +* directions). +* NSCT maximum number of spherical harmonics moments of the flux. +* MAT material mixture index in each region. +* VOL volumes of each region. +* TOTAL macroscopic total cross sections. +* NCODE boundary condition indices. +* ZCODE albedos. +* QEXT Legendre components of the fixed source. +* LFIXUP flag to enable negative flux fixup. +* DU first direction cosines ($\\mu$). +* DE second direction cosines ($\\eta$). +* W weights. +* MRM quadrature index. +* MRMY quadrature index. +* DB diamond-scheme parameter. +* DA diamond-scheme parameter. +* MN moment-to-discrete matrix. +* DN discrete-to-moment matrix. +* ISBS flag to indicate the presence or not of boundary fixed +* sources. +* NBS number of boundary fixed sources. +* ISBSM flag array to indicate the presence or not of boundary fixed +* source in each unit surface. +* BS boundary source array with their intensities. +* MAXL maximum size of boundary source array. +* WX spatial X axis closure relation weighting factors. +* WY spatial Y axis closure relation weighting factors. +* CST constants for the polynomial approximations. +* ISADPT flag to enable/disable adaptive flux calculations.\ +* +*Parameters: input/output +* FUNKNO Legendre components of the flux and boundary fluxes. +* FLUXC flux at the cutoff energy. +* +*----------------------------------------------------------------------- +#if defined(_OPENMP) + USE omp_lib +#endif +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NUN,NGEFF,IMPX,NGIND(NGEFF),LX,LY,IELEM,NM,NMX,NMY,NMAT, + 1 NPQ,NSCT,MAT(LX,LY),NCODE(4),MRM(NPQ),MRMY(NPQ),ISBS,NBS, + 2 ISBSM(4*ISBS,NPQ*ISBS,NGEFF*ISBS),MAXL + LOGICAL INCONV(NGEFF) + REAL VOL(LX,LY),TOTAL(0:NMAT,NGEFF),ZCODE(4),QEXT(NUN,NGEFF), + 1 DU(NPQ),DE(NPQ),W(NPQ),DB(LX,NPQ),DA(LX,LY,NPQ), + 2 FUNKNO(NUN,NGEFF),BS(MAXL*ISBS,NBS*ISBS),WX(IELEM+1), + 3 WY(IELEM+1),CST(IELEM),MN(NPQ,NSCT),DN(NSCT,NPQ) + LOGICAL LFIXUP,ISADPT(2) +*---- +* LOCAL VARIABLES +*---- + INTEGER NPQD(4),IIND(4),P + REAL WX0(IELEM+1),WY0(IELEM+1) + DOUBLE PRECISION Q(NM),Q2(NM,NM+1),XNJ(NMY),V + PARAMETER(IUNOUT=6,RLOG=1.0E-8,PI=3.141592654) + LOGICAL ISFIX(2) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: INDANG + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:) :: FLUX + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: FLUX_G + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: XNI +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(INDANG(NPQ,4)) + ALLOCATE(XNI(NMX,LY),FLUX(NM,NSCT,LX,LY)) + ALLOCATE(FLUX_G(NM,NSCT,LX,LY,NGEFF)) +*---- +* LENGTH OF FUNKNO COMPONENTS (IN ORDER) +*---- + LFLX=NM*LX*LY*NSCT + LXNI=NMX*LY*NPQ + LXNJ=NMY*LX*NPQ +*---- +* SET OCTANT SWAPPING ORDER. +*---- + NPQD(:4)=0 + INDANG(:NPQ,:4)=0 + IIND(:)=0 + DO M=1,NPQ + VU=DU(M) + VE=DE(M) + IF(W(M).EQ.0) CYCLE + IF((VU.GE.0.0).AND.(VE.GE.0.0)) THEN + IND=1 + JND=4 + ELSE IF((VU.LE.0.0).AND.(VE.GE.0.0)) THEN + IND=2 + JND=3 + ELSE IF((VU.LE.0.0).AND.(VE.LE.0.0)) THEN + IND=3 + JND=1 + ELSE + IND=4 + JND=2 + ENDIF + IIND(JND)=IND + NPQD(IND)=NPQD(IND)+1 + INDANG(NPQD(IND),IND)=M + ENDDO +*---- +* MAIN LOOP OVER OCTANTS. +*---- + + FLUX_G(:NM,:NSCT,:LX,:LY,:NGEFF)=0.0D0 + WX0=WX + WY0=WY + + DO 190 JND=1,4 + IND=IIND(JND) +*---- +* PRELIMINARY LOOPS FOR SETTING BOUNDARY CONDITIONS. +*---- + +*$OMP PARALLEL DO +*$OMP+ PRIVATE(M,IG,VU,VE,M1,IOF,JOF,IEL,I,J,IPQD) +*$OMP+ SHARED(FUNKNO) COLLAPSE(2) + + DO 70 IG=1,NGEFF + DO 60 IPQD=1,NPQD(IND) + IF(.NOT.INCONV(IG)) GO TO 60 + M=INDANG(IPQD,IND) + VU=DU(M) + VE=DE(M) + ! X-BOUNDARY + IF(VU.GT.0.0)THEN + M1=MRM(M) + IF((NCODE(1).NE.4))THEN + DO IEL=1,NMX + DO J=1,LY + IOF=((M-1)*LY+(J-1))*NMX+IEL + JOF=((M1-1)*LY+(J-1))*NMX+IEL + FUNKNO(LFLX+IOF,IG)=FUNKNO(LFLX+JOF,IG) + ENDDO + ENDDO + ENDIF + ELSEIF(VU.LT.0.0)THEN + M1=MRM(M) + IF((NCODE(2).NE.4))THEN + DO IEL=1,NMX + DO J=1,LY + IOF=((M-1)*LY+(J-1))*NMX+IEL + JOF=((M1-1)*LY+(J-1))*NMX+IEL + FUNKNO(LFLX+IOF,IG)=FUNKNO(LFLX+JOF,IG) + ENDDO + ENDDO + ENDIF + ENDIF + ! Y-BOUNDARY + IF(VE.GT.0.0)THEN + M1=MRMY(M) + IF((NCODE(3).NE.4))THEN + DO IEL=1,NMY + DO I=1,LX + IOF=((M-1)*LX+(I-1))*NMY+IEL + JOF=((M1-1)*LX+(I-1))*NMY+IEL + FUNKNO(LFLX+LXNI+IOF,IG)= + > FUNKNO(LFLX+LXNI+JOF,IG) + ENDDO + ENDDO + ENDIF + ELSEIF(VE.LT.0.0)THEN + M1=MRMY(M) + IF((NCODE(4).NE.4))THEN + DO IEL=1,NMY + DO I=1,LX + IOF=((M-1)*LX+(I-1))*NMY+IEL + JOF=((M1-1)*LX+(I-1))*NMY+IEL + FUNKNO(LFLX+LXNI+IOF,IG)= + > FUNKNO(LFLX+LXNI+JOF,IG) + ENDDO + ENDDO + ENDIF + ENDIF + 60 CONTINUE + 70 CONTINUE + +*OMP END PARALLEL DO + +*---- +* MAIN SWAPPING LOOPS FOR SN FLUX CALCULATION +*---- + +*$OMP PARALLEL DO +*$OMP+ PRIVATE(ITID,FLUX,M,IG,XNI,XNJ,Q,Q2,IOF,IER,II,JJ,IEL,I,J,P) +*$OMP+ PRIVATE(IPQD,I0,J0,IBM,SIGMA,V,ISFIX,IX,JX,IY,JY) +*$OMP+ FIRSTPRIVATE(WX,WY,WX0,WY0) SHARED(FUNKNO) +*$OMP+ REDUCTION(+:FLUX_G) COLLAPSE(2) + + ! LOOP FOR GROUPS TO EXECUTE IN PARALLEL + DO 180 IG=1,NGEFF + + ! LOOP OVER ALL DIRECTIONS + DO 170 IPQD=1,NPQD(IND) + IF(.NOT.INCONV(IG)) GO TO 170 + M=INDANG(IPQD,IND) + IF(W(M).EQ.0.0) GO TO 170 + + ! GET AND PRINT THREAD NUMBER +#if defined(_OPENMP) + ITID=omp_get_thread_num() +#else + ITID=0 +#endif + IF(IMPX.GT.5) WRITE(IUNOUT,400) ITID,NGIND(IG),IPQD + + ! INITIALIZE FLUXES + FLUX(:NM,:NSCT,:LX,:LY)=0.0D0 + +*---- +* LOOP OVER X- AND Y-DIRECTED AXES. +*---- + + ! X-AXIS LOOP + DO 155 I0=1,LX + I=I0 + IF((IND.EQ.2).OR.(IND.EQ.3)) I=LX+1-I + + ! Y-BOUNDARIES CONDITIONS + XNJ=0.0 + DO IEL=1,NMY + IOF=(M-1)*NMY*LX+(I-1)*NMY+IEL + IF((IND.EQ.1).OR.(IND.EQ.2)) THEN + XNJ(IEL)=FUNKNO(LFLX+LXNI+IOF,IG)*ZCODE(3) + ELSE + XNJ(IEL)=FUNKNO(LFLX+LXNI+IOF,IG)*ZCODE(4) + ENDIF + ENDDO + + ! Y-BOUNDARIES FIXED SOURCES + IF(ISBS.EQ.1) THEN + IF((IND.EQ.3.OR.IND.EQ.4).AND.ISBSM(4,M,IG).NE.0) THEN + XNJ(1)=XNJ(1)+BS(I,ISBSM(4,M,IG)) + ELSE IF((IND.EQ.1.OR.IND.EQ.2).AND.ISBSM(3,M,IG).NE.0) THEN + XNJ(1)=XNJ(1)+BS(I,ISBSM(3,M,IG)) + ENDIF + ENDIF + + ! Y-AXIS LOOP + DO 140 J0=1,LY + J=J0 + IF((IND.EQ.3).OR.(IND.EQ.4)) J=LY+1-J + + ! X-BOUNDARIES CONDITIONS + IF(I0.EQ.1) THEN + XNI(:NMX,J)=0.0 + DO IEL=1,NMX + IOF=(M-1)*NMX*LY+(J-1)*NMX+IEL + IF((IND.EQ.1).OR.(IND.EQ.4)) THEN + XNI(IEL,J)=FUNKNO(LFLX+IOF,IG)*ZCODE(1) + ELSE + XNI(IEL,J)=FUNKNO(LFLX+IOF,IG)*ZCODE(2) + ENDIF + ENDDO + ENDIF + + ! X-BOUNDARIES FIXED SOURCES + IF(ISBS.EQ.1.AND.I0.EQ.1) THEN + IF((IND.EQ.2.OR.IND.EQ.3).AND.ISBSM(2,M,IG).NE.0) THEN + XNI(1,J)=XNI(1,J)+BS(J,ISBSM(2,M,IG)) + ELSE IF((IND.EQ.1.OR.IND.EQ.4).AND.ISBSM(1,M,IG).NE.0) THEN + XNI(1,J)=XNI(1,J)+BS(J,ISBSM(1,M,IG)) + ENDIF + ENDIF + + ! DATA + IBM=MAT(I,J) + IF(IBM.EQ.0) GO TO 140 + SIGMA=TOTAL(IBM,IG) + V=VOL(I,J) + + ! SOURCE DENSITY TERM + DO IEL=1,NM + Q(IEL)=0.0D0 + DO P=1,NSCT + IOF=((J-1)*LX*NSCT+(I-1)*NSCT+(P-1))*NM+IEL + Q(IEL)=Q(IEL)+QEXT(IOF,IG)*MN(M,P) + ENDDO + ENDDO + + ISFIX=.FALSE. + DO WHILE (.NOT.ALL(ISFIX)) ! LOOP FOR ADAPTIVE CALCULATION + + ! FLUX MOMENT COEFFICIENTS MATRIX + Q2(:NM,:NM+1)=0.0D0 + + DO IY=1,IELEM + DO JY=1,IELEM + DO IX=1,IELEM + DO JX=1,IELEM + II=IELEM*(IY-1)+IX + JJ=IELEM*(JY-1)+JX + + ! DIAGONAL TERMS + IF(II.EQ.JJ) THEN + Q2(II,JJ)=SIGMA*V + 1 +CST(IX)**2*WX(JX+1)*ABS(DA(I,J,M)) + 2 +CST(IY)**2*WY(JY+1)*ABS(DB(I,M)) + + ! UPPER DIAGONAL TERMS + ELSEIF(II.LT.JJ) THEN + ! X-SPACE TERMS + IF(IY.EQ.JY) THEN + IF(MOD(IX+JX,2).EQ.1) THEN + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*DA(I,J,M) + ELSE + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*ABS(DA(I,J,M)) + ENDIF + ! Y-SPACE TERMS + ELSEIF(IX.EQ.JX) THEN + IF(MOD(IY+JY,2).EQ.1) THEN + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*DB(I,M) + ELSE + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ABS(DB(I,M)) + ENDIF + ENDIF + + ! UNDER DIAGONAL TERMS + ELSE + ! X-SPACE TERMS + IF(IY.EQ.JY) THEN + IF(MOD(IX+JX,2).EQ.1) THEN + Q2(II,JJ)=CST(IX)*CST(JX)*(WX(JX+1)-2)*DA(I,J,M) + ELSE + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*ABS(DA(I,J,M)) + ENDIF + ! Y-SPACE TERMS + ELSEIF(IX.EQ.JX) THEN + IF(MOD(IY+JY,2).EQ.1) THEN + Q2(II,JJ)=CST(IY)*CST(JY)*(WY(JY+1)-2)*DB(I,M) + ELSE + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ABS(DB(I,M)) + ENDIF + ENDIF + + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + + ! FLUX SOURCE VECTOR + DO IY=1,IELEM + DO IX=1,IELEM + II=IELEM*(IY-1)+IX + Q2(II,NM+1)=Q(II)*V + ! X-SPACE TERMS + IF(MOD(IX,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IX)*(1-WX(1)) + 1 *XNI(IY,J)*ABS(DA(I,J,M)) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IX)*(1+WX(1)) + 1 *XNI(IY,J)*DA(I,J,M) + ENDIF + ! Y-SPACE TERMS + IF(MOD(IY,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IY)*(1-WY(1)) + 1 *XNJ(IX)*ABS(DB(I,M)) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IY)*(1+WY(1)) + 1 *XNJ(IX)*DB(I,M) + ENDIF + ENDDO + ENDDO + + CALL ALSBD(NM,1,Q2,IER,NM) + IF(IER.NE.0) CALL XABORT('SNFBC2: SINGULAR MATRIX.') + + ! ADAPTIVE CORRECTION OF WEIGHTING PARAMETERS + IF(ANY(ISADPT)) THEN + IF(ISADPT(1)) THEN + CALL SNADPT(IELEM,NM,IELEM,Q2(1:IELEM:1,NM+1), + 1 XNI(:NMX,J),1.0,WX,ISFIX(1)) + ELSE + ISFIX(1)=.TRUE. + ENDIF + IF(ISADPT(2)) THEN + CALL SNADPT(IELEM,NM,IELEM,Q2(1:NM:IELEM,NM+1), + 1 XNJ,1.0,WY,ISFIX(2)) + ELSE + ISFIX(2)=.TRUE. + ENDIF + ELSE + ISFIX=.TRUE. + ENDIF + + END DO ! END OF ADAPTIVE LOOP + + ! CLOSURE RELATIONS + IF(IELEM.EQ.1.AND.LFIXUP.AND.(Q2(1,2).LE.RLOG)) Q2(1,2)=0.0 + XNI(:NMX,J)=WX(1)*XNI(:NMX,J) + XNJ(:NMY)=WY(1)*XNJ(:NMY) + DO IY=1,IELEM + DO IX=1,IELEM + II=IELEM*(IY-1)+IX + ! X-SPACE + IF(MOD(IX,2).EQ.1) THEN + XNI(IY,J)=XNI(IY,J)+CST(IX)*WX(IX+1) + 1 *Q2(II,NM+1) + ELSE + XNI(IY,J)=XNI(IY,J)+CST(IX)*WX(IX+1) + 1 *Q2(II,NM+1)*SIGN(1.0,DA(I,J,M)) + ENDIF + ! Y-SPACE + IF(MOD(IY,2).EQ.1) THEN + XNJ(IX)=XNJ(IX)+CST(IY)*WY(IY+1) + 1 *Q2(II,NM+1) + ELSE + XNJ(IX)=XNJ(IX)+CST(IY)*WY(IY+1) + 1 *Q2(II,NM+1)*SIGN(1.0,DB(I,M)) + ENDIF + ENDDO + ENDDO + IF(IELEM.EQ.1.AND.LFIXUP.AND.(XNI(1,J).LE.RLOG)) XNI(1,J)=0.0 + IF(IELEM.EQ.1.AND.LFIXUP.AND.(XNJ(1).LE.RLOG)) XNJ(1)=0.0 + WX=WX0 + WY=WY0 + + ! SAVE LEGENDRE MOMENT OF THE FLUX + DO P=1,NSCT + DO IEL=1,NM + FLUX(IEL,P,I,J)=FLUX(IEL,P,I,J)+Q2(IEL,NM+1)*DN(P,M) + ENDDO + ENDDO + + 140 CONTINUE ! END OF Y-LOOP + + ! SAVE Y-BOUNDARY CONDITIONS + DO IEL=1,NMY + IOF=(M-1)*NMY*LX+(I-1)*NMY+IEL + FUNKNO(LFLX+LXNI+IOF,IG)=REAL(XNJ(IEL)) + ENDDO + + 155 CONTINUE ! END OF X-LOOP + + ! SAVE X-BOUNDARY CONDITIONS + DO J=1,LY + DO IEL=1,NMX + IOF=(M-1)*NMX*LY+(J-1)*NMX+IEL + FUNKNO(LFLX+IOF,IG)=REAL(XNI(IEL,J)) + ENDDO + ENDDO + + ! SAVE FLUX INFORMATION + FLUX_G(:,:,:,:,IG)=FLUX_G(:,:,:,:,IG)+FLUX(:,:,:,:) + + 170 CONTINUE ! END OF DIRECTION LOOP + 180 CONTINUE ! END OF ENERGY LOOP +*$OMP END PARALLEL DO + 190 CONTINUE ! END OF OCTANT LOOP + + ! SAVE FLUX INFORMATION + DO 200 IG=1,NGEFF + IF(.NOT.INCONV(IG)) GO TO 200 + FUNKNO(:LFLX,IG)= + 1 RESHAPE(REAL(FLUX_G(:NM,:NSCT,:LX,:LY,IG)), + 2 (/ LFLX /) ) + 200 CONTINUE + + ! CALL XABORT('SNFBC2: testing') + +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XNI,FLUX_G,FLUX,INDANG) + RETURN + 400 FORMAT(16H SNFBC2: thread=,I8,12H --->(group=,I4,7H angle=,I4,1H)) + END diff --git a/Dragon/src/SNFBC3.F b/Dragon/src/SNFBC3.F new file mode 100644 index 0000000..4a2b304 --- /dev/null +++ b/Dragon/src/SNFBC3.F @@ -0,0 +1,679 @@ +*DECK SNFBC3 + SUBROUTINE SNFBC3(NUN,NGEFF,IMPX,INCONV,NGIND,LX,LY,LZ,IELEM,NM, + 1 NMX,NMY,NMZ,NMAT,NPQ,NSCT,MAT,VOL,TOTAL,NCODE,ZCODE,QEXT,LFIXUP, + 2 DU,DE,DZ,W,MRMX,MRMY,MRMZ,DC,DB,DA,MN,DN,WX,WY,WZ,CST,ISADPT, + 3 ISBS,NBS,ISBSM,BS,MAXL,FUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform one inner iteration for solving SN equations in 3D Cartesian +* geometry for the HODD method. Energy-angle multithreading. Albedo +* boundary conditions. Boltzmann (BTE) discretization. +* +*Copyright: +* Copyright (C) 2025 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert, A. A. Calloo and C. Bienvenue +* +*Parameters: input +* NUN total number of unknowns in vector FUNKNO. +* NGEFF number of energy groups processed in parallel. +* IMPX print flag (equal to zero for no print). +* INCONV energy group convergence flag (set to .FALSE. if converged). +* NGIND energy group indices assign to the NGEFF set. +* LX number of meshes along X axis. +* LY number of meshes along Y axis. +* LZ number of meshes along Z axis. +* IELEM measure of order of the spatial approximation polynomial: +* =1 constant - default for HODD; +* =2 linear - default for DG; +* >3 higher orders. +* NM number of moments in space for flux components +* NMX number of moments for X axis boundaries components +* NMY number of moments for Y axis boundaries components +* NMZ number of moments for Z axis boundaries components +* NMAT number of material mixtures. +* NPQ number of SN directions in height octants. +* NSCT maximum number of spherical harmonics moments of the flux. +* MAT material mixture index in each region. +* VOL volumes of each region. +* TOTAL macroscopic total cross sections. +* ESTOPW stopping power. +* NCODE boundary condition indices. +* ZCODE albedos. +* DELTAE energy group width in MeV. +* QEXT Legendre components of the fixed source. +* LFIXUP flag to enable negative flux fixup. +* DU first direction cosines ($\\mu$). +* DE second direction cosines ($\\eta$). +* DZ third direction cosines ($\\xi$). +* W weights. +* MRMX quadrature index. +* MRMY quadrature index. +* MRMZ quadrature index. +* DC diamond-scheme parameter. +* DB diamond-scheme parameter. +* DA diamond-scheme parameter. +* MN moment-to-discrete matrix. +* DN discrete-to-moment matrix. +* ISBS flag to indicate the presence or not of boundary fixed +* sources. +* NBS number of boundary fixed sources. +* ISBSM flag array to indicate the presence or not of boundary fixed +* source in each unit surface. +* BS boundary source array with their intensities. +* MAXL maximum size of boundary source array. +* WX spatial X axis closure relation weighting factors. +* WY spatial Y axis closure relation weighting factors. +* WZ spatial Z axis closure relation weighting factors. +* CST constants for the polynomial approximations. +* ISADPT flag to enable/disable adaptive flux calculations. +* +*Parameters: input/output +* FUNKNO Legendre components of the flux and boundary fluxes. +* FLUXC flux at the cutoff energy. +* +*----------------------------------------------------------------------- +* +#if defined(_OPENMP) + USE omp_lib +#endif +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NUN,NGEFF,IMPX,NGIND(NGEFF),LX,LY,LZ,IELEM,NM,NMX,NMY,NMZ, + 1 NMAT,NPQ,NSCT,MAT(LX,LY,LZ),NCODE(6),MRMX(NPQ),MRMY(NPQ), + 2 MRMZ(NPQ),ISBS,NBS,ISBSM(6*ISBS,NPQ*ISBS,NGEFF*ISBS),MAXL + LOGICAL INCONV(NGEFF) + REAL VOL(LX,LY,LZ),TOTAL(0:NMAT,NGEFF),ZCODE(6),QEXT(NUN,NGEFF), + 1 DU(NPQ),DE(NPQ),DZ(NPQ),W(NPQ),DC(LX,LY,NPQ),DB(LX,LZ,NPQ), + 2 DA(LY,LZ,NPQ),FUNKNO(NUN,NGEFF),BS(MAXL*ISBS,NBS*ISBS), + 3 WX(IELEM+1),WY(IELEM+1),WZ(IELEM+1),CST(IELEM),MN(NPQ,NSCT), + 4 DN(NSCT,NPQ) + LOGICAL LFIXUP,ISADPT(3) +*---- +* LOCAL VARIABLES +*---- + INTEGER NPQD(8),IIND(8),P + PARAMETER(IUNOUT=6,RLOG=1.0E-8,PI=3.141592654) + REAL WX0(IELEM+1),WY0(IELEM+1),WZ0(IELEM+1) + DOUBLE PRECISION V,Q(NM),Q2(NM,NM+1),XNK(NMZ) + LOGICAL ISFIX(3) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: INDANG + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: FLUX + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:,:,:) :: FLUX_G + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: XNI + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: XNJ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(INDANG(NPQ,8)) + ALLOCATE(XNI(NMX,LY,LZ),XNJ(NMY,LZ)) + ALLOCATE(FLUX(NM,NSCT,LX,LY,LZ)) + ALLOCATE(FLUX_G(NM,NSCT,LX,LY,LZ,NGEFF)) +*---- +* LENGTH OF FUNKNO COMPONENTS (IN ORDER) +*---- + LFLX=NM*LX*LY*LZ*NSCT + LXNI=NMX*LY*LZ*NPQ + LXNJ=NMY*LX*LZ*NPQ + LXNK=NMZ*LX*LY*NPQ +*---- +* SET OCTANT SWAPPING ORDER. +*---- + NPQD(:8)=0 + INDANG(:NPQ,:8)=0 + IIND(:)=0 + DO 10 M=1,NPQ + VU=DU(M) + VE=DE(M) + VZ=DZ(M) + IF(W(M).EQ.0) CYCLE + IF((VU.GE.0.0).AND.(VE.GE.0.0).AND.(VZ.GE.0.0)) THEN + IND=1 + JND=8 + ELSE IF((VU.LE.0.0).AND.(VE.GE.0.0).AND.(VZ.GE.0.0)) THEN + IND=2 + JND=7 + ELSE IF((VU.LE.0.0).AND.(VE.LE.0.0).AND.(VZ.GE.0.0)) THEN + IND=3 + JND=5 + ELSE IF((VU.GE.0.0).AND.(VE.LE.0.0).AND.(VZ.GE.0.0)) THEN + IND=4 + JND=6 + ELSE IF((VU.GE.0.0).AND.(VE.GE.0.0).AND.(VZ.LE.0.0)) THEN + IND=5 + JND=4 + ELSE IF((VU.LE.0.0).AND.(VE.GE.0.0).AND.(VZ.LE.0.0)) THEN + IND=6 + JND=3 + ELSE IF((VU.LE.0.0).AND.(VE.LE.0.0).AND.(VZ.LE.0.0)) THEN + IND=7 + JND=1 + ELSE + IND=8 + JND=2 + ENDIF + IIND(JND)=IND + NPQD(IND)=NPQD(IND)+1 + INDANG(NPQD(IND),IND)=M + 10 CONTINUE +*---- +* MAIN LOOP OVER OCTANTS. +*---- + + FLUX_G(:NM,:NSCT,:LX,:LY,:LZ,:NGEFF)=0.0D0 + WX0=WX + WY0=WY + WZ0=WZ + + DO 420 JND=1,8 + IND=IIND(JND) +*---- +* PRELIMINARY LOOPS FOR SETTING BOUNDARY CONDITIONS. +*---- + +*$OMP PARALLEL DO +*$OMP+ PRIVATE(M,IG,VU,VE,VZ,M1,E1,IOF,JOF,IEL,I,J,K,IPQD) +*$OMP+ SHARED(FUNKNO) COLLAPSE(2) + + DO 150 IG=1,NGEFF + DO 140 IPQD=1,NPQD(IND) + IF(.NOT.INCONV(IG)) GO TO 140 + M=INDANG(IPQD,IND) + VU=DU(M) + VE=DE(M) + VZ=DZ(M) + ! X-BOUNDARY + IF(VU.GT.0.0)THEN + M1=MRMX(M) + IF(NCODE(1).NE.4)THEN + DO IEL=1,NMX + DO J=1,LY + DO K=1,LZ + IOF=(((M-1)*LZ+(K-1))*LY+(J-1))*NMX+IEL + JOF=(((M1-1)*LZ+(K-1))*LY+(J-1))*NMX+IEL + FUNKNO(LFLX+IOF,IG)=FUNKNO(LFLX+JOF,IG) + ENDDO + ENDDO + ENDDO + ENDIF + ELSEIF(VU.LT.0.0)THEN + M1=MRMX(M) + IF(NCODE(2).NE.4)THEN + DO IEL=1,NMX + DO J=1,LY + DO K=1,LZ + IOF=(((M-1)*LZ+(K-1))*LY+(J-1))*NMX+IEL + JOF=(((M1-1)*LZ+(K-1))*LY+(J-1))*NMX+IEL + FUNKNO(LFLX+IOF,IG)=FUNKNO(LFLX+JOF,IG) + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + ! Y-BOUNDARY + IF(VE.GT.0.0)THEN + M1=MRMY(M) + IF(NCODE(3).NE.4)THEN + DO IEL=1,NMY + DO I=1,LX + DO K=1,LZ + IOF=(((M-1)*LZ+(K-1))*LX+(I-1))*NMY+IEL + JOF=(((M1-1)*LZ+(K-1))*LX+(I-1))*NMY+IEL + FUNKNO(LFLX+LXNI+IOF,IG)=FUNKNO(LFLX+LXNI+JOF,IG) + ENDDO + ENDDO + ENDDO + ENDIF + ELSEIF(VE.LT.0.0)THEN + M1=MRMY(M) + IF(NCODE(4).NE.4)THEN + DO IEL=1,NMY + DO I=1,LX + DO K=1,LZ + IOF=(((M-1)*LZ+(K-1))*LX+(I-1))*NMY+IEL + JOF=(((M1-1)*LZ+(K-1))*LX+(I-1))*NMY+IEL + FUNKNO(LFLX+LXNI+IOF,IG)=FUNKNO(LFLX+LXNI+JOF,IG) + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + ! Z-BOUNDARY + IF(VZ.GT.0.0)THEN + M1=MRMZ(M) + IF(NCODE(5).NE.4)THEN + DO IEL=1,NMZ + DO I=1,LX + DO J=1,LY + IOF=(((M-1)*LY+(J-1))*LX+(I-1))*NMZ+IEL + JOF=(((M1-1)*LY+(J-1))*LX+(I-1))*NMZ+IEL + E1=FUNKNO(LFLX+LXNI+LXNJ+IOF,IG) + FUNKNO(LFLX+LXNI+LXNJ+IOF,IG)=FUNKNO(LFLX+LXNI+LXNJ+JOF,IG) + FUNKNO(LFLX+LXNI+LXNJ+JOF,IG)=E1 + ENDDO + ENDDO + ENDDO + ENDIF + ELSEIF(VZ.LT.0.0)THEN + M1=MRMZ(M) + IF(NCODE(6).NE.4)THEN + DO IEL=1,NMZ + DO I=1,LX + DO J=1,LY + IOF=(((M-1)*LY+(J-1))*LX+(I-1))*NMZ+IEL + JOF=(((M1-1)*LY+(J-1))*LX+(I-1))*NMZ+IEL + E1=FUNKNO(LFLX+LXNI+LXNJ+IOF,IG) + FUNKNO(LFLX+LXNI+LXNJ+IOF,IG)=FUNKNO(LFLX+LXNI+LXNJ+JOF,IG) + FUNKNO(LFLX+LXNI+LXNJ+JOF,IG)=E1 + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + 140 CONTINUE + 150 CONTINUE + +*$OMP END PARALLEL DO + +*---- +* MAIN SWAPPING LOOPS FOR SN FLUX CALCULATION +*---- + +*$OMP PARALLEL DO +*$OMP+ PRIVATE(ITID,FLUX,M,IG,XNI,XNJ,XNK,Q,Q2,IOF,IER,II,JJ,I,J,K) +*$OMP+ PRIVATE(IPQD,I0,J0,K0,IBM,SIGMA,V,ISFIX,IX,JX,IY,JY,IZ,JZ,IEL) +*$OMP+ PRIVATE(IIX,IIY,IIZ,P) FIRSTPRIVATE(WX,WY,WZ,WX0,WY0,WZ0) +*$OMP+ SHARED(FUNKNO) REDUCTION(+:FLUX_G) COLLAPSE(2) + + ! LOOP FOR GROUPS TO EXECUTE IN PARALLEL + DO 410 IG=1,NGEFF + + ! LOOP OVER ALL DIRECTIONS + DO 400 IPQD=1,NPQD(IND) + IF(.NOT.INCONV(IG)) GO TO 400 + M=INDANG(IPQD,IND) + IF(W(M).EQ.0.0) GO TO 400 + + ! GET AND PRINT THREAD NUMBER +#if defined(_OPENMP) + ITID=omp_get_thread_num() +#else + ITID=0 +#endif + IF(IMPX.GT.5) WRITE(IUNOUT,500) ITID,NGIND(IG),IPQD + + ! INITIALIZE FLUX + FLUX(:NM,:NSCT,:LX,:LY,:LZ)=0.0D0 + +*---- +* LOOP OVER X-, Y- AND Z-DIRECTED AXES. +*---- + + ! X-AXIS LOOP + DO 350 I0=1,LX + I=I0 + IF((IND.EQ.2).OR.(IND.EQ.3).OR.(IND.EQ.6).OR.(IND.EQ.7)) I=LX+1-I + + ! Y-AXIS LOOP + DO 310 J0=1,LY + J=J0 + IF((IND.EQ.3).OR.(IND.EQ.4).OR.(IND.EQ.7).OR.(IND.EQ.8)) J=LY+1-J + + ! Z-BOUNDARIES CONDITIONS + XNK=0.0 + DO IEL=1,NMZ + IOF=(((M-1)*LY+(J-1))*LX+(I-1))*NMZ+IEL + IF((IND.EQ.1).OR.(IND.EQ.2).OR.(IND.EQ.3).OR.(IND.EQ.4)) THEN + XNK(IEL)=FUNKNO(LFLX+LXNI+LXNJ+IOF,IG)*ZCODE(5) + ELSE + XNK(IEL)=FUNKNO(LFLX+LXNI+LXNJ+IOF,IG)*ZCODE(6) + ENDIF + ENDDO + + ! Z-BOUNDARIES FIXED SOURCES + IF(ISBS.EQ.1) THEN + IF(((IND.EQ.5).OR.(IND.EQ.6).OR.(IND.EQ.7).OR.(IND.EQ.8)) + 1 .AND.ISBSM(6,M,IG).NE.0) THEN + XNK(1)=XNK(1)+BS((I-1)*LY+J,ISBSM(6,M,IG)) + ELSEIF(((IND.EQ.1).OR.(IND.EQ.2).OR.(IND.EQ.3).OR.(IND.EQ.4)) + 1 .AND.ISBSM(5,M,IG).NE.0) THEN + XNK(1)=XNK(1)+BS((I-1)*LY+J,ISBSM(5,M,IG)) + ENDIF + ENDIF + + ! Z-AXIS LOOP + DO 280 K0=1,LZ + K=K0 + IF((IND.EQ.5).OR.(IND.EQ.6).OR.(IND.EQ.7).OR.(IND.EQ.8)) K=LZ+1-K + + ! Y-BOUNDARIES CONDITIONS + IF(J0.EQ.1) THEN + XNJ(:NMY,K)=0.0 + DO IEL=1,NMY + IOF=(((M-1)*LZ+(K-1))*LX+(I-1))*NMY+IEL + IF((IND.EQ.1).OR.(IND.EQ.2).OR.(IND.EQ.5).OR.(IND.EQ.6)) THEN + XNJ(IEL,K)=FUNKNO(LFLX+LXNI+IOF,IG)*ZCODE(3) + ELSE + XNJ(IEL,K)=FUNKNO(LFLX+LXNI+IOF,IG)*ZCODE(4) + ENDIF + ENDDO + + !Y-BOUNDARIES FIXED SOURCES + IF(ISBS.EQ.1) THEN + IF(((IND.EQ.3).OR.(IND.EQ.4).OR.(IND.EQ.7).OR.(IND.EQ.8)) + 1 .AND.ISBSM(4,M,IG).NE.0) THEN + XNJ(1,K)=XNJ(1,K)+BS((I-1)*LZ+K,ISBSM(4,M,IG)) + ELSEIF(((IND.EQ.1).OR.(IND.EQ.2).OR.(IND.EQ.5).OR.(IND.EQ.6)) + 1 .AND.ISBSM(3,M,IG).NE.0) THEN + XNJ(1,K)=XNJ(1,K)+BS((I-1)*LZ+K,ISBSM(3,M,IG)) + ENDIF + ENDIF + ENDIF + + ! X-BOUNDARIES CONDITIONS + IF(I0.EQ.1) THEN + XNI(:NMX,J,K)=0.0 + DO IEL=1,NMX + IOF=(((M-1)*LZ+(K-1))*LY+(J-1))*NMX+IEL + IF((IND.EQ.1).OR.(IND.EQ.4).OR.(IND.EQ.5).OR.(IND.EQ.8)) THEN + XNI(IEL,J,K)=FUNKNO(LFLX+IOF,IG)*ZCODE(1) + ELSE + XNI(IEL,J,K)=FUNKNO(LFLX+IOF,IG)*ZCODE(2) + ENDIF + ENDDO + + ! X-BOUNDARIES FIXED SOURCES + IF(ISBS.EQ.1) THEN + IF(((IND.EQ.2).OR.(IND.EQ.3).OR.(IND.EQ.6).OR.(IND.EQ.7)) + 1 .AND.ISBSM(2,M,IG).NE.0) THEN + XNI(1,J,K)=XNI(1,J,K)+BS((J-1)*LZ+K,ISBSM(2,M,IG)) + ELSEIF(((IND.EQ.1).OR.(IND.EQ.4).OR.(IND.EQ.5).OR.(IND.EQ.8)) + 1 .AND.ISBSM(1,M,IG).NE.0) THEN + XNI(1,J,K)=XNI(1,J,K)+BS((J-1)*LZ+K,ISBSM(1,M,IG)) + ENDIF + ENDIF + ENDIF + + ! DATA + IBM=MAT(I,J,K) + IF(IBM.EQ.0) GO TO 280 + SIGMA=TOTAL(IBM,IG) + V=VOL(I,J,K) + + ! SOURCE DENSITY TERM + DO IEL=1,NM + Q(IEL)=0.0D0 + DO P=1,NSCT + IOF=((((K-1)*LY+(J-1))*LX+(I-1))*NSCT+(P-1))*NM+IEL + Q(IEL)=Q(IEL)+QEXT(IOF,IG)*MN(M,P) + ENDDO + ENDDO + + ISFIX=.FALSE. + DO WHILE (.NOT.ALL(ISFIX)) ! LOOP FOR ADAPTIVE CALCULATION + + ! FLUX MOMENT COEFFICIENTS MATRIX + Q2(:NM,:NM+1)=0.0D0 + + DO IZ=1,IELEM + DO JZ=1,IELEM + DO IY=1,IELEM + DO JY=1,IELEM + DO IX=1,IELEM + DO JX=1,IELEM + + II=IELEM**2*(IZ-1)+IELEM*(IY-1)+IX + JJ=IELEM**2*(JZ-1)+IELEM*(JY-1)+JX + + ! DIAGONAL TERMS + IF(II.EQ.JJ) THEN + Q2(II,JJ)=SIGMA*V + 1 +CST(IX)**2*WX(JX+1)*ABS(DA(J,K,M)) + 2 +CST(IY)**2*WY(JY+1)*ABS(DB(I,K,M)) + 3 +CST(IZ)**2*WZ(JZ+1)*ABS(DC(I,J,M)) + + ! UPPER DIAGONAL TERMS + ELSEIF(II.LT.JJ) THEN + IF(IZ.EQ.JZ) THEN + IF(IY.EQ.JY) THEN + ! X-SPACE TERMS + IF(MOD(IX+JX,2).EQ.1) THEN + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*DA(J,K,M) + ELSE + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*ABS(DA(J,K,M)) + ENDIF + ELSEIF(IX.EQ.JX) THEN + ! Y-SPACE TERMS + IF(MOD(IY+JY,2).EQ.1) THEN + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*DB(I,K,M) + ELSE + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ABS(DB(I,K,M)) + ENDIF + ENDIF + ELSEIF(IY.EQ.JY.AND.IX.EQ.JX) THEN + ! Z-SPACE TERMS + IF(MOD(IZ+JZ,2).EQ.1) THEN + Q2(II,JJ)=CST(IZ)*CST(JZ)*WZ(JZ+1)*DC(I,J,M) + ELSE + Q2(II,JJ)=CST(IZ)*CST(JZ)*WZ(JZ+1)*ABS(DC(I,J,M)) + ENDIF + ENDIF + + ! UNDER DIAGONAL TERMS + ELSE + IF(IZ.EQ.JZ) THEN + IF(IY.EQ.JY) THEN + ! X-SPACE TERMS + IF(MOD(IX+JX,2).EQ.1) THEN + Q2(II,JJ)=CST(IX)*CST(JX)*(WX(JX+1)-2)*DA(J,K,M) + ELSE + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*ABS(DA(J,K,M)) + ENDIF + ELSEIF(IX.EQ.JX) THEN + ! Y-SPACE TERMS + IF(MOD(IY+JY,2).EQ.1) THEN + Q2(II,JJ)=CST(IY)*CST(JY)*(WY(JY+1)-2)*DB(I,K,M) + ELSE + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ABS(DB(I,K,M)) + ENDIF + ENDIF + ELSEIF(IY.EQ.JY.AND.IX.EQ.JX) THEN + ! Z-SPACE TERMS + IF(MOD(IZ+JZ,2).EQ.1) THEN + Q2(II,JJ)=CST(IZ)*CST(JZ)*(WZ(JZ+1)-2)*DC(I,J,M) + ELSE + Q2(II,JJ)=CST(IZ)*CST(JZ)*WZ(JZ+1)*ABS(DC(I,J,M)) + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + + ! FLUX SOURCE VECTOR + DO IZ=1,IELEM + DO IY=1,IELEM + DO IX=1,IELEM + II=IELEM**2*(IZ-1)+IELEM*(IY-1)+IX + IIX=IELEM*(IZ-1)+IY + IIY=IELEM*(IZ-1)+IX + IIZ=IELEM*(IY-1)+IX + Q2(II,NM+1)=Q(II)*V + ! X-SPACE TERMS + IF(MOD(IX,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IX)*(1-WX(1)) + 1 *XNI(IIX,J,K)*ABS(DA(J,K,M)) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IX)*(1+WX(1)) + 1 *XNI(IIX,J,K)*DA(J,K,M) + ENDIF + ! Y-SPACE TERMS + IF(MOD(IY,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IY)*(1-WY(1)) + 1 *XNJ(IIY,K)*ABS(DB(I,K,M)) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IY)*(1+WY(1)) + 1 *XNJ(IIY,K)*DB(I,K,M) + ENDIF + ! Z-SPACE TERMS + IF(MOD(IZ,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IZ)*(1-WZ(1)) + 1 *XNK(IIZ)*ABS(DC(I,J,M)) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IZ)*(1+WZ(1)) + 1 *XNK(IIZ)*DC(I,J,M) + ENDIF + ENDDO + ENDDO + ENDDO + + CALL ALSBD(NM,1,Q2,IER,NM) + IF(IER.NE.0) CALL XABORT('SNFBC3: SINGULAR MATRIX.') + + ! ADAPTIVE CORRECTION OF WEIGHTING PARAMETERS + IF(ANY(ISADPT)) THEN + IF(ISADPT(1)) THEN + CALL SNADPT(IELEM,NM,IELEM**2,Q2(1:IELEM:1,NM+1), + 1 XNI(:NMX,J,K),1.0,WX,ISFIX(1)) + ELSE + ISFIX(1)=.TRUE. + ENDIF + IF(ISADPT(2)) THEN + CALL SNADPT(IELEM,NM,IELEM**2,Q2(1:IELEM**2:IELEM,NM+1), + 1 XNJ(:NMY,K),1.0,WY,ISFIX(2)) + ELSE + ISFIX(2)=.TRUE. + ENDIF + IF(ISADPT(3)) THEN + CALL SNADPT(IELEM,NM,IELEM**2,Q2(1:NM:IELEM**2,NM+1), + 1 XNK,1.0,WZ,ISFIX(3)) + ELSE + ISFIX(3)=.TRUE. + ENDIF + ELSE + ISFIX=.TRUE. + ENDIF + + END DO ! END OF ADAPTIVE LOOP + + ! CLOSURE RELATIONS + IF(IELEM.EQ.1.AND.LFIXUP.AND.(Q2(1,2).LE.RLOG)) Q2(1,2)=0.0 + XNI(:NMX,J,K)=WX(1)*XNI(:NMX,J,K) + XNJ(:NMY,K)=WY(1)*XNJ(:NMY,K) + XNK(:NMZ)=WZ(1)*XNK(:NMZ) + DO IZ=1,IELEM + DO IY=1,IELEM + DO IX=1,IELEM + II=IELEM**2*(IZ-1)+IELEM*(IY-1)+IX + IIX=IELEM*(IZ-1)+IY + IIY=IELEM*(IZ-1)+IX + IIZ=IELEM*(IY-1)+IX + ! X-SPACE + IF(MOD(IX,2).EQ.1) THEN + XNI(IIX,J,K)=XNI(IIX,J,K)+CST(IX)*WX(IX+1) + 1 *Q2(II,NM+1) + ELSE + XNI(IIX,J,K)=XNI(IIX,J,K)+CST(IX)*WX(IX+1) + 1 *Q2(II,NM+1)*SIGN(1.0,DA(J,K,M)) + ENDIF + ! Y-SPACE + IF(MOD(IY,2).EQ.1) THEN + XNJ(IIY,K)=XNJ(IIY,K)+CST(IY)*WY(IY+1) + 1 *Q2(II,NM+1) + ELSE + XNJ(IIY,K)=XNJ(IIY,K)+CST(IY)*WY(IY+1) + 1 *Q2(II,NM+1)*SIGN(1.0,DB(I,K,M)) + ENDIF + ! Z-SPACE + IF(MOD(IZ,2).EQ.1) THEN + XNK(IIZ)=XNK(IIZ)+CST(IZ)*WZ(IZ+1) + 1 *Q2(II,NM+1) + ELSE + XNK(IIZ)=XNK(IIZ)+CST(IZ)*WZ(IZ+1) + 1 *Q2(II,NM+1)*SIGN(1.0,DC(I,J,M)) + ENDIF + ENDDO + ENDDO + ENDDO + IF(IELEM.EQ.1.AND.LFIXUP.AND.(XNI(1,J,K).LE.RLOG)) + 1 XNI(1,J,K)=0.0 + IF(IELEM.EQ.1.AND.LFIXUP.AND.(XNJ(1,K).LE.RLOG)) + 1 XNJ(1,K)=0.0 + IF(IELEM.EQ.1.AND.LFIXUP.AND.(XNK(1).LE.RLOG)) XNK(1)=0.0 + WX=WX0 + WY=WY0 + WZ=WZ0 + + ! SAVE LEGENDRE MOMENT OF THE FLUX + DO P=1,NSCT + DO IEL=1,NM + FLUX(IEL,P,I,J,K)=FLUX(IEL,P,I,J,K)+Q2(IEL,NM+1)*DN(P,M) + ENDDO + ENDDO + + 280 CONTINUE ! END OF Z-LOOP + + ! SAVE BOUNDARY CONDITIONS + DO IEL=1,NMZ + IOF=(((M-1)*LY+(J-1))*LX+(I-1))*NMZ+IEL + FUNKNO(LFLX+LXNI+LXNJ+IOF,IG)=REAL(XNK(IEL)) + ENDDO + + 310 CONTINUE ! END OF Y-LOOP + + ! SAVE BOUNDARY CONDITIONS + DO K=1,LZ + DO IEL=1,NMY + IOF=(((M-1)*LZ+(K-1))*LX+(I-1))*NMY+IEL + FUNKNO(LFLX+LXNI+IOF,IG)=REAL(XNJ(IEL,K)) + ENDDO + ENDDO + + 350 CONTINUE ! END OF X-LOOP + + ! SAVE BOUNDARY CONDITIONS + DO K=1,LZ + DO J=1,LY + DO IEL=1,NMX + IOF=(((M-1)*LZ+(K-1))*LY+(J-1))*NMX+IEL + FUNKNO(LFLX+IOF,IG)=REAL(XNI(IEL,J,K)) + ENDDO + ENDDO + ENDDO + + ! SAVE FLUX INFORMATION + FLUX_G(:,:,:,:,:,IG)=FLUX_G(:,:,:,:,:,IG)+FLUX(:,:,:,:,:) + + 400 CONTINUE ! END OF DIRECTION LOOP + 410 CONTINUE ! END OF ENERGY LOOP +*$OMP END PARALLEL DO + 420 CONTINUE ! END OF OCTANT LOOP + + ! SAVE FLUX INFORMATION + DO 430 IG=1,NGEFF + IF(.NOT.INCONV(IG)) GO TO 430 + FUNKNO(:LFLX,IG)= + 1 RESHAPE(REAL(FLUX_G(:NM,:NSCT,:LX,:LY,:LZ,IG)), + 2 (/LFLX/)) + 430 CONTINUE + +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(FLUX_G,FLUX,XNJ,XNI,INDANG) + RETURN + 500 FORMAT(16H SNFBC3: thread=,I8,12H --->(group=,I4,7H angle=,I4,1H)) + END diff --git a/Dragon/src/SNFBH2.F b/Dragon/src/SNFBH2.F new file mode 100644 index 0000000..6ff2f01 --- /dev/null +++ b/Dragon/src/SNFBH2.F @@ -0,0 +1,598 @@ +*DECK SNFBH2 + SUBROUTINE SNFBH2(NUN,NGEFF,IMPX,INCONV,NGIND,NHEX,ISPLH,SIDE, + 1 IELEM,NM,NMX,NMY,NMAT,NPQ,NSCT,MAT,VOL,TOTAL,QEXT,LFIXUP,DU,DE,W, + 2 DB,DA,MN,DN,WX,WY,CST,ISADPT,LOZSWP,COORDMAP,FUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform one inner iteration for solving SN equations in 2D hexagonal +* geometry for the HODD/DG method. Energy-angle multithreading. VOID +* boundary conditions. Boltzmann (BTE) discretization. + +* +*Copyright: +* Copyright (C) 2025 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert, A. A. Calloo and C. Bienvenue +* +*Parameters: input +* NUN total number of unknowns in vector FUNKNO. +* NGEFF number of energy groups processed in parallel. +* IMPX print flag (equal to zero for no print). +* INCONV energy group convergence flag (set to .FALSE. if converged). +* NGIND energy group indices assign to the NGEFF set. +* NHEX number of hexagons in X-Y plane. +* ISPLH splitting option for hexagons. +* SIDE side of an hexagon. +* IELEM measure of order of the spatial approximation polynomial: +* =1 constant - default for HODD; +* =2 linear - default for DG; +* >3 higher orders. +* NM number of moments in space and energy for flux components +* NMX number of moments for X axis boundaries components +* NMY number of moments for Y axis boundaries components +* NMAT number of material mixtures. +* NPQ number of SN directions in four octants (including zero-weight +* directions). +* NSCT maximum number of spherical harmonics moments of the flux. +* MAT material mixture index in each region. +* VOL volumes of each region. +* TOTAL macroscopic total cross sections. +* QEXT Legendre components of the fixed source. +* LFIXUP flag to enable negative flux fixup. +* DU first direction cosines ($\\mu$). +* DE second direction cosines ($\\eta$). +* W weights. +* DB diamond-scheme parameter. +* DA diamond-scheme parameter. +* MN moment-to-discrete matrix. +* DN discrete-to-moment matrix. +* WX spatial X axis closure relation weighting factors. +* WY spatial Y axis closure relation weighting factors. +* CST constants for the polynomial approximations. +* ISADPT flag to enable/disable adaptive flux calculations. +* LOZSWP lozenge sweep order depending on direction. +* COORDMAP coordinate map - mapping the hexagons from the indices +* within the DRAGON geometry to a Cartesian axial coordinate +* array (see redblobgames.com website). +* +*Parameters: input/output +* FUNKNO Legendre components of the flux and boundary fluxes. +* +*Comments: +* 1. The direction of the axes I, J and D for the surface boundary +* fluxes are shown in the diagram below. This means that +* i) lozenge A has I- and D-boundaries (instead of I and J) +* i) lozenge B has I- and J-boundaries +* i) lozenge C has D- and J-boundaries (instead of I and J) +* +* ^ +* j-axis | +* | ^ +* _________ / d-axis +* / / \ / +* / B / \ +* / / \ +* (-------( A ) +* \ \ / +* \ C \ / +* \_______\_/ \ +* \ i-axis +* ^ +* +*----------------------------------------------------------------------- +#if defined(_OPENMP) + USE omp_lib +#endif +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NUN,NGEFF,IMPX,NGIND(NGEFF),NHEX,ISPLH,IELEM,NM,NMX, + 1 NMY,NMAT,NPQ,NSCT,MAT(ISPLH,ISPLH,3,NHEX),LOZSWP(3,6), + 2 COORDMAP(3,NHEX) + LOGICAL INCONV(NGEFF) + REAL SIDE,VOL(ISPLH,ISPLH,3,NHEX),TOTAL(0:NMAT,NGEFF), + 1 QEXT(NUN,NGEFF),DU(NPQ),DE(NPQ),W(NPQ), + 2 DB(ISPLH,ISPLH,3,NHEX,NPQ),DA(ISPLH,ISPLH,3,NHEX,NPQ), + 3 MN(NPQ,NSCT),DN(NSCT,NPQ),FUNKNO(NUN,NGEFF),WX(IELEM+1), + 3 WY(IELEM+1),CST(IELEM) + LOGICAL LFIXUP,ISADPT(2) +*---- +* LOCAL VARIABLES +*---- + INTEGER :: NPQD(6),IIND(6),P,DCOORD + REAL :: JAC(2,2,3), MUH, ETAH, AAA, BBB, CCC, DDD, MUHTEMP, + 1 ETAHTEMP, WX0(IELEM+1),WY0(IELEM+1) + DOUBLE PRECISION :: Q(NM), Q2(NM,NM+1), V,THETA, XNI(NMX), + 1 XNJ(NMY) + PARAMETER(IUNOUT=6,RLOG=1.0E-8,PI=3.141592654) + LOGICAL :: LHEX(NHEX) + LOGICAL ISFIX(2) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: INDANG + INTEGER, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: TMPMAT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:) :: FLUX + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: FLUX_G + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: TMPXNI, + > TMPXNJ, TMPXND +*---- +* MAP MATERIAL VALUES TO CARTESIAN AXIAL COORDINATE MAP +*---- + NRINGS=INT((SQRT( REAL((4*NHEX-1)/3) )+1.)/2.) + NCOL=2*NRINGS -1 + ALLOCATE(TMPMAT(ISPLH,ISPLH,3,NCOL,NCOL)) + TMPMAT(:,:,:,:,:) = -1 + DO IHEX_DOM=1,NHEX + TMPMAT(:,:,:,COORDMAP(1,IHEX_DOM),COORDMAP(2,IHEX_DOM)) = + > MAT(:,:,:,IHEX_DOM) + ENDDO +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(INDANG(NPQ,6)) + ALLOCATE(FLUX(NM,NSCT,3*ISPLH**2,NHEX)) + ALLOCATE(FLUX_G(NM,NSCT,3*ISPLH**2,NHEX,NGEFF)) + ALLOCATE(TMPXNI(IELEM,ISPLH,NCOL)) + ALLOCATE(TMPXNJ(IELEM,ISPLH,NCOL)) + ALLOCATE(TMPXND(IELEM,ISPLH,NCOL)) +*---- +* CONSTRUCT JACOBIAN MATRIX FOR EACH LOZENGE +*---- + JAC = RESHAPE((/ 1., -SQRT(3.), 1., SQRT(3.), 2., 0., 1., + > SQRT(3.), 2., 0., -1., SQRT(3.) /), SHAPE(JAC)) + JAC = (SIDE/2.)*JAC +*---- +* LENGTH OF FUNKNO COMPONENTS (IN ORDER) +*---- + LFLX=3*NM*(ISPLH**2)*NHEX*NSCT +*---- +* SET DODECANT SWAPPING ORDER +*---- + NPQD(:6)=0 + INDANG(:NPQ,:6)=0 + IIND(:6)=0 + DO M=1,NPQ + VU=DU(M) + VE=DE(M) + IF(W(M).EQ.0) CYCLE + THETA=0.0D0 + IF(VE.GT.0.0)THEN + IF(VU.EQ.0.0)THEN + THETA = PI/2 + ELSEIF(VU.GT.0.0)THEN + THETA = ATAN(ABS(VE/VU)) + ELSEIF(VU.LT.0.0)THEN + THETA = PI - ATAN(ABS(VE/VU)) + ENDIF + ELSEIF(VE.LT.0.0)THEN + IF(VU.EQ.0.0)THEN + THETA = 3*PI/2 + ELSEIF(VU.LT.0.0)THEN + THETA = PI + ATAN(ABS(VE/VU)) + ELSEIF(VU.GT.0.0)THEN + THETA = 2.*PI - ATAN(ABS(VE/VU)) + ENDIF + ENDIF + IND=0 + IF((THETA.GT.0.0).AND.(THETA.LT.(PI/3.)))THEN + IND=1 + ELSEIF((THETA.GT.(PI/3.)).AND.(THETA.LT.(2.*PI/3.)))THEN + IND=2 + ELSEIF((THETA.GT.(2.*PI/3.)).AND.(THETA.LT.(PI)))THEN + IND=3 + ELSEIF((THETA.GT.(PI)).AND.(THETA.LT.(4.*PI/3.)))THEN + IND=4 + ELSEIF((THETA.GT.(4.*PI/3.)).AND.(THETA.LT.(5.*PI/3.)))THEN + IND=5 + ELSEIF((THETA.GT.(5.*PI/3.)).AND.(THETA.LT.(2.*PI)))THEN + IND=6 + ENDIF + ! Assume IIND(I)=I in hexagonal geometry + IIND(IND)=IND + NPQD(IND)=NPQD(IND)+1 + INDANG(NPQD(IND),IND)=M + ENDDO +*---- +* MAIN LOOP OVER DODECANTS +*---- + + FLUX_G(:NM,:NSCT,:3*ISPLH**2,:NHEX,:NGEFF)=0.0D0 + WX0=WX + WY0=WY + + DO JND=1,6 + IND=IIND(JND) + ! Needed because of S2 LS (4 dir. for 6 sextants) + IF(IND.EQ.0) CYCLE + +*---- +* MAIN SWAPPING LOOPS FOR SN FLUX CALCULATION +* LOOP OVER ENERGY AND ANGLES +*---- + +*$OMP PARALLEL DO +*$OMP+ PRIVATE(ITID,FLUX,M,IG,XNI,XNJ,Q,Q2,IOF,IER,II,JJ,IEL,I,J,P) +*$OMP+ PRIVATE(IPQD,IBM,SIGMA,V,ISFIX,IX,JX,IY,JY,AAA,BBB,CCC,DDD) +*$OMP+ PRIVATE(LHEX,IHEX,IIHEX,DCOORD,ILOZLOOP,ILOZ,IL,I2,JL,J2) +*$OMP+ PRIVATE(MUHTEMP,MUH,ETAHTEMP,ETAH,I3,I_FETCH,III,JJJ,IIM,JIM) +*$OMP+ PRIVATE(TMPXNI,TMPXNJ,TMPXND) +*$OMP+ FIRSTPRIVATE(WX,WY,WX0,WY0) SHARED(FUNKNO) +*$OMP+ REDUCTION(+:FLUX_G) COLLAPSE(2) + + ! LOOP FOR GROUPS TO EXECUTE IN PARALLEL + DO IG=1,NGEFF + + ! LOOP OVER ALL DIRECTIONS + DO IPQD=1,NPQD(IND) + IF(.NOT.INCONV(IG)) CYCLE + M=INDANG(IPQD,IND) + IF(W(M).EQ.0.0) CYCLE + + ! GET AND PRINT THREAD NUMBER +#if defined(_OPENMP) + ITID=omp_get_thread_num() +#else + ITID=0 +#endif + IF(IMPX.GT.5) WRITE(IUNOUT,400) ITID,NGIND(IG),IPQD + + ! INITIALIZE FLUXES AND BOUNDARY FLUXES + FLUX(:NM,:NSCT,:3*ISPLH**2,:NHEX)=0.0D0 + TMPXNI(:IELEM,:ISPLH,:NCOL)=0.0D0 + TMPXNJ(:IELEM,:ISPLH,:NCOL)=0.0D0 + TMPXND(:IELEM,:ISPLH,:NCOL)=0.0D0 + + ! LOOP OVER CARTESIAN MAP OF HEXAGONAL DOMAIN + DO JJJ=1,NCOL + JIM=JJJ + ! Account for different sweep direction depending on angle + IF((IND.EQ.1).OR.(IND.EQ.2).OR.(IND.EQ.3)) JIM=NCOL+1-JIM + + DO III=1,NCOL + IIM=III + ! Account for different sweep direction depending on angle + IF((IND.EQ.2).OR.(IND.EQ.3).OR.(IND.EQ.4)) IIM=NCOL+1-IIM + + ! For IND 3 or 6, Cartesian axial coordinate map is swept + ! vertically instead of horizontally. IM suffix is for 'IMmutable' + I=IIM + J=JIM + IF((IND.EQ.3).OR.(IND.EQ.6))THEN + I=JIM + J=IIM + ENDIF + + ! If within corners of Cartesian axial coordinate map (where + ! there are no hexagons), skip loop + IF(TMPMAT(1,1,1,I,J).EQ.-1) CYCLE + + ! Find DRAGON geometry hexagonal index using I and J + LHEX=(COORDMAP(1,:).EQ.I .AND. COORDMAP(2,:).EQ.J) + IHEX=0 + DO IIHEX=1,NHEX + IF(LHEX(IIHEX)) THEN + IHEX=IIHEX + EXIT + ENDIF + ENDDO + IF(IHEX.EQ.0) CALL XABORT('SNFTH1: IHEX FAILURE.') + ! Find D coordinate + DCOORD = ABS(COORDMAP(3,IHEX))-NRINGS + + ! LOOP OVER LOZENGES + DO ILOZLOOP=1,3 + ILOZ=LOZSWP(ILOZLOOP,IND) + + ! Get Jacobian elements values + AAA = JAC(1,1,ILOZ) + BBB = JAC(1,2,ILOZ) + CCC = JAC(2,1,ILOZ) + DDD = JAC(2,2,ILOZ) + + + ! LOOP OVER SUBMESH WITHIN EACH LOZENGE + DO IL=1,ISPLH + I2=IL + ! Account for different sweep direction depending on angle + IF((ILOZ.EQ.1).OR.(ILOZ.EQ.2))THEN + IF((IND.EQ.2).OR.(IND.EQ.3).OR.(IND.EQ.4)) I2=ISPLH+1-I2 + ELSEIF(ILOZ.EQ.3)THEN + IF((IND.EQ.3).OR.(IND.EQ.4).OR.(IND.EQ.5)) I2=ISPLH+1-I2 + ENDIF + + DO JL=1,ISPLH + J2=JL + ! Account for different sweep direction depending on angle + IF((ILOZ.EQ.2).OR.(ILOZ.EQ.3))THEN + IF((IND.EQ.4).OR.(IND.EQ.5).OR.(IND.EQ.6)) J2=ISPLH+1-J2 + ELSEIF(ILOZ.EQ.1)THEN + IF((IND.EQ.3).OR.(IND.EQ.4).OR.(IND.EQ.5)) J2=ISPLH+1-J2 + ENDIF + + ! READ IN XNI AND XNJ DEPENDING ON LOZENGE + I_FETCH=0 + IF((ILOZ.EQ.1))THEN + ! Read boundary fluxes in reverse for lozenge A since affine + ! transformation of lozenges causes the D and I directions + ! of lozenges C and A respectively to be reversed + I_FETCH=ISPLH+1-I2 + XNI(:) = TMPXNI(:,J2,J) + XNJ(:) = TMPXND(:,I_FETCH,DCOORD) + ELSEIF((ILOZ.EQ.2))THEN + XNI(:) = TMPXNI(:,J2,J) + XNJ(:) = TMPXNJ(:,I2,I) + ELSEIF((ILOZ.EQ.3))THEN + XNI(:) = TMPXND(:,J2,DCOORD) + XNJ(:) = TMPXNJ(:,I2,I) + ENDIF + + ! DATA + IBM=MAT(I2,J2,ILOZ,IHEX) + ! Skip loop if virtual element + IF(IBM.EQ.0) CYCLE + SIGMA=TOTAL(IBM,IG) + V=VOL(I2,J2,ILOZ,IHEX) + + ! COMPUTE ADJUSTED DIRECTION COSINES + MUHTEMP = DA(I2,J2,ILOZ,IHEX,M) + ETAHTEMP = DB(I2,J2,ILOZ,IHEX,M) + MUH = (MUHTEMP*DDD) - (ETAHTEMP*BBB) + ETAH = (-MUHTEMP*CCC) + (ETAHTEMP*AAA) + + ! SOURCE DENSITY TERM + DO IEL=1,NM + Q(IEL)=0.0D0 + DO P=1,NSCT + IOF=((((((IHEX-1)*3+(ILOZ-1))*ISPLH+(J2-1))*ISPLH+ + 1 (I2-1))*NSCT+(P-1))*NM)+IEL + Q(IEL)=Q(IEL)+QEXT(IOF,IG)*MN(M,P) + ENDDO + ENDDO + + ISFIX=.FALSE. + DO WHILE (.NOT.ALL(ISFIX)) ! LOOP FOR ADAPTIVE CALCULATION + + ! FLUX MOMENT COEFFICIENTS MATRIX + Q2(:NM,:NM+1)=0.0D0 + + DO IY=1,IELEM + DO JY=1,IELEM + DO IX=1,IELEM + DO JX=1,IELEM + II=IELEM*(IY-1)+IX + JJ=IELEM*(JY-1)+JX + + ! DIAGONAL TERMS + IF(II.EQ.JJ) THEN + Q2(II,JJ)=SIGMA*V + 1 +CST(IX)**2*WX(JX+1)*ABS(MUH) + 2 +CST(IY)**2*WY(JY+1)*ABS(ETAH) + + ! UPPER DIAGONAL TERMS + ELSEIF(II.LT.JJ) THEN + ! X-SPACE TERMS + IF(IY.EQ.JY) THEN + IF(MOD(IX+JX,2).EQ.1) THEN + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*MUH + ELSE + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*ABS(MUH) + ENDIF + ! Y-SPACE TERMS + ELSEIF(IX.EQ.JX) THEN + IF(MOD(IY+JY,2).EQ.1) THEN + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ETAH + ELSE + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ABS(ETAH) + ENDIF + ENDIF + + ! UNDER DIAGONAL TERMS + ELSE + ! X-SPACE TERMS + IF(IY.EQ.JY) THEN + IF(MOD(IX+JX,2).EQ.1) THEN + Q2(II,JJ)=CST(IX)*CST(JX)*(WX(JX+1)-2)*MUH + ELSE + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*ABS(MUH) + ENDIF + ! Y-SPACE TERMS + ELSEIF(IX.EQ.JX) THEN + IF(MOD(IY+JY,2).EQ.1) THEN + Q2(II,JJ)=CST(IY)*CST(JY)*(WY(JY+1)-2)*ETAH + ELSE + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ABS(ETAH) + ENDIF + ENDIF + + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + + ! FLUX SOURCE VECTOR + DO IY=1,IELEM + DO IX=1,IELEM + II=IELEM*(IY-1)+IX + Q2(II,NM+1)=Q(II)*V + ! X-SPACE TERMS + IF(MOD(IX,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IX)*(1-WX(1)) + 1 *XNI(IY)*ABS(MUH) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IX)*(1+WX(1)) + 1 *XNI(IY)*MUH + ENDIF + ! Y-SPACE TERMS + IF(MOD(IY,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IY)*(1-WY(1)) + 1 *XNJ(IX)*ABS(ETAH) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IY)*(1+WY(1)) + 1 *XNJ(IX)*ETAH + ENDIF + ENDDO + ENDDO + + CALL ALSBD(NM,1,Q2,IER,NM) + IF(IER.NE.0) CALL XABORT('SNFBH2: SINGULAR MATRIX.') + + ! ADAPTIVE CORRECTION OF WEIGHTING PARAMETERS + IF(ANY(ISADPT)) THEN + IF(ISADPT(1)) THEN + CALL SNADPT(IELEM,NM,IELEM,Q2(1:IELEM:1,NM+1), + 1 XNI(:NMX),1.0,WX,ISFIX(1)) + ELSE + ISFIX(1)=.TRUE. + ENDIF + IF(ISADPT(2)) THEN + CALL SNADPT(IELEM,NM,IELEM,Q2(1:NM:IELEM,NM+1), + 1 XNJ(:NMY),1.0,WY,ISFIX(2)) + ELSE + ISFIX(2)=.TRUE. + ENDIF + ELSE + ISFIX=.TRUE. + ENDIF + + END DO ! END OF ADAPTIVE LOOP + + ! CLOSURE RELATIONS + IF(IELEM.EQ.1.AND.LFIXUP.AND.(Q2(1,2).LE.RLOG)) Q2(1,2)=0.0 + ! Read XNI/XNI into TMPXNI/J/D + IF((ILOZ.EQ.1).OR.(ILOZ.EQ.2))THEN + TMPXNI(:NMX,J2,J)=WX(1)*XNI(:NMX) + ELSE + TMPXND(:NMX,J2,DCOORD)=WX(1)*XNI(:NMX) + ENDIF + IF((ILOZ.EQ.2).OR.(ILOZ.EQ.3))THEN + TMPXNJ(:NMY,I2,I)=WY(1)*XNJ(:NMY) + ELSE + I3=I_FETCH + TMPXND(:NMY,I3,DCOORD)=WY(1)*XNJ(:NMY) + ENDIF + DO IY=1,IELEM + DO IX=1,IELEM + II=IELEM*(IY-1)+IX + ! X-SPACE + ! Assign I-boundary fluxes if lozenges A or B + IF((ILOZ.EQ.1).OR.(ILOZ.EQ.2))THEN + IF(MOD(IX,2).EQ.1) THEN + TMPXNI(IY,J2,J)=TMPXNI(IY,J2,J)+CST(IX)*WX(IX+1) + 1 *Q2(II,NM+1) + ELSE + TMPXNI(IY,J2,J)=TMPXNI(IY,J2,J)+CST(IX)*WX(IX+1) + 1 *Q2(II,NM+1)*SIGN(1.0,MUH) + ENDIF + ENDIF + ! Y-SPACE + ! Assign J-boundary fluxes if lozenges B or C + IF((ILOZ.EQ.2).OR.(ILOZ.EQ.3))THEN + IF(MOD(IY,2).EQ.1) THEN + TMPXNJ(IX,I2,I)=TMPXNJ(IX,I2,I)+CST(IY)*WY(IY+1) + 1 *Q2(II,NM+1) + ELSE + TMPXNJ(IX,I2,I)=TMPXNJ(IX,I2,I)+CST(IY)*WY(IY+1) + 1 *Q2(II,NM+1)*SIGN(1.0,ETAH) + ENDIF + ENDIF + ! D-SPACE + ! Assign D-boundary fluxes if lozenge A using XNJ + IF((ILOZ.EQ.1))THEN + I3=I_FETCH + IF(MOD(IY,2).EQ.1) THEN + TMPXND(IX,I3,DCOORD)=TMPXND(IX,I3,DCOORD)+CST(IY)*WY(IY+1) + 1 *Q2(II,NM+1) + ELSE + TMPXND(IX,I3,DCOORD)=TMPXND(IX,I3,DCOORD)+CST(IY)*WY(IY+1) + 1 *Q2(II,NM+1)*SIGN(1.0,ETAH) + ENDIF + ENDIF + ! Assign D-boundary fluxes if lozenge C using XNI + IF((ILOZ.EQ.3))THEN + IF(MOD(IX,2).EQ.1) THEN + TMPXND(IY,J2,DCOORD)=TMPXND(IY,J2,DCOORD)+CST(IX)*WX(IX+1) + 1 *Q2(II,NM+1) + ELSE + TMPXND(IY,J2,DCOORD)=TMPXND(IY,J2,DCOORD)+CST(IX)*WX(IX+1) + 1 *Q2(II,NM+1)*SIGN(1.0,MUH) + ENDIF + ENDIF + ENDDO + ENDDO + ! FLIP GRADIENTS IF NECESSARY + DO IY=1,IELEM + IF((MOD(IY,2).EQ.0).AND.(ILOZ.EQ.3).AND.(IL.EQ.ISPLH)) + 1 TMPXND(IY,J2,DCOORD)=TMPXND(IY,J2,DCOORD)*(-1) + ENDDO + I3=I_FETCH + DO IX=1,IELEM + IF((MOD(IX,2).EQ.0).AND.(ILOZ.EQ.1).AND.(JL.EQ.ISPLH)) + 1 TMPXND(IX,I3,DCOORD)=TMPXND(IX,I3,DCOORD)*(-1) + ENDDO + ! LFIXUP + IF(IELEM.EQ.1.AND.LFIXUP)THEN + IF((ILOZ.EQ.1).OR.(ILOZ.EQ.2))THEN + IF(TMPXNI(1,J2,J).LE.RLOG) TMPXNI(1,J2,J)=0.0 + ELSE + IF(TMPXND(1,J2,DCOORD).LE.RLOG) TMPXND(1,J2,DCOORD)=0.0 + ENDIF + IF((ILOZ.EQ.2).OR.(ILOZ.EQ.3))THEN + IF(TMPXNJ(1,I2,I).LE.RLOG) TMPXNJ(1,I2,I)=0.0 + ELSE + I3=I_FETCH + IF(TMPXND(1,I3,DCOORD).LE.RLOG) TMPXND(1,I3,DCOORD)=0.0 + ENDIF + ENDIF + WX=WX0 + WY=WY0 + + ! SAVE LEGENDRE MOMENT OF THE FLUX + IOF=((ILOZ-1)*ISPLH+(J2-1))*ISPLH+I2 + DO P=1,NSCT + DO IEL=1,NM + FLUX(IEL,P,IOF,IHEX)=FLUX(IEL,P,IOF,IHEX)+Q2(IEL,NM+1)*DN(P,M) + ENDDO + ENDDO + + ENDDO ! END OF WITHIN LOZENGE J-LOOP + ENDDO ! END OF WITHIN LOZENGE I-LOOP + + ENDDO ! END OF LOZENGE LOOP + + ENDDO ! END OF I COLUMNS OF CARTESIAN MAP LOOP + ENDDO ! END OF J COLUMNS OF CARTESIAN MAP LOOP + + ! SAVE FLUX INFORMATION + FLUX_G(:,:,:,:,IG)=FLUX_G(:,:,:,:,IG)+FLUX(:,:,:,:) + + ENDDO ! END OF DIRECTION LOOP + ENDDO ! END OF ENERGY LOOP +*$OMP END PARALLEL DO + ENDDO ! END OF OCTANT LOOP + + ! SAVE FLUX INFORMATION + DO IG=1,NGEFF + IF(.NOT.INCONV(IG)) CYCLE + FUNKNO(:LFLX,IG)= + 1 RESHAPE(REAL(FLUX_G(:IELEM**2,:NSCT,:3*ISPLH**2,:NHEX,IG)), + 2 (/ LFLX /) ) + ENDDO + + ! CALL XABORT('SNFBH2: testing') + +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(FLUX_G,FLUX,INDANG,TMPXNI,TMPXNJ,TMPXND,TMPMAT) + RETURN + 400 FORMAT(16H SNFBH2: thread=,I8,12H --->(group=,I4,7H angle=,I4,1H)) + END diff --git a/Dragon/src/SNFBH3.F b/Dragon/src/SNFBH3.F new file mode 100644 index 0000000..cc7b8d7 --- /dev/null +++ b/Dragon/src/SNFBH3.F @@ -0,0 +1,793 @@ +*DECK SNFBH3 + SUBROUTINE SNFBH3(NUN,NGEFF,IMPX,INCONV,NGIND,NHEX,LZ,ISPLH,SIDE, + 1 IELEM,NM,NMX,NMY,NMZ,NMAT,NPQ,NSCT,MAT,VOL,TOTAL,NCODE,ZCODE, + 2 QEXT,LFIXUP,DU,DE,DZ,W,MRMZ,DC,DB,DA,MN,DN,WX,WY,WZ,CST,ISADPT, + 3 LOZSWP,COORDMAP,FUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform one inner iteration for solving SN equations in 3D Cartesian +* geometry for the HODD method. Energy-angle multithreading. Albedo +* boundary conditions on top/bottom, Void on sides. Boltzmann (BTE) +* discretization. +* +*Copyright: +* Copyright (C) 2025 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert, A. A. Calloo and C. Bienvenue +* +*Parameters: input +* NUN total number of unknowns in vector FUNKNO. +* NGEFF number of energy groups processed in parallel. +* IMPX print flag (equal to zero for no print). +* INCONV energy group convergence flag (set to .FALSE. if converged). +* NGIND energy group indices assign to the NGEFF set. +* NHEX number of hexagons in X-Y plane. +* ISPLH splitting option for hexagons. +* SIDE side of an hexagon. +* LZ number of meshes along Z axis. +* IELEM measure of order of the spatial approximation polynomial: +* =1 constant - default for HODD; +* =2 linear - default for DG; +* >3 higher orders. +* NM number of moments in space for flux components +* NMX number of moments for X axis boundaries components +* NMY number of moments for Y axis boundaries components +* NMZ number of moments for Z axis boundaries components +* NMAT number of material mixtures. +* NPQ number of SN directions in height octants. +* NSCT maximum number of spherical harmonics moments of the flux. +* MAT material mixture index in each region. +* VOL volumes of each region. +* TOTAL macroscopic total cross sections. +* ESTOPW stopping power. +* NCODE boundary condition indices. +* ZCODE albedos. +* DELTAE energy group width in MeV. +* QEXT Legendre components of the fixed source. +* LFIXUP flag to enable negative flux fixup. +* DU first direction cosines ($\\mu$). +* DE second direction cosines ($\\eta$). +* DZ third direction cosines ($\\xi$). +* W weights. +* MRMZ quadrature index. +* DC diamond-scheme parameter. +* DB diamond-scheme parameter. +* DA diamond-scheme parameter. +* MN moment-to-discrete matrix. +* DN discrete-to-moment matrix. +* WX spatial X axis closure relation weighting factors. +* WY spatial Y axis closure relation weighting factors. +* WZ spatial Z axis closure relation weighting factors. +* CST constants for the polynomial approximations. +* ISADPT flag to enable/disable adaptive flux calculations. +* LOZSWP lozenge sweep order depending on direction. +* COORDMAP coordinate map - mapping the hexagons from the indices +* within the DRAGON geometry to a Cartesian axial coordinate +* array (see redblobgames.com website). +* +*Parameters: input/output +* FUNKNO Legendre components of the flux and boundary fluxes. +* +*Comments: +* 1. The direction of the axes I, J and D for the surface boundary +* fluxes are shown in the diagram below. This means that +* i) lozenge A has I- and D-boundaries (instead of I and J) +* i) lozenge B has I- and J-boundaries +* i) lozenge C has D- and J-boundaries (instead of I and J) +* +* ^ +* j-axis | +* | ^ +* _________ / d-axis +* / / \ / +* / B / \ +* / / \ +* (-------( A ) +* \ \ / +* \ C \ / +* \_______\_/ \ +* \ i-axis +* ^ +* +*----------------------------------------------------------------------- +* +#if defined(_OPENMP) + USE omp_lib +#endif +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NUN,NGEFF,IMPX,NGIND(NGEFF),NHEX,LZ,ISPLH,IELEM,NM,NMX, + 1 NMY,NMZ,NMAT,NPQ,NSCT,MAT(ISPLH,ISPLH,3,NHEX,LZ),NCODE(6), + 2 MRMZ(NPQ),LOZSWP(3,6),COORDMAP(3,NHEX) + LOGICAL INCONV(NGEFF) + REAL SIDE,VOL(ISPLH,ISPLH,3,NHEX,LZ),TOTAL(0:NMAT,NGEFF),ZCODE(6), + 1 QEXT(NUN,NGEFF),DU(NPQ),DE(NPQ),DZ(NPQ),W(NPQ), + 2 DC(ISPLH*ISPLH*3*NHEX,1,NPQ),DB(ISPLH*ISPLH*3*NHEX,LZ,NPQ), + 3 DA(1,LZ,NPQ),FUNKNO(NUN,NGEFF),WX(IELEM+1),WY(IELEM+1), + 4 WZ(IELEM+1),CST(IELEM),MN(NPQ,NSCT),DN(NSCT,NPQ) + LOGICAL LFIXUP,ISADPT(3) +*---- +* LOCAL VARIABLES +*---- + INTEGER :: NPQD(12),IIND(12),P,DCOORD + REAL :: JAC(2,2,3),MUH,ETAH,XIH,AAA,BBB,CCC,DDD,MUHTEMP,ETAHTEMP, + 1 WX0(IELEM+1),WY0(IELEM+1),WZ0(IELEM+1) + DOUBLE PRECISION :: V,Q(NM),Q2(NM,NM+1),THETA,XNI(NMX), + > XNJ(NMY),XNK(NMZ) + PARAMETER(IUNOUT=6,RLOG=1.0E-8,PI=3.141592654) + LOGICAL ISFIX(3),LHEX(NHEX) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: INDANG + INTEGER, ALLOCATABLE, DIMENSION(:,:,:,:,:,:) :: TMPMAT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: FLUX + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:,:,:) :: FLUX_G + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: TMPXNI, + > TMPXNJ, TMPXND + DOUBLE PRECISION,ALLOCATABLE, DIMENSION(:,:,:,:,:) :: TMPXNK +*---- +* MAP MATERIAL VALUES TO CARTESIAN AXIAL COORDINATE MAP +*---- + NRINGS=INT((SQRT( REAL((4*NHEX-1)/3) )+1.)/2.) + NCOL=2*NRINGS -1 + ALLOCATE(TMPMAT(ISPLH,ISPLH,3,NCOL,NCOL,LZ)) + TMPMAT(:,:,:,:,:,:) = -1 + DO K=1,LZ + DO IHEX_XY=1,NHEX + TMPMAT(:,:,:,COORDMAP(1,IHEX_XY),COORDMAP(2,IHEX_XY),K) = + > MAT(:,:,:,IHEX_XY,K) + ENDDO + ENDDO +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(INDANG(NPQ,12)) + ALLOCATE(FLUX(NM,NSCT,3*ISPLH**2,NHEX,LZ)) + ALLOCATE(FLUX_G(NM,NSCT,3*ISPLH**2,NHEX,LZ,NGEFF)) + ALLOCATE(TMPXNI(NMX,ISPLH,NCOL)) + ALLOCATE(TMPXNJ(NMY,ISPLH,NCOL)) + ALLOCATE(TMPXND(NMX,ISPLH,NCOL)) + ALLOCATE(TMPXNK(NMZ,ISPLH,ISPLH,3,NHEX)) +*---- +* CONSTRUCT JACOBIAN MATRIX FOR EACH LOZENGE +*---- + JAC = RESHAPE((/ 1., -SQRT(3.), 1., SQRT(3.), 2., 0., 1., + > SQRT(3.), 2., 0., -1., SQRT(3.) /), SHAPE(JAC)) + JAC = (SIDE/2.)*JAC +*---- +* LENGTH OF FUNKNO COMPONENTS (IN ORDER) +*---- + LFLX=3*NM*(ISPLH**2)*NHEX*LZ*NSCT + L5=3*NMZ*(ISPLH**2)*NHEX +*---- +* SET DODECANT SWAPPING ORDER. +*---- + NPQD(:12)=0 + INDANG(:NPQ,:12)=0 + IIND(:12)=0 + DO M=1,NPQ + VU=DU(M) + VE=DE(M) + VZ=DZ(M) + IF(W(M).EQ.0) CYCLE + THETA=0.0D0 + IF(VE.GT.0.0)THEN + IF(VU.EQ.0.0)THEN + THETA = PI/2 + ELSEIF(VU.GT.0.0)THEN + THETA = ATAN(ABS(VE/VU)) + ELSEIF(VU.LT.0.0)THEN + THETA = PI - ATAN(ABS(VE/VU)) + ENDIF + ELSEIF(VE.LT.0.0)THEN + IF(VU.EQ.0.0)THEN + THETA = 3*PI/2 + ELSEIF(VU.LT.0.0)THEN + THETA = PI + ATAN(ABS(VE/VU)) + ELSEIF(VU.GT.0.0)THEN + THETA = 2.*PI - ATAN(ABS(VE/VU)) + ENDIF + ENDIF + ! UNFOLD DODECANTS + IND=0 + IF(VZ.GE.0.0)THEN + IF((THETA.GT.0.0).AND.(THETA.LT.(PI/3.)))THEN + IND=1 + ELSEIF((THETA.GT.(PI/3.)).AND.(THETA.LT.(2.*PI/3.)))THEN + IND=2 + ELSEIF((THETA.GT.(2.*PI/3.)).AND.(THETA.LT.(PI)))THEN + IND=3 + ELSEIF((THETA.GT.(PI)).AND.(THETA.LT.(4.*PI/3.)))THEN + IND=4 + ELSEIF((THETA.GT.(4.*PI/3.)).AND.(THETA.LT.(5.*PI/3.)))THEN + IND=5 + ELSEIF((THETA.GT.(5.*PI/3.)).AND.(THETA.LT.(2.*PI)))THEN + IND=6 + ENDIF + ELSEIF(VZ.LT.0.0)THEN + IF((THETA.GT.0.0).AND.(THETA.LT.(PI/3.)))THEN + IND=7 + ELSEIF((THETA.GT.(PI/3.)).AND.(THETA.LT.(2.*PI/3.)))THEN + IND=8 + ELSEIF((THETA.GT.(2.*PI/3.)).AND.(THETA.LT.(PI)))THEN + IND=9 + ELSEIF((THETA.GT.(PI)).AND.(THETA.LT.(4.*PI/3.)))THEN + IND=10 + ELSEIF((THETA.GT.(4.*PI/3.)).AND.(THETA.LT.(5.*PI/3.)))THEN + IND=11 + ELSEIF((THETA.GT.(5.*PI/3.)).AND.(THETA.LT.(2.*PI)))THEN + IND=12 + ENDIF + ENDIF + ! Assume IIND(I)=I in hexagonal geometry + IIND(IND)=IND + NPQD(IND)=NPQD(IND)+1 + INDANG(NPQD(IND),IND)=M + ENDDO +*---- +* MAIN LOOP OVER DODECANTS. +*---- + + FLUX_G(:NM,:NSCT,:3*ISPLH**2,:NHEX,:LZ,:NGEFF)=0.0D0 + WX0=WX + WY0=WY + WZ0=WZ + + DO JND=1,12 + IND=IIND(JND) + IND_XY=MOD(IND-1,6)+1 + ! Needed because of S2 LS (8 dir. for 12 dodecants) + IF(IND.EQ.0) CYCLE +*---- +* PRELIMINARY LOOPS FOR SETTING BOUNDARY CONDITIONS. +*---- + + IF((NCODE(5).NE.1).or.(NCODE(6).NE.1))THEN +*$OMP PARALLEL DO +*$OMP+ PRIVATE(M,IG,VZ,M1,IOF,JOF,IPQD) +*$OMP+ SHARED(FUNKNO) COLLAPSE(2) + + DO IG=1,NGEFF + DO IPQD=1,NPQD(IND) + IF(.NOT.INCONV(IG)) CYCLE + M=INDANG(IPQD,IND) + + VZ=DZ(M) + ! Z-BOUNDARY + IF(VZ.GT.0.0)THEN + M1=MRMZ(M) + IF(NCODE(5).NE.4)THEN + IOF=(M-1)*(L5) + JOF=(M1-1)*(L5) + FUNKNO(LFLX+IOF+1:LFLX+IOF+L5,IG)= + > FUNKNO(LFLX+JOF+1:LFLX+JOF+L5,IG) + ENDIF + ELSEIF(VZ.LT.0.0)THEN + M1=MRMZ(M) + IF(NCODE(6).NE.4)THEN + IOF=(M-1)*(L5) + JOF=(M1-1)*(L5) + FUNKNO(LFLX+IOF+1:LFLX+IOF+L5,IG)= + > FUNKNO(LFLX+JOF+1:LFLX+JOF+L5,IG) + ENDIF + ENDIF +* + ENDDO + ENDDO + +*$OMP END PARALLEL DO + ENDIF + + ! CALL XABORT('SNFBH3: testing 1 ') +*---- +* MAIN SWAPPING LOOPS FOR SN FLUX CALCULATION +* LOOP OVER ENERGY AND ANGLES +*---- + +*$OMP PARALLEL DO +*$OMP+ PRIVATE(ITID,FLUX,M,IG,XNI,XNJ,XNK,Q,Q2,IOF,IER,II,JJ,I,J,K,K0) +*$OMP+ PRIVATE(IPQD,IBM,SIGMA,V,ISFIX,IX,JX,IY,JY,IZ,JZ,AAA,BBB,CCC,DDD) +*$OMP+ PRIVATE(IIX,IIY,IIZ,P,IEL) +*$OMP+ PRIVATE(LHEX,IHEX_XY,IIHEX,DCOORD,ILOZLOOP,ILOZ,IL,I2,JL,J2) +*$OMP+ PRIVATE(MUHTEMP,MUH,ETAHTEMP,ETAH,XIH,I3,I_FETCH,III,JJJ,IIM,JIM) +*$OMP+ PRIVATE(TMPXNI,TMPXNJ,TMPXND,TMPXNK) +*$OMP+ FIRSTPRIVATE(WX,WY,WZ,WX0,WY0,WZ0) SHARED(FUNKNO,IND) +*$OMP+ REDUCTION(+:FLUX_G) COLLAPSE(2) + ! LOOP FOR GROUPS TO EXECUTE IN PARALLEL + DO IG=1,NGEFF + + ! LOOP OVER ALL DIRECTIONS + DO IPQD=1,NPQD(IND) + IF(.NOT.INCONV(IG)) CYCLE + M=INDANG(IPQD,IND) + IF(W(M).EQ.0.0) CYCLE + + ! GET AND PRINT THREAD NUMBER +#if defined(_OPENMP) + ITID=omp_get_thread_num() +#else + ITID=0 +#endif + IF(IMPX.GT.5) WRITE(IUNOUT,500) ITID,NGIND(IG),IPQD + + ! INITIALIZE FLUX AND Z-BOUNDARY FLUXES + FLUX(:NM,:NSCT,:3*ISPLH**2,:NHEX,:LZ)=0.0D0 + TMPXNK(:NMZ,:ISPLH,:ISPLH,:3,:NHEX)=0.0D0 + + ! PICK UP BOUNDARY ELEMENTS + IF((NCODE(5).NE.1).or.(NCODE(6).NE.1))THEN + IOF=(M-1)*(L5) + 1 + TMPXNK(:NMZ,:ISPLH,:ISPLH,:3,:NHEX)= + > RESHAPE(FUNKNO(LFLX+IOF:LFLX+IOF+L5,IG), + > (/NMZ,ISPLH,ISPLH,3,NHEX/)) + ENDIF + ! ACCOUNT FOR ALBEDO IN BOUNDARY ELEMENTS + IF(IND.LT.7) THEN + TMPXNK(:NMZ,:ISPLH,:ISPLH,:3,:NHEX)= + > TMPXNK(:NMZ,:ISPLH,:ISPLH,:3,:NHEX)*ZCODE(5) + ELSE + TMPXNK(:NMZ,:ISPLH,:ISPLH,:3,:NHEX)= + > TMPXNK(:NMZ,:ISPLH,:ISPLH,:3,:NHEX)*ZCODE(6) + ENDIF + +*---- +* LOOP OVER Z-AXIS PLANES +*---- + + DO K0=1,LZ + K=K0 + IF(IND.GE.7) K=LZ+1-K0 + + ! INITIALIZE I,J,D-BOUNDARY FLUXES + TMPXNI(:NMX,:ISPLH,:NCOL)=0.0D0 + TMPXNJ(:NMY,:ISPLH,:NCOL)=0.0D0 + TMPXND(:NMX,:ISPLH,:NCOL)=0.0D0 + +*---- +* LOOP OVER CARTESIAN MAP OF HEXAGONAL DOMAIN +*---- + + DO JJJ=1,NCOL + JIM=JJJ + ! Account for different sweep direction depending on angle + IF((IND_XY.EQ.1).OR.(IND_XY.EQ.2).OR.(IND_XY.EQ.3)) JIM=NCOL+1-JIM + + DO III=1,NCOL + IIM=III + ! Account for different sweep direction depending on angle + IF((IND_XY.EQ.2).OR.(IND_XY.EQ.3).OR.(IND_XY.EQ.4)) IIM=NCOL+1-IIM + + ! For IND_XY 3 or 6, Cartesian axial coordinate map is swept + ! vertically instead of horizontally. IM suffix is for 'IMmutable' + I=IIM + J=JIM + IF((IND_XY.EQ.3).OR.(IND_XY.EQ.6))THEN + I=JIM + J=IIM + ENDIF + + ! If within corners of Cartesian axial coordinate map (where + ! there are no hexagons), skip loop + IF(TMPMAT(1,1,1,I,J,K).EQ.-1) CYCLE + + ! Find in X-Y plane DRAGON geometry hexagonal index using I and J + LHEX=(COORDMAP(1,:).EQ.I .AND. COORDMAP(2,:).EQ.J) + IHEX_XY=0 + DO IIHEX=1,NHEX + IF(LHEX(IIHEX)) THEN + IHEX_XY=IIHEX + EXIT + ENDIF + ENDDO + IF(IHEX_XY.EQ.0) CALL XABORT('SNFBH3: IHEX_XY FAILURE.') + ! Find D coordinate + DCOORD = ABS(COORDMAP(3,IHEX_XY))-NRINGS + +*---- +* LOOP OVER LOZENGES +*---- + + DO ILOZLOOP=1,3 + ILOZ=LOZSWP(ILOZLOOP,IND_XY) + + ! Get Jacobian elements values + AAA = JAC(1,1,ILOZ) + BBB = JAC(1,2,ILOZ) + CCC = JAC(2,1,ILOZ) + DDD = JAC(2,2,ILOZ) + + ! CALL XABORT('SNFBH3: testing 19 ') +*---- +* LOOP OVER SUBMESH WITHIN EACH LOZENGE +*---- + DO IL=1,ISPLH + I2=IL + ! Account for different sweep direction depending on angle + IF((ILOZ.EQ.1).OR.(ILOZ.EQ.2))THEN + IF((IND_XY.EQ.2).OR.(IND_XY.EQ.3).OR.(IND_XY.EQ.4))I2=ISPLH+1-I2 + ELSEIF(ILOZ.EQ.3)THEN + IF((IND_XY.EQ.3).OR.(IND_XY.EQ.4).OR.(IND_XY.EQ.5))I2=ISPLH+1-I2 + ENDIF + + DO JL=1,ISPLH + J2=JL + ! Account for different sweep direction depending on angle + IF((ILOZ.EQ.2).OR.(ILOZ.EQ.3))THEN + IF((IND_XY.EQ.4).OR.(IND_XY.EQ.5).OR.(IND_XY.EQ.6))J2=ISPLH+1-J2 + ELSEIF(ILOZ.EQ.1)THEN + IF((IND_XY.EQ.3).OR.(IND_XY.EQ.4).OR.(IND_XY.EQ.5))J2=ISPLH+1-J2 + ENDIF + ! READ IN XNI AND XNJ DEPENDING ON LOZENGE + I_FETCH=0 + IF((ILOZ.EQ.1))THEN + ! Read boundary fluxes in reverse for lozenge A since affine + ! transformation of lozenges causes the D and I directions + ! of lozenges C and A respectively to be reversed + I_FETCH=ISPLH+1-I2 + XNI(:) = TMPXNI(:,J2,J) + XNJ(:) = TMPXND(:,I_FETCH,DCOORD) + ELSEIF((ILOZ.EQ.2))THEN + XNI(:) = TMPXNI(:,J2,J) + XNJ(:) = TMPXNJ(:,I2,I) + ELSEIF((ILOZ.EQ.3))THEN + XNI(:) = TMPXND(:,J2,DCOORD) + XNJ(:) = TMPXNJ(:,I2,I) + ENDIF + XNK(:) = TMPXNK(:,I2,J2,ILOZ,IHEX_XY) + + ! DATA + IBM=MAT(I2,J2,ILOZ,IHEX_XY,K) + ! Skip loop if virtual element + IF(IBM.EQ.0) CYCLE + SIGMA=TOTAL(IBM,IG) + V=VOL(I2,J2,ILOZ,IHEX_XY,K) + + ! COMPUTE ADJUSTED DIRECTION COSINES + MUHTEMP = DA(1,K,M) + ETAHTEMP = DB(1,K,M) + MUH = (MUHTEMP*DDD) - (ETAHTEMP*BBB) + ETAH = (-MUHTEMP*CCC) + (ETAHTEMP*AAA) + XIH = DC(1,1,M) + + ! IF(IND.EQ.12) CALL XABORT('SNFBH3: testing 60 ') + ! WRITE(*,*) (((((((K-1)*NHEX+(IHEX_XY-1))*3+(ILOZ-1))*ISPLH+ + ! > (J2-1))*ISPLH+(I2-1))*NSCT+(2-1))*NM)+1 + ! WRITE(*,*) K, NHEX, IHEX_XY, ILOZ, ISPLH, J2, I2, NSCT, NM + ! CALL XABORT('SNFBH3: testing 2') + ! SOURCE DENSITY TERM + DO IEL=1,NM + Q(IEL)=0.0D0 + DO P=1,NSCT + IOF=(((((((K-1)*NHEX+(IHEX_XY-1))*3+(ILOZ-1))*ISPLH+(J2-1))* + > ISPLH+(I2-1))*NSCT+(P-1))*NM)+IEL + Q(IEL)=Q(IEL)+QEXT(IOF,IG)*MN(M,P) + ENDDO + ENDDO + + ! CALL XABORT('SNFBH3: testing 17 ') + ISFIX=.FALSE. + DO WHILE (.NOT.ALL(ISFIX)) ! LOOP FOR ADAPTIVE CALCULATION + + ! FLUX MOMENT COEFFICIENTS MATRIX + Q2(:NM,:NM+1)=0.0D0 + DO IZ=1,IELEM + DO JZ=1,IELEM + DO IY=1,IELEM + DO JY=1,IELEM + DO IX=1,IELEM + DO JX=1,IELEM + + II=IELEM**2*(IZ-1)+IELEM*(IY-1)+IX + JJ=IELEM**2*(JZ-1)+IELEM*(JY-1)+JX + + ! IF(IPQD.EQ.3) CALL XABORT('SNFBH3: testing 69 ') + ! CALL XABORT('SNFBH3: testing 17 ') + ! DIAGONAL TERMS + IF(II.EQ.JJ) THEN + Q2(II,JJ)=SIGMA*V + 1 +CST(IX)**2*WX(JX+1)*ABS(MUH) + 2 +CST(IY)**2*WY(JY+1)*ABS(ETAH) + 3 +CST(IZ)**2*WZ(JZ+1)*ABS(XIH) + + ! IF(IND.EQ.12) CALL XABORT('SNFBH3: testing 70 ') + ! CALL XABORT('SNFBH3: testing 191 ') + ! UPPER DIAGONAL TERMS + ELSEIF(II.LT.JJ) THEN + ! CALL XABORT('SNFBH3: testing 1919 ') + IF(IZ.EQ.JZ) THEN + IF(IY.EQ.JY) THEN + ! X-SPACE TERMS + IF(MOD(IX+JX,2).EQ.1) THEN + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*MUH + ELSE + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*ABS(MUH) + ENDIF + ELSEIF(IX.EQ.JX) THEN + ! Y-SPACE TERMS + IF(MOD(IY+JY,2).EQ.1) THEN + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ETAH + ELSE + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ABS(ETAH) + ENDIF + ENDIF + ELSEIF(IY.EQ.JY.AND.IX.EQ.JX) THEN + ! Z-SPACE TERMS + IF(MOD(IZ+JZ,2).EQ.1) THEN + Q2(II,JJ)=CST(IZ)*CST(JZ)*WZ(JZ+1)*XIH + ELSE + Q2(II,JJ)=CST(IZ)*CST(JZ)*WZ(JZ+1)*ABS(XIH) + ENDIF + ENDIF + ! IF(IND.EQ.12) CALL XABORT('SNFBH3: testing 75 ') + ! CALL XABORT('SNFBH3: testing 19 ') + + ! UNDER DIAGONAL TERMS + ELSE + ! CALL XABORT('SNFBH3: testing 1920 ') + IF(IZ.EQ.JZ) THEN + IF(IY.EQ.JY) THEN + ! X-SPACE TERMS + IF(MOD(IX+JX,2).EQ.1) THEN + Q2(II,JJ)=CST(IX)*CST(JX)*(WX(JX+1)-2)*MUH + ELSE + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*ABS(MUH) + ENDIF + ELSEIF(IX.EQ.JX) THEN + ! Y-SPACE TERMS + IF(MOD(IY+JY,2).EQ.1) THEN + Q2(II,JJ)=CST(IY)*CST(JY)*(WY(JY+1)-2)*ETAH + ELSE + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ABS(ETAH) + ENDIF + ENDIF + ELSEIF(IY.EQ.JY.AND.IX.EQ.JX) THEN + ! Z-SPACE TERMS + IF(MOD(IZ+JZ,2).EQ.1) THEN + Q2(II,JJ)=CST(IZ)*CST(JZ)*(WZ(JZ+1)-2)*XIH + ELSE + Q2(II,JJ)=CST(IZ)*CST(JZ)*WZ(JZ+1)*ABS(XIH) + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + + ! FLUX SOURCE VECTOR + DO IZ=1,IELEM + DO IY=1,IELEM + DO IX=1,IELEM + II=IELEM**2*(IZ-1)+IELEM*(IY-1)+IX + IIX=IELEM*(IZ-1)+IY + IIY=IELEM*(IZ-1)+IX + IIZ=IELEM*(IY-1)+IX + Q2(II,NM+1)=Q(II)*V + ! X-SPACE TERMS + IF(MOD(IX,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IX)*(1-WX(1)) + 1 *XNI(IIX)*ABS(MUH) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IX)*(1+WX(1)) + 1 *XNI(IIX)*MUH + ENDIF + ! Y-SPACE TERMS + IF(MOD(IY,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IY)*(1-WY(1)) + 1 *XNJ(IIY)*ABS(ETAH) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IY)*(1+WY(1)) + 1 *XNJ(IIY)*ETAH + ENDIF + ! Z-SPACE TERMS + IF(MOD(IZ,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IZ)*(1-WZ(1)) + 1 *XNK(IIZ)*ABS(XIH) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IZ)*(1+WZ(1)) + 1 *XNK(IIZ)*XIH + ENDIF + ENDDO + ENDDO + ENDDO + + CALL ALSBD(NM,1,Q2,IER,NM) + IF(IER.NE.0) CALL XABORT('SNFBH3: SINGULAR MATRIX.') + + ! ADAPTIVE CORRECTION OF WEIGHTING PARAMETERS + IF(ANY(ISADPT)) THEN + IF(ISADPT(1)) THEN + CALL SNADPT(IELEM,NM,IELEM**2,Q2(1:IELEM:1,NM+1), + 1 XNI(:NMX),1.0,WX,ISFIX(1)) + ELSE + ISFIX(1)=.TRUE. + ENDIF + IF(ISADPT(2)) THEN + CALL SNADPT(IELEM,NM,IELEM**2,Q2(1:IELEM**2:IELEM,NM+1), + 1 XNJ(:NMY),1.0,WY,ISFIX(2)) + ELSE + ISFIX(2)=.TRUE. + ENDIF + IF(ISADPT(3)) THEN + CALL SNADPT(IELEM,NM,IELEM**2,Q2(1:NM:IELEM**2,NM+1), + 1 XNK(:NMZ),1.0,WZ,ISFIX(3)) + ELSE + ISFIX(3)=.TRUE. + ENDIF + ELSE + ISFIX=.TRUE. + ENDIF + + END DO ! END OF ADAPTIVE LOOP + + ! CLOSURE RELATIONS + IF(IELEM.EQ.1.AND.LFIXUP.AND.(Q2(1,2).LE.RLOG)) Q2(1,2)=0.0 + ! Read XNI/XNI/XNK into TMPXNI/J/D/K + IF((ILOZ.EQ.1).OR.(ILOZ.EQ.2))THEN + TMPXNI(:NMX,J2,J)=WX(1)*XNI(:NMX) + ELSE + TMPXND(:NMX,J2,DCOORD)=WX(1)*XNI(:NMX) + ENDIF + IF((ILOZ.EQ.2).OR.(ILOZ.EQ.3))THEN + TMPXNJ(:NMY,I2,I)=WY(1)*XNJ(:NMY) + ELSE + I3=I_FETCH + TMPXND(:NMY,I3,DCOORD)=WY(1)*XNJ(:NMY) + ENDIF + TMPXNK(:NMZ,I2,J2,ILOZ,IHEX_XY)=WZ(1)*XNK(:NMZ) + DO IZ=1,IELEM + DO IY=1,IELEM + DO IX=1,IELEM + II=IELEM**2*(IZ-1)+IELEM*(IY-1)+IX + IIX=IELEM*(IZ-1)+IY + IIY=IELEM*(IZ-1)+IX + IIZ=IELEM*(IY-1)+IX + ! X-SPACE + ! Assign I-boundary fluxes if lozenges A or B + IF((ILOZ.EQ.1).OR.(ILOZ.EQ.2))THEN + IF(MOD(IX,2).EQ.1) THEN + TMPXNI(IIX,J2,J)=TMPXNI(IIX,J2,J)+CST(IX)*WX(IX+1) + 1 *Q2(II,NM+1) + ELSE + TMPXNI(IIX,J2,J)=TMPXNI(IIX,J2,J)+CST(IX)*WX(IX+1) + 1 *Q2(II,NM+1)*SIGN(1.0,MUH) + ENDIF + ENDIF + ! Y-SPACE + ! Assign J-boundary fluxes if lozenges B or C + IF((ILOZ.EQ.2).OR.(ILOZ.EQ.3))THEN + IF(MOD(IY,2).EQ.1) THEN + TMPXNJ(IIY,I2,I)=TMPXNJ(IIY,I2,I)+CST(IY)*WY(IY+1) + 1 *Q2(II,NM+1) + ELSE + TMPXNJ(IIY,I2,I)=TMPXNJ(IIY,I2,I)+CST(IY)*WY(IY+1) + 1 *Q2(II,NM+1)*SIGN(1.0,ETAH) + ENDIF + ENDIF + ! D-SPACE + ! Assign D-boundary fluxes if lozenge A using XNJ + IF((ILOZ.EQ.1))THEN + I3=I_FETCH + IF(MOD(IY,2).EQ.1) THEN + TMPXND(IIY,I3,DCOORD)=TMPXND(IIY,I3,DCOORD)+CST(IY)*WY(IY+1) + 1 *Q2(II,NM+1) + ELSE + TMPXND(IIY,I3,DCOORD)=TMPXND(IIY,I3,DCOORD)+CST(IY)*WY(IY+1) + 1 *Q2(II,NM+1)*SIGN(1.0,ETAH) + ENDIF + ENDIF + ! Assign D-boundary fluxes if lozenge C using XNI + IF((ILOZ.EQ.3))THEN + IF(MOD(IX,2).EQ.1) THEN + TMPXND(IIX,J2,DCOORD)=TMPXND(IIX,J2,DCOORD)+CST(IX)*WX(IX+1) + 1 *Q2(II,NM+1) + ELSE + TMPXND(IIX,J2,DCOORD)=TMPXND(IIX,J2,DCOORD)+CST(IX)*WX(IX+1) + 1 *Q2(II,NM+1)*SIGN(1.0,MUH) + ENDIF + ENDIF + ! Z-SPACE + IF(MOD(IZ,2).EQ.1) THEN + TMPXNK(IIZ,I2,J2,ILOZ,IHEX_XY)=TMPXNK(IIZ,I2,J2,ILOZ,IHEX_XY) + 1 +CST(IZ)*WZ(IZ+1)*Q2(II,NM+1) + ELSE + TMPXNK(IIZ,I2,J2,ILOZ,IHEX_XY)=TMPXNK(IIZ,I2,J2,ILOZ,IHEX_XY) + 1 +CST(IZ)*WZ(IZ+1)*Q2(II,NM+1)*SIGN(1.0,XIH) + ENDIF + ENDDO + ENDDO + ENDDO + ! FLIP GRADIENTS IF NECESSARY + DO IZ=1,IELEM + DO IY=1,IELEM + IIX=IELEM*(IZ-1)+IY + IF((MOD(IY,2).EQ.0).AND.(ILOZ.EQ.3).AND.(IL.EQ.ISPLH)) + 1 TMPXND(IIX,J2,DCOORD)=TMPXND(IIX,J2,DCOORD)*(-1) + ENDDO + ENDDO + I3=I_FETCH + DO IZ=1,IELEM + DO IX=1,IELEM + IIY=IELEM*(IZ-1)+IX + IF((MOD(IX,2).EQ.0).AND.(ILOZ.EQ.1).AND.(JL.EQ.ISPLH)) + 1 TMPXND(IIY,I3,DCOORD)=TMPXND(IIY,I3,DCOORD)*(-1) + ENDDO + ENDDO + ! LFIXUP + IF(IELEM.EQ.1.AND.LFIXUP)THEN + IF((ILOZ.EQ.1).OR.(ILOZ.EQ.2))THEN + IF(TMPXNI(1,J2,J).LE.RLOG) TMPXNI(1,J2,J)=0.0 + ELSE + IF(TMPXND(1,J2,DCOORD).LE.RLOG) TMPXND(1,J2,DCOORD)=0.0 + ENDIF + IF((ILOZ.EQ.2).OR.(ILOZ.EQ.3))THEN + IF(TMPXNJ(1,I2,I).LE.RLOG) TMPXNJ(1,I2,I)=0.0 + ELSE + I3=I_FETCH + IF(TMPXND(1,I3,DCOORD).LE.RLOG) TMPXND(1,I3,DCOORD)=0.0 + ENDIF + IF(TMPXNK(1,I2,J2,ILOZ,IHEX_XY).LE.RLOG) + 1 TMPXNK(1,I2,J2,ILOZ,IHEX_XY)=0.0 + ENDIF + WX=WX0 + WY=WY0 + WZ=WZ0 + + ! SAVE LEGENDRE MOMENT OF THE FLUX + IOF=((ILOZ-1)*ISPLH+(J2-1))*ISPLH+I2 + DO P=1,NSCT + DO IEL=1,NM + FLUX(IEL,P,IOF,IHEX_XY,K) = FLUX(IEL,P,IOF,IHEX_XY,K) + 1 +Q2(IEL,NM+1)*DN(P,M) + ENDDO + ENDDO + + ENDDO ! END OF WITHIN LOZENGE J-LOOP + ENDDO ! END OF WITHIN LOZENGE I-LOOP + + ENDDO ! END OF LOZENGE LOOP + + ENDDO ! END OF I COLUMNS OF CARTESIAN MAP LOOP + ENDDO ! END OF J COLUMNS OF CARTESIAN MAP LOOP + ENDDO ! END OF Z-LOOP + + ! SAVE FLUX INFORMATION + FLUX_G(:,:,:,:,:,IG)=FLUX_G(:,:,:,:,:,IG)+FLUX(:,:,:,:,:) + + ! SAVE K-BOUNDARY CONDITIONS IF NOT VOID B.C. + IF((NCODE(5).NE.1).or.(NCODE(6).NE.1))THEN + IOF=(M-1)*(L5) + FUNKNO(LFLX+IOF+1:LFLX+IOF+L5,IG)= + > RESHAPE(REAL(TMPXNK(:NMZ,:ISPLH,:ISPLH,:3,:NHEX)), + > (/L5/)) + ENDIF + + ENDDO ! END OF DIRECTION LOOP + ENDDO ! END OF ENERGY LOOP +*$OMP END PARALLEL DO + ENDDO ! END OF OCTANT LOOP + + ! SAVE FLUX INFORMATION + DO IG=1,NGEFF + IF(.NOT.INCONV(IG)) CYCLE + FUNKNO(:LFLX,IG)= + 1 RESHAPE(REAL(FLUX_G(:NM,:NSCT,:3*ISPLH**2,:NHEX,:LZ,IG)), + 2 (/LFLX/)) + ENDDO +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(FLUX_G,FLUX,INDANG,TMPXNI,TMPXNJ,TMPXND,TMPXNK,TMPMAT) + RETURN + 500 FORMAT(16H SNFBH3: thread=,I8,12H --->(group=,I4,7H angle=,I4,1H)) + END diff --git a/Dragon/src/SNFC12.f b/Dragon/src/SNFC12.f new file mode 100644 index 0000000..f0a8df2 --- /dev/null +++ b/Dragon/src/SNFC12.f @@ -0,0 +1,178 @@ +*DECK SNFC12 + SUBROUTINE SNFC12(LX,LY,NMAT,NPQ,NSCT,MAT,VOL,TOTAL,NCODE,ZCODE, + 1 QEXT,LFIXUP,DU,DE,W,MRM,MRMY,DB,DA,DAL,FLUX,XNEI,XNEJ,MN,DN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform one inner iteration for solving SN equations in 2D R-Z +* geometry for the diamond differencing method. Albedo boundary +* conditions. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* LX number of meshes along X axis. +* LY number of meshes along Y axis. +* NMAT number of material mixtures. +* NPQ number of SN directions in four octants (including zero-weight +* directions). +* NSCT maximum number of spherical harmonics moments of the flux. +* MAT material mixture index in each region. +* VOL volumes of each region. +* TOTAL macroscopic total cross sections. +* NCODE boundary condition indices. +* ZCODE albedos. +* QEXT Legendre components of the fixed source. +* LFIXUP flag to enable negative flux fixup. +* DU first direction cosines ($\\mu$). +* DE second direction cosines ($\\eta$). +* W weights. +* MRM quadrature index. +* MRMY quadrature index. +* DB diamond-scheme parameter. +* DA diamond-scheme parameter. +* DAL diamond-scheme parameter. +* MN moment-to-discrete matrix. +* DN discrete-to-moment matrix. +* +*Parameters: input/output +* XNEI X-directed SN boundary fluxes. +* XNEJ Y-directed SN boundary fluxes. +* +*Parameters: output +* FLUX Legendre components of the flux. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER LX,LY,NMAT,NPQ,NSCT,MAT(LX,LY),NCODE(4),MRM(NPQ),MRMY(NPQ) + REAL VOL(LX,LY),TOTAL(0:NMAT),ZCODE(4),QEXT(NSCT,LX,LY),DU(NPQ), + 1 DE(NPQ),W(NPQ),DB(LX,NPQ),DA(LX,LY,NPQ),DAL(LX,LY,NPQ), + 2 FLUX(NSCT,LX,LY),XNEI(LY,NPQ),XNEJ(LX,NPQ),MN(NPQ,NSCT), + 3 DN(NSCT,NPQ) + LOGICAL LFIXUP +*---- +* LOCAL VARIABLES +*---- + INTEGER P + DOUBLE PRECISION QQ,C1,XNM,XNJ,Q2(1,2) + PARAMETER(RLOG=1.0E-8,PI=3.141592654) + REAL, ALLOCATABLE, DIMENSION(:,:) :: XARN + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: XNI +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(XARN(LX,LY),XNI(LY)) +*---- +* MAIN LOOP OVER SN ANGLES. +*---- + FLUX(:NSCT,:LX,:LY)=0.0 + XARN(:LX,:LY)=0.0 + C1=0.0 + XNM=0.0 + DO 170 M=1,NPQ + WEIGHT=W(M) + VU=DU(M) + VE=DE(M) + IF(NCODE(1).NE.4) THEN + M1=MRM(M) + IF(WEIGHT.EQ.0.0) THEN + DO 10 J=1,LY + XNEI(J,M)=XNEI(J,M1) + 10 CONTINUE + ELSE IF(VU.GT.0.0) THEN + DO 20 J=1,LY + E1=XNEI(J,M) + XNEI(J,M)=XNEI(J,M1) + XNEI(J,M1)=E1 + 20 CONTINUE + ENDIF + ENDIF + IF(NCODE(3).NE.4) THEN + M1=MRMY(M) + IF(VE.GT.0) THEN + DO 40 I=1,LX + E1=XNEJ(I,M) + XNEJ(I,M)=XNEJ(I,M1) + XNEJ(I,M1)=E1 + 40 CONTINUE + ENDIF + ENDIF + IF(VE.GT.0.0) GOTO 70 + IF(VU.GT.0.0) GOTO 60 + IND=3 + GOTO 90 + 60 IND=4 + GOTO 90 + 70 IF(VU.GT.0.0) GOTO 80 + IND=2 + GOTO 90 + 80 IND=1 +*---- +* LOOP OVER X- AND Y-DIRECTED AXES. +*---- + 90 DO 155 II=1,LX + I=II + IF((IND.EQ.2).OR.(IND.EQ.3)) I=LX+1-II + IF((IND.EQ.1).OR.(IND.EQ.2)) THEN + XNJ=XNEJ(I,M)*ZCODE(3) + ELSE + XNJ=XNEJ(I,M)*ZCODE(4) + ENDIF + DO 140 JJ=1,LY + J=JJ + IF((IND.EQ.3).OR.(IND.EQ.4)) J=LY+1-JJ + C1=DAL(I,J,M) + IF(II.EQ.1) THEN + IF((IND.EQ.1).OR.(IND.EQ.4)) THEN + XNI(J)=XNEI(J,M) + ELSE + XNI(J)=XNEI(J,M)*ZCODE(2) + ENDIF + ENDIF + IF(MAT(I,J).EQ.0) GO TO 140 + QQ=0.0D0 + DO 110 P=1,NSCT + QQ=QQ+QEXT(P,I,J)*MN(M,P) + 110 CONTINUE + VT=VOL(I,J)*TOTAL(MAT(I,J)) + XNM=XARN(I,J) + Q2(1,1)=C1+2.0D0*ABS(DA(I,J,M))+2.0D0*ABS(DB(I,M))+VT + Q2(1,2)=C1*XNM+2.0D0*ABS(DA(I,J,M))*XNI(J)+2.0D0*ABS(DB(I,M)) + 1 *XNJ+VOL(I,J)*QQ + IF(Q2(1,1).EQ.0.0D0) CALL XABORT('SNFC12: SINGULAR MATRIX.') + Q2(1,2)=Q2(1,2)/Q2(1,1) + IF(LFIXUP.AND.(Q2(1,2).LE.RLOG)) Q2(1,2)=0.0 + XNI(J)=2.0D0*Q2(1,2)-XNI(J) + XNJ=2.0D0*Q2(1,2)-XNJ + XARN(I,J)=REAL(2.0D0*Q2(1,2)-XNM) + IF(LFIXUP.AND.(XARN(I,J).LE.RLOG)) XARN(I,J)=0.0 + IF(W(M).LE.RLOG) XARN(I,J)=REAL(Q2(1,2)) + IF(LFIXUP.AND.(XNI(J).LE.RLOG)) XNI(J)=0.0 + IF(LFIXUP.AND.(XNJ.LE.RLOG)) XNJ=0.0 + DO 135 P=1,NSCT + FLUX(P,I,J)=FLUX(P,I,J)+REAL(Q2(1,2))*DN(P,M) + 135 CONTINUE + 140 CONTINUE + XNEJ(I,M)=REAL(XNJ) + 155 CONTINUE + DO 165 J=1,LY + XNEI(J,M)=REAL(XNI(J)) + 165 ENDDO + 170 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XNI,XARN) + RETURN + END diff --git a/Dragon/src/SNFE1D.f b/Dragon/src/SNFE1D.f new file mode 100644 index 0000000..6877ae1 --- /dev/null +++ b/Dragon/src/SNFE1D.f @@ -0,0 +1,431 @@ +*DECK SNFE1P + SUBROUTINE SNFE1D(LX,NMAT,IELEM,EELEM,NM,NLF,NSCT,U,MAT, + 1 VOL,TOTAL,ESTOPW,NCODE,ZCODE,DELTAE,QEXT,LFIXUP,LSHOOT, + 2 FUNKNO,ISBS,NBS,ISBSM,BS,WX,WE,CST,ISADPT,IBFP,NUN,MN,DN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform one inner iteration for solving SN equations in 1D slab +* geometry. Albedo boundary conditions. Boltzmann-Fokker-Planck (BFP) +* discretization. +* +*Copyright: +* Copyright (C) 2020 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert, A. A. Calloo and C. Bienvenue +* +*Parameters: input +* LX number of regions. +* NMAT number of material mixtures. +* IELEM measure of order of the spatial approximation polynomial: +* =1 constant - default for HODD; +* =2 linear - default for DG; +* >3 higher orders. +* EELEM measure of order of the energy approximation polynomial: +* =1 constant - default for HODD; +* =2 linear - default for DG; +* >3 higher orders. +* NM total number of moments of the flux in space and +* energy. +* NLF number of $\\mu$ levels. +* NSCT number of Legendre components in the flux: +* =1: isotropic sources; +* =2: linearly anisotropic sources. +* U base points in $\\mu$ of the SN quadrature. +* W weights of the SN quadrature. +* MN moment-to-discrete matrix. +* DN discrete-to-moment matrix. +* MAT material mixture index in each region. +* VOL volumes of each region. +* TOTAL macroscopic total cross sections. +* ESTOPW stopping power. +* NCODE boundary condition indices. +* ZCODE albedos. +* DELTAE energy group width in MeV. +* QEXT Legendre components of the fixed source. +* QEXT0 initial slowing-down angular fluxes. +* LFIXUP flag to enable negative flux fixup. +* LSHOOT flag to enable/disable shooting method. +* ISBS flag to indicate the presence or not of boundary fixed +* sources. +* NBS number of boundary fixed sources. +* ISBSM flag array to indicate the presence or not of boundary fixed +* source in each unit surface. +* BS boundary source array with their intensities. +* WX spatial closure relation weighting factors. +* WE energy closure relation weighting factors. +* CST constants for the polynomial approximations. +* ISADPTX flag to enable/disable spatial adaptive flux calculations. +* ISADPTE flag to enable/disable energy adaptive flux calculations. +* IBFP type of energy proparation relation: +* =1 Galerkin type; +* =2 heuristic Przybylski and Ligou type. +* NUN total number of unknowns in vector FUNKNO +* +*Parameters: input/output +* FUNKNO Legendre components of the flux and boundary fluxes. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER LX,NMAT,IELEM,EELEM,NLF,NSCT,MAT(LX), + 1 NCODE(2),ISBS,NBS,ISBSM(2*ISBS,NLF*ISBS),NM,IBFP,NUN + REAL U(NLF),VOL(LX),TOTAL(0:NMAT),ESTOPW(0:NMAT,2),ZCODE(2), + 1 DELTAE,QEXT(NUN),FUNKNO(NUN),BS(NBS*ISBS),WX(IELEM+1), + 2 WE(EELEM+1),CST(MAX(IELEM,EELEM)),MN(NLF,NSCT),DN(NSCT,NLF) + LOGICAL LFIXUP,LSHOOT,ISADPT(2) +*---- +* LOCAL VARIABLES +*---- + REAL BM,BP,TB,WX0(IELEM+1),WE0(EELEM+1) + DOUBLE PRECISION XNI(EELEM),FEP(IELEM),XNI1(EELEM),XNI2(EELEM), + 1 XNIA(EELEM),XNIB(EELEM),XNIA1(EELEM),XNIA2(EELEM),XNIB1(EELEM), + 2 XNIB2(EELEM) + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: Q + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: Q2 + PARAMETER(RLOG=1.0E-8) + LOGICAL ISSHOOT,ISFIX(2) +*---- +* ALLOCATABLE ARRAYS +*---- + ALLOCATE(Q(NM),Q2(NM,NM+1)) +*---- +* LENGTH OF FUNKNO COMPONENTS (IN ORDER) +*---- + LFLX=NM*LX*NSCT + LXNI=EELEM*NLF + IF(LSHOOT) LXNI=0 + LFEP=IELEM*NLF*LX +*---- +* INNER ITERATION. +*---- + FUNKNO(:LFLX)=0.0 + XNI=0.0D0 + WX0=WX + WE0=WE + + ! SHOOTING METHOD WHEN THERE IS A NON-VACUUM RIGHT + ! BOUNDARY CONDITION. + ISSHOOT=(ZCODE(2).NE.0.0).AND.LSHOOT + IF(ISSHOOT) THEN + NS=6 + ELSE + NS=2 + ENDIF + + ! LOOP OVER ALL DIRECTIONS + DO 200 M0=1,NLF/2 + + ! LOOP FOR SHOOTING METHOD + DO 500 IS=1,NS + + ! CHOOSE DIRECTION + IF(MOD(IS,2).EQ.0) THEN + M=NLF-M0+1 ! FORWARD + ELSE + M=M0 ! BACKWARD + ENDIF + + ! SHOOTING METHOD BOUNDARY CONDITIONS. + IF(ISSHOOT) THEN + ! 1ST BACKWARD SWEEP + IF(IS.EQ.1) THEN + XNI(:EELEM)=0.0D0 + XNI1(:EELEM)=0.0D0 + XNI2(:EELEM)=0.0D0 + ! 1ST FORWARD SWEEP + ELSEIF(IS.EQ.2) THEN + XNIA1=0.0D0 + IF(NCODE(1).EQ.4) THEN + XNIA1(:EELEM)=REAL(XNI(:EELEM)) + XNI(:EELEM)=0.0D0 + ELSE + XNI(:EELEM)=ZCODE(1)*REAL(XNI(:EELEM)) + ENDIF + ! 2ND BACKWARD SWEEP + ELSEIF(IS.EQ.3) THEN + XNIA2(:EELEM)=0.0D0 + XNIA(:EELEM)=0.0D0 + IF(NCODE(1).EQ.4) THEN + XNIA2(:EELEM)=REAL(XNI(:EELEM)) + ELSE + XNIA(:EELEM)=REAL(XNI(:EELEM)) + ENDIF + XNI(:EELEM)=1.0D0 + ! 2ND FORWARD SWEEP + ELSEIF(IS.EQ.4) THEN + IF(NCODE(1).EQ.4) THEN + XNIB1(:EELEM)=REAL(XNI(:EELEM)) + XNI1(:EELEM)=XNIA1(:EELEM)/(1.0D0+XNIA1(:EELEM)-XNIB1(:EELEM)) + XNI(:EELEM)=1.0D0 + ELSE + XNI(:EELEM)=ZCODE(1)*REAL(XNI(:EELEM)) + ENDIF + ! 3RD BACKWARD SWEEP + ELSEIF(IS.EQ.5) THEN + IF(NCODE(1).EQ.4) THEN + XNIB2(:EELEM)=REAL(XNI(:EELEM)) + XNI2(:EELEM)=XNIA2(:EELEM)/(1.0D0+XNIA2(:EELEM)-XNIB2(:EELEM)) + XNI(:EELEM)=XNI1(:EELEM) + ELSE + XNIB(:EELEM)=REAL(XNI(:EELEM)) + XNI(:EELEM)=ZCODE(2)*XNIA(:EELEM)/(1.0D0+ZCODE(2) + 1 *(XNIA(:EELEM)-XNIB(:EELEM))) + ENDIF + ! 3RD FORWARD SWEEP + ELSEIF(IS.EQ.6) THEN + XNI(:EELEM)=ZCODE(1)*XNI(:EELEM) + IF(NCODE(1).EQ.4) XNI(:EELEM)=XNI2 + ENDIF + ! NO SHOOTING METHOD BOUNDARY CONDITIONS + ELSE + IF(.NOT.LSHOOT) THEN + IF(U(M).GT.0.0) THEN + IF(NCODE(1).NE.4) THEN + DO IEL=1,EELEM + IOF=(M-1)*EELEM+IEL + FUNKNO(LFLX+LXNI+IOF)=FUNKNO(LFLX+LXNI-IOF+1) + ENDDO + ENDIF + ELSE + IF(NCODE(2).NE.4) THEN + DO IEL=1,EELEM + IOF=(M-1)*EELEM+IEL + FUNKNO(LFLX+LXNI+IOF)=FUNKNO(LFLX+LXNI-IOF+1) + ENDDO + ENDIF + ENDIF + XNI(:EELEM)=0.0D0 + ELSE + IF(IS.EQ.1) THEN + XNI(:EELEM)=0.0D0 + ELSE + XNI(:EELEM)=ZCODE(1)*XNI(:EELEM) + ENDIF + ENDIF + ENDIF + + ! X-BOUNDARIES CONDITIONS (NO SHOOTING) + IF(.NOT.LSHOOT) THEN + DO IEL=1,EELEM + IOF=(M-1)*EELEM+IEL + IF(U(M).GT.0.0) THEN + XNI(IEL)=FUNKNO(LFLX+IOF)*ZCODE(1) + ELSE + XNI(IEL)=FUNKNO(LFLX+IOF)*ZCODE(2) + ENDIF + ENDDO + ENDIF + + ! BOUNDARY FIXED SOURCES + IF(U(M).GT.0) THEN + IF(ISBS.EQ.1.AND.ISBSM(1,M).NE.0) THEN + XNI(1)=XNI(1)+BS(ISBSM(1,M)) + ENDIF + ELSE + IF(ISBS.EQ.1.AND.ISBSM(2,M).NE.0) THEN + XNI(1)=XNI(1)+BS(ISBSM(2,M)) + ENDIF + ENDIF + + ! SWEEPING OVER ALL VOXELS + DO 30 I0=1,LX + I=I0 + IF(U(M).LT.0) I=LX+1-I + + ! DATA + IBM=MAT(I) + SIGMA=TOTAL(IBM) + BM=ESTOPW(IBM,1)/DELTAE + BP=ESTOPW(IBM,2)/DELTAE + + ! TYPE OF ENERGY PROPAGATION FACTOR + IF(IBFP.EQ.1) THEN ! GALERKIN TYPE + TB=BM/BP + WE(1)=WE(1)*TB + WE(2:EELEM+1)=(WE(2:EELEM+1)-1)*TB+1 + ELSE ! PRZYBYLSKI AND LIGOU TYPE + TB=1.0 + ENDIF + + ! SOURCE DENSITY TERM + DO IEL=1,NM + Q(IEL)=0.0 + DO L=1,NSCT + IOF=(I-1)*NSCT*NM+(L-1)*NM+IEL + Q(IEL)=Q(IEL)+QEXT(IOF)*MN(M,L) + ENDDO + ENDDO + + ! ENERGY GROUP UPPER BOUNDARY INCIDENT FLUX + DO IEL=1,IELEM + IOF=(I-1)*NLF*IELEM+(M-1)*IELEM+IEL + FEP(IEL)=QEXT(LFLX+LXNI+IOF) + ENDDO + + ISFIX=.FALSE. + DO WHILE (.NOT.ALL(ISFIX)) ! LOOP FOR ADAPTIVE CALCULATION + + !FLUX MOMENT COEFFICIENTS MATRIX + Q2=0.0D0 + DO IX=1,IELEM + DO JX=1,IELEM + DO IE=1,EELEM + DO JE=1,EELEM + II=EELEM*(IX-1)+IE + JJ=EELEM*(JX-1)+JE + + ! DIAGONAL TERMS + IF(II.EQ.JJ) THEN + Q2(II,JJ)=(SIGMA+CST(IE)**2*WE(JE+1)*BP + 1 +(IE-1)*(BM-BP))*VOL(I) + 2 +CST(IX)**2*WX(JX+1)*ABS(U(M)) + + ! UPPER DIAGONAL TERMS + ELSEIF(II.LT.JJ) THEN + ! ENERGY TERMS + IF(IX.EQ.JX) THEN + IF(MOD(IE+JE,2).EQ.1) THEN + Q2(II,JJ)=-CST(IE)*CST(JE)*WE(JE+1)*BP*VOL(I) + ELSE + Q2(II,JJ)=CST(IE)*CST(JE)*WE(JE+1)*BP*VOL(I) + ENDIF + ! X-SPACE TERMS + ELSEIF(IE.EQ.JE) THEN + IF(MOD(IX+JX,2).EQ.1) THEN + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*U(M) + ELSE + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*ABS(U(M)) + ENDIF + ENDIF + + ! UNDER DIAGONAL TERMS + ELSE + ! ENERGY TERMS + IF(IX.EQ.JX) THEN + IF(MOD(IE+JE,2).EQ.1) THEN + Q2(II,JJ)=-CST(IE)*CST(JE)*(WE(JE+1)*BP-BM-BP)*VOL(I) + ELSE + Q2(II,JJ)=CST(IE)*CST(JE)*(WE(JE+1)*BP+BM-BP)*VOL(I) + ENDIF + ! X-SPACE TERMS + ELSEIF(IE.EQ.JE) THEN + IF(MOD(IX+JX,2).EQ.1) THEN + Q2(II,JJ)=CST(IX)*CST(JX)*(WX(JX+1)-2.0D0)*U(M) + ELSE + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*ABS(U(M)) + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + + ! FLUX SOURCE VECTOR + DO IX=1,IELEM + DO IE=1,EELEM + II=EELEM*(IX-1)+IE + Q2(II,NM+1)=Q(II)*VOL(I) + ! ENERGY TERMS + IF(MOD(IE,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IE)*(BM-WE(1)*BP)*FEP(IX)*VOL(I) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)+CST(IE)*(BM+WE(1)*BP)*FEP(IX)*VOL(I) + ENDIF + ! X-SPACE TERMS + IF(MOD(IX,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IX)*(1-WX(1))*XNI(IE)*ABS(U(M)) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IX)*(1+WX(1))*XNI(IE)*U(M) + ENDIF + ENDDO + ENDDO + + CALL ALSBD(NM,1,Q2,IER,NM) + IF(IER.NE.0) CALL XABORT('SNFE1D: SINGULAR MATRIX.') + + ! ADAPTIVE CORRECTION OF WEIGHTING PARAMETERS + IF(ANY(ISADPT)) THEN + IF(ISADPT(1)) THEN + CALL SNADPT(EELEM,NM,IELEM,Q2(1:NM:1,NM+1),FEP, + 1 TB,WE,ISFIX(1)) + ELSE + ISFIX(1)=.TRUE. + ENDIF + IF(ISADPT(2)) THEN + CALL SNADPT(IELEM,NM,EELEM,Q2(1:NM:EELEM,NM+1),XNI, + 1 1.0,WX,ISFIX(2)) + ELSE + ISFIX(2)=.TRUE. + ENDIF + ELSE + ISFIX=.TRUE. + ENDIF + + END DO ! END OF ADAPTIVE LOOP + + ! CLOSURE RELATIONS + IF(IELEM.EQ.1.AND.LFIXUP.AND.(Q2(1,2).LE.RLOG)) Q2(1,2)=0.0 + XNI(:EELEM)=WX(1)*XNI(:EELEM) + FEP(:IELEM)=WE(1)*FEP(:IELEM) + DO IX=1,IELEM + DO IE=1,EELEM + II=EELEM*(IX-1)+IE + ! ENERGY TERMS + IF(MOD(IE,2).EQ.1) THEN + FEP(IX)=FEP(IX)+CST(IE)*WE(IE+1)*Q2(II,NM+1) + ELSE + FEP(IX)=FEP(IX)-CST(IE)*WE(IE+1)*Q2(II,NM+1) + ENDIF + ! X-SPACE TERMS + IF(MOD(IX,2).EQ.1) THEN + XNI(IE)=XNI(IE)+CST(IX)*WX(IX+1)*Q2(II,NM+1) + ELSE + XNI(IE)=XNI(IE)+CST(IX)*WX(IX+1)*Q2(II,NM+1)*SIGN(1.0,U(M)) + ENDIF + ENDDO + ENDDO + IF(IELEM.EQ.1.AND.LFIXUP.AND.(XNI(1).LE.RLOG)) XNI(1)=0.0 + WX=WX0 + WE=WE0 + + IF(ISSHOOT.AND.IS.LT.5) GO TO 30 + + ! SAVE ENERGY GROUP LOWER BOUNDARY OUTGOING FLUX + DO IEL=1,IELEM + IOF=(I-1)*NLF*IELEM+(M-1)*IELEM+IEL + FUNKNO(LFLX+LXNI+IOF)=REAL(FEP(IEL))/DELTAE + ENDDO + + ! SAVE LEGENDRE MOMENT OF THE FLUX + DO L=1,NSCT + DO IEL=1,NM + IOF=(I-1)*NSCT*NM+(L-1)*NM+IEL + FUNKNO(IOF)=FUNKNO(IOF)+REAL(Q2(IEL,NM+1))*DN(L,M) + ENDDO + ENDDO + + 30 CONTINUE ! END OF X-LOOP + + ! SAVE BOUNDARIES FLUX + IF(.NOT.LSHOOT) THEN + DO IEL=1,EELEM + IOF=(M-1)*EELEM+IEL + FUNKNO(LFLX+IOF)=REAL(XNI(IEL)) + ENDDO + ENDIF + + 500 CONTINUE ! END OF SHOOTING METHOD LOOP + 200 CONTINUE ! END OF DIRECTION LOOP + + DEALLOCATE(Q,Q2) + RETURN + END diff --git a/Dragon/src/SNFE2D.F b/Dragon/src/SNFE2D.F new file mode 100644 index 0000000..76ed90e --- /dev/null +++ b/Dragon/src/SNFE2D.F @@ -0,0 +1,610 @@ +*DECK SNFE2D + SUBROUTINE SNFE2D(NUN,NGEFF,IMPX,INCONV,NGIND,LX,LY,IELEM, + 1 EELEM,NM,NME,NMX,NMY,NMAT,NPQ,NSCT,MAT,VOL,TOTAL,ESTOPW, + 2 NCODE,ZCODE,DELTAE,QEXT,LFIXUP,DU,DE,W,MRM,MRMY,DB,DA,FUNKNO, + 3 ISLG,FLUXC,ISBS,NBS,ISBSM,BS,MAXL,WX,WY,WE,CST,ISADPT,IBFP,MN,DN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform one inner iteration for solving SN equations in 2D Cartesian +* geometry for the HODD method. Energy-angle multithreading. Albedo +* boundary conditions. Boltzmann-Fokker-Planck (BFP) discretization. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert, A. A. Calloo and C. Bienvenue +* +*Parameters: input +* NUN total number of unknowns in vector FUNKNO. +* NGEFF number of energy groups processed in parallel. +* IMPX print flag (equal to zero for no print). +* INCONV energy group convergence flag (set to .FALSE. if converged). +* NGIND energy group indices assign to the NGEFF set. +* LX number of meshes along X axis. +* LY number of meshes along Y axis. +* IELEM measure of order of the spatial approximation polynomial: +* =1 constant - default for HODD; +* =2 linear - default for DG; +* >3 higher orders. +* EELEM measure of order of the energy approximation polynomial: +* =1 constant - default for HODD; +* =2 linear - default for DG; +* >3 higher orders. +* NM number of moments in space and energy for flux components +* NME number of moments for energy boundaries components +* NMX number of moments for X axis boundaries components +* NMY number of moments for Y axis boundaries components +* NMAT number of material mixtures. +* NPQ number of SN directions in four octants (including zero-weight +* directions). +* NSCT maximum number of spherical harmonics moments of the flux. +* MAT material mixture index in each region. +* VOL volumes of each region. +* TOTAL macroscopic total cross sections. +* ESTOPW stopping power. +* NCODE boundary condition indices. +* ZCODE albedos. +* DELTAE energy group width in MeV. +* QEXT Legendre components of the fixed source. +* LFIXUP flag to enable negative flux fixup. +* DU first direction cosines ($\\mu$). +* DE second direction cosines ($\\eta$). +* W weights. +* MRM quadrature index. +* MRMY quadrature index. +* DB diamond-scheme parameter. +* DA diamond-scheme parameter. +* MN moment-to-discrete matrix. +* DN discrete-to-moment matrix. +* ISBS flag to indicate the presence or not of boundary fixed +* sources. +* NBS number of boundary fixed sources. +* ISBSM flag array to indicate the presence or not of boundary fixed +* source in each unit surface. +* BS boundary source array with their intensities. +* MAXL maximum size of boundary source array. +* WX spatial X axis closure relation weighting factors. +* WY spatial Y axis closure relation weighting factors. +* WE energy closure relation weighting factors. +* CST constants for the polynomial approximations. +* ISADPTX flag to enable/disable adaptive X axis flux calculations. +* ISADPTY flag to enable/disable adaptive Y axis flux calculations. +* ISADPTE flag to enable/disable adaptive energy flux calculations. +* IBFP type of energy proparation relation: +* =1 Galerkin type; +* =2 heuristic Przybylski and Ligou type. +* +*Parameters: input/output +* FUNKNO Legendre components of the flux and boundary fluxes. +* FLUXC flux at the cutoff energy. +* +*----------------------------------------------------------------------- +#if defined(_OPENMP) + USE omp_lib +#endif +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NUN,NGEFF,IMPX,NGIND(NGEFF),LX,LY,IELEM,EELEM, + 1 NM,NME,NMX,NMY,NMAT,NPQ, + 2 NSCT,MAT(LX,LY),NCODE(4),MRM(NPQ),MRMY(NPQ),ISLG(NGEFF),ISBS, + 3 NBS,ISBSM(4*ISBS,NPQ*ISBS,NGEFF*ISBS),MAXL + LOGICAL INCONV(NGEFF) + REAL VOL(LX,LY),TOTAL(0:NMAT,NGEFF),ESTOPW(0:NMAT,2,NGEFF), + 1 ZCODE(4),DELTAE(NGEFF),QEXT(NUN,NGEFF),DU(NPQ),DE(NPQ),W(NPQ), + 2 DB(LX,NPQ),DA(LX,LY,NPQ),FUNKNO(NUN,NGEFF),FLUXC(LX,LY), + 3 BS(MAXL*ISBS,NBS*ISBS),WX(IELEM+1),WY(IELEM+1),WE(EELEM+1), + 4 CST(MAX(IELEM,EELEM)),MN(NPQ,NSCT),DN(NSCT,NPQ) + LOGICAL LFIXUP,ISADPT(3) +*---- +* LOCAL VARIABLES +*---- + INTEGER NPQD(4),IIND(4),P + REAL BM,BP,TB,WX0(IELEM+1),WY0(IELEM+1),WE0(EELEM+1) + DOUBLE PRECISION Q(NM),Q2(NM,NM+1),FEP(NME), + 1 XNJ(NMY),V + PARAMETER(IUNOUT=6,RLOG=1.0E-8,PI=3.141592654) + LOGICAL ISFIX(3) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: INDANG + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:) :: FLUX,FLUX0 + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: FLUX_G, + 1 FLUX0_G + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: XNI +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(INDANG(NPQ,4)) + ALLOCATE(XNI(NMX,LY),FLUX(NM,NSCT,LX,LY), + 1 FLUX0(NME,NPQ,LX,LY)) + ALLOCATE(FLUX_G(NM,NSCT,LX,LY,NGEFF), + 1 FLUX0_G(NME,NPQ,LX,LY,NGEFF)) +*---- +* LENGTH OF FUNKNO COMPONENTS (IN ORDER) +*---- + LFLX=NM*LX*LY*NSCT + LXNI=NMX*LY*NPQ + LXNJ=NMY*LX*NPQ + LFEP=NME*LX*LY*NPQ +*---- +* SET OCTANT SWAPPING ORDER. +*---- + NPQD(:4)=0 + INDANG(:NPQ,:4)=0 + DO M=1,NPQ + VU=DU(M) + VE=DE(M) + IF((VU.GE.0.0).AND.(VE.GE.0.0)) THEN + IND=1 + JND=4 + ELSE IF((VU.LE.0.0).AND.(VE.GE.0.0)) THEN + IND=2 + JND=3 + ELSE IF((VU.LE.0.0).AND.(VE.LE.0.0)) THEN + IND=3 + JND=1 + ELSE + IND=4 + JND=2 + ENDIF + IIND(JND)=IND + NPQD(IND)=NPQD(IND)+1 + INDANG(NPQD(IND),IND)=M + ENDDO +*---- +* MAIN LOOP OVER OCTANTS. +*---- + + FLUX_G(:NM,:NSCT,:LX,:LY,:NGEFF)=0.0D0 + FLUX0_G(:NME,:NPQ,:LX,:LY,:NGEFF)=0.0D0 + WE0=WE + WX0=WX + WY0=WY + + DO 190 JND=1,4 + IND=IIND(JND) +*---- +* PRELIMINARY LOOPS FOR SETTING BOUNDARY CONDITIONS. +*---- + +*$OMP PARALLEL DO +*$OMP+ PRIVATE(M,IG,VU,VE,M1,IOF,JOF,IEL,I,J,IPQD) +*$OMP+ SHARED(FUNKNO) COLLAPSE(2) + + DO 70 IG=1,NGEFF + DO 60 IPQD=1,NPQD(IND) + IF(.NOT.INCONV(IG)) GO TO 60 + M=INDANG(IPQD,IND) + VU=DU(M) + VE=DE(M) + ! X-BOUNDARY + IF(VU.GT.0.0)THEN + M1=MRM(M) + IF((NCODE(1).NE.4))THEN + DO IEL=1,NMX + DO J=1,LY + IOF=((M-1)*LY+(J-1))*NMX+IEL + JOF=((M1-1)*LY+(J-1))*NMX+IEL + FUNKNO(LFLX+IOF,IG)=FUNKNO(LFLX+JOF,IG) + ENDDO + ENDDO + ENDIF + ELSEIF(VU.LT.0.0)THEN + M1=MRM(M) + IF((NCODE(2).NE.4))THEN + DO IEL=1,NMX + DO J=1,LY + IOF=((M-1)*LY+(J-1))*NMX+IEL + JOF=((M1-1)*LY+(J-1))*NMX+IEL + FUNKNO(LFLX+IOF,IG)=FUNKNO(LFLX+JOF,IG) + ENDDO + ENDDO + ENDIF + ENDIF + ! Y-BOUNDARY + IF(VE.GT.0.0)THEN + M1=MRMY(M) + IF((NCODE(3).NE.4))THEN + DO IEL=1,NMY + DO I=1,LX + IOF=((M-1)*LX+(I-1))*NMY+IEL + JOF=((M1-1)*LX+(I-1))*NMY+IEL + FUNKNO(LFLX+LXNI+IOF,IG)= + > FUNKNO(LFLX+LXNI+JOF,IG) + ENDDO + ENDDO + ENDIF + ELSEIF(VE.LT.0.0)THEN + M1=MRMY(M) + IF((NCODE(4).NE.4))THEN + DO IEL=1,NMY + DO I=1,LX + IOF=((M-1)*LX+(I-1))*NMY+IEL + JOF=((M1-1)*LX+(I-1))*NMY+IEL + FUNKNO(LFLX+LXNI+IOF,IG)= + > FUNKNO(LFLX+LXNI+JOF,IG) + ENDDO + ENDDO + ENDIF + ENDIF + 60 CONTINUE + 70 CONTINUE + +*$OMP END PARALLEL DO + +*---- +* MAIN SWAPPING LOOPS FOR SN FLUX CALCULATION +*---- + +*$OMP PARALLEL DO +*$OMP+ PRIVATE(ITID,FLUX,M,IG,XNI,XNJ,Q,Q2,IOF,IER,II,JJ,IEL,I,J,L) +*$OMP+ PRIVATE(FEP,FLUX0,BM,BP,IIE,IIX,IIY,IE,IX,IY) +*$OMP+ PRIVATE(ISFIX,JX,JY,JE,TB,V,SIGMA,IBM,J0,I0,IPQD) +*$OMP+ FIRSTPRIVATE(WE,WX,WY,WE0,WX0,WY0) SHARED(FUNKNO) +*$OMP+ REDUCTION(+:FLUX_G,FLUX0_G,FLUXC) COLLAPSE(2) + + ! LOOP FOR GROUPS TO EXECUTE IN PARALLEL + DO 180 IG=1,NGEFF + + ! LOOP OVER ALL DIRECTIONS + DO 170 IPQD=1,NPQD(IND) + IF(.NOT.INCONV(IG)) GO TO 170 + M=INDANG(IPQD,IND) + IF(W(M).EQ.0.0) GO TO 170 + + ! GET AND PRINT THREAD NUMBER +#if defined(_OPENMP) + ITID=omp_get_thread_num() +#else + ITID=0 +#endif + IF(IMPX.GT.5) WRITE(IUNOUT,400) ITID,NGIND(IG),IPQD + + ! INITIALIZE FLUXES + FLUX(:NM,:NSCT,:LX,:LY)=0.0D0 + FLUX0(:NME,:NPQ,:LX,:LY)=0.0D0 + +*---- +* LOOP OVER X- AND Y-DIRECTED AXES. +*---- + + ! X-AXIS LOOP + DO 155 I0=1,LX + I=I0 + IF((IND.EQ.2).OR.(IND.EQ.3)) I=LX+1-I + + ! Y-BOUNDARIES CONDITIONS + XNJ=0.0 + DO IEL=1,NMY + IOF=(M-1)*NMY*LX+(I-1)*NMY+IEL + IF((IND.EQ.1).OR.(IND.EQ.2)) THEN + XNJ(IEL)=FUNKNO(LFLX+LXNI+IOF,IG)*ZCODE(3) + ELSE + XNJ(IEL)=FUNKNO(LFLX+LXNI+IOF,IG)*ZCODE(4) + ENDIF + ENDDO + + ! Y-BOUNDARIES FIXED SOURCES + IF(ISBS.EQ.1) THEN + IF((IND.EQ.3.OR.IND.EQ.4).AND.ISBSM(4,M,IG).NE.0) THEN + XNJ(1)=XNJ(1)+BS(I,ISBSM(4,M,IG)) + ELSE IF((IND.EQ.1.OR.IND.EQ.2).AND.ISBSM(3,M,IG).NE.0) THEN + XNJ(1)=XNJ(1)+BS(I,ISBSM(3,M,IG)) + ENDIF + ENDIF + + ! Y-AXIS LOOP + DO 140 J0=1,LY + J=J0 + IF((IND.EQ.3).OR.(IND.EQ.4)) J=LY+1-J + + ! X-BOUNDARIES CONDITIONS + IF(I0.EQ.1) THEN + XNI(:NMX,J)=0.0 + DO IEL=1,NMX + IOF=(M-1)*NMX*LY+(J-1)*NMX+IEL + IF((IND.EQ.1).OR.(IND.EQ.4)) THEN + XNI(IEL,J)=FUNKNO(LFLX+IOF,IG)*ZCODE(1) + ELSE + XNI(IEL,J)=FUNKNO(LFLX+IOF,IG)*ZCODE(2) + ENDIF + ENDDO + ENDIF + + ! X-BOUNDARIES FIXED SOURCES + IF(ISBS.EQ.1.AND.I0.EQ.1) THEN + IF((IND.EQ.2.OR.IND.EQ.3).AND.ISBSM(2,M,IG).NE.0) THEN + XNI(1,J)=XNI(1,J)+BS(J,ISBSM(2,M,IG)) + ELSE IF((IND.EQ.1.OR.IND.EQ.4).AND.ISBSM(1,M,IG).NE.0) THEN + XNI(1,J)=XNI(1,J)+BS(J,ISBSM(1,M,IG)) + ENDIF + ENDIF + + ! DATA + IBM=MAT(I,J) + IF(IBM.EQ.0) GO TO 140 + SIGMA=TOTAL(IBM,IG) + BM=ESTOPW(IBM,1,IG)/DELTAE(IG) + BP=ESTOPW(IBM,2,IG)/DELTAE(IG) + V=VOL(I,J) + + ! TYPE OF ENERGY PROPAGATION FACTOR + IF(IBFP.EQ.1) THEN ! GALERKIN TYPE + TB=BM/BP + WE(1)=WE(1)*TB + WE(2:EELEM+1)=(WE(2:EELEM+1)-1)*TB+1 + ELSE ! PRZYBYLSKI AND LIGOU TYPE + TB=1.0 + ENDIF + + ! SOURCE DENSITY TERM + DO IEL=1,NM + Q(IEL)=0.0D0 + DO P=1,NSCT + IOF=((J-1)*LX*NSCT+(I-1)*NSCT+(P-1))*NM+IEL + Q(IEL)=Q(IEL)+QEXT(IOF,IG)*MN(M,P) + ENDDO + ENDDO + + ! ENERGY GROUP UPPER BOUNDARY INCIDENT FLUX + DO IEL=1,NME + IOF=((J-1)*LX*NPQ+(I-1)*NPQ+(M-1))*NME+IEL + FEP(IEL)=QEXT(LFLX+LXNI+LXNJ+IOF,IG) + ENDDO + + ISFIX=.FALSE. + DO WHILE (.NOT.ALL(ISFIX)) ! LOOP FOR ADAPTIVE CALCULATION + + ! FLUX MOMENT COEFFICIENTS MATRIX + Q2(:NM,:NM+1)=0.0D0 + + DO IY=1,IELEM + DO JY=1,IELEM + DO IX=1,IELEM + DO JX=1,IELEM + DO IE=1,EELEM + DO JE=1,EELEM + II=IELEM*EELEM*(IY-1)+EELEM*(IX-1)+IE + JJ=IELEM*EELEM*(JY-1)+EELEM*(JX-1)+JE + + ! DIAGONAL TERMS + IF(II.EQ.JJ) THEN + Q2(II,JJ)=(SIGMA+CST(IE)**2*WE(JE+1)*BP+(IE-1)*(BM-BP))*V + 1 +CST(IX)**2*WX(JX+1)*ABS(DA(I,J,M)) + 2 +CST(IY)**2*WY(JY+1)*ABS(DB(I,M)) + + ! UPPER DIAGONAL TERMS + ELSEIF(II.LT.JJ) THEN + IF(IY.EQ.JY) THEN + ! ENERGY TERMS + IF(IX.EQ.JX) THEN + IF(MOD(IE+JE,2).EQ.1) THEN + Q2(II,JJ)=-CST(IE)*CST(JE)*WE(JE+1)*BP*V + ELSE + Q2(II,JJ)=CST(IE)*CST(JE)*WE(JE+1)*BP*V + ENDIF + ! X-SPACE TERMS + ELSEIF(IE.EQ.JE) THEN + IF(MOD(IX+JX,2).EQ.1) THEN + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*DA(I,J,M) + ELSE + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*ABS(DA(I,J,M)) + ENDIF + ENDIF + ! Y-SPACE TERMS + ELSEIF(IX.EQ.JX.AND.IE.EQ.JE) THEN + IF(MOD(IY+JY,2).EQ.1) THEN + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*DB(I,M) + ELSE + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ABS(DB(I,M)) + ENDIF + ENDIF + + ! UNDER DIAGONAL TERMS + ELSE + + IF(IY.EQ.JY) THEN + ! ENERGY TERMS + IF(IX.EQ.JX) THEN + IF(MOD(IE+JE,2).EQ.1) THEN + Q2(II,JJ)=-CST(IE)*CST(JE)*(WE(JE+1)*BP-BM-BP)*V + ELSE + Q2(II,JJ)=CST(IE)*CST(JE)*(WE(JE+1)*BP+BM-BP)*V + ENDIF + ! X-SPACE TERMS + ELSEIF(IE.EQ.JE) THEN + IF(MOD(IX+JX,2).EQ.1) THEN + Q2(II,JJ)=CST(IX)*CST(JX)*(WX(JX+1)-2.0D0)*DA(I,J,M) + ELSE + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*ABS(DA(I,J,M)) + ENDIF + ENDIF + ! Y-SPACE TERMS + ELSEIF(IX.EQ.JX.AND.IE.EQ.JE) THEN + IF(MOD(IY+JY,2).EQ.1) THEN + Q2(II,JJ)=CST(IY)*CST(JY)*(WY(JY+1)-2.0D0)*DB(I,M) + ELSE + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ABS(DB(I,M)) + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + + ! FLUX SOURCE VECTOR + DO IY=1,IELEM + DO IX=1,IELEM + DO IE=1,EELEM + II=IELEM*EELEM*(IY-1)+EELEM*(IX-1)+IE + IIE=IELEM*(IY-1)+IX + IIX=EELEM*(IY-1)+IE + IIY=EELEM*(IX-1)+IE + Q2(II,NM+1)=Q(II)*V + ! ENERGY TERMS + IF(MOD(IE,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IE)*(BM-WE(1)*BP)*FEP(IIE)*V + ELSE + Q2(II,NM+1)=Q2(II,NM+1)+CST(IE)*(BM+WE(1)*BP)*FEP(IIE)*V + ENDIF + ! X-SPACE TERMS + IF(MOD(IX,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IX)*(1-WX(1)) + 1 *XNI(IIX,J)*ABS(DA(I,J,M)) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IX)*(1+WX(1)) + 1 *XNI(IIX,J)*DA(I,J,M) + ENDIF + ! Y-SPACE TERMS + IF(MOD(IY,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IY)*(1-WY(1)) + 1 *XNJ(IIY)*ABS(DB(I,M)) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IY)*(1+WY(1)) + 1 *XNJ(IIY)*DB(I,M) + ENDIF + ENDDO + ENDDO + ENDDO + + CALL ALSBD(NM,1,Q2,IER,NM) + IF(IER.NE.0) CALL XABORT('SNFE2D: SINGULAR MATRIX.') + + ! ADAPTIVE CORRECTION OF WEIGHTING PARAMETERS + IF(ANY(ISADPT)) THEN + IF(ISADPT(1)) THEN + CALL SNADPT(EELEM,NM,IELEM**2,Q2(1:EELEM:1,NM+1), + 1 FEP,TB,WE,ISFIX(1)) + ELSE + ISFIX(1)=.TRUE. + ENDIF + IF(ISADPT(2)) THEN + CALL SNADPT(IELEM,NM,EELEM*IELEM,Q2(1:IELEM*EELEM:IELEM,NM+1), + 1 XNI(:NMX,J),1.0,WX,ISFIX(2)) + ELSE + ISFIX(2)=.TRUE. + ENDIF + IF(ISADPT(3)) THEN + CALL SNADPT(IELEM,NM,EELEM*IELEM,Q2(1:NM:IELEM*EELEM,NM+1), + 1 XNJ,1.0,WY,ISFIX(3)) + ELSE + ISFIX(3)=.TRUE. + ENDIF + ELSE + ISFIX=.TRUE. + ENDIF + + END DO ! END OF ADAPTIVE LOOP + + ! CLOSURE RELATIONS + IF(IELEM.EQ.1.AND.LFIXUP.AND.(Q2(1,2).LE.RLOG)) Q2(1,2)=0.0 + XNI(:NMX,J)=WX(1)*XNI(:NMX,J) + XNJ(:NMY)=WY(1)*XNJ(:NMY) + FEP(:NME)=WE(1)*FEP(:NME) + DO IY=1,IELEM + DO IX=1,IELEM + DO IE=1,EELEM + II=IELEM*EELEM*(IY-1)+EELEM*(IX-1)+IE + IIE=IELEM*(IY-1)+IX + IIX=EELEM*(IY-1)+IE + IIY=EELEM*(IX-1)+IE + ! ENERGY + IF(MOD(IE,2).EQ.1) THEN + FEP(IIE)=FEP(IIE)+CST(IE)*WE(IE+1)*Q2(II,NM+1) + ELSE + FEP(IIE)=FEP(IIE)-CST(IE)*WE(IE+1)*Q2(II,NM+1) + ENDIF + ! X-SPACE + IF(MOD(IX,2).EQ.1) THEN + XNI(IIX,J)=XNI(IIX,J)+CST(IX)*WX(IX+1) + 1 *Q2(II,NM+1) + ELSE + XNI(IIX,J)=XNI(IIX,J)+CST(IX)*WX(IX+1) + 1 *Q2(II,NM+1)*SIGN(1.0,DA(I,J,M)) + ENDIF + ! Y-SPACE + IF(MOD(IY,2).EQ.1) THEN + XNJ(IIY)=XNJ(IIY)+CST(IY)*WY(IY+1) + 1 *Q2(II,NM+1) + ELSE + XNJ(IIY)=XNJ(IIY)+CST(IY)*WY(IY+1) + 1 *Q2(II,NM+1)*SIGN(1.0,DB(I,M)) + ENDIF + ENDDO + ENDDO + ENDDO + IF(IELEM.EQ.1.AND.LFIXUP.AND.(XNI(1,J).LE.RLOG)) XNI(1,J)=0.0 + IF(IELEM.EQ.1.AND.LFIXUP.AND.(XNJ(1).LE.RLOG)) XNJ(1)=0.0 + WE=WE0 + WX=WX0 + WY=WY0 + + ! SAVE ENERGY GROUP LOWER BOUNDARY OUTGOING FLUX + FLUX0(:NME,M,I,J)=REAL(FEP(:NME))/DELTAE(IG) + + ! SAVE LAST GROUP LOWER BOUNDARY FLUX + IF(ISLG(IG).EQ.1) THEN + FLUXC(I,J)=FLUXC(I,J)+REAL(FLUX0(1,M,I,J))*DN(1,M) + ENDIF + + ! SAVE LEGENDRE MOMENT OF THE FLUX + DO P=1,NSCT + DO IEL=1,NM + FLUX(IEL,P,I,J)=FLUX(IEL,P,I,J)+Q2(IEL,NM+1)*DN(P,M) + ENDDO + ENDDO + + 140 CONTINUE ! END OF Y-LOOP + + ! SAVE Y-BOUNDARY CONDITIONS + DO IEL=1,NMY + IOF=(M-1)*NMY*LX+(I-1)*NMY+IEL + FUNKNO(LFLX+LXNI+IOF,IG)=REAL(XNJ(IEL)) + ENDDO + + 155 CONTINUE ! END OF X-LOOP + + ! SAVE BOUNDARY CONDITIONS + DO J=1,LY + DO IEL=1,NMX + IOF=(M-1)*NMX*LY+(J-1)*NMX+IEL + FUNKNO(LFLX+IOF,IG)=REAL(XNI(IEL,J)) + ENDDO + ENDDO + + ! SAVE FLUX INFORMATION + FLUX_G(:,:,:,:,IG)=FLUX_G(:,:,:,:,IG)+FLUX(:,:,:,:) + FLUX0_G(:,:,:,:,IG)=FLUX0_G(:,:,:,:,IG)+FLUX0(:,:,:,:) + + 170 CONTINUE ! END OF DIRECTION LOOP + 180 CONTINUE ! END OF ENERGY LOOP +*$OMP END PARALLEL DO + 190 CONTINUE ! END OF OCTANT LOOP + ! SAVE FLUX INFORMATION + DO 200 IG=1,NGEFF + IF(.NOT.INCONV(IG)) GO TO 200 + FUNKNO(:LFLX,IG)= + 1 RESHAPE(REAL(FLUX_G(:NM,:NSCT,:LX,:LY,IG)), + 2 (/ LFLX /) ) + FUNKNO(LFLX+LXNI+LXNJ+1:LFLX+LXNI+LXNJ+LFEP,IG)= + 1 RESHAPE(REAL(FLUX0_G(:NME,:NPQ,:LX,:LY,IG)), (/ LFEP /) ) + 200 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XNI,FLUX0_G,FLUX_G,FLUX0,FLUX,INDANG) + RETURN + 400 FORMAT(16H SNFP12: thread=,I8,12H --->(group=,I4,7H angle=,I4,1H)) + END diff --git a/Dragon/src/SNFE3D.F b/Dragon/src/SNFE3D.F new file mode 100644 index 0000000..d0c8cf4 --- /dev/null +++ b/Dragon/src/SNFE3D.F @@ -0,0 +1,778 @@ +*DECK SNFP13 + SUBROUTINE SNFE3D(NUN,NGEFF,IMPX,INCONV,NGIND,LX,LY,LZ, + 1 IELEM,EELEM,NM,NME,NMX,NMY,NMZ,NMAT,NPQ,NSCT,MAT,VOL,TOTAL, + 2 ESTOPW,NCODE,ZCODE,DELTAE,QEXT,LFIXUP,DU,DE,DZ,W,MRMX,MRMY,MRMZ, + 3 DC,DB,DA,FUNKNO,ISLG,FLUXC,ISBS,NBS,ISBSM,BS,MAXL,WX,WY,WZ,WE, + 4 CST,ISADPT,IBFP,MN,DN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform one inner iteration for solving SN equations in 3D Cartesian +* geometry for the HODD method. Energy-angle multithreading. Albedo +* boundary conditions. Boltzmann-Fokker-Planck (BFP) discretization. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert, A. A. Calloo and C. Bienvenue +* +*Parameters: input +* NUN total number of unknowns in vector FUNKNO. +* NGEFF number of energy groups processed in parallel. +* IMPX print flag (equal to zero for no print). +* INCONV energy group convergence flag (set to .FALSE. if converged). +* NGIND energy group indices assign to the NGEFF set. +* LX number of meshes along X axis. +* LY number of meshes along Y axis. +* LZ number of meshes along Z axis. +* IELEM measure of order of the spatial approximation polynomial: +* =1 constant - default for HODD; +* =2 linear - default for DG; +* >3 higher orders. +* EELEM measure of order of the energy approximation polynomial: +* =1 constant - default for HODD; +* =2 linear - default for DG; +* >3 higher orders. +* NM number of moments in space and energy for flux components +* NME number of moments for energy boundaries components +* NMX number of moments for X axis boundaries components +* NMY number of moments for Y axis boundaries components +* NMZ number of moments for Z axis boundaries components +* NMAT number of material mixtures. +* NPQ number of SN directions in height octants. +* NSCT maximum number of spherical harmonics moments of the flux. +* MAT material mixture index in each region. +* VOL volumes of each region. +* TOTAL macroscopic total cross sections. +* ESTOPW stopping power. +* NCODE boundary condition indices. +* ZCODE albedos. +* DELTAE energy group width in MeV. +* QEXT Legendre components of the fixed source. +* LFIXUP flag to enable negative flux fixup. +* DU first direction cosines ($\\mu$). +* DE second direction cosines ($\\eta$). +* DZ third direction cosines ($\\xi$). +* W weights. +* MRMX quadrature index. +* MRMY quadrature index. +* MRMZ quadrature index. +* DC diamond-scheme parameter. +* DB diamond-scheme parameter. +* DA diamond-scheme parameter. +* MN moment-to-discrete matrix. +* DN discrete-to-moment matrix. +* ISBS flag to indicate the presence or not of boundary fixed +* sources. +* NBS number of boundary fixed sources. +* ISBSM flag array to indicate the presence or not of boundary fixed +* source in each unit surface. +* BS boundary source array with their intensities. +* MAXL maximum size of boundary source array. +* WX spatial X axis closure relation weighting factors. +* WY spatial Y axis closure relation weighting factors. +* WZ spatial Z axis closure relation weighting factors. +* WE energy closure relation weighting factors. +* CST constants for the polynomial approximations. +* ISADPTX flag to enable/disable adaptive X axis flux calculations. +* ISADPTY flag to enable/disable adaptive Y axis flux calculations. +* ISADPTZ flag to enable/disable adaptive Z axis flux calculations. +* ISADPTE flag to enable/disable adaptive energy flux calculations. +* IBFP type of energy proparation relation: +* =1 Galerkin type; +* =2 heuristic Przybylski and Ligou type. +* +*Parameters: input/output +* FUNKNO Legendre components of the flux and boundary fluxes. +* FLUXC flux at the cutoff energy. +* +*----------------------------------------------------------------------- +* +#if defined(_OPENMP) + USE omp_lib +#endif +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NUN,NGEFF,IMPX,NGIND(NGEFF),LX,LY,LZ,IELEM,EELEM,NM,NME, + 1 NMX,NMY,NMZ,NMAT,NPQ,NSCT,MAT(LX,LY,LZ),NCODE(6),MRMX(NPQ), + 2 MRMY(NPQ),MRMZ(NPQ),ISLG(NGEFF),ISBS,NBS, + 3 ISBSM(6*ISBS,NPQ*ISBS,NGEFF*ISBS),MAXL + LOGICAL INCONV(NGEFF) + REAL VOL(LX,LY,LZ),TOTAL(0:NMAT,NGEFF),ESTOPW(0:NMAT,2,NGEFF), + 1 ZCODE(6),DELTAE(NGEFF),QEXT(NUN,NGEFF),DU(NPQ),DE(NPQ),DZ(NPQ), + 2 W(NPQ),DC(LX,LY,NPQ),DB(LX,LZ,NPQ),DA(LY,LZ,NPQ), + 3 FUNKNO(NUN,NGEFF),FLUXC(LX,LY,LZ),BS(MAXL*ISBS,NBS*ISBS), + 4 WX(IELEM+1),WY(IELEM+1),WZ(IELEM+1),WE(EELEM+1), + 5 CST(MAX(IELEM,EELEM)),MN(NPQ,NSCT),DN(NSCT,NPQ) + LOGICAL LFIXUP,ISADPT(4) +*---- +* LOCAL VARIABLES +*---- + INTEGER NPQD(8),IIND(8),P + PARAMETER(IUNOUT=6,RLOG=1.0E-8,PI=3.141592654) + REAL BM,BP,WX0(IELEM+1),WY0(IELEM+1),WZ0(IELEM+1),WE0(EELEM+1) + DOUBLE PRECISION V,Q(NM),Q2(NM,NM+1),FEP(NME),XNK(NMZ) + LOGICAL ISFIX(4) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: INDANG + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: FLUX,FLUX0 + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:,:,:) :: FLUX_G, + 1 FLUX0_G + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: XNI + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: XNJ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(INDANG(NPQ,8)) + ALLOCATE(XNI(NMX,LY,LZ),XNJ(NMY,LZ)) + ALLOCATE(FLUX(NM,NSCT,LX,LY,LZ), + 1 FLUX0(NME,NPQ,LX,LY,LZ)) + ALLOCATE(FLUX_G(NM,NSCT,LX,LY,LZ,NGEFF), + 1 FLUX0_G(NME,NPQ,LX,LY,LZ,NGEFF)) +*---- +* LENGTH OF FUNKNO COMPONENTS (IN ORDER) +*---- + LFLX=NM*LX*LY*LZ*NSCT + LXNI=NMX*LY*LZ*NPQ + LXNJ=NMY*LX*LZ*NPQ + LXNK=NMZ*LX*LY*NPQ + LFEP=NME*LX*LY*LZ*NPQ +*---- +* SET OCTANT SWAPPING ORDER. +*---- + NPQD(:8)=0 + INDANG(:NPQ,:8)=0 + DO 10 M=1,NPQ + VU=DU(M) + VE=DE(M) + VZ=DZ(M) + IF((VU.GE.0.0).AND.(VE.GE.0.0).AND.(VZ.GE.0.0)) THEN + IND=1 + JND=8 + ELSE IF((VU.LE.0.0).AND.(VE.GE.0.0).AND.(VZ.GE.0.0)) THEN + IND=2 + JND=7 + ELSE IF((VU.LE.0.0).AND.(VE.LE.0.0).AND.(VZ.GE.0.0)) THEN + IND=3 + JND=5 + ELSE IF((VU.GE.0.0).AND.(VE.LE.0.0).AND.(VZ.GE.0.0)) THEN + IND=4 + JND=6 + ELSE IF((VU.GE.0.0).AND.(VE.GE.0.0).AND.(VZ.LE.0.0)) THEN + IND=5 + JND=4 + ELSE IF((VU.LE.0.0).AND.(VE.GE.0.0).AND.(VZ.LE.0.0)) THEN + IND=6 + JND=3 + ELSE IF((VU.LE.0.0).AND.(VE.LE.0.0).AND.(VZ.LE.0.0)) THEN + IND=7 + JND=1 + ELSE + IND=8 + JND=2 + ENDIF + IIND(JND)=IND + NPQD(IND)=NPQD(IND)+1 + INDANG(NPQD(IND),IND)=M + 10 CONTINUE +*---- +* MAIN LOOP OVER OCTANTS. +*---- + + FLUX_G(:NM,:NSCT,:LX,:LY,:LZ,:NGEFF)=0.0D0 + FLUX0_G(:NME,:NPQ,:LX,:LY,:LZ,:NGEFF)=0.0D0 + + DO 420 JND=1,8 + IND=IIND(JND) +*---- +* PRELIMINARY LOOPS FOR SETTING BOUNDARY CONDITIONS. +*---- + +*$OMP PARALLEL DO +*$OMP+ PRIVATE(M,IG,VU,VE,VZ,M1,IOF,JOF,IEL,I,J,K,IPQD,E1) +*$OMP+ SHARED(FUNKNO) COLLAPSE(2) + + DO 150 IG=1,NGEFF + DO 140 IPQD=1,NPQD(IND) + IF(.NOT.INCONV(IG)) GO TO 140 + M=INDANG(IPQD,IND) + VU=DU(M) + VE=DE(M) + VZ=DZ(M) + ! X-BOUNDARY + IF(VU.GT.0.0)THEN + M1=MRMX(M) + IF(NCODE(1).NE.4)THEN + DO IEL=1,NMX + DO J=1,LY + DO K=1,LZ + IOF=(((M-1)*LZ+(K-1))*LY+(J-1))*NMX+IEL + JOF=(((M1-1)*LZ+(K-1))*LY+(J-1))*NMX+IEL + FUNKNO(LFLX+IOF,IG)=FUNKNO(LFLX+JOF,IG) + ENDDO + ENDDO + ENDDO + ENDIF + ELSEIF(VU.LT.0.0)THEN + M1=MRMX(M) + IF(NCODE(2).NE.4)THEN + DO IEL=1,NMX + DO J=1,LY + DO K=1,LZ + IOF=(((M-1)*LZ+(K-1))*LY+(J-1))*NMX+IEL + JOF=(((M1-1)*LZ+(K-1))*LY+(J-1))*NMX+IEL + FUNKNO(LFLX+IOF,IG)=FUNKNO(LFLX+JOF,IG) + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + ! Y-BOUNDARY + IF(VE.GT.0.0)THEN + M1=MRMY(M) + IF(NCODE(3).NE.4)THEN + DO IEL=1,NMY + DO I=1,LX + DO K=1,LZ + IOF=(((M-1)*LZ+(K-1))*LX+(I-1))*NMY+IEL + JOF=(((M1-1)*LZ+(K-1))*LX+(I-1))*NMY+IEL + FUNKNO(LFLX+LXNI+IOF,IG)=FUNKNO(LFLX+LXNI+JOF,IG) + ENDDO + ENDDO + ENDDO + ENDIF + ELSEIF(VE.LT.0.0)THEN + M1=MRMY(M) + IF(NCODE(4).NE.4)THEN + DO IEL=1,NMY + DO I=1,LX + DO K=1,LZ + IOF=(((M-1)*LZ+(K-1))*LX+(I-1))*NMY+IEL + JOF=(((M1-1)*LZ+(K-1))*LX+(I-1))*NMY+IEL + FUNKNO(LFLX+LXNI+IOF,IG)=FUNKNO(LFLX+LXNI+JOF,IG) + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + ! Z-BOUNDARY + IF(VZ.GT.0.0)THEN + M1=MRMZ(M) + IF(NCODE(5).NE.4)THEN + DO IEL=1,NMZ + DO I=1,LX + DO J=1,LY + IOF=(((M-1)*LY+(J-1))*LX+(I-1))*NMZ+IEL + JOF=(((M1-1)*LY+(J-1))*LX+(I-1))*NMZ+IEL + E1=FUNKNO(LFLX+LXNI+LXNJ+IOF,IG) + FUNKNO(LFLX+LXNI+LXNJ+IOF,IG)=FUNKNO(LFLX+LXNI+LXNJ+JOF,IG) + FUNKNO(LFLX+LXNI+LXNJ+JOF,IG)=E1 + ENDDO + ENDDO + ENDDO + ENDIF + ELSEIF(VZ.LT.0.0)THEN + M1=MRMZ(M) + IF(NCODE(6).NE.4)THEN + DO IEL=1,NMZ + DO I=1,LX + DO J=1,LY + IOF=(((M-1)*LY+(J-1))*LX+(I-1))*NMZ+IEL + JOF=(((M1-1)*LY+(J-1))*LX+(I-1))*NMZ+IEL + E1=FUNKNO(LFLX+LXNI+LXNJ+IOF,IG) + FUNKNO(LFLX+LXNI+LXNJ+IOF,IG)=FUNKNO(LFLX+LXNI+LXNJ+JOF,IG) + FUNKNO(LFLX+LXNI+LXNJ+JOF,IG)=E1 + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + 140 CONTINUE + 150 CONTINUE + +*$OMP END PARALLEL DO + +*---- +* MAIN SWAPPING LOOPS FOR SN FLUX CALCULATION +*---- + +*$OMP PARALLEL DO +*$OMP+ PRIVATE(ITID,FLUX,M,IG,XNI,XNJ,XNK,Q,Q2,IOF,IER,II,JJ,IEL,I,J,K) +*$OMP+ PRIVATE(FEP,FLUX0,BM,BP,IIE,IIX,IIY,IIZ,IX,IY,IZ) +*$OMP+ PRIVATE(IE,ISFIX,JX,JY,JZ,JE,TB,V,SIGMA,IBM,I0,J0,K0,L,IPQD) +*$OMP+ FIRSTPRIVATE(WE,WX,WY,WZ,WE0,WX0,WY0,WZ0) SHARED(FUNKNO) +*$OMP+ REDUCTION(+:FLUX_G,FLUX0_G,FLUXC) COLLAPSE(2) + + ! LOOP FOR GROUPS TO EXECUTE IN PARALLEL + DO 410 IG=1,NGEFF + + ! LOOP OVER ALL DIRECTIONS + DO 400 IPQD=1,NPQD(IND) + IF(.NOT.INCONV(IG)) GO TO 400 + M=INDANG(IPQD,IND) + IF(W(M).EQ.0.0) GO TO 400 + + ! GET AND PRINT THREAD NUMBER +#if defined(_OPENMP) + ITID=omp_get_thread_num() +#else + ITID=0 +#endif + IF(IMPX.GT.5) WRITE(IUNOUT,500) ITID,NGIND(IG),IPQD + + ! INITIALIZE FLUX + FLUX(:NM,:NSCT,:LX,:LY,:LZ)=0.0D0 + FLUX0(:NME,:NPQ,:LX,:LY,:LZ)=0.0D0 + WE0=WE + WX0=WX + WY0=WY + WZ0=WZ + +*---- +* LOOP OVER X-, Y- AND Z-DIRECTED AXES. +*---- + + ! X-AXIS LOOP + DO 350 I0=1,LX + I=I0 + IF((IND.EQ.2).OR.(IND.EQ.3).OR.(IND.EQ.6).OR.(IND.EQ.7)) I=LX+1-I + + ! Y-AXIS LOOP + DO 310 J0=1,LY + J=J0 + IF((IND.EQ.3).OR.(IND.EQ.4).OR.(IND.EQ.7).OR.(IND.EQ.8)) J=LY+1-J + + ! Z-BOUNDARIES CONDITIONS + DO IEL=1,NMZ + IOF=(((M-1)*LY+(J-1))*LX+(I-1))*NMZ+IEL + IF((IND.EQ.1).OR.(IND.EQ.2).OR.(IND.EQ.3).OR.(IND.EQ.4)) THEN + XNK(IEL)=FUNKNO(LFLX+LXNI+LXNJ+IOF,IG)*ZCODE(5) + ELSE + XNK(IEL)=FUNKNO(LFLX+LXNI+LXNJ+IOF,IG)*ZCODE(6) + ENDIF + ENDDO + + ! Z-BOUNDARIES FIXED SOURCES + IF(ISBS.EQ.1) THEN + IF(((IND.EQ.5).OR.(IND.EQ.6).OR.(IND.EQ.7).OR.(IND.EQ.8)) + 1 .AND.ISBSM(6,M,IG).NE.0) THEN + XNK(1)=XNK(1)+BS((I-1)*LY+J,ISBSM(6,M,IG)) + ELSEIF(((IND.EQ.1).OR.(IND.EQ.2).OR.(IND.EQ.3).OR.(IND.EQ.4)) + 1 .AND.ISBSM(5,M,IG).NE.0) THEN + XNK(1)=XNK(1)+BS((I-1)*LY+J,ISBSM(5,M,IG)) + ENDIF + ENDIF + + ! Z-AXIS LOOP + DO 280 K0=1,LZ + K=K0 + IF((IND.EQ.5).OR.(IND.EQ.6).OR.(IND.EQ.7).OR.(IND.EQ.8)) K=LZ+1-K + + ! Y-BOUNDARIES CONDITIONS + IF(J0.EQ.1) THEN + DO IEL=1,NMY + IOF=(((M-1)*LZ+(K-1))*LX+(I-1))*NMY+IEL + IF((IND.EQ.1).OR.(IND.EQ.2).OR.(IND.EQ.5).OR.(IND.EQ.6)) THEN + XNJ(IEL,K)=FUNKNO(LFLX+LXNI+IOF,IG)*ZCODE(3) + ELSE + XNJ(IEL,K)=FUNKNO(LFLX+LXNI+IOF,IG)*ZCODE(4) + ENDIF + ENDDO + + !Y-BOUNDARIES FIXED SOURCES + IF(ISBS.EQ.1) THEN + IF(((IND.EQ.3).OR.(IND.EQ.4).OR.(IND.EQ.7).OR.(IND.EQ.8)) + 1 .AND.ISBSM(4,M,IG).NE.0) THEN + XNJ(1,K)=XNJ(1,K)+BS((I-1)*LZ+K,ISBSM(4,M,IG)) + ELSEIF(((IND.EQ.1).OR.(IND.EQ.2).OR.(IND.EQ.5).OR.(IND.EQ.6)) + 1 .AND.ISBSM(3,M,IG).NE.0) THEN + XNJ(1,K)=XNJ(1,K)+BS((I-1)*LZ+K,ISBSM(3,M,IG)) + ENDIF + ENDIF + ENDIF + + ! X-BOUNDARIES CONDITIONS + IF(I0.EQ.1) THEN + DO IEL=1,NMX + IOF=(((M-1)*LZ+(K-1))*LY+(J-1))*NMX+IEL + IF((IND.EQ.1).OR.(IND.EQ.4).OR.(IND.EQ.5).OR.(IND.EQ.8)) THEN + XNI(IEL,J,K)=FUNKNO(LFLX+IOF,IG)*ZCODE(1) + ELSE + XNI(IEL,J,K)=FUNKNO(LFLX+IOF,IG)*ZCODE(2) + ENDIF + ENDDO + + ! X-BOUNDARIES FIXED SOURCES + IF(ISBS.EQ.1) THEN + IF(((IND.EQ.2).OR.(IND.EQ.3).OR.(IND.EQ.6).OR.(IND.EQ.7)) + 1 .AND.ISBSM(2,M,IG).NE.0) THEN + XNI(1,J,K)=XNI(1,J,K)+BS((J-1)*LZ+K,ISBSM(2,M,IG)) + ELSEIF(((IND.EQ.1).OR.(IND.EQ.4).OR.(IND.EQ.5).OR.(IND.EQ.8)) + 1 .AND.ISBSM(1,M,IG).NE.0) THEN + XNI(1,J,K)=XNI(1,J,K)+BS((J-1)*LZ+K,ISBSM(1,M,IG)) + ENDIF + ENDIF + ENDIF + + ! DATA + IBM=MAT(I,J,K) + IF(IBM.EQ.0) GO TO 280 + SIGMA=TOTAL(IBM,IG) + BM=ESTOPW(IBM,1,IG)/DELTAE(IG) + BP=ESTOPW(IBM,2,IG)/DELTAE(IG) + V=VOL(I,J,K) + + ! TYPE OF ENERGY PROPAGATION FACTOR + IF(IBFP.EQ.1) THEN ! GALERKIN TYPE + TB=BM/BP + WE(1)=WE(1)*TB + WE(2:EELEM+1)=(WE(2:EELEM+1)-1)*TB+1 + ELSE ! PRZYBYLSKI AND LIGOU TYPE + TB=1.0 + ENDIF + + ! SOURCE DENSITY TERM + DO IEL=1,NM + Q(IEL)=0.0D0 + DO P=1,NSCT + IOF=((((K-1)*LY+(J-1))*LX+(I-1))*NSCT+(P-1))*NM+IEL + Q(IEL)=Q(IEL)+QEXT(IOF,IG)*MN(M,P) + ENDDO + ENDDO + + ! ENERGY GROUP UPPER BOUNDARY INCIDENT FLUX + DO IEL=1,NME + IOF=((((K-1)*LY+(J-1))*LX+(I-1))*NPQ+(M-1))*NME+IEL + FEP(IEL)=QEXT(LFLX+LXNI+LXNJ+LXNK+IOF,IG) + ENDDO + + ISFIX=.FALSE. + DO WHILE (.NOT.ALL(ISFIX)) ! LOOP FOR ADAPTIVE CALCULATION + + ! FLUX MOMENT COEFFICIENTS MATRIX + Q2(:NM,:NM+1)=0.0D0 + + DO IZ=1,IELEM + DO JZ=1,IELEM + DO IY=1,IELEM + DO JY=1,IELEM + DO IX=1,IELEM + DO JX=1,IELEM + DO IE=1,EELEM + DO JE=1,EELEM + II=IELEM**2*EELEM*(IZ-1)+IELEM*EELEM*(IY-1)+EELEM*(IX-1)+IE + JJ=IELEM**2*EELEM*(JZ-1)+IELEM*EELEM*(JY-1)+EELEM*(JX-1)+JE + + ! DIAGONAL TERMS + IF(II.EQ.JJ) THEN + Q2(II,JJ)=(SIGMA+CST(IE)**2*WE(JE+1)*BP+(IE-1)*(BM-BP))*V + 1 +CST(IX)**2*WX(JX+1)*ABS(DA(J,K,M)) + 2 +CST(IY)**2*WY(JY+1)*ABS(DB(I,K,M)) + 3 +CST(IZ)**2*WZ(JZ+1)*ABS(DC(I,J,M)) + + ! UPPER DIAGONAL TERMS + ELSEIF(II.LT.JJ) THEN + IF(IZ.EQ.JZ) THEN + IF(IY.EQ.JY) THEN + IF(IX.EQ.JX) THEN + ! ENERGY TERMS + IF(MOD(IE+JE,2).EQ.1) THEN + Q2(II,JJ)=-CST(IE)*CST(JE)*WE(JE+1)*BP*V + ELSE + Q2(II,JJ)=CST(IE)*CST(JE)*WE(JE+1)*BP*V + ENDIF + ELSEIF(IE.EQ.JE) THEN + ! X-SPACE TERMS + IF(MOD(IX+JX,2).EQ.1) THEN + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*DA(J,K,M) + ELSE + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*ABS(DA(J,K,M)) + ENDIF + ENDIF + ELSEIF(IX.EQ.JX.AND.IE.EQ.JE) THEN + ! Y-SPACE TERMS + IF(MOD(IY+JY,2).EQ.1) THEN + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*DB(I,K,M) + ELSE + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ABS(DB(I,K,M)) + ENDIF + ENDIF + ELSEIF(IY.EQ.JY.AND.IX.EQ.JX.AND.IE.EQ.JE) THEN + ! Z-SPACE TERMS + IF(MOD(IZ+JZ,2).EQ.1) THEN + Q2(II,JJ)=CST(IZ)*CST(JZ)*WZ(JZ+1)*DC(I,J,M) + ELSE + Q2(II,JJ)=CST(IZ)*CST(JZ)*WZ(JZ+1)*ABS(DC(I,J,M)) + ENDIF + ENDIF + + ! UNDER DIAGONAL TERMS + ELSE + IF(IZ.EQ.JZ) THEN + IF(IY.EQ.JY) THEN + IF(IX.EQ.JX) THEN + ! ENERGY TERMS + IF(MOD(IE+JE,2).EQ.1) THEN + Q2(II,JJ)=-CST(IE)*CST(JE)*(WE(JE+1)*BP-BM-BP)*V + ELSE + Q2(II,JJ)=CST(IE)*CST(JE)*(WE(JE+1)*BP+BM-BP)*V + ENDIF + ELSEIF(IE.EQ.JE) THEN + ! X-SPACE TERMS + IF(MOD(IX+JX,2).EQ.1) THEN + Q2(II,JJ)=CST(IX)*CST(JX)*(WX(JX+1)-2)*DA(J,K,M) + ELSE + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*ABS(DA(J,K,M)) + ENDIF + ENDIF + ELSEIF(IX.EQ.JX.AND.IE.EQ.JE) THEN + ! Y-SPACE TERMS + IF(MOD(IY+JY,2).EQ.1) THEN + Q2(II,JJ)=CST(IY)*CST(JY)*(WY(JY+1)-2)*DB(I,K,M) + ELSE + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ABS(DB(I,K,M)) + ENDIF + ENDIF + ELSEIF(IY.EQ.JY.AND.IX.EQ.JX.AND.IE.EQ.JE) THEN + ! Z-SPACE TERMS + IF(MOD(IZ+JZ,2).EQ.1) THEN + Q2(II,JJ)=CST(IZ)*CST(JZ)*(WZ(JZ+1)-2)*DC(I,J,M) + ELSE + Q2(II,JJ)=CST(IZ)*CST(JZ)*WZ(JZ+1)*ABS(DC(I,J,M)) + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + + ! FLUX SOURCE VECTOR + DO IZ=1,IELEM + DO IY=1,IELEM + DO IX=1,IELEM + DO IE=1,EELEM + + II=IELEM**2*EELEM*(IZ-1)+IELEM*EELEM*(IY-1)+EELEM*(IX-1)+IE + IIE=IELEM**2*(IZ-1)+IELEM*(IY-1)+IX + IIX=IELEM*EELEM*(IZ-1)+EELEM*(IY-1)+IE + IIY=IELEM*EELEM*(IZ-1)+EELEM*(IX-1)+IE + IIZ=IELEM*EELEM*(IY-1)+EELEM*(IX-1)+IE + Q2(II,NM+1)=Q(II)*V + ! ENERGY TERMS + IF(MOD(IE,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IE)*(BM-WE(1)*BP)*FEP(IIE)*V + ELSE + Q2(II,NM+1)=Q2(II,NM+1)+CST(IE)*(BM+WE(1)*BP)*FEP(IIE)*V + ENDIF + ! X-SPACE TERMS + IF(MOD(IX,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IX)*(1-WX(1)) + 1 *XNI(IIX,J,K)*ABS(DA(J,K,M)) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IX)*(1+WX(1)) + 1 *XNI(IIX,J,K)*DA(J,K,M) + ENDIF + ! Y-SPACE TERMS + IF(MOD(IY,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IY)*(1-WY(1)) + 1 *XNJ(IIY,K)*ABS(DB(I,K,M)) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IY)*(1+WY(1)) + 1 *XNJ(IIY,K)*DB(I,K,M) + ENDIF + ! Z-SPACE TERMS + IF(MOD(IZ,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IZ)*(1-WZ(1)) + 1 *XNK(IIZ)*ABS(DC(I,J,M)) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IZ)*(1+WZ(1)) + 1 *XNK(IIZ)*DC(I,J,M) + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + CALL ALSBD(NM,1,Q2,IER,NM) + IF(IER.NE.0) CALL XABORT('SNFE2D: SINGULAR MATRIX.') + + ! ADAPTIVE CORRECTION OF WEIGHTING PARAMETERS + IF(ANY(ISADPT)) THEN + IF(ISADPT(1)) THEN + CALL SNADPT(EELEM,NM,IELEM**3,Q2(1:EELEM:1,NM+1), + 1 FEP,TB,WE,ISFIX(1)) + ELSE + ISFIX(1)=.TRUE. + ENDIF + IF(ISADPT(2)) THEN + CALL SNADPT(IELEM,NM,EELEM*IELEM**2, + 1 Q2(1:IELEM*EELEM:IELEM,NM+1),XNI(:NMX,J,K), + 2 1.0,WX,ISFIX(2)) + ELSE + ISFIX(2)=.TRUE. + ENDIF + IF(ISADPT(3)) THEN + CALL SNADPT(IELEM,NM,EELEM*IELEM**2, + 1 Q2(1:EELEM*IELEM**2:IELEM*EELEM,NM+1),XNJ(:NMY,K), + 2 1.0,WY,ISFIX(3)) + ELSE + ISFIX(3)=.TRUE. + ENDIF + IF(ISADPT(4)) THEN + CALL SNADPT(IELEM,NM,EELEM*IELEM**2, + 1 Q2(1:NM:EELEM*IELEM**2,NM+1),XNK,1.0,WZ,ISFIX(4)) + ELSE + ISFIX(4)=.TRUE. + ENDIF + ELSE + ISFIX=.TRUE. + ENDIF + + END DO ! END OF ADAPTIVE LOOP + + ! CLOSURE RELATIONS + IF(IELEM.EQ.1.AND.LFIXUP.AND.(Q2(1,2).LE.RLOG)) Q2(1,2)=0.0 + XNI(:NMX,J,K)=WX(1)*XNI(:NMX,J,K) + XNJ(:NMY,K)=WY(1)*XNJ(:NMY,K) + XNK(:NMZ)=WZ(1)*XNK(:NMZ) + FEP(:NME)=WE(1)*FEP(:NME) + DO IZ=1,IELEM + DO IY=1,IELEM + DO IX=1,IELEM + DO IE=1,EELEM + + II=IELEM**2*EELEM*(IZ-1)+IELEM*EELEM*(IY-1)+EELEM*(IX-1)+IE + IIE=IELEM**2*(IZ-1)+IELEM*(IY-1)+IX + IIX=IELEM*EELEM*(IZ-1)+EELEM*(IY-1)+IE + IIY=IELEM*EELEM*(IZ-1)+EELEM*(IX-1)+IE + IIZ=IELEM*EELEM*(IY-1)+EELEM*(IX-1)+IE + + ! ENERGY + IF(MOD(IE,2).EQ.1) THEN + FEP(IIE)=FEP(IIE)+CST(IE)*WE(IE+1)*Q2(II,NM+1) + ELSE + FEP(IIE)=FEP(IIE)-CST(IE)*WE(IE+1)*Q2(II,NM+1) + ENDIF + ! X-SPACE + IF(MOD(IX,2).EQ.1) THEN + XNI(IIX,J,K)=XNI(IIX,J,K)+CST(IX)*WX(IX+1) + 1 *Q2(II,NM+1) + ELSE + XNI(IIX,J,K)=XNI(IIX,J,K)+CST(IX)*WX(IX+1) + 1 *Q2(II,NM+1)*SIGN(1.0,DA(J,K,M)) + ENDIF + ! Y-SPACE + IF(MOD(IY,2).EQ.1) THEN + XNJ(IIY,K)=XNJ(IIY,K)+CST(IY)*WY(IY+1) + 1 *Q2(II,NM+1) + ELSE + XNJ(IIY,K)=XNJ(IIY,K)+CST(IY)*WY(IY+1) + 1 *Q2(II,NM+1)*SIGN(1.0,DB(I,K,M)) + ENDIF + ! Z-SPACE + IF(MOD(IZ,2).EQ.1) THEN + XNK(IIZ)=XNK(IIZ)+CST(IZ)*WZ(IZ+1) + 1 *Q2(II,NM+1) + ELSE + XNK(IIZ)=XNK(IIZ)+CST(IZ)*WZ(IZ+1) + 1 *Q2(II,NM+1)*SIGN(1.0,DC(I,J,M)) + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + IF(IELEM.EQ.1.AND.LFIXUP.AND.(XNI(1,J,K).LE.RLOG)) + 1 XNI(1,J,K)=0.0 + IF(IELEM.EQ.1.AND.LFIXUP.AND.(XNJ(1,K).LE.RLOG)) + 1 XNJ(1,K)=0.0 + IF(IELEM.EQ.1.AND.LFIXUP.AND.(XNK(1).LE.RLOG)) XNK(1)=0.0 + WE=WE0 + WX=WX0 + WY=WY0 + WZ=WZ0 + + ! SAVE ENERGY GROUP LOWER BOUNDARY OUTGOING FLUX + FLUX0(:NME,M,I,J,K)=REAL(FEP(:NME))/DELTAE(IG) + + ! SAVE LAST GROUP LOWER BOUNDARY FLUX + IF(ISLG(IG).EQ.1) THEN + FLUXC(I,J,K)=FLUXC(I,J,K)+REAL(FLUX0(1,M,I,J,K))*DN(1,M) + ENDIF + + ! SAVE LEGENDRE MOMENT OF THE FLIX + DO P=1,NSCT + DO IEL=1,NM + FLUX(IEL,P,I,J,K)=FLUX(IEL,P,I,J,K)+Q2(IEL,NM+1)*DN(P,M) + ENDDO + ENDDO + + 280 CONTINUE ! END OF Z-LOOP + + ! SAVE BOUNDARY CONDITIONS + DO IEL=1,NMZ + IOF=(((M-1)*LY+(J-1))*LX+(I-1))*NMZ+IEL + FUNKNO(LFLX+LXNI+LXNJ+IOF,IG)=REAL(XNK(IEL)) + ENDDO + + 310 CONTINUE ! END OF Y-LOOP + + ! SAVE BOUNDARY CONDITIONS + DO K=1,LZ + DO IEL=1,NMY + IOF=(((M-1)*LZ+(K-1))*LX+(I-1))*NMY+IEL + FUNKNO(LFLX+LXNI+IOF,IG)=REAL(XNJ(IEL,K)) + ENDDO + ENDDO + + 350 CONTINUE ! END OF X-LOOP + + ! SAVE BOUNDARY CONDITIONS + DO K=1,LZ + DO J=1,LY + DO IEL=1,NMX + IOF=(((M-1)*LZ+(K-1))*LY+(J-1))*NMX+IEL + FUNKNO(LFLX+IOF,IG)=REAL(XNI(IEL,J,K)) + ENDDO + ENDDO + ENDDO + + ! SAVE FLUX INFORMATION + FLUX_G(:,:,:,:,:,IG)=FLUX_G(:,:,:,:,:,IG)+FLUX(:,:,:,:,:) + FLUX0_G(:,:,:,:,:,IG)=FLUX0_G(:,:,:,:,:,IG)+FLUX0(:,:,:,:,:) + + + 400 CONTINUE ! END OF DIRECTION LOOP + 410 CONTINUE ! END OF ENERGY LOOP +*$OMP END PARALLEL DO + 420 CONTINUE ! END OF OCTANT LOOP + + ! SAVE FLUX INFORMATION + DO 430 IG=1,NGEFF + IF(.NOT.INCONV(IG)) GO TO 430 + FUNKNO(:LFLX,IG)= + 1 RESHAPE(REAL(FLUX_G(:NM,:NSCT,:LX,:LY,:LZ,IG)), + 2 (/LFLX/)) + FUNKNO(LFLX+LXNI+LXNJ+LXNK+1:LFLX+LXNI+LXNJ+LXNK+LFEP,IG)= + 1 RESHAPE(REAL(FLUX0_G(:NME,:NPQ,:LX,:LY,:LZ,IG)), + 2 (/ LFEP /) ) + 430 CONTINUE + +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(FLUX0_G,FLUX_G,FLUX0,FLUX,XNJ,XNI,INDANG) + RETURN + 500 FORMAT(16H SNFP13: thread=,I8,12H --->(group=,I4,7H angle=,I4,1H)) + END diff --git a/Dragon/src/SNFG2D.F b/Dragon/src/SNFG2D.F new file mode 100644 index 0000000..e89a19b --- /dev/null +++ b/Dragon/src/SNFG2D.F @@ -0,0 +1,512 @@ +*DECK SNFG2D + SUBROUTINE SNFG2D(NUN,NGEFF,IMPX,INCONV,NGIND,LX,LY,IELEM, + 1 NM,NMX,NMY,NMAT,NPQ,NSCT,MAT,VOL,TOTAL,NCODE,ZCODE,QEXT,LFIXUP, + 2 DU,DE,W,MRM,MRMY,DB,DA,FUNKNO,ISBS,NBS,ISBSM,BS,MAXL,WX,WY, + 3 CST,ISADPT,MN,DN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform one inner iteration for solving SN equations in 2D Cartesian +* geometry for the HODD method. Energy-angle multithreading. Albedo +* boundary conditions. Boltzmann (BTE) discretization. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert, A. A. Calloo and C.Bienvenue +* +*Parameters: input +* NUN total number of unknowns in vector FUNKNO. +* NGEFF number of energy groups processed in parallel. +* IMPX print flag (equal to zero for no print). +* INCONV energy group convergence flag (set to .FALSE. if converged). +* NGIND energy group indices assign to the NGEFF set. +* LX number of meshes along X axis. +* LY number of meshes along Y axis. +* IELEM measure of order of the spatial approximation polynomial: +* =1 constant - default for HODD; +* =2 linear - default for DG; +* >3 higher orders. +* NM number of moments in space and energy for flux components +* NMX number of moments for X axis boundaries components +* NMY number of moments for Y axis boundaries components +* NMAT number of material mixtures. +* NPQ number of SN directions in four octants (including zero-weight +* directions). +* NSCT maximum number of spherical harmonics moments of the flux. +* MAT material mixture index in each region. +* VOL volumes of each region. +* TOTAL macroscopic total cross sections. +* NCODE boundary condition indices. +* ZCODE albedos. +* QEXT Legendre components of the fixed source. +* LFIXUP flag to enable negative flux fixup. +* DU first direction cosines ($\\mu$). +* DE second direction cosines ($\\eta$). +* W weights. +* MRM quadrature index. +* MRMY quadrature index. +* DB diamond-scheme parameter. +* DA diamond-scheme parameter. +* MN moment-to-discrete matrix. +* DN discrete-to-moment matrix. +* ISBS flag to indicate the presence or not of boundary fixed +* sources. +* NBS number of boundary fixed sources. +* ISBSM flag array to indicate the presence or not of boundary fixed +* source in each unit surface. +* BS boundary source array with their intensities. +* MAXL maximum size of boundary source array. +* WX spatial X axis closure relation weighting factors. +* WY spatial Y axis closure relation weighting factors. +* CST constants for the polynomial approximations. +* ISADPTX flag to enable/disable adaptive X axis flux calculations. +* ISADPTY flag to enable/disable adaptive Y axis flux calculations. +* +*Parameters: input/output +* FUNKNO Legendre components of the flux and boundary fluxes. +* FLUXC flux at the cutoff energy. +* +*----------------------------------------------------------------------- +#if defined(_OPENMP) + USE omp_lib +#endif +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NUN,NGEFF,IMPX,NGIND(NGEFF),LX,LY,IELEM, + 1 NM,NMX,NMY,NMAT,NPQ, + 2 NSCT,MAT(LX,LY),NCODE(4),MRM(NPQ),MRMY(NPQ),ISBS, + 3 NBS,ISBSM(4*ISBS,NPQ*ISBS,NGEFF*ISBS),MAXL + LOGICAL INCONV(NGEFF) + REAL VOL(LX,LY),TOTAL(0:NMAT,NGEFF), + 1 ZCODE(4),QEXT(NUN,NGEFF),DU(NPQ),DE(NPQ),W(NPQ), + 2 DB(LX,NPQ),DA(LX,LY,NPQ),FUNKNO(NUN,NGEFF), + 3 BS(MAXL*ISBS,NBS*ISBS),WX(IELEM+1),WY(IELEM+1), + 4 CST(IELEM),MN(NPQ,NSCT),DN(NSCT,NPQ) + LOGICAL LFIXUP,ISADPT(2) +*---- +* LOCAL VARIABLES +*---- + INTEGER NPQD(4),IIND(4),P + REAL WX0(IELEM+1),WY0(IELEM+1) + DOUBLE PRECISION Q(NM),Q2(NM,NM+1), + 1 XNJ(NMY),V + PARAMETER(IUNOUT=6,RLOG=1.0E-8,PI=3.141592654) + LOGICAL ISFIX(2) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: INDANG + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:) :: FLUX + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: FLUX_G + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: XNI +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(INDANG(NPQ,4)) + ALLOCATE(XNI(NMX,LY),FLUX(NM,NSCT,LX,LY)) + ALLOCATE(FLUX_G(NM,NSCT,LX,LY,NGEFF)) +*---- +* LENGTH OF FUNKNO COMPONENTS (IN ORDER) +*---- + LFLX=NM*LX*LY*NSCT + LXNI=NMX*LY*NPQ + LXNJ=NMY*LX*NPQ +*---- +* SET OCTANT SWAPPING ORDER. +*---- + NPQD(:4)=0 + INDANG(:NPQ,:4)=0 + DO M=1,NPQ + VU=DU(M) + VE=DE(M) + IF((VU.GE.0.0).AND.(VE.GE.0.0)) THEN + IND=1 + JND=4 + ELSE IF((VU.LE.0.0).AND.(VE.GE.0.0)) THEN + IND=2 + JND=3 + ELSE IF((VU.LE.0.0).AND.(VE.LE.0.0)) THEN + IND=3 + JND=1 + ELSE + IND=4 + JND=2 + ENDIF + IIND(JND)=IND + NPQD(IND)=NPQD(IND)+1 + INDANG(NPQD(IND),IND)=M + ENDDO +*---- +* MAIN LOOP OVER OCTANTS. +*---- + + FLUX_G(:NM,:NSCT,:LX,:LY,:NGEFF)=0.0D0 + WX0=WX + WY0=WY + + DO 190 JND=1,4 + IND=IIND(JND) +*---- +* PRELIMINARY LOOPS FOR SETTING BOUNDARY CONDITIONS. +*---- + +*$OMP PARALLEL DO +*$OMP+ PRIVATE(M,IG,VU,VE,M1,IOF,JOF,IEL,I,J,IPQD) +*$OMP+ SHARED(FUNKNO) COLLAPSE(2) + + DO 70 IG=1,NGEFF + DO 60 IPQD=1,NPQD(IND) + IF(.NOT.INCONV(IG)) GO TO 60 + M=INDANG(IPQD,IND) + VU=DU(M) + VE=DE(M) + ! X-BOUNDARY + IF(VU.GT.0.0)THEN + M1=MRM(M) + IF((NCODE(1).NE.4))THEN + DO IEL=1,NMX + DO J=1,LY + IOF=((M-1)*LY+(J-1))*NMX+IEL + JOF=((M1-1)*LY+(J-1))*NMX+IEL + FUNKNO(LFLX+IOF,IG)=FUNKNO(LFLX+JOF,IG) + ENDDO + ENDDO + ENDIF + ELSEIF(VU.LT.0.0)THEN + M1=MRM(M) + IF((NCODE(2).NE.4))THEN + DO IEL=1,NMX + DO J=1,LY + IOF=((M-1)*LY+(J-1))*NMX+IEL + JOF=((M1-1)*LY+(J-1))*NMX+IEL + FUNKNO(LFLX+IOF,IG)=FUNKNO(LFLX+JOF,IG) + ENDDO + ENDDO + ENDIF + ENDIF + ! Y-BOUNDARY + IF(VE.GT.0.0)THEN + M1=MRMY(M) + IF((NCODE(3).NE.4))THEN + DO IEL=1,NMY + DO I=1,LX + IOF=((M-1)*LX+(I-1))*NMY+IEL + JOF=((M1-1)*LX+(I-1))*NMY+IEL + FUNKNO(LFLX+LXNI+IOF,IG)= + > FUNKNO(LFLX+LXNI+JOF,IG) + ENDDO + ENDDO + ENDIF + ELSEIF(VE.LT.0.0)THEN + M1=MRMY(M) + IF((NCODE(4).NE.4))THEN + DO IEL=1,NMY + DO I=1,LX + IOF=((M-1)*LX+(I-1))*NMY+IEL + JOF=((M1-1)*LX+(I-1))*NMY+IEL + FUNKNO(LFLX+LXNI+IOF,IG)= + > FUNKNO(LFLX+LXNI+JOF,IG) + ENDDO + ENDDO + ENDIF + ENDIF + 60 CONTINUE + 70 CONTINUE + +*OMP END PARALLEL DO + +*---- +* MAIN SWAPPING LOOPS FOR SN FLUX CALCULATION +*---- + +*$OMP PARALLEL DO +*$OMP+ PRIVATE(ITID,FLUX,M,IG,XNI,XNJ,Q,Q2,IOF,IER,II,JJ,IEL,I,J,L) +*$OMP+ PRIVATE(IPQD,I0,J0,IBM,SIGMA,V,ISFIX,IX,JX,IY,JY) +*$OMP+ FIRSTPRIVATE(WX,WY,WX0,WY0) SHARED(FUNKNO) +*$OMP+ REDUCTION(+:FLUX_G) COLLAPSE(2) + + ! LOOP FOR GROUPS TO EXECUTE IN PARALLEL + DO 180 IG=1,NGEFF + + ! LOOP OVER ALL DIRECTIONS + DO 170 IPQD=1,NPQD(IND) + IF(.NOT.INCONV(IG)) GO TO 170 + M=INDANG(IPQD,IND) + IF(W(M).EQ.0.0) GO TO 170 + + ! GET AND PRINT THREAD NUMBER +#if defined(_OPENMP) + ITID=omp_get_thread_num() +#else + ITID=0 +#endif + IF(IMPX.GT.5) WRITE(IUNOUT,400) ITID,NGIND(IG),IPQD + + ! INITIALIZE FLUXES + FLUX(:NM,:NSCT,:LX,:LY)=0.0D0 + +*---- +* LOOP OVER X- AND Y-DIRECTED AXES. +*---- + + ! X-AXIS LOOP + DO 155 I0=1,LX + I=I0 + IF((IND.EQ.2).OR.(IND.EQ.3)) I=LX+1-I + + ! Y-BOUNDARIES CONDITIONS + XNJ=0.0 + DO IEL=1,NMY + IOF=(M-1)*NMY*LX+(I-1)*NMY+IEL + IF((IND.EQ.1).OR.(IND.EQ.2)) THEN + XNJ(IEL)=FUNKNO(LFLX+LXNI+IOF,IG)*ZCODE(3) + ELSE + XNJ(IEL)=FUNKNO(LFLX+LXNI+IOF,IG)*ZCODE(4) + ENDIF + ENDDO + + ! Y-BOUNDARIES FIXED SOURCES + IF(ISBS.EQ.1) THEN + IF((IND.EQ.3.OR.IND.EQ.4).AND.ISBSM(4,M,IG).NE.0) THEN + XNJ(1)=XNJ(1)+BS(I,ISBSM(4,M,IG)) + ELSE IF((IND.EQ.1.OR.IND.EQ.2).AND.ISBSM(3,M,IG).NE.0) THEN + XNJ(1)=XNJ(1)+BS(I,ISBSM(3,M,IG)) + ENDIF + ENDIF + + ! Y-AXIS LOOP + DO 140 J0=1,LY + J=J0 + IF((IND.EQ.3).OR.(IND.EQ.4)) J=LY+1-J + + ! X-BOUNDARIES CONDITIONS + IF(I0.EQ.1) THEN + XNI(:NMX,J)=0.0 + DO IEL=1,NMX + IOF=(M-1)*NMX*LY+(J-1)*NMX+IEL + IF((IND.EQ.1).OR.(IND.EQ.4)) THEN + XNI(IEL,J)=FUNKNO(LFLX+IOF,IG)*ZCODE(1) + ELSE + XNI(IEL,J)=FUNKNO(LFLX+IOF,IG)*ZCODE(2) + ENDIF + ENDDO + ENDIF + + ! X-BOUNDARIES FIXED SOURCES + IF(ISBS.EQ.1.AND.I0.EQ.1) THEN + IF((IND.EQ.2.OR.IND.EQ.3).AND.ISBSM(2,M,IG).NE.0) THEN + XNI(1,J)=XNI(1,J)+BS(J,ISBSM(2,M,IG)) + ELSE IF((IND.EQ.1.OR.IND.EQ.4).AND.ISBSM(1,M,IG).NE.0) THEN + XNI(1,J)=XNI(1,J)+BS(J,ISBSM(1,M,IG)) + ENDIF + ENDIF + + ! DATA + IBM=MAT(I,J) + IF(IBM.EQ.0) GO TO 140 + SIGMA=TOTAL(IBM,IG) + V=VOL(I,J) + + ! SOURCE DENSITY TERM + DO IEL=1,NM + Q(IEL)=0.0D0 + DO P=1,NSCT + IOF=((J-1)*LX*NSCT+(I-1)*NSCT+(P-1))*NM+IEL + Q(IEL)=Q(IEL)+QEXT(IOF,IG)*MN(M,P) + ENDDO + ENDDO + + ISFIX=.FALSE. + DO WHILE (.NOT.ALL(ISFIX)) ! LOOP FOR ADAPTIVE CALCULATION + + ! FLUX MOMENT COEFFICIENTS MATRIX + Q2(:NM,:NM+1)=0.0D0 + + DO IY=1,IELEM + DO JY=1,IELEM + DO IX=1,IELEM + DO JX=1,IELEM + II=IELEM*(IY-1)+IX + JJ=IELEM*(JY-1)+JX + + ! DIAGONAL TERMS + IF(II.EQ.JJ) THEN + Q2(II,JJ)=SIGMA*V + 1 +CST(IX)**2*WX(JX+1)*ABS(DA(I,J,M)) + 2 +CST(IY)**2*WY(JY+1)*ABS(DB(I,M)) + + ! UPPER DIAGONAL TERMS + ELSEIF(II.LT.JJ) THEN + ! X-SPACE TERMS + IF(IY.EQ.JY) THEN + IF(MOD(IX+JX,2).EQ.1) THEN + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*DA(I,J,M) + ELSE + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*ABS(DA(I,J,M)) + ENDIF + ! Y-SPACE TERMS + ELSEIF(IX.EQ.JX) THEN + IF(MOD(IY+JY,2).EQ.1) THEN + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*DB(I,M) + ELSE + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ABS(DB(I,M)) + ENDIF + ENDIF + + ! UNDER DIAGONAL TERMS + ELSE + ! X-SPACE TERMS + IF(IY.EQ.JY) THEN + IF(MOD(IX+JX,2).EQ.1) THEN + Q2(II,JJ)=CST(IX)*CST(JX)*(WX(JX+1)-2)*DA(I,J,M) + ELSE + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*ABS(DA(I,J,M)) + ENDIF + ! Y-SPACE TERMS + ELSEIF(IX.EQ.JX) THEN + IF(MOD(IY+JY,2).EQ.1) THEN + Q2(II,JJ)=CST(IY)*CST(JY)*(WY(JY+1)-2)*DB(I,M) + ELSE + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ABS(DB(I,M)) + ENDIF + ENDIF + + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + + ! FLUX SOURCE VECTOR + DO IY=1,IELEM + DO IX=1,IELEM + II=IELEM*(IY-1)+IX + Q2(II,NM+1)=Q(II)*V + ! X-SPACE TERMS + IF(MOD(IX,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IX)*(1-WX(1)) + 1 *XNI(IY,J)*ABS(DA(I,J,M)) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IX)*(1+WX(1)) + 1 *XNI(IY,J)*DA(I,J,M) + ENDIF + ! Y-SPACE TERMS + IF(MOD(IY,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IY)*(1-WY(1)) + 1 *XNJ(IX)*ABS(DB(I,M)) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IY)*(1+WY(1)) + 1 *XNJ(IX)*DB(I,M) + ENDIF + ENDDO + ENDDO + + CALL ALSBD(NM,1,Q2,IER,NM) + IF(IER.NE.0) CALL XABORT('SNFE2D: SINGULAR MATRIX.') + + ! ADAPTIVE CORRECTION OF WEIGHTING PARAMETERS + IF(ANY(ISADPT)) THEN + IF(ISADPT(1)) THEN + CALL SNADPT(IELEM,NM,IELEM,Q2(1:IELEM:1,NM+1), + 1 XNI(:NMX,J),1.0,WX,ISFIX(1)) + ELSE + ISFIX(1)=.TRUE. + ENDIF + IF(ISADPT(2)) THEN + CALL SNADPT(IELEM,NM,IELEM,Q2(1:NM:IELEM,NM+1), + 1 XNJ,1.0,WY,ISFIX(2)) + ELSE + ISFIX(2)=.TRUE. + ENDIF + ELSE + ISFIX=.TRUE. + ENDIF + + END DO ! END OF ADAPTIVE LOOP + + ! CLOSURE RELATIONS + IF(IELEM.EQ.1.AND.LFIXUP.AND.(Q2(1,2).LE.RLOG)) Q2(1,2)=0.0 + XNI(:NMX,J)=WX(1)*XNI(:NMX,J) + XNJ(:NMY)=WY(1)*XNJ(:NMY) + DO IY=1,IELEM + DO IX=1,IELEM + II=IELEM*(IY-1)+IX + ! X-SPACE + IF(MOD(IX,2).EQ.1) THEN + XNI(IY,J)=XNI(IY,J)+CST(IX)*WX(IX+1) + 1 *Q2(II,NM+1) + ELSE + XNI(IY,J)=XNI(IY,J)+CST(IX)*WX(IX+1) + 1 *Q2(II,NM+1)*SIGN(1.0,DA(I,J,M)) + ENDIF + ! Y-SPACE + IF(MOD(IY,2).EQ.1) THEN + XNJ(IX)=XNJ(IX)+CST(IY)*WY(IY+1) + 1 *Q2(II,NM+1) + ELSE + XNJ(IX)=XNJ(IX)+CST(IY)*WY(IY+1) + 1 *Q2(II,NM+1)*SIGN(1.0,DB(I,M)) + ENDIF + ENDDO + ENDDO + IF(IELEM.EQ.1.AND.LFIXUP.AND.(XNI(1,J).LE.RLOG)) XNI(1,J)=0.0 + IF(IELEM.EQ.1.AND.LFIXUP.AND.(XNJ(1).LE.RLOG)) XNJ(1)=0.0 + WX=WX0 + WY=WY0 + + ! SAVE LEGENDRE MOMENT OF THE FLUX + DO P=1,NSCT + DO IEL=1,NM + FLUX(IEL,P,I,J)=FLUX(IEL,P,I,J)+Q2(IEL,NM+1)*DN(P,M) + ENDDO + ENDDO + + 140 CONTINUE ! END OF Y-LOOP + + ! SAVE Y-BOUNDARY CONDITIONS + DO IEL=1,NMY + IOF=(M-1)*NMY*LX+(I-1)*NMY+IEL + FUNKNO(LFLX+LXNI+IOF,IG)=REAL(XNJ(IEL)) + ENDDO + + 155 CONTINUE ! END OF X-LOOP + + ! SAVE X-BOUNDARY CONDITIONS + DO J=1,LY + DO IEL=1,NMX + IOF=(M-1)*NMX*LY+(J-1)*NMX+IEL + FUNKNO(LFLX+IOF,IG)=REAL(XNI(IEL,J)) + ENDDO + ENDDO + + ! SAVE FLUX INFORMATION + FLUX_G(:,:,:,:,IG)=FLUX_G(:,:,:,:,IG)+FLUX(:,:,:,:) + + 170 CONTINUE ! END OF DIRECTION LOOP + 180 CONTINUE ! END OF ENERGY LOOP +*$OMP END PARALLEL DO + 190 CONTINUE ! END OF OCTANT LOOP + + ! SAVE FLUX INFORMATION + DO 200 IG=1,NGEFF + IF(.NOT.INCONV(IG)) GO TO 200 + FUNKNO(:LFLX,IG)= + 1 RESHAPE(REAL(FLUX_G(:NM,:NSCT,:LX,:LY,IG)), + 2 (/ LFLX /) ) + 200 CONTINUE + +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XNI,FLUX_G,FLUX,INDANG) + RETURN + 400 FORMAT(16H SNFP12: thread=,I8,12H --->(group=,I4,7H angle=,I4,1H)) + END diff --git a/Dragon/src/SNFG3D.F b/Dragon/src/SNFG3D.F new file mode 100644 index 0000000..b2d408e --- /dev/null +++ b/Dragon/src/SNFG3D.F @@ -0,0 +1,682 @@ +*DECK SNFG3D + SUBROUTINE SNFG3D(NUN,NGEFF,IMPX,INCONV,NGIND,LX,LY,LZ, + 1 IELEM,NM,NMX,NMY,NMZ,NMAT,NPQ,NSCT,MAT,VOL,TOTAL, + 2 NCODE,ZCODE,QEXT,LFIXUP,DU,DE,DZ,W,MRMX,MRMY,MRMZ, + 3 DC,DB,DA,FUNKNO,ISBS,NBS,ISBSM,BS,MAXL,WX,WY,WZ, + 4 CST,ISADPT,MN,DN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform one inner iteration for solving SN equations in 3D Cartesian +* geometry for the HODD method. Energy-angle multithreading. Albedo +* boundary conditions. Boltzmann (BTE) discretization. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert, A. A. Calloo and C. Bienvenue +* +*Parameters: input +* NUN total number of unknowns in vector FUNKNO. +* NGEFF number of energy groups processed in parallel. +* IMPX print flag (equal to zero for no print). +* INCONV energy group convergence flag (set to .FALSE. if converged). +* NGIND energy group indices assign to the NGEFF set. +* LX number of meshes along X axis. +* LY number of meshes along Y axis. +* LZ number of meshes along Z axis. +* IELEM measure of order of the spatial approximation polynomial: +* =1 constant - default for HODD; +* =2 linear - default for DG; +* >3 higher orders. +* NM number of moments in space for flux components +* NMX number of moments for X axis boundaries components +* NMY number of moments for Y axis boundaries components +* NMZ number of moments for Z axis boundaries components +* NMAT number of material mixtures. +* NPQ number of SN directions in height octants. +* NSCT maximum number of spherical harmonics moments of the flux. +* MAT material mixture index in each region. +* VOL volumes of each region. +* TOTAL macroscopic total cross sections. +* ESTOPW stopping power. +* NCODE boundary condition indices. +* ZCODE albedos. +* DELTAE energy group width in MeV. +* QEXT Legendre components of the fixed source. +* LFIXUP flag to enable negative flux fixup. +* DU first direction cosines ($\\mu$). +* DE second direction cosines ($\\eta$). +* DZ third direction cosines ($\\xi$). +* W weights. +* MRMX quadrature index. +* MRMY quadrature index. +* MRMZ quadrature index. +* DC diamond-scheme parameter. +* DB diamond-scheme parameter. +* DA diamond-scheme parameter. +* MN moment-to-discrete matrix. +* DN discrete-to-moment matrix. +* ISBS flag to indicate the presence or not of boundary fixed +* sources. +* NBS number of boundary fixed sources. +* ISBSM flag array to indicate the presence or not of boundary fixed +* source in each unit surface. +* BS boundary source array with their intensities. +* MAXL maximum size of boundary source array. +* WX spatial X axis closure relation weighting factors. +* WY spatial Y axis closure relation weighting factors. +* WZ spatial Z axis closure relation weighting factors. +* CST constants for the polynomial approximations. +* ISADPTX flag to enable/disable adaptive X axis flux calculations. +* ISADPTY flag to enable/disable adaptive Y axis flux calculations. +* ISADPTZ flag to enable/disable adaptive Z axis flux calculations. +* +*Parameters: input/output +* FUNKNO Legendre components of the flux and boundary fluxes. +* FLUXC flux at the cutoff energy. +* +*----------------------------------------------------------------------- +* +#if defined(_OPENMP) + USE omp_lib +#endif +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NUN,NGEFF,IMPX,NGIND(NGEFF),LX,LY,LZ,IELEM, + 1 NM,NMX,NMY,NMZ,NMAT, + 2 NPQ,NSCT,MAT(LX,LY,LZ),NCODE(6),MRMX(NPQ),MRMY(NPQ),MRMZ(NPQ), + 3 ISBS,NBS,ISBSM(6*ISBS,NPQ*ISBS,NGEFF*ISBS),MAXL + LOGICAL INCONV(NGEFF) + REAL VOL(LX,LY,LZ),TOTAL(0:NMAT,NGEFF), + 1 ZCODE(6),QEXT(NUN,NGEFF),DU(NPQ),DE(NPQ),DZ(NPQ), + 2 W(NPQ),DC(LX,LY,NPQ),DB(LX,LZ,NPQ),DA(LY,LZ,NPQ), + 3 FUNKNO(NUN,NGEFF),BS(MAXL*ISBS,NBS*ISBS), + 4 WX(IELEM+1),WY(IELEM+1),WZ(IELEM+1), + 5 CST(IELEM),MN(NPQ,NSCT),DN(NSCT,NPQ) + LOGICAL LFIXUP,ISADPT(4) +*---- +* LOCAL VARIABLES +*---- + INTEGER NPQD(8),IIND(8),P + PARAMETER(IUNOUT=6,RLOG=1.0E-8,PI=3.141592654) + REAL WX0(IELEM+1),WY0(IELEM+1),WZ0(IELEM+1) + DOUBLE PRECISION V,Q(NM),Q2(NM,NM+1),XNK(NMZ) + LOGICAL ISFIX(3) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: INDANG + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: FLUX + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:,:,:) :: FLUX_G + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: XNI + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: XNJ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(INDANG(NPQ,8)) + ALLOCATE(XNI(NMX,LY,LZ),XNJ(NMY,LZ)) + ALLOCATE(FLUX(NM,NSCT,LX,LY,LZ)) + ALLOCATE(FLUX_G(NM,NSCT,LX,LY,LZ,NGEFF)) +*---- +* LENGTH OF FUNKNO COMPONENTS (IN ORDER) +*---- + LFLX=NM*LX*LY*LZ*NSCT + LXNI=NMX*LY*LZ*NPQ + LXNJ=NMY*LX*LZ*NPQ + LXNK=NMZ*LX*LY*NPQ +*---- +* SET OCTANT SWAPPING ORDER. +*---- + NPQD(:8)=0 + INDANG(:NPQ,:8)=0 + DO 10 M=1,NPQ + VU=DU(M) + VE=DE(M) + VZ=DZ(M) + IF((VU.GE.0.0).AND.(VE.GE.0.0).AND.(VZ.GE.0.0)) THEN + IND=1 + JND=8 + ELSE IF((VU.LE.0.0).AND.(VE.GE.0.0).AND.(VZ.GE.0.0)) THEN + IND=2 + JND=7 + ELSE IF((VU.LE.0.0).AND.(VE.LE.0.0).AND.(VZ.GE.0.0)) THEN + IND=3 + JND=5 + ELSE IF((VU.GE.0.0).AND.(VE.LE.0.0).AND.(VZ.GE.0.0)) THEN + IND=4 + JND=6 + ELSE IF((VU.GE.0.0).AND.(VE.GE.0.0).AND.(VZ.LE.0.0)) THEN + IND=5 + JND=4 + ELSE IF((VU.LE.0.0).AND.(VE.GE.0.0).AND.(VZ.LE.0.0)) THEN + IND=6 + JND=3 + ELSE IF((VU.LE.0.0).AND.(VE.LE.0.0).AND.(VZ.LE.0.0)) THEN + IND=7 + JND=1 + ELSE + IND=8 + JND=2 + ENDIF + IIND(JND)=IND + NPQD(IND)=NPQD(IND)+1 + INDANG(NPQD(IND),IND)=M + 10 CONTINUE +*---- +* MAIN LOOP OVER OCTANTS. +*---- + + FLUX_G(:NM,:NSCT,:LX,:LY,:LZ,:NGEFF)=0.0D0 + WX0=WX + WY0=WY + WZ0=WZ + + DO 420 JND=1,8 + IND=IIND(JND) +*---- +* PRELIMINARY LOOPS FOR SETTING BOUNDARY CONDITIONS. +*---- + +*$OMP PARALLEL DO +*$OMP+ PRIVATE(M,IG,VU,VE,VZ,M1,IOF,JOF,IEL,I,J,K,IPQD,E1) +*$OMP+ SHARED(FUNKNO) COLLAPSE(2) + + DO 150 IG=1,NGEFF + DO 140 IPQD=1,NPQD(IND) + IF(.NOT.INCONV(IG)) GO TO 140 + M=INDANG(IPQD,IND) + VU=DU(M) + VE=DE(M) + VZ=DZ(M) + ! X-BOUNDARY + IF(VU.GT.0.0)THEN + M1=MRMX(M) + IF(NCODE(1).NE.4)THEN + DO IEL=1,NMX + DO J=1,LY + DO K=1,LZ + IOF=(((M-1)*LZ+(K-1))*LY+(J-1))*NMX+IEL + JOF=(((M1-1)*LZ+(K-1))*LY+(J-1))*NMX+IEL + FUNKNO(LFLX+IOF,IG)=FUNKNO(LFLX+JOF,IG) + ENDDO + ENDDO + ENDDO + ENDIF + ELSEIF(VU.LT.0.0)THEN + M1=MRMX(M) + IF(NCODE(2).NE.4)THEN + DO IEL=1,NMX + DO J=1,LY + DO K=1,LZ + IOF=(((M-1)*LZ+(K-1))*LY+(J-1))*NMX+IEL + JOF=(((M1-1)*LZ+(K-1))*LY+(J-1))*NMX+IEL + FUNKNO(LFLX+IOF,IG)=FUNKNO(LFLX+JOF,IG) + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + ! Y-BOUNDARY + IF(VE.GT.0.0)THEN + M1=MRMY(M) + IF(NCODE(3).NE.4)THEN + DO IEL=1,NMY + DO I=1,LX + DO K=1,LZ + IOF=(((M-1)*LZ+(K-1))*LX+(I-1))*NMY+IEL + JOF=(((M1-1)*LZ+(K-1))*LX+(I-1))*NMY+IEL + FUNKNO(LFLX+LXNI+IOF,IG)=FUNKNO(LFLX+LXNI+JOF,IG) + ENDDO + ENDDO + ENDDO + ENDIF + ELSEIF(VE.LT.0.0)THEN + M1=MRMY(M) + IF(NCODE(4).NE.4)THEN + DO IEL=1,NMY + DO I=1,LX + DO K=1,LZ + IOF=(((M-1)*LZ+(K-1))*LX+(I-1))*NMY+IEL + JOF=(((M1-1)*LZ+(K-1))*LX+(I-1))*NMY+IEL + FUNKNO(LFLX+LXNI+IOF,IG)=FUNKNO(LFLX+LXNI+JOF,IG) + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + ! Z-BOUNDARY + IF(VZ.GT.0.0)THEN + M1=MRMZ(M) + IF(NCODE(5).NE.4)THEN + DO IEL=1,NMZ + DO I=1,LX + DO J=1,LY + IOF=(((M-1)*LY+(J-1))*LX+(I-1))*NMZ+IEL + JOF=(((M1-1)*LY+(J-1))*LX+(I-1))*NMZ+IEL + E1=FUNKNO(LFLX+LXNI+LXNJ+IOF,IG) + FUNKNO(LFLX+LXNI+LXNJ+IOF,IG)=FUNKNO(LFLX+LXNI+LXNJ+JOF,IG) + FUNKNO(LFLX+LXNI+LXNJ+JOF,IG)=E1 + ENDDO + ENDDO + ENDDO + ENDIF + ELSEIF(VZ.LT.0.0)THEN + M1=MRMZ(M) + IF(NCODE(6).NE.4)THEN + DO IEL=1,NMZ + DO I=1,LX + DO J=1,LY + IOF=(((M-1)*LY+(J-1))*LX+(I-1))*NMZ+IEL + JOF=(((M1-1)*LY+(J-1))*LX+(I-1))*NMZ+IEL + E1=FUNKNO(LFLX+LXNI+LXNJ+IOF,IG) + FUNKNO(LFLX+LXNI+LXNJ+IOF,IG)=FUNKNO(LFLX+LXNI+LXNJ+JOF,IG) + FUNKNO(LFLX+LXNI+LXNJ+JOF,IG)=E1 + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + 140 CONTINUE + 150 CONTINUE + +*$OMP END PARALLEL DO + +*---- +* MAIN SWAPPING LOOPS FOR SN FLUX CALCULATION +*---- + +*$OMP PARALLEL DO +*$OMP+ PRIVATE(ITID,FLUX,M,IG,XNI,XNJ,XNK,Q,Q2,IOF,IER,II,JJ,I,J,K) +*$OMP+ PRIVATE(IPQD,I0,J0,K0,IBM,SIGMA,V,ISFIX,IX,JX,IY,JY,IZ,JZ,IEL) +*$OMP+ PRIVATE(IIX,IIY,IIZ,L) FIRSTPRIVATE(WX,WY,WZ,WX0,WY0,WZ0) +*$OMP+ SHARED(FUNKNO) REDUCTION(+:FLUX_G) COLLAPSE(2) + + ! LOOP FOR GROUPS TO EXECUTE IN PARALLEL + DO 410 IG=1,NGEFF + + ! LOOP OVER ALL DIRECTIONS + DO 400 IPQD=1,NPQD(IND) + IF(.NOT.INCONV(IG)) GO TO 400 + M=INDANG(IPQD,IND) + IF(W(M).EQ.0.0) GO TO 400 + + ! GET AND PRINT THREAD NUMBER +#if defined(_OPENMP) + ITID=omp_get_thread_num() +#else + ITID=0 +#endif + IF(IMPX.GT.5) WRITE(IUNOUT,500) ITID,NGIND(IG),IPQD + + ! INITIALIZE FLUX + FLUX(:NM,:NSCT,:LX,:LY,:LZ)=0.0D0 + +*---- +* LOOP OVER X-, Y- AND Z-DIRECTED AXES. +*---- + + ! X-AXIS LOOP + DO 350 I0=1,LX + I=I0 + IF((IND.EQ.2).OR.(IND.EQ.3).OR.(IND.EQ.6).OR.(IND.EQ.7)) I=LX+1-I + + ! Y-AXIS LOOP + DO 310 J0=1,LY + J=J0 + IF((IND.EQ.3).OR.(IND.EQ.4).OR.(IND.EQ.7).OR.(IND.EQ.8)) J=LY+1-J + + ! Z-BOUNDARIES CONDITIONS + XNK=0.0 + DO IEL=1,NMZ + IOF=(((M-1)*LY+(J-1))*LX+(I-1))*NMZ+IEL + IF((IND.EQ.1).OR.(IND.EQ.2).OR.(IND.EQ.3).OR.(IND.EQ.4)) THEN + XNK(IEL)=FUNKNO(LFLX+LXNI+LXNJ+IOF,IG)*ZCODE(5) + ELSE + XNK(IEL)=FUNKNO(LFLX+LXNI+LXNJ+IOF,IG)*ZCODE(6) + ENDIF + ENDDO + + ! Z-BOUNDARIES FIXED SOURCES + IF(ISBS.EQ.1) THEN + IF(((IND.EQ.5).OR.(IND.EQ.6).OR.(IND.EQ.7).OR.(IND.EQ.8)) + 1 .AND.ISBSM(6,M,IG).NE.0) THEN + XNK(1)=XNK(1)+BS((I-1)*LY+J,ISBSM(6,M,IG)) + ELSEIF(((IND.EQ.1).OR.(IND.EQ.2).OR.(IND.EQ.3).OR.(IND.EQ.4)) + 1 .AND.ISBSM(5,M,IG).NE.0) THEN + XNK(1)=XNK(1)+BS((I-1)*LY+J,ISBSM(5,M,IG)) + ENDIF + ENDIF + + ! Z-AXIS LOOP + DO 280 K0=1,LZ + K=K0 + IF((IND.EQ.5).OR.(IND.EQ.6).OR.(IND.EQ.7).OR.(IND.EQ.8)) K=LZ+1-K + + ! Y-BOUNDARIES CONDITIONS + IF(J0.EQ.1) THEN + XNJ(:NMY,K)=0.0 + DO IEL=1,NMY + IOF=(((M-1)*LZ+(K-1))*LX+(I-1))*NMY+IEL + IF((IND.EQ.1).OR.(IND.EQ.2).OR.(IND.EQ.5).OR.(IND.EQ.6)) THEN + XNJ(IEL,K)=FUNKNO(LFLX+LXNI+IOF,IG)*ZCODE(3) + ELSE + XNJ(IEL,K)=FUNKNO(LFLX+LXNI+IOF,IG)*ZCODE(4) + ENDIF + ENDDO + + !Y-BOUNDARIES FIXED SOURCES + IF(ISBS.EQ.1) THEN + IF(((IND.EQ.3).OR.(IND.EQ.4).OR.(IND.EQ.7).OR.(IND.EQ.8)) + 1 .AND.ISBSM(4,M,IG).NE.0) THEN + XNJ(1,K)=XNJ(1,K)+BS((I-1)*LZ+K,ISBSM(4,M,IG)) + ELSEIF(((IND.EQ.1).OR.(IND.EQ.2).OR.(IND.EQ.5).OR.(IND.EQ.6)) + 1 .AND.ISBSM(3,M,IG).NE.0) THEN + XNJ(1,K)=XNJ(1,K)+BS((I-1)*LZ+K,ISBSM(3,M,IG)) + ENDIF + ENDIF + ENDIF + + ! X-BOUNDARIES CONDITIONS + IF(I0.EQ.1) THEN + XNI(:NMX,J,K)=0.0 + DO IEL=1,NMX + IOF=(((M-1)*LZ+(K-1))*LY+(J-1))*NMX+IEL + IF((IND.EQ.1).OR.(IND.EQ.4).OR.(IND.EQ.5).OR.(IND.EQ.8)) THEN + XNI(IEL,J,K)=FUNKNO(LFLX+IOF,IG)*ZCODE(1) + ELSE + XNI(IEL,J,K)=FUNKNO(LFLX+IOF,IG)*ZCODE(2) + ENDIF + ENDDO + + ! X-BOUNDARIES FIXED SOURCES + IF(ISBS.EQ.1) THEN + IF(((IND.EQ.2).OR.(IND.EQ.3).OR.(IND.EQ.6).OR.(IND.EQ.7)) + 1 .AND.ISBSM(2,M,IG).NE.0) THEN + XNI(1,J,K)=XNI(1,J,K)+BS((J-1)*LZ+K,ISBSM(2,M,IG)) + ELSEIF(((IND.EQ.1).OR.(IND.EQ.4).OR.(IND.EQ.5).OR.(IND.EQ.8)) + 1 .AND.ISBSM(1,M,IG).NE.0) THEN + XNI(1,J,K)=XNI(1,J,K)+BS((J-1)*LZ+K,ISBSM(1,M,IG)) + ENDIF + ENDIF + ENDIF + + ! DATA + IBM=MAT(I,J,K) + IF(IBM.EQ.0) GO TO 280 + SIGMA=TOTAL(IBM,IG) + V=VOL(I,J,K) + + ! SOURCE DENSITY TERM + DO IEL=1,NM + Q(IEL)=0.0D0 + DO P=1,NSCT + IOF=((((K-1)*LY+(J-1))*LX+(I-1))*NSCT+(P-1))*NM+IEL + Q(IEL)=Q(IEL)+QEXT(IOF,IG)*MN(M,P) + ENDDO + ENDDO + + ISFIX=.FALSE. + DO WHILE (.NOT.ALL(ISFIX)) ! LOOP FOR ADAPTIVE CALCULATION + + ! FLUX MOMENT COEFFICIENTS MATRIX + Q2(:NM,:NM+1)=0.0D0 + + DO IZ=1,IELEM + DO JZ=1,IELEM + DO IY=1,IELEM + DO JY=1,IELEM + DO IX=1,IELEM + DO JX=1,IELEM + + II=IELEM**2*(IZ-1)+IELEM*(IY-1)+IX + JJ=IELEM**2*(JZ-1)+IELEM*(JY-1)+JX + + ! DIAGONAL TERMS + IF(II.EQ.JJ) THEN + Q2(II,JJ)=SIGMA*V + 1 +CST(IX)**2*WX(JX+1)*ABS(DA(J,K,M)) + 2 +CST(IY)**2*WY(JY+1)*ABS(DB(I,K,M)) + 3 +CST(IZ)**2*WZ(JZ+1)*ABS(DC(I,J,M)) + + ! UPPER DIAGONAL TERMS + ELSEIF(II.LT.JJ) THEN + IF(IZ.EQ.JZ) THEN + IF(IY.EQ.JY) THEN + ! X-SPACE TERMS + IF(MOD(IX+JX,2).EQ.1) THEN + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*DA(J,K,M) + ELSE + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*ABS(DA(J,K,M)) + ENDIF + ELSEIF(IX.EQ.JX) THEN + ! Y-SPACE TERMS + IF(MOD(IY+JY,2).EQ.1) THEN + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*DB(I,K,M) + ELSE + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ABS(DB(I,K,M)) + ENDIF + ENDIF + ELSEIF(IY.EQ.JY.AND.IX.EQ.JX) THEN + ! Z-SPACE TERMS + IF(MOD(IZ+JZ,2).EQ.1) THEN + Q2(II,JJ)=CST(IZ)*CST(JZ)*WZ(JZ+1)*DC(I,J,M) + ELSE + Q2(II,JJ)=CST(IZ)*CST(JZ)*WZ(JZ+1)*ABS(DC(I,J,M)) + ENDIF + ENDIF + + ! UNDER DIAGONAL TERMS + ELSE + IF(IZ.EQ.JZ) THEN + IF(IY.EQ.JY) THEN + ! X-SPACE TERMS + IF(MOD(IX+JX,2).EQ.1) THEN + Q2(II,JJ)=CST(IX)*CST(JX)*(WX(JX+1)-2)*DA(J,K,M) + ELSE + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*ABS(DA(J,K,M)) + ENDIF + ELSEIF(IX.EQ.JX) THEN + ! Y-SPACE TERMS + IF(MOD(IY+JY,2).EQ.1) THEN + Q2(II,JJ)=CST(IY)*CST(JY)*(WY(JY+1)-2)*DB(I,K,M) + ELSE + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ABS(DB(I,K,M)) + ENDIF + ENDIF + ELSEIF(IY.EQ.JY.AND.IX.EQ.JX) THEN + ! Z-SPACE TERMS + IF(MOD(IZ+JZ,2).EQ.1) THEN + Q2(II,JJ)=CST(IZ)*CST(JZ)*(WZ(JZ+1)-2)*DC(I,J,M) + ELSE + Q2(II,JJ)=CST(IZ)*CST(JZ)*WZ(JZ+1)*ABS(DC(I,J,M)) + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + + ! FLUX SOURCE VECTOR + DO IZ=1,IELEM + DO IY=1,IELEM + DO IX=1,IELEM + II=IELEM**2*(IZ-1)+IELEM*(IY-1)+IX + IIX=IELEM*(IZ-1)+IY + IIY=IELEM*(IZ-1)+IX + IIZ=IELEM*(IY-1)+IX + Q2(II,NM+1)=Q(II)*V + ! X-SPACE TERMS + IF(MOD(IX,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IX)*(1-WX(1)) + 1 *XNI(IIX,J,K)*ABS(DA(J,K,M)) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IX)*(1+WX(1)) + 1 *XNI(IIX,J,K)*DA(J,K,M) + ENDIF + ! Y-SPACE TERMS + IF(MOD(IY,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IY)*(1-WY(1)) + 1 *XNJ(IIY,K)*ABS(DB(I,K,M)) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IY)*(1+WY(1)) + 1 *XNJ(IIY,K)*DB(I,K,M) + ENDIF + ! Z-SPACE TERMS + IF(MOD(IZ,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IZ)*(1-WZ(1)) + 1 *XNK(IIZ)*ABS(DC(I,J,M)) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IZ)*(1+WZ(1)) + 1 *XNK(IIZ)*DC(I,J,M) + ENDIF + ENDDO + ENDDO + ENDDO + + CALL ALSBD(NM,1,Q2,IER,NM) + IF(IER.NE.0) CALL XABORT('SNFE2D: SINGULAR MATRIX.') + + ! ADAPTIVE CORRECTION OF WEIGHTING PARAMETERS + IF(ANY(ISADPT)) THEN + IF(ISADPT(1)) THEN + CALL SNADPT(IELEM,NM,IELEM**2,Q2(1:IELEM:1,NM+1), + 1 XNI(:NMX,J,K),1.0,WX,ISFIX(1)) + ELSE + ISFIX(1)=.TRUE. + ENDIF + IF(ISADPT(2)) THEN + CALL SNADPT(IELEM,NM,IELEM**2,Q2(1:IELEM**2:IELEM,NM+1), + 1 XNJ(:NMY,K),1.0,WY,ISFIX(2)) + ELSE + ISFIX(2)=.TRUE. + ENDIF + IF(ISADPT(3)) THEN + CALL SNADPT(IELEM,NM,IELEM**2,Q2(1:NM:IELEM**2,NM+1), + 1 XNK,1.0,WZ,ISFIX(3)) + ELSE + ISFIX(3)=.TRUE. + ENDIF + ELSE + ISFIX=.TRUE. + ENDIF + + END DO ! END OF ADAPTIVE LOOP + + ! CLOSURE RELATIONS + IF(IELEM.EQ.1.AND.LFIXUP.AND.(Q2(1,2).LE.RLOG)) Q2(1,2)=0.0 + XNI(:NMX,J,K)=WX(1)*XNI(:NMX,J,K) + XNJ(:NMY,K)=WY(1)*XNJ(:NMY,K) + XNK(:NMZ)=WZ(1)*XNK(:NMZ) + DO IZ=1,IELEM + DO IY=1,IELEM + DO IX=1,IELEM + II=IELEM**2*(IZ-1)+IELEM*(IY-1)+IX + IIX=IELEM*(IZ-1)+IY + IIY=IELEM*(IZ-1)+IX + IIZ=IELEM*(IY-1)+IX + ! X-SPACE + IF(MOD(IX,2).EQ.1) THEN + XNI(IIX,J,K)=XNI(IIX,J,K)+CST(IX)*WX(IX+1) + 1 *Q2(II,NM+1) + ELSE + XNI(IIX,J,K)=XNI(IIX,J,K)+CST(IX)*WX(IX+1) + 1 *Q2(II,NM+1)*SIGN(1.0,DA(J,K,M)) + ENDIF + ! Y-SPACE + IF(MOD(IY,2).EQ.1) THEN + XNJ(IIY,K)=XNJ(IIY,K)+CST(IY)*WY(IY+1) + 1 *Q2(II,NM+1) + ELSE + XNJ(IIY,K)=XNJ(IIY,K)+CST(IY)*WY(IY+1) + 1 *Q2(II,NM+1)*SIGN(1.0,DB(I,K,M)) + ENDIF + ! Z-SPACE + IF(MOD(IZ,2).EQ.1) THEN + XNK(IIZ)=XNK(IIZ)+CST(IZ)*WZ(IZ+1) + 1 *Q2(II,NM+1) + ELSE + XNK(IIZ)=XNK(IIZ)+CST(IZ)*WZ(IZ+1) + 1 *Q2(II,NM+1)*SIGN(1.0,DC(I,J,M)) + ENDIF + ENDDO + ENDDO + ENDDO + IF(IELEM.EQ.1.AND.LFIXUP.AND.(XNI(1,J,K).LE.RLOG)) + 1 XNI(1,J,K)=0.0 + IF(IELEM.EQ.1.AND.LFIXUP.AND.(XNJ(1,K).LE.RLOG)) + 1 XNJ(1,K)=0.0 + IF(IELEM.EQ.1.AND.LFIXUP.AND.(XNK(1).LE.RLOG)) XNK(1)=0.0 + WX=WX0 + WY=WY0 + WZ=WZ0 + + ! SAVE LEGENDRE MOMENT OF THE FLUX + DO P=1,NSCT + DO IEL=1,NM + FLUX(IEL,P,I,J,K)=FLUX(IEL,P,I,J,K)+Q2(IEL,NM+1)*DN(P,M) + ENDDO + ENDDO + + 280 CONTINUE ! END OF Z-LOOP + + ! SAVE BOUNDARY CONDITIONS + DO IEL=1,NMZ + IOF=(((M-1)*LY+(J-1))*LX+(I-1))*NMZ+IEL + FUNKNO(LFLX+LXNI+LXNJ+IOF,IG)=REAL(XNK(IEL)) + ENDDO + + 310 CONTINUE ! END OF Y-LOOP + + ! SAVE BOUNDARY CONDITIONS + DO K=1,LZ + DO IEL=1,NMY + IOF=(((M-1)*LZ+(K-1))*LX+(I-1))*NMY+IEL + FUNKNO(LFLX+LXNI+IOF,IG)=REAL(XNJ(IEL,K)) + ENDDO + ENDDO + + 350 CONTINUE ! END OF X-LOOP + + ! SAVE BOUNDARY CONDITIONS + DO K=1,LZ + DO J=1,LY + DO IEL=1,NMX + IOF=(((M-1)*LZ+(K-1))*LY+(J-1))*NMX+IEL + FUNKNO(LFLX+IOF,IG)=REAL(XNI(IEL,J,K)) + ENDDO + ENDDO + ENDDO + + ! SAVE FLUX INFORMATION + FLUX_G(:,:,:,:,:,IG)=FLUX_G(:,:,:,:,:,IG)+FLUX(:,:,:,:,:) + + 400 CONTINUE ! END OF DIRECTION LOOP + 410 CONTINUE ! END OF ENERGY LOOP +*$OMP END PARALLEL DO + 420 CONTINUE ! END OF OCTANT LOOP + + ! SAVE FLUX INFORMATION + DO 430 IG=1,NGEFF + IF(.NOT.INCONV(IG)) GO TO 430 + FUNKNO(:LFLX,IG)= + 1 RESHAPE(REAL(FLUX_G(:NM,:NSCT,:LX,:LY,:LZ,IG)), + 2 (/LFLX/)) + 430 CONTINUE + +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(FLUX_G,FLUX,XNJ,XNI,INDANG) + RETURN + 500 FORMAT(16H SNFP13: thread=,I8,12H --->(group=,I4,7H angle=,I4,1H)) + END diff --git a/Dragon/src/SNFKC2.F b/Dragon/src/SNFKC2.F new file mode 100644 index 0000000..c95de6b --- /dev/null +++ b/Dragon/src/SNFKC2.F @@ -0,0 +1,562 @@ +*DECK SNFKC2 + SUBROUTINE SNFKC2(NKBA,NUN,NGEFF,IMPX,INCONV,NGIND,LX,LY,IELEM, + 1 NM,NMX,NMY,NMAT,NPQ,NSCT,MAT,VOL,TOTAL,NCODE,ZCODE,QEXT,LFIXUP, + 2 DU,DE,W,MRM,MRMY,DB,DA,MN,DN,WX,WY,CST,ISADPT,ISBS,NBS,ISBSM,BS, + 3 MAXL,FUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform one inner iteration for solving SN equations in 2D Cartesian +* geometry for the HODD method. KBA-like multithreading. Albedo +* boundary conditions. Boltzmann (BTE) discretization. +* +*Copyright: +* Copyright (C) 2025 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert, A. A. Calloo and C. Bienvenue +* +*Parameters: input +* NKBA number of macrocells along each axis +* NUN total number of unknowns in vector FUNKNO. +* NGEFF number of energy groups processed in parallel. +* IMPX print flag (equal to zero for no print). +* INCONV energy group convergence flag (set to .FALSE. if converged). +* NGIND energy group indices assign to the NGEFF set. +* LX number of meshes along X axis. +* LY number of meshes along Y axis. +* IELEM measure of order of the spatial approximation polynomial: +* =1 constant - default for HODD; +* =2 linear - default for DG; +* >3 higher orders. +* NM number of moments in space and energy for flux components +* NMX number of moments for X axis boundaries components +* NMY number of moments for Y axis boundaries components +* NMAT number of material mixtures. +* NPQ number of SN directions in four octants (including zero-weight +* directions). +* NSCT maximum number of spherical harmonics moments of the flux. +* MAT material mixture index in each region. +* VOL volumes of each region. +* TOTAL macroscopic total cross sections. +* NCODE boundary condition indices. +* ZCODE albedos. +* QEXT Legendre components of the fixed source. +* LFIXUP flag to enable negative flux fixup. +* DU first direction cosines ($\\mu$). +* DE second direction cosines ($\\eta$). +* W weights. +* MRM quadrature index. +* MRMY quadrature index. +* DB diamond-scheme parameter. +* DA diamond-scheme parameter. +* MN moment-to-discrete matrix. +* DN discrete-to-moment matrix. +* ISBS flag to indicate the presence or not of boundary fixed +* sources. +* NBS number of boundary fixed sources. +* ISBSM flag array to indicate the presence or not of boundary fixed +* source in each unit surface. +* BS boundary source array with their intensities. +* MAXL maximum size of boundary source array. +* WX spatial X axis closure relation weighting factors. +* WY spatial Y axis closure relation weighting factors. +* CST constants for the polynomial approximations. +* ISADPT flag to enable/disable adaptive flux calculations. +* +*Parameters: input/output +* FUNKNO Legendre components of the flux and boundary fluxes. +* FLUXC flux at the cutoff energy. +* +*----------------------------------------------------------------------- +#if defined(_OPENMP) + USE omp_lib +#endif +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NKBA,NUN,NGEFF,IMPX,NGIND(NGEFF),LX,LY,IELEM,NM,NMX,NMY, + 1 NMAT,NPQ,NSCT,MAT(LX,LY),NCODE(4),MRM(NPQ),MRMY(NPQ),ISBS,NBS, + 2 ISBSM(4*ISBS,NPQ*ISBS,NGEFF*ISBS),MAXL + LOGICAL INCONV(NGEFF) + REAL VOL(LX,LY),TOTAL(0:NMAT,NGEFF),ZCODE(4),QEXT(NUN,NGEFF), + 1 DU(NPQ),DE(NPQ),W(NPQ),DB(LX,NPQ),DA(LX,LY,NPQ), + 2 FUNKNO(NUN,NGEFF),BS(MAXL*ISBS,NBS*ISBS),WX(IELEM+1), + 3 WY(IELEM+1),CST(IELEM),MN(NPQ,NSCT),DN(NSCT,NPQ) + LOGICAL LFIXUP,ISADPT(2) +*---- +* LOCAL VARIABLES +*---- + INTEGER NPQD(4),IIND(4),P + REAL WX0(IELEM+1),WY0(IELEM+1) + DOUBLE PRECISION Q(NM),Q2(NM,NM+1),V + PARAMETER(IUNOUT=6,RLOG=1.0E-8,PI=3.141592654) + LOGICAL ISFIX(2) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: INDANG + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: FLUX + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: FLUX_G + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:) :: XNI,XNJ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(INDANG(NPQ,4)) + ALLOCATE(FLUX(NM,NSCT)) + ALLOCATE(FLUX_G(NM,NSCT,LX,LY,NGEFF)) + ALLOCATE(XNI(IELEM,LY,NPQ,NGEFF),XNJ(IELEM,LX,NPQ,NGEFF)) +*---- +* LENGTH OF FUNKNO COMPONENTS (IN ORDER) +*---- + LFLX=NM*LX*LY*NSCT + LXNI=NMX*LY*NPQ + LXNJ=NMY*LX*NPQ +*---- +* NUMBER OF MACROCELLS (MACRO*) +* NUMBER OF LZ LAYERS IN EACH MACROCELL (NCELL*) +*---- + MACROX=NKBA + MACROY=NKBA + NCELLX=1+(LX-1)/MACROX + NCELLY=1+(LY-1)/MACROY +*---- +* SET OCTANT SWAPPING ORDER. +*---- + NPQD(:4)=0 + INDANG(:NPQ,:4)=0 + IIND(:)=0 + DO M=1,NPQ + VU=DU(M) + VE=DE(M) + IF(W(M).EQ.0) CYCLE + IF((VU.GE.0.0).AND.(VE.GE.0.0)) THEN + IND=1 + JND=4 + ELSE IF((VU.LE.0.0).AND.(VE.GE.0.0)) THEN + IND=2 + JND=3 + ELSE IF((VU.LE.0.0).AND.(VE.LE.0.0)) THEN + IND=3 + JND=1 + ELSE + IND=4 + JND=2 + ENDIF + IIND(JND)=IND + NPQD(IND)=NPQD(IND)+1 + INDANG(NPQD(IND),IND)=M + ENDDO +*---- +* MAIN LOOP OVER OCTANTS. +*---- + + FLUX_G(:NM,:NSCT,:LX,:LY,:NGEFF)=0.0D0 + WX0=WX + WY0=WY + + DO 240 JND=1,4 + IND=IIND(JND) +*---- +* PRELIMINARY LOOPS FOR SETTING BOUNDARY CONDITIONS. +*---- + +*$OMP PARALLEL DO +*$OMP+ PRIVATE(M,IG,VU,VE,M1,IOF,JOF,IEL,I,J,IPQD) +*$OMP+ SHARED(FUNKNO) COLLAPSE(2) + + DO 70 IG=1,NGEFF + DO 60 IPQD=1,NPQD(IND) + IF(.NOT.INCONV(IG)) GO TO 60 + M=INDANG(IPQD,IND) + VU=DU(M) + VE=DE(M) + ! X-BOUNDARY + IF(VU.GT.0.0)THEN + M1=MRM(M) + IF((NCODE(1).NE.4))THEN + DO IEL=1,NMX + DO J=1,LY + IOF=((M-1)*LY+(J-1))*NMX+IEL + JOF=((M1-1)*LY+(J-1))*NMX+IEL + FUNKNO(LFLX+IOF,IG)=FUNKNO(LFLX+JOF,IG) + ENDDO + ENDDO + ENDIF + ELSEIF(VU.LT.0.0)THEN + M1=MRM(M) + IF((NCODE(2).NE.4))THEN + DO IEL=1,NMX + DO J=1,LY + IOF=((M-1)*LY+(J-1))*NMX+IEL + JOF=((M1-1)*LY+(J-1))*NMX+IEL + FUNKNO(LFLX+IOF,IG)=FUNKNO(LFLX+JOF,IG) + ENDDO + ENDDO + ENDIF + ENDIF + ! Y-BOUNDARY + IF(VE.GT.0.0)THEN + M1=MRMY(M) + IF((NCODE(3).NE.4))THEN + DO IEL=1,NMY + DO I=1,LX + IOF=((M-1)*LX+(I-1))*NMY+IEL + JOF=((M1-1)*LX+(I-1))*NMY+IEL + FUNKNO(LFLX+LXNI+IOF,IG)= + > FUNKNO(LFLX+LXNI+JOF,IG) + ENDDO + ENDDO + ENDIF + ELSEIF(VE.LT.0.0)THEN + M1=MRMY(M) + IF((NCODE(4).NE.4))THEN + DO IEL=1,NMY + DO I=1,LX + IOF=((M-1)*LX+(I-1))*NMY+IEL + JOF=((M1-1)*LX+(I-1))*NMY+IEL + FUNKNO(LFLX+LXNI+IOF,IG)= + > FUNKNO(LFLX+LXNI+JOF,IG) + ENDDO + ENDDO + ENDIF + ENDIF + 60 CONTINUE + 70 CONTINUE + +*OMP END PARALLEL DO + +*---- +* KBA DIAGONAL LOOP +*---- + XNI(:IELEM,:LY,:NPQ,:NGEFF)=0.0D0 + XNJ(:IELEM,:LX,:NPQ,:NGEFF)=0.0D0 + DO 230 IDI=1,MACROX+MACROY-1 + +*---- +* MAIN SWAPPING LOOPS FOR SN FLUX CALCULATION +*---- + +*$OMP PARALLEL DO +*$OMP+ PRIVATE(ITID,FLUX,M,IG,Q,Q2,IOF,IER,II,JJ,IEL,I,J,P) +*$OMP+ PRIVATE(IPQD,IMX,IMY,IBM,SIGMA,V,ISFIX,IX,JX,IY,JY,JCEL) +*$OMP+ FIRSTPRIVATE(WX,WY,WX0,WY0) SHARED(FUNKNO,XNI,XNJ) +*$OMP+ REDUCTION(+:FLUX_G) COLLAPSE(3) + + ! LOOP FOR GROUPS TO EXECUTE IN PARALLEL + DO 220 IG=1,NGEFF + + ! LOOP OVER ALL DIRECTIONS + DO 210 IPQD=1,NPQD(IND) + + ! LOOP OVER MACROCELLS IN WAVEFRONT + DO 200 ICEL=MAX(1,IDI-MACROY+1),MIN(MACROX,IDI) + + IF(.NOT.INCONV(IG)) GO TO 200 + M=INDANG(IPQD,IND) + IF(W(M).EQ.0.0) GO TO 200 + + ! GET AND PRINT THREAD NUMBER +#if defined(_OPENMP) + ITID=omp_get_thread_num() +#else + ITID=0 +#endif + IF(IMPX.GT.5) WRITE(IUNOUT,400) ITID,NGIND(IG),IPQD + +*---- +* LOOP OVER X- AND Y-DIRECTED AXES. +*---- + JCEL=IDI-ICEL+1 + + ! X-BOUNDARIES CONDITIONS + IF(ICEL.EQ.1) THEN + DO IMY=1,MIN(NCELLY,LY-(JCEL-1)*NCELLY) + J=(JCEL-1)*NCELLY+IMY + IF((IND.EQ.3).OR.(IND.EQ.4)) J=LY+1-J + DO IEL=1,NMX + IOF=(M-1)*NMX*LY+(J-1)*NMX+IEL + IF((IND.EQ.1).OR.(IND.EQ.4)) THEN + XNI(IEL,J,IPQD,IG)=FUNKNO(LFLX+IOF,IG)*ZCODE(1) + ELSE + XNI(IEL,J,IPQD,IG)=FUNKNO(LFLX+IOF,IG)*ZCODE(2) + ENDIF + ENDDO + + ! X-BOUNDARIES FIXED SOURCES + IF(ISBS.EQ.1) THEN + IF((IND.EQ.2.OR.IND.EQ.3).AND.ISBSM(2,M,IG).NE.0) THEN + XNI(1,J,IPQD,IG)=XNI(1,J,IPQD,IG)+BS(J,ISBSM(2,M,IG)) + ELSE IF((IND.EQ.1.OR.IND.EQ.4).AND.ISBSM(1,M,IG).NE.0) THEN + XNI(1,J,IPQD,IG)=XNI(1,J,IPQD,IG)+BS(J,ISBSM(1,M,IG)) + ENDIF + ENDIF + ENDDO + ENDIF + + ! Y-BOUNDARIES CONDITIONS + IF(JCEL.EQ.1) THEN + DO IMX=1,MIN(NCELLX,LX-(ICEL-1)*NCELLX) + I=(ICEL-1)*NCELLX+IMX + IF((IND.EQ.2).OR.(IND.EQ.3)) I=LX+1-I + DO IEL=1,NMY + IOF=(M-1)*NMY*LX+(I-1)*NMY+IEL + IF((IND.EQ.1).OR.(IND.EQ.2)) THEN + XNJ(IEL,I,IPQD,IG)=FUNKNO(LFLX+LXNI+IOF,IG)*ZCODE(3) + ELSE + XNJ(IEL,I,IPQD,IG)=FUNKNO(LFLX+LXNI+IOF,IG)*ZCODE(4) + ENDIF + ENDDO + + ! Y-BOUNDARIES FIXED SOURCES + IF(ISBS.EQ.1) THEN + IF((IND.EQ.3.OR.IND.EQ.4).AND.ISBSM(4,M,IG).NE.0) THEN + XNJ(1,I,IPQD,IG)=XNJ(1,I,IPQD,IG)+BS(I,ISBSM(4,M,IG)) + ELSE IF((IND.EQ.1.OR.IND.EQ.2).AND.ISBSM(3,M,IG).NE.0) THEN + XNJ(1,I,IPQD,IG)=XNJ(1,I,IPQD,IG)+BS(I,ISBSM(3,M,IG)) + ENDIF + ENDIF + ENDDO + ENDIF + + ! X-AXIS LOOP + DO 190 IMX=1,MIN(NCELLX,LX-(ICEL-1)*NCELLX) + I=(ICEL-1)*NCELLX+IMX + IF((IND.EQ.2).OR.(IND.EQ.3)) I=LX+1-I + + ! Y-AXIS LOOP + DO 180 IMY=1,MIN(NCELLY,LY-(JCEL-1)*NCELLY) + J=(JCEL-1)*NCELLY+IMY + IF((IND.EQ.3).OR.(IND.EQ.4)) J=LY+1-J + + ! INITIALIZE FLUXES + FLUX(:NM,:NSCT)=0.0D0 + + ! IF(ITID.EQ.1)THEN + ! WRITE(*,*) 'I,J', JCEL, NCELLY, IMY + ! WRITE(*,*) IND, IPQD, I, J + ! WRITE(*,*) XNI(:,J,IPQD,IG) + ! WRITE(*,*) XNJ(:,I,IPQD,IG) + ! ENDIF + + ! DATA + IBM=MAT(I,J) + IF(IBM.EQ.0) GO TO 200 + SIGMA=TOTAL(IBM,IG) + V=VOL(I,J) + + ! SOURCE DENSITY TERM + DO IEL=1,NM + Q(IEL)=0.0D0 + DO P=1,NSCT + IOF=((J-1)*LX*NSCT+(I-1)*NSCT+(P-1))*NM+IEL + Q(IEL)=Q(IEL)+QEXT(IOF,IG)*MN(M,P) + ENDDO + ENDDO + + ISFIX=.FALSE. + DO WHILE (.NOT.ALL(ISFIX)) ! LOOP FOR ADAPTIVE CALCULATION + + ! FLUX MOMENT COEFFICIENTS MATRIX + Q2(:NM,:NM+1)=0.0D0 + + DO IY=1,IELEM + DO JY=1,IELEM + DO IX=1,IELEM + DO JX=1,IELEM + II=IELEM*(IY-1)+IX + JJ=IELEM*(JY-1)+JX + + ! DIAGONAL TERMS + IF(II.EQ.JJ) THEN + Q2(II,JJ)=SIGMA*V + 1 +CST(IX)**2*WX(JX+1)*ABS(DA(I,J,M)) + 2 +CST(IY)**2*WY(JY+1)*ABS(DB(I,M)) + + ! UPPER DIAGONAL TERMS + ELSEIF(II.LT.JJ) THEN + ! X-SPACE TERMS + IF(IY.EQ.JY) THEN + IF(MOD(IX+JX,2).EQ.1) THEN + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*DA(I,J,M) + ELSE + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*ABS(DA(I,J,M)) + ENDIF + ! Y-SPACE TERMS + ELSEIF(IX.EQ.JX) THEN + IF(MOD(IY+JY,2).EQ.1) THEN + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*DB(I,M) + ELSE + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ABS(DB(I,M)) + ENDIF + ENDIF + + ! UNDER DIAGONAL TERMS + ELSE + ! X-SPACE TERMS + IF(IY.EQ.JY) THEN + IF(MOD(IX+JX,2).EQ.1) THEN + Q2(II,JJ)=CST(IX)*CST(JX)*(WX(JX+1)-2)*DA(I,J,M) + ELSE + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*ABS(DA(I,J,M)) + ENDIF + ! Y-SPACE TERMS + ELSEIF(IX.EQ.JX) THEN + IF(MOD(IY+JY,2).EQ.1) THEN + Q2(II,JJ)=CST(IY)*CST(JY)*(WY(JY+1)-2)*DB(I,M) + ELSE + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ABS(DB(I,M)) + ENDIF + ENDIF + + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + + ! FLUX SOURCE VECTOR + DO IY=1,IELEM + DO IX=1,IELEM + II=IELEM*(IY-1)+IX + Q2(II,NM+1)=Q(II)*V + ! X-SPACE TERMS + IF(MOD(IX,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IX)*(1-WX(1)) + 1 *XNI(IY,J,IPQD,IG)*ABS(DA(I,J,M)) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IX)*(1+WX(1)) + 1 *XNI(IY,J,IPQD,IG)*DA(I,J,M) + ENDIF + ! Y-SPACE TERMS + IF(MOD(IY,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IY)*(1-WY(1)) + 1 *XNJ(IX,I,IPQD,IG)*ABS(DB(I,M)) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IY)*(1+WY(1)) + 1 *XNJ(IX,I,IPQD,IG)*DB(I,M) + ENDIF + ENDDO + ENDDO + + CALL ALSBD(NM,1,Q2,IER,NM) + IF(IER.NE.0) CALL XABORT('SNFKC2: SINGULAR MATRIX.') + + ! IF(ITID.EQ.1)THEN + ! WRITE(*,*) 'I,J' + ! WRITE(*,*) Q2(:,NM+1) + ! WRITE(*,*) ' ' + ! WRITE(*,*) ' ' + ! WRITE(*,*) ' ' + ! WRITE(*,*) ' ' + ! ENDIF + + ! ADAPTIVE CORRECTION OF WEIGHTING PARAMETERS + IF(ANY(ISADPT)) THEN + IF(ISADPT(1)) THEN + CALL SNADPT(IELEM,NM,IELEM,Q2(1:IELEM:1,NM+1), + 1 XNI(:NMX,J,IPQD,IG),1.0,WX,ISFIX(1)) + ELSE + ISFIX(1)=.TRUE. + ENDIF + IF(ISADPT(2)) THEN + CALL SNADPT(IELEM,NM,IELEM,Q2(1:NM:IELEM,NM+1), + 1 XNJ(:NMY,I,IPQD,IG),1.0,WY,ISFIX(2)) + ELSE + ISFIX(2)=.TRUE. + ENDIF + ELSE + ISFIX=.TRUE. + ENDIF + + END DO ! END OF ADAPTIVE LOOP + + ! CLOSURE RELATIONS + IF(IELEM.EQ.1.AND.LFIXUP.AND.(Q2(1,2).LE.RLOG)) Q2(1,2)=0.0 + XNI(:NMX,J,IPQD,IG)=WX(1)*XNI(:NMX,J,IPQD,IG) + XNJ(:NMY,I,IPQD,IG)=WY(1)*XNJ(:NMY,I,IPQD,IG) + DO IY=1,IELEM + DO IX=1,IELEM + II=IELEM*(IY-1)+IX + ! X-SPACE + IF(MOD(IX,2).EQ.1) THEN + XNI(IY,J,IPQD,IG)=XNI(IY,J,IPQD,IG)+CST(IX)*WX(IX+1) + 1 *Q2(II,NM+1) + ELSE + XNI(IY,J,IPQD,IG)=XNI(IY,J,IPQD,IG)+CST(IX)*WX(IX+1) + 1 *Q2(II,NM+1)*SIGN(1.0,DA(I,J,M)) + ENDIF + ! Y-SPACE + IF(MOD(IY,2).EQ.1) THEN + XNJ(IX,I,IPQD,IG)=XNJ(IX,I,IPQD,IG)+CST(IY)*WY(IY+1) + 1 *Q2(II,NM+1) + ELSE + XNJ(IX,I,IPQD,IG)=XNJ(IX,I,IPQD,IG)+CST(IY)*WY(IY+1) + 1 *Q2(II,NM+1)*SIGN(1.0,DB(I,M)) + ENDIF + ENDDO + ENDDO + IF(IELEM.EQ.1.AND.LFIXUP.AND.(XNI(1,J,IPQD,IG).LE.RLOG)) + 1 XNI(1,J,IPQD,IG)=0.0 + IF(IELEM.EQ.1.AND.LFIXUP.AND.(XNJ(1,I,IPQD,IG).LE.RLOG)) + 1 XNJ(1,I,IPQD,IG)=0.0 + WX=WX0 + WY=WY0 + + ! SAVE LEGENDRE MOMENT OF THE FLUX + DO P=1,NSCT + DO IEL=1,NM + FLUX(IEL,P)=FLUX(IEL,P)+Q2(IEL,NM+1)*DN(P,M) + ENDDO + ENDDO + + ! SAVE X-BOUNDARY CONDITIONS + IF((ICEL-1)*NCELLX+IMX.EQ.LX) THEN + DO IEL=1,NMX + IOF=(M-1)*NMX*LY+(J-1)*NMX+IEL + FUNKNO(LFLX+IOF,IG)=REAL(XNI(IEL,J,IPQD,IG)) + ENDDO + ENDIF + + ! SAVE Y-BOUNDARY CONDITIONS + IF((JCEL-1)*NCELLY+IMY.EQ.LY) THEN + DO IEL=1,NMY + IOF=(M-1)*NMY*LX+(I-1)*NMY+IEL + FUNKNO(LFLX+LXNI+IOF,IG)=REAL(XNJ(IEL,I,IPQD,IG)) + ENDDO + ENDIF + + ! SAVE FLUX INFORMATION + FLUX_G(:,:,I,J,IG)=FLUX_G(:,:,I,J,IG)+FLUX(:,:) + + 180 CONTINUE ! END OF Y-LOOP + 190 CONTINUE ! END OF X-LOOP + + 200 CONTINUE ! END OF MACROCELL LOOP + 210 CONTINUE ! END OF DIRECTION LOOP + 220 CONTINUE ! END OF ENERGY LOOP +*$OMP END PARALLEL DO + 230 CONTINUE ! END OF WAVEFRONT LOOP + 240 CONTINUE ! END OF OCTANT LOOP + + ! SAVE FLUX INFORMATION + DO 250 IG=1,NGEFF + IF(.NOT.INCONV(IG)) GO TO 250 + FUNKNO(:LFLX,IG)= + 1 RESHAPE(REAL(FLUX_G(:NM,:NSCT,:LX,:LY,IG)),(/ LFLX /) ) + 250 CONTINUE + + ! CALL XABORT('SNFKC2: testing') + +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XNI,XNJ,FLUX_G,FLUX,INDANG) + RETURN + 400 FORMAT(16H SNFKC2: thread=,I8,12H --->(group=,I4,7H angle=,I4,1H)) + END diff --git a/Dragon/src/SNFKC3.F b/Dragon/src/SNFKC3.F new file mode 100644 index 0000000..c3e83ac --- /dev/null +++ b/Dragon/src/SNFKC3.F @@ -0,0 +1,755 @@ +*DECK SNFKC3 + SUBROUTINE SNFKC3(NKBA,NUN,NGEFF,IMPX,INCONV,NGIND,LX,LY,LZ,IELEM, + 1 NM,NMX,NMY,NMZ,NMAT,NPQ,NSCT,MAT,VOL,TOTAL,NCODE,ZCODE,QEXT, + 2 LFIXUP,DU,DE,DZ,W,MRMX,MRMY,MRMZ,DC,DB,DA,MN,DN,WX,WY,WZ,CST, + 3 ISADPT,ISBS,NBS,ISBSM,BS,MAXL,FUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform one inner iteration for solving SN equations in 3D Cartesian +* geometry for the HODD method. Energy-angle multithreading. Albedo +* boundary conditions. Boltzmann (BTE) discretization. +* +*Copyright: +* Copyright (C) 2025 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert, A. A. Calloo and C. Bienvenue +* +*Parameters: input +* NKBA number of macrocells along each axis +* NUN total number of unknowns in vector FUNKNO. +* NGEFF number of energy groups processed in parallel. +* IMPX print flag (equal to zero for no print). +* INCONV energy group convergence flag (set to .FALSE. if converged). +* NGIND energy group indices assign to the NGEFF set. +* LX number of meshes along X axis. +* LY number of meshes along Y axis. +* LZ number of meshes along Z axis. +* IELEM measure of order of the spatial approximation polynomial: +* =1 constant - default for HODD; +* =2 linear - default for DG; +* >3 higher orders. +* NM number of moments in space for flux components +* NMX number of moments for X axis boundaries components +* NMY number of moments for Y axis boundaries components +* NMZ number of moments for Z axis boundaries components +* NMAT number of material mixtures. +* NPQ number of SN directions in height octants. +* NSCT maximum number of spherical harmonics moments of the flux. +* MAT material mixture index in each region. +* VOL volumes of each region. +* TOTAL macroscopic total cross sections. +* ESTOPW stopping power. +* NCODE boundary condition indices. +* ZCODE albedos. +* DELTAE energy group width in MeV. +* QEXT Legendre components of the fixed source. +* LFIXUP flag to enable negative flux fixup. +* DU first direction cosines ($\\mu$). +* DE second direction cosines ($\\eta$). +* DZ third direction cosines ($\\xi$). +* W weights. +* MRMX quadrature index. +* MRMY quadrature index. +* MRMZ quadrature index. +* DC diamond-scheme parameter. +* DB diamond-scheme parameter. +* DA diamond-scheme parameter. +* MN moment-to-discrete matrix. +* DN discrete-to-moment matrix. +* ISBS flag to indicate the presence or not of boundary fixed +* sources. +* NBS number of boundary fixed sources. +* ISBSM flag array to indicate the presence or not of boundary fixed +* source in each unit surface. +* BS boundary source array with their intensities. +* MAXL maximum size of boundary source array. +* WX spatial X axis closure relation weighting factors. +* WY spatial Y axis closure relation weighting factors. +* WZ spatial Z axis closure relation weighting factors. +* CST constants for the polynomial approximations. +* ISADPT flag to enable/disable adaptive flux calculations. +* +*Parameters: input/output +* FUNKNO Legendre components of the flux and boundary fluxes. +* FLUXC flux at the cutoff energy. +* +*----------------------------------------------------------------------- +* +#if defined(_OPENMP) + USE omp_lib +#endif +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NUN,NGEFF,IMPX,NGIND(NGEFF),LX,LY,LZ,IELEM,NM,NMX,NMY,NMZ, + 1 NMAT,NPQ,NSCT,MAT(LX,LY,LZ),NCODE(6),MRMX(NPQ),MRMY(NPQ), + 2 MRMZ(NPQ),ISBS,NBS,ISBSM(6*ISBS,NPQ*ISBS,NGEFF*ISBS),MAXL + LOGICAL INCONV(NGEFF) + REAL VOL(LX,LY,LZ),TOTAL(0:NMAT,NGEFF),ZCODE(6),QEXT(NUN,NGEFF), + 1 DU(NPQ),DE(NPQ),DZ(NPQ),W(NPQ),DC(LX,LY,NPQ),DB(LX,LZ,NPQ), + 2 DA(LY,LZ,NPQ),FUNKNO(NUN,NGEFF),BS(MAXL*ISBS,NBS*ISBS), + 3 WX(IELEM+1),WY(IELEM+1),WZ(IELEM+1),CST(IELEM),MN(NPQ,NSCT), + 4 DN(NSCT,NPQ) + LOGICAL LFIXUP,ISADPT(3) +*---- +* LOCAL VARIABLES +*---- + INTEGER NPQD(8),IIND(8),P + PARAMETER(IUNOUT=6,RLOG=1.0E-8,PI=3.141592654) + REAL WX0(IELEM+1),WY0(IELEM+1),WZ0(IELEM+1) + DOUBLE PRECISION V,Q(NM),Q2(NM,NM+1) + LOGICAL ISFIX(3) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: III,JJJ + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: INDANG + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: FLUX + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:,:,:) :: FLUX_G + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: XNI,XNJ,XNK +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(INDANG(NPQ,8)) + ALLOCATE(XNI(NMX,LY,LZ,NPQ,NGEFF),XNJ(NMY,LX,LZ,NPQ,NGEFF), + 1 XNK(NMZ,LX,LY,NPQ,NGEFF)) + ALLOCATE(FLUX(NM,NSCT)) + ALLOCATE(FLUX_G(NM,NSCT,LX,LY,LZ,NGEFF)) +*---- +* LENGTH OF FUNKNO COMPONENTS (IN ORDER) +*---- + LFLX=NM*LX*LY*LZ*NSCT + LXNI=NMX*LY*LZ*NPQ + LXNJ=NMY*LX*LZ*NPQ + LXNK=NMZ*LX*LY*NPQ +*---- +* NUMBER OF MACROCELLS (MACRO*) +* NUMBER OF LZ LAYERS IN EACH MACROCELL (NCELL*) +*---- + MACROX=NKBA + MACROY=NKBA + MACROZ=NKBA + NCELLX=1+(LX-1)/MACROX + NCELLY=1+(LY-1)/MACROY + NCELLZ=1+(LZ-1)/MACROZ +*---- +* SET OCTANT SWAPPING ORDER. +*---- + NPQD(:8)=0 + INDANG(:NPQ,:8)=0 + IIND(:)=0 + DO 10 M=1,NPQ + VU=DU(M) + VE=DE(M) + VZ=DZ(M) + IF(W(M).EQ.0) CYCLE + IF((VU.GE.0.0).AND.(VE.GE.0.0).AND.(VZ.GE.0.0)) THEN + IND=1 + JND=8 + ELSE IF((VU.LE.0.0).AND.(VE.GE.0.0).AND.(VZ.GE.0.0)) THEN + IND=2 + JND=7 + ELSE IF((VU.LE.0.0).AND.(VE.LE.0.0).AND.(VZ.GE.0.0)) THEN + IND=3 + JND=5 + ELSE IF((VU.GE.0.0).AND.(VE.LE.0.0).AND.(VZ.GE.0.0)) THEN + IND=4 + JND=6 + ELSE IF((VU.GE.0.0).AND.(VE.GE.0.0).AND.(VZ.LE.0.0)) THEN + IND=5 + JND=4 + ELSE IF((VU.LE.0.0).AND.(VE.GE.0.0).AND.(VZ.LE.0.0)) THEN + IND=6 + JND=3 + ELSE IF((VU.LE.0.0).AND.(VE.LE.0.0).AND.(VZ.LE.0.0)) THEN + IND=7 + JND=1 + ELSE + IND=8 + JND=2 + ENDIF + IIND(JND)=IND + NPQD(IND)=NPQD(IND)+1 + INDANG(NPQD(IND),IND)=M + 10 CONTINUE +*---- +* MAIN LOOP OVER OCTANTS. +*---- + + FLUX_G(:NM,:NSCT,:LX,:LY,:LZ,:NGEFF)=0.0D0 + WX0=WX + WY0=WY + WZ0=WZ + + DO 520 JND=1,8 + IND=IIND(JND) +*---- +* PRELIMINARY LOOPS FOR SETTING BOUNDARY CONDITIONS. +*---- + +*$OMP PARALLEL DO +*$OMP+ PRIVATE(M,IG,VU,VE,VZ,M1,E1,IOF,JOF,IEL,I,J,K,IPQD) +*$OMP+ SHARED(FUNKNO) COLLAPSE(2) + + DO 150 IG=1,NGEFF + DO 140 IPQD=1,NPQD(IND) + IF(.NOT.INCONV(IG)) GO TO 140 + M=INDANG(IPQD,IND) + VU=DU(M) + VE=DE(M) + VZ=DZ(M) + ! X-BOUNDARY + IF(VU.GT.0.0)THEN + M1=MRMX(M) + IF(NCODE(1).NE.4)THEN + DO IEL=1,NMX + DO J=1,LY + DO K=1,LZ + IOF=(((M-1)*LZ+(K-1))*LY+(J-1))*NMX+IEL + JOF=(((M1-1)*LZ+(K-1))*LY+(J-1))*NMX+IEL + FUNKNO(LFLX+IOF,IG)=FUNKNO(LFLX+JOF,IG) + ENDDO + ENDDO + ENDDO + ENDIF + ELSEIF(VU.LT.0.0)THEN + M1=MRMX(M) + IF(NCODE(2).NE.4)THEN + DO IEL=1,NMX + DO J=1,LY + DO K=1,LZ + IOF=(((M-1)*LZ+(K-1))*LY+(J-1))*NMX+IEL + JOF=(((M1-1)*LZ+(K-1))*LY+(J-1))*NMX+IEL + FUNKNO(LFLX+IOF,IG)=FUNKNO(LFLX+JOF,IG) + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + ! Y-BOUNDARY + IF(VE.GT.0.0)THEN + M1=MRMY(M) + IF(NCODE(3).NE.4)THEN + DO IEL=1,NMY + DO I=1,LX + DO K=1,LZ + IOF=(((M-1)*LZ+(K-1))*LX+(I-1))*NMY+IEL + JOF=(((M1-1)*LZ+(K-1))*LX+(I-1))*NMY+IEL + FUNKNO(LFLX+LXNI+IOF,IG)=FUNKNO(LFLX+LXNI+JOF,IG) + ENDDO + ENDDO + ENDDO + ENDIF + ELSEIF(VE.LT.0.0)THEN + M1=MRMY(M) + IF(NCODE(4).NE.4)THEN + DO IEL=1,NMY + DO I=1,LX + DO K=1,LZ + IOF=(((M-1)*LZ+(K-1))*LX+(I-1))*NMY+IEL + JOF=(((M1-1)*LZ+(K-1))*LX+(I-1))*NMY+IEL + FUNKNO(LFLX+LXNI+IOF,IG)=FUNKNO(LFLX+LXNI+JOF,IG) + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + ! Z-BOUNDARY + IF(VZ.GT.0.0)THEN + M1=MRMZ(M) + IF(NCODE(5).NE.4)THEN + DO IEL=1,NMZ + DO I=1,LX + DO J=1,LY + IOF=(((M-1)*LY+(J-1))*LX+(I-1))*NMZ+IEL + JOF=(((M1-1)*LY+(J-1))*LX+(I-1))*NMZ+IEL + E1=FUNKNO(LFLX+LXNI+LXNJ+IOF,IG) + FUNKNO(LFLX+LXNI+LXNJ+IOF,IG)=FUNKNO(LFLX+LXNI+LXNJ+JOF,IG) + FUNKNO(LFLX+LXNI+LXNJ+JOF,IG)=E1 + ENDDO + ENDDO + ENDDO + ENDIF + ELSEIF(VZ.LT.0.0)THEN + M1=MRMZ(M) + IF(NCODE(6).NE.4)THEN + DO IEL=1,NMZ + DO I=1,LX + DO J=1,LY + IOF=(((M-1)*LY+(J-1))*LX+(I-1))*NMZ+IEL + JOF=(((M1-1)*LY+(J-1))*LX+(I-1))*NMZ+IEL + E1=FUNKNO(LFLX+LXNI+LXNJ+IOF,IG) + FUNKNO(LFLX+LXNI+LXNJ+IOF,IG)=FUNKNO(LFLX+LXNI+LXNJ+JOF,IG) + FUNKNO(LFLX+LXNI+LXNJ+JOF,IG)=E1 + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + 140 CONTINUE + 150 CONTINUE + +*$OMP END PARALLEL DO + +*---- +* KBA DIAGONAL LOOP +*---- + XNI(:NMX,:LY,:LZ,:NPQ,:NGEFF)=0.0D0 + XNJ(:NMY,:LX,:LZ,:NPQ,:NGEFF)=0.0D0 + XNK(:NMZ,:LX,:LY,:NPQ,:NGEFF)=0.0D0 + + DO 510 IDI=1,MACROX+MACROY+MACROZ-2 + + ! SET KBA SWAPPING INDICES + MACROMAX=MIN(MACROX,IDI)*MIN(MACROY,IDI) + ALLOCATE(III(MACROMAX),JJJ(MACROMAX)) + NCWAVEF=0 + DO ICEL=MAX(1,IDI-MACROY-MACROZ+2),MIN(MACROX,IDI) + DO JCEL=MAX(1,IDI-ICEL-MACROZ+2),MIN(MACROY,IDI-ICEL+1) + NCWAVEF=NCWAVEF+1 + IF(NCWAVEF.GT.MACROMAX) CALL XABORT('SNFD13: MACROMAX OVERFLOW.') + III(NCWAVEF)=ICEL + JJJ(NCWAVEF)=JCEL + ENDDO + ENDDO + +*---- +* MAIN SWAPPING LOOPS FOR SN FLUX CALCULATION +*---- + +*$OMP PARALLEL DO +*$OMP+ PRIVATE(ITID,FLUX,M,IG,Q,Q2,IOF,IER,II,JJ,I,J,K,ICEL,JCEL,KCEL) +*$OMP+ PRIVATE(IPQD,IMX,IMY,IMZ,IBM,SIGMA,V,ISFIX,IX,JX,IY,JY,IZ,JZ,IEL) +*$OMP+ PRIVATE(IIX,IIY,IIZ,P) FIRSTPRIVATE(WX,WY,WZ,WX0,WY0,WZ0) +*$OMP+ SHARED(XNI,XNJ,XNK,FUNKNO) REDUCTION(+:FLUX_G) COLLAPSE(3) + + ! LOOP FOR GROUPS TO EXECUTE IN PARALLEL + DO 500 IG=1,NGEFF + + ! LOOP OVER ALL DIRECTIONS + DO 490 IPQD=1,NPQD(IND) + + ! LOOP OVER MACROCELLS IN WAVEFRONT + DO 480 ICWAVEF=1,NCWAVEF + + IF(.NOT.INCONV(IG)) GO TO 480 + M=INDANG(IPQD,IND) + IF(W(M).EQ.0.0) GO TO 480 + + ! GET AND PRINT THREAD NUMBER +#if defined(_OPENMP) + ITID=omp_get_thread_num() +#else + ITID=0 +#endif + IF(IMPX.GT.5) WRITE(IUNOUT,600) ITID,NGIND(IG),IPQD,ICEL,JCEL,KCEL + +*---- +* LOOP OVER X-, Y- AND Z-DIRECTED AXES. +*---- + ICEL=III(ICWAVEF) + JCEL=JJJ(ICWAVEF) + KCEL=IDI-ICEL-JCEL+2 + + ! Z-BOUNDARIES CONDITIONS + IF(KCEL.EQ.1) THEN + DO IMX=1,MIN(NCELLX,LX-(ICEL-1)*NCELLX) + I=(ICEL-1)*NCELLX+IMX + IF((IND.EQ.2).OR.(IND.EQ.3).OR.(IND.EQ.6).OR.(IND.EQ.7))I=LX+1-I + DO IMY=1,MIN(NCELLX,LY-(JCEL-1)*NCELLX) + J=(JCEL-1)*NCELLX+IMY + IF((IND.EQ.3).OR.(IND.EQ.4).OR.(IND.EQ.7).OR.(IND.EQ.8))J=LY+1-J + + DO IEL=1,NMZ + IOF=(((M-1)*LY+(J-1))*LX+(I-1))*NMZ+IEL + IF((IND.EQ.1).OR.(IND.EQ.2).OR.(IND.EQ.3).OR.(IND.EQ.4)) THEN + XNK(IEL,I,J,IPQD,IG)=FUNKNO(LFLX+LXNI+LXNJ+IOF,IG)*ZCODE(5) + ELSE + XNK(IEL,I,J,IPQD,IG)=FUNKNO(LFLX+LXNI+LXNJ+IOF,IG)*ZCODE(6) + ENDIF + ENDDO + ! Z-BOUNDARIES FIXED SOURCES + IF(ISBS.EQ.1) THEN + IF(((IND.EQ.5).OR.(IND.EQ.6).OR.(IND.EQ.7).OR.(IND.EQ.8)) + 1 .AND.ISBSM(6,M,IG).NE.0) THEN + XNK(1,I,J,IPQD,IG)=XNK(1,I,J,IPQD,IG)+ + 1 BS((I-1)*LY+J,ISBSM(6,M,IG)) + ELSEIF(((IND.EQ.1).OR.(IND.EQ.2).OR.(IND.EQ.3).OR.(IND.EQ.4)) + 1 .AND.ISBSM(5,M,IG).NE.0) THEN + XNK(1,I,J,IPQD,IG)=XNK(1,I,J,IPQD,IG)+ + 1 BS((I-1)*LY+J,ISBSM(5,M,IG)) + ENDIF + ENDIF + + ENDDO + ENDDO + ENDIF + + ! Y-BOUNDARIES CONDITIONS + IF(JCEL.EQ.1) THEN + DO IMX=1,MIN(NCELLX,LX-(ICEL-1)*NCELLX) + I=(ICEL-1)*NCELLX+IMX + IF((IND.EQ.2).OR.(IND.EQ.3).OR.(IND.EQ.6).OR.(IND.EQ.7))I=LX+1-I + DO IMZ=1,MIN(NCELLX,LZ-(KCEL-1)*NCELLX) + K=(KCEL-1)*NCELLX+IMZ + IF((IND.EQ.5).OR.(IND.EQ.6).OR.(IND.EQ.7).OR.(IND.EQ.8))K=LZ+1-K + + DO IEL=1,NMY + IOF=(((M-1)*LZ+(K-1))*LX+(I-1))*NMY+IEL + IF((IND.EQ.1).OR.(IND.EQ.2).OR.(IND.EQ.5).OR.(IND.EQ.6)) THEN + XNJ(IEL,I,K,IPQD,IG)=FUNKNO(LFLX+LXNI+IOF,IG)*ZCODE(3) + ELSE + XNJ(IEL,I,K,IPQD,IG)=FUNKNO(LFLX+LXNI+IOF,IG)*ZCODE(4) + ENDIF + ENDDO + !Y-BOUNDARIES FIXED SOURCES + IF(ISBS.EQ.1) THEN + IF(((IND.EQ.3).OR.(IND.EQ.4).OR.(IND.EQ.7).OR.(IND.EQ.8)) + 1 .AND.ISBSM(4,M,IG).NE.0) THEN + XNJ(1,I,K,IPQD,IG)=XNJ(1,I,K,IPQD,IG)+ + 1 BS((I-1)*LZ+K,ISBSM(4,M,IG)) + ELSEIF(((IND.EQ.1).OR.(IND.EQ.2).OR.(IND.EQ.5).OR.(IND.EQ.6)) + 1 .AND.ISBSM(3,M,IG).NE.0) THEN + XNJ(1,I,K,IPQD,IG)=XNJ(1,I,K,IPQD,IG)+ + 1 BS((I-1)*LZ+K,ISBSM(3,M,IG)) + ENDIF + ENDIF + + ENDDO + ENDDO + ENDIF + + ! X-BOUNDARIES CONDITIONS + IF(ICEL.EQ.1) THEN + DO IMY=1,MIN(NCELLX,LY-(JCEL-1)*NCELLX) + J=(JCEL-1)*NCELLX+IMY + IF((IND.EQ.3).OR.(IND.EQ.4).OR.(IND.EQ.7).OR.(IND.EQ.8))J=LY+1-J + DO IMZ=1,MIN(NCELLX,LZ-(KCEL-1)*NCELLX) + K=(KCEL-1)*NCELLX+IMZ + IF((IND.EQ.5).OR.(IND.EQ.6).OR.(IND.EQ.7).OR.(IND.EQ.8))K=LZ+1-K + + DO IEL=1,NMX + IOF=(((M-1)*LZ+(K-1))*LY+(J-1))*NMX+IEL + IF((IND.EQ.1).OR.(IND.EQ.4).OR.(IND.EQ.5).OR.(IND.EQ.8)) THEN + XNI(IEL,J,K,IPQD,IG)=FUNKNO(LFLX+IOF,IG)*ZCODE(1) + ELSE + XNI(IEL,J,K,IPQD,IG)=FUNKNO(LFLX+IOF,IG)*ZCODE(2) + ENDIF + ENDDO + ! X-BOUNDARIES FIXED SOURCES + IF(ISBS.EQ.1) THEN + IF(((IND.EQ.2).OR.(IND.EQ.3).OR.(IND.EQ.6).OR.(IND.EQ.7)) + 1 .AND.ISBSM(2,M,IG).NE.0) THEN + XNI(1,J,K,IPQD,IG)=XNI(1,J,K,IPQD,IG)+ + 1 BS((J-1)*LZ+K,ISBSM(2,M,IG)) + ELSEIF(((IND.EQ.1).OR.(IND.EQ.4).OR.(IND.EQ.5).OR.(IND.EQ.8)) + 1 .AND.ISBSM(1,M,IG).NE.0) THEN + XNI(1,J,K,IPQD,IG)=XNI(1,J,K,IPQD,IG)+ + 1 BS((J-1)*LZ+K,ISBSM(1,M,IG)) + ENDIF + ENDIF + + ENDDO + ENDDO + ENDIF + + ! X-AXIS LOOP + DO 470 IMX=1,MIN(NCELLX,LX-(ICEL-1)*NCELLX) + I=(ICEL-1)*NCELLX+IMX + IF((IND.EQ.2).OR.(IND.EQ.3).OR.(IND.EQ.6).OR.(IND.EQ.7)) I=LX+1-I + + ! Y-AXIS LOOP + DO 460 IMY=1,MIN(NCELLX,LY-(JCEL-1)*NCELLX) + J=(JCEL-1)*NCELLX+IMY + IF((IND.EQ.3).OR.(IND.EQ.4).OR.(IND.EQ.7).OR.(IND.EQ.8)) J=LY+1-J + + ! Z-AXIS LOOP + DO 450 IMZ=1,MIN(NCELLX,LZ-(KCEL-1)*NCELLX) + K=(KCEL-1)*NCELLX+IMZ + IF((IND.EQ.5).OR.(IND.EQ.6).OR.(IND.EQ.7).OR.(IND.EQ.8)) K=LZ+1-K + + ! INITIALIZE FLUXES + FLUX(:NM,:NSCT)=0.0D0 + + ! DATA + IBM=MAT(I,J,K) + IF(IBM.EQ.0) GO TO 450 + SIGMA=TOTAL(IBM,IG) + V=VOL(I,J,K) + + ! SOURCE DENSITY TERM + DO IEL=1,NM + Q(IEL)=0.0D0 + DO P=1,NSCT + IOF=((((K-1)*LY+(J-1))*LX+(I-1))*NSCT+(P-1))*NM+IEL + Q(IEL)=Q(IEL)+QEXT(IOF,IG)*MN(M,P) + ENDDO + ENDDO + + ISFIX=.FALSE. + DO WHILE (.NOT.ALL(ISFIX)) ! LOOP FOR ADAPTIVE CALCULATION + + ! FLUX MOMENT COEFFICIENTS MATRIX + Q2(:NM,:NM+1)=0.0D0 + + DO IZ=1,IELEM + DO JZ=1,IELEM + DO IY=1,IELEM + DO JY=1,IELEM + DO IX=1,IELEM + DO JX=1,IELEM + + II=IELEM**2*(IZ-1)+IELEM*(IY-1)+IX + JJ=IELEM**2*(JZ-1)+IELEM*(JY-1)+JX + + ! DIAGONAL TERMS + IF(II.EQ.JJ) THEN + Q2(II,JJ)=SIGMA*V + 1 +CST(IX)**2*WX(JX+1)*ABS(DA(J,K,M)) + 2 +CST(IY)**2*WY(JY+1)*ABS(DB(I,K,M)) + 3 +CST(IZ)**2*WZ(JZ+1)*ABS(DC(I,J,M)) + + ! UPPER DIAGONAL TERMS + ELSEIF(II.LT.JJ) THEN + IF(IZ.EQ.JZ) THEN + IF(IY.EQ.JY) THEN + ! X-SPACE TERMS + IF(MOD(IX+JX,2).EQ.1) THEN + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*DA(J,K,M) + ELSE + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*ABS(DA(J,K,M)) + ENDIF + ELSEIF(IX.EQ.JX) THEN + ! Y-SPACE TERMS + IF(MOD(IY+JY,2).EQ.1) THEN + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*DB(I,K,M) + ELSE + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ABS(DB(I,K,M)) + ENDIF + ENDIF + ELSEIF(IY.EQ.JY.AND.IX.EQ.JX) THEN + ! Z-SPACE TERMS + IF(MOD(IZ+JZ,2).EQ.1) THEN + Q2(II,JJ)=CST(IZ)*CST(JZ)*WZ(JZ+1)*DC(I,J,M) + ELSE + Q2(II,JJ)=CST(IZ)*CST(JZ)*WZ(JZ+1)*ABS(DC(I,J,M)) + ENDIF + ENDIF + + ! UNDER DIAGONAL TERMS + ELSE + IF(IZ.EQ.JZ) THEN + IF(IY.EQ.JY) THEN + ! X-SPACE TERMS + IF(MOD(IX+JX,2).EQ.1) THEN + Q2(II,JJ)=CST(IX)*CST(JX)*(WX(JX+1)-2)*DA(J,K,M) + ELSE + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*ABS(DA(J,K,M)) + ENDIF + ELSEIF(IX.EQ.JX) THEN + ! Y-SPACE TERMS + IF(MOD(IY+JY,2).EQ.1) THEN + Q2(II,JJ)=CST(IY)*CST(JY)*(WY(JY+1)-2)*DB(I,K,M) + ELSE + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ABS(DB(I,K,M)) + ENDIF + ENDIF + ELSEIF(IY.EQ.JY.AND.IX.EQ.JX) THEN + ! Z-SPACE TERMS + IF(MOD(IZ+JZ,2).EQ.1) THEN + Q2(II,JJ)=CST(IZ)*CST(JZ)*(WZ(JZ+1)-2)*DC(I,J,M) + ELSE + Q2(II,JJ)=CST(IZ)*CST(JZ)*WZ(JZ+1)*ABS(DC(I,J,M)) + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + + ! FLUX SOURCE VECTOR + DO IZ=1,IELEM + DO IY=1,IELEM + DO IX=1,IELEM + II=IELEM**2*(IZ-1)+IELEM*(IY-1)+IX + IIX=IELEM*(IZ-1)+IY + IIY=IELEM*(IZ-1)+IX + IIZ=IELEM*(IY-1)+IX + Q2(II,NM+1)=Q(II)*V + ! X-SPACE TERMS + IF(MOD(IX,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IX)*(1-WX(1)) + 1 *XNI(IIX,J,K,IPQD,IG)*ABS(DA(J,K,M)) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IX)*(1+WX(1)) + 1 *XNI(IIX,J,K,IPQD,IG)*DA(J,K,M) + ENDIF + ! Y-SPACE TERMS + IF(MOD(IY,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IY)*(1-WY(1)) + 1 *XNJ(IIY,I,K,IPQD,IG)*ABS(DB(I,K,M)) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IY)*(1+WY(1)) + 1 *XNJ(IIY,I,K,IPQD,IG)*DB(I,K,M) + ENDIF + ! Z-SPACE TERMS + IF(MOD(IZ,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IZ)*(1-WZ(1)) + 1 *XNK(IIZ,I,J,IPQD,IG)*ABS(DC(I,J,M)) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IZ)*(1+WZ(1)) + 1 *XNK(IIZ,I,J,IPQD,IG)*DC(I,J,M) + ENDIF + ENDDO + ENDDO + ENDDO + + CALL ALSBD(NM,1,Q2,IER,NM) + IF(IER.NE.0) CALL XABORT('SNFKC3: SINGULAR MATRIX.') + + ! ADAPTIVE CORRECTION OF WEIGHTING PARAMETERS + IF(ANY(ISADPT)) THEN + IF(ISADPT(1)) THEN + CALL SNADPT(IELEM,NM,IELEM**2,Q2(1:IELEM:1,NM+1), + 1 XNI(:NMX,J,K,IPQD,IG),1.0,WX,ISFIX(1)) + ELSE + ISFIX(1)=.TRUE. + ENDIF + IF(ISADPT(2)) THEN + CALL SNADPT(IELEM,NM,IELEM**2,Q2(1:IELEM**2:IELEM,NM+1), + 1 XNJ(:NMY,I,K,IPQD,IG),1.0,WY,ISFIX(2)) + ELSE + ISFIX(2)=.TRUE. + ENDIF + IF(ISADPT(3)) THEN + CALL SNADPT(IELEM,NM,IELEM**2,Q2(1:NM:IELEM**2,NM+1), + 1 XNK(:NMZ,I,J,IPQD,IG),1.0,WZ,ISFIX(3)) + ELSE + ISFIX(3)=.TRUE. + ENDIF + ELSE + ISFIX=.TRUE. + ENDIF + + END DO ! END OF ADAPTIVE LOOP + + ! CLOSURE RELATIONS + IF(IELEM.EQ.1.AND.LFIXUP.AND.(Q2(1,2).LE.RLOG)) Q2(1,2)=0.0 + XNI(:NMX,J,K,IPQD,IG)=WX(1)*XNI(:NMX,J,K,IPQD,IG) + XNJ(:NMY,I,K,IPQD,IG)=WY(1)*XNJ(:NMY,I,K,IPQD,IG) + XNK(:NMZ,I,J,IPQD,IG)=WZ(1)*XNK(:NMZ,I,J,IPQD,IG) + DO IZ=1,IELEM + DO IY=1,IELEM + DO IX=1,IELEM + II=IELEM**2*(IZ-1)+IELEM*(IY-1)+IX + IIX=IELEM*(IZ-1)+IY + IIY=IELEM*(IZ-1)+IX + IIZ=IELEM*(IY-1)+IX + ! X-SPACE + IF(MOD(IX,2).EQ.1) THEN + XNI(IIX,J,K,IPQD,IG)=XNI(IIX,J,K,IPQD,IG)+CST(IX)*WX(IX+1) + 1 *Q2(II,NM+1) + ELSE + XNI(IIX,J,K,IPQD,IG)=XNI(IIX,J,K,IPQD,IG)+CST(IX)*WX(IX+1) + 1 *Q2(II,NM+1)*SIGN(1.0,DA(J,K,M)) + ENDIF + ! Y-SPACE + IF(MOD(IY,2).EQ.1) THEN + XNJ(IIY,I,K,IPQD,IG)=XNJ(IIY,I,K,IPQD,IG)+CST(IY)*WY(IY+1) + 1 *Q2(II,NM+1) + ELSE + XNJ(IIY,I,K,IPQD,IG)=XNJ(IIY,I,K,IPQD,IG)+CST(IY)*WY(IY+1) + 1 *Q2(II,NM+1)*SIGN(1.0,DB(I,K,M)) + ENDIF + ! Z-SPACE + IF(MOD(IZ,2).EQ.1) THEN + XNK(IIZ,I,J,IPQD,IG)=XNK(IIZ,I,J,IPQD,IG)+CST(IZ)*WZ(IZ+1) + 1 *Q2(II,NM+1) + ELSE + XNK(IIZ,I,J,IPQD,IG)=XNK(IIZ,I,J,IPQD,IG)+CST(IZ)*WZ(IZ+1) + 1 *Q2(II,NM+1)*SIGN(1.0,DC(I,J,M)) + ENDIF + ENDDO + ENDDO + ENDDO + IF(IELEM.EQ.1.AND.LFIXUP.AND.(XNI(1,J,K,IPQD,IG).LE.RLOG)) + 1 XNI(1,J,K,IPQD,IG)=0.0 + IF(IELEM.EQ.1.AND.LFIXUP.AND.(XNJ(1,I,K,IPQD,IG).LE.RLOG)) + 1 XNJ(1,I,K,IPQD,IG)=0.0 + IF(IELEM.EQ.1.AND.LFIXUP.AND.(XNK(1,I,J,IPQD,IG).LE.RLOG)) + 1 XNK(1,I,J,IPQD,IG)=0.0 + WX=WX0 + WY=WY0 + WZ=WZ0 + + ! SAVE LEGENDRE MOMENT OF THE FLUX + DO P=1,NSCT + DO IEL=1,NM + FLUX(IEL,P)=FLUX(IEL,P)+Q2(IEL,NM+1)*DN(P,M) + ENDDO + ENDDO + + ! SAVE X-BOUNDARY CONDITIONS + IF((ICEL-1)*NCELLX+IMX.EQ.LX) THEN + DO IEL=1,NMX + IOF=(((M-1)*LZ+(K-1))*LY+(J-1))*NMX+IEL + FUNKNO(LFLX+IOF,IG)=REAL(XNI(IEL,J,K,IPQD,IG)) + ENDDO + ENDIF + + ! SAVE Y-BOUNDARY CONDITIONS + IF((JCEL-1)*NCELLX+IMY.EQ.LY) THEN + DO IEL=1,NMY + IOF=(((M-1)*LZ+(K-1))*LX+(I-1))*NMY+IEL + FUNKNO(LFLX+LXNI+IOF,IG)=REAL(XNJ(IEL,I,K,IPQD,IG)) + ENDDO + ENDIF + + ! SAVE Z-BOUNDARY CONDITIONS + IF((KCEL-1)*NCELLX+IMZ.EQ.LZ) THEN + DO IEL=1,NMZ + IOF=(((M-1)*LY+(J-1))*LX+(I-1))*NMZ+IEL + FUNKNO(LFLX+LXNI+LXNJ+IOF,IG)=REAL(XNK(IEL,I,J,IPQD,IG)) + ENDDO + ENDIF + + ! SAVE FLUX INFORMATION + FLUX_G(:,:,I,J,K,IG)=FLUX_G(:,:,I,J,K,IG)+FLUX(:,:) + + 450 CONTINUE ! END OF Z-LOOP + 460 CONTINUE ! END OF Y-LOOP + 470 CONTINUE ! END OF X-LOOP + + 480 CONTINUE ! END OF MACROCELL LOOP + 490 CONTINUE ! END OF DIRECTION LOOP + 500 CONTINUE ! END OF ENERGY LOOP +*$OMP END PARALLEL DO + DEALLOCATE(JJJ,III) + 510 CONTINUE ! END OF WAVEFRONT LOOP + 520 CONTINUE ! END OF OCTANT LOOP + + ! SAVE FLUX INFORMATION + DO 530 IG=1,NGEFF + IF(.NOT.INCONV(IG)) GO TO 530 + FUNKNO(:LFLX,IG)= + 1 RESHAPE(REAL(FLUX_G(:NM,:NSCT,:LX,:LY,:LZ,IG)), (/LFLX/)) + 530 CONTINUE + +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(FLUX_G,FLUX,XNK,XNJ,XNI,INDANG) + RETURN +* + 600 FORMAT(16H SNFKC3: thread=,I8,12H --->(group=,I4,7H angle=,I4, + 1 11H macrocell=,3I5,1H)) + END diff --git a/Dragon/src/SNFKH2.F b/Dragon/src/SNFKH2.F new file mode 100644 index 0000000..4cbf2fa --- /dev/null +++ b/Dragon/src/SNFKH2.F @@ -0,0 +1,614 @@ +*DECK SNFKH2 + SUBROUTINE SNFKH2(NUN,NGEFF,IMPX,INCONV,NGIND,NHEX,ISPLH,SIDE, + 1 IELEM,NM,NMX,NMY,NMAT,NPQ,NSCT,MAT,VOL,TOTAL,QEXT,LFIXUP,DU,DE,W, + 2 DB,DA,MN,DN,WX,WY,CST,ISADPT,LOZSWP,COORDMAP,FUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform one inner iteration for solving SN equations in 2D hexagonal +* geometry for the HODD/DG method. KBA-like multithreading, i.e., +* macrocell-energy. VOID boundary conditions. Boltzmann (BTE) +* discretization. + +* +*Copyright: +* Copyright (C) 2025 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert, A. A. Calloo and C. Bienvenue +* +*Parameters: input +* NUN total number of unknowns in vector FUNKNO. +* NGEFF number of energy groups processed in parallel. +* IMPX print flag (equal to zero for no print). +* INCONV energy group convergence flag (set to .FALSE. if converged). +* NGIND energy group indices assign to the NGEFF set. +* NHEX number of hexagons in X-Y plane. +* ISPLH splitting option for hexagons. +* SIDE side of an hexagon. +* IELEM measure of order of the spatial approximation polynomial: +* =1 constant - default for HODD; +* =2 linear - default for DG; +* >3 higher orders. +* NM number of moments in space and energy for flux components +* NMX number of moments for X axis boundaries components +* NMY number of moments for Y axis boundaries components +* NMAT number of material mixtures. +* NPQ number of SN directions in four octants (including zero-weight +* directions). +* NSCT maximum number of spherical harmonics moments of the flux. +* MAT material mixture index in each region. +* VOL volumes of each region. +* TOTAL macroscopic total cross sections. +* QEXT Legendre components of the fixed source. +* LFIXUP flag to enable negative flux fixup. +* DU first direction cosines ($\\mu$). +* DE second direction cosines ($\\eta$). +* W weights. +* DB diamond-scheme parameter. +* DA diamond-scheme parameter. +* MN moment-to-discrete matrix. +* DN discrete-to-moment matrix. +* WX spatial X axis closure relation weighting factors. +* WY spatial Y axis closure relation weighting factors. +* CST constants for the polynomial approximations. +* ISADPT flag to enable/disable adaptive flux calculations. +* LOZSWP lozenge sweep order depending on direction. +* COORDMAP coordinate map - mapping the hexagons from the indices +* within the DRAGON geometry to a Cartesian axial coordinate +* array (see redblobgames.com website). +* +*Parameters: input/output +* FUNKNO Legendre components of the flux and boundary fluxes. +* +*Comments: +* 1. The direction of the axes I, J and D for the surface boundary +* fluxes are shown in the diagram below. This means that +* i) lozenge A has I- and D-boundaries (instead of I and J) +* i) lozenge B has I- and J-boundaries +* i) lozenge C has D- and J-boundaries (instead of I and J) +* +* ^ +* j-axis | +* | ^ +* _________ / d-axis +* / / \ / +* / B / \ +* / / \ +* (-------( A ) +* \ \ / +* \ C \ / +* \_______\_/ \ +* \ i-axis +* ^ +* +*----------------------------------------------------------------------- +#if defined(_OPENMP) + USE omp_lib +#endif +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NUN,NGEFF,IMPX,NGIND(NGEFF),NHEX,ISPLH,IELEM,NM,NMX, + 1 NMY,NMAT,NPQ,NSCT,MAT(ISPLH,ISPLH,3,NHEX),LOZSWP(3,6), + 2 COORDMAP(3,NHEX) + LOGICAL INCONV(NGEFF) + REAL SIDE,VOL(ISPLH,ISPLH,3,NHEX),TOTAL(0:NMAT,NGEFF), + 1 QEXT(NUN,NGEFF),DU(NPQ),DE(NPQ),W(NPQ), + 2 DB(ISPLH,ISPLH,3,NHEX,NPQ),DA(ISPLH,ISPLH,3,NHEX,NPQ), + 3 MN(NPQ,NSCT),DN(NSCT,NPQ),FUNKNO(NUN,NGEFF),WX(IELEM+1), + 3 WY(IELEM+1),CST(IELEM) + LOGICAL LFIXUP,ISADPT(2) +*---- +* LOCAL VARIABLES +*---- + INTEGER :: NPQD(6),IIND(6),P,DCOORD + REAL :: JAC(2,2,3), MUH, ETAH, AAA, BBB, CCC, DDD, MUHTEMP, + 1 ETAHTEMP, WX0(IELEM+1),WY0(IELEM+1) + DOUBLE PRECISION :: Q(NM), Q2(NM,NM+1), V,THETA, XNI(NMX), + 1 XNJ(NMY) + PARAMETER(IUNOUT=6,RLOG=1.0E-8,PI=3.141592654) + LOGICAL :: LHEX(NHEX) + LOGICAL ISFIX(2) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: INDANG + INTEGER, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: TMPMAT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: FLUX + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: FLUX_G + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: TMPXNI, + > TMPXNJ, TMPXND +*---- +* MAP MATERIAL VALUES TO CARTESIAN AXIAL COORDINATE MAP +*---- + NRINGS=INT((SQRT( REAL((4*NHEX-1)/3) )+1.)/2.) + NCOL=2*NRINGS -1 + ALLOCATE(TMPMAT(ISPLH,ISPLH,3,NCOL,NCOL)) + TMPMAT(:,:,:,:,:) = -1 + DO IHEX_DOM=1,NHEX + TMPMAT(:,:,:,COORDMAP(1,IHEX_DOM),COORDMAP(2,IHEX_DOM)) = + > MAT(:,:,:,IHEX_DOM) + ENDDO +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(INDANG(NPQ,6)) + ALLOCATE(FLUX(NM,NSCT)) + ALLOCATE(FLUX_G(NM,NSCT,3*ISPLH**2,NHEX,NGEFF)) + ALLOCATE(TMPXNI(IELEM,ISPLH,NCOL,NPQ,NGEFF)) + ALLOCATE(TMPXNJ(IELEM,ISPLH,NCOL,NPQ,NGEFF)) + ALLOCATE(TMPXND(IELEM,ISPLH,NCOL,NPQ,NGEFF)) +*---- +* CONSTRUCT JACOBIAN MATRIX FOR EACH LOZENGE +*---- + JAC = RESHAPE((/ 1., -SQRT(3.), 1., SQRT(3.), 2., 0., 1., + > SQRT(3.), 2., 0., -1., SQRT(3.) /), SHAPE(JAC)) + JAC = (SIDE/2.)*JAC +*---- +* LENGTH OF FUNKNO COMPONENTS (IN ORDER) +*---- + LFLX=3*NM*(ISPLH**2)*NHEX*NSCT +*---- +* SET DODECANT SWAPPING ORDER +*---- + NPQD(:6)=0 + INDANG(:NPQ,:6)=0 + IIND(:6)=0 + DO M=1,NPQ + VU=DU(M) + VE=DE(M) + IF(W(M).EQ.0) CYCLE + THETA=0.0D0 + IF(VE.GT.0.0)THEN + IF(VU.EQ.0.0)THEN + THETA = PI/2 + ELSEIF(VU.GT.0.0)THEN + THETA = ATAN(ABS(VE/VU)) + ELSEIF(VU.LT.0.0)THEN + THETA = PI - ATAN(ABS(VE/VU)) + ENDIF + ELSEIF(VE.LT.0.0)THEN + IF(VU.EQ.0.0)THEN + THETA = 3*PI/2 + ELSEIF(VU.LT.0.0)THEN + THETA = PI + ATAN(ABS(VE/VU)) + ELSEIF(VU.GT.0.0)THEN + THETA = 2.*PI - ATAN(ABS(VE/VU)) + ENDIF + ENDIF + IND=0 + IF((THETA.GT.0.0).AND.(THETA.LT.(PI/3.)))THEN + IND=1 + ELSEIF((THETA.GT.(PI/3.)).AND.(THETA.LT.(2.*PI/3.)))THEN + IND=2 + ELSEIF((THETA.GT.(2.*PI/3.)).AND.(THETA.LT.(PI)))THEN + IND=3 + ELSEIF((THETA.GT.(PI)).AND.(THETA.LT.(4.*PI/3.)))THEN + IND=4 + ELSEIF((THETA.GT.(4.*PI/3.)).AND.(THETA.LT.(5.*PI/3.)))THEN + IND=5 + ELSEIF((THETA.GT.(5.*PI/3.)).AND.(THETA.LT.(2.*PI)))THEN + IND=6 + ENDIF + ! Assume IIND(I)=I in hexagonal geometry + IIND(IND)=IND + NPQD(IND)=NPQD(IND)+1 + INDANG(NPQD(IND),IND)=M + ENDDO +*---- +* MAIN LOOP OVER DODECANTS +*---- + + FLUX_G(:NM,:NSCT,:3*ISPLH**2,:NHEX,:NGEFF)=0.0D0 + WX0=WX + WY0=WY + + DO JND=1,6 + IND=IIND(JND) + ! Needed because of S2 LS (4 dir. for 6 sextants) + IF(IND.EQ.0) CYCLE + TMPXNI(:IELEM,:ISPLH,:NCOL,:NPQ,:NGEFF)=0.0D0 + TMPXNJ(:IELEM,:ISPLH,:NCOL,:NPQ,:NGEFF)=0.0D0 + TMPXND(:IELEM,:ISPLH,:NCOL,:NPQ,:NGEFF)=0.0D0 + +*---- +* LOOP OVER WAVEFRONTS +*---- + DO IDI=1,NCOL+NCOL-1 +*---- +* MAIN SWAPPING LOOPS FOR SN FLUX CALCULATION +* LOOP OVER MACROCELLS IN WAVEFRONT AND ENERGY +*---- + +*$OMP PARALLEL DO +*$OMP+ PRIVATE(ITID,FLUX,M,IG,XNI,XNJ,Q,Q2,IOF,IER,II,JJ,IEL,I,J,P) +*$OMP+ PRIVATE(IPQD,IBM,SIGMA,V,ISFIX,IX,JX,IY,JY,AAA,BBB,CCC,DDD) +*$OMP+ PRIVATE(LHEX,IHEX,IIHEX,DCOORD,ILOZLOOP,ILOZ,IL,I2,JL,J2) +*$OMP+ PRIVATE(MUHTEMP,MUH,ETAHTEMP,ETAH,I3,I_FETCH) +*$OMP+ SHARED(TMPXNI,TMPXNJ,TMPXND,IND,IDI,FUNKNO) +*$OMP+ FIRSTPRIVATE(WX,WY,WX0,WY0) +*$OMP+ COLLAPSE(2) + + ! LOOP OVER MACROCELLS IN WAVEFRONT + DO J_MC=MAX(1,IDI-NCOL+1),MIN(NCOL,IDI) + + ! LOOP FOR GROUPS TO EXECUTE IN PARALLEL + DO IG=1,NGEFF + + ! LOOP OVER ALL DIRECTIONS + DO IPQD=1,NPQD(IND) + IF(.NOT.INCONV(IG)) CYCLE + M=INDANG(IPQD,IND) + IF(W(M).EQ.0.0) CYCLE + + ! GET AND PRINT THREAD NUMBER +#if defined(_OPENMP) + ITID=omp_get_thread_num() +#else + ITID=0 +#endif + IF(IMPX.GT.5) WRITE(IUNOUT,400) ITID,NGIND(IG),IPQD + + JIM=J_MC + ! Account for different sweep direction depending on angle + IF((IND.EQ.1).OR.(IND.EQ.2).OR.(IND.EQ.3)) JIM=NCOL+1-JIM + + ! Find I coordinate of macrocell based on Jth coordinate, the + ! wavefront number and occasionally the number of rings in the + ! domain + IF((IND.EQ.1).OR.(IND.EQ.4)) THEN + I_MC=IDI-J_MC+1 + ELSE + I_MC=IDI-J_MC+(NRINGS+1-J_MC) + ENDIF + IIM=I_MC + ! Account for different sweep direction depending on angle + IF((IND.EQ.2).OR.(IND.EQ.3).OR.(IND.EQ.4)) IIM=NCOL+1-IIM + + ! For IND 3 or 6, Cartesian axial coordinate map is swept + ! vertically instead of horizontally. IM suffix is for 'IMmutable' + I=IIM + J=JIM + IF((IND.EQ.3).OR.(IND.EQ.6))THEN + I=JIM + J=IIM + ENDIF + IF((I.GT.NCOL).OR.(I.LT.1)) CYCLE + IF((J.GT.NCOL).OR.(J.LT.1)) CYCLE + ! If within corners of Cartesian axial coordinate map (where + ! there are no hexagons), skip loop + IF(TMPMAT(1,1,1,I,J).EQ.-1) CYCLE + + ! Find DRAGON geometry hexagonal index using I and J + LHEX=(COORDMAP(1,:).EQ.I .AND. COORDMAP(2,:).EQ.J) + IHEX=0 + DO IIHEX=1,NHEX + IF(LHEX(IIHEX)) THEN + IHEX=IIHEX + EXIT + ENDIF + ENDDO + IF(IHEX.EQ.0) CALL XABORT('SNFDH2: IHEX FAILURE.') + ! Find D coordinate + DCOORD = ABS(COORDMAP(3,IHEX))-NRINGS + + ! LOOP OVER LOZENGES + DO ILOZLOOP=1,3 + ILOZ=LOZSWP(ILOZLOOP,IND) + + ! Get Jacobian elements values + AAA = JAC(1,1,ILOZ) + BBB = JAC(1,2,ILOZ) + CCC = JAC(2,1,ILOZ) + DDD = JAC(2,2,ILOZ) + + + ! LOOP OVER SUBMESH WITHIN EACH LOZENGE + DO IL=1,ISPLH + I2=IL + ! Account for different sweep direction depending on angle + IF((ILOZ.EQ.1).OR.(ILOZ.EQ.2))THEN + IF((IND.EQ.2).OR.(IND.EQ.3).OR.(IND.EQ.4)) I2=ISPLH+1-I2 + ELSEIF(ILOZ.EQ.3)THEN + IF((IND.EQ.3).OR.(IND.EQ.4).OR.(IND.EQ.5)) I2=ISPLH+1-I2 + ENDIF + + DO JL=1,ISPLH + J2=JL + ! Account for different sweep direction depending on angle + IF((ILOZ.EQ.2).OR.(ILOZ.EQ.3))THEN + IF((IND.EQ.4).OR.(IND.EQ.5).OR.(IND.EQ.6)) J2=ISPLH+1-J2 + ELSEIF(ILOZ.EQ.1)THEN + IF((IND.EQ.3).OR.(IND.EQ.4).OR.(IND.EQ.5)) J2=ISPLH+1-J2 + ENDIF + + ! INITIALIZE FLUXES AND BOUNDARY FLUXES + FLUX(:IELEM**2,:NSCT)=0.0D0 + + ! READ IN XNI AND XNJ DEPENDING ON LOZENGE + I_FETCH=0 + IF((ILOZ.EQ.1))THEN + ! Read boundary fluxes in reverse for lozenge A since affine + ! transformation of lozenges causes the D and I directions + ! of lozenges C and A respectively to be reversed + I_FETCH=ISPLH+1-I2 + XNI(:) = TMPXNI(:,J2,J,IPQD,IG) + XNJ(:) = TMPXND(:,I_FETCH,DCOORD,IPQD,IG) + ELSEIF((ILOZ.EQ.2))THEN + XNI(:) = TMPXNI(:,J2,J,IPQD,IG) + XNJ(:) = TMPXNJ(:,I2,I,IPQD,IG) + ELSEIF((ILOZ.EQ.3))THEN + XNI(:) = TMPXND(:,J2,DCOORD,IPQD,IG) + XNJ(:) = TMPXNJ(:,I2,I,IPQD,IG) + ENDIF + + ! DATA + IBM=MAT(I2,J2,ILOZ,IHEX) + ! Skip loop if virtual element + IF(IBM.EQ.0) CYCLE + SIGMA=TOTAL(IBM,IG) + V=VOL(I2,J2,ILOZ,IHEX) + + ! COMPUTE ADJUSTED DIRECTION COSINES + MUHTEMP = DA(I2,J2,ILOZ,IHEX,M) + ETAHTEMP = DB(I2,J2,ILOZ,IHEX,M) + MUH = (MUHTEMP*DDD) - (ETAHTEMP*BBB) + ETAH = (-MUHTEMP*CCC) + (ETAHTEMP*AAA) + + ! SOURCE DENSITY TERM + DO IEL=1,NM + Q(IEL)=0.0D0 + DO P=1,NSCT + IOF=((((((IHEX-1)*3+(ILOZ-1))*ISPLH+(J2-1))*ISPLH+ + 1 (I2-1))*NSCT+(P-1))*NM)+IEL + Q(IEL)=Q(IEL)+QEXT(IOF,IG)*MN(M,P) + ENDDO + ENDDO + + ISFIX=.FALSE. + DO WHILE (.NOT.ALL(ISFIX)) ! LOOP FOR ADAPTIVE CALCULATION + + ! FLUX MOMENT COEFFICIENTS MATRIX + Q2(:NM,:NM+1)=0.0D0 + + DO IY=1,IELEM + DO JY=1,IELEM + DO IX=1,IELEM + DO JX=1,IELEM + II=IELEM*(IY-1)+IX + JJ=IELEM*(JY-1)+JX + + ! DIAGONAL TERMS + IF(II.EQ.JJ) THEN + Q2(II,JJ)=SIGMA*V + 1 +CST(IX)**2*WX(JX+1)*ABS(MUH) + 2 +CST(IY)**2*WY(JY+1)*ABS(ETAH) + + ! UPPER DIAGONAL TERMS + ELSEIF(II.LT.JJ) THEN + ! X-SPACE TERMS + IF(IY.EQ.JY) THEN + IF(MOD(IX+JX,2).EQ.1) THEN + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*MUH + ELSE + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*ABS(MUH) + ENDIF + ! Y-SPACE TERMS + ELSEIF(IX.EQ.JX) THEN + IF(MOD(IY+JY,2).EQ.1) THEN + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ETAH + ELSE + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ABS(ETAH) + ENDIF + ENDIF + + ! UNDER DIAGONAL TERMS + ELSE + ! X-SPACE TERMS + IF(IY.EQ.JY) THEN + IF(MOD(IX+JX,2).EQ.1) THEN + Q2(II,JJ)=CST(IX)*CST(JX)*(WX(JX+1)-2)*MUH + ELSE + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*ABS(MUH) + ENDIF + ! Y-SPACE TERMS + ELSEIF(IX.EQ.JX) THEN + IF(MOD(IY+JY,2).EQ.1) THEN + Q2(II,JJ)=CST(IY)*CST(JY)*(WY(JY+1)-2)*ETAH + ELSE + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ABS(ETAH) + ENDIF + ENDIF + + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + + ! FLUX SOURCE VECTOR + DO IY=1,IELEM + DO IX=1,IELEM + II=IELEM*(IY-1)+IX + Q2(II,NM+1)=Q(II)*V + ! X-SPACE TERMS + IF(MOD(IX,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IX)*(1-WX(1)) + 1 *XNI(IY)*ABS(MUH) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IX)*(1+WX(1)) + 1 *XNI(IY)*MUH + ENDIF + ! Y-SPACE TERMS + IF(MOD(IY,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IY)*(1-WY(1)) + 1 *XNJ(IX)*ABS(ETAH) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IY)*(1+WY(1)) + 1 *XNJ(IX)*ETAH + ENDIF + ENDDO + ENDDO + + CALL ALSBD(NM,1,Q2,IER,NM) + IF(IER.NE.0) CALL XABORT('SNFKH2: SINGULAR MATRIX.') + + ! ADAPTIVE CORRECTION OF WEIGHTING PARAMETERS + IF(ANY(ISADPT)) THEN + IF(ISADPT(1)) THEN + CALL SNADPT(IELEM,NM,IELEM,Q2(1:IELEM:1,NM+1), + 1 XNI(:NMX),1.0,WX,ISFIX(1)) + ELSE + ISFIX(1)=.TRUE. + ENDIF + IF(ISADPT(2)) THEN + CALL SNADPT(IELEM,NM,IELEM,Q2(1:NM:IELEM,NM+1), + 1 XNJ(:NMY),1.0,WY,ISFIX(2)) + ELSE + ISFIX(2)=.TRUE. + ENDIF + ELSE + ISFIX=.TRUE. + ENDIF + + END DO ! END OF ADAPTIVE LOOP + + ! CLOSURE RELATIONS + IF(IELEM.EQ.1.AND.LFIXUP.AND.(Q2(1,2).LE.RLOG)) Q2(1,2)=0.0 + ! Read XNI/XNI into TMPXNI/J/D + IF((ILOZ.EQ.1).OR.(ILOZ.EQ.2))THEN + TMPXNI(:NMX,J2,J,IPQD,IG)=WX(1)*XNI(:NMX) + ELSE + TMPXND(:NMX,J2,DCOORD,IPQD,IG)=WX(1)*XNI(:NMX) + ENDIF + IF((ILOZ.EQ.2).OR.(ILOZ.EQ.3))THEN + TMPXNJ(:NMY,I2,I,IPQD,IG)=WY(1)*XNJ(:NMY) + ELSE + I3=I_FETCH + TMPXND(:NMY,I3,DCOORD,IPQD,IG)=WY(1)*XNJ(:NMY) + ENDIF + DO IY=1,IELEM + DO IX=1,IELEM + II=IELEM*(IY-1)+IX + ! X-SPACE + ! Assign I-boundary fluxes if lozenges A or B + IF((ILOZ.EQ.1).OR.(ILOZ.EQ.2))THEN + IF(MOD(IX,2).EQ.1) THEN + TMPXNI(IY,J2,J,IPQD,IG)=TMPXNI(IY,J2,J,IPQD,IG)+CST(IX)* + 1 WX(IX+1)*Q2(II,NM+1) + ELSE + TMPXNI(IY,J2,J,IPQD,IG)=TMPXNI(IY,J2,J,IPQD,IG)+CST(IX)* + 1 WX(IX+1)*Q2(II,NM+1)*SIGN(1.0,MUH) + ENDIF + ENDIF + ! Y-SPACE + ! Assign J-boundary fluxes if lozenges B or C + IF((ILOZ.EQ.2).OR.(ILOZ.EQ.3))THEN + IF(MOD(IY,2).EQ.1) THEN + TMPXNJ(IX,I2,I,IPQD,IG)=TMPXNJ(IX,I2,I,IPQD,IG)+CST(IY)* + 1 WY(IY+1)*Q2(II,NM+1) + ELSE + TMPXNJ(IX,I2,I,IPQD,IG)=TMPXNJ(IX,I2,I,IPQD,IG)+CST(IY)* + 1 WY(IY+1)*Q2(II,NM+1)*SIGN(1.0,ETAH) + ENDIF + ENDIF + ! D-SPACE + ! Assign D-boundary fluxes if lozenge A using XNJ + IF((ILOZ.EQ.1))THEN + I3=I_FETCH + IF(MOD(IY,2).EQ.1) THEN + TMPXND(IX,I3,DCOORD,IPQD,IG)=TMPXND(IX,I3,DCOORD,IPQD,IG)+ + 1 CST(IY)*WY(IY+1)*Q2(II,NM+1) + ELSE + TMPXND(IX,I3,DCOORD,IPQD,IG)=TMPXND(IX,I3,DCOORD,IPQD,IG)+ + 1 CST(IY)*WY(IY+1)*Q2(II,NM+1)*SIGN(1.0,ETAH) + ENDIF + ENDIF + ! Assign D-boundary fluxes if lozenge C using XNI + IF((ILOZ.EQ.3))THEN + IF(MOD(IX,2).EQ.1) THEN + TMPXND(IY,J2,DCOORD,IPQD,IG)=TMPXND(IY,J2,DCOORD,IPQD,IG)+ + 1 CST(IX)*WX(IX+1)*Q2(II,NM+1) + ELSE + TMPXND(IY,J2,DCOORD,IPQD,IG)=TMPXND(IY,J2,DCOORD,IPQD,IG)+ + 1 CST(IX)*WX(IX+1)*Q2(II,NM+1)*SIGN(1.0,MUH) + ENDIF + ENDIF + ENDDO + ENDDO + ! FLIP GRADIENTS IF NECESSARY + DO IY=1,IELEM + IF((MOD(IY,2).EQ.0).AND.(ILOZ.EQ.3).AND.(IL.EQ.ISPLH)) + 1 TMPXND(IY,J2,DCOORD,IPQD,IG)=TMPXND(IY,J2,DCOORD,IPQD,IG)*(-1) + ENDDO + I3=I_FETCH + DO IX=1,IELEM + IF((MOD(IX,2).EQ.0).AND.(ILOZ.EQ.1).AND.(JL.EQ.ISPLH)) + 1 TMPXND(IX,I3,DCOORD,IPQD,IG)=TMPXND(IX,I3,DCOORD,IPQD,IG)*(-1) + ENDDO + ! LFIXUP + IF(IELEM.EQ.1.AND.LFIXUP)THEN + IF((ILOZ.EQ.1).OR.(ILOZ.EQ.2))THEN + IF(TMPXNI(1,J2,J,IPQD,IG).LE.RLOG) TMPXNI(1,J2,J,IPQD,IG)=0.0 + ELSE + IF(TMPXND(1,J2,DCOORD,IPQD,IG).LE.RLOG) + 1 TMPXND(1,J2,DCOORD,IPQD,IG)=0.0 + ENDIF + IF((ILOZ.EQ.2).OR.(ILOZ.EQ.3))THEN + IF(TMPXNJ(1,I2,I,IPQD,IG).LE.RLOG) TMPXNJ(1,I2,I,IPQD,IG)=0.0 + ELSE + I3=I_FETCH + IF(TMPXND(1,I3,DCOORD,IPQD,IG).LE.RLOG) + 1 TMPXND(1,I3,DCOORD,IPQD,IG)=0.0 + ENDIF + ENDIF + WX=WX0 + WY=WY0 + ! SAVE LEGENDRE MOMENT OF THE FLUX + DO P=1,NSCT + DO IEL=1,NM + FLUX(IEL,P)=FLUX(IEL,P) + Q2(IEL,NM+1)*DN(P,M) + ENDDO + ENDDO + + ! SAVE FLUX INFORMATION + IOF=((ILOZ-1)*ISPLH+(J2-1))*ISPLH+I2 + FLUX_G(:,:,IOF,IHEX,IG)=FLUX_G(:,:,IOF,IHEX,IG)+FLUX(:,:) + + ENDDO ! END OF WITHIN LOZENGE J-LOOP + ENDDO ! END OF WITHIN LOZENGE I-LOOP + + ENDDO ! END OF LOZENGE LOOP + + ENDDO ! END OF DIRECTION LOOP + ENDDO ! END OF ENERGY LOOP + + ENDDO ! END OF MACROCELL LOOP +*$OMP END PARALLEL DO + ENDDO ! END OF WAVEFRONT LOOP + + ENDDO ! END OF OCTANT LOOP + + ! SAVE FLUX INFORMATION + DO IG=1,NGEFF + IF(.NOT.INCONV(IG)) CYCLE + FUNKNO(:LFLX,IG)= + 1 RESHAPE(REAL(FLUX_G(:IELEM**2,:NSCT,:3*ISPLH**2,:NHEX,IG)), + 2 (/ LFLX /) ) + ENDDO + + ! CALL XABORT('SNFKH2: testing') + +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(FLUX_G,FLUX,INDANG,TMPXNI,TMPXNJ,TMPXND,TMPMAT) + RETURN + 400 FORMAT(16H SNFKH2: thread=,I8,12H --->(group=,I4,7H angle=,I4,1H)) + END diff --git a/Dragon/src/SNFKH3.F b/Dragon/src/SNFKH3.F new file mode 100644 index 0000000..fe5c3f1 --- /dev/null +++ b/Dragon/src/SNFKH3.F @@ -0,0 +1,857 @@ +*DECK SNFKH3 + SUBROUTINE SNFKH3(NKBA,NUN,NGEFF,IMPX,INCONV,NGIND,NHEX,LZ,ISPLH, + 1 SIDE,IELEM,NM,NMX,NMY,NMZ,NMAT,NPQ,NSCT,MAT,VOL,TOTAL,NCODE, + 2 ZCODE,QEXT,LFIXUP,DU,DE,DZ,W,MRMZ,DC,DB,DA,MN,DN,WX,WY,WZ,CST, + 3 ISADPT,LOZSWP,COORDMAP,FUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform one inner iteration for solving SN equations in 3D Cartesian +* geometry for the HODD method. KBA-like multithreading. Albedo +* boundary conditions on top/bottom, Void on sides. Boltzmann (BTE) +* discretization. +* +*Copyright: +* Copyright (C) 2025 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert, A. A. Calloo and C. Bienvenue +* +*Parameters: input +* NKBA number of macrocells along the z-axis +* NUN total number of unknowns in vector FUNKNO. +* NGEFF number of energy groups processed in parallel. +* IMPX print flag (equal to zero for no print). +* INCONV energy group convergence flag (set to .FALSE. if converged). +* NGIND energy group indices assign to the NGEFF set. +* NHEX number of hexagons in X-Y plane. +* ISPLH splitting option for hexagons. +* SIDE side of an hexagon. +* LZ number of meshes along Z axis. +* IELEM measure of order of the spatial approximation polynomial: +* =1 constant - default for HODD; +* =2 linear - default for DG; +* >3 higher orders. +* NM number of moments in space for flux components +* NMX number of moments for X axis boundaries components +* NMY number of moments for Y axis boundaries components +* NMZ number of moments for Z axis boundaries components +* NMAT number of material mixtures. +* NPQ number of SN directions in height octants. +* NSCT maximum number of spherical harmonics moments of the flux. +* MAT material mixture index in each region. +* VOL volumes of each region. +* TOTAL macroscopic total cross sections. +* ESTOPW stopping power. +* NCODE boundary condition indices. +* ZCODE albedos. +* DELTAE energy group width in MeV. +* QEXT Legendre components of the fixed source. +* LFIXUP flag to enable negative flux fixup. +* DU first direction cosines ($\\mu$). +* DE second direction cosines ($\\eta$). +* DZ third direction cosines ($\\xi$). +* W weights. +* MRMZ quadrature index. +* DC diamond-scheme parameter. +* DB diamond-scheme parameter. +* DA diamond-scheme parameter. +* MN moment-to-discrete matrix. +* DN discrete-to-moment matrix. +* WX spatial X axis closure relation weighting factors. +* WY spatial Y axis closure relation weighting factors. +* WZ spatial Z axis closure relation weighting factors. +* CST constants for the polynomial approximations. +* ISADPT flag to enable/disable adaptive flux calculations. +* LOZSWP lozenge sweep order depending on direction. +* COORDMAP coordinate map - mapping the hexagons from the indices +* within the DRAGON geometry to a Cartesian axial coordinate +* array (see redblobgames.com website). +* +*Parameters: input/output +* FUNKNO Legendre components of the flux and boundary fluxes. +* +*Comments: +* 1. The direction of the axes I, J and D for the surface boundary +* fluxes are shown in the diagram below. This means that +* i) lozenge A has I- and D-boundaries (instead of I and J) +* i) lozenge B has I- and J-boundaries +* i) lozenge C has D- and J-boundaries (instead of I and J) +* +* ^ +* j-axis | +* | ^ +* _________ / d-axis +* / / \ / +* / B / \ +* / / \ +* (-------( A ) +* \ \ / +* \ C \ / +* \_______\_/ \ +* \ i-axis +* ^ +* +*----------------------------------------------------------------------- +* +#if defined(_OPENMP) + USE omp_lib +#endif +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NUN,NGEFF,IMPX,NGIND(NGEFF),NHEX,LZ,ISPLH,IELEM,NM,NMX, + 1 NMY,NMZ,NMAT,NPQ,NSCT,MAT(ISPLH,ISPLH,3,NHEX,LZ),NCODE(6), + 2 MRMZ(NPQ),LOZSWP(3,6),COORDMAP(3,NHEX) + LOGICAL INCONV(NGEFF) + REAL SIDE,VOL(ISPLH,ISPLH,3,NHEX,LZ),ZCODE(6),TOTAL(0:NMAT,NGEFF), + 1 QEXT(NUN,NGEFF),DU(NPQ),DE(NPQ),DZ(NPQ),W(NPQ), + 2 DC(ISPLH*ISPLH*3*NHEX,1,NPQ),DB(ISPLH*ISPLH*3*NHEX,LZ,NPQ), + 3 DA(1,LZ,NPQ),FUNKNO(NUN,NGEFF),WX(IELEM+1),WY(IELEM+1), + 4 WZ(IELEM+1),CST(IELEM),MN(NPQ,NSCT),DN(NSCT,NPQ) + LOGICAL LFIXUP,ISADPT(3) +*---- +* LOCAL VARIABLES +*---- + INTEGER :: NPQD(12),IIND(12),P,DCOORD + REAL :: JAC(2,2,3),MUH,ETAH,XIH,AAA,BBB,CCC,DDD,MUHTEMP,ETAHTEMP, + 1 WX0(IELEM+1),WY0(IELEM+1),WZ0(IELEM+1) + DOUBLE PRECISION :: V,Q(NM),Q2(NM,NM+1),THETA,XNI(NMX), + > XNJ(NMY),XNK(NMZ) + PARAMETER(IUNOUT=6,RLOG=1.0E-8,PI=3.141592654) + LOGICAL ISFIX(3),LHEX(NHEX) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: III,JJJ,KKK + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: INDANG + INTEGER, ALLOCATABLE, DIMENSION(:,:,:,:,:,:) :: TMPMAT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: FLUX + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:,:,:) :: FLUX_G + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:,:,:) :: TMPXNI, + > TMPXNJ, TMPXND + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:,:,:,:) :: TMPXNK + + ! CALL XABORT('SNFKH3: testing 1') +*---- +* MAP MATERIAL VALUES TO CARTESIAN AXIAL COORDINATE MAP +*---- + NRINGS=INT((SQRT( REAL((4*NHEX-1)/3) )+1.)/2.) + NCOL=2*NRINGS -1 + ALLOCATE(TMPMAT(ISPLH,ISPLH,3,NCOL,NCOL,LZ)) + TMPMAT(:,:,:,:,:,:) = -1 + DO IZ=1,LZ + DO IHEX_XY=1,NHEX + TMPMAT(:,:,:,COORDMAP(1,IHEX_XY),COORDMAP(2,IHEX_XY),IZ) = + > MAT(:,:,:,IHEX_XY,IZ) + ENDDO + ENDDO +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(INDANG(NPQ,12)) + ALLOCATE(FLUX(NM,NSCT)) + ALLOCATE(FLUX_G(NM,NSCT,3*ISPLH**2,NHEX,LZ,NGEFF)) + ALLOCATE(TMPXNI(NMX,ISPLH,NCOL,LZ,NPQ,NGEFF)) + ALLOCATE(TMPXNJ(NMY,ISPLH,NCOL,LZ,NPQ,NGEFF)) + ALLOCATE(TMPXND(NMX,ISPLH,NCOL,LZ,NPQ,NGEFF)) + ALLOCATE(TMPXNK(NMZ,ISPLH,ISPLH,3,NHEX,NPQ,NGEFF)) +*---- +* CONSTRUCT JACOBIAN MATRIX FOR EACH LOZENGE +*---- + JAC = RESHAPE((/ 1., -SQRT(3.), 1., SQRT(3.), 2., 0., 1., + > SQRT(3.), 2., 0., -1., SQRT(3.) /), SHAPE(JAC)) + JAC = (SIDE/2.)*JAC +*---- +* LENGTH OF FUNKNO COMPONENTS (IN ORDER) +*---- + LFLX=3*NM*(ISPLH**2)*NHEX*LZ*NSCT + L5=3*NMZ*(ISPLH**2)*NHEX +*---- +* NUMBER OF MACROCELLS (MACRO*) +* NUMBER OF LZ LAYERS IN EACH MACROCELL (NCELL*) +*---- + MACROZ=NKBA + NCELLZ = (LZ + MACROZ - 1) / MACROZ +*---- +* SET DODECANT SWAPPING ORDER. +*---- + NPQD(:12)=0 + INDANG(:NPQ,:12)=0 + IIND(:12)=0 + DO M=1,NPQ + VU=DU(M) + VE=DE(M) + VZ=DZ(M) + IF(W(M).EQ.0) CYCLE + THETA=0.0D0 + IF(VE.GT.0.0)THEN + IF(VU.EQ.0.0)THEN + THETA = PI/2 + ELSEIF(VU.GT.0.0)THEN + THETA = ATAN(ABS(VE/VU)) + ELSEIF(VU.LT.0.0)THEN + THETA = PI - ATAN(ABS(VE/VU)) + ENDIF + ELSEIF(VE.LT.0.0)THEN + IF(VU.EQ.0.0)THEN + THETA = 3*PI/2 + ELSEIF(VU.LT.0.0)THEN + THETA = PI + ATAN(ABS(VE/VU)) + ELSEIF(VU.GT.0.0)THEN + THETA = 2.*PI - ATAN(ABS(VE/VU)) + ENDIF + ENDIF + ! UNFOLD DODECANTS + IND=0 + IF(VZ.GE.0.0)THEN + IF((THETA.GT.0.0).AND.(THETA.LT.(PI/3.)))THEN + IND=1 + ELSEIF((THETA.GT.(PI/3.)).AND.(THETA.LT.(2.*PI/3.)))THEN + IND=2 + ELSEIF((THETA.GT.(2.*PI/3.)).AND.(THETA.LT.(PI)))THEN + IND=3 + ELSEIF((THETA.GT.(PI)).AND.(THETA.LT.(4.*PI/3.)))THEN + IND=4 + ELSEIF((THETA.GT.(4.*PI/3.)).AND.(THETA.LT.(5.*PI/3.)))THEN + IND=5 + ELSEIF((THETA.GT.(5.*PI/3.)).AND.(THETA.LT.(2.*PI)))THEN + IND=6 + ENDIF + ELSEIF(VZ.LT.0.0)THEN + IF((THETA.GT.0.0).AND.(THETA.LT.(PI/3.)))THEN + IND=7 + ELSEIF((THETA.GT.(PI/3.)).AND.(THETA.LT.(2.*PI/3.)))THEN + IND=8 + ELSEIF((THETA.GT.(2.*PI/3.)).AND.(THETA.LT.(PI)))THEN + IND=9 + ELSEIF((THETA.GT.(PI)).AND.(THETA.LT.(4.*PI/3.)))THEN + IND=10 + ELSEIF((THETA.GT.(4.*PI/3.)).AND.(THETA.LT.(5.*PI/3.)))THEN + IND=11 + ELSEIF((THETA.GT.(5.*PI/3.)).AND.(THETA.LT.(2.*PI)))THEN + IND=12 + ENDIF + ENDIF + ! Assume IIND(I)=I in hexagonal geometry + IIND(IND)=IND + NPQD(IND)=NPQD(IND)+1 + INDANG(NPQD(IND),IND)=M + ENDDO +*---- +* MAIN LOOP OVER DODECANTS. +*---- + + FLUX_G(:NM,:NSCT,:3*ISPLH**2,:NHEX,:LZ,:NGEFF)=0.0D0 + WX0=WX + WY0=WY + WZ0=WZ + + DO JND=1,12 + IND=IIND(JND) + IND_XY=MOD(IND-1,6)+1 + ! Needed because of S2 LS (8 dir. for 12 dodecants) + IF(IND.EQ.0) CYCLE +*---- +* PRELIMINARY LOOPS FOR SETTING BOUNDARY CONDITIONS. +*---- + + IF((NCODE(5).NE.1).or.(NCODE(6).NE.1))THEN +*$OMP PARALLEL DO +*$OMP+ PRIVATE(M,IG,VZ,M1,IOF,JOF,IPQD) +*$OMP+ SHARED(FUNKNO) COLLAPSE(2) + + DO IG=1,NGEFF + DO IPQD=1,NPQD(IND) + IF(.NOT.INCONV(IG)) CYCLE + M=INDANG(IPQD,IND) + + VZ=DZ(M) + ! Z-BOUNDARY + IF(VZ.GT.0.0)THEN + M1=MRMZ(M) + IF(NCODE(5).NE.4)THEN + IOF=(M-1)*(L5) + JOF=(M1-1)*(L5) + FUNKNO(LFLX+IOF+1:LFLX+IOF+L5,IG)= + > FUNKNO(LFLX+JOF+1:LFLX+JOF+L5,IG) + ENDIF + ELSEIF(VZ.LT.0.0)THEN + M1=MRMZ(M) + IF(NCODE(6).NE.4)THEN + IOF=(M-1)*(L5) + JOF=(M1-1)*(L5) + FUNKNO(LFLX+IOF+1:LFLX+IOF+L5,IG)= + > FUNKNO(LFLX+JOF+1:LFLX+JOF+L5,IG) + ENDIF + ENDIF +* + ENDDO + ENDDO + +*$OMP END PARALLEL DO + ENDIF + + TMPXNI(:NMX,:ISPLH,:NCOL,:LZ,:NPQ,:NGEFF)=0.0D0 + TMPXNJ(:NMY,:ISPLH,:NCOL,:LZ,:NPQ,:NGEFF)=0.0D0 + TMPXND(:NMX,:ISPLH,:NCOL,:LZ,:NPQ,:NGEFF)=0.0D0 + TMPXNK(:NMZ,:ISPLH,:ISPLH,:3,:NHEX,:NPQ,:NGEFF)=0.0D0 + +*---- +* LOOP OVER WAVEFRONTS +*---- + DO IDI=1,NCOL+NCOL+MACROZ-2 +*---- +* SET SWEEP INDICES +*---- + NMAX=MIN(NCOL,IDI)*MIN(NCOL,IDI) + ALLOCATE(III(NMAX),JJJ(NMAX),KKK(NMAX)) + NCEL=0 + + J_STT=MAX(1,IDI-NCOL-MACROZ+2) + J_END=MIN(NCOL,IDI) + + DO J_MC=J_STT,J_END + JIM=J_MC + ! Account for different sweep direction depending on angle + IF((IND_XY.EQ.1).OR.(IND_XY.EQ.2).OR.(IND_XY.EQ.3)) JIM=NCOL+1-JIM + + IF((IND_XY.EQ.1).OR.(IND_XY.EQ.4)) THEN + I_STT=MAX(1,IDI-J_MC-MACROZ+2) + I_END=MIN(NCOL,IDI-J_MC+1) + ELSE + I_STT=MAX(1,NRINGS-J_MC+1) + I_END=MIN(NCOL,IDI-J_MC+(NRINGS+1-J_MC)) + ENDIF + + DO I_MC=I_STT,I_END + IIM=I_MC + ! Account for different sweep direction depending on angle + IF((IND_XY.EQ.2).OR.(IND_XY.EQ.3).OR.(IND_XY.EQ.4)) IIM=NCOL+1-IIM + + ! For IND_XY 3 or 6, Cartesian axial coordinate map is swept + ! vertically instead of horizontally. IM suffix is for 'IMmutable' + I=IIM + J=JIM + IF((IND_XY.EQ.3).OR.(IND_XY.EQ.6))THEN + I=JIM + J=IIM + ENDIF + + ! If within corners of Cartesian axial coordinate map (where + ! there are no hexagons), skip loop + IF(TMPMAT(1,1,1,I,J,1).EQ.-1) CYCLE + + ! Find I coordinate of macrocell + IF((IND_XY.EQ.1).OR.(IND_XY.EQ.4)) THEN + K_MC=IDI-I_MC-J_MC+2 + ELSE + K_MC=IDI-I_MC+NRINGS-((J_MC-1)*2) + ENDIF + IF((K_MC.GT.MACROZ)) CYCLE + K=K_MC + + NCEL=NCEL+1 + IF(NCEL.GT.NMAX) CALL XABORT('SNFDH3: NMAX OVERFLOW.') + III(NCEL)=I + JJJ(NCEL)=J + KKK(NCEL)=K + ENDDO ! I_MC + + ENDDO ! J_MC +* +*---- +* MAIN SWAPPING LOOPS FOR SN FLUX CALCULATION +* LOOP OVER MACROCELLS IN WAVEFRONT AND ENERGY +*---- +*$OMP PARALLEL DO +*$OMP+ PRIVATE(ITID,FLUX,M,IG,XNI,XNJ,XNK,Q,Q2,IOF,IER,II,JJ,I,J,K,K_MC) +*$OMP+ PRIVATE(IPQD,IBM,SIGMA,V,ISFIX,IX,JX,IY,JY,IZ,JZ,AAA,BBB,CCC,DDD) +*$OMP+ PRIVATE(IIX,IIY,IIZ,P,IEL) +*$OMP+ PRIVATE(LHEX,IHEX_XY,IIHEX,DCOORD,ILOZLOOP,ILOZ,IL,I2,JL,J2) +*$OMP+ PRIVATE(MUHTEMP,MUH,ETAHTEMP,ETAH,XIH,I3,I_FETCH) +*$OMP+ SHARED(IND,TMPXNI,TMPXNJ,TMPXND,TMPXNK,III,JJJ,KKK,FUNKNO) +*$OMP+ FIRSTPRIVATE(WX,WY,WZ,WX0,WY0,WZ0) +*$OMP+ COLLAPSE(2) + + ! LOOP FOR MACROCELLS TO EXECUTE IN PARALLEL + DO ICEL=1,NCEL + + ! LOOP FOR GROUPS TO EXECUTE IN PARALLEL + DO IG=1,NGEFF + + ! LOOP OVER ALL DIRECTIONS + DO IPQD=1,NPQD(IND) + IF(.NOT.INCONV(IG)) CYCLE + M=INDANG(IPQD,IND) + IF(W(M).EQ.0.0) CYCLE + + ! GET AND PRINT THREAD NUMBER +#if defined(_OPENMP) + ITID=omp_get_thread_num() +#else + ITID=0 +#endif + IF(IMPX.GT.5) WRITE(IUNOUT,500) ITID,NGIND(IG),IPQD + + I=III(ICEL) + J=JJJ(ICEL) + K_MC=KKK(ICEL) + + ! Find in X-Y plane DRAGON geometry hexagonal index using I and J + LHEX=(COORDMAP(1,:).EQ.I .AND. COORDMAP(2,:).EQ.J) + IHEX_XY=0 + DO IIHEX=1,NHEX + IF(LHEX(IIHEX)) THEN + IHEX_XY=IIHEX + EXIT + ENDIF + ENDDO + IF(IHEX_XY.EQ.0) CALL XABORT('SNFDH3: IHEX_XY FAILURE.') + ! Find D coordinate + DCOORD = ABS(COORDMAP(3,IHEX_XY))-NRINGS + + IF(IDI.EQ.1)THEN + ! PICK UP BOUNDARY ELEMENTS + IF((NCODE(5).NE.1).or.(NCODE(6).NE.1))THEN + IOF=(M-1)*(L5) + 1 + TMPXNK(:NMZ,:ISPLH,:ISPLH,:3,:NHEX,IPQD,IG)= + > RESHAPE(FUNKNO(LFLX+IOF:LFLX+IOF+L5,IG), + > (/NMZ,ISPLH,ISPLH,3,NHEX/)) + ENDIF + ! ACCOUNT FOR ALBEDO IN BOUNDARY ELEMENTS + IF(IND.LT.7) THEN + TMPXNK(:NMZ,:ISPLH,:ISPLH,:3,:NHEX,IPQD,IG)= + > TMPXNK(:NMZ,:ISPLH,:ISPLH,:3,:NHEX,IPQD,IG)*ZCODE(5) + ELSE + TMPXNK(:NMZ,:ISPLH,:ISPLH,:3,:NHEX,IPQD,IG)= + > TMPXNK(:NMZ,:ISPLH,:ISPLH,:3,:NHEX,IPQD,IG)*ZCODE(6) + ENDIF + ENDIF + +*---- +* LOOP OVER Z-AXIS PLANES IN MACROCELL +*---- + + DO IMZ=1,MIN(NCELLZ,LZ-(K_MC-1)*NCELLZ) + K=(K_MC-1)*NCELLZ+IMZ + IF(IND.GE.7) K=LZ+1-K + +*---- +* LOOP OVER LOZENGES +*---- + + DO ILOZLOOP=1,3 + ILOZ=LOZSWP(ILOZLOOP,IND_XY) + + ! Get Jacobian elements values + AAA = JAC(1,1,ILOZ) + BBB = JAC(1,2,ILOZ) + CCC = JAC(2,1,ILOZ) + DDD = JAC(2,2,ILOZ) + + ! CALL XABORT('SNFKH3: testing 19 ') +*---- +* LOOP OVER SUBMESH WITHIN EACH LOZENGE +*---- + DO IL=1,ISPLH + I2=IL + ! Account for different sweep direction depending on angle + IF((ILOZ.EQ.1).OR.(ILOZ.EQ.2))THEN + IF((IND_XY.EQ.2).OR.(IND_XY.EQ.3).OR.(IND_XY.EQ.4))I2=ISPLH+1-I2 + ELSEIF(ILOZ.EQ.3)THEN + IF((IND_XY.EQ.3).OR.(IND_XY.EQ.4).OR.(IND_XY.EQ.5))I2=ISPLH+1-I2 + ENDIF + + DO JL=1,ISPLH + J2=JL + ! Account for different sweep direction depending on angle + IF((ILOZ.EQ.2).OR.(ILOZ.EQ.3))THEN + IF((IND_XY.EQ.4).OR.(IND_XY.EQ.5).OR.(IND_XY.EQ.6))J2=ISPLH+1-J2 + ELSEIF(ILOZ.EQ.1)THEN + IF((IND_XY.EQ.3).OR.(IND_XY.EQ.4).OR.(IND_XY.EQ.5))J2=ISPLH+1-J2 + ENDIF + + FLUX(:IELEM**3,:NSCT)=0.0D0 + + ! READ IN XNI AND XNJ DEPENDING ON LOZENGE + I_FETCH=0 + IF((ILOZ.EQ.1))THEN + ! Read boundary fluxes in reverse for lozenge A since affine + ! transformation of lozenges causes the D and I directions + ! of lozenges C and A respectively to be reversed + I_FETCH=ISPLH+1-I2 + XNI(:) = TMPXNI(:,J2,J,K,IPQD,IG) + XNJ(:) = TMPXND(:,I_FETCH,DCOORD,K,IPQD,IG) + ELSEIF((ILOZ.EQ.2))THEN + XNI(:) = TMPXNI(:,J2,J,K,IPQD,IG) + XNJ(:) = TMPXNJ(:,I2,I,K,IPQD,IG) + ELSEIF((ILOZ.EQ.3))THEN + XNI(:) = TMPXND(:,J2,DCOORD,K,IPQD,IG) + XNJ(:) = TMPXNJ(:,I2,I,K,IPQD,IG) + ENDIF + XNK(:) = TMPXNK(:,I2,J2,ILOZ,IHEX_XY,IPQD,IG) + + ! DATA + IBM=MAT(I2,J2,ILOZ,IHEX_XY,K) + ! Skip loop if virtual element + IF(IBM.EQ.0) CYCLE + SIGMA=TOTAL(IBM,IG) + V=VOL(I2,J2,ILOZ,IHEX_XY,K) + + ! COMPUTE ADJUSTED DIRECTION COSINES + MUHTEMP = DA(1,K,M) + ETAHTEMP = DB(1,K,M) + MUH = (MUHTEMP*DDD) - (ETAHTEMP*BBB) + ETAH = (-MUHTEMP*CCC) + (ETAHTEMP*AAA) + XIH = DC(1,1,M) + + ! IF(IND.EQ.12) CALL XABORT('SNFKH3: testing 60 ') + ! WRITE(*,*) (((((((K-1)*NHEX+(IHEX_XY-1))*3+(ILOZ-1))*ISPLH+ + ! > (J2-1))*ISPLH+(I2-1))*NSCT+(2-1))*NM)+1 + ! WRITE(*,*) K, NHEX, IHEX_XY, ILOZ, ISPLH, J2, I2, NSCT, NM + ! CALL XABORT('SNFKH3: testing 2') + ! SOURCE DENSITY TERM + DO IEL=1,NM + Q(IEL)=0.0D0 + DO P=1,NSCT + IOF=(((((((K-1)*NHEX+(IHEX_XY-1))*3+(ILOZ-1))*ISPLH+(J2-1))* + > ISPLH+(I2-1))*NSCT+(P-1))*NM)+IEL + Q(IEL)=Q(IEL)+QEXT(IOF,IG)*MN(M,P) + ENDDO + ENDDO + + ! CALL XABORT('SNFKH3: testing 17 ') + ISFIX=.FALSE. + DO WHILE (.NOT.ALL(ISFIX)) ! LOOP FOR ADAPTIVE CALCULATION + + ! FLUX MOMENT COEFFICIENTS MATRIX + Q2(:NM,:NM+1)=0.0D0 + DO IZ=1,IELEM + DO JZ=1,IELEM + DO IY=1,IELEM + DO JY=1,IELEM + DO IX=1,IELEM + DO JX=1,IELEM + + II=IELEM**2*(IZ-1)+IELEM*(IY-1)+IX + JJ=IELEM**2*(JZ-1)+IELEM*(JY-1)+JX + + ! IF(IPQD.EQ.3) CALL XABORT('SNFKH3: testing 69 ') + ! CALL XABORT('SNFKH3: testing 17 ') + ! DIAGONAL TERMS + IF(II.EQ.JJ) THEN + Q2(II,JJ)=SIGMA*V + 1 +CST(IX)**2*WX(JX+1)*ABS(MUH) + 2 +CST(IY)**2*WY(JY+1)*ABS(ETAH) + 3 +CST(IZ)**2*WZ(JZ+1)*ABS(XIH) + + ! IF(IND.EQ.12) CALL XABORT('SNFKH3: testing 70 ') + ! CALL XABORT('SNFKH3: testing 191 ') + ! UPPER DIAGONAL TERMS + ELSEIF(II.LT.JJ) THEN + ! CALL XABORT('SNFKH3: testing 1919 ') + IF(IZ.EQ.JZ) THEN + IF(IY.EQ.JY) THEN + ! X-SPACE TERMS + IF(MOD(IX+JX,2).EQ.1) THEN + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*MUH + ELSE + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*ABS(MUH) + ENDIF + ELSEIF(IX.EQ.JX) THEN + ! Y-SPACE TERMS + IF(MOD(IY+JY,2).EQ.1) THEN + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ETAH + ELSE + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ABS(ETAH) + ENDIF + ENDIF + ELSEIF(IY.EQ.JY.AND.IX.EQ.JX) THEN + ! Z-SPACE TERMS + IF(MOD(IZ+JZ,2).EQ.1) THEN + Q2(II,JJ)=CST(IZ)*CST(JZ)*WZ(JZ+1)*XIH + ELSE + Q2(II,JJ)=CST(IZ)*CST(JZ)*WZ(JZ+1)*ABS(XIH) + ENDIF + ENDIF + ! IF(IND.EQ.12) CALL XABORT('SNFKH3: testing 75 ') + ! CALL XABORT('SNFKH3: testing 19 ') + + ! UNDER DIAGONAL TERMS + ELSE + ! CALL XABORT('SNFKH3: testing 1920 ') + IF(IZ.EQ.JZ) THEN + IF(IY.EQ.JY) THEN + ! X-SPACE TERMS + IF(MOD(IX+JX,2).EQ.1) THEN + Q2(II,JJ)=CST(IX)*CST(JX)*(WX(JX+1)-2)*MUH + ELSE + Q2(II,JJ)=CST(IX)*CST(JX)*WX(JX+1)*ABS(MUH) + ENDIF + ELSEIF(IX.EQ.JX) THEN + ! Y-SPACE TERMS + IF(MOD(IY+JY,2).EQ.1) THEN + Q2(II,JJ)=CST(IY)*CST(JY)*(WY(JY+1)-2)*ETAH + ELSE + Q2(II,JJ)=CST(IY)*CST(JY)*WY(JY+1)*ABS(ETAH) + ENDIF + ENDIF + ELSEIF(IY.EQ.JY.AND.IX.EQ.JX) THEN + ! Z-SPACE TERMS + IF(MOD(IZ+JZ,2).EQ.1) THEN + Q2(II,JJ)=CST(IZ)*CST(JZ)*(WZ(JZ+1)-2)*XIH + ELSE + Q2(II,JJ)=CST(IZ)*CST(JZ)*WZ(JZ+1)*ABS(XIH) + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + + ! FLUX SOURCE VECTOR + DO IZ=1,IELEM + DO IY=1,IELEM + DO IX=1,IELEM + II=IELEM**2*(IZ-1)+IELEM*(IY-1)+IX + IIX=IELEM*(IZ-1)+IY + IIY=IELEM*(IZ-1)+IX + IIZ=IELEM*(IY-1)+IX + Q2(II,NM+1)=Q(II)*V + ! X-SPACE TERMS + IF(MOD(IX,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IX)*(1-WX(1)) + 1 *XNI(IIX)*ABS(MUH) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IX)*(1+WX(1)) + 1 *XNI(IIX)*MUH + ENDIF + ! Y-SPACE TERMS + IF(MOD(IY,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IY)*(1-WY(1)) + 1 *XNJ(IIY)*ABS(ETAH) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IY)*(1+WY(1)) + 1 *XNJ(IIY)*ETAH + ENDIF + ! Z-SPACE TERMS + IF(MOD(IZ,2).EQ.1) THEN + Q2(II,NM+1)=Q2(II,NM+1)+CST(IZ)*(1-WZ(1)) + 1 *XNK(IIZ)*ABS(XIH) + ELSE + Q2(II,NM+1)=Q2(II,NM+1)-CST(IZ)*(1+WZ(1)) + 1 *XNK(IIZ)*XIH + ENDIF + ENDDO + ENDDO + ENDDO + + CALL ALSBD(NM,1,Q2,IER,NM) + IF(IER.NE.0) CALL XABORT('SNFKH3: SINGULAR MATRIX.') + + ! ADAPTIVE CORRECTION OF WEIGHTING PARAMETERS + IF(ANY(ISADPT)) THEN + IF(ISADPT(1)) THEN + CALL SNADPT(IELEM,NM,IELEM**2,Q2(1:IELEM:1,NM+1), + 1 XNI(:NMX),1.0,WX,ISFIX(1)) + ELSE + ISFIX(1)=.TRUE. + ENDIF + IF(ISADPT(2)) THEN + CALL SNADPT(IELEM,NM,IELEM**2,Q2(1:IELEM**2:IELEM,NM+1), + 1 XNJ(:NMY),1.0,WY,ISFIX(2)) + ELSE + ISFIX(2)=.TRUE. + ENDIF + IF(ISADPT(3)) THEN + CALL SNADPT(IELEM,NM,IELEM**2,Q2(1:NM:IELEM**2,NM+1), + 1 XNK(:NMZ),1.0,WZ,ISFIX(3)) + ELSE + ISFIX(3)=.TRUE. + ENDIF + ELSE + ISFIX=.TRUE. + ENDIF + + END DO ! END OF ADAPTIVE LOOP + + ! CLOSURE RELATIONS + IF(IELEM.EQ.1.AND.LFIXUP.AND.(Q2(1,2).LE.RLOG)) Q2(1,2)=0.0 + ! Read XNI/XNI/XNK into TMPXNI/J/D/K + IF((ILOZ.EQ.1).OR.(ILOZ.EQ.2))THEN + TMPXNI(:NMX,J2,J,K,IPQD,IG)=WX(1)*XNI(:NMX) + ELSE + TMPXND(:NMX,J2,DCOORD,K,IPQD,IG)=WX(1)*XNI(:NMX) + ENDIF + IF((ILOZ.EQ.2).OR.(ILOZ.EQ.3))THEN + TMPXNJ(:NMY,I2,I,K,IPQD,IG)=WY(1)*XNJ(:NMY) + ELSE + I3=I_FETCH + TMPXND(:NMY,I3,DCOORD,K,IPQD,IG)=WY(1)*XNJ(:NMY) + ENDIF + TMPXNK(:NMZ,I2,J2,ILOZ,IHEX_XY,IPQD,IG)=WZ(1)*XNK(:NMZ) + DO IZ=1,IELEM + DO IY=1,IELEM + DO IX=1,IELEM + II=IELEM**2*(IZ-1)+IELEM*(IY-1)+IX + IIX=IELEM*(IZ-1)+IY + IIY=IELEM*(IZ-1)+IX + IIZ=IELEM*(IY-1)+IX + ! X-SPACE + ! Assign I-boundary fluxes if lozenges A or B + IF((ILOZ.EQ.1).OR.(ILOZ.EQ.2))THEN + IF(MOD(IX,2).EQ.1) THEN + TMPXNI(IIX,J2,J,K,IPQD,IG)=TMPXNI(IIX,J2,J,K,IPQD,IG)+ + 1 CST(IX)*WX(IX+1)*Q2(II,NM+1) + ELSE + TMPXNI(IIX,J2,J,K,IPQD,IG)=TMPXNI(IIX,J2,J,K,IPQD,IG)+ + 1 CST(IX)*WX(IX+1)*Q2(II,NM+1)*SIGN(1.0,MUH) + ENDIF + ENDIF + ! Y-SPACE + ! Assign J-boundary fluxes if lozenges B or C + IF((ILOZ.EQ.2).OR.(ILOZ.EQ.3))THEN + IF(MOD(IY,2).EQ.1) THEN + TMPXNJ(IIY,I2,I,K,IPQD,IG)=TMPXNJ(IIY,I2,I,K,IPQD,IG)+ + 1 CST(IY)*WY(IY+1)*Q2(II,NM+1) + ELSE + TMPXNJ(IIY,I2,I,K,IPQD,IG)=TMPXNJ(IIY,I2,I,K,IPQD,IG)+ + 1 CST(IY)*WY(IY+1)*Q2(II,NM+1)*SIGN(1.0,ETAH) + ENDIF + ENDIF + ! D-SPACE + ! Assign D-boundary fluxes if lozenge A using XNJ + IF((ILOZ.EQ.1))THEN + I3=I_FETCH + IF(MOD(IY,2).EQ.1) THEN + TMPXND(IIY,I3,DCOORD,K,IPQD,IG)= + 1 TMPXND(IIY,I3,DCOORD,K,IPQD,IG)+CST(IY)*WY(IY+1)*Q2(II,NM+1) + ELSE + TMPXND(IIY,I3,DCOORD,K,IPQD,IG)= + 1 TMPXND(IIY,I3,DCOORD,K,IPQD,IG)+CST(IY)*WY(IY+1) + 1 *Q2(II,NM+1)*SIGN(1.0,ETAH) + ENDIF + ENDIF + ! Assign D-boundary fluxes if lozenge C using XNI + IF((ILOZ.EQ.3))THEN + IF(MOD(IX,2).EQ.1) THEN + TMPXND(IIX,J2,DCOORD,K,IPQD,IG)= + 1 TMPXND(IIX,J2,DCOORD,K,IPQD,IG)+CST(IX)*WX(IX+1)*Q2(II,NM+1) + ELSE + TMPXND(IIX,J2,DCOORD,K,IPQD,IG)= + 1 TMPXND(IIX,J2,DCOORD,K,IPQD,IG)+CST(IX)*WX(IX+1) + 1 *Q2(II,NM+1)*SIGN(1.0,MUH) + ENDIF + ENDIF + ! Z-SPACE + IF(MOD(IZ,2).EQ.1) THEN + TMPXNK(IIZ,I2,J2,ILOZ,IHEX_XY,IPQD,IG)= + 1 TMPXNK(IIZ,I2,J2,ILOZ,IHEX_XY,IPQD,IG)+ + 1 CST(IZ)*WZ(IZ+1)*Q2(II,NM+1) + ELSE + TMPXNK(IIZ,I2,J2,ILOZ,IHEX_XY,IPQD,IG)= + 1 TMPXNK(IIZ,I2,J2,ILOZ,IHEX_XY,IPQD,IG)+ + 1 CST(IZ)*WZ(IZ+1)*Q2(II,NM+1)*SIGN(1.0,XIH) + ENDIF + ENDDO + ENDDO + ENDDO + ! FLIP GRADIENTS IF NECESSARY + DO IZ=1,IELEM + DO IY=1,IELEM + IIX=IELEM*(IZ-1)+IY + IF((MOD(IY,2).EQ.0).AND.(ILOZ.EQ.3).AND.(IL.EQ.ISPLH)) + 1 TMPXND(IIX,J2,DCOORD,K,IPQD,IG)= + 1 TMPXND(IIX,J2,DCOORD,K,IPQD,IG)*(-1) + ENDDO + ENDDO + I3=I_FETCH + DO IZ=1,IELEM + DO IX=1,IELEM + IIY=IELEM*(IZ-1)+IX + IF((MOD(IX,2).EQ.0).AND.(ILOZ.EQ.1).AND.(JL.EQ.ISPLH)) + 1 TMPXND(IIY,I3,DCOORD,K,IPQD,IG)= + 1 TMPXND(IIY,I3,DCOORD,K,IPQD,IG)*(-1) + ENDDO + ENDDO + ! LFIXUP + IF(IELEM.EQ.1.AND.LFIXUP)THEN + IF((ILOZ.EQ.1).OR.(ILOZ.EQ.2))THEN + IF(TMPXNI(1,J2,J,K,IPQD,IG).LE.RLOG) + 1 TMPXNI(1,J2,J,K,IPQD,IG)=0.0 + ELSE + IF(TMPXND(1,J2,DCOORD,K,IPQD,IG).LE.RLOG) + 1 TMPXND(1,J2,DCOORD,K,IPQD,IG)=0.0 + ENDIF + IF((ILOZ.EQ.2).OR.(ILOZ.EQ.3))THEN + IF(TMPXNJ(1,I2,I,K,IPQD,IG).LE.RLOG) + 1 TMPXNJ(1,I2,I,K,IPQD,IG)=0.0 + ELSE + I3=I_FETCH + IF(TMPXND(1,I3,DCOORD,K,IPQD,IG).LE.RLOG) + 1 TMPXND(1,I3,DCOORD,K,IPQD,IG)=0.0 + ENDIF + IF(TMPXNK(1,I2,J2,ILOZ,IHEX_XY,IPQD,IG).LE.RLOG) + 1 TMPXNK(1,I2,J2,ILOZ,IHEX_XY,IPQD,IG)=0.0 + ENDIF + WX=WX0 + WY=WY0 + WZ=WZ0 + + ! SAVE LEGENDRE MOMENT OF THE FLUX + DO P=1,NSCT + DO IEL=1,NM + FLUX(IEL,P)=FLUX(IEL,P)+Q2(IEL,NM+1)*DN(P,M) + ENDDO + ENDDO + + IOF=((ILOZ-1)*ISPLH+(J2-1))*ISPLH+I2 + FLUX_G(:,:,IOF,IHEX_XY,K,IG)=FLUX_G(:,:,IOF,IHEX_XY,K,IG)+ + 1 FLUX(:,:) + + ENDDO ! END OF WITHIN LOZENGE J-LOOP + ENDDO ! END OF WITHIN LOZENGE I-LOOP + + ENDDO ! END OF LOZENGE LOOP + ENDDO ! END OF Z-LOOP + + ! SAVE K-BOUNDARY CONDITIONS IF NOT VOID B.C. + IF(IDI.EQ.NCOL+NCOL+MACROZ-2)THEN + IF((NCODE(5).NE.1).or.(NCODE(6).NE.1))THEN + IOF=(M-1)*(L5) + FUNKNO(LFLX+IOF+1:LFLX+IOF+L5,IG)= + > RESHAPE(REAL(TMPXNK(:NMZ,:ISPLH,:ISPLH,:3,:NHEX,IPQD,IG)), + > (/L5/)) + ENDIF + ENDIF + + ENDDO ! END OF DIRECTION LOOP + ENDDO ! END OF ENERGY LOOP + ENDDO ! END OF MACROCELL (WITHIN ONE WAVEFRONT) LOOP +*$OMP END PARALLEL DO + DEALLOCATE(JJJ,III,KKK) + ENDDO ! END OF WAVEFRONT LOOP + ENDDO ! END OF OCTANT LOOP + + ! SAVE FLUX INFORMATION + DO IG=1,NGEFF + IF(.NOT.INCONV(IG)) CYCLE + FUNKNO(:LFLX,IG)= + 1 RESHAPE(REAL(FLUX_G(:NM,:NSCT,:3*ISPLH**2,:NHEX,:LZ,IG)), + 2 (/LFLX/)) + ENDDO +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(FLUX_G,FLUX,INDANG,TMPXNI,TMPXNJ,TMPXND,TMPXNK,TMPMAT) + RETURN + 500 FORMAT(16H SNFKH3: thread=,I8,12H --->(group=,I4,7H angle=,I4,1H)) + END diff --git a/Dragon/src/SNFLUX.f b/Dragon/src/SNFLUX.f new file mode 100644 index 0000000..09a832d --- /dev/null +++ b/Dragon/src/SNFLUX.f @@ -0,0 +1,1129 @@ +*DECK SNFLUX + SUBROUTINE SNFLUX(KPSYS,INCONV,NGIND,IPTRK,IMPX,NGEFF,NREG, + 1 NBMIX,NUN,MAT,VOL,KEYFLX,FUNKNO,SUNKNO,ITER,NBS,KPSOU1,KPSOU2, + 2 FLUXC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solve a single non-accelerated scattering iteration of the N-group +* transport equation for fluxes using the discrete ordinates (SN) +* method. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* KPSYS pointer to the assembly matrices. KPSYS is an array of +* directories. +* INCONV energy group convergence flag (set to .FALSE. if converged). +* NGIND energy group indices assign to the NGEFF set. +* IPTRK pointer to the tracking (L_TRACK signature). +* IMPX print flag (equal to zero for no print). +* NGEFF number of energy groups processed in parallel. +* NREG total number of regions for which specific values of the +* neutron flux and reactions rates are required. +* NBMIX number of mixtures. +* NUN total number of unknowns in vectors SUNKNO and FUNKNO. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX position of averaged flux elements in FUNKNO vector. +* SUNKNO input source vector. +* ITER number of previous calls to SNFLUX. +* NBS +* KPSOU1 +* KPSOU2 +* +*Parameters: input/output +* FUNKNO unknown vector. +* FLUXC flux at the cutoff energy. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) KPSYS(NGEFF),IPTRK,KPSOU1(NGEFF),KPSOU2(NGEFF) + INTEGER NGEFF,NGIND(NGEFF),IMPX,NREG,NBMIX,NUN,MAT(NREG), + 1 KEYFLX(NREG),ITER,NBS(NGEFF) + LOGICAL INCONV(NGEFF) + REAL VOL(NREG),FUNKNO(NUN,NGEFF),SUNKNO(NUN,NGEFF) + REAL,OPTIONAL :: FLUXC(NREG) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6,NSTATE=40) + INTEGER IPAR(NSTATE),NCODE(6),BSINFO(2),EELEM,ESCHM,P,Q, + > LOZSWP(3,6) + REAL ZCODE(6),SIDE,LAMBDA0 + LOGICAL LFIXUP,LDSA,LSHOOT,LADPT(4) +*---- +* ALLOCATABLE ARRAYS +*--- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KEYSPN + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: COORDMAP + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: ISBSM + REAL, ALLOCATABLE, DIMENSION(:,:) :: QEXT,OLD,SGAR,BS,EMOMTR, + 1 SIGMATR,MTR + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SGAS,ESTOPW +* + TYPE(C_PTR) U_PTR,W_PTR,PL_PTR,JOP_PTR,UPQ_PTR,WPQ_PTR,ALPHA_PTR, + 1 PLZ_PTR,SURF_PTR,XXX_PTR,DU_PTR,DE_PTR,MRM_PTR,MRMX_PTR,MRMY_PTR, + 2 MRMZ_PTR,DB_PTR,DA_PTR,DAL_PTR,DZ_PTR,DC_PTR,WX_PTR,WE_PTR, + 3 CST_PTR,MN_PTR,DN_PTR,IL_PTR + INTEGER, POINTER, DIMENSION(:) :: JOP,MRM,MRMX,MRMY,MRMZ,ISLG,IL + REAL, POINTER, DIMENSION(:) :: U,W,PL,UPQ,WPQ,ALPHA,PLZ,SURF,DU, + 1 DE,XXX,DB,DA,DAL,DZ,DC,DELTAE,WX,WE,CST,MN,DN +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(QEXT(NUN,NGEFF),KEYSPN(NREG),DELTAE(NGEFF),ISLG(NGEFF)) +*---- +* RECOVER SN SPECIFIC PARAMETERS. +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',IPAR) + ITYPE=IPAR(6) + NSCT=IPAR(7) + IELEM=IPAR(8) + ISCHM=IPAR(10) + L4=IPAR(11) + LX=IPAR(12) + LY=IPAR(13) + LZ=IPAR(14) + NLF=IPAR(15) + ISCAT=IPAR(16) + LFIXUP=IPAR(18).EQ.1 + LDSA=IPAR(19).EQ.1 + NSDSA=IPAR(21) + ISPLH=IPAR(26) + NKBA=IPAR(28) + IGAV=IPAR(29) + LSHOOT=.TRUE. + IF(IPAR(30).EQ.0) LSHOOT=.FALSE. + IBFP=IPAR(31) + EELEM=IPAR(35) + ESCHM=IPAR(36) + LADPT(1:4)=.FALSE. + IF(ESCHM.EQ.3) LADPT(1)=.TRUE. + IF(ISCHM.EQ.3) LADPT(2:4)=.TRUE. +*---- +* TEST FOR DSA and SAVE OLD FLUX. +*---- + LDSA=.FALSE. + IF(MOD(ITER,(NSDSA+1))==0) LDSA=.TRUE. + + IF(LDSA)THEN + ALLOCATE(OLD(NUN,NGEFF)) + OLD(:NUN,:NGEFF)=FUNKNO(:NUN,:NGEFF) + ENDIF +*---- +* RECOVER TOTAL AND WITHIN-GROUP SCATTERING MULTIGROUP CROSS SECTIONS. +*---- + ALLOCATE(SGAR(0:NBMIX,NGEFF),SGAS(0:NBMIX,ISCAT,NGEFF)) + ALLOCATE(ESTOPW(0:NBMIX,2,NGEFF),EMOMTR(0:NBMIX,NGEFF)) + NANI=1 + DO 10 II=1,NGEFF + IF(.NOT.INCONV(II)) GO TO 10 + CALL LCMLEN(KPSYS(II),'DRAGON-TXSC',ILONG,ITYLCM) + IF(ILONG.NE.NBMIX+1) CALL XABORT('SNFLUX: INVALID TXSC LENGTH.') + CALL LCMLEN(KPSYS(II),'DRAGON-S0XSC',ILONG,ITYLCM) + NANI=MAX(NANI,ILONG/(NBMIX+1)) + IF(NANI.GT.ISCAT) CALL XABORT('SNFLUX: INVALID S0XSC LENGTH.') + CALL LCMGET(KPSYS(II),'DRAGON-TXSC',SGAR(0,II)) + CALL LCMGET(KPSYS(II),'DRAGON-S0XSC',SGAS(0,1,II)) +*---- +* TEST FOR FOKKER-PLANCK TREATMENT. +*---- + IF(IBFP.GT.0) THEN + CALL LCMLEN(KPSYS(II),'DRAGON-ESTOP',IFP,ITYLCM) + IF(IFP.NE.(NBMIX+1)*2) CALL XABORT('SNFLUX: INVALID ESTOPW LEN' + 1 //'GTH.') + CALL LCMGET(KPSYS(II),'DRAGON-ESTOP',ESTOPW(0,1,II)) + CALL LCMGET(KPSYS(II),'DRAGON-DELTE',DELTAE(II)) + CALL LCMGET(KPSYS(II),'DRAGON-ISLG',ISLG(II)) + IF(ISLG(II).EQ.1) FLUXC(:)=0.0 + CALL LCMLEN(KPSYS(II),'DRAGON-EMOMT',IFP,ITYLCM) + IF(IFP.NE.NBMIX+1) CALL XABORT('SNFLUX: INVALID EMOMTR LENGTH.') + CALL LCMGET(KPSYS(II),'DRAGON-EMOMT',EMOMTR(0,II)) + ENDIF +*---- +* PRINT ZEROTH MOMENT OF SOURCES. +*---- + IF(IMPX.GT.3) THEN + WRITE(IUNOUT,500) NGIND(II) + WRITE(IUNOUT,'(1P,6(5X,E15.7))') (SUNKNO(KEYFLX(I),II),I=1,NREG) + ENDIF + 10 CONTINUE +*---- +* RECOVER INFORMATION ABOUT BOUNDARY SOURCES +*---- + ISBS=0 + MAXL=0 + IF(SUM(NBS).NE.0) THEN + ISBS=1 + IF(ITYPE.EQ.2) THEN + MAXL=1 + ALLOCATE(ISBSM(2,NLF,NGEFF)) + ELSE IF(ITYPE.EQ.5) THEN + MAXL=MAX(LX,LY) + CALL LCMLEN(IPTRK,'DU',NPQ,ITYLCM) + ALLOCATE(ISBSM(4,NPQ,NGEFF)) + ELSE IF(ITYPE.EQ.7) THEN + MAXL=MAX(LX*LY,LX*LZ,LY*LZ) + CALL LCMLEN(IPTRK,'DU',NPQ,ITYLCM) + ALLOCATE(ISBSM(6,NPQ,NGEFF)) + ELSE + CALL XABORT('SNFLUX: BOUNDARY SOURCE NOT IMPLEMENTED FOR THAT' + 1 //' GEOMETRY') + ALLOCATE(ISBSM(0,0,0),BS(0,0)) + ENDIF + ALLOCATE(BS(MAXL,SUM(NBS))) + BS=0.0 + ISBSM=0 + JJ=1 + DO 11 II=1,NGEFF + IF(NBS(II).NE.0) THEN + DO N=1,NBS(II) + CALL LCMGDL(KPSOU1(II),N,BS(1,JJ)) + CALL LCMGDL(KPSOU2(II),N,BSINFO) + ISBSM(BSINFO(1),BSINFO(2),II)=JJ + JJ=JJ+1 + ENDDO + ENDIF + 11 CONTINUE + ELSE + ALLOCATE(ISBSM(0,0,0),BS(0,0)) + ENDIF +*---- +* COMPUTE THE FLUX. +*---- + IF((ITYPE.EQ.2).AND.(IBFP.EQ.0)) THEN +*------------ +* 1D SLAB +*------------ + ! EXTRACTING PARAMETERS + IF(IELEM*NSCT*NREG.GT.NUN) CALL XABORT('SNFLUX: QEXT OVERFLOW' + 1 //'(1)') + CALL LCMGPD(IPTRK,'U',U_PTR) + CALL LCMGPD(IPTRK,'WX',WX_PTR) + CALL LCMGPD(IPTRK,'CST',CST_PTR) + CALL LCMGPD(IPTRK,'MN',MN_PTR) + CALL LCMGPD(IPTRK,'DN',DN_PTR) + CALL LCMGPD(IPTRK,'IL',IL_PTR) + CALL C_F_POINTER(U_PTR,U,(/ NLF /)) + CALL C_F_POINTER(WX_PTR,WX,(/ IELEM+1 /)) + CALL C_F_POINTER(CST_PTR,CST,(/ IELEM /)) + CALL C_F_POINTER(MN_PTR,MN,(/ NLF*NSCT /)) + CALL C_F_POINTER(DN_PTR,DN,(/ NLF*NSCT /)) + CALL C_F_POINTER(IL_PTR,IL,(/ NSCT /)) + CALL LCMGET(IPTRK,'NCODE',NCODE) + CALL LCMGET(IPTRK,'ZCODE',ZCODE) + + ! LOOP FOR GROUPS + DO 40 II=1,NGEFF + IF(.NOT.INCONV(II)) GO TO 40 + IF(IMPX.GT.2) WRITE(IUNOUT,510) NGIND(II),'SN/1D-slab' + + ! FIXED VOLUMIC SOURCES + QEXT(:NUN,II)=SUNKNO(:NUN,II) + + ! IN-GROUP SCATTERING + DO 30 IR=1,NREG + IBM=MAT(IR) + IF(IBM.EQ.0) GO TO 30 + DO 20 P=1,NSCT + IF(IL(P).GT.NANI-1) GO TO 20 + DO 15 IEL=1,IELEM + IND=(IR-1)*NSCT*IELEM+IELEM*(P-1)+IEL + QEXT(IND,II)=QEXT(IND,II)+SGAS(IBM,IL(P)+1,II)*FUNKNO(IND,II) + 15 CONTINUE + 20 CONTINUE + 30 CONTINUE + + ! ONE-SPEED FLUX CALCULATION + CALL SNFBC1(NREG,NBMIX,IELEM,NLF,NSCT,U,MAT,VOL,SGAR(0,II), + 1 NCODE,ZCODE,QEXT(1,II),LFIXUP,LSHOOT,ISBS,SUM(NBS), + 2 ISBSM(1,1,II),BS,WX,CST,LADPT(2),NUN,FUNKNO(1,II),MN,DN) + + 40 CONTINUE ! END OF ENERGY LOOP + + ELSE IF(ITYPE.EQ.2) THEN +*------------ +* 1D SLAB BOLTZMANN-FOKKER-PLANCK +*------------ + ! EXTRACTING PARAMETERS + NM=IELEM*EELEM + IF((IELEM*NLF+NM*NSCT)*NREG.GT.NUN) THEN + CALL XABORT('SNFLUX: QEXT OVERFLOW(1a)') + ENDIF + IOF=NM*NSCT*NREG+1 + CALL LCMGPD(IPTRK,'U',U_PTR) + CALL LCMGPD(IPTRK,'WX',WX_PTR) + CALL LCMGPD(IPTRK,'WE',WE_PTR) + CALL LCMGPD(IPTRK,'CST',CST_PTR) + CALL LCMGPD(IPTRK,'MN',MN_PTR) + CALL LCMGPD(IPTRK,'DN',DN_PTR) + CALL LCMGPD(IPTRK,'IL',IL_PTR) + CALL C_F_POINTER(U_PTR,U,(/ NLF /)) + CALL C_F_POINTER(WX_PTR,WX,(/ IELEM+1 /)) + CALL C_F_POINTER(WE_PTR,WE,(/ EELEM+1 /)) + CALL C_F_POINTER(CST_PTR,CST,(/ MAX(IELEM,EELEM) /)) + CALL C_F_POINTER(MN_PTR,MN,(/ NLF*NSCT /)) + CALL C_F_POINTER(DN_PTR,DN,(/ NLF*NSCT /)) + CALL C_F_POINTER(IL_PTR,IL,(/ NSCT /)) + CALL LCMGET(IPTRK,'NCODE',NCODE) + CALL LCMGET(IPTRK,'ZCODE',ZCODE) + + ! ANGULAR FOKKER-PLANCK OPERATOR + ALLOCATE(SIGMATR(NSCT,NSCT),MTR(NLF,NLF)) + SIGMATR=0.0 + DO P=1,NSCT + SIGMATR(P,P)=-IL(P)*(IL(P)+1) + ENDDO + MTR=MATMUL(MATMUL(RESHAPE(MN,[NLF,NSCT]),SIGMATR), + 1 RESHAPE(DN,[NSCT,NLF])) + LAMBDA0=0.0 + DO M=1,NLF + IF(MTR(M,M).LT.-LAMBDA0) LAMBDA0=-MTR(M,M) + ENDDO + DO M=1,NLF + MTR(M,M)=MTR(M,M)+LAMBDA0 + ENDDO + SIGMATR=MATMUL(MATMUL(RESHAPE(DN,[NSCT,NLF]),MTR), + 1 RESHAPE(MN,[NLF,NSCT])) + DEALLOCATE(MTR) + DO II=1,NGEFF + DO IBM=1,NBMIX + SGAR(IBM,II)=SGAR(IBM,II)+LAMBDA0*EMOMTR(IBM,II) + ENDDO + ENDDO + + ! LOOP FOR GROUPS + DO 80 II=1,NGEFF + IF(.NOT.INCONV(II)) GO TO 80 + IF(IMPX.GT.2) WRITE(IUNOUT,510) NGIND(II),'SN-BFP/1D-slab' + + ! FIXED VOLUMIC SOURCES + QEXT(:NUN,II)=SUNKNO(:NUN,II) + + ! IN-GROUP SCATTERING + DO 70 IR=1,NREG + IBM=MAT(IR) + IF(IBM.EQ.0) GO TO 70 + DO 60 P=1,NSCT + IF(IL(P).GT.NANI-1) GO TO 60 + DO 50 IEL=1,NM + IND=(IR-1)*NSCT*NM+NM*(P-1)+IEL + QEXT(IND,II)=QEXT(IND,II)+SGAS(IBM,IL(P)+1,II)*FUNKNO(IND,II) + DO Q=1,NSCT + JND=(IR-1)*NSCT*NM+NM*(Q-1)+IEL + QEXT(IND,II)=QEXT(IND,II)+EMOMTR(IBM,II)*SIGMATR(P,Q) + 1 *FUNKNO(JND,II) + ENDDO + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + + ! ONE-SPEED FLUX CALCULATION + CALL SNFE1D(NREG,NBMIX,IELEM,EELEM,NM,NLF,NSCT,U,MAT,VOL, + 1 SGAR(0,II),ESTOPW(0,1,II),NCODE,ZCODE,DELTAE(II),QEXT(1,II), + 2 LFIXUP,LSHOOT,FUNKNO(1,II),ISBS,SUM(NBS),ISBSM(1,1,II),BS,WX,WE, + 3 CST,LADPT(1:2),IBFP,NUN,MN,DN) + + ! SOLUTION FLUX AT THE CUTOFF ENERGY + IF(ISLG(II).EQ.1) THEN + LXNI=EELEM*NLF + IF(LSHOOT) LXNI=0 + DO 71 IR=1,NREG + IBM=MAT(IR) + FLUXC(IR)=0.0 + DO 72 IP=1,NLF + IND=NM*NSCT*NREG+LXNI+(IR-1)*NLF*IELEM+(IP-1)*IELEM+1 + JND=(IP-1)*NSCT+1 + FLUXC(IR)=FLUXC(IR)+FUNKNO(IND,II)*DN(JND) + 72 CONTINUE + 71 CONTINUE + ENDIF + + 80 CONTINUE ! END OF ENERGY LOOP + DEALLOCATE(SIGMATR) + + ELSE IF(ITYPE.EQ.3) THEN +*------------ +* 1D TUBE/CYLINDRICAL +*------------ + ! EXTRACTING PARAMETERS + IF(IELEM.NE.1) CALL XABORT('SNFLUX: DIAM 0 EXPECTED(1).') + IF(NSCT*NREG.GT.NUN) CALL XABORT('SNFLUX: QEXT OVERFLOW(2)') + M2=NLF/2 + CALL LCMLEN(IPTRK,'UPQ',NPQ,ITYLCM) + CALL LCMGPD(IPTRK,'JOP',JOP_PTR) + CALL LCMGPD(IPTRK,'U',U_PTR) + CALL LCMGPD(IPTRK,'UPQ',UPQ_PTR) + CALL LCMGPD(IPTRK,'WPQ',WPQ_PTR) + CALL LCMGPD(IPTRK,'ALPHA',ALPHA_PTR) + CALL LCMGPD(IPTRK,'PLZ',PLZ_PTR) + CALL LCMGPD(IPTRK,'PL',PL_PTR) + CALL LCMGPD(IPTRK,'SURF',SURF_PTR) + CALL LCMGET(IPTRK,'ZCODE',ZCODE) + CALL C_F_POINTER(JOP_PTR,JOP,(/ M2 /)) + CALL C_F_POINTER(U_PTR,U,(/ NPQ /)) + CALL C_F_POINTER(UPQ_PTR,UPQ,(/ NPQ /)) + CALL C_F_POINTER(WPQ_PTR,WPQ,(/ NPQ /)) + CALL C_F_POINTER(ALPHA_PTR,ALPHA,(/ NPQ /)) + CALL C_F_POINTER(PLZ_PTR,PLZ,(/ NSCT*M2 /)) + CALL C_F_POINTER(PL_PTR,PL,(/ NSCT*NPQ /)) + CALL C_F_POINTER(SURF_PTR,SURF,(/ NREG+1 /)) + + ! LOOP FOR GROUPS + DO 120 II=1,NGEFF + IF(.NOT.INCONV(II)) GO TO 120 + IF(IMPX.GT.2) WRITE(IUNOUT,510) NGIND(II),'SN/1D-cyl' + + ! FIXED VOLUMIC SOURCES + QEXT(:NUN,II)=SUNKNO(:NUN,II) + + ! IN-GROUP SCATTERING + DO 110 IR=1,NREG + IBM=MAT(IR) + IF(IBM.EQ.0) GO TO 110 + IOF=0 + DO 100 P=0,NANI-1 + DO 90 IM=0,P + IF(MOD(P+IM,2).EQ.1) GO TO 90 + IOF=IOF+1 + IND=(IR-1)*NSCT+IOF + QEXT(IND,II)=QEXT(IND,II)+SGAS(IBM,P+1,II)*FUNKNO(IND,II) + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE + + ! ONE-SPEED FLUX CALCULATION + CURR=0.0 + CALL SNFT1C(NREG,NBMIX,M2,NPQ,ISCAT,NSCT,JOP,U,UPQ,WPQ,ALPHA, + 1 PLZ,PL,MAT,VOL,SURF,SGAR(0,II),IGAV,QEXT(1,II),LFIXUP,CURR, + 2 FUNKNO(1,II)) + IF(ZCODE(2).NE.0.0) THEN + CA=CURR + CB=1.0 + CALL SNFT1C(NREG,NBMIX,M2,NPQ,ISCAT,NSCT,JOP,U,UPQ,WPQ,ALPHA, + 1 PLZ,PL,MAT,VOL,SURF,SGAR(0,II),IGAV,QEXT(1,II),LFIXUP,CB, + 2 FUNKNO(1,II)) + CURR=ZCODE(2)*CA/(1.0+ZCODE(2)*(CA-CB)) + CALL SNFT1C(NREG,NBMIX,M2,NPQ,ISCAT,NSCT,JOP,U,UPQ,WPQ,ALPHA, + 1 PLZ,PL,MAT,VOL,SURF,SGAR(0,II),IGAV,QEXT(1,II),LFIXUP,CURR, + 2 FUNKNO(1,II)) + ENDIF + + 120 CONTINUE ! END OF ENERGY LOOP + + ELSE IF(ITYPE.EQ.4) THEN +*------------ +* 1D SPHERE +*------------ + ! EXTRACTING PARAMETERS + IF(IELEM.NE.1) CALL XABORT('SNFLUX: DIAM 0 EXPECTED(2).') + NSCT=ISCAT + IF(NSCT*NREG.GT.NUN) CALL XABORT('SNFLUX: QEXT OVERFLOW(3)') + CALL LCMGPD(IPTRK,'U',U_PTR) + CALL LCMGPD(IPTRK,'W',W_PTR) + CALL LCMGPD(IPTRK,'ALPHA',ALPHA_PTR) + CALL LCMGPD(IPTRK,'PLZ',PLZ_PTR) + CALL LCMGPD(IPTRK,'PL',PL_PTR) + CALL LCMGPD(IPTRK,'SURF',SURF_PTR) + CALL LCMGPD(IPTRK,'XXX',XXX_PTR) + CALL LCMGET(IPTRK,'ZCODE',ZCODE) + CALL C_F_POINTER(U_PTR,U,(/ NLF /)) + CALL C_F_POINTER(W_PTR,W,(/ NLF /)) + CALL C_F_POINTER(ALPHA_PTR,ALPHA,(/ NLF /)) + CALL C_F_POINTER(PLZ_PTR,PLZ,(/ NSCT /)) + CALL C_F_POINTER(PL_PTR,PL,(/ NSCT*NLF /)) + CALL C_F_POINTER(SURF_PTR,SURF,(/ NREG+1 /)) + CALL C_F_POINTER(XXX_PTR,XXX,(/ NREG+1 /)) + + ! LOOP FOR GROUPS + DO 150 II=1,NGEFF + IF(.NOT.INCONV(II)) GO TO 150 + IF(IMPX.GT.2) WRITE(IUNOUT,510) NGIND(II),'SN/1D-sph' + + ! FIXED VOLUMIC SOURCES + QEXT(:NUN,II)=SUNKNO(:NUN,II) + + ! IN-GROUP SCATTERING + DO 140 IR=1,NREG + IBM=MAT(IR) + IF(IBM.EQ.0) GO TO 140 + DO 130 P=0,NANI-1 + IND=(IR-1)*NSCT+P+1 + QEXT(IND,II)=QEXT(IND,II)+SGAS(IBM,P+1,II)*FUNKNO(IND,II) + 130 CONTINUE + 140 CONTINUE + + ! ONE-SPEED FLUX CALCULATION + CURR=0.0 + CALL SNFT1S(NREG,NBMIX,NLF,NSCT,U,W,ALPHA,PLZ,PL,MAT,VOL,SURF, + 1 XXX,SGAR(0,II),IGAV,QEXT(1,II),LFIXUP,CURR,FUNKNO(1,II)) + IF(ZCODE(2).NE.0.0) THEN + CA=CURR + CB=1.0 + CALL SNFT1S(NREG,NBMIX,NLF,NSCT,U,W,ALPHA,PLZ,PL,MAT,VOL, + 1 SURF,XXX,SGAR(0,II),IGAV,QEXT(1,II),LFIXUP,CB,FUNKNO(1,II)) + CURR=ZCODE(2)*CA/(1.0+ZCODE(2)*(CA-CB)) + CALL SNFT1S(NREG,NBMIX,NLF,NSCT,U,W,ALPHA,PLZ,PL,MAT,VOL, + 1 SURF,XXX,SGAR(0,II),IGAV,QEXT(1,II),LFIXUP,CURR,FUNKNO(1,II)) + ENDIF + + 150 CONTINUE ! END OF ENERGY LOOP + + ELSE IF((ITYPE.EQ.5).AND.(IBFP.EQ.0)) THEN +*------------ +* 2D CARTESIAN +*------------ + ! EXTRACTING PARAMETERS + NM=IELEM**2 + NMX=IELEM + IF(NM*NSCT*NREG.GT.NUN) CALL XABORT('SNFLUX: QEXT OVE' + 1 //'RFLOW(4a)') + CALL LCMLEN(IPTRK,'DU',NPQ,ITYLCM) + CALL LCMGPD(IPTRK,'DU',DU_PTR) + CALL LCMGPD(IPTRK,'DE',DE_PTR) + CALL LCMGPD(IPTRK,'W',W_PTR) + CALL LCMGPD(IPTRK,'MRM',MRM_PTR) + CALL LCMGPD(IPTRK,'MRMY',MRMY_PTR) + CALL LCMGPD(IPTRK,'DB',DB_PTR) + CALL LCMGPD(IPTRK,'DA',DA_PTR) + CALL LCMGPD(IPTRK,'WX',WX_PTR) + CALL LCMGPD(IPTRK,'CST',CST_PTR) + CALL LCMGPD(IPTRK,'IL',IL_PTR) + CALL LCMGPD(IPTRK,'MN',MN_PTR) + CALL LCMGPD(IPTRK,'DN',DN_PTR) + CALL C_F_POINTER(DU_PTR,DU,(/ NPQ /)) + CALL C_F_POINTER(DE_PTR,DE,(/ NPQ /)) + CALL C_F_POINTER(W_PTR,W,(/ NPQ /)) + CALL C_F_POINTER(MRM_PTR,MRM,(/ NPQ /)) + CALL C_F_POINTER(MRMY_PTR,MRMY,(/ NPQ /)) + CALL C_F_POINTER(DB_PTR,DB,(/ LX*NPQ /)) + CALL C_F_POINTER(DA_PTR,DA,(/ LX*LY*NPQ /)) + CALL C_F_POINTER(WX_PTR,WX,(/ IELEM+1 /)) + CALL C_F_POINTER(CST_PTR,CST,(/ IELEM /)) + CALL C_F_POINTER(IL_PTR,IL,(/ NSCT /)) + CALL C_F_POINTER(MN_PTR,MN,(/ NPQ*NSCT /)) + CALL C_F_POINTER(DN_PTR,DN,(/ NPQ*NSCT /)) + CALL LCMGET(IPTRK,'NCODE',NCODE) + CALL LCMGET(IPTRK,'ZCODE',ZCODE) + + ! LOOP FOR GROUPS + DO 200 II=1,NGEFF + IF(.NOT.INCONV(II)) GO TO 200 + IF(IMPX.GT.2) WRITE(IUNOUT,510) NGIND(II),'SN/2D-car' + + ! FIXED VOLUMIC SOURCES + QEXT(:NUN,II)=SUNKNO(:NUN,II) + + ! IN-GROUP SCATTERING + DO 190 IR=1,NREG + IBM=MAT(IR) + IF(IBM.EQ.0) GO TO 190 + IOF=0 + DO 180 P=1,NSCT + IF(IL(P).GT.NANI-1) GO TO 180 + DO 160 IEL=1,NM + IND=(IR-1)*NSCT*NM+(P-1)*NM+IEL + QEXT(IND,II)=QEXT(IND,II)+SGAS(IBM,IL(P)+1,II)*FUNKNO(IND,II) + 160 CONTINUE + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE ! END OF ENERGY LOOP + IF(NKBA.EQ.0)THEN + CALL SNFBC2(NUN,NGEFF,IMPX,INCONV,NGIND,LX,LY,IELEM,NM,NMX, + 1 NMX,NBMIX,NPQ,NSCT,MAT,VOL,SGAR,NCODE,ZCODE,QEXT,LFIXUP, + 2 DU,DE,W,MRM,MRMY,DB,DA,MN,DN,WX,WX,CST,LADPT(2:3), + 3 ISBS,SUM(NBS),ISBSM,BS,MAXL,FUNKNO) + ELSE IF(NKBA.GT.0)THEN + IF(ISBS.EQ.1) CALL XABORT('SNFLUX: BOUNDARY SOURCES NOT YET ' + 1 //'VERIFIED WITH KBA ALGORITHM. YET TO BE VALIDATED. COMMENT ' + 2 //'CALL TO XABORT, RECOMPILE AND PROCEED WITH CAUTION.') + IF(ISCHM.EQ.3) CALL XABORT('SNFLUX: AWD METHOD NOT YET ' + 1 //'VERIFIED WITH KBA ALGORITHM. YET TO BE VALIDATED. COMMENT ' + 2 //'CALL TO XABORT, RECOMPILE AND PROCEED WITH CAUTION.') + CALL SNFKC2(NKBA,NUN,NGEFF,IMPX,INCONV,NGIND,LX,LY,IELEM,NM, + 1 NMX,NMX,NBMIX,NPQ,NSCT,MAT,VOL,SGAR,NCODE,ZCODE,QEXT,LFIXUP, + 2 DU,DE,W,MRM,MRMY,DB,DA,MN,DN,WX,WX,CST,LADPT(2:3), + 3 ISBS,SUM(NBS),ISBSM,BS,MAXL,FUNKNO) + ENDIF + ELSE IF(ITYPE.EQ.5) THEN +*------------ +* 2D CARTESIAN BOLTZMANN-FOKKER-PLANCK +*------------ + ! EXTRACTING PARAMETERS + NM=IELEM**2*EELEM + NME=IELEM**2 + NMX=IELEM*EELEM + CALL LCMLEN(IPTRK,'DU',NPQ,ITYLCM) + IF((NSCT*NM+NPQ*NME)*NREG.GT.NUN) THEN + CALL XABORT('SNFLUX: QEXT OVERFLOW(4b)') + ENDIF + CALL LCMGPD(IPTRK,'DU',DU_PTR) + CALL LCMGPD(IPTRK,'DE',DE_PTR) + CALL LCMGPD(IPTRK,'W',W_PTR) + CALL LCMGPD(IPTRK,'MRM',MRM_PTR) + CALL LCMGPD(IPTRK,'MRMY',MRMY_PTR) + CALL LCMGPD(IPTRK,'DB',DB_PTR) + CALL LCMGPD(IPTRK,'DA',DA_PTR) + CALL LCMGPD(IPTRK,'WX',WX_PTR) + CALL LCMGPD(IPTRK,'WE',WE_PTR) + CALL LCMGPD(IPTRK,'CST',CST_PTR) + CALL LCMGPD(IPTRK,'IL',IL_PTR) + CALL LCMGPD(IPTRK,'MN',MN_PTR) + CALL LCMGPD(IPTRK,'DN',DN_PTR) + CALL C_F_POINTER(DU_PTR,DU,(/ NPQ /)) + CALL C_F_POINTER(DE_PTR,DE,(/ NPQ /)) + CALL C_F_POINTER(W_PTR,W,(/ NPQ /)) + CALL C_F_POINTER(MRM_PTR,MRM,(/ NPQ /)) + CALL C_F_POINTER(MRMY_PTR,MRMY,(/ NPQ /)) + CALL C_F_POINTER(DB_PTR,DB,(/ LX*NPQ /)) + CALL C_F_POINTER(DA_PTR,DA,(/ LX*LY*NPQ /)) + CALL C_F_POINTER(WX_PTR,WX,(/ IELEM+1 /)) + CALL C_F_POINTER(WE_PTR,WE,(/ EELEM+1 /)) + CALL C_F_POINTER(CST_PTR,CST,(/ MAX(IELEM,EELEM) /)) + CALL C_F_POINTER(IL_PTR,IL,(/ NSCT /)) + CALL C_F_POINTER(MN_PTR,MN,(/ NPQ*NSCT /)) + CALL C_F_POINTER(DN_PTR,DN,(/ NPQ*NSCT /)) + CALL LCMGET(IPTRK,'NCODE',NCODE) + CALL LCMGET(IPTRK,'ZCODE',ZCODE) + + ! ANGULAR FOKKER-PLANCK OPERATOR + ALLOCATE(SIGMATR(NSCT,NSCT),MTR(NPQ,NPQ)) + SIGMATR=0.0 + DO P=1,NSCT + SIGMATR(P,P)=-IL(P)*(IL(P)+1) + ENDDO + MTR=MATMUL(MATMUL(RESHAPE(MN,[NPQ,NSCT]),SIGMATR), + 1 RESHAPE(DN,[NSCT,NPQ])) + LAMBDA0=0.0 + DO M=1,NPQ + IF(MTR(M,M).LT.-LAMBDA0) LAMBDA0=-MTR(M,M) + ENDDO + DO M=1,NPQ + MTR(M,M)=MTR(M,M)+LAMBDA0 + ENDDO + SIGMATR=MATMUL(MATMUL(RESHAPE(DN,[NSCT, NPQ]),MTR), + 1 RESHAPE(MN,[NPQ,NSCT])) + DEALLOCATE(MTR) + DO II=1,NGEFF + DO IBM=1,NBMIX + SGAR(IBM,II)=SGAR(IBM,II)+LAMBDA0*EMOMTR(IBM,II) + ENDDO + ENDDO + + ! LOOP FOR GROUPS + DO 250 II=1,NGEFF + IF(.NOT.INCONV(II)) GO TO 250 + IF(IMPX.GT.2) WRITE(IUNOUT,510) NGIND(II),'SN-BFP/2D-car' + + ! FIXED VOLUMIC SOURCES + QEXT(:NUN,II)=SUNKNO(:NUN,II) + + ! IN-GROUP SCATTERING + DO 240 IR=1,NREG + IBM=MAT(IR) + IF(IBM.EQ.0) GO TO 240 + IOF=0 + DO 230 P=1,NSCT + IF(IL(P).GT.NANI-1) GO TO 230 + DO 210 IEL=1,NM + IND=(IR-1)*NSCT*NM+(P-1)*NM+IEL + QEXT(IND,II)=QEXT(IND,II)+SGAS(IBM,IL(P)+1,II)*FUNKNO(IND,II) + DO Q=1,NSCT + JND=(IR-1)*NSCT*NM+(Q-1)*NM+IEL + QEXT(IND,II)=QEXT(IND,II)+EMOMTR(IBM,II)*SIGMATR(P,Q) + 1 *FUNKNO(JND,II) + ENDDO + 210 CONTINUE + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE ! END OF ENERGY LOOP + DEALLOCATE(SIGMATR) + + ! FLUX CALCULATION + CALL SNFE2D(NUN,NGEFF,IMPX,INCONV,NGIND,LX,LY,IELEM, + 1 EELEM,NM,NME,NMX,NMX,NBMIX,NPQ,NSCT,MAT,VOL,SGAR,ESTOPW, + 2 NCODE,ZCODE,DELTAE,QEXT,LFIXUP,DU,DE,W,MRM,MRMY,DB,DA,FUNKNO, + 3 ISLG,FLUXC,ISBS,SUM(NBS),ISBSM,BS,MAXL,WX,WX,WE,CST,LADPT(1:3), + 4 IBFP,MN,DN) + + ELSE IF(ITYPE.EQ.6) THEN +*------------ +* TUBE 2D (R-Z) +*------------ + ! EXTRACTING PARAMETERS + IF(IELEM.NE.1) CALL XABORT('SNFLUX: DIAM 0 EXPECTED(3).') + IF(NSCT*NREG.GT.NUN) CALL XABORT('SNFLUX: QEXT OVERFLOW(5)') + CALL LCMLEN(IPTRK,'DU',NPQ,ITYLCM) + CALL LCMGPD(IPTRK,'DU',DU_PTR) + CALL LCMGPD(IPTRK,'DE',DE_PTR) + CALL LCMGPD(IPTRK,'W',W_PTR) + CALL LCMGPD(IPTRK,'MRM',MRM_PTR) + CALL LCMGPD(IPTRK,'MRMY',MRMY_PTR) + CALL LCMGPD(IPTRK,'DB',DB_PTR) + CALL LCMGPD(IPTRK,'DA',DA_PTR) + CALL LCMGPD(IPTRK,'DAL',DAL_PTR) + CALL LCMGPD(IPTRK,'IL',IL_PTR) + CALL LCMGPD(IPTRK,'MN',MN_PTR) + CALL LCMGPD(IPTRK,'DN',DN_PTR) + CALL C_F_POINTER(DU_PTR,DU,(/ NPQ /)) + CALL C_F_POINTER(DE_PTR,DE,(/ NPQ /)) + CALL C_F_POINTER(W_PTR,W,(/ NPQ /)) + CALL C_F_POINTER(MRM_PTR,MRM,(/ NPQ /)) + CALL C_F_POINTER(MRMY_PTR,MRMY,(/ NPQ /)) + CALL C_F_POINTER(DB_PTR,DB,(/ LX*NPQ /)) + CALL C_F_POINTER(DA_PTR,DA,(/ LX*LY*NPQ /)) + CALL C_F_POINTER(DAL_PTR,DAL,(/ LX*LY*NPQ /)) + CALL C_F_POINTER(IL_PTR,IL,(/ NSCT /)) + CALL C_F_POINTER(MN_PTR,MN,(/ NPQ*NSCT /)) + CALL C_F_POINTER(DN_PTR,DN,(/ NPQ*NSCT /)) + CALL LCMGET(IPTRK,'NCODE',NCODE) + CALL LCMGET(IPTRK,'ZCODE',ZCODE) + + ! LOOP FOR GROUPS + DO 290 II=1,NGEFF + IF(.NOT.INCONV(II)) GO TO 290 + IF(IMPX.GT.2) WRITE(IUNOUT,510) NGIND(II),'SN/2D-rz' + + ! FIXED VOLUMIC SOURCES + QEXT(:NUN,II)=SUNKNO(:NUN,II) + + ! IN-GROUP SCATTERING + DO 280 IR=1,NREG + IBM=MAT(IR) + IF(IBM.EQ.0) GO TO 280 + IOF=0 + DO 270 P=1,NSCT + IF(IL(P).GT.MIN(ISCAT,NANI)-1) GO TO 270 + IND=(IR-1)*NSCT+(P-1)*IELEM*IELEM+1 + QEXT(IND,II)=QEXT(IND,II)+SGAS(IBM,IL(P)+1,II)*FUNKNO(IND,II) + 270 CONTINUE + 280 CONTINUE + + ! ONE-SPEED FLUX CALCULATION + CALL SNFC12(LX,LY,NBMIX,NPQ,NSCT,MAT,VOL,SGAR(0,II),NCODE,ZCODE, + 1 QEXT(1,II),LFIXUP,DU,DE,W,MRM,MRMY,DB,DA,DAL,FUNKNO(1,II), + 2 FUNKNO(L4+1,II),FUNKNO(L4+IELEM*LY*NPQ+1,II),MN,DN) + + 290 CONTINUE ! END OF ENERGY GROUP + + ELSE IF((ITYPE.EQ.7).AND.(IBFP.EQ.0)) THEN +*---- +* 3D CARTESIAN CASE +*---- + ! EXTRACTING PARAMETERS + NM=IELEM**3 + NMX=IELEM**2 + IF(NM*NSCT*NREG.GT.NUN) CALL XABORT('SNFLUX: QE' + 1 //'XT OVERFLOW(6a)') + CALL LCMLEN(IPTRK,'DU',NPQ,ITYLCM) + CALL LCMGPD(IPTRK,'DU',DU_PTR) + CALL LCMGPD(IPTRK,'DE',DE_PTR) + CALL LCMGPD(IPTRK,'DZ',DZ_PTR) + CALL LCMGPD(IPTRK,'W',W_PTR) + CALL LCMGPD(IPTRK,'MRMX',MRMX_PTR) + CALL LCMGPD(IPTRK,'MRMY',MRMY_PTR) + CALL LCMGPD(IPTRK,'MRMZ',MRMZ_PTR) + CALL LCMGPD(IPTRK,'DC',DC_PTR) + CALL LCMGPD(IPTRK,'DB',DB_PTR) + CALL LCMGPD(IPTRK,'DA',DA_PTR) + CALL LCMGPD(IPTRK,'WX',WX_PTR) + CALL LCMGPD(IPTRK,'CST',CST_PTR) + CALL LCMGPD(IPTRK,'IL',IL_PTR) + CALL LCMGPD(IPTRK,'MN',MN_PTR) + CALL LCMGPD(IPTRK,'DN',DN_PTR) + CALL C_F_POINTER(DU_PTR,DU,(/ NPQ /)) + CALL C_F_POINTER(DE_PTR,DE,(/ NPQ /)) + CALL C_F_POINTER(DZ_PTR,DZ,(/ NPQ /)) + CALL C_F_POINTER(W_PTR,W,(/ NPQ /)) + CALL C_F_POINTER(MRMX_PTR,MRMX,(/ NPQ /)) + CALL C_F_POINTER(MRMY_PTR,MRMY,(/ NPQ /)) + CALL C_F_POINTER(MRMZ_PTR,MRMZ,(/ NPQ /)) + CALL C_F_POINTER(DC_PTR,DC,(/ LX*LY*NPQ /)) + CALL C_F_POINTER(DB_PTR,DB,(/ LX*LY*NPQ /)) + CALL C_F_POINTER(DA_PTR,DA,(/ LX*LY*NPQ /)) + CALL C_F_POINTER(WX_PTR,WX,(/ IELEM+1 /)) + CALL C_F_POINTER(CST_PTR,CST,(/ IELEM /)) + CALL C_F_POINTER(IL_PTR,IL,(/ NSCT /)) + CALL C_F_POINTER(MN_PTR,MN,(/ NPQ*NSCT /)) + CALL C_F_POINTER(DN_PTR,DN,(/ NPQ*NSCT /)) + CALL LCMGET(IPTRK,'NCODE',NCODE) + CALL LCMGET(IPTRK,'ZCODE',ZCODE) + + ! LOOP FOR GROUPS + DO 340 II=1,NGEFF + IF(.NOT.INCONV(II)) GO TO 340 + IF(IMPX.GT.2) WRITE(IUNOUT,510) NGIND(II),'SN/3D-car' + + ! FIXED VOLUMIC SOURCES + QEXT(:NUN,II)=SUNKNO(:NUN,II) + + ! IN-GROUP SCATTERING + DO 330 IR=1,NREG + IBM=MAT(IR) + IF(IBM.EQ.0) GO TO 330 + IOF=0 + DO 320 P=1,NSCT + IF(IL(P).GT.NANI-1) GO TO 320 + DO 300 IEL=1,NM + IND=(IR-1)*NSCT*NM+(P-1)*NM+IEL + QEXT(IND,II)=QEXT(IND,II)+SGAS(IBM,IL(P)+1,II)*FUNKNO(IND,II) + 300 CONTINUE + 320 CONTINUE + 330 CONTINUE + 340 CONTINUE ! END OF ENERGY LOOP + + ! FLUX CALCULATION + IF(NKBA.EQ.0)THEN + CALL SNFBC3(NUN,NGEFF,IMPX,INCONV,NGIND,LX,LY,LZ,IELEM,NM,NMX, + 1 NMX,NMX,NBMIX,NPQ,NSCT,MAT,VOL,SGAR,NCODE,ZCODE,QEXT,LFIXUP, + 2 DU,DE,DZ,W,MRMX,MRMY,MRMZ,DC,DB,DA,MN,DN,WX,WX,WX,CST, + 3 LADPT(2:4),ISBS,SUM(NBS),ISBSM,BS,MAXL,FUNKNO) + ELSE IF(NKBA.GT.0)THEN + IF(ISBS.EQ.1) CALL XABORT('SNFLUX: BOUNDARY SOURCES NOT YET ' + 1 //'VERIFIED WITH KBA ALGORITHM. YET TO BE VALIDATED. COMMENT ' + 2 //'CALL TO XABORT, RECOMPILE AND PROCEED WITH CAUTION.') + IF(ISCHM.EQ.3) CALL XABORT('SNFLUX: AWD METHOD NOT YET ' + 1 //'VERIFIED WITH KBA ALGORITHM. YET TO BE VALIDATED. COMMENT ' + 2 //'CALL TO XABORT, RECOMPILE AND PROCEED WITH CAUTION.') + CALL SNFKC3(NKBA,NUN,NGEFF,IMPX,INCONV,NGIND,LX,LY,LZ,IELEM, + 1 NM,NMX,NMX,NMX,NBMIX,NPQ,NSCT,MAT,VOL,SGAR,NCODE,ZCODE,QEXT, + 2 LFIXUP,DU,DE,DZ,W,MRMX,MRMY,MRMZ,DC,DB,DA,MN,DN,WX,WX,WX,CST, + 3 LADPT(2:4),ISBS,SUM(NBS),ISBSM,BS,MAXL,FUNKNO) + ENDIF + ELSE IF(ITYPE.EQ.7) THEN +*------------ +* 3D CARTESIAN BOLTZMANN-FOKKER-PLANCK +*------------ + ! EXTRACTING PARAMETERS + NM=IELEM**3*EELEM + NME=IELEM**3 + NMX=IELEM**2*EELEM + CALL LCMLEN(IPTRK,'DU',NPQ,ITYLCM) + IF((NSCT*NM+NPQ*NME)*NREG.GT.NUN) THEN + CALL XABORT('SNFLUX: QEXT OVERFLOW(6b)') + ENDIF + CALL LCMGPD(IPTRK,'DU',DU_PTR) + CALL LCMGPD(IPTRK,'DE',DE_PTR) + CALL LCMGPD(IPTRK,'DZ',DZ_PTR) + CALL LCMGPD(IPTRK,'W',W_PTR) + CALL LCMGPD(IPTRK,'MRMX',MRMX_PTR) + CALL LCMGPD(IPTRK,'MRMY',MRMY_PTR) + CALL LCMGPD(IPTRK,'MRMZ',MRMZ_PTR) + CALL LCMGPD(IPTRK,'DC',DC_PTR) + CALL LCMGPD(IPTRK,'DB',DB_PTR) + CALL LCMGPD(IPTRK,'DA',DA_PTR) + CALL LCMGPD(IPTRK,'WX',WX_PTR) + CALL LCMGPD(IPTRK,'WE',WE_PTR) + CALL LCMGPD(IPTRK,'CST',CST_PTR) + CALL LCMGPD(IPTRK,'IL',IL_PTR) + CALL LCMGPD(IPTRK,'MN',MN_PTR) + CALL LCMGPD(IPTRK,'DN',DN_PTR) + CALL C_F_POINTER(DU_PTR,DU,(/ NPQ /)) + CALL C_F_POINTER(DE_PTR,DE,(/ NPQ /)) + CALL C_F_POINTER(DZ_PTR,DZ,(/ NPQ /)) + CALL C_F_POINTER(W_PTR,W,(/ NPQ /)) + CALL C_F_POINTER(MRMX_PTR,MRMX,(/ NPQ /)) + CALL C_F_POINTER(MRMY_PTR,MRMY,(/ NPQ /)) + CALL C_F_POINTER(MRMZ_PTR,MRMZ,(/ NPQ /)) + CALL C_F_POINTER(DC_PTR,DC,(/ LX*LY*NPQ /)) + CALL C_F_POINTER(DB_PTR,DB,(/ LX*LY*NPQ /)) + CALL C_F_POINTER(DA_PTR,DA,(/ LX*LY*NPQ /)) + CALL C_F_POINTER(WX_PTR,WX,(/ IELEM+1 /)) + CALL C_F_POINTER(WE_PTR,WE,(/ EELEM+1 /)) + CALL C_F_POINTER(CST_PTR,CST,(/ MAX(IELEM,EELEM) /)) + CALL C_F_POINTER(IL_PTR,IL,(/ NSCT /)) + CALL C_F_POINTER(MN_PTR,MN,(/ NPQ*NSCT /)) + CALL C_F_POINTER(DN_PTR,DN,(/ NPQ*NSCT /)) + CALL LCMGET(IPTRK,'NCODE',NCODE) + CALL LCMGET(IPTRK,'ZCODE',ZCODE) + + ! ANGULAR FOKKER-PLANCK OPERATOR + ALLOCATE(SIGMATR(NSCT,NSCT),MTR(NPQ,NPQ)) + SIGMATR=0.0 + DO P=1,NSCT + SIGMATR(P,P)=-IL(P)*(IL(P)+1) + ENDDO + MTR=MATMUL(MATMUL(RESHAPE(MN,[NPQ, NSCT]),SIGMATR), + 1 RESHAPE(DN,[NSCT,NPQ])) + LAMBDA0=0.0 + DO M=1,NPQ + IF(MTR(M,M).LT.-LAMBDA0) LAMBDA0=-MTR(M,M) + ENDDO + DO M=1,NPQ + MTR(M,M)=MTR(M,M)+LAMBDA0 + ENDDO + SIGMATR=MATMUL(MATMUL(RESHAPE(DN,[NSCT,NPQ]),MTR), + 1 RESHAPE(MN,[NPQ,NSCT])) + DEALLOCATE(MTR) + DO II=1,NGEFF + DO IBM=1,NBMIX + SGAR(IBM,II)=SGAR(IBM,II)+LAMBDA0*EMOMTR(IBM,II) + ENDDO + ENDDO + + ! LOOP FOR GROUPS + DO 390 II=1,NGEFF + IF(.NOT.INCONV(II)) GO TO 390 + IF(IMPX.GT.2) WRITE(IUNOUT,510) NGIND(II),'SN-BFP/3D-car' + + ! FIXED VOLUMIC SOURCES + QEXT(:NUN,II)=SUNKNO(:NUN,II) + + ! IN-GROUP SCATTERING + DO 380 IR=1,NREG + IBM=MAT(IR) + IF(IBM.EQ.0) GO TO 380 + IOF=0 + DO 370 P=1,NSCT + IF(IL(P).GT.NANI-1) GO TO 370 + DO 350 IEL=1,NM + IND=(IR-1)*NSCT*NM+(P-1)*NM+IEL + QEXT(IND,II)=QEXT(IND,II)+SGAS(IBM,IL(P)+1,II)*FUNKNO(IND,II) + DO Q=1,NSCT + JND=(IR-1)*NSCT*NM+(Q-1)*NM+IEL + QEXT(IND,II)=QEXT(IND,II)+EMOMTR(IBM,II)*SIGMATR(P,Q) + 1 *FUNKNO(JND,II) + ENDDO + 350 CONTINUE + 370 CONTINUE + 380 CONTINUE + 390 CONTINUE ! END OF ENERGY LOOP + DEALLOCATE(SIGMATR) + + ! FLUX CALCULATION + CALL SNFE3D(NUN,NGEFF,IMPX,INCONV,NGIND,LX,LY,LZ, + 1 IELEM,EELEM,NM,NME,NMX,NMX,NMX,NBMIX,NPQ,NSCT,MAT,VOL,SGAR, + 2 ESTOPW,NCODE,ZCODE,DELTAE,QEXT,LFIXUP,DU,DE,DZ,W,MRMX,MRMY,MRMZ, + 3 DC,DB,DA,FUNKNO,ISLG,FLUXC,ISBS,SUM(NBS),ISBSM,BS,MAXL, + 4 WX,WX,WX,WE,CST,LADPT,IBFP,MN,DN) + + ELSE IF(ITYPE.EQ.8) THEN +*------------ +* 2D HEXAGONAL +*------------ + ! EXTRACTING PARAMETERS + NM=IELEM**2 + NMX=IELEM + IF(NM*NSCT*NREG.GT.NUN) CALL XABORT('SNFLUX: QEXT OVE' + 1 //'RFLOW(7)') + CALL LCMLEN(IPTRK,'DU',NPQ,ITYLCM) + CALL LCMGPD(IPTRK,'DU',DU_PTR) + CALL LCMGPD(IPTRK,'DE',DE_PTR) + CALL LCMGPD(IPTRK,'W',W_PTR) + CALL LCMGPD(IPTRK,'DB',DB_PTR) + CALL LCMGPD(IPTRK,'DA',DA_PTR) + CALL LCMGPD(IPTRK,'WX',WX_PTR) + CALL LCMGPD(IPTRK,'CST',CST_PTR) + CALL LCMGPD(IPTRK,'IL',IL_PTR) + CALL LCMGPD(IPTRK,'MN',MN_PTR) + CALL LCMGPD(IPTRK,'DN',DN_PTR) + CALL C_F_POINTER(DU_PTR,DU,(/ NPQ /)) + CALL C_F_POINTER(DE_PTR,DE,(/ NPQ /)) + CALL C_F_POINTER(W_PTR,W,(/ NPQ /)) + CALL C_F_POINTER(DB_PTR,DB,(/ LX*NPQ /)) + CALL C_F_POINTER(DA_PTR,DA,(/ LX*LY*NPQ /)) + CALL C_F_POINTER(WX_PTR,WX,(/ IELEM+1 /)) + CALL C_F_POINTER(CST_PTR,CST,(/ IELEM /)) + CALL C_F_POINTER(IL_PTR,IL,(/ NSCT /)) + CALL C_F_POINTER(MN_PTR,MN,(/ NPQ*NSCT /)) + CALL C_F_POINTER(DN_PTR,DN,(/ NPQ*NSCT /)) + CALL LCMGET(IPTRK,'SIDE',SIDE) + CALL LCMGET(IPTRK,'LOZSWP',LOZSWP) + NHEX=LX/(3*ISPLH**2) + ALLOCATE(COORDMAP(3,NHEX)) + CALL LCMGET(IPTRK,'COORDMAP',COORDMAP) + + ! LOOP FOR GROUPS + DO 440 II=1,NGEFF + IF(.NOT.INCONV(II)) GO TO 440 + IF(IMPX.GT.2) WRITE(IUNOUT,510) NGIND(II),'SN/2D-hex' + + ! FIXED VOLUMIC SOURCES + QEXT(:NUN,II)=SUNKNO(:NUN,II) + + ! IN-GROUP SCATTERING + DO 430 IR=1,NREG + IBM=MAT(IR) + IF(IBM.EQ.0) GO TO 430 + IOF=0 + DO 420 P=1,NSCT + IF(IL(P).GT.NANI-1) GO TO 420 + DO 400 IEL=1,NM + IND=(((IR-1)*NSCT+(P-1))*NM)+IEL + QEXT(IND,II)=QEXT(IND,II)+SGAS(IBM,IL(P)+1,II)*FUNKNO(IND,II) + 400 CONTINUE + 420 CONTINUE + 430 CONTINUE + 440 CONTINUE ! END OF ENERGY LOOP + + ! FLUX CALCULATION + IF(NKBA.EQ.0)THEN + CALL SNFBH2(NUN,NGEFF,IMPX,INCONV,NGIND,NHEX,ISPLH,SIDE, + 1 IELEM,NM,NMX,NMX,NBMIX,NPQ,NSCT,MAT,VOL,SGAR,QEXT,LFIXUP,DU, + 2 DE,W,DB,DA,MN,DN,WX,WX,CST,LADPT(2:3),LOZSWP,COORDMAP, + 3 FUNKNO) + ELSE IF(NKBA.GE.1)THEN + IF(ISCHM.EQ.3) CALL XABORT('SNFLUX: AWD METHOD NOT YET ' + 1 //'VERIFIED WITH KBA ALGORITHM. YET TO BE VALIDATED. COMMENT ' + 2 //'CALL TO XABORT, RECOMPILE AND PROCEED WITH CAUTION.') + CALL SNFKH2(NUN,NGEFF,IMPX,INCONV,NGIND,NHEX,ISPLH,SIDE, + 1 IELEM,NM,NMX,NMX,NBMIX,NPQ,NSCT,MAT,VOL,SGAR,QEXT,LFIXUP,DU, + 2 DE,W,DB,DA,MN,DN,WX,WX,CST,LADPT(2:3),LOZSWP,COORDMAP, + 3 FUNKNO) + + ENDIF + DEALLOCATE(COORDMAP) + + ELSE IF(ITYPE.EQ.9) THEN +*------------ +* 3D HEXAGONAL +*------------ + ! EXTRACTING PARAMETERS + NM=IELEM**3 + NMX=IELEM**2 + IF(IELEM*IELEM*IELEM*NSCT*NREG.GT.NUN) CALL XABORT('SNFLUX: QE' + 1 //'XT OVERFLOW(8)') + CALL LCMLEN(IPTRK,'DU',NPQ,ITYLCM) + CALL LCMGPD(IPTRK,'DU',DU_PTR) + CALL LCMGPD(IPTRK,'DE',DE_PTR) + CALL LCMGPD(IPTRK,'DZ',DZ_PTR) + CALL LCMGPD(IPTRK,'W',W_PTR) + CALL LCMGPD(IPTRK,'MRMZ',MRMZ_PTR) + CALL LCMGPD(IPTRK,'DC',DC_PTR) + CALL LCMGPD(IPTRK,'DB',DB_PTR) + CALL LCMGPD(IPTRK,'DA',DA_PTR) + CALL LCMGPD(IPTRK,'WX',WX_PTR) + CALL LCMGPD(IPTRK,'CST',CST_PTR) + CALL LCMGPD(IPTRK,'IL',IL_PTR) + CALL LCMGPD(IPTRK,'MN',MN_PTR) + CALL LCMGPD(IPTRK,'DN',DN_PTR) + CALL C_F_POINTER(DU_PTR,DU,(/ NPQ /)) + CALL C_F_POINTER(DE_PTR,DE,(/ NPQ /)) + CALL C_F_POINTER(DZ_PTR,DZ,(/ NPQ /)) + CALL C_F_POINTER(W_PTR,W,(/ NPQ /)) + CALL C_F_POINTER(MRMZ_PTR,MRMZ,(/ NPQ /)) + CALL C_F_POINTER(DC_PTR,DC,(/ LX*LY*NPQ /)) + CALL C_F_POINTER(DB_PTR,DB,(/ LX*LY*NPQ /)) + CALL C_F_POINTER(DA_PTR,DA,(/ LX*LY*NPQ /)) + CALL C_F_POINTER(IL_PTR,IL,(/ NSCT /)) + CALL C_F_POINTER(WX_PTR,WX,(/ IELEM+1 /)) + CALL C_F_POINTER(CST_PTR,CST,(/ IELEM /)) + CALL C_F_POINTER(MN_PTR,MN,(/ NPQ*NSCT /)) + CALL C_F_POINTER(DN_PTR,DN,(/ NPQ*NSCT /)) + CALL LCMGET(IPTRK,'NCODE',NCODE) + CALL LCMGET(IPTRK,'ZCODE',ZCODE) + CALL LCMGET(IPTRK,'SIDE',SIDE) + CALL LCMGET(IPTRK,'LOZSWP',LOZSWP) + ! Number of hexagons in one plane only + NHEX=LX/(3*ISPLH**2) + ALLOCATE(COORDMAP(3,NHEX)) + CALL LCMGET(IPTRK,'COORDMAP',COORDMAP) + + ! LOOP FOR GROUPS + DO 490 II=1,NGEFF + IF(.NOT.INCONV(II)) GO TO 490 + IF(IMPX.GT.2) WRITE(IUNOUT,510) NGIND(II),'SN/3D-hex' + + ! FIXED VOLUMIC SOURCES + QEXT(:NUN,II)=SUNKNO(:NUN,II) + + ! IN-GROUP SCATTERING + DO 480 IR=1,NREG + IBM=MAT(IR) + IF(IBM.EQ.0) GO TO 480 + IOF=0 + DO 470 P=1,NSCT + IF(IL(P).GT.NANI-1) GO TO 470 + DO 450 IEL=1,IELEM*IELEM*IELEM + IND=(((IR-1)*NSCT+(P-1))*IELEM**3)+IEL + QEXT(IND,II)=QEXT(IND,II)+SGAS(IBM,IL(P)+1,II)*FUNKNO(IND,II) + 450 CONTINUE + 470 CONTINUE + 480 CONTINUE + 490 CONTINUE ! END OF ENERGY LOOP + + ! FLUX CALCULATION + IF(NKBA.EQ.0)THEN + CALL SNFBH3(NUN,NGEFF,IMPX,INCONV,NGIND,NHEX,LZ,ISPLH,SIDE, + 1 IELEM,NM,NMX,NMX,NMX,NBMIX,NPQ,NSCT,MAT,VOL,SGAR,NCODE,ZCODE, + 2 QEXT,LFIXUP,DU,DE,DZ,W,MRMZ,DC,DB,DA,MN,DN,WX,WX,WX,CST, + 3 LADPT(2:4),LOZSWP,COORDMAP,FUNKNO) + ELSE IF(NKBA.GE.1)THEN + IF(ISCHM.EQ.3) CALL XABORT('SNFLUX: AWD METHOD NOT YET ' + 1 //'VERIFIED WITH KBA ALGORITHM. YET TO BE VALIDATED. COMMENT ' + 2 //'CALL TO XABORT, RECOMPILE AND PROCEED WITH CAUTION.') + CALL SNFKH3(NKBA,NUN,NGEFF,IMPX,INCONV,NGIND,NHEX,LZ,ISPLH, + 1 SIDE,IELEM,NM,NMX,NMX,NMX,NBMIX,NPQ,NSCT,MAT,VOL,SGAR,NCODE, + 2 ZCODE,QEXT,LFIXUP,DU,DE,DZ,W,MRMZ,DC,DB,DA,MN,DN,WX,WX,WX, + 3 CST,LADPT(2:4),LOZSWP,COORDMAP,FUNKNO) + ENDIF + DEALLOCATE(COORDMAP) + ELSE + CALL XABORT('SNFLUX: TYPE OF DISCRETIZATION NOT IMPLEMENTED.') + ENDIF + DEALLOCATE(ESTOPW,SGAS,SGAR) +*---- +* PRINT COMPLETE UNKNOWN VECTOR. +*---- + DO 495 II=1,NGEFF + IF(.NOT.INCONV(II)) GO TO 495 + IF(IMPX.GT.5) THEN + WRITE(IUNOUT,520) NGIND(II) + WRITE(IUNOUT,'(1P,4(5X,E15.7))') (FUNKNO(:,II)) + ENDIF + 495 CONTINUE +*---- +* DIFFUSION SYNTHETIC ACCELERATION. +*---- + IF(LDSA) THEN + ISOLVSA=IPAR(33) + + CALL LCMSIX(IPTRK,'DSA',1) + CALL LCMGET(IPTRK,'KEYFLX',KEYSPN) + CALL LCMGET(IPTRK,'STATE-VECTOR',IPAR) + IF(NREG.NE.IPAR(1)) CALL XABORT('SNFLUX: INVALID NREG (DSA).') + NUNSA=IPAR(2) + ITYPE=IPAR(6) + + IF((ITYPE.EQ.7).OR.(ITYPE.EQ.9)) THEN + IELEMSA=IPAR(9) + ELSE + IF(ISOLVSA.EQ.1)THEN + IELEMSA=IPAR(8) + ELSEIF(ISOLVSA.EQ.2)THEN + IELEMSA=IPAR(9) + ENDIF + ENDIF + + IMPY=MAX(0,IMPX-1) + CALL LCMSIX(IPTRK,' ',2) + + CALL SNDSA(KPSYS,INCONV,NGIND,IPTRK,IMPY,NGEFF,NREG,NBMIX, + 1 NUN,MAT,VOL,KEYFLX,KEYSPN,NUNSA,IELEMSA,ZCODE,OLD,FUNKNO, + 2 NHEX) + + DEALLOCATE(OLD) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(DELTAE,KEYSPN,QEXT,BS,ISBSM) + RETURN +* + 500 FORMAT(//41H SNFLUX: N E U T R O N S O U R C E S (,I5,3H ):) + 510 FORMAT(/25H SNFLUX: PROCESSING GROUP,I5,6H WITH ,A,1H.) + 520 FORMAT(//41H SNFLUX: A F T E R T R A N S P O R T (,I5,3H ):) + END diff --git a/Dragon/src/SNFT12.F b/Dragon/src/SNFT12.F new file mode 100644 index 0000000..1ee44fc --- /dev/null +++ b/Dragon/src/SNFT12.F @@ -0,0 +1,506 @@ +*DECK SNFT12 + SUBROUTINE SNFT12(NUN,NGEFF,IMPX,INCONV,NGIND,LX,LY,IELEM,NMAT, + 1 NPQ,NSCT,MAT,VOL,TOTAL,NCODE,ZCODE,QEXT,LFIXUP,DU,DE,W,MRM,MRMY, + 2 DB,DA,FUNKNO,ISBS,NBS,ISBSM,BS,MAXL,MN,DN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform one inner iteration for solving SN equations in 2D Cartesian +* geometry for the HODD method. Energy-angle multithreading. Albedo +* boundary conditions. +* +*Copyright: +* Copyright (C) 2020 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NUN total number of unknowns in vector FUNKNO. +* NGEFF number of energy groups processed in parallel. +* IMPX print flag (equal to zero for no print). +* INCONV energy group convergence flag (set to .FALSE. if converged). +* NGIND energy group indices assign to the NGEFF set. +* LX number of meshes along X axis. +* LY number of meshes along Y axis. +* IELEM measure of order of the spatial approximation polynomial: +* =1 constant - classical diamond scheme - default for HODD; +* =2 linear; +* =3 parabolic. +* NMAT number of material mixtures. +* NPQ number of SN directions in four octants (including zero-weight +* directions). +* NSCT maximum number of spherical harmonics moments of the flux. +* MAT material mixture index in each region. +* VOL volumes of each region. +* TOTAL macroscopic total cross sections. +* NCODE boundary condition indices. +* ZCODE albedos. +* QEXT Legendre components of the fixed source. +* LFIXUP flag to enable negative flux fixup. +* DU first direction cosines ($\\mu$). +* DE second direction cosines ($\\eta$). +* W weights. +* MRM quadrature index. +* MRMY quadrature index. +* DB diamond-scheme parameter. +* DA diamond-scheme parameter. +* MN moment-to-discrete matrix. +* DN discrete-to-moment matrix. +* +*Parameters: input/output +* FUNKNO Legendre components of the flux and boundary fluxes. +* +*----------------------------------------------------------------------- +* +#if defined(_OPENMP) + USE omp_lib +#endif +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NUN,NGEFF,IMPX,NGIND(NGEFF),LX,LY,IELEM,NMAT,NPQ,NSCT, + 1 MAT(LX,LY),NCODE(4),MRM(NPQ),MRMY(NPQ),ISBS,NBS, + 2 ISBSM(4*ISBS,NPQ*ISBS,NGEFF*ISBS),MAXL + LOGICAL INCONV(NGEFF) + REAL VOL(LX,LY),TOTAL(0:NMAT,NGEFF),ZCODE(4),QEXT(NUN,NGEFF), + 1 DU(NPQ),DE(NPQ),W(NPQ),DB(LX,NPQ),DA(LX,LY,NPQ), + 2 FUNKNO(NUN,NGEFF),BS(MAXL*ISBS,NBS*ISBS),MN(NPQ,NSCT), + 3 DN(NSCT,NPQ) + LOGICAL LFIXUP +*---- +* LOCAL VARIABLES +*---- + INTEGER NPQD(4),IIND(4),P + DOUBLE PRECISION Q(IELEM**2),Q2(IELEM**2,(IELEM**2)+1),XNJ(IELEM), + 1 VT,CONST0,CONST1,CONST2 + PARAMETER(IUNOUT=6,RLOG=1.0E-8,PI=3.141592654) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: INDANG + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:) :: FLUX + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: FLUX_G + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: XNI +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(INDANG(NPQ,4)) + ALLOCATE(XNI(IELEM,LY),FLUX(IELEM**2,NSCT,LX,LY)) + ALLOCATE(FLUX_G(IELEM**2,NSCT,LX,LY,NGEFF)) +*---- +* DEFINITION OF CONSTANTS. +*---- + L4=IELEM*IELEM*LX*LY*NSCT + CONST0=2.0D0*DSQRT(3.0D0) + CONST1=2.0D0*DSQRT(5.0D0) + CONST2=2.0D0*DSQRT(15.0D0) +*---- +* PARAMETER VALIDATION. +*---- + IF(IELEM.GT.4) CALL XABORT('SNFT12: INVALID IELEM (DIAM) VALUE. ' + 1 //'CHECK INPUT DATA FILE.') + FLUX_G(:IELEM**2,:NSCT,:LX,:LY,:NGEFF)=0.0D0 +*---- +* SET OCTANT SWAPPING ORDER. +*---- + NPQD(:4)=0 + INDANG(:NPQ,:4)=0 + IIND(:)=0 + DO M=1,NPQ + VU=DU(M) + VE=DE(M) + IF(W(M).EQ.0) CYCLE + IF((VU.GE.0.0).AND.(VE.GE.0.0)) THEN + IND=1 + JND=4 + ELSE IF((VU.LE.0.0).AND.(VE.GE.0.0)) THEN + IND=2 + JND=3 + ELSE IF((VU.LE.0.0).AND.(VE.LE.0.0)) THEN + IND=3 + JND=1 + ELSE + IND=4 + JND=2 + ENDIF + IIND(JND)=IND + NPQD(IND)=NPQD(IND)+1 + INDANG(NPQD(IND),IND)=M + ENDDO +*---- +* MAIN LOOP OVER OCTANTS. +*---- + DO 190 JND=1,4 + IND=IIND(JND) +*---- +* PRELIMINARY LOOPS FOR SETTING BOUNDARY CONDITIONS. +*---- +*$OMP PARALLEL DO +*$OMP1 PRIVATE(M,IG,WEIGHT,VU,VE,M1,E1,IOF,JOF,IEL,I,J) +*$OMP2 SHARED(FUNKNO) COLLAPSE(2) + DO 70 IG=1,NGEFF + DO 60 IPQD=1,NPQD(IND) + IF(.NOT.INCONV(IG)) GO TO 60 + M=INDANG(IPQD,IND) + WEIGHT=W(M) + VU=DU(M) + VE=DE(M) + IF(VU.GT.0.0)THEN + M1=MRM(M) + IF((NCODE(1).NE.4))THEN + DO IEL=1,IELEM + DO J=1,LY + IOF=((M-1)*LY+(J-1))*IELEM+IEL + JOF=((M1-1)*LY+(J-1))*IELEM+IEL + FUNKNO(L4+IOF,IG)=FUNKNO(L4+JOF,IG) + ENDDO + ENDDO + ENDIF + ELSEIF(VU.LT.0.0)THEN + M1=MRM(M) + IF((NCODE(2).NE.4))THEN + DO IEL=1,IELEM + DO J=1,LY + IOF=((M-1)*LY+(J-1))*IELEM+IEL + JOF=((M1-1)*LY+(J-1))*IELEM+IEL + FUNKNO(L4+IOF,IG)=FUNKNO(L4+JOF,IG) + ENDDO + ENDDO + ENDIF + ENDIF + IF(VE.GT.0.0)THEN + M1=MRMY(M) + IF((NCODE(3).NE.4))THEN + DO IEL=1,IELEM + DO I=1,LX + IOF=((M-1)*LX+(I-1))*IELEM+IEL + JOF=((M1-1)*LX+(I-1))*IELEM+IEL + FUNKNO(L4+IELEM*LY*NPQ+IOF,IG)= + > FUNKNO(L4+IELEM*LY*NPQ+JOF,IG) + ENDDO + ENDDO + ENDIF + ELSEIF(VE.LT.0.0)THEN + M1=MRMY(M) + IF((NCODE(4).NE.4))THEN + DO IEL=1,IELEM + DO I=1,LX + IOF=((M-1)*LX+(I-1))*IELEM+IEL + JOF=((M1-1)*LX+(I-1))*IELEM+IEL + FUNKNO(L4+IELEM*LY*NPQ+IOF,IG)= + > FUNKNO(L4+IELEM*LY*NPQ+JOF,IG) + ENDDO + ENDDO + ENDIF + ENDIF + 60 CONTINUE + 70 CONTINUE +*$OMP END PARALLEL DO +*---- +* MAIN SWAPPING LOOPS FOR SN FLUX CALCULATION +*---- +*$OMP PARALLEL DO +*$OMP1 PRIVATE(ITID,FLUX,M,IG,XNI,XNJ,Q,Q2,IOF,IER,II,JJ,IEL,JEL,I,J,K) +*$OMP2 PRIVATE(VT) SHARED(FUNKNO) REDUCTION(+:FLUX_G) +*$OMP3 COLLAPSE(2) + DO 180 IG=1,NGEFF + DO 170 IPQD=1,NPQD(IND) +#if defined(_OPENMP) + ITID=omp_get_thread_num() +#else + ITID=0 +#endif + IF(IMPX.GT.5) WRITE(IUNOUT,400) ITID,NGIND(IG),IPQD + IF(.NOT.INCONV(IG)) GO TO 170 + M=INDANG(IPQD,IND) + FLUX(:IELEM**2,:NSCT,:LX,:LY)=0.0D0 + IF(W(M).EQ.0.0) GO TO 170 +*---- +* LOOP OVER X- AND Y-DIRECTED AXES. +*---- + DO 155 II=1,LX + I=II + IF((IND.EQ.2).OR.(IND.EQ.3)) I=LX+1-I + DO 100 IEL=1,IELEM + IOF=(M-1)*IELEM*LX+(I-1)*IELEM+IEL + IF((IND.EQ.1).OR.(IND.EQ.2)) THEN + XNJ(IEL)=FUNKNO(L4+IELEM*LY*NPQ+IOF,IG)*ZCODE(3) + ELSE + XNJ(IEL)=FUNKNO(L4+IELEM*LY*NPQ+IOF,IG)*ZCODE(4) + ENDIF + 100 CONTINUE + IF(ISBS.EQ.1) THEN + IF((IND.EQ.3.OR.IND.EQ.4).AND.ISBSM(4,M,IG).NE.0) THEN + XNJ(1)=XNJ(1)+BS(I,ISBSM(4,M,IG)) + ELSE IF((IND.EQ.1.OR.IND.EQ.2).AND.ISBSM(3,M,IG).NE.0) THEN + XNJ(1)=XNJ(1)+BS(I,ISBSM(3,M,IG)) + ENDIF + ENDIF + DO 140 JJ=1,LY + J=JJ + IF((IND.EQ.3).OR.(IND.EQ.4)) J=LY+1-J + DO 105 IEL=1,IELEM + IF(II.EQ.1) THEN + IOF=(M-1)*IELEM*LY+(J-1)*IELEM+IEL + IF((IND.EQ.1).OR.(IND.EQ.4)) THEN + XNI(IEL,J)=FUNKNO(L4+IOF,IG)*ZCODE(1) + ELSE + XNI(IEL,J)=FUNKNO(L4+IOF,IG)*ZCODE(2) + ENDIF + ENDIF + 105 CONTINUE + IF(ISBS.EQ.1.AND.II.EQ.1) THEN + IF((IND.EQ.2.OR.IND.EQ.3).AND.ISBSM(2,M,IG).NE.0) THEN + XNI(1,J)=XNI(1,J)+BS(J,ISBSM(2,M,IG)) + ELSE IF((IND.EQ.1.OR.IND.EQ.4).AND.ISBSM(1,M,IG).NE.0) THEN + XNI(1,J)=XNI(1,J)+BS(J,ISBSM(1,M,IG)) + ENDIF + ENDIF + IF(MAT(I,J).EQ.0) GO TO 140 +*------ + DO 115 IEL=1,IELEM**2 + Q(IEL)=0.0D0 + DO 110 P=1,NSCT + IOF=((J-1)*LX*NSCT+(I-1)*NSCT+(P-1))*IELEM*IELEM+IEL + Q(IEL)=Q(IEL)+QEXT(IOF,IG)*MN(M,P) + 110 CONTINUE + 115 CONTINUE + VT=VOL(I,J)*TOTAL(MAT(I,J),IG) + Q2(:IELEM**2,:(IELEM**2)+1)=0.0D0 + IF(IELEM.EQ.1) THEN + Q2(1,1)=2.0D0*ABS(DA(I,J,M))+2.0D0*ABS(DB(I,M))+VT +* ------ + Q2(1,2)=2.0D0*ABS(DA(I,J,M))*XNI(1,J)+2.0D0*ABS(DB(I,M)) + 1 *XNJ(1)+VOL(I,J)*Q(1) + ELSE IF(IELEM.EQ.2) THEN + Q2(1,1)=VT + Q2(2,1)=CONST0*DA(I,J,M) + Q2(2,2)=-VT-6.0D0*ABS(DA(I,J,M)) + Q2(3,1)=CONST0*DB(I,M) + Q2(3,3)=-VT-6.0D0*ABS(DB(I,M)) + Q2(4,2)=-CONST0*DB(I,M) + Q2(4,3)=-CONST0*DA(I,J,M) + Q2(4,4)=VT+6.0D0*ABS(DA(I,J,M))+6.0D0*ABS(DB(I,M)) +* ------ + Q2(1,5)=VOL(I,J)*Q(1) + Q2(2,5)=-VOL(I,J)*Q(2)+CONST0*DA(I,J,M)*XNI(1,J) + Q2(3,5)=-VOL(I,J)*Q(3)+CONST0*DB(I,M)*XNJ(1) + Q2(4,5)=VOL(I,J)*Q(4)-CONST0*DA(I,J,M)*XNI(2,J)-CONST0* + 1 DB(I,M)*XNJ(2) + ELSE IF(IELEM.EQ.3) THEN + Q2(1,1)=VT+2.0D0*ABS(DA(I,J,M))+2.0D0*ABS(DB(I,M)) + Q2(2,2)=-VT-2.0D0*ABS(DB(I,M)) + Q2(3,1)=CONST1*ABS(DA(I,J,M)) + Q2(3,2)=-CONST2*DA(I,J,M) + Q2(3,3)=VT+1.0D1*ABS(DA(I,J,M))+2.0D0*ABS(DB(I,M)) + Q2(4,4)=-VT-2.0D0*ABS(DA(I,J,M)) + Q2(5,5)=VT + Q2(6,4)=-CONST1*ABS(DA(I,J,M)) + Q2(6,5)=CONST2*DA(I,J,M) + Q2(6,6)=-VT-1.0D1*ABS(DA(I,J,M)) + Q2(7,1)=CONST1*ABS(DB(I,M)) + Q2(7,4)=-CONST2*DB(I,M) + Q2(7,7)=VT+2.0D0*ABS(DA(I,J,M))+1.0D1*ABS(DB(I,M)) + Q2(8,2)=-CONST1*ABS(DB(I,M)) + Q2(8,5)=CONST2*DB(I,M) + Q2(8,8)=-VT-1.0D1*ABS(DB(I,M)) + Q2(9,3)=CONST1*ABS(DB(I,M)) + Q2(9,6)=-CONST2*DB(I,M) + Q2(9,7)=CONST1*ABS(DA(I,J,M)) + Q2(9,8)=-CONST2*DA(I,J,M) + Q2(9,9)=VT+1.0D1*ABS(DA(I,J,M))+1.0D1*ABS(DB(I,M)) +* ------ + Q2(1,10)=VOL(I,J)*Q(1)+2.0D0*ABS(DA(I,J,M))*XNI(1,J)+2.0D0* + 1 ABS(DB(I,M))*XNJ(1) + Q2(2,10)=-VOL(I,J)*Q(2)-2.0D0*ABS(DB(I,M))*XNJ(2) + Q2(3,10)=VOL(I,J)*Q(3)+CONST1*ABS(DA(I,J,M))*XNI(1,J)+2.0D0* + 1 ABS(DB(I,M))*XNJ(3) + Q2(4,10)=-VOL(I,J)*Q(4)-2.0D0*ABS(DA(I,J,M))*XNI(2,J) + Q2(5,10)=VOL(I,J)*Q(5) + Q2(6,10)=-VOL(I,J)*Q(6)-CONST1*ABS(DA(I,J,M))*XNI(2,J) + Q2(7,10)=VOL(I,J)*Q(7)+2.0D0*ABS(DA(I,J,M))*XNI(3,J)+CONST1* + 1 ABS(DB(I,M))*XNJ(1) + Q2(8,10)=-VOL(I,J)*Q(8)-CONST1*ABS(DB(I,M))*XNJ(2) + Q2(9,10)=VOL(I,J)*Q(9)+CONST1*ABS(DA(I,J,M))*XNI(3,J)+CONST1* + 1 ABS(DB(I,M))*XNJ(3) + ELSE IF(IELEM.EQ.4) THEN + Q2(1,1) = VT + Q2(2,1) = 2*3**(0.5D0)*DA(I,J,M) + Q2(2,2) = - VT - 6*ABS(DA(I,J,M)) + Q2(3,3) = VT + Q2(4,1) = 2*7**(0.5D0)*DA(I,J,M) + Q2(4,2) = -2*21**(0.5D0)*ABS(DA(I,J,M)) + Q2(4,3) = 2*35**(0.5D0)*DA(I,J,M) + Q2(4,4) = - VT - 14*ABS(DA(I,J,M)) + Q2(5,1) = 2*3**(0.5D0)*DB(I,M) + Q2(5,5) = - VT - 6*ABS(DB(I,M)) + Q2(6,2) = -2*3**(0.5D0)*DB(I,M) + Q2(6,5) = -2*3**(0.5D0)*DA(I,J,M) + Q2(6,6) = VT + 6*ABS(DB(I,M)) + 6*ABS(DA(I,J,M)) + Q2(7,3) = 2*3**(0.5D0)*DB(I,M) + Q2(7,7) = - VT - 6*ABS(DB(I,M)) + Q2(8,4) = -2*3**(0.5D0)*DB(I,M) + Q2(8,5) = -2*7**(0.5D0)*DA(I,J,M) + Q2(8,6) = 2*21**(0.5D0)*ABS(DA(I,J,M)) + Q2(8,7) = -2*35**(0.5D0)*DA(I,J,M) + Q2(8,8) = VT + 6*ABS(DB(I,M)) + 14*ABS(DA(I,J,M)) + Q2(9,9) = VT + Q2(10,9) = 2*3**(0.5D0)*DA(I,J,M) + Q2(10,10) = - VT - 6*ABS(DA(I,J,M)) + Q2(11,11) = VT + Q2(12,9) = 2*7**(0.5D0)*DA(I,J,M) + Q2(12,10) = -2*21**(0.5D0)*ABS(DA(I,J,M)) + Q2(12,11) = 2*35**(0.5D0)*DA(I,J,M) + Q2(12,12) = - VT - 14*ABS(DA(I,J,M)) + Q2(13,1) = 2*7**(0.5D0)*DB(I,M) + Q2(13,5) = -2*21**(0.5D0)*ABS(DB(I,M)) + Q2(13,9) = 2*35**(0.5D0)*DB(I,M) + Q2(13,13) = - VT - 14*ABS(DB(I,M)) + Q2(14,2) = -2*7**(0.5D0)*DB(I,M) + Q2(14,6) = 2*21**(0.5D0)*ABS(DB(I,M)) + Q2(14,10) = -2*35**(0.5D0)*DB(I,M) + Q2(14,13) = -2*3**(0.5D0)*DA(I,J,M) + Q2(14,14) = VT + 14*ABS(DB(I,M)) + 6*ABS(DA(I,J,M)) + Q2(15,3) = 2*7**(0.5D0)*DB(I,M) + Q2(15,7) = -2*21**(0.5D0)*ABS(DB(I,M)) + Q2(15,11) = 2*35**(0.5D0)*DB(I,M) + Q2(15,15) = - VT - 14*ABS(DB(I,M)) + Q2(15,16) = -2*35**(0.5D0)*DA(I,J,M) + Q2(16,4) = -2*7**(0.5D0)*DB(I,M) + Q2(16,8) = 2*21**(0.5D0)*ABS(DB(I,M)) + Q2(16,12) = -2*35**(0.5D0)*DB(I,M) + Q2(16,13) = -2*7**(0.5D0)*DA(I,J,M) + Q2(16,14) = 2*21**(0.5D0)*ABS(DA(I,J,M)) + Q2(16,15) = -2*35**(0.5D0)*DA(I,J,M) + Q2(16,16) = VT + 14*ABS(DB(I,M)) + 14*ABS(DA(I,J,M)) +* ------ + Q2(1,17) = Q(1)*VOL(I,J) + Q2(2,17) = -Q(2)*VOL(I,J) + Q2(3,17) = Q(3)*VOL(I,J) + Q2(4,17) = -Q(4)*VOL(I,J) + Q2(5,17) = -Q(5)*VOL(I,J) + Q2(6,17) = Q(6)*VOL(I,J) + Q2(7,17) = -Q(7)*VOL(I,J) + Q2(8,17) = Q(8)*VOL(I,J) + Q2(9,17) = Q(9)*VOL(I,J) + Q2(10,17) = -Q(10)*VOL(I,J) + Q2(11,17) = Q(11)*VOL(I,J) + Q2(12,17) = -Q(12)*VOL(I,J) + Q2(13,17) = -Q(13)*VOL(I,J) + Q2(14,17) = Q(14)*VOL(I,J) + Q2(15,17) = -Q(15)*VOL(I,J) + Q2(16,17) = Q(16)*VOL(I,J) + + Q2(2,17) = Q2(2,17) + 2*3**(0.5D0)*DA(I,J,M)*XNI(1,J) + Q2(4,17) = Q2(4,17) + 2*7**(0.5D0)*DA(I,J,M)*XNI(1,J) + Q2(5,17) = Q2(5,17) + 2*3**(0.5D0)*DB(I,M)*XNJ(1) + Q2(6,17) = Q2(6,17) + (- 2*3**(0.5D0)*DB(I,M)*XNJ(2) - + > 2*3**(0.5D0)*DA(I,J,M)*XNI(2,J)) + Q2(7,17) = Q2(7,17) + 2*3**(0.5D0)*DB(I,M)*XNJ(3) + Q2(8,17) = Q2(8,17) + (- 2*3**(0.5D0)*DB(I,M)*XNJ(4) - + > 2*7**(0.5D0)*DA(I,J,M)*XNI(2,J)) + Q2(10,17) = Q2(10,17) + 2*3**(0.5D0)*DA(I,J,M)*XNI(3,J) + Q2(12,17) = Q2(12,17) + 2*7**(0.5D0)*DA(I,J,M)*XNI(3,J) + Q2(13,17) = Q2(13,17) + 2*7**(0.5D0)*DB(I,M)*XNJ(1) + Q2(14,17) = Q2(14,17) + (- 2*7**(0.5D0)*DB(I,M)*XNJ(2) - + > 2*3**(0.5D0)*DA(I,J,M)*XNI(4,J)) + Q2(15,17) = Q2(15,17) + 2*7**(0.5D0)*DB(I,M)*XNJ(3) + Q2(16,17) = Q2(16,17) + (- 2*7**(0.5D0)*DB(I,M)*XNJ(4) - + > 2*7**(0.5D0)*DA(I,J,M)*XNI(4,J)) + ENDIF +* + DO 125 IEL=1,IELEM**2 + DO 120 JEL=IEL+1,IELEM**2 + Q2(IEL,JEL)=Q2(JEL,IEL) + 120 CONTINUE + 125 CONTINUE +* + CALL ALSBD(IELEM**2,1,Q2,IER,IELEM**2) + IF(IER.NE.0) CALL XABORT('SNFT12: SINGULAR MATRIX.') +* + IF(IELEM.EQ.1) THEN + IF(LFIXUP.AND.(Q2(1,2).LE.RLOG)) Q2(1,2)=0.0 + XNI(1,J)=2.0D0*Q2(1,2)-XNI(1,J) + XNJ(1)=2.0D0*Q2(1,2)-XNJ(1) + IF(LFIXUP.AND.(XNI(1,J).LE.RLOG)) XNI(1,J)=0.0 + IF(LFIXUP.AND.(XNJ(1).LE.RLOG)) XNJ(1)=0.0 + ELSE IF(IELEM.EQ.2) THEN + XNI(1,J)=XNI(1,J)+SIGN(1.0,DU(M))*CONST0*Q2(2,5) + XNI(2,J)=XNI(2,J)+SIGN(1.0,DU(M))*CONST0*Q2(4,5) + XNJ(1)=XNJ(1)+SIGN(1.0,DE(M))*CONST0*Q2(3,5) + XNJ(2)=XNJ(2)+SIGN(1.0,DE(M))*CONST0*Q2(4,5) + ELSE IF(IELEM.EQ.3) THEN + XNI(1,J)=2.0D0*Q2(1,10)+CONST1*Q2(3,10)-XNI(1,J) + XNI(2,J)=2.0D0*Q2(4,10)+CONST1*Q2(6,10)-XNI(2,J) + XNI(3,J)=2.0D0*Q2(7,10)+CONST1*Q2(9,10)-XNI(3,J) + XNJ(1)=2.0D0*Q2(1,10)+CONST1*Q2(7,10)-XNJ(1) + XNJ(2)=2.0D0*Q2(2,10)+CONST1*Q2(8,10)-XNJ(2) + XNJ(3)=2.0D0*Q2(3,10)+CONST1*Q2(9,10)-XNJ(3) + ELSE IF(IELEM.EQ.4) THEN + XNI(1,J) = XNI(1,J) + SIGN(1.0,DU(M))*2*3 + > **(0.5D0)*Q2(02,17) + SIGN(1.0,DU(M))*2*7 + > **(0.5D0)*Q2(04,17) + XNI(2,J) = XNI(2,J) + SIGN(1.0,DU(M))*2*3 + > **(0.5D0)*Q2(06,17) + SIGN(1.0,DU(M))*2*7 + > **(0.5D0)*Q2(08,17) + XNI(3,J) = XNI(3,J) + SIGN(1.0,DU(M))*2*3 + > **(0.5D0)*Q2(10,17) + SIGN(1.0,DU(M))*2*7 + > **(0.5D0)*Q2(12,17) + XNI(4,J) = XNI(4,J) + SIGN(1.0,DU(M))*2*3 + > **(0.5D0)*Q2(14,17) + SIGN(1.0,DU(M))*2*7 + > **(0.5D0)*Q2(16,17) + XNJ(1) = XNJ(1) + SIGN(1.0,DE(M))*2*7 + > **(0.5D0)*Q2(13,17) + SIGN(1.0,DE(M))*2*3 + > **(0.5D0)*Q2(05,17) + XNJ(2) = XNJ(2) + SIGN(1.0,DE(M))*2*7 + > **(0.5D0)*Q2(14,17) + SIGN(1.0,DE(M))*2*3 + > **(0.5D0)*Q2(06,17) + XNJ(3) = XNJ(3) + SIGN(1.0,DE(M))*2*7 + > **(0.5D0)*Q2(15,17) + SIGN(1.0,DE(M))*2*3 + > **(0.5D0)*Q2(07,17) + XNJ(4) = XNJ(4) + SIGN(1.0,DE(M))*2*7 + > **(0.5D0)*Q2(16,17) + SIGN(1.0,DE(M))*2*3 + > **(0.5D0)*Q2(08,17) + ENDIF +* + DO 135 P=1,NSCT + DO 130 IEL=1,IELEM**2 + FLUX(IEL,P,I,J)=FLUX(IEL,P,I,J)+Q2(IEL,IELEM**2+1)*DN(P,M) + 130 CONTINUE + 135 CONTINUE +*------ + 140 CONTINUE + DO 150 IEL=1,IELEM + IOF=(M-1)*IELEM*LX+(I-1)*IELEM+IEL + FUNKNO(L4+IELEM*LY*NPQ+IOF,IG)=REAL(XNJ(IEL)) + 150 CONTINUE +*-- + 155 CONTINUE + DO 165 J=1,LY + DO 160 IEL=1,IELEM + IOF=(M-1)*IELEM*LY+(J-1)*IELEM+IEL + FUNKNO(L4+IOF,IG)=REAL(XNI(IEL,J)) + 160 CONTINUE + 165 CONTINUE + FLUX_G(:,:,:,:,IG)=FLUX_G(:,:,:,:,IG)+FLUX(:,:,:,:) + 170 CONTINUE + 180 CONTINUE +*$OMP END PARALLEL DO + 190 CONTINUE + DO 200 IG=1,NGEFF + IF(.NOT.INCONV(IG)) GO TO 200 + FUNKNO(:L4,IG)= + 1 RESHAPE(REAL(FLUX_G(:IELEM**2,:NSCT,:LX,:LY,IG)), (/ L4 /) ) + 200 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XNI,FLUX_G,FLUX,INDANG) + RETURN + 400 FORMAT(16H SNFT12: thread=,I8,12H --->(group=,I4,7H angle=,I4,1H)) + END diff --git a/Dragon/src/SNFT1C.f b/Dragon/src/SNFT1C.f new file mode 100644 index 0000000..efaa775 --- /dev/null +++ b/Dragon/src/SNFT1C.f @@ -0,0 +1,211 @@ +*DECK SNFT1C + SUBROUTINE SNFT1C(NREG,NMAT,M2,NPQ,ISCAT,NSCT,JOP,U,UPQ,WPQ,ALPHA, + 1 PLZ,PL,MAT,VOL,SURF,TOTAL,IGAV,QEXT,LFIXUP,CURR,FLUX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform one inner iteration for solving SN equations in 1D cylindrical +* geometry. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NREG number of regions. +* NMAT number of material mixtures. +* M2 number of axial $\\xi$ levels. +* NPQ number of SN directions in one octant. +* ISCAT anisotropy of one-speed sources: +* =1 isotropic sources; +* =2 linearly anisotropic sources. +* NSCT number of spherical harmonics components in the flux. +* JOP number of base points per axial level in one octant. +* U base points in $\\mu$ of the 1D quadrature. Used with +* zero-weight points. +* UPQ base points in $\\mu$ of the 2D SN quadrature. +* WPQ weights of the 2D SN quadrature. +* ALPHA angular redistribution terms. +* PLZ discrete values of the spherical harmonics corresponding +* to the 1D quadrature. Used with zero-weight points. +* MN moment-to-discrete matrix. +* DN discrete-to-moment matrix. +* MAT material mixture index in each region. +* VOL volumes of each region. +* SURF surfaces surrounding each region. +* TOTAL macroscopic total cross sections. +* IGAV type of condition at axial axis (=1 specular reflection; +* =2 zero-weight reflection; =3 averaged reflection). +* QEXT spherical harmonics components of the fixed source. +* LFIXUP flag to enable negative flux fixup. +* +*Parameters: input/output +* CURR entering current at input and leaving current at output. +* +*Parameters: output +* FLUX spherical harmonics components of the flux. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NREG,NMAT,M2,NPQ,ISCAT,NSCT,JOP(M2),MAT(NREG),IGAV + REAL U(M2),UPQ(NPQ),WPQ(NPQ),ALPHA(NPQ),PLZ(NSCT,M2),PL(NSCT,NPQ), + 1 VOL(NREG),SURF(NREG+1),TOTAL(0:NMAT),QEXT(NSCT,NREG),CURR, + 2 FLUX(NSCT,NREG) + LOGICAL LFIXUP +*---- +* LOCAL VARIABLES +*---- + PARAMETER(RLOG=1.0E-8,PI=3.141592654) + DOUBLE PRECISION Q,E2,AFB,Q1,Q2,PSIA,WSIA,CURSUM + REAL, ALLOCATABLE, DIMENSION(:) :: FLXB,AFGL +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(FLXB(M2),AFGL(NREG)) +*---- +* COMPUTE A NORMALIZATION CONSTANT. +*---- + DENOM=0.0 + DO 10 I=1,NPQ + IF(UPQ(I).GT.0.0) DENOM=DENOM+4.0*WPQ(I)*UPQ(I) + 10 CONTINUE +*---- +* OUTER LOOP OVER AXIAL LEVELS. +*---- + FLUX(:NSCT,:NREG)=0.0 + CURSUM=0.0D0 + IPQ=0 + DO 200 IP=1,M2 +*---- +* INITIALIZATION SWEEP (USING ZERO-WEIGHT POINTS). AFB IS THE EDGE +* FLUX VALUE AND AFGL(I) IS THE CENTERED FLUX VALUE. +*---- + AFB=CURR/DENOM + DO 30 I=NREG,1,-1 ! Spatial sweep + Q=0.0D0 + IBM=MAT(I) + IOF=0 + DO 25 IL=0,ISCAT-1 + DO 20 IM=0,IL + IF(MOD(IL+IM,2).EQ.1) GO TO 20 + IOF=IOF+1 + Q=Q+QEXT(IOF,I)*PLZ(IOF,IP)*(2.0*IL+1.0)/(4.0*PI) + 20 CONTINUE + 25 CONTINUE + Q1=-4.0D0*PI*SQRT(1.0-U(IP)*U(IP))/(SURF(I+1)-SURF(I)) + E2=(Q-Q1*AFB)/(TOTAL(IBM)-Q1) + IF(LFIXUP.AND.(E2.LE.RLOG)) E2=0.0 + AFB=2.0*E2-AFB + IF(LFIXUP.AND.(AFB.LE.RLOG)) AFB=0.0 + AFGL(I)=REAL(E2) + IF(LFIXUP.AND.(AFGL(I).LE.RLOG)) AFGL(I)=0.0 + 30 CONTINUE + WSIA=0.0D0 + IF(IGAV.EQ.2) THEN + PSIA=0.0D0 + ELSE + PSIA=AFB + ENDIF +*---- +* BACKWARD SWEEP (FROM EXTERNAL SURFACE TOWARD CENTRAL AXIS). +*---- + ALPMAX=0.0 + DO 80 M=2*JOP(IP),JOP(IP)+1,-1 ! Angular sweep + AFB=CURR/DENOM + ALPMIN=ALPHA(IPQ+M) + DO 70 I=NREG,1,-1 ! Spatial sweep + Q=0.0 + IBM=MAT(I) + IOF=0 + DO 45 IL=0,ISCAT-1 + DO 40 IM=0,IL + IF(MOD(IL+IM,2).EQ.1) GO TO 40 + IOF=IOF+1 + Q=Q+QEXT(IOF,I)*PL(IOF,IPQ+M)*(2.0*IL+1.0)/(4.0*PI) + 40 CONTINUE + 45 CONTINUE + Q1=Q*VOL(I)-UPQ(IPQ+M)*(SURF(I)+SURF(I+1))*AFB+(SURF(I+1)- + 1 SURF(I))*(ALPMIN+ALPMAX)*AFGL(I)/WPQ(IPQ+M) + Q2=TOTAL(IBM)*VOL(I)-2.0D0*UPQ(IPQ+M)*SURF(I)+2.0D0* + 1 (SURF(I+1)-SURF(I))*ALPMIN/WPQ(IPQ+M) + E2=Q1/Q2 + IF(LFIXUP.AND.(E2.LE.RLOG)) E2=0.0 + AFB=2.0*E2-AFB ! IN SPACE + IF(LFIXUP.AND.(AFB.LE.RLOG)) AFB=0.0 + AFGL(I)=2.0*REAL(E2)-AFGL(I) ! IN ANGLE + IF(LFIXUP.AND.(AFGL(I).LE.RLOG)) AFGL(I)=0.0 + DO 60 K=1,NSCT + FLUX(K,I)=FLUX(K,I)+4.0*WPQ(IPQ+M)*REAL(E2)*PL(K,IPQ+M) + 60 CONTINUE + 70 CONTINUE + IF(IGAV.EQ.1) THEN + FLXB(2*JOP(IP)-M+1)=REAL(AFB) + ELSE IF(IGAV.EQ.2) THEN + PSIA=PSIA+WPQ(IPQ+M)*REAL(AFB) + WSIA=WSIA+WPQ(IPQ+M) + ENDIF + ALPMAX=ALPMIN + 80 CONTINUE + IF(IGAV.EQ.2) PSIA=PSIA/WSIA +*---- +* FORWARD SWEEP (FROM CENTRAL AXIS TOWARD EXTERNAL SURFACE). +*---- + DO 130 M=JOP(IP),1,-1 ! Angular sweep + ALPMIN=ALPHA(IPQ+M) + IF(IGAV.EQ.1) THEN + AFB=FLXB(M) + ELSE IF(IGAV.EQ.2) THEN + AFB=PSIA + ELSE IF(IGAV.EQ.3) THEN + AFB=PSIA + ENDIF + DO 120 I=1,NREG ! Spatial sweep + Q=0.0 + IBM=MAT(I) + IOF=0 + DO 100 IL=0,ISCAT-1 + DO 90 IM=0,IL + IF(MOD(IL+IM,2).EQ.1) GO TO 90 + IOF=IOF+1 + Q=Q+QEXT(IOF,I)*PL(IOF,IPQ+M)*(2.0*IL+1.0)/(4.0*PI) + 90 CONTINUE + 100 CONTINUE + Q1=Q*VOL(I)+UPQ(IPQ+M)*(SURF(I)+SURF(I+1))*AFB+(SURF(I+1)- + 1 SURF(I))*(ALPMIN+ALPMAX)*AFGL(I)/WPQ(IPQ+M) + Q2=TOTAL(IBM)*VOL(I)+2.0D0*UPQ(IPQ+M)*SURF(I+1)+2.0D0* + 1 (SURF(I+1)-SURF(I))*ALPMIN/WPQ(IPQ+M) + E2=Q1/Q2 + IF(LFIXUP.AND.(E2.LE.RLOG)) E2=0.0 + AFB=2.0*E2-AFB ! IN SPACE + IF(LFIXUP.AND.(AFB.LE.RLOG)) AFB=0.0 + AFGL(I)=2.0*REAL(E2)-AFGL(I) ! IN ANGLE + IF(LFIXUP.AND.(AFGL(I).LE.RLOG)) AFGL(I)=0.0 + DO 110 K=1,NSCT + FLUX(K,I)=FLUX(K,I)+4.0*WPQ(IPQ+M)*REAL(E2)*PL(K,IPQ+M) + 110 CONTINUE + 120 CONTINUE + CURSUM=CURSUM+4.0*WPQ(IPQ+M)*UPQ(IPQ+M)*AFB + ALPMAX=ALPMIN + 130 CONTINUE +*---- +* END OF OUTER LOOP OVER AXIAL LEVELS +*---- + IPQ=IPQ+2*JOP(IP) + 200 CONTINUE + IF(IPQ.NE.NPQ) CALL XABORT('SN1T1C: BUG.') + CURR=REAL(CURSUM) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(AFGL,FLXB) + RETURN + END diff --git a/Dragon/src/SNFT1S.f b/Dragon/src/SNFT1S.f new file mode 100644 index 0000000..0624545 --- /dev/null +++ b/Dragon/src/SNFT1S.f @@ -0,0 +1,185 @@ +*DECK SNFT1S + SUBROUTINE SNFT1S(NREG,NMAT,NLF,NSCT,U,W,ALPHA,PLZ,PL,MAT,VOL, + 1 SURF,XXX,TOTAL,IGAV,QEXT,LFIXUP,CURR,FLUX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform one inner iteration for solving SN equations in 1D spherical +* geometry. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NREG number of regions. +* NMAT number of material mixtures. +* NLF number of SN directions. +* NSCT number of Legendre components in the flux. +* =1 isotropic sources; +* =2 linearly anisotropic sources. +* U base points in $\\mu$ of the 1D quadrature. +* W weights of the quadrature. +* ALPHA angular redistribution terms. +* PLZ discrete values of the spherical harmonics corresponding +* to the 1D quadrature. Used with zero-weight points. +* MN moment-to-discrete matrix. +* DN discrete-to-moment matrix. +* MAT material mixture index in each region. +* VOL volumes of each region. +* SURF surfaces surrounding each region. +* XXX radii. +* TOTAL macroscopic total cross sections. +* IGAV type of condition at axial axis (=1 specular reflection; +* =2 zero-weight reflection; =3 averaged reflection). +* QEXT spherical harmonics components of the fixed source. +* LFIXUP flag to enable negative flux fixup. +* +*Parameters: input/output +* CURR entering current at input and leaving current at output. +* +*Parameters: output +* FLUX spherical harmonics components of the flux. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NREG,NMAT,NLF,NSCT,MAT(NREG),IGAV + REAL U(NLF),W(NLF),ALPHA(NLF),PLZ(NSCT),PL(NSCT,NLF),VOL(NREG), + 1 SURF(NREG+1),XXX(NREG+1),TOTAL(0:NMAT),QEXT(NSCT,NREG),CURR, + 2 FLUX(NSCT,NREG) + LOGICAL LFIXUP +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION Q,E2,AFB,Q1,Q2,PSIA,WSIA,CURSUM + PARAMETER(RLOG=1.0E-8) + REAL, ALLOCATABLE, DIMENSION(:) :: AFGL,FLXB +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(AFGL(NREG),FLXB(NLF/2)) +*---- +* COMPUTE A NORMALIZATION CONSTANT. +*---- + DENOM=0.0 + DO 10 I=1,NLF + IF(U(I).GT.0.0) DENOM=DENOM+W(I)*U(I) + 10 CONTINUE +*---- +* INITIALIZATION SWEEP (USING ZERO-WEIGHT POINTS). AFB IS THE EDGE +* FLUX VALUE AND AFGL(I) IS THE CENTERED FLUX VALUE. +*---- + AFB=CURR/DENOM + DO 30 I=NREG,1,-1 ! Spatial sweep + Q=0.0D0 + IBM=MAT(I) + IOF=0 + DO 20 IL=0,NSCT-1 + Q=Q+QEXT(IL+1,I)*PLZ(IL+1)*(2.0*IL+1.0)/2.0 + 20 CONTINUE + Q1=(XXX(I+1)-XXX(I))*Q+2.0*AFB + Q2=(XXX(I+1)-XXX(I))*TOTAL(IBM)+2.0 + E2=Q1/Q2 + IF(LFIXUP.AND.(E2.LE.RLOG)) E2=0.0 + AFB=2.0*E2-AFB + IF(LFIXUP.AND.(AFB.LE.RLOG)) AFB=0.0 + AFGL(I)=REAL(E2) + IF(LFIXUP.AND.(AFGL(I).LE.RLOG)) AFGL(I)=0.0 + 30 CONTINUE + IF(IGAV.EQ.2) THEN + PSIA=0.0D0 + WSIA=0.0D0 + ELSE + PSIA=AFB + ENDIF +*---- +* BACKWARD SWEEP (FROM EXTERNAL SURFACE TOWARD CENTRAL AXIS). +*---- + FLUX(:NSCT,:NREG)=0.0 + CURSUM=0.0D0 + ALPMIN=0.0 + DO 80 IP=1,NLF/2 + AFB=CURR/DENOM + ALPMAX=ALPHA(IP) + DO 70 I=NREG,1,-1 ! Spatial sweep + Q=0.0 + IBM=MAT(I) + IOF=0 + DO 40 IL=0,NSCT-1 + Q=Q+QEXT(IL+1,I)*PL(IL+1,IP)*(2.0*IL+1.0)/2.0 + 40 CONTINUE + Q1=Q*VOL(I)-U(IP)*(SURF(I)+SURF(I+1))*AFB+0.5D0*(SURF(I+1)- + 1 SURF(I))*(ALPMIN+ALPMAX)*AFGL(I)/W(IP) + Q2=TOTAL(IBM)*VOL(I)-2.0D0*U(IP)*SURF(I)+(SURF(I+1)-SURF(I))* + 1 ALPMAX/W(IP) + E2=Q1/Q2 + IF(LFIXUP.AND.(E2.LE.RLOG)) E2=0.0 + AFB=2.0*E2-AFB ! IN SPACE + IF(LFIXUP.AND.(AFB.LE.RLOG)) AFB=0.0 + AFGL(I)=2.0*REAL(E2)-AFGL(I) ! IN ANGLE + IF(LFIXUP.AND.(AFGL(I).LE.RLOG)) AFGL(I)=0.0 + DO 60 K=1,NSCT + FLUX(K,I)=FLUX(K,I)+W(IP)*REAL(E2)*PL(K,IP) + 60 CONTINUE + 70 CONTINUE + IF(IGAV.EQ.1) THEN + FLXB(IP)=REAL(AFB) + ELSE IF(IGAV.EQ.2) THEN + PSIA=PSIA+W(IP)*REAL(AFB) + WSIA=WSIA+W(IP) + ENDIF + ALPMIN=ALPMAX + 80 CONTINUE + IF(IGAV.EQ.2) PSIA=PSIA/WSIA +*---- +* FORWARD SWEEP (FROM CENTRAL AXIS TOWARD EXTERNAL SURFACE). +*---- + DO 130 IP=1+NLF/2,NLF + ALPMAX=ALPHA(IP) + IF(IGAV.EQ.1) THEN + AFB=FLXB(NLF-IP+1) + ELSE IF(IGAV.EQ.2) THEN + AFB=PSIA + ELSE IF(IGAV.EQ.3) THEN + AFB=PSIA + ENDIF + DO 120 I=1,NREG ! Spatial sweep + Q=0.0 + IBM=MAT(I) + IOF=0 + DO 90 IL=0,NSCT-1 + Q=Q+QEXT(IL+1,I)*PL(IL+1,IP)*(2.0*IL+1.0)/2.0 + 90 CONTINUE + Q1=Q*VOL(I)+U(IP)*(SURF(I)+SURF(I+1))*AFB+0.5D0*(SURF(I+1)- + 1 SURF(I))*(ALPMIN+ALPMAX)*AFGL(I)/W(IP) + Q2=TOTAL(IBM)*VOL(I)+2.0D0*U(IP)*SURF(I+1)+(SURF(I+1)-SURF(I))* + 1 ALPMAX/W(IP) + E2=Q1/Q2 + IF(LFIXUP.AND.(E2.LE.RLOG)) E2=0.0 + AFB=2.0*E2-AFB ! IN SPACE + IF(LFIXUP.AND.(AFB.LE.RLOG)) AFB=0.0 + AFGL(I)=2.0*REAL(E2)-AFGL(I) ! IN ANGLE + IF(LFIXUP.AND.(AFGL(I).LE.RLOG)) AFGL(I)=0.0 + DO 110 K=1,NSCT + FLUX(K,I)=FLUX(K,I)+W(IP)*REAL(E2)*PL(K,IP) + 110 CONTINUE + 120 CONTINUE + CURSUM=CURSUM+W(IP)*U(IP)*AFB + ALPMIN=ALPMAX + 130 CONTINUE + CURR=REAL(CURSUM) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(FLXB,AFGL) + RETURN + END diff --git a/Dragon/src/SNGMRE.f b/Dragon/src/SNGMRE.f new file mode 100644 index 0000000..10a439f --- /dev/null +++ b/Dragon/src/SNGMRE.f @@ -0,0 +1,229 @@ +*DECK SNGMRE + SUBROUTINE SNGMRE (KPSYS,NGIND,IPTRK,IMPX,NGEFF,NREG,NBMIX,NUN, + 1 NSTART,MAXIT,EPSINR,MAT,VOL,KEYFLX,FUNKNO,SUNKNO,NBS,KPSOU1, + 2 KPSOU2,FLUXC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solve N-group transport equation for fluxes using the discrete +* ordinates (SN) method with a GMRES(m) acceleration. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* KPSYS pointer to the assembly matrices. KPSYS is an array of +* directories. +* NGIND energy group indices assign to the NGEFF set. +* IPTRK pointer to the tracking (L_TRACK signature). +* IMPX print flag (equal to zero for no print). +* NGEFF number of energy groups processed in parallel. +* NREG total number of regions for which specific values of the +* neutron flux and reactions rates are required. +* NBMIX number of mixtures. +* NUN total number of unknowns in vectors SUNKNO and FUNKNO. +* NSTART restarts the GMRES method every NSTART iterations. +* MAXIT maximum number of inner iterations. +* EPSINR convergence criterion. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX position of averaged flux elements in FUNKNO vector. +* SUNKNO input source vector. +* +*Parameters: input/output +* FUNKNO unknown vector. +* FLUXC flux at the cutoff energy. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NGEFF,NGIND(NGEFF),IMPX,NREG,NBMIX,NUN,NSTART,MAXIT, + 1 MAT(NREG),KEYFLX(NREG),NBS(NGEFF) + TYPE(C_PTR) KPSYS(NGEFF),IPTRK,KPSOU1(NGEFF),KPSOU2(NGEFF) + REAL EPSINR,VOL(NREG),FUNKNO(NUN,NGEFF),SUNKNO(NUN,NGEFF) + REAL,OPTIONAL :: FLUXC(NREG) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6) + REAL SDOT +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KMAX + REAL, ALLOCATABLE, DIMENSION(:,:) :: RR,QQ + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: EPS1,RHO + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: G,C,S,X + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: V,H + LOGICAL, ALLOCATABLE, DIMENSION(:) :: INCONV +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(G(NSTART+1,NGEFF),C(NSTART+1,NGEFF),S(NSTART+1,NGEFF), + 1 X(NUN,NGEFF),V(NUN,NSTART+1,NGEFF),H(NSTART+1,NSTART,NGEFF), + 1 EPS1(NGEFF),INCONV(NGEFF),KMAX(NGEFF),RHO(NGEFF)) + ALLOCATE(RR(NUN,NGEFF),QQ(NUN,NGEFF)) +*---- +* GLOBAL GMRES ITERATION. +*---- + DO II=1,NGEFF + EPS1(II)=EPSINR*SQRT(SDOT(NUN,SUNKNO(1,II),1,SUNKNO(1,II),1)) + RHO(II)=1.0E10 + INCONV(II)=(EPS1(II).NE.0.0) + ENDDO + LNCONV=NGEFF + ITER=0 + NITER=1 + DO WHILE((LNCONV.GT.0).AND.(ITER.LT.MAXIT)) + RR(:NUN,:NGEFF)=FUNKNO(:NUN,:NGEFF) + CALL SNFLUX(KPSYS,INCONV,NGIND,IPTRK,IMPX,NGEFF,NREG, + 1 NBMIX,NUN,MAT,VOL,KEYFLX,RR,SUNKNO(1,1),NITER,NBS,KPSOU1, + 2 KPSOU2,FLUXC) + NITER=NITER+1 + DO II=1,NGEFF + IF(.NOT.INCONV(II)) CYCLE + X(:NUN,II)=RR(:NUN,II)-FUNKNO(:NUN,II) + RHO(II)=SQRT(DOT_PRODUCT(X(:NUN,II),X(:NUN,II))) + IF(RHO(II).LT.EPS1(II)) THEN + LNCONV=LNCONV-1 + INCONV(II)=.FALSE. + ENDIF + ENDDO +*---- +* TEST FOR TERMINATION ON ENTRY +*---- + IF(LNCONV.EQ.0) GO TO 100 +* + G(:NSTART+1,:NGEFF)=0.0D0 + C(:NSTART+1,:NGEFF)=0.0D0 + S(:NSTART+1,:NGEFF)=0.0D0 + V(:NUN,:NSTART+1,:NGEFF)=0.0D0 + H(:NSTART+1,:NSTART,:NGEFF)=0.0D0 + KMAX(:NGEFF)=0 + DO II=1,NGEFF + IF(.NOT.INCONV(II)) CYCLE + G(1,II)=RHO(II) + DO I=1,NUN + V(I,1,II)=X(I,II)/RHO(II) + X(I,II)=FUNKNO(I,II) + ENDDO + ENDDO +*---- +* GMRES(1) ITERATION +*---- + K=0 + DO WHILE((LNCONV.GT.0).AND.(K.LT.NSTART).AND.(ITER.LT.MAXIT)) + K=K+1 + ITER=ITER+1 + IF(IMPX.GT.2) WRITE(IUNOUT,300) ITER,MAXVAL(RHO(:NGEFF)), + 1 LNCONV + RR(:NUN,:NGEFF)=0.0 + QQ(:NUN,:NGEFF)=0.0 + DO II=1,NGEFF + IF(.NOT.INCONV(II)) CYCLE + RR(:NUN,II)=REAL(V(:NUN,K,II)) + ENDDO + CALL SNFLUX(KPSYS,INCONV,NGIND,IPTRK,IMPX,NGEFF,NREG, + 1 NBMIX,NUN,MAT,VOL,KEYFLX,RR,QQ(1,1),NITER,NBS,KPSOU1, + 2 KPSOU2,FLUXC) + NITER=NITER+1 + DO II=1,NGEFF + IF(.NOT.INCONV(II)) CYCLE + V(:NUN,K+1,II)=V(:NUN,K,II)-RR(:NUN,II) + KMAX(II)=K +*---- +* MODIFIED GRAM-SCHMIDT +*---- + DO J=1,K + HR=DOT_PRODUCT(V(:NUN,J,II),V(:NUN,K+1,II)) + H(J,K,II)=HR + V(:NUN,K+1,II)=V(:NUN,K+1,II)-HR*V(:NUN,J,II) + ENDDO + H(K+1,K,II)=SQRT(DOT_PRODUCT(V(:NUN,K+1,II),V(:NUN,K+1,II))) +*---- +* REORTHOGONALIZE +*---- + DO J=1,K + HR=DOT_PRODUCT(V(:NUN,J,II),V(:NUN,K+1,II)) + H(J,K,II)=H(J,K,II)+HR + V(:NUN,K+1,II)=V(:NUN,K+1,II)-HR*V(:NUN,J,II) + ENDDO + H(K+1,K,II)=SQRT(DOT_PRODUCT(V(:NUN,K+1,II),V(:NUN,K+1,II))) +*---- +* WATCH OUT FOR HAPPY BREAKDOWN +*---- + IF(H(K+1,K,II).NE.0.0) THEN + V(:NUN,K+1,II)=V(:NUN,K+1,II)/H(K+1,K,II) + ENDIF +*---- +* FORM AND STORE THE INFORMATION FOR THE NEW GIVENS ROTATION +*---- + DO I=1,K-1 + W1=C(I,II)*H(I,K,II)-S(I,II)*H(I+1,K,II) + W2=S(I,II)*H(I,K,II)+C(I,II)*H(I+1,K,II) + H(I,K,II)=W1 + H(I+1,K,II)=W2 + ENDDO + ZNU=SQRT(H(K,K,II)**2+H(K+1,K,II)**2) + IF(ZNU.NE.0.0) THEN + C(K,II)=H(K,K,II)/ZNU + S(K,II)=-H(K+1,K,II)/ZNU + H(K,K,II)=C(K,II)*H(K,K,II)-S(K,II)*H(K+1,K,II) + H(K+1,K,II)=0.0D0 + W1=C(K,II)*G(K,II)-S(K,II)*G(K+1,II) + W2=S(K,II)*G(K,II)+C(K,II)*G(K+1,II) + G(K,II)=W1 + G(K+1,II)=W2 + ENDIF +*---- +* UPDATE THE RESIDUAL NORM +*---- + RHO(II)=ABS(G(K+1,II)) + IF(RHO(II).LE.EPS1(II)) THEN + INCONV(II)=.FALSE. + LNCONV=LNCONV-1 + ENDIF + ENDDO + ENDDO +*---- +* AT THIS POINT EITHER K > NSTART OR RHO < EPS1. +* IT'S TIME TO COMPUTE X AND CYCLE. +*---- + DO II=1,NGEFF + K=KMAX(II) + IF(K.EQ.0) CYCLE + G(K,II)=G(K,II)/H(K,K,II) + DO L=K-1,1,-1 + W1=G(L,II)-DOT_PRODUCT(H(L,L+1:K,II),G(L+1:K,II)) + G(L,II)=W1/H(L,L,II) + ENDDO + DO J=1,K + X(:,II)=X(:,II)+G(J,II)*V(:,J,II) + ENDDO + FUNKNO(:,II)=REAL(X(:,II)) + ENDDO + ENDDO +* + IF(IMPX.GT.2) WRITE(IUNOUT,'(32H SNGMRE: NUMBER OF ONE-SPEED ITE, + 1 8HRATIONS=,I5,1H.)') ITER +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 100 DEALLOCATE(QQ,RR) + DEALLOCATE(RHO,KMAX,INCONV,EPS1,H,V,X,S,C,G) + RETURN +* + 300 FORMAT(28H SNGMRE: ONE-SPEED ITERATION,I4,10H L2 NORM=,1P,E11.4, + 1 23H NON-CONVERGED GROUPS=,I5) + END diff --git a/Dragon/src/SNQU01.f b/Dragon/src/SNQU01.f new file mode 100644 index 0000000..0959d2f --- /dev/null +++ b/Dragon/src/SNQU01.f @@ -0,0 +1,143 @@ +*DECK SNQU01 + SUBROUTINE SNQU01(NLF,JOP,U,W,TPQ,UPQ,VPQ,WPQ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Set the level-symmetric (type 1) quadratures. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NLF order of the SN approximation (even number). +* +*Parameters: output +* JOP number of base points per axial level in one octant. +* U base points in $\\xi$ of the axial quadrature. Used with +* zero-weight points. +* W weights for the axial quadrature in $\\xi$. +* TPQ base points in $\\xi$ of the 2D SN quadrature. +* UPQ base points in $\\mu$ of the 2D SN quadrature. +* VPQ base points in $\\eta$ of the 2D SN quadrature. +* WPQ weights of the 2D SN quadrature. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NLF,JOP(NLF/2) + REAL U(NLF/2),W(NLF/2),TPQ(NLF*(NLF/2+1)/4),UPQ(NLF*(NLF/2+1)/4), + 1 VPQ(NLF*(NLF/2+1)/4),WPQ(NLF*(NLF/2+1)/4) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(PI=3.141592654,MAXNLF=20,MAXNBA=55,MAXW=12) + INTEGER INWEI(MAXNBA) + DOUBLE PRECISION ZMU1,ZMU2,WSUM2,WEI(MAXW) +*---- +* SET THE UNIQUE QUADRATURE VALUES. +*---- + IF(NLF.GT.MAXNLF) CALL XABORT('SNQU01: MAXNLF OVERFLOW.') + M2=NLF/2 + NPQ=M2*(M2+1)/2 + NW=1+(NLF*(NLF+8)-1)/48 + IF(NW.GT.MAXW) CALL XABORT('SNQU01: MAXW OVERFLOW.') + ZMU1=0.0D0 + WEI(:NW)=0.0D0 + IF(NLF.EQ.2) THEN + ZMU1=1.0D0/3.0D0 + WEI(1)=1.0D0 + ELSE IF(NLF.EQ.4) THEN + ZMU1=0.3500212**2 + WEI(1)=1.0D0/3.0D0 + ELSE IF(NLF.EQ.6) THEN + ZMU1=0.2666355**2 + WEI(1)=0.1761263 + WEI(2)=0.1572071 + ELSE IF(NLF.EQ.8) THEN + ZMU1=1.0D0/21.0D0 + WEI(1)=0.1209877 + WEI(2)=0.0907407 + WEI(3)=0.0925926 + ELSE IF(NLF.EQ.12) THEN + ZMU1=0.1672126**2 + WEI(1)=0.0707626 + WEI(2)=0.0558811 + WEI(3)=0.0373377 + WEI(4)=0.0502819 + WEI(5)=0.0258513 + ELSE IF(NLF.EQ.16) THEN + ZMU1=0.1389568**2 + WEI(1)=0.0489872 + WEI(2)=0.0413296 + WEI(3)=0.0212326 + WEI(4)=0.0256207 + WEI(5)=0.0360486 + WEI(6)=0.0144586 + WEI(7)=0.0344958 + WEI(8)=0.0085179 + ELSE + CALL XABORT('SNQU01: ORDER NOT AVAILABLE.') + ENDIF + U(1)=REAL(SQRT(ZMU1)) + DO I=2,M2 + ZMU2=ZMU1+2.0D0*DBLE(I-1)*(1.0D0-3.0D0*ZMU1)/DBLE(NLF-2) + U(I)=REAL(SQRT(ZMU2)) + ENDDO +*---- +* COMPUTE THE POSITION OF WEIGHTS. +*---- + IPR=0 + INMAX=0 + DO IP=1,M2 + JOP(IP)=M2-IP+1 + DO IQ=1,JOP(IP) + IPR=IPR+1 + IF(IPR.GT.MAXNBA) CALL XABORT('SNQU01: MAXNBA OVERFLOW.') + TPQ(IPR)=U(IP) + UPQ(IPR)=U(M2+2-IP-IQ) + VPQ(IPR)=U(IQ) + IS=MIN(IP,IQ,M2+2-IP-IQ) + NW0=0 + DO II=1,IS-1 + NW0=NW0+(M2-3*(II-1)+1)/2 + ENDDO + KK=IP-IS+1 + LL=IQ-IS+1 + IF(KK.EQ.1)THEN + INWEI(IPR)=NW0+MIN(LL,M2-3*(IS-1)+1-LL) + ELSEIF(LL.EQ.1)THEN + INWEI(IPR)=NW0+MIN(KK,M2-3*(IS-1)+1-KK) + ELSE + INWEI(IPR)=NW0+MIN(KK,LL) + ENDIF + INMAX=MAX(INMAX,INWEI(IPR)) + ENDDO + ENDDO + IF(INMAX.NE.NW) CALL XABORT('SNQU01: INVALID VALUE OD NW.') + IF(IPR.NE.NPQ) CALL XABORT('SNQU01: BAD VALUE ON NPQ.') +*---- +* SET THE LEVEL-SYMMETRIC QUADRATURES. +*---- + IPQ=0 + WSUM=0.0 + DO IP=1,M2 + WSUM2=0.0D0 + DO IQ=1,JOP(IP) + IPQ=IPQ+1 + WPQ(IPQ)=REAL(WEI(INWEI(IPQ))*PI/2.0) + WSUM2=WSUM2+WEI(INWEI(IPQ)) + ENDDO + W(IP)=REAL(WSUM2) + WSUM=WSUM+REAL(WSUM2*PI/2.0) + ENDDO + RETURN + END diff --git a/Dragon/src/SNQU02.f b/Dragon/src/SNQU02.f new file mode 100644 index 0000000..dcc4665 --- /dev/null +++ b/Dragon/src/SNQU02.f @@ -0,0 +1,158 @@ +*DECK SNQU02 + SUBROUTINE SNQU02(NLF,JOP,U,W,TPQ,UPQ,VPQ,WPQ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Set the level-symmetric (type 2) quadratures. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NLF order of the SN approximation (even number). +* +*Parameters: output +* JOP number of base points per axial level in one octant. +* U base points in $\\xi$ of the axial quadrature. Used with +* zero-weight points. +* W weights for the axial quadrature in $\\xi$. +* TPQ base points in $\\xi$ of the 2D SN quadrature. +* UPQ base points in $\\mu$ of the 2D SN quadrature. +* VPQ base points in $\\eta$ of the 2D SN quadrature. +* WPQ weights of the 2D SN quadrature. +* +*----------------------------------------------------------------------- +* + IMPLICIT DOUBLE PRECISION(A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NLF,JOP(NLF/2) + REAL U(NLF/2),W(NLF/2),TPQ(NLF*(NLF/2+1)/4),UPQ(NLF*(NLF/2+1)/4), + 1 VPQ(NLF*(NLF/2+1)/4),WPQ(NLF*(NLF/2+1)/4) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(PI=3.141592654,MAXNLF=24,MAXEQ=64,MAXNBA=78,MAXW=16) + INTEGER INWEI(MAXNBA) + DOUBLE PRECISION WSUM2,WEI(MAXW),ZMAT(MAXEQ,MAXW+1),UD(MAXW) +*---- +* SET THE UNIQUE QUADRATURE VALUES. +*---- + IF(NLF.GT.MAXNLF) CALL XABORT('SNQU02: MAXNLF OVERFLOW.') + M2=NLF/2 + NPQ=M2*(M2+1)/2 + ZMU1=1.0D0/(3.0D0*DBLE(NLF-1)) + NW=1+(NLF*(NLF+8)-1)/48 + IF(NW.GT.MAXW) CALL XABORT('SNQU02: MAXW OVERFLOW.') + IF(NLF.EQ.2) THEN + ZMU1=0.33333333 + ELSE IF(NLF.EQ.4) THEN + ZMU1=0.12251480 + ELSE IF(NLF.EQ.6) THEN + ZMU1=0.07109447 + ELSE IF(NLF.EQ.8) THEN + ZMU1=0.04761903 + ELSE IF(NLF.EQ.10) THEN + ZMU1=0.03584310 + ELSE IF(NLF.EQ.12) THEN + ZMU1=0.02796615 + ELSE IF(NLF.EQ.14) THEN + ZMU1=0.02310250 + ELSE IF(NLF.EQ.16) THEN + ZMU1=0.01931398 + ELSE IF(NLF.EQ.18) THEN + ZMU1=0.01692067 + ELSE IF(NLF.EQ.20) THEN + ZMU1=0.01455253 + ELSE + CALL XABORT('SNQU02: ORDER NOT AVAILABLE.') + ENDIF + U(1)=REAL(SQRT(ZMU1)) + DO I=2,M2 + ZMU2=ZMU1+2.0D0*DBLE(I-1)*(1.0D0-3.0D0*ZMU1)/DBLE(NLF-2) + U(I)=REAL(SQRT(ZMU2)) + ENDDO +*---- +* COMPUTE THE POSITION OF WEIGHTS. +*---- + IPR=0 + INMAX=0 + DO IP=1,M2 + JOP(IP)=M2-IP+1 + DO IQ=1,JOP(IP) + IPR=IPR+1 + IF(IPR.GT.MAXNBA) CALL XABORT('SNQU02: MAXNBA OVERFLOW.') + TPQ(IPR)=U(IP) + UPQ(IPR)=U(M2+2-IP-IQ) + VPQ(IPR)=U(IQ) + IS=MIN(IP,IQ,M2+2-IP-IQ) + NW0=0 + DO II=1,IS-1 + NW0=NW0+(M2-3*(II-1)+1)/2 + ENDDO + KK=IP-IS+1 + LL=IQ-IS+1 + IF(KK.EQ.1)THEN + INWEI(IPR)=NW0+MIN(LL,M2-3*(IS-1)+1-LL) + ELSEIF(LL.EQ.1)THEN + INWEI(IPR)=NW0+MIN(KK,M2-3*(IS-1)+1-KK) + ELSE + INWEI(IPR)=NW0+MIN(KK,LL) + ENDIF + INMAX=MAX(INMAX,INWEI(IPR)) + ENDDO + ENDDO + IF(INMAX.NE.NW) CALL XABORT('SNQU02: INVALID VALUE OF NW.') + IF(IPR.NE.NPQ) CALL XABORT('SNQU02: BAD VALUE ON NPQ.') +*---- +* SET THE RECTANGULAR SYSTEM AND SOLVE IT USING THE QR METHOD. +*---- + NEQ=0 + DO IPL=0,NLF,2 + DO IPK=IPL,NLF-IPL,2 + IF(MOD(IPL+IPK,2).EQ.1) CYCLE + NEQ=NEQ+1 + IF(NEQ.GT.MAXEQ) CALL XABORT('SNQU02: MAXEQ OVERFLOW.') + DO IW=1,NW + ZMAT(NEQ,IW)=0.0D0 + ENDDO + DO IPQ=1,NPQ + ZMU=TPQ(IPQ) + ZETA=UPQ(IPQ) + IW=INWEI(IPQ) + ZMAT(NEQ,IW)=ZMAT(NEQ,IW)+(ZMU**IPK)*(ZETA**IPL) + ENDDO + REF=1.0D0/DBLE(IPK+IPL+1) + DO I=1,IPL-1,2 + REF=REF*DBLE(I)/DBLE(IPK+I) + ENDDO + ZMAT(NEQ,NW+1)=REF + ENDDO + ENDDO + CALL ALST2F(MAXEQ,NEQ,NW,ZMAT,UD) + CALL ALST2S(MAXEQ,NEQ,NW,ZMAT,UD,ZMAT(1,NW+1),WEI) +*---- +* SET THE LEVEL-SYMMETRIC QUADRATURES. +*---- + IPQ=0 + WSUM=0.0 + DO IP=1,M2 + WSUM2=0.0D0 + DO IQ=1,JOP(IP) + IPQ=IPQ+1 + WPQ(IPQ)=REAL(WEI(INWEI(IPQ))*PI/2.0) + WSUM2=WSUM2+WEI(INWEI(IPQ)) + ENDDO + W(IP)=REAL(WSUM2) + WSUM=WSUM+REAL(WSUM2*PI/2.0) + ENDDO + RETURN + END diff --git a/Dragon/src/SNQU03.f b/Dragon/src/SNQU03.f new file mode 100644 index 0000000..07e5c89 --- /dev/null +++ b/Dragon/src/SNQU03.f @@ -0,0 +1,121 @@ +*DECK SNQU03 + SUBROUTINE SNQU03(NLF,JOP,U,W,TPQ,UPQ,VPQ,WPQ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Set the level-symmetric quadratures of code SNOW. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NLF order of the SN approximation (even number). +* +*Parameters: output +* JOP number of base points per axial level in one octant. +* U base points in $\\xi$ of the axial quadrature. Used with +* zero-weight points. +* W weights for the axial quadrature in $\\xi$. +* TPQ base points in $\\xi$ of the 2D SN quadrature. +* UPQ base points in $\\mu$ of the 2D SN quadrature. +* VPQ base points in $\\eta$ of the 2D SN quadrature. +* WPQ weights of the 2D SN quadrature. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NLF,JOP(NLF/2) + REAL U(NLF/2),W(NLF/2),TPQ(NLF*(NLF/2+1)/4),UPQ(NLF*(NLF/2+1)/4), + 1 VPQ(NLF*(NLF/2+1)/4),WPQ(NLF*(NLF/2+1)/4) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(PI=3.141592654,MAXNLF=20,MAXNBA=55,MAXW=12) + INTEGER INWEI(MAXNBA) + DOUBLE PRECISION ZMU1,ZMU2,WSUM2,WEI(MAXW) +*---- +* SET THE UNIQUE QUADRATURE VALUES. +*---- + IF(NLF.GT.MAXNLF) CALL XABORT('SNQU03: MAXNLF OVERFLOW.') + M2=NLF/2 + NPQ=M2*(M2+1)/2 + ZMU1=1.0D0/(3.0D0*DBLE(NLF-1)) + NW=1+(NLF*(NLF+8)-1)/48 + IF(NW.GT.MAXW) CALL XABORT('SNQU03: MAXW OVERFLOW.') + IF(NLF.EQ.2) THEN + WEI(1)=1.0D0 + ELSE IF(NLF.EQ.4) THEN + WEI(1)=0.3333333 + ELSE IF(NLF.EQ.6) THEN + WEI(1)=0.1608612 + WEI(2)=0.1724721 + ELSE IF(NLF.EQ.8) THEN + WEI(1)=0.1066008 + WEI(2)=0.1011727 + WEI(3)=0.0731616 + ELSE + CALL XABORT('SNQU03: ORDER NOT AVAILABLE.') + ENDIF + U(1)=REAL(SQRT(ZMU1)) + DO I=2,M2 + ZMU2=ZMU1+2.0D0*DBLE(I-1)*(1.0D0-3.0D0*ZMU1)/DBLE(NLF-2) + U(I)=REAL(SQRT(ZMU2)) + ENDDO +*---- +* COMPUTE THE POSITION OF WEIGHTS. +*---- + IPR=0 + INMAX=0 + DO IP=1,M2 + JOP(IP)=M2-IP+1 + DO IQ=1,JOP(IP) + IPR=IPR+1 + IF(IPR.GT.MAXNBA) CALL XABORT('SNQU03: MAXNBA OVERFLOW.') + TPQ(IPR)=U(IP) + UPQ(IPR)=U(M2+2-IP-IQ) + VPQ(IPR)=U(IQ) + IS=MIN(IP,IQ,M2+2-IP-IQ) + NW0=0 + DO II=1,IS-1 + NW0=NW0+(M2-3*(II-1)+1)/2 + ENDDO + KK=IP-IS+1 + LL=IQ-IS+1 + IF(KK.EQ.1)THEN + INWEI(IPR)=NW0+MIN(LL,M2-3*(IS-1)+1-LL) + ELSEIF(LL.EQ.1)THEN + INWEI(IPR)=NW0+MIN(KK,M2-3*(IS-1)+1-KK) + ELSE + INWEI(IPR)=NW0+MIN(KK,LL) + ENDIF + INMAX=MAX(INMAX,INWEI(IPR)) + ENDDO + ENDDO + IF(INMAX.NE.NW) CALL XABORT('SNQU03: INVALID VALUE OD NW.') + IF(IPR.NE.NPQ) CALL XABORT('SNQU03: BAD VALUE ON NPQ.') +*---- +* SET THE LEVEL-SYMMETRIC QUADRATURES. +*---- + IPQ=0 + WSUM=0.0 + DO IP=1,M2 + WSUM2=0.0D0 + DO IQ=1,JOP(IP) + IPQ=IPQ+1 + WPQ(IPQ)=REAL(WEI(INWEI(IPQ))*PI/2.0) + WSUM2=WSUM2+WEI(INWEI(IPQ)) + ENDDO + W(IP)=REAL(WSUM2) + WSUM=WSUM+REAL(WSUM2*PI/2.0) + ENDDO + RETURN + END diff --git a/Dragon/src/SNQU04.f b/Dragon/src/SNQU04.f new file mode 100644 index 0000000..a04f36f --- /dev/null +++ b/Dragon/src/SNQU04.f @@ -0,0 +1,76 @@ +*DECK SNQU04 + SUBROUTINE SNQU04(NLF,JOP,U,W,TPQ,UPQ,VPQ,WPQ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Set the Gauss-Legendre, Gauss-Chebyshev quadratures. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NLF order of the SN approximation (even number). +* +*Parameters: output +* JOP number of base points per axial level in one octant. +* U base points in $\\xi$ of the axial quadrature. Used with +* zero-weight points. +* W weights for the axial quadrature in $\\xi$. +* TPQ base points in $\\xi$ of the 2D SN quadrature. +* UPQ base points in $\\mu$ of the 2D SN quadrature. +* VPQ base points in $\\eta$ of the 2D SN quadrature. +* WPQ weights of the 2D SN quadrature. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NLF,JOP(NLF/2) + REAL U(NLF/2),W(NLF/2),TPQ(NLF*(NLF/2+1)/4),UPQ(NLF*(NLF/2+1)/4), + 1 VPQ(NLF*(NLF/2+1)/4),WPQ(NLF*(NLF/2+1)/4) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(PI=3.141592654,MAXNLF=64) + REAL U2(MAXNLF),W2(MAXNLF) +*---- +* SET THE QUARATURE VALUES. +*---- + M2=NLF/2 + NPQ=M2*(M2+1)/2 + IF(NLF.EQ.2) THEN + U(1)=1/SQRT(3.0) + W(1)=1.0 + ELSE + IF(NLF.GT.MAXNLF) CALL XABORT('SNQU04: TOO MANY GAUSS POINTS.') + CALL ALGPT(NLF,-1.0,1.0,U2,W2) + DO 45 M=1,M2 + U(M)=U2(M2+M) + W(M)=W2(M2+M) + 45 CONTINUE + ENDIF + IPQ=0 + WSUM=0.0 + DO IP=1,M2 + JOP(IP)=M2-IP+1 + DO IQ=1,JOP(IP) + IPQ=IPQ+1 + OMEGA=0.5*PI*(1.0-REAL(NLF-2*IP-2*IQ+3)/REAL(NLF-2*IP+2)) + TPQ(IPQ)=U(IP) + UPQ(IPQ)=SQRT(1.0-U(IP)*U(IP))*COS(OMEGA) + VPQ(IPQ)=SQRT(1.0-U(IP)*U(IP))*SIN(OMEGA) + WPQ(IPQ)=PI*W(IP)/REAL(NLF-2*IP+2) + WSUM=WSUM+WPQ(IPQ) + ENDDO + ENDDO + IF(IPQ.NE.NPQ) CALL XABORT('SNQU04: BAD VALUE ON NPQ.') + RETURN + END diff --git a/Dragon/src/SNQU05.f b/Dragon/src/SNQU05.f new file mode 100644 index 0000000..b141193 --- /dev/null +++ b/Dragon/src/SNQU05.f @@ -0,0 +1,367 @@ +*DECK SNQU05 + SUBROUTINE SNQU05(NLF,TPQ,UPQ,VPQ,WPQ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To define symmetric Legendre-Chebyshev quadrature angles. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal. +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* M. Hampartzounian +* +*Update(s): +* Adapted to SNT: module of N.Martin. +* +*Parameters: input +* NLF order of the SN approximation (even number). +* +*Parameters: output +* TPQ base points in $\\xi$ of the 2D/3D SN quadrature. +* UPQ base points in $\\mu$ of the 2D/3D SN quadrature. +* VPQ base points in $\\eta$ of the 2D/3D SN quadrature. +* WPQ weights of the 2D/3D SN quadrature. +* +*Reference: +* G. Longoni, A. Haghighat, +* Development of New Quadrature Sets with the +* Ordinate Splitting Technique, +* M&C 2001, Salt Lake City, September 2001. +* +*----------------------------------------------------------------------- +* +*---- +* Subroutine arguments +*---- + INTEGER NLF + REAL TPQ(NLF*(NLF/2+1)/4),UPQ(NLF*(NLF/2+1)/4), + 1 VPQ(NLF*(NLF/2+1)/4),WPQ(NLF*(NLF/2+1)/4) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='SNQU05',MAXNLF=44) + DOUBLE PRECISION DZERO,DONE,DTWO,PID2 + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Functions +*---- + DOUBLE PRECISION XDRCST,PI +*---- +* Local variables +*---- + INTEGER NBPT,ILEVEL,JLEVEL,NLEVEL,KLEVEL,IPOINT,IPT + DOUBLE PRECISION ALPHA,XI,ROTXI,COSA,SINA +*---- +* Data +*---- + INTEGER IS,IA + DOUBLE PRECISION SYST(2,253) + SAVE SYST +*---- +* Set quadrature points and weights +*---- + IF(NLF.GT.MAXNLF) CALL XABORT('SNQU05: MAXNLF OVERFLOW.') +*---- +* Order = 2 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 1, 1)/ + > 0.577350269189626D0,1.0D0/ +*---- +* Order = 4 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 2, 3)/ + > 0.33998104358486D0,0.32607257743127D0,0.86113631159405D0, + > 0.34785484513745D0/ +*---- +* Order = 6 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 4, 6)/ + > 0.23861918608320D0,0.15597131152423D0,0.66120938646626D0, + > 0.18038078652407D0,0.93246951420315D0,0.17132449237917D0/ +*---- +* Order = 8 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 7, 10)/ + > 0.18343464249565D0,0.09067094584459D0,0.52553240991633D0, + > 0.10456888195930D0,0.79666647741362D0,0.11119051722669D0, + > 0.96028985649754D0,0.10122853629037D0/ +*---- +* Order = 10 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 11, 15)/ + > 0.14887433898163D0,0.05910484494295D0,0.43339539412925D0, + > 0.06731667982750D0,0.67940956829902D0,0.07302878750533D0, + > 0.86506336668898D0,0.07472567457529D0,0.97390652851718D0, + > 0.06667134430868D0/ +*---- +* Order = 12 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 16, 21)/ + > 0.12523340851147D0,0.04152450763557D0,0.36783149899818D0, + > 0.04669850730767D0,0.58731795428663D0,0.05079185668077D0, + > 0.76990267419428D0,0.05335944284779D0,0.90411725637050D0, + > 0.05346966299765D0,0.98156063424671D0,0.04717533638653D0/ +*---- +* Order = 14 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 22, 28)/ + > 0.10805494870734D0,0.03075197906617D0,0.31911236892789D0, + > 0.03419974395355D0,0.51524863635816D0,0.03710767949559D0, + > 0.68729290481172D0,0.03930079178955D0,0.82720131506965D0, + > 0.04050619022934D0,0.92843488366371D0,0.04007904357982D0, + > 0.98628380869675D0,0.03511946033190D0/ +*---- +* Order = 16 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 29, 36)/ + > 0.09501250983764D0,0.02368132630688D0,0.28160355077926D0, + > 0.02608620214927D0,0.45801677765726D0,0.02819275323250D0, + > 0.61787624440245D0,0.02991919776332D0,0.75540440835553D0, + > 0.03115724281390D0,0.86563120238710D0,0.03171950389411D0, + > 0.94457502307371D0,0.03112676196937D0,0.98940093499154D0, + > 0.02715245941196D0/ +*---- +* Order = 18 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 37, 45)/ + > 0.08477501304174D0,0.01879359810702D0,0.25188622569150D0, + > 0.02053456046823D0,0.41175116146291D0,0.02209781073233D0, + > 0.55977083107372D0,0.02344048577842D0,0.69168704306110D0, + > 0.02451104134236D0,0.80370495897046D0,0.02523551102634D0, + > 0.89260246650148D0,0.02547524341783D0,0.95582394956707D0, + > 0.02485727444991D0,0.99156516842283D0,0.02161601352180D0/ +*---- +* Order = 20 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 46, 55)/ + > 0.07652652113350D0,0.01527533871307D0,0.22778585114165D0, + > 0.01657477627473D0,0.37370608871523D0,0.01776201366480D0, + > 0.51086700195199D0,0.01881266263554D0,0.63605368072293D0, + > 0.01969908866072D0,0.74633190646642D0,0.02038602396117D0, + > 0.83911697181714D0,0.02081918540086D0,0.91223442824898D0, + > 0.02089068276635D0,0.96397192728679D0,0.02030071490687D0, + > 0.99312859917998D0,0.01761400714924D0/ +*---- +* Order = 22 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 56, 66)/ + > 0.06973927331972D0,0.01265926116869D0,0.20786042668821D0, + > 0.01365414983460D0,0.34193582089230D0,0.01457483386523D0, + > 0.46935583798525D0,0.01540654710137D0,0.58764040351215D0, + > 0.01613318515391D0,0.69448726317471D0,0.01673569074235D0, + > 0.78781680600113D0,0.01718832124013D0,0.86581257768321D0, + > 0.01744911712470D0,0.92695677224150D0,0.01743111170530D0, + > 0.97006049778158D0,0.01688745083050D0,0.99429458550512D0, + > 0.01462799524418D0/ +*---- +* Order = 24 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 67, 78)/ + > 0.06405689286261D0,0.01066151627890D0,0.19111886747361D0, + > 0.01143976875880D0,0.31504267969640D0,0.01216704729278D0, + > 0.43379350762497D0,0.01283396311708D0,0.54542147138999D0, + > 0.01343053376483D0,0.64809365193896D0,0.01394552172544D0, + > 0.74012419158451D0,0.01436502694016D0,0.82000198588723D0, + > 0.01466929621748D0,0.88641552731297D0,0.01482464636908D0, + > 0.93827455142585D0,0.01475914616380D0,0.97472855656607D0, + > 0.01426569422080D0,0.99518721974900D0,0.01234123034267D0/ +*---- +* Order = 26 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 79, 91)/ + > 0.05923009342931D0,0.00910164732917D0,0.17685882035693D0, + > 0.00972170362377D0,0.29200483948558D0,0.01030561968603D0, + > 0.40305175512448D0,0.01084718405284D0,0.50844071482581D0, + > 0.01133990678847D0,0.60669229300123D0,0.01177672504332D0, + > 0.69642726048349D0,0.01214941348255D0,0.77638594865137D0, + > 0.01244735829575D0,0.84544594311257D0,0.01265480931773D0, + > 0.90263786157297D0,0.01274395622539D0,0.94715906696364D0, + > 0.01265412770351D0,0.97838544586603D0,0.01220892547636D0, + > 0.99588570114160D0,0.01055137268743D0/ +*---- +* Order = 28 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 92,105)/ + > 0.05507928988403D0,0.00786050092975D0,0.16456928213333D0, + > 0.00836239940448D0,0.27206162763654D0,0.00883798049356D0, + > 0.37625151607709D0,0.00928299705271D0,0.47587422501394D0, + > 0.00969306579864D0,0.56972047161791D0,0.01006352716248D0, + > 0.65665109450180D0,0.01038917711347D0,0.73561087718791D0, + > 0.01066374513244D0,0.80564137195850D0,0.01087881964355D0, + > 0.86589252190936D0,0.01102147166953D0,0.91563302581684D0, + > 0.01106822904179D0,0.95425928269356D0,0.01096714930000D0, + > 0.98130316299531D0,0.01056605251579D0,0.99644249859202D0, + > 0.00912428140132D0/ +*---- +* Order = 30 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=106,120)/ + > 0.05147184255532D0,0.00685684352624D0,0.15386991360868D0, + > 0.00726874212489D0,0.25463692616461D0,0.00766103235284D0, + > 0.35270472554884D0,0.00803072809779D0,0.44703376949342D0, + > 0.00837477474924D0,0.53662414821306D0,0.00868997871608D0, + > 0.62052618288637D0,0.00897287728847D0,0.69785049482498D0, + > 0.00921949657093D0,0.76777743319354D0,0.00942489107957D0, + > 0.82956575621336D0,0.00958219000643D0,0.88256055526296D0, + > 0.00968054393272D0,0.92620000651698D0,0.00969978543893D0, + > 0.96002192312100D0,0.00959491170268D0,0.98366807161209D0, + > 0.00923324554691D0,0.99689350414176D0,0.00796814638786D0/ +*---- +* Order = 32 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=121,136)/ + > 0.04830766568774D0,0.00603375553217D0,0.14447196158186D0, + > 0.00637591467195D0,0.23928736227279D0,0.00670317136284D0, + > 0.33186860213190D0,0.00701337528509D0,0.42135127674309D0, + > 0.00730434107922D0,0.50689990719947D0,0.00757381130805D0, + > 0.58771576112490D0,0.00781938956129D0,0.66304425908752D0, + > 0.00803842135657D0,0.73218213532892D0,0.00822777972086D0, + > 0.79448375640681D0,0.00838343484386D0,0.84936770896391D0, + > 0.00849970145691D0,0.89632095843854D0,0.00856713191057D0, + > 0.93490639505449D0,0.00856850293792D0,0.96476187795073D0, + > 0.00846401442985D0,0.98561180730897D0,0.00813711928812D0, + > 0.99726375488382D0,0.00701885042221D0/ +*---- +* Order = 34 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=137,153)/ + > 0.04550982195310D0,0.00535039649002D0,0.13615235725880D0, + > 0.00563769027317D0,0.22566669163722D0,0.00591345985566D0, + > 0.31331108104631D0,0.00617612426888D0,0.39835927975331D0, + > 0.00642408458066D0,0.48010653651464D0,0.00665570376058D0, + > 0.55787552837148D0,0.00686927018743D0,0.63102165671823D0, + > 0.00706293794571D0,0.69893926435390D0,0.00723461457806D0, + > 0.76106458437911D0,0.00738175933892D0,0.81688476588987D0, + > 0.00750110078301D0,0.86593368730159D0,0.00758751425230D0, + > 0.90781120740225D0,0.00763351850909D0,0.94216032905008D0, + > 0.00762273892258D0,0.96871043413727D0,0.00752113249273D0, + > 0.98722623909002D0,0.00722576516252D0,0.99757230194591D0, + > 0.00622779370687D0/ +*---- +* Order = 36 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=154,171)/ + > 0.04301819847371D0,0.00477684864836D0,0.12873610380802D0, + > 0.00502039327879D0,0.21350089236042D0,0.00525488868613D0, + > 0.29668499489157D0,0.00547915111524D0,0.37767254966703D0, + > 0.00569198776656D0,0.45586393486895D0,0.00589218549996D0, + > 0.53068031264856D0,0.00607849018656D0,0.60156759861950D0, + > 0.00624957522881D0,0.66800134713266D0,0.00640398037611D0, + > 0.72948900231201D0,0.00654000932504D0,0.78557638994910D0, + > 0.00665561122424D0,0.83584737503067D0,0.00674782531543D0, + > 0.87992821829261D0,0.00681274160010D0,0.91750240344171D0, + > 0.00684271263501D0,0.94826416091557D0,0.00682558556827D0, + > 0.97203921707055D0,0.00672476115101D0,0.98857686223253D0, + > 0.00646291222847D0,0.99783406138946D0,0.00555667184560D0/ +*---- +* Order = 38 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=172,190)/ + > 0.04078514790459D0,0.00429079101476D0,0.12208402533452D0, + > 0.00449902743170D0,0.20257045398628D0,0.00470006077885D0, + > 0.28170880888511D0,0.00489299029385D0,0.35897244495443D0, + > 0.00507691088444D0,0.43384715631935D0,0.00525090669126D0, + > 0.50583473801940D0,0.00541403881989D0,0.57445603748646D0, + > 0.00556532827760D0,0.63925418826503D0,0.00570372124187D0, + > 0.69979962680485D0,0.00582803437120D0,0.75568295130273D0, + > 0.00593692197056D0,0.80655201425815D0,0.00602847883995D0, + > 0.85201700089545D0,0.00610101854081D0,0.89189086124464D0, + > 0.00614733110727D0,0.92568500732863D0,0.00617630505125D0, + > 0.95353898729968D0,0.00613319286783D0,0.97477439677976D0, + > 0.00607355513150D0,0.98978922946055D0,0.00577832504734D0, + > 0.99803301416225D0,0.00504805879326D0/ +*---- +* Order = 40 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=191,210)/ + > 0.03877241750606D0,0.00387529739892D0,0.11608407067269D0, + > 0.00405472727181D0,0.19269758075384D0,0.00422835343883D0, + > 0.26815218442225D0,0.00439548053431D0,0.34199409501760D0, + > 0.00455541138509D0,0.41377918521708D0,0.00470744324502D0, + > 0.48307585742886D0,0.00485086018626D0,0.54946703621944D0, + > 0.00498492376041D0,0.61255384817576D0,0.00510886273005D0, + > 0.67195746920806D0,0.00522174107642D0,0.72731518674779D0, + > 0.00532302904828D0,0.77831437316505D0,0.00540964292729D0, + > 0.82459057917465D0,0.00548656553689D0,0.86600919232031D0, + > 0.00553340517150D0,0.90199639822285D0,0.00558997462627D0, + > 0.93299517738927D0,0.00556748623087D0,0.95765721118329D0, + > 0.00561397264950D0,0.97754603471325D0,0.00541857778427D0, + > 0.99051106402526D0,0.00539644941610D0,0.99831206210441D0, + > 0.00434333104876D0/ +*---- +* Order = 42 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=211,231)/ + > 0.03694894316534D0,0.00351734448725D0,0.11064502720743D0, + > 0.00367304067267D0,0.18373680686444D0,0.00382400922292D0, + > 0.25582507379698D0,0.00396970636014D0,0.32651616975104D0, + > 0.00410958765725D0,0.39542362251945D0,0.00424310738074D0, + > 0.46217274386666D0,0.00436970393775D0,0.52639343800021D0, + > 0.00448884199956D0,0.58774968956786D0,0.00459981369037D0, + > 0.64587456004057D0,0.00470237199319D0,0.70050533824065D0, + > 0.00479452034217D0,0.75127821879747D0,0.00488025174105D0, + > 0.79791981602651D0,0.00494337495192D0,0.84045950845072D0, + > 0.00502154054607D0,0.87755806345153D0,0.00503689455872D0, + > 0.91197509273697D0,0.00517770715670D0,0.93729218041353D0, + > 0.00526592418727D0,0.96414624148124D0,0.00570793259377D0, + > 0.97695704453476D0,0.00690539560442D0,0.99322113425436D0, + > 0.00541384107796D0,0.99769796354612D0,0.00754180253610D0/ +*---- +* Order = 44 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=232,253)/ + > 0.03528923696410D0,0.00320677989952D0,0.10569190169021D0, + > 0.00334274692733D0,0.17556801710226D0,0.00347482459015D0, + > 0.24456941646933D0,0.00360258272163D0,0.31235278934078D0, + > 0.00372559021852D0,0.37857772181427D0,0.00384342407853D0, + > 0.44292618820931D0,0.00395560422690D0,0.50503688871692D0, + > 0.00406188071758D0,0.56471466385375D0,0.00416116332728D0, + > 0.62139067754562D0,0.00425481282618D0,0.67534196136471D0, + > 0.00433842941591D0,0.72528399895512D0,0.00441848009213D0, + > 0.77261708065981D0,0.00448920279793D0,0.81468343050057D0, + > 0.00453553695561D0,0.85451710591231D0,0.00462393394081D0, + > 0.88796251449581D0,0.00457908321421D0,0.91913386326312D0, + > 0.00479985160516D0,0.94407409289036D0,0.00460697658507D0, + > 0.96484471190689D0,0.00431337311996D0,0.98174671963958D0, + > 0.00476874072667D0,0.99175403861920D0,0.00484009055849D0, + > 0.99874459587735D0,0.00339611207931D0/ +*---- +* Start processing +*---- + PI=XDRCST('Pi',' ') + PID2=PI/DTWO + NBPT=(NLF*(NLF+2))/8 + ILEVEL=1 + JLEVEL=0 + NLEVEL=NLF/2 + KLEVEL=(NLEVEL*(NLEVEL-1))/2 + IPOINT=0 + DO IPT=1,NBPT + IPOINT=IPOINT+1 + JLEVEL = JLEVEL + 1 + ALPHA =PI*(DBLE(NLEVEL-ILEVEL+1-JLEVEL)+DONE/DTWO) + > /(DTWO*DBLE(NLEVEL-ILEVEL+1)) + XI=SYST(1,KLEVEL+ILEVEL) + ROTXI=SQRT(DONE-XI**2) + COSA=COS(ALPHA) + SINA=SIN(ALPHA) + TPQ(IPOINT)=REAL(COSA*ROTXI) + UPQ(IPOINT)=REAL(SINA*ROTXI) + VPQ(IPOINT)=REAL(XI) + WPQ(IPOINT)=REAL(PID2*SYST(2,KLEVEL+ILEVEL)) + IF(JLEVEL .EQ. NLEVEL-ILEVEL+1) THEN + ILEVEL = ILEVEL + 1 + JLEVEL = 0 + ENDIF + ENDDO + RETURN + END + diff --git a/Dragon/src/SNQU06.f b/Dragon/src/SNQU06.f new file mode 100644 index 0000000..b5da229 --- /dev/null +++ b/Dragon/src/SNQU06.f @@ -0,0 +1,949 @@ +*DECK SNQU06 + SUBROUTINE SNQU06(NLF,TPQ,UPQ,VPQ,WPQ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To define QR (quadruple range) quadrature angles. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal. +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* N. Martin +* +*Parameters: input +* NLF order of the SN approximation (even number). +* +*Parameters: output +* TPQ base points in $\\xi$ of the 2D/3D SN quadrature. +* UPQ base points in $\\mu$ of the 2D/3D SN quadrature. +* VPQ base points in $\\eta$ of the 2D/3D SN quadrature. +* WPQ weights of the 2D/3D SN quadrature. +* +*Reference: +* Eric M. Baker. +* Quadruple range quadrature verification and extention, +* Los Alamos documentation LA-UR-07-8050 (2006). +* +*----------------------------------------------------------------------- +* +*---- +* Subroutine arguments +*---- + INTEGER NLF + REAL TPQ(NLF*(NLF/2+1)/4),UPQ(NLF*(NLF/2+1)/4), + 1 VPQ(NLF*(NLF/2+1)/4),WPQ(NLF*(NLF/2+1)/4) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='SNQU06',MAXNLF=74) + DOUBLE PRECISION DZERO,DONE,DTWO,PID2 + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Functions +*---- + DOUBLE PRECISION XDRCST,PI +*---- +* Local variables +*---- + INTEGER NBPT,ILEVEL,JLEVEL,NLEVEL,KLEVEL,IPOINT,IPT + DOUBLE PRECISION ALPHA,XI,ROTXI,COSA,SINA +*---- +* Data +*---- + INTEGER IS,IA + DOUBLE PRECISION SYST(2,703) + SAVE SYST +*---- +* Set quadrature points and weights +*---- + IF(NLF.GT.MAXNLF) CALL XABORT('SNQU06: MAXNLF OVERFLOW.') +*---- +* Order = 2 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 1, 1)/ + > 0.7071067811865475D0,1.570796326794897D0/ +*---- +* Order = 4 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 2, 3)/ + > 3.288613193063390D-1,7.853981633974483D-1,9.443782254288237D-1, + > 0.7853981633974483D0/ +*---- +* Order = 6 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 4, 6)/ + > 1.797057505503707D-1, 4.414924088048230D-1,7.071067811865475D-1, + > 6.878115091852507D-1, 9.837204090691257D-1, 4.414924088048230D-1/ +*---- +* Order = 8 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 7, 10)/ + > 1.119194178021025D-1, 2.790495092691071D-1, + > 4.990088153604911D-1, 5.063486541283412D-1, + > 8.665969087139183D-1, 5.063486541283412D-1, + > 9.937172857099943D-1, 2.790495092691071D-1/ +*---- +* Order = 10 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 11, 15)/ + > 7.608393410010900D-2, 1.913207247027131D-1, + > 3.599152552241242D-1, 3.748555766138863D-1, + > 7.071067811865475D-1, 4.384437241616979D-1, + > 9.329849993740272D-1, 3.748555766138863D-1, + > 9.971014165930416D-1, 1.913207247027131D-1/ +*---- +* Order = 12 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 16, 21)/ + > 5.498238339818787D-2, 1.389912271015858D-1, + > 2.686450605979331D-1, 2.849847975948065D-1, + > 5.658713393447228D-1, 3.614221387010560D-1, + > 8.244935580756284D-1, 3.614221387010560D-1, + > 9.632392389309796D-1, 2.849847975948065D-1, + > 9.984873246645922D-1, 1.389912271015858D-1/ +*---- +* Order = 14 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 22, 28)/ + > 4.155046739519842D-2, 1.054032627117009D-1, + > 2.070312681580549D-1, 2.225734192425536D-1, + > 4.548121603136229D-1, 2.966594661924317D-1, + > 7.071067811865475D-1, 3.215240305015243D-1, + > 8.905873897775868D-1, 2.966594661924317D-1, + > 9.783343262938634D-1, 2.225734192425536D-1, + > 9.991364064326955D-1, 1.054032627117009D-1/ +*---- +* Order = 16 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 29, 36)/ + > 3.248697884632087D-2, 8.261058789185801D-2, + > 1.639512569400686D-1, 1.780108196819361D-1, + > 3.700379385471330D-1, 2.453650131486301D-1, + > 6.006186663088213D-1, 2.794117426750241D-1, + > 7.995356262740346D-1, 2.794117426750241D-1, + > 9.290166435730784D-1, 2.453650131486301D-1, + > 9.864684411311756D-1, 1.780108196819361D-1, + > 9.994721587945503D-1, 8.261058789185801D-2/ +*---- +* Order = 18 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 37, 45)/ + > 2.608861776207381D-2, 6.645559945847256D-2, + > 1.328246569072209D-1, 1.452965934855972D-1, + > 3.053252347988094D-1, 2.051444864132550D-1, + > 5.104236819705835D-1, 2.416159520924252D-1, + > 7.071067811865475D-1, 2.537710638953967D-1, + > 8.599230575368895D-1, 2.416159520924252D-1, + > 9.522481299509345D-1, 2.051444864132550D-1, + > 9.911395514847942D-1, 1.452965934855972D-1, + > 9.996596340871549D-1, 6.645559945847256D-2/ +*---- +* Order = 20 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 46, 55)/ + > 2.140636649836879D-2, 5.459883427719590D-2, + > 1.096782080789725D-1, 1.206689353273136D-1, + > 2.554062770706209D-1, 1.734506495359569D-1, + > 4.359965790249476D-1, 2.093517367248734D-1, + > 6.217587837057514D-1, 2.273280075321085D-1, + > 7.832087939271013D-1, 2.273280075321085D-1, + > 8.999483224488741D-1, 2.093517367248734D-1, + > 9.668338190366146D-1, 1.734506495359569D-1, + > 9.939671476827519D-1, 1.206689353273136D-1, + > 9.997708574835223D-1, 5.459883427719590D-2/ +*---- +* Order = 22 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 56, 66)/ + > 1.787818127983761D-2, 4.564471367918457D-2, + > 9.203377352741595D-2, 1.017137272660963D-1, + > 2.163635206471488D-1, 1.482265633964675D-1, + > 3.750373673684837D-1, 1.822612531818470D-1, + > 5.464247324681954D-1, 2.027611569667827D-1, + > 7.071067811865475D-1, 2.095814978141405D-1, + > 8.375082159280953D-1, 2.027611569667827D-1, + > 9.270096941657714D-1, 1.822612531818470D-1, + > 9.763128734853243D-1, 1.482265633964675D-1, + > 9.957558860133865D-1, 1.017137272660963D-1, + > 9.998401725446549D-1, 4.564471367918457D-2/ +*---- +* Order = 24 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 67, 78)/ + > 1.515427633810212D-2, 3.871995573990722D-2, + > 7.829331784823644D-2, 8.683898824818842D-2, + > 1.853856824160965D-1, 1.279220161079748D-1, + > 3.250513900479526D-1, 1.595962888003237D-1, + > 4.813341017203090D-1, 1.808538704864877D-1, + > 6.359378348511013D-1, 1.914670440145664D-1, + > 7.717402867577236D-1, 1.914670440145664D-1, + > 8.765372111445716D-1, 1.808538704864877D-1, + > 9.456963539254520D-1, 1.595962888003237D-1, + > 9.826658377877590D-1, 1.279220161079748D-1, + > 9.969303668663700D-1, 8.683898824818842D-2, + > 9.998851673610667D-1, 3.871995573990722D-2/ +*---- +* Order = 26 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 79, 91)/ + > 1.300784260340052D-2, 3.325591619718422D-2, + > 6.739381484979049D-2, 7.496658920041428D-2, + > 1.604653826023372D-1, 1.113898480184530D-1, + > 2.838506265695340D-1, 1.405952903244943D-1, + > 4.256053496742027D-1, 1.616563247494470D-1, + > 5.714795978613439D-1, 1.742889475411106D-1, + > 7.071067811865475D-1, 1.784904947326901D-1, + > 8.206162740454497D-1, 1.742889475411106D-1, + > 9.049088828874981D-1, 1.616563247494470D-1, + > 9.588685112131292D-1, 1.405952903244943D-1, + > 9.870414687267630D-1, 1.113898480184530D-1, + > 9.977264523505389D-1, 7.496658920041428D-2, + > 9.999153944363519D-1, 3.325591619718422D-2/ +*---- +* Order = 28 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA= 92,105)/ + > 1.128664599103795D-2, 2.886965398857025D-2, + > 5.860802825933166D-2, 6.534816595720066D-2, + > 1.401592977980301D-1, 9.778151915986106D-2, + > 2.496535423349043D-1, 1.245928602207950D-1, + > 3.780145294131805D-1, 1.449498625863828D-1, + > 5.141044083621162D-1, 1.585386998315389D-1, + > 6.460952816893911D-1, 1.653174016530996D-1, + > 7.632567634673841D-1, 1.653174016530996D-1, + > 8.577276125336286D-1, 1.585386998315389D-1, + > 9.257996627524400D-1, 1.449498625863828D-1, + > 9.683352254253865D-1, 1.245928602207950D-1, + > 9.901289669738802D-1, 9.778151915986106D-2, + > 9.982810721553091D-1, 6.534816595720066D-2, + > 9.999363037825324D-1, 2.886965398857025D-2/ +*---- +* Order = 30 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=106,120)/ + > 9.885454799950707D-3, 2.529575708608393D-2, + > 5.142584271456661D-2, 5.745247946520937D-2, + > 1.234174526540014D-1, 8.646511772502708D-2, + > 2.210520064292830D-1, 1.110388326617575D-1, + > 3.373313406305213D-1, 1.304366407688838D-1, + > 4.634907863833664D-1, 1.443355921311845D-1, + > 5.898656904335448D-1, 1.526595716146173D-1, + > 7.071067811865475D-1, 1.554283438893696D-1, + > 8.075013729086518D-1, 1.526595716146173D-1, + > 8.861017384802541D-1, 1.443355921311845D-1, + > 9.413859817462841D-1, 1.304366407688838D-1, + > 9.752620214350542D-1, 1.110388326617575D-1, + > 9.923548419695433D-1, 8.646511772502708D-2, + > 9.986768159425233D-1, 5.745247946520937D-2, + > 9.999511376979368D-1, 2.529575708608393D-2/ +*---- +* Order = 32 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=121,136)/ + > 8.729657082861998D-3, 2.234563433970334D-2, + > 4.548138640446708D-2, 5.089471201185089D-2, + > 1.094657179495637D-1, 7.696546183192337D-2, + > 1.969448911359501D-1, 9.948832189094168D-2, + > 3.024482742232713D-1, 1.178163725528086D-1, + > 4.190211144820449D-1, 1.316318495967909D-1, + > 5.387770134090762D-1, 1.408332013024988D-1, + > 6.537245138927594D-1, 1.454226098709307D-1, + > 7.567326211652801D-1, 1.454226098709307D-1, + > 8.424484137453142D-1, 1.408332013024988D-1, + > 9.079764895735049D-1, 1.316318495967909D-1, + > 9.531657995434818D-1, 1.178163725528086D-1, + > 9.804145602016775D-1, 9.948832189094168D-2, + > 9.939905716825420D-1, 7.696546183192337D-2, + > 9.989651863256935D-1, 5.089471201185089D-2, + > 9.999618958176435D-1, 2.234563433970334D-2/ +*---- +* Order = 34 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=137,153)/ + > 7.765167550594897D-3, 1.988233444736077D-2, + > 4.050698458787639D-2, 4.539097865607717D-2, + > 9.772547366646427D-2, 6.892134946532859D-2, + > 1.764725073896891D-1, 8.958447192452450D-2, + > 2.724164548901113D-1, 1.068152712507604D-1, + > 3.799892988394926D-1, 1.203101631042851D-1, + > 4.927420326833888D-1, 1.299509173542970D-1, + > 6.039089138656826D-1, 1.357218046104536D-1, + > 7.071067811865475D-1, 1.376417451687221D-1, + > 7.970533380857090D-1, 1.357218046104536D-1, + > 8.701754358903969D-1, 1.299509173542970D-1, + > 9.249908825320770D-1, 1.203101631042851D-1, + > 9.621794401800030D-1, 1.068152712507604D-1, + > 9.843055694933338D-1, 8.958447192452450D-2, + > 9.952134101772671D-1, 6.892134946532859D-2, + > 9.991792552888583D-1, 4.539097865607717D-2, + > 9.999698506319634D-1, 1.988233444736077D-2/ +*---- +* Order = 36 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=154,171)/ + > 6.952010366745025D-3, 1.780448256851573D-2, + > 3.630329822321955D-2, 4.072837739441321D-2, + > 8.775842996404620D-2, 6.205518747222860D-2, + > 1.589616059026264D-1, 8.104138647658412D-2, + > 2.464422434563339D-1, 9.719456818914889D-2, + > 3.457022371739597D-1, 1.102303994594047D-1, + > 4.514464196113868D-1, 1.200213906455903D-1, + > 5.579698061333865D-1, 1.265362696526889D-1, + > 6.596626820591664D-1, 1.297861015388739D-1, + > 7.515618044435914D-1, 1.297861015388739D-1, + > 8.298612507181373D-1, 1.265362696526889D-1, + > 8.922982294166338D-1, 1.200213906455903D-1, + > 9.383442668940432D-1, 1.102303994594047D-1, + > 9.691574797937686D-1, 9.719456818914889D-2, + > 9.872847653280476D-1, 8.104138647658412D-2, + > 9.961417860777880D-1, 6.205518747222860D-2, + > 9.993408180086091D-1, 4.072837739441321D-2, + > 9.999758344839443D-1, 1.780448256851573D-2/ +*---- +* Order = 38 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=172,190)/ + > 6.260124726824094D-3, 1.603575186530219D-2, + > 3.271949450064389D-2, 3.674484447429247D-2, + > 7.922836042016190D-2, 5.615133571572357D-2, + > 1.438820502560538D-1, 7.362948392130560D-2, + > 2.238694254490736D-1, 8.875049346501127D-2, + > 3.155245603429847D-1, 1.012516526819094D-1, + > 4.144771888783680D-1, 1.110019513021974D-1, + > 5.159200804329141D-1, 1.179578982613787D-1, + > 6.149740744496668D-1, 1.221213481438653D-1, + > 7.071067811865475D-1, 1.235068071329247D-1, + > 7.885473275300447D-1, 1.221213481438653D-1, + > 8.566367203232041D-1, 1.179578982613787D-1, + > 9.100597012831003D-1, 1.110019513021974D-1, + > 9.489174104316804D-1, 1.012516526819094D-1, + > 9.746191463074700D-1, 8.875049346501127D-2, + > 9.895948441731669D-1, 7.362948392130560D-2, + > 9.968564926332842D-1, 5.615133571572357D-2, + > 9.994645739993101D-1, 3.674484447429247D-2, + > 9.999804052272247D-1, 1.603575186530219D-2/ +*---- +* Order = 40 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=191,210)/ + > 5.666555435801935D-3, 1.451779509317350D-2, + > 2.963979274695100D-2, 3.331533618587398D-2, + > 7.187424763201411D-2, 5.104054858395153D-2, + > 1.308135974586322D-1, 6.716362589103700D-2, + > 2.041579376098809D-1, 8.131097620559026D-2, + > 2.888941786344192D-1, 9.324211470049753D-2, + > 3.813947484262091D-1, 1.028266819400935D-1, + > 4.776033421571356D-1, 1.100123318316945D-1, + > 5.732994237606388D-1, 1.147920152181985D-1, + > 6.644147983089062D-1, 1.171767377473380D-1, + > 7.473640182589308D-1, 1.171767377473380D-1, + > 8.193459408062747D-1, 1.147920152181985D-1, + > 8.785755787411428D-1, 1.100123318316945D-1, + > 9.244122705118689D-1, 1.028266819400935D-1, + > 9.573610361567596D-1, 9.324211470049753D-2, + > 9.789379635660678D-1, 8.131097620559026D-2, + > 9.914069813754243D-1, 6.716362589103700D-2, + > 9.974137017944620D-1, 5.104054858395153D-2, + > 9.995606448264746D-1, 3.331533618587398D-2, + > 9.999839449458641D-1, 1.451779509317350D-2/ +*---- +* Order = 42 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=211,231)/ + > 5.153529715794118D-3, 1.320539632418366D-2, + > 2.697415577591218D-2, 3.034217800698840D-2, + > 6.549119792630967D-2, 4.658869227256107D-2, + > 1.194207057461457D-1, 6.149373560761037D-2, + > 1.868636355236370D-1, 7.473138541437220D-2, + > 2.653234848709176D-1, 8.608289338331400D-2, + > 3.517712327776513D-1, 9.542142388267645D-2, + > 4.427751437470710D-1, 1.026887640907876D-1, + > 5.346931294496370D-1, 1.078700892228989D-1, + > 6.239117782235315D-1, 1.109716362868715D-1, + > 7.071067811865475D-1, 1.120039378103684D-1, + > 7.814947811687234D-1, 1.109716362868715D-1, + > 8.450463048374058D-1, 1.078700892228989D-1, + > 8.966326851502574D-1, 1.026887640907876D-1, + > 9.360860002104996D-1, 9.542142388267645D-2, + > 9.641594517381199D-1, 8.608289338331400D-2, + > 9.823858619294607D-1, 7.473138541437220D-2, + > 9.928437415016990D-1, 6.149373560761037D-2, + > 9.978531470082043D-1, 4.658869227256107D-2, + > 9.996361312598584D-1, 3.034217800698840D-2, + > 9.999867204775614D-1, 1.320539632418366D-2/ +*---- +* Order = 44 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=232,253)/ + > 4.707114717103505D-3, 1.206308084642689D-2, + > 2.465173376735076D-2, 2.774821193462954D-2, + > 5.991670409568439D-2, 4.268848001641819D-2, + > 1.094334822143285D-1, 5.649746567994538D-2, + > 1.716206775350476D-1, 6.889030401909524D-2, + > 2.443940481368066D-1, 7.966885558279603D-2, + > 3.252092377487526D-1, 8.871167329713092D-2, + > 4.111529714803756D-1, 9.595714699102763D-2, + > 4.990835442262655D-1, 1.013841131358227D-1, + > 5.858114200649882D-1, 1.049937517313658D-1, + > 6.683033272342810D-1, 1.067950801627900D-1, + > 7.438888779969691D-1, 1.067950801627900D-1, + > 8.104473950364958D-1, 1.049937517313658D-1, + > 8.665538736181088D-1, 1.013841131358227D-1, + > 9.115663629395599D-1, 9.595714699102763D-2, + > 9.456420843442170D-1, 8.871167329713092D-2, + > 9.696760021962513D-1, 7.966885558279603D-2, + > 9.851631047914915D-1, 6.889030401909524D-2, + > 9.939941211951136D-1, 5.649746567994538D-2, + > 9.982033803640970D-1, 4.268848001641819D-2, + > 9.996960998334762D-1, 2.774821193462954D-2, + > 9.999889214741531D-1, 1.206308084642689D-2/ +*---- +* Order = 46 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=254,276)/ + > 4.316263740076508D-3, 1.106270311640170D-2, + > 2.261617115926903D-2, 2.547185620354161D-2, + > 5.502063421109040D-2, 3.925335576844175D-2, + > 1.006332490304859D-1, 5.207448910676365D-2, + > 1.581268223158908D-1, 6.368572226347834D-2, + > 2.257488308236949D-1, 7.390806352099788D-2, + > 3.013494595288169D-1, 8.262656871717886D-2, + > 3.824459703834832D-1, 8.977817435489181D-2, + > 4.663257595606548D-1, 9.533683737852415D-2, + > 5.501830693329847D-1, 9.929896064532817D-2, + > 6.312785125450332D-1, 1.016710684725573D-1, + > 7.071067811865475D-1, 1.024607276986862D-1, + > 7.755562130490158D-1, 1.016710684725573D-1, + > 8.350440648369020D-1, 9.929896064532817D-2, + > 8.846130713312902D-1, 9.533683737852415D-2, + > 9.239778567354501D-1, 8.977817435489181D-2, + > 9.535137666765435D-1, 8.262656871717886D-2, + > 9.741855395055578D-1, 7.390806352099788D-2, + > 9.874188108722047D-1, 6.368572226347834D-2, + > 9.949235896236294D-1, 5.207448910676365D-2, + > 9.984852176226794D-1, 3.925335576844175D-2, + > 9.997442216897753D-1, 2.547185620354161D-2, + > 9.999906848902774D-1, 1.106270311640170D-2/ +*---- +* Order = 48 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=277,300)/ + > 3.972127715469235D-3, 1.018170331312922D-2, + > 2.082219684210920D-2, 2.346349353303599D-2, + > 5.069784852121022D-2, 3.621292193062666D-2, + > 9.284156235089204D-2, 4.814205277021821D-2, + > 1.461314233398479D-1, 5.903176230890425D-2, + > 2.090839313632731D-1, 6.872060753743357D-2, + > 2.798722573569018D-1, 7.710072080607362D-2, + > 3.563718475936031D-1, 8.410905852056142D-2, + > 4.362363542057792D-1, 8.971603507554962D-2, + > 5.170013989086162D-1, 9.391384633073917D-2, + > 5.962091754811982D-1, 9.670612366917621D-2, + > 6.715437180389010D-1, 9.809983760200038D-2, + > 7.409649349075090D-1, 9.809983760200038D-2, + > 8.028291344190430D-1, 9.670612366917621D-2, + > 8.559845521541460D-1, 9.391384633073917D-2, + > 8.998321194918805D-1, 8.971603507554962D-2, + > 9.343442118634447D-1, 8.410905852056142D-2, + > 9.600372490491982D-1, 7.710072080607362D-2, + > 9.778976989673706D-1, 6.872060753743357D-2, + > 9.892651854344568D-1, 5.903176230890425D-2, + > 9.956808948153246D-1, 4.814205277021821D-2, + > 9.987140372275341D-1, 3.621292193062666D-2, + > 9.997831945570342D-1, 2.346349353303599D-2, + > 9.999921110695884D-1, 1.018170331312922D-2/ +*---- +* Order = 50 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=301,325)/ + > 3.667550894412352D-3, 9.401828916276707D-3, + > 1.923311271050877D-2, 2.168279634366668D-2, + > 4.686269256303738D-2, 3.350948773339766D-2, + > 8.591181096521539D-2, 4.463150509293552D-2, + > 1.354257349069718D-1, 5.485592665859271D-2, + > 1.941407846601355D-1, 6.403724294009948D-2, + > 2.604960566070634D-1, 7.207485785563070D-2, + > 3.326658203805228D-1, 7.890682566302415D-2, + > 4.086156970191086D-1, 8.450117205318058D-2, + > 4.861816572020138D-1, 8.884657138646223D-2, + > 5.631674054600955D-1, 9.194373283617630D-2, + > 6.374531035792810D-1, 9.379831926574879D-2, + > 7.071067811865475D-1, 9.441579330451362D-2, + > 7.704891567940086D-1, 9.379831926574879D-2, + > 8.263428304446916D-1, 9.194373283617630D-2, + > 8.738577665732013D-1, 8.884657138646223D-2, + > 9.127065312298296D-1, 8.450117205318058D-2, + > 9.430447772775977D-1, 7.890682566302415D-2, + > 9.654749113737599D-1, 7.207485785563070D-2, + > 9.809736773897386D-1, 6.403724294009948D-2, + > 9.907875000851124D-1, 5.485592665859271D-2, + > 9.963027455230047D-1, 4.463150509293552D-2, + > 9.989013404965188D-1, 3.350948773339766D-2, + > 9.998150265801494D-1, 2.168279634366668D-2, + > 9.999932745126024D-1, 9.401828916276707D-3/ +*---- +* Order = 52 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=326,351)/ + > 3.396696521564986D-3, 8.708184858650910D-3, + > 1.781892050929334D-2, 2.009672209559701D-2, + > 4.344484549656114D-2, 3.109543899569998D-2, + > 7.972274758288012D-2, 4.148557359431433D-2, + > 1.258351250930473D-1, 5.109681624694140D-2, + > 1.806991980219270D-1, 5.979803209497304D-2, + > 2.429742598458005D-1, 6.749583467970308D-2, + > 3.110847255339362D-1, 7.413013546424966D-2, + > 3.832618562348258D-1, 7.966752788841578D-2, + > 4.576040998675997D-1, 8.409386224353523D-2, + > 5.321533124724104D-1, 8.740711539780842D-2, + > 6.049820056372407D-1, 8.961127788931235D-2, + > 6.742853437025943D-1, 9.071164194824712D-2, + > 7.384709034673433D-1, 9.071164194824712D-2, + > 7.962391430061333D-1, 8.961127788931235D-2, + > 8.466480095202735D-1, 8.740711539780842D-2, + > 8.891560536735741D-1, 8.409386224353523D-2, + > 9.236397293076104D-1, 7.966752788841578D-2, + > 9.503821828819580D-1, 7.413013546424966D-2, + > 9.700327360725438D-1, 6.749583467970308D-2, + > 9.835384079100482D-1, 5.979803209497304D-2, + > 9.920511686867856D-1, 5.109681624694140D-2, + > 9.968170762571418D-1, 4.148557359431433D-2, + > 9.990558269685333D-1, 3.109543899569998D-2, + > 9.998412304320539D-1, 2.009672209559701D-2, + > 9.999942312097307D-1, 8.708184858650910D-3/ +*---- +* Order = 54 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=352,378)/ + > 3.154765578452475D-3, 8.088519222518445D-3, + > 1.655490845630564D-2, 1.867799415496943D-2, + > 4.038615839476834D-2, 2.893121574263062D-2, + > 7.417347458492733D-2, 3.865622019474338D-2, + > 1.172128302266212D-1, 4.770225064114276D-2, + > 1.685713218507331D-1, 5.595108446790947D-2, + > 2.270915986436383D-1, 6.331631488632194D-2, + > 2.914082582079124D-1, 6.974022040259096D-2, + > 3.599789431577641D-1, 7.518873114594296D-2, + > 4.311305838436490D-1, 7.964552607244304D-2, + > 5.031191739976250D-1, 8.310615532185532D-2, + > 5.741997608797084D-1, 8.557281096997747D-2, + > 6.427021081394999D-1, 8.705010633284512D-2, + > 7.071067811865475D-1, 8.754202768311478D-2, + > 7.661161793050990D-1, 8.705010633284512D-2, + > 8.187152341355850D-1, 8.557281096997747D-2, + > 8.642170426206298D-1, 8.310615532185532D-2, + > 9.022895431482260D-1, 7.964552607244304D-2, + > 9.329604281442055D-1, 7.518873114594296D-2, + > 9.565987806014759D-1, 6.974022040259096D-2, + > 9.738734033874612D-1, 6.331631488632194D-2, + > 9.856894589319176D-1, 5.595108446790947D-2, + > 9.931068182377288D-1, 4.770225064114276D-2, + > 9.972453537961454D-1, 3.865622019474338D-2, + > 9.991841462964235D-1, 2.893121574263062D-2, + > 9.998629581127622D-1, 1.867799415496943D-2, + > 9.999950237146908D-1, 8.088519222518445D-3/ +*---- +* Order = 56 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=379,406)/ + > 2.937783068161103D-3, 7.532680050608221D-3, + > 1.542057328035316D-2, 1.740393870836662D-2, + > 3.763822344160284D-2, 2.698374387900945D-2, + > 6.917953054276372D-2, 3.610294286409177D-2, + > 1.094349422308658D-1, 4.462772409676748D-2, + > 1.575965218033132D-1, 5.245143079823476D-2, + > 2.126604305088603D-1, 5.949430183433835D-2, + > 2.734385687346029D-1, 6.570130151997985D-2, + > 3.385818199466888D-1, 7.103829899589742D-2, + > 4.066156050266695D-1, 7.548738262548303D-2, + > 4.759868689664975D-1, 7.904202969199018D-2, + > 5.451202571507631D-1, 8.170266224145589D-2, + > 6.124802047142074D-1, 8.347291855738130D-2, + > 6.766350014909858D-1, 8.435680753384398D-2, + > 7.363185959605350D-1, 8.435680753384398D-2, + > 7.904859257654386D-1, 8.347291855738130D-2, + > 8.383578622783268D-1, 8.170266224145589D-2, + > 8.794523867563669D-1, 7.904202969199018D-2, + > 9.135993376468678D-1, 7.548738262548303D-2, + > 9.409369538930799D-1, 7.103829899589742D-2, + > 9.618894682490145D-1, 6.570130151997985D-2, + > 9.771261644720124D-1, 5.949430183433835D-2, + > 9.875035880013286D-1, 5.245143079823476D-2, + > 9.939939604539492D-1, 4.462772409676748D-2, + > 9.976042264113975D-1, 3.610294286409177D-2, + > 9.992914310330896D-1, 2.698374387900945D-2, + > 9.998810958907590D-1, 1.740393870836662D-2, + > 9.999956847060113D-1, 7.532680050608221D-3/ +*---- +* Order = 58 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=407,435)/ + > 2.742433926349367D-3, 7.032198002138893D-3, + > 1.439878984638582D-2, 1.625558572095192D-2, + > 3.516048827839076D-2, 2.522520908746962D-2, + > 6.466981500411214D-2, 3.379142344706885D-2, + > 1.023963769013716D-1, 4.183513829563056D-2, + > 1.476370627578143D-1, 4.926003874337995D-2, + > 1.995172380704506D-1, 5.599261639569382D-2, + > 2.569989752795515D-1, 6.198069665978488D-2, + > 3.188984690691561D-1, 6.719054793752873D-2, + > 3.839134581171505D-1, 7.160316710825960D-2, + > 4.506602512451940D-1, 7.521031896392870D-2, + > 5.177188670869931D-1, 7.801077736827083D-2, + > 5.836839333174925D-1, 8.000706366604473D-2, + > 6.472183977592858D-1, 8.120284618700015D-2, + > 7.071067811865475D-1, 8.160107162859419D-2, + > 7.623046278240104D-1, 8.120284618700015D-2, + > 8.119809517390300D-1, 8.000706366604473D-2, + > 8.555508019177823D-1, 7.801077736827083D-2, + > 8.926955460556631D-1, 7.521031896392870D-2, + > 9.233690793374722D-1, 7.160316710825960D-2, + > 9.477888828348582D-1, 6.719054793752873D-2, + > 9.664116755840962D-1, 6.198069665978488D-2, + > 9.798943166039586D-1, 5.599261639569382D-2, + > 9.890416056467216D-1, 4.926003874337995D-2, + > 9.947436765305283D-1, 4.183513829563056D-2, + > 9.979067165959621D-1, 3.379142344706885D-2, + > 9.993816788715036D-1, 2.522520908746962D-2, + > 9.998963320519581D-1, 1.625558572095192D-2, + > 9.999962395210092D-1, 7.032198002138893D-3/ +*---- +* Order = 60 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=436,465)/ + > 2.565935816040464D-3, 6.579962619041378D-3, + > 1.347516554782726D-2, 1.521696776845086D-2, + > 3.291878087349994D-2, 2.363209088631991D-2, + > 6.058415580193666D-2, 3.169244521291083D-2, + > 9.600762130781930D-2, 3.929176131897425D-2, + > 1.385744973107413D-1, 4.634296332807871D-2, + > 1.875194470293309D-1, 5.277837509680457D-2, + > 2.419322530851564D-1, 5.854875269926412D-2, + > 3.007708877829240D-1, 6.362110627094798D-2, + > 3.628827241348177D-1, 6.797575914341677D-2, + > 4.270337881301431D-1, 7.160310605662001D-2, + > 4.919450854898168D-1, 7.450044532753710D-2, + > 5.563343213452209D-1, 7.666914603657626D-2, + > 6.189608105599492D-1, 7.811230591489950D-2, + > 6.786710589083211D-1, 7.883297571760606D-2, + > 7.344423692845193D-1, 7.883297571760606D-2, + > 7.854218707108751D-1, 7.811230591489950D-2, + > 8.309585566641411D-1, 7.666914603657626D-2, + > 8.706262302862330D-1, 7.450044532753710D-2, + > 9.042356682830091D-1, 7.160310605662001D-2, + > 9.318348182615274D-1, 6.797575914341677D-2, + > 9.536964260509063D-1, 6.362110627094798D-2, + > 9.702931438061076D-1, 5.854875269926412D-2, + > 9.822608904897995D-1, 5.277837509680457D-2, + > 9.903520125162948D-1, 4.634296332807871D-2, + > 9.953805988921094D-1, 3.929176131897425D-2, + > 9.981630929190713D-1, 3.169244521291083D-2, + > 9.994580300671972D-1, 2.363209088631991D-2, + > 9.999092058349391D-1, 1.521696776845086D-2, + > 9.999967079812753D-1, 6.579962619041378D-3/ +*---- +* Order = 62 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=466,496)/ + > 2.405939628907848D-3, 6.169968963546275D-3, + > 1.263753399803356D-2, 1.427456861312436D-2, + > 3.088414635685555D-2, 2.218439608809088D-2, + > 5.687137210380912D-2, 2.978102161065714D-2, + > 9.019210028251855D-2, 3.696937092634360D-2, + > 1.303066527232758D-1, 4.367061943331126D-2, + > 1.765426012600548D-1, 4.982249645060048D-2, + > 2.280987746820670D-1, 5.537868201403226D-2, + > 2.840550769938310D-1, 6.030717484633422D-2, + > 3.433889379342239D-1, 6.458796732100688D-2, + > 4.049984831103632D-1, 6.821039566414624D-2, + > 4.677318207524097D-1, 7.117047743682441D-2, + > 5.304212533007296D-1, 7.346846419828167D-2, + > 5.919207725381885D-1, 7.510675391195046D-2, + > 6.511448995883448D-1, 7.608824036260866D-2, + > 7.071067811865475D-1, 7.641513111317905D-2, + > 7.589534371356944D-1, 7.608824036260866D-2, + > 8.059961532400723D-1, 7.510675391195046D-2, + > 8.477342119124858D-1, 7.346846419828167D-2, + > 8.838704338621333D-1, 7.117047743682441D-2, + > 9.143173566537523D-1, 6.821039566414624D-2, + > 9.391932907045310D-1, 6.458796732100688D-2, + > 9.588079647322652D-1, 6.030717484633422D-2, + > 9.736379968902917D-1, 5.537868201403226D-2, + > 9.842930000463954D-1, 4.982249645060048D-2, + > 9.914737395695640D-1, 4.367061943331126D-2, + > 9.959243872135214D-1, 3.696937092634360D-2, + > 9.983815137686745D-1, 2.978102161065714D-2, + > 9.995229709735581D-1, 2.218439608809088D-2, + > 9.999201431786683D-1, 1.427456861312436D-2, + > 9.999971057230626D-1, 6.169968963546275D-3/ +*---- +* Order = 64 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=497,528)/ + > 2.260451006401776D-3, 5.797117680017662D-3, + > 1.187555474628660D-2, 1.341688614356055D-2, + > 2.903192296767898D-2, 2.086504628721960D-2, + > 5.348772246647195D-2, 2.803569126620853D-2, + > 8.488403572313128D-2, 3.484354779039823D-2, + > 1.227451197406277D-1, 4.121716160665880D-2, + > 1.664778916763791D-1, 4.709924845926102D-2, + > 2.153746593423551D-1, 5.244635195862705D-2, + > 2.686204966167571D-1, 5.722762992459373D-2, + > 3.253060318502849D-1, 6.142301931103583D-2, + > 3.844458467127314D-1, 6.502107279693194D-2, + > 4.450021333238041D-1, 6.801672562809563D-2, + > 5.059127742515483D-1, 7.040918982162950D-2, + > 5.661226261485058D-1, 7.220010760651431D-2, + > 6.246165176514237D-1, 7.339204014218695D-2, + > 6.804523156165483D-1, 7.398732697450898D-2, + > 7.327923622500970D-1, 7.398732697450898D-2, + > 7.809316268899658D-1, 7.339204014218695D-2, + > 8.243210370739783D-1, 7.220010760651431D-2, + > 8.625846421361221D-1, 7.040918982162950D-2, + > 8.955295089148449D-1, 6.801672562809563D-2, + > 9.231475455989314D-1, 6.502107279693194D-2, + > 9.456087910133986D-1, 6.142301931103583D-2, + > 9.632460894274976D-1, 5.722762992459373D-2, + > 9.765314926376745D-1, 5.244635195862705D-2, + > 9.860451873940605D-1, 4.709924845926102D-2, + > 9.924382275889311D-1, 4.121716160665880D-2, + > 9.963908372116607D-1, 3.484354779039823D-2, + > 9.985685071868378D-1, 2.803569126620853D-2, + > 9.995784848869041D-1, 2.086504628721960D-2, + > 9.999294831134183D-1, 1.341688614356055D-2, + > 9.999974451773603D-1, 5.797117680017662D-3/ +*---- +* Order = 66 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=529,561)/ + > 2.127767955855947D-3, 5.457055989066269D-3, + > 1.118039441421181D-2, 1.263408341121632D-2, + > 2.734100277100129D-2, 1.965938521651337D-2, + > 5.039565382935335D-2, 2.643794451890077D-2, + > 8.002669926187768D-2, 3.289309077657504D-2, + > 1.158131591183225D-1, 3.895995661650402D-2, + > 1.572300146684183D-1, 4.458584184375271D-2, + > 2.036500183342073D-1, 4.973005671396442D-2, + > 2.543492281175076D-1, 5.436302857337294D-2, + > 3.085169689930697D-1, 5.846485650012917D-2, + > 3.652704783006284D-1, 6.202354684819099D-2, + > 4.236740543125242D-1, 6.503314324601964D-2, + > 4.827621314188725D-1, 6.749192029021972D-2, + > 5.415653801336422D-1, 6.940075957307684D-2, + > 5.991386896375901D-1, 7.076178092149795D-2, + > 6.545897375326029D-1, 7.157726645471736D-2, + > 7.071067811865475D-1, 7.184889180746158D-2, + > 7.559843090415290D-1, 7.157726645471736D-2, + > 8.006452588876996D-1, 7.076178092149795D-2, + > 8.406586340725370D-1, 6.940075957307684D-2, + > 8.757515198204952D-1, 6.749192029021972D-2, + > 9.058147137811288D-1, 6.503314324601964D-2, + > 9.309014328499179D-1, 6.202354684819099D-2, + > 9.512188390918934D-1, 5.846485650012917D-2, + > 9.671124392520386D-1, 5.436302857337294D-2, + > 9.790437528693378D-1, 4.973005671396442D-2, + > 9.875620094390878D-1, 4.458584184375271D-2, + > 9.932710164778967D-1, 3.895995661650402D-2, + > 9.967927203813484D-1, 3.289309077657504D-2, + > 9.987293317386408D-1, 2.643794451890077D-2, + > 9.996261649073998D-1, 1.965938521651337D-2, + > 9.999374974370861D-1, 1.263408341121632D-2, + > 9.999977362992008D-1, 5.457055989066269D-3/ +*---- +* Order = 68 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=562,595)/ + > 2.006430897540039D-3, 5.146050313292597D-3, + > 1.054447088264912D-2, 1.191770807990189D-2, + > 2.579323625075468D-2, 1.855478004998946D-2, + > 4.756278722072234D-2, 2.497175458640582D-2, + > 7.557097996402496D-2, 3.109953168579275D-2, + > 1.094439543367078D-1, 3.687913529406050D-2, + > 1.487153270030891D-1, 4.226206890226890D-2, + > 1.928273387808641D-1, 4.721028879193994D-2, + > 2.411349977536837D-1, 5.169555561856539D-2, + > 2.929138510155265D-1, 5.569829899210566D-2, + > 3.473716688709153D-1, 5.920617987876196D-2, + > 4.036639760910661D-1, 6.221252672611230D-2, + > 4.609130411977627D-1, 6.471478978336624D-2, + > 5.182296606197990D-1, 6.671311918267942D-2, + > 5.747368634369850D-1, 6.820913521902009D-2, + > 6.295945185532131D-1, 6.920492910010646D-2, + > 6.820237474599884D-1, 6.970231119307893D-2, + > 7.313300266641826D-1, 6.970231119307893D-2, + > 7.769238973076757D-1, 6.920492910010646D-2, + > 8.183382783461961D-1, 6.820913521902009D-2, + > 8.552414973876606D-1, 6.671311918267942D-2, + > 8.874453044857635D-1, 6.471478978336624D-2, + > 9.149073146534305D-1, 6.221252672611230D-2, + > 9.377275316774245D-1, 5.920617987876196D-2, + > 9.561388371378154D-1, 5.569829899210566D-2, + > 9.704915830950472D-1, 5.169555561856539D-2, + > 9.812327029908297D-1, 4.721028879193994D-2, + > 9.888800491032086D-1, 4.226206890226890D-2, + > 9.939929682141341D-1, 3.687913529406050D-2, + > 9.971404249087873D-1, 3.109953168579275D-2, + > 9.988682502071013D-1, 2.497175458640582D-2, + > 9.996672991369242D-1, 1.855478004998946D-2, + > 9.999444055215295D-1, 1.191770807990189D-2, + > 9.999979871155008D-1, 5.146050313292597D-3/ +*---- +* Order = 70 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=596,630)/ + > 1.895182390808144D-3, 4.860883544830628D-3, + > 9.961246688281479D-3, 1.126046540783217D-2, + > 2.437294975502797D-2, 1.754029683264231D-2, + > 4.496109079691220D-2, 2.362319238448706D-2, + > 7.147420525157438D-2, 2.944673122343525D-2, + > 1.035791506531498D-1, 3.495721171268495D-2, + > 1.408602617289225D-1, 4.010998546152185D-2, + > 1.828200227142416D-1, 4.486951999487671D-2, + > 2.288821565254979D-1, 4.920893733923423D-2, + > 2.783976951621312D-1, 5.310912506931291D-2, + > 3.306543210696288D-1, 5.655756629702146D-2, + > 3.848889902593347D-1, 5.954703320530382D-2, + > 4.403035834865983D-1, 6.207426689302348D-2, + > 4.960831016113237D-1, 6.413873664427702D-2, + > 5.514157377272589D-1, 6.574154187441527D-2, + > 6.055140267651983D-1, 6.688449453259325D-2, + > 6.576361927484648D-1, 6.756940076441969D-2, + > 7.071067811865475D-1, 6.779754843107255D-2, + > 7.533356741767272D-1, 6.756940076441969D-2, + > 7.958346331937275D-1, 6.688449453259325D-2, + > 8.342305941325233D-1, 6.574154187441527D-2, + > 8.682750464545719D-1, 6.413873664427702D-2, + > 8.978489596635172D-1, 6.207426689302348D-2, + > 9.229628731304146D-1, 5.954703320530382D-2, + > 9.437519377240943D-1, 5.655756629702146D-2, + > 9.604658886854926D-1, 5.310912506931291D-2, + > 9.734541378124793D-1, 4.920893733923423D-2, + > 9.831463976920040D-1, 4.486951999487671D-2, + > 9.900294877758235D-1, 4.010998546152185D-2, + > 9.946212141061401D-1, 3.495721171268495D-2, + > 9.974424484568801D-1, 2.944673122343525D-2, + > 9.989887388326016D-1, 2.362319238448706D-2, + > 9.997029355364717D-1, 1.754029683264231D-2, + > 9.999503855514108D-1, 1.126046540783217D-2, + > 9.999982041402402D-1, 4.860883544830628D-3/ +*---- +* Order = 72 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=631,666)/ + > 1.792934454202931D-3, 4.598771655133457D-3, + > 9.425061112313890D-3, 1.065603341978431D-2, + > 2.306655207082563D-2, 1.660643477465490D-2, + > 4.256620201285560D-2, 2.238010857286012D-2, + > 6.769916617188922D-2, 2.792054146952203D-2, + > 9.816763086953637D-2, 3.317875933222189D-2, + > 1.335999707374397D-1, 3.811363223988677D-2, + > 1.735510826588126D-1, 4.269199698797202D-2, + > 2.175046751209386D-1, 4.688833809218218D-2, + > 2.648780127840390D-1, 5.068409479675100D-2, + > 3.150293990097726D-1, 5.406671002171079D-2, + > 3.672684559193769D-1, 5.702853994383097D-2, + > 4.208690454062535D-1, 5.956572815765240D-2, + > 4.750844817568741D-1, 6.167712597050399D-2, + > 5.291645281141019D-1, 6.336331655665649D-2, + > 5.823735501979260D-1, 6.462577941116331D-2, + > 6.340091223112186D-1, 6.546621488177129D-2, + > 6.834203406787824D-1, 6.588603711319039D-2, + > 7.300250940525928D-1, 6.588603711319039D-2, + > 7.733255671618250D-1, 6.546621488177129D-2, + > 8.129213049427747D-1, 6.462577941116331D-2, + > 8.485192409048718D-1, 6.336331655665649D-2, + > 8.799401884183961D-1, 6.167712597050399D-2, + > 9.071214067691430D-1, 5.956572815765240D-2, + > 9.301149828309383D-1, 5.702853994383097D-2, + > 9.490819130926168D-1, 5.406671002171079D-2, + > 9.642819288691345D-1, 5.068409479675100D-2, + > 9.760592790914571D-1, 4.688833809218218D-2, + > 9.848248685466640D-1, 4.269199698797202D-2, + > 9.910353413571865D-1, 3.811363223988677D-2, + > 9.951698931586820D-1, 3.317875933222189D-2, + > 9.977057797264838D-1, 2.792054146952203D-2, + > 9.990936484865674D-1, 2.238010857286012D-2, + > 9.997339316916096D-1, 1.660643477465490D-2, + > 9.999555831250852D-1, 1.065603341978431D-2, + > 9.999983926917297D-1, 4.598771655133457D-3/ +*---- +* Order = 74 +*---- + DATA ((SYST(IS,IA),IS=1,2),IA=667,703)/ + > 1.698741886354622D-3, 4.357295595609470D-3, + > 8.930992904023735D-3, 1.009891155595077D-2, + > 2.186221185368514D-2, 1.574490757594847D-2, + > 4.035686918939289D-2, 2.123186989304243D-2, + > 6.421330823399199D-2, 2.650852294936087D-2, + > 9.316448689887876D-2, 3.153013523379523D-2, + > 1.268771624175196D-1, 3.625879153931750D-2, + > 1.649519866208174D-1, 4.066355379567878D-2, + > 2.069251875729949D-1, 4.472025016442803D-2, + > 2.522722781263537D-1, 4.841093781051414D-2, + > 3.004140595738183D-1, 5.172313096383708D-2, + > 3.507250096820162D-1, 5.464889158975430D-2, + > 4.025439676980595D-1, 5.718387043152167D-2, + > 4.551868677602700D-1, 5.932636945044961D-2, + > 5.079611361117360D-1, 6.107647781254220D-2, + > 5.601812617687321D-1, 6.243531594168673D-2, + > 6.111849763541508D-1, 6.340440772608052D-2, + > 6.603494357038005D-1, 6.398519049059308D-2, + > 7.071067811865475D-1, 6.417866575467489D-2, + > 7.509584694013859D-1, 6.398519049059308D-2, + > 7.914877918698279D-1, 6.340440772608052D-2, + > 8.283700585868560D-1, 6.243531594168673D-2, + > 8.613799882746722D-1, 6.107647781254220D-2, + > 8.903959318295398D-1, 5.932636945044961D-2, + > 9.154006522118627D-1, 5.718387043152167D-2, + > 9.364784928569100D-1, 5.464889158975430D-2, + > 9.538088869424411D-1, 5.172313096383708D-2, + > 9.676562910914906D-1, 4.841093781051414D-2, + > 9.783567686421354D-1, 4.472025016442803D-2, + > 9.863015979454995D-1, 4.066355379567878D-2, + > 9.919184369981628D-1, 3.625879153931750D-2, + > 9.956507311205414D-1, 3.153013523379523D-2, + > 9.979361958790984D-1, 2.650852294936087D-2, + > 9.991853297107750D-1, 2.123186989304243D-2, + > 9.997609932843272D-1, 1.574490757594847D-2, + > 9.999601178875827D-1, 1.009891155595077D-2, + > 9.999985571369608D-1, 4.357295595609470D-3/ +*---- +* Start processing +*---- + PI=XDRCST('Pi',' ') + PID2=PI/DTWO + NBPT=(NLF*(NLF+2))/8 + ILEVEL=1 + JLEVEL=0 + NLEVEL=NLF/2 + KLEVEL=(NLEVEL*(NLEVEL-1))/2 + IPOINT=0 + DO IPT=1,NBPT + IPOINT=IPOINT+1 + JLEVEL = JLEVEL + 1 + ALPHA =PI*(DBLE(NLEVEL-ILEVEL+1-JLEVEL)+DONE/DTWO) + > /(DTWO*DBLE(NLEVEL-ILEVEL+1)) + XI=SYST(1,KLEVEL+ILEVEL) + ROTXI=SQRT(DONE-XI**2) + COSA=COS(ALPHA) + SINA=SIN(ALPHA) + TPQ(IPOINT)=REAL(COSA*ROTXI) + UPQ(IPOINT)=REAL(SINA*ROTXI) + VPQ(IPOINT)=REAL(XI) + WPQ(IPOINT)=REAL(DTWO/DBLE(NLF/DTWO+DONE)*SYST(2,KLEVEL+ILEVEL)) + IF(JLEVEL .EQ. NLEVEL-ILEVEL+1) THEN + ILEVEL = ILEVEL + 1 + JLEVEL = 0 + ENDIF + ENDDO + RETURN + END + diff --git a/Dragon/src/SNQU07.f b/Dragon/src/SNQU07.f new file mode 100644 index 0000000..11ff654 --- /dev/null +++ b/Dragon/src/SNQU07.f @@ -0,0 +1,73 @@ +*DECK SNQU07 + SUBROUTINE SNQU07(NLF,X,W) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To define Gauss-Lobatto points and weights (1D quadrature). +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal. +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* C. Bienvenue +* +*Parameters: input +* NLF order of the SN approximation (even number). +* +*Parameters: output +* X base points in $\\mu$ of the quadrature. +* W weights of the quadrature. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NLF + REAL X(NLF),W(NLF) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(PI=3.141592654,NMAX=100,EPS=1.0E-6) + INTEGER N + REAL XOLD(NLF),P(NLF,NLF) +*---- +* COMPUTE QUADRATURE PARAMETERS +*---- + + ! INITIAL GUESS BASE POINTS + DO 10 I=1,NLF + X(I)=COS(PI*(I-1)/(NLF-1)) + XOLD(I)=2.0 + 10 ENDDO + + ! NEWTON-RAPHSON METHOD TO COMPUTE BASE POINTS + P(:NLF,:NLF)=0.0 + DO 20 I=1,NLF + N=1 + DO WHILE (ABS(X(I)-XOLD(I)).GT.EPS) + XOLD(I) = X(I) + P(I,1)=1 + P(I,2)=X(I) + DO 30 J=2,NLF-1 + P(I,J+1)=((2*J-1)*X(I)*P(I,J)-(J-1)*P(I,J-1))/J + 30 ENDDO + X(I)=XOLD(I)-(X(I)*P(I,NLF)-P(I,NLF-1))/(NLF*P(I,NLF)) + IF(N.GT.NMAX) CALL XABORT('SNQU07: CONVERGENCE ISSUE.') + N=N+1 + ENDDO + W(I)=2/((NLF-1)*NLF*P(I,NLF)**2) + 20 ENDDO + + ! COMPUTE WEIGHTS + DO 40 I=1,NLF + W(I)=2/((NLF-1)*NLF*P(I,NLF)**2) + 40 ENDDO + + RETURN + END \ No newline at end of file diff --git a/Dragon/src/SNQU10.f b/Dragon/src/SNQU10.f new file mode 100644 index 0000000..4fc930b --- /dev/null +++ b/Dragon/src/SNQU10.f @@ -0,0 +1,74 @@ +*DECK SNQU10 + SUBROUTINE SNQU10(NLF,JOP,U,W,TPQ,UPQ,VPQ,WPQ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Set the product of Gauss-Legendre and Gauss-Chebyshev quadratures. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NLF order of the SN approximation (even number). +* +*Parameters: output +* JOP number of base points per axial level in one octant. +* U base points in $\\xi$ of the axial quadrature. Used with +* zero-weight points. +* W weights for the axial quadrature in $\\xi$. +* TPQ base points in $\\xi$ of the 2D SN quadrature. +* UPQ base points in $\\mu$ of the 2D SN quadrature. +* VPQ base points in $\\eta$ of the 2D SN quadrature. +* WPQ weights of the 2D SN quadrature. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NLF,JOP(NLF/2) + REAL U(NLF/2),W(NLF/2),TPQ((NLF**2)/4),UPQ((NLF**2)/4), + 1 VPQ((NLF**2)/4),WPQ((NLF**2)/4) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(PI=3.141592654,MAXNLF=64) + REAL U2(MAXNLF),W2(MAXNLF) +*---- +* SET THE QUARATURE VALUES. +*---- + M2=NLF/2 + IF(NLF.EQ.2) THEN + U(1)=1/SQRT(3.0) + W(1)=1.0 + ELSE + IF(NLF.GT.MAXNLF) CALL XABORT('SNQU10: TOO MANY GAUSS POINTS.') + CALL ALGPT(NLF,-1.0,1.0,U2,W2) + DO 45 M=1,M2 + U(M)=U2(M2+M) + W(M)=W2(M2+M) + 45 CONTINUE + ENDIF + IPQ=0 + WSUM=0.0 + DO IP=1,M2 + JOP(IP)=M2 + DO IQ=1,M2 + IPQ=IPQ+1 + OMEGA=0.5*PI*(1.0-REAL(NLF-2*IQ+1)/REAL(NLF)) + TPQ(IPQ)=U(IP) + UPQ(IPQ)=SQRT(1.0-U(IP)*U(IP))*COS(OMEGA) + VPQ(IPQ)=SQRT(1.0-U(IP)*U(IP))*SIN(OMEGA) + WPQ(IPQ)=PI*W(IP)/REAL(NLF) + WSUM=WSUM+WPQ(IPQ) + ENDDO + ENDDO + RETURN + END diff --git a/Dragon/src/SNSBFP.f b/Dragon/src/SNSBFP.f new file mode 100644 index 0000000..111cab0 --- /dev/null +++ b/Dragon/src/SNSBFP.f @@ -0,0 +1,190 @@ +*DECK SNSBFP + SUBROUTINE SNSBFP(IG,IPTRK,KPMACR,KPSYS,NANIS,NLF,NREG,NMAT, + 1 NUNKNO,NGRP,MATCOD,FLUX,QEXT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the QEXT for the solution of SN equations with a Boltzmann- +* Fokker-Planck discretization. +* +*Copyright: +* Copyright (C) 2020 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IG secondary group. +* IPTRK pointer to the tracking LCM object. +* KPMACR pointer to the secondary-group related macrolib information. +* KPSYS pointer to the system matrix information. +* NANIS maximum cross section Legendre order. +* NLF number of Legendre components in the flux. +* NREG number of regions. +* NMAT number of mixtures. +* NUNKNO number of unknowns per energy group including spherical +* harmonic terms, interface currents, fundamental currents +* and slowing-down angular fluxes at group boundary. +* NGRP number of energy groups. +* MATCOD mixture indices. +* FLUX fluxes and slowing-down angular fluxes at group boundary. +* +*Parameters: output +* QEXT sources and slowing-down angular fluxes at group boundary. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,KPMACR,KPSYS + INTEGER IG,NANIS,NLF,NREG,NMAT,NUNKNO,NGRP,MATCOD(NREG) + REAL FLUX(NUNKNO,NGRP),QEXT(NUNKNO,NGRP) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40,PI4=12.5663706144) + INTEGER JPAR(NSTATE),EELEM,P + CHARACTER CAN(0:19)*2 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) :: XSCAT + TYPE(C_PTR) IL_PTR,IM_PTR + INTEGER, POINTER, DIMENSION(:) :: IL,IM +*---- +* DATA STATEMENTS +*---- + DATA CAN /'00','01','02','03','04','05','06','07','08','09', + > '10','11','12','13','14','15','16','17','18','19'/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IJJ(0:NMAT),NJJ(0:NMAT),IPOS(0:NMAT)) + ALLOCATE(XSCAT(0:NMAT*NGRP)) +*---- +* RECOVER SNT SPECIFIC PARAMETERS +*---- + LFEP=0 + CALL LCMGET(IPTRK,'STATE-VECTOR',JPAR) + IF(JPAR(1).NE.NREG) CALL XABORT('SNSBFP: INCONSISTENT NREG.') + IF(JPAR(2).NE.NUNKNO) CALL XABORT('SNSBFP: INCONSISTENT NUNKNO.') + IF(JPAR(15).NE.NLF) CALL XABORT('SNSBFP: INCONSISTENT NLF.') + ITYPE=JPAR(6) + NSCT=JPAR(7) + IELEM=JPAR(8) + ISCAT=JPAR(16) + EELEM=JPAR(35) + CALL LCMGPD(IPTRK,'IL',IL_PTR) + CALL LCMGPD(IPTRK,'IM',IM_PTR) + CALL C_F_POINTER(IL_PTR,IL,(/ NSCT /)) + CALL C_F_POINTER(IM_PTR,IM,(/ NSCT /)) +*---- +* CONSTRUCT THE QEXT. +*---- + IJJ(0)=0 + NJJ(0)=0 + IPOS(0)=0 + XSCAT(0)=0.0 + IOF0=0 + DO 130 P=1,NSCT + ILP=IL(P) + IF(ILP.GT.MIN(ISCAT-1,NANIS)) GO TO 130 + CALL LCMGET(KPMACR,'NJJS'//CAN(ILP),NJJ(1)) + CALL LCMGET(KPMACR,'IJJS'//CAN(ILP),IJJ(1)) + CALL LCMGET(KPMACR,'IPOS'//CAN(ILP),IPOS(1)) + CALL LCMGET(KPMACR,'SCAT'//CAN(ILP),XSCAT(1)) + IF((ITYPE.EQ.2).OR.(ITYPE.EQ.4)) THEN +*---- +* SLAB OR SPHERICAL 1D CASE. +*---- + NM=IELEM*EELEM + LFEP=IELEM*NLF*NREG + DO 20 IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) GO TO 20 + DO 15 IEL=1,NM + IND=(IR-1)*NSCT*NM+(P-1)*NM+IEL + JG=IJJ(IBM) + DO 10 JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + QEXT(IND,IG)=QEXT(IND,IG)+FLUX(IND,JG)* + 1 XSCAT(IPOS(IBM)+JND-1) + ENDIF + JG=JG-1 + 10 CONTINUE + 15 CONTINUE + 20 CONTINUE + ELSE IF((ITYPE.EQ.5).OR.(ITYPE.EQ.6).OR.(ITYPE.EQ.8)) THEN +*---- +* 2D CASES (CARTESIAN OR R-Z). +*---- + NME=IELEM*IELEM + NM=NME*EELEM + CALL LCMLEN(IPTRK,'DU',NPQ,ITYLCM) + LFEP=NME*NPQ*NREG + DO 70 IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) GO TO 70 + DO 65 IEL=1,NM + IND=(IR-1)*NSCT*NM+(P-1)*NM+IEL + JG=IJJ(IBM) + DO 60 JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + QEXT(IND,IG)=QEXT(IND,IG)+FLUX(IND,JG)* + 1 XSCAT(IPOS(IBM)+JND-1) + ENDIF + JG=JG-1 + 60 CONTINUE + 65 CONTINUE + 70 CONTINUE + ELSE IF(ITYPE.EQ.7) THEN +*---- +* 3D CASES (CARTESIAN) +*---- + NME=IELEM*IELEM*IELEM + NM=NME*EELEM + CALL LCMLEN(IPTRK,'DU',NPQ,ITYLCM) + LFEP=NME*NPQ*NREG + DO 110 IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) GO TO 110 + DO 100 IEL=1,NM + IND=(IR-1)*NSCT*NM+(P-1)*NM+IEL + JG=IJJ(IBM) + DO 90 JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + QEXT(IND,IG)=QEXT(IND,IG)+FLUX(IND,JG)* + 1 XSCAT(IPOS(IBM)+JND-1) + ENDIF + JG=JG-1 + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE + ELSE + CALL XABORT('SNSBFP: TYPE OF DISCRETIZATION NOT IMPLEMENTED.') + ENDIF + 130 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XSCAT) + DEALLOCATE(IPOS,NJJ,IJJ) +*---- +* RECOVER SLOWING-DOWN ANGULAR FLUXES +*---- + CALL LCMGET(KPSYS,'DRAGON-DELTE',DELTAE) + IF(IG.EQ.1) THEN + QEXT(NUNKNO-LFEP+1:NUNKNO,1)=0.0 + ELSE + QEXT(NUNKNO-LFEP+1:NUNKNO,IG)=FLUX(NUNKNO-LFEP+1:NUNKNO,IG-1) + 1 *DELTAE + ENDIF + RETURN + END diff --git a/Dragon/src/SNSOUR.f b/Dragon/src/SNSOUR.f new file mode 100644 index 0000000..7e2a0bb --- /dev/null +++ b/Dragon/src/SNSOUR.f @@ -0,0 +1,188 @@ +*DECK SNSOUR + SUBROUTINE SNSOUR(MAX1,IG,IPTRK,KPMACR,NANIS,NREG,NMAT,NUNKNO, + > NGRP,MATCOD,FLUX,SOURCE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the source for the solution of SN equations. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAX1 first dimension of FLUX and SOURCE arrays. +* IG secondary group. +* IPTRK pointer to the tracking LCM object. +* KPMACR pointer to the secondary-group related macrolib information. +* NANIS maximum cross section Legendre order. +* NREG number of regions. +* NMAT number of mixtures. +* NUNKNO number of unknowns per energy group including spherical +* harmonic terms, interface currents and fundamental +* currents. +* NGRP number of energy groups. +* MATCOD mixture indices. +* FLUX fluxes. +* +*Parameters: output +* SOURCE sources. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,KPMACR + INTEGER MAX1,IG,NANIS,NREG,NMAT,NUNKNO,NGRP,MATCOD(NREG) + REAL FLUX(MAX1,NGRP),SOURCE(MAX1,NGRP) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40,PI4=12.5663706144) + INTEGER JPAR(NSTATE),P,P2,ILP + CHARACTER CAN(0:19)*2 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) :: XSCAT + TYPE(C_PTR) IL_PTR,IM_PTR + INTEGER, POINTER, DIMENSION(:) :: IL,IM +*---- +* DATA STATEMENTS +*---- + DATA CAN /'00','01','02','03','04','05','06','07','08','09', + > '10','11','12','13','14','15','16','17','18','19'/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IJJ(0:NMAT),NJJ(0:NMAT),IPOS(0:NMAT)) + ALLOCATE(XSCAT(0:NMAT*NGRP)) +*---- +* RECOVER SNT SPECIFIC PARAMETERS. +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',JPAR) + IF(JPAR(1).NE.NREG) CALL XABORT('SNSOUR: INCONSISTENT NREG.') + IF(JPAR(2).NE.NUNKNO) CALL XABORT('SNSOUR: INCONSISTENT NUNKNO.') + ITYPE=JPAR(6) + NSCT=JPAR(7) + IELEM=JPAR(8) + ISCAT=JPAR(16) + CALL LCMGPD(IPTRK,'IL',IL_PTR) + CALL LCMGPD(IPTRK,'IM',IM_PTR) + CALL C_F_POINTER(IL_PTR,IL,(/ NSCT /)) + CALL C_F_POINTER(IM_PTR,IM,(/ NSCT /)) +*---- +* CONSTRUCT THE SOURCE. +*---- + IJJ(0)=0 + NJJ(0)=0 + IPOS(0)=0 + XSCAT(0)=0.0 + IOF0=0 + DO 90 P=1,NSCT + ILP = IL(P) + IF(ILP.GT.MIN(ISCAT-1,NANIS)) GO TO 90 + CALL LCMGET(KPMACR,'NJJS'//CAN(ILP),NJJ(1)) + CALL LCMGET(KPMACR,'IJJS'//CAN(ILP),IJJ(1)) + CALL LCMGET(KPMACR,'IPOS'//CAN(ILP),IPOS(1)) + CALL LCMGET(KPMACR,'SCAT'//CAN(ILP),XSCAT(1)) + IF((ITYPE.EQ.2).OR.(ITYPE.EQ.4)) THEN +*---- +* SLAB OR SPHERICAL 1D CASE. +*---- + DO 20 IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) GO TO 20 + DO 15 IEL=1,IELEM + IND=(IR-1)*NSCT*IELEM+IELEM*(P-1)+IEL + JG=IJJ(IBM) + DO 10 JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + SOURCE(IND,IG)=SOURCE(IND,IG)+FLUX(IND,JG)* + 1 XSCAT(IPOS(IBM)+JND-1) + ENDIF + JG=JG-1 + 10 CONTINUE + 15 CONTINUE + 20 CONTINUE + ELSE IF(ITYPE.EQ.3) THEN +*---- +* CYLINDRICAL 1D CASE. +*---- + DO 50 P2=0,P-1 + IF(MOD((P-1)+P2,2).EQ.1) GO TO 50 + IOF0=IOF0+1 + DO 40 IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) GO TO 40 + IND=(IR-1)*NSCT+IOF0 + JG=IJJ(IBM) + DO 30 JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + SOURCE(IND,IG)=SOURCE(IND,IG)+FLUX(IND,JG)* + 1 XSCAT(IPOS(IBM)+JND-1) + ENDIF + JG=JG-1 + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + ELSE IF((ITYPE.EQ.5).OR.(ITYPE.EQ.6).OR.(ITYPE.EQ.8)) THEN +*---- +* 2D CASES (CARTESIAN OR R-Z). +*---- + NM=IELEM**2 + DO 70 IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) GO TO 70 + DO 65 IEL=1,NM + IND=(IR-1)*NSCT*NM+(P-1)*NM+IEL + JG=IJJ(IBM) + DO 60 JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + SOURCE(IND,IG)=SOURCE(IND,IG)+FLUX(IND,JG)* + 1 XSCAT(IPOS(IBM)+JND-1) + ENDIF + JG=JG-1 + 60 CONTINUE + 65 CONTINUE + 70 CONTINUE + ELSE IF((ITYPE.EQ.7).OR.(ITYPE.EQ.9)) THEN +*---- +* 3D CARTESIAN CASE +*---- + NM=IELEM**3 + DO 110 IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) GO TO 110 + DO 125 IEL=1,NM + IND=(IR-1)*NSCT*NM+(P-1)*NM+IEL + JG=IJJ(IBM) + DO 120 JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + SOURCE(IND,IG)=SOURCE(IND,IG)+FLUX(IND,JG)* + 1 XSCAT(IPOS(IBM)+JND-1) + ENDIF + JG=JG-1 + 120 CONTINUE + 125 CONTINUE + 110 CONTINUE + ELSE + CALL XABORT('SNSOUR: TYPE OF DISCRETIZATION NOT IMPLEMENTED.') + ENDIF + 90 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XSCAT) + DEALLOCATE(IPOS,NJJ,IJJ) + RETURN + END diff --git a/Dragon/src/SNT.f b/Dragon/src/SNT.f new file mode 100644 index 0000000..fecbc83 --- /dev/null +++ b/Dragon/src/SNT.f @@ -0,0 +1,395 @@ +*DECK SNT + SUBROUTINE SNT(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* SN method tracking operator. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1) create or modification type(L_TRACK); +* HENTRY(2) read-only type(L_GEOM). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40,IOUT=6) + TYPE(C_PTR) IPTRK,IPGEOM + CHARACTER TEXT4*4,TEXT12*12,TITLE*72,HSIGN*12 + DOUBLE PRECISION DFLOTT + REAL EPSI + LOGICAL LOG,LFIXUP,LDSA,LBIHET,LIVO,LSHOOT + INTEGER IGP(NSTATE),ISTATE(NSTATE),NCODE(6),NITMA,EELEM,ESCHM,IGLK +*---- +* PARAMETER VALIDATION +*---- + IF(NENTRY.LE.1) CALL XABORT('SNT: TWO PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('SNT: L' + 1 //'CM OBJECT EXPECTED AT LHS.') + IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) CALL XABORT('SNT: E' + 1 //'NTRY IN CREATE OR MODIFICATION MODE EXPECTED.') + IF((JENTRY(2).NE.2).OR.((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2))) + 1 CALL XABORT('SNT: LCM OBJECT IN READ-ONLY MODE EXPECTED AT R' + 2 //'HS.') + CALL LCMGTC(KENTRY(2),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_GEOM') THEN + TEXT12=HENTRY(2) + CALL XABORT('SNT: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_GEOM EXPECTED.') + ENDIF + IPTRK=KENTRY(1) + IPGEOM=KENTRY(2) + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) + ITYPE=ISTATE(1) +* + LBIHET=.FALSE. + IMPX=1 + TITLE=' ' + IF(JENTRY(1).EQ.0) THEN + HSIGN='L_TRACK' + CALL LCMPTC(IPTRK,'SIGNATURE',12,HSIGN) + HSIGN='SN' + CALL LCMPTC(IPTRK,'TRACK-TYPE',12,HSIGN) + MAXPTS=ISTATE(6) + ISCHM=1 + ESCHM=1 + IELEM=1 + EELEM=1 + NLF=0 + ISCAT=0 + IQUAD=2 + LFIXUP=.FALSE. + LDSA=.FALSE. + LIVO=.TRUE. + IGLK=0 + ICL1=3 + ICL2=3 + ISPLH=0 + IF((ITYPE.EQ.8).OR.(ITYPE.EQ.9)) THEN + CALL LCMLEN(IPGEOM,'SPLITL',ILEN,ITYLCM) + IF(ILEN.GT.0)THEN + CALL LCMGET(IPGEOM,'SPLITL',ISPLH) + IF(ISPLH.EQ.0) ISPLH=1 + MAXPTS=MAXPTS*3*ISPLH**2 + ELSE + CALL XABORT('SNT: SPLITL SPECIFIER NEEDED FOR SN '// + 1 'WITH HEXAGONAL GEOMETRY.') + ENDIF + ENDIF + NSTART=0 + NSDSA=1000 + IELEMSA=1 + ISOLVSA=2 + MAXIT=100 + EPSI=1.0E-5 + CALL LCMGET(IPGEOM,'NCODE',NCODE) + LOG=.FALSE. + DO 10 I=1,4 + LOG=LOG.OR.(NCODE(I).EQ.3) + 10 CONTINUE + IF(LOG) MAXPTS=2*MAXPTS + IQUA10=0 + IBIHET=2 + INSB=0 + MCELL=0 + NMPI=0 + NFOU=0 + LSHOOT=.TRUE. + CALL LCMLEN(IPGEOM,'BIHET',ILONG,ITYLCM) + LBIHET=(ILONG.NE.0) + IF(LBIHET) IQUA10=5 + IBFP=0 + ELSE IF(JENTRY(1).EQ.1) THEN + CALL LCMGTC(IPTRK,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_TRACK') THEN + TEXT12=HENTRY(1) + CALL XABORT('SNT: SIGNATURE OF '//TEXT12//' IS '//HSIGN + 1 //'. L_TRACK EXPECTED.') + ENDIF + CALL LCMGTC(IPTRK,'TRACK-TYPE',12,HSIGN) + IF(HSIGN.NE.'SN') THEN + TEXT12=HENTRY(1) + CALL XABORT('SNT: TRACK-TYPE OF '//TEXT12//' IS '//HSIGN + 1 //'. SN EXPECTED.') + ENDIF + CALL LCMGET(IPTRK,'STATE-VECTOR',IGP) + MAXPTS=IGP(1) + IELEM=IGP(8) + ISCHM=IGP(10) + NLF=IGP(15) + ISCAT=IGP(16) + IQUAD=IGP(17) + LFIXUP=IGP(18).EQ.1 + LDSA=IGP(19).EQ.1 + NSTART=IGP(20) + NSDSA=IGP(21) + MAXIT=IGP(22) + LIVO=IGP(23).EQ.1 + ICL1=IGP(24) + ICL2=IGP(25) + ISPLH=IGP(26) + INSB=IGP(27) + MCELL=IGP(28) + LSHOOT=IGP(30).EQ.1 + NMPI=IGP(32) + ISOLVSA=IGP(33) + NFOU=IGP(34) + EELEM=IGP(35) + ESCHM=IGP(36) + IGLK=IGP(37) + LBIHET=IGP(40).GT.0 + EPSI=1.0E-5 + IF(LBIHET) THEN + CALL LCMSIX(IPTRK,'BIHET',1) + CALL LCMGET(IPTRK,'PARAM',IGP) + CALL LCMSIX(IPTRK,'BIHET',2) + IBIHET=IGP(6) + IQUA10=IGP(8) + ELSE + IBIHET=0 + IQUA10=0 + ENDIF + CALL LCMLEN(IPTRK,'TITLE',LENGT,ITYLCM) + IF(LENGT.GT.0) CALL LCMGTC(IPTRK,'TITLE',72,TITLE) + ENDIF + FRTM=0.05 + 15 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + 16 CONTINUE + IF(INDIC.EQ.10) GO TO 30 + IF(INDIC.NE.3) CALL XABORT('SNT: CHARACTER DATA EXPECTED.') + IF(TEXT4.EQ.'EDIT') THEN + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SNT: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT4.EQ.'TITL') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TITLE,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('SNT: TITLE EXPECTED.') + ELSE IF(TEXT4.EQ.'MAXR') THEN + CALL REDGET(INDIC,MAXPTS,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SNT: INTEGER DATA EXPECTED(2).') + ELSE IF(TEXT4.EQ.'SCHM') THEN + CALL REDGET(INDIC,ISCHM,FLOTT,TEXT4,DFLOTT) + IF(ISCHM.EQ.2) IELEM=2 + IF(INDIC.NE.1) CALL XABORT('SNT: INTEGER DATA EXPECTED(2.1).') + ELSE IF(TEXT4.EQ.'ESCH') THEN + CALL REDGET(INDIC,ESCHM,FLOTT,TEXT4,DFLOTT) + IF(ESCHM.EQ.2) EELEM=2 + IF(INDIC.NE.1) CALL XABORT('SNT: INTEGER DATA EXPECTED(2.2).') + ELSE IF(TEXT4.EQ.'DIAM') THEN + CALL REDGET(INDIC,IELEM,FLOTT,TEXT4,DFLOTT) + IELEM=IELEM+1 + IF(INDIC.NE.1) CALL XABORT('SNT: INTEGER DATA EXPECTED(3).') + ELSE IF(TEXT4.EQ.'EDIA') THEN + CALL REDGET(INDIC,EELEM,FLOTT,TEXT4,DFLOTT) + EELEM=EELEM+1 + IF(INDIC.NE.1) CALL XABORT('SNT: INTEGER DATA EXPECTED(3.1).') + ELSE IF(TEXT4.EQ.'SN') THEN + CALL REDGET(INDIC,NLF,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SNT: INTEGER DATA EXPECTED(4).') + IF(MOD(NLF,2).EQ.1) CALL XABORT('SNT: EVEN SN ORDER EXPECTED.') + ISCAT=NLF + ELSE IF(TEXT4.EQ.'SCAT') THEN + IF(NLF.EQ.0) CALL XABORT('SNT: DEFINE SN FIRST.') + CALL REDGET(INDIC,ISCAT,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SNT: INTEGER DATA EXPECTED(5).') + ELSE IF(TEXT4.EQ.'MAXI') THEN + CALL REDGET(INDIC,MAXIT,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SNT: INTEGER DATA EXPECTED(6).') + ELSE IF(TEXT4.EQ.'EPSI') THEN + CALL REDGET(INDIC,NITMA,EPSI,TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('SNT: REAL DATA EXPECTED(1).') + ELSE IF(TEXT4.EQ.'QUAD') THEN + CALL REDGET(INDIC,IQUAD,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SNT: INTEGER DATA EXPECTED(7).') + IF((IQUAD.LT.1).OR.(IQUAD.GT.20)) CALL XABORT('SNT: INVALID'// + 1 ' QUAD VALUE.') + ELSE IF(TEXT4.EQ.'NFIX') THEN + LFIXUP=.TRUE. + CALL REDGET(INDIC,ICL1,FLOTT,TEXT4,DFLOTT) + ELSE IF(TEXT4.EQ.'LIVO') THEN + LIVO=.TRUE. + CALL REDGET(INDIC,ICL1,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SNT: INTEGER DATA EXPECTED(8).') + CALL REDGET(INDIC,ICL2,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SNT: INTEGER DATA EXPECTED(9).') + ELSE IF(TEXT4.EQ.'NLIV') THEN + LIVO=.FALSE. + ELSE IF(TEXT4.EQ.'DSA') THEN + LDSA=.TRUE. + CALL REDGET(INDIC,NSDSA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SNT: INTEGER DATA EXPECTED(10).') + CALL REDGET(INDIC,IELEMSA,FLOTT,TEXT4,DFLOTT) + IELEMSA=IELEMSA + 1 + IF(INDIC.NE.1) CALL XABORT('SNT: INTEGER DATA EXPECTED(11).') + CALL REDGET(INDIC,ISOLVSA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SNT: INTEGER DATA EXPECTED(12).') + ELSE IF(TEXT4.EQ.'NDSA') THEN + LDSA=.FALSE. + ELSE IF(TEXT4.EQ.'GMRE') THEN + CALL REDGET(INDIC,NSTART,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SNT: INTEGER DATA EXPECTED(13).') + IF(NSTART.LT.0) CALL XABORT('SNT: POSITIVE VALUE EXPECTED.') + ELSE IF(TEXT4.EQ.'QUAB') THEN + CALL REDGET(INDIC,IQUA10,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SNT: INTEGER DATA EXPECTED(14).') + ELSE IF(TEXT4.EQ.'SAPO') THEN + IBIHET=1 + ELSE IF(TEXT4.EQ.'HEBE') THEN + IBIHET=2 + ELSE IF(TEXT4.EQ.'SLSI') THEN + IBIHET=3 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF (INDIC.NE.2) GOTO 16 + FRTM=FLOTT + ELSE IF(TEXT4.EQ.'SLSS') THEN + IBIHET=4 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF (INDIC.NE.2) GOTO 16 + FRTM=FLOTT + ELSE IF(TEXT4.EQ.'ONEG') THEN + INSB=0 + ELSE IF(TEXT4.EQ.'ALLG') THEN + INSB=1 + ELSE IF(TEXT4.EQ.'KBA') THEN + ! Enable parallelisation over macrocells in wavefront (and + ! energies depending ONEG/ALLG) + CALL REDGET(INDIC,MCELL,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SNT: INTEGER DATA EXPECTED(15).') + IF(MCELL.LT.0) CALL XABORT('SNT: POSITIVE INTEGER EXPECTED.') + ELSE IF(TEXT4.EQ.'MPIM') THEN + ! Compute graph and mpi rank/process allocation depending on + ! the problem for Wyvern + CALL REDGET(INDIC,NMPI,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SNT: INTEGER DATA EXPECTED(16).') + IF(NMPI.LE.0) CALL XABORT('SNT: POSITIVE INTEGER EXPECTED.') + ELSE IF(TEXT4.EQ.'NSHT') THEN + LSHOOT=.FALSE. + ELSE IF(TEXT4.EQ.'BTE') THEN + ! Boltzmann transport equation + IBFP=0 + ELSE IF(TEXT4.EQ.'BFPG') THEN + ! Boltzmann Fokker-Planck equation with Galerkin energy + ! propagation factors + IBFP=1 + ELSE IF(TEXT4.EQ.'BFPL') THEN + ! Boltzmann Fokker-Planck equation with Przybylski and Ligou + ! energy propagation factors + IBFP=2 + ELSE IF(TEXT4.EQ.'FOUR') THEN + ! Perform Fourier Analysis + CALL REDGET(INDIC,NFOU,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SNT: INTEGER DATA EXPECTED(17).') + ELSE IF(TEXT4.EQ.'GQ') THEN + ! Galerkin quadrature + CALL REDGET(INDIC,IGLK,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SNT: INTEGER DATA EXPECTED(14).') + ELSE IF(TEXT4.EQ.';') THEN + GO TO 30 + ELSE + CALL XABORT('SNT: '//TEXT4//' IS AN INVALID KEY WORD.') + ENDIF + GO TO 15 +* + 30 IF(TITLE.NE.' ') CALL LCMPTC(IPTRK,'TITLE',72,TITLE) + TEXT12=HENTRY(2) + CALL LCMPTC(IPTRK,'LINK.GEOM',12,TEXT12) + IF(IMPX.GT.1) WRITE(IOUT,100) TITLE +* + IF(MAXPTS.EQ.0) CALL XABORT('SNT: MAXPTS NOT DEFINED.') + IF(IGLK.EQ.0) ISCAT=MIN(ISCAT,NLF) + CALL SNTRK(MAXPTS,IPTRK,IPGEOM,IMPX,ISCHM,IELEM,ISPLH,INSB, + 1 NLF,MAXIT,EPSI,ISCAT,IQUAD,LFIXUP,LIVO,ICL1,ICL2,LDSA,NSTART, + 2 NSDSA,IELEMSA,ISOLVSA,LBIHET,LSHOOT,IBFP,MCELL,NMPI,NFOU, + 3 EELEM,ESCHM,IGLK) +* + IF(IMPX.GT.1) THEN + CALL LCMGET(IPTRK,'STATE-VECTOR',IGP) + WRITE(IOUT,110) (IGP(I),I=1,15) + WRITE(IOUT,120) (IGP(I),I=16,31),IGP(35),IGP(36),IGP(37), + 1 IGP(40),EPSI + ENDIF +*---- +* PROCESS DOUBLE HETEROGENEITY (BIHET) DATA (IF AVAILABLE) +*---- + IF(LBIHET) CALL XDRTBH(IPGEOM,IPTRK,IQUA10,IBIHET,IMPX,FRTM) + RETURN +* + 100 FORMAT(1H1,19H SSSSS NN NN ,95(1H*)/ + 1 20H SSSSSSS NNN NN ,57(1H*), + 2 38H MULTIGROUP VERSION. A. HEBERT (2005)/ + 3 19H SS SS NNNN NN/19H SS NN NN NN/ + 4 19H SS NN NN NN/19H SS SS NN NN NN/ + 5 19H SSSSSSS NN NNNN/19H SSSSS NN NNN//1X,A72//) + 110 FORMAT(/14H STATE VECTOR:/ + 1 7H NREG ,I8,22H (NUMBER OF REGIONS)/ + 2 7H NUN ,I8,23H (NUMBER OF UNKNOWNS)/ + 3 7H ILK ,I8,39H (0=LEAKAGE PRESENT/1=LEAKAGE ABSENT)/ + 4 7H NBMIX ,I8,36H (MAXIMUM NUMBER OF MIXTURES USED)/ + 5 7H NSURF ,I8,29H (NUMBER OF OUTER SURFACES)/ + 6 7H ITYPE ,I8,21H (TYPE OF GEOMETRY)/ + 7 7H NFUNL ,I8,45H (NUMBER OF SPHERICAL HARMONICS COMPONENTS)/ + 8 7H IELEM ,I8,46H (ORDER OF POLYNOMIAL USED IN SPATIAL APPROX, + 9 38H./1=CONSTANT/2=LINEAR/3=PARABOLIC/...)/ + 1 7H NDIM ,I8,35H (NUMBER OF GEOMETRIC DIMENSIONS)/ + 2 7H ISCHM ,I8,46H (METHOD OF SPATIAL DISCRETISATION/1=HODD/2=, + 3 9HDG/3=AWD)/ + 3 7H LL4 ,I8,36H (ORDER OF THE MATRICES PER GROUP)/ + 4 7H LX ,I8,38H (NUMBER OF MESHES ALONG THE X AXIS)/ + 5 7H LY ,I8,38H (NUMBER OF MESHES ALONG THE Y AXIS)/ + 6 7H LZ ,I8,38H (NUMBER OF MESHES ALONG THE Z AXIS)/ + 7 7H NLF ,I8,13H (SN ORDER)) + 120 FORMAT( + 1 7H ISCAT ,I8,47H (1=ISOTROPIC SOURCE/2=LINEARLY ANISOTROPIC S, + 2 6HOURCE)/ + 3 7H IQUAD ,I8,47H (<4=LEVEL-SYMMETRIC OF TYPE IQUAD/4=LEGENDRE, + 4 58H-CHEBYSHEV/5=SYMMETRIC LEGENDRE-CHEBYSHEV/6=QR/>9=PRODUCT)/ + 5 7H IFIX ,I8,29H (0/1: NEGATIVE FLUX FIXUP)/ + 6 7H IDSA ,I8,32H (0/1: SYNTHETIC ACCELERATION)/ + 7 7H NSTART,I8,32H (NUMBER OF RESTARTS IN GMRES)/ + 8 7H NSDSA ,I8,45H (NUMBER OF ITERATIONS BEFORE ENABLING DSA)/ + 9 7H MAXIT ,I8,39H (MAXIMUM NUMBER OF INNER ITERATIONS)/ + 1 7H LIVO ,I8,38H (0/1: LIVOLANT ACCELERATION OFF/ON)/ + 2 7H ICL1 ,I8,39H (NUMBER OF FREE ITERATIONS IN LIVO.)/ + 3 7H ICL2 ,I8,46H (NUMBER OF ACCELERATED ITERATIONS IN LIVO.)/ + 4 7H ISPLH ,I8,46H (DEGREE OF LOZENGE SPLITTING FOR HEXAGONAL , + 5 9HGEOMETRY)/ + 6 7H INSB ,I8,36H (0/1: GROUP VECTORIZATION OFF/ON)/ + 7 7H MCELL ,I8,37H (0/>0: KBA WAVEFRONT SWEEP OFF/ON)/ + 8 7H IGAV ,I8,45H (CONDITION AT AXIAL AXIS FOR CYL./SPH. 1D)/ + 9 7H LSHOOT,I8,38H (0/1: SHOOTING METHOD IN 1D OFF/ON)/ + 1 7H IBFP ,I8,43H (0/1/2: BFP SOLUTION OFF/GALERKIN/LIGOU)/ + 2 7H EELEM ,I8,45H (ORDER OF POLYNOMIAL USED IN ENERGY APPROX, + 3 38H./1=CONSTANT/2=LINEAR/3=PARABOLIC/...)/ + 4 7H ESCHM ,I8,45H (METHOD OF ENERGY DISCRETISATION/1=HODD/2=, + 5 9HDG/3=AWD)/ + 6 7H IGLK ,I8,42H (0=CLASSICAL SN/>0=GALERKIN QUADRATURE)/ + 7 7H IBIHET,I8,47H (0/1: DOUBLE HETEROGENEITY IS NOT/IS ACTIVE)/ + 8 7H EPSI ,E11.1,45H (CONVERGENCE CRITERION ON INNER ITERATIONS)) + END diff --git a/Dragon/src/SNT1DC.f b/Dragon/src/SNT1DC.f new file mode 100644 index 0000000..702c067 --- /dev/null +++ b/Dragon/src/SNT1DC.f @@ -0,0 +1,184 @@ +*DECK SNT1DC + SUBROUTINE SNT1DC (IMPX,LX,NCODE,ZCODE,XXX,NLF,NPQ,NSCT,IQUAD, + 1 JOP,U,W,TPQ,UPQ,VPQ,WPQ,ALPHA,PLZ,PL,VOL,IDL,SURF,IL,IM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Numbering corresponding to a 1-D cylindrical geometry with discrete +* ordinates approximation of the flux. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IMPX print parameter. +* LX number of elements along the R axis. +* NCODE type of boundary condition applied on each side +* (i=1 R-; i=2 R+): +* =1 VOID; =2 REFL; =7 ZERO. +* ZCODE ZCODE(I) is the albedo corresponding to boundary condition +* 'VOID' on each side (ZCODE(I)=0.0 by default). +* XXX coordinates along the R axis. +* NLF order of the SN approximation (even number). +* NPQ number of SN directions in two octants. +* NSCT maximum number of spherical harmonics moments of the flux. +* IQUAD type of SN quadrature (1 Level symmetric, type IQUAD; +* 4 Gauss-Legendre and Gauss-Chebyshev; 10 product). +* +*Parameters: output +* JOP number of base points per axial level in one octant. +* U base points in $\\xi$ of the axial quadrature. Used with +* zero-weight points. +* W weights for the quadrature in $\\mu$. +* TPQ base points in $\\xi$ of the 2D SN quadrature. +* UPQ base points in $\\mu$ of the 2D SN quadrature. +* VPQ base points in $\\eta$ of the 2D SN quadrature. +* WPQ weights of the 2D SN quadrature. +* ALPHA angular redistribution terms. +* PLZ discrete values of the spherical harmonics corresponding +* to the 1D quadrature. Used with zero-weight points. +* PL discrete values of the spherical harmonics corresponding +* to the 2D SN quadrature. +* VOL volume of each element. +* IDL position of integrated fluxes into unknown vector. +* SURF surfaces. +* IL indexes (l) of each spherical harmonics in the +* interpolation basis. +* IM indexes (m) of each spherical harmonics in the +* interpolation basis. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IMPX,LX,NCODE(2),NLF,NPQ,NSCT,IQUAD,JOP(NLF/2),IDL(LX), + 1 IL(NSCT),IM(NSCT) + REAL ZCODE(2),XXX(LX+1),U(NLF/2),W(NLF/2),PLZ(NSCT,NLF/2), + 1 PL(NSCT,NPQ),TPQ(NPQ),UPQ(NPQ),VPQ(NPQ),WPQ(NPQ),ALPHA(NPQ), + 2 VOL(LX),SURF(LX+1) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(PI=3.141592654) + REAL, ALLOCATABLE, DIMENSION(:) :: TPQ2,UPQ2,VPQ2,WPQ2 +*---- +* GENERATE QUADRATURE BASE POINTS AND CORRESPONDING WEIGHTS. +*---- + IF(MOD(NLF,2).EQ.1) CALL XABORT('SNT1DC: EVEN NLF EXPECTED.') + M2=NLF/2 + ALLOCATE(TPQ2(NPQ/2),UPQ2(NPQ/2),VPQ2(NPQ/2),WPQ2(NPQ/2)) + IF(IQUAD.EQ.1) THEN + CALL SNQU01(NLF,JOP,U,W,TPQ2,UPQ2,VPQ2,WPQ2) + ELSE IF(IQUAD.EQ.2) THEN + CALL SNQU02(NLF,JOP,U,W,TPQ2,UPQ2,VPQ2,WPQ2) + ELSE IF(IQUAD.EQ.3) THEN + CALL SNQU03(NLF,JOP,U,W,TPQ2,UPQ2,VPQ2,WPQ2) + ELSE IF(IQUAD.EQ.4) THEN + CALL SNQU04(NLF,JOP,U,W,TPQ2,UPQ2,VPQ2,WPQ2) + ELSE IF(IQUAD.EQ.10) THEN + CALL SNQU10(NLF,JOP,U,W,TPQ2,UPQ2,VPQ2,WPQ2) + ELSE + CALL XABORT('SNT1DC: UNKNOWN QUADRATURE TYPE.') + ENDIF + IPQ=0 + IPR=0 + WSUM=0.0 + DO IP=1,M2 + DO IQ=1,JOP(IP) + IPQ=IPQ+1 + IPR=IPR+1 + TPQ(IPQ)=TPQ2(IPR) + UPQ(IPQ)=UPQ2(IPR) + VPQ(IPQ)=VPQ2(IPR) + WPQ(IPQ)=WPQ2(IPR) + WSUM=WSUM+WPQ(IPQ) + ENDDO + DO IQ=JOP(IP)+1,2*JOP(IP) + IPQ=IPQ+1 + JQ=IQ-(JOP(IP)+1)+1 + JPQ=IPQ-2*JQ+1 + TPQ(IPQ)=TPQ(JPQ) + UPQ(IPQ)=-UPQ(JPQ) + VPQ(IPQ)=VPQ(JPQ) + WPQ(IPQ)=WPQ(JPQ) + WSUM=WSUM+WPQ(IPQ) + ENDDO + ENDDO + DEALLOCATE(WPQ2,VPQ2,UPQ2,TPQ2) + IF(IPQ.NE.NPQ) CALL XABORT('SNT1DC: BAD VALUE ON NPQ.') +*---- +* COMPUTE ALPHA. +*---- + IPQ=0 + DO IP=1,M2 + SUMETA=0.0 + DO IQ=1,2*JOP(IP) + IPQ=IPQ+1 + ALPHA(IPQ)=SUMETA + SUMETA=SUMETA+WPQ(IPQ)*UPQ(IPQ) + ENDDO + ENDDO +*---- +* PRINT COSINES AND WEIGHTS. +*---- + IF(IMPX.GT.1) THEN + WRITE(6,'(/20H SNT1DC: WEIGHT SUM=,1P,E11.4)') WSUM + WRITE(6,60) (U(N),N=1,M2) + 60 FORMAT(//,1X,'THE POSITIVE QUADRATURE COSINES FOLLOW'// + 1 (1X,5E14.6)) + WRITE(6,70) (W(N),N=1,M2) + 70 FORMAT(//,1X,'THE CORRESPONDING QUADRATURE WEIGHTS FOLLOW'// + 1 (1X,5E14.6)) + WRITE(6,74) (UPQ(N),N=1,NPQ) + 74 FORMAT(//,1X,'THE BASE POINTS (MU) FOLLOW'//(1X,5E14.6)) + WRITE(6,75) (WPQ(N),N=1,NPQ) + 75 FORMAT(//,1X,'THE WEIGHTS FOLLOW'//(1X,5E14.6)) + WRITE(6,76) (ALPHA(N),N=1,NPQ) + 76 FORMAT(//,1X,'THE ALPHAS FOLLOW'//(1X,5E14.6)) + ENDIF +*---- +* GENERATE SPHERICAL HARMONICS FOR SCATTERING SOURCE. +*---- + IOF=0 + IL(:NSCT)=0 + IM(:NSCT)=0 + DO 130 L=0,NLF-1 + DO 120 M=0,L + IF(MOD(L+M,2).EQ.1) GO TO 120 + IOF=IOF+1 + IL(IOF)=L + IM(IOF)=M + IF(IOF.GT.NSCT) GO TO 140 + DO 100 N=1,M2 + PLZ(IOF,N)=PNSH(L,M,U(N),-SQRT(1.0-U(N)*U(N)),0.0) + 100 CONTINUE + DO 110 N=1,NPQ + PL(IOF,N)=PNSH(L,M,TPQ(N),UPQ(N),VPQ(N)) + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE +*---- +* COMPUTE SURFACES AND VOLUMES. +*---- + 140 DO 150 I=1,LX+1 + SURF(I)=2.0*PI*XXX(I) + 150 CONTINUE + DO 160 I=1,LX + IDL(I)=(I-1)*NSCT+1 + VOL(I)=PI*(XXX(I+1)*XXX(I+1)-XXX(I)*XXX(I)) + 160 CONTINUE +*---- +* SET BOUNDARY CONDITIONS. +*---- + IF(NCODE(2).EQ.2) ZCODE(2)=1.0 +* + RETURN + END diff --git a/Dragon/src/SNT1DP.f b/Dragon/src/SNT1DP.f new file mode 100644 index 0000000..a154558 --- /dev/null +++ b/Dragon/src/SNT1DP.f @@ -0,0 +1,241 @@ +*DECK SNT1DP + SUBROUTINE SNT1DP (IMPX,LX,IELEM,NCODE,ZCODE,XXX,NLF,NSCT,U,W,PL, + 1 VOL,IDL,LL4,NUN,LSHOOT,EELEM,WX,WE,CST,IBFP,ISCHM,ESCHM,IGLK,MN, + 2 DN,IL,IM,IQUAD) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Numbering corresponding to a 1-D slab geometry with discrete +* ordinates approximation of the flux. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert and C. Bienvenue +* +*Parameters: input +* IMPX print parameter. +* LX number of elements along the X axis. +* IELEM measure of order of the spatial approximation polynomial: +* =1 constant - default for HODD; +* =2 linear - default for DG; +* >3 higher orders. +* NCODE type of boundary condition applied on each side +* (i=1 X-; i=2 X+): +* =1 VOID; =2 REFL; =7 ZERO. +* ZCODE ZCODE(I) is the albedo corresponding to boundary condition +* 'VOID' on each side (ZCODE(I)=0.0 by default). +* XXX coordinates along the R axis. +* NLF number of $\\mu$ levels. +* NSCT maximum number of Legendre components in the flux. +* LSHOOT enablig flag for the shooting method. +* EELEM measure of order of the energy approximation polynomial: +* =1 constant - default for HODD; +* =2 linear - default for DG; +* >3 higher orders. +* IBFP type of energy proparation relation: +* =0 no Fokker-Planck term; +* =1 Galerkin type; +* =2 heuristic Przybylski and Ligou type. +* ISCHM method of spatial discretisation: +* =1 High-Order Diamond Differencing (HODD) - default; +* =2 Discontinuous Galerkin finite element method (DG); +* =3 Adaptive weighted method (AWD). +* ESCHM method of energy discretisation: +* =1 High-Order Diamond Differencing (HODD) - default; +* =2 Discontinuous Galerkin finite element method (DG); +* =3 Adaptive weighted method (AWD). +* IGLK angular interpolation type: +* =0 classical SN method. +* =1 Galerkin quadrature method (M = inv(D)) +* =2 Galerkin quadrature method (D = inv(M)) +* IQUAD quadrature type: +* =1 Gauss-Lobatto; +* =2 Gauss-Legendre. +* +*Parameters: output +* U base points in $\\mu$ of the 1D quadrature. +* W weights for the quadrature in $\\mu$. +* PL discrete values of the Legendre polynomials corresponding +* to the SN quadrature. +* VOL volume of each element. +* IDL position of integrated fluxes into unknown vector. +* LL4 number of unknowns being solved for, over the domain. This +* includes the various moments of the isotropic (and if present, +* anisotropic) flux. +* NUN total number of unknowns stored in the FLUX vector per group. +* This includes LL4 (see above) as well as any surface boundary +* fluxes, if present. +* WX spatial closure relation weighting factors. +* WE energy closure relation weighting factors. +* CST constants for the polynomial approximations. +* MN moment-to-discrete matrix. +* DN discrete-to-moment matrix. +* IL indexes (l) of each spherical harmonics in the +* interpolation basis. +* IM indexes (m) of each spherical harmonics in the +* interpolation basis. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IMPX,LX,IELEM,NCODE(2),NLF,NSCT,IDL(LX),LL4,NUN,EELEM, + 1 IBFP,ISCHM,ESCHM,IL(NSCT),IM(NSCT),IQUAD,IGLK + REAL ZCODE(2),XXX(LX+1),U(NLF),W(NLF),VOL(LX),WX(IELEM+1), + 1 WE(EELEM+1),CST(MAX(IELEM,EELEM)),PX,PE,MN(NLF,NSCT), + 2 DN(NSCT,NLF),PL(NSCT,NLF) + LOGICAL LSHOOT +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION MND(NLF,NSCT) +*---- +* GENERATE QUADRATURE BASE POINTS AND CORRESPONDING WEIGHTS. +*---- + IF(MOD(NLF,2).EQ.1) CALL XABORT('SNT1DP: EVEN NLF EXPECTED.') + IF(IQUAD.EQ.1) THEN + CALL SNQU07(NLF,U,W) ! GAUSS-LOBATTO + ELSEIF(IQUAD.EQ.2) THEN + CALL ALGPT(NLF,-1.0,1.0,U,W) ! GAUSS-LEGENDRE + ELSE + CALL XABORT('SNT1DP: UNKNOWN QUADRATURE TYPE.') + ENDIF +*---- +* PRINT COSINES AND WEIGHTS. +*---- + IF(IMPX.GT.1) THEN + WRITE(6,60) (U(M),M=1,NLF) + 60 FORMAT(//,1X,'THE QUADRATURE COSINES FOLLOW'// + 1 (1X,5E14.6)) + WRITE(6,70) (W(M),M=1,NLF) + 70 FORMAT(//,1X,'THE CORRESPONDING QUADRATURE WEIGHTS FOLLOW'// + 1 (1X,5E14.6)) + ENDIF +*---- +* GENERATE LEGENDRE POLYNOMIALS FOR SCATTERING SOURCE. +*---- + DO 145 M=1,NLF + PL(1,M)=1.0 + IF(NSCT.GT.1) THEN + PL(2,M)=U(M) + DO 140 L=2,NSCT-1 + PL(L+1,M)=((2.0*L-1.0)*U(M)*PL(L,M)-(L-1)*PL(L-1,M))/L + 140 CONTINUE + ENDIF + 145 CONTINUE +*---- +* GENERATE MAPPING MATRIX FOR GALERKIN QUADRATURE METHOD +*---- + MN(:NLF,:NSCT)=0.0D0 + DN(:NSCT,:NLF)=0.0D0 + IL(:NSCT)=0 + IM(:NSCT)=0 + IF(IGLK.EQ.1) THEN + DO L=0,NSCT-1 + IL(L+1)=L + DO N=1,NLF + DN(L+1,N)=W(N)*PL(L+1,N) + ENDDO + ENDDO + MND=DN + CALL ALINVD(NLF,MND,NLF,IER) + IF(IER.NE.0) CALL XABORT('SNT1DP: SINGULAR MATRIX.') + MN = REAL(MND) + ELSEIF(IGLK.EQ.2) THEN + DO L=0,NSCT-1 + IL(L+1)=L + DO N=1,NLF + MN(N,L+1)=(2.0*L+1.0)/2.0*PL(L+1,N) + ENDDO + ENDDO + MND=MN + CALL ALINVD(NLF,MND,NLF,IER) + IF(IER.NE.0) CALL XABORT('SNT1DP: SINGULAR MATRIX.') + DN = REAL(MND) + ELSE + DO L=0,NSCT-1 + IL(L+1)=L + DO N=1,NLF + DN(L+1,N)=W(N)*PL(L+1,N) + MN(N,L+1)=(2.0*L+1.0)/2.0*PL(L+1,N) + ENDDO + ENDDO + ENDIF +*---- +* GENERATE THE WEIGHTING PARAMETERS OF THE CLOSURE RELATION. +*---- + PX=1 + PE=1 + IF(ISCHM.EQ.1.OR.ISCHM.EQ.3) THEN + PX=1 + ELSEIF(ISCHM.EQ.2) THEN + PX=0 + ELSE + CALL XABORT('SNT1DP: UNKNOWN TYPE OF SPATIAL CLOSURE RELATION.') + ENDIF + IF(MOD(IELEM,2).EQ.1) THEN + WX(1)=-PX + WX(2:IELEM+1:2)=1+PX + IF(IELEM.GE.2) WX(3:IELEM+1:2)=1-PX + ELSE + WX(1)=PX + WX(2:IELEM+1:2)=1-PX + IF(IELEM.GE.2) WX(3:IELEM+1:2)=1+PX + ENDIF + IF(IBFP.NE.0) THEN + IF(ESCHM.EQ.1.OR.ESCHM.EQ.3) THEN + PE=1 + ELSEIF(ESCHM.EQ.2) THEN + PE=0 + ELSE + CALL XABORT('SNT1DP: UNKNOWN TYPE OF ENERGY CLOSURE RELATION.') + ENDIF + IF(MOD(EELEM,2).EQ.1) THEN + WE(1)=-PE + WE(2:EELEM+1:2)=1+PE + IF(EELEM.GE.2) WE(3:EELEM+1:2)=1-PE + ELSE + WE(1)=PE + WE(2:EELEM+1:2)=1-PE + IF(EELEM.GE.2) WE(3:EELEM+1:2)=1+PE + ENDIF + ENDIF + ! NORMALIZED LEGENDRE POLYNOMIAL CONSTANTS + DO IEL=1,MAX(IELEM,EELEM) + CST(IEL)=SQRT(2.0*IEL-1.0) + ENDDO +*---- +* COMPUTE VOLUMES, ISOTROPIC FLUX INDICES and UNKNOWNS. +*---- + NM=IELEM*EELEM + NMX=EELEM + LL4=LX*NSCT*NM + NUN=LL4 + DO I=1,LX + IDL(I)=(I-1)*NSCT*NM+1 + VOL(I)=XXX(I+1)-XXX(I) + ENDDO + IF(.NOT.LSHOOT) NUN=NUN+NMX*NLF +*---- +* SET BOUNDARY CONDITIONS. +*---- + IF(NCODE(1).EQ.2) ZCODE(1)=1.0 + IF(NCODE(2).EQ.2) ZCODE(2)=1.0 + IF((NCODE(1).EQ.4).OR.(NCODE(2).EQ.4)) THEN + IF((NCODE(1).NE.4).OR.(NCODE(2).NE.4)) CALL XABORT('SNT1DP: ' + 1 //'INVALID TRANSLATION BOUNDARY CONDITIONS.') + ZCODE(1)=1.0 + ZCODE(2)=1.0 + ENDIF + IF((ZCODE(1).EQ.0.0).AND.(ZCODE(2).NE.0.0)) CALL XABORT('SNT1DP:' + 1 //' CANNOT SUPPORT LEFT VACUUM BC IF RIGHT BC IS NOT VACUUM.') +* + RETURN + END diff --git a/Dragon/src/SNT1DS.f b/Dragon/src/SNT1DS.f new file mode 100644 index 0000000..e446c78 --- /dev/null +++ b/Dragon/src/SNT1DS.f @@ -0,0 +1,135 @@ +*DECK SNT1DS + SUBROUTINE SNT1DS (IMPX,LX,NCODE,ZCODE,XXX,NLF,NSCT,U,W,ALPHA, + 1 PLZ,PL,VOL,IDL,SURF,IQUAD,IL,IM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Numbering corresponding to a 1-D spherical geometry with discrete +* ordinates approximation of the flux. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IMPX print parameter. +* LX number of elements along the R axis. +* NCODE type of boundary condition applied on each side +* (i=1 R-; i=2 R+): +* =1 VOID; =2 REFL; =7 ZERO. +* ZCODE ZCODE(I) is the albedo corresponding to boundary condition +* 'VOID' on each side (ZCODE(I)=0.0 by default). +* XXX coordinates along the R axis. +* NLF order of the SN approximation (even number). +* NSCT maximum number of spherical harmonics moments of the flux. +* IQUAD quadrature type: +* =1 Gauss-Lobatto; +* =2 Gauss-Legendre. +* +*Parameters: output +* U base points in $\\xi$ of the axial quadrature. +* W weights for the quadrature in $\\mu$. +* ALPHA angular redistribution terms. +* PLZ discrete values of the spherical harmonics corresponding +* to the 1D quadrature.Used with zero-weight points. +* PL discrete values of the spherical harmonics corresponding +* to the 2D SN quadrature. +* VOL volume of each element. +* IDL position of integrated fluxes into unknown vector. +* SURF surfaces. +* IL indexes (l) of each spherical harmonics in the +* interpolation basis. +* IM indexes (m) of each spherical harmonics in the +* interpolation basis. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IMPX,LX,NCODE(2),NLF,NSCT,IDL(LX),IQUAD,IL(NSCT),IM(NSCT) + REAL ZCODE(2),XXX(LX+1),U(NLF),W(NLF),PLZ(NSCT),PL(NSCT,NLF), + 1 ALPHA(NLF),VOL(LX),SURF(LX+1) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(PI=3.141592654) +*---- +* GENERATE QUADRATURE BASE POINTS AND CORRESPONDING WEIGHTS. +*---- + IF(MOD(NLF,2).EQ.1) CALL XABORT('SNT1DS: EVEN NLF EXPECTED.') + IF(IQUAD.EQ.1) THEN + CALL SNQU07(NLF,U,W) ! GAUSS-LOBATTO + ELSEIF(IQUAD.EQ.2) THEN + CALL ALGPT(NLF,-1.0,1.0,U,W) ! GAUSS-LEGENDRE + ELSE + CALL XABORT('SNT1DS: UNKNOWN QUADRATURE TYPE.') + ENDIF +*---- +* COMPUTE ALPHA. +*---- + SUMETA=0.0 + DO IP=1,NLF + SUMETA=SUMETA-2.0*W(IP)*U(IP) + ALPHA(IP)=SUMETA + ENDDO +*---- +* PRINT COSINES AND WEIGHTS. +*---- + IF(IMPX.GT.1) THEN + WRITE(6,60) (U(M),M=1,NLF) + 60 FORMAT(//,1X,'THE POSITIVE QUADRATURE COSINES FOLLOW'// + 1 (1X,5E14.6)) + WRITE(6,70) (W(M),M=1,NLF) + 70 FORMAT(//,1X,'THE CORRESPONDING QUADRATURE WEIGHTS FOLLOW'// + 1 (1X,5E14.6)) + WRITE(6,76) (ALPHA(M),M=1,NLF) + 76 FORMAT(//,1X,'THE ALPHAS FOLLOW'//(1X,5E14.6)) + ENDIF +*---- +* GENERATE LEGENDRE POLYNOMIALS FOR SCATTERING SOURCE. +*---- + IL(:NSCT)=0 + IM(:NSCT)=0 + DO 150 M=1,NLF + PL(1,M)=1.0 + IL(1)=0 + IF(NSCT.GT.1) THEN + PL(2,M)=U(M) + IL(2)=1 + DO 140 L=2,NSCT-1 + PL(L+1,M)=((2.0*L-1.0)*U(M)*PL(L,M)-(L-1)*PL(L-1,M))/REAL(L) + IL(L+1)=L + 140 CONTINUE + ENDIF + 150 CONTINUE + PLZ(1)=1.0 + IF(NSCT.GT.1) THEN + PLZ(2)=-1.0 + DO 160 L=2,NSCT-1 + PLZ(L+1)=(-(2.0*L-1.0)*PLZ(L)-(L-1)*PLZ(L-1))/REAL(L) + 160 CONTINUE + ENDIF +*---- +* COMPUTE SURFACES AND VOLUMES. +*---- + DO 200 I=1,LX+1 + SURF(I)=4.0*PI*XXX(I)*XXX(I) + 200 CONTINUE + DO 210 I=1,LX + IDL(I)=(I-1)*NSCT+1 + VOL(I)=4.0*PI*(XXX(I+1)**3-XXX(I)**3)/3.0 + 210 CONTINUE +*---- +* SET BOUNDARY CONDITIONS. +*---- + IF(NCODE(2).EQ.2) ZCODE(2)=1.0 +* + RETURN + END diff --git a/Dragon/src/SNTRK.f b/Dragon/src/SNTRK.f new file mode 100644 index 0000000..effa98c --- /dev/null +++ b/Dragon/src/SNTRK.f @@ -0,0 +1,686 @@ +*DECK SNTRK + SUBROUTINE SNTRK(MAXPTS,IPTRK,IPGEOM,IMPX,ISCHM,IELEM,ISPLH,INSB, + 1 NLF,MAXIT,EPSI,ISCAT,IQUAD,LFIXUP,LIVO,ICL1,ICL2,LDSA,NSTART, + 2 NSDSA,IELEMSA,ISOLVSA,LBIHET,LSHOOT,IBFP,MCELL,NMPI,NFOU, + 3 EELEM,ESCHM,IGLK) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover of the geometry and tracking for SN methods. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert and N. Martin +* +*Parameters: input +* MAXPTS allocated storage for arrays of dimension NEL. +* IPTRK L_TRACK pointer to the tracking information. +* IPGEOM L_GEOM pointer to the geometry. +* IMPX print flag. +* ISCHM method of spatial discretisation: +* =1 High-Order Diamond Differencing (HODD) - default; +* =2 Discontinuous Galerkin finite element method (DG); +* =3 Adaptive weighted method (AWD). +* IELEM measure of order of the spatial approximation polynomial: +* =1 constant - default for HODD; +* =2 linear - default for DG; +* >3 higher orders. +* ISPLH mesh-splitting index for hexagons into lozenges. +* INSB group vectorization flag (=0/1 group vectorization off/on). +* NLF SN order for the flux (even number). +* MAXIT maximum number of inner iterations (default=100). +* EPSI convergence criterion on inner iterations (default=5.E-5). +* ISCAT anisotropy of one-speed sources: +* =1 isotropic sources; +* =2 linearly anisotropic sources. +* IQUAD type of SN quadrature (=1 Level symmetric, type IQUAD; +* =4 Gauss-Legendre and Gauss-Chebyshev; =10 product). +* LFIXUP flag to enable negative flux fixup. +* LIVO flag to enable Livolant acceleration. +* ICL1 Number of free iterations with Livolant acceleration. +* ICL2 Number of accelerated iterations with Livolant acceleration. +* LDSA flag to enable diffusion synthetic acceleration. +* NSTART restarts the GMRES method every NSTART iterations. +* NSDSA number of inner flux iterations before enabling SA. +* IELEMSA degree of the Lagrangian finite elements for the SA: +* <0 order -IELEMSA primal finite elements; +* >0 order IELEMSA dual finite elements. +* ISOLVSA type of solver to be used for the SA: +* 1 - BIVAC ; +* 2 - TRIVAC. +* LBIHET flag to enable the double-heterogeneity model. +* LSHOOT enablig flag for the shooting method. +* IBFP type of energy proparation relation: +* =0 no Fokker-Planck term; +* =1 Galerkin type; +* =2 heuristic Przybylski and Ligou type. +* MCELL number of macrocells along each axis (in Cartesian geometry) +* for the parallelisation using the OpenMP paradigm; OR +* number of macrocells along the z-axis (in hexagonal geometry) +* for the parallelisation using the OpenMP paradigm. +* NMPI number of macrocells along each axis (in Cartesian geometry) +* or along the z-axis for the hexagonal geometry for the +* parallelisation using the MPI paradigm, when using WYVERN. +* NFOU number of Fourier frequencies in the range (2*pi/L) to be +* investigated. +* ESCHM method of energy discretisation: +* =1 High-Order Diamond Differencing (HODD) - default; +* =2 Discontinuous Galerkin finite element method (DG); +* =3 Adaptive weighted method (AWD). +* EELEM measure of order of the energy approximation polynomial: +* =1 constant - default for HODD; +* =2 linear - default for DG; +* >3 higher orders. +* IGLK angular interpolation type: +* =0 classical SN method. +* =1 Galerkin quadrature method (M = inv(D)) +* =2 Galerkin quadrature method (D = inv(M)) +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPGEOM + INTEGER MAXPTS,IMPX,ISCHM,IELEM,ISPLH,INSB,NLF,ISCAT,IQUAD, + 1 MAXIT,ICL1,ICL2,NSTART,NSDSA,IELEMSA,ISOLVSA,MCELL,NMPI,NFOU, + 2 EELEM,ESCHM,IGLK + REAL EPSI + LOGICAL LFIXUP,LDSA,LBIHET,LIVO,LSHOOT +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + LOGICAL ILK + CHARACTER HSMG*131 + INTEGER ISTATE(NSTATE),IGP(NSTATE),NCODE(6),ICODE(6),LOZSWP(3,6),P + REAL ZCODE(6) + INTEGER, ALLOCATABLE, DIMENSION(:) :: MAT,IDL,ISPLX,ISPLY,ISPLZ, + 1 JOP,MRMX,MRMY,MRMZ,IL,IM + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: COORDMAP + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: KEYANI + REAL, ALLOCATABLE, DIMENSION(:) :: VOL,XXX,YYY,ZZZ,UU,WW,PL,TPQ, + 1 UPQ,VPQ,WPQ,ALPHA,PLZ,SURF,DU,DE,DZ,DC,DB,DA,DAL,WX,WE,CST,MN,DN +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(MAT(MAXPTS),VOL(MAXPTS),IDL(MAXPTS)) +* + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) + ITYPE=ISTATE(1) + ISUB2=ISTATE(9) +*---- +* PARAMETER VALIDATION. +*---- + IF(ISUB2.NE.0) CALL XABORT('SNTRK: DISCRETIZATION NOT AVAILABLE + 1 .(1)') + IF((ISCHM.NE.1).AND.(ISCHM.NE.2).AND.(ISCHM.NE.3)) THEN + CALL XABORT('SNTRK: SPATIAL DISCRETIZATION SCHEME NOT AVAILABLE + 1. ONLY VALUES OF 1 (=DIAMOND-DIFFERENCE) OR 2 (=DISCONTINUOUS GALE + 2RKIN) OR 3 (=ADAPTIVE WEIGHTED DIFFERENCE) ARE ALLOWED.') + ENDIF + IF((ESCHM.NE.1).AND.(ESCHM.NE.2).AND.(ESCHM.NE.3)) THEN + CALL XABORT('SNTRK: ENERGY DISCRETIZATION SCHEME NOT AVAILABLE + 1. ONLY VALUES OF 1 (=DIAMOND-DIFFERENCE) OR 2 (=DISCONTINUOUS GALE + 2RKIN) OR 3 (=ADAPTIVE WEIGHTED DIFFERENCE) ARE ALLOWED.') + ENDIF + IF(ISCHM.EQ.3.OR.ESCHM.EQ.3) THEN + IF(.NOT.(ITYPE.EQ.2.OR.ITYPE.EQ.5.OR.ITYPE.EQ.7)) THEN + CALL XABORT('SNTRK: ADAPTIVE SCHEME ONLY AVAILABLE IN CARTESIAN' + 1 //' GEOMETRIES') + ELSEIF(IELEM.GT.1.AND.ISCHM.EQ.3.OR. + 1 EELEM.GT.1.AND.ESCHM.EQ.3) THEN + CALL XABORT('SNTRK: ADAPTIVE SCHEMES ONLY AVAILABLE FOR CONSTANT' + 1 //' ORDER CLOSURE RELATION.') + ENDIF + ENDIF + IF((ITYPE.NE.2).AND.(ITYPE.NE.3).AND.(ITYPE.NE.4).AND. + 1 (ITYPE.NE.5).AND.(ITYPE.NE.6).AND.(ITYPE.NE.7).AND. + 2 (ITYPE.NE.8).AND.(ITYPE.NE.9)) THEN + CALL XABORT('SNTRK: DISCRETIZATION NOT AVAILABLE.(2)') + ENDIF + IF((LDSA).AND.(ISOLVSA.EQ.1))THEN + IF((ITYPE.EQ.7).OR.(ITYPE.EQ.9)) + > CALL XABORT('SNTRK: SYNTHETIC ACCELERATION WITH BIVAC NOT AV + 1AILABLE IN 3D.') + ENDIF +* + ALLOCATE(XXX(MAXPTS+1),YYY(MAXPTS+1),ZZZ(MAXPTS+1)) + ALLOCATE(ISPLX(MAXPTS),ISPLY(MAXPTS),ISPLZ(MAXPTS)) + CALL READ3D(MAXPTS,MAXPTS,MAXPTS,MAXPTS,IPGEOM,IHEX,IR,ILK,SIDE, + 1 XXX,YYY,ZZZ,IMPX,LX,LY,LZ,MAT,NEL,NCODE,ICODE,ZCODE,ISPLX,ISPLY, + 2 ISPLZ,ISPLTH,ISPLTL) + DEALLOCATE(ISPLZ,ISPLY,ISPLX) +* + IF(LX*LY*LZ.GT.MAXPTS) THEN + WRITE (HSMG,'(38HSNTRK: MAXPTS SHOULD BE INCREASED FROM,I7, + 1 3H TO,I7)') MAXPTS,LX*LY*LZ + CALL XABORT(HSMG) + ENDIF + IF((ITYPE.EQ.2).OR.(ITYPE.EQ.3)) THEN + ! 1-D AND 2-D CYLINDRICAL CASES. + NCODE(3)=2 + NCODE(4)=5 + ZCODE(3)=1.0 + ZCODE(4)=1.0 + YYY(1)=0.0 + YYY(2)=2.0 + ELSE IF(ITYPE.EQ.6) THEN + LY=LZ + DO I=1,LZ+1 + YYY(I)=ZZZ(I) + ENDDO + NCODE(3)=NCODE(5) + NCODE(4)=NCODE(6) + ZCODE(3)=ZCODE(5) + ZCODE(4)=ZCODE(6) + ICODE(3)=ICODE(5) + ICODE(4)=ICODE(6) + ENDIF + + IF(IBFP.EQ.0) EELEM=1 + +*---- +* UNFOLD THE DOMAIN IN DIAGONAL SYMMETRY CASES. +*---- + IF(ITYPE.EQ.7) THEN + ! CARTESIAN 3D CASE + IDIAG=0 + IF((NCODE(2).EQ.3).AND.(NCODE(3).EQ.3)) THEN + IDIAG=1 + NCODE(3)=NCODE(1) + NCODE(2)=NCODE(4) + ZCODE(3)=ZCODE(1) + ZCODE(2)=ZCODE(4) + ICODE(3)=ICODE(1) + ICODE(2)=ICODE(4) + K=NEL + DO IZ=LZ,1,-1 + IOFF=(IZ-1)*LX*LY + DO IY=LY,1,-1 + DO IX=LX,IY+1,-1 + MAT(IOFF+(IY-1)*LX+IX)=MAT(IOFF+(IX-1)*LY+IY) + ENDDO + DO IX=IY,1,-1 + MAT(IOFF+(IY-1)*LX+IX)=MAT(K) + K=K-1 + ENDDO + ENDDO + ENDDO + NEL=LX*LY*LZ + IF(K.NE.0) THEN + CALL XABORT('SNTRK: UNABLE TO UNFOLD THE DOMAIN.') + ENDIF + ELSE IF((NCODE(1).EQ.3).AND.(NCODE(4).EQ.3)) THEN + IDIAG=1 + NCODE(1)=NCODE(3) + NCODE(4)=NCODE(2) + ZCODE(1)=ZCODE(3) + ZCODE(4)=ZCODE(2) + ICODE(1)=ICODE(3) + ICODE(4)=ICODE(2) + K=NEL + DO IZ=LZ,1,-1 + IOFF=(IZ-1)*LX*LY + DO IY=LY,1,-1 + DO IX=LX,IY,-1 + MAT(IOFF+(IY-1)*LX+IX)=MAT(K) + K=K-1 + ENDDO + ENDDO + ENDDO + DO IZ=1,LZ + IOFF=(IZ-1)*LX*LY + DO IY=1,LY + DO IX=1,IY-1 + MAT(IOFF+(IY-1)*LX+IX)=MAT(IOFF+(IX-1)*LY+IY) + ENDDO + ENDDO + ENDDO + NEL=LX*LY*LZ + IF(K.NE.0) THEN + CALL XABORT('SNTRK: UNABLE TO UNFOLD THE DOMAIN.') + ENDIF + ENDIF + + ELSE + ! OTHER CASES + IF((NCODE(2).EQ.3).AND.(NCODE(3).EQ.3)) THEN + NCODE(3)=NCODE(1) + NCODE(2)=NCODE(4) + ZCODE(3)=ZCODE(1) + ZCODE(2)=ZCODE(4) + ICODE(3)=ICODE(1) + ICODE(2)=ICODE(4) + K=LX*(LX+1)/2 + DO IY=LY,1,-1 + DO IX=LX,IY+1,-1 + MAT((IY-1)*LX+IX)=MAT((IX-1)*LY+IY) + ENDDO + DO IX=IY,1,-1 + MAT((IY-1)*LX+IX)=MAT(K) + K=K-1 + ENDDO + ENDDO + NEL=LX*LY + IF(K.NE.0) THEN + CALL XABORT('SNTRK: UNABLE TO UNFOLD THE DOMAIN.') + ENDIF + ELSE IF((NCODE(1).EQ.3).AND.(NCODE(4).EQ.3)) THEN + NCODE(1)=NCODE(3) + NCODE(4)=NCODE(2) + ZCODE(1)=ZCODE(3) + ZCODE(4)=ZCODE(2) + ICODE(1)=ICODE(3) + ICODE(4)=ICODE(2) + K=LX*(LX+1)/2 + DO IY=LY,1,-1 + DO IX=LX,IY,-1 + MAT((IY-1)*LX+IX)=MAT(K) + K=K-1 + ENDDO + ENDDO + DO IY=1,LY + DO IX=1,IY-1 + MAT((IY-1)*LX+IX)=MAT((IX-1)*LY+IY) + ENDDO + ENDDO + NEL=LX*LY + IF(K.NE.0) THEN + CALL XABORT('SNTRK: UNABLE TO UNFOLD THE DOMAIN.') + ENDIF + ENDIF + ENDIF + + IF(IMPX.GT.5) THEN + WRITE(6,600) 'NCODE',(NCODE(I),I=1,6) + WRITE(6,600) 'ICODE',(ICODE(I),I=1,6) + WRITE(6,600) 'MAT',(MAT(I),I=1,LX*LY*LZ) + ENDIF +*--- +* CALL TO THE SN TRACKING MODULE RELEVANT TO EACH GEOMETRY +*--- + NDIM=0 + IF(ITYPE.EQ.2) THEN +* 1D SLAB GEOMETRY. + NDIM=1 + IF(ISCAT.EQ.0) CALL XABORT('SNTRK: SCAT NOT DEFINED.') + IF(IGLK.NE.0) THEN + NSCT=NLF + ELSE + NSCT=ISCAT + ENDIF + ALLOCATE(UU(NLF),WW(NLF),WX(IELEM+1),WE(EELEM+1), + 1 CST(MAX(IELEM,EELEM)),MN(NSCT*NLF),DN(NLF*NSCT),IL(NSCT), + 2 IM(NSCT),PL(NSCT*NLF)) + CALL SNT1DP(IMPX,LX,IELEM,NCODE,ZCODE,XXX,NLF,NSCT,UU,WW,PL, + 1 VOL,IDL,LL4,NUN,LSHOOT,EELEM,WX,WE,CST,IBFP,ISCHM,ESCHM, + 2 IGLK,MN,DN,IL,IM,IQUAD) + CALL LCMPUT(IPTRK,'U',NLF,2,UU) + CALL LCMPUT(IPTRK,'W',NLF,2,WW) + CALL LCMPUT(IPTRK,'WX',IELEM+1,2,WX) + IF(IBFP.NE.0) CALL LCMPUT(IPTRK,'WE',EELEM+1,2,WE) + CALL LCMPUT(IPTRK,'CST',MAX(IELEM,EELEM),2,CST) + CALL LCMPUT(IPTRK,'MN',NSCT*NLF,2,MN) + CALL LCMPUT(IPTRK,'DN',NLF*NSCT,2,DN) + CALL LCMPUT(IPTRK,'IL',NSCT,1,IL) + CALL LCMPUT(IPTRK,'IM',NSCT,1,IM) + CALL LCMPUT(IPTRK,'PL',NSCT*NLF,2,PL) + DEALLOCATE(WW,UU,WX,WE,CST,MN,DN,IL,IM,PL) + ! For Fourier Analysis + IF(NFOU.GT.0)THEN + XLEN = XXX(LX+1) + CALL LCMPUT(IPTRK,'XXX',LX+1,2,XXX) + CALL LCMPUT(IPTRK,'XLEN',1,2,XLEN) + ENDIF + ELSE IF(ITYPE.EQ.3) THEN +* 1D CYLINDRICAL GEOMETRY. + NDIM=1 + IF(ISCAT.EQ.0) CALL XABORT('SNTRK: SCAT NOT DEFINED.') + NSCT=(ISCAT/2)*(ISCAT/2+1)+(ISCAT+1)*MOD(ISCAT,2)/2 + IF(IQUAD.GE.10) THEN +* PRODUCT QUADRATURE. + NPQ=(NLF**2)/2 + ELSE + NPQ=NLF*(1+NLF/2)/2 + ENDIF + ALLOCATE(JOP(NLF/2),UU(NLF/2),WW(NLF/2),TPQ(NPQ),UPQ(NPQ), + 1 VPQ(NPQ),WPQ(NPQ),ALPHA(NPQ),PLZ(NSCT*NLF/2),PL(NSCT*NPQ), + 2 SURF(LX+1),IL(NSCT),IM(NSCT)) + CALL SNT1DC(IMPX,LX,NCODE,ZCODE,XXX,NLF,NPQ,NSCT,IQUAD,JOP, + 1 UU,WW,TPQ,UPQ,VPQ,WPQ,ALPHA,PLZ,PL,VOL,IDL,SURF,IL,IM) + DEALLOCATE(VPQ,TPQ,WW) + CALL LCMPUT(IPTRK,'JOP',NLF/2,1,JOP) + CALL LCMPUT(IPTRK,'U',NLF/2,2,UU) + CALL LCMPUT(IPTRK,'UPQ',NPQ,2,UPQ) + CALL LCMPUT(IPTRK,'WPQ',NPQ,2,WPQ) + CALL LCMPUT(IPTRK,'ALPHA',NPQ,2,ALPHA) + CALL LCMPUT(IPTRK,'PLZ',NSCT*NLF/2,2,PLZ) + CALL LCMPUT(IPTRK,'PL',NSCT*NPQ,2,PL) + CALL LCMPUT(IPTRK,'SURF',LX+1,2,SURF) + CALL LCMPUT(IPTRK,'IL',NSCT,1,IL) + CALL LCMPUT(IPTRK,'IM',NSCT,1,IM) + DEALLOCATE(SURF,PL,PLZ,ALPHA,WPQ,UPQ,UU,JOP,IL,IM) + LL4=LX*NSCT + NUN=LL4 + ELSE IF(ITYPE.EQ.4) THEN +* 1D SPHERICAL GEOMETRY. + NDIM=1 + IF(ISCAT.EQ.0) CALL XABORT('SNTRK: SCAT NOT DEFINED.') + NSCT=ISCAT + ALLOCATE(UU(NLF),WW(NLF),ALPHA(NLF),PLZ(NSCT),PL(NSCT*NLF), + 1 SURF(LX+1),IL(NSCT),IM(NSCT)) + CALL SNT1DS(IMPX,LX,NCODE,ZCODE,XXX,NLF,NSCT,UU,WW,ALPHA, + 1 PLZ,PL,VOL,IDL,SURF,IQUAD,IL,IM) + CALL LCMPUT(IPTRK,'U',NLF,2,UU) + CALL LCMPUT(IPTRK,'W',NLF,2,WW) + CALL LCMPUT(IPTRK,'ALPHA',NLF,2,ALPHA) + CALL LCMPUT(IPTRK,'PLZ',NSCT,2,PLZ) + CALL LCMPUT(IPTRK,'PL',NSCT*NLF,2,PL) + CALL LCMPUT(IPTRK,'SURF',LX+1,2,SURF) + CALL LCMPUT(IPTRK,'XXX',LX+1,2,XXX) + CALL LCMPUT(IPTRK,'IL',NSCT,1,IL) + CALL LCMPUT(IPTRK,'IM',NSCT,1,IM) + DEALLOCATE(SURF,PL,PLZ,ALPHA,WW,UU,IL,IM) + LL4=LX*NSCT + NUN=LL4 + ELSE IF((ITYPE.EQ.5).OR.(ITYPE.EQ.6).OR.(ITYPE.EQ.8)) THEN +* 2D GEOMETRIES: CARTESIAN; TUBE; HEXAGONAL + NDIM=2 + IF(ISCAT.EQ.0) CALL XABORT('SNTRK: SCAT NOT DEFINED.') + IF(IQUAD.GE.10) THEN + NPQ=NLF**2 + ELSE + NPQ=(NLF+4)*NLF/2 + ENDIF + IF(IGLK.NE.0) THEN + NPQ=(NLF+2)*NLF/2 + NSCT=NPQ + ELSE + NSCT=ISCAT*(ISCAT+1)/2 + ENDIF + IGE=0 +* + IF(ITYPE.EQ.5) THEN + ! 2D Cartesian + IF(NFOU.GT.0)THEN + XLEN = XXX(LX+1) + YLEN = YYY(LY+1) + CALL LCMPUT(IPTRK,'XXX',LX+1,2,XXX) + CALL LCMPUT(IPTRK,'XLEN',1,2,XLEN) + + CALL LCMPUT(IPTRK,'YYY',LY+1,2,YYY) + CALL LCMPUT(IPTRK,'YLEN',1,2,YLEN) + ENDIF + ELSEIF(ITYPE.EQ.6) THEN + ! 2D Tube + IGE=1 + ELSEIF(ITYPE.EQ.8) THEN + ! 2D Hexagonal + IGE=2 + NHEX=LX/(3*ISPLH**2) + ALLOCATE(COORDMAP(3,NHEX)) + COORDMAP(:,:)=0 + CALL SNTSFH(IMPX,ITYPE,NHEX,LZ,MCELL,ISPLH,MAT,LOZSWP, + > COORDMAP) + CALL LCMPUT(IPTRK,'LOZSWP',3*6,1,LOZSWP) + CALL LCMPUT(IPTRK,'COORDMAP',3*NHEX,1,COORDMAP) + CALL LCMPUT(IPTRK,'SIDE',1,2,SIDE) + DEALLOCATE(COORDMAP) + ENDIF +* + ALLOCATE(MRMX(NPQ),MRMY(NPQ)) + ALLOCATE(DU(NPQ),DE(NPQ),WW(NPQ),DB(LX*NPQ),DA(LX*LY*NPQ), + 1 DAL(LX*LY*NPQ),WX(IELEM+1), + 2 WE(EELEM+1),CST(MAX(IELEM,EELEM)),MN(NSCT*NPQ),DN(NPQ*NSCT), + 3 IL(NSCT),IM(NSCT),PL(NSCT*NPQ)) + CALL SNTT2D(IGE,IMPX,LX,LY,SIDE,IELEM,NLF,NPQ,NSCT,IQUAD, + 1 NCODE,ZCODE,MAT,XXX,YYY,VOL,IDL,DU,DE,WW,MRMX,MRMY,DB,DA,DAL, + 2 PL,LL4,NUN,EELEM,WX,WE,CST,IBFP,ISCHM,ESCHM,IGLK,MN,DN,IL,IM, + 3 ISCAT) + CALL LCMPUT(IPTRK,'DU',NPQ,2,DU) + CALL LCMPUT(IPTRK,'DE',NPQ,2,DE) + CALL LCMPUT(IPTRK,'W',NPQ,2,WW) + CALL LCMPUT(IPTRK,'MRM',NPQ,1,MRMX) + CALL LCMPUT(IPTRK,'MRMY',NPQ,1,MRMY) + CALL LCMPUT(IPTRK,'DB',LX*NPQ,2,DB) + CALL LCMPUT(IPTRK,'DA',LX*LY*NPQ,2,DA) + IF(IGE.EQ.1) CALL LCMPUT(IPTRK,'DAL',LX*LY*NPQ,2,DAL) + CALL LCMPUT(IPTRK,'PL',NSCT*NPQ,2,PL) + CALL LCMPUT(IPTRK,'WX',IELEM+1,2,WX) + IF(IBFP.NE.0) CALL LCMPUT(IPTRK,'WE',EELEM+1,2,WE) + CALL LCMPUT(IPTRK,'CST',MAX(IELEM,EELEM),2,CST) + CALL LCMPUT(IPTRK,'MN',NSCT*NPQ,2,MN) + CALL LCMPUT(IPTRK,'DN',NPQ*NSCT,2,DN) + CALL LCMPUT(IPTRK,'IL',NSCT,1,IL) + CALL LCMPUT(IPTRK,'IM',NSCT,1,IM) + CALL LCMPUT(IPTRK,'PL',NSCT*NPQ,2,PL) + DEALLOCATE(DAL,DA,DB,WW,DE,DU,WX,WE,CST,MN,DN,IL,IM,PL) + DEALLOCATE(MRMY,MRMX) + ELSE IF((ITYPE.EQ.7).OR.(ITYPE.EQ.9)) THEN +* 3D GEOMETRIES: CARTESIAN; HEXAGONAL + NDIM=3 + IF(ISCAT.EQ.0) CALL XABORT('SNTRK: SCAT NOT DEFINED.') + IF(IQUAD.GE.10) THEN + NPQ=2*NLF**2 + ELSE + NPQ=(NLF+2)*NLF + ENDIF + IF(IGLK.NE.0) THEN + NSCT=NPQ + ELSE + NSCT=ISCAT*(ISCAT+1) + ENDIF + IGE=0 +* + IF(ITYPE.EQ.9) THEN + ! 3D Hexagonal + IGE=2 + NHEX =LX/(3*ISPLH**2) + ALLOCATE(COORDMAP(3,NHEX)) + COORDMAP(:,:)=0 + CALL SNTSFH(IMPX,ITYPE,NHEX,LZ,MCELL,ISPLH,MAT,LOZSWP, + > COORDMAP) + CALL LCMPUT(IPTRK,'LOZSWP',3*6,1,LOZSWP) + CALL LCMPUT(IPTRK,'COORDMAP',3*NHEX,1,COORDMAP) + CALL LCMPUT(IPTRK,'SIDE',1,2,SIDE) + DEALLOCATE(COORDMAP) + ENDIF +* + ALLOCATE(MRMX(NPQ),MRMY(NPQ),MRMZ(NPQ)) + ALLOCATE(DU(NPQ),DE(NPQ),DZ(NPQ),WW(NPQ),DC(LX*LY*NPQ), + 1 DB(LX*LZ*NPQ),DA(LY*LZ*NPQ),WX(IELEM+1), + 2 WE(EELEM+1),CST(MAX(IELEM,EELEM)),MN(NSCT*NPQ),DN(NPQ*NSCT), + 3 IL(NSCT),IM(NSCT),PL(NSCT*NPQ)) + CALL SNTT3D(IGE,IMPX,LX,LY,LZ,SIDE,IELEM,NLF,NPQ,NSCT,IQUAD, + 1 NCODE,ZCODE,MAT,XXX,YYY,ZZZ,VOL,IDL,DU,DE,DZ,WW,MRMX,MRMY, + 2 MRMZ,DC,DB,DA,PL,LL4,NUN,EELEM,WX,WE,CST,IBFP,ISCHM,ESCHM, + 3 IGLK,MN,DN,IL,IM,ISCAT) +* + CALL LCMPUT(IPTRK,'DU',NPQ,2,DU) + CALL LCMPUT(IPTRK,'DE',NPQ,2,DE) + CALL LCMPUT(IPTRK,'DZ',NPQ,2,DZ) + CALL LCMPUT(IPTRK,'W',NPQ,2,WW) + CALL LCMPUT(IPTRK,'MRMX',NPQ,1,MRMX) + CALL LCMPUT(IPTRK,'MRMY',NPQ,1,MRMY) + CALL LCMPUT(IPTRK,'MRMZ',NPQ,1,MRMZ) + CALL LCMPUT(IPTRK,'DC',LX*LY*NPQ,2,DC) + CALL LCMPUT(IPTRK,'DB',LX*LZ*NPQ,2,DB) + CALL LCMPUT(IPTRK,'DA',LY*LZ*NPQ,2,DA) + CALL LCMPUT(IPTRK,'PL',NSCT*NPQ,2,PL) + CALL LCMPUT(IPTRK,'WX',IELEM+1,2,WX) + IF(IBFP.NE.0) CALL LCMPUT(IPTRK,'WE',EELEM+1,2,WE) + CALL LCMPUT(IPTRK,'CST',MAX(IELEM,EELEM),2,CST) + CALL LCMPUT(IPTRK,'MN',NSCT*NPQ,2,MN) + CALL LCMPUT(IPTRK,'DN',NPQ*NSCT,2,DN) + CALL LCMPUT(IPTRK,'IL',NSCT,1,IL) + CALL LCMPUT(IPTRK,'IM',NSCT,1,IM) + CALL LCMPUT(IPTRK,'PL',NSCT*NPQ,2,PL) + DEALLOCATE(DA,DB,DC,WW,DZ,DE,DU,WX,WE,CST,MN,DN,IL,IM,PL) + DEALLOCATE(MRMZ,MRMY,MRMX) + ELSE + CALL XABORT('SNTRK: UNKNOWN GEOMETRY.') + ENDIF + DEALLOCATE(YYY,ZZZ) +*---- +* THE NUMBER OF UNKNOWNS OF A BOLTZMANN-FOKKER-PLANCK DISCRETIZATION IS +* INCREASED TO HOLD SLOWING-DOWN ANGULAR FLUXES. +*---- + IF(IBFP.GT.0) THEN + IF(NDIM.EQ.1) THEN + NUN=NUN+IELEM*NLF*NEL + ELSE IF(NDIM.EQ.2) THEN + NUN=NUN+IELEM**2*NPQ*NEL + ELSE IF(NDIM.EQ.3) THEN + NUN=NUN+IELEM**3*NPQ*NEL + ELSE + CALL XABORT('SNTRK: FOKKER-PLANCK NOT IMPLEMENTED.') + ENDIF + ENDIF + IF(IMPX.GT.0) WRITE (6,'(/33H SNTRK: ORDER OF LINEAR SYSTEMS =, + 1 I10/8X,37HNUMBER OF UNKNOWNS PER ENERGY GROUP =,I10)') LL4,NUN +* + IF(IMPX.GT.5) THEN + I1=1 + DO I=1,(NEL-1)/8+1 + I2=I1+7 + IF(I2.GT.NEL) I2=NEL + WRITE (6,620) (J,J=I1,I2) + WRITE (6,630) (MAT(J),J=I1,I2) + WRITE (6,640) (IDL(J),J=I1,I2) + WRITE (6,650) (VOL(J),J=I1,I2) + I1=I1+8 + ENDDO + ENDIF +*---- +* SYNTHETIC ACCELERATION TRACKING INFORMATION. +*---- + IF(LDSA) THEN + IF(IMPX.GT.0) WRITE (6,'(/32H SNTRK: SYNTHETIC ACCELERATION I, + 1 19HNFORMATION FOLLOWS:)') + CALL LCMSIX(IPTRK,'DSA',1) + ICOL=3 ! Gauss-Legendre quadrature + NLFSA=2 ! P1 method + ISPN=1 ! simplified PN method + ISCSA=1 ! isotropic scattering + NVD=1 ! SN-type VOID boundary conditions + NADI=2 ! ADI iteration + ICHX=2 ! Raviart-Thomas finite elements + ISEG=0 ! scalar algorithm + IMPV=0 ! print parameter for vector operations + IF(MAXPTS.EQ.0) CALL XABORT('SNTRK: MAXPTS NOT DEFINED.') + IF((ITYPE.EQ.7).OR.(ITYPE.EQ.9)) THEN + CALL TRITRK(MAXPTS,IPTRK,IPGEOM,IMPX,IELEMSA,ICOL,ICHX,ISEG, + 1 IMPV,NLFSA,NVD,ISPN,ISCSA,NADI) + ELSE + IF(ISOLVSA.EQ.1)THEN + CALL BIVTRK(MAXPTS,IPTRK,IPGEOM,IMPX,IELEMSA,ICOL, + 1 NLFSA,NVD,ISPN,ISCSA) + ELSEIF(ISOLVSA.EQ.2)THEN + CALL TRITRK(MAXPTS,IPTRK,IPGEOM,IMPX,IELEMSA,ICOL,ICHX, + 1 ISEG,IMPV,NLFSA,NVD,ISPN,ISCSA,NADI) + ELSE + CALL XABORT('SNTRK: UNDEFINED SOLVER OPTION FOR ' + 1 //'SYNTHETIC ACCELERATION.') + ENDIF + ENDIF + CALL LCMSIX(IPTRK,' ',2) + ENDIF +*---- +* SAVE GENERAL AND SN-SPECIFIC TRACKING INFORMATION. +*---- + IGP(:NSTATE)=0 + IGP(1)=NEL + IGP(2)=NUN + IF(ILK) THEN + IGP(3)=0 + ELSE + IGP(3)=1 + ENDIF + IGP(4)=ISTATE(7) + IGP(5)=1 + IGP(6)=ITYPE + IGP(7)=NSCT + IGP(8)=IELEM + IGP(9)=NDIM + IGP(10)=ISCHM + IGP(11)=LL4 + IGP(12)=LX + IGP(13)=LY + IGP(14)=LZ + IGP(15)=NLF + IGP(16)=ISCAT + IGP(17)=IQUAD + IGP(18)=0 + IF(LFIXUP) IGP(18)=1 + IGP(19)=0 + IF(LDSA) IGP(19)=1 + IGP(20)=NSTART + IGP(21)=NSDSA + IGP(22)=MAXIT + IF(LIVO) IGP(23)=1 + IGP(24)=ICL1 + IGP(25)=ICL2 + IGP(26)=ISPLH + IGP(27)=INSB + IGP(28)=MCELL + IF((ITYPE.EQ.3).OR.(ITYPE.GE.4)) IGP(29)=1 + IGP(30)=0 + IF(LSHOOT) IGP(30)=1 + IGP(31)=IBFP + IGP(32)=NMPI + IGP(33)=ISOLVSA + IGP(34)=NFOU + IGP(35)=EELEM + IGP(36)=ESCHM + IGP(37)=IGLK + IF(LBIHET) IGP(40)=1 + + CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,IGP) + CALL LCMPUT(IPTRK,'MATCOD',NEL,1,MAT) + CALL LCMPUT(IPTRK,'VOLUME',NEL,2,VOL) + CALL LCMPUT(IPTRK,'KEYFLX',NEL,1,IDL) + CALL LCMPUT(IPTRK,'NCODE',6,1,NCODE) + CALL LCMPUT(IPTRK,'ICODE',6,1,ICODE) + CALL LCMPUT(IPTRK,'ZCODE',6,2,ZCODE) + CALL LCMPUT(IPTRK,'EPSI',1,2,EPSI) + IF(ITYPE.EQ.4) CALL LCMPUT(IPTRK,'XXX',LX+1,2,XXX) + DEALLOCATE(XXX) +*---- +* SET KEYFLX$ANIS +*---- + NLIN=IELEM**NDIM*EELEM + ALLOCATE(KEYANI(NEL,NLIN,NSCT)) + DO IR=1,NEL + IND=IDL(IR) + DO IE=1,NLIN + DO P=1,NSCT + IF(IND.EQ.0) THEN + KEYANI(IR,IE,P)=0 + ELSE + KEYANI(IR,IE,P)=IND+(P-1)*NLIN+IE-1 + ENDIF + ENDDO + ENDDO + ENDDO + CALL LCMPUT(IPTRK,'KEYFLX$ANIS',NEL*NLIN*NSCT,1,KEYANI) + DEALLOCATE(KEYANI) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IDL,VOL,MAT) + RETURN +* + 600 FORMAT(/25H SNTRK: VALUES OF VECTOR ,A6,4H ARE/(1X,1P,20I6)) + 620 FORMAT (///11H REGION ,8(I8,6X,1HI)) + 630 FORMAT ( 11H MIXTURE ,8(I8,6X,1HI)) + 640 FORMAT ( 11H POINTER ,8(I8,6X,1HI)) + 650 FORMAT ( 11H VOLUME ,8(1P,E13.6,2H I)) + END diff --git a/Dragon/src/SNTSFH.f b/Dragon/src/SNTSFH.f new file mode 100644 index 0000000..630f38a --- /dev/null +++ b/Dragon/src/SNTSFH.f @@ -0,0 +1,253 @@ +*DECK SNTSFH + SUBROUTINE SNTSFH (IMPX,ITYPE,NHEX,LZ,MCELL,ISPLH,MAT,LOZSWP, + > COORDMAP) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Output arrays for lozenge sweep order (direction-dependent) and +* coordinate map, both needed for resolution of the discrete ordinates +* transport equation in hexagonal geometry. +* +*Copyright: +* Copyright (C) 2025 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. A. Calloo +* +*Parameters: input +* IMPX print parameter. +* ITYPE geometry type (8:hexagonal 2D, 9:hexagonal 3D). +* NHEX number of hexagons (for 3D, in one plane only). +* LZ number of mesh elements in z-axis (including split). +* MCELL number of macrocells to use along z-axis. +* ISPLH mesh-splitting in 3*ISPLH**2 lozenges per hexagon. +* MAT mixture index assigned to each element. +* +*Parameters: local +* NRINGS number of hexagonal rings in the domain, assuming the centre +* hexagon counts as 1 ring. +* +*Parameters: output +* LOZSWP lozenge sweep order depending on direction. +* COORDMAP coordinate map: mapping hexagon from DRAGON geometry indices +* to the axial coordinate system, using p, r, s axes. The s +* axis is redundant, which means that using p and r axes +* effectively maps the hexagon geometry to a 2D map. Refer to +* the redblobgames blog for more information. +* +*Comments: +* The lozenge under consideration is given by the position within the +* matrix. See user manual and/or data manual and/or thesis +* _____ +* / / \ +* / B / \ +* ,----(---- A )----. +* / \ C \ / \ +* / \___\_/ \ +* \ 4 / \ 2 / +* \ / \ / +* )----( 1 )----( +* / \ / \ +* / \_____/ \ +* \ 5 / \ 7 / +* \ / \ / +* `----( 6 )----' +* \ / +* \_____/ +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IMPX,ITYPE,NHEX,LZ,MCELL,ISPLH,MAT(ISPLH**2,3,NHEX,LZ), + > COORDMAP(3,NHEX) +*---- +* LOCAL VARIABLES +*---- + INTEGER, DIMENSION(3,6) :: LOZSWP,MAPCODE + INTEGER, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: TMPMAT + INTEGER, ALLOCATABLE, DIMENSION(:) :: TASKSPERWAVE +*---- +* LOZENGE SWEEP ORDERING WITHIN HEXAGONS - DIRECTION DEPENDENT +*---- + LOZSWP = RESHAPE((/ 3, 2, 1, 3, 1, 2, 1, 3, 2, 1, 2, 3, 2, 1, + > 3, 2, 3, 1 /), SHAPE(LOZSWP)) +*---- +* CREATE COORDIDATE MAP FROM DRAGON INDEX TO AXIAL COORDINATES +*---- + NRINGS=INT((SQRT( REAL((4*NHEX-1)/3) )+1.)/2.) + IF(NRINGS.EQ.1) CALL XABORT('NOT IMPLEMENTED FOR SINGLE HEX YET.') + IF(NHEX.NE.1+3*NRINGS*(NRINGS-1)) CALL XABORT('SNTSFH: INVALID ' + 1 //'VALUE OF NHEX(1).') +* + MAPCODE = RESHAPE((/ -1, 0, 1, -1, 1, 0, 0, 1, -1, 1, 0, -1, 1, + > -1, 0, 0, -1, 1 /), SHAPE(MAPCODE)) +* + ! It should be noted that the algorithm below effectively + ! reverses the y-axis. However, this should be of no consequence + ! whatsoever as it would akin to the user defining the domain + ! somewhat differently in the geometry. Calculations and results + ! should be unaffected. + IHEX_DOM=1 + DO IRING=1,NRINGS + ! Initialise first 'ring', i.e., centre hexagon + IF(IRING.EQ.1) THEN + ITMP1 = NRINGS + ITMP2 = NRINGS + ITMP3 = -2*(NRINGS) + COORDMAP(1,IHEX_DOM)=ITMP1 + COORDMAP(2,IHEX_DOM)=ITMP2 + COORDMAP(3,IHEX_DOM)=ITMP3 + + IHEX_DOM = IHEX_DOM+1 + ! Ignore rest of this loop and move on to next ring + CYCLE + ENDIF + + ! Find coordinates for hexagon when moving from ring n-1 to n + ITMP1 = ITMP1+1 + ITMP2 = ITMP2-1 + ITMP3 = ITMP3+0 + COORDMAP(1,IHEX_DOM)=ITMP1 + COORDMAP(2,IHEX_DOM)=ITMP2 + COORDMAP(3,IHEX_DOM)=ITMP3 + IHEX_DOM = IHEX_DOM+1 + + ! 'Sweep' each of the 3 axes of the hexagonal plane and their + ! negative directions + DO IND=1,6 + ! Step through each hexagon per each axis + DO IHEX=1,IRING-1 + ITMP1 = ITMP1+MAPCODE(1,IND) + ITMP2 = ITMP2+MAPCODE(2,IND) + ITMP3 = ITMP3+MAPCODE(3,IND) + ! Store each of the coordinates except the last hexagon + ! in the last direction. This is because we already + ! computed that hexagon when moving from ring n-1 to n + IF((IND.EQ.6).AND.(IHEX.EQ.IRING-1))THEN + CONTINUE + ELSE + COORDMAP(1,IHEX_DOM)=ITMP1 + COORDMAP(2,IHEX_DOM)=ITMP2 + COORDMAP(3,IHEX_DOM)=ITMP3 + IHEX_DOM = IHEX_DOM+1 + ENDIF + ENDDO ! ihex + ENDDO ! ind + ENDDO ! iring + +*---- +* COMPUTE NUMBER OF CONCURRENT HEXAGONS PER WAVEFRONT FOR PRINTING +* PURPOSES ONLY +*---- + IF(MCELL > 0)THEN + + ! Build material array in axial coordinates + NCOLS=2*NRINGS -1 + ALLOCATE(TMPMAT(ISPLH**2,3,NCOLS,NCOLS,LZ)) + TMPMAT(:,:,:,:,:)=-1 + DO IZ=1,LZ + DO IHEX_XY=1,NHEX + TMPMAT(:,:,COORDMAP(1,IHEX_XY),COORDMAP(2,IHEX_XY),IZ) = + > MAT(:,:,IHEX_XY,IZ) + ENDDO + ENDDO + + ! Build TasksPerWave array + IF(ITYPE==8)THEN + ! 2D Hexagonal + NWAVES=NCOLS+NCOLS-1 + ALLOCATE(TASKSPERWAVE(NWAVES)) + TASKSPERWAVE(:)=0 + + DO IWAVE=1,NWAVES + ICOUNT = 0 + DO J=MAX(1,IWAVE-NCOLS+1),MIN(NCOLS,IWAVE) + I=IWAVE-J+1 + I=NCOLS+1-I + IF((I.GT.NCOLS).OR.(I.LT.1)) CYCLE + IF((J.GT.NCOLS).OR.(J.LT.1)) CYCLE + ! If within corners of Cartesian axial coordinate map + ! (where there are no hexagons), skip loop + IF(TMPMAT(1,1,I,J,1).EQ.-1) CYCLE + ICOUNT = ICOUNT + 1 + ENDDO + TASKSPERWAVE(IWAVE) = ICOUNT + ENDDO + ELSEIF(ITYPE==9)THEN + ! 3D Hexagonal + MCELLZ = MCELL + NWAVES=NCOLS+NCOLS+MCELLZ-2 + ALLOCATE(TASKSPERWAVE(NWAVES)) + TASKSPERWAVE(:)=0 + + DO IWAVE=1,NWAVES + ICOUNT = 0 + J_STT=MAX(1,IWAVE-NCOLS-MCELLZ+2) + J_END=MIN(NCOLS,IWAVE) + DO J_MC=J_STT,J_END + J=J_MC + I_STT=MAX(1,IWAVE-J_MC-MCELLZ+2) + I_END=MIN(NCOLS,IWAVE-J_MC+1) + DO I_MC=I_STT,I_END + I=I_MC + I=NCOLS+1-I + ! If within corners of Cartesian axial coordinate map + ! (where there are no hexagons), skip loop + IF(TMPMAT(1,1,I,J,1).EQ.-1) CYCLE + K_MC=IWAVE-I_MC-J_MC+2 + ICOUNT = ICOUNT + 1 + ENDDO + ENDDO + TASKSPERWAVE(IWAVE) = ICOUNT + ENDDO + ENDIF + + DEALLOCATE(TMPMAT) + + ENDIF + +*---- +* PRINT A FEW GEOMETRY CHARACTERISTICS +*---- + IF(IMPX.GT.2) THEN + WRITE(*, 100) + WRITE(*, 101) NCOLS + WRITE(*, 102) NRINGS + WRITE(*, 103) + DO I=1,6 + WRITE(*,104) I, LOZSWP(:,I) + ENDDO + IF(MCELL > 0)THEN + WRITE(*, 105) NWAVES + WRITE(*, 106) + DO I = 1, NWAVES + WRITE(*, 107) TASKSPERWAVE(I) + END DO + DEALLOCATE(TASKSPERWAVE) + ENDIF + ENDIF + IF(IMPX.GT.4) THEN + WRITE(*, 109) + WRITE(*, 110) + DO I = 1, NHEX + WRITE(*, 111) I, COORDMAP(:, I) + END DO + ENDIF + + RETURN + 100 FORMAT (' ') + 101 FORMAT ('NCOLS =', I4) + 102 FORMAT ('NRINGS =', I4) + 103 FORMAT ('LOZENGE SWEEP ORDER') + 104 FORMAT ('IND_XY:', I4, ' LOZ. ORDER:', 3I4) + 105 FORMAT ('NWAVES =', I4) + 106 FORMAT ('TASKS PER WAVE') + 107 FORMAT (I4) + 109 FORMAT (' ') + 110 FORMAT ('COORDINATE MAP IS GIVEN BELOW:') + 111 FORMAT ('DRAGON IND:', I4, ' AXIAL COORD:', 3I4) + END diff --git a/Dragon/src/SNTT2D.f b/Dragon/src/SNTT2D.f new file mode 100644 index 0000000..e5cdd85 --- /dev/null +++ b/Dragon/src/SNTT2D.f @@ -0,0 +1,572 @@ +*DECK SNTT2D + SUBROUTINE SNTT2D (IGE,IMPX,LX,LY,SIDE,IELEM,NLF,NPQ,NSCT,IQUAD, + 1 NCODE,ZCODE,MAT,XXX,YYY,VOL,IDL,DU,DE,W,MRM,MRMY,DB,DA,DAL,PL, + 2 LL4,NUN,EELEM,WX,WE,CST,IBFP,ISCHM,ESCHM,IGLK,MN,DN,IL,IM,ISCAT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Numbering corresponding to a 2-D Cartesian or R-Z geometry with +* discrete ordinates approximation of the flux. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert and C. Bienvenue +* +*Parameters: input +* IGE type of 2D geometry (=0 Cartesian; =1 R-Z; =2 Hexagonal). +* IMPX print parameter. +* LX number of elements along the X axis. +* LY number of elements along the Y axis. +* SIDE side of an hexagon. +* IELEM measure of order of the spatial approximation polynomial: +* =1 constant - only for HODD, classical diamond scheme +* (default for HODD); +* =2 linear - default for DG; +* =3 parabolic; +* =4 cubic - only for DG. +* NLF SN order for the flux (even number). +* NPQ number of SN directions in four octants (including zero-weight +* directions). +* NSCT maximum number of spherical harmonics moments of the flux. +* IQUAD type of SN quadrature (1 Level symmetric, type IQUAD; +* 4 Legendre-Chebyshev; 5 symmetric Legendre-Chebyshev; +* 6 quadruple range). +* NCODE type of boundary condition applied on each side +* (i=1 X-; i=2 X+; i=3 Y-; i=4 Y+): +* =1: VOID; =2: REFL; =4: TRAN. +* ZCODE ZCODE(I) is the albedo corresponding to boundary condition +* 'VOID' on each side (ZCODE(I)=0.0 by default). +* MAT mixture index assigned to each element. +* XXX Cartesian coordinates along the X axis. +* YYY Cartesian coordinates along the Y axis. +* EELEM measure of order of the energy approximation polynomial: +* =1 constant - default for HODD; +* =2 linear - default for DG; +* >3 higher orders. +* IBFP type of energy proparation relation: +* =0 no Fokker-Planck term; +* =1 Galerkin type; +* =2 heuristic Przybylski and Ligou type. +* ISCHM method of spatial discretisation: +* =1 High-Order Diamond Differencing (HODD) - default; +* =2 Discontinuous Galerkin finite element method (DG); +* =3 Adaptive weighted method (AWD). +* ESCHM method of energy discretisation: +* =1 High-Order Diamond Differencing (HODD) - default; +* =2 Discontinuous Galerkin finite element method (DG); +* =3 Adaptive weighted method (AWD). +* IGLK angular interpolation type: +* =0 classical SN method. +* =1 Galerkin quadrature method (M = inv(D)) +* =2 Galerkin quadrature method (D = inv(M)) +* ISCAT maximum number of spherical harmonics moments of the flux. +* +*Parameters: output +* VOL volume of each element. +* IDL isotropic flux indices. +* DU first direction cosines ($\\mu$). +* DE second direction cosines ($\\eta$). +* W weights. +* MRM quadrature index. +* MRMY quadrature index. +* DB diamond-scheme parameter. +* DA diamond-scheme parameter. +* DAL diamond-scheme angular redistribution parameter. +* PL discrete values of the spherical harmonics corresponding +* to the 2D SN quadrature. +* LL4 number of unknowns being solved for, over the domain. This +* includes the various moments of the isotropic (and if present, +* anisotropic) flux. +* NUN total number of unknowns stored in the FLUX vector per group. +* This includes LL4 (see above) as well as any surface boundary +* fluxes, if present. +* WX spatial closure relation weighting factors. +* WE energy closure relation weighting factors. +* CST constants for the polynomial approximations. +* MN moment-to-discrete matrix. +* DN discrete-to-moment matrix. +* IL indexes (l) of each spherical harmonics in the +* interpolation basis. +* IM indexes (m) of each spherical harmonics in the +* interpolation basis. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IGE,IMPX,LX,LY,IELEM,NLF,NPQ,NSCT,IQUAD,NCODE(4), + 1 MAT(LX,LY),IDL(LX*LY),MRM(NPQ),MRMY(NPQ),LL4,NUN,EELEM,IBFP, + 2 ISCHM,ESCHM,IL(NSCT),IM(NSCT),ISCAT,IGLK + REAL ZCODE(4),VOL(LX,LY),XXX(LX+1),YYY(LY+1),DU(NPQ),DE(NPQ), + 1 W(NPQ),DB(LX,NPQ),DA(LX,LY,NPQ),DAL(LX,LY,NPQ),PL(NSCT,NPQ), + 2 WX(IELEM+1),WE(EELEM+1),CST(MAX(IELEM,EELEM)),MN(NPQ,NSCT), + 3 DN(NSCT,NPQ) +*---- +* LOCAL VARIABLES +*---- + CHARACTER HSMG*131 + LOGICAL L1,L2,L3,L4 + PARAMETER(RLOG=1.0E-8,PI=3.141592654) + REAL PX,PE + DOUBLE PRECISION NORM,IPROD + INTEGER, ALLOCATABLE, DIMENSION(:) :: JOP + REAL, ALLOCATABLE, DIMENSION(:) :: XX,YY,UU,WW,TPQ,UPQ,VPQ,WPQ + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: V,V2 + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: U,MND + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: RLM +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(XX(LX),YY(LY)) +*---- +* UNFOLD FOUR-OCTANT QUADRATURES. +*---- + IF(MOD(NLF,2).EQ.1) CALL XABORT('SNTT2D: EVEN NLF EXPECTED.') + IF(IQUAD.EQ.10) THEN + NPQ0=NLF**2/4 + ELSE + NPQ0=NLF*(NLF/2+1)/4 + ENDIF + ALLOCATE(JOP(NLF/2),UU(NLF/2),WW(NLF/2),TPQ(NPQ0),UPQ(NPQ0), + 1 VPQ(NPQ0),WPQ(NPQ0)) + IF(IQUAD.EQ.1) THEN + CALL SNQU01(NLF,JOP,UU,WW,TPQ,UPQ,VPQ,WPQ) + ELSE IF(IQUAD.EQ.2) THEN + CALL SNQU02(NLF,JOP,UU,WW,TPQ,UPQ,VPQ,WPQ) + ELSE IF(IQUAD.EQ.3) THEN + CALL SNQU03(NLF,JOP,UU,WW,TPQ,UPQ,VPQ,WPQ) + ELSE IF(IQUAD.EQ.4) THEN + CALL SNQU04(NLF,JOP,UU,WW,TPQ,UPQ,VPQ,WPQ) + ELSE IF(IQUAD.EQ.5) THEN + UU(:NLF/2)=0.0 + CALL SNQU05(NLF,TPQ,UPQ,VPQ,WPQ) + ELSE IF(IQUAD.EQ.6) THEN + UU(:NLF/2)=0.0 + CALL SNQU06(NLF,TPQ,UPQ,VPQ,WPQ) + ELSE IF(IQUAD.EQ.10) THEN + CALL SNQU10(NLF,JOP,UU,WW,TPQ,UPQ,VPQ,WPQ) + ELSE + CALL XABORT('SNTT2D: UNKNOWN QUADRATURE TYPE.') + ENDIF + N=0 + IOF=0 + DO 30 I=1,NLF/2 + IF(IGLK.NE.0) THEN + JOF = NLF-2*I+2 + KOF = (NLF+4)*NLF/4 + ELSE + IOF=IOF+1 + JOF=IOF+NLF-2*I+2 + KOF=IOF+(NLF+4)*NLF/4 + MRM(IOF)=JOF + MRMY(IOF)=KOF + DU(IOF)=-SQRT(1.0-UU(I)*UU(I)) + DE(IOF)=-UU(I) + W(IOF)=0.0 + ENDIF + DO 10 J=0,NLF/2-I + IOF=IOF+1 + KOF=IOF+(NLF+4)*NLF/4 + MRM(IOF)=JOF + MRMY(IOF)=KOF + DU(IOF)=-UPQ(N+J+1) + DE(IOF)=-VPQ(N+J+1) + W(IOF)=WPQ(N+J+1) + JOF=JOF-1 + 10 CONTINUE + DO 20 J=NLF/2-I,0,-1 + IOF=IOF+1 + KOF=IOF+(NLF+4)*NLF/4 + MRM(IOF)=JOF + MRMY(IOF)=KOF + DU(IOF)=UPQ(N+J+1) + DE(IOF)=-VPQ(N+J+1) + W(IOF)=WPQ(N+J+1) + JOF=JOF-1 + 20 CONTINUE + N=N+NLF/2-I+1 + 30 CONTINUE + N=0 + DO 60 I=1,NLF/2 + IF(IGLK.NE.0) THEN + JOF=NLF-2*I+2 + KOF=-(NLF+4)*NLF/4 + ELSE + IOF=IOF+1 + JOF=IOF+NLF-2*I+2 + KOF=IOF-(NLF+4)*NLF/4 + MRM(IOF)=JOF + MRMY(IOF)=KOF + DU(IOF)=-SQRT(1.0-UU(I)*UU(I)) + DE(IOF)=UU(I) + W(IOF)=0.0 + ENDIF + DO 40 J=0,NLF/2-I + IOF=IOF+1 + KOF=IOF-(NLF+4)*NLF/4 + MRM(IOF)=JOF + MRMY(IOF)=KOF + DU(IOF)=-UPQ(N+J+1) + DE(IOF)=VPQ(N+J+1) + W(IOF)=WPQ(N+J+1) + JOF=JOF-1 + 40 CONTINUE + DO 50 J=NLF/2-I,0,-1 + IOF=IOF+1 + KOF=IOF-(NLF+4)*NLF/4 + MRM(IOF)=JOF + MRMY(IOF)=KOF + DU(IOF)=UPQ(N+J+1) + DE(IOF)=VPQ(N+J+1) + W(IOF)=WPQ(N+J+1) + JOF=JOF-1 + 50 CONTINUE + N=N+NLF/2-I+1 + 60 CONTINUE + DEALLOCATE(WPQ,VPQ,UPQ,TPQ,WW,UU,JOP) + IF(IMPX.GE.4) THEN + WRITE(6,'(/41H SNTT2D: FOUR-OCTANT ANGULAR QUADRATURES:/26X, + 1 2HMU,9X,3HETA,10X,2HXI,6X,6HWEIGHT)') + SUM=0.0 + DO 70 N=1,NPQ + SUM=SUM+W(N) + ZI=SQRT(ABS(1.0-DU(N)**2-DE(N)**2)) + IF(ZI.LT.1.0E-3) ZI=0.0 + WRITE(6,'(1X,3I5,1P,4E12.4)') N,MRM(N),MRMY(N),DU(N),DE(N),ZI, + 1 W(N) + 70 CONTINUE + WRITE(6,'(54X,10(1H-)/52X,1P,E12.4)') SUM + ENDIF +*---- +* IDENTIFICATION OF THE GEOMETRY. +*---- + IF(IGE.EQ.0) THEN +* ---------- +* 2D CARTESIAN +* ---------- + DO 82 N=1,NPQ + VU=DU(N) + VE=DE(N) + DO 81 I=1,LX + XX(I)=XXX(I+1)-XXX(I) + DB(I,N)=VE*XX(I) + DO 80 J=1,LY + YY(J)=YYY(J+1)-YYY(J) + DA(I,J,N)=VU*YY(J) + DAL(I,J,N)=0.0 + 80 CONTINUE + 81 CONTINUE + 82 CONTINUE + DO 91 I=1,LX + DO 90 J=1,LY + VOL(I,J)=XX(I)*YY(J) + 90 CONTINUE + 91 CONTINUE + ELSEIF(IGE.EQ.1) THEN +* ---------- +* 2D TUBE +* ---------- + DO 95 J=1,LY + YY(J)=YYY(J+1)-YYY(J) + 95 CONTINUE + DO 102 N=1,NPQ + VU=DU(N)*PI + DO 101 I=1,LX + XX(I)=XXX(I+1)-XXX(I) + VE=(XXX(I)+XXX(I+1))*VU + DO 100 J=1,LY + DA(I,J,N)=VE*YY(J) + 100 CONTINUE + 101 CONTINUE + 102 CONTINUE + DB(:LX,:NPQ)=0.0 + DAL(:LX,:LY,:NPQ)=0.0 + DO 135 J=1,LY + DO 111 I=1,LX + VE=2.0*PI*(XXX(I+1)-XXX(I))*YY(J) + DO 110 N=2,NPQ + DB(I,N)=DB(I,N-1)-W(N)*DU(N)*VE + 110 CONTINUE + 111 CONTINUE + DO 130 N=2,NPQ + VE=W(N) + IF(VE.LE.RLOG) GOTO 130 + DO 120 I=1,LX + DAL(I,J,N)=(DB(I,N)+DB(I,N-1))/VE + 120 CONTINUE + 130 CONTINUE + 135 CONTINUE + DO 155 I=1,LX + VE=PI*XX(I)*(XXX(I+1)+XXX(I)) + DO 140 N=1,NPQ + DB(I,N)=VE*DE(N) + 140 CONTINUE + DO 150 J=1,LY + VOL(I,J)=YY(J)*VE + 150 CONTINUE + 155 CONTINUE + ELSEIF(IGE.EQ.2) THEN +* ---------- +* 2D HEXAGONAL +* ---------- + DET = SQRT(3.0)*(SIDE**2)/2.0 + DO 162 N=1,NPQ + VU=DU(N) + VE=DE(N) + DO 161 I=1,LX + DB(I,N)=VE + DO 160 J=1,LY + DA(I,J,N)=VU + VOL(I,J)=DET + 160 CONTINUE + 161 CONTINUE + 162 CONTINUE + ENDIF +*---- +* GENERATE SPHERICAL HARMONICS FOR SCATTERING SOURCE. +*---- + IOF=0 + DO 211 L=0,ISCAT-1 + DO 210 M=-L,L + IF(MOD(L+M,2).EQ.1) GO TO 210 + IOF=IOF+1 + IF(IOF.GT.NSCT) GO TO 211 + DO 200 N=1,NPQ + ZI=SQRT(ABS(1.0-DU(N)**2-DE(N)**2)) + IF(ZI.LT.1.0E-3) ZI=0.0 + PL(IOF,N)=PNSH(L,M,ZI,DU(N),DE(N)) + 200 CONTINUE + 210 CONTINUE + 211 CONTINUE +*---- +* GENERATE MAPPING MATRIX FOR GALERKIN QUADRATURE METHOD +*---- + MN(:NPQ,:NSCT)=0.0 + DN(:NSCT,:NPQ)=0.0 + IL(:NSCT)=0 + IM(:NSCT)=0 + IF(IGLK.NE.0) THEN + ALLOCATE(U(NPQ,NPQ),RLM(NPQ,ISCAT,2*ISCAT-1),V(NPQ),V2(NPQ), + 1 MND(NPQ,NPQ)) + RLM(:NPQ,:ISCAT,:2*ISCAT-1)=0.0 + DO L=0,ISCAT-1 + DO M=-L,L + DO N=1,NPQ + ZI=SQRT(ABS(1.0-DU(N)**2-DE(N)**2)) + IF(ZI.LT.1.0E-3) ZI=0.0 + RLM(N,L+1,M+L+1)=PNSH(L,M,DU(N),DE(N),ZI) + ENDDO + ENDDO + ENDDO + ! GRAM-SCHMIDT PROCEDURE TO FIND INDEPENDANT SET + ! OF SPHERICAL HARMONICS WITH ANY QUADRATURE + U(:NPQ,:NPQ)=0.0D0 + NORM=0.0D0 + DO N=1,NPQ + NORM=NORM+RLM(N,1,1)**2 + ENDDO + NORM=SQRT(NORM) + DO N=1,NPQ + IF(IGLK.EQ.1) THEN + MND(1,N)=2.0D0*W(N)*RLM(N,1,1) + ELSEIF(IGLK.EQ.2) THEN + MND(N,1)=(2.0*L+1.0)/(4.0*PI)*RLM(N,1,1) + ELSE + CALL XABORT('UNKNOWN GALERKIN QUADRATURE METHOD.') + ENDIF + U(N,1)=RLM(N,1,1)/NORM + ENDDO + IND=1 + ! ITERATE OVER THE SPHERICAL HARMONICS + DO 212 L=1,ISCAT-1 + DO 213 M=0,L + V2(:NPQ)=0.0D0 + DO N=1,IND + IPROD=0.0D0 + DO N2=1,NPQ + IPROD=IPROD+U(N2,N)*RLM(N2,L+1,M+L+1) + ENDDO + DO N2=1,NPQ + V2(N2)=V2(N2)+IPROD*U(N2,N) + ENDDO + ENDDO + V(:NPQ)=0.0D0 + DO N=1,NPQ + V(N)=RLM(N,L+1,M+L+1)-V2(N) + ENDDO + NORM=0.0D0 + DO N=1,NPQ + NORM=NORM+V(N)**2 + ENDDO + NORM=SQRT(NORM) + ! KEEP THE SPHERICAL HARMONICS IF IT IS INDEPENDANT + IF(NORM.GE.1.0E-5) THEN + IND=IND+1 + DO N=1,NPQ + U(N,IND)=V(N)/NORM + IF(IGLK.EQ.1) THEN + MND(IND,N)=2.0D0*W(N)*RLM(N,L+1,M+L+1) + ELSEIF(IGLK.EQ.2) THEN + MND(N,IND)=(2.0*L+1.0)/(4.0*PI)*RLM(N,L+1,M+L+1) + ELSE + CALL XABORT('UNKNOWN GALERKIN QUADRATURE METHOD.') + ENDIF + ENDDO + IL(IND)=L + IM(IND)=M + ENDIF + IF(IND.EQ.NPQ) GOTO 217 + 213 ENDDO + 212 ENDDO + CALL XABORT('SNTT2D: THE'// + 1 ' GRAM-SCHMIDTH PROCEDURE TO FIND A SUITABLE INTERPOLATION'// + 2 ' BASIS REQUIRE HIGHER LEGENDRE ORDER.') + ! FIND INVERSE MATRIX + 217 IF(IGLK.EQ.1) THEN + DN=REAL(MND) + CALL ALINVD(NPQ,MND,NPQ,IER) + IF(IER.NE.0) CALL XABORT('SNTT2D: SINGULAR MATRIX.') + MN=REAL(MND) + ELSEIF(IGLK.EQ.2) THEN + MN=REAL(MND) + CALL ALINVD(NPQ,MND,NPQ,IER) + IF(IER.NE.0) CALL XABORT('SNTT2D: SINGULAR MATRIX.') + DN=REAL(MND) + ELSE + CALL XABORT('UNKNOWN GALERKIN QUADRATURE METHOD.') + ENDIF + DEALLOCATE(U,RLM,V,V2,MND) + ELSE + IND=1 + DO L=0,ISCAT-1 + DO 218 M=-L,L + IF(MOD(L+M,2).EQ.1) GO TO 218 + IL(IND)=L + IM(IND)=M + DO N=1,NPQ + ZI=SQRT(ABS(1.0-DU(N)**2-DE(N)**2)) + IF(ZI.LT.1.0E-3) ZI=0.0 + DN(IND,N)=2.0*W(N)*PNSH(L,M,ZI,DU(N),DE(N)) + MN(N,IND)=(2.0*L+1.0)/(4.0*PI) + 1 *PNSH(L,M,ZI,DU(N),DE(N)) + ENDDO + IND=IND+1 + 218 ENDDO + ENDDO + ENDIF +*---- +* GENERATE THE WEIGHTING PARAMETERS OF THE CLOSURE RELATION. +*---- + PX=1 + PE=1 + IF(ISCHM.EQ.1.OR.ISCHM.EQ.3) THEN + PX=1 + ELSEIF(ISCHM.EQ.2) THEN + PX=0 + ELSE + CALL XABORT('SNTT2D: UNKNOWN TYPE OF SPATIAL CLOSURE RELATION.') + ENDIF + IF(MOD(IELEM,2).EQ.1) THEN + WX(1)=-PX + WX(2:IELEM+1:2)=1+PX + IF(IELEM.GE.2) WX(3:IELEM+1:2)=1-PX + ELSE + WX(1)=PX + WX(2:IELEM+1:2)=1-PX + IF(IELEM.GE.2) WX(3:IELEM+1:2)=1+PX + ENDIF + IF(IBFP.NE.0) THEN + IF(ESCHM.EQ.1.OR.ESCHM.EQ.3) THEN + PE=1 + ELSEIF(ESCHM.EQ.2) THEN + PE=0 + ELSE + CALL XABORT('SNTT2D: UNKNOWN TYPE OF ENERGY CLOSURE RELATION.') + ENDIF + IF(MOD(EELEM,2).EQ.1) THEN + WE(1)=-PE + WE(2:EELEM+1:2)=1+PE + IF(EELEM.GE.2) WE(3:EELEM+1:2)=1-PE + ELSE + WE(1)=PE + WE(2:EELEM+1:2)=1-PE + IF(EELEM.GE.2) WE(3:EELEM+1:2)=1+PE + ENDIF + ENDIF + ! NORMALIZED LEGENDRE POLYNOMIAL CONSTANTS + DO IEL=1,MAX(IELEM,EELEM) + CST(IEL)=SQRT(2.0*IEL-1.0) + ENDDO +*---- +* COMPUTE ISOTROPIC FLUX INDICES. +*---- + NM=IELEM*IELEM*EELEM + NMX=IELEM*EELEM + NMY=IELEM*EELEM + NME=IELEM**2 + LL4=LX*LY*NSCT*NM + IF(IGE.LT.2) THEN + NUN=LL4+(LX*NMY+LY*NMX)*NPQ + DO I=1,LX*LY + IDL(I)=(I-1)*NSCT*NM+1 + ENDDO + ELSEIF(IGE.EQ.2) THEN + NUN=LL4 + DO I=1,LX + IDL(I)=(I-1)*NSCT*NM+1 + ENDDO + ELSE + CALL XABORT('SNTT2D: CHECK SPATIAL SCHEME DISCRETISATION '// + 1 'PARAMETER.') + ENDIF +*---- +* SET BOUNDARY CONDITIONS. +*---- + DO 240 I=1,4 + IF(NCODE(I).NE.1) ZCODE(I)=1.0 + IF(NCODE(I).EQ.5) CALL XABORT('SNTT2D: SYME BC NOT ALLOWED.') + IF(NCODE(I).EQ.7) CALL XABORT('SNTT2D: ZERO FLUX BC NOT ALLOWED.') + 240 CONTINUE +*---- +* CHECK FOR INVALID VIRTUAL ELEMENTS. +*---- + DO 295 I=2,LX-1 + DO 290 J=2,LY-1 + IF(MAT(I,J).EQ.0) THEN + L1=(NCODE(1).NE.1) + DO 250 J1=1,J-1 + L1=L1.OR.(MAT(I,J1).NE.0) + 250 CONTINUE + L2=(NCODE(2).NE.1) + DO 260 J1=J+1,LY + L2=L2.OR.(MAT(I,J1).NE.0) + 260 CONTINUE + L3=(NCODE(3).NE.1) + DO 270 I1=1,I-1 + L3=L3.OR.(MAT(I1,J).NE.0) + 270 CONTINUE + L4=(NCODE(4).NE.1) + DO 280 I1=I+1,LX + L4=L4.OR.(MAT(I1,J).NE.0) + 280 CONTINUE + IF(L1.AND.L2.AND.L3.AND.L4) THEN + WRITE(HSMG,'(17HSNTT2D: ELEMENT (,I3,1H,,I3,11H) CANNOT BE, + 1 9H VIRTUAL.)') I,J + CALL XABORT(HSMG) + ENDIF + ENDIF + 290 CONTINUE + 295 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(YY,XX) + RETURN + END diff --git a/Dragon/src/SNTT3D.f b/Dragon/src/SNTT3D.f new file mode 100644 index 0000000..3162d44 --- /dev/null +++ b/Dragon/src/SNTT3D.f @@ -0,0 +1,609 @@ +*DECK SNTT3D + SUBROUTINE SNTT3D(IGE,IMPX,LX,LY,LZ,SIDE,IELEM,NLF,NPQ,NSCT,IQUAD, + 1 NCODE,ZCODE,MAT,XXX,YYY,ZZZ,VOL,IDL,DU,DE,DZ,W,MRMX,MRMY,MRMZ,DC, + 2 DB,DA,PL,LL4,NUN,EELEM,WX,WE,CST,IBFP,ISCHM,ESCHM,IGLK,MN,DN,IL, + 3 IM,ISCAT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Numbering corresponding to a 3-D Cartesian with discrete ordinates +* approximation of the flux. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): N. Martin and C. Bienvenue +* +*Parameters: input +* IGE geometry type with (=0 for Cartesian, =2 for hexagonal). +* IMPX print parameter. +* LX number of elements along the X axis; +* OR, number of elements in X-Y plane in hexagonal geometry, +* including lozenges and further submeshing of lozenges +* e.g. domain of 7 hex. by 5 levels with a submeshing of 2 +* will have LX=7*3*2*2=84 +* LY number of elements along the Y axis. +* LZ number of elements along the Z axis. +* SIDE side of hexagon. +* IELEM measure of order of the spatial approximation polynomial: +* =1 constant - only for HODD, classical diamond scheme +* (default for HODD); +* =2 linear - default for DG; +* =3 parabolic; +* =4 cubic - only for DG. +* NLF SN order for the flux (even number). +* NPQ number of SN directions in eight octants. +* NSCT maximum number of spherical harmonics moments of the flux. +* IQUAD type of SN quadrature (1 Level symmetric, type IQUAD; +* 4 Legendre-Chebyshev; 5 symmetric Legendre-Chebyshev; +* 6 quadruple range). +* NCODE type of boundary condition applied on each side +* (i=1 X-; i=2 X+; i=3 Y-; i=4 Y+; i=5 Z-; i=6 Z+): +* =1 VOID; =2 REFL; =4 TRAN. +* ZCODE ZCODE(I) is the albedo corresponding to boundary condition +* 'VOID' on each side (ZCODE(I)=0.0 by default). +* MAT mixture index assigned to each element. +* XXX Cartesian coordinates along the X axis. +* YYY Cartesian coordinates along the Y axis. +* ZZZ Cartesian coordinates along the Z axis. +* EELEM measure of order of the energy approximation polynomial: +* =1 constant - default for HODD; +* =2 linear - default for DG; +* >3 higher orders. +* IBFP type of energy proparation relation: +* =0 no Fokker-Planck term; +* =1 Galerkin type; +* =2 heuristic Przybylski and Ligou type. +* ISCHM method of spatial discretisation: +* =1 High-Order Diamond Differencing (HODD) - default; +* =2 Discontinuous Galerkin finite element method (DG); +* =3 Adaptive weighted method (AWD). +* ESCHM method of energy discretisation: +* =1 High-Order Diamond Differencing (HODD) - default; +* =2 Discontinuous Galerkin finite element method (DG); +* =3 Adaptive weighted method (AWD). +* IGLK angular interpolation type: +* =0 classical SN method. +* =1 Galerkin quadrature method (M = inv(D)) +* =2 Galerkin quadrature method (D = inv(M)) +* ISCAT maximum number of spherical harmonics moments of the flux. +* +*Parameters: output +* VOL volume of each element. +* IDL isotropic flux indices. +* DU first direction cosines ($\\mu$). +* DE second direction cosines ($\\eta$). +* DZ third direction cosines ($\\xi$). +* W weights. +* MRMX quadrature index. +* MRMY quadrature index. +* MRMZ quadrature index. +* DC diamond-scheme parameter. +* DB diamond-scheme parameter. +* DA diamond-scheme parameter. +* PL discrete values of the spherical harmonics corresponding +* to the 3D SN quadrature. +* LL4 number of unknowns being solved for, over the domain. This +* includes the various moments of the isotropic (and if present, +* anisotropic) flux. +* NUN total number of unknowns stored in the FLUX vector per group. +* This includes LL4 (see above) as well as any surface boundary +* fluxes, if present. +* WX spatial closure relation weighting factors. +* WE energy closure relation weighting factors. +* CST constants for the polynomial approximations. +* MN moment-to-discrete matrix. +* DN discrete-to-moment matrix. +* IL indexes (l) of each spherical harmonics in the +* interpolation basis. +* IM indexes (m) of each spherical harmonics in the +* interpolation basis. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IMPX,LX,LY,LZ,IELEM,NLF,NPQ,NSCT,IQUAD,NCODE(6), + 1 MAT(LX,LY,LZ),IDL(LX*LY*LZ),MRMX(NPQ),MRMY(NPQ),MRMZ(NPQ),EELEM, + 2 IBFP,ISCHM,ESCHM,IL(NSCT),IM(NSCT),ISCAT,IGLK + REAL ZCODE(6),VOL(LX,LY,LZ),XXX(LX+1),YYY(LY+1),ZZZ(LZ+1), + 1 DU(NPQ),DE(NPQ),DZ(NPQ),W(NPQ),DC(LX,LY,NPQ),DB(LX,LZ,NPQ), + 2 DA(LY,LZ,NPQ),PL(NSCT,NPQ),WX(IELEM+1), + 3 WE(EELEM+1),CST(MAX(IELEM,EELEM)),MN(NPQ,NSCT),DN(NSCT,NPQ) +*---- +* LOCAL VARIABLES +*---- + CHARACTER HSMG*131 + LOGICAL L1,L2,L3,L4,L5,L6 + PARAMETER(RLOG=1.0E-8,PI=3.141592654) + REAL PX,PE + DOUBLE PRECISION MND(NPQ,NPQ),NORM,IPROD + INTEGER, ALLOCATABLE, DIMENSION(:) :: JOP + REAL, ALLOCATABLE, DIMENSION(:) :: XX,YY,ZZ,UU,WW,TPQ,UPQ,VPQ,WPQ + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: V,V2 + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: U + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: RLM +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(XX(LX),YY(LY),ZZ(LZ)) +*---- +* UNFOLD HEIGHT-OCTANT QUADRATURES. +*---- + IF(MOD(NLF,2).EQ.1) CALL XABORT('SNTT3D: EVEN NLF EXPECTED.') + IF(IQUAD.EQ.10) THEN + NPQ0=NLF**2/4 + ELSE + NPQ0=NLF*(NLF/2+1)/4 + ENDIF + ALLOCATE(JOP(NLF/2),UU(NLF/2),WW(NLF/2),TPQ(NPQ0),UPQ(NPQ0), + 1 VPQ(NPQ0),WPQ(NPQ0)) + IF(IQUAD.EQ.1) THEN +!Level-symmetric quadrature of type 1 + CALL SNQU01(NLF,JOP,UU,WW,TPQ,UPQ,VPQ,WPQ) + ELSE IF(IQUAD.EQ.2) THEN +!Level-symmetric quadrature of type 2 + CALL SNQU02(NLF,JOP,UU,WW,TPQ,UPQ,VPQ,WPQ) + ELSE IF(IQUAD.EQ.3) THEN +!Snow Level-symmetric type quadrature + CALL SNQU03(NLF,JOP,UU,WW,TPQ,UPQ,VPQ,WPQ) + ELSE IF(IQUAD.EQ.4) THEN +!Legendre-Chebyshev quadrature + CALL SNQU04(NLF,JOP,UU,WW,TPQ,UPQ,VPQ,WPQ) + ELSE IF(IQUAD.EQ.5) THEN +!Symmetric Legendre-Chebyshev quadrature + CALL SNQU05(NLF,TPQ,UPQ,VPQ,WPQ) + ELSE IF(IQUAD.EQ.6) THEN +!Quadruple Range quadrature + CALL SNQU06(NLF,TPQ,UPQ,VPQ,WPQ) + ELSE IF(IQUAD.EQ.10) THEN + CALL SNQU10(NLF,JOP,UU,WW,TPQ,UPQ,VPQ,WPQ) + ELSE + CALL XABORT('SNTT3D: UNKNOWN QUADRATURE TYPE.') + ENDIF + N=0 + IOF=0 + DO 320 I=1,NLF/2 + JOF=IOF+NLF-2*I+2 + DO 330 J=0,NLF/2-I + IOF=IOF+1 + KOF=IOF+(NLF+2)*NLF/4 + LOF=IOF+(NLF+2)*NLF/2 + MRMX(IOF)=JOF + MRMY(IOF)=KOF + MRMZ(IOF)=LOF + DU(IOF)=-UPQ(N+J+1) + DE(IOF)=-VPQ(N+J+1) + DZ(IOF)=-TPQ(N+J+1) + W(IOF)=WPQ(N+J+1) + JOF=JOF-1 + 330 CONTINUE + DO 340 J=NLF/2-I,0,-1 + IOF=IOF+1 + KOF=IOF+(NLF+2)*NLF/4 + LOF=IOF+(NLF+2)*NLF/2 + MRMX(IOF)=JOF + MRMY(IOF)=KOF + MRMZ(IOF)=LOF + DU(IOF)=UPQ(N+J+1) + DE(IOF)=-VPQ(N+J+1) + DZ(IOF)=-TPQ(N+J+1) + W(IOF)=WPQ(N+J+1) + JOF=JOF-1 + 340 CONTINUE + N=N+NLF/2-I+1 + 320 CONTINUE + N=0 + DO 350 I=1,NLF/2 + JOF=IOF+NLF-2*I+2 + DO 360 J=0,NLF/2-I + IOF=IOF+1 + KOF=IOF-(NLF+2)*NLF/4 + LOF=IOF+(NLF+2)*NLF/2 + MRMX(IOF)=JOF + MRMY(IOF)=KOF + MRMZ(IOF)=LOF + DU(IOF)=-UPQ(N+J+1) + DE(IOF)=VPQ(N+J+1) + DZ(IOF)=-TPQ(N+J+1) + W(IOF)=WPQ(N+J+1) + JOF=JOF-1 + 360 CONTINUE + DO 370 J=NLF/2-I,0,-1 + IOF=IOF+1 + KOF=IOF-(NLF+2)*NLF/4 + LOF=IOF+(NLF+2)*NLF/2 + MRMX(IOF)=JOF + MRMY(IOF)=KOF + MRMZ(IOF)=LOF + DU(IOF)=UPQ(N+J+1) + DE(IOF)=VPQ(N+J+1) + DZ(IOF)=-TPQ(N+J+1) + W(IOF)=WPQ(N+J+1) + JOF=JOF-1 + 370 CONTINUE + N=N+NLF/2-I+1 + 350 CONTINUE + N=0 + DO 380 I=1,NLF/2 + JOF=IOF+NLF-2*I+2 + DO 390 J=0,NLF/2-I + IOF=IOF+1 + KOF=IOF+(NLF+2)*NLF/4 + LOF=IOF-(NLF+2)*NLF/2 + MRMX(IOF)=JOF + MRMY(IOF)=KOF + MRMZ(IOF)=LOF + DU(IOF)=-UPQ(N+J+1) + DE(IOF)=-VPQ(N+J+1) + DZ(IOF)=TPQ(N+J+1) + W(IOF)=WPQ(N+J+1) + JOF=JOF-1 + 390 CONTINUE + DO 400 J=NLF/2-I,0,-1 + IOF=IOF+1 + KOF=IOF+(NLF+2)*NLF/4 + LOF=IOF-(NLF+2)*NLF/2 + MRMX(IOF)=JOF + MRMY(IOF)=KOF + MRMZ(IOF)=LOF + DU(IOF)=UPQ(N+J+1) + DE(IOF)=-VPQ(N+J+1) + DZ(IOF)=TPQ(N+J+1) + W(IOF)=WPQ(N+J+1) + JOF=JOF-1 + 400 CONTINUE + N=N+NLF/2-I+1 + 380 CONTINUE + N=0 + DO 410 I=1,NLF/2 + JOF=IOF+NLF-2*I+2 + DO 420 J=0,NLF/2-I + IOF=IOF+1 + KOF=IOF-(NLF+2)*NLF/4 + LOF=IOF-(NLF+2)*NLF/2 + MRMX(IOF)=JOF + MRMY(IOF)=KOF + MRMZ(IOF)=LOF + DU(IOF)=-UPQ(N+J+1) + DE(IOF)=VPQ(N+J+1) + DZ(IOF)=TPQ(N+J+1) + W(IOF)=WPQ(N+J+1) + JOF=JOF-1 + 420 CONTINUE + DO 430 J=NLF/2-I,0,-1 + IOF=IOF+1 + KOF=IOF-(NLF+2)*NLF/4 + LOF=IOF-(NLF+2)*NLF/2 + MRMX(IOF)=JOF + MRMY(IOF)=KOF + MRMZ(IOF)=LOF + DU(IOF)=UPQ(N+J+1) + DE(IOF)=VPQ(N+J+1) + DZ(IOF)=TPQ(N+J+1) + W(IOF)=WPQ(N+J+1) + JOF=JOF-1 + 430 CONTINUE + N=N+NLF/2-I+1 + 410 CONTINUE + DEALLOCATE(WPQ,VPQ,UPQ,TPQ,WW,UU,JOP) + IF(IMPX.GE.4) THEN + WRITE(6,'(/41H SNTT3D:HEIGHT-OCTANT ANGULAR QUADRATURES:/26X, + 1 2HMU,9X,3HETA,10X,2HXI,6X,6HWEIGHT)') + SUM=0.0 + DO 70 N=1,NPQ + SUM=SUM+W(N) + WRITE(6,'(1X,4I5,1P,4E12.4)') N,MRMX(N),MRMY(N),MRMZ(N),DU(N), + 1 DE(N),DZ(N),W(N) + 70 CONTINUE + WRITE(6,'(54X,10(1H-)/52X,1P,E12.4)') SUM + ENDIF +*---- +* IDENTIFICATION OF THE GEOMETRY. +*---- + IF(IGE.EQ.0) THEN +* ---------- +* 3D CARTESIAN +* ---------- + DO 83 N=1,NPQ + VU=DU(N) + VE=DE(N) + VZ=DZ(N) + DO 82 I=1,LX + DO 81 J=1,LY + DO 80 K=1,LZ + XX(I)=XXX(I+1)-XXX(I) + YY(J)=YYY(J+1)-YYY(J) + ZZ(K)=ZZZ(K+1)-ZZZ(K) + DA(J,K,N)=VU*YY(J)*ZZ(K) + DB(I,K,N)=VE*XX(I)*ZZ(K) + DC(I,J,N)=VZ*XX(I)*YY(J) + VOL(I,J,K)=XX(I)*YY(J)*ZZ(K) + 80 CONTINUE + 81 CONTINUE + 82 CONTINUE + 83 CONTINUE + ELSEIF(IGE.EQ.2) THEN +* ---------- +* 3D HEXAGONAL +* ---------- + DET = SQRT(3.0)*(SIDE**2)/2.0 + DO 93 N=1,NPQ + VU=DU(N) + VE=DE(N) + VZ=DZ(N) + DO 92 K=1,LZ + DO 91 J=1,LY + DO 90 I=1,LX + ZZ(K)=ZZZ(K+1)-ZZZ(K) + DA(J,K,N)=VU*ZZ(K) + DB(I,K,N)=VE*ZZ(K) + DC(I,J,N)=VZ*DET + VOL(I,J,K)=DET*ZZ(K) + 90 CONTINUE + 91 CONTINUE + 92 CONTINUE + 93 CONTINUE + ENDIF +*---- +* GENERATE SPHERICAL HARMONICS FOR SCATTERING SOURCE. +*---- + IOF=0 + DO 211 L=0,ISCAT-1 + DO 210 M=-L,L + IOF=IOF+1 + IF(IOF.GT.ISCAT) GO TO 211 + DO 200 N=1,NPQ + PL(IOF,N)=PNSH(L,M,DU(N),DE(N),DZ(N)) + 200 CONTINUE + 210 CONTINUE + 211 CONTINUE +*---- +* GENERATE MAPPING MATRIX FOR GALERKIN QUADRATURE METHOD +*---- + MN(:NPQ,:NSCT)=0.0 + DN(:NSCT,:NPQ)=0.0 + IL(:NSCT)=0 + IM(:NSCT)=0 + IF(IGLK.NE.0) THEN + ALLOCATE(U(NPQ,NPQ),RLM(NPQ,ISCAT,2*ISCAT-1),V(NPQ),V2(NPQ)) + RLM(:NPQ,:ISCAT-1,:2*ISCAT-1)=0.0 + DO L=0,ISCAT-1 + DO M=-L,L + DO N=1,NPQ + RLM(N,L+1,M+L+1)=PNSH(L,M,DU(N),DE(N),DZ(N)) + ENDDO + ENDDO + ENDDO + ! GRAM-SCHMIDT PROCEDURE TO FIND INDEPENDANT SET + ! OF SPHERICAL HARMONICS WITH ANY QUADRATURE + U(:NPQ,:NPQ)=0.0D0 + NORM=0.0D0 + DO N=1,NPQ + NORM=NORM+RLM(N,1,1)**2 + ENDDO + NORM=SQRT(NORM) + DO N=1,NPQ + IF(IGLK.EQ.1) THEN + MND(1,N)=W(N)*RLM(N,1,1) + ELSEIF(IGLK.EQ.2) THEN + MND(N,1)=(2.0*L+1.0)/(4.0*PI)*RLM(N,1,1) + ELSE + CALL XABORT('UNKNOWN GALERKIN QUADRATURE METHOD.') + ENDIF + U(N,1)=RLM(N,1,1)/NORM + ENDDO + IND=1 + ! ITERATE OVER THE SPHERICAL HARMONICS + DO 212 L=1,ISCAT-1 + DO 213 M=-L,L + V2(:NPQ)=0.0D0 + DO N=1,IND + IPROD=0.0D0 + DO N2=1,NPQ + IPROD=IPROD+U(N2,N)*RLM(N2,L+1,M+L+1) + ENDDO + DO N2=1,NPQ + V2(N2)=V2(N2)+IPROD*U(N2,N) + ENDDO + ENDDO + V(:NPQ)=0.0D0 + DO N=1,NPQ + V(N)=RLM(N,L+1,M+L+1)-V2(N) + ENDDO + NORM=0.0D0 + DO N=1,NPQ + NORM=NORM+V(N)**2 + ENDDO + NORM=SQRT(NORM) + ! KEEP THE SPHERICAL HARMONICS IF IT IS INDEPENDANT + IF(NORM.GE.1.0E-5) THEN + IND=IND+1 + DO N=1,NPQ + U(N,IND)=V(N)/NORM + IF(IGLK.EQ.1) THEN + MND(IND,N)=W(N)*RLM(N,L+1,M+L+1) + ELSEIF(IGLK.EQ.2) THEN + MND(N,IND)=(2.0*L+1.0)/(4.0*PI)*RLM(N,L+1,M+L+1) + ELSE + CALL XABORT('UNKNOWN GALERKIN QUADRATURE METHOD.') + ENDIF + ENDDO + IL(IND)=L + IM(IND)=M + ENDIF + IF(IND.EQ.NPQ) GOTO 217 + 213 ENDDO + 212 ENDDO + CALL XABORT('SNTT3D: THE'// + 1 ' GRAM-SCHMIDTH PROCEDURE TO FIND A SUITABLE INTERPOLATION'// + 2 ' BASIS REQUIRE HIGHER LEGENDRE ORDER.') + ! FIND INVERSE MATRIX + 217 IF(IGLK.EQ.1) THEN + DN=REAL(MND) + CALL ALINVD(NPQ,MND,NPQ,IER) + IF(IER.NE.0) CALL XABORT('SNTT3D: SINGULAR MATRIX.') + MN=REAL(MND) + ELSEIF(IGLK.EQ.2) THEN + MN=REAL(MND) + CALL ALINVD(NPQ,MND,NPQ,IER) + IF(IER.NE.0) CALL XABORT('SNTT3D: SINGULAR MATRIX.') + DN=REAL(MND) + ELSE + CALL XABORT('UNKNOWN GALERKIN QUADRATURE METHOD.') + ENDIF + DEALLOCATE(U,RLM,V,V2) + ELSE + IND=1 + DO L=0,ISCAT-1 + DO 218 M=-L,L + IL(IND)=L + IM(IND)=M + DO N=1,NPQ + DN(IND,N)=W(N)*PNSH(L,M,DU(N),DE(N),DZ(N)) + MN(N,IND)=(2.0*L+1.0)/(4.0*PI) + 1 *PNSH(L,M,DU(N),DE(N),DZ(N)) + ENDDO + IND=IND+1 + 218 ENDDO + ENDDO + ENDIF +*---- +* GENERATE THE WEIGHTING PARAMETERS OF THE CLOSURE RELATION. +*---- + PX=1 + PE=1 + IF(ISCHM.EQ.1.OR.ISCHM.EQ.3) THEN + PX=1 + ELSEIF(ISCHM.EQ.2) THEN + PX=0 + ELSE + CALL XABORT('SNTT3D: UNKNOWN TYPE OF SPATIAL CLOSURE RELATION.') + ENDIF + IF(MOD(IELEM,2).EQ.1) THEN + WX(1)=-PX + WX(2:IELEM+1:2)=1+PX + IF(IELEM.GE.2) WX(3:IELEM+1:2)=1-PX + ELSE + WX(1)=PX + WX(2:IELEM+1:2)=1-PX + IF(IELEM.GE.2) WX(3:IELEM+1:2)=1+PX + ENDIF + IF(IBFP.NE.0) THEN + IF(ESCHM.EQ.1.OR.ESCHM.EQ.3) THEN + PE=1 + ELSEIF(ESCHM.EQ.2) THEN + PE=0 + ELSE + CALL XABORT('SNTT3D: UNKNOWN TYPE OF ENERGY CLOSURE RELATION.') + ENDIF + IF(MOD(EELEM,2).EQ.1) THEN + WE(1)=-PE + WE(2:EELEM+1:2)=1+PE + IF(EELEM.GE.2) WE(3:EELEM+1:2)=1-PE + ELSE + WE(1)=PE + WE(2:EELEM+1:2)=1-PE + IF(EELEM.GE.2) WE(3:EELEM+1:2)=1+PE + ENDIF + ENDIF + ! NORMALIZED LEGENDRE POLYNOMIAL CONSTANTS + DO IEL=1,MAX(IELEM,EELEM) + CST(IEL)=SQRT(2.0*IEL-1.0) + ENDDO +*---- +* COMPUTE ISOTROPIC FLUX INDICES. +*---- + NM=IELEM**3*EELEM + NMX=IELEM**2*EELEM + NMY=NMX + NMZ=NMX + NME=IELEM**3 + LL4=LX*LY*LZ*NSCT*NM + IF(IGE.EQ.0)THEN + NUN=LL4+(NMX*LY*LZ+NMY*LX*LZ+NMZ*LX*LY)*NPQ + ELSEIF(IGE.EQ.2)THEN + IF((NCODE(5)==1).and.(NCODE(5)==NCODE(6)))THEN + NUN=LL4 + ELSE + NUN=LL4+(LX*LY*LZ)*NMZ*NPQ + ENDIF + ELSE + CALL XABORT('SNTT3D: CHECK SPATIAL SCHEME DISCRETISATION '// + 1 'PARAMETER.') + ENDIF + DO I=1,LX*LY*LZ + IDL(I)=(I-1)*NSCT*NM+1 + ENDDO +*---- +* SET BOUNDARY CONDITIONS. +*---- + DO 240 I=1,6 + IF(NCODE(I).NE.1) ZCODE(I)=1.0 + IF(NCODE(I).EQ.5) CALL XABORT('SNTT3D: SYME BC NOT ALLOWED.') + IF(NCODE(I).EQ.7) CALL XABORT('SNTT3D: ZERO FLUX BC NOT ALLOWED.') + 240 CONTINUE +*---- +* CHECK FOR INVALID VIRTUAL ELEMENTS. +*---- + DO 292 I=2,LX-1 + DO 291 J=2,LY-1 + DO 290 K=2,LZ-1 + IF(MAT(I,J,K).EQ.0) THEN + L1=(NCODE(1).NE.1) + DO 251 J1=1,J-1 + DO 250 K1=1,K-1 + L1=L1.OR.(MAT(I,J1,K1).NE.0) + 250 CONTINUE + 251 CONTINUE + L2=(NCODE(2).NE.1) + DO 261 J1=J+1,LY + DO 260 K1=K+1,LZ + L2=L2.OR.(MAT(I,J1,K1).NE.0) + 260 CONTINUE + 261 CONTINUE + L3=(NCODE(3).NE.1) + DO 271 I1=1,I-1 + DO 270 K1=1,K-1 + L3=L3.OR.(MAT(I1,J,K1).NE.0) + 270 CONTINUE + 271 CONTINUE + L4=(NCODE(4).NE.1) + DO 281 I1=I+1,LX + DO 280 K1=K+1,LZ + L4=L4.OR.(MAT(I1,J,K1).NE.0) + 280 CONTINUE + 281 CONTINUE + L5=(NCODE(5).NE.1) + DO 301 I1=1,I-1 + DO 300 J1=1,J-1 + L5=L5.OR.(MAT(I1,J1,K).NE.0) + 300 CONTINUE + 301 CONTINUE + L6=(NCODE(6).NE.0) + DO 311 I1=I+1,LX + DO 310 J1=I+1,LY + L6=L6.OR.(MAT(I1,J1,K).NE.0) + 310 CONTINUE + 311 CONTINUE + IF(L1.AND.L2.AND.L3.AND.L4.AND.L5.AND.L6) THEN + WRITE(HSMG,'(17HSNTT3D: ELEMENT (,I3,1H,,I3,11H) CANNOT BE, + 1 9H VIRTUAL.)') I,J,K + CALL XABORT(HSMG) + ENDIF + ENDIF + 290 CONTINUE + 291 CONTINUE + 292 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(ZZ,YY,XX) + RETURN + END diff --git a/Dragon/src/SPH.F b/Dragon/src/SPH.F new file mode 100644 index 0000000..abc1c21 --- /dev/null +++ b/Dragon/src/SPH.F @@ -0,0 +1,900 @@ +*DECK SPH + SUBROUTINE SPH(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Superhomogeneisation (SPH) procedure. +* +*Copyright: +* Copyright (C) 2011 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1) Edition (L_EDIT), Microlib (L_LIBRARY), +* Macrolib (L_MACROLIB) or Saphyb (L_SAPHYB) object; +* HENTRY(I) I>1 read-only type (Edition (L_EDIT) and/or +* L_MACROLIB and/or L_LIBRARY and/or L_SAPHYB and/or L_TRACK). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file; =6 HDF5 file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +#if defined(HDF5_LIB) + USE hdf5_wrap +#endif /* defined(HDF5_LIB) */ +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40,IOUT=6,MAXISD=400) + INTEGER ISTATE(NSTATE),DIMSAP(50) + CHARACTER CNDOOR*12,HSIGN*12,HSMG*131,TEXT12*12,HEDIT*12, + 1 HEQUI*4,HMASL*4,HEQNAM*80,HFORMAT*132 + LOGICAL LARM,LTEMP,LNEW,LLEAK + REAL REALIR + DOUBLE PRECISION DFLOT + TYPE(C_PTR) IPTRK,IPFLX,IPOUT,IPRHS,IPMICR,IPMACR,IPSAP,IPAPX, + 1 JPMAC,KPMAC,IPEDIT,IPSPH,IPCPO,IPOPT +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: WORK1,WORK2 + REAL, ALLOCATABLE, DIMENSION(:,:) :: SPH2,SPOLD + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: VARV +*---- +* APEX LOCAL VARIABLES +*---- +#if defined(HDF5_LIB) + LOGICAL LFROM,LMPO + CHARACTER TEXT80*80,RECNAM*80 + CHARACTER(LEN=100), ALLOCATABLE, DIMENSION(:) :: LIST + INTEGER, ALLOCATABLE, DIMENSION(:) :: DIMS_APX + REAL, ALLOCATABLE, DIMENSION(:) :: XVOLM + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: OUPUTID +#endif /* defined(HDF5_LIB) */ +*---- +* PARAMETER VALIDATION. +*---- + IPTRK=C_NULL_PTR + IFTRK=0 + IPFLX=C_NULL_PTR + IPOPT=C_NULL_PTR + IF(NENTRY.EQ.0) CALL XABORT('SPH: MISSING PARAMETERS(1).') + IMIN=1 + ITYPE=0 + IPOUT=KENTRY(1) + IF((IENTRY(1).LE.2).AND.(JENTRY(1).EQ.0)) THEN + IMIN=3 + IF(NENTRY.EQ.1) CALL XABORT('SPH: MISSING PARAMETERS(2).') + IF((IENTRY(2).LE.2).AND.(JENTRY(2).EQ.2)) THEN + IPRHS=KENTRY(2) + ELSE IF((IENTRY(2).EQ.6).AND.(JENTRY(2).EQ.2)) THEN + IPRHS=KENTRY(2) + ITYPE=6 ! Apex file in extraction mode + ELSE + CALL XABORT('SPH: RHS LCM OR HDF5 OBJECT EXPECTED.') + ENDIF + ELSE IF((IENTRY(1).LE.2).AND.(JENTRY(1).EQ.1)) THEN + IMIN=2 + IPRHS=IPOUT + ELSE IF((IENTRY(1).EQ.6).AND.(JENTRY(1).EQ.1)) THEN + ITYPE=6 ! Apex file in modification mode + IMIN=2 + IPRHS=IPOUT + ELSE + CALL XABORT('SPH: LHS LCM OR HDF5 OBJECT EXPECTED.') + ENDIF + IF(ITYPE.EQ.0) THEN + CALL LCMGTC(KENTRY(IMIN-1),'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_EDIT') THEN + ITYPE=1 + ELSE IF(HSIGN.EQ.'L_LIBRARY') THEN + ITYPE=2 + ELSE IF(HSIGN.EQ.'L_MACROLIB') THEN + ITYPE=3 + ELSE IF(HSIGN.EQ.'L_SAPHYB') THEN + ITYPE=4 + ELSE IF(HSIGN.EQ.'L_MULTICOMPO') THEN + ITYPE=5 + ELSE + CALL XABORT('SPH: L_EDIT, L_LIBRARY, L_MACROLIB OR L_SAPHY' + 1 //'B EXPECTED AT FIRST RHS PARAMETER.') + ENDIF + ENDIF + DO 10 I=IMIN,NENTRY + IF((IENTRY(I).LE.2).AND.(JENTRY(I).EQ.2)) THEN + CALL LCMGTC(KENTRY(I),'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_TRACK') THEN + IPTRK=KENTRY(I) + ELSE IF(HSIGN.EQ.'L_FLUX') THEN + IPFLX=KENTRY(I) + ELSE IF(HSIGN.EQ.'L_OPTIMIZE') THEN + IPOPT=KENTRY(I) + ELSE + HFORMAT='(40HSPH: UNKNOWN TYPE OF PARAMETER(1). NAME=,'// + 1 'A12,11H<--- HSIGN=,A12,5H<---.)' + WRITE(HSMG,HFORMAT) HENTRY(I),HSIGN + CALL XABORT(HSMG) + ENDIF + ELSE IF((IENTRY(I).EQ.3).AND.(JENTRY(I).EQ.2)) THEN + IFTRK=FILUNIT(KENTRY(I)) + ELSE + HFORMAT='(40HSPH: UNKNOWN TYPE OF PARAMETER(2). NAME=,A12,'// + 1 '5H<---.)' + WRITE(HSMG,HFORMAT) HENTRY(I) + CALL XABORT(HSMG) + ENDIF + 10 CONTINUE +*---- +* INITIALIZE OR RECOVER EXISTING SPH STATE-VECTOR +*---- + IF(ITYPE.EQ.1) THEN +* TRY TO RECOVER SPH STATE-VECTOR FROM LAST-EDIT DIRECTORY + CALL LCMGTC(IPRHS,'LAST-EDIT',12,HEDIT) + IF(IPRINT.GT.0) THEN + WRITE(6,'(32H SPH: STEP UP L_EDIT DIRECTORY '',A,5H''(1).)') + 1 HEDIT + ENDIF + IPEDIT=IPRHS + IPMICR=LCMGID(IPEDIT,HEDIT) + IPMACR=LCMGID(IPMICR,'MACROLIB') + CALL LCMLEN(IPMICR,'SIGNATURE',ILONG,ITYLCM) + IF(ILONG.EQ.0) IPMICR=C_NULL_PTR + IPSAP=C_NULL_PTR + IPAPX=C_NULL_PTR + ELSE IF(ITYPE.EQ.2) THEN + IPEDIT=C_NULL_PTR + IPMICR=IPRHS + IPMACR=LCMGID(IPMICR,'MACROLIB') + IPSAP=C_NULL_PTR + IPAPX=C_NULL_PTR + ELSE IF(ITYPE.EQ.3) THEN + IPEDIT=C_NULL_PTR + IPMICR=C_NULL_PTR + IPMACR=IPRHS + IPSAP=C_NULL_PTR + IPAPX=C_NULL_PTR + ELSE IF((ITYPE.EQ.4).OR.(ITYPE.EQ.5)) THEN + IPEDIT=C_NULL_PTR + IPMICR=C_NULL_PTR + IPMACR=C_NULL_PTR + IPSAP=IPRHS + IPAPX=C_NULL_PTR + ELSE IF(ITYPE.EQ.6) THEN + IPEDIT=C_NULL_PTR + IPMICR=C_NULL_PTR + IPMACR=C_NULL_PTR + IPSAP=C_NULL_PTR + IPAPX=IPRHS + ENDIF + ILEN=0 + IF(C_ASSOCIATED(IPMACR)) CALL LCMLEN(IPMACR,'SPH',ILEN,ITYLCM) + IF(ILEN.NE.0) THEN + IPSPH=LCMGID(IPMACR,'SPH') + CALL LCMGET(IPSPH,'STATE-VECTOR',ISTATE) + NSPH=ISTATE(1) + KSPH=ISTATE(2) + MAXIT=ISTATE(3) + MAXNBI=ISTATE(4) + ILHS=ISTATE(5) + IMC=ISTATE(6) + IGRMIN=ISTATE(7) + IGRMAX=ISTATE(8) + IF(NSPH.GE.2) THEN + CALL LCMGTC(IPSPH,'SPH$TRK',12,CNDOOR) + CALL LCMGET(IPSPH,'SPH-EPSILON',EPSPH) + ELSE + CNDOOR=' ' + EPSPH=0.0 + ENDIF + LARM=(NSPH.EQ.4) + ELSE + NSPH=3 + IF(.NOT.C_ASSOCIATED(IPTRK)) NSPH=2 + KSPH=1 + MAXIT=200 + MAXNBI=10 + ILHS=0 + IMC=2 + IGRMIN=1 + IGRMAX=HUGE(IGRMAX) + EPSPH=1.0E-4 + CNDOOR=' ' + LARM=.FALSE. + ENDIF +*---- +* SET CNDOOR, IMC AND NSPH TO CONSISTENT VALUES +*---- + IF((NSPH.GE.2).AND.(C_ASSOCIATED(IPTRK))) THEN + CALL LCMGTC(IPTRK,'SIGNATURE',12,TEXT12) + IF(TEXT12.NE.'L_TRACK') THEN + CALL XABORT('SPH: TRACKING DATA STRUCTURE EXPECTED.') + ENDIF + CALL LCMGTC(IPTRK,'TRACK-TYPE',12,CNDOOR) + IMC=2 + IF(CNDOOR.EQ.'SYBIL') THEN +* SYBIL TRANSPORT-TRANSPORT EQUIVALENCE + NSPH=3 + IF(LARM) NSPH=4 + ELSE IF(CNDOOR.EQ.'NXT') THEN +* NXT TRANSPORT-TRANSPORT EQUIVALENCE + NSPH=3 + IF(IFTRK.EQ.0) CALL XABORT('SPH: MISSING TRACKING FILE') + ELSE IF(CNDOOR.EQ.'EXCELL') THEN +* EXCELL TRANSPORT-TRANSPORT EQUIVALENCE + NSPH=3 + IF(IFTRK.EQ.0) CALL XABORT('SPH: MISSING TRACKING FILE') + ELSE IF(CNDOOR.EQ.'MCCG') THEN +* MCCG TRANSPORT-TRANSPORT EQUIVALENCE + NSPH=4 + IF(IFTRK.EQ.0) CALL XABORT('SPH: MISSING TRACKING FILE') + ELSE IF(CNDOOR.EQ.'SN') THEN +* SN TRANSPORT-TRANSPORT EQUIVALENCE + NSPH=4 + ELSE IF(CNDOOR.EQ.'BIVAC') THEN +* BIVAC TRANSPORT-DIFFUSION EQUIVALENCE + NSPH=4 + IMC=1 + ELSE IF(CNDOOR.EQ.'TRIVAC') THEN +* TRIVAC TRANSPORT-DIFFUSION EQUIVALENCE + NSPH=4 + IMC=1 + ELSE + CALL XABORT('SPH: '//CNDOOR//' IS AN INVALID TRACKING MODU' + > //'LE') + ENDIF + ENDIF +*---- +* SPH DIRECTIVE ANALYSIS +*---- + IPRINT=1 + HEDIT=' ' + HEQUI=' ' + HEQNAM=' ' + ICAL=0 + B2=0.0 + LLEAK=.FALSE. + NALBP=0 + ILUPS=0 + ALLOCATE(SPOLD(1,1)) + 20 CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT12,DFLOT) + IF(ITYPLU.EQ.10) GO TO 50 + IF(ITYPLU.NE.3) CALL XABORT('SPH: READ ERROR - CHARACTER VA' + > //'RIABLE EXPECTED') + 30 IF(TEXT12.EQ.';') THEN + GO TO 50 + ELSE IF(TEXT12.EQ.'EDIT') THEN + CALL REDGET(ITYPLU,IPRINT,REALIR,TEXT12,DFLOT) + IF(ITYPLU.NE.1) CALL XABORT('SPH: READ ERROR - INTEGER' + > //' VARIABLE EXPECTED') + ELSE IF(TEXT12.EQ.'IDEM') THEN + ILHS=0 + ELSE IF(TEXT12.EQ.'MICRO') THEN + IF((ITYPE.EQ.3).OR.(ITYPE.EQ.4)) THEN + CALL XABORT('SPH: UNABLE TO PRODUCE A MICROLIB') + ENDIF + ILHS=2 + ELSE IF(TEXT12.EQ.'MACRO') THEN + ILHS=3 + ELSE IF(TEXT12.EQ.'ASYM') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT12,DFLOT) + IF(ITYPLU.NE.1) CALL XABORT('SPH: READ ERROR - INTEGER V' + > //'ARIABLE EXPECTED') + IF(INTLIR.LE.0) CALL XABORT('SPH: INVALID ASYMPTOTIC MIX' + > //'TURE SET') + KSPH=-INTLIR + ELSE IF(TEXT12.EQ.'STD') THEN + KSPH=1 + ELSE IF(TEXT12.EQ.'SELE_ALB') THEN + KSPH=2 + ELSE IF(TEXT12.EQ.'SELE_FD') THEN + KSPH=3 + ELSE IF(TEXT12.EQ.'SELE_EDF') THEN + KSPH=4 + ELSE IF(TEXT12.EQ.'SELE_MWG') THEN + KSPH=6 + ELSE IF(TEXT12.EQ.'STD_FISS') THEN + KSPH=7 + ELSE IF(TEXT12.EQ.'OFF') THEN +* NO SPH CORRECTION PERFORMED + NSPH=0 + KSPH=0 + CNDOOR=' ' + ELSE IF(TEXT12.EQ.'UPS') THEN + ILUPS=1 + ELSE IF(TEXT12.EQ.'SPRD') THEN +* THE SPH FACTORS ARE READ FROM INPUT + NSPH=1 + KSPH=0 + CNDOOR=' ' + CALL REDGET(ITYPLU,NMERGO,REALIR,TEXT12,DFLOT) + IF(ITYPLU.EQ.3) THEN + NSPH=0 + GO TO 30 + ELSE IF(ITYPLU.NE.1) THEN + CALL XABORT('SPH: READ ERROR - INTEGER VARIABLE EXPECTED') + ENDIF + CALL REDGET(ITYPLU,NGCONO,REALIR,TEXT12,DFLOT) + IF(ITYPLU.NE.1) CALL XABORT('SPH: READ ERROR - INTEGER' + > //' VARIABLE EXPECTED') + DEALLOCATE(SPOLD) + ALLOCATE(SPOLD(NMERGO,NGCONO)) + DO I=1,NMERGO + DO J=1,NGCONO + CALL REDGET(ITYPLU,INTLIR,SPOLD(I,J),TEXT12,DFLOT) + IF(ITYPLU.NE.2) CALL XABORT('SPH: READ ERROR - REAL' + > //' VARIABLE EXPECTED') + ENDDO + ENDDO + ELSE IF(TEXT12.EQ.'SPOP') THEN +* THE SPH FACTORS ARE READ FROM A L_OPTIMIZE OBJECT + NSPH=1 + KSPH=0 + CNDOOR=' ' + ISTATE(:NSTATE)=0 + CALL LCMGET(IPOPT,'DEL-STATE',ISTATE) + NGCONO=ISTATE(1) + NMERGO=ISTATE(2) + IMC=ISTATE(4)-2 + NGR1=ISTATE(5) + NGR2=ISTATE(6) + IBM1=ISTATE(7) + IBM2=ISTATE(8) + NALBP=ISTATE(9) + NPERT=(NGR2-NGR1+1)*(NALBP+IBM2-IBM1+1) + DEALLOCATE(SPOLD) + ALLOCATE(SPOLD(NMERGO+NALBP,NGCONO),VARV(NPERT)) + CALL LCMGET(IPOPT,'VAR-VALUE',VARV) + SPOLD(:NMERGO+NALBP,:NGCONO)=1.0 + IPERT=0 + DO IGR=NGR1,NGR2 + DO IBM=IBM1,IBM2 + IPERT=IPERT+1 + SPOLD(IBM,IGR)=REAL(VARV(IPERT)) + ENDDO + DO IAL=1,NALBP + IPERT=IPERT+1 + SPOLD(NMIX+IAL,IGR)=REAL(VARV(IPERT)) + ENDDO + ENDDO + DEALLOCATE(VARV) + IF(IPERT.NE.NPERT) CALL XABORT('SPH: SPOP UPDATE FAILURE.') + ELSE IF(TEXT12.EQ.'HOMO') THEN +* HOMOGENEOUS MACRO CALCULATION (NO ITERATIONS ARE PERFORMED) + NSPH=2 + KSPH=0 + CNDOOR=' ' + ELSE IF(TEXT12.EQ.'ALBS') THEN + NSPH=2 + KSPH=5 + CNDOOR=' ' + ELSE IF(TEXT12.EQ.'PN') THEN + IMC=1 + ELSE IF(TEXT12.EQ.'SN') THEN + IMC=2 + ELSE IF(TEXT12.EQ.'ITER') THEN +* SPH ITERATION MAIN CONTROL PARAMETERS + 40 CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT12,DFLOT) + IF(ITYPLU.EQ.1) THEN + MAXIT=INTLIR + ELSE IF(ITYPLU.EQ.2) THEN + EPSPH=REALIR + ELSE IF(ITYPLU.EQ.3) THEN + GO TO 30 + ENDIF + GO TO 40 + ELSE IF(TEXT12.EQ.'MAXNB') THEN +* SPH ITERATION AUXILIARY CONTROL PARAMETERS + CALL REDGET(ITYPLU,MAXNBI,REALIR,TEXT12,DFLOT) + IF(ITYPLU.NE.1) CALL XABORT('SPH: READ ERROR - INTEGER' + > //' VARIABLE EXPECTED') + ELSE IF(TEXT12.EQ.'BELL') THEN + IF(IMC.NE.2) CALL XABORT('SPH: SN OPTION MANDATORY') + IMC=3 + ELSE IF(TEXT12.EQ.'ARM') THEN + LARM=.TRUE. + ELSE IF(TEXT12.EQ.'STEP') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT12,DFLOT) + IF(ITYPLU.NE.3) CALL XABORT('SPH: READ ERROR - CHARACTER' + > //' VARIABLE EXPECTED') + IF(TEXT12.EQ.'UP') THEN + IF((ITYPE.NE.1).AND.(ITYPE.NE.5)) THEN + CALL XABORT('SPH: L_EDIT OR L_MULTICOMPO EXPECTED AT RHS') + ENDIF + CALL REDGET(ITYPLU,INTLIR,REALIR,HEDIT,DFLOT) + IF(ITYPLU.NE.3) CALL XABORT('SPH: READ ERROR - CHARACTER' + > //' VARIABLE EXPECTED') + ELSE IF(TEXT12.EQ.'AT') THEN + IF((ITYPE.NE.4).AND.(ITYPE.NE.5).AND.(ITYPE.NE.6)) THEN + CALL XABORT('SPH: L_SAPHYB, L_MULTICOMPO OR APEX FILE E' + > //'XPECTED AT RHS') + ENDIF + CALL REDGET(ITYPLU,ICAL,REALIR,TEXT12,DFLOT) + IF(ITYPLU.NE.1) CALL XABORT('SPH: READ ERROR - INTEGER' + > //' VARIABLE EXPECTED') + IF(ICAL.LE.0) CALL XABORT('SPH: INVALID VALUE OF ICAL') + ELSE + CALL XABORT('SPH: KEYWORD UP OR AT EXPECTED') + ENDIF + ELSE IF(TEXT12.EQ.'EQUI') THEN + IF((ITYPE.NE.4).AND.(ITYPE.NE.6)) THEN + CALL XABORT('SPH: L_SAPHYB OR APEX FILE EXPECTED AT RHS') + ENDIF + CALL REDGET(ITYPLU,INTLIR,REALIR,HEQNAM,DFLOT) + IF(ITYPLU.NE.3) CALL XABORT('SPH: READ ERROR - CHARACTER' + > //' VARIABLE EXPECTED') + HEQUI=HEQNAM(:4) + ELSE IF(TEXT12.EQ.'LOCNAM') THEN + IF(ITYPE.NE.4) CALL XABORT('SPH: L_SAPHYB EXPECTED AT RHS') + IF(HEQUI.EQ.' ') CALL XABORT('SPH: HEQUI IS NOT DEFINED') + CALL REDGET(ITYPLU,INTLIR,REALIR,HEQNAM,DFLOT) + IF(ITYPLU.NE.3) CALL XABORT('SPH: READ ERROR - CHARACTER' + > //' VARIABLE EXPECTED') + ELSE IF(TEXT12.EQ.'LEAK') THEN + LLEAK=.TRUE. + CALL REDGET(ITYPLU,NITMA,REALIR,TEXT12,DFLOT) + IF(ITYPLU.EQ.3) GO TO 30 + IF(ITYPLU.NE.2) CALL XABORT('SPH: REAL DATA EXPECTED.') + B2=REALIR + ELSE IF(TEXT12.EQ.'GRMIN') THEN + CALL REDGET(ITYPLU,IGRMIN,REALIR,TEXT12,DFLOT) + IF(ITYPLU.NE.1) CALL XABORT('SPH: INTEGER DATA EXPECTED.') + ELSE IF(TEXT12.EQ.'GRMAX') THEN + CALL REDGET(ITYPLU,IGRMAX,REALIR,TEXT12,DFLOT) + IF(ITYPLU.NE.1) CALL XABORT('SPH: INTEGER DATA EXPECTED.') + ELSE + CALL XABORT('SPH: INVALID KEYWORD='//TEXT12) + ENDIF + GO TO 20 +*---- +* RESET TO MICROLIB IN DIRECTORY HEDIT +*---- + 50 IF(ITYPE.EQ.1) THEN + IF(HEDIT.EQ.' ') CALL LCMGTC(IPEDIT,'LAST-EDIT',12,HEDIT) + IF(IPRINT.GT.0) THEN + WRITE(6,'(32H SPH: STEP UP L_EDIT DIRECTORY '',A,5H''(2).)') + 1 HEDIT + ENDIF + CALL LCMLEN(IPEDIT,HEDIT,ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + CALL LCMLIB(IPEDIT) + CALL XABORT('SPH: MISSING DIRECTORY: '//HEDIT) + ENDIF + IPMICR=LCMGID(IPEDIT,HEDIT) + IPMACR=LCMGID(IPMICR,'MACROLIB') + CALL LCMLEN(IPMICR,'SIGNATURE',ILONG,ITYLCM) + IF(ILONG.EQ.0) IPMICR=C_NULL_PTR + IPSAP=C_NULL_PTR + IPAPX=C_NULL_PTR + ENDIF +*---- +* SET POINTERS TO MACROLIB (IPMACR) AND OUTPUT (IPOUT) LCM OBJECTS +*---- + IF(ILHS.EQ.0) THEN + ILHS2=ITYPE + ELSE + ILHS2=ILHS + ENDIF + IF((C_ASSOCIATED(IPRHS,IPOUT)).AND.(ITYPE.NE.ILHS2)) THEN + IF(ILHS2.EQ.1) THEN + CALL XABORT('SPH: CANNOT EXTRACT AN EDITION OBJECT FROM AN' + > //' OBJECT IN MODIFICATION MODE.') + ELSE IF(ILHS2.EQ.2) THEN + CALL XABORT('SPH: CANNOT EXTRACT A MICROLIB FROM AN OBJECT' + > //' IN MODIFICATION MODE.') + ELSE IF(ILHS2.EQ.3) THEN + CALL XABORT('SPH: CANNOT EXTRACT A MACROLIB FROM AN OBJECT' + > //' IN MODIFICATION MODE.') + ELSE IF(ILHS2.EQ.4) THEN + CALL XABORT('SPH: CANNOT EXTRACT A SAPHYB FROM AN OBJECT I' + > //'N MODIFICATION MODE.') + ELSE IF(ILHS2.EQ.5) THEN + CALL XABORT('SPH: CANNOT EXTRACT A MULTICOMPO FROM AN OBJE' + > //'T IN MODIFICATION MODE.') + ELSE IF(ILHS2.EQ.6) THEN + CALL XABORT('SPH: CANNOT EXTRACT AN HDF FILE FROM AN OBJEC' + > //'T IN MODIFICATION MODE.') + ENDIF + ELSE IF((.NOT.C_ASSOCIATED(IPRHS,IPOUT)).AND.(ILHS2.EQ.1)) THEN + IF(.NOT.C_ASSOCIATED(IPEDIT)) CALL XABORT('SPH: NO EDITION OB' + > //'JECT ON RHS') + CALL LCMEQU(IPEDIT,IPOUT) + IF(IPRINT.GT.0) THEN + WRITE(6,'(32H SPH: STEP UP L_EDIT DIRECTORY '',A,5H''(3).)') + > HEDIT + ENDIF + IPEDIT=IPOUT + IPMICR=LCMGID(IPEDIT,HEDIT) + IPMACR=LCMGID(IPMICR,'MACROLIB') + CALL LCMLEN(IPMICR,'SIGNATURE',ILONG,ITYLCM) + IF(ILONG.EQ.0) IPMICR=C_NULL_PTR + ELSE IF((.NOT.C_ASSOCIATED(IPRHS,IPOUT)).AND.(ILHS2.EQ.2)) THEN + IF(ITYPE.EQ.2) THEN + IF(.NOT.C_ASSOCIATED(IPMICR)) CALL XABORT('SPH: NO MICROLI' + > //'B ON RHS') + CALL LCMEQU(IPMICR,IPOUT) + IPMACR=LCMGID(IPMICR,'MACROLIB') + ELSE IF(ITYPE.EQ.5) THEN + IPMACR=C_NULL_PTR + ELSE + CALL XABORT('SPH: RHS CANNOT BE CONVERTED TO A MICROLIB') + ENDIF + IPEDIT=C_NULL_PTR + IPMICR=IPOUT + ELSE IF((.NOT.C_ASSOCIATED(IPRHS,IPOUT)).AND.(ILHS2.EQ.3)) THEN + IF((ITYPE.NE.4).AND.(ITYPE.NE.5).AND.(ITYPE.NE.6)) THEN + CALL LCMEQU(IPMACR,IPOUT) + ENDIF + IPEDIT=C_NULL_PTR + IPMICR=C_NULL_PTR + IPMACR=IPOUT + ELSE IF((.NOT.C_ASSOCIATED(IPRHS,IPOUT)).AND.(ILHS2.EQ.4)) THEN + IF(.NOT.C_ASSOCIATED(IPSAP)) CALL XABORT('SPH: NO SAPHYB ON R' + > //'HS') + CALL LCMEQU(IPSAP,IPOUT) + IPEDIT=C_NULL_PTR + IPMICR=C_NULL_PTR + IPMACR=C_NULL_PTR + ELSE IF((.NOT.C_ASSOCIATED(IPRHS,IPOUT)).AND.(ILHS2.EQ.5)) THEN + IF(.NOT.C_ASSOCIATED(IPSAP)) CALL XABORT('SPH: NO MULTICOMPO ' + > //'ON RHS') + CALL LCMEQU(IPSAP,IPOUT) + IPEDIT=C_NULL_PTR + IPMICR=C_NULL_PTR + IPMACR=C_NULL_PTR + ELSE IF((.NOT.C_ASSOCIATED(IPRHS,IPOUT)).AND.(ILHS2.EQ.6)) THEN + CALL XABORT('SPH: CANNOT DUPLICATE AN HDF5 FILE') + ENDIF +*---- +* BUILD A MACROLIB IF NEEDED, ASSIGN AND INITIALIZE SPH-FACTOR ARRAY +*---- + ALLOCATE(SPH2(1,1)) + LTEMP=.FALSE. +#if defined(HDF5_LIB) + LMPO=.FALSE. +#endif /* defined(HDF5_LIB) */ + IF(ITYPE.EQ.4) THEN +* A Saphyb is given at RHS + IF(ILHS2.EQ.3) THEN + IPMACR=IPOUT + ELSE IF(ILHS2.EQ.4) THEN + LTEMP=.TRUE. + CALL LCMOP(IPMACR,'*TEMPORARY*',0,1,0) + ELSE + CALL XABORT('SPH: OPTION NOT IMPLEMENTED(1).') + ENDIF + CALL LCMLEN(IPSAP,'DIMSAP',ILENG,ITYLCM) + IF(ILENG.EQ.0) CALL XABORT('SPH: INVALID SAPHYB.') + CALL LCMGET(IPSAP,'DIMSAP',DIMSAP) + NMERGE=DIMSAP(7) ! number of mixtures + NGCOND=DIMSAP(20) ! number of energy groups + DEALLOCATE(SPH2) + ALLOCATE(SPH2(NMERGE,NGCOND)) + HMASL=' ' + CALL SPHSAP(IPSAP,IPMACR,ICAL,IPRINT,HEQUI,HMASL,NMERGE, + > NGCOND,ILUPS,SPH2,B2) + NALBP=0 ! no albedo correction + ELSE IF(ITYPE.EQ.5) THEN +* A Multicompo is given at RHS + IF(ILHS2.EQ.2) THEN + IPMICR=IPOUT + ELSE IF((ILHS2.EQ.3).OR.(ILHS2.EQ.5)) THEN + LTEMP=.TRUE. + CALL LCMOP(IPMICR,'*TEMPORARY*',0,1,0) + ELSE + CALL XABORT('SPH: OPTION NOT IMPLEMENTED(2).') + ENDIF + IF(HEDIT.EQ.' ') HEDIT='default' + IF(IPRINT.GT.0) THEN + HFORMAT='(38H SPH: STEP UP L_MULTICOMPO DIRECTORY '',A,'// + > '2H''.)' + WRITE(6,HFORMAT) HEDIT + ENDIF + IPCPO=LCMGID(IPSAP,HEDIT) + CALL LCMLEN(IPCPO,'STATE-VECTOR',ILENG,ITYLCM) + IF(ILENG.EQ.0) CALL XABORT('SPH: INVALID MULTICOMPO.') + CALL LCMGET(IPCPO,'STATE-VECTOR',ISTATE) + NMERGE=ISTATE(1) ! number of mixtures + NGCOND=ISTATE(2) ! number of energy groups + MAXISO=MAXISD*NMERGE + CALL SPHCPO(MAXISO,IPMICR,IPCPO,NMERGE,NGCOND,IPRINT,ICAL, + > ILUPS,B2) + IPMACR=LCMGID(IPMICR,'MACROLIB') + IF(ILHS2.EQ.3) CALL LCMEQU(IPMACR,IPOUT) + DEALLOCATE(SPH2) + ALLOCATE(SPH2(NMERGE,NGCOND)) + SPH2(:NMERGE,:NGCOND)=1.0 + NALBP=0 ! no albedo correction + ELSE IF(ITYPE.EQ.6) THEN +* An Apex or MPO file is given at RHS +#if defined(HDF5_LIB) + IF(ILHS2.EQ.3) THEN + IPMACR=IPOUT + ELSE + LTEMP=.TRUE. + CALL LCMOP(IPMACR,'*TEMPORARY*',0,1,0) + ENDIF + LMPO=hdf5_group_exists(IPAPX,"/contents/") + IF(LMPO) THEN + ! A MPO file is found at RHS + ! Find the (multigroup mesh, output geometry) couple + IF(HEDIT.EQ.' ') HEDIT='output_0' + CALL hdf5_read_data(IPAPX,"/energymesh/NENERGYMESH",NENERG) + CALL hdf5_read_data(IPAPX,"/geometry/NGEOMETRY",NGEOME) + CALL hdf5_read_data(IPAPX,"/output/OUPUTID",OUPUTID) + READ(HEDIT,'(7X,I2)') ID + ID_G=0 + ID_E=0 + DO I=1,NGEOME + DO J=1,NENERG + IF(OUPUTID(J,I).EQ.ID) THEN + ID_G=I-1 + ID_E=J-1 + GO TO 55 + ENDIF + ENDDO + ENDDO + CALL XABORT('SPH: no ID found in /output/OUPUTID.') + 55 WRITE(RECNAM,'(23H/energymesh/energymesh_,I0)') ID_E + IF(IPRINT.GT.1) THEN + HFORMAT='(/39H SPH: Process MPO multiparameter file o'// + > '9Hn output=,A,13h calculation=,I5)' + WRITE(IOUT,HFORMAT) TRIM(HEDIT),ICAL + WRITE(IOUT,'(21H SPH: energy group=,A)') TRIM(RECNAM) + ENDIF + CALL hdf5_read_data(IPAPX,TRIM(RECNAM)//"/ENERGY",WORK1) + NGCOND=SIZE(WORK1,1)-1 + DO IGR=1,NGCOND+1 + WORK1(IGR)=WORK1(IGR)/1.0E-6 + ENDDO + CALL LCMPUT(IPMACR,'ENERGY',NGCOND+1,2,WORK1) + DEALLOCATE(WORK1,OUPUTID) + WRITE(RECNAM,'(19H/geometry/geometry_,I0,1H/)') ID_G + IF(IPRINT.GT.1) THEN + WRITE(IOUT,'(21H SPH: geometry group=,A)') TRIM(RECNAM) + ENDIF + CALL hdf5_read_data(IPAPX,TRIM(RECNAM)//"NZONE",NMERGE) + CALL hdf5_read_data(IPAPX,TRIM(RECNAM)//"ZONEVOLUME",XVOLM) + ! + DEALLOCATE(SPH2) + ALLOCATE(SPH2(NMERGE,NGCOND)) + HMASL=' ' + CALL SPHMPO(IPAPX,IPMACR,ICAL,IPRINT,HEQNAM,HMASL,NMERGE, + > NALBP,NGCOND,HEDIT,XVOLM,ILUPS,SPH2,B2) + DEALLOCATE(XVOLM) + ELSE + ! An Apex file is found at RHS + NMERGE=1 + IF(hdf5_group_exists(IPAPX,"/physconst/")) THEN + CALL hdf5_get_shape(IPAPX,"/physconst/ENRGS",DIMS_APX) + ELSE IF(hdf5_group_exists(IPAPX,"/physco001/")) THEN + CALL hdf5_get_shape(IPAPX,"/physc001/ENRGS",DIMS_APX) + ELSE + CALL XABORT('SPH: GROUP physconst NOT FOUND IN HDF5 FILE') + ENDIF + NGCOND=DIMS_APX(1)-1 + CALL hdf5_list_groups(IPAPX, "calc 1", LIST) + DO I=1,SIZE(LIST) + IF(LIST(I)(:2).EQ.'xs') THEN + READ(LIST(I),'(2X,I8)') II + NMERGE=MAX(II,NMERGE) + ENDIF + ENDDO + DEALLOCATE(LIST) + DEALLOCATE(SPH2) + ALLOCATE(SPH2(NMERGE,NGCOND)) + LFROM=(NMERGE.GT.1) + CALL SPHAPX(IPAPX,IPMACR,ICAL,IPRINT,HEQNAM,NMERGE,NGCOND, + > LFROM,ILUPS,SPH2,B2) + ENDIF + NALBP=0 ! no albedo correction +#else + CALL XABORT('SPH: THE HDF5 API IS NOT AVAILABLE(1)') +#endif /* defined(HDF5_LIB) */ + ELSE +* A Edition/Microlib/Macrolib is given at RHS + CALL LCMGET(IPMACR,'STATE-VECTOR',ISTATE) + NGCOND=ISTATE(1) + NMERGE=ISTATE(2) + NALBP=ISTATE(8) + DEALLOCATE(SPH2) + ALLOCATE(SPH2(NMERGE+NALBP,NGCOND)) + SPH2(:NMERGE+NALBP,:NGCOND)=1.0 + ENDIF + IF(IGRMIN.GT.NGCOND) CALL XABORT('SPH: IGRMIN OVERFLOW.') + IGRMAX=MIN(IGRMAX,NGCOND) +*---- +* STORE SPH-RELATED INFORMATION +*---- + IF(NSPH.GT.0) THEN + IF(.NOT.C_ASSOCIATED(IPMACR)) CALL XABORT('SPH: MISSING MACRO' + > //'LIB.') + IPSPH=LCMDID(IPMACR,'SPH') + IF(NSPH.GE.2) THEN + CALL LCMPTC(IPSPH,'SPH$TRK',12,CNDOOR) + CALL LCMPUT(IPSPH,'SPH-EPSILON',1,2,EPSPH) + ENDIF + ISTATE(:NSTATE)=0 + ISTATE(1)=NSPH + ISTATE(2)=KSPH + ISTATE(3)=MAXIT + ISTATE(4)=MAXNBI + ISTATE(5)=ILHS + ISTATE(6)=IMC + ISTATE(7)=IGRMIN + ISTATE(8)=IGRMAX + CALL LCMPUT(IPSPH,'STATE-VECTOR',NSTATE,1,ISTATE) + IF(IPRINT.GT.0) WRITE(IOUT,200) (ISTATE(I),I=1,8),EPSPH,CNDOOR + ENDIF +*---- +* COMPUTE SPH FACTORS +*---- + IF(NSPH.EQ.1) THEN + IF(NMERGE+NALBP.NE.NMERGO) CALL XABORT('SPH: INVALID NUMBER OF' + > //' REGIONS AFTER SPRD.') + IF(NGCOND.NE.NGCONO) CALL XABORT('SPH: INVALID NUMBER OF GROUP' + > //'S AFTER SPRD.') + SPH2(:NMERGE+NALBP,:NGCOND)=SPOLD(:NMERGE+NALBP,:NGCOND) + ELSE IF(NSPH.GE.2) THEN + CALL LCMLEN(IPMACR,'SPH',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + CALL LCMLIB(IPMACR) + CALL XABORT('SPH: NO SPH DIRECTORY AVAILABLE.') + ENDIF + CALL SPHDRV(IPTRK,IFTRK,IPMACR,IPFLX,IPRINT,IMC,NGCOND,NMERGE, + > NALBP,IGRMIN,IGRMAX,SPH2) + ENDIF + DEALLOCATE(SPOLD) +*---- +* APPLY SPH CORRECTION +*---- + IF((ILHS2.LE.3).AND.(.NOT.C_ASSOCIATED(IPMICR))) THEN +* Correction of Macrolib information + CALL LCMGET(IPMACR,'STATE-VECTOR',ISTATE) + NIFISS=ISTATE(4) + NED=ISTATE(5) + CALL SPHCMA(IPMACR,IPRINT,IMC,NMERGE,NGCOND,NIFISS,NED,NALBP, + > SPH2) + ELSE IF(ILHS2.LE.3) THEN +* Correction of Microlib information + CALL LCMGET(IPMICR,'STATE-VECTOR',ISTATE) + NISOT=ISTATE(2) + NL=ISTATE(4) + NED=ISTATE(13) + NDEL=ISTATE(19) + NW=MAX(1,ISTATE(25)) + ISTATE(25)=NW + CALL LCMPUT(IPMICR,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL SPHCMI(IPMICR,IPRINT,IMC,NMERGE,NISOT,NGCOND,NL,NW,NED, + > NDEL,NALBP,SPH2) + ELSE IF((ILHS2.EQ.4).AND.(HEQUI.NE.' ')) THEN +*---- +* STORE A NEW SET OF SPH FACTORS IN THE SAPHYB +*---- + LNEW=(.NOT.C_ASSOCIATED(IPRHS,IPOUT)) + CALL SPHSTO(IPOUT,ICAL,IPRINT,LNEW,HEQUI,HEQNAM,NMERGE,NGCOND, + > SPH2) + ELSE IF(ILHS2.EQ.5) THEN +*---- +* APPLY A NEW SET OF SPH FACTORS IN THE MULTICOMPO +*---- + IPCPO=LCMGID(IPOUT,HEDIT) + CALL SPHSCO(IPCPO,ICAL,IPRINT,IMC,NMERGE,NGCOND,SPH2) + ELSE IF((ILHS2.EQ.6).AND.(HEQNAM.NE.' ')) THEN +*---- +* STORE A NEW SET OF SPH FACTORS IN THE APEX OR MPO FILE +*---- +#if defined(HDF5_LIB) + LNEW=(.NOT.C_ASSOCIATED(IPRHS,IPOUT)) + ALLOCATE(WORK1(NGCOND)) + IF(LMPO) THEN + CALL SPHSTM(IPAPX,ICAL,IPRINT,LNEW,HEQNAM,HEDIT,NMERGE,NGCOND, + > SPH2) + ELSE + IF(NMERGE.EQ.1) THEN + WRITE(TEXT80,'(4Hcalc,I8,14H/xs/MEDIA_SPH/)') ICAL + WORK1(:NGCOND)=SPH2(IBM,:NGCOND) + CALL hdf5_create_group(IPAPX,TRIM(TEXT80)) + CALL hdf5_write_data(IPAPX,TRIM(TEXT80)//HEQNAM,WORK1) + ELSE + DO IBM=1,NMERGE + WRITE(TEXT80,'(4Hcalc,I8,3H/xs,I8,11H/MEDIA_SPH/)') ICAL, + > IBM + WORK1(:NGCOND)=SPH2(IBM,:NGCOND) + CALL hdf5_create_group(IPAPX,TRIM(TEXT80)) + CALL hdf5_write_data(IPAPX,TRIM(TEXT80)//HEQNAM,WORK1) + ENDDO + ENDIF + ENDIF + DEALLOCATE(WORK1) +#else + CALL XABORT('SPH: THE HDF5 API IS NOT AVAILABLE(2)') +#endif /* defined(HDF5_LIB) */ + ENDIF +*---- +* RELEASE MEMORY ALLOCATED FOR MACROLIB/MICROLIB AND SPH FACTORS +*---- + IF((C_ASSOCIATED(IPMICR)).AND.LTEMP) THEN + CALL LCMCL(IPMICR,2) + ELSE IF(LTEMP) THEN + CALL LCMCL(IPMACR,2) + ENDIF + DEALLOCATE(SPH2) +*---- +* INCLUDE LEAKAGE IN THE MACROLIB (USED ONLY FOR NON-REGRESSION TESTS) +*---- + IF(LLEAK) THEN + IF(ILHS2.EQ.1) THEN + CALL LCMLEN(IPOUT,HEDIT,ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + CALL LCMLIB(IPEDIT) + CALL XABORT('SPH: MISSING DIRECTORY: '//HEDIT) + ENDIF + IPMICR=LCMGID(IPOUT,HEDIT) + IPMACR=LCMGID(IPMICR,'MACROLIB') + ELSE IF(ILHS2.EQ.2) THEN + IPMACR=LCMGID(IPOUT,'MACROLIB') + ELSE IF(ILHS2.EQ.3) THEN + IPMACR=IPOUT + ELSE + CALL XABORT('SPH: LHS MACROLIB EXPECTED WITH LEAK OPTION.') + ENDIF + CALL LCMGET(IPMACR,'STATE-VECTOR',ISTATE) + NGRP=ISTATE(1) + NMIX=ISTATE(2) + JPMAC=LCMGID(IPMACR,'GROUP') + ALLOCATE(WORK1(NMIX),WORK2(NMIX)) + DO 70 IGR=1,NGRP + KPMAC=LCMGIL(JPMAC,IGR) + CALL LCMGET(KPMAC,'NTOT0',WORK1) + CALL LCMGET(KPMAC,'DIFF',WORK2) + DO 60 IBM=1,NMIX + WORK1(IBM)=WORK1(IBM)+B2*WORK2(IBM) + 60 CONTINUE + CALL LCMPUT(KPMAC,'NTOT0',NMIX,2,WORK1) + 70 CONTINUE + DEALLOCATE(WORK2,WORK1) + B2=0.0 + CALL LCMPUT(IPMACR,'B2 B1HOM',1,2,B2) + ENDIF + IF((IPRINT.GT.5).AND.(ITYPE.LE.5)) CALL LCMLIB(IPOUT) + RETURN +* + 200 FORMAT(/20H SPH-RELATED OPTIONS/1X,19(1H-)/ + 1 7H NSPH ,I8,47H (=0: NO SPH CORRECTION; =1: READ SPH FACTORS, + 2 32H; >1: TYPE OF MACRO-CALCULATION)/ + 3 7H KSPH ,I8,47H (<0: ASYMPTOTIC SPH NORMALIZATION; =1: AVERA, + 4 60HGE FLUX; >1: SELENGUT NORMALIZATION; =7: AVERAGE FLUX IN FIS, + 5 11HSILE ZONES)/ + 6 7H MAXIT ,I8,37H (MAXIMUM NUMBER OF SPH ITERATIONS)/ + 7 7H MAXNBI,I8,47H (MAXIMUM NUMBER OF BAD ITERATIONS BEFORE ABO, + 8 6HRTING)/ + 9 7H ILHS ,I8,47H (=0/1/2/3: PRODUCE A RHS-TYPE/EDITION/MICROL, + 1 19HIB/MACROLIB AT LHS)/ + 2 7H IMC ,I8,47H (=1/2/3: PN-TYPE/SN-PIJ-MOC-TYPE CORRECTION/, + 3 32HPIJ-TYPE WITH BELL ACCELERATION)/ + 4 7H IGRMIN,I8,27H (FIRST GROUP TO PROCESS)/ + 5 7H IGRMAX,I8,26H (LAST GROUP TO PROCESS)/ + 6 7H EPSPH ,1P,E8.1,26H (CONVERGENCE CRITERION)/ + 7 8H CNDOOR ,A8,37H (MACRO-CALCULATION TRACKING MODULE)) + END diff --git a/Dragon/src/SPHAPX.f b/Dragon/src/SPHAPX.f new file mode 100644 index 0000000..666d623 --- /dev/null +++ b/Dragon/src/SPHAPX.f @@ -0,0 +1,621 @@ +*DECK SPHAPX + SUBROUTINE SPHAPX(IPAPX,IPMAC,ICAL,IMPX,HEQUI,NMIL,NGROUP,LFROM, + 1 ILUPS,SPH,B2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Extract a Macrolib corresponding to an elementary calculation in an +* Apex file +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* A. Hebert +* +*Parameters: input +* IPAPX pointer to the Apex file. +* ICAL index of the elementary calculation being considered. +* IMPX print parameter (equal to zero for no print). +* HEQUI keyword of SPH-factor set to be recovered. +* NMIL number of mixtures in the elementary calculation. +* NGROUP number of energy groups in the elementary calculation. +* LFROM macroregion flag (=.true. if 'xs n' groups are set). +* ILUPS up-scattering removing flag (=1 to remove up-scattering from +* output cross-sections). +* B2 imposed buckling. +* +*Parameters: output +* IPMAC pointer to the Macrolib (L_MACROLIB signature). +* SPH SPH-factor set extracted from the Apex file. +* B2 buckling recovered from Apex file. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPAPX,IPMAC + INTEGER ICAL,IMPX,NMIL,NGROUP,ILUPS + REAL SPH(NMIL,NGROUP),B2 + CHARACTER(LEN=80) HEQUI + LOGICAL LFROM +*---- +* LOCAL VARIABLES +*---- + INTEGER, PARAMETER::IOUT=6 + INTEGER, PARAMETER::NSTATE=40 + INTEGER, PARAMETER::MAXFRD=4 + REAL FLOTT, DEN, FF, CSCAT + INTEGER I, J, K, I0, IBM, IFISS, IGMAX, IGMIN, IGR, IL, IMAC, + & IPOSDE, IREA, IRES, ISO, ITRANC, JGR, NED, NBISO, NL, NBMAC, + & NREA, NSURFD, NISOF, NISOP, NBYTE, RANK, TYPE, DIMSR(5),IRENT0 + INTEGER ISTATE(NSTATE) + LOGICAL LSTRD,LDIFF,LHFACT + CHARACTER RECNAM*80,RECNAM2*80,TEXT12*12,TEXT8*8,HSMG*131, + & HHAD(MAXFRD)*16,CM*2 + TYPE(C_PTR) JPMAC,KPMAC +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ITOTM,IRESM,IPOS,NJJM,IJJM + INTEGER, ALLOCATABLE, DIMENSION(:) :: DIMS_APX + REAL, ALLOCATABLE, DIMENSION(:) :: ENER,XVOLM,FLUXS,STR,WRK, + 1 SCAT,GAR,CONCES + REAL, ALLOCATABLE, DIMENSION(:,:) :: NWT0, EFACT, XSB,SIGSB,SIGS0, + 1 ADF + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: XS,SIGS,SS2DB + REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: SS2D + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LXS + CHARACTER(LEN=4), ALLOCATABLE, DIMENSION(:) :: TYPISO + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HEDI,HADF,NOMISO, + 1 NOMMAC + CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: NOMREA + CHARACTER(LEN=20), ALLOCATABLE, DIMENSION(:) :: NOMMIL +*---- +* SCRATCH STORAGE ALLOCATION +* SIGS0 P0 scattering cross sections. +*---- + ALLOCATE(IPOS(NMIL),NJJM(NMIL),IJJM(NMIL),NOMMIL(NMIL)) + ALLOCATE(SIGS0(NMIL,NGROUP)) +*---- +* RECOVER APEX FILE CHARACTERISTICS +*---- + NBISO=0 + NBMAC=0 + NREA=0 + IF(hdf5_group_exists(IPAPX,"/explicit/")) THEN + NBISO=0 + CALL hdf5_info(IPAPX,"/explicit/ISONAME",RANK,TYPE,NBYTE,DIMSR) + IF(RANK.NE.99) NBISO=DIMSR(1) + NBMAC=0 + CALL hdf5_info(IPAPX,"/explicit/MACNAME",RANK,TYPE,NBYTE,DIMSR) + IF(RANK.NE.99) NBMAC=DIMSR(1) + NREA=0 + CALL hdf5_info(IPAPX,"/explicit/REANAME",RANK,TYPE,NBYTE,DIMSR) + IF(RANK.NE.99) NREA=DIMSR(1) + ELSE IF(hdf5_group_exists(IPAPX,"/expli001/")) THEN + NBISO=0 + CALL hdf5_info(IPAPX,"/expli001/ISONAME",RANK,TYPE,NBYTE,DIMSR) + IF(RANK.NE.99) NBISO=DIMSR(1) + NBMAC=0 + CALL hdf5_info(IPAPX,"/expli001/MACNAME",RANK,TYPE,NBYTE,DIMSR) + IF(RANK.NE.99) NBMAC=DIMSR(1) + NREA=0 + CALL hdf5_info(IPAPX,"/expli001/REANAME",RANK,TYPE,NBYTE,DIMSR) + IF(RANK.NE.99) NREA=DIMSR(1) + ELSE + CALL XABORT('SPHAPX: GROUP explicit NOT FOUND IN APEX FILE.') + ENDIF + NISOF=0 + NISOP=0 + IF(NBISO.GT.0) THEN + IF(hdf5_group_exists(IPAPX,"/physconst/")) THEN + CALL hdf5_get_shape(IPAPX,"/physconst/ISOTA",DIMS_APX) + ELSE IF(hdf5_group_exists(IPAPX,"/physco001/")) THEN + CALL hdf5_get_shape(IPAPX,"/physc001/ISOTA",DIMS_APX) + ENDIF + IF(DIMS_APX(1).NE.NBISO) THEN + WRITE(HSMG,'(44H SPHAPX: INCONSISTENT number of ISOTOPES IN , + 1 31Hexplicit AND physconst GROUPS (,I4,3H VS,I5,2H).)') NBISO, + 2 DIMS_APX(1) + CALL XABORT(HSMG) + ENDIF + DEALLOCATE(DIMS_APX) + IF(hdf5_group_exists(IPAPX,"/physconst/")) THEN + CALL hdf5_read_data(IPAPX,"/physconst/ISOTYP",TYPISO) + ELSE IF(hdf5_group_exists(IPAPX,"/physco001/")) THEN + CALL hdf5_read_data(IPAPX,"/physc001/ISOTYP",TYPISO) + ENDIF + DO I=1,NBISO + IF(TYPISO(I).EQ.'FISS') NISOF=NISOF+1 + IF(TYPISO(I).EQ.'F.P.') NISOP=NISOP+1 + ENDDO + DEALLOCATE(TYPISO) + ENDIF + NSURFD=0 + RECNAM='calc 1/miscellaneous/' + CALL hdf5_info(IPAPX,TRIM(RECNAM)//"ADF",RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.NE.99) NSURFD=NSURFD+4 + CALL hdf5_info(IPAPX,TRIM(RECNAM)//"CPDF",RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.NE.99) NSURFD=NSURFD+4 + CALL hdf5_info(IPAPX,TRIM(RECNAM)//"INTERNAL_ADF",RANK,TYPE,NBYTE, + 1 DIMSR) + IF(TYPE.NE.99) NSURFD=NSURFD+4 + CALL hdf5_info(IPAPX,TRIM(RECNAM)//"INTERNAL_CPDF",RANK,TYPE, + 1 NBYTE,DIMSR) + IF(TYPE.NE.99) NSURFD=NSURFD+4 + IF(NBISO+NBMAC.EQ.0) CALL XABORT('SPHAPX: NO CROSS SECTIONS.') +*---- +* RECOVER INFORMATION FROM physconst GROUP. +*---- + IF(hdf5_group_exists(IPAPX,"/physconst/")) THEN + CALL hdf5_read_data(IPAPX,"/physconst/ENRGS",ENER) + ELSE IF(hdf5_group_exists(IPAPX,"/physco001/")) THEN + CALL hdf5_read_data(IPAPX,"/physco001/ENRGS",ENER) + ELSE + CALL XABORT('SPHAPX: GROUP physconst NOT FOUND IN APEX FILE.') + ENDIF + DO IGR=1,NGROUP+1 + ENER(IGR)=ENER(IGR)/1.0E-6 + ENDDO + CALL LCMPUT(IPMAC,'ENERGY',NGROUP+1,2,ENER) + DEALLOCATE(ENER) +*---- +* RECOVER INFORMATION FROM explicit GROUP. +*---- + ALLOCATE(ITOTM(NMIL),IRESM(NMIL)) + ITOTM(:)=0 + IRESM(:)=0 + IF(NREA.GT.0) THEN + IF(hdf5_group_exists(IPAPX,"/explicit/")) THEN + CALL hdf5_read_data(IPAPX,"/explicit/REANAME",NOMREA) + ELSE IF(hdf5_group_exists(IPAPX,"/expli001/")) THEN + CALL hdf5_read_data(IPAPX,"/expli001/REANAME",NOMREA) + ELSE + CALL XABORT('SPHAPX: GROUP explicit NOT FOUND IN APEX FILE.') + ENDIF + IF(IMPX.GT.1) THEN + WRITE(IOUT,'(29H SPHAPX: Available reactions:/(1X,10A13))') + 1 (NOMREA(I),I=1,NREA) + ENDIF + ENDIF + IF(NBISO.GT.0) THEN + IF(hdf5_group_exists(IPAPX,"/explicit/")) THEN + CALL hdf5_read_data(IPAPX,"/explicit/ISONAME",NOMISO) + ELSE IF(hdf5_group_exists(IPAPX,"/expli001/")) THEN + CALL hdf5_read_data(IPAPX,"/expli001/ISONAME",NOMISO) + ELSE + CALL XABORT('SPHAPX: GROUP explicit NOT FOUND IN APEX FILE.') + ENDIF + ENDIF + IF(NBMAC.GT.0) THEN + IF(hdf5_group_exists(IPAPX,"/explicit/")) THEN + CALL hdf5_read_data(IPAPX,"/explicit/MACNAME",NOMMAC) + ELSE IF(hdf5_group_exists(IPAPX,"/expli001/")) THEN + CALL hdf5_read_data(IPAPX,"/expli001/MACNAME",NOMMAC) + ELSE + CALL XABORT('SPHAPX: GROUP explicit NOT FOUND IN APEX FILE.') + ENDIF + DO I=1,NBMAC + IF(NOMMAC(I).EQ.'TOTAL') ITOTM(:)=I + IF(NOMMAC(I).EQ.'RESIDUAL') IRESM(:)=I + ENDDO + DEALLOCATE(NOMMAC) + ENDIF +*---- +* RECOVER INFORMATION FROM miscellaneous GROUP +*---- + LSTRD=(B2.EQ.0.0) + WRITE(RECNAM,'(4Hcalc,I8,15H/miscellaneous/)') ICAL + CALL hdf5_info(IPAPX,TRIM(RECNAM)//"KEFF",RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.NE.99) THEN + CALL hdf5_read_data(IPAPX,TRIM(RECNAM)//"KEFF",FLOTT) + CALL LCMPUT(IPMAC,'K-EFFECTIVE',1,2,FLOTT) + ENDIF + CALL hdf5_info(IPAPX,TRIM(RECNAM)//"KINF",RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.NE.99) THEN + CALL hdf5_read_data(IPAPX,TRIM(RECNAM)//"KINF",FLOTT) + CALL LCMPUT(IPMAC,'K-INFINITY',1,2,FLOTT) + ENDIF + CALL hdf5_info(IPAPX,TRIM(RECNAM)//"B2",RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.NE.99) THEN + CALL hdf5_read_data(IPAPX,TRIM(RECNAM)//"B2",B2) + LSTRD=(B2.EQ.0.0) + CALL LCMPUT(IPMAC,'B2 B1HOM',1,2,B2) + ENDIF + IF(NSURFD.GT.0) THEN + K=0 + CALL hdf5_info(IPAPX,TRIM(RECNAM)//"ADF",RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.NE.99) THEN + HHAD(K+1)='ADF' + K=K+1 + ENDIF + CALL hdf5_info(IPAPX,TRIM(RECNAM)//"CPDF",RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.NE.99) THEN + HHAD(K+1)='CPDF' + K=K+1 + ENDIF + CALL hdf5_info(IPAPX,TRIM(RECNAM)//"INTERNAL_ADF",RANK,TYPE, + 1 NBYTE,DIMSR) + IF(TYPE.NE.99) THEN + HHAD(K+1)='INTERNAL_ADF' + K=K+1 + ENDIF + CALL hdf5_info(IPAPX,TRIM(RECNAM)//"INTERNAL_CPDF",RANK,TYPE, + 1 NBYTE,DIMSR) + IF(TYPE.NE.99) THEN + HHAD(K+1)='INTERNAL_CPDF' + K=K+1 + ENDIF + IF(4*K.NE.NSURFD) CALL XABORT('SPHAPX: INVALID ADF COUNT.') + CALL LCMSIX(IPMAC,'ADF',1) + CALL LCMPUT(IPMAC,'NTYPE',1,1,NSURFD) + ALLOCATE(WRK(NGROUP),HADF(NSURFD)) + DO I=1,K + CALL hdf5_read_data(IPAPX,TRIM(RECNAM)//HHAD(I),ADF) + DO I0=1,4 + IF(HHAD(I).EQ.'ADF') THEN + WRITE(TEXT8,'(3HADF,I1)') I0 + ELSE IF(HHAD(I).EQ.'CPDF') THEN + WRITE(TEXT8,'(4HCPDF,I1)') I0 + ELSE IF(HHAD(I).EQ.'INTERNAL_ADF') THEN + WRITE(TEXT8,'(6HIN_ADF,I1)') I0 + ELSE IF(HHAD(I).EQ.'INTERNAL_CPDF') THEN + WRITE(TEXT8,'(7HIN_CPDF,I1)') I0 + ENDIF + HADF((I-1)*4+I0)=TEXT8 + WRK(:)=ADF(I0,:) + CALL LCMPUT(IPMAC,TEXT8,NGROUP,2,WRK) + ENDDO + DEALLOCATE(ADF) + ENDDO + CALL LCMPTC(IPMAC,'HADF',8,NSURFD,HADF) + DEALLOCATE(HADF,WRK) + CALL LCMSIX(IPMAC,' ',2) + ENDIF +*---- +* FIND SCATTERING ANISOTROPY. +*---- + WRITE(RECNAM,'(4Hcalc,I8,4H/xs/)') ICAL + IF(LFROM) WRITE(RECNAM,'(4Hcalc,I8,3H/xs,I8,1H/)') ICAL,1 + CALL hdf5_info(IPAPX,TRIM(RECNAM)//"mac/TOTAL/DIFF",RANK, + 1 TYPE,NBYTE,DIMSR) + IF(TYPE.EQ.99) THEN + CALL HDF5_list(IPAPX,TRIM(RECNAM)//"mac/TOTAL") + CALL XABORT('SPHAPX: MISSING SCATTERING INFO.') + ENDIF + NL=DIMSR(2) + IF(IMPX.GT.1) THEN + WRITE(IOUT,'(36H SPHAPX: number of Legendre orders =,I4)') NL + ENDIF +*---- +* ALLOCATE MACROLIB WORKING ARRAYS. +*---- + ALLOCATE(LXS(NREA),NWT0(NMIL,NGROUP),EFACT(NMIL,NGROUP), + 1 XVOLM(NMIL),SIGS(NMIL,NGROUP,NL),SS2D(NMIL,NGROUP,NGROUP,NL), + 2 XS(NMIL,NGROUP,NREA)) + NWT0(:NMIL,:NGROUP)=0.0 + EFACT(:NMIL,:NGROUP)=0.0 + SIGS(:NMIL,:NGROUP,:NL)=0.0 + SS2D(:NMIL,:NGROUP,:NGROUP,:NL)=0.0 + XS(:NMIL,:NGROUP,:NREA)=0.0 + LXS(:NREA)=.FALSE. + SPH(:NMIL,:NGROUP)=1.0 +*---- +* LOOP OVER APEX MIXTURES. +*---- + DO IBM=1,NMIL + IF(LFROM) WRITE(RECNAM,'(4Hcalc,I8,3H/xs,I8,1H/)') ICAL,IBM +*---- +* RECOVER SPH FACTORS +*---- + IF(HEQUI.NE.' ') THEN + WRITE(RECNAM2,'(A,11H/MEDIA_SPH/,A)') TRIM(RECNAM),TRIM(HEQUI) + CALL hdf5_info(IPAPX,TRIM(RECNAM2),RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.NE.99) THEN + CALL hdf5_read_data(IPAPX,TRIM(RECNAM2),WRK) + SPH(IBM,:NGROUP)=WRK(:NGROUP) + DEALLOCATE(WRK) + ENDIF + ENDIF +*---- +* RECOVER MIXTURE VOLUMES AND FLUXES. +*---- + CALL hdf5_info(IPAPX,TRIM(RECNAM)//"MEDIA_VOLUME",RANK, + 1 TYPE,NBYTE,DIMSR) + IF(TYPE.EQ.99) THEN + XVOLM(IBM)=1.0 + WRITE(IOUT,'(44H SPHAPX: WARNING -- Record MEDIA_VOLUME is m, + 1 42Hissing in the Apex file. Volume set to 1.0)') + ELSE + CALL hdf5_read_data(IPAPX,TRIM(RECNAM)//"MEDIA_VOLUME", + 1 XVOLM(IBM)) + ENDIF + CALL hdf5_read_data(IPAPX,TRIM(RECNAM)//"FLUX",FLUXS) + DO I=1,NGROUP + NWT0(IBM,I)=NWT0(IBM,I)+FLUXS(I)*XVOLM(IBM) + ENDDO + DEALLOCATE(FLUXS) +*---- +* RECOVER CROSS SECTIONS. +*---- + IRENT0=0 + DO IREA=1,NREA + IF(NOMREA(IREA).EQ.'TOTA') IRENT0=IREA + ENDDO + IF(IRENT0.EQ.0) CALL XABORT('SPHAPX: MISSING NTOT0.') + IMAC=ITOTM(IBM) + IRES=IRESM(IBM) + ALLOCATE(SIGSB(NGROUP,NL),SS2DB(NGROUP,NGROUP,NL), + 1 XSB(NGROUP,NREA)) + IF(IMAC.NE.0) THEN + CALL SPHSX5(IPAPX,RECNAM,NREA,NGROUP,NISOF,NISOP,NL,-1,NOMREA, + 1 SIGSB,SS2DB,XSB,LXS) + DO J=1,NL + DO I=1,NGROUP + SIGS(IBM,I,J)=SIGS(IBM,I,J)+SIGSB(I,J) + ENDDO + ENDDO + DO K=1,NL + DO J=1,NGROUP + DO I=1,NGROUP + SS2D(IBM,I,J,K)=SS2D(IBM,I,J,K)+SS2DB(I,J,K) + ENDDO + ENDDO + ENDDO + DO J=1,NREA + DO I=1,NGROUP + XS(IBM,I,J)=XS(IBM,I,J)+XSB(I,J) + ENDDO + ENDDO + ELSE IF(NBISO.GT.0) THEN + CALL hdf5_read_data(IPAPX,TRIM(RECNAM)//"mic/CONC",CONCES) + DO ISO=1,NBISO + DEN=CONCES(ISO) + IF(DEN.NE.0.0) THEN + CALL SPHSX5(IPAPX,RECNAM,NREA,NGROUP,NISOF,NISOP,NL,ISO, + 1 NOMREA,SIGSB,SS2DB,XSB,LXS) + DO J=1,NL + DO I=1,NGROUP + SIGS(IBM,I,J)=SIGS(IBM,I,J)+DEN*SIGSB(I,J) + ENDDO + ENDDO + DO K=1,NL + DO J=1,NGROUP + DO I=1,NGROUP + SS2D(IBM,I,J,K)=SS2D(IBM,I,J,K)+DEN*SS2DB(I,J,K) + ENDDO + ENDDO + ENDDO + DO J=1,NREA + DO I=1,NGROUP + XS(IBM,I,J)=XS(IBM,I,J)+DEN*XSB(I,J) + ENDDO + ENDDO + ENDIF + ENDDO + DEALLOCATE(CONCES) + IF(IRES.NE.0) THEN + CALL SPHSX5(IPAPX,RECNAM,NREA,NGROUP,NISOF,NISOP,NL,-2, + 1 NOMREA,SIGSB,SS2DB,XSB,LXS) + DO J=1,NL + DO I=1,NGROUP + SIGS(IBM,I,J)=SIGS(IBM,I,J)+SIGSB(I,J) + ENDDO + ENDDO + DO K=1,NL + DO J=1,NGROUP + DO I=1,NGROUP + SS2D(IBM,I,J,K)=SS2D(IBM,I,J,K)+SS2DB(I,J,K) + ENDDO + ENDDO + ENDDO + DO J=1,NREA + DO I=1,NGROUP + XS(IBM,I,J)=XS(IBM,I,J)+XSB(I,J) + ENDDO + ENDDO + ENDIF + ELSE + CALL XABORT('SPHAPX: NO MACROSCOPIC SET.') + ENDIF + DEALLOCATE(XSB,SS2DB,SIGSB) +* +* UP-SCATTERING CORRECTION OF THE MACROLIB. + IF(ILUPS.EQ.1) THEN + DO JGR=2,NGROUP + DO IGR=1,JGR-1 ! IGR < JGR + FF=NWT0(IBM,JGR)/NWT0(IBM,IGR) + CSCAT=SS2D(IBM,IGR,JGR,1) ! IGR < JGR + XS(IBM,IGR,IRENT0)=XS(IBM,IGR,IRENT0)-CSCAT*FF + XS(IBM,JGR,IRENT0)=XS(IBM,JGR,IRENT0)-CSCAT + DO IL=1,NL + CSCAT=SS2D(IBM,IGR,JGR,IL) + SIGS(IBM,IGR,IL)=SIGS(IBM,IGR,IL)-CSCAT*FF + SIGS(IBM,JGR,IL)=SIGS(IBM,JGR,IL)-CSCAT + SS2D(IBM,JGR,IGR,IL)=SS2D(IBM,JGR,IGR,IL)-CSCAT*FF + SS2D(IBM,IGR,JGR,IL)=0.0 + ENDDO + ENDDO + ENDDO + ENDIF +* end of loop over apex mixtures + ENDDO ! IBM +*---- +* IDENTIFY SPECIAL FLUX EDITS +*---- + ALLOCATE(HEDI(NREA)) + NED=0 + DO IREA=1,NREA + IF(NOMREA(IREA).EQ.'ABSO') THEN + NED=NED+1 + HEDI(NED)='ABSO' + ELSE IF(NOMREA(IREA).EQ.'FISS') THEN + NED=NED+1 + HEDI(NED)='NFTOT' + ENDIF + ENDDO +*---- +* STORE MACROLIB. +*---- + CALL LCMPUT(IPMAC,'VOLUME',NMIL,2,XVOLM) + IFISS=0 + ITRANC=0 + LDIFF=.FALSE. + LHFACT=.FALSE. + ALLOCATE(STR(NMIL),WRK(NMIL)) + SIGS0(:NMIL,:NGROUP)=0.0 + JPMAC=LCMLID(IPMAC,'GROUP',NGROUP) + DO IGR=1,NGROUP + STR(:NMIL)=0.0 + KPMAC=LCMDIL(JPMAC,IGR) + CALL LCMPUT(KPMAC,'FLUX-INTG',NMIL,2,NWT0(1,IGR)) + DO IREA=1,NREA + IF(.NOT.LXS(IREA)) CYCLE + IF(NOMREA(IREA).EQ.'TOTA') THEN + IF(LSTRD) THEN + DO IBM=1,NMIL + STR(IBM)=STR(IBM)+XS(IBM,IGR,IREA) + ENDDO + ENDIF + CALL LCMPUT(KPMAC,'NTOT0',NMIL,2,XS(1,IGR,IREA)) + ELSE IF(NOMREA(IREA).EQ.'N2N') THEN +* correct scattering XS with excess XS + SIGS0(:,IGR)=SIGS0(:,IGR)+XS(:,IGR,IREA) + CALL LCMPUT(KPMAC,'N2N',NMIL,2,XS(1,IGR,IREA)) + ELSE IF(NOMREA(IREA).EQ.'FISS') THEN + CALL LCMPUT(KPMAC,'NFTOT',NMIL,2,XS(1,IGR,IREA)) + ELSE IF(NOMREA(IREA).EQ.'CHI') THEN + CALL LCMPUT(KPMAC,'CHI',NMIL,2,XS(1,IGR,IREA)) + ELSE IF(NOMREA(IREA).EQ.'NUFI') THEN + IFISS=1 + CALL LCMPUT(KPMAC,'NUSIGF',NMIL,2,XS(1,IGR,IREA)) + ELSE IF(NOMREA(IREA).EQ.'ENER') THEN + LHFACT=.TRUE. + EFACT(:,IGR)=EFACT(:,IGR)+XS(:,IGR,IREA) + ELSE IF(NOMREA(IREA).EQ.'KAFI') THEN + LHFACT=.TRUE. + EFACT(:,IGR)=EFACT(:,IGR)+XS(:,IGR,IREA) + ELSE IF(NOMREA(IREA).EQ.'EGAM') THEN + LHFACT=.TRUE. + EFACT(:,IGR)=EFACT(:,IGR)+XS(:,IGR,IREA) + ELSE IF(NOMREA(IREA).EQ.'LEAK') THEN + LDIFF=LSTRD + IF(.NOT.LSTRD) THEN + DO IBM=1,NMIL + LDIFF=LDIFF.OR.(XS(IBM,IGR,IREA).NE.0.0) + STR(IBM)=XS(IBM,IGR,IREA)/B2 + ENDDO + ENDIF + ELSE IF(NOMREA(IREA).EQ.'DIFF') THEN + DO IL=1,NL + WRITE(CM,'(I2.2)') IL-1 + IF(IL.EQ.1) THEN + DO IBM=1,NMIL + SIGS0(IBM,IGR)=SIGS0(IBM,IGR)+SIGS(IBM,IGR,IL) + ENDDO + ELSE + CALL LCMPUT(KPMAC,'SIGS'//CM,NMIL,2,SIGS(1,IGR,IL)) + ENDIF + ENDDO + ELSE IF(NOMREA(IREA).EQ.'SCAT') THEN + ALLOCATE(SCAT(NGROUP*NMIL),GAR(NMIL)) + DO IL=1,NL + WRITE(CM,'(I2.2)') IL-1 + IPOSDE=0 + DO IBM=1,NMIL + IPOS(IBM)=IPOSDE+1 + IGMIN=IGR + IGMAX=IGR + DO JGR=NGROUP,1,-1 + IF(SS2D(IBM,IGR,JGR,IL).NE.0.0) THEN + IGMIN=MIN(IGMIN,JGR) + IGMAX=MAX(IGMAX,JGR) + ENDIF + ENDDO + IJJM(IBM)=IGMAX + NJJM(IBM)=IGMAX-IGMIN+1 + DO JGR=IGMAX,IGMIN,-1 + IPOSDE=IPOSDE+1 + SCAT(IPOSDE)=SS2D(IBM,IGR,JGR,IL) + ENDDO + GAR(IBM)=SCAT(IPOS(IBM)+IJJM(IBM)-IGR) + ENDDO + CALL LCMPUT(KPMAC,'SCAT'//CM,IPOSDE,2,SCAT) + CALL LCMPUT(KPMAC,'NJJS'//CM,NMIL,1,NJJM) + CALL LCMPUT(KPMAC,'IJJS'//CM,NMIL,1,IJJM) + CALL LCMPUT(KPMAC,'IPOS'//CM,NMIL,1,IPOS) + CALL LCMPUT(KPMAC,'SIGW'//CM,NMIL,2,GAR) + ENDDO + DEALLOCATE(GAR,SCAT) + ELSE + CALL LCMPUT(KPMAC,NOMREA(IREA),NMIL,2,XS(1,IGR,IREA)) + ENDIF + ENDDO + IF(LSTRD) THEN + IF((ITRANC.EQ.0).AND.(NL.GT.1)) THEN +* Apollo-type transport correction + DO IBM=1,NMIL + STR(IBM)=STR(IBM)-SIGS(IBM,IGR,2) + ENDDO + ENDIF + DO IBM=1,NMIL + STR(IBM)=1.0/(3.0*STR(IBM)) + ENDDO + LDIFF=.TRUE. + ENDIF + IF((ITRANC.EQ.0).AND.(NL.GT.1)) THEN +* Apollo-type transport correction + IF(IGR.EQ.NGROUP) ITRANC=2 + CALL LCMPUT(KPMAC,'TRANC',NMIL,2,SIGS(1,IGR,2)) + ENDIF + IF(LDIFF) CALL LCMPUT(KPMAC,'DIFF',NMIL,2,STR) + IF(LHFACT) CALL LCMPUT(KPMAC,'H-FACTOR',NMIL,2,EFACT(1,IGR)) + ENDDO + DEALLOCATE(WRK,STR) +*---- +* RELEASE MEMORY +*---- + DEALLOCATE(LXS,XS,SS2D,SIGS,XVOLM,EFACT,NWT0) + IF(NBISO.GT.0) DEALLOCATE(NOMISO) + DEALLOCATE(NOMREA,IRESM,ITOTM) +*---- +* SAVE SCATTERING P0 INFO +*---- + DO IGR=1,NGROUP + KPMAC=LCMDIL(JPMAC,IGR) + CALL LCMPUT(KPMAC,'SIGS00',NMIL,2,SIGS0(1,IGR)) + ENDDO +*---- +* WRITE STATE VECTOR +*---- + TEXT12='L_MACROLIB' + CALL LCMPTC(IPMAC,'SIGNATURE',12,TEXT12) + ISTATE(:NSTATE)=0 + ISTATE(1)=NGROUP + ISTATE(2)=NMIL + ISTATE(3)=NL ! 1+scattering anisotropy + ISTATE(4)=IFISS + ISTATE(5)=NED + ISTATE(6)=ITRANC + IF(LDIFF) ISTATE(9)=1 + IF(NSURFD.GT.0) ISTATE(12)=3 ! ADF/CPDF information + CALL LCMPUT(IPMAC,'STATE-VECTOR',NSTATE,1,ISTATE) + IF(NED.GT.0) CALL LCMPTC(IPMAC,'ADDXSNAME-P0',8,NED,HEDI) + DEALLOCATE(HEDI) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SIGS0) + DEALLOCATE(NOMMIL,IJJM,NJJM,IPOS) + RETURN + END diff --git a/Dragon/src/SPHCMA.f b/Dragon/src/SPHCMA.f new file mode 100644 index 0000000..3c4b8d6 --- /dev/null +++ b/Dragon/src/SPHCMA.f @@ -0,0 +1,385 @@ +*DECK SPHCMA + SUBROUTINE SPHCMA(IPMACR,IPRINT,IMC,NMERGE,NGCOND,NIFISS,NED, + 1 NALBP,SPH) +* +*----------------------------------------------------------------------- +* +*Purpose: +* SPH-correction of a Macrolib. +* +*Copyright: +* Copyright (C) 2011 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMACR pointer to the condensed macrolib (L_MACROLIB signature). +* IPRINT print flag (equal to 0 for no print). +* IMC type of macro-calculation (=1 diffusion or SPN; +* =2 other options; +* =3 type PIJ with Bell acceleration). +* NMERGE number of merged regions. +* NGCOND number of condensed groups. +* NIFISS number of fissile isotopes. +* NED number of additional phi-weighted edits in macrolib. +* NALBP number of physical albedos per condensed group. +* SPH SPH homogenization factors. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMACR + INTEGER IPRINT,IMC,NMERGE,NGCOND,NIFISS,NED,NALBP + REAL SPH(NMERGE+NALBP,NGCOND) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + INTEGER ISTATE(NSTATE) + DOUBLE PRECISION DNUM,DDEN + CHARACTER HSIGN*12,TEXT12*12,TEXT2*2,TEXT8*8 + TYPE(C_PTR) JPMACR,KPMACR + INTEGER, ALLOCATABLE, DIMENSION(:) :: NJJ,IJJ,IPOS + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IHEDIT + REAL, ALLOCATABLE, DIMENSION(:) :: GAR1,SPHHOM + REAL, ALLOCATABLE, DIMENSION(:,:) :: NTOT,GAR2,ALB + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SIGS +*---- +* SCRATCH STORAGE ALLOCATION +* IHEDIT character*8 names of phi-weighted edits in macrolib. +*---- + ALLOCATE(IHEDIT(2,NED+1),NJJ(NMERGE),IJJ(NMERGE),IPOS(NMERGE)) + ALLOCATE(GAR1(NMERGE*NGCOND),GAR2(NMERGE,NIFISS),SPHHOM(NGCOND)) +*---- +* RECOVER MACROLIB INFORMATION +*---- + CALL LCMGTC(IPMACR,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_MACROLIB') CALL XABORT('SPHCMA: MACROLIB EXPECTED') + CALL LCMGET(IPMACR,'STATE-VECTOR',ISTATE) + IF(NGCOND.NE.ISTATE(1)) THEN + CALL XABORT('SPHCMA: INVALID NGCOND') + ELSE IF(NMERGE.NE.ISTATE(2)) THEN + CALL XABORT('SPHCMA: INVALID NMERGE') + ELSE IF((NIFISS.NE.0).AND.(NIFISS.NE.ISTATE(4))) THEN + CALL XABORT('SPHCMA: INVALID NIFISS') + ELSE IF(NED.NE.ISTATE(5)) THEN + CALL XABORT('SPHCMA: INVALID NED') + ELSE IF(NALBP.NE.ISTATE(8)) THEN + CALL XABORT('SPHCMA: INVALID NALBP') + ENDIF +* + IF(NED.GT.0) CALL LCMGET(IPMACR,'ADDXSNAME-P0',IHEDIT) + NL=ISTATE(3) + ITRANC=ISTATE(6) + NDEL=ISTATE(7) + ILEAKS=ISTATE(9) + NW=MAX(1,ISTATE(10)) + ISTATE(10)=NW + ISTATE(14)=1 + CALL LCMPUT(IPMACR,'STATE-VECTOR',NSTATE,1,ISTATE) +*---- +* LOOP OVER GROUPS +*---- + ALLOCATE(SIGS(NMERGE,NGCOND,NL)) + SIGS(:NMERGE,:NGCOND,:NL)=0.0 + JPMACR=LCMGID(IPMACR,'GROUP') + DO 230 IGR=1,NGCOND + KPMACR=LCMGIL(JPMACR,IGR) +*---- +* SPH FACTORS +*---- + CALL LCMPUT(KPMACR,'NSPH',NMERGE,2,SPH(1,IGR)) +*---- +* INTEGRATED FLUX +*---- + CALL LCMLEN(KPMACR,'FLUX-INTG',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.0) CALL XABORT('SPHCMA: MISSING FLUX-INTG INFO') + CALL LCMGET(KPMACR,'FLUX-INTG',GAR1) + DNUM=0.0D0 + DDEN=0.0D0 + DO 10 IBM=1,NMERGE + DNUM=DNUM+GAR1(IBM) + GAR1(IBM)=GAR1(IBM)/SPH(IBM,IGR) + DDEN=DDEN+GAR1(IBM) + 10 CONTINUE + CALL LCMPUT(KPMACR,'FLUX-INTG',NMERGE,2,GAR1) + SPHHOM(IGR)=REAL(DNUM/DDEN) + DO 15 IW=2,MIN(NW+1,10) + WRITE(TEXT12,'(11HFLUX-INTG-P,I1)') IW-1 + CALL LCMLEN(KPMACR,TEXT12,ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,TEXT12,GAR1) + ELSE + CALL LCMGET(KPMACR,'FLUX-INTG',GAR1) + ENDIF + IF(MOD(IW-1,2).EQ.0) GAR1(IBM)=GAR1(IBM)/SPH(IBM,IGR) + CALL LCMPUT(KPMACR,TEXT12,NMERGE,2,GAR1) + 15 CONTINUE +*---- +* MACROSCOPIC TOTAL CROSS SECTIONS +*---- + CALL LCMLEN(KPMACR,'NTOT0',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.0) CALL XABORT('SPHCMA: MISSING NTOT0 INFO') + ALLOCATE(NTOT(NMERGE,NW+1)) + DO 40 IW=1,MIN(NW+1,10) + WRITE(TEXT12,'(4HNTOT,I1)') IW-1 + CALL LCMLEN(KPMACR,TEXT12,ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,TEXT12,NTOT(1,IW)) + ELSE + NTOT(:,IW)=NTOT(:,1) + ENDIF + IF((IMC.EQ.1).AND.(MOD(IW-1,2).EQ.0)) THEN + DO 20 IBM=1,NMERGE + GAR1(IBM)=NTOT(IBM,IW)*SPH(IBM,IGR) + 20 CONTINUE + ELSEIF((IMC.EQ.1).AND.(MOD(IW-1,2).EQ.1)) THEN + DO 30 IBM=1,NMERGE + GAR1(IBM)=NTOT(IBM,IW)/SPH(IBM,IGR) + 30 CONTINUE + ELSE + GAR1(:NMERGE)=NTOT(:NMERGE,IW) + ENDIF + CALL LCMPUT(KPMACR,TEXT12,NMERGE,2,GAR1) + 40 CONTINUE +*---- +* MACROSCOPIC NU*FISSION CROSS SECTIONS (STEADY-STATE AND DELAYED) +*---- + IF(NIFISS.GT.0) THEN + CALL LCMGET(KPMACR,'NUSIGF',GAR2) + DO 55 IFIS=1,NIFISS + DO 50 IBM=1,NMERGE + GAR2(IBM,IFIS)=GAR2(IBM,IFIS)*SPH(IBM,IGR) + 50 CONTINUE + 55 CONTINUE + CALL LCMPUT(KPMACR,'NUSIGF',NMERGE*NIFISS,2,GAR2) + DO 70 IDEL=1,NDEL + WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL + CALL LCMGET(KPMACR,TEXT12,GAR2) + DO 65 IFIS=1,NIFISS + DO 60 IBM=1,NMERGE + GAR2(IBM,IFIS)=GAR2(IBM,IFIS)*SPH(IBM,IGR) + 60 CONTINUE + 65 CONTINUE + CALL LCMPUT(KPMACR,TEXT12,NMERGE*NIFISS,2,GAR2) + 70 CONTINUE + ENDIF +*---- +* MACROSCOPIC SCATTERING CROSS SECTIONS +*---- + DO 110 IL=1,NL + WRITE(TEXT2,'(I2.2)') IL-1 + CALL LCMLEN(KPMACR,'NJJS'//TEXT2,ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'NJJS'//TEXT2,NJJ) + CALL LCMGET(KPMACR,'IJJS'//TEXT2,IJJ) + CALL LCMGET(KPMACR,'IPOS'//TEXT2,IPOS) + CALL LCMGET(KPMACR,'SCAT'//TEXT2,GAR1) + IPO=0 + DO 85 IBM=1,NMERGE + IPO=IPOS(IBM) + DO 80 JGR=IJJ(IBM),IJJ(IBM)-NJJ(IBM)+1,-1 + IF(MOD(IL-1,2).EQ.0) THEN + IF((IGR.EQ.JGR).AND.(IMC.GT.1).AND.(IL.LE.NW+1)) THEN + GAR1(IPO)=GAR1(IPO)*SPH(IBM,IGR)+ + > (NTOT(IBM,1)-NTOT(IBM,IL)*SPH(IBM,IGR)) + ELSE + GAR1(IPO)=GAR1(IPO)*SPH(IBM,JGR) ! IGR <- JGR + ENDIF + ELSE + IF((IGR.EQ.JGR).AND.(IMC.GT.1).AND.(IL.LE.NW+1)) THEN + GAR1(IPO)=GAR1(IPO)/SPH(IBM,IGR)+ + > (NTOT(IBM,1)-NTOT(IBM,IL)/SPH(IBM,IGR)) + ELSE + GAR1(IPO)=GAR1(IPO)/SPH(IBM,IGR) + ENDIF + ENDIF + SIGS(IBM,JGR,IL)=SIGS(IBM,JGR,IL)+GAR1(IPO) + IPO=IPO+1 + 80 CONTINUE + 85 CONTINUE + CALL LCMPUT(KPMACR,'SCAT'//TEXT2,IPO-1,2,GAR1) + ENDIF + CALL LCMLEN(KPMACR,'SIGW'//TEXT2,ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'SIGW'//TEXT2,GAR1) + DO 90 IBM=1,NMERGE + IF(MOD(IL-1,2).EQ.0) THEN + IF((IMC.GT.1).AND.(IL.LE.NW+1)) THEN + GAR1(IBM)=GAR1(IBM)*SPH(IBM,IGR)+ + > (NTOT(IBM,1)-NTOT(IBM,IL)*SPH(IBM,IGR)) + ELSE + GAR1(IBM)=GAR1(IBM)*SPH(IBM,IGR) + ENDIF + ELSE + IF((IMC.GT.1).AND.(IL.LE.NW+1)) THEN + GAR1(IBM)=GAR1(IBM)/SPH(IBM,IGR)+ + > (NTOT(IBM,1)-NTOT(IBM,IL)/SPH(IBM,IGR)) + ELSE + GAR1(IBM)=GAR1(IBM)/SPH(IBM,IGR) + ENDIF + ENDIF + 90 CONTINUE + CALL LCMPUT(KPMACR,'SIGW'//TEXT2,NMERGE,2,GAR1) + ENDIF + 110 CONTINUE + DEALLOCATE(NTOT) +*---- +* DIFFUSION COEFFICIENTS +*---- + IF(ILEAKS.EQ.1) THEN + CALL LCMLEN(KPMACR,'DIFF',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.0) CALL XABORT('SPHCMA: UNABLE TO RECOVER DIFF R' + > //'ECORDS IN THE MACROLIB OBJECT.') + CALL LCMGET(KPMACR,'DIFF',GAR1) + DO 120 IBM=1,NMERGE + GAR1(IBM)=GAR1(IBM)*SPH(IBM,IGR) + 120 CONTINUE + CALL LCMPUT(KPMACR,'DIFF',NMERGE,2,GAR1) + ELSE IF(ILEAKS.EQ.2) THEN + CALL LCMLEN(KPMACR,'DIFFX',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'DIFFX',GAR1) + DO 140 IBM=1,NMERGE + GAR1(IBM)=GAR1(IBM)*SPH(IBM,IGR) + 140 CONTINUE + CALL LCMPUT(KPMACR,'DIFFX',NMERGE,2,GAR1) + ENDIF + CALL LCMLEN(KPMACR,'DIFFY',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'DIFFY',GAR1) + DO 150 IBM=1,NMERGE + GAR1(IBM)=GAR1(IBM)*SPH(IBM,IGR) + 150 CONTINUE + CALL LCMPUT(KPMACR,'DIFFY',NMERGE,2,GAR1) + ENDIF + CALL LCMLEN(KPMACR,'DIFFZ',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'DIFFZ',GAR1) + DO 160 IBM=1,NMERGE + GAR1(IBM)=GAR1(IBM)*SPH(IBM,IGR) + 160 CONTINUE + CALL LCMPUT(KPMACR,'DIFFZ',NMERGE,2,GAR1) + ENDIF + ENDIF +*---- +* SPECIFIC REACTIONS +*---- + CALL LCMLEN(KPMACR,'H-FACTOR',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'H-FACTOR',GAR1) + DO 170 IBM=1,NMERGE + GAR1(IBM)=GAR1(IBM)*SPH(IBM,IGR) + 170 CONTINUE + CALL LCMPUT(KPMACR,'H-FACTOR',NMERGE,2,GAR1) + ENDIF + CALL LCMLEN(KPMACR,'OVERV',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'OVERV',GAR1) + DO 180 IBM=1,NMERGE + GAR1(IBM)=GAR1(IBM)*SPH(IBM,IGR) + 180 CONTINUE + CALL LCMPUT(KPMACR,'OVERV',NMERGE,2,GAR1) + ENDIF + CALL LCMLEN(KPMACR,'TRANC',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'TRANC',GAR1) + DO 190 IBM=1,NMERGE + GAR1(IBM)=GAR1(IBM)/SPH(IBM,IGR) + 190 CONTINUE + CALL LCMPUT(KPMACR,'TRANC',NMERGE,2,GAR1) + ENDIF + CALL LCMLEN(KPMACR,'ABS',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'ABS',GAR1) + DO 200 IBM=1,NMERGE + GAR1(IBM)=GAR1(IBM)*SPH(IBM,IGR) + 200 CONTINUE + CALL LCMPUT(KPMACR,'ABS',NMERGE,2,GAR1) + ENDIF +*---- +* ADDITIONAL PHI-WEIGHTED EDITS +*---- + DO 220 IED=1,NED + WRITE(TEXT8,'(2A4)') (IHEDIT(I0,IED),I0=1,2) + IF((TEXT8.EQ.'H-FACTOR').OR.(TEXT8(:5).EQ.'OVERV').OR. + > (TEXT8(:3).EQ.'ABS').OR.(TEXT8(:5).EQ.'TRANC')) GO TO 220 + CALL LCMLEN(KPMACR,TEXT8,ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,TEXT8,GAR1) + DO 210 IBM=1,NMERGE + IF(TEXT8(:4).EQ.'STRD') THEN + GAR1(IBM)=GAR1(IBM)/SPH(IBM,IGR) + ELSE + GAR1(IBM)=GAR1(IBM)*SPH(IBM,IGR) + ENDIF + 210 CONTINUE + CALL LCMPUT(KPMACR,TEXT8,NMERGE,2,GAR1) + ENDIF + 220 CONTINUE + 230 CONTINUE +*---- +* STORE SCATTERING CROSS SECTIONS +*---- + DO 245 IGR=1,NGCOND + KPMACR=LCMGIL(JPMACR,IGR) + CALL LCMLEN(KPMACR,'SIGS00',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'SIGS00',SIGS(1,IGR,1)) + CALL LCMGET(KPMACR,'NTOT0',GAR1) + DO 235 IBM=1,NMERGE + IF(IMC.EQ.1) THEN + SIGS(IBM,IGR,1)=SIGS(IBM,IGR,1)*SPH(IBM,IGR) + ELSE + SIGS(IBM,IGR,1)=SIGS(IBM,IGR,1)*SPH(IBM,IGR)+GAR1(IBM)* + > (1.0-SPH(IBM,IGR)) + ENDIF + 235 CONTINUE + ENDIF + DO 240 IL=1,NL + WRITE(TEXT2,'(I2.2)') IL-1 + CALL LCMLEN(KPMACR,'SIGS'//TEXT2,ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMPUT(KPMACR,'SIGS'//TEXT2,NMERGE,2,SIGS(1,IGR,IL)) + ENDIF + 240 CONTINUE + 245 CONTINUE + DEALLOCATE(SIGS) +*---- +* PHYSICAL ALBEDOS +*---- + IF(NALBP.GT.0) THEN + CALL LCMLEN(IPMACR,'ALBEDO',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.NALBP*NGCOND) THEN + ALLOCATE(ALB(NALBP,NGCOND)) + CALL LCMGET(IPMACR,'ALBEDO',ALB) + DO 270 IGR=1,NGCOND + DO 260 IAL=1,NALBP + FACT=0.5*(1.0-ALB(IAL,IGR))/(1.0+ALB(IAL,IGR))* + 1 SPH(NMERGE+IAL,IGR) + ALB(IAL,IGR)=(1.0-2.0*FACT)/(1.0+2.0*FACT) + 260 CONTINUE + 270 CONTINUE + CALL LCMPUT(IPMACR,'ALBEDO',NGCOND*NALBP,2,ALB) + DEALLOCATE(ALB) + ELSE IF(ILCMLN.EQ.NALBP*NGCOND*NGCOND) THEN + ! no SPH correction of albedo matrices. + ELSE + CALL XABORT('SPHCMA: INVALID ALBEDO LENGTH.') + ENDIF + ENDIF + IF(IPRINT.GT.5) WRITE(6,'(/28H SPHCMA: MACROLIB CORRECTED.)') +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SPHHOM,GAR2,GAR1) + DEALLOCATE(IPOS,IJJ,NJJ,IHEDIT) + RETURN + END diff --git a/Dragon/src/SPHCMI.f b/Dragon/src/SPHCMI.f new file mode 100644 index 0000000..d977cd3 --- /dev/null +++ b/Dragon/src/SPHCMI.f @@ -0,0 +1,276 @@ +*DECK SPHCMI + SUBROUTINE SPHCMI(IPMICR,IPRINT,IMC,NMERGE,NISOT,NGCOND,NL,NW, + 1 NED,NDEL,NALBP,SPH) +* +*----------------------------------------------------------------------- +* +*Purpose: +* SPH-correction of a Microlib. +* +*Copyright: +* Copyright (C) 2011 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMICR pointer to the condensed microlib (L_LIBRARY signature). +* IPRINT print flag (equal to 0 for no print). +* IMC type of macro-calculation (=1 diffusion or SPN; +* =2 other options; +* =3 type PIJ with Bell acceleration). +* NMERGE number of merged regions. +* NISOT number of isotopes in microlib. +* NGCOND number of condensed groups. +* NL number of Legendre orders in scattering info. +* NW type of weighting for PN cross section info (=0 P0; =1 P1). +* NED number of additional phi-weighted edits in microlib. +* NDEL number of delayed precursor groups. +* NALBP number of physical albedos per condensed group. +* SPH SPH homogenization factors. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMICR + INTEGER IPRINT,IMC,NMERGE,NISOT,NGCOND,NL,NW,NED,NDEL,NALBP + REAL SPH(NMERGE+NALBP,NGCOND) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + INTEGER ISTATE(NSTATE) + TYPE(C_PTR) KPMICR + CHARACTER HSIGN*12,TEXT12*12,CM*2,TEXT8*8,HSMG*131 + DOUBLE PRECISION DSUM +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IMIX,ITYPR + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IHUSED,IHEDIT + REAL, ALLOCATABLE, DIMENSION(:,:) :: GAR + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: WSCAT + CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: HMAKE + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO +*---- +* SCRATCH STORAGE ALLOCATION +* IHEDIT character*8 names of phi-weighted edits in microlib. +*---- + MAXH=7+2*NW+NL+NED+NDEL + ALLOCATE(IHEDIT(2,NED+1),ITYPR(NL)) + ALLOCATE(GAR(NGCOND,MAXH),WSCAT(NGCOND,NGCOND,NL)) + ALLOCATE(IHUSED(3,NISOT),IMIX(NISOT),IPISO(NISOT)) + ALLOCATE(HMAKE(MAXH+NL)) +*---- +* RECOVER MICROLIB INFORMATION +*---- + CALL LCMLEN(IPMICR,'SIGNATURE',LENGTH,ITYLCM) + IF(LENGTH.EQ.0) GO TO 210 + CALL LCMGTC(IPMICR,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_LIBRARY') CALL XABORT('SPHCMI: MICROLIB EXPECTED') + CALL LCMGET(IPMICR,'STATE-VECTOR',ISTATE) + IF(ISTATE(1).NE.NMERGE) CALL XABORT('SPHCMI: INVALID NMERGE') + IF(ISTATE(2).NE.NISOT) CALL XABORT('SPHCMI: INVALID NISOT') + IF(ISTATE(3).NE.NGCOND) CALL XABORT('SPHCMI: INVALID NGCOND') + IF(ISTATE(4).NE.NL) CALL XABORT('SPHCMI: INVALID NL') + IF(ISTATE(13).NE.NED) CALL XABORT('SPHCMI: INVALID NED') + IF(ISTATE(19).NE.NDEL) CALL XABORT('SPHCMI: INVALID NDEL') + IF(NED.GT.0) CALL LCMGET(IPMICR,'ADDXSNAME-P0',IHEDIT) +*---- +* LOOP OVER ISOTOPES +*---- + CALL LCMGET(IPMICR,'ISOTOPESUSED',IHUSED) + CALL LCMGET(IPMICR,'ISOTOPESMIX',IMIX) + CALL LIBIPS(IPMICR,NISOT,IPISO) + DO 200 ISOT=1,NISOT + WRITE(TEXT12,'(3A4)') (IHUSED(I0,ISOT),I0=1,3) + IF(IPRINT.GT.4) THEN + WRITE(6,'(29H SPHCMI: PROCESSING ISOTOPE '',A12,2H''.)') TEXT12 + ENDIF + IBM=IMIX(ISOT) + KPMICR=IPISO(ISOT) ! set ISOT-th isotope + IF(.NOT.C_ASSOCIATED(KPMICR)) THEN + WRITE(HSMG,'(17HSPHCMI: ISOTOPE '',A12,16H'' IS NOT AVAILAB, + > 19HLE IN THE MICROLIB.)') TEXT12 + CALL XABORT(HSMG) + ENDIF + MAXH=MAXH + DO 10 J=1,MAXH+NL + HMAKE(J)=' ' + 10 CONTINUE + GAR(:NGCOND,:MAXH)=0.0 + WSCAT(:NGCOND,:NGCOND,:NL)=0.0 +*---- +* RECOVER CALCULATION-SPECIFIC ISOTOPIC DATA +*---- + DO 20 IW=1,MIN(NW+1,10) + WRITE(TEXT12,'(3HNWT,I1)') IW-1 + CALL LCMLEN(KPMICR,TEXT12,LENGTH,ITYLCM) + IF(LENGTH.EQ.NGCOND) THEN + CALL LCMGET(KPMICR,TEXT12,GAR(1,IW)) + ELSE + CALL LCMGET(KPMICR,'NWT0',GAR(1,IW)) + ENDIF + HMAKE(IW)=TEXT12 + WRITE(TEXT12,'(4HNTOT,I1)') IW-1 + CALL LCMLEN(KPMICR,TEXT12,LENGTH,ITYLCM) + IF(LENGTH.EQ.NGCOND) THEN + CALL LCMGET(KPMICR,TEXT12,GAR(1,1+IW+NW)) + ELSE + CALL LCMGET(KPMICR,'NTOT0',GAR(1,1+IW+NW)) + ENDIF + HMAKE(1+IW+NW)=TEXT12 + 20 CONTINUE + CALL XDRLGS(KPMICR,-1,IPRINT,0,NL-1,1,NGCOND,GAR(1,3+2*NW),WSCAT, + > ITYPR) + DO 30 IL=0,NL-1 + IF(ITYPR(IL+1).NE.0) THEN + WRITE (CM,'(I2.2)') IL + HMAKE(3+2*NW+IL)='SIGS'//CM + ENDIF + 30 CONTINUE + CALL LCMLEN(KPMICR,'NUSIGF',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGCOND) THEN + CALL LCMGET(KPMICR,'NUSIGF',GAR(1,3+2*NW+NL)) + HMAKE(3+2*NW+NL)='NUSIGF' + ENDIF + IF(NDEL.GT.0) THEN + WRITE(TEXT12,'(6HNUSIGF,I2.2)') NDEL + CALL LCMLEN(KPMICR,TEXT12,LENGTH,ITYLCM) + IF(LENGTH.EQ.NGCOND) THEN + DO 40 IDEL=1,NDEL + WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL + CALL LCMGET(KPMICR,TEXT12,GAR(1,3+2*NW+NL+IDEL)) + HMAKE(3+2*NW+NL+IDEL)=TEXT12 + 40 CONTINUE + ENDIF + ENDIF + CALL LCMLEN(KPMICR,'H-FACTOR',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGCOND) THEN + CALL LCMGET(KPMICR,'H-FACTOR',GAR(1,4+2*NW+NL+NDEL)) + HMAKE(4+2*NW+NL+NDEL)='H-FACTOR' + ENDIF + CALL LCMLEN(KPMICR,'OVERV',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGCOND) THEN + CALL LCMGET(KPMICR,'OVERV',GAR(1,5+2*NW+NL+NDEL)) + HMAKE(5+2*NW+NL+NDEL)='OVERV' + ENDIF + CALL LCMLEN(KPMICR,'TRANC',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGCOND) THEN + CALL LCMGET(KPMICR,'TRANC',GAR(1,6+2*NW+NL+NDEL)) + HMAKE(6+2*NW+NL+NDEL)='TRANC' + ENDIF + DO 60 IED=1,NED + WRITE(TEXT8,'(2A4)') (IHEDIT(I0,IED),I0=1,2) + CALL LCMLEN(KPMICR,TEXT8,LENGTH,ITYLCM) + IF((LENGTH.GT.0).AND.(TEXT8.NE.'TRANC')) THEN + CALL LCMGET(KPMICR,TEXT8,GAR(1,6+2*NW+NL+NDEL+IED)) + HMAKE(6+2*NW+NL+NDEL+IED)=TEXT8 + ENDIF + 60 CONTINUE + CALL LCMLEN(KPMICR,'STRD',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGCOND) THEN + CALL LCMGET(KPMICR,'STRD',GAR(1,7+2*NW+NL+NDEL+NED)) + HMAKE(7+2*NW+NL+NDEL+NED)='STRD' + ENDIF +*---- +* APPLY SPH CORRECTION +*---- + DO 80 J=1,MAXH + IF((HMAKE(J).NE.' ').AND.(HMAKE(J)(:4).NE.'SIGS')) THEN + DO 70 IG=1,NGCOND + IF((HMAKE(J)(:4).EQ.'NTOT').AND.(MOD(J-2-NW,2).EQ.1).AND. + > (IMC.EQ.1)) THEN + GAR(IG,J)=GAR(IG,J)/SPH(IBM,IG) + ELSE IF((HMAKE(J)(:3).EQ.'NWT').AND.(MOD(J-1,2).EQ.0)) THEN + GAR(IG,J)=GAR(IG,J)/SPH(IBM,IG) + ELSE IF((HMAKE(J)(:4).EQ.'STRD').OR.(HMAKE(J).EQ.'TRANC')) THEN + GAR(IG,J)=GAR(IG,J)/SPH(IBM,IG) + ELSE IF((HMAKE(J)(:3).EQ.'NWT').AND.(MOD(J-1,2).EQ.1)) THEN + CONTINUE + ELSE IF((HMAKE(J)(:4).EQ.'NTOT').AND.(MOD(J-2-NW,2).EQ.0).AND. + > (IMC.EQ.1)) THEN + GAR(IG,J)=GAR(IG,J)*SPH(IBM,IG) + ELSE IF((HMAKE(J)(:4).EQ.'NTOT').AND.(IMC.GT.1)) THEN + CONTINUE + ELSE + GAR(IG,J)=GAR(IG,J)*SPH(IBM,IG) + ENDIF + 70 CONTINUE + ENDIF + 80 CONTINUE + DO 105 IL=1,NL + ITYPR(IL)=0 + IF(HMAKE(MAXH+IL+1).NE.' ') ITYPR(IL)=1 + DO 100 IG2=1,NGCOND + DSUM=0.0 + DO 90 IG1=1,NGCOND + IF(MOD(IL-1,2).EQ.0) THEN + IF((IG1.EQ.IG2).AND.(IMC.GT.1).AND.(IL.LE.NW+1)) THEN + WSCAT(IG1,IG1,IL)=WSCAT(IG1,IG1,IL)*SPH(IBM,IG1) + > +(GAR(IG1,2+NW)-GAR(IG1,1+IL+NW)*SPH(IBM,IG1)) + ELSE + WSCAT(IG1,IG2,IL)=WSCAT(IG1,IG2,IL)*SPH(IBM,IG2) ! IG1 <- IG2 + ENDIF + ELSE + IF((IG1.EQ.IG2).AND.(IMC.GT.1).AND.(IL.LE.NW+1)) THEN + WSCAT(IG1,IG1,IL)=WSCAT(IG1,IG1,IL)/SPH(IBM,IG1) + > +(GAR(IG1,2+NW)-GAR(IG1,1+IL+NW)/SPH(IBM,IG1)) + ELSE + WSCAT(IG1,IG2,IL)=WSCAT(IG1,IG2,IL)/SPH(IBM,IG1) + ENDIF + ENDIF + DSUM=DSUM+WSCAT(IG1,IG2,IL) + 90 CONTINUE + IF((IL.EQ.1).AND.(IMC.GT.1)) THEN + GAR(IG2,2+2*NW+IL)=GAR(IG2,2+2*NW+IL)*SPH(IBM,IG2)+ + > GAR(IG2,2+NW)*(1.0-SPH(IBM,IG2)) + ELSE IF(IL.EQ.1) THEN + GAR(IG2,2+2*NW+IL)=GAR(IG2,2+2*NW+IL)*SPH(IBM,IG2) + ELSE + GAR(IG2,2+2*NW+IL)=REAL(DSUM) + ENDIF + 100 CONTINUE + 105 CONTINUE +*---- +* SAVE CORRECTED INFORMATION ON LCM +*---- + DO 110 J=1,MAXH + IF((HMAKE(J).NE.' ').AND.(HMAKE(J)(:4).NE.'SIGS')) THEN + CALL LCMPUT(KPMICR,HMAKE(J),NGCOND,2,GAR(1,J)) + ENDIF + 110 CONTINUE + CALL XDRLGS(KPMICR,1,IPRINT,0,NL-1,1,NGCOND,GAR(1,3+2*NW),WSCAT, + > ITYPR) + 200 CONTINUE +*---- +* CORRECT MACROLIB INFORMATION +*---- + 210 CALL LCMLEN(IPMICR,'MACROLIB',LENGTH,ITYLCM) + IF(LENGTH.NE.0) THEN + CALL LCMSIX(IPMICR,'MACROLIB',1) + CALL LCMLEN(IPMICR,'STATE-VECTOR',LENGTH,ITYLCM) + IF(LENGTH.GT.0) THEN + CALL LCMGET(IPMICR,'STATE-VECTOR',ISTATE) + NIFISS=ISTATE(4) + CALL SPHCMA(IPMICR,IPRINT,IMC,NMERGE,NGCOND,NIFISS,NED,NALBP, + > SPH) + ENDIF + CALL LCMSIX(IPMICR,' ',2) + ENDIF + IF(IPRINT.GT.5) WRITE(6,'(/28H SPHCMI: MICROLIB CORRECTED.)') +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(HMAKE) + DEALLOCATE(IPISO,IMIX,IHUSED) + DEALLOCATE(WSCAT,GAR) + DEALLOCATE(ITYPR,IHEDIT) + RETURN + END diff --git a/Dragon/src/SPHCPO.f b/Dragon/src/SPHCPO.f new file mode 100644 index 0000000..fa474a3 --- /dev/null +++ b/Dragon/src/SPHCPO.f @@ -0,0 +1,431 @@ +*DECK SPHCPO + SUBROUTINE SPHCPO(MAXISO,IPLIB,IPCPO,NMIL,NGRP,IMPX,ICAL,ILUPS,B2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Extract a Microlib corresponding to an elementary calculation in a +* Multicompo. +* +*Copyright: +* Copyright (C) 2012 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXISO maximum allocated space for output microlib TOC information. +* IPLIB address of the output microlib LCM object. +* IPCPO address of the multicompo object. +* NMIL number of mixtures in the elementary calculation. +* NGRP number of energy groups. +* IMPX print parameter (equal to zero for no print). +* ICAL index of the elementary calculation being considered. +* ILUPS up-scattering removing flag (=1 to remove up-scattering from +* output cross-sections). +* +*Parameters: output +* B2 buckling recovered from the Multicompo. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB,IPCPO + INTEGER MAXISO,NMIL,NGRP,IMPX,ICAL,ILUPS + REAL B2 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40,MAXED=50,IOUT=6) + CHARACTER TEXT12*12,HSMG*131,HVECT1(MAXED)*8,HVECT2(MAXED)*8 + INTEGER ISTATE(NSTATE) + TYPE(C_PTR) JPLIB,KPLIB,JPCPO,KPCPO,LPCPO,MPCPO,NPCPO,OPCPO + INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYP1,ITOD1,IMIX2,ITYP2, + 1 ITOD2,MILVO,MUP + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: HUSE1,HNAM1,HUSE2,HNAM2 + REAL, ALLOCATABLE, DIMENSION(:) :: DENS1,TEMP1,VOL1,DENS2,TEMP2, + 1 VOL2,ENER,DELT,VOLMI2,GAR4 + REAL, ALLOCATABLE, DIMENSION(:,:) :: GAR6 + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: ADF2 + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HADF,HADF2 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(HUSE1(3,MAXISO),HNAM1(3,MAXISO),ITYP1(MAXISO), + 1 ITOD1(MAXISO),IMIX2(MAXISO),ITYP2(MAXISO),ITOD2(MAXISO), + 2 HUSE2(3,MAXISO),HNAM2(3,MAXISO),MILVO(NMIL)) + ALLOCATE(DENS1(MAXISO),TEMP1(MAXISO),VOL1(MAXISO),DENS2(MAXISO), + 1 TEMP2(MAXISO),VOL2(MAXISO),ENER(NGRP+1),DELT(NGRP),VOLMI2(NMIL)) +*---- +* MICROLIB INITIALIZATION +*---- + IF(ILUPS.EQ.1) CALL XABORT('SPHCPO: UPS OPTION NOT IMPLEMENTED.') + NBISO2=0 + NCOMB2=0 + NED2=0 + TEXT12='L_LIBRARY' + CALL LCMPTC(IPLIB,'SIGNATURE',12,TEXT12) + DENS2(:MAXISO)=0.0 + TEMP2(:MAXISO)=0.0 + VOL2(:MAXISO)=0.0 + VOLMI2(:NMIL)=0.0 + IMIX2(:MAXISO)=0 + ITYP2(:MAXISO)=0 + ITOD2(:MAXISO)=0 +*---- +* RECOVER NDEPL +*---- + NDEPL=0 + CALL LCMLEN(IPCPO,'DEPL-CHAIN',ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + CALL LCMSIX(IPCPO,'DEPL-CHAIN',1) + CALL LCMGET(IPCPO,'STATE-VECTOR',ISTATE) + NDEPL=ISTATE(1) + CALL LCMSIX(IPCPO,' ',2) + ENDIF +*---- +* DETECT DISCONTINUITY FACTORS +*---- + JPCPO=LCMGID(IPCPO,'MIXTURES') + KPCPO=LCMGIL(JPCPO,1) + LPCPO=LCMGID(KPCPO,'CALCULATIONS') + MPCPO=LCMGIL(LPCPO,1) + CALL LCMGET(MPCPO,'STATE-VECTOR',ISTATE) + IDF=ISTATE(24) + NTYPE=0 + IF(IDF.GT.0) THEN + IF(IDF.EQ.1) THEN + NTYPE=2 + ELSE IF(IDF.EQ.2) THEN + CALL LCMSIX(MPCPO,'MACROLIB',1) + CALL LCMLEN(MPCPO,'ADF',ILONG,ITYLCM) + IF(ILONG.EQ.0) CALL XABORT('SPHCPO: MISSING ADF DIRECTORY ' + 1 //'IN MULTICOMPO OBJECT.') + CALL LCMSIX(MPCPO,'ADF',1) + CALL LCMGET(MPCPO,'NTYPE',NTYPE) + CALL LCMSIX(MPCPO,' ',2) + CALL LCMSIX(MPCPO,' ',2) + ELSE + CALL XABORT('SPHCPO: MATRIX ADF IS NOT IMPLEMENTED.') + ENDIF + ENDIF + ALLOCATE(HADF(NTYPE),ADF2(NMIL,NGRP,NTYPE),GAR4(NGRP), + 1 GAR6(NGRP,2)) + IF((IDF.GE.2).AND.(NTYPE.GT.0)) THEN + CALL LCMSIX(MPCPO,'MACROLIB',1) + CALL LCMSIX(MPCPO,'ADF',1) + CALL LCMGTC(MPCPO,'HADF',8,NTYPE,HADF) + CALL LCMSIX(MPCPO,' ',2) + CALL LCMSIX(MPCPO,' ',2) + ENDIF +*---- +* LOOP OVER MICROLIB MIXTURES +*---- + MILVO(:NMIL)=0 + NCOMB=0 + JPCPO=LCMGID(IPCPO,'MIXTURES') + ITRANC=0 + NDEL=0 + NDFI=0 + NL=0 + NW=0 + DO 190 IBM=1,NMIL + KPCPO=LCMGIL(JPCPO,IBM) + LPCPO=LCMGID(KPCPO,'CALCULATIONS') +*---- +* SELECT ICAL-TH ELEMENTARY CALCULATION +*---- + IF(IMPX.GT.0) THEN + WRITE(IOUT,'(33H SPHCPO: COMPO ACCESS FOR MIXTURE,I6,6H AND C, + 1 10HALCULATION,I5)') IBM,ICAL + ENDIF + MPCPO=LCMGIL(LPCPO,ICAL) + IF(IMPX.GT.50) CALL LCMLIB(MPCPO) + CALL LCMGET(MPCPO,'STATE-VECTOR',ISTATE) + NL=ISTATE(4) + ITRANC=ISTATE(5) + NDEPL=MAX(ISTATE(11),NDEPL) + NDEL=ISTATE(19) + NDFI=ISTATE(20) + NW=MAX(NW,ISTATE(25)) + IF(ISTATE(1).NE.1) CALL XABORT('SPHCPO: INVALID NUMBER OF MATERI' + 1 //'AL MIXTURES IN THE COMPO.') + IF(ISTATE(3).NE.NGRP) CALL XABORT('SPHCPO: INVALID NUMBER OF ENE' + 1 //'RGY GROUPS IN THE COMPO.') + IF(ISTATE(24).NE.IDF) CALL XABORT('SPHCPO: INVALID NUMBER OF DIS' + 1 //'CONTINUITY FACTORS IN THE COMPO.') + NBISO1=ISTATE(2) + IF(NBISO1.GT.MAXISO) CALL XABORT('SPHCPO: MAXISO OVERFLOW(1).') + NED1=ISTATE(13) + IF(NED1.GT.MAXED) CALL XABORT('SPHCPO: MAXED OVERFLOW(1).') + CALL LCMLEN(MPCPO,'MIXTURESVOL',ILONG,ITYLCM) + IF(ILONG.GT.0) CALL LCMGET(MPCPO,'MIXTURESVOL',VOLMI2(IBM)) + CALL LCMGET(MPCPO,'ISOTOPESUSED',HUSE1) + CALL LCMGET(MPCPO,'ISOTOPERNAME',HNAM1) + CALL LCMGET(MPCPO,'ISOTOPESDENS',DENS1) + CALL LCMGET(MPCPO,'ISOTOPESTYPE',ITYP1) + CALL LCMGET(MPCPO,'ISOTOPESTODO',ITOD1) + CALL LCMGET(MPCPO,'ISOTOPESVOL',VOL1) + CALL LCMGET(MPCPO,'ISOTOPESTEMP',TEMP1) + B2=0.0 + CALL LCMLEN(MPCPO,'B2 B1HOM',ILONG,ITYLCM) + IF(ILONG.GT.0) CALL LCMGET(MPCPO,'B2 B1HOM',B2) + IF(NED1.GT.0) CALL LCMGTC(MPCPO,'ADDXSNAME-P0',8,NED1,HVECT1) + CALL LCMGET(MPCPO,'ENERGY',ENER) + CALL LCMGET(MPCPO,'DELTAU',DELT) + DO 30 IED1=1,NED1 + DO 20 IED2=1,NED2 + IF(HVECT1(IED1).EQ.HVECT2(IED2)) GO TO 30 + 20 CONTINUE + NED2=NED2+1 + IF(NED2.GT.MAXED) CALL XABORT('SPHCPO: MAXED OVERFLOW(2).') + HVECT2(NED2)=HVECT1(IED1) + 30 CONTINUE + IF(IBM.GT.9999) CALL XABORT('SPHCPO: IBM OVERFLOW.') + DO 100 ISO=1,NBISO1 ! compo isotope + WRITE(TEXT12,'(2A4,I4.4)') (HUSE1(I,ISO),I=1,2),IBM + DO 60 JSO=1,NBISO2 ! microlib isotope + IF((HUSE1(1,ISO).EQ.HUSE2(1,JSO)).AND.(HUSE1(2,ISO).EQ. + 1 HUSE2(2,JSO)).AND.(IMIX2(JSO).EQ.IBM)) THEN + IF(ITYP1(ISO).NE.ITYP2(JSO)) THEN + WRITE(HSMG,500) 'ITYP',ISO,ITYP1(ISO),ITYP2(JSO) + CALL XABORT(HSMG) + ENDIF + JSO1=JSO + GO TO 90 + ENDIF + 60 CONTINUE + NBISO2=NBISO2+1 + IF(NBISO2.GT.MAXISO) THEN + WRITE(IOUT,'(/16H SPHCPO: NBISO2=,I6,8H MAXISO=,I6)') NBISO2, + 1 MAXISO + CALL XABORT('SPHCPO: MAXISO OVERFLOW(2).') + ENDIF + READ(TEXT12,'(3A4)') (HUSE2(I0,NBISO2),I0=1,3) + DO 70 I0=1,3 + HNAM2(I0,NBISO2)=HNAM1(I0,ISO) + 70 CONTINUE + IMIX2(NBISO2)=IBM + ITYP2(NBISO2)=ITYP1(ISO) + ITOD2(NBISO2)=ITOD1(ISO) + IF(ITYP2(NBISO2).EQ.1) ITOD2(NBISO2)=1 + DENS2(NBISO2)=0.0 + JSO1=NBISO2 + IF(ITOD2(NBISO2).NE.1) THEN + DO 80 J=1,NCOMB + IF(IBM.EQ.MILVO(J)) GO TO 90 + 80 CONTINUE + NCOMB=NCOMB+1 + IF(NCOMB.GT.NMIL) CALL XABORT('SPHCPO: MILVO OVERFLOW.') + MILVO(NCOMB)=IBM + ENDIF + 90 DENS2(JSO1)=DENS1(ISO) + VOL2(JSO1)=VOL1(ISO) + TEMP2(JSO1)=TEMP1(ISO) + 100 CONTINUE +*---- +* PROCESS ISOTOPE DIRECTORIES FOR MICROLIB MIXTURE IBM +*---- + JPLIB=LCMLID(IPLIB,'ISOTOPESLIST',NBISO2) + DO 180 ISO=1,NBISO2 ! microlib isotope + IF(IMIX2(ISO).NE.IBM) GO TO 180 + DO 120 JSO=1,NBISO1 ! compo isotope + IF((HUSE1(1,JSO).EQ.HUSE2(1,ISO)).AND.(HUSE1(2,JSO).EQ. + 1 HUSE2(2,ISO))) THEN + JSO1=JSO + GO TO 130 + ENDIF + 120 CONTINUE + WRITE(TEXT12,'(3A4)') (HUSE2(I0,ISO),I0=1,3) + CALL XABORT('SPHCPO: UNABLE TO FIND '//TEXT12//'.') + 130 KPLIB=LCMDIL(JPLIB,ISO) ! set ISO-th isotope + MPCPO=LCMGIL(LPCPO,ICAL) + NPCPO=LCMGID(MPCPO,'ISOTOPESLIST') + CALL LCMLEL(NPCPO,JSO1,ILENG,ITYLCM) + IF(ILENG.NE.0) THEN + OPCPO=LCMGIL(NPCPO,JSO1) ! set JSO1-th isotope + CALL LCMEQU(OPCPO,KPLIB) + ENDIF + 180 CONTINUE +*---- +* PROCESS ADF INFORMATION +*---- + IF(IDF.GT.0) THEN + CALL LCMSIX(MPCPO,'MACROLIB',1) + CALL LCMLEN(MPCPO,'ADF',ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + CALL LCMSIX(MPCPO,'ADF',1) + IF(IDF.EQ.1) THEN + GAR6(:NGRP,:2)=0.0 + CALL LCMGET(MPCPO,'ALBS00',GAR6) + DO IGR=1,NGRP + ADF2(IBM,IGR,:2)=GAR6(IGR,:2) + ENDDO + ELSE IF((IDF.EQ.2).OR.(IDF.EQ.3)) THEN + CALL LCMGET(MPCPO,'NTYPE',NTYPE2) + ALLOCATE(HADF2(NTYPE2)) + CALL LCMGTC(MPCPO,'HADF',8,NTYPE2,HADF2) + IF(NTYPE2.EQ.1) THEN +* assign the same ADF to all sides. + CALL LCMLEN(MPCPO,HADF2(1),ILONG,ITYLCM) + IF(ILONG.NE.NGRP) CALL XABORT('SPHCPO: INVALID ADF LENGT' + 1 //'H(1).') + CALL LCMGET(MPCPO,HADF2(1),GAR4) + DO ITY=1,NTYPE + DO IGR=1,NGRP + ADF2(IBM,IGR,ITY)=GAR4(IGR) + ENDDO + ENDDO + ELSE + IF(NTYPE2.GT.NTYPE) CALL XABORT('SPHCPO: NTYPE OVERFLOW.') + DO ITY2=1,NTYPE2 + ITY=0 + DO JTY=1,NTYPE + IF(HADF2(ITY2).EQ.HADF(JTY)) THEN + ITY=JTY + GO TO 185 + ENDIF + ENDDO + WRITE(HSMG,'(18HSPHCPO: ADF NAMED ,A,11H NOT FOUND.)') + 1 TRIM(HADF2(ITY2)) + CALL XABORT(HSMG) + 185 CALL LCMLEN(MPCPO,HADF2(ITY2),ILONG,ITYLCM) + IF(ILONG.NE.NGRP) CALL XABORT('SPHCPO: INVALID ADF LEN' + 1 //'GTH(2).') + CALL LCMGET(MPCPO,HADF2(ITY2),GAR4) + DO IGR=1,NGRP + ADF2(IBM,IGR,ITY)=GAR4(IGR) + ENDDO + ENDDO + ENDIF + DEALLOCATE(HADF2) + ENDIF + CALL LCMSIX(MPCPO,' ',2) + ENDIF + CALL LCMSIX(MPCPO,' ',2) + ENDIF + 190 CONTINUE +*---- +* MICROLIB FINALIZATION +*---- + ISTATE(:NSTATE)=0 + ISTATE(1)=NMIL + ISTATE(2)=NBISO2 + ISTATE(3)=NGRP + ISTATE(4)=NL + ISTATE(5)=ITRANC + ISTATE(7)=1 + ISTATE(11)=NDEPL + ISTATE(12)=NCOMB+NCOMB2 + ISTATE(13)=NED2 + ISTATE(14)=NMIL + ISTATE(18)=1 + ISTATE(19)=NDEL + ISTATE(20)=NDFI + ISTATE(22)=MAXISO/NMIL + ISTATE(25)=NW + IF(NBISO2.EQ.0) CALL XABORT('SPHCPO: NBISO2=0.') + CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMPUT(IPLIB,'MIXTURESVOL',NMIL,2,VOLMI2) + CALL LCMPUT(IPLIB,'ISOTOPESUSED',3*NBISO2,3,HUSE2) + CALL LCMPUT(IPLIB,'ISOTOPERNAME',3*NBISO2,3,HNAM2) + CALL LCMPUT(IPLIB,'ISOTOPESDENS',NBISO2,2,DENS2) + CALL LCMPUT(IPLIB,'ISOTOPESMIX',NBISO2,1,IMIX2) + CALL LCMPUT(IPLIB,'ISOTOPESTYPE',NBISO2,1,ITYP2) + CALL LCMPUT(IPLIB,'ISOTOPESTODO',NBISO2,1,ITOD2) + CALL LCMPUT(IPLIB,'ISOTOPESVOL',NBISO2,2,VOL2) + CALL LCMPUT(IPLIB,'ISOTOPESTEMP',NBISO2,2,TEMP2) + IF(NED2.GT.0) CALL LCMPTC(IPLIB,'ADDXSNAME-P0',8,NED2,HVECT2) + CALL LCMPUT(IPLIB,'ENERGY',NGRP+1,2,ENER) + CALL LCMPUT(IPLIB,'DELTAU',NGRP,2,DELT) + IF(IMPX.GT.5) CALL LCMLIB(IPLIB) +*---- +* RECOVER GENERAL INFORMATION FROM MIXTURE 1 +*---- + B2=0.0 + KPCPO=LCMGIL(JPCPO,1) + LPCPO=LCMGID(KPCPO,'CALCULATIONS') + MPCPO=LCMGIL(LPCPO,ICAL) + CALL LCMLEN(MPCPO,'K-EFFECTIVE',ILENG,ITYLCM) + IF(ILENG.EQ.1) THEN + CALL LCMGET(MPCPO,'K-EFFECTIVE',FLOTT) + CALL LCMPUT(IPLIB,'K-EFFECTIVE',1,2,FLOTT) + IF(IMPX.GT.1) THEN + WRITE(6,'(22H SPHCPO: K-EFFECTIVE =,1P,E13.6)') FLOTT + ENDIF + ENDIF + CALL LCMLEN(MPCPO,'K-INFINITY',ILENG,ITYLCM) + IF(ILENG.EQ.1) THEN + CALL LCMGET(MPCPO,'K-INFINITY',FLOTT) + CALL LCMPUT(IPLIB,'K-INFINITY',1,2,FLOTT) + IF(IMPX.GT.1) THEN + WRITE(6,'(21H SPHCPO: K-INFINITY =,1P,E13.6)') FLOTT + ENDIF + ENDIF + CALL LCMLEN(MPCPO,'B2 B1HOM',ILENG,ITYLCM) + IF(ILENG.EQ.1) THEN + CALL LCMGET(MPCPO,'B2 B1HOM',B2) + CALL LCMPUT(IPLIB,'B2 B1HOM',1,2,B2) + IF(IMPX.GT.1) THEN + WRITE(6,'(13H SPHCPO: B2 =,1P,E14.6)') B2 + ENDIF + ENDIF +*---- +* BUILD EMBEDDED MACROLIB +*---- + ALLOCATE(MUP(NMIL)) + MUP(:NMIL)=1 + CALL SPHEMB(IPLIB,IPCPO,NGRP,NMIL,MUP,IMPX) + DEALLOCATE(MUP) +*---- +* WRITE ADF INFORMATION +*---- + IF(IDF.EQ.1) THEN + CALL LCMSIX(IPLIB,'MACROLIB',1) + CALL LCMSIX(IPLIB,'ADF',1) + CALL LCMPUT(IPLIB,'ALBS00',NMIL*NGRP*2,2,ADF2(1,1,1)) + CALL LCMSIX(IPLIB,' ',2) + CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) + ISTATE(12)=IDF + CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMSIX(IPLIB,' ',2) + ELSE IF((IDF.EQ.2).OR.(IDF.EQ.3)) THEN + CALL LCMSIX(IPLIB,'MACROLIB',1) + CALL LCMSIX(IPLIB,'ADF',1) + DO ITYPE=1,NTYPE + CALL LCMPUT(IPLIB,HADF(ITYPE),NMIL*NGRP,2, + 1 ADF2(1,1,ITYPE)) + ENDDO + CALL LCMSIX(IPLIB,' ',2) + CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) + ISTATE(12)=IDF + CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMSIX(IPLIB,' ',2) + IF(IMPX.GT.1) THEN + DO IBM=1,NMIL + WRITE(6,'(/40H SPHCPO: DISCONTINUITY FACTORS - MIXTURE,I5)') + 1 IBM + DO ITYPE=1,NTYPE + WRITE(6,'(1X,A,1H:,1P,(5X,10E12.4))') TRIM(HADF(ITYPE)), + 1 (ADF2(IBM,IGR,ITYPE),IGR=1,NGRP) + ENDDO + ENDDO + ENDIF + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GAR6,GAR4,ADF2,HADF) + DEALLOCATE(VOLMI2,DELT,ENER,VOL2,TEMP2,DENS2,VOL1,TEMP1,DENS1) + DEALLOCATE(MILVO,HNAM2,HUSE2,ITOD2,ITYP2,IMIX2,ITOD1,ITYP1,HNAM1, + 1 HUSE1) + RETURN +* + 500 FORMAT(8HSPHCPO: ,A,1H(,I4,2H)=,2I5) + END diff --git a/Dragon/src/SPHDRV.f b/Dragon/src/SPHDRV.f new file mode 100644 index 0000000..d6fee88 --- /dev/null +++ b/Dragon/src/SPHDRV.f @@ -0,0 +1,215 @@ +*DECK SPHDRV + SUBROUTINE SPHDRV(IPTRK,IFTRK,IPMACR,IPFLX,IPRINT,IMC,NGCOND, + 1 NMERGE,NALBP,IGRMIN,IGRMAX,SPH) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the SPH factors. These factors are used to multiply the +* cross sections and to divide the fluxes. The SPH factors calculation +* is generally application dependent. New SPH algorithms should be +* implemented in this driver. +* +*Copyright: +* Copyright (C) 2011 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK pointer to the macro-tracking LCM object. +* IFTRK unit of the macro-tracking binary sequential file. +* IPMACR pointer to the Macrolib (L_MACROLIB signature). +* IPFLX pointer towards an initialization flux (L_FLUX signature). +* IPRINT print flag (equal to 0 for no print). +* IMC type of macro-calculation (=1 diffusion or SPN; +* =2 other options; +* =3 type PIJ with Bell acceleration). +* NGCOND number of condensed groups. +* NMERGE number of merged regions. +* NALBP number of physical albedos. +* IGRMIN first group to process. +* IGRMAX last group to process. +* +*Parameters: output +* SPH SPH homogenization factors. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPMACR,IPFLX + INTEGER IFTRK,IPRINT,IMC,NGCOND,NMERGE,NALBP,IGRMIN,IGRMAX + REAL SPH(NMERGE+NALBP,NGCOND) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER TEXT12*12,CNDOOR*12,CTITRE*72,SUFF(2)*2,HSMG*131 + INTEGER ISTATE(NSTATE) + LOGICAL ILK + TYPE(C_PTR) IPSPH +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MAT2,KEY2,MERG2 + REAL, ALLOCATABLE, DIMENSION(:) :: VOL2,VREF,VMAC + DATA SUFF/'00','01'/ +*---- +* RECOVER SPH-RELATED INFORMATION +*---- + CALL LCMLEN(IPMACR,'SPH',ILONG,ITYLCM) + IF(ILONG.EQ.0) CALL XABORT('SPHDRV: MISSING SPH DIRECTORY.') + IPSPH=LCMDID(IPMACR,'SPH') + CALL LCMGET(IPSPH,'STATE-VECTOR',ISTATE) + NSPH=ISTATE(1) + KSPH=ISTATE(2) + MAXIT=ISTATE(3) + MAXNBI=ISTATE(4) + IF((NSPH.EQ.0).OR.(NSPH.EQ.1)) CALL XABORT('SPHDRV: INVALID VALU' + > //'E OF NSPH.') +*---- +* RECOVER AND USE AN EXISTING MACRO-TRACKING. +*---- + IF(C_ASSOCIATED(IPTRK)) THEN + IF(NSPH.GE.2) THEN + CALL LCMGTC(IPSPH,'SPH$TRK',12,CNDOOR) + CALL LCMGET(IPSPH,'SPH-EPSILON',EPSPH) + ENDIF + CALL LCMGTC(IPTRK,'SIGNATURE',12,TEXT12) + IF(TEXT12.NE.'L_TRACK') THEN + CALL XABORT('SPHDRV: TRACKING DATA STRUCTURE EXPECTED.') + ENDIF + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + NREG2=ISTATE(1) + NUN2=ISTATE(2) + ILK=ISTATE(3).EQ.0 + CALL LCMGTC(IPTRK,'TRACK-TYPE',12,CNDOOR) + IF(CNDOOR.EQ.'MCCG') THEN + CALL LCMLEN(IPTRK,'KEYFLX',LKFL,ITYLCM) + NFUNL=LKFL/NREG2 + ELSE + NFUNL=1 + ENDIF +*---- +* THE NUMBER OF UNKNOWNS OF A CURRENT-BASED MULTICELL ITERATION IS +* INCREASED TO HOLD INTERFACE CURRENT COMPONENTS. +*---- + IF(NSPH.EQ.4) THEN + IF(CNDOOR.EQ.'SYBIL') NUN2=NUN2+ISTATE(9) + IF((CNDOOR.EQ.'EXCELL').AND.(ISTATE(7).EQ.5)) + > NUN2=NUN2+ISTATE(28) + ENDIF +* + IF((CNDOOR.EQ.'EXCELL').OR.(CNDOOR.EQ.'MCCG')) THEN + ISCAT=ISTATE(6) + ELSE IF(CNDOOR.EQ.'SN') THEN + ISCAT=ISTATE(16) + ELSE IF(CNDOOR.EQ.'BIVAC') THEN + IF(ISTATE(14).EQ.0) THEN + ISCAT=1 + ELSE + ISCAT=ISTATE(16) + ENDIF + ELSE IF(CNDOOR.EQ.'TRIVAC') THEN + IF(ISTATE(30).EQ.0) THEN + ISCAT=1 + ELSE + ISCAT=ISTATE(32) + ENDIF + ELSE + ISCAT=1 + ENDIF + ISCAT=ABS(ISCAT) + ALLOCATE(VOL2(NREG2),MAT2(NREG2),KEY2(NREG2*NFUNL)) + CALL LCMGET(IPTRK,'VOLUME',VOL2) + CALL LCMGET(IPTRK,'MATCOD',MAT2) + CALL LCMGET(IPTRK,'KEYFLX',KEY2) + CALL LCMLEN(IPTRK,'TITLE',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGTC(IPTRK,'TITLE',72,CTITRE) + ELSE + CTITRE='*** NO TITLE PROVIDED ***' + ENDIF + NBMIX2=0 + IF(KSPH.EQ.5) THEN +* HEBERT-BENOIST ALBS TECHNIQUE. + DO 20 IREG=1,NREG2 + NBMIX2=MAX(NBMIX2,MAT2(IREG)) + 20 CONTINUE + ALLOCATE(MERG2(NBMIX2)) + DO 25 IBM=1,NBMIX2 + MERG2(IBM)=1 + 25 CONTINUE + ILK=.FALSE. + ELSE + DO 30 IREG=1,NREG2 + NBMIX2=MAX(NBMIX2,MAT2(IREG)) + 30 CONTINUE + IF(NBMIX2.NE.NMERGE) THEN + WRITE(HSMG,'(41HSPHDRV: INVALID NUMBER OF MACRO-REGIONS (, + > 2I6,2H).)') NBMIX2,NMERGE + CALL XABORT(HSMG) + ENDIF + ALLOCATE(MERG2(NBMIX2)) + DO 35 IBM=1,NBMIX2 + MERG2(IBM)=IBM + 35 CONTINUE + ENDIF +* +* RECOVER TABULATED FUNCTIONS. + CALL XDRTA2 + ELSE + ISCAT=1 + ILK=.FALSE. + NBMIX2=0 + NREG2=0 + NUN2=0 + ENDIF +*---- +* CHECK VOLUME CONSISTENCY +*---- + ALLOCATE(VREF(NMERGE),VMAC(NMERGE)) + VMAC(:)=0.0 + CALL LCMGET(IPMACR,'VOLUME',VREF) + DO IREG=1,NREG2 + IBM=MAT2(IREG) + IF(IBM.GT.0) VMAC(IBM)=VMAC(IBM)+VOL2(IREG) + ENDDO + VREFT=SUM(VREF(:NMERGE)) + VMACT=SUM(VMAC(:NMERGE)) + DO IBM=1,NMERGE + ERR=ABS(VREF(IBM)/VREFT-VMAC(IBM)/VMACT) + IF(ERR.GT.1.0E-4*ABS(VREF(IBM)/VREFT)) THEN + WRITE(HSMG,'(38HSPHDRV: INCONSISTENT VOLUME IN MIXTURE,I5, + > 3H BY,F7.2,2H %)') IBM,ERR*100.0 + CALL XABORT(HSMG) + ENDIF + ENDDO + DEALLOCATE(VMAC,VREF) +*---- +* GENERAL PROCEDURE FOR COMPUTING THE SPH FACTORS +*---- + CALL SPHEQU(NBMIX2,IPTRK,IFTRK,IPMACR,IPFLX,CNDOOR,NSPH,KSPH, + 1 MAXIT,MAXNBI,EPSPH,IPRINT,IMC,NGCOND,NMERGE,NALBP,ISCAT,NREG2, + 2 NUN2,MAT2,VOL2,KEY2,MERG2,ILK,CTITRE,IGRMIN,IGRMAX,SPH) + IF(C_ASSOCIATED(IPTRK)) DEALLOCATE(MERG2,KEY2,MAT2,VOL2) +*---- +* PRINT SPH FACTORS +*---- + IF(IPRINT.GT.1) THEN + WRITE(6,'(/21H SPHDRV: SPH FACTORS:)') + WRITE(6,200) ((IKK,IGR,SPH(IKK,IGR),IKK=1,NMERGE+NALBP),IGR=1, + > NGCOND) + ENDIF + RETURN +* + 200 FORMAT(4X,4HSPH(,I5,1H,,I3,2H)=,F9.5,:,4X,4HSPH(,I5,1H,,I3,2H)=, + > F9.5,:,4X,4HSPH(,I5,1H,,I3,2H)=,F9.5,:,4X,4HSPH(,I5,1H,,I3,2H)=, + > F9.5,:,4X,4HSPH(,I5,1H,,I3,2H)=,F9.5) + END diff --git a/Dragon/src/SPHEMB.f b/Dragon/src/SPHEMB.f new file mode 100644 index 0000000..a635a7a --- /dev/null +++ b/Dragon/src/SPHEMB.f @@ -0,0 +1,137 @@ +*DECK SPHEMB + SUBROUTINE SPHEMB(IPLIB,IPCPO,NGRP,NMIX,MIXUPD,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Build embedded macrolib and recover depletion data from the +* multicompo. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert, R. Chambon +* +*Parameters: input/output +* IPLIB address of the microlib LCM object. +* IPCPO address of the multicompo object. +* NGRP number of energy groups. +* NMIX maximum number of material mixtures in the microlib. +* MIXUPD tag for mixture which will be updated. +* IMPX print parameter (equal to zero for no print). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB,IPCPO + INTEGER NGRP,NMIX + INTEGER MIXUPD(NMIX) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40,IOUT=6) + CHARACTER HSMG*131 + INTEGER ISTATE(NSTATE),IST1(NSTATE),IST2(NSTATE) + REAL TMPDAY(3) + LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASK,MASKL + INTEGER, POINTER, DIMENSION(:) :: ISONA,ISOMI + REAL, POINTER, DIMENSION(:) :: DENIS + TYPE(C_PTR) ISONA_PTR,ISOMI_PTR,DENIS_PTR +*---- +* RECOVER THE DEPLETION CHAIN +*---- + CALL LCMLEN(IPLIB,'DEPL-CHAIN',ILENG1,ITYLCM) + CALL LCMLEN(IPCPO,'DEPL-CHAIN',ILENG2,ITYLCM) + IF((ILENG1.NE.0).AND.(ILENG2.NE.0)) THEN + CALL LCMSIX(IPCPO,'DEPL-CHAIN',1) + CALL LCMGET(IPCPO,'STATE-VECTOR',IST1) + CALL LCMSIX(IPCPO,' ',2) + CALL LCMSIX(IPLIB,'DEPL-CHAIN',1) + CALL LCMGET(IPLIB,'STATE-VECTOR',IST2) + CALL LCMSIX(IPLIB,' ',2) + DO 100 I=1,NSTATE + IF(IST1(I).NE.IST2(I)) THEN + WRITE(HSMG,'(40HSPHEMB: INVALID STATE-VECTOR COMPONENT (,I2, + 1 36H) FOR DEPL-CHAIN DATA IN MULTICOMPO ,1H.)') I + CALL XABORT(HSMG) + ENDIF + 100 CONTINUE + ELSE IF((ILENG1.EQ.0).AND.(ILENG2.NE.0)) THEN + CALL LCMSIX(IPCPO,'DEPL-CHAIN',1) + CALL LCMSIX(IPLIB,'DEPL-CHAIN',1) + CALL LCMEQU(IPCPO,IPLIB) + CALL LCMSIX(IPLIB,' ',2) + CALL LCMSIX(IPCPO,' ',2) + ENDIF +*---- +* COMPUTE THE MACROSCOPIC X-SECTIONS +*---- + CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) + MAXMIX=ISTATE(1) + IF(MAXMIX.NE.NMIX) CALL XABORT('SPHEMB: INVALID NMIX.') + NBISO=ISTATE(2) + ALLOCATE(MASK(MAXMIX),MASKL(NGRP)) + CALL LCMGPD(IPLIB,'ISOTOPESUSED',ISONA_PTR) + CALL LCMGPD(IPLIB,'ISOTOPESMIX',ISOMI_PTR) + CALL LCMGPD(IPLIB,'ISOTOPESDENS',DENIS_PTR) + CALL C_F_POINTER(ISONA_PTR,ISONA,(/ NBISO /)) + CALL C_F_POINTER(ISOMI_PTR,ISOMI,(/ NBISO /)) + CALL C_F_POINTER(DENIS_PTR,DENIS,(/ NBISO /)) + MASK(:MAXMIX)=.FALSE. + MASKL(:NGRP)=.TRUE. + DO 110 ISOT=1,NBISO + IBM=ISOMI(ISOT) + IF(IBM.GT.0) THEN + IF(MIXUPD(IBM).NE.0) MASK(IBM)=.TRUE. + ENDIF + 110 CONTINUE + ITSTMP=0 + TMPDAY(1)=0.0 + TMPDAY(2)=0.0 + TMPDAY(3)=0.0 + CALL LIBMIX(IPLIB,MAXMIX,NGRP,NBISO,ISONA,ISOMI,DENIS,MASK,MASKL, + 1 ITSTMP,TMPDAY) + DEALLOCATE(MASKL,MASK) +*---- +* RECOVER GENERAL INFORMATION FROM MICROLIB +*---- + B2=0.0 + CALL LCMLEN(IPLIB,'K-EFFECTIVE',ILENG,ITYLCM) + IF(ILENG.EQ.1) THEN + CALL LCMGET(IPLIB,'K-EFFECTIVE',FLOTT) + CALL LCMSIX(IPLIB,'MACROLIB',1) + CALL LCMPUT(IPLIB,'K-EFFECTIVE',1,2,FLOTT) + CALL LCMSIX(IPLIB,' ',2) + IF(IMPX.GT.1) THEN + WRITE(6,'(22H SPHCPO: K-EFFECTIVE =,1P,E13.6)') FLOTT + ENDIF + ENDIF + CALL LCMLEN(IPLIB,'K-INFINITY',ILENG,ITYLCM) + IF(ILENG.EQ.1) THEN + CALL LCMGET(IPLIB,'K-INFINITY',FLOTT) + CALL LCMSIX(IPLIB,'MACROLIB',1) + CALL LCMPUT(IPLIB,'K-INFINITY',1,2,FLOTT) + CALL LCMSIX(IPLIB,' ',2) + IF(IMPX.GT.1) THEN + WRITE(6,'(21H SPHCPO: K-INFINITY =,1P,E13.6)') FLOTT + ENDIF + ENDIF + CALL LCMLEN(IPLIB,'B2 B1HOM',ILENG,ITYLCM) + IF(ILENG.EQ.1) THEN + CALL LCMGET(IPLIB,'B2 B1HOM',B2) + CALL LCMSIX(IPLIB,'MACROLIB',1) + CALL LCMPUT(IPLIB,'B2 B1HOM',1,2,B2) + CALL LCMSIX(IPLIB,' ',2) + IF(IMPX.GT.1) THEN + WRITE(6,'(13H SPHCPO: B2 =,1P,E14.6)') B2 + ENDIF + ENDIF + RETURN + END diff --git a/Dragon/src/SPHEQU.f b/Dragon/src/SPHEQU.f new file mode 100644 index 0000000..b4b42dc --- /dev/null +++ b/Dragon/src/SPHEQU.f @@ -0,0 +1,757 @@ +*DECK SPHEQU + SUBROUTINE SPHEQU(NBMIX2,IPTRK2,IFTRAK,IPMACR,IPFLX,CDOOR,NSPH, + 1 KSPH,MAXIT,MAXNBI,EPSPH,IPRINT,IMC,NGCOND,NMERGE,NALBP,ISCAT, + 2 NREG2,NUN2,MAT2,VOL2,KEY2,MERG2,ILK,CTITRE,IGRMIN,IGRMAX,SPH) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the SPH factors for the homogenization of any geometry +* using a transport-transport or transport-diffusion equivalence +* technique. The macro-calculation can be performed using a standard +* solution door of Dragon. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NBMIX2 number of macro-mixtures. Equal to MAX(MAT2(IREG)) for +* (IREG .le. NREG2). +* IPTRK2 pointer to the tracking of the macro-geometry (L_TRACK +* signature). +* IFTRAK unit number of the sequential binary tracking file. +* IPMACR pointer to the reference macrolib (L_MACROLIB signature). +* IPFLX pointer towards an initialization flux (L_FLUX signature). +* CDOOR tracking operator used to track the macro-geometry. +* NSPH type of SPH algorithm: +* =2 homogeneous macro-calculation (non-iterative procedure +* or Hebert-Benoist SPH-5 procedure); +* =3 any type of pij macro-calculation; +* =4 any type of diffusion, SN, PN or SPN macro-calculation; +* KSPH type of SPH factor normalization: +* <0 asymptotic normatization with respect to mixture -KSPH; +* =1 average flux normalization; +* =2 Selengut normalization using ALBS information; +* =3 Selengut normalization using FD_B boundary fluxes; +* =4 generalized Selengut normalization (EDF type); +* =5 Selengut normalization with surface leakage; +* =6 Selengut with water gap normalization; +* =7 average flux normalization in fissile zones. +* The Hebert-Benoist procedure is used if NSPH=2 and KSPH=5. +* MAXIT maximum number of SPH iterations. +* MAXNBI acceptable number of SPH iterations with an increase in +* convergence error before aborting. +* EPSPH convergence criterion for stopping the SPH iterations. +* IPRINT print flag (equal to 0 for no print). +* IMC type of macro-calculation (=1 diffusion or SPN; +* =2 other options; +* =3 type PIJ with Bell acceleration). +* NGCOND number of condensed groups. +* NMERGE number of merged regions (equal to 1 or to the number of +* different flux components in the macro-calculation). +* NALBP number of physical albedos. +* ISCAT scattering anisotropy in the reference set of cross sections +* (=1 isotropic in LAB; =2 linearly-anisotropic in LAB). +* NREG2 number of macro-regions (in the macro-calculation). +* NUN2 number of unknowns in a one-group macro-calculation. +* MAT2 mixture index per macro-region. +* VOL2 volume of macro-regions. +* KEY2 pointer to flux values in unknown vector. +* MERG2 index of merged macro-regions per macro-mixture. +* ILK leakage switch. +* CTITRE title. +* IGRMIN first group to process. +* IGRMAX last group to process. +* +*Parameters: output +* SPH SPH homogenization factors. +* +*References(s): +* A. Hebert, 'A Consistent Technique for the Pin-by-Pin Homogenization +* of a Pressurized Water Reactor Assembly', Nucl. Sci. Eng., 113, 227 +* (1993). +* +* A. Hebert and P. Benoist, 'A Consistent Technique for the Global +* Homogenization of a Pressurized Water Reactor Assembly', Nucl. Sci. +* Eng., 109, 360 (1991). +* +* A. Hebert and G. Mathonniere, 'Development of a Third-Generation +* Superhomogeneisation Method for the Homogenization of a +* Pressurized Water Reactor Assembly', Nucl. Sci. Eng., 115, 129 +* (1993). +* +* T. Courau, M. Cometto, E. Girardi, D. Couyras and N. Schwartz, +* 'Elements of Validation of Pin-by-Pin Calculations with the Future +* EDF Calculation Scheme Based on APOLLO2 and COCAGNE Codes', +* Proceedings of ICAPP '08 Anaheim, CA USA, June 8-12, 2008. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE DOORS_MOD +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK2,IPMACR,IPFLX + INTEGER NBMIX2,IFTRAK,NSPH,KSPH,MAXIT,MAXNBI,IPRINT,IMC,NGCOND, + 1 NMERGE,NALBP,ISCAT,NREG2,NUN2,MAT2(NREG2),KEY2(NREG2), + 2 MERG2(NBMIX2),IGRMIN,IGRMAX + REAL VOL2(NREG2),SPH(NMERGE+NALBP,NGCOND) + LOGICAL ILK + CHARACTER CDOOR*12,CTITRE*72 +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + INTEGER IPAR(NSTATE) + LOGICAL LNORM,LEXAC,LDIFF,REBFLG + DOUBLE PRECISION FLXTOT,VOLTOT + CHARACTER TEXT12*12,HSMG*131 + TYPE(C_PTR) IPADF,IPSYS2,JPSYS2,JPFLX,KPSYS2,IPSOU +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NPSYS + REAL, ALLOCATABLE, DIMENSION(:) :: SIGMD,VOLMER,FACTOR,OUTG1, + 1 OUTG2,COURIN,COUROW,SNORM,SPHNEW,SIGG + REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGMA,SIGMS,DIFF,FUNKNO, + 1 SUNKNO,FLXMER,ZLEAK,ALB1,ALB2,WORK + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SIGT,SIGW + REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: SUNMER + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LFISS +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NPSYS(NGCOND)) + ALLOCATE(SIGMA(0:NBMIX2,ISCAT+1),SIGMD(0:NBMIX2),COURIN(NGCOND), + 1 COUROW(NGCOND),VOLMER(NMERGE),SIGW(NMERGE,NGCOND,ISCAT+1), + 2 FLXMER(NMERGE,NGCOND),DIFF(NMERGE,NGCOND),ZLEAK(NMERGE,NGCOND), + 3 SUNMER(NMERGE,NGCOND,NGCOND,ISCAT),FUNKNO(NUN2,NGCOND), + 4 SUNKNO(NUN2,NGCOND),FACTOR(NMERGE),OUTG1(NGCOND),OUTG2(NGCOND), + 5 SNORM(NGCOND),ALB1(NALBP,NGCOND),ALB2(NALBP,NGCOND), + 6 LFISS(NMERGE)) +*---- +* CALCULATION OF THE REFERENCE MERGED/CONDENSED SET OF CROSS SECTIONS +*---- + IF(NALBP.GT.1) CALL XABORT('SPHEQU: NALBP<=1 EXPECTED.') + CALL LCMGET(IPMACR,'STATE-VECTOR',IPAR) + NL=IPAR(3) + NIFISS=IPAR(4) + ILEAKS=IPAR(9) + NW=MAX(1,IPAR(10)) + IF(IPAR(2).NE.NMERGE) THEN + CALL XABORT('SPHEQU: INVALID VALUE OF NMERGE.') + ELSE IF(IPAR(8).NE.NALBP) THEN + CALL XABORT('SPHEQU: INVALID VALUE OF NALBP.') + ENDIF + ALLOCATE(SIGT(NMERGE,NGCOND,NW+1),SIGMS(0:NBMIX2,NW+1)) + CALL SPHMAC(IPMACR,IPRINT,NMERGE,NALBP,NGCOND,ISCAT,NW,NIFISS, + 1 ILEAKS,VOLMER,FLXMER,SUNMER,SIGT,SIGW,DIFF,ZLEAK,OUTG2,ALB2, + 2 LFISS) +* + DO 30 INL=1,ISCAT + DO 20 IGR=1,NGCOND + DO 10 IKK=1,NMERGE + SUNMER(IKK,IGR,IGR,INL)=SUNMER(IKK,IGR,IGR,INL)-SIGW(IKK,IGR,INL) + 10 CONTINUE + 20 CONTINUE + 30 CONTINUE + LDIFF=.FALSE. + NLF=0 + NANI=0 + IF((NSPH.EQ.4).AND.((CDOOR.EQ.'BIVAC').OR.(CDOOR.EQ.'TRIVAC'))) + > THEN +* TRANSPORT-DIFFUSION EQUIVALENCE. + IF(.NOT.C_ASSOCIATED(IPTRK2)) THEN + CALL XABORT('SPHEQU: MACRO-TRACKING NOT DEFINED(1).') + ENDIF + CALL LCMGET(IPTRK2,'STATE-VECTOR',IPAR) + IF(CDOOR.EQ.'BIVAC') THEN + NLF=IPAR(14) + NANI=IPAR(16) + ELSE IF(CDOOR.EQ.'TRIVAC') THEN + NLF=IPAR(30) + NANI=IPAR(32) + ENDIF + LDIFF=(NLF.EQ.0).OR.(NANI.LT.0) + NANI=ABS(NANI) + IF(NANI.GT.ISCAT) CALL XABORT('SPHEQU: ISCAT OVERFLOW.') + IF(LDIFF) THEN + IF(ILEAKS.EQ.0) CALL XABORT('SPHEQU: UNABLE TO COMPUTE DIFF' + > //'USION COEFFICIENTS.') + ENDIF + ENDIF + IF(NLF.EQ.0) NANI=1 +*---- +* RECOVER THE AVERAGED GAP AND ROW FLUXES FOR EDF-TYPE NORMALIZATION. +*---- + IF(KSPH.GE.2) THEN + CALL LCMLEN(IPMACR,'ADF',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + CALL LCMLIB(IPMACR) + CALL XABORT('SPHEQU: NO ADF DIRECTORY IN THE MACROLIB.') + ENDIF + IPADF=LCMDID(IPMACR,'ADF') + ENDIF + IF((KSPH.EQ.2).OR.(KSPH.EQ.5)) THEN + CALL LCMLEN(IPADF,'ALBS00',ILONG,ITYLCM) + IF(ILONG.NE.2*NGCOND) THEN + WRITE(HSMG,'(26HSPHEQU: BAD ALBS00 LENGTH=,I5,10H EXPECTED=, + > I5,1H.)') ILONG,2*NGCOND + CALL XABORT(HSMG) + ENDIF + ALLOCATE(WORK(NGCOND,2)) + CALL LCMGET(IPADF,'ALBS00',WORK) + COURIN(:NGCOND)=WORK(:NGCOND,1) + DEALLOCATE(WORK) + IF(IPRINT.GT.3) THEN + WRITE(6,'(/45H SPHEQU: THE VALUES OF ALBS PER MACRO-GROUPS , + > 3HARE)') + WRITE(6,'(1X,1P,10E13.5)') (COURIN(IGR),IGR=1,NGCOND) + ENDIF + ELSE IF((KSPH.EQ.3).OR.(KSPH.EQ.6)) THEN + CALL LCMLEN(IPADF,'FD_B',ILONG,ITYLCM) + IF(ILONG.NE.NMERGE*NGCOND) THEN + CALL LCMLIB(IPADF) + WRITE(HSMG,'(24HSPHEQU: BAD FD_B LENGTH=,I5,10H EXPECTED=, + > I5,5H (1).)') ILONG,NMERGE*NGCOND + CALL XABORT(HSMG) + ENDIF + ALLOCATE(WORK(NMERGE,NGCOND)) + CALL LCMGET(IPADF,'FD_B',WORK) + DO IGR=1,NGCOND + VOLTOT=0.0D0 + FLXTOT=0.0D0 + DO IKK=1,NMERGE + VOLTOT=VOLTOT+VOLMER(IKK) + FLXTOT=FLXTOT+WORK(IKK,IGR)*VOLMER(IKK) + ENDDO + COURIN(IGR)=REAL(FLXTOT/VOLTOT) + ENDDO + DEALLOCATE(WORK) + IF(IPRINT.GT.3) THEN + WRITE(6,'(/45H SPHEQU: THE VALUES OF FD_B PER MACRO-GROUPS , + > 3HARE)') + WRITE(6,'(1X,1P,10E13.5)') (COURIN(IGR),IGR=1,NGCOND) + ENDIF + ELSE IF(KSPH.EQ.4) THEN + CALL LCMLEN(IPADF,'FD_B',ILONG,ITYLCM) + IF(ILONG.NE.NMERGE*NGCOND) THEN + WRITE(HSMG,'(24HSPHEQU: BAD FD_B LENGTH=,I5,10H EXPECTED=, + > I5,5H (2).)') ILONG,NMERGE*NGCOND + CALL XABORT(HSMG) + ENDIF + ALLOCATE(WORK(NMERGE,NGCOND)) + CALL LCMGET(IPADF,'FD_B',WORK) + DO IGR=1,NGCOND + VOLTOT=0.0D0 + FLXTOT=0.0D0 + DO IKK=1,NMERGE + VOLTOT=VOLTOT+VOLMER(IKK) + FLXTOT=FLXTOT+WORK(IKK,IGR)*VOLMER(IKK) + ENDDO + COURIN(IGR)=REAL(FLXTOT/VOLTOT) + ENDDO + CALL LCMLEN(IPADF,'FD_H',ILONG,ITYLCM) + IF(ILONG.NE.NMERGE*NGCOND) THEN + WRITE(HSMG,'(24HSPHEQU: BAD FD_H LENGTH=,I5,10H EXPECTED=, + > I5,1H.)') ILONG,NMERGE*NGCOND + CALL XABORT(HSMG) + ENDIF + CALL LCMGET(IPADF,'FD_H',WORK) + DO IGR=1,NGCOND + VOLTOT=0.0D0 + FLXTOT=0.0D0 + DO IKK=1,NMERGE + VOLTOT=VOLTOT+VOLMER(IKK) + FLXTOT=FLXTOT+WORK(IKK,IGR)*VOLMER(IKK) + ENDDO + COUROW(IGR)=REAL(FLXTOT/VOLTOT) + ENDDO + DEALLOCATE(WORK) + IF(IPRINT.GT.3) THEN + WRITE(6,'(/45H SPHEQU: THE VALUES OF FD_B PER MACRO-GROUPS , + > 3HARE)') + WRITE(6,'(1X,1P,10E13.5)') (COURIN(IGR),IGR=1,NGCOND) + WRITE(6,'(/45H SPHEQU: THE VALUES OF FD_H PER MACRO-GROUPS , + > 3HARE)') + WRITE(6,'(1X,1P,10E13.5)') (COUROW(IGR),IGR=1,NGCOND) + ENDIF + ENDIF +*---- +* ITERATIVE STRATEGY USED TO COMPUTE THE SPH FACTORS +*---- + IPRIN2=MAX(0,IPRINT-5) + CALL LCMOP(IPSYS2,'SPH$SYS',0,1,0) + JPSYS2=LCMLID(IPSYS2,'GROUP',NGCOND) +*---- +* REMOVE DB2 LEAKAGE FROM SOURCES +*---- + IF(ILEAKS.NE.0) THEN + DO 50 IGR=1,NGCOND + DO 40 IKK=1,NMERGE + SUNMER(IKK,IGR,IGR,1)=SUNMER(IKK,IGR,IGR,1)-ZLEAK(IKK,IGR) + 40 CONTINUE + 50 CONTINUE + ENDIF +*---- +* SET SPH NORMALIZATION INFORMATION +*---- + IF(KSPH.LT.0) THEN +* ASYMPTOTIC NORMALIZATION WITH RESPECT TO MIXTURE -KSPH. + DO 70 IGR=1,NGCOND + VOLTOT=0.0D0 + FLXTOT=0.0D0 + DO 60 IKK=1,NMERGE + IF(IKK.EQ.-KSPH) THEN + VOLTOT=VOLTOT+VOLMER(IKK) + FLXTOT=FLXTOT+FLXMER(IKK,IGR)*VOLMER(IKK) + ENDIF + 60 CONTINUE + IF(VOLTOT.EQ.0.0) CALL XABORT('SPHEQU: ASYMPTOTIC NORMALIZATI' + > //'ON FAILURE.') + COURIN(IGR)=REAL(FLXTOT/VOLTOT) + SPH(:NMERGE,IGR)=1.0 + 70 CONTINUE + IF(IPRINT.GT.3) THEN + WRITE(6,910) (COURIN(IGR),IGR=1,NGCOND) + WRITE(6,'(/)') + ENDIF + ELSE IF(KSPH.EQ.1) THEN +* AVERAGE FLUX NORMALIZATION. + DO 90 IGR=1,NGCOND + VOLTOT=0.0D0 + FLXTOT=0.0D0 + DO 80 IKK=1,NMERGE + VOLTOT=VOLTOT+VOLMER(IKK) + FLXTOT=FLXTOT+FLXMER(IKK,IGR)*VOLMER(IKK) + 80 CONTINUE + COURIN(IGR)=REAL(FLXTOT/VOLTOT) + 90 CONTINUE + IF(IPRINT.GT.3) THEN + WRITE(6,910) (COURIN(IGR),IGR=1,NGCOND) + WRITE(6,'(/)') + ENDIF + ELSE IF((KSPH.EQ.2).OR.(KSPH.EQ.3).OR.(KSPH.EQ.5)) THEN +* SELENGUT NORMALIZATION. + DO 120 IGR=1,NGCOND + VOLTOT=0.0D0 + FLXTOT=0.0D0 + DO 100 IKK=1,NMERGE + VOLTOT=VOLTOT+VOLMER(IKK) + FLXTOT=FLXTOT+FLXMER(IKK,IGR)*VOLMER(IKK) + 100 CONTINUE + FLXTOT=FLXTOT/VOLTOT + DO 110 IKK=1,NMERGE + SPH(IKK,IGR)=REAL(FLXTOT)/COURIN(IGR) + 110 CONTINUE + 120 CONTINUE + ELSE IF(KSPH.EQ.4) THEN +* GENERALIZED SELENGUT NORMALIZATION (EDF-TYPE). + DO 150 IGR=1,NGCOND + VOLTOT=0.0D0 + FLXTOT=0.0D0 + DO 130 IKK=1,NMERGE + VOLTOT=VOLTOT+VOLMER(IKK) + FLXTOT=FLXTOT+FLXMER(IKK,IGR)*VOLMER(IKK) + 130 CONTINUE + FLXTOT=FLXTOT/VOLTOT + DO 140 IKK=1,NMERGE + SPH(IKK,IGR)=COUROW(IGR)/COURIN(IGR) + 140 CONTINUE + COURIN(IGR)=COURIN(IGR)*REAL(FLXTOT)/COUROW(IGR) + 150 CONTINUE + ELSE IF(KSPH.EQ.6) THEN +* MACRO-CALCULATION WATER GAP NORMALIZATION. +* COUROW = flux in gap in diffusion, initialized to flux in gap in transport +* FUNKNO = FLXMER : flux in diffusion, initialized to flux in transport + DO 160 IGR=1,NGCOND + COUROW(IGR)=COURIN(IGR) + SPH(:NMERGE,IGR)=1.0 + 160 CONTINUE + ELSE IF(KSPH.EQ.7) THEN +* AVERAGE FLUX NORMALIZATION IN FISSILE ZONES. + DO 180 IGR=1,NGCOND + VOLTOT=0.0D0 + FLXTOT=0.0D0 + DO 170 IKK=1,NMERGE + IF(LFISS(IKK)) THEN + VOLTOT=VOLTOT+VOLMER(IKK) + FLXTOT=FLXTOT+FLXMER(IKK,IGR)*VOLMER(IKK) + ENDIF + 170 CONTINUE + COURIN(IGR)=REAL(FLXTOT/VOLTOT) + 180 CONTINUE + IF(IPRINT.GT.3) THEN + WRITE(6,910) (COURIN(IGR),IGR=1,NGCOND) + WRITE(6,'(/)') + ENDIF + ENDIF + IF((NSPH.EQ.2).AND.(KSPH.NE.5)) GO TO 470 +*---- +* SPH ITERATIONS. +*---- + ITER=0 + IF(C_ASSOCIATED(IPFLX)) THEN + CALL LCMGET(IPFLX,'STATE-VECTOR',IPAR) + IF(IPAR(1).NE.NGCOND) CALL XABORT('SPHEQU: INVALID NB OF GROUP' + 1 //'S IN THE INITIALIZATION FLUX.') + IF(IPAR(2).NE.NUN2) CALL XABORT('SPHEQU: INVALID NB OF UNKNOWN' + 1 //'S IN THE INITIALIZATION FLUX.') + JPFLX=LCMGID(IPFLX,'FLUX') + DO 190 IGR=1,NGCOND + CALL LCMGDL(JPFLX,IGR,FUNKNO(1,IGR)) + 190 CONTINUE + ITER=1 + ELSE IF((CDOOR.EQ.'BIVAC').OR.(CDOOR.EQ.'TRIVAC')) THEN + DO 200 IGR=1,NGCOND + FUNKNO(:NUN2,IGR)=1.0 + 200 CONTINUE + ELSE + DO 220 IGR=1,NGCOND + FUNKNO(:NUN2,IGR)=0.0 + DO 210 IREG=1,NREG2 + IMAT=MAT2(IREG) + IF(IMAT.GT.0) FUNKNO(KEY2(IREG),IGR)=FLXMER(MERG2(IMAT),IGR) + 210 CONTINUE + 220 CONTINUE + ENDIF + OLDERR=1.0 + NBIERR=0 + 230 ITER=ITER+1 + IF(ITER.GE.MAXIT) THEN + WRITE(6,'(/46H SPHEQU: MAX. NUMBER OF ITERATIONS IS REACHED.)') + GO TO 440 + ENDIF + ERROR=0.0 + ERR2=0.0 + DO 240 IREG=1,NREG2 + IF(MAT2(IREG).GT.NBMIX2) THEN + CALL XABORT('SPHEQU: INVALID MACRO-MIXTURE INDEX.') + ENDIF + 240 CONTINUE +*---- +* SET MACROSCOPIC CROSS SECTIONS IN THE IPSYS2 LCM OBJECT. +*---- + NPSYS(:NGCOND)=0 + DO 310 IGR=IGRMIN,IGRMAX + SIGMS(0:NBMIX2,:NW+1)=0.0 + SIGMA(0:NBMIX2,:ISCAT+1)=0.0 + SIGMD(0:NBMIX2)=0.0 + DO 280 IREG=1,NREG2 + IMAT=MAT2(IREG) + IF(IMAT.EQ.0) GO TO 280 + IMERG=MERG2(IMAT) + IF(LDIFF) SIGMD(IMAT)=DIFF(IMERG,IGR)*SPH(IMERG,IGR) + IF(IMC.EQ.1) THEN + SIGMA(IMAT,1)=SIGW(IMERG,IGR,1)*SPH(IMERG,IGR) + DO 250 IW=1,NW+1 + IF(MOD(IW-1,2).EQ.0) THEN + SIGMS(IMAT,IW)=SIGT(IMERG,IGR,IW)*SPH(IMERG,IGR) + ELSE IF(MOD(IW-1,2).EQ.1) THEN + SIGMS(IMAT,IW)=SIGT(IMERG,IGR,IW)/SPH(IMERG,IGR) + ENDIF + 250 CONTINUE + ELSE IF(IMC.EQ.2) THEN +* TRANSPORT-PIJ EQUIVALENCE WITHOUT BELL FACTOR ACCELERATION. + SIGMA(IMAT,1)=SIGW(IMERG,IGR,1)*SPH(IMERG,IGR)+SIGT(IMERG,IGR,1) + > *(1.0-SPH(IMERG,IGR)) + DO 260 IW=1,NW+1 + SIGMS(IMAT,IW)=SIGT(IMERG,IGR,IW) + 260 CONTINUE + ELSE IF(IMC.EQ.3) THEN +* TRANSPORT-PIJ EQUIVALENCE WITH BELL FACTOR ACCELERATION. + SIGMA(IMAT,1)=0.0 + DO 270 IW=1,NW+1 + SIGMS(IMAT,IW)=SIGT(IMERG,IGR,IW) + 270 CONTINUE + ENDIF + 280 CONTINUE + NPSYS(IGR)=IGR + KPSYS2=LCMDIL(JPSYS2,IGR) + DO 290 IW=1,MIN(NW+1,10) + IF(IW.EQ.1) THEN + TEXT12='DRAGON-TXSC' + ELSE + WRITE(TEXT12,'(8HDRAGON-T,I1,3HXSC)') IW-1 + ENDIF + CALL LCMPUT(KPSYS2,TEXT12,NBMIX2+1,2,SIGMS(0,IW)) + 290 CONTINUE + CALL LCMPUT(KPSYS2,'DRAGON-S0XSC',NBMIX2+1,2,SIGMA(0,1)) + IF(LDIFF) THEN + SIGMD(0)=1.0E10 + CALL LCMPUT(KPSYS2,'DRAGON-DIFF',NBMIX2+1,2,SIGMD(0)) + ENDIF +*---- +* SPH CORRECTION OF PHYSICAL ALBEDOS +*---- + IF(NALBP.GT.0) THEN + DO 300 IAL=1,NALBP + FACT=0.5*(1.0-ALB2(IAL,IGR))/(1.0+ALB2(IAL,IGR))* + 1 SPH(NMERGE+IAL,IGR) + ALB1(IAL,IGR)=(1.0-2.0*FACT)/(1.0+2.0*FACT) + 300 CONTINUE + CALL LCMPUT(KPSYS2,'ALBEDO',NALBP,2,ALB1(1,IGR)) + ENDIF + 310 CONTINUE +*---- +* ASSEMBLY OF PIJ OR SYSTEM MATRICES AT ITERATION ITER. +*---- + IF(.NOT.C_ASSOCIATED(IPTRK2)) THEN + CALL XABORT('SPHEQU: MACRO-TRACKING NOT DEFINED(2).') + ENDIF + ISTRM=1 + KNORM=1 + IPHASE=2 + IF(NSPH.EQ.4) IPHASE=1 + IF(IPHASE.EQ.2) THEN + IPIJK=1 + ITPIJ=1 + LNORM=.FALSE. + CALL DOORPV(CDOOR,JPSYS2,NPSYS,IPTRK2,IFTRAK,IPRIN2,NGCOND, + > NREG2,NBMIX2,NANI,MAT2,VOL2,KNORM,IPIJK,ILK,ITPIJ,LNORM, + > CTITRE,NALBP) + ELSE + CALL DOORAV(CDOOR,JPSYS2,NPSYS,IPTRK2,IFTRAK,IPRIN2,NGCOND, + > NREG2,NBMIX2,NANI,NW,MAT2,VOL2,KNORM,ILK,CTITRE,NALBP,ISTRM) + ENDIF +*---- +* TRANSPORT-PIJ EQUIVALENCE WITH BELL FACTOR ACCELERATION. +*---- + IF(IMC.EQ.3) THEN + CALL SPHTRA(JPSYS2,ITER,NPSYS,KSPH,NREG2,NUN2,NMERGE,NALBP, + 1 NGCOND,SUNMER(1,1,1,1),FLXMER,NBMIX2,MAT2,VOL2,KEY2,MERG2,SPH, + 2 SIGW(1,1,1),SIGT(1,1,1),COURIN,FUNKNO) + SNORM(:NGCOND)=1.0 + GO TO 390 + ENDIF +*---- +* MACRO-FLUX CALCULATION AT ITERATION ITER. +*---- + ALLOCATE(SIGG(0:NBMIX2)) + DO IGR=1,NGCOND + SUNKNO(:NUN2,IGR)=0.0 + IF(NPSYS(IGR).EQ.0) CYCLE + IF(ITER.EQ.1) THEN + SIGG(0)=0.0 + DO IBM=1,NBMIX2 + PV=0.0 + DO JGR=1,NGCOND + PV=PV+SUNMER(MERG2(IBM),JGR,IGR,1)*FLXMER(MERG2(IBM),JGR) + ENDDO ! JGR + SIGG(IBM)=PV + ENDDO ! IBM + CALL DOORS(CDOOR,IPTRK2,NBMIX2,0,NUN2,SIGG,SUNKNO(1,IGR)) + ELSE + DO JGR=1,NGCOND + SIGG(0)=0.0 + DO IBM=1,NBMIX2 + SIGG(IBM)=SUNMER(MERG2(IBM),JGR,IGR,1)*SPH(MERG2(IBM),JGR) + ENDDO ! IBM + CALL DOORS(CDOOR,IPTRK2,NBMIX2,0,NUN2,SIGG,SUNKNO(1,IGR), + 1 FUNKNO(1,JGR)) + ENDDO + ENDIF + ENDDO ! IGR + DEALLOCATE(SIGG) +*---- +* COMPUTE THE MACRO-FLUX USING THE VECTORIAL DOOR. +*---- + IDIR=0 + IPSOU=C_NULL_PTR + LEXAC=.FALSE. + REBFLG=.FALSE. + CALL DOORFV(CDOOR,JPSYS2,NPSYS,IPTRK2,IFTRAK,IPRIN2,NGCOND, + 1 NBMIX2,IDIR,NREG2,NUN2,IPHASE,LEXAC,MAT2,VOL2,KEY2,CTITRE, + 2 SUNKNO,FUNKNO,IPMACR,IPSOU,REBFLG) +*---- +* COMPUTE MACRO-CALCULATION LEAKAGE RATES IF NALBP.GT.0 +*---- + IF(NALBP.GT.0) THEN + DO 340 IGR=1,NGCOND + OUTG1(IGR)=0.0 + DO 330 K=1,NREG2 + L=MAT2(K) + IF(L.EQ.0) GO TO 330 + IUN=KEY2(K) + IF(VOL2(K).EQ.0.0) GO TO 330 + IKK=MERG2(L) + OUTG1(IGR)=OUTG1(IGR)+(SIGW(IKK,IGR,1)-SIGT(IKK,IGR,1))* + > FUNKNO(IUN,IGR)*VOLMER(IKK)*SPH(IKK,IGR) + DO 320 JGR=1,NGCOND + OUTG1(IGR)=OUTG1(IGR)+SUNMER(IKK,JGR,IGR,1)*FUNKNO(IUN,JGR)* + > VOLMER(IKK)*SPH(IKK,JGR) + 320 CONTINUE + 330 CONTINUE + IF(IPRIN2.GT.0) WRITE(6,920) IGR,OUTG1(IGR) + 340 CONTINUE + ENDIF +*---- +* MACRO-FLUX NORMALIZATION. +*---- + IF(ILK.AND.(NALBP.EQ.0)) GO TO 390 + SNORM(:NGCOND)=1.0 + IF(KSPH.LT.0) THEN +* ASYMTTOTIC NORMALIZATION WITH RESPECT TO MIXTURE -KSPH. + IF(-KSPH.GT.NMERGE) CALL XABORT('SPHEQU: INVALID ASYMPTOTIC M' + > //'IXTURE SET.') + DO 360 IGR=1,NGCOND + IF(NPSYS(IGR).EQ.0) GO TO 360 + VOLTOT=0.0D0 + FLXTOT=0.0D0 + DO 350 IREG=1,NREG2 + IMAT=MAT2(IREG) + IF(IMAT.EQ.0) GO TO 350 + IF(MERG2(IMAT).EQ.-KSPH) THEN + VOLTOT=VOLTOT+VOL2(IREG) + FLXTOT=FLXTOT+FUNKNO(KEY2(IREG),IGR)*VOL2(IREG) + ENDIF + 350 CONTINUE + IF(VOLTOT.GT.0) THEN + FLXTOT=FLXTOT/VOLTOT + FFF=COURIN(IGR)/REAL(FLXTOT) + ELSE + FFF=1.0 + ENDIF + SNORM(IGR)=FFF + IF(IPRIN2.GT.0) WRITE(6,960) IGR,FFF + 360 CONTINUE + ELSE +* AVERAGE OR SELENGUT FLUX NORMALIZATION. + DO 380 IGR=1,NGCOND + IF(NPSYS(IGR).EQ.0) GO TO 380 + VOLTOT=0.0D0 + FLXTOT=0.0D0 + DO 370 IREG=1,NREG2 + IMAT=MAT2(IREG) + IF(IMAT.EQ.0) GO TO 370 + IMERG=MERG2(IMAT) + IF((KSPH.NE.7).OR.LFISS(IMERG)) THEN + VOLTOT=VOLTOT+VOL2(IREG) + FLXTOT=FLXTOT+FUNKNO(KEY2(IREG),IGR)*VOL2(IREG) + ENDIF + 370 CONTINUE + FLXTOT=FLXTOT/VOLTOT + IF(IPRINT.GE.100) THEN + WRITE(6,*)'FLXTOT: =',FLXTOT,'VOLTOT: =',VOLTOT + ENDIF + IF(KSPH.NE.6) THEN + SNORM(IGR)=COURIN(IGR)/REAL(FLXTOT) + ELSE +* Compute diffusion flux in water gap => COUROW(IGR) + IF(CDOOR.NE.'TRIVAC') CALL XABORT('SPHEQU: TRIVAC expected' + 1 //' as tracking module with SELE-GAP') + CALL SPHGAP(IPTRK2,IPRINT,NREG2,NUN2,MAT2,KEY2,FUNKNO(1,IGR), + 1 COUROW(IGR)) + IF(IPRINT.GE.100) THEN + WRITE(6,*)'COURIN: =',COURIN(IGR),'COUROW: =',COUROW(IGR) + ENDIF + SNORM(IGR)=COURIN(IGR)/COUROW(IGR) + ENDIF + IF(IPRIN2.GT.0) WRITE(6,960) IGR,SNORM(IGR) + 380 CONTINUE + ENDIF +*---- +* COMPUTE THE IMPROVED SPH FACTORS. +*---- + 390 ALLOCATE(SPHNEW(NMERGE+NALBP)) + DO 430 IGR=1,NGCOND + IF(NPSYS(IGR).EQ.0) GO TO 430 + VOLMER(:NMERGE)=0.0 + FACTOR(:NMERGE)=0.0 + SPHNEW(:NMERGE+NALBP)=1.0 + DO 400 IREG=1,NREG2 + IMAT=MAT2(IREG) + IF(IMAT.EQ.0) GO TO 400 + IKK=MERG2(IMAT) + VOLMER(IKK)=VOLMER(IKK)+VOL2(IREG) + FACTOR(IKK)=FACTOR(IKK)+FUNKNO(KEY2(IREG),IGR)*VOL2(IREG) + 400 CONTINUE + DO 410 IKK=1,NMERGE + IF(VOLMER(IKK).EQ.0.0) GO TO 410 + FACTOR(IKK)=FACTOR(IKK)/VOLMER(IKK) + SPHNEW(IKK)=FLXMER(IKK,IGR)/(SNORM(IGR)*FACTOR(IKK)) + IF(SPHNEW(IKK).LT.0.0) THEN + WRITE(6,980) IGR,IKK + SPHNEW(IKK)=1.0 + ENDIF + 410 CONTINUE + IF(NALBP.EQ.1) SPHNEW(NMERGE+1)=OUTG1(IGR)/(OUTG2(IGR)*SNORM(IGR)) + DO 420 IKK=1,NMERGE+NALBP + ERRT=ABS((SPHNEW(IKK)-SPH(IKK,IGR))/SPHNEW(IKK)) + ERR2=ERR2+ERRT*ERRT + ERROR=MAX(ERROR,ERRT) + SPH(IKK,IGR)=SPHNEW(IKK) + 420 CONTINUE + IF(IPRINT.GT.4) THEN + WRITE(6,930) 'NSPH',IGR,(SPH(IKK,IGR),IKK=1,NMERGE+NALBP) + ENDIF + IF(IPRINT.GT.5) THEN + WRITE(6,930) 'FUNKNO',IGR,(FUNKNO(IUNK,IGR),IUNK=1,NUN2) + ENDIF + 430 CONTINUE + DEALLOCATE(SPHNEW) + ERR2=SQRT(ERR2/(NMERGE*NGCOND)) + IF(IPRINT.GT.1) WRITE(6,935) ITER,ERROR,ERR2 + IF(IPRINT.GT.2) THEN + IF(ERROR.GE.EPSPH) WRITE(6,940) ((IKK,IGR,SPH(IKK,IGR), + > IKK=1,NMERGE+NALBP),IGR=1,NGCOND) + ENDIF + IF(ERR2.LT.EPSPH) GO TO 440 + IF((ITER.GT.1).AND.(ERR2.GT.OLDERR)) THEN + WRITE(6,970) ITER + NBIERR=NBIERR+1 + IF(NBIERR.GE.MAXNBI) THEN + WRITE(6,990) ITER + GO TO 440 + ENDIF + ENDIF + OLDERR=ERR2 + GO TO 230 + 440 WRITE(6,950) ITER +*---- +* RESET SOURCES TO NO DB2 LEAKAGE +*---- + IF(ILEAKS.NE.0) THEN + DO 460 IGR=1,NGCOND + DO 450 IKK=1,NMERGE + SUNMER(IKK,IGR,IGR,1)=SUNMER(IKK,IGR,IGR,1)+ZLEAK(IKK,IGR) + 450 CONTINUE + 460 CONTINUE + ENDIF + CALL LCMCL(IPSYS2,2) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 470 DEALLOCATE(LFISS,ALB2,ALB1,SNORM,OUTG2,OUTG1,FACTOR,SUNKNO, + 1 FUNKNO,SUNMER,ZLEAK,DIFF,FLXMER,SIGW,SIGT,VOLMER,COUROW,COURIN, + 2 SIGMD,SIGMS,SIGMA) + DEALLOCATE(NPSYS) + RETURN +* + 910 FORMAT(/44H SPHEQU: AVERAGE FLUXES PER MACRO-GROUPS ARE/ + > (1X,1P,10E13.5)) + 920 FORMAT(/8H SPHEQU:,5X,6HGROUP=,I4,15H MACRO LEAKAGE=,1P,E12.4) + 930 FORMAT(/26H SPHEQU: VALUES OF VECTOR ,A,9H IN GROUP,I5,4H ARE/ + > (1X,1P,10E13.5)) + 935 FORMAT(/14H SPHEQU: ITER=,I3,4X,6HERROR=,1P,E10.3,1X,6HERR 2=, + > E10.3) + 940 FORMAT(4X,4HSPH(,I3,1H,,I3,2H)=,F9.5,:,4X,4HSPH(,I3,1H,,I3,2H)=, + > F9.5,:,4X,4HSPH(,I3,1H,,I3,2H)=,F9.5,:,4X,4HSPH(,I3,1H,,I3,2H)=, + > F9.5,:,4X,4HSPH(,I3,1H,,I3,2H)=,F9.5) + 950 FORMAT(/40H SPHEQU: ENDING OF SPH CONVERGENCE AFTER,I5, + > 12H ITERATIONS.) + 960 FORMAT(/43H SPHEQU: FLUX NORMALIZATION FACTOR IN GROUP,I4,1H=,1P, + 1 E13.5) + 970 FORMAT(1X,'Warning: oscillations in SPH at iteration ',i10) + 980 FORMAT(1X,'Warning: negative SPH factor in group ',i5, + > ' and region ',i5,' set to 1.0') + 990 FORMAT(1X,'Warning: maximum of 3 error oscillations ', + >'in SPH convergence reached at iteration ',i10) + END diff --git a/Dragon/src/SPHGAP.f b/Dragon/src/SPHGAP.f new file mode 100644 index 0000000..b9b9865 --- /dev/null +++ b/Dragon/src/SPHGAP.f @@ -0,0 +1,297 @@ +*DECK SPHGAP + SUBROUTINE SPHGAP(IPTRK2,IPRINT,NREG,NUN,MAT,KEY,FUNKNO,COUGAP) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the average flux at the boundary +* +*Copyright: +* Copyright (C) 2014 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modIFy it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Chambon +* +*Parameters: input +* IPTRK2 pointer to the TRIVAC tracking of the macro-geometry +* (L_TRACK signature). +* IPRINT print flag (equal to 0 for no print). +* NREG number of macro-regions (in the macro calculation). +* NUN number of unknowns in the macro-calculation. +* MAT mixture index per macro-region. +* KEY position of the flux components associated with each volume. +* FUNKNO neutron flux. +* +*Parameters: output +* COUGAP boundary average flux. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK2 + INTEGER NREG,NUN,MAT(NREG),KEY(NREG) + REAL FUNKNO(NUN),COUGAP +*---- +* LOCAL VARIABLES +*---- + INTEGER NSTATE,NP + PARAMETER (NSTATE=40,NP=3) + INTEGER IPAR(NSTATE),IELEM,NCODE(6),LX,LY,LP,ITYPE,IPRINT, + + ICHX,IDIM,LC,L4,MAXKN,MKN,ITYLCM + INTEGER I,J + REAL XM(1),XP(1),YM(1),YP(1),SXM,SXP,SYM,SYP,DG,LTOT,FACT + REAL E(25) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KN + REAL, ALLOCATABLE, DIMENSION(:) :: X,Y,XX,YY,XXX,YYY,AXYZ +*---- +* RECOVER TRIVAC SPECIFIC TRACKING INFORMATION +*---- + CALL LCMGET(IPTRK2,'STATE-VECTOR',IPAR) + ITYPE=IPAR(6) + IF(ITYPE.NE.5) CALL XABORT('SPHGAP: 2D Cartesian geometry ' + 1 //'expected') + IELEM=IPAR(9) + L4=IPAR(11) + ICHX=IPAR(12) + LX=IPAR(14) + LY=IPAR(15) + LP=MAX(LX,LY)*NP + IDIM=2 + ALLOCATE(XX(LX*LY),YY(LX*LY),XXX(LX+1),YYY(LY+1)) + ALLOCATE(X(3*LX),Y(3*LY),AXYZ(LP)) + CALL LCMGET(IPTRK2,'XX',XX) + CALL LCMGET(IPTRK2,'YY',YY) + CALL LCMGET(IPTRK2,'NCODE',NCODE) +*---- +* Compute the coordinate of the point on the boundary +*---- + XXX(1)=0.0 + DO 10 I=1,LX + XXX(I+1)=XXX(I)+XX(I) + 10 CONTINUE + YYY(1)=0.0 + DO 20 I=1,LY + YYY(I+1)=YYY(I)+YY((I-1)*LX+1) + 20 CONTINUE + IF(NCODE(1).EQ.5)THEN + XM(1)=(XXX(1)+XXX(2))/2.0 + ELSE + XM(1)=XXX(1) + ENDIF + IF(NCODE(2).EQ.5)THEN + XP(1)=(XXX(LX+1)+XXX(LX))/2.0 + ELSE + XP(1)=XXX(LX+1) + ENDIF + IF(NCODE(3).EQ.5)THEN + YM(1)=(YYY(1)+YYY(2))/2.0 + ELSE + YM(1)=YYY(1) + ENDIF + IF(NCODE(4).EQ.5)THEN + YP(1)=(YYY(LY+1)+YYY(LY))/2.0 + ELSE + YP(1)=YYY(LY+1) + ENDIF + DO I=1,NP + FACT=REAL(2*I-1)/REAL(2*NP) + X(I)=(XXX(2)-XM(1))*FACT + X(NP*(LX-1)+I)=XXX(LX)+(XP(1)-XXX(LX))*FACT + DO J=1,LX-2 + X(NP*J+I)=XXX(J+1)+(XXX(J+2)-XXX(J+1))*FACT + ENDDO + Y(I)=(YYY(2)-YM(1))*FACT + Y(NP*(LY-1)+I)=YYY(LY)+(YP(1)-YYY(LY))*FACT + DO J=1,LY-2 + Y(NP*J+I)=YYY(J+1)+(YYY(J+2)-YYY(J+1))*FACT + ENDDO + ENDDO + IF(IPRINT.GE.100) then + WRITE(6,*)'FUNKNO: =' + do I=1,LY + WRITE(6,*) I,'#',(FUNKNO(KEY(J+(I-1)*LX)),J=1,LX) + enddo + WRITE(6,*)'NCODE: =',(NCODE(I),I=1,6) + WRITE(6,*)'XXX: =',(XXX(I),I=1,LX+1) + WRITE(6,*)'YYY: =',(YYY(I),I=1,LY+1) + WRITE(6,*)'X: =',(X(I),I=1,3*LX) + WRITE(6,*)'Y: =',(Y(I),I=1,3*LY) + endIF +*---- +* Interpolate the flux +*---- + COUGAP=0.0 + LTOT=0.0 + IF(NCODE(1).EQ.5)THEN + SXM=-1.0 + ELSE + IF(ICHX.EQ.1) THEN +* Variational collocation method + CALL LCMLEN(IPTRK2,'KN',MAXKN,ITYLCM) + MKN=MAXKN/(LX*LY) + ALLOCATE(KN(MAXKN)) + CALL LCMGET(IPTRK2,'KN',KN) + CALL LCMSIX(IPTRK2,'BIVCOL',1) + CALL LCMLEN(IPTRK2,'T',LC,ITYLCM) + CALL LCMGET(IPTRK2,'E',E) + CALL LCMSIX(IPTRK2,' ',2) + CALL VALU2B(LC,MKN,LX,LY,L4,XM(1),Y(1),XXX,YYY,FUNKNO,MAT,KN, + + 1,3*LY,E,AXYZ) + ELSE IF(ICHX.EQ.2) THEN +* Raviart-Thomas finite element method + CALL VALU4B(IELEM,NUN,LX,LY,XM(1),Y(1),XXX,YYY,FUNKNO,MAT,KEY, + + 1,3*LY,AXYZ) + ELSE IF(ICHX.EQ.3) THEN +* Nodal collocation method (MCFD) + CALL VALU1B(IDIM,LX,LY,L4,XM(1),Y(1),XXX,YYY,FUNKNO,MAT,IELEM, + + 1,3*LY,AXYZ) + ELSE + CALL XABORT('SPHGAP: INTERPOLATION NOT IMPLEMENTED(1).') + ENDIF + IF(IPRINT.GE.100) WRITE(6,*)'SPHGAP: AXYZ =',(AXYZ(I),I=1,3*LY) + SXM=0.0 + DO J=1,LY + DG=(MIN(YP(1),YYY(J+1))-MAX(YM(1),YYY(J)))/REAL(NP) + DO I=1,NP + SXM=SXM+AXYZ((J-1)*NP+I)*DG + ENDDO + ENDDO + COUGAP=COUGAP+SXM + LTOT=LTOT+YP(1)-YM(1) + ENDIF + IF(NCODE(2).EQ.5)THEN + SXP=-1.0 + ELSE + IF(ICHX.EQ.1) THEN +* Variational collocation method + CALL LCMLEN(IPTRK2,'KN',MAXKN,ITYLCM) + MKN=MAXKN/(LX*LY) + ALLOCATE(KN(MAXKN)) + CALL LCMGET(IPTRK2,'KN',KN) + CALL LCMSIX(IPTRK2,'BIVCOL',1) + CALL LCMLEN(IPTRK2,'T',LC,ITYLCM) + CALL LCMGET(IPTRK2,'E',E) + CALL LCMSIX(IPTRK2,' ',2) + CALL VALU2B(LC,MKN,LX,LY,L4,XP(1),Y(1),XXX,YYY,FUNKNO,MAT,KN, + + 1,3*LY,E,AXYZ) + ELSE IF(ICHX.EQ.2) THEN +* Raviart-Thomas finite element method + CALL VALU4B(IELEM,NUN,LX,LY,XP(1),Y(1),XXX,YYY,FUNKNO,MAT,KEY, + + 1,3*LY,AXYZ) + ELSE IF(ICHX.EQ.3) THEN +* Nodal collocation method (MCFD) + CALL VALU1B(IDIM,LX,LY,L4,XP(1),Y(1),XXX,YYY,FUNKNO,MAT,IELEM, + + 1,3*LY,AXYZ) + ELSE + CALL XABORT('SPHGAP: INTERPOLATION NOT IMPLEMENTED(2).') + ENDIF + IF(IPRINT.GE.100) WRITE(6,*)'SPHGAP: AXYZ =',(AXYZ(I),I=1,3*LY) + SXP=0.0 + DO J=1,LY + DG=(MIN(YP(1),YYY(J+1))-MAX(YM(1),YYY(J)))/REAL(NP) + DO I=1,NP + SXP=SXP+AXYZ((J-1)*NP+I)*DG + ENDDO + ENDDO + COUGAP=COUGAP+SXP + LTOT=LTOT+YP(1)-YM(1) + ENDIF + IF(NCODE(3).EQ.5)THEN + SYM=-1.0 + ELSE + IF(ICHX.EQ.1) THEN +* Variational collocation method + CALL LCMLEN(IPTRK2,'KN',MAXKN,ITYLCM) + MKN=MAXKN/(LX*LY) + ALLOCATE(KN(MAXKN)) + CALL LCMGET(IPTRK2,'KN',KN) + CALL LCMSIX(IPTRK2,'BIVCOL',1) + CALL LCMLEN(IPTRK2,'T',LC,ITYLCM) + CALL LCMGET(IPTRK2,'E',E) + CALL LCMSIX(IPTRK2,' ',2) + CALL VALU2B(LC,MKN,LX,LY,L4,X(1),YM(1),XXX,YYY,FUNKNO,MAT,KN, + + 3*LX,1,E,AXYZ) + ELSE IF(ICHX.EQ.2) THEN +* Raviart-Thomas finite element method + CALL VALU4B(IELEM,NUN,LX,LY,X(1),YM(1),XXX,YYY,FUNKNO,MAT,KEY, + + 3*LX,1,AXYZ) + ELSE IF(ICHX.EQ.3) THEN +* Nodal collocation method (MCFD) + CALL VALU1B(IDIM,LX,LY,L4,X(1),YM(1),XXX,YYY,FUNKNO,MAT,IELEM, + + 3*LX,1,AXYZ) + ELSE + CALL XABORT('SPHGAP: INTERPOLATION NOT IMPLEMENTED(3).') + ENDIF + IF(IPRINT.GE.100) WRITE(6,*)'SPHGAP: AXYZ =',(AXYZ(I),I=1,3*LX) + SYM=0.0 + DO J=1,LX + DG=(MIN(XP(1),XXX(J+1))-MAX(XM(1),XXX(J)))/REAL(NP) + DO I=1,NP + SXM=SXM+AXYZ((J-1)*NP+I)*DG + ENDDO + ENDDO + COUGAP=COUGAP+SYM + LTOT=LTOT+XP(1)-XM(1) + ENDIF + IF(NCODE(4).EQ.5)THEN + SYP=-1.0 + ELSE + IF(ICHX.EQ.1) THEN +* Variational collocation method + CALL LCMLEN(IPTRK2,'KN',MAXKN,ITYLCM) + MKN=MAXKN/(LX*LY) + ALLOCATE(KN(MAXKN)) + CALL LCMGET(IPTRK2,'KN',KN) + CALL LCMSIX(IPTRK2,'BIVCOL',1) + CALL LCMLEN(IPTRK2,'T',LC,ITYLCM) + CALL LCMGET(IPTRK2,'E',E) + CALL LCMSIX(IPTRK2,' ',2) + CALL VALU2B(LC,MKN,LX,LY,L4,X(1),YP(1),XXX,YYY,FUNKNO,MAT,KN, + + 3*LX,1,E,AXYZ) + ELSE IF(ICHX.EQ.2) THEN +* Raviart-Thomas finite element method + CALL VALU4B(IELEM,NUN,LX,LY,X(1),YP(1),XXX,YYY,FUNKNO,MAT,KEY, + + 3*LX,1,AXYZ) + ELSE IF(ICHX.EQ.3) THEN +* Nodal collocation method (MCFD) + CALL VALU1B(IDIM,LX,LY,L4,X(1),YP(1),XXX,YYY,FUNKNO,MAT,IELEM, + + 3*LX,1,AXYZ) + ELSE + CALL XABORT('SPHGAP: INTERPOLATION NOT IMPLEMENTED(4).') + ENDIF + IF(IPRINT.GE.100) WRITE(6,*)'SPHGAP: AXYZ =',(AXYZ(I),I=1,3*LX) + SYP=0.0 + DO J=1,LX + DG=(MIN(XP(1),XXX(J+1))-MAX(XM(1),XXX(J)))/REAL(NP) + DO I=1,NP + SXP=SXP+AXYZ((J-1)*NP+I)*DG + ENDDO + ENDDO + COUGAP=COUGAP+SYP + LTOT=LTOT+XP(1)-XM(1) + ENDIF + IF(IPRINT.GE.100) WRITE(6,*)'SPHGAP: S-XY-PM =',SXM,SXP,SYM,SYP + +* Compute the average flux + IF(LTOT.EQ.0.0) CALL XABORT('SPHGAP: Error boundary flux = 0.0') + IF(IPRINT.GE.100) WRITE(6,*)'SPHGAP: COUGAP =',COUGAP,' LTOT=', + 1 LTOT,'Before normalization' + COUGAP=COUGAP/LTOT + IF(IPRINT.GE.5) WRITE(6,*)'SPHGAP: COUGAP =',COUGAP,' LTOT=',LTOT +*---- +* DEALLOCATE +*---- + DEALLOCATE(AXYZ,Y,X) + DEALLOCATE(YYY,XXX,YY,XX) + RETURN + END diff --git a/Dragon/src/SPHMAC.f b/Dragon/src/SPHMAC.f new file mode 100644 index 0000000..b53313e --- /dev/null +++ b/Dragon/src/SPHMAC.f @@ -0,0 +1,336 @@ +*DECK SPHMAC + SUBROUTINE SPHMAC(IPMACR,IPRINT,NMERGE,NALBP,NGCOND,ISCAT,NW, + 1 NIFISS,ILEAKS,VOLMER,FLXMER,SUNMER,SIGT,SIGW,DIFF,ZLEAK,OUTG, + 2 ALB,LFISS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recovery of the reference merged/condensed set of cross sections +* to be used by an SPH homogenization algorithm. +* +*Copyright: +* Copyright (C) 2011 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMACR pointer to the condensed macrolib (L_MACROLIB signature). +* IPRINT print flag (equal to 0 for no print). +* NMERGE number of merged regions. +* NALBP number of physical albedos. +* NGCOND number of condensed groups. +* ISCAT scattering anisotropy in the reference set of cross sections +* (=1 isotropic in LAB; =2 linearly-anisotropic in LAB). +* NW type of weighting for PN cross section info (=0 P0; =1 P1). +* NIFISS number of fissile isotopes. +* ILEAKS type of leakage calculation: =0 no leakage; =1 homogeneous +* leakage (Diffon); =2 isotropic streaming (Ecco); +* =3 anisotropic streaming (Tibere). +* +*Parameters: output +* VOLMER merged volumes. +* FLXMER merged/condensed averaged fluxes. +* SUNMER merged/condensed production (fission + scattering) cross +* sections. The third dimension is for secondary neutrons. +* SIGT merged/condensed total P0 and P1 cross sections. +* SIGW merged/condensed within-group scattering cross sections. +* DIFF merged/condensed diffusion coefficients. +* ZLEAK merged/condensed DB2 leakage rates. +* OUTG merged/condensed leakage rates. +* ALB physical albedos. +* LFISS fission flag in mergeg zones. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMACR + INTEGER IPRINT,NMERGE,NALBP,NGCOND,ISCAT,NW,NIFISS,ILEAKS + REAL VOLMER(NMERGE),FLXMER(NMERGE,NGCOND), + 1 SUNMER(NMERGE,NGCOND,NGCOND,ISCAT),SIGT(NMERGE,NGCOND,NW+1), + 2 SIGW(NMERGE,NGCOND,ISCAT+1),DIFF(NMERGE,NGCOND), + 3 ZLEAK(NMERGE,NGCOND),OUTG(NGCOND),ALB(NALBP,NGCOND) + LOGICAL LFISS(NMERGE) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + INTEGER ISTATE(NSTATE) + DOUBLE PRECISION ZNUMER,ZLEAKA,ZDENUM + CHARACTER HSIGN*12,SUFF*2,TEXT12*12 + TYPE(C_PTR) JPMACR,KPMACR + INTEGER, ALLOCATABLE, DIMENSION(:) :: NJJ,IJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) :: SIGMA,XSCAT,SIG1 + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: PRODUC +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NJJ(NMERGE),IJJ(NMERGE),IPOS(NMERGE)) + ALLOCATE(PRODUC(NMERGE,NGCOND,NIFISS),SIGMA(NMERGE*NIFISS), + 1 XSCAT(NMERGE*NGCOND)) +*---- +* RECOVER MACROLIB INFORMATION +*---- + CALL LCMGTC(IPMACR,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_MACROLIB') CALL XABORT('SPHMAC: MACROLIB EXPECTED') + CALL LCMGET(IPMACR,'STATE-VECTOR',ISTATE) + IF(ISTATE(1).NE.NGCOND) CALL XABORT('SPHMAC: INVALID NGCOND') + IF(ISTATE(2).NE.NMERGE) CALL XABORT('SPHMAC: INVALID NMERGE') + NL=ISTATE(3) + IF(ISTATE(4).NE.NIFISS) CALL XABORT('SPHMAC: INVALID NIFISS') + IF(NIFISS.EQ.0) CALL XABORT('SPHMAC: NO FISSILE ZONES') + ITRANC=ISTATE(6) + ILEAK=ISTATE(9) + IF(MAX(1,ISTATE(10)).NE.NW) CALL XABORT('SPHMAC: INVALID NW') +*---- +* SET OUTPUT INFORMATION TO ZERO +*---- + PRODUC(:NMERGE,:NGCOND,:NIFISS)=0.0 + FLXMER(:NMERGE,:NGCOND)=0.0 + SUNMER(:NMERGE,:NGCOND,:NGCOND,:ISCAT)=0.0 + SIGT(:NMERGE,:NGCOND,:NW+1)=0.0 + SIGW(:NMERGE,:NGCOND,:ISCAT+1)=0.0 + DIFF(:NMERGE,:NGCOND)=0.0 + ZLEAK(:NMERGE,:NGCOND)=0.0 + LFISS(:NMERGE)=.FALSE. +*---- +* RECOVER FLUX AND COMPUTE THE FISSION RATE INFORMATION +*---- + ZNUMER=0.0D0 + ZLEAKA=0.0D0 + ZDENUM=0.0D0 + CALL LCMGET(IPMACR,'VOLUME',VOLMER) + IF(NALBP.GT.0) CALL LCMGET(IPMACR,'ALBEDO',ALB) + JPMACR=LCMGID(IPMACR,'GROUP') + DO 40 IGR=1,NGCOND + KPMACR=LCMGIL(JPMACR,IGR) + CALL LCMLEN(KPMACR,'FLUX-INTG',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.0) CALL XABORT('SPHMAC: MISSING FLUX-INTG INFO') + CALL LCMGET(KPMACR,'FLUX-INTG',FLXMER(1,IGR)) + CALL LCMLEN(KPMACR,'NUSIGF',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'NUSIGF',SIGMA(1)) + DO 35 IFIS=1,NIFISS + DO 30 IBM=1,NMERGE + SS=FLXMER(IBM,IGR)*SIGMA((IFIS-1)*NMERGE+IBM) + PRODUC(IBM,IGR,IFIS)=PRODUC(IBM,IGR,IFIS)+SS + ZNUMER=ZNUMER+SS + 30 CONTINUE + 35 CONTINUE + ENDIF + 40 CONTINUE +*---- +* RECOVER EIGENVALUES +*---- + CALL LCMLEN(IPMACR,'K-EFFECTIVE',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.1) THEN + CALL LCMGET(IPMACR,'K-EFFECTIVE',EIGENK) + ELSE + EIGENK=1.0 + ENDIF + IF(IPRINT.GT.5) WRITE(6,'(/16H SPHMAC: EIGENK=,1P,E12.4)') EIGENK + CALL LCMLEN(IPMACR,'B2 B1HOM',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.1) THEN + CALL LCMGET(IPMACR,'B2 B1HOM',B2) + ELSE + B2=0.0 + ENDIF + IF(IPRINT.GT.5) WRITE(6,'(/12H SPHMAC: B2=,1P,E12.4)') B2 +*---- +* RECOVER MERGED/CONDENSED CROSS SECTIONS +*---- + DO 175 IGR=1,NGCOND + KPMACR=LCMGIL(JPMACR,IGR) + CALL LCMLEN(KPMACR,'NTOT0',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'NTOT0',SIGMA(1)) + ELSE + CALL XABORT('SPHMAC: MISSING NTOT0 INFO') + ENDIF + IF(ITRANC.NE.0) THEN +* TRANSPORT CORRECTION. + ALLOCATE(SIG1(NMERGE)) + CALL LCMGET(KPMACR,'TRANC',SIG1) + DO 45 IBM=1,NMERGE + SIGMA(IBM)=SIGMA(IBM)-SIG1(IBM) + 45 CONTINUE + DEALLOCATE(SIG1) + ENDIF + DO 50 IBM=1,NMERGE + ZDENUM=ZDENUM+SIGMA(IBM)*FLXMER(IBM,IGR) + 50 CONTINUE + IF(ILEAKS.EQ.1) THEN + CALL LCMLEN(KPMACR,'DIFF',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.0) CALL XABORT('SPHMAC: UNABLE TO RECOVER DIFF R' + > //'ECORDS IN THE MACROLIB OBJECT.') + CALL LCMGET(KPMACR,'DIFF',DIFF(1,IGR)) + ENDIF + DO 60 IBM=1,NMERGE + IF(ILEAKS.EQ.1) THEN + ZLEAK(IBM,IGR)=DIFF(IBM,IGR)*B2*FLXMER(IBM,IGR) + ELSE IF(ILEAKS.GT.1) THEN + CALL XABORT('SPHMAC: LEAKAGE MODEL NOT IMPLEMENTED') + ELSE + ZLEAK(IBM,IGR)=0.0 + ENDIF + SIGT(IBM,IGR,1)=SIGMA(IBM) + ZLEAKA=ZLEAKA+ZLEAK(IBM,IGR) + 60 CONTINUE +* + CALL LCMLEN(KPMACR,'CHI',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + DO 75 IFIS=1,NIFISS + CALL LCMGET(KPMACR,'CHI',SIGMA(1)) + DO 70 IBM=1,NMERGE + DO 65 JGR=1,NGCOND + SS=SIGMA((IFIS-1)*NMERGE+IBM)*PRODUC(IBM,JGR,IFIS)/EIGENK + IF(SS.NE.0.0) LFISS(IBM)=.TRUE. + SUNMER(IBM,JGR,IGR,1)=SUNMER(IBM,JGR,IGR,1)+SS + 65 CONTINUE + 70 CONTINUE + 75 CONTINUE + ENDIF + DO 90 IW=2,MIN(NW+1,10) + WRITE(TEXT12,'(4HNTOT,I1)') IW-1 + CALL LCMLEN(KPMACR,TEXT12,ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,TEXT12,SIGMA(1)) + DO 80 IBM=1,NMERGE + SIGT(IBM,IGR,IW)=SIGMA(IBM) + 80 CONTINUE + ELSE + DO 85 IBM=1,NMERGE + SIGT(IBM,IGR,IW)=SIGT(IBM,IGR,1) + 85 CONTINUE + ENDIF + 90 CONTINUE +*---- +* PROCESS SCATTERING INFORMATION +*---- + DO 170 INL=1,ISCAT + WRITE(SUFF,'(I2.2)') INL-1 + CALL LCMLEN(KPMACR,'SIGW'//SUFF,ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'SIGW'//SUFF,SIGMA(1)) + ELSE + SIGMA(:NMERGE)=0.0 + ENDIF + IF((ITRANC.NE.0).AND.(INL.EQ.1)) THEN +* TRANSPORT CORRECTION. + ALLOCATE(SIG1(NMERGE)) + CALL LCMGET(KPMACR,'TRANC',SIG1) + DO 120 IBM=1,NMERGE + SIGMA(IBM)=SIGMA(IBM)-SIG1(IBM) + 120 CONTINUE + DEALLOCATE(SIG1) + ENDIF + CALL LCMLEN(KPMACR,'NJJS'//SUFF,ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPMACR,'NJJS'//SUFF,NJJ) + CALL LCMGET(KPMACR,'IJJS'//SUFF,IJJ) + CALL LCMGET(KPMACR,'IPOS'//SUFF,IPOS) + CALL LCMGET(KPMACR,'SCAT'//SUFF,XSCAT) + DO 150 IBM=1,NMERGE + IPO=IPOS(IBM) + DO 130 JGR=IJJ(IBM),IJJ(IBM)-NJJ(IBM)+1,-1 + IF(IGR.EQ.JGR) THEN + SS=SIGMA(IBM)*FLXMER(IBM,JGR) + SIGW(IBM,IGR,INL)=SIGW(IBM,IGR,INL)+SS + ELSE + SS=XSCAT(IPO)*FLXMER(IBM,JGR) + ENDIF + SUNMER(IBM,JGR,IGR,INL)=SUNMER(IBM,JGR,IGR,INL)+SS + IF(INL.EQ.1) ZDENUM=ZDENUM-SS + IPO=IPO+1 + 130 CONTINUE + 150 CONTINUE + ENDIF + 170 CONTINUE + 175 CONTINUE +*---- +* COMPUTE REFERENCE LEAKAGE RATES +*---- + DO 182 IGR=1,NGCOND + OUTG(IGR)=0.0 + DO 181 IBM=1,NMERGE + OUTG(IGR)=OUTG(IGR)-SIGT(IBM,IGR,1)*FLXMER(IBM,IGR)- + 1 ZLEAK(IBM,IGR) + DO 180 JGR=1,NGCOND + OUTG(IGR)=OUTG(IGR)+SUNMER(IBM,JGR,IGR,1) + 180 CONTINUE + 181 CONTINUE + 182 CONTINUE +* + DO 202 INL=1,ISCAT + DO 201 IGR=1,NGCOND + DO 200 IBM=1,NMERGE + IF(VOLMER(IBM).NE.0.0) THEN + SIGW(IBM,IGR,INL)=SIGW(IBM,IGR,INL)/FLXMER(IBM,IGR) + DO 190 JGR=1,NGCOND + SUNMER(IBM,JGR,IGR,INL)=SUNMER(IBM,JGR,IGR,INL)/FLXMER(IBM,JGR) + 190 CONTINUE + ENDIF + 200 CONTINUE + 201 CONTINUE + 202 CONTINUE + DO 215 IGR=1,NGCOND + DO 210 IBM=1,NMERGE + IF(VOLMER(IBM).NE.0.0) THEN + ZLEAK(IBM,IGR)=ZLEAK(IBM,IGR)/FLXMER(IBM,IGR) + FLXMER(IBM,IGR)=FLXMER(IBM,IGR)/VOLMER(IBM) + ENDIF + 210 CONTINUE + 215 CONTINUE +*---- +* PRINT INFORMATION +*---- + IF(IPRINT.GT.4) THEN + WRITE(6,'(/33H SPHMAC: type of PN weighting NW=,I2)') NW + WRITE(6,240) ZNUMER/ZDENUM,ZNUMER/(ZDENUM+ZLEAKA) + WRITE(6,250) 'VOLMER',(VOLMER(IKK),IKK=1,NMERGE) + DO 220 IW=1,NW+1 + WRITE(TEXT12,'(4HNTOT,I1)') IW-1 + WRITE(6,250) TEXT12,((SIGT(IKK,IGR,IW),IKK=1,NMERGE), + > IGR=1,NGCOND) + 220 CONTINUE + WRITE(6,250) 'FLXMER',((FLXMER(IKK,IGR),IKK=1,NMERGE), + > IGR=1,NGCOND) + WRITE(6,250) 'ZLEAK',((ZLEAK(IKK,IGR),IKK=1,NMERGE), + > IGR=1,NGCOND) + IF(NALBP.GT.0) THEN + WRITE(6,250) 'ALBEDO',((ALB(IAL,IGR),IAL=1,NALBP), + > IGR=1,NGCOND) + WRITE(6,250) 'OUTG',(OUTG(IGR),IGR=1,NGCOND) + ENDIF + DO 230 INL=1,ISCAT + WRITE(SUFF,'(I2.2)') INL-1 + WRITE(6,250) 'SIGW'//SUFF,((SIGW(IKK,IGR,INL),IKK=1,NMERGE) + > ,IGR=1,NGCOND) + WRITE(6,250) 'SUNMER'//SUFF,(((SUNMER(IKK,IGR,JGR,INL), + > IKK=1,NMERGE),IGR=1,NGCOND),JGR=1,NGCOND) + 230 CONTINUE + IF(ILEAKS.EQ.1) THEN + WRITE(6,250) 'DIFF',((DIFF(IKK,IGR),IKK=1,NMERGE),IGR=1, + > NGCOND) + ENDIF + WRITE(6,260) 'LFISS',(LFISS(IKK),IKK=1,NMERGE) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XSCAT,SIGMA,PRODUC) + DEALLOCATE(IPOS,IJJ,NJJ) + RETURN +* + 240 FORMAT(/20H SPHMAC: K-INFINITY=,1P,D13.6/8X,12HK-EFFECTIVE=,D13.6, + > 25H (FUNDAMENTAL MODE VALUE)) + 250 FORMAT(/26H SPHMAC: VALUES OF VECTOR ,A,4H ARE/(1X,1P,10E13.5)) + 260 FORMAT(/26H SPHMAC: VALUES OF VECTOR ,A,4H ARE/(1X,20L6)) + END diff --git a/Dragon/src/SPHMOL.f b/Dragon/src/SPHMOL.f new file mode 100644 index 0000000..8813895 --- /dev/null +++ b/Dragon/src/SPHMOL.f @@ -0,0 +1,101 @@ +*DECK SPHMOL + SUBROUTINE SPHMOL(IPMPO,ICAL,NMIL,NGROUP,NSURFD,HEDIT,VOSAP, + & DFACT,VFLUX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover surface flux data from a MPO file generated with APOLLO3. +* +*Copyright: +* Copyright (C) 2024 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* A. Hebert +* +*Parameters: input +* IPMPO pointer to the MPO file. +* ICAL index of the elementary calculation being considered. +* NMIL number of mixtures in the elementary calculation. +* NGROUP number of energy groups in the elementary calculation. +* NSURFD number of surfaces in a mixture. +* HEDIT name of output group for a (multigroup mesh, output geometry) +* couple (generally equal to 'output_0'). +* VOSAP mixture volumes in the MPO file. +* +*Parameters: output +* DFACT discontinuity factors. +* VFLUX averaged volume fluxes. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMPO + INTEGER ICAL,NMIL,NGROUP,NSURFD + REAL VOSAP(NMIL),DFACT(NMIL,NGROUP,NSURFD),VFLUX(NMIL,NGROUP) + CHARACTER(LEN=12) HEDIT +*---- +* LOCAL VARIABLES +*---- + INTEGER RANK,TYPE,TYPE2,DIMSR(5) + CHARACTER RECNAM*80,HSMG*131 +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: VREAL,SURF,LG + REAL, ALLOCATABLE, DIMENSION(:,:) :: SURFLX +*---- +* RECOVER ASSEMBLY DISCONTINUITY FACTORS +*---- + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0,6H/flux/)') + & TRIM(HEDIT),ICAL-1 + CALL hdf5_info(IPMPO,TRIM(RECNAM)//"NSURF",RANK,TYPE,NBYTE,DIMSR) + CALL hdf5_info(IPMPO,TRIM(RECNAM)//"SURFFLUX",RANK,TYPE2,NBYTE, + & DIMSR) + IF((TYPE.EQ.99).OR.(TYPE2.EQ.99)) THEN + CALL hdf5_list(IPMPO,TRIM(RECNAM)) + CALL XABORT('SPHMOL: UNABLE TO FIND ADF INFORMATION.') + ENDIF + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"NSURF",NSURFD) + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"SURFFLUX",SURFLX) + CALL hdf5_info(IPMPO,TRIM(RECNAM)//"SURF",RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.NE.99) THEN + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"SURF",SURF) + IF(DIMSR(1).NE.NMIL*NSURFD) THEN + WRITE(HSMG,'(24HSPHMOL: INVALID LENGTH (,I5,11H) FOR SURF , + & 14HGROUP. LENGTH=,I5,10H EXPECTED.)') DIMSR(1),NSURFD + CALL XABORT(HSMG) + ENDIF + ELSE +* temporary..... + CALL hdf5_read_data(IPMPO,"/geometry/geometry_0/COORDINATE",LG) + ALLOCATE(SURF(NSURFD)) + SURF(:NSURFD)=LG(2) + DEALLOCATE(LG) + ENDIF + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"TOTALFLUX",VREAL) + DO IGR=1,NGROUP + DO IBM=1,NMIL + IOF=(IGR-1)*NMIL+IBM + VFLUX(IBM,IGR)=VREAL(IOF)/VOSAP(IBM) + ENDDO + ENDDO + DO I=1,NSURFD + DO IGR=1,NGROUP + DO IBM=1,NMIL + IOF=(IGR-1)*NMIL+IBM + DFACT(IBM,IGR,I)=SURFLX(I,IOF)/(VFLUX(IBM,IGR)*SURF(I)) + ENDDO + ENDDO + ENDDO + DEALLOCATE(VREAL,SURF,SURFLX) + RETURN + END diff --git a/Dragon/src/SPHMPO.f b/Dragon/src/SPHMPO.f new file mode 100644 index 0000000..64acbf8 --- /dev/null +++ b/Dragon/src/SPHMPO.f @@ -0,0 +1,716 @@ +*DECK SPHMPO + SUBROUTINE SPHMPO(IPMPO,IPMAC,ICAL,IMPX,HEQUI,HMASL,NMIL,NALBP, + 1 NGROUP,HEDIT,VOSAP,ILUPS,SPH,B2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Extract a Macrolib corresponding to an elementary calculation in a +* MPO file +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* A. Hebert +* +*Parameters: input +* IPMPO pointer to the MPO file. +* ICAL index of the elementary calculation being considered. +* IMPX print parameter (equal to zero for no print). +* HEQUI keyword of SPH-factor set to be recovered. +* HMASL keyword of MASL data set to be recovered. +* NMIL number of mixtures in the elementary calculation. +* NALBP number of physical albedos per energy group. +* NGROUP number of energy groups in the elementary calculation. +* HEDIT name of output group for a (multigroup mesh, output geometry) +* couple (generally equal to 'output_0'). +* VOSAP mixture volumes in the MPO file. +* ILUPS up-scattering removing flag (=1 to remove up-scattering from +* output cross-sections). +* B2 imposed buckling. +* +*Parameters: output +* IPMAC pointer to the Macrolib (L_MACROLIB signature). +* SPH SPH-factor set extracted from the MPO file. +* B2 buckling recovered from MPO file. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMPO,IPMAC + INTEGER ICAL,IMPX,NMIL,NALBP,NGROUP,ILUPS + REAL VOSAP(NMIL),SPH(NMIL+NALBP,NGROUP),B2 + CHARACTER(LEN=80) HEQUI,HMASL + CHARACTER(LEN=12) HEDIT +*---- +* LOCAL VARIABLES +*---- + INTEGER, PARAMETER::NSTATE=40 + INTEGER ISTATE(NSTATE) + INTEGER I,NADDRXS,NREA,NISO,NISOM,ADDRZX,ADDRZI,IBM,ISO,ISOM, + & NBISO,NBYTE,RANK,TYPE,DIMSR(5),NL,ILOC,NLOC,IPROF,JOFS,NL1, + & NL2,IPRC,NPRC,IOF,IGR,JGR,ITRANC,NED,IFISS,IGMAX,IGMIN, + & IPOSDE,IL,IREA,NSURFD,IDF,NALBP2,TYPE2,TYPE4,NITMA + REAL FLOTT,DEN,ZIL,FF,CSCAT + LOGICAL LSPH,LMASL,LSTRD,LDIFF,LHFACT,LNEW + CHARACTER RECNAM*80,RECNA2*80,TEXT12*12,CM*2,HSMG*131 + TYPE(C_PTR) JPMAC,KPMAC +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: REACTION,ISOTOPE,IDATAP, + & ADDRISO,LOCAD,FAG,ADR + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: ADDRXS + REAL, ALLOCATABLE, DIMENSION(:) :: FLUXS,CONCEN,RDATAX,RVALO, + & FMASL,LAMBDAD,BETADF,INVEL,LAMB,VREAL + REAL, ALLOCATABLE, DIMENSION(:,:) :: NWT0,EFACT,CHID,SIGS0,TOTAL, + & DIFF,BETAR,INVELS,DISFAC,ALBP,VFLUX + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: XS,SIGS,CHIRS,ALBP_ERM, + & SFLUX + REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: SS2D + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HEDI,HADF + CHARACTER(LEN=24), ALLOCATABLE, DIMENSION(:) :: TEXT24,NOMREA, + & NOMISO + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LXS + CHARACTER(LEN=80), ALLOCATABLE, DIMENSION(:) :: LOCTYP,LOCKEY + INTEGER, ALLOCATABLE, DIMENSION(:) :: IPOS,NJJM,IJJM + REAL, ALLOCATABLE, DIMENSION(:) :: SCAT,GAR +*---- +* SCRATCH STORAGE ALLOCATION +* SIGS0 P0 scattering cross sections. +* TOTAL total cross sections. +* DIFF diffusion coefficients. +* FMASL heavy element mass. +*---- + ALLOCATE(IPOS(NMIL),NJJM(NMIL),IJJM(NMIL)) + ALLOCATE(SIGS0(NMIL,NGROUP),TOTAL(NMIL,NGROUP),DIFF(NMIL,NGROUP), + & FMASL(NMIL)) + SIGS0(:NMIL,:NGROUP)=0.0 + TOTAL(:NMIL,:NGROUP)=0.0 + DIFF(:NMIL,:NGROUP)=0.0 + FMASL(:NMIL)=0.0 +*---- +* RECOVER MPO FILE CHARACTERISTICS +*---- + WRITE(RECNAM,'(8H/output/,A,6H/info/)') TRIM(HEDIT) + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"NADDRXS",NADDRXS) + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"NREA",NREA) + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"NISO",NISO) + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"ADDRXS",ADDRXS) + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"REACTION",REACTION) + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"ISOTOPE",ISOTOPE) + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"TRANSPROFILE",IDATAP) + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"ADDRISO",ADDRISO) + NBISO=ADDRISO(SIZE(ADDRISO,1)) + IF(NBISO.EQ.0) CALL XABORT('SPHMPO: NO CROSS SECTIONS.') + ALLOCATE(NOMREA(NREA),NOMISO(NBISO)) + CALL hdf5_read_data(IPMPO,"contents/reactions/REACTIONAME",TEXT24) + DO I=1,NREA + NOMREA(I)=TEXT24(REACTION(I)+1) + ENDDO + DEALLOCATE(TEXT24) + CALL hdf5_read_data(IPMPO,"contents/isotopes/ISOTOPENAME",TEXT24) + DO I=1,NBISO + NOMISO(I)=TEXT24(ISOTOPE(I)+1) + ENDDO + DEALLOCATE(TEXT24) + IF(IMPX.GT.1) THEN + WRITE(6,'(/24H SPHMPO: reaction names:)') + DO I=1,NREA + WRITE(6,'(5X,7HNOMREA(,I3,2H)=,A)') I,TRIM(NOMREA(I)) + ENDDO + WRITE(6,'(/23H SPHMPO: isotope names:)') + DO I=1,NBISO + WRITE(6,'(5X,7HNOMISO(,I3,2H)=,A)') I,TRIM(NOMISO(I)) + ENDDO + WRITE(6,'(/34H SPHMPO: number of energy groups =,I4)') NGROUP + WRITE(6,'(30H SPHMPO: number of mixtures =,I4)') NMIL + WRITE(6,'(30H SPHMPO: number of reactions =,I4)') NREA + WRITE(6,'(30H SPHMPO: number of isotopes =,I4)') NBISO + ENDIF + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0)') TRIM(HEDIT),ICAL-1 + IF(.not.hdf5_group_exists(IPMPO,TRIM(RECNAM))) THEN + WRITE(HSMG,'(38HSPHMPO: missing elementary calculation,I5, + & 10H in group ,A,1H.)') ICAL,TRIM(HEDIT) + CALL XABORT(HSMG) + ENDIF +*---- +* SET EQUIVALENCE AND HEAVY DENSITY FLAGS. +*---- + LSPH=.FALSE. + LMASL=.FALSE. + NLOC=0 + IF(hdf5_group_exists(IPMPO,"/local_values/")) THEN + CALL hdf5_read_data(IPMPO,"local_values/LOCVALTYPE",LOCTYP) + CALL hdf5_read_data(IPMPO,"local_values/LOCVALNAME",LOCKEY) + NLOC=SIZE(LOCTYP,1) + DO ILOC=1,NLOC + LSPH=LSPH.OR.((LOCTYP(ILOC).EQ.'EQUI').AND. + & (LOCKEY(ILOC).EQ.HEQUI)) + LMASL=LMASL.OR.((LOCTYP(ILOC).EQ.'HEAVY_METAL_DENSITY').AND. + & (LOCKEY(ILOC).EQ.HMASL)) + ENDDO + ENDIF +*---- +* FIND SCATTERING ANISOTROPY. +*---- + NL=0 + DO I=1,NADDRXS + DO ISO=1,NISO + NL=MAX(NL,ADDRXS(NREA+1,ISO,I)) + NL=MAX(NL,ADDRXS(NREA+2,ISO,I)) + ENDDO + ENDDO + IF(IMPX.GT.1) THEN + WRITE(6,'(37H SPHMPO: number of legendre orders =,I4)') NL + ENDIF +*---- +* RECOVER GENERAL INFORMATION +*---- + LSTRD=(B2.EQ.0.0) + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0,8H/addons/)') + & TRIM(HEDIT),ICAL-1 + CALL hdf5_info(IPMPO,TRIM(RECNAM)//"KEFF",RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.NE.99) THEN + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"KEFF",FLOTT) + CALL LCMPUT(IPMAC,'K-EFFECTIVE',1,2,FLOTT) + IF(IMPX.GT.1) THEN + WRITE(6,'(22H SPHMPO: K-EFFECTIVE =,1P,E13.6)') FLOTT + ENDIF + ENDIF + CALL hdf5_info(IPMPO,TRIM(RECNAM)//"KINF",RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.NE.99) THEN + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"KINF",FLOTT) + CALL LCMPUT(IPMAC,'K-INFINITY',1,2,FLOTT) + IF(IMPX.GT.1) THEN + WRITE(6,'(21H SPHMPO: K-INFINITY =,1P,E13.6)') FLOTT + ENDIF + ENDIF + CALL hdf5_info(IPMPO,TRIM(RECNAM)//"B2",RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.NE.99) THEN + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"B2",B2) + LSTRD=(B2.EQ.0.0) + CALL LCMPUT(IPMAC,'B2 B1HOM',1,2,B2) + IF(IMPX.GT.1) THEN + WRITE(6,'(13H SPHMPO: B2 =,1P,E14.6)') B2 + ENDIF + ENDIF +*---- +* SET NSURFD +*---- + IDF=0 + NSURFD=0 + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0,7H/zone_0, + & 15H/discontinuity/)') TRIM(HEDIT),ICAL-1 + LNEW=hdf5_group_exists(IPMPO,TRIM(RECNAM)) + IF(LNEW) THEN +* new specification + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"NSURF",NSURFD) + ELSE +* old specification + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0,12H/flux/NSURF/)') + & TRIM(HEDIT),ICAL-1 + CALL hdf5_info(IPMPO,TRIM(RECNAM),RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.NE.99) CALL hdf5_read_data(IPMPO,TRIM(RECNAM),NSURFD) + ENDIF + IF(NSURFD.EQ.0) GO TO 10 +*---- +* RECOVER DISCONTINUITY FACTOR INFORMATION +*---- + IF(LNEW) THEN +* new specification + ALLOCATE(SFLUX(NMIL,NGROUP**2,NSURFD),VFLUX(NMIL,NGROUP)) + DO IBM=1,NMIL + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0,6H/zone_,I0,1H/)') + & TRIM(HEDIT),ICAL-1,IBM-1 + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"ZONEFLUX",VREAL) + VFLUX(IBM,:NGROUP)=VREAL(:NGROUP)/VOSAP(IBM) + DEALLOCATE(VREAL) + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0,6H/zone_,I0, + & 15H/discontinuity/)') TRIM(HEDIT),ICAL-1,IBM-1 + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"NSURF",NITMA) + IF(NITMA.NE.NSURFD) THEN + WRITE(HSMG,'(32HSPHMPO: THE NUMBER OF SURFACES (,I5, + & 12H) IN MIXTURE,I5,31H IS DIFFERENT FROM THE NUMBER (,I5, + & 15H) IN MIXTURE 1.)') NITMA,IBM,NSURFD + CALL XABORT(HSMG) + ENDIF + CALL hdf5_info(IPMPO,TRIM(RECNAM)//"DFACTOR",RANK,TYPE2, + & NBYTE,DIMSR) + CALL hdf5_info(IPMPO,TRIM(RECNAM)//"DFACTORGxG",RANK,TYPE4, + & NBYTE,DIMSR) + IF(TYPE2.NE.99) THEN + IDF=3 ! discontinuity factor information + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"DFACTOR",DISFAC) + DO I=1,NSURFD + SFLUX(IBM,:NGROUP,I)=DISFAC(I,:NGROUP) + ENDDO + DEALLOCATE(DISFAC) + ELSE IF(TYPE4.NE.99) THEN + IDF=4 ! matrix discontinuity factor information + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"DFACTORGxG",DISFAC) + DO I=1,NSURFD + SFLUX(IBM,:NGROUP**2,I)=DISFAC(I,:NGROUP**2) + ENDDO + DEALLOCATE(DISFAC) + ELSE + CALL hdf5_list(IPMPO,TRIM(RECNAM)) + CALL XABORT('SPHMPO: UNABLE TO SET TYPE OF DF.') + ENDIF + ENDDO + ELSE +* old specification + ALLOCATE(SFLUX(NMIL,NGROUP,NSURFD),VFLUX(NMIL,NGROUP)) + IDF=3 ! discontinuity factor information + CALL SPHMOL(IPMPO,ICAL,NMIL,NGROUP,NSURFD,HEDIT,VOSAP,SFLUX, + 1 VFLUX) + ENDIF +*---- +* WRITE DISCONTINUITY FACTOR INFORMATION ON IPMAC +*---- + CALL LCMSIX(IPMAC,'ADF',1) + CALL LCMPUT(IPMAC,'NTYPE',1,1,NSURFD) + CALL LCMPUT(IPMAC,'AVG_FLUX',NMIL*NGROUP,2,VFLUX) + ALLOCATE(HADF(NSURFD)) + IF((IDF.EQ.2).OR.(IDF.EQ.3)) THEN + DO I=1,NSURFD + WRITE(HADF(I),'(3HFD_,I5.5)') I + CALL LCMPUT(IPMAC,HADF(I),NMIL*NGROUP,2,SFLUX(1,1,I)) + ENDDO + ELSE IF(IDF.EQ.4) THEN + DO I=1,NSURFD + WRITE(HADF(I),'(3HFD_,I5.5)') I + CALL LCMPUT(IPMAC,HADF(I),NMIL*NGROUP**2,2,SFLUX(1,1,I)) + ENDDO + ENDIF + CALL LCMPTC(IPMAC,'HADF',8,NSURFD,HADF) + DEALLOCATE(VFLUX,SFLUX) + CALL LCMSIX(IPMAC,' ',2) +*---- +* RECOVER ALBEDO INFORMATION +*---- + 10 WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0,6H/flux/)') + & TRIM(HEDIT),ICAL-1 + CALL hdf5_info(IPMPO,TRIM(RECNAM)//"ALBEDO",RANK,TYPE,NBYTE, + & DIMSR) + IF(TYPE.NE.99) THEN + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"NALBP",NALBP2) + IF(NALBP2.NE.NALBP) CALL XABORT('SPHMPO: INVALID NALBP(1).') + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"ALBEDO",ALBP) + CALL LCMPUT(IPMAC,'ALBEDO',NALBP*NGROUP,2,ALBP) + DEALLOCATE(ALBP) + ENDIF + CALL hdf5_info(IPMPO,TRIM(RECNAM)//"ALBEDOGxG",RANK,TYPE,NBYTE, + & DIMSR) + IF(TYPE.NE.99) THEN + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"NALBP",NALBP2) + IF(NALBP2.NE.NALBP) CALL XABORT('SPHMPO: INVALID NALBP(2).') + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"ALBEDOGxG",ALBP_ERM) + CALL LCMPUT(IPMAC,'ALBEDO',NALBP*NGROUP*NGROUP,2,ALBP_ERM) + DEALLOCATE(ALBP_ERM) + ENDIF +*---- +* ALLOCATE MACROLIB WORKING ARRAYS. +*---- + ALLOCATE(LXS(NREA),NWT0(NMIL,NGROUP),EFACT(NMIL,NGROUP), + 1 SIGS(NMIL,NGROUP,NL),SS2D(NMIL,NGROUP,NGROUP,NL), + 2 XS(NMIL,NGROUP,NREA),FAG(NGROUP),ADR(NGROUP)) + NWT0(:NMIL,:NGROUP)=0.0 + EFACT(:NMIL,:NGROUP)=0.0 + SIGS(:NMIL,:NGROUP,:NL)=0.0 + SS2D(:NMIL,:NGROUP,:NGROUP,:NL)=0.0 + XS(:NMIL,:NGROUP,:NREA)=0.0 + LXS(:NREA)=.FALSE. + LDIFF=.FALSE. +*---- +* ALLOCATE DELAYED NEUTRON WORKING ARRAYS. +*---- + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0, + & 24H/zone_0/kinetics/LAMBDAD)') TRIM(HEDIT),ICAL-1 + NPRC=0 + CALL hdf5_info(IPMPO,TRIM(RECNAM),RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.NE.99) NPRC=DIMSR(1) + IF(IMPX.GT.1) THEN + WRITE(6,'(37H SPHMPO: number of precursor groups =,I4)') NPRC + ENDIF + ALLOCATE(LAMB(NPRC),CHIRS(NGROUP,NPRC,NMIL),BETAR(NPRC,NMIL), + & INVELS(NGROUP,NMIL)) + LAMB(:NPRC)=0.0 + CHIRS(:NGROUP,:NPRC,:NMIL)=0.0 + BETAR(:NPRC,:NMIL)=0.0 + INVELS(:NGROUP,:NMIL)=0.0 +*---- +* LOOP OVER MPO MIXTURES +*---- + DO IBM=1,NMIL + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0,6H/zone_,I0,1H/)') + & TRIM(HEDIT),ICAL-1,IBM-1 + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"ZONEFLUX",FLUXS) + DO I=1,NGROUP + NWT0(IBM,I)=NWT0(IBM,I)+FLUXS(I) + ENDDO + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"ADDRZI",ADDRZI) + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"ADDRZX",ADDRZX) + NISOM=ADDRISO(ADDRZI+2)-ADDRISO(ADDRZI+1) + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"CONCENTRATION",CONCEN) + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"CROSSECTION",RDATAX) + DO ISOM=1,NISOM + ! loop over the isotopes present in the mix + NL1=ADDRXS(NREA+1,ISOM,ADDRZX+1) + NL2=ADDRXS(NREA+2,ISOM,ADDRZX+1) + IF((NL1.GT.NL).OR.(NL2.GT.NL)) THEN + CALL XABORT('SPHMPO: NL OVERFLOW.') + ENDIF + DEN=CONCEN(ISOM) + IF(DEN.NE.0.0) THEN + IF(IMPX.GT.3) THEN + ISO=ADDRISO(ADDRZI+1)+ISOM + WRITE(6,'(10H mixture=,I5,15H concentration(,A,2H)=,1P, + & E12.4)') IBM,TRIM(NOMISO(ISO)),DEN + ENDIF + DO IREA=1,NREA + IOF=ADDRXS(IREA,ISOM,ADDRZX+1) + IF(IOF.LT.0) CYCLE + IF(NOMREA(IREA).EQ.'Diffusion') THEN + DO IL=1,NL1 + DO IGR=1,NGROUP + FLOTT=DEN*RDATAX(IOF+(IL-1)*NGROUP+IGR) + SIGS(IBM,IGR,IL)=SIGS(IBM,IGR,IL)+FLOTT + LXS(IREA)=LXS(IREA).OR.(FLOTT.NE.0.0) + ENDDO + ENDDO + ELSE IF(NOMREA(IREA).EQ.'Scattering') THEN + IPROF=ADDRXS(NREA+3,ISOM,ADDRZX+1) + DO IGR=1,NGROUP + FAG(IGR)=IDATAP(IPROF+IGR)+1 + ADR(IGR)=IDATAP(IPROF+NGROUP+IGR) + ENDDO + ADR(NGROUP+1)=IDATAP(IPROF+1+2*NGROUP) + JOFS=0 + DO IL=1,NL2 + ZIL=REAL(2*IL-1) + DO IGR=1,NGROUP + DO JGR=FAG(IGR),FAG(IGR)+(ADR(IGR+1)-ADR(IGR))-1 + IF(JGR.GT.NGROUP) CALL XABORT('SPHMPO: SS2D OVER' + & //'FLOW.') + FLOTT=DEN*RDATAX(IOF+JOFS+1)/ZIL + SS2D(IBM,JGR,IGR,IL)=SS2D(IBM,JGR,IGR,IL)+FLOTT ! JGR <-- IGR + JOFS=JOFS+1 + LXS(IREA)=LXS(IREA).OR.(FLOTT.NE.0.0) + ENDDO + ENDDO + ENDDO + ELSE IF(NOMREA(IREA).EQ.'FissionSpectrum') THEN + DO IGR=1,NGROUP + XS(IBM,IGR,IREA)=RDATAX(IOF+IGR) + LXS(IREA)=LXS(IREA).OR.(RDATAX(IOF+IGR).NE.0.0) + ENDDO + ELSE + DO IGR=1,NGROUP + XS(IBM,IGR,IREA)=XS(IBM,IGR,IREA)+DEN*RDATAX(IOF+IGR) + LXS(IREA)=LXS(IREA).OR.(DEN*RDATAX(IOF+IGR).NE.0.0) + ENDDO + ENDIF + ENDDO ! end of loop over reactions + ENDIF + ENDDO ! end of loop over isotopes + DEALLOCATE(RDATAX,CONCEN,FLUXS) +* + IF(hdf5_group_exists(IPMPO,TRIM(RECNAM)//"kinetics")) THEN + WRITE(RECNA2,'(A,9Hkinetics/)') TRIM(RECNAM) + CALL hdf5_list(IPMPO,TRIM(RECNA2)) + CALL hdf5_read_data(IPMPO,TRIM(RECNA2)//"LAMBDAD",LAMBDAD) + IF(SIZE(LAMBDAD,1).NE.NPRC) CALL XABORT('SPHMPO: WRONG NPRC.') + CALL hdf5_read_data(IPMPO,TRIM(RECNA2)//"CHID",CHID) + CALL hdf5_read_data(IPMPO,TRIM(RECNA2)//"BETADF",BETADF) + CALL hdf5_read_data(IPMPO,TRIM(RECNA2)//"INVERSESPEED",INVEL) + CHIRS(:NGROUP,:NPRC,IBM)=CHID(:NGROUP,:NPRC) + BETAR(:NPRC,IBM)=BETADF(:NPRC) + INVELS(:NGROUP,IBM)=INVEL(:NGROUP) + DEALLOCATE(INVEL,BETADF,CHID,LAMBDAD) + ENDIF +* +* UP-SCATTERING CORRECTION OF THE MACROLIB. + IF(ILUPS.EQ.1) THEN + DO JGR=2,NGROUP + DO IGR=1,JGR-1 ! IGR < JGR + FF=NWT0(IBM,JGR)/NWT0(IBM,IGR) + CSCAT=SS2D(IBM,IGR,JGR,1) ! IGR < JGR + DO IL=1,NL + CSCAT=SS2D(IBM,IGR,JGR,IL) + SIGS(IBM,IGR,IL)=SIGS(IBM,IGR,IL)-CSCAT*FF + SIGS(IBM,JGR,IL)=SIGS(IBM,JGR,IL)-CSCAT + SS2D(IBM,JGR,IGR,IL)=SS2D(IBM,JGR,IGR,IL)-CSCAT*FF + SS2D(IBM,IGR,JGR,IL)=0.0 + ENDDO + ENDDO + ENDDO + ENDIF +* + IF(LSPH) THEN + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"LOCALVALUE",RVALO) + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"LOCALVALADDR",LOCAD) + DO ILOC=1,NLOC + IF((LOCTYP(ILOC).EQ.'EQUI').AND.(LOCKEY(ILOC).EQ.HEQUI)) + & THEN + IF(LOCAD(ILOC+1)-LOCAD(ILOC).NE.NGROUP) THEN + CALL XABORT('SPHMPO: INVALID NUMBER OF COMPONENTS FOR ' + & //'SPH FACTORS') + ENDIF + DO IGR=1,NGROUP + SPH(IBM,IGR)=RVALO(LOCAD(ILOC)+IGR-1) + ENDDO + ENDIF + ENDDO + DEALLOCATE(LOCAD,RVALO) + ELSE + SPH(IBM,:NGROUP)=1.0 + ENDIF + IF(LMASL) THEN + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"LOCALVALUE",RVALO) + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"LOCALVALADDR",LOCAD) + DO ILOC=1,NLOC + IF((LOCTYP(ILOC).EQ.'HEAVY_METAL_DENSITY').AND. + & (LOCKEY(ILOC).EQ.HMASL)) THEN + IF(LOCAD(ILOC+1)-LOCAD(ILOC).NE.1) THEN + CALL XABORT('SPHMPO: INVALID NUMBER OF COMPONENTS FOR ' + & //'HEAVY_METAL_DENSITY') + ENDIF + FMASL(IBM)=RVALO(LOCAD(ILOC)) + ENDIF + ENDDO + DEALLOCATE(RVALO) + ENDIF +*---- +* RECOVER DIFFUSION COEFFICIENT INFORMATION +*---- + IF(hdf5_group_exists(IPMPO,TRIM(RECNAM)//"leakage")) THEN + CALL hdf5_info(IPMPO,TRIM(RECNAM)//"leakage/DIFFCOEF",RANK, + & TYPE,NBYTE,DIMSR) + IF(TYPE.NE.99) THEN + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"leakage/DIFFCOEF", + & VREAL) + DO IGR=1,NGROUP + DIFF(IBM,IGR)=VREAL(IGR) + ENDDO + DEALLOCATE(VREAL) + LDIFF=.TRUE. + LSTRD=.FALSE. + GO TO 20 + ENDIF + CALL hdf5_info(IPMPO,TRIM(RECNAM)//"leakage/DB2",RANK,TYPE, + & NBYTE,DIMSR) + IF(TYPE.NE.99) THEN + CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"leakage/DB2",VREAL) + DO IGR=1,NGROUP + DIFF(IBM,IGR)=VREAL(IGR)/B2 + ENDDO + DEALLOCATE(VREAL) + LDIFF=.TRUE. + LSTRD=.FALSE. + ENDIF + ENDIF + 20 CONTINUE + ENDDO ! end of loop over mixtures + IF(NALBP.GT.0) THEN + SPH(NMIL+1:NMIL+NALBP,:NGROUP)=1.0 ! assigned to albedo function + ENDIF + DEALLOCATE(ADDRISO,IDATAP,ISOTOPE,REACTION,ADDRXS) +*---- +* IDENTIFY SPECIAL FLUX EDITS +*---- + ALLOCATE(HEDI(NREA)) + NED=0 + DO IREA=1,NREA + IF((NOMREA(IREA).EQ.'Total').or. + & (NOMREA(IREA).EQ.'Absorption').or. + & (NOMREA(IREA).EQ.'CaptureEnergyCapture').or. + & (NOMREA(IREA).EQ.'Diffusion').or. + & (NOMREA(IREA).EQ.'FissionEnergyFission').or. + & (NOMREA(IREA).EQ.'FissionSpectrum').or. + & (NOMREA(IREA).EQ.'NuFission').or. + & (NOMREA(IREA).EQ.'Scattering')) CYCLE + NED=NED+1 + IF(NOMREA(IREA).EQ.'Fission') THEN + HEDI(NED)='NFTOT' + ELSE + HEDI(NED)=NOMREA(IREA)(:8) + ENDIF + ENDDO +*---- +* STORE MACROLIB. +*---- + CALL LCMPUT(IPMAC,'VOLUME',NMIL,2,VOSAP) + IF(LMASL) CALL LCMPUT(IPMAC,'MASL',NMIL,2,FMASL) + IFISS=0 + ITRANC=0 + LHFACT=.FALSE. + ALLOCATE(VREAL(NMIL)) + JPMAC=LCMLID(IPMAC,'GROUP',NGROUP) + DO IGR=1,NGROUP + KPMAC=LCMDIL(JPMAC,IGR) + CALL LCMPUT(KPMAC,'FLUX-INTG',NMIL,2,NWT0(1,IGR)) + IF(NPRC.GT.0) THEN + DO IBM=1,NMIL + VREAL(IBM)=INVELS(IGR,IBM) + ENDDO + CALL LCMPUT(KPMAC,'OVERV',NMIL,2,VREAL) + ENDIF + DO IREA=1,NREA + IF(.NOT.LXS(IREA)) CYCLE + IF(NOMREA(IREA).EQ.'Absorption') THEN + TOTAL(:,IGR)=TOTAL(:,IGR)+XS(:,IGR,IREA) + ELSE IF(NOMREA(IREA).EQ.'Nexcess') THEN +* correct scattering XS with excess XS + SIGS0(:,IGR)=SIGS0(:,IGR)+XS(:,IGR,IREA) + CALL LCMPUT(KPMAC,'N2N',NMIL,2,XS(1,IGR,IREA)) + ELSE IF(NOMREA(IREA).EQ.'Fission') THEN + CALL LCMPUT(KPMAC,'NFTOT',NMIL,2,XS(1,IGR,IREA)) + ELSE IF(NOMREA(IREA).EQ.'FissionSpectrum') THEN + CALL LCMPUT(KPMAC,'CHI',NMIL,2,XS(1,IGR,IREA)) + DO IPRC=1,NPRC + DO IBM=1,NMIL + VREAL(IBM)=CHIRS(IGR,IPRC,IBM) + ENDDO + WRITE(TEXT12,'(A3,I2.2)') 'CHI',IPRC + CALL LCMPUT(KPMAC,TEXT12,NMIL,2,VREAL) + ENDDO + ELSE IF(NOMREA(IREA).EQ.'NuFission') THEN + IFISS=1 + CALL LCMPUT(KPMAC,'NUSIGF',NMIL,2,XS(1,IGR,IREA)) + DO IPRC=1,NPRC + DO IBM=1,NMIL + VREAL(IBM)=XS(IBM,IGR,IREA)*BETAR(IPRC,IBM) + ENDDO + WRITE(TEXT12,'(A6,I2.2)') 'NUSIGF',IPRC + CALL LCMPUT(KPMAC,TEXT12,NMIL,2,VREAL) + ENDDO + ELSE IF(NOMREA(IREA).EQ.'CaptureEnergyCapture') THEN + LHFACT=.TRUE. + EFACT(:,IGR)=EFACT(:,IGR)+XS(:,IGR,IREA) + ELSE IF(NOMREA(IREA).EQ.'FissionEnergyFission') THEN + LHFACT=.TRUE. + EFACT(:,IGR)=EFACT(:,IGR)+XS(:,IGR,IREA) + ELSE IF(NOMREA(IREA).EQ.'TransportCorrection') THEN + ITRANC=2 + CALL LCMPUT(KPMAC,'TRANC',NMIL,2,XS(1,IGR,IREA)) + ELSE IF(NOMREA(IREA).EQ.'Diffusion') THEN + DO IL=1,NL + WRITE(CM,'(I2.2)') IL-1 + IF(IL.EQ.1) THEN + DO IBM=1,NMIL + SIGS0(IBM,IGR)=SIGS0(IBM,IGR)+SIGS(IBM,IGR,IL) + TOTAL(IBM,IGR)=TOTAL(IBM,IGR)+SIGS(IBM,IGR,IL) + ENDDO + ELSE + CALL LCMPUT(KPMAC,'SIGS'//CM,NMIL,2,SIGS(1,IGR,IL)) + ENDIF + ENDDO + ELSE IF(NOMREA(IREA).EQ.'Scattering') THEN + ALLOCATE(SCAT(NGROUP*NMIL),GAR(NMIL)) + DO IL=1,NL + WRITE(CM,'(I2.2)') IL-1 + IPOSDE=0 + DO IBM=1,NMIL + IPOS(IBM)=IPOSDE+1 + IGMIN=IGR + IGMAX=IGR + DO JGR=NGROUP,1,-1 + IF(SS2D(IBM,IGR,JGR,IL).NE.0.0) THEN + IGMIN=MIN(IGMIN,JGR) + IGMAX=MAX(IGMAX,JGR) + ENDIF + ENDDO + IJJM(IBM)=IGMAX + NJJM(IBM)=IGMAX-IGMIN+1 + DO JGR=IGMAX,IGMIN,-1 + IPOSDE=IPOSDE+1 + SCAT(IPOSDE)=SS2D(IBM,IGR,JGR,IL) ! IGR <-- JGR + ENDDO + GAR(IBM)=SCAT(IPOS(IBM)+IJJM(IBM)-IGR) + ENDDO + CALL LCMPUT(KPMAC,'SCAT'//CM,IPOSDE,2,SCAT) + CALL LCMPUT(KPMAC,'NJJS'//CM,NMIL,1,NJJM) + CALL LCMPUT(KPMAC,'IJJS'//CM,NMIL,1,IJJM) + CALL LCMPUT(KPMAC,'IPOS'//CM,NMIL,1,IPOS) + CALL LCMPUT(KPMAC,'SIGW'//CM,NMIL,2,GAR) + ENDDO + DEALLOCATE(GAR,SCAT) + ELSE + CALL LCMPUT(KPMAC,NOMREA(IREA),NMIL,2,XS(1,IGR,IREA)) + ENDIF + ENDDO ! end of loop over reactions + IF(LSTRD) THEN + IF((ITRANC.EQ.0).AND.(NL.GT.1)) THEN +* Apollo-type transport correction + VREAL(:)=TOTAL(:,IGR)-SIGS(:,IGR,2) + ELSE + VREAL(:)=TOTAL(:,IGR) + ENDIF + DO IBM=1,NMIL + DIFF(IBM,IGR)=1.0/(3.0*VREAL(IBM)) + ENDDO + LDIFF=.TRUE. + ENDIF + IF((ITRANC.EQ.0).AND.(NL.GT.1)) THEN +* Apollo-type transport correction + IF(IGR.EQ.NGROUP) ITRANC=2 + CALL LCMPUT(KPMAC,'TRANC',NMIL,2,SIGS(1,IGR,2)) + ENDIF + IF(LDIFF) CALL LCMPUT(KPMAC,'DIFF',NMIL,2,DIFF(1,IGR)) + IF(LHFACT) CALL LCMPUT(KPMAC,'H-FACTOR',NMIL,2,EFACT(1,IGR)) + ENDDO + DEALLOCATE(VREAL) +*---- +* RELEASE MEMORY +*---- + DEALLOCATE(INVELS,BETAR,CHIRS,LAMB) + DEALLOCATE(ADR,FAG,XS,SS2D,SIGS,EFACT,NWT0,LXS) + DEALLOCATE(NOMISO,NOMREA) +*---- +* SAVE SCATTERING P0 AND TOTAL CROSS SECTION INFO +*---- + DO IGR=1,NGROUP + KPMAC=LCMDIL(JPMAC,IGR) + CALL LCMPUT(KPMAC,'SIGS00',NMIL,2,SIGS0(1,IGR)) + CALL LCMPUT(KPMAC,'NTOT0',NMIL,2,TOTAL(1,IGR)) + ENDDO +*---- +* WRITE STATE VECTOR +*---- + IF(IMPX.GT.1) THEN + WRITE(6,'(32H SPHMPO: fissile isotope index =,I4)') IFISS + WRITE(6,'(37H SPHMPO: transport correction index =,I4)') ITRANC + ENDIF + TEXT12='L_MACROLIB' + CALL LCMPTC(IPMAC,'SIGNATURE',12,TEXT12) + ISTATE(:NSTATE)=0 + ISTATE(1)=NGROUP + ISTATE(2)=NMIL + ISTATE(3)=NL ! 1+scattering anisotropy + ISTATE(4)=IFISS + ISTATE(5)=NED + ISTATE(6)=ITRANC + ISTATE(8)=NALBP + IF(LDIFF) ISTATE(9)=1 + ISTATE(12)=IDF ! ADF information + CALL LCMPUT(IPMAC,'STATE-VECTOR',NSTATE,1,ISTATE) + IF(NED.GT.0) CALL LCMPTC(IPMAC,'ADDXSNAME-P0',8,NED,HEDI) + DEALLOCATE(HEDI) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(FMASL,DIFF,TOTAL,SIGS0) + DEALLOCATE(IJJM,NJJM,IPOS) + RETURN + END diff --git a/Dragon/src/SPHSAP.f b/Dragon/src/SPHSAP.f new file mode 100644 index 0000000..dc279ef --- /dev/null +++ b/Dragon/src/SPHSAP.f @@ -0,0 +1,732 @@ +*DECK SPHSAP + SUBROUTINE SPHSAP(IPSAP,IPMAC,ICAL,IMPX,HEQUI,HMASL,NMIL,NGROUP, + > ILUPS,SPH,B2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Extract a Macrolib corresponding to an elementary calculation in a +* Saphyb. +* +*Copyright: +* Copyright (C) 2011 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPSAP pointer to the Saphyb (L_SAPHYB signature). +* ICAL index of the elementary calculation being considered. +* IMPX print parameter (equal to zero for no print). +* HEQUI keyword of SPH-factor set to be recovered. +* HMASL keyword of MASL data set to be recovered. +* NMIL number of mixtures in the elementary calculation. +* NGROUP number of energy groups in the elementary calculation. +* ILUPS up-scattering removing flag (=1 to remove up-scattering from +* output cross-sections). +* B2 imposed buckling. +* +*Parameters: output +* IPMAC pointer to the Macrolib (L_MACROLIB signature). +* SPH SPH-factor set extracted from the Saphyb. +* B2 buckling recovered from the Saphyb. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSAP,IPMAC + INTEGER ICAL,IMPX,NMIL,NGROUP,ILUPS + REAL SPH(NMIL,NGROUP),B2 + CHARACTER HEQUI*4,HMASL*4 +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40,MAXREA=25,MAXMAC=2,MAXDIV=3,MAXLOC=10) + INTEGER ISTATE(NSTATE),DIMSAP(50) + REAL VALDIV(MAXDIV) + LOGICAL LSTRD,LDIFF,LSPH,LMASL + CHARACTER TEXT12*12,HSMG*131,NOMREA(MAXREA)*12,CM*2, + 1 IDVAL(MAXDIV)*4,LOCTYP(MAXLOC)*4,LOCKEY(MAXLOC)*4,TEXT8*8, + 2 TEXT9*8 + TYPE(C_PTR) JPMAC,KPMAC +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: LOCAD,ISADRX,LENGDX,LENGDP, + 1 IDATA,IHEDI,TOTM,RESM,ISOTS,NOMISO,IPOS,NJJM,IJJM + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: IADRX + REAL, ALLOCATABLE, DIMENSION(:) :: ENER,XVOLM,FLUXS,RDATA,STR,WRK, + 1 SCAT,GAR,RVALO,CONCES,LAMB,SURF,FMASL + REAL, ALLOCATABLE, DIMENSION(:,:) :: NWT0,XSB,SIGS0,SIGSB,SURFLX, + 1 WORK,BETAR,INVELS + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: XS,SIGS,SS2DB,CHIRS + REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: SS2D + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LXS + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HADF + CHARACTER(LEN=20), ALLOCATABLE, DIMENSION(:) :: NOMMIL +*---- +* SCRATCH STORAGE ALLOCATION +* SIGS0 P0 scattering cross sections. +*---- + ALLOCATE(IPOS(NMIL),NJJM(NMIL),IJJM(NMIL),NOMMIL(NMIL)) + ALLOCATE(SIGS0(NMIL,NGROUP),FMASL(NMIL)) + FMASL(:NMIL)=0.0 +*---- +* RECOVER SAPHYB CHARACTERISTICS +*---- + CALL LCMLEN(IPSAP,'DIMSAP',ILENG,ITYLCM) + IF(ILENG.EQ.0) CALL XABORT('SPHSAP: INVALID SAPHYB.') + CALL LCMGET(IPSAP,'DIMSAP',DIMSAP) + IF(NMIL.NE.DIMSAP(7)) THEN + CALL XABORT('SPHSAP: INVALID VALUE OF NMIL.') + ELSE IF(NGROUP.NE.DIMSAP(20)) THEN + CALL XABORT('SPHSAP: INVALID VALUE OF NGROUP.') + ENDIF + NREA=DIMSAP(4) ! number of reactions + NISO=DIMSAP(5) ! number of particularized isotopes + NMAC=DIMSAP(6) ! number of macroscopic sets + NPARL=DIMSAP(11) ! number of local variables + NADRX=DIMSAP(18) ! number of address sets + NCALS=DIMSAP(19) ! number of elementary calculations in the Saphyb + NPRC=DIMSAP(31) ! number of delayed neutron precursor groups + NISOTS=DIMSAP(32) ! number of isotopes in edition tables + IF(IMPX.GT.1) THEN + WRITE(6,'(30H SPHSAP: number of reactions =,I3)') NREA + WRITE(6,'(44H SPHSAP: number of particularized isotopes =,I4)') + 1 NISO + WRITE(6,'(37H SPHSAP: number of macroscopic sets =,I2)') NMAC + WRITE(6,'(29H SPHSAP: number of mixtures =,I5)') NMIL + WRITE(6,'(36H SPHSAP: number of local variables =,I4)') NPARL + WRITE(6,'(33H SPHSAP: number of address sets =,I4)') NADRX + WRITE(6,'(33H SPHSAP: number of calculations =,I5)') NCALS + WRITE(6,'(34H SPHSAP: number of energy groups =,I4)') NGROUP + WRITE(6,'(37H SPHSAP: number of precursor groups =,I4)') NPRC + WRITE(6,'(46H SPHSAP: number of isotopes in output tables =, + 1 I4)') NISOTS + ENDIF + IF(NREA.GT.MAXREA) CALL XABORT('SPHSAP: MAXREA OVERFLOW(1)') + IF(NMAC.GT.MAXMAC) CALL XABORT('SPHSAP: MAXMAC OVERFLOW') + INDX=NISO+NMAC + IF(INDX.EQ.0) CALL XABORT('SPHSAP: NO CROSS SECTIONS FOUND.') +*---- +* RECOVER INFORMATION FROM constphysiq DIRECTORY. +*---- + ALLOCATE(ENER(NGROUP+1)) + CALL LCMSIX(IPSAP,'constphysiq',1) + CALL LCMGET(IPSAP,'ENRGS',ENER) + CALL LCMSIX(IPSAP,' ',2) + DO IGR=1,NGROUP+1 + ENER(IGR)=ENER(IGR)/1.0E-6 + ENDDO + CALL LCMPUT(IPMAC,'ENERGY',NGROUP+1,2,ENER) + DEALLOCATE(ENER) +*---- +* RECOVER INFORMATION FROM contenu DIRECTORY. +*---- + ALLOCATE(TOTM(NMIL),RESM(NMIL)) + CALL LCMSIX(IPSAP,'contenu',1) + IF(NREA.GT.0) THEN + CALL LCMGTC(IPSAP,'NOMREA',12,NREA,NOMREA) + IF(IMPX.GT.1) THEN + WRITE(6,'(29H SPHSAP: Available reactions:/(1X,10A13))') + 1 (NOMREA(I),I=1,NREA) + ENDIF + ENDIF + CALL LCMGET(IPSAP,'TOTMAC',TOTM) + CALL LCMGET(IPSAP,'RESMAC',RESM) + IF(NISO.GT.0) THEN + ALLOCATE(NOMISO(NISO*2)) + CALL LCMGET(IPSAP,'NOMISO',NOMISO) + ENDIF + CALL LCMSIX(IPSAP,' ',2) +*---- +* RECOVER INFORMATION FROM adresses DIRECTORY. +*---- + NL=0 + IF(NADRX.GT.0) THEN + ALLOCATE(IADRX((NREA+2),(NISO+NMAC),NADRX)) + CALL LCMSIX(IPSAP,'adresses',1) + CALL LCMGET(IPSAP,'ADRX',IADRX) + CALL LCMSIX(IPSAP,' ',2) + DO IAD=1,NADRX + DO ISO=1,NISO+NMAC + NL=MAX(NL,IADRX(NREA+1,ISO,IAD)) + NL=MAX(NL,IADRX(NREA+2,ISO,IAD)) + ENDDO + ENDDO + ENDIF + IF(IMPX.GT.1) THEN + WRITE(6,'(36H SPHSAP: number of legendre orders =,I4)') NL + ENDIF +*---- +* RECOVER INFORMATION FROM geom DIRECTORY. +*---- + NSURFD=0 + CALL LCMSIX(IPSAP,'geom',1) + ALLOCATE(XVOLM(NMIL)) + CALL LCMGET(IPSAP,'XVOLMT',XVOLM) + CALL LCMGTC(IPSAP,'NOMMIL',20,NMIL,NOMMIL) + CALL LCMLEN(IPSAP,'outgeom',ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + CALL LCMSIX(IPSAP,'outgeom',1) + CALL LCMLEN(IPSAP,'SURF',NSURFD,ITYLCM) + IF(IMPX.GT.1) THEN + WRITE(6,'(42H SPHSAP: number of discontinuity factors =,I4/)') + 1 NSURFD + ENDIF + CALL LCMSIX(IPSAP,' ',2) + ENDIF + ALLOCATE(SURFLX(NSURFD,NGROUP),SURF(NSURFD)) + IF(NSURFD.GT.0) THEN + CALL LCMSIX(IPSAP,'outgeom',1) + CALL LCMGET(IPSAP,'SURF',SURF) + CALL LCMSIX(IPSAP,' ',2) + ENDIF + CALL LCMSIX(IPSAP,' ',2) +*---- +* RECOVER INFORMATION FROM caldir DIRECTORY. +*---- + WRITE(TEXT12,'(4Hcalc,I8)') ICAL + CALL LCMLEN(IPSAP,TEXT12,ILENG,ITYLCM) + IF(ILENG.EQ.0) THEN + WRITE(HSMG,'(29HSPHSAP: MISSING CALCULATION '',A12,2H''.)') + 1 TEXT12 + CALL XABORT(HSMG) + ENDIF + CALL LCMSIX(IPSAP,TEXT12,1) + CALL LCMSIX(IPSAP,'info',1) + LSPH=.FALSE. + LMASL=.FALSE. + IF(NPARL.GT.0) THEN + CALL LCMGET(IPSAP,'NLOC',NLOC) + IF(NLOC.GT.MAXLOC) CALL XABORT('SPHSAP: MAXLOC OVERFLOW') + CALL LCMGTC(IPSAP,'LOCTYP',4,NLOC,LOCTYP) + CALL LCMGTC(IPSAP,'LOCKEY',4,NLOC,LOCKEY) + ALLOCATE(LOCAD(NLOC+1)) + CALL LCMGET(IPSAP,'LOCADR',LOCAD) + DO ILOC=1,NLOC + LSPH=LSPH.OR.((LOCTYP(ILOC).EQ.'EQUI').AND. + 1 (LOCKEY(ILOC).EQ.HEQUI)) + LMASL=LMASL.OR.((LOCTYP(ILOC).EQ.'MASL').AND. + 1 (LOCKEY(ILOC).EQ.HMASL)) + ENDDO + ENDIF + IF((HEQUI.NE.' ').AND.(.NOT.LSPH)) THEN + WRITE(HSMG,'(46HSPHSAP: UNABLE TO FIND A LOCAL PARAMETER SET O, + 1 25HF TYPE EQUI WITH KEYWORD ,A4,1H.)') HEQUI + CALL XABORT(HSMG) + ELSE IF((HMASL.NE.' ').AND.(.NOT.LMASL)) THEN + WRITE(HSMG,'(46HSPHSAP: UNABLE TO FIND A LOCAL PARAMETER SET O, + 1 25HF TYPE MASL WITH KEYWORD ,A4,1H.)') HMASL + CALL XABORT(HSMG) + ENDIF + ALLOCATE(ISADRX(NMIL),LENGDX(NMIL),LENGDP(NMIL)) + CALL LCMGET(IPSAP,'ISADRX',ISADRX) + CALL LCMGET(IPSAP,'LENGDX',LENGDX) + CALL LCMGET(IPSAP,'LENGDP',LENGDP) + IF(NISOTS.GT.0) THEN + ALLOCATE(ISOTS(NISOTS*2)) + CALL LCMGET(IPSAP,'ISOTS',ISOTS) + ENDIF + CALL LCMSIX(IPSAP,' ',2) + CALL LCMSIX(IPSAP,'divers',1) + CALL LCMLEN(IPSAP,'NVDIV',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + NVDIV=0 + ELSE + CALL LCMGET(IPSAP,'NVDIV',NVDIV) + ENDIF + LSTRD=(B2.EQ.0.0) + IF(NVDIV.GT.0) THEN + IF(NVDIV.GT.MAXDIV) CALL XABORT('SPHSAP: MAXDIV OVERFLOW.') + CALL LCMGTC(IPSAP,'IDVAL',4,NVDIV,IDVAL) + CALL LCMGET(IPSAP,'VALDIV',VALDIV) + DO I=1,NVDIV + IF(IMPX.GT.1) THEN + WRITE(6,'(9H SPHSAP: ,I3,2X,A,1H=,1P,E13.5)') I,IDVAL(I), + 1 VALDIV(I) + ENDIF + IF(IDVAL(I).EQ.'KEFF') THEN + CALL LCMPUT(IPMAC,'K-EFFECTIVE',1,2,VALDIV(I)) + ELSE IF(IDVAL(I).EQ.'KINF') THEN + CALL LCMPUT(IPMAC,'K-INFINITY',1,2,VALDIV(I)) + ELSE IF(IDVAL(I).EQ.'B2') THEN + B2=VALDIV(I) + LSTRD=(B2.EQ.0.0) + CALL LCMPUT(IPMAC,'B2 B1HOM',1,2,VALDIV(I)) + ENDIF + ENDDO + ENDIF + CALL LCMSIX(IPSAP,' ',2) +*---- +* ALLOCATE MACROLIB WORKING ARRAYS. +*---- + ALLOCATE(LXS(NREA),NWT0(NMIL,NGROUP),SIGS(NMIL,NGROUP,NL), + 1 SS2D(NMIL,NGROUP,NGROUP,NL),XS(NMIL,NGROUP,NREA)) + LXS(:NREA)=.FALSE. + NWT0(:NMIL,:NGROUP)=0.0 + SIGS(:NMIL,:NGROUP,:NL)=0.0 + SS2D(:NMIL,:NGROUP,:NGROUP,:NL)=0.0 + XS(:NMIL,:NGROUP,:NREA)=0.0 +*---- +* ALLOCATE DELAYED NEUTRON WORKING ARRAYS. +*---- + ALLOCATE(LAMB(NPRC),CHIRS(NGROUP,NPRC,NMIL),BETAR(NPRC,NMIL), + 1 INVELS(NGROUP,NMIL)) + LAMB(:NPRC)=0.0 + CHIRS(:NGROUP,:NPRC,:NMIL)=0.0 + BETAR(:NPRC,:NMIL)=0.0 + INVELS(:NGROUP,:NMIL)=0.0 + CALL LCMSIX(IPSAP,'divers',1) + CALL LCMLEN(IPSAP,'NPR',ILONG,ITYLCM) + IF((NPRC.GT.0).AND.(ILONG.EQ.1)) THEN + CALL LCMGET(IPSAP,'NPR',NPR) + IF(NPR.NE.NPRC) CALL XABORT('SPHSAP: NPR INCONSISTENCY(1).') + CALL LCMGET(IPSAP,'LAMBRS',LAMB) + DO IBM=1,NMIL + CALL LCMGET(IPSAP,'CHIRS',CHIRS(1,1,IBM)) + CALL LCMGET(IPSAP,'BETARS',BETAR(1,IBM)) + CALL LCMGET(IPSAP,'INVELS',INVELS(1,IBM)) + ENDDO + ENDIF + CALL LCMSIX(IPSAP,' ',2) +*---- +* LOOP OVER SAPHYB MIXTURES. +*---- + IF(NADRX.EQ.0) CALL XABORT('SPHSAP: NO ADDRESS SETS AVAILABLE.') + DO IBM=1,NMIL + WRITE(TEXT12,'(4Hmili,I8)') IBM + CALL LCMLEN(IPSAP,TEXT12,ILENG,ITYLCM) + IF(ILENG.EQ.0) THEN + WRITE(HSMG,'(29HSPHSAP: MISSING MIXTURE '',A12,2H''.)') + 1 TEXT12 + CALL XABORT(HSMG) + ENDIF + CALL LCMSIX(IPSAP,TEXT12,1) + IMAC=TOTM(IBM) + IRES=RESM(IBM) + IAD=ISADRX(IBM) + NDATAX=LENGDX(IBM) + NDATAP=LENGDP(IBM) + ALLOCATE(FLUXS(NGROUP),RDATA(NDATAX),IDATA(NDATAP)) + CALL LCMGET(IPSAP,'FLUXS',FLUXS) + CALL LCMGET(IPSAP,'RDATAX',RDATA) + CALL LCMGET(IPSAP,'IDATAP',IDATA) + DO I=1,NGROUP + NWT0(IBM,I)=NWT0(IBM,I)+FLUXS(I) + ENDDO + ALLOCATE(SIGSB(NGROUP,NL),SS2DB(NGROUP,NGROUP,NL), + 1 XSB(NGROUP,NREA)) + IF(IMAC.NE.0) THEN + CALL SPHSXS(NREA,INDX,NADRX,NGROUP,NL,NDATAX,NDATAP, + 1 NISO+IMAC,IAD,IADRX,RDATA,IDATA,NOMREA,SIGSB,SS2DB,XSB, + 2 LXS) + DO IL=1,NL + DO I=1,NGROUP + SIGS(IBM,I,IL)=SIGS(IBM,I,IL)+SIGSB(I,IL) + ENDDO + ENDDO + DO IL=1,NL + DO J=1,NGROUP + DO I=1,NGROUP + SS2D(IBM,I,J,IL)=SS2D(IBM,I,J,IL)+SS2DB(I,J,IL) + ENDDO + ENDDO + ENDDO + DO IR=1,NREA + DO I=1,NGROUP + XS(IBM,I,IR)=XS(IBM,I,IR)+XSB(I,IR) + ENDDO + ENDDO + ELSE IF(NISO.NE.0) THEN + IF(NISOTS.EQ.0) CALL XABORT('SPHSAP: MISSING CONCES INFO.') + ALLOCATE(CONCES(NISOTS)) + CALL LCMGET(IPSAP,'CONCES',CONCES) + DO ISO=1,NISO + WRITE(TEXT8,'(2A4)') (NOMISO(2*(ISO-1)+I0),I0=1,2) + ISOKEP=0 + DO IS2=1,NISOTS + ISOKEP=IS2 + WRITE(TEXT9,'(2A4)') (ISOTS(2*(IS2-1)+I0),I0=1,2) + IF(TEXT9.EQ.TEXT8) GO TO 10 + ENDDO + CYCLE + 10 DEN=CONCES(ISOKEP) + IF(DEN.NE.0.0) THEN + CALL SPHSXS(NREA,INDX,NADRX,NGROUP,NL,NDATAX,NDATAP,ISO, + 1 IAD,IADRX,RDATA,IDATA,NOMREA,SIGSB,SS2DB,XSB,LXS) + DO IL=1,NL + DO I=1,NGROUP + SIGS(IBM,I,IL)=SIGS(IBM,I,IL)+DEN*SIGSB(I,IL) + ENDDO + ENDDO + DO IL=1,NL + DO J=1,NGROUP + DO I=1,NGROUP + SS2D(IBM,I,J,IL)=SS2D(IBM,I,J,IL)+DEN*SS2DB(I,J,IL) + ENDDO + ENDDO + ENDDO + DO IR=1,NREA + DO I=1,NGROUP + XS(IBM,I,IR)=XS(IBM,I,IR)+DEN*XSB(I,IR) + ENDDO + ENDDO + ENDIF + ENDDO + DEALLOCATE(CONCES) + IF(IRES.NE.0) THEN + CALL SPHSXS(NREA,INDX,NADRX,NGROUP,NL,NDATAX,NDATAP, + 1 NISO+IRES,IAD,IADRX,RDATA,IDATA,NOMREA,SIGSB,SS2DB,XSB, + 2 LXS) + DO IL=1,NL + DO I=1,NGROUP + SIGS(IBM,I,IL)=SIGS(IBM,I,IL)+SIGSB(I,IL) + ENDDO + ENDDO + DO IL=1,NL + DO J=1,NGROUP + DO I=1,NGROUP + SS2D(IBM,I,J,IL)=SS2D(IBM,I,J,IL)+SS2DB(I,J,IL) + ENDDO + ENDDO + ENDDO + DO IR=1,NREA + DO I=1,NGROUP + XS(IBM,I,IR)=XS(IBM,I,IR)+XSB(I,IR) + ENDDO + ENDDO + ENDIF + ELSE + CALL XABORT('SPHSAP: NO MACROSCOPIC SET.') + ENDIF + DEALLOCATE(XSB,SS2DB,SIGSB,IDATA,RDATA,FLUXS) +* +* UP-SCATTERING CORRECTION OF THE MACROLIB. + IF(ILUPS.EQ.1) THEN + IRENT0=0 + IRENT1=0 + DO IREA=1,NREA + IF(NOMREA(IREA).EQ.'TOTALE') IRENT0=IREA + IF(NOMREA(IREA).EQ.'TOTALE P1') IRENT1=IREA + ENDDO + IF(IRENT0.EQ.0) CALL XABORT('SPHSAP: MISSING NTOT0.') + DO JGR=2,NGROUP + DO IGR=1,JGR-1 ! IGR < JGR + FF=NWT0(IBM,JGR)/NWT0(IBM,IGR) + CSCAT=SS2D(IBM,IGR,JGR,1) ! IGR < JGR + XS(IBM,IGR,IRENT0)=XS(IBM,IGR,IRENT0)-CSCAT*FF + XS(IBM,JGR,IRENT0)=XS(IBM,JGR,IRENT0)-CSCAT + IF((IRENT1.GT.0).AND.(NL.GT.1)) THEN + CSCAT=SS2D(IBM,IGR,JGR,2) + XS(IBM,IGR,IRENT1)=XS(IBM,IGR,IRENT1)-CSCAT*FF + XS(IBM,JGR,IRENT1)=XS(IBM,JGR,IRENT1)-CSCAT + ENDIF + DO IL=1,NL + CSCAT=SS2D(IBM,IGR,JGR,IL) + SIGS(IBM,IGR,IL)=SIGS(IBM,IGR,IL)-CSCAT*FF + SIGS(IBM,JGR,IL)=SIGS(IBM,JGR,IL)-CSCAT + SS2D(IBM,JGR,IGR,IL)=SS2D(IBM,JGR,IGR,IL)-CSCAT*FF + SS2D(IBM,IGR,JGR,IL)=0.0 + ENDDO + ENDDO + ENDDO + ENDIF +* + IF(LSPH) THEN + ALLOCATE(RVALO(LOCAD(NLOC+1)-1)) + CALL LCMGET(IPSAP,'RVALOC',RVALO) + DO ILOC=1,NLOC + IF((LOCTYP(ILOC).EQ.'EQUI').AND.(LOCKEY(ILOC).EQ.HEQUI)) + 1 THEN + IF(LOCAD(ILOC+1)-LOCAD(ILOC).NE.NGROUP) THEN + CALL XABORT('SPHSAP: INVALID NUMBER OF COMPONENTS FOR ' + 1 //'SPH FACTORS') + ENDIF + DO IGR=1,NGROUP + SPH(IBM,IGR)=RVALO(LOCAD(ILOC)+IGR-1) + ENDDO + ENDIF + ENDDO + DEALLOCATE(RVALO) + ELSE + SPH(IBM,:NGROUP)=1.0 + ENDIF + IF(LMASL) THEN + ALLOCATE(RVALO(LOCAD(NLOC+1)-1)) + CALL LCMGET(IPSAP,'RVALOC',RVALO) + DO ILOC=1,NLOC + IF((LOCTYP(ILOC).EQ.'MASL').AND.(LOCKEY(ILOC).EQ.HMASL)) + 1 THEN + IF(LOCAD(ILOC+1)-LOCAD(ILOC).NE.1) THEN + CALL XABORT('SPHSAP: INVALID NUMBER OF COMPONENTS FOR ' + 1 //'MASL') + ENDIF + FMASL(IBM)=RVALO(LOCAD(ILOC)) + ENDIF + ENDDO + DEALLOCATE(RVALO) + ENDIF +* + CALL LCMLEN(IPSAP,'cinetique',ILONG,ITYLCM) + IF((NPRC.GT.0).AND.(ILONG.NE.0)) THEN + CALL LCMSIX(IPSAP,'cinetique',1) + CALL LCMGET(IPSAP,'NPR',NPR) + IF(NPR.NE.NPRC) CALL XABORT('SPHSAP: NPR INCONSISTENCY(2).') + CALL LCMGET(IPSAP,'LAMBRS',LAMB) + CALL LCMGET(IPSAP,'CHIRS',CHIRS(1,1,IBM)) + CALL LCMGET(IPSAP,'BETARS',BETAR(1,IBM)) + CALL LCMGET(IPSAP,'INVELS',INVELS(1,IBM)) + CALL LCMSIX(IPSAP,' ',2) + ENDIF + CALL LCMSIX(IPSAP,' ',2) +* END OF LOOP OVER SAPHYB MIXTURES + ENDDO + IF(NPARL.GT.0) DEALLOCATE(LOCAD) +*---- +* RECOVER DISCONTINUITY FACTOR INFORMATION +*---- + IDF=0 + IF(NSURFD.GT.0) THEN + IDF=2 + CALL LCMSIX(IPSAP,'outflx',1) + CALL LCMGET(IPSAP,'SURFLX',SURFLX) + CALL LCMSIX(IPSAP,' ',2) + CALL LCMSIX(IPMAC,'ADF',1) + CALL LCMPUT(IPMAC,'NTYPE',1,1,NSURFD) + ALLOCATE(HADF(NSURFD),WORK(NMIL,NGROUP)) + DO I=1,NSURFD + WRITE(HADF(I),'(3HFD_,I5.5)') I + DO IGR=1,NGROUP + WORK(:,IGR)=SURFLX(I,IGR)/SURF(I) + ENDDO + CALL LCMPUT(IPMAC,HADF(I),NMIL*NGROUP,2,WORK) + ENDDO + CALL LCMPTC(IPMAC,'HADF',8,NSURFD,HADF) + DEALLOCATE(WORK,HADF) + CALL LCMSIX(IPMAC,' ',2) + ENDIF + DEALLOCATE(SURFLX,SURF) + CALL LCMSIX(IPSAP,' ',2) +*---- +* IDENTIFY SPECIAL FLUX EDITS +*---- + ALLOCATE(IHEDI(2*NREA)) + NED=0 + DO IREA=1,NREA + IF(.NOT.LXS(IREA)) CYCLE + IF(NOMREA(IREA).EQ.'TOTALE') CYCLE + IF(NOMREA(IREA).EQ.'TOTALE P1') CYCLE + IF(NOMREA(IREA).EQ.'EXCESS') CYCLE + IF(NOMREA(IREA).EQ.'SPECTRE') CYCLE + IF(NOMREA(IREA).EQ.'NU*FISSION') CYCLE + IF(NOMREA(IREA)(:7).EQ.'ENERGIE') CYCLE + IF(NOMREA(IREA).EQ.'SELF') CYCLE + IF(NOMREA(IREA).EQ.'TRANSP-CORR') CYCLE + IF(NOMREA(IREA).EQ.'FUITES') CYCLE + IF(NOMREA(IREA).EQ.'DIFFUSION') CYCLE + IF(NOMREA(IREA).EQ.'TRANSFERT') CYCLE + NED=NED+1 + IF(NED.GT.MAXREA) CALL XABORT('SPHSAP: MAXREA OVERFLOW(2).') + IF(NOMREA(IREA).EQ.'FISSION') THEN + TEXT8='NFTOT' + READ(TEXT8,'(2A4)') IHEDI(2*NED-1),IHEDI(2*NED) + ELSE + READ(NOMREA(IREA),'(2A4)') IHEDI(2*NED-1),IHEDI(2*NED) + ENDIF + ENDDO +*---- +* STORE MACROLIB. +*---- + CALL LCMPUT(IPMAC,'VOLUME',NMIL,2,XVOLM) + IF(LMASL) CALL LCMPUT(IPMAC,'MASL',NMIL,2,FMASL) + IF(NPRC.GT.0) CALL LCMPUT(IPMAC,'LAMBDA-D',NPRC,2,LAMB) + IFISS=0 + ITRANC=0 + LDIFF=.FALSE. + NW=0 + ALLOCATE(STR(NMIL),WRK(NMIL)) + SIGS0(:NMIL,:NGROUP)=0.0 + JPMAC=LCMLID(IPMAC,'GROUP',NGROUP) + DO IGR=1,NGROUP + STR(:NMIL)=0.0 + KPMAC=LCMDIL(JPMAC,IGR) + CALL LCMPUT(KPMAC,'FLUX-INTG',NMIL,2,NWT0(1,IGR)) + IF(NPRC.GT.0) THEN + DO IBM=1,NMIL + WRK(IBM)=INVELS(IGR,IBM) + ENDDO + CALL LCMPUT(KPMAC,'OVERV',NMIL,2,WRK) + ENDIF + DO IREA=1,NREA + IF(.NOT.LXS(IREA)) CYCLE + IF(NOMREA(IREA).EQ.'TOTALE') THEN + IF(LSTRD) THEN + DO IBM=1,NMIL + STR(IBM)=STR(IBM)+XS(IBM,IGR,IREA) + ENDDO + ENDIF + CALL LCMPUT(KPMAC,'NTOT0',NMIL,2,XS(1,IGR,IREA)) + ELSE IF(NOMREA(IREA).EQ.'TOTALE P1') THEN + NW=1 + CALL LCMPUT(KPMAC,'NTOT1',NMIL,2,XS(1,IGR,IREA)) + ELSE IF(NOMREA(IREA).EQ.'EXCESS') THEN +* correct scattering XS with excess XS + DO IBM=1,NMIL + SIGS0(IBM,IGR)=SIGS0(IBM,IGR)+XS(IBM,IGR,IREA) + ENDDO + CALL LCMPUT(KPMAC,'N2N',NMIL,2,XS(1,IGR,IREA)) + ELSE IF(NOMREA(IREA).EQ.'FISSION') THEN + CALL LCMPUT(KPMAC,'NFTOT',NMIL,2,XS(1,IGR,IREA)) + ELSE IF(NOMREA(IREA).EQ.'SPECTRE') THEN + CALL LCMPUT(KPMAC,'CHI',NMIL,2,XS(1,IGR,IREA)) + DO IPRC=1,NPRC + DO IBM=1,NMIL + WRK(IBM)=CHIRS(IGR,IPRC,IBM) + ENDDO + WRITE(TEXT12,'(A3,I2.2)') 'CHI',IPRC + CALL LCMPUT(KPMAC,TEXT12,NMIL,2,WRK) + ENDDO + ELSE IF(NOMREA(IREA).EQ.'NU*FISSION') THEN + IFISS=1 + CALL LCMPUT(KPMAC,'NUSIGF',NMIL,2,XS(1,IGR,IREA)) + DO IPRC=1,NPRC + DO IBM=1,NMIL + WRK(IBM)=XS(IBM,IGR,IREA)*BETAR(IPRC,IBM) + ENDDO + WRITE(TEXT12,'(A6,I2.2)') 'NUSIGF',IPRC + CALL LCMPUT(KPMAC,TEXT12,NMIL,2,WRK) + ENDDO + ELSE IF(NOMREA(IREA).EQ.'ENERGIE') THEN + CALL LCMPUT(KPMAC,'H-FACTOR',NMIL,2,XS(1,IGR,IREA)) + ELSE IF(NOMREA(IREA).EQ.'SELF') THEN + CALL LCMPUT(KPMAC,'SIGW00',NMIL,2,XS(1,IGR,IREA)) + ELSE IF(NOMREA(IREA).EQ.'TRANSP-CORR') THEN + ITRANC=2 + IF(LSTRD) THEN + DO IBM=1,NMIL + STR(IBM)=STR(IBM)-XS(IBM,IGR,IREA) + ENDDO + ENDIF + CALL LCMPUT(KPMAC,'TRANC',NMIL,2,XS(1,IGR,IREA)) + ELSE IF(NOMREA(IREA).EQ.'FUITES') THEN + LDIFF=LSTRD + IF(.NOT.LSTRD) THEN + DO IBM=1,NMIL + LDIFF=LDIFF.OR.(XS(IBM,IGR,IREA).NE.0.0) + STR(IBM)=XS(IBM,IGR,IREA)/B2 + ENDDO + ENDIF + ELSE IF(NOMREA(IREA).EQ.'DIFFUSION') THEN + DO IL=1,NL + WRITE(CM,'(I2.2)') IL-1 + IF(IL.EQ.1) THEN + DO IBM=1,NMIL + SIGS0(IBM,IGR)=SIGS0(IBM,IGR)+SIGS(IBM,IGR,IL) + ENDDO + ELSE + CALL LCMPUT(KPMAC,'SIGS'//CM,NMIL,2,SIGS(1,IGR,IL)) + ENDIF + ENDDO + ELSE IF(NOMREA(IREA).EQ.'TRANSFERT') THEN + ALLOCATE(SCAT(NGROUP*NMIL),GAR(NMIL)) + DO IL=1,NL + WRITE(CM,'(I2.2)') IL-1 + IPOSDE=0 + DO IBM=1,NMIL + IPOS(IBM)=IPOSDE+1 + IGMIN=IGR + IGMAX=IGR + DO JGR=NGROUP,1,-1 + IF(SS2D(IBM,IGR,JGR,IL).NE.0.0) THEN + IGMIN=MIN(IGMIN,JGR) + IGMAX=MAX(IGMAX,JGR) + ENDIF + ENDDO + IJJM(IBM)=IGMAX + NJJM(IBM)=IGMAX-IGMIN+1 + DO JGR=IGMAX,IGMIN,-1 + IPOSDE=IPOSDE+1 + SCAT(IPOSDE)=SS2D(IBM,IGR,JGR,IL) + ENDDO + GAR(IBM)=SCAT(IPOS(IBM)+IJJM(IBM)-IGR) + ENDDO + CALL LCMPUT(KPMAC,'SCAT'//CM,IPOSDE,2,SCAT) + CALL LCMPUT(KPMAC,'NJJS'//CM,NMIL,1,NJJM) + CALL LCMPUT(KPMAC,'IJJS'//CM,NMIL,1,IJJM) + CALL LCMPUT(KPMAC,'IPOS'//CM,NMIL,1,IPOS) + CALL LCMPUT(KPMAC,'SIGW'//CM,NMIL,2,GAR) + ENDDO + DEALLOCATE(GAR,SCAT) + ELSE + CALL LCMPUT(KPMAC,NOMREA(IREA),NMIL,2,XS(1,IGR,IREA)) + ENDIF + ENDDO + IF(LSTRD) THEN + IF((ITRANC.EQ.0).AND.(NL.GT.1)) THEN +* Apollo-type transport correction + DO IBM=1,NMIL + STR(IBM)=STR(IBM)-SIGS(IBM,IGR,2) + ENDDO + ENDIF + DO IBM=1,NMIL + STR(IBM)=1.0/(3.0*STR(IBM)) + ENDDO + LDIFF=.TRUE. + ENDIF + IF((ITRANC.EQ.0).AND.(NL.GT.1)) THEN +* Apollo-type transport correction + IF(IGR.EQ.NGROUP) ITRANC=2 + CALL LCMPUT(KPMAC,'TRANC',NMIL,2,SIGS(1,IGR,2)) + ENDIF + IF(LDIFF) CALL LCMPUT(KPMAC,'DIFF',NMIL,2,STR) + ENDDO + DEALLOCATE(WRK,STR) +*---- +* RELEASE MEMORY +*---- + DEALLOCATE(INVELS,BETAR,CHIRS,LAMB,LXS,XS,SS2D,SIGS,NWT0,LENGDP, + 1 LENGDX,ISADRX,XVOLM) + IF(NISOTS.GT.0) DEALLOCATE(ISOTS) + IF(NADRX.GT.0) DEALLOCATE(IADRX) + IF(NISO.GT.0) DEALLOCATE(NOMISO) + DEALLOCATE(RESM,TOTM) +*---- +* SAVE SCATTERING P0 INFO +*---- + DO IGR=1,NGROUP + KPMAC=LCMDIL(JPMAC,IGR) + CALL LCMPUT(KPMAC,'SIGS00',NMIL,2,SIGS0(1,IGR)) + ENDDO +*---- +* WRITE STATE VECTOR +*---- + TEXT12='L_MACROLIB' + CALL LCMPTC(IPMAC,'SIGNATURE',12,TEXT12) + ISTATE(:NSTATE)=0 + ISTATE(1)=NGROUP + ISTATE(2)=NMIL + ISTATE(3)=NL ! 1+scattering anisotropy + ISTATE(4)=IFISS + ISTATE(5)=NED + ISTATE(6)=ITRANC + ISTATE(7)=NPRC + IF(LDIFF) ISTATE(9)=1 + ISTATE(10)=NW + ISTATE(12)=IDF + CALL LCMPUT(IPMAC,'STATE-VECTOR',NSTATE,1,ISTATE) + IF(NED.GT.0) CALL LCMPUT(IPMAC,'ADDXSNAME-P0',2*NED,3,IHEDI) + DEALLOCATE(IHEDI) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(FMASL,SIGS0) + DEALLOCATE(NOMMIL,IJJM,NJJM,IPOS) + RETURN + END diff --git a/Dragon/src/SPHSCO.f b/Dragon/src/SPHSCO.f new file mode 100644 index 0000000..d44aee2 --- /dev/null +++ b/Dragon/src/SPHSCO.f @@ -0,0 +1,83 @@ +*DECK SPHSCO + SUBROUTINE SPHSCO(IPCPO,ICAL,IMPX,IMC,NMIL,NGRP,SPH) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Apply a new set of SPH factors for an elementary calculation in a +* Multicompo. +* +*Copyright: +* Copyright (C) 2012 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPCPO pointer to the Multicompo (L_MULTICOMPO signature). +* ICAL index of the elementary calculation being considered. +* IMPX print parameter (equal to zero for no print). +* IMC type of macro-calculation (=1 diffusion or SPN; +* =2 other options). +* NMIL number of mixtures in the elementary calculation. +* NGRP number of energy groups in the elementary calculation. +* SPH SPH-factor set to be applied to the Multicompo. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPCPO + INTEGER ICAL,IMPX,IMC,NMIL,NGRP + REAL SPH(NMIL,NGRP) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40,IOUT=6) + INTEGER ISTATE(NSTATE) + TYPE(C_PTR) JPCPO,KPCPO,LPCPO,MPCPO + REAL, ALLOCATABLE, DIMENSION(:) :: SPH2 +* + CALL LCMLEN(IPCPO,'STATE-VECTOR',ILENG,ITYLCM) + IF(ILENG.EQ.0) CALL XABORT('SPHSCO: INVALID MULTICOMPO.') + CALL LCMGET(IPCPO,'STATE-VECTOR',ISTATE) + IF(NMIL.NE.ISTATE(1)) THEN + CALL XABORT('SPHSCO: INVALID NUMBER OF MIXTURES(1).') + ELSE IF(NGRP.NE.ISTATE(2)) THEN + CALL XABORT('SPHSCO: INVALID NUMBER OF ENERGY GROUPS(1).') + ELSE IF((ICAL.LE.0).OR.(ICAL.GT.ISTATE(3))) THEN + CALL XABORT('SPHSCO: INVALID VALUE OF ICAL.') + ENDIF + JPCPO=LCMGID(IPCPO,'MIXTURES') + DO 20 IBM=1,NMIL + IF(IMPX.GT.0) WRITE(IOUT,'(/33H SPHSCO: PROCESS MULTICOMPO MIXTU, + 1 2HRE,I5)') IBM + KPCPO=LCMGIL(JPCPO,IBM) + LPCPO=LCMGID(KPCPO,'CALCULATIONS') + MPCPO=LCMGIL(LPCPO,ICAL) + CALL LCMGET(MPCPO,'STATE-VECTOR',ISTATE) + IF(ISTATE(1).NE.1) THEN + CALL XABORT('SPHSCO: INVALID NUMBER OF MIXTURES(2).') + ELSE IF(ISTATE(3).NE.NGRP) THEN + CALL XABORT('SPHSCO: INVALID NUMBER OF ENERGY GROUPS(2).') + ENDIF + NISOT=ISTATE(2) + NL=ISTATE(4) + NED=ISTATE(13) + NDEL=ISTATE(19) + NW=ISTATE(25) + ALLOCATE(SPH2(NGRP)) + DO 10 IGR=1,NGRP + SPH2(IGR)=SPH(IBM,IGR) + 10 CONTINUE + NALBP=0 ! no albedo correction + CALL SPHCMI(MPCPO,IMPX,IMC,1,NISOT,NGRP,NL,NW,NED,NDEL,NALBP,SPH2) + DEALLOCATE(SPH2) + 20 CONTINUE + RETURN + END diff --git a/Dragon/src/SPHSTM.f b/Dragon/src/SPHSTM.f new file mode 100644 index 0000000..c1b98cb --- /dev/null +++ b/Dragon/src/SPHSTM.f @@ -0,0 +1,119 @@ +*DECK SPHSTM + SUBROUTINE SPHSTM(IPAPX,ICAL,IMPX,LNEW,HEQUI,HEDIT,NMIL,NGROUP, + 1 SPH) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Store a new set of SPH factors for an elementary calculation in a +* MPO file. +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPAPX pointer to the MPO file. +* ICAL index of the elementary calculation being considered. +* IMPX print parameter (equal to zero for no print). +* LNEW flag set to .TRUE. to allow the overwriting of the existing +* set of SPH factors named HEQUI. +* HEQUI LOCKEY name of SPH-factor set to be stored. +* HEDIT name of output group for a (multigroup mesh, output geometry) +* couple (generally equal to 'output_0'). +* NMIL number of mixtures in the elementary calculation. +* NGROUP number of energy groups in the elementary calculation. +* SPH SPH-factor set to be stored the MPO file. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPAPX + INTEGER ICAL,IMPX,NMIL,NGROUP + REAL SPH(NMIL,NGROUP) + LOGICAL LNEW + CHARACTER(LEN=80) HEQUI + CHARACTER(LEN=12) HEDIT +*---- +* LOCAL VARIABLES +*---- + CHARACTER RECNAM*80 +*---- +* SLLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: LOCAD,LOCA_OLD + REAL, ALLOCATABLE, DIMENSION(:) :: RVALO,RVALO_OLD + CHARACTER(LEN=80), ALLOCATABLE, DIMENSION(:) :: LOCTYP,LOCKEY, + & LOCTYP_OLD,LOCKEY_OLD +*---- +* RECOVER MPO FILE CHARACTERISTICS +*---- + NLOC_OLD=0 + IF(hdf5_group_exists(IPAPX,"/local_values/")) THEN + CALL hdf5_read_data(IPAPX,"local_values/LOCVALTYPE",LOCTYP_OLD) + CALL hdf5_read_data(IPAPX,"local_values/LOCVALNAME",LOCKEY_OLD) + NLOC_OLD=SIZE(LOCTYP_OLD,1) + NLOC=NLOC_OLD + DO ILOC=1,NLOC_OLD + IF((LOCTYP_OLD(ILOC).EQ.'EQUI').AND. + & (LOCKEY_OLD(ILOC).EQ.HEQUI)) THEN +* SET HEQUI EXISTS. + IF(LNEW) THEN + IF(IMPX.GT.0) WRITE(6,'(28H SPHSTM: OVERWRITE SPH-FACTO, + & 12HR SET NAMED ,A)') HEQUI + JLOC=ILOC + GO TO 10 + ELSE + CALL XABORT('SPHSTM: THIS SPH FACTOR SET EXISTS: '//HEQUI) + ENDIF + ENDIF + ENDDO + ENDIF + NLOC=NLOC_OLD+1 + JLOC=NLOC + 10 ALLOCATE(LOCTYP(NLOC),LOCKEY(NLOC)) + IF(NLOC_OLD.GT.0) THEN + LOCTYP(:NLOC_OLD)=LOCTYP_OLD(:NLOC_OLD) + LOCKEY(:NLOC_OLD)=LOCKEY_OLD(:NLOC_OLD) + DEALLOCATE(LOCKEY_OLD,LOCTYP_OLD) + ENDIF + LOCTYP(JLOC)='EQUI' + LOCKEY(JLOC)=HEQUI + CALL hdf5_delete(IPAPX,"local_values/LOCVALTYPE") + CALL hdf5_delete(IPAPX,"local_values/LOCVALNAME") + CALL hdf5_write_data(IPAPX,"local_values/LOCVALTYPE",LOCTYP) + CALL hdf5_write_data(IPAPX,"local_values/LOCVALNAME",LOCKEY) +*---- +* LOOP OVER MIXTURES. +*---- + DO IBM=1,NMIL + WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0,6H/zone_,I0,1H/)') + & TRIM(HEDIT),ICAL-1,IBM-1 + CALL hdf5_read_data(IPAPX,TRIM(RECNAM)//"LOCVALADDR",LOCA_OLD) + CALL hdf5_read_data(IPAPX,TRIM(RECNAM)//"LOCALVALUE",RVALO_OLD) + ALLOCATE(LOCAD(NLOC+1)) + LOCAD(:NLOC_OLD+1)=LOCA_OLD(:NLOC_OLD+1) + LOCAD(JLOC+1)=LOCAD(JLOC)+NGROUP + ALLOCATE(RVALO(LOCAD(NLOC+1))) + RVALO(:LOCA_OLD(NLOC_OLD+1))=RVALO_OLD(:LOCA_OLD(NLOC_OLD+1)) + DEALLOCATE(LOCA_OLD,RVALO_OLD) + DO IGR=1,NGROUP + RVALO(LOCAD(JLOC)+IGR)=SPH(IBM,IGR) + ENDDO + CALL hdf5_delete(IPAPX,TRIM(RECNAM)//"LOCVALADDR") + CALL hdf5_delete(IPAPX,TRIM(RECNAM)//"LOCALVALUE") + CALL hdf5_write_data(IPAPX,TRIM(RECNAM)//"LOCVALADDR",LOCAD) + CALL hdf5_write_data(IPAPX,TRIM(RECNAM)//"LOCALVALUE",RVALO) + DEALLOCATE(RVALO,LOCAD) + ENDDO + RETURN + END diff --git a/Dragon/src/SPHSTO.f b/Dragon/src/SPHSTO.f new file mode 100644 index 0000000..3b0cfb6 --- /dev/null +++ b/Dragon/src/SPHSTO.f @@ -0,0 +1,141 @@ +*DECK SPHSTO + SUBROUTINE SPHSTO(IPSAP,ICAL,IMPX,LNEW,HEQUI,HEQNAM,NMIL,NGROUP, + 1 SPH) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Store a new set of SPH factors for an elementary calculation in a +* Saphyb. +* +*Copyright: +* Copyright (C) 2011 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPSAP pointer to the Saphyb (L_SAPHYB signature). +* ICAL index of the elementary calculation being considered. +* IMPX print parameter (equal to zero for no print). +* LNEW flag set to .TRUE. to allow the overwriting of the existing +* set of SPH factors named HEQUI. +* HEQUI LOCKEY name of SPH-factor set to be stored. +* HEQNAM LOCNAM name of SPH-factor set to be stored. +* NMIL number of mixtures in the elementary calculation. +* NGROUP number of energy groups in the elementary calculation. +* SPH SPH-factor set to be stored the Saphyb. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSAP + INTEGER ICAL,IMPX,NMIL,NGROUP + REAL SPH(NMIL,NGROUP) + LOGICAL LNEW + CHARACTER HEQUI*4,HEQNAM*80 +*---- +* LOCAL VARIABLES +*---- + PARAMETER(MAXLOC=10) + INTEGER DIMSAP(50) + CHARACTER TEXT12*12,HSMG*131,LOCTYP(MAXLOC)*4,LOCNAM(MAXLOC)*80, + 1 LOCKEY(MAXLOC)*4 + INTEGER, ALLOCATABLE, DIMENSION(:) :: LOCAD + REAL, ALLOCATABLE, DIMENSION(:) :: RVALO +*---- +* RECOVER SAPHYB CHARACTERISTICS +*---- + IF(HEQUI.EQ.' ') CALL XABORT('SPHSTO: HEQUI NOT DEFINED') + CALL LCMLEN(IPSAP,'DIMSAP',ILENG,ITYLCM) + IF(ILENG.EQ.0) CALL XABORT('SPHSTO: DIMSAP NOT DEFINED') + CALL LCMGET(IPSAP,'DIMSAP',DIMSAP) + NMIL=DIMSAP(7) ! number of mixtures + NCALS=DIMSAP(19) ! number of elementary calculations in the SAPHYB + NGROUP=DIMSAP(20)! number of energy groups + IF(IMPX.GT.0) THEN + WRITE(6,'(29H SPHSTO: number of mixtures =,I5)') NMIL + WRITE(6,'(33H SPHSTO: number of calculations =,I5)') NCALS + WRITE(6,'(34H SPHSTO: number of energy groups =,I4)') NGROUP + ENDIF + IF(ICAL.GT.NCALS) CALL XABORT('SPHSTO: ICAL INDEX OVERFLOW') +*---- +* RECOVER INFORMATION FROM caldir DIRECTORY. +*---- + WRITE(TEXT12,'(4Hcalc,I8)') ICAL + CALL LCMLEN(IPSAP,TEXT12,ILENG,ITYLCM) + IF(ILENG.EQ.0) THEN + WRITE(HSMG,'(29HSPHSTO: MISSING CALCULATION '',A12,2H''.)') + 1 TEXT12 + CALL XABORT(HSMG) + ENDIF + CALL LCMSIX(IPSAP,TEXT12,1) + CALL LCMSIX(IPSAP,'info',1) + CALL LCMGET(IPSAP,'NLOC',NLOC) + IF(NLOC+1.GT.MAXLOC) CALL XABORT('SPHSTO: MAXLOC OVERFLOW') + CALL LCMGTC(IPSAP,'LOCTYP',4,NLOC,LOCTYP) + CALL LCMGTC(IPSAP,'LOCNAM',80,NLOC,LOCNAM) + CALL LCMGTC(IPSAP,'LOCKEY',4,NLOC,LOCKEY) + ALLOCATE(LOCAD(NLOC+2)) + CALL LCMGET(IPSAP,'LOCADR',LOCAD) + DO ILOC=1,NLOC + IF ((LOCTYP(ILOC).EQ.'EQUI').AND.(LOCKEY(ILOC).EQ.HEQUI)) THEN +* SET HEQUI EXISTS. + IF(LNEW) THEN + IF(IMPX.GT.0) WRITE(6,'(31H SPHSTO: OVERWRITE SPH-FACTOR S, + 1 9HET NAMED ,A)') HEQUI + JLOC=ILOC + GO TO 10 + ELSE + CALL XABORT('SPHSTO: THIS SPH FACTOR SET EXISTS: '//HEQUI) + ENDIF + ENDIF + ENDDO +* A NEW SET OF SPH FACTORS IS DEFINED IN THE SAPHYB + JLOC=NLOC+1 + NLOC=NLOC+1 + LOCTYP(NLOC)='EQUI' + LOCKEY(NLOC)=HEQUI + IF(HEQNAM.NE.' ') THEN + LOCNAM(NLOC)=HEQNAM + ELSE + LOCNAM(NLOC)=HEQUI + ENDIF + LOCAD(NLOC+1)=LOCAD(NLOC)+NGROUP + CALL LCMPUT(IPSAP,'NLOC',1,1,NLOC) + CALL LCMPTC(IPSAP,'LOCTYP',4,NLOC,LOCTYP) + CALL LCMPTC(IPSAP,'LOCNAM',80,NLOC,LOCNAM) + CALL LCMPTC(IPSAP,'LOCKEY',4,NLOC,LOCKEY) + CALL LCMPUT(IPSAP,'LOCADR',NLOC+1,1,LOCAD) + 10 CALL LCMSIX(IPSAP,' ',2) +*---- +* LOOP OVER MIXTURES. +*---- + DO IBM=1,NMIL + WRITE(TEXT12,'(4Hmili,I8)') IBM + CALL LCMLEN(IPSAP,TEXT12,ILENG,ITYLCM) + IF(ILENG.EQ.0) THEN + WRITE(HSMG,'(29HSPHSTO: MISSING MIXTURE '',A12,2H''.)') + 1 TEXT12 + CALL XABORT(HSMG) + ENDIF + CALL LCMSIX(IPSAP,TEXT12,1) + ALLOCATE(RVALO(LOCAD(NLOC+1))) + CALL LCMGET(IPSAP,'RVALOC',RVALO) + DO IGR=1,NGROUP + RVALO(LOCAD(JLOC)+IGR-1)=SPH(IBM,IGR) + ENDDO + CALL LCMPUT(IPSAP,'RVALOC',LOCAD(NLOC+1)-1,2,RVALO) + DEALLOCATE(RVALO) + CALL LCMSIX(IPSAP,' ',2) + ENDDO + DEALLOCATE(LOCAD) + CALL LCMSIX(IPSAP,' ',2) + RETURN + END diff --git a/Dragon/src/SPHSX5.f b/Dragon/src/SPHSX5.f new file mode 100644 index 0000000..f3b89de --- /dev/null +++ b/Dragon/src/SPHSX5.f @@ -0,0 +1,132 @@ +*DECK SPHSX5 + SUBROUTINE SPHSX5(IPAPX,RECNAM,NREA,NGROUP,NISOF,NISOP,NL,INDX, + 1 NOMREA,SIGS,SS2D,XS,LXS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover the cross sections of an elementary calculation and single +* mixture in an Apex file. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPAPX pointer to the Apex file. +* RECNAM character identification of calculation. +* NREA number of reactions in the Apex file. +* NGROUP number of energy groups. +* NISOF number of fissile isotopes. +* NISOP number of fission products. +* NL maximum Legendre order (NL=1 is for isotropic scattering). +* INDX position of isotopic set in current mixture (=-2: residual +* set; -1: total set; >0 isotope index). +* NOMREA names of reactions in the Apex file. +* LXS existence flag of each reaction. +* +*Parameters: output +* SIGS scattering cross sections. +* SS2D complete scattering matrix. +* XS cross sections per reaction. +* LXS existence flag of each reaction. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE hdf5_wrap + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPAPX + CHARACTER RECNAM*80 + INTEGER NREA,NGROUP,NISOF,NISOP,NL,INDX + REAL SS2D(NGROUP,NGROUP,NL),SIGS(NGROUP,NL),XS(NGROUP,NREA) + LOGICAL LXS(NREA) + CHARACTER NOMREA(NREA)*12 +*---- +* LOCAL VARIABLES +*---- + INTEGER RANK,TYPE,NBYTE,DIMSR(5),IREA,IOF,IL + CHARACTER RECNAM2*80,RECNAM3*80 + REAL, ALLOCATABLE, DIMENSION(:) :: WORK1D + REAL, ALLOCATABLE, DIMENSION(:,:) :: WORK2D + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: WORK3D + REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: WORK4D +*---- +* FILL OUTPUT ARRAYS +*---- + SIGS(:NGROUP,:NL)=0.0 + SS2D(:NGROUP,:NGROUP,:NL)=0.0 + XS(:NGROUP,:NREA)=0.0 + IOF=0 + IF(INDX.EQ.-2) THEN + ! residual set + RECNAM2=TRIM(RECNAM)//"mac/RESIDUAL/" + ELSE IF(INDX.EQ.-1) THEN + ! total set + RECNAM2=TRIM(RECNAM)//"mac/TOTAL/" + ELSE IF((INDX.GE.1).AND.(INDX.LE.NISOF)) THEN + ! particularized fissile isotope set + IOF=0 + RECNAM2=TRIM(RECNAM)//"mic/f.p./" + ELSE IF((INDX.GE.NISOF+1).AND.(INDX.LE.NISOF+NISOP)) THEN + ! particularized fission product set + IOF=NISOF + RECNAM2=TRIM(RECNAM)//"mic/fiss/" + ELSE IF(INDX.GE.NISOF+NISOP+1) THEN + ! particularized stable isotope set + IOF=NISOF+NISOP + RECNAM2=TRIM(RECNAM)//"mic/othe/" + ENDIF + DO IREA=1,NREA + RECNAM3=TRIM(RECNAM2)//NOMREA(IREA) + IF(NOMREA(IREA).EQ.'PROF') CYCLE + CALL hdf5_info(IPAPX,RECNAM3,RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.NE.99) THEN + LXS(IREA)=.TRUE. + IF(NOMREA(IREA).EQ.'DIFF') THEN + IF(INDX.LT.0) THEN + CALL hdf5_read_data(IPAPX,RECNAM3,WORK2D) + SIGS(:,:)=WORK2D(:,:) + DEALLOCATE(WORK2D) + ELSE + CALL hdf5_read_data(IPAPX,RECNAM3,WORK3D) + SIGS(:,:)=WORK3D(:,:,INDX-IOF) + DEALLOCATE(WORK3D) + ENDIF + ELSE IF(NOMREA(IREA).EQ.'SCAT') THEN + IF(INDX.LT.0) THEN + CALL hdf5_read_data(IPAPX,RECNAM3,WORK3D) + SS2D(:,:,:)=WORK3D(:,:,:) + DEALLOCATE(WORK3D) + ELSE + CALL hdf5_read_data(IPAPX,RECNAM3,WORK4D) + SS2D(:,:,:)=WORK4D(:,:,:,INDX-IOF) + DEALLOCATE(WORK4D) + ENDIF + NL=SIZE(SS2D,3) + DO IL=2,NL + SS2D(:,:,IL)=SS2D(:,:,IL)/REAL(2*IL-1) + ENDDO + ELSE + IF(INDX.LT.0) THEN + CALL hdf5_read_data(IPAPX,RECNAM3,WORK1D) + XS(:,IREA)=WORK1D(:) + DEALLOCATE(WORK1D) + ELSE + CALL hdf5_read_data(IPAPX,RECNAM3,WORK2D) + XS(:,IREA)=WORK2D(:,INDX-IOF) + DEALLOCATE(WORK2D) + ENDIF + ENDIF + ENDIF + ENDDO + RETURN + END diff --git a/Dragon/src/SPHSXS.f b/Dragon/src/SPHSXS.f new file mode 100644 index 0000000..af0950e --- /dev/null +++ b/Dragon/src/SPHSXS.f @@ -0,0 +1,145 @@ +*DECK SPHSXS + SUBROUTINE SPHSXS(NREA,IDIM2,NADRX,NGROUP,NL,NDATAX,NDATAP,INDX, + 1 IAD,ADRX,RDATAX,IDATAP,NOMREA,SIGS,SS2D,XS,LXS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover the cross sections of an elementary calculation and single +* mixture in a Saphyb. +* +*Copyright: +* Copyright (C) 2011 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NREA number of reactions in the Saphyb. +* IDIM2 second dimension of ADRX array. +* NADRX number of address sets. +* NGROUP number of energy groups. +* NL maximum Legendre order (NL=1 is for isotropic scattering). +* NDATAX number of components in RDATAX. +* NDATAP number of components in IDATAP. +* INDX position of isotopic set in current mixture. +* IAD last index in ADRX. +* ADRX index for RDATAX in the Saphyb. +* RDATAX main cross section container in the Saphyb. +* IDATAP index for scattering matrix information in the Saphyb. +* NOMREA names of reactions in the Saphyb. +* LXS existence flag of each reaction. +* +*Parameters: output +* SIGS scattering cross sections. +* SS2D complete scattering matrix. +* XS cross sections per reaction. +* LXS existence flag of each reaction. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NREA,IDIM2,NADRX,NGROUP,NL,NDATAX,NDATAP,INDX,IAD, + 1 ADRX(NREA+2,IDIM2,NADRX),IDATAP(NDATAP) + REAL SS2D(NGROUP,NGROUP,NL),SIGS(NGROUP,NL),XS(NGROUP,NREA), + 1 RDATAX(NDATAX) + LOGICAL LXS(NREA) + CHARACTER NOMREA(NREA)*12 +*---- +* LOCAL VARIABLES +*---- + INTEGER FAGG,LAGG,FDGG,WGAL,FAG,LAG,FDG(NGROUP),ADR(NGROUP+1) +*---- +* FILL OUTPUT ARRAYS +*---- + IREAPR=0 + IRENTO=0 + DO IREA=1,NREA + IF(NOMREA(IREA).EQ.'PROFIL') IREAPR=IREA + IF(NOMREA(IREA).EQ.'TOTALE') IRENTO=IREA + ENDDO + SIGS(:NGROUP,:NL)=0.0 + SS2D(:NGROUP,:NGROUP,:NL)=0.0 + XS(:NGROUP,:NREA)=0.0 + NL1=ADRX(NREA+1,INDX,IAD) + NL2=ADRX(NREA+2,INDX,IAD) + IF((NL1.GT.NL).OR.(NL2.GT.NL)) THEN + CALL XABORT('SPHSXS: NL OVERFLOW.') + ENDIF + DO IREA=1,NREA + IOF=ADRX(IREA,INDX,IAD) + IF(IOF.EQ.0) CYCLE + IF(NOMREA(IREA).EQ.'DIFFUSION') THEN + DO IL=1,NL1 + DO IGR=1,NGROUP + SIGS(IGR,IL)=RDATAX(IOF+(IL-1)*NGROUP+IGR-1) + LXS(IREA)=LXS(IREA).OR.(SIGS(IGR,IL).NE.0.0) + ENDDO + ENDDO + IF(ADRX(IRENTO,INDX,IAD).EQ.0) THEN + DO IGR=1,NGROUP + XS(IGR,IRENTO)=XS(IGR,IRENTO)+RDATAX(IOF+IGR-1) + LXS(IRENTO)=LXS(IRENTO).OR.(XS(IGR,IRENTO).NE.0.0) + ENDDO + ENDIF + ELSE IF(NOMREA(IREA).EQ.'ABSORPTION') THEN + DO IGR=1,NGROUP + XS(IGR,IREA)=RDATAX(IOF+IGR-1) + LXS(IREA)=LXS(IREA).OR.(XS(IGR,IREA).NE.0.0) + ENDDO + IF(ADRX(IRENTO,INDX,IAD).EQ.0) THEN + DO IGR=1,NGROUP + XS(IGR,IRENTO)=XS(IGR,IRENTO)+RDATAX(IOF+IGR-1) + LXS(IRENTO)=LXS(IRENTO).OR.(XS(IGR,IRENTO).NE.0.0) + ENDDO + ENDIF + ELSE IF(NOMREA(IREA).EQ.'PROFIL') THEN + CYCLE + ELSE IF(NOMREA(IREA).EQ.'TRANSFERT') THEN + IF(IREAPR.EQ.0) CALL XABORT('SPHSXS: MISSING PROFILE INFO.') + IPROF=ADRX(IREAPR,INDX,IAD) + FAGG=IDATAP(IPROF) + LAGG=IDATAP(IPROF+1) + FDGG=IDATAP(IPROF+2) + WGAL=IDATAP(IPROF+3) + FAG=IDATAP(IPROF+4) + LAG=IDATAP(IPROF+5) + DO IGR=1,NGROUP + FDG(IGR)=IDATAP(IPROF+5+IGR) + ADR(IGR)=IDATAP(IPROF+5+NGROUP+IGR) + ENDDO + ADR(NGROUP+1)=IDATAP(IPROF+6+2*NGROUP) + JOFS=0 + DO IL=1,NL2 + ZIL=REAL(2*IL-1) + IF(WGAL.NE.0) THEN + DO IGR=FAGG,LAGG + DO JGR=FDGG,FDGG+WGAL-1 + SS2D(IGR,JGR,IL)=RDATAX(IOF+JOFS)/ZIL ! IGR <-- JGR + JOFS=JOFS+1 + LXS(IREA)=LXS(IREA).OR.(SS2D(IGR,JGR,IL).NE.0.0) + ENDDO + ENDDO + ENDIF + DO IGR=FAG,LAG + DO JGR=FDG(IGR),FDG(IGR)+(ADR(IGR+1)-ADR(IGR))-1 + SS2D(IGR,JGR,IL)=RDATAX(IOF+JOFS)/ZIL ! IGR <-- JGR + JOFS=JOFS+1 + LXS(IREA)=LXS(IREA).OR.(SS2D(IGR,JGR,IL).NE.0.0) + ENDDO + ENDDO + ENDDO + ELSE + DO IGR=1,NGROUP + XS(IGR,IREA)=RDATAX(IOF+IGR-1) + LXS(IREA)=LXS(IREA).OR.(XS(IGR,IREA).NE.0.0) + ENDDO + ENDIF + ENDDO + RETURN + END diff --git a/Dragon/src/SPHTRA.f b/Dragon/src/SPHTRA.f new file mode 100644 index 0000000..b3025a0 --- /dev/null +++ b/Dragon/src/SPHTRA.f @@ -0,0 +1,181 @@ +*DECK SPHTRA + SUBROUTINE SPHTRA(JPSYS,IEX,NPSYS,KSPH,NREG,NUN,NMERGE,NALBP, + 1 NGCOND,SUNMER,FLXMER,NBMIX,MAT,VOL,KEY,MERG,SPH,SIGW,SIGT, + 2 COURIN,FUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transport calculation over the macro-geometry using the collision +* probability technique. Use the Bell factor acceleration strategy. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* JPSYS pointer to the 'GROUP' directory in the system LCM object. +* IEX iteration number. +* NPSYS group masks. +* KSPH type of SPH factor normalization: +* <0 asymptotic normalization; +* =1 average flux normalization; +* =2 Selengut normalization; +* =3 generalized Selengut normalization (EDF type); +* =4 Selengut normalization with surface leakage. +* NREG number of macro-regions (in the macro calculation). +* NUN number of unknowns per group in macro-calculation. +* NMERGE number of merged regions. +* NALBP number of physical albedos. +* NGCOND number of condensed groups. +* SUNMER incoming source (scattering+fission) cross sections. +* FLXMER flux estimate per mixture. +* NBMIX number of material mixtures. +* MAT mixture index per macro-region. +* VOL volume of macro-regions. +* KEY position of the flux components associated with each volume. +* MERG index of merged regions. +* SPH SPH factors. +* SIGW transport correction. +* SIGT macroscopic total cross section. +* COURIN averaged flux if KSPH=1. Equal to 4 times the incoming current +* per unit surface if KSPH=2 or 3. +* +*Parameters: output +* FUNKNO neutron flux. +* +*Reference(s): +* P. Blanc-Tranchant, A. Santamarina, G. Willermoz and A. Hebert, +* "Definition and Validation of a 2-D Transport Scheme for PWR Control +* Rod Clusters", paper presented at the Int. Conf. on Mathematics and +* Computation, Reactor Physics and Environmental Analysis in Nuclear +* Applications, Madrid, Spain, September 27-30, 1999. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) JPSYS + INTEGER IEX,NPSYS(NGCOND),KSPH,NREG,NUN,NMERGE,NALBP,NGCOND,NBMIX, + 1 MAT(NREG),KEY(NREG),MERG(NBMIX) + REAL SUNMER(NMERGE,NGCOND,NGCOND),FLXMER(NMERGE,NGCOND),VOL(NREG), + 1 SPH(NMERGE+NALBP,NGCOND),SIGW(NMERGE,NGCOND),SIGT(NMERGE,NGCOND), + 2 COURIN(NGCOND),FUNKNO(NUN,NGCOND) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) KPSYS +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: SIGMA,SUNKNO + REAL, ALLOCATABLE, DIMENSION(:,:) :: PIJ + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: WORK2,WORK3 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(SIGMA(0:NBMIX),SUNKNO(NREG),PIJ(NREG,NREG)) + ALLOCATE(WORK2(NREG+1,NREG+1),WORK3(NREG,NREG+1)) +*---- +* GLOBAL SOURCE FOR THE BELL FACTOR METHOD. +*---- + DO 100 IGR=1,NGCOND + IF(NPSYS(IGR).EQ.0) GO TO 100 + SUNKNO(:NREG)=0.0 + IF(IEX.EQ.1) THEN + DO 20 IREG=1,NREG + IMAT=MAT(IREG) + IMERG=MERG(IMAT) + IF(IMAT.EQ.0) GO TO 20 + IF(VOL(IREG).EQ.0.0) GO TO 20 + SUM=-(SIGT(IMERG,IGR)-SIGW(IMERG,IGR))*FLXMER(IMERG,IGR) + DO 10 JGR=1,NGCOND + SUM=SUM+SUNMER(IMERG,JGR,IGR)*FLXMER(IMERG,JGR) + 10 CONTINUE + SUNKNO(IREG)=SUM + 20 CONTINUE + ELSE + DO 30 IREG=1,NREG + IMAT=MAT(IREG) + IMERG=MERG(IMAT) + IF(IMAT.EQ.0) GO TO 30 + IF(VOL(IREG).EQ.0.0) GO TO 30 + GARS=-(SIGT(IMERG,IGR)-SIGW(IMERG,IGR))*SPH(IMERG,IGR) + SUM=FUNKNO(KEY(IREG),IGR)*GARS + DO 25 JGR=1,NGCOND + GARS=SUNMER(IMERG,JGR,IGR)*SPH(IMERG,JGR) + SUM=SUM+FUNKNO(KEY(IREG),JGR)*GARS + 25 CONTINUE + SUNKNO(IREG)=SUM + 30 CONTINUE + ENDIF +*---- +* COMPUTE THE WORK2 MATRIX. +*---- + KPSYS=LCMGIL(JPSYS,IGR) + CALL LCMGET(KPSYS,'DRAGON-TXSC',SIGMA) + CALL LCMGET(KPSYS,'DRAGON-PCSCT',PIJ) + DO 45 I=1,NREG + WORK2(I,NREG+1)=0.0D0 + DO 40 J=1,NREG + WORK2(I,NREG+1)=WORK2(I,NREG+1)+PIJ(I,J)*VOL(I)*SUNKNO(J) + WORK2(I,J)=PIJ(I,J)*VOL(I) + 40 CONTINUE + 45 CONTINUE +*---- +* COMPUTE THE NEUTRON FLUXES. +*---- + IF(KSPH.LT.0) THEN +* ASYMPTOTIC NORMALIZATION. + VOLTOT=0.0 + DO 60 I=1,NREG + IF(MAT(I).EQ.-KSPH) THEN + VOLTOT=VOLTOT+VOL(I) + WORK2(NREG+1,I)=VOL(I) + ELSE + WORK2(NREG+1,I)=0.0D0 + ENDIF + DO 50 J=1,NREG + JBM=MAT(J) + WORK2(I,J)=-SIGMA(JBM)*WORK2(I,J) + 50 CONTINUE + WORK2(I,I)=WORK2(I,I)+VOL(I) + 60 CONTINUE + WORK2(NREG+1,NREG+1)=COURIN(IGR)*VOLTOT + ELSE +* INTEGRATED FLUX OR SELENGUT NORMALIZATION. + VOLTOT=0.0 + DO 80 I=1,NREG + VOLTOT=VOLTOT+VOL(I) + WORK2(NREG+1,I)=VOL(I) + DO 70 J=1,NREG + JBM=MAT(J) + WORK2(I,J)=-SIGMA(JBM)*WORK2(I,J) + 70 CONTINUE + WORK2(I,I)=WORK2(I,I)+VOL(I) + 80 CONTINUE + WORK2(NREG+1,NREG+1)=COURIN(IGR)*VOLTOT + ENDIF + CALL ALSVDF(WORK2,NREG+1,NREG,NREG+1,NREG,WORK3(1,NREG+1), + 1 WORK3) + CALL ALSVDS(WORK2,WORK3(1,NREG+1),WORK3,NREG+1,NREG,NREG+1, + 1 NREG,WORK2(1,NREG+1),WORK2(1,NREG+1)) + FUNKNO(:NUN,IGR)=0.0 + DO 90 I=1,NREG + FUNKNO(KEY(I),IGR)=REAL(WORK2(I,NREG+1)) + 90 CONTINUE + 100 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(WORK3,WORK2) + DEALLOCATE(PIJ,SUNKNO,SIGMA) + RETURN + END diff --git a/Dragon/src/SYB001.f b/Dragon/src/SYB001.f new file mode 100644 index 0000000..dfd9903 --- /dev/null +++ b/Dragon/src/SYB001.f @@ -0,0 +1,171 @@ +*DECK SYB001 + SUBROUTINE SYB001 (NREG,NSUPCE,NPIJ,SIGT,SIGW,IMPX,IQUAD,NMC, + 1 RAYRE,PIJW,PISW,PSJW,PSSW) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the cellwise scattering-reduced collision, escape and +* transmission probabilities for the 'do-it-yourself' approach. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NREG total number of regions (NREG=NMC(NSUPCE+1)). +* NSUPCE total number of cells. +* NPIJ length of cellwise scattering-reduced collision probability +* matrices. +* SIGT total macroscopic cross sections. +* SIGW P0 within-group scattering macroscopic cross sections. +* IMPX print flag (equal to 0 for no print). +* IQUAD quadrature parameter. +* NMC offset of the first volume in each cell. +* RAYRE radius of the tubes in each cell. +* +*Parameters: output +* PIJW cellwise scattering-reduced collision probability matrices. +* PISW cellwise scattering-reduced escape probability matrices. +* PSJW cellwise scattering-reduced collision probability matrices +* for incoming neutrons. +* PSSW cellwise scattering-reduced transmission probability +* matrices. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NSUPCE,NREG,NPIJ,IMPX,IQUAD,NMC(NSUPCE+1) + REAL SIGT(NREG),SIGW(NREG),RAYRE(NREG+NSUPCE),PIJW(NPIJ), + 1 PISW(NREG),PSJW(NREG),PSSW(NSUPCE) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (PI=3.141592654) + LOGICAL LSKIP + REAL, ALLOCATABLE, DIMENSION(:) :: PIS,PSJ,ZTR,WORK + REAL, ALLOCATABLE, DIMENSION(:,:) :: PP +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(PIS(NREG),PSJ(NREG)) +* + IPIJ=0 + DO 160 IKK=1,NSUPCE + J1=NMC(IKK) + J2=NMC(IKK+1)-J1 +*---- +* COMPUTE THE REDUCED COLLISION PROBABILITY MATRIX +*---- + ALLOCATE(PP(J2,J2),ZTR(1+IQUAD*((J2*(5+J2))/2))) + CALL SYBT1D(J2,RAYRE(J1+IKK),.FALSE.,IQUAD,ZTR) + CALL SYBALC(J2,J2,RAYRE(J1+IKK),SIGT(J1+1),IQUAD,0.0,ZTR,PP) + DEALLOCATE(ZTR) + SURFA=2.0*PI*RAYRE(J1+J2+IKK) + PSS=0.0 + RJN=0.0 + DO 20 I=1,J2 + PIS(I)=0.0 + DO 10 J=1,J2 + PIS(I)=PIS(I)+PP(I,J)*SIGT(J+J1) + 10 CONTINUE + PIS(I)=1.0-PIS(I) + RJN1=RAYRE(I+J1+IKK)**2 + PSJ(I)=4.0*PI*(RJN1-RJN)*PIS(I)/SURFA + PSS=PSS+PSJ(I)*SIGT(I+J1) + RJN=RJN1 + 20 CONTINUE + PSS=1.0-PSS + IF(IMPX.GE.8) THEN + CALL SYBPRX(1,1,J2,IKK,SIGT(J1+1),SIGW(J1+1),PP(1,1),PIS(1), + 1 PSJ(1),PSS) + ENDIF +*---- +* CHECK IF SCATTERING REDUCTION IS REQUIRED +*---- + LSKIP=.TRUE. + DO 30 I=1,J2 + LSKIP=LSKIP.AND.(SIGW(J1+I).EQ.0.0) + 30 CONTINUE +*---- +* SCATTERING REDUCTION IF LSKIP=.FALSE. +*---- + IF(LSKIP) THEN +* DO NOT PERFORM SCATTERING REDUCTION. + DO 45 I=1,J2 + DO 40 J=1,J2 + PIJW(IPIJ+(J-1)*J2+I)=PP(I,J) + 40 CONTINUE + 45 CONTINUE + DO 50 I=1,J2 + PISW(J1+I)=PIS(I) + PSJW(J1+I)=PSJ(I) + 50 CONTINUE + PSSW(IKK)=PSS + ELSE +* COMPUTE THE SCATTERING-REDUCED COLLISION AND ESCAPE MATRICES. + DO 70 I=1,J2 + DO 60 J=1,J2 + PIJW(IPIJ+(J-1)*J2+I)=-PP(I,J)*SIGW(J1+J) + 60 CONTINUE + PIJW(IPIJ+(I-1)*J2+I)=1.0+PIJW(IPIJ+(I-1)*J2+I) + 70 CONTINUE + CALL ALINV(J2,PIJW(IPIJ+1),J2,IER) + IF(IER.NE.0) CALL XABORT('SYB001: SINGULAR MATRIX.') + ALLOCATE(WORK(J2)) + DO 120 I=1,J2 + DO 80 K=1,J2 + WORK(K)=PIJW(IPIJ+(K-1)*J2+I) + 80 CONTINUE + DO 100 J=1,J2 + WGAR=0.0 + DO 90 K=1,J2 + WGAR=WGAR+WORK(K)*PP(K,J) + 90 CONTINUE + PIJW(IPIJ+(J-1)*J2+I)=WGAR + 100 CONTINUE + WGAR=0.0 + DO 110 K=1,J2 + WGAR=WGAR+WORK(K)*PIS(K) + 110 CONTINUE + PISW(J1+I)=WGAR + 120 CONTINUE + DEALLOCATE(WORK) +* +* COMPUTE THE SCATTERING-REDUCED COLLISION PROBABILITY MATRIX +* FOR INCOMING NEUTRONS. + DO 140 J=1,J2 + WGAR=PSJ(J) + DO 130 K=1,J2 + WGAR=WGAR+PSJ(K)*SIGW(J1+K)*PIJW(IPIJ+(J-1)*J2+K) + 130 CONTINUE + PSJW(J1+J)=WGAR + 140 CONTINUE +* +* COMPUTE THE SCATTERING-REDUCED TRANSMISSION PROBABILITY MATRIX. + WGAR=PSS + DO 150 K=1,J2 + WGAR=WGAR+PSJ(K)*SIGW(J1+K)*PISW(J1+K) + 150 CONTINUE + PSSW(IKK)=WGAR + ENDIF + DEALLOCATE(PP) + IF(IMPX.GE.10) THEN + CALL SYBPRX(2,1,J2,IKK,SIGT(J1+1),SIGW(J1+1),PIJW(IPIJ+1), + 1 PISW(J1+1),PSJW(J1+1),PSSW(J1+1)) + ENDIF + IPIJ=IPIJ+J2*J2 + 160 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(PSJ,PIS) + RETURN + END diff --git a/Dragon/src/SYB002.f b/Dragon/src/SYB002.f new file mode 100644 index 0000000..fd959d8 --- /dev/null +++ b/Dragon/src/SYB002.f @@ -0,0 +1,243 @@ +*DECK SYB002 + SUBROUTINE SYB002 (NGEN,NPIJ,NPIS,SIGT2,SIGW2,IMPX,NCOUR,IWIGN, + 1 IQUAD,XX,YY,NMC,RAYRE,MAIL,RZMAIL,PIJW,PISW,PSJW,PSSW) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the cellwise scattering-reduced collision, escape and +* transmission probabilities in a 2-D Cartesian or hexagonal assembly +* with Roth approximation. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NGEN total number of generating cells. +* NPIJ length of cellwise scattering-reduced collision probability +* matrices. +* NPIS length of cellwise scattering-reduced escape probability +* matrices (NPIS=NMC(NGEN+1)). +* SIGT2 total macroscopic cross sections. +* SIGW2 P0 within-group scattering macroscopic cross sections. +* IMPX print flag (equal to 0 for no print). +* NCOUR number of currents surrounding the cells (=4 Cartesian +* lattice; =6 hexagonal lattice). +* IWIGN type of cylinderization. +* IQUAD quadrature parameters. +* XX X-thickness of the generating cells. +* YY Y-thickness of the generating cells. +* NMC offset of the first volume in each generating cell. +* RAYRE radius of the tubes in each generating cell. +* MAIL offset of the first tracking information in each generating +* cell. +* RZMAIL real tracking information. +* +*Parameters: output +* PIJW cellwise scattering-reduced collision probability matrices. +* PISW cellwise scattering-reduced escape probability matrices. +* PSJW cellwise scattering-reduced collision probability matrices +* for incoming neutrons. +* PSSW cellwise scattering-reduced transmission probability +* matrices. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NGEN,NPIJ,NPIS,IMPX,NCOUR,IWIGN,IQUAD(4),NMC(NGEN+1), + 1 MAIL(2,NGEN) + REAL SIGT2(NPIS),SIGW2(NPIS),XX(NGEN),YY(NGEN),RAYRE(NPIS), + 1 RZMAIL(*),PIJW(NPIJ),PISW(NPIS),PSJW(NPIS),PSSW(NGEN) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (PI=3.141592654) + LOGICAL LSKIP + REAL, ALLOCATABLE, DIMENSION(:) :: PIS,PSJ,RAYR2,WORK + REAL, ALLOCATABLE, DIMENSION(:,:) :: PP +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(PIS(NPIS),PSJ(NPIS)) +* + MR=IQUAD(4) + IPIJ=0 + DO 220 JKG=1,NGEN + J1=NMC(JKG) + J2=NMC(JKG+1)-J1 +*---- +* CYLINDERIZATION OPTIONS +*---- + A=XX(JKG) + B=YY(JKG) + IB=MAIL(2,JKG) + RJ1=RAYRE(NMC(JKG+1)) + SCALE1=1.0 + SCALE2=1.0 + ROUT=0.0 + IF((NCOUR.EQ.4).AND.(IWIGN.EQ.1)) THEN +* ASKEW CYLINDERIZATION CARTESIAN. + RJ2=(A+B)/PI + SCALE1=(A*B-PI*RJ1**2)/(PI*RJ2**2-PI*RJ1**2) + ROUT=RJ2 + ELSE IF((NCOUR.EQ.4).AND.(IWIGN.EQ.2)) THEN +* WIGNER CYLINDERIZATION CARTESIAN. + ROUT=SQRT(A*B/PI) + ELSE IF((NCOUR.EQ.4).AND.(IWIGN.EQ.3)) THEN +* SANCHEZ CYLINDERIZATION CARTESIAN. + SCALE2=SQRT(PI*A*B)/(A+B) + ROUT=SQRT(A*B/PI) + ELSE IF(IWIGN.EQ.1) THEN +* ASKEW CYLINDERIZATION HEXAGONAL. + RJ2=3.0*A/PI + SCALE1=(1.5*SQRT(3.0)*A*A-PI*RJ1**2)/(PI*RJ2**2-PI*RJ1**2) + ROUT=RJ2 + ELSE IF(IWIGN.EQ.2) THEN +* WIGNER CYLINDERIZATION HEXAGONAL. + ROUT=SQRT(1.5*SQRT(3.0)/PI)*A + ELSE IF(IWIGN.EQ.3) THEN +* SANCHEZ CYLINDERIZATION HEXAGONAL. + SCALE2=SQRT(PI*SQRT(3.0)/6.0) + ROUT=SQRT(1.5*SQRT(3.0)/PI)*A + ENDIF + IF(ROUT.LE.RJ1) CALL XABORT('SYB002: CYLINDERIZATION ERROR.') +*---- +* COMPUTE THE REDUCED COLLISION PROBABILITY MATRIX +*---- + SURFA=0.5*PI*ROUT + ALLOCATE(PP(J2,J2),RAYR2(J2+1)) + DO 10 I=1,J2 + RAYR2(I)=RAYRE(J1+I) + 10 CONTINUE + RAYR2(J2+1)=ROUT + SIGT2(J1+J2)=SIGT2(J1+J2)*SCALE1 + CALL SYBALC(J2,J2,RAYR2,SIGT2(J1+1),MR,0.0,RZMAIL(IB),PP) + PSS=0.0 + RJ1=0.0 + DO 30 I=1,J2 + PIS(I)=1.0 + RJ2=RAYR2(I+1)**2 + VV=PI*(RJ2-RJ1) + DO 20 J=1,J2 + PIS(I)=PIS(I)-PP(I,J)*SIGT2(J1+J) + 20 CONTINUE + PSS=PSS+PIS(I)*SIGT2(J1+I)*VV/SURFA + RJ1=RJ2 + 30 CONTINUE + DEALLOCATE(RAYR2) + PSS=1.0-SCALE2*PSS +*---- +* COMPUTE THE REDUCED COLLISION PROBABILITY MATRIX FOR INCOMING +* NEUTRONS +*---- + SURFA=(0.5*PI*ROUT)/SCALE2 + RJ1=0.0 + DO 40 I=1,J2-1 + RJ2=PI*RAYRE(J1+I+1)**2 + PSJ(I)=PIS(I)*(RJ2-RJ1)/SURFA + RJ1=RJ2 + 40 CONTINUE + RJ2=PI*ROUT**2 + PSJ(J2)=PIS(J2)*(RJ2-RJ1)*SCALE1/SURFA + SIGT2(J1+J2)=SIGT2(J1+J2)/SCALE1 + IF(IMPX.GE.8) THEN + CALL SYBPRX(1,1,J2,JKG,SIGT2(J1+1),SIGW2(J1+1),PP(1,1),PIS(1), + 1 PSJ(1),PSS) + ENDIF +*---- +* CHECK IF SCATTERING REDUCTION IS REQUIRED +*---- + LSKIP=.TRUE. + DO 70 I=1,J2 + LSKIP=LSKIP.AND.(SIGW2(J1+I).EQ.0.0) + 70 CONTINUE +*---- +* SCATTERING REDUCTION IF LSKIP=.FALSE. +*---- + IF(LSKIP) THEN +* DO NOT PERFORM SCATTERING REDUCTION. + DO 90 I=1,J2 + DO 80 J=1,J2-1 + PIJW(IPIJ+(J-1)*J2+I)=PP(I,J) + 80 CONTINUE + PIJW(IPIJ+(J2-1)*J2+I)=PP(I,J2)*SCALE1 + 90 CONTINUE + DO 100 I=1,J2 + PISW(J1+I)=PIS(I) + PSJW(J1+I)=PSJ(I) + 100 CONTINUE + PSSW(JKG)=PSS + ELSE +* COMPUTE THE SCATTERING-REDUCED COLLISION AND ESCAPE MATRICES. + DO 120 I=1,J2 + DO 110 J=1,J2-1 + PIJW(IPIJ+(J-1)*J2+I)=-PP(I,J)*SIGW2(J1+J) + 110 CONTINUE + PIJW(IPIJ+(J2-1)*J2+I)=-PP(I,J2)*SIGW2(J1+J2)*SCALE1 + PIJW(IPIJ+(I-1)*J2+I)=1.0+PIJW(IPIJ+(I-1)*J2+I) + 120 CONTINUE + CALL ALINV(J2,PIJW(IPIJ+1),J2,IER) + IF(IER.NE.0) CALL XABORT('SYB002: SINGULAR MATRIX.') + ALLOCATE(WORK(J2)) + DO 170 I=1,J2 + DO 130 K=1,J2 + WORK(K)=PIJW(IPIJ+(K-1)*J2+I) + 130 CONTINUE + DO 150 J=1,J2-1 + WGAR=0.0 + DO 140 K=1,J2 + WGAR=WGAR+WORK(K)*PP(K,J) + 140 CONTINUE + PIJW(IPIJ+(J-1)*J2+I)=WGAR + 150 CONTINUE + WGAR=0.0 + DO 155 K=1,J2 + WGAR=WGAR+WORK(K)*PP(K,J2) + 155 CONTINUE + PIJW(IPIJ+(J2-1)*J2+I)=WGAR*SCALE1 + WGAR=0.0 + DO 160 K=1,J2 + WGAR=WGAR+WORK(K)*PIS(K) + 160 CONTINUE + PISW(J1+I)=WGAR + 170 CONTINUE + DEALLOCATE(WORK) +* +* COMPUTE THE SCATTERING-REDUCED COLLISION PROBABILITY MATRIX +* FOR INCOMING NEUTRONS. + DO 190 J=1,J2 + WGAR=PSJ(J) + DO 180 K=1,J2 + WGAR=WGAR+PSJ(K)*SIGW2(J1+K)*PIJW(IPIJ+(J-1)*J2+K) + 180 CONTINUE + PSJW(J1+J)=WGAR + 190 CONTINUE +* +* COMPUTE THE SCATTERING-REDUCED TRANSMISSION PROBABILITY MATRIX. + WGAR=PSS + DO 200 K=1,J2 + WGAR=WGAR+PSJ(K)*SIGW2(J1+K)*PISW(J1+K) + 200 CONTINUE + PSSW(JKG)=WGAR + ENDIF + DEALLOCATE(PP) + IF(IMPX.GE.10) THEN + CALL SYBPRX(2,1,J2,JKG,SIGT2(J1+1),SIGW2(J1+1),PIJW(IPIJ+1), + 1 PISW(J1+1),PSJW(J1+1),PSSW(JKG)) + ENDIF + IPIJ=IPIJ+J2*J2 + 220 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(PSJ,PIS) + RETURN + END diff --git a/Dragon/src/SYB003.f b/Dragon/src/SYB003.f new file mode 100644 index 0000000..3ddfbf0 --- /dev/null +++ b/Dragon/src/SYB003.f @@ -0,0 +1,304 @@ +*DECK SYB003 + SUBROUTINE SYB003 (NGEN,NPIJ,NPIS,SIGT2,SIGW2,IMPX,NCOUR,IWIGN, + 1 IQUAD,XX,YY,NMC,RAYRE,MAIL,RZMAIL,PIJW,PISW,PSJW,PSSW) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the cellwise scattering-reduced collision, escape and +* transmission probabilities in a 2-D Cartesian or hexagonal assembly +* with Roth x 4 or Roth x 6 approximation. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NGEN total number of generating cells. +* NPIJ length of cellwise scattering-reduced collision probability +* matrices. +* NPIS length of cellwise scattering-reduced escape probability +* matrices (NPIS=NMC(NGEN+1)). +* SIGT2 total macroscopic cross sections. +* SIGW2 P0 within-group scattering macroscopic cross sections. +* IMPX print flag (equal to 0 for no print). +* NCOUR number of currents surrounding the cells (=4 Cartesian +* lattice; =6 hexagonal lattice). +* IWIGN type of cylinderization. +* IQUAD quadrature parameters. +* XX X-thickness of the generating cells. +* YY Y-thickness of the generating cells. +* NMC offset of the first volume in each generating cell. +* RAYRE radius of the tubes in each generating cell. +* MAIL offset of the first tracking information in each generating +* cell. +* RZMAIL real tracking information. +* +*Parameters: output +* PIJW cellwise scattering-reduced collision probability matrices. +* PISW cellwise scattering-reduced escape probability matrices. +* PSJW cellwise scattering-reduced collision probability matrices +* for incoming neutrons. +* PSSW cellwise scattering-reduced transmission probability +* matrices. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NGEN,NPIJ,NPIS,IMPX,NCOUR,IWIGN,IQUAD(4),NMC(NGEN+1), + 1 MAIL(2,NGEN) + REAL SIGT2(NPIS),SIGW2(NPIS),XX(NGEN),YY(NGEN),RAYRE(NPIS), + 1 RZMAIL(*),PIJW(NPIJ),PISW(NCOUR*NPIS),PSJW(NCOUR*NPIS), + 2 PSSW(NGEN*NCOUR*NCOUR) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (PI=3.141592654) + LOGICAL LSKIP + INTEGER ISLR(4,4),ISLH(6,6) + REAL PBB(6),PSS(36) + REAL, ALLOCATABLE, DIMENSION(:) :: RAYR2,WORK + REAL, ALLOCATABLE, DIMENSION(:,:) :: PIS,PSJ,PP +*---- +* DATA STATEMENTS +*---- + SAVE ISLR,ISLH + DATA ISLR/0,4,1,1,4,0,1,1,3,3,0,2,3,3,2,0/ + DATA ISLH/0,1,2,3,2,1,1,0,1,2,3,2,2,1,0,1,2,3, + 1 3,2,1,0,1,2,2,3,2,1,0,1,1,2,3,2,1,0/ +* + MR=IQUAD(4) + IPIJ=0 + IPIS=0 + IPSS=0 + DO 240 JKG=1,NGEN + J1=NMC(JKG) + J2=NMC(JKG+1)-J1 +*---- +* CYLINDERIZATION OPTIONS +*---- + A=XX(JKG) + B=YY(JKG) + IB=MAIL(2,JKG) + RJ1=RAYRE(NMC(JKG+1)) + SCALE1=1.0 + SCALE2=1.0 + ROUT=0.0 + IF((NCOUR.EQ.4).AND.(IWIGN.EQ.1)) THEN +* ASKEW CYLINDERIZATION CARTESIAN. + RJ2=(A+B)/PI + SCALE1=(A*B-PI*RJ1**2)/(PI*RJ2**2-PI*RJ1**2) + ROUT=RJ2 + ELSE IF((NCOUR.EQ.4).AND.(IWIGN.EQ.2)) THEN +* WIGNER CYLINDERIZATION CARTESIAN. + ROUT=SQRT(A*B/PI) + ELSE IF((NCOUR.EQ.4).AND.(IWIGN.EQ.3)) THEN +* SANCHEZ CYLINDERIZATION CARTESIAN. + SCALE2=SQRT(PI*A*B)/(A+B) + ROUT=SQRT(A*B/PI) + ELSE IF(IWIGN.EQ.1) THEN +* ASKEW CYLINDERIZATION HEXAGONAL. + RJ2=3.0*A/PI + SCALE1=(1.5*SQRT(3.0)*A*A-PI*RJ1**2)/(PI*RJ2**2-PI*RJ1**2) + ROUT=RJ2 + ELSE IF(IWIGN.EQ.2) THEN +* WIGNER CYLINDERIZATION HEXAGONAL. + ROUT=SQRT(1.5*SQRT(3.0)/PI)*A + ELSE IF(IWIGN.EQ.3) THEN +* SANCHEZ CYLINDERIZATION HEXAGONAL. + SCALE2=SQRT(PI*SQRT(3.0)/6.0) + ROUT=SQRT(1.5*SQRT(3.0)/PI)*A + ENDIF + IF(ROUT.LE.RJ1) CALL XABORT('SYB003: CYLINDERIZATION ERROR.') +*---- +* COMPUTE THE REDUCED COLLISION PROBABILITY MATRIX +*---- + SURFA=0.5*PI*ROUT + ALLOCATE(PIS(J2,NCOUR),PSJ(NCOUR,J2),PP(J2,J2),RAYR2(J2+1)) + DO 10 I=1,J2 + RAYR2(I)=RAYRE(J1+I) + 10 CONTINUE + RAYR2(J2+1)=ROUT + SIGT2(J1+J2)=SIGT2(J1+J2)*SCALE1 + CALL SYBALC(J2,J2,RAYR2,SIGT2(J1+1),MR,0.0,RZMAIL(IB),PP) +* + PSSX=0.0 + RJ1=0.0 + DO 50 I=1,J2 + PISX=1.0 + RJ2=RAYR2(I+1)**2 + VV=PI*(RJ2-RJ1) + DO 20 J=1,J2 + PISX=PISX-PP(I,J)*SIGT2(J1+J) + 20 CONTINUE + PSSX=PSSX+PISX*SIGT2(J1+I)*VV/SURFA + IF(NCOUR.EQ.4) THEN + DEN1=2.0*(A+B) + PIS(I,1)=PISX*B/DEN1 + PIS(I,2)=PISX*B/DEN1 + PIS(I,3)=PISX*A/DEN1 + PIS(I,4)=PISX*A/DEN1 + ELSE + DO 30 IC=1,NCOUR + PIS(I,IC)=PISX/6.0 + 30 CONTINUE + ENDIF +*---- +* COMPUTE THE REDUCED COLLISION PROBABILITY MATRIX FOR INCOMING +* NEUTRONS +*---- + SURFA2=(0.5*PI*ROUT)/SCALE2 + DO 40 IC=1,NCOUR + IF(I.LE.J2-1) THEN + PSJ(IC,I)=PISX*VV/SURFA2 + ELSE IF(I.EQ.J2) THEN + PSJ(IC,I)=PISX*VV*SCALE1/SURFA2 + ENDIF + 40 CONTINUE + RJ1=RJ2 + 50 CONTINUE + DEALLOCATE(RAYR2) +*---- +* COMPUTE THE TRANSMISSION PROBABILITIES +*---- + PSSX=1.0-SCALE2*PSSX + IF(NCOUR.EQ.4) THEN + A=XX(JKG) + B=YY(JKG) + DEN1=MAX(2.0*B+A,2.0*A+B) + PBB(1)=B/DEN1 + PBB(2)=MAX(A,2.0*A-B)/DEN1 + PBB(3)=A/DEN1 + PBB(4)=MAX(B,2.0*B-A)/DEN1 + ELSE + PBB(1)=1.0/5.0 + PBB(2)=1.0/5.0 + PBB(3)=1.0/5.0 + ENDIF + DO 65 JC=1,NCOUR + DO 60 IC=1,NCOUR + IF(NCOUR.EQ.4) THEN + IB=ISLR(IC,JC) + ELSE + IB=ISLH(IC,JC) + ENDIF + IF(IB.GT.0) THEN + PSS((JC-1)*NCOUR+IC)=PSSX*PBB(IB) + ELSE + PSS((JC-1)*NCOUR+IC)=0.0 + ENDIF + 60 CONTINUE + 65 CONTINUE + SIGT2(J1+J2)=SIGT2(J1+J2)/SCALE1 + IF(IMPX.GE.8) THEN + CALL SYBPRX(1,NCOUR,J2,JKG,SIGT2(J1+1),SIGW2(J1+1),PP(1,1), + 1 PIS(1,1),PSJ(1,1),PSS(1)) + ENDIF +*---- +* CHECK IF SCATTERING REDUCTION IS REQUIRED +*---- + LSKIP=.TRUE. + DO 70 I=1,J2 + LSKIP=LSKIP.AND.(SIGW2(J1+I).EQ.0.0) + 70 CONTINUE +*---- +* SCATTERING REDUCTION IF LSKIP=.FALSE. +*---- + IF(LSKIP) THEN +* DO NOT PERFORM SCATTERING REDUCTION. + DO 85 I=1,J2 + DO 80 J=1,J2-1 + PIJW(IPIJ+(J-1)*J2+I)=PP(I,J) + 80 CONTINUE + PIJW(IPIJ+(J2-1)*J2+I)=PP(I,J2)*SCALE1 + 85 CONTINUE + DO 95 I=1,J2 + DO 90 JC=1,NCOUR + PISW(IPIS+(JC-1)*J2+I)=PIS(I,JC) + PSJW(IPIS+(I-1)*NCOUR+JC)=PSJ(JC,I) + 90 CONTINUE + 95 CONTINUE + DO 105 IC=1,NCOUR + DO 100 JC=1,NCOUR + PSSW(IPSS+(JC-1)*NCOUR+IC)=PSS((JC-1)*NCOUR+IC) + 100 CONTINUE + 105 CONTINUE + ELSE +* COMPUTE THE SCATTERING-REDUCED COLLISION AND ESCAPE MATRICES. + DO 120 I=1,J2 + DO 110 J=1,J2-1 + PIJW(IPIJ+(J-1)*J2+I)=-PP(I,J)*SIGW2(J1+J) + 110 CONTINUE + PIJW(IPIJ+(J2-1)*J2+I)=-PP(I,J2)*SIGW2(J1+J2)*SCALE1 + PIJW(IPIJ+(I-1)*J2+I)=1.0+PIJW(IPIJ+(I-1)*J2+I) + 120 CONTINUE + CALL ALINV(J2,PIJW(IPIJ+1),J2,IER) + IF(IER.NE.0) CALL XABORT('SYB003: SINGULAR MATRIX.') + ALLOCATE(WORK(J2)) + DO 175 I=1,J2 + DO 130 K=1,J2 + WORK(K)=PIJW(IPIJ+(K-1)*J2+I) + 130 CONTINUE + DO 150 J=1,J2-1 + WGAR=0.0 + DO 140 K=1,J2 + WGAR=WGAR+WORK(K)*PP(K,J) + 140 CONTINUE + PIJW(IPIJ+(J-1)*J2+I)=WGAR + 150 CONTINUE + WGAR=0.0 + DO 155 K=1,J2 + WGAR=WGAR+WORK(K)*PP(K,J2) + 155 CONTINUE + PIJW(IPIJ+(J2-1)*J2+I)=WGAR*SCALE1 + DO 170 JC=1,NCOUR + WGAR=0.0 + DO 160 K=1,J2 + WGAR=WGAR+WORK(K)*PIS(K,JC) + 160 CONTINUE + PISW(IPIS+(JC-1)*J2+I)=WGAR + 170 CONTINUE + 175 CONTINUE + DEALLOCATE(WORK) +* +* COMPUTE THE SCATTERING-REDUCED COLLISION PROBABILITY MATRIX +* FOR INCOMING NEUTRONS. + DO 200 IC=1,NCOUR + DO 190 J=1,J2 + WGAR=PSJ(IC,J) + DO 180 K=1,J2 + WGAR=WGAR+PSJ(IC,K)*SIGW2(J1+K)*PIJW(IPIJ+(J-1)*J2+K) + 180 CONTINUE + PSJW(IPIS+(J-1)*NCOUR+IC)=WGAR + 190 CONTINUE + 200 CONTINUE +* +* COMPUTE THE SCATTERING-REDUCED TRANSMISSION PROBABILITY MATRIX. + DO 230 IC=1,NCOUR + DO 220 JC=1,NCOUR + WGAR=PSS((JC-1)*NCOUR+IC) + DO 210 K=1,J2 + WGAR=WGAR+PSJ(IC,K)*SIGW2(J1+K)*PISW(IPIS+(JC-1)*J2+K) + 210 CONTINUE + PSSW(IPSS+(JC-1)*NCOUR+IC)=WGAR + 220 CONTINUE + 230 CONTINUE + ENDIF + DEALLOCATE(PP,PSJ,PIS) + IF(IMPX.GE.10) THEN + CALL SYBPRX(2,NCOUR,J2,JKG,SIGT2(J1+1),SIGW2(J1+1),PIJW(IPIJ+1), + 1 PISW(IPIS+1),PSJW(IPIS+1),PSSW(IPSS+1)) + ENDIF + IPIJ=IPIJ+J2*J2 + IPIS=IPIS+J2*NCOUR + IPSS=IPSS+NCOUR*NCOUR + 240 CONTINUE + RETURN + END diff --git a/Dragon/src/SYB004.f b/Dragon/src/SYB004.f new file mode 100644 index 0000000..928e72b --- /dev/null +++ b/Dragon/src/SYB004.f @@ -0,0 +1,241 @@ +*DECK SYB004 + SUBROUTINE SYB004 (NGEN,NPIJ,NPIS,NRAYRE,SIGT2,SIGW2,IMPX,NCOUR, + 1 IQUAD,XX,YY,LSECT,NMC,NMCR,RAYRE,MAIL,IZMAIL,RZMAIL,PIJW,PISW, + 2 PSJW,PSSW) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the cellwise scattering-reduced collision, escape and +* transmission probabilities in a 2-D Cartesian or hexagonal assembly +* with DP-0 approximation. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NGEN total number of generating cells. +* NPIJ length of cellwise scattering-reduced collision probability +* matrices. +* NPIS length of cellwise scattering-reduced escape probability +* matrices (NPIS=NMC(NGEN+1)). +* NRAYRE size of array RAYRE (NRAYRE=NMCR(NGEN+1)). +* SIGT2 total macroscopic cross sections. +* SIGW2 P0 within-group scattering macroscopic cross sections. +* IMPX print flag (equal to 0 for no print). +* NCOUR number of currents surrounding the cells (=4 Cartesian +* lattice; =6 hexagonal lattice). +* IQUAD quadrature parameters. +* XX X-thickness of the generating cells. +* YY Y-thickness of the generating cells. +* LSECT type of sectorization. +* NMC offset of the first volume in each generating cell. +* NMCR offset of the first radius in each generating cell. +* RAYRE radius of the tubes in each generating cell. +* MAIL offset of the first tracking information in each generating +* cell. +* IZMAIL integer tracking information. +* RZMAIL real tracking information. +* +*Parameters: output +* PIJW cellwise scattering-reduced collision probability matrices. +* PISW cellwise scattering-reduced escape probability matrices. +* PSJW cellwise scattering-reduced collision probability matrices +* for incoming neutrons. +* PSSW cellwise scattering-reduced transmission probability +* matrices. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NGEN,NPIJ,NPIS,NRAYRE,IMPX,NCOUR,IQUAD(4),LSECT(NGEN), + 1 NMC(NGEN+1),NMCR(NGEN+1),MAIL(2,NGEN),IZMAIL(*) + REAL SIGT2(NPIS),SIGW2(NPIS),XX(NGEN),YY(NGEN),RAYRE(NRAYRE), + 1 RZMAIL(*),PIJW(NPIJ),PISW(NCOUR*NPIS),PSJW(NCOUR*NPIS), + 2 PSSW(NGEN*NCOUR*NCOUR) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (PI=3.141592654,SMALL=5.0E-3,SQRT3=1.732050807568877) + LOGICAL LSKIP + REAL PSS(36),SURFA(6),ALPA(64),PWA(64) + REAL, ALLOCATABLE, DIMENSION(:) :: VOL,WORK + REAL, ALLOCATABLE, DIMENSION(:,:) :: PIS,PSJ,PP +* + IPIJ=0 + IPIS=0 + IPSS=0 + DO 220 JKG=1,NGEN + J1=NMC(JKG) + J2=NMC(JKG+1)-J1 + J1R=NMCR(JKG) + J2R=NMCR(JKG+1)-J1R + ALLOCATE(PIS(J2,NCOUR),PSJ(NCOUR,J2),PP(J2,J2),VOL(J2)) +*---- +* COMPUTE THE REDUCED COLLISION PROBABILITY MATRIX +*---- + A=XX(JKG) + B=YY(JKG) + IF((NCOUR.EQ.4).AND.(LSECT(JKG).NE.0)) THEN +* SECTORIZED CARTESIAN CELL. + IB1=MAIL(1,JKG) + IB2=MAIL(2,JKG) + IF(LSECT(JKG).EQ.-999) THEN + NSECT=4 + ELSE IF((LSECT(JKG).EQ.-1).OR.(LSECT(JKG).EQ.-101)) THEN + NSECT=8 + ELSE + NSECT=4*MOD(ABS(LSECT(JKG)),100) + ENDIF + MNA4=4*IQUAD(1) + CALL SYB4QG(IMPX,1,MNA4,J2R,NSECT,LSECT(JKG),J2,RZMAIL(IB2), + 1 IZMAIL(IB1),A,B,RAYRE(J1R+2),SIGT2(J1+1),SMALL,VOL,PP,PIS,PSS) + ELSE IF(LSECT(JKG).NE.0) THEN +* SECTORIZED HEXAGONAL CELL. + IB1=MAIL(1,JKG) + IB2=MAIL(2,JKG) + NSECT=6 + MNA4=12*IQUAD(1) + CALL SYB7QG(IMPX,1,MNA4,J2R,NSECT,LSECT(JKG),J2,RZMAIL(IB2), + 1 IZMAIL(IB1),A,RAYRE(J1R+2),SIGT2(J1+1),SMALL,VOL,PP,PIS,PSS) + ELSE IF((NCOUR.EQ.4).AND.(J2.EQ.1)) THEN + CALL ALGPT(IQUAD(3),-1.0,1.0,ALPA,PWA) + CALL RECT1(IQUAD(3),A,B,SIGT2(J1+1),SMALL,PP,PIS,PSS,ALPA,PWA) + VOL(1)=A*B + ELSE IF(J2.EQ.1) THEN + CALL ALGPT(IQUAD(3),-1.0,1.0,ALPA,PWA) + CALL XHX2D0(IQUAD(3),ALPA,PWA,A,SIGT2(J1+1),SMALL,PP,PIS,PSS) + VOL(1)=1.5*SQRT3*A*A + ELSE +* NON-SECTORIZED CARTESIAN OR HEXAGONAL CELL. + IB1=MAIL(1,JKG) + IB2=MAIL(2,JKG) + CALL SYBUP0(RZMAIL(IB2),IZMAIL(IB1),NCOUR,J2,SIGT2(J1+1),SMALL, + 1 A,B,IMPX,VOL,PP,PIS,PSS) + ENDIF +*---- +* COMPUTE THE REDUCED COLLISION PROBABILITY MATRIX FOR INCOMING +* NEUTRONS +*---- + DO 65 I=1,J2 + IF(NCOUR.EQ.4) THEN + SURFA(1)=0.25*B + SURFA(2)=0.25*B + SURFA(3)=0.25*A + SURFA(4)=0.25*A + ELSE + DO 50 JC=1,6 + SURFA(JC)=0.25*A + 50 CONTINUE + ENDIF + DO 60 JC=1,NCOUR + PSJ(JC,I)=PIS(I,JC)*VOL(I)/SURFA(JC) + 60 CONTINUE + 65 CONTINUE + DEALLOCATE(VOL) + IF(IMPX.GE.8) THEN + CALL SYBPRX(1,NCOUR,J2,JKG,SIGT2(J1+1),SIGW2(J1+1),PP(1,1), + 1 PIS(1,1),PSJ(1,1),PSS(1)) + ENDIF +*---- +* CHECK IF SCATTERING REDUCTION IS REQUIRED +*---- + LSKIP=.TRUE. + DO 70 I=1,J2 + LSKIP=LSKIP.AND.(SIGW2(J1+I).EQ.0.0) + 70 CONTINUE +*---- +* SCATTERING REDUCTION IF LSKIP=.FALSE. +*---- + IF(LSKIP) THEN +* DO NOT PERFORM SCATTERING REDUCTION. + DO 85 I=1,J2 + DO 80 J=1,J2 + PIJW(IPIJ+(J-1)*J2+I)=PP(I,J) + 80 CONTINUE + 85 CONTINUE + DO 95 I=1,J2 + DO 90 JC=1,NCOUR + PISW(IPIS+(JC-1)*J2+I)=PIS(I,JC) + PSJW(IPIS+(I-1)*NCOUR+JC)=PSJ(JC,I) + 90 CONTINUE + 95 CONTINUE + DO 105 IC=1,NCOUR + DO 100 JC=1,NCOUR + PSSW(IPSS+(JC-1)*NCOUR+IC)=PSS((JC-1)*NCOUR+IC) + 100 CONTINUE + 105 CONTINUE + ELSE +* COMPUTE THE SCATTERING-REDUCED COLLISION AND ESCAPE MATRICES. + DO 120 I=1,J2 + DO 110 J=1,J2 + PIJW(IPIJ+(J-1)*J2+I)=-PP(I,J)*SIGW2(J1+J) + 110 CONTINUE + PIJW(IPIJ+(I-1)*J2+I)=1.0+PIJW(IPIJ+(I-1)*J2+I) + 120 CONTINUE + CALL ALINV(J2,PIJW(IPIJ+1),J2,IER) + IF(IER.NE.0) CALL XABORT('SYB004: SINGULAR MATRIX.') + ALLOCATE(WORK(J2)) + DO 175 I=1,J2 + DO 130 K=1,J2 + WORK(K)=PIJW(IPIJ+(K-1)*J2+I) + 130 CONTINUE + DO 150 J=1,J2 + WGAR=0.0 + DO 140 K=1,J2 + WGAR=WGAR+WORK(K)*PP(K,J) + 140 CONTINUE + PIJW(IPIJ+(J-1)*J2+I)=WGAR + 150 CONTINUE + DO 170 JC=1,NCOUR + WGAR=0.0 + DO 160 K=1,J2 + WGAR=WGAR+WORK(K)*PIS(K,JC) + 160 CONTINUE + PISW(IPIS+(JC-1)*J2+I)=WGAR + 170 CONTINUE + 175 CONTINUE + DEALLOCATE(WORK) +* +* COMPUTE THE SCATTERING-REDUCED COLLISION PROBABILITY MATRIX +* FOR INCOMING NEUTRONS. + DO 195 IC=1,NCOUR + DO 190 J=1,J2 + WGAR=PSJ(IC,J) + DO 180 K=1,J2 + WGAR=WGAR+PSJ(IC,K)*SIGW2(J1+K)*PIJW(IPIJ+(J-1)*J2+K) + 180 CONTINUE + PSJW(IPIS+(J-1)*NCOUR+IC)=WGAR + 190 CONTINUE + 195 CONTINUE +* +* COMPUTE THE SCATTERING-REDUCED TRANSMISSION PROBABILITY MATRIX. + DO 215 IC=1,NCOUR + DO 210 JC=1,NCOUR + WGAR=PSS((JC-1)*NCOUR+IC) + DO 200 K=1,J2 + WGAR=WGAR+PSJ(IC,K)*SIGW2(J1+K)*PISW(IPIS+(JC-1)*J2+K) + 200 CONTINUE + PSSW(IPSS+(JC-1)*NCOUR+IC)=WGAR + 210 CONTINUE + 215 CONTINUE + ENDIF + DEALLOCATE(PP,PSJ,PIS) + IF(IMPX.GE.10) THEN + CALL SYBPRX(2,NCOUR,J2,JKG,SIGT2(J1+1),SIGW2(J1+1),PIJW(IPIJ+1), + 1 PISW(IPIS+1),PSJW(IPIS+1),PSSW(IPSS+1)) + ENDIF + IPIJ=IPIJ+J2*J2 + IPIS=IPIS+J2*NCOUR + IPSS=IPSS+NCOUR*NCOUR + 220 CONTINUE + RETURN + END diff --git a/Dragon/src/SYB005.f b/Dragon/src/SYB005.f new file mode 100644 index 0000000..1a9f852 --- /dev/null +++ b/Dragon/src/SYB005.f @@ -0,0 +1,243 @@ +*DECK SYB005 + SUBROUTINE SYB005 (NGEN,NPIJ,NPIS,NRAYRE,SIGT2,SIGW2,IMPX,NCOUR, + 1 IQUAD,XX,YY,LSECT,NMC,NMCR,RAYRE,MAIL,IZMAIL,RZMAIL,PIJW,PISW, + 2 PSJW,PSSW) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the cellwise scattering-reduced collision, escape and +* transmission probabilities in a 2-D Cartesian or hexagonal assembly +* with DP-1 approximation. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NGEN total number of generating cells. +* NPIJ length of cellwise scattering-reduced collision probability +* matrices. +* NPIS length of cellwise scattering-reduced escape probability +* matrices (NPIS=NMC(NGEN+1)). +* NRAYRE size of array rayre (NRAYRE=NMCR(NGEN+1)). +* SIGT2 total macroscopic cross sections. +* SIGW2 P0 within-group scattering macroscopic cross sections. +* IMPX print flag (equal to 0 for no print). +* NCOUR number of currents surrounding the cells (=12 Cartesian +* lattice; =18 hexagonal lattice). +* IQUAD quadrature parameters. +* XX X-thickness of the generating cells. +* YY Y-thickness of the generating cells. +* LSECT type of sectorization. +* NMC offset of the first volume in each generating cell. +* NMCR offset of the first radius in each generating cell. +* RAYRE radius of the tubes in each generating cell. +* MAIL offset of the first tracking information in each generating +* cell. +* IZMAIL integer tracking information. +* RZMAIL real tracking information. +* +*Parameters: output +* PIJW cellwise scattering-reduced collision probability matrices. +* PISW cellwise scattering-reduced escape probability matrices. +* PSJW cellwise scattering-reduced collision probability matrices +* for incoming neutrons. +* PSSW cellwise scattering-reduced transmission probability +* matrices. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NGEN,NPIJ,NPIS,NRAYRE,IMPX,NCOUR,IQUAD(4),LSECT(NGEN), + 1 NMC(NGEN+1),NMCR(NGEN+1),MAIL(2,NGEN),IZMAIL(*) + REAL SIGT2(NPIS),SIGW2(NPIS),XX(NGEN),YY(NGEN),RAYRE(NRAYRE), + 1 RZMAIL(*),PIJW(NPIJ),PISW(NCOUR*NPIS),PSJW(NCOUR*NPIS), + 2 PSSW(NGEN*NCOUR*NCOUR) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (PI=3.141592654,SMALL=5.0E-3,SQRT3=1.732050807568877) + LOGICAL LSKIP + REAL PSS(324),SURFA(6),ALPA(64),PWA(64) + DOUBLE PRECISION PPP(16) + REAL, ALLOCATABLE, DIMENSION(:) :: VOL,WORK + REAL, ALLOCATABLE, DIMENSION(:,:) :: PIS,PSJ,PP +* + IPIJ=0 + IPIS=0 + IPSS=0 + DO 240 JKG=1,NGEN + J1=NMC(JKG) + J2=NMC(JKG+1)-J1 + J1R=NMCR(JKG) + J2R=NMCR(JKG+1)-J1R + ALLOCATE(PIS(J2,NCOUR),PSJ(NCOUR,J2),PP(J2,J2),VOL(J2)) +*---- +* COMPUTE THE REDUCED COLLISION PROBABILITY MATRIX +*---- + A=XX(JKG) + B=YY(JKG) + IF((NCOUR.EQ.12).AND.(LSECT(JKG).NE.0)) THEN +* SECTORIZED CARTESIAN CELL. + IB1=MAIL(1,JKG) + IB2=MAIL(2,JKG) + IF(LSECT(JKG).EQ.-999) THEN + NSECT=4 + ELSE IF((LSECT(JKG).EQ.-1).OR.(LSECT(JKG).EQ.-101)) THEN + NSECT=8 + ELSE + NSECT=4*MOD(ABS(LSECT(JKG)),100) + ENDIF + MNA4=4*IQUAD(1) + CALL SYB4QG(IMPX,3,MNA4,J2R,NSECT,LSECT(JKG),J2,RZMAIL(IB2), + 1 IZMAIL(IB1),A,B,RAYRE(J1R+2),SIGT2(J1+1),SMALL,VOL,PP,PIS,PSS) + ELSE IF(LSECT(JKG).NE.0) THEN +* SECTORIZED HEXAGONAL CELL. + IB1=MAIL(1,JKG) + IB2=MAIL(2,JKG) + NSECT=6 + MNA4=12*IQUAD(1) + CALL SYB7QG(IMPX,3,MNA4,J2R,NSECT,LSECT(JKG),J2,RZMAIL(IB2), + 1 IZMAIL(IB1),A,RAYRE(J1R+2),SIGT2(J1+1),SMALL,VOL,PP,PIS,PSS) + ELSE IF((NCOUR.EQ.12).AND.(J2.EQ.1)) THEN + CALL ALGPT(IQUAD(3),-1.0,1.0,ALPA,PWA) + CALL RECT2(IQUAD(3),A,B,SIGT2(J1+1),SMALL,PP,PIS,PSS,ALPA,PWA) + VOL(1)=A*B + ELSE IF(J2.EQ.1) THEN + CALL ALGPT(IQUAD(3),-1.0,1.0,ALPA,PWA) + CALL XHX2D1(IQUAD(3),ALPA,PWA,A,SIGT2(J1+1),SMALL,PP,PIS,PSS, + 1 PPP) + VOL(1)=1.5*SQRT3*A*A + ELSE +* NON-SECTORIZED CARTESIAN OR HEXAGONAL CELL. + IB1=MAIL(1,JKG) + IB2=MAIL(2,JKG) + CALL SYBUP1(RZMAIL(IB2),IZMAIL(IB1),NCOUR/3,J2,SIGT2(J1+1), + 1 SMALL,A,B,IMPX,VOL,PP,PIS,PSS) + ENDIF +*---- +* COMPUTE THE REDUCED COLLISION PROBABILITY MATRIX FOR INCOMING +* NEUTRONS +*---- + DO 65 I=1,J2 + IF(NCOUR.EQ.12) THEN + SURFA(1)=0.25*B + SURFA(2)=0.25*B + SURFA(3)=0.25*A + SURFA(4)=0.25*A + ELSE + DO 50 JC=1,6 + SURFA(JC)=0.25*A + 50 CONTINUE + ENDIF + DO 60 JC=1,NCOUR + PSJ(JC,I)=PIS(I,JC)*VOL(I)/SURFA(1+(JC-1)/3) + 60 CONTINUE + 65 CONTINUE + DEALLOCATE(VOL) + IF(IMPX.GE.8) THEN + CALL SYBPRX(1,NCOUR,J2,JKG,SIGT2(J1+1),SIGW2(J1+1),PP(1,1), + 1 PIS(1,1),PSJ(1,1),PSS(1)) + ENDIF +*---- +* CHECK IF SCATTERING REDUCTION IS REQUIRED +*---- + LSKIP=.TRUE. + DO 70 I=1,J2 + LSKIP=LSKIP.AND.(SIGW2(J1+I).EQ.0.0) + 70 CONTINUE +*---- +* SCATTERING REDUCTION IF LSKIP=.FALSE. +*---- + IF(LSKIP) THEN +* DO NOT PERFORM SCATTERING REDUCTION. + DO 85 I=1,J2 + DO 80 J=1,J2 + PIJW(IPIJ+(J-1)*J2+I)=PP(I,J) + 80 CONTINUE + 85 CONTINUE + DO 95 I=1,J2 + DO 90 JC=1,NCOUR + PISW(IPIS+(JC-1)*J2+I)=PIS(I,JC) + PSJW(IPIS+(I-1)*NCOUR+JC)=PSJ(JC,I) + 90 CONTINUE + 95 CONTINUE + DO 105 IC=1,NCOUR + DO 100 JC=1,NCOUR + PSSW(IPSS+(JC-1)*NCOUR+IC)=PSS((JC-1)*NCOUR+IC) + 100 CONTINUE + 105 CONTINUE + ELSE +* COMPUTE THE SCATTERING-REDUCED COLLISION AND ESCAPE MATRICES. + DO 120 I=1,J2 + DO 110 J=1,J2 + PIJW(IPIJ+(J-1)*J2+I)=-PP(I,J)*SIGW2(J1+J) + 110 CONTINUE + PIJW(IPIJ+(I-1)*J2+I)=1.0+PIJW(IPIJ+(I-1)*J2+I) + 120 CONTINUE + CALL ALINV(J2,PIJW(IPIJ+1),J2,IER) + IF(IER.NE.0) CALL XABORT('SYB005: SINGULAR MATRIX.') + ALLOCATE(WORK(J2)) + DO 175 I=1,J2 + DO 130 K=1,J2 + WORK(K)=PIJW(IPIJ+(K-1)*J2+I) + 130 CONTINUE + DO 150 J=1,J2 + WGAR=0.0 + DO 140 K=1,J2 + WGAR=WGAR+WORK(K)*PP(K,J) + 140 CONTINUE + PIJW(IPIJ+(J-1)*J2+I)=WGAR + 150 CONTINUE + DO 170 JC=1,NCOUR + WGAR=0.0 + DO 160 K=1,J2 + WGAR=WGAR+WORK(K)*PIS(K,JC) + 160 CONTINUE + PISW(IPIS+(JC-1)*J2+I)=WGAR + 170 CONTINUE + 175 CONTINUE + DEALLOCATE(WORK) +* +* COMPUTE THE SCATTERING-REDUCED COLLISION PROBABILITY MATRIX +* FOR INCOMING NEUTRONS. + DO 200 IC=1,NCOUR + DO 190 J=1,J2 + WGAR=PSJ(IC,J) + DO 180 K=1,J2 + WGAR=WGAR+PSJ(IC,K)*SIGW2(J1+K)*PIJW(IPIJ+(J-1)*J2+K) + 180 CONTINUE + PSJW(IPIS+(J-1)*NCOUR+IC)=WGAR + 190 CONTINUE + 200 CONTINUE +* +* COMPUTE THE SCATTERING-REDUCED TRANSMISSION PROBABILITY MATRIX. + DO 230 IC=1,NCOUR + DO 220 JC=1,NCOUR + WGAR=PSS((JC-1)*NCOUR+IC) + DO 210 K=1,J2 + WGAR=WGAR+PSJ(IC,K)*SIGW2(J1+K)*PISW(IPIS+(JC-1)*J2+K) + 210 CONTINUE + PSSW(IPSS+(JC-1)*NCOUR+IC)=WGAR + 220 CONTINUE + 230 CONTINUE + ENDIF + DEALLOCATE(PP,PSJ,PIS) + IF(IMPX.GE.10) THEN + CALL SYBPRX(2,NCOUR,J2,JKG,SIGT2(J1+1),SIGW2(J1+1),PIJW(IPIJ+1), + 1 PISW(IPIS+1),PSJW(IPIS+1),PSSW(IPSS+1)) + ENDIF + IPIJ=IPIJ+J2*J2 + IPIS=IPIS+J2*NCOUR + IPSS=IPSS+NCOUR*NCOUR + 240 CONTINUE + RETURN + END diff --git a/Dragon/src/SYB31C.f b/Dragon/src/SYB31C.f new file mode 100644 index 0000000..5d914a1 --- /dev/null +++ b/Dragon/src/SYB31C.f @@ -0,0 +1,141 @@ +*DECK SYB31C + SUBROUTINE SYB31C (PPLUS,TAUP,XOPJ,XOPI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Evaluation of the $C_{ij}$ function in 1D cylindrical and 2D geometry. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* TAUP side to side optical path. +* XOPJ optical path in volume j (or volume i). +* XOPI optical path in volume i (or volume j). +* +*Parameters: output +* PPLUS value of the probability. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + REAL PPLUS,TAUP,XOPJ,XOPI +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MKI3=600) + REAL T(2,2),B(2,2) + COMMON /BICKL3/BI3(0:MKI3),BI31(0:MKI3),BI32(0:MKI3),PAS3,XLIM3,L3 +*---- +* ASYMPTOTIC VALUE +*---- + IF(TAUP.GE.XLIM3) THEN + PPLUS = 0. + RETURN + ENDIF +*---- +* SYMMETRIC FORMULA IN (I,J). WE SET POPI <= POPJ +*---- + IF(XOPJ.LT.XOPI) THEN + POPI = XOPJ + POPJ = XOPI + ELSE + POPI = XOPI + POPJ = XOPJ + ENDIF +*---- +* GENERAL CASE +* +* POPI < POPJ < 1. +* VOID (I,J) UP TO THE END OF PROGRAM +*---- + T(2,2) = TAUP + POPJ + POPI + T(1,2) = TAUP + POPJ + T(2,1) = TAUP + POPI + T(1,1) = TAUP +* + DO 15 I=1,2 + DO 10 J=1,2 + B(I,J) = TABKI(3,T(I,J)) + 10 CONTINUE + 15 CONTINUE +*---- +* GENERAL DIFFERENCE FORMULA. THIS FORMULAS SHOULD NOT BE APPLIED TO +* VOIDED (I,J) VOLUMES +*---- + IF(POPI.GE.0.004) THEN +* LARGE POPI AND POPJ (MOST GENERAL CASE) + PNLUS = B(2,2) + B(1,1) - (B(1,2) + B(2,1)) + PPLUS = PNLUS + ELSE IF(POPJ.GT.0.002) THEN +* SMALL POPI, LARGE POPJ. USE DERIVATIVE DIFFERENCES. + IF(TAUP.GE.XLIM3) THEN + APLUS=0. + ELSE IF(TAUP+POPI.GE.XLIM3) THEN + APLUS=TABKI(3,TAUP) + ELSE IF(POPI.LE.0.002) THEN + APLUS=(TABKI(2,TAUP)+TABKI(2,TAUP+POPI))*POPI*0.5 + ELSE IF(POPI.LT.0.004) THEN + PQLUS=(TABKI(2,TAUP)+TABKI(2,TAUP+POPI))*POPI*0.5 + PRLUS=TABKI(3,TAUP)-TABKI(3,TAUP+POPI) + FACT=500.0*(POPI-0.002) + APLUS=PRLUS*FACT+PQLUS*(1.0-FACT) + ELSE + APLUS=TABKI(3,TAUP)-TABKI(3,TAUP+POPI) + ENDIF + IF(TAUP+POPJ.GE.XLIM3) THEN + BPLUS=0. + ELSE IF(TAUP+POPI+POPJ.GE.XLIM3) THEN + BPLUS=TABKI(3,TAUP+POPJ) + ELSE IF(POPI.LE.0.002) THEN + BPLUS=(TABKI(2,TAUP+POPJ)+TABKI(2,TAUP+POPI+POPJ))*POPI*0.5 + ELSE IF(POPI.LT.0.004) THEN + PQLUS=(TABKI(2,TAUP+POPJ)+TABKI(2,TAUP+POPI+POPJ))*POPI*0.5 + PRLUS=TABKI(3,TAUP+POPJ)-TABKI(3,TAUP+POPI+POPJ) + FACT=500.0*(POPI-0.002) + BPLUS=PRLUS*FACT+PQLUS*(1.0-FACT) + ELSE + BPLUS=TABKI(3,TAUP+POPJ)-TABKI(3,TAUP+POPI+POPJ) + ENDIF + PPLUS = APLUS - BPLUS + ELSE IF(T(2,2).GE.XLIM3) THEN +* SIMILAR TO A SECOND DERIVATIVE. ASYMPTOTIC TAUP. + PNLUS = B(2,2) + B(1,1) - (B(1,2) + B(2,1)) + PPLUS = PNLUS + ELSE +* SIMILAR TO A SECOND DERIVATIVE. + IF(T(2,2).EQ.0.) THEN + PPLUS = 0. + ELSE IF(TAUP.EQ.0.) THEN + PPLUS = 1.57079632679489 + TABKI(1,TAUP+POPI+POPJ) + PPLUS = PPLUS * 0.5 * POPI*POPJ + ELSE IF(TAUP.LE.0.002) THEN + PPLUS = TABKI(1,TAUP) + TABKI(1,TAUP+POPI+POPJ) + PPLUS = PPLUS * 0.5 * POPI*POPJ + ELSE IF(TAUP.LT.0.004) THEN + PQLUS = TABKI(1,TAUP) + TABKI(1,TAUP+POPI+POPJ) + PRLUS = TABKI(1,TAUP) + TAUP1 = TAUP + POPI + POPJ + PRLUS = PRLUS + TABKI(1,TAUP1) + FACT=500.0*(TAUP-0.002) + PPLUS = PRLUS * FACT + PQLUS * (1.0-FACT) + PPLUS = PPLUS * 0.5 * POPI*POPJ + ELSE +* VOIDED VOLUMES (I,J) SEPARATED WITH NON-VOIDED VOLUMES. + PRLUS = TABKI(1,TAUP) + TAUP1 = TAUP + POPI + POPJ + PRLUS = PRLUS + TABKI(1,TAUP1) + PPLUS = PRLUS * 0.5 * POPI*POPJ + ENDIF + ENDIF + RETURN + END diff --git a/Dragon/src/SYB32C.f b/Dragon/src/SYB32C.f new file mode 100644 index 0000000..f091425 --- /dev/null +++ b/Dragon/src/SYB32C.f @@ -0,0 +1,55 @@ +*DECK SYB32C + SUBROUTINE SYB32C (PPLUS,TAUP,POPI,M) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Evaluation of the $E_i$ function in 2D geometry. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* TAUP initial optical path. +* POPI delta optical path. +* M order of the Bickley function (equal to M+1). +* +*Parameters: output +* PPLUS value of the difference. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + REAL PPLUS,TAUP,POPI + INTEGER M +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MKI3=600) + COMMON /BICKL3/BI3(0:MKI3),BI31(0:MKI3),BI32(0:MKI3),PAS3,XLIM3,L3 +* + TAUQ=TAUP+POPI + IF(TAUP.GE.XLIM3) THEN + PPLUS=0. + ELSE IF(TAUQ.GE.XLIM3) THEN + PPLUS=TABKI(M+1,TAUP) + ELSE IF(POPI.LE.0.002) THEN + PPLUS=(TABKI(M,TAUP)+TABKI(M,TAUQ))*POPI*0.5 + ELSE IF(POPI.LT.0.004) THEN + PQLUS=(TABKI(M,TAUP)+TABKI(M,TAUQ))*POPI*0.5 + PRLUS=TABKI(M+1,TAUP)-TABKI(M+1,TAUQ) + FACT=500.0*(POPI-0.002) + PPLUS=PRLUS*FACT+PQLUS*(1.0-FACT) + ELSE + PPLUS=TABKI(M+1,TAUP)-TABKI(M+1,TAUQ) + ENDIF + RETURN + END diff --git a/Dragon/src/SYB33C.f b/Dragon/src/SYB33C.f new file mode 100644 index 0000000..1fa6686 --- /dev/null +++ b/Dragon/src/SYB33C.f @@ -0,0 +1,44 @@ +*DECK SYB33C + SUBROUTINE SYB33C (PPLUS,TAUP) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Evaluation of the $D_i$ function in 1D cylindrical and 2D geometry. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* TAUP optical path. +* +*Parameters: output +* PPLUS value of the expression. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + REAL PPLUS,TAUP +* + IF (TAUP .EQ. 0.0) THEN + PPLUS=0.0 + ELSE IF (TAUP .GT. 0.004) THEN + PPLUS=TAUP+TABKI(3,TAUP)-TABKI(3,0.0) + ELSE IF (TAUP .GT. 0.002) THEN + PPLUS=TAUP+TABKI(3,TAUP)-TABKI(3,0.0) + PQLUS= 0.5*TAUP*TAUP*TABKI(1,TAUP*0.5) + FACT=500.0*(TAUP-0.002) + PPLUS=PPLUS*FACT+PQLUS*(1.0-FACT) + ELSE + PPLUS=0.5*TAUP*TAUP*TABKI(1,TAUP*0.5) + ENDIF + RETURN + END diff --git a/Dragon/src/SYB41C.f b/Dragon/src/SYB41C.f new file mode 100644 index 0000000..d87177a --- /dev/null +++ b/Dragon/src/SYB41C.f @@ -0,0 +1,72 @@ +*DECK SYB41C + SUBROUTINE SYB41C(PP,TAU0,TAUI,TAUJ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Evaluation of the $C_{ij}$ function in 1D spherical geometry. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* TAU0 side to side optical path. +* TAUI optical path in volume i (or volume j). +* TAUJ optical path in volume j (or volume i). +* +*Parameters: output +* PP value of the expression. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + REAL PP,TAU0,TAUI,TAUJ +*---- +* SYMMETRIC FORMULA IN (I,J). WE SET POPI <= POPJ +*---- + IF(TAUJ.LT.TAUI) THEN + POPI = TAUJ + POPJ = TAUI + ELSE + POPI = TAUI + POPJ = TAUJ + ENDIF + IF(POPI.GT.0.004) THEN + PP=EXP(-TAU0)-EXP(-(TAU0+POPI))-EXP(-(TAU0+POPJ))+ + 1 EXP(-(TAU0+POPI+POPJ)) + ELSE IF((POPI.GT.0.002).AND.(POPJ.GT.0.004)) THEN + PP=EXP(-TAU0)-EXP(-(TAU0+POPI))-EXP(-(TAU0+POPJ))+ + 1 EXP(-(TAU0+POPI+POPJ)) + PQ=POPI*(EXP(-TAU0)-EXP(-(TAU0+POPJ))) + FACTI=500.0*(POPI-0.002) + PP=PP*FACTI+PQ*(1.0-FACTI) + ELSE IF((POPI.GT.0.002).AND.(POPJ.GT.0.002)) THEN + PP=EXP(-TAU0)-EXP(-(TAU0+POPI))-EXP(-(TAU0+POPJ))+ + 1 EXP(-(TAU0+POPI+POPJ)) + PQ=POPI*(EXP(-TAU0)-EXP(-(TAU0+POPJ))) + PR=POPJ*(EXP(-TAU0)-EXP(-(TAU0+POPI))) + PS=POPI*POPJ*EXP(-TAU0) + FACTI=500.0*(POPI-0.002) + FACTJ=500.0*(POPJ-0.002) + PP=PP*FACTI*FACTJ+PQ*(1.0-FACTI)*FACTJ+PR*FACTI*(1.0-FACTJ) + 1 +PS*(1.0-FACTI)*(1.0-FACTJ) + ELSE IF(POPJ.GT.0.004) THEN + PP=POPI*(EXP(-TAU0)-EXP(-(TAU0+POPJ))) + ELSE IF(POPJ.GT.0.002) THEN + PP=POPI*(EXP(-TAU0)-EXP(-(TAU0+POPJ))) + PS=POPI*POPJ*EXP(-TAU0) + FACTJ=500.0*(POPJ-0.002) + PP=PP*FACTJ+PS*(1.0-FACTJ) + ELSE + PP=POPI*POPJ*EXP(-TAU0) + ENDIF + RETURN + END diff --git a/Dragon/src/SYB43C.f b/Dragon/src/SYB43C.f new file mode 100644 index 0000000..1fbfb0b --- /dev/null +++ b/Dragon/src/SYB43C.f @@ -0,0 +1,42 @@ +*DECK SYB43C + SUBROUTINE SYB43C(PP,TAUI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Evaluation of the $D_i$ function in 1D spherical geometry. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* TAUI optical path in volume i. +* +*Parameters: output +* PP value of the expression. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + REAL PP,TAUI +* + IF(TAUI.GT.0.004) THEN + PP=TAUI-1.0+EXP(-TAUI) + ELSE IF(TAUI.GT.0.002) THEN + PP=TAUI-1.0+EXP(-TAUI) + PQ=0.5*(TAUI**2) + FACT=500.0*(TAUI-0.002) + PP=PP*FACT+PQ*(1.0-FACT) + ELSE + PP=0.5*(TAUI**2) + ENDIF + RETURN + END diff --git a/Dragon/src/SYB4QG.f b/Dragon/src/SYB4QG.f new file mode 100644 index 0000000..f12e542 --- /dev/null +++ b/Dragon/src/SYB4QG.f @@ -0,0 +1,277 @@ +*DECK SYB4QG + SUBROUTINE SYB4QG (IMPX,NCURR,MNA4,NRD,NSECT,LSECT,NREG,ZZR,ZZI, + 1 A,B,RAYRE,SIGTR,TRONC,VOL,PIJ,PVS,PSS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the one-group collision, leakage and transmission +* probabilities in a Cartesian sectorized cell. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IMPX print parameter (equal to zero for no print). +* NCURR type of interface currents (=1 DP-0; =3 DP-1). +* MNA4 number of angles in (0,$\\pi$/2). +* NRD one plus the number of tubes in the cell. +* NSECT number of sectors. +* LSECT type of sectorization: +* =-999 no sectorization / processed as a sectorized cell; +* =-101 X-type sectorization of the coolant; +* =-1 X-type sectorization of the cell; +* =101 +-type sectorization of the coolant; +* =1 +-type sectorization of the cell; +* =102 + and X-type sectorization of the coolant; +* =2 + and X-type sectorization of the cell. +* NREG number of regions. +* ZZR real tracking elements. +* ZZI integer tracking elements. +* A size of the external X side. +* B size of the external Y side. +* RAYRE radius of the tubes. +* SIGTR total macroscopic cross section. +* TRONC voided block criterion. +* +*Parameters: output +* VOL volumes. +* PIJ volume to volume reduced probability. +* PVS volume to surface probabilities: +* XINF surface 1; XSUP surface 2; +* YINF surface 3; YSUP surface 4. +* PSS surface to surface probabilities in the following order: +* PSS(i,j) is the probability from surface i to surface j. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IMPX,NCURR,MNA4,NRD,NSECT,LSECT,NREG,ZZI(*) + REAL ZZR(*),A,B,RAYRE(NRD-1),SIGTR(NREG),TRONC,VOL(NREG), + 1 PIJ(NREG,NREG),PVS(NREG,4*NCURR),PSS(4*NCURR,4*NCURR) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (SIGVID=1.0E-10,NSURFQ=4) + INTEGER IPER(3) + REAL QSS(54) + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NUMREG + REAL, ALLOCATABLE, DIMENSION(:) :: WORKIJ,G + REAL, ALLOCATABLE, DIMENSION(:,:) :: VOLINT + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: PSIX + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LGFULL +*---- +* DATA STATEMENT AND INLINE FUNCTIONS +*---- + SAVE IPER + DATA IPER/1,3,2/ + INC(IC,IH)=(IC-1)*NCURR+IPER(IH) + INQ(IH,JH,IS)=(IS-1)*NCURR*NCURR+(IH-1)*NCURR+JH +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NUMREG(NSECT,NRD)) + ALLOCATE(VOLINT(NSECT,NRD),WORKIJ(0:(NREG+4)*(NREG+5)/2-1), + 1 PSIX(0:3,NCURR,NREG),G(NREG+4)) + ALLOCATE(LGFULL(NREG)) +*---- +* COMPUTE THE VOLUMES +*---- + CALL SYB4VO(NSECT,NRD,A,B,RAYRE,VOLINT) + IND=0 + DO 30 I=1,NRD-1 + IF(ABS(LSECT).GT.100) THEN + IND=IND+1 + DO 10 ISEC=1,NSECT + NUMREG(ISEC,I)=IND + 10 CONTINUE + ELSE IF(LSECT.EQ.-1) THEN + NUMREG(1,I)=IND+4 + NUMREG(2,I)=IND+1 + NUMREG(3,I)=IND+1 + NUMREG(4,I)=IND+2 + NUMREG(5,I)=IND+2 + NUMREG(6,I)=IND+3 + NUMREG(7,I)=IND+3 + NUMREG(8,I)=IND+4 + IND=IND+4 + ELSE + DO 20 ISEC=1,NSECT + IND=IND+1 + NUMREG(ISEC,I)=IND + 20 CONTINUE + ENDIF + 30 CONTINUE + IF(LSECT.EQ.-999) THEN + IND=IND+1 + DO 40 ISEC=1,NSECT + NUMREG(ISEC,I)=IND + 40 CONTINUE + ELSE IF((LSECT.EQ.-1).OR.(LSECT.EQ.-101)) THEN + NUMREG(1,I)=IND+4 + NUMREG(2,I)=IND+1 + NUMREG(3,I)=IND+1 + NUMREG(4,I)=IND+2 + NUMREG(5,I)=IND+2 + NUMREG(6,I)=IND+3 + NUMREG(7,I)=IND+3 + NUMREG(8,I)=IND+4 + IND=IND+4 + ELSE + DO 50 ISEC=1,NSECT + IND=IND+1 + NUMREG(ISEC,I)=IND + 50 CONTINUE + ENDIF + DO 60 I=1,NREG + VOL(I)=0.0 + 60 CONTINUE + DO 75 IR=1,NRD + DO 70 IS=1,NSECT + IND=NUMREG(IS,IR) + VOL(IND)=VOL(IND)+VOLINT(IS,IR) + 70 CONTINUE + 75 CONTINUE +*---- +* CHECH FOR VOIDED REGIONS +*---- + DO 80 IR=1,NREG + IF(VOL(IR) .GT. 0.) THEN + DR=SQRT(VOL(IR)) + ELSE + DR=0.0 + ENDIF + LGFULL(IR)=(SIGTR(IR)*DR).GT.TRONC + IF(SIGTR(IR).LE.SIGVID) SIGTR(IR)=SIGVID + 80 CONTINUE +*---- +* COMPUTE COLLISION, DP-0 ESCAPE AND DP-0 TRANSMISSION PROBABILITIES +*---- + MZIS=ZZI(1) + MZRS=ZZI(2) + CALL SYBUQV(ZZR(MZRS),ZZI(MZIS),NSURFQ,NREG,SIGTR,MNA4,LGFULL, + 1 WORKIJ) +*---- +* STAMM'LER RENORMALIZATION +*---- + G(1)=A/4.0 + G(2)=B/4.0 + G(3)=A/4.0 + G(4)=B/4.0 + DO 100 IR=1,NREG + G(4+IR)=SIGTR(IR)*VOL(IR) + 100 CONTINUE +* FIRST APPLY THE ORTHONORMALIZATION FACTOR: + DO 105 I=0,(NSURFQ+NREG)*(NSURFQ+NREG+1)/2-1 + WORKIJ(I)=WORKIJ(I)*ZZR(MZRS)*ZZR(MZRS) + 105 CONTINUE +* +* THEN PERFORM STAMM'LER NORMALIZATION: + CALL SYBRHL(IMPX,NSURFQ,NREG,G,WORKIJ) +* + IIJ=NSURFQ*(NSURFQ+1)/2-1 + DO 120 JR=1,NREG + IIJ=IIJ+NSURFQ + DO 110 IR=1,JR-1 + AUX=WORKIJ(IIJ+IR)/(SIGTR(IR)*SIGTR(JR)) + PIJ(IR,JR)=AUX/VOL(IR) + PIJ(JR,IR)=AUX/VOL(JR) + 110 CONTINUE + IIJ=IIJ+JR + AUX=WORKIJ(IIJ)/(SIGTR(JR)*SIGTR(JR)) + PIJ(JR,JR)=AUX/VOL(JR) + 120 CONTINUE +*---- +* PIS AND PSS CALCULATION +*---- + IF(NCURR.GT.1) THEN +* PERFORM A DP-1 CALCULATION USING THE TRACKING. + CALL SYBUQ0(ZZR(MZRS),ZZI(MZIS),NSURFQ,NREG,SIGTR,MNA4, + 1 LGFULL,PSIX(0,1,1),QSS) +* + DO 132 JS=0,NSURFQ-1 + DO 131 IH=1,NCURR + DO 130 IR=1,NREG + ZNOR=G(JS+1)+G(NSURFQ+IR) + PSIX(JS,IH,IR)=ZNOR*PSIX(JS,IH,IR)/SIGTR(IR)/VOL(IR) + 130 CONTINUE + 131 CONTINUE + 132 CONTINUE + IIQ=1 + DO 142 JS=0,NSURFQ-1 + DO 141 IS=0,JS-1 + ZNOR=G(IS+1)+G(JS+1) + DO 140 IH=1,NCURR*NCURR + QSS(IIQ)=ZNOR*QSS(IIQ) + IIQ=IIQ+1 + 140 CONTINUE + 141 CONTINUE + 142 CONTINUE + ELSE +* RECOVER PSI AND PSS INFORMATION FROM DP-0 PIJ CALCULATION. + IIQ=1 + IIJ=0 + DO 160 JS=0,NSURFQ-1 + DO 150 IS=0,JS-1 + QSS(IIQ)=4.0*WORKIJ(IIJ) + IIQ=IIQ+NCURR*NCURR + IIJ=IIJ+1 + 150 CONTINUE + IIJ=IIJ+1 + 160 CONTINUE + IIJ=NSURFQ*(NSURFQ+1)/2 + DO 180 IR=1,NREG + DO 170 JS=0,NSURFQ-1 + PSIX(JS,1,IR)=WORKIJ(IIJ+JS)/SIGTR(IR)/VOL(IR) + 170 CONTINUE + IIJ=IIJ+NSURFQ+IR + 180 CONTINUE + ENDIF +*---- +* LOAD THE EURYDICE CP ARRAYS +*---- + DO 191 I=1,NREG + DO 190 IH=1,NCURR + PVS(I,INC(1,IH))=PSIX(3,IH,I) + PVS(I,INC(2,IH))=PSIX(1,IH,I) + PVS(I,INC(3,IH))=PSIX(0,IH,I) + PVS(I,INC(4,IH))=PSIX(2,IH,I) + 190 CONTINUE + 191 CONTINUE + DO 201 I=1,4*NCURR + DO 200 J=1,4*NCURR + PSS(I,J)=0.0 + 200 CONTINUE + 201 CONTINUE + DO 220 IH=1,NCURR + DO 210 JH=1,NCURR + PSS(INC(2,IH),INC(1,JH))=QSS(INQ(IH,JH,5))/B + PSS(INC(3,IH),INC(1,JH))=QSS(INQ(JH,IH,4))/A + PSS(INC(4,IH),INC(1,JH))=QSS(INQ(JH,IH,6))/A + PSS(INC(1,IH),INC(2,JH))=QSS(INQ(IH,JH,5))/B + PSS(INC(3,IH),INC(2,JH))=QSS(INQ(JH,IH,1))/A + PSS(INC(4,IH),INC(2,JH))=QSS(INQ(IH,JH,3))/A + PSS(INC(1,IH),INC(3,JH))=QSS(INQ(IH,JH,4))/B + PSS(INC(2,IH),INC(3,JH))=QSS(INQ(IH,JH,1))/B + PSS(INC(4,IH),INC(3,JH))=QSS(INQ(IH,JH,2))/A + PSS(INC(1,IH),INC(4,JH))=QSS(INQ(IH,JH,6))/B + PSS(INC(2,IH),INC(4,JH))=QSS(INQ(JH,IH,3))/B + PSS(INC(3,IH),INC(4,JH))=QSS(INQ(IH,JH,2))/A + 210 CONTINUE + 220 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(LGFULL) + DEALLOCATE(G,PSIX,WORKIJ,VOLINT) + DEALLOCATE(NUMREG) + RETURN + END diff --git a/Dragon/src/SYB4T1.f b/Dragon/src/SYB4T1.f new file mode 100644 index 0000000..fe24926 --- /dev/null +++ b/Dragon/src/SYB4T1.f @@ -0,0 +1,65 @@ +*DECK SYB4T1 + SUBROUTINE SYB4T1 (NIR,JMINRB,XCOTEB,COSPHI,Y0,ORIGIN,PENTES, + & ANGLES,IXRAYO,DELTAH,DXMIN,DELTAC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the position of the next track intersecting with side 1 in a +* sectorized Cartesian cell. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NIR number of radius. +* JMINRB index of the first radius intercepting the side. +* XCOTEB radius interceptions. +* COSPHI cosinus. +* Y0 position of the tube center. +* ORIGIN origin of the track. +* PENTES slope of the track. +* ANGLES slope of the sector. +* IXRAYO index of the radius. +* DELTAH position of the south-west corner. +* DXMIN accuracy. +* +*Parameters: output +* DELTAC position of the next trajectory. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NIR,JMINRB,IXRAYO + REAL XCOTEB(JMINRB:NIR),COSPHI,Y0,ORIGIN,PENTES,ANGLES,DELTAH, + & DXMIN,DELTAC +* +* Rayon Exterieur Suivant + IF (JMINRB .LE. NIR) THEN + IF (IXRAYO .LE. NIR) THEN + Y = XCOTEB(IXRAYO) + D = Y * COSPHI - Y0 + DELTAC = MIN(DELTAC, D) + ENDIF + ENDIF +* +* Secteur Suivant + DA = ANGLES - PENTES + IF (ABS (DA) .GT. DXMIN) THEN + D = ORIGIN / DA + DELTAC = MIN(DELTAC, D) + ENDIF +* +* Coin Sud-West + DELTAC = MIN(DELTAC, DELTAH) +* + RETURN + END diff --git a/Dragon/src/SYB4T2.f b/Dragon/src/SYB4T2.f new file mode 100644 index 0000000..2f71ab9 --- /dev/null +++ b/Dragon/src/SYB4T2.f @@ -0,0 +1,72 @@ +*DECK SYB4T2 + SUBROUTINE SYB4T2 (NIR,JMINRA,XCOTEA,SINPHI,DCOTEB,COSPHI,ORIGIN, + & PENTES,ANGLES,IXRAYO,HXRAYO,DXMIN,DELTAC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the position of the next track intersecting with side 2 (west +* side) in a sectorized Cartesian cell. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NIR number of radius. +* JMINRA index of the first radius intercepting the side. +* XCOTEA radius interceptions. +* SINPHI sinus +* DCOTEB half-side of the rectangle (center-side position). +* COSPHI cosinus. +* ORIGIN origin of the track. +* PENTES slope of the track. +* ANGLES slope of the sector. +* IXRAYO index of the radius. +* HXRAYO central radius (generally a negative number). +* DXMIN accuracy. +* +*Parameters: output +* DELTAC position of the next trajectory. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NIR,JMINRA,IXRAYO + REAL XCOTEA(JMINRA:NIR),SINPHI,DCOTEB,COSPHI,ORIGIN,PENTES, + & ANGLES,HXRAYO,DXMIN,DELTAC +* +* Rayon Exterieur Suivant + IF (JMINRA .LE. NIR) THEN + H0 = - DCOTEB * SINPHI + IF ((IXRAYO .EQ. JMINRA) .OR. (HXRAYO .GE. H0)) THEN + IR = IXRAYO + S = 1. + ELSE + IR = IXRAYO - 1 + S = - 1. + ENDIF + IF (IR .LE. NIR) THEN + X = S * XCOTEA(IR) + D = DCOTEB * COSPHI + X * SINPHI + DELTAC = MIN(DELTAC, D) + ENDIF + ENDIF +* +* Secteur Suivant + DA = ANGLES - PENTES + D = ABS(ANGLES) + ABS(PENTES) + IF (ABS(DA) .GT. DXMIN*D) THEN + D = ORIGIN / DA + DELTAC = MIN(DELTAC, D) + ENDIF +* + RETURN + END diff --git a/Dragon/src/SYB4T3.f b/Dragon/src/SYB4T3.f new file mode 100644 index 0000000..4cd8c55 --- /dev/null +++ b/Dragon/src/SYB4T3.f @@ -0,0 +1,71 @@ +*DECK SYB4T3 + SUBROUTINE SYB4T3 (NIR,JMINRB,XCOTEB,SINPHI,DCOTEA,COSPHI,ORIGIN, + & PENTES,ANGLES,IXRAYO,HXRAYO,DXMIN,DELTAC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the position of the next track intersecting with side 3 in a +* sectorized Cartesian cell. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NIR number of radius. +* JMINRB index of the first radius intercepting the side. +* XCOTEB radius interceptions. +* SINPHI sinus. +* DCOTEA half-side of the rectangle (center-side position). +* COSPHI cosinus. +* ORIGIN origin of the track. +* PENTES slope of the track. +* ANGLES slope of the sector. +* IXRAYO index of the radius. +* HXRAYO central radius. +* DXMIN accuracy. +* +*Parameters: output +* DELTAC position of the next trajectory. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NIR,JMINRB,IXRAYO + REAL XCOTEB(JMINRB:NIR),SINPHI,DCOTEA,COSPHI,ORIGIN,PENTES, + & ANGLES,HXRAYO,DXMIN,DELTAC +* +* Rayon Exterieur Suivant + IF (JMINRB .LE. NIR) THEN + H0 = DCOTEA * COSPHI + IF ((IXRAYO .EQ. JMINRB) .OR. (HXRAYO .LE. H0)) THEN + IR = IXRAYO + S = 1. + ELSE + IR = IXRAYO - 1 + S = - 1. + ENDIF + IF (IR .LE. NIR) THEN + X = S * XCOTEB (IR) + D = DCOTEA * SINPHI + X * COSPHI + DELTAC = MIN (DELTAC, D) + ENDIF + ENDIF +* +* Secteur Suivant + DA = ANGLES - PENTES + IF (ABS (DA) .GT. DXMIN) THEN + D = ORIGIN / DA + DELTAC = MIN (DELTAC, D) + ENDIF +* + RETURN + END diff --git a/Dragon/src/SYB4T4.f b/Dragon/src/SYB4T4.f new file mode 100644 index 0000000..7e7508e --- /dev/null +++ b/Dragon/src/SYB4T4.f @@ -0,0 +1,66 @@ +*DECK SYB4T4 + SUBROUTINE SYB4T4 (NIR,JMINRA,XCOTEA,SINPHI,DCOTEB,COSPHI,ORIGIN, + & PENTES,ANGLES,IXRAYO,DELTAH,DXMIN,DELTAC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the position of the next track intersecting with side 4 in a +* sectorized Cartesian cell. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NIR number of radius. +* JMINRA index of the first radius intercepting the side. +* XCOTEA radius interceptions. +* SINPHI sinus. +* DCOTEB half-side of the rectangle (center-side position). +* COSPHI cosinus. +* ORIGIN origin of the track. +* PENTES slope of the track. +* ANGLES slope of the sector. +* IXRAYO index of the radius. +* DELTAH position of the corner. +* DXMIN accuracy. +* +*Parameters: output +* DELTAC position of the next trajectory. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NIR,JMINRA,IXRAYO + REAL XCOTEA(JMINRA:NIR),SINPHI,DCOTEB,COSPHI,ORIGIN,PENTES, + & ANGLES,DELTAH,DXMIN,DELTAC +* +* Rayon Exterieur Suivant + IF (JMINRA .LE. NIR) THEN + IF (IXRAYO .LE. NIR) THEN + Y = XCOTEA(IXRAYO) + D = Y * SINPHI - DCOTEB * COSPHI + DELTAC = MIN(DELTAC, D) + ENDIF + ENDIF +* +* Secteur Suivant + DA = ANGLES - PENTES + IF (ABS(DA) .GT. DXMIN) THEN + D = ORIGIN / DA + DELTAC = MIN(DELTAC, D) + ENDIF +* +* Coin Sud-West + DELTAC = MIN(DELTAC, DELTAH) +* + RETURN + END diff --git a/Dragon/src/SYB4TC.f b/Dragon/src/SYB4TC.f new file mode 100644 index 0000000..309d95d --- /dev/null +++ b/Dragon/src/SYB4TC.f @@ -0,0 +1,235 @@ +*DECK SYB4TC + SUBROUTINE SYB4TC (DELTAR,DDELTA,ANGLES,NHMAX,IXRAYO,IS1,NSECT4, + & IFAC,NUMREG,RAYONS,ZZW,ZZE,ZZR,HXRAYO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the track lengths and interception lengths in a rectangular +* cell. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* DELTAR used to compute the interception. +* DDELTA undefined. +* ANGLES angular values. +* NHMAX number of interceptions. +* IXRAYO tube indices. +* IS1 index of the first sector. +* NSECT4 number of sectors. +* IFAC undefined. +* NUMREG region indices of the tube sectors. +* RAYONS radius. +* ZZW position of the west interception (left). +* ZZE position of the east interception (right). +* +*Parameters: input/output +* ZZR tracking information. +* HXRAYO preceding/next interception lengths. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NHMAX,IXRAYO(NHMAX),IS1,NSECT4,IFAC,NUMREG(NSECT4,*) + REAL DELTAR,DDELTA,ANGLES(NSECT4),RAYONS(*),ZZW,ZZE,ZZR(*), + & HXRAYO(NHMAX+1) +*---- +* LOCAL VARIABLES +*---- +*:AE Aire de la courbure Est (a Droite) +*:AW Aire de la courbure West (a Gauche) +*:GE Abcisse du point Est (Trajectoire precedente) +*:GW Abcisse du point West (Trajectoire precedente) +*:HE Abcisse du point Est +*:HW Abcisse du point West (Intersection) +*:XW Abcisse du point West (Region) +*:IHE No de l'abcisse Est +*:IRE No du Rayon Cote Est +C +*:IL No de l'Intersection +*:IREGC No de la Region Courante +*:IREGS No de la Region Suivante +*:ISC No du Secteur Courant +*:IS2 No du Secteur Suivant +*:JRC No de la Couronne Courante +*:JRS No de la Couronne Suivante +* + DDELT2 = DDELTA * DDELTA + DELTA2 = DELTAR * DELTAR +* + AW = 0. + GW = HXRAYO(1) + HW = ZZW + XW = HW + JRC = IXRAYO(1) + ISC = IS1 + ISF = ISC + IF (NSECT4 .GT. 1) THEN + IF (IFAC .EQ. 1) THEN + ISF = 1 - ISF + ELSEIF (IFAC .EQ. 2) THEN + ISF = ISF - NSECT4 / 2 + ELSEIF (IFAC .EQ. 3) THEN + ISF = 1 + NSECT4 / 2 - ISF + ENDIF + IF (ISF .LE. 0) ISF = ISF + NSECT4 + ENDIF + IREGC = NUMREG(ISF, JRC) + IL = 0 +* + HXRAYO(1) = HW +*---- +* Boucle des Volumes internes +* Debut +*---- + DO IHE = 2, NHMAX +* +* No de Couronne Suivante + JRS = IXRAYO(IHE) +* +* Soit : Meme Couronne => Changement de Secteur +* Sinon : Changement de Couronne => No de Rayon + IRE = 0 + IF (JRC .EQ. JRS) THEN + IF (ISC .LT. NSECT4) THEN + IS2 = ISC + 1 + ELSE + IS2 = 1 + ENDIF + ELSE + IS2 = ISC + IRE = MIN(JRC, JRS) + ENDIF +* +* Soit Changement de Secteur + IF (JRC .EQ. JRS) THEN + HE = DELTAR * ANGLES(ISC) +* +* Sinon Changement de Couronne + ELSE + H2 = RAYONS(IRE) * RAYONS(IRE) - DELTA2 + IF (H2 .GT. 0) THEN + HE = SQRT(H2) + IF (JRS .EQ. IRE) THEN + HE = - HE + ENDIF + ELSE + HE = 0. + ENDIF +* + ENDIF +* +* Protection contre les longueurs negatives + IF (HE .LT. HW) THEN + HE = HW + ENDIF +* +* +++ +* Debut +* Region Suivante + ISF = IS2 + IF (NSECT4 .GT. 1) THEN + IF (IFAC .EQ. 1) THEN + ISF = 1 - ISF + ELSEIF (IFAC .EQ. 2) THEN + ISF = ISF - NSECT4 / 2 + ELSEIF (IFAC .EQ. 3) THEN + ISF = 1 + NSECT4 / 2 - ISF + ENDIF + IF (ISF .LE. 0) ISF = ISF + NSECT4 + ENDIF + IREGS = NUMREG(ISF, JRS) + IF (IREGS .NE. IREGC) THEN +* +* Nouvelles Valeurs + AE = 0. + GE = HXRAYO(IHE) +* +* Moyenne entre l'intervalle precedent et Actuel + ZZH = HE - XW + ZZH = (ZZH + GE - GW) * 0.5 +* +* Ajout de la courbure + IF (JRC .NE. JRS) THEN + H2 = HE - GE + H2 = H2 * H2 + XCORDE = H2 + DDELT2 + IF (XCORDE .GT. 0.) THEN + XCORDE = SQRT(XCORDE) + XUNITE = XCORDE / RAYONS(IRE) + XUNITE = XUNITE / 2. + XALPHA = ASIN(XUNITE) + XUNITE = XALPHA - COS(XALPHA) * XUNITE + AE = XUNITE * RAYONS(IRE) * RAYONS(IRE) + AE = AE / DDELTA + ENDIF +* + IF (JRS .EQ. IRE) THEN + AE = - AE + ENDIF + ENDIF +* +* Longueur Moyenne +* Nouvelle Abcisse + IL = IL + 1 + ZZR(IL) = ZZH + AE - AW +C +C Valeurs Precedentes (Region) + AW = AE + GW = GE + XW = HE + ENDIF +* Fin Region Suivante +* +++ +* +* Valeurs Precedentes (Intersection) + HXRAYO(IHE) = HE + HW = HE +* +* Suivants + IREGC = IREGS + ISC = IS2 + JRC = JRS +* +* - - - - - - - - - - - - - +* Boucle des Volumes internes +* Fin +* - - - - - - - - - - - - - + ENDDO +* +* - - - - - - - - - - - - - +* Dernier Intervalle +* Debut +* - - - - - - - - - - - - - +* +* Intervalle + ZZH = ZZE - XW +* +* Protection contre les Volumes Negatifs + ZZH = MAX(ZZH, 0.) +* +* Moyenne entre l'intervalle precedent et Actuel + ZZH = (ZZH + HXRAYO(NHMAX+1) - GW) * 0.5 +* +* Ajout de la Courbure Eventuelle +* Mise a jour de la Nouvelle abcisse + IL = IL + 1 + ZZR(IL) = ZZH - AW + HXRAYO(NHMAX+1) = ZZE +* - - - - - - - - - - - - - +* Dernier Intervalle +* Fin +* - - - - - - - - - - - - - +* + RETURN + END diff --git a/Dragon/src/SYB4TH.f b/Dragon/src/SYB4TH.f new file mode 100644 index 0000000..bfb5c97 --- /dev/null +++ b/Dragon/src/SYB4TH.f @@ -0,0 +1,375 @@ +*DECK SYB4TH + SUBROUTINE SYB4TH (NRMAX,RAYONS,PENTES,ORIGIN,ISCMIN,ISCMAX, + & ANGLES,DXMIN,DELTAC,ISCW,ISCE,ISXW,ISXE,NHMAX,IXRAYO,HXRAYO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the intersection lenghts of a track in a sectorized Cartesian +* cell. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NRMAX number of radius. +* RAYONS radius of each tube. +* PENTES slope of the track with respect to the axis or to the sides. +* ORIGIN origin of the track. +* ISCMIN first sector with a possible intersection. +* ISCMAX last sector with a possible intersection. +* ANGLES slope of the sectors. +* DXMIN accuracy. +* DELTAC position of the track. +* +*Parameters: output +* ISCW index of the first sector (west/left). +* ISCE index of the last sector (east/right). +* ISXW index of the first side (west/left). Equal to 1 or 2. +* ISXE index of the last side (east/right). Equal to 3 or 4. +* NHMAX number of intersections. +* IXRAYO indices of the intersecting tubes. +* HXRAYO position of the intersections (boundary). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NRMAX,ISCMIN,ISCMAX,ISCW,ISCE,ISXW,ISXE,NHMAX, + & IXRAYO(NHMAX) + REAL RAYONS(NRMAX),PENTES(4),ORIGIN(4),ANGLES(ISCMAX),DXMIN, + & DELTAC,HXRAYO(NHMAX+1) +*---- +* LOCAL VARIABLES +*---- + CHARACTER * 4 AJOU(2) + LOGICAL AJRAYO + LOGICAL AJSECT +* +* Remarque Importante : +* Pour choisir entre deux lignes Proches +* Il faut prendre le cas correspondant a +* DELTAC + DXMIN +* ZHC + DXMIN +* + DXMAX = 2. + D2 = DELTAC * DELTAC + DR = DELTAC + DXMIN + ZH1 = DR * PENTES(1) + ORIGIN(1) + ZH2 = DR * PENTES(2) + ORIGIN(2) + IF (ZH2 .GE. (ZH1 - DXMIN)) THEN + ZHW = DELTAC * PENTES(2) + ORIGIN(2) + ISXW = 2 + ELSE + ZHW = DELTAC * PENTES(1) + ORIGIN(1) + ISXW = 1 + ENDIF + ZH3 = DELTAC * PENTES(3) + ORIGIN(3) + ZH4 = DELTAC * PENTES(4) + ORIGIN(4) + IF (ZH3 .LE. (ZH4 + DXMIN)) THEN + ZHE = ZH3 + ISXE = 3 + ELSE + ZHE = ZH4 + ISXE = 4 + ENDIF +* +* Recherche du Premier Secteur +* L'Angle ISC delimite les Secteurs ISC,ISC+1 + DO 101 ISCW = ISCMIN, ISCMAX + ZHS = DELTAC * ANGLES(ISCW) + IF (ZHS .GT. (ZHW + DXMIN)) THEN + GOTO 102 + ENDIF + 101 CONTINUE + ISCW = ISCMAX + 1 + ZHS = ZHE + DXMAX + 102 CONTINUE +* +* Couronne Interne + DO 201 NRMIN = 1, NRMAX + IF (RAYONS(NRMIN) .GT. DR) THEN + R2 = RAYONS(NRMIN) * RAYONS(NRMIN) + H2 = R2 - D2 + IF (H2 .GT. 0.) THEN + H0 = SQRT(H2) + GOTO 202 + ENDIF + ENDIF + 201 CONTINUE + H0 = 0. + NRMIN = NRMAX + 1 + 202 CONTINUE +* NRMIN = Couronne la Plus Interne +* NRMIN = Le Plus Petit Rayon a Prendre en Compte +* DXMIN - H0 = Limite entre Couronnes West et Est +* +* Recherche du Premier Rayon + H2 = ZHW * ZHW + R2 = D2 + H2 + RW = SQRT(R2) +* +* Pente pour le Rayon West +* Pente pour le Cote +* PR = - DELTAC / ZHW +* PC = PENTES(ISXW) +* +* ------------- +* Debut +* Couronne West +* ------------- +* +* Aucune Couronne + IF (NRMIN .GT. NRMAX) THEN + ZHR = ZHE + DXMAX + ICC = NRMIN +* +* Couronne a Gauche (ZHW <0) + ELSEIF (ZHW .LE. (- 0.5 * H0)) THEN + IF ((- ZHW * PENTES(ISXW)) .GT. DR) THEN + RW = RW - DXMIN + ELSE + RW = RW + DXMIN + ENDIF + DO 221 ICC = NRMAX, NRMIN, -1 + ZRR = RAYONS(ICC) + IF (ZRR .LE. RW) THEN + GOTO 222 + ENDIF + 221 CONTINUE + ICC = NRMIN - 1 + 222 CONTINUE + IF (ICC .LT. NRMIN) THEN + ZHR = H0 + ELSE + R2 = ZRR * ZRR + H2 = R2 - D2 + ZHR = - SQRT(H2) + ENDIF + ICC = ICC + 1 +* +* Couronne Centrale + ELSEIF (ZHW .LE. (0.5 * H0)) THEN + ICC = NRMIN + ZHR = H0 +* +* Couronne a Droite (ZHW >0) + ELSE + IF ((ZHW * PENTES(ISXW)) .GT. - DR) THEN + RW = RW + DXMIN + ELSE + RW = RW - DXMIN + ENDIF + DO 231 ICC = NRMIN, NRMAX + ZRR = RAYONS(ICC) + IF (ZRR .GE. RW) THEN + GOTO 232 + ENDIF + 231 CONTINUE + ICC = NRMAX + 1 + 232 CONTINUE + IF (ICC .GT. NRMAX) THEN + ZHR = ZHE + DXMAX + ELSE + R2 = ZRR * ZRR + H2 = R2 - D2 + ZHR = SQRT(H2) + ENDIF +* + ENDIF +* ------------- +* Couronne West +* Fin +* ------------- +* +* Premiere Position Courante + IHC = 1 + ISC = ISCW + ZHC = ZHW +* + IXRAYO(IHC) = ICC + HXRAYO(IHC) = ZHC +* +* Cote West Intersecte Rayon + IF (ZHR .LE. (ZHC + DXMIN)) THEN + IF (ZHR .GT. 0.) THEN + ICC = ICC + 1 + ELSE + ICC = ICC - 1 + ENDIF + ZHC = MAX (ZHR, ZHC) +* + IHC = IHC + 1 + IXRAYO(IHC) = ICC + HXRAYO(IHC) = ZHC +* + IF (ICC .GT. NRMAX) THEN + ZHR = ZHE + DXMAX + ELSEIF (ICC .EQ. NRMIN) THEN + ZHR = H0 + ELSEIF (ZHR .LT. 0.) THEN + R2 = RAYONS(ICC-1) * RAYONS(ICC-1) + H2 = R2 - D2 + ZHR = - SQRT(H2) + ELSE + R2 = RAYONS(ICC) * RAYONS(ICC) + H2 = R2 - D2 + ZHR = SQRT(H2) + ENDIF + ENDIF +* +* Suivant + 555 CONTINUE + ZHN = MIN (ZHE, ZHR, ZHS) +* +* +++ +* Debut +* point Courant ( Changement de Secteur +* Sinon : Changement de Couronne => No de Rayon + IF (JRC .EQ. JRS) THEN + IF (ISC .LT. NSECT4) THEN + IS2 = ISC + 1 + ELSE + IS2 = 1 + ENDIF + ELSE + IS2 = ISC + ENDIF +* +* +++ +* Debut +* Region Suivante + ISF = IS2 + IF (NSECT4 .GT. 1) THEN + IF (IFAC .EQ. 1) THEN + ISF = 1 - ISF + ELSEIF (IFAC .EQ. 2) THEN + ISF = ISF - NSECT4 / 2 + ELSEIF (IFAC .EQ. 3) THEN + ISF = 1 + NSECT4 / 2 - ISF + ENDIF + IF (ISF .LE. 0) ISF = ISF + NSECT4 + ENDIF + IREGS = NUMREG(ISF, JRS) + 3 + IF (IREGS .NE. IREGC) THEN + IREGI(NLMAX) = IREGC + NLMAX = NLMAX + 1 + IREGC = IREGS + ENDIF +* Fin Region Suivante +* +++ +* +* Suivants + ISC = IS2 + JRC = JRS +* +* - - - - - - - - - - - - - +* Boucle des Volumes internes +* Fin +* - - - - - - - - - - - - - + ENDDO +* + IREGI(NLMAX) = IREGC +* + RETURN + END diff --git a/Dragon/src/SYB4TN.f b/Dragon/src/SYB4TN.f new file mode 100644 index 0000000..a15ba8e --- /dev/null +++ b/Dragon/src/SYB4TN.f @@ -0,0 +1,99 @@ +*DECK SYB4TN + SUBROUTINE SYB4TN (NHMAX,IXRAYO,ISDEBU,COSECT,NRI,RAYONS,DELTAC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Search of the next singular point in a Cartesian cell. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NHMAX number of intervals (the number of interceptions is NHMAX+1). +* IXRAYO tubes indices from west to east. +* ISDEBU index of the first sector. +* COSECT cosinus of the sector angles. +* NRI number of radius. +* RAYONS radius of the tubes. +* +*Parameters: input/output +* DELTAC next distance. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NHMAX,IXRAYO(NHMAX),ISDEBU,NRI + REAL COSECT(*),RAYONS(NRI),DELTAC +*---- +* LOCAL VARIABLES +*---- + LOGICAL LGSEC1,LGSEC2 +* + IF (NHMAX .LT. 2) RETURN + IHX = 0 + IR1 = IXRAYO(1) + IR2 = IXRAYO(2) + LGSEC2 = IR1 .EQ. IR2 + IF (LGSEC2) THEN + ISC = ISDEBU + 1 + ELSE + ISC = ISDEBU + ENDIF +* + DO IHC = 2, NHMAX - 1 + LGSEC1 = LGSEC2 + IR0 = IR1 + IR1 = IR2 +* + IR2 = IXRAYO(IHC+1) + LGSEC2 = IR1 .EQ. IR2 + IF (LGSEC2) THEN + ISC = ISC + 1 + ENDIF +* +* Tangente = Intersection Couronne + IF (IR2 .EQ. IR0) THEN + IF (IR2 .EQ. IR1+1) THEN + IF (RAYONS(IR1) .LT. DELTAC) THEN + DELTAC = RAYONS(IR1) + IHX = IHC + ENDIF + ENDIF +* +* Coin Secteur/Rayon + ELSEIF (LGSEC1) THEN + IF (IR2 .EQ. IR1+1) THEN + RR = RAYONS(IR1) + DD = RR * COSECT(ISC-1) + IF (DD .LT. DELTAC) THEN + DELTAC = DD + IHX = IHC + ENDIF + ENDIF +* +* Coin Secteur/Rayon + ELSEIF (LGSEC2) THEN + IF (IR0 .EQ. IR1+1) THEN + RR = RAYONS(IR1) + DD = RR * COSECT(ISC-1) + IF (DD .LT. DELTAC) THEN + DELTAC = DD + IHX = IHC + ENDIF + ENDIF +* + ENDIF +* + ENDDO +* + RETURN + END diff --git a/Dragon/src/SYB4TR.f b/Dragon/src/SYB4TR.f new file mode 100644 index 0000000..0db2794 --- /dev/null +++ b/Dragon/src/SYB4TR.f @@ -0,0 +1,333 @@ +*DECK SYB4TR + SUBROUTINE SYB4TR(MNA,NRD,NSECT4,COTEA,COTEB,RAYONS,IFAC,NUMREG, + 1 JMINRA,XCOTEA,JMINRB,XCOTEB,LFAIRE,DXMIN,DELR,IQW,PWA2,ZWA2, + 2 NXMIN,NXMAX,NZR,ZZR,NZI,ZZI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the tracking information related to a square or rectangular +* sectorized heterogeneous cell (called 4 times). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MNA number of angles in (0,$\\pi$/2). +* NRD one plus the number of tubes in the cell. +* NSECT4 number of sectors. +* COTEA X-axis Cartesian dimensions of the cell. +* COTEB Y-axis Cartesian dimensions of the cell. +* RAYONS radius of each cylinder. +* IFAC starting side (=0, 1, 2 or 3). +* NUMREG merged volume number in each sector. +* JMINRA first interception with side a. +* XCOTEA interceptions with side a. +* JMINRB first interception with side b. +* XCOTEB interceptions with side b. +* LFAIRE tracking calculation flag (=.FALSE. only compute the number +* of real and integer tracking elements). +* DXMIN geometrical epsilon. +* DELR half distance between the tracks. +* IQW equal weight quadrature flag (=1 to use equal weight +* quadratures in angle and space). +* PWA2 weights of the angular quadrature set. +* ZWA2 base points of the angular quadrature set. +* +*Parameters: output +* NXMIN minimum number of tracks per region. +* NXMAX maximum number of tracks per region. +* NZR number of real tracking elements. +* ZZR real tracking information. +* NZI number of integer tracking elements. +* ZZI integer tracking information. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MNA,NRD,NSECT4,IFAC,NUMREG(NSECT4,NRD),JMINRA,JMINRB, + 1 IQW,NXMIN,NXMAX,NZR,NZI,ZZI(*) + REAL COTEA,COTEB,RAYONS(NRD-1),XCOTEA(JMINRA:NRD-1), + 1 XCOTEB(JMINRB:NRD-1),DXMIN,DELR,PWA2(MNA),ZWA2(MNA), + 2 ZZR(*) + LOGICAL LFAIRE +*---- +* LOCAL VARIABLES +*---- +*ISCW No du Premier Secteur A L'Ouest (a gauche) +*ISXW No de la Surface Externe A L'Ouest (a gauche) +*ISXE No de la Surface Externe A L'Est (a droite) + PARAMETER (PI314 = 3.141592653589793) + PARAMETER (PIS2 = PI314 / 2) + PARAMETER (PIS4 = PI314 / 4) + LOGICAL NTRIOR + REAL ORIGIN(4) + REAL PENTES(4) + REAL WX(64) + REAL ZX(64) + INTEGER, ALLOCATABLE, DIMENSION(:) :: IXRAYO + REAL, ALLOCATABLE, DIMENSION(:) :: HXRAYO,ANGLES,COSECT +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IXRAYO(NRD*2+NSECT4+3)) + ALLOCATE(HXRAYO(NRD*2+NSECT4+3),ANGLES(NSECT4),COSECT(NSECT4)) +* +* Interpolation des Trajectoires + DCOTEA = COTEA * 0.5 + DCOTEB = COTEB * 0.5 + IZI = 0 + IZR = 0 +* + DELR2 = DELR * 2. +* +* /Debut/ Boucle sur les Angles (0 a Pi/2) + DO 350 IA = 1, MNA + MNT = 0 + IZI = IZI + 2 + IZIT = IZI +* + WANGIA = PWA2(IA) * 0.5 + ZAIA = ZWA2(IA) + 1. + YAIA = 1. - ZWA2(IA) +* + PHI = PIS4 * ZAIA + COSPHI = COS(PHI) + SINPHI = SIN(PHI) + PENTES(1) = - SINPHI / COSPHI + ORIGIN(1) = - DCOTEA / COSPHI + PENTES(2) = COSPHI / SINPHI + ORIGIN(2) = - DCOTEB / SINPHI + PENTES(3) = - SINPHI / COSPHI + ORIGIN(3) = DCOTEA / COSPHI + PENTES(4) = COSPHI / SINPHI + ORIGIN(4) = DCOTEB / SINPHI + IF (LFAIRE) THEN + ZZR(IZR+1) = SINPHI + ZZR(IZR+3) = COSPHI + IF ((IFAC .EQ. 0) .OR. (IFAC .EQ. 2)) THEN + ZZR(IZR+2) = COSPHI + ZZR(IZR+4) = - SINPHI + ELSE + ZZR(IZR+2) = - COSPHI + ZZR(IZR+4) = SINPHI + ENDIF + DO 10 I=1,4 + ZZR(IZR+4+I) = ZZR(IZR+I) + 10 CONTINUE + ZZR(IZR+9) = WANGIA + ENDIF + IZR = IZR + 9 + PHIJ = PHI + PI314 / 2 + PHIJ = - PHIJ + PHIK = PI314 * 2 / NSECT4 + ISCMIN = 1 + ISCMAX = NSECT4 + DO I = 1, NSECT4 + PHIJ = PHIJ + PHIK + IF (PHIJ .LE. (DXMIN - PIS2)) THEN + ISCMIN = I + 1 + ELSEIF (PHIJ .GE. (PIS2 - DXMIN)) THEN + ISCMAX = I - 1 + GOTO 20 + ELSE + ANGLES(I) = TAN(PHIJ) + COSECT(I) = COS(PHIJ) + ENDIF + ENDDO +* + 20 DELTAH = (DCOTEB * COSPHI) - (DCOTEA * SINPHI) +* +* Rayon Max Pour cet angle (Rext) + DELTAS = DCOTEA * SINPHI + DCOTEB * COSPHI +* +* Suivant West (Gauche,Bas=Sud) + DELTAC = 0. +*---- +* /Debut/ Boucle sur les Trajectoires +*---- + NTRIOR = .TRUE. + DO WHILE (NTRIOR) + MNT = MNT + 1 + DELTAP = DELTAC + CALL SYB4TH (NRD-1, RAYONS, + & PENTES, ORIGIN, + & ISCMIN, ISCMAX, ANGLES, + & DXMIN, DELTAC, + & ISCW, ISCE, ISXW, ISXE, NHMAX, + & IXRAYO, HXRAYO) +* + DELTAC = DELTAS +* + CALL SYB4TN (NHMAX, IXRAYO, ISCW, + & COSECT, NRD-1, RAYONS, + & DELTAC) +* + IF (ISXW .EQ.1) THEN + CALL SYB4T1 (NRD-1, JMINRB, XCOTEB, + & COSPHI, - DCOTEA * SINPHI, + & ORIGIN(1), PENTES(1), ANGLES(ISCW), + & IXRAYO, DELTAH, + & DXMIN, DELTAC) + ELSE + CALL SYB4T2 (NRD-1, JMINRA, XCOTEA, + & SINPHI, DCOTEB, COSPHI, + & ORIGIN(2), PENTES(2), ANGLES(ISCW), + & IXRAYO, HXRAYO, + & DXMIN, DELTAC) + ENDIF +* + IF (ISXE .EQ. 4) THEN + CALL SYB4T4 (NRD-1, JMINRA, XCOTEA, + & SINPHI, DCOTEB, COSPHI, + & ORIGIN(4), PENTES(4), ANGLES(ISCE-1), + & IXRAYO(NHMAX), - DELTAH, + & DXMIN, DELTAC) + ELSE + CALL SYB4T3 (NRD-1, JMINRB, XCOTEB, + & SINPHI, DCOTEA, COSPHI, + & ORIGIN(3), PENTES(3), ANGLES(ISCE-1), + & IXRAYO(NHMAX), HXRAYO(NHMAX), + & DXMIN, DELTAC) + ENDIF +* +* Intervalle entre 2 Intersections, Decoupage + DELTAX = DELTAC - DELTAP + IF (DELTAX .LE. DELR2) THEN + NX = 1 + ZX(1) = 0.0 + WX(1) = 2.0 + ELSE + NX = INT(DELTAX / DELR2 + 1) + IF(IQW.EQ.0) THEN +* GAUSS-LEGENDRE INTEGRATION POINTS. ZX(I) IS NOT USED. + IF(NX.GT.20) THEN + IF(NX.LT.24) THEN + NX=24 + ELSE IF(NX.LT.28) THEN + NX=28 + ELSE IF(NX.LT.32) THEN + NX=32 + ELSE IF(NX.LT.64) THEN + NX=64 + ELSE IF(NX.GT.64) THEN + CALL XABORT('SYB4TR: GAUSS OVERFLOW.') + ENDIF + ENDIF + CALL ALGPT(NX,-1.0,1.0,ZX,WX) + ELSE +* EQUAL WEIGHT INTEGRATION POINTS. + DO 30 I=1,NX + ZX(I)=(2.0*REAL(I)-1.0)/REAL(NX)-1.0 + WX(I)=2.0/REAL(NX) + 30 CONTINUE + ENDIF + ENDIF + NXMIN = MIN(NX, NXMIN) + NXMAX = MAX(NX, NXMAX) +* Intervalle entre 2 Intersections, Fin du Decoupage +* + IF (LFAIRE) THEN +* +* Debut : Nombre et Numeros des Regions + CALL SYB4TI (NHMAX, IXRAYO, ISCW, + & NSECT4, IFAC, NUMREG, + & NLMAX, ZZI(IZI+4)) + ZZI(IZI+1) = NLMAX + ZZI(IZI+2) = NX + ZZI(IZI+3) = ISXW + IF (IFAC .EQ. 1) THEN + ZZI(IZI+3) = 6 - ZZI(IZI+3) + ELSEIF (IFAC .EQ. 2) THEN + ZZI(IZI+3) = ZZI(IZI+3) + 2 + ELSEIF (IFAC .EQ. 3) THEN + ZZI(IZI+3) = 4 - ZZI(IZI+3) + ENDIF + IF (ZZI(IZI+3) .GE. 4) ZZI(IZI+3) = ZZI(IZI+3) - 4 +* + IZI = IZI + 4 + NLMAX + ZZI(IZI) = ISXE + IF (IFAC .EQ. 1) THEN + ZZI(IZI) = 6 - ZZI(IZI) + ELSEIF (IFAC .EQ. 2) THEN + ZZI(IZI) = ZZI(IZI) + 2 + ELSEIF (IFAC .EQ. 3) THEN + ZZI(IZI) = 4 - ZZI(IZI) + ENDIF + IF (ZZI(IZI) .GE. 4) ZZI(IZI) = ZZI(IZI) - 4 +* Fin : Nombre et Numeros des Regions +* +*---- +* Boucle sur les trajectoires +*---- + DELTAR = DELTAP + DO 250 IX = 1, NX +* + WW = 0.5 * WX(IX) +* + IZR = IZR + 1 + ZZR(IZR) = WW * WANGIA * DELTAX + DDELTA = DELTAX * WW + DELTAR = DELTAR + DDELTA +* +* Position de L'intersection Gauche (West) + ZZW = DELTAR * PENTES(ISXW) + ORIGIN(ISXW) +* +* Position de L'intersection Droite (Est) + ZZE = DELTAR * PENTES(ISXE) + ORIGIN(ISXE) +* +* Longueur des intersections + CALL SYB4TC (DELTAR, DDELTA, ANGLES, + & NHMAX, IXRAYO, + & ISCW, NSECT4, IFAC, NUMREG, + & RAYONS, ZZW, ZZE, + & ZZR(IZR+1), HXRAYO) + IZR = IZR + NLMAX +* + 250 CONTINUE + ELSE +* +* Pour le comptage des Numeros de Regions +* deux indices de plus pour les surfaces Entrante et Sortante + IZR = IZR + (NHMAX + 1) * NX + IZI = IZI + 5 + NHMAX + ENDIF +* +* Position des limites Gauche et Droite (West et Est) + DR = DELTAC + DXMIN + ZZW = DR * PENTES(ISXW) + ORIGIN(ISXW) + ZZE = DR * PENTES(ISXE) + ORIGIN(ISXE) + NTRIOR = ZZW .LT. ZZE + IF (NTRIOR) THEN + IF (DELTAC .LE. DELTAP) THEN + CALL XABORT ('SYB4TR: INFINITE LOOP.') + ENDIF + ENDIF +* +* /Fin/ Boucle sur les Trajectoires + ENDDO +* +* /Fin/ Boucle sur les Angles + IF (LFAIRE) THEN + ZZI(IZIT-1) = MNT + ZZI(IZIT) = IFAC + ENDIF + 350 CONTINUE + NZI = IZI + NZR = IZR +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(COSECT,ANGLES,HXRAYO) + DEALLOCATE(IXRAYO) +* + RETURN + END diff --git a/Dragon/src/SYB4TS.f b/Dragon/src/SYB4TS.f new file mode 100644 index 0000000..d04fbe5 --- /dev/null +++ b/Dragon/src/SYB4TS.f @@ -0,0 +1,242 @@ +*DECK SYB4TS + SUBROUTINE SYB4TS(NA,NRD,NSECT,LSECT,NREG,COTEA,COTEB,RAYRE, + 1 ILIGN,IQW,DELR,LFAIRE,VOL,NZR,ZZR,NZI,ZZI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the tracking information related to a square or rectangular +* sectorized heterogeneous cell. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NA number of angles in (0,$\\pi$/2). +* NRD one plus the number of tubes in the cell. +* NSECT number of sectors. +* LSECT type of sectorization: +* =-999 no sectorization / processed as a sectorized cell; +* =-101 X-type sectorization of the coolant; +* =-1 X-type sectorization of the cell; +* =101 +-type sectorization of the coolant; +* =1 +-type sectorization of the cell; +* =102 + and X-type sectorization of the coolant; +* =2 + and X-type sectorization of the cell. +* NREG number of regions in the cell. +* COTEA X-axis Cartesian dimension of the cell. +* COTEB Y-axis Cartesian dimension of the cell. +* RAYRE radius of each cylinder. +* ILIGN tracking print flag (=1 to print the tracking). +* IQW equal weight quadrature flag (=1 to use equal weight +* quadratures in angle and space). +* DELR half distance between the tracks. +* LFAIRE tracking calculation flag (=.FALSE. only compute the number +* of tracks). +* +*Parameters: output +* VOL volumes. +* NZR number of real elements in vector ZZR. +* ZZR real tracking information. +* NZI number of integer elements in vector ZZI. +* ZZI integer tracking information. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NA,NRD,NSECT,LSECT,NREG,ILIGN,IQW,NZR,NZI,ZZI(*) + REAL COTEA,COTEB,RAYRE(NRD-1),DELR,VOL(NREG),ZZR(*) + LOGICAL LFAIRE +*---- +* LOCAL VARIABLES +*---- + PARAMETER (DXMIN=1.E-3,PIO2=1.570796327) + REAL ZA(64),WA(64) + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NUMREG + REAL, ALLOCATABLE, DIMENSION(:) :: XCOTEA,XCOTEB + REAL, ALLOCATABLE, DIMENSION(:,:) :: VOLINT +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NUMREG(NSECT,NRD)) + ALLOCATE(VOLINT(NSECT,NRD),XCOTEA(NRD),XCOTEB(NRD)) +* + IF(NA.GT.64) CALL XABORT('SYB4TS: NA IS GREATER THAN 64.') + IF(2.0*RAYRE(NRD-1).GT.SQRT(COTEA**2+COTEB**2)) THEN + CALL XABORT('SYB4TS: A RADIUS IS GREATER THAN HALF THE DIAGO' + 1 //'NAL OF THE RECTANGLE.') + ENDIF + IF(IQW.EQ.0) THEN +* GAUSS-LEGENDRE INTEGRATION POINTS. + CALL ALGPT(NA,-1.0,1.0,ZA,WA) + ELSE +* EQUAL WEIGHT INTEGRATION POINTS. + DO 10 I=1,NA + ZA(I)=(2.0*REAL(I)-1.0)/REAL(NA)-1.0 + WA(I)=2.0/REAL(NA) + 10 CONTINUE + ENDIF +*---- +* SET ZZI(1:2) AND COMPUTE THE NUMERICAL ORTHONORMALIZATION FACTORS +*---- + IF(LFAIRE) THEN + ZZI(1)=3 + ZZI(2)=1 + ZN1=0.0 + ZN2=0.0 + ZN3=0.0 + DO 20 IA=1,NA + PHI=0.5*PIO2*(ZA(IA)+1.0) + SI=SIN(PHI) + ZN1=ZN1+SI*WA(IA) + ZN2=ZN2+SI*SI*WA(IA) + ZN3=ZN3+SI*SI*SI*WA(IA) + 20 CONTINUE + ZN1=0.5*ZN1*PIO2 + ZN2=0.5*ZN2*PIO2 + ZN3=0.5*ZN3*PIO2 + ZZR(1)=1.0/SQRT(ZN1) + ZZR(2)=1.0/SQRT(0.75*ZN3-0.7205061948*ZN2*ZN2/ZN1) + ZZR(3)=ZZR(2)*0.8488263632*ZN2/ZN1 + ZZR(4)=2.0/SQRT(3.0*(ZN1-ZN3)) + IF(ILIGN.GT.0) WRITE (6,210) (ZZR(I),I=1,4) + ENDIF +*---- +* COMPUTE THE VOLUMES AND NUMREG +*---- + CALL SYB4VO(NSECT,NRD,COTEA,COTEB,RAYRE,VOLINT) + IND=0 + DO 50 I=1,NRD-1 + IF(ABS(LSECT).GT.100) THEN + IND=IND+1 + DO 30 ISEC=1,NSECT + NUMREG(ISEC,I)=IND + 30 CONTINUE + ELSE IF(LSECT.EQ.-1) THEN + NUMREG(1,I)=IND+4 + NUMREG(2,I)=IND+1 + NUMREG(3,I)=IND+1 + NUMREG(4,I)=IND+2 + NUMREG(5,I)=IND+2 + NUMREG(6,I)=IND+3 + NUMREG(7,I)=IND+3 + NUMREG(8,I)=IND+4 + IND=IND+4 + ELSE + DO 40 ISEC=1,NSECT + IND=IND+1 + NUMREG(ISEC,I)=IND + 40 CONTINUE + ENDIF + 50 CONTINUE + IF(LSECT.EQ.-999) THEN + IND=IND+1 + DO 60 ISEC=1,NSECT + NUMREG(ISEC,I)=IND + 60 CONTINUE + ELSE IF((LSECT.EQ.-1).OR.(LSECT.EQ.-101)) THEN + NUMREG(1,I)=IND+4 + NUMREG(2,I)=IND+1 + NUMREG(3,I)=IND+1 + NUMREG(4,I)=IND+2 + NUMREG(5,I)=IND+2 + NUMREG(6,I)=IND+3 + NUMREG(7,I)=IND+3 + NUMREG(8,I)=IND+4 + IND=IND+4 + ELSE + DO 70 ISEC=1,NSECT + IND=IND+1 + NUMREG(ISEC,I)=IND + 70 CONTINUE + ENDIF + DO 80 I=1,NREG + VOL(I)=0.0 + 80 CONTINUE + DO 95 IR=1,NRD + DO 90 IS=1,NSECT + IND=NUMREG(IS,IR) + VOL(IND)=VOL(IND)+VOLINT(IS,IR) + 90 CONTINUE + 95 CONTINUE +*---- +* INTERSECTION OF COTEB WITH THE TUBES +*---- + H2=0.25*COTEB*COTEB + DO 100 MRE=NRD-1,1,-1 + XI=RAYRE(MRE)*RAYRE(MRE)-H2 + IF(XI.GT.0.0) THEN + XCOTEA(MRE)=SQRT(XI) + ELSE + JMINRA=MRE+1 + GO TO 110 + ENDIF + 100 CONTINUE + JMINRA=1 +*---- +* INTERSECTION OF COTEA WITH THE TUBES +*---- + 110 H2=0.25*COTEA*COTEA + DO 120 MRE=NRD-1,1,-1 + XI=RAYRE(MRE)*RAYRE(MRE)-H2 + IF(XI.GT.0.0) THEN + XCOTEB(MRE)=SQRT(XI) + ELSE + JMINRB=MRE+1 + GO TO 130 + ENDIF + 120 CONTINUE + JMINRB=1 +* + 130 IZI=3 + IZR=5 + MZIS=1 + MZRS=1 + NXMIN=999999999 + NXMAX=0 + DO 140 IFAC=0,3 + MZIR=MZIS + MZRR=MZRS + CALL SYB4TR(NA,NRD,NSECT,COTEA,COTEB,RAYRE,IFAC,NUMREG,JMINRA, + 1 XCOTEA(JMINRA),JMINRB,XCOTEB(JMINRB),LFAIRE,DXMIN,DELR,IQW, + 2 WA,ZA,NXMIN,NXMAX,MZRR,ZZR(IZR),MZIR,ZZI(IZI)) + IZI=IZI+MZIR + IZR=IZR+MZRR + 140 CONTINUE + NZI=IZI + NZR=IZR +* + IF((ILIGN.GT.0).AND.(.NOT.LFAIRE)) THEN + WRITE(6,200) NA,NRD,NSECT,COTEA,COTEB,DXMIN,DELR,NZI,NZR, + 1 NXMIN,NXMAX + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XCOTEB,XCOTEA,VOLINT) + DEALLOCATE(NUMREG) + RETURN +* + 200 FORMAT(/49H SYB4TS: TRACKING OF A SECTORIZED CARTESIAN CELL./ + 1 7H NA ,I8,29H (NUMBER OF ANGLES IN PI/2)/ + 2 7H NRD ,I8,22H (1+NUMBER OF TUBES)/ + 3 7H NSECT ,I8,22H (NUMBER OF SECTORS)/ + 4 7H COTEA ,1P,E8.1,16H (X-AXIS SIDE)/ + 5 7H COTEB ,1P,E8.1,16H (Y-AXIS SIDE)/ + 6 7H DXMIN ,1P,E8.1,24H (GEOMETRICAL EPSILON)/ + 7 7H DELR ,1P,E8.1,37H (HALF DISTANCE BETWEEN THE TRACKS)/ + 8 7H NZI ,I8,40H (NUMBER OF INTEGER TRACKING ELEMENTS)/ + 9 7H NZR ,I8,37H (NUMBER OF REAL TRACKING ELEMENTS)/ + 1 7H NXMIN ,I8,37H (MINIMUM NB. OF TRACKS PER REGION)/ + 2 7H NXMAX ,I8,37H (MAXIMUM NB. OF TRACKS PER REGION)) + 210 FORMAT (/47H SYB4TS: NUMERICAL ORTHONORMALIZATION FACTORS =,1P, + 1 4E12.4/) + END diff --git a/Dragon/src/SYB4VO.f b/Dragon/src/SYB4VO.f new file mode 100644 index 0000000..e92c3d4 --- /dev/null +++ b/Dragon/src/SYB4VO.f @@ -0,0 +1,142 @@ +*DECK SYB4VO + SUBROUTINE SYB4VO(NSECT,NR,DX,DY,RAD,VOLINT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the volumes of a Cartesian sectorized cell. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NSECT number of sectors (multiple of 4). +* NR one plus the number of tubes. +* DX X-oriented side. +* DY Y-oriented side. +* RAD radius of the tubes. +* +*Parameters: output +* VOLINT volumes. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NSECT,NR + REAL DX,DY,RAD(NR-1),VOLINT(NSECT,NR) +* + IF(MOD(4+NSECT,4).NE.0) CALL XABORT('SYB4VO: INVALID NSECT.') + DDX = DX / 2. + DDY = DY / 2. + RADDD = SQRT(DDX*DDX + DDY*DDY) + TETA0 = 3.14159265358979 * 2. / REAL(NSECT) +*---- +* ITER=1 IS FOR (0, PI/4) AND ITER=2 IS FOR (PI/2, PI/4) +*---- + DO 15 IR=1,NR + DO 10 IS=1,NSECT + VOLINT(IS,IR)=0.0 + 10 CONTINUE + 15 CONTINUE + DO 60 ITER=1,2 + IF(ITER.EQ.1) THEN + ISA = 1 + ISB = 0 + DDXY=DDX + ELSE + ISA = - 1 + ISB = NSECT/4 + 1 + DDXY=DDY + ENDIF +* + TETAC = ACOS(DDXY / RADDD) + TETA2 = 0. + DO 20 IR = 1, NR-1 + IF (RAD(IR) .GT. DDXY) THEN + IRNEXT = IR + GOTO 30 + ENDIF + 20 CONTINUE + IRNEXT = NR +*---- +* IRNEXT : NEXT RADIUS INTERCEPTING A SIDE +* DDY2 : LAST PROCESSED COORDINATE +* ISNEXT : NEXT SECTOR +*---- + 30 DDY2 = 0. + ISNEXT = 1 +*---- +* NEXT SECTOR +*---- + 40 IS = ISNEXT + IF (IS .NE. 0) THEN + ISV = ISA * IS + ISB + IR0 = IRNEXT + DDY1 = DDY2 + TETA1 = TETA2 + TETA2 = IS * TETA0 +* +* THE ANGLE IS LIMITED BY THE DIAGONAL. + IF (TETA2 .GE. (TETAC - 1.E-6)) THEN + ISNEXT = 0 + TETA2 = TETAC + RAD2 = RADDD + ELSE + ISNEXT = IS + 1 + RAD2 = DDXY / COS(TETA2) + ENDIF +* +* THE NEXT RADIUS IS INTERCEPTING THE SECTOR. + IF (IR0 .LT. NR) THEN + RADIR = RAD(IR0) + IF (RADIR .LT. (RAD2 * (1. - 1.E-6))) THEN + RAD2 = RADIR + TETA2 = ACOS(DDXY / RAD2) + IRNEXT = IR0 + 1 + ISNEXT = IS + ELSE IF (RADIR .LE. (RAD2 * (1. + 1.E-6))) THEN +* THE NEXT RADIUS IS EQUAL TO THE SECTOR. + IRNEXT = IR0 + 1 + ENDIF + ENDIF +* +* DDY2 IS THE NEXT COORDINATE AND DT IS HALF THE ANGLE +* INCREMENT FOR THE SECTOR. + DDY2 = RAD2 * SIN(TETA2) + DT = (TETA2 - TETA1) * 0.5 +* +* COMPLETE TUBES. + R1 = 0. + DO 50 IR = 1, IR0 - 1 + R0 = R1 + R1 = RAD(IR) + DR = (R1 - R0) * (R1 + R0) + VOLINT(ISV, IR) = VOLINT(ISV, IR) + DT * DR + 50 CONTINUE +* +* LAST SIDE-INTERCEPTED TUBE. + VOLMAX = DDXY * 0.5 * (DDY2 - DDY1) + VOLMAX = VOLMAX - DT * R1 * R1 + VOLINT(ISV, IR0) = VOLINT(ISV, IR0) + VOLMAX + GOTO 40 + ENDIF + 60 CONTINUE +* + DO 90 IR=1,NR + DO 70 IS=NSECT/4+1,NSECT/2 + VOLINT(IS,IR)=VOLINT(NSECT/2-IS+1,IR) + 70 CONTINUE + DO 80 IS=NSECT/2+1,NSECT + VOLINT(IS,IR)=VOLINT(NSECT-IS+1,IR) + 80 CONTINUE + 90 CONTINUE + RETURN + END diff --git a/Dragon/src/SYB7QG.f b/Dragon/src/SYB7QG.f new file mode 100644 index 0000000..75d5d70 --- /dev/null +++ b/Dragon/src/SYB7QG.f @@ -0,0 +1,302 @@ +*DECK SYB7QG + SUBROUTINE SYB7QG (IMPX,NCURR,MNA4,NRD,NSECT,LSECT,NREG,ZZR,ZZI, + 1 HSIDE,RAYRE,SIGTR,TRONC,VOL,PIJ,PVS,PSS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the one-group collision, leakage and transmission +* probabilities in a hexagonal sectorized cell. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IMPX print parameter (equal to zero for no print). +* NCURR type of interface current approximation: +* =1 DP-0; =3 DP-1 interface currents. +* MNA4 number of angles in (0,$\\pi$/2). +* NRD one plus the number of tubes in the cell. +* NSECT number of sectors. +* LSECT type of sectorization: +* =-999 no sectorization / processed as a sectorized cell; +* =-101 X-type sectorization of the coolant; +* =-1 X-type sectorization of the cell. +* NREG number of regions. +* ZZR real tracking elements. +* ZZI integer tracking elements. +* HSIDE length of the hexagon sides. +* RAYRE radius of the tubes. +* SIGTR total macroscopic cross section. +* TRONC voided block criterion. +* +*Parameters: output +* VOL volumes. +* PIJ volume to volume reduced probability. +* PVS volume to surface probabilities. +* PSS surface to surface probabilities in the following order: +* PSS(i,j) is the probability from surface i to surface j. +* +*Comments: +* hexagone surface identification. +* side 2 +* xxxxxxxx +* x x +* side 3 x x side 1 +* x x +* x x +* side 4 x x side 6 +* xxxxxxxx +* side 5 +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IMPX,NCURR,MNA4,NRD,NSECT,LSECT,NREG,ZZI(*) + REAL ZZR(*),HSIDE,RAYRE(NRD-1),SIGTR(NREG),TRONC,VOL(NREG), + 1 PIJ(NREG,NREG),PVS(NREG,6*NCURR),PSS(6*NCURR,6*NCURR) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (SIGVID=1.0E-10,NSURFQ=6) + INTEGER IPER(3) + REAL QSS(135) + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NUMREG + REAL, ALLOCATABLE, DIMENSION(:) :: VOLINT,WORKIJ,G + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: PSIX + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LGFULL +*---- +* DATA STATEMENT AND INLINE FUNCTIONS +*---- + SAVE IPER + DATA IPER/1,3,2/ + INC(IC,IH)=(IC-1)*NCURR+IPER(IH) + INQ(IH,JH,IS)=(IS-1)*NCURR*NCURR+(IH-1)*NCURR+JH +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NUMREG(NSECT,NRD)) + ALLOCATE(VOLINT(NRD),WORKIJ(0:(NREG+6)*(NREG+7)/2-1), + 1 PSIX(0:5,NCURR,NREG),G(NREG+6)) + ALLOCATE(LGFULL(NREG)) +*---- +* COMPUTE THE VOLUMES +*---- + CALL SYB7VO(NRD,HSIDE,RAYRE,VOLINT) + IND=0 + DO 30 I=1,NRD-1 + IF(ABS(LSECT).GT.100) THEN + IND=IND+1 + DO 10 ISEC=1,NSECT + NUMREG(ISEC,I)=IND + 10 CONTINUE + ELSE IF(LSECT.EQ.-1) THEN + NUMREG(1,I)=IND+5 + NUMREG(2,I)=IND+6 + NUMREG(3,I)=IND+1 + NUMREG(4,I)=IND+2 + NUMREG(5,I)=IND+3 + NUMREG(6,I)=IND+4 + IND=IND+6 + ELSE + DO 20 ISEC=1,NSECT + IND=IND+1 + NUMREG(ISEC,I)=IND + 20 CONTINUE + ENDIF + 30 CONTINUE + IF(LSECT.EQ.-999) THEN + IND=IND+1 + DO 40 ISEC=1,NSECT + NUMREG(ISEC,I)=IND + 40 CONTINUE + ELSE IF((LSECT.EQ.-1).OR.(LSECT.EQ.-101)) THEN + NUMREG(1,I)=IND+5 + NUMREG(2,I)=IND+6 + NUMREG(3,I)=IND+1 + NUMREG(4,I)=IND+2 + NUMREG(5,I)=IND+3 + NUMREG(6,I)=IND+4 + IND=IND+6 + ELSE + DO 50 ISEC=1,NSECT + IND=IND+1 + NUMREG(ISEC,I)=IND + 50 CONTINUE + ENDIF + DO 60 I=1,NREG + VOL(I)=0.0 + 60 CONTINUE + DO 75 IR=1,NRD + DO 70 IS=1,NSECT + IND=NUMREG(IS,IR) + VOL(IND)=VOL(IND)+VOLINT(IR)/6.0 + 70 CONTINUE + 75 CONTINUE +*---- +* CHECK FOR VOIDED REGIONS +*---- + DO 80 IR=1,NREG + IF(VOL(IR) .GT. 0.) THEN + DR=SQRT(VOL(IR)) + ELSE + DR=0.0 + ENDIF + LGFULL(IR)=(SIGTR(IR)*DR).GT.TRONC + IF(SIGTR(IR).LE.SIGVID) SIGTR(IR)=SIGVID + 80 CONTINUE +*---- +* COMPUTE COLLISION, DP-0 ESCAPE AND DP-0 TRANSMISSION PROBABILITIES +*---- + MZIS=ZZI(1) + MZRS=ZZI(2) + CALL SYBUQV(ZZR(MZRS),ZZI(MZIS),NSURFQ,NREG,SIGTR,MNA4,LGFULL, + 1 WORKIJ) +*---- +* STAMM'LER RENORMALIZATION +*---- + DO 90 IR=1,NSURFQ + G(IR)=HSIDE/4.0 + 90 CONTINUE + DO 100 IR=1,NREG + G(6+IR)=SIGTR(IR)*VOL(IR) + 100 CONTINUE +* FIRST APPLY THE ORTHONORMALIZATION FACTOR: + DO 110 I=0,(NSURFQ+NREG)*(NSURFQ+NREG+1)/2-1 + WORKIJ(I)=WORKIJ(I)*ZZR(MZRS)*ZZR(MZRS) + 110 CONTINUE +* +* THEN PERFORM STAMM'LER NORMALIZATION: + CALL SYBRHL(IMPX,NSURFQ,NREG,G,WORKIJ) +* + IIJ=NSURFQ*(NSURFQ+1)/2-1 + DO 130 JR=1,NREG + IIJ=IIJ+NSURFQ + DO 120 IR=1,JR-1 + AUX=WORKIJ(IIJ+IR)/(SIGTR(IR)*SIGTR(JR)) + PIJ(IR,JR)=AUX/VOL(IR) + PIJ(JR,IR)=AUX/VOL(JR) + 120 CONTINUE + IIJ=IIJ+JR + AUX=WORKIJ(IIJ)/(SIGTR(JR)*SIGTR(JR)) + PIJ(JR,JR)=AUX/VOL(JR) + 130 CONTINUE +*---- +* PIS AND PSS CALCULATION +*---- + IF(NCURR.GT.1) THEN +* PERFORM A DP-1 CALCULATION USING THE TRACKING. + CALL SYBUQ0(ZZR(MZRS),ZZI(MZIS),NSURFQ,NREG,SIGTR,MNA4, + 1 LGFULL,PSIX(0,1,1),QSS) +* + DO 160 JS=0,NSURFQ-1 + DO 150 IH=1,NCURR + DO 140 IR=1,NREG + ZNOR=G(JS+1)+G(NSURFQ+IR) + PSIX(JS,IH,IR)=ZNOR*PSIX(JS,IH,IR)/SIGTR(IR)/VOL(IR) + 140 CONTINUE + 150 CONTINUE + 160 CONTINUE + IIQ=1 + DO 190 JS=0,NSURFQ-1 + DO 180 IS=0,JS-1 + ZNOR=G(IS+1)+G(JS+1) + DO 170 IH=1,NCURR*NCURR + QSS(IIQ)=ZNOR*QSS(IIQ) + IIQ=IIQ+1 + 170 CONTINUE + 180 CONTINUE + 190 CONTINUE + DO 210 IIQ=1,135,9 + DO 200 IIS=1,8,2 + QSS(IIQ+IIS)=-QSS(IIQ+IIS) + 200 CONTINUE + 210 CONTINUE + ELSE +* RECOVER PSI AND PSS INFORMATION FROM DP-0 PIJ CALCULATION. + IIQ=1 + IIJ=0 + DO 230 JS=0,NSURFQ-1 + DO 220 IS=0,JS-1 + QSS(IIQ)=4.0*WORKIJ(IIJ) + IIQ=IIQ+NCURR*NCURR + IIJ=IIJ+1 + 220 CONTINUE + IIJ=IIJ+1 + 230 CONTINUE + IIJ=NSURFQ*(NSURFQ+1)/2 + DO 250 IR=1,NREG + DO 240 JS=0,NSURFQ-1 + PSIX(JS,1,IR)=WORKIJ(IIJ+JS)/SIGTR(IR)/VOL(IR) + 240 CONTINUE + IIJ=IIJ+NSURFQ+IR + 250 CONTINUE + ENDIF +*---- +* LOAD THE EURYDICE CP ARRAYS +*---- + DO 270 I=1,NREG + DO 260 IH=1,NCURR + SGN=1.0 + IF(IH.EQ.2) SGN=-1.0 + PVS(I,INC(1,IH))=SGN*PSIX(2,IH,I) + PVS(I,INC(2,IH))=SGN*PSIX(3,IH,I) + PVS(I,INC(3,IH))=SGN*PSIX(4,IH,I) + PVS(I,INC(4,IH))=SGN*PSIX(5,IH,I) + PVS(I,INC(5,IH))=SGN*PSIX(0,IH,I) + PVS(I,INC(6,IH))=SGN*PSIX(1,IH,I) + 260 CONTINUE + 270 CONTINUE + DO 290 I=1,6*NCURR + DO 280 J=1,6*NCURR + PSS(I,J)=0.0 + 280 CONTINUE + 290 CONTINUE + DO 310 IH=1,NCURR + DO 300 JH=1,NCURR + PSS(INC(2,IH),INC(1,JH))=QSS(INQ(IH,JH,6))/HSIDE + PSS(INC(3,IH),INC(1,JH))=QSS(INQ(IH,JH,9))/HSIDE + PSS(INC(4,IH),INC(1,JH))=QSS(INQ(JH,IH,13))/HSIDE + PSS(INC(5,IH),INC(1,JH))=QSS(INQ(JH,IH,2))/HSIDE + PSS(INC(6,IH),INC(1,JH))=QSS(INQ(JH,IH,3))/HSIDE + PSS(INC(1,IH),INC(2,JH))=QSS(INQ(JH,IH,6))/HSIDE + PSS(INC(3,IH),INC(2,JH))=QSS(INQ(IH,JH,10))/HSIDE + PSS(INC(4,IH),INC(2,JH))=QSS(INQ(IH,JH,14))/HSIDE + PSS(INC(5,IH),INC(2,JH))=QSS(INQ(JH,IH,4))/HSIDE + PSS(INC(6,IH),INC(2,JH))=QSS(INQ(JH,IH,5))/HSIDE + PSS(INC(1,IH),INC(3,JH))=QSS(INQ(JH,IH,9))/HSIDE + PSS(INC(2,IH),INC(3,JH))=QSS(INQ(JH,IH,10))/HSIDE + PSS(INC(4,IH),INC(3,JH))=QSS(INQ(IH,JH,15))/HSIDE + PSS(INC(5,IH),INC(3,JH))=QSS(INQ(JH,IH,7))/HSIDE + PSS(INC(6,IH),INC(3,JH))=QSS(INQ(JH,IH,8))/HSIDE + PSS(INC(1,IH),INC(4,JH))=QSS(INQ(JH,IH,13))/HSIDE + PSS(INC(2,IH),INC(4,JH))=QSS(INQ(JH,IH,14))/HSIDE + PSS(INC(3,IH),INC(4,JH))=QSS(INQ(JH,IH,15))/HSIDE + PSS(INC(5,IH),INC(4,JH))=QSS(INQ(JH,IH,11))/HSIDE + PSS(INC(6,IH),INC(4,JH))=QSS(INQ(JH,IH,12))/HSIDE + PSS(INC(1,IH),INC(5,JH))=QSS(INQ(IH,JH,2))/HSIDE + PSS(INC(2,IH),INC(5,JH))=QSS(INQ(JH,IH,4))/HSIDE + PSS(INC(3,IH),INC(5,JH))=QSS(INQ(IH,JH,7))/HSIDE + PSS(INC(4,IH),INC(5,JH))=QSS(INQ(IH,JH,11))/HSIDE + PSS(INC(6,IH),INC(5,JH))=QSS(INQ(IH,JH,1))/HSIDE + PSS(INC(1,IH),INC(6,JH))=QSS(INQ(IH,JH,3))/HSIDE + PSS(INC(2,IH),INC(6,JH))=QSS(INQ(IH,JH,5))/HSIDE + PSS(INC(3,IH),INC(6,JH))=QSS(INQ(JH,IH,8))/HSIDE + PSS(INC(4,IH),INC(6,JH))=QSS(INQ(IH,JH,12))/HSIDE + PSS(INC(5,IH),INC(6,JH))=QSS(INQ(JH,IH,1))/HSIDE + 300 CONTINUE + 310 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(LGFULL) + DEALLOCATE(G,PSIX,WORKIJ,VOLINT) + DEALLOCATE(NUMREG) + RETURN + END diff --git a/Dragon/src/SYB7T0.f b/Dragon/src/SYB7T0.f new file mode 100644 index 0000000..007c983 --- /dev/null +++ b/Dragon/src/SYB7T0.f @@ -0,0 +1,387 @@ +*DECK SYB7T0 + SUBROUTINE SYB7T0(MNA,NRD,COTE,RAYONS,JMINR,XCOTE,LFAIRE,DELR, + 1 IQW,PWA2,ZWA2,NXMIN,NXMAX,NZR,ZZR,NZI,ZZI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the tracking information related to an hexagonal sectorized +* heterogeneous cell. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MNA number of angles in (0,$\\pi$/6). +* NRD one plus the number of tubes in the cell. +* COTE length of the hexagon side. +* RAYONS radius of each cylinder. +* JMINR first interception with side. +* XCOTE interceptions with side. +* LFAIRE tracking calculation flag (=.FALSE. only compute the number +* of real and integer tracking elements). +* DELR half distance between the tracks. +* IQW equal weight quadrature flag (=1 to use equal weight +* quadratures in angle and space). +* PWA2 weights of the angular quadrature set. +* ZWA2 base points of the angular quadrature set. +* +*Parameters: output +* NXMIN minimum number of tracks per region. +* NXMAX maximum number of tracks per region. +* NZR number of real tracking elements. +* ZZR real tracking information. +* NZI number of integer tracking elements. +* ZZI integer tracking information. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MNA,NRD,JMINR,IQW,NXMIN,NXMAX,NZR,NZI,ZZI(*) + REAL COTE,RAYONS(NRD-1),XCOTE(NRD),DELR,PWA2(64), + & ZWA2(64),ZZR(*) + LOGICAL LFAIRE +*---- +* LOCAL VARIABLES +*---- + PARAMETER (PI314 = 3.141592653589793) + PARAMETER (PI6 = PI314 / 6) + PARAMETER (PI12 = PI314 / 12) + PARAMETER (SQRT3 = 1.732050807568877) + PARAMETER (SQRT32 = SQRT3 / 2) + REAL ANGLES(5) + REAL COSECT(3) + LOGICAL LGTRAE + LOGICAL LGTRAW + LOGICAL LVERIF + LOGICAL NTRIOR + REAL ORIGIN(4) + REAL PENTES(4) + CHARACTER * 4 TYSUIT + REAL WX(64) + REAL ZX(64) + INTEGER, ALLOCATABLE, DIMENSION(:) :: IXRAYO + REAL, ALLOCATABLE, DIMENSION(:) :: HXRAYO +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IXRAYO(NRD*2+3),HXRAYO(NRD*2+3)) +*---- +* Interpolation des Trajectoires +*---- + IZI = 0 + IZR = 0 + LVERIF = .FALSE. + DELR2 = DELR * 2. + HAUTEU = COTE * SQRT32 +*---- +* /Debut/ Boucle sur les Angles +*---- + DO 350 IA = 1, MNA + MNT = 0 + IZI = IZI + 1 + IZIT = IZI +* + WANGIA = PWA2(IA) + ZAIA = ZWA2(IA) + 1. + YAIA = 1. - ZWA2(IA) + WANGIA = WANGIA / 6. +* + PHI = PI12 * ZAIA + PHI6 = PI12 * YAIA + PHI3 = PHI + PI6 + COSPHI = COS(PHI) + SINPHI = SIN(PHI) + COSPH3 = COS(PHI3) + SINPH3 = SIN(PHI3) + COSPH6 = COS(PHI6) + SINPH6 = SIN(PHI6) + TANPH6 = TAN(PHI6) + IF(LFAIRE) THEN + ZZR(IZR+1) = COSPH6 + ZZR(IZR+2) = SINPH6 + ZZR(IZR+3) = SINPHI + ZZR(IZR+4) = COSPHI + ZZR(IZR+5) = COSPH3 + ZZR(IZR+6) = -SINPH3 + ZZR(IZR+7) = WANGIA + ENDIF + IZR = IZR + 7 + ANGLES(1) = COSPHI + ANGLES(2) = SINPHI + ANGLES(3) = - TAN(PHI3) + ANGLES(4) = TANPH6 + ANGLES(5) = COSPHI / SINPHI +* + PENTES(1) = TANPH6 + PENTES(2) = ANGLES(5) + PENTES(3) = - TAN(PHI3) + PENTES(4) = PENTES(1) + ORIGIN(1) = - HAUTEU / COS(PHI6) + ORIGIN(2) = - HAUTEU / SINPHI + ORIGIN(3) = HAUTEU / COS(PHI3) + ORIGIN(4) = - ORIGIN(1) +* + COSECT(1) = COS(PHI3) + COSECT(2) = COS(PHI6) + COSECT(3) = SINPHI +*---- +* Rayon Max Pour cet angle(Rext) +*---- + XIZERO = HAUTEU * TANPH6 + DO MRA = JMINR, NRD-1 + IF(XCOTE(MRA) .GE. XIZERO) GOTO 140 + ENDDO + MRA = NRD + 140 MRAE = MRA + MRAW = MRA +*---- +* Les Lignes d'integrations sont limites +* et par les secteurs +* et par les couronnes +* +* Demarrage au centre de l'hexagone +*---- + IHMAX = NRD - MRA + IHMIN = IHMAX + 1 + HXRAYO(IHMIN) = ORIGIN(1) + DO IR = MRAW, 2, -1 + IHMAX = IHMAX + 1 + IXRAYO(IHMAX) = IR + HXRAYO(IHMAX+1) = - RAYONS(IR-1) + ENDDO + DO IS = 1, 3 + IXRAYO(IHMAX+IS) = 1 + HXRAYO(IHMAX+IS+1) = 0. + ENDDO + IHMAX = IHMAX + 3 + HXRAYO(IHMAX+1) = 0. + DO IR = 1, MRAE-1 + IHMAX = IHMAX + 1 + IXRAYO(IHMAX) = IR + HXRAYO(IHMAX+1) = RAYONS(IR) + ENDDO + IHMAX = IHMAX + 1 + IXRAYO(IHMAX) = MRAE + HXRAYO(IHMAX+1) = ORIGIN(4) +* + DELTCW = COTE * COSECT(1) + DELTAS = COTE * COSECT(2) + DELTCE = COTE * COSECT(3) + ORIPHI = HAUTEU * COSPHI + ORIPH6 = HAUTEU * SINPH6 + ORIPH3 = HAUTEU * SINPH3 +* + ISW2 = 2 + CALL SYB7TW(NRD, JMINR, XCOTE, IXRAYO(IHMIN), + & DELTCW, DELTAS, ORIPH6, ORIPHI, + & COSPH6, SINPHI, + & ISW2, LGTRAW, DELTAW) + ISW = ISW2 / 2 +* + ISE2 = 8 + CALL SYB7TE(NRD, JMINR, XCOTE, IXRAYO(IHMAX), + & DELTCE, DELTAS, ORIPH6, ORIPH3, + & COSPH6, COSPH3, + & ISE2, LGTRAE, DELTAE) +* + DELTAC = 0. + NTRIOR = .TRUE. + IRSUIT = 0 +*---- +* /Debut/ Boucle sur les Trajectoires +*---- + DO WHILE(NTRIOR) + NHMAX = IHMAX + 1 - IHMIN + DELTAP = DELTAC +* + TYSUIT = 'Sud' + IHSUIT = IHMIN + DELTAC = DELTAS + IF(DELTAW .LT. DELTAC) THEN + TYSUIT = 'West' + IHSUIT = IHMIN + DELTAC = DELTAW + ENDIF + IF(DELTAE .LT. DELTAC) THEN + TYSUIT = 'Est' + IHSUIT = IHMAX + DELTAC = DELTAE + ENDIF + CALL SYB7TN(IHMIN, IHMAX, IXRAYO, ISW, + & COSECT, NRD-1, RAYONS, + & TYSUIT, IHSUIT, DELTAC, IRSUIT) +* + DELTAX = DELTAC - DELTAP + IF(DELTAX .LE. DELR2) THEN + NX = 1 + ZX(1) = 0.0 + WX(1) = 2.0 + ELSE + NX = INT(DELTAX / DELR2 + 1) + IF(IQW.EQ.0) THEN +* GAUSS-LEGENDRE INTEGRATION POINTS. ZX(I) IS NOT USED. + IF(NX.GT.20) THEN + IF(NX.LT.24) THEN + NX=24 + ELSE IF(NX.LT.28) THEN + NX=28 + ELSE IF(NX.LT.32) THEN + NX=32 + ELSE IF(NX.LT.64) THEN + NX=64 + ELSE IF(NX.GT.64) THEN + CALL XABORT('SYB7T0: GAUSS OVERFLOW.') + ENDIF + ENDIF + CALL ALGPT(NX,-1.0,1.0,ZX,WX) + ELSE +* EQUAL WEIGHT INTEGRATION POINTS. + DO 30 I=1,NX + ZX(I)=(2.0*REAL(I)-1.0)/REAL(NX)-1.0 + WX(I)=2.0/REAL(NX) + 30 CONTINUE + ENDIF + ENDIF + NXMIN = MIN(NX, NXMIN) + NXMAX = MAX(NX, NXMAX) +* + MNT = MNT + 1 + IF(LFAIRE) THEN + ZZI(IZI+1) = NHMAX + ZZI(IZI+2) = NX + DO I=0,NHMAX-1 + ZZI(IZI+3+I)=IXRAYO(IHMIN+I) + ENDDO +* + DELTAR = DELTAP + DO 250 IX = 1, NX +* + WW = 0.5 * WX(IX) +* + IZR = IZR + 1 + ZZR(IZR) = WW * WANGIA * DELTAX + DDELTA = DELTAX * WW + DELTAR = DELTAR + DDELTA +* +* Position de L'intersection Gauche(West) + ZZW = DELTAR * PENTES(ISW) + ORIGIN(ISW) +* +* Position de L'intersection Droite(Est) + ISE = ISE2 / 2 + ZZE = DELTAR * PENTES(ISE) + ORIGIN(ISE) +*---- +* Longueur des intersections +*---- + CALL SYB7TC(DELTAR, DDELTA, ANGLES(ISW+2), NHMAX, ZZI(IZI+3), + & NRD-1, RAYONS, ZZW, ZZE, + & ZZR(IZR+1), HXRAYO(IHMIN)) + IZR = IZR + NHMAX +* + 250 CONTINUE + ELSE +*---- +* Pour le comptage il faudra compter +* pour plus tard (les douzes symetries) +* deux indices de plus pour les surfaces Entrante et Sortante +*---- + IZR = IZR +(NHMAX + 1) * NX + IZI = IZI + 2 + ENDIF +* + IZI = IZI + NHMAX + 2 +* + IF(TYSUIT .EQ. 'Est') THEN + IRC = IXRAYO(IHMAX) + IF(LGTRAE) THEN + IHMAX = IHMAX - 1 + IF(IRC .EQ. IXRAYO(IHMAX)) ISE2 = ISE2 - 1 + ELSEIF(IRC .GE. NRD) THEN + NTRIOR = .FALSE. + ELSE + IHMAX = IHMAX + 1 + IXRAYO(IHMAX) = IRC + 1 + HXRAYO(IHMAX+1) = HXRAYO(IHMAX) + ENDIF + IF(NTRIOR) THEN + CALL SYB7TE(NRD, JMINR, XCOTE, IXRAYO(IHMAX), + & DELTCE, DELTAS, ORIPH6, ORIPH3, + & COSPH6, COSPH3, + & ISE2, LGTRAE, DELTAE) + ENDIF + ELSEIF(TYSUIT .EQ. 'West') THEN + IRC = IXRAYO(IHMIN) + IF(LGTRAW) THEN + IHMIN = IHMIN + 1 + IF(IRC .EQ. IXRAYO(IHMIN)) ISW2 = ISW2 + 1 + ELSEIF(IRC .GE. NRD) THEN + NTRIOR = .FALSE. + ELSE + IHMIN = IHMIN - 1 + IXRAYO(IHMIN) = IRC + 1 + HXRAYO(IHMIN) = HXRAYO(IHMIN+1) + ENDIF + NTRIOR = ISW .LE. 2 + IF(NTRIOR) THEN + CALL SYB7TW(NRD, JMINR, XCOTE, IXRAYO(IHMIN), + & DELTCW, DELTAS, ORIPH6, ORIPHI, + & COSPH6, SINPHI, + & ISW2, LGTRAW, DELTAW) + IF((ISW2 / 2) .NE. ISW) THEN + IF(LFAIRE) THEN + ZZI(IZI+1) = 0 + ZZI(IZI+2) = 0 + MNT = MNT + 1 + ENDIF + IZI = IZI+2 + ENDIF + ISW = ISW2 / 2 + IF(ISW2 .EQ. 5) THEN + IF(LGTRAW) THEN + HC = DELTAW * PENTES(ISW) + ORIGIN(ISW) + LGTRAW = HC .GE. 0. + ENDIF + ENDIF + ENDIF + ELSEIF(TYSUIT .EQ. 'Coin') THEN + IXRAYO(IHSUIT) = IRSUIT + ELSEIF(TYSUIT .EQ. 'Tang') THEN +* +** Decalage du tableau entier de 2 Cases + DO I = 2, IHMAX - IHSUIT + IXRAYO(IHSUIT+I-2) = IXRAYO(IHSUIT+I) + ENDDO +* +** Decalage du tableau reel de 2 Cases + DO I = 2, IHMAX + 1 - IHSUIT + HXRAYO(IHSUIT+I-2) = HXRAYO(IHSUIT+I) + ENDDO +* + IHMAX = IHMAX - 2 + ELSE + NTRIOR = .FALSE. + ENDIF +* +* /Fin/ Boucle sur les Trajectoires + ENDDO +* +* /Fin/ Boucle sur les Angles + IF(LFAIRE) ZZI(IZIT) = MNT + 350 CONTINUE + NZI = IZI + NZR = IZR +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(HXRAYO,IXRAYO) +* + RETURN + END diff --git a/Dragon/src/SYB7TC.f b/Dragon/src/SYB7TC.f new file mode 100644 index 0000000..a4eca3f --- /dev/null +++ b/Dragon/src/SYB7TC.f @@ -0,0 +1,132 @@ +*DECK SYB7TC + SUBROUTINE SYB7TC (DELTAR, DDELTA, ANGLES, NHMAX, IXRAYO, + & NRI, RAYONS, ZZW, ZZE, ZZR, HXRAYO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the intersection lenghts of a track in a sectorized hexagonal +* cell. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* DELTAR used to compute the intersection. +* DDELTA used to compute the intersection. +* ANGLES angular values (begin at 1 or 2): +* 1= $\\tan$(-$\\pi$/6-PHI); +* 2= $\\tan$(+$\\pi$/6-PHI); +* 3= $\\tan$(3$\\pi$/6-PHI). +* NHMAX number of intersections. +* IXRAYO tube indices. +* NRI number of radii (= NRD-1) +* RAYONS radius of each cylinder. +* ZZW position of the west intersection (left). +* ZZE position of the east intersection (right). +* +*Parameters: output +* ZZR intersection lenghts. +* +*Parameters: input/output +* HXRAYO preceding/next intersection lenghts. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NHMAX,IXRAYO(NHMAX),NRI + REAL DELTAR,DDELTA,ANGLES(3),RAYONS(NRI),ZZW,ZZE,ZZR(NHMAX), + & HXRAYO(NHMAX+1) +* + DDELT2 = DDELTA * DDELTA + DELTA2 = DELTAR * DELTAR + GC = 0. + HC = ZZW + IRC = IXRAYO(1) + ISC = 0 + HPRAYO = HXRAYO(1) + HXRAYO(1) = HC +* + DO IH = 1, NHMAX-1 + GP = GC + GC = 0. + HP = HC + IRP = IRC + IRR = 0 +* + IRC = IXRAYO(IH+1) + IF (IRP .EQ. IRC) THEN + ISC = ISC + 1 + HC = DELTAR * ANGLES(ISC) + ELSE + IRR = MIN(IRP, IRC) +* +* Distance + H2 = RAYONS(IRR) * RAYONS(IRR) - DELTA2 + IF (H2 .GT. 0) THEN + HC = SQRT(H2) + IF (IRC .EQ. IRR) THEN + HC = - HC + ENDIF + ELSE + HC = 0. + ENDIF +* + ENDIF +* +* Protection contre les longueurs negatives + IF (HC .LT. HP) THEN + HC = HP + ZZH = 0. + ELSE + ZZH = HC - HP + ENDIF + ZZH = (ZZH + HXRAYO(IH+1) - HPRAYO) * 0.5 + HPRAYO = HXRAYO(IH+1) + HXRAYO(IH+1) = HC +* +* Ajout de la courbure + IF (IRP .NE. IRC) THEN + H2 = HC - HPRAYO + H2 = H2 * H2 + XCORDE = H2 + DDELT2 + IF (XCORDE .GT. 0.) THEN +* Surface entre la corde et l'arc + XUNITE = SQRT(XCORDE) / RAYONS(IRR) / 2. + XALPHA = ASIN(XUNITE) + XUNITE = XALPHA - COS(XALPHA) * XUNITE + GC = XUNITE * RAYONS(IRR) * RAYONS(IRR) / DDELTA + ELSE + GC = 0. + ENDIF +* + IF (IRC .EQ. IRR) THEN + GC = - GC + ENDIF + ENDIF +* +* Longueur Moyenne + ZZR(IH) = ZZH + GC - GP +* + ENDDO +* +* Dernier + IF (ZZE .LT. HC) THEN + ZZH = 0. + ELSE + ZZH = ZZE - HC + ENDIF + ZZH = (ZZH + HXRAYO(NHMAX+1) - HPRAYO) * 0.5 + ZZR(NHMAX) = ZZH - GC + HXRAYO(NHMAX+1) = ZZE +* + RETURN + END diff --git a/Dragon/src/SYB7TE.f b/Dragon/src/SYB7TE.f new file mode 100644 index 0000000..2acdc02 --- /dev/null +++ b/Dragon/src/SYB7TE.f @@ -0,0 +1,78 @@ +*DECK SYB7TE + SUBROUTINE SYB7TE (NRD,MRE,XICOTE,IRMAX,DELTCE,DELTCS,ORIPH6, + & ORIPH3,COSPH6,COSPH3,ISE2,LGTRAE,DELTAE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the intersection lenghts of a track in a sectorized hexagonal +* cell, following a singular point at east. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NRD one plus the number of tube in the cell. +* MRE first radius intersection the side or first region in contact +* with the external side. +* XICOTE intersections with the side. +* IRMAX region index in contact with the external side. +* DELTCE distance from the east corner. +* DELTCS distance from the south-east corner. +* ORIPH6 distance at the middle of north-east side. +* ORIPH3 distance at the middle of south-east side. +* COSPH6 cosinus ($\\pi$/6-Phi). +* COSPH3 cosinus ($\\pi$/6+Phi). +* +*Parameters: input/output +* ISE2 half side on east (8 followed by 7-6 or NE followed by +* SE (north and south)). +* +*Parameters: output +* LGTRAE removing/addition flag of the next intersection. A removing +* occurs if and only if the track cross a sector and the +* south-east north (upper) zone. +* DELTAE distance of the next track. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NRD,MRE,IRMAX,ISE2 + REAL XICOTE(NRD-1),DELTCE,DELTCS,ORIPH6,ORIPH3,COSPH6,COSPH3, + & DELTAE + LOGICAL LGTRAE +* + IF (ISE2 .EQ. 8) THEN + LGTRAE = (IRMAX .EQ. NRD) + IF (LGTRAE) THEN + DELTAE = DELTCE + ELSE + DELTAE = XICOTE(IRMAX) * COSPH6 - ORIPH6 + ENDIF + ELSE + LGTRAE = ISE2 .EQ. 7 + IF (LGTRAE) THEN + LGTRAE = IRMAX .GT. MRE + ENDIF + IF (LGTRAE) THEN + DELTAE = ORIPH3 - XICOTE(IRMAX-1) * COSPH3 + ELSE + ISE2 = 6 + IF (IRMAX .LT. NRD) THEN + DELTAE = ORIPH3 + XICOTE(IRMAX) * COSPH3 + ELSE + DELTAE = DELTCS + ENDIF + ENDIF + ENDIF +* + RETURN + END diff --git a/Dragon/src/SYB7TN.f b/Dragon/src/SYB7TN.f new file mode 100644 index 0000000..e0833fc --- /dev/null +++ b/Dragon/src/SYB7TN.f @@ -0,0 +1,108 @@ +*DECK SYB7TN + SUBROUTINE SYB7TN (IHMIN,IHMAX,IXRAYO,ISDEBU,COSECT,NRI,RAYONS, + & TYSUIT,IHSUIT,DELTAC,IRSUIT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Search of the next singular point in an hexagonal cell. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IHMIN index of the first tube. +* IHMAX index of the last tube. +* IXRAYO tube indices from west to east. +* ISDEBU index of the first sector. +* COSECT sector angle cosinus. +* NRI number of radius. +* RAYONS radius of the tubes. +* +*Parameters: input/output +* DELTAC next distance. +* +*Parameters: output +* TYSUIT type of the next singular point. +* IHSUIT index of the next singular point. +* IRSUIT index of the preceding tube. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IHMIN,IHMAX,IXRAYO(IHMAX),ISDEBU,NRI,IHSUIT,IRSUIT + REAL COSECT(3),RAYONS(NRI),DELTAC + CHARACTER TYSUIT*4 +*---- +* LOCAL VARIABLES +*---- + LOGICAL LGSEC1 + LOGICAL LGSEC2 +* + IR1 = IXRAYO(IHMIN) + IR2 = IXRAYO(IHMIN+1) + LGSEC2 = IR1 .EQ. IR2 + IF (LGSEC2) THEN + ISC = ISDEBU + ELSE + ISC = ISDEBU - 1 + ENDIF +* + DO IHC = IHMIN + 1, IHMAX - 1 + LGSEC1 = LGSEC2 + IR0 = IR1 + IR1 = IR2 +* + IR2 = IXRAYO(IHC+1) + LGSEC2 = IR1 .EQ. IR2 + IF (LGSEC2) THEN + ISC = ISC + 1 + ENDIF +* +* Tangente = Intersection Couronne + IF (IR2 .EQ. IR0) THEN + IF (IR2 .EQ. IR1+1) THEN + IF (RAYONS(IR1) .LT. DELTAC) THEN + IHSUIT = IHC + DELTAC = RAYONS(IR1) + TYSUIT = 'Tang' + ENDIF + ENDIF +* +* Coin du 1er Secteur + ELSEIF (ISC .EQ. 1) THEN + IF (LGSEC2) THEN + RR = RAYONS(IR1) + DD = RR * COSECT(ISC) + IF (DD .LT. DELTAC) THEN + IHSUIT = IHC + DELTAC = DD + TYSUIT = 'Coin' + IRSUIT = IR1 + 1 + ENDIF + ENDIF +* +* Coin d'un Secteur Est + ELSEIF (LGSEC1) THEN + RR = RAYONS(IR1) + DD = RR * COSECT(ISC) + IF (DD .LT. DELTAC) THEN + IHSUIT = IHC + DELTAC = DD + TYSUIT = 'Coin' + IRSUIT = IR1 + 1 + ENDIF + ENDIF +* + ENDDO +* + RETURN + END diff --git a/Dragon/src/SYB7TR.f b/Dragon/src/SYB7TR.f new file mode 100644 index 0000000..00504da --- /dev/null +++ b/Dragon/src/SYB7TR.f @@ -0,0 +1,150 @@ +*DECK SYB7TR + SUBROUTINE SYB7TR (MNA,NRD,NZIS,NZRS,IFAC,ISYM,NUMREG,ZZIS,ZZRS, + 1 NZIR,NZRR,ZZIR,ZZRR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Unfold the tracking information related to an hexagonal sectorized +* heterogeneous cell. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MNA number of angles in (0,$\\pi$/6). +* NRD one plus the number of tubes in the cell. +* NUMREG tubes indices. +* NZIS undefined. +* NZRS undefined. +* IFAC undefined. +* ISYM undefined. +* ZZIS undefined. +* ZZRS undefined. +* +*Parameters: input/output +* NZRR length if the original/unfolded real tracking information. +* ZZRR original/unfolded real tracking information. +* NZIR length if the original/unfolded integer tracking information. +* ZZIR original/unfolded integer tracking information. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MNA,NRD,NZIS,NZRS,IFAC,ISYM,NUMREG(0:5,NRD), + & ZZIS(NZIS),NZIR,NZRR,ZZIR(*) + REAL ZZRS(NZRS),ZZRR(*) +* + IZRR = 0 + IZRS = 0 + IZIR = 0 + IZIS = 0 + DO IA = 1, MNA + ISS = IFAC + DO IST = 1, 3 + ISC = 2 * MOD(ISS, 6) + ZZRR(IZRR+ISC+1) = ZZRS(IZRS+1) + ZZRR(IZRR+ISC+2) = ISYM * ZZRS(IZRS+2) + ISC = 2 * MOD(ISS+3, 6) + ZZRR(IZRR+ISC+1) = ZZRS(IZRS+1) + ZZRR(IZRR+ISC+2) = ISYM * ZZRS(IZRS+2) + ISS = ISS + ISYM + IZRS = IZRS + 2 + ENDDO + IZRR = IZRR + 12 +* + IZRS = IZRS + 1 + IZRR = IZRR + 1 + W = ZZRS(IZRS) + ZZRR(IZRR) = W +* + ISSDEB = IFAC + IZIS = IZIS + 1 + MNT = ZZIS(IZIS) + IZIR = IZIR + 1 + ZZIR(IZIR) = MNT - 1 + IZIR = IZIR + 1 + ZZIR(IZIR) = IFAC * ISYM +* + DO ITT = 1, MNT + IZIS = IZIS + 1 + NH = ZZIS(IZIS) + IZIS = IZIS + 1 + NX = ZZIS(IZIS) + IF (NX .LT. 0) CALL XABORT('SYB7TR: NEGATIVE TRACKS.') + IF (NH .EQ. 0) THEN + ISSDEB = ISSDEB + ISYM + ELSE + ZZIR(IZIR+2) = NX + IZIR = IZIR + 2 +* + IZIR = IZIR + 1 + ZZIR(IZIR) = MOD(ISSDEB, 6) +* + ISS = ISSDEB + ISR = 0 + DO IHS = 1, NH + ISP = ISR + ISR = ZZIS(IZIS+IHS) + IF (ISR .EQ. ISP) THEN + ISS = ISS + ISYM + ENDIF + ISC = MOD(ISS, 6) + IRC = NUMREG(ISC, ISR) + 5 + ZZIR(IZIR+IHS) = IRC + ENDDO + IZIS = IZIS + NH +* + DO ITX = 1, NX + IZRS = IZRS + 1 + IZRR = IZRR + 1 + W = ZZRS(IZRS) + ZZRR(IZRR) = W + IRC = 0 + DO IHS = 1, NH + IRP = IRC + W = ZZRS(IZRS+IHS) + IRC = ZZIR(IZIR+IHS) + IF (IRC .EQ. IRP ) THEN + ZZRR(IZRR) = W + ZZRR(IZRR) + ELSE + IZRR = IZRR + 1 + ZZRR(IZRR) = W + ENDIF + ENDDO + IZRS = IZRS + NH + ENDDO +* + IRC = 0 + JZIR = IZIR + DO IHS = 1, NH + IRP = IRC + IRC = ZZIR(IZIR+IHS) + IF (IRC .NE. IRP) THEN + JZIR = JZIR + 1 + ZZIR(JZIR) = IRC + ENDIF + ENDDO + NHR = JZIR - IZIR + ZZIR(IZIR-2) = NHR + IZIR = JZIR + 1 + ISC = MOD(ISS, 6) + ZZIR(IZIR) = ISC + ENDIF +* + ENDDO + ENDDO +* + NZIR = IZIR + NZRR = IZRR +* + RETURN + END diff --git a/Dragon/src/SYB7TS.f b/Dragon/src/SYB7TS.f new file mode 100644 index 0000000..f154916 --- /dev/null +++ b/Dragon/src/SYB7TS.f @@ -0,0 +1,222 @@ +*DECK SYB7TS + SUBROUTINE SYB7TS(NA,NRD,NSECT,LSECT,NREG,HSIDE,RAYRE,ILIGN,IQW, + 1 DELR,LFAIRE,VOL,NZR,ZZR,NZI,ZZI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the tracking information related to an hexagonal sectorized +* heterogeneous cell. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NA number of angles in (0,$\\pi$/2). +* NRD one plus the number of tubes in the cell. +* NSECT number of sectors. +* LSECT type of sectorization: +* =-999 no sectorization / processed as a sectorized cell; +* =-101 X-type sectorization of the coolant; +* =-1 X-type sectorization of the cell. +* NREG number of regions in the cell. +* HSIDE length of the hexagon side. +* RAYRE radius of each cylinder. +* ILIGN tracking print flag (=1 to print the tracking). +* IQW equal weight quadrature flag (=1 to use equal weight +* quadratures in angle and space). +* DELR half distance between the tracks. +* LFAIRE tracking calculation flag (=.FALSE. only compute the number +* of tracks). +* +*Parameters: output +* VOL volumes. +* NZR number of real elements in vector ZZR. +* ZZR real tracking information. +* NZI number of integer elements in vector ZZI. +* ZZI integer tracking information. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NA,NRD,NSECT,LSECT,NREG,ILIGN,IQW,NZR,NZI,ZZI(*) + REAL HSIDE,RAYRE(NRD-1),DELR,VOL(NREG),ZZR(*) + LOGICAL LFAIRE +*---- +* LOCAL VARIABLES +*---- + PARAMETER(DXMIN=1.E-3,PIO2=1.570796327,SQRT32=1.7320508075689/2.0) + REAL ZA(64),WA(64) + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NUMREG + REAL, ALLOCATABLE, DIMENSION(:) :: VOLINT,XCOTE +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NUMREG(NSECT,NRD)) + ALLOCATE(VOLINT(NRD),XCOTE(NRD)) +* + IF(NA.GT.64) CALL XABORT('SYB7TS: NA IS GREATER THAN 64.') + IF(RAYRE(NRD-1).GT.HSIDE) CALL XABORT('SYB7TS: A RADIUS IS GREAT' + 1 //'ER THAN THE HEXAGON SIDE LENGTH.') + IF(IQW.EQ.0) THEN +* GAUSS-LEGENDRE INTEGRATION POINTS. + CALL ALGPT(NA,-1.0,1.0,ZA,WA) + ELSE +* EQUAL WEIGHT INTEGRATION POINTS. + DO 10 I=1,NA + ZA(I)=(2.0*REAL(I)-1.0)/REAL(NA)-1.0 + WA(I)=2.0/REAL(NA) + 10 CONTINUE + ENDIF +*---- +* COMPUTE THE VOLUMES AND NUMREG +*---- + CALL SYB7VO(NRD,HSIDE,RAYRE,VOLINT) + IND=0 + DO 50 I=1,NRD-1 + IF(ABS(LSECT).GT.100) THEN + IND=IND+1 + DO 30 ISEC=1,NSECT + NUMREG(ISEC,I)=IND + 30 CONTINUE + ELSE IF(LSECT.EQ.-1) THEN + NUMREG(1,I)=IND+5 + NUMREG(2,I)=IND+6 + NUMREG(3,I)=IND+1 + NUMREG(4,I)=IND+2 + NUMREG(5,I)=IND+3 + NUMREG(6,I)=IND+4 + IND=IND+6 + ELSE + DO 40 ISEC=1,NSECT + IND=IND+1 + NUMREG(ISEC,I)=IND + 40 CONTINUE + ENDIF + 50 CONTINUE + IF(LSECT.EQ.-999) THEN + IND=IND+1 + DO 60 ISEC=1,NSECT + NUMREG(ISEC,I)=IND + 60 CONTINUE + ELSE IF((LSECT.EQ.-1).OR.(LSECT.EQ.-101)) THEN + NUMREG(1,I)=IND+5 + NUMREG(2,I)=IND+6 + NUMREG(3,I)=IND+1 + NUMREG(4,I)=IND+2 + NUMREG(5,I)=IND+3 + NUMREG(6,I)=IND+4 + IND=IND+6 + ELSE + DO 70 ISEC=1,NSECT + IND=IND+1 + NUMREG(ISEC,I)=IND + 70 CONTINUE + ENDIF + DO 80 I=1,NREG + VOL(I)=0.0 + 80 CONTINUE + DO 95 IR=1,NRD + DO 90 IS=1,NSECT + IND=NUMREG(IS,IR) + VOL(IND)=VOL(IND)+VOLINT(IR)/6.0 + 90 CONTINUE + 95 CONTINUE +*---- +* INTERSECTION OF THE HEXAGON SIDE WITH THE TUBES +*---- + HAUTEU=HSIDE*SQRT32 + H2=HAUTEU*HAUTEU + DO 100 MRE=NRD-1,1,-1 + XI=RAYRE(MRE)*RAYRE(MRE)-H2 + IF(XI.GT.0.0) THEN + XCOTE(MRE)=SQRT(XI) + ELSE + JMINR=MRE+1 + GO TO 110 + ENDIF + 100 CONTINUE + JMINR=1 +* + 110 NXMIN=999999999 + NXMAX=0 + CALL SYB7T0(NA,NRD,HSIDE,RAYRE,JMINR,XCOTE,LFAIRE,DELR,IQW, + 1 WA,ZA,NXMIN,NXMAX,MZRS,ZZR(1),MZIS,ZZI(3)) +* + IF(LFAIRE) THEN +* SET ZZI(1:2) AND COMPUTE THE NUMERICAL ORTHONORMALIZATION +* FACTORS. + ZZI(1)=MZIS+3 + ZZI(2)=MZRS+1 + ZN1=0.0 + ZN2=0.0 + ZN3=0.0 + DO 120 IA=1,NA + PHI=0.5*PIO2*(ZA(IA)+1.0) + SI=SIN(PHI) + ZN1=ZN1+SI*WA(IA) + ZN2=ZN2+SI*SI*WA(IA) + ZN3=ZN3+SI*SI*SI*WA(IA) + 120 CONTINUE + ZN1=0.5*ZN1*PIO2 + ZN2=0.5*ZN2*PIO2 + ZN3=0.5*ZN3*PIO2 + ZZR(MZRS+1)=1.0/SQRT(ZN1) + ZZR(MZRS+2)=1.0/SQRT(0.75*ZN3-0.7205061948*ZN2*ZN2/ZN1) + ZZR(MZRS+3)=ZZR(MZRS+2)*0.8488263632*ZN2/ZN1 + ZZR(MZRS+4)=2.0/SQRT(3.0*(ZN1-ZN3)) + IF(ILIGN.GT.0) WRITE (6,210) (ZZR(MZRS+I),I=1,4) +* +* UNFOLD THE TRACKS. + IZI=MZIS+2 + IZR=MZRS+4 + DO 140 ISYM=-1,1,2 + DO 130 IFAC=3,8 + MZIR=MZIS + MZRR=MZRS + CALL SYB7TR(NA,NRD,MZIS,MZRS,IFAC,ISYM,NUMREG,ZZI(3),ZZR(1), + 1 MZIR,MZRR,ZZI(IZI+1),ZZR(IZR+1)) + IZI=IZI+MZIR + IZR=IZR+MZRR + 130 CONTINUE + 140 CONTINUE + NZI=IZI + NZR=IZR + ELSE + NZI=13*MZIS+3 + NZR=13*MZRS+5 + ENDIF +* + IF((ILIGN.GT.0).AND.(.NOT.LFAIRE)) THEN + WRITE(6,200) NA,NRD,NSECT,HSIDE,DXMIN,DELR,NZI,NZR,NXMIN, + 1 NXMAX + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XCOTE,VOLINT) + DEALLOCATE(NUMREG) + RETURN +* + 200 FORMAT(/49H SYB7TS: TRACKING OF A SECTORIZED HEXAGONAL CELL./ + 1 7H NA ,I8,29H (NUMBER OF ANGLES IN PI/2)/ + 2 7H NRD ,I8,22H (1+NUMBER OF TUBES)/ + 3 7H NSECT ,I8,22H (NUMBER OF SECTORS)/ + 4 7H HSIDE ,1P,E8.1,17H (HEXAGON SIDE)/ + 5 7H DXMIN ,1P,E8.1,24H (GEOMETRICAL EPSILON)/ + 6 7H DELR ,1P,E8.1,37H (HALF DISTANCE BETWEEN THE TRACKS)/ + 7 7H NZI ,I8,40H (NUMBER OF INTEGER TRACKING ELEMENTS)/ + 8 7H NZR ,I8,37H (NUMBER OF REAL TRACKING ELEMENTS)/ + 9 7H NXMIN ,I8,37H (MINIMUM NB. OF TRACKS PER REGION)/ + 1 7H NXMAX ,I8,37H (MAXIMUM NB. OF TRACKS PER REGION)) + 210 FORMAT (/47H SYB7TS: NUMERICAL ORTHONORMALIZATION FACTORS =,1P, + 1 4E12.4/) + END diff --git a/Dragon/src/SYB7TW.f b/Dragon/src/SYB7TW.f new file mode 100644 index 0000000..5333169 --- /dev/null +++ b/Dragon/src/SYB7TW.f @@ -0,0 +1,111 @@ +*DECK SYB7TW + SUBROUTINE SYB7TW (NRD,MRE,XICOTE,IRMIN,DELTCW,DELTCS,ORIPH6, + & ORIPHI,COSPH6,SINPHI,ISW2,LGTRAW,DELTAW) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the intersection lenghts of a track in a sectorized hexagonal +* cell, following a singular point at west. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NRD one plus the number of tubes in the cell. +* MRE first radius intersection the side or first region in contact +* with the external side. +* XICOTE intersections with the side. +* IRMIN region index in contact with the external side. +* DELTCW distance from the south-west corner. +* DELTCS distance from the south-east corner. +* ORIPH6 distance at the middle of south-west side. +* ORIPHI distance at the middle of south side. +* COSPH6 cosinus ($\\pi$/6-Phi). +* SINPHI sinus (Phi). +* +*Parameters: input/output +* ISW2 half side on west (2-3 followed by 4-5 or SW (N-S) followed by +* south (W-E)). +* +*Parameters: output +* LGTRAW removing/addition flag of the next intersection. The formula +* corresponding to case ISW2=5 is complex. In this case, the +* tangent can pass on both sides. +* DELTAW distance of the next track. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NRD,MRE,IRMIN,ISW2 + REAL XICOTE(NRD-1),DELTCW,DELTCS,ORIPH6,ORIPHI,COSPH6,SINPHI, + & DELTAW + LOGICAL LGTRAW +* +** Le cas le plus courant est : Secteur Suivant (Sud) +** Le cas general est nettement plus complexe : +* +* NE PAS CONFONDRE +* Intervalle et Limite +* +* Le Suivant depasse le Milieu du Cote Sud-West + IF (ISW2 .EQ. 2) THEN + IF (IRMIN .LE. MRE) THEN + ISW2 = 3 + ENDIF + ENDIF +* +* Le Suivant depasse le Milieu du Cote Sud + IF (ISW2 .EQ. 4) THEN + IF (IRMIN .LE. MRE) THEN + ISW2 = 5 + ENDIF + ENDIF +* +* Limite suivante Sud-West Nord (Haut) + IF (ISW2 .EQ. 2) THEN + LGTRAW = .TRUE. + DELTAW = ORIPH6 - XICOTE(IRMIN-1) * COSPH6 +* +* Limite suivante de Sud-West Sud (Bas) + ELSEIF (ISW2 .EQ. 3) THEN +* + LGTRAW = IRMIN .EQ. NRD +* +* Limite suivante (secteur) coin SSW + IF (LGTRAW) THEN + DELTAW = DELTCW +* +* Limite suivante egalement Sud-West Sud (Bas) + ELSE + DELTAW = ORIPH6 + XICOTE(IRMIN) * COSPH6 + ENDIF +* +* Limite suivante de Sud West (Horizontal Gauche) + ELSEIF (ISW2 .EQ. 4) THEN + LGTRAW = .TRUE. + DELTAW = ORIPHI - XICOTE(IRMIN-1) * SINPHI +* +* Limite suivante de Sud West (Horizontal Gauche) + ELSE +* +* Limite suivante (secteur) coin Extreme SSE + IF (IRMIN .GE. NRD) THEN + LGTRAW = .FALSE. + DELTAW = DELTCS + ELSE + LGTRAW = .TRUE. + DELTAW = ORIPHI + XICOTE(IRMIN) * SINPHI + ENDIF + ENDIF +* + RETURN + END diff --git a/Dragon/src/SYB7VO.f b/Dragon/src/SYB7VO.f new file mode 100644 index 0000000..278db67 --- /dev/null +++ b/Dragon/src/SYB7VO.f @@ -0,0 +1,119 @@ +*DECK SYB7VO + SUBROUTINE SYB7VO(NR,HSIDES,RAD,VOLINT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the volumes of an hexagonal cell. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NR one thus the number of tubes. +* HSIDES hexagon side. +* RAD radius of the tubes. +* +*Parameters: output +* VOLINT volumes. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NR + REAL HSIDES,RAD(NR-1),VOLINT(NR) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (SQRT32=1.7320508075689/2.0) +* + TETA0 = 6.0 + DO 10 IR=1,NR + VOLINT(IR)=0.0 + 10 CONTINUE + DDXY = HSIDES * SQRT32 +* + TETAC = ACOS(DDXY / HSIDES) + TETA2 = 0. + DO 20 IR = 1, NR-1 + IF (RAD(IR) .GT. DDXY) THEN + IRNEXT = IR + GOTO 30 + ENDIF + 20 CONTINUE + IRNEXT = NR +*---- +* IRNEXT : NEXT RADIUS INTERCEPTING A SIDE. +* DDY2 : LAST PROCESSED COORDINATE. +* ISNEXT : NEXT SECTOR. +*---- + 30 DDY2 = 0. + ISNEXT = 1 +*---- +* NEXT SECTOR +*---- + 40 IS = ISNEXT + IF (IS .NE. 0) THEN + IR0 = IRNEXT + DDY1 = DDY2 + TETA1 = TETA2 + TETA2 = IS * TETA0 +* +* THE ANGLE IS LIMITED BY THE DIAGONAL. + IF (TETA2 .GE. (TETAC - 1.E-6)) THEN + ISNEXT = 0 + TETA2 = TETAC + RAD2 = HSIDES + ELSE + ISNEXT = IS + 1 + RAD2 = DDXY / COS(TETA2) + ENDIF +* +* THE NEXT RADIUS IS INTERCEPTING THE SECTOR. + IF (IR0 .LT. NR) THEN + RADIR = RAD(IR0) + IF (RADIR .LT. (RAD2 * (1. - 1.E-6))) THEN + RAD2 = RADIR + TETA2 = ACOS(DDXY / RAD2) + IRNEXT = IR0 + 1 + ISNEXT = IS + ELSE IF (RADIR .LE. (RAD2 * (1. + 1.E-6))) THEN +* THE NEXT RADIUS IS EQUAL TO THE SECTOR. + IRNEXT = IR0 + 1 + ENDIF + ENDIF +* +* DDY2 IS THE NEXT COORDINATE AND DT IS HALF THE ANGLE +* INCREMENT FOR THE SECTOR. + DDY2 = RAD2 * SIN(TETA2) + DT = (TETA2 - TETA1) * 0.5 +* +* COMPLETE TUBES. + R1 = 0. + DO 50 IR = 1, IR0 - 1 + R0 = R1 + R1 = RAD(IR) + DR = (R1 - R0) * (R1 + R0) + VOLINT(IR) = VOLINT(IR) + DT * DR + 50 CONTINUE +* +* LAST SIDE-INTERCEPTED TUBE. + VOLMAX = DDXY * 0.5 * (DDY2 - DDY1) + VOLMAX = VOLMAX - DT * R1 * R1 + VOLINT(IR0) = VOLINT(IR0) + VOLMAX + GOTO 40 + ENDIF +* + DO 60 I = 1, NR + VOLINT(I) = 12.0 * VOLINT(I) + 60 CONTINUE + RETURN + END diff --git a/Dragon/src/SYBALC.f b/Dragon/src/SYBALC.f new file mode 100644 index 0000000..aa1c1a7 --- /dev/null +++ b/Dragon/src/SYBALC.f @@ -0,0 +1,212 @@ +*DECK SYBALC + SUBROUTINE SYBALC(NPIJ,MAXPTS,RAYRE,SIG,NGAUSS,ALBEDO,Z,PIJ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Pij calculation in 1D cylindrical geometry. The tracking is computed +* by subroutine SYBT1D. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NPIJ number of regions. +* MAXPTS first dimension of matrix PIJ. +* RAYRE radius of regions array. +* SIG total cross section array. +* NGAUSS number of Gauss points. +* ALBEDO outside albedo. +* Z tracking information. +* +*Parameters: output +* PIJ reduced collision probability matrix. +* +*Reference: +* A. Kavenoky, 'Calcul et utilisation des probabilites de premiere +* collision pour les milieux heterogenes a une dimension: Les programmes +* ALCOLL et CORTINA', note CEA-N-1077, Commissariat a l'energie +* atomique, mars 1969. +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NPIJ,MAXPTS,NGAUSS + REAL RAYRE(NPIJ+1),SIG(NPIJ),PIJ(MAXPTS,NPIJ),ALBEDO,Z(*) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MKI3=600,PI=3.1415926535,ZI30=0.785398164) + LOGICAL LGEMPT + REAL, ALLOCATABLE, DIMENSION(:,:) :: AUXI + COMMON /BICKL3/BI3(0:MKI3),BI31(0:MKI3),BI32(0:MKI3),PAS3,XLIM3,L3 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(AUXI(NPIJ,3)) +*---- +* TEST FOR VOIDED REGIONS +*---- + LGEMPT=.FALSE. + VOLI=PI*RAYRE(1)**2 + DO 10 IP=1,NPIJ + LGEMPT=LGEMPT.OR.(2.0*(RAYRE(IP+1)-RAYRE(IP))*SIG(IP).LE.0.004) + AUXI(IP,1)=PI*RAYRE(IP+1)**2-VOLI + AUXI(IP,2)=MAX(1.0E-10,SIG(IP)) + VOLI=PI*RAYRE(IP+1)**2 + 10 CONTINUE + SURF=2.0*PI*RAYRE(NPIJ+1) + PIJ(:MAXPTS,:NPIJ)=0.0 + IZ=1 + IF(.NOT.LGEMPT) THEN +* NO VOIDED REGIONS DETECTED. + DO 42 IX=1,NPIJ + DO 41 I=1,NGAUSS + IZ=IZ+2 + W=Z(IZ) + DO 20 ITR=IX,NPIJ + IZ=IZ+1 + AUXI(ITR,3)=AUXI(ITR,2)*Z(IZ) + 20 CONTINUE + AUX0=2.0*AUXI(IX,3) + DII=AUX0-ZI30+TABKI(3,AUX0) + PIJ(IX,IX)=PIJ(IX,IX)+W*DII/AUXI(IX,2)**2 + TAU=AUX0 + TAU1J=0.0 + DO 40 IP=IX+1,NPIJ + AUX1=AUXI(IP,3) + AUX2=TAU+2.0*AUXI(IP,3) + DII=AUX1-ZI30+TABKI(3,AUX1) + TAB0=TABKI(3,TAU) + TAB1=TABKI(3,TAU+AUX1) + TAB2=TABKI(3,AUX2) + CII=TAB0-2.0*TAB1+TAB2 + TAB0=TABKI(3,TAU1J) + TAB1=TABKI(3,TAU1J+AUX0) + TAB2=TABKI(3,TAU1J+AUX1) + TAB3=TABKI(3,TAU1J+AUX0+AUX1) + CIJ1=TAB0-TAB1-TAB2+TAB3 + PIJ(IP,IP)=PIJ(IP,IP)+W*(2.0*DII+CII)/AUXI(IP,2)**2 + PIJ(IX,IP)=PIJ(IX,IP)+W*CIJ1/(AUXI(IX,2)*AUXI(IP,2)) + TAUIJ=0.0 + DO 30 JP=IP+1,NPIJ + AUX3=AUXI(JP,3) + IF(TAUIJ+AUX1+AUX3.GE.XLIM3) THEN + TAB0=TABKI(3,TAUIJ) + TAB1=TABKI(3,TAUIJ+AUX1) + TAB2=TABKI(3,TAUIJ+AUX3) + TAB3=TABKI(3,TAUIJ+AUX1+AUX3) + ELSE + K=NINT(TAUIJ*PAS3) + TAB0=BI3(K)+TAUIJ*(BI31(K)+TAUIJ*BI32(K)) + TAUX=TAUIJ+AUX1 + K=NINT(TAUX*PAS3) + TAB1=BI3(K)+TAUX*(BI31(K)+TAUX*BI32(K)) + TAUX=TAUIJ+AUX3 + K=NINT(TAUX*PAS3) + TAB2=BI3(K)+TAUX*(BI31(K)+TAUX*BI32(K)) + TAUX=TAUIJ+AUX1+AUX3 + K=NINT(TAUX*PAS3) + TAB3=BI3(K)+TAUX*(BI31(K)+TAUX*BI32(K)) + ENDIF + CIJ2=TAB0-TAB1-TAB2+TAB3 + IF(TAUIJ+AUX2+AUX3.GE.XLIM3) THEN + TAB0=TABKI(3,TAUIJ+TAU+AUX1) + TAB1=TABKI(3,TAUIJ+AUX2) + TAB2=TABKI(3,TAUIJ+TAU+AUX1+AUX3) + TAB3=TABKI(3,TAUIJ+AUX2+AUX3) + ELSE + TAUX=TAUIJ+TAU+AUX1 + K=NINT(TAUX*PAS3) + TAB0=BI3(K)+TAUX*(BI31(K)+TAUX*BI32(K)) + TAUX=TAUIJ+AUX2 + K=NINT(TAUX*PAS3) + TAB1=BI3(K)+TAUX*(BI31(K)+TAUX*BI32(K)) + TAUX=TAUIJ+TAU+AUX1+AUX3 + K=NINT(TAUX*PAS3) + TAB2=BI3(K)+TAUX*(BI31(K)+TAUX*BI32(K)) + TAUX=TAUIJ+AUX2+AUX3 + K=NINT(TAUX*PAS3) + TAB3=BI3(K)+TAUX*(BI31(K)+TAUX*BI32(K)) + ENDIF + CIJ3=TAB0-TAB1-TAB2+TAB3 + PIJ(IP,JP)=PIJ(IP,JP)+W*(CIJ2+CIJ3)/(AUXI(IP,2)*AUXI(JP,2)) + TAUIJ=TAUIJ+AUX3 + 30 CONTINUE + TAU=AUX2 + TAU1J=TAU1J+AUX1 + 40 CONTINUE + 41 CONTINUE + 42 CONTINUE + ELSE + DO 72 IX=1,NPIJ + DO 71 I=1,NGAUSS + IZ=IZ+2 + W=Z(IZ) + DO 50 ITR=IX,NPIJ + IZ=IZ+1 + AUXI(ITR,3)=AUXI(ITR,2)*Z(IZ) + 50 CONTINUE + CALL SYB33C(DII,2.0*AUXI(IX,3)) + PIJ(IX,IX)=PIJ(IX,IX)+W*DII/AUXI(IX,2)**2 + TAU=2.0*AUXI(IX,3) + TAU1J=0.0 + DO 70 IP=IX+1,NPIJ + CALL SYB33C(DII,AUXI(IP,3)) + CALL SYB31C(CII,TAU,AUXI(IP,3),AUXI(IP,3)) + CALL SYB31C(CIJ1,TAU1J,2.0*AUXI(IX,3),AUXI(IP,3)) + PIJ(IP,IP)=PIJ(IP,IP)+W*(2.0*DII+CII)/AUXI(IP,2)**2 + PIJ(IX,IP)=PIJ(IX,IP)+W*CIJ1/(AUXI(IX,2)*AUXI(IP,2)) + TAUIJ=0.0 + DO 60 JP=IP+1,NPIJ + CALL SYB31C(CIJ2,TAUIJ,AUXI(IP,3),AUXI(JP,3)) + CALL SYB31C(CIJ3,TAUIJ+TAU+AUXI(IP,3),AUXI(IP,3),AUXI(JP,3)) + PIJ(IP,JP)=PIJ(IP,JP)+W*(CIJ2+CIJ3)/(AUXI(IP,2)*AUXI(JP,2)) + TAUIJ=TAUIJ+AUXI(JP,3) + 60 CONTINUE + TAU=TAU+2*AUXI(IP,3) + TAU1J=TAU1J+AUXI(IP,3) + 70 CONTINUE + 71 CONTINUE + 72 CONTINUE + ENDIF +* + DO 85 I=1,NPIJ + DO 80 J=I,NPIJ + VAL=PIJ(I,J) + PIJ(I,J)=VAL/AUXI(I,1) + PIJ(J,I)=VAL/AUXI(J,1) + 80 CONTINUE + 85 CONTINUE +*---- +* COMPUTING REFLECTED PROBABILITIES ASSUMING WHITE BOUNDARY CONDITION. +*---- + IF(ALBEDO.NE.0.0) THEN + PSS=1.0 + DO 100 IK=1,NPIJ + AUXI(IK,3)=1.0 + DO 90 JK=1,NPIJ + AUXI(IK,3)=AUXI(IK,3)-PIJ(IK,JK)*AUXI(JK,2) + 90 CONTINUE + PSS=PSS-4.0*AUXI(IK,1)*AUXI(IK,2)*AUXI(IK,3)/SURF + 100 CONTINUE + AUX0=ALBEDO/(1.0-ALBEDO*PSS) + DO 120 JK=1,NPIJ + AUX1=AUX0*(4.0*AUXI(JK,1)/SURF)*AUXI(JK,3) + DO 110 IK=1,NPIJ + PIJ(IK,JK)=PIJ(IK,JK)+AUXI(IK,3)*AUX1 + 110 CONTINUE + 120 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(AUXI) + RETURN + END diff --git a/Dragon/src/SYBALP.f b/Dragon/src/SYBALP.f new file mode 100644 index 0000000..c3963bd --- /dev/null +++ b/Dragon/src/SYBALP.f @@ -0,0 +1,217 @@ +*DECK SYBALP + SUBROUTINE SYBALP(NPIJ,MAXPTS,Y,SIG,NCOD,ALB,PIJ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Pij calculation using the method of Kavenoky in 1D slab geometry. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NPIJ number of regions. +* MAXPTS first dimension of matrix PIJ. +* Y abscissa array. +* SIG total cross section array. +* NCOD left and right type of boundary conditions (=1 void; +* =2 refl; =4 tran). +* ALB left and right albedos. +* +*Parameters: output +* PIJ reduced collision probability matrix. +* +*Reference: +* A. Kavenoky, 'Calcul et utilisation des probabilites de premiere +* collision pour les milieux heterogenes a une dimension: Les programmes +* ALCOLL et CORTINA', note CEA-N-1077, Commissariat a l'energie +* atomique, mars 1969. +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NPIJ,MAXPTS,NCOD(2) + REAL Y(NPIJ+1),SIG(NPIJ),ALB(2),PIJ(MAXPTS,NPIJ) +*---- +* LOCAL VARIABLES +*---- + CHARACTER BC*8 + REAL, ALLOCATABLE, DIMENSION(:,:) :: AUXI,F2 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(AUXI(2*NPIJ,3),F2(2*NPIJ,2*NPIJ)) +*---- +* SET THE BOUNDARY CONDITIONS +*---- + IF((NCOD(1).EQ.1).AND.(NCOD(2).EQ.1)) THEN + BC='VOID' + IF((ALB(1).NE.0.0).OR.(ALB(2).NE.0.0)) BC='ALBE' + ELSE IF((NCOD(1).EQ.4).AND.(NCOD(2).EQ.4)) THEN + BC='TRAN' + ELSE IF((ALB(1).EQ.0.0).AND.(ALB(2).EQ.0.0)) THEN + BC='VOID' + ELSE + BC='ALBE' + ENDIF +*---- +* COMPUTE THE PIJ MATRIX +*---- + PIJ(:MAXPTS,:NPIJ)=0.0 + IF(BC.EQ.'VOID') THEN + DO 10 IP=1,NPIJ + AUXI(IP,1)=Y(IP+1)-Y(IP) + AUXI(IP,3)=MAX(1.0E-10,AUXI(IP,1)*SIG(IP)) + AUXI(IP,2)=AUXI(IP,3)/AUXI(IP,1) + 10 CONTINUE + DO 25 IP=1,NPIJ + CALL SYBRII(RIIP,1.0,0.0,AUXI(IP,3)) + PIJ(IP,IP)=RIIP/AUXI(IP,2)**2 + TAU0=0.0 + DO 20 JP=IP+1,NPIJ + CALL SYBRIJ(RIJP,1.0,TAU0,AUXI(IP,3),AUXI(JP,3)) + PIJ(IP,JP)=RIJP/(AUXI(IP,2)*AUXI(JP,2)) + TAU0=TAU0+AUXI(JP,3) + 20 CONTINUE + 25 CONTINUE + DO 35 IP=1,NPIJ + DO 30 JP=IP,NPIJ + PIJ(JP,IP)=PIJ(IP,JP) + 30 CONTINUE + 35 CONTINUE + ELSE IF(BC.EQ.'TRAN') THEN + DO 40 IP=1,NPIJ + AUXI(IP,1)=Y(IP+1)-Y(IP) + AUXI(IP,3)=MAX(1.0E-10,AUXI(IP,1)*SIG(IP)) + AUXI(IP,2)=AUXI(IP,3)/AUXI(IP,1) + 40 CONTINUE + TAUCEL=0.0 + DO 50 IP=1,NPIJ + TAUCEL=TAUCEL+AUXI(IP,3) + 50 CONTINUE + M=-1 + 60 M=M+1 + IF(M.GT.100) CALL XABORT('SYBALP: UNABLE TO CONVERGE(1).') + F2(:2*NPIJ,:2*NPIJ)=0.0 + SMALL=0.0 + DO 75 IP=1,NPIJ + CALL SYBRII(RIIP,1.0,M*TAUCEL,AUXI(IP,3)) + CALL SYBRII(RIIM,-1.0,(M+1)*TAUCEL,AUXI(IP,3)) + F2(IP,IP)=F2(IP,IP)+(RIIP+RIIM)/AUXI(IP,2)**2 + SMALL=MAX(SMALL,ABS(F2(IP,IP)*AUXI(IP,2))) + TAU0=0.0 + DO 70 JP=IP+1,NPIJ + CALL SYBRIJ(RIJP,1.0,M*TAUCEL+TAU0,AUXI(IP,3),AUXI(JP,3)) + CALL SYBRIJ(RIJM,-1.0,(M+1)*TAUCEL-TAU0,AUXI(IP,3),AUXI(JP,3)) + F2(IP,JP)=F2(IP,JP)+(RIJP+RIJM)/(AUXI(IP,2)*AUXI(JP,2)) + TAU0=TAU0+AUXI(JP,3) + SMALL=MAX(SMALL,ABS(F2(IP,JP)*AUXI(JP,2))) + 70 CONTINUE + 75 CONTINUE + DO 85 IP=1,NPIJ + DO 80 JP=IP,NPIJ + PIJ(IP,JP)=PIJ(IP,JP)+F2(IP,JP) + 80 CONTINUE + 85 CONTINUE + IF(SMALL.LE.1.0E-6) GO TO 90 + GO TO 60 + 90 DO 105 IP=1,NPIJ + DO 100 JP=IP,NPIJ + PIJ(JP,IP)=PIJ(IP,JP) + 100 CONTINUE + 105 CONTINUE + ELSE IF(BC.EQ.'ALBE') THEN + TAUCEL=0.0 + DO 110 IP=1,NPIJ + AUXI(IP,1)=Y(IP+1)-Y(IP) + AUXI(IP,3)=MAX(1.0E-10,AUXI(IP,1)*SIG(IP)) + AUXI(IP,2)=AUXI(IP,3)/AUXI(IP,1) + AUXI(2*NPIJ-IP+1,1)=AUXI(IP,1) + AUXI(2*NPIJ-IP+1,2)=AUXI(IP,2) + AUXI(2*NPIJ-IP+1,3)=AUXI(IP,3) + TAUCEL=TAUCEL+2.0*AUXI(IP,3) + 110 CONTINUE + F2(:2*NPIJ,:2*NPIJ)=0.0 + DO 125 IP=1,2*NPIJ + CALL SYBRII(RIIP,1.0,0.0,AUXI(IP,3)) + F2(IP,IP)=F2(IP,IP)+RIIP/AUXI(IP,2)**2 + TAU0=0.0 + DO 120 JP=IP+1,2*NPIJ + CALL SYBRIJ(RIJP,1.0,TAU0,AUXI(IP,3),AUXI(JP,3)) + F2(IP,JP)=F2(IP,JP)+RIJP/(AUXI(IP,2)*AUXI(JP,2)) + F2(JP,IP)=F2(JP,IP)+RIJP/(AUXI(IP,2)*AUXI(JP,2)) + TAU0=TAU0+AUXI(JP,3) + 120 CONTINUE + 125 CONTINUE + DO 135 IP=1,NPIJ + DO 130 JP=1,NPIJ + PIJ(IP,JP)=PIJ(IP,JP)+F2(IP,JP)+ALB(2)*F2(2*NPIJ+1-IP,JP) + 130 CONTINUE + 135 CONTINUE + M=0 + 140 M=M+1 + IF(M.GT.100) CALL XABORT('UNABLE TO CONVERGE(2).') + F2(:2*NPIJ,:2*NPIJ)=0.0 + SMALL=0.0 + DO 155 IP=1,2*NPIJ + CALL SYBRII(RIIP,1.0,M*TAUCEL,AUXI(IP,3)) + F2(IP,IP)=F2(IP,IP)+ALB(1)**M*RIIP/AUXI(IP,2)**2 + SMALL=MAX(SMALL,ABS(F2(IP,IP)*AUXI(IP,2))) + TAU0=0.0 + DO 150 JP=IP+1,2*NPIJ + CALL SYBRIJ(RIJP,1.0,M*TAUCEL+TAU0,AUXI(IP,3),AUXI(JP,3)) + F2(IP,JP)=F2(IP,JP)+ALB(1)**M*RIJP/(AUXI(IP,2)*AUXI(JP,2)) + CALL SYBRIJ(RIJM,-1.0,M*TAUCEL-TAU0,AUXI(JP,3),AUXI(IP,3)) + F2(JP,IP)=F2(JP,IP)+ALB(1)**M*RIJM/(AUXI(IP,2)*AUXI(JP,2)) + TAU0=TAU0+AUXI(JP,3) + SMALL=MAX(SMALL,ABS(F2(IP,JP)*AUXI(JP,2))) + SMALL=MAX(SMALL,ABS(F2(JP,IP)*AUXI(IP,2))) + 150 CONTINUE + 155 CONTINUE + DO 165 IP=1,NPIJ + DO 160 JP=1,NPIJ + PIJ(IP,JP)=PIJ(IP,JP)+ALB(2)**M*F2(IP,JP)+ALB(2)**(M-1) + 1 *F2(2*NPIJ+1-IP,JP) + 160 CONTINUE + 165 CONTINUE + F2(:2*NPIJ,:2*NPIJ)=0.0 + DO 175 IP=1,NPIJ + CALL SYBRII(RIIM,-1.0,M*TAUCEL,AUXI(IP,3)) + F2(IP,IP)=F2(IP,IP)+ALB(1)**M*RIIM/AUXI(IP,2)**2 + TAU0=0.0 + DO 170 JP=IP+1,2*NPIJ + CALL SYBRIJ(RIJM,-1.0,M*TAUCEL-TAU0,AUXI(IP,3),AUXI(JP,3)) + F2(IP,JP)=F2(IP,JP)+ALB(1)**M*RIJM/(AUXI(IP,2)*AUXI(JP,2)) + CALL SYBRIJ(RIJP,1.0,M*TAUCEL+TAU0,AUXI(JP,3),AUXI(IP,3)) + F2(JP,IP)=F2(JP,IP)+ALB(1)**M*RIJP/(AUXI(IP,2)*AUXI(JP,2)) + TAU0=TAU0+AUXI(JP,3) + SMALL=MAX(SMALL,ABS(F2(IP,JP)*AUXI(JP,2))) + SMALL=MAX(SMALL,ABS(F2(JP,IP)*AUXI(IP,2))) + 170 CONTINUE + 175 CONTINUE + DO 185 IP=1,NPIJ + DO 180 JP=1,NPIJ + PIJ(IP,JP)=PIJ(IP,JP)+ALB(2)**M*F2(IP,JP)+ALB(2)**(M+1)* + 1 F2(2*NPIJ+1-IP,JP) + 180 CONTINUE + 185 CONTINUE + IF(SMALL.LE.1.0E-6) GO TO 190 + GO TO 140 + ENDIF + 190 DO 210 IP=1,NPIJ + DO 200 JP=1,NPIJ + PIJ(IP,JP)=PIJ(IP,JP)/AUXI(IP,1) + 200 CONTINUE + 210 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(F2,AUXI) + RETURN + END diff --git a/Dragon/src/SYBALS.f b/Dragon/src/SYBALS.f new file mode 100644 index 0000000..ae10ef8 --- /dev/null +++ b/Dragon/src/SYBALS.f @@ -0,0 +1,171 @@ +*DECK SYBALS + SUBROUTINE SYBALS(NPIJ,MAXPTS,RAYRE,SIG,NGAUSS,ALBEDO,Z,PIJ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Pij calculation in 1D spherical geometry. The tracking is computed +* by subroutine SYBT1D. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NPIJ number of regions. +* MAXPTS first dimension of matrix PIJ. +* RAYRE radius of regions array. +* SIG total cross section array. +* NGAUSS number of Gauss points. +* ALBEDO outside albedo. +* Z tracking information. +* +*Parameters: output +* PIJ reduced collision probability matrix. +* +*Reference: +* A. Kavenoky, 'Calcul et utilisation des probabilites de premiere +* collision pour les milieux heterogenes a une dimension: Les programmes +* ALCOLL et CORTINA', note CEA-N-1077, Commissariat a l'energie +* atomique, mars 1969. +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NPIJ,MAXPTS,NGAUSS + REAL RAYRE(NPIJ+1),SIG(NPIJ),PIJ(MAXPTS,NPIJ),ALBEDO,Z(*) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (PI=3.1415926535) + LOGICAL LGEMPT + REAL, ALLOCATABLE, DIMENSION(:,:) :: AUXI +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(AUXI(NPIJ,3)) +*---- +* TEST FOR VOIDED REGIONS +*---- + LGEMPT=.FALSE. + VOLI=PI*RAYRE(1)**2 + DO 10 IP=1,NPIJ + LGEMPT=LGEMPT.OR.(2.0*(RAYRE(IP+1)-RAYRE(IP))*SIG(IP).LE.0.004) + AUXI(IP,1)=(4.0/3.0)*PI*RAYRE(IP+1)**3-VOLI + AUXI(IP,2)=MAX(1.0E-10,SIG(IP)) + VOLI=(4.0/3.0)*PI*RAYRE(IP+1)**3 + 10 CONTINUE + SURF=4.0*PI*RAYRE(NPIJ+1)**2 + PIJ(:MAXPTS,:NPIJ)=0.0 + IZ=1 + IF(.NOT.LGEMPT) THEN +* NO VOIDED REGIONS DETECTED. + DO 42 IX=1,NPIJ + DO 41 I=1,NGAUSS + IZ=IZ+2 + W=Z(IZ) + DO 20 ITR=IX,NPIJ + IZ=IZ+1 + AUXI(ITR,3)=AUXI(ITR,2)*Z(IZ) + 20 CONTINUE + AUX0=2.0*AUXI(IX,3) + EXP0=EXP(-AUX0) + DII=AUX0-1.0+EXP0 + PIJ(IX,IX)=PIJ(IX,IX)+W*DII/AUXI(IX,2)**2 + TAU=AUX0 + TAU1J=0.0 + DO 40 IP=IX+1,NPIJ + AUX1=AUXI(IP,3) + EXP1=EXP(-TAU) + EXP2=EXP(-AUX1) + EXP3=EXP(-TAU1J) + DII=AUX1-1.0+EXP2 + CII=EXP1*(1.0-2.0*EXP2+EXP2*EXP2) + CIJ1=EXP3*(1.0-EXP0-EXP2+EXP0*EXP2) + PIJ(IP,IP)=PIJ(IP,IP)+W*(2.0*DII+CII)/AUXI(IP,2)**2 + PIJ(IX,IP)=PIJ(IX,IP)+W*CIJ1/(AUXI(IX,2)*AUXI(IP,2)) + TAUIJ=0.0 + DO 30 JP=IP+1,NPIJ + EXP4=EXP(-TAUIJ) + EXP5=EXP(-AUXI(JP,3)) + CIJ2=EXP4*(1.0-EXP2-EXP5+EXP2*EXP5) + CIJ3=EXP1*EXP2*EXP4*(1.0-EXP2-EXP5+EXP2*EXP5) + PIJ(IP,JP)=PIJ(IP,JP)+W*(CIJ2+CIJ3)/(AUXI(IP,2)*AUXI(JP,2)) + TAUIJ=TAUIJ+AUXI(JP,3) + 30 CONTINUE + TAU=TAU+2.0*AUX1 + TAU1J=TAU1J+AUX1 + 40 CONTINUE + 41 CONTINUE + 42 CONTINUE + ELSE + DO 72 IX=1,NPIJ + DO 71 I=1,NGAUSS + IZ=IZ+2 + W=Z(IZ) + DO 50 ITR=IX,NPIJ + IZ=IZ+1 + AUXI(ITR,3)=AUXI(ITR,2)*Z(IZ) + 50 CONTINUE + CALL SYB43C(DII,2.0*AUXI(IX,3)) + PIJ(IX,IX)=PIJ(IX,IX)+W*DII/AUXI(IX,2)**2 + TAU=2.0*AUXI(IX,3) + TAU1J=0.0 + DO 70 IP=IX+1,NPIJ + CALL SYB43C(DII,AUXI(IP,3)) + CALL SYB41C(CII,TAU,AUXI(IP,3),AUXI(IP,3)) + CALL SYB41C(CIJ1,TAU1J,2.0*AUXI(IX,3),AUXI(IP,3)) + PIJ(IP,IP)=PIJ(IP,IP)+W*(2.0*DII+CII)/AUXI(IP,2)**2 + PIJ(IX,IP)=PIJ(IX,IP)+W*CIJ1/(AUXI(IX,2)*AUXI(IP,2)) + TAUIJ=0.0 + DO 60 JP=IP+1,NPIJ + CALL SYB41C(CIJ2,TAUIJ,AUXI(IP,3),AUXI(JP,3)) + CALL SYB41C(CIJ3,TAUIJ+TAU+AUXI(IP,3),AUXI(IP,3),AUXI(JP,3)) + PIJ(IP,JP)=PIJ(IP,JP)+W*(CIJ2+CIJ3)/(AUXI(IP,2)*AUXI(JP,2)) + TAUIJ=TAUIJ+AUXI(JP,3) + 60 CONTINUE + TAU=TAU+2*AUXI(IP,3) + TAU1J=TAU1J+AUXI(IP,3) + 70 CONTINUE + 71 CONTINUE + 72 CONTINUE + ENDIF +* + DO 85 I=1,NPIJ + DO 80 J=I,NPIJ + VAL=PIJ(I,J) + PIJ(I,J)=VAL/AUXI(I,1) + PIJ(J,I)=VAL/AUXI(J,1) + 80 CONTINUE + 85 CONTINUE +*---- +* COMPUTING REFLECTED PROBABILITIES ASSUMING WHITE BOUNDARY CONDITION. +*---- + IF(ALBEDO.NE.0.0) THEN + PSS=1.0 + DO 100 IK=1,NPIJ + AUXI(IK,3)=1.0 + DO 90 JK=1,NPIJ + AUXI(IK,3)=AUXI(IK,3)-PIJ(IK,JK)*AUXI(JK,2) + 90 CONTINUE + PSS=PSS-4.0*AUXI(IK,1)*AUXI(IK,2)*AUXI(IK,3)/SURF + 100 CONTINUE + AUX0=ALBEDO/(1.0-ALBEDO*PSS) + DO 120 JK=1,NPIJ + AUX1=AUX0*(4.0*AUXI(JK,1)/SURF)*AUXI(JK,3) + DO 110 IK=1,NPIJ + PIJ(IK,JK)=PIJ(IK,JK)+AUXI(IK,3)*AUX1 + 110 CONTINUE + 120 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(AUXI) + RETURN + END diff --git a/Dragon/src/SYBCP1.f b/Dragon/src/SYBCP1.f new file mode 100644 index 0000000..713c338 --- /dev/null +++ b/Dragon/src/SYBCP1.f @@ -0,0 +1,192 @@ +*DECK SYBCP1 + SUBROUTINE SYBCP1 (IPTRK,ITG,IMPX,NREG,SIGT,SIGW,PIJ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the scattering-reduced collision probabilities for +* Sybil. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK pointer to the Sybil tracking (L_TRACK signature). +* ITG type of Sybil one-speed solution operator. +* IMPX print flag (equal to zero for no print). +* NREG total number of regions. +* SIGT total macroscopic cross sections ordered by volume. +* SIGW P0 within-group scattering macroscopic cross sections +* ordered by volume. +* +*Parameters: output +* PIJ scattering-reduced collision probabilities matrix. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER ITG,IMPX,NREG + REAL SIGT(NREG),SIGW(NREG),PIJ(NREG,NREG) +*---- +* LOCAL VARIABLES +*---- + INTEGER IPAR(16) + INTEGER, TARGET, SAVE, DIMENSION(1) :: IDUMMY + REAL, TARGET, SAVE, DIMENSION(1) :: DUMMY + INTEGER, ALLOCATABLE, DIMENSION(:) :: NCODE,NMC3,LSEC4,NMC4,NMCR4, + 1 MAIL,IFR,INUM,MIX,IGEN + REAL, ALLOCATABLE, DIMENSION(:) :: XX2,ZCODE,ZTR,RAYR3,PROCE,XX4, + 1 YY4,RAYR4,ALB,DVX + INTEGER, POINTER, DIMENSION(:) :: IZMAI + REAL, POINTER, DIMENSION(:) :: RZMAI + TYPE(C_PTR) :: IZMAI_PTR,RZMAI_PTR +* + IF(ITG.EQ.1) THEN + PIJ(1,1)=1.0/(SIGT(1)-SIGW(1)) + ELSE IF(ITG.EQ.2) THEN + CALL LCMSIX(IPTRK,'PURE-GEOM',1) + CALL LCMGET(IPTRK,'PARAM',IPAR) + ITYPE=IPAR(1) + IHEX=IPAR(2) + IQUA2=IPAR(3) + IF(ITYPE.GE.8) CALL LCMGET(IPTRK,'SIDE',SIDE) + ALLOCATE(XX2(NREG+1),NCODE(6),ZCODE(6)) + CALL LCMGET(IPTRK,'XXX',XX2) + CALL LCMGET(IPTRK,'NCODE',NCODE) + CALL LCMGET(IPTRK,'ZCODE',ZCODE) + CALL LCMSIX(IPTRK,' ',2) +* + IF(ITYPE.EQ.2) THEN + CALL SYBALP(NREG,NREG,XX2,SIGT,NCODE,ZCODE,PIJ) + ELSE IF(ITYPE.EQ.3) THEN + ALLOCATE(ZTR(1+IQUA2*((NREG*(5+NREG))/2))) + CALL SYBT1D(NREG,XX2,.FALSE.,IQUA2,ZTR) + CALL SYBALC(NREG,NREG,XX2,SIGT,IQUA2,ZCODE(2),ZTR,PIJ) + DEALLOCATE(ZTR) + ELSE IF(ITYPE.EQ.4) THEN + ALLOCATE(ZTR(1+IQUA2*((NREG*(5+NREG))/2))) + CALL SYBT1D(NREG,XX2,.TRUE.,IQUA2,ZTR) + CALL SYBALS(NREG,NREG,XX2,SIGT,IQUA2,ZCODE(2),ZTR,PIJ) + DEALLOCATE(ZTR) + ENDIF + DEALLOCATE(ZCODE,NCODE,XX2) + CALL SYBWIJ(NREG,NREG,SIGW,PIJ) + ELSE IF(ITG.EQ.3) THEN + CALL LCMSIX(IPTRK,'DOITYOURSELF',1) + CALL LCMGET(IPTRK,'PARAM',IPAR) + NSUPCE=IPAR(1) + IQUA3=IPAR(2) + ISTAT=IPAR(3) + ALLOCATE(NMC3(NSUPCE+1),RAYR3(NSUPCE+NREG),PROCE(NSUPCE**2)) + CALL LCMGET(IPTRK,'NMC',NMC3) + CALL LCMGET(IPTRK,'RAYRE',RAYR3) + CALL LCMGET(IPTRK,'PROCEL',PROCE) + CALL LCMSIX(IPTRK,' ',2) + NPIJ=0 + DO 10 IKG=1,NSUPCE + J2=NMC3(IKG+1)-NMC3(IKG) + NPIJ=NPIJ+J2*J2 + 10 CONTINUE +* + CALL SYBRXE(NREG,NPIJ,NSUPCE,RAYR3,SIGT,SIGW,PIJ,IQUA3,ISTAT, + 1 NMC3,PROCE,IMPX) + DEALLOCATE(PROCE,RAYR3,NMC3) + ELSE IF(ITG.EQ.4) THEN + CALL LCMSIX(IPTRK,'EURYDICE',1) + CALL LCMGET(IPTRK,'PARAM',IPAR) + IHEX=IPAR(1) + MULTC=IPAR(2) + IWIGN=IPAR(3) + NMCEL=IPAR(4) + NMERGE=IPAR(5) + NGEN=IPAR(6) + IJAT=IPAR(7) + LMAILI=IPAR(15) + LMAILR=IPAR(16) + ALLOCATE(LSEC4(NGEN),NMC4(NGEN+1),NMCR4(NGEN+1),MAIL(2*NGEN)) + ALLOCATE(XX4(NGEN),YY4(NGEN)) + CALL LCMGET(IPTRK,'XX',XX4) + CALL LCMGET(IPTRK,'YY',YY4) + CALL LCMGET(IPTRK,'LSECT',LSEC4) + CALL LCMGET(IPTRK,'NMC',NMC4) + CALL LCMGET(IPTRK,'NMCR',NMCR4) + CALL LCMGET(IPTRK,'MAIL',MAIL) + ALLOCATE(RAYR4(NMCR4(NGEN+1))) + CALL LCMGET(IPTRK,'RAYRE',RAYR4) + IF(LMAILI.GT.0) THEN + CALL LCMGPD(IPTRK,'ZMAILI',IZMAI_PTR) + CALL C_F_POINTER(IZMAI_PTR,IZMAI,(/ LMAILI /)) + ELSE +* THIS INFO IS NOT REQUIRED IN THE CALLED ROUTINE. + IZMAI=>IDUMMY + ENDIF + IF(LMAILR.GT.0) THEN + CALL LCMGPD(IPTRK,'ZMAILR',RZMAI_PTR) + CALL C_F_POINTER(RZMAI_PTR,RZMAI,(/ LMAILR /)) + ELSE +* THIS INFO IS NOT REQUIRED IN THE CALLED ROUTINE. + RZMAI=>DUMMY + ENDIF + NCOUR=4 + IF(IHEX.NE.0) NCOUR=6 + IF(MULTC.EQ.4) NCOUR=3*NCOUR + ALLOCATE(IFR(NCOUR*NMCEL),INUM(NMCEL),MIX(NCOUR*NMERGE), + 1 IGEN(NMERGE)) + ALLOCATE(ALB(NCOUR*NMCEL),DVX(NCOUR*NMERGE)) + CALL LCMGET(IPTRK,'IFR',IFR) + CALL LCMGET(IPTRK,'ALB',ALB) + CALL LCMGET(IPTRK,'INUM',INUM) + CALL LCMGET(IPTRK,'MIX',MIX) + CALL LCMGET(IPTRK,'DVX',DVX) + CALL LCMGET(IPTRK,'IGEN',IGEN) + CALL LCMSIX(IPTRK,' ',2) +* + NPIJ=0 + DO 20 IKG=1,NGEN + J2=NMC4(IKG+1)-NMC4(IKG) + NPIJ=NPIJ+J2*J2 + 20 CONTINUE + NPIS=NMC4(NGEN+1) + IF(MULTC.EQ.1) THEN + CALL SYBRX2(NREG,NPIJ,NPIS,SIGT,SIGW,PIJ,IMPX,NCOUR, + 1 IWIGN,NMCEL,NMERGE,NGEN,IPAR(8),XX4,YY4,NMC4,RAYR4,MAIL, + 2 RZMAI,IFR,ALB,INUM,IGEN) + ELSE + NRAYRE=NMCR4(NGEN+1) + CALL SYBRX3(MULTC,NREG,NPIJ,NPIS,NRAYRE,SIGT,SIGW,PIJ,IMPX, + 1 NCOUR,IWIGN,NMCEL,NMERGE,NGEN,IJAT,IPAR(8),XX4,YY4,LSEC4, + 2 NMC4,NMCR4,RAYR4,MAIL,IZMAI,RZMAI,IFR,ALB,INUM,MIX,DVX,IGEN) + ENDIF + DEALLOCATE(DVX,ALB) + DEALLOCATE(IGEN,MIX,INUM,IFR) + DEALLOCATE(RAYR4,YY4,XX4) + DEALLOCATE(MAIL,NMCR4,NMC4,LSEC4) + ELSE + CALL XABORT('SYBCP1: UNKNOWN CP MODULE.') + ENDIF +* + IF(IMPX.GE.7) THEN + WRITE (6,1130) (J,J=1,NREG) + DO 90 I=1,NREG + WRITE (6,1140) I,(PIJ(I,J),J=1,NREG) + 90 CONTINUE + WRITE (6,'(//)') + ENDIF + RETURN +* + 1130 FORMAT (//49H SYBCP1: SCATTERING-REDUCED COLLISION PROBABILITY, + 1 9H MATRIX ://(11X,2HJ=,I4,:,5X,2HJ=,I4,:,5X,2HJ=,I4,:,5X,2HJ=, + 2 I4,:,5X,2HJ=,I4,:,5X,2HJ=,I4,:,5X,2HJ=,I4,:,5X,2HJ=,I4,:,5X, + 3 2HJ=,I4,:,5X,2HJ=,I4,:,5X,2HJ=,I4)) + 1140 FORMAT (3H I=,I4,2H: ,1P,11E11.3/(9X,11E11.3)) + END diff --git a/Dragon/src/SYBEUR.f b/Dragon/src/SYBEUR.f new file mode 100644 index 0000000..d606a67 --- /dev/null +++ b/Dragon/src/SYBEUR.f @@ -0,0 +1,506 @@ +*DECK SYBEUR + SUBROUTINE SYBEUR (MAXPTS,MAXCEL,MAXJ,MAXZ,IPGEOM,NREG,IR,MAT, + 1 VOL,ILK,IMPX,IHEX,NCOUR,LMAILI,LMAILR,NMCEL,NMERGE,NGEN,IJAT, + 2 MULTC,IWIGN,IHALT,ILIGN,INORM,IRECT,IQW,IQUAD,XX,YY,LSECT,NMC, + 3 NMCR,RAYRE,MAIL,IZMAIL,RZMAIL,IFR,ALB,SUR,INUM,MIX,DVX,IGEN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover and analysis of the geometry for the description of a 2-D +* assembly (Eurydice-2) for the interface current method. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* MAXPTS allocated storage for arrays of dimension NREG. +* MAXCEL allocated storage for arrays of dimension NMCEL, NMERGE or +* NGEN. +* MAXJ allocated storage for arrays of dimension IJAS, IJAZ or IJAT. +* MAXZ allocated storage for arrays of dimension LMAILI or LMAILR. +* IPGEOM pointer to the geometry LCM object (L_GEOM signature). +* NREG total number of volumes. +* IR number of mixtures. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* ILK leakage flag (ILK=.TRUE. if neutron leakage through external +* boundary is present). +* IMPX print flag (equal to 0 for no print). +* IHEX type of lattice: =0 Cartesian lattice; .ne.0 hexagonal +* lattice. +* NCOUR number of out-currents per cell. +* LMAILI space required to store the integer tracking information. +* LMAILR space required to store the real tracking information. +* MULTC type of multicell approximation. +* IWIGN type of cylinderization (=1/2/3: Askew/Wigner/Sanchez +* cylinderization). +* IHALT halt switch (=1 to stop after calculation of the maximum +* tracking storage). +* ILIGN tracking print flag (=1 to print the tracking). +* INORM track normalization flag (=1 to avoid track normalization). +* IRECT rectangular flag (=1 to avoid considering symmetries of +* square cells). +* IQW equal weight quadrature flag (=1 to use equal weight +* quadratures in angle and space). +* IQUAD quadrature parameters. +* NMCEL total number of cells in the domain. +* IFR index-number of in-currents. +* ALB transmission/albedo associated with each in-current. +* SUR surface associated with each in-current. +* NMERGE total number of merged cells for which specific values +* of the neutron flux and reactions rates are required. +* Many cells with different position in the domain can +* be merged before the neutron flux calculation if they +* own the same generating cell (NMERGE.le.NMCEL). +* IJAT total number of distinct out-currents. +* INUM index-number of the merged cell associated to each cell. +* MIX index-number of out-currents. +* DVX weight associated with each out-current. +* Note: IFR, ALB, MIX and DVX contains information to rebuild +* the geometrical 'A' matrix. +* NGEN total number of generating cells. A generating cell is +* defined by its material and dimensions, irrespective of +* its position in the domain (NGEN.le.NMERGE). +* XX X-thickness of the generating cells. +* YY Y-thickness of the generating cells. +* LSECT type of sectorization. +* NMC offset of the first volume in each generating cell. +* NMCR offset of the first radius in each generating cell +* (identical to NMC in no-sectorization cases). +* RAYRE radius of the tubes in each generating cell. +* MAIL offset of the first tracking information in each generating +* cell. +* IZMAIL integer tracking information. +* RZMAIL real tracking information. +* IGEN index-number of the generating cell associated with each +* merged cell. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPGEOM + INTEGER MAXPTS,MAXCEL,MAXJ,MAXZ,NREG,IR,MAT(MAXPTS),IMPX,IHEX, + 1 NCOUR,LMAILI,LMAILR,NMCEL,NMERGE,NGEN,IJAT,MULTC,IWIGN,IHALT, + 2 ILIGN,INORM,IRECT,IQW,IQUAD(4),LSECT(MAXCEL),NMC(MAXCEL+1), + 3 NMCR(MAXCEL+1),MAIL(2,MAXCEL),IZMAIL(MAXZ),IFR(MAXJ), + 4 INUM(MAXCEL),MIX(MAXJ),IGEN(MAXCEL) + REAL VOL(MAXPTS),XX(MAXCEL),YY(MAXCEL),RAYRE(MAXPTS),RZMAIL(MAXZ), + 1 ALB(MAXJ),SUR(MAXJ),DVX(MAXJ) + LOGICAL ILK +*---- +* LOCAL VARIABLES +*---- + PARAMETER (PI=3.141592654) + LOGICAL LHEX + CHARACTER HSMG*131,HDOM*8 + INTEGER NCODE(6),IIT(24),ISMR(6,8),ISMH(8,12),ZZI + REAL ZCODE(6) + INTEGER, ALLOCATABLE, DIMENSION(:) :: IORI + REAL, ALLOCATABLE, DIMENSION(:) :: POURCE,ZZ,VOL2,RAD +*---- +* DATA STATEMENTS +*---- + SAVE ISMR,ISMH,IIT + DATA ISMR/1,2,3,4,0,0,3,4,2,1,0,0,2,1,4,3,0,0,4,3,1,2,0,0, + 1 2,1,3,4,0,0,3,4,1,2,0,0,1,2,4,3,0,0,4,3,2,1,0,0/ + DATA ISMH/1,2,3,4,5,6,0,0,6,1,2,3,4,5,0,0,5,6,1,2,3,4,0,0, + 1 4,5,6,1,2,3,0,0,3,4,5,6,1,2,0,0,2,3,4,5,6,1,0,0, + 2 1,6,5,4,3,2,0,0,2,1,6,5,4,3,0,0,3,2,1,6,5,4,0,0, + 3 4,3,2,1,6,5,0,0,5,4,3,2,1,6,0,0,6,5,4,3,2,1,0,0/ + DATA IIT/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20, + 1 24,28,32,64/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IORI(MAXCEL),POURCE(MAXCEL)) +* + CALL READEU(MAXPTS,MAXCEL,IPGEOM,IR,MAT,ILK,NMCEL,NMERGE, + 1 NGEN,INUM,IGEN,NREG,LX,LY,XX,YY,LSECT,RAYRE,NMC,NMCR,IORI, + 2 NCODE,ZCODE,IHEX,IMPX) + LHEX=IHEX.NE.0 + IF(MULTC.LE.2) THEN +* MODIFICATION OF THE RADIUS IN CASES WHERE THEY INTERCEPT +* THE CELL BOUNDARY. CYLINDERIZED TUBES ARE COMPUTED SO AS +* TO PRESERVE THE EXACT VOLUMES. + DO 25 IKG=1,NGEN + I1=NMC(IKG)+1 + I2=NMC(IKG+1) + DO 20 I=I1+1,I2 + RJ=RAYRE(I) + VTOT=PI*RJ*RJ + IF(LHEX) THEN + A=XX(IKG)*SQRT(3.0) + IF(2.0*RJ.GT.A) THEN + THETA=ACOS(0.5*A/RJ) + VT=0.5*A*RJ*SIN(THETA) + VC=RJ*RJ*THETA + VTOT=VTOT-6.0*(VC-VT) + RJ=SQRT(VTOT/PI) + ENDIF + ELSE + IF(2.0*RJ.GT.XX(IKG)) THEN + THETA=ACOS(0.5*XX(IKG)/RJ) + VT=0.5*XX(IKG)*RJ*SIN(THETA) + VC=RJ*RJ*THETA + VTOT=VTOT-2.0*(VC-VT) + ENDIF + IF(2.0*RJ.GT.YY(IKG)) THEN + THETA=ACOS(0.5*YY(IKG)/RJ) + VT=0.5*YY(IKG)*RJ*SIN(THETA) + VC=RJ*RJ*THETA + VTOT=VTOT-2.0*(VC-VT) + ENDIF + IF(2.0*RJ.GT.MIN(XX(IKG),YY(IKG))) RJ=SQRT(VTOT/PI) + ENDIF + RAYRE(I)=RJ +20 CONTINUE +25 CONTINUE +* + DO 30 IKG=1,NGEN + IF (LSECT(IKG).NE.0) CALL XABORT('SYBEUR: SECTORIZATION FO' + 1 //'RBIDDEN.') +30 CONTINUE +* + IF(.NOT.LHEX) THEN + A=0.0 + B=0.0 + DO 40 IKG=1,NGEN + IF((A.NE.0.0).AND.(A.NE.XX(IKG)).AND.(IWIGN.EQ.2)) THEN + CALL XABORT('SYBEUR: OPTION ASKE OR SANC REQUIRED(1).') + ENDIF + A=XX(IKG) + IF((B.NE.0.0).AND.(B.NE.YY(IKG)).AND.(IWIGN.EQ.2)) THEN + CALL XABORT('SYBEUR: OPTION ASKE OR SANC REQUIRED(2).') + ENDIF + B=YY(IKG) +40 CONTINUE + ENDIF + ELSE +* SWITCH TO LSECT(IKG)=-999 IN CASES WHERE THE RADIUS INTERCEPT +* THE CELL BOUNDARY. + DO 55 IKG=1,NGEN + I1=NMC(IKG)+1 + I2=NMC(IKG+1) + DO 50 I=I1+1,I2 + RJ=RAYRE(I) + IF(LHEX.AND.(LSECT(IKG).EQ.0)) THEN + IF(2.0*RJ.GT.XX(IKG)*SQRT(3.0)) LSECT(IKG)=-999 + ELSE IF(LSECT(IKG).EQ.0) THEN + IF(2.0*RJ.GT.MIN(XX(IKG),YY(IKG))) LSECT(IKG)=-999 + ENDIF +50 CONTINUE +55 CONTINUE + ENDIF +* + IF(MULTC.EQ.1) THEN + IF(IMPX.GE.1) WRITE (6,'(/20H ROTH APPROXIMATION.)') + IJAS=NMCEL + ELSE IF(LHEX.AND.(MULTC.EQ.2)) THEN + IF(IMPX.GE.1) WRITE (6,'(/24H ROTH X 6 APPROXIMATION.)') + IJAS=6*NMCEL + ELSE IF(MULTC.EQ.2) THEN + IF(IMPX.GE.1) WRITE (6,'(/24H ROTH X 4 APPROXIMATION.)') + IJAS=4*NMCEL + ELSE IF(LHEX.AND.(MULTC.EQ.3)) THEN + IF(IMPX.GE.1) WRITE (6,'(/27H DP-0 APPROXIMATION AROUND , + 1 13HEACH HEXAGON.)') + IJAS=6*NMCEL + ELSE IF(MULTC.EQ.3) THEN + IF(IMPX.GE.1) WRITE (6,'(/27H DP-0 APPROXIMATION AROUND , + 1 20HEACH CARTESIAN CELL.)') + IJAS=4*NMCEL + ELSE IF(LHEX.AND.(MULTC.EQ.4)) THEN + IF(IMPX.GE.1) WRITE (6,'(/27H DP-1 APPROXIMATION AROUND , + 1 13HEACH HEXAGON.)') + IJAS=18*NMCEL + ELSE IF(MULTC.EQ.4) THEN + IF(IMPX.GE.1) WRITE (6,'(/27H DP-1 APPROXIMATION AROUND , + 1 20HEACH CARTESIAN CELL.)') + IJAS=12*NMCEL + ENDIF + IF(IJAS.GT.MAXJ) THEN + WRITE (HSMG,660) IJAS + CALL XABORT(HSMG) + ENDIF + IF(IMPX.GE.1) THEN + IF((MULTC.LE.2).AND.(IWIGN.EQ.1)) THEN + WRITE (6,'(23H ASKEW CYLINDERIZATION./)') + ELSE IF((MULTC.LE.2).AND.(IWIGN.EQ.2)) THEN + WRITE (6,'(24H WIGNER CYLINDERIZATION./)') + ELSE IF((MULTC.LE.2).AND.(IWIGN.EQ.3)) THEN + WRITE (6,'(25H SANCHEZ CYLINDERIZATION./)') + ENDIF + IF(INORM.EQ.1) WRITE (6,670) + IF(IRECT.EQ.1) WRITE (6,'(/30H SYMMETRIES OF SQUARE CELLS AR, + 1 17HE NOT CONSIDERED.)') + IF(IQW.EQ.1) WRITE (6,'(/32H USE EQUAL WEIGHT QUADRATURES IN, + 1 17H ANGLE AND SPACE.)') + HDOM='(0,PI/4)' + IF(LHEX) HDOM='(0,PI/6)' + WRITE (6,690) IQUAD(1),HDOM,IQUAD(2),IQUAD(3),IQUAD(4) + ENDIF + DO 100 IQQ=1,4 + DO 60 I=1,24 + IF(IQUAD(IQQ).EQ.IIT(I)) GO TO 100 +60 CONTINUE + CALL XABORT('SYBEUR: INVALID QUADRATURE PARAMETER.') +100 CONTINUE +* + NCODE(5)=0 + NCODE(6)=0 + ALLOCATE(ZZ(NGEN)) + ZZ(:NGEN)=1.0 + IF(LHEX) THEN + NCOUR=6 + CALL NUMERH(NCOUR,MULTC,NCODE,ZCODE,IHEX,LX,1,IORI,ISMH,POURCE, + 1 IMPX,NMCEL,IFR,ALB,SUR,NMERGE,INUM,MIX,DVX,NGEN,IGEN,XX,ZZ) + ELSE + NCOUR=4 + CALL NUMER3(NCOUR,MULTC,NCODE,ZCODE,LX,LY,1,IORI,ISMR,POURCE, + 1 IMPX,NMCEL,IFR,ALB,SUR,NMERGE,INUM,MIX,DVX,NGEN,IGEN,XX,YY,ZZ) + ENDIF + DEALLOCATE(ZZ) +*---- +* COMPUTE THE NUMBER OF DISTINCT OUT CURRENTS BETWEEN THE CELLS +*---- + IJAT=0 + DO 130 I=1,NCOUR*NMERGE + IJAT=MAX(IJAT,MIX(I)) +130 CONTINUE + IF(IMPX.GE.1) WRITE (6,760) NMCEL,NMERGE,NGEN,MAXCEL + IF(NMCEL.GT.MAXCEL) CALL XABORT('SYBEUR: INSUFFICIENT MAXCEL.') + IF(IMPX.GE.1) WRITE (6,770) IJAT,IJAS,MAXJ + IF(IJAT.GT.MAXJ) CALL XABORT('SYBEUR: INSUFFICIENT MAXJ.') +*---- +* ESTIMATION OF THE MEMORY REQUIRED TO STORE THE TRACKING INFORMATION +*---- + NA=IQUAD(1) + NX=IQUAD(2) + MR=IQUAD(4) + LMAILI=0 + LMAILR=0 + DO 150 IKG=1,NGEN + J2=NMC(IKG+1)-NMC(IKG) + J1R=NMCR(IKG) + J2R=NMCR(IKG+1)-J1R + IF((J2.EQ.1).AND.(LSECT(IKG).NE.-999)) THEN + GO TO 150 + ELSE IF(LHEX.AND.LSECT(IKG).NE.0) THEN +* TRACKING FOR AN HEXAGONAL SECTORIZED CELL. + IF(LSECT(IKG).EQ.-999) THEN + NSECT=6 + ELSE + NSECT=6*MOD(ABS(LSECT(IKG)),100) + ENDIF + DELR=XX(IKG)/REAL(NX*J2R) + ALLOCATE(VOL2(J2)) + CALL SYB7TS(NA,J2R,NSECT,LSECT(IKG),J2,XX(IKG),RAYRE(J1R+2), + 1 ILIGN,IQW,DELR,.FALSE.,VOL2(1),LR,ZZR,LI,ZZI) + DEALLOCATE(VOL2) + LMAILI=LMAILI+LI + LMAILR=LMAILR+LR + ELSE IF(LSECT(IKG).NE.0) THEN +* TRACKING FOR A CARTESIAN SECTORIZED CELL. + IF(LSECT(IKG).EQ.-999) THEN + NSECT=4 + ELSE IF((LSECT(IKG).EQ.-1).OR.(LSECT(IKG).EQ.-101)) THEN + NSECT=8 + ELSE + NSECT=4*MOD(ABS(LSECT(IKG)),100) + ENDIF + DELR=SQRT(XX(IKG)**2+YY(IKG)**2)/REAL(2*NX*J2R) + ALLOCATE(VOL2(J2)) + CALL SYB4TS(NA,J2R,NSECT,LSECT(IKG),J2,XX(IKG),YY(IKG), + 1 RAYRE(J1R+2),ILIGN,IQW,DELR,.FALSE.,VOL2(1),LR,ZZR,LI,ZZI) + DEALLOCATE(VOL2) + LMAILI=LMAILI+LI + LMAILR=LMAILR+LR + ELSE IF(MULTC.LE.2) THEN + NPIJ=J2R + LMAILR=LMAILR+1+MR*((NPIJ*(5+NPIJ))/2) + ELSE IF((MULTC.GE.3).AND.(J2R.GT.1)) THEN + NPIJ=J2R-1 + LMAILR=LMAILR+1+MR*((NPIJ*(5+NPIJ))/2) + IF(LHEX) THEN + LMAILI=LMAILI+4+3*NA*(2+(J2R+1)*(3+2*J2R)) + LMAILR=LMAILR+J2R+4+3*NA*(13+2*(J2R+1)*NX*J2R) + ELSE IF((XX(IKG).EQ.YY(IKG)).AND.(IRECT.NE.1)) THEN + LMAILI=LMAILI+4+2*NA*(2+(J2R+1)*(3+2*J2R)) + LMAILR=LMAILR+J2R+4+2*NA*(9+2*(J2R+1)*NX*J2R) + ELSE + LMAILI=LMAILI+4+2*NA*(2+(2*J2R+1)*(3+2*J2R)) + LMAILR=LMAILR+J2R+4+2*NA*(9+2*(2*J2R+1)*NX*J2R) + ENDIF + ENDIF +150 CONTINUE + IF((IMPX.GE.1).OR.(LMAILR.GT.MAXZ).OR.(LMAILI.GT.MAXZ)) THEN + WRITE (6,680) LMAILI,LMAILR,MAXZ + ENDIF + IF((LMAILI.GT.MAXZ).OR.(LMAILR.GT.MAXZ)) THEN + WRITE(HSMG,'(14HSYBEUR: MAXZ (,I10,24H) IS LESS THAN THE ESTIM, + 1 22HATED TRACKING LENGTH (,I10,2H).)') MAXZ,MAX(LMAILI,LMAILR) + CALL XABORT(HSMG) + ENDIF + IZMAIL(:LMAILI)=0 + RZMAIL(:LMAILR)=0.0 +*---- +* COMPUTE THE VOLUMES AND THE TRACKING INFORMATION +*---- + IF(IHALT.EQ.1) CALL XABORT('SYBEUR: STOP REQUESTED.') + LMAILI=0 + LMAILR=0 + PRECC=0.0 + ALLOCATE(VOL2(NMC(NGEN+1))) + DO 210 IKG=1,NGEN + MAIL(1,IKG)=0 + MAIL(2,IKG)=0 + J1=NMC(IKG) + J2=NMC(IKG+1)-J1 + J1R=NMCR(IKG) + J2R=NMCR(IKG+1)-J1R + IF(MULTC.LE.2) THEN + ALLOCATE(RAD(J2R+1)) + DO 180 I=1,J2R + RAD(I)=RAYRE(J1R+I) +180 CONTINUE + IF(LHEX.AND.(IWIGN.EQ.1)) THEN +* ASKEW CYLINDERIZATION HEXAGONAL. + RAD(J2R+1)=3.0*XX(IKG)/PI + ELSE IF(LHEX.AND.(IWIGN.GE.2)) THEN +* WIGNER OR SANCHEZ CYLINDERIZATION HEXAGONAL. + RAD(J2R+1)=SQRT(1.5*SQRT(3.0)/PI)*XX(IKG) + ELSE IF(IWIGN.EQ.1) THEN +* ASKEW CYLINDERIZATION CARTESIAN. + RAD(J2R+1)=(XX(IKG)+YY(IKG))/PI + ELSE IF(IWIGN.GE.2) THEN +* WIGNER OR SANCHEZ CYLINDERIZATION CARTESIAN. + RAD(J2R+1)=SQRT(XX(IKG)*YY(IKG)/PI) + ENDIF + CALL SYBT1D(J2R,RAD,.FALSE.,MR,RZMAIL(LMAILR+1)) + DEALLOCATE(RAD) + LI=0 + LR=1+MR*((J2R*(5+J2R))/2) + ELSE + IF((J2.EQ.1).AND.(LSECT(IKG).NE.-999)) THEN + GO TO 190 + ELSE IF((LSECT(IKG).NE.0).AND.LHEX) THEN +* TRACKING FOR AN HEXAGONAL SECTORIZED CELL. + IF(LSECT(IKG).EQ.-999) THEN + NSECT=6 + ELSE + NSECT=6*MOD(ABS(LSECT(IKG)),100) + ENDIF + DELR=XX(IKG)/REAL(NX*J2R) + CALL SYB7TS(NA,J2R,NSECT,LSECT(IKG),J2,XX(IKG),RAYRE(J1R+2), + 1 ILIGN,IQW,DELR,.TRUE.,VOL2(J1+1),LR,RZMAIL(LMAILR+1), + 2 LI,IZMAIL(LMAILI+1)) + ELSE IF(LSECT(IKG).NE.0) THEN +* TRACKING FOR A CARTESIAN SECTORIZED CELL. + IF(LSECT(IKG).EQ.-999) THEN + NSECT=4 + ELSE IF((LSECT(IKG).EQ.-1).OR.(LSECT(IKG).EQ.-101)) THEN + NSECT=8 + ELSE + NSECT=4*MOD(ABS(LSECT(IKG)),100) + ENDIF + DELR=SQRT(XX(IKG)**2+YY(IKG)**2)/REAL(2*NX*J2R) + CALL SYB4TS(NA,J2R,NSECT,LSECT(IKG),J2,XX(IKG),YY(IKG), + 1 RAYRE(J1R+2),ILIGN,IQW,DELR,.TRUE.,VOL2(J1+1),LR, + 2 RZMAIL(LMAILR+1),LI,IZMAIL(LMAILI+1)) + ELSE IF(LHEX) THEN + CALL SYBHTK(NA,NX,J2R,XX(IKG),RAYRE(J1R+1),ILIGN,INORM, + 1 IQW,LR,RZMAIL(LMAILR+1),LI,IZMAIL(LMAILI+1),PREC) + ELSE + CALL SYBRTK(NA,NX,J2R,XX(IKG),YY(IKG),RAYRE(J1R+1),ILIGN, + 1 INORM,IRECT,IQW,LR,RZMAIL(LMAILR+1),LI,IZMAIL(LMAILI+1), + 2 PREC) + ENDIF + PRECC=AMAX1(PRECC,PREC) + ENDIF + MAIL(1,IKG)=LMAILI+1 + MAIL(2,IKG)=LMAILR+1 + LMAILI=LMAILI+LI + LMAILR=LMAILR+LR + IF(LMAILI.GT.MAXZ) CALL XABORT('SYBEUR: INSUFFICIENT MAXZ(1).') + IF(LMAILR.GT.MAXZ) CALL XABORT('SYBEUR: INSUFFICIENT MAXZ(2).') +* +190 IF(LSECT(IKG).EQ.0) THEN +* COMPUTE THE VOLUMES IN A NON-SECTORIZED GENERATING CELL. + RJ=0.0 + DO 200 I=1,J2R-1 + RJ1=RAYRE(J1R+I+1)**2 + VOL2(J1+I)=PI*(RJ1-RJ) + RJ=RJ1 +200 CONTINUE + IF(LHEX) THEN + VOL2(J1+J2)=1.5*SQRT(3.0)*XX(IKG)**2-PI*RJ + ELSE + VOL2(J1+J2)=XX(IKG)*YY(IKG)-PI*RJ + ENDIF + ENDIF +210 CONTINUE + IF(IMPX.GE.1) WRITE (6,710) LMAILI,LMAILR,PRECC +*---- +* WEIGHTING VOLUMES BY POURCE +*---- + I1=0 + DO 230 IKK=1,NMERGE + IKG=IGEN(IKK) + J1=NMC(IKG) + I2=NMC(IKG+1)-J1 + IF(I1+I2.GT.MAXPTS) THEN + WRITE(HSMG,790) I1+I2 + CALL XABORT(HSMG) + ENDIF + DO 220 I=1,I2 + I1=I1+1 + IF(VOL2(J1+I).LE.0.0) THEN + WRITE(HSMG,'(41HSYBEUR: NEGATIVE OR ZERO VOLUME IN REGION, + 1 I5,1H.)') J1+I + CALL XABORT(HSMG) + ENDIF + VOL(I1)=VOL2(J1+I)*POURCE(IKK) +220 CONTINUE +230 CONTINUE + DEALLOCATE(VOL2) + IF(I1.NE.NREG) CALL XABORT('SYBEUR: WRONG NUMBER OF REGIONS.') + IF(IMPX.GE.1) WRITE (6,780) NREG,MAXPTS + IF(NREG.GT.MAXPTS) CALL XABORT('SYBEUR: INSUFFICIENT MAXPTS.') +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(POURCE,IORI) + RETURN +* +660 FORMAT (42HSYBEUR: MAXJ SHOULD BE GREATER OR EQUAL TO,I7,1H.) +670 FORMAT (52H THE TRACKS ARE NOT NORMALIZED AND THE GEOMETRIC ACC, + 1 43HURACY OF THE TRACKING MESH IS NOT COMPUTED./) +680 FORMAT (/49H SYBEUR: MAXIMUM STORAGE REQUIRED BY THE TRACKS =,I8, + 1 2H +,I7,8X,24HAVAILABLE STORAGE MAXZ =,I8/) +690 FORMAT (/23H QUADRATURE PARAMETERS:/24H HETEROGENEOUS CELLS -, + 1 17H ANGLES NA =,I3,4H IN ,A8/24X,17H SEGMENTS NX =, + 2 I3//41H HOMOGENEOUS CELLS - ANGLES NH =,I3// + 3 41H CYLINDRICAL CELLS - SEGMENTS MR =,I3//) +710 FORMAT (/47H SYBEUR: EXACT STORAGE REQUIRED BY THE TRACKS =,I7, + 1 6H INT +,I7,5H REAL,8X,10HACCURACY =,1P,E11.3/) +760 FORMAT (/38H TOTAL NUMBER OF CELLS IN THE DOMAIN =,I7/ + 1 31H TOTAL NUMBER OF MERGED CELLS =,I7/ + 2 35H TOTAL NUMBER OF GENERATING CELLS =,I7,5X, + 3 26HAVAILABLE STORAGE MAXCEL =,I7/) +770 FORMAT (/40H TOTAL NUMBER OF DISTINCT OUT-CURRENTS =,I7/ + 1 57H TOTAL NUMBER OF OUT-CURRENTS SURROUNDING ALL THE CELLS =,I7, + 2 5X,24HAVAILABLE STORAGE MAXJ =,I7/) +780 FORMAT (/20H NUMBER OF VOLUMES =,I7,5X,22HAVAILABLE STORAGE MAXB, + 1 4HLK =,I7/) +790 FORMAT (44HSYBEUR: MAXPTS SHOULD BE GREATER OR EQUAL TO,I7,1H.) + END diff --git a/Dragon/src/SYBHN2.f b/Dragon/src/SYBHN2.f new file mode 100644 index 0000000..3a7feca --- /dev/null +++ b/Dragon/src/SYBHN2.f @@ -0,0 +1,398 @@ +*DECK SYBHN2 + SUBROUTINE SYBHN2(NREG,NSURF,SIDE,Z,IZ,VOL,SIGT,TRONC,PVS,PSS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the DP-1 leakage and transmission probabilities for an +* heterogeneous non-sectorized hexagonal cell. The tracks are computed +* by SYBHTK. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NREG number regions in the cell. +* NSURF number of surfaces. +* SIDE length of one of sides of the hexagon. +* Z real integration mesh. +* IZ integer integration mesh. +* VOL volumes. +* SIGT total cross sections. +* TRONC voided block cutoff criterion. +* +*Parameters: output +* PVS leakage probability: +* PVS(i,j) for volume i to side j with i=1,nr and j=1,18. +* PSS transmission probability: +* PSS(i,j) for side i to side j with i=1,18 and j=1,18. +* +*Reference: +* M. Ouisloumen, Resolution par la methode des probabilites de +* collision de l'equation integrale du transport a deux et trois +* dimensions en geometrie hexagonale, Ph. D. thesis, Ecole +* Polytechnique de Montreal, Montreal, October 1993. +* +*Comments: +* hexagone surface identification. +* side a,b,c +* side 4,5,6 dir a -> isotropic +* xxxxxxxx dir c -> tangent to surface +* x x dir b -> normal to surface +* side 7,8,9 x x side 1,2,3 +* x x +* x x +* x x +* side 10,11,12 x x side 16,17,18 +* x x +* xxxxxxxx +* side 13,14,15 +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NREG,NSURF,IZ(*) + REAL Z(*),SIDE,SIGT(NREG),TRONC,VOL(NREG),PVS(NREG,3*NSURF), + 1 PSS(3*NSURF,3*NSURF) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MKI3=600,MKI4=600,MKI5=600) + PARAMETER (SQ3=1.732050807568877,SQ2=1.414213562373095, + 1 PI=3.141592653589793,ZI30=0.785398164,ZI40=0.666666667) + REAL KI3,KI4,KI5 + REAL PBB(16) + INTEGER IROT(18,18) + REAL, ALLOCATABLE, DIMENSION(:,:) :: COSINU +*---- +* BICKLEY TABLES +*---- + COMMON /BICKL3/BI3(0:MKI3),BI31(0:MKI3),BI32(0:MKI3),PAS3,XLIM3,L3 + COMMON /BICKL4/BI4(0:MKI4),BI41(0:MKI4),BI42(0:MKI4),PAS4,XLIM4,L4 + COMMON /BICKL5/BI5(0:MKI5),BI51(0:MKI5),BI52(0:MKI5),PAS5,XLIM5,L5 +* + SAVE IROT + DATA IROT / + + 0, 0, 0, 1, 2,-3, 7, 8,-9,13,14, 0, 7, 8, 9, 1, 2, 3, + + 0, 0, 0, 2, 4, 5, 8,10,11,14,15, 0, 8,10,-11, 2, 4,-5, + + 0, 0, 0, 3,-5, 6, 9,-11,12,0, 0,16,-9,11,12,-3, 5,6, + + 1, 2, 3, 0, 0, 0, 1, 2,-3, 7, 8,-9,13,14, 0, 7, 8, 9, + + 2, 4,-5, 0, 0, 0, 2, 4, 5, 8,10,11,14,15, 0, 8,10,-11, + + -3, 5, 6, 0, 0, 0, 3,-5, 6, 9,-11,12,0, 0,16,-9,11,12, + + 7, 8, 9, 1, 2, 3, 0, 0, 0, 1, 2,-3, 7, 8,-9,13,14, 0, + + 8,10,-11, 2, 4,-5, 0, 0, 0, 2, 4, 5, 8,10,11,14,15, 0, + + -9,11,12,-3, 5, 6, 0, 0, 0, 3,-5, 6, 9,-11,12,0, 0,16, + + 13,14, 0, 7, 8, 9, 1, 2, 3, 0, 0, 0, 1, 2,-3, 7, 8,-9, + + 14,15, 0, 8,10,-11, 2, 4,-5, 0, 0, 0, 2, 4, 5, 8,10,11, + + 0, 0,16,-9,11,12,-3, 5, 6, 0, 0, 0, 3,-5, 6, 9,-11,12, + + 7, 8,-9, 13,14, 0, 7, 8, 9, 1, 2, 3, 0, 0, 0, 1, 2,-3, + + 8,10,11,14,15, 0, 8,10,-11, 2, 4,-5, 0, 0, 0, 2, 4, 5, + + 9,-11,12, 0, 0,16,-9,11,12,-3, 5, 6, 0, 0, 0, 3,-5, 6, + + 1, 2,-3, 7, 8,-9, 13,14, 0, 7, 8, 9, 1, 2, 3, 0, 0, 0, + + 2, 4, 5, 8,10,11,14,15, 0, 8,10,-11, 2, 4,-5, 0, 0, 0, + + 3,-5, 6, 9,-11,12, 0, 0,16,-9,11,12,-3, 5, 6, 0, 0, 0/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(COSINU(2,NSURF)) +*---- +* INTEGRATION USING THE TRACKING +*---- + ZERO=TRONC/(SQ3*SIDE) + PBB(:16)=0.0 + PVS(:NREG,:18)=0.0 + IZ0=2 + IZR=4 + DO 205 IA=1,IZ(2) + DO 20 I=1,NSURF + COSINU(1,I)=Z(IZR+1) + COSINU(2,I)=Z(IZR+2) + IZR=IZR+2 + 20 CONTINUE + MNT=IZ(IZ0+1) + IZ0=IZ0+2 + IZR=IZR+1 + DO 200 IMNT=1,MNT + NH=IZ(IZ0+1) + NX=IZ(IZ0+2) + ISURF=IZ(IZ0+3)+1 + JSURF=IZ(IZ0+NH+4)+1 + DO 190 INX=1,NX + Z1=Z(IZR+1)/SIDE + IZR=IZR+1 + DW1=Z1*COSINU(1,ISURF) + DW2=Z1*COSINU(1,JSURF) + IF((ISURF.EQ.5).AND.(JSURF.EQ.6)) THEN + W610=SQ3*COSINU(2,ISURF)+COSINU(1,ISURF) + W611=2.0*COSINU(2,JSURF)*COSINU(2,ISURF) + Z2=Z1*W611 + Z3=Z1*W610 + KI3=ZI30 + KI4=ZI40 + POP=0.0 + DO 40 I=1,NH + III=IZ(IZ0+3+I)-NSURF+1 + SIGTI=SIGT(III) + POP0=POP + POP=POP+SIGTI*Z(IZR+I) + IF(POP.LT.XLIM3) GO TO 30 + IF(SIGTI.LE.ZERO) GO TO 50 + PVS(III,1)=PVS(III,1)+KI3*Z1 + PVS(III,2)=PVS(III,2)+KI4*DW1 + GO TO 50 + 30 K=NINT(POP*PAS3) + WI3=BI3(K)+POP*(BI31(K)+POP*BI32(K)) + WI4=BI4(K)+POP*(BI41(K)+POP*BI42(K)) + IF(SIGTI.LE.ZERO) THEN + PVS(III,1)=PVS(III,1)+TABKI(2,POP0)*Z(IZR+I)*Z1 + PVS(III,2)=PVS(III,2)+KI3*Z(IZR+I)*DW1 + ELSE + PVS(III,1)=PVS(III,1)+(KI3-WI3)*Z1 + PVS(III,2)=PVS(III,2)+(KI4-WI4)*DW1 + ENDIF + KI3=WI3 + KI4=WI4 + 40 CONTINUE + 50 KI3=ZI30 + KI4=ZI40 + POP=0.0 + K=0 + DO 80 I=1,NH + III=IZ(IZ0+3+I)-NSURF+1 + SIGTI=SIGT(III) + POP0=POP + POP=POP+SIGTI*Z(IZR+NH+1-I) + IF(POP.LT.XLIM3) GO TO 70 + IF(SIGTI.LE.ZERO) GO TO 185 + PVS(III,1)=PVS(III,1)+KI3*Z1 + PVS(III,2)=PVS(III,2)+KI4*DW2 + GO TO 185 + 70 K=NINT(POP*PAS3) + WI3=BI3(K)+POP*(BI31(K)+POP*BI32(K)) + WI4=BI4(K)+POP*(BI41(K)+POP*BI42(K)) + IF(SIGTI.LE.ZERO) THEN + PVS(III,1)=PVS(III,1)+TABKI(2,POP0)*Z(IZR+NH+1-I)*Z1 + PVS(III,2)=PVS(III,2)+KI3*Z(IZR+NH+1-I)*DW2 + ELSE + PVS(III,1)=PVS(III,1)+(KI3-WI3)*Z1 + PVS(III,2)=PVS(III,2)+(KI4-WI4)*DW2 + ENDIF + KI3=WI3 + KI4=WI4 + 80 CONTINUE + KI5=BI5(K)+POP*(BI51(K)+POP*BI52(K)) + PBB(1)=PBB(1)+KI3*Z1 + PBB(3)=PBB(3)+KI4*Z3 + PBB(5)=PBB(5)+KI5*Z1 + PBB(6)=PBB(6)+KI5*Z2 + ELSE IF((ISURF.EQ.5).AND.(JSURF.EQ.1)) THEN + W610=SQ3*COSINU(1,JSURF)+COSINU(2,JSURF) + W511=2.0*COSINU(2,ISURF)*COSINU(2,JSURF) + Z2=Z1*W511 + Z3=Z1*W610 + KI3=ZI30 + KI4=ZI40 + POP=0.0 + K=0 + DO 100 I=1,NH + III=IZ(IZ0+3+I)-NSURF+1 + SIGTI=SIGT(III) + POP0=POP + POP=POP+SIGTI*Z(IZR+I) + IF(POP.LT.XLIM3) GO TO 90 + IF(SIGTI.LE.ZERO) GO TO 110 + PVS(III,1)=PVS(III,1)+KI3*Z1 + PVS(III,2)=PVS(III,2)+KI4*DW1 + GO TO 110 + 90 K=NINT(POP*PAS3) + WI3=BI3(K)+POP*(BI31(K)+POP*BI32(K)) + WI4=BI4(K)+POP*(BI41(K)+POP*BI42(K)) + IF(SIGTI.LE.ZERO) THEN + PVS(III,1)=PVS(III,1)+TABKI(2,POP0)*Z(IZR+I)*Z1 + PVS(III,2)=PVS(III,2)+KI3*Z(IZR+I)*DW1 + ELSE + PVS(III,1)=PVS(III,1)+(KI3-WI3)*Z1 + PVS(III,2)=PVS(III,2)+(KI4-WI4)*DW1 + ENDIF + KI3=WI3 + KI4=WI4 + 100 CONTINUE + 110 KI3=ZI30 + KI4=ZI40 + POP=0.0 + DO 130 I=1,NH + III=IZ(IZ0+3+I)-NSURF+1 + SIGTI=SIGT(III) + POP0=POP + POP=POP+SIGTI*Z(IZR+NH+1-I) + IF(POP.LT.XLIM3) GO TO 120 + IF(SIGTI.LE.ZERO) GO TO 185 + PVS(III,1)=PVS(III,1)+KI3*Z1 + PVS(III,2)=PVS(III,2)+KI4*DW2 + GO TO 185 + 120 K=NINT(POP*PAS3) + WI3=BI3(K)+POP*(BI31(K)+POP*BI32(K)) + WI4=BI4(K)+POP*(BI41(K)+POP*BI42(K)) + IF(SIGTI.LE.ZERO) THEN + PVS(III,1)=PVS(III,1)+TABKI(2,POP0)*Z(IZR+NH+1-I)*Z1 + PVS(III,2)=PVS(III,2)+KI3*Z(IZR+NH+1-I)*DW2 + ELSE + PVS(III,1)=PVS(III,1)+(KI3-WI3)*Z1 + PVS(III,2)=PVS(III,2)+(KI4-WI4)*DW2 + ENDIF + KI3=WI3 + KI4=WI4 + 130 CONTINUE + KI5=BI5(K)+POP*(BI51(K)+POP*BI52(K)) + PBB(7)=PBB(7)+KI3*Z1 + PBB(9)=PBB(9)+KI4*Z3 + PBB(11)=PBB(11)+KI5*Z1 + PBB(12)=PBB(12)+KI5*Z2 + ELSE IF((ISURF.EQ.5).AND.(JSURF.EQ.2)) THEN + Z2=Z1*COSINU(1,ISURF) + Z3=Z1*COSINU(1,ISURF)*COSINU(1,JSURF) + KI3=ZI30 + KI4=ZI40 + POP=0.0 + K=0 + DO 150 I=1,NH + III=IZ(IZ0+3+I)-NSURF+1 + SIGTI=SIGT(III) + POP0=POP + POP=POP+SIGTI*Z(IZR+I) + IF(POP.LT.XLIM3) GO TO 140 + IF(SIGTI.LE.ZERO) GO TO 160 + PVS(III,1)=PVS(III,1)+KI3*Z1 + PVS(III,2)=PVS(III,2)+KI4*Z2 + GO TO 160 + 140 K=NINT(POP*PAS3) + WI3=BI3(K)+POP*(BI31(K)+POP*BI32(K)) + WI4=BI4(K)+POP*(BI41(K)+POP*BI42(K)) + IF(SIGTI.LE.ZERO) THEN + PVS(III,1)=PVS(III,1)+TABKI(2,POP0)*Z(IZR+I)*Z1 + PVS(III,2)=PVS(III,2)+KI3*Z(IZR+I)*Z2 + ELSE + PVS(III,1)=PVS(III,1)+(KI3-WI3)*Z1 + PVS(III,2)=PVS(III,2)+(KI4-WI4)*Z2 + ENDIF + KI3=WI3 + KI4=WI4 + 150 CONTINUE + 160 KI3=ZI30 + KI4=ZI40 + POP=0.0 + K=0 + DO 180 I=1,NH + III=IZ(IZ0+3+I)-NSURF+1 + SIGTI=SIGT(III) + POP0=POP + POP=POP+SIGTI*Z(IZR+NH+1-I) + IF(POP.LT.XLIM3) GO TO 170 + IF(SIGTI.LE.ZERO) GO TO 185 + PVS(III,1)=PVS(III,1)+KI3*Z1 + PVS(III,2)=PVS(III,2)+KI4*Z2 + GO TO 185 + 170 K=NINT(POP*PAS3) + WI3=BI3(K)+POP*(BI31(K)+POP*BI32(K)) + WI4=BI4(K)+POP*(BI41(K)+POP*BI42(K)) + IF(SIGTI.LE.ZERO) THEN + PVS(III,1)=PVS(III,1)+TABKI(2,POP0)*Z(IZR+NH+1-I)*Z1 + PVS(III,2)=PVS(III,2)+KI3*Z(IZR+NH+1-I)*Z2 + ELSE + PVS(III,1)=PVS(III,1)+(KI3-WI3)*Z1 + PVS(III,2)=PVS(III,2)+(KI4-WI4)*Z2 + ENDIF + KI3=WI3 + KI4=WI4 + 180 CONTINUE + KI5=BI5(K)+POP*(BI51(K)+POP*BI52(K)) + PBB(13)=PBB(13)+2.0*KI3*Z1 + PBB(14)=PBB(14)+2.0*KI4*Z2 + PBB(15)=PBB(15)+2.0*KI5*Z3 + PBB(16)=PBB(16)+2.0*KI5*(Z1-Z3) + ENDIF + 185 IZR=IZR+NH + 190 CONTINUE + IZ0=IZ0+NH+4 + 200 CONTINUE + 205 CONTINUE +*---- +* PSS ORTHONORMALIZATION +*---- + E1=Z(1) + E2=Z(2) + E3=Z(3) + E4=Z(4) + P13=PBB(13) + PBB(1)=PBB(1)*E1*E1 + PBB(7)=PBB(7)*E1*E1 + PBB(13)=P13*E1*E1 + PBB(3)=-0.25*PBB(3)*E1*E4*SQ3 + PBB(9)=-0.25*PBB(9)*E1*E4 + PBB(14)=E1*(PBB(14)*E2-E3*P13) + SQRT6=.25*SQ3*E4*E2 + PBB(5)=SQRT6*PBB(5)+E3*PBB(3)/E1 + PBB(11)=SQRT6*PBB(11)+E3*PBB(9)/E1 + PBB(6)=-0.5*E4*E4*PBB(6) + PBB(12)=-0.5*E4*E4*PBB(12) + PBB(16)=E4*E4*PBB(16) + PBB(15)=E2*E2*PBB(15)-E3*(2.*PBB(14)/E1+E3*P13) +*---- +* PIS NORMALIZATION +*---- + DO 210 I=1,NREG + COEF=0.25*SIDE/VOL(I) + IF(SIGT(I).LE.ZERO) THEN + PVS(I,2)=COEF*E1*(E2*PVS(I,2)-E3*PVS(I,1)) + PVS(I,1)=COEF*PVS(I,1)*E1*E1 + ELSE + SIGTI=COEF/SIGT(I) + PVS(I,2)=SIGTI*E1*(E2*PVS(I,2)-E3*PVS(I,1)) + PVS(I,1)=SIGTI*PVS(I,1)*E1*E1 + ENDIF + 210 CONTINUE +*---- +* OTHER PROBABILITIES COMPUTATION +*---- + PBB(2)=(-SQ3*PBB(3)-4.*PBB(1))/SQ2 + PBB(4)=-4.5*PBB(6)+SQ3*(-SQ2*PBB(5)+8.*PBB(3))+8.*PBB(1) + PBB(8)=(-3.*SQ3*PBB(9)-4.*PBB(7))/SQ2 + PBB(10)=-4.5*PBB(12)+SQ3*(SQ2*PBB(11)+8.*PBB(9))+8.*PBB(7) +*---- +* TRANSMISSION MATRIX +*---- + DO 225 I=1,18 + DO 220 J=1,18 + IB=IROT(J,I) + IF(IB.LT.0) THEN + PSS(I,J)=-PBB(-IB) + ELSEIF(IB.GT.0) THEN + PSS(I,J)=PBB(IB) + ELSE + PSS(I,J)=0. + ENDIF + 220 CONTINUE + 225 CONTINUE +*---- +* LEAKAGE MARTIX +*---- + DO 235 J=1,NREG + K=3 + DO 230 I=1,5 + K=K+3 + PVS(J,K-1)=PVS(J,2) + PVS(J,K-2)=PVS(J,1) + 230 CONTINUE + 235 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(COSINU) + RETURN + END diff --git a/Dragon/src/SYBHTK.f b/Dragon/src/SYBHTK.f new file mode 100644 index 0000000..109966f --- /dev/null +++ b/Dragon/src/SYBHTK.f @@ -0,0 +1,512 @@ +*DECK SYBHTK + SUBROUTINE SYBHTK (NA,NX,NREG,SIDE,RAYRE,ILIGN,INORM,IQW,LR,Z,LI, + 1 IZ,PREC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the tracking information related to an hexagonal heterogeneous +* cell. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NA number of angles in (0,$\\pi$/6). +* NX number of tracks in each sub domain for a given angle. +* NREG number of regions in the cell. +* SIDE side of an hexagon. +* RAYRE radius of each cylinder (RAYRE(1)=0.0). +* ILIGN tracking print flag (=1 to print the tracking). +* INORM track normalization flag (=1 to avoid track normalization). +* IQW equal weight quadrature flag (=1 to use equal weight +* quadratures in angle and space). +* +*Parameters: output +* LR exact size of array Z with +* L.LE.4+3*NA*(13+2*(NREG+1)*NX*NREG). +* Z real tracking information. +* Z(1) to Z(4) contain the numerical orthonormalization +* factors. +* LI size of array IZ with +* L.LE.NREG+4+3*NA*(2+(NREG+1)*(3+2*NREG)). +* IZ integer tracking information. +* IZ(1)=5, IZ(2)=NREG+1 and IZ(3)=3 for an hexagonal cell. +* PREC accuracy obtained if the non-normalized tracks are used +* to integrate the volumes. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NA,NX,NREG,ILIGN,INORM,IQW,LR,LI,IZ(*) + REAL SIDE,RAYRE(NREG),Z(*),PREC +*---- +* LOCAL VARIABLES +*---- + PARAMETER (PIO2=1.570796327,PI=3.14159265358979,SQ3=1.73205080757) + REAL ZX(64),WX(64),ZA(64),WA(64),ZXJ(64),WXJ(64) + REAL, ALLOCATABLE, DIMENSION(:) :: VAP +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(VAP(NREG)) +* + NA3=3*NA + IF(NX.GT.10) CALL XABORT('SYBHTK: NX IS GREATER THAN 10.') + IF(NA.GT.64) CALL XABORT('SYBHTK: NA IS GREATER THAN 64.') + IF(2.0*RAYRE(NREG).GT.SQ3*SIDE) CALL XABORT('SYBHTK: A RADIUS IS' + 1 //' GREATER THAN HALF A SIDE.') +*---- +* COMPUTE VOLUMES +*---- + VOL=1.5*SQ3*SIDE**2 + DO 10 IR=NREG,1,-1 + R2=PI*RAYRE(IR)**2 + Z(IR)=VOL-R2 + VOL=R2 + 10 CONTINUE +* + IF(IQW.EQ.0) THEN +* GAUSS-LEGENDRE AND GAUSS-JACOBI INTEGRATION POINTS. + CALL ALGPT(NX,-1.,1.,ZX(1),WX(1)) + CALL ALGJP(NX,ZXJ,WXJ) + CALL ALGPT(NA,-1.,-1./3.,ZA(1),WA(1)) + CALL ALGPT(NA,-1./3.,1./3.,ZA(NA+1),WA(NA+1)) + CALL ALGPT(NA,1./3.,1.,ZA(2*NA+1),WA(2*NA+1)) + ELSE +* EQUAL WEIGHT INTEGRATION POINTS. + DO 15 I=1,NX + ZX(I)=(2.0*REAL(I)-1.0)/REAL(NX)-1.0 + WX(I)=2.0/REAL(NX) + ZXJ(I)=0.5*(2.0*REAL(I)-1.0)/REAL(NX) + WXJ(I)=ZXJ(I)/REAL(NX) + 15 CONTINUE + DO 20 I=1,NA3 + ZA(I)=(2.0*REAL(I)-1.0)/REAL(NA3)-1.0 + WA(I)=2.0/REAL(NA3) + 20 CONTINUE + ENDIF + IZ(1)=5 + IZ(2)=NREG+1 + IZ(3)=3 + IZ(4)=NA3 + PREC=0.0 + LI=4 + LR=NREG+4 +*---- +* INTEGRATION IN ANGLE FROM 0 TO PI/2 +*---- + ZN1=0.0 + ZN2=0.0 + ZN3=0.0 + DO 350 IA=1,NA3 + PHI=0.5*PIO2*(ZA(IA)+1.0) + SI=SIN(PHI) + CO=COS(PHI) + TA=SI/CO + FACT1=(SQ3/TA)/(SQ3/TA-1.0) + FACT2=(SQ3/TA)/(SQ3/TA+1.0) + ZN1=ZN1+SI*WA(IA) + ZN2=ZN2+SI*SI*WA(IA) + ZN3=ZN3+SI*SI*SI*WA(IA) + Z(LR+1:LR+6)=0.0 + Z(LR+9)=SI + Z(LR+10)=CO + IF(PHI.LT.PI/6.) THEN + Z(LR+11)=COS(PHI+PI/6.) + Z(LR+12)=SIN(PHI+PI/6.) + ELSE IF(PHI.LT.PI/3.) THEN + Z(LR+1)=COS(PHI-PI/6.) + Z(LR+2)=SIN(PHI-PI/6.) + ELSE + Z(LR+3)=SI + Z(LR+4)=CO + ENDIF + Z(LR+13)=WA(IA) + LR=LR+13 +*---- +* FIRST ANGULAR DOMAIN (0 TO PI/6) +*---- + L4=LI+1 + IZ(LI+1)=0 + IZ(LI+2)=0 + LI=LI+2 + IF(PHI.GT.PIO2/3.0) GO TO 120 + X1=0.0 + XLIM=MIN(SIDE,0.5*SIDE*(SQ3/TA-1.0)) + DLIM=0.5*SIDE*SQ3*CO+(0.5*SIDE-XLIM)*SI + DO 100 K0=NREG,1,-1 + KMAX=NREG-K0+1 + X2=MIN(XLIM,XLIM-(RAYRE(K0)-DLIM)/SI) + L3=LR+1 + L5=LI+1 + LI=LI+3 + VAP(:NREG)=0.0 + DO 50 IX=1,NX + IF(K0.EQ.NREG) THEN + S=0.5*(X2-X1)*SI*WX(IX) + X=X1+0.5*(X2-X1)*(1.0+ZX(IX)) + ELSE +* FLURIG CHANGE OF VARIABLE. + S=2.0*(X2-X1)*SI*WXJ(IX) + X=X1+(X2-X1)*ZXJ(IX)**2 + ENDIF + Z(LR+1)=S*WA(IA) + LR=LR+1 + C=0.5*SIDE*SQ3*SI-(0.5*SIDE-X)*CO + D=0.5*SIDE*SQ3*CO+(0.5*SIDE-X)*SI + D=D*D + SUM=0.0 + CORDE=0.0 + DO 30 K=NREG,K0+1,-1 + RR=RAYRE(K)**2-D + CORDE=SQRT(RR) + DEL=C-CORDE + SUM=SUM+DEL + Z(LR+NREG-K+1)=DEL + VAP(K)=VAP(K)+DEL*S + C=CORDE + 30 CONTINUE + IF(KMAX.NE.1) THEN + DEL=2.0*CORDE + SUM=SUM+DEL + Z(LR+KMAX)=DEL + VAP(K)=VAP(K)+DEL*S + DO 40 I=1,KMAX-2 + DEL=Z(LR+KMAX-I) + SUM=SUM+DEL + Z(LR+KMAX+I)=DEL + VAP(K+I)=VAP(K+I)+DEL*S + 40 CONTINUE + ENDIF + LR=LR+2*KMAX-1 + DEL=X*FACT1/CO-SUM + Z(LR)=DEL + VAP(NREG)=VAP(NREG)+DEL*S + 50 CONTINUE + DO 60 K=KMAX-1,1-KMAX,-1 + IZ(LI+K+KMAX)=5+ABS(K)+1+NREG-KMAX + 60 CONTINUE + LI=LI+2*KMAX + IZ(L5)=2*KMAX-1 + IZ(L5+1)=NX + IZ(L5+2)=4 ! ISURF + IZ(LI)=5 ! JSURF +*---- +* VOLUME NORMALIZATION +*---- + IF((INORM.EQ.0).AND.(K0.LT.NREG)) THEN + DLIM1=0.5*SIDE*SQ3*CO+(0.5*SIDE-X2)*SI + DLIM2=0.5*SIDE*SQ3*CO+(0.5*SIDE-X1)*SI + VW1=0.0 + SUMVAP=0.0 + DO 70 I=K0,NREG-1 + SUMVAP=SUMVAP+VAP(I) + RW=RAYRE(I+1) + VEX1=RW*RW*ACOS(DLIM1/RW)-DLIM1*SQRT(RW*RW-DLIM1*DLIM1) + IF(RW.GT.DLIM2) + 1 VEX1=VEX1-(RW*RW*ACOS(DLIM2/RW)-DLIM2*SQRT(RW*RW-DLIM2*DLIM2)) + SUM=(VEX1-VW1)/VAP(I) + PREC=MAX(PREC,ABS(1.0-SUM)*(VEX1-VW1)/(1.5*SQ3*SIDE**2)) + VW1=VEX1 + VAP(I)=SUM + 70 CONTINUE + VEX1=0.5*(SIDE*SQ3*SI-(SIDE-X1-X2)*CO)*(X2-X1)*SI + VEX2=0.5*FACT1*TA*(X2*X2-X1*X1)-VEX1 + SUM=(VEX1-0.5*VW1)/(VEX1-0.5*SUMVAP) + PREC=MAX(PREC,ABS(1.0-SUM)*(VEX1-0.5*VW1)/(1.5*SQ3*SIDE**2)) + VEX1=SUM + SUM=(VEX2-0.5*VW1)/(VEX2-0.5*SUMVAP) + PREC=MAX(PREC,ABS(1.0-SUM)*(VEX2-0.5*VW1)/(1.5*SQ3*SIDE**2)) + VEX2=SUM + DO 90 IX=1,NX + KMAX=(IZ(L5)+1)/2 + Z(L3+KMAX)=Z(L3+KMAX)*VAP(K0) + DO 80 I=1,KMAX-2 + Z(L3+KMAX-I)=Z(L3+KMAX-I)*VAP(K0+I) + Z(L3+KMAX+I)=Z(L3+KMAX+I)*VAP(K0+I) + 80 CONTINUE + Z(L3+1)=Z(L3+1)*VEX1 + Z(L3+2*KMAX-1)=Z(L3+2*KMAX-1)*VEX2 + L3=L3+2*KMAX + 90 CONTINUE + ENDIF + IZ(L4)=IZ(L4)+1 + IF(X2.GE.XLIM) GO TO 120 + X1=X2 + 100 CONTINUE +*---- +* SECOND ANGULAR DOMAIN (PI/6 TO PI/3) +*---- + 120 IF((PHI.LE.PI/6.0).OR.(PHI.GT.2.0*PIO2/3.0)) GO TO 240 + X1=0.5*SIDE*(SQ3/TA-1.0) + XLIM=SIDE + DLIM=0.5*SIDE*SQ3*CO+(0.5*SIDE-XLIM)*SI + DO 230 K0=NREG,1,-1 + KMAX=NREG-K0+1 + X2=MIN(XLIM,XLIM-(RAYRE(K0)-DLIM)/SI) + IF(X2.LE.X1) GO TO 230 + L3=LR+1 + L5=LI+1 + LI=LI+3 + VAP(:NREG)=0.0 + DO 150 IX=1,NX + IF(K0.EQ.NREG) THEN + S=0.5*(X2-X1)*SI*WX(IX) + X=X1+0.5*(X2-X1)*(1.0+ZX(IX)) + ELSE +* FLURIG CHANGE OF VARIABLE. + S=2.0*(X2-X1)*SI*WXJ(IX) + X=X1+(X2-X1)*ZXJ(IX)**2 + ENDIF + Z(LR+1)=S*WA(IA) + LR=LR+1 + C=0.5*SIDE*SQ3*SI-(0.5*SIDE-X)*CO + D=0.5*SIDE*SQ3*CO+(0.5*SIDE-X)*SI + D=D*D + SUM=0.0 + CORDE=0.0 + DO 130 K=NREG,K0+1,-1 + RR=RAYRE(K)**2-D + CORDE=SQRT(RR) + DEL=C-CORDE + SUM=SUM+DEL + Z(LR+NREG-K+1)=DEL + VAP(K)=VAP(K)+DEL*S + C=CORDE + 130 CONTINUE + IF(KMAX.NE.1) THEN + DEL=2.0*CORDE + SUM=SUM+DEL + Z(LR+KMAX)=DEL + VAP(K)=VAP(K)+DEL*S + DO 140 I=1,KMAX-2 + DEL=Z(LR+KMAX-I) + SUM=SUM+DEL + Z(LR+KMAX+I)=DEL + VAP(K+I)=VAP(K+I)+DEL*S + 140 CONTINUE + ENDIF + LR=LR+2*KMAX-1 + DEL=(X+SIDE)*FACT2/CO-SUM + Z(LR)=DEL + VAP(NREG)=VAP(NREG)+DEL*S + 150 CONTINUE + DO 160 K=KMAX-1,1-KMAX,-1 + IZ(LI+K+KMAX)=5+ABS(K)+1+NREG-KMAX + 160 CONTINUE + LI=LI+2*KMAX + IZ(L5)=2*KMAX-1 + IZ(L5+1)=NX + IZ(L5+2)=4 ! ISURF + IZ(LI)=0 ! JSURF +*---- +* VOLUME NORMALIZATION +*---- + IF((INORM.EQ.0).AND.(K0.LT.NREG)) THEN + DLIM1=0.5*SIDE*SQ3*CO+(0.5*SIDE-X2)*SI + DLIM2=0.5*SIDE*SQ3*CO+(0.5*SIDE-X1)*SI + VW1=0.0 + SUMVAP=0.0 + DO 200 I=K0,NREG-1 + SUMVAP=SUMVAP+VAP(I) + RW=RAYRE(I+1) + VEX1=RW*RW*ACOS(DLIM1/RW)-DLIM1*SQRT(RW*RW-DLIM1*DLIM1) + IF(RW.GT.DLIM2) + 1 VEX1=VEX1-(RW*RW*ACOS(DLIM2/RW)-DLIM2*SQRT(RW*RW-DLIM2*DLIM2)) + SUM=(VEX1-VW1)/VAP(I) + PREC=MAX(PREC,ABS(1.0-SUM)*(VEX1-VW1)/(1.5*SQ3*SIDE**2)) + VW1=VEX1 + VAP(I)=SUM + 200 CONTINUE + VEX1=0.5*(SIDE*SQ3*SI-(SIDE-X1-X2)*CO)*(X2-X1)*SI + VEX2=0.5*FACT2*TA*(X2-X1)*(X1+X2+2.0*SIDE)-VEX1 + SUM=(VEX1-0.5*VW1)/(VEX1-0.5*SUMVAP) + PREC=MAX(PREC,ABS(1.0-SUM)*(VEX1-0.5*VW1)/(1.5*SQ3*SIDE**2)) + VEX1=SUM + SUM=(VEX2-0.5*VW1)/(VEX2-0.5*SUMVAP) + PREC=MAX(PREC,ABS(1.0-SUM)*(VEX2-0.5*VW1)/(1.5*SQ3*SIDE**2)) + VEX2=SUM + DO 220 IX=1,NX + KMAX=(IZ(L5)+1)/2 + Z(L3+KMAX)=Z(L3+KMAX)*VAP(K0) + DO 210 I=1,KMAX-2 + Z(L3+KMAX-I)=Z(L3+KMAX-I)*VAP(K0+I) + Z(L3+KMAX+I)=Z(L3+KMAX+I)*VAP(K0+I) + 210 CONTINUE + Z(L3+1)=Z(L3+1)*VEX1 + Z(L3+2*KMAX-1)=Z(L3+2*KMAX-1)*VEX2 + L3=L3+2*KMAX + 220 CONTINUE + ENDIF + IZ(L4)=IZ(L4)+1 + X1=X2 + 230 CONTINUE +*---- +* THIRD ANGULAR DOMAIN (PI/3 TO PI/2) +*---- + 240 IF(PHI.LE.2.0*PIO2/3.0) GO TO 350 + X1=SQ3*SIDE/TA + XLIM=0.5*(SIDE+X1) + DO 340 K0=NREG,1,-1 + KMAX=NREG-K0+1 + X2=XLIM-RAYRE(K0)/SI + IF(X2.LE.X1) GO TO 340 + L3=LR+1 + L5=LI+1 + LI=LI+3 + VAP(:NREG)=0.0 + DO 270 IX=1,NX + IF(K0.EQ.NREG) THEN + S=0.5*(X2-X1)*SI*WX(IX) + X=X1+0.5*(X2-X1)*(1.0+ZX(IX)) + ELSE +* FLURIG CHANGE OF VARIABLE. + S=2.0*(X2-X1)*SI*WXJ(IX) + X=X1+(X2-X1)*ZXJ(IX)**2 + ENDIF + Z(LR+1)=S*WA(IA) + LR=LR+1 + C=0.5*SIDE*SQ3*SI-(0.5*SIDE-X)*CO + D=0.5*SIDE*SQ3*CO+(0.5*SIDE-X)*SI + D=D*D + SUM=0.0 + CORDE=0.0 + DO 250 K=NREG,K0+1,-1 + RR=RAYRE(K)**2-D + CORDE=SQRT(RR) + DEL=C-CORDE + SUM=SUM+DEL + Z(LR+NREG-K+1)=DEL + VAP(K)=VAP(K)+DEL*S + C=CORDE + 250 CONTINUE + IF(KMAX.NE.1) THEN + DEL=2.0*CORDE + SUM=SUM+DEL + Z(LR+KMAX)=DEL + VAP(K)=VAP(K)+DEL*S + DO 260 I=1,KMAX-2 + DEL=Z(LR+KMAX-I) + SUM=SUM+DEL + Z(LR+KMAX+I)=DEL + VAP(K+I)=VAP(K+I)+DEL*S + 260 CONTINUE + ENDIF + IF(KMAX.NE.KMAX) CALL XABORT('BUG') + LR=LR+2*KMAX-1 + DEL=SQ3*SIDE/SI-SUM + Z(LR)=DEL + VAP(NREG)=VAP(NREG)+DEL*S + 270 CONTINUE + DO 280 K=KMAX-1,1-KMAX,-1 + IZ(LI+K+KMAX)=5+ABS(K)+1+NREG-KMAX + 280 CONTINUE + LI=LI+2*KMAX + IZ(L5)=2*KMAX-1 + IZ(L5+1)=NX + IZ(L5+2)=4 ! ISURF + IZ(LI)=1 ! JSURF +*---- +* VOLUME NORMALIZATION +*---- + IF((INORM.EQ.0).AND.(K0.LT.NREG)) THEN + DLIM1=0.5*SIDE*SQ3*CO+(0.5*SIDE-X2)*SI + DLIM2=0.5*SIDE*SQ3*CO+(0.5*SIDE-X1)*SI + VW1=0.0 + SUMVAP=0.0 + DO 310 I=K0,NREG-1 + SUMVAP=SUMVAP+VAP(I) + RW=RAYRE(I+1) + VEX1=RW*RW*ACOS(DLIM1/RW)-DLIM1*SQRT(RW*RW-DLIM1*DLIM1) + IF(RW.GT.DLIM2) + 1 VEX1=VEX1-(RW*RW*ACOS(DLIM2/RW)-DLIM2*SQRT(RW*RW-DLIM2*DLIM2)) + SUM=(VEX1-VW1)/VAP(I) + PREC=MAX(PREC,ABS(1.0-SUM)*(VEX1-VW1)/(1.5*SQ3*SIDE**2)) + VW1=VEX1 + VAP(I)=SUM + 310 CONTINUE + VEX1=0.5*(SIDE*SQ3*SI-(SIDE-X1-X2)*CO)*(X2-X1)*SI + VEX2=(X2-X1)*SQ3*SIDE-VEX1 + SUM=(VEX1-0.5*VW1)/(VEX1-0.5*SUMVAP) + PREC=MAX(PREC,ABS(1.0-SUM)*(VEX1-0.5*VW1)/(1.5*SQ3*SIDE**2)) + VEX1=SUM + SUM=(VEX2-0.5*VW1)/(VEX2-0.5*SUMVAP) + PREC=MAX(PREC,ABS(1.0-SUM)*(VEX2-0.5*VW1)/(1.5*SQ3*SIDE**2)) + VEX2=SUM + DO 330 IX=1,NX + KMAX=(IZ(L5)+1)/2 + Z(L3+KMAX)=Z(L3+KMAX)*VAP(K0) + DO 320 I=1,KMAX-2 + Z(L3+KMAX-I)=Z(L3+KMAX-I)*VAP(K0+I) + Z(L3+KMAX+I)=Z(L3+KMAX+I)*VAP(K0+I) + 320 CONTINUE + Z(L3+1)=Z(L3+1)*VEX1 + Z(L3+2*KMAX-1)=Z(L3+2*KMAX-1)*VEX2 + L3=L3+2*KMAX + 330 CONTINUE + ENDIF + IZ(L4)=IZ(L4)+1 + X1=X2 + 340 CONTINUE + 350 CONTINUE + ZN1=0.5*ZN1*PIO2 + ZN2=0.5*ZN2*PIO2 + ZN3=0.5*ZN3*PIO2 + Z(NREG+1)=1.0/SQRT(ZN1) + Z(NREG+2)=1.0/SQRT(0.75*ZN3-0.7205061948*ZN2*ZN2/ZN1) + Z(NREG+3)=Z(NREG+2)*0.8488263632*ZN2/ZN1 + Z(NREG+4)=2.0/SQRT(3.0*(ZN1-ZN3)) +*---- +* TRACKING INFORMATION OUTPUT +*---- + IF(ILIGN.EQ.1) THEN + L1I=IZ(1)-1 + L1R=IZ(2)-1 + WRITE(6,500) (Z(L1R+I),I=1,4) + L1R=L1R+4 + L2=0 + DO 375 IA=1,NA3 + MNT=IZ(L1I+1) + L1I=L1I+2 + ZSIN=Z(L1R+9) + ZCOS=Z(L1R+10) + L1R=L1R+13 + DO 370 IMNT=1,MNT + NH=IZ(L1I+1) + NX=IZ(L1I+2) + L1I=L1I+3 + DO 360 IX=1,NX + L2=L2+1 + IF((IMNT.EQ.1).AND.(IX.EQ.1)) THEN + WRITE(6,510) L2,ZSIN,ZCOS,Z(L1R+1),NH,(Z(L1R+I+1),I=1,NH) + ELSE + WRITE(6,520) L2,Z(L1R+1),NH,(Z(L1R+I+1),I=1,NH) + ENDIF + L1R=L1R+NH+1 + 360 CONTINUE + L1I=L1I+NH+1 + 370 CONTINUE + 375 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(VAP) + RETURN +* + 500 FORMAT (1H1//30H TRACKING INFORMATION LISTING.//12H NUMERICAL O, + 1 27HRTHONORMALIZATION FACTORS =,1P,4E12.4//6H TRACK) + 510 FORMAT (1X,I5,7H SIN =,1P,E10.3,7H COS =,E10.3,9H WEIGHT =, + 1 E10.3,6H NH =,I3,12H SEGMENTS =,5E10.3:/(80X,5E10.3)) + 520 FORMAT (1X,I5,34X,9H WEIGHT =,1P,E10.3,6H NH =,I3,10H SEGMENTS, + 1 2H =,5E10.3:/(80X,5E10.3)) + END diff --git a/Dragon/src/SYBILA.f b/Dragon/src/SYBILA.f new file mode 100644 index 0000000..d839928 --- /dev/null +++ b/Dragon/src/SYBILA.f @@ -0,0 +1,234 @@ +*DECK SYBILA + SUBROUTINE SYBILA (IPSYS,IPTRK,IMPX,NREG,NBMIX,MAT,SIGT0,SIGW0) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of cellwise scattering-reduced collision, escape and +* transmission probabilities for the current iteration method in +* Eurydice (Sybil). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPSYS pointer to the system matrices. +* IPTRK pointer to the tracking (L_TRACK signature). +* IMPX print flag (equal to zero for no print). +* NREG total number of merged regions for which specific values +* of the neutron flux and reactions rates are required. +* NBMIX number of mixtures. +* MAT index-number of the mixture type assigned to each volume. +* SIGT0 total macroscopic cross sections ordered by mixture. +* SIGW0 within-group scattering macroscopic cross section ordered +* by mixture. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSYS,IPTRK + INTEGER IMPX,NREG,NBMIX,MAT(NREG) + REAL SIGT0(0:NBMIX),SIGW0(0:NBMIX) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + INTEGER JPAR(NSTATE),IPAR(16) + INTEGER, ALLOCATABLE, DIMENSION(:) :: NMC3,LSEC4,NMC4,NMCR4,MAIL, + 1 IGEN + REAL, ALLOCATABLE, DIMENSION(:) :: SIGT,SIGW,SIGT2,SIGW2,RAYR3, + 1 XX4,YY4,RAYR4 + INTEGER, POINTER, DIMENSION(:) :: IZMAI + REAL, POINTER, DIMENSION(:) :: RZMAI,PSSW,PSJW,PISW,PIJW + TYPE(C_PTR) :: PSSW_PTR,PSJW_PTR,PISW_PTR,PIJW_PTR,IZMAI_PTR, + 1 RZMAI_PTR +*---- +* BICKLEY FLAG +*---- + SAVE IBICKL + DATA IBICKL/0/ +*---- +* RECOVER BICKLEY TABLES +*---- + IF(IBICKL.EQ.0) THEN + CALL XDRTA2 + IBICKL=1 + ENDIF +*---- +* RECOVER SYBIL SPECIFIC PARAMETERS +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',JPAR) + ITG=JPAR(6) +* + IF(ITG.EQ.1) THEN + CALL XABORT('SYBILA: THIS GEOMETRY CANNOT BE PROCESSED WITH A' + 1 //' CURRENT ITERATION METHOD. USE KEYWORD PIJ IN ASM: (1).') + ELSE IF(ITG.EQ.2) THEN + CALL XABORT('SYBILA: THIS GEOMETRY CANNOT BE PROCESSED WITH A' + 1 //' CURRENT ITERATION METHOD. USE KEYWORD PIJ IN ASM: (2).') + ELSE IF(ITG.EQ.3) THEN + CALL LCMSIX(IPTRK,'DOITYOURSELF',1) + CALL LCMGET(IPTRK,'PARAM',IPAR) + NSUPCE=IPAR(1) + IQUA3=IPAR(2) + ALLOCATE(NMC3(NSUPCE+1),RAYR3(NSUPCE+NREG)) + CALL LCMGET(IPTRK,'NMC',NMC3) + CALL LCMGET(IPTRK,'RAYRE',RAYR3) + CALL LCMSIX(IPTRK,' ',2) + NPIJ=0 + DO 10 IKG=1,NSUPCE + J2=NMC3(IKG+1)-NMC3(IKG) + NPIJ=NPIJ+J2*J2 + 10 CONTINUE + IF(NMC3(NSUPCE+1).NE.NREG) CALL XABORT('SYBILA: ABORT.') + ALLOCATE(SIGT(NREG),SIGW(NREG)) + DO 15 I=1,NREG + SIGT(I)=SIGT0(MAT(I)) + SIGW(I)=SIGW0(MAT(I)) + 15 CONTINUE +* + PIJW_PTR=LCMARA(NPIJ) + PISW_PTR=LCMARA(NREG) + PSJW_PTR=LCMARA(NREG) + PSSW_PTR=LCMARA(NSUPCE) + CALL C_F_POINTER(PIJW_PTR,PIJW,(/ NPIJ /)) + CALL C_F_POINTER(PISW_PTR,PISW,(/ NREG /)) + CALL C_F_POINTER(PSJW_PTR,PSJW,(/ NREG /)) + CALL C_F_POINTER(PSSW_PTR,PSSW,(/ NSUPCE /)) + CALL SYB001 (NREG,NSUPCE,NPIJ,SIGT,SIGW,IMPX,IQUA3,NMC3,RAYR3, + 1 PIJW,PISW,PSJW,PSSW) + CALL LCMPPD(IPSYS,'PSSW$SYBIL',NSUPCE,2,PSSW_PTR) + CALL LCMPPD(IPSYS,'PSJW$SYBIL',NREG,2,PSJW_PTR) + CALL LCMPPD(IPSYS,'PISW$SYBIL',NREG,2,PISW_PTR) + CALL LCMPPD(IPSYS,'PIJW$SYBIL',NPIJ,2,PIJW_PTR) + DEALLOCATE(SIGW,SIGT,RAYR3) + DEALLOCATE(NMC3) + ELSE IF(ITG.EQ.4) THEN + CALL LCMSIX(IPTRK,'EURYDICE',1) + CALL LCMGET(IPTRK,'PARAM',IPAR) + IHEX=IPAR(1) + MULTC=IPAR(2) + IWIGN=IPAR(3) + NMCEL=IPAR(4) + NMERGE=IPAR(5) + NGEN=IPAR(6) + IJAT=IPAR(7) + LMAILI=IPAR(15) + LMAILR=IPAR(16) + ALLOCATE(LSEC4(NGEN),NMC4(NGEN+1),NMCR4(NGEN+1),MAIL(2*NGEN)) + ALLOCATE(XX4(NGEN),YY4(NGEN)) + CALL LCMGET(IPTRK,'XX',XX4) + CALL LCMGET(IPTRK,'YY',YY4) + CALL LCMGET(IPTRK,'LSECT',LSEC4) + CALL LCMGET(IPTRK,'NMC',NMC4) + CALL LCMGET(IPTRK,'NMCR',NMCR4) + CALL LCMGET(IPTRK,'MAIL',MAIL) + ALLOCATE(RAYR4(NMCR4(NGEN+1))) + CALL LCMGET(IPTRK,'RAYRE',RAYR4) + IF(LMAILI.GT.0) THEN + CALL LCMGPD(IPTRK,'ZMAILI',IZMAI_PTR) + CALL C_F_POINTER(IZMAI_PTR,IZMAI,(/ LMAILI /)) + ELSE +* THIS INFO IS NOT REQUIRED IN THE CALLED ROUTINE. + NULLIFY(IZMAI) + ENDIF + IF(LMAILR.GT.0) THEN + CALL LCMGPD(IPTRK,'ZMAILR',RZMAI_PTR) + CALL C_F_POINTER(RZMAI_PTR,RZMAI,(/ LMAILR /)) + ELSE +* THIS INFO IS NOT REQUIRED IN THE CALLED ROUTINE. + NULLIFY(RZMAI) + ENDIF + ALLOCATE(IGEN(NMERGE)) + CALL LCMGET(IPTRK,'IGEN',IGEN) + CALL LCMSIX(IPTRK,' ',2) +* + NCOUR=4 + IF(IHEX.NE.0) NCOUR=6 + NPIJ=0 + DO 20 IKG=1,NGEN + J2=NMC4(IKG+1)-NMC4(IKG) + NPIJ=NPIJ+J2*J2 + 20 CONTINUE + NPIS=NMC4(NGEN+1) + ALLOCATE(SIGT2(NREG),SIGW2(NREG)) + I1=0 + DO 40 IKK=1,NMERGE + IKG=IGEN(IKK) + J1=NMC4(IKG) + I2=NMC4(IKG+1)-J1 + DO 30 I=1,I2 + SIGT2(J1+I)=SIGT0(MAT(I1+I)) + SIGW2(J1+I)=SIGW0(MAT(I1+I)) + 30 CONTINUE + I1=I1+I2 + 40 CONTINUE + IF(MULTC.EQ.1) THEN + PIJW_PTR=LCMARA(NPIJ) + PISW_PTR=LCMARA(NPIS) + PSJW_PTR=LCMARA(NPIS) + PSSW_PTR=LCMARA(NGEN) + CALL C_F_POINTER(PIJW_PTR,PIJW,(/ NPIJ /)) + CALL C_F_POINTER(PISW_PTR,PISW,(/ NPIS /)) + CALL C_F_POINTER(PSJW_PTR,PSJW,(/ NPIS /)) + CALL C_F_POINTER(PSSW_PTR,PSSW,(/ NGEN /)) +* + CALL SYB002 (NGEN,NPIJ,NPIS,SIGT2,SIGW2,IMPX,NCOUR,IWIGN, + 1 IPAR(8),XX4,YY4,NMC4,RAYR4,MAIL,RZMAI,PIJW,PISW,PSJW,PSSW) + CALL LCMPPD(IPSYS,'PSSW$SYBIL',NGEN,2,PSSW_PTR) + CALL LCMPPD(IPSYS,'PSJW$SYBIL',NPIS,2,PSJW_PTR) + CALL LCMPPD(IPSYS,'PISW$SYBIL',NPIS,2,PISW_PTR) + CALL LCMPPD(IPSYS,'PIJW$SYBIL',NPIJ,2,PIJW_PTR) + ELSE + IF(MULTC.EQ.4) NCOUR=3*NCOUR + NRAYRE=NMCR4(NGEN+1) + PIJW_PTR=LCMARA(NPIJ) + PISW_PTR=LCMARA(NCOUR*NPIS) + PSJW_PTR=LCMARA(NCOUR*NPIS) + PSSW_PTR=LCMARA(NCOUR*NCOUR*NGEN) + CALL C_F_POINTER(PIJW_PTR,PIJW,(/ NPIJ /)) + CALL C_F_POINTER(PISW_PTR,PISW,(/ NCOUR*NPIS /)) + CALL C_F_POINTER(PSJW_PTR,PSJW,(/ NCOUR*NPIS /)) + CALL C_F_POINTER(PSSW_PTR,PSSW,(/ NCOUR*NCOUR*NGEN /)) +* + IF(MULTC.EQ.2) THEN +* ROTH X 4 OR ROTH X 6 APPROXIMATION. + CALL SYB003 (NGEN,NPIJ,NPIS,SIGT2,SIGW2,IMPX,NCOUR,IWIGN, + 1 IPAR(8),XX4,YY4,NMC4,RAYR4,MAIL,RZMAI,PIJW,PISW,PSJW, + 2 PSSW) + ELSE IF(MULTC.EQ.3) THEN +* DP-0 APPROXIMATION. + CALL SYB004 (NGEN,NPIJ,NPIS,NRAYRE,SIGT2,SIGW2,IMPX, + 1 NCOUR,IPAR(8),XX4,YY4,LSEC4,NMC4,NMCR4,RAYR4,MAIL, + 2 IZMAI,RZMAI,PIJW,PISW,PSJW,PSSW) + ELSE IF(MULTC.EQ.4) THEN +* DP-1 APPROXIMATION. + CALL SYB005 (NGEN,NPIJ,NPIS,NRAYRE,SIGT2,SIGW2,IMPX, + 1 NCOUR,IPAR(8),XX4,YY4,LSEC4,NMC4,NMCR4,RAYR4,MAIL, + 2 IZMAI,RZMAI,PIJW, PISW,PSJW,PSSW) + ELSE + CALL XABORT('SYBILA: UNKNOWN CP MODULE(1).') + ENDIF + DEALLOCATE(RAYR4,YY4,XX4) + DEALLOCATE(IGEN,MAIL,NMCR4,NMC4,LSEC4) + CALL LCMPPD(IPSYS,'PSSW$SYBIL',NCOUR*NCOUR*NGEN,2,PSSW_PTR) + CALL LCMPPD(IPSYS,'PSJW$SYBIL',NCOUR*NPIS,2,PSJW_PTR) + CALL LCMPPD(IPSYS,'PISW$SYBIL',NCOUR*NPIS,2,PISW_PTR) + CALL LCMPPD(IPSYS,'PIJW$SYBIL',NPIJ,2,PIJW_PTR) + ENDIF + DEALLOCATE(SIGW2,SIGT2) + ELSE + CALL XABORT('SYBILA: UNKNOWN CP MODULE(2).') + ENDIF + IF(IMPX.GT.2) CALL LCMLIB(IPSYS) + RETURN + END diff --git a/Dragon/src/SYBILF.f b/Dragon/src/SYBILF.f new file mode 100644 index 0000000..9e344c1 --- /dev/null +++ b/Dragon/src/SYBILF.f @@ -0,0 +1,227 @@ +*DECK SYBILF + SUBROUTINE SYBILF (KPSYS,IPTRK,IFTRAK,IMPX,NGEFF,NGIND,IDIR,NREG, + 1 NUNKNO,MAT,VOL,FUNKNO,SUNKNO,TITR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solve N-group transport equation for fluxes using the SYBIL current +* iteration method. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* KPSYS pointer to the assembly matrices (L_PIJ signature). KPSYS is +* an array of directories. +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK not used. +* IMPX print flag (equal to zero for no print). +* NGEFF number of energy groups processed in parallel. +* NGIND energy group indices assign to the NGEFF set. +* IDIR not used (=0 only for SYBIL). +* NREG total number of regions for which specific values of the +* neutron flux and reactions rates are required. +* NUNKNO total number of unknowns in vectors SUNKNO and FUNKNO. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* SUNKNO input source vector. +* TITR title. +* +*Parameters: input/output +* FUNKNO unknown vector. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) KPSYS(NGEFF),IPTRK + CHARACTER TITR*72 + INTEGER NGEFF,NGIND(NGEFF),IFTRAK,IMPX,IDIR,NREG,NUNKNO, + 1 MAT(NREG) + REAL VOL(NREG),FUNKNO(NUNKNO,NGEFF),SUNKNO(NUNKNO,NGEFF) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6,NSTATE=40) + CHARACTER NAMLCM*12,NAMMY*12 + INTEGER ISTATE(NSTATE),IPAR(16) + LOGICAL EMPTY,LCM +*---- +* ALLOCATABLE ARRAYS +*---- + TYPE(C_PTR) NMC3_PTR,PROCE_PTR,PIJW_PTR,PISW_PTR,PSJW_PTR, + 1 PSSW_PTR,XX4_PTR,YY4_PTR,NMC4_PTR,IFR_PTR,ALB_PTR,INUM_PTR, + 2 MIX_PTR,DVX_PTR,IGEN_PTR + INTEGER, POINTER, DIMENSION(:) :: NMC3,NMC4,IFR,INUM,MIX,IGEN + REAL, POINTER, DIMENSION(:) :: PROCE,PIJW,PISW,PSJW,PSSW,XX4,YY4, + 1 ALB,DVX +* + IF(IDIR.NE.0) CALL XABORT('SYBILF: EXPECTING IDIR=0') + IF(IFTRAK.NE.0) CALL XABORT('SYBILF: EXPECTING IFTRAK=0') + IF(MAT(1).LT.0) CALL XABORT('SYBILF: EXPECTING MAT(1)>=0') + IF(VOL(1).LT.0.0) CALL XABORT('SYBILF: EXPECTING VOL(1)>=0') + CALL LCMINF(KPSYS(1),NAMLCM,NAMMY,EMPTY,ILONG,LCM) +*---- +* RECOVER SYBIL SPECIFIC PARAMETERS +*---- + IF(IMPX.GT.2) WRITE(IUNOUT,'(//9H SYBILF: ,A72)') TITR + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + ITG=ISTATE(6) + CALL LCMGET(IPTRK,'EPSJ',EPSJ) +*---- +* MAIN LOOP OVER ENERGY GROUPS. +*---- + DO 90 II=1,NGEFF + IF(IMPX.GT.1) WRITE(IUNOUT,'(/25H SYBILF: PROCESSING GROUP,I5, + 1 6H WITH ,A,1H.)') NGIND(II),'SYBIL' +* + IF(ITG.EQ.1) THEN + CALL XABORT('SYBILF: THIS GEOMETRY CANNOT BE PROCESSED WITH A' + 1 //' CURRENT ITERATION METHOD. USE KEYWORD PIJ IN ASM: (1).') + ELSE IF(ITG.EQ.2) THEN + CALL XABORT('SYBILF: THIS GEOMETRY CANNOT BE PROCESSED WITH A' + 1 //' CURRENT ITERATION METHOD. USE KEYWORD PIJ IN ASM: (2).') + ELSE IF(ITG.EQ.3) THEN + CALL LCMSIX(IPTRK,'DOITYOURSELF',1) + CALL LCMGET(IPTRK,'PARAM',IPAR) + NSUPCE=IPAR(1) + ISTAT=IPAR(3) + CALL LCMGPD(IPTRK,'NMC',NMC3_PTR) + CALL LCMGPD(IPTRK,'PROCEL',PROCE_PTR) + CALL LCMSIX(IPTRK,' ',2) +* + CALL C_F_POINTER(NMC3_PTR,NMC3,(/ NSUPCE+1 /)) + CALL C_F_POINTER(PROCE_PTR,PROCE,(/ NSUPCE*NSUPCE /)) + NPIJ=0 + DO 10 IKG=1,NSUPCE + J2=NMC3(IKG+1)-NMC3(IKG) + NPIJ=NPIJ+J2*J2 + 10 CONTINUE + IF(NMC3(NSUPCE+1).NE.NREG) CALL XABORT('SYBILF: ABORT.') +* + IF(LCM) THEN + CALL LCMGPD(KPSYS(II),'PIJW$SYBIL',PIJW_PTR) + CALL LCMGPD(KPSYS(II),'PISW$SYBIL',PISW_PTR) + CALL LCMGPD(KPSYS(II),'PSJW$SYBIL',PSJW_PTR) + CALL LCMGPD(KPSYS(II),'PSSW$SYBIL',PSSW_PTR) +* + CALL C_F_POINTER(PIJW_PTR,PIJW,(/ NPIJ /)) + CALL C_F_POINTER(PISW_PTR,PISW,(/ NREG /)) + CALL C_F_POINTER(PSJW_PTR,PSJW,(/ NREG /)) + CALL C_F_POINTER(PSSW_PTR,PSSW,(/ NSUPCE /)) + ELSE + ALLOCATE(PIJW(NPIJ),PISW(NREG),PSJW(NREG),PSSW(NSUPCE)) + CALL LCMGET(KPSYS(II),'PIJW$SYBIL',PIJW) + CALL LCMGET(KPSYS(II),'PISW$SYBIL',PISW) + CALL LCMGET(KPSYS(II),'PSJW$SYBIL',PSJW) + CALL LCMGET(KPSYS(II),'PSSW$SYBIL',PSSW) + ENDIF +* + CALL SYBJJ0 (NREG,NSUPCE,NPIJ,EPSJ,NUNKNO,FUNKNO(1,II), + 1 SUNKNO(1,II),IMPX,ISTAT,NMC3,PROCE,PIJW,PISW,PSJW,PSSW) + IF(.NOT.LCM) DEALLOCATE(PSSW,PSJW,PISW,PIJW) + ELSE IF(ITG.EQ.4) THEN + CALL LCMSIX(IPTRK,'EURYDICE',1) + CALL LCMGET(IPTRK,'PARAM',IPAR) + IHEX=IPAR(1) + MULTC=IPAR(2) + NMCEL=IPAR(4) + NMERGE=IPAR(5) + NGEN=IPAR(6) + IJAT=IPAR(7) + NCOUR=4 + IF(IHEX.NE.0) NCOUR=6 +* + CALL LCMGPD(IPTRK,'XX',XX4_PTR) + CALL LCMGPD(IPTRK,'YY',YY4_PTR) + CALL LCMGPD(IPTRK,'NMC',NMC4_PTR) + CALL LCMGPD(IPTRK,'IFR',IFR_PTR) + CALL LCMGPD(IPTRK,'ALB',ALB_PTR) + CALL LCMGPD(IPTRK,'INUM',INUM_PTR) + CALL LCMGPD(IPTRK,'MIX',MIX_PTR) + CALL LCMGPD(IPTRK,'DVX',DVX_PTR) + CALL LCMGPD(IPTRK,'IGEN',IGEN_PTR) + CALL LCMSIX(IPTRK,' ',2) +* + CALL C_F_POINTER(XX4_PTR,XX4,(/ NGEN /)) + CALL C_F_POINTER(YY4_PTR,YY4,(/ NGEN /)) + CALL C_F_POINTER(NMC4_PTR,NMC4,(/ NGEN+1 /)) + CALL C_F_POINTER(IFR_PTR,IFR,(/ NCOUR*NMCEL /)) + CALL C_F_POINTER(ALB_PTR,ALB,(/ NCOUR*NMCEL /)) + CALL C_F_POINTER(INUM_PTR,INUM,(/ NMCEL /)) + CALL C_F_POINTER(MIX_PTR,MIX,(/ NCOUR*NMERGE /)) + CALL C_F_POINTER(DVX_PTR,DVX,(/ NCOUR*NMERGE /)) + CALL C_F_POINTER(IGEN_PTR,IGEN,(/ NMERGE /)) + NPIJ=0 + DO 20 IKG=1,NGEN + J2=NMC4(IKG+1)-NMC4(IKG) + NPIJ=NPIJ+J2*J2 + 20 CONTINUE + NPIS=NMC4(NGEN+1) +* + IF(MULTC.EQ.1) THEN + IF(LCM) THEN + CALL LCMGPD(KPSYS(II),'PIJW$SYBIL',PIJW_PTR) + CALL LCMGPD(KPSYS(II),'PISW$SYBIL',PISW_PTR) + CALL LCMGPD(KPSYS(II),'PSJW$SYBIL',PSJW_PTR) + CALL LCMGPD(KPSYS(II),'PSSW$SYBIL',PSSW_PTR) +* + CALL C_F_POINTER(PIJW_PTR,PIJW,(/ NPIJ /)) + CALL C_F_POINTER(PISW_PTR,PISW,(/ NPIS /)) + CALL C_F_POINTER(PSJW_PTR,PSJW,(/ NPIS /)) + CALL C_F_POINTER(PSSW_PTR,PSSW,(/ NGEN /)) + ELSE + ALLOCATE(PIJW(NPIJ),PISW(NPIS),PSJW(NPIS),PSSW(NGEN)) + CALL LCMGET(KPSYS(II),'PIJW$SYBIL',PIJW) + CALL LCMGET(KPSYS(II),'PISW$SYBIL',PISW) + CALL LCMGET(KPSYS(II),'PSJW$SYBIL',PSJW) + CALL LCMGET(KPSYS(II),'PSSW$SYBIL',PSSW) + ENDIF +* + CALL SYBJJ1 (NREG,NMCEL,NMERGE,NGEN,NPIJ,NPIS,EPSJ,NUNKNO, + 1 FUNKNO(1,II),SUNKNO(1,II),IMPX,NCOUR,XX4,YY4,NMC4,IFR,ALB, + 2 INUM,IGEN,PIJW,PISW,PSJW,PSSW) + ELSE + IF(MULTC.EQ.4) NCOUR=3*NCOUR + IF(LCM) THEN + CALL LCMGPD(KPSYS(II),'PIJW$SYBIL',PIJW_PTR) + CALL LCMGPD(KPSYS(II),'PISW$SYBIL',PISW_PTR) + CALL LCMGPD(KPSYS(II),'PSJW$SYBIL',PSJW_PTR) + CALL LCMGPD(KPSYS(II),'PSSW$SYBIL',PSSW_PTR) +* + CALL C_F_POINTER(PIJW_PTR,PIJW,(/ NPIJ /)) + CALL C_F_POINTER(PISW_PTR,PISW,(/ NCOUR*NPIS /)) + CALL C_F_POINTER(PSJW_PTR,PSJW,(/ NCOUR*NPIS /)) + CALL C_F_POINTER(PSSW_PTR,PSSW,(/ NCOUR*NCOUR*NGEN /)) + ELSE + ALLOCATE(PIJW(NPIJ),PISW(NCOUR*NPIS),PSJW(NCOUR*NPIS), + 1 PSSW(NCOUR*NCOUR*NGEN)) + CALL LCMGET(KPSYS(II),'PIJW$SYBIL',PIJW) + CALL LCMGET(KPSYS(II),'PISW$SYBIL',PISW) + CALL LCMGET(KPSYS(II),'PSJW$SYBIL',PSJW) + CALL LCMGET(KPSYS(II),'PSSW$SYBIL',PSSW) + ENDIF +* + CALL SYBJJ2 (NREG,NMCEL,NMERGE,NGEN,IJAT,NPIJ,NPIS,EPSJ, + 1 NUNKNO,FUNKNO(1,II),SUNKNO(1,II),IMPX,NCOUR,NMC4,IFR,ALB, + 2 INUM,MIX,DVX,IGEN,PIJW,PISW,PSJW,PSSW) + ENDIF + IF(.NOT.LCM) DEALLOCATE(PSSW,PSJW,PISW,PIJW) + ELSE + CALL XABORT('SYBILF: UNKNOWN CP MODULE(2).') + ENDIF +*---- +* END OF LOOP OVER ENERGY GROUPS +*---- + 90 CONTINUE + RETURN + END diff --git a/Dragon/src/SYBILP.f b/Dragon/src/SYBILP.f new file mode 100644 index 0000000..3ee5e39 --- /dev/null +++ b/Dragon/src/SYBILP.f @@ -0,0 +1,128 @@ +*DECK SYBILP + SUBROUTINE SYBILP (IPTRK,IMPX,NREG,NBMIX,MAT,VOL,SIGT0,SIGW0, + 1 NELPIJ,PIJ,ILK) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the collision probabilities for Sybil. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK pointer to the tracking (L_TRACK signature). +* IMPX print flag (equal to zero for no print). +* NREG total number of merged blocks for which specific values +* of the neutron flux and reactions rates are required. +* NBMIX number of mixtures (NBMIX=max(MAT(i))). +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* SIGT0 total macroscopic cross sections ordered by mixture. +* SIGW0 P0 within-group scattering macroscopic cross sections +* ordered by mixture. +* NELPIJ number of elements in pij matrix. +* ILK leakage flag (=.true. if neutron leakage through external +* boundary is present). +* +*Parameters: output +* PIJ reduced and symmetrized collision probabilities. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + LOGICAL ILK + TYPE(C_PTR) IPTRK + INTEGER IMPX,NREG,NBMIX,MAT(NREG),NELPIJ + REAL VOL(NREG),SIGT0(0:NBMIX),SIGW0(0:NBMIX),PIJ(NELPIJ) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (EPS1=1.0E-4,NSTATE=40) + INTEGER JPAR(NSTATE) +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: SIGT,SIGW + REAL, ALLOCATABLE, DIMENSION(:,:) :: PP +*---- +* BICKLEY FLAG +*---- + SAVE IBICKL + DATA IBICKL/0/ +*---- +* RECOVER BICKLEY FUNCTIONS +*---- + IF(IBICKL.EQ.0) THEN + CALL XDRTA2 + IBICKL=1 + ENDIF +*---- +* RECOVER SYBIL SPECIFIC PARAMETERS +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',JPAR) + ITG=JPAR(6) +* + ALLOCATE(SIGT(NREG),SIGW(NREG),PP(NREG,NREG)) + DO 10 I=1,NREG + SIGT(I)=SIGT0(MAT(I)) + SIGW(I)=SIGW0(MAT(I)) + 10 CONTINUE + CALL SYBCP1(IPTRK,ITG,IMPX,NREG,SIGT,SIGW,PP) +* + IF((IMPX.GE.10).OR.(IMPX.LT.0)) THEN +* CHECK THE RECIPROCITY CONDITIONS. + VOLTOT=0.0 + DO 20 I=1,NREG + VOLTOT=VOLTOT+VOL(I) + 20 CONTINUE + VOLTOT=VOLTOT/REAL(NREG) + WRK=0.0 + DO 40 I=1,NREG + DO 30 J=1,NREG + AAA=PP(I,J)*VOL(I) + BBB=PP(J,I)*VOL(J) + WRK=MAX(WRK,ABS(AAA-BBB)/VOLTOT) + 30 CONTINUE + 40 CONTINUE + IF(WRK.GE.EPS1) WRITE (6,150) WRK +* CHECK THE CONSERVATION CONDITIONS. + IF(.NOT.ILK) THEN + WRK=0.0 + DO 60 I=1,NREG + F1=1.0 + DO 50 J=1,NREG + AAA=PP(I,J) + F1=F1-AAA*(SIGT(J)-SIGW(J)) + 50 CONTINUE + WRK=AMAX1(WRK,ABS(F1)) + 60 CONTINUE + IF(WRK.GE.EPS1) WRITE (6,160) WRK + ENDIF + ENDIF +* + IC=0 + DO 80 IKK=1,NREG + IOF=(IKK-1)*NREG + DO 70 JKK=1,IKK + IC=IC+1 + PIJ(IC)=PP(JKK,IKK)*VOL(JKK) + 70 CONTINUE + 80 CONTINUE + DEALLOCATE(PP,SIGT,SIGW) + RETURN +* + 150 FORMAT (/50H THE SCATTERING-REDUCED PIJ DO NOT MEET THE RECIPR, + 1 25HOCITY CONDITIONS. RECIP =,1P,E10.3/) + 160 FORMAT (/50H THE SCATTERING-REDUCED PIJ DO NOT MEET THE CONSER, + 1 25HVATION CONDITIONS. LEAK =,1P,E10.3/) + END diff --git a/Dragon/src/SYBILT.f b/Dragon/src/SYBILT.f new file mode 100644 index 0000000..d1db3f7 --- /dev/null +++ b/Dragon/src/SYBILT.f @@ -0,0 +1,286 @@ +*DECK SYBILT + SUBROUTINE SYBILT(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Sybil-type (2D) tracking operator. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1) creation or modification type(L_TRACK); +* HENTRY(2) read-only type(L_GEOM). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40,IOUT=6) + CHARACTER TEXT4*4,TEXT12*12,TITLE*72,HSIGN*12 + DOUBLE PRECISION DFLOTT + INTEGER ITITL(18),IGP(NSTATE),ISTATE(NSTATE),JQUA2(2),IPARAM(15) +*---- +* PARAMETER VALIDATION +*---- + IF(NENTRY.LE.1) CALL XABORT('SYBILT: TWO PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('SYBILT: L' + 1 //'CM OBJECT EXPECTED AT LHS.') + IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) CALL XABORT('SYBILT: E' + 1 //'NTRY IN CREATE OR MODIFICATION MODE EXPECTED.') + IF((JENTRY(2).NE.2).OR.((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2))) + 1 CALL XABORT('SYBILT: LCM OBJECT IN READ-ONLY MODE EXPECTED AT R' + 1 //'HS.') + CALL LCMGTC(KENTRY(2),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_GEOM') THEN + TEXT12=HENTRY(2) + CALL XABORT('SYBILT: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_GEOM EXPECTED.') + ENDIF + HSIGN='L_TRACK' + CALL LCMPTC(KENTRY(1),'SIGNATURE',12,HSIGN) + HSIGN='SYBIL' + CALL LCMPTC(KENTRY(1),'TRACK-TYPE',12,HSIGN) + CALL LCMGET(KENTRY(2),'STATE-VECTOR',ISTATE) +* + IMPX=1 + TITLE=' ' + IF(JENTRY(1).EQ.0) THEN + MAXPTS=ISTATE(6) + MAXZ=10000 + MAXJ=MAX(18,4*MAXPTS) + MULTC=3 + IWIGN=3 + INORM=0 + IQW=0 + JQUA1=5 + JQUA2(1)=3 + JQUA2(2)=3 + IQUA10=5 + IBIHET=2 + ELSE IF(JENTRY(1).EQ.1) THEN + CALL LCMGTC(KENTRY(1),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_TRACK') THEN + TEXT12=HENTRY(1) + CALL XABORT('SYBILT: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_TRACK EXPECTED.') + ENDIF + CALL LCMGTC(KENTRY(1),'TRACK-TYPE',12,HSIGN) + IF(HSIGN.NE.'SYBIL') THEN + TEXT12=HENTRY(1) + CALL XABORT('SYBILT: TRACK-TYPE OF '//TEXT12//' IS '//HSIGN + 1 //'. SYBIL EXPECTED.') + ENDIF + CALL LCMGET(KENTRY(1),'STATE-VECTOR',IGP) + MAXPTS=IGP(1) + ITG=IGP(6) + MAXZ=IGP(7) + MAXJ=IGP(8) + IF(ITG.EQ.2) THEN + CALL LCMSIX(KENTRY(1),'PURE-GEOM',1) + CALL LCMGET(KENTRY(1),'PARAM',IPARAM) + CALL LCMSIX(KENTRY(1),' ',2) + JQUA1=IPARAM(3) + ELSE IF(ITG.EQ.3) THEN + CALL LCMSIX(KENTRY(1),'DOITYOURSELF',1) + CALL LCMGET(KENTRY(1),'PARAM',IPARAM) + CALL LCMSIX(KENTRY(1),' ',2) + JQUA1=IPARAM(2) + ELSE IF(ITG.EQ.4) THEN + CALL LCMSIX(KENTRY(1),'EURYDICE',1) + CALL LCMGET(KENTRY(1),'PARAM',IPARAM) + CALL LCMSIX(KENTRY(1),' ',2) + MULTC=IPARAM(2) + IWIGN=IPARAM(3) + INORM=IPARAM(12) + IQW=IPARAM(13) + JQUA1=IPARAM(10) + JQUA2(1)=IPARAM(8) + JQUA2(2)=IPARAM(9) + ENDIF + IF(IGP(40).NE.0) THEN + CALL LCMSIX(KENTRY(1),'BIHET',1) + CALL LCMGET(KENTRY(1),'PARAM',IPARAM) + CALL LCMSIX(KENTRY(1),' ',2) + IBIHET=IPARAM(6) + IQUA10=IPARAM(8) + ELSE + IBIHET=0 + IQUA10=0 + ENDIF + CALL LCMLEN(KENTRY(1),'TITLE',LENGT,ITYLCM) + IF(LENGT.GT.0) CALL LCMGTC(KENTRY(1),'TITLE',72,TITLE) + ENDIF + IRECT=0 + IHALT=0 + ILIGN=0 + FRTM=0.05 + EPSJ=0.5E-5 + 20 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + 21 CONTINUE + IF(INDIC.EQ.10) GO TO 30 + IF(INDIC.NE.3) CALL XABORT('SYBILT: CHARACTER DATA EXPECTED.') + IF(TEXT4.EQ.'EDIT') THEN + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SYBILT: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT4.EQ.'MAXR') THEN + CALL REDGET(INDIC,MAXPTS,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SYBILT: INTEGER DATA EXPECTED(2).') + MAXJ=MAX(MAXJ,4*MAXPTS) + ELSE IF(TEXT4.EQ.'MAXJ') THEN +* ALLOCATED STORAGE FOR STORING THE INTERFACE CURRENTS. + CALL REDGET(INDIC,MAXJ,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SYBILT: INTEGER DATA EXPECTED.') + ELSE IF(TEXT4.EQ.'MAXZ') THEN +* ALLOCATED STORAGE FOR STORING THE TRACKING INFORMATION. + CALL REDGET(INDIC,MAXZ,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SYBILT: INTEGER DATA EXPECTED.') + ELSE IF(TEXT4.EQ.'TITL') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TITLE,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('SYBILT: TITLE EXPECTED.') + ELSE IF(TEXT4.EQ.'ROTH') THEN + MULTC=1 + ELSE IF(TEXT4.EQ.'ROT+') THEN + MULTC=2 + ELSE IF(TEXT4.EQ.'DP00') THEN + MULTC=3 + ELSE IF(TEXT4.EQ.'DP01') THEN + MULTC=4 + ELSE IF(TEXT4.EQ.'ASKE') THEN +* USE ASKEW CYLINDERIZATION IN EURYDICE. + IWIGN=1 + ELSE IF(TEXT4.EQ.'WIGN') THEN +* USE ASKEW CYLINDERIZATION IN EURYDICE. + IWIGN=2 + ELSE IF(TEXT4.EQ.'SANC') THEN +* USE SANCHEZ CYLINDERIZATION IN EURYDICE. + IWIGN=3 + ELSE IF(TEXT4.EQ.'HALT') THEN +* STOP AT THE END OF TRACKING. + IHALT=1 + ELSE IF(TEXT4.EQ.'LIGN') THEN +* PRINT THE TRACKING INFORMATION. + ILIGN=1 + ELSE IF(TEXT4.EQ.'RENO') THEN +* NORMALIZE TRACKS. + INORM=0 + ELSE IF(TEXT4.EQ.'NORE') THEN +* DO NOT NORMALIZE TRACKS. + INORM=1 + ELSE IF(TEXT4.EQ.'RECT') THEN +* DO NOT CONSIDER THE SYMMETRIES OF SQUARE CELLS IN EURYDICE. + IRECT=1 + ELSE IF(TEXT4.EQ.'GAUS') THEN +* USE GAUSS QUADRATURES IN ANGLE AND SPACE. + IQW=0 + ELSE IF(TEXT4.EQ.'EQW') THEN +* USE EQUAL WEIGHT QUADRATURES IN ANGLE AND SPACE. + IQW=1 + ELSE IF(TEXT4.EQ.'QUA1') THEN +* 1-D QUADRATURE PARAMETER. + CALL REDGET(INDIC,JQUA1,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SYBILT: INTEGER DATA EXPECTED.') + ELSE IF(TEXT4.EQ.'QUA2') THEN +* 2-D QUADRATURE PARAMETERS (ANGLE AND SPACE). + CALL REDGET(INDIC,JQUA2(1),FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SYBILT: INTEGER DATA EXPECTED.') + CALL REDGET(INDIC,JQUA2(2),FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SYBILT: INTEGER DATA EXPECTED.') + ELSE IF(TEXT4.EQ.'EPSJ') THEN + CALL REDGET(INDIC,NITMA,EPSJ,TEXT4,DFLOTT) + IF (INDIC.NE.2) CALL XABORT('SYBILT: REAL DATA EXPECTED.') + ELSE IF(TEXT4.EQ.'QUAB') THEN + CALL REDGET(INDIC,IQUA10,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('SYBILT: INTEGER DATA EXPECTED.') + ELSE IF(TEXT4.EQ.'SAPO') THEN + IBIHET=1 + ELSE IF(TEXT4.EQ.'HEBE') THEN + IBIHET=2 + ELSE IF(TEXT4.EQ.'SLSI') THEN + IBIHET=3 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF (INDIC.NE.2) GOTO 21 + FRTM=FLOTT + ELSE IF(TEXT4.EQ.'SLSS') THEN + IBIHET=4 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF (INDIC.NE.2) GOTO 21 + FRTM=FLOTT + ELSE IF(TEXT4.EQ.';') THEN + GO TO 30 + ELSE + CALL XABORT('SYBILT: '//TEXT4//' IS AN INVALID KEY WORD.') + ENDIF + GO TO 20 +* + 30 IF(TITLE.NE.' ') THEN + READ(TITLE,'(18A4)') (ITITL(I),I=1,18) + CALL LCMPUT(KENTRY(1),'TITLE',18,3,ITITL) + ENDIF + TEXT12=HENTRY(2) + READ(TEXT12,'(3A4)') (ITITL(I),I=1,3) + CALL LCMPUT(KENTRY(1),'LINK.GEOM',3,3,ITITL) + IF(IMPX.GT.1) WRITE(IOUT,100) TITLE +* + IF(MAXPTS.EQ.0) CALL XABORT('SYBILT: MAXPTS NOT DEFINED.') + CALL LCMPUT(KENTRY(1),'EPSJ',1,2,EPSJ) + CALL SYBTRK (KENTRY(1),KENTRY(2),IMPX,MAXPTS,MAXJ,MAXZ,MULTC, + 1 IWIGN,IHALT,ILIGN,INORM,IRECT,IQW,JQUA1,JQUA2,IQUA10,IBIHET,FRTM) +* + IF(IMPX.GT.0) THEN + CALL LCMGET(KENTRY(1),'STATE-VECTOR',IGP) + WRITE(IOUT,110) (IGP(I),I=1,9),IGP(40) + WRITE(IOUT,120) EPSJ + ENDIF + RETURN +* + 100 FORMAT(1H1, + 1 36H SSSSS YY YY BBBBBB IIIIII LL ,10X,2H1 ,83(1H*)/ + 2 38H SSSSSSS YY YY BBBBBBB IIIIII LL ,8X,3H11 ,45(1H*), + 3 38H MULTIGROUP VERSION. A. HEBERT (1987)/ + 4 48H SS SS YY YY BB BB II LL 111/ + 5 48H SSS Y Y BBBBBB II LL === 11/ + 6 48H SSS YY BBBBBB II LL === 11/ + 7 48H SS SS YY BB BB II LL 11/ + 8 50H SSSSSSS YY BBBBBBB IIIIII LLLLLLL 111111/ + 9 50H SSSSS YY BBBBBB IIIIII LLLLLLL 111111// + 1 1X,A72//) + 110 FORMAT(/14H STATE VECTOR:/ + 1 7H NREG ,I7,22H (NUMBER OF REGIONS)/ + 2 7H NUN ,I7,28H (NUMBER OF FLUX UNKNOWNS)/ + 3 7H ILK ,I7,39H (0=LEAKAGE PRESENT/1=LEAKAGE ABSENT)/ + 4 7H NBMIX ,I7,36H (MAXIMUM NUMBER OF MIXTURES USED)/ + 5 7H NSURF ,I7,29H (NUMBER OF OUTER SURFACES)/ + 6 7H ITG ,I7,21H (TYPE OF GEOMETRY)/ + 7 5H MAXZ ,I9,20H (TRACKING LENGTH)/ + 8 5H MAXJ ,I9,41H (INTERNAL STORAGE LENGTH FOR CURRENTS)/ + 9 7H NUNCUR,I7,47H (NUMBER OF ADDITIONAL INTERFACE CURRENT COMP, + 1 7HONENTS)/ + 2 7H IBIHET,I7,46H (0/1=DOUBLE HETEROGENEITY IS NOT/IS ACTIVE)) + 120 FORMAT(5H EPSJ,1P,E11.2,33H (FLUX-CURRENT ITERATION EPSILON)) + END diff --git a/Dragon/src/SYBJJ0.f b/Dragon/src/SYBJJ0.f new file mode 100644 index 0000000..90709c4 --- /dev/null +++ b/Dragon/src/SYBJJ0.f @@ -0,0 +1,275 @@ +*DECK SYBJJ0 + SUBROUTINE SYBJJ0 (IPAS,NSUPCE,NPIJ,NUNKNO,EPSJ,FUNKNO,SUNKNO, + 1 IMPX,ISTAT,NMC,PROCEL,PIJW,PISW,PSJW,PSSW) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the neutron flux and interface currents in a do-it-yourself +* geometry using the current iteration method. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPAS total number of regions. +* NSUPCE number of cells. +* NPIJ length of cellwise scattering-reduced collision probability +* matrices. +* EPSJ stopping criterion for flux-current iterations. +* NUNKNO total number of unknowns in vectors SUNKNO and FUNKNO. +* SUNKNO input source vector. +* IMPX print flag (equal to 0 for no print). +* ISTAT statistical approximation flag (set with ISTAT=1). +* NMC offset of the first volume in each cell. +* PROCEL user supplied geometrical matrix. +* PIJW cellwise scattering-reduced collision probability matrices. +* PISW cellwise scattering-reduced escape probability matrices. +* PSJW cellwise scattering-reduced collision probability matrices +* for incoming neutrons. +* PSSW cellwise scattering-reduced transmission probability matrices. +* +*Parameters: input/output +* FUNKNO unknown vector. +* +*----------------------------------------------------------------------- +* + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IPAS,NSUPCE,NPIJ,NUNKNO,IMPX,ISTAT,NMC(NSUPCE+1) + REAL EPSJ,FUNKNO(NUNKNO),SUNKNO(NUNKNO),PROCEL(NSUPCE,NSUPCE), + 1 PIJW(NPIJ),PISW(IPAS),PSJW(IPAS),PSSW(NSUPCE) +*---- +* LOCAL VARIABLES +*---- + REAL PIJ + LOGICAL LOGTES + PARAMETER (MAXIT=400,LACCFC=2,ICL1=3,ICL2=3) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, DIMENSION(:), POINTER :: INDPIJ + DOUBLE PRECISION, DIMENSION(:), POINTER :: CIT0 + DOUBLE PRECISION, DIMENSION(:,:), POINTER :: CITR,AITR + DOUBLE PRECISION, DIMENSION(:), POINTER :: WCURR +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(INDPIJ(NSUPCE)) + ALLOCATE(CITR(3,NSUPCE),CIT0(NSUPCE),AITR(2,NSUPCE)) + ALLOCATE(WCURR(NSUPCE)) +* + IPIJ=0 + DO 10 JKG=1,NSUPCE + J2=NMC(JKG+1)-NMC(JKG) + INDPIJ(JKG)=IPIJ + IPIJ=IPIJ+J2*J2 + 10 CONTINUE +*---- +* PROCESS STATISTICAL APPROXIMATION +*---- + IF(ISTAT.NE.0) THEN + X1=0.0D0 + DO 20 IKK=1,NSUPCE + X1=X1+PSSW(IKK)*PROCEL(1,IKK) + 20 CONTINUE + X1=1.0D0/(1.0D0-X1) + SSS=0.0D0 + DO 35 IKK=1,NSUPCE + I1P=NMC(IKK) + I2=NMC(IKK+1)-I1P + DO 30 I=1,I2 + SSS=SSS+PROCEL(1,IKK)*X1*PSJW(I1P+I)*SUNKNO(I1P+I) + 30 CONTINUE + 35 CONTINUE + IT3=1 + DO 40 IKK=1,NSUPCE + CITR(IT3,IKK)=SSS + 40 CONTINUE + GO TO 190 + ENDIF +*---- +* COMPUTE PSJW * Q(*) CONTRIBUTION +*---- + DO 52 IKK=1,NSUPCE + CIT0(IKK)=0.0D0 + CITR(1,IKK)=FUNKNO(IPAS+IKK) + DO 51 JKK=1,NSUPCE + I1P=NMC(JKK) + I2=NMC(JKK+1)-I1P + DO 50 I=1,I2 + CIT0(IKK)=CIT0(IKK)+PROCEL(IKK,JKK)*PSJW(I1P+I)*SUNKNO(I1P+I) + 50 CONTINUE + 51 CONTINUE + 52 CONTINUE +*---- +* COMPUTE NORMALIZATION VECTOR WCURR +*---- + DO 65 JKK=1,NSUPCE + WCURR(JKK)=1.0D0 + DO 60 IKK=1,NSUPCE + WCURR(JKK)=WCURR(JKK)-PROCEL(IKK,JKK)*PSSW(JKK) + 60 CONTINUE + 65 CONTINUE +* + ISTART=1 + TEST=0.0D0 + ITER=0 + 70 ITER=ITER+1 + IF(ITER.GT.MAXIT) THEN + WRITE(6,'(/47H SYBJJ0: *** WARNING *** MAXIMUM NUMBER OF ITER, + 1 15HATIONS REACHED.)') + GO TO 190 + ENDIF + IT3=MOD(ITER,3)+1 + IT2=MOD(ITER-1,3)+1 + IT1=MOD(ITER-2,3)+1 + DO 80 I=1,NSUPCE + CITR(IT3,I)=CIT0(I) + 80 CONTINUE +*---- +* COMPUTE PSSW * J(-) CONTRIBUTION +*---- + DO 95 IKK=1,NSUPCE + DO 90 JKK=1,NSUPCE + PSS=PROCEL(IKK,JKK)*PSSW(JKK) + CITR(IT3,IKK)=CITR(IT3,IKK)+PSS*CITR(IT2,JKK) + 90 CONTINUE + 95 CONTINUE +*---- +* NORMALIZATION +*---- + S1=0.0D0 + S2=0.0D0 + DO 100 I=1,NSUPCE + S1=S1+WCURR(I)*CITR(IT3,I) + S2=S2+CIT0(I) + 100 CONTINUE + ZNORM=S2/S1 + IF(ZNORM.LT.0.0D0) ZNORM=1.0D0 + DO 110 I=1,NSUPCE + CITR(IT3,I)=CITR(IT3,I)*ZNORM + 110 CONTINUE +*---- +* ONE/TWO PARAMETER ACCELERATION +*---- + ALP=1.0D0 + BET=0.0D0 + LOGTES=(1+MOD(ITER-ISTART,ICL1+ICL2).GT.ICL1) + IF(LOGTES) THEN + DO 135 IKK=1,NSUPCE + AITR(1,IKK)=CITR(IT3,IKK)-CITR(IT2,IKK) + AITR(2,IKK)=CITR(IT2,IKK)-CITR(IT1,IKK) + DO 130 JKK=1,NSUPCE + PSS=PROCEL(IKK,JKK)*PSSW(JKK) + AITR(1,IKK)=AITR(1,IKK)-PSS*(CITR(IT3,JKK)-CITR(IT2,JKK)) + AITR(2,IKK)=AITR(2,IKK)-PSS*(CITR(IT2,JKK)-CITR(IT1,JKK)) + 130 CONTINUE + 135 CONTINUE + IF((LACCFC.EQ.1).OR.(MOD(ITER-ISTART,ICL1+ICL2).EQ.ICL1)) THEN + S1=0.0D0 + S2=0.0D0 + DO 140 I=1,NSUPCE + S1=S1+(CITR(IT3,I)-CITR(IT2,I))*AITR(1,I) + S2=S2+AITR(1,I)*AITR(1,I) + 140 CONTINUE + IF(S2.EQ.0.0D0) THEN + ISTART=ITER+1 + ELSE + ALP=S1/S2 + IF(ALP.LE.0.0D0) THEN + ISTART=ITER+1 + ALP=1.0D0 + ENDIF + ENDIF + DO 150 I=1,NSUPCE + CITR(IT3,I)=CITR(IT2,I)+ALP*(CITR(IT3,I)-CITR(IT2,I)) + 150 CONTINUE + ELSE IF(LACCFC.EQ.2) THEN + S1=0.0D0 + S2=0.0D0 + S3=0.0D0 + S4=0.0D0 + S5=0.0D0 + DO 160 I=1,NSUPCE + S1=S1+(CITR(IT3,I)-CITR(IT2,I))*AITR(1,I) + S2=S2+AITR(1,I)*AITR(1,I) + S3=S3+(CITR(IT3,I)-CITR(IT2,I))*AITR(2,I) + S4=S4+AITR(1,I)*AITR(2,I) + S5=S5+AITR(2,I)*AITR(2,I) + 160 CONTINUE + DET=S2*S5-S4*S4 + IF(DET.EQ.0.0D0) THEN + ISTART=ITER+1 + ELSE + ALP=(S5*S1-S4*S3)/DET + BET=(S2*S3-S4*S1)/DET + IF(ALP.LE.0.0D0) THEN + ISTART=ITER+1 + ALP=1.0D0 + BET=0.0D0 + ENDIF + ENDIF + DO 170 I=1,NSUPCE + CITR(IT3,I)=CITR(IT2,I)+ALP*(CITR(IT3,I)-CITR(IT2,I))+ + 1 BET*(CITR(IT2,I)-CITR(IT1,I)) + 170 CONTINUE + ENDIF + ENDIF +*---- +* CHECK THE CONVERGENCE ERROR +*---- + ERR1=0.0D0 + ERR2=0.0D0 + DO 180 I=1,NSUPCE + ERR1=MAX(ERR1,ABS(CITR(IT3,I)-CITR(IT2,I))) + ERR2=MAX(ERR2,ABS(CITR(IT3,I))) + 180 CONTINUE + IF(IMPX.GT.3) WRITE(6,'(30H SYBJJ0: CURRENT ITERATION NB.,I4, + 1 7H ERROR=,1P,E10.3,5H OVER,E10.3,15H NORMALIZATION=,E10.3, + 2 14H ACCELERATION=,2E11.3,1H.)') ITER,ERR1,ERR2,ZNORM,ALP, + 3 BET/ALP + IF(ITER.EQ.1) TEST=ERR1/ERR2 + IF((ITER.GT.20).AND.(ERR1/ERR2.GT.TEST)) CALL XABORT('SYBJJ0: ' + 1 //'CONVERGENCE FAILURE.') + IF(LOGTES.OR.(ERR1.GT.EPSJ*ERR2)) GO TO 70 + IF(IMPX.GT.2) WRITE(6,'(37H SYBJJ0: CURRENT CONVERGENCE AT ITERA, + 1 8HTION NB.,I4,7H ERROR=,1P,E10.3,5H OVER,E10.3,1H.)') ITER,ERR1, + 2 ERR2 +* + 190 DO 200 I=1,IPAS + FUNKNO(I)=0.0 + 200 CONTINUE + DO 210 I=1,NSUPCE + FUNKNO(IPAS+I)=REAL(CITR(IT3,I)) + 210 CONTINUE +*---- +* COMPUTE ( PISW * J(-) ) + ( PIJW * Q(*) ) CONTRIBUTION +*---- + DO 240 IKK=1,NSUPCE + I1P=NMC(IKK) + I2=NMC(IKK+1)-I1P + DO 230 J=1,I2 + FUNKNO(I1P+J)=FUNKNO(I1P+J)+PISW(I1P+J)*FUNKNO(IPAS+IKK) + DO 220 I=1,I2 + PIJ=PIJW(INDPIJ(IKK)+(I-1)*I2+J) + FUNKNO(I1P+J)=FUNKNO(I1P+J)+PIJ*SUNKNO(I1P+I) + 220 CONTINUE + 230 CONTINUE + 240 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(WCURR) + DEALLOCATE(AITR,CIT0,CITR) + DEALLOCATE(INDPIJ) + RETURN + END diff --git a/Dragon/src/SYBJJ1.f b/Dragon/src/SYBJJ1.f new file mode 100644 index 0000000..a342976 --- /dev/null +++ b/Dragon/src/SYBJJ1.f @@ -0,0 +1,370 @@ +*DECK SYBJJ1 + SUBROUTINE SYBJJ1 (IPAS,NMCEL,NMERGE,NGEN,NPIJ,NPIS,EPSJ,NUNKNO, + 1 FUNKNO,SUNKNO,IMPX,NCOUR,XX,YY,NMC,IFR,ALB,INUM,IGEN,PIJW,PISW, + 2 PSJW,PSSW) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the neutron flux and interface currents in a 2-D Cartesian +* or hexagonal assembly using the current iteration method with Roth +* approximation. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPAS total number of regions. +* NMCEL total number of cells in the domain. +* NMERGE total number of merged cells for which specific values +* of the neutron flux and reactions rates are required. +* Many cells with different position in the domain can +* be merged before the neutron flux calculation if they +* own the same generating cell. Equal to the total number +* of distinct out-currents (NMERGE.le.NMCEL). +* NGEN total number of generating cells. A generating cell is +* defined by its material and dimensions, irrespective of +* its position in the domain (NGEN.le.NMERGE). +* NPIJ size of cellwise scattering-reduced collision probability +* matrices. +* NPIS size of cellwise scattering-reduced escape probability +* matrices. +* EPSJ stopping criterion for flux-current iterations. +* NUNKNO total number of unknowns in vectors SUNKNO and FUNKNO. +* SUNKNO input source vector. +* IMPX print flag (equal to 0 for no print). +* NCOUR number of incoming currents (=4 Cartesian lattice; +* =6 hexagonal lattice). +* XX X-thickness of the generating cells. +* YY Y-thickness of the generating cells. +* NMC offset of the first volume in each generating cell. +* IFR index-number of in-currents. +* ALB transmission/albedo associated with each in-current. +* Note: IFR and ALB contains information to rebuild the +* geometrical 'A' matrix. +* INUM index-number of the merged cell associated to each cell. +* IGEN index-number of the generating cell associated with each +* merged cell. +* PIJW cellwise scattering-reduced collision probability matrices. +* PISW cellwise scattering-reduced escape probability matrices. +* PSJW cellwise scattering-reduced collision probability matrices +* for incoming neutrons. +* PSSW cellwise scattering-reduced transmission probability matrices. +* +*Parameters: input/output +* FUNKNO unknown vector. +* +*----------------------------------------------------------------------- +* + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IPAS,NMCEL,NMERGE,NGEN,NPIJ,NPIS,NUNKNO,IMPX,NCOUR, + 1 NMC(NGEN+1),IFR(NCOUR*NMCEL),INUM(NMCEL),IGEN(NMERGE) + REAL EPSJ,FUNKNO(NUNKNO),SUNKNO(NUNKNO),XX(NGEN),YY(NGEN), + 1 ALB(NCOUR*NMCEL),PIJW(NPIJ),PISW(NPIS),PSJW(NPIS),PSSW(NGEN) +*---- +* LOCAL VARIABLES +*---- + REAL PIJ,PIS + DOUBLE PRECISION PIBB(6) + LOGICAL LOGTES + PARAMETER (MAXIT=400,LACCFC=2,ICL1=3,ICL2=3) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, DIMENSION(:), POINTER :: INDPIJ,INDNMC + DOUBLE PRECISION, DIMENSION(:), POINTER :: CIT0 + DOUBLE PRECISION, DIMENSION(:,:), POINTER :: CITR,AITR + DOUBLE PRECISION, DIMENSION(:), POINTER :: WCURR +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(INDPIJ(NGEN),INDNMC(NMERGE)) + ALLOCATE(CITR(3,NMERGE),CIT0(NMERGE),AITR(2,NMERGE)) + ALLOCATE(WCURR(NMERGE)) +* + IPIJ=0 + DO 10 JKG=1,NGEN + J2=NMC(JKG+1)-NMC(JKG) + INDPIJ(JKG)=IPIJ + IPIJ=IPIJ+J2*J2 + 10 CONTINUE + KNMC=0 + DO 20 JKK=1,NMERGE + JKG=IGEN(JKK) + J2=NMC(JKG+1)-NMC(JKG) + INDNMC(JKK)=KNMC + KNMC=KNMC+J2 + 20 CONTINUE +* + DO 30 I=1,NMERGE + WCURR(I)=1.0D0 + CIT0(I)=0.0D0 + CITR(1,I)=FUNKNO(IPAS+I) + 30 CONTINUE +*---- +* COMPUTE PSJW * Q(*) CONTRIBUTION +*---- + DO 45 IKK=1,NMERGE + IKG=IGEN(IKK) + I1P=NMC(IKG) + I2=NMC(IKG+1)-I1P + KNMC=INDNMC(IKK) + DO 40 I=1,I2 + CIT0(IKK)=CIT0(IKK)+PSJW(I1P+I)*SUNKNO(KNMC+I) + 40 CONTINUE + 45 CONTINUE +*---- +* COMPUTE NORMALIZATION VECTOR WCURR +*---- + DO 65 ICEL=1,NMCEL + IKK=INUM(ICEL) + IS=NCOUR*(ICEL-1) + IKG=IGEN(IKK) + IF(NCOUR.EQ.4) THEN + A=XX(IKG) + B=YY(IKG) + DEN1=2.0D0*(A+B) + PIBB(1)=B/DEN1 + PIBB(2)=B/DEN1 + PIBB(3)=A/DEN1 + PIBB(4)=A/DEN1 + ELSE + DO 50 JC=1,NCOUR + PIBB(JC)=1.0D0/6.0D0 + 50 CONTINUE + ENDIF + DO 60 JC=1,NCOUR + J1=IFR(IS+JC) + WCURR(J1)=WCURR(J1)-PSSW(IKG)*PIBB(JC)*ALB(IS+JC) + 60 CONTINUE + 65 CONTINUE +* + ISTART=1 + TEST=0.0D0 + ITER=0 + 70 ITER=ITER+1 + IF(ITER.GT.MAXIT) THEN + WRITE(6,'(/47H SYBJJ1: *** WARNING *** MAXIMUM NUMBER OF ITER, + 1 15HATIONS REACHED.)') + GO TO 190 + ENDIF + IT3=MOD(ITER,3)+1 + IT2=MOD(ITER-1,3)+1 + IT1=MOD(ITER-2,3)+1 + DO 80 I=1,NMERGE + CITR(IT3,I)=CIT0(I) + 80 CONTINUE +*---- +* COMPUTE PSSW * J(-) CONTRIBUTION +*---- + DO 95 ICEL=1,NMCEL + IKK=INUM(ICEL) + IS=NCOUR*(ICEL-1) + IKG=IGEN(IKK) + IF(NCOUR.EQ.4) THEN + A=XX(IKG) + B=YY(IKG) + DEN1=2.0D0*(A+B) + PIBB(1)=B/DEN1 + PIBB(2)=B/DEN1 + PIBB(3)=A/DEN1 + PIBB(4)=A/DEN1 + ELSE + DO 85 JC=1,NCOUR + PIBB(JC)=1.0D0/6.0D0 + 85 CONTINUE + ENDIF + DO 90 JC=1,NCOUR + J1=IFR(IS+JC) + PSS=PSSW(IKG)*PIBB(JC) + CITR(IT3,IKK)=CITR(IT3,IKK)+PSS*ALB(IS+JC)*CITR(IT2,J1) + 90 CONTINUE + 95 CONTINUE +*---- +* NORMALIZATION +*---- + S1=0.0D0 + S2=0.0D0 + DO 100 I=1,NMERGE + S1=S1+WCURR(I)*CITR(IT3,I) + S2=S2+CIT0(I) + 100 CONTINUE + ZNORM=S2/S1 + IF(ZNORM.LT.0.0D0) ZNORM=1.0D0 + DO 110 I=1,NMERGE + CITR(IT3,I)=CITR(IT3,I)*ZNORM + 110 CONTINUE +*---- +* ONE/TWO PARAMETER ACCELERATION +*---- + ALP=1.0D0 + BET=0.0D0 + LOGTES=(1+MOD(ITER-ISTART,ICL1+ICL2).GT.ICL1) + IF(LOGTES) THEN + DO 120 I=1,NMERGE + AITR(1,I)=CITR(IT3,I)-CITR(IT2,I) + AITR(2,I)=CITR(IT2,I)-CITR(IT1,I) + 120 CONTINUE + DO 135 ICEL=1,NMCEL + IKK=INUM(ICEL) + IS=NCOUR*(ICEL-1) + IKG=IGEN(IKK) + IF(NCOUR.EQ.4) THEN + A=XX(IKG) + B=YY(IKG) + DEN1=2.0D0*(A+B) + PIBB(1)=B/DEN1 + PIBB(2)=B/DEN1 + PIBB(3)=A/DEN1 + PIBB(4)=A/DEN1 + ELSE + DO 125 JC=1,NCOUR + PIBB(JC)=1.0D0/6.0D0 + 125 CONTINUE + ENDIF + DO 130 JC=1,NCOUR + J1=IFR(IS+JC) + PSS=PSSW(IKG)*PIBB(JC)*ALB(IS+JC) + AITR(1,IKK)=AITR(1,IKK)-PSS*(CITR(IT3,J1)-CITR(IT2,J1)) + AITR(2,IKK)=AITR(2,IKK)-PSS*(CITR(IT2,J1)-CITR(IT1,J1)) + 130 CONTINUE + 135 CONTINUE + IF((LACCFC.EQ.1).OR.(MOD(ITER-ISTART,ICL1+ICL2).EQ.ICL1)) THEN + S1=0.0D0 + S2=0.0D0 + DO 140 I=1,NMERGE + S1=S1+(CITR(IT3,I)-CITR(IT2,I))*AITR(1,I) + S2=S2+AITR(1,I)*AITR(1,I) + 140 CONTINUE + IF(S2.EQ.0.0D0) THEN + ISTART=ITER+1 + ELSE + ALP=S1/S2 + IF(ALP.LE.0.0D0) THEN + ISTART=ITER+1 + ALP=1.0D0 + ENDIF + ENDIF + DO 150 I=1,NMERGE + CITR(IT3,I)=CITR(IT2,I)+ALP*(CITR(IT3,I)-CITR(IT2,I)) + 150 CONTINUE + ELSE IF(LACCFC.EQ.2) THEN + S1=0.0D0 + S2=0.0D0 + S3=0.0D0 + S4=0.0D0 + S5=0.0D0 + DO 160 I=1,NMERGE + S1=S1+(CITR(IT3,I)-CITR(IT2,I))*AITR(1,I) + S2=S2+AITR(1,I)*AITR(1,I) + S3=S3+(CITR(IT3,I)-CITR(IT2,I))*AITR(2,I) + S4=S4+AITR(1,I)*AITR(2,I) + S5=S5+AITR(2,I)*AITR(2,I) + 160 CONTINUE + DET=S2*S5-S4*S4 + IF(DET.EQ.0.0D0) THEN + ISTART=ITER+1 + ELSE + ALP=(S5*S1-S4*S3)/DET + BET=(S2*S3-S4*S1)/DET + IF(ALP.LE.0.0D0) THEN + ISTART=ITER+1 + ALP=1.0D0 + BET=0.0D0 + ENDIF + ENDIF + DO 170 I=1,NMERGE + CITR(IT3,I)=CITR(IT2,I)+ALP*(CITR(IT3,I)-CITR(IT2,I))+ + 1 BET*(CITR(IT2,I)-CITR(IT1,I)) + 170 CONTINUE + ENDIF + ENDIF +*---- +* CHECK THE CONVERGENCE ERROR +*---- + ERR1=0.0D0 + ERR2=0.0D0 + DO 180 I=1,NMERGE + ERR1=MAX(ERR1,ABS(CITR(IT3,I)-CITR(IT2,I))) + ERR2=MAX(ERR2,ABS(CITR(IT3,I))) + 180 CONTINUE + IF(IMPX.GT.3) WRITE(6,'(30H SYBJJ1: CURRENT ITERATION NB.,I4, + 1 7H ERROR=,1P,E10.3,5H OVER,E10.3,15H NORMALIZATION=,E10.3, + 2 14H ACCELERATION=,2E11.3,1H.)') ITER,ERR1,ERR2,ZNORM,ALP, + 3 BET/ALP + IF(ITER.EQ.1) TEST=ERR1/ERR2 + IF((ITER.GT.20).AND.(ERR1/ERR2.GT.TEST)) CALL XABORT('SYBJJ1: ' + 1 //'CONVERGENCE FAILURE.') + IF(LOGTES.OR.(ERR1.GT.EPSJ*ERR2)) GO TO 70 + IF(IMPX.GT.2) WRITE(6,'(37H SYBJJ1: CURRENT CONVERGENCE AT ITERA, + 1 8HTION NB.,I4,7H ERROR=,1P,E10.3,5H OVER,E10.3,1H.)') ITER,ERR1, + 2 ERR2 +* + 190 DO 200 I=1,IPAS + FUNKNO(I)=0.0 + 200 CONTINUE + DO 210 I=1,NMERGE + FUNKNO(IPAS+I)=REAL(CITR(IT3,I)) + 210 CONTINUE +*---- +* COMPUTE PISW * J(-) CONTRIBUTION +*---- + DO 250 ICEL=1,NMCEL + IKK=INUM(ICEL) + IS=NCOUR*(ICEL-1) + IKG=IGEN(IKK) + IF(NCOUR.EQ.4) THEN + A=XX(IKG) + B=YY(IKG) + DEN1=2.0D0*(A+B) + PIBB(1)=B/DEN1 + PIBB(2)=B/DEN1 + PIBB(3)=A/DEN1 + PIBB(4)=A/DEN1 + ELSE + DO 220 JC=1,NCOUR + PIBB(JC)=1.0D0/6.0D0 + 220 CONTINUE + ENDIF + I1P=NMC(IKG) + I2=NMC(IKG+1)-I1P + KNMC=INDNMC(IKK) + DO 240 J=1,I2 + DO 230 JC=1,NCOUR + J1=IFR(IS+JC) + PIS=PISW(I1P+J)*REAL(PIBB(JC)) + FUNKNO(KNMC+J)=FUNKNO(KNMC+J)+PIS*ALB(IS+JC)*FUNKNO(IPAS+J1) + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE +*---- +* COMPUTE PIJW * Q(*) CONTRIBUTION +*---- + DO 280 IKK=1,NMERGE + IKG=IGEN(IKK) + I2=NMC(IKG+1)-NMC(IKG) + KNMC=INDNMC(IKK) + DO 270 I=1,I2 + DO 260 J=1,I2 + PIJ=PIJW(INDPIJ(IKG)+(I-1)*I2+J) + FUNKNO(KNMC+J)=FUNKNO(KNMC+J)+PIJ*SUNKNO(KNMC+I) + 260 CONTINUE + 270 CONTINUE + 280 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(WCURR) + DEALLOCATE(AITR,CIT0,CITR) + DEALLOCATE(INDNMC,INDPIJ) + RETURN + END diff --git a/Dragon/src/SYBJJ2.f b/Dragon/src/SYBJJ2.f new file mode 100644 index 0000000..76dffa4 --- /dev/null +++ b/Dragon/src/SYBJJ2.f @@ -0,0 +1,343 @@ +*DECK SYBJJ2 + SUBROUTINE SYBJJ2 (IPAS,NMCEL,NMERGE,NGEN,IJAT,NPIJ,NPIS,EPSJ, + 1 NUNKNO,FUNKNO,SUNKNO,IMPX,NCOUR,NMC,IFR,ALB,INUM,MIX,DVX,IGEN, + 2 PIJW,PISW,PSJW,PSSW) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the neutron flux and interface currents in a 2-D Cartesian +* or hexagonal assembly using the current iteration method with +* Roth X 4, DP0 or DP1 approximation. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPAS total number of regions. +* NMCEL total number of cells in the domain. +* NMERGE total number of merged cells for which specific values +* of the neutron flux and reactions rates are required. +* Many cells with different position in the domain can +* be merged before the neutron flux calculation if they +* own the same generating cell (NMERGE.le.NMCEL). +* NGEN total number of generating cells. A generating cell is +* defined by its material and dimensions, irrespective of +* its position in the domain (NGEN.le.NMERGE). +* IJAT total number of distinct out-currents. +* NPIJ size of cellwise scattering-reduced collision probability +* matrices. +* NPIS size of cellwise scattering-reduced escape probability +* matrices. +* EPSJ stopping criterion for flux-current iterations. +* NUNKNO total number of unknowns in vectors SUNKNO and FUNKNO. +* SUNKNO input source vector. +* IMPX print flag (equal to 0 for no print). +* NCOUR number of incoming currents (=4 Cartesian lattice; +* =6 hexagonal lattice). +* NMC offset of the first volume in each generating cell. +* IFR index-number of in-currents. +* ALB transmission/albedo associated with each in-current. +* INUM index-number of the merged cell associated to each cell. +* MIX index-number of out-currents. +* DVX weight associated with each out-current. +* Note: IFR, ALB, MIX and DVX contains information to rebuild +* the geometrical 'A' matrix. +* IGEN index-number of the generating cell associated with each +* merged cell. +* PIJW cellwise scattering-reduced collision probability matrices. +* PISW cellwise scattering-reduced escape probability matrices. +* PSJW cellwise scattering-reduced collision probability matrices +* for incoming neutrons. +* PSSW cellwise scattering-reduced transmission probability +* matrices. +* +*Parameters: input/output +* FUNKNO unknown vector. +* +*----------------------------------------------------------------------- +* + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IPAS,NMCEL,NMERGE,NGEN,IJAT,NPIJ,NPIS,NUNKNO,IMPX,NCOUR, + 1 NMC(NGEN+1),IFR(NCOUR*NMCEL),INUM(NMCEL),MIX(NCOUR*NMERGE), + 2 IGEN(NMERGE) + REAL EPSJ,FUNKNO(NUNKNO),SUNKNO(NUNKNO),ALB(NCOUR*NMCEL), + 1 DVX(NCOUR*NMERGE),PIJW(NPIJ),PISW(NCOUR*NPIS),PSJW(NCOUR*NPIS), + 2 PSSW(NGEN*NCOUR*NCOUR) +*---- +* LOCAL VARIABLES +*---- + REAL PIJ,PIS + LOGICAL LOGTES + PARAMETER (MAXIT=400,LACCFC=2,ICL1=3,ICL2=3) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, DIMENSION(:), POINTER :: INDPIJ,INDNMC + DOUBLE PRECISION, DIMENSION(:), POINTER :: CIT0 + DOUBLE PRECISION, DIMENSION(:,:), POINTER :: CITR,AITR + DOUBLE PRECISION, DIMENSION(:), POINTER :: WCURR +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(INDPIJ(NGEN),INDNMC(NMERGE)) + ALLOCATE(CITR(3,IJAT),CIT0(IJAT),AITR(2,IJAT)) + ALLOCATE(WCURR(IJAT)) +* + IPIJ=0 + DO 10 JKG=1,NGEN + J2=NMC(JKG+1)-NMC(JKG) + INDPIJ(JKG)=IPIJ + IPIJ=IPIJ+J2*J2 + 10 CONTINUE + KNMC=0 + DO 20 JKK=1,NMERGE + JKG=IGEN(JKK) + J2=NMC(JKG+1)-NMC(JKG) + INDNMC(JKK)=KNMC + KNMC=KNMC+J2 + 20 CONTINUE +* + DO 30 I=1,IJAT + WCURR(I)=1.0D0 + CIT0(I)=0.0D0 + CITR(1,I)=FUNKNO(IPAS+I) + 30 CONTINUE +*---- +* COMPUTE PSJW * Q(*) CONTRIBUTION +*---- + DO 42 IKK=1,NMERGE + IKG=IGEN(IKK) + I1P=NMC(IKG) + I2=NMC(IKG+1)-I1P + IT=NCOUR*(IKK-1) + KNMC=INDNMC(IKK) + DO 41 I=1,I2 + DO 40 IC=1,NCOUR + JCC=MIX(IT+IC) + PBJ=PSJW(I1P*NCOUR+(I-1)*NCOUR+IC) + CIT0(JCC)=CIT0(JCC)+PBJ*DVX(IT+IC)*SUNKNO(KNMC+I) + 40 CONTINUE + 41 CONTINUE + 42 CONTINUE +*---- +* COMPUTE NORMALIZATION VECTOR WCURR +*---- + DO 52 ICEL=1,NMCEL + IKK=INUM(ICEL) + IT=NCOUR*(IKK-1) + IS=NCOUR*(ICEL-1) + IKG=IGEN(IKK) + IPSS=(IKG-1)*NCOUR*NCOUR + DO 51 JC=1,NCOUR + J1=IFR(IS+JC) + DO 50 IC=1,NCOUR + PSS=PSSW(IPSS+(JC-1)*NCOUR+IC) + WCURR(J1)=WCURR(J1)-PSS*ALB(IS+JC)*DVX(IT+IC) + 50 CONTINUE + 51 CONTINUE + 52 CONTINUE +* + ISTART=1 + TEST=0.0D0 + ITER=0 + 70 ITER=ITER+1 + IF(ITER.GT.MAXIT) THEN + WRITE(6,'(/47H SYBJJ2: *** WARNING *** MAXIMUM NUMBER OF ITER, + 1 15HATIONS REACHED.)') + GO TO 190 + ENDIF + IT3=MOD(ITER,3)+1 + IT2=MOD(ITER-1,3)+1 + IT1=MOD(ITER-2,3)+1 + DO 80 I=1,IJAT + CITR(IT3,I)=CIT0(I) + 80 CONTINUE +*---- +* COMPUTE PSSW * J(-) CONTRIBUTION +*---- + DO 92 ICEL=1,NMCEL + IKK=INUM(ICEL) + IT=NCOUR*(IKK-1) + IS=NCOUR*(ICEL-1) + IKG=IGEN(IKK) + IPSS=(IKG-1)*NCOUR*NCOUR + DO 91 JC=1,NCOUR + J1=IFR(IS+JC) + DO 90 IC=1,NCOUR + J2=MIX(IT+IC) + PSS=PSSW(IPSS+(JC-1)*NCOUR+IC) + CITR(IT3,J2)=CITR(IT3,J2)+PSS*ALB(IS+JC)*DVX(IT+IC)*CITR(IT2,J1) + 90 CONTINUE + 91 CONTINUE + 92 CONTINUE +*---- +* NORMALIZATION +*---- + S1=0.0D0 + S2=0.0D0 + DO 100 I=1,IJAT + S1=S1+WCURR(I)*CITR(IT3,I) + S2=S2+CIT0(I) + 100 CONTINUE + ZNORM=S2/S1 + IF(ZNORM.LT.0.0D0) ZNORM=1.0D0 + DO 110 I=1,IJAT + CITR(IT3,I)=CITR(IT3,I)*ZNORM + 110 CONTINUE +*---- +* ONE/TWO PARAMETER ACCELERATION +*---- + ALP=1.0D0 + BET=0.0D0 + LOGTES=(1+MOD(ITER-ISTART,ICL1+ICL2).GT.ICL1) + IF(LOGTES) THEN + DO 120 I=1,IJAT + AITR(1,I)=CITR(IT3,I)-CITR(IT2,I) + AITR(2,I)=CITR(IT2,I)-CITR(IT1,I) + 120 CONTINUE + DO 132 ICEL=1,NMCEL + IKK=INUM(ICEL) + IT=NCOUR*(IKK-1) + IS=NCOUR*(ICEL-1) + IKG=IGEN(IKK) + IPSS=(IKG-1)*NCOUR*NCOUR + DO 131 JC=1,NCOUR + J1=IFR(IS+JC) + DO 130 IC=1,NCOUR + J2=MIX(IT+IC) + PSS=PSSW(IPSS+(JC-1)*NCOUR+IC)*ALB(IS+JC)*DVX(IT+IC) + AITR(1,J2)=AITR(1,J2)-PSS*(CITR(IT3,J1)-CITR(IT2,J1)) + AITR(2,J2)=AITR(2,J2)-PSS*(CITR(IT2,J1)-CITR(IT1,J1)) + 130 CONTINUE + 131 CONTINUE + 132 CONTINUE + IF((LACCFC.EQ.1).OR.(MOD(ITER-ISTART,ICL1+ICL2).EQ.ICL1)) THEN + S1=0.0D0 + S2=0.0D0 + DO 140 I=1,IJAT + S1=S1+(CITR(IT3,I)-CITR(IT2,I))*AITR(1,I) + S2=S2+AITR(1,I)*AITR(1,I) + 140 CONTINUE + IF(S2.EQ.0.0D0) THEN + ISTART=ITER+1 + ELSE + ALP=S1/S2 + IF(ALP.LE.0.0D0) THEN + ISTART=ITER+1 + ALP=1.0D0 + ENDIF + ENDIF + DO 150 I=1,IJAT + CITR(IT3,I)=CITR(IT2,I)+ALP*(CITR(IT3,I)-CITR(IT2,I)) + 150 CONTINUE + ELSE IF(LACCFC.EQ.2) THEN + S1=0.0D0 + S2=0.0D0 + S3=0.0D0 + S4=0.0D0 + S5=0.0D0 + DO 160 I=1,IJAT + S1=S1+(CITR(IT3,I)-CITR(IT2,I))*AITR(1,I) + S2=S2+AITR(1,I)*AITR(1,I) + S3=S3+(CITR(IT3,I)-CITR(IT2,I))*AITR(2,I) + S4=S4+AITR(1,I)*AITR(2,I) + S5=S5+AITR(2,I)*AITR(2,I) + 160 CONTINUE + DET=S2*S5-S4*S4 + IF(DET.EQ.0.0D0) THEN + ISTART=ITER+1 + ELSE + ALP=(S5*S1-S4*S3)/DET + BET=(S2*S3-S4*S1)/DET + IF(ALP.LE.0.0D0) THEN + ISTART=ITER+1 + ALP=1.0D0 + BET=0.0D0 + ENDIF + ENDIF + DO 170 I=1,IJAT + CITR(IT3,I)=CITR(IT2,I)+ALP*(CITR(IT3,I)-CITR(IT2,I))+ + 1 BET*(CITR(IT2,I)-CITR(IT1,I)) + 170 CONTINUE + ENDIF + ENDIF +*---- +* CHECK THE CONVERGENCE ERROR +*---- + ERR1=0.0D0 + ERR2=0.0D0 + DO 180 I=1,IJAT + ERR1=MAX(ERR1,ABS(CITR(IT3,I)-CITR(IT2,I))) + ERR2=MAX(ERR2,ABS(CITR(IT3,I))) + 180 CONTINUE + IF(IMPX.GT.3) WRITE(6,'(30H SYBJJ2: CURRENT ITERATION NB.,I4, + 1 7H ERROR=,1P,E10.3,5H OVER,E10.3,15H NORMALIZATION=,E10.3, + 2 14H ACCELERATION=,2E11.3,1H.)') ITER,ERR1,ERR2,ZNORM,ALP, + 3 BET/ALP + IF(ITER.EQ.1) TEST=ERR1/ERR2 + IF((ITER.GT.20).AND.(ERR1/ERR2.GT.TEST)) THEN + WRITE(6,'(/45H SYBJJ2: *** WARNING *** CONVERGENCE DIFFICUL, + 1 5HTIES.)') + GO TO 190 + ENDIF + IF(LOGTES.OR.(ERR1.GT.EPSJ*ERR2)) GO TO 70 + IF(IMPX.GT.2) WRITE(6,'(37H SYBJJ2: CURRENT CONVERGENCE AT ITERA, + 1 8HTION NB.,I4,7H ERROR=,1P,E10.3,5H OVER,E10.3,1H.)') ITER,ERR1, + 2 ERR2 +* + 190 DO 200 I=1,IPAS + FUNKNO(I)=0.0 + 200 CONTINUE + DO 210 I=1,IJAT + FUNKNO(IPAS+I)=REAL(CITR(IT3,I)) + 210 CONTINUE +*---- +* COMPUTE PISW * J(-) CONTRIBUTION +*---- + DO 240 ICEL=1,NMCEL + IKK=INUM(ICEL) + IS=NCOUR*(ICEL-1) + IKG=IGEN(IKK) + I1P=NMC(IKG) + I2=NMC(IKG+1)-I1P + KNMC=INDNMC(IKK) + DO 230 J=1,I2 + DO 220 JC=1,NCOUR + J1=IFR(IS+JC) + PIS=PISW(I1P*NCOUR+(JC-1)*I2+J) + FUNKNO(KNMC+J)=FUNKNO(KNMC+J)+PIS*ALB(IS+JC)*FUNKNO(IPAS+J1) + 220 CONTINUE + 230 CONTINUE + 240 CONTINUE +*---- +* COMPUTE PIJW * Q(*) CONTRIBUTION +*---- + DO 270 IKK=1,NMERGE + IKG=IGEN(IKK) + I2=NMC(IKG+1)-NMC(IKG) + KNMC=INDNMC(IKK) + DO 260 I=1,I2 + DO 250 J=1,I2 + PIJ=PIJW(INDPIJ(IKG)+(I-1)*I2+J) + FUNKNO(KNMC+J)=FUNKNO(KNMC+J)+PIJ*SUNKNO(KNMC+I) + 250 CONTINUE + 260 CONTINUE + 270 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(WCURR) + DEALLOCATE(AITR,CIT0,CITR) + DEALLOCATE(INDNMC,INDPIJ) + RETURN + END diff --git a/Dragon/src/SYBPRX.f b/Dragon/src/SYBPRX.f new file mode 100644 index 0000000..563474a --- /dev/null +++ b/Dragon/src/SYBPRX.f @@ -0,0 +1,72 @@ +*DECK SYBPRX + SUBROUTINE SYBPRX (IND,NCOUR,IPAS,IKG,SIGT,SIGW,P,PIS,PSJ,PSS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Print the cell-wise collision probabilities in SYBRX- modules. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IND reduction flag (1/2: matrix reduction off/on). +* NCOUR total number of surfaces. +* IPAS total number of volumes. +* IKG generating cell indices. +* SIGT total macroscopic cross sections. +* SIGW scattering macroscopic cross sections. +* P reduced collision probabilities. +* PIS volume to surface probabilities. +* PSJ surface to volume probabilities. +* PSS surface to surface probabilities. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IND,NCOUR,IPAS,IKG + REAL SIGT(IPAS),SIGW(IPAS),P(IPAS,IPAS),PIS(IPAS,NCOUR), + 1 PSJ(NCOUR,IPAS),PSS(NCOUR,NCOUR) +* + IF(IND.EQ.1) THEN + WRITE (6,100) IKG + WRITE (6,120) (SIGT(I),I=1,IPAS) + ELSE + WRITE (6,110) IKG + WRITE (6,120) (SIGT(I),I=1,IPAS) + WRITE (6,130) + WRITE (6,120) (SIGW(I),I=1,IPAS) + ENDIF + WRITE (6,'(/16H P(I,J) MATRIX :/)') + DO 10 I=1,IPAS + WRITE (6,120) (P(I,J),J=1,IPAS) +10 CONTINUE + WRITE (6,'(/16H PIS(I) MATRIX :/)') + DO 20 I=1,IPAS + WRITE (6,120) (PIS(I,J),J=1,NCOUR) +20 CONTINUE + WRITE (6,'(/16H PSJ(I) MATRIX :/)') + DO 30 I=1,IPAS + WRITE (6,120) (PSJ(J,I),J=1,NCOUR) +30 CONTINUE + WRITE (6,'(/13H PSS MATRIX :/)') + DO 40 I=1,NCOUR + WRITE (6,120) (PSS(I,J),J=1,NCOUR) +40 CONTINUE + WRITE (6,'(//)') + RETURN +100 FORMAT (/32H SYBPRX: NO SCATTERING REDUCTION/16H GENERATING CELL, + 1 3H NB,I4//35H TOTAL MACROSCOPIC CROSS SECTIONS :) +110 FORMAT (/29H SYBPRX: SCATTERING REDUCTION/19H GENERATING CELL NB, + 1 I4//35H TOTAL MACROSCOPIC CROSS SECTIONS :) +120 FORMAT (1X,1P,10E13.5) +130 FORMAT(/40H SCATTERING MACROSCOPIC CROSS SECTIONS :) + END diff --git a/Dragon/src/SYBRHL.f b/Dragon/src/SYBRHL.f new file mode 100644 index 0000000..5794b6a --- /dev/null +++ b/Dragon/src/SYBRHL.f @@ -0,0 +1,181 @@ +*DECK SYBRHL + SUBROUTINE SYBRHL(IPRT,NSOUT,NREG,G,PROB) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Stamm'ler normalisation of collision, escape and transmission +* probabilities. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPRT print parameter (equal to zero for no print). +* NSOUT number of surfaces. +* NREG number of regions. +* +*Parameters: input/output +* G surface and volume array on input and +* renormalization factors at output. +* PROB collision, escape and transmission probabilities on input +* and normalized collision, escape and transmission +* probabilities at output. +* +*Reference: +* R. Roy et.al., +* Normalization techniques for CP matrices, Physor-90, +* Marseille/France, v 2, p ix-40 (1990). +* A. Villarino, R.J.J.Stamm'ler and A.A.Ferri and J.J.Casal +* Helios: Angularly dependent collision probabilities E., +* Nucl.Sci.Eng. 112,16-31, 1992. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IPRT,NSOUT,NREG + REAL G(NSOUT+NREG),PROB((NSOUT+NREG)*(NSOUT*NREG+1)/2) +*---- +* LOCAL VARIABLES +*---- + INTEGER CPTLB,CPTAC,CTOT + PARAMETER (CPTLB=3, CPTAC=3, CTOT=CPTAC+CPTLB, IUNOUT=6, + 1 EPSCON=1.0E-6, NITMAX=20) + DOUBLE PRECISION WFSPAD,WFSP,NOM,DENOM,DMU + LOGICAL NOTCON + REAL, ALLOCATABLE, DIMENSION(:,:) :: WEIG +* + INDPOS(I,J)=MAX(I,J)*(MAX(I,J)-1)/2+MIN(I,J) +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(WEIG(NSOUT+NREG,3)) +*---- +* INITIALISATION OF WEIGHTS +*---- + NOTCON=.FALSE. + DO 10 IR=1,NSOUT+NREG + WEIG(IR,1)=0.0 + WEIG(IR,2)=0.5 + WEIG(IR,3)=0.5 + 10 CONTINUE +*---- +* MAIN ITERATION LOOP +*---- + IF(IPRT.GT.8) THEN + WRITE(IUNOUT,'(/30H SYBRHL: NORMALIZATION FACTORS)') + WRITE(IUNOUT,'(1X,A24)') 'ITER. MU ERROR ' + ENDIF + NIT=0 + 20 NIT=NIT+1 + IF(NIT.GT.NITMAX) THEN + NOTCON=.TRUE. + WRITE(IUNOUT,'(31H SYBRHL: WEIGHTS NOT CONVERGED.)') + GO TO 80 + ENDIF + DO 40 IR=1,NSOUT+NREG + WFSPAD=G(IR)+PROB(INDPOS(IR,IR))*WEIG(IR,3) + WFSP=PROB(INDPOS(IR,IR)) + DO 30 JR=1,NSOUT+NREG + WFSPAD=WFSPAD-WEIG(JR,3)*PROB(INDPOS(IR,JR)) + WFSP=WFSP+PROB(INDPOS(IR,JR)) + 30 CONTINUE + WEIG(IR,3)=REAL(WFSPAD/WFSP) + 40 CONTINUE +*---- +* ACCELERATION BY RESIDUAL MINIMIZATION +*---- + IF(MOD(NIT-1,CTOT).GE.CPTAC) THEN + NOM = 0.0D0 + DENOM = 0.0D0 + DO 50 IR=1,NSOUT+NREG + R1= WEIG(IR,2) - WEIG(IR,1) + R2= WEIG(IR,3) - WEIG(IR,2) + NOM = NOM + R1*(R2-R1) + DENOM = DENOM + (R2-R1)*(R2-R1) + 50 CONTINUE + IF(DENOM.EQ.0.0D0) THEN + DMU=1.0D0 + ELSE + DMU=-NOM/DENOM + ENDIF + ZMU=REAL(DMU) + IF(ZMU.GT.10.0 .OR. ZMU.LT.0.0) THEN + IF( IPRT.GT.2 ) WRITE(IUNOUT,'(I3,1P,G12.4,A)') NIT,ZMU, + > ' =MU / SYBRHL: NON ACCELERATION' + ZMU=1.0 + ENDIF + DO 60 IR=1,NSOUT+NREG + WEIG(IR,3)=WEIG(IR,2)+ZMU*(WEIG(IR,3)-WEIG(IR,2)) + WEIG(IR,2)=WEIG(IR,1)+ZMU*(WEIG(IR,2)-WEIG(IR,1)) + 60 CONTINUE + ELSE + ZMU = 1.0 + ENDIF +*---- +* CALCULATIONS OF SQUARE DISTANCE BETWEEN 2 ITERATIONS AND UPDATING +* OF THE SOLUTION +*---- + TOTCON = 0.0 + DO 70 IR=1,NSOUT+NREG + TMPCON=ABS(WEIG(IR,3)-WEIG(IR,2))/WEIG(IR,3) + TOTCON=MAX(TMPCON,TOTCON) + WEIG(IR,1)=WEIG(IR,2) + WEIG(IR,2)=WEIG(IR,3) + 70 CONTINUE + IF(IPRT.GT.8) WRITE(IUNOUT,'(I3,F9.5,E15.7)') NIT,ZMU,TOTCON +*---- +* CONVERGENCE TEST +*---- + IF(TOTCON.LT.EPSCON) GO TO 80 + GO TO 20 +*---- +* RENORMALIZE "PIJ" SYMMETRIC MATRIX +*---- + 80 IPRB=0 + DO 95 IR=1,NSOUT+NREG + G(IR)=WEIG(IR,1) + DO 90 JR=1,IR + IPRB=IPRB+1 + PROB(IPRB)=PROB(IPRB)*(WEIG(IR,1)+WEIG(JR,1)) + 90 CONTINUE + 95 CONTINUE +*---- +* PRINT WEIGHT FACTORS IF THERE IS A PROBLEM +*---- + IF(NOTCON .OR. (IPRT.GE.15)) THEN + WRITE(IUNOUT,'(24H SURFACE WEIGHTS FACTORS/)') + NSURC=1 + DO 100 IP =1,(9+NSOUT)/10 + NSURM=MIN(NSOUT,NSURC+9) + WRITE(IUNOUT,'(10X,10(A5,I6)/)') + > (' SUR ',IR,IR= NSURC, NSURM) + WRITE(IUNOUT,'(10H WEIGHT ,10F11.5)') + > (WEIG(IR,1),IR=NSURC,NSURM) + NSURC=NSURC+10 + 100 CONTINUE + WRITE(IUNOUT,'(24H VOLUME WEIGHTS FACTORS/)') + NVOLC=NSOUT+1 + DO 110 IP=1,(9+NREG)/10 + NVOLM=MIN(NSOUT+NREG,NVOLC+9) + WRITE(IUNOUT,'(10X,10(A5,I6)/)') + > (' VOL ',IR,IR=NVOLC-NSOUT,NVOLM-NSOUT) + WRITE(IUNOUT,'(10H WEIGHT ,10F11.5)') + > (WEIG(IR,1),IR=NVOLC,NVOLM) + NVOLC=NVOLC+10 + 110 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(WEIG) + RETURN + END diff --git a/Dragon/src/SYBRII.f b/Dragon/src/SYBRII.f new file mode 100644 index 0000000..2db117e --- /dev/null +++ b/Dragon/src/SYBRII.f @@ -0,0 +1,39 @@ +*DECK SYBRII + SUBROUTINE SYBRII(PP,SG,TAU0,TAUI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Evaluation of the $R_{ii}$ function in 1D slab geometry. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* SG specular parity sign. +* TAU0 side-to-side optical path. +* TAUI optical path in volume i. +* +*Parameters: output +* PP value of the expression. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + REAL PP,SG,TAU0,TAUI +* + IF(TAUI.GT.1.0E-10) THEN + PP=SG*TABEN(2,TAU0)*TAUI-(TABEN(3,TAU0)-TABEN(3,TAU0+SG*TAUI)) + ELSE + PP=0.5*(TAUI**2)*TABEN(1,TAU0) + ENDIF + RETURN + END diff --git a/Dragon/src/SYBRIJ.f b/Dragon/src/SYBRIJ.f new file mode 100644 index 0000000..995ea05 --- /dev/null +++ b/Dragon/src/SYBRIJ.f @@ -0,0 +1,54 @@ +*DECK SYBRIJ + SUBROUTINE SYBRIJ(PP,SG,TAU0,TAUI,TAUJ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Evaluation of the $R_{ij}$ function in 1D slab geometry. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* SG specular parity sign. +* TAU0 side to side optical path. +* TAUI optical path in volume i (or volume j). +* TAUJ optical path in volume j (or volume i). +* +*Parameters: output +* PP value of the expression. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + REAL PP,SG,TAU0,TAUI,TAUJ +*---- +* SYMMETRIC FORMULA IN (I,J). WE SET POPI <= POPJ +*---- + IF(TAUJ.LT.TAUI) THEN + POPI = TAUJ + POPJ = TAUI + ELSE + POPI = TAUI + POPJ = TAUJ + ENDIF + IF((POPI.GT.1.0E-10).AND.(POPJ.GT.1.0E-10)) THEN + PP=0.5*(TABEN(3,TAU0)-TABEN(3,TAU0+SG*POPI)- + 1 TABEN(3,TAU0+SG*POPJ)+TABEN(3,TAU0+SG*POPI+SG*POPJ)) + ELSE IF(POPJ.GT.1.0E-10) THEN + PP=SG*0.5*POPI*(TABEN(2,TAU0)-TABEN(2,TAU0+SG*POPJ)) + ELSE IF(POPI.GT.1.0E-10) THEN + PP=SG*0.5*POPJ*(TABEN(2,TAU0)-TABEN(2,TAU0+SG*POPI)) + ELSE + PP=0.5*POPI*POPJ*TABEN(1,TAU0) + ENDIF + RETURN + END diff --git a/Dragon/src/SYBRN2.f b/Dragon/src/SYBRN2.f new file mode 100644 index 0000000..63d5518 --- /dev/null +++ b/Dragon/src/SYBRN2.f @@ -0,0 +1,429 @@ +*DECK SYBRN2 + SUBROUTINE SYBRN2 (NREG,NSURF,A,B,Z,IZ,VOL,SIGT,TRONC,PVS,PSS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the DP-1 leakage and transmission probabilities for an +* heterogeneous non-sectorized square or rectangular cell. The tracks +* are computed by SYBRTK. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NREG number of regions in the cell. +* NSURF number of surfaces. +* A dimension of the external X sides. +* B dimension of the external Y sides. +* Z real tracking information. +* IZ integer tracking information. +* VOL volumes. +* SIGT total macroscopic cross section. +* TRONC voided block criterion. +* +*Parameters: output +* PVS volume to surface probabilities: +* XINF surfaces 1, 2 and 3; XSUP surfaces 4, 5 and 6; +* YINF surfaces 7, 8 and 9; YSUP surfaces 10, 11 and 12. +* PSS surface to surface probabilities in the following order: +* PSS(i,j) is the probability from surface i to surface j. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NREG,NSURF,IZ(*) + REAL A,B,Z(*),VOL(NREG),SIGT(NREG),TRONC,PVS(NREG,3*NSURF), + 1 PSS(3*NSURF,3*NSURF) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MKI3=600,MKI4=600,MKI5=600) + PARAMETER (PI=3.141592654,ZI30=0.785398164,ZI40=0.666666667) + LOGICAL ICARE + REAL KI3,KI4,KI5 + INTEGER ISN(12,12) + REAL PBB(28) + REAL, ALLOCATABLE, DIMENSION(:,:) :: COSINU +*---- +* BICKLEY TABLES +*---- + COMMON /BICKL3/BI3(0:MKI3),BI31(0:MKI3),BI32(0:MKI3),PAS3,XLIM3,L3 + COMMON /BICKL4/BI4(0:MKI4),BI41(0:MKI4),BI42(0:MKI4),PAS4,XLIM4,L4 + COMMON /BICKL5/BI5(0:MKI5),BI51(0:MKI5),BI52(0:MKI5),PAS5,XLIM5,L5 +* + SAVE ISN + DATA ISN/ 0, 0, 0, 4, 12, 0, 1, 9,-19, 1, 9, 19, + 1 0, 0, 0, 8, 16, 0, 5, 13,-23, 5, 13, 23, + 2 0, 0, 0, 0, 0, 28, 17, 21,-25,-17,-21,-25, + 3 4, 12, 0, 0, 0, 0, 1, 9, 19, 1, 9,-19, + 4 8, 16, 0, 0, 0, 0, 5, 13, 23, 5, 13,-23, + 5 0, 0, 28, 0, 0, 0,-17,-21,-25, 17, 21,-25, + 6 3, 11, 20, 3, 11,-20, 0, 0, 0, 2, 10, 0, + 7 7, 15, 24, 7, 15,-24, 0, 0, 0, 6, 14, 0, + 8 -18,-22,-27, 18, 22,-27, 0, 0, 0, 0, 0, 26, + 9 3, 11,-20, 3, 11, 20, 2, 10, 0, 0, 0, 0, + 1 7, 15,-24, 7, 15, 24, 6, 14, 0, 0, 0, 0, + 2 18, 22,-27,-18,-22,-27, 0, 0, 26, 0, 0, 0/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(COSINU(2,NSURF)) +*---- +* INTEGRATION USING THE TRACKING +*---- + ICARE=IZ(1).EQ.2 + ZERO=TRONC*(A+B)/(2.0*A*B) + AOB=A/B + PBB(:28)=0.0 + PVS(:NREG,:12)=0.0 + IZ0=2 + IZR=4 + DO 205 IA=1,IZ(2) + DO 20 I=1,NSURF + COSINU(1,I)=Z(IZR+1) + COSINU(2,I)=Z(IZR+2) + IZR=IZR+2 + 20 CONTINUE + MNT=IZ(IZ0+1) + IZ0=IZ0+2 + IZR=IZR+1 + DO 200 IMNT=1,MNT + NH=IZ(IZ0+1) + NX=IZ(IZ0+2) + ISURF=IZ(IZ0+3)+1 + JSURF=IZ(IZ0+NH+4)+1 + DO 190 INX=1,NX + Z1=Z(IZR+1) + IZR=IZR+1 + IF((ISURF.EQ.3).AND.(JSURF.EQ.2)) THEN + Z1=0.5*Z1/A + Z2=Z1*COSINU(1,ISURF) + Z3=Z1*COSINU(2,ISURF) + Z4=Z1*COSINU(1,ISURF)*COSINU(1,JSURF) + Z5=Z1*COSINU(2,ISURF)*COSINU(1,JSURF) + KI3=ZI30 + KI4=ZI40 + POP=0.0 + DO 40 I=1,NH + III=IZ(IZ0+3+I)-NSURF+1 + SIGTI=SIGT(III) + POP0=POP + POP=POP+SIGTI*Z(IZR+I) + IF(POP.LT.XLIM3) GO TO 30 + IF(SIGTI.LE.ZERO) GO TO 50 + PVS(III,7)=PVS(III,7)+2.0*KI3*Z1 + PVS(III,8)=PVS(III,8)+2.0*KI4*Z3 + GO TO 50 + 30 K=NINT(POP*PAS3) + WI3=BI3(K)+POP*(BI31(K)+POP*BI32(K)) + WI4=BI4(K)+POP*(BI41(K)+POP*BI42(K)) + IF(SIGTI.LE.ZERO) THEN + PVS(III,7)=PVS(III,7)+2.0*TABKI(2,POP0)*Z(IZR+I)*Z1 + PVS(III,8)=PVS(III,8)+2.0*KI3*Z(IZR+I)*Z3 + ELSE + PVS(III,7)=PVS(III,7)+2.0*(KI3-WI3)*Z1 + PVS(III,8)=PVS(III,8)+2.0*(KI4-WI4)*Z3 + ENDIF + KI3=WI3 + KI4=WI4 + 40 CONTINUE + 50 KI3=ZI30 + KI4=ZI40 + POP=0.0 + K=0 + DO 80 I=1,NH + III=IZ(IZ0+3+I)-NSURF+1 + SIGTI=SIGT(III) + POP0=POP + POP=POP+SIGTI*Z(IZR+NH+1-I) + IF(POP.LT.XLIM3) GO TO 70 + IF(SIGTI.LE.ZERO) GO TO 185 + PVS(III,1)=PVS(III,1)+2.0*KI3*Z1*AOB + PVS(III,2)=PVS(III,2)+2.0*KI4*Z2*AOB + GO TO 185 + 70 K=NINT(POP*PAS3) + WI3=BI3(K)+POP*(BI31(K)+POP*BI32(K)) + WI4=BI4(K)+POP*(BI41(K)+POP*BI42(K)) + IF(SIGTI.LE.ZERO) THEN + PVS(III,1)=PVS(III,1)+2.0*TABKI(2,POP0)*Z(IZR+NH+1-I)*Z1*AOB + PVS(III,2)=PVS(III,2)+2.0*KI3*Z(IZR+NH+1-I)*Z2*AOB + ELSE + PVS(III,1)=PVS(III,1)+2.0*(KI3-WI3)*Z1*AOB + PVS(III,2)=PVS(III,2)+2.0*(KI4-WI4)*Z2*AOB + ENDIF + KI3=WI3 + KI4=WI4 + 80 CONTINUE + KI5=BI5(K)+POP*(BI51(K)+POP*BI52(K)) + PBB(1)=PBB(1)+KI3*Z1 + PBB(5)=PBB(5)+KI4*Z2 + PBB(9)=PBB(9)+KI4*Z3 + PBB(13)=PBB(13)+KI5*Z4 + PBB(21)=PBB(21)+KI5*Z5 + PBB(23)=PBB(23)+KI5*(Z1-Z5) + ELSE IF((ISURF.EQ.3).AND.(JSURF.EQ.4)) THEN + Z1=Z1/A + Z2=Z1*COSINU(2,ISURF) + Z3=Z1*COSINU(2,ISURF)*COSINU(2,JSURF) + KI3=ZI30 + KI4=ZI40 + POP=0.0 + K=0 + DO 100 I=1,NH + III=IZ(IZ0+3+I)-NSURF+1 + SIGTI=SIGT(III) + POP0=POP + POP=POP+SIGTI*Z(IZR+I) + IF(POP.LT.XLIM3) GO TO 90 + IF(SIGTI.LE.ZERO) GO TO 110 + PVS(III,7)=PVS(III,7)+KI3*Z1 + PVS(III,8)=PVS(III,8)+KI4*Z2 + GO TO 110 + 90 K=NINT(POP*PAS3) + WI3=BI3(K)+POP*(BI31(K)+POP*BI32(K)) + WI4=BI4(K)+POP*(BI41(K)+POP*BI42(K)) + IF(SIGTI.LE.ZERO) THEN + PVS(III,7)=PVS(III,7)+TABKI(2,POP0)*Z(IZR+I)*Z1 + PVS(III,8)=PVS(III,8)+KI3*Z(IZR+I)*Z2 + ELSE + PVS(III,7)=PVS(III,7)+(KI3-WI3)*Z1 + PVS(III,8)=PVS(III,8)+(KI4-WI4)*Z2 + ENDIF + KI3=WI3 + KI4=WI4 + 100 CONTINUE + 110 KI3=ZI30 + KI4=ZI40 + POP=0.0 + DO 130 I=1,NH + III=IZ(IZ0+3+I)-NSURF+1 + SIGTI=SIGT(III) + POP0=POP + POP=POP+SIGTI*Z(IZR+NH+1-I) + IF(POP.LT.XLIM3) GO TO 120 + IF(SIGTI.LE.ZERO) GO TO 185 + PVS(III,7)=PVS(III,7)+KI3*Z1 + PVS(III,8)=PVS(III,8)+KI4*Z2 + GO TO 185 + 120 K=NINT(POP*PAS3) + WI3=BI3(K)+POP*(BI31(K)+POP*BI32(K)) + WI4=BI4(K)+POP*(BI41(K)+POP*BI42(K)) + IF(SIGTI.LE.ZERO) THEN + PVS(III,7)=PVS(III,7)+TABKI(2,POP0)*Z(IZR+NH+1-I)*Z1 + PVS(III,8)=PVS(III,8)+KI3*Z(IZR+NH+1-I)*Z2 + ELSE + PVS(III,7)=PVS(III,7)+(KI3-WI3)*Z1 + PVS(III,8)=PVS(III,8)+(KI4-WI4)*Z2 + ENDIF + KI3=WI3 + KI4=WI4 + 130 CONTINUE + KI5=BI5(K)+POP*(BI51(K)+POP*BI52(K)) + PBB(2)=PBB(2)+2.0*KI3*Z1 + PBB(6)=PBB(6)+2.0*KI4*Z2 + PBB(14)=PBB(14)+2.0*KI5*Z3 + PBB(26)=PBB(26)+2.0*KI5*(Z1-Z3) + ELSE IF((ISURF.EQ.1).AND.(JSURF.EQ.2)) THEN + Z1=Z1/B + Z2=Z1*COSINU(1,ISURF) + Z3=Z1*COSINU(1,ISURF)*COSINU(1,JSURF) + KI3=ZI30 + KI4=ZI40 + POP=0.0 + DO 150 I=1,NH + III=IZ(IZ0+3+I)-NSURF+1 + SIGTI=SIGT(III) + POP0=POP + POP=POP+SIGTI*Z(IZR+I) + IF(POP.LT.XLIM3) GO TO 140 + IF(SIGTI.LE.ZERO) GO TO 160 + PVS(III,1)=PVS(III,1)+KI3*Z1 + PVS(III,2)=PVS(III,2)+KI4*Z2 + GO TO 160 + 140 K=NINT(POP*PAS3) + WI3=BI3(K)+POP*(BI31(K)+POP*BI32(K)) + WI4=BI4(K)+POP*(BI41(K)+POP*BI42(K)) + IF(SIGTI.LE.ZERO) THEN + PVS(III,1)=PVS(III,1)+TABKI(2,POP0)*Z(IZR+I)*Z1 + PVS(III,2)=PVS(III,2)+KI3*Z(IZR+I)*Z2 + ELSE + PVS(III,1)=PVS(III,1)+(KI3-WI3)*Z1 + PVS(III,2)=PVS(III,2)+(KI4-WI4)*Z2 + ENDIF + KI3=WI3 + KI4=WI4 + 150 CONTINUE + 160 KI3=ZI30 + KI4=ZI40 + POP=0.0 + K=0 + DO 180 I=1,NH + III=IZ(IZ0+3+I)-NSURF+1 + SIGTI=SIGT(III) + POP0=POP + POP=POP+SIGTI*Z(IZR+NH+1-I) + IF(POP.LT.XLIM3) GO TO 170 + IF(SIGTI.LE.ZERO) GO TO 185 + PVS(III,1)=PVS(III,1)+KI3*Z1 + PVS(III,2)=PVS(III,2)+KI4*Z2 + GO TO 185 + 170 K=NINT(POP*PAS3) + WI3=BI3(K)+POP*(BI31(K)+POP*BI32(K)) + WI4=BI4(K)+POP*(BI41(K)+POP*BI42(K)) + IF(SIGTI.LE.ZERO) THEN + PVS(III,1)=PVS(III,1)+TABKI(2,POP0)*Z(IZR+NH+1-I)*Z1 + PVS(III,2)=PVS(III,2)+KI3*Z(IZR+NH+1-I)*Z2 + ELSE + PVS(III,1)=PVS(III,1)+(KI3-WI3)*Z1 + PVS(III,2)=PVS(III,2)+(KI4-WI4)*Z2 + ENDIF + KI3=WI3 + KI4=WI4 + 180 CONTINUE + KI5=BI5(K)+POP*(BI51(K)+POP*BI52(K)) + PBB(4)=PBB(4)+2.0*KI3*Z1 + PBB(8)=PBB(8)+2.0*KI4*Z2 + PBB(16)=PBB(16)+2.0*KI5*Z3 + PBB(28)=PBB(28)+2.0*KI5*(Z1-Z3) + ENDIF + 185 IZR=IZR+NH + 190 CONTINUE + IZ0=IZ0+NH+4 + 200 CONTINUE + 205 CONTINUE +*---- +* APPLY SYMMETRIES +*---- + IF(ICARE) THEN + PBB(1)=2.0*PBB(1) + PBB(5)=PBB(5)+PBB(9) + PBB(9)=PBB(5) + PBB(13)=2.0*PBB(13) + PBB(21)=PBB(21)+PBB(23) + PBB(23)=PBB(21) + PBB(4)=PBB(2) + PBB(8)=PBB(6) + PBB(16)=PBB(14) + PBB(28)=PBB(26) + DO 210 I=1,NREG + PVS(I,7)=PVS(I,7)+PVS(I,1) + PVS(I,8)=PVS(I,8)+PVS(I,2) + PVS(I,1)=PVS(I,7) + PVS(I,2)=PVS(I,8) + 210 CONTINUE + ENDIF + PBB(10)=PBB(6) + PBB(12)=PBB(8) + PBB(17)=PBB(9) + PBB(19)=PBB(5) + PBB(25)=PBB(13) + PBB(3)=PBB(1)*AOB + PBB(7)=PBB(9)*AOB + PBB(11)=PBB(5)*AOB + PBB(15)=PBB(13)*AOB + PBB(18)=PBB(19)*AOB + PBB(20)=PBB(17)*AOB + PBB(22)=PBB(23)*AOB + PBB(24)=PBB(21)*AOB + PBB(27)=PBB(25)*AOB +*---- +* ORTHONORMALIZATION +*---- + Z1=Z(1) + Z2=Z(2) + Z3=Z(3) + Z4=Z(4) + DO 280 I=1,4 + DEN0=PBB(I) + DEN1=PBB(4+I) + DEN2=PBB(8+I) + PBB(I)=Z1*Z1*DEN0 + PBB(4+I)=Z1*(Z2*DEN1-Z3*DEN0) + PBB(8+I)=Z1*(Z2*DEN2-Z3*DEN0) + PBB(12+I)=Z2*Z2*PBB(12+I)-Z2*Z3*(DEN1+DEN2)+Z3*Z3*DEN0 + PBB(24+I)=Z4*Z4*PBB(24+I) + 280 CONTINUE + DO 290 I=1,2 + DEN1=PBB(16+I) + DEN2=PBB(18+I) + PBB(16+I)=Z1*Z4*DEN1 + PBB(18+I)=Z1*Z4*DEN2 + PBB(20+I)=(Z2*PBB(20+I)-Z3*DEN1)*Z4 + PBB(22+I)=(Z2*PBB(22+I)-Z3*DEN2)*Z4 + 290 CONTINUE + DO 300 J=1,NREG + DEN1=PVS(J,7) + DEN2=PVS(J,1) + PVS(J,7)=Z1*Z1*DEN1 + PVS(J,1)=Z1*Z1*DEN2 + PVS(J,8)=Z1*(Z2*PVS(J,8)-Z3*DEN1) + PVS(J,2)=Z1*(Z2*PVS(J,2)-Z3*DEN2) + 300 CONTINUE +* + Z1=0.0 + Z2=0.0 + Z4=0.0 + Z5=0.0 + DO 510 J=1,NREG + X=4.0*VOL(J) + SIGTI=SIGT(J) + IF(SIGTI.GT.ZERO) THEN + Z1=Z1+PVS(J,7) + Z2=Z2+PVS(J,8) + Z4=Z4+PVS(J,1) + Z5=Z5+PVS(J,2) + X=X*SIGTI + ENDIF + PVS(J,7)=PVS(J,7)*A/X + PVS(J,8)=PVS(J,8)*A/X + PVS(J,1)=PVS(J,1)*B/X + PVS(J,2)=PVS(J,2)*B/X + 510 CONTINUE + IF((Z1.GT.TRONC).AND.(Z2.GT.TRONC).AND.(Z4.GT.TRONC).AND.(Z5.GT. + 1 TRONC)) THEN + Z1=(1.0-2.0*PBB(1)-PBB(2))/Z1 + Z2=(-2.0*PBB(9)-PBB(10))/Z2 + Z4=(1.0-2.0*PBB(3)-PBB(4))/Z4 + Z5=(-2.0*PBB(11)-PBB(12))/Z5 + DO 520 J=1,NREG + PVS(J,7)=PVS(J,7)*Z1 + PVS(J,8)=PVS(J,8)*Z2 + PVS(J,1)=PVS(J,1)*Z4 + PVS(J,2)=PVS(J,2)*Z5 + 520 CONTINUE + ENDIF +* + DO 540 I=1,NREG + PVS(I,4)=PVS(I,1) + PVS(I,5)=PVS(I,2) + PVS(I,10)=PVS(I,7) + PVS(I,11)=PVS(I,8) + 540 CONTINUE + DO 560 JC=1,12 + DO 550 IC=1,12 + IB=ISN(IC,JC) + IF(IB.LT.0) THEN + PSS(IC,JC)=-PBB(-IB) + ELSE IF(IB.GT.0) THEN + PSS(IC,JC)=PBB(IB) + ELSE + PSS(IC,JC)=0.0 + ENDIF + CONTINUE + 550 CONTINUE + 560 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(COSINU) + RETURN + END diff --git a/Dragon/src/SYBRTK.f b/Dragon/src/SYBRTK.f new file mode 100644 index 0000000..1aa4e9a --- /dev/null +++ b/Dragon/src/SYBRTK.f @@ -0,0 +1,517 @@ +*DECK SYBRTK + SUBROUTINE SYBRTK (NA,NX,NREG,A,B,RAYRE,ILIGN,INORM,IRECT,IQW,LR, + 1 Z,LI,IZ,PREC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the tracking information related to a square or rectangular +* heterogeneous cell. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NA number of angles in (0,$\\pi$/4). +* NX number of tracks in each sub domain for a given angle. +* NREG number of regions in the cell. +* A Cartesian dimension of the cell along the X axis. +* B Cartesian dimension of the cell along the Y axis. +* RAYRE radius of each cylinder (RAYRE(1)=0.0). +* ILIGN tracking print flag (=1 to print the tracking). +* INORM track normalization flag (=1 to avoid track normalization). +* IRECT rectangular flag (=1 to avoid considering symmetries of +* square cells). +* IQW equal weight quadrature flag (=1 to use equal weight +* quadratures in angle and space). +* +*Parameters: output +* LR exact size of array Z. +* L.LE.4+2*NA*(9+2*(NREG+1)*NX*NREG) for a square cell; +* L.LE.4+2*NA*(9+2*(2*NREG+1)*NX*NREG) for a rectangular cell. +* Z real tracking information. +* Z(1) to Z(4) contain the numerical orthonormalization +* factors. +* LI size of array IZ. +* L.LE.NREG+4+2*NA*(2+(NREG+1)*(3+2*NREG)) for a square cell; +* L.LE.NREG+4+2*NA*(2+(2*NREG+1)*(3+2*NREG)) for a rectangular +* cell. +* IZ integer tracking information. +* IZ(1)=5 and IZ(2)=NREG+1 for a square or rectangular cell; +* IZ(3)=1 if the cell is rectangular or if IRECT=1; +* IZ(3)=2 if the cell is square. +* PREC accuracy obtained if the non-normalized tracks are used +* to integrate the volumes. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NA,NX,NREG,ILIGN,INORM,IRECT,IQW,LR,LI,IZ(*) + REAL A,B,RAYRE(NREG),Z(*),PREC +*---- +* LOCAL VARIABLES +*---- + PARAMETER (PIO2=1.570796327,PI=3.14159265358979) + REAL ZX(64),WX(64),ZA(64),WA(64),ZXJ(64),WXJ(64) + REAL, ALLOCATABLE, DIMENSION(:) :: VAP +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(VAP(NREG)) +* + NA2=2*NA + IF(NX.GT.10) CALL XABORT('SYBRTK: NX IS GREATER THAN 10.') + IF(NA.GT.64) CALL XABORT('SYBRTK: NA IS GREATER THAN 64.') + IF(2.0*RAYRE(NREG).GT.MIN(A,B)) CALL XABORT('SYBRTK: A RADIUS IS' + 1 //' GREATER THAN HALF A SIDE.') +*---- +* COMPUTE VOLUMES +*---- + VOL=A*B + DO 10 IR=NREG,1,-1 + R2=PI*RAYRE(IR)**2 + Z(IR)=VOL-R2 + VOL=R2 + 10 CONTINUE +* + IF(IQW.EQ.0) THEN +* GAUSS-LEGENDRE AND GAUSS-JACOBI INTEGRATION POINTS. + CALL ALGPT(NX,-1.,1.,ZX(1),WX(1)) + CALL ALGJP(NX,ZXJ,WXJ) + CALL ALGPT(NA,-1.,0.,ZA(1),WA(1)) + CALL ALGPT(NA,0.,1.,ZA(NA+1),WA(NA+1)) + ELSE +* EQUAL WEIGHT INTEGRATION POINTS. + DO 15 I=1,NX + ZX(I)=(2.0*REAL(I)-1.0)/REAL(NX)-1.0 + WX(I)=2.0/REAL(NX) + ZXJ(I)=0.5*(2.0*REAL(I)-1.0)/REAL(NX) + WXJ(I)=ZXJ(I)/REAL(NX) + 15 CONTINUE + DO 20 I=1,NA2 + ZA(I)=(2.0*REAL(I)-1.0)/REAL(NA2)-1.0 + WA(I)=2.0/REAL(NA2) + 20 CONTINUE + ENDIF + IZ(1)=5 + IZ(2)=NREG+1 + IZ(3)=2 + IF((A.NE.B).OR.(IRECT.EQ.1)) IZ(3)=1 + IZ(4)=NA2 + AI=1.0/A + BI=1.0/B + AO2=0.5*A + BO2=0.5*B + AB=A*B + PREC=0.0 + LI=4 + LR=NREG+4 +*---- +* INTEGRATION IN ANGLE FROM 0 TO PI/2 +*---- + ZN1=0.0 + ZN2=0.0 + ZN3=0.0 + DO 350 IA=1,NA2 + PHI=0.5*PIO2*(ZA(IA)+1.0) + SI=SIN(PHI) + CO=COS(PHI) + TA=SI/CO + ZN1=ZN1+SI*WA(IA) + ZN2=ZN2+SI*SI*WA(IA) + ZN3=ZN3+SI*SI*SI*WA(IA) + Z(LR+1)=SI + Z(LR+2)=CO + Z(LR+3)=SI + Z(LR+4)=CO + Z(LR+5)=CO + Z(LR+6)=SI + Z(LR+7)=CO + Z(LR+8)=SI + Z(LR+9)=WA(IA) + LR=LR+9 +*---- +* FIRST ANGULAR DOMAIN +*---- + L4=LI+1 + IZ(LI+1)=0 + IZ(LI+2)=0 + LI=LI+2 + IF((IZ(3).EQ.2).AND.(PHI.GT.0.5*PIO2)) GO TO 120 + X1=0.0 + XLIM=MIN(A,B/TA) + DLIM=BO2*CO+(AO2-XLIM)*SI + DO 100 K0=NREG,1,-1 + KMAX=NREG-K0+1 + X2=MIN(XLIM,XLIM-(RAYRE(K0)-DLIM)/SI) + L3=LR+1 + L5=LI+1 + LI=LI+3 + VAP(:NREG)=0.0 + DO 50 IX=1,NX + IF(K0.EQ.NREG) THEN + S=0.5*(X2-X1)*SI*WX(IX) + X=X1+0.5*(X2-X1)*(1.0+ZX(IX)) + ELSE +* FLURIG CHANGE OF VARIABLE. + S=2.0*(X2-X1)*SI*WXJ(IX) + X=X1+(X2-X1)*ZXJ(IX)**2 + ENDIF + Z(LR+1)=S*WA(IA) + LR=LR+1 + C=BO2*SI-(AO2-X)*CO + D=BO2*CO+(AO2-X)*SI + D=D*D + SUM=0.0 + CORDE=0.0 + DO 30 K=NREG,K0+1,-1 + RR=RAYRE(K)**2-D + CORDE=SQRT(RR) + DEL=C-CORDE + SUM=SUM+DEL + Z(LR+NREG-K+1)=DEL + VAP(K)=VAP(K)+DEL*S + C=CORDE + 30 CONTINUE + IF(KMAX.NE.1) THEN + DEL=2.0*CORDE + SUM=SUM+DEL + Z(LR+KMAX)=DEL + VAP(K)=VAP(K)+DEL*S + DO 40 I=1,KMAX-2 + DEL=Z(LR+KMAX-I) + SUM=SUM+DEL + Z(LR+KMAX+I)=DEL + VAP(K+I)=VAP(K+I)+DEL*S + 40 CONTINUE + ENDIF + LR=LR+2*KMAX-1 + DEL=X/CO-SUM + Z(LR)=DEL + VAP(NREG)=VAP(NREG)+DEL*S + 50 CONTINUE + DO 60 K=KMAX-1,1-KMAX,-1 + IZ(LI+K+KMAX)=3+ABS(K)+1+NREG-KMAX + 60 CONTINUE + LI=LI+2*KMAX + IZ(L5)=2*KMAX-1 + IZ(L5+1)=NX + IZ(L5+2)=2 ! ISURF + IZ(LI)=1 ! JSURF +*---- +* VOLUME NORMALIZATION +*---- + IF((INORM.EQ.0).AND.(K0.LT.NREG)) THEN + DLIM1=BO2*CO+(AO2-X2)*SI + DLIM2=BO2*CO+(AO2-X1)*SI + VW1=0.0 + SUMVAP=0.0 + DO 70 I=K0,NREG-1 + SUMVAP=SUMVAP+VAP(I) + RW=RAYRE(I+1) + VEX1=RW*RW*ACOS(DLIM1/RW)-DLIM1*SQRT(RW*RW-DLIM1*DLIM1) + IF(RW.GT.DLIM2) + 1 VEX1=VEX1-(RW*RW*ACOS(DLIM2/RW)-DLIM2*SQRT(RW*RW-DLIM2*DLIM2)) + SUM=(VEX1-VW1)/VAP(I) + PREC=MAX(PREC,ABS(1.0-SUM)*(VEX1-VW1)/AB) + VW1=VEX1 + VAP(I)=SUM + 70 CONTINUE + VEX1=0.5*(B*SI-(A-X1-X2)*CO)*(X2-X1)*SI + VEX2=0.5*TA*(X2*X2-X1*X1)-VEX1 + SUM=(VEX1-0.5*VW1)/(VEX1-0.5*SUMVAP) + PREC=MAX(PREC,ABS(1.0-SUM)*(VEX1-0.5*VW1)/AB) + VEX1=SUM + SUM=(VEX2-0.5*VW1)/(VEX2-0.5*SUMVAP) + PREC=MAX(PREC,ABS(1.0-SUM)*(VEX2-0.5*VW1)/AB) + VEX2=SUM + DO 90 IX=1,NX + KMAX=(IZ(L5)+1)/2 + Z(L3+KMAX)=Z(L3+KMAX)*VAP(K0) + DO 80 I=1,KMAX-2 + Z(L3+KMAX-I)=Z(L3+KMAX-I)*VAP(K0+I) + Z(L3+KMAX+I)=Z(L3+KMAX+I)*VAP(K0+I) + 80 CONTINUE + Z(L3+1)=Z(L3+1)*VEX1 + Z(L3+2*KMAX-1)=Z(L3+2*KMAX-1)*VEX2 + L3=L3+2*KMAX + 90 CONTINUE + ENDIF + IZ(L4)=IZ(L4)+1 + IF(X2.GE.XLIM) GO TO 120 + X1=X2 + 100 CONTINUE +*---- +* SECOND ANGULAR DOMAIN +*---- + 120 IF(PHI.LE.ATAN(B*AI)) GO TO 240 + X1=B/TA + XLIM=0.5*(A+X1) + DO 230 K0=NREG,1,-1 + KMAX=NREG-K0+1 + X2=XLIM-RAYRE(K0)/SI + IF(X2.LE.X1) GO TO 230 + L3=LR+1 + L5=LI+1 + LI=LI+3 + VAP(:NREG)=0.0 + DO 150 IX=1,NX + IF(K0.EQ.NREG) THEN + S=0.5*(X2-X1)*SI*WX(IX) + X=X1+0.5*(X2-X1)*(1.0+ZX(IX)) + ELSE +* FLURIG CHANGE OF VARIABLE. + S=2.0*(X2-X1)*SI*WXJ(IX) + X=X1+(X2-X1)*ZXJ(IX)**2 + ENDIF + Z(LR+1)=S*WA(IA) + LR=LR+1 + C=BO2*SI-(AO2-X)*CO + D=BO2*CO+(AO2-X)*SI + D=D*D + SUM=0.0 + CORDE=0.0 + DO 130 K=NREG,K0+1,-1 + RR=RAYRE(K)**2-D + CORDE=SQRT(RR) + DEL=C-CORDE + SUM=SUM+DEL + Z(LR+NREG-K+1)=DEL + VAP(K)=VAP(K)+DEL*S + C=CORDE + 130 CONTINUE + IF(KMAX.NE.1) THEN + DEL=2.0*CORDE + SUM=SUM+DEL + Z(LR+KMAX)=DEL + VAP(K)=VAP(K)+DEL*S + DO 140 I=1,KMAX-2 + DEL=Z(LR+KMAX-I) + SUM=SUM+DEL + Z(LR+KMAX+I)=DEL + VAP(K+I)=VAP(K+I)+DEL*S + 140 CONTINUE + ENDIF + LR=LR+2*KMAX-1 + DEL=B/SI-SUM + Z(LR)=DEL + VAP(NREG)=VAP(NREG)+DEL*S + 150 CONTINUE + DO 160 K=KMAX-1,1-KMAX,-1 + IZ(LI+K+KMAX)=3+ABS(K)+1+NREG-KMAX + 160 CONTINUE + LI=LI+2*KMAX + IZ(L5)=2*KMAX-1 + IZ(L5+1)=NX + IZ(L5+2)=2 ! ISURF + IZ(LI)=3 ! JSURF +*---- +* VOLUME NORMALIZATION +*---- + IF((INORM.EQ.0).AND.(K0.LT.NREG)) THEN + DLIM1=BO2*CO+(AO2-X2)*SI + DLIM2=BO2*CO+(AO2-X1)*SI + VW1=0.0 + SUMVAP=0.0 + DO 200 I=K0,NREG-1 + SUMVAP=SUMVAP+VAP(I) + RW=RAYRE(I+1) + VEX1=RW*RW*ACOS(DLIM1/RW)-DLIM1*SQRT(RW*RW-DLIM1*DLIM1) + IF(RW.GT.DLIM2) + 1 VEX1=VEX1-(RW*RW*ACOS(DLIM2/RW)-DLIM2*SQRT(RW*RW-DLIM2*DLIM2)) + SUM=(VEX1-VW1)/VAP(I) + PREC=MAX(PREC,ABS(1.0-SUM)*(VEX1-VW1)/AB) + VW1=VEX1 + VAP(I)=SUM + 200 CONTINUE + VEX1=0.5*(B*SI-(A-X1-X2)*CO)*(X2-X1)*SI + VEX2=(X2-X1)*B-VEX1 + SUM=(VEX1-0.5*VW1)/(VEX1-0.5*SUMVAP) + PREC=MAX(PREC,ABS(1.0-SUM)*(VEX1-0.5*VW1)/AB) + VEX1=SUM + SUM=(VEX2-0.5*VW1)/(VEX2-0.5*SUMVAP) + PREC=MAX(PREC,ABS(1.0-SUM)*(VEX2-0.5*VW1)/AB) + VEX2=SUM + DO 220 IX=1,NX + KMAX=(IZ(L5)+1)/2 + Z(L3+KMAX)=Z(L3+KMAX)*VAP(K0) + DO 210 I=1,KMAX-2 + Z(L3+KMAX-I)=Z(L3+KMAX-I)*VAP(K0+I) + Z(L3+KMAX+I)=Z(L3+KMAX+I)*VAP(K0+I) + 210 CONTINUE + Z(L3+1)=Z(L3+1)*VEX1 + Z(L3+2*KMAX-1)=Z(L3+2*KMAX-1)*VEX2 + L3=L3+2*KMAX + 220 CONTINUE + ENDIF + IZ(L4)=IZ(L4)+1 + X1=X2 + 230 CONTINUE +*---- +* THIRD ANGULAR DOMAIN +*---- + 240 IF(IZ(3).EQ.2) GO TO 350 + IF(PHI.LE.ATAN(A*BI)) GO TO 350 + X1=A/TA + XLIM=0.5*(B+X1) + DO 340 K0=NREG,1,-1 + KMAX=NREG-K0+1 + X2=XLIM-RAYRE(K0)/SI + IF(X2.LE.X1) GO TO 340 + L3=LR+1 + L5=LI+1 + LI=LI+3 + VAP(:NREG)=0.0 + DO 270 IX=1,NX + IF(K0.EQ.NREG) THEN + S=0.5*(X2-X1)*SI*WX(IX) + X=X1+0.5*(X2-X1)*(1.0+ZX(IX)) + ELSE +* FLURIG CHANGE OF VARIABLE. + S=2.0*(X2-X1)*SI*WXJ(IX) + X=X1+(X2-X1)*ZXJ(IX)**2 + ENDIF + Z(LR+1)=S*WA(IA) + LR=LR+1 + C=AO2*SI-(BO2-X)*CO + D=AO2*CO+(BO2-X)*SI + D=D*D + SUM=0.0 + CORDE=0.0 + DO 250 K=NREG,K0+1,-1 + RR=RAYRE(K)**2-D + CORDE=SQRT(RR) + DEL=C-CORDE + SUM=SUM+DEL + Z(LR+NREG-K+1)=DEL + VAP(K)=VAP(K)+DEL*S + C=CORDE + 250 CONTINUE + IF(KMAX.NE.1) THEN + DEL=2.0*CORDE + SUM=SUM+DEL + Z(LR+KMAX)=DEL + VAP(K)=VAP(K)+DEL*S + DO 260 I=1,KMAX-2 + DEL=Z(LR+KMAX-I) + SUM=SUM+DEL + Z(LR+KMAX+I)=DEL + VAP(K+I)=VAP(K+I)+DEL*S + 260 CONTINUE + ENDIF + LR=LR+2*KMAX-1 + DEL=A/SI-SUM + Z(LR)=DEL + VAP(NREG)=VAP(NREG)+DEL*S + 270 CONTINUE + DO 280 K=KMAX-1,1-KMAX,-1 + IZ(LI+K+KMAX)=3+ABS(K)+1+NREG-KMAX + 280 CONTINUE + LI=LI+2*KMAX + IZ(L5)=2*KMAX-1 + IZ(L5+1)=NX + IZ(L5+2)=0 ! ISURF + IZ(LI)=1 ! JSURF +*---- +* VOLUME NORMALIZATION +*---- + IF((INORM.EQ.0).AND.(K0.LT.NREG)) THEN + DLIM1=AO2*CO+(BO2-X2)*SI + DLIM2=AO2*CO+(BO2-X1)*SI + VW1=0.0 + SUMVAP=0.0 + DO 310 I=K0,NREG-1 + SUMVAP=SUMVAP+VAP(I) + RW=RAYRE(I+1) + VEX1=RW*RW*ACOS(DLIM1/RW)-DLIM1*SQRT(RW*RW-DLIM1*DLIM1) + IF(RW.GT.DLIM2) + 1 VEX1=VEX1-(RW*RW*ACOS(DLIM2/RW)-DLIM2*SQRT(RW*RW-DLIM2*DLIM2)) + SUM=(VEX1-VW1)/VAP(I) + PREC=MAX(PREC,ABS(1.0-SUM)*(VEX1-VW1)/AB) + VW1=VEX1 + VAP(I)=SUM + 310 CONTINUE + VEX1=0.5*(A*SI-(B-X1-X2)*CO)*(X2-X1)*SI + VEX2=(X2-X1)*A-VEX1 + SUM=(VEX1-0.5*VW1)/(VEX1-0.5*SUMVAP) + PREC=MAX(PREC,ABS(1.0-SUM)*(VEX1-0.5*VW1)/AB) + VEX1=SUM + SUM=(VEX2-0.5*VW1)/(VEX2-0.5*SUMVAP) + PREC=MAX(PREC,ABS(1.0-SUM)*(VEX2-0.5*VW1)/AB) + VEX2=SUM + DO 330 IX=1,NX + KMAX=(IZ(L5)+1)/2 + Z(L3+KMAX)=Z(L3+KMAX)*VAP(K0) + DO 320 I=1,KMAX-2 + Z(L3+KMAX-I)=Z(L3+KMAX-I)*VAP(K0+I) + Z(L3+KMAX+I)=Z(L3+KMAX+I)*VAP(K0+I) + 320 CONTINUE + Z(L3+1)=Z(L3+1)*VEX1 + Z(L3+2*KMAX-1)=Z(L3+2*KMAX-1)*VEX2 + L3=L3+2*KMAX + 330 CONTINUE + ENDIF + IZ(L4)=IZ(L4)+1 + X1=X2 + 340 CONTINUE + 350 CONTINUE + ZN1=0.5*ZN1*PIO2 + ZN2=0.5*ZN2*PIO2 + ZN3=0.5*ZN3*PIO2 + Z(NREG+1)=1.0/SQRT(ZN1) + Z(NREG+2)=1.0/SQRT(0.75*ZN3-0.7205061948*ZN2*ZN2/ZN1) + Z(NREG+3)=Z(NREG+2)*0.8488263632*ZN2/ZN1 + Z(NREG+4)=2.0/SQRT(3.0*(ZN1-ZN3)) +*---- +* TRACKING INFORMATION OUTPUT +*---- + IF(ILIGN.EQ.1) THEN + L1I=IZ(1)-1 + L1R=IZ(2)-1 + WRITE(6,500) (Z(L1R+I),I=1,4) + L1R=L1R+4 + L2=0 + DO 380 IA=1,NA2 + MNT=IZ(L1I+1) + L1I=L1I+2 + ZSIN=Z(L1R+1) + ZCOS=Z(L1R+2) + L1R=L1R+9 + DO 370 IMNT=1,MNT + NH=IZ(L1I+1) + NX=IZ(L1I+2) + L1I=L1I+3 + DO 360 IX=1,NX + L2=L2+1 + IF((IMNT.EQ.1).AND.(IX.EQ.1)) THEN + WRITE(6,510) L2,ZSIN,ZCOS,Z(L1R+1),NH,(Z(L1R+I+1),I=1,NH) + ELSE + WRITE(6,520) L2,Z(L1R+1),NH,(Z(L1R+I+1),I=1,NH) + ENDIF + L1R=L1R+NH+1 + 360 CONTINUE + L1I=L1I+NH+1 + 370 CONTINUE + 380 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(VAP) + RETURN +* + 500 FORMAT (1H1//30H TRACKING INFORMATION LISTING.//12H NUMERICAL O, + 1 27HRTHONORMALIZATION FACTORS =,1P,4E12.4//6H TRACK) + 510 FORMAT (1X,I5,7H SIN =,1P,E10.3,7H COS =,E10.3,9H WEIGHT =, + 1 E10.3,6H NH =,I3,12H SEGMENTS =,5E10.3:/(80X,5E10.3)) + 520 FORMAT (1X,I5,34X,9H WEIGHT =,1P,E10.3,6H NH =,I3,10H SEGMENTS, + 1 2H =,5E10.3:/(80X,5E10.3)) + END diff --git a/Dragon/src/SYBRX2.f b/Dragon/src/SYBRX2.f new file mode 100644 index 0000000..fa8974c --- /dev/null +++ b/Dragon/src/SYBRX2.f @@ -0,0 +1,191 @@ +*DECK SYBRX2 + SUBROUTINE SYBRX2 (IPAS,NPIJ,NPIS,SIGT,SIGW,P,IMPX,NCOUR,IWIGN, + 1 NMCEL,NMERGE,NGEN,IQUAD,XX,YY,NMC,RAYRE,MAIL,RZMAIL,IFR,ALB, + 2 INUM,IGEN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the global scattering-reduced collision probabilities in a +* 2-D Cartesian or hexagonal assembly using the interface current +* method with Roth approximation. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPAS total number of volumes. +* NPIJ length of cellwise scattering-reduced collision probability +* matrices. +* NPIS length of cellwise scattering-reduced collision probability +* matrices (NPIS=NMC(NGEN+1)). +* SIGT total macroscopic cross sections. +* SIGW within group scattering cross sections. +* IMPX print flag (equal to 0 for no print). +* NCOUR number of currents surrounding the cells (=4 Cartesian +* lattice; =6 hexagonal lattice). +* IWIGN type of cylinderization. +* IQUAD quadrature parameters. +* NMCEL total number of cells in the domain. +* IFR index-number of in-currents. +* ALB transmission/albedo associated with each in-current. +* NMERGE total number of merged cells for which specific values +* of the neutron flux and reactions rates are required. +* Many cells with different position in the domain can +* be merged before the neutron flux calculation if they +* own the same generating cell. This allows some reduction +* in cpu time and memory (NMERGE.le.NMCEL). +* INUM index-number of the merged cell associated to each cell. +* Note: IFR and ALB contains information to rebuild the +* geometrical 'A' matrix. +* NGEN total number of generating cells. A generating cell is +* defined by its material and its position in the domain +* (NGEN.le.NMERGE). +* XX X-thickness of the generating cells. +* YY Y-thickness of the generating cells. +* NMC offset of the first volume in each generating cell. +* RAYRE radius of the tubes in each generating cell. +* MAIL offset of the first tracking information in each +* generating cell. +* RZMAIL real tracking information. +* IGEN index-number of the generating cell associated with each +* merged cell. +* +*Parameters: output +* P reduced collision probabilities. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IPAS,NPIJ,NPIS,IMPX,NCOUR,IWIGN,NMCEL,NMERGE,NGEN, + 1 IQUAD(4),NMC(NGEN+1),MAIL(2,NGEN),IFR(NCOUR*NMCEL),INUM(NMCEL), + 2 IGEN(NMERGE) + REAL SIGT(IPAS),SIGW(IPAS),P(IPAS,IPAS),XX(NGEN),YY(NGEN), + 1 RAYRE(NPIS),RZMAIL(*),ALB(NCOUR*NMCEL) +*---- +* LOCAL VARIABLES +*---- + REAL PIBB(6) +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: SIGT2,SIGW2,PIJW,PISW,PSJW,PSSW + REAL, ALLOCATABLE, DIMENSION(:,:) :: PSSB +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(PSSB(NMERGE,2*NMERGE),SIGT2(IPAS),SIGW2(IPAS),PIJW(NPIJ), + 1 PISW(NPIS),PSJW(NPIS),PSSW(NGEN)) +* + DO 20 I=1,IPAS + DO 10 J=1,IPAS + P(I,J)=0.0 + 10 CONTINUE + 20 CONTINUE + I1=0 + DO 40 IKK=1,NMERGE + IKG=IGEN(IKK) + J1=NMC(IKG) + I2=NMC(IKG+1)-J1 + DO 30 I=1,I2 + SIGT2(J1+I)=SIGT(I1+I) + SIGW2(J1+I)=SIGW(I1+I) + 30 CONTINUE + I1=I1+I2 + 40 CONTINUE +* + CALL SYB002 (NGEN,NPIJ,NPIS,SIGT2,SIGW2,IMPX,NCOUR,IWIGN,IQUAD, + 1 XX,YY,NMC,RAYRE,MAIL,RZMAIL,PIJW,PISW,PSJW,PSSW) +* + IPIJ=0 + DO 80 JKG=1,NGEN + J2=NMC(JKG+1)-NMC(JKG) + I1=0 + DO 70 IKK=1,NMERGE + IKG=IGEN(IKK) + I2=NMC(IKG+1)-NMC(IKG) + IF(IKG.EQ.JKG) THEN + DO 60 J=1,J2 + DO 50 I=1,J2 + P(I1+I,I1+J)=PIJW(IPIJ+(J-1)*J2+I) + 50 CONTINUE + 60 CONTINUE + ENDIF + I1=I1+I2 + 70 CONTINUE + IPIJ=IPIJ+J2*J2 + 80 CONTINUE +*---- +* COMPUTATION OF PSSB=A*(I-PSS*A)**-1 +*---- + DO 100 I=1,NMERGE + DO 90 J=1,NMERGE + PSSB(I,J)=0.0 + PSSB(I,NMERGE+J)=0.0 + 90 CONTINUE + PSSB(I,I)=1.0 + 100 CONTINUE + DO 130 ICEL=1,NMCEL + IKK=INUM(ICEL) + IKG=IGEN(IKK) + IS=NCOUR*(ICEL-1) + IF(NCOUR.EQ.4) THEN + A=XX(IKG) + B=YY(IKG) + DEN1=2.0*(A+B) + PIBB(1)=B/DEN1 + PIBB(2)=B/DEN1 + PIBB(3)=A/DEN1 + PIBB(4)=A/DEN1 + ELSE + DO 110 JC=1,NCOUR + PIBB(JC)=1.0/6.0 + 110 CONTINUE + ENDIF + ZZZ=PSSW(IKG) + DO 120 JC=1,NCOUR + J1=IFR(IS+JC) + ALBEDO=PIBB(JC)*ALB(IS+JC) + PSSB(J1,NMERGE+IKK)=PSSB(J1,NMERGE+IKK)+ALBEDO + PSSB(J1,IKK)=PSSB(J1,IKK)-ZZZ*ALBEDO + 120 CONTINUE + 130 CONTINUE + CALL ALSB(NMERGE,NMERGE,PSSB,IER,NMERGE) + IF(IER.NE.0) CALL XABORT('SYBRX2: SINGULAR MATRIX.') +*---- +* COMPUTATION OF PIS*PSSB*PSJ +*---- + I1=0 + DO 170 IKK=1,NMERGE + IKG=IGEN(IKK) + I1P=NMC(IKG) + I2=NMC(IKG+1)-I1P + DO 160 I=1,I2 + ZZZ=PISW(I1P+I) + J1=0 + DO 150 JKK=1,NMERGE + JKG=IGEN(JKK) + J1P=NMC(JKG) + J2=NMC(JKG+1)-J1P + DO 140 J=1,J2 + P(I1+I,J1+J)=P(I1+I,J1+J)+ZZZ*PSSB(JKK,NMERGE+IKK)*PSJW(J1P+J) + 140 CONTINUE + J1=J1+J2 + 150 CONTINUE + 160 CONTINUE + I1=I1+I2 + 170 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(PSSW,PSJW,PISW,PIJW,SIGW2,SIGT2,PSSB) + RETURN + END diff --git a/Dragon/src/SYBRX3.f b/Dragon/src/SYBRX3.f new file mode 100644 index 0000000..d8587ca --- /dev/null +++ b/Dragon/src/SYBRX3.f @@ -0,0 +1,216 @@ +*DECK SYBRX3 + SUBROUTINE SYBRX3 (MULTC,IPAS,NPIJ,NPIS,NRAYRE,SIGT,SIGW,P,IMPX, + 1 NCOUR,IWIGN,NMCEL,NMERGE,NGEN,IJAT,IQUAD,XX,YY,LSECT,NMC,NMCR, + 2 RAYRE,MAIL,IZMAIL,RZMAIL,IFR,ALB,INUM,MIX,DVX,IGEN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the global scattering-reduced collision probabilities in a +* 2-D Cartesian or hexagonal assembly using the interface current +* method with Roth x 4, Roth x 6, DP-0 or DP-1 approximation. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MULTC type of interface cuttent approximation: +* =2 Roth x 4 or Roth x 6 approximation; +* =3 DP-0 approximation; =4 DP-1 approximation. +* IPAS total number of volumes. +* NPIJ length of cellwise scattering-reduced collision probability +* matrices. +* NPIS length of cellwise scattering-reduced collision probability +* matrices (NPIS=NMC(NGEN+1)). +* NRAYRE size of array rayre (NRAYRE=NMCR(NGEN+1)). +* SIGT total macroscopic cross sections. +* SIGW P0 within-group scattering macroscopic cross sections. +* IMPX print flag (equal to 0 for no print). +* NCOUR number of currents surrounding the cells (=4 or 12 Cartesian +* lattice; =6 or 18 hexagonal lattice). +* IWIGN type of cylinderization if MULTC=2. +* IQUAD quadrature parameters. +* NMCEL total number of cells in the domain. +* IFR index-number of in-currents. +* ALB transmission/albedo associated with each in-current. +* NMERGE total number of merged cells for which specific values +* of the neutron flux and reactions rates are required. +* Many cells with different position in the domain can +* be merged before the neutron flux calculation if they +* own the same generating cell. This allows some reduction +* in cpu time and memory (NMERGE.le.NMCEL). +* IJAT total number of distinct out-currents. +* INUM index-number of the merged cell associated to each cell. +* MIX index-number of out-currents. +* DVX weight associated with each out-current. +* Note: IFR, ALB, MIX and DVX contains information to rebuild +* the geometrical 'A' matrix. +* NGEN total number of generating cells. A generating cell is +* defined by its material and its position in the domain +* (NGEN.le.NMERGE). +* XX X-thickness of the generating cells. +* YY Y-thickness of the generating cells. +* LSECT type of sectorization. +* NMC offset of the first volume in each generating cell. +* NMCR offset of the first radius in each generating cell. +* RAYRE radius of the tubes in each generating cell. +* MAIL offset of the first tracking information in each generatin +* cell. +* IZMAIL integer tracking information. +* RZMAIL real tracking information. +* IGEN index-number of the generating cell associated with each +* merged cell. +* +*Parameters: output +* P reduced collision probabilities. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MULTC,IPAS,NPIJ,NPIS,NRAYRE,IMPX,NCOUR,IWIGN,NMCEL, + 1 NMERGE,NGEN,IJAT,IQUAD(4),LSECT(NGEN),NMC(NGEN+1),NMCR(NGEN+1), + 2 MAIL(2,NGEN),IZMAIL(*),IFR(NCOUR*NMCEL),INUM(NMCEL), + 3 MIX(NCOUR*NMERGE),IGEN(NMERGE) + REAL SIGT(IPAS),SIGW(IPAS),P(IPAS,IPAS),XX(NGEN),YY(NGEN), + 1 RAYRE(NRAYRE),RZMAIL(*),ALB(NCOUR*NMCEL),DVX(NCOUR*NMERGE) +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: SIGT2,SIGW2,PIJW,PISW,PSJW, + 1 PSSW + REAL, ALLOCATABLE, DIMENSION(:,:) :: PSSB +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(PSSB(IJAT,2*IJAT),SIGT2(IPAS),SIGW2(IPAS),PIJW(NPIJ), + 1 PISW(NCOUR*NPIS),PSJW(NCOUR*NPIS),PSSW(NGEN*NCOUR*NCOUR)) +* + DO 20 I=1,IPAS + DO 10 J=1,IPAS + P(I,J)=0.0 + 10 CONTINUE + 20 CONTINUE + I1=0 + DO 40 IKK=1,NMERGE + IKG=IGEN(IKK) + J1=NMC(IKG) + I2=NMC(IKG+1)-J1 + DO 30 I=1,I2 + SIGT2(J1+I)=SIGT(I1+I) + SIGW2(J1+I)=SIGW(I1+I) + 30 CONTINUE + I1=I1+I2 + 40 CONTINUE +* + IF(MULTC.EQ.2) THEN +* ROTH X 4 OR ROTH X 6 APPROXIMATION. + CALL SYB003 (NGEN,NPIJ,NPIS,SIGT2,SIGW2,IMPX,NCOUR,IWIGN,IQUAD, + 1 XX,YY,NMC,RAYRE,MAIL,RZMAIL,PIJW,PISW,PSJW,PSSW) + ELSE IF(MULTC.EQ.3) THEN +* DP-0 APPROXIMATION. + CALL SYB004 (NGEN,NPIJ,NPIS,NRAYRE,SIGT2,SIGW2,IMPX,NCOUR, + 1 IQUAD,XX,YY,LSECT,NMC,NMCR,RAYRE,MAIL,IZMAIL,RZMAIL,PIJW,PISW, + 2 PSJW,PSSW) + ELSE IF(MULTC.EQ.4) THEN +* DP-1 APPROXIMATION. + CALL SYB005 (NGEN,NPIJ,NPIS,NRAYRE,SIGT2,SIGW2,IMPX,NCOUR, + 1 IQUAD,XX,YY,LSECT,NMC,NMCR,RAYRE,MAIL,IZMAIL,RZMAIL,PIJW,PISW, + 2 PSJW,PSSW) + ELSE + CALL XABORT('SYBRX3: UNKNOWN CP MODULE.') + ENDIF +* + IPIJ=0 + DO 80 JKG=1,NGEN + J2=NMC(JKG+1)-NMC(JKG) + I1=0 + DO 70 IKK=1,NMERGE + IKG=IGEN(IKK) + I2=NMC(IKG+1)-NMC(IKG) + IF(IKG.EQ.JKG) THEN + DO 60 J=1,J2 + DO 50 I=1,J2 + P(I1+I,I1+J)=PIJW(IPIJ+(J-1)*J2+I) + 50 CONTINUE + 60 CONTINUE + ENDIF + I1=I1+I2 + 70 CONTINUE + IPIJ=IPIJ+J2*J2 + 80 CONTINUE +*---- +* COMPUTATION OF PSSB=A*(I-PSS*A)**-1 +*---- + DO 100 I=1,IJAT + DO 90 J=1,IJAT + PSSB(I,J)=0.0 + PSSB(I,IJAT+J)=0.0 + 90 CONTINUE + PSSB(I,I)=1.0 + 100 CONTINUE + DO 130 ICEL=1,NMCEL + IKK=INUM(ICEL) + IT=NCOUR*(IKK-1) + IS=NCOUR*(ICEL-1) + IKG=IGEN(IKK) + IPSS=(IKG-1)*NCOUR*NCOUR + DO 120 JC=1,NCOUR + J1=IFR(IS+JC) + J2=MIX(IT+JC) + ALBEDO=ALB(IS+JC) + PSSB(J1,IJAT+J2)=PSSB(J1,IJAT+J2)+ALBEDO*DVX(IT+JC) + DO 110 IC=1,NCOUR + J2=MIX(IT+IC) + PSSB(J1,J2)=PSSB(J1,J2)-PSSW(IPSS+(JC-1)*NCOUR+IC)*ALBEDO* + 1 DVX(IT+IC) + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + CALL ALSB(IJAT,IJAT,PSSB,IER,IJAT) + IF(IER.NE.0) CALL XABORT('SYBRX3: SINGULAR MATRIX.') +*---- +* COMPUTATION OF PISW*PSSB*PSJW +*---- + I1=0 + DO 190 IKK=1,NMERGE + IKG=IGEN(IKK) + I1P=NMC(IKG) + I2=NMC(IKG+1)-I1P + IT=NCOUR*(IKK-1) + DO 180 I=1,I2 + DO 170 IC=1,NCOUR + ICC=MIX(IT+IC) + ZZZ=PISW(I1P*NCOUR+(IC-1)*I2+I)*SIGN(1.0,DVX(IT+IC)) + J1=0 + DO 160 JKK=1,NMERGE + JKG=IGEN(JKK) + J1P=NMC(JKG) + J2=NMC(JKG+1)-J1P + JT=NCOUR*(JKK-1) + DO 150 J=1,J2 + DO 140 JC=1,NCOUR + JCC=MIX(JT+JC) + PBJ=PSJW(J1P*NCOUR+(J-1)*NCOUR+JC) + P(I1+I,J1+J)=P(I1+I,J1+J)+ZZZ*DVX(JT+JC)*PSSB(JCC,IJAT+ICC)*PBJ + 140 CONTINUE + 150 CONTINUE + J1=J1+J2 + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE + I1=I1+I2 + 190 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(PSSW,PSJW,PISW,PIJW,SIGW2,SIGT2,PSSB) + RETURN + END diff --git a/Dragon/src/SYBRXE.f b/Dragon/src/SYBRXE.f new file mode 100644 index 0000000..685b7e0 --- /dev/null +++ b/Dragon/src/SYBRXE.f @@ -0,0 +1,126 @@ +*DECK SYBRXE + SUBROUTINE SYBRXE(IPAS,NPIJ,NSUPCE,RAYRE,SIGT,SIGW,P,IQUAD,ISTAT, + 1 NMC,PROCEL,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the reduced collision probabilities for the +* 'do-it-yourself' approach. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPAS number of volumes. +* NPIJ length of cellwise scattering-reduced collision probability +* matrices. +* NSUPCE number of cells. +* RAYRE radius of the tubes in each cell. +* SIGT total macroscopic cross sections. +* SIGW P0 within-group scattering macroscopic cross sections. +* IQUAD quadrature parameter. +* ISTAT istat=1 for the statistical approximation. +* NMC offset of the first volume in each cell. +* PROCEL user supplied geometrical matrix. +* IMPX print flag (equal to 0 for no print). +* +*Parameters: output +* P reduced collision probabilities. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IPAS,NPIJ,NSUPCE,IQUAD,ISTAT,NMC(NSUPCE+1),IMPX + REAL RAYRE(NSUPCE+IPAS),SIGT(IPAS),SIGW(IPAS),P(IPAS,IPAS), + 1 PROCEL(NSUPCE,NSUPCE) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (PI=3.141592654) + INTEGER, ALLOCATABLE, DIMENSION(:) :: IAPPAR + REAL, ALLOCATABLE, DIMENSION(:) :: PIJW,PISW,PSJW,PSSW + REAL, ALLOCATABLE, DIMENSION(:,:) :: PSSB +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IAPPAR(IPAS)) + ALLOCATE(PIJW(NPIJ),PISW(IPAS),PSJW(IPAS),PSSB(NSUPCE,2*NSUPCE), + 1 PSSW(NSUPCE)) +* + CALL SYB001 (NMC(NSUPCE+1),NSUPCE,NPIJ,SIGT,SIGW,IMPX,IQUAD,NMC, + 1 RAYRE,PIJW,PISW,PSJW,PSSW) +* + IPIJ=0 + DO 30 IKK=1,NSUPCE + J1=NMC(IKK) + J2=NMC(IKK+1)-J1 + DO 20 I=1,J2 + IAPPAR(I+J1)=IKK + DO 10 J=1,J2 + P(J1+I,J1+J)=PIJW(IPIJ+(J-1)*J2+I) + 10 CONTINUE + 20 CONTINUE + IPIJ=IPIJ+J2*J2 + 30 CONTINUE +*---- +* COMPUTATION OF QIJ MATRIX +*---- + IF(ISTAT.EQ.0) THEN + DO 50 I=1,NSUPCE + DO 40 J=1,NSUPCE + PSSB(I,J)=-PROCEL(I,J)*PSSW(J) + PSSB(I,NSUPCE+J)=PROCEL(I,J) + 40 CONTINUE + PSSB(I,I)=1.0+PSSB(I,I) + 50 CONTINUE + CALL ALSB(NSUPCE,NSUPCE,PSSB,IER,NSUPCE) + IF(IER.NE.0) CALL XABORT('SYBRXE: SINGULAR MATRIX.') +* COMPUTATION OF PIJ MATRIX. + DO 70 I=1,IPAS + K=IAPPAR(I) + DO 60 J=1,IPAS + L=IAPPAR(J) + XX=PISW(I)*PSSB(K,NSUPCE+L)*PSJW(J) + IF(L.EQ.K) THEN + P(I,J)=P(I,J)+XX + ELSE + P(I,J)=XX + ENDIF + 60 CONTINUE + 70 CONTINUE + ELSE + X1=0.0 + DO 80 I=1,NSUPCE + X1=X1+PSSW(I)*PROCEL(1,I) + 80 CONTINUE + X1=1.0/(1.0-X1) + DO 100 J=1,IPAS + L=IAPPAR(J) + ZZZ=PROCEL(1,L)*X1*PSJW(J) + DO 90 I=1,IPAS + K=IAPPAR(I) + XX=PISW(I)*ZZZ + IF(L.EQ.K) THEN + P(I,J)=P(I,J)+XX + ELSE + P(I,J)=XX + ENDIF + 90 CONTINUE + 100 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(PSSW,PSSB,PSJW,PISW,PIJW) + DEALLOCATE(IAPPAR) + RETURN + END diff --git a/Dragon/src/SYBT1D.f b/Dragon/src/SYBT1D.f new file mode 100644 index 0000000..8377d67 --- /dev/null +++ b/Dragon/src/SYBT1D.f @@ -0,0 +1,93 @@ +*DECK SYBT1D + SUBROUTINE SYBT1D(NPIJ,RAD,LGSPH,NGAUSS,Z) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Tracking for pij calculation using the method of Kavenoky in annular +* or spherical geometry. The tracking is used by SYBALC. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NPIJ number of regions. +* RAD radius of regions array. +* LGSPH geometry flag (=.TRUE. for spherical geometry). +* NGAUSS number of Gauss points. +* +*Parameters: output +* Z tracking information. +* +*----------------------------------------------------------------------- +* +* REFERENCE: +* A. KAVENOKY, 'CALCUL ET UTILISATION DES PROBABILITES DE PREMIERE +* COLLISION POUR LES MILIEUX HETEROGENES A UNE DIMENSION: LES PROGRAMMES +* ALCOLL ET CORTINA', NOTE CEA-N-1077, COMMISSARIAT A L'ENERGIE +* ATOMIQUE, MARS 1969. +*---- +* SUBROUTINE ARGUMENTS +*---- + LOGICAL LGSPH + INTEGER NPIJ,NGAUSS + REAL RAD(0:NPIJ),Z(*) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(MAXGAU=64,PI=3.1415926535) + REAL ALPR(MAXGAU),PWR(MAXGAU) +* + CALL ALGJP(NGAUSS,ALPR,PWR) + SUM=0.0 + IZ=1 + RIK1=RAD(0) + RI=1.0/RAD(NPIJ) + DO 60 IK=1,NPIJ + RIK2=RAD(IK) + RD=RIK2-RIK1 + DO 50 IL=1,NGAUSS + R=RIK2-RD*ALPR(IL)**2 + R2=R*R + IZ=IZ+2 + IZ1=IZ +* +*---- +* STORE INTEGRATION WEIGHT (TIMES 2) FOR THIS LINE +*---- + AUX=RD*PWR(IL)*4.0 + IF(LGSPH) AUX=AUX*R*PI + Z(IZ)=AUX + CT1=0. + CT2=0. + DO 40 I=IK,NPIJ + CT2=SQRT(RAD(I)**2-R2) + IZ=IZ+1 +*---- +* STORE LENGTH OF PATH +*---- + Z(IZ)=CT2-CT1 + CT1=CT2 + 40 CONTINUE +*---- +* STORE COS(PHI)*INTEGRATION WEIGHT ( TIMES 2 ) +*---- + Z(IZ1-1)=Z(IZ1)*CT2*RI + SUM=SUM+AUX/CT2 + 50 CONTINUE + RIK1=RIK2 + 60 CONTINUE + IZ=IZ+1 + IF(LGSPH) THEN + Z(1)=SUM/(PI*2.0*RAD(NPIJ)) + ELSE + Z(1)=SUM/PI + ENDIF + RETURN + END diff --git a/Dragon/src/SYBTRK.f b/Dragon/src/SYBTRK.f new file mode 100644 index 0000000..e0b661b --- /dev/null +++ b/Dragon/src/SYBTRK.f @@ -0,0 +1,290 @@ +*DECK SYBTRK + SUBROUTINE SYBTRK (IPTRK,IPGEOM,IMPX,MAXPTS,MAXJ,MAXZ,MULTC,IWIGN, + 1 IHALT,ILIGN,INORM,IRECT,IQW,JQUA1,JQUA2,IQUA10,IBIHET,FRTM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover of the geometry and tracking for Sybil modules. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* IPTRK pointer to the Sybil tracking (L_TRACK signature). +* IPGEOM pointer to the geometry (L_GEOM signature). +* IMPX print flag. +* MAXPTS allocated storage for arrays of dimension NREG. +* MAXJ allocated storage for interface current arrays. +* MAXZ allocated storage for tracking arrays. +* MULTC type of multicell approximation in Eurydice. +* IWIGN type of cylinderization. +* IHALT stop flag at the end of tracking (set with IHALT=1). +* ILIGN on/off switch for track printout. +* INORM on/off switch for track normalization. +* IRECT on/off switch for using symmetries in square cells. +* IQW type of quadrature. +* JQUA1 1-D quadrature parameter. +* JQUA2 2-D quadrature parameters. +* IQUA10 quadrature parameter for micro-structures in Bihet. +* IBIHET type of double-heterogeneity method (=1 Sanchez-Pomraning +* model; =2 Hebert model; =3 She-Liu-Shi model (no shadow); +* =4 She-Liu-Shi model (with shadow)). +* FRTM minimum volume fraction of the grain in the representative +* volume for She-Liu-Shi model. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPGEOM + INTEGER IMPX,MAXPTS,MAXJ,MAXZ,MULTC,IWIGN,IHALT,ILIGN,INORM, + 1 IRECT,IQW,JQUA1,JQUA2(2),IQUA10,IBIHET + REAL FRTM +*---- +* LOCAL VARIABLES +*---- + PARAMETER (PI=3.141592654,NSTATE=40) + LOGICAL ILK,LBIHET + INTEGER ISTATE(NSTATE),IQUAD(4),IGP(NSTATE),IPARAM(16) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MAT,IDL,NCODE,ICODE,ISPLX, + 1 ISPLY,ISPLZ,NMC3,LSECT,NMC4,NMCR4,MAIL,IZMAI,IFR,INUM,MIX,IGEN + REAL, ALLOCATABLE, DIMENSION(:) :: VOL,XX2,YY2,ZZ2,ZCODE,RAYR3, + 1 PROCE,POURC,SURFA,XX4,YY4,RAYR4,RZMAI,ALB,SUR,DVX +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(MAT(MAXPTS),IDL(MAXPTS)) + ALLOCATE(VOL(MAXPTS)) +* + ITG=0 + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) + LBIHET=(ISTATE(12).EQ.1) + IF(ISTATE(1).EQ.1) THEN + ITG=1 + IF(ISTATE(6).NE.1) CALL XABORT('SYBTRK: INVALID NUMBER OF REGI' + 1 //'ONS.') + CALL LCMLEN(IPGEOM,'MIX',NMILG,ITYLCM) + IF(NMILG.NE.1) CALL XABORT('SYBTRK: INVALID MIX VECTOR.') + CALL LCMGET(IPGEOM,'MIX',MAT(1)) + IR=MAT(1) + VOL(1)=1.0 + ILK=.FALSE. + NREG=1 + ELSE IF((ISTATE(1).GT.1).AND.(ISTATE(1).LT.5).AND.(ISTATE(9).EQ. + 1 0)) THEN + ITG=2 + ALLOCATE(NCODE(6),ICODE(6)) + ALLOCATE(XX2(MAXPTS+1),YY2(MAXPTS+1),ZZ2(MAXPTS+1),ZCODE(6)) +* + ALLOCATE(ISPLX(MAXPTS),ISPLY(MAXPTS),ISPLZ(MAXPTS)) + CALL READ3D(MAXPTS,MAXPTS,MAXPTS,MAXPTS,IPGEOM,IHEX,IR,ILK, + 1 SIDE,XX2,YY2,ZZ2,IMPX,LX,LY,LZ,MAT,NREG,NCODE,ICODE,ZCODE, + 2 ISPLX,ISPLY,ISPLZ,ISPLH,ISPLL) + DEALLOCATE(ISPLZ,ISPLY,ISPLX) + DO 10 IC=1,6 + IF(NCODE(IC).EQ.7) CALL XABORT('SYBTRK: ZERO FLUX BOUNDARY CO' + 1 //'NDITION NOT PERMITTED.') + 10 CONTINUE +* +* COMPUTATION OF THE VOLUMES. + DO 20 IKK=1,NREG + A=XX2(IKK) + B=XX2(IKK+1) + IF(ISTATE(1).EQ.2) THEN + VOL(IKK)=(B-A) + ELSE IF(ISTATE(1).EQ.3) THEN + VOL(IKK)=PI*(B-A)*(B+A) + ELSE IF(ISTATE(1).EQ.4) THEN + VOL(IKK)=4.0*PI*(B-A)*(A*A+A*B+B*B)/3.0 + ENDIF + 20 CONTINUE + IF(IMPX.GE.1) WRITE (6,'(/29H QUADRATURE PARAMETER JQUA1 =, + 1 I2/)') JQUA1 +* + IPARAM(1)=ISTATE(1) + IPARAM(2)=IHEX + IPARAM(3)=JQUA1 + IPARAM(4)=LX + IPARAM(5)=LY + IPARAM(6)=LZ + CALL LCMSIX(IPTRK,'PURE-GEOM',1) + CALL LCMPUT(IPTRK,'PARAM',6,1,IPARAM) + CALL LCMPUT(IPTRK,'XXX',LX+1,2,XX2) + CALL LCMPUT(IPTRK,'YYY',LY+1,2,YY2) + CALL LCMPUT(IPTRK,'ZZZ',LZ+1,2,ZZ2) + CALL LCMPUT(IPTRK,'NCODE',6,1,NCODE) + CALL LCMPUT(IPTRK,'ICODE',6,1,ICODE) + CALL LCMPUT(IPTRK,'ZCODE',6,2,ZCODE) + DEALLOCATE(ZCODE,ICODE,NCODE) + IF(ISTATE(1).GE.8) CALL LCMPUT(IPTRK,'SIDE',1,2,SIDE) + CALL LCMSIX(IPTRK,' ',2) + DEALLOCATE(ZZ2,YY2,XX2) + ELSE IF(ISTATE(1).EQ.30) THEN + ITG=3 + ALLOCATE(NMC3(1+MAXPTS)) + ALLOCATE(RAYR3(2*MAXPTS),PROCE(MAXPTS**2),POURC(MAXPTS), + 1 SURFA(MAXPTS)) +* + CALL READMT (MAXPTS,IPGEOM,IR,MAT,VOL,ILK,ISTAT,NSUPCE, + 1 NREG,NMC3,RAYR3,PROCE,POURC, + 2 SURFA,IMPX) + IF(IMPX.GE.1) WRITE (6,'(/29H QUADRATURE PARAMETER JQUA1 =, + 1 I2/)') JQUA1 +* + IPARAM(1)=NSUPCE + IPARAM(2)=JQUA1 + IPARAM(3)=ISTAT + CALL LCMSIX(IPTRK,'DOITYOURSELF',1) + CALL LCMPUT(IPTRK,'PARAM',3,1,IPARAM) + CALL LCMPUT(IPTRK,'NMC',1+NSUPCE,1,NMC3) + CALL LCMPUT(IPTRK,'RAYRE',NREG+NSUPCE,2,RAYR3) + CALL LCMPUT(IPTRK,'PROCEL',NSUPCE**2,2,PROCE) + CALL LCMPUT(IPTRK,'POURCE',NSUPCE,2,POURC) + CALL LCMPUT(IPTRK,'SURFA',NSUPCE,2,SURFA) + CALL LCMSIX(IPTRK,' ',2) + DEALLOCATE(SURFA,POURC,PROCE,RAYR3,NMC3) + ELSE IF( (ISTATE(1).EQ.5).OR.(ISTATE(1).EQ.8) .OR. + 1 ((ISTATE(1).EQ.20).AND.(ISTATE(13).EQ.0)) .OR. + 2 ((ISTATE(1).EQ.24).AND.(ISTATE(13).EQ.0)) ) THEN + ITG=4 + MAXCEL=MAXPTS + ALLOCATE(LSECT(MAXCEL),NMC4(MAXCEL+1),NMCR4(MAXCEL+1), + 1 MAIL(2*MAXCEL),IZMAI(MAXZ),IFR(MAXJ),INUM(MAXCEL),MIX(MAXJ), + 2 IGEN(MAXCEL)) + ALLOCATE(XX4(MAXCEL),YY4(MAXCEL),RAYR4(MAXPTS),RZMAI(MAXZ), + 1 ALB(MAXJ),SUR(MAXJ),DVX(MAXJ)) + IQUAD(1)=JQUA2(1) + IQUAD(2)=JQUA2(2) + IQUAD(3)=JQUA1 + IQUAD(4)=JQUA1 +* + CALL SYBEUR(MAXPTS,MAXCEL,MAXJ,MAXZ,IPGEOM,NREG,IR,MAT,VOL, + 1 ILK,IMPX,IHEX,NCOUR,LMAILI,LMAILR,NMCEL,NMERGE,NGEN,IJAT,MULTC, + 2 IWIGN,IHALT,ILIGN,INORM,IRECT,IQW,IQUAD,XX4,YY4,LSECT,NMC4, + 3 NMCR4,RAYR4,MAIL,IZMAI,RZMAI,IFR,ALB,SUR,INUM,MIX,DVX,IGEN) +* + IPARAM(1)=IHEX + IPARAM(2)=MULTC + IPARAM(3)=IWIGN + IPARAM(4)=NMCEL + IPARAM(5)=NMERGE + IPARAM(6)=NGEN + IPARAM(7)=IJAT + IPARAM(8)=IQUAD(1) + IPARAM(9)=IQUAD(2) + IPARAM(10)=IQUAD(3) + IPARAM(11)=IQUAD(4) + IPARAM(12)=INORM + IPARAM(13)=IQW + IPARAM(14)=NCOUR + IPARAM(15)=LMAILI + IPARAM(16)=LMAILR + IRDIM=NMCR4(NGEN+1) + CALL LCMSIX(IPTRK,'EURYDICE',1) + CALL LCMPUT(IPTRK,'PARAM',16,1,IPARAM) + CALL LCMPUT(IPTRK,'XX',NGEN,2,XX4) + CALL LCMPUT(IPTRK,'YY',NGEN,2,YY4) + CALL LCMPUT(IPTRK,'LSECT',NGEN,1,LSECT) + CALL LCMPUT(IPTRK,'NMC',1+NGEN,1,NMC4) + CALL LCMPUT(IPTRK,'NMCR',1+NGEN,1,NMCR4) + CALL LCMPUT(IPTRK,'RAYRE',IRDIM,2,RAYR4) + CALL LCMPUT(IPTRK,'MAIL',2*NGEN,1,MAIL) + IF(LMAILI.GT.0) THEN + CALL LCMPUT(IPTRK,'ZMAILI',LMAILI,1,IZMAI) + ENDIF + IF(LMAILR.GT.0) THEN + CALL LCMPUT(IPTRK,'ZMAILR',LMAILR,2,RZMAI) + ENDIF + CALL LCMPUT(IPTRK,'IFR',NCOUR*NMCEL,1,IFR) + CALL LCMPUT(IPTRK,'ALB',NCOUR*NMCEL,2,ALB) + CALL LCMPUT(IPTRK,'SUR',NCOUR*NMCEL,2,SUR) + CALL LCMPUT(IPTRK,'INUM',NMCEL,1,INUM) + CALL LCMPUT(IPTRK,'MIX',NCOUR*NMERGE,1,MIX) + CALL LCMPUT(IPTRK,'DVX',NCOUR*NMERGE,2,DVX) + CALL LCMPUT(IPTRK,'IGEN',NMERGE,1,IGEN) + CALL LCMSIX(IPTRK,' ',2) + DEALLOCATE(DVX,SUR,ALB,RZMAI,RAYR4,YY4,XX4) + DEALLOCATE(IGEN,MIX,INUM,IFR,IZMAI,MAIL,NMCR4,NMC4,LSECT) + ELSE + CALL XABORT('SYBTRK: INVALID GEOMETRY MODULE.') + ENDIF +*---- +* SAVE GENERAL AND SYBIL-SPECIFIC TRACKING INFORMATION +*---- + DO 30 I=1,NREG + IDL(I)=I + 30 CONTINUE + IF(ITG.EQ.3) THEN + NUNCUR=NSUPCE + ELSE IF(ITG.EQ.4) THEN + NUNCUR=IJAT + ELSE + NUNCUR=0 + ENDIF + IGP(:NSTATE)=0 + IGP(1)=NREG + IGP(2)=NREG + IF(ILK) THEN + IGP(3)=0 + ELSE + IGP(3)=1 + ENDIF + IGP(4)=IR + IGP(5)=0 + IGP(6)=ITG + IGP(7)=MAXZ + IGP(8)=MAXJ + IGP(9)=NUNCUR + IF(LBIHET) IGP(40)=1 + CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,IGP) + CALL LCMPUT(IPTRK,'MATCOD',NREG,1,MAT) + CALL LCMPUT(IPTRK,'VOLUME',NREG,2,VOL) + CALL LCMPUT(IPTRK,'KEYFLX',NREG,1,IDL) +*---- +* DOUBLE HETEROGENEITY OPTION +*---- + IF(LBIHET) CALL XDRTBH(IPGEOM,IPTRK,IQUA10,IBIHET,IMPX,FRTM) +*---- +* PRINT TRACKING ARRAYS +*---- + IF(IMPX.GT.5) THEN + CALL LCMGET(IPTRK,'STATE-VECTOR',IGP) + NREG=IGP(1) + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'VOLUME',VOL) + CALL LCMGET(IPTRK,'KEYFLX',IDL) + I1=1 + DO 60 I=1,(NREG-1)/8+1 + I2=I1+7 + IF(I2.GT.NREG) I2=NREG + WRITE (6,620) (J,J=I1,I2) + WRITE (6,630) (MAT(J),J=I1,I2) + WRITE (6,640) (IDL(J),J=I1,I2) + WRITE (6,650) (VOL(J),J=I1,I2) + I1=I1+8 + 60 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(VOL) + DEALLOCATE(IDL,MAT) + RETURN +* + 620 FORMAT (///11H REGION ,8(I8,6X,1HI)) + 630 FORMAT ( 11H MIXTURE ,8(I8,6X,1HI)) + 640 FORMAT ( 11H POINTER ,8(I8,6X,1HI)) + 650 FORMAT ( 11H VOLUME ,8(1P,E13.6,2H I)) + END diff --git a/Dragon/src/SYBUP0.f b/Dragon/src/SYBUP0.f new file mode 100644 index 0000000..6cc7e65 --- /dev/null +++ b/Dragon/src/SYBUP0.f @@ -0,0 +1,206 @@ +*DECK SYBUP0 + SUBROUTINE SYBUP0(ZZR,ZZI,NSURF,NREG,SIGT,TRONC,A,B,IMPX,VOL,PIJ, + 1 PIS,PSS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the one-group collision, DP-0 leakage and DP-0 transmission +* probabilities in a Cartesian or hexagonal non-sectorized cell. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ZZR real tracking elements. +* ZZI integer tracking elements. +* NSURF number of surfaces (4 or 6). +* NREG number of regions. +* SIGT total macroscopic cross section. +* TRONC voided block criterion. +* A Cartesian dimension of the cell along the X axis or side of +* the hexagon. +* B Cartesian dimension of the cell along the Y axis. +* IMPX print flag. +* +*Parameters: output +* VOL volumes. +* PIJ cellwise reduced collision probability matrices. +* PIS cellwise reduced escape probability matrices. +* PSS cellwise reduced transmission probability matrices. +* PSS(i,j) is the probability from surface i to surface j. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ZZI(*),NSURF,NREG,IMPX + REAL ZZR(*),SIGT(NREG),TRONC,A,B,VOL(NREG),PIJ(NREG,NREG), + 1 PIS(NREG,NSURF),PSS(NSURF,NSURF) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (SIGVID=1.0E-10) + REAL SURF(6) + REAL, ALLOCATABLE, DIMENSION(:) :: G,PIJS + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LGFULL +*---- +* INLINE FUNCTIONS +*---- + INDPOS(I,J)=MAX(I,J)*(MAX(I,J)-1)/2+MIN(I,J) +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(G(NREG+6),LGFULL(NREG)) +*---- +* CHECK FOR VOIDED REGIONS +*---- + DO 10 IR=1,NREG + VOL(IR)=ZZR(IR) + IF(VOL(IR).GT.0.) THEN + DR=SQRT(VOL(IR)) + ELSE + DR=0.0 + ENDIF + LGFULL(IR)=(SIGT(IR)*DR).GT.TRONC + IF(SIGT(IR).LE.SIGVID) SIGT(IR)=SIGVID + 10 CONTINUE +*---- +* COMPUTE SYMMETRIZED CP MATRIX +*---- + IOFI=ZZI(1) + IOFR=ZZI(2) + ICARE=ZZI(3) + MNA=ZZI(4) + ALLOCATE(PIJS((NREG+NSURF)*(NREG+NSURF+1)/2)) + CALL SYBUQV(ZZR(IOFR),ZZI(IOFI),NSURF,NREG,SIGT,MNA,LGFULL,PIJS) +*---- +* APPLY SYMMETRIES +*---- + IF(NSURF.EQ.4) THEN + SURF(1)=0.25*B + SURF(2)=0.25*B + SURF(3)=0.25*A + SURF(4)=0.25*A + ELSE + DO 20 JC=1,6 + SURF(JC)=0.25*A + 20 CONTINUE + ENDIF + DO 30 I=1,NSURF + G(I)=SURF(I) + 30 CONTINUE + IF(ICARE.EQ.1) THEN +* RECTANGULAR CELL. + PIJS(2)=2.0*PIJS(2) + PIJS(5)=0.5*PIJS(5) + PIJS(9)=2.0*PIJS(9) + PIJS(4)=PIJS(5) + PIJS(7)=PIJS(5) + PIJS(8)=PIJS(5) + IOF=11 + DO 50 I=1,NREG + G(4+I)=SIGT(I)*VOL(I) + SUM1=PIJS(IOF)+PIJS(IOF+1) + SUM2=PIJS(IOF+2)+PIJS(IOF+3) + PIJS(IOF)=SUM1 + PIJS(IOF+1)=SUM1 + PIJS(IOF+2)=SUM2 + PIJS(IOF+3)=SUM2 + DO 40 J=4,3+I + PIJS(IOF+J)=2.0*PIJS(IOF+J) + 40 CONTINUE + IOF=IOF+4+I + 50 CONTINUE + ELSE IF(ICARE.EQ.2) THEN +* SQUARE CELL. + PIJS(9)=2.0*PIJS(9) + PIJS(2)=PIJS(9) + PIJS(4)=PIJS(5) + PIJS(7)=PIJS(5) + PIJS(8)=PIJS(5) + IOF=11 + DO 80 I=1,NREG + G(4+I)=SIGT(I)*VOL(I) + SUM=PIJS(IOF)+PIJS(IOF+1)+PIJS(IOF+2)+PIJS(IOF+3) + DO 60 J=0,3 + PIJS(IOF+J)=SUM + 60 CONTINUE + DO 70 J=4,3+I + PIJS(IOF+J)=4.0*PIJS(IOF+J) + 70 CONTINUE + IOF=IOF+4+I + 80 CONTINUE + ELSE IF(ICARE.EQ.3) THEN +* HEXAGONAL CELL. + PIJS(12)=2.0*PIJS(12) + PIJS(7)=PIJS(12) + PIJS(18)=PIJS(12) + PIJS(2)=PIJS(20) + PIJS(5)=PIJS(20) + PIJS(9)=PIJS(20) + PIJS(14)=PIJS(20) + PIJS(16)=PIJS(20) + PIJS(4)=PIJS(11) + PIJS(8)=PIJS(11) + PIJS(13)=PIJS(11) + PIJS(17)=PIJS(11) + PIJS(19)=PIJS(11) + IOF=22 + DO 120 I=1,NREG + G(6+I)=SIGT(I)*VOL(I) + SUM=0.0 + DO 90 J=0,5 + SUM=SUM+PIJS(IOF+J) + 90 CONTINUE + DO 100 J=0,5 + PIJS(IOF+J)=SUM + 100 CONTINUE + DO 110 J=6,5+I + PIJS(IOF+J)=6.0*PIJS(IOF+J) + 110 CONTINUE + IOF=IOF+6+I + 120 CONTINUE + ENDIF +*---- +* FIRST APPLY THE ORTHONORMALIZATION FACTOR +*---- + DO 130 I=1,(NSURF+NREG)*(NSURF+NREG+1)/2 + PIJS(I)=PIJS(I)*ZZR(IOFR)*ZZR(IOFR) + 130 CONTINUE +*---- +* VILLARINO-STAMM'LER NORMALIZATION +*---- + CALL SYBRHL(IMPX,NSURF,NREG,G,PIJS) +*---- +* REFORMAT PIJ, PIS AND PSS MATRICES +*---- + DO 150 I=1,NSURF + DO 140 J=1,NSURF + PSS(I,J)=PIJS(INDPOS(I,J))/SURF(I) + 140 CONTINUE + 150 CONTINUE + DO 170 I=1,NSURF + DO 160 J=1,NREG + PIS(J,I)=PIJS(INDPOS(I,NSURF+J))/VOL(J)/SIGT(J) + 160 CONTINUE + 170 CONTINUE + DO 190 I=1,NREG + DO 180 J=1,NREG + PIJ(I,J)=PIJS(INDPOS(NSURF+I,NSURF+J))/(VOL(I)*SIGT(I)*SIGT(J)) + 180 CONTINUE + 190 CONTINUE + DEALLOCATE(PIJS) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(LGFULL,G) + RETURN + END diff --git a/Dragon/src/SYBUP1.f b/Dragon/src/SYBUP1.f new file mode 100644 index 0000000..2173378 --- /dev/null +++ b/Dragon/src/SYBUP1.f @@ -0,0 +1,227 @@ +*DECK SYBUP1 + SUBROUTINE SYBUP1(ZZR,ZZI,NSURF,NREG,SIGT,TRONC,A,B,IMPX,VOL,PIJ, + 1 PIS,PSS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the one-group collision, DP-1 leakage and DP-1 transmission +* probabilities in a Cartesian or hexagonal non-sectorized cell. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ZZR real tracking elements. +* ZZI integer tracking elements. +* NSURF number of surfaces (4 or 6). +* NREG number of regions. +* SIGT total macroscopic cross section. +* TRONC voided block criterion. +* A Cartesian dimension of the cell along the X axis or side of +* the hexagon. +* B Cartesian dimension of the cell along the Y axis. +* IMPX print flag. +* +*Parameters: output +* VOL volumes. +* PIJ cellwise reduced collision probability matrices. +* PIS cellwise reduced escape probability matrices. +* PSS cellwise reduced transmission probability matrices. +* PSS(i,j) is the probability from surface i to surface j. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ZZI(*),NSURF,NREG,IMPX + REAL ZZR(*),SIGT(NREG),TRONC,A,B,VOL(NREG),PIJ(NREG,NREG), + 1 PIS(NREG,3*NSURF),PSS(3*NSURF,3*NSURF) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (SIGVID=1.0E-10,NCURR=3) + REAL SURF(6) + REAL, ALLOCATABLE, DIMENSION(:) :: G,PIJS + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LGFULL +*---- +* INLINE FUNCTIONS +*---- + INDPOS(I,J)=MAX(I,J)*(MAX(I,J)-1)/2+MIN(I,J) +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(G(NREG+6),LGFULL(NREG)) +*---- +* CHECK FOR VOIDED REGIONS +*---- + DO 10 IR=1,NREG + VOL(IR)=ZZR(IR) + IF(VOL(IR).GT.0.) THEN + DR=SQRT(VOL(IR)) + ELSE + DR=0.0 + ENDIF + LGFULL(IR)=(SIGT(IR)*DR).GT.TRONC + IF(SIGT(IR).LE.SIGVID) SIGT(IR)=SIGVID + 10 CONTINUE +*---- +* COMPUTE SYMMETRIZED CP MATRIX +*---- + IOFI=ZZI(1) + IOFR=ZZI(2) + ICARE=ZZI(3) + MNA=ZZI(4) + ALLOCATE(PIJS((NREG+NSURF)*(NREG+NSURF+1)/2)) + CALL SYBUQV(ZZR(IOFR),ZZI(IOFI),NSURF,NREG,SIGT,MNA,LGFULL,PIJS) +*---- +* APPLY SYMMETRIES +*---- + IF(NSURF.EQ.4) THEN + SURF(1)=0.25*B + SURF(2)=0.25*B + SURF(3)=0.25*A + SURF(4)=0.25*A + ELSE + DO 20 JC=1,6 + SURF(JC)=0.25*A + 20 CONTINUE + ENDIF + DO 30 I=1,NSURF + G(I)=SURF(I) + 30 CONTINUE + IF(ICARE.EQ.1) THEN +* RECTANGULAR CELL. + PIJS(2)=2.0*PIJS(2) + PIJS(5)=0.5*PIJS(5) + PIJS(9)=2.0*PIJS(9) + PIJS(4)=PIJS(5) + PIJS(7)=PIJS(5) + PIJS(8)=PIJS(5) + IOF=11 + DO 50 I=1,NREG + G(4+I)=SIGT(I)*VOL(I) + SUM1=PIJS(IOF)+PIJS(IOF+1) + SUM2=PIJS(IOF+2)+PIJS(IOF+3) + PIJS(IOF)=SUM1 + PIJS(IOF+1)=SUM1 + PIJS(IOF+2)=SUM2 + PIJS(IOF+3)=SUM2 + DO 40 J=4,3+I + PIJS(IOF+J)=2.0*PIJS(IOF+J) + 40 CONTINUE + IOF=IOF+4+I + 50 CONTINUE + ELSE IF(ICARE.EQ.2) THEN +* SQUARE CELL. + PIJS(9)=2.0*PIJS(9) + PIJS(2)=PIJS(9) + PIJS(4)=PIJS(5) + PIJS(7)=PIJS(5) + PIJS(8)=PIJS(5) + IOF=11 + DO 80 I=1,NREG + G(4+I)=SIGT(I)*VOL(I) + SUM=PIJS(IOF)+PIJS(IOF+1)+PIJS(IOF+2)+PIJS(IOF+3) + DO 60 J=0,3 + PIJS(IOF+J)=SUM + 60 CONTINUE + DO 70 J=4,3+I + PIJS(IOF+J)=4.0*PIJS(IOF+J) + 70 CONTINUE + IOF=IOF+4+I + 80 CONTINUE + ELSE IF(ICARE.EQ.3) THEN +* HEXAGONAL CELL. + PIJS(12)=2.0*PIJS(12) + PIJS(7)=PIJS(12) + PIJS(18)=PIJS(12) + PIJS(2)=PIJS(20) + PIJS(5)=PIJS(20) + PIJS(9)=PIJS(20) + PIJS(14)=PIJS(20) + PIJS(16)=PIJS(20) + PIJS(4)=PIJS(11) + PIJS(8)=PIJS(11) + PIJS(13)=PIJS(11) + PIJS(17)=PIJS(11) + PIJS(19)=PIJS(11) + IOF=22 + DO 120 I=1,NREG + G(6+I)=SIGT(I)*VOL(I) + SUM=0.0 + DO 90 J=0,5 + SUM=SUM+PIJS(IOF+J) + 90 CONTINUE + DO 100 J=0,5 + PIJS(IOF+J)=SUM + 100 CONTINUE + DO 110 J=6,5+I + PIJS(IOF+J)=6.0*PIJS(IOF+J) + 110 CONTINUE + IOF=IOF+6+I + 120 CONTINUE + ENDIF +*---- +* FIRST APPLY THE ORTHONORMALIZATION FACTOR +*---- + DO 130 I=1,(NSURF+NREG)*(NSURF+NREG+1)/2 + PIJS(I)=PIJS(I)*ZZR(IOFR)*ZZR(IOFR) + 130 CONTINUE +*---- +* PERFORM A DP-1 PIS AND PSS CALCULATION USING THE TRACKING +*---- + IF(NSURF.EQ.4) THEN + CALL SYBRN2(NREG,NSURF,A,B,ZZR(IOFR),ZZI(3),ZZR(1),SIGT,TRONC, + 1 PIS,PSS) + ELSE IF(NSURF.EQ.6) THEN + CALL SYBHN2(NREG,NSURF,A,ZZR(IOFR),ZZI(3),ZZR(1),SIGT,TRONC, + 1 PIS,PSS) + ENDIF +*---- +* VILLARINO-STAMM'LER NORMALIZATION +*---- + CALL SYBRHL(IMPX,NSURF,NREG,G,PIJS) + DO 160 IR=1,NREG + DO 150 IS=1,NSURF + ZNOR=G(IS)+G(NSURF+IR) + DO 140 IH=1,3 + ISS=(IS-1)*3+IH + PIS(IR,ISS)=ZNOR*PIS(IR,ISS) + 140 CONTINUE + 150 CONTINUE + 160 CONTINUE + DO 200 IS=1,NSURF + DO 190 JS=1,NSURF + ZNOR=G(IS)+G(JS) + DO 180 IH=1,3 + ISS=(IS-1)*3+IH + DO 170 JH=1,3 + JSS=(JS-1)*3+JH + PSS(ISS,JSS)=ZNOR*PSS(ISS,JSS) + 170 CONTINUE + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE +*---- +* LOAD THE EURYDICE CP ARRAY +*---- + DO 220 I=1,NREG + DO 210 J=1,NREG + PIJ(I,J)=PIJS(INDPOS(NSURF+I,NSURF+J))/(VOL(I)*SIGT(I)*SIGT(J)) + 210 CONTINUE + 220 CONTINUE + DEALLOCATE(PIJS) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(LGFULL,G) + RETURN + END diff --git a/Dragon/src/SYBUQ0.f b/Dragon/src/SYBUQ0.f new file mode 100644 index 0000000..905b5e5 --- /dev/null +++ b/Dragon/src/SYBUQ0.f @@ -0,0 +1,409 @@ +*DECK SYBUQ0 + SUBROUTINE SYBUQ0(ZZR,ZZI,NSURF,NREG,SIGT,MNA,LGFULL,PSI,QSS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the one-group DP-1 leakage and transmission +* probabilities in a sectorized Cartesian or hexagonal cell. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ZZR real tracking elements. +* ZZI integer tracking elements. +* NSURF number of surfaces. +* NREG number of regions. +* SIGT total macroscopic cross section. +* MNA number of angles. +* LGFULL voided region flag (=.TRUE. in voided regions). +* +*Parameters: output +* PSI escape probabilities. +* QSS transmission probabilities. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ZZI(*),NSURF,NREG,MNA + REAL ZZR(*),SIGT(NREG),PSI(0:NSURF-1,3,NREG), + 1 QSS(9*NSURF*(NSURF-1)/2) + LOGICAL LGFULL(NREG) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MKI3=600,MKI4=600,MKI5=600) + PARAMETER (ZI30=0.785398164,ZI40=0.666666667) + LOGICAL LGEMPT + REAL, ALLOCATABLE, DIMENSION(:) :: POPTX + REAL, ALLOCATABLE, DIMENSION(:,:) :: COSINU + COMMON /BICKL3/BI3(0:MKI3),BI31(0:MKI3),BI32(0:MKI3),PAS3,XLIM3,L3 + COMMON /BICKL4/BI4(0:MKI4),BI41(0:MKI4),BI42(0:MKI4),PAS4,XLIM4,L4 + COMMON /BICKL5/BI5(0:MKI5),BI51(0:MKI5),BI52(0:MKI5),PAS5,XLIM5,L5 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(POPTX(2*NREG+4),COSINU(2,0:NSURF-1)) +*---- +* CHECK FOR VOIDED REGIONS +*---- + LGEMPT=.FALSE. + DO 10 IR=1,NREG + LGEMPT=LGEMPT.OR.(.NOT.LGFULL(IR)) + 10 CONTINUE +*---- +* INITIALIZATION +*---- + IZ0=0 + IZR=4 + DO 22 I=1,NREG + DO 21 J=1,3 + DO 20 K=0,NSURF-1 + PSI(K,J,I)=0.0 + 20 CONTINUE + 21 CONTINUE + 22 CONTINUE + DO 30 I=1,9*NSURF*(NSURF-1)/2 + QSS(I)=0.0 + 30 CONTINUE +* + IF(LGEMPT) THEN +* VOIDED REGION DETECTED. +* LOOP OVER THE ANGLE (FROM 0 TO PI/3). + DO 100 IA=1,MNA + MNT=ZZI(IZ0+1) + IZ0=IZ0+2 + IZFINI=IZ0 + IOF=IZR + DO 40 I=0,NSURF-1 + IOF=IOF+1 + COSINU(1,I)=ZZR(IOF) + IOF=IOF+1 + COSINU(2,I)=ZZR(IOF) + 40 CONTINUE + IZR=IZR+NSURF*2+1 +* +* LOOP OVER COMPLETE TRACKS. + DO 90 ITT=1,MNT + IZ0=IZ0+1 + NH=ZZI(IZ0) + IZ0=IZ0+1 + NX=ZZI(IZ0) +* +* WEST SIDE. + IZ0=IZ0+1 + ISW=ZZI(IZ0) + IZDEBU=IZ0 + IZFINI=IZ0+NH+1 +* + DO 80 ITX=1,NX + IZR=IZR+1 + WITRAJ=ZZR(IZR) + IZ0=IZDEBU +* +* COMPUTE OPTICAL LENGTHS. + DO 50 IX=1,NH + IZ0=IZ0+1 + IR=ZZI(IZ0)+1-NSURF + IZR=IZR+1 + SEG=ZZR(IZR) + POPTX(IX)=SEG*SIGT(IR) + 50 CONTINUE +* + IZ0=IZ0+1 + ISE=ZZI(IZ0) +* +* EXTERNAL IS IXI=0 + IZ0=IZDEBU + PKI3=ZI30*WITRAJ + PKI4=ZI40*WITRAJ + TAUX=0. + DO 60 IXI=1,NH + QIJ3=PKI3 + QIJ4=PKI4 + IZ0=IZ0+1 + IRS=ZZI(IZ0)+1-NSURF + TAUP=TAUX + TAUX=TAUX+POPTX(IXI) + IF(TAUX.GE.XLIM3) THEN + PKI3=0.0 + PKI4=0.0 + ELSE + K=NINT(TAUX*PAS3) + PKI3=(BI3(K)+TAUX*(BI31(K)+TAUX*BI32(K)))*WITRAJ + PKI4=(BI4(K)+TAUX*(BI41(K)+TAUX*BI42(K)))*WITRAJ + ENDIF + SIJ3=QIJ3-PKI3 + SIJ4=QIJ4-PKI4 +* +* COMPUTE LEAKAGE PROBABILITIES. + IF(.NOT. LGFULL(IRS)) THEN + CALL SYB32C(SIJ3,TAUP,POPTX(IXI),2) + SIJ3=SIJ3*WITRAJ + CALL SYB32C(SIJ4,TAUP,POPTX(IXI),3) + SIJ4=SIJ4*WITRAJ + ENDIF + PSI(ISW,1,IRS)=PSI(ISW,1,IRS)+SIJ3 + PSI(ISW,2,IRS)=PSI(ISW,2,IRS)+SIJ4*COSINU(2,ISW) + PSI(ISW,3,IRS)=PSI(ISW,3,IRS)+SIJ4*COSINU(1,ISW) + 60 CONTINUE +* +* EXTERNAL IS IXI=NH + IZ0=IZFINI + PKI3=ZI30*WITRAJ + PKI4=ZI40*WITRAJ + TAUX=0. + DO 70 IXI=NH,1,-1 + QIJ3=PKI3 + QIJ4=PKI4 + IZ0=IZ0-1 + IRS=ZZI(IZ0)+1-NSURF + TAUP=TAUX + TAUX=TAUX+POPTX(IXI) + IF(TAUX.GE.XLIM3) THEN + PKI3=0.0 + PKI4=0.0 + ELSE + K=NINT(TAUX*PAS3) + PKI3=(BI3(K)+TAUX*(BI31(K)+TAUX*BI32(K)))*WITRAJ + PKI4=(BI4(K)+TAUX*(BI41(K)+TAUX*BI42(K)))*WITRAJ + ENDIF + SIJ3=QIJ3-PKI3 + SIJ4=QIJ4-PKI4 + IF(.NOT. LGFULL(IRS)) THEN + CALL SYB32C(SIJ3,TAUP,POPTX(IXI),2) + SIJ3=SIJ3*WITRAJ + CALL SYB32C(SIJ4,TAUP,POPTX(IXI),3) + SIJ4=SIJ4*WITRAJ + ENDIF + PSI(ISE,1,IRS)=PSI(ISE,1,IRS)+SIJ3 + PSI(ISE,2,IRS)=PSI(ISE,2,IRS)+SIJ4*COSINU(2,ISE) + PSI(ISE,3,IRS)=PSI(ISE,3,IRS)+SIJ4*COSINU(1,ISE) + 70 CONTINUE +* + IF(TAUX.GE.XLIM5) THEN + PKI5=0.0 + ELSE + K=NINT(TAUX*PAS5) + PKI5=(BI5(K)+TAUX*(BI51(K)+TAUX*BI52(K)))*WITRAJ + ENDIF +* +* COMPUTE TRANSMISSION PROBABILITIES. + IIJ=0 + IS1=0 + IS2=0 + IF(ISW .LT. ISE) THEN + IIJ=((ISE-1)*ISE)/2+ISW + IS1=ISW + IS2=ISE + ELSE IF(ISE .LT. ISW) THEN + IIJ=((ISW-1)*ISW)/2+ISE + IS2=ISW + IS1=ISE + ELSE + CALL XABORT('SYBUQ0: IDENTICAL INCOMING AND OUTCOMING SUR' + 1 //'FACES(1).') + ENDIF + IIJ=IIJ*9 + QSS(IIJ+1)=QSS(IIJ+1)+PKI3 + QSS(IIJ+2)=QSS(IIJ+2)+PKI4*COSINU(2,IS1) + QSS(IIJ+3)=QSS(IIJ+3)+PKI4*COSINU(1,IS1) + QSS(IIJ+4)=QSS(IIJ+4)+PKI4*COSINU(2,IS2) + QSS(IIJ+7)=QSS(IIJ+7)+PKI4*COSINU(1,IS2) + QSS(IIJ+5)=QSS(IIJ+5)+PKI5*COSINU(2,IS1)*COSINU(2,IS2) + QSS(IIJ+6)=QSS(IIJ+6)+PKI5*COSINU(1,IS1)*COSINU(2,IS2) + QSS(IIJ+8)=QSS(IIJ+8)+PKI5*COSINU(2,IS1)*COSINU(1,IS2) + QSS(IIJ+9)=QSS(IIJ+9)+PKI5*COSINU(1,IS1)*COSINU(1,IS2) +* END OF TRACK. + 80 CONTINUE + IZ0=IZFINI + 90 CONTINUE +* END OF ANGLE + 100 CONTINUE + ELSE +* NO VOIDED REGION DETECTED. FAST INTEGRATION METHOD. +* LOOP OVER THE ANGLE (FROM 0 TO PI/3). + DO 170 IA=1,MNA + MNT=ZZI(IZ0+1) + IZ0=IZ0+2 + IZFINI=IZ0 + IOF=IZR + DO 110 I=0,NSURF-1 + IOF=IOF+1 + COSINU(1,I)=ZZR(IOF) + IOF=IOF+1 + COSINU(2,I)=ZZR(IOF) + 110 CONTINUE + IZR=IZR+NSURF*2+1 +* +* LOOP OVER COMPLETE TRACKS. + DO 160 ITT=1,MNT + IZ0=IZ0+1 + NH=ZZI(IZ0) + IZ0=IZ0+1 + NX=ZZI(IZ0) +* +* WEST SIDE. + IZ0=IZ0+1 + ISW=ZZI(IZ0) + IZDEBU=IZ0 + IZFINI=IZ0+NH+1 + DO 150 ITX=1,NX + IZR=IZR+1 + WITRAJ=ZZR(IZR) + IZ0=IZDEBU +* +* COMPUTE OPTICAL LENGTHS. + DO 120 IX=1,NH + IZ0=IZ0+1 + IR=ZZI(IZ0)+1-NSURF + IZR=IZR+1 + SEG=ZZR(IZR) + POPTX(IX)=SEG*SIGT(IR) + 120 CONTINUE +* + IZ0=IZ0+1 + ISE=ZZI(IZ0) +* +* EXTERNAL IS IXI=0 + IZ0=IZDEBU + PKI3=ZI30*WITRAJ + PKI4=ZI40*WITRAJ + TAUX=0. + DO 130 IXI=1,NH + QIJ3=PKI3 + QIJ4=PKI4 + IZ0=IZ0+1 + IRS=ZZI(IZ0)+1-NSURF + TAUX=TAUX+POPTX(IXI) + IF(TAUX.GE.XLIM3) THEN + PKI3=0.0 + PKI4=0.0 + ELSE + K=NINT(TAUX*PAS3) + PKI3=(BI3(K)+TAUX*(BI31(K)+TAUX*BI32(K)))*WITRAJ + PKI4=(BI4(K)+TAUX*(BI41(K)+TAUX*BI42(K)))*WITRAJ + ENDIF + SIJ3=QIJ3-PKI3 + SIJ4=QIJ4-PKI4 +* +* COMPUTE LEAKAGE PROBABILITIES. + PSI(ISW,1,IRS)=PSI(ISW,1,IRS)+SIJ3 + PSI(ISW,2,IRS)=PSI(ISW,2,IRS)+SIJ4*COSINU(2,ISW) + PSI(ISW,3,IRS)=PSI(ISW,3,IRS)+SIJ4*COSINU(1,ISW) + 130 CONTINUE +* +* EXTERNAL IS IXI=NH + IZ0=IZFINI + PKI3=ZI30*WITRAJ + PKI4=ZI40*WITRAJ + TAUX=0. + DO 140 IXI=NH,1,-1 + QIJ3=PKI3 + QIJ4=PKI4 + IZ0=IZ0-1 + IRS=ZZI(IZ0)+1-NSURF + TAUX=TAUX+POPTX(IXI) + IF(TAUX.GE.XLIM3) THEN + PKI3=0.0 + PKI4=0.0 + ELSE + K=NINT(TAUX*PAS3) + PKI3=(BI3(K)+TAUX*(BI31(K)+TAUX*BI32(K)))*WITRAJ + PKI4=(BI4(K)+TAUX*(BI41(K)+TAUX*BI42(K)))*WITRAJ + ENDIF + SIJ3=QIJ3-PKI3 + SIJ4=QIJ4-PKI4 + PSI(ISE,1,IRS)=PSI(ISE,1,IRS)+SIJ3 + PSI(ISE,2,IRS)=PSI(ISE,2,IRS)+SIJ4*COSINU(2,ISE) + PSI(ISE,3,IRS)=PSI(ISE,3,IRS)+SIJ4*COSINU(1,ISE) + 140 CONTINUE +* + IF(TAUX.GE.XLIM5) THEN + PKI5=0.0 + ELSE + K=NINT(TAUX*PAS5) + PKI5=(BI5(K)+TAUX*(BI51(K)+TAUX*BI52(K)))*WITRAJ + ENDIF +* +* COMPUTE TRANSMISSION PROBABILITIES. + IIJ=0 + IS1=0 + IS2=0 + IF(ISW .LT. ISE) THEN + IIJ=((ISE-1)*ISE)/2+ISW + IS1=ISW + IS2=ISE + ELSE IF(ISE .LT. ISW) THEN + IIJ=((ISW-1)*ISW)/2+ISE + IS2=ISW + IS1=ISE + ELSE + CALL XABORT('SYBUQ0: IDENTICAL INCOMING AND OUTCOMING SUR' + 1 //'FACES(2).') + ENDIF + IIJ=IIJ*9 + QSS(IIJ+1)=QSS(IIJ+1)+PKI3 + QSS(IIJ+2)=QSS(IIJ+2)+PKI4*COSINU(2,IS1) + QSS(IIJ+3)=QSS(IIJ+3)+PKI4*COSINU(1,IS1) + QSS(IIJ+4)=QSS(IIJ+4)+PKI4*COSINU(2,IS2) + QSS(IIJ+7)=QSS(IIJ+7)+PKI4*COSINU(1,IS2) + QSS(IIJ+5)=QSS(IIJ+5)+PKI5*COSINU(2,IS1)*COSINU(2,IS2) + QSS(IIJ+6)=QSS(IIJ+6)+PKI5*COSINU(1,IS1)*COSINU(2,IS2) + QSS(IIJ+8)=QSS(IIJ+8)+PKI5*COSINU(2,IS1)*COSINU(1,IS2) + QSS(IIJ+9)=QSS(IIJ+9)+PKI5*COSINU(1,IS1)*COSINU(1,IS2) +* END OF TRACK. + 150 CONTINUE + IZ0=IZFINI + 160 CONTINUE +* END OF ANGLE. + 170 CONTINUE + ENDIF +*---- +* NUMERICAL ORTHONORMALIZATION +*---- + Z1=ZZR(1) + Z2=ZZR(2) + Z3=ZZR(3) + Z4=ZZR(4) + DO 185 IRS=1,NREG + DO 180 ISE=0,NSURF-1 + DEN0=PSI(ISE,1,IRS) + PSI(ISE,1,IRS)=0.25*Z1*Z1*DEN0 + PSI(ISE,2,IRS)=0.25*Z1*Z4*PSI(ISE,2,IRS) + PSI(ISE,3,IRS)=0.25*Z1*(Z2*PSI(ISE,3,IRS)-Z3*DEN0) + 180 CONTINUE + 185 CONTINUE + IIJ=0 + DO 190 IS=1,NSURF*(NSURF-1)/2 + DEN0=QSS(IIJ+1) + DEN1=QSS(IIJ+3) + DEN2=QSS(IIJ+7) + QSS(IIJ+1)=Z1*Z1*DEN0 + QSS(IIJ+3)=Z1*(Z2*DEN1-Z3*DEN0) + QSS(IIJ+7)=Z1*(Z2*DEN2-Z3*DEN0) + QSS(IIJ+9)=Z2*Z2*QSS(IIJ+9)-Z2*Z3*(DEN1+DEN2)+Z3*Z3*DEN0 + DEN1=QSS(IIJ+2) + DEN2=QSS(IIJ+4) + QSS(IIJ+2)=Z1*Z4*DEN1 + QSS(IIJ+4)=Z1*Z4*DEN2 + QSS(IIJ+6)=(Z2*QSS(IIJ+6)-Z3*DEN2)*Z4 + QSS(IIJ+8)=(Z2*QSS(IIJ+8)-Z3*DEN1)*Z4 + QSS(IIJ+5)=Z4*Z4*QSS(IIJ+5) + IIJ=IIJ+9 + 190 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(COSINU,POPTX) + RETURN + END diff --git a/Dragon/src/SYBUQV.f b/Dragon/src/SYBUQV.f new file mode 100644 index 0000000..2da3291 --- /dev/null +++ b/Dragon/src/SYBUQV.f @@ -0,0 +1,243 @@ +*DECK SYBUQV + SUBROUTINE SYBUQV(ZZR,ZZI,NSURF,NREG,SIGT,MNA,LGFULL,PIJ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the one-group collision, DP-0 leakage and DP-0 transmission +* probabilities in a Cartesian or hexagonal cell. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ZZR real tracking elements. +* ZZI integer tracking elements. +* NSURF number of surfaces (4 or 6). +* NREG number of regions. +* SIGT total macroscopic cross section. +* MNA number of angles. +* LGFULL void flad (=.TRUE. in voided regions). +* +*Parameters: output +* PIJ collision, DP-0 leakage and DP-0 transmission probabilities +* in lower triangular form. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ZZI(*),NSURF,NREG,MNA + REAL ZZR(*),SIGT(NSURF:NSURF+NREG-1), + > PIJ(0:(NREG+NSURF)*(NREG+NSURF+1)/2-1) + LOGICAL LGFULL(NSURF:NSURF+NREG-1) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MKI3=600,ZI30=0.785398164) + LOGICAL LGEMPT + REAL, ALLOCATABLE, DIMENSION(:) :: POPTX + COMMON /BICKL3/BI3(0:MKI3),BI31(0:MKI3),BI32(0:MKI3),PAS3,XLIM3,L3 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(POPTX(2*NREG+4)) +*---- +* CHECK FOR VOIDED REGIONS +*---- + LGEMPT=.FALSE. + DO 10 IR=1,NREG + LGEMPT=LGEMPT.OR.(.NOT.LGFULL(IR+NSURF-1)) + 10 CONTINUE +*---- +* INITIALIZATION +*---- + IZ0=0 + IZR=4 + PIJ(0:(NREG+NSURF)*(NREG+NSURF+1)/2-1)=0.0 + IF(LGEMPT) THEN +* VOIDED REGION DETECTED. + DO 52 IA=1,MNA + MNT=ZZI(IZ0+1) + IZ0=IZ0+2 + IZR=IZR+NSURF*2+1 +* +* LOOP OVER COMPLETE TRACKS. + DO 51 ITT=1,MNT + IZ0=IZ0+1 + NH=ZZI(IZ0) + IZ0=IZ0+1 + NX=ZZI(IZ0) +* + IZ0=IZ0+1 + ISW=ZZI(IZ0) ! WEST SIDE + JZI=IZ0 + DO 50 ITX=1,NX + IZR=IZR+1 + WITRAJ=ZZR(IZR)/4.0 + IZ0=JZI +* +* COMPUTE OPTICAL LENGTHS. + DO 20 IX=1,NH + IR=ZZI(IZ0+IX) + POPTX(IX)=ZZR(IZR+IX)*SIGT(IR) + 20 CONTINUE + ISE=ZZI(IZ0+NH+1) ! EAST SIDE + IZR=IZR+NH +* +* EXTERNAL IS IR=0 + IRS=ISW + POP1=0. + DO 40 IXI=1,NH + IRT=IRS + IRS=ZZI(IZ0+IXI) +* +* BEGINNING WITH IRS == JRS, P(i,i)=Taup -(B3(0)-P3) + IIJ=IRS*(IRS+3)/2 + CALL SYB33C(PPLUS,POPTX(IXI)) + PIJ(IIJ)=PIJ(IIJ)+2.0*PPLUS*WITRAJ + TAUX=0. + DO 30 IXJ=IXI,NH + JRS=ZZI(IZ0+IXJ) + IIJ=MAX(IRT*(IRT+1)/2+JRS,JRS*(JRS+1)/2+IRT) + IF(IRT.LT.NSURF) THEN + CALL SYB32C(PPLUS,TAUX,POPTX(IXJ),2) + PIJ(IIJ)=PIJ(IIJ)+PPLUS*WITRAJ + ELSE + CALL SYB31C(PPLUS,TAUX,POP1,POPTX(IXJ)) + IF(JRS.EQ.IRT) PPLUS=2.0*PPLUS + PIJ(IIJ)=PIJ(IIJ)+PPLUS*WITRAJ + ENDIF + TAUX=TAUX+POPTX(IXJ) + 30 CONTINUE + IIJ=MAX(IRT*(IRT+1)/2+ISE,ISE*(ISE+1)/2+IRT) + IF(IRT.LT.NSURF) THEN + PIJ(IIJ)=PIJ(IIJ)+TABKI(3,TAUX)*WITRAJ + ELSE + CALL SYB32C(PPLUS,TAUX,POP1,2) + PIJ(IIJ)=PIJ(IIJ)+PPLUS*WITRAJ + ENDIF + POP1=POPTX(IXI) + 40 CONTINUE + IZ0=IZ0+NH+1 +* +* COMPUTE REMAINING PSI FROM LAST REGION TO EAST SIDE. + IIJ=MAX(IRS*(IRS+1)/2+ISE,ISE*(ISE+1)/2+IRS) + CALL SYB32C(PPLUS,0.0,POP1,2) + PIJ(IIJ)=PIJ(IIJ)+PPLUS*WITRAJ + 50 CONTINUE + 51 CONTINUE + 52 CONTINUE + ELSE +* NO VOIDED REGION DETECTED. FAST INTEGRATION METHOD. +* LOOP OVER THE ANGLE(FROM 0 TO PI/3). + DO 92 IA=1,MNA + MNT=ZZI(IZ0+1) + IZ0=IZ0+2 + IZR=IZR+NSURF*2+1 +* +* LOOP OVER COMPLETE TRACKS. + DO 91 ITT=1,MNT + IZ0=IZ0+1 + NH=ZZI(IZ0) + IZ0=IZ0+1 + NX=ZZI(IZ0) +* +* WEST SIDE + IZ0=IZ0+1 + ISW=ZZI(IZ0) + JZI=IZ0 + DO 90 ITX=1,NX + IZR=IZR+1 + WITRAJ=ZZR(IZR)/4.0 + JZR=IZR + IZ0=JZI + IF(WITRAJ.LT.0.0) CALL XABORT('SYBUQV: FAILURE 3.') + IF(NH.GT.2*NREG+4) CALL XABORT('SYBUQV: FAILURE 4.') +* +* COMPUTE OPTICAL LENGTHS. + DO 60 IX=1,NH + IZ0=IZ0+1 + IR=ZZI(IZ0) + IZR=IZR+1 + SEG=ZZR(IZR) + POPTX(IX)=SEG*SIGT(IR) + 60 CONTINUE +* +* EXTERNAL IS IR=0 + IZ0=JZI + IRS=ISW + JZ0=0 + DO 80 IXI=1,NH + IRT=IRS + IZ00=IZ0 + IZ0=IZ0+1 + IRS=ZZI(IZ0) +* +* PREVIOUS REGION J + JZ0=IZ00 + PKI3=ZI30*WITRAJ + TAUX=0. +* +* BEGINNING WITH IRS == JRS,P(i,i)=Taup -(B3(0)-P3) + IIJ=IRS*(IRS+3)/2 + PIJ(IIJ)=PIJ(IIJ)+POPTX(IXI)*WITRAJ + DO 70 IXJ=IXI,NH + JZ0=JZ0+1 + JRS=ZZI(JZ0) + QIJ3=PKI3 + TAUX=TAUX+POPTX(IXJ) + IF(TAUX.GE.XLIM3) THEN + PKI3=0.0 + ELSE + K=NINT(TAUX*PAS3) + PKI3=(BI3(K)+TAUX*(BI31(K)+TAUX*BI32(K)))*WITRAJ + ENDIF + SIJ3=QIJ3-PKI3 +* +* BEGINNING OF PIJ : REGION IRS,JRS + IIJ=MAX(IRS*(IRS+1)/2+JRS,JRS*(JRS+1)/2+IRS) + PIJ(IIJ)=PIJ(IIJ)-SIJ3 +* +* REMAINING OF PIJ : Region IRS,JRS +* OR ... PSI IFF IXI=1, IRT IS THE WEST SIDE + IIJ=MAX(IRT*(IRT+1)/2+JRS,JRS*(JRS+1)/2+IRT) + PIJ(IIJ)=PIJ(IIJ)+SIJ3 + 70 CONTINUE +* +* COMPUTE LEAKAGE AND TRANSMISSION PROBABILITIES PSI, PSS + JZ0=JZ0+1 + ISE=ZZI(JZ0) + IIJ=IRS*(IRS+1)/2+ISE + PIJ(IIJ)=PIJ(IIJ)-PKI3 + IIJ=MAX(IRT*(IRT+1)/2+ISE,ISE*(ISE+1)/2+IRT) + PIJ(IIJ)=PIJ(IIJ)+PKI3 + 80 CONTINUE +* +* COMPUTE REMAINING PSI FROM LAST REGION TO EAST SIDE. + IZ0=IZ0+1 + ISE=ZZI(JZ0) + IIJ=MAX(IRS*(IRS+1)/2+ISE,ISE*(ISE+1)/2+IRS) + PIJ(IIJ)=PIJ(IIJ)+ZI30*WITRAJ + 90 CONTINUE + 91 CONTINUE + 92 CONTINUE + IIJ=NSURF*(NSURF+1)/2-1 + DO 100 JR=1,NREG + IIJ=IIJ+NSURF+JR + PIJ(IIJ)=PIJ(IIJ)*2.0 + 100 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(POPTX) + RETURN + END diff --git a/Dragon/src/SYBWIJ.f b/Dragon/src/SYBWIJ.f new file mode 100644 index 0000000..a172df4 --- /dev/null +++ b/Dragon/src/SYBWIJ.f @@ -0,0 +1,57 @@ +*DECK SYBWIJ + SUBROUTINE SYBWIJ (NREG,MAXPTS,SIGW,PIJ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Scattering reduction for collision probabilities. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NREG total number of regions. +* MAXPTS first dimension of matrix PIJ. +* SIGW P0 within-group scattering macroscopic cross sections +* ordered by volume. +* +*Parameters: input/output +* PIJ reduced collision probability matrix on input and +* scattering-reduced collision probability matrix at output. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NREG,MAXPTS + REAL SIGW(NREG),PIJ(MAXPTS,NREG) +*---- +* LOCAL VARIABLES +*---- + REAL, ALLOCATABLE, DIMENSION(:,:) :: WIJ +* + ALLOCATE(WIJ(NREG,2*NREG)) + DO 20 I=1,NREG + DO 10 J=1,NREG + WIJ(I,NREG+J)=PIJ(I,J) + WIJ(I,J)=-PIJ(I,J)*SIGW(J) + 10 CONTINUE + WIJ(I,I)=1.0+WIJ(I,I) + 20 CONTINUE + CALL ALSB(NREG,NREG,WIJ,IER,NREG) + IF(IER.NE.0) CALL XABORT('SYBWIJ: SINGULAR MATRIX.') + DO 40 J=1,NREG + DO 30 I=1,NREG + PIJ(I,J)=WIJ(I,NREG+J) + 30 CONTINUE + 40 CONTINUE + DEALLOCATE(WIJ) + RETURN + END diff --git a/Dragon/src/TLM.f b/Dragon/src/TLM.f new file mode 100644 index 0000000..01f5863 --- /dev/null +++ b/Dragon/src/TLM.f @@ -0,0 +1,425 @@ +*DECK TLM + SUBROUTINE TLM(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Create Matlab procedure to trace the integration lines +* generated with the NXT tracking module of DRAGON. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* NENTRY number of data structures transfered to this module. +* HENTRY name of the data structures. +* IENTRY data structure type where: +* =1 for LCM memory object; +* =2 for XSM file; +* =3 for sequential binary file; +* =4 for sequential ASCII file. +* JENTRY access permission for the data structure where: +* =0 for a data structure in creation mode; +* =1 for a data structure in modifications mode; +* =2 for a data structure in read-only mode. +* KENTRY data structure pointer. +* +*Comments: +* Instructions for the use of the TLM: module: +* M-file.m := TLM: [ M-file.m ] VOLTRK TRKFIL :: +* [ EDIT [ iprint ] ] +* [ NTPO nplots ] +* (TLMget) ; +* where +* M-file.m : SEQ_ASCII file containing Matlab instructions. +* VOLTRK : read-only tracking data structure +* (signature L_TRACK). +* TRKFIL : read-only sequential binary tracking file. +* EDIT : keyword to specify print level. +* iprint : print level. By default, iprint=1. +* NTPO : keyword to specify number of plots generated +* by this execution. +* nplots : number of plots. By default, nplots=1. +* (TLMget) : Processing options to select types of plots. +* (read from input using the TLMGET routine). +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: and TLM: Modules, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='TLM ') + INTEGER ILCMUP,ILCMDN + PARAMETER (ILCMUP=1,ILCMDN=2) + INTEGER NSTATE,NIPLP + PARAMETER (NSTATE=40,NIPLP=6) + DOUBLE PRECISION DZERO,DONE + PARAMETER (DZERO=0.0D0,DONE=1.0D0) +*---- +* Variables for input via REDGET +*---- + INTEGER ITYPLU,INTLIR + CHARACTER CARLIR*72,CARLST*72 + REAL REALIR + DOUBLE PRECISION DBLLIR +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MATALB,NUMERG + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IPLP + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DPLP,DGMESH,DANGLT, + 1 VOMER1,VOMERG + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) ::DVNOR1,DVNOR +*---- +* Local functions +*---- + INTEGER TLMVPL + INTEGER IVALID +*---- +* Local variables +*---- + TYPE(C_PTR) IPTRK + INTEGER IMTRK,IFTRK,IMFTRK,IMMAT,IPMAT + INTEGER IEN + CHARACTER HSIGN*12,CMAT*4 + INTEGER ISTATT(NSTATE),IEDIMG(NSTATE) + CHARACTER TITLE*72 + INTEGER IPRINT,NPLOTS + CHARACTER CTYPE*4,COMNT*80 + INTEGER NCOMNT,NBTR,ICOM + INTEGER NDIM,ISPEC,NREG,NSOUT,NALBG,NCOR,NANGL,NFSUR, + > NFREG,IFMT,MXSUB,MXSEG + INTEGER NBUCEL,NUCELL(3),MAXMSH,MAXMSP,MXGREG,MAXMDH + INTEGER II,KK,ITRKT,IRENOT,NBDR,NSUR,IPLOT + INTEGER NSKTRK + INTEGER ITGEO,ILONG,ITYLCM + DOUBLE PRECISION XYZL(2,3) + LOGICAL LMIX +*---- +* Validate entry parameters +*---- + IF(NENTRY .NE. 3) CALL XABORT(NAMSBR// + > ': Three data structures required') + IPTRK=C_NULL_PTR + IMTRK=0 + IFTRK=0 + IMFTRK=0 + IEN=1 + IMMAT=JENTRY(IEN) + IPMAT=FILUNIT(KENTRY(IEN)) + IF(IENTRY(IEN) .NE. 4 ) CALL XABORT(NAMSBR// + > ': Matlab .m file is not an ASCII file') + IF(IMMAT .NE. 0 .AND. + > IMMAT .NE. 1 ) CALL XABORT(NAMSBR// + > ': Matlab .m file not in create or update mode') +*---- +* Scan data structure to determine type and mode +*---- + DO IEN=2,NENTRY + IF(IENTRY(IEN) .EQ. 1 .OR. IENTRY(IEN) .EQ. 2) THEN + IF(JENTRY(IEN) .EQ. 2) THEN + CALL LCMGTC(KENTRY(IEN),'SIGNATURE',12,HSIGN) + IF(HSIGN .EQ. 'L_TRACK') THEN + IPTRK=KENTRY(IEN) + IMTRK=IEN + CALL LCMGTC(KENTRY(IEN),'TRACK-TYPE',12,HSIGN) + IF((HSIGN .NE. 'EXCELL').AND.(HSIGN .NE. 'MCCG')) THEN + CALL XABORT(NAMSBR// + > ': Tracking data structure type is invalid') + ENDIF + ELSE + CALL XABORT(NAMSBR// + > ': Invalid signature for '//HENTRY(IEN)) + ENDIF + ELSE + CALL XABORT(NAMSBR// + > ': Tracking data structure not in read-only mode') + ENDIF + ELSE IF(IENTRY(IEN) .EQ. 3) THEN + IF(JENTRY(IEN) .NE. 2) CALL XABORT(NAMSBR// + > ': Tracking file not in read-only mode') + IFTRK=FILUNIT(KENTRY(IEN)) + IMFTRK=IEN + ELSE + CALL XABORT(NAMSBR// + > ': Invalid data structure format for '//HENTRY(IEN)) + ENDIF + ENDDO + IF(IMFTRK .EQ. 0) CALL XABORT(NAMSBR// + >': No tracking file available') + IF(IMTRK .EQ. 0) CALL XABORT(NAMSBR// + >': No Tracking data structure available') +*---- +* Recover EDIT level and number of track processing option +* [ EDIT [ iprint ] ] +* [ NTPO [ nplots ] ] +* by default iprint=1 and nplots=1. +*---- + IPRINT=1 + NPLOTS=1 + LMIX=.FALSE. + 1010 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + 1011 CONTINUE + IF(ITYPLU .EQ. 10) GO TO 1015 + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + > ': Read error -- Character variable expected') + IF(CARLIR(1:4) .EQ. ';') THEN + GO TO 1015 + ELSE IF(CARLIR(1:4) .EQ. 'EDIT') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) GO TO 1011 + IPRINT=INTLIR + ELSE IF(CARLIR(1:7) .EQ. 'MIXTURE') THEN + LMIX=.TRUE. + ELSE IF(CARLIR(1:4) .EQ. 'NTPO') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) GO TO 1011 + NPLOTS=INTLIR + ELSE + GO TO 1015 + ENDIF + GO TO 1010 + 1015 CONTINUE +*---- +* Get Matlab plot options +*---- + CARLST=CARLIR + ALLOCATE(IPLP(NIPLP,NPLOTS),DPLP(4*NPLOTS)) + CALL TLMGET(IPRINT,NPLOTS,NDIM,CARLST,IPLP,DPLP) +*---- +* Read tracking file parameters +*---- + READ(IFTRK) CTYPE,NCOMNT,NBTR,IFMT + IF(CTYPE .NE. '$TRK') CALL XABORT(NAMSBR// + >': Binary file is not a valid NXT: tracking file') + IF(IFMT .NE. 1) CALL XABORT(NAMSBR//': IFMT.NE.1') + ITRKT=1 + IRENOT=1 + DO ICOM=1,NCOMNT + READ(IFTRK) COMNT + IF(COMNT(1:12) .EQ. 'TRKNOR ' ) THEN + IF(COMNT(15:26) .EQ. 'Directional ' ) THEN + IRENOT=-1 + ELSE IF(COMNT(15:26) .EQ. 'Global ' ) THEN + IRENOT=0 + ENDIF + ELSE IF(COMNT(1:12) .EQ. 'OPTION ' ) THEN + IF(COMNT(15:26) .EQ. 'Extended ' ) THEN + ITRKT=0 + ENDIF + ENDIF + ENDDO + IF(ITRKT .NE .0) CALL XABORT(NAMSBR// + >': Insufficient information on tracking file'// + >' Use EDIT -1000 in NXT:') + READ(IFTRK) NDIM,ISPEC,NREG,NSOUT,NALBG,NCOR,NANGL,MXSUB,MXSEG + READ(IFTRK) KK + ALLOCATE(MATALB(-NSOUT:NREG)) + READ(IFTRK) (MATALB(II),II=-NSOUT,NREG) + DO II=1,4 + READ(IFTRK) KK + ENDDO + NSKTRK=NCOMNT+8 + REWIND(IFTRK) +*---- +* Initialize tracking parameters to 0 +*---- + ISTATT(:NSTATE)=0 + IEDIMG(:NSTATE)=0 +*---- +* Read state vectors +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATT) + CALL LCMGTC(IPTRK,'TITLE',72,TITLE) + IF(ISTATT( 7) .NE. 4) CALL XABORT(NAMSBR// + >': Tracking data structure incompatible with current module') + NSUR=ISTATT(5) + IRENOT=ISTATT(8) + MXSEG=MAX(MXSEG,ISTATT(18)) + CALL LCMSIX(IPTRK,'NXTRecords ',ILCMUP) + CALL LCMGET(IPTRK,'G00000001DIM',IEDIMG) + IF(ISTATT( 1) .NE. NREG .OR. + > ISTATT( 5) .NE. NSOUT .OR. + > ISTATT(21) .NE. NANGL .OR. + > IEDIMG( 1) .NE. NDIM ) THEN + WRITE(IOUT,9000) ISTATT( 1),NREG ,ISTATT( 5),NSOUT, + > ISTATT(21),NANGL, + > IEDIMG( 1),NDIM + CALL XABORT(NAMSBR// + >': Tracking data structure and file do mot match') + ENDIF + ITGEO=ABS(IEDIMG( 2)) + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6000) NAMSBR,NREG,NSOUT,NANGL,NDIM,ITGEO + ENDIF + NBUCEL=IEDIMG( 5) + NUCELL(1)=IEDIMG(13) + NUCELL(2)=IEDIMG(14) + NUCELL(3)=IEDIMG(15) + MAXMSH =IEDIMG(16) + MAXMSP =IEDIMG(20) + NFSUR =IEDIMG(22) + NFREG =IEDIMG(23) + MXGREG =IEDIMG(25) + MAXMDH=MAX(MAXMSH,MAXMSP,MXGREG) + ALLOCATE(DGMESH((MAXMDH+2)*4)) + CALL TLMGEO(IPTRK,IPMAT,IPRINT,ITGEO,MAXMDH,NDIM,NUCELL, + > DGMESH,XYZL) + ALLOCATE(DANGLT(NDIM*NANGL)) + CALL LCMGET(IPTRK,'TrackingDirc',DANGLT) + NBDR=1 + IF(IRENOT .EQ. -1) NBDR=NBDR+NANGL + ALLOCATE(DVNOR(NREG,NBDR),DVNOR1(NFREG,NBDR)) + DVNOR1(:NFREG,:NBDR)=DONE + IF(IRENOT .EQ. -1) THEN + CALL LCMGET(IPTRK,'VTNormalizeD',DVNOR1(1,2)) + ELSE IF(IRENOT .EQ. 0) THEN + CALL LCMGET(IPTRK,'VTNormalize ',DVNOR1(1,1)) + ENDIF +*---- +* Merge normalization factors +*---- + CALL LCMLEN(IPTRK,'NumMerge ',ILONG,ITYLCM) + IF(ILONG.EQ.NFREG) THEN + ALLOCATE(VOMER1(NFREG),NUMERG(NFREG),VOMERG(NREG)) + CALL LCMGET(IPTRK,'VolMerge ',VOMER1) + CALL LCMGET(IPTRK,'NumMerge ',NUMERG) + VOMERG(:NREG)=DZERO + DVNOR(:NREG,:NBDR)=DZERO + DO II=1,NFREG + KK=NUMERG(II) + IF(KK.EQ.0) CYCLE + IF(KK.GT.NREG) CALL XABORT(NAMSBR//': DVNOR overflow') + VOMERG(KK)=VOMERG(KK)+VOMER1(II) + DVNOR(KK,:)=DVNOR(KK,:)+DVNOR1(II,:)*VOMER1(II) + ENDDO + DO II=1,NREG + DVNOR(II,:)=DVNOR(II,:)/VOMERG(II) + ENDDO + DEALLOCATE(VOMERG,NUMERG,VOMER1) + ELSE + IF(NREG.NE.NFREG) CALL XABORT(NAMSBR//': INVALID VALUE OF NREG') + DVNOR(:,:)=DVNOR1(:,:) + ENDIF + DEALLOCATE(DVNOR1) + CALL LCMSIX(IPTRK,'NXTRecords ',ILCMDN) +*---- +* Read IPMAT to end-of-file and +* insert pause if in update mode +*---- + IF(IMMAT .EQ. 1) THEN + 1000 CONTINUE + READ(IPMAT,'(A4)',END=1005) CMAT + GO TO 1000 + 1005 CONTINUE + WRITE(IPMAT,7010) + ENDIF +*---- +* Write execution comments on IPMAT +*---- + WRITE(IPMAT,7000) NAMSBR,HENTRY(IMTRK),HENTRY(IMFTRK),TITLE +*---- +* Loop over PLOTS +*---- + DO IPLOT=1,NPLOTS + IF(ABS(IPLP(1,IPLOT)) .EQ. 1) THEN +*---- +* POINTS +*---- + CALL TLMPNT(IPMAT ,IFTRK ,IPRINT,NSKTRK,NBTR ,NDIM , + > NREG ,NSUR ,MXSUB ,MXSEG ,NANGL ,NBDR , + > NPLOTS,IPLOT ,IPLP ,DANGLT,DVNOR ) + ELSE IF(ABS(IPLP(1,IPLOT)) .EQ. 2) THEN +*---- +* DIRECTIONS +*---- + CALL TLMDIR(IPMAT ,IFTRK ,IPRINT,ISPEC, NSKTRK,NBTR , + > NDIM ,NSOUT, NREG ,MXSUB ,MXSEG ,NANGL , + > NBDR ,NPLOTS,IPLOT ,IPLP ,DANGLT,DVNOR , + > MATALB,LMIX ) + ELSE IF(ABS(IPLP(1,IPLOT)) .EQ. 3) THEN +*---- +* PLANA +* Test if plane is valid +*---- + IVALID=TLMVPL(NDIM,NANGL,NPLOTS,IPLOT,IPLP,DPLP,DANGLT,XYZL) + IF(IVALID . GE. 0) THEN + CALL TLMPLA(IPMAT ,IFTRK ,IPRINT,NSKTRK,NBTR ,NDIM , + > NREG ,MXSUB ,MXSEG ,NANGL ,NBDR ,NPLOTS, + > IPLOT ,IPLP ,DPLP ,DANGLT,DVNOR ) + ENDIF + ELSE IF(ABS(IPLP(1,IPLOT)) .EQ. 4) THEN +*---- +* PLANP +* Test if plane is valid +*---- + IVALID=TLMVPL(NDIM,NANGL,NPLOTS,IPLOT,IPLP, + > DPLP,DANGLT,XYZL) + IF(IVALID . GE. 0) THEN + CALL TLMPLP(IPMAT ,IFTRK ,IPRINT,NSKTRK,NBTR ,NDIM , + > NREG ,MXSUB ,MXSEG ,NANGL ,NBDR ,NPLOTS, + > IPLOT ,IPLP ,DPLP ,DANGLT,DVNOR ) + ENDIF + ELSE IF(ABS(IPLP(1,IPLOT)) .EQ. 5) THEN +*---- +* REGION +*---- + CALL TLMREG(IPMAT ,IFTRK ,IPRINT,NSKTRK,NBTR ,NDIM , + > NSOUT ,NREG ,MXSUB ,MXSEG ,NANGL ,NBDR , + > NPLOTS,IPLOT ,IPLP ,DANGLT,DVNOR ,MATALB, + > LMIX ) + ENDIF + ENDDO +*---- +* Release memory +*---- + DEALLOCATE(DPLP,IPLP,MATALB,DVNOR,DANGLT,DGMESH) +*---- +* Processing finished, return +*---- + RETURN +*---- +* Matlab .m file format +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows '/ + > ' NREG =',I10/ + > ' NSUR =',I10/ + > ' NANGL=',I10/ + > ' NDIM =',I10/ + > ' ITGEO=',I10,10X,'*)') + 7000 FORMAT('%'/ + > '% File generated using : ',6X,A6/ + > '% Tracking structure name : ',A12/ + > '% Tracking file name : ',A12/ + > '% Title : ',A72/ + > '%') + 7010 FORMAT('pause ;') + 9000 FORMAT('NREG =',2I10/ + > 'NSUR =',2I10/ + > 'NANGL=',2I10/ + > 'NDIM =',2I10) + END diff --git a/Dragon/src/TLMDIR.f b/Dragon/src/TLMDIR.f new file mode 100644 index 0000000..3903a2c --- /dev/null +++ b/Dragon/src/TLMDIR.f @@ -0,0 +1,407 @@ +*DECK TLMDIR + SUBROUTINE TLMDIR(IPMAT ,IFTRK ,IPRINT,ISPEC,NSKTRK,NBTR , + > NDIM ,NSOUT, NREG ,MXSUB,MXSEG ,NANGL , + > NBDR ,NPLOTS,IPLOT ,IPLP ,DANGLT,DVNOR , + > MATALB,LMIX ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To generate the Matlab instruction for drawing the +* lines for the directions selected. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* C. Plamondon, G. Marleau +* +*Parameters: input +* IPMAT pointer to Matlab-m file. +* IFTRK pointer to the TRACKING file. +* IPRINT print level. +* ISPEC type of boundary (=0 TISO; =1 TSPC). +* NSKTRK number of records to skip on track file before tracking +* lines can be extracted. +* NBTR number of tracks. +* NDIM number of dimensions for problem. +* NSOUT number of surfaces for problem. +* NREG number of regions for problem. +* MXSUB maximum number of subtracks in a line. +* MXSEG maximum number of segments in a line. +* NANGL number of direction for tracking. +* NBDR number of direction for volume normalization. +* NPLOTS number of plots. +* IPLOT plot number being processed. +* IPLP integer plot parameters. +* DANGLT track directions. +* DVNOR track normalization factor for regional volumes. +* MATALB surface direction and region material identification array. +* LMIX flag set to .true. to draw mixture lines. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPMAT,IFTRK + INTEGER IPRINT,ISPEC,NSKTRK,NBTR,NDIM,NSOUT,NREG,MXSUB, + > MXSEG,NANGL,NBDR,NPLOTS,IPLOT + INTEGER IPLP(6,NPLOTS),MATALB(-NSOUT:NREG) + DOUBLE PRECISION DANGLT(NDIM,NANGL),DVNOR(NREG,NBDR) + LOGICAL LMIX +*---- +* Local parameters +*---- + INTEGER IOUT + LOGICAL LNEW + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='TLMDIR') +*---- +* Local variables for tracking file +*---- + INTEGER ILINE,IDUM,NSUB,NBSEG,NTLINE,ISEG,IPLANE,IPTA2, + > IPTA3 + DOUBLE PRECISION WEIGHT +*---- +* Other local variables +*---- + INTEGER IREG,ILREG,ILSUR,IDIR,ISV,IDL,IPL,IU,IV,IPM, + > ITRACE,II,ISUB + DOUBLE PRECISION DXYZ(3,2),FLEN + CHARACTER TITLE*36 +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NUMERO,KANGL + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: LENGTH + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: TORIG +*---- +* Scratch storage allocation +* NUMERO region/surface identification number for segment. +* LENGTH segment length. +*---- + ALLOCATE(NUMERO(MXSEG),LENGTH(MXSEG),KANGL(MXSUB), + > TORIG(NDIM,MXSUB)) +*---- +* Processing starts: +* print routine opening header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 1) WRITE(IOUT,6000) NAMSBR +*---- +* Print IPMAT header +*---- + IDL=IPLP(2,IPLOT) + IPL=IPLP(3,IPLOT) + IU=IPLP(4,IPLOT) + IV=IPLP(5,IPLOT) + WRITE(TITLE,'(A4,I4,A7,I1,A4,I6,A4,I6)') + >'Dir=',IDL,' Plane=',IPL,' IU=',IU,' IV=',IV + IF(LMIX) THEN + WRITE(IPMAT,7000) NAMSBR,TITLE,MAXVAL(MATALB(1:NREG))+1 + ELSE + WRITE(IPMAT,7000) NAMSBR,TITLE,NREG + ENDIF +*---- +* Print matlab instructions for line segment +*---- + DO IREG=1,NREG + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6002) IREG + ENDIF + DO ILINE=1,NSKTRK + READ(IFTRK) IDUM + ENDDO + ILREG=0 +*---- +* Scan over lines +*---- + DO ILINE=1,NBTR + READ(IFTRK) NSUB,NBSEG,WEIGHT, + > (KANGL(II),II=1,NSUB), + > (NUMERO(ISEG),ISEG=1,NBSEG), + > (LENGTH(ISEG),ISEG=1,NBSEG), + > NTLINE,IPLANE,IPTA2,IPTA3, + > ((TORIG(IDIR,ISUB),IDIR=1,NDIM),ISUB=1,NSUB) + IF(ISPEC.EQ.0) THEN + IF(NSUB.NE.1) CALL XABORT(NAMSBR//': NSUB.NE.1') + DO IDIR=1,NDIM + DXYZ(IDIR,1)=TORIG(IDIR,1) + ENDDO + ITRACE=0 + IF(IDL .EQ. 0 .OR. IDL .EQ. KANGL(1) ) THEN + IF(NDIM .EQ. 2) THEN + ITRACE=1 + ELSE + IF(IPL .EQ. 0 .OR. IPL .EQ. IPLANE) THEN + IF(IU .GT. 0) THEN + IF(IU .EQ. IPTA2) ITRACE=1 + ELSE IF(IV .GT. 0) THEN + IF(IV .EQ. IPTA3) ITRACE=1 + ELSE + ITRACE=1 + ENDIF + ENDIF + ENDIF + ENDIF + DO ISEG=1,NBSEG + ISV=NUMERO(ISEG) + IF(ISV .GT. 0) THEN + IF(NBDR.EQ.1) THEN + FLEN=LENGTH(ISEG)/DVNOR(ISV,1) + ELSE + FLEN=LENGTH(ISEG)/DVNOR(ISV,KANGL(1)+1) + ENDIF + DO IDIR=1,NDIM + DXYZ(IDIR,2)=DXYZ(IDIR,1)+DANGLT(IDIR,KANGL(1))*FLEN + ENDDO + IF(IREG .EQ. ISV .AND. ITRACE .EQ. 1) THEN + ILREG=ILREG+1 + IF(ILREG .EQ. 1) WRITE(IPMAT,7002) + WRITE(IPMAT,7004) + > ((DXYZ(IDIR,IPM),IPM=1,2),IDIR=1,NDIM), + > FLOAT(ILINE),FLOAT(ISEG),LENGTH(ISEG) + ENDIF + DO IDIR=1,NDIM + DXYZ(IDIR,1)=DXYZ(IDIR,2) + ENDDO + ENDIF + ENDDO + ELSE IF(ISPEC.EQ.1) THEN + ISUB=0 + LNEW=.TRUE. + DO ISEG=1,NBSEG + ISV=NUMERO(ISEG) + IF(ISV.GT.0) THEN + IF(LNEW) THEN + ISUB=ISUB+1 + IF(ISUB.GT.NSUB) CALL XABORT(NAMSBR// + > ': NSUB overflow') + DO IDIR=1,NDIM + DXYZ(IDIR,1)=TORIG(IDIR,ISUB) + ENDDO + LNEW=.FALSE. + ENDIF + IF(NBDR.EQ.1) THEN + FLEN=LENGTH(ISEG)/DVNOR(ISV,1) + ELSE + FLEN=LENGTH(ISEG)/DVNOR(ISV,KANGL(ISUB)+1) + ENDIF + DO IDIR=1,NDIM + DXYZ(IDIR,2)=DXYZ(IDIR,1)+DANGLT(IDIR,KANGL(ISUB))*FLEN + ENDDO + IF(IREG .EQ. ISV) THEN + ILREG=ILREG+1 + IF(ILREG .EQ. 1) WRITE(IPMAT,7002) + IF(IDL .EQ. 0 .OR. IDL .EQ. KANGL(ISUB)) THEN + WRITE(IPMAT,7004) + > ((DXYZ(IDIR,IPM),IPM=1,2),IDIR=1,NDIM), + > FLOAT(ILINE),FLOAT(ISEG),LENGTH(ISEG) + ENDIF + ENDIF + DO IDIR=1,NDIM + DXYZ(IDIR,1)=DXYZ(IDIR,2) + ENDDO + ELSE + LNEW=.TRUE. + ENDIF + ENDDO + IF(ISUB.NE.NSUB) CALL XABORT(NAMSBR//': Algorithm failure') + ENDIF + ENDDO +*---- +* Write Matlab commands to trace lines +*---- + IF(ILREG .GE. 1) THEN + WRITE(IPMAT,7003) + IF(LMIX) THEN + IF(NDIM .EQ. 2) THEN + WRITE(IPMAT,7012) MATALB(IREG)+1 + ELSE + WRITE(IPMAT,7013) MATALB(IREG)+1 + ENDIF + ELSE + IF(NDIM .EQ. 2) THEN + WRITE(IPMAT,7012) IREG + ELSE + WRITE(IPMAT,7013) IREG + ENDIF + ENDIF +*---- +* Change colour for next region +*---- + WRITE(IPMAT,7090) + IF(IREG .NE. NREG) THEN + IF(IPLP(1,IPLOT) .GT. 0) WRITE(IPMAT,7091) + ENDIF + ENDIF + REWIND IFTRK + ENDDO + IF(IPLP(6,IPLOT) .EQ. 0) WRITE(IPMAT,7093) + WRITE(IPMAT,7091) +*---- +* Print matlab instructions for surface points +*---- + IF(IPLP(6,IPLOT) .EQ. 1) THEN + DO ILINE=1,NSKTRK + READ(IFTRK) IDUM + ENDDO + ILSUR=0 +*---- +* Scan over lines +*---- + DO ILINE=1,NBTR + READ(IFTRK) NSUB,NBSEG,WEIGHT, + > (KANGL(II),II=1,NSUB), + > (NUMERO(ISEG),ISEG=1,NBSEG), + > (LENGTH(ISEG),ISEG=1,NBSEG), + > NTLINE,IPLANE,IPTA2,IPTA3, + > ((TORIG(IDIR,ISUB),IDIR=1,NDIM),ISUB=1,NSUB) + IF(ISPEC.EQ.0) THEN + IF(NSUB.NE.1) CALL XABORT(NAMSBR//': NSUB.NE.1') + DO IDIR=1,NDIM + DXYZ(IDIR,1)=TORIG(IDIR,1) + ENDDO + ITRACE=0 + IF(IDL .EQ. 0 .OR. IDL .EQ. KANGL(1) ) THEN + IF(NDIM .EQ. 2) THEN + ITRACE=1 + ELSE + IF(IPL .EQ. 0 .OR. IPL .EQ. IPLANE) THEN + IF(IU .GT. 0) THEN + IF(IU .EQ. IPTA2) ITRACE=1 + ELSE IF(IV .GT. 0) THEN + IF(IV .EQ. IPTA3) ITRACE=1 + ELSE + ITRACE=1 + ENDIF + ENDIF + ENDIF + ENDIF + DO ISEG=1,NBSEG + ISV=NUMERO(ISEG) + IF(ISV .LT. 0) THEN + IF(ITRACE .EQ. 1) THEN + ILSUR=ILSUR+1 + IF(ILSUR .EQ. 1) WRITE(IPMAT,7005) + WRITE(IPMAT,7004) + > (DXYZ(IDIR,1),IDIR=1,NDIM), + > FLOAT(ILINE),FLOAT(ISEG),LENGTH(ISEG) + ENDIF + ELSE IF(ISV .GT. 0) THEN + IF(NBDR.EQ.1) THEN + FLEN=LENGTH(ISEG)/DVNOR(ISV,1) + ELSE + FLEN=LENGTH(ISEG)/DVNOR(ISV,KANGL(1)+1) + ENDIF + DO IDIR=1,NDIM + DXYZ(IDIR,1)=DXYZ(IDIR,1)+DANGLT(IDIR,KANGL(1))*FLEN + ENDDO + ENDIF + ENDDO + ELSE IF(ISPEC.EQ.1) THEN + ISUB=0 + LNEW=.TRUE. + DO ISEG=1,NBSEG + ISV=NUMERO(ISEG) + IF(ISV.GT.0) THEN + IF(LNEW) THEN + ISUB=ISUB+1 + IF(ISUB.GT.NSUB) CALL XABORT(NAMSBR// + > ': NSUB overflow') + DO IDIR=1,NDIM + DXYZ(IDIR,1)=TORIG(IDIR,ISUB) + ENDDO + LNEW=.FALSE. + ENDIF + IF(NBDR.EQ.1) THEN + FLEN=LENGTH(ISEG)/DVNOR(ISV,1) + ELSE + FLEN=LENGTH(ISEG)/DVNOR(ISV,KANGL(ISUB)+1) + ENDIF + DO IDIR=1,NDIM + DXYZ(IDIR,1)=DXYZ(IDIR,1)+DANGLT(IDIR,KANGL(ISUB))*FLEN + ENDDO + ELSE + LNEW=.TRUE. + ENDIF + ENDDO + IF(ISUB.NE.NSUB) CALL XABORT(NAMSBR//': Algorithm failure') + ENDIF + ENDDO +*---- +* Write Matlab commands to trace lines +*---- + WRITE(IPMAT,7003) + IF(NDIM .EQ. 2) THEN + WRITE(IPMAT,7010) + ELSE + WRITE(IPMAT,7011) + ENDIF + WRITE(IPMAT,7092) + WRITE(IPMAT,7093) + WRITE(IPMAT,7091) + REWIND IFTRK + ENDIF +*---- +* Processing finished, return +*---- + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(TORIG,KANGL,LENGTH,NUMERO) + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6002 FORMAT(' Processing lines for region = ',I8) +*---- +* Matlab .m file format +*---- + 7000 FORMAT('%'/'% Output from ',A6/'%'/ + >'hold on;'/7Htitle(',A36,3H');/9Hxcol=jet(,i5,2H);) + 7002 FORMAT('TLMIntegrationLines=[') + 7003 FORMAT(12X,'];') + 7004 FORMAT(9F18.10) + 7005 FORMAT('TLMSurfacePoints=[') + 7010 FORMAT('plot(TLMSurfacePoints(:,1),', + > 'TLMSurfacePoints(:,2),',6H'k.');) + 7011 FORMAT('plot3(TLMSurfacePoints(:,1),', + > 'TLMSurfacePoints(:,2),', + > 'TLMSurfacePoints(:,3),',6H'k.');) + 7012 FORMAT('[m,n]=size(TLMIntegrationLines);'/ + > 'idreg=',I5,';'/ + > 'for i=1:m'/ + > ' TLMcolorset=line([TLMIntegrationLines(i,1),', + > 'TLMIntegrationLines(i,2)],', + > '[TLMIntegrationLines(i,3),', + > 'TLMIntegrationLines(i,4)]);'/ + > ' set(TLMcolorset,',8H'Color',,'xcol(idreg,:));'/ + > 'end;') + 7013 FORMAT('[m,n]=size(TLMIntegrationLines);'/ + > 'idreg=',I5,';'/ + > 'for i=1:m'/ + > ' TLMcolorset=line([TLMIntegrationLines(i,1),', + > 'TLMIntegrationLines(i,2)],', + > '[TLMIntegrationLines(i,3),', + > 'TLMIntegrationLines(i,4)],', + > '[TLMIntegrationLines(i,5),', + > 'TLMIntegrationLines(i,6)]);'/ + > ' set(TLMcolorset,',8H'Color',,'xcol(idreg,:));'/ + > 'end;') + 7090 FORMAT('clear TLMIntegrationLines TLMcolorset ;') + 7091 FORMAT('pause ;') + 7092 FORMAT('clear TLMSurfacePoints ;') + 7093 FORMAT('hold off;') + END diff --git a/Dragon/src/TLMGEO.f b/Dragon/src/TLMGEO.f new file mode 100644 index 0000000..4f297fa --- /dev/null +++ b/Dragon/src/TLMGEO.f @@ -0,0 +1,206 @@ +*DECK TLMGEO + SUBROUTINE TLMGEO(IPTRK,IPMAT,IPRINT,ITGEO,MAXMDH,NDIM,NUCELL, + > DGMESH,XYZL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To generate the Matlab instruction for drawing the global geometry. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* C. Plamondon, G. Marleau +* +*Parameters: input +* IPTRK tracking data structure. +* IPMAT pointer to Matlab-m file. +* IPRINT print level. +* ITGEO type of geometry (0 for annular; 1 for Cartesian; +* 2 for hexagonal). +* MAXMDH maximum dimensions of DGMESH. +* NDIM number of dimensions for problem. +* NUCELL cell dimensions for each direction. +* DGMESH mesh of global beometry. +* +*Parameters: output +* XYZL mesh limits. +* +*---------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPTRK + INTEGER IPMAT + INTEGER IPRINT,ITGEO,MAXMDH,NDIM + INTEGER NUCELL(NDIM) + DOUBLE PRECISION DGMESH(-1:MAXMDH,4),XYZL(2,3) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='TLMGEO') + DOUBLE PRECISION DZERO + PARAMETER (DZERO=0.0D0) +*---- +* Other local variables +*---- + INTEGER IDIR,NX,NY,NZ,IPT,IH + CHARACTER NAMREC*12 + DOUBLE PRECISION POSHRX(7),POSHRY(7),POSHDX(7),POSHDY(7), + > ROTMAT(2,2) +*---- +* Data +*---- + CHARACTER CDIR(4)*1 + SAVE CDIR + DATA CDIR /'X','Y','Z','R'/ +*---- +* Processing starts: +* print routine opening header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF + DO IDIR=1,NDIM + NAMREC='G00000001SM'//CDIR(IDIR) + IF(ITGEO .EQ. 2) THEN + CALL LCMGET(IPTRK,NAMREC,DGMESH(0,IDIR)) + ELSE + CALL LCMGET(IPTRK,NAMREC,DGMESH(0,IDIR)) + XYZL(1,IDIR)=DGMESH(0,IDIR) + XYZL(2,IDIR)=DGMESH(NUCELL(IDIR),IDIR) + ENDIF + ENDDO + WRITE(IPMAT,7000) + NX=NUCELL(1) + NY=NUCELL(2) +* write(6,*) 'ITGEO,NDIM=',ITGEO,NDIM,NX,NY +* write(6,*) 'DGMESHx=',(DGMESH(IH,1),IH=-1,NX) +* write(6,*) 'DGMESHy=',(DGMESH(IH,2),IH=-1,NX) +*---- +* For hexagon, find reference corner positions +*---- + IF(ABS(ITGEO) .EQ. 2) THEN +* IF(ITGEO .EQ. 2) THEN +*---- +* One side parallel to x-axis +*---- +* POSHRX(1)=DGMESH(0,1) +* POSHRY(1)=DZERO +* ELSE +*---- +* One side parallel to y-axis +*---- + POSHRX(1)=DZERO + POSHRY(1)=DGMESH(0,2) +* ENDIF + ROTMAT(1,1)=0.5D0 + ROTMAT(2,1)=SQRT(3.0D0)/2.0D0 + ROTMAT(1,2)=-ROTMAT(2,1) + ROTMAT(2,2)=ROTMAT(1,1) + DO IPT=2,7 + POSHRX(IPT)=ROTMAT(1,1)*POSHRX(IPT-1) + > +ROTMAT(1,2)*POSHRY(IPT-1) + POSHRY(IPT)=ROTMAT(2,1)*POSHRX(IPT-1) + > +ROTMAT(2,2)*POSHRY(IPT-1) + ENDDO + WRITE(IPMAT,7040) CDIR(1),NX + WRITE(IPMAT,7040) CDIR(2),NX + IF(NDIM .EQ. 3) THEN + WRITE(IPMAT,7040) CDIR(3),NZ + ENDIF + DO IH=1,NX + DO IPT=1,7 + POSHDX(IPT)=POSHRX(IPT)+DGMESH(IH,1) + POSHDY(IPT)=POSHRY(IPT)+DGMESH(IH,2) + ENDDO + WRITE(IPMAT,7041) CDIR(1),IH,(POSHDX(IPT),IPT=1,7) + WRITE(IPMAT,7041) CDIR(2),IH,(POSHDY(IPT),IPT=1,7) + ENDDO + ENDIF +*---- +* Print IPMAT header +*---- + IF(NDIM .EQ. 2) THEN + IF(ITGEO .EQ. 2) THEN + DO IH=1,NX + WRITE(IPMAT,7042) IH,IH + ENDDO + ELSE + WRITE(IPMAT,7020) + > DGMESH(0,1),DGMESH(NX,1), + > DGMESH(0,2),DGMESH(NY,2) + WRITE(IPMAT,7021) + ENDIF + ELSE IF(NDIM .EQ. 3) THEN + NZ=NUCELL(3) + WRITE(IPMAT,7001) + IF(ITGEO .EQ. 2) THEN + WRITE(IPMAT,7043) + > DGMESH(1,3),DGMESH(NZ,3) + DO IH=1,NX + WRITE(IPMAT,7042) IH,IH + ENDDO + ELSE + WRITE(IPMAT,7030) + > DGMESH(1,1),DGMESH(NX,1), + > DGMESH(1,2),DGMESH(NY,2), + > DGMESH(1,3),DGMESH(NZ,3) + WRITE(IPMAT,7031) + ENDIF + ENDIF +*---- +* Processing finished, return +*---- + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') +*---- +* Matlab .m file format +*---- + 7000 FORMAT('figure;'/'hold on;'/'axis equal;'/ + >12Hxlabel('x');/12Hylabel('y');) + 7001 FORMAT(12Hzlabel('z');) + 7020 FORMAT('xmin=',F18.10,';'/'xmax=',F18.10,';'/ + > 'ymin=',F18.10,';'/'ymax=',F18.10,';'/) + 7021 FORMAT('line([xmin,xmin],[ymin,ymax]);'/ + > 'line([xmin,xmax],[ymin,ymin]);'/ + > 'line([xmax,xmax],[ymin,ymax]);'/ + > 'line([xmin,xmax],[ymax,ymax]);') + 7030 FORMAT('xmin=',F18.10,';'/'xmax=',F18.10,';'/ + > 'ymin=',F18.10,';'/'ymax=',F18.10,';'/ + > 'zmin=',F18.10,';'/'zmax=',F18.10,';'/) + 7031 FORMAT('line([xmin,xmin],[ymin,ymax],[zmin,zmin]);'/ + > 'line([xmin,xmax],[ymin,ymin],[zmin,zmin]);'/ + > 'line([xmax,xmax],[ymin,ymax],[zmin,zmin]);'/ + > 'line([xmin,xmax],[ymax,ymax],[zmin,zmin]);'/ + > 'line([xmin,xmin],[ymin,ymin],[zmin,zmax]);'/ + > 'line([xmax,xmax],[ymin,ymin],[zmin,zmax]);'/ + > 'line([xmax,xmax],[ymax,ymax],[zmin,zmax]);'/ + > 'line([xmin,xmin],[ymax,ymax],[zmin,zmax]);'/ + > 'line([xmin,xmin],[ymin,ymax],[zmax,zmax]);'/ + > 'line([xmin,xmax],[ymin,ymin],[zmax,zmax]);'/ + > 'line([xmax,xmax],[ymin,ymax],[zmax,zmax]);'/ + > 'line([xmin,xmax],[ymax,ymax],[zmax,zmax]);') + 7040 FORMAT('HexM',A1,'=zeros(',I4,',7);') + 7041 FORMAT('HexM',A1,'(',I4,',:)=[',7F18.10,'];') + 7042 FORMAT('line(HexMX(',I4,',:),HexMY(',I4,',:));') + 7043 FORMAT('zmin=',F18.10,';'/'zmax=',F18.10,';'/) + END diff --git a/Dragon/src/TLMGET.f b/Dragon/src/TLMGET.f new file mode 100644 index 0000000..03fdb36 --- /dev/null +++ b/Dragon/src/TLMGET.f @@ -0,0 +1,283 @@ +*DECK TLMGET + SUBROUTINE TLMGET(IPRINT,NPLOTS,NDIM ,CARLST, + > IPLP ,DPLP ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To read from the input file the TLM: module processing options. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* G. Marleau +* +*Parameters: input +* IPRINT print level. +* NPLOTS number of plots generated. +* NDIM number of dimensions. +* +*Parameters: input/output +* CARLST last character string read. +* +*Parameters: output +* IPLP integer plot parameters. +* DPLP double precision plot parameters. +* +*Comments: +* Input data is of the form: +* { +* POINTS [NoPause] | +* DIRECTIONS [NoPause] DIR idir [ PLAN iplan { U iu | V iv } ] | +* PLANA [NoPause] A ra B rb [ C rc ] D rd | +* PLANP [NoPause] DIR idir DIST dist [ PLAN iplan ] +* } +* +*---------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + CHARACTER CARLST*72 + INTEGER IPRINT,NPLOTS,NDIM + INTEGER IPLP(6,NPLOTS) + DOUBLE PRECISION DPLP(4,NPLOTS) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='TLMGET') +*---- +* Variables for input via REDGET +*---- + INTEGER ITYPLU,INTLIR + CHARACTER CARLIR*72 + REAL REALIR + DOUBLE PRECISION DBLLIR +*---- +* Local variables +*---- + INTEGER IPLOT +*---- +* Processing starts: +* print routine opening header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF +*---- +* Get data from input file +*---- + IPLP(:6,:NPLOTS)=0 + DPLP(:4,:NPLOTS)=0.0D0 + ITYPLU=3 + CARLIR=CARLST + IPLOT=0 + 100 CONTINUE + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + >': Read error -- Character variable expected') + IF(CARLIR(1:4) .EQ. ';') GO TO 105 + IPLOT=IPLOT+1 + IF(IPLOT .GT. NPLOTS) THEN + WRITE(IOUT,9000) NAMSBR,NPLOTS + 110 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .EQ. 3) THEN + IF(CARLIR(1:4) .EQ. ';') GO TO 105 + ENDIF + GO TO 110 + ENDIF + IF(CARLIR .EQ. 'POINTS') THEN + IPLP(1,IPLOT)=1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + > ': Read error -- Character variable expected') + IF(CARLIR .NE. 'NoPause') GO TO 100 + IPLP(1,IPLOT)=-1 + ELSE IF(CARLIR .EQ. 'DIRECTIONS') THEN + IPLP(1,IPLOT)=2 + 120 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + > ': Read error -- Character variable expected') + IF(CARLIR .EQ. 'DIR') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': Read error -- integer variable expected for DIR') + IPLP(2,IPLOT)=INTLIR + GO TO 120 + ELSE IF(CARLIR .EQ. 'PLAN') THEN + IF(NDIM .EQ. 2) WRITE(IOUT,9001) NAMSBR,CARLIR(1:12) + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': Read error -- integer variable expected for PLAN') + IPLP(3,IPLOT)=INTLIR + GO TO 120 + ELSE IF(CARLIR .EQ. 'U') THEN + IF(NDIM .EQ. 2) WRITE(IOUT,9001) NAMSBR,CARLIR(1:12) + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': Read error -- integer variable expected for U') + IPLP(4,IPLOT)=INTLIR + GO TO 120 + ELSE IF(CARLIR .EQ. 'V') THEN + IF(NDIM .EQ. 2) WRITE(IOUT,9001) NAMSBR,CARLIR(1:12) + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': Read error -- integer variable expected for V') + IPLP(5,IPLOT)=INTLIR + GO TO 120 + ELSE IF(CARLIR .EQ. 'NoPause') THEN + IPLP(1,IPLOT)=-2 + GO TO 120 + ELSE IF(CARLIR .EQ. 'SPoints') THEN + IPLP(6,IPLOT)=1 + GO TO 120 + ELSE + GO TO 100 + ENDIF + ELSE IF(CARLIR .EQ. 'PLANA') THEN + IPLP(1,IPLOT)=3 + 130 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + > ': Read error -- Character variable expected') + IF(CARLIR .EQ. 'A') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .EQ. 2) THEN + DPLP(1,IPLOT)=REALIR + ELSE IF(ITYPLU .EQ. 4) THEN + DPLP(1,IPLOT)=DBLLIR + ELSE + CALL XABORT(NAMSBR// + > ': Read error -- real variable expected for A') + ENDIF + GO TO 130 + ELSE IF(CARLIR .EQ. 'B') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .EQ. 2) THEN + DPLP(2,IPLOT)=REALIR + ELSE IF(ITYPLU .EQ. 4) THEN + DPLP(2,IPLOT)=DBLLIR + ELSE + CALL XABORT(NAMSBR// + > ': Read error -- real variable expected for B') + ENDIF + GO TO 130 + ELSE IF(CARLIR .EQ. 'C') THEN + IF(NDIM .EQ. 2) WRITE(IOUT,9001) NAMSBR,CARLIR(1:12) + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .EQ. 2) THEN + DPLP(3,IPLOT)=REALIR + ELSE IF(ITYPLU .EQ. 4) THEN + DPLP(3,IPLOT)=DBLLIR + ELSE + CALL XABORT(NAMSBR// + > ': Read error -- real variable expected for C') + ENDIF + GO TO 130 + ELSE IF(CARLIR .EQ. 'D') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .EQ. 2) THEN + DPLP(4,IPLOT)=REALIR + ELSE IF(ITYPLU .EQ. 4) THEN + DPLP(4,IPLOT)=DBLLIR + ELSE + CALL XABORT(NAMSBR// + > ': Read error -- real variable expected for D') + ENDIF + GO TO 130 + ELSE IF(CARLIR .EQ. 'NoPause') THEN + IPLP(1,IPLOT)=-3 + GO TO 130 + ELSE + GO TO 100 + ENDIF + ELSE IF(CARLIR .EQ. 'PLANP') THEN + IPLP(1,IPLOT)=4 + 140 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + > ': Read error -- Character variable expected') + IF(CARLIR .EQ. 'DIR') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': Read error -- integer variable expected for DIR') + IPLP(2,IPLOT)=INTLIR + GO TO 140 + ELSE IF(CARLIR .EQ. 'DIST') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .EQ. 2) THEN + DPLP(1,IPLOT)=REALIR + ELSE IF(ITYPLU .EQ. 4) THEN + DPLP(1,IPLOT)=DBLLIR + ELSE + CALL XABORT(NAMSBR// + > ': Read error -- real variable expected for DIST') + ENDIF + GO TO 140 + ELSE IF(CARLIR .EQ. 'PLAN') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(NDIM .EQ. 2) WRITE(IOUT,9001) NAMSBR,CARLIR(1:12) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': Read error -- integer variable expected for PLAN') + IPLP(3,IPLOT)=INTLIR + GO TO 140 + ELSE IF(CARLIR .EQ. 'NoPause') THEN + IPLP(1,IPLOT)=-4 + GO TO 140 + ELSE + GO TO 100 + ENDIF + ELSE IF(CARLIR .EQ. 'REGIONS') THEN + IPLP(1,IPLOT)=5 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .EQ. 1) THEN + IPLP(2,IPLOT)=INTLIR + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + GO TO 100 + ENDIF + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + > ': Read error -- Character variable expected') + IF(CARLIR .NE. 'NoPause') GO TO 100 + IPLP(1,IPLOT)=-5 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .EQ. 1) THEN + IPLP(2,IPLOT)=INTLIR + ENDIF + ELSE + CALL XABORT(NAMSBR//': Keyword '//CARLIR(1:12)//' is invalid.') + ENDIF + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + GO TO 100 + 105 CONTINUE + CARLST=CARLIR +*---- +* Processing finished, return +*---- + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') +*---- +* Warning formats +*---- + 9000 FORMAT(1X,'Warning from ',A6,2X,'Number of plots exceeded'/ + >1X,'Only first ',I10,1X,'plots considered') + 9001 FORMAT(1X,'Warning from ',A6,2X,'Invalid keyword '/ + >1X,'Keyword : ',A12,1X,'Not used in 2-D') + END diff --git a/Dragon/src/TLMPLA.f b/Dragon/src/TLMPLA.f new file mode 100644 index 0000000..b45dfe3 --- /dev/null +++ b/Dragon/src/TLMPLA.f @@ -0,0 +1,254 @@ +*DECK TLMPLA + SUBROUTINE TLMPLA(IPMAT ,IFTRK ,IPRINT,NSKTRK,NBTR ,NDIM , + > NREG ,MXSUB ,MXSEG ,NANGL ,NBDR ,NPLOTS, + > IPLOT ,IPLP ,DPLP ,DANGLT,DVNOR ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To generate the Matlab instruction for drawing the +* intersections between the lines and an arbitrary plane +* in 3 D or a line in 2D. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* C. Plamondon, G. Marleau +* +*Parameters: input +* IPMAT pointer to Matlab-m file. +* IFTRK pointer to the TRACKING file. +* IPRINT print level. +* NSKTRK number of records to skip on track file before tracking +* lines can be extracted. +* NBTR numbre of tracks. +* NDIM number of dimensions for problem. +* NREG number of regions for problem. +* MXSUB maximum number of subtracks in a line. +* MXSEG maximum number of segments in a line. +* NANGL number of direction for tracking. +* NBDR number of direction for volume normalization. +* NPLOTS number of plots. +* IPLOT plot number being processed. +* IPLP integer plot parameters. +* DPLP real plot parameters. +* DANGLT track directions. +* DVNOR track normalization factor for regional volumes. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPMAT,IFTRK + INTEGER IPRINT,NSKTRK,NBTR,NDIM,NREG,MXSUB,MXSEG, + > NANGL,NBDR,NPLOTS,IPLOT + INTEGER IPLP(6,NPLOTS) + DOUBLE PRECISION DPLP(4,NPLOTS),DANGLT(NDIM,NANGL), + > DVNOR(NREG,NBDR) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='TLMPLA') + DOUBLE PRECISION DZERO,DONE + PARAMETER (DZERO=0.0D0,DONE=1.0D0) +*---- +* Local variables for tracking file +*---- + INTEGER ILINE,IDUM,NBSEG,NTLINE,ISEG, + > IPLANE,IPTA2,IPTA3,NSUB,ISUB,II + DOUBLE PRECISION WEIGHT +*---- +* Other local variables +*---- + INTEGER IDIR,IREG,ILREG,ISV ,ITRACE + CHARACTER TITLE*66 + DOUBLE PRECISION DXYZ(3),FLEN + DOUBLE PRECISION NUMER,DENOM,DINT,DINP(2),DPLPT(4) +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NUMERO,KANGL + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: LENGTH + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: TORIG +*---- +* Data +*---- + CHARACTER ACOL(0:6)*2 + DATA ACOL /'b.','g.','r.','c.','m.','y.','k.'/ +*---- +* Scratch storage allocation +* NUMERO region/surface identification number for segment. +* LENGTH segment length. +*---- + ALLOCATE(NUMERO(MXSEG),LENGTH(MXSEG)) + ALLOCATE(KANGL(MXSUB),TORIG(NDIM,MXSUB)) +*---- +* Processing starts: +* print routine opening header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF +*---- +* Print IPMAT header +*---- + DO IDIR=1,4 + DPLPT(IDIR)=DPLP(IDIR,IPLOT) + ENDDO + IF(NDIM .EQ. 2) THEN + WRITE(TITLE,'(A22,4(1X,A2,F8.2))') + > 'Lines crossing plane= ', + > 'A=',DPLPT(1),'B=',DPLPT(2),'D=',DPLPT(4) + WRITE(IPMAT,7000) NAMSBR,TITLE + ELSE IF(NDIM .EQ. 3) THEN + WRITE(TITLE,'(A22,4(1X,A2,F8.2))') + > 'Lines crossing plane= ', + > 'A=',DPLPT(1),'B=',DPLPT(2),'C=',DPLPT(3),'D=',DPLPT(4) + WRITE(IPMAT,7000) NAMSBR,TITLE + ENDIF +*---- +* Print matlab instructions for line segment +*---- + DO IREG=1,NREG + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6002) IREG + ENDIF + DO ILINE=1,NSKTRK + READ(IFTRK) IDUM + ENDDO + ILREG=0 +*---- +* Scan over lines +*---- + DO ILINE=1,NBTR + READ(IFTRK) NSUB,NBSEG,WEIGHT, + > (KANGL(II),II=1,NSUB), + > (NUMERO(ISEG),ISEG=1,NBSEG), + > (LENGTH(ISEG),ISEG=1,NBSEG), + > NTLINE,IPLANE,IPTA2,IPTA3, + > ((TORIG(IDIR,ISUB),IDIR=1,NDIM),ISUB=1,NSUB) + IF(NSUB.NE.1) CALL XABORT(NAMSBR// + >': Cyclic tracks not permitted for option PLANA') +*---- +* find location of first intersection between line and geometry +*---- + ISUB=1 + DO IDIR=1,NDIM + DXYZ(IDIR)=TORIG(IDIR,ISUB) + ENDDO +*---- +* For surface A*X+B*Y+C*Z=D +* and line +* X=X0+R*DANGLT(1) +* Y=Y0+R*DANGLT(2) +* Y=Z0+R*DANGLT(3) +* Intersection must satisfy: +* A*R*DANGLT(1)+B*R*DANGLT(2)+C*R*DANGLT(3)=D +* R=(D-A*X0-B*Y0-C*Z0)/(A*DANGLT(1)+B*DANGLT(2)+C*DANGLT(3)) +*---- + NUMER=DPLPT(4) + DENOM=DZERO + DO IDIR=1,NDIM + DENOM=DENOM+DPLPT(IDIR)*DANGLT(IDIR,KANGL(1)) + NUMER=NUMER-DPLPT(IDIR)*DXYZ(IDIR) + ENDDO + IF(DENOM .NE. DZERO) THEN +*---- +* DINT=+/- R +*---- + DINT=NUMER/DENOM + DINP(1)=DZERO + DO ISEG=1,NBSEG + ISV=NUMERO(ISEG) + IF(ISV .GT. 0) THEN + FLEN=LENGTH(ISEG)/DVNOR(ISV,1) + IF(NBDR .GT. 1) THEN + FLEN=LENGTH(ISEG)/DVNOR(ISV,KANGL(1)+1) + ENDIF + DINP(2)=DINP(1)+FLEN + ITRACE=0 + IF(DINP(1) .LE. DINT .AND. DINT .LE. DINP(2)) THEN + DO IDIR=1,NDIM + DXYZ(IDIR)=DXYZ(IDIR)+DANGLT(IDIR,KANGL(1))*DINT + ENDDO + ITRACE=1 + ENDIF + IF(ITRACE .EQ. 1) THEN + IF(ISV .EQ. IREG) THEN + ILREG=ILREG+1 + IF(ILREG .EQ. 1) THEN + WRITE(IPMAT,7002) + ENDIF + WRITE(IPMAT,7004) + > (DXYZ(IDIR),IDIR=1,NDIM),ILINE + ENDIF + GO TO 100 + ENDIF + DINP(1)=DINP(2) + ENDIF + ENDDO + 100 CONTINUE + ENDIF + ENDDO +*---- +* Write Matlab commands to print points +*---- + IF(ILREG .GE. 1) THEN + WRITE(IPMAT,7003) + IF(NDIM .EQ. 2) THEN + WRITE(IPMAT,7010) ACOL(MOD(IREG,7)) + ELSE + WRITE(IPMAT,7011) ACOL(MOD(IREG,7)) + ENDIF + WRITE(IPMAT,7090) + IF(IPLP(1,IPLOT) .GT. 0) WRITE(IPMAT,7091) + ENDIF + REWIND IFTRK + ENDDO + WRITE(IPMAT,7093) + IF(IPLP(1,IPLOT) .LT. 0) WRITE(IPMAT,7091) +*---- +* Processing finished, return +*---- + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(KANGL,TORIG) + DEALLOCATE(LENGTH,NUMERO) + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6002 FORMAT(' Processing lines for region = ',I8) +*---- +* Matlab .m file format +*---- + 7000 FORMAT('%'/'% Output from ',A6/'%'/ + >'%figure;'/'hold on;'/7Htitle(',A66,3H');) + 7002 FORMAT('TLMSurfacePoints=[') + 7003 FORMAT(12X,'];') + 7004 FORMAT(3F18.10,2X,I10) + 7010 FORMAT('plot(TLMSurfacePoints(:,1),', + > 'TLMSurfacePoints(:,2),',1H',A2,3H');) + 7011 FORMAT('plot3(TLMSurfacePoints(:,1),', + > 'TLMSurfacePoints(:,2),', + > 'TLMSurfacePoints(:,3),',1H',A2,3H');) + 7090 FORMAT('clear TLMSurfacePoints;') + 7091 FORMAT('pause ;') + 7093 FORMAT('hold off;') + END diff --git a/Dragon/src/TLMPLP.f b/Dragon/src/TLMPLP.f new file mode 100644 index 0000000..fd50c22 --- /dev/null +++ b/Dragon/src/TLMPLP.f @@ -0,0 +1,271 @@ +*DECK TLMPLP + SUBROUTINE TLMPLP(IPMAT ,IFTRK ,IPRINT,NSKTRK,NBTR ,NDIM , + > NREG ,MXSUB ,MXSEG ,NANGL ,NBDR ,NPLOTS, + > IPLOT ,IPLP ,DPLP ,DANGLT,DVNOR ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To generate the Matlab instruction for drawing the +* intersections between the lines and an plane (3D) or a line (2D) +* normal to the line directon. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* C. Plamondon, G. Marleau +* +*Parameters: input +* IPMAT pointer to Matlab-m file. +* IFTRK pointer to the TRACKING file. +* IPRINT print level. +* NSKTRK number of records to skip on track file before tracking +* lines can be extracted. +* NBTR numbre of tracks. +* NDIM number of dimensions for problem. +* NREG number of regions for problem. +* MXSUB maximum number of subtracks in a line. +* MXSEG maximum number of segments in a line. +* NANGL number of direction for tracking. +* NBDR number of direction for volume normalization. +* NPLOTS number of plots. +* IPLOT plot number being processed. +* IPLP integer plot parameters. +* DPLP real plot parameters. +* DANGLT track directions. +* DVNOR track normalization factor for regional volumes. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPMAT,IFTRK + INTEGER IPRINT,NSKTRK,NBTR,NDIM,NREG,MXSUB,MXSEG, + > NANGL,NBDR,NPLOTS,IPLOT + INTEGER IPLP(6,NPLOTS) + DOUBLE PRECISION DPLP(4,NPLOTS),DANGLT(NDIM,NANGL), + > DVNOR(NREG,NBDR) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='TLMPLP') + DOUBLE PRECISION DZERO,DONE + PARAMETER (DZERO=0.0D0,DONE=1.0D0) +*---- +* Local variables for tracking file +*---- + INTEGER ILINE,IDUM,NBSEG,NTLINE,ISEG, + > IPLANE,IPTA2,IPTA3,NSUB,ISUB,II + DOUBLE PRECISION WEIGHT +*---- +* Other local variables +*---- + INTEGER IDIR,IREG,ILREG,ISV,IDL,IPL,IFDL,ILDL + CHARACTER TITLE*66 + DOUBLE PRECISION DXYZ(3),FLEN + DOUBLE PRECISION NUMER,DENOM,DINT,DINP(2),DPLPT(4) +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NUMERO,KANGL + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: LENGTH + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: TORIG +*---- +* Data +*---- + CHARACTER ACOL(0:6)*2 + DATA ACOL /'b.','g.','r.','c.','m.','y.','k.'/ +*---- +* Scratch storage allocation +* NUMERO region/surface identification number for segment. +* LENGTH segment length. +*---- + ALLOCATE(NUMERO(MXSEG),LENGTH(MXSEG)) + ALLOCATE(KANGL(MXSUB),TORIG(NDIM,MXSUB)) +*---- +* Processing starts: +* print routine opening header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF +*---- +* Print IPMAT header +*---- + IDL=IPLP(2,IPLOT) + IPL=IPLP(3,IPLOT) + IF(IDL .EQ. 0) THEN + IFDL=1 + ILDL=NANGL + ELSE + IFDL=IDL + ILDL=IDL + ENDIF + DO IDL=IFDL,ILDL + DO IDIR=1,NDIM + DPLPT(IDIR)=DANGLT(IDIR,IDL) + ENDDO + DO IDIR=NDIM+1,3 + DPLPT(IDIR)=DZERO + ENDDO + DPLPT(4)=DPLP(4,IPLOT) + IF(NDIM .EQ. 2) THEN + WRITE(TITLE,'(A22,1P,4(1X,A2,F8.2))') + > 'Lines crossing plane= ', + > 'A=',DPLPT(1),'B=',DPLPT(2),'D=',DPLPT(4) + WRITE(IPMAT,7000) NAMSBR,TITLE + ELSE IF(NDIM .EQ. 3) THEN + WRITE(TITLE,'(A22,1P,4(1X,A2,F8.2))') + > 'Lines crossing plane= ', + > 'A=',DPLPT(1),'B=',DPLPT(2),'C=',DPLPT(3),'D=',DPLPT(4) + WRITE(IPMAT,7000) NAMSBR,TITLE + ENDIF +*---- +* Print matlab instructions for line segment +*---- + DO IREG=1,NREG + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6002) IREG + ENDIF + DO ILINE=1,NSKTRK + READ(IFTRK) IDUM + ENDDO + ILREG=0 +*---- +* Scan over lines +*---- + DO ILINE=1,NBTR + READ(IFTRK) NSUB,NBSEG,WEIGHT, + > (KANGL(II),II=1,NSUB), + > (NUMERO(ISEG),ISEG=1,NBSEG), + > (LENGTH(ISEG),ISEG=1,NBSEG), + > NTLINE,IPLANE,IPTA2,IPTA3, + > ((TORIG(IDIR,ISUB),IDIR=1,NDIM),ISUB=1,NSUB) + IF(NSUB.NE.1) CALL XABORT(NAMSBR// + >': Cyclic tracks not permitted for option PLANP') +*---- +* Verify for valid plane and angle +*---- + IF(KANGL(1) .EQ. IDL .AND. + > (IPL .EQ. IPLANE .OR. IPL .EQ. 0) ) THEN +*---- +* find location of first intersection between line and geometry +*---- + ISUB=1 + DO IDIR=1,NDIM + DXYZ(IDIR)=TORIG(IDIR,ISUB) + ENDDO +*---- +* For surface A*X+B*Y+C*Z=D +* and line +* X=X0+R*DANGLT(1) +* Y=Y0+R*DANGLT(2) +* Y=Z0+R*DANGLT(3) +* Intersection must satisfy: +* A*R*DANGLT(1)+B*R*DANGLT(2)+C*R*DANGLT(3)=D +* R=(D-A*X0-B*Y0-C*Z0)/(A*DANGLT(1)+B*DANGLT(2)+C*DANGLT(3)) +*---- + NUMER=DPLPT(4) + DENOM=DZERO + DO IDIR=1,NDIM + DENOM=DENOM+DPLPT(IDIR)*DANGLT(IDIR,KANGL(1)) + NUMER=NUMER-DPLPT(IDIR)*DXYZ(IDIR) + ENDDO + IF(DENOM .NE. DZERO) THEN +*---- +* DINT=R +*---- + DINT=NUMER/DENOM + DINP(1)=DZERO + DO ISEG=1,NBSEG + ISV=NUMERO(ISEG) + IF(ISV .GT. 0) THEN + FLEN=LENGTH(ISEG)/DVNOR(ISV,1) + IF(NBDR .GT. 1) + > FLEN=LENGTH(ISEG)/DVNOR(ISV,KANGL(1)+1) + DINP(2)=DINP(1)+FLEN + IF(DINP(1) .LE. DINT .AND. DINT .LE. DINP(2)) THEN + DO IDIR=1,NDIM + DXYZ(IDIR)=DXYZ(IDIR)+DANGLT(IDIR,KANGL(1))*DINT + ENDDO + IF(ISV .EQ. IREG) THEN + ILREG=ILREG+1 + IF(ILREG .EQ. 1) THEN + WRITE(IPMAT,7002) + ENDIF + WRITE(IPMAT,7004) + > (DXYZ(IDIR),IDIR=1,NDIM),ILINE + GO TO 100 + ENDIF + ENDIF + DINP(1)=DINP(2) + ENDIF + ENDDO + 100 CONTINUE + ENDIF + ENDIF + ENDDO +*---- +* Write Matlab commands to print points +*---- + IF(ILREG .GE. 1) THEN + WRITE(IPMAT,7003) + IF(NDIM .EQ. 2) THEN + WRITE(IPMAT,7010) ACOL(MOD(IREG,7)) + ELSE + WRITE(IPMAT,7011) ACOL(MOD(IREG,7)) + ENDIF + WRITE(IPMAT,7090) + IF(IPLP(1,IPLOT) .GT. 0) WRITE(IPMAT,7091) + ENDIF + REWIND IFTRK + ENDDO + ENDDO + WRITE(IPMAT,7093) + IF(IPLP(1,IPLOT) .LT. 0) WRITE(IPMAT,7091) +*---- +* Processing finished, return +*---- + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(KANGL,TORIG) + DEALLOCATE(LENGTH,NUMERO) + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6002 FORMAT(' Processing lines for region = ',I8) +*---- +* Matlab .m file format +*---- + 7000 FORMAT('%'/'% Output from ',A6/'%'/ + >'%figure;'/'hold on;'/7Htitle(',A66,3H');/ + >12Hxlabel('x');/12Hylabel('y');) + 7002 FORMAT('TLMSurfacePoints=[') + 7003 FORMAT(12X,'];') + 7004 FORMAT(3F18.10,2X,I10) + 7010 FORMAT('plot(TLMSurfacePoints(:,1),', + > 'TLMSurfacePoints(:,2),',1H',A2,3H');) + 7011 FORMAT('plot3(TLMSurfacePoints(:,1),', + > 'TLMSurfacePoints(:,2),', + > 'TLMSurfacePoints(:,3),',1H',A2,3H');) + 7090 FORMAT('clear TLMSurfacePoints TLMcolorset;') + 7091 FORMAT('pause ;') + 7093 FORMAT('hold off;') + END diff --git a/Dragon/src/TLMPNT.f b/Dragon/src/TLMPNT.f new file mode 100644 index 0000000..b80d9f6 --- /dev/null +++ b/Dragon/src/TLMPNT.f @@ -0,0 +1,222 @@ +*DECK TLMPNT + SUBROUTINE TLMPNT(IPMAT ,IFTRK ,IPRINT,NSKTRK,NBTR ,NDIM , + > NREG ,NSUR ,MXSUB ,MXSEG ,NANGL ,NBDR , + > NPLOTS,IPLOT ,IPLP ,DANGLT,DVNOR ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To generate the Matlab instruction for drawing the +* external surface intersection points. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* C. Plamondon, G. Marleau +* +*Parameters: input +* IPMAT pointer to Matlab-m file. +* IFTRK pointer to the TRACKING file. +* IPRINT print level. +* NSKTRK number of records to skip on track file before tracking +* lines can be extracted. +* NBTR numbre of tracks. +* NDIM number of dimensions for problem. +* NREG number of regions for problem. +* NSUR number of outer surfaces for problem. +* MXSUB maximum number of subtracks in a line. +* MXSEG maximum number of segments in a line. +* NANGL number of direction for tracking. +* NBDR number of direction for volume normalization. +* NPLOTS number of plots. +* IPLOT plot number being processed. +* IPLP integer plot parameters. +* DANGLT track directions. +* DVNOR track normalization factor for regional volumes. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPMAT,IFTRK + INTEGER IPRINT,NSKTRK,NBTR,NDIM,NREG,NSUR,MXSUB,MXSEG, + > NANGL,NBDR,NPLOTS,IPLOT + INTEGER IPLP(6,NPLOTS) + DOUBLE PRECISION DANGLT(NDIM,NANGL),DVNOR(NREG,NBDR) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='TLMPNT') +*---- +* Local variables for tracking file +*---- + INTEGER ILINE,IDUM,NBSEG,NTLINE,ISEG,KSEG, + > IPLANE,IPTA2,IPTA3,NSUB,ISUB,II + DOUBLE PRECISION WEIGHT +*---- +* Other local variables +*---- + INTEGER ISUR,IFACE,IDIR,ISV,IENTER + DOUBLE PRECISION DXYZ(3),FLEN + CHARACTER TITLE*36 +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NUMERO,KANGL + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: LENGTH + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: TORIG +*---- +* Data +*---- + CHARACTER ACOL(0:6)*2 + DATA ACOL /'b.','g.','r.','c.','m.','y.','k.'/ +*---- +* Scratch storage allocation +* NUMERO region/surface identification number for segment. +* LENGTH segment length. +*---- + ALLOCATE(NUMERO(MXSEG),LENGTH(MXSEG)) + ALLOCATE(KANGL(MXSUB),TORIG(NDIM,MXSUB)) +*---- +* Processing starts: +* print routine opening header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF +*---- +* Print IPMAT header +*---- + WRITE(TITLE,'(A18,18X)') 'Points on surfaces' + WRITE(IPMAT,7000) NAMSBR,TITLE +*---- +* Identify points associated with each surface +*---- + DO ISUR=1,NSUR + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6002) ISUR + ENDIF + DO ILINE=1,NSKTRK + READ(IFTRK) IDUM + ENDDO + IFACE=0 +*---- +* Scan over lines +*---- + DO ILINE=1,NBTR + READ(IFTRK) NSUB,NBSEG,WEIGHT, + > (KANGL(II),II=1,NSUB), + > (NUMERO(ISEG),ISEG=1,NBSEG), + > (LENGTH(ISEG),ISEG=1,NBSEG), + > NTLINE,IPLANE,IPTA2,IPTA3, + > ((TORIG(IDIR,ISUB),IDIR=1,NDIM),ISUB=1,NSUB) +*---- +* Find line segment location +*---- + ISUB=0 + IENTER=-1 + DO ISEG=1,NBSEG + ISV=NUMERO(ISEG) + IF(ISV .EQ. -ISUR) THEN + IF(IENTER .EQ. -1) THEN + ISUB=ISUB+1 + IF(ISUB.GT.NSUB) THEN + WRITE(IOUT,9000) ILINE + WRITE(IOUT,9001) + > (NUMERO(KSEG),LENGTH(KSEG),KSEG=1,NBSEG) + CALL XABORT(NAMSBR//': Invalid tracking line') + ENDIF + DO IDIR=1,NDIM + DXYZ(IDIR)=TORIG(IDIR,ISUB) + ENDDO + ENDIF + IENTER=-IENTER + IFACE=IFACE+1 + IF(IFACE .EQ. 1) THEN + WRITE(IPMAT,7002) ISUR + ENDIF + WRITE(IPMAT,7004) (DXYZ(IDIR),IDIR=1,NDIM),ILINE + ELSE IF(ISV .GT. 0) THEN + IF(NBDR.EQ.1) THEN + FLEN=LENGTH(ISEG)/DVNOR(ISV,1) + ELSE + FLEN=LENGTH(ISEG)/DVNOR(ISV,KANGL(1)+1) + ENDIF + DO IDIR=1,NDIM + DXYZ(IDIR)=DXYZ(IDIR)+ + > DANGLT(IDIR,KANGL(1))*FLEN + ENDDO + ENDIF + ENDDO + ENDDO +*---- +* Write Matlab commands to print points +*---- + IF(IFACE .GE. 1) THEN + WRITE(IPMAT,7003) + IF(NDIM .EQ. 2) THEN + WRITE(IPMAT,7010) ISUR,ACOL(MOD(ISUR,7)) + ELSE + WRITE(IPMAT,7011) ISUR,ACOL(MOD(ISUR,7)) + ENDIF + WRITE(IPMAT,7090) + IF(IPLP(1,IPLOT) .GT. 0) WRITE(IPMAT,7091) + ENDIF + REWIND IFTRK + ENDDO + WRITE(IPMAT,7093) + IF(IPLP(1,IPLOT) .LT. 0) WRITE(IPMAT,7091) +*---- +* Processing finished, return +*---- + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(KANGL,TORIG) + DEALLOCATE(LENGTH,NUMERO) + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6002 FORMAT(' Processing points for surface = ',I8) +*---- +* Matlab .m file format +*---- + 7000 FORMAT('%'/'% Output from ',A6/'%'/'%hold on;'/ + >7Htitle(',A36,3H');) + 7002 FORMAT('% Points for Surface ',I10/ + > 'TLMSurfacePoints=[') + 7003 FORMAT(12X,'];') + 7004 FORMAT(3F18.10,2X,I10) + 7010 FORMAT('% Plot surface ',I10/ + > 'plot(TLMSurfacePoints(:,1),', + > 'TLMSurfacePoints(:,2),',1H',A2,3H');) + 7011 FORMAT('% Plot surface ',I10/ + > 'plot3(TLMSurfacePoints(:,1),', + > 'TLMSurfacePoints(:,2),', + > 'TLMSurfacePoints(:,3),',1H',A2,3H');) + 7090 FORMAT('clear TLMSurfacePoints;') + 7091 FORMAT('pause ;') + 7093 FORMAT('hold off ;') +*---- +* Errors +*---- + 9000 FORMAT(' ***** Error **** '/ + > ' Number of track cycles exceeded for line ', I10) + 9001 FORMAT(1P,4(1X,I10,E20.10)) + END diff --git a/Dragon/src/TLMREG.f b/Dragon/src/TLMREG.f new file mode 100644 index 0000000..dd17024 --- /dev/null +++ b/Dragon/src/TLMREG.f @@ -0,0 +1,246 @@ +*DECK TLMREG + SUBROUTINE TLMREG(IPMAT ,IFTRK ,IPRINT,NSKTRK,NBTR ,NDIM , + > NSOUT ,NREG ,MXSUB ,MXSEG ,NANGL ,NBDR , + > NPLOTS,IPLOT , IPLP ,DANGLT,DVNOR ,MATALB, + > LMIX ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To generate the Matlab instruction for drawing the +* lines for the region selected. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* C. Plamondon, G. Marleau +* +*Parameters: input +* IPMAT pointer to Matlab-m file. +* IFTRK pointer to the TRACKING file. +* IPRINT print level. +* NSKTRK number of records to skip on track file before tracking +* lines can be extracted. +* NBTR numbre of tracks. +* NDIM number of dimensions for problem. +* NREG number of regions for problem. +* NSOUT number of outer surfaces for problem. +* MXSUB maximum number of subtracks in a line. +* MXSEG maximum number of segments in a line. +* NANGL number of direction for tracking. +* NBDR number of direction for volume normalization. +* NPLOTS number of plots. +* IPLOT plot number being processed. +* IPLP integer plot parameters. +* DANGLT track directions. +* DVNOR track normalization factor for regional volumes. +* MATALB surface direction and region material identification array. +* LMIX flag set to .TRUE. to draw mixture lines. +* +*---------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER IPMAT,IFTRK + INTEGER IPRINT,NSKTRK,NBTR,NDIM,NSOUT,NREG,MXSUB,MXSEG, + > NANGL,NBDR,NPLOTS,IPLOT + INTEGER IPLP(6,NPLOTS),MATALB(-NSOUT:NREG) + DOUBLE PRECISION DANGLT(NDIM,NANGL),DVNOR(NREG,NBDR) + LOGICAL LMIX +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='TLMREG') +*---- +* Local variables for tracking file +*---- + INTEGER ILINE,IDUM,NBSEG,NTLINE,ISEG,KSEG, + > IPLANE,IPTA2,IPTA3,NSUB,ISUB,II + DOUBLE PRECISION WEIGHT +*---- +* Other local variables +*---- + INTEGER IREG,ILREG,IDIR,ISV,IENTER,ITRACE,IPM + DOUBLE PRECISION DXYZ(3,2),FLEN + CHARACTER TITLE*36 +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NUMERO,KANGL + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: LENGTH + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: TORIG +*---- +* Scratch storage allocation +* NUMERO region/surface identification number for segment. +* LENGTH segment length. +*---- + ALLOCATE(NUMERO(MXSEG),LENGTH(MXSEG)) + ALLOCATE(KANGL(MXSUB),TORIG(NDIM,MXSUB)) +*---- +* Processing starts: +* print routine opening header if required +* and initialize various parameters. +*---- + IF(IPRINT .GE. 1) WRITE(IOUT,6000) NAMSBR +*---- +* Print IPMAT header +*---- + IREG=IPLP(2,IPLOT) + WRITE(TITLE,'(A4,I4)') 'Reg=',IREG + IF(LMIX) THEN + WRITE(IPMAT,7000) NAMSBR,TITLE,MAXVAL(MATALB(1:NREG))+1 + ELSE + WRITE(IPMAT,7000) NAMSBR,TITLE,NREG + ENDIF +*---- +* Print matlab instructions for line segment +*---- + IF(IPRINT .GE. 10) WRITE(IOUT,6002) IREG + DO ILINE=1,NSKTRK + READ(IFTRK) IDUM + ENDDO + ILREG=0 +*---- +* Scan over lines +*---- + DO ILINE=1,NBTR + READ(IFTRK) NSUB,NBSEG,WEIGHT, + > (KANGL(II),II=1,NSUB), + > (NUMERO(ISEG),ISEG=1,NBSEG), + > (LENGTH(ISEG),ISEG=1,NBSEG), + > NTLINE,IPLANE,IPTA2,IPTA3, + > ((TORIG(IDIR,ISUB),IDIR=1,NDIM),ISUB=1,NSUB) +*---- +* Find line segment location +*---- + ISUB=0 + IENTER=-1 + ITRACE=1 + DO ISEG=1,NBSEG + ISV=NUMERO(ISEG) + IF(ISV .GT. 0) THEN + FLEN=LENGTH(ISEG)/DVNOR(ISV,1) + IF(NBDR .GT. 1) THEN + FLEN=LENGTH(ISEG)/DVNOR(ISV,KANGL(1)+1) + ENDIF + DO IDIR=1,NDIM + DXYZ(IDIR,2)=DXYZ(IDIR,1)+ + > DANGLT(IDIR,KANGL(1))*FLEN + ENDDO + IF(IREG .EQ. ISV .AND. ITRACE .EQ. 1) THEN + ILREG=ILREG+1 + IF(ILREG .EQ. 1) THEN + WRITE(IPMAT,7002) + ENDIF + WRITE(IPMAT,7004) + > ((DXYZ(IDIR,IPM),IPM=1,2),IDIR=1,NDIM) + ENDIF + DO IDIR=1,NDIM + DXYZ(IDIR,1)=DXYZ(IDIR,2) + ENDDO + ELSE + IF(IENTER .EQ. -1) THEN + ISUB=ISUB+1 + IF(ISUB.GT.NSUB) THEN + WRITE(IOUT,9000) ILINE + WRITE(IOUT,9001) + > (NUMERO(KSEG),LENGTH(KSEG),KSEG=1,NBSEG) + CALL XABORT(NAMSBR//': Invalid tracking line') + ENDIF + DO IDIR=1,NDIM + DXYZ(IDIR,1)=TORIG(IDIR,ISUB) + ENDDO + ENDIF + IENTER=-IENTER + ENDIF + ENDDO + ENDDO +*---- +* Write Matlab commands to trace lines +*---- + IF(ILREG .GE. 1) THEN + WRITE(IPMAT,7003) + IF(LMIX) THEN + IF(NDIM .EQ. 2) THEN + WRITE(IPMAT,7012) MATALB(IREG)+1 + ELSE + WRITE(IPMAT,7013) MATALB(IREG)+1 + ENDIF + ELSE + IF(NDIM .EQ. 2) THEN + WRITE(IPMAT,7012) IREG + ELSE + WRITE(IPMAT,7013) IREG + ENDIF + ENDIF +*---- +* Change colour for next region +*---- + WRITE(IPMAT,7090) + IF(IREG .NE. NREG) THEN + IF(IPLP(1,IPLOT) .GT. 0) WRITE(IPMAT,7091) + ENDIF + ENDIF + REWIND IFTRK +*---- +* Processing finished, return +*---- + IF(IPRINT .GE. 1) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(KANGL,TORIG) + DEALLOCATE(LENGTH,NUMERO) + RETURN +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6002 FORMAT(' Processing lines for region = ',I8) +*---- +* Matlab .m file format +*---- + 7000 FORMAT('%'/'% Output from ',A6/'%' + >/7Htitle(',A36,3H');/9Hxcol=jet(,i5,2H);) + 7002 FORMAT('TLMIntegrationLines=[') + 7003 FORMAT(12X,'];') + 7004 FORMAT(6F18.10) + 7012 FORMAT('[m,n]=size(TLMIntegrationLines);'/ + > 'for i=1:m'/ + > ' TLMcolorset=line([TLMIntegrationLines(i,1),', + > 'TLMIntegrationLines(i,2)],', + > '[TLMIntegrationLines(i,3),', + > 'TLMIntegrationLines(i,4)]);'/ + > ' set(TLMcolorset,',8H'Color',,'xcol(',i5,',:));'/ + > 'end;') + 7013 FORMAT('[m,n]=size(TLMIntegrationLines);'/ + > 'for i=1:m'/ + > ' TLMcolorset=line([TLMIntegrationLines(i,1),', + > 'TLMIntegrationLines(i,2)],', + > '[TLMIntegrationLines(i,3),', + > 'TLMIntegrationLines(i,4)],', + > '[TLMIntegrationLines(i,5),', + > 'TLMIntegrationLines(i,6)]);'/ + > ' set(TLMcolorset,',8H'Color',,'xcol(',i5,',:));'/ + > 'end;') + 7090 FORMAT('clear TLMIntegrationLines TLMcolorset ;') + 7091 FORMAT('pause ;') +*---- +* Errors +*---- + 9000 FORMAT(' ***** Error **** '/ + > ' Number of track cycles exceeded for line ', I10) + 9001 FORMAT(1P,4(1X,I10,E20.10)) + END diff --git a/Dragon/src/TLMVPL.f b/Dragon/src/TLMVPL.f new file mode 100644 index 0000000..e44e017 --- /dev/null +++ b/Dragon/src/TLMVPL.f @@ -0,0 +1,359 @@ +*DECK TLMVPL + FUNCTION TLMVPL(NDIM,NANGL,NPLOTS,IPLOT,IPLP,DPLPR,DANGLT,XYZL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To verify that the plane selected crosses the geometry. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* C. Plamondon, G. Marleau +* +*Parameters: input +* NDIM number of dimensions for problem. +* NANGL number of direction for tracking. +* NPLOTS number of plots. +* IPLOT plot number being processed. +* IPLP integer plot parameters. +* DPLPR real plot parameters. +* DANGLT track directions. +* XYZL mesh limits. +* +*Parameters: output. +* TLMVPL flag to indicate intersection with +* no intersection if TLPVPL<0. +* +*---------- +* +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NDIM,NANGL,NPLOTS,IPLOT + INTEGER IPLP(6,NPLOTS) + DOUBLE PRECISION DPLPR(4,NPLOTS),DANGLT(NDIM,NANGL),XYZL(2,3) +*---- +* Function type +*---- + INTEGER TLMVPL +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='TLMVPL') + DOUBLE PRECISION DZERO,DONE + PARAMETER (DZERO=0.0D0,DONE=1.0D0) +*---- +* Local variables +*---- + INTEGER IDIR + DOUBLE PRECISION DPLP(4),A,B,C,D,DROITE,G(4), + > XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX +*---- +* Processing starts: +* Initialize TLMVPL +* Verification que le plan croise bien la region 3D +*---- + IF(ABS(IPLP(1,IPLOT)) .EQ. 3) THEN +*---- +* PLANA + DO IDIR=1,4 + DPLP(IDIR)=DPLPR(IDIR,IPLOT) + ENDDO +*---- + ELSE IF(ABS(IPLP(1,IPLOT)) .EQ. 4) THEN +*---- +* PLANP lines +*---- + DO IDIR=1,NDIM + DPLP(IDIR)=DANGLT(IDIR,IPLP(2,IPLOT)) + ENDDO + DO IDIR=NDIM+1,3 + DPLP(IDIR)=DZERO + ENDDO + ENDIF + A=DPLP(1) + B=DPLP(2) + C=DPLP(3) + D=DPLP(4) + XMIN=XYZL(1,1) + XMAX=XYZL(2,1) + YMIN=XYZL(1,2) + YMAX=XYZL(2,2) + ZMIN=XYZL(1,3) + ZMAX=XYZL(2,3) + TLMVPL=0 + IF(NDIM .EQ. 3) THEN +*---- +* Verification que le plan +* A*B+B*Y+C*Z=D +* croise bien la region 3D +*---- + IF(A .EQ. DZERO) THEN + IF(B .EQ. DZERO) THEN + IF(C .EQ. DZERO) THEN + TLMVPL=-8 + WRITE(IOUT,9000) NAMSBR,A,B,C,D + ELSE + DROITE=D/C + IF(DROITE .LE. ZMAX .AND. DROITE .GE. ZMIN) THEN + TLMVPL=1 + ELSE + TLMVPL=-1 + WRITE(IOUT,9001) NAMSBR,'ZZ',A,B,C,D + ENDIF + ENDIF + ELSE IF(C .EQ. DZERO) THEN + DROITE=D/B + IF(DROITE .LE. YMAX .AND. DROITE .GE. YMIN) THEN + TLMVPL=1 + ELSE + TLMVPL=-2 + WRITE(IOUT,9001) NAMSBR,'YY',A,B,C,D + ENDIF + ELSE + G(1)=(D-B*YMIN)/C + G(2)=(D-B*YMAX)/C + G(3)=(D-C*ZMIN)/B + IF(G(1) .LT. ZMAX .AND. G(1) .GT. ZMIN) THEN + TLMVPL=1 + ELSE IF(G(2) .LT. ZMAX .AND. G(2) .GT. ZMIN) THEN + TLMVPL=1 + ELSE IF(G(3) .LT. YMAX .AND. G(3) .GT. YMIN) THEN + TLMVPL=1 + ELSE + G(1)=(D-(B*(YMIN+YMAX)/2))/C + G(2)=(D-(C*(ZMIN+ZMAX)/2))/B + IF(G(1) .LE. ZMAX .AND. G(1) .GE. ZMIN) THEN + TLMVPL=1 + ELSE IF(G(2) .LE. YMAX .AND. G(2) .GE. YMIN) THEN + TLMVPL=1 + ELSE + TLMVPL=-3 + WRITE(IOUT,9001) NAMSBR,'YZ',A,B,C,D + ENDIF + ENDIF + ENDIF + ELSE IF(B .EQ. 0) THEN + IF(C .EQ. 0) THEN + DROITE=D/A + IF(DROITE .LE. XMAX .AND. DROITE .GE. XMIN) THEN + TLMVPL=1 + ELSE + TLMVPL=-4 + WRITE(IOUT,9001) NAMSBR,'XX',A,B,C,D + ENDIF + ELSE + G(1)=(D-A*XMIN)/C + G(2)=(D-A*XMAX)/C + G(3)=(D-C*ZMIN)/A + IF(G(1) .LT. ZMAX .AND. G(1) .GT. ZMIN) THEN + TLMVPL=1 + ELSE IF(G(2) .LT. ZMAX .AND. G(2) .GT. ZMIN) THEN + TLMVPL=1 + ELSE IF(G(3) .LT. XMAX .AND. G(3) .GT. XMIN) THEN + TLMVPL=1 + ELSE + G(1)=(D-(A*(XMIN+XMAX)/2))/C + G(2)=(D-(C*(ZMIN+ZMAX)/2))/A + IF(G(1) .LE. ZMAX .AND. G(1) .GE. ZMIN) THEN + TLMVPL=1 + ELSE IF(G(2) .LE. XMAX .AND. G(2) .GE. XMIN) THEN + TLMVPL=1 + ELSE + TLMVPL=-5 + WRITE(IOUT,9001) NAMSBR,'XY',A,B,C,D + ENDIF + ENDIF + ENDIF + ELSE IF(C .EQ. 0) THEN + G(1)=(D-A*XMIN)/B + G(2)=(D-A*XMAX)/B + G(3)=(D-B*YMIN)/A + IF(G(1) .LT. YMAX .AND. G(1) .GT. YMIN) THEN + TLMVPL=1 + ELSE IF(G(2) .LT. YMAX .AND. G(2) .GT. YMIN) THEN + TLMVPL=1 + ELSE IF(G(3) .LT. XMAX .AND. G(3) .GT. XMIN) THEN + TLMVPL=1 + ELSE + G(1)=(D-(A*(XMIN+XMAX)/2))/B + G(2)=(D-(B*(YMIN+YMAX)/2))/A + IF(G(1) .LE. YMAX .AND. G(1) .GE. YMIN) THEN + TLMVPL=1 + ELSE IF(G(2) .LE. XMAX .AND. G(2) .GE. XMIN) THEN + TLMVPL=1 + ELSE + TLMVPL=-6 + WRITE(IOUT,9001) NAMSBR,'XZ',A,B,C,D + ENDIF + ENDIF + ELSE + G(1)=(D-A*XMIN-B*YMIN)/C + G(2)=(D-A*XMIN-B*YMAX)/C + G(3)=(D-A*XMAX-B*YMIN)/C + G(4)=(D-A*XMAX-B*YMAX)/C + IF(G(1) .LT. ZMAX .AND. G(1) .GT. ZMIN) THEN + TLMVPL=1 + ELSE IF(G(2) .LT. ZMAX .AND. G(2) .GT. ZMIN) THEN + TLMVPL=1 + ELSE IF(G(3) .LT. ZMAX .AND. G(3) .GT. ZMIN) THEN + TLMVPL=1 + ELSE IF(G(4) .LT. YMAX .AND. G(4) .GT. YMIN) THEN + TLMVPL=1 + ELSE + G(1)=(D-C*ZMIN-B*YMIN)/A + G(2)=(D-C*ZMIN-B*YMAX)/A + G(3)=(D-C*ZMAX-B*YMIN)/A + G(4)=(D-C*ZMAX-B*YMAX)/A + IF(G(1) .LT. XMAX .AND. G(1) .GT. XMIN) THEN + TLMVPL=1 + ELSE IF(G(2) .LT. XMAX .AND. G(2) .GT. XMIN) THEN + TLMVPL=1 + ELSE IF(G(3) .LT. XMAX .AND. G(3) .GT. XMIN) THEN + TLMVPL=1 + ELSE IF(G(4) .LT. XMAX .AND. G(4) .GT. XMIN) THEN + TLMVPL=1 + ELSE + G(1)=(D-C*ZMIN-A*XMIN)/B + G(2)=(D-C*ZMIN-A*XMAX)/B + G(3)=(D-C*ZMAX-A*XMIN)/B + G(4)=(D-C*ZMAX-A*XMAX)/B + IF(G(1) .LT. YMAX .AND. G(1) .GT. YMIN) THEN + TLMVPL=1 + ELSE IF(G(2) .LT. YMAX .AND. G(2) .GT. YMIN) THEN + TLMVPL=1 + ELSE IF(G(3) .LT. YMAX .AND. G(3) .GT. YMIN) THEN + TLMVPL=1 + ELSE IF(G(4) .LT. YMAX .AND. G(4) .GT. YMIN) THEN + TLMVPL=1 + ELSE + G(1)=(D-((C*(ZMIN+ZMAX)/2)+(B*(YMIN+YMAX)/2)))/A + G(2)=(D-((A*(XMIN+XMAX)/2)+(C*(ZMIN+ZMAX)/2)))/B + G(3)=(D-((A*(XMIN+XMAX)/2)+(B*(YMIN+YMAX)/2)))/C + IF(G(1) .LE. XMAX .AND. G(1) .GE. XMIN) THEN + TLMVPL=1 + ELSE IF(G(2) .LE. YMAX .AND. G(2) .GE. YMIN) THEN + TLMVPL=1 + ELSE IF(G(2) .LE. ZMAX .AND. G(2) .GE. ZMIN) THEN + TLMVPL=1 + ELSE + TLMVPL=-7 + WRITE(IOUT,9001) NAMSBR,'ZZ',A,B,C,D + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + ELSE IF(NDIM .EQ. 2) THEN +*---- +* Verification que le plan +* A*B+B*Y=D +* croise bien la region 2D (2 PLANS) +*---- + IF(A .EQ. 0) THEN +*---- +* LIGNE PARALLELE A Y +*---- + IF(B .EQ. 0) THEN + TLMVPL=-9 + WRITE(IOUT,9010) NAMSBR,A,B,D + ELSE + DROITE=D/B + IF(DROITE .LE. YMAX .AND. DROITE .GE. YMIN) THEN + TLMVPL=1 + ELSE + TLMVPL=-10 + WRITE(IOUT,9011) NAMSBR,'YY',A,B,D + ENDIF + ENDIF + ELSE IF(B .EQ. 0) THEN +*---- +* LIGNE PARALLELE A X +*---- + DROITE=D/A + IF(DROITE .LE. XMAX .AND. DROITE .GE. XMIN) THEN + TLMVPL=1 + ELSE + TLMVPL=-11 + WRITE(IOUT,9011) NAMSBR,'XX',A,B,D + ENDIF + ELSE +*---- +* LIGNE DIAGONALE +*---- + G(1)=(D-A*XMIN)/B + G(2)=(D-A*XMAX)/B + G(3)=(D-B*YMIN)/A + IF(G(1) .LT. YMAX .AND. G(1) .GT. YMIN) THEN +*---- +* PLAN XMIN + UN AUTRE +*---- + TLMVPL=1 + ELSE IF(G(2) .LT. YMAX .AND. G(2) .GT. YMIN) THEN +*---- +* PLAN XMAX + 1 AUTRE +*---- + TLMVPL=1 + ELSE IF(G(3) .LT. XMAX .AND. G(3) .GT. XMIN) THEN +*---- +* PLAN YMIN + 1 AUTRE +*---- + TLMVPL=1 + ELSE +*---- +* 0 OU 1 PLAN +* VERIFIER POUR COINS +* EN TROUVANT L'INTERSECTION AVEC LE PLAN CENTRAL +*---- + G(1)=(D-A*(XMIN+XMAX)/2)/B + G(2)=(D-(B*(YMIN+YMAX)/2))/A + IF(G(1) .LT. YMAX .AND. G(1) .GT. YMIN) THEN +*---- +* 1 COIN + PLAN CENTRAL EN X +*---- + TLMVPL=1 + ELSE IF(G(2) .LT. XMAX .AND. G(2) .GT. XMIN) THEN +*---- +* 1 COIN + PLAN CENTRAL EN Y +*---- + TLMVPL=1 + ELSE +*---- +* PAS D'INTERSECTION +*---- + TLMVPL=-12 + WRITE(IOUT,9011) NAMSBR,'XY',A,B,D + ENDIF + ENDIF + ENDIF + ENDIF +*---- +* Processing finished, return +*---- + RETURN +*---- +* Output formats +*---- + 9000 FORMAT(1X,'***** Warning in ',A6,' *****'/ + > 1X,'Invalid equation for 3-D plane : '/ + > 1X,F20.10,'*X + ',F20.10,'*Y + ',F20.10,'*Z = ',F20.10) + 9001 FORMAT(1X,'***** Warning in ',A6,' *****'/ + > 1X,'No intersection between region and plane in ',A2/ + > 1X,F20.10,'*X + ',F20.10,'*Y + ',F20.10,'*Z = ',F20.10) + 9010 FORMAT(1X,'***** Warning in ',A6,' *****'/ + > 1X,'Invalid equation for 2-D plane : '/ + > 1X,F20.10,'*X + ',F20.10,'*Y + = ',F20.10) + 9011 FORMAT(1X,'***** Warning in ',A6,' *****'/ + > 1X,'No intersection between region and LINE in ',A2/ + > 1X,F20.10,'*X + ',F20.10,'*Y + = ',F20.10) + END diff --git a/Dragon/src/TONCMI.f b/Dragon/src/TONCMI.f new file mode 100644 index 0000000..6159c09 --- /dev/null +++ b/Dragon/src/TONCMI.f @@ -0,0 +1,239 @@ +*DECK TONCMI + SUBROUTINE TONCMI(IPMICR,IPRINT,NMERGE,NISOT,NGCOND,NL,NED,NDEL, + 1 MASKI,SPH) +* +*----------------------------------------------------------------------- +* +*Purpose: +* SPH-correction of a Microlib. +* +*Copyright: +* Copyright (C) 2017 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMICR pointer to the condensed microlib (L_LIBRARY signature). +* IPRINT print flag (equal to 0 for no print). +* NMERGE number of merged regions. +* NISOT number of isotopes in microlib. +* NGCOND number of condensed groups. +* NL number of Legendre orders in scattering info. +* NED number of additional phi-weighted edits in microlib. +* NDEL number of delayed precursor groups. +* MASKI isotope mask (=.TRUE. if an isotope is to be corrected). +* SPH SPH homogenization factors. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMICR + INTEGER IPRINT,NMERGE,NISOT,NGCOND,NL,NED,NDEL + LOGICAL MASKI(NISOT) + REAL SPH(NMERGE,NGCOND) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + INTEGER ISTATE(NSTATE) + TYPE(C_PTR) KPMICR + CHARACTER HSIGN*12,TEXT12*12,CM*2,TEXT8*8,HSMG*131,HMAKE(100)*12 + DOUBLE PRECISION DSUM +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IMIX,ITYPR + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IHUSED,IHEDIT + REAL, ALLOCATABLE, DIMENSION(:,:) :: GAR + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: WSCAT + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO +*---- +* SCRATCH STORAGE ALLOCATION +* IHEDIT character*8 names of phi-weighted edits in microlib. +*---- + ALLOCATE(IHEDIT(2,NED+1),ITYPR(NL)) + ALLOCATE(GAR(NGCOND,10+NL+NED+2*NDEL),WSCAT(NGCOND,NGCOND,NL)) + ALLOCATE(IHUSED(3,NISOT),IMIX(NISOT),IPISO(NISOT)) +*---- +* RECOVER MICROLIB INFORMATION +*---- + CALL LCMGTC(IPMICR,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_LIBRARY') CALL XABORT('TONCMI: MICROLIB EXPECTED') + CALL LCMGET(IPMICR,'STATE-VECTOR',ISTATE) + IF(ISTATE(1).NE.NMERGE) CALL XABORT('TONCMI: INVALID NMERGE') + IF(ISTATE(2).NE.NISOT) CALL XABORT('TONCMI: INVALID NISOT') + IF(ISTATE(3).NE.NGCOND) CALL XABORT('TONCMI: INVALID NGCOND') + IF(ISTATE(4).NE.NL) CALL XABORT('TONCMI: INVALID NL') + IF(ISTATE(13).NE.NED) CALL XABORT('TONCMI: INVALID NED') + IF(ISTATE(19).NE.NDEL) CALL XABORT('TONCMI: INVALID NDEL') + IF(NED.GT.0) CALL LCMGET(IPMICR,'ADDXSNAME-P0',IHEDIT) +*---- +* LOOP OVER ISOTOPES +*---- + CALL LCMGET(IPMICR,'ISOTOPESUSED',IHUSED) + CALL LCMGET(IPMICR,'ISOTOPESMIX',IMIX) + CALL LIBIPS(IPMICR,NISOT,IPISO) + DO 200 ISOT=1,NISOT + IF(.NOT.MASKI(ISOT)) GO TO 200 + WRITE(TEXT12,'(3A4)') (IHUSED(I0,ISOT),I0=1,3) + IF(IPRINT.GT.2) THEN + WRITE(6,'(29H TONCMI: PROCESSING ISOTOPE '',A12,2H''.)') TEXT12 + ENDIF + IBM=IMIX(ISOT) + KPMICR=IPISO(ISOT) ! set ISOT-th isotope + IF(.NOT.C_ASSOCIATED(KPMICR)) THEN + WRITE(HSMG,'(17HTONCMI: ISOTOPE '',A12,16H'' IS NOT AVAILAB, + > 19HLE IN THE MICROLIB.)') TEXT12 + CALL XABORT(HSMG) + ENDIF + MAXH=10+NL+NED+2*NDEL + IF(MAXH+NL.GT.100) CALL XABORT('TONCMI: STATIC STORAGE EXCEEDED') + DO 10 J=1,MAXH+NL + HMAKE(J)=' ' + 10 CONTINUE + GAR(:NGCOND,:10+NL+NED+2*NDEL)=0.0 + WSCAT(:NGCOND,:NGCOND,:NL)=0.0 +*---- +* RECOVER CALCULATION-SPECIFIC ISOTOPIC DATA +*---- + CALL LCMGET(KPMICR,'NWT0',GAR(1,1)) + HMAKE(1)='NWT0' + CALL LCMLEN(KPMICR,'NWT1',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGCOND) THEN + CALL LCMGET(KPMICR,'NWT1',GAR(1,2)) + HMAKE(2)='NWT1' + ENDIF + CALL XDRLGS(KPMICR,-1,IPRINT,0,NL-1,1,NGCOND,GAR(1,3),WSCAT,ITYPR) + DO 30 IL=0,NL-1 + IF(ITYPR(IL+1).NE.0) THEN + WRITE (CM,'(I2.2)') IL + HMAKE(3+IL)='SIGS'//CM + ENDIF + 30 CONTINUE + CALL LCMGET(KPMICR,'NTOT0',GAR(1,3+NL)) + HMAKE(3+NL)='NTOT0' + CALL LCMLEN(KPMICR,'NTOT1',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGCOND) THEN + HMAKE(4+NL)='NTOT1' + CALL LCMGET(KPMICR,'NTOT1',GAR(1,4+NL)) + ENDIF + CALL LCMLEN(KPMICR,'NUSIGF',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGCOND) THEN + CALL LCMGET(KPMICR,'NUSIGF',GAR(1,5+NL)) + HMAKE(5+NL)='NUSIGF' + ENDIF + IF(NDEL.GT.0) THEN + WRITE(TEXT12,'(6HNUSIGF,I2.2)') NDEL + CALL LCMLEN(KPMICR,TEXT12,LENGTH,ITYLCM) + IF(LENGTH.EQ.NGCOND) THEN + DO 40 IDEL=1,NDEL + WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL + CALL LCMGET(KPMICR,TEXT12,GAR(1,MAXH-2*NDEL-2+IDEL)) + HMAKE(MAXH-2*NDEL-2+IDEL)=TEXT12 + 40 CONTINUE + ENDIF + ENDIF + CALL LCMLEN(KPMICR,'H-FACTOR',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGCOND) THEN + CALL LCMGET(KPMICR,'H-FACTOR',GAR(1,MAXH-2*NDEL-4)) + HMAKE(MAXH-2*NDEL-4)='H-FACTOR' + ENDIF + CALL LCMLEN(KPMICR,'OVERV',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGCOND) THEN + CALL LCMGET(KPMICR,'OVERV',GAR(1,MAXH-2*NDEL-3)) + HMAKE(MAXH-2*NDEL-3)='OVERV' + ENDIF + CALL LCMLEN(KPMICR,'TRANC',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGCOND) THEN + CALL LCMGET(KPMICR,'TRANC',GAR(1,MAXH-2*NDEL-2)) + HMAKE(MAXH-2*NDEL-2)='TRANC' + ENDIF + DO 60 IED=1,NED + WRITE(TEXT8,'(2A4)') (IHEDIT(I0,IED),I0=1,2) + CALL LCMLEN(KPMICR,TEXT8,LENGTH,ITYLCM) + IF((LENGTH.GT.0).AND.(TEXT8.NE.'TRANC')) THEN + CALL LCMGET(KPMICR,TEXT8,GAR(1,5+NL+IED)) + HMAKE(5+NL+IED)=TEXT8 + ENDIF + 60 CONTINUE + CALL LCMLEN(KPMICR,'STRD',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGCOND) THEN + CALL LCMGET(KPMICR,'STRD',GAR(1,MAXH)) + HMAKE(MAXH)='STRD' + ENDIF +*---- +* APPLY SPH CORRECTION +*---- + DO 80 J=1,MAXH + IF((HMAKE(J).NE.' ').AND.(HMAKE(J)(:4).NE.'SIGS')) THEN + DO 70 IG=1,NGCOND + IF((HMAKE(J)(:4).EQ.'STRD').OR.(HMAKE(J).EQ.'NWT0').OR. + > (HMAKE(J).EQ.'TRANC')) THEN + GAR(IG,J)=GAR(IG,J)/SPH(IBM,IG) + ELSE IF(HMAKE(J)(:5).EQ.'NWT1') THEN + CONTINUE + ELSE IF(HMAKE(J)(:4).EQ.'NTOT') THEN + CONTINUE + ELSE + GAR(IG,J)=GAR(IG,J)*SPH(IBM,IG) + ENDIF + 70 CONTINUE + ENDIF + 80 CONTINUE + DO 105 IL=1,NL + ITYPR(IL)=0 + IF(HMAKE(MAXH+IL+1).NE.' ') ITYPR(IL)=1 + DO 100 IG2=1,NGCOND + DSUM=0.0 + DO 90 IG1=1,NGCOND + IF(MOD(IL-1,2).EQ.0) THEN + IF(IG1.EQ.IG2) THEN + WSCAT(IG1,IG1,IL)=WSCAT(IG1,IG1,IL)*SPH(IBM,IG1) + > +GAR(IG1,3+NL)*(1.0-SPH(IBM,IG1)) + ELSE + WSCAT(IG1,IG2,IL)=WSCAT(IG1,IG2,IL)*SPH(IBM,IG2) ! IG1 <- IG2 + ENDIF + ELSE + IF(IG1.EQ.IG2) THEN + WSCAT(IG1,IG1,IL)=WSCAT(IG1,IG1,IL)/SPH(IBM,IG1) + > +GAR(IG1,4+NL)*(1.0-1.0/SPH(IBM,IG1)) + ELSE + WSCAT(IG1,IG2,IL)=WSCAT(IG1,IG2,IL)/SPH(IBM,IG1) + ENDIF + ENDIF + DSUM=DSUM+WSCAT(IG1,IG2,IL) + 90 CONTINUE + IF(IL.EQ.1) THEN + GAR(IG2,2+IL)=GAR(IG2,2+IL)*SPH(IBM,IG2)+GAR(IG2,3+NL)* + 1 (1.0-SPH(IBM,IG2)) + ELSE + GAR(IG2,2+IL)=REAL(DSUM) + ENDIF + 100 CONTINUE + 105 CONTINUE +*---- +* SAVE CORRECTED INFORMATION ON LCM +*---- + DO 110 J=1,MAXH + IF((HMAKE(J).NE.' ').AND.(HMAKE(J)(:4).NE.'SIGS')) THEN + CALL LCMPUT(KPMICR,HMAKE(J),NGCOND,2,GAR(1,J)) + ENDIF + 110 CONTINUE + CALL XDRLGS(KPMICR,1,IPRINT,0,NL-1,1,NGCOND,GAR(1,3),WSCAT,ITYPR) + 200 CONTINUE + IF(IPRINT.GT.2) WRITE(6,'(/28H TONCMI: MICROLIB CORRECTED.)') +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IPISO,IMIX,IHUSED) + DEALLOCATE(WSCAT,GAR) + DEALLOCATE(ITYPR,IHEDIT) + RETURN + END diff --git a/Dragon/src/TONDRV.f b/Dragon/src/TONDRV.f new file mode 100644 index 0000000..3c709b1 --- /dev/null +++ b/Dragon/src/TONDRV.f @@ -0,0 +1,471 @@ +*DECK TONDRV + SUBROUTINE TONDRV (IPLIB,IPTRK,IFTRAK,NGRO,NBISO,NBMIX,NREG, + 1 NUN,CDOOR,NRES,IMPX,ISONRF,ISONAM,MIX,DEN,SN,LSHI,IPHASE,KSPH, + 2 IPROB,MAT,VOL,KEYFLX,LEAKSW,TITR,IGRMIN,IGRMAX,MAXX0,ITRANZ,EPS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform a multidimensional self-shielding calculation in order to +* compute the dilution cross section of each resonant isotope present +* in the domain. +* +*Copyright: +* Copyright (C) 2017 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the internal microscopic cross section library +* (L_LIBRARY signature). +* IPTRK pointer to the tracking. (L_TRACK signature). +* IFTRAK unit number of the sequential binary tracking file. +* NGRO number of energy groups. +* NBISO number of isotopes present in the calculation domain. +* NBMIX number of mixtures in the macrolib. +* NREG number of regions. +* NUN number of unknowns in the flux or source vector in one +* energy group. +* CDOOR name of the geometry/solution module. +* NRES number of resonant mixtures. +* IMPX print flag. +* ISONRF reference name of isotopes. +* ISONAM alias name of isotopes. +* MIX mix number of each isotope (can be zero). +* DEN density of each isotope. +* LSHI resonant region number associated with each isotope. +* Infinite dilution will be assumed if LSHI(i)=0. +* IPHASE type of flux solution (=1 use a native flux solution door; +* =2 use collision probabilities). +* KSPH SPH equivalence flag (=0 no SPH correction; =1 SPH correction +* in the fuel). +* IPROB adjoint macrolib flag (=0 direct; =1 adjoint). +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX pointers of fluxes in unknown vector. +* LEAKSW leakage flag (=.true. if leakage is present on the outer +* surface). +* TITR title. +* IGRMIN first group where the self-shielding is applied. +* IGRMAX most thermal group where the self-shielding is applied. +* MAXX0 maximum number of self-shielding iterations. +* ITRANZ type of transport correction used in the self-shielding +* calculations. +* EPS convergence criterion for the self-shielding iterations. +* +*Parameters: input/output +* SN estimate of the dilution cross section in each energy group +* of each isotope on input and computed dilution cross section +* in each energy group of each isotope at output. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB,IPTRK + INTEGER IFTRAK,NGRO,NBISO,NBMIX,NREG,NUN,NRES,IMPX, + 1 ISONRF(3,NBISO),ISONAM(3,NBISO),MIX(NBISO),LSHI(NBISO),IPHASE, + 2 KSPH,IPROB,MAT(NREG),KEYFLX(NREG),IGRMIN,IGRMAX,MAXX0,ITRANZ + REAL DEN(NBISO),SN(NGRO,NBISO),VOL(NREG),EPS + LOGICAL LEAKSW + CHARACTER CDOOR*12,TITR*72 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NALPHA=9,NRAT=(NALPHA+1)/2,NSTATE=40) + TYPE(C_PTR) JPLIB,KPLIB + INTEGER IPAR(NSTATE) + REAL TMPDAY(3) + CHARACTER HSMG*130,TEXT12*12,HNAMIS*12 + LOGICAL START,LOGDO +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: LSHI2 + REAL, ALLOCATABLE, DIMENSION(:) :: VOLISO + REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGT1,SIGT2,SIGT3,SPH + LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASK,MASKL + LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: NOCONV +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(SIGT1(0:NBMIX,NGRO),SIGT2(0:NBMIX,NGRO), + 1 SIGT3(0:NBMIX,NGRO),VOLISO(NBISO)) + ALLOCATE(MASK(NBMIX),MASKL(NGRO),NOCONV(NBMIX,NGRO)) +* + IF(IMPX.GE.2) THEN + WRITE (6,'(//23H TONDRV: VALUES OF MAT:)') + I1=1 + KI=(NREG-1)/11+1 + DO 10 I=1,KI + I2=I1+10 + IF(I2.GT.NREG) I2=NREG + WRITE (6,350) (J,J=I1,I2) + WRITE (6,360) (MAT(J),J=I1,I2) + I1=I1+11 + 10 CONTINUE + WRITE (6,'(//)') + ENDIF +*---- +* RECOVER SELF SHIELDING DATA +*---- + IF(LEAKSW) CALL XABORT('TONDRV: NEUTRON LEAKAGE IS FORBIDDEN.') + IF(CDOOR.EQ.' ') CALL XABORT('TONDRV: THE GEOMETRY IS NOT YET ' + 1 //'DEFINED.') +* + TK3=0.0 + TK4=0.0 + CALL KDRCPU(TK1) + ICPIJ=0 + IF(IMPX.GT.0) THEN + WRITE (6,400) TITR,CDOOR + WRITE (6,'(15H TONE''S METHOD./)') + WRITE (6,405) IGRMIN,IGRMAX,MAXX0,KSPH,ITRANZ,IPHASE,EPS + ENDIF + IF(NRES.EQ.0) THEN + WRITE (6,410) + RETURN + ENDIF + DO 30 I=1,NREG + IF(MAT(I).GT.NBMIX) THEN + WRITE (HSMG,380) NBMIX + CALL XABORT(HSMG) + ENDIF + 30 CONTINUE + IGRMAX=MIN(IGRMAX,NGRO) + DO 60 LLL=1,NGRO + DO 50 IBM=1,NBMIX + NOCONV(IBM,LLL)=.FALSE. + 50 CONTINUE + 60 CONTINUE + CALL LCMSIX(IPLIB,'MACROLIB',1) + JPLIB=LCMGID(IPLIB,'GROUP') + DO 70 LLL=IGRMIN,IGRMAX + IF(IPROB.EQ.0) LL=LLL + IF(IPROB.EQ.1) LL=NGRO-LLL+1 + KPLIB=LCMGIL(JPLIB,LL) + SIGT2(0,LLL)=0.0 + CALL LCMGET(KPLIB,'NTOT0',SIGT2(1,LLL)) +*---- +* TRANSPORT CORRECTION +*---- + IF(ITRANZ.NE.0) THEN + SIGT3(0,LLL)=0.0 + CALL LCMGET(KPLIB,'TRANC',SIGT3(1,LLL)) + ELSE + SIGT3(0:NBMIX,LLL)=0.0 + ENDIF +* + NOCONV(:NBMIX,LLL)=.TRUE. + 70 CONTINUE + CALL LCMSIX(IPLIB,' ',2) + IF(IMPX.GE.2) THEN + WRITE (6,'(/19H TONE INPUT VALUES:/)') + DO 80 LLL=IGRMIN,IGRMAX + WRITE(6,420) LLL + WRITE(6,460) (SN(LLL,J),J=1,NBISO) + WRITE(6,480) (SIGT2(IBM,LLL),IBM=1,NBMIX) + 80 CONTINUE + WRITE(6,490) + ENDIF +*---- +* ELIMINATE ISOTOPE ABSENT FROM GEOMETRY +*---- + DO IBM=1,NBMIX + DO IREG=1,NREG + IF(MAT(IREG).EQ.IBM) GO TO 85 + ENDDO + DO ISO=1,NBISO + IF(MIX(ISO).EQ.IBM) LSHI(ISO)=0 + ENDDO + 85 CONTINUE + ENDDO +*---- +* RECOMPUTE THE VECTOR LSHI +*---- + ALLOCATE(LSHI2(NBISO)) + NRES1=0 + NRES2=0 + LSHI2(:NBISO)=0 + DO 140 INRS=1,NRES + 100 DENMAX=0.0 + KSOT=0 + DO 120 ISO=1,NBISO + VOLISO(ISO)=0.0 + DO 110 I=1,NREG + IF(MAT(I).EQ.MIX(ISO)) VOLISO(ISO)=VOLISO(ISO)+VOL(I) + 110 CONTINUE + IF(LSHI2(ISO).EQ.0) THEN + IF((LSHI(ISO).EQ.INRS).AND.(DEN(ISO)*VOLISO(ISO).GT.DENMAX)) + 1 THEN + KSOT=ISO + DENMAX=DEN(ISO)*VOLISO(ISO) + ENDIF + ENDIF + 120 CONTINUE + CALL LCMPUT(IPLIB,'ISOTOPESVOL',NBISO,2,VOLISO) + IF(KSOT.GT.0) THEN + NRES2=NRES2+1 + DO 130 ISO=1,NBISO + IF((ISONRF(1,ISO).EQ.ISONRF(1,KSOT)).AND. + 1 (ISONRF(2,ISO).EQ.ISONRF(2,KSOT)).AND. + 2 (ISONRF(3,ISO).EQ.ISONRF(3,KSOT)).AND. + 3 (LSHI(ISO).EQ.INRS)) LSHI2(ISO)=NRES2 + IF((ISONAM(1,ISO).EQ.ISONAM(1,KSOT)).AND. + 1 (ISONAM(2,ISO).EQ.ISONAM(2,KSOT)).AND. + 2 (LSHI(ISO).EQ.INRS)) LSHI2(ISO)=NRES2 + 130 CONTINUE + GO TO 100 + ENDIF + IF(NRES2.EQ.NRES1) THEN + WRITE(HSMG,'(43HTONDRV: NO RESONANT ISOTOPES IN RESONANT RE, + 1 11HGION NUMBER,I4,5H (1).)') INRS + CALL XABORT(HSMG) + ENDIF + NRES1=NRES2 + 140 CONTINUE +*---- +* ITERATION LOOP +*---- + NITER=0 + 160 NITER=NITER+1 + START=(NITER.EQ.1) + IF(IMPX.GT.5) WRITE (6,430) NITER + DO 170 L=IGRMIN,IGRMAX + SIGT1(0:NBMIX,L)=SIGT2(0:NBMIX,L) + 170 CONTINUE + DO 210 INRS=1,NRES2 + NBNRS=0 + TEXT12=' ' + DO 200 IBM=1,NBMIX + LOGDO=.FALSE. + DO 180 I=1,NREG + LOGDO=LOGDO.OR.(MAT(I).EQ.IBM) + 180 CONTINUE + IF(.NOT.LOGDO) GO TO 200 + DO 190 ISO=1,NBISO + IF((MIX(ISO).EQ.IBM).AND.(LSHI2(ISO).EQ.INRS)) THEN + WRITE(HNAMIS,'(3A4)') (ISONAM(I0,ISO),I0=1,3) + IF(HNAMIS.NE.TEXT12) THEN + IF(IMPX.GT.5) WRITE(6,'(/29H TONDRV: PROCESSING ISOTOPE '', + 1 A12,2H''.)') HNAMIS + NBNRS=NBNRS+1 + TEXT12=HNAMIS + ENDIF + ENDIF + 190 CONTINUE + 200 CONTINUE + IF(NBNRS.EQ.0) THEN + IF(START.AND.(IMPX.GE.1)) WRITE(6,385) 'TONDRV',INRS + GO TO 210 + ELSE IF(START.AND.(NBNRS.GT.1).AND.(IMPX.GE.1)) THEN + WRITE (6,370) NBNRS,INRS + ENDIF + CALL TONSN3 (IPLIB,IPTRK,IFTRAK,NGRO,NBISO,NBMIX,NREG,NUN, + 1 CDOOR,INRS,NBNRS,IMPX,ISONAM,MIX,DEN,SN,LSHI2,IPHASE,MAT, + 2 VOL,KEYFLX,LEAKSW,TITR,START,SIGT2,SIGT3,NOCONV,ICPIJ,TK3, + 3 TK4) + 210 CONTINUE + ZZMAX=0.0 + LNGRO=0 + ICOUNT=0 + DO 240 L=IGRMIN,IGRMAX + ZNORM=0.0 + DO 220 IBM=1,NBMIX + ZNORM=MAX(ZNORM,ABS(SIGT2(IBM,L))) + 220 CONTINUE + ZMAX=0.0 + MASKL(L)=.FALSE. + DO 230 IBM=1,NBMIX + YMAX=ABS(SIGT1(IBM,L)-SIGT2(IBM,L))/ZNORM + ZMAX=MAX(ZMAX,YMAX) + NOCONV(IBM,L)=(NOCONV(IBM,L).AND.(YMAX.GT.EPS)) + MASKL(L)=MASKL(L).OR.NOCONV(IBM,L) + 230 CONTINUE + IF(MASKL(L)) ICOUNT=ICOUNT+1 + IF(ZMAX.GT.ZZMAX) THEN + ZZMAX=ZMAX + LNGRO=L + ENDIF + 240 CONTINUE + IF(IMPX.GT.5) WRITE (6,440) NITER,ICOUNT,ZZMAX,LNGRO + IF(IMPX.GE.10) THEN + WRITE (6,450) (L,MASKL(L),L=IGRMIN,IGRMAX) + WRITE (6,'(/31H INPUT MACROSCOPIC X-S IN GROUP,I4,1H:)') LNGRO + WRITE (6,'(1X,1P,10E12.4)') (SIGT1(IBM,LNGRO),IBM=1,NBMIX) + WRITE (6,'(/32H OUTPUT MACROSCOPIC X-S IN GROUP,I4,1H:)') LNGRO + WRITE (6,'(1X,1P,10E12.4)') (SIGT2(IBM,LNGRO),IBM=1,NBMIX) + ENDIF + IF(IMPX.GT.5) THEN + WRITE (6,'(/29H OUTPUT DILUTION X-S IN GROUP,I4,1H:)') LNGRO + WRITE (6,'(1X,1P,10E12.4)') (SN(LNGRO,J),J=1,NBISO) + ENDIF + IF((NITER.GE.MAXX0).AND.(ICOUNT.GT.0)) THEN + WRITE (6,390) + GO TO 250 + ELSE IF(ICOUNT.GT.0) THEN + GO TO 160 + ENDIF +*---- +* CONVERGENCE IS OBTAINED +*---- + 250 IF(IMPX.GE.2) THEN + WRITE (6,'(/20H TONE OUTPUT VALUES:/)') + WRITE(6,415) ((ISONAM(I0,J),I0=1,2),J=1,NBISO) + DO 260 L=IGRMIN,IGRMAX + WRITE(6,420) L + WRITE(6,460) (SN(L,J),J=1,NBISO) + IF(IMPX.GE.5) WRITE(6,480) (SIGT2(IBM,L),IBM=1,NBMIX) + 260 CONTINUE + WRITE(6,490) + ENDIF +*---- +* COMPUTE THE NEW SELF-SHIELDED MACROSCOPIC CROSS SECTIONS +*---- + MASKL(:NGRO)=.FALSE. + DO 270 LLL=IGRMIN,IGRMAX + MASKL(LLL)=.TRUE. + 270 CONTINUE + DO 290 IBM=1,NBMIX + DO 280 ISO=1,NBISO + MASK(IBM)=(MIX(ISO).EQ.IBM).AND.(LSHI(ISO).GT.0) + IF(MASK(IBM)) GO TO 290 + 280 CONTINUE + 290 CONTINUE + ITSTMP=0 + TMPDAY(1)=0.0 + TMPDAY(2)=0.0 + TMPDAY(3)=0.0 + CALL LIBMIX(IPLIB,NBMIX,NGRO,NBISO,ISONAM,MIX,DEN,MASK,MASKL, + > ITSTMP,TMPDAY) + IF(IMPX.GT.0) WRITE (6,500) NITER,ZZMAX +*---- +* COMPUTE THE SPH FACTORS +*---- + IF(KSPH.EQ.1) THEN + CALL LCMSIX(IPLIB,'MACROLIB',1) + JPLIB=LCMGID(IPLIB,'GROUP') + DO 300 LLL=IGRMIN,IGRMAX + IF(IPROB.EQ.0) LL=LLL + IF(IPROB.EQ.1) LL=NGRO-LLL+1 + KPLIB=LCMGIL(JPLIB,LL) + SIGT2(0,LLL)=0.0 + CALL LCMGET(KPLIB,'NTOT0',SIGT2(1,LLL)) + IF(ITRANZ.NE.0) THEN + SIGT3(0,LLL)=0.0 + CALL LCMGET(KPLIB,'TRANC',SIGT3(1,LLL)) + ELSE + SIGT3(0:NBMIX,LLL)=0.0 + ENDIF + 300 CONTINUE + CALL LCMSIX(IPLIB,' ',2) + DO 340 INRS=1,NRES2 + NBNRS=0 + TEXT12=' ' + DO 330 IBM=1,NBMIX + LOGDO=.FALSE. + DO 310 I=1,NREG + LOGDO=LOGDO.OR.(MAT(I).EQ.IBM) + 310 CONTINUE + IF(.NOT.LOGDO) GO TO 330 + DO 320 ISO=1,NBISO + IF((MIX(ISO).EQ.IBM).AND.(LSHI2(ISO).EQ.INRS)) THEN + WRITE(HNAMIS,'(3A4)') (ISONAM(I0,ISO),I0=1,3) + IF(HNAMIS.NE.TEXT12) THEN + NBNRS=NBNRS+1 + TEXT12=HNAMIS + ENDIF + ENDIF + 320 CONTINUE + 330 CONTINUE + IF(NBNRS.GT.1) THEN + ALLOCATE(SPH(NBMIX,NGRO)) + SPH(:NBMIX,:NGRO)=1.0 + CALL TONSPH(IPLIB,IPTRK,IFTRAK,NREG,NUN,NBMIX,NBISO,ISONAM, + 1 MAT,VOL,KEYFLX,CDOOR,INRS,LEAKSW,IMPX,DEN,MIX,LSHI2,ITRANZ, + 2 IPHASE,NGRO,IGRMIN,IGRMAX,NBNRS,TITR,SIGT2,SIGT3,SN,SPH, + 3 ICPIJ,TK3,TK4) + DEALLOCATE(SPH) + ENDIF + 340 CONTINUE + CALL LIBMIX(IPLIB,NBMIX,NGRO,NBISO,ISONAM,MIX,DEN,MASK,MASKL, + > ITSTMP,TMPDAY) + CALL KDRCPU(TK2) + ENDIF + DEALLOCATE(LSHI2) + CALL KDRCPU(TK2) + IF(IMPX.GT.1) WRITE(6,'(/9H TONDRV: ,F8.1,18H SECOND TO PERFORM, + 1 16H SELF SHIELDING;/9X,F8.1,30H SECOND TO COMPUTE SYSTEM MATR, + 2 5HICES;/9X,F8.1,31H SECOND TO COMPUTE FLUX VALUES;/9X,I7,2X, + 3 25HFLUX SOLUTION DOOR CALLS.)') TK2-TK1,TK3,TK4,ICPIJ +*---- +* STORE THE GENERAL SHIBA PARAMETERS +*---- + IPAR(:NSTATE)=0 + IPAR(1)=IGRMIN + IPAR(2)=IGRMAX + IPAR(3)=MAXX0 + IPAR(4)=KSPH + IPAR(5)=0 + IPAR(6)=ITRANZ + IPAR(7)=1 + IPAR(8)=IPHASE + CALL LCMSIX(IPLIB,'SHIBA',1) + CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,IPAR) + CALL LCMPUT(IPLIB,'EPS-SHIBA',1,2,EPS) + CALL LCMSIX(IPLIB,' ',2) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(NOCONV,MASKL,MASK) + DEALLOCATE(VOLISO,SIGT3,SIGT2,SIGT1) + RETURN +* + 350 FORMAT(//26H VOLUME NB. :,11(I5,3X,1HI)) + 360 FORMAT( 26H MIXTURE (MAT) :,11(I5,3X,1HI)) + 370 FORMAT(/42H TONDRV: USE THE NORDHEIM MODEL TO PROCESS,I3,5H RESO, + 1 39HNANT MIXTURES IN RESONANT REGION NUMBER,I3,1H.) + 380 FORMAT(32HTONDRV: INVALID VALUE OF NBMIX (,I5,2H).) + 385 FORMAT(A6,1X,': RESONANT REGION =',I10,1X,'NOT USED.') + 390 FORMAT(/1X,61(1H*)/42H TONDRV: MAXIMUM NUMBER OF SELF-SHIELDING , + 1 20HITERATIONS EXCEEDED./1X,61(1H*)/) + 400 FORMAT( + > 1X,'MULTIDIMENSIONAL SELF-SHIELDING CALCULATION WITH TONE''S ', + > 'METHOD -> A. HEBERT'/ + > 1X,A72/ + > 1X,'COLLISION PROBABILITY MODULE: ',A12/) + 405 FORMAT(/8H OPTIONS/8H -------/ + 1 7H IGRMIN,I8,27H (FIRST GROUP TO PROCESS)/ + 2 7H IGRMAX,I8,34H (MOST THERMAL GROUP TO PROCESS)/ + 3 7H MAXX0 ,I8,33H (MAXIMUM NUMBER OF ITERATIONS)/ + 4 7H KSPH ,I8,46H (=0: NO SPH CORRECTION; =1: SPH CORRECTION , + 5 20HIN RESONANT REGIONS)/ + 6 7H ITRANZ,I8,45H (0=NO TRANSPORT CORRECTION/1=APOLLO TYPE/2, + 7 57H=RECOVER FROM LIBRARY/3=WIMS-D TYPE/4=LEAKAGE CORRECTION)/ + 8 7H IPHASE,I8,37H (=1: NATIVE ASSEMBLY; =2: USE PIJ)/ + 9 7H EPS ,1P,E8.1,22H (STOPING CRITERION)/) + 410 FORMAT(/52H TONDRV: THERE IS NO REQUEST TO PROCESS ANY RESONANT, + 1 9H ISOTOPE./) + 415 FORMAT(12X,2A4,3X,2A4,3X,2A4,3X,2A4,3X,2A4,3X,2A4,3X,2A4,3X,2A4, + 1 3X,2A4,3X,2A4,3X,2A4) + 420 FORMAT(1X,131(1H-)/8H GROUP =,I4/) + 430 FORMAT(/40H PERFORMING SELF-SHIELDING ITERATION NB.,I5) + 440 FORMAT(/27H SELF-SHIELDING ITERATION =,I4,5X,14HNUMBER OF NON , + 1 18HCONVERGED GROUPS =,I4,5X,7HERROR =,1P,E13.4,0P,9H IN GROUP, + 2 I4/) + 450 FORMAT(7H MASKL(,I3,2H)=,L1,:,8H MASKL(,I3,2H)=,L1,:,8H MASKL(, + 1 I3,2H)=,L1,:,8H MASKL(,I3,2H)=,L1,:,8H MASKL(,I3,2H)=,L1,:, + 2 8H MASKL(,I3,2H)=,L1,:,8H MASKL(,I3,2H)=,L1,:,8H MASKL(,I3, + 3 2H)=,L1,:,8H MASKL(,I3,2H)=,L1) + 460 FORMAT(/37H MICROSCOPIC DILUTION CROSS SECTIONS:/(9X,1P,11E11.3)) + 480 FORMAT(/34H MACROSCOPIC TOTAL CROSS SECTIONS:/(9X,1P,11E11.3)) + 490 FORMAT(/1X,131(1H-)/) + 500 FORMAT(/40H CONVERGENCE REACHED AT TONE ITERATION =,I4,7H ERROR, + 1 2H =,1P,E11.3/) + END diff --git a/Dragon/src/TONDST.f b/Dragon/src/TONDST.f new file mode 100644 index 0000000..4b75bda --- /dev/null +++ b/Dragon/src/TONDST.f @@ -0,0 +1,205 @@ +*DECK TONDST + SUBROUTINE TONDST (IPSYS,NPSYS,IPTRK,IFTRAK,CDOOR,IMPX,NBM,NBNRS, + 1 NREG,NUN,NGRO,IPHASE,MAT,VOL,KEYFLX,LEAKSW,IRES,DENM,SIGT0,SIGT2, + 2 SIGT3,TITR,DILAV,TK3,TK4) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of escape probability information. +* +*Copyright: +* Copyright (C) 2017 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPSYS pointer to the pij (L_PIJ signature). +* NPSYS index array pointing to the IPSYS list component corresponding +* to each energy group. Set to zero if a group is not to be +* processed. Usually, NPSYS(I)=I. +* IPTRK pointer to the tracking. (L_TRACK signature). +* IFTRAK unit number of the sequential binary tracking file. +* CDOOR name of the geometry/solution module. +* IMPX print flag (equal to zero for no print). +* NBM number of mixtures. +* NBNRS number of totaly correlated resonant regions. +* NREG total number of merged blocks for which specific values +* of the neutron flux and reactions rates are required. +* NUN number of unknowns in the flux or source vector in one +* energy group. +* NGRO number of energy groups. +* IPHASE type of flux solution (=1 use a native flux solution door; +* =2 use collision probabilities). +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX pointers of fluxes in unknown vector. +* LEAKSW leakage flag (=.TRUE. if leakage is present on the outer +* surface). +* IRES resonant mixture number assigned to each mixture. +* DENM number density of the resonant isotope in each mixture. +* SIGT0 total macroscopic cross sections of the resonant isotope +* in each mixture. +* SIGT2 total macroscopic cross sections of the light materials in +* each mixture. +* SIGT3 transport correction in each mixture. +* TITR title. +* +*Parameters: output +* DILAV average dilution. +* +*Parameters: input/output +* TK3 cpu time to compute system matrices. +* TK4 cpu time to compute fluxes. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE DOORS_MOD +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSYS,IPTRK + CHARACTER CDOOR*12,TITR*72 + LOGICAL LEAKSW + INTEGER NPSYS(NGRO),IFTRAK,IMPX,NBM,NBNRS,NREG,NUN,NGRO,IPHASE, + 1 MAT(NREG),KEYFLX(NREG),IRES(NBM) + REAL VOL(NREG),DENM(0:NBM),SIGT0(0:NBM,NGRO),SIGT2(0:NBM,NGRO), + 1 SIGT3(0:NBM,NGRO),DILAV(NBNRS,NGRO),TK3,TK4 +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPSYS,KPSYS,IPMACR,IPSOU + LOGICAL LNORM,LEXAC,REBFLG + REAL, ALLOCATABLE, DIMENSION(:) :: SSIGT,SSIGW + REAL, ALLOCATABLE, DIMENSION(:,:) :: SUN,FUN1,FUN2 + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: TOT1,TOT2 + INTEGER NALBP +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(SSIGT(0:NBM),SSIGW(0:NBM)) +*---- +* INITIALIZATIONS. +*---- + NALBP=0 + NANI=1 + NW=0 + IPIJK=1 + ITPIJ=1 + KNORM=1 + LNORM=.FALSE. + IDIR=0 + LEXAC=.FALSE. + JPSYS=LCMLID(IPSYS,'GROUP',NGRO) +*---- +* SELECT THE MACROSCOPIC CROSS SECTIONS. +*---- + SSIGT(0)=0.0 + SSIGW(0)=0.0 + DO 20 LLL=1,NGRO + IF(NPSYS(LLL).NE.0) THEN + DO 10 IBM=1,NBM + SSIGT(IBM)=SIGT0(IBM,LLL)+SIGT2(IBM,LLL)-SIGT3(IBM,LLL) + SSIGW(IBM)=-SIGT3(IBM,LLL) + 10 CONTINUE + KPSYS=LCMDIL(JPSYS,LLL) + CALL LCMPUT(KPSYS,'DRAGON-TXSC',NBM+1,2,SSIGT(0)) + CALL LCMPUT(KPSYS,'DRAGON-S0XSC',NBM+1,2,SSIGW(0)) + ENDIF + 20 CONTINUE +*---- +* ASSEMBLY MATRIX OR REDUCED COLLISION PROBABILITIES CALCULATION. +*---- + CALL KDRCPU(TKA) + ISTRM=1 + IF(IPHASE.EQ.1) THEN +* USE A NATIVE DOOR. + CALL DOORAV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IMPX,NGRO,NREG, + 1 NBM,NANI,NW,MAT,VOL,KNORM,LEAKSW,TITR,NALBP,ISTRM) + ELSE IF(IPHASE.EQ.2) THEN +* USE A COLLISION PROBABILITY DOOR. + CALL DOORPV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IMPX,NGRO,NREG, + 1 NBM,NANI,MAT,VOL,KNORM,IPIJK,LEAKSW,ITPIJ,LNORM,TITR,NALBP) + ENDIF + CALL KDRCPU(TKB) + TK3=TK3+(TKB-TKA) +*---- +* ALLOCATE MEMORY. +*---- + ALLOCATE(SUN(NUN,NGRO),FUN1(NUN,NGRO),FUN2(NUN,NGRO)) +*---- +* SOLVE FOR THE FLUX AND SET UP VECTOR DILAV. +*---- + CALL KDRCPU(TKA) + SUN(:NUN,:NGRO)=0.0 + DO 30 LLL=1,NGRO + IF(NPSYS(LLL).NE.0) THEN + CALL DOORS(CDOOR,IPTRK,NBM,0,NUN,SIGT2(0,LLL),SUN(1,LLL)) + ENDIF + 30 CONTINUE + CALL LCMLEN(IPSYS,'FLUX1',ILON1,ITYLCM) + IF(ILON1.EQ.NUN*NGRO) THEN + CALL LCMGET(IPSYS,'FLUX1',FUN1) + ELSE + FUN1(:NUN,:NGRO)=0.0 + ENDIF + IPMACR=C_NULL_PTR + IPSOU=C_NULL_PTR + REBFLG=.FALSE. + CALL DOORFV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IMPX,NGRO,NBM,IDIR, + 1 NREG,NUN,IPHASE,LEXAC,MAT,VOL,KEYFLX,TITR,SUN,FUN1,IPMACR, + 2 IPSOU,REBFLG) + CALL LCMPUT(IPSYS,'FLUX1',NUN*NGRO,2,FUN1) +* + SUN(:NUN,:NGRO)=0.0 + DO 40 LLL=1,NGRO + IF(NPSYS(LLL).NE.0) THEN + CALL DOORS(CDOOR,IPTRK,NBM,0,NUN,DENM,SUN(1,LLL)) + ENDIF + 40 CONTINUE + CALL LCMLEN(IPSYS,'FLUX2',ILON2,ITYLCM) + IF(ILON2.EQ.NUN*NGRO) THEN + CALL LCMGET(IPSYS,'FLUX2',FUN2) + ELSE + FUN2(:NUN,:NGRO)=0.0 + ENDIF + IPMACR=C_NULL_PTR + REBFLG=.FALSE. + CALL DOORFV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IMPX,NGRO,NBM,IDIR, + 1 NREG,NUN,IPHASE,LEXAC,MAT,VOL,KEYFLX,TITR,SUN,FUN2,IPMACR, + 2 IPSOU,REBFLG) + CALL LCMPUT(IPSYS,'FLUX2',NUN*NGRO,2,FUN2) + ALLOCATE(TOT2(NBNRS),TOT1(NBNRS)) + DO 70 LLL=1,NGRO + IF(NPSYS(LLL).NE.0) THEN + TOT2(:)=0.0D0 + TOT1(:)=0.0D0 + DO 50 I=1,NREG + IBM=MAT(I) + IF(IBM.EQ.0) GO TO 50 + IRS=IRES(IBM) + IF(IRS.GT.0) THEN + TOT1(IRS)=TOT1(IRS)+FUN1(KEYFLX(I),LLL)*VOL(I) + TOT2(IRS)=TOT2(IRS)+FUN2(KEYFLX(I),LLL)*VOL(I) + ENDIF + 50 CONTINUE + DO 60 IRS=1,NBNRS + DILAV(IRS,LLL)=REAL(TOT1(IRS)/TOT2(IRS)) + 60 CONTINUE + ENDIF + 70 CONTINUE + DEALLOCATE(TOT2,TOT1) + CALL KDRCPU(TKB) + TK4=TK4+(TKB-TKA) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SUN,FUN2,FUN1) + DEALLOCATE(SSIGW,SSIGT) + RETURN + END diff --git a/Dragon/src/TONE.f b/Dragon/src/TONE.f new file mode 100644 index 0000000..e5c3faa --- /dev/null +++ b/Dragon/src/TONE.f @@ -0,0 +1,276 @@ +*DECK TONE + SUBROUTINE TONE(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Interpolation of nuclear properties in a lattice code library using +* the Tone's method. +* +*Copyright: +* Copyright (C) 2017 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file. When 3 object are present: +* HENTRY(1) modification type(L_LIBRARY); +* HENTRY(2) read-only type(L_TRACK); +* HENTRY(3) read-only sequential binary tracking file. +* When 4 object are present: +* HENTRY(1) creation type(L_LIBRARY); +* HENTRY(2) read-only type(L_LIBRARY); +* HENTRY(3) read-only type(L_TRACK); +* HENTRY(4) read-only sequential binary tracking file. +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + CHARACTER HSMG*131,TEXT12*12,HSIGN*12,TEXT4*4,CDOOR*12,TITLE*72 + INTEGER IPAR(NSTATE),IGP(NSTATE) + DOUBLE PRECISION DFLOTT + LOGICAL LEAKSW + TYPE(C_PTR) IPLIB,IPTRK +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MAT,IDL,MIX,LSHI,ISONR,ISONA + REAL, ALLOCATABLE, DIMENSION(:) :: VOL,DEN,SNGAR +*---- +* PARAMETER VALIDATION +*---- + IENT=1 + IF(NENTRY.LE.1) CALL XABORT('TONE: TWO PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('TONE: LCM ' + 1 //'OBJECT EXPECTED AT LHS.') + IF(JENTRY(1).EQ.0) THEN +* INTERNAL LIBRARY CREATION. COPY THE FIRST RHS ON THIS LHS. + IF(NENTRY.LE.2) CALL XABORT('TONE: THREE PARAMETERS EXPECTED.') + IF((JENTRY(2).NE.2).OR.((IENTRY(2).NE.1).AND. + 1 (IENTRY(2).NE.2))) CALL XABORT('TONE: LCM OBJECT IN READ-ONLY' + 2 //'MODE EXPECTED AT FIRST RHS.') + CALL LCMEQU(KENTRY(2),KENTRY(1)) + IENT=3 + ELSE IF(JENTRY(1).EQ.1) THEN +* INTERNAL LIBRARY MODIFICATION. + IENT=2 + ELSE + CALL XABORT('TONE: INTERNAL LIBRARY IN CREATE OR MODIFICATION ' + 1 //'MODE EXPECTED.') + ENDIF + IPLIB=KENTRY(1) +*---- +* RECOVER THE TRACKING OBJECT +*---- + DO 10 I=IENT,NENTRY + IF((JENTRY(I).EQ.2).AND.(IENTRY(I).LE.2)) THEN + CALL LCMGTC(KENTRY(I),'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_TRACK') THEN + IPTRK=KENTRY(I) + GO TO 20 + ENDIF + ENDIF + 10 CONTINUE + CALL XABORT('TONE: UNABLE TO FIND A TRACKING OBJECT.') + 20 CALL LCMGTC(IPTRK,'TRACK-TYPE',12,CDOOR) +*---- +* RECOVER TRACKING FILE INFORMATION +*---- + IFTRAK=0 + DO 40 I=IENT+1,NENTRY + IF(IENTRY(I).EQ.3) THEN + IFTRAK=FILUNIT(KENTRY(I)) + TEXT12=HENTRY(I) + IF(JENTRY(I).NE.2) CALL XABORT('TONE: TRACKING FILE '//TEXT12// + 1 ' NOT IN READ-ONLY MODE.') + GO TO 50 + ENDIF + 40 CONTINUE +*---- +* RECOVER TABULATED FUNCTIONS +*---- + 50 CALL XDRTA2 +*---- +* RECOVER GENERAL TRACKING INFORMATION +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',IGP) + NREG=IGP(1) + NUN=IGP(2) + LEAKSW=IGP(3).EQ.0 + IF(CDOOR.EQ.'MCCG') THEN + CALL LCMLEN(IPTRK,'KEYFLX',LKFL,ITYLCM) + NFUNL=LKFL/NREG + ELSE + NFUNL=1 + ENDIF + ALLOCATE(MAT(NREG),VOL(NREG),IDL(NREG*NFUNL)) + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'VOLUME',VOL) + CALL LCMGET(IPTRK,'KEYFLX',IDL) + CALL LCMLEN(IPTRK,'TITLE',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGTC(IPTRK,'TITLE',72,TITLE) + ELSE + TITLE='*** NO TITLE PROVIDED ***' + ENDIF +*---- +* RECOVER GENERAL INTERNAL LIBRARY INFORMATION +*---- + CALL LCMGTC(IPLIB,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_LIBRARY') THEN + TEXT12=HENTRY(1) + CALL XABORT('TONE: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_LIBRARY EXPECTED.') + ENDIF + CALL LCMGET(IPLIB,'STATE-VECTOR',IPAR) + NBISO=IPAR(2) + NGRO=IPAR(3) + ITRANC=IPAR(5) + IPROB=IPAR(6) + IGRMIN=IPAR(9)+1 + IGRMAX=IPAR(10) + NBMIX=IPAR(14) + NRES=IPAR(15) + IF(NGRO.LT.250) THEN + WRITE(6,'(/48H TONE: *** WARNING*** THIS SIMPLIFIED SELF-SHIEL, + 1 48HDING MODEL REQUIRES MORE THAN 250 ENERGY GROUPS.)') + ENDIF + IF(IGP(4).GT.NBMIX) THEN + WRITE(HSMG,'(44HTONE: THE NUMBER OF MIXTURES IN THE TRACKING, + 1 2H (,I5,50H) IS GREATER THAN THE NUMBER OF MIXTURES IN THE IN, + 2 16HTERNAL LIBRARY (,I5,2H).)') IGP(4),NBMIX + CALL XABORT(HSMG) + ENDIF + ALLOCATE(MIX(NBISO),DEN(NBISO),LSHI(NBISO),SNGAR(NGRO*NBISO)) + CALL LCMGET(IPLIB,'ISOTOPESMIX',MIX) + CALL LCMGET(IPLIB,'ISOTOPESDENS',DEN) + CALL LCMGET(IPLIB,'ISOTOPESSHI',LSHI) + CALL LCMGET(IPLIB,'ISOTOPESDSN',SNGAR) +*---- +* RECOVER REFERENCE AND ALIAS ISOTOPES NAMES +*---- + ALLOCATE(ISONR(3*NBISO),ISONA(3*NBISO)) + CALL LCMGET(IPLIB,'ISOTOPERNAME',ISONR) + CALL LCMGET(IPLIB,'ISOTOPESUSED',ISONA) +*---- +* READ THE INPUT DATA +*---- +* DEFAULT OPTIONS: + IMPX=1 + CALL LCMLEN(IPLIB,'SHIBA',LENLCM,ITYLCM) + IF(LENLCM.NE.0) THEN + CALL LCMSIX(IPLIB,'SHIBA',1) + CALL LCMGET(IPLIB,'STATE-VECTOR',IPAR) + CALL LCMGET(IPLIB,'EPS-SHIBA',EPS) + CALL LCMSIX(IPLIB,' ',2) + IGRMIN=IPAR(1) + IGRMAX=IPAR(2) + MAXX0=IPAR(3) + KSPH=IPAR(4) + ITRANZ=IPAR(6) + LEVEL=IPAR(7) + IPHASE=IPAR(8) + ELSE + MAXX0=20 + KSPH=1 + ITRANZ=ITRANC + LEVEL=0 + EPS=1.0E-4 + IF(CDOOR.EQ.'SYBIL') THEN + IPHASE=2 + ELSE IF(CDOOR.EQ.'EXCELL') THEN + IPHASE=2 + ELSE + IPHASE=1 + ENDIF + ENDIF +*---- +* READ LIBRARY DATA +*---- + 60 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.10) GO TO 100 + IF(INDIC.NE.3) CALL XABORT('TONE: CHARACTER DATA EXPECTED.') + IF(TEXT4.EQ.'EDIT') THEN +* READ THE PRINT INDEX. + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('TONE: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT4.EQ.'GRMI') THEN + CALL REDGET(ITYPLU,IGRMIN,FLOTT,TEXT4,DFLOTT) + IF(ITYPLU.NE.1) CALL XABORT('TONE: INTEGER DATA EXPECTED(2).') + ELSE IF(TEXT4.EQ.'GRMA') THEN + CALL REDGET(ITYPLU,IGRMAX,FLOTT,TEXT4,DFLOTT) + IF(ITYPLU.NE.1) CALL XABORT('TONE: INTEGER DATA EXPECTED(3).') + IF(IGRMAX.GT.NGRO) THEN + CALL XABORT('TONE: ILLEGAL NUMBER OF GROUP IN LIBRARY.') + ENDIF + ELSE IF(TEXT4.EQ.'MXIT') THEN + CALL REDGET(ITYPLU,MAXX0,FLOTT,TEXT4,DFLOTT) + IF(ITYPLU.NE.1) CALL XABORT('TONE: INTEGER DATA EXPECTED(4).') + ELSE IF(TEXT4.EQ.'EPS') THEN + CALL REDGET(ITYPLU,NITMA,EPS,TEXT4,DFLOTT) + IF(ITYPLU.NE.2) CALL XABORT('TONE: REAL DATA EXPECTED.') + ELSE IF(TEXT4.EQ.'NOTR') THEN + ITRANZ=0 + ELSE IF(TEXT4.EQ.'TRAN') THEN + ITRANZ=ITRANC + ELSE IF(TEXT4.EQ.'ARM') THEN + IPHASE=1 + ELSE IF(TEXT4.EQ.'PIJ') THEN + IPHASE=2 + ELSE IF(TEXT4.EQ.'NOSP') THEN + KSPH=0 + ELSE IF(TEXT4.EQ.'SPH') THEN + KSPH=1 + ELSE IF(TEXT4.EQ.';') THEN + GO TO 100 + ELSE + CALL XABORT('TONE: '//TEXT4//' IS AN INVALID KEY-WORD.') + ENDIF + GO TO 60 +*---- +* THE NUMBER OF UNKNOWNS OF A CURRENT-BASED MULTICELL ITERATION IS +* INCREASED TO HOLD INTERFACE CURRENT COMPONENTS. +*---- + 100 IF(IPHASE.EQ.1) THEN + IF(CDOOR.EQ.'SYBIL') NUN=NUN+IGP(9) + IF((CDOOR.EQ.'EXCELL').AND.(IGP(7).EQ.5)) NUN=NUN+IGP(28) + ENDIF + IF(NBMIX.EQ.0) CALL XABORT('TONE: NBMIX NOT YET DEFINED.') + IF(NRES.EQ.0) CALL XABORT('TONE: THERE IS NO RESONANT ISOTOPES.') + IF(NREG.EQ.0) CALL XABORT('TONE: NREG = 0') + CALL TONDRV(IPLIB,IPTRK,IFTRAK,NGRO,NBISO,NBMIX,NREG,NUN,CDOOR, + 1 NRES,IMPX,ISONR,ISONA,MIX,DEN,SNGAR,LSHI,IPHASE,KSPH,IPROB,MAT, + 2 VOL,IDL,LEAKSW,TITLE,IGRMIN,IGRMAX,MAXX0,ITRANZ,EPS) +*---- +* RELEASE GENERAL TRACKING INFORMATION +*---- + DEALLOCATE(IDL,VOL,MAT) +*---- +* RELEASE GENERAL INTERNAL LIBRARY INFORMATION +*---- + DEALLOCATE(ISONA,ISONR,SNGAR,LSHI,DEN,MIX) + RETURN + END diff --git a/Dragon/src/TONSN3.f b/Dragon/src/TONSN3.f new file mode 100644 index 0000000..e5ced06 --- /dev/null +++ b/Dragon/src/TONSN3.f @@ -0,0 +1,267 @@ +*DECK TONSN3 + SUBROUTINE TONSN3 (IPLIB,IPTRK,IFTRAK,NGRO,NBISO,NBM,NREG,NUN, + 1 CDOOR,INRS,NBNRS,IMPX,ISONAM,MIX,DEN,SN,LSHI,IPHASE,MAT,VOL, + 2 KEYFLX,LEAKSW,TITR,START,SIGT2,SIGT3,NOCONV,ICPIJ,TK3,TK4) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform one multidimensional self-shielding iteration using the +* Tone's method with Nordheim (PIC) approximation. +* +*Copyright: +* Copyright (C) 2017 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the internal microscopic cross section library +* (L_LIBRARY signature). +* IPTRK pointer to the tracking. (L_TRACK signature). +* IFTRAK unit number of the sequential binary tracking file. +* NGRO number of energy groups. +* NBISO number of isotopes present in the calculation domain. +* NBM number of mixtures in the macrolib. +* NREG number of volumes. +* NUN number of unknowns in the flux or source vector in one +* energy group. +* CDOOR name of the geometry/solution module. +* INRS index of the resonant isotope under consideration. +* NBNRS number of totaly correlated resonant regions. +* IMPX print flag. +* ISONAM alias name of isotopes. +* MIX mix number of each isotope (can be zero). +* DEN density of each isotope. +* LSHI resonant region number associated with each isotope. +* Infinite dilution will be assumed if LSHI(i)=0. +* IPHASE type of flux solution (=1 use a native flux solution door; +* =2 use collision probabilities). +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX pointers of fluxes in unknown vector. +* LEAKSW leakage flag (=.TRUE. if leakage is present on the outer +* surface). +* TITR title. +* START beginning-of-iteration flag (=.TRUE. if TONSN3 is called +* for the first time). +* SIGT3 transport correction. +* NOCONV mixture convergence flag. (NOCONV(IBM,L)=.TRUE. if mixture IBM +* is not converged in group L). +* +*Parameters: input/output +* SN estimate of the dilution cross section in each energy group +* of each isotope on input and computed dilution cross section +* in each energy group of each isotope at output. +* SIGT2 total macroscopic cross sections on ipput and total +* macroscopic cross sections as modified by Tone's method +* at output. +* +*Parameters: output +* ICPIJ number of flux solution door calls. +* +*Reference: +* A. Hebert, 'Revisiting the Stamm'ler Self-Shielding Method', Presented +* at the 25th CNS annnual conference, June 6-9, Toronto, 2004. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB,IPTRK + INTEGER IFTRAK,NGRO,NBISO,NBM,NREG,NUN,INRS,NBNRS,IMPX, + 1 ISONAM(3,NBISO),MIX(NBISO),LSHI(NBISO),IPHASE,MAT(NREG), + 2 KEYFLX(NREG),ICPIJ + REAL DEN(NBISO),SN(NGRO,NBISO),VOL(NREG),SIGT2(0:NBM,NGRO), + 1 SIGT3(0:NBM,NGRO),TK3,TK4 + CHARACTER CDOOR*12,TITR*72 + LOGICAL LEAKSW,START,NOCONV(NBM,NGRO) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) KPLIB + CHARACTER TEXT12*12,HNAMIS*12 + LOGICAL LOGDO +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IRES,ISONR,NPSYS + REAL, ALLOCATABLE, DIMENSION(:) :: GAR,GAS,VST,DENM + REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGT0,TOTAL,SIGE + LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASKI + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO +*---- +* SCRATCH STORAGE ALLOCATION +* SIGT0 macroscopic xs of the resonant isotopes as interpolated. +*---- + ALLOCATE(IRES(NBM),ISONR(NBISO),NPSYS(NGRO)) + ALLOCATE(SIGT0(0:NBM,NGRO),TOTAL(NGRO,NBNRS),DENM(0:NBM), + 1 GAR(NGRO),GAS(NGRO),SIGE(NBNRS,NGRO),VST(NBNRS)) + ALLOCATE(MASKI(NBISO)) + ALLOCATE(IPISO(NBISO)) +*---- +* FIND THE RESONANT MIXTURE NUMBERS AND THE CORRELATED ISOTOPES +* ASSOCIATED WITH REGION INRS +*---- + IRES(:NBM)=0 + ISONR(:NBISO)=0 + MASKI(:NBISO)=.FALSE. + IRS=0 + TEXT12=' ' + DO 30 IBM=1,NBM + LOGDO=.FALSE. + DO 10 I=1,NREG + LOGDO=LOGDO.OR.(MAT(I).EQ.IBM) + 10 CONTINUE + IF(.NOT.LOGDO) GO TO 30 + DO 20 ISO=1,NBISO + LOGDO=START.OR.(DEN(ISO).NE.0.) + IF((MIX(ISO).EQ.IBM).AND.(LSHI(ISO).EQ.INRS)) THEN + WRITE(HNAMIS,'(3A4)') (ISONAM(I0,ISO),I0=1,3) + IF(HNAMIS.NE.TEXT12) THEN + IRS=IRS+1 + TEXT12=HNAMIS + IF(LOGDO) MASKI(ISO)=.TRUE. + ENDIF + ISONR(ISO)=IRS + IRES(IBM)=IRS + ENDIF + 20 CONTINUE + 30 CONTINUE + IF(IRS.NE.NBNRS) CALL XABORT('TONSN3: INVALID VALUE OF NBNRS.') +*---- +* SET THE LCM MICROLIB ISOTOPEWISE DIRECTORIES. +*---- + CALL LIBIPS(IPLIB,NBISO,IPISO) +*---- +* UNLOAD MICROSCOPIC X-S FROM LCM TO SCRATCH STORAGE. +*---- + DO 40 ISO=1,NBISO + IRS=ISONR(ISO) + IF(IRS.GT.0) THEN + KPLIB=IPISO(ISO) ! set ISO-th isotope + CALL LCMGET(KPLIB,'NTOT0',TOTAL(1,IRS)) + ENDIF + 40 CONTINUE +* + VST(:NBNRS)=0.0 + DO 60 I=1,NREG + IF(MAT(I).EQ.0) GO TO 60 + IND=IRES(MAT(I)) + IF(IND.GT.0) VST(IND)=VST(IND)+VOL(I) + 60 CONTINUE +* + NPSYS(:NGRO)=0 + DO 110 LLL=1,NGRO + LOGDO=.FALSE. + DO 70 IBM=1,NBM + IRS=IRES(IBM) + IF(IRS.GT.0) LOGDO=LOGDO.OR.NOCONV(IBM,LLL) + 70 CONTINUE + IF(LOGDO) THEN + NPSYS(LLL)=LLL +* +* COMPUTE THE LIGHT AND RESONANT COMPONENTS OF THE MACROSCOPIC +* CROSS SECTIONS IN EACH RESONANT MIXTURE. + DENM(0:NBM)=0.0 + SIGT0(0:NBM,LLL)=0.0 + DO 90 ISO=1,NBISO + IRS=ISONR(ISO) + IF(IRS.GT.0) THEN + IBM=MIX(ISO) + DENM(IBM)=DEN(ISO) + SIGT2(IBM,LLL)=SIGT2(IBM,LLL)-TOTAL(LLL,IRS)*DEN(ISO) + SIGT0(IBM,LLL)=TOTAL(LLL,IRS)*DEN(ISO) + ENDIF + 90 CONTINUE + IF(IMPX.GE.10) THEN + WRITE (6,400) LLL,(SIGT0(I,LLL),I=1,NBM) + WRITE (6,410) LLL,(SIGT2(I,LLL),I=1,NBM) + ENDIF + ENDIF + 110 CONTINUE +*---- +* SET UP VECTOR SIGE. +*---- + CALL LCMSIX(IPLIB,'SHIBA',1) +* + SIGE(:NBNRS,:NGRO)=0.0 + CALL LCMSIX(IPLIB,'--AVERAGE--',1) + CALL TONDST(IPLIB,NPSYS,IPTRK,IFTRAK,CDOOR,IMPX,NBM,NBNRS,NREG, + 1 NUN,NGRO,IPHASE,MAT,VOL,KEYFLX,LEAKSW,IRES,DENM,SIGT0,SIGT2, + 2 SIGT3,TITR,SIGE,TK3,TK4) + CALL LCMSIX(IPLIB,' ',2) + DO 130 LLL=1,NGRO + IF(NPSYS(LLL).NE.0) THEN + ICPIJ=ICPIJ+2 + DO 120 ISO=1,NBISO + IRS=ISONR(ISO) + IF((LSHI(ISO).EQ.INRS).AND.(IRS.GT.0).AND. + 1 (DEN(ISO).NE.0.0)) THEN + SN(LLL,ISO)=MAX(1.0,SIGE(IRS,LLL)) + ELSE IF((LSHI(ISO).EQ.INRS).AND.(IRS.GT.0)) THEN + SN(LLL,ISO)=1.0E10 + ENDIF + 120 CONTINUE + ENDIF + 130 CONTINUE + CALL LCMSIX(IPLIB,' ',2) +* + DO 320 LLL=1,NGRO + LOGDO=.FALSE. + DO 300 IBM=1,NBM + IRS=IRES(IBM) + IF(IRS.GT.0) LOGDO=LOGDO.OR.NOCONV(IBM,LLL) + 300 CONTINUE + IF(LOGDO) THEN + DO 310 ISO=1,NBISO + IRS=ISONR(ISO) + IF(IRS.GT.0) THEN + IBM=MIX(ISO) + SIGT2(IBM,LLL)=SIGT2(IBM,LLL)+TOTAL(LLL,IRS)*DEN(ISO) + ENDIF + 310 CONTINUE + ENDIF + 320 CONTINUE +*---- +* SAVE THE GROUP- AND ISOTOPE-DEPENDENT DILUTIONS +*---- + CALL LCMPUT(IPLIB,'ISOTOPESDSB',NBISO*NGRO,2,SN) + CALL LCMPUT(IPLIB,'ISOTOPESDSN',NBISO*NGRO,2,SN) +*---- +* COMPUTE THE SELF-SHIELDED MICROSCOPIC CROSS SECTIONS AND UPDATE +* VECTOR SIGT2 +*---- + IMPX2=MAX(0,IMPX-1) + CALL LIBLIB (IPLIB,NBISO,MASKI,IMPX2) + DO 350 ISO=1,NBISO + IRS=ISONR(ISO) + IF(IRS.GT.0) THEN + IBM=MIX(ISO) + KPLIB=IPISO(ISO) ! set ISO-th isotope + CALL LCMGET(KPLIB,'NTOT0',GAR) + DO 340 LLL=1,NGRO + TOTAL(LLL,IRS)=TOTAL(LLL,IRS)-GAR(LLL) + SIGT2(IBM,LLL)=SIGT2(IBM,LLL)-DEN(ISO)*TOTAL(LLL,IRS) + 340 CONTINUE + ENDIF + 350 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IPISO) + DEALLOCATE(MASKI) + DEALLOCATE(VST,SIGE,GAS,GAR,DENM,TOTAL,SIGT0) + DEALLOCATE(NPSYS,ISONR,IRES) + RETURN +* + 400 FORMAT(//51H TOTAL MACROSCOPIC CROSS SECTIONS OF THE RESONANT M, + 1 31HATERIALS IN EACH MIXTURE (GROUP,I5,2H):/(1X,1P,11E11.3)) + 410 FORMAT(//51H TOTAL MACROSCOPIC CROSS SECTIONS OF THE OTHER MATE, + 1 28HRIALS IN EACH MIXTURE (GROUP,I5,2H):/(1X,1P,11E11.3)) + END diff --git a/Dragon/src/TONSPH.f b/Dragon/src/TONSPH.f new file mode 100644 index 0000000..812ac62 --- /dev/null +++ b/Dragon/src/TONSPH.f @@ -0,0 +1,351 @@ +*DECK TONSPH + SUBROUTINE TONSPH(IPLIB,IPTRK,IFTRAK,NREG,NUN,NBM,NBISO,ISONAM, + 1 MAT,VOL,KEYFLX,CDOOR,INRS,LEAKSW,IMPX,DEN,MIX,LSHI,ITRANC, + 2 IPHASE,NGRO,IGRMIN,IGRMAX,NBNRS,TITR,SIGT2,SIGT3,SN,SPH,ICPIJ, + 3 TK3,TK4) +* +*----------------------------------------------------------------------- +* +*Purpose: +* SPH equivalence procedure over the self-shielded cross sections. Use +* all the standard solution doors of Dragon. +* +*Copyright: +* Copyright (C) 2017 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIB pointer to the internal microscopic cross section library +* (L_LIBRARY signature). +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK file unit number used to store the tracks. +* NREG number of regions. +* NUN number of unknowns per energy group. +* NBM number of mixtures in the internal library. +* NBISO number of isotopes. +* ISONAM alias name of isotopes in IPLIB. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX pointers of fluxes in unknown vector. +* CDOOR name of the geometry/solution operator. +* INRS index of the resonant isotope under consideration. +* LEAKSW leakage flag (LEAKSW=.TRUE. if neutron leakage through +* external boundary is present). +* IMPX print flag (equal to zero for no print). +* DEN density of each isotope. +* MIX mix number of each isotope (can be zero). +* LSHI resonant region number associated with each isotope. +* Infinite dilution will be assumed if LSHI(i)=0. +* ITRANC type of transport correction. +* IPHASE type of flux solution (=1 use a native flux solution door; +* =2 use collision probabilities). +* NGRO number of energy groups. +* IGRMIN first group where the self-shielding is applied. +* IGRMAX most thermal group where the self-shielding is applied. +* NBNRS number of totally correlated fuel regions. NBNRS=max(IRES). +* TITR title. +* SIGT2 total macroscopic cross sections. +* SIGT3 transport correction. +* SN computed dilution cross section in each energy group of +* each isotope. +* +*Parameters: output +* SPH SPH factors. +* ICPIJ number of flux solution door calls. +* +*Parameters: input/output +* TK3 cpu time to compute system matrices. +* TK4 cpu time to compute fluxes. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE DOORS_MOD +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB,IPTRK + INTEGER IFTRAK,NREG,NUN,NBM,NBISO,ISONAM(3,NBISO),MAT(NREG), + 1 KEYFLX(NREG),INRS,IMPX,MIX(NBISO),LSHI(NBISO),ITRANC,IPHASE, + 2 NGRO,IGRMIN,IGRMAX,NBNRS,ICPIJ + REAL VOL(NREG),DEN(NBISO),SIGT2(0:NBM,NGRO),SIGT3(0:NBM,NGRO), + 1 SN(NGRO,NBISO),SPH(NBM,NGRO),TK3,TK4 + LOGICAL LEAKSW + CHARACTER CDOOR*12,TITR*72,HNAMIS*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + TYPE(C_PTR) JPLIB,KPLIB,IPMACR,IPSOU + LOGICAL LHOMOG,LPROB,LEXAC,LOGDO,REBFLG + CHARACTER TEXT12*12 + INTEGER NALBP,ISTATE(NSTATE) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IRES,ISONR,NPSYS + REAL, ALLOCATABLE, DIMENSION(:) :: VST,SIGTXS,SIGS0X,SIGG,FLNEW + REAL, ALLOCATABLE, DIMENSION(:,:) :: FLUX,SIG0,SIG1,SIG3,TOTAL, + 1 SIGS0,TRANC,PHGAR,SUNKNO,FUNKNO + LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASKI + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IRES(NBM),ISONR(NBISO),NPSYS(NGRO)) + ALLOCATE(VST(NBNRS),SIGTXS(0:NBM),SIGS0X(0:NBM),SIGG(0:NBM), + 1 FLNEW(NBNRS),SUNKNO(NUN,NGRO),FUNKNO(NUN,NGRO),FLUX(NBM,NGRO), + 2 SIG0(NBM,NGRO),SIG1(NBM,NGRO),SIG3(NBM,NGRO),TOTAL(NGRO,NBNRS), + 3 SIGS0(NGRO,NBNRS),TRANC(NGRO,NBNRS),PHGAR(NGRO,NBNRS)) + ALLOCATE(MASKI(NBISO)) + ALLOCATE(IPISO(NBISO)) +*---- +* FIND THE RESONANT MIXTURE NUMBERS AND THE CORRELATED ISOTOPES +* ASSOCIATED WITH REGION INRS +*---- + IRES(:NBM)=0 + ISONR(:NBISO)=0 + IRS=0 + TEXT12=' ' + DO 30 IBM=1,NBM + LOGDO=.FALSE. + DO 10 I=1,NREG + LOGDO=LOGDO.OR.(MAT(I).EQ.IBM) + 10 CONTINUE + IF(.NOT.LOGDO) GO TO 30 + DO 20 ISO=1,NBISO + IF((MIX(ISO).EQ.IBM).AND.(LSHI(ISO).EQ.INRS)) THEN + WRITE(HNAMIS,'(3A4)') (ISONAM(I0,ISO),I0=1,3) + IF(HNAMIS.NE.TEXT12) THEN + IRS=IRS+1 + TEXT12=HNAMIS + ENDIF + ISONR(ISO)=IRS + IRES(IBM)=IRS + ENDIF + 20 CONTINUE + 30 CONTINUE + IF(IRS.NE.NBNRS) CALL XABORT('TONSPH: INVALID VALUE OF NBNRS.') +*---- +* SET THE LCM MICROLIB ISOTOPEWISE DIRECTORIES. +*---- + CALL LIBIPS(IPLIB,NBISO,IPISO) +*---- +* UNLOAD MICROSCOPIC X-S FROM LCM TO SCRATCH STORAGE. +*---- + DO 40 ISO=1,NBISO + IRS=ISONR(ISO) + IF(IRS.GT.0) THEN + KPLIB=IPISO(ISO) ! set ISO-th isotope + CALL LCMGET(KPLIB,'NTOT0',TOTAL(1,IRS)) + CALL LCMGET(KPLIB,'SIGS00',SIGS0(1,IRS)) + DO IGRP=IGRMIN,IGRMAX +* Compute a ST flux for the homogeneous equivalent medium. + PHGAR(IGRP,IRS)=MAX(0.0,SN(IGRP,ISO)/(SN(IGRP,ISO)+ + 1 (TOTAL(IGRP,IRS)-SIGS0(IGRP,IRS)))) + ENDDO + IF(ITRANC.NE.0) CALL LCMGET(KPLIB,'TRANC',TRANC(1,IRS)) + ENDIF + 40 CONTINUE +*---- +* COMPUTE THE MERGED VOLUMES. +*---- + NALBP=0 + LHOMOG=.TRUE. + VST(:NBNRS)=0.0 + DO 50 I=1,NREG + IBM=MAT(I) + IF(IBM.EQ.0) GO TO 50 + IND=IRES(IBM) + IF(IND.EQ.0) THEN + LHOMOG=.FALSE. + ELSE + VST(IND)=VST(IND)+VOL(I) + ENDIF + 50 CONTINUE + IF(LHOMOG.AND.(NBNRS.EQ.1)) GO TO 260 + IF(IMPX.GE.3) WRITE(6,'(37H TONSPH: SPH FACTOR CALCULATION (NBNR, + 1 2HS=,I5,1H)/)') NBNRS +*---- +* SET THE MIXTURE-DEPENDENT MACROSCOPIC XS. +*---- + FUNKNO(:NUN,:NGRO)=0.0 + SUNKNO(:NUN,:NGRO)=0.0 + NPSYS(:NGRO)=0 + CALL LCMSIX(IPLIB,'SHIBA',1) + JPLIB=LCMLID(IPLIB,'GROUP',NGRO) + DO 110 IGRP=IGRMIN,IGRMAX + NPSYS(IGRP)=IGRP +* +* COMPUTE THE LIGHT AND RESONANT COMPONENTS OF THE MACROSCOPIC +* CROSS SECTIONS IN EACH RESONANT MIXTURE. + DO 70 IBM=1,NBM + SIG0(IBM,IGRP)=0.0 + SIG1(IBM,IGRP)=0.0 + SIG3(IBM,IGRP)=SIGT3(IBM,IGRP) + 70 CONTINUE + DO 80 ISO=1,NBISO + IRS=ISONR(ISO) + IF(IRS.GT.0) THEN + IBM=MIX(ISO) + FLUX(IBM,IGRP)=PHGAR(IGRP,IRS) + SIGT2(IBM,IGRP)=SIGT2(IBM,IGRP)-TOTAL(IGRP,IRS)*DEN(ISO) + SIG0(IBM,IGRP)=TOTAL(IGRP,IRS)*DEN(ISO) + SIG1(IBM,IGRP)=SIGS0(IGRP,IRS)*DEN(ISO) + IF(ITRANC.NE.0) THEN + SIG3(IBM,IGRP)=SIGT3(IBM,IGRP)-TRANC(IGRP,IRS)*DEN(ISO) + ENDIF + ENDIF + 80 CONTINUE + IF(IMPX.GE.10) THEN + WRITE (6,400) IGRP,(SIG0(I,IGRP),I=1,NBM) + WRITE (6,410) IGRP,(SIG1(I,IGRP),I=1,NBM) + WRITE (6,420) IGRP,(SIGT2(I,IGRP),I=1,NBM) + WRITE (6,430) IGRP,(FLUX(I,IGRP),I=1,NBM) + ENDIF +*---- +* COMPUTE THE SOURCES. +*---- + SIGG(0)=0.0 + DO 90 IBM=1,NBM + SIGG(IBM)=SIGT2(IBM,IGRP) + IF(IRES(IBM).GT.0) THEN + SIGG(IBM)=SIGG(IBM)+FLUX(IBM,IGRP)*(SIG1(IBM,IGRP)- + > SIG0(IBM,IGRP)) + IF(.NOT.LHOMOG) SIGG(IBM)=SIGG(IBM)-FLUX(IBM,IGRP)* + > SIGT2(IBM,IGRP) + ENDIF + 90 CONTINUE + SUNKNO(:NUN,IGRP)=0.0 + CALL DOORS(CDOOR,IPTRK,NBM,0,NUN,SIGG,SUNKNO(1,IGRP)) +* + IF(NPSYS(IGRP).NE.0) THEN + ICPIJ=ICPIJ+1 + SIGTXS(0)=0.0 + SIGS0X(0)=0.0 + DO 100 IBM=1,NBM + IND=IRES(IBM) + IF((ITRANC.NE.0).AND.(IND.EQ.0)) THEN + SIGTXS(IBM)=SIGT2(IBM,IGRP)-SIG3(IBM,IGRP) + ELSE + SIGTXS(IBM)=SIGT2(IBM,IGRP) + ENDIF + IF(IND.EQ.0) THEN +* REMOVE TRANSPORT CORRECTION. + IF(ITRANC.NE.0) THEN + SIGS0X(IBM)=-SIG3(IBM,IGRP) + ELSE + SIGS0X(IBM)=0.0 + ENDIF + ELSE +* BELL ACCELERATION. + SIGTXS(IBM)=SIGTXS(IBM)+SIG0(IBM,IGRP) + SIGS0X(IBM)=SIGTXS(IBM) + IF(LHOMOG) SIGS0X(IBM)=SIGS0X(IBM)-SIGT2(IBM,IGRP) + ENDIF + 100 CONTINUE + KPLIB=LCMDIL(JPLIB,IGRP) + CALL LCMPUT(KPLIB,'DRAGON-TXSC',NBM+1,2,SIGTXS) + CALL LCMPUT(KPLIB,'DRAGON-S0XSC',NBM+1,2,SIGS0X) + ENDIF + 110 CONTINUE +*---- +* SOLVE FOR THE FLUX USING DIRECT SELF-SHIELDED CROSS SECTIONS +*---- + CALL KDRCPU(TKA) + ISTRM=1 + NANI=1 + NW=0 + KNORM=1 + IMPY=MAX(0,IMPX-3) + IF(IPHASE.EQ.1) THEN +* USE A NATIVE DOOR. + CALL DOORAV(CDOOR,JPLIB,NPSYS,IPTRK,IFTRAK,IMPY,NGRO,NREG, + 1 NBM,NANI,NW,MAT,VOL,KNORM,LEAKSW,TITR,NALBP,ISTRM) + ELSE IF(IPHASE.EQ.2) THEN +* USE A COLLISION PROBABILITY DOOR. + IPIJK=1 + ITPIJ=1 + CALL DOORPV(CDOOR,JPLIB,NPSYS,IPTRK,IFTRAK,IMPY,NGRO,NREG, + 1 NBM,NANI,MAT,VOL,KNORM,IPIJK,LEAKSW,ITPIJ,.FALSE.,TITR,NALBP) + ENDIF + CALL KDRCPU(TKB) + TK3=TK3+(TKB-TKA) + CALL KDRCPU(TKA) + IDIR=0 + LEXAC=.FALSE. + IPMACR=C_NULL_PTR + IPSOU=C_NULL_PTR + REBFLG=.FALSE. + CALL DOORFV(CDOOR,JPLIB,NPSYS,IPTRK,IFTRAK,IMPX,NGRO,NBM,IDIR, + 1 NREG,NUN,IPHASE,LEXAC,MAT,VOL,KEYFLX,TITR,SUNKNO,FUNKNO,IPMACR, + 2 IPSOU,REBFLG) + CALL LCMSIX(IPLIB,' ',2) + TK4=TK4+(TKB-TKA) +*---- +* HOMOGENIZE THE FLUX +*---- + DO 150 IGRP=IGRMIN,IGRMAX + IF(NPSYS(IGRP).NE.0) THEN + FLNEW(:NBNRS)=0.0 + DO 120 I=1,NREG + IF(MAT(I).EQ.0) GO TO 120 + IND=IRES(MAT(I)) + IF(IND.GT.0) FLNEW(IND)=FLNEW(IND)+FUNKNO(KEYFLX(I),IGRP)*VOL(I) + 120 CONTINUE + DO 130 IND=1,NBNRS + FLNEW(IND)=FLNEW(IND)/VST(IND) + 130 CONTINUE +*---- +* SPH FACTOR CONTROL +*---- + DO 140 IBM=1,NBM + IND=IRES(IBM) + IF(IND.GT.0) THEN + SPHNEW=PHGAR(IGRP,IND)/FLNEW(IND) + LPROB=(SPHNEW.LE.0.).OR.(SPHNEW.GT.1.).OR.(FLNEW(IND).LT.0.05) + IF(LPROB) SPHNEW=1.0 + SPH(IBM,IGRP)=SPHNEW + ENDIF + 140 CONTINUE + ENDIF + 150 CONTINUE +*---- +* SPH CORRECTION OF THE MICROLIB +*---- + CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) + NL=ISTATE(4) + NED=ISTATE(13) + NDEL=ISTATE(19) + DO 160 ISO=1,NBISO + MASKI(ISO)=(ISONR(ISO).GT.0) + 160 CONTINUE + CALL TONCMI(IPLIB,IMPX,NBM,NBISO,NGRO,NL,NED,NDEL,MASKI,SPH) + IF(IMPX.GT.3) THEN + DO 170 IGRP=IGRMIN,IGRMAX + WRITE (6,440) IGRP,(SPH(IBM,IGRP),IBM=1,NBM) + 170 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 260 DEALLOCATE(IPISO) + DEALLOCATE(MASKI) + DEALLOCATE(PHGAR,TRANC,SIGS0,TOTAL,SIG3,SIG1,SIG0,FLUX,FUNKNO, + 1 SUNKNO,FLNEW,SIGG,SIGS0X,SIGTXS,VST) + DEALLOCATE(NPSYS,ISONR,IRES) + RETURN + 400 FORMAT(/51H TOTAL MACROSCOPIC CROSS SECTIONS OF THE RESONANT M, + 1 31HATERIALS IN EACH MIXTURE (GROUP,I5,2H):/(1X,1P,11E11.3)) + 410 FORMAT(/51H SCATTERING MACROSCOPIC CROSS SECTIONS OF THE OTHER, + 1 33H MATERIALS IN EACH MIXTURE (GROUP,I5,2H):/(1X,1P,11E11.3)) + 420 FORMAT(/51H TOTAL MACROSCOPIC CROSS SECTIONS OF THE OTHER MATE, + 1 28HRIALS IN EACH MIXTURE (GROUP,I5,2H):/(1X,1P,11E11.3)) + 430 FORMAT(/19H TABSN3 FLUX (GROUP,I5,2H):/(1X,1P,11E11.3)) + 440 FORMAT(/19H SPH FACTORS (GROUP,I5,2H):/(1X,1P,11E11.3)) + END diff --git a/Dragon/src/TRA.f b/Dragon/src/TRA.f new file mode 100644 index 0000000..57cf98a --- /dev/null +++ b/Dragon/src/TRA.f @@ -0,0 +1,94 @@ +*DECK TRA + SUBROUTINE TRA(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transposition of a macrolib. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1) creation type(L_MACROLIB); +* HENTRY(2) read-only type(L_MACROLIB). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + TYPE(C_PTR) IPMAC1,IPMAC2 + CHARACTER HSIGN*12,TEXT12*12 + INTEGER ISTATE(NSTATE) +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.NE.2) CALL XABORT('T: TWO PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('T: LI' + 1 //'NKED LIST OR XSM FILE EXPECTED AT LHS.') + IF(JENTRY(1).NE.0) CALL XABORT('T: ENTRY IN CREATE OR MODE E' + 1 //'XPECTED.') + IF((JENTRY(2).NE.2).OR.((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2))) + 1 CALL XABORT('T: LINKED LIST OR XSM FILE IN READ-ONLY MODE E' + 2 //'XPECTED AT RHS.') + CALL LCMGTC(KENTRY(2),'SIGNATURE',12,HSIGN) + IPMAC1=KENTRY(1) + IF(HSIGN.EQ.'L_MACROLIB') THEN + IPMAC2=KENTRY(2) + ELSE IF(HSIGN.EQ.'L_LIBRARY') THEN + IPMAC2=LCMGID(KENTRY(2),'MACROLIB') + ELSE + TEXT12=HENTRY(2) + CALL XABORT('T: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_MACROLIB OR L_LIBRARY EXPECTED.') + ENDIF +*---- +* TRANSPOSITION +*---- + CALL LCMGET(IPMAC2,'STATE-VECTOR',ISTATE) + NG=ISTATE(1) + NMIL=ISTATE(2) + NL=ISTATE(3) + NF=ISTATE(4) + NDEL=ISTATE(7) + ISTEP=ISTATE(11) + CALL TRAXS(IPMAC1,IPMAC2,NG,NMIL,NL,NF,NDEL,ISTEP) +*---- +* SAVE THE SIGNATURE AND STATE VECTOR +*---- + HSIGN='L_MACROLIB' + CALL LCMPTC(IPMAC1,'SIGNATURE',12,HSIGN) + IF(ISTATE(13).EQ.0) THEN + ISTATE(13)=1 + ELSE IF(ISTATE(13).EQ.1) THEN + ISTATE(13)=0 + ENDIF + CALL LCMPUT(IPMAC1,'STATE-VECTOR',NSTATE,1,ISTATE) +* + RETURN + END diff --git a/Dragon/src/TRAGRO.f b/Dragon/src/TRAGRO.f new file mode 100644 index 0000000..09bda37 --- /dev/null +++ b/Dragon/src/TRAGRO.f @@ -0,0 +1,209 @@ +*DECK TRAGRO + SUBROUTINE TRAGRO(IPMAC1,IPMAC2,NG,NMIL,NL,NF,NDEL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transposition of information in GROUP list. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMAC1 pointer to the transposed macrolib. +* IPMAC2 pointer to the original macrolib. +* NG number of energy groups. +* NMIL number of homogenized mixtures. +* NL number of Legendre orders. +* NF number of fissile isotopes. +* NDEL number of precursor groups. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMAC1,IPMAC2 + INTEGER NG,NMIL,NL,NF,NDEL +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPMAC1,KPMAC1,JPMAC2,KPMAC2 + CHARACTER CM*2,NAMT1*12,NAMT2*12,TEXT12*12 + DOUBLE PRECISION SUMA,SUMB +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) :: GAR3,XIOF,VOLMER + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: GAR1A,GAR1B,GAR2 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IJJ(NMIL),NJJ(NMIL),IPOS(NMIL)) + ALLOCATE(GAR1A(NMIL,NF,NG),GAR1B(NMIL,NF,NG),GAR2(NG,NG,NMIL), + 1 GAR3(NMIL*NG)) +*---- +* PROCESS TRANSFERT SCATTERING INFORMATION +*---- + JPMAC2=LCMGID(IPMAC2,'GROUP') + JPMAC1=LCMLID(IPMAC1,'GROUP',NG) + DO IL=1,NL + WRITE(CM,'(I2.2)') IL-1 + GAR2(:NG,:NG,:NMIL)=0.0 + DO IG=1,NG + KPMAC2=LCMGIL(JPMAC2,IG) + LENGTH=1 + IF(IL.GT.1) CALL LCMLEN(KPMAC2,'SCAT'//CM,LENGTH,ITYLCM) + IF(LENGTH.GT.0) THEN + CALL LCMGET(KPMAC2,'SCAT'//CM,GAR3) + CALL LCMGET(KPMAC2,'NJJS'//CM,NJJ) + CALL LCMGET(KPMAC2,'IJJS'//CM,IJJ) + CALL LCMGET(KPMAC2,'IPOS'//CM,IPOS) + DO IMIL=1,NMIL + IPOSDE=IPOS(IMIL) + DO JG=IJJ(IMIL),IJJ(IMIL)-NJJ(IMIL)+1,-1 + GAR2(IG,JG,IMIL)=GAR3(IPOSDE) ! IG <-- JG + IPOSDE=IPOSDE+1 + ENDDO + ENDDO + ENDIF + ENDDO + DO IG=1,NG + KPMAC1=LCMDIL(JPMAC1,IG) + IPOSDE=0 + DO IMIL=1,NMIL + IPOS(IMIL)=IPOSDE+1 + IGMIN=IG + IGMAX=IG + DO JG=1,NG + IF(GAR2(NG-JG+1,NG-IG+1,IMIL).NE.0.0) THEN + IGMIN=MIN(IGMIN,JG) + IGMAX=MAX(IGMAX,JG) + ENDIF + ENDDO + IJJ(IMIL)=IGMAX + NJJ(IMIL)=IGMAX-IGMIN+1 + DO JG=IGMAX,IGMIN,-1 + IPOSDE=IPOSDE+1 + GAR3(IPOSDE)=GAR2(NG-JG+1,NG-IG+1,IMIL) + ENDDO + ENDDO + IF(IPOSDE.GT.0) THEN + CALL LCMPUT(KPMAC1,'SCAT'//CM,IPOSDE,2,GAR3) + CALL LCMPUT(KPMAC1,'NJJS'//CM,NMIL,1,NJJ) + CALL LCMPUT(KPMAC1,'IJJS'//CM,NMIL,1,IJJ) + CALL LCMPUT(KPMAC1,'IPOS'//CM,NMIL,1,IPOS) + ENDIF + ENDDO + ENDDO +*---- +* PROCESS VECTOR CROSS SECTIONS +*---- + ALLOCATE(VOLMER(NMIL)) + CALL LCMLEN(IPMAC2,'VOLUME',ILONG,ITYLCM) + IF(ILONG.EQ.NMIL) CALL LCMGET(IPMAC2,'VOLUME',VOLMER) + DO IG=1,NG + KPMAC2=LCMGIL(JPMAC2,IG) + KPMAC1=LCMDIL(JPMAC1,NG-IG+1) + NAMT2=' ' + CALL LCMNXT(KPMAC2,NAMT2) + TEXT12=NAMT2 + 10 IF(NAMT2(:4).EQ.'SCAT') GO TO 20 + IF(NAMT2(:4).EQ.'NJJS') GO TO 20 + IF(NAMT2(:4).EQ.'IJJS') GO TO 20 + IF(NAMT2(:4).EQ.'IPOS') GO TO 20 + CALL LCMLEN(KPMAC2,NAMT2,ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + ALLOCATE(XIOF(ILONG)) + CALL LCMGET(KPMAC2,NAMT2,XIOF) + NAMT1=NAMT2 + IF(NAMT2(:3).EQ.'CHI') THEN + NAMT1='NUSIGF'//NAMT2(4:) + ELSE IF(NAMT2(:6).EQ.'NUSIGF') THEN + NAMT1='CHI'//NAMT2(7:) + ELSE IF(NAMT2(:9).EQ.'FLUX-INTG') THEN + NAMT1='NWAT0' + DO IMIL=1,NMIL + XIOF(IMIL)=XIOF(IMIL)/VOLMER(IMIL) + ENDDO + ELSE IF(NAMT2.EQ.'FLUX-INTG-P1') THEN + NAMT1='NWAT1' + DO IMIL=1,NMIL + XIOF(IMIL)=XIOF(IMIL)/VOLMER(IMIL) + ENDDO + ELSE IF(NAMT2(:5).EQ.'NWAT0') THEN + NAMT1='FLUX-INTG' + DO IMIL=1,NMIL + XIOF(IMIL)=XIOF(IMIL)*VOLMER(IMIL) + ENDDO + ELSE IF(NAMT2(:5).EQ.'NWAT1') THEN + NAMT1='FLUX-INTG-P1' + DO IMIL=1,NMIL + XIOF(IMIL)=XIOF(IMIL)*VOLMER(IMIL) + ENDDO + ENDIF + CALL LCMPUT(KPMAC1,NAMT1,ILONG,2,XIOF) + DEALLOCATE(XIOF) + ENDIF + 20 CALL LCMNXT(KPMAC2,NAMT2) + IF(NAMT2.NE.TEXT12) GO TO 10 + ENDDO + DEALLOCATE(VOLMER) +*---- +* FISSION SPECTRUM NORMALIZATION +*---- + DO IDEL=0,NDEL + IF(IDEL.EQ.0) THEN + CM=' ' + ELSE + WRITE(CM,'(I2.2)') IDEL + ENDIF + GAR1A(:NMIL,:NF,:NG)=0.0 + GAR1B(:NMIL,:NF,:NG)=0.0 + DO IG=1,NG + KPMAC1=LCMGIL(JPMAC1,IG) + CALL LCMGET(KPMAC1,'CHI'//CM,GAR1A(1,1,IG)) + CALL LCMGET(KPMAC1,'NUSIGF'//CM,GAR1B(1,1,IG)) + ENDDO + DO IFIS=1,NF + DO IMIL=1,NMIL + SUMA=0.0D0 + SUMB=0.0D0 + DO IG=1,NG + SUMA=SUMA+GAR1A(IMIL,IFIS,IG) + SUMB=SUMB+GAR1B(IMIL,IFIS,IG) + ENDDO + IF(SUMA.GT.0.0) THEN + DO IG=1,NG + GAR1A(IMIL,IFIS,IG)=GAR1A(IMIL,IFIS,IG)*REAL(SUMB/SUMA) + GAR1B(IMIL,IFIS,IG)=GAR1B(IMIL,IFIS,IG)*REAL(SUMA/SUMB) + ENDDO + ELSE + DO IG=1,NG + GAR1A(IMIL,IFIS,IG)=0.0 + GAR1B(IMIL,IFIS,IG)=0.0 + ENDDO + ENDIF + ENDDO + ENDDO + DO IG=1,NG + KPMAC1=LCMGIL(JPMAC1,IG) + CALL LCMPUT(KPMAC1,'CHI'//CM,NMIL*NF,2,GAR1A(1,1,IG)) + CALL LCMPUT(KPMAC1,'NUSIGF'//CM,NMIL*NF,2,GAR1B(1,1,IG)) + ENDDO + ENDDO +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GAR3,GAR2,GAR1B,GAR1A) + DEALLOCATE(IPOS,NJJ,IJJ) + RETURN + END diff --git a/Dragon/src/TRAXS.f b/Dragon/src/TRAXS.f new file mode 100644 index 0000000..7a077ca --- /dev/null +++ b/Dragon/src/TRAXS.f @@ -0,0 +1,96 @@ +*DECK TRAXS + SUBROUTINE TRAXS(IPMAC1,IPMAC2,NG,NMIL,NL,NF,NDEL,ISTEP) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Macrolib transposition. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMAC1 pointer to the transposed macrolib (L_MACROLIB signature). +* IPMAC2 pointer to the original macrolib (L_MACROLIB signature). +* NG number of energy groups. +* NMIL number of homogenized mixtures. +* NL number of Legendre orders. +* NF number of fissile isotopes. +* NDEL number of precursor groups. +* ISTEP number of components in STEP directory. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMAC1,IPMAC2 + INTEGER NG,NMIL,NL,NF,NDEL,ISTEP +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NCOPY1=4,NCOPY2=11) + TYPE(C_PTR) JPMAC1,KPMAC1,JPMAC2,KPMAC2 + CHARACTER TEXT12*12,TCOPY1(NCOPY1)*12,TCOPY2(NCOPY2)*12 + REAL, ALLOCATABLE, DIMENSION(:) :: GAR1,XIOF + DATA TCOPY1/'ENERGY','DELTAU','FLUXDISAFACT','DIFFHET'/ + DATA TCOPY2/'ADDXSNAME-P0','FISSIONINDEX','ALBEDO','VOLUME', + 1 'LAMBDA-D','BETA-D','K-EFFECTIVE','K-INFINITY','B2 B1HOM', + 2 'B2 HETE','TIMESTAMP'/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(GAR1(NG+1)) +*---- +* COPY THE INFORMATION ON ROOT +*---- + DO ICOPY=1,NCOPY1 + TEXT12=TCOPY1(ICOPY) + CALL LCMLEN(IPMAC2,TEXT12,ILONG,ITYLCM) + print *,'TRAXS: transpose=',TEXT12,' ILONG=',ILONG + IF(ILONG.GT.0) THEN + CALL LCMGET(IPMAC2,TEXT12,GAR1) + ALLOCATE(XIOF(ILONG)) + DO I=1,ILONG + XIOF(I)=GAR1(ILONG+1-I) + ENDDO + CALL LCMPUT(IPMAC1,TEXT12,ILONG,2,XIOF) + DEALLOCATE(XIOF) + ENDIF + ENDDO + DO ICOPY=1,NCOPY2 + TEXT12=TCOPY2(ICOPY) + CALL LCMLEN(IPMAC2,TEXT12,ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + ALLOCATE(XIOF(ILONG)) + CALL LCMGET(IPMAC2,TEXT12,XIOF) + CALL LCMPUT(IPMAC1,TEXT12,ILONG,2,XIOF) + DEALLOCATE(XIOF) + ENDIF + ENDDO +*---- +* COPY THE INFORMATION ON DIRECTORY GROUP +*---- + CALL TRAGRO(IPMAC1,IPMAC2,NG,NMIL,NL,NF,NDEL) + IF(ISTEP.GT.0) THEN + JPMAC2=LCMGID(IPMAC2,'STEP') + JPMAC1=LCMLID(IPMAC1,'STEP',ISTEP) + DO IS=1,ISTEP + KPMAC2=LCMGIL(JPMAC2,IS) + KPMAC1=LCMDIL(JPMAC1,IS) + CALL TRAGRO(KPMAC1,KPMAC2,NG,NMIL,NL,NF,NDEL) + ENDDO + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GAR1) + RETURN + END diff --git a/Dragon/src/TRFICF.f b/Dragon/src/TRFICF.f new file mode 100644 index 0000000..291e471 --- /dev/null +++ b/Dragon/src/TRFICF.f @@ -0,0 +1,123 @@ +*DECK TRFICF + SUBROUTINE TRFICF(KPSYS,IFTRAK,IPRNTF,NGEFF,NGIND,IDIR,NREGIO, + > NUNKNO,MATCOD,VOLUME,KEYFLX,FUNKNO,SUNKNO, + > TITRE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solve N-group transport equation for fluxes using the scattering +* modified collision probability matrix. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* KPSYS pointer to the pij matrices (L_PIJ signature). KPSYS is +* an array of directories. +* IFTRAK not used. +* IPRNTF print selection for flux modules. +* NGEFF number of energy groups processed in parallel. +* NGIND energy group indices assign to the NGEFF set. +* IDIR directional collision probability flag: +* =0 for pij or wij; +* =k for pijk or wijk k=1,2,3. +* NREGIO number of regions considered. +* NUNKNO number of unknown in the system. +* MATCOD mixture code in region. +* VOLUME volume of region. +* KEYFLX flux elements in unknown system. +* SUNKNO source for system of unknown. +* TITRE title. +* +*Parameters: input/output +* FUNKNO unknown vector solved for. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) KPSYS(NGEFF) + CHARACTER TITRE*72 + INTEGER NGEFF,NGIND(NGEFF),IFTRAK,IPRNTF,IDIR,NREGIO,NUNKNO, + > MATCOD(NREGIO),KEYFLX(NREGIO) + REAL VOLUME(NREGIO),FUNKNO(NUNKNO,NGEFF), + > SUNKNO(NUNKNO,NGEFF) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6) + CHARACTER CNS(0:3)*1,NAMLCM*12,NAMMY*12 + INTEGER ILCMLN + LOGICAL EMPTY,LCM + SAVE CNS +*---- +* ALLOCATABLE ARRAYS +*---- + TYPE(C_PTR) CPMAT_PTR + REAL, POINTER, DIMENSION(:) :: CPMAT +*---- +* DATA STATEMENTS +*---- + DATA CNS /'-','1','2','3'/ +*---- +* RECOVER TRAFIC SPECIFIC PARAMETERS +*---- + IF(IPRNTF.GT.2) WRITE(IUNOUT,'(//9H TRFICF: ,A72)') TITRE + CALL LCMINF(KPSYS(1),NAMLCM,NAMMY,EMPTY,ILONG,LCM) + IF(IFTRAK.LT.0) CALL XABORT('TRFICF: EXPECTING IFTRAK>=0') + IF(MATCOD(1).LT.0) CALL XABORT('TRFICF: EXPECTING MATCOD(1)>=0') + IF(VOLUME(1).LT.0.0) CALL XABORT('TRFICF: EXPECTING VOLUME(1)>=0') +*---- +* MAIN LOOP OVER ENERGY GROUPS. +*---- + IF(.NOT.LCM) THEN + ALLOCATE(CPMAT(NREGIO*NREGIO),STAT=IER) + IF(IER.NE.0) CALL XABORT('TRFICF: CANNOT ALLOCATE CPMAT.') + ENDIF + DO 60 II=1,NGEFF + IF(IPRNTF.GT.2) WRITE(IUNOUT,'(/25H TRFICF: PROCESSING GROUP,I5, + 1 6H WITH ,A,1H.)') NGIND(II),'TRAFIC' +*---- +* READ SCATTERING MODIFIED COLLISION PROBABILITIES +*---- + CALL LCMLEN(KPSYS(II),'DRAGON'//CNS(IDIR)//'PCSCT',ILCMLN,ITYLCM) + IF((ILCMLN.GT.0).AND.LCM) THEN + CALL LCMGPD(KPSYS(II),'DRAGON'//CNS(IDIR)//'PCSCT',CPMAT_PTR) + CALL C_F_POINTER(CPMAT_PTR,CPMAT,(/ NREGIO*NREGIO /)) + ELSE IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPSYS(II),'DRAGON'//CNS(IDIR)//'PCSCT',CPMAT) + ELSE + CALL XABORT('TRFICF: RECORD DRAGON'//CNS(IDIR)// + > 'PCSCT ABSENT FROM LCM') + ENDIF +*---- +* SOLVE TRANSPORT EQUATION +*---- + JCPMAT=0 + DO 30 I=1,NREGIO + FUNKNO(KEYFLX(I),II)=0.0 + 30 CONTINUE + DO 50 I=1,NREGIO + IPOS=KEYFLX(I) + DO 40 J=1,NREGIO + JPOS=KEYFLX(J) + JCPMAT=JCPMAT+1 + FUNKNO(JPOS,II)=FUNKNO(JPOS,II)+SUNKNO(IPOS,II)*CPMAT(JCPMAT) + 40 CONTINUE + 50 CONTINUE +*---- +* END OF LOOP OVER ENERGY GROUPS +*---- + 60 CONTINUE + IF(.NOT.LCM) DEALLOCATE(CPMAT) + RETURN + END diff --git a/Dragon/src/TRIFIS.f b/Dragon/src/TRIFIS.f new file mode 100644 index 0000000..c61d306 --- /dev/null +++ b/Dragon/src/TRIFIS.f @@ -0,0 +1,178 @@ +*DECK TRIFIS + SUBROUTINE TRIFIS(IPTRK,NREG,NMAT,NIFIS,NUNKNO,NGRP,MATCOD,VOL, + > XSCHI,XSNUF,FUNKNO,SUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the fission source for a TRIVAC tracking. +* +*Copyright: +* Copyright (C) 2025 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK pointer to the tracking LCM object. +* NANIS maximum cross section Legendre order. +* NREG number of regions. +* NMAT number of mixtures. +* NIFIS number of fissile isotopes. +* NUNKNO number of unknowns per energy group. +* NGRP number of energy groups. +* MATCOD mixture indices. +* VOL volumes. +* XSCHI fission spectra. +* XSNUP nu times the fission cross sections. +* FUNKNO fluxes. +* +*Parameters: output +* SUNKNO sources. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE DOORS_MOD +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER NREG,NMAT,NIFIS,NUNKNO,NGRP,MATCOD(NREG) + REAL VOL(NREG),XSCHI(0:NMAT,NIFIS,NGRP),XSNUF(0:NMAT,NIFIS,NGRP), + 1 FUNKNO(NUNKNO,NGRP),SUNKNO(NUNKNO,NGRP) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + INTEGER JPAR(NSTATE),IJ1(125),IJ2(125),IJ3(125) + CHARACTER*12 CXDOOR +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KN,IDL + REAL, ALLOCATABLE, DIMENSION(:) :: FXSOR + REAL, ALLOCATABLE, DIMENSION(:,:) :: RR,RS +*---- +* RECOVER TRIVAC SPECIFIC PARAMETERS. +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',JPAR) + IF(JPAR(1).NE.NREG) CALL XABORT('TRIFIS: INCONSISTENT NREG.') + IF(JPAR(2).NE.NUNKNO) CALL XABORT('TRIFIS: INCONSISTENT NUNKNO.') + ITYPE=JPAR(6) + IELEM=JPAR(9) + ICOL=JPAR(10) + ISCAT=JPAR(32) + IF(ICOL.EQ.4) THEN + CALL XABORT('TRIFIS: COLLOCATION NODAL NOT IMPLEMENTED.') + ELSE IF((ITYPE.NE.2).AND.(ITYPE.NE.5).AND.(ITYPE.NE.7)) THEN + CALL XABORT('TRIFIS: CARTESIAN 1D, 2D OR 3D GEOMETRY EXPECTED.') + ENDIF + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + ALLOCATE(KN(MAXKN),IDL(NREG)) + CALL LCMGET(IPTRK,'KN',KN) + CALL LCMGET(IPTRK,'KEYFLX',IDL) + IF(IELEM.LT.0) THEN + ! Lagrangian finite element method +*---- +* RECOVER THE FINITE ELEMENT UNIT STIFFNESS MATRIX. +*---- + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMLEN(IPTRK,'T',LC,ITYLCM) + ALLOCATE(RR(LC,LC),RS(LC,LC)) + CALL LCMGET(IPTRK,'R',RR) + CALL LCMGET(IPTRK,'RS',RS) + CALL LCMSIX(IPTRK,' ',2) +*---- +* COMPUTE VECTORS IJ1 AND IJ2 +*---- + LL=LC*LC*LC + DO L=1,LL + L1=1+MOD(L-1,LC) + L2=1+(L-L1)/LC + L3=1+MOD(L2-1,LC) + IJ1(L)=L1 + IJ2(L)=L3 + IJ3(L)=1+(L2-L3)/LC + ENDDO +*---- +* COMPUTE THE SOURCE +*---- + NUM1=0 + DO IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) CYCLE + IF(VOL(IR).EQ.0.0) GO TO 10 + DO I=1,LL + IND1=KN(NUM1+I) + IF(IND1.EQ.0) CYCLE + I1=IJ1(I) + I2=IJ2(I) + I3=IJ3(I) + DO J=1,LL + IND2=KN(NUM1+J) + IF(IND2.EQ.0) CYCLE + AUXX=RR(I1,IJ1(J))*RR(I2,IJ2(J))*RR(I3,IJ3(J))*VOL(IR) + DO IG=1,NGRP + DO JG=1,NGRP + DO IS=1,NIFIS + SIGG=XSCHI(IBM,IS,IG)*XSNUF(IBM,IS,JG) + SUNKNO(IND1,IG)=SUNKNO(IND1,IG)+AUXX*SIGG* + > FUNKNO(IND2,JG) + ENDDO ! IS + ENDDO ! JG + ENDDO ! IG + ENDDO ! J + ENDDO ! I + 10 NUM1=NUM1+LL + ENDDO ! IR + DEALLOCATE(RS,RR) + ! append the integrated volumic sources + ALLOCATE(FXSOR(NUNKNO)) + DO IS=1,NIFIS + FXSOR(:NUNKNO)=0.0 + DO IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) CYCLE + DO IG=1,NGRP + FXSOR(IDL(IR))=FXSOR(IDL(IR))+VOL(IR)*XSNUF(IBM,IS,IG)* + > FUNKNO(IDL(IR),IG) + ENDDO ! IG + DO IG=1,NGRP + SUNKNO(IDL(IR),IG)=SUNKNO(IDL(IR),IG)+XSCHI(IBM,IS,IG)* + > FXSOR(IDL(IR)) + ENDDO ! IG + ENDDO ! IR + ENDDO ! IS + DEALLOCATE(FXSOR) + ELSE + ! Raviart-Thomas finite element method + CXDOOR='TRIVAC' + ALLOCATE(FXSOR(NUNKNO)) + DO IS=1,NIFIS + FXSOR(:NUNKNO)=0.0 + DO IG=1,NGRP + CALL DOORS(CXDOOR,IPTRK,NMAT,0,NUNKNO,XSNUF(0,IS,IG), + > FXSOR,FUNKNO(1,IG)) + ENDDO + DO IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.EQ.0) CYCLE + DO IE=1,IELEM**3 + IND=IDL(IR)+IE-1 + IF(IND.EQ.0) CYCLE + DO IG=1,NGRP + SUNKNO(IND,IG)=SUNKNO(IND,IG)+XSCHI(IBM,IS,IG)* + > FXSOR(IND) + ENDDO + ENDDO + ENDDO + ENDDO ! IS + DEALLOCATE(FXSOR) + ENDIF + DEALLOCATE(IDL,KN) + RETURN + END diff --git a/Dragon/src/TRIFLV.f b/Dragon/src/TRIFLV.f new file mode 100644 index 0000000..8148377 --- /dev/null +++ b/Dragon/src/TRIFLV.f @@ -0,0 +1,158 @@ +*DECK TRIFLV + SUBROUTINE TRIFLV(KPSYS,INCONV,NGIND,IPTRK,IMPX,MAXIT,NGEFF,NREG, + 1 NUN,KEYFLX,FUNKNO,SUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solve N-group transport equation for fluxes using the diffusion +* approximation or simplified PN method in TRIVAC. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* KPSYS pointer to the assembly matrices. KPSYS is an array of +* directories. +* INCONV energy group convergence flag (set to .FALSE. if converged). +* NGIND energy group indices assign to the NGEFF set. +* IPTRK pointer to the tracking (L_TRACK signature). +* IMPX print flag (equal to zero for no print). +* NGEFF number of energy groups processed in parallel. +* NREG total number of regions for which specific values of the +* neutron flux and reactions rates are required. +* NUN total number of unknowns in vectors SUNKNO and FUNKNO. +* KEYFLX position of averaged flux elements in FUNKNO vector. +* SUNKNO input source vector. +* +*Parameters: input/output +* FUNKNO unknown vector. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) KPSYS(NGEFF),IPTRK + INTEGER MAXIT,NGEFF,NGIND(NGEFF),IMPX,NREG,NUN,KEYFLX(NREG) + LOGICAL INCONV(NGEFF) + REAL FUNKNO(NUN,NGEFF),SUNKNO(NUN,NGEFF) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6,NSTATE=40,EPSINR=1.0E-5,ICL1=3,ICL2=3) + DOUBLE PRECISION F1,F2,R1,R2,DMU + INTEGER IPAR(NSTATE) + CHARACTER NAMP*12 +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: GAR,OLD1,OLD2 +*---- +* RECOVER TRIVAC SPECIFIC PARAMETERS. +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',IPAR) + ITY=2 + IELEM=ABS(IPAR(9)) + LL4=IPAR(11) + ISPLH=IPAR(13) + LX=IPAR(14) + LZ=IPAR(16) + NLF=IPAR(30) + IF(IPAR(12).EQ.2) ITY=3 + IF((NLF.GT.0).AND.(ITY.GE.3)) ITY=10+ITY + IF((ITY.EQ.11).OR.(ITY.EQ.13)) LL4=LL4*NLF/2 + NADI=IPAR(33) +*---- +* MAIN LOOP OVER ENERGY GROUPS. +*---- + ALLOCATE(GAR(NUN),OLD1(NUN),OLD2(NUN)) + GAR(:NUN)=0.0 + OLD1(:NUN)=0.0 + OLD2(:NUN)=0.0 + DO 130 II=1,NGEFF + IF(.NOT.INCONV(II)) GO TO 130 + IF(IMPX.GT.1) WRITE(IUNOUT,'(/25H TRIFLV: PROCESSING GROUP,I5, + 1 6H WITH ,A,1H.)') NGIND(II),'TRIVAC' +*---- +* SOLVE FOR THE FLUXES. USE EQUATION (C.24) IN IGE-281. +*---- + NAMP='A001001' + OLD2(:NUN)=0.0 + TEST=0.0 + ITER=0 + 20 ITER=ITER+1 + IF(ITER.GT.MAXIT) THEN + WRITE(IUNOUT,'(46H TRIFLV: MAXIMUM NUMBER OF ONE-SPEED ITERATION, + 1 9H REACHED.)') + GO TO 130 + ENDIF + DO 30 I=1,NUN + OLD1(I)=OLD2(I) + OLD2(I)=FUNKNO(I,II) + 30 CONTINUE + CALL MTLDLM(NAMP,IPTRK,KPSYS(II),LL4,ITY,FUNKNO(1,II),GAR) + DO 40 I=1,NUN + GAR(I)=SUNKNO(I,II)-GAR(I) + 40 CONTINUE + CALL FLDADI(NAMP,IPTRK,KPSYS(II),LL4,ITY,GAR,NADI) + DO 50 I=1,NUN + FUNKNO(I,II)=FUNKNO(I,II)+GAR(I) + 50 CONTINUE +*---- +* VARIATIONAL ACCELERATION. +*---- + DMU=1.0D0 + IF(MOD(ITER-1,ICL1+ICL2).GE.ICL1) THEN + F1=0.0D0 + F2=0.0D0 + DO 80 I=1,NUN + R1=OLD2(I)-OLD1(I) + R2=FUNKNO(I,II)-OLD2(I) + F1=F1+R1*(R2-R1) + F2=F2+(R2-R1)*(R2-R1) + 80 CONTINUE + DMU=-F1/F2 + IF(DMU.GT.0.0) THEN + DO 90 I=1,NUN + FUNKNO(I,II)=OLD2(I)+REAL(DMU)*(FUNKNO(I,II)-OLD2(I)) + OLD2(I)=OLD1(I)+REAL(DMU)*(OLD2(I)-OLD1(I)) + 90 CONTINUE + ENDIF + ENDIF +*---- +* CALCULATE ERROR AND TEST FOR CONVERGENCE. +*---- + AAA=0.0 + BBB=0.0 + DO 100 I=1,NREG + IF(KEYFLX(I).EQ.0) GO TO 100 + AAA=MAX(AAA,ABS(FUNKNO(KEYFLX(I),II)-OLD2(KEYFLX(I)))) + BBB=MAX(BBB,ABS(FUNKNO(KEYFLX(I),II))) + 100 CONTINUE + IF(IMPX.GT.2) WRITE(IUNOUT,300) ITER,AAA,BBB,DMU + IF(AAA.LE.EPSINR*BBB) GO TO 130 + IF(ITER.EQ.1) TEST=AAA + IF((ITER.GE.10).AND.(AAA.GT.TEST)) THEN + WRITE(IUNOUT,'(43H TRIFLV: UNABLE TO CONVERGE ONE-SPEED ITERA, + 1 6HTIONS.)') + GO TO 130 + ENDIF + GO TO 20 +*---- +* END OF LOOP OVER ENERGY GROUPS +*---- + 130 CONTINUE + DEALLOCATE(OLD2,OLD1,GAR) + RETURN +* + 300 FORMAT(28H TRIFLV: ONE-SPEED ITERATION,I3,8H ERROR=,1P,E11.4, + 1 5H OVER,E11.4,22H ACCELERATION FACTOR=,0P,F7.3) + END diff --git a/Dragon/src/TRIVA.f b/Dragon/src/TRIVA.f new file mode 100644 index 0000000..97031b5 --- /dev/null +++ b/Dragon/src/TRIVA.f @@ -0,0 +1,156 @@ +*DECK TRIVA + SUBROUTINE TRIVA(IPSYS,IPTRK,IMPX,NREG,NBMIX,NANI,NW,MAT,VOL, + 1 SIGT0,SIGW0,DIFF) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of one-speed finite-difference or finite-element matrices +* for a discretization of the 3D diffusion or SPN equation. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPSYS pointer to the system matrices. +* IPTRK pointer to the tracking (L_TRACK signature). +* IMPX print flag (equal to zero for no print). +* NREG total number of merged regions for which specific values +* of the neutron flux and reactions rates are required. +* NBMIX number of mixtures. +* NANI number of Legendre orders for the scattering cross sections. +* NW type of weighting for P1 cross section info (=0 P0 ; =1 P1). +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* SIGT0 P0 and P1 total macroscopic cross sections ordered by mixture. +* SIGW0 within-group scattering macroscopic cross section ordered +* by mixture. +* DIFF diffusion coefficients ordered by mixture. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSYS,IPTRK + INTEGER IMPX,NREG,NBMIX,NANI,NW,MAT(NREG) + REAL VOL(NREG),SIGT0(0:NBMIX,NW+1),SIGW0(0:NBMIX,NANI), + 1 DIFF(0:NBMIX) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + INTEGER ISTATE(NSTATE),IGB(8) + LOGICAL LBIHET + CHARACTER NAMP*12,TEXT10*10 + REAL, ALLOCATABLE, DIMENSION(:) :: GAMMA + REAL, ALLOCATABLE, DIMENSION(:,:) :: SGD,SGDI + PARAMETER(TEXT10='A001001') +*---- +* RECOVER TRIVAC SPECIFIC TRACKING INFORMATION +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + LBIHET=ISTATE(40).NE.0 + IF(LBIHET) THEN + CALL LCMSIX(IPTRK,'BIHET',1) + CALL LCMGET(IPTRK,'PARAM',IGB) + IF(NREG.NE.IGB(3)) CALL XABORT('TRIVA: INVALID VALUE OF NREG(' + 1 //'1).') + CALL LCMSIX(IPTRK,' ',2) + ELSE + IF(NREG.NE.ISTATE(1)) CALL XABORT('TRIVA: INVALID VALUE OF NR' + 1 //'EG(2).') + ENDIF + ICHX=ISTATE(12) + NLF=ISTATE(30) + ISCAT=ABS(ISTATE(32)) +*---- +* RECOVER PHYSICAL ALBEDO FUNCTIONS. +*---- + CALL LCMLEN(IPSYS,'ALBEDO-FU',NALBP,ITYLCM) + IF(NALBP.GT.0) THEN + ALLOCATE(GAMMA(NALBP)) + CALL LCMGET(IPSYS,'ALBEDO-FU',GAMMA) + ENDIF +*---- +* COMPUTE THE WITHIN-GROUP SYSTEM MATRICES (LEAKAGE AND REMOVAL). +* ASSEMBLY OF THE ADI SPLITTED SYSTEM MATRICES +*---- + IF(NLF.EQ.0) THEN +*---- +* ++++ DIFFUSION THEORY ++++ +*---- + IF(NANI.GT.1) THEN + CALL XABORT('TRIVA: SPN MACRO-CALCULATION EXPECTED(1).') + ENDIF + ALLOCATE(SGD(NBMIX,4)) + DO 10 IBM=1,NBMIX + SGD(IBM,1)=DIFF(IBM) + SGD(IBM,2)=DIFF(IBM) + SGD(IBM,3)=DIFF(IBM) + SGD(IBM,4)=SIGT0(IBM,1)-SIGW0(IBM,1) + 10 CONTINUE +*---- +* ASSEMBLY OF A SINGLE-GROUP SYSTEM MATRIX WITH LEAKAGE AND REMOVAL +* CROSS SECTIONS. +*---- + CALL TRIASM(TEXT10,IPTRK,IPSYS,IMPX,NBMIX,NREG,NALBP,0,MAT, + 1 VOL,GAMMA,SGD,SGD) + DEALLOCATE(SGD) + ELSE +*---- +* ++++ PN OR SPN THEORY ++++ +*---- + IF(NLF.LT.2) THEN + CALL XABORT('TRIVA: PN OR SPN KEYWORD EXPECTED.') + ELSE IF(ICHX.NE.2) THEN + CALL XABORT('TRIVA: DISCRETIZATION NOT AVAILABLE.') + ENDIF + NAN=MIN(ISCAT,NANI)+1 + ALLOCATE(SGD(NBMIX,NAN),SGDI(NBMIX,NAN)) + DO 30 IL=0,NAN-1 + DO 20 IBM=1,NBMIX + IF(IL.LE.NW) THEN + GARS=SIGT0(IBM,IL+1) + ELSE IF((NW.GE.1).AND.(MOD(IL,2).EQ.1)) THEN + GARS=SIGT0(IBM,2) + ELSE + GARS=SIGT0(IBM,1) + ENDIF + IF(IL.LE.NAN-2) GARS=GARS-SIGW0(IBM,IL+1) + SGD(IBM,IL+1)=GARS + IF(GARS.NE.0.0) THEN + SGDI(IBM,IL+1)=1.0/GARS + ELSE + SGDI(IBM,IL+1)=1.0E10 + ENDIF + 20 CONTINUE + WRITE(NAMP,'(4HSCAR,I2.2,6H001001)') IL + CALL LCMPUT(IPSYS,NAMP,NBMIX,2,SGD(1,IL+1)) + WRITE(NAMP,'(4HSCAI,I2.2,6H001001)') IL + CALL LCMPUT(IPSYS,NAMP,NBMIX,2,SGDI(1,IL+1)) + 30 CONTINUE + ISTATE(:NSTATE)=0 + ISTATE(7)=NBMIX + ISTATE(8)=NAN + CALL LCMPUT(IPSYS,'STATE-VECTOR',NSTATE,1,ISTATE) +*---- +* ASSEMBLY OF A SINGLE-GROUP SYSTEM MATRIX WITH LEAKAGE AND REMOVAL +* CROSS SECTIONS FOR THE SIMPLIFIED PN METHOD. +*---- + CALL TRIASN(TEXT10,IPTRK,IPSYS,IMPX,NBMIX,NREG,NAN,NALBP,0, + 1 MAT,VOL,GAMMA,SGD,SGDI) + DEALLOCATE(SGDI,SGD) + ENDIF + IF(NALBP.GT.0) DEALLOCATE(GAMMA) + IF(IMPX.GT.2) CALL LCMLIB(IPSYS) + IF(IMPX.GT.10) CALL LCMVAL(IPSYS,' ') + RETURN + END diff --git a/Dragon/src/TRIVSO.f b/Dragon/src/TRIVSO.f new file mode 100644 index 0000000..b4da369 --- /dev/null +++ b/Dragon/src/TRIVSO.f @@ -0,0 +1,248 @@ +*DECK TRIVSO + SUBROUTINE TRIVSO(MAX1,IG,IPTRK,KPMACR,NANIS,NREG,NMAT,NUNKNO, + > NGRP,MATCOD,VOL,FUNKNO,SUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the source for the solution of diffusion or PN equations. +* TRIVAC-specific version. +* +*Copyright: +* Copyright (C) 2004 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAX1 first dimension of FUNKNO and SUNKNO arrays. +* IG secondary group. +* IPTRK pointer to the tracking LCM object. +* KPMACR pointer to the secondary-group related macrolib information. +* NANIS maximum cross section Legendre order. +* NREG number of regions. +* NMAT number of mixtures. +* NUNKNO number of unknowns per energy group including spherical +* harmonic terms, interface currents and fundamental +* currents. +* NGRP number of energy groups. +* MATCOD mixture indices. +* VOL volumes. +* FUNKNO fluxes. +* +*Parameters: output +* SUNKNO sources. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,KPMACR + INTEGER MAX1,IG,NANIS,NREG,NMAT,NUNKNO,NGRP,MATCOD(NREG) + REAL VOL(NREG),FUNKNO(MAX1,NGRP),SUNKNO(MAX1,NGRP) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + INTEGER JPAR(NSTATE) + CHARACTER CAN(0:9)*2 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS,KN + REAL, ALLOCATABLE, DIMENSION(:) :: XSCAT + REAL, ALLOCATABLE, DIMENSION(:,:) :: RR +*---- +* DATA STATEMENTS +*---- + DATA CAN /'00','01','02','03','04','05','06','07','08','09'/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IJJ(0:NMAT),NJJ(0:NMAT),IPOS(0:NMAT)) + ALLOCATE(XSCAT(0:NMAT*NGRP)) +*---- +* RECOVER TRIVAC SPECIFIC PARAMETERS. +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',JPAR) + IF(JPAR(1).NE.NREG) CALL XABORT('TRIVSO: INCONSISTENT NREG.') + IF(JPAR(2).NE.NUNKNO) CALL XABORT('TRIVSO: INCONSISTENT NUNKNO.') + ITYPE=JPAR(6) + IELEM=JPAR(9) + ICOL=JPAR(10) + L4=JPAR(11) + NLF=JPAR(30) + ISCAT=JPAR(32) + IF(ICOL.EQ.4) THEN + CALL XABORT('TRIVSO: COLLOCATION NODAL NOT IMPLEMENTED.') + ELSE IF((ITYPE.NE.2).AND.(ITYPE.NE.5).AND.(ITYPE.NE.7)) THEN + CALL XABORT('TRIVSO: CARTESIAN 1D, 2D OR 3D GEOMETRY EXPECTED.') + ELSE IF(IELEM.LT.0) THEN + CALL XABORT('TRIVSO: RAVIART-THOMAS METHOD EXPECTED.') + ENDIF + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + ALLOCATE(KN(MAXKN)) + CALL LCMGET(IPTRK,'KN',KN) +*---- +* RECOVER THE FINITE ELEMENT UNIT STIFFNESS MATRIX. +*---- + IF(NLF.GT.0) THEN + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMLEN(IPTRK,'T',LC,ITYLCM) + ALLOCATE(RR(LC,LC)) + CALL LCMGET(IPTRK,'R',RR) + CALL LCMSIX(IPTRK,' ',2) + ENDIF +*---- +* COMPUTE THE SOURCE +*---- + IF(NLF.EQ.0) THEN +*---- +* ++++ DIFFUSION THEORY ++++ +*---- + CALL LCMGET(KPMACR,'NJJS00',NJJ(1)) + CALL LCMGET(KPMACR,'IJJS00',IJJ(1)) + CALL LCMGET(KPMACR,'IPOS00',IPOS(1)) + CALL LCMGET(KPMACR,'SCAT00',XSCAT(1)) + IF((ITYPE.EQ.2).OR.(ITYPE.EQ.5).OR.(ITYPE.EQ.7)) THEN +*---- +* CARTESIAN DUAL (RAVIART-THOMAS) CASE. +*---- + NUM1=0 + DO 60 IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) GO TO 60 + IF(VOL(IR).EQ.0.0) GO TO 50 + DO 40 I0=1,IELEM**3 + IND=KN(NUM1+1)+I0-1 + JG=IJJ(IBM) + DO 30 JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + SUNKNO(IND,IG)=SUNKNO(IND,IG)+FUNKNO(IND,JG)*VOL(IR)* + > XSCAT(IPOS(IBM)+JND-1) + ENDIF + JG=JG-1 + 30 CONTINUE + 40 CONTINUE + 50 NUM1=NUM1+1+6*IELEM**2 + 60 CONTINUE + ELSE + CALL XABORT('TRIVSO: DISCRETIZATION NOT IMPLEMENTED(1).') + ENDIF + ELSE +*---- +* ++++ SPN THEORY ++++ +*---- + DO 350 IL=0,MIN(ABS(ISCAT)-1,NANIS) + FACT=REAL(2*IL+1) + CALL LCMGET(KPMACR,'NJJS'//CAN(IL),NJJ(1)) + CALL LCMGET(KPMACR,'IJJS'//CAN(IL),IJJ(1)) + CALL LCMGET(KPMACR,'IPOS'//CAN(IL),IPOS(1)) + CALL LCMGET(KPMACR,'SCAT'//CAN(IL),XSCAT(1)) + NUM1=0 + DO 340 IR=1,NREG + IBM=MATCOD(IR) + IF(IBM.LE.0) GO TO 340 + IF(MOD(IL,2).EQ.0) THEN + DO 250 I0=1,IELEM**3 + IND=(IL/2)*L4+KN(NUM1+1)+I0-1 + JG=IJJ(IBM) + DO 240 JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + SUNKNO(IND,IG)=SUNKNO(IND,IG)+FACT*FUNKNO(IND,JG)* + > VOL(IR)*XSCAT(IPOS(IBM)+JND-1) + ENDIF + JG=JG-1 + 240 CONTINUE + 250 CONTINUE + ELSE + DO 330 I0=1,IELEM + DO 275 IC=1,2 + IIC=1+(IC-1)*IELEM + KN1=KN(NUM1+2+(IC-1)*IELEM**2) + IND1=(IL/2)*L4+ABS(KN1)+I0-1 + S1=REAL(SIGN(1,KN1)) + DO 270 JC=1,2 + JJC=1+(JC-1)*IELEM + KN2=KN(NUM1+2+(JC-1)*IELEM**2) + IND2=(IL/2)*L4+ABS(KN2)+I0-1 + IF((KN1.NE.0).AND.(KN2.NE.0)) THEN + S2=REAL(SIGN(1,KN2)) + AUXX=S1*S2*FACT*RR(IIC,JJC)*VOL(IR) + JG=IJJ(IBM) + DO 260 JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + SUNKNO(IND1,IG)=SUNKNO(IND1,IG)-AUXX*FUNKNO(IND2,JG)* + 1 XSCAT(IPOS(IBM)+JND-1) + ENDIF + JG=JG-1 + 260 CONTINUE + ENDIF + 270 CONTINUE + 275 CONTINUE + DO 295 IC=3,4 + IIC=1+(IC-3)*IELEM + KN1=KN(NUM1+2+(IC-1)*IELEM**2) + IND1=(IL/2)*L4+ABS(KN1)+I0-1 + S1=REAL(SIGN(1,KN1)) + DO 290 JC=3,4 + JJC=1+(JC-3)*IELEM + KN2=KN(NUM1+2+(JC-1)*IELEM**2) + IND2=(IL/2)*L4+ABS(KN2)+I0-1 + IF((KN1.NE.0).AND.(KN2.NE.0)) THEN + S2=REAL(SIGN(1,KN2)) + AUXX=S1*S2*FACT*RR(IIC,JJC)*VOL(IR) + JG=IJJ(IBM) + DO 280 JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + SUNKNO(IND1,IG)=SUNKNO(IND1,IG)-AUXX*FUNKNO(IND2,JG)* + 1 XSCAT(IPOS(IBM)+JND-1) + ENDIF + JG=JG-1 + 280 CONTINUE + ENDIF + 290 CONTINUE + 295 CONTINUE + DO 320 IC=5,6 + IIC=1+(IC-5)*IELEM + KN1=KN(NUM1+2+(IC-1)*IELEM**2) + IND1=(IL/2)*L4+ABS(KN1)+I0-1 + S1=REAL(SIGN(1,KN1)) + DO 310 JC=5,6 + JJC=1+(JC-5)*IELEM + KN2=KN(NUM1+2+(JC-1)*IELEM**2) + IND2=(IL/2)*L4+ABS(KN2)+I0-1 + IF((KN1.NE.0).AND.(KN2.NE.0)) THEN + S2=REAL(SIGN(1,KN2)) + AUXX=S1*S2*FACT*RR(IIC,JJC)*VOL(IR) + JG=IJJ(IBM) + DO 300 JND=1,NJJ(IBM) + IF(JG.NE.IG) THEN + SUNKNO(IND1,IG)=SUNKNO(IND1,IG)-AUXX*FUNKNO(IND2,JG)* + 1 XSCAT(IPOS(IBM)+JND-1) + ENDIF + JG=JG-1 + 300 CONTINUE + ENDIF + 310 CONTINUE + 320 CONTINUE + 330 CONTINUE + ENDIF + NUM1=NUM1+1+6*IELEM**2 + 340 CONTINUE + 350 CONTINUE + ENDIF + DEALLOCATE(KN) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + IF(NLF.GT.0) DEALLOCATE(RR) + DEALLOCATE(XSCAT) + DEALLOCATE(IPOS,NJJ,IJJ) + RETURN + END diff --git a/Dragon/src/TRKHEX.f b/Dragon/src/TRKHEX.f new file mode 100644 index 0000000..84b546a --- /dev/null +++ b/Dragon/src/TRKHEX.f @@ -0,0 +1,2954 @@ +*DECK TRKHEX + SUBROUTINE TRKHEX(IPRT,NCEL,FVOL,REMESH,MESH,PAS1,A,COS1,COS2, + + COS3,POP,STAIRS,IPLANZ,FACST,NDIM,NCYL,MAT,IFILE, + + IANGL,POIDS,MAT2,NSECT,T0,TSEC,V0,VSEC,PAS2,RAYON, + + ZMIN,ZMAX,FACB,NVOL,SECTOR,NSMIN,SURB,RAUX,NSURF,CORN, + + ICOR,VOISIN,NCEL2,NSOUT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the tracking information related to a +* hexagonal heterogeneous assembly for a given +* angle in a 3D or 2D geometry. +* +*Copyright: +* Copyright (C) 1991 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): +* M. Ouisloumen +* +*Parameters: input +* IPRT print option. +* NCEL number of cells of the assembly. +* FVOL first zone in the cell. +* NVOL first volume number in the cell. +* NCYL number of cylinder in the cell. +* REMESH contains the coordinates of the hexagon centers (height for +* Z), the location of the cylinders and their radius. +* The order is: +* XH(1),XH(2),...,YH(1),YH(2),...,ZH(1),ZH(2),...,XC(1),YC(1), +* ZC(1),RC(1),XC(2),YC(2),ZC(2),RC(2)... +* A lenght of one of the hexagone. +* COS1 X director cosine. +* COS2 Y director cosine. +* COS3 Z director cosine. +* PAS1 line spacing in Y. +* PAS2 line spacing in Z. +* STAIRS cell maximum number in plane. +* FACST surface maximum number in plane. +* NDIM number of dimensions of problem. +* IFILE file track unit number. +* NSECT number of sectors in volume. +* FACB first bottom or top surface number. +* SECTOR flag for sector. +* SURB initial surface numbering. +* VOISIN 6 neighbors of each cell in the X-Y plane. +* NSOUT Total number of surfaces in global geometry. +* +*Parameters: input/output +* IANGL angle number. +* +*Parameters: scratch +* POP undefined. +* MAT undefined. +* T0 undefined. +* TSEC undefined. +* V0 undefined. +* VSEC undefined. +* RAUX undefined. +* MESH undefined. +* IPLANZ undefined. +* POIDS undefined. +* MAT2 undefined. +* RAYON undefined. +* ZMIN undefined. +* ZMAX undefined. +* NSMIN undefined. +* NSURF undefined. +* CORN undefined. +* ICOR undefined. +* NCEL2 undefined. +* +*Comments: +* Assembly coordinate system +* .Z +* . +* . . Y +* ++++++++ . . +* + + . . +* + + . . +* + + .. +* I ++++++++ I O .............. X +* I I I I +* I I I I +* I I I I +* + I I + +* ++++++++ +* +*--------------------------- TRKHEX --------------------------------- +* + IMPLICIT NONE + INTEGER IOUT + DOUBLE PRECISION SQRT3,PI + CHARACTER*6 NAMSBR + PARAMETER (IOUT=6,SQRT3=1.732050807568877D0, + > PI=3.141592653589793D0,NAMSBR='TRKHEX') +*---- +* ROUTINE PARAMETERS +*---- + INTEGER IPRT,NCEL,MESH,IPLANZ,NDIM,ICOR,IFILE,NSMIN, + > NSURF,NCEL2,IANGL,NSOUT + REAL REMESH(MESH) + DOUBLE PRECISION POP(*),A,COS1,COS2,COS3,PAS1,PAS2,RAYON,POIDS, + > ZMIN,ZMAX + DOUBLE PRECISION T0(*),TSEC(*),RAUX(*) + INTEGER FVOL(NCEL),STAIRS(IPLANZ),FACST(IPLANZ), + > NCYL(NCEL),MAT(*),MAT2(*),NSECT(*),V0(*), + > VSEC(*),FACB(*),NVOL(*),SURB(NSMIN:*), + > CORN(ICOR),VOISIN(6,NCEL2) + LOGICAL SECTOR +*---- +* LOCAL VECTORS +*---- + INTEGER SURC(6),SURF1(8),SURF2(8),FACEM(5), + > FACES(5),FACEM1(5),FACEM2(5),FACEMD(5), + > SURFX(8),FACEMU(5),MAT3(10) + DOUBLE PRECISION T(9),XDR(8),YDR(8),ZDR(8) + LOGICAL START,DIRUP,LGSTOR,LGDIM,LGPG1,LGFAC, + > LGMAT3,LGDIR,LGPER,LGFAC8,LGFAC7, + > LTHROU,LGDEB,LGPASS,PASSU,PASSD,LGPAS0, + > LGPASU,LGPASD,LGOUT1,LGOUTU,LGOUTD,LGG,LGG1 +*---- +* ADDITIONNAL VARIABLES +*---- + INTEGER IFONC,IFCOUR,JSEC2,JSEC,JCC,J,IVS1,IVS0,JC, + > JCC0,KMAX,N,IZONE,ISECTR,L,LMIN,ILINE, + > IZZ,IZ0,LMAX,L0,LL,LSTEP,ISV,JSV, + > JVOUT2,JVOUT1,IFV,IVSEC1,IS,IVS,IVSEC2,JAUX, + > ISEC,IS1,IAUX,LPOP,IMAM,IFOUT2,KSECT,JMAX,JMIN, + > IXY,KFACE,ISURF2,ISURF1,NFACX,ISTAIR,IMAX,IW, + > IFACST,LFOUT2,ISXX,KS,IP,KOUT,KFXX,MSECT,LVOUT, + > IFOUT1,NSURF2,NSURF1,IVOUT1,IMAT2,IVOL,KPOP, + > IFDOWN,MFACD,IMATD,ICDOWN,I3,IVAUX,ISC,ISS, + > ISSX,I2,I1,JS,MFACU,IMAT0,KPC,IVOUT2,NFAC,ICXX, + > IYY,NFXX,ICELLD,IXX,KPLD,IFACEU,IVOUT,IFACE, + > ICELLX,IMAT,LSV,I,IX,NCOUR,LIM2,ICELL,LIM1, + > ITAB,ICELL0,KFACE2,KFACED,KFACE1,KPER, + > IPOP,NCELZ,LFACE,KAM,KMA,KCEL1,IPP,ICELL2, + > IVDOWN,IPOS,IVUP,KUP,KDOWN,KMAT2,LVOIS,KC, + > IFF1,IXF,IFF0,IAC,MM,KPER3,IFG,IC,LAUX,KVOL2, + > KVOL1,IV01,IV02,K,ICYL,ISTEP,IFACE2,IFACE1, + > ICC,KPL,MFAC2,MFAC,MFAC1,IFF,IPAR,ICEL0,IC8, + > IPPP,IPX,KCEL2,JFF,ISURM,IVOLC,IETAG,KCELD,ISURC + DOUBLE PRECISION ANG0,DIST,YAUX,XAUX,TTHYP0,TTHYP1,THYP,XT,YT, + > YRF,YRH,PENTE,XPT,ATAN0,ANG2,ANG1,YPT,DEL0, + > YPH2,TGA,TT1,TT0,TTHYP,YPF,DEL1,ATAN1,YPH, + > COSR,SINR,R2AZ,ZZ,COAZ, + > CY0MIN,CY0MAX,DIV2,COS1I,DIV1,Y0MIN,Y0MAX,SAZ, + > TERM3,COEF1,TERM2,ZLA,TERM1,Z0,Z00,Z0MAX,COEF2, + > Z0MIN,COS2I,XZTMIN,ZTMAX,XZTMAX,SSS,Y0COS,ZTMIN, + > Y00,SSQ,CZMAX,ZZ0,CZMIN,CZX1,CZX2,XY02,Y0,XY01, + > DELTA,SDELTA,ALP,Z2,PASY,Z1,Y,X,ACOS6,PASZ,EPS1, + > EPS2,EPS3,EPS4,EPS5,EPS6,EPSY,EPSZ,EPSX,EPSS, + > YDEN2,R2,YDEN1,YDDD,YDEN,RSCOS2,POID1,AY,SCOS3, + > AX,TGDIR,SCOS2,AZ,SCOS1,TTT,ZP,ZM,T0MIN,T0MAX, + > TM,R,YYC,YCYL,XCYL,SDEL,TP,DEL,BZ,DEE,YDROIT, + > XDROIT,XMA2,XMA,XPA2,Y6,Y1,Y3,ZDROIT,Y4,XPA, + > YY,Y2,Y5,ZZZ,YUP,ZDOWN,ZUP,FACY,FACX,YDOWN, + > FTX,FTY + DOUBLE PRECISION AUX1,WEIGHT + DOUBLE PRECISION YT1,YT2,YT3,YT4,YT5,YT6,XT1,XT2,XT3,XT4,EPST,DZ0 + CHARACTER HSMG*131 +* +* FONCTION NECESSAIRE POUR LA ROTATION ET LA RECHERCHE +* DES SURFACES EXTERNES +* + IFONC(N,L)= 2+(N-1)*(L+3*(N-2)) + IFCOUR(N)=NINT( (4.+SQRT(1.+4.*FLOAT(N-1)/3.) + + +SQRT(1.+4.*FLOAT(N-2)/3.))*.25) +* +* TRACKING PAR RAPPORT AU PLAN YOZ. LES DIMENSIONS DU PLAN +* A TRACKER SONT DETERMINEES EN FONCTION DES ANGLES +* + DO 767 ITAB=1,5 + SURF1(ITAB)=0 + SURF2(ITAB)=0 + FACEM(ITAB)=0 + 767 CONTINUE + T(9)=1.0D30 + EPS1=1.0D-6 + EPST=EPS1*EPS1 + DZ0=0.0D0 + EPS2=2.0D0*EPS1 + EPS3=5.0D0*EPS1 + EPS4=1.0D-2*EPS1 + EPS5=9.0D0*EPS1 + EPS6=10.0D0*EPS1 + EPSS=MAX(EPS1*ABS(COS1),EPS1*ABS(COS2)) + EPSS=MAX(EPSS,EPS1*ABS(COS3)) + EPSX=EPSS + EPSY=EPSS + EPSZ=EPSS + PASZ=PAS2 + PASY=PAS1 + Z1=0.0 + Z2=0.0 + NCOUR=1 + IF(STAIRS(1).GT.1)NCOUR=IFCOUR(STAIRS(1)) + LIM2=STAIRS(1) + LIM1=IFONC(NCOUR,0) + ACOS6=.5*SQRT3*A + X=0. + Y=0. + ICELL=1 + ICELL0=0 + KPER=0 + IPOP=0 + KFACE1=9 + KFACE2=9 + KFACED=9 + LGOUT1=.FALSE. + LGOUTD=.FALSE. + LGOUTU=.FALSE. + LGDEB=.TRUE. + LGPAS0=.FALSE. + LGMAT3=.FALSE. + START=.TRUE. + DIRUP=.TRUE. + NCELZ=2*NCEL + LGDIM=NDIM.EQ.3 + LFACE=6 + SCOS1=COS1*COS1 + SCOS2=COS2*COS2 + AZ=SCOS1+SCOS2 + LGPG1=.FALSE. + TGDIR=COS2/COS1 + YDDD=SQRT3*TGDIR + YDEN=1.+YDDD + YDEN1=-1.+YDDD + YDEN2=1.-YDDD + ICDOWN=0 + ICELLD=0 + ICELLX=0 + IETAG=0 + IFDOWN=0 + IMAT2=0 + IMATD=0 + ISURC=0 + ISURM=0 + IVOLC=0 + KCEL1=0 + KCEL2=0 + KCELD=0 + KMAX=0 + KPER3=0 + KPL=0 + KPOP=0 + KSECT=0 + LPOP=0 + MFACD=0 + NSURF1=0 + IF(LGDIM) THEN + R2=RAYON*RAYON + SCOS3=COS3*COS3 + AX=SCOS2+SCOS3 + AY=SCOS1+SCOS3 + RSCOS2=R2*SCOS2 + LGPG1=IPLANZ.GT.1 + LFACE=8 + POID1=POIDS +* +*--L'ASSEMBLAGE A TRAITER EST CONFINE DANS UN CYLINDRE DE RAYON=RAYON +* FERME PAR DEUX CALOTTES SPHERIQUES A CES EXTREMITES +* + ALP=SCOS1+SCOS3 + ZLA=SCOS1/R2 +* +*--EXTEMUMS DE Z0: LIMITES SELON L'AXE Z DU PLAN A TRACKER +* + TERM1=SCOS1+SCOS2*SCOS3 + TERM2=-SCOS1+SCOS2*SCOS3 + TERM3=RAYON/(COS1*SQRT((1.-SCOS3)*TERM1)) + COEF1=TERM3*TERM1 + COEF2=TERM3*TERM2 + Z0MIN=ZMIN+COEF1 + Z0MIN=MIN(Z0MIN,ZMIN-COEF1) + Z0MIN=MIN(Z0MIN,ZMIN+COEF2) + Z0MIN=MIN(Z0MIN,ZMIN-COEF2) + Z0MAX=ZMAX+COEF1 + Z0MAX=MAX(Z0MAX,ZMAX-COEF1) + Z0MAX=MAX(Z0MAX,ZMAX+COEF2) + Z0MAX=MAX(Z0MAX,ZMAX-COEF2) + PASZ=(Z0MAX-Z0MIN)*PAS2 + Z0=Z0MIN+PASZ*.5 + Z00=Z0 + SAZ=SQRT(AZ) + CY0MIN=-RAYON*SAZ/ABS(COS1) + CY0MAX=-CY0MIN + COAZ=COS3/AZ + R2AZ=R2*AZ + ZZ=RAYON*ABS(COS3*COS2/(COS1*SAZ)) + Y0MIN=999999.0 + Y0MAX=-Y0MIN + ELSE + R2=0.0D0 + POID1=0.0D0 + RSCOS2=0.0D0 + ALP=0.0D0 + ZLA=0.0D0 + CY0MIN=0.0D0 + CY0MAX=0.0D0 + COAZ=0.0D0 + R2AZ=0.0D0 + ZZ=0.0D0 + Z0=0.0D0 + Z00=0.0D0 + Y0MIN=-RAYON/ABS(COS1) + Y0MAX=-Y0MIN + PASY=(Y0MAX-Y0MIN)*PAS1 + POIDS=POIDS*PASY + Z0MIN=999999.0 + Z0MAX=-Z0MIN + ENDIF + DIV1=1./(COS2+COS1*SQRT3) + DIV2=1./(COS2-COS1*SQRT3) + COS1I=1./COS1 + COS2I=1./COS2 + 777 CONTINUE + ILINE=0 + IF(LGDIM) THEN +* +*--DOMAINE DE VARIATION DE Y0 POUR Z0 FIXE +* + CZX1=Z0-ZZ + CZX2=Z0+ZZ + CZMIN=MIN(CZX1,CZX2) + CZMAX=MAX(CZX1,CZX2) + IF(CZMAX.LT.ZMIN)THEN + ZZ0=Z0-ZMIN + DELTA=-ZLA*ZZ0*ZZ0+ALP + IF(DELTA.GE.0.) THEN + SDELTA=SQRT(DELTA) + XY01=ZZ0*COS2*COS3 + XY02=RAYON*SDELTA + Y0MIN=(XY01-XY02)/ALP + Y0MAX=(XY01+XY02)/ALP + ELSE + CALL XABORT('TRKHEX: ALGORITHME FAILURE -A') + ENDIF + ELSEIF(CZMIN.LT.ZMAX)THEN + Y0MIN=CY0MIN + Y0MAX=CY0MAX + ELSE + ZZ0=Z0-ZMAX + DELTA=-ZLA*ZZ0*ZZ0+ALP + IF(DELTA.GE.0.) THEN + SDELTA=SQRT(DELTA) + XY01=ZZ0*COS2*COS3 + XY02=RAYON*SDELTA + Y0MIN=(XY01-XY02)/ALP + Y0MAX=(XY01+XY02)/ALP + ELSE + CALL XABORT('TRKHEX: ALGORITHME FAILURE - B') + ENDIF + ENDIF + PASY=(Y0MAX-Y0MIN)*PAS1 + POIDS=POID1*PASZ*PASY + Y0=Y0MIN + ILINE=ILINE+1 + 611 SSQ=SCOS1*(R2-Y0*Y0)+RSCOS2 + IF(SSQ.GT.0.) THEN + SSS=SQRT(SSQ) + Y0COS=Y0*COS2 + XZTMAX=Z0+(SSS-Y0COS)*COAZ + XZTMIN=Z0+(-SSS-Y0COS)*COAZ + ZTMAX=MAX(XZTMAX,XZTMIN) + ZTMIN=MIN(XZTMAX,XZTMIN) + IF(ZTMAX.LT.ZMIN) THEN + Y0=Y0+PASY + IF(Y0.GT.Y0MAX) GOTO 53 + GOTO 611 + ELSEIF(ZTMIN.GT.ZMAX) THEN + Y0=Y0+PASY + IF(Y0.GT.Y0MAX) GOTO 53 + GOTO 611 + ENDIF + ENDIF + ELSE + Y0=Y0MIN+PASY*.5 + ILINE=ILINE+1 + ENDIF + Y00=Y0 + LGDEB=.TRUE. + IX=1 + I=CORN(1) + LGPER=.FALSE. + GOTO 42 +* +* INTERSECTION DES PLANS DE L'HEXAGONE AVEC LA DROITE +* + 10 YY=Y-Y0 + TERM1=SQRT3*(X+A) + TERM2=SQRT3*(X-A) + T(1)=(TERM1+YY)*DIV1 + T(2)=(YY+ACOS6)*COS2I + T(3)=(YY-TERM2)*DIV2 + T(4)=(YY+TERM2)*DIV1 + T(5)=(YY-ACOS6)*COS2I + T(6)=(YY-TERM1)*DIV2 + IF(LGDIM) THEN + Z2=REMESH(NCELZ+ICELL) + IF(LGPG1) THEN + IF(ICELL.GT.STAIRS(1))THEN + KPL=INT(AINT(REAL(ICELL)/REAL(STAIRS(1)))) + IF(MOD(ICELL,STAIRS(1)).NE.0)KPL=KPL+1 + ICC=ICELL-STAIRS(KPL-1) + IF(KPL.GT.2)ICC=ICC+STAIRS(KPL-2) + Z1=REMESH(NCELZ+ICC) + GOTO 14 + ENDIF + ENDIF + 14 T(7)=(Z1-Z0)/COS3 + T(8)=(Z2-Z0)/COS3 + ZDR(1)=COS3*T(1)+Z0 + ZDR(2)=COS3*T(2)+Z0 + ZDR(3)=COS3*T(3)+Z0 + ZDR(4)=COS3*T(4)+Z0 + ZDR(5)=COS3*T(5)+Z0 + ZDR(6)=COS3*T(6)+Z0 + ZDR(7)=Z1 + XDR(7)=COS1*T(7) + YDR(7)=COS2*T(7)+Y0 + XDR(8)=COS1*T(8) + YDR(8)=COS2*T(8)+Y0 + ZDR(8)=Z2 + ENDIF + XDR(1)=COS1*T(1) + YDR(1)=SQRT3*(X-XDR(1)+A)+Y + XDR(2)=COS1*T(2) + YDR(2)=Y+ACOS6 + XDR(3)=COS1*T(3) + YDR(3)=SQRT3*(-X+A+XDR(3))+Y + XDR(4)=COS1*T(4) + YDR(4)=SQRT3*(X-XDR(4)-A)+Y + XDR(5)=COS1*T(5) + YDR(5)=Y-ACOS6 + XDR(6)=COS1*T(6) + YDR(6)=SQRT3*(-X+XDR(6)-A)+Y +* +* RECHERCHE DES FACES DE SORTIE +* + 15 IFACE2=9 + IFACE1=9 + MFAC=0 + MFAC1=0 + MFAC2=0 + LGFAC=.FALSE. + LGPASU=.FALSE. + LGPASD=.FALSE. + Y2=Y+ACOS6 + Y5=Y-ACOS6 + XPA=X+A + XMA=X-A + XPA2=X+.5*A + XMA2=X-.5*A + DO 20 I=1,LFACE + YDROIT=YDR(I) + XDROIT=XDR(I) + IF(LGDIM) THEN + ZDROIT=ZDR(I) + IF((ZDROIT.LE.Z2.OR.ABS(ZDROIT-Z2).LE.EPSZ).AND. + + (ZDROIT.GE.Z1.OR.ABS(ZDROIT-Z1).LE.EPSZ)) GOTO 17 + GOTO 19 + ENDIF + 17 IF((YDROIT.GE.Y5.OR.ABS(YDROIT-Y5).LE.EPSY).AND. + + (YDROIT.LE.Y2.OR.ABS(YDROIT-Y2).LE.EPSY))THEN + IF((XDROIT.GE.XMA.OR.ABS(XDROIT-XMA).LE.EPSX).AND. + + (XDROIT.LE.XPA.OR.ABS(XDROIT-XPA).LE.EPSX))THEN + Y4=SQRT3*(X-XDROIT-A)+Y + Y3=SQRT3*(-X+A+XDROIT)+Y + Y6=SQRT3*(-X+XDROIT-A)+Y + Y1=SQRT3*(X-XDROIT+A)+Y + IF(ABS(YDROIT-Y2).LT.EPSY) THEN + IF(((XDROIT.GE.XMA2).OR.ABS(XDROIT-XMA2).LE.EPSX).AND. + + ((XDROIT.LE.XPA2).OR.ABS(XDROIT-XPA2).LE.EPSX))GOTO 18 + GOTO 19 + ELSEIF(ABS(YDROIT-Y5).LT.EPSY) THEN + IF(((XDROIT.GE.XMA2).OR.ABS(XDROIT-XMA2).LE.EPSX).AND. + + ((XDROIT.LE.XPA2).OR.ABS(XDROIT-XPA2).LE.EPSX))GOTO 18 + GOTO 19 + ELSEIF(ABS(YDROIT-Y1).LT.EPSY) THEN + GOTO 18 + ELSEIF(ABS(YDROIT-Y3).LT.EPSY) THEN + GOTO 18 + ELSEIF(ABS(YDROIT-Y4).LT.EPSY) THEN + GOTO 18 + ELSEIF(ABS(YDROIT-Y6).LT.EPSY) THEN + GOTO 18 + ELSEIF(I.EQ.7) THEN + IF(XDROIT.GE.XMA2.AND.XDROIT.LE.XPA2)THEN + GOTO 18 + ELSEIF(XDROIT.GE.XMA.AND.XDROIT.LE.XMA2)THEN + IF(((YDROIT.GE.Y4).OR.ABS(YDROIT-Y4).LE.EPSY).AND. + + ((YDROIT.LE.Y3).OR.ABS(YDROIT-Y3).LE.EPSY))GOTO 18 + GOTO 19 + ELSEIF(XDROIT.GE.XPA2.AND.XDROIT.LE.XPA)THEN + IF(((YDROIT.GE.Y6).OR.ABS(YDROIT-Y6).LE.EPSY).AND. + + ((YDROIT.LE.Y1).OR.ABS(YDROIT-Y1).LE.EPSY))GOTO 18 + GOTO 19 + ENDIF + ELSEIF(I.EQ.8) THEN + IF(XDROIT.GE.XMA2.AND.XDROIT.LE.XPA2)THEN + GOTO 18 + ELSEIF(XDROIT.GE.XMA.AND.XDROIT.LE.XMA2)THEN + IF(((YDROIT.GE.Y4).OR.ABS(YDROIT-Y4).LE.EPSY).AND. + + ((YDROIT.LE.Y3).OR.ABS(YDROIT-Y3).LE.EPSY))GOTO 18 + GOTO 19 + ELSEIF(XDROIT.GE.XPA2.AND.XDROIT.LE.XPA)THEN + IF(((YDROIT.GE.Y6).OR.ABS(YDROIT-Y6).LE.EPSY).AND. + + ((YDROIT.LE.Y1).OR.ABS(YDROIT-Y1).LE.EPSY))GOTO 18 + GOTO 19 + ENDIF + ELSE + CALL XABORT('TRKHEX: ALGORITHME FAILURE - C') + ENDIF + GOTO 19 + 18 IF(IFACE1.NE.9) THEN + MFAC=MFAC+1 + FACEM(MFAC)=IFACE1 + ENDIF + IFACE1=IFACE2 + IFACE2=I + ENDIF + ENDIF + 19 CONTINUE + 20 CONTINUE +* +* CAS OU LA FACE N'A PAS ETE COMPTE +* + DO 720 IFF=1,LFACE + IF(IFF.NE.IFACE1.AND.IFACE2.NE.IFF) THEN + FTX=ABS(T(IFACE1)-T(IFF)) + FTY=ABS(T(IFACE2)-T(IFF)) + IF(FTX.LE.EPS2) THEN + DO 715 JFF=1,MFAC + IF(FACEM(JFF).EQ.IFF) GOTO 718 + 715 CONTINUE + IF(IFACE2.EQ.9)THEN + IFACE2=IFF + ELSE + MFAC=MFAC+1 + FACEM(MFAC)=IFF + ENDIF + ELSEIF(FTY.LE.EPS2) THEN + DO 717 JFF=1,MFAC + IF(FACEM(JFF).EQ.IFF) GOTO 718 + 717 CONTINUE + IF(IFACE1.EQ.9)THEN + IFACE1=IFF + ELSE + MFAC=MFAC+1 + FACEM(MFAC)=IFF + ENDIF + ENDIF + ENDIF + 718 CONTINUE + 720 CONTINUE + IF(IFACE1.EQ.8) THEN + IPX=IFACE1 + IFACE1=IFACE2 + IFACE2=IPX + ELSEIF(IFACE2.EQ.7) THEN + IPX=IFACE1 + IFACE1=IFACE2 + IFACE2=IPX + ENDIF + LGFAC=MFAC.GT.0 + IF(IFACE1.GT.8.OR.IFACE2.GT.8) THEN +* +* CAS OU LA DROITE EST TANGENTE A UNE CELLULE PERIPHERIQUE +* + IF(LGDEB) THEN + I=ICELL+1 + IF(I.GT.NCEL) GOTO 58 + GOTO 42 + ENDIF + KPER=KPER+1 + MAT2(KPER)=ICELL + IF(DIRUP) THEN + IF(LGOUTU) THEN + ICELL=KCEL2 + IFACE2=KFACE2 + GOTO 739 + ENDIF + ELSE + IF(LGOUTD) THEN + ICELL=KCELD + IFACE1=KFACED + GOTO 739 + ENDIF + ENDIF + IF(LGPAS0) GOTO 56 + ISURC=1 + IETAG=0 + ISURM=6 + SURC(1)=1 + SURC(2)=2 + SURC(3)=3 + SURC(4)=4 + SURC(5)=5 + SURC(6)=6 + IF(LGDIM) THEN + IF(ICELL.LE.STAIRS(1)) THEN + IVOLC=ICELL + I=VOISIN(1,IVOLC) + ELSE + IVOLC=ICELL-STAIRS(KPL-1) + ISURC=0 + I=IVOLC + IF(DIRUP) THEN + IF(KPL.GT.2) IETAG=STAIRS(KPL-2) + ELSE + IF(KPL.EQ.IPLANZ) THEN + IETAG=STAIRS(KPL-1) + ELSE + IETAG=STAIRS(KPL) + ENDIF + ENDIF + ENDIF + ELSE + IVOLC=ICELL + I=VOISIN(1,IVOLC) + ENDIF + LGPAS0=.TRUE. + IF(I.GT.NCEL2) THEN + I=NCEL+10 + GOTO 56 + ENDIF + I=I+IETAG + LGPER=.TRUE. + GOTO 42 + ENDIF +* +*--RECHERCHE DU PLUS GRAND PARCOURS +* + IF(LGFAC) THEN + IF(T(IFACE1).GT.T(IFACE2))THEN + IPPP=IFACE2 + IFACE2=IFACE1 + IFACE1=IPPP + ENDIF + DO 730 IPAR=1,MFAC + IF(T(FACEM(IPAR)).GT.T(IFACE2))THEN + IPPP=IFACE2 + IFACE2=FACEM(IPAR) + FACEM(IPAR)=IPPP + ELSEIF(T(FACEM(IPAR)).LT.T(IFACE1))THEN + IPPP=IFACE1 + IFACE1=FACEM(IPAR) + FACEM(IPAR)=IPPP + ENDIF + 730 CONTINUE + ENDIF +* + IF(LGDIM) THEN + IF(ABS(COS3).GT.EPS1) THEN + ZUP=COS3*T(IFACE2)+Z0 + ZDOWN=COS3*T(IFACE1)+Z0 +* +* CAS OU IFACE1 ET IFACE2 FORMENT LE MEME COIN +* + IF(ZUP.LT.ZDOWN) THEN + IFF=IFACE1 + IFACE1=IFACE2 + IFACE2=IFF + ZZZ=ZUP + ZUP=ZDOWN + ZDOWN=ZUP + ENDIF + ELSE + YUP=COS2*T(IFACE2)+Y0 + YDOWN=COS2*T(IFACE1)+Y0 + IF(YUP.LT.YDOWN) THEN + IFF=IFACE1 + IFACE1=IFACE2 + IFACE2=IFF + ENDIF + ENDIF +* +* ON PREND LA FACE 7 OU 8 DANS LE CAS D'UN COIN +* + IF(LGFAC) THEN + DO 21 IC8=1,MFAC + IF(FACEM(IC8).EQ.8) THEN + FACEM(IC8)=IFACE2 + IFACE2=8 + ELSEIF(FACEM(IC8).EQ.7) THEN + FACEM(IC8)=IFACE1 + IFACE1=7 + ENDIF + 21 CONTINUE + ENDIF + IF(IFACE2.EQ.7)THEN + IFF=IFACE2 + IFACE2=IFACE1 + IFACE1=IFF + ENDIF + IF(IFACE1.EQ.8)THEN + IFF=IFACE2 + IFACE2=IFACE1 + IFACE1=IFF + ENDIF + ELSE + YUP=COS2*T(IFACE2)+Y0 + YDOWN=COS2*T(IFACE1)+Y0 + IF(YUP.LT.YDOWN) THEN + IFF=IFACE1 + IFACE1=IFACE2 + IFACE2=IFF + ENDIF + ENDIF + MFAC1=0 + MFAC2=0 +* +* STOCKAGE POUR LE TRAITEMENT DES FACES DU COIN +* + IF(LGFAC)THEN + DO 301 IFF=1,MFAC + FACX=ABS(T(FACEM(IFF))-T(IFACE2)) + FACY=ABS(T(FACEM(IFF))-T(IFACE1)) + IF(FACY.LE.EPS1) THEN + MFAC1=MFAC1+1 + FACEM1(MFAC1)=FACEM(IFF) + IF(FACX.LE.EPS1) THEN + MFAC2=MFAC2+1 + FACEM2(MFAC2)=FACEM(IFF) + ENDIF + ELSEIF(FACX.LE.EPS1) THEN + MFAC2=MFAC2+1 + FACEM2(MFAC2)=FACEM(IFF) + ELSE + IF(FACX.LT.FACY) THEN + MFAC2=MFAC2+1 + FACEM2(MFAC2)=FACEM(IFF) + ELSE + MFAC1=MFAC1+1 + FACEM1(MFAC1)=FACEM(IFF) + ENDIF + ENDIF + 301 CONTINUE + ENDIF +* +* DETERMINATION DES FACES D'ENTREE OU DE SORTIE +* + IF(.NOT.LGDEB) THEN + ICEL0=ICELL + ISTEP=0 + IF(ICELL.GT.STAIRS(1)) THEN + ISTEP=STAIRS(KPL-1) + ICEL0=ICELL-ISTEP + ENDIF + IXF=0 + LGG=.TRUE. + LGG1=.FALSE. + IF(DIRUP) THEN + IFF0=IFACE1 + IFF1=IFACE2 + IFF=IFACE1 + 554 CONTINUE + IF(IFF.LT.7) THEN + LVOIS=VOISIN(IFF,ICEL0)+ISTEP + ELSE + LVOIS=ICELL-STAIRS(1) + ENDIF + IF(LVOIS.EQ.ICELL0) THEN + IFACE1=IFF + IF(LGG1)FACEM1(IXF)=IFF0 + GOTO 556 + ENDIF + IXF=IXF+1 + LGG1=.FALSE. + IF(IXF.LE.MFAC1) THEN + IFF=FACEM1(IXF) + LGG1=.TRUE. + GOTO 554 + ENDIF + IF(LGG) THEN + LGG=.FALSE. + IF(ABS(T(IFF0)-T(IFACE2)).LE.EPS6) THEN + IFF=IFACE2 + IFACE2=IFACE1 + GOTO 554 + ENDIF + ENDIF + IFACE1=IFF0 + IFACE2=IFF1 + ELSE + IFF0=IFACE2 + IFF1=IFACE1 + IFF=IFACE2 + 557 CONTINUE + IF(IFF.LT.7) THEN + LVOIS=VOISIN(IFF,ICEL0)+ISTEP + ELSE + LVOIS=ICELL+STAIRS(1) + ENDIF + IF(LVOIS.EQ.ICELL0) THEN + IFACE2=IFF + IF(LGG1)FACEM2(IXF)=IFF0 + GOTO 556 + ENDIF + IXF=IXF+1 + LGG1=.FALSE. + IF(IXF.LE.MFAC2) THEN + LGG1=.TRUE. + IFF=FACEM2(IXF) + GOTO 557 + ENDIF + IF(LGG) THEN + LGG=.FALSE. + IF(ABS(T(IFF0)-T(IFACE1)).LE.EPS6) THEN + IFF=IFACE1 + IFACE1=IFACE2 + GOTO 557 + ENDIF + ENDIF + IFACE2=IFF0 + IFACE1=IFF1 + ENDIF + ENDIF + 556 CONTINUE + ICELL0=ICELL +* +* ELEMINATION DES PARCOURS NULS SAUF LE DERNIER. +* + IF(ABS(T(IFACE1)-T(IFACE2)).GT.EPS1) GO TO 930 +* + KPER=KPER+1 + MAT2(KPER)=ICELL + IF(LGDEB) THEN + I=ICELL+1 + IF(I.GT.NCEL) GOTO 58 + GOTO 42 + ENDIF + ISURC=1 + IETAG=0 + ISURM=6 + SURC(1)=1 + SURC(2)=2 + SURC(3)=3 + SURC(4)=4 + SURC(5)=5 + SURC(6)=6 + IF(LGDIM) THEN + IF(ICELL.LE.STAIRS(1)) THEN + IVOLC=ICELL + IF(.NOT.LGFAC) THEN + IF(DIRUP) THEN + IF(IFACE2.LT.8) THEN + I=VOISIN(IFACE2,ICELL) + IF(I.GT.NCEL2) THEN + KPER=KPER-1 + ISURC=0 + GOTO 931 + ELSEIF(IFACE1.LT.7) THEN + IF(VOISIN(IFACE1,ICELL).GT.NCEL2)THEN + IFF=IFACE1 + IFACE1=IFACE2 + IFACE2=IFF + KPER=KPER-1 + ISURC=0 + GOTO 931 + ENDIF + ENDIF + ISURM=1 + SURC(1)=IFACE2 + IF(IFACE1.LT.7) THEN + ISURM=2 + SURC(2)=IFACE1 + ENDIF + ELSE + IF(IPLANZ.EQ.1) THEN + KPER=KPER-1 + ISURC=0 + GOTO 930 + ENDIF + IF(IFACE1.LT.7) THEN + IF(VOISIN(IFACE1,ICELL).GT.NCEL2)THEN + IFF=IFACE1 + IFACE1=IFACE2 + IFACE2=IFF + KPER=KPER-1 + ISURC=0 + GOTO 931 + ENDIF + ENDIF + ISURM=1 + SURC(1)=IFACE1 + ENDIF + ELSE + IF(IFACE1.LT.7) THEN + I=VOISIN(IFACE1,ICELL) + IF(I.GT.NCEL2) THEN + KPER=KPER-1 + ISURC=0 + GOTO 931 + ENDIF + IF(IFACE2.LT.7) THEN + IF(VOISIN(IFACE2,ICELL).GT.NCEL2)THEN + IFF=IFACE1 + IFACE1=IFACE2 + IFACE2=IFF + KPER=KPER-1 + ISURC=0 + GOTO 931 + ENDIF + ENDIF + ISURM=1 + SURC(1)=IFACE1 + IF(IFACE2.LT.7) THEN + ISURM=2 + SURC(2)=IFACE2 + ENDIF + ELSE + KPER=KPER-1 + ISURC=0 + GOTO 930 + ENDIF + ENDIF + ELSE + ISURM=1 + IF(IFACE2.EQ.8) THEN + ISURM=ISURM-1 + ELSE + SURC(ISURM)=IFACE2 + ENDIF + ISURM=ISURM+1 + IF(IFACE1.EQ.7) THEN + ISURM=ISURM-1 + ELSE + SURC(ISURM)=IFACE1 + ENDIF + DO 111 KC=1,MFAC + IF(FACEM(KC).LT.7) THEN + ISURM=ISURM+1 + SURC(ISURM)=FACEM(KC) + ENDIF + 111 CONTINUE + I=VOISIN(SURC(1),IVOLC) + ENDIF + ELSE + IVOLC=ICELL-STAIRS(KPL-1) + IF(.NOT.LGFAC) THEN + IF(DIRUP) THEN + IF(IFACE2.LT.8) THEN + IF(IFACE2.EQ.7) THEN + IFG=IFACE1 + IFACE1=IFACE2 + IFACE2=IFG + ENDIF + IF(VOISIN(IFACE2,IVOLC).GT.NCEL2) THEN + KPER=KPER-1 + ISURC=0 + GOTO 931 + ELSEIF(IFACE1.LT.7) THEN + IF(VOISIN(IFACE1,IVOLC).GT.NCEL2) THEN + IFF=IFACE2 + IFACE2=IFACE1 + IFACE1=IFF + KPER=KPER-1 + ISURC=0 + GOTO 931 + ENDIF + ENDIF + ISURM=1 + SURC(1)=IFACE2 + IF(IFACE1.LT.7) THEN + ISURM=2 + SURC(2)=IFACE1 + ENDIF + ELSEIF(KPL.EQ.IPLANZ) THEN + KPER=KPER-1 + ISURC=0 + GOTO 930 + ELSE + ISURM=1 + SURC(1)=IFACE1 + ENDIF + ELSE + IF(IFACE1.LT.7) THEN + IF(VOISIN(IFACE1,IVOLC).GT.NCEL2) THEN + KPER=KPER-1 + ISURC=0 + GOTO 931 + ELSEIF(IFACE2.LT.7) THEN + IF(VOISIN(IFACE2,IVOLC).GT.NCEL2) THEN + IFF=IFACE2 + IFACE2=IFACE1 + IFACE1=IFF + KPER=KPER-1 + ISURC=0 + GOTO 931 + ENDIF + ENDIF + ISURM=1 + SURC(1)=IFACE1 + IF(IFACE2.LT.7) THEN + ISURM=2 + SURC(2)=IFACE2 + ENDIF + ELSEIF(KPL.EQ.1) THEN + KPER=KPER-1 + ISURC=0 + GOTO 930 + ELSE + ISURM=1 + SURC(1)=IFACE2 + ENDIF + ENDIF + ELSE + ISURM=1 + IF(IFACE2.EQ.8) THEN + ISURM=ISURM-1 + ELSE + SURC(ISURM)=IFACE2 + ENDIF + ISURM=ISURM+1 + IF(IFACE1.EQ.7) THEN + ISURM=ISURM-1 + ELSE + SURC(ISURM)=IFACE1 + ENDIF + DO 222 KC=1,MFAC + IF(FACEM(KC).LT.7) THEN + ISURM=ISURM+1 + SURC(ISURM)=FACEM(KC) + ENDIF + 222 CONTINUE + ENDIF + ISURC=0 + I=IVOLC + IF(DIRUP) THEN + IF(KPL.GT.2) THEN + IETAG=STAIRS(KPL-2) + ENDIF + ELSE + IF(KPL.EQ.IPLANZ) THEN + IETAG=STAIRS(KPL-1) + ELSE + IETAG=STAIRS(KPL) + ENDIF + ENDIF + ENDIF + ELSE + IF(.NOT.LGFAC) THEN + IF(DIRUP) THEN + IF(VOISIN(IFACE2,ICELL).GT.NCEL2) THEN + KPER=KPER-1 + ISURC=0 + GOTO 931 + ENDIF + ELSE + IF(VOISIN(IFACE1,ICELL).GT.NCEL2) THEN + KPER=KPER-1 + ISURC=0 + GOTO 931 + ENDIF + ENDIF + ISURM=2 + SURC(1)=IFACE2 + SURC(2)=IFACE1 + ELSE + DO 333 IC=1,MFAC + ISURM=ISURM+1 + SURC(ISURM)=FACEM(IC) + 333 CONTINUE + ENDIF + IVOLC=ICELL + I=VOISIN(SURC(1),IVOLC) + ENDIF + LGPAS0=.TRUE. + LGPER=.TRUE. + IF(I.GT.NCEL2) THEN + I=NCEL+10 + GOTO 56 + ENDIF + I=I+IETAG + ICELL0=IVOLC+IETAG + GOTO 42 + 931 CONTINUE + 930 LGDEB=.FALSE. +* +* STOKAGE DES ANCIENS VOLUMES PARCOURUS +* + IF(ABS(T(IFACE1)-T(IFACE2)).GE.EPS3) THEN + IF(LGMAT3) THEN + DO 555 IAC=1,KPER3 + KPER=KPER+1 + MAT2(KPER)=MAT3(IAC) + 555 CONTINUE + ENDIF + LGMAT3=.FALSE. + KPER3=0 + ENDIF +* +* CALCUL DES PARCOURS OPTIQUE. LA CELLULE PEUT CONTENIR DES +* CYLINDRES D'AXES DIFFERENTS +* + KPER=KPER+1 + IF(KPER.GT.NCEL+10) THEN + GOTO 384 + ENDIF + MAT2(KPER)=ICELL +* +* COMPTAGE DES CELLULES DU COIN EN PERIPHERIE DANS MAT2 +* + LGOUT1=.FALSE. + LGOUTU=.FALSE. + IF(LGFAC) THEN + DO 812 MM=1,MFAC1 + IF(FACEM1(MM).LT.7) THEN + IF(ICELL.LE.STAIRS(1)) THEN + KMAT2=VOISIN(FACEM1(MM),ICELL) + IF(KMAT2.LE.NCEL2) THEN + IF(IFACE1.LT.7) THEN + IF(VOISIN(IFACE1,ICELL).GT.NCEL2) THEN + IPP=IFACE1 + IFACE1=FACEM1(MM) + FACEM1(MM)=IPP + IF(IPP.LT.7) THEN + KMAT2=VOISIN(IPP,ICELL) + IF(KMAT2.LE.LIM2) THEN + IF(KMAT2.GE.LIM1)THEN + KPER=KPER+1 + MAT2(KPER)=KMAT2 + ELSEIF(LGDIM)THEN + KPER=KPER+1 + MAT2(KPER)=KMAT2 + ENDIF + ENDIF + ENDIF + ELSE + IF(KMAT2.LE.LIM2) THEN + IF(KMAT2.GE.LIM1)THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=KMAT2 + ELSEIF(LGDIM)THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=KMAT2 + ENDIF + ELSEIF(LGDIM) THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=KMAT2 + ENDIF + ENDIF + ELSE + IF(KMAT2.LE.LIM2) THEN + IF(KMAT2.GE.LIM1)THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=KMAT2 + ELSEIF(LGDIM)THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=KMAT2 + ENDIF + ELSEIF(LGDIM) THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=KMAT2 + ENDIF + ENDIF + ENDIF + ELSE + ICELL2=ICELL-STAIRS(KPL-1) + KMAT2=VOISIN(FACEM1(MM),ICELL2) + IF(KMAT2.LE.NCEL2) THEN + IF(IFACE1.LT.7) THEN + IF(VOISIN(IFACE1,ICELL2).GT.NCEL2) THEN + IPP=IFACE1 + IFACE1=FACEM1(MM) + FACEM1(MM)=IPP + IF(IPP.EQ.7) THEN + KPER=KPER+1 + MAT2(KPER)=ICELL-STAIRS(KPL-1) + IF(KPL.GT.2)MAT2(KPER)=MAT2(KPER)+STAIRS(KPL-2) + ELSE + KMAT2=VOISIN(IPP,ICELL2) + IF(KMAT2.LE.LIM2) THEN + IF(KMAT2.GE.LIM1)THEN + KPER=KPER+1 + MAT2(KPER)=KMAT2 + ELSEIF(KPL.EQ.1)THEN + KPER=KPER+1 + MAT2(KPER)=KMAT2 + ENDIF + ENDIF + ENDIF + ELSE + IF(KMAT2.LE.LIM2) THEN + IF(KMAT2.GE.LIM1)THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=KMAT2 + ELSEIF(KPL.EQ.1)THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=KMAT2 + ENDIF + ELSEIF(KPL.EQ.1) THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=KMAT2 + ENDIF + ENDIF + ELSE + IF(KMAT2.LE.LIM2) THEN + IF(KMAT2.GE.LIM1)THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=KMAT2 + ELSEIF(KPL.EQ.1)THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=KMAT2 + ENDIF + ELSEIF(KPL.EQ.1) THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=KMAT2 + ENDIF + ENDIF + ELSE + LGOUT1=.TRUE. + KCEL1=ICELL + KFACE1=FACEM1(MM) + ENDIF + ENDIF + ENDIF + 812 CONTINUE + DO 813 MM=1,MFAC2 + IF(FACEM2(MM).LT.7) THEN + IF(ICELL.LE.STAIRS(1)) THEN + KMAT2=VOISIN(FACEM2(MM),ICELL) + IF(KMAT2.LE.NCEL2) THEN + IF(IFACE2.LT.7) THEN + IF(VOISIN(IFACE2,ICELL).GT.NCEL2) THEN + IPP=IFACE2 + IFACE2=FACEM2(MM) + FACEM2(MM)=IPP + IF(IPP.EQ.8) THEN + KPER=KPER+1 + MAT2(KPER)=ICELL+STAIRS(1) + ELSE + KAM=VOISIN(IPP,ICELL) + IF(KAM.LE.LIM2) THEN + IF(KAM.GE.LIM1)THEN + KPER=KPER+1 + MAT2(KPER)=KAM + ELSEIF(LGDIM) THEN + KPER=KPER+1 + MAT2(KPER)=KAM + ENDIF + ENDIF + ENDIF + ELSE + IF(KMAT2.GE.LIM1)THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=KMAT2 + ELSEIF(LGDIM) THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=KMAT2 + ENDIF + ENDIF + ELSE + IF(KMAT2.GE.LIM1)THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=KMAT2 + ELSEIF(LGDIM) THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=KMAT2 + ENDIF + ENDIF + ELSE + KFACE2=FACEM2(MM) + KCEL2=ICELL + LGOUTU=.TRUE. + ENDIF + ELSE + ICELL2=ICELL-STAIRS(KPL-1) + KMAT2=VOISIN(FACEM2(MM),ICELL2) + IF(KMAT2.LE.NCEL2) THEN + IF(IFACE2.LT.7) THEN + IF(VOISIN(IFACE2,ICELL2).GT.NCEL2) THEN + IPP=IFACE2 + IFACE2=FACEM2(MM) + FACEM2(MM)=IPP + IF(IPP.EQ.8) THEN + IF(ICELL2.LE.LIM2) THEN + IF(ICELL2.GE.LIM1) THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=ICELL2+STAIRS(KPL) + ELSEIF(KPL.EQ.IPLANZ-1) THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=ICELL2+STAIRS(KPL) + ENDIF + ELSEIF(KPL.EQ.IPLANZ-1)THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=ICELL2+STAIRS(KPL) + ENDIF + ELSE + KMA=VOISIN(IPP,ICELL2) + IF(KMA.LE.LIM2) THEN + IF(KMA.GE.LIM1) THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=KMA+STAIRS(KPL-1) + ELSEIF(KPL.EQ.IPLANZ) THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=KMA+STAIRS(KPL-1) + ENDIF + ELSEIF(KPL.EQ.IPLANZ)THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=KMA+STAIRS(KPL-1) + ENDIF + ENDIF + ELSE + IF(KMAT2.LE.LIM2) THEN + IF(KMAT2.GE.LIM1) THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=KMAT2+STAIRS(KPL-1) + ELSEIF(KPL.EQ.IPLANZ) THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=KMAT2+STAIRS(KPL-1) + ENDIF + ELSEIF(KPL.EQ.IPLANZ)THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=KMAT2+STAIRS(KPL-1) + ENDIF + ENDIF + ELSE + IF(KMAT2.LE.LIM2) THEN + IF(KMAT2.GE.LIM1) THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=KMAT2+STAIRS(KPL-1) + ELSEIF(KPL.EQ.IPLANZ) THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=KMAT2+STAIRS(KPL-1) + ENDIF + ELSEIF(KPL.EQ.IPLANZ)THEN + LGMAT3=.TRUE. + KPER3=KPER3+1 + MAT3(KPER3)=KMAT2+STAIRS(KPL-1) + ENDIF + ENDIF + ELSE + KFACE2=FACEM2(MM) + KCEL2=ICELL + LGOUTU=.TRUE. + ENDIF + ENDIF + ENDIF + 813 CONTINUE + IF(IPOP.LT.1)LGMAT3=.FALSE. + ENDIF +**** + IF(ICELL.GT.NCEL) THEN + WRITE(HSMG,'(29HTRKHEX: CELL OVERFLOW (ICELL=,I6,6H NCYL=,I6, + + 6H NCEL=,I6,1H))') ICELL,NCYL(ICELL),NCEL + CALL XABORT(HSMG) + ENDIF +**** + KUP=1 + KDOWN=2 + IVUP=0 + IVDOWN=0 + LTHROU=.FALSE. + IF(NCYL(ICELL).GT.0) THEN + IPOS=2*NCEL + IF(LGDIM) IPOS=3*NCEL + DO 22 I=1,ICELL-1 + IPOS=IPOS+NCYL(I) + 22 CONTINUE + KUP=NCYL(ICELL)+1 + KDOWN=KUP+1 + LGFAC8=.TRUE. + LGFAC7=.TRUE. + LAUX=0 + DO 25 ICYL=1,NCYL(ICELL) + IPOS=IPOS+1 + XCYL=REMESH(ICELL) + YCYL=REMESH(NCEL+ICELL) + R =REMESH(IPOS) + LAUX=LAUX+1 + RAUX(LAUX)=R*R +* +*--TOUS LES CYLINDRES SONT SUPPOSES D'AXES Z +* + YYC=Y0-YCYL + BZ=-COS1*XCYL+YYC*COS2 + DEE=YYC*COS1+XCYL*COS2 + DEL=RAUX(LAUX)*AZ-DEE*DEE + IF(DEL.GT.0.) THEN + SDEL=SQRT(DEL) + TP=(-BZ+SDEL)/AZ + TM=(-BZ-SDEL)/AZ + IF(LGDIM) THEN + ZP=COS3*TP+Z0 + ZM=COS3*TM+Z0 + IF(ZP.LT.ZM) THEN + ZZZ=ZP + ZP=ZM + ZM=ZZZ + TTT=TP + TP=TM + TM=TTT + ENDIF + IF(ZM.GT.Z2.OR.ZP.LT.Z1) GOTO 24 + LTHROU=.TRUE. + IF(ZP.GE.Z2.OR.ABS(ZP-Z2).LE.EPS1) THEN + IF(IFACE2.EQ.8)THEN + IF(LGFAC8)THEN + LGFAC8=.FALSE. + IVUP=ICYL + ENDIF + IF(ABS(TM-T(8)).LT.EPS6) THEN + LTHROU=.FALSE. + IF(.NOT.LGFAC8)IVUP=ICYL+1 + GO TO 24 + ENDIF + ENDIF + IF(ZM.LE.Z1) THEN + IF(IFACE1.EQ.7)THEN + IF(LGFAC7)THEN + LGFAC7=.FALSE. + IVDOWN=ICYL + ENDIF + ENDIF + GOTO 24 + ENDIF + IVDOWN=ICYL + IF(ABS(TM-T(7)).LT.EPS4) THEN + LGFAC7=.FALSE. + GO TO 24 + ENDIF + IVDOWN=ICYL+1 + KDOWN=KDOWN-1 + T0(KDOWN)=TM + V0(KDOWN)=ICYL+1 + GO TO 24 + ELSEIF(ZM.LE.Z1.OR.ABS(ZM-Z1).LE.EPS1) THEN + IF(IFACE1.EQ.7)THEN + IF(LGFAC7)THEN + LGFAC7=.FALSE. + IVDOWN=ICYL + ENDIF + IF(ABS(TP-T(7)).LT.EPS4) THEN + LTHROU=.FALSE. + IF(.NOT.LGFAC7) IVDOWN=ICYL+1 + GO TO 24 + ENDIF + ENDIF + IVUP=ICYL + IF(ABS(TP-T(8)).LT.EPS4) THEN + LGFAC8=.FALSE. + GO TO 24 + ENDIF + IVUP=ICYL+1 + KUP=KUP+1 + T0(KUP)=TP + V0(KUP)=ICYL + GO TO 24 + ENDIF + ENDIF + IF(LGFAC8)IVUP=ICYL+1 + IF(LGFAC7)IVDOWN=ICYL+1 + KUP=KUP+1 + KDOWN=KDOWN-1 + T0(KUP)=TP + T0(KDOWN)=TM + V0(KUP)=ICYL + V0(KDOWN)=ICYL+1 + ENDIF + 24 CONTINUE + 25 CONTINUE + ENDIF +* +* VOLUME A BORDURE HEXAGONALE +* + KVOL2=NCYL(ICELL)+1 + IF(IFACE2.EQ.8) THEN + IF(LTHROU) KVOL2=IVUP + ENDIF + KVOL1=NCYL(ICELL)+1 + IF(IFACE1.EQ.7) THEN + IF(LTHROU) KVOL1=IVDOWN + ENDIF + KUP=KUP+1 + KDOWN=KDOWN-1 + T0(KUP)=T(IFACE2) + T0(KDOWN)=T(IFACE1) + V0(KUP)=KVOL2 + V0(KDOWN)=KVOL1 + IF(COS3.LT.0.) THEN + T0MIN=T0(KUP) + T0MAX=T0(KDOWN) + ELSE + T0MAX=T0(KUP) + T0MIN=T0(KDOWN) + ENDIF +* +* STOCKAGE POUR SECTEURS +* + K=0 + IV01=V0(KDOWN) + IV02=V0(KDOWN) + LSV=FVOL(ICELL)+NCYL(ICELL) + IFV=FVOL(ICELL)-1 + JVOUT1=0 + JVOUT2=0 + IVSEC1=0 + IVSEC2=0 + DO 125 I=KDOWN,KUP + K=K+1 + TSEC(K)=T0(I) + IV01=MIN(IV01,V0(I)) + IV02=MAX(IV02,V0(I)) + IVS=0 + DO 233 IS=1,V0(I)-1 + IF(NSECT(IFV+IS).GT.1) THEN + IVS=IVS+6*(NSECT(IFV+IS)-1) + ELSE + IVS=IVS+1 + ENDIF + 233 CONTINUE + IF(NSECT(IFV+V0(I)).GT.1) THEN + YPT=COS2*T0(I)+Y0 + XPT=COS1*T0(I) + LGPASS=.TRUE. +* +* CAS OU LA TRACK ARRIVE SUR LE CENTRE DE LA CELLULE +* + IF(V0(I).EQ.1) THEN + IF(ABS(XPT-X).LE.EPS1.AND.ABS(YPT-Y).LE.EPS1) THEN + IF(K.EQ.1) THEN + YPT=COS2*T0(I+1)+Y0 + XPT=COS1*T0(I+1) + LGPASS=.FALSE. + ELSE + YPT=COS2*T0(I-1)+Y0 + XPT=COS1*T0(I-1) + LGPASS=.FALSE. + ENDIF + ENDIF + ENDIF +* + IF(XPT-X.EQ.0.) THEN + PENTE=.5*PI + ELSE + PENTE=ATAN((YPT-Y)/(XPT-X)) + ENDIF + IF(XPT.GT.X) THEN + IF(YPT.LT.Y)PENTE=2*PI-ABS(PENTE) + ELSE + IF(YPT.LT.Y) THEN + PENTE=PI+ABS(PENTE) + ELSE + PENTE=PI-ABS(PENTE) + ENDIF + ENDIF + ISV=6*(NSECT(IFV+V0(I))-1) + JSV=ISV/2 + ANG1=2.*PI/FLOAT(ISV) + ANG2=PI/FLOAT(JSV) + ATAN0=0. + DEL0=PENTE + ISEC=0 + DO 231 IS1=1,ISV + ATAN1=FLOAT(IS1)*ANG1 + DEL1=ABS(PENTE-ATAN1) +* +* 2.E-2 CORRESPAND A PEU PRES A 1 DEGRE +* + IF(DEL0.LE.2.E-2.OR.DEL1.LE.2.E-2) THEN + IAUX=IS1 + IF(DEL0.LE.2.E-2)IAUX=IS1-1 + IF(IAUX.EQ.0)IAUX=ISV + IF(IAUX.EQ.JSV) THEN + SINR=0. + COSR=-1. + ELSEIF(IAUX.EQ.ISV) THEN + SINR=0. + COSR=1. + ELSE + SINR=SIN(FLOAT(IAUX)*ANG1) + COSR=COS(FLOAT(IAUX)*ANG1) + ENDIF + YPH=-(XPT-X)*SINR+(YPT-Y)*COSR + YPF=0. + IF(K.EQ.1) THEN + YPH2=-(COS1*T0(KUP)-X)*SINR+(COS2*T0(KUP)+Y0-Y)*COSR + IF(YPH.GT.YPF) THEN + IF(YPH2.GT.YPF) THEN + ISEC=IAUX+1 + ELSE + IF(MOD(ISV,IAUX).EQ.0) THEN + IF(ISV/IAUX.NE.4) THEN + JAUX=IAUX + IF(IAUX.GT.JSV)JAUX=IAUX-JSV + TGA=TAN(FLOAT(JAUX)*ANG2) + TTHYP=(-X*TGA+Y-Y0)/(COS2-COS1*TGA) + ELSE + TTHYP=X*COS1I + ENDIF + ELSE + JAUX=IAUX + IF(IAUX.GT.JSV)JAUX=IAUX-JSV + TGA=TAN(FLOAT(JAUX)*ANG2) + TTHYP=(-X*TGA+Y-Y0)/(COS2-COS1*TGA) + ENDIF + ISEC=IAUX + IF(TTHYP.GT.T0MIN) THEN + TT0=ABS(TTHYP-T0(I)) + IF(TT0.LE.EPS1) THEN + ISEC=IAUX + TT1=ABS(TTHYP-T0(I+1)) + JVOUT1=IAUX+1 + IF(TT1.LE.EPS1) THEN + IF(TT1.LT.TT0) THEN + ISEC=IAUX+1 + JVOUT1=0 + JVOUT2=IAUX + IF(JVOUT2.GT.ISV) JVOUT2=JVOUT2-ISV + ENDIF + ENDIF + IF(JVOUT1.GT.ISV) JVOUT1=JVOUT1-ISV + ELSE + ISEC=IAUX+1 + ENDIF + ENDIF + ENDIF + ELSEIF(YPH.LT.YPF) THEN + IF(YPH2.LT.YPF) THEN + ISEC=IAUX + ELSE + IF(MOD(ISV,IAUX).EQ.0) THEN + IF(ISV/IAUX.NE.4) THEN + JAUX=IAUX + IF(IAUX.GT.JSV)JAUX=IAUX-JSV + TGA=TAN(FLOAT(JAUX)*ANG2) + TTHYP=(-X*TGA+Y-Y0)/(COS2-COS1*TGA) + ELSE + TTHYP=X*COS1I + ENDIF + ELSE + JAUX=IAUX + IF(IAUX.GT.JSV)JAUX=IAUX-JSV + TGA=TAN(FLOAT(JAUX)*ANG2) + TTHYP=(-X*TGA+Y-Y0)/(COS2-COS1*TGA) + ENDIF + ISEC=IAUX+1 + IF(TTHYP.GT.T0MIN)THEN + TT0=ABS(T0(I)-TTHYP) + IF(TT0.LE.EPS1) THEN + ISEC=IAUX+1 + TT1=ABS(T0(I+1)-TTHYP) + JVOUT1=IAUX + IF(TT1.LE.EPS1) THEN + IF(TT1.LE.TT0) THEN + ISEC=IAUX + JVOUT1=0 + JVOUT2=IAUX+1 + IF(JVOUT2.GT.ISV) JVOUT2=JVOUT2-ISV + ENDIF + ENDIF + IF(JVOUT1.GT.ISV) JVOUT1=JVOUT1-ISV + ELSE + ISEC=IAUX + ENDIF + ENDIF + ENDIF + ELSE + ISEC=IAUX + IF(YPH2.GT.YPF) ISEC=IAUX+1 + ENDIF + ELSE + YPH2=-(COS1*T0(KDOWN)-X)*SINR+(COS2*T0(KDOWN)+Y0-Y)*COSR + IF(YPH.GT.YPF) THEN + IF(YPH2.GT.YPF) THEN + ISEC=IAUX+1 + ELSE + IF(MOD(ISV,IAUX).EQ.0) THEN + IF(ISV/IAUX.NE.4) THEN + JAUX=IAUX + IF(IAUX.GT.JSV)JAUX=IAUX-JSV + TGA=TAN(FLOAT(JAUX)*ANG2) + TTHYP=(-X*TGA+Y-Y0)/(COS2-COS1*TGA) + ELSE + TTHYP=X*COS1I + ENDIF + ELSE + JAUX=IAUX + IF(IAUX.GT.JSV)JAUX=IAUX-JSV + TGA=TAN(FLOAT(JAUX)*ANG2) + TTHYP=(-X*TGA+Y-Y0)/(COS2-COS1*TGA) + ENDIF + ISEC=IAUX + IF(TTHYP.LE.T0MAX) THEN + IF(LGPASS) THEN + IF(NCYL(ICELL).GT.1) THEN + XAUX=X-COS1*TTHYP + YAUX=Y-COS2*TTHYP-Y0 + DIST=XAUX*XAUX+YAUX*YAUX + ISEC=IAUX + IF(V0(I).GT.NCYL(ICELL)) THEN + IF(DIST.LE.RAUX(NCYL(ICELL))) GOTO 331 + ELSEIF(V0(I).EQ.1) THEN + IF(DIST.GE.RAUX(1)) GOTO 331 + ELSE + IF(DIST.GE.RAUX(V0(I))) GOTO 331 + IF(DIST.LE.RAUX(V0(I)-1)) GOTO 331 + ENDIF + ENDIF + ENDIF + TT0=ABS(T0(I)-TTHYP) + IF(TT0.LE.EPS1) THEN + ISEC=IAUX + TT1=ABS(T0(I-1)-TTHYP) + JVOUT2=IAUX+1 + IF(TT1.LE.EPS1) THEN + IF(TT1.LT.TT0) THEN + ISEC=IAUX+1 + JVOUT2=0 + JVOUT1=IAUX + IF(JVOUT1.GT.ISV) JVOUT1=JVOUT1-ISV + ENDIF + ENDIF + IF(JVOUT2.GT.ISV) JVOUT2=JVOUT2-ISV + ELSE + ISEC=IAUX+1 + ENDIF + ENDIF + ENDIF + ELSEIF(YPH.LT.YPF) THEN + IF(YPH2.LT.YPF) THEN + ISEC=IAUX + ELSE + IF(MOD(ISV,IAUX).EQ.0) THEN + IF(ISV/IAUX.NE.4) THEN + JAUX=IAUX + IF(IAUX.GT.JSV)JAUX=IAUX-JSV + TGA=TAN(FLOAT(JAUX)*ANG2) + TTHYP=(-X*TGA+Y-Y0)/(COS2-COS1*TGA) + ELSE + TTHYP=X*COS1I + ENDIF + ELSE + JAUX=IAUX + IF(IAUX.GT.JSV)JAUX=IAUX-JSV + TGA=TAN(FLOAT(JAUX)*ANG2) + TTHYP=(-X*TGA+Y-Y0)/(COS2-COS1*TGA) + ENDIF + ISEC=IAUX+1 + IF(TTHYP.LT.T0MAX) THEN + IF(LGPASS) THEN + IF(NCYL(ICELL).GT.1) THEN + XAUX=X-COS1*TTHYP + YAUX=Y-COS2*TTHYP-Y0 + DIST=XAUX*XAUX+YAUX*YAUX + ISEC=IAUX+1 + IF(V0(I).GT.NCYL(ICELL)) THEN + IF(DIST.LE.RAUX(NCYL(ICELL))) GOTO 331 + ELSEIF(V0(I).EQ.1) THEN + IF(DIST.GE.RAUX(1)) GOTO 331 + ELSE + IF(DIST.GE.RAUX(V0(I))) GOTO 331 + IF(DIST.LE.RAUX(V0(I)-1)) GOTO 331 + ENDIF + ENDIF + ENDIF + TT0=ABS(T0(I)-TTHYP) + IF(TT0.LE.EPS1) THEN + ISEC=IAUX+1 + TT1=ABS(T0(I-1)-TTHYP) + JVOUT2=IAUX + IF(TT1.LE.EPS1) THEN + IF(TT1.LE.TT0) THEN + ISEC=IAUX + JVOUT2=0 + JVOUT1=IAUX+1 + IF(JVOUT1.GT.ISV) JVOUT1=JVOUT1-ISV + ENDIF + ENDIF + IF(JVOUT2.GT.ISV) JVOUT2=JVOUT2-ISV + ELSE + ISEC=IAUX + ENDIF + ENDIF + ENDIF + ELSE + ISEC=IAUX + IF(YPH2.GT.YPF) ISEC=IAUX+1 + ENDIF + ENDIF + 331 CONTINUE + IF(ISEC.GT.ISV)ISEC=ISEC-ISV + GOTO 232 + ELSEIF(PENTE.LT.ATAN1) THEN + ISEC=IS1 + IAUX=IS1-1 + IF(IAUX.EQ.0)IAUX=ISV + IF(MOD(ISV,IAUX).EQ.0) THEN + IF(ISV/IAUX.NE.4) THEN + JAUX=IAUX + IF(IAUX.GT.JSV)JAUX=IAUX-JSV + TGA=TAN(FLOAT(JAUX)*ANG2) + TTHYP0=(-X*TGA+Y-Y0)/(COS2-COS1*TGA) + ELSE + TTHYP0=X*COS1I + ENDIF + ELSE + JAUX=IAUX + IF(IAUX.GT.JSV)JAUX=IAUX-JSV + TGA=TAN(FLOAT(JAUX)*ANG2) + TTHYP0=(-X*TGA+Y-Y0)/(COS2-COS1*TGA) + ENDIF + IF(ABS(T0(I)-TTHYP0).LE.EPS1) THEN + IF(IAUX.EQ.JSV) THEN + SINR=0. + COSR=-1. + ELSEIF(IAUX.EQ.ISV) THEN + SINR=0. + COSR=1. + ELSE + SINR=SIN(FLOAT(IAUX)*ANG1) + COSR=COS(FLOAT(IAUX)*ANG1) + ENDIF + IF(K.EQ.1) THEN + YPH2=-(COS1*T0(KUP)-X)*SINR+(COS2*T0(KUP)+Y0-Y)*COSR + ELSE + YPH2=-(COS1*T0(KDOWN)-X)*SINR+(COS2*T0(KDOWN)+Y0-Y)*COSR + ENDIF + IF(YPH2.LE.0.)ISEC=IS1-1 + GOTO 232 + ENDIF + IAUX=IS1 + IF(MOD(ISV,IAUX).EQ.0) THEN + IF(ISV/IAUX.NE.4) THEN + JAUX=IAUX + IF(IAUX.GT.JSV)JAUX=IAUX-JSV + TGA=TAN(FLOAT(JAUX)*ANG2) + TTHYP1=(-X*TGA+Y-Y0)/(COS2-COS1*TGA) + ELSE + TTHYP1=X*COS1I + ENDIF + ELSE + JAUX=IAUX + IF(IAUX.GT.JSV)JAUX=IAUX-JSV + TGA=TAN(FLOAT(JAUX)*ANG2) + TTHYP1=(-X*TGA+Y-Y0)/(COS2-COS1*TGA) + ENDIF + IF(ABS(T0(I)-TTHYP1).LE.EPS1) THEN + IF(IAUX.EQ.JSV) THEN + SINR=0. + COSR=-1. + ELSEIF(IAUX.EQ.ISV) THEN + SINR=0. + COSR=1. + ELSE + SINR=SIN(FLOAT(IAUX)*ANG1) + COSR=COS(FLOAT(IAUX)*ANG1) + ENDIF + IF(K.EQ.1) THEN + YPH2=-(COS1*T0(KUP)-X)*SINR+(COS2*T0(KUP)+Y0-Y)*COSR + ELSE + YPH2=-(COS1*T0(KDOWN)-X)*SINR+(COS2*T0(KDOWN)+Y0-Y)*COSR + ENDIF + IF(YPH2.GT.0.)ISEC=IS1+1 + IF(ISEC.GT.ISV)ISEC=ISEC-ISV + GOTO 232 + ENDIF + GOTO 232 + ENDIF + ATAN0=ATAN1 + DEL0=DEL1 + 231 CONTINUE + CALL XABORT('TRKHEX: ALGORITHME FAILURE -D') + 232 CONTINUE + ELSE + ISEC=1 + ENDIF + VSEC(K)=IVS+ISEC + IF(JVOUT1.NE.0) THEN + IVSEC1=IVS+JVOUT1 + JVOUT1=0 + ENDIF + IF(JVOUT2.NE.0) THEN + IVSEC2=IVS+JVOUT2 + JVOUT2=0 + ENDIF + 125 CONTINUE + KMAX=K + JCC0=IFV +* +* CAS OU IL N'Y A PAS D'INTERSECTION AVEC LES SECTEURS +* + IF(KMAX.EQ.2) THEN + IF(VSEC(1).EQ.VSEC(KMAX)) GOTO 527 + ENDIF +* + DO 227 JC=IV01,IV02 + JCC=JCC0+JC + IF(NSECT(JCC).GT.1) THEN +* +* INTERSECTION DE LA DIRECTION AVEC LES SECTEURS +* + JSEC=3*(NSECT(JCC)-1) + JSEC2=JSEC+JSEC + ANG0=PI/FLOAT(JSEC) + IVS0=VSEC(1) + IVS1=VSEC(1)-1 + IF(IVS1.EQ.0)IVS1=JSEC + DO 225 J=1,JSEC + IF(MOD(JSEC,J).EQ.0) THEN + IF(JSEC/J.NE.2) THEN + TGA=TAN(FLOAT(J)*ANG0) + THYP=(-X*TGA+Y-Y0)/(COS2-COS1*TGA) + ELSE + THYP=X*COS1I + ENDIF + ELSE + TGA=TAN(FLOAT(J)*ANG0) + THYP=(-X*TGA+Y-Y0)/(COS2-COS1*TGA) + ENDIF + IF(THYP.LE.T0MIN.OR.THYP.GE.T0MAX) GOTO 223 +* +* LES PARCOURS NULS AU CENTRE DE LA CELLULE NE SONT PAS ELEMINES +* +* IF(LGDIM) THEN + IZ0=1 + IF(IFACE1.EQ.7) THEN + IF(ABS(THYP-T0MIN).LE.EPS1) GOTO 223 + IZ0=2 + ENDIF + IF(ABS(THYP-T0MAX).LE.EPS1) GOTO 223 + DO 171 IZZ=IZ0,KMAX-1 + IF(ABS(THYP-TSEC(IZZ)).LE.EPS1) THEN + IF(JC.EQ.1) THEN + IF(J.EQ.IVS0.OR.J.EQ.IVS1) THEN + IF(VSEC(1).NE.VSEC(2)) GOTO 114 + ENDIF + ENDIF + GOTO 223 + ENDIF + 171 CONTINUE + 114 CONTINUE +* +* CE TESTE EST NECESSAIRE SI TOUTES LES ZONES NE SONT PAS SECTORISEES +* ON SUPPOSE ICI QU'ON A AFFAIRE A DES CYLINDRES CONCENTRIQUES +* + IF(NCYL(ICELL).GT.1) THEN + XAUX=X-COS1*THYP + YAUX=Y-COS2*THYP-Y0 + DIST=XAUX*XAUX+YAUX*YAUX + IF(JC.GT.NCYL(ICELL)) THEN + IF(DIST.LE.RAUX(NCYL(ICELL))) THEN + IF(KMAX.EQ.2) THEN + IF(ABS(DIST-RAUX(NCYL(ICELL))).GT.EPS5) THEN + IF(VSEC(1).EQ.VSEC(2)) GOTO 223 + ENDIF + ELSE + GOTO 223 + ENDIF + ENDIF + ELSEIF(JC.EQ.1) THEN + IF(DIST.GE.RAUX(1)) GOTO 223 + ELSE + IF(DIST.GE.RAUX(JC)) GOTO 223 + IF(DIST.LE.RAUX(JC-1)) GOTO 223 + ENDIF + ENDIF + LMIN=2 + LMAX=KMAX + LSTEP=1 + LL=0 + L0=2 + IF(COS3.LT.0.) THEN + LMAX=1 + LMIN=KMAX-1 + LSTEP=-1 + LL=1 + L0=1 + ENDIF + DO 220 K=LMIN,LMAX,LSTEP + IF(THYP.LT.TSEC(K)) THEN + IF(K.EQ.L0)THEN + IF(VSEC(1).EQ.VSEC(2)) GOTO 223 + ENDIF + DO 241 L=KMAX,K+LL,-1 + TSEC(L+1)=TSEC(L) + VSEC(L+1)=VSEC(L) + 241 CONTINUE + TSEC(K+LL)=THYP + KMAX=KMAX+1 + IZONE=1 + DO 210 N=KDOWN,KUP + IF(THYP.LE.T0(N)) THEN + IZONE=V0(N) + GO TO 211 + ENDIF + 210 CONTINUE + CALL XABORT('TRKHEX: IMPOSSIBLE CASE ') + 211 XT=COS1*THYP + YT=COS2*THYP+Y0 +* +* TRAITEMENT DU PROBLEME DU CENTRE DE LA CELLULE SECTORISEE +* + IF(JC.EQ.1) THEN + IF(ABS(XT-X).LE.EPS1.AND.ABS(YT-Y).LE.EPS1) THEN + IF(K.EQ.2) THEN + VSEC(2)=VSEC(1) + GOTO 224 + ENDIF + XT=COS1*T0MIN + YT=COS2*T0MIN+Y0 + IF(ABS(XT-X).LE.EPS1.AND.ABS(YT-Y).LE.EPS1) THEN + CALL XABORT('TRKHEX: TRACK PARALLEL TO OZ 2') + ENDIF + ENDIF + ENDIF +* + IAUX=J + IF(J.EQ.JSEC) THEN + SINR=0. + COSR=-1. + IF(XT.GT.X) THEN + IAUX=JSEC2 + COSR=1. + ENDIF + ELSE + IF(YT.LT.Y) IAUX=J+JSEC + SINR=SIN(IAUX*ANG0) + COSR=COS(IAUX*ANG0) + ENDIF + YRH=0. + YRF=-(XDR(IFACE2)-X)*SINR+(YDR(IFACE2)-Y)*COSR + IF(YRF.GT.YRH)THEN + ISECTR=IAUX + ELSE + ISECTR=IAUX+1 + ENDIF + IF(ISECTR.GT.JSEC2)ISECTR=ISECTR-JSEC2 + ISS=0 + DO 240 ISC=1,IZONE-1 + IF(NSECT(IFV+ISC).GT.1) THEN + ISS=ISS+6*(NSECT(IFV+ISC)-1) + ELSE + ISS=ISS+1 + ENDIF + 240 CONTINUE + IVAUX=ISS+ISECTR + VSEC(K+LL)=IVAUX + GOTO 223 + ENDIF + 220 CONTINUE + 223 CONTINUE + 225 CONTINUE + ENDIF + 224 CONTINUE + 227 CONTINUE + 527 CONTINUE + IF(VSEC(1).NE.VSEC(2)) THEN + IF(ABS(TSEC(1)-TSEC(2)).LE.EPS1) THEN + IF(VSEC(1).EQ.VSEC(3))THEN + DO 528 ISSX=2,KMAX-1 + VSEC(ISSX)=VSEC(ISSX+1) + TSEC(ISSX)=TSEC(ISSX+1) + 528 CONTINUE + KMAX=KMAX-1 + GOTO 529 + ENDIF + ENDIF + ENDIF + 529 CONTINUE +* +* CALCUL DES VOLUMES DE SORTIES +* + LSV=NVOL(ICELL)-1 + DO 228 JS=1,NCYL(ICELL)+1 + IF(NSECT(IFV+JS).GT.1) THEN + LSV=LSV+6*(NSECT(IFV+JS)-1) + ELSE + LSV=LSV+1 + ENDIF + 228 CONTINUE + IFV=NVOL(ICELL)-1 +* +* PARCOURS OPTIQUES ET VOLUMES ASSOCIES +* + IF(DIRUP) THEN + I1=1 + I2=KMAX-1 + I3=1 + KPOP=IPOP+1 + ELSE + I2=1 + I1=KMAX-1 + I3=-1 + KPOP=IPOP+KMAX-1 + ENDIF + DO 230 I=I1,I2,I3 + IPOP=IPOP+1 + POP(IPOP)=ABS(TSEC(I+1)-TSEC(I)) + IVOL=VSEC(I+1)+IFV + IF(IVOL.GT.LSV) IVOL=IVOL-LSV+FVOL(ICELL)-1 + MAT(IPOP)=IVOL + 230 CONTINUE + IMAT2=MAT(IPOP) + 739 CONTINUE + IF(START) THEN + IFDOWN=IFACE1 + ICDOWN=ICELL + IMATD=MAT(KPOP) + KFACED=KFACE1 + KCELD=KCEL1 + LGOUTD=LGOUT1 + MFACD=MFAC1 + MFACU=MFAC2 + IFACEU=IFACE2 + KPLD=KPL + DO 229 IXX=1,MFACD + FACEMD(IXX)=FACEM1(IXX) + 229 CONTINUE + DO 329 IXX=1,MFACU + FACEMU(IXX)=FACEM2(IXX) + 329 CONTINUE + ENDIF +* +* RECHERCHE DES PROCHAINS VOLUMES A TRACKER +* + IF(DIRUP) THEN + START=.FALSE. + IVOUT=ICELL + IMAT=IMAT2 + IF(IFACE2.LE.6) THEN + ICELLX=ICELL + IF(ICELL.LE.STAIRS(1)) THEN + ICELL=VOISIN(IFACE2,ICELL) + IF(ICELL.GT.NCEL2) THEN + IFACE=IFACE2 + GOTO 35 + ENDIF + GOTO 31 + ENDIF + KPL=INT(AINT(REAL(ICELL)/REAL(STAIRS(1)))) + IF(MOD(ICELL,STAIRS(1)).NE.0)KPL=KPL+1 + ICELL2=ICELL-STAIRS(KPL-1) + ICELLX=ICELL2 + ICELL2=VOISIN(IFACE2,ICELL2) + IF(ICELL2.GT.NCEL2) THEN + IFACE=IFACE2 + GOTO 35 + ENDIF + ICELL=STAIRS(KPL-1)+ICELL2 + ELSE + ICELLX=ICELL + IF(.NOT.LGPG1) THEN + IFACE=IFACE2 + GOTO 35 + ENDIF + IF(ICELL.LE.STAIRS(1)) THEN + ICELL=ICELL+STAIRS(1) + GOTO 31 + ENDIF + KPL=INT(AINT(REAL(ICELL)/REAL(STAIRS(1)))) + IF(MOD(ICELL,STAIRS(1)).NE.0)KPL=KPL+1 + ICELLX=ICELL-STAIRS(KPL-1) + ICELL=ICELLX+STAIRS(KPL) + ENDIF + 31 IF(ICELL.GT.NCEL) THEN + IFACE=IFACE2 + GOTO 35 + ENDIF + KPER=KPER+1 + MAT2(KPER)=ICELL + IF(KPER-1.GE.3) THEN + IF(MAT2(KPER-1).EQ.ICELL) THEN + GOTO 631 + ELSEIF(MAT2(KPER-2).EQ.ICELL) THEN + GOTO 631 + ELSEIF(MAT2(KPER-3).EQ.ICELL) THEN + GOTO 631 + ENDIF + GOTO 632 + 631 CONTINUE + IF(LGPAS0) GOTO 56 + ISURC=1 + IETAG=0 + ISURM=6 + SURC(1)=1 + SURC(2)=2 + SURC(3)=3 + SURC(4)=4 + SURC(5)=5 + SURC(6)=6 + IF(LGDIM) THEN + IF(ICELL.LT.STAIRS(1)) THEN + IVOLC=ICELL + I=VOISIN(1,IVOLC) + ELSE + KPL=INT(AINT(REAL(ICELL)/REAL(STAIRS(1)))) + IF(MOD(ICELL,STAIRS(1)).NE.0)KPL=KPL+1 + IVOLC=ICELL-STAIRS(KPL-1) + IF(KPL.GT.2) THEN + IETAG=STAIRS(KPL-2) + ENDIF + I=VOISIN(1,IVOLC) + ENDIF + ELSE + IVOLC=ICELL + I=VOISIN(1,IVOLC) + ENDIF + LGPAS0=.TRUE. + IF(I.GT.NCEL2) THEN + I=NCEL+10 + GOTO 56 + ENDIF + I=I+IETAG + LGPER=.TRUE. + GOTO 42 + ENDIF + 632 CONTINUE + X=REMESH(ICELL) + Y=REMESH(NCEL+ICELL) + LGPAS0=.FALSE. + GOTO 10 + ENDIF +* + 30 IVOUT=ICELL + IMAT=IMATD + START=.TRUE. + IF(IFDOWN.LE.6) THEN + IF(ICELL.LE.STAIRS(1)) THEN + ICELLD=ICELL + ICELL=VOISIN(IFDOWN,ICELL) + IF(ICELL.GT.NCEL2) THEN + IFACE=IFDOWN + IVOUT2=IVOUT + LGSTOR=.TRUE. + GOTO 34 + ENDIF + GOTO 33 + ENDIF + KPL=INT(AINT(REAL(ICELL)/REAL(STAIRS(1)))) + IF(MOD(ICELL,STAIRS(1)).NE.0) KPL=KPL+1 + ICELL2=ICELL-STAIRS(KPL-1) + ICELLD=ICELL2 + ICELL2=VOISIN(IFDOWN,ICELL2) + IF(ICELL2.GT.NCEL2) THEN + IFACE=IFDOWN + IVOUT2=IVOUT + LGSTOR=.TRUE. + GOTO 34 + ENDIF + ICELL=STAIRS(KPL-1)+ICELL2 + GOTO 33 + ELSE + ICELLD=ICELL + IF(ICELL.LE.STAIRS(1)) THEN + IFACE=IFDOWN + IVOUT2=IVOUT + LGSTOR=.TRUE. + GOTO 34 + ENDIF + KPL=INT(AINT(REAL(ICELL)/REAL(STAIRS(1)))) + IF(MOD(ICELL,STAIRS(1)).NE.0) KPL=KPL+1 + ICELL=ICELL-STAIRS(KPL-1) + ICELLD=ICELL + IF(KPL.GT.2)ICELL=ICELL+STAIRS(KPL-2) + ENDIF + 33 IF(ICELL.GT.NCEL) THEN + IFACE=IFDOWN + IVOUT2=IVOUT + LGSTOR=.TRUE. + GOTO 35 + ENDIF + KPER=KPER+1 + MAT2(KPER)=ICELL + IF(KPER-1.GE.3) THEN + IF(MAT2(KPER-1).EQ.ICELL) THEN + GOTO 635 + ELSEIF(MAT2(KPER-2).EQ.ICELL) THEN + GOTO 635 + ELSEIF(MAT2(KPER-3).EQ.ICELL) THEN + GOTO 635 + ENDIF + GOTO 637 + 635 CONTINUE + IF(LGPAS0) GOTO 56 + ISURC=1 + IETAG=0 + ISURM=6 + SURC(1)=1 + SURC(2)=2 + SURC(3)=3 + SURC(4)=4 + SURC(5)=5 + SURC(6)=6 + IF(LGDIM) THEN + IF(ICELL.LT.STAIRS(1)) THEN + IVOLC=ICELL + I=VOISIN(1,IVOLC) + ELSE + KPC=INT(AINT(REAL(ICELL)/REAL(STAIRS(1)))) + IF(MOD(ICELL,STAIRS(1)).NE.0)KPC=KPC+1 + IVOLC=ICELL-STAIRS(KPC-1) + IF(KPC.EQ.IPLANZ) THEN + IETAG=STAIRS(KPC-1) + ELSE + IETAG=STAIRS(KPC) + ENDIF + I=VOISIN(1,IVOLC) + ENDIF + ELSE + IVOLC=ICELL + I=VOISIN(1,IVOLC) + ENDIF + LGPAS0=.TRUE. + IF(I.GT.NCEL2) THEN + I=NCEL+10 + GOTO 56 + ENDIF + I=I+IETAG + LGPER=.TRUE. + GOTO 42 + ENDIF + 637 IF(ICELL+NCEL.GT.MESH) + > CALL XABORT('TRKHEX: ALGORITHME FAILURE -E') + X=REMESH(ICELL) + Y=REMESH(NCEL+ICELL) + LGDIR=.FALSE. + LGPAS0=.FALSE. + GOTO 10 +* + 34 CONTINUE +* +* RECHERCHE DE LA FACE DE SORTIE +* + 35 CONTINUE + IMAT0=IMAT + NFAC=1 + NFXX=1 +* + IF(LGMAT3) THEN + DO 666 IAC=1,KPER3 + KPER=KPER+1 + MAT2(KPER)=MAT3(IAC) + 666 CONTINUE + ENDIF + LGMAT3=.FALSE. + KPER3=0 + PASSD=.FALSE. + PASSU=.FALSE. + IF(DIRUP) THEN + IYY=0 + IF(LGFAC) THEN + DO 335 IXX=1,MFAC2 + IF(FACEM2(IXX).LE.6) THEN + ICXX=VOISIN(FACEM2(IXX),ICELLX) + IF(ICXX.GT.NCEL2) THEN + IYY=IYY+1 + FACES(IYY)=FACEM2(IXX) + ENDIF + ELSE + IF(LGPG1) THEN + IF(IVOUT.LE.STAIRS(IPLANZ-1)) THEN + PASSU=.TRUE. + GOTO 435 + ENDIF + ENDIF + IYY=IYY+1 + FACES(IYY)=FACEM2(IXX) + ENDIF + 435 CONTINUE + 335 CONTINUE + ENDIF + NFACX=IYY+1 + ELSE + IYY=0 + DO 336 IXX=1,MFACD + IF(FACEMD(IXX).LE.6) THEN + ICXX=VOISIN(FACEMD(IXX),ICELLD) + IF(ICXX.GT.NCEL2) THEN + IYY=IYY+1 + FACES(IYY)=FACEMD(IXX) + ENDIF + ELSE + IF(IVOUT.LE.STAIRS(1))THEN + IYY=IYY+1 + FACES(IYY)=FACEMD(IXX) + PASSD=.TRUE. + ENDIF + ENDIF + 336 CONTINUE + NFACX=IYY+1 +* + ENDIF + ISURF1=0 + ISURF2=0 + IF(IVOUT.LE.STAIRS(1)) THEN + ISTAIR=0 + IFACST=-1 + IF(LGDIM) THEN + ISS=0 + DO 300 IW=0,NCYL(NCEL2) + IF(NSECT(FVOL(NCEL2)+IW).GT.1)THEN + ISS=6*(NSECT(FVOL(NCEL2)+IW)-1)+ISS + ELSE + ISS=1+ISS + ENDIF + 300 CONTINUE + IFACST=FACB(NCEL2)+ISS-1 + ENDIF + IMAX=1 + GOTO 37 + ENDIF + I=INT(AINT(REAL(IVOUT)/REAL(STAIRS(1)))) + IF(MOD(IVOUT,STAIRS(1)).NE.0)I=I+1 + ISTAIR=STAIRS(I-1) + IFACST=FACST(I-1)-1 + IMAX=I + 37 KFACE=IVOUT-IFONC(NCOUR,0)-ISTAIR + IMAT=IMAT0 + IFOUT2=2*KFACE+2+IFACST + IF(IFACE.EQ.7) THEN + IMAM=1 + IF(LPOP.NE.IPOP)IMAM=IPOP + IFOUT2=MAT(IMAM) + ELSEIF(IFACE.EQ.8) THEN + IPP=IVOUT + IF(LGPG1)IPP=IVOUT-STAIRS(IPLANZ-1) + IFOUT2=FACB(NCEL2+IPP)+VSEC(KMAX) + ELSE + IF(NCOUR.EQ.1) THEN + IFOUT2=IFACE + IF(LGDIM)IFOUT2=IFOUT2+IFACST+1 + ELSEIF(IVOUT.LE.(IFONC(NCOUR,1)+ISTAIR)) THEN + IF(IFACE.EQ.2) THEN + IFOUT2=IFOUT2+1 + ELSEIF(IFACE.EQ.6) THEN + IFOUT2=FACST(IMAX) + ELSEIF(IFACE.EQ.3) THEN + IFOUT2=IFOUT2+2 + ENDIF + ELSEIF(IVOUT.LE.(IFONC(NCOUR,2)+ISTAIR)) THEN + IFOUT2=2*KFACE+3+IFACST + IF(IFACE.EQ.3) THEN + IFOUT2=IFOUT2+1 + ELSEIF(IFACE.EQ.4) THEN + IFOUT2=IFOUT2+2 + ENDIF + ELSEIF(IVOUT.LE.(IFONC(NCOUR,3)+ISTAIR)) THEN + IFOUT2=2*KFACE+4+IFACST + IF(IFACE.EQ.4) THEN + IFOUT2=IFOUT2+1 + ELSEIF(IFACE.EQ.5) THEN + IFOUT2=IFOUT2+2 + ENDIF + ELSEIF(IVOUT.LE.(IFONC(NCOUR,4)+ISTAIR)) THEN + IFOUT2=2*KFACE+5+IFACST + IF(IFACE.EQ.5) THEN + IFOUT2=IFOUT2+1 + ELSEIF(IFACE.EQ.6) THEN + IFOUT2=IFOUT2+2 + ENDIF + ELSEIF(IVOUT.LE.(IFONC(NCOUR,5)+ISTAIR)) THEN + IFOUT2=2*KFACE+6+IFACST + IF(IFACE.EQ.6) THEN + IFOUT2=IFOUT2+1 + ELSEIF(IFACE.EQ.1) THEN + IFOUT2=IFOUT2+2 + ENDIF + ELSEIF(IVOUT.LE.STAIRS(IMAX)) THEN + IFOUT2=2*KFACE+7+IFACST + IF(IFACE.EQ.1)IFOUT2=IFOUT2+1 + ELSE + CALL XABORT('TRKHEX: ALGORITHME FAILURE -F') + ENDIF +* +* PRISE EN COMPTE DES SECTEURS +* + KSECT=NSECT(FVOL(IVOUT)+NCYL(IVOUT)) + IF(KSECT.GT.2) THEN + IXY=0 + DO 371 IXX=0,NCYL(IVOUT)-1 + IF(NSECT(FVOL(IVOUT)+IXX).GT.1) THEN + IXY=IXY+6*(NSECT(FVOL(IVOUT)+IXX)-1) + ELSE + IXY=IXY+1 + ENDIF + 371 CONTINUE + JMIN=(IFACE-1)*(KSECT-1)+IXY+NVOL(IVOUT)-1 + JMAX=KSECT-1+JMIN + IF(IMAT.GT.JMAX) THEN + IF(IFACE.EQ.1) THEN + IMAT=NVOL(IVOUT)+IXY + ELSE + IMAT=IMAT-1 + ENDIF + ELSEIF(IMAT.LE.JMIN) THEN + IF(IFACE.EQ.6) THEN + IMAT=NVOL(IVOUT)+IXY-1+6*(KSECT-1) + ELSE + IMAT=IMAT+1 + ENDIF + ENDIF + IMAT=IMAT-(IFACE-1)*(KSECT-1)-IXY-NVOL(IVOUT)+1 + IFOUT2=SURB(IFOUT2)+IMAT + ELSEIF(SECTOR) THEN + IFOUT2=SURB(IFOUT2)+1 + ENDIF + ENDIF +*------ DISTRIBUTION DES NEUTRONS SUR DES FACES DES PLANS SUPERIEURS +* OU INFERIEURS AUTRE QUE LE PLAN CONSIDERE + IF(LGPG1) THEN + IF(DIRUP) THEN + IF(PASSU) THEN + IF(IVOUT.LE.STAIRS(1)) THEN + LFOUT2=FACST(1)+IFOUT2-STAIRS(1) + LVOUT=STAIRS(1)+IVOUT + GOTO 477 + ELSEIF(IVOUT.LE.STAIRS(IPLANZ-1)) THEN + LFOUT2=FACST(IMAX)+IFOUT2-FACST(IMAX-1) + LVOUT=STAIRS(IMAX)+IVOUT-STAIRS(IMAX-1) + GOTO 477 + ENDIF + ENDIF + GOTO 478 + ELSE + IF(PASSD) THEN + IF(IVOUT.GT.STAIRS(1)) THEN + IF(IVOUT.GT.STAIRS(2)) THEN + LFOUT2=IFOUT2-FACST(IMAX-1)+FACST(IMAX-2) + LVOUT=IVOUT-STAIRS(IMAX-1)+STAIRS(IMAX-2) + GOTO 477 + ELSE + LFOUT2=IFOUT2-FACST(1)+STAIRS(1) + LVOUT=IVOUT-STAIRS(1) + GOTO 477 + ENDIF + ENDIF + ENDIF + GOTO 478 + ENDIF + 477 IF(SECTOR) THEN + MSECT=NSECT(FVOL(LVOUT)+NCYL(LVOUT)) + IF(MSECT.EQ.KSECT) THEN + LFOUT2=SURB(LFOUT2)+IMAT + ELSEIF(MSECT.LT.KSECT) THEN + LFOUT2=SURB(LFOUT2)+NINT(REAL(MSECT*IMAT)/REAL(KSECT)) + ELSE + KFXX=NINT(REAL(MSECT*IMAT)/REAL(KSECT)) + IF(KFXX.EQ.1) THEN + LFOUT2=SURB(LFOUT2)+1 + SURFX(NFXX)=LFOUT2+1 + NFXX=NFXX+1 + ELSEIF(KFXX.EQ.MSECT)THEN + LFOUT2=SURB(LFOUT2)+KFXX + SURFX(NFXX)=LFOUT2-1 + NFXX=NFXX+1 + ELSE + LFOUT2=SURB(LFOUT2)+KFXX + SURFX(NFXX)=LFOUT2-1 + SURFX(NFXX+1)=LFOUT2+1 + NFXX=NFXX+2 + ENDIF + ENDIF + SURFX(NFXX)=LFOUT2 + NFXX=NFXX+1 + ENDIF + ENDIF +* + 478 SURFX(NFXX)=IFOUT2 + NFXX=NFXX+1 + NFAC=NFAC+1 + IF(NFAC.LE.NFACX) THEN + IFACE=FACES(NFAC-1) + GOTO 37 + ENDIF +* + IF(DIRUP) THEN + IFOUT1=IFOUT2 + IVOUT1=IVOUT + DIRUP=.FALSE. + ICELL=ICDOWN + ICELL0=ICELL + KPL=INT(AINT(REAL(ICELL)/REAL(STAIRS(1)))) + IF(MOD(ICELL,STAIRS(1)).NE.0) KPL=KPL+1 + LGDIR=.TRUE. + LPOP=IPOP + NSURF1=NFXX-1 + DO 377 IXX=1,NSURF1 + SURF1(IXX)=SURFX(IXX) + IF(SURF1(IXX).GT.NSOUT) CALL XABORT('TRKHEX: SURF1 OVERFLOW.') + 377 CONTINUE + GOTO 30 + ELSE + NSURF2=NFAC-1 + DO 378 IXX=1,NSURF2 + SURF2(IXX)=SURFX(IXX) + IF(SURF2(IXX).GT.NSOUT) CALL XABORT('TRKHEX: SURF2 OVERFLOW.') + 378 CONTINUE + ENDIF +* + IF(LGSTOR) THEN + IF(LGDIR) THEN + KOUT=IVOUT1 + IVOUT1=IVOUT + IVOUT=KOUT + LGDIR=.FALSE. + ENDIF + GOTO 38 + ENDIF +* +* STOCKAGE DES PARCOURS OPTIQUES +* + 38 CONTINUE + WEIGHT=ABS(COS1)*POIDS + AUX1=1./DBLE(NSURF) + ISXX=0 + DO 439 ISS=NSURF1+1,NSURF + ISXX=ISXX+1 + IF(ISXX.GT.NSURF1)ISXX=1 + SURF1(ISS)=SURF1(ISXX) + 439 CONTINUE + ISXX=0 + DO 442 ISS=NSURF2+1,NSURF + ISXX=ISXX+1 + IF(ISXX.GT.NSURF2)ISXX=1 + SURF2(ISS)=SURF2(ISXX) + 442 CONTINUE + IF(IPRT .GE. 500) THEN + WRITE(IOUT,6000) ILINE,WEIGHT,IPOP,Y0,Z0,-SURF1(NSURF), + > -SURF2(NSURF) + WRITE(IOUT,6001) (MAT(K),POP(K),K=LPOP,1,-1), + > (MAT(K),POP(K),K=LPOP+1,IPOP) + ENDIF + WRITE(IFILE) 1,IPOP+NSURF+NSURF,WEIGHT,IANGL, + + (-SURF1(KS),KS=1,NSURF),(MAT(K),K=LPOP,1,-1), + + (MAT(K),K=LPOP+1,IPOP),(-SURF2(KS),KS=1,NSURF), + + (AUX1,KS=1,NSURF),(POP(K),K=LPOP,1,-1), + + (POP(K),K=LPOP+1,IPOP),(AUX1,KS=1,NSURF) +* +* INITIALIZATION +* + DO 383 IS=1,5 + FACEM(IS)=0 + SURF1(IS)=0 + SURF2(IS)=0 + 383 CONTINUE +* + 384 CONTINUE + Y0=Y00 + Z0=Z00 +* +* POSSIBILITE DE LA CONTINUITE DE LA TRACK SUR D'AUTRES VOLUMES +* APRES AVOIR INTERSECTEE UN VOLUME PERIPHERIQUE +* + LGPER=.FALSE. + IF(NCEL.GT.1) THEN + LGPER=.TRUE. +* +*-- RECHERCHE DES CELLULES DANS CORN OU LA TRACK PEUT ABOUTIR +* + IX=1 + I=CORN(IX) + LGDEB=.TRUE. + GO TO 401 + ENDIF +* +* DEPLACEMENT HORIZENTAL PUIS VERTICAL DANS LE PLAN YOZ +* + 40 Y0=Y0+PASY + + ILINE=ILINE+1 + LGOUT1=.FALSE. + LGOUTD=.FALSE. + LGOUTU=.FALSE. + LGDEB=.TRUE. + LGPAS0=.FALSE. + IF(Y0.GT.Y0MAX) GOTO 53 + IF(LGDIM) THEN + 711 SSQ=R2AZ-SCOS1*Y0*Y0 + IF(SSQ.GT.0.) THEN + SSS=SQRT(SSQ) + Y0COS=Y0*COS2 + XZTMAX=Z0+(SSS-Y0COS)*COAZ + XZTMIN=Z0+(-SSS-Y0COS)*COAZ + ZTMIN=MIN(XZTMAX,XZTMIN) + ZTMAX=MAX(XZTMAX,XZTMIN) + IF(ZTMAX.LT.ZMIN) THEN + Y0=Y0+PASY + ILINE=ILINE+1 + IF(Y0.GT.Y0MAX) GOTO 53 + GOTO 711 + ELSEIF(ZTMIN.GT.ZMAX) THEN + Y0=Y0+PASY + ILINE=ILINE+1 + IF(Y0.GT.Y0MAX) GOTO 53 + GOTO 711 + ENDIF + ENDIF + ENDIF +*CC I=1 + IX=1 + I=CORN(1) + KPER=0 + 401 Y00=Y0 + IPOP=0 + START=.TRUE. + DIRUP= .TRUE. + LGPAS0=.FALSE. +* +* RECHERCHE DE LA PREMIERE CELLULE INTERSECTEE +* + 42 CONTINUE + 50 CONTINUE + IF(LGPER) THEN + DO 421 IP=1,KPER + IF(I.EQ.MAT2(IP))GOTO 56 + 421 CONTINUE + ENDIF + X=REMESH(I) + Y=REMESH(NCEL+I) + IF(LGDIM) THEN + Z2=REMESH(NCELZ+I) + Z1=0. + IF(LGPG1) THEN + IF(I.GT.STAIRS(1))THEN + KPL=INT(AINT(REAL(I)/REAL(STAIRS(1)))) + IF(MOD(I,STAIRS(1)).NE.0) KPL=KPL+1 + ICC=I-STAIRS(KPL-1) + IF(KPL.GT.2)ICC=ICC+STAIRS(KPL-2) + Z1=REMESH(NCELZ+ICC) + ENDIF + ENDIF + ENDIF + YY=Y-Y0 + TERM1=SQRT3*(X+A) + TERM2=SQRT3*(X-A) + T(1)=(TERM1+YY)*DIV1 + T(2)=(YY+ACOS6)*COS2I + T(3)=(YY-TERM2)*DIV2 + T(4)=(YY+TERM2)*DIV1 + T(5)=(YY-ACOS6)*COS2I + T(6)=(YY-TERM1)*DIV2 + XDR(1)=COS1*T(1) + YDR(1)=SQRT3*(X-XDR(1)+A)+Y + XDR(2)=COS1*T(2) + YDR(2)=Y+ACOS6 + XDR(3)=COS1*T(3) + YDR(3)=SQRT3*(-X+A+XDR(3))+Y + XDR(4)=COS1*T(4) + YDR(4)=SQRT3*(X-XDR(4)-A)+Y + XDR(5)=COS1*T(5) + YDR(5)=Y-ACOS6 + XDR(6)=COS1*T(6) + YDR(6)=SQRT3*(-X+XDR(6)-A)+Y + IF(LGDIM) THEN + T(7)=(Z1-Z0)/COS3 + T(8)=(Z2-Z0)/COS3 + ZDR(1)=COS3*T(1)+Z0 + ZDR(2)=COS3*T(2)+Z0 + ZDR(3)=COS3*T(3)+Z0 + ZDR(4)=COS3*T(4)+Z0 + ZDR(5)=COS3*T(5)+Z0 + ZDR(6)=COS3*T(6)+Z0 + XDR(7)=COS1*T(7) + YDR(7)=COS2*T(7)+Y0 + ZDR(7)=Z1 + XDR(8)=COS1*T(8) + YDR(8)=COS2*T(8)+Y0 + ZDR(8)=Z2 + ENDIF + DO 45 J=1,LFACE + YDROIT=YDR(J) + XDROIT=XDR(J) + IF(LGDIM) THEN + ZDROIT=ZDR(J) + IF(ZDROIT.LE.Z2.AND.ZDROIT.GE.Z1) GOTO 64 + GOTO 45 + ENDIF + 64 CONTINUE +*---- +* MODIFIED FOR PRECISION ON LINUX +*---- + YT1=YDROIT-YDR(5) + IF(ABS(YT1) .LT. EPST) YT1=0.0D0 + YT2=YDR(2)-YDROIT + IF(ABS(YT2) .LT. EPST) YT2=0.0D0 + YT3=YDROIT-SQRT3*(X-XDROIT-A)-Y + IF(ABS(YT3) .LT. EPST) YT3=0.0D0 + YT4=SQRT3*(-X+XDROIT+A)+Y-YDROIT + IF(ABS(YT4) .LT. EPST) YT4=0.0D0 + YT5=YDROIT+SQRT3*(X-XDROIT+A)-Y + IF(ABS(YT5) .LT. EPST) YT5=0.0D0 + YT6=SQRT3*(X-XDROIT+A)+Y-YDROIT + IF(ABS(YT6) .LT. EPST) YT6=0.0D0 + XT1=XDROIT-X+A + IF(ABS(XT1) .LT. EPST) XT1=0.0D0 + XT2=X+A-XDROIT + IF(ABS(XT2) .LT. EPST) XT2=0.0D0 + XT3=X-A*0.5D0-XDROIT + IF(ABS(XT3) .LT. EPST) XT3=0.0D0 + XT4=XDROIT-X-A*0.5D0 + IF(ABS(XT4) .LT. EPST) XT4=0.0D0 + IF(YT1 .GE. DZ0 .AND. YT2 .GE. DZ0) THEN + IF(XT1 .GE. DZ0 .AND. XT2 .GE. DZ0) THEN + IF(XT3 .GT. DZ0)THEN + IF(YT4 .GE. DZ0 .AND. YT3 .GE. DZ0)THEN + ICELL=I + GOTO 15 + ENDIF + GOTO 45 + ENDIF + IF(XT4 .GT. DZ0)THEN + IF(YT6 .GE. DZ0 .AND. YT5 .GE. DZ0)THEN + ICELL=I + GOTO 15 + ENDIF + GOTO 45 + ENDIF + ICELL=I + GOTO 15 + ENDIF + ENDIF + 45 CONTINUE + 56 CONTINUE + IF(.NOT.LGPAS0) THEN + IX=IX+1 + IF(IX.LE.ICOR) THEN + I=CORN(IX) + GOTO 50 + ENDIF + ELSE + 57 ISURC=ISURC+1 + IF(ISURC.LE.ISURM) THEN + I=VOISIN(SURC(ISURC),IVOLC) + IF(I.GT.NCEL2) GOTO 57 + I=I+IETAG + ICELL0=IVOLC+IETAG + GOTO 50 + ENDIF + IF(LGDIM) THEN + IF(DIRUP) THEN + LGPASU=.TRUE. + IF(IETAG.LT.STAIRS(IPLANZ)) THEN + IETAG=IETAG+STAIRS(1) + ISURC=0 + IF(LGPG1) THEN + I=IVOLC+IETAG + IF(I.LE.NCEL)GOTO 50 + ENDIF + GOTO 57 + ENDIF + IF(LGPASU) THEN + GOTO 384 + ENDIF + ELSE + LGPASD=.TRUE. + IF(IETAG.GT.STAIRS(1)) THEN + IETAG=IETAG-STAIRS(1) + ISURC=0 + IF(LGPG1) THEN + I=IVOLC+IETAG + IF(I.LE.NCEL)GOTO 50 + ENDIF + GOTO 57 + ENDIF + IF(LGPASD) THEN + GOTO 384 + ENDIF + ENDIF + ENDIF + ENDIF + IF(LGPER) THEN + LGPER=.FALSE. + GOTO 40 + ENDIF +* + 58 LGPAS0=.FALSE. + Y0=Y0+PASY + ILINE=ILINE+1 + IF(Y0.GT.Y0MAX) GOTO 53 + IF(LGDIM) THEN + 811 SSQ=R2AZ-SCOS1*Y0*Y0 + IF(SSQ.GT.0.) THEN + SSS=SQRT(SSQ) + Y0COS=Y0*COS2 + XZTMAX=Z0+(SSS-Y0COS)*COAZ + XZTMIN=Z0+(-SSS-Y0COS)*COAZ + ZTMAX=MAX(XZTMAX,XZTMIN) + ZTMIN=MIN(XZTMAX,XZTMIN) + IF(ZTMAX.LT.ZMIN) THEN + Y0=Y0+PASY + ILINE=ILINE+1 + IF(Y0.GT.Y0MAX) GOTO 53 + GOTO 811 + ELSEIF(ZTMIN.GT.ZMAX) THEN + Y0=Y0+PASY + ILINE=ILINE+1 + IF(Y0.GT.Y0MAX) GOTO 53 + GOTO 811 + ENDIF + ENDIF + ENDIF + Y00=Y0 + IX=1 + I=CORN(1) + KPER=0 + LGDEB=.TRUE. + GOTO 42 + 53 IF(LGDIM) THEN + KPER=0 + IPOP=0 + START=.TRUE. + DIRUP= .TRUE. + LGDEB=.TRUE. + LGPAS0=.FALSE. + Z0=Z0+PASZ + Z00=Z0 + IF(Z0.LT.Z0MAX) GOTO 777 + ENDIF + RETURN +*---- +* FORMATS +*---- + 6000 FORMAT(' INTEGRATION LINE ',I10,5X,'WEIGHT =',1P,E15.6,5X, + > 'NUMBER OF SEGMENTS =',I10/ + > ' Y0 = ',E15.6,10X,'Z0 = ',E15.6,5X, + > ' SURFI=',I10,5X,'SURFF=',I10) + 6001 FORMAT(1P,(I6,E15.6)) + END diff --git a/Dragon/src/USS.f b/Dragon/src/USS.f new file mode 100644 index 0000000..33ea918 --- /dev/null +++ b/Dragon/src/USS.f @@ -0,0 +1,346 @@ +*DECK USS + SUBROUTINE USS(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Universal self-shielding operator. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1) creation or modification type(L_LIBRARY) (no +* subgroups); +* HENTRY(2) read-only type(L_LIBRARY) (with subgroups); +* HENTRY(3) read-only type(L_TRACK); +* HENTRY(4) optional read-only sequential binary tracking file. +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40,MAXRSS=300,IOUT=6) + TYPE(C_PTR) IPLI0,IPLIB,IPTRK + CHARACTER TEXT4*4,HSIGN*12,TEXT12*12,HSMG*131,CDOOR*12,TITR*72, + 1 HISOT*12 + DOUBLE PRECISION DFLOTT + LOGICAL LEAKSW,LFLAT + INTEGER IGP(NSTATE),IPAR(NSTATE),IPAS(NSTATE),IRSS(MAXRSS) +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.LE.2) CALL XABORT('USS: THREE PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('USS: LI' + 1 //'NKED LIST OR XSM FILE EXPECTED AT LHS.') + IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) CALL XABORT('USS: EN' + 1 //'TRY IN CREATE OR MODIFICATION MODE EXPECTED.') + IF((JENTRY(2).NE.2).OR.((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2))) + 1 CALL XABORT('USS: LINKED LIST OR XSM FILE IN READ-ONLY MODE E' + 2 //'XPECTED AT FIRST RHS.') + IF((JENTRY(3).NE.2).OR.((IENTRY(3).NE.1).AND.(IENTRY(3).NE.2))) + 1 CALL XABORT('USS: LINKED LIST OR XSM FILE IN READ-ONLY MODE E' + 2 //'XPECTED AT SECOND RHS.') + CALL LCMGTC(KENTRY(3),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_TRACK') THEN + TEXT12=HENTRY(3) + CALL XABORT('USS: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_TRACK EXPECTED.') + ENDIF + CALL LCMGTC(KENTRY(3),'TRACK-TYPE',12,CDOOR) + IPLI0=KENTRY(1) + IPLIB=KENTRY(2) + IPTRK=KENTRY(3) + INDREC=0 + IF(JENTRY(1).EQ.0) THEN + INDREC=1 + HSIGN='L_LIBRARY' + CALL LCMPTC(IPLI0,'SIGNATURE',12,HSIGN) + ELSE IF(JENTRY(1).EQ.1) THEN + CALL LCMGTC(IPLI0,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_LIBRARY') THEN + TEXT12=HENTRY(1) + CALL XABORT('USS: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_LIBRARY EXPECTED.') + ENDIF + INDREC=2 + ENDIF +*---- +* RECOVER TABULATED FUNCTIONS. +*---- + CALL XDRTA2 +*---- +* RECOVER TRACKING FILE INFORMATION. +*---- + IFTRAK=0 + IF(NENTRY.GE.4) THEN + IF(IENTRY(4).EQ.3) THEN + IF(JENTRY(4).NE.2) CALL XABORT('USS: BINARY TRACKING FILE NA' + 1 //'MED '//HENTRY(4)//' IS NOT IN REAL-ONLY MODE.') + IFTRAK=FILUNIT(KENTRY(4)) + ENDIF + ENDIF +*---- +* RECOVER GENERAL TRACKING INFORMATION. +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',IGP) + NREG=IGP(1) + NUN=IGP(2) + LEAKSW=IGP(3).EQ.0 + CALL LCMLEN(IPTRK,'TITLE',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGTC(IPTRK,'TITLE',72,TITR) + ELSE + TITR='*** NO TITLE PROVIDED ***' + ENDIF +*---- +* RECOVER INTERNAL LIBRARY PARAMETERS. +*---- + CALL LCMGTC(IPLIB,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_LIBRARY') THEN + TEXT12=HENTRY(2) + CALL XABORT('USS: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_LIBRARY EXPECTED.') + ENDIF + CALL LCMGET(IPLIB,'STATE-VECTOR',IPAR) + NBISO=IPAR(2) + NGRP=IPAR(3) + NL=IPAR(4) + ITRANC=IPAR(5) + IGRMIN=IPAR(9)+1 + IGRMAX=IPAR(10) + NED=IPAR(13) + NBMIX=IPAR(14) + NRES=IPAR(15) + ISUBG=IPAR(17) + NDEL=IPAR(19) + IF(IGP(4).GT.NBMIX) THEN + WRITE(HSMG,'(45HUSS: THE NUMBER OF MIXTURES IN THE TRACKING (, + 1 I5,55H) IS GREATER THAN THE NUMBER OF MIXTURES IN THE INTERNA, + 2 11HL LIBRARY (,I5,2H).)') IGP(4),NBMIX + CALL XABORT(HSMG) + ELSE IF((ISUBG.LE.0).OR.(ISUBG.EQ.2)) THEN + CALL XABORT('USS: THE INPUT INTERNAL LIBRARY HAS NO SUBGROUP' + 1 //'S.') + ENDIF + IF(INDREC.EQ.2) THEN + CALL LCMGET(IPLI0,'STATE-VECTOR',IPAR) + IF(IPAR(2).NE.NBISO) CALL XABORT('USS: INVALID LIBRARY.') + ENDIF +* + IMPX=1 + LFLAT=.FALSE. + CALL LCMLEN(IPLI0,'SHIBA_SG',LENLCM,ITYLCM) + IF(LENLCM.NE.0) THEN + CALL LCMSIX(IPLI0,'SHIBA_SG',1) + CALL LCMGET(IPLI0,'STATE-VECTOR',IPAS) + CALL LCMSIX(IPLI0,' ',2) + IGRMIN=IPAS(1) + IGRMAX=IPAS(2) + KSPH=IPAS(3) + ITRANZ=IPAS(4) + NPASS=IPAS(5) + IPHASE=IPAS(6) + ICALC=IPAS(8) + ICORR=IPAS(9) + MAXST=IPAS(10) + ELSE + KSPH=1 + ITRANZ=ITRANC + NPASS=2 + IF(CDOOR.EQ.'SYBIL') THEN + IPHASE=2 + ELSE IF(CDOOR.EQ.'EXCELL') THEN + IPHASE=2 + ELSE + IPHASE=1 + ENDIF + ICALC=0 + ICORR=0 + MAXST=50 + IF(ISUBG.EQ.6) MAXST=20 + ENDIF +* + 30 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.10) GO TO 70 + IF(INDIC.NE.3) CALL XABORT('USS: CHARACTER DATA EXPECTED(1).') + IF(TEXT4.EQ.'EDIT') THEN + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('USS: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT4.EQ.'GRMI') THEN + CALL REDGET(ITYPLU,IGRMIN,FLOTT,TEXT4,DFLOTT) + IF(ITYPLU.NE.1) CALL XABORT('USS: INTEGER DATA EXPECTED(2).') + ELSE IF(TEXT4.EQ.'GRMA') THEN + CALL REDGET(ITYPLU,IGRMAX,FLOTT,TEXT4,DFLOTT) + IF(ITYPLU.NE.1) CALL XABORT('USS: INTEGER DATA EXPECTED(3).') + IF(IGRMAX.GT.NGRP) THEN + CALL XABORT('USS: ILLEGAL NUMBER OF GROUP IN LIBRARY.') + ENDIF + ELSE IF(TEXT4.EQ.'NOSP') THEN + KSPH=0 + ELSE IF(TEXT4.EQ.'NOTR') THEN + ITRANZ=0 + ELSE IF(TEXT4.EQ.'TRAN') THEN + ITRANZ=1 + ELSE IF(TEXT4.EQ.'PASS') THEN + CALL REDGET(ITYPLU,NPASS,FLOTT,TEXT4,DFLOTT) + IF(ITYPLU.NE.1) CALL XABORT('USS: INTEGER DATA EXPECTED(5).') + IF(NPASS.LE.0) CALL XABORT('USS: POSITIVE PASS EXPECTED.') + ELSE IF(TEXT4.EQ.'ARM') THEN + IPHASE=1 + ELSE IF(TEXT4.EQ.'PIJ') THEN + IPHASE=2 + ELSE IF(TEXT4.EQ.'CALC') THEN + ICALC=1 + CALL LCMSIX(IPLI0,'SHIBA_SG',1) + CALL LCMSIX(IPLI0,'-DATA-CALC-',1) + CALL REDGET(ITYPLU,NITMA,FLOTT,TEXT12,DFLOTT) + IF(ITYPLU.NE.3) CALL XABORT('USS: CHARACTER DATA EXPECTED(2).') + 40 IF(TEXT12.EQ.'ENDC') THEN + CALL LCMSIX(IPLI0,' ',2) + CALL LCMSIX(IPLI0,' ',2) + GO TO 30 + ENDIF + IF(TEXT12.NE.'REGI') CALL XABORT('USS: REGI KEYWORD EXPECTED.') + CALL REDGET(ITYPLU,NITMA,FLOTT,TEXT12,DFLOTT) + IF(ITYPLU.NE.3) CALL XABORT('USS: CHARACTER DATA EXPECTED(3).') + IF(TEXT12(5:).NE.' ') CALL XABORT('USS: 4-CHARACTER NAME EXPE' + 1 //'CTED.') + CALL LCMSIX(IPLI0,TEXT12(:4),1) + CALL REDGET(ITYPLU,NITMA,FLOTT,TEXT12,DFLOTT) + IF(ITYPLU.NE.3) CALL XABORT('USS: CHARACTER DATA EXPECTED(4).') + 50 IF((TEXT12.EQ.'ENDC').OR.(TEXT12.EQ.'REGI')) THEN + CALL LCMSIX(IPLI0,' ',2) + GO TO 40 + ENDIF + HISOT=TEXT12 + NRSS=0 + 60 CALL REDGET(ITYPLU,NITMA,FLOTT,TEXT12,DFLOTT) + IF(ITYPLU.EQ.3) THEN + IF(TEXT12.EQ.'ALL') THEN + NRSS=1 + IRSS(1)=-999 + GO TO 60 + ENDIF + IF(NRSS.EQ.0) CALL XABORT('USS: INTEGER ARRAY EXPECTED.') + CALL LCMPUT(IPLI0,HISOT,NRSS,1,IRSS) + GO TO 50 + ENDIF + IF(ITYPLU.NE.1) CALL XABORT('USS: INTEGER DATA EXPECTED(6).') + NRSS=NRSS+1 + IF(NRSS.GT.MAXRSS) CALL XABORT('USS: MAXRSS OVERFLOW.') + IF((NITMA.LE.0).OR.(NITMA.GT.NBMIX)) THEN + WRITE(HSMG,'(43HUSS: REGI KEYWORD -- INVALID MIXTURE INDEX=, + 1 I5,1H.)') NITMA + CALL XABORT(HSMG) + ENDIF + IRSS(NRSS)=NITMA + GO TO 60 + ELSE IF(TEXT4.EQ.'NOCO') THEN + ICORR=1 + ELSE IF(TEXT4.EQ.'MAXS') THEN + CALL REDGET(ITYPLU,MAXST,FLOTT,TEXT4,DFLOTT) + IF(ITYPLU.NE.1) CALL XABORT('USS: INTEGER DATA EXPECTED(7).') + ELSE IF(TEXT4.EQ.'FLAT') THEN + IF(INDREC.EQ.1) CALL XABORT('USS: OUTPUT MICROLIB IN MODIFICA' + 1 //'TION MODE EXPECTED.') + LFLAT=.TRUE. + ELSE IF(TEXT4.EQ.';') THEN + GO TO 70 + ELSE + CALL XABORT('USS: '//TEXT4//' IS AN INVALID KEY WORD.') + ENDIF + GO TO 30 +*---- +* THE NUMBER OF UNKNOWNS OF A CURRENT-BASED MULTICELL ITERATION IS +* INCREASED TO HOLD INTERFACE CURRENT COMPONENTS. +*---- + 70 IF(IPHASE.EQ.1) THEN + IF(CDOOR.EQ.'SYBIL') NUN=NUN+IGP(9) + IF((CDOOR.EQ.'EXCELL').AND.(IGP(7).EQ.5)) NUN=NUN+IGP(28) + ENDIF +*---- +* CALL USS: DRIVER. +*---- + IF(IMPX.GT.0) THEN + IF(INDREC.EQ.1) WRITE(IOUT,100) + WRITE(IOUT,110) TITR,CDOOR(:9),ISUBG,IGRMIN,IGRMAX,KSPH,ITRANZ, + 1 NPASS,IPHASE,ICALC,ICORR,MAXST + ENDIF +*---- +* PERFORM SELF-SHIELDING. +*---- + IF(CDOOR.EQ.'MCCG') THEN + CALL LCMLEN(IPTRK,'KEYFLX',LKFL,ITYLCM) + NFUNL=LKFL/NREG + ELSE + NFUNL=1 + ENDIF + CALL USSDRV(IPLI0,IPTRK,IPLIB,IFTRAK,INDREC,CDOOR,IMPX,IGRMIN, + 1 IGRMAX,NGRP,NBMIX,NREG,NUN,NBISO,NL,NED,NDEL,LEAKSW,ITRANZ, + 2 IPHASE,TITR,KSPH,NRES,NPASS,ICALC,ICORR,ISUBG,MAXST,LFLAT) +*---- +* STORE THE GENERAL SHELF-SHIELDING PARAMETERS. +*---- + IPAS(:NSTATE)=0 + IPAS(1)=IGRMIN + IPAS(2)=IGRMAX + IPAS(3)=KSPH + IPAS(4)=ITRANZ + IPAS(5)=NPASS + IPAS(6)=IPHASE + IPAS(8)=ICALC + IPAS(9)=ICORR + IPAS(10)=MAXST + CALL LCMSIX(IPLI0,'SHIBA_SG',1) + CALL LCMPUT(IPLI0,'STATE-VECTOR',NSTATE,1,IPAS) + CALL LCMSIX(IPLI0,' ',2) + RETURN +* + 100 FORMAT(1H1,23HUU UU SSSSS SSSSS ,107(1H*)/ + 1 25H UU UU SSSSSSS SSSSSSS ,63(1H*), + 2 43H UNIVERSAL SELF-SHIELDING MODEL. A. HEBERT/ + 3 24H UU UU SS SS SS SS/21H UU UU SSS SSS/ + 4 23H UU UU SSS SSS/24H UU UU SS SS SS SS/ + 5 24H UUUUUUU SSSSSSS SSSSSSS/23H UUUUU SSSSS SSSSS/) + 110 FORMAT(/1X,A72//8H OPTIONS/8H -------/ + 1 7H CDOOR ,A8,30H (NAME OF THE SOLUTION DOOR)/ + 2 7H ISUBG ,I8,47H (=1: SUBG; =3: PT; =4: PTSL; =5: PTMC; =6: R, + 3 3HSE)/ + 4 7H IGRMIN,I8,27H (FIRST GROUP TO PROCESS)/ + 5 7H IGRMAX,I8,34H (MOST THERMAL GROUP TO PROCESS)/ + 6 7H KSPH ,I8,47H (=0: NO SPH CORRECTION; =1: SPH CORRECTION I, + 7 19HN RESONANT REGIONS)/ + 8 7H ITRANZ,I8,45H (0=NO TRANSPORT CORRECTION/1=APOLLO TYPE/2, + 9 57H=RECOVER FROM LIBRARY/3=WIMS-D TYPE/4=LEAKAGE CORRECTION)/ + 1 7H NPASS ,I8,31H (NUMBER OF OUTER ITERATIONS)/ + 2 7H IPHASE,I8,37H (=1: NATIVE ASSEMBLY; =2: USE PIJ)/ + 3 7H ICALC ,I8,48H (=0: NO &CALC DATA; =1: &CALC DATA AVAILABLE)/ + 4 7H ICORR ,I8,47H (=1: SUPPRESS MUTUAL RESONANCE SHIELDING EFF, + 5 4HECT)/ + 6 7H MAXST ,I8,36H (MAXIMUM NUMBER OF ST ITERATIONS)) + END diff --git a/Dragon/src/USSCOR.f b/Dragon/src/USSCOR.f new file mode 100644 index 0000000..5d274db --- /dev/null +++ b/Dragon/src/USSCOR.f @@ -0,0 +1,232 @@ +*DECK USSCOR + SUBROUTINE USSCOR(MAXNOR,IGRP,IPSYS,IASM,IRES,NBNRS,NIRES,NOR, + 1 CONR,IPPT1,IPPT2,WEIGH,TOTPT,SIGX,VOLMER) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the collision probability matrix taking into account the +* correlation effects between pairs of resonant isotopes in the same +* energy group. +* +*Copyright: +* Copyright (C) 2003 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXNOR maximum order of the probability tables (PT). +* IGRP energy group index. +* IPSYS pointer to the internal microscopic cross section library. +* builded by the self-shielding module. +* IASM offset in IPSYS. +* IRES index of the resonant isotope been processed. +* NBNRS number of correlated fuel regions. +* NIRES exact number of correlated resonant isotopes. +* NOR exact order of the probability table. +* CONR number density of the resonant isotopes. +* IPPT1 pointer to LCM directory of each resonant isotope. +* IPPT2 information related to each resonant isotope: +* IPPT2(:,1) index of a resonant region (used with infinite +* dilution case); +* IPPT2(:,2:4) alias name of resonant isotope. +* WEIGH multiband weights. +* TOTPT base points in total xs. +* SIGX macroscopic total xs of the non-resonant isotopes in each fuel +* region. +* VOLMER volumes of the resonant and non-resonant regions. +* +* Reference: +* A. Hebert, "A Mutual Resonance Self-Shielding Model Consistent with +* Ribon Subgroup Equations", Int. Mtg. on the Physics of Fuel Cycles +* and Advanced Nuclear Systems: Global Developments. PHYSOR-2004, +* Chicago, Illinois, April 25 - 29, 2004. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSYS,IPPT1(NIRES) + INTEGER MAXNOR,IGRP,IASM,IRES,NBNRS,NIRES,NOR(NIRES), + 1 IPPT2(NIRES,4) + REAL CONR(NBNRS,NIRES),WEIGH(MAXNOR,NIRES),TOTPT(MAXNOR,NIRES), + 1 SIGX(NBNRS,NIRES),VOLMER(0:NBNRS) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) KPSYS,JPLIB1,KPLIB1,JPLIB2 + CHARACTER TEXT12*12 + LOGICAL LMOD +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: WCOR,SIGR + REAL, ALLOCATABLE, DIMENSION(:,:) :: PIJ2,PIJ3,DILW + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: DIL,PIJ4 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(WCOR(MAXNOR**2),SIGR(NBNRS),DIL(0:NBNRS,0:NBNRS,MAXNOR), + 1 PIJ2(0:NBNRS,0:NBNRS),PIJ3(0:NBNRS,0:NBNRS), + 2 PIJ4(0:NBNRS,0:NBNRS,MAXNOR),DILW(0:NBNRS,0:NBNRS)) +*---- +* COMPUTE THE MULTIBAND DILUTION MATRICES. +*---- + LMOD=(VOLMER(0).EQ.0.0) + NQT1=NOR(IRES) + DO 35 I1=1,NQT1 + DO 20 IND=1,NBNRS + SIGR(IND)=CONR(IND,IRES)*TOTPT(I1,IRES) + DO 10 JRES=1,NIRES + IF(JRES.NE.IRES) SIGR(IND)=SIGR(IND)+SIGX(IND,JRES) + 10 CONTINUE + 20 CONTINUE + KPSYS=LCMGIL(IPSYS,IASM+I1) + CALL LCMGET(KPSYS,'DRAGON-PAV',DIL(0,0,I1)) + IF(LMOD) THEN + CALL ALINV(NBNRS,DIL(1,1,I1),NBNRS+1,IER) + ELSE + CALL ALINV(NBNRS+1,DIL(0,0,I1),NBNRS+1,IER) + ENDIF + IF(IER.NE.0) CALL XABORT('USSCOR: SINGULAR MATRIX(1).') + DO 30 IND=1,NBNRS + DIL(IND,IND,I1)=DIL(IND,IND,I1)-SIGR(IND) + 30 CONTINUE + 35 CONTINUE +*---- +* COMPUTE THE AVERAGED COLLISION PROBABILITY MATRICES. +*---- + IF(NIRES.EQ.2) THEN + JRES=MOD(IRES,NIRES)+1 + JPLIB1=LCMGID(IPPT1(IRES),'GROUP-PT') + CALL LCMLEL(JPLIB1,IGRP,ILONG1,ITYLCM) + JPLIB2=LCMGID(IPPT1(JRES),'GROUP-PT') + CALL LCMLEL(JPLIB2,IGRP,ILONG2,ITYLCM) + IF((ILONG1.NE.0).AND.(ILONG2.NE.0)) THEN + KPLIB1=LCMGIL(JPLIB1,IGRP) +* +* COMPUTE THE FULLY CORRELATED PIJ MATRIX. + WRITE(TEXT12,'(3A4)') (IPPT2(JRES,I0),I0=2,4) + CALL LCMGET(KPLIB1,TEXT12,WCOR) + NQT2=NOR(JRES) + DO 100 I1=1,NQT1 + DO 40 IND=1,NBNRS + SIGR(IND)=CONR(IND,IRES)*TOTPT(I1,IRES) + 40 CONTINUE + KPSYS=LCMGIL(IPSYS,IASM+I1) + CALL LCMGET(KPSYS,'DRAGON-PAV',PIJ3(0,0)) + CALL USSSEK(NBNRS,NQT2,LMOD,SIGR,CONR(1,JRES),WEIGH(1,JRES), + 1 TOTPT(1,JRES),PIJ3(0,0),DIL(0,0,I1)) + PIJ3(0:NBNRS,0:NBNRS)=0.0 + DO 95 I2=1,NQT2 + WWW=WCOR((I2-1)*NQT1+I1)/WEIGH(I1,IRES) + DO 60 I=0,NBNRS + DO 50 J=0,NBNRS + PIJ2(I,J)=DIL(I,J,I1) + 50 CONTINUE + 60 CONTINUE + DO 70 I=1,NBNRS + PIJ2(I,I)=PIJ2(I,I)+SIGR(I)+CONR(I,JRES)*TOTPT(I2,JRES) + 70 CONTINUE + IF(LMOD) THEN + CALL ALINV(NBNRS,PIJ2(1,1),NBNRS+1,IER) + ELSE + CALL ALINV(NBNRS+1,PIJ2(0,0),NBNRS+1,IER) + ENDIF + IF(IER.NE.0) CALL XABORT('USSCOR: SINGULAR MATRIX(2).') + DO 90 I=0,NBNRS + DO 80 J=0,NBNRS + PIJ3(I,J)=PIJ3(I,J)+WWW*PIJ2(I,J) + 80 CONTINUE + 90 CONTINUE + 95 CONTINUE +* +* STORE CORRECTED PIJ MATRIX. + CALL LCMPUT(KPSYS,'DRAGON-PAV',(NBNRS+1)**2,2,PIJ3(0,0)) + 100 CONTINUE + ENDIF + ELSE IF(NIRES.GT.1) THEN + DO 110 I1=1,NQT1 + KPSYS=LCMGIL(IPSYS,IASM+I1) + CALL LCMGET(KPSYS,'DRAGON-PAV',PIJ4(0,0,I1)) + 110 CONTINUE + DO 200 JRES=1,NIRES + JPLIB1=LCMGID(IPPT1(IRES),'GROUP-PT') + CALL LCMLEL(JPLIB1,IGRP,ILONG1,ITYLCM) + JPLIB2=LCMGID(IPPT1(JRES),'GROUP-PT') + CALL LCMLEL(JPLIB2,IGRP,ILONG2,ITYLCM) + IF((JRES.NE.IRES).AND.(ILONG1.NE.0).AND.(ILONG2.NE.0)) THEN + KPLIB1=LCMGIL(JPLIB1,IGRP) +* +* COMPUTE THE FULLY CORRELATED PIJ MATRIX. + WRITE(TEXT12,'(3A4)') (IPPT2(JRES,I0),I0=2,4) + CALL LCMGET(KPLIB1,TEXT12,WCOR) + NQT2=NOR(JRES) + DO 190 I1=1,NQT1 + DO 130 I=0,NBNRS + DO 120 J=0,NBNRS + DILW(I,J)=DIL(I,J,I1) + 120 CONTINUE + 130 CONTINUE + DO 145 IND=1,NBNRS + SIGR(IND)=CONR(IND,IRES)*TOTPT(I1,IRES) + DO 140 KRES=1,NIRES + IF((KRES.NE.IRES).AND.(KRES.NE.JRES)) THEN + SIGR(IND)=SIGR(IND)+SIGX(IND,KRES) + ENDIF + 140 CONTINUE + 145 CONTINUE + CALL USSSEK(NBNRS,NQT2,LMOD,SIGR,CONR(1,JRES),WEIGH(1,JRES), + 1 TOTPT(1,JRES),PIJ4(0,0,I1),DILW(0,0)) +* + PIJ3(0:NBNRS,0:NBNRS)=0.0 + DO 172 I2=1,NQT2 + WWW=WCOR((I2-1)*NQT1+I1)/WEIGH(I1,IRES) + DO 155 I=0,NBNRS + DO 150 J=0,NBNRS + PIJ2(I,J)=DILW(I,J) + 150 CONTINUE + 155 CONTINUE + DO 160 I=1,NBNRS + PIJ2(I,I)=PIJ2(I,I)+SIGR(I)+CONR(I,JRES)*TOTPT(I2,JRES) + 160 CONTINUE + IF(LMOD) THEN + CALL ALINV(NBNRS,PIJ2(1,1),NBNRS+1,IER) + ELSE + CALL ALINV(NBNRS+1,PIJ2(0,0),NBNRS+1,IER) + ENDIF + IF(IER.NE.0) CALL XABORT('USSCOR: SINGULAR MATRIX(3).') + DO 171 I=0,NBNRS + DO 170 J=0,NBNRS + PIJ3(I,J)=PIJ3(I,J)+WWW*PIJ2(I,J) + 170 CONTINUE + 171 CONTINUE + 172 CONTINUE + KPSYS=LCMGIL(IPSYS,IASM+I1) + CALL LCMGET(KPSYS,'DRAGON-PAV',PIJ2(0,0)) + DO 185 I=0,NBNRS + DO 180 J=0,NBNRS + IF(PIJ4(I,J,I1).NE.0.0) THEN + PIJ2(I,J)=PIJ2(I,J)*PIJ3(I,J)/PIJ4(I,J,I1) + ENDIF + 180 CONTINUE + 185 CONTINUE +* +* STORE CORRECTED PIJ MATRIX. + CALL LCMPUT(KPSYS,'DRAGON-PAV',(NBNRS+1)**2,2,PIJ2(0,0)) + 190 CONTINUE + ENDIF + 200 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(DILW,PIJ4,PIJ3,PIJ2,DIL,SIGR,WCOR) + RETURN + END diff --git a/Dragon/src/USSDRV.f b/Dragon/src/USSDRV.f new file mode 100644 index 0000000..ae8ea6f --- /dev/null +++ b/Dragon/src/USSDRV.f @@ -0,0 +1,492 @@ +*DECK USSDRV + SUBROUTINE USSDRV(IPLI0,IPTRK,IPLIB,IFTRAK,INDREC,CDOOR,IMPX, + 1 IGRMIN,IGRMAX,NGRP,NBMIX,NREG,NUN,NBISO,NL,NED,NDEL,LEAKSW, + 2 ITRANC,IPHASE,TITR,KSPH,NRES,NPASS,ICALC,ICORR,ISUBG,MAXST, + 3 LFLAT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Driver for a resonance self-shielding calculation. +* +*Copyright: +* Copyright (C) 2003 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLI0 pointer to the internal microscopic cross section library +* builded by the self-shielding module (L_LIBRARY signature). +* IPTRK pointer to the tracking (L_TRACK signature). +* IPLIB pointer to the internal microscopic cross section library +* with subgroups (L_LIBRARY signature). +* IFTRAK unit number of the sequential binary tracking file. +* INDREC access flag for the internal microscopic cross section library +* builded by the self-shielding module (=1 IPLI0 access in +* creation mode; =2 in modification mode). +* CDOOR name of the geometry/solution operator. +* IMPX print flag (equal to zero for no print). +* IGRMIN first group where the self-shielding is applied. +* IGRMAX most thermal group where the self-shielding is applied. +* NGRP number of energy groups. +* NBMIX number of mixtures in the internal library. +* NREG number of regions. +* NUN number of unknowns per energy group. +* NBISO number of isotopes specifications in the internal library. +* NL number of Legendre orders required in the calculation +* (NL=1 or higher). +* NED number of extra vector edits. +* NDEL number of delayed neutron precursor groups. +* LEAKSW leakage flag (LEAKSW=.TRUE. if neutron leakage through +* external boundary is present). +* ITRANC type of transport correction. +* IPHASE type of flux solution (=1 use a native flux solution door; +* =2 use collision probabilities). +* TITR title. +* KSPH SPH equivalence flag (=0 no SPH correction; =1 SPH correction +* in the fuel). +* NRES number of self-shielding zones, as given by LIB:. +* NPASS number of outer iterations. +* ICALC simplified self-shielding flag (=1 IPLI0 is containing ICALC +* data. =0 no ICALC data). +* ICORR mutual resonance shielding flag (=1 to suppress the model +* in cases it is required in LIB operator). +* ISUBG type of self-shielding model (=1 use physical probability +* tables; =3 use original Ribon method; =4 use Ribon extended +* method; =6 use resonance spectrum expansion method). +* MAXST maximum number of fixed point iterations for the ST scattering +* source. +* LFLAT force the initial subgroup flux to be flat if IPLI0 is open +* in modification mode. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLI0,IPTRK,IPLIB + INTEGER IFTRAK,INDREC,IMPX,IGRMIN,IGRMAX,NGRP,NBMIX,NREG,NUN, + 1 NBISO,NL,NED,NDEL,ITRANC,IPHASE,KSPH,NRES,NPASS,ICALC,ICORR, + 2 ISUBG,MAXST + CHARACTER CDOOR*12,TITR*72 + LOGICAL LEAKSW,LFLAT +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40,MAXRSS=300,MAXESP=4) + TYPE(C_PTR) JPLI0,KPLI0,JPLIB,KPLIB + CHARACTER HSMG*131,HCAL*12,TEXT4*4,NAM1*4,FNAM1*4,NAM2*12, + 1 FNAM2*12,CBDPNM*12,TEXT8*8 + INTEGER IPAR(NSTATE),IRSS(MAXRSS),IESP(MAXESP+1) + REAL TMPDAY(3),EESP(MAXESP+1) + LOGICAL LTEST +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MAT,KEYFLX,MIX,IEVOL,ITYPE, + 1 LSHI,IAPT,IHSUF,IREX,ILLIB,JCEDM,LSHI2 + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISONAM,ISONRF,IHLIB + REAL, ALLOCATABLE, DIMENSION(:) :: VOL,TN,DEN,ENER,GS,VOLMIX + LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASK,MASKL +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(MAT(NREG),KEYFLX(NREG),ISONAM(3,NBISO),ISONRF(3,NBISO), + 3 MIX(NBISO),IEVOL(NBISO),ITYPE(NBISO),LSHI(NBISO),IAPT(NBISO), + 4 IHSUF(NBISO),IREX(NBMIX),IHLIB(2,NBISO),ILLIB(NBISO)) + ALLOCATE(VOL(NREG),TN(NBISO),DEN(NBISO)) +*---- +* RECOVER USEFUL INFORMATION FROM TRACKING OBJECT. +*---- + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'VOLUME',VOL) + CALL LCMGET(IPTRK,'KEYFLX',KEYFLX) +*---- +* RECOVER USEFUL INFORMATION FROM LIBRARY OBJECTS. +*---- + CALL LCMGET(IPLIB,'ISOTOPESUSED',ISONAM) + CALL LCMGET(IPLIB,'ISOTOPERNAME',ISONRF) + CALL LCMGET(IPLIB,'ISOTOPESMIX',MIX) + CALL LCMGET(IPLIB,'ISOTOPESTODO',IEVOL) + CALL LCMGET(IPLIB,'ISOTOPESTYPE',ITYPE) + CALL LCMGET(IPLIB,'ISOTOPESTEMP',TN) +* + CALL LCMPUT(IPLI0,'ISOTOPESMIX',NBISO,1,MIX) + CALL LCMPUT(IPLI0,'ISOTOPESTODO',NBISO,1,IEVOL) + CALL LCMPUT(IPLI0,'ISOTOPESTYPE',NBISO,1,ITYPE) + CALL LCMPUT(IPLI0,'ISOTOPESTEMP',NBISO,2,TN) + IF(INDREC.EQ.1) THEN + CALL LCMGET(IPLIB,'ISOTOPESDENS',DEN) + CALL LCMPUT(IPLI0,'ISOTOPESDENS',NBISO,2,DEN) + ELSE IF(INDREC.EQ.2) THEN + CALL LCMGET(IPLI0,'ISOTOPESDENS',DEN) + ENDIF + CALL LCMGET(IPLIB,'ISOTOPESSHI',LSHI) + CALL LCMLEN(IPLIB,'ISOTOPESDSN',NELSN,ITYLCM) + IF(NELSN.GT.0) THEN + NGIS=NGRP*NBISO + ALLOCATE(GS(NGIS)) + CALL LCMGET(IPLIB,'ISOTOPESDSN',GS) + CALL LCMPUT(IPLI0,'ISOTOPESDSN',NGIS,2,GS) + CALL LCMGET(IPLIB,'ISOTOPESDSB',GS) + CALL LCMPUT(IPLI0,'ISOTOPESDSB',NGIS,2,GS) + DEALLOCATE(GS) + ENDIF + ALLOCATE(ENER(NGRP+1)) + CALL LCMGET(IPLIB,'ENERGY',ENER) + CALL LCMPUT(IPLI0,'ENERGY',NGRP+1,2,ENER) + CALL LCMGET(IPLIB,'DELTAU',ENER) + CALL LCMPUT(IPLI0,'DELTAU',NGRP,2,ENER) + DEALLOCATE(ENER) + CALL LCMLEN(IPLIB,'CHI-LIMITS',NBESP,ITYLCM) + IF(NBESP.GT.0) THEN + NBESP=NBESP-1 + IF(NBESP.GT.MAXESP) CALL XABORT('USSDRV: MAXESP OVERFLOW.') + CALL LCMGET(IPLIB,'CHI-LIMITS',IESP) + CALL LCMPUT(IPLI0,'CHI-LIMITS',NBESP+1,1,IESP) + CALL LCMGET(IPLIB,'CHI-ENERGY',EESP) + CALL LCMPUT(IPLI0,'CHI-ENERGY',NBESP+1,2,EESP) + ENDIF + DO 10 ISO=1,NBISO + DO 5 I=1,NREG + IF(MAT(I).EQ.MIX(ISO)) GO TO 10 + 5 CONTINUE + LSHI(ISO)=0 + 10 CONTINUE +*---- +* COMPUTE MIXTURESVOL. +*---- + ALLOCATE(VOLMIX(NBMIX)) + VOLMIX(:NBMIX)=0.0 + DO I=1,NREG + IBM=MAT(I) + IF(IBM.GT.0) VOLMIX(IBM)=VOLMIX(IBM)+VOL(I) + CALL LCMPUT(IPLI0,'MIXTURESVOL',NBMIX,2,VOLMIX) + ENDDO + DEALLOCATE(VOLMIX) +* + DO 15 ISO=1,NBISO + TEXT8='MICROLIB' + READ(TEXT8,'(2A4)') IHLIB(1,ISO),IHLIB(2,ISO) + ILLIB(ISO)=0 + 15 CONTINUE + CALL LCMPUT(IPLI0,'ILIBRARYTYPE',2*NBISO,3,IHLIB(1,1)) + CALL LCMPUT(IPLI0,'ILIBRARYINDX',NBISO,1,ILLIB) +* + JPLIB=LCMGID(IPLIB,'ISOTOPESLIST') + JPLI0=LCMLID(IPLI0,'ISOTOPESLIST',NBISO) + IF(INDREC.EQ.1) THEN +* COPY THE NON RESONANT ISOTOPES. + CALL KDRCPU(TK1) + DO 20 ISO=1,NBISO + IF((LSHI(ISO).EQ.0).OR.(DEN(ISO).EQ.0.0)) THEN + CALL LCMLEL(JPLIB,ISO,ILEN,ITYLCM) + IF(ILEN.EQ.0) THEN + DO JSO=1,ISO-1 + CALL LCMLEL(JPLIB,JSO,ILEN,ITYLCM) + IF(ILEN.EQ.0) CYCLE + IF((ISONAM(1,ISO).EQ.ISONAM(1,JSO)).AND.(ISONAM(2,ISO) + 1 .EQ.ISONAM(2,JSO)).AND.(ISONAM(3,ISO).EQ.ISONAM(3,JSO))) + 2 THEN + IF(LSHI(JSO).GT.0) THEN + KPLIB=LCMGIL(JPLIB,JSO) ! set JSO-th isotope + GO TO 16 + ELSE + GO TO 20 + ENDIF + ENDIF + ENDDO + ELSE + KPLIB=LCMGIL(JPLIB,ISO) ! set ISO-th isotope + GO TO 16 + ENDIF + GO TO 20 + 16 CALL LCMLEL(JPLI0,ISO,ILEN,ITYLCM) + IF(ILEN.NE.0) GO TO 20 + KPLI0=LCMDIL(JPLI0,ISO) ! set ISO-th isotope + CALL LCMEQU(KPLIB,KPLI0) + ENDIF + 20 CONTINUE + CALL KDRCPU(TK2) + IF(IMPX.GT.1) WRITE(6,'(/33H USSDRV: CPU TIME SPENT TO COPY T, + 1 26HHE NON-RESONANT ISOTOPES =,F8.1,8H SECOND.)') TK2-TK1 +* +* WRITE THE OUTPUT INTERNAL LIBRARY PARAMETERS. + CALL LCMGET(IPLIB,'STATE-VECTOR',IPAR) + IPAR(8)=0 + IPAR(17)=0 + CALL LCMPUT(IPLI0,'STATE-VECTOR',NSTATE,1,IPAR) + IF(NED.GT.0) THEN + ALLOCATE(JCEDM(2*NED)) + CALL LCMGET(IPLIB,'ADDXSNAME-P0',JCEDM) + CALL LCMPUT(IPLI0,'ADDXSNAME-P0',2*NED,3,JCEDM) + DEALLOCATE(JCEDM) + ENDIF + CALL LCMLEN(IPLIB,'DEPL-CHAIN',ILENG,ITYLCM) + IF(ILENG.NE.0) THEN + CALL LCMSIX(IPLIB,'DEPL-CHAIN',1) + CALL LCMSIX(IPLI0,'DEPL-CHAIN',1) + CALL LCMEQU(IPLIB,IPLI0) + CALL LCMSIX(IPLI0,' ',2) + CALL LCMSIX(IPLIB,' ',2) + ENDIF + ENDIF +*---- +* RECOMPUTE THE VECTOR LSHI. +*---- + ALLOCATE(LSHI2(NBISO)) + NRES2=0 + NRES3=0 + DO 30 ISO=1,NBISO + IF(LSHI(ISO).NE.0) NRES3=NRES3+1 + LSHI2(ISO)=0 + 30 CONTINUE + DO 80 INRS=1,NRES + 40 DENMAX=0.0 + KSOT=0 + DO 60 ISO=1,NBISO + IF(LSHI2(ISO).EQ.0) THEN + VOLISO=0.0 + DO 50 I=1,NREG + IF(MAT(I).EQ.MIX(ISO)) VOLISO=VOLISO+VOL(I) + 50 CONTINUE + IF((ABS(LSHI(ISO)).EQ.INRS).AND.(DEN(ISO)*VOLISO.GT.DENMAX)) + 1 THEN + KSOT=ISO + DENMAX=DEN(ISO)*VOLISO + ENDIF + ENDIF + 60 CONTINUE + IF(KSOT.GT.0) THEN + NRES2=NRES2+1 + DO 70 ISO=1,NBISO + LTEST=((ISONRF(1,ISO).EQ.ISONRF(1,KSOT)).AND. + 1 (ISONRF(2,ISO).EQ.ISONRF(2,KSOT)).AND. + 2 (ISONRF(3,ISO).EQ.ISONRF(3,KSOT)).AND. + 3 (ABS(LSHI(ISO)).EQ.INRS)) + LTEST=LTEST.OR.((ISONAM(1,ISO).EQ.ISONAM(1,KSOT)).AND. + 1 (ISONAM(2,ISO).EQ.ISONAM(2,KSOT)).AND. + 2 (ABS(LSHI(ISO)).EQ.INRS)) + IF(LTEST) LSHI2(ISO)=NRES2 + IF(LTEST.AND.(LSHI(ISO).EQ.-INRS)) THEN + DO 65 JSO=1,NBISO + IF(LSHI(JSO).EQ.LSHI(ISO)) LSHI2(JSO)=NRES2 + 65 CONTINUE + ENDIF + 70 CONTINUE + GO TO 40 + ENDIF + 80 CONTINUE + IF(NRES2.EQ.0) THEN + CALL LCMEQU(IPLIB,IPLI0) + GO TO 266 + ENDIF +*---- +* FIND THE ISOTOPE-NAME SUFFIX VALUES. +*---- + TEXT4=' ' + READ(TEXT4,'(A4)') IHBLK + DO 90 ISO=1,NBISO + IF((LSHI2(ISO).NE.0).AND.(DEN(ISO).NE.0.0)) THEN + WRITE(TEXT4,'(I4.4)') MIX(ISO) + READ(TEXT4,'(A4)') IHSUF(ISO) + ELSE + IHSUF(ISO)=IHBLK + ENDIF + 90 CONTINUE + IF(ICALC.EQ.1) THEN + CALL LCMSIX(IPLI0,'SHIBA_SG',1) + CALL LCMSIX(IPLI0,'-DATA-CALC-',1) + NAM1=' ' + CALL LCMNXT(IPLI0,NAM1) + FNAM1=NAM1 + 100 CALL LCMSIX(IPLI0,NAM1,1) + NAM2=' ' + CALL LCMNXT(IPLI0,NAM2) + FNAM2=NAM2 + 110 CALL LCMLEN(IPLI0,NAM2,NRSS,ITYLCM) + CALL LCMGET(IPLI0,NAM2,IRSS) + READ(NAM2,'(2A4)') IN1,IN2 + DO 130 ISO=1,NBISO + IF((ISONAM(1,ISO).EQ.IN1).AND.(ISONAM(2,ISO).EQ.IN2).AND. + 1 (LSHI2(ISO).NE.0)) THEN + IF((NRSS.EQ.1).AND.(IRSS(1).EQ.-999)) THEN + READ(NAM1,'(A4)') IHSUF(ISO) + ELSE + DO 120 I=1,NRSS + IF(IRSS(I).EQ.MIX(ISO)) READ(NAM1,'(A4)') IHSUF(ISO) + 120 CONTINUE + ENDIF + ENDIF + 130 CONTINUE + CALL LCMNXT(IPLI0,NAM2) + IF(NAM2.EQ.FNAM2) GO TO 140 + GO TO 110 + 140 CALL LCMSIX(IPLI0,' ',2) + CALL LCMNXT(IPLI0,NAM1) + IF(NAM1.EQ.FNAM1) THEN + CALL LCMSIX(IPLI0,' ',2) + CALL LCMSIX(IPLI0,' ',2) + GO TO 150 + ENDIF + GO TO 100 + ENDIF +* + 150 NPASS2=NPASS + IF(NRES3.EQ.1) NPASS2=1 + DO 265 IPASS=1,NPASS2 + IF((IMPX.GT.0).AND.(NPASS2.GT.1)) WRITE (6,'(/15H USSDRV: SELF S, + 1 25HHIELDING ITERATION NUMBER,I4,8H NRES2=,I4,1H.)') IPASS,NRES2 + DO 260 INRS=1,NRES2 +*---- +* COMPUTE THE NUMBER OF RESONANT ISOTOPES IN REGION INRS AND THE +* RESONANT ISOTOPE INDEX ASSOCIATED TO EACH ISOTOPE SPECIFICATION. +*---- + NIRES=0 + DO 200 ISO=1,NBISO + IAPT(ISO)=0 + IF((LSHI2(ISO).EQ.INRS).AND.(DEN(ISO).NE.0.0)) THEN + DO 170 I=1,NREG + IF(MAT(I).EQ.MIX(ISO)) GO TO 180 + 170 CONTINUE + GO TO 200 + 180 DO 190 JSO=1,ISO-1 + IF((ISONAM(1,ISO).EQ.ISONAM(1,JSO)).AND. + 1 (ISONAM(2,ISO).EQ.ISONAM(2,JSO)).AND. + 2 (ISONAM(3,ISO).EQ.ISONAM(3,JSO)).AND. + 3 (LSHI2(JSO).EQ.INRS).AND. + 4 (DEN(JSO).NE.0.0).AND.(IAPT(JSO).NE.0)) THEN + IAPT(ISO)=IAPT(JSO) + GO TO 200 + ENDIF + 190 CONTINUE + IIII=ISO + NIRES=NIRES+1 + IAPT(ISO)=NIRES + ENDIF + 200 CONTINUE + WRITE(HCAL,'(1HC,I5.5,1H/,I5.5)') IIII,NBISO + IF(NIRES.EQ.0) THEN + WRITE(HSMG,'(45HUSSDRV: NO RESONANT ISOTOPES IN RESONANT REGI, + 1 9HON NUMBER,I4,7H (HCAL=,A12,2H).)') INRS,HCAL + CALL XABORT(HSMG) + ENDIF + IF(IMPX.GT.0) WRITE (6,'(/35H USSDRV: PERFORMING SELF-SHIELDING , + 1 18HCALCULATION NAMED ,A12,1H.)') HCAL +*---- +* FIND THE NUMBER OF FUEL REGIONS AND THE FUEL REGION INDICES ASSIGNED +* TO EACH RESONANT MIXTURE. +*---- + NBNRS=0 + DO 210 IBM=1,NBMIX + IREX(IBM)=0 + 210 CONTINUE + DO 230 ISO=1,NBISO + IBM=MIX(ISO) + IF((IAPT(ISO).GT.0).AND.(IREX(IBM).EQ.0)) THEN + DO 220 JSO=1,ISO-1 + IF((IHSUF(JSO).EQ.IHSUF(ISO)).AND.(IAPT(JSO).EQ.IAPT(ISO))) + 1 THEN + IREX(IBM)=IREX(MIX(JSO)) + GO TO 230 + ENDIF + 220 CONTINUE + IF(IMPX.GT.0) WRITE(6,'(9X,3H-->,3A4)') (ISONAM(J,ISO),J=1,2), + 1 IHSUF(ISO) + NBNRS=NBNRS+1 + IREX(IBM)=NBNRS + ELSE IF(IAPT(ISO).GT.0) THEN + IF(IMPX.GT.0) WRITE(6,'(9X,3H-->,3A4)') (ISONAM(J,ISO),J=1,3) + ENDIF + 230 CONTINUE + IF(NBNRS.EQ.0) THEN + WRITE (HSMG,'(33HUSSDRV: INVALID RESONANT REGION =,I10)') INRS + CALL XABORT(HSMG) + ENDIF + IF(IMPX.GE.0) WRITE(6,410) NIRES,NBNRS,INRS +*---- +* DETERMINE WHICH MODERATOR ISOTOPES ARE MIXED WITH RESONANT ONES. +*---- + DO 250 ISO=1,NBISO + IF((IAPT(ISO).EQ.0).AND.(IREX(MIX(ISO)).GT.0)) IAPT(ISO)=NIRES+1 + 250 CONTINUE +*---- +* ERASE OLD GROUP-INFO AND ASSEMB- DIRECTORIES. +*---- + IF(LFLAT.AND.(IPASS.EQ.1).AND.(INDREC.EQ.2)) THEN + CALL LCMSIX(IPLI0,'SHIBA_SG',1) + CALL LCMSIX(IPLI0,HCAL,1) + DO IRES=1,NIRES + WRITE(CBDPNM,'(3HCOR,I4.4,1H/,I4.4)') IRES,NIRES + CALL LCMSIX(IPLI0,CBDPNM,1) + CALL LCMLEN(IPLI0,'GROUP-INFO',ILONG,ITYLCM) + IF(ILONG.GT.0) CALL LCMDEL(IPLI0,'GROUP-INFO') + CALL LCMLEN(IPLI0,'ASSEMB-PHYS',ILONG,ITYLCM) + IF(ILONG.GT.0) CALL LCMDEL(IPLI0,'ASSEMB-PHYS') + CALL LCMLEN(IPLI0,'ASSEMB-RIBON',ILONG,ITYLCM) + IF(ILONG.GT.0) CALL LCMDEL(IPLI0,'ASSEMB-RIBON') + CALL LCMLEN(IPLI0,'ASSEMB-RSE',ILONG,ITYLCM) + IF(ILONG.GT.0) CALL LCMDEL(IPLI0,'ASSEMB-RSE') + CALL LCMSIX(IPLI0,' ',2) + ENDDO + CALL LCMSIX(IPLI0,' ',2) + CALL LCMSIX(IPLI0,' ',2) + ENDIF +*---- +* PERFORM A SELF-SHIELDING CALCULATION NAMED HCAL. +*---- + CALL USSONE(IPLI0,IPTRK,IPLIB,IFTRAK,CDOOR,IMPX,IGRMIN,IGRMAX, + 1 NIRES,NBNRS,IREX,NGRP,NBMIX,NREG,NUN,NBISO,NL,NED,NDEL,ISONAM, + 2 IHSUF,HCAL,DEN,MIX,IAPT,MAT,VOL,KEYFLX,LEAKSW,ITRANC,IPHASE, + 3 TITR,KSPH,ICORR,ISUBG,MAXST) + 260 CONTINUE + 265 CONTINUE + 266 DEALLOCATE(LSHI2) + IF(IMPX.GE.4) CALL LCMLIB(IPLI0) +*---- +* BUILD THE MACROLIB IN THE OUTPUT INTERNAL LIBRARY. +*---- + ALLOCATE(MASK(NBMIX)) + DO 280 IBM=1,NBMIX + MASK(IBM)=.TRUE. + DO 270 I=1,NREG + IF(MAT(I).EQ.IBM) GO TO 280 + 270 CONTINUE + MASK(IBM)=.FALSE. + 280 CONTINUE + ALLOCATE(MASKL(NGRP)) + DO 290 I=1,NGRP + MASKL(I)=.TRUE. + 290 CONTINUE +* + ITSTMP=0 + TMPDAY(1)=0.0 + TMPDAY(2)=0.0 + TMPDAY(3)=0.0 + CALL KDRCPU(TK1) + CALL LCMLEN(IPLI0,'ISOTOPESUSED',ILENG,ITYLCM) + IF(ILENG.EQ.0) CALL XABORT('USSDRV: MISSING ISOTOPESUSED RECORD.') + CALL LCMGET(IPLI0,'ISOTOPESUSED',ISONAM) + CALL LIBMIX(IPLI0,NBMIX,NGRP,NBISO,ISONAM,MIX,DEN,MASK,MASKL, + 1 ITSTMP,TMPDAY) + CALL KDRCPU(TK2) + IF(IMPX.GT.1) WRITE(6,'(/37H USSDRV: CPU TIME SPENT TO BUILD THE , + 1 19HEMBEDDED MACROLIB =,F8.1,8H SECOND.)') TK2-TK1 + DEALLOCATE(MASKL,MASK) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(DEN,TN,VOL) + DEALLOCATE(ILLIB,IHLIB,IREX,IHSUF,IAPT,LSHI,ITYPE,IEVOL,MIX, + 1 ISONRF,ISONAM,KEYFLX,MAT) + RETURN +* + 410 FORMAT(/48H USSDRV: NUMBER OF CORRELATED RESONANT ISOTOPES=,I4/9X, + 1 35HNUMBER OF CORRELATED FUEL MIXTURES=,I4,19H IN RESONANT REGION, + 2 I3) + END diff --git a/Dragon/src/USSEXC.f b/Dragon/src/USSEXC.f new file mode 100644 index 0000000..92b5db4 --- /dev/null +++ b/Dragon/src/USSEXC.f @@ -0,0 +1,383 @@ +*DECK USSEXC + SUBROUTINE USSEXC(MAXNOR,CDOOR,IPLI0,IPTRK,IFTRAK,IMPX,NGRP,IGRP, + 1 IASM,NBMIX,NREG,NUN,NL,IPHASE,MAT,VOL,KEYFLX,IREX,SIGGAR,TITR, + 2 NIRES,IRES,NBNRS,NOR,CONR,IPPT1,IPPT2,STGAR,SSGAR,VOLMER,XFLUX, + 3 UNGAR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of the flux for the subgroup projection method (SPM) using +* the response matrix method. This is a non-iterative approach which is +* useful in exceptional cases where the fixed-point approach fails. +* +*Copyright: +* Copyright (C) 2010 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXNOR maximum order of the probability tables (PT). +* CDOOR name of the geometry/solution operator. +* IPLI0 pointer to the internal microscopic cross section library +* builded by the self-shielding module. +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK file unit number used to store the tracks. +* IMPX print flag (equal to zero for no print). +* NGRP number of energy groups. +* IGRP index of energy group being processed. +* IASM offset of information computed by DOORAV or DOORPV. +* NBMIX number of mixtures in the internal library. +* NREG number of regions. +* NUN number of unknowns in the flux or source vector in one +* energy group and one band. +* NL number of Legendre orders required in the calculation +* (NL=1 or higher). +* IPHASE type of flux solution (=1 use a native flux solution door; +* =2 use collision probabilities). +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX pointers of fluxes in unknown vector. +* IREX fuel region index assigned to each mixture. Equal to zero +* in non-resonant mixtures or in mixtures not used. +* SIGGAR macroscopic x-s of the non-resonant isotopes in each mixture: +* (*,*,*,1) total; (*,*,*,2) transport correction; +* (*,*,*,3) P0 scattering; (*,*,*,4) flux times P0 scattering. +* TITR title. +* NIRES exact number of correlated resonant isotopes. +* IRES index of the resonant isotope being processed. +* NBNRS number of correlated fuel regions. +* NOR exact order of the probability table. +* CONR number density of the resonant isotopes. +* IPPT1 pointer to LCM directory of each resonant isotope. +* IPPT2 information related to each resonant isotope: +* IPPT2(:,1) index of a resonant region (used with infinite +* dilution case); +* IPPT2(:,2:4) alias name of resonant isotope. +* STGAR averaged microscopic total xs in resonant region. +* SSGAR averaged microscopic scattering xs in resonant region. +* VOLMER volumes of the resonant and non-resonant regions. +* +*Parameters: input/output +* XFLUX subgroup flux. +* +*Parameters: output +* UNGAR averaged flux unknowns. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE DOORS_MOD +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLI0,IPTRK,IPPT1(NIRES) + INTEGER MAXNOR,IFTRAK,IMPX,NGRP,IGRP,IASM,NBMIX,NREG,NUN,NL, + 1 IPHASE,MAT(NREG),KEYFLX(NREG),IREX(NBMIX),NIRES,IRES,NBNRS, + 2 NOR(NIRES,NGRP),IPPT2(NIRES,4) + REAL VOL(NREG),SIGGAR(NBMIX,0:NIRES,NGRP,4),CONR(NBNRS,NIRES), + 1 STGAR(NBNRS,NIRES,NGRP),SSGAR(NBNRS,NIRES,NL,NGRP), + 2 VOLMER(0:NBNRS),XFLUX(NBNRS,MAXNOR),UNGAR(NUN,NIRES,NGRP) + CHARACTER CDOOR*12,TITR*72 +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPSYS,KPSYS,JPLIB,KPLIB,IPMACR,IPSOU + LOGICAL EMPTY,LCM,LEXAC,REBFLG + CHARACTER CBDPNM*12,TEXT12*12,TEXX12*12 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NPSYS + REAL, ALLOCATABLE, DIMENSION(:) :: AWPHI,FUN,SUN,SIGG + REAL, ALLOCATABLE, DIMENSION(:,:) :: WEIGH,TOTPT,SIGWS,PAV + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: MATRIX + TYPE(C_PTR) SIGP_PTR + REAL, POINTER, DIMENSION(:) :: SIGP +*---- +* STATEMENT FUNCTIONS +*---- + INM(IND,INOR,NBNRS)=(INOR-1)*NBNRS+IND +*---- +* SCRATCH STORAGE ALLOCATION +*---- + NORI=NOR(IRES,IGRP) + ALLOCATE(WEIGH(MAXNOR,NIRES),TOTPT(MAXNOR,NIRES), + 1 SIGWS(MAXNOR,NIRES),PAV(0:NBNRS,0:NBNRS),AWPHI(0:NBNRS), + 2 SIGG(0:NBMIX)) + ALLOCATE(MATRIX(NBNRS*NORI,NBNRS*NORI+1)) +*---- +* RECOVER THE SPECIFIC DIRECTORY FOR IRES-TH RESONANT ISOTOPE. +*---- + WRITE(CBDPNM,'(3HCOR,I4.4,1H/,I4.4)') IRES,NIRES + CALL LCMSIX(IPLI0,CBDPNM,1) + IPSYS=LCMGID(IPLI0,'ASSEMB-RIBON') + CALL LCMSIX(IPLI0,' ',2) +*---- +* COMPUTE THE AVERAGED COLLISION PROBABILITY MATRIX. +*---- + ALLOCATE(NPSYS(NORI*(NBNRS+1))) + ALLOCATE(FUN(NUN*NORI*(NBNRS+1)),SUN(NUN*NORI*(NBNRS+1))) + FUN(:NUN*NORI*(NBNRS+1))=0.0 + SUN(:NUN*NORI*(NBNRS+1))=0.0 + DO 50 INOR=1,NORI + DO 40 JNBN=0,NBNRS + NPSYS((INOR-1)*(NBNRS+1)+JNBN+1)=IASM+INOR + T1=0.0 + DO 10 I=1,NREG + IBM=MAT(I) + IF(IBM.EQ.0) GO TO 10 + IND=IREX(IBM) + IF((JNBN.EQ.0).AND.(IND.EQ.0)) THEN + T1=T1+SIGGAR(IBM,0,IGRP,3)*VOL(I) + ELSE IF(IND.EQ.JNBN) THEN + T1=T1+VOL(I) + ENDIF + 10 CONTINUE + SIGG(0:NBMIX)=0.0 + DO 20 IBM=1,NBMIX + IND=IREX(IBM) + IF((JNBN.EQ.0).AND.(IND.EQ.0)) THEN + SIGG(IBM)=SIGG(IBM)+SIGGAR(IBM,0,IGRP,3) + ELSE IF(IND.EQ.JNBN) THEN + SIGG(IBM)=SIGG(IBM)+1.0 + ENDIF + 20 ENDDO + IOF=(INOR-1)*NUN*(NBNRS+1)+JNBN*NUN + CALL DOORS(CDOOR,IPTRK,NBMIX,0,NUN,SIGG,SUN(IOF+1)) + DO 30 I=1,NUN + IF(T1.NE.0.0) SUN(IOF+I)=SUN(IOF+I)/T1 + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE +*---- +* SOLVE FOR THE MULTIBAND FLUX. +*---- + IDIR=0 + NABS=NORI*(NBNRS+1) + LEXAC=.FALSE. + IPMACR=C_NULL_PTR + IPSOU=C_NULL_PTR + REBFLG=.FALSE. + CALL DOORFV(CDOOR,IPSYS,NPSYS,IPTRK,IFTRAK,IMPX,NABS,NBMIX, + 1 IDIR,NREG,NUN,IPHASE,LEXAC,MAT,VOL,KEYFLX,TITR,SUN,FUN,IPMACR, + 2 IPSOU,REBFLG) +*---- +* HOMOGENIZE THE MULTIBAND FLUX. +*---- + DO 170 INOR=1,NORI + PAV(0:NBNRS,0:NBNRS)=0.0 + DO 155 JNBN=0,NBNRS + DO 150 I=1,NREG + IBM=MAT(I) + IF(IBM.EQ.0) GO TO 150 + IOF=(INOR-1)*NUN*(NBNRS+1)+JNBN*NUN+KEYFLX(I)-1 + PAV(IREX(IBM),JNBN)=PAV(IREX(IBM),JNBN)+FUN(IOF+1)*VOL(I) + 150 CONTINUE + 155 CONTINUE + DO 165 I=0,NBNRS + DO 160 J=0,NBNRS + IF(VOLMER(I).NE.0.0) PAV(I,J)=PAV(I,J)*VOLMER(J)/VOLMER(I) + 160 CONTINUE + 165 CONTINUE + KPSYS=LCMGIL(IPSYS,IASM+INOR) + CALL LCMPUT(KPSYS,'DRAGON-PAV',(NBNRS+1)**2,2,PAV(0,0)) + 170 CONTINUE + DEALLOCATE(SUN,FUN,NPSYS) +*---- +* COLLECT THE BASE POINTS IN TOTAL AND PARTIAL CROSS SECTION. +*---- + DO 200 JRES=1,NIRES + JPLIB=LCMGID(IPPT1(JRES),'GROUP-PT') + CALL LCMLEL(JPLIB,IGRP,ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + KPLIB=LCMGIL(JPLIB,IGRP) + CALL LCMINF(KPLIB,TEXT12,TEXX12,EMPTY,ILONG,LCM) + CALL LCMLEN(KPLIB,'PROB-TABLE',LENG,ITYLCM) + NPART=LENG/MAXNOR + IF(LCM) THEN + CALL LCMGPD(KPLIB,'PROB-TABLE',SIGP_PTR) + CALL C_F_POINTER(SIGP_PTR,SIGP,(/ MAXNOR*NPART /)) + ELSE + ALLOCATE(SIGP(MAXNOR*NPART)) + CALL LCMGET(KPLIB,'PROB-TABLE',SIGP) + ENDIF + DO 190 INOR=1,NOR(JRES,IGRP) + WEIGH(INOR,JRES)=SIGP(INOR) + TOTPT(INOR,JRES)=SIGP(MAXNOR+INOR) + SIGWS(INOR,JRES)=SIGP(3*MAXNOR+INOR) + 190 CONTINUE + IF(.NOT.LCM) DEALLOCATE(SIGP) + ELSE + WEIGH(1,JRES)=1.0 + TOTPT(1,JRES)=STGAR(IPPT2(JRES,1),JRES,IGRP) + SIGWS(1,JRES)=SSGAR(IPPT2(JRES,1),JRES,1,IGRP) + ENDIF + 200 CONTINUE +*---- +* RESPONSE MATRIX APPROACH. LOOP OVER THE SECONDARY SUBGROUPS. +*---- + DO 272 INOR=1,NORI + KPSYS=LCMGIL(IPSYS,IASM+INOR) + CALL LCMGET(KPSYS,'DRAGON-PAV',PAV(0,0)) +*---- +* LOOP OVER THE PRIMARY SUBGROUPS. NORI+1 IS THE SOURCE. +*---- + DO 271 JNOR=1,NORI+1 + IF(JNOR.LE.NORI) THEN + JNBMAX=NBNRS + ELSE + JNBMAX=1 + ENDIF + DO 270 JNBN=1,JNBMAX + AWPHI(1:NBNRS)=0.0 + DO 250 I=1,NREG + IBM=MAT(I) + IF(IBM.EQ.0) GO TO 250 + JND=IREX(IBM) + QQQ=0.0 + IF(JNOR.EQ.NORI+1) THEN + DO 230 JRES=0,NIRES + IF(JRES.EQ.0) THEN + QQQ=QQQ+SIGGAR(IBM,0,IGRP,3) + ELSE IF((JRES.NE.IRES).AND.(JND.GT.0)) THEN + QQQ=QQQ+SIGGAR(IBM,JRES,IGRP,4) + ENDIF + 230 CONTINUE + ELSE IF((JND.EQ.JNBN).AND.(JNOR.NE.INOR)) THEN + QQQ=QQQ-WEIGH(JNOR,IRES)*CONR(JND,IRES)*SIGWS(JNOR,IRES) + ENDIF + DO 240 IND=1,NBNRS + AWPHI(IND)=AWPHI(IND)+PAV(IND,JND)*QQQ*VOL(I)/VOLMER(JND) + 240 CONTINUE + 250 CONTINUE + DO 260 IND=1,NBNRS + MATRIX(INM(IND,INOR,NBNRS),INM(JNBN,JNOR,NBNRS))=AWPHI(IND) + 260 CONTINUE + 270 CONTINUE + 271 CONTINUE + 272 CONTINUE +* + DO 280 I=1,NBNRS*NORI + MATRIX(I,I)=MATRIX(I,I)+1.0D0 + 280 CONTINUE + CALL ALSBD(NBNRS*NORI,1,MATRIX,IER,NBNRS*NORI) + IF(IER.NE.0) CALL XABORT('USSEXC: SINGULAR MATRIX.') + XFLUX(:NBNRS,:NORI)=0.0 + DO 295 IND=1,NBNRS + DO 290 INOR=1,NORI + I1=INM(IND,INOR,NBNRS) + XFLUX(IND,INOR)=REAL(MATRIX(I1,NBNRS*NORI+1)) + 290 CONTINUE + 295 CONTINUE +* END OF RESPONSE MATRIX APPROACH. +* +*---- +* COLLECT THE BASE POINTS IN PARTIAL CROSS SECTION. +*---- + DO 340 JRES=1,NIRES + JPLIB=LCMGID(IPPT1(JRES),'GROUP-PT') + CALL LCMLEL(JPLIB,IGRP,ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + KPLIB=LCMGIL(JPLIB,IGRP) + CALL LCMINF(KPLIB,TEXT12,TEXX12,EMPTY,ILONG,LCM) + CALL LCMLEN(KPLIB,'PROB-TABLE',LENG,ITYLCM) + NPART=LENG/MAXNOR + IF(LCM) THEN + CALL LCMGPD(KPLIB,'PROB-TABLE',SIGP_PTR) + CALL C_F_POINTER(SIGP_PTR,SIGP,(/ MAXNOR*NPART /)) + ELSE + ALLOCATE(SIGP(MAXNOR*NPART)) + CALL LCMGET(KPLIB,'PROB-TABLE',SIGP) + ENDIF + DO 330 INOR=1,NOR(JRES,IGRP) + WEIGH(INOR,JRES)=SIGP(INOR) + SIGWS(INOR,JRES)=SIGP(3*MAXNOR+INOR) + 330 CONTINUE + IF(.NOT.LCM) DEALLOCATE(SIGP) + ELSE + WEIGH(1,JRES)=1.0 + SIGWS(1,JRES)=SSGAR(IPPT2(JRES,1),JRES,1,IGRP) + ENDIF + 340 CONTINUE +*---- +* COMPUTE THE AVERAGED SOURCE. +*---- + ALLOCATE(FUN(NUN*NORI),SUN(NUN*NORI)) + SUN(:NUN*NORI)=0.0 + ALLOCATE(NPSYS(NORI)) + DO 385 INOR=1,NORI + NPSYS(INOR)=IASM+INOR + KPSYS=LCMGIL(IPSYS,IASM+INOR) + CALL LCMLEN(KPSYS,'FUNKNO$USS',ILENG,ITYLCM) + IF(ILENG.EQ.NUN) THEN + CALL LCMGET(KPSYS,'FUNKNO$USS',FUN((INOR-1)*NUN+1)) + ELSE + FUN((INOR-1)*NUN+1:INOR*NUN)=0.0 + ENDIF + SIGG(0)=0.0 + DO 380 IBM=1,NBMIX + QQQ=SIGGAR(IBM,0,IGRP,3) + IND=IREX(IBM) + DO 360 JRES=1,NIRES + IF((JRES.NE.IRES).AND.(IND.GT.0)) THEN + QQQ=QQQ+SIGGAR(IBM,JRES,IGRP,4) + ENDIF + 360 CONTINUE + IF(IND.GT.0) THEN + DO 370 JNOR=1,NORI + IF(JNOR.NE.INOR) THEN + QQQ=QQQ+WEIGH(JNOR,IRES)*CONR(IND,IRES)*SIGWS(JNOR,IRES)* + 1 XFLUX(IND,JNOR) + ENDIF + 370 CONTINUE + ENDIF + SIGG(IBM)=QQQ*WEIGH(INOR,IRES) + 380 CONTINUE + IOF=(INOR-1)*NUN + CALL DOORS(CDOOR,IPTRK,NBMIX,0,NUN,SIGG,SUN(IOF+1)) + 385 CONTINUE +* + IF(IMPX.GT.0) THEN + WRITE(TEXT12,'(3A4)') (IPPT2(IRES,I),I=2,4) + WRITE(6,'(15H USSEXC: GROUP=,I5,24H. SUBGROUP CALCULATION B, + 1 37HASED ON RESPONSE MATRICES. ISOTOPE='',A12,2H''.)') IGRP, + 2 TEXT12 + ENDIF +*---- +* SOLVE FOR THE MULTIBAND FLUX (VECTOR OF LENGTH NREG). +*---- + IPMACR=C_NULL_PTR + IPSOU=C_NULL_PTR + REBFLG=.FALSE. + CALL DOORFV(CDOOR,IPSYS,NPSYS,IPTRK,IFTRAK,IMPX,NORI,NBMIX,IDIR, + 1 NREG,NUN,IPHASE,LEXAC,MAT,VOL,KEYFLX,TITR,SUN,FUN,IPMACR,IPSOU, + 2 REBFLG) + DEALLOCATE(NPSYS) +*---- +* INTEGRATE THE REGION-ORDERED FLUX OVER SUBGROUPS AND COMPUTE UNGAR, +* THE REGION-ORDERED FLUX. +*---- + UNGAR(:NREG,IRES,IGRP)=0.0 + DO 420 INOR=1,NORI + KPSYS=LCMGIL(IPSYS,IASM+INOR) + IOF=(INOR-1)*NUN + CALL LCMPUT(KPSYS,'FUNKNO$USS',NUN,2,FUN(IOF+1)) +* + DO 410 I=1,NREG + IOF=(INOR-1)*NUN+KEYFLX(I)-1 + UNGAR(I,IRES,IGRP)=UNGAR(I,IRES,IGRP)+FUN(IOF+1) + 410 CONTINUE + 420 CONTINUE + DEALLOCATE(SUN,FUN) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(MATRIX) + DEALLOCATE(SIGG,AWPHI,PAV,SIGWS,TOTPT,WEIGH) + RETURN + END diff --git a/Dragon/src/USSEXD.f b/Dragon/src/USSEXD.f new file mode 100644 index 0000000..31f7622 --- /dev/null +++ b/Dragon/src/USSEXD.f @@ -0,0 +1,377 @@ +*DECK USSEXD + SUBROUTINE USSEXD(MAXNOR,CDOOR,IPLI0,IPTRK,IFTRAK,IMPX,NGRP,IG, + 1 IASM,NBMIX,NREG,NUN,IPHASE,MAT,VOL,KEYFLX,IREX,SIGGAR,TITR,NIRES, + 2 IRES,NBNRS,MRANK,CONR,GOLD,IPPT1,IPPT2,VOLMER,XFLUX,UNGAR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of the flux for the resonance spectrum expansion (RSE) method +* using the response matrix method. This is a non-iterative approach +* which is useful in exceptional cases where the fixed-point approach +* fails. +* +*Copyright: +* Copyright (C) 2024 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXNOR maximum order of the probability tables (RSE). +* CDOOR name of the geometry/solution operator. +* IPLI0 pointer to the internal microscopic cross section library +* builded by the self-shielding module. +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK file unit number used to store the tracks. +* IMPX print flag (equal to zero for no print). +* NGRP number of energy groups. +* IG index of energy group being processed. +* IASM offset of information computed by DOORAV or DOORPV. +* NBMIX number of mixtures in the internal library. +* NREG number of regions. +* NUN number of unknowns in the flux or source vector in one +* energy group and one band. +* IPHASE type of flux solution (=1 use a native flux solution door; +* =2 use collision probabilities). +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX pointers of fluxes in unknown vector. +* IREX fuel region index assigned to each mixture. Equal to zero +* in non-resonant mixtures or in mixtures not used. +* SIGGAR macroscopic x-s of the non-resonant isotopes in each mixture: +* (*,*,*,1) total; (*,*,*,2) transport correction; +* (*,*,*,3) P0 scattering. +* TITR title. +* NIRES exact number of correlated resonant isotopes. +* IRES index of the resonant isotope being processed. +* NBNRS number of correlated fuel regions. +* MRANK exact order of the probability table. +* CONR number density of the resonant isotopes. +* GOLD type of self-shielding model (=1.0 physical probability +* tables; =-1001.0 resonance spectrum expansion method). +* IPPT1 pointer to LCM directory of each resonant isotope. +* IPPT2 information related to each resonant isotope: +* IPPT2(:,1) index of a resonant region (used with infinite +* dilution case); +* IPPT2(:,2:4) alias name of resonant isotope. +* VOLMER volumes of the resonant and non-resonant regions. +* +*Parameters: input/output +* XFLUX subgroup flux. +* +*Parameters: output +* UNGAR averaged fluxes per volume. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE DOORS_MOD +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLI0,IPTRK,IPPT1(NIRES) + INTEGER MAXNOR,IFTRAK,IMPX,NGRP,IG,IASM,NBMIX,NREG,NUN,IPHASE, + 1 MAT(NREG),KEYFLX(NREG),IREX(NBMIX),NIRES,IRES,NBNRS,MRANK(NGRP), + 2 IPPT2(NIRES,4) + REAL VOL(NREG),SIGGAR(NBMIX,0:NIRES,NGRP,3),CONR(NBNRS,NIRES), + 1 GOLD(NIRES,NGRP),VOLMER(0:NBNRS), + 2 XFLUX(NBNRS,MAXNOR,NGRP),UNGAR(NREG,NIRES,NGRP) + CHARACTER CDOOR*12,TITR*72 +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPSYS,KPSYS,IPMACR,IPSOU,IPLIB,JPLIB1,KPLIB,IOFSET + DOUBLE PRECISION QQQ,SSS,T1 + LOGICAL LEXAC,REBFLG + CHARACTER CBDPNM*12,TEXT12*12 + TYPE VECTOR_ARRAY + DOUBLE PRECISION, POINTER, DIMENSION(:) :: VECTOR + END TYPE VECTOR_ARRAY + TYPE(VECTOR_ARRAY) :: WEIGHT_V,GAMMA_V +*---- +* ALLOCATABLE ARRAYS +*---- + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: JPLIB2 + INTEGER, ALLOCATABLE, DIMENSION(:) :: NPSYS + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NJJ + REAL, ALLOCATABLE, DIMENSION(:) :: AWPHI,FUN,SUN,SIGG + REAL, ALLOCATABLE, DIMENSION(:,:) :: PAV + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: MATRIX + TYPE MATRIX_ARRAY + DOUBLE PRECISION, POINTER, DIMENSION(:,:) :: MATRIX + END TYPE MATRIX_ARRAY + TYPE(MATRIX_ARRAY), ALLOCATABLE, DIMENSION(:,:) :: SCAT_M +*---- +* STATEMENT FUNCTIONS +*---- + INM(IND,IM,NBNRS)=(IM-1)*NBNRS+IND +*---- +* SCRATCH STORAGE ALLOCATION +*---- + MI=MRANK(IG) + ALLOCATE(NJJ(NGRP,NIRES)) + ALLOCATE(PAV(0:NBNRS,0:NBNRS),AWPHI(0:NBNRS)) + ALLOCATE(MATRIX(NBNRS*MI,NBNRS*MI+1)) + ALLOCATE(JPLIB2(NIRES),SCAT_M(NGRP,NIRES),SIGG(0:NBMIX)) +*---- +* RECOVER RSE INFORMATION FROM MICROLIB +*---- + IPLIB=IPPT1(IRES) + JPLIB1=LCMGID(IPLIB,'GROUP-RSE') + DO JRES=1,NIRES + WRITE(TEXT12,'(3A4)') (IPPT2(JRES,I),I=2,4) + CALL LCMSIX(IPLIB,TEXT12,1) + JPLIB2(JRES)=LCMGID(IPLIB,'SCAT_M') ! SCAT_M information + CALL LCMGET(IPLIB,'NJJS00',NJJ(:NGRP,JRES)) + CALL LCMSIX(IPLIB,' ',2) + ENDDO + KPLIB=LCMGIL(JPLIB1,IG) + CALL LCMGPD(KPLIB,'WEIGHT_V',IOFSET) + CALL C_F_POINTER(IOFSET,WEIGHT_V%VECTOR,(/MI/)) + CALL LCMGPD(KPLIB,'GAMMA_V',IOFSET) + CALL C_F_POINTER(IOFSET,GAMMA_V%VECTOR,(/MI/)) + DO JRES=1,NIRES + IPOS=1 + DO JG=1,IG-1 + IPOS=IPOS+NJJ(JG,JRES) + ENDDO + DO JG=IG-NJJ(IG,JRES)+1,IG + MJ=MRANK(JG) + CALL LCMGPL(JPLIB2(JRES),IPOS+IG-JG,IOFSET) + CALL C_F_POINTER(IOFSET,SCAT_M(JG,JRES)%MATRIX,(/MI,MJ/)) + ENDDO + ENDDO +*---- +* RECOVER THE SPECIFIC DIRECTORY FOR IRES-TH RESONANT ISOTOPE. +*---- + WRITE(CBDPNM,'(3HCOR,I4.4,1H/,I4.4)') IRES,NIRES + CALL LCMSIX(IPLI0,CBDPNM,1) + IPSYS=LCMGID(IPLI0,'ASSEMB-RSE') + CALL LCMSIX(IPLI0,' ',2) +*---- +* COMPUTE THE AVERAGED COLLISION PROBABILITY MATRIX. +*---- + ALLOCATE(NPSYS(MI*(NBNRS+1))) + ALLOCATE(FUN(NUN*MI*(NBNRS+1)),SUN(NUN*MI*(NBNRS+1))) + FUN(:NUN*MI*(NBNRS+1))=0.0 + SUN(:NUN*MI*(NBNRS+1))=0.0 + DO 50 IM=1,MI + DO 40 JNBN=0,NBNRS + NPSYS((IM-1)*(NBNRS+1)+JNBN+1)=IASM+IM + T1=0.0D0 + DO 10 I=1,NREG + IBM=MAT(I) + IF(IBM.EQ.0) GO TO 10 + IND=IREX(IBM) + IF((JNBN.EQ.0).AND.(IND.EQ.0)) THEN + SSS=SIGGAR(IBM,0,IG,3)*GAMMA_V%VECTOR(IM) + T1=T1+SSS*VOL(I) + ELSE IF(IND.EQ.JNBN) THEN + T1=T1+VOL(I) + ENDIF + 10 CONTINUE + IOF=(IM-1)*NUN*(NBNRS+1)+JNBN*NUN + SIGG(0:NBMIX)=0.0 + DO 20 IBM=1,NBMIX + IND=IREX(IBM) + IF((JNBN.EQ.0).AND.(IND.EQ.0)) THEN + SSS=SIGGAR(IBM,0,IG,3)*GAMMA_V%VECTOR(IM) + SIGG(IBM)=REAL(SSS,4) + ELSE IF(IND.EQ.JNBN) THEN + SIGG(IBM)=1.0 + ENDIF + 20 CONTINUE + CALL DOORS(CDOOR,IPTRK,NBMIX,0,NUN,SIGG,SUN(IOF+1)) + DO 30 I=1,NUN + IF(T1.NE.0.0) SUN(IOF+I)=SUN(IOF+I)/REAL(T1,4) + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE +*---- +* SOLVE FOR THE MULTIBAND FLUX. +*---- + IDIR=0 + NABS=MI*(NBNRS+1) + LEXAC=.FALSE. + IPMACR=C_NULL_PTR + IPSOU=C_NULL_PTR + REBFLG=.FALSE. + CALL DOORFV(CDOOR,IPSYS,NPSYS,IPTRK,IFTRAK,IMPX,NABS,NBMIX, + 1 IDIR,NREG,NUN,IPHASE,LEXAC,MAT,VOL,KEYFLX,TITR,SUN,FUN,IPMACR, + 2 IPSOU,REBFLG) +*---- +* HOMOGENIZE THE MULTIBAND FLUX. +*---- + DO 100 IM=1,MI + PAV(0:NBNRS,0:NBNRS)=0.0 + DO 70 JNBN=0,NBNRS + DO 60 I=1,NREG + IBM=MAT(I) + IF(IBM.EQ.0) GO TO 60 + IOF=(IM-1)*NUN*(NBNRS+1)+JNBN*NUN+KEYFLX(I)-1 + PAV(IREX(IBM),JNBN)=PAV(IREX(IBM),JNBN)+FUN(IOF+1)*VOL(I) + 60 CONTINUE + 70 CONTINUE + DO 90 I=0,NBNRS + DO 80 J=0,NBNRS + IF(VOLMER(I).NE.0.0) PAV(I,J)=PAV(I,J)*VOLMER(J)/VOLMER(I) + 80 CONTINUE + 90 CONTINUE + KPSYS=LCMGIL(IPSYS,IASM+IM) + CALL LCMPUT(KPSYS,'DRAGON-PAV',(NBNRS+1)**2,2,PAV(0,0)) + 100 CONTINUE + DEALLOCATE(SUN,FUN,NPSYS) +*---- +* RESPONSE MATRIX APPROACH. LOOP OVER THE SECONDARY SUBGROUPS. +*---- + MATRIX(:NBNRS*MI,:NBNRS*MI+1)=0.0D0 + DO 200 IM=1,MI + KPSYS=LCMGIL(IPSYS,IASM+IM) + CALL LCMGET(KPSYS,'DRAGON-PAV',PAV(0,0)) +*---- +* LOOP OVER THE PRIMARY SUBGROUPS. MI+1 IS THE SOURCE. +*---- + DO 190 JM=1,MI+1 + IF(JM.LE.MI) THEN + JNBMAX=NBNRS + ELSE + JNBMAX=1 + ENDIF + DO 180 JNBN=1,JNBMAX + AWPHI(1:NBNRS)=0.0 + DO 160 I=1,NREG + IBM=MAT(I) + IF(IBM.EQ.0) GO TO 160 + JND=IREX(IBM) + QQQ=0.0D0 + IF(JM.EQ.MI+1) THEN + QQQ=QQQ+SIGGAR(IBM,0,IG,3)*GAMMA_V%VECTOR(IM) + IF(JND.NE.0) THEN + DO 130 JRES=1,NIRES + DENSIT=CONR(JND,JRES) + DO 120 JG=IG-NJJ(IG,JRES)+1,IG-1 + IF(GOLD(IRES,JG).NE.-1001.) CYCLE + DO 110 KM=1,MRANK(JG) + QQQ=QQQ+DENSIT*SCAT_M(JG,JRES)%MATRIX(IM,KM)* + 1 XFLUX(JND,KM,JG) + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + ENDIF + ELSE IF((JND.EQ.JNBN).AND.(JM.NE.IM)) THEN + DO 140 JRES=1,NIRES + DENSIT=CONR(JND,JRES) + IF(GOLD(IRES,IG).NE.-1001.) CYCLE + IF(JM.EQ.IM) CYCLE + QQQ=QQQ-DENSIT*SCAT_M(IG,JRES)%MATRIX(IM,JM) + 140 CONTINUE + ENDIF + DO 150 IND=1,NBNRS + AWPHI(IND)=AWPHI(IND)+PAV(IND,JND)*REAL(QQQ,4)*VOL(I)/VOLMER(JND) + 150 CONTINUE + 160 CONTINUE + DO 170 IND=1,NBNRS + MATRIX(INM(IND,IM,NBNRS),INM(JNBN,JM,NBNRS))=AWPHI(IND) + 170 CONTINUE + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE +* + DO 210 I=1,NBNRS*MI + MATRIX(I,I)=MATRIX(I,I)+1.0D0 + 210 CONTINUE + CALL ALSBD(NBNRS*MI,1,MATRIX,IER,NBNRS*MI) + IF(IER.NE.0) CALL XABORT('USSEXD: SINGULAR MATRIX.') + XFLUX(:NBNRS,:MAXNOR,IG)=0.0 + DO 230 IND=1,NBNRS + DO 220 IM=1,MI + I1=INM(IND,IM,NBNRS) + XFLUX(IND,IM,IG)=REAL(MATRIX(I1,NBNRS*MI+1)) + 220 CONTINUE + 230 CONTINUE +* END OF RESPONSE MATRIX APPROACH. +*---- +* COMPUTE THE AVERAGED SOURCE. +*---- + ALLOCATE(FUN(NUN*MI),SUN(NUN*MI)) + SUN(:NUN*MI)=0.0 + ALLOCATE(NPSYS(MI)) + DO 250 IM=1,MI + NPSYS(IM)=IASM+IM + KPSYS=LCMGIL(IPSYS,IASM+IM) + CALL LCMLEN(KPSYS,'FUNKNO$USS',ILENG,ITYLCM) + IF(ILENG.EQ.NUN) THEN + CALL LCMGET(KPSYS,'FUNKNO$USS',FUN((IM-1)*NUN+1)) + ELSE + FUN((IM-1)*NUN+1:IM*NUN)=0.0 + ENDIF + SIGG(0:NBMIX)=0.0 + DO 240 IBM=1,NBMIX + IND=IREX(IBM) + QQQ=SIGGAR(IBM,0,IG,3)*GAMMA_V%VECTOR(IM) + IF(IND.GT.0) THEN + DO JG=1,IG + DO JRES=1,NIRES + IF(GOLD(IRES,JG).NE.-1001.) CYCLE + IF(JG.LT.IG-NJJ(IG,JRES)+1) CYCLE + DENSIT=CONR(IND,JRES) + DO JM=1,MRANK(JG) + IF((JG.EQ.IG).AND.(JM.EQ.IM)) CYCLE + QQQ=QQQ+DENSIT*SCAT_M(JG,JRES)%MATRIX(IM,JM)* + 1 XFLUX(IND,JM,JG) + ENDDO + ENDDO + ENDDO + ENDIF + SIGG(IBM)=REAL(QQQ,4) + 240 CONTINUE + IOF=(IM-1)*NUN + CALL DOORS(CDOOR,IPTRK,NBMIX,0,NUN,SIGG,SUN(IOF+1)) + 250 CONTINUE +* + IF(IMPX.GT.0) THEN + WRITE(TEXT12,'(3A4)') (IPPT2(IRES,I),I=2,4) + WRITE(6,'(15H USSEXD: GROUP=,I5,24H. SUBGROUP CALCULATION B, + 1 37HASED ON RESPONSE MATRICES. ISOTOPE='',A12,2H''.)') IG, + 2 TEXT12 + ENDIF +*---- +* SOLVE FOR THE MULTIBAND FLUX (VECTOR OF LENGTH NREG). +*---- + IPMACR=C_NULL_PTR + IPSOU=C_NULL_PTR + REBFLG=.FALSE. + CALL DOORFV(CDOOR,IPSYS,NPSYS,IPTRK,IFTRAK,IMPX,MI,NBMIX,IDIR, + 1 NREG,NUN,IPHASE,LEXAC,MAT,VOL,KEYFLX,TITR,SUN,FUN,IPMACR,IPSOU, + 2 REBFLG) + DEALLOCATE(NPSYS) +*---- +* INTEGRATE THE REGION-ORDERED FLUX OVER SUBGROUPS AND COMPUTE UNGAR, +* THE REGION-ORDERED FLUX. +*---- + UNGAR(:NREG,IRES,IG)=0.0 + DO 270 IM=1,MI + KPSYS=LCMGIL(IPSYS,IASM+IM) + IOF=(IM-1)*NUN + CALL LCMPUT(KPSYS,'FUNKNO$USS',NUN,2,FUN(IOF+1)) +* + DO 260 I=1,NREG + IOF=(IM-1)*NUN+KEYFLX(I) + UNGAR(I,IRES,IG)=UNGAR(I,IRES,IG)+REAL(WEIGHT_V%VECTOR(IM)* + 1 FUN(IOF),4) + 260 CONTINUE + 270 CONTINUE + DEALLOCATE(SUN,FUN) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SIGG,SCAT_M,JPLIB2) + DEALLOCATE(MATRIX) + DEALLOCATE(AWPHI,PAV) + DEALLOCATE(NJJ) + RETURN + END diff --git a/Dragon/src/USSFLU.f b/Dragon/src/USSFLU.f new file mode 100644 index 0000000..a21aad9 --- /dev/null +++ b/Dragon/src/USSFLU.f @@ -0,0 +1,499 @@ +*DECK USSFLU + SUBROUTINE USSFLU(IPTRK,IPLIB,IPLI0,IFTRAK,NREG,NUN,NBMIX,NBISO, + 1 NIRES,NL,NED,NDEL,ISONAM,ISOBIS,HCAL,MAT,VOL,KEYFLX,CDOOR, + 2 LEAKSW,IMPX,DEN,MIX,IAPT,IPHASE,NGRP,IGRMIN,IGRMAX,NBNRS,IREX, + 3 TITR,ICORR,ISUBG,MAXST,GOLD,UNGAR,PHGAR,STGAR,SFGAR,SSGAR,S0GAR, + 4 SAGAR,SDGAR,SWGAR,MASKG,SIGGAR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the self-shielded cross sections in each energy group using a +* subgroup approach. +* +*Copyright: +* Copyright (C) 2003 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK pointer to the tracking (L_TRACK signature). +* IPLIB pointer to the internal microscopic cross section library +* with subgroups (L_LIBRARY signature). +* IPLI0 pointer to the internal microscopic cross section library +* builded by the self-shielding module. +* IFTRAK file unit number used to store the tracks. +* NREG number of regions. +* NUN number of unknowns per energy group and band. +* NBMIX number of mixtures in the internal library. +* NBISO number of isotopes. +* NIRES number of correlated resonant isotopes. +* NL number of legendre orders required in the calculation +* (NL=1 or higher). +* NED number of extra vector edits. +* NDEL number of delayed neutron precursor groups. +* ISONAM alias name of isotopes in IPLIB. +* ISOBIS alias name of isotopes in IPLI0. +* HCAL name of the self-shielding calculation. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX pointers of fluxes in unknown vector. +* CDOOR name of the geometry/solution operator. +* LEAKSW leakage flag (LEAKSW=.true. if neutron leakage through +* external boundary is present). +* IMPX print flag (equal to zero for no print). +* DEN density of each isotope. +* MIX mix number of each isotope (can be zero). +* IAPT resonant isotope index associated with isotope I. Mixed +* moderator if IAPT(I)=NIRES+1. Out-of-fuel isotope if +* IAPT(I)=0. +* IPHASE type of flux solution (=1 use a native flux solution door; +* =2 use collision probabilities). +* NGRP number of energy groups. +* IGRMIN first group where the self-shielding is applied. +* IGRMAX most thermal group where the self-shielding is applied. +* NBNRS number of correlated fuel regions. Note that NBNRS=max(IREX). +* IREX fuel region index assigned to each mixture. Equal to zero +* in non-resonant mixtures or in mixtures not used. +* TITR title. +* ICORR mutual resonance shielding flag (=1 to suppress the model +* in cases it is required in LIB operator). +* ISUBG type of self-shielding model (=1 use physical probability +* tables; =3 use original Ribon method; =4 use Ribon extended +* method). +* MAXST maximum number of fixed point iterations for the ST scattering +* source. +* +*Parameters: output +* GOLD Goldstein-Cohen parameters. +* UNGAR averaged flux unknowns. +* PHGAR averaged fluxes in correlated fuel regions. +* STGAR microscopic self-shielded total x-s. +* SFGAR microscopic self-shielded fission x-s. +* SSGAR microscopic self-shielded scattering x-s. +* S0GAR microscopic transfer scattering xs (isotope,secondary, +* primary). +* SAGAR microscopic self-shielded additional xs. +* SDGAR microscopic self-shielded delayed nu-sigf xs. +* SWGAR microscopic secondary slowing-down cross sections (ISUBG=4). +* ISMIN first secondary group indices. +* ISMAX last secondary group indices. +* MASKG energy group mask pointing on self-shielded groups. +* SIGGAR macroscopic x-s of the non-resonant isotopes in each mixture: +* (*,*,*,1) total; (*,*,*,2) transport correction; +* (*,*,*,3) P0 scattering; (*,*,*,4) flux times P0 scattering. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPLIB,IPLI0 + INTEGER IFTRAK,NREG,NUN,NBMIX,NBISO,NIRES,NL,NED,NDEL, + 1 ISONAM(3,NBISO),ISOBIS(3,NBISO),MAT(NREG),KEYFLX(NREG),IMPX, + 2 MIX(NBISO),IAPT(NBISO),IPHASE,NGRP,IGRMIN,IGRMAX,NBNRS, + 3 IREX(NBMIX),ICORR,ISUBG,MAXST + REAL VOL(NREG),DEN(NBISO),GOLD(NIRES,NGRP),UNGAR(NUN,NIRES,NGRP), + 1 PHGAR(NBNRS,NIRES,NGRP),STGAR(NBNRS,NIRES,NGRP), + 2 SFGAR(NBNRS,NIRES,NGRP),SSGAR(NBNRS,NIRES,NL,NGRP), + 3 S0GAR(NBNRS,NIRES,NL,NGRP,NGRP),SAGAR(NBNRS,NIRES,NED,NGRP), + 4 SDGAR(NBNRS,NIRES,NDEL,NGRP),SWGAR(NBNRS,NIRES,NGRP), + 5 SIGGAR(NBMIX,0:NIRES,NGRP,4) + LOGICAL LEAKSW,MASKG(NGRP,NIRES) + CHARACTER HCAL*12,CDOOR*12,TITR*72 +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPP,KPLIB,LPLIB,MPLIB,JPLI0,KPLI0 + LOGICAL LRES,LLIB,LRIB + PARAMETER (MAXED=50,MAXNOR=12) + CHARACTER TEXT12*12,HVECT(MAXED)*8,CBDPNM*12,HSMG*131 +*---- +* ALLOCATABLE ARRAYS +*---- + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPPT1,IPISO1,IPISO2 + INTEGER, ALLOCATABLE, DIMENSION(:) :: IWRK + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NOR,IPPT2,ISM,ISMIN,ISMAX + REAL, ALLOCATABLE, DIMENSION(:) :: GAS,GA1,VOLMER,DELTA,GOLD2 + REAL, ALLOCATABLE, DIMENSION(:,:) :: GA2,CONR,XFLUX +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IPPT1(NIRES)) + ALLOCATE(NOR(NIRES,NGRP),IPPT2(NIRES,5),IWRK(NGRP),ISM(2,NL), + 1 ISMIN(NL,NGRP),ISMAX(NL,NGRP)) + ALLOCATE(XFLUX(NBNRS,MAXNOR),GAS(NGRP),GA1(NGRP),GA2(NGRP,NGRP), + 1 CONR(NBNRS,NIRES),VOLMER(0:NBNRS),DELTA(NGRP)) + ALLOCATE(IPISO1(NBISO),IPISO2(NBISO)) +* + CALL KDRCPU(TK1) + DO 15 IG1=1,NGRP + DO 10 IL=1,NL + ISMIN(IL,IG1)=NGRP + ISMAX(IL,IG1)=1 + 10 CONTINUE + 15 CONTINUE + DO 20 IRES=1,NIRES + NOR(IRES,1)=-1 + 20 CONTINUE +* + IF(NED.GT.0) THEN + IF(NED.GT.MAXED) CALL XABORT('USSFLU: INVALID VALUE OF MAXED.') + CALL LCMGTC(IPLIB,'ADDXSNAME-P0',8,NED,HVECT) + ENDIF +* + CALL LIBIPS(IPLIB,NBISO,IPISO1) + CALL LIBIPS(IPLI0,NBISO,IPISO2) + SIGGAR(:NBMIX,0:NIRES,:NGRP,:4)=0.0 + DO 190 ISO=1,NBISO + IBM=MIX(ISO) + DO 30 I=1,NREG + IF(MAT(I).EQ.IBM) GO TO 35 + 30 CONTINUE + GO TO 190 + 35 IRES=IAPT(ISO) + DENN=DEN(ISO) + JRES=IRES + IF(IRES.EQ.NIRES+1) JRES=0 +*---- +* RECOVER INFINITE DILUTION OR SELF-SHIELDED CROSS SECTIONS AND +* COMPUTE OUT-OF-FUEL MACROSCOPIC CROSS SECTIONS. +*---- + KPLI0=IPISO2(ISO) ! set ISO-th isotope + IF(C_ASSOCIATED(KPLI0)) THEN + CALL LCMLEN(KPLI0,'NTOT0',ILENGT,ITYLCM) + IF(ILENGT.NE.0) THEN + LLIB=.FALSE. + IPP=KPLI0 + ELSE + LLIB=.TRUE. + IPP=IPISO1(ISO) ! set ISO-th isotope + ENDIF + ELSE + LLIB=.TRUE. + IPP=IPISO1(ISO) ! set ISO-th isotope + ENDIF + IF(LLIB.AND.(.NOT.C_ASSOCIATED(IPP))) THEN + WRITE(HSMG,'(18H USSFLU: ISOTOPE '',3A4,7H'' (ISO=,I8,5H) IS , + 1 39HNOT AVAILABLE IN THE ORIGINAL MICROLIB.)') (ISONAM(I0,ISO), + 2 I0=1,3),ISO + CALL XABORT(HSMG) + ENDIF + IF((.NOT.LLIB).AND.(IMPX.GT.2)) WRITE(6,'(/18H USSFLU: RECOVER I, + 1 8HSOTOPE '',3A4,23H'' FROM THE NEW LIBRARY.)') (ISOBIS(I0,ISO), + 2 I0=1,3) + IF((DENN.NE.0.0).AND.(IBM.NE.0)) THEN + CALL LCMLEN(IPP,'NTOT0',ILENGT,ITYLCM) + IF(ILENGT.NE.NGRP) CALL XABORT('USSFLU: INVALID X-SECTIONS.') + CALL LCMGET(IPP,'NTOT0',GA1) + DO 40 IGRP=1,NGRP + SIGGAR(IBM,JRES,IGRP,1)=SIGGAR(IBM,JRES,IGRP,1)+DENN*GA1(IGRP) + 40 CONTINUE + CALL LCMGET(IPP,'SIGS00',GA1) + CALL LCMLEN(IPP,'NWT0',ILENGT,ITYLCM) + IF(ILENGT.GT.0) THEN + CALL LCMGET(IPP,'NWT0',GAS) + ELSE + GAS(:NGRP)=1.0 + ENDIF + DO 45 IGRP=1,NGRP + SIGGAR(IBM,JRES,IGRP,3)=SIGGAR(IBM,JRES,IGRP,3)+DENN*GA1(IGRP) + SIGGAR(IBM,JRES,IGRP,4)=SIGGAR(IBM,JRES,IGRP,4)+DENN*GA1(IGRP)* + 1 GAS(IGRP) + 45 CONTINUE + CALL LCMLEN(IPP,'TRANC',ILENGT,ITYLCM) + IF(ILENGT.GT.0) THEN + CALL LCMGET(IPP,'TRANC',GA1) + ELSE + GA1(:NGRP)=0.0 + ENDIF + DO 50 IGRP=1,NGRP + SIGGAR(IBM,JRES,IGRP,2)=SIGGAR(IBM,JRES,IGRP,2)+DENN*GA1(IGRP) + 50 CONTINUE + ENDIF + CALL LCMGET(IPLI0,'DELTAU',DELTA) +*---- +* RECOVER PROBABILITY TABLE INFORMATION. +*---- + IF((IRES.GT.0).AND.(IRES.LE.NIRES)) THEN + IF(NOR(IRES,1).EQ.-1) THEN + KPLIB=IPISO1(ISO) ! set ISO-th isotope +* +* RECOVER INFINITE DILUTION VALUES. + CALL LCMGET(KPLIB,'NTOT0',GAS) + DO 55 IG=1,NGRP + STGAR(:NBNRS,IRES,IG)=0.0 + STGAR(:NBNRS,IRES,IG)=GAS(IG) + SFGAR(:NBNRS,IRES,IG)=0.0 + SWGAR(:NBNRS,IRES,IG)=0.0 + SAGAR(:NBNRS,IRES,:NED,IG)=0.0 + SDGAR(:NBNRS,IRES,:NDEL,IG)=0.0 + 55 CONTINUE + CALL LCMLEN(KPLIB,'NUSIGF',ILENGT,ITYLCM) + IF(ILENGT.GT.0) THEN + CALL LCMGET(KPLIB,'NUSIGF',GAS) + DO 60 IG=1,NGRP + SFGAR(:NBNRS,IRES,IG)=GAS(IG) + 60 CONTINUE + ENDIF + DO 80 IL=1,NL + CALL XDRLGS(KPLIB,-1,IMPX,IL-1,IL-1,1,NGRP,GAS,GA2,ITYPRO) +* JG IS THE SECONDARY GROUP. + DO 72 IG=1,NGRP + SSGAR(:NBNRS,IRES,IL,IG)=GAS(IG) + DO 70 JG=1,NGRP + IF(IL.EQ.1) THEN + SWGAR(:NBNRS,IRES,JG)=SWGAR(:NBNRS,IRES,JG)+GA2(JG,IG)* + 1 DELTA(IG) + ENDIF + S0GAR(:NBNRS,IRES,IL,JG,IG)=GA2(JG,IG) + 70 CONTINUE + 72 CONTINUE + 80 CONTINUE + DO 95 IG=1,NGRP + SWGAR(:NBNRS,IRES,IG)=SWGAR(:NBNRS,IRES,IG)/DELTA(IG) + 95 CONTINUE + DO 110 IED=1,NED + CALL LCMLEN(KPLIB,HVECT(IED),ILENGT,ITYLCM) + IF(ILENGT.GT.0) THEN + CALL LCMGET(KPLIB,HVECT(IED),GAS) + DO 105 IG=1,NGRP + SAGAR(:NBNRS,IRES,IED,IG)=GAS(IG) + 105 CONTINUE + ENDIF + 110 CONTINUE + DO 130 IDEL=1,NDEL + WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL + CALL LCMLEN(KPLIB,TEXT12,ILENGT,ITYLCM) + IF(ILENGT.GT.0) THEN + CALL LCMGET(KPLIB,TEXT12,GAS) + DO 125 IG=1,NGRP + SDGAR(:NBNRS,IRES,IDEL,IG)=GAS(IG) + 125 CONTINUE + ENDIF + 130 CONTINUE +* + GOLD(IRES,:NGRP)=1.0 + NOR(IRES,:NGRP)=0 + CALL LCMSIX(KPLIB,'PT-TABLE',1) + CALL LCMGET(KPLIB,'NOR',IWRK) + LPLIB=LCMGID(KPLIB,'GROUP-PT') + DO 150 IG1=1,NGRP + IF(IWRK(IG1).GT.1) THEN + MPLIB=LCMGIL(LPLIB,IG1) + CALL LCMGET(MPLIB,'ISM-LIMITS',ISM) + DO 140 IL=1,NL + ISMIN(IL,IG1)=MIN(ISMIN(IL,IG1),ISM(1,IL)) + ISMAX(IL,IG1)=MAX(ISMAX(IL,IG1),ISM(2,IL)) + 140 CONTINUE + ENDIF + NOR(IRES,IG1)=IWRK(IG1) + 150 CONTINUE + CALL LCMSIX(KPLIB,' ',2) + CALL LCMLEN(KPLIB,'NGOLD',ILENGT,ITYLCM) + IF(ILENGT.GT.0) THEN + ALLOCATE(GOLD2(NGRP)) + CALL LCMGET(KPLIB,'NGOLD',GOLD2) + DO 160 IG1=1,NGRP + GOLD(IRES,IG1)=GOLD2(IG1) + 160 CONTINUE + DEALLOCATE(GOLD2) + ENDIF + CALL LCMLEN(KPLIB,'BIN-NFS',ILENGT,ITYLCM) + IF(ILENGT.GT.0) THEN + CALL LCMGET(KPLIB,'BIN-NFS',IWRK) + DO 180 IG1=1,NGRP + IF((GOLD(IRES,IG1).LT.-900.).AND.(IWRK(IG1).EQ.0)) THEN + GOLD(IRES,IG1)=1.0 + ENDIF + 180 CONTINUE + ENDIF + ENDIF + ENDIF + 190 CONTINUE + CALL KDRCPU(TK2) + IF(IMPX.GT.1) WRITE(6,'(/34H USSFLU: CPU TIME SPENT TO RECOVER, + 1 23H INFINITE-DILUTION XS =,F8.1,8H SECOND./)') TK2-TK1 +* + CALL KDRCPU(TK1) + TK4=0.0 + TK5=0.0 + ICPIJ=0 +*---- +* COMPUTE THE MERGED VOLUMES AND NUMBER DENSITIES. +*---- + VOLMER(0:NBNRS)=0.0 + DO 210 I=1,NREG + IBM=MAT(I) + IF(IBM.GT.0) VOLMER(IREX(IBM))=VOLMER(IREX(IBM))+VOL(I) + 210 CONTINUE + CONR(:NBNRS,:NIRES)=0.0 + DO 240 ISO=1,NBISO + JRES=IAPT(ISO) + IF((JRES.GT.0).AND.(JRES.LE.NIRES)) THEN + DENN=DEN(ISO) + DO 230 IREG=1,NREG + IBM=MAT(IREG) + IF(MIX(ISO).EQ.IBM) THEN + IND=IREX(IBM) + IF(IND.EQ.0) CALL XABORT('USSFLU: IREX FAILURE.') + CONR(IND,JRES)=CONR(IND,JRES)+DENN*VOL(IREG)/VOLMER(IND) + ENDIF + 230 CONTINUE + ENDIF + 240 CONTINUE +*---- +* RECOVER POSITION OF PROBABILITY TABLES AND NAME OF RESONANT ISOTOPE. +*---- + DO 270 IRES=1,NIRES + ISOT=0 + DO 250 JSOT=1,NBISO + IF(IAPT(JSOT).EQ.IRES) THEN + ISOT=JSOT + GO TO 260 + ENDIF + 250 CONTINUE + CALL XABORT('USSFLU: UNABLE TO FIND A RESONANT ISOTOPE.') + 260 KPLIB=IPISO1(ISOT) ! set ISOT-th isotope + CALL LCMLEN(KPLIB,'PT-TABLE',ILENGT,ITYLCM) + IF(ILENGT.EQ.0) CALL XABORT('USSFLU: BUG1.') + CALL LCMSIX(KPLIB,'PT-TABLE',1) + CALL LCMGET(KPLIB,'NDEL',NDEL0) + IF(NDEL0.GT.NDEL) CALL XABORT('USSFLU: NDEL OVERFLOW.') + CALL LCMLEN(KPLIB,'GROUP-PT',ILENGT,ITYLCM) + IF(ILENGT.EQ.0) CALL XABORT('USSFLU: BUG2.') + IPPT1(IRES)=KPLIB + CALL LCMSIX(KPLIB,' ',2) + IPPT2(IRES,1)=IREX(MIX(ISOT)) + IPPT2(IRES,2)=ISONAM(1,ISOT) + IPPT2(IRES,3)=ISONAM(2,ISOT) + IPPT2(IRES,4)=ISONAM(3,ISOT) + IPPT2(IRES,5)=NDEL0 + IF(IPPT2(IRES,1).LE.0) CALL XABORT('USSFLU: BUG3.') + 270 CONTINUE +*---- +* DETERMINE WHICH GROUPS ARE SELF-SHIELDED. +*---- + DO 290 IGRP=1,NGRP + DO 280 IRES=1,NIRES + MASKG(IGRP,IRES)=((IGRP.GE.IGRMIN).AND.(IGRP.LE.IGRMAX).AND. + 1 (NOR(IRES,IGRP).GT.1)) + 280 CONTINUE + 290 CONTINUE +*---- +* INITIALIZATION OF THE MULTIBAND FLUXES AND SOURCES. +*---- + CALL LCMSIX(IPLI0,'SHIBA_SG',1) + CALL LCMSIX(IPLI0,HCAL,1) + DO 310 IRES=1,NIRES + WRITE(CBDPNM,'(3HCOR,I4.4,1H/,I4.4)') IRES,NIRES + CALL LCMSIX(IPLI0,CBDPNM,1) + JPLI0=LCMLID(IPLI0,'NWT0-PT',NGRP) + DO 300 IGRP=1,NGRP + IF(MASKG(IGRP,IRES)) THEN + CALL LCMLEL(JPLI0,IGRP,ILENGT1,ITYLCM) + IF(ILENGT1.EQ.0) THEN + NORI=NOR(IRES,IGRP) + XFLUX(:NBNRS,:NORI)=1.0 + CALL LCMPDL(JPLI0,IGRP,NBNRS*NORI,2,XFLUX) + ENDIF + ENDIF + 300 CONTINUE + CALL LCMSIX(IPLI0,' ',2) + 310 CONTINUE +* + CALL KDRCPU(TKA) +* + DO 340 IRES=1,NIRES + LRIB=.FALSE. + DO 330 IGRP=1,NGRP + LRIB=LRIB.OR.(MASKG(IGRP,IRES).AND.(GOLD(IRES,IGRP).EQ.-999.)) + IF(MASKG(IGRP,IRES)) ICPIJ=ICPIJ+NOR(IRES,IGRP) + 330 CONTINUE +*---- +* ITERATIVE APPROACH FOR THE HELIOS/WIMS-7 METHOD. +*---- + CALL USSIT1(MAXNOR,NGRP,MASKG(1,IRES),IRES,IPLI0,IPTRK,IFTRAK, + 1 CDOOR,IMPX,NBMIX,NREG,NUN,NL,IPHASE,MAXST,MAT,VOL,KEYFLX,LEAKSW, + 2 IREX,SIGGAR,TITR,NIRES,NBNRS,NOR,CONR,GOLD,IPPT1,IPPT2,STGAR, + 3 SSGAR,VOLMER,UNGAR) +*---- +* ITERATIVE APPROACH FOR THE SUBGROUP PROJECTION METHOD. +*---- + CALL USSIST(MAXNOR,NGRP,MASKG(1,IRES),IRES,IPLI0,IPTRK,IFTRAK, + 1 CDOOR,IMPX,NBMIX,NREG,NUN,NL,IPHASE,MAXST,MAT,VOL,KEYFLX,LEAKSW, + 2 IREX,SIGGAR,TITR,ICORR,NIRES,NBNRS,NOR,CONR,GOLD,IPPT1,IPPT2, + 3 STGAR,SSGAR,VOLMER,UNGAR) +*---- +* RESPONSE MATRIX APPROACH FOR THE RIBON EXTENDED METHOD. +*---- + IF(LRIB) THEN + CALL USSIT0(MAXNOR,NGRP,MASKG(1,IRES),IRES,IPLI0,IPTRK,IFTRAK, + 1 CDOOR,IMPX,NBMIX,NREG,NUN,NL,IPHASE,MAT,VOL,KEYFLX,LEAKSW,IREX, + 2 SIGGAR,TITR,ICORR,NIRES,NBNRS,NOR,CONR,GOLD,IPPT1,IPPT2,STGAR, + 3 SSGAR,SWGAR,VOLMER,UNGAR) + ENDIF + 340 CONTINUE + CALL KDRCPU(TKB) + TK4=TK4+(TKB-TKA) +*---- +* COMPUTE THE SELF-SHIELDED REACTION RATES. +*---- + PHGAR(:NBNRS,:NIRES,:NGRP)=1.0 + DO 360 IGRP=1,NGRP + LRES=.FALSE. + DO 345 IRES=1,NIRES + LRES=LRES.OR.MASKG(IGRP,IRES) + 345 CONTINUE + IF(LRES) THEN + MAXXS=2+NL+NED+NDEL + DO 350 IL=1,NL + MAXXS=MAXXS+MAX(ISMAX(IL,IGRP)-ISMIN(IL,IGRP)+1,0) + 350 CONTINUE + IF(ISUBG.EQ.4) MAXXS=MAXXS+1 + CALL KDRCPU(TKA) + CALL USSIT2(MAXNOR,IPLI0,IGRP,NGRP,ISMIN(1,IGRP),ISMAX(1,IGRP), + 1 NIRES,NBNRS,NL,NED,NDEL,NOR(1,IGRP),IPPT1,IPPT2,GOLD(1,IGRP), + 2 MAXXS,ISUBG,PHGAR(1,1,IGRP),STGAR(1,1,IGRP),SFGAR(1,1,IGRP), + 3 SSGAR(1,1,1,IGRP),S0GAR(1,1,1,1,IGRP),SAGAR(1,1,1,IGRP), + 4 SDGAR(1,1,1,IGRP),SWGAR(1,1,IGRP)) + CALL KDRCPU(TKB) + TK5=TK5+(TKB-TKA) + ENDIF + 360 CONTINUE +* *************************************************************** + CALL LCMSIX(IPLI0,' ',2) + CALL LCMSIX(IPLI0,' ',2) + CALL LCMVAL(IPLI0,' ') +*---- +* RESET MASKG FOR SPH CALCULATION IN SMALL LETHARGY WIDTH GROUPS. +*---- + DO 380 IGRP=1,NGRP + DO 370 IRES=1,NIRES + IF(MASKG(IGRP,IRES)) THEN + LRES=((GOLD(IRES,IGRP).EQ.-998.).OR.(GOLD(IRES,IGRP).EQ.-1000.)) + MASKG(IGRP,IRES)=.NOT.LRES + IF(DELTA(IGRP).GT.0.1) MASKG(IGRP,IRES)=.TRUE. + ENDIF + 370 CONTINUE + 380 CONTINUE + CALL KDRCPU(TK2) + IF(IMPX.GT.1) WRITE(6,'(/34H USSFLU: CPU TIME SPENT TO COMPUTE, + 1 31H SELF-SHIELDED REACTION RATES =,F8.1,19H SECOND, INCLUDING: + 2 /9X,F8.1,46H SECOND TO BUILD/SOLVE SUBGROUP MATRIX SYSTEM;/9X, + 4 F8.1,38H SECOND TO COMPUTE THE REACTION RATES./9X,9HNUMBER OF, + 5 23H ASSEMBLY DOORS CALLS =,I5,1H.)') TK2-TK1,TK4,TK5,ICPIJ +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IPISO2,IPISO1) + DEALLOCATE(DELTA,VOLMER,CONR,GA2,GA1,GAS,XFLUX) + DEALLOCATE(ISMAX,ISMIN,ISM,IWRK,IPPT2,NOR) + DEALLOCATE(IPPT1) + RETURN + END diff --git a/Dragon/src/USSIN1.f b/Dragon/src/USSIN1.f new file mode 100644 index 0000000..086610b --- /dev/null +++ b/Dragon/src/USSIN1.f @@ -0,0 +1,296 @@ +*DECK USSIN1 + SUBROUTINE USSIN1(IPLI0,IPLIB,NGRP,NBMIX,NBISO,NIRES,NBNRS,NL, + 1 NED,NDEL,IREX,IMPX,ISONAM,ISOBIS,MIX,IAPT,MASKI,SPH,PHGAR,STGAR, + 2 SFGAR,SSGAR,S0GAR,SAGAR,SDGAR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Write the self-shielded and SPH-corrected cross sections on the +* internal library. +* +*Copyright: +* Copyright (C) 2003 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLI0 pointer to the internal microscopic cross section library +* builded by the self-shielding module (L_LIBRARY signature). +* IPLIB pointer to the internal microscopic cross section library +* with subgroups (L_LIBRARY signature). +* NGRP number of energy groups. +* NBMIX number of mixtures in the internal library. +* NBISO number of isotopes. +* NIRES number of resonant isotopes in fuel regions. +* NBNRS number of totally correlated fuel regions. +* NL number of Legendre orders required in the calculation +* (NL=1 or higher). +* NED number of extra vector edits. +* NDEL number of delayed neutron precursor groups. +* IREX fuel region index assigned to each mixture (equal to zero +* in non-resonant mixtures or in mixtures not used). +* IMPX print flag (equal to zero for no print). +* ISONAM alias name of isotopes in IPLIB. +* ISOBIS alias name of isotopes in IPLI0. +* MIX mix number of each isotope (can be zero). +* IAPT resonant isotope index associated with isotope I. Mixed +* moderator if IAPT(I)=NIRES+1. Out-of-fuel isotope if +* IAPT(I)=0. +* MASKI isotopic flag (MASKI(ISO)=.TRUE. to process isotope ISO). +* SPH SPH factors. +* PHGAR averaged fluxes in correlated fuel regions. +* STGAR microscopic self-shielded total x-s. +* SFGAR microscopic self-shielded fission x-s. +* SSGAR microscopic self-shielded scattering x-s. +* S0GAR microscopic transfer scattering xs (isotope,secondary, +* primary). +* SAGAR microscopic self-shielded additional xs. +* SDGAR microscopic self-shielded delayed nu-sigf xs. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLI0,IPLIB + INTEGER NGRP,NBMIX,NBISO,NIRES,NBNRS,NL,NED,NDEL,IREX(NBMIX), + 1 IMPX,ISONAM(3,NBISO),ISOBIS(3,NBISO),MIX(NBISO),IAPT(NBISO) + REAL SPH(NBNRS,NIRES,NGRP),PHGAR(NBNRS,NIRES,NGRP), + 1 STGAR(NBNRS,NIRES,NGRP),SFGAR(NBNRS,NIRES,NGRP), + 2 SSGAR(NBNRS,NIRES,NL,NGRP),S0GAR(NBNRS,NIRES,NL,NGRP,NGRP), + 3 SAGAR(NBNRS,NIRES,NED,NGRP),SDGAR(NBNRS,NIRES,NDEL,NGRP) + LOGICAL MASKI(NBISO) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(MAXED=50,MAXSAV=100,MAXESP=4) + TYPE(C_PTR) JPLI0,KPLI0,KPLIB + INTEGER IPAR(40),ISAV(MAXSAV),IESP(MAXESP+1) + REAL EESP(MAXESP+1) + CHARACTER TEXT12*12,HSIGN*12,CM*2,HVECT(MAXED)*8,HCHI*12 + LOGICAL LOGNF,LTEST +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ISONR,ITITLE + REAL, ALLOCATABLE, DIMENSION(:) :: GAR1,ENERGY,LAMB + REAL, ALLOCATABLE, DIMENSION(:,:) :: GAR2 + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(GAR1(NGRP),GAR2(NGRP,NGRP),ENERGY(NGRP+1),IPISO(NBISO)) +* + CALL LCMGTC(IPLIB,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_LIBRARY') THEN + CALL XABORT('USSIN1: SIGNATURE IS '//HSIGN//'. L_LIBRARY EXPEC' + 1 //'TED.') + ENDIF + CALL LCMGET(IPLIB,'STATE-VECTOR',IPAR) + IF(NGRP.NE.IPAR(3)) CALL XABORT('USSIN1: INVALID NB OF GROUPS.') + IF(NL.NE.IPAR(4)) CALL XABORT('USSIN1: INVALID VALUE OF NL.') + IF(NED.NE.IPAR(13)) CALL XABORT('USSIN1: INVALID VALUE OF NED.') + IF(NED.GT.0) THEN + IF(NED.GT.MAXED) CALL XABORT('USSIN1: INVALID VALUE OF MAXED.') + CALL LCMGTC(IPLIB,'ADDXSNAME-P0',8,NED,HVECT) + ENDIF + CALL LCMLEN(IPLIB,'ENERGY',LENGT,ITYLCM) + IF(LENGT-1.NE.NGRP) CALL XABORT('LIBIN2: INVALID GROUP STRUCTU' + 1 //'RE.') + CALL LCMGET(IPLIB,'ENERGY',ENERGY) + CALL LCMPUT(IPLI0,'ENERGY',NGRP+1,2,ENERGY) + CALL LCMGET(IPLIB,'DELTAU',ENERGY) + CALL LCMPUT(IPLI0,'DELTAU',NGRP,2,ENERGY) + CALL LCMLEN(IPLIB,'CHI-LIMITS',NBESP,ITYLCM) + IF(NBESP.GT.0) THEN + NBESP=NBESP-1 + IF(NBESP.GT.MAXESP) CALL XABORT('USSIN1: MAXESP OVERFLOW.') + CALL LCMGET(IPLIB,'CHI-LIMITS',IESP) + CALL LCMPUT(IPLI0,'CHI-LIMITS',NBESP+1,1,IESP) + CALL LCMGET(IPLIB,'CHI-ENERGY',EESP) + CALL LCMPUT(IPLI0,'CHI-ENERGY',NBESP+1,2,EESP) + ENDIF + ALLOCATE(ISONR(3*NBISO)) + CALL LCMGET(IPLIB,'ISOTOPERNAME',ISONR) + CALL LCMPUT(IPLI0,'ISOTOPERNAME',3*NBISO,3,ISONR) + DEALLOCATE(ISONR) + CALL LIBIPS(IPLIB,NBISO,IPISO) + JPLI0=LCMLID(IPLI0,'ISOTOPESLIST',NBISO) + DO 370 ISOT=1,NBISO + IRES=IAPT(ISOT) + IF(MASKI(ISOT).AND.(IRES.GT.0).AND.(IRES.LE.NIRES)) THEN + KPLIB=IPISO(ISOT) ! set ISOT-th isotope + WRITE(TEXT12,'(3A4)') (ISOBIS(J,ISOT),J=1,3) + IF(IMPX.GT.0) WRITE (6,'(/29H USSIN1: PROCESSING ISOTOPE '', + 1 A12,2H''.)') TEXT12 + KPLI0=LCMDIL(JPLI0,ISOT) ! set ISOT-th isotope + CALL LCMPTC(KPLI0,'ALIAS',12,TEXT12) + CALL LCMGET(KPLIB,'AWR',AWR) + CALL LCMPUT(KPLI0,'AWR',1,2,AWR) + CALL LCMLEN(KPLIB,'README',LENTIT,ITYLCM) + IF(LENTIT.GT.0) THEN + ALLOCATE(ITITLE(LENTIT)) + CALL LCMGET(KPLIB,'README',ITITLE) + CALL LCMPUT(KPLI0,'README',LENTIT,3,ITITLE) + DEALLOCATE(ITITLE) + ENDIF + CALL LCMLEN(KPLIB,'NUSIGF',NFIS,ITYLCM) + LOGNF=(NFIS.GT.0) + IF(LOGNF) THEN + IF(NBESP.EQ.0) THEN + CALL LCMGET(KPLIB,'CHI',GAR1) + CALL LCMPUT(KPLI0,'CHI',NGRP,2,GAR1) + ELSE + DO ISP=1,NBESP + WRITE(HCHI,'(5HCHI--,I2.2)') ISP + CALL LCMLEN(KPLIB,HCHI,ILONG,ITYLCM) + IF(ILONG.EQ.NGRP) THEN + CALL LCMGET(KPLIB,HCHI,GAR1) + CALL LCMPUT(KPLI0,HCHI,NGRP,2,GAR1) + ENDIF + ENDDO + ENDIF + ENDIF + IND=IREX(MIX(ISOT)) + IF(IND.EQ.0) CALL XABORT('USSIN1: IREX FAILURE.') + DO 20 IG1=1,NGRP + GAR1(IG1)=PHGAR(IND,IRES,IG1) + 20 CONTINUE + CALL LCMPUT(KPLI0,'NWT0',NGRP,2,GAR1) + DO 30 IG1=1,NGRP + GAR1(IG1)=SPH(IND,IRES,IG1) + 30 CONTINUE + CALL LCMPUT(KPLI0,'NSPH',NGRP,2,GAR1) + DO 40 IG1=1,NGRP + GAR1(IG1)=STGAR(IND,IRES,IG1) + 40 CONTINUE + CALL LCMPUT(KPLI0,'NTOT0',NGRP,2,GAR1) + IF(LOGNF) THEN + DO 50 IG1=1,NGRP + GAR1(IG1)=SFGAR(IND,IRES,IG1) + 50 CONTINUE + CALL LCMPUT(KPLI0,'NUSIGF',NGRP,2,GAR1) + ENDIF + DO 90 IL=1,NL + WRITE(CM,'(I2.2)') IL-1 + DO 70 IG1=1,NGRP + GAR1(IG1)=SSGAR(IND,IRES,IL,IG1) + DO 60 IG2=1,NGRP + GAR2(IG2,IG1)=S0GAR(IND,IRES,IL,IG2,IG1) + 60 CONTINUE + 70 CONTINUE + CALL XDRLGS(KPLI0,1,IMPX,IL-1,IL-1,1,NGRP,GAR1,GAR2,ITYPRO) + 90 CONTINUE + CALL LCMLEN(KPLIB,'XS-SAVED',ILENG,ITYLCM) + IF(ILENG.GT.MAXSAV) CALL XABORT('USSIN1: XS-SAVED OVERFLOW.') + IF(ILENG.GT.0) CALL LCMGET(KPLIB,'XS-SAVED',ISAV) + IF(ILENG.GT.0) CALL LCMPUT(KPLI0,'XS-SAVED',ILENG,1,ISAV) + CALL LCMLEN(KPLIB,'SCAT-SAVED',ILENG,ITYLCM) + IF(ILENG.GT.MAXSAV) CALL XABORT('USSIN1: SCAT-SAVED OVERFLOW.') + IF(ILENG.GT.0) CALL LCMGET(KPLIB,'SCAT-SAVED',ISAV) + IF(ILENG.GT.0) CALL LCMPUT(KPLI0,'SCAT-SAVED',ILENG,1,ISAV) + DO 110 IED=1,NED + CALL LCMLEN(KPLIB,HVECT(IED),NEDI,ITYLCM) + IF((NEDI.GT.0).AND.(HVECT(IED)(:3).NE.'CHI').AND. + 1 (HVECT(IED)(:2).NE.'NU').AND.(HVECT(IED).NE.'NGOLD').AND. + 2 (HVECT(IED)(:3).NE.'NWT').AND.(HVECT(IED).NE.'NTOT0')) THEN + DO 100 IG1=1,NGRP + GAR1(IG1)=SAGAR(IND,IRES,IED,IG1) + 100 CONTINUE + CALL LCMPUT(KPLI0,HVECT(IED),NGRP,2,GAR1) + ENDIF + 110 CONTINUE + CALL LCMLEN(KPLIB,'NUSIGF01',ILONG,ITYLCM) + IF(ILONG.EQ.NGRP) THEN + CALL LCMLEN(KPLIB,'LAMBDA-D',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + WRITE(TEXT12,'(3A4)') (ISONAM(J,ISOT),J=1,3) + CALL XABORT('USSIN1: MISSING LAMBDA-D INFO '//'FOR '// + 1 TEXT12//'.') + ENDIF + ALLOCATE(LAMB(ILONG)) + CALL LCMGET(KPLIB,'LAMBDA-D',LAMB) + CALL LCMPUT(KPLI0,'LAMBDA-D',ILONG,2,LAMB) + DEALLOCATE(LAMB) + DO 130 IDEL=1,NDEL + WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL + LTEST=.FALSE. + DO 120 IG1=1,NGRP + GAR1(IG1)=SDGAR(IND,IRES,IDEL,IG1) + LTEST=LTEST.OR.(GAR1(IG1).NE.0.0) + 120 CONTINUE + IF(LTEST) THEN + CALL LCMPUT(KPLI0,TEXT12,NGRP,2,GAR1) + WRITE(TEXT12,'(3HCHI,I2.2)') IDEL + CALL LCMGET(KPLIB,TEXT12,GAR1) + CALL LCMPUT(KPLI0,TEXT12,NGRP,2,GAR1) + ENDIF + 130 CONTINUE + ENDIF +* + IF(IMPX.GT.2) THEN + CALL LCMGET(KPLI0,'NWT0',GAR1) + WRITE (6,'(/20H SELF-SHIELDED FLUX:/ + 1 (1X,1P,10E12.4))') (GAR1(I),I=1,NGRP) + WRITE (6,'(/13H SPH FACTORS:/(1X,1P,10E12.4))') + 1 (SPH(IND,IRES,I),I=1,NGRP) + CALL LCMGET(KPLI0,'NTOT0',GAR1) + WRITE (6,'(/36H SELF-SHIELDED MICROSCOPIC TOTAL XS:/ + 1 (1X,1P,10E12.4))') (GAR1(I),I=1,NGRP) + DO 350 IL=1,NL + WRITE(CM,'(I2.2)') IL-1 + CALL LCMLEN(KPLI0,'SCAT'//CM,ILSCAT,ITYLCM) + IF(ILSCAT.GT.NGRP**2) CALL XABORT('USSIN1: OVERWRITING ME' + 1 //'MORY(2).') + IF((IL.EQ.1).OR.(ILSCAT.GT.0)) THEN + CALL LCMGET(KPLI0,'SIGS'//CM,GAR1) + WRITE (6,'(/16H SELF-SHIELDED P,A2,18H MICROSCOPIC SCATT, + 1 9HERING XS:/(1X,1P,10E12.4))') CM,(GAR1(I),I=1,NGRP) + ENDIF + 350 CONTINUE + IF(LOGNF) THEN + CALL LCMGET(KPLI0,'NUSIGF',GAR1) + WRITE (6,'(/38H SELF-SHIELDED MICROSCOPIC FISSION XS:/ + 1 (1X,1P,10E12.4))') (GAR1(I),I=1,NGRP) + IF(NBESP.EQ.0) THEN + CALL LCMGET(KPLI0,'CHI',GAR1) + WRITE (6,'(/18H FISSION SPECTRUM:/ + 1 (1X,1P,10E12.4))') (GAR1(I),I=1,NGRP) + ELSE + DO 355 ISP=1,NBESP + WRITE(HCHI,'(5HCHI--,I2.2)') ISP + CALL LCMLEN(KPLI0,HCHI,ILONG,ITYLCM) + IF(ILONG.EQ.NGRP) THEN + CALL LCMGET(KPLI0,HCHI,GAR1) + WRITE (6,'(/I3,21H-TH FISSION SPECTRUM:/ + 1 (1X,1P,10E12.4))') ISP,(GAR1(I),I=1,NGRP) + ENDIF + 355 CONTINUE + ENDIF + ENDIF + DO 360 IED=1,NED + CALL LCMLEN(KPLI0,HVECT(IED),NEDI,ITYLCM) + IF((NEDI.GT.0).AND.(HVECT(IED)(:3).NE.'CHI').AND. + 1 (HVECT(IED)(:2).NE.'NU').AND.(HVECT(IED).NE.'NGOLD').AND. + 2 (HVECT(IED)(:3).NE.'NWT').AND.(HVECT(IED).NE.'NTOT0')) THEN + CALL LCMGET(KPLI0,HVECT(IED),GAR1) + WRITE (6,'(/15H SELF-SHIELDED ,A6,1H:/(1X,1P,10E12.4))') + 1 HVECT(IED),(GAR1(I),I=1,NGRP) + ENDIF + 360 CONTINUE + ENDIF + ENDIF + 370 CONTINUE + IF(IMPX.GT.3) CALL LCMLIB(IPLI0) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IPISO,ENERGY,GAR2,GAR1) + RETURN + END diff --git a/Dragon/src/USSIST.f b/Dragon/src/USSIST.f new file mode 100644 index 0000000..be654e0 --- /dev/null +++ b/Dragon/src/USSIST.f @@ -0,0 +1,509 @@ +*DECK USSIST + SUBROUTINE USSIST(MAXNOR,NGRP,MASKG,IRES,IPLI0,IPTRK,IFTRAK, + 1 CDOOR,IMPX,NBMIX,NREG,NUN,NL,IPHASE,MAXST,MAT,VOL,KEYFLX,LEAKSW, + 2 IREX,SIGGAR,TITR,ICORR,NIRES,NBNRS,NOR,CONR,GOLD,IPPT1,IPPT2, + 3 STGAR,SSGAR,VOLMER,UNGAR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the multiband fluxes as required by the subgroup method using +* the subgroup projection method (SPM): +* a) assume a single resonant isotope; +* b) use the standard solution doors of Dragon. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXNOR maximum order of the probability tables (PT). +* NGRP number of energy group. +* MASKG energy group mask pointing on self-shielded groups. +* IRES index of the resonant isotope. +* IPLI0 pointer to the internal microscopic cross section library +* builded by the self-shielding module. +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK file unit number used to store the tracks. +* CDOOR name of the geometry/solution operator. +* IMPX print flag (equal to zero for no print). +* NBMIX number of mixtures in the internal library. +* NREG number of regions. +* NUN number of unknowns in the flux or source vector in one +* energy group and one band. +* NL number of Legendre orders required in the calculation +* (NL=1 or higher). +* IPHASE type of flux solution (=1 use a native flux solution door; +* =2 use collision probabilities). +* MAXST maximum number of fixed point iterations for the ST scattering +* source. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX pointers of fluxes in unknown vector. +* LEAKSW leakage switch (LEAKSW=.TRUE. if neutron leakage through +* external boundary is present). +* IREX fuel region index assigned to each mixture. Equal to zero +* in non-resonant mixtures or in mixtures not used. +* SIGGAR macroscopic x-s of the non-resonant isotopes in each mixture: +* (*,*,*,1) total; (*,*,*,2) transport correction; +* (*,*,*,3) P0 scattering; (*,*,*,4) flux times P0 scattering. +* TITR title. +* ICORR mutual resonance shielding flag (=1 to suppress the model +* in cases it is required in LIB operator). +* NIRES exact number of correlated resonant isotopes. +* NBNRS number of correlated fuel regions. +* NOR exact order of the probability table. +* CONR number density of the resonant isotopes. +* GOLD type of self-shielding model (=1.0 physical probability +* tables; =-998.0/-1000.0 subgroup projection method). +* IPPT1 pointer to LCM directory of each resonant isotope. +* IPPT2 information related to each resonant isotope: +* IPPT2(:,1) index of a resonant region (used with infinite +* dilution case); +* IPPT2(:,2:4) alias name of resonant isotope. +* STGAR averaged microscopic total xs in resonant region. +* SSGAR averaged microscopic scattering xs in resonant region. +* VOLMER volumes of the resonant regions. +* +*Parameters: output +* UNGAR averaged flux unknowns. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE DOORS_MOD +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLI0,IPTRK,IPPT1(NIRES) + INTEGER MAXNOR,NGRP,IRES,IFTRAK,IMPX,NBMIX,NREG,NUN,NL,IPHASE, + 1 MAXST,MAT(NREG),KEYFLX(NREG),IREX(NBMIX),ICORR,NIRES,NBNRS, + 2 NOR(NIRES,NGRP),IPPT2(NIRES,4) + REAL VOL(NREG),SIGGAR(NBMIX,0:NIRES,NGRP,4), + 1 CONR(NBNRS,NIRES),GOLD(NIRES,NGRP),STGAR(NBNRS,NIRES,NGRP), + 2 SSGAR(NBNRS,NIRES,NL,NGRP),VOLMER(0:NBNRS), + 3 UNGAR(NUN,NIRES,NGRP) + CHARACTER CDOOR*12,TITR*72 + LOGICAL LEAKSW,MASKG(NGRP) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPSYS,JPLIB,KPLIB,KPSYS,JPLI0,JPLI01,IPMACR,IPSOU + CHARACTER CBDPNM*12,TEXT12*12,TEXX12*12,HSMG*131 + DOUBLE PRECISION ZNUM,ZDEN + LOGICAL EMPTY,LCM,LEXAC,LSPM,REBFLG + INTEGER NALBP +*---- +* ALLOCATABLE STATEMENTS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NPSYS + REAL, ALLOCATABLE, DIMENSION(:) :: SIGTXS,SIGS0X,SIGG,FLNEW,WCOR, + 1 FUN,SUN + REAL, ALLOCATABLE, DIMENSION(:,:) :: WEIGH,TOTPT,SIGWS + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: XFLUX + TYPE(C_PTR) SIGP_PTR + REAL, POINTER, DIMENSION(:) :: SIGP +*---- +* FIND THE NUMBER OF COMPONENTS REQUIRED AND ALLOCATE THE LIST OF +* ASSEMBLY MATRICES. +*---- + NASM=0 + DO 10 IGRP=1,NGRP + LSPM=(MASKG(IGRP).AND.((GOLD(IRES,IGRP).EQ.-998.).OR. + 1 (GOLD(IRES,IGRP).EQ.-1000.))) + IF(LSPM) NASM=NASM+NOR(IRES,IGRP) + 10 CONTINUE + IF(NASM.EQ.0) RETURN + IF(NGRP.LT.250) CALL XABORT('USSIST: THIS SIMPLIFIED SELF-SHIELD' + 1 //'ING MODEL REQUIRES MORE THAN 250 ENERGY GROUPS.') +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NPSYS(MAXNOR*NGRP)) + ALLOCATE(XFLUX(NBNRS,MAXNOR,NIRES),SIGTXS(0:NBMIX), + 1 SIGS0X(0:NBMIX),SIGG(0:NBMIX),WEIGH(MAXNOR,NIRES), + 2 TOTPT(MAXNOR,NIRES),SIGWS(MAXNOR,NIRES),FLNEW(NBNRS), + 3 WCOR(MAXNOR**2)) +*---- +* CREATE A SPECIFIC DIRECTORY FOR IRES-TH RESONANT ISOTOPE. +*---- + WRITE(CBDPNM,'(3HCOR,I4.4,1H/,I4.4)') IRES,NIRES + CALL LCMSIX(IPLI0,CBDPNM,1) + JPLI0=LCMGID(IPLI0,'NWT0-PT') + IPSYS=LCMLID(IPLI0,'ASSEMB-RIBON',NASM) + CALL LCMSIX(IPLI0,' ',2) +*---- +* LOOP OVER THE ENERGY GROUPS. +*---- + IASM=0 + DO 100 IGRP=1,NGRP + LSPM=(MASKG(IGRP).AND.((GOLD(IRES,IGRP).EQ.-998.).OR. + 1 (GOLD(IRES,IGRP).EQ.-1000.))) + IF(LSPM) THEN + IF(IMPX.GT.2) THEN + WRITE(TEXT12,'(3A4)') (IPPT2(IRES,J0),J0=2,4) + WRITE(6,'(36H USSIST: PROCESS CORRELATED ISOTOPE ,A12, + 1 11H WITH INDEX,I3,9H IN GROUP,I4,22H (SUBGROUP PROJECTION , + 2 8HMETHOD).)') TEXT12,IRES,IGRP + ENDIF + DO 20 JRES=1,NIRES + IF(GOLD(JRES,IGRP).NE.GOLD(IRES,IGRP)) THEN + WRITE(HSMG,'(32HUSSIST: PT NOT SET FOR ISOTOPE '',3A4, + 1 10H'' IN GROUP,I5,1H.)') (IPPT2(JRES,J0),J0=2,4),IGRP + CALL XABORT(HSMG) + ELSE IF(NOR(JRES,IGRP).GT.MAXNOR) THEN + CALL XABORT('USSIST: MAXNOR OVERFLOW.') + ENDIF + 20 CONTINUE + NORI=NOR(IRES,IGRP) + DO 40 JRES=1,NIRES +*---- +* RECOVER THE PREVIOUS FLUXES. +*---- + IF(NOR(JRES,IGRP).EQ.1) THEN + XFLUX(:NBNRS,:MAXNOR,JRES)=1.0 + ELSE + WRITE(CBDPNM,'(3HCOR,I4.4,1H/,I4.4)') JRES,NIRES + CALL LCMSIX(IPLI0,CBDPNM,1) + JPLI01=LCMGID(IPLI0,'NWT0-PT') + CALL LCMLEL(JPLI01,IGRP,ILON,ITYLCM) + IF(ILON.GT.NBNRS*MAXNOR) THEN + WRITE(TEXT12,'(3A4)') (IPPT2(IRES,J0),J0=2,4) + WRITE(HSMG,'(34HUSSIST: FLUX OVERFLOW FOR ISOTOPE ,A12)') + 1 TEXT12 + CALL XABORT(HSMG) + ENDIF + CALL LCMGDL(JPLI01,IGRP,XFLUX(1,1,JRES)) + CALL LCMSIX(IPLI0,' ',2) + ENDIF +*---- +* COLLECT THE BASE POINTS IN TOTAL CROSS SECTION. +*---- + JPLIB=LCMGID(IPPT1(JRES),'GROUP-PT') + CALL LCMLEL(JPLIB,IGRP,ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + KPLIB=LCMGIL(JPLIB,IGRP) + CALL LCMINF(KPLIB,TEXT12,TEXX12,EMPTY,ILONG,LCM) + CALL LCMLEN(KPLIB,'PROB-TABLE',LENG,ITYLCM) + NPART=LENG/MAXNOR + IF(LCM) THEN + CALL LCMGPD(KPLIB,'PROB-TABLE',SIGP_PTR) + CALL C_F_POINTER(SIGP_PTR,SIGP,(/ MAXNOR*NPART /)) + ELSE + ALLOCATE(SIGP(MAXNOR*NPART)) + CALL LCMGET(KPLIB,'PROB-TABLE',SIGP) + ENDIF + DO 30 INOR=1,NOR(JRES,IGRP) + WEIGH(INOR,JRES)=SIGP(INOR) + TOTPT(INOR,JRES)=SIGP(MAXNOR+INOR) + SIGWS(INOR,JRES)=SIGP(3*MAXNOR+INOR) + 30 CONTINUE + IF(.NOT.LCM) DEALLOCATE(SIGP) + ELSE + WEIGH(1,JRES)=1.0 + TOTPT(1,JRES)=STGAR(IPPT2(JRES,1),JRES,IGRP) + SIGWS(1,JRES)=SSGAR(IPPT2(JRES,1),JRES,1,IGRP) + ENDIF + 40 CONTINUE +*---- +* SET THE MIXTURE-DEPENDENT CROSS SECTIONS. +*---- + JPLIB=LCMGID(IPPT1(IRES),'GROUP-PT') + KPLIB=LCMGIL(JPLIB,IGRP) + DO 90 INOR=1,NORI + SIGTXS(0:NBMIX)=0.0 + SIGS0X(0:NBMIX)=0.0 + DO 80 IBM=1,NBMIX + IND=IREX(IBM) + DO 70 JRES=0,NIRES + IF(JRES.EQ.0) THEN +* ADMIXED NON-RESONANT ISOTOPES. + SIGTXS(IBM)=SIGTXS(IBM)+(SIGGAR(IBM,0,IGRP,1)- + 1 SIGGAR(IBM,0,IGRP,2)) + SIGS0X(IBM)=SIGS0X(IBM)-SIGGAR(IBM,0,IGRP,2) + ELSE IF((JRES.NE.IRES).AND.(IND.GT.0)) THEN +* MUTUAL SHIELDING MODEL FROM CORRELATED RESONANT ISOTOPES. + WRITE(TEXT12,'(3A4)') (IPPT2(JRES,I0),I0=2,4) + IF((NOR(JRES,IGRP).GT.1).AND.(ICORR.NE.1)) THEN + CALL LCMLEN(KPLIB,TEXT12,ILEN,ITYLCM) + IF(ILEN.EQ.0) THEN + CALL LCMLIB(KPLIB) + CALL XABORT('USSIST: UNABLE TO FIND CORRELATED ISOTO' + 1 //'PE '//TEXT12//'.') + ENDIF + CALL LCMGET(KPLIB,TEXT12,WCOR) + ENDIF + IF((ICORR.EQ.1).AND. +* ECCO CORRELATION MODEL. + 1 (IPPT2(IRES,2).EQ.IPPT2(JRES,2)).AND. + 1 (IPPT2(IRES,3).EQ.IPPT2(JRES,3))) THEN + SIGTXS(IBM)=SIGTXS(IBM)+CONR(IND,JRES)*TOTPT(INOR,IRES) + ELSE + ZNUM=0.0D0 + ZDEN=0.0D0 + DO 60 I2=1,NOR(JRES,IGRP) + IF((ICORR.EQ.1).OR.(NOR(JRES,IGRP).EQ.1)) THEN + WWW=WEIGH(INOR,IRES)*WEIGH(I2,JRES)*XFLUX(IND,I2,JRES) + ELSE + WWW=WCOR((I2-1)*NORI+INOR)*XFLUX(IND,I2,JRES) + ENDIF + ZNUM=ZNUM+WWW*CONR(IND,JRES)*TOTPT(I2,JRES) + ZDEN=ZDEN+WWW + 60 CONTINUE + IF(ZNUM/ZDEN.LT.0.0) THEN +* BADLY BEHAVED CORRELATED WEIGHT MATRIX. + ZNUM=0.0D0 + ZDEN=0.0D0 + DO 65 I2=1,NOR(JRES,IGRP) + WWW=WEIGH(INOR,IRES)*WEIGH(I2,JRES)*XFLUX(IND,I2,JRES) + ZNUM=ZNUM+WWW*CONR(IND,JRES)*TOTPT(I2,JRES) + ZDEN=ZDEN+WWW + 65 CONTINUE + ENDIF + SIGTXS(IBM)=SIGTXS(IBM)+REAL(ZNUM/ZDEN) + ENDIF + ENDIF + 70 CONTINUE + IF(IND.GT.0) THEN + SIGTXS(IBM)=SIGTXS(IBM)+CONR(IND,IRES)*TOTPT(INOR,IRES) + SIGS0X(IBM)=SIGS0X(IBM)+WEIGH(INOR,IRES)*CONR(IND,IRES)* + 1 SIGWS(INOR,IRES) + ENDIF + 80 CONTINUE + IASM=IASM+1 + NPSYS(IASM)=IASM + KPSYS=LCMDIL(IPSYS,IASM) + CALL LCMPUT(KPSYS,'DRAGON-TXSC',NBMIX+1,2,SIGTXS(0)) + CALL LCMPUT(KPSYS,'DRAGON-S0XSC',NBMIX+1,2,SIGS0X(0)) + 90 CONTINUE + ELSE IF(GOLD(IRES,IGRP).EQ.-998.) THEN + CALL LCMLEL(JPLI0,IGRP,LENG0,ITYLCM) + IF(LENG0.NE.0) THEN + WRITE(HSMG,'(42HUSSIST: UNEXPECTED SELF-SHIELDING DATA FOU, + 1 11HND IN GROUP,I5,1H.)') IGRP + CALL XABORT(HSMG) + ENDIF + ELSE IF(GOLD(IRES,IGRP).EQ.-1000.) THEN + CALL LCMLEL(JPLI0,IGRP,LENG0,ITYLCM) + IF(LENG0.NE.0) THEN + WRITE(HSMG,'(42HUSSIST: UNEXPECTED SELF-SHIELDING DATA FOU, + 1 11HND IN GROUP,I5,1H.)') IGRP + CALL XABORT(HSMG) + ENDIF + ENDIF + 100 CONTINUE +*---- +* ASSEMBLY MATRIX OR REDUCED COLLISION PROBABILITIES CALCULATION. +*---- + NANI=1 + KNORM=1 + NALBP=0 + IMPY=MAX(0,IMPX-3) + IF(IPHASE.EQ.1) THEN +* USE A NATIVE DOOR. + ISTRM=1 + NW=0 + CALL DOORAV(CDOOR,IPSYS,NPSYS,IPTRK,IFTRAK,IMPY,NASM,NREG, + 1 NBMIX,NANI,NW,MAT,VOL,KNORM,LEAKSW,TITR,NALBP,ISTRM) + ELSE IF(IPHASE.EQ.2) THEN +* USE A COLLISION PROBABILITY DOOR. + IPIJK=1 + ITPIJ=1 + CALL DOORPV(CDOOR,IPSYS,NPSYS,IPTRK,IFTRAK,IMPY,NASM,NREG, + 1 NBMIX,NANI,MAT,VOL,KNORM,IPIJK,LEAKSW,ITPIJ,.FALSE.,TITR, + 2 NALBP) + ENDIF +*---- +* LOOP OVER THE ENERGY GROUPS. +*---- + IASM=0 + DO 280 IGRP=1,NGRP + LSPM=(MASKG(IGRP).AND.((GOLD(IRES,IGRP).EQ.-998.).OR. + 1 (GOLD(IRES,IGRP).EQ.-1000.))) + IF(LSPM) THEN + NORI=NOR(IRES,IGRP) +*---- +* COLLECT THE BASE POINTS IN PARTIAL CROSS SECTION. +*---- + DO 120 JRES=1,NIRES + JPLIB=LCMGID(IPPT1(JRES),'GROUP-PT') + CALL LCMLEL(JPLIB,IGRP,ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + KPLIB=LCMGIL(JPLIB,IGRP) + CALL LCMINF(KPLIB,TEXT12,TEXX12,EMPTY,ILONG,LCM) + CALL LCMLEN(KPLIB,'PROB-TABLE',LENG,ITYLCM) + NPART=LENG/MAXNOR + IF(LCM) THEN + CALL LCMGPD(KPLIB,'PROB-TABLE',SIGP_PTR) + CALL C_F_POINTER(SIGP_PTR,SIGP,(/ MAXNOR*NPART /)) + ELSE + ALLOCATE(SIGP(MAXNOR*NPART)) + CALL LCMGET(KPLIB,'PROB-TABLE',SIGP) + ENDIF + DO 110 INOR=1,NOR(JRES,IGRP) + WEIGH(INOR,JRES)=SIGP(INOR) + SIGWS(INOR,JRES)=SIGP(3*MAXNOR+INOR) + 110 CONTINUE + IF(.NOT.LCM) DEALLOCATE(SIGP) + ELSE + WEIGH(1,JRES)=1.0 + SIGWS(1,JRES)=SSGAR(IPPT2(JRES,1),JRES,1,IGRP) + ENDIF + 120 CONTINUE +*---- +* RECOVER THE PREVIOUS FLUXES. +*---- + WRITE(CBDPNM,'(3HCOR,I4.4,1H/,I4.4)') IRES,NIRES + CALL LCMSIX(IPLI0,CBDPNM,1) + JPLI01=LCMGID(IPLI0,'NWT0-PT') + CALL LCMLEL(JPLI01,IGRP,ILON,ITYLCM) + IF(ILON.GT.NBNRS*MAXNOR) THEN + WRITE(TEXT12,'(3A4)') (IPPT2(IRES,J0),J0=2,4) + WRITE(HSMG,'(34HUSSIST: FLUX OVERFLOW FOR ISOTOPE ,A12)') + 1 TEXT12 + CALL XABORT(HSMG) + ENDIF + CALL LCMGDL(JPLI01,IGRP,XFLUX(1,1,IRES)) + CALL LCMSIX(IPLI0,' ',2) +*---- +* ITERATIVE PROCEDURE. +*---- + ITER=0 + 140 ITER=ITER+1 + IF(ITER.GT.MAXST) GO TO 240 + ERR1=0.0 + ERR2=0.0 +*---- +* COMPUTE THE AVERAGED SOURCE. +*---- + ALLOCATE(FUN(NUN*NORI),SUN(NUN*NORI)) + SUN(:NUN*NORI)=0.0 + DO 195 INOR=1,NORI + KPSYS=LCMGIL(IPSYS,IASM+INOR) + CALL LCMLEN(KPSYS,'FUNKNO$USS',ILENG,ITYLCM) + IF(ILENG.EQ.NUN) THEN + CALL LCMGET(KPSYS,'FUNKNO$USS',FUN((INOR-1)*NUN+1)) + ELSE + FUN((INOR-1)*NUN+1:INOR*NUN)=0.0 + ENDIF + NPSYS(INOR)=IASM+INOR + SIGG(0)=0.0 + DO 190 IBM=1,NBMIX + SIGG(IBM)=SIGGAR(IBM,0,IGRP,3) + IND=IREX(IBM) + DO 150 JRES=1,NIRES + IF((JRES.NE.IRES).AND.(IND.GT.0)) THEN + SIGG(IBM)=SIGG(IBM)+SIGGAR(IBM,JRES,IGRP,4) + ENDIF + 150 CONTINUE + IF(IND.GT.0) THEN + DO 160 JNOR=1,NORI + IF(JNOR.NE.INOR) THEN + SIGG(IBM)=SIGG(IBM)+WEIGH(JNOR,IRES)*CONR(IND,IRES)* + 1 SIGWS(JNOR,IRES)*XFLUX(IND,JNOR,IRES) + ENDIF + 160 CONTINUE + ENDIF + 190 CONTINUE + IOF=(INOR-1)*NUN + CALL DOORS(CDOOR,IPTRK,NBMIX,0,NUN,SIGG,SUN(IOF+1)) + 195 CONTINUE +*---- +* SOLVE FOR THE MULTIBAND FLUX. +*---- + IDIR=0 + LEXAC=.FALSE. + IPMACR=C_NULL_PTR + IPSOU=C_NULL_PTR + REBFLG=.FALSE. + CALL DOORFV(CDOOR,IPSYS,NPSYS,IPTRK,IFTRAK,IMPX,NORI,NBMIX, + 1 IDIR,NREG,NUN,IPHASE,LEXAC,MAT,VOL,KEYFLX,TITR,SUN,FUN,IPMACR, + 2 IPSOU,REBFLG) +*---- +* HOMOGENIZE THE FLUX AT ITERATION ITER. +*---- + UNGAR(:NUN,IRES,IGRP)=0.0 + DO 235 INOR=1,NORI + KPSYS=LCMGIL(IPSYS,IASM+INOR) + CALL LCMPUT(KPSYS,'FUNKNO$USS',NUN,2,FUN((INOR-1)*NUN+1)) + FLNEW(:NBNRS)=0.0 + DO 200 I=1,NREG + IF(MAT(I).EQ.0) GO TO 200 + IOF=(INOR-1)*NUN+KEYFLX(I) + IND=IREX(MAT(I)) + IF(IND.GT.0) FLNEW(IND)=FLNEW(IND)+FUN(IOF)*VOL(I) + 200 CONTINUE + DO 210 IND=1,NBNRS + FLNEW(IND)=FLNEW(IND)/VOLMER(IND) + 210 CONTINUE +* + DO 220 I=1,NUN + IOF=(INOR-1)*NUN+I + UNGAR(I,IRES,IGRP)=UNGAR(I,IRES,IGRP)+FUN(IOF)*WEIGH(INOR,IRES) + 220 CONTINUE +*---- +* CONVERGENCE CONTROL. +*---- + DO 230 IND=1,NBNRS + ERR1=MAX(ERR1,ABS(FLNEW(IND)-XFLUX(IND,INOR,IRES))) + ERR2=MAX(ERR2,ABS(FLNEW(IND))) + XFLUX(IND,INOR,IRES)=FLNEW(IND) + 230 CONTINUE + 235 CONTINUE + DEALLOCATE(SUN,FUN) + IF(IMPX.GT.2) THEN + WRITE(TEXT12,'(3A4)') (IPPT2(IRES,I),I=2,4) + WRITE(6,'(15H USSIST: GROUP=,I5,20H. SUBGROUP ITERATION,I4, + 1 11H. ISOTOPE='',A12,9H''. ERROR=,1P,E11.4,1H.)') + 2 IGRP,ITER,TEXT12,ERR1 + ENDIF + IF(ERR2.GT.1.0E10) GO TO 240 + IF(ERR1.GT.1.0E-4*ERR2) GO TO 140 + IF(IMPX.GT.1) THEN + WRITE(TEXT12,'(3A4)') (IPPT2(IRES,I),I=2,4) + WRITE(6,'(15H USSIST: GROUP=,I5,24H. SUBGROUP ITERATION CON, + 1 11HVERGENCE IN,I4,22H ITERATIONS. ISOTOPE='',A12,2H''.)') + 2 IGRP,ITER,TEXT12 + ENDIF + GO TO 250 +*---- +* ALTERNATIVE TREATMENT IN CASE OF FAILURE OF FIXED POINT ITERATIONS. +* USE A NON-ITERATIVE RESPONSE MATRIX APPROACH. +*---- + 240 IF(IMPX.GT.0) THEN + WRITE(TEXT12,'(3A4)') (IPPT2(IRES,I),I=2,4) + WRITE(6,'(15H USSIST: GROUP=,I5,24H. SUBGROUP ITERATION FAI, + 1 16HLED FOR ISOTOPE ,A12,32H. USE AN ALTERNATIVE RESPONSE MA, + 2 14HTRIX APPROACH.)') IGRP,TEXT12 + ENDIF + CALL USSEXC(MAXNOR,CDOOR,IPLI0,IPTRK,IFTRAK,IMPX,NGRP,IGRP, + 1 IASM,NBMIX,NREG,NUN,NL,IPHASE,MAT,VOL,KEYFLX,IREX,SIGGAR,TITR, + 2 NIRES,IRES,NBNRS,NOR,CONR,IPPT1,IPPT2,STGAR,SSGAR,VOLMER, + 3 XFLUX(1,1,IRES),UNGAR) + 250 IF(IMPX.GT.2) THEN + DO 270 IND=1,NBNRS + T1=0.0 + DO 260 INOR=1,NORI + T1=T1+WEIGH(INOR,IRES)*XFLUX(IND,INOR,IRES) + 260 CONTINUE + WRITE(6,'(31H USSIST: AVERAGED FLUX IN GROUP,I4,9H AND RESO, + 1 11HNANT REGION,I4,21H FOR RESONANT ISOTOPE,I4,2H =,F9.5)') + 2 IGRP,IND,IRES,T1 + 270 CONTINUE + ENDIF + CALL LCMPDL(JPLI0,IGRP,NBNRS*NORI,2,XFLUX(1,1,IRES)) + IASM=IASM+NORI + ENDIF + 280 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(WCOR,FLNEW,SIGWS,TOTPT,WEIGH,SIGG,SIGS0X,SIGTXS,XFLUX) + DEALLOCATE(NPSYS) + RETURN + END diff --git a/Dragon/src/USSIT0.f b/Dragon/src/USSIT0.f new file mode 100644 index 0000000..6e0af2d --- /dev/null +++ b/Dragon/src/USSIT0.f @@ -0,0 +1,670 @@ +*DECK USSIT0 + SUBROUTINE USSIT0(MAXNOR,NGRP,MASKG,IRES,IPLI0,IPTRK,IFTRAK, + 1 CDOOR,IMPX,NBMIX,NREG,NUN,NL,IPHASE,MAT,VOL,KEYFLX,LEAKSW,IREX, + 2 SIGGAR,TITR,ICORR,NIRES,NBNRS,NOR,CONR,GOLD,IPPT1,IPPT2,STGAR, + 3 SSGAR,SWGAR,VOLMER,UNGAR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the multiband fluxes as required by the subgroup method using +* a response matrix approach (Ribon extended subgroup method): +* a) assume a single resonant isotope; +* b) use the standard solution doors of Dragon. +* +*Copyright: +* Copyright (C) 2003 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXNOR maximum order of the probability tables (PT). +* NGRP number of energy group. +* MASKG energy group mask pointing on self-shielded groups. +* IRES index of the resonant isotope. +* IPLI0 pointer to the internal microscopic cross section library +* builded by the self-shielding module. +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK file unit number used to store the tracks. +* CDOOR name of the geometry/solution operator. +* IMPX print flag (equal to zero for no print). +* NBMIX number of mixtures in the internal library. +* NREG number of regions. +* NUN number of unknowns in the flux or source vector in one +* energy group and one band. +* NL number of Legendre orders required in the calculation +* (NL=1 or higher). +* IPHASE type of flux solution (=1 use a native flux solution door; +* =2 use collision probabilities). +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX pointers of fluxes in unknown vector. +* LEAKSW leakage switch (LEAKSW=.TRUE. if neutron leakage through +* external boundary is present). +* IREX fuel region index assigned to each mixture. Equal to zero +* in non-resonant mixtures or in mixtures not used. +* SIGGAR macroscopic x-s of the non-resonant isotopes in each mixture: +* (*,*,*,1) total; (*,*,*,2) transport correction; +* (*,*,*,3) P0 scattering; (*,*,*,4) flux times P0 scattering. +* TITR title. +* ICORR mutual resonance shielding flag (=1 to suppress the model +* in cases it is required in LIB operator). +* NIRES exact number of correlated resonant isotopes. +* NBNRS number of correlated fuel regions. +* NOR exact order of the probability table. +* CONR number density of the resonant isotopes. +* GOLD type of self-shielding model (=1.0 physical probability +* tables; =-999.0 Ribon extended method). +* IPPT1 pointer to LCM directory of each resonant isotope. +* IPPT2 information related to each resonant isotope: +* IPPT2(:,1) index of a resonant region (used with infinite +* dilution case); +* IPPT2(:,2:4) alias name of resonant isotope. +* STGAR averaged microscopic total xs in resonant region. +* SSGAR averaged microscopic scattering xs in resonant region. +* SWGAR microscopic secondary slowing-down cross sections (used +* if GOLD=-999.). +* VOLMER volumes of the resonant and non-resonant regions. +* +*Parameters: output +* UNGAR averaged flux unknowns. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE DOORS_MOD +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLI0,IPTRK,IPPT1(NIRES) + INTEGER MAXNOR,NGRP,IRES,IFTRAK,IMPX,NBMIX,NREG,NUN,NL, + 1 IPHASE,MAT(NREG),KEYFLX(NREG),IREX(NBMIX),ICORR,NIRES,NBNRS, + 2 NOR(NIRES,NGRP),IPPT2(NIRES,4) + REAL VOL(NREG),SIGGAR(NBMIX,0:NIRES,NGRP,4), + 1 CONR(NBNRS,NIRES),GOLD(NIRES,NGRP),STGAR(NBNRS,NIRES,NGRP), + 2 SSGAR(NBNRS,NIRES,NL,NGRP),SWGAR(NBNRS,NIRES,NGRP), + 3 VOLMER(0:NBNRS),UNGAR(NUN,NIRES,NGRP) + LOGICAL LEAKSW,MASKG(NGRP) + CHARACTER CDOOR*12,TITR*72 +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPSYS,KPSYS,JPLIB,KPLIB,JPLI0,IPMACR,IPSOU + LOGICAL EMPTY,LCM,LEXAC,REBFLG + CHARACTER CBDPNM*12,TEXT12*12,TEXX12*12,HSMG*131 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NPSYS + REAL, ALLOCATABLE, DIMENSION(:) :: SIGTXS,SIGS0X,SIGG,AWPHI,FUN, + 1 SUN + REAL, ALLOCATABLE, DIMENSION(:,:) :: WEIGH,TOTPT,WSLD,SIGWS,PAV, + 1 SIGX + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: XFLUX + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: MATRIX + TYPE(C_PTR) SIGP_PTR + REAL, POINTER, DIMENSION(:) :: SIGP +*---- +* STATEMENT FUNCTIONS +*---- + INM(IND,INOR,NBNRS)=(INOR-1)*NBNRS+IND +*---- +* FIND THE NUMBER OF COMPONENTS REQUIRED AND ALLOCATE THE LIST OF +* ASSEMBLY MATRICES. +*---- + NASM=0 + DO 10 IGRP=1,NGRP + IF(MASKG(IGRP).AND.(GOLD(IRES,IGRP).EQ.-999.)) THEN + NASM=NASM+NOR(IRES,IGRP) + ENDIF + 10 CONTINUE + IF(NASM.EQ.0) RETURN +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(XFLUX(NBNRS,MAXNOR,NIRES),SIGTXS(0:NBMIX), + 1 SIGS0X(0:NBMIX),SIGG(0:NBMIX),AWPHI(0:NBNRS),WEIGH(MAXNOR,NIRES), + 2 TOTPT(MAXNOR,NIRES),WSLD(MAXNOR**2,NIRES),SIGWS(MAXNOR,NIRES), + 3 PAV(0:NBNRS,0:NBNRS),SIGX(NBNRS,NIRES)) + ALLOCATE(MATRIX(NBNRS*MAXNOR,NBNRS*MAXNOR+1)) +*---- +* CREATE A SPECIFIC DIRECTORY FOR IRES-TH RESONANT ISOTOPE. +*---- + WRITE(CBDPNM,'(3HCOR,I4.4,1H/,I4.4)') IRES,NIRES + CALL LCMSIX(IPLI0,CBDPNM,1) + JPLI0=LCMGID(IPLI0,'NWT0-PT') + IPSYS=LCMLID(IPLI0,'ASSEMB-RIBON',NASM) + CALL LCMSIX(IPLI0,' ',2) +*---- +* LOOP OVER THE ENERGY GROUPS. +*---- + ALLOCATE(NPSYS(NASM)) + IASM=0 + DO 120 IGRP=1,NGRP + IF(MASKG(IGRP).AND.(GOLD(IRES,IGRP).EQ.-999.)) THEN + IF(IMPX.GT.1) THEN + WRITE(TEXT12,'(3A4)') (IPPT2(IRES,J0),J0=2,4) + WRITE(6,'(36H USSIT0: PROCESS CORRELATED ISOTOPE ,A12, + 1 11H WITH INDEX,I3,9H IN GROUP,I4,22H (RESPONSE MATRIX APPR, + 2 6HOACH).)') TEXT12,IRES,IGRP + ENDIF + DO 20 JRES=1,NIRES + IF(GOLD(JRES,IGRP).NE.GOLD(IRES,IGRP)) THEN + WRITE(HSMG,'(34HUSSIT0: PTSL NOT SET FOR ISOTOPE '',3A4, + 1 10H'' IN GROUP,I4,1H.)') (IPPT2(JRES,J0),J0=2,4),IGRP + CALL XABORT(HSMG) + ELSE IF(NOR(JRES,IGRP).GT.MAXNOR) THEN + CALL XABORT('USSIT0: MAXNOR OVERFLOW.') + ENDIF + 20 CONTINUE +*---- +* COLLECT THE BASE POINTS IN TOTAL CROSS SECTION. +*---- + NORI=NOR(IRES,IGRP) + DO 40 JRES=1,NIRES + JPLIB=LCMGID(IPPT1(JRES),'GROUP-PT') + CALL LCMLEL(JPLIB,IGRP,ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + KPLIB=LCMGIL(JPLIB,IGRP) + CALL LCMINF(KPLIB,TEXT12,TEXX12,EMPTY,ILONG,LCM) + CALL LCMLEN(KPLIB,'PROB-TABLE',LENG,ITYLCM) + NPART=LENG/MAXNOR + IF(LCM) THEN + CALL LCMGPD(KPLIB,'PROB-TABLE',SIGP_PTR) + CALL C_F_POINTER(SIGP_PTR,SIGP,(/ MAXNOR*NPART /)) + ELSE + ALLOCATE(SIGP(MAXNOR*NPART)) + CALL LCMGET(KPLIB,'PROB-TABLE',SIGP) + ENDIF + DO 30 INOR=1,NOR(JRES,IGRP) + WEIGH(INOR,JRES)=SIGP(INOR) + TOTPT(INOR,JRES)=SIGP(MAXNOR+INOR) + 30 CONTINUE + IF(.NOT.LCM) DEALLOCATE(SIGP) + ELSE + WEIGH(1,JRES)=1.0 + TOTPT(1,JRES)=STGAR(IPPT2(JRES,1),JRES,IGRP) + ENDIF + 40 CONTINUE +*---- +* SET THE MIXTURE-DEPENDENT CROSS SECTIONS. +*---- + DO 110 INOR=1,NORI + SIGTXS(0:NBMIX)=0.0 + SIGS0X(0:NBMIX)=0.0 + DO 90 IBM=1,NBMIX + IND=IREX(IBM) + DO 80 JRES=0,NIRES + IF(JRES.EQ.0) THEN + SIGTXS(IBM)=SIGTXS(IBM)+(SIGGAR(IBM,0,IGRP,1)- + 1 SIGGAR(IBM,0,IGRP,2)) + SIGS0X(IBM)=SIGS0X(IBM)-SIGGAR(IBM,0,IGRP,2) + ELSE IF((JRES.NE.IRES).AND.(IND.GT.0)) THEN + SIGTXS(IBM)=SIGTXS(IBM)+SIGGAR(IBM,JRES,IGRP,1) + ENDIF + 80 CONTINUE + IF(IND.GT.0) THEN + SIGTXS(IBM)=SIGTXS(IBM)+CONR(IND,IRES)*TOTPT(INOR,IRES) + ENDIF + 90 CONTINUE + IASM=IASM+1 + NPSYS(IASM)=IASM + KPSYS=LCMDIL(IPSYS,IASM) + CALL LCMPUT(KPSYS,'DRAGON-TXSC',NBMIX+1,2,SIGTXS) + CALL LCMPUT(KPSYS,'DRAGON-S0XSC',NBMIX+1,2,SIGS0X) + 110 CONTINUE + ELSE IF(GOLD(IRES,IGRP).EQ.-999.) THEN + CALL LCMLEL(JPLI0,IGRP,LENG0,ITYLCM) + IF(LENG0.NE.0) THEN + WRITE(HSMG,'(42HUSSIT0: UNEXPECTED SELF-SHIELDING DATA FOU, + 1 11HND IN GROUP,I5,1H.)') IGRP + CALL XABORT(HSMG) + ENDIF + ENDIF + 120 CONTINUE +*---- +* ASSEMBLY MATRIX OR REDUCED COLLISION PROBABILITIES CALCULATION. +*---- + NANI=1 + KNORM=1 + NALBP=0 + IMPY=MAX(0,IMPX-3) + IF(IPHASE.EQ.1) THEN +* USE A NATIVE DOOR. + ISTRM=1 + NW=0 + CALL DOORAV(CDOOR,IPSYS,NPSYS,IPTRK,IFTRAK,IMPY,NASM,NREG, + 1 NBMIX,NANI,NW,MAT,VOL,KNORM,LEAKSW,TITR,NALBP,ISTRM) + ELSE IF(IPHASE.EQ.2) THEN +* USE A COLLISION PROBABILITY DOOR. + IPIJK=1 + ITPIJ=1 + CALL DOORPV(CDOOR,IPSYS,NPSYS,IPTRK,IFTRAK,IMPY,NASM,NREG, + 1 NBMIX,NANI,MAT,VOL,KNORM,IPIJK,LEAKSW,ITPIJ,.FALSE.,TITR,NALBP) + ENDIF + DEALLOCATE(NPSYS) +*---- +* LOOP OVER THE ENERGY GROUPS. +*---- + IASM=0 + DO 300 IGRP=1,NGRP + IF(MASKG(IGRP).AND.(GOLD(IRES,IGRP).EQ.-999.)) THEN + IF(IMPX.GT.5) WRITE(6,'(/25H USSIT0: PROCESSING GROUP,I5, + > 6H WITH ,A,1H.)') IGRP,CDOOR + NORI=NOR(IRES,IGRP) +*---- +* COMPUTE THE AVERAGED COLLISION PROBABILITY MATRIX. +*---- + ALLOCATE(NPSYS(NORI*(NBNRS+1))) + ALLOCATE(FUN(NUN*NORI*(NBNRS+1)),SUN(NUN*NORI*(NBNRS+1))) + FUN(:NUN*NORI*(NBNRS+1))=0.0 + SUN(:NUN*NORI*(NBNRS+1))=0.0 + DO 145 INOR=1,NORI + DO 140 JNBN=0,NBNRS + NPSYS((INOR-1)*(NBNRS+1)+JNBN+1)=IASM+INOR + T1=0.0 + DO 125 I=1,NREG + IBM=MAT(I) + IF(IBM.EQ.0) GO TO 125 + IND=IREX(IBM) + IF((JNBN.EQ.0).AND.(IND.EQ.0)) THEN + T1=T1+SIGGAR(IBM,0,IGRP,3)*VOL(I) + ELSE IF(IND.EQ.JNBN) THEN + T1=T1+VOL(I) + ENDIF + 125 CONTINUE + IOF=(INOR-1)*NUN*(NBNRS+1)+JNBN*NUN + SIGG(0:NBMIX)=0.0 + DO 130 IBM=1,NBMIX + IND=IREX(IBM) + IF((JNBN.EQ.0).AND.(IND.EQ.0)) THEN + SIGG(IBM)=SIGG(IBM)+SIGGAR(IBM,0,IGRP,3) + ELSE IF(IND.EQ.JNBN) THEN + SIGG(IBM)=SIGG(IBM)+1.0 + ENDIF + 130 CONTINUE + CALL DOORS(CDOOR,IPTRK,NBMIX,0,NUN,SIGG,SUN(IOF+1)) + + DO 135 I=1,NUN + IF(T1.NE.0.0) SUN(IOF+I)=SUN(IOF+I)/T1 + 135 CONTINUE + 140 CONTINUE + 145 CONTINUE +*---- +* SOLVE FOR THE MULTIBAND FLUX. +*---- + IDIR=0 + NABS=NORI*(NBNRS+1) + LEXAC=.FALSE. + IPMACR=C_NULL_PTR + IPSOU=C_NULL_PTR + REBFLG=.FALSE. + CALL DOORFV(CDOOR,IPSYS,NPSYS,IPTRK,IFTRAK,IMPX,NABS,NBMIX, + 1 IDIR,NREG,NUN,IPHASE,LEXAC,MAT,VOL,KEYFLX,TITR,SUN,FUN,IPMACR, + 2 IPSOU,REBFLG) +*---- +* HOMOGENIZE THE MULTIBAND FLUX. +*---- + DO 170 INOR=1,NORI + PAV(0:NBNRS,0:NBNRS)=0.0 + DO 155 JNBN=0,NBNRS + T1=0.0 + DO 150 I=1,NREG + IBM=MAT(I) + IF(IBM.EQ.0) GO TO 150 + IOF=(INOR-1)*NUN*(NBNRS+1)+JNBN*NUN+KEYFLX(I) + PAV(IREX(IBM),JNBN)=PAV(IREX(IBM),JNBN)+FUN(IOF)*VOL(I) + 150 CONTINUE + 155 CONTINUE + DO 165 I=0,NBNRS + DO 160 J=0,NBNRS + IF(VOLMER(I).NE.0.0) PAV(I,J)=PAV(I,J)*VOLMER(J)/VOLMER(I) + 160 CONTINUE + 165 CONTINUE + KPSYS=LCMGIL(IPSYS,IASM+INOR) + CALL LCMPUT(KPSYS,'DRAGON-PAV',(NBNRS+1)**2,2,PAV(0,0)) + 170 CONTINUE + DEALLOCATE(SUN,FUN,NPSYS) +*---- +* COLLECT THE BASE POINTS IN TOTAL AND PARTIAL CROSS SECTION. +*---- + DO 200 JRES=1,NIRES + JPLIB=LCMGID(IPPT1(JRES),'GROUP-PT') + CALL LCMLEL(JPLIB,IGRP,ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + KPLIB=LCMGIL(JPLIB,IGRP) + CALL LCMINF(KPLIB,TEXT12,TEXX12,EMPTY,ILONG,LCM) + CALL LCMLEN(KPLIB,'PROB-TABLE',LENG,ITYLCM) + NPART=LENG/MAXNOR + IF(LCM) THEN + CALL LCMGPD(KPLIB,'PROB-TABLE',SIGP_PTR) + CALL C_F_POINTER(SIGP_PTR,SIGP,(/ MAXNOR*NPART /)) + ELSE + ALLOCATE(SIGP(MAXNOR*NPART)) + CALL LCMGET(KPLIB,'PROB-TABLE',SIGP) + ENDIF + IF(GOLD(IRES,IGRP).EQ.-999.) THEN + DO 180 INOR=1,NOR(JRES,IGRP) + WEIGH(INOR,JRES)=SIGP(INOR) + TOTPT(INOR,JRES)=SIGP(MAXNOR+INOR) + 180 CONTINUE + CALL LCMGET(KPLIB,'SIGQT-SLOW',WSLD(1,JRES)) + CALL LCMGET(KPLIB,'SIGQT-SIGS',SIGWS(1,JRES)) + ELSE + DO 190 INOR=1,NOR(JRES,IGRP) + WEIGH(INOR,JRES)=SIGP(INOR) + TOTPT(INOR,JRES)=SIGP(MAXNOR+INOR) + SIGWS(INOR,JRES)=SIGP(3*MAXNOR+INOR) + 190 CONTINUE + ENDIF + IF(.NOT.LCM) DEALLOCATE(SIGP) + ELSE + WEIGH(1,JRES)=1.0 + TOTPT(1,JRES)=STGAR(IPPT2(JRES,1),JRES,IGRP) + IF(GOLD(IRES,IGRP).EQ.-999.) THEN + SIGWS(1,JRES)=SWGAR(IPPT2(JRES,1),JRES,IGRP) + WSLD(1,JRES)=1.0 + ELSE + SIGWS(1,JRES)=SSGAR(IPPT2(JRES,1),JRES,1,IGRP) + ENDIF + ENDIF + 200 CONTINUE +*---- +* TAKE INTO ACCOUNT CORRELATION EFFECTS BETWEEN ISOTOPES USING THE +* MUTUAL SELF-SHIELDING MODEL. +*---- + IF((NIRES.GT.1).AND.(GOLD(IRES,IGRP).EQ.-999.).AND. + 1 (ICORR.EQ.0)) THEN + DO 225 JRES=1,NIRES + DO 220 IND=1,NBNRS + SIGX(IND,JRES)=0.0 + T1=0.0 + T2=0.0 + DO 215 I=1,NREG + IBM=MAT(I) + IF(IBM.EQ.0) GO TO 215 + IF(IND.EQ.IREX(IBM)) THEN + T1=T1+(SIGGAR(IBM,JRES,IGRP,1)-SIGGAR(IBM,JRES,IGRP,2))* + 1 VOL(I) + T2=T2+VOL(I) + ENDIF + 215 CONTINUE + IF(T2.NE.0.0) SIGX(IND,JRES)=T1/T2 + 220 CONTINUE + 225 CONTINUE + CALL USSCOR(MAXNOR,IGRP,IPSYS,IASM,IRES,NBNRS,NIRES, + 1 NOR(1,IGRP),CONR,IPPT1,IPPT2,WEIGH,TOTPT,SIGX,VOLMER) + ENDIF +*---- +* RESPONSE MATRIX APPROACH. LOOP OVER THE SECONDARY SUBGROUPS. +*---- + DO 272 INOR=1,NORI + KPSYS=LCMGIL(IPSYS,IASM+INOR) + CALL LCMGET(KPSYS,'DRAGON-PAV',PAV(0,0)) +*---- +* LOOP OVER THE PRIMARY SUBGROUPS. NORI+1 IS THE SOURCE. +*---- + DO 271 JNOR=1,NORI+1 + IF(JNOR.LE.NORI) THEN + JNBMAX=NBNRS + ELSE + JNBMAX=1 + ENDIF + DO 270 JNBN=1,JNBMAX + AWPHI(1:NBNRS)=0.0 + DO 250 I=1,NREG + IBM=MAT(I) + IF(IBM.EQ.0) GO TO 250 + JND=IREX(IBM) + QQQ=0.0 + IF(JNOR.EQ.NORI+1) THEN + DO 230 JRES=0,NIRES + IF(JRES.EQ.0) THEN + QQQ=QQQ+SIGGAR(IBM,0,IGRP,3) + ELSE IF((JRES.NE.IRES).AND.(JND.GT.0)) THEN + QQQ=QQQ+SIGGAR(IBM,JRES,IGRP,4) + ENDIF + 230 CONTINUE + ELSE IF(JND.EQ.JNBN) THEN + IF(GOLD(IRES,IGRP).EQ.-999.) THEN + WWW=WSLD((JNOR-1)*NORI+INOR,IRES)/WEIGH(INOR,IRES) + ELSE + WWW=WEIGH(JNOR,IRES) + ENDIF + QQQ=QQQ-WWW*CONR(JND,IRES)*SIGWS(JNOR,IRES) + ENDIF + DO 240 IND=1,NBNRS + AWPHI(IND)=AWPHI(IND)+PAV(IND,JND)*QQQ*VOL(I)/VOLMER(JND) + 240 CONTINUE + 250 CONTINUE + DO 260 IND=1,NBNRS + MATRIX(INM(IND,INOR,NBNRS),INM(JNBN,JNOR,NBNRS))=AWPHI(IND) + 260 CONTINUE + 270 CONTINUE + 271 CONTINUE + 272 CONTINUE +* + DO 280 I=1,NBNRS*NORI + MATRIX(I,I)=MATRIX(I,I)+1.0D0 + 280 CONTINUE + CALL ALSBD(NBNRS*NORI,1,MATRIX,IER,NBNRS*MAXNOR) + IF(IER.NE.0) CALL XABORT('USSIT0: SINGULAR MATRIX.') + XFLUX(:NBNRS,:MAXNOR,IRES)=0.0 + DO 295 IND=1,NBNRS + DO 290 INOR=1,NORI + I1=INM(IND,INOR,NBNRS) + XFLUX(IND,INOR,IRES)=REAL(MATRIX(I1,NBNRS*NORI+1)) + 290 CONTINUE + 295 CONTINUE +* END OF RESPONSE MATRIX APPROACH. +* + CALL LCMPDL(JPLI0,IGRP,NBNRS*NORI,2,XFLUX(1,1,IRES)) + IASM=IASM+NORI + ENDIF + 300 CONTINUE +*---- +* COMPUTE UNGAR, THE REGION-ORDERED FLUX. +*---- + ALLOCATE(NPSYS(NASM),FUN(NUN*NASM),SUN(NUN*NASM)) + SUN(:NUN*NASM)=0.0 + IASM=0 + DO 420 IGRP=1,NGRP + IF(MASKG(IGRP).AND.(GOLD(IRES,IGRP).EQ.-999.)) THEN + NORI=NOR(IRES,IGRP) +*---- +* RECOVER THE PREVIOUS FLUXES. +*---- + WRITE(CBDPNM,'(3HCOR,I4.4,1H/,I4.4)') IRES,NIRES + CALL LCMSIX(IPLI0,CBDPNM,1) + JPLI0=LCMGID(IPLI0,'NWT0-PT') + CALL LCMLEL(JPLI0,IGRP,ILON,ITYLCM) + IF(ILON.GT.NBNRS*MAXNOR) THEN + WRITE(TEXT12,'(3A4)') (IPPT2(IRES,J0),J0=2,4) + WRITE(HSMG,'(34HUSSIT0: FLUX OVERFLOW FOR ISOTOPE ,A12)') + 1 TEXT12 + CALL XABORT(HSMG) + ENDIF + CALL LCMGDL(JPLI0,IGRP,XFLUX(1,1,IRES)) + CALL LCMSIX(IPLI0,' ',2) +*---- +* COLLECT THE BASE POINTS IN PARTIAL CROSS SECTION. +*---- + DO 340 JRES=1,NIRES + JPLIB=LCMGID(IPPT1(JRES),'GROUP-PT') + CALL LCMLEL(JPLIB,IGRP,ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + KPLIB=LCMGIL(JPLIB,IGRP) + CALL LCMINF(KPLIB,TEXT12,TEXX12,EMPTY,ILONG,LCM) + CALL LCMLEN(KPLIB,'PROB-TABLE',LENG,ITYLCM) + NPART=LENG/MAXNOR + IF(LCM) THEN + CALL LCMGPD(KPLIB,'PROB-TABLE',SIGP_PTR) + CALL C_F_POINTER(SIGP_PTR,SIGP,(/ MAXNOR*NPART /)) + ELSE + ALLOCATE(SIGP(MAXNOR*NPART)) + CALL LCMGET(KPLIB,'PROB-TABLE',SIGP) + ENDIF + IF(GOLD(IRES,IGRP).EQ.-999.) THEN + DO 320 INOR=1,NOR(JRES,IGRP) + WEIGH(INOR,JRES)=SIGP(INOR) + 320 CONTINUE + CALL LCMGET(KPLIB,'SIGQT-SLOW',WSLD(1,JRES)) + CALL LCMGET(KPLIB,'SIGQT-SIGS',SIGWS(1,JRES)) + ELSE + DO 330 INOR=1,NOR(JRES,IGRP) + WEIGH(INOR,JRES)=SIGP(INOR) + SIGWS(INOR,JRES)=SIGP(3*MAXNOR+INOR) + 330 CONTINUE + ENDIF + IF(.NOT.LCM) DEALLOCATE(SIGP) + ELSE + WEIGH(1,JRES)=1.0 + IF(GOLD(IRES,IGRP).EQ.-999.) THEN + SIGWS(1,JRES)=SWGAR(IPPT2(JRES,1),JRES,IGRP) + WSLD(1,JRES)=1.0 + ELSE + SIGWS(1,JRES)=SSGAR(IPPT2(JRES,1),JRES,1,IGRP) + ENDIF + ENDIF + 340 CONTINUE +*---- +* COMPUTE THE AVERAGED SOURCE. +*---- + DO 380 INOR=1,NORI + NPSYS(IASM+INOR)=IASM+INOR + KPSYS=LCMGIL(IPSYS,IASM+INOR) + CALL LCMLEN(KPSYS,'FUNKNO$USS',ILENG,ITYLCM) + IF(ILENG.EQ.NUN) THEN + CALL LCMGET(KPSYS,'FUNKNO$USS',FUN((IASM+INOR-1)*NUN+1)) + ELSE + FUN((IASM+INOR-1)*NUN+1:(IASM+INOR)*NUN)=0.0 + ENDIF + SIGG(0)=0.0 + DO 370 IBM=1,NBMIX + QQQ=SIGGAR(IBM,0,IGRP,3) + IND=IREX(IBM) + DO 350 JRES=1,NIRES + IF((JRES.NE.IRES).AND.(IND.GT.0)) THEN + QQQ=QQQ+SIGGAR(IBM,JRES,IGRP,4) + ENDIF + 350 CONTINUE + IF(IND.GT.0) THEN + DO 360 JNOR=1,NORI + IF(GOLD(IRES,IGRP).EQ.-999.) THEN + WWW=WSLD((JNOR-1)*NORI+INOR,IRES)/WEIGH(INOR,IRES) + ELSE + WWW=WEIGH(JNOR,IRES) + ENDIF + QQQ=QQQ+WWW*CONR(IND,IRES)*SIGWS(JNOR,IRES)* + 1 XFLUX(IND,JNOR,IRES) + 360 CONTINUE + ENDIF + SIGG(IBM)=QQQ*WEIGH(INOR,IRES) + 370 CONTINUE + IOF=(IASM+INOR-1)*NUN + CALL DOORS(CDOOR,IPTRK,NBMIX,0,NUN,SIGG,SUN(IOF+1)) + 380 CONTINUE +* + IF(IMPX.GT.0) THEN + WRITE(TEXT12,'(3A4)') (IPPT2(IRES,I),I=2,4) + WRITE(6,'(15H USSIT0: GROUP=,I5,24H. SUBGROUP CALCULATION B, + 1 37HASED ON RESPONSE MATRICES. ISOTOPE='',A12,2H''.)') IGRP, + 2 TEXT12 + ENDIF + IF(IMPX.GT.2) THEN + DO 400 IND=1,NBNRS + T1=0.0 + DO 390 INOR=1,NOR(IRES,IGRP) + T1=T1+WEIGH(INOR,IRES)*XFLUX(IND,INOR,IRES) + 390 CONTINUE + WRITE(6,'(31H USSIT0: AVERAGED FLUX IN GROUP,I4,8H AND RES, + 1 12HONANT REGION,I4,21H FOR RESONANT ISOTOPE,I4,2H =,F9.5)') + 2 IGRP,IND,IRES,T1 + 400 CONTINUE + ENDIF +* + IASM=IASM+NORI + ENDIF + 420 CONTINUE +*---- +* SOLVE FOR THE MULTIBAND FLUX (VECTOR OF LENGTH NREG). +*---- + IDIR=0 + LEXAC=.FALSE. + IF(IMPX.GT.5) WRITE(6,'(/33H USSIT0: PROCESSING MULTIBAND FLU, + 1 14HX (IL=1) WITH ,A,1H.)') CDOOR + IPMACR=C_NULL_PTR + IPSOU=C_NULL_PTR + REBFLG=.FALSE. + CALL DOORFV(CDOOR,IPSYS,NPSYS,IPTRK,IFTRAK,IMPX,NASM,NBMIX, + 1 IDIR,NREG,NUN,IPHASE,LEXAC,MAT,VOL,KEYFLX,TITR,SUN,FUN,IPMACR, + 2 IPSOU,REBFLG) +*---- +* INTEGRATE THE REGION-ORDERED FLUX OVER SUBGROUPS. +*---- + IASM=0 + DO 480 IGRP=1,NGRP + IF(MASKG(IGRP).AND.(GOLD(IRES,IGRP).EQ.-999.)) THEN + UNGAR(:NUN,IRES,IGRP)=0.0 + NORI=NOR(IRES,IGRP) + DO 475 INOR=1,NORI + KPSYS=LCMGIL(IPSYS,IASM+INOR) + IOF=(IASM+INOR-1)*NUN + CALL LCMPUT(KPSYS,'FUNKNO$USS',NUN,2,FUN(IOF+1)) +*---- +* NORMALIZE THE MULTIBAND FLUX. THIS NORMALIZATION IS ONLY REQUIRED IF +* THE MUTUAL SELF-SHIELDING MODEL IS USED. +*---- + IF((NIRES.GT.1).AND.(GOLD(IRES,IGRP).EQ.-999.).AND.(ICORR.EQ.0)) + 1 THEN + IOFF=(IASM+INOR-1)*NUN + AWPHI(0:NBNRS)=0.0 + DO 430 I=1,NREG + IBM=MAT(I) + IF(IBM.GT.0) THEN + IND=IREX(IBM) + AWPHI(IND)=AWPHI(IND)+FUN(IOFF+KEYFLX(I))*VOL(I)/ + 1 VOLMER(IND) + ENDIF + 430 CONTINUE + CALL LCMGET(KPSYS,'DRAGON-PAV',PAV(0,0)) + DO 450 IND=0,NBNRS + TT=0.0 + DO 440 J=1,NREG + IBM=MAT(J) + IF(IBM.GT.0) THEN + JND=IREX(IBM) + IOFS=(IASM+INOR-1)*NUN+KEYFLX(J) + TT=TT+PAV(IND,JND)*SUN(IOFS)*VOL(J)/VOLMER(JND) + ENDIF + 440 CONTINUE + AWPHI(IND)=TT/AWPHI(IND) + 450 CONTINUE + DO 460 I=1,NREG + IBM=MAT(I) + IF(IBM.GT.0) FUN(IOFF+KEYFLX(I))=FUN(IOFF+KEYFLX(I))* + 1 AWPHI(IREX(IBM)) + 460 CONTINUE + ENDIF +* + DO 470 I=1,NUN + IOF=(IASM+INOR-1)*NUN+I + UNGAR(I,IRES,IGRP)=UNGAR(I,IRES,IGRP)+FUN(IOF) + 470 CONTINUE + 475 CONTINUE + IASM=IASM+NORI + ENDIF + 480 CONTINUE + DEALLOCATE(SUN,FUN,NPSYS) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(MATRIX) + DEALLOCATE(SIGX,PAV,SIGWS,WSLD,TOTPT,WEIGH,AWPHI,SIGG,SIGS0X, + 1 SIGTXS,XFLUX) + RETURN + END diff --git a/Dragon/src/USSIT1.f b/Dragon/src/USSIT1.f new file mode 100644 index 0000000..6372563 --- /dev/null +++ b/Dragon/src/USSIT1.f @@ -0,0 +1,441 @@ +*DECK USSIT1 + SUBROUTINE USSIT1(MAXNOR,NGRP,MASKG,IRES,IPLI0,IPTRK,IFTRAK, + 1 CDOOR,IMPX,NBMIX,NREG,NUN,NL,IPHASE,MAXST,MAT,VOL,KEYFLX,LEAKSW, + 2 IREX,SIGGAR,TITR,NIRES,NBNRS,NOR,CONR,GOLD,IPPT1,IPPT2,STGAR, + 3 SSGAR,VOLMER,UNGAR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the multiband fluxes as required by the subgroup method using +* an iterative approach: +* a) assume a single resonant isotope; +* b) use the standard solution doors of Dragon. +* +*Copyright: +* Copyright (C) 2003 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXNOR maximum order of the probability tables (PT). +* NGRP number of energy group. +* MASKG energy group mask pointing on self-shielded groups. +* IRES index of the resonant isotope. +* IPLI0 pointer to the internal microscopic cross section library +* builded by the self-shielding module. +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK file unit number used to store the tracks. +* CDOOR name of the geometry/solution operator. +* IMPX print flag (equal to zero for no print). +* NBMIX number of mixtures in the internal library. +* NREG number of regions. +* NUN number of unknowns in the flux or source vector in one +* energy group and one band. +* NL number of Legendre orders required in the calculation +* (NL=1 or higher). +* IPHASE type of flux solution (=1 use a native flux solution door; +* =2 use collision probabilities). +* MAXST maximum number of fixed point iterations for the ST scattering +* source. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX pointers of fluxes in unknown vector. +* LEAKSW leakage switch (LEAKSW=.TRUE. if neutron leakage through +* external boundary is present). +* IREX fuel region index assigned to each mixture. Equal to zero +* in non-resonant mixtures or in mixtures not used. +* SIGGAR macroscopic x-s of the non-resonant isotopes in each mixture. +* (*,*,*,1) total; (*,*,*,2) transport correction; +* (*,*,*,3) P0 scattering; (*,*,*,4) flux times P0 scattering. +* TITR title. +* NIRES exact number of correlated resonant isotopes. +* NBNRS number of correlated fuel regions. +* NOR exact order of the probability table. +* CONR number density of the resonant isotopes. +* GOLD Goldstein-Cohen parameter (.ge.0.0). +* IPPT1 pointer to LCM directory of each resonant isotope. +* IPPT2 information related to each resonant isotope: +* IPPT2(:,1) index of a resonant region (used with infinite +* dilution case); +* IPPT2(:,2:4) alias name of resonant isotope. +* STGAR averaged microscopic total xs in resonant region. +* SSGAR averaged microscopic scattering xs in resonant region. +* VOLMER volumes of the resonant regions. +* +*Parameters: output +* UNGAR averaged flux unknowns. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE DOORS_MOD +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLI0,IPTRK,IPPT1(NIRES) + INTEGER MAXNOR,NGRP,IRES,IFTRAK,IMPX,NBMIX,NREG,NUN,NL, + 1 IPHASE,MAXST,MAT(NREG),KEYFLX(NREG),IREX(NBMIX),NIRES,NBNRS, + 2 NOR(NIRES,NGRP),IPPT2(NIRES,4) + REAL VOL(NREG),SIGGAR(NBMIX,0:NIRES,NGRP,4), + 1 CONR(NBNRS,NIRES),GOLD(NIRES,NGRP),STGAR(NBNRS,NIRES,NGRP), + 2 SSGAR(NBNRS,NIRES,NL,NGRP),VOLMER(0:NBNRS), + 3 UNGAR(NUN,NIRES,NGRP) + CHARACTER CDOOR*12,TITR*72 + LOGICAL LEAKSW,MASKG(NGRP) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPLIB,KPLIB,JPLI0,KPSYS,IPSYS,IPMACR,IPSOU + CHARACTER CBDPNM*12,TEXT12*12,TEXX12*12,HSMG*131 + LOGICAL EMPTY,LCM,LEXAC,REBFLG +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NPSYS + REAL, ALLOCATABLE, DIMENSION(:) :: SIGTXS,SIGS0X,SIGG,FLNEW,FUN, + 1 SUN + REAL, ALLOCATABLE, DIMENSION(:,:) :: WEIGH,TOTPT,SIGWS + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: XFLUX + TYPE(C_PTR) SIGP_PTR + REAL, POINTER, DIMENSION(:) :: SIGP +*---- +* FIND THE NUMBER OF COMPONENTS REQUIRED AND ALLOCATE THE LIST OF +* ASSEMBLY MATRICES. +*---- + NASM=0 + DO 10 IGRP=1,NGRP + IF(MASKG(IGRP).AND.(GOLD(IRES,IGRP).GT.-900.)) THEN + NASM=NASM+NOR(IRES,IGRP) + ENDIF + 10 CONTINUE + IF(NASM.EQ.0) RETURN +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NPSYS(MAXNOR*NGRP)) + ALLOCATE(XFLUX(NBNRS,MAXNOR,NIRES),SIGTXS(0:NBMIX), + 1 SIGS0X(0:NBMIX),SIGG(0:NBMIX),WEIGH(MAXNOR,NIRES), + 2 TOTPT(MAXNOR,NIRES),SIGWS(MAXNOR,NIRES),FLNEW(NBNRS)) +*---- +* CREATE A SPECIFIC DIRECTORY FOR IRES-TH RESONANT ISOTOPE. +*---- + WRITE(CBDPNM,'(3HCOR,I4.4,1H/,I4.4)') IRES,NIRES + CALL LCMSIX(IPLI0,CBDPNM,1) + JPLI0=LCMGID(IPLI0,'NWT0-PT') + CALL LCMLEN(IPLI0,'ASSEMB-PHYS',ILONG,ITYLCM) + IPSYS=LCMLID(IPLI0,'ASSEMB-PHYS',MAX(ILONG,NASM)) + CALL LCMSIX(IPLI0,' ',2) +*---- +* LOOP OVER THE ENERGY GROUPS. +*---- + IASM=0 + DO 100 IGRP=1,NGRP + IF(MASKG(IGRP).AND.(GOLD(IRES,IGRP).GT.-900.)) THEN + IF(IMPX.GT.2) THEN + WRITE(TEXT12,'(3A4)') (IPPT2(IRES,J0),J0=2,4) + WRITE(6,'(36H USSIT1: PROCESS CORRELATED ISOTOPE ,A12, + 1 11H WITH INDEX,I3,9H IN GROUP,I4,20H (ITERATIVE METHOD).)') + 2 TEXT12,IRES,IGRP + ENDIF + DO 20 JRES=1,NIRES + IF(GOLD(JRES,IGRP).EQ.-998.) THEN + WRITE(HSMG,'(28HUSSIT1: PT SET FOR ISOTOPE '',3A4, + 1 10H'' IN GROUP,I4,1H.)') (IPPT2(JRES,J0),J0=2,4),IGRP + CALL XABORT(HSMG) + ELSE IF(GOLD(JRES,IGRP).EQ.-999.) THEN + WRITE(HSMG,'(30HUSSIT1: PTSL SET FOR ISOTOPE '',3A4, + 1 10H'' IN GROUP,I4,1H.)') (IPPT2(JRES,J0),J0=2,4),IGRP + CALL XABORT(HSMG) + ELSE IF(GOLD(JRES,IGRP).EQ.-1000.) THEN + WRITE(HSMG,'(30HUSSIT1: PTMC SET FOR ISOTOPE '',3A4, + 1 10H'' IN GROUP,I4,1H.)') (IPPT2(JRES,J0),J0=2,4),IGRP + CALL XABORT(HSMG) + ELSE IF(NOR(JRES,IGRP).GT.MAXNOR) THEN + CALL XABORT('USSIT1: MAXNOR OVERFLOW.') + ENDIF + 20 CONTINUE + NORI=NOR(IRES,IGRP) +*---- +* COLLECT THE BASE POINTS IN TOTAL AND PARTIAL CROSS SECTION. +*---- + DO 40 JRES=1,NIRES + JPLIB=LCMGID(IPPT1(JRES),'GROUP-PT') + CALL LCMLEL(JPLIB,IGRP,ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + KPLIB=LCMGIL(JPLIB,IGRP) + CALL LCMINF(KPLIB,TEXT12,TEXX12,EMPTY,ILONG,LCM) + CALL LCMLEN(KPLIB,'PROB-TABLE',LENG,ITYLCM) + NPART=LENG/MAXNOR + IF(LCM) THEN + CALL LCMGPD(KPLIB,'PROB-TABLE',SIGP_PTR) + CALL C_F_POINTER(SIGP_PTR,SIGP,(/ MAXNOR*NPART /)) + ELSE + ALLOCATE(SIGP(MAXNOR*NPART)) + CALL LCMGET(KPLIB,'PROB-TABLE',SIGP) + ENDIF + DO 30 INOR=1,NOR(JRES,IGRP) + WEIGH(INOR,JRES)=SIGP(INOR) + TOTPT(INOR,JRES)=SIGP(MAXNOR+INOR) + SIGWS(INOR,JRES)=SIGP(3*MAXNOR+INOR) + 30 CONTINUE + IF(.NOT.LCM) DEALLOCATE(SIGP) + ELSE + WEIGH(1,JRES)=1.0 + TOTPT(1,JRES)=STGAR(IPPT2(JRES,1),JRES,IGRP) + SIGWS(1,JRES)=SSGAR(IPPT2(JRES,1),JRES,1,IGRP) + ENDIF + 40 CONTINUE +*---- +* SET THE MIXTURE-DEPENDENT CROSS SECTIONS. +*---- + DO 90 INOR=1,NORI + SIGTXS(0:NBMIX)=0.0 + SIGS0X(0:NBMIX)=0.0 + DO 80 IBM=1,NBMIX + IND=IREX(IBM) + DO 70 JRES=0,NIRES + IF(JRES.EQ.0) THEN + SIGTXS(IBM)=SIGTXS(IBM)+(SIGGAR(IBM,0,IGRP,1)- + 1 SIGGAR(IBM,0,IGRP,2)) + SIGS0X(IBM)=SIGS0X(IBM)-SIGGAR(IBM,0,IGRP,2) + ELSE IF((JRES.NE.IRES).AND.(IND.GT.0)) THEN + IF((IPPT2(IRES,2).EQ.IPPT2(JRES,2)).AND. + 1 (IPPT2(IRES,3).EQ.IPPT2(JRES,3))) THEN +* FULL CORRELATION APPROXIMATION SIMILAR TO THE TECHNIQUE +* USED IN ECCO. + SIGTXS(IBM)=SIGTXS(IBM)+CONR(IND,JRES)*TOTPT(INOR,IRES) + SIGS0X(IBM)=SIGS0X(IBM)+(1.0-GOLD(JRES,IGRP))* + 1 CONR(IND,JRES)*SIGWS(INOR,IRES) + ELSE + SIGTXS(IBM)=SIGTXS(IBM)+SIGGAR(IBM,JRES,IGRP,1) + ENDIF + ENDIF + 70 CONTINUE + IF(IND.GT.0) THEN + SIGTXS(IBM)=SIGTXS(IBM)+CONR(IND,IRES)*TOTPT(INOR,IRES) + SIGS0X(IBM)=SIGS0X(IBM)+(1.0-GOLD(IRES,IGRP))*CONR(IND,IRES) + 1 *SIGWS(INOR,IRES) + ENDIF + 80 CONTINUE + IASM=IASM+1 + NPSYS(IASM)=IASM + KPSYS=LCMDIL(IPSYS,IASM) + CALL LCMPUT(KPSYS,'DRAGON-TXSC',NBMIX+1,2,SIGTXS) + CALL LCMPUT(KPSYS,'DRAGON-S0XSC',NBMIX+1,2,SIGS0X) + 90 CONTINUE + ELSE IF(GOLD(IRES,IGRP).GT.-900.) THEN + CALL LCMLEL(JPLI0,IGRP,LENG0,ITYLCM) + IF(LENG0.NE.0) THEN + WRITE(HSMG,'(42HUSSIT1: UNEXPECTED SELF-SHIELDING DATA FOU, + 1 11HND IN GROUP,I5,1H.)') IGRP + CALL XABORT(HSMG) + ENDIF + ENDIF + 100 CONTINUE +*---- +* ASSEMBLY MATRIX OR REDUCED COLLISION PROBABILITIES CALCULATION. +*---- + NANI=1 + KNORM=1 + NALBP=0 + IMPY=MAX(0,IMPX-3) + IF(IPHASE.EQ.1) THEN +* USE A NATIVE DOOR. + ISTRM=1 + NW=0 + CALL DOORAV(CDOOR,IPSYS,NPSYS,IPTRK,IFTRAK,IMPY,NASM,NREG, + 1 NBMIX,NANI,NW,MAT,VOL,KNORM,LEAKSW,TITR,NALBP,ISTRM) + ELSE IF(IPHASE.EQ.2) THEN +* USE A COLLISION PROBABILITY DOOR. + IPIJK=1 + ITPIJ=1 + CALL DOORPV(CDOOR,IPSYS,NPSYS,IPTRK,IFTRAK,IMPY,NASM,NREG, + 1 NBMIX,NANI,MAT,VOL,KNORM,IPIJK,LEAKSW,ITPIJ,.FALSE.,TITR, + 2 NALBP) + ENDIF +*---- +* LOOP OVER THE ENERGY GROUPS. +*---- + IASM=0 + DO 260 IGRP=1,NGRP + IF(MASKG(IGRP).AND.(GOLD(IRES,IGRP).GT.-900.)) THEN + NORI=NOR(IRES,IGRP) +*---- +* COLLECT THE BASE POINTS IN PARTIAL CROSS SECTION. +*---- + DO 120 JRES=1,NIRES + JPLIB=LCMGID(IPPT1(JRES),'GROUP-PT') + CALL LCMLEL(JPLIB,IGRP,ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + KPLIB=LCMGIL(JPLIB,IGRP) + CALL LCMINF(KPLIB,TEXT12,TEXX12,EMPTY,ILONG,LCM) + CALL LCMLEN(KPLIB,'PROB-TABLE',LENG,ITYLCM) + NPART=LENG/MAXNOR + IF(LCM) THEN + CALL LCMGPD(KPLIB,'PROB-TABLE',SIGP_PTR) + CALL C_F_POINTER(SIGP_PTR,SIGP,(/ MAXNOR*NPART /)) + ELSE + ALLOCATE(SIGP(MAXNOR*NPART)) + CALL LCMGET(KPLIB,'PROB-TABLE',SIGP) + ENDIF + DO 110 INOR=1,NOR(JRES,IGRP) + WEIGH(INOR,JRES)=SIGP(INOR) + SIGWS(INOR,JRES)=SIGP(3*MAXNOR+INOR) + 110 CONTINUE + IF(.NOT.LCM) DEALLOCATE(SIGP) + ELSE + WEIGH(1,JRES)=1.0 + SIGWS(1,JRES)=SSGAR(IPPT2(JRES,1),JRES,1,IGRP) + ENDIF + 120 CONTINUE +*---- +* RECOVER THE PREVIOUS FLUXES. +*---- + WRITE(CBDPNM,'(3HCOR,I4.4,1H/,I4.4)') IRES,NIRES + CALL LCMSIX(IPLI0,CBDPNM,1) + JPLI0=LCMGID(IPLI0,'NWT0-PT') + CALL LCMLEL(JPLI0,IGRP,ILON,ITYLCM) + IF(ILON.GT.NBNRS*MAXNOR) THEN + WRITE(TEXT12,'(3A4)') (IPPT2(IRES,J0),J0=2,4) + WRITE(HSMG,'(34HUSSIT1: FLUX OVERFLOW FOR ISOTOPE ,A12)') + 1 TEXT12 + CALL XABORT(HSMG) + ENDIF + CALL LCMGDL(JPLI0,IGRP,XFLUX(1,1,IRES)) + CALL LCMSIX(IPLI0,' ',2) +*---- +* ITERATIVE PROCEDURE. +*---- + ITER=0 + 140 ITER=ITER+1 + IF(ITER.GT.MAXST) THEN + WRITE(HSMG,'(35HUSSIT1: TOO MANY ITERATIONS (MAXST=,I4,2H).)') + 1 MAXST + CALL XABORT(HSMG) + ENDIF + ERR1=0.0 + ERR2=0.0 +*---- +* COMPUTE THE AVERAGED SOURCE. +*---- + ALLOCATE(FUN(NUN*NORI),SUN(NUN*NORI)) + SUN(:NUN*NORI)=0.0 + DO 195 INOR=1,NORI + KPSYS=LCMGIL(IPSYS,IASM+INOR) + CALL LCMLEN(KPSYS,'FUNKNO$USS',ILENG,ITYLCM) + IF(ILENG.EQ.NUN) THEN + CALL LCMGET(KPSYS,'FUNKNO$USS',FUN((INOR-1)*NUN+1)) + ELSE + FUN((INOR-1)*NUN+1:INOR*NUN)=0.0 + ENDIF + NPSYS(INOR)=IASM+INOR + SIGG(0)=0.0 + DO 170 IBM=1,NBMIX + SIGG(IBM)=SIGGAR(IBM,0,IGRP,3) + IND=IREX(IBM) + DO 150 JRES=1,NIRES + IF((JRES.NE.IRES).AND.(IND.GT.0)) THEN + IF((IPPT2(IRES,2).EQ.IPPT2(JRES,2)).AND. + 1 (IPPT2(IRES,3).EQ.IPPT2(JRES,3))) THEN + SIGG(IBM)=SIGG(IBM)+GOLD(JRES,IGRP)*SIGGAR(IBM,JRES,IGRP,4) + ELSE + SIGG(IBM)=SIGG(IBM)+SIGGAR(IBM,JRES,IGRP,4) + ENDIF + ENDIF + 150 CONTINUE + IF(IND.GT.0) THEN + DO 160 JNOR=1,NORI + SIGG(IBM)=SIGG(IBM)+GOLD(IRES,IGRP)*WEIGH(JNOR,IRES)* + 1 CONR(IND,IRES)*SIGWS(JNOR,IRES)*XFLUX(IND,JNOR,IRES) + 160 CONTINUE + ENDIF + 170 CONTINUE + IOF=(INOR-1)*NUN + CALL DOORS(CDOOR,IPTRK,NBMIX,0,NUN,SIGG,SUN(IOF+1)) + 195 CONTINUE +*---- +* SOLVE FOR THE MULTIBAND FLUX. +*---- + IDIR=0 + LEXAC=.FALSE. + IPMACR=C_NULL_PTR + IPSOU=C_NULL_PTR + REBFLG=.FALSE. + CALL DOORFV(CDOOR,IPSYS,NPSYS,IPTRK,IFTRAK,IMPX,NORI,NBMIX, + 1 IDIR,NREG,NUN,IPHASE,LEXAC,MAT,VOL,KEYFLX,TITR,SUN,FUN,IPMACR, + 2 IPSOU,REBFLG) +*---- +* HOMOGENIZE THE FLUX AT ITERATION ITER. +*---- + UNGAR(:NUN,IRES,IGRP)=0.0 + DO 235 INOR=1,NORI + KPSYS=LCMGIL(IPSYS,IASM+INOR) + CALL LCMPUT(KPSYS,'FUNKNO$USS',NUN,2,FUN((INOR-1)*NUN+1)) + FLNEW(:NBNRS)=0.0 + DO 200 I=1,NREG + IF(MAT(I).EQ.0) GO TO 200 + IOF=(INOR-1)*NUN+KEYFLX(I) + IND=IREX(MAT(I)) + IF(IND.GT.0) FLNEW(IND)=FLNEW(IND)+FUN(IOF)*VOL(I) + 200 CONTINUE + DO 210 IND=1,NBNRS + FLNEW(IND)=FLNEW(IND)/VOLMER(IND) + 210 CONTINUE +* + DO 220 I=1,NUN + IOF=(INOR-1)*NUN+I + UNGAR(I,IRES,IGRP)=UNGAR(I,IRES,IGRP)+FUN(IOF)*WEIGH(INOR,IRES) + 220 CONTINUE +*---- +* COMPUTE ERR1 AND ERR2. +*---- + DO 230 IND=1,NBNRS + ERR1=MAX(ERR1,ABS(FLNEW(IND)-XFLUX(IND,INOR,IRES))) + ERR2=MAX(ERR2,ABS(FLNEW(IND))) + XFLUX(IND,INOR,IRES)=FLNEW(IND) + 230 CONTINUE + 235 CONTINUE + DEALLOCATE(SUN,FUN) +*---- +* CONVERGENCE CONTROL. +*---- + IF(IMPX.GT.2) THEN + WRITE(TEXT12,'(3A4)') (IPPT2(IRES,I),I=2,4) + WRITE(6,'(15H USSIT1: GROUP=,I5,24H. SUBGROUP ITERATION ITE, + 1 6HRATION,I4,11H. ISOTOPE='',A12,9H''. ERROR=,1P,E11.4,1H.)') + 2 IGRP,ITER,TEXT12,ERR1 + ENDIF + IF((ERR1.GT.1.0E-4*ERR2).AND.(GOLD(IRES,IGRP).NE.0.0)) GO TO 140 + IF(IMPX.GT.1) THEN + WRITE(TEXT12,'(3A4)') (IPPT2(IRES,I),I=2,4) + WRITE(6,'(15H USSIT1: GROUP=,I5,24H. SUBGROUP ITERATION CON, + 1 11HVERGENCE IN,I4,22H ITERATIONS. ISOTOPE='',A12,2H''.)') + 2 IGRP,ITER,TEXT12 + ENDIF + IF(IMPX.GT.2) THEN + DO 250 IND=1,NBNRS + T1=0.0 + DO 240 INOR=1,NORI + T1=T1+WEIGH(INOR,IRES)*XFLUX(IND,INOR,IRES) + 240 CONTINUE + WRITE(6,'(31H USSIT1: AVERAGED FLUX IN GROUP,I4,9H AND RESO, + 1 11HNANT REGION,I4,21H FOR RESONANT ISOTOPE,I4,2H =,F9.5)') + 2 IGRP,IND,IRES,T1 + 250 CONTINUE + ENDIF + CALL LCMPDL(JPLI0,IGRP,NBNRS*NORI,2,XFLUX(1,1,IRES)) + IASM=IASM+NORI + ENDIF + 260 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(FLNEW,SIGWS,TOTPT,WEIGH,SIGG,SIGS0X,SIGTXS,XFLUX) + DEALLOCATE(NPSYS) + RETURN + END diff --git a/Dragon/src/USSIT2.f b/Dragon/src/USSIT2.f new file mode 100644 index 0000000..8738ee2 --- /dev/null +++ b/Dragon/src/USSIT2.f @@ -0,0 +1,277 @@ +*DECK USSIT2 + SUBROUTINE USSIT2(MAXNOR,IPLI0,IGRP,NGRP,ISMIN,ISMAX,NIRES,NBNRS, + 1 NL,NED,NDEL,NOR,IPPT1,IPPT2,GOLD,MAXXS,ISUBG,PHGAR,STGAR,SFGAR, + 2 SSGAR,S0GAR,SAGAR,SDGAR,SWGAR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute self-shielded microscopic cross sections. +* +*Copyright: +* Copyright (C) 2003 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXNOR maximum order of the probability tables (PT). +* IPLI0 pointer to the internal microscopic cross section library +* builded by the self-shielding module. +* IGRP energy group under consideration. +* NGRP number of energy groups. +* ISMIN minimum secondary group corresponding to group IGRP. +* ISMAX maximum secondary group corresponding to group IGRP. +* NIRES exact number of resonant isotopes. +* NBNRS number of correlated fuel regions. +* NL number of Legendre orders required in the calculation +* (NL=1 or higher). +* NED number of extra vector edits. +* NDEL number of delayed neutron precursor groups. +* NOR exact order of the probability table. +* IPPT1 pointer to LCM directory of each resonant isotope. +* IPPT2 information related to each resonant isotope: +* IPPT2(:,1) index of a resonant region (used with infinite +* dilution case); +* IPPT2(:,2:4) alias name of resonant isotope; +* IPPT2(:,5) number of delayed neutron groups. +* GOLD Goldstein-Cohen parameters. Set to -999. to enable the Ribon +* extended method for a specific isotope. +* MAXXS number of x-s types. +* ISUBG type of self-shielding model (=1 use physical probability +* tables; =4 use Ribon extended method). +* +*Parameters: output +* PHGAR averaged flux. +* STGAR averaged microscopic total xs in resonant region. +* SFGAR averaged nu*microscopic fission xs in resonant region. +* SSGAR averaged microscopic scattering xs in resonant region. +* S0GAR averaged microscopic transfer scattering xs in resonant +* region for primary neutrons in current group. +* SAGAR averaged microscopic self-shielded additional xs. +* SDGAR microscopic self-shielded delayed nu-sigf xs. +* SWGAR averaged microscopic secondary slowing-down cross sections +* (ISUBG=4). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLI0,IPPT1(NIRES) + INTEGER MAXNOR,NGRP,ISMIN(NL),ISMAX(NL),NIRES,NBNRS,NL,NED,NDEL, + 1 NOR(NIRES),IPPT2(NIRES,5),MAXXS,ISUBG + REAL GOLD(NIRES),PHGAR(NBNRS,NIRES),STGAR(NBNRS,NIRES), + 1 SFGAR(NBNRS,NIRES),SSGAR(NBNRS,NIRES,NL), + 2 S0GAR(NBNRS,NIRES,NL,NGRP),SAGAR(NBNRS,NIRES,NED), + 3 SDGAR(NBNRS,NIRES,NDEL),SWGAR(NBNRS,NIRES) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPLIB,KPLIB,JPLI0 + LOGICAL EMPTY,LCM + CHARACTER HSMG*131,TEXT12*12,TEXX12*12,CBDPNM*12 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISM + REAL, ALLOCATABLE, DIMENSION(:) :: CGAR + REAL, ALLOCATABLE, DIMENSION(:,:) :: WEIGH,TOTPT,SIGFPT,SIGWPT, + 1 XFLUX + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SIGSPT,SIGAPT,SIGDPT + REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: SIG0PT + TYPE(C_PTR) SIGP_PTR + REAL, POINTER, DIMENSION(:) :: SIGP +*---- +* SCRATCH STORAGE ALLOCATION +* ISM minimum/maximum secondary group indices. +*---- + ALLOCATE(ISM(2,NL)) + ALLOCATE(CGAR(MAXXS),WEIGH(MAXNOR,NIRES),TOTPT(MAXNOR,NIRES), + 1 SIGFPT(MAXNOR,NIRES),SIGSPT(MAXNOR,NIRES,NL), + 2 SIG0PT(MAXNOR,NIRES,NL,NGRP),SIGAPT(MAXNOR,NIRES,NED), + 3 SIGDPT(MAXNOR,NIRES,NDEL),SIGWPT(MAXNOR,NIRES), + 4 XFLUX(NBNRS,MAXNOR)) +*---- +* RECOVER THE PROBABILITY TABLE INFORMATION IN CURRENT GROUP. +*---- + DO 110 IRES=1,NIRES + JPLIB=LCMGID(IPPT1(IRES),'GROUP-PT') + CALL LCMLEL(JPLIB,IGRP,ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + KPLIB=LCMGIL(JPLIB,IGRP) +* RECOVER PROBABILITY TABLE VALUES FROM PT-TABLE DIRECTORY. + CALL LCMINF(KPLIB,TEXT12,TEXX12,EMPTY,ILONG,LCM) + CALL LCMGET(KPLIB,'ISM-LIMITS',ISM) + CALL LCMLEN(KPLIB,'PROB-TABLE',LENG,ITYLCM) + IF(LENG.EQ.0) THEN + CALL XABORT('USSIT2: NO PROBABILITY TABLES PRESENT.') + ELSE + NPART=LENG/MAXNOR + ENDIF + IF(LCM) THEN + CALL LCMGPD(KPLIB,'PROB-TABLE',SIGP_PTR) + CALL C_F_POINTER(SIGP_PTR,SIGP,(/ MAXNOR*NPART /)) + ELSE + ALLOCATE(SIGP(MAXNOR*NPART)) + CALL LCMGET(KPLIB,'PROB-TABLE',SIGP) + ENDIF + CALL LCMLEN(KPLIB,'SIGQT-SLOW',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPLIB,'SIGQT-SIGS',SIGWPT(1,IRES)) + ENDIF + NDEL0=IPPT2(IRES,5) + IF(NDEL0.GT.NDEL) CALL XABORT('USSIT2: NDEL OVERFLOW.') + DO 70 INOR=1,NOR(IRES) + WEIGH(INOR,IRES)=SIGP(INOR) + TOTPT(INOR,IRES)=SIGP(MAXNOR+INOR) + SIGFPT(INOR,IRES)=SIGP(2*MAXNOR+INOR) + IPP=3 + DO 10 IL=1,NL + IPP=IPP+1 + SIGSPT(INOR,IRES,IL)=SIGP((IPP-1)*MAXNOR+INOR) + 10 CONTINUE + DO 35 IL=1,NL + DO 20 JG=1,NGRP + SIG0PT(INOR,IRES,IL,JG)=0.0 + 20 CONTINUE + DO 30 JG=ISM(1,IL),ISM(2,IL) + IPP=IPP+1 + SIG0PT(INOR,IRES,IL,JG)=SIGP((IPP-1)*MAXNOR+INOR) + 30 CONTINUE + 35 CONTINUE + DO 40 IED=1,NED + IPP=IPP+1 + SIGAPT(INOR,IRES,IED)=SIGP((IPP-1)*MAXNOR+INOR) + 40 CONTINUE + DO 50 IDEL=1,NDEL + SIGDPT(INOR,IRES,IDEL)=0.0 + 50 CONTINUE + DO 60 IDEL=1,NDEL0 + IPP=IPP+1 + SIGDPT(INOR,IRES,IDEL)=SIGP((IPP-1)*MAXNOR+INOR) + 60 CONTINUE + IF(IPP.NE.NPART) THEN + WRITE(TEXT12,'(3A4)') (IPPT2(IRES,J0),J0=2,4) + WRITE(HSMG,'(26HUSSIT2: FAILURE. ISOTOPE='',A12,7H'' (IPP=, + 1 I6,7H NPART=,I6,6H IGRP=,I6,2H).)') TEXT12,IPP,NPART,IGRP + CALL XABORT(HSMG) + ENDIF + 70 CONTINUE + IF(.NOT.LCM) DEALLOCATE(SIGP) + ELSE +* USE INFINITE DILUTION VALUES. + IND=IPPT2(IRES,1) + XFLUX(:NBNRS,1)=1.0 + WEIGH(1,IRES)=1.0 + TOTPT(1,IRES)=STGAR(IND,IRES) + SIGFPT(1,IRES)=SFGAR(IND,IRES) + SIGWPT(1,IRES)=SWGAR(IND,IRES) + DO 80 IED=1,NED + SIGAPT(1,IRES,IED)=SAGAR(IND,IRES,IED) + 80 CONTINUE + DO 90 IDEL=1,NDEL + SIGDPT(1,IRES,IDEL)=SDGAR(IND,IRES,IDEL) + 90 CONTINUE + DO 105 IL=1,NL + SIGSPT(1,IRES,IL)=SSGAR(IND,IRES,IL) + DO 100 JG=1,NGRP + SIG0PT(1,IRES,IL,JG)=S0GAR(IND,IRES,IL,JG) + 100 CONTINUE + 105 CONTINUE + ENDIF + 110 CONTINUE +*---- +* COMPUTE THE SELF-SHIELDED CROSS SECTIONS IN CURRENT GROUP. +*---- + DO 230 K=1,NIRES + IF(NOR(K).EQ.1) GO TO 230 + WRITE(CBDPNM,'(3HCOR,I4.4,1H/,I4.4)') K,NIRES + NDEL0=IPPT2(K,5) + CALL LCMSIX(IPLI0,CBDPNM,1) + JPLI0=LCMGID(IPLI0,'NWT0-PT') + CALL LCMGDL(JPLI0,IGRP,XFLUX) + CALL LCMSIX(IPLI0,' ',2) + DO 220 I=1,NBNRS + PHGAR(I,K)=0.0 + DO 120 IOF=1,MAXXS + CGAR(IOF)=0.0 + 120 CONTINUE + DO 170 KINOR=1,NOR(K) + WW=XFLUX(I,KINOR)*WEIGH(KINOR,K) + PHGAR(I,K)=PHGAR(I,K)+WW + CGAR(1)=CGAR(1)+TOTPT(KINOR,K)*WW + CGAR(2)=CGAR(2)+SIGFPT(KINOR,K)*WW + IOF=2 + JOF=0 + DO 140 IL=1,NL + IOF=IOF+1 + IF((ISUBG.EQ.4).AND.(GOLD(K).EQ.-999.)) THEN + WW=XFLUX(I,KINOR)*WEIGH(KINOR,K) + ENDIF + CGAR(IOF)=CGAR(IOF)+SIGSPT(KINOR,K,IL)*WW + JOF=IOF + DO 130 JGRP=ISMIN(IL),ISMAX(IL) + JOF=JOF+1 + CGAR(JOF)=CGAR(JOF)+SIG0PT(KINOR,K,IL,JGRP)*WW + 130 CONTINUE + IOF=JOF + 140 CONTINUE + IOF=JOF + DO 150 IED=1,NED + IOF=IOF+1 + CGAR(IOF)=CGAR(IOF)+SIGAPT(KINOR,K,IED)*WW + 150 CONTINUE + DO 160 IDEL=1,NDEL0 + IOF=IOF+1 + CGAR(IOF)=CGAR(IOF)+SIGDPT(KINOR,K,IDEL)*WW + 160 CONTINUE + IOF=IOF+NDEL-NDEL0 + IF((ISUBG.EQ.4).AND.(GOLD(K).EQ.-999.)) THEN + IOF=IOF+1 + CGAR(IOF)=CGAR(IOF)+SIGWPT(KINOR,K)*WW + ELSE IF(ISUBG.EQ.4) THEN + IOF=IOF+1 + CGAR(IOF)=CGAR(IOF)+SIGSPT(KINOR,K,1)*WW + ENDIF + IF(IOF.NE.MAXXS) CALL XABORT('USSIT2: BAD NB OF X-S TYPES.') + 170 CONTINUE +* + STGAR(I,K)=CGAR(1)/PHGAR(I,K) + SFGAR(I,K)=CGAR(2)/PHGAR(I,K) + IOF=2 + DO 195 IL=1,NL + IOF=IOF+1 + SSGAR(I,K,IL)=CGAR(IOF)/PHGAR(I,K) + DO 180 JGRP=1,NGRP + S0GAR(I,K,IL,JGRP)=0.0 + 180 CONTINUE + DO 190 JGRP=ISMIN(IL),ISMAX(IL) + IOF=IOF+1 + S0GAR(I,K,IL,JGRP)=CGAR(IOF)/PHGAR(I,K) + 190 CONTINUE + 195 CONTINUE + DO 200 IED=1,NED + IOF=IOF+1 + SAGAR(I,K,IED)=CGAR(IOF)/PHGAR(I,K) + 200 CONTINUE + DO 210 IDEL=1,NDEL0 + IOF=IOF+1 + SDGAR(I,K,IDEL)=CGAR(IOF)/PHGAR(I,K) + 210 CONTINUE + IOF=IOF+NDEL-NDEL0 + IF(ISUBG.EQ.4) SWGAR(I,K)=CGAR(IOF+1)/PHGAR(I,K) + 220 CONTINUE + 230 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XFLUX,SIGWPT,SIGDPT,SIGAPT,SIG0PT,SIGSPT,SIGFPT,TOTPT, + 1 WEIGH,CGAR) + DEALLOCATE(ISM) + RETURN + END diff --git a/Dragon/src/USSIT3.f b/Dragon/src/USSIT3.f new file mode 100644 index 0000000..32c1e41 --- /dev/null +++ b/Dragon/src/USSIT3.f @@ -0,0 +1,466 @@ +*DECK USSIT3 + SUBROUTINE USSIT3(MAXNOR,NGRP,MASKG,IRES,IPLI0,IPTRK,IFTRAK,CDOOR, + 1 IMPX,NBMIX,NREG,NUN,IPHASE,MAXST,MAT,VOL,KEYFLX,LEAKSW,IREX, + 2 SIGGAR,TITR,ICORR,NIRES,NBNRS,CONR,GOLD,IPPT1,IPPT2,VOLMER, + 3 UNGAR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the snapshot weights as required by the resonance spectrum +* expansion (RSE) method: +* a) assume a single resonant isotope; +* b) use the standard solution doors of Dragon. +* +*Copyright: +* Copyright (C) 2023 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXNOR maximum number of base points. +* NGRP number of energy group. +* MASKG energy group mask pointing on self-shielded groups. +* IRES index of the resonant isotope. +* IPLI0 pointer to the internal microscopic cross section library +* builded by the self-shielding module. +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK file unit number used to store the tracks. +* CDOOR name of the geometry/solution operator. +* IMPX print flag (equal to zero for no print). +* NBMIX number of mixtures in the internal library. +* NREG number of regions. +* NUN number of unknowns in the flux or source vector in one +* energy group and one band. +* IPHASE type of flux solution (=1 use a native flux solution door; +* =2 use collision probabilities). +* MAXST maximum number of fixed point iterations for the ST scattering +* source. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX pointers of fluxes in unknown vector. +* LEAKSW leakage switch (LEAKSW=.TRUE. if neutron leakage through +* external boundary is present). +* IREX fuel region index assigned to each mixture. Equal to zero +* in non-resonant mixtures or in mixtures not used. +* SIGGAR macroscopic x-s of the non-resonant isotopes in each mixture: +* (*,*,*,1) total; (*,*,*,2) transport correction; +* (*,*,*,3) P0 scattering. +* TITR title. +* ICORR mutual resonance shielding flag (=1 to suppress the model +* in cases it is required in LIB operator). +* NIRES exact number of correlated resonant isotopes. +* NBNRS number of correlated fuel regions. +* CONR number density of the resonant isotopes. +* GOLD type of self-shielding model (=1.0 physical probability +* tables; =-1001.0 resonance spectrum expansion method). +* IPPT1 pointer to LCM directory of each resonant isotope. +* IPPT2 information related to each resonant isotope: +* IPPT2(:,1) index of a resonant region (used with infinite +* dilution case); +* IPPT2(:,2:4) alias name of resonant isotope. +* VOLMER volumes of the resonant regions. +* +*Parameters: output +* UNGAR averaged flux unknowns. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE DOORS_MOD +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLI0,IPTRK,IPPT1(NIRES) + INTEGER MAXNOR,NGRP,IRES,IFTRAK,IMPX,NBMIX,NREG,NUN,IPHASE, + 1 MAXST,MAT(NREG),KEYFLX(NREG),IREX(NBMIX),ICORR,NIRES,NBNRS, + 2 IPPT2(NIRES,4) + REAL VOL(NREG),SIGGAR(NBMIX,0:NIRES,NGRP,3),CONR(NBNRS,NIRES), + 1 GOLD(NIRES,NGRP),VOLMER(0:NBNRS),UNGAR(NUN,NIRES,NGRP) + CHARACTER CDOOR*12,TITR*72 + LOGICAL LEAKSW,MASKG(NGRP) +*---- +* LOCAL VARIABLES +*---- + REAL ERR1,ERR2 + DOUBLE PRECISION T1 + CHARACTER CBDPNM*12,TEXT12*12 + LOGICAL LEXAC,REBFLG,LSOUR + TYPE(C_PTR) IPLIB,JPLI0,JPLIB1,KPLIB,IPSYS,KPSYS,IOFSET, + 1 IPMACR,IPSOU +*---- +* ALLOCATABLE ARRAYS +*---- + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: JPLIB2,JPLIB3 + INTEGER, ALLOCATABLE, DIMENSION(:) :: NPSYS,MRANK + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NJJ + REAL, ALLOCATABLE, DIMENSION(:) :: SIGTXS,SIGS0X,SIGG + REAL, ALLOCATABLE, DIMENSION(:,:) :: FUN,SUN + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: XFLUX2 + TYPE VECTOR_ARRAY + DOUBLE PRECISION, POINTER, DIMENSION(:) :: VECTOR + END TYPE VECTOR_ARRAY + TYPE MATRIX_ARRAY + DOUBLE PRECISION, POINTER, DIMENSION(:,:) :: MATRIX + END TYPE MATRIX_ARRAY + TYPE(VECTOR_ARRAY), ALLOCATABLE, DIMENSION(:) :: SIGT_V,WEIGHT_V, + 1 GAMMA_V + TYPE(MATRIX_ARRAY), ALLOCATABLE, DIMENSION(:,:) :: SIGT_M + TYPE(MATRIX_ARRAY), ALLOCATABLE, DIMENSION(:,:,:) :: SCAT_M + TYPE MATRIX_ARRAY_SP + REAL, POINTER, DIMENSION(:,:) :: MATRIX + END TYPE MATRIX_ARRAY_SP + TYPE(MATRIX_ARRAY_SP), ALLOCATABLE, DIMENSION(:) :: PSI_M +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(JPLIB2(NIRES),JPLIB3(NIRES)) + ALLOCATE(NJJ(NGRP,NIRES),NPSYS(MAXNOR*NGRP),MRANK(NGRP)) + ALLOCATE(SIGT_V(NGRP),SIGT_M(NGRP,NIRES),SCAT_M(NGRP,NGRP,NIRES), + 1 WEIGHT_V(NGRP),GAMMA_V(NGRP),PSI_M(NGRP)) +*---- +* FIND THE NUMBER OF COMPONENTS REQUIRED AND ALLOCATE THE LIST OF +* ASSEMBLY MATRICES. +*---- + IPLIB=IPPT1(IRES) + CALL LCMLEN(IPLIB,'NOR',ILONG,ITYLCM) + IF(ILONG.NE.NGRP) THEN + CALL LCMLIB(IPLIB) + CALL XABORT('USSIT3: RANK ARRAY MISSING.') + ENDIF + CALL LCMGET(IPLIB,'NOR',MRANK) + NASM=0 + DO IG=1,NGRP + IF(MASKG(IG).AND.(GOLD(IRES,IG).EQ.-1001.)) THEN + NASM=NASM+MRANK(IG) + ENDIF + ENDDO + IF(NASM.EQ.0) GO TO 50 + DO JRES=1,NIRES + DO JG=1,NGRP + DO IG=1,NGRP + NULLIFY(SCAT_M(IG,JG,JRES)%MATRIX) + ENDDO + ENDDO + ENDDO +*---- +* CREATE A SPECIFIC DIRECTORY FOR IRES-TH RESONANT ISOTOPE. +*---- + WRITE(CBDPNM,'(3HCOR,I4.4,1H/,I4.4)') IRES,NIRES + CALL LCMSIX(IPLI0,CBDPNM,1) + JPLI0=LCMGID(IPLI0,'NWT0-PT') + IPSYS=LCMLID(IPLI0,'ASSEMB-RSE',NASM) + CALL LCMSIX(IPLI0,' ',2) +*---- +* RECOVER RSE INFORMATION FROM MICROLIB (PART 1) +*---- + JPLIB1=LCMGID(IPLIB,'GROUP-RSE') + DO JRES=1,NIRES + WRITE(TEXT12,'(3A4)') (IPPT2(JRES,I),I=2,4) + CALL LCMSIX(IPLIB,TEXT12,1) + IF(JRES.NE.IRES) THEN + JPLIB2(JRES)=LCMGID(IPLIB,'SIGT_M') ! holds SIGT_M information + ELSE + JPLIB2(JRES)=C_NULL_PTR + ENDIF + JPLIB3(JRES)=LCMGID(IPLIB,'SCAT_M') ! holds SCAT_M information + CALL LCMGET(IPLIB,'NJJS00',NJJ(:NGRP,JRES)) + CALL LCMSIX(IPLIB,' ',2) + ENDDO + IPOS=1 + DO IG=1,NGRP + IF(.NOT.MASKG(IG).OR.(GOLD(IRES,IG).NE.-1001.)) CYCLE + IF(IMPX.GE.9) WRITE(6,'(22H USSIT3: energy group=,I8)') IG +*---- +* RECOVER RSE INFORMATION FROM MICROLIB (PART 2) +*---- + MI=MRANK(IG) + KPLIB=LCMGIL(JPLIB1,IG) + CALL LCMLEN(KPLIB,'SIGT_V',ILONG,ITYLCM) + IF(ILONG.GT.MAXNOR) CALL XABORT('USSIT3: MAXNOR OVERFLOW.') + CALL LCMGPD(KPLIB,'SIGT_V',IOFSET) + CALL C_F_POINTER(IOFSET,SIGT_V(IG)%VECTOR,(/MI/)) + CALL LCMGPD(KPLIB,'WEIGHT_V',IOFSET) + CALL C_F_POINTER(IOFSET,WEIGHT_V(IG)%VECTOR,(/MI/)) + CALL LCMGPD(KPLIB,'GAMMA_V',IOFSET) + CALL C_F_POINTER(IOFSET,GAMMA_V(IG)%VECTOR,(/MI/)) + DO JRES=1,NIRES + IF(JRES.NE.IRES) THEN + CALL LCMGPL(JPLIB2(JRES),IG,IOFSET) + CALL C_F_POINTER(IOFSET,SIGT_M(IG,JRES)%MATRIX,(/MI,MI/)) + ENDIF + IPOS=1 + DO JG=1,IG-1 + IPOS=IPOS+NJJ(JG,JRES) + ENDDO + DO JG=IG-NJJ(IG,JRES)+1,IG + MJ=MRANK(JG) + CALL LCMGPL(JPLIB3(JRES),IPOS+IG-JG,IOFSET) + CALL C_F_POINTER(IOFSET,SCAT_M(IG,JG,JRES)%MATRIX,(/MI,MJ/)) + ENDDO + ENDDO + ENDDO +*---- +* INITIALIZE THE SUBGROUP FLUX WITH FUNKNO$USS INFORMATION +*---- + IASM=0 + DO IG=1,NGRP + IF(.NOT.MASKG(IG).OR.(GOLD(IRES,IG).NE.-1001.)) CYCLE + MI=MRANK(IG) + ALLOCATE(PSI_M(IG)%MATRIX(NUN,MI)) + DO IM=1,MI + CALL LCMLEL(IPSYS,IASM+IM,ILONG,ITYLCM) + IF(ILONG.EQ.-1) THEN + KPSYS=LCMGIL(IPSYS,IASM+IM) + CALL LCMGET(KPSYS,'FUNKNO$USS',PSI_M(IG)%MATRIX(:NUN,IM)) + ELSE + PSI_M(IG)%MATRIX(:NUN,IM)=REAL(GAMMA_V(IG)%VECTOR(IM)) + ENDIF + ENDDO +*---- +* COMPUTE GROUPWISE MACROSCOPIC CROSS SECTIONS. +*---- + ALLOCATE(SIGTXS(0:NBMIX),SIGS0X(0:NBMIX)) + DO IM=1,MI + SIGTXS(0:NBMIX)=0.0 + SIGS0X(0:NBMIX)=0.0 + DO IBM=1,NBMIX + IND=IREX(IBM) + DO 10 JRES=0,NIRES + IF(JRES.EQ.0) THEN +* ADMIXED NON-RESONANT ISOTOPES. + SIGTXS(IBM)=SIGTXS(IBM)+(SIGGAR(IBM,0,IG,1)- + 1 SIGGAR(IBM,0,IG,2)) + SIGS0X(IBM)=SIGS0X(IBM)-SIGGAR(IBM,0,IG,2) + ELSE IF((JRES.NE.IRES).AND.(IND.GT.0).AND.(ICORR.EQ.1)) THEN +* ECCO CORRELATION MODEL. + IF((IPPT2(IRES,2).EQ.IPPT2(JRES,2)).AND. + 1 (IPPT2(IRES,3).EQ.IPPT2(JRES,3))) THEN + DENSIT=CONR(IND,JRES) + SIGTXS(IBM)=SIGTXS(IBM)+DENSIT* + 1 REAL(SIGT_V(IG)%VECTOR(IM)) + SIGS0X(IBM)=SIGS0X(IBM)+DENSIT* + 1 REAL(SCAT_M(IG,IG,JRES)%MATRIX(IM,IM)) + ELSE + DENSIT=CONR(IND,JRES) + SIGS0X(IBM)=SIGS0X(IBM)+DENSIT* + 1 REAL(SCAT_M(IG,IG,JRES)%MATRIX(IM,IM)) + ENDIF + ELSE IF((JRES.NE.IRES).AND.(IND.GT.0).AND.(ICORR.EQ.0)) THEN +* MUTUAL SHIELDING MODEL OF CORRELATED RESONANT ISOTOPES. + DENSIT=CONR(IND,JRES) + SIGTXS(IBM)=SIGTXS(IBM)+DENSIT* + 1 REAL(SIGT_M(IG,JRES)%MATRIX(IM,IM)) + SIGS0X(IBM)=SIGS0X(IBM)+DENSIT* + 1 REAL(SCAT_M(IG,IG,JRES)%MATRIX(IM,IM)) + ENDIF + 10 CONTINUE + IF(IND.GT.0) THEN + DENSIT=CONR(IND,IRES) + SIGTXS(IBM)=SIGTXS(IBM)+DENSIT*REAL(SIGT_V(IG)%VECTOR(IM)) + SIGS0X(IBM)=SIGS0X(IBM)+DENSIT* + 1 REAL(SCAT_M(IG,IG,IRES)%MATRIX(IM,IM)) + ENDIF + ENDDO + NPSYS(IASM+IM)=IASM+IM + KPSYS=LCMDIL(IPSYS,IASM+IM) + CALL LCMPUT(KPSYS,'DRAGON-TXSC',NBMIX+1,2,SIGTXS(0)) + CALL LCMPUT(KPSYS,'DRAGON-S0XSC',NBMIX+1,2,SIGS0X(0)) + ENDDO + IASM=IASM+MI + DEALLOCATE(SIGS0X,SIGTXS) + ENDDO +*---- +* ASSEMBLY MATRIX OR REDUCED COLLISION PROBABILITIES CALCULATION. +*---- + NANI=1 + KNORM=1 + NALBP=0 + IMPY=MAX(0,IMPX-3) + IF(IPHASE.EQ.1) THEN +* USE A NATIVE DOOR. + ISTRM=1 + NW=0 + CALL DOORAV(CDOOR,IPSYS,NPSYS,IPTRK,IFTRAK,IMPY,NASM,NREG, + 1 NBMIX,NANI,NW,MAT,VOL,KNORM,LEAKSW,TITR,NALBP,ISTRM) + ELSE IF(IPHASE.EQ.2) THEN +* USE A COLLISION PROBABILITY DOOR. + IPIJK=1 + ITPIJ=1 + CALL DOORPV(CDOOR,IPSYS,NPSYS,IPTRK,IFTRAK,IMPY,NASM,NREG, + 1 NBMIX,NANI,MAT,VOL,KNORM,IPIJK,LEAKSW,ITPIJ,.FALSE.,TITR, + 2 NALBP) + ENDIF +*---- +* LOOP OVER ENERGY GROUPS FOR THE FLUX CALCULATION. +*---- + ALLOCATE(XFLUX2(NBNRS,MAXNOR,NGRP)) + XFLUX2(:NBNRS,:MAXNOR,:NGRP)=0.0 + IASM=0 + DO IG=1,NGRP + MI=MRANK(IG) + IF(.NOT.MASKG(IG).OR.(GOLD(IRES,IG).NE.-1001.)) CYCLE + ITER=0 + 20 ITER=ITER+1 + IF(ITER.GT.MAXST) GO TO 30 + ERR1=0.0 + ERR2=0.0 +*---- +* COMPUTE THE AVERAGED SOURCE TAKING INTO ACCOUNT CORRELATION EFFECTS. +*---- + ALLOCATE(FUN(NUN,MI),SUN(NUN,MI),SIGG(0:NBMIX)) + SUN(:NUN,:MI)=0.0 + DO IM=1,MI + FUN(:NUN,IM)=PSI_M(IG)%MATRIX(:NUN,IM) + NPSYS(IM)=IASM+IM + SIGG(0)=0.0 + DO IBM=1,NBMIX + SIGG(IBM)=REAL(SIGGAR(IBM,0,IG,3)*GAMMA_V(IG)%VECTOR(IM),4) + ENDDO + CALL DOORS(CDOOR,IPTRK,NBMIX,0,NUN,SIGG,SUN(1,IM)) + DO JG=1,IG + DO JM=1,MRANK(JG) + IF((JG.EQ.IG).AND.(JM.EQ.IM)) CYCLE + SIGG(0:NBMIX)=0.0 + LSOUR=.FALSE. + DO IBM=1,NBMIX + IND=IREX(IBM) + IF(IND.LE.0) CYCLE + DO JRES=1,NIRES + DENSIT=CONR(IND,JRES) + IF((JG.EQ.IG).AND.(JRES.NE.IRES)) THEN + ! process off-diagonal terms in SIGT_M(IG,JRES)%MATRIX + LSOUR=.TRUE. + SIGG(IBM)=SIGG(IBM)-REAL(DENSIT* + 1 SIGT_M(IG,JRES)%MATRIX(IM,JM),4) + ENDIF + IF(JG.LT.IG-NJJ(IG,JRES)+1) CYCLE + IF(GOLD(IRES,JG).NE.-1001.) CYCLE + LSOUR=.TRUE. + SIGG(IBM)=SIGG(IBM)+DENSIT*REAL( + 1 SCAT_M(IG,JG,JRES)%MATRIX(IM,JM),4) + ENDDO ! JRES + ENDDO ! IBM + IF(LSOUR) CALL DOORS(CDOOR,IPTRK,NBMIX,0,NUN,SIGG, + 1 SUN(1,IM),PSI_M(JG)%MATRIX(:,JM)) + ENDDO ! JM + ENDDO ! JG + ENDDO ! IM + DEALLOCATE(SIGG) +*---- +* SOLVE FOR THE MULTIBAND FLUX. +*---- + IDIR=0 + LEXAC=.FALSE. + IPMACR=C_NULL_PTR + IPSOU=C_NULL_PTR + REBFLG=.FALSE. + CALL DOORFV(CDOOR,IPSYS,NPSYS,IPTRK,IFTRAK,IMPX,MI,NBMIX,IDIR, + 1 NREG,NUN,IPHASE,LEXAC,MAT,VOL,KEYFLX,TITR,SUN,FUN,IPMACR,IPSOU, + 2 REBFLG) +*---- +* CONVERGENCE CONTROL. +*---- + DO IM=1,MI + KPSYS=LCMGIL(IPSYS,IASM+IM) + CALL LCMPUT(KPSYS,'FUNKNO$USS',NUN,2,FUN(1,IM)) + DO I=1,NREG + IUN=KEYFLX(I) + DELTA=FUN(IUN,IM)-PSI_M(IG)%MATRIX(IUN,IM) + ERR1=MAX(ERR1,ABS(DELTA)) + ERR2=MAX(ERR2,ABS(FUN(IUN,IM))) + ENDDO + PSI_M(IG)%MATRIX(:NUN,IM)=FUN(:NUN,IM) + ENDDO + DEALLOCATE(SUN,FUN) + IF(IMPX.GT.2) THEN + WRITE(TEXT12,'(3A4)') (IPPT2(IRES,I),I=2,4) + WRITE(6,'(15H USSIT3: GROUP=,I5,15H. RSE ITERATION,I4, + 1 11H. ISOTOPE='',A12,9H''. ERROR=,1P,E11.4,1H.)') IG, + 2 ITER,TEXT12,ERR1 + ENDIF + IF(ERR1.GT.1.0E5) GO TO 30 + IF(ERR1.GT.1.0E-4*ERR2) GO TO 20 + IF(IMPX.GT.1) THEN + WRITE(TEXT12,'(3A4)') (IPPT2(IRES,I),I=2,4) + WRITE(6,'(15H USSIT3: GROUP=,I5,24H. RSE ITERATION CONVERGE, + 1 6HNCE IN,I4,22H ITERATIONS. ISOTOPE='',A12,2H''.)') IG, + 2 ITER,TEXT12 + ENDIF +*---- +* COMPUTE XFLUX2 FOR IRES IN GROUP IG. +*---- + XFLUX2(:NBNRS,:MI,IG)=0.0 + DO I=1,NREG + IF(MAT(I).EQ.0) CYCLE + IND=IREX(MAT(I)) + IF(IND.EQ.0) CYCLE + IUN=KEYFLX(I) + DO IM=1,MI + XFLUX2(IND,IM,IG)=XFLUX2(IND,IM,IG)+VOL(I)* + 1 PSI_M(IG)%MATRIX(IUN,IM) + ENDDO + ENDDO + DO IM=1,MI + DO IND=1,NBNRS + XFLUX2(IND,IM,IG)=XFLUX2(IND,IM,IG)/VOLMER(IND) + ENDDO + ENDDO +*---- +* USE SNAPSHOT WEIGHTS TO AVERAGE SUBGROUP FLUX UNKNOWNS. +*---- + UNGAR(:NUN,IRES,IG)=0.0 + DO IUN=1,NUN + DO IM=1,MI + UNGAR(IUN,IRES,IG)=UNGAR(IUN,IRES,IG)+ + 1 REAL(WEIGHT_V(IG)%VECTOR(IM)*PSI_M(IG)%MATRIX(IUN,IM),4) + ENDDO + ENDDO + GO TO 40 +*---- +* ALTERNATIVE TREATMENT IN CASE OF FAILURE OF FIXED POINT ITERATIONS. +* USE A NON-ITERATIVE RESPONSE MATRIX APPROACH. +*---- + 30 IF(IMPX.GT.0) THEN + WRITE(TEXT12,'(3A4)') (IPPT2(IRES,I),I=2,4) + WRITE(6,'(15H USSIT3: GROUP=,I5,24H. SUBGROUP ITERATION FAI, + 1 16HLED FOR ISOTOPE ,A12,32H. USE AN ALTERNATIVE RESPONSE MA, + 2 14HTRIX APPROACH.)') IG,TEXT12 + ENDIF + CALL USSEXD(MAXNOR,CDOOR,IPLI0,IPTRK,IFTRAK,IMPX,NGRP,IG,IASM, + 1 NBMIX,NREG,NUN,IPHASE,MAT,VOL,KEYFLX,IREX,SIGGAR,TITR,NIRES, + 2 IRES,NBNRS,MRANK,CONR,GOLD,IPPT1,IPPT2,VOLMER,XFLUX2,UNGAR) +*---- +* SAVE XFLUX2 FOR IRES IN GROUP IG. +*---- + 40 CALL LCMPDL(JPLI0,IG,NBNRS*MI,2,XFLUX2(1,1,IG)) + IF(IMPX.GT.2) THEN + DO IND=1,NBNRS + T1=0.0D0 + DO IM=1,MI + T1=T1+WEIGHT_V(IG)%VECTOR(IM)*XFLUX2(IND,IM,IG) + ENDDO + WRITE(6,'(31H USSIT3: AVERAGED FLUX IN GROUP,I4,9H AND RESO, + 1 11HNANT REGION,I4,21H FOR RESONANT ISOTOPE,I4,2H =,F9.5)') + 2 IG,IND,IRES,T1 + ENDDO + ENDIF + IASM=IASM+MI + ENDDO +*---- +* SCRATCH STORAGE DEALLOCATION. +*---- + DEALLOCATE(XFLUX2) + DO IG=1,NGRP + IF(.NOT.MASKG(IG).OR.(GOLD(IRES,IG).NE.-1001.)) CYCLE + DEALLOCATE(PSI_M(IG)%MATRIX) + ENDDO + 50 DEALLOCATE(PSI_M,GAMMA_V,WEIGHT_V,SCAT_M,SIGT_M,SIGT_V) + DEALLOCATE(MRANK,NPSYS,NJJ) + DEALLOCATE(JPLIB3,JPLIB2) + RETURN + END diff --git a/Dragon/src/USSIT4.f b/Dragon/src/USSIT4.f new file mode 100644 index 0000000..2311928 --- /dev/null +++ b/Dragon/src/USSIT4.f @@ -0,0 +1,187 @@ +*DECK USSIT4 + SUBROUTINE USSIT4(MAXNOR,IPLI0,IPPT1,IPPT2,NGRP,NIRES,NBNRS,NL, + 1 NED,NDEL,PHGAR,STGAR,SFGAR,SSGAR,S0GAR,SAGAR,SDGAR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute self-shielded microscopic cross sections for the RSE method. +* +*Copyright: +* Copyright (C) 2023 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXNOR maximum number of base points. +* IPLI0 pointer to the internal microscopic cross section library +* builded by the self-shielding module. +* IPPT1 pointer to LCM directory of each resonant isotope. +* IPPT2 information related to each resonant isotope: +* IPPT2(:,1) index of a resonant region (used with infinite +* dilution case); +* IPPT2(:,2:4) alias name of resonant isotope; +* IPPT2(:,5) number of delayed neutron groups. +* NGRP number of energy groups. +* NIRES exact number of resonant isotopes. +* NBNRS number of correlated fuel regions. +* NL number of Legendre orders required in the calculation +* (NL=1 or higher). +* NED number of extra vector edits. +* NDEL number of delayed neutron precursor groups. +* +*Parameters: output +* PHGAR averaged flux. +* STGAR averaged microscopic total xs in resonant region. +* SFGAR averaged nu*microscopic fission xs in resonant region. +* SSGAR averaged microscopic scattering xs in resonant region. +* S0GAR averaged microscopic transfer scattering xs in resonant +* region for primary neutrons in current group. +* SAGAR averaged microscopic self-shielded additional xs. +* SDGAR microscopic self-shielded delayed nu-sigf xs. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLI0,IPPT1(NIRES) + INTEGER MAXNOR,IPPT2(NIRES,5),NGRP,NIRES,NBNRS,NL,NED,NDEL + REAL PHGAR(NBNRS,NIRES,NGRP),STGAR(NBNRS,NIRES,NGRP), + 1 SFGAR(NBNRS,NIRES,NGRP),SSGAR(NBNRS,NIRES,NL,NGRP), + 2 S0GAR(NBNRS,NIRES,NL,NGRP,NGRP),SAGAR(NBNRS,NIRES,NED,NGRP), + 3 SDGAR(NBNRS,NIRES,NDEL,NGRP) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(MAX_R=12) + TYPE(C_PTR) IPLIB,JPLIB1,JPLIB2,KPLIB,JPLI0 + CHARACTER HSMG*131,TEXT12*12,CBDPNM*12 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MRANK + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISM + REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGP_R + REAL, ALLOCATABLE, DIMENSION(:,:) :: XFLUX + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: CGAR + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: SIGP +*---- +* SCRATCH STORAGE ALLOCATION. +*---- + ALLOCATE(XFLUX(NBNRS,MAXNOR),ISM(2,NL),MRANK(NGRP)) +*---- +* RECOVER INFORMATION FROM THE INTERNAL MICROSCOPIC LIBRARY. +*---- + DO IRES=1,NIRES + IPLIB=IPPT1(IRES) + CALL LCMLEN(IPLIB,'NOR',ILONG,ITYLCM) + IF(ILONG.NE.NGRP) THEN + CALL LCMLIB(IPLIB) + CALL XABORT('USSIT4: RANK ARRAY MISSING.') + ENDIF + JPLIB1=LCMGID(IPLIB,'GROUP-RSE') + JPLIB2=LCMGID(IPLIB,'GROUP-PT') +*---- +* WEIGHT DILUTION-DEPENDENT DATA. +*---- + CALL LCMGET(IPLIB,'NOR',MRANK) + WRITE(CBDPNM,'(3HCOR,I4.4,1H/,I4.4)') IRES,NIRES + CALL LCMSIX(IPLI0,CBDPNM,1) + CALL LCMLEN(IPLI0,'NWT0-PT',ILONG,ITYLCM) + JPLI0=LCMGID(IPLI0,'NWT0-PT') + DO IGRP=1,NGRP + MI=MRANK(IGRP) + IF(MI.LE.1) CYCLE + CALL LCMLEL(JPLI0,IGRP,ILONG,ITYLCM) + IF(ILONG.EQ.0) CYCLE + CALL LCMGDL(JPLI0,IGRP,XFLUX) + CALL LCMLEL(JPLIB1,IGRP,ILONG1,ITYLCM) + CALL LCMLEL(JPLIB2,IGRP,ILONG2,ITYLCM) + IF((ILONG1.EQ.-1).AND.(ILONG2.EQ.0)) THEN + ! recover a RSE table + KPLIB=LCMGIL(JPLIB1,IGRP) + CALL LCMLEN(KPLIB,'RSE-TABLE',ILONG,ITYLCM) + IF(ILONG.EQ.0) CALL XABORT('USSIT4: MISSING SIGP INFO(1).') + NPART=ILONG/MI + CALL LCMGET(KPLIB,'ISM-LIMITS',ISM) + ALLOCATE(SIGP(NPART,MI),CGAR(NPART)) + CALL LCMGET(KPLIB,'RSE-TABLE',SIGP) + ELSE IF((ILONG1.EQ.0).AND.(ILONG2.EQ.-1)) THEN + ! recover a physical probability table + IF(MI.GT.MAX_R) CALL XABORT('USSIT4: MAX_R OVERFLOW.') + KPLIB=LCMGIL(JPLIB2,IGRP) + CALL LCMLEN(KPLIB,'PROB-TABLE',ILONG,ITYLCM) + IF(ILONG.EQ.0) CALL XABORT('USSIT4: MISSING SIGP INFO(2).') + NPART=ILONG/MAX_R + CALL LCMGET(KPLIB,'ISM-LIMITS',ISM) + ALLOCATE(SIGP(NPART,MI),CGAR(NPART)) + SIGP(:NPART,:MI)=0.0D0 + ALLOCATE(SIGP_R(MAX_R,NPART)) + CALL LCMGET(KPLIB,'PROB-TABLE',SIGP_R) + DO IPP=1,NPART + SIGP(IPP,:MI)=SIGP_R(:MI,IPP) + ENDDO + DO I=1,NBNRS + XFLUX(I,:MI)=XFLUX(I,:MI)*SIGP_R(:MI,1) + ENDDO + SIGP(1,:MI)=1.0D0 + DEALLOCATE(SIGP_R) + ELSE + CALL XABORT('USSIT4: TWO TYPES OF PROBABILITY TABLES.') + ENDIF + ! perform weighting of PT or RSE table + NDEL0=IPPT2(IRES,5) + DO I=1,NBNRS + CGAR(1)=0.0D0 + DO IM=1,MI + CGAR(1)=CGAR(1)+XFLUX(I,IM)*SIGP(1,IM) + ENDDO + CGAR(2:NPART)=MATMUL(SIGP(2:NPART,:MI),XFLUX(I,:MI)) + PHGAR(I,IRES,IGRP)=REAL(CGAR(1),4) + STGAR(I,IRES,IGRP)=REAL(CGAR(2)/CGAR(1),4) + SFGAR(I,IRES,IGRP)=REAL(CGAR(3)/CGAR(1),4) + IPP=3 + DO IL=1,NL + IPP=IPP+1 + SSGAR(I,IRES,IL,IGRP)=REAL(CGAR(IPP)/CGAR(1),4) + ENDDO + DO IL=1,NL + S0GAR(I,IRES,IL,:NGRP,IGRP)=0.0 + DO JGRP=ISM(1,IL),ISM(2,IL) + IPP=IPP+1 + S0GAR(I,IRES,IL,JGRP,IGRP)=REAL(CGAR(IPP)/CGAR(1),4) + ENDDO + ENDDO + DO IED=1,NED + IPP=IPP+1 + SAGAR(I,IRES,IED,IGRP)=REAL(CGAR(IPP)/CGAR(1),4) + ENDDO + DO IDEL=1,NDEL0 + IPP=IPP+1 + SDGAR(I,IRES,IDEL,IGRP)=REAL(CGAR(IPP)/CGAR(1),4) + ENDDO + IF(NDEL0.NE.0) IPP=IPP+NDEL-NDEL0 + IF(IPP.NE.NPART) THEN + WRITE(TEXT12,'(3A4)') (IPPT2(IRES,J0),J0=2,4) + WRITE(HSMG,'(26HUSSIT4: FAILURE. ISOTOPE='',A12, + 1 7H'' (IPP=,I6,7H NPART=,I6,6H IGRP=,I6,2H).)') TEXT12, + 2 IPP,NPART,IGRP + CALL XABORT(HSMG) + ENDIF + ENDDO + DEALLOCATE(CGAR,SIGP) + ENDDO + CALL LCMSIX(IPLI0,' ',2) + ENDDO +*---- +* SCRATCH STORAGE DEALLOCATION. +*---- + DEALLOCATE(MRANK,ISM,XFLUX) + RETURN + END diff --git a/Dragon/src/USSONE.f b/Dragon/src/USSONE.f new file mode 100644 index 0000000..89dbd9e --- /dev/null +++ b/Dragon/src/USSONE.f @@ -0,0 +1,190 @@ +*DECK USSONE + SUBROUTINE USSONE(IPLI0,IPTRK,IPLIB,IFTRAK,CDOOR,IMPX,IGRMIN, + 1 IGRMAX,NIRES,NBNRS,IREX,NGRP,NBMIX,NREG,NUN,NBISO,NL,NED,NDEL, + 2 ISONAM,IHSUF,HCAL,DEN,MIX,IAPT,MAT,VOL,KEYFLX,LEAKSW,ITRANC, + 3 IPHASE,TITR,KSPH,ICORR,ISUBG,MAXST) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform a resonance self-shielding calculation named HCAL and build +* a corresponding internal library. +* +*Copyright: +* Copyright (C) 2003 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLI0 pointer to the internal microscopic cross section library +* builded by the self-shielding module (L_LIBRARY signature). +* IPTRK pointer to the tracking. (L_TRACK signature). +* IPLIB pointer to the internal microscopic cross section library +* with subgroups (L_LIBRARY signature). +* IFTRAK unit number of the sequential binary tracking file. +* CDOOR name of the geometry/solution operator. +* IMPX print flag (equal to zero for no print). +* IGRMIN first group where the self-shielding is applied. +* IGRMAX most thermal group where the self-shielding is applied. +* NIRES number of correlated resonant isotopes in fuel regions. +* NBNRS number of correlated fuel regions. Note that NBNRS=max(IREX). +* IREX fuel region index assigned to each mixture. Equal to zero +* in non-resonant mixtures or in mixtures not used. +* NGRP number of energy groups. +* NBMIX number of mixtures in the internal library. +* NREG number of regions. +* NUN number of unknowns per energy group. +* NBISO number of isotopes specifications in the internal library. +* NL number of Legendre orders required in the calculation +* (NL=1 or higher). +* NED number of extra vector edits. +* NDEL number of delayed neutron precursor groups. +* ISONAM alias name of isotopes. +* IHSUF suffix name of isotopes. +* HCAL name of the self-shielding calculation. +* DEN density of each isotope. +* MIX mix number of each isotope (can be zero). +* IAPT resonant isotope index associated with isotope I. Mixed +* moderator if IAPT(I)=NIRES+1. Out-of-fuel isotope if +* IAPT(I)=0. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX pointers of fluxes in unknown vector. +* LEAKSW leakage flag (LEAKSW=.TRUE. if neutron leakage through +* external boundary is present). +* ITRANC type of transport correction. +* IPHASE type of flux solution (=1 use a native flux solution door; +* =2 use collision probabilities). +* TITR title. +* KSPH SPH equivalence flag (=0 no SPH correction; =1 SPH correction +* in the fuel). +* ICORR mutual resonance shielding flag (=1 to suppress the model +* in cases it is required in LIB operator). +* ISUBG type of self-shielding model (=1 use physical probability +* tables; =3 use original Ribon method; =4 use Ribon extended +* method; =6 use resonance spectrum expansion method). +* MAXST maximum number of fixed point iterations for the ST scattering +* source. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLI0,IPTRK,IPLIB + INTEGER IFTRAK,IMPX,IGRMIN,IGRMAX,NIRES,NBNRS,IREX(NBMIX), + 1 NGRP,NBMIX,NREG,NUN,NBISO,NL,NED,NDEL,ISONAM(3,NBISO), + 2 IHSUF(NBISO),MIX(NBISO),IAPT(NBISO),MAT(NREG),KEYFLX(NREG), + 3 ITRANC,IPHASE,KSPH,ICORR,ISUBG,MAXST + REAL DEN(NBISO),VOL(NREG) + LOGICAL LEAKSW + CHARACTER CDOOR*12,HCAL*12,TITR*72 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISOBIS + REAL, ALLOCATABLE, DIMENSION(:) :: SIGAR,UNGAR,DELTAU + REAL, ALLOCATABLE, DIMENSION(:,:) :: GOLD + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SPH,PHGAR,STGAR,SFGAR,SWGAR + REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: SSGAR,SAGAR,SDGAR + REAL, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: S0GAR + LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASKI + LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: MASKG +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(ISOBIS(3,NBISO)) + ALLOCATE(SPH(NBNRS,NIRES,NGRP),PHGAR(NBNRS,NIRES,NGRP), + 1 STGAR(NBNRS,NIRES,NGRP),SFGAR(NBNRS,NIRES,NGRP), + 2 SSGAR(NBNRS,NIRES,NL,NGRP),S0GAR(NBNRS,NIRES,NL,NGRP,NGRP), + 3 SAGAR(NBNRS,NIRES,NED,NGRP),SDGAR(NBNRS,NIRES,NDEL,NGRP), + 4 SWGAR(NBNRS,NIRES,NGRP),DELTAU(NGRP)) + ALLOCATE(MASKI(NBISO),MASKG(NGRP,NIRES)) +*---- +* FIND THE NEW ISOTOPE NAMES IN IPLI0. +*---- + CALL LCMLEN(IPLI0,'ISOTOPESUSED',ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + CALL LCMGET(IPLI0,'ISOTOPESUSED',ISOBIS) + ELSE + CALL LCMGET(IPLIB,'ISOTOPESUSED',ISOBIS) + ENDIF + DO 10 ISO=1,NBISO + IF((IAPT(ISO).GT.0).AND.(IAPT(ISO).LE.NIRES)) THEN + ISOBIS(3,ISO)=IHSUF(ISO) + ENDIF + 10 CONTINUE + CALL LCMPUT(IPLI0,'ISOTOPESUSED',3*NBISO,3,ISOBIS) +* + ALLOCATE(SIGAR(4*NBMIX*(NIRES+1)*NGRP),UNGAR(NUN*NIRES*NGRP), + 1 GOLD(NIRES,NGRP)) +*---- +* COMPUTE THE NEUTRON FLUX. +*---- + IF(ISUBG.EQ.6) THEN + ! resonance spectrum expansion method + CALL USSRSE(IPTRK,IPLIB,IPLI0,IFTRAK,NREG,NUN,NBMIX,NBISO, + 1 NIRES,NL,NED,NDEL,ISONAM,ISOBIS,HCAL,MAT,VOL,KEYFLX,CDOOR, + 2 LEAKSW,IMPX,DEN,MIX,IAPT,IPHASE,NGRP,IGRMIN,IGRMAX,NBNRS, + 3 IREX,TITR,ICORR,MAXST,GOLD,UNGAR,PHGAR,STGAR,SFGAR,SSGAR, + 4 S0GAR,SAGAR,SDGAR,MASKG,SIGAR) + ELSE + ! subgroup method + CALL USSFLU(IPTRK,IPLIB,IPLI0,IFTRAK,NREG,NUN,NBMIX,NBISO, + 1 NIRES,NL,NED,NDEL,ISONAM,ISOBIS,HCAL,MAT,VOL,KEYFLX,CDOOR, + 2 LEAKSW,IMPX,DEN,MIX,IAPT,IPHASE,NGRP,IGRMIN,IGRMAX,NBNRS, + 3 IREX,TITR,ICORR,ISUBG,MAXST,GOLD,UNGAR,PHGAR,STGAR,SFGAR, + 4 SSGAR,S0GAR,SAGAR,SDGAR,SWGAR,MASKG,SIGAR) + ENDIF +*---- +* COMPUTE THE SPH FACTORS. +*---- + SPH(:NBNRS,:NIRES,:NGRP)=1.0 + IF(KSPH.EQ.1) THEN + CALL LCMGET(IPLI0,'DELTAU',DELTAU) + CALL USSSPH(IPLI0,IPTRK,IFTRAK,NREG,NUN,NBMIX,NBISO,NIRES,NL, + 1 NED,NDEL,ISONAM,HCAL,MAT,VOL,KEYFLX,CDOOR,LEAKSW,IMPX,DEN,MIX, + 2 IAPT,ITRANC,IPHASE,NGRP,MASKG,NBNRS,IREX,TITR,ISUBG,SIGAR, + 3 GOLD,UNGAR,PHGAR,STGAR,SFGAR,SSGAR,S0GAR,SAGAR,SDGAR,SWGAR, + 4 DELTAU,SPH) + ENDIF +* + DEALLOCATE(GOLD,UNGAR,SIGAR) +*---- +* CREATE THE SELF-SHIELDED INTERNAL LIBRARY USING A SIMPLE +* TRANSCRIPTION OF THE SELF-SHIELDED CROSS SECTIONS. +*---- + CALL KDRCPU(TK1) +* SIMPLE TRANSCRIPTION OF THE SELF-SHIELDED CROSS SECTIONS. + DO 100 ISO=1,NBISO + MASKI(ISO)=(IAPT(ISO).GT.0).AND.(IAPT(ISO).LE.NIRES) + 100 CONTINUE + DO 120 ISO=1,NBISO + IF(MASKI(ISO)) THEN + DO 110 JSO=ISO+1,NBISO + IF((ISOBIS(1,ISO).EQ.ISOBIS(1,JSO)).AND. + 1 (ISOBIS(2,ISO).EQ.ISOBIS(2,JSO)).AND. + 2 (ISOBIS(3,ISO).EQ.ISOBIS(3,JSO))) MASKI(JSO)=.FALSE. + 110 CONTINUE + ENDIF + 120 CONTINUE + CALL USSIN1(IPLI0,IPLIB,NGRP,NBMIX,NBISO,NIRES,NBNRS,NL,NED,NDEL, + 1 IREX,IMPX,ISONAM,ISOBIS,MIX,IAPT,MASKI,SPH,PHGAR,STGAR,SFGAR, + 2 SSGAR,S0GAR,SAGAR,SDGAR) + CALL KDRCPU(TK2) + IF(IMPX.GT.1) WRITE(6,'(/36H USSONE: CPU TIME SPENT TO BUILD THE, + 1 33H SELF-SHIELDED INTERNAL LIBRARY =,F8.1,8H SECOND.)') TK2-TK1 +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(MASKG,MASKI) + DEALLOCATE(DELTAU,SWGAR,SDGAR,SAGAR,S0GAR,SSGAR,SFGAR,STGAR, + 1 PHGAR,SPH) + DEALLOCATE(ISOBIS) + RETURN + END diff --git a/Dragon/src/USSRSE.f b/Dragon/src/USSRSE.f new file mode 100644 index 0000000..aa0f60e --- /dev/null +++ b/Dragon/src/USSRSE.f @@ -0,0 +1,458 @@ +*DECK USSRSE + SUBROUTINE USSRSE(IPTRK,IPLIB,IPLI0,IFTRAK,NREG,NUN,NBMIX,NBISO, + 1 NIRES,NL,NED,NDEL,ISONAM,ISOBIS,HCAL,MAT,VOL,KEYFLX,CDOOR, + 2 LEAKSW,IMPX,DEN,MIX,IAPT,IPHASE,NGRP,IGRMIN,IGRMAX,NBNRS,IREX, + 3 TITR,ICORR,MAXST,GOLD,UNGAR,PHGAR,STGAR,SFGAR,SSGAR,S0GAR,SAGAR, + 4 SDGAR,MASKG,SIGGAR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the self-shielded cross sections in each energy group using +* the resonance spectrum expansion method. +* +*Copyright: +* Copyright (C) 2023 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK pointer to the tracking (L_TRACK signature). +* IPLIB pointer to the internal microscopic cross section library +* with subgroups (L_LIBRARY signature). +* IPLI0 pointer to the internal microscopic cross section library +* builded by the self-shielding module. +* IFTRAK file unit number used to store the tracks. +* NREG number of regions. +* NUN number of unknowns per energy group and band. +* NBMIX number of mixtures in the internal library. +* NBISO number of isotopes. +* NIRES number of correlated resonant isotopes. +* NL number of legendre orders required in the calculation +* (NL=1 or higher). +* NED number of extra vector edits. +* NDEL number of delayed neutron precursor groups. +* ISONAM alias name of isotopes in IPLIB. +* ISOBIS alias name of isotopes in IPLI0. +* HCAL name of the self-shielding calculation. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX pointers of fluxes in unknown vector. +* CDOOR name of the geometry/solution operator. +* LEAKSW leakage flag (LEAKSW=.true. if neutron leakage through +* external boundary is present). +* IMPX print flag (equal to zero for no print). +* DEN density of each isotope. +* MIX mix number of each isotope (can be zero). +* IAPT resonant isotope index associated with isotope I. Mixed +* moderator if IAPT(I)=NIRES+1. Out-of-fuel isotope if +* IAPT(I)=0. +* IPHASE type of flux solution (=1 use a native flux solution door; +* =2 use collision probabilities). +* NGRP number of energy groups. +* IGRMIN first group where the self-shielding is applied. +* IGRMAX most thermal group where the self-shielding is applied. +* NBNRS number of correlated fuel regions. Note that NBNRS=max(IREX). +* IREX fuel region index assigned to each mixture. Equal to zero +* in non-resonant mixtures or in mixtures not used. +* TITR title. +* ICORR mutual resonance shielding flag (=1 to suppress the model +* in cases it is required in LIB operator). +* MAXST maximum number of fixed point iterations for the ST scattering +* source. +* +*Parameters: output +* GOLD Goldstein-Cohen parameters. +* UNGAR averaged flux unknowns. +* PHGAR averaged fluxes in correlated fuel regions. +* STGAR microscopic self-shielded total x-s. +* SFGAR microscopic self-shielded fission x-s. +* SSGAR microscopic self-shielded scattering x-s. +* S0GAR microscopic transfer scattering xs (isotope,secondary, +* primary). +* SAGAR microscopic self-shielded additional xs. +* SDGAR microscopic self-shielded delayed nu-sigf xs. +* MASKG energy group mask pointing on self-shielded groups. +* SIGGAR macroscopic x-s of the non-resonant isotopes in each mixture: +* (*,*,*,1) total; (*,*,*,2) transport correction; +* (*,*,*,3) P0 scattering; (*,*,*,4) flux times P0 scattering. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPLIB,IPLI0 + INTEGER IFTRAK,NREG,NUN,NBMIX,NBISO,NIRES,NL,NED,NDEL, + 1 ISONAM(3,NBISO),ISOBIS(3,NBISO),MAT(NREG),KEYFLX(NREG),IMPX, + 2 MIX(NBISO),IAPT(NBISO),IPHASE,NGRP,IGRMIN,IGRMAX,NBNRS, + 3 IREX(NBMIX),ICORR,MAXST + REAL VOL(NREG),DEN(NBISO),GOLD(NIRES,NGRP),UNGAR(NUN,NIRES,NGRP), + 1 PHGAR(NBNRS,NIRES,NGRP),STGAR(NBNRS,NIRES,NGRP), + 2 SFGAR(NBNRS,NIRES,NGRP),SSGAR(NBNRS,NIRES,NL,NGRP), + 3 S0GAR(NBNRS,NIRES,NL,NGRP,NGRP),SAGAR(NBNRS,NIRES,NED,NGRP), + 4 SDGAR(NBNRS,NIRES,NDEL,NGRP),SIGGAR(NBMIX,0:NIRES,NGRP,4) + LOGICAL LEAKSW,MASKG(NGRP,NIRES) + CHARACTER HCAL*12,CDOOR*12,TITR*72 +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPP,KPLIB,LPLIB,MPLIB,JPLI0,KPLI0,IOFSET + LOGICAL LLIB + PARAMETER (MAXED=50,MAXNOR=20) + CHARACTER TEXT12*12,HVECT(MAXED)*8,CBDPNM*12,HSMG*131 +*---- +* ALLOCATABLE ARRAYS +*---- + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPPT1,IPISO1,IPISO2 + INTEGER, ALLOCATABLE, DIMENSION(:) :: IWRK + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NOR,IPPT2,ISM + REAL, ALLOCATABLE, DIMENSION(:) :: GAS,GA1,VOLMER,DELTAU,GOLD2 + REAL, ALLOCATABLE, DIMENSION(:,:) :: GA2,CONR,XFLUX + TYPE VECTOR_ARRAY + DOUBLE PRECISION, POINTER, DIMENSION(:) :: VECTOR + END TYPE VECTOR_ARRAY + TYPE(VECTOR_ARRAY), ALLOCATABLE, DIMENSION(:,:) :: GAMMA_V +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IPPT1(NIRES)) + ALLOCATE(NOR(NIRES,NGRP),IPPT2(NIRES,5),IWRK(NGRP),ISM(2,NL)) + ALLOCATE(GAS(NGRP),GA1(NGRP),GA2(NGRP,NGRP),CONR(NBNRS,NIRES), + 1 VOLMER(0:NBNRS),DELTAU(NGRP),GAMMA_V(NGRP,NIRES)) + ALLOCATE(IPISO1(NBISO),IPISO2(NBISO)) +* + CALL KDRCPU(TK1) + PHGAR(:NBNRS,:NIRES,:NGRP)=1.0 + NOR(:NIRES,1)=-1 +* + IF(NED.GT.0) THEN + IF(NED.GT.MAXED) CALL XABORT('USSRSE: INVALID VALUE OF MAXED.') + CALL LCMGTC(IPLIB,'ADDXSNAME-P0',8,NED,HVECT) + ENDIF +* + CALL LIBIPS(IPLIB,NBISO,IPISO1) + CALL LIBIPS(IPLI0,NBISO,IPISO2) + SIGGAR(:NBMIX,0:NIRES,:NGRP,:4)=0.0 + DO 190 ISO=1,NBISO + IBM=MIX(ISO) + DO 30 I=1,NREG + IF(MAT(I).EQ.IBM) GO TO 35 + 30 CONTINUE + GO TO 190 + 35 IRES=IAPT(ISO) + DENN=DEN(ISO) + JRES=IRES + IF(IRES.EQ.NIRES+1) JRES=0 +*---- +* RECOVER INFINITE DILUTION OR SELF-SHIELDED CROSS SECTIONS AND +* COMPUTE OUT-OF-FUEL MACROSCOPIC CROSS SECTIONS. +*---- + KPLI0=IPISO2(ISO) ! set ISO-th isotope + IF(C_ASSOCIATED(KPLI0)) THEN + CALL LCMLEN(KPLI0,'NTOT0',ILEN0,ITYLCM) + IF(ILEN0.NE.0) THEN + LLIB=.FALSE. + IPP=KPLI0 + ELSE + LLIB=.TRUE. + IPP=IPISO1(ISO) ! set ISO-th isotope + ENDIF + ELSE + LLIB=.TRUE. + IPP=IPISO1(ISO) ! set ISO-th isotope + ENDIF + IF(LLIB.AND.(.NOT.C_ASSOCIATED(IPP))) THEN + WRITE(HSMG,'(18H USSRSE: ISOTOPE '',3A4,7H'' (ISO=,I8,5H) IS , + 1 39HNOT AVAILABLE IN THE ORIGINAL MICROLIB.)') (ISONAM(I0,ISO), + 2 I0=1,3),ISO + CALL XABORT(HSMG) + ENDIF + IF((.NOT.LLIB).AND.(IMPX.GT.2)) WRITE(6,'(/18H USSRSE: RECOVER I, + 1 8HSOTOPE '',3A4,23H'' FROM THE NEW LIBRARY.)') (ISOBIS(I0,ISO), + 2 I0=1,3) + IF((DENN.NE.0.0).AND.(IBM.NE.0)) THEN + CALL LCMLEN(IPP,'NTOT0',ILENGT,ITYLCM) + IF(ILENGT.NE.NGRP) THEN + CALL LCMLIB(IPP) + CALL XABORT('USSRSE: INVALID X-SECTIONS.') + ENDIF + CALL LCMGET(IPP,'NTOT0',GA1) + CALL XDRLGS(IPP,-1,IMPX,0,0,1,NGRP,GAS,GA2,ITYPRO) + DO 40 IGRP=1,NGRP + SIGGAR(IBM,JRES,IGRP,1)=SIGGAR(IBM,JRES,IGRP,1)+DENN*GA1(IGRP) + 40 CONTINUE + CALL LCMGET(IPP,'SIGS00',GA1) + CALL LCMLEN(IPP,'NWT0',ILENGT,ITYLCM) + IF(ILENGT.GT.0) THEN + CALL LCMGET(IPP,'NWT0',GAS) + ELSE + GAS(:NGRP)=1.0 + ENDIF + DO 45 IGRP=1,NGRP + SIGGAR(IBM,JRES,IGRP,3)=SIGGAR(IBM,JRES,IGRP,3)+DENN*GA1(IGRP) + DO 44 JGRP=1,IGRP + SIGGAR(IBM,JRES,IGRP,4)=SIGGAR(IBM,JRES,IGRP,4)+DENN* + 1 GA2(IGRP,JGRP)*GAS(JGRP) + 44 CONTINUE + 45 CONTINUE + CALL LCMLEN(IPP,'TRANC',ILENGT,ITYLCM) + IF(ILENGT.GT.0) THEN + CALL LCMGET(IPP,'TRANC',GA1) + ELSE + GA1(:NGRP)=0.0 + ENDIF + DO 50 IGRP=1,NGRP + SIGGAR(IBM,JRES,IGRP,2)=SIGGAR(IBM,JRES,IGRP,2)+DENN*GA1(IGRP) + 50 CONTINUE + ENDIF + CALL LCMGET(IPLI0,'DELTAU',DELTAU) +*---- +* RECOVER PROBABILITY TABLE INFORMATION. +*---- + IF((IRES.GT.0).AND.(IRES.LE.NIRES)) THEN + IF(NOR(IRES,1).EQ.-1) THEN + KPLIB=IPISO1(ISO) ! set ISO-th isotope +* +* RECOVER INFINITE DILUTION VALUES. + CALL LCMGET(KPLIB,'NTOT0',GAS) + DO 55 IGRP=1,NGRP + STGAR(:NBNRS,IRES,IGRP)=0.0 + STGAR(:NBNRS,IRES,IGRP)=GAS(IGRP) + SFGAR(:NBNRS,IRES,IGRP)=0.0 + SAGAR(:NBNRS,IRES,:NED,IGRP)=0.0 + SDGAR(:NBNRS,IRES,:NDEL,IGRP)=0.0 + 55 CONTINUE + CALL LCMLEN(KPLIB,'NUSIGF',ILENGT,ITYLCM) + IF(ILENGT.GT.0) THEN + CALL LCMGET(KPLIB,'NUSIGF',GAS) + DO 60 IGRP=1,NGRP + SFGAR(:NBNRS,IRES,IGRP)=GAS(IGRP) + 60 CONTINUE + ENDIF + DO 80 IL=1,NL + CALL XDRLGS(KPLIB,-1,IMPX,IL-1,IL-1,1,NGRP,GAS,GA2,ITYPRO) +* JG IS THE SECONDARY GROUP. + DO 72 IGRP=1,NGRP + SSGAR(:NBNRS,IRES,IL,IGRP)=GAS(IGRP) + DO 70 JGRP=1,NGRP + S0GAR(:NBNRS,IRES,IL,JGRP,IGRP)=GA2(JGRP,IGRP) + 70 CONTINUE + 72 CONTINUE + 80 CONTINUE + DO 110 IED=1,NED + CALL LCMLEN(KPLIB,HVECT(IED),ILENGT,ITYLCM) + IF(ILENGT.GT.0) THEN + CALL LCMGET(KPLIB,HVECT(IED),GAS) + DO 105 IGRP=1,NGRP + SAGAR(:NBNRS,IRES,IED,IGRP)=GAS(IGRP) + 105 CONTINUE + ENDIF + 110 CONTINUE + DO 130 IDEL=1,NDEL + WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL + CALL LCMLEN(KPLIB,TEXT12,ILENGT,ITYLCM) + IF(ILENGT.GT.0) THEN + CALL LCMGET(KPLIB,TEXT12,GAS) + DO 125 IGRP=1,NGRP + SDGAR(:NBNRS,IRES,IDEL,IGRP)=GAS(IGRP) + 125 CONTINUE + ENDIF + 130 CONTINUE +* + GOLD(IRES,:NGRP)=1.0 + NOR(IRES,:NGRP)=0 + CALL LCMLEN(KPLIB,'NGOLD',ILENGT,ITYLCM) + IF(ILENGT.GT.0) THEN + ALLOCATE(GOLD2(NGRP)) + CALL LCMGET(KPLIB,'NGOLD',GOLD2) + GOLD(IRES,IGRMIN:IGRMAX)=GOLD2(IGRMIN:IGRMAX) + DEALLOCATE(GOLD2) + ENDIF + CALL LCMLEN(KPLIB,'PT-TABLE',ILENGT,ITYLCM) + IF(ILENGT.EQ.-1) THEN + CALL LCMSIX(KPLIB,'PT-TABLE',1) + CALL LCMGET(KPLIB,'NOR',IWRK) + CALL LCMLEN(KPLIB,'GROUP-RSE',ILENGT,ITYLCM) + IF(ILENGT.GT.0) THEN + LPLIB=LCMGID(KPLIB,'GROUP-RSE') + DO IGRP=IGRMIN,IGRMAX + MI=NOR(IRES,IGRP) + CALL LCMLEL(LPLIB,IGRP,ILENGT,ITYLCM) + IF(ILENGT.EQ.0) GOLD(IRES,IGRP)=1.0 + NOR(IRES,IGRP)=IWRK(IGRP) + CALL LCMLEL(LPLIB,IGRP,ILENGT,ITYLCM) + IF(GOLD(IRES,IGRP).EQ.-1001.0) THEN + MPLIB=LCMGIL(LPLIB,IGRP) + CALL LCMGPD(MPLIB,'GAMMA_V',IOFSET) + CALL C_F_POINTER(IOFSET,GAMMA_V(IGRP,IRES)%VECTOR, + 1 (/MI/)) + ENDIF + ENDDO + ENDIF + CALL LCMSIX(KPLIB,' ',2) + ENDIF + ENDIF + ENDIF + 190 CONTINUE + CALL KDRCPU(TK2) + IF(IMPX.GT.1) WRITE(6,'(/34H USSRSE: CPU TIME SPENT TO RECOVER, + 1 23H INFINITE-DILUTION XS =,F8.1,8H SECOND./)') TK2-TK1 +* + CALL KDRCPU(TK1) + TK4=0.0 + TK5=0.0 + ICPIJ=0 +*---- +* COMPUTE THE MERGED VOLUMES AND NUMBER DENSITIES. +*---- + VOLMER(0:NBNRS)=0.0 + DO 210 I=1,NREG + IBM=MAT(I) + IF(IBM.GT.0) VOLMER(IREX(IBM))=VOLMER(IREX(IBM))+VOL(I) + 210 CONTINUE + CONR(:NBNRS,:NIRES)=0.0 + DO 240 ISO=1,NBISO + JRES=IAPT(ISO) + IF((JRES.GT.0).AND.(JRES.LE.NIRES)) THEN + DENN=DEN(ISO) + DO 230 IREG=1,NREG + IBM=MAT(IREG) + IF(MIX(ISO).EQ.IBM) THEN + IND=IREX(IBM) + IF(IND.EQ.0) CALL XABORT('USSRSE: IREX FAILURE.') + CONR(IND,JRES)=CONR(IND,JRES)+DENN*VOL(IREG)/VOLMER(IND) + ENDIF + 230 CONTINUE + ENDIF + 240 CONTINUE +*---- +* RECOVER POSITION OF PROBABILITY TABLES AND NAME OF RESONANT ISOTOPE. +*---- + DO 270 IRES=1,NIRES + ISOT=0 + DO 250 JSOT=1,NBISO + IF(IAPT(JSOT).EQ.IRES) THEN + ISOT=JSOT + GO TO 260 + ENDIF + 250 CONTINUE + CALL XABORT('USSRSE: UNABLE TO FIND A RESONANT ISOTOPE.') + 260 KPLIB=IPISO1(ISOT) ! set ISOT-th isotope + CALL LCMLEN(KPLIB,'PT-TABLE',ILONG,ITYLCM) + IF(ILONG.EQ.0) CALL XABORT('USSRSE: BUG1.') + CALL LCMSIX(KPLIB,'PT-TABLE',1) + CALL LCMGET(KPLIB,'NDEL',NDEL0) + IF(NDEL0.GT.NDEL) CALL XABORT('USSRSE: NDEL OVERFLOW.') + IPPT1(IRES)=KPLIB + CALL LCMSIX(KPLIB,' ',2) + IPPT2(IRES,1)=IREX(MIX(ISOT)) + IPPT2(IRES,2)=ISONAM(1,ISOT) + IPPT2(IRES,3)=ISONAM(2,ISOT) + IPPT2(IRES,4)=ISONAM(3,ISOT) + IPPT2(IRES,5)=NDEL0 + IF(IPPT2(IRES,1).LE.0) CALL XABORT('USSRSE: BUG3.') + 270 CONTINUE +*---- +* DETERMINE WHICH GROUPS ARE SELF-SHIELDED. +*---- + DO 290 IGRP=1,NGRP + DO 280 IRES=1,NIRES + MASKG(IGRP,IRES)=((IGRP.GE.IGRMIN).AND.(IGRP.LE.IGRMAX).AND. + 1 (NOR(IRES,IGRP).GT.0)) + 280 CONTINUE + 290 CONTINUE +*---- +* INITIALIZATION OF THE MULTIBAND FLUXES AND SOURCES. +*---- + CALL LCMSIX(IPLI0,'SHIBA_SG',1) + CALL LCMSIX(IPLI0,HCAL,1) + DO 310 IRES=1,NIRES + WRITE(CBDPNM,'(3HCOR,I4.4,1H/,I4.4)') IRES,NIRES + CALL LCMSIX(IPLI0,CBDPNM,1) + JPLI0=LCMLID(IPLI0,'NWT0-PT',NGRP) + DO 300 IGRP=1,NGRP + IF(MASKG(IGRP,IRES)) THEN + CALL LCMLEL(JPLI0,IGRP,ILENGT,ITYLCM) + IF(ILENGT.EQ.0) THEN + MI=NOR(IRES,IGRP) + ALLOCATE(XFLUX(NBNRS,MI)) + IF(GOLD(IRES,IGRP).EQ.1.0) THEN + XFLUX(:NBNRS,:MI)=1.0 + ELSE IF(GOLD(IRES,IGRP).EQ.-1001.0) THEN + DO IM=1,MI + XFLUX(:NBNRS,IM)=REAL(GAMMA_V(IGRP,IRES)%VECTOR(IM)) + ENDDO + ENDIF + CALL LCMPDL(JPLI0,IGRP,NBNRS*MI,2,XFLUX) + DEALLOCATE(XFLUX) + ENDIF + ENDIF + 300 CONTINUE + CALL LCMSIX(IPLI0,' ',2) + 310 CONTINUE +* + DO 340 IRES=1,NIRES + DO 330 IGRP=1,NGRP + IF(MASKG(IGRP,IRES)) ICPIJ=ICPIJ+NOR(IRES,IGRP) + 330 CONTINUE + CALL KDRCPU(TKA) +*---- +* ITERATIVE APPROACH FOR THE HELIOS/WIMS-7 METHOD. +*---- + MAX_R=12 + CALL USSIT1(MAX_R,NGRP,MASKG(1,IRES),IRES,IPLI0,IPTRK,IFTRAK, + 1 CDOOR,IMPX,NBMIX,NREG,NUN,NL,IPHASE,MAXST,MAT,VOL,KEYFLX,LEAKSW, + 2 IREX,SIGGAR,TITR,NIRES,NBNRS,NOR,CONR,GOLD,IPPT1,IPPT2,STGAR, + 3 SSGAR,VOLMER,UNGAR) +*---- +* ITERATIVE APPROACH FOR THE RESONANCE SPECTRUM EXPANSION METHOD. +*---- + CALL USSIT3(MAXNOR,NGRP,MASKG(1,IRES),IRES,IPLI0,IPTRK,IFTRAK, + 1 CDOOR,IMPX,NBMIX,NREG,NUN,IPHASE,MAXST,MAT,VOL,KEYFLX,LEAKSW, + 2 IREX,SIGGAR,TITR,ICORR,NIRES,NBNRS,CONR,GOLD,IPPT1,IPPT2, + 3 VOLMER,UNGAR) + CALL KDRCPU(TKB) + TK4=TK4+(TKB-TKA) + 340 CONTINUE +*---- +* COMPUTE THE SELF-SHIELDED REACTION RATES. +*---- + CALL USSIT4(MAXNOR,IPLI0,IPPT1,IPPT2,NGRP,NIRES,NBNRS,NL,NED, + 1 NDEL,PHGAR,STGAR,SFGAR,SSGAR,S0GAR,SAGAR,SDGAR) + CALL LCMSIX(IPLI0,' ',2) + CALL LCMSIX(IPLI0,' ',2) + CALL LCMVAL(IPLI0,' ') +*---- +* RESET MASKG FOR SPH CALCULATION IN SMALL LETHARGY WIDTH GROUPS. +*---- + IF(NIRES.GT.1) THEN + DO 360 IGRP=1,NGRP + DO 350 IRES=1,NIRES + IF(MASKG(IGRP,IRES)) THEN + MASKG(IGRP,IRES)=.NOT.(GOLD(IRES,IGRP).EQ.-1001.) + IF(DELTAU(IGRP).GT.0.1) MASKG(IGRP,IRES)=.TRUE. + ENDIF + 350 CONTINUE + 360 CONTINUE + ENDIF + CALL KDRCPU(TK2) + IF(IMPX.GT.1) WRITE(6,'(/34H USSRSE: CPU TIME SPENT TO COMPUTE, + 1 31H SELF-SHIELDED REACTION RATES =,F8.1,19H SECOND, INCLUDING: + 2 /9X,F8.1,46H SECOND TO BUILD/SOLVE SUBGROUP MATRIX SYSTEM;/9X, + 4 F8.1,38H SECOND TO COMPUTE THE REACTION RATES./9X,9HNUMBER OF, + 5 23H ASSEMBLY DOORS CALLS =,I5,1H.)') TK2-TK1,TK4,TK5,ICPIJ +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IPISO2,IPISO1) + DEALLOCATE(GAMMA_V,DELTAU,VOLMER,CONR,GA2,GA1,GAS) + DEALLOCATE(ISM,IWRK,IPPT2,NOR) + DEALLOCATE(IPPT1) + RETURN + END diff --git a/Dragon/src/USSSEK.f b/Dragon/src/USSSEK.f new file mode 100644 index 0000000..849de6b --- /dev/null +++ b/Dragon/src/USSSEK.f @@ -0,0 +1,117 @@ +*DECK USSSEK + SUBROUTINE USSSEK(NBNRS,NQT,LMOD,SIGR,CONRL,WEIGH,SIGL,PIJK,DIL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the dilution matrix preserving the non-correlated collision +* probability matrix in each subgroup. Use a fixed point iteration. +* +*Copyright: +* Copyright (C) 2003 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NBNRS number of correlated fuel regions. +* NQT number of subgroups in admixed resonant isotope. +* LMOD moderator flag (=.TRUE. if all regions are containing the +* resonant isotopes; =.FALSE. if a moderator region exists). +* SIGR macroscopic total xs of the other isotopes. +* CONRL number density of the admixed resonant isotope. +* WEIGH multiband weights for the admixed resonant isotope. +* SIGL microscopic total xs of the admixed resonant isotope. +* PIJK non-correlated collision probability matrix. +* +*Parameters: input/output +* DIL estimate and converged value of the dilution matrix. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + LOGICAL LMOD + INTEGER NBNRS,NQT + REAL SIGR(NBNRS),CONRL(NBNRS),WEIGH(NQT),SIGL(NQT), + 1 PIJK(0:NBNRS,0:NBNRS),DIL(0:NBNRS,0:NBNRS) +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: WORK +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(WORK(0:NBNRS,0:NBNRS,3)) +* + DEN=0.0 + DO 20 I=0,NBNRS + DO 10 J=0,NBNRS + WORK(I,J,3)=PIJK(I,J) + DEN=MAX(DEN,ABS(PIJK(I,J))) + 10 CONTINUE + 20 CONTINUE + IF(LMOD) THEN + CALL ALINV(NBNRS,WORK(1,1,3),NBNRS+1,IER) + ELSE + CALL ALINV(NBNRS+1,WORK(0,0,3),NBNRS+1,IER) + ENDIF + IF(IER.NE.0) CALL XABORT('USSSEK: SINGULAR MATRIX(1).') + ITER=0 + 30 ITER=ITER+1 + IF(ITER.GT.50) CALL XABORT('USSSEK: MAXIMUM NB. OF ITERATIONS.') + DO 45 I=0,NBNRS + DO 40 J=0,NBNRS + WORK(I,J,1)=0.0 + 40 CONTINUE + 45 CONTINUE + DO 72 L=1,NQT + DO 55 I=0,NBNRS + DO 50 J=0,NBNRS + WORK(I,J,2)=DIL(I,J) + 50 CONTINUE + 55 CONTINUE + DO 60 I=1,NBNRS + WORK(I,I,2)=WORK(I,I,2)+SIGR(I)+CONRL(I)*SIGL(L) + 60 CONTINUE + IF(LMOD) THEN + CALL ALINV(NBNRS,WORK(1,1,2),NBNRS+1,IER) + ELSE + CALL ALINV(NBNRS+1,WORK(0,0,2),NBNRS+1,IER) + ENDIF + IF(IER.NE.0) CALL XABORT('USSSEK: SINGULAR MATRIX(2).') + DO 71 I=0,NBNRS + DO 70 J=0,NBNRS + WORK(I,J,1)=WORK(I,J,1)+WEIGH(L)*WORK(I,J,2) + 70 CONTINUE + 71 CONTINUE + 72 CONTINUE + ERR=0.0 + DO 85 I=0,NBNRS + DO 80 J=0,NBNRS + ERR=MAX(ERR,ABS(PIJK(I,J)-WORK(I,J,1))) + 80 CONTINUE + 85 CONTINUE + IF(ERR.LT.1.0E-4*DEN) GO TO 110 + IF(LMOD) THEN + CALL ALINV(NBNRS,WORK(1,1,1),NBNRS+1,IER) + ELSE + CALL ALINV(NBNRS+1,WORK(0,0,1),NBNRS+1,IER) + ENDIF + IF(IER.NE.0) CALL XABORT('USSSEK: SINGULAR MATRIX(3).') + DO 105 I=0,NBNRS + DO 100 J=0,NBNRS + DIL(I,J)=DIL(I,J)+WORK(I,J,3)-WORK(I,J,1) + 100 CONTINUE + 105 CONTINUE + GO TO 30 +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 110 DEALLOCATE(WORK) + RETURN + END diff --git a/Dragon/src/USSSPH.f b/Dragon/src/USSSPH.f new file mode 100644 index 0000000..d220d59 --- /dev/null +++ b/Dragon/src/USSSPH.f @@ -0,0 +1,386 @@ +*DECK USSSPH + SUBROUTINE USSSPH(IPLI0,IPTRK,IFTRAK,NREG,NUN,NBMIX,NBISO,NIRES, + 1 NL,NED,NDEL,ISOBIS,HCAL,MAT,VOL,KEYFLX,CDOOR,LEAKSW,IMPX,DEN,MIX, + 2 IAPT,ITRANC,IPHASE,NGRP,MASKG,NBNRS,IREX,TITR,ISUBG,SIGGAR,GOLD, + 3 UNGAR,PHGAR,STGAR,SFGAR,SSGAR,S0GAR,SAGAR,SDGAR,SWGAR,DELTAU,SPH) +* +*----------------------------------------------------------------------- +* +*Purpose: +* SPH equivalence procedure over the self-shielded cross sections. Use +* all the standard solution doors of Dragon. +* +*Copyright: +* Copyright (C) 2003 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLI0 pointer to the internal microscopic cross section library +* builded by the self-shielding module. +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK file unit number used to store the tracks. +* NREG number of regions. +* NUN number of unknowns per energy group. +* NBMIX number of mixtures in the internal library. +* NBISO number of isotopes. +* NIRES number of correlated resonant isotopes. +* NL number of Legendre orders required in the calculation +* (NL=1 or higher). +* NED number of extra vector edits. +* NDEL number of delayed neutron precursor groups. +* ISOBIS alias name of isotopes in IPLI0. +* HCAL name of the self-shielding calculation. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX pointers of fluxes in unknown vector. +* CDOOR name of the geometry/solution operator. +* LEAKSW leakage flag (LEAKSW=.TRUE. if neutron leakage through +* external boundary is present). +* IMPX print flag (equal to zero for no print). +* DEN density of each isotope. +* MIX mix number of each isotope (can be zero). +* IAPT resonant isotope index associated with isotope I. Mixed +* moderator if IAPT(I)=NIRES+1. Out-of-fuel isotope if +* IAPT(I)=0. +* ITRANC type of transport correction. +* IPHASE type of flux solution (=1 use a native flux solution door; +* =2 use collision probabilities). +* NGRP number of energy groups. +* MASKG energy group mask pointing on self-shielded groups. +* NBNRS number of totally correlated fuel regions (NBNRS=max(IREX)). +* IREX fuel region index assigned to each mixture. Equal to zero +* in non-resonant mixtures or in mixtures not used. +* TITR title. +* ISUBG type of self-shielding model (=1 use physical probability +* tables; =3 use original Ribon method; =4 use Ribon extended +* method; =6 use resonance spectrum expansion method). +* SIGGAR macroscopic x-s of the non-resonant isotopes in each mixture: +* (*,*,*,1) total; (*,*,*,2) transport correction; +* (*,*,*,3) P0 scattering. +* UNGAR averaged flux unknowns. +* STGAR microscopic self-shielded total x-s. +* +*Parameters: input/output +* GOLD Goldstein-Cohen parameters. +* PHGAR uncorrected and SPH-corrected averaged fluxes. +* SFGAR uncorrected and SPH-corrected microscopic self-shielded +* fission x-s. +* SSGAR uncorrected and SPH-corrected microscopic +* self-shielded scattering x-s. +* S0GAR uncorrected and SPH-corrected microscopic +* transfer scattering x-s +* (isotope,secondary,primary). +* SAGAR uncorrected and SPH-corrected microscopic +* additional x-s. +* SDGAR uncorrected and SPH-corrected microscopic +* self-shielded delayed nu-sigf x-s. +* SWGAR uncorrected and SPH-corrected microscopic +* secondary slowing-down cross sections (ISUBG=4). +* DELTAU lethargy width of each energy group. +* +*Parameters: output +* SPH SPH factors. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE DOORS_MOD +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLI0,IPTRK + INTEGER IFTRAK,NREG,NUN,NBMIX,NBISO,NIRES,NL,NED,NDEL, + 1 ISOBIS(3,NBISO),MAT(NREG),KEYFLX(NREG),IMPX,MIX(NBISO), + 2 IAPT(NBISO),ITRANC,IPHASE,NGRP,NBNRS,IREX(NBMIX),ISUBG + REAL VOL(NREG),DEN(NBISO),SIGGAR(NBMIX,0:NIRES,NGRP,3), + 1 GOLD(NIRES,NGRP),UNGAR(NUN,NIRES,NGRP),PHGAR(NBNRS,NIRES,NGRP), + 2 STGAR(NBNRS,NIRES,NGRP),SFGAR(NBNRS,NIRES,NGRP), + 3 SSGAR(NBNRS,NIRES,NL,NGRP),S0GAR(NBNRS,NIRES,NL,NGRP,NGRP), + 4 SAGAR(NBNRS,NIRES,NED,NGRP),SDGAR(NBNRS,NIRES,NDEL,NGRP), + 5 SWGAR(NBNRS,NIRES,NGRP),DELTAU(NGRP),SPH(NBNRS,NIRES,NGRP) + LOGICAL LEAKSW,MASKG(NGRP,NIRES) + CHARACTER CDOOR*12,HCAL*12,TITR*72 +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPLI0,KPLI0,IPMACR,IPSOU + LOGICAL LHOMOG,LPROB,LTIT,LEXAC,REBFLG + CHARACTER TEX8*8,HSMG*131 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NPSYS + REAL, ALLOCATABLE, DIMENSION(:) :: VOLMER,SIGTXS,SIGS0X,SIGG,FLNEW + REAL, ALLOCATABLE, DIMENSION(:,:) :: SUNKNO,FUNKNO,SIGTI +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NPSYS(NGRP)) + ALLOCATE(SIGTI(NBMIX,5),VOLMER(NBNRS),SIGTXS(0:NBMIX), + 1 SIGS0X(0:NBMIX),SIGG(0:NBMIX),FLNEW(NBNRS),SUNKNO(NUN,NGRP), + 2 FUNKNO(NUN,NGRP)) +*---- +* COMPUTE THE MERGED VOLUMES. +*---- + LHOMOG=.TRUE. + VOLMER(:NBNRS)=0.0 + DO 10 I=1,NREG + IBM=MAT(I) + IF(IBM.EQ.0) GO TO 10 + IND=IREX(IBM) + IF(IND.EQ.0) THEN + LHOMOG=.FALSE. + ELSE + VOLMER(IND)=VOLMER(IND)+VOL(I) + ENDIF + 10 CONTINUE + SPH(:NBNRS,:NIRES,:NGRP)=1.0 + IF(LHOMOG.AND.(NBNRS.EQ.1).AND.(NIRES.EQ.1)) GO TO 270 +*---- +* EVALUATION OF THE SPH FACTOR IN THE RESONANT REGION. +*---- + ICPIJ=0 + CALL KDRCPU(TK1) + CALL LCMSIX(IPLI0,'SHIBA_SG',1) + CALL LCMSIX(IPLI0,HCAL,1) + LTIT=.TRUE. + JPLI0=LCMLID(IPLI0,'GROUP',NGRP) +*---- +* LOOP OVER THE RESONANT ISOTOPES. +*---- + DO 150 IRES=1,NIRES + FUNKNO(:NUN,:NGRP)=0.0 + SUNKNO(:NUN,:NGRP)=0.0 + NPSYS(:NGRP)=0 + DO 100 IGRP=1,NGRP + IF(.NOT.MASKG(IGRP,IRES)) GO TO 100 + NPSYS(IGRP)=IGRP +*---- +* SET THE MIXTURE-DEPENDENT MACROSCOPIC XS. +*---- + SIGTI(:NBMIX,:5)=0.0 + DO 60 IBM=1,NBMIX + IND=IREX(IBM) + DO 50 JRES=0,NIRES + IF(JRES.EQ.0) THEN + SIGTI(IBM,1)=SIGTI(IBM,1)+SIGGAR(IBM,0,IGRP,1) + SIGTI(IBM,3)=SIGTI(IBM,3)+SIGGAR(IBM,0,IGRP,3) + IF(ITRANC.NE.0) SIGTI(IBM,2)=SIGTI(IBM,2)+ + 1 SIGGAR(IBM,0,IGRP,2) + ELSE IF((JRES.GT.0).AND.(IND.NE.0)) THEN + DENJ=0.0 + DO 30 JSO=1,NBISO + IF((IAPT(JSO).EQ.JRES).AND.(MIX(JSO).EQ.IBM)) DENJ=DEN(JSO) + 30 CONTINUE + SIGTI(IBM,5)=SIGTI(IBM,5)+DENJ*STGAR(IND,JRES,IGRP) + IF(ISUBG.EQ.4) THEN + SIGTI(IBM,4)=SIGTI(IBM,4)+PHGAR(IND,JRES,IGRP)*DENJ* + 1 SWGAR(IND,JRES,IGRP) + ELSE IF((ISUBG.EQ.6).AND.(GOLD(JRES,IGRP).EQ.-1001.)) THEN + DO 40 JGRP=1,IGRP + SIGTI(IBM,4)=SIGTI(IBM,4)+PHGAR(IND,JRES,JGRP)*DENJ* + 1 S0GAR(IND,JRES,1,IGRP,JGRP)*DELTAU(JGRP)/DELTAU(IGRP) + 40 CONTINUE + ELSE + SIGTI(IBM,4)=SIGTI(IBM,4)+PHGAR(IND,JRES,IGRP)*DENJ* + 1 SSGAR(IND,JRES,1,IGRP) + ENDIF + ENDIF + 50 CONTINUE + 60 CONTINUE +*---- +* COMPUTE THE SOURCES. +*---- + SIGG(0)=0.0 + DO 65 IBM=1,NBMIX + SIGG(IBM)=SIGTI(IBM,3) + IF(IREX(IBM).GT.0) SIGG(IBM)=SIGG(IBM)+SIGTI(IBM,4) + 65 CONTINUE + CALL DOORS(CDOOR,IPTRK,NBMIX,0,NUN,SIGG,SUNKNO(1,IGRP)) + SIGG(0:NBMIX)=0.0 + DO 70 IBM=1,NBMIX + IF(IREX(IBM).GT.0) THEN + SIGG(IBM)=SIGG(IBM)-SIGTI(IBM,5) + IF(.NOT.LHOMOG) SIGG(IBM)=SIGG(IBM)-SIGTI(IBM,1) + ENDIF + 70 CONTINUE + CALL DOORS(CDOOR,IPTRK,NBMIX,0,NUN,SIGG,SUNKNO(1,IGRP), + 1 UNGAR(1,IRES,IGRP)) +* + IF(NPSYS(IGRP).NE.0) THEN + ICPIJ=ICPIJ+1 + SIGTXS(0:)=0.0 + SIGS0X(0:)=0.0 + DO 90 IBM=1,NBMIX + SIGTXS(IBM)=SIGTI(IBM,1)-SIGTI(IBM,2) + IND=IREX(IBM) + IF(IND.EQ.0) THEN +* REMOVE TRANSPORT CORRECTION. + SIGS0X(IBM)=-SIGTI(IBM,2) + ELSE IF(IND.GT.0) THEN +* BELL ACCELERATION. + SIGTXS(IBM)=SIGTXS(IBM)+SIGTI(IBM,5) + SIGS0X(IBM)=SIGTXS(IBM) + IF(LHOMOG) SIGS0X(IBM)=SIGS0X(IBM)-SIGTI(IBM,1) + ENDIF + 90 CONTINUE + KPLI0=LCMDIL(JPLI0,IGRP) + CALL LCMPUT(KPLI0,'DRAGON-TXSC',NBMIX+1,2,SIGTXS) + CALL LCMPUT(KPLI0,'DRAGON-S0XSC',NBMIX+1,2,SIGS0X) + ENDIF + 100 CONTINUE +*---- +* SOLVE FOR THE FLUX USING DIRECT SELF-SHIELDED CROSS SECTIONS +*---- + NANI=1 + KNORM=1 + NALBP=0 + IMPY=MAX(0,IMPX-3) + IF(IPHASE.EQ.1) THEN +* USE A NATIVE DOOR. + ISTRM=1 + NW=0 + CALL DOORAV(CDOOR,JPLI0,NPSYS,IPTRK,IFTRAK,IMPY,NGRP,NREG, + 1 NBMIX,NANI,NW,MAT,VOL,KNORM,LEAKSW,TITR,NALBP,ISTRM) + ELSE IF(IPHASE.EQ.2) THEN +* USE A COLLISION PROBABILITY DOOR. + IPIJK=1 + ITPIJ=1 + CALL DOORPV(CDOOR,JPLI0,NPSYS,IPTRK,IFTRAK,IMPY,NGRP,NREG, + 1 NBMIX,NANI,MAT,VOL,KNORM,IPIJK,LEAKSW,ITPIJ,.FALSE.,TITR, + 2 NALBP) + ENDIF + IDIR=0 + LEXAC=.FALSE. + IPMACR=C_NULL_PTR + IPSOU=C_NULL_PTR + REBFLG=.FALSE. + CALL DOORFV(CDOOR,JPLI0,NPSYS,IPTRK,IFTRAK,IMPX,NGRP,NBMIX,IDIR, + 1 NREG,NUN,IPHASE,LEXAC,MAT,VOL,KEYFLX,TITR,SUNKNO,FUNKNO,IPMACR, + 2 IPSOU,REBFLG) +*---- +* HOMOGENIZE THE FLUX +*---- + DO 140 IGRP=1,NGRP + IF(NPSYS(IGRP).NE.0) THEN + FLNEW(:NBNRS)=0.0 + DO 110 I=1,NREG + IBM=MAT(I) + IF(IBM.EQ.0) GO TO 110 + IND=IREX(IBM) + IF(IND.GT.0) FLNEW(IND)=FLNEW(IND)+FUNKNO(KEYFLX(I),IGRP)*VOL(I) + 110 CONTINUE + DO 120 IND=1,NBNRS + FLNEW(IND)=FLNEW(IND)/VOLMER(IND) + 120 CONTINUE +*---- +* SPH FACTOR CONTROL. +*---- + DO 130 IND=1,NBNRS + SPHNEW=PHGAR(IND,IRES,IGRP)/FLNEW(IND) + LPROB=(SPHNEW.LE.0.0).OR.(SPHNEW.GT.1.0).OR.(FLNEW(IND).LT.0.05) + IF(LPROB) SPHNEW=1.0 + SPH(IND,IRES,IGRP)=SPHNEW + 130 CONTINUE + ENDIF + 140 CONTINUE + 150 CONTINUE +*---- +* SPH CORRECTION. +*---- + DO 260 IRES=1,NIRES + DO 250 IGRP=1,NGRP + IF(MASKG(IGRP,IRES)) THEN + SPHNEW=1.0 + DO 200 IND=1,NBNRS + SPHNEW=SPH(IND,IRES,IGRP) + IF(SPHNEW.NE.SPHNEW) THEN + WRITE(HSMG,'(41HUSSSPH: UNABLE TO SET SPH FACTOR IN GROUP,I4, + 1 12H AND SS ZONE,I4,1H.)') IGRP,IND + CALL XABORT(HSMG) + ENDIF + PHGAR(IND,IRES,IGRP)=PHGAR(IND,IRES,IGRP)/SPHNEW + SFGAR(IND,IRES,IGRP)=SFGAR(IND,IRES,IGRP)*SPHNEW + IF(ISUBG.EQ.4) SWGAR(IND,IRES,IGRP)=SWGAR(IND,IRES,IGRP)*SPHNEW + DO 175 IL=1,NL + IF(MOD(IL-1,2).EQ.0) THEN + SSGAR(IND,IRES,IL,IGRP)=SSGAR(IND,IRES,IL,IGRP)*SPHNEW+ + 1 STGAR(IND,IRES,IGRP)*(1.0-SPHNEW) + ELSE + SSGAR(IND,IRES,IL,IGRP)=0.0 + ENDIF + DO 170 JGRP=1,NGRP + IF(MOD(IL-1,2).EQ.0) THEN + IF(IGRP.EQ.JGRP) THEN + S0GAR(IND,IRES,IL,IGRP,IGRP)=S0GAR(IND,IRES,IL,IGRP,IGRP)* + 1 SPHNEW+STGAR(IND,IRES,IGRP)*(1.0-SPHNEW) + ELSE + S0GAR(IND,IRES,IL,JGRP,IGRP)=S0GAR(IND,IRES,IL,JGRP,IGRP)* + 1 SPHNEW + ENDIF + ELSE + IF(IGRP.EQ.JGRP) THEN + S0GAR(IND,IRES,IL,IGRP,IGRP)=S0GAR(IND,IRES,IL,IGRP,IGRP)/ + 1 SPHNEW+STGAR(IND,IRES,IGRP)*(1.0-1.0/SPHNEW) + ELSE + S0GAR(IND,IRES,IL,JGRP,IGRP)=S0GAR(IND,IRES,IL,JGRP,IGRP)/ + 1 SPH(IND,IRES,JGRP) + ENDIF + ENDIF + IF(MOD(IL-1,2).EQ.1) THEN + SSGAR(IND,IRES,IL,IGRP)=SSGAR(IND,IRES,IL,IGRP)+ + 1 S0GAR(IND,IRES,IL,JGRP,IGRP) + ENDIF + 170 CONTINUE + 175 CONTINUE + DO 180 IED=1,NED + SAGAR(IND,IRES,IED,IGRP)=SAGAR(IND,IRES,IED,IGRP)*SPHNEW + 180 CONTINUE + DO 190 IDEL=1,NDEL + SDGAR(IND,IRES,IDEL,IGRP)=SDGAR(IND,IRES,IDEL,IGRP)*SPHNEW + 190 CONTINUE + 200 CONTINUE +* + IF(IMPX.GT.1) THEN + IF(LTIT) THEN + WRITE(6,'(/42H USSSPH: SPH CORRECTED SELF-SHIELDED MICRO, + 1 23HSCOPIC CROSS SECTIONS (,A12,2H)./6H GROUP,5H FUEL,9X, + 2 4HFLUX,2X,23HSPH FACTOR ISOTOPE...,8X,5HTOTAL,3X, + 3 10HSCATTERING,3X,10HNU*FISSION,13H WITHIN-GROUP,7X, + 4 6HDELTAU)') HCAL + LTIT=.FALSE. + ENDIF + DO 240 IND=1,NBNRS + DO 220 ISO=1,NBISO + IF(IAPT(ISO).EQ.IRES) THEN + WRITE(TEX8,'(2A4)') (ISOBIS(J,ISO),J=1,2) + ENDIF + 220 CONTINUE + WRITE(6,'(1X,2I5,1P,E13.4,E12.4,3X,1H'',A8,1H'',5E13.4)') + 1 IGRP,IND,PHGAR(IND,IRES,IGRP),SPH(IND,IRES,IGRP), + 2 TEX8,STGAR(IND,IRES,IGRP),SSGAR(IND,IRES,1,IGRP), + 3 SFGAR(IND,IRES,IGRP),S0GAR(IND,IRES,1,IGRP,IGRP),DELTAU(IGRP) + 240 CONTINUE + ENDIF + ENDIF + 250 CONTINUE + 260 CONTINUE +* *************************************************************** + CALL LCMSIX(IPLI0,' ',2) + CALL LCMSIX(IPLI0,' ',2) + CALL KDRCPU(TK2) + IF(IMPX.GT.1) WRITE(6,'(/34H USSSPH: CPU TIME SPENT TO COMPUTE, + 1 18H THE SPH FACTORS =,F8.1,8H SECOND./9X,17HNUMBER OF ASSEMBL, + 2 15HY DOORS CALLS =,I5,1H.)') TK2-TK1,ICPIJ +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 270 DEALLOCATE(FUNKNO,SUNKNO,FLNEW,SIGG,SIGS0X,SIGTXS,VOLMER,SIGTI) + DEALLOCATE(NPSYS) + RETURN + END diff --git a/Dragon/src/VDG.f b/Dragon/src/VDG.f new file mode 100644 index 0000000..d00f17a --- /dev/null +++ b/Dragon/src/VDG.f @@ -0,0 +1,420 @@ +*DECK VDG + SUBROUTINE VDG(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +* Reaction rate comparison operator for Van Der Gucht benchmarks. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): read-only reference type(L_EDIT); +* HENTRY(2): read-only type(L_EDIT). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MAXGRO=500,MAXISO=100) + CHARACTER TEXT4*4,TITLE*72,TEXT12*12,HSIGN*12,HSMG*131 + DOUBLE PRECISION DFLOTT + TYPE(C_PTR) IPLIB,JPLIB,IPEDI,JPEDI +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: SIGA2,DELTA2,SIGA1,ERR,FLUX, + 1 SIGS,SIGA,DEN2,VOLU2,DEN1,VOLU1,SIGA3,SIGA4,DELTA1 + REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGA3I,SIGA4I + CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: NAMES1,NAMES2 + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO1,IPISO2 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(DELTA2(MAXGRO),ERR(MAXGRO),NAMES2(MAXISO),FLUX(MAXGRO), + 1 SIGS(MAXGRO),SIGA(MAXGRO),DEN2(MAXISO),VOLU2(MAXISO), + 2 DEN1(MAXISO),VOLU1(MAXISO),NAMES1(MAXISO),DELTA1(MAXGRO)) +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.LE.1) CALL XABORT('VDG: TWO PARAMETERS EXPECTED.') + IF((JENTRY(1).NE.2).OR.(IENTRY(1).LT.1).OR.(IENTRY(1).GT.4)) + 1 CALL XABORT('VDG: LINKED LIST OR FILE IN READ-ONLY MODE EXPEC' + 2 //'TED AT FIRST RHS.') + IF((JENTRY(2).NE.2).OR.(IENTRY(2).LT.1).OR.(IENTRY(2).GT.4)) + 1 CALL XABORT('VDG: LINKED LIST OR FILE IN READ-ONLY MODE EXPEC' + 2 //'TED AT SECOND RHS.') +*---- +* READ INPUT DATA. +*---- + IMPX=1 + IG1=1 + IG2=9999999 + IPICK=0 + 10 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.10) GO TO 20 + IF(INDIC.NE.3) CALL XABORT('VDG: CHARACTER DATA EXPECTED(1).') + IF(TEXT4.EQ.'EDIT') THEN + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('VDG: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT4.EQ.'GRMI') THEN + CALL REDGET(INDIC,IG1,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('VDG: INTEGER DATA EXPECTED(3).') + ELSE IF(TEXT4.EQ.'GRMA') THEN + CALL REDGET(INDIC,IG2,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('VDG: INTEGER DATA EXPECTED(4).') + ELSE IF(TEXT4.EQ.';') THEN + GO TO 20 + ELSE IF(TEXT4.EQ.'PICK') THEN + IPICK=1 + GO TO 20 + ELSE + CALL XABORT('VDG: '//TEXT4//' IS AN INVALID KEY WORD.') + ENDIF + GO TO 10 +*---- +* PROCESS FIRST AND SECOND RHS. +*---- + 20 IF(IENTRY(1).GE.3) THEN + CALL LCMOP(IPLIB,'COPY1',0,1,0) + IFILE=FILUNIT(KENTRY(1)) + CALL LCMEXP(IPLIB,0,IFILE,IENTRY(1)-2,2) + ELSE + IPLIB=KENTRY(1) + ENDIF + CALL LCMGTC(IPLIB,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_EDIT') THEN + TEXT12=HENTRY(1) + CALL XABORT('VDG: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_EDIT EXPECTED.') + ENDIF + IF(IENTRY(2).GE.3) THEN + CALL LCMOP(IPEDI,'COPY2',0,1,0) + IFILE=FILUNIT(KENTRY(2)) + CALL LCMEXP(IPEDI,0,IFILE,IENTRY(2)-2,2) + ELSE + IPEDI=KENTRY(2) + ENDIF + CALL LCMGTC(IPEDI,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_EDIT') THEN + TEXT12=HENTRY(2) + CALL XABORT('VDG: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_EDIT EXPECTED.') + ENDIF + CALL LCMLEN(IPEDI,'TITLE',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGTC(IPEDI,'TITLE',72,TITLE) + ELSE + TITLE='*** NO TITLE PROVIDED ***' + ENDIF + WRITE(6,'(/1X,A72)') TITLE +*---- +* RECOVER GENERAL INFORMATION FROM THE APPROXIMATE RUN. +*---- + CALL LCMSIX(IPEDI,'REF-CASE0001',1) + CALL LCMLEN(IPEDI,'ISOTOPESDENS',NISOT1,ITYLCM) + WRITE(6,*) 'VDG: DRAGON NISOT(APPROX)=',NISOT1 + IF(NISOT1.GT.MAXISO) CALL XABORT('VDG: INSUFFICIENT MAXISO(1).') + CALL LCMGTC(IPEDI,'ISOTOPESUSED',12,NISOT1,NAMES1) + IF(IMPX.GT.1) THEN + WRITE(6,'(/24H VDG: APPROXIMATE OUTPUT)') + CALL LCMLIB(IPEDI) + WRITE(6,'(9H ISOTOPES/(2H '',A12,1H'',:,2X,1H'',A12,1H'',:,2X, + 1 1H'',A12,1H'',:,2X,1H'',A12,1H''))') NAMES1(:NISOT1) + ENDIF + CALL LCMLEN(IPEDI,'DELTAU',LGRP1,ITYLCM) + IF(LGRP1.GT.MAXGRO) CALL XABORT('VDG: INSUFFICIENT MAXGRO(1).') + CALL LCMGET(IPEDI,'DELTAU',DELTA1) + CALL LCMGET(IPEDI,'ISOTOPESVOL',VOLU1) + CALL LCMGET(IPEDI,'ISOTOPESDENS',DEN1) +*---- +* SET THE LCM MICROLIB ISOTOPEWISE DIRECTORIES. +*---- + ALLOCATE(IPISO1(NISOT1)) + CALL LIBIPS(IPEDI,NISOT1,IPISO1) +*---- +* RECOVER GENERAL INFORMATION FROM THE AUTOSECOL RUN. +*---- + CALL LCMSIX(IPLIB,'REF-CASE0001',1) + CALL LCMLEN(IPLIB,'ISOTOPESDENS',NISOT2,ITYLCM) + IF(NISOT2.NE.NISOT1) CALL XABORT('VDG: INVALIB NISOT.') + WRITE(6,*) 'VDG: DRAGON NISOT(APPROX)=',NISOT2 + CALL LCMGTC(IPLIB,'ISOTOPESUSED',12,NISOT2,NAMES2) + IF(IMPX.GT.1) THEN + WRITE(6,'(/22H VDG: AUTOSECOL OUTPUT)') + CALL LCMLIB(IPLIB) + WRITE(6,'(9H ISOTOPES/(2H '',A12,1H'',:,2X,1H'',A12,1H'',:,2X, + 1 1H'',A12,1H'',:,2X,1H'',A12,1H''))') NAMES2(:NISOT2) + ENDIF + CALL LCMLEN(IPLIB,'DELTAU',LGRP2,ITYLCM) + IF(LGRP2.GT.MAXGRO) CALL XABORT('VDG: INSUFFICIENT MAXGRO(2).') + CALL LCMGET(IPLIB,'DELTAU',DELTA2) + LGRMIN=LGRP2+1 + LGRMAX=0 + IG2=MIN(LGRP2,IG2) + DO 30 I=IG1,IG2 + IF(DELTA2(I).NE.0.0) THEN + LGRMIN=MIN(LGRMIN,I) + LGRMAX=MAX(LGRMAX,I) + ENDIF + 30 CONTINUE + CALL LCMGET(IPLIB,'ISOTOPESVOL',VOLU2) + CALL LCMGET(IPLIB,'ISOTOPESDENS',DEN2) +*---- +* SET THE LCM MICROLIB ISOTOPEWISE DIRECTORIES. +*---- + ALLOCATE(IPISO2(NISOT2)) + CALL LIBIPS(IPLIB,NISOT2,IPISO2) +*---- +* LOOP OVER THE ISOTOPES OF THE APPROXIMATE RUN. +*---- + ALLOCATE(SIGA1(LGRP1),SIGA2(LGRP2),SIGA3(LGRP1),SIGA4(LGRP2)) + ALLOCATE(SIGA3I(LGRP1,NISOT1),SIGA4I(LGRP2,NISOT2)) + SIGA3(:LGRP1)=0.0 + SIGA4(:LGRP2)=0.0 + SIGA3I(:LGRP1,:NISOT1)=0.0 + SIGA4I(:LGRP2,:NISOT2)=0.0 + NRES=0 + DO 170 ISOT=1,NISOT1 + TEXT12=NAMES1(ISOT) + IF(TEXT12(:8).EQ.'*MAC*RES') THEN + NRES=NRES+1 + GO TO 170 + ENDIF + SIGA1(:LGRP1)=0.0 + SIGA2(:LGRP2)=0.0 + NAMES1(ISOT)=TEXT12 + WRITE(6,'(/26H VDG: PROCESSING ISOTOPE '',A12,2H''.)') TEXT12 + IF(NAMES1(ISOT).NE.NAMES2(ISOT)) THEN + WRITE(HSMG,'(28H VDG: INVALID ISOTOPE NAMES=,A12,4H VS ,A12, + 1 1H.)') NAMES1(ISOT),NAMES2(ISOT) + CALL XABORT(HSMG) + ENDIF + JPEDI=IPISO1(ISOT) + IF(.NOT.C_ASSOCIATED(JPEDI)) CALL XABORT('VDG: ERROR NB 210') + CALL LCMGET(JPEDI,'NTOT0',SIGA) + CALL LCMGET(JPEDI,'SIGS00',SIGS) + CALL LCMGET(JPEDI,'NWT0',FLUX) + DO 100 I=1,LGRP1 + SIGGG=(SIGA(I)-SIGS(I))*FLUX(I)*VOLU1(ISOT)*DEN1(ISOT) + SIGA1(I)=SIGA1(I)+SIGGG + SIGA3(I)=SIGA3(I)+SIGGG + SIGA3I(I,ISOT)=SIGA3I(I,ISOT)+SIGGG + 100 CONTINUE + IF(IMPX.NE.0) THEN + WRITE (6,'(/27H DRAGON VOLUME OF THE FUEL=,1P,E12.4)') + 1 VOLU1(ISOT) + WRITE (6,'(/27H CONDENSED LETHARGY WIDTHS:/(1X,1P,10E12.4))') + 1 (DELTA1(I),I=1,LGRP2) + WRITE (6,'(/23H CONDENSED DRAGON FLUX:/(1X,1P,10E12.4))') + 1 (FLUX(I),I=1,LGRP2) + WRITE (6,'(/35H CONDENSED DRAGON ABSORPTION RATES:/ + 1 (1X,1P,10E12.4))') (SIGA1(I),I=1,LGRP2) + ENDIF +*---- +* RECOVER INFORMATION FROM AUTOSECOL RUN. +*---- + IF(IMPX.NE.0) THEN + WRITE (6,'(/35H AUTOSECOL VOLUME OF THE FUEL ISOT=,I4,1H=,1P, + 1 E12.4)') ISOT,VOLU2(ISOT) + ENDIF + JPLIB=IPISO2(ISOT) + IF(.NOT.C_ASSOCIATED(JPLIB)) CALL XABORT('VDG: ERROR NB 211') + CALL LCMGET(JPLIB,'NTOT0',SIGA) + CALL LCMGET(JPLIB,'SIGS00',SIGS) + CALL LCMGET(JPLIB,'NWT0',FLUX) + CALL LCMSIX(JPLIB,' ',2) + DO 130 I=LGRMIN,LGRMAX + SIGGG=(SIGA(I)-SIGS(I))*FLUX(I)*VOLU2(ISOT)*DEN2(ISOT) + SIGA2(I)=SIGA2(I)+SIGGG + SIGA4(I)=SIGA4(I)+SIGGG + SIGA4I(I,ISOT)=SIGA4I(I,ISOT)+SIGGG + 130 CONTINUE + IF(ABS(VOLU1(ISOT)-VOLU2(ISOT)).GT.1.0E-4*VOLU1(ISOT)) THEN + WRITE(HSMG,'(46HVDG: INVALID INTEGRATED VOLUME IN DRAGON. ISOT, + 1 5HOPE='',A12,16H'' DRAGON VOLUME=,1P,E12.4,16H. AUTOSECOL VOLU, + 2 3HME=,E12.4,1H.)') NAMES1(ISOT),VOLU1(ISOT),VOLU2(ISOT) + CALL XABORT(HSMG) + ENDIF + IF(IMPX.NE.0) THEN + WRITE (6,'(/30H AUTOSECOL VOLUME OF THE FUEL=,1P,E12.4)') + 1 VOLU2(ISOT) + WRITE (6,'(/23H ENERGY DOMAIN INDICES=,I5,5H --->,I5)') + 1 LGRMIN,LGRMAX + WRITE (6,'(/27H CONDENSED LETHARGY WIDTHS:/(1X,1P,10E12.4))') + 1 (DELTA2(I),I=LGRMIN,LGRMAX) + WRITE (6,'(/26H CONDENSED AUTOSECOL FLUX:/(1X,1P,10E12.4))') + 1 (FLUX(I),I=LGRMIN,LGRMAX) + WRITE (6,'(/38H CONDENSED AUTOSECOL ABSORPTION RATES:/ + 1 (1X,1P,10E12.4))') (SIGA2(I),I=LGRMIN,LGRMAX) + ENDIF +*---- +* PERFORM STATISTICS ON A PARTICULAR ISOTOPE. +*---- + SUMREF=0.0 + ZMAX=0.0 + ZAVER=0.0 + SUM=0.0 + IMAX=0 + DO 150 I=LGRMIN,LGRMAX + ERR(I)=100.0*(SIGA1(I)-SIGA2(I))/SIGA2(I) + IF(I-LGRMIN+1.GE.3) ZAVER=ZAVER+ABS(ERR(I)) + EPSD=ABS(DELTA2(I)-DELTA1(I))/DELTA2(I) + IF(EPSD.GT.1.0E-3) CALL XABORT('VDG: INVALID DELTA1.(1)') + IF((I-LGRMIN+1.GE.3).AND.(ABS(ERR(I)).GT.ZMAX)) THEN + ZMAX=ABS(ERR(I)) + IMAX=I + ENDIF + SUMREF=SUMREF+SIGA2(I) + SUM=SUM+SIGA1(I) + 150 CONTINUE + ZAVER=ZAVER/REAL(LGRP2-2) + SUMERR=100.0*(SUM-SUMREF)/SUMREF + WRITE (6,'(1H1/11H ISOTOPE ='',A12,1H''//10X,9HAUTOSECOL,3X, + 1 6HDRAGON,8X,5HERROR)') NAMES1(ISOT) + DO 160 I=LGRMIN,LGRMAX + WRITE (6,'(1X,I5,3X,1P,2E12.5,0P,F9.3,2H %)') I,SIGA2(I), + 1 SIGA1(I),ERR(I) + 160 CONTINUE + WRITE (6,'(10X,11(1H-),1X,11(1H-)/3X,3HSUM,3X,1P,2E12.5,0P,F9.3, + 1 2H %)') SUMREF,SUM,SUMERR + WRITE (6,'(/10X,14HMAXIMUM ERROR=,F9.3,2H %,9H IN GROUP,I4)') + 1 ZMAX,IMAX + WRITE (6,'(10X,14HAVERAGE ERROR=,F9.3,2H %)') ZAVER + WRITE (6,'(7X,17HINTEGRATED ERROR=,F9.3,2H %/)') SUMERR + 170 CONTINUE + DEALLOCATE(IPISO2,IPISO1) +*---- +* PERFORM STATISTICS ON EACH TYPE OF ISOTOPE. +*---- + IF(NISOT1-NRES.GT.2) THEN + DO 200 ISOT=1,NISOT1 + IF(NAMES1(ISOT)(:8).EQ.'*MAC*RES') GO TO 200 + SUMREF=0.0 + ZMAX=0.0 + ZAVER=0.0 + SUM=0.0 + IMAX=0 + DO 180 I=LGRMIN,LGRMAX + ERR(I)=100.0*(SIGA3I(I,ISOT)-SIGA4I(I,ISOT))/SIGA4I(I,ISOT) + IF(I-LGRMIN+1.GE.3) ZAVER=ZAVER+ABS(ERR(I)) + EPSD=ABS(DELTA2(I)-DELTA1(I))/DELTA2(I) + IF(EPSD.GT.1.0E-3) CALL XABORT('VDG: INVALID DELTA1.(2)') + IF((I-LGRMIN+1.GE.3).AND.(ABS(ERR(I)).GT.ZMAX)) THEN + ZMAX=ABS(ERR(I)) + IMAX=I + ENDIF + SUMREF=SUMREF+SIGA4I(I,ISOT) + SUM=SUM+SIGA3I(I,ISOT) + 180 CONTINUE + ZAVER=ZAVER/REAL(LGRMAX-LGRMIN-1) + SUMERR=100.0*(SUM-SUMREF)/SUMREF + WRITE (6,'(1H1/12H SUM OF ALL ,A8//10X,9HAUTOSECOL,3X, + 1 6HDRAGON,8X,5HERROR)') NAMES1(ISOT) + DO 190 I=LGRMIN,LGRMAX + WRITE (6,'(1X,I5,3X,1P,2E12.5,0P,F9.3,2H %)') I,SIGA4I(I,ISOT), + 1 SIGA3I(I,ISOT),ERR(I) + 190 CONTINUE + WRITE (6,'(10X,11(1H-),1X,11(1H-)/3X,3HSUM,3X,1P,2E12.5,0P, + 1 F9.3,2H %)') SUMREF,SUM,SUMERR + WRITE (6,'(/10X,14HMAXIMUM ERROR=,F9.3,2H %,9H IN GROUP,I4)') + 1 ZMAX,IMAX + WRITE (6,'(10X,14HAVERAGE ERROR=,F9.3,2H %)') ZAVER + WRITE (6,'(7X,17HINTEGRATED ERROR=,F9.3,2H %/)') SUMERR + 200 CONTINUE + ENDIF +*---- +* PERFORM STATISTICS ON ALL ISOTOPES. +*---- + SUMREF=0.0 + ZMAX=0.0 + ZAVER=0.0 + SUM=0.0 + IMAX=0 + DO 210 I=LGRMIN,LGRMAX + ERR(I)=100.0*(SIGA3(I)-SIGA4(I))/SIGA4(I) + IF(I-LGRMIN+1.GE.3) ZAVER=ZAVER+ABS(ERR(I)) + EPSD=ABS(DELTA2(I)-DELTA1(I))/DELTA2(I) + IF(EPSD.GT.1.0E-3) CALL XABORT('VDG: INVALID DELTA1.(3)') + IF((I-LGRMIN+1.GE.3).AND.(ABS(ERR(I)).GT.ZMAX)) THEN + ZMAX=ABS(ERR(I)) + IMAX=I + ENDIF + SUMREF=SUMREF+SIGA4(I) + SUM=SUM+SIGA3(I) + 210 CONTINUE + ZAVER=ZAVER/REAL(LGRMAX-LGRMIN-1) + SUMERR=100.0*(SUM-SUMREF)/SUMREF + WRITE (6,'(1H1/20H SUM OF ALL ISOTOPES//10X,9HAUTOSECOL,3X, + 1 6HDRAGON,8X,5HERROR)') + DO 220 I=LGRMIN,LGRMAX + WRITE (6,'(1X,I5,3X,1P,2E12.5,0P,F9.3,2H %)') I,SIGA4(I), + 1 SIGA3(I),ERR(I) + 220 CONTINUE + WRITE (6,'(10X,11(1H-),1X,11(1H-)/3X,3HSUM,3X,1P,2E12.5,0P,F9.3, + 1 2H %)') SUMREF,SUM,SUMERR + WRITE (6,'(/10X,14HMAXIMUM ERROR=,F9.3,2H %,9H IN GROUP,I4)') + 1 ZMAX,IMAX + WRITE (6,'(10X,14HAVERAGE ERROR=,F9.3,2H %)') ZAVER + WRITE (6,'(7X,17HINTEGRATED ERROR=,F9.3,2H %/)') SUMERR + IF(IMPX.GT.50) THEN + WRITE(6,'(1P,E12.5,1H,,E12.5,1H,,E12.5,1H,,E12.5,1H,,E12.5,1H,, + 1 E12.5,1H,,E12.5,1H,,E12.5,1H,,E12.5,1H,,E12.5,1H,)') + 2 (ERR(I),I=LGRMIN,LGRMAX) + ENDIF +*---- +* RECOVER THE FINAL POWER AND SAVE IT IN A CLE-2000 VARIABLE +*---- + IF(IPICK.EQ.1) THEN + CALL REDGET(ITYP,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('VDG: CHARACTER DATA EXPECTED(2).') + IF(TEXT4.EQ.'MAXV') THEN + VAL=ZMAX + ELSE IF(TEXT4.EQ.'AVER') THEN + VAL=ZAVER + ELSE IF(TEXT4.EQ.'INTG') THEN + VAL=SUMERR + ELSE + CALL XABORT('VDG: MAXV/AVER/INTG KEYWORD EXPECTED.') + ENDIF + CALL REDGET(ITYP,NITMA,FLOTT,TEXT4,DFLOTT) + IF(ITYP.NE.-2) CALL XABORT('VDG: OUTPUT REAL EXPECTED.') + ITYP=2 + CALL REDPUT(ITYP,NITMA,VAL,TEXT4,DFLOTT) + CALL REDGET(ITYP,NITMA,FLOTT,TEXT4,DFLOTT) + IF((ITYP.NE.3).OR.(TEXT4.NE.';')) THEN + CALL XABORT('VDG: ; CHARACTER EXPECTED.') + ENDIF + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SIGA4I,SIGA3I,SIGA4,SIGA3,SIGA2,SIGA1) + DEALLOCATE(DELTA1,NAMES1,VOLU1,DEN1,VOLU2,DEN2,SIGA,SIGS,FLUX, + 1 NAMES2,ERR,DELTA2) + RETURN + END diff --git a/Dragon/src/XCGBCM.f b/Dragon/src/XCGBCM.f new file mode 100644 index 0000000..6a0f6d4 --- /dev/null +++ b/Dragon/src/XCGBCM.f @@ -0,0 +1,54 @@ +*DECK XCGBCM + SUBROUTINE XCGBCM(IPTRK,NSOUT,NCODE,MATRT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Built boundary condition matrix for reflection and transmission. +* +*Copyright: +* Copyright (C) 1998 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G.Marleau +* +*Parameters: input +* IPTRK pointer to the tracking file. +* NSOUT number of outer surface. +* NCODE albedo type. +* +*Parameters: output +* MATRT BC matrix for reflection/transmission. +* +*---------------------------------------------------------------------- +* + USE GANLIB + PARAMETER (NMCOD=6) + TYPE(C_PTR) IPTRK + INTEGER NSOUT,NCODE(NMCOD),MATRT(NSOUT),ISOUT +*---- +* INITIALIZE MATRT TO REFLECTION +*---- + DO 100 ISOUT=1,NSOUT + MATRT(ISOUT)=ISOUT + 100 CONTINUE +*---- +* FOR CARTESIAN CELL LOOK AT PERIODIC BOUNDARY CONDITIONS +* AND SET TRANSMISSION MATRIX +*---- + IF(NSOUT.EQ.4) THEN + IF((NCODE(1) .EQ. 4) .AND. (NCODE(2) .EQ.4)) THEN + MATRT(1)=3 + MATRT(3)=1 + ENDIF + IF((NCODE(3) .EQ. 4) .AND. (NCODE(4) .EQ.4)) THEN + MATRT(2)=4 + MATRT(4)=2 + ENDIF + ENDIF + CALL LCMPUT(IPTRK,'BC-REFL+TRAN',NSOUT,1,MATRT) + RETURN + END diff --git a/Dragon/src/XCGDIM.f b/Dragon/src/XCGDIM.f new file mode 100644 index 0000000..a28fb98 --- /dev/null +++ b/Dragon/src/XCGDIM.f @@ -0,0 +1,210 @@ +*DECK XCGDIM + SUBROUTINE XCGDIM(IPGEOM,MREGIO,NSOUT,IROT,IAPP,MAXJ,NVOL, + > NBAN,MNAN,NRT,MSROD,MAROD,NSURF) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Initialize dimension for 2-D cluster geometry. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPGEOM pointer to the geometry. +* MREGIO maximum number of regions. +* NSOUT number of surface for outer region. +* IROT type of PIJ reconstruction: +* =0 CP calculations; +* =1 direct JPM reconstruction; +* =2 rot2 type reconstruction. +* IAPP type of surface conditions +* level of dp approximation for jpm: +* =1 DP0 all; +* =2 DP1 all (default); +* =3 DP1 inside DP0 outside symmetry conditions for CP. +* MAXJ maximum number of currents. +* Unused for CP calculations. +* +*Parameters: output +* NVOL number of regions. +* NBAN number of concentric regions. +* MNAN maximum nunber of radius to read. +* NRT number of rod types. +* MSROD maximum number of subrods per rods. +* MAROD maximum number of rods an annulus. +* NSURF maximum number real surfaces. +* Unused for CP calculation. +* +*---------------------------------------------------------------------- +* + USE GANLIB + PARAMETER (NSTATE=40) + TYPE(C_PTR) IPGEOM + INTEGER MREGIO,NSOUT,IROT,IAPP,MAXJ,NVOL, + > NBAN,MNAN,NRT,MSROD,MAROD,NSURF,ISTATE(NSTATE) + CHARACTER CMSG*131,TEXT12*12 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: JSPLIT,JGEOM +*---- +* CHECK FOR VALID IROT AND GEOMETRY +*---- + IF(IROT.GT.2.OR.IROT.LT.0) + > CALL XABORT('XCGDIM: UNABLE TO PROCESS THE GEOMETRY.') + ISTATE(:NSTATE)=0 + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) +*---- +* CHECK FOR INVALID GEOMETRY OPTIONS +* ISTATE( 8) -> CELL IS INVALID +* ISTATE(10) -> MERGE IS INVALID +* ISTATE(11) -> SPLIT IS INVALID FOR CLUSTER ANNULUS +*---- + IF ( (ISTATE(8).NE.0).OR.(ISTATE(10).NE.0) ) + > CALL XABORT('XCGDIM: UNABLE TO PROCESS THE GEOMETRY.') + IF(ISTATE(11).EQ.0) THEN + NVOL=ISTATE(6) + ELSE + CALL LCMLEN(IPGEOM,'SPLITR',NSPLIT,ITYPE) + IF(ITYPE.NE.1) + > CALL XABORT('XCGDIM: SPLIT RECORD ON LCM IS NOT INTEGER') + ALLOCATE(JSPLIT(NSPLIT)) + CALL LCMGET(IPGEOM,'SPLITR',JSPLIT) + IF(NSOUT.GT.1) THEN + NVOL=1 + ELSE + NVOL=0 + ENDIF + DO 135 ISPLIT=1,NSPLIT + NVOL=NVOL+ABS(JSPLIT(ISPLIT)) + 135 CONTINUE + DEALLOCATE(JSPLIT) + ENDIF + NBAN=NVOL + MNAN=NBAN+1 + IF(NSOUT.EQ.4) THEN + MNAN=MNAN+3 + ENDIF + IF(NSOUT.EQ.4) THEN + NSURF=2*NVOL+2 + ELSE IF(NSOUT.EQ.6) THEN + NSURF=2*NVOL+4 + ELSE + NSURF=2*NVOL-1 + ENDIF +*---- +* COUNT NUMBER OF ROD TYPES IN CLUSTER +*---- + CALL LCMLEN(IPGEOM,'CLUSTER',ILONG,ITYPE) + IF(ITYPE.NE.3) + > CALL XABORT('XCGDIM: CLUSTER RECORD ON LCM IS NOT CHARACTER') + NRT=ILONG/3 + IF(ISTATE(9).LT.NRT) THEN + WRITE(CMSG,9001) ISTATE(9),NRT + CALL XABORT(CMSG) + ENDIF + ALLOCATE(JGEOM(ILONG)) + IPOS=1 + MSROD=1 + MAROD=1 + CALL LCMGET(IPGEOM,'CLUSTER',JGEOM) +*---- +* FOR EACH ROD TYPE FIND NUMBER OF SUBRODS AND NUMBER OF PINS +*---- + DO 120 IRT=1,NRT + WRITE(TEXT12(1:4),'(A4)') JGEOM(IPOS) + WRITE(TEXT12(5:8),'(A4)') JGEOM(IPOS+1) + WRITE(TEXT12(9:12),'(A4)') JGEOM(IPOS+2) + IPOS=IPOS+3 + CALL LCMSIX(IPGEOM,TEXT12,1) + ISTATE(:NSTATE)=0 + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) + CALL LCMGET(IPGEOM,'RPIN',RPIN) + CALL LCMGET(IPGEOM,'NPIN',NPIN) + MAROD=MAX(MAROD,NPIN) + IF(RPIN.EQ.0.0) THEN + IROTS=1 + ELSE + IROTS=IROT + ENDIF + IF(ISTATE(1).NE.3) THEN + WRITE(CMSG,9002) ISTATE(1) + CALL XABORT(CMSG) + ENDIF + IF(ISTATE(11).EQ.0) THEN + NVOL=NVOL+ISTATE(6) + NMSROD=ISTATE(6) + IF(IROT.GT.0) NSURF=NSURF+2*IROTS*ISTATE(6) + ELSE + CALL LCMLEN(IPGEOM,'SPLITR',NSPLIT,ITYPE) + IF(ITYPE.NE.1) + > CALL XABORT('XCGDIM: SPLIT RECORD ON LCM IS NOT INTEGER') + ALLOCATE(JSPLIT(NSPLIT)) + CALL LCMGET(IPGEOM,'SPLITR',JSPLIT) + NMSROD=0 + DO 130 ISPLIT=1,NSPLIT + NMSROD=NMSROD+ABS(JSPLIT(ISPLIT)) + NVOL=NVOL+ABS(JSPLIT(ISPLIT)) + 130 CONTINUE + IF(IROT.GT.0) NSURF=NSURF+2*IROTS*NMSROD + DEALLOCATE(JSPLIT) + ENDIF + MSROD=MAX(MSROD,NMSROD) + CALL LCMSIX(IPGEOM,' ',2) + 120 CONTINUE + MNAN=MAX(MNAN,MSROD+1) + DEALLOCATE(JGEOM) +*---- +* CHECK IF NUMBER OF REGIONS IS ADEQUATE +*---- + IF (NVOL.GT.MREGIO) THEN + WRITE(CMSG,9003) MREGIO,NVOL + CALL XABORT(CMSG) + ENDIF + IF(IROT.GT.0) THEN + IF(IAPP.EQ.3) THEN + IAPPR=2 + ELSE + IAPPR=IAPP + ENDIF + IF(NSOUT.EQ.4) THEN + NSURF=NSURF*IAPPR+4 + ELSE IF(NSOUT.EQ.6) THEN + NSURF=NSURF*IAPPR+6 + ELSE + NSURF=NSURF*IAPPR + ENDIF + IF(MAXJ.LT.NSURF) THEN + WRITE(CMSG,9004) NSURF,MAXJ + CALL XABORT(CMSG) + ENDIF + ELSE + NSURF=1 + IF(NSOUT.EQ.6) THEN + CALL LCMGET(IPGEOM,'IHEX',IHEX) + IF(IHEX.EQ.1) THEN + IAPP=12 + ELSE IF(IHEX.EQ.3) THEN + IAPP=6 + ENDIF + ENDIF + ENDIF + RETURN +*---- +* ERROR MESSAGES FORMATS +*---- + 9001 FORMAT('XCGDIM: ONLY ',I10,5X,'SUB GEOMETRIES ON LCM WHILE ',5X, + > I10,5X,'SUB GEOMETRIES ARE REQUIRED BY CLUSTER') + 9002 FORMAT('XCGDIM: ',I10,5X,'IS AN ILLEGAL GEOMETRY INSIDE CLUSTER') + 9003 FORMAT('XCGDIM: MAXIMUM NUMBER OF REGION ALLOCATED =',I10, + > 5X,'NUMBER OF REGION REQUIRED =',I10) + 9004 FORMAT('XCGDIM: NUMBER OF CURRENT=',I10,5X,'IS LARGER THAN ', + >'ALLOWED MAXIMUM VALUE MAXJ=',I10) + END diff --git a/Dragon/src/XCGGEO.f b/Dragon/src/XCGGEO.f new file mode 100644 index 0000000..758017f --- /dev/null +++ b/Dragon/src/XCGGEO.f @@ -0,0 +1,801 @@ +*DECK XCGGEO + SUBROUTINE XCGGEO(IPGEOM,IROT,NSOUT,NVOL,NBAN,MNAN,NRT,MSROD, + > IPRT,ILK,NMAT,RAN,NRODS,RODS,NRODR,RODR,NRINFO, + > MATALB,VOLSUR,COTE,RADMIN,NCODE,ICODE,ZCODE, + > ALBEDO,KEYMRG,NXRS,NXRI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read and analyse 2-D cluster geometry. +* +*Copyright: +* Copyright (C) 1990 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPGEOM pointer to the geometry. +* IROT type of pij reconstruction: +* <0 cp calculations with symmetries; +* =0 cp calculations; +* =1 direct jpm reconstruction; +* =2 rot2 type reconstruction. +* NSOUT number of outer surface. +* NVOL maximum number of regions. +* NBAN number of concentric regions. +* MNAN maximum number of radius to read. +* NRT number of rod types. +* MSROD maximum number of subrods per rods. +* IPRT impression level. +* +*Parameters: output +* ILK leakage flag. ILK=.TRUE. if neutron leakage through +* external boundary is present. +* NMAT total number of materials. +* RAN radius of annular regions. +* NRODS integer description of rod of a given type: +* NRODS(1,IRT) = number of rod; +* NRODS(2,IRT) = number of subrods in rod; +* NRODS(3,IRT) = first concentric region. +* RODS real description of rod of a given type: +* RODS(1,IRT) = rod center radius; +* RODS(2,IRT) = angular position of first rod. +* NRODR subrod region. +* RODR subrod radius. +* NRINFO annular region content. +* NRINFO(1,IAN) = new region number. +* NRINFO(2,IAN): = +I cluster number (all); +* = 1000000+I cluster number cut (in); +* = 2000000+I cluster number cut (part); +* = 3000000+I cluster number cut (out); +* = 0 no cluster associated; +* = -I cluster at center (all). +* MATALB albedo-material of regions. +* VOLSUR surface/4-volume of regions. +* COTE additional side length for rectangle. +* RADMIN minimum radius of region. +* NCODE albedo type. +* ICODE albedo number associated with face. +* ZCODE albedo zcode vector. +* ALBEDO albedo. +* KEYMRG region-surface merge vector. +* NXRS integer description of rod of a given type +* last concentric region. +* NXRI annular region content multi-rod. +* +*---------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE + INTEGER IOUT,NSTATE,NMCOD + REAL PI,THSQ3 + PARAMETER (IOUT=6,NSTATE=40,NMCOD=6,PI=3.1415926535898, + > THSQ3=2.598076212) + CHARACTER NAMSBR*6 + PARAMETER (NAMSBR='XCGGEO') +*----- +* ROUTINE PARAMETERS +*---- + TYPE(C_PTR) IPGEOM + LOGICAL ILK,EMPTY,LCM + INTEGER IROT,NSOUT,NVOL,NBAN,MNAN,NRT,MSROD,IPRT, + > NMAT,NRODS(3,NRT),NRODR(NRT),NRINFO(2,NBAN), + > MATALB(-NSOUT:NVOL),NCODE(NMCOD),ICODE(NMCOD), + > KEYMRG(-NSOUT:NVOL),NXRS(NRT),NXRI(NRT,NBAN) + REAL RAN(NBAN),RODS(2,NRT),RODR(MSROD,NRT), + > VOLSUR(-NSOUT:NVOL),COTE,RADMIN,ALBEDO(NMCOD), + > ZCODE(NMCOD) +*---- +* LOCAL VARIABLES +*---- + INTEGER ISTATE(NSTATE) + CHARACTER GEONAM*12,TEXT12*12,CMSG*131 + INTEGER IRT,IAN,IS,IC,ITRAN,I,NRANN,NRRANN,NSPLIT,ISA,ILSTP, + > ISPL,ISURW,NTAN,IPOS,ITYPE,IM,ISR,IZRT,JAN,JRT,KRT, + > ILR,JSUR,JSW,ISV,ILSTR,JPRT,LRT,IREG,ILONG + REAL RADL,RADN,VFIN,DELV,XTOP,XBOT,VOLI,VOLROD,VOLF, + > VOLIS,XNROD,VOLFS,VANSPI,VRPSPI,VRDSPI,XINT, + > YINT,ANGR,ANGA,VRGOU1,VRGIN1 + INTEGER, ALLOCATABLE, DIMENSION(:) :: MATANN,ISPLIT,JGEOM + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: MATROD + REAL, ALLOCATABLE, DIMENSION(:) :: RAD + REAL, ALLOCATABLE, DIMENSION(:,:) :: VRGIO +*---- +* SCRATCH STORAGE ALLOCATION +* MATANN : TYPE OF MATERIAL FOR ANNULAR REGIONS I(NBAN) +* MATROD : TYPE OF MATERIAL FOR EACH SUBROD I(MSROD,NRT) +* ISPLIT : SPLITTING VECTOR FOR RODS I(NBAN+1) +* RAD : RADIUS VECTOR R(MNAN) +* VRGIO : DIVIDED ROD VOLUME R(2,NRT) +* : 2 - INSIDE REGION +* : 1 - OUTSIDE REGION +*---- + ALLOCATE(MATANN(NBAN),MATROD(MSROD,NRT),ISPLIT(NBAN+1)) + ALLOCATE(RAD(MNAN),VRGIO(2,NRT)) +*---- +* INITIALIZE NRINFO, NXRI AND NXRS TO 0 +*---- + DO 3 IRT=1,NRT + NXRS(IRT)=0 + NRODR(IRT)=0 + 3 CONTINUE + DO 4 IAN=1,NBAN + NRINFO(1,IAN)=0 + NRINFO(2,IAN)=0 + DO 5 IRT=1,NRT + NXRI(IRT,IAN)=0 + 5 CONTINUE + 4 CONTINUE + DO 6 IS=-NSOUT,NVOL + KEYMRG(IS)=IS + 6 CONTINUE + VOLSUR(0)=0.0 + MATALB(0)=0 +*---- +* READ GEOMETRY INFORMATIONS +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) +*---- +* RECOVER THE BOUNDARY CONDITIONS. +*---- + CALL LCMGET(IPGEOM,'NCODE',NCODE) + CALL LCMGET(IPGEOM,'ZCODE',ALBEDO) + CALL LCMGET(IPGEOM,'ICODE',ICODE) + DO 7 IC=1,NMCOD + ZCODE(IC)=ALBEDO(IC) + IF(ICODE(IC).NE.0) CALL XABORT(NAMSBR// + >': MACROLIB DEFINED ALBEDOS ARE NOT IMPLEMENTED.') + 7 CONTINUE + ITRAN=0 + DO 100 I=1,NMCOD + IF ((NCODE(I) .EQ. 3) .OR. (NCODE(I) .EQ. 5) .OR. + > (NCODE(I) .GE. 7)) THEN + CALL XABORT(NAMSBR//': INVALID TYPE OF B.C.') + ELSE IF(NCODE(I).EQ.2) THEN + ZCODE(I)=1.0 + ALBEDO(I)=1.0 + ELSE IF(NCODE(I).EQ.4) THEN + ITRAN=ITRAN+1 + ZCODE(I)=1.0 + ALBEDO(I)=1.0 + ELSE IF(NCODE(I).EQ.6) THEN + NCODE(I)=1 + ENDIF + 100 CONTINUE + IF(NSOUT.EQ.1.AND.IROT.GT.-400) THEN + MATALB(-1)=-2 + IF (NCODE(2).EQ.0) + > CALL XABORT(NAMSBR//': ANNULAR BOUNDARY CONDITION MISSING.') + IF(ITRAN.NE.0) THEN + NCODE(2)=2 + ENDIF + IF(ICODE(2).EQ.0) ICODE(2)=-2 + ILK=( (NCODE(2).EQ.1) .OR. (ZCODE(2).NE.1.0) ) + ELSE IF(NSOUT.EQ.6.OR.IROT.LT.-600) THEN + IF(ITRAN.NE.0) THEN + NCODE(1)=2 + ENDIF + IF(IROT.LT.0) THEN + MATALB(-1)=-1 + ELSE + MATALB(-1)=-1 + DO 101 IS=2,6 + ZCODE(IS)=ZCODE(1) + MATALB(-IS)=-1 + 101 CONTINUE + ENDIF + IF (NCODE(1).EQ.0) CALL XABORT(NAMSBR// + > ': HEXAGONAL BOUNDARY CONDITION MISSING.') + IF(ICODE(1).EQ.0) ICODE(1)=-1 + ILK=( (NCODE(1).EQ.1) .OR. (ZCODE(1).NE.1.0) ) + ELSE + IF(IROT.LT.0) THEN + IF(ITRAN.NE.0) CALL XABORT(NAMSBR// + > ': CARTESIAN SYMMETRY NO TRANSLATION BOUNDARY CONDITIONS') + IF(ZCODE(1).NE.ZCODE(2).OR.ZCODE(1).NE.ZCODE(3).OR. + > ZCODE(1).NE.ZCODE(4)) CALL XABORT(NAMSBR// + > ': CARTESIAN SYMMETRY REQUIRES '// + > ' IDENTICAL BOUNDARY CONDITION IN ALL DIRECTIONS.') + MATALB(-1)=-1 + IF (NCODE(1).EQ.0) CALL XABORT(NAMSBR// + > ': CARTESIAN BOUNDARY CONDITION MISSING.') + IF(ICODE(1).EQ.0) ICODE(1)=-1 + ILK=( (NCODE(1).EQ.1) .OR. (ZCODE(1).NE.1.0) ) + ELSE + MATALB(-1)=-2 + MATALB(-2)=-4 + MATALB(-3)=-1 + MATALB(-4)=-3 + ZCODE(5)=ZCODE(1) + ZCODE(1)=ZCODE(2) + ZCODE(2)=ZCODE(4) + ZCODE(4)=ZCODE(3) + ZCODE(3)=ZCODE(5) + ILK=.FALSE. + DO 102 IS=1,NSOUT + IF (NCODE(IS).EQ.0) CALL XABORT(NAMSBR// + > ': RECTANGLE BOUNDARY CONDITION MISSING.') + IF(.NOT. ILK) THEN + IF( (NCODE(IS).EQ.1) .OR. (ZCODE(IS).NE.1.0) ) THEN + ILK=.TRUE. + ENDIF + ENDIF + IF(ICODE(IS).EQ.0) ICODE(IS)=-IS + 102 CONTINUE + IF(ITRAN .GT. 0) THEN + IF(MOD(ITRAN,2) .EQ. 1) CALL XABORT(NAMSBR// + > ': TRANSLATION SYMMETRIES COME IN PAIRS') + IF((NCODE(1) .EQ. 4) .AND. (NCODE(2) .EQ. 4)) THEN + ITRAN=ITRAN-2 + ENDIF + IF((NCODE(3) .EQ. 4) .AND. (NCODE(4) .EQ. 4)) THEN + ITRAN=ITRAN-2 + ENDIF + IF(ITRAN .NE. 0) CALL XABORT(NAMSBR// + > ': WRONG PAIRS OF TRANSLATION SYMMETRIES') + ENDIF + ENDIF + ENDIF +*---- +* RECOVER THE MIXTURE FOR ANNULAR REGIONS +*---- + NRANN=ISTATE(6) + CALL LCMGET(IPGEOM,'MIX',MATANN) + NMAT=0 + DO 110 I=1,NRANN + NMAT=MAX(NMAT,MATANN(I)) + 110 CONTINUE +*---- +* RECOVER THE MESH COORDINATES +*---- + IF((IROT.LT.-400).OR.(NSOUT.GT.1)) THEN + NRRANN=NRANN-1 + MATANN(NBAN)=MATANN(NRANN) + ELSE + NRRANN=NRANN + ENDIF + CALL LCMGET(IPGEOM,'RADIUS',RAD) + IF(ISTATE(11).EQ.1) THEN +*---- +* SPLIT ANNULUS WHEN REQUIRED +*---- + CALL LCMLEN(IPGEOM,'SPLITR',ILONG,ITYPE) + IF(ILONG.GT.NBAN+1) CALL XABORT(NAMSBR//': SPLITR OVERFLOW') + CALL LCMGET(IPGEOM,'SPLITR',ISPLIT) + NSPLIT=0 + DO 145 ISA=1,NRRANN + NSPLIT=NSPLIT+ABS(ISPLIT(ISA)) + 145 CONTINUE + ILSTP=NSPLIT + RADL=RAD(NRRANN+1) + DO 155 ISA=NRRANN,1,-1 + RADN=RAD(ISA) + RAN(ILSTP)=RADL + MATANN(ILSTP)=MATANN(ISA) + IF(ISPLIT(ISA).LT.0) THEN +*---- +* ANNULUS EQUAL VOLUMES SPLIT +*---- + VFIN=RADL*RADL + DELV=(VFIN-RADN*RADN)/FLOAT(ABS(ISPLIT(ISA))) + DO 165 ISPL=ABS(ISPLIT(ISA))-1,1,-1 + ILSTP=ILSTP-1 + VFIN=VFIN-DELV + RAN(ILSTP)=SQRT(VFIN) + MATANN(ILSTP)=MATANN(ISA) + 165 CONTINUE + ELSE IF(ISPLIT(ISA).GT.0) THEN +*---- +* ANNULUS EQUAL TICKNESS SPLIT +*---- + VFIN=RADL + DELV=(VFIN-RADN)/FLOAT(ISPLIT(ISA)) + DO 175 ISPL=ISPLIT(ISA)-1,1,-1 + ILSTP=ILSTP-1 + VFIN=VFIN-DELV + RAN(ILSTP)=VFIN + MATANN(ILSTP)=MATANN(ISA) + 175 CONTINUE + ELSE + CALL XABORT(NAMSBR//': A SPLIT OF 0 IS INVALID') + ENDIF + RADL=RADN + ILSTP=ILSTP-1 + 155 CONTINUE + ELSE + DO 20 IAN=1,NRRANN + RAN(IAN)=RAD(IAN+1) + 20 CONTINUE + ENDIF + RADMIN=RAN(1) + NTAN=NBAN + IF(NSOUT.EQ.1.AND.IROT.GT.-400) THEN + VOLSUR(-1)=0.5*PI*RAN(NBAN) + ELSE IF(NSOUT.EQ.6.OR.IROT.LT.-600) THEN + CALL LCMGET(IPGEOM,'SIDE',RAN(NBAN)) + NTAN=NBAN-1 + IF(IROT.LT.0) THEN + VOLSUR(-1)=1.5*RAN(NBAN) + ELSE + VOLSUR(-1)=0.25*RAN(NBAN) + DO 30 ISURW=-2,-6,-1 + VOLSUR(ISURW)=VOLSUR(-1) + 30 CONTINUE + ENDIF + ELSE + CALL LCMGET(IPGEOM,'MESHX',RAD(1)) + CALL LCMGET(IPGEOM,'MESHY',RAD(3)) + RAN(NBAN)=RAD(2)-RAD(1) + COTE=RAD(4)-RAD(3) + NTAN=NBAN-1 + IF(IROT.LT.0) THEN + IF(RAN(NBAN).NE.COTE) CALL XABORT(NAMSBR// + > ': CARTESIAN SYMMETRY REQUIRES SQUARE CELL.') + VOLSUR(-1)=COTE + ELSE + VOLSUR(-1)=0.25*COTE + VOLSUR(-2)=0.25*RAN(NBAN) + VOLSUR(-3)=VOLSUR(-1) + VOLSUR(-4)=VOLSUR(-2) + ENDIF + ENDIF +*---- +* READ CLUSTER GEOMETRY AND ANALYSE +*---- + ALLOCATE(JGEOM(3*NRT)) + IPOS=1 + CALL LCMGET(IPGEOM,'CLUSTER',JGEOM) +*---- +* READ ROD DESCRIPTION AND SAVE +*---- + DO 120 IRT=1,NRT + WRITE(TEXT12(1:4),'(A4)') JGEOM(IPOS) + WRITE(TEXT12(5:8),'(A4)') JGEOM(IPOS+1) + WRITE(TEXT12(9:12),'(A4)') JGEOM(IPOS+2) + IPOS=IPOS+3 + CALL LCMSIX(IPGEOM,TEXT12,1) + ISTATE(:NSTATE)=0 + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) + CALL LCMGET(IPGEOM,'MIX',MATROD(1,IRT)) + CALL LCMLEN(IPGEOM,'RADIUS',NRODS(2,IRT),ITYPE) + CALL LCMGET(IPGEOM,'NPIN',NRODS(1,IRT)) + CALL LCMGET(IPGEOM,'RPIN',RODS(1,IRT)) + CALL LCMGET(IPGEOM,'APIN',RODS(2,IRT)) + NRODS(2,IRT)=NRODS(2,IRT)-1 + CALL LCMGET(IPGEOM,'RADIUS',RAD) + DO 121 IM=1,NRODS(2,IRT) + RODR(IM,IRT)=RAD(IM+1) + NMAT=MAX(NMAT,MATROD(IM,IRT)) + 121 CONTINUE + IF(ISTATE(11).EQ.1) THEN +*---- +* SPLIT RODS WHEN REQUIRED +*---- + CALL LCMLEN(IPGEOM,'SPLITR',ILONG,ITYPE) + IF(ILONG.GT.NBAN+1) CALL XABORT(NAMSBR//': SPLITR OVERFLOW') + CALL LCMGET(IPGEOM,'SPLITR',ISPLIT) + NSPLIT=0 + DO 140 ISR=1,NRODS(2,IRT) + NSPLIT=NSPLIT+ABS(ISPLIT(ISR)) + 140 CONTINUE + ILSTP=NSPLIT + RADL=RODR(NRODS(2,IRT),IRT) + DO 150 ISR=NRODS(2,IRT),1,-1 + IF(ISR.EQ.1) THEN + RADN=0.0 + ELSE + RADN=RODR(ISR-1,IRT) + ENDIF + IF(ISPLIT(ISR).LT.0) THEN +*---- +* RODS EQUAL VOLUMES SPLIT +*---- + RODR(ILSTP,IRT)=RADL + MATROD(ILSTP,IRT)=MATROD(ISR,IRT) + VFIN=RADL*RADL + DELV=(VFIN-RADN*RADN)/FLOAT(ABS(ISPLIT(ISR))) + DO 160 ISPL=ABS(ISPLIT(ISR))-1,1,-1 + ILSTP=ILSTP-1 + VFIN=VFIN-DELV + RODR(ILSTP,IRT)=SQRT(VFIN) + MATROD(ILSTP,IRT)=MATROD(ISR,IRT) + 160 CONTINUE + ELSE IF(ISPLIT(ISR).GT.0) THEN +*---- +* RODS EQUAL TICKNESS SPLIT +*---- + RODR(ILSTP,IRT)=RADL + MATROD(ILSTP,IRT)=MATROD(ISR,IRT) + VFIN=RADL + DELV=(VFIN-RADN)/FLOAT(ISPLIT(ISR)) + DO 170 ISPL=ISPLIT(ISR)-1,1,-1 + ILSTP=ILSTP-1 + VFIN=VFIN-DELV + RODR(ILSTP,IRT)=VFIN + MATROD(ILSTP,IRT)=MATROD(ISR,IRT) + 170 CONTINUE + ELSE + CALL XABORT(NAMSBR//': A SPLIT OF 0 IS INVALID') + ENDIF + RADL=RADN + ILSTP=ILSTP-1 + 150 CONTINUE + NRODS(2,IRT)=NSPLIT + ENDIF + RADMIN=MIN(RADMIN,RODR(1,IRT)) + CALL LCMSIX(IPGEOM,' ',2) + 120 CONTINUE +*---- +* CHECK ROD GEOMETRY AND REORDER IF NECESSARY +*---- + CALL XCGROD(NRT,MSROD,NRODS,RODS,MATROD,RODR) +*---- +* LOCALIZE ROD POSITION WITH RESPECT TO ANNULUS +*---- + IZRT=0 + DO 122 IRT=1,NRT + XTOP=RODS(1,IRT)+RODR(NRODS(2,IRT),IRT) + XBOT=RODS(1,IRT)-RODR(NRODS(2,IRT),IRT) + IF((XBOT.LT.0.0).AND.(NRODS(1,IRT).GT.1)) THEN + CALL XABORT(NAMSBR//': OVERLAPPING RODS') + ELSE IF(RODS(1,IRT).EQ.0.0) THEN + IF(RODR(NRODS(2,IRT),IRT).LE.RAN(1)) THEN + NRODS(3,IRT)=-1 + NXRS(IRT)=-1 + NXRI(IRT,1)=-1 + NRINFO(2,1)=-IRT + ELSE + CALL XABORT(NAMSBR//': CENTRAL ROD OVERLAPP WITH ANNULUS') + ENDIF + ELSE +*---- +* SEARCH IN ANNULUS SINCE RODS MAY NOT BE LOCATED IN +* SQUARE OR HEXAGONAL CROWN WHERE NTAN=NBAN-1 +*---- + JAN=0 + KRT=0 + DO 130 IAN=1,NTAN + JAN=IAN + IF(XBOT.LE.RAN(IAN)) THEN + NRODS(3,IRT)=IAN + NXRS(IRT)=IAN + NRINFO(2,IAN)=IRT + DO 134 JRT=1,NRT + KRT=JRT + IF(NXRI(KRT,IAN).EQ.0) THEN + NXRI(KRT,IAN)=IRT + IZRT=MAX(IZRT,KRT) + GO TO 131 + ENDIF + 134 CONTINUE + ENDIF + 130 CONTINUE + WRITE(CMSG,9001) NAMSBR,IRT + CALL XABORT(CMSG) + 131 CONTINUE + IF(XTOP.GT.RAN(JAN)) THEN + NXRI(KRT,IAN)=IRT+1000000 + DO 132 IAN=JAN+1,NTAN + IF(XTOP.LE.RAN(IAN)) THEN + NXRS(IRT)=IAN + NRINFO(2,IAN)=IRT + DO 135 JRT=1,NRT + KRT=JRT + IF(NXRI(KRT,IAN).EQ.0) THEN + NXRI(KRT,IAN)=IRT+3000000 + IZRT=MAX(IZRT,KRT) + GO TO 133 + ENDIF + 135 CONTINUE + ELSE + NXRS(IRT)=IAN + NRINFO(2,IAN)=IRT + DO 136 JRT=1,NRT + KRT=JRT + IF(NXRI(KRT,IAN).EQ.0) THEN + NXRI(KRT,IAN)=IRT+2000000 + IZRT=MAX(IZRT,KRT) + GO TO 137 + ENDIF + 136 CONTINUE + 137 CONTINUE + ENDIF + 132 CONTINUE + WRITE(CMSG,9001) NAMSBR,IRT + CALL XABORT(CMSG) + 133 CONTINUE + ENDIF + ENDIF +*---- +* GEOMETRY CANNOT BE TRACKED BY JPM +*--- + IF(IROT.GT.0.AND.IZRT.GT.1) CALL XABORT(NAMSBR// + > ': ROD OVERLAPP -- JPM CAN NOT TRACK THIS GEOMETRY') + 122 CONTINUE +*---- +* CHECK FOR VALID CLUSTER IN JPM TRACKING +*---- + IF(IROT.GT.0) THEN + DO 180 IAN=1,NTAN + ILR=NRINFO(2,IAN) + IF(ILR.GT.0) THEN + IF(NXRI(1,IAN).NE.ILR) CALL XABORT(NAMSBR// + > ': ANNULUS OVERLAP PIN -- JPM CAN NOT TRACK THIS GEOMETRY') + ENDIF + 180 CONTINUE + ENDIF + DEALLOCATE(JGEOM) + IF(IPRT.GT.2) THEN + WRITE(IOUT,6010) + DO 600 IAN=1,NTAN + IF((NRINFO(2,IAN).EQ.0).OR. + > (NRINFO(2,IAN).EQ.NXRI(1,IAN))) THEN + WRITE(IOUT,6013) IAN,NRINFO(2,IAN), + > RAN(IAN),MATANN(IAN) + ELSE + DO 601 IRT=1,NRT + IF(NXRI(IRT,IAN).EQ.0) GO TO 602 + WRITE(IOUT,6013) IAN,NXRI(IRT,IAN), + > RAN(IAN),MATANN(IAN) + 601 CONTINUE + ENDIF + 602 CONTINUE + 600 CONTINUE + IF(NSOUT.EQ.6.OR.IROT.LT.-600) THEN + WRITE(IOUT,6030) NBAN,NRINFO(2,NBAN),RAN(NBAN),MATANN(NBAN) + ELSE IF(NSOUT.EQ.4.OR.IROT.LT.-400) THEN + WRITE(IOUT,6040) NBAN,NRINFO(2,NBAN),RAN(NBAN), + > COTE,MATANN(NBAN) + ENDIF + WRITE(IOUT,6021) (4.0*VOLSUR(JSUR),JSUR=-1,-NSOUT,-1) + WRITE(IOUT,6022) (ICODE(-MATALB(JSUR)),JSUR=-1,-NSOUT,-1) + WRITE(IOUT,6023) (-JSW,ALBEDO(JSW),JSW=1,NMCOD) + WRITE(IOUT,6011) (IRT,NRODS(1,IRT),NRODS(2,IRT),NRODS(3,IRT), + > NXRS(IRT),RODS(1,IRT),RODS(2,IRT),IRT=1,NRT) + WRITE(IOUT,6012) ((IRT,ISR,RODR(ISR,IRT),MATROD(ISR,IRT), + > ISR=1,NRODS(2,IRT)),IRT=1,NRT) + ENDIF +*---- +* FILL IN VOLSUR AND MATALB VECTORS +*---- + VOLI=0.0 + IPOS=0 + VOLFS=0.0 + DO 200 IAN=1,NTAN + VOLROD=0.0 + VOLF=PI*RAN(IAN)*RAN(IAN) + IF(NRINFO(2,IAN).NE.0) THEN + IF(NRINFO(2,IAN).EQ.NXRI(1,IAN)) THEN + VOLIS=0.0 + IRT=ABS(NRINFO(2,IAN)) + XNROD=FLOAT(NRODS(1,IRT)) + DO 202 ISV=1,NRODS(2,IRT) + IPOS=IPOS+1 + VOLFS=PI*RODR(ISV,IRT)*RODR(ISV,IRT)*XNROD + VOLSUR(IPOS)=VOLFS-VOLIS + MATALB(IPOS)=MATROD(ISV,IRT) + VOLIS=VOLFS + 202 CONTINUE + NRODR(IRT)=IPOS + VOLROD=VOLROD+VOLFS + ELSE + DO 210 IRT=1,NRT + JRT=ABS(NXRI(IRT,IAN)) + IF(JRT.LT.1000000.AND.JRT.GT.0) THEN + XNROD=FLOAT(NRODS(1,JRT)) + VOLIS=0.0 + ILSTR=NRODS(2,JRT) + DO 211 ISV=1,ILSTR + IPOS=IPOS+1 + VOLFS=PI*RODR(ISV,JRT)*RODR(ISV,JRT)*XNROD + VOLSUR(IPOS)=(VOLFS-VOLIS) + MATALB(IPOS)=MATROD(ISV,JRT) + VOLIS=VOLFS + 211 CONTINUE + NRODR(JRT)=IPOS + VOLROD=VOLROD+VOLFS + ELSE IF(JRT.GT.0) THEN +*---- +* ANNULUS INTERSECT RODS +* 1) FIND X (XINT) AND Y (YINT) INTERSECTION +* XINT=(RAN**2+RPIN**2-RODR**2)/(2*RPIN) +* YINT=SQRT(RAN**2-XINT**2) +* 2) FIND OPENNING ANGLE FOR VOLUME LIMITED BY +* ANNULUS (ANGA) AND ROD (ANGR) +* ANGA=ACOS(XINT/RAN) +* ANGR=ACOS((XINT-RPIN)/RODR) +* 3) EVALUATE VOLUME +* VRDOUT=ANGR*RODR**2-YINT*(XINT-RPIN) +* VANIN=ANGA*RAN**2-YINT*XINT +* VRGOUT=VRDOUT-VANIN +* =ANGR*RODR**2-ANGA*RAN**2+YINT*RPIN +* VRGIN=PI*RODR*RODR-VRGOUT +*---- + JPRT=JRT/1000000 + JRT=MOD(JRT,1000000) + ILSTR=NRODS(2,JRT) + XNROD=FLOAT(NRODS(1,JRT)) + IF(JPRT.EQ.1) THEN + VANSPI=RAN(IAN)*RAN(IAN) + VRPSPI=RODS(1,JRT)*RODS(1,JRT) + VRDSPI=RODR(ILSTR,JRT)*RODR(ILSTR,JRT) + XINT=(VANSPI+VRPSPI-VRDSPI)/(2*RODS(1,JRT)) + YINT=SQRT(VANSPI-XINT*XINT) + ANGR=ACOS((XINT-RODS(1,JRT))/RODR(ILSTR,JRT)) + ANGA=ACOS(XINT/RAN(IAN)) + VRGIO(1,JRT)=(ANGR*VRDSPI-ANGA*VANSPI) + > +YINT*RODS(1,JRT) + VRGIO(2,JRT)=PI*VRDSPI-VRGIO(1,JRT) +*---- +* FIRST ANNULUS CROSSING ROD +* COMPUTE ROD VOLUME AND ROD REGION NUMBER +*---- + VOLIS=0.0 + DO 212 ISV=1,ILSTR + IPOS=IPOS+1 + VOLFS=PI*RODR(ISV,JRT)*RODR(ISV,JRT)*XNROD + VOLSUR(IPOS)=(VOLFS-VOLIS) + MATALB(IPOS)=MATROD(ISV,JRT) + VOLIS=VOLFS + 212 CONTINUE + NRODR(JRT)=IPOS + VOLROD=VOLROD+XNROD*VRGIO(2,JRT) + ELSE IF(JPRT.EQ.2) THEN +*---- +* ROD OVERLAPP THIS ANNULUS AND PRECEEDING ANNULUS +*---- + VANSPI=RAN(IAN)*RAN(IAN) + VRPSPI=RODS(1,JRT)*RODS(1,JRT) + VRDSPI=RODR(ILSTR,JRT)*RODR(ILSTR,JRT) + XINT=(VANSPI+VRPSPI-VRDSPI)/(2*RODS(1,JRT)) + YINT=SQRT(VANSPI-XINT*XINT) + ANGR=ACOS((XINT-RODS(1,JRT))/RODR(ILSTR,JRT)) + ANGA=ACOS(XINT/RAN(IAN)) + VRGOU1=ANGR*VRDSPI-ANGA*VANSPI + > +YINT*RODS(1,JRT) + VRGIN1=PI*VRDSPI-VRGOU1 + VOLROD=VOLROD+XNROD*(VRGIN1-VRGIO(2,JRT)) + VRGIO(1,JRT)=VRGOU1 + VRGIO(2,JRT)=VRGIN1 + ELSE +*---- +* LAST ANNULUS CROSSING ROD +*---- + VOLROD=VOLROD+XNROD*VRGIO(1,JRT) + ENDIF + ENDIF + 210 CONTINUE + ENDIF + ENDIF + IPOS=IPOS+1 + VOLSUR(IPOS)=VOLF-VOLI-VOLROD + MATALB(IPOS)=MATANN(IAN) + NRINFO(1,IAN)=IPOS + VOLI=VOLF + 200 CONTINUE +*---- +* FINAL REGION ANALYSIS FOR RECTANGLE AND HEXAGONE +*---- + IF(NSOUT.EQ.6.OR.IROT.LT.-600) THEN + IPOS=IPOS+1 + MATALB(IPOS)=MATANN(NBAN) + NRINFO(1,NBAN)=IPOS + VOLF=THSQ3*RAN(NBAN)*RAN(NBAN) + VOLSUR(IPOS)=VOLF-VOLI + ELSE IF(NSOUT.EQ.4.OR.IROT.LT.-400) THEN + IPOS=IPOS+1 + MATALB(IPOS)=MATANN(NBAN) + NRINFO(1,NBAN)=IPOS + VOLF=RAN(NBAN)*COTE + VOLSUR(IPOS)=VOLF-VOLI + ENDIF +*---- +* PRINT GEOMETRY INFORMATION IF REQUIRED +*---- + IF(IPRT.GT.0) THEN + CALL LCMINF(IPGEOM,GEONAM,TEXT12,EMPTY,ILONG,LCM) + IF(NSOUT.EQ.6.OR.IROT.LT.-600) THEN + WRITE(IOUT,'(/31H 2-D HEXAGONAL CLUSTER GEOMETRY, + > 21H BASED ON GEOMETRY : ,A12,1H./)') GEONAM + ELSE IF(NSOUT.EQ.4.OR.IROT.LT.-400) THEN + WRITE(IOUT,'(/28H 2-D SQUARE CLUSTER GEOMETRY, + > 21H BASED ON GEOMETRY : ,A12,1H./)') GEONAM + ELSE + WRITE(IOUT,'(/33H 2-D CYLINDRICAL CLUSTER GEOMETRY, + > 21H BASED ON GEOMETRY : ,A12,1H./)') GEONAM + ENDIF + IF (.NOT.ILK) WRITE(IOUT,'(17H INFINITE DOMAIN.)') + ENDIF +*---- +* PRINT REGION VOLUME AND MATERIAL INFORMATION WHEN REQUIRED +*---- + IF(IPRT.GT.2) THEN + WRITE(IOUT,6000) + IREG=0 + DO 610 IAN=1,NTAN + IREG=IREG+1 + IF(NRINFO(2,IAN).EQ.0) THEN + WRITE(IOUT,6001) IAN,IREG,MATALB(IREG),VOLSUR(IREG) + ELSE + IF(NRINFO(2,IAN).EQ.NXRI(1,IAN)) THEN + IRT=ABS(NRINFO(2,IAN)) + IF(IRT.LT.2000000) THEN + LRT=MOD(IRT,1000000) + DO 612 ISV=1,NRODS(2,LRT) + WRITE(IOUT,6002) ISV,IREG, + > MATALB(IREG),VOLSUR(IREG) + IREG=IREG+1 + 612 CONTINUE + ENDIF + ELSE + DO 613 JRT=1,NRT + KRT=ABS(NXRI(JRT,IAN)) + IF((KRT.LT.2000000).AND.(KRT.GE.1)) THEN + LRT=MOD(KRT,1000000) + DO 614 ISV=1,NRODS(2,LRT) + WRITE(IOUT,6002) ISV,IREG, + > MATALB(IREG),VOLSUR(IREG) + IREG=IREG+1 + 614 CONTINUE + ENDIF + 613 CONTINUE + ENDIF + WRITE(IOUT,6001) IAN,IREG,MATALB(IREG),VOLSUR(IREG) + ENDIF + 610 CONTINUE +*---- +* LAST REGION FOR SQUARE AND HEXAGONES +*---- + IF(NSOUT.EQ.6.OR.IROT.LT.-600) THEN + IREG=IREG+1 + WRITE(IOUT,6001) IAN,IREG,MATALB(IREG),VOLSUR(IREG) + ELSE IF(NSOUT.EQ.4.OR.IROT.LT.-400) THEN + IREG=IREG+1 + WRITE(IOUT,6001) IAN,IREG,MATALB(IREG),VOLSUR(IREG) + ENDIF + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(VRGIO,RAD) + DEALLOCATE(ISPLIT,MATROD,MATANN) + RETURN +*---- +* GEOMETRY DESCRIPTION FORMATS +*---- + 6000 FORMAT(//1X,'CLUSTER GEOMETRICAL DESCRIPTION.'/ + >1X,'ANN',2X,'ROD',2X,'REG',9X,'MATERIAL',7X,'VOLUME') + 6001 FORMAT(1X,I3,6X,I4,3X,I10,1P,5X,E15.7) + 6002 FORMAT(5X,I4,1X,I4,3X,I10,1P,5X,E15.7) + 6010 FORMAT(1X,'ANNULAR REGIONS DESCRIPTION'/ + >4X,'ANNULUS',5X,'ROD ARRAY',8X,'OUTER RADIUS',6X,'MIXTURE') + 6011 FORMAT(1X,'ROD CLUSTER DESCRIPTION'/ + >2X,'ROD ARRAY',5X,'NRODS',5X,'NSUBR',7X,'AND',7X,'ANF',8X, + >'PITCH RADIUS',5X,'FIRST ROD ANGLE'/ + >(1X,5I10,5X,E15.7,5X,E15.7)) + 6012 FORMAT(1X,'SUBROD DESCRIPTION'/ + >8X,'IRT',7X,'ISR',8X,'OUTER RADIUS',6X,'MIXTURE',1P/ + >(1X,2I10,5X,E15.7,1X,I10)) + 6013 FORMAT(1P,(1X,I10,4X,I10,5X,E15.7,1X,I10)) + 6021 FORMAT(1X,'OUTER SURFACE DESCRIPTION'/1P,6(5X,E15.7)) + 6022 FORMAT(1X,'OUTER SURFACE ICODES '/1P,6(5X,I10,5X)) + 6023 FORMAT(1X,'GEOMETRICAL ALBEDOS '/1P,6(2X,I3,E15.7)) + 6040 FORMAT(1X,'RECTANGULAR REGION DESCRIPTION'/ + >2X,'RECTANGLE',5X,'ROD ARRAY', + >8X,'X SIDE WIDTH',8X,'Y SIDE WIDTH',8X,'MIXTURE',1P/ + >(1X,I10,4X,I10,5X,E15.7,5X,E15.7,5X,I10)) + 6030 FORMAT(1X,'HEXAGONAL REGIONS DESCRIPTION'/ + >3X,'HEXAHONE',5X,'ROD ARRAY', + >10X,'SIDE WIDTH',8X,'MIXTURE',1P/ + >(1X,I10,4X,I10,5X,E15.7,5X,I10)) +*---- +* ERROR MESSAGE FORMAT +*---- + 9001 FORMAT(A6,': ROD TYPE ',I10,5X,'NOT INSIDE CLUSTER') + END diff --git a/Dragon/src/XCGROD.f b/Dragon/src/XCGROD.f new file mode 100644 index 0000000..8ee931a --- /dev/null +++ b/Dragon/src/XCGROD.f @@ -0,0 +1,234 @@ +*DECK XCGROD + SUBROUTINE XCGROD(NRT,MSROD,NRODS,RODS,MATROD,RODR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Check geometry and reorder rod clusters if necessary. +* +*Copyright: +* Copyright (C) 1994 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* NRT number of rod types. +* MSROD maximum number of subrods per rods. +* +*Parameters: input/output +* NRODS integer description of rod of a given type: +* NRODS(1,IRT) = number of rod; +* NRODS(2,IRT) = number of subrods in rod; +* NRODS(3,IRT) = first concentric region. +* RODS real description of rod of a given type: +* RODS(1,IRT) = rod center radius; +* RODS(2,IRT) = angular position of first rod. +* MATROD type of material for each subrod. +* RODR subrod radius. +* +*---------------------------------------------------------------------- +* + INTEGER IOUT + REAL PI + PARAMETER (IOUT=6,PI=3.1415926535898) + INTEGER NRT,NRODS(3,NRT),MATROD(MSROD,NRT) + REAL RODS(2,NRT),RODR(MSROD,NRT) + INTEGER, ALLOCATABLE, DIMENSION(:) :: IORD +*---- +* SCRATCH STORAGE ALLOCATION +* IORD : NEW ROD CLUSTER ORDER I(NRT) +*---- + ALLOCATE(IORD(NRT)) +*---- +* CLASSIFY ROD CLUSTER BY INCREASING DISTANCE OF CENTER AND ANGLE +*---- + DO 100 IRT=1,NRT + IORD(IRT)=IRT + 100 CONTINUE + DO 110 IRT=2,NRT + REFR=RODS(1,IRT) + REFA=RODS(2,IRT) + IPOS=IORD(IRT) + DO 111 JRT=IRT-1,1,-1 + KRT=JRT + IF(RODS(1,JRT).GT.REFR) THEN + RODS(1,JRT+1)=RODS(1,JRT) + RODS(2,JRT+1)=RODS(2,JRT) + IORD(JRT+1)=IORD(JRT) + ELSE IF(RODS(1,JRT).EQ.REFR) THEN + IPOS=-IPOS + GO TO 112 + ELSE + GO TO 112 + ENDIF + 111 CONTINUE + KRT=0 + 112 CONTINUE + RODS(1,KRT+1)=REFR + RODS(2,KRT+1)=REFA + IORD(KRT+1)=IPOS + IF(IPOS.LT.0) THEN + DO 113 JRT=KRT,1,-1 + LRT=JRT + IF((RODS(2,JRT).GT.REFA).AND. + > (RODS(1,JRT).EQ.REFR)) THEN + RODS(1,JRT+1)=RODS(1,JRT) + RODS(2,JRT+1)=RODS(2,JRT) + IORD(JRT+1)=IORD(JRT) + ELSE + GO TO 114 + ENDIF + 113 CONTINUE + LRT=0 + 114 CONTINUE + RODS(1,LRT+1)=REFR + RODS(2,LRT+1)=REFA + IORD(LRT+1)=-IPOS + ENDIF + 110 CONTINUE +*---- +* REORDER REMAINING VECTORS NRODS,MATROD,RODR +*---- + DO 140 IRT=1,NRT + JRT=IORD(IRT) + IF(JRT.NE.IRT) THEN + DO 141 IX=1,3 + NNR=NRODS(IX,IRT) + NRODS(IX,IRT)=NRODS(IX,JRT) + NRODS(IX,JRT)=NNR + 141 CONTINUE + DO 142 IS=1,MSROD + MATT=MATROD(IS,IRT) + MATROD(IS,IRT)=MATROD(IS,JRT) + MATROD(IS,JRT)=MATT + RROD=RODR(IS,IRT) + RODR(IS,IRT)=RODR(IS,JRT) + RODR(IS,JRT)=RROD + 142 CONTINUE + DO 143 KRT=IRT+1,NRT + IF(IORD(KRT).EQ.IRT) THEN + IORD(KRT)=JRT + IORD(IRT)=IRT + GO TO 144 + ENDIF + 143 CONTINUE + 144 CONTINUE + ENDIF + 140 CONTINUE +*---- +* FIND IF ROD OVERLAPP +*---- + DO 150 IRT=1,NRT + NRDB=NRODS(1,IRT) + NSBRB=NRODS(2,IRT) + RODRB=RODR(NSBRB,IRT) + RODRB2=RODRB*RODRB + RDPB=RODS(1,IRT) + XBOT=RDPB-RODRB + DANGB=2.*PI/FLOAT(NRDB) + ANGB=RODS(2,IRT) +*---- +* CHECK FOR ROD OVERLAPP INSIDE EACH CLUSTER +*---- + IF(NRDB.GT.1) THEN + IF(RODRB.GT.RDPB) THEN + WRITE(IOUT,'(1X,24HROD OVERLAP IN CLUSTER =,I10)') IRT + CALL XABORT('XCGROD: ROD OVERLAP IN A CLUSTER') + ELSE + ANGMIN=2.*ASIN(RODRB/RDPB) + IF(DANGB.LE.ANGMIN) THEN + WRITE(IOUT,'(1X,24HROD OVERLAP IN CLUSTER =,I10)') IRT + CALL XABORT('XCGROD: ROD OVERLAP IN A CLUSTER') + ENDIF + ENDIF + ENDIF +*---- +* CHECK FOR ROD OVERLAPP BETWEEN DIFFERENT CLUSTERS +*---- + DO 151 JRT=IRT-1,1,-1 + NRDT=NRODS(1,JRT) + NSBRT=NRODS(2,JRT) + RODRT=RODR(NSBRT,JRT) + RODRT2=RODRT*RODRT + RDPT=RODS(1,JRT) + XTOP=RDPT+RODRT + DANGT=2.*PI/FLOAT(NRDT) + ANGT=RODS(2,JRT) +*---- +* NO OVERLAPP +*---- + IF(XTOP.LT.XBOT) GO TO 152 +*---- +* SOME OVERLAPP POSSIBLE TEST FOR INTERSECTION +*---- + ANG1=ANGB + DO 160 IA1=1,NRDB +*---- +* FIND POSITION OF ROD (X0,Y0) +*---- + X01=RDPB*COS(ANG1) + Y01=RDPB*SIN(ANG1) + RRX=RODRB2-X01*X01 + RRY=RODRB2-Y01*Y01 + XY=X01*Y01 + RR1=(RRX-Y01*Y01) + ANG2=ANGT + DO 161 IA2=1,NRDT + X02=RDPT*COS(ANG2) + Y02=RDPT*SIN(ANG2) + RR2=(RODRT2-X02*X02-Y02*Y02) +*---- +* CHECK FOR ROD INSIDE ROD +*---- + DELX=X02-X01 + DELY=Y02-Y01 + DIST=SQRT(DELX**2+DELY**2) + IF(DIST.LT.RODRT+RODRB) THEN + WRITE(IOUT,'(1X,25HROD OVERLAP IN CLUSTERS =,2I10)') + > IRT,JRT + CALL XABORT('XCGROD: ROD OVERLAP IN 2 CLUSTERS') + ENDIF +*---- +* FIND IF CIRCLES +* (X-X01)**2+(Y-Y01)**2=RODRB*2 +* (X-X02)**2+(Y-Y02)**2=RODRT*2 +* INTERSECT +*---- + IF(X02.NE.X01) THEN + CCR=1./DELX + BBR=-DELY*CCR + AAR=0.5*CCR*(RR1-RR2) + ARGSQ=AAR*(2.*X01-2.*BBR*Y01-AAR) + > +BBR*(BBR*RRY+2.*XY)+RRX + ELSE + CCR=1./DELY + BBR=-DELX*CCR + AAR=0.5*CCR*(RR1-RR2) + ARGSQ=AAR*(2.*Y01-2.*BBR*X01-AAR) + > +BBR*(BBR*RRX+2.*XY)+RRY + ENDIF + IF(ARGSQ.GE.0.0) THEN + WRITE(IOUT,'(1X,25HROD OVERLAP IN CLUSTERS =,2I10)') + > IRT,JRT + CALL XABORT('XCGROD: ROD OVERLAP IN 2 CLUSTERS') + ENDIF + ANG2=ANG2+DANGT + 161 CONTINUE + ANG1=ANG1+DANGB + 160 CONTINUE + 151 CONTINUE + 152 CONTINUE + 150 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IORD) +*---- +* RETURN +*---- + RETURN + END diff --git a/Dragon/src/XCWHEX.f b/Dragon/src/XCWHEX.f new file mode 100644 index 0000000..25572ec --- /dev/null +++ b/Dragon/src/XCWHEX.f @@ -0,0 +1,229 @@ +*DECK XCWHEX + SUBROUTINE XCWHEX(ANGD,RADC,SIDE,LINTER,XPOS,INDS,IMS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Track outer hexagone for 2-D cluster geometry. +* +*Copyright: +* Copyright (C) 1991 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G.Marleau +* +*Parameters: input +* ANGD track angle. +* RADC Y-position of track > 0. +* SIDE side of hexagone. +* IMS surface merge. +* +*Parameters: output +* LINTER intersection logical. +* XPOS points of intersection. +* INDS surface of intersection. +* +*Comments: +* Equations for sides of hexagone YR(XR) +* SIDE 1: YR=-SQ3*XR+SQ3*SIDE ( 0 <=YR<= SQ3*SIDE/2) +* ( SIDE/2 <=XR<= SIDE ) +* SIDE 2: YR= SQ3*SIDE/2 ( -SIDE/2 <=XR<= SIDE/2 ) +* SIDE 3: YR= SQ3*XR+SQ3*SIDE ( 0 <=YR<= SQ3*SIDE/2) +* ( -SIDE <=XR<= -SIDE/2 ) +* SIDE 4: YR=-SQ3*XR-SQ3*SIDE (-SQ3*SIDE/2 <=YR<= 0 ) +* ( -SIDE <=XR<= -SIDE/2 ) +* SIDE 5: YR=-SQ3*SIDE/2 ( -SIDE/2 <=XR<= SIDE/2 ) +* SIDE 6: YR= SQ3*XR-SQ3*SIDE (-SQ3*SIDE/2 <=YR<= 0 ) +* ( SIDE/2 <=XR<= SIDE ) +* Equations for sides of hexagone XR(YR) +* SIDE 1: XR=-OSQ3*YR+SIDE ( 0 <=YR<= SQ3*SIDE/2) +* ( SIDE/2 <=XR<= SIDE ) +* SIDE 3: XR= OSQ3*YR-SIDE ( 0 <=YR<= SQ3*SIDE/2) +* ( -SIDE <=XR<= -SIDE/2 ) +* SIDE 4: XR=-OSQ3*YR-SIDE (-SQ3*SIDE/2 <=YR<= 0 ) +* ( -SIDE <=XR<= -SIDE/2 ) +* SIDE 6: XR= OSQ3*YR+SIDE (-SQ3*SIDE/2 <=YR<= 0 ) +* ( SIDE/2 <=XR<= SIDE ) +* TRACK EQUATION: +* YR= SQ3*(SLOPEY*XR+RINTY) +* OR XR= OSQ3*SLOPEX*YR-RINTX +* +*---------------------------------------------------------------------- +* + PARAMETER (SQ3=1.73205080756887729,OSQ3=0.577350269189625795) + INTEGER IMS(6),INDS(2) + LOGICAL LINTER + REAL ANGD,RADC,SIDE,XPOS(2) +*---- + YRINT=SQ3*SIDE + YLIM=0.5*YRINT + XLIM=0.5*SIDE + SINA=SIN(ANGD) + COSA=COS(ANGD) + LINTER=.FALSE. + IF(COSA.EQ.0.0) THEN +*---- +* TRACK PARALLEL TO Y +*---- + IF( RADC.LT. XLIM ) THEN +*---- +* TRACK INTERCEPT SURFACE 5 AND 2 +*---- + IF(SINA.LT.0.0) THEN + INDS(2)=IMS(5) + INDS(1)=IMS(2) + ELSE + INDS(2)=IMS(2) + INDS(1)=IMS(5) + ENDIF + XPOS(2)=YLIM + XPOS(1)=-XPOS(2) + LINTER=.TRUE. + ELSE IF(RADC.LE.SIDE) THEN +*---- +* TRACK INTERCEPT SURFACE 3 AND 4 OR 6 AND 1 +*---- + IF(SINA.LT.0.0) THEN + INDS(2)=IMS(3) + INDS(1)=IMS(4) + ELSE + INDS(2)=IMS(6) + INDS(1)=IMS(1) + ENDIF + XPOS(2)=YRINT-SQ3*RADC + XPOS(1)=-XPOS(2) + LINTER=.TRUE. + ENDIF + ELSE IF(SINA.EQ.0.0) THEN +*---- +* TRACK PARALLEL TO X +*---- + IF(RADC.LE.YLIM ) THEN +*---- +* TRACK INTERCEPT SURFACE 6 AND 4 +*---- + INDS(2)=IMS(4) + INDS(1)=IMS(6) + XPOS(2)= OSQ3*RADC+SIDE + XPOS(1)=-XPOS(2) + LINTER=.TRUE. + ENDIF + ELSE + NSEG=0 + COSAI=1.0/COSA + SINAI=1.0/SINA + SLOPEY=OSQ3*SINA*COSAI + SLOPEX=SQ3*COSA*SINAI + RINTY=OSQ3*RADC*COSAI + RINTX=RADC*SINAI + XREF=RADC*COSAI*SINA + OPSY=1.0/(1+SLOPEY) + OMSY=1.0/(1-SLOPEY) + XLSX=SLOPEX*XLIM + SPRY=SIDE+RINTY + SMRY=SIDE-RINTY +*---- +* SURFACE 1: XR=(SIDE-RINTY)/(1+SLOPEY) +* (SIDE/2 <=XR<= SIDE) +*---- + XR=SMRY*OPSY + IF( (XLIM.LE.XR) .AND. (XR.LE.SIDE) ) THEN +*---- +* TRACK INTERSEPT SURFACE 1 +*---- + NSEG=NSEG+1 + INDS(NSEG)=IMS(1) + XPOS(NSEG)=XR + ENDIF +*---- +* SURFACE 2: XR= SLOPEX*SIDE/2-RINTX +* (-SIDE/2 <=XR<= SIDE/2) +*---- + XR=XLSX-RINTX + IF( ABS(XR).LE.XLIM ) THEN +*---- +* TRACK INTERSEPT SURFACE 2 +*---- + NSEG=NSEG+1 + INDS(NSEG)=IMS(2) + XPOS(NSEG)=XR + IF(NSEG.EQ.2) GO TO 100 + ENDIF +*---- +* SURFACE 3: XR=-(SIDE-RINTY)/(1-SLOPEY) +* (-SIDE <=XR<= -SIDE/2) +*---- + XR=-SMRY*OMSY + IF( (-SIDE.LE.XR) .AND. (XR.LE.-XLIM) )THEN +*---- +* TRACK INTERSEPT SURFACE 3 +*---- + NSEG=NSEG+1 + INDS(NSEG)=IMS(3) + XPOS(NSEG)=XR + IF(NSEG.EQ.2) GO TO 100 + ENDIF +*---- +* SURFACE 4: XR=-(SIDE+RINTY)/(1+SLOPEY) +* (-SIDE <=XR<= -SIDE/2) +*---- + XR=-SPRY*OPSY + IF( (-SIDE.LE.XR) .AND. (XR.LE.-XLIM) ) THEN +*---- +* TRACK INTERSEPT SURFACE 4 +*---- + NSEG=NSEG+1 + INDS(NSEG)=IMS(4) + XPOS(NSEG)=XR + IF(NSEG.EQ.2) GO TO 100 + ENDIF +*---- +* SURFACE 5: XR=-SLOPEX*SIDE/2-RINTX +* (-SIDE/2 <=XR<= SIDE/2) +*---- + XR=-XLSX-RINTX + IF( ABS(XR).LE.XLIM ) THEN +*---- +* TRACK INTERSEPT SURFACE 5 +*---- + NSEG=NSEG+1 + INDS(NSEG)=IMS(5) + XPOS(NSEG)=XR + IF(NSEG.EQ.2) GO TO 100 + ENDIF +*---- +* SURFACE 6: XR=(RINTY+SIDE)/(1-SLOPEY) +* (SIDE/2 <=XR<= SIDE) +*---- + XR=SPRY*OMSY + IF( (XLIM.LE.XR) .AND. (XR.LE.SIDE) ) THEN +*---- +* TRACK INTERSEPT SURFACE 6 +*---- + NSEG=NSEG+1 + INDS(NSEG)=IMS(6) + XPOS(NSEG)=XR + ENDIF + 100 CONTINUE + IF(NSEG.EQ.2) THEN + LINTER=.TRUE. +*---- +* ROTATE HEXAGONE BY -ANGD +*---- + XPOS(1)=XREF+XPOS(1)*COSAI + XPOS(2)=XREF+XPOS(2)*COSAI + IF( XPOS(1).GT.XPOS(2) ) THEN + INDT=INDS(2) + INDS(2)=INDS(1) + INDS(1)=INDT + XPOST=XPOS(2) + XPOS(2)=XPOS(1) + XPOS(1)=XPOST + ENDIF + ENDIF + ENDIF + RETURN + END diff --git a/Dragon/src/XCWICL.f b/Dragon/src/XCWICL.f new file mode 100644 index 0000000..a894e27 --- /dev/null +++ b/Dragon/src/XCWICL.f @@ -0,0 +1,347 @@ +*DECK XCWICL + SUBROUTINE XCWICL( NDIM, NSURX, NVOL, NBAN, NRT, MSROD, + > MAROD, NANGL, DENS, ISYMM,IFTEMP, IPRT, + > NRINFO, RAN, COTE, NRODS, RODS, NRODR, + > RODR, MXSEG, NXRI, IMS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform isotropic tracking for 2-d cluster geometry. +* +*Copyright: +* Copyright (C) 1994 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G.Marleau +* +*Parameters: input +* NDIM dimension of problem. +* NSURX number of initial outer surfaces. +* NVOL total number of regions. +* NBAN number of concentric regions. +* NRT number of rod types. +* MSROD maximum number of subrod per rods. +* MAROD maximum number of rod in any cluster. +* NANGL number of integration angles. +* DENS minimum parallel line trak density. +* ISYMM integration symmetry factor. +* IFTEMP temporary tracking file unit. +* IPRT print level. +* NRINFO type of concentric region: +* NRINFO(1,IAN) = new region number; +* NRINFO(2,IAN) = associated cluster; +* = 0 no cluster. +* RAN radius/lattice side of region. +* COTE y dimension for rectangle. +* NRODS integer description of rod type: +* NRODS(1,IRT) = number of rod; +* NRODS(2,IRT) = number of subrods in rod; +* NRODS(3,IRT) = associated annulus. +* RODS description of rod of a given type: +* RODS(1,IRT) = rod center radius; +* RODS(2,IRT) = angle position of one rod. +* NRODR subrod region. +* RODR subrod radius. +* MXSEG current maximum track length. +* NXRI annular region content multi-rod. +* IMS surface merge. +* +*---------------------------------------------------------------------- +* + PARAMETER (IUNOUT=6,PI=3.1415926535897932,SQ3=1.7320508075688773) + INTEGER NDIM,NSURX,NVOL,NBAN,NRT,MSROD,MAROD,NANGL, + > ISYMM,IFTEMP,IPRT,NXRI(NRT,NBAN),NRINFO(2,NBAN), + > NRODS(3,NRT),NRODR(NRT),MXSEG,INDS(2),IMS(6) + LOGICAL LINTER + REAL DENS,RAN(NBAN),COTE,RODS(2,NRT),RODR(MSROD,NRT), + > XPOS(2) + DOUBLE PRECISION DCSA(2),SIDE(2),TRKPOS(2,2),ROTPOS(2,2), + > DRADC,WEIGHT +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NRSEG,NNSEG + REAL, ALLOCATABLE, DIMENSION(:) :: ATOP + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DENSTY,SEGLEN + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: ANGLES + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: RODP +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NRSEG(MXSEG),NNSEG(MXSEG)) + ALLOCATE(ANGLES(NDIM,NANGL),DENSTY(NANGL),SEGLEN(MXSEG), + > RODP(2,MAROD,NRT),ATOP(NRT)) +* + IF(IPRT.GE.1) THEN + WRITE(IUNOUT,'(//1X,A20)') 'ISOTROPIC TRACKING ' + ENDIF +*---- +* DETERMINE INTEGRATION LIMITS FOR CLUSTER REGIONS +*---- + IF(NSURX.EQ.6) THEN + RADEQ=RAN(NBAN) + NTAN=NBAN-1 + ELSE IF(NSURX.EQ.4) THEN + SIDE(1)=DBLE(RAN(NBAN)) + SIDE(2)=DBLE(COTE) + RADEQ=0.5*SQRT(RAN(NBAN)*RAN(NBAN)+COTE*COTE) + NTAN=NBAN-1 + ELSE + RADEQ=RAN(NBAN) + NTAN=NBAN + ENDIF + IF(ISYMM.GT.1) THEN + DANGI=4.0*PI/FLOAT(NANGL*ISYMM) + ELSE + DANGI=2.0*PI/FLOAT(NANGL) + ENDIF + NPLINE=INT(RADEQ*DENS+1.0) + NPLINE=NPLINE+MOD(NPLINE+1,2) + DRADI=RADEQ/FLOAT(NPLINE) + IF(IPRT.GT.0) THEN + WRITE(IUNOUT,6010) NVOL,NSURX,NBAN,NRT + WRITE(IUNOUT,6011) + WRITE(IUNOUT,6012) (II,NRODS(1,II),NRODS(2,II), + > NRODS(3,II),II=1,NRT) + WRITE(IUNOUT,6000) NANGL,DENS,NPLINE,1.0/DRADI,ISYMM + ENDIF + ANGD=-0.5*DANGI + RADD=-0.5*DRADI + WEIGHT=DRADI/DBLE(NANGL) + DO 5 IANGL=1,NANGL + ANGXX=ANGD+DANGI*FLOAT(IANGL) + ANGLES(1,IANGL)=COS(ANGXX) + ANGLES(2,IANGL)=SIN(ANGXX) + DENSTY(IANGL)=REAL(2*NANGL) + 5 CONTINUE + WRITE(IFTEMP) ((ANGLES(II,JJ),II=1,NDIM),JJ=1,NANGL) + WRITE(IFTEMP) (DENSTY(JJ),JJ=1,NANGL) +*---- +* NUMBER OF RODS BETWEEN ORIGIN AND ROD 1 +*---- + DO 90 IRT=1,NRT + IF(NRODS(3,IRT).GT.0) THEN + NBROD=NRODS(2,IRT) + DANGR=2.*PI/FLOAT(NRODS(1,IRT)) + IF(RODR(NBROD,IRT).GT.RODS(1,IRT)) THEN + ATOP(IRT)=0.0 + ELSE + ATOP(IRT)=(RODS(2,IRT) + > +ASIN(RODR(NBROD,IRT)/RODS(1,IRT)))/DANGR + ENDIF + ENDIF + 90 CONTINUE +*---- +* SWEEP THROUGH TRACK ANGLES +*---- + DO 100 IANG=1,NANGL + ANGD=ANGD+DANGI + DCSA(1)=COS(DBLE(ANGD)) + DCSA(2)=SIN(DBLE(ANGD)) +*---- +* LOCALIZE RODS WITH RESPECT TO TRAKING ANGLE +* RODP(1,IRD,IRT)= X POSITION OF CENTER +* RODP(2,IRD,IRT)= Y POSITION OF CENTER +*---- + DO 110 IRT=1,NRT + IF(NRODS(3,IRT).GT.0) THEN + DANGR=2.*PI/FLOAT(NRODS(1,IRT)) +*---- +* NUMBER OF RODS BETWEEN FIRST ROD AND Y=0 TRACK +*---- + ANGC=(ANGD/DANGR)-ATOP(IRT) + IF(ANGC.GT.0.0) THEN + IRDEP=INT(ANGC+0.9999) + ELSE + IRDEP=INT(ANGC) + ENDIF + ANGC=RODS(2,IRT)-ANGD+IRDEP*DANGR +*---- +* STORE POSITION OF NRODS+1 RODS STARTING WITH FIRST +* ROD ABOVE OR ON Y=0 TRACK +*---- + DO 120 IRD=1,NRODS(1,IRT) + RODP(1,IRD,IRT)=RODS(1,IRT)*COS(ANGC) + RODP(2,IRD,IRT)=RODS(1,IRT)*SIN(ANGC) + ANGC=ANGC+DANGR + 120 CONTINUE + ENDIF + 110 CONTINUE + RADC=RADD + DO 130 IRAD=1,NPLINE +*---- +* INITIALIZE REGION POSITION VECTOR +*---- + DO 135 ISEG=1,MXSEG + NRSEG(ISEG)=0 + NNSEG(ISEG)=0 + 135 CONTINUE + RADC=RADC+DRADI + RADC2=RADC*RADC + DRADC=DBLE(RADC) + NLSEG=MXSEG + NFSEG=0 + NRIN=0 + IF(NSURX.EQ.6) THEN + CALL XCWHEX(ANGD,RADC,RAN(NBAN),LINTER,XPOS,INDS,IMS) + ELSE IF(NSURX.EQ.4) THEN + TRKPOS(1,1)=-DRADC*DCSA(2) + TRKPOS(2,1)=DRADC*DCSA(1) + CALL XCWREC(DCSA,SIDE,TRKPOS,LINTER,ROTPOS,INDS,IMS) + XPOS(1)=REAL(ROTPOS(1,1)) + XPOS(2)=REAL(ROTPOS(1,2)) + ELSE + LINTER=.FALSE. + INDS(1)=1 + INDS(2)=1 + ENDIF + IF(LINTER) THEN + NRSEG(NLSEG)=NRIN + NNSEG(NFSEG+1)=NRIN + SEGLEN(NLSEG)=XPOS(2) + NLSEG=NLSEG-1 + NRIN=NRINFO(1,NBAN) + NFSEG=NFSEG+1 + NRSEG(NFSEG)=NRIN + NNSEG(NLSEG+1)=NRIN + SEGLEN(NFSEG)=XPOS(1) + ENDIF +*---- +* TRACK INSIDE ANNULAR REGIONS +*---- + DO 140 IAN=NTAN,1,-1 + IF(RADC.GT.RAN(IAN)) GO TO 141 +*---- +* LINE INTERSECT ANNULUS IAN +*---- + XPOS(2)=SQRT(RAN(IAN)*RAN(IAN)-RADC2) + XPOS(1)=-XPOS(2) + NRSEG(NLSEG)=NRIN + NNSEG(NFSEG+1)=NRIN + SEGLEN(NLSEG)=XPOS(2) + NLSEG=NLSEG-1 + NRIN=NRINFO(1,IAN) + NFSEG=NFSEG+1 + NRSEG(NFSEG)=NRIN + NNSEG(NLSEG+1)=NRIN + SEGLEN(NFSEG)=XPOS(1) + IF(NRINFO(2,IAN).NE.0) THEN +*---- +* TRACK INSIDE RODS +*---- + DO 146 KRT=1,NRT + JRT=NXRI(KRT,IAN) + IF((JRT.GT.3000000).OR. + > ((JRT.GT.0).AND.(JRT.LT.1000000)) ) THEN + LRT=MOD(JRT,1000000) + CALL XCWROD(NRIN,NRODS(1,LRT),NRODR(LRT), + > RODR(1,LRT),RODP(1,1,LRT),DRADC, + > NFSEG,NLSEG,SEGLEN,NRSEG,NNSEG) + ELSE IF(JRT.EQ.0) THEN + GO TO 147 + ENDIF + 146 CONTINUE + 147 CONTINUE + DO 143 KRT=1,NRT + JRT=NXRI(KRT,IAN) + IF(JRT.LT.0) THEN + IRT=-JRT + NXTR=NRODR(IRT) + DO 144 IRD=NRODS(2,IRT),1,-1 + IF(RADC.GT.RODR(IRD,IRT)) GO TO 141 +*---- +* LINE INTERSECT CENTERED ROD IRD +*---- + XPOS(2)=SQRT(RODR(IRD,IRT)*RODR(IRD,IRT)-RADC2) + XPOS(1)=-XPOS(2) + NRSEG(NLSEG)=NRIN + NNSEG(NFSEG+1)=NRIN + SEGLEN(NLSEG)=XPOS(2) + NLSEG=NLSEG-1 + NRIN=NXTR + NXTR=NXTR-1 + NFSEG=NFSEG+1 + NRSEG(NFSEG)=NRIN + NNSEG(NLSEG+1)=NRIN + SEGLEN(NFSEG)=XPOS(1) + 144 CONTINUE + GO TO 141 + ENDIF + 143 CONTINUE + ENDIF + 140 CONTINUE + 141 CONTINUE +*---- +* COMPRESS AND SORT TRACK VECTOR +*---- + IF(IPRT.GE.20) THEN + WRITE(IUNOUT,6020) IANG,ANGD,IRAD,RADC + ENDIF + CALL XCWSRT(IPRT,MXSEG,SEGLEN,NRSEG,NNSEG,NTSEG) + NSEG=NTSEG + IF(IPRT.GE.20) THEN + WRITE(IUNOUT,6002) NSEG,-INDS(1),-INDS(2) + WRITE(IUNOUT,6021) (SEGLEN(IIJJ),NRSEG(IIJJ),IIJJ=1,NSEG+1) + ENDIF +*---- +* CONVERT SEGMENT DIVISION TO SEGMENT LENGTH +*---- + DO 160 ISEG=1,NSEG + SEGLEN(ISEG)=SEGLEN(ISEG+1)-SEGLEN(ISEG) + 160 CONTINUE + IF(NSEG+2.GT.MXSEG) THEN + WRITE(IUNOUT,6023) NSEG,MXSEG + WRITE(IUNOUT,6021) (SEGLEN(IIJJ),NRSEG(IIJJ),IIJJ=1,NSEG) + CALL XABORT('XCWICL: NUMBER OF SEGMENT GREATER THAN'// + > ' MAXUMUM ALLOWED') + ENDIF + IF(NSEG.GT.0) THEN + WRITE(IFTEMP) 1,NSEG+2,WEIGHT,IANG, + > -INDS(1),(NRSEG(JSEG),JSEG=1,NSEG),-INDS(2), + > 1.0D0,(SEGLEN(JSEG),JSEG=1,NSEG),1.0D0 + ENDIF + IF(IPRT.GE.30) THEN + WRITE(IUNOUT,6022) NSEG,-INDS(1),-INDS(2) + WRITE(IUNOUT,6021) (SEGLEN(IIJJ),NRSEG(IIJJ),IIJJ=1,NSEG) + ENDIF + 130 CONTINUE + 100 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(ATOP,RODP,SEGLEN,DENSTY,ANGLES) + DEALLOCATE(NNSEG,NRSEG) + RETURN +*---- +* FORMATS +*---- + 6000 FORMAT(1X,'INTEGRATION PARAMETERS',/ + > 1X,' NUMBER OF ANGLES =',I10,/ + > 1X,' MINIMUM TRACK DENSITY =',1P,E15.7,/ + > 1X,'NUMBER OF PARALLEL LINES =',I10,/ + > 1X,'EFFECTIVE TRACK DENSITY =',1P,E15.7,/ + > 1X,' SYMMETRY FACTOR =',I10) + 6002 FORMAT(' FINAL TRACK POSITION WITH NUMBER OF SEGMENTS = ',I10/ + > ' FIRST SURFACE INTERSECTED = ',I10,5X, + > ' LAST SURFACE INTERSECTED = ',I10) + 6010 FORMAT(1X,' TOTAL NUMBER OF REGIONS =',I10/ + > 1X,' NUMBER OF INITIAL SURFACES =',I10/ + > 1X,' NUMBER OF ANNULAR REGIONS =',I10/ + > 1X,' NUMBER OF RODS TYPES =',I10) + 6011 FORMAT(1X,' ROD TYPE',10X,' NB. RODS',10X, + > 'NB. SUBROD',10X,'IN ANNULUS') + 6012 FORMAT((1X,I10,10X,I10,10X,I10,10X,I10)) + 6020 FORMAT(//1X,' TRACKING INFORMATION'/ + > 1X,' ANGD(',I5,')=',F15.7/ + > 1X,' RADC(',I5,')=',F15.7/ + > 1X,' INTERSECTION AND REGION FOLLOWING') + 6021 FORMAT(4(5X,F15.7,I10)) + 6022 FORMAT(' FINAL TRACKING LENGTH WITH NUMBER OF SEGMENTS = ',I10/ + > ' FIRST SURFACE INTERSECTED = ',I10,4X, + > ' LAST SURFACE INTERSECTED = ',I10) + 6023 FORMAT(1X,' NUMBER OF SEGMENTS ',I10,5X,'ALLOWED =',I10) + END diff --git a/Dragon/src/XCWREC.f b/Dragon/src/XCWREC.f new file mode 100644 index 0000000..8a949ee --- /dev/null +++ b/Dragon/src/XCWREC.f @@ -0,0 +1,229 @@ +*DECK XCWREC + SUBROUTINE XCWREC(ANGD,SIDE,TRKPOS,LINTER,ROTPOS,INDS,IMS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Track outer rectangle for 2-D cluster. +* +*Copyright: +* Copyright (C) 1992 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G.Marleau +* +*Parameters: input +* ANGD track director cosines (cos(a),sin(a)). +* SIDE side of rectangle. +* IMS surface merge. +* +*Parameters: input/output +* TRKPOS one track point at input (*,1). +* Track origin at output (*,1). +* Track origin at input (*,2). +* +*Parameters: output +* LINTER intersection logical. +* ROTPOS position wrt rotated axis. +* INDS surface of intersection. +* +*---------------------------------------------------------------------- +* + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DOUBLE PRECISION ANGD(2),SIDE(2),TRKPOS(2,2),ROTPOS(2,2) + INTEGER IMS(6),INDS(2) + LOGICAL LINTER +*---- +* EQUATIONS FOR SIDES +* SIDE 1: XR= SIDE(1)/2 (-SIDE(2)/2<=YR<=SIDE(2)/2) +* SIDE 2: YR= SIDE(2)/2 (-SIDE(1)/2<=XR<=SIDE(1)/2) +* SIDE 3: XR=-SIDE(1)/2 (-SIDE(2)/2<=YR<=SIDE(2)/2) +* SIDE 4: YR=-SIDE(2)/2 (-SIDE(1)/2<=XR<=SIDE(1)/2) +* TRACK EQUATION +* YR= TAN(ANGD)*(XR-TRKPOS(1,1))+TRKPOS(2,1) +* OR XR=COTAN(ANGD)*(YR-TRKPOS(2,1))+TRKPOS(1,1) +*---- + YTOP=0.5D0*SIDE(2) + XTOP=0.5D0*SIDE(1) + LINTER=.FALSE. + IF(ANGD(1).EQ.0.0D0) THEN +*---- +* TRACK PARALLEL TO Y +* TRACK INTERCEPT SURFACE 4 AND 2 +*---- + IF(ABS(TRKPOS(1,1)).LT.XTOP) THEN + TRKPOS(1,2)=TRKPOS(1,1) + IF(ANGD(2).LT.0.0) THEN + INDS(2)=IMS(4) + INDS(1)=IMS(2) + TRKPOS(2,2)=-YTOP + TRKPOS(2,1)=YTOP + ELSE + INDS(2)=IMS(2) + INDS(1)=IMS(4) + TRKPOS(2,2)=YTOP + TRKPOS(2,1)=-YTOP + ENDIF + LINTER=.TRUE. + ENDIF + ELSE IF(ANGD(2).EQ.0.0D0) THEN +*---- +* TRACK PARALLEL TO X +* TRACK INTERCEPT SURFACE 3 AND 1 +*---- + IF(ABS(TRKPOS(2,1)).LT.YTOP) THEN + TRKPOS(2,2)=TRKPOS(2,1) + IF(ANGD(1).LT.0.0D0) THEN + INDS(2)=IMS(3) + INDS(1)=IMS(1) + TRKPOS(1,2)=-XTOP + TRKPOS(1,1)=XTOP + ELSE + INDS(2)=IMS(1) + INDS(1)=IMS(3) + TRKPOS(1,2)=XTOP + TRKPOS(1,1)=-XTOP + ENDIF + LINTER=.TRUE. + ENDIF + ELSE + NSEG=1 + COSAI=1.0/ANGD(1) + SINAI=1.0/ANGD(2) +*---- +* SLOPEY=TAN(ANGD) +* SLOPEX=COTAN(ANGD) +* RINTY=TRKPOS(2,1)-SLOPEY*TRKPOS(1,1) +* RINTX=TRKPOS(1,1)-SOLPEX*TRKPOS(2,1) +*---- + SLOPEY=ANGD(2)*COSAI + SLOPEX=ANGD(1)*SINAI + RINTY=TRKPOS(2,1)-SLOPEY*TRKPOS(1,1) + RINTX=TRKPOS(1,1)-SLOPEX*TRKPOS(2,1) +*---- +* SURFACE 3: YR=RINTY-SLOPEY*XTOP +* (-YTOP <=YR<= YTOP) +*---- + TRKPOS(2,NSEG)=RINTY-SLOPEY*XTOP + IF( ABS(TRKPOS(2,NSEG)).LE.YTOP ) THEN +*---- +* TRACK INTERSEPT SURFACE 3 +*---- + INDS(NSEG)=IMS(3) + TRKPOS(1,NSEG)=-XTOP + NSEG=NSEG+1 + ENDIF +*---- +* SURFACE 1: YR=RINTY+SLOPEY*XTOP +* (-YTOP <=YR<= YTOP) +*---- + TRKPOS(2,NSEG)=RINTY+SLOPEY*XTOP + IF( ABS(TRKPOS(2,NSEG)).LE.YTOP ) THEN +*---- +* TRACK INTERSEPT SURFACE 1 +*---- + INDS(NSEG)=IMS(1) + TRKPOS(1,NSEG)=XTOP + IF(NSEG.EQ.2) GO TO 100 + NSEG=NSEG+1 + ENDIF +*---- +* SURFACE 4: XR=RINTX-SLOPEX*YTOP +* (-XTOP <=XR<= XTOP) +*---- + TRKPOS(1,NSEG)=RINTX-SLOPEX*YTOP + IF( ABS(TRKPOS(1,NSEG)).LE.XTOP ) THEN +*---- +* TRACK INTERSEPT SURFACE 4 +*---- + INDS(NSEG)=IMS(4) + TRKPOS(2,NSEG)=-YTOP + IF(NSEG.EQ.2) GO TO 100 + NSEG=NSEG+1 + ENDIF +*---- +* SURFACE 2: XR=RINTX+SLOPEX*YTOP +* (-XTOP <=XR<= XTOP) +*---- + TRKPOS(1,NSEG)=RINTX+SLOPEX*YTOP + IF( ABS(TRKPOS(1,NSEG)).LE.XTOP ) THEN +*---- +* TRACK INTERSEPT SURFACE 2 +*---- + INDS(NSEG)=IMS(2) + TRKPOS(2,NSEG)=YTOP + IF(NSEG.EQ.2) GO TO 100 + NSEG=NSEG+1 + ENDIF + 100 CONTINUE + IF(NSEG.EQ.2) THEN + LINTER=.TRUE. +*---- +* REORDER INTERSECTION POINTS FOR DIRECTION +*---- + IF(ANGD(1).LT.0.0D0) THEN + IF(TRKPOS(1,1).GT.TRKPOS(1,2)) THEN + TRKTMP=TRKPOS(1,2) + TRKPOS(1,2)=TRKPOS(1,1) + TRKPOS(1,1)=TRKTMP + TRKTMP=TRKPOS(2,2) + TRKPOS(2,2)=TRKPOS(2,1) + TRKPOS(2,1)=TRKTMP + INDT=INDS(2) + INDS(2)=INDS(1) + INDS(1)=INDT + ENDIF + ELSE + IF(TRKPOS(1,1).GT.TRKPOS(1,2)) THEN + TRKTMP=TRKPOS(1,2) + TRKPOS(1,2)=TRKPOS(1,1) + TRKPOS(1,1)=TRKTMP + TRKTMP=TRKPOS(2,2) + TRKPOS(2,2)=TRKPOS(2,1) + TRKPOS(2,1)=TRKTMP + INDT=INDS(2) + INDS(2)=INDS(1) + INDS(1)=INDT + ENDIF + ENDIF + IF(ANGD(2).LT.0.0D0) THEN + IF(TRKPOS(2,2).GT.TRKPOS(2,1)) THEN + TRKTMP=TRKPOS(1,2) + TRKPOS(1,2)=TRKPOS(1,1) + TRKPOS(1,1)=TRKTMP + TRKTMP=TRKPOS(2,2) + TRKPOS(2,2)=TRKPOS(2,1) + TRKPOS(2,1)=TRKTMP + INDT=INDS(2) + INDS(2)=INDS(1) + INDS(1)=INDT + ENDIF + ELSE + IF(TRKPOS(2,1).GT.TRKPOS(2,2)) THEN + TRKTMP=TRKPOS(1,2) + TRKPOS(1,2)=TRKPOS(1,1) + TRKPOS(1,1)=TRKTMP + TRKTMP=TRKPOS(2,2) + TRKPOS(2,2)=TRKPOS(2,1) + TRKPOS(2,1)=TRKTMP + INDT=INDS(2) + INDS(2)=INDS(1) + INDS(1)=INDT + ENDIF + ENDIF + ENDIF + ENDIF +*---- +* ROTATE RECTANGLE BY ANGD +*---- + IF(LINTER) THEN + DO 110 II=1,2 + ROTPOS(1,II)=ANGD(1)*TRKPOS(1,II)+ANGD(2)*TRKPOS(2,II) + ROTPOS(2,II)=-ANGD(2)*TRKPOS(1,II)+ANGD(1)*TRKPOS(2,II) + 110 CONTINUE + ENDIF + RETURN + END diff --git a/Dragon/src/XCWROD.f b/Dragon/src/XCWROD.f new file mode 100644 index 0000000..258e725 --- /dev/null +++ b/Dragon/src/XCWROD.f @@ -0,0 +1,195 @@ +*DECK XCWROD + SUBROUTINE XCWROD(NRIN,NRODS,NRODR,RODR,RODP,RADC,NFSEG,NLSEG, + > SEGLEN,NRSEG,NNSEG) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform rod tracking for 2-D cluster geometry. +* +*Copyright: +* Copyright (C) 1992 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G.Marleau +* +*Parameters: input +* NRIN current region number. +* NRODS integer description of rod type: +* NRODS(1) = number of rod; +* NRODS(2) = number of subrods in rod. +* NRODR subrod region. +* RODR subrod radius. +* RODP rod position: +* RODP(1,IRD) = X-position; +* RODP(2,IRD) = Y-position. +* RADC Y-position of track. +* +*Parameters: output +* NFSEG initial segment position. +* NLSEG final segment position. +* SEGLEN length of track. +* NRSEG region crossed by track. +* NNSEG region crossed by track (left). +* +*---------------------------------------------------------------------- +* + INTEGER NRIN,NRODS(2),NRODR,NFSEG,NLSEG,NRSEG(*),NNSEG(*) + REAL RODR(*),RODP(2,*) + DOUBLE PRECISION SEGLEN(*),RADC,RADR,RADR2 +*---- +* FILL IN SEGLEN FROM THE END STARTING WITH ROD FURTHER FROM +* TRACK STARTING POINT UNTIL CENTER OF TRACK REACHED +*---- + NPROD=(NRODS(1)+3)/2 + NSBR=NRODS(2) + IF(RADC.GE.0.0D0) THEN + IPDEB=1 + IPFIN=NPROD + IPSTP=1 + IMDEB=NPROD + IMFIN=1 + IMSTP=-1 + ELSE + RADR=RODP(2,1)-RADC + IF(ABS(RADR).LT.RODR(NSBR)) THEN + IPDEB=NRODS(1)+1 + IPFIN=MAX(2,NRODS(1)+1-NPROD) + ELSE + IPDEB=NRODS(1) + IPFIN=MAX(1,NRODS(1)-NPROD) + ENDIF + IPSTP=-1 + IMDEB=IPFIN + IMFIN=IPDEB + IMSTP=1 + ENDIF + NXSEG=NLSEG + DO 100 IRZ=IPDEB,IPFIN,IPSTP + IF(IRZ.EQ.NRODS(1)+1) THEN + IRD=1 + ELSE + IRD=IRZ + ENDIF + RADR=RODP(2,IRD)-RADC + RADR2=RADR*RADR + NREG=NRIN + IF( ABS(RADR).LT.RODR(NSBR) ) THEN +*---- +* ROD INTERCEPS +*---- + XTRA=SQRT(RODR(NSBR)*RODR(NSBR)-REAL(RADR2)) + XLST=RODP(1,IRD)+XTRA + XFST=RODP(1,IRD)-XTRA + IF(XLST.LT.0.0) THEN +*---- +* CENTER OF TRACK REACHED/EXIT +*---- + GO TO 1000 + ELSE +*---- +* SET POINTERS TO SEGLEN VECTOR W.R.T. LAST POSITION FREE +*---- + NFLSEG=NXSEG-2*NSBR + NLLSEG=NXSEG + NXSEG=NFLSEG + ENDIF + SEGLEN(NLLSEG)=XLST + NRSEG(NLLSEG)=NREG + NNSEG(NFLSEG+1)=-NREG + NLLSEG=NLLSEG-1 + NREG=NRODR + NFLSEG=NFLSEG+1 + SEGLEN(NFLSEG)=XFST + NRSEG(NFLSEG)=NREG + NNSEG(NLLSEG+1)=-NREG + DO 110 ISBR=NSBR-1,1,-1 + IF( ABS(RADR).LT.RODR(ISBR) ) THEN +*---- +* SUBROD INTERCEPS +*---- + XTRA=SQRT(RODR(ISBR)*RODR(ISBR)-REAL(RADR2)) + SEGLEN(NLLSEG)=RODP(1,IRD)+XTRA + NRSEG(NLLSEG)=NREG + NNSEG(NFLSEG+1)=-NREG + NLLSEG=NLLSEG-1 + NREG=NREG-1 + NFLSEG=NFLSEG+1 + SEGLEN(NFLSEG)=RODP(1,IRD)-XTRA + NRSEG(NFLSEG)=NREG + NNSEG(NLLSEG+1)=-NREG + ENDIF + 110 CONTINUE + ENDIF + 100 CONTINUE + 1000 CONTINUE + NLSEG=NXSEG +*---- +* FILL IN SEGLEN FROM THE BEGINNING STARTING WITH ROD CLOSEST FROM +* TRACK STARTING POINT UNTIL CENTER OF TRACK REACHED +*---- + NXSEG=NFSEG + DO 200 IRZ=IMDEB,IMFIN,IMSTP + IF(IRZ.EQ.NRODS(1)+1) THEN + IRD=1 + ELSE + IRD=IRZ + ENDIF + RADR=RODP(2,IRD)-RADC + RADR2=RADR*RADR + NREG=NRIN + IF( ABS(RADR).LT.RODR(NSBR) ) THEN +*---- +* ROD INTERCEPS +*---- + XTRA=SQRT(RODR(NSBR)*RODR(NSBR)-REAL(RADR2)) + XLST=RODP(1,IRD)+XTRA + XFST=RODP(1,IRD)-XTRA + IF(XLST.LT.0.0) THEN +*---- +* SET POINTERS TO SEGLEN VECTOR W.R.T. FIRST POSITION FREE +*---- + NLLSEG=NXSEG+2*NSBR + NFLSEG=NXSEG + NXSEG=NLLSEG + ELSE +*---- +* CENTER OF TRACK REACHED/EXIT +*---- + GO TO 2000 + ENDIF + SEGLEN(NLLSEG)=XLST + NRSEG(NLLSEG)=NREG + NNSEG(NFLSEG+1)=-NREG + NLLSEG=NLLSEG-1 + NREG=NRODR + NFLSEG=NFLSEG+1 + SEGLEN(NFLSEG)=XFST + NRSEG(NFLSEG)=NREG + NNSEG(NLLSEG+1)=-NREG + DO 210 ISBR=NSBR-1,1,-1 + IF( ABS(RADR).LT.RODR(ISBR) ) THEN +*---- +* SUBROD INTERCEPS +*---- + XTRA=SQRT(RODR(ISBR)*RODR(ISBR)-REAL(RADR2)) + SEGLEN(NLLSEG)=RODP(1,IRD)+XTRA + NRSEG(NLLSEG)=NREG + NNSEG(NFLSEG+1)=-NREG + NLLSEG=NLLSEG-1 + NREG=NREG-1 + NFLSEG=NFLSEG+1 + SEGLEN(NFLSEG)=RODP(1,IRD)-XTRA + NRSEG(NFLSEG)=NREG + NNSEG(NLLSEG+1)=-NREG + ENDIF + 210 CONTINUE + ENDIF + 200 CONTINUE + 2000 CONTINUE + NFSEG=NXSEG + RETURN + END diff --git a/Dragon/src/XCWSCL.f b/Dragon/src/XCWSCL.f new file mode 100644 index 0000000..888bfaf --- /dev/null +++ b/Dragon/src/XCWSCL.f @@ -0,0 +1,580 @@ +*DECK XCWSCL + SUBROUTINE XCWSCL( NDIM, NSURX, NVOL, NBAN, NRT, MSROD, + > MAROD, NANGL, DENS,IFTEMP, IPRT, NCODE, + > SWZERO,NRINFO, RAN, COTE, NRODS, RODS, + > NRODR, RODR, MXSUB, MXSEG, NXRI, IMS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform specular tracking for 2-D square cluster. +* +*Copyright: +* Copyright (C) 1990 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G.Marleau +* +*Parameters: input +* NDIM dimension of problem. +* NSURX number of initial surface. +* NVOL total number of regions. +* NBAN number of concentric regions. +* NRT number of rod types. +* MSROD maximum number of subrod per rods. +* MAROD maximum number of rod in any cluster. +* NANGL number of integration angles. +* DENS minimum parallel line trak density. +* IFTEMP temporary tracking file unit. +* SWZERO logical for specular tracking. +* IPRT print level. +* NCODE boundary type. +* NRINFO type of concentric region: +* NRINFO(1,IAN) = new region number; +* NRINFO(2,IAN) = associated cluster; +* = 0 no cluster. +* RAN radius/lattice side of region. +* COTE Y dimension for rectangle. +* NRODS integer description of rod type: +* NRODS(1,IRT) = number of rod; +* NRODS(2,IRT) = number of subrods in rod; +* NRODS(3,IRT) = associated region. +* RODS description of rod of a given type: +* RODS(1,IRT) = rod center radius; +* RODS(2,IRT) = angle position of one rod. +* NRODR subrod region. +* RODR subrod radius. +* MXSUB current maximum number of subtracks. +* MXSEG current maximum track length. +* NXRI annular region content multi-rod. +* IMS surface merge. +* +*---------------------------------------------------------------------- +* + PARAMETER (IUNOUT=6,PI=3.1415926535897932,EPS=1.E-5) + CHARACTER TEDATA*13 + INTEGER NDIM,NSURX,NVOL,NBAN,NRT,MSROD,MAROD,NANGL, + > IFTEMP,IPRT,NCODE(6),NRINFO(2,NBAN), + > NRODS(3,NRT),NRODR(NRT),MXSUB,MXSEG, + > INDS(2),NXRI(NRT,NBAN),IMS(6),IPER(2) + LOGICAL LINTER,LNEWP,SWZERO + REAL DENS,RAN(NBAN),COTE,RODS(2,NRT),RODR(MSROD,NRT) + DOUBLE PRECISION DFACX,DFACY,SIDE(2),RCIRC,DENSP,DENLIN, + > PROJ,PMAX,PMIN,DEPART,TRKPOS(2,2),ROTPOS(2,2), + > TRKBEG(2,2),DIRBEG(2),RONEPS,ANGD,ANGC,RADC, + > RADC2,WEIGHT,XPO +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NRSEG,NNSEG,KANGL + REAL, ALLOCATABLE, DIMENSION(:) :: ATOP + REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: RODP + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SEGLEN,WGTANG, + > DNSANG,PTSANG + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: DANGLE +*---- +* SCRATCH STORAGE ALLOCATION +* NRSEG : region crossed by track +* NNSEG : region crossed by track (left) +* SEGLEN: length of track +* RODP : rod position in cartesian geometry +* ATOP : number of rod between origin and rod1 +* DANGLE: integration angles +* WGTANG: integration weight +* DNSANG: integration densities +* PTSANG: principal integration angles +*---- + ALLOCATE(NRSEG(MXSEG),NNSEG(MXSEG),KANGL(MXSUB)) + ALLOCATE(SEGLEN(MXSEG),RODP(2,MAROD,NRT,2),ATOP(NRT)) + ALLOCATE(DANGLE(NDIM,2,4*NANGL),WGTANG(4*NANGL),DNSANG(NANGL), + > PTSANG(NANGL)) +*---- +* DETERMINE INTEGRATION LIMITS FOR CLUSTER REGIONS +*---- + IF(IPRT.GE.1) THEN + WRITE(IUNOUT,'(//1X,A20)') 'SPECULAR TRACKING ' + ENDIF + MLSEG=MXSEG/(2*NANGL) + SIDE(1)=DBLE(RAN(NBAN)) + SIDE(2)=DBLE(COTE) + IF( ABS((SIDE(1)-SIDE(2))/ABS(1)).GT.10.*EPS )THEN + CALL XABORT('XCWSCL: AVAILABLE ONLY FOR SQUARE GEOMETRIES') + ENDIF + RCIRC=SQRT(SIDE(1)**2+SIDE(2)**2) + SIDE(1)= SIDE(1)/RCIRC + SIDE(2)= SIDE(2)/RCIRC + NTAN=NBAN-1 + IF(IPRT.GT.0) THEN + WRITE(IUNOUT,6000) NVOL,NSURX,NBAN,NRT + WRITE(IUNOUT,6001) + WRITE(IUNOUT,6002) (II,NRODS(1,II),NRODS(2,II), + > NRODS(3,II),II=1,NRT) + WRITE(IUNOUT,6003) NANGL,DENS + ENDIF +*---- +* SET FLAG FOR SURFACE CROSSING +* IPER(1) = X-PERIOD +* IPER(2) = Y-PERIOD +* VALUES ARE +* IPER(I) = 1 FOR PERIODIC BC +* IPER(I) = 2 FOR OTHER BC +*---- + IPER(1)=2 + IPER(2)=2 + IF( (NCODE(1) .EQ. 4) .AND. (NCODE(2) .EQ. 4) ) THEN + IPER(1)=1 + ENDIF + IF( (NCODE(3) .EQ. 4) .AND. (NCODE(4) .EQ. 4) ) THEN + IPER(2)=1 + ENDIF + IPERG=MIN(IPER(1),IPER(2)) + IF( SWZERO )THEN + IFIN= NANGL-1 + IDEB= 0 + ISTRID=1 + ELSE + IFIN= 2*NANGL + IDEB= 0 + ISTRID=2 + ENDIF + IANG=0 + DO 100 ITX= IDEB, IFIN, ISTRID + INDS(1)= ITX + ITY=IFIN-ITX + INDS(2)=ITY + IANG= IANG+1 + ITYPBC= 0 ! Cartesian boundary + CALL XELTSA( NDIM, ITYPBC, SIDE, INDS, DENSP, DANGLE(1,1,IANG)) +*---- +* CHANGE DENLIN FOR HORIZONTAL & VERTICAL ANGLES +*---- + IF( (ITX .EQ. 0) .OR. (ITY .EQ. 0) )THEN + DNSANG(IANG)=DBLE(DENS) + ELSE + DENLIN= DENSP / RCIRC + NTRAC=MAX(1,INT(DBLE(DENS)/DENLIN+0.5D0)) + DNSANG(IANG)= DBLE(NTRAC) * DENLIN + ENDIF +*---- +* COMPUTE NTRAK AND CHANGE DENS ACCORDING TO INPUT +*---- + PTSANG(IANG)= DANGLE(1,1,IANG) + 100 CONTINUE + CALL XELTSW(SIDE,NANGL,PTSANG,WGTANG) + IF( IPRT.GT.2 )THEN + DO 110 IANG= 1, NANGL + WRITE(IUNOUT,6004) IANG, DANGLE(1,1,IANG),WGTANG(IANG), + > DNSANG(IANG),WGTANG(IANG)/DNSANG(IANG) + 110 CONTINUE + ENDIF +*---- +* LOCALIZE CENTER OF REFERENCE ROD WITH RESPECT TO X-Y AXIS +*---- + DO 120 IRT=1,NRT + IF(NRODS(3,IRT).GT.0) THEN + NBROD=NRODS(2,IRT) + DANGR=2.*PI/FLOAT(NRODS(1,IRT)) + IF(RODR(NBROD,IRT).GT.RODS(1,IRT)) THEN + ATOP(IRT)=0.0 + ELSE + ATOP(IRT)=(RODS(2,IRT) + > +ASIN(RODR(NBROD,IRT)/RODS(1,IRT)))/DANGR + ENDIF + ENDIF + 120 CONTINUE + SIDE(1)=DBLE(RAN(NBAN)) + SIDE(2)=DBLE(COTE) +*---- +* COPY ANGLES AND DENSITIES ON TEMPORARY TRACKING FILE +*---- + DO 125 IANG=1,NANGL + DANGLE(1,1,2*NANGL-IANG+1)=-DANGLE(1,1,IANG) + DANGLE(2,1,2*NANGL-IANG+1)=DANGLE(2,1,IANG) + WGTANG(2*NANGL-IANG+1)=WGTANG(IANG) + 125 CONTINUE + DO 126 IANG=1,2*NANGL + DANGLE(1,1,4*NANGL-IANG+1)=DANGLE(1,1,IANG) + DANGLE(2,1,4*NANGL-IANG+1)=-DANGLE(2,1,IANG) + WGTANG(4*NANGL-IANG+1)=WGTANG(IANG) + 126 CONTINUE + WRITE(IFTEMP) ((DANGLE(IDIM,1,IANG),IDIM=1,NDIM),IANG=1,4*NANGL) + WRITE(IFTEMP) (2.0D0/WGTANG(IANG),IANG=1,4*NANGL) +*---- +* PRINT TRACKING INFORMATION IF REQUIRED +*---- + NSOLMX=0 + IF((IPRT.GT.1).AND.(IPRT.LT.100))THEN + WRITE(IUNOUT,'(/8H0ECHO = ,I3,27H SOLID ANGLES TO BE TRACKED)') + > NANGL + NSOLMX= MIN(9, NANGL/10) + IREF1=0 + WRITE(IUNOUT,'(1X,10(I1,9X))') (IREF1, IZZ=0,NSOLMX) + WRITE(IUNOUT,'(1X,10(I1,9X))') (MOD(IZZ,10), IZZ=0,NSOLMX) + WRITE(IUNOUT,'(2H 0)') + TEDATA='(1H+,TXXX,I1)' + ENDIF + NOTRAK= 0 +*---- +* ANGULAR TRACK SWEEP +*---- + IXYN=0 + IXYR=0 + N0LSEG=0 + DO 130 IANG=1,NANGL + DENLIN = DNSANG(IANG) + DENSP = 1.D0 / DENLIN +*---- +* PRINT TRACKING INFORMATION IF REQUIRED +*---- + IF((IPRT.GT.1).AND.(IPRT.LT.100))THEN + IF( MOD(IANG,100) .EQ. 0 )THEN + IREF1=IREF1+1 + NDEBS= NSOLMX+1 + NSOLMX=MIN(NDEBS+9, NANGL/10) + WRITE(IUNOUT,'(1X,10(I1,9X))')(IREF1,IZZ=NDEBS,NSOLMX) + WRITE(IUNOUT,'(1X,10(I1,9X))') + > (MOD(IZZ,10),IZZ=NDEBS,NSOLMX) + WRITE(IUNOUT,'(2H 0)') + ELSE + WRITE(TEDATA(7:9),'(I3.3)') MOD(IANG,100) + 2 + WRITE(IUNOUT,TEDATA) MOD(IANG,10) + ENDIF + ENDIF +*---- +* LOCALIZE ROD POSITIONS WITH RESPECT TO 2 DIFFERENT ANGLES +* POSSIBLE (+-COS(THETA),SIN(THETA)) +*---- + ANGD=ATAN2(DANGLE(2,1,IANG),DANGLE(1,1,IANG)) + DO 300 IA=1,2 + DO 310 IRT=1,NRT + IF(NRODS(3,IRT).GT.0) THEN + DANGR=2.*PI/FLOAT(NRODS(1,IRT)) + ANGC=(ANGD/DANGR)-ATOP(IRT) + IF(ANGC.GT.0.0) THEN + IRDEP=INT(ANGC+0.9999) + ELSE + IRDEP=INT(ANGC) + ENDIF + ANGC=RODS(2,IRT)-ANGD+IRDEP*DANGR + DO 320 IRD=1,NRODS(1,IRT) + RODP(1,IRD,IRT,IA)=RODS(1,IRT)*REAL(COS(ANGC)) + RODP(2,IRD,IRT,IA)=RODS(1,IRT)*REAL(SIN(ANGC)) + ANGC=ANGC+DANGR + 320 CONTINUE + ENDIF + 310 CONTINUE + ANGD=PI-ANGD + 300 CONTINUE +*---- +* PROJECT THE 4 CORNERS OF SQUARE LOCATED AT +* -SIDE(1)/2 < X < SIDE(1)/2 AND -SIDE(2)/2 < Y < SIDE(2)/2 +* ON LINE NORMAL TO TRACK DIRECTION +*---- + PMIN = +1.0D+50 + PMAX = -1.0D+50 + DFACX=1.0D0 + DO 150 IX=1,2 + DFACY=1.0D0 + DO 160 IY=1,2 + PROJ = (SIDE(1)*DFACX*DANGLE(1,2,IANG) + > + SIDE(2)*DFACY*DANGLE(2,2,IANG))/2.0 + IF( PROJ.LT.PMIN ) PMIN = PROJ + IF( PROJ.GT.PMAX ) PMAX = PROJ + DFACY=-1.0D0*DFACY + 160 CONTINUE + DFACX=-1.0D0*DFACX + 150 CONTINUE +*---- +* FIND NUMBER OF PARALLEL TRACK: NEAREST INTEGER +1 FOR SECURITY +*---- + NPOINT =NINT((PMAX-PMIN)*DENLIN)+1 + DEPART =0.5D0*(PMAX+PMIN-DBLE(NPOINT)*DENSP) + DO 170 J = 1, 2 + TRKPOS(J,1)= DEPART*DANGLE(J,2,IANG) + DANGLE(J,2,IANG)= DANGLE(J,2,IANG)*DENSP + 170 CONTINUE + LNEWP=.TRUE. +*---- +* TRACK OVER 2*NPOINT PARALLEL TRACK FOR DIRECTION +* TRACK AND REFLECTION +*---- + IXYF=0 + DO 180 IPOINT = 1,2*NPOINT + NRIN=0 + IF(LNEWP)THEN + NSUB=0 + IA=1 + NOTRAK=NOTRAK+1 + NSEG=0 + N0FSEG=1 + N0LSEG=MLSEG + IF(IXYF.EQ.0) THEN + DO 181 J=1,2 + TRKPOS(J,1)= TRKPOS(J,1) +DANGLE(J,2,IANG) + 181 CONTINUE + IXYN=0 + ENDIF + ELSE + N0FSEG=N0LSEG+1 + N0LSEG=N0LSEG+MLSEG + ENDIF + DO 182 ISEG=N0FSEG,N0LSEG + NRSEG(ISEG)=0 + NNSEG(ISEG)=0 + SEGLEN(ISEG)=0.0D0 + 182 CONTINUE + NLSEG=N0LSEG + NFSEG=N0FSEG +*---- +* FIND EXTERNAL SURFACES CROSSED BY THIS TRACK +*---- + CALL XCWREC(DANGLE(1,1,IANG),SIDE,TRKPOS,LINTER,ROTPOS, + > INDS,IMS) +*---- +* REJECT TRACK IF LINTER IS FALSE +*---- + IF(.NOT.LINTER) GO TO 183 +*---- +* KEEP THE TRACK IF LINTER IS TRUE +* A) SAVE INITIAL AND FINAL SURFACE INFORMATION +*---- + NRSEG(NFSEG)=-INDS(1) + SEGLEN(NFSEG)=0.5D0 + NRSEG(NLSEG)=-INDS(2) + SEGLEN(NLSEG)=0.5D0 + NFSEG=NFSEG+1 + NLSEG=NLSEG-1 +*---- +* SAVE INFORMATION FOR INITIAL AND FINAL ANNULAR TRACKING +*---- + NRSEG(NFSEG)=NRINFO(1,NBAN) + NNSEG(NFSEG)=NRIN + SEGLEN(NFSEG)=ROTPOS(1,1) + NRSEG(NLSEG)=NRIN + NNSEG(NLSEG)=NRINFO(1,NBAN) + SEGLEN(NLSEG)=ROTPOS(1,2) + NLSEG=NLSEG-1 + NFSEG=NFSEG+1 + NRIN=NRINFO(1,NBAN) +*---- +* TRACK INSIDE ANNULAR REGIONS +*---- + RADC=ABS(ROTPOS(2,1)) + RADC2=RADC**2 + DO 210 IAN=NTAN,1,-1 + IF(RADC.GE.RAN(IAN)) GO TO 211 +*---- +* LINE INTERSECT ANNULUS IAN +*---- + XPO=SQRT(RAN(IAN)**2-RADC2) + NRSEG(NLSEG)=NRIN + NNSEG(NFSEG+1)=NRIN + SEGLEN(NLSEG)=XPO + NLSEG=NLSEG-1 + NRIN=NRINFO(1,IAN) + NFSEG=NFSEG+1 + NRSEG(NFSEG)=NRIN + NNSEG(NLSEG+1)=NRIN + SEGLEN(NFSEG)=-XPO + IF(NRINFO(2,IAN).NE.0) THEN +*---- +* TRACK INSIDE RODS +*---- + DO 146 KRT=1,NRT + JRT=NXRI(KRT,IAN) + LRT=MOD(JRT,1000000) + IF((JRT.GT.3000000).OR. + > ((JRT.GT.0).AND.(JRT.LT.1000000)) ) THEN + CALL XCWROD(NRIN,NRODS(1,LRT),NRODR(LRT), + > RODR(1,LRT),RODP(1,1,LRT,IA), + > ROTPOS(2,1),NFSEG,NLSEG,SEGLEN,NRSEG, + > NNSEG) + ELSE IF(JRT.EQ.0) THEN + GO TO 147 + ENDIF + 146 CONTINUE + 147 CONTINUE + DO 143 KRT=1,NRT + JRT=NXRI(KRT,IAN) + IF(JRT.LT.0) THEN + IRT=-JRT + NXTR=NRODR(IRT) + DO 144 IRD=NRODS(2,IRT),1,-1 + IF(RADC.GT.RODR(IRD,IRT)) GO TO 211 +*---- +* LINE INTERSECT CENTERED ROD IRD +*---- + XPO=SQRT(RODR(IRD,IRT)*RODR(IRD,IRT)-RADC2) + NRSEG(NLSEG)=NRIN + NNSEG(NFSEG+1)=NRIN + SEGLEN(NLSEG)=XPO + NLSEG=NLSEG-1 + NRIN=NXTR + NXTR=NXTR-1 + NFSEG=NFSEG+1 + NRSEG(NFSEG)=NRIN + NNSEG(NLSEG+1)=NRIN + SEGLEN(NFSEG)=-XPO + 144 CONTINUE + GO TO 211 + ENDIF + 143 CONTINUE + ENDIF + 210 CONTINUE + 211 CONTINUE + IF( LNEWP )THEN + IF(IXYF .EQ. 0) THEN + IXYF=MOD(INDS(1)+1,2)+1 + ENDIF + DO 250 J= 1, 2 + TRKBEG(J,IXYF)= TRKPOS(J,1) + DIRBEG(J)= DANGLE(J,1,IANG) + 250 CONTINUE + ELSE IF(IXYN .EQ. 0) THEN + IXY=MOD(INDS(1)+1,2)+1 + IF(IXY.NE.IXYF) THEN + IXYN=IXY + DO 251 J= 1, 2 + TRKBEG(J,IXYN)= TRKPOS(J,1) + 251 CONTINUE + ENDIF + ENDIF + IF(IPRT.GE.100) THEN + WRITE(IUNOUT,6100) IANG,DANGLE(1,1,IANG),DANGLE(2,1,IANG), + > IPOINT,INDS(1),(TRKPOS(II,1),II=1,2), + > IPOINT,INDS(2),(TRKPOS(II,2),II=1,2) + ENDIF + NSUB=NSUB+1 + IF(NSUB.GT.MXSUB) CALL XABORT('XCWSCL: MXSUB OVERFLOW.') + KANGL(NSUB)=IANG +*---- +* COMPRESS AND SORT TRACK VECTOR +*---- + ISRT=N0FSEG+1 + NSRT=MLSEG-2 + CALL XCWSRT(IPRT,NSRT,SEGLEN(ISRT),NRSEG(ISRT), + > NNSEG(ISRT),NTSEG) + NOSEG=NSEG+NTSEG+2 + IF(IPRT.GE.200) THEN + WRITE(IUNOUT,6101) ROTPOS(2,1), + > (SEGLEN(IIJJ),NRSEG(IIJJ),IIJJ=NSEG+2,NOSEG), + > SEGLEN(N0LSEG),NRSEG(N0LSEG) + ENDIF +*---- +* CONVERT SEGMENT DIVISION TO SEGMENT LENGTH +*---- + DO 240 ISEG=NSEG+2,NOSEG-1 + SEGLEN(ISEG)=SEGLEN(ISEG+1)-SEGLEN(ISEG) + 240 CONTINUE + SEGLEN(NOSEG)=SEGLEN(N0LSEG) + NRSEG(NOSEG)=NRSEG(N0LSEG) + IF(IPRT.GE.200) THEN + WRITE(IUNOUT,6102) NOSEG-NSEG, + > (SEGLEN(IIJJ),NRSEG(IIJJ),IIJJ=NSEG+1,NOSEG) + ENDIF + NSEG=NOSEG + N0LSEG=NSEG +*---- +* FOR TRANSLATION -> CHANGE TRACK STARTUP POINT +* FOR REFLECTION -> CHANGE TRACK DIRECTION +*---- + JINT=MOD(INDS(2)+1,2)+1 + KINT=MOD(INDS(2),2)+1 + IF(IPER(JINT) .EQ. 1) THEN + TRKPOS(JINT,2)=-TRKPOS(JINT,2) + ELSE + DANGLE(JINT,1,IANG)=-DANGLE(JINT,1,IANG) + IA=MOD(IA,2)+1 + ENDIF + RONEPS= 0.0D0 + DO 260 J= 1, 2 + TRKPOS(J,1)= TRKPOS(J,2) + RONEPS= RONEPS + (TRKPOS(J,1)-TRKBEG(J,IXYF))**2 + > + (DANGLE(J,1,IANG)-DIRBEG(J))**2 + 260 CONTINUE + LNEWP= RONEPS.LT.EPS + IF(LNEWP)THEN +*---- +* NOW, WRITE THE TRACK +*---- + WEIGHT= 0.25*WGTANG(IANG)/DNSANG(IANG) + WRITE(IFTEMP) NSUB,NSEG, WEIGHT, + > (KANGL(I),I=1,NSUB), + > (NRSEG(I),I=1,NSEG), + > (SEGLEN(I),I=1,NSEG) + IF(IPRT.GE.300) THEN + WRITE(IUNOUT,6103) NOTRAK,IANG,NSEG, + > (SEGLEN(I),NRSEG(I),I=1,NSEG) + ENDIF + IF(IPERG .EQ. 1) THEN + IF(IXYN .EQ. IXYF) THEN + TRKPOS(1,1)=TRKBEG(1,IXYR) + TRKPOS(2,1)=TRKBEG(2,IXYR) + DANGLE(IXYF,1,IANG)=ABS(DANGLE(IXYF,1,IANG)) + IXYF=0 + ELSE IF(IXYN .EQ. 0) THEN + IF(IPER(IXYF).EQ.1) THEN + DANGLE(IXYF,1,IANG)=-DANGLE(IXYF,1,IANG) + IXYN=IXYF + IXYR=IXYF + ELSE + IXYF=0 + ENDIF + ELSE IF(IXYN .NE. IXYF) THEN + IF(IPER(IXYF).EQ.1) THEN + IXYR=IXYN + TRKBEG(1,IXYR)=TRKBEG(1,IXYF) + TRKBEG(2,IXYR)=TRKBEG(2,IXYF) + DANGLE(IXYF,1,IANG)=-DANGLE(IXYF,1,IANG) + IXYN=IXYF + ELSE IF(IPER(IXYN).EQ.1) THEN + DANGLE(IXYN,1,IANG)=-DANGLE(IXYN,1,IANG) + TRKPOS(1,1)=TRKBEG(1,IXYN) + TRKPOS(2,1)=TRKBEG(2,IXYN) + IXYR=IXYF + IXYF=IXYN + ENDIF + ENDIF + ELSE + IXYF=0 + ENDIF + ENDIF + 183 CONTINUE + 180 CONTINUE + 130 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(PTSANG,DNSANG,WGTANG,DANGLE) + DEALLOCATE(ATOP,RODP,SEGLEN) + DEALLOCATE(KANGL,NNSEG,NRSEG) + RETURN +*---- +* FORMATS +*---- + 6000 FORMAT(1X,' TOTAL NUMBER OF REGIONS =',I10/ + > 1X,' NUMBER OF INITIAL SURFACES =',I10/ + > 1X,' NUMBER OF ANNULAR REGIONS =',I10/ + > 1X,' NUMBER OF RODS TYPES =',I10) + 6001 FORMAT(1X,' ROD TYPE',10X,' NB. RODS',10X, + > 'NB. SUBROD',10X,'IN ANNULUS') + 6002 FORMAT((1X,I10,10X,I10,10X,I10,10X,I10)) + 6003 FORMAT(1X,'INTEGRATION PARAMETERS',/ + > 1X,' NUMBER OF ANGLES =',I10,/ + > 1X,' MINIMUM TRACK DENSITY =',1P,E15.7) + 6004 FORMAT( 1X,I4,': COS=',F10.6,' WGT=',F10.6,' DNS=',F10.6, + > ' WGT/DEN=',F10.6) + 6100 FORMAT(//' *** TRACKING INFORMATION ***'/ + > ' ANGLE(',I5,') :',1P,2E15.7/ + > ' START SURFACE (',I5,') :',5X,I10,5X,1P,2E15.7/ + > ' FINISH SURFACE (',I5,') :',5X,I10,5X,1P,2E15.7) + 6101 FORMAT(' INTERSECTION OF REGION AT NORMAL DISTANCE =',1P,E15.7/ + > 3(5X,E15.7,1X,I5)) + 6102 FORMAT(' NUMBER OF SEGMENTS ',I10/1P,3(5X,E15.7,1X,I5)) + 6103 FORMAT(/' INFORMATION TO TRACKING FILE: ', + > ' TRACK NUMBER =',I5,2X,'IANG =',I5,2X,'NSEG =',I7/1P, + > 3(5X,E15.7,1X,I5)) + END diff --git a/Dragon/src/XCWSRT.f b/Dragon/src/XCWSRT.f new file mode 100644 index 0000000..ad2b14c --- /dev/null +++ b/Dragon/src/XCWSRT.f @@ -0,0 +1,154 @@ +*DECK XCWSRT + SUBROUTINE XCWSRT(IPRT,MXSEG,SEGLEN,NRSEG,NNSEG,NTSEG) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Sort region intersection by position. +* +*Copyright: +* Copyright (C) 1994 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G.Marleau +* +*Parameters: input +* IPRT print level. +* MXSEG current maximum track length. +* +*Parameters: input/output +* SEGLEN length of track. +* NRSEG region crossed by track. +* NNSEG region crossed by track (left). +* +*Parameters: output +* NTSEG total number of segments. +* +*---------------------------------------------------------------------- +* + PARAMETER (IUNOUT=6) + INTEGER IPRT,MXSEG,NRSEG(*),NNSEG(*),NTSEG + DOUBLE PRECISION SEGLEN(*) +*---- +* LOCAL VARIABLES +*---- + INTEGER REFNR,REFNN + DOUBLE PRECISION REFSL +*---- +* REMOVE TERM WITH NRSEG<=0 +*---- + NTSEG=0 + DO 100 IS=1,MXSEG-1 + IF(NRSEG(IS).GT.0) THEN + NTSEG=NTSEG+1 + NRSEG(NTSEG)=NRSEG(IS) + NNSEG(NTSEG)=NNSEG(IS) + SEGLEN(NTSEG)=SEGLEN(IS) + ENDIF + 100 CONTINUE + NSEG=NTSEG+1 + NRSEG(NSEG)=NRSEG(MXSEG) + NNSEG(NSEG)=NNSEG(MXSEG) + SEGLEN(NSEG)=SEGLEN(MXSEG) + IF(IPRT.GE.200) THEN + WRITE(IUNOUT,6000) + WRITE(IUNOUT,6010) (IIJJ,SEGLEN(IIJJ),NNSEG(IIJJ), + > NRSEG(IIJJ),IIJJ=1,NSEG) + ENDIF +*---- +* SORT FROM MINIMUM TO MAXIMUM +*---- + DO 110 IS=2,NSEG + REFSL=SEGLEN(IS) + REFNR=NRSEG(IS) + REFNN=NNSEG(IS) + DO 111 JS=IS-1,1,-1 + KS=JS + IF(SEGLEN(JS).GT.REFSL) THEN + SEGLEN(JS+1)=SEGLEN(JS) + NRSEG(JS+1)=NRSEG(JS) + NNSEG(JS+1)=NNSEG(JS) + ELSE + GO TO 112 + ENDIF + 111 CONTINUE + KS=0 + 112 CONTINUE + SEGLEN(KS+1)=REFSL + NRSEG(KS+1)=REFNR + NNSEG(KS+1)=REFNN + 110 CONTINUE + IF(IPRT.GE.200) THEN + WRITE(IUNOUT,6001) + WRITE(IUNOUT,6010) (IIJJ,SEGLEN(IIJJ),NNSEG(IIJJ), + > NRSEG(IIJJ),IIJJ=1,NSEG) + ENDIF +*---- +* CHECK FOR ROD INTERSECTION WITH ANNULUS OR +* ANNULUS LOCATED BETWEEN ROD SETS +*---- + DO 120 IS=1,NSEG + NTB=NRSEG(IS) + NFB=NNSEG(IS) + IF(NTB.GT.0) THEN + IF(NTB.LT.NFB) THEN + DO 121 JS=IS+1,NSEG + NTE=NRSEG(JS) + NFE=NNSEG(JS) + IF((NTE.EQ.NFB).AND.(NFE.EQ.NTB)) GO TO 122 + IF(NTE.GT.NTB) THEN + NRSEG(JS)=NTB + ENDIF + IF(ABS(NFE).GT.NTB) THEN + IF(NFE.LT.0) THEN + NNSEG(JS)=-NTB + ELSE + NNSEG(JS)=NTB + ENDIF + ENDIF + 121 CONTINUE + ENDIF + ENDIF + 122 CONTINUE + IF(NFB.GT.0) THEN + DO 123 JS=IS-1,1,-1 + NTE=NRSEG(JS) + IF(NTE.GT.0) THEN + IF(NFB.NE.NTE) THEN + NRSEG(IS)=0 + ENDIF + GO TO 124 + ENDIF + 123 CONTINUE + ENDIF + 124 CONTINUE + 120 CONTINUE +*---- +* REMOVE NEW TERMS WITH NRSEG<=0 +*---- + NTSEG=0 + DO 130 IS=1,NSEG-1 + IF(NRSEG(IS).GT.0) THEN + NTSEG=NTSEG+1 + NRSEG(NTSEG)=NRSEG(IS) + NNSEG(NTSEG)=NNSEG(IS) + SEGLEN(NTSEG)=SEGLEN(IS) + ENDIF + 130 CONTINUE + NSEG=NTSEG+1 + NRSEG(NSEG)=NRSEG(MXSEG) + NNSEG(NSEG)=NNSEG(MXSEG) + SEGLEN(NSEG)=SEGLEN(MXSEG) + RETURN +*---- +* FORMATS +*---- + 6000 FORMAT(' COMPRESSED TRACKING FILE'/ + >5X,'NUMBER',7X,'POSITION',4X,'BEFORE',5X,'AFTER') + 6001 FORMAT(' SORTED TRACKING FILE'/ + >5X,'NUMBER',7X,'POSITION',4X,'BEFORE',5X,'AFTER') + 6010 FORMAT((1X,I10,F15.7,2I10)) + END diff --git a/Dragon/src/XCWTRK.f b/Dragon/src/XCWTRK.f new file mode 100644 index 0000000..4747124 --- /dev/null +++ b/Dragon/src/XCWTRK.f @@ -0,0 +1,318 @@ +*DECK XCWTRK + SUBROUTINE XCWTRK(IPTRK ,IPGEOM,GEONAM,IDISP ,IFTEMP,IPRT , + > NDIM ,ITOPT ,NVOL ,NSUR ,NANGL ,ISYMM , + > DENS ,PCORN ,MXSUB ,MXSEG ,ICODE ,TITREC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Analyse cluster geometry and perform specular or isotropic +* traking if required. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPTRK pointer to the excell tracking. +* IPGEOM pointer to the geometry. +* GEONAM geometry name. +* IFTEMP temporary tracking file. +* IPRT print option. +* TITREC title for execution. +* +*Parameters: input/output +* IDISP tracking file disposition: +* = -2 no traking - only analyse geometry +* then abort (option halt); +* = -1 modify tracking file; +* = 0 old tracking file; +* = 1 new tracking file. +* +*Parameters: output +* NDIM number of physical dimensions. +* ITOPT tracking option: +* = 0 finite; +* = 1 cyclic. +* NVOL number of physical regions. +* NSUR number of outer surface. +* NANGL number of angles. +* ISYMM symmetry factor. +* DENS track density. +* PCORN corner proximity. +* MXSUB maximum number of subtracks. +* MXSEG maximum segment length. +* ICODE albedo associated with face. +* +*------------------------- XCWTRK ------------------------------- +* + USE GANLIB + IMPLICIT NONE + INTEGER IOUT,NALB,NSTATE + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NALB=6,NSTATE=40, + > NAMSBR='XCWTRK') +*---- +* ROUTINE PARAMETERS +*---- + + TYPE(C_PTR) IPTRK,IPGEOM + INTEGER IDISP ,IFTEMP,IPRT ,NDIM ,ITOPT ,NVOL ,NSUR , + > NANGL ,ISYMM ,MXSUB ,MXSEG ,ICODE(NALB) + REAL DENS ,PCORN + CHARACTER GEONAM*12,TITREC*7 +*---- +* REDGET VARIABLES +*---- + INTEGER ITYPLU,INTLIR + CHARACTER CARLIR*12 + REAL REALIR + DOUBLE PRECISION DBLLIR +*---- +* LOCAL VARIABLES +*---- + LOGICAL SWZERO + CHARACTER COMENT*80 + INTEGER NCODE(NALB),IMS(NALB) + REAL ALBEDO(NALB) + INTEGER ISTATE(NSTATE) + REAL EXTKOP(NSTATE) + INTEGER ILENGT,ITYLCM,NANGR ,NCOMNT,NCOR ,NALBG, + > MSROD ,MAROD ,MNAN ,NRT ,NSURX ,NBAN , + > NUNK ,JJ ,IHS + REAL COTE ,RADMIN +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KEYMRG,MATALB,NRINFO,NRODS, + > NRODR,NXRI + REAL, ALLOCATABLE, DIMENSION(:) :: VOLSUR,RAN,RODS,RODR +*---- +* DEFAULT TRACKING OPTIONS: +*---- + PCORN=0.0 + ISTATE(:NSTATE)=0 + EXTKOP(:NSTATE)=0.0 + CALL LCMLEN(IPTRK,'STATE-VECTOR',ILENGT,ITYLCM) + IF(ILENGT .LE. 0 .OR. ILENGT .GT. NSTATE) THEN + ITOPT=0 + NANGR=15 + ISYMM=1 + DENS=0.0 + ELSE + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + CALL LCMGET(IPTRK,'EXCELTRACKOP',EXTKOP) + ITOPT=ISTATE(9) + NANGR=ISTATE(11) + ISYMM=ISTATE(12) + DENS=EXTKOP(2) + ENDIF +*---- +* READ THE NEW TRACKING OPTIONS. +*---- + IF(IDISP .LE. 0) GO TO 200 + 100 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// + > ': CHARACTER DATA EXPECTED.') + IF((CARLIR .EQ. 'TISO') .OR. (CARLIR .EQ. 'TSPC')) THEN + IF(CARLIR .EQ. 'TSPC') THEN + ITOPT=1 + SWZERO=.TRUE. + ELSE + ITOPT=0 + ENDIF +*---- +* 2-D QUADRATURE PARAMETERS (ANGLE AND SPACE). +*---- + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .EQ. 3) THEN + IF(ITOPT .EQ. 1 .AND. CARLIR .EQ. 'MEDI') THEN + SWZERO=.FALSE. + ELSE + CALL XABORT('XCWTRK: *MEDI* KEYWORD EXPECTED.') + ENDIF + CALL REDGET(ITYPLU,NANGR,REALIR,CARLIR,DBLLIR) + ENDIF + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': INTEGER DATA EXPECTED.') + NANGR=INTLIR + IF(NANGR.LT.2) CALL XABORT(NAMSBR// + > ': THE NUMBER OF ANGLES MUST BE > 1.') + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR// + > ': REAL DATA EXPECTED.') + DENS=REALIR + ELSE IF(CARLIR .EQ. 'HALT') THEN +*---- +* NO TRACKING OPTION +*---- + IDISP=-2 + ELSE IF(CARLIR .EQ. 'SYMM') THEN +*---- +* SYMMETRY FACTOR +*---- + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// + > ': INTEGER DATA EXPECTED.') + ISYMM=INTLIR + ELSE IF(CARLIR .EQ. ';') THEN + NANGL=NANGR + GO TO 200 + ELSE + CALL XABORT(NAMSBR//': INVALID KEYWORD.') + ENDIF + GO TO 100 + 200 CONTINUE +*---- +* Set NANGL for specular tracking to a valid value +*---- + IF(ITOPT .EQ. 1) THEN + NANGL=MIN(30,NANGL) + IF(NANGL .GT. 24) THEN + NANGL = 30 + ELSE IF(NANGL .GT. 20) THEN + NANGL = 24 + ELSE IF(NANGL .GT. 18) THEN + NANGL = 20 + ELSE IF(NANGL .GT. 14) THEN + NANGL = 18 + ELSE IF(NANGL .GT. 12) THEN + NANGL = 14 + ELSE IF(NANGL .GT. 8) THEN + NANGL = 12 + ELSE + NANGL = 8 + ENDIF + ISYMM=1 + ENDIF +*---- +* SAVE EXCELL SPECIFIC TRACKING INFORMATION. +*---- + ISTATE(1)=NVOL + ISTATE(5)=NSUR + ISTATE(9)=ITOPT + ISTATE(11)=NANGR + ISTATE(12)=ISYMM + CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,ISTATE) + EXTKOP(2)=DENS + CALL LCMPUT(IPTRK,'EXCELTRACKOP',NSTATE,2,EXTKOP) +*---- +* ANALYZE GEOMETRY AND STORE DESCRIPTION ON TRACKING STRUCTURE +*---- + CALL AXGXCW(IPGEOM,IPTRK ,IPRT ,GEONAM,ISYMM ) +*---- +* READ TRACKING STRUCTURE +* KEYMRG : INTEGER MERGE VECTOR +* VOLSUR : REAL VOLUME-SURFACE VECTOR +* MATALB : INTEGER MATERIAL-FACE VECTOR +*---- + ISTATE(:NSTATE)=0 + CALL LCMSIX(IPTRK,'EXCELL ',1) + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE ) + NDIM = ISTATE(1) + NSUR = ISTATE(2) + NVOL = ISTATE(3) + NSURX = ISTATE(4) + NBAN = ISTATE(5) + NUNK = ISTATE(6) + NRT = ISTATE(7) + MSROD = ISTATE(8) + MAROD = ISTATE(9) + MNAN = ISTATE(10) + ALLOCATE(KEYMRG(NUNK),VOLSUR(NUNK),MATALB(NUNK)) + ALLOCATE(NRINFO(2*MNAN),NRODS(3*NRT),NRODR(NRT),NXRI(NRT*NBAN)) + ALLOCATE(RAN(NBAN),RODS(2*NRT),RODR(MSROD*NRT)) + CALL LCMGET(IPTRK,'RAN ',RAN ) + IF(NSURX .EQ. 4) + >CALL LCMGET(IPTRK,'COTE ',COTE ) + CALL LCMGET(IPTRK,'RADMIN ',RADMIN) + CALL LCMGET(IPTRK,'NRODS ',NRODS ) + CALL LCMGET(IPTRK,'RODS ',RODS ) + CALL LCMGET(IPTRK,'NRODR ',NRODR ) + CALL LCMGET(IPTRK,'RODR ',RODR ) + CALL LCMGET(IPTRK,'NRINFO ',NRINFO) + CALL LCMGET(IPTRK,'NXRI ',NXRI ) + CALL LCMGET(IPTRK,'KEYMRG ',KEYMRG) + CALL LCMGET(IPTRK,'MATALB ',MATALB) + CALL LCMGET(IPTRK,'VOLSUR ',VOLSUR) + CALL LCMSIX(IPTRK,'EXCELL ',2) + CALL LCMGET(IPTRK,'ALBEDO ',ALBEDO) + CALL LCMGET(IPTRK,'ICODE ',ICODE ) + CALL LCMGET(IPTRK,'NCODE ',NCODE ) + IF(ISYMM.GT.1) THEN + DO 110 IHS=1,NALB + IMS(IHS)=1 + 110 CONTINUE + ELSE + DO 111 IHS=1,NALB + IMS(IHS)=IHS + 111 CONTINUE + ENDIF + IF(IDISP .EQ. 1) THEN + MXSUB=1 + MXSEG=4*(NBAN+1+NRT*MSROD*MAROD) + IF(ITOPT .EQ. 1) THEN + MXSUB=4*NANGL + MXSEG=16*NANGL*MXSEG + ENDIF + NCOMNT=5 + NCOR=1 + NALBG=NALB + WRITE(IFTEMP) '$TRK',NCOMNT,0,0 + COMENT='CREATOR : DRAGON' + WRITE(IFTEMP) COMENT + COMENT='MODULE : XCWTRK' + WRITE(IFTEMP) COMENT + COMENT='TYPE : CLUSTER' + WRITE(IFTEMP) COMENT + COMENT='GEOMETRY : '//GEONAM + WRITE(IFTEMP) COMENT + COMENT=TITREC + WRITE(IFTEMP) COMENT + IF(ITOPT .EQ. 1) THEN + WRITE(IFTEMP) NDIM,ITOPT,NVOL,NSUR,NALBG,NCOR,4*NANGL,MXSUB, + > MXSEG + ELSE + WRITE(IFTEMP) NDIM,ITOPT,NVOL,NSUR,NALBG,NCOR,NANGL,MXSUB, + > MXSEG + ENDIF + WRITE(IFTEMP) (VOLSUR(JJ),JJ=1,1+NSUR+NVOL) + WRITE(IFTEMP) (MATALB(JJ),JJ=1,1+NSUR+NVOL) + WRITE(IFTEMP) (ICODE(JJ),JJ=1,NALBG) + WRITE(IFTEMP) (ALBEDO(JJ),JJ=1,NALBG) +*---- +* SET DEFAULT TRACKING DENSITY +*---- + IF(DENS .EQ. 0.0) DENS=5.0/RADMIN + IF(ITOPT .EQ. 1) THEN +*---- +* SPECULAR TRACKING +*---- + CALL XCWSCL(NDIM ,NSURX ,NVOL ,NBAN ,NRT ,MSROD ,MAROD , + > NANGL ,DENS ,IFTEMP,IPRT ,NCODE ,SWZERO,NRINFO, + > RAN ,COTE ,NRODS ,RODS ,NRODR ,RODR ,MXSUB , + > MXSEG ,NXRI ,IMS ) + NANGL=4*NANGL + ELSE +*---- +* ISOTROPIC TRACKING +*---- + CALL XCWICL(NDIM ,NSURX ,NVOL ,NBAN ,NRT ,MSROD ,MAROD , + > NANGL ,DENS ,ISYMM ,IFTEMP,IPRT ,NRINFO,RAN , + > COTE ,NRODS ,RODS ,NRODR ,RODR ,MXSEG ,NXRI , + > IMS) + ENDIF + ENDIF +*---- +* RELEASE BLOCKS FOR GEOMETRY +*---- + DEALLOCATE(RODR,RODS,RAN) + DEALLOCATE(NXRI,NRODR,NRODS,NRINFO) + DEALLOCATE(MATALB,VOLSUR,KEYMRG) + RETURN + END diff --git a/Dragon/src/XDDCOM.f b/Dragon/src/XDDCOM.f new file mode 100644 index 0000000..1817db5 --- /dev/null +++ b/Dragon/src/XDDCOM.f @@ -0,0 +1,46 @@ +*DECK XDDCOM + FUNCTION XDDCOM(DBLE1,DBLE2,DEPS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To compare two double precision values. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): R. Le Tellier. +* +*Parameters: input +* DBLE1 first double precision value. +* DBLE2 second double precision value. +* DEPS comparison criterion. +* +*Parameters: output +* XDDCOM comparison flag. +* +*----------------------------------------------------------------------- + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + DOUBLE PRECISION DBLE1,DBLE2,DEPS + LOGICAL XDDCOM +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION DLIM,DIFF +* + DLIM=DEPS*1.D-3 + IF (ABS(DBLE1).GT.DLIM) THEN + DIFF=(DBLE2/DBLE1-1.D0) + XDDCOM=(ABS(DIFF).LT.DEPS) + ELSE + XDDCOM=(ABS(DBLE2).LT.DLIM) + ENDIF +* + END diff --git a/Dragon/src/XDRCRE.f b/Dragon/src/XDRCRE.f new file mode 100644 index 0000000..7c0d1c0 --- /dev/null +++ b/Dragon/src/XDRCRE.f @@ -0,0 +1,222 @@ +*DECK XDRCRE + SUBROUTINE XDRCRE(NAMMOD,IBEAF) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To print DRAGON credits. +* +*Copyright: +* Copyright (C) 2004 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* NAMMOD name of DRAGON module. +* IBEAF flag for beginning or finishing module where: +* =1 before module execution; +* =-1 after module execution. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER NAMMOD*12 + INTEGER IBEAF +*---- +* LOCAL PARAMETERS +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='XDRCRE') +*---- +* LOCAL VARIABLES +*---- + CHARACTER USE*72,AUT*72 + INTEGER ICOPYR +*---- +* PRINT CREDITS +*---- + ICOPYR=0 + IF(IBEAF .EQ. 1) THEN + WRITE(IOUT,6000) NAMMOD + IF (NAMMOD .EQ. 'ASM: ') THEN + USE='To built system matrices (CP and IC)' + AUT='A. Hebert, G. Marleau, R. Roy' + ELSE IF(NAMMOD .EQ. 'COMPO: ') THEN + USE='Create multiparameter reactor composition database' + AUT='A. Hebert' + ELSE IF(NAMMOD .EQ. 'EDI: ') THEN + USE='Editing module' + AUT='A. Hebert, G. Marleau' + ELSE IF(NAMMOD .EQ. 'EVO: ') THEN + USE='Isotopic depletion and fuel burnup' + AUT='A. Hebert' + ELSE IF(NAMMOD .EQ. 'EXCELT: ') THEN + USE='Excell tracking in 2- and 3-D' + AUT='G. Marleau, M. Ouisloumen, R. Roy' + ELSE IF(NAMMOD .EQ. 'NXT: ') THEN + USE='New excell tracking in 2- and 3-D' + AUT='G. Marleau' + ELSE IF(NAMMOD .EQ. 'MCCGT: ') THEN + USE='Method of characteristics in 2- and 3-D' + AUT='I. Suslov, R. Roy, R. Le Tellier, A. Hebert' + ELSE IF(NAMMOD .EQ. 'BIVACT: ') THEN + USE='2-D diffusion or SPN finite element tracking' + AUT='A. Hebert' + ELSE IF(NAMMOD .EQ. 'TRIVAT: ') THEN + USE='3-D diffusion or SPN finite element tracking' + AUT='A. Hebert' + ELSE IF(NAMMOD .EQ. 'SNT: ') THEN + USE='Discrete ordinates tracking' + AUT='A. Hebert' + ELSE IF(NAMMOD .EQ. 'FLU: ') THEN + USE='Solve the flux equations' + AUT='R. Roy, A. Hebert, G. Marleau' + ELSE IF(NAMMOD .EQ. 'GEO: ') THEN + USE='Geometry definition' + AUT='A. Hebert' + ELSE IF(NAMMOD .EQ. 'INFO: ') THEN + USE='Information on water, UO2 and ThO2' + AUT='R. Roy' + ELSE IF(NAMMOD .EQ. 'LIB: ') THEN + USE='Microscopic xs-library processing' + AUT='A. Hebert, G. Marleau' + ELSE IF(NAMMOD .EQ. 'MAC: ') THEN + USE='Macroscopic xs processor' + AUT='G. Marleau' + ELSE IF(NAMMOD .EQ. 'MRG: ') THEN + USE='Merge excell tracking file' + AUT='G. Marleau' + ELSE IF(NAMMOD .EQ. 'PSP: ') THEN + USE='Generates ps graphics for dragon' + AUT='K.E. Kohler, G. Marleau' + ICOPYR=1 + ELSE IF(NAMMOD .EQ. 'SHI: ') THEN + USE='Self-shielding by improved Stammler method' + AUT='A. Hebert' + ELSE IF(NAMMOD .EQ. 'USS: ') THEN + USE='Self-shielding by subgroup method' + AUT='A. Hebert' + ELSE IF(NAMMOD .EQ. 'TONE: ') THEN + USE='Self-shielding by Tone method' + AUT='A. Hebert' + ELSE IF(NAMMOD .EQ. 'AUTO: ') THEN + USE='Self-shielding by Autosecol method' + AUT='A. Hebert' + ELSE IF(NAMMOD .EQ. 'VDG: ') THEN + USE='Statistics on Van Der Gucht benchmarks' + AUT='A. Hebert' + ELSE IF(NAMMOD .EQ. 'SYBILT: ') THEN + USE='Sybil 2-D tracking' + AUT='A. Hebert' + ELSE IF(NAMMOD .EQ. 'TLM: ') THEN + USE='Generate matlab line tracking file' + AUT='C. Plamondon, G. Marleau' + ELSE IF(NAMMOD .EQ. 'M2T: ') THEN + USE='Generate an apotrim interface file' + AUT='A. Hebert' + ELSE IF(NAMMOD .EQ. 'FMAC: ') THEN + USE='Recover information from a FMAC-M interface file' + AUT='A. Hebert' + ELSE IF(NAMMOD .EQ. 'PSOUR: ') THEN + USE='Compute a fixed source from companion particles' + AUT='A. Hebert' + ELSE IF(NAMMOD .EQ. 'HEAT: ') THEN + USE='Compute the energy and charge deposition values' + AUT='A. Hebert' + ELSE IF(NAMMOD .EQ. 'CHAB: ') THEN + USE='Modify and renormalize a microlib' + AUT='A. Hebert' + ELSE IF(NAMMOD .EQ. 'CPO: ') THEN + USE='Create Version3 reactor composition database' + AUT='A. Hebert' + ELSE IF(NAMMOD .EQ. 'SAP: ') THEN + USE='Create a Saphyb composition database' + AUT='A. Hebert' + ELSE IF(NAMMOD .EQ. 'APX: ') THEN + USE='Create an APEX composition database' + AUT='A. Hebert' + ELSE IF(NAMMOD .EQ. 'MPO: ') THEN + USE='Create a MPO composition database' + AUT='A. Hebert' + ELSE IF(NAMMOD .EQ. 'MC: ') THEN + USE='Multigroup Monte-Carlo calculation' + AUT='R. Le Tellier, B. Arsenault' + ELSE IF(NAMMOD .EQ. 'T: ') THEN + USE='Transpose a macrolib' + AUT='A. Hebert' + ELSE IF(NAMMOD .EQ. 'DMAC: ') THEN + USE='Set the GPT adjoint sources (Macrolib gradient)' + AUT='A. Hebert' + ELSE IF(NAMMOD .EQ. 'FMT: ') THEN + USE='Transfer data structure to formatted output files' + AUT='G. Marleau' + ELSE IF(NAMMOD .EQ. 'EPC: ') THEN + USE='Error propagation module' + AUT='G. Marleau' + ELSE IF(NAMMOD .EQ. 'SPH: ') THEN + USE='Superhomogenization (SPH) calculation' + AUT='A. Hebert' + ELSE IF(NAMMOD .EQ. 'CFC: ') THEN + USE='Construction of a feedback database for CANDU reactors' + AUT='M. T. Sissaoui' + ELSE IF(NAMMOD .EQ. 'SENS: ') THEN + USE='Sensitivity analysis to cross-section on the reactivity' + AUT='C. Laville, G. Marleau' + ELSE IF(NAMMOD .EQ. 'DUO: ') THEN + USE='Perturbative analysis using the Clio formula' + AUT='A. Hebert' + ELSE IF(NAMMOD .EQ. 'BREF: ') THEN + USE='Discontinuity factors calculation in a 1D reflector' + AUT='A. Hebert' + ELSE IF(NAMMOD .EQ. 'SALT: ') THEN + USE='Track calculations from a SALOME surfacic file' + AUT='A. Hebert, X. Warin' + ELSE IF(NAMMOD .EQ. 'G2S: ') THEN + USE='Generate a surfacic file in SALOME format from a DRAGON' + > //' geometry' + AUT='G. Civario' + ELSE IF(NAMMOD .EQ. 'G2MC: ') THEN + USE='Generate a surfacic file in Monte Carlo format from a ' + > //'DRAGON geometry' + AUT='G. Civario' + ELSE IF(NAMMOD .EQ. 'MRG: ') THEN + USE='Merge regions in tracking data structure' + AUT='G. Marleau' + ELSE IF(NAMMOD .EQ. 'CLM: ') THEN + USE='Combine and redistribute liquid fuel mixtures' + AUT='G. Marleau' + ELSE + USE='No description available for this module' + AUT='No author provided for this module' + ENDIF + WRITE(IOUT,6100) USE,AUT + IF(ICOPYR .EQ. 1) THEN + WRITE(IOUT,6111) + ELSE + WRITE(IOUT,6110) + ENDIF + ELSE + WRITE(IOUT,6001) NAMMOD + ENDIF + RETURN +*---- +* FORMATS +*---- + 6000 FORMAT('->@BEGIN MODULE : ',A12) + 6001 FORMAT('->@END MODULE : ',A12) + 6100 FORMAT('->@DESCRIPTION : ',A72/ + > '->@CREDITS : ',A72) + 6110 FORMAT('->@COPYRIGHTS : ECOLE POLYTECHNIQUE DE MONTREAL '/ + > ' GNU LESSER GENERAL PUBLIC LICENSE') + 6111 FORMAT('->@COPYRIGHTS : ECOLE POLYTECHNIQUE DE MONTREAL '/ + > ' GNU LESSER GENERAL PUBLIC LICENSE'/ + > ' K.E. KOHLER FOR PSPLOT ') + END diff --git a/Dragon/src/XDREXP.f b/Dragon/src/XDREXP.f new file mode 100644 index 0000000..88ce471 --- /dev/null +++ b/Dragon/src/XDREXP.f @@ -0,0 +1,106 @@ +*DECK XDREXP + SUBROUTINE XDREXP(DX,NBX,PARAM,E00,E01,E10,E11) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Construct exponential tables for linear interpolation. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy, R. Le Tellier +* +*Parameters: input +* DX step for tables (here, DX=0.02d0). +* NBX order of tables (here, NBX=7936). +* +*Parameters: output +* PARAM exponential table characteristics. +* E00 exponential table. +* E01 exponential table. +* E10 exponential table. +* E11 exponential table. +* +*Comments: +* Modified in order to tabulate (1-exp(-x))/x instead of (1-exp(-x))). +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NBX + DOUBLE PRECISION DX + REAL PARAM(3), E00(0:NBX), E01(0:NBX), E10(0:NBX), + > E11(0:NBX) +*---- +* LOCAL VARIABLES +*---- + INTEGER I + DOUBLE PRECISION X0, X1, X2, X3, X4, PAS, XLIM, EX00, EX01, + > EX10, EX11 + DOUBLE PRECISION DEPS, DREF, DZERO, DONE, TAUDMIN + PARAMETER ( DEPS= 1.D-10, DREF= 1.D0/512.D0, + > DZERO= 0.D0, DONE=1.D0, TAUDMIN=2.D-2 ) +*---- +* SPACE AND VALUES FOR EXPONENTIAL TABLES +*---- + INTEGER MEX1 + PARAMETER ( MEX1=7936 ) +* + IF( NBX.NE. MEX1 ) GO TO 97 + IF( DX .GT. DREF+DEPS .OR. DX .LT. DREF-DEPS ) GO TO 98 + PAS= DONE/DX + XLIM= DBLE(NBX)*DX +*---- +* WE CONSTRUCT THE LINEAR TABLES USING ACCURATE *EXP* VALUES +*---- + X0= DZERO + EX00= DZERO + EX10= DONE + DO 20 I= 0, NBX-1 +* +* STORE CONSTANT VALUE: + X1= X0 + DX + IF (X1.LE.TAUDMIN) THEN + X2=0.5D0*X1 + X3=X1/3.D0 + X4=0.5D0*X2 + EX11=DONE-X2*(DONE-X3*(DONE-X4)) + ELSE + EX11=(DONE - EXP(-X1))/X1 + ENDIF + EX01=(DONE - EXP(-X1)) +* +* STORE STEP AND CONSTANT VALUES: + X2=(EX01-EX00)/(X1-X0) + X3=(EX11-EX10)/(X1-X0) + E01(I)= REAL(X2) + E00(I)= REAL(EX00-X0*X2) + E11(I)= REAL(X3) + E10(I)= REAL(EX10-X0*X3) + X0= X1 + EX00= EX01 + EX10= EX11 + 20 CONTINUE + PARAM(1)=REAL(PAS) + PARAM(2)=REAL(DX) + PARAM(3)=REAL(XLIM) + E10(NBX)= REAL(1.D0/XLIM) + E11(NBX)= 0.0 + E00(NBX)= 1.0 + E01(NBX)= 0.0 + RETURN +*---- +* ERROR SECTION +*---- + 97 CALL XABORT('XDREXP: EXP LINEAR TABLES HAVE MORE THAN 7936 ELEM' + > //'ENTS') + 98 CALL XABORT('XDREXP: EXP LINEAR TABLES HAVE A STEP OF 1/512') + END diff --git a/Dragon/src/XDRH11.f b/Dragon/src/XDRH11.f new file mode 100644 index 0000000..23d872d --- /dev/null +++ b/Dragon/src/XDRH11.f @@ -0,0 +1,228 @@ +*DECK XDRH11 + SUBROUTINE XDRH11 (IR1,NMILG,NG,NSMAX,MICRO,IQUAD,NS,IDIL,MIXGR, + 1 RS,FRACT,VOLK,SIGMA,SIGMS,NCO,RRRR,QKOLD,QKDEL,PKL,COEF) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the reduced collision probabilities for the Sanchez- +* Pomraning double heterogeneity model (part 1). +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IR1 number of elementary mixtures in the domain. +* NMILG number of composite mixtures in the domain. +* NG number of different kind of micro structures. A kind of +* micro structure is characterized by the radius of its +* micro volumes. All the micro volumes of the same kind +* should own the same nuclear properties in a given macro +* volume. +* NSMAX maximum number of volumes (tubes or shells) in each kind of +* micro structure. +* MICRO type of micro volumes (=3 cylinder; =4 sphere). +* IQUAD quadrature parameter for the treatment of the micro volumes. +* NS number of volumes in each kind of micro structure. +* IDIL elementary mixture indices in the diluent of the composite +* mixtures. +* MIXGR elementary mixture indices in the micro structures. +* RS radius of the micro volumes. +* FRACT volumic fractions of the micro volumes. +* VOLK volumic fractions of the tubes or shells in the micro volumes. +* +*Parameters: input/output +* SIGMA total macroscopic cross sections in each mixture of the +* composite geometry. +* SIGMS scattering macroscopic cross sections in each mixture of the +* composite geometry. +* +*Parameters: output +* NCO number of volumes in each composite mixture. +* RRRR information used by XDRH20, XDRH23, XDRH30 and XDRH33. +* QKOLD information used by XDRH20, XDRH23, XDRH30 and XDRH33. +* QKDEL information used by XDRH20, XDRH23, XDRH30 and XDRH33. +* PKL information used by XDRH20, XDRH23, XDRH30 and XDRH33. +* COEF information used by XDRH20, XDRH23, XDRH30 and XDRH33. +* +*References: +* R. Sanchez and G. C. Pomraning, A Statistical Analysis of the Double +* Heterogeneity Problem, Ann. Nucl. Energy, 18, 371-395 (1991). +* \\\\ +* R. Sanchez and E. Masiello, Treatment of the Double Heterogeneity +* with the Method of Characteristics", PHYSOR 2002, Seoul, Korea (2002). +* \\\\ +* R. Sanchez, Renormalized Treatment of the Double Heterogeneity with +* the Method of Characteristics, PHYSOR 2004, Chicago, USA (2004). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IR1,NMILG,NG,NSMAX,MICRO,IQUAD,NS(NG),IDIL(NMILG), + 1 MIXGR(NSMAX,NG,NMILG),NCO(NMILG) + REAL RS(NSMAX+1,NG),FRACT(NG,IR1+NMILG),VOLK(NG,NSMAX), + 1 SIGMA(0:IR1+NMILG),SIGMS(0:IR1+NMILG),RRRR(NMILG), + 2 QKOLD(NG,NSMAX,NMILG),QKDEL(NG,NSMAX,NMILG), + 3 PKL(NG,NSMAX,NSMAX,NMILG) + DOUBLE PRECISION COEF(1+NG*NSMAX,1+NG*NSMAX,NMILG) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(EPS1=1.0E-5) + DOUBLE PRECISION DP0,DP1,DP1OLD,QKD,CHORD,CHORDK,DDOT + REAL, ALLOCATABLE, DIMENSION(:) :: SIG,ZZ + REAL, ALLOCATABLE, DIMENSION(:,:) :: QKN + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: RHS +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(QKN(NSMAX,NSMAX),RHS(1+NG*NSMAX)) +*---- +* COMPUTE THE EQUIVALENT TOTAL CROSS SECTIONS IN COMPOSITE REGIONS +*---- + QKOLD(:NG,:NSMAX,:NMILG)=0.0 + QKDEL(:NG,:NSMAX,:NMILG)=0.0 + PKL(:NG,:NSMAX,:NSMAX,:NMILG)=0.0 + IPOW=MICRO-1 + DO 110 IBM=1,NMILG + MIL=IR1+IBM + DILF=1.0 + DO 10 J=1,NG + DILF=DILF-FRACT(J,MIL) + 10 CONTINUE + DP1OLD=0.0D0 + ITER=0 + DO + ITER=ITER+1 + IF(ITER.GT.100) CALL XABORT('XDRH11: CONVERGENCE FAILURE.') + DP1=DILF*SIGMA(IDIL(IBM)) + DO 80 J=1,NG + FRT=FRACT(J,MIL) + IF(FRT.LE.0.00001) GO TO 80 + ALLOCATE(SIG(NS(J))) + CHORD=0.0D0 + DO 20 K=1,NS(J) + SIG(K)=REAL(SIGMA(MIXGR(K,J,IBM))-DP1OLD) + SIG(K)=MAX(0.0,SIG(K)) + CHORD=CHORD+(RS(K+1,J)**IPOW-RS(K,J)**IPOW)*SIG(K) + 20 CONTINUE + CHORD=4.0D0*CHORD/(REAL(IPOW)*RS(NS(J)+1,J)**(IPOW-1)) + ALLOCATE(ZZ(1+IQUAD*((NS(J)*(5+NS(J)))/2))) + IF(MICRO.EQ.3) THEN + CALL SYBT1D(NS(J),RS(1,J),.FALSE.,IQUAD,ZZ) + CALL SYBALC(NS(J),NSMAX,RS(1,J),SIG,IQUAD,0.0,ZZ,QKN) + ELSE IF(MICRO.EQ.4) THEN + CALL SYBT1D(NS(J),RS(1,J),.TRUE.,IQUAD,ZZ) + CALL SYBALS(NS(J),NSMAX,RS(1,J),SIG,IQUAD,0.0,ZZ,QKN) + ENDIF + DEALLOCATE(ZZ) + IF(CHORD.GE.1.0E4) THEN + DO 25 K=1,NS(J) + CHORDK=4.0D0*(RS(K+1,J)**IPOW-RS(K,J)**IPOW)/(REAL(IPOW) + 1 *RS(NS(J)+1,J)**(IPOW-1)) + QKDEL(J,K,IBM)=REAL(CHORDK/CHORD) + DP1=DP1+FRT*VOLK(J,K)*QKDEL(J,K,IBM)*SIG(K) + 25 CONTINUE + ELSE + DO 40 K=1,NS(J) + QKD=1.0D0 + DO 30 N=1,NS(J) + QKD=QKD-QKN(K,N)*SIG(N) + 30 CONTINUE + QKDEL(J,K,IBM)=REAL(QKD) + DP1=DP1+FRT*VOLK(J,K)*QKDEL(J,K,IBM)*SIG(K) + 40 CONTINUE + ENDIF + IF(ITER.EQ.1) THEN + DO 50 K=1,NS(J) + QKOLD(J,K,IBM)=QKDEL(J,K,IBM) + 50 CONTINUE + IF(CHORD.GE.1.0E4) THEN + DO 60 K=1,NS(J) + PKL(J,K,K,IBM)=1.0/SIGMA(MIXGR(K,J,IBM)) + 60 CONTINUE + ELSE + DO 75 K=1,NS(J) + DO 70 N=1,NS(J) + PKL(J,K,N,IBM)=QKN(K,N) + 70 CONTINUE + 75 CONTINUE + ENDIF + ENDIF + DEALLOCATE(SIG) + 80 CONTINUE + IF(ABS(DP1OLD-DP1/DILF).LE.EPS1*ABS(DP1)) EXIT + DP1OLD=DP1/DILF + ENDDO + RRRR(IBM)=DILF + SIGMIN=REAL(DP1)/DILF + DO 100 J=1,NG + FRT=FRACT(J,MIL) + IF(FRT.LE.0.00001) GO TO 100 + DO 90 K=1,NS(J) + RRRR(IBM)=RRRR(IBM)+FRT*VOLK(J,K)*QKDEL(J,K,IBM) + SIGMIN=MIN(SIGMIN,SIGMA(MIXGR(K,J,IBM))) + 90 CONTINUE + 100 CONTINUE + IF((SIGMIN*(1.0+EPS1).LT.DP1/DILF).AND.(MICRO.EQ.3)) THEN + CALL XABORT('XDRH11: SANCHEZ-POMRANING MODEL FAILURE.') + ENDIF + SIGMA(IR1+IBM)=REAL(DP1)/DILF + 110 CONTINUE +*---- +* COMPUTE THE EQUIVALENT SCATTERING CROSS SECTIONS IN COMPOSITE REGIONS +*---- + COEF(:1+NG*NSMAX,:1+NG*NSMAX,:NMILG)=0.0D0 + DO 170 IBM=1,NMILG + MIL=IR1+IBM + NCO(IBM)=1 + DILF=1.0 + DP0=0.0D0 + DO 130 J=1,NG + FRT=FRACT(J,MIL) + DILF=DILF-FRT + IF(FRT.LE.0.00001) GO TO 130 + DO 120 K=1,NS(J) + DP0=DP0+FRT*VOLK(J,K)*QKOLD(J,K,IBM)*SIGMA(MIXGR(K,J,IBM)) + 120 CONTINUE + 130 CONTINUE + DP0=DP0+DILF*SIGMA(IDIL(IBM)) + COEF(1,1,IBM)=1.0D0 + RHS(1)=DILF*SIGMS(IDIL(IBM))/DP0 + IND2=1 + DO 160 J=1,NG + FRT=FRACT(J,MIL) + IF(FRT.LE.0.00001) GO TO 160 + DO 150 K=1,NS(J) + NCO(IBM)=NCO(IBM)+1 + COEF(1,IND2+K,IBM)=-FRT*VOLK(J,K)*QKOLD(J,K,IBM)* + 1 SIGMS(MIXGR(K,J,IBM))/DP0 + COEF(IND2+K,IND2+K,IBM)=1.0D0 + DO 140 N=1,NS(J) + COEF(IND2+K,IND2+N,IBM)=COEF(IND2+K,IND2+N,IBM) + 1 -PKL(J,K,N,IBM)*SIGMS(MIXGR(N,J,IBM)) + 140 CONTINUE + COEF(IND2+K,1,IBM)=-(QKOLD(J,K,IBM)-QKDEL(J,K,IBM)) + RHS(IND2+K)=QKDEL(J,K,IBM) + 150 CONTINUE + IND2=IND2+NS(J) + 160 CONTINUE + CALL ALINVD(NCO(IBM),COEF(1,1,IBM),1+NG*NSMAX,IER) + IF(IER.NE.0) CALL XABORT('XDRH11: SINGULAR MATRIX.') + DP0=DDOT(NCO(IBM),COEF(1,1,IBM),1+NG*NSMAX,RHS,1) + SIGMS(IR1+IBM)=REAL(DP0)*SIGMA(IR1+IBM) + 170 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(RHS,QKN) + RETURN + END diff --git a/Dragon/src/XDRH12.f b/Dragon/src/XDRH12.f new file mode 100644 index 0000000..0ded853 --- /dev/null +++ b/Dragon/src/XDRH12.f @@ -0,0 +1,211 @@ +*DECK XDRH12 + SUBROUTINE XDRH12 (IR1,NMILG,NG,NSMAX,MICRO,IQUAD,NS,IDIL,MIXGR, + 1 RS,FRACT,VOLK,SIGMA,SIGMS,NCO,RRRR,QKDEL,PKL,COEF) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the reduced collision probabilities for the Hebert +* double heterogeneity model (part 1). +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IR1 number of elementary mixtures in the domain. +* NMILG number of composite mixtures in the domain. +* NG number of different kind of micro structures. A kind of +* micro structure is characterized by the radius of its +* micro volumes. All the micro volumes of the same kind +* should own the same nuclear properties in a given macro +* volume. +* NSMAX maximum number of volumes (tubes or shells) in each kind of +* micro structure. +* MICRO type of micro volumes (=3 cylinder; =4 sphere). +* IQUAD quadrature parameter for the treatment of the micro volumes. +* NS number of volumes in each kind of micro structure. +* IDIL elementary mixture indices in the diluent of the composite +* mixtures. +* MIXGR elementary mixture indices in the micro structures. +* RS radius of the micro volumes. +* FRACT volumic fractions of the micro volumes. +* VOLK volumic fractions of the tubes or shells in the micro volumes. +* +*Parameters: input/output +* SIGMA total macroscopic cross sections in each mixture of the +* composite geometry. +* SIGMS scattering macroscopic cross sections in each mixture of the +* composite geometry. +* +*Parameters: output +* NCO number of volumes in each composite mixture. +* RRRR information used by XDRH20, XDRH23, XDRH30 and XDRH33. +* QKDEL information used by XDRH20, XDRH23, XDRH30 and XDRH33. +* PKL information used by XDRH20, XDRH23, XDRH30 and XDRH33. +* COEF information used by XDRH20, XDRH23, XDRH30 and XDRH33. +* +*Reference: +* A. Hebert, A Collision Probability Analysis of the Double +* Heterogeneity Problem, Nucl. Sci. Eng., 115, 177 - 184 (1993). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IR1,NMILG,NG,NSMAX,MICRO,IQUAD,NS(NG),IDIL(NMILG), + 1 MIXGR(NSMAX,NG,NMILG),NCO(NMILG) + REAL RS(NSMAX+1,NG),FRACT(NG,IR1+NMILG),VOLK(NG,NSMAX), + 1 SIGMA(0:IR1+NMILG),SIGMS(0:IR1+NMILG),RRRR(NMILG), + 2 QKDEL(NG,NSMAX,NMILG),PKL(NG,NSMAX,NSMAX,NMILG) + DOUBLE PRECISION COEF(1+NG*NSMAX,1+NG*NSMAX,NMILG) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION DP0,DP1,QKD,CHORD,CHORDK,RAPP,DDOT + REAL RGAR(2),SIGT(1) + REAL, ALLOCATABLE, DIMENSION(:) :: SIG,ZZ + REAL, ALLOCATABLE, DIMENSION(:,:) :: QKN + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: RHS +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(QKN(NSMAX,NSMAX),RHS(1+NG*NSMAX)) +*---- +* COMPUTE THE EQUIVALENT TOTAL CROSS SECTIONS IN COMPOSITE REGIONS +*---- + QKDEL(:NG,:NSMAX,:NMILG)=0.0 + PKL(:NG,:NSMAX,:NSMAX,:NMILG)=0.0 + IPOW=MICRO-1 + DO 80 IBM=1,NMILG + MIL=IR1+IBM + SIGT(1)=SIGMA(IDIL(IBM)) + DILF=1.0 + DO 10 J=1,NG + DILF=DILF-FRACT(J,MIL) + 10 CONTINUE + DP0=DILF*SIGT(1) + DP1=DP0 + DO 70 J=1,NG + FRT=FRACT(J,MIL) + IF(FRT.LE.0.00001) GO TO 70 + RGAR(1)=0.0 + RGAR(2)=RS(NS(J)+1,J) + ALLOCATE(SIG(NS(J))) + CHORD=0.0D0 + DO 20 K=1,NS(J) + SIG(K)=SIGMA(MIXGR(K,J,IBM)) + CHORD=CHORD+(RS(K+1,J)**IPOW-RS(K,J)**IPOW)*SIG(K) + 20 CONTINUE + CHORD=4.0D0*CHORD/(REAL(IPOW)*RS(NS(J)+1,J)**(IPOW-1)) + ALLOCATE(ZZ(1+IQUAD*3)) + IF(MICRO.EQ.3) THEN + CALL SYBT1D(1,RGAR(1),.FALSE.,IQUAD,ZZ) + CALL SYBALC(1,NSMAX,RGAR(1),SIGT(1),IQUAD,0.0,ZZ,QKN) + ELSE IF(MICRO.EQ.4) THEN + CALL SYBT1D(1,RGAR(1),.TRUE.,IQUAD,ZZ) + CALL SYBALS(1,NSMAX,RGAR(1),SIGT(1),IQUAD,0.0,ZZ,QKN) + ENDIF + DEALLOCATE(ZZ) + RAPP=1.0D0/(1.0D0-QKN(1,1)*SIGT(1)) + ALLOCATE(ZZ(1+IQUAD*((NS(J)*(5+NS(J)))/2))) + IF(MICRO.EQ.3) THEN + CALL SYBT1D(NS(J),RS(1,J),.FALSE.,IQUAD,ZZ) + CALL SYBALC(NS(J),NSMAX,RS(1,J),SIG(1),IQUAD,0.0,ZZ,QKN) + ELSE IF(MICRO.EQ.4) THEN + CALL SYBT1D(NS(J),RS(1,J),.TRUE.,IQUAD,ZZ) + CALL SYBALS(NS(J),NSMAX,RS(1,J),SIG(1),IQUAD,0.0,ZZ,QKN) + ENDIF + DEALLOCATE(ZZ) + IF(CHORD.GE.1.0E4) THEN + DO 25 K=1,NS(J) + CHORDK=4.0D0*(RS(K+1,J)**IPOW-RS(K,J)**IPOW)/(REAL(IPOW) + 1 *RS(NS(J)+1,J)**(IPOW-1)) + QKDEL(J,K,IBM)=REAL(CHORDK/CHORD) + FACT=FRT*VOLK(J,K)*QKDEL(J,K,IBM)*SIG(K) + DP0=DP0+FACT + DP1=DP1+FACT*RAPP + 25 CONTINUE + ELSE + DO 40 K=1,NS(J) + QKD=1.0D0 + DO 30 N=1,NS(J) + QKD=QKD-QKN(K,N)*SIG(N) + 30 CONTINUE + QKDEL(J,K,IBM)=REAL(QKD) + FACT=FRT*VOLK(J,K)*QKDEL(J,K,IBM)*SIG(K) + DP0=DP0+FACT + DP1=DP1+FACT*RAPP + 40 CONTINUE + ENDIF + IF(CHORD.GE.1.0E4) THEN + DO 50 K=1,NS(J) + PKL(J,K,K,IBM)=1.0/SIGMA(MIXGR(K,J,IBM)) + 50 CONTINUE + ELSE + DO 65 K=1,NS(J) + DO 60 N=1,NS(J) + PKL(J,K,N,IBM)=QKN(K,N) + 60 CONTINUE + 65 CONTINUE + ENDIF + DEALLOCATE(SIG) + 70 CONTINUE + SIGMA(IR1+IBM)=REAL(DP1) + RRRR(IBM)=REAL(DP1/DP0) + 80 CONTINUE +*---- +* COMPUTE THE EQUIVALENT SCATTERING CROSS SECTIONS IN COMPOSITE REGIONS +*---- + COEF(:1+NG*NSMAX,:1+NG*NSMAX,:NMILG)=0.0D0 + DO 170 IBM=1,NMILG + MIL=IR1+IBM + NCO(IBM)=1 + DILF=1.0 + DP0=0.0D0 + DO 130 J=1,NG + FRT=FRACT(J,MIL) + DILF=DILF-FRT + IF(FRT.LE.0.00001) GO TO 130 + DO 120 K=1,NS(J) + DP0=DP0+FRT*VOLK(J,K)*QKDEL(J,K,IBM)*SIGMA(MIXGR(K,J,IBM)) + 120 CONTINUE + 130 CONTINUE + DP0=DP0+DILF*SIGMA(IDIL(IBM)) + COEF(1,1,IBM)=1.0D0-(1.0D0-RRRR(IBM))*DILF*SIGMS(IDIL(IBM))/DP0 + RHS(1)=RRRR(IBM)*DILF*SIGMS(IDIL(IBM))/DP0 + IND2=1 + DO 160 J=1,NG + FRT=FRACT(J,MIL) + IF(FRT.LE.0.00001) GO TO 160 + DO 150 K=1,NS(J) + NCO(IBM)=NCO(IBM)+1 + COEF(1,IND2+K,IBM)=-FRT*VOLK(J,K)*QKDEL(J,K,IBM)* + 1 SIGMS(MIXGR(K,J,IBM))/DP0 + COEF(IND2+K,IND2+K,IBM)=1.0D0 + DO 140 N=1,NS(J) + COEF(IND2+K,IND2+N,IBM)=COEF(IND2+K,IND2+N,IBM) + 1 -PKL(J,K,N,IBM)*SIGMS(MIXGR(N,J,IBM)) + 140 CONTINUE + COEF(IND2+K,1,IBM)=-(1.0D0-RRRR(IBM))*QKDEL(J,K,IBM) + RHS(IND2+K)=RRRR(IBM)*QKDEL(J,K,IBM) + 150 CONTINUE + IND2=IND2+NS(J) + 160 CONTINUE + CALL ALINVD(NCO(IBM),COEF(1,1,IBM),1+NG*NSMAX,IER) + IF(IER.NE.0) CALL XABORT('XDRH12: SINGULAR MATRIX.') + DP0=DDOT(NCO(IBM),COEF(1,1,IBM),1+NG*NSMAX,RHS,1) + SIGMS(IR1+IBM)=REAL(DP0)*SIGMA(IR1+IBM) + 170 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(RHS,QKN) + RETURN + END diff --git a/Dragon/src/XDRH13.f b/Dragon/src/XDRH13.f new file mode 100644 index 0000000..607dfae --- /dev/null +++ b/Dragon/src/XDRH13.f @@ -0,0 +1,205 @@ +*DECK XDRH13 + SUBROUTINE XDRH13 (IR1,NMILG,NG,NSMAX,IQUAD,FRTM,NS,IDIL,MIXGR, + 1 RS,FRACT,SIGMA,SIGMS,P1I,P1DI,P1KI,SIGA1) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the reduced collision probabilities for the She-Liu-Shi +* double heterogeneity model (part 1). +* +*Copyright: +* Copyright (C) 2019 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Chambon +* +*Parameters: input +* IR1 number of elementary mixtures in the domain. +* NMILG number of composite mixtures in the domain. +* NG number of different kind of micro structures. A kind of +* micro structure is characterized by the radius of its +* micro volumes. All the micro volumes of the same kind +* should own the same nuclear properties in a given macro +* volume. +* NSMAX maximum number of volumes (tubes or shells) in each kind of +* micro structure. +* IQUAD quadrature parameter for the treatment of the micro volumes. +* if IQUAD < 0, lines with regular interval are applied. +* FRTM minimum volume fraction of the grain in the representative +* volume for She-Liu-Shi models. +* NS number of volumes in each kind of micro structure. +* IDIL elementary mixture indices in the diluent of the composite +* mixtures. +* MIXGR elementary mixture indices in the micro structures. +* RS radius of the micro volumes. +* FRACT volumic fractions of the micro volumes. +* +*Parameters: input/output +* SIGMA total macroscopic cross sections in each mixture of the +* composite geometry. +* SIGMS scattering macroscopic cross sections in each mixture of the +* composite geometry. +* +*Parameters: output +* P1I non collision probability in subvolume with 1 grain type. +* P1KI escape probability from layer k in subvolume +* with 1 grain type. +* P1DI escape probability from matrix in subvolume +* with 1 grain type. +* SIGA1 output cross sections. +* +*Reference: +* D. She, Z. Liu, and L. Shi, An Equivalent Homogenization Method for +* Treating the Stochastic Media, Nucl. Sci. Eng., 185, 351-360 (2018) +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IR1,NMILG,NG,NSMAX,IQUAD,NS(NG),IDIL(NMILG), + 1 MIXGR(NSMAX,NG,NMILG) + REAL FRTM,RS(NSMAX+1,NG),FRACT(NG,IR1+NMILG),SIGMA(0:IR1+NMILG), + 1 SIGMS(0:IR1+NMILG),P1I(NG,NMILG),P1DI(NG,NMILG), + 2 P1KI(NSMAX,NG,NMILG),SIGA1(NG,NMILG) +*---- +* LOCAL VARIABLES +*---- + INTEGER NR,IBM,J,K,N,M,MIL,NSMAX2 + REAL DILF,DX,DXFACT,DRMIN,X,EP,EPI1,EPI2,LM,LGAR,SIGMA1,SIGMS1, + > FRT,RMAX,SIGT,XI,FRTT + DOUBLE PRECISION P1,P1D + REAL RGAR(NSMAX+2),LR(NSMAX+1) +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: SIG + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: P1K +*---- +* SCRATCH STORAGE ALLOCATION +*---- + NSMAX2=NSMAX+NG + ALLOCATE(SIG(NSMAX2),P1K(NSMAX2)) +*---- +* COMPUTE THE EQUIVALENT TOTAL AND SCATTERING CROSS SECTIONS +* IN COMPOSITE REGIONS +*---- + DXFACT=100.0 + IF(IQUAD.LT.0) DXFACT=REAL(-IQUAD) + DO 180 IBM=1,NMILG + MIL=IR1+IBM + SIGT=SIGMA(IDIL(IBM)) + DILF=1.0 + SIGMA(IR1+IBM)=0.0 + SIGMS(IR1+IBM)=0.0 + DO 10 J=1,NG + DILF=DILF-FRACT(J,MIL) + 10 CONTINUE + DO 130 J=1,NG + FRT=FRACT(J,MIL) + IF(FRT.LE.0.00001) GO TO 130 + NR=NS(J) + DRMIN=RS(NS(J)+1,J) + RGAR(1)=0.0 + DO 15 K=2,NS(J)+1 + DRMIN=MIN(DRMIN,RS(K,J)-RS(K-1,J)) + RGAR(K)=RS(K,J) + 15 CONTINUE + DO 20 K=1,NS(J) + P1K(K)=0.0D0 + SIG(K)=SIGMA(MIXGR(K,J,IBM)) + 20 CONTINUE + FRTT=1.0-DILF +* FRT too small -> additional ring of matrix + IF((1.0-DILF).LT.FRTM) THEN + NR=NR+1 + RGAR(NR+1)=RGAR(NR)*(FRTM/FRT)**(1.0/3.0) + SIG(NR)=SIGT + FRTT=FRTM + ENDIF + RMAX=RGAR(NR+1) + LGAR=4.0/3.0*RMAX/FRTT + P1=0.0D0 + P1D=0.0D0 + DX=DRMIN/DXFACT + XI=-0.5 + K=1 +* integral over radius to compute collision prob. + 30 XI=XI+1.0 + X=DX*XI + IF (X.GT.RGAR(K+1)) K=K+1 + IF (K.GT.NR) GO TO 100 +* Ref 1): Eq 13-17 +* compute segment lengths + LM=LGAR/2.0 + DO 40 N=1,NR + IF (N.LT.K) THEN + LR(N)=0.0D0 + ELSEIF (N.EQ.K) THEN + LR(N)=(RGAR(N+1)**2.0 - X**2.0)**0.5 + ELSE + LR(N)=(RGAR(N+1)**2.0 - X**2.0)**0.5 + 1 -(RGAR(N)**2.0 - X**2.0)**0.5 + ENDIF + LM=LM-LR(N) + 40 CONTINUE +* Ref 1): Eq 18-19 + EP=2*SIGT*LM + DO 50 N=1,NR + EP=EP+2*LR(N)*SIG(N) + 50 CONTINUE + P1=P1+X*DX*EXP(-EP) + DO 70 N=K,NR + EPI1=SIGT*LM + EPI2=SIGT*LM + DO 60 M=1,NR + IF (M.LT.N) THEN + EPI2=EPI2+2*LR(M)*SIG(M) + ELSEIF (M.EQ.N) THEN + EPI2=EPI2+LR(M)*SIG(M) + ELSE + EPI1=EPI1+LR(M)*SIG(M) + EPI2=EPI2+LR(M)*SIG(M) + ENDIF + 60 CONTINUE +* bug + IF(N.GT.NSMAX2) CALL XABORT('XDRH13: NSMAX OVERFLOW.') + P1K(N)=P1K(N)+X*DX*(EXP(-EPI1)+EXP(-EPI2))* + 1 (1.0D0-EXP(-LR(N)*SIG(N))) + 70 CONTINUE + GO TO 30 + 100 CONTINUE + P1=P1*2/RMAX**2.0 + P1I(J,IBM)=REAL(P1) + P1D=1.0D0-P1 + DO 110 K=1,NS(J) + P1K(K)=P1K(K)*2/RMAX**2.0 + P1KI(K,J,IBM)=REAL(P1K(K)) +* collision prob. conservation, Ref 1): Eq 4 + P1D=P1D-P1K(K) + 110 CONTINUE + P1DI(J,IBM)=REAL(P1D) +* Ref 1): Eq 5 + SIGMA1=REAL(-LOG(P1)/LGAR) + SIGA1(J,IBM)=SIGMA1 + SIGMS1=REAL(P1D/(1.0-P1)*SIGMA1/SIGT*SIGMS(IDIL(IBM))) + DO 120 K=1,NS(J) + SIGMS1=REAL(SIGMS1+P1K(K)/(1.0-P1)*SIGMA1/SIG(K)* + 1 SIGMS(MIXGR(K,J,IBM))) + 120 CONTINUE +* Ref 1): Eq 26 + SIGMA(IR1+IBM)=SIGMA(IR1+IBM)+SIGMA1*FRT/(1-DILF) + SIGMS(IR1+IBM)=SIGMS(IR1+IBM)+SIGMS1*FRT/(1-DILF) + 130 CONTINUE + 180 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(P1K,SIG) + RETURN + END diff --git a/Dragon/src/XDRH20.f b/Dragon/src/XDRH20.f new file mode 100644 index 0000000..80345ee --- /dev/null +++ b/Dragon/src/XDRH20.f @@ -0,0 +1,182 @@ +*DECK XDRH20 + SUBROUTINE XDRH20 (IBIHET,NUN,IR1,NMILG,NREG,NREG2,NG,NSMAX, + 1 KEYFLX,NS,IDIL,MIXGR,IBI,FRACT,VOLK,SIGMA,NCO,RRRR,QKOLD,QKDEL, + 2 PKL,COEF,SUNKNO,FLUAS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the macro-source for the Hebert or Sanchez-Pomraning +* double heterogeneity model (part 2). +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IBIHET type of double-heterogeneity method (=1 Sanchez-Pomraning +* model; =2 Hebert model). +* NUN number of unknown in the system. +* IR1 number of mixtures in the domain. +* NMILG number of composite mixtures in the domain. +* NREG number of volumes in the composite geometry. +* NREG2 number of volumes in the macro geometry. +* NG number of different kind of micro structures. A kind of +* micro structure is characterized by the radius of its +* micro volumes. All the micro volumes of the same kind +* should own the same nuclear properties in a given macro +* volume. +* NSMAX maximum number of volumes (tubes or shells) in each kind of +* micro structure. +* KEYFLX flux elements in unknown system. +* NS number of volumes in each kind of micro structure. +* IDIL elementary mixture indices in the diluent of the composite +* mixtures. +* MIXGR elementary mixture indices in the micro structures. +* IBI type of mixture in each volume of the macro geometry. +* If IBI(IKK) is greater than IR1, the volume IKK contains a +* micro structure. +* FRACT volumic fractions of the micro volumes. +* VOLK volumic fractions of the tubes or shells in the micro volumes. +* SIGMA equivalent total macroscopic cross section in each mixture. +* NCO number of volumes in each composite mixture. +* QKOLD information computed by XDRH11. +* QKDEL information computed by XDRH11 or XDRH12. +* PKL information computed by XDRH11 or XDRH12. +* RRRR information computed by XDRH11 or XDRH12. +* COEF information computed by XDRH11 or XDRH12. +* SUNKNO sources defined in the composite geometry. +* +*Parameters: output +* FLUAS equivalent macro-source. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IBIHET,NUN,IR1,NMILG,NREG,NREG2,NG,NSMAX,KEYFLX(NREG), + 1 NS(NG),IDIL(NMILG),MIXGR(NSMAX,NG,NMILG),IBI(NREG2),NCO(NMILG) + REAL FRACT(NG,IR1+NMILG),VOLK(NG,NSMAX),SIGMA(0:IR1+NMILG), + 1 RRRR(NMILG),QKOLD(NG,NSMAX,NMILG),QKDEL(NG,NSMAX,NMILG), + 2 PKL(NG,NSMAX,NSMAX,NMILG),SUNKNO(NUN),FLUAS(NREG2) + DOUBLE PRECISION COEF(1+NG*NSMAX,1+NG*NSMAX,NMILG) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION DP0,DDOT + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: RHS +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(RHS(1+NG*NSMAX)) +* + IF(IBIHET.EQ.1) THEN + GO TO 10 + ELSE IF(IBIHET.EQ.2) THEN + GO TO 60 + ELSE + CALL XABORT('XDRH20: INVALID DOUBLE HETEROGENEITY METHOD.') + ENDIF +*---- +* COMPUTE THE EQUIVALENT MACRO-SOURCE (SANCHEZ-POMRANING METHOD). +*---- + 10 IND1=NREG2 + DO 50 I=1,NREG2 + MIL=IBI(I) + IF(MIL.GT.IR1) THEN + IBM=MIL-IR1 + INDGAR=IND1 + DILF=1.0 + DP0=0.0D0 + DO 30 J=1,NG + FRT=FRACT(J,MIL) + DILF=DILF-FRT + IF(FRT.LE.0.00001) GO TO 30 + DO 20 K=1,NS(J) + DP0=DP0+FRT*VOLK(J,K)*QKOLD(J,K,IBM)*SIGMA(MIXGR(K,J,IBM)) + 20 CONTINUE + IND1=IND1+NS(J) + 30 CONTINUE + DP0=DP0+DILF*SIGMA(IDIL(IBM)) + RHS(1)=DILF*SUNKNO(KEYFLX(I))/DP0 + IND1=INDGAR + IND2=1 + DO 40 J=1,NG + FRT=FRACT(J,MIL) + IF(FRT.LE.0.00001) GO TO 40 + DO K=1,NS(J) + IUNK=KEYFLX(IND1+K) + RHS(1)=RHS(1)+FRT*VOLK(J,K)*QKOLD(J,K,IBM)*SUNKNO(IUNK)/DP0 + RHS(IND2+K)=0.0D0 + DO N=1,NS(J) + IUNK=KEYFLX(IND1+N) + RHS(IND2+K)=RHS(IND2+K)+PKL(J,K,N,IBM)*SUNKNO(IUNK) + ENDDO + ENDDO + IND1=IND1+NS(J) + IND2=IND2+NS(J) + 40 CONTINUE + DP0=DDOT(NCO(IBM),COEF(1,1,IBM),1+NG*NSMAX,RHS,1) + FLUAS(I)=REAL(DP0)*SIGMA(IBI(I))*RRRR(IBM) + ELSE + FLUAS(I)=SUNKNO(KEYFLX(I)) + ENDIF + 50 CONTINUE + RETURN +*---- +* COMPUTE THE EQUIVALENT MACRO-SOURCE (HEBERT METHOD). +*---- + 60 IND1=NREG2 + DO 100 I=1,NREG2 + MIL=IBI(I) + IF(MIL.GT.IR1) THEN + IBM=MIL-IR1 + INDGAR=IND1 + DILF=1.0 + DP0=0.0D0 + DO 80 J=1,NG + FRT=FRACT(J,MIL) + DILF=DILF-FRT + IF(FRT.LE.0.00001) GO TO 80 + DO 70 K=1,NS(J) + DP0=DP0+FRT*VOLK(J,K)*QKDEL(J,K,IBM)*SIGMA(MIXGR(K,J,IBM)) + 70 CONTINUE + IND1=IND1+NS(J) + 80 CONTINUE + DP0=DP0+DILF*SIGMA(IDIL(IBM)) + RHS(1)=DILF*SUNKNO(KEYFLX(I))/DP0 + IND1=INDGAR + IND2=1 + DO 90 J=1,NG + FRT=FRACT(J,MIL) + IF(FRT.LE.0.00001) GO TO 90 + DO K=1,NS(J) + IUNK=KEYFLX(IND1+K) + RHS(1)=RHS(1)+FRT*VOLK(J,K)*QKDEL(J,K,IBM)*SUNKNO(IUNK)/DP0 + RHS(IND2+K)=0.0D0 + DO N=1,NS(J) + IUNK=KEYFLX(IND1+N) + RHS(IND2+K)=RHS(IND2+K)+PKL(J,K,N,IBM)*SUNKNO(IUNK) + ENDDO + ENDDO + IND1=IND1+NS(J) + IND2=IND2+NS(J) + 90 CONTINUE + DP0=DDOT(NCO(IBM),COEF(1,1,IBM),1+NG*NSMAX,RHS,1) + FLUAS(I)=REAL(DP0)*SIGMA(IBI(I)) + ELSE + FLUAS(I)=SUNKNO(KEYFLX(I)) + ENDIF + 100 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(RHS) + RETURN + END diff --git a/Dragon/src/XDRH23.f b/Dragon/src/XDRH23.f new file mode 100644 index 0000000..10f4122 --- /dev/null +++ b/Dragon/src/XDRH23.f @@ -0,0 +1,116 @@ +*DECK XDRH23 + SUBROUTINE XDRH23 (IBIHET,NUN,IR1,NMILG,NREG,NREG2,NG,NSMAX, + 1 KEYFLX,NS,IDIL,MIXGR,IBI,FRACT,SIGMA,P1I,P1DI,P1KI,SIGA1,SUNKNO, + 2 FLUAS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the macro-source for the She-Liu-Shi double +* heterogeneity model (part 2). +* +*Copyright: +* Copyright (C) 2019 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Chambon +* +*Parameters: input +* IBIHET type of double-heterogeneity method (=1 Sanchez-Pomraning +* model; =2 Hebert model). +* NUN number of unknown in the system. +* IR1 number of mixtures in the domain. +* NMILG number of composite mixtures in the domain. +* NREG number of volumes in the composite geometry. +* NREG2 number of volumes in the macro geometry. +* NG number of different kind of micro structures. A kind of +* micro structure is characterized by the radius of its +* micro volumes. All the micro volumes of the same kind +* should own the same nuclear properties in a given macro +* volume. +* NSMAX maximum number of volumes (tubes or shells) in each kind of +* micro structure. +* KEYFLX flux elements in unknown system. +* NS number of volumes in each kind of micro structure. +* IDIL elementary mixture indices in the diluent of the composite +* mixtures. +* MIXGR elementary mixture indices in the micro structures. +* IBI type of mixture in each volume of the macro geometry. +* If IBI(IKK) is greater than IR1, the volume IKK contains a +* micro structure. +* FRACT volumic fractions of the micro volumes. +* SIGMA equivalent total macroscopic cross section in each mixture. +* P1I non collision probability in subvolume with 1 grain type. +* P1KI escape probability from layer k in subvolume +* with 1 grain type. +* P1DI escape probability from matrix in subvolume +* with 1 grain type. +* SIGA1 equiv. total macro. XS with 1 grain type. +* SUNKNO sources defined in the composite geometry. +* +*Parameters: output +* FLUAS equivalent macro-source. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IBIHET,NUN,IR1,NMILG,NREG,NREG2,NG,NSMAX,KEYFLX(NREG), + 1 NS(NG),IDIL(NMILG),MIXGR(NSMAX,NG,NMILG),IBI(NREG2) + REAL FRACT(NG,IR1+NMILG),SIGMA(0:IR1+NMILG),P1I(NG,NMILG), + 1 P1DI(NG,NMILG),P1KI(NSMAX,NG,NMILG),SIGA1(NG,NMILG), + 2 SUNKNO(NUN),FLUAS(NREG2) +*---- +* LOCAL VARIABLES +*---- + INTEGER IND1,I,MIL,K,J,IBM,IUNK + REAL Q1I,DILF,FRT +*---- +* SCRATCH STORAGE ALLOCATION +*---- + IF(IBIHET.NE.3) THEN + CALL XABORT('XDRH23: INVALID DOUBLE HETEROGENEITY METHOD.') + ENDIF +*---- +* COMPUTE THE EQUIVALENT MACRO-SOURCE (SLS METHOD). +*---- + IND1=NREG2 + DO 60 I=1,NREG2 + MIL=IBI(I) + IF(MIL.GT.IR1) THEN + FLUAS(I)=0.0 + IBM=MIL-IR1 + DILF=1.0 + Q1I=0.0 + DO 30 J=1,NG + FRT=FRACT(J,MIL) + DILF=DILF-FRT + 30 CONTINUE + DO 50 J=1,NG + FRT=FRACT(J,MIL) + IF(FRT.LE.0.00001) GO TO 40 + Q1I=P1DI(J,IBM)/(1.0-P1I(J,IBM))*SUNKNO(KEYFLX(I)) + > *SIGA1(J,IBM)/SIGMA(IDIL(IBM)) + DO K=1,NS(J) + IUNK=KEYFLX(IND1+K) + Q1I=Q1I+P1KI(K,J,IBM)/(1.0-P1I(J,IBM))*SUNKNO(IUNK) + > *SIGA1(J,IBM)/SIGMA(MIXGR(K,J,IBM)) + ENDDO + IND1=IND1+NS(J) + 40 FLUAS(I)=FLUAS(I)+Q1I*FRT + 50 CONTINUE + FLUAS(I)=FLUAS(I)/(1.0-DILF) + ELSE + FLUAS(I)=SUNKNO(KEYFLX(I)) + ENDIF + 60 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + RETURN + END diff --git a/Dragon/src/XDRH30.f b/Dragon/src/XDRH30.f new file mode 100644 index 0000000..bdb778f --- /dev/null +++ b/Dragon/src/XDRH30.f @@ -0,0 +1,212 @@ +*DECK XDRH30 + SUBROUTINE XDRH30 (IBIHET,NUN,IR1,NMILG,NREG,NREG2,NG,NSMAX, + 1 KEYFLX,NS,IDIL,MIXGR,IBI,FRACT,VOLK,SIGMA,SIGMS,NCO,RRRR,QKOLD, + 2 QKDEL,PKL,COEF,SUNKNO,FUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the composite flux for the Hebert or Sanchez-Pomraning +* double heterogeneity model (part 3). +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IBIHET type of double-heterogeneity method (=1 Sanchez-Pomraning +* model; =2 Hebert model). +* NUN number of unknown in the system. +* IR1 number of mixtures in the domain. +* NMILG number of composite mixtures in the domain. +* NREG number of volumes in the composite geometry. +* NREG2 number of volumes in the macro geometry. +* NG number of different kind of micro structures. A kind of +* micro structure is characterized by the radius of its +* micro volumes. All the micro volumes of the same kind +* should own the same nuclear properties in a given macro +* volume. +* NSMAX maximum number of volumes (tubes or shells) in each kind of +* micro structure. +* KEYFLX flux elements in unknown system. +* NS number of volumes in each kind of micro structure. +* IDIL elementary mixture indices in the diluent of the composite +* mixtures. +* MIXGR elementary mixture indices in the micro structures. +* IBI type of mixture in each volume of the macro geometry. +* If IBI(IKK) is greater than IR1, the volume IKK contains a +* micro structure. +* FRACT volumic fractions of the micro volumes. +* VOLK volumic fractions of the tubes or shells in the micro volumes. +* SIGMA equivalent total macroscopic cross section in each mixture. +* SIGMS equivalent scattering macroscopic cross section in each +* mixture. +* NCO number of volumes in each composite mixture. +* QKOLD information computed by XDRH11. +* QKDEL information computed by XDRH11 or XDRH12. +* PKL information computed by XDRH11 or XDRH12. +* RRRR information computed by XDRH11 or XDRH12. +* COEF information computed by XDRH11 or XDRH12. +* SUNKNO sources defined in the composite geometry. +* +*Parameters: input/output +* FUNKNO macro-flux on input (solution of the transport equation +* defined over the macro-geometry) and composite flux on output. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IBIHET,NUN,IR1,NMILG,NREG,NREG2,NG,NSMAX,KEYFLX(NREG), + 1 NS(NG),IDIL(NMILG),MIXGR(NSMAX,NG,NMILG),IBI(NREG2),NCO(NMILG) + REAL FRACT(NG,IR1+NMILG),VOLK(NG,NSMAX),SIGMA(0:IR1+NMILG), + 1 SIGMS(0:IR1+NMILG),RRRR(NMILG),QKOLD(NG,NSMAX,NMILG), + 2 QKDEL(NG,NSMAX,NMILG),PKL(NG,NSMAX,NSMAX,NMILG),SUNKNO(NUN), + 3 FUNKNO(NUN) + DOUBLE PRECISION COEF(1+NG*NSMAX,1+NG*NSMAX,NMILG) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION DP0,DDOT + REAL, ALLOCATABLE, DIMENSION(:) :: FLUAS + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: RHS +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(FLUAS(NREG2),RHS(1+NG*NSMAX)) +* + IF(IBIHET.EQ.1) THEN + GO TO 10 + ELSE IF(IBIHET.EQ.2) THEN + GO TO 70 + ELSE + CALL XABORT('XDRH30: INVALID DOUBLE HETEROGENEITY METHOD.') + ENDIF +*---- +* COMPUTE THE COMPOSITE FLUX (SANCHEZ-POMRANING METHOD). +*---- + 10 IND1=NREG2 + DO 60 I=1,NREG2 + MIL=IBI(I) + IF(MIL.GT.IR1) THEN + IBM=MIL-IR1 + FUNKNO(KEYFLX(I))=FUNKNO(KEYFLX(I))/RRRR(IBM) + INDGAR=IND1 + DILF=1.0 + DP0=0.0D0 + DO 30 J=1,NG + FRT=FRACT(J,MIL) + DILF=DILF-FRT + IF(FRT.LE.0.00001) GO TO 30 + DO 20 K=1,NS(J) + DP0=DP0+FRT*VOLK(J,K)*QKOLD(J,K,IBM)*SIGMA(MIXGR(K,J,IBM)) + 20 CONTINUE + IND1=IND1+NS(J) + 30 CONTINUE + DP0=DP0+DILF*SIGMA(IDIL(IBM)) + IUNK=KEYFLX(I) + RHS(1)=DILF*(SIGMS(IDIL(IBM))*FUNKNO(IUNK)+SUNKNO(IUNK))/DP0 + IND1=INDGAR + IND2=1 + DO 40 J=1,NG + FRT=FRACT(J,MIL) + IF(FRT.LE.0.00001) GO TO 40 + DO K=1,NS(J) + IUNK=KEYFLX(IND1+K) + RHS(1)=RHS(1)+FRT*VOLK(J,K)*QKOLD(J,K,IBM)*SUNKNO(IUNK)/DP0 + RHS(IND2+K)=QKDEL(J,K,IBM)*FUNKNO(KEYFLX(I)) + DO N=1,NS(J) + IUNK=KEYFLX(IND1+N) + RHS(IND2+K)=RHS(IND2+K)+PKL(J,K,N,IBM)*SUNKNO(IUNK) + ENDDO + ENDDO + IND1=IND1+NS(J) + IND2=IND2+NS(J) + 40 CONTINUE + IND1=INDGAR + IND2=1 + DO 50 J=1,NG + IF(FRACT(J,MIL).LE.0.00001) GO TO 50 + DO K=1,NS(J) + IUNK=KEYFLX(IND1+K) + DP0=DDOT(NCO(IBM),COEF(IND2+K,1,IBM),1+NG*NSMAX,RHS,1) + FUNKNO(IUNK)=REAL(DP0) + ENDDO + IND1=IND1+NS(J) + IND2=IND2+NS(J) + 50 CONTINUE + ENDIF + 60 CONTINUE + RETURN +*---- +* COMPUTE THE COMPOSITE FLUX (HEBERT METHOD). +*---- + 70 IND1=NREG2 + DO 120 I=1,NREG2 + MIL=IBI(I) + IF(MIL.GT.IR1) THEN + IBM=MIL-IR1 + INDGAR=IND1 + DILF=1.0 + DP0=0.0D0 + DO 90 J=1,NG + FRT=FRACT(J,MIL) + DILF=DILF-FRT + IF(FRT.LE.0.00001) GO TO 90 + DO 80 K=1,NS(J) + DP0=DP0+FRT*VOLK(J,K)*QKDEL(J,K,IBM)*SIGMA(MIXGR(K,J,IBM)) + 80 CONTINUE + IND1=IND1+NS(J) + 90 CONTINUE + DP0=DP0+DILF*SIGMA(IDIL(IBM)) + IUNK=KEYFLX(I) + RHS(1)=DILF*(RRRR(IBM)*SIGMS(IDIL(IBM))*FUNKNO(IUNK)+ + 1 SUNKNO(IUNK))/DP0 + IND1=INDGAR + IND2=1 + DO 100 J=1,NG + FRT=FRACT(J,MIL) + IF(FRT.LE.0.00001) GO TO 100 + DO K=1,NS(J) + IUNK=KEYFLX(IND1+K) + RHS(1)=RHS(1)+FRT*VOLK(J,K)*QKDEL(J,K,IBM)*SUNKNO(IUNK)/DP0 + RHS(IND2+K)=RRRR(IBM)*QKDEL(J,K,IBM)*FUNKNO(KEYFLX(I)) + DO N=1,NS(J) + IUNK=KEYFLX(IND1+N) + RHS(IND2+K)=RHS(IND2+K)+PKL(J,K,N,IBM)*SUNKNO(IUNK) + ENDDO + ENDDO + IND1=IND1+NS(J) + IND2=IND2+NS(J) + 100 CONTINUE + IND1=INDGAR + IND2=1 + DO 110 J=1,NG + IF(FRACT(J,MIL).LE.0.00001) GO TO 110 + DP0=DDOT(NCO(IBM),COEF(1,1,IBM),1+NG*NSMAX,RHS,1) + FLUAS(I)=REAL(DP0)*SIGMA(IBI(I)) + DO K=1,NS(J) + IUNK=KEYFLX(IND1+K) + DP0=DDOT(NCO(IBM),COEF(IND2+K,1,IBM),1+NG*NSMAX,RHS,1) + FUNKNO(IUNK)=REAL(DP0) + ENDDO + IND1=IND1+NS(J) + IND2=IND2+NS(J) + 110 CONTINUE + IUNK=KEYFLX(I) + FUNKNO(IUNK)=RRRR(IBM)*FUNKNO(IUNK)+(1.0-RRRR(IBM))*FLUAS(I)/ + 1 SIGMA(IBI(I)) + ENDIF + 120 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(RHS,FLUAS) + RETURN + END diff --git a/Dragon/src/XDRH33.f b/Dragon/src/XDRH33.f new file mode 100644 index 0000000..9aa5ced --- /dev/null +++ b/Dragon/src/XDRH33.f @@ -0,0 +1,117 @@ +*DECK XDRH33 + SUBROUTINE XDRH33 (IBIHET,NUN,IR1,NMILG,NREG,NREG2,NG,NSMAX, + 1 KEYFLX,NS,IDIL,MIXGR,IBI,FRACT,VOLK,SIGMA,P1I,P1DI,P1KI,SIGA1, + 2 FUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the composite flux for the She-Liu-Shi double +* heterogeneity model (part 3). +* +*Copyright: +* Copyright (C) 2019 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Chambon +* +*Parameters: input +* IBIHET type of double-heterogeneity method (=1 Sanchez-Pomraning +* model; =2 Hebert model). +* NUN number of unknown in the system. +* IR1 number of mixtures in the domain. +* NMILG number of composite mixtures in the domain. +* NREG number of volumes in the composite geometry. +* NREG2 number of volumes in the macro geometry. +* NG number of different kind of micro structures. A kind of +* micro structure is characterized by the radius of its +* micro volumes. All the micro volumes of the same kind +* should own the same nuclear properties in a given macro +* volume. +* NSMAX maximum number of volumes (tubes or shells) in each kind of +* micro structure. +* KEYFLX flux elements in unknown system. +* NS number of volumes in each kind of micro structure. +* IDIL elementary mixture indices in the diluent of the composite +* mixtures. +* MIXGR elementary mixture indices in the micro structures. +* IBI type of mixture in each volume of the macro geometry. +* If IBI(IKK) is greater than IR1, the volume IKK contains a +* micro structure. +* FRACT volumic fractions of the micro volumes. +* VOLK volumic fractions of the tubes or shells in the micro volumes. +* SIGMA equivalent total macroscopic cross section in each mixture. +* P1I non collision probability in subvolume with 1 grain type. +* P1KI escape probability from layer k in subvolume +* with 1 grain type. +* P1DI escape probability from matrix in subvolume +* with 1 grain type. +* SIGA1 corrected cross section. +* +*Parameters: input/output +* FUNKNO macro-flux on input (solution of the transport equation +* defined over the macro-geometry) and composite flux on output. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IBIHET,NUN,IR1,NMILG,NREG,NREG2,NG,NSMAX,KEYFLX(NREG), + 1 NS(NG),IDIL(NMILG),MIXGR(NSMAX,NG,NMILG),IBI(NREG2) + REAL FRACT(NG,IR1+NMILG),VOLK(NG,NSMAX),SIGMA(0:IR1+NMILG), + 1 P1I(NG,NMILG),P1DI(NG,NMILG),P1KI(NSMAX,NG,NMILG), + 2 SIGA1(NG,NMILG),FUNKNO(NUN) +*---- +* LOCAL VARIABLES +*---- + INTEGER IBM,I,J,K,IUNK,IND1,MIL + REAL FAVG,SIGTT,DILF,FRT +*---- +* SCRATCH STORAGE ALLOCATION +*---- + IF(IBIHET.NE.3) THEN + CALL XABORT('XDRH33: INVALID DOUBLE HETEROGENEITY METHOD.') + ENDIF +*---- +* COMPUTE THE COMPOSITE FLUX. +*---- + IND1=NREG2 + DO 60 I=1,NREG2 + MIL=IBI(I) + IF(MIL.GT.IR1) THEN + IBM=MIL-IR1 + FAVG=FUNKNO(KEYFLX(I)) + SIGTT=SIGMA(IR1+IBM) + DILF=1.0 + DO 30 J=1,NG + FRT=FRACT(J,MIL) + DILF=DILF-FRT + IF(FRT.LE.0.00001) GO TO 30 + 30 CONTINUE +* flux in composite matrix + FUNKNO(KEYFLX(I))=0.0 + IUNK=KEYFLX(I) + DO 40 J=1,NG + FRT=FRACT(J,MIL) + IF(FRT.LE.0.00001) GO TO 40 + FUNKNO(KEYFLX(I))=FUNKNO(KEYFLX(I))+FAVG*SIGA1(J,IBM) + > /SIGMA(IDIL(IBM))/(1.0-P1I(J,IBM))*P1DI(J,IBM)/DILF + DO K=1,NS(J) + IUNK=KEYFLX(IND1+K) + FUNKNO(IUNK)=FAVG*SIGA1(J,IBM)/SIGMA(MIXGR(K,J,IBM)) + > /(1.0-P1I(J,IBM))*P1KI(K,J,IBM)/(1.0-DILF)/VOLK(J,K) + ENDDO + IND1=IND1+NS(J) + 40 CONTINUE + ENDIF + 60 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + RETURN + END diff --git a/Dragon/src/XDRKIN.f b/Dragon/src/XDRKIN.f new file mode 100644 index 0000000..4608e41 --- /dev/null +++ b/Dragon/src/XDRKIN.f @@ -0,0 +1,135 @@ +*DECK XDRKIN + SUBROUTINE XDRKIN(DX,NBX,MLOG,BIV,PASV,XLIMV) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Construct Bickley tables for KI1(X), KI2(X), KI3(X), KI4(X), KI5(X), +* taking into account logarithmic singularities for KI1(X) and KI2(X). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* DX step for tables (here, DX=0.02d0). +* NBX nb element in tables (here, NBX=600). +* MLOG interval for logarithmic singularities (suggested values: +* MLOG(1)=30, MLOG(2)=15, MLOG(3)= 0, MLOG(4)= 0, MLOG(5)= 0). +* +*Parameters: output +* BIV elements of quadratic BICKLEY table. +* PASV step quadratic of BICKLEY table. +* XLMV upper limit of quadratic BICKLEY table. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +***** CALLS: *AKIN10* ROUTINE FOR ACCURATE KIN(X) BICKLEY VALUES +* *AK0BES* ROUTINE FOR ACCURATE K0(X) BESSEL VALUES +* *AK1BES* ROUTINE FOR ACCURATE K1(X) BESSEL VALUES +*---- +* SUBROUTINE ARGUMENTS +*---- + DOUBLE PRECISION DX + INTEGER NBX,MLOG(5) + REAL BIV(0:NBX,3,5),PASV(5),XLIMV(5) +*---- +* LOCAL VARIABLES +*---- + INTEGER I,KI,IORD + DOUBLE PRECISION X, AKIN(-1:10), AK0BES, AK1BES + DOUBLE PRECISION GAMMA, PIO2, PAS, XLIM + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: C0, C1, C2 + PARAMETER ( GAMMA=0.57721566490153D0, + > PIO2= 1.57079632679490D0 ) +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(C0(5,0:NBX), C1(5,0:NBX), C2(5,0:NBX)) +* + IF( MLOG(3).GT.0.OR.MLOG(4).GT.0.OR.MLOG(5).GT.0 )GOTO 99 +* + IF( NBX .NE. 600 )GOTO 97 + IF( DX .NE.0.02D0 )GOTO 98 + PAS= 1.0D0/DX + XLIM= DBLE(NBX)*DX + DO 10 I=1,5 + XLIMV(I)=REAL(XLIM) + PASV(I)=REAL(PAS) + 10 CONTINUE +*---- +* FIRST, WE CONSTRUCT THE TABLES USING ACCURATE *AKIN10* VALUES +*---- + X= 0.D0 + CALL AKIN10(X,AKIN(1)) + AKIN( 0)= 0.D0 + AKIN(-1)= 0.D0 + DO 30 I= 0, NBX-1 + DO 20 KI= 1, 5 + C2(KI,I)= 0.5D0 * AKIN(KI-2) + C1(KI,I)= -(AKIN(KI-1)+X*AKIN(KI-2)) + C0(KI,I)= AKIN(KI)+X*(AKIN(KI-1)+X*C2(KI,I)) + 20 CONTINUE + X= X + DX + CALL AKIN10(X,AKIN(1)) + AKIN( 0)= AK0BES(X) + AKIN(-1)= AK1BES(X) + 30 CONTINUE + DO 40 KI= 1, 5 + C0(KI,NBX)= 0.D0 + C1(KI,NBX)= 0.D0 + C2(KI,NBX)= 0.D0 + 40 CONTINUE +*---- +* KI1(X) ADJUSTMENTS +*---- + X= 0.D0 + DO 50 I= 1, MLOG(1)-1 + X= X + DX + C0(1,I)= C0(1,I) + 0.5D0*X + C1(1,I)= C1(1,I) - LOG(X) + C2(1,I)= C2(1,I) - 0.5D0/X + 50 CONTINUE +* + C1(1,0)= GAMMA-(LOG(2.D0)+1.D0) +*---- +* KI2(X) ADJUSTMENTS +*---- + X= 0.D0 + DO 60 I= 1, MLOG(2)-1 + X= X + DX + C0(2,I)= C0(2,I) + 0.25D0*X*X + C1(2,I)= C1(2,I) - X + C2(2,I)= C2(2,I) + 0.5D0*LOG(X) +0.75D0 + 60 CONTINUE +* + C1(2,0)= -PIO2 + C2(2,0)= 0.5D0*(LOG(2.D0)+1.5D0-GAMMA) +*---- +* OUTPUT VALUES +*---- + DO 80 I= 0, NBX + DO 70 IORD=1,5 + BIV(I,1,IORD)= REAL(C0(IORD,I)) + BIV(I,2,IORD)= REAL(C1(IORD,I)) + BIV(I,3,IORD)= REAL(C2(IORD,I)) + 70 CONTINUE + 80 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(C2, C1, C0) + RETURN +*---- +* ERROR SECTION +*---- + 97 CALL XABORT('XDRKIN: KIN TABLES HAVE MORE THAN 600 ELEMENTS') + 98 CALL XABORT('XDRKIN: KIN TABLES HAVE A STEP OF 0.02') + 99 CALL XABORT('XDRKIN: NO LOG SINGULARITY TAKEN FOR KI345') + END diff --git a/Dragon/src/XDRLGS.f b/Dragon/src/XDRLGS.f new file mode 100644 index 0000000..e91b8f6 --- /dev/null +++ b/Dragon/src/XDRLGS.f @@ -0,0 +1,300 @@ +*DECK XDRLGS + SUBROUTINE XDRLGS(IPLIB ,IGS ,IPRINT,MINLEG,MAXLEG,IORD , + > NGROUP,XSREC ,SCAT ,ITYPRO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Get/save Legendre-dependent cross section data from/on IPLIB. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau +* +*Parameters: input +* IPLIB pointer to the internal library. +* IGS get or save flag: +* >0 save; +* <0 get. +* IPRINT Print level (cross sections printed if IPRINT>99). +* MINLEG mimimum Legendre order to process for scattering. +* MAXLEG maximum Legendre order to process for scattering. +* IORD cross section order: +* =1 constant; +* =2 linear; +* =3 quadratic. +* NGROUP number of energy groups. +* +*Parameters: input/output +* XSREC cross section records (scattering cross section of +* order MINLEG to MAXLEG for IRPROC=MINLEG+1,MAXLEG+1). +* SCAT complete scattering matrix (SCAT(JG,IG) is from IG to JG +* for order MINLEG to MAXLEG). +* +*Parameters: output +* ITYPRO vector for cross section processed indices: +* =0 absent (not processed); +* >0 present (processed). +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + INTEGER IGS,IPRINT,MINLEG,MAXLEG,IORD,NGROUP, + > ITYPRO(MAXLEG-MINLEG+1) + REAL XSREC(NGROUP,MAXLEG-MINLEG+1), + > SCAT(NGROUP,NGROUP,MAXLEG-MINLEG+1) +*---- +* LOCAL PARAMETERS +* SCATTERING CROSS SECTIONS START AT MINLEG+1 WITH +* NAME NAMSCT='SIGS'//NAMLEG AND NAMSCT='SCAT'//NAMLEG +* WITH NAMLEG DEFINED BY +* WRITE(NAMLEG ,'(I2.2)') ILEG +* FOR ILEG=MINLEG+1 TO MAXLEG+1 +*---- + INTEGER IOUT,MAXGAR + PARAMETER (IOUT=6,MAXGAR=100) + INTEGER NPROC,IGAR(MAXGAR),IODIV,LONG,ITYP,LONG2,ILEG, + > IXSR,IXSTN,IG,JG,NXSCMP,IGTO,IGMIN,IGMAX,IGFROM + CHARACTER*12 NAMXS + CHARACTER NAMLEG*2,NORD*6,HCM(0:10)*2 + INTEGER, ALLOCATABLE, DIMENSION(:) :: NJJ,IJJ + REAL, ALLOCATABLE, DIMENSION(:) :: XSSCMP + DATA HCM /'00','01','02','03','04','05','06','07','08', + > '09','10'/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NJJ(NGROUP),IJJ(NGROUP),XSSCMP(NGROUP*NGROUP)) +* + IODIV=0 + IF(IORD.EQ.1) THEN + NORD=' ' + IODIV=1 + ELSE IF(IORD.EQ.2) THEN + NORD=' LIN' + IODIV=2 + ELSE IF(IORD.EQ.3) THEN + NORD=' QUA' + IODIV=4 + ENDIF + NPROC=MAXLEG-MINLEG+1 +*---- +* READ/INITIALIZE STATE VECTORS +*---- + IF(MAXLEG+1.GT.MAXGAR) THEN + WRITE(IOUT,9000) 'SCAT-SAVED',MAXGAR,MAXLEG+1 + CALL XABORT('XDRLGS: INVALID VALUE FOR MAXLEG') + ELSE IF(MAXLEG.LT.MINLEG) THEN + CALL XABORT('XDRLGS: MAXLEG.LT.MINLEG') + ENDIF +* + ITYPRO(:NPROC)=0 + CALL LCMLEN(IPLIB,'SCAT-SAVED',LONG,ITYP) + LONG2=MAX(LONG,MAXLEG+1) + IGAR(:LONG2)=0 + IF(LONG.NE.0) THEN + CALL LCMGET(IPLIB,'SCAT-SAVED',IGAR) + DO 20 ILEG=MINLEG+1,MIN(LONG,MAXLEG+1) + ITYPRO(ILEG-MINLEG)=IGAR(ILEG) + 20 CONTINUE + ELSE IF(IGS.LT.0) THEN + CALL XABORT('XDRLGS: NO SCAT-SAVED RECORD AVAILABLE') + ENDIF +* + IF(IGS.GT.0) THEN +*---- +* SAVE LOCAL SCATTERING MATRIX +*---- + IXSR=0 + DO 120 ILEG=MINLEG+1,MAXLEG+1 + IXSR=IXSR+1 + IXSTN=MOD(ITYPRO(IXSR)/IODIV,2) +*---- +* FIND IF SCATTERING XS NOT ALL 0.0 +*---- + IF((ILEG.EQ.1).AND.(IODIV.EQ.1)) THEN + IF(IXSTN.EQ.0) THEN + ITYPRO(IXSR)=ITYPRO(IXSR)+IODIV + IGAR(ILEG)=IGAR(ILEG)+IODIV + IXSTN=1 + ENDIF + ELSE + DO 130 IG=1,NGROUP + DO 131 JG=1,NGROUP + IF(SCAT(IG,JG,IXSR).NE.0.0) THEN + IF(IXSTN.EQ.0) THEN + ITYPRO(IXSR)=ITYPRO(IXSR)+IODIV + IGAR(ILEG)=IGAR(ILEG)+IODIV + IXSTN=1 + ENDIF + GO TO 135 + ENDIF + 131 CONTINUE + 130 CONTINUE + ENDIF + 135 IF(IXSTN.NE.0) THEN + IF(ILEG.LE.11) THEN + NAMLEG=HCM(ILEG-1) + ELSE + WRITE(NAMLEG,'(I2.2)') ILEG-1 + ENDIF + CALL LCMPUT(IPLIB,'SIGS'//NAMLEG//NORD,NGROUP,2, + > XSREC(1,IXSR)) +*---- +* COMPRESS SCATTERING MATRIX +* SCAT(IGTO,IGFROM) REPRESENT SCATTERING CROSS SECTION +* FROM GROUP "IGFROM" TO GROUP "IGTO" +* IJJ(IGTO) IS MAXIMUM GROUP NUMBER +* WITH SCATTERING TO "IGTO" GROUP +* NJJ(IGTO) IS NUMBER OF GROUPS +* WITH SCATTERING TO "IGTO" GROUP +* XSSCMP(IX) IS COMPRESSED SCATTERING MATRIX +* IX CAN BE LOCALIZED IN SCAT(IGTO,IGFROM) USING +* IF(IGTO=1) THEN +* IPOSD=1 +* ELSE +* IPOSD=1+SUM( NJJ(IGF) , IGF=1,IGTO-1) +* ENDIF +* IF(IGFROM.GT.IJJ(IGTO)) THEN +* XSSCMP NOT STORED +* ELSE IF(IGFROM.LT.IJJ(IGTO)-NJJ(IGTO)+1) THEN +* XSSCMP NOT STORED +* ELSE +* IX=IPOSD+IJJ(IGTO)-IGFROM +* XSSCMP(IX)=SCAT(IGTO,IGFROM) +* ENDIF +*---- + NXSCMP=0 + DO 140 IGTO=1,NGROUP + IGMIN=IGTO + IGMAX=IGTO + DO 150 IGFROM=1,NGROUP + IF(SCAT(IGTO,IGFROM,IXSR).NE.0.0) THEN + IGMIN=MIN(IGMIN,IGFROM) + IGMAX=MAX(IGMAX,IGFROM) + ENDIF + 150 CONTINUE + IJJ(IGTO)=IGMAX + NJJ(IGTO)=IGMAX-IGMIN+1 + DO 160 IGFROM=IGMAX,IGMIN,-1 + NXSCMP=NXSCMP+1 + XSSCMP(NXSCMP)=SCAT(IGTO,IGFROM,IXSR) + 160 CONTINUE + 140 CONTINUE + CALL LCMPUT(IPLIB,'NJJS'//NAMLEG//NORD,NGROUP,1,NJJ) + CALL LCMPUT(IPLIB,'IJJS'//NAMLEG//NORD,NGROUP,1,IJJ) + CALL LCMPUT(IPLIB,'SCAT'//NAMLEG//NORD,NXSCMP,2,XSSCMP) + ENDIF + 120 CONTINUE + CALL LCMPUT(IPLIB,'SCAT-SAVED',LONG2,1,IGAR) + ELSE +*---- +* GET LOCAL SCATTERING MATRIX +*---- + IXSR=0 + DO 220 ILEG=MINLEG+1,MAXLEG+1 + IXSR=IXSR+1 +*---- +* READ IF IXSTN = 1 +* INITIALIZE TO 0.0 IF IXSTN = 0 +*---- + XSREC(:NGROUP,IXSR)=0.0 + SCAT(:NGROUP,:NGROUP,IXSR)=0.0 + IXSTN=MOD(ITYPRO(IXSR)/IODIV,2) + IF(IXSTN.EQ.1) THEN + IF(ILEG.LE.11) THEN + NAMLEG=HCM(ILEG-1) + ELSE + WRITE(NAMLEG,'(I2.2)') ILEG-1 + ENDIF + CALL LCMGET(IPLIB,'SIGS'//NAMLEG//NORD,XSREC(1,IXSR)) + CALL LCMGET(IPLIB,'NJJS'//NAMLEG//NORD,NJJ) + CALL LCMGET(IPLIB,'IJJS'//NAMLEG//NORD,IJJ) + CALL LCMGET(IPLIB,'SCAT'//NAMLEG//NORD,XSSCMP) +*---- +* DECOMPRESS SCATTERING MATRIX +* SCAT(IGTO,IGFROM) REPRESENT SCATTERING CROSS SECTION +* FROM GROUP "IGFROM" TO GROUP "IGTO" +* IJJ(IGTO) IS MAXIMUM GROUP NUMBER +* WITH SCATTERING TO "IGTO" GROUP +* NJJ(IGTO) IS NUMBER OF GROUPS +* WITH SCATTERING TO "IGTO" GROUP +* XSSCMP(IX) IS COMPRESSED SCATTERING MATRIX +* SCAT(IGTO,IGFROM) CAN BE LOCALIZED IN XSSCMP(IX) USING +* IF(IGTO=1) THEN +* IPOSD=1 +* ELSE +* IPOSD=1+SUM( NJJ(IGF) , IGF=1,IGTO-1) +* ENDIF +* IF(IGFROM.GT.IJJ(IGTO)) THEN +* SCAT(IGTO,IGFROM)=0.0 +* ELSE IF(IGFROM.LT.IJJ(IGTO)-NJJ(IGTO)+1) THEN +* SCAT(IGTO,IGFROM)=0.0 +* ELSE +* SCAT(IGTO,IGFROM)=XSSCMP(IPOSD+IJJ(IGTO)-IGFROM) +* ENDIF +*---- + NXSCMP=0 + DO 240 IGTO=1,NGROUP + IGMAX=IJJ(IGTO) + IGMIN=IGMAX-NJJ(IGTO)+1 + DO 250 IGFROM=IGMAX,IGMIN,-1 + NXSCMP=NXSCMP+1 + SCAT(IGTO,IGFROM,IXSR)=XSSCMP(NXSCMP) + 250 CONTINUE + 240 CONTINUE + ENDIF + 220 CONTINUE + ENDIF + IF(IPRINT .GE. 100) THEN +*---- +* Print XS +*---- + IXSR=0 + DO ILEG=MINLEG+1,MAXLEG+1 + IXSR=IXSR+1 + IXSTN=MOD(ITYPRO(ILEG)/IODIV,2) + IF(IXSTN.NE.0) THEN + WRITE(NAMXS,'(A4,I2.2,A6)') 'SIGS',ILEG-1,NORD + WRITE(IOUT,6000) NAMXS + WRITE(IOUT,6010) (XSREC(IG,IXSR),IG=1,NGROUP) +*---- +* SCAT(IGTO,IGFROM) REPRESENT SCATTERING CROSS SECTION +* FROM GROUP "IGFROM" TO GROUP "IGTO" +*---- + WRITE(NAMXS,'(A4,I2.2,A6)') 'SCAT',ILEG-1,NORD + WRITE(IOUT,6000) NAMXS + DO IGFROM=1,NGROUP + WRITE(IOUT,6001) IGFROM + WRITE(IOUT,6010) (SCAT(IGTO,IGFROM,IXSR),IGTO=1,NGROUP) + ENDDO + ENDIF + ENDDO + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XSSCMP,IJJ,NJJ) + RETURN +*---- +* ABORT FORMAT +*---- + 6000 FORMAT(/' CROSS SECTION TYPE = ',A12) + 6001 FORMAT(/' SCATTERING FROM GROUP = ',I10) + 6010 FORMAT(1P,5E16.7) + 9000 FORMAT(/' XDRLGS: ****** ABORT ******'/ + > ' INVALID LENGTH OF RECORD ',A10/ + > ' STORAGE SPACE = ',I10/ + > ' LENGTH OF RECORD LONG = ',I10/ + > ' ***************************') + END diff --git a/Dragon/src/XDRLXS.f b/Dragon/src/XDRLXS.f new file mode 100644 index 0000000..d49a89f --- /dev/null +++ b/Dragon/src/XDRLXS.f @@ -0,0 +1,119 @@ +*DECK XDRLXS + SUBROUTINE XDRLXS(IPLIB ,IGS ,IPRINT,NPROC ,NAMDXS,IORD , + > NGROUP,XSREC ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Get/save Legendre-independent cross section data from/on IPLIB. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau +* +*Parameters: input +* IPLIB pointer to the internal library. +* IGS get or save flag: +* >0 save; +* <0 get. +* IPRINT Print level (cross sections printed if IPRINT>99). +* NPROC number of Legendre-independent terms to process. +* NAMDXS names of cross sections to process. +* IORD cross section order: +* =1 constant; +* =2 linear; +* =3 quadratic. +* NGROUP number of energy groups. +* +*Parameters: input/output +* XSREC cross section records for IRPROC=1,NPROC. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + INTEGER IGS,IPRINT,NPROC,IORD,NGROUP + REAL XSREC(NGROUP,NPROC) + CHARACTER NAMDXS(NPROC)*6,NORD*6 +*---- +* LOCAL VARIABLES +*---- + INTEGER IOUT + PARAMETER (IOUT=6) + INTEGER IODIV,IXSR,IG,JG,ILENG,ITYLCM +* + IF(IORD.EQ.1) THEN + NORD=' ' + IODIV=1 + ELSE IF(IORD.EQ.2) THEN + NORD=' LIN' + IODIV=2 + ELSE IF(IORD.EQ.3) THEN + NORD=' QUA' + IODIV=4 + ENDIF + IF(NPROC.LE.0) THEN + CALL XABORT('XDRLXS: ZERO OR NEGATIVE VALUE OF NPROC') + ENDIF +* + IF(IGS.GT.0) THEN +*---- +* SAVE LOCAL DEFAULT XS IF REQUIRED +*---- +* + DO 100 IXSR=1,NPROC +*---- +* FIND IF XS NOT ALL 0.0 +*---- + DO 110 IG=1,NGROUP + IF(XSREC(IG,IXSR).NE.0.0) GO TO 115 + 110 CONTINUE + GO TO 100 +*---- +* SAVE IF XS NOT ALL 0.0 +*---- + 115 CALL LCMPUT(IPLIB,NAMDXS(IXSR)//NORD,NGROUP,2,XSREC(1,IXSR)) + 100 CONTINUE + ELSE +*---- +* GET LOCAL DEFAULT XS IF REQUIRED +*---- + DO 200 IXSR=1,NPROC + XSREC(:NGROUP,IXSR)=0.0 + CALL LCMLEN(IPLIB,NAMDXS(IXSR)//NORD,ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + CALL LCMGET(IPLIB,NAMDXS(IXSR)//NORD,XSREC(1,IXSR)) + ENDIF + 200 CONTINUE + ENDIF + IF(IPRINT .GE. 100) THEN +*---- +* Print XS +*---- + DO IXSR=1,NPROC + DO IG=1,NGROUP + IF(XSREC(IG,IXSR).NE.0.0) THEN + WRITE(IOUT,6000) NAMDXS(IXSR)//NORD + WRITE(IOUT,6010) (XSREC(JG,IXSR),JG=1,NGROUP) + GO TO 210 + ENDIF + ENDDO + 210 CONTINUE + ENDDO + ENDIF + RETURN +*---- +* Formats +*---- + 6000 FORMAT(/' CROSS SECTION TYPE = ',A12) + 6010 FORMAT(1P,5E16.7) + END diff --git a/Dragon/src/XDRNRM.f b/Dragon/src/XDRNRM.f new file mode 100644 index 0000000..0cfe272 --- /dev/null +++ b/Dragon/src/XDRNRM.f @@ -0,0 +1,75 @@ +*DECK XDRNRM + SUBROUTINE XDRNRM(NREGIO,NBMIX,MATCOD,VOLUME,XSSIGT,XSSIGW, + > PIJSYM,PIS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Normalisation of the scattering-reduced cp matrix to force neutron +* conservation (no leakage). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NREGIO number of regions considered. +* NBMIX number of mixtures. +* MATCOD mixture code in each region. +* VOLUME volume of each region. +* XSSIGT total macroscopic cross sections. +* XSSIGW P0 within-group scattering cross sections. +* +*Parameters: input/output +* PIJSYM group condensed reduce/symmetric scattering-reduced pij +* matrix. +* PIS escape probabilities. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NREGIO,NBMIX,MATCOD(NREGIO) + REAL VOLUME(NREGIO),XSSIGT(NBMIX),XSSIGW(NBMIX), + > PIJSYM(NREGIO*(NREGIO+1)/2),PIS(NREGIO) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION SUM,DD +*---- +* INTRINSIC FUNCTION FOR POSITION IN CONDENSED PIJ MATRIX +*---- + INDPOS(I,J)=MAX(I,J)*(MAX(I,J)-1)/2+MIN(I,J) +* + DD=0.0D0 + DO 20 I=1,NREGIO + SUM=0.0D0 + DO 10 J=1,NREGIO + MATNUM=MATCOD(J) + IF(MATNUM.GT.0) THEN + SUM=SUM+(XSSIGT(MATNUM)-XSSIGW(MATNUM))*PIJSYM(INDPOS(I,J))/ + 1 VOLUME(I) + ENDIF + 10 CONTINUE + PIS(I)=REAL(1.0D0-SUM) + MATNUM=MATCOD(I) + IF(MATNUM.GT.0) THEN + DD=DD+(XSSIGT(MATNUM)-XSSIGW(MATNUM))*VOLUME(I)*PIS(I) + ENDIF + 20 CONTINUE + IF(DD.EQ.0.0D0) RETURN + DO 40 I=1,NREGIO + DO 30 J=1,I + INDPIJ=INDPOS(I,J) + PIJSYM(INDPIJ)=PIJSYM(INDPIJ)+PIS(I)*PIS(J)*VOLUME(I)*VOLUME(J)/ + > REAL(DD) + 30 CONTINUE + 40 CONTINUE + RETURN + END diff --git a/Dragon/src/XDRTA2.f b/Dragon/src/XDRTA2.f new file mode 100644 index 0000000..1326930 --- /dev/null +++ b/Dragon/src/XDRTA2.f @@ -0,0 +1,98 @@ +*DECK XDRTA2 + SUBROUTINE XDRTA2 +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover the tabulated functions required by the flux solution and +* store them in common blocks. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy and A. Hebert +* +*----------------------------------------------------------------------- +* +***** OUTPUT: THE FIVE COMMONS OF BICKLEY QUADRATIC TABLES ARE FILLED +* AND SAVED WITH RESPECTIVE NAMES: +* /BICKL1/,/BICKL2/,/BICKL3/,/BICKL4/,/BICKL5/ +* +* A COMMON FOR LINEAR EXPONENTIAL TABLES IS FILLED +* AND SAVED WITH NAME: /EXP1/ +*---- +* BICKLEY FUNCTION COMMONS +*---- + DOUBLE PRECISION DX + INTEGER MLOG(5) + PARAMETER (NBX=600,DX=0.02D0,MLOG=(/30,15,0,0,0/)) + REAL BIV(0:NBX,3,5),XLIMV(5),PASV(5) + COMMON /BICKL1/BI1(0:NBX),BI11(0:NBX),BI12(0:NBX),PAS1,XLIM1,L1 + COMMON /BICKL2/BI2(0:NBX),BI21(0:NBX),BI22(0:NBX),PAS2,XLIM2,L2 + COMMON /BICKL3/BI3(0:NBX),BI31(0:NBX),BI32(0:NBX),PAS3,XLIM3,L3 + COMMON /BICKL4/BI4(0:NBX),BI41(0:NBX),BI42(0:NBX),PAS4,XLIM4,L4 + COMMON /BICKL5/BI5(0:NBX),BI51(0:NBX),BI52(0:NBX),PAS5,XLIM5,L5 + SAVE /BICKL1/,/BICKL2/,/BICKL3/,/BICKL4/,/BICKL5/ +*---- +* EXPONENTIAL COMMONS +*---- + DOUBLE PRECISION DEX + REAL PARAM(3) + PARAMETER (NBEX=7936,DEX=1.D0/512.D0) + COMMON /EXP1/ E10(0:NBEX),E11(0:NBEX),PASE1,DXE1,XLIME1 + COMMON /EXP0/ E00(0:NBEX),E01(0:NBEX),PASE0,DXE0,XLIME0 + SAVE /EXP1/,/EXP0/ +*---- +* CHARGE BICKLEY TABLES INTO COMMON +*---- + CALL XDRKIN(DX,NBX,MLOG,BIV,PASV,XLIMV) + PAS1=PASV(1) + PAS2=PASV(2) + PAS3=PASV(3) + PAS4=PASV(4) + PAS5=PASV(5) + XLIM1=XLIMV(1) + XLIM2=XLIMV(2) + XLIM3=XLIMV(3) + XLIM4=XLIMV(4) + XLIM5=XLIMV(5) + L1=MLOG(1) + L2=MLOG(2) + L3=MLOG(3) + L4=MLOG(4) + L5=MLOG(5) + BI1(0:NBX)=BIV(0:NBX,1,1) + BI11(0:NBX)=BIV(0:NBX,2,1) + BI12(0:NBX)=BIV(0:NBX,3,1) +* + BI2(0:NBX)=BIV(0:NBX,1,2) + BI21(0:NBX)=BIV(0:NBX,2,2) + BI22(0:NBX)=BIV(0:NBX,3,2) +* + BI3(0:NBX)=BIV(0:NBX,1,3) + BI31(0:NBX)=BIV(0:NBX,2,3) + BI32(0:NBX)=BIV(0:NBX,3,3) +* + BI4(0:NBX)=BIV(0:NBX,1,4) + BI41(0:NBX)=BIV(0:NBX,2,4) + BI42(0:NBX)=BIV(0:NBX,3,4) +* + BI5(0:NBX)=BIV(0:NBX,1,5) + BI51(0:NBX)=BIV(0:NBX,2,5) + BI52(0:NBX)=BIV(0:NBX,3,5) +*---- +* CHARGE EXPONENTIAL TABLES INTO COMMON +*---- + CALL XDREXP(DEX,NBEX,PARAM,E00,E01,E10,E11) + PASE1=PARAM(1) + DXE1=PARAM(2) + XLIME1=PARAM(3) + PASE0=PARAM(1) + DXE0=PARAM(2) + XLIME0=PARAM(3) + RETURN + END diff --git a/Dragon/src/XDRTBH.f b/Dragon/src/XDRTBH.f new file mode 100644 index 0000000..93a5311 --- /dev/null +++ b/Dragon/src/XDRTBH.f @@ -0,0 +1,165 @@ +*DECK XDRTBH + SUBROUTINE XDRTBH(IPGEOM,IPTRK,IQUA10,IBIHET,IMPX,FRTM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover the double-heterogeneity (Bihet) data from the geometry +* object IPGEOM and update the tracking object IPTRK. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK pointer to the excell tracking (L_TRACK). +* IPGEOM pointer to the geometry (L_GEOM). +* IQUA10 quadrature parameter for the double heterogeneity option. +* IBIHET type of double-heterogeneity method: =1 Sanchez-Pomraning +* model; =2 Hebert model; =3 She-Liu-Shi model (no shadow); +* =4 She-Liu-Shi model (with shadow). +* IMPX tracking print level. +* FRTM minimum volume fraction of the grain in the representative +* volume for She-Liu-Shi model. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPGEOM,IPTRK + INTEGER IQUA10,IBIHET,IMPX + REAL FRTM +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + INTEGER ISTRAK(NSTATE),ISTATE(NSTATE),IPARAM(8) + CHARACTER CDOOR*12 + INTEGER, ALLOCATABLE, DIMENSION(:) :: NS,IBI,MAT,IDIL,MIXGR,KEYF1, + 1 KEYF2 + REAL, ALLOCATABLE, DIMENSION(:) :: RS,FRACT,VOLK,VOL +* + IF(IQUA10.EQ.0) CALL XABORT('XDRTBH: INVALID IQUA10.') + IF(IBIHET.EQ.0) CALL XABORT('XDRTBH: INVALID IBIHET.') +* + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTRAK) + NREG2=ISTRAK(1) + NUN2=ISTRAK(2) + IR2=ISTRAK(4) + CALL LCMSIX(IPGEOM,'BIHET',1) + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) + NG=ISTATE(1) + NSMAX=ISTATE(2)-1 + ALLOCATE(NS(NG)) + CALL LCMGET(IPGEOM,'NS',NS) + NSMAX=0 + DO 10 I=1,NG + NSMAX=MAX(NSMAX,NS(I)) + 10 CONTINUE +* + ALLOCATE(IBI(NREG2)) + ALLOCATE(RS(NG*(1+NSMAX)),FRACT(NG*IR2),VOLK(NG*NSMAX)) +* + MAXPTS=NREG2*(NSMAX+1)*NG + ALLOCATE(MAT(MAXPTS),VOL(MAXPTS)) + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'VOLUME',VOL) + CALL LCMSIX(IPTRK,'BIHET',1) + CALL LCMPUT(IPTRK,'IBI',NREG2,1,MAT) + CALL LCMPUT(IPTRK,'VOLUME',NREG2,2,VOL) + CALL LCMSIX(IPTRK,' ',2) +* + DO 20 I=1,NREG2 + IBI(I)=MAT(I) + 20 CONTINUE +*---- +* RECOVER DOUBLE-HETEROGENEITY INFORMATION FROM GEOMETRY OBJECT +*---- + ALLOCATE(IDIL(IR2),MIXGR(NG*NSMAX*IR2)) + CALL READBH(MAXPTS,IPGEOM,IR1,IR2,NREG,NREG2,MAT,VOL,NG,NSMAX, + 1 MICRO,NS,IBI,RS,FRACT,VOLK,IMPX,IDIL,MIXGR) + DEALLOCATE(IBI) + IF(IMPX.GE.1) THEN + WRITE (6,'(/" QUADRATURE PARAMETER FOR THE MICRO STRUC", + 1 "TURES =",I2/)') IQUA10 + WRITE (6,'(" TYPE OF DOUBLE HETEROGENEITY MODEL (1/2: ", + 1 "SANCHEZ-POMRANING/HEBERT)=",I2/)') IBIHET + ENDIF + CALL LCMSIX(IPGEOM,' ',2) +*---- +* RESET STATE-VECTOR INFORMATION +*---- + IPARAM(1)=IR1 + IPARAM(2)=IR2 + IPARAM(3)=NREG2 + IPARAM(4)=NG + IPARAM(5)=NSMAX + IPARAM(6)=IBIHET + IPARAM(7)=MICRO + IPARAM(8)=IQUA10 + CALL LCMSIX(IPTRK,'BIHET',1) + CALL LCMPUT(IPTRK,'PARAM',8,1,IPARAM) + CALL LCMPUT(IPTRK,'NS',NG,1,NS) + CALL LCMPUT(IPTRK,'RS',NG*(1+NSMAX),2,RS) + CALL LCMPUT(IPTRK,'FRACT',NG*IR2,2,FRACT) + CALL LCMPUT(IPTRK,'VOLK',NG*NSMAX,2,VOLK) + CALL LCMPUT(IPTRK,'IDIL',IR2-IR1,1,IDIL) + CALL LCMPUT(IPTRK,'MIXGR',NG*NSMAX*(IR2-IR1),1,MIXGR) + CALL LCMPUT(IPTRK,'FRTM',1,2,FRTM) + DEALLOCATE(MIXGR,IDIL,NS) + DEALLOCATE(VOLK,FRACT,RS) + CALL LCMSIX(IPTRK,' ',2) + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTRAK) + ISTRAK(1)=NREG + ISTRAK(2)=NUN2+(NREG-NREG2) + ISTRAK(4)=IR1 + CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,ISTRAK) + CALL LCMPUT(IPTRK,'MATCOD',NREG,1,MAT) + CALL LCMPUT(IPTRK,'VOLUME',NREG,2,VOL) + DEALLOCATE(VOL,MAT) +*---- +* RESET KEYFLX AND KEYFLX$ANIS +*---- + CALL LCMGTC(IPTRK,'TRACK-TYPE',12,CDOOR) + IF((CDOOR.EQ.'MCCG').OR.(CDOOR.EQ.'SN')) THEN + CALL LCMLEN(IPTRK,'KEYFLX$ANIS',LKFL,ITYLCM) + NFUNL=LKFL/NREG2 + ALLOCATE(KEYF1(NREG*NFUNL),KEYF2(NREG2*NFUNL)) + CALL LCMGET(IPTRK,'KEYFLX$ANIS',KEYF2) + KEYF1(:NREG*NFUNL)=0 + DO 35 INF=1,NFUNL + DO 30 I=1,NREG2 + IOF1=(INF-1)*NREG+I + IOF2=(INF-1)*NREG2+I + KEYF1(IOF1)=KEYF2(IOF2) + 30 CONTINUE + 35 CONTINUE + IUNK=NUN2 + DO 40 I=NREG2+1,NREG + IUNK=IUNK+1 + KEYF1(I)=IUNK + 40 CONTINUE + CALL LCMPUT(IPTRK,'KEYFLX',NREG,1,KEYF1(:NREG)) + CALL LCMPUT(IPTRK,'KEYFLX$ANIS',NREG*NFUNL,1,KEYF1) + DEALLOCATE(KEYF2,KEYF1) + ELSE + ALLOCATE(KEYF1(NREG)) + KEYF1(:NREG)=0 + CALL LCMGET(IPTRK,'KEYFLX',KEYF1(:NREG2)) + IUNK=NUN2 + DO 50 I=NREG2+1,NREG + IUNK=IUNK+1 + KEYF1(I)=IUNK + 50 CONTINUE + CALL LCMPUT(IPTRK,'KEYFLX',NREG,1,KEYF1) + DEALLOCATE(KEYF1) + ENDIF + RETURN + END diff --git a/Dragon/src/XEL3T2.f b/Dragon/src/XEL3T2.f new file mode 100644 index 0000000..1a64b9c --- /dev/null +++ b/Dragon/src/XEL3T2.f @@ -0,0 +1,372 @@ +*DECK XEL3T2 + SUBROUTINE XEL3T2(IX,IY,IZ,LDIM,N3MS,N3MR,N3RS,LMESH,NZP,N2MS, + 1 N2MR,N3S,N3R,NFI,MINDIM,MAXDIM,REMESH,VOLSUR, + 2 MATALB,KEYMRG,INDEX,MAX2,MIN2,ICOR2,REM2,VOL2, + 3 MAT2,KEY2,IND2,IND2T3,MATMRG,VOLMRG,ZCOR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Create 2D projection (EXCELT geometry analysis) of a 3D prismatic +* geometry. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IX first direction perpendicular to the projection axis. +* IY second direction perpendicular to the projection axis. +* IZ projection axis. +* LDIM dimension of MINDIM,MAXDIM,MAX2,MIN2 arrays. +* N3MS maximum number of outer surfaces for the 3D geometry. +* N3MR maximum number of regions for the 3D geometry. +* N3RS second dimension of INDEX array. +* LMESH dimension of REMESH array. +* NZP number of plan in the 3D prismatic geometry. +* N2MS maximum number of outer surfaces for the 2D projected +* geometry. +* N2MR maximum number of regions for the 2D projected geometry. +* MINDIM min index values for the different axes of the 3D geometry. +* MAXDIM max index values for the different axes of the 3D geometry. +* REMESH different meshes of the 3D geometry. +* VOLSUR outer surfaces and volumes for the 3D geometry. +* MATALB albedo and material indexes for the 3D geometry. +* KEYMRG merging index for the 3D geometry. +* INDEX location index for the 3D geometry. +* +*Parameters: output +* N3S number of outer surfaces for the 3D geometry after merging. +* N3R number of regions for the 3D geometry after merging. +* NFI effective dimension for MATMRG AND VOLMRG arrays. +* MAX2 min index values for the different axes of the 2D projected +* geometry. +* MIN2 max index values for the different axes of the 2D projected +* geometry. +* ICOR2 undefined. +* REM2 different meshes of the 2D projected geometry. +* VOL2 outer surfaces and volumes for the 2D projected geometry. +* MAT2 albedo and material indexes for the 2D projected geometry. +* KEY2 merging index for the 2D projected geometry. +* IND2 location index for the 2D projected geometry. +* IND2T3 mapping index between the 2D projected geometries (plan by +* plan) and the initial 3D geometry. +* MATMRG albedo and material indexes for the 3D geometry after merging. +* VOLMRG outer surfaces and volumes for the 3D geometry after merging. +* ZCOR coordinates of the different plans of the 3D prismatic +* geometry. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IX,IY,IZ,LDIM,N3MS,N3MR,N3RS,LMESH,NZP,N2MS,N2MR, + 1 N3S,N3R,NFI,MINDIM(LDIM),MAXDIM(LDIM),MATALB(-N3MS:N3MR), + 2 KEYMRG(-N3MS:N3MR),INDEX(4,N3RS),MAX2(LDIM),MIN2(LDIM), + 3 ICOR2(LDIM),MAT2(-N2MS:N2MR),KEY2(-N2MS:N2MR),IND2(4,N2MR), + 4 IND2T3(-N2MS:N2MR,0:NZP+1),MATMRG(N3RS) + REAL REMESH(LMESH),VOLSUR(-N3MS:N3MR),REM2(LMESH), + 1 VOL2(-N2MS:N2MR),VOLMRG(N3RS),ZCOR(0:NZP) +*---- +* LOCAL VARIABLES +*---- + INTEGER II,IR,IS,ZPL,IMRG,IPOS,ITYP,ZPLB,IPOSB,IIB,IPOS2,IMRG2 + REAL DELZ + INTEGER, ALLOCATABLE, DIMENSION(:) :: ITEMP,ITEMP2 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(ITEMP(LMESH),ITEMP2(LMESH)) +*--- +* CREATE MATMRG AND VOLMRG ARRAYS FOR 3D GEOMETRY +*--- + VOLMRG(:N3RS)=0.0 + N3S=0 + DO IS=-N3MS,-1 + N3S=MIN(KEYMRG(IS),N3S) + ENDDO + N3S=-N3S + DO IS=-N3MS,-1 + VOLMRG(N3S+1+KEYMRG(IS))=VOLMRG(N3S+1+KEYMRG(IS))+VOLSUR(IS) + MATMRG(N3S+1+KEYMRG(IS))=MATALB(IS) + ENDDO + N3R=0 + MATMRG(N3S+1)=0 + DO IR=1,N3MR + N3R=MAX(KEYMRG(IR),N3R) + VOLMRG(N3S+1+KEYMRG(IR))=VOLMRG(N3S+1+KEYMRG(IR))+VOLSUR(IR) + MATMRG(N3S+1+KEYMRG(IR))=MATALB(IR) + ENDDO + NFI=N3S+N3R+1 +*--- +* CREATE PERMUTATION ARRAY FOR THE CHANGE OF COORDINATES (IX,IY,IZ) -> +* (1,2,3) +*--- + IPOS=0 + DO II=MINDIM(IX),MAXDIM(IX) + IPOS=IPOS+1 + ITEMP(IPOS)=II + ENDDO + DO II=MINDIM(IY),MAXDIM(IY) + IPOS=IPOS+1 + ITEMP(IPOS)=II + ENDDO + DO II=MINDIM(IZ),MAXDIM(IZ) + IPOS=IPOS+1 + ITEMP(IPOS)=II + ENDDO + DO II=4,LDIM + DO IPOSB=MINDIM(II)-2,MAXDIM(II) + IPOS=IPOS+1 + ITEMP(IPOS)=IPOSB + ENDDO + ENDDO + DO II=1,LMESH + ITEMP2(ITEMP(II))=II + ENDDO +*--- +* CREATE MAXDIM, MINDIM, REMESH, FOR 2D GEOMETRY +*--- + MIN2(1)=1 + MAX2(1)=MAXDIM(IX)-MINDIM(IX)+MIN2(1) + ICOR2(1)=1 + DO II=MIN2(1),MAX2(1) + REM2(II)=REMESH(ITEMP(II)) + ENDDO + MIN2(2)=MAX2(1)+1 + MAX2(2)=MAXDIM(IY)-MINDIM(IY)+MIN2(2) + ICOR2(2)=2 + DO II=MIN2(2),MAX2(2) + REM2(II)=REMESH(ITEMP(II)) + ENDDO + MIN2(3)=MAX2(2)+1 + MAX2(3)=MAXDIM(IZ)-MINDIM(IZ)+MIN2(3) + ICOR2(3)=3 + DO II=MIN2(3),MAX2(3) + REM2(II)=REMESH(ITEMP(II)) + ENDDO + DO II=4,LDIM + MIN2(II)=MINDIM(II) + MAX2(II)=MAXDIM(II) + ICOR2(II)=3 + DO IPOS=MIN2(II)-2,MAX2(II) + REM2(IPOS)=REMESH(ITEMP(IPOS)) + ENDDO + ENDDO +*--- +* CREATE Z-COORDINATES ARRAY +*--- + DO II=MINDIM(IZ),MAXDIM(IZ) + ZCOR(II-MINDIM(IZ))=REMESH(II)-REMESH(MINDIM(IZ)) + ENDDO +*--- +* CREATE INDEX FOR 2D GEOMETRY (FROM FIRST Z-PLAN) AND MAPPING INDEX +* BETWEEN 2D AND 3D +*--- + IND2T3(-N2MS:N2MR,0:NZP+1)=0 +* + IR=0 + IS=-N3MS-1 + DO 10 II=1,N3RS + IF ((INDEX(1,II).EQ.0).AND. + 1 (INDEX(2,II).EQ.0).AND. + 2 (INDEX(3,II).EQ.0)) GOTO 10 + ZPL=INDEX(IZ,II)-MINDIM(IZ)+1 + IPOS=0 +* what is the element we have encountered? +* find if this (ix,iy,it) INDEX position has already been +* encountered in another iz-plan + IF ((ZPL.EQ.0).OR.(ZPL.EQ.(NZP+1))) THEN + ITYP=-1 + IF (ZPL.EQ.0) THEN +* It is a bottom surface + ZPLB=NZP+1 + ELSE +* It is a top surface + ZPLB=0 + ENDIF +* scan for a matching top/bottom surface + DO IPOSB=1,N2MR + IF (IND2T3(IPOSB,ZPLB).NE.0) THEN + IIB=N3MS+1+IND2T3(IPOSB,ZPLB) + IF ((INDEX(IX,IIB).EQ.INDEX(IX,II)).AND. + 1 (INDEX(IY,IIB).EQ.INDEX(IY,II)).AND. + 1 (INDEX(4,IIB).EQ.INDEX(4,II))) THEN + IPOS=IPOSB + GOTO 31 + ENDIF + ENDIF + ENDDO +* scan for a matching region + DO 21 ZPLB=1,NZP + DO 20 IPOSB=1,N2MR + IF (IND2T3(IPOSB,ZPLB).NE.0) THEN + IIB=N3MS+1+IND2T3(IPOSB,ZPLB) + IF ((INDEX(IX,IIB).EQ.INDEX(IX,II)).AND. + 1 (INDEX(IY,IIB).EQ.INDEX(IY,II)).AND. + 1 (INDEX(4,IIB).EQ.INDEX(4,II))) THEN + IPOS=IPOSB + GOTO 31 + ENDIF + ENDIF + 20 CONTINUE + 21 CONTINUE +* find an empty space + DO 41 IPOSB=1,N2MR + DO ZPLB=0,NZP+1 + IF (IND2T3(IPOSB,ZPLB).NE.0) GOTO 41 + ENDDO + IPOS=IPOSB + GOTO 31 + 41 CONTINUE + CALL XABORT('XEL3T2: INCOMPATIBLE MESHES(1).') + 31 CONTINUE + ELSE + IF ((INDEX(IX,II).LT.MINDIM(IX)).OR. + 1 (INDEX(IY,II).LT.MINDIM(IY)).OR. + 2 (INDEX(IX,II).EQ.MAXDIM(IX)).OR. + 3 (INDEX(IY,II).EQ.MAXDIM(IY))) THEN +* It is a lateral surface + ITYP=-1 +* scan for a matching lateral surface + DO 23 ZPLB=1,NZP + DO 22 IPOSB=-N2MS,-1 + IF (IND2T3(IPOSB,ZPLB).NE.0) THEN + IIB=N3MS+1+IND2T3(IPOSB,ZPLB) + IF ((INDEX(IX,IIB).EQ.INDEX(IX,II)).AND. + 1 (INDEX(IY,IIB).EQ.INDEX(IY,II)).AND. + 1 (INDEX(4,IIB).EQ.INDEX(4,II))) THEN + IPOS=IPOSB + GOTO 32 + ENDIF + ENDIF + 22 CONTINUE + 23 CONTINUE +* find an empty space + DO 42 IPOSB=-N2MS,1 + DO ZPLB=1,NZP + IF (IND2T3(IPOSB,ZPLB).NE.0) GOTO 42 + ENDDO + IPOS=IPOSB + GOTO 32 + 42 CONTINUE + CALL XABORT('XEL3T2: INCOMPATIBLE MESHES(2).') + 32 CONTINUE + ELSE +* It is a region + ITYP=1 +* scan for a matching top or bottom surface + DO 25 ZPLB=0,NZP+1,NZP+1 + DO 24 IPOSB=1,N2MR + IF (IND2T3(IPOSB,ZPLB).NE.0) THEN + IIB=N3MS+1+IND2T3(IPOSB,ZPLB) + IF ((INDEX(IX,IIB).EQ.INDEX(IX,II)).AND. + 1 (INDEX(IY,IIB).EQ.INDEX(IY,II)).AND. + 1 (INDEX(4,IIB).EQ.INDEX(4,II))) THEN + IPOS=IPOSB + GOTO 33 + ENDIF + ENDIF + 24 CONTINUE + 25 CONTINUE +* scan for a matching region + DO 27 ZPLB=1,NZP + DO 26 IPOSB=1,N2MR + IF (IND2T3(IPOSB,ZPLB).NE.0) THEN + IIB=IND2T3(IPOSB,ZPLB)+N3MS+1 + IF ((INDEX(IX,IIB).EQ.INDEX(IX,II)).AND. + 1 (INDEX(IY,IIB).EQ.INDEX(IY,II)).AND. + 1 (INDEX(4,IIB).EQ.INDEX(4,II))) THEN + IPOS=IPOSB + GOTO 33 + ENDIF + ENDIF + 26 CONTINUE + 27 CONTINUE +* find an empty space + DO 43 IPOSB=1,N2MR + DO ZPLB=0,NZP+1 + IF (IND2T3(IPOSB,ZPLB).NE.0) GOTO 43 + ENDDO + IPOS=IPOSB + GOTO 33 + 43 CONTINUE + CALL XABORT('XEL3T2: INCOMPATIBLE MESHES(3).') + 33 CONTINUE + ENDIF + ENDIF + IF (ITYP.EQ.-1) THEN + IS=IS+1 + IMRG=IS + ELSE + IR=IR+1 + IMRG=IR + ENDIF + IND2T3(IPOS,ZPL)=IMRG + DO ZPLB=0,NZP+1 + IF (IND2T3(IPOS,ZPLB).NE.0) THEN + IIB=N3MS+1+IND2T3(IPOS,ZPLB) + IF ((INDEX(IX,IIB).NE.INDEX(IX,II)).OR. + 1 (INDEX(IY,IIB).NE.INDEX(IY,II)).OR. + 1 (INDEX(4,IIB).NE.INDEX(4,II))) THEN + WRITE(6,*) ZPLB,IND2T3(IPOS,ZPLB),IIB + WRITE(6,*) INDEX(IX,IIB),INDEX(IX,II) + WRITE(6,*) INDEX(IY,IIB),INDEX(IY,II) + WRITE(6,*) INDEX(4,IIB),INDEX(4,II) + CALL XABORT('XEL3T2: PROJECTION FAILED (1).') + ENDIF + ENDIF + ENDDO + 10 CONTINUE + IF ((IR.NE.N3MR).OR.(-IS.NE.1)) THEN + WRITE(6,*) N3MR,IR + WRITE(6,*) 1,-IS + CALL XABORT('XEL3T2: PROJECTION FAILED (2).') + ENDIF +*--- +* CREATE VOLSUR, MATALB, KEYMRG INDEX FOR 2D GEOMETRY (FROM FIRST +* Z-PLAN) APPLY KEYMRG TO MAPPING INDEX BETWEEN 2D AND 3D +*--- + DELZ=REMESH(MINDIM(IZ)+1)-REMESH(MINDIM(IZ)) + DO 60 IPOS=-N2MS,N2MR + IMRG=IND2T3(IPOS,1) + VOL2(IPOS)=VOLSUR(IMRG)/DELZ + MAT2(IPOS)=MATALB(IMRG) + KEY2(IPOS)=IPOS + IPOS2=IPOS+N2MS+1 + IMRG2=IMRG+N3MS+1 + IF (INDEX(IX,IMRG2).LT.MINDIM(IX)) THEN + IND2(1,IPOS2)=MIN2(1)-1 + ELSE + IND2(1,IPOS2)=ITEMP2(INDEX(IX,IMRG2)) + ENDIF + IF (INDEX(IY,IMRG2).LT.MINDIM(IY)) THEN + IND2(2,IPOS2)=MIN2(2)-1 + ELSE + IND2(2,IPOS2)=ITEMP2(INDEX(IY,IMRG2)) + ENDIF + IND2(3,IPOS2)=ITEMP2(MINDIM(IZ)) + IF (INDEX(4,IMRG2).EQ.0) THEN + IND2(4,IPOS2)=0 + ELSE + IND2(4,IPOS2)=ITEMP2(INDEX(4,IMRG2)) + ENDIF + DO 50 ZPL=0,NZP+1 + IMRG=IND2T3(IPOS,ZPL) + IND2T3(IPOS,ZPL)=KEYMRG(IMRG) + 50 CONTINUE + 60 CONTINUE + IND2(3,N2MS+1)=0 +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(ITEMP2,ITEMP) + RETURN + END diff --git a/Dragon/src/XELBIN.f b/Dragon/src/XELBIN.f new file mode 100644 index 0000000..f84be2f --- /dev/null +++ b/Dragon/src/XELBIN.f @@ -0,0 +1,457 @@ +*DECK XELBIN + SUBROUTINE XELBIN( IPGEOM, NDIM, NGEOME, L1CELL, NTYPES, NGIDL, + > NTIDL, NBLOCK, MAXGRI, NUNKO, IPRT, CELLG, + > NSURO, NVOLO, IDLGEO, MATGEO, KEYGEO, IDLTYP, + > IDLBLK, KEYTYP, MATTYP, KEYINT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Identify every zone of every type to its material and +* interface all internal surfaces for cells present in the supercell. +* +*Copyright: +* Copyright (C) 1987 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPGEOM pointer to the geometry (l_geom). +* NDIM number of dimensions (2 or 3). +* NGEOME number of geometries. +* L1CELL .true. if only one cell. +* NTYPES number of types. +* NGIDL lenght of geometric numbering. +* NTIDL lenght of type numbering. +* NBLOCK number of blocks. +* MAXGRI number of cells along each axis. +* NUNKO old number of unknowns. +* IPRT intermediate printing level for output. +* CELLG to keep geometry names. +* NSURO number of surfaces of each geometry. +* NVOLO number of zones of each geometry. +* IDLGEO position of each geometry in the +* geometry numbering scheme. +* MATGEO material numbers corresponding to geometries. +* KEYGEO geometric key for each type. +* IDLTYP position of each type in numbering scheme. +* IDLBLK position of each block in numbering scheme. +* KEYTYP type key for each block. +* +*Parameters: output +* MATTYP material numbers for zones of every type. +* KEYINT interface key (giving the connected surface). +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +* + TYPE(C_PTR) IPGEOM + INTEGER NDIM, NGEOME, NTYPES, NGIDL, NTIDL, NBLOCK, + > NUNKO, IPRT + INTEGER NSURO(NGEOME), NVOLO(NGEOME), IDLGEO(NGEOME), + > MATGEO( NGIDL), KEYGEO(NTYPES), IDLTYP(NTYPES), + > MATTYP( NTIDL), KEYTYP(NBLOCK), IDLBLK(NBLOCK), + > KEYINT(NUNKO ), MAXGRI(NDIM) , CELLG(3*NTYPES) +* + INTEGER ILO(3,2), NO(2), KTYP(2), + > KMAT(2), KSUR(2), KABSO(2), KSID(2), + > ICOORD(3), NCODE(6) + CHARACTER GEOCEL*12, TEDATA*12, TEMESH(4)*7 + LOGICAL SWKILL, L1CELL, LL1, LL2 + INTEGER NSTATE, IOUT, MAXSPL + PARAMETER ( NSTATE=40, IOUT=6, MAXSPL=100 ) + INTEGER ISTATE(NSTATE),ISPLT(MAXSPL) + INTEGER NUMGEO, NUMTYP, NUMBLK, I, K + INTEGER NBMD + INTEGER IMYT, IUNK, ITYP, IMYG, IGEO, NSUX, NVOX, ICYL, + > ICX, ICY, ICZ, LR, LX, LY, LZ, KOLD, ITYPG, + > ISUR, IX, IY, IZ, IOFF, KNEW, ILEN, ITYLCM, + > ISX, ISY, ISZ, ISR, KIOFX, KIOFY, KIOFZ, + > J0, J1, J2, JC, JR, IP0, IP1, IP2, N, NP1, NP2, + > K0, K1, K2, K3, KR, IBLK, ISUX + EQUIVALENCE ( ICOORD(1),LX ),(ICOORD(2),LY),(ICOORD(3),LZ ) + DATA TEMESH / 'X', 'Y', 'Z', 'R'/ +* + NUMGEO(I,K)= I + IDLGEO(K) + NUMTYP(I,K)= I + IDLTYP(K) + NUMBLK(I,K)= I + IDLBLK(K) +* + SWKILL= .FALSE. + LL1= .FALSE. + LL2= .FALSE. + DO 10 IMYT= 1, NTIDL + MATTYP(IMYT)= 0 + 10 CONTINUE + DO 20 IUNK= 1, NUNKO + KEYINT(IUNK)= 0 + 20 CONTINUE + DO 40 ITYP= 1, NTYPES + IGEO = KEYGEO( ITYP ) + NVOX = NVOLO( IGEO ) + NSUX = NSURO( IGEO ) + IF( .NOT.L1CELL )THEN + WRITE(GEOCEL( 1: 4), '(A4)') CELLG(3*ITYP-2) + WRITE(GEOCEL( 5: 8), '(A4)') CELLG(3*ITYP-1) + WRITE(GEOCEL( 9:12), '(A4)') CELLG(3*ITYP ) + CALL LCMSIX(IPGEOM, GEOCEL, 1) + ELSE + CALL LCMGET(IPGEOM,'NCODE', NCODE) + LL1=((NCODE(2).EQ.3).AND.(NCODE(3).EQ.3)) + LL2=((NCODE(1).EQ.3).AND.(NCODE(4).EQ.3)) + ENDIF + ISTATE(:NSTATE)=0 + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) + ITYPG= ISTATE(1) + IF( ITYPG.EQ.20) THEN +* FOR *CARCEL* GEOMETRIES + ICYL= 1 + ICX= 1 + ICY= 2 + ICZ= 3 + ELSEIF(ITYPG.EQ.3.OR.ITYPG.EQ.6 )THEN +* FOR *CARCEL*, *TUBE* OR *TUBEZ* GEOMETRIES + ICYL= 1 + ICX= 1 + ICY= 2 + ICZ= 3 + IF( LL1.OR.LL2 )THEN + CALL XABORT( 'XELBIN: DIAGONAL SYMETRIES NOT POSSIBLE') + ENDIF + ELSEIF( ITYPG.GT.20 )THEN +* FOR *CARCELX*, *CARCELY* OR *CARCELZ* + ICYL= 1 + ICZ= ITYPG-20 + ICX= MOD(ICZ , 3) + 1 + ICY= MOD(ICZ+1, 3) + 1 + ELSE +* FOR *CAR2D* OR *CAR3D* + ICYL= 0 + ICX= 1 + ICY= 2 + ICZ= 3 + ENDIF + LR= ISTATE(2) + LX= MAX(1,ISTATE(3)) + LY= MAX(1,ISTATE(4)) + LZ= MAX(1,ISTATE(5)) + KOLD= ISTATE(6) + DO 30 ISUR= NSUX, -1 + MATTYP(NUMTYP(ISUR,ITYP))= MATGEO(NUMGEO(ISUR,IGEO)) + 30 CONTINUE +* +* GET MIXTURE NUMBERS + CALL LCMLEN(IPGEOM, 'MIX', ILEN, ITYLCM) + IF( ILEN.NE.KOLD )THEN + WRITE(IOUT,*) 'LENGHT(MIX)= ',ILEN + WRITE(IOUT,*) '# OF VOLUMES= ',KOLD + CALL LCMLIB(IPGEOM) + CALL XABORT( 'XELBIN: INVALID NUMBER OF MIXTURES') + ENDIF + CALL LCMGET(IPGEOM,'MIX',MATTYP(NUMTYP(1,ITYP))) +* +* IN THE CASE OF DIAGONAL SYMMETRY IN 'ONE-CELL' +* CAR2D AND CAR3D GEOMETRY UNFOLD MIXTURES +* + IF(ITYPG .LT. 20) THEN + K3=ISTATE(6) + NBMD=(LZ*LY*(LX+1))/2 + IF(K3 .EQ. NBMD) THEN +*---- +* MIXTURE ENTERED IN DIAGONAL FORM +*---- + IF( LL1 )THEN + DO 72 IZ=LZ,1,-1 + IOFF=(IZ-1)*LX*LY + DO 71 IY=LY,1,-1 + DO 60 IX=LX,IY+1,-1 + MATTYP(NUMTYP(IOFF+(IY-1)*LX+IX,ITYP))= + > MATTYP(NUMTYP(IOFF+(IX-1)*LY+IY,ITYP)) + 60 CONTINUE + DO 70 IX=IY,1,-1 + MATTYP(NUMTYP(IOFF+(IY-1)*LX+IX,ITYP))= + > MATTYP(NUMTYP(K3,ITYP)) + K3=K3-1 + 70 CONTINUE + 71 CONTINUE + 72 CONTINUE + KOLD= LX*LY*LZ + ELSEIF( LL2 )THEN + DO 82 IZ=LZ,1,-1 + IOFF=(IZ-1)*LX*LY + DO 81 IY=LY,1,-1 + DO 80 IX=LX,IY,-1 + MATTYP(NUMTYP(IOFF+(IY-1)*LX+IX,ITYP))= + > MATTYP(NUMTYP(K3,ITYP)) + K3=K3-1 + 80 CONTINUE + 81 CONTINUE + 82 CONTINUE + DO 92 IZ=1,LZ + IOFF=(IZ-1)*LX*LY + DO 91 IY=1,LY + DO 90 IX=1,IY-1 + MATTYP(NUMTYP(IOFF+(IY-1)*LX+IX,ITYP))= + > MATTYP(NUMTYP(IOFF+(IX-1)*LY+IY,ITYP)) + 90 CONTINUE + 91 CONTINUE + 92 CONTINUE + KOLD= LX*LY*LZ + ENDIF + ENDIF + ENDIF +* +* FOR THE PARTICULAR CASE OF *TUBE* OR *TUBEZ* GEOMETRIES + IF( ITYPG.EQ.3.OR.ITYPG.EQ.6 )THEN + DO 39 IZ= 1, LZ + MATTYP(NUMTYP(KOLD+IZ,ITYP))= -2 + 39 CONTINUE + KOLD= KOLD+LZ + ENDIF +* +* FILL UP MATTYP ACCORDING TO SPLITTING VALUES. + KNEW= NVOX + ISR= 0 + ISX= 0 + ISY= 0 + ISZ= 0 + DO 308 K0= ICOORD(ICZ),1,-1 + KIOFZ= KOLD + TEDATA= 'SPLIT'//TEMESH(ICZ) + CALL LCMLEN(IPGEOM,TEDATA,ILEN,ITYLCM) + IF( ILEN.GT.MAXSPL )THEN + CALL XABORT('XELBIN: SPLIT OVERFLOW ('//TEDATA//')') + ELSEIF( ILEN.EQ.0 )THEN + ISZ= 1 + ELSE + CALL LCMGET(IPGEOM,TEDATA,ISPLT) + ISZ= ISPLT(K0) + ENDIF + DO 307 J0=ISZ,1,-1 + KOLD= KIOFZ + DO 306 K1= ICOORD(ICY),1,-1 + KIOFY= KOLD + TEDATA= 'SPLIT'//TEMESH(ICY) + CALL LCMLEN(IPGEOM,TEDATA,ILEN,ITYLCM) + IF( ILEN.GT.MAXSPL )THEN + CALL XABORT('XELBIN: SPLIT OVERFLOW ('//TEDATA//')') + ELSEIF( ILEN.EQ.0 )THEN + ISY= 1 + ELSE + CALL LCMGET(IPGEOM,TEDATA,ISPLT) + ISY= ISPLT(K1) + ENDIF + DO 305 J1=ISY,1,-1 + KOLD= KIOFY + DO 304 K2= ICOORD(ICX),1,-1 + KIOFX= KOLD + TEDATA= 'SPLIT'//TEMESH(ICX) + CALL LCMLEN(IPGEOM,TEDATA,ILEN,ITYLCM) + IF( ILEN.GT.MAXSPL )THEN + CALL XABORT('XELBIN: SPLIT OVERFLOW ('//TEDATA//')') + ELSEIF( ILEN.EQ.0 )THEN + ISX= 1 + ELSE + CALL LCMGET(IPGEOM,TEDATA,ISPLT) + ISX= ISPLT(K2) + ENDIF + DO 303 J2=ISX,1,-1 + KOLD= KIOFX +* FOR RECTANGULAR OUTER REGIONS. + IMYT= MATTYP(NUMTYP(KOLD,ITYP)) + MATTYP(NUMTYP(KNEW,ITYP))= IMYT + KNEW= KNEW-1 + KOLD= KOLD-1 + IF( ICYL.EQ.1 )THEN +* FOR CYLINDRICAL INNER REGIONS. + DO 302 KR= LR,1,-1 + TEDATA= 'SPLIT'//TEMESH(4) + CALL LCMLEN(IPGEOM,TEDATA,ILEN,ITYLCM) + IF( ILEN.GT.MAXSPL )THEN + CALL XABORT('XELBIN: SPLIT OVERFLOW ('//TEDATA//')') + ELSEIF( ILEN.EQ.0 )THEN + ISR= 1 + ELSE + CALL LCMGET(IPGEOM,TEDATA,ISPLT) + ISR= ABS(ISPLT(KR)) + ENDIF + IMYT= MATTYP(NUMTYP(KOLD,ITYP)) + DO 301 JR=ISR,1,-1 + MATTYP(NUMTYP(KNEW,ITYP))= IMYT + KNEW= KNEW-1 + 301 CONTINUE + KOLD= KOLD-1 + 302 CONTINUE + ENDIF + 303 CONTINUE + 304 CONTINUE + 305 CONTINUE + 306 CONTINUE + 307 CONTINUE + 308 CONTINUE + IF( KNEW.NE.0 )THEN + WRITE(IOUT,*) 'XELBIN: KNEW.NE.0 = PROBLEM WITH SPLITTING' + SWKILL= .TRUE. + ENDIF + IF( KOLD.NE.0 )THEN + WRITE(IOUT,*) 'XELBIN: KOLD.NE.0 = PROBLEM WITH SPLITTING' + SWKILL= .TRUE. + ENDIF +* + IF( .NOT.L1CELL ) CALL LCMSIX(IPGEOM, ' ', 2) + 40 CONTINUE +* +* RECOMPOSE INTERNAL SURFACES COUPLING (INTERFACES) +* THIS ASSUMES THAT AN ORDERING OF SURFACES IS DONE +* BECAUSE: SIDE-BY-SIDE INTERFACES +* ARE SUPPOSED IN INCREASING POSITION. + DO 220 N= 1, NDIM +* +* DEFINITION OF THE SIDE NUMBER TO COUPLE. + KSID(1)= -2*N + KSID(2)= (-2*N) + 1 + NP1 = MOD(N ,NDIM) + 1 + IF( NDIM.EQ.3 )THEN + NP2 = MOD(N+1,NDIM) + 1 + DO 112 IP1= 1, MAXGRI(NP1) + ILO(NP1,1)= IP1 + ILO(NP1,2)= IP1 + DO 111 IP2= 1, MAXGRI(NP2) + ILO(NP2,1)= IP2 + ILO(NP2,2)= IP2 + DO 110 IP0= 1, MAXGRI(N)-1 + ILO(N ,1)= IP0 + ILO(N ,2)= IP0 + 1 + DO 100 JC= 1, 2 + NO(JC)= MAXGRI(1)*(MAXGRI(2)*ILO(3,JC)+ILO(2,JC)- + > MAXGRI(2))+ILO(1,JC)-MAXGRI(1) + KTYP(JC)= KEYTYP( NO(JC) ) + IF( KTYP(JC).EQ.0 ) GO TO 110 + IGEO = KEYGEO( KTYP(JC) ) +* SEARCH FROM THE END + KSUR(JC)= NSURO(IGEO) + KMAT(JC)= MATTYP( NUMTYP(KSUR(JC),KTYP(JC)) ) + 100 CONTINUE +* +* ORDERING INTERFACING OF THE TWO BLOCKS. + 101 CONTINUE + IF( KMAT(1).EQ.KSID(1).AND.KMAT(2).EQ.KSID(2) )THEN + IF( KSUR(1).EQ.0 .OR. KSUR(2).EQ.0 ) GO TO 109 + KABSO(1)= NUMBLK( KSUR(1),NO(1) ) + KABSO(2)= NUMBLK( KSUR(2),NO(2) ) + KEYINT( KABSO(1) )= KABSO(2) + KEYINT( KABSO(2) )= KABSO(1) + KSUR(1)= KSUR(1)+1 + KSUR(2)= KSUR(2)+1 + ELSE + IF( KMAT(1).NE.KSID(1) ) KSUR(1)= KSUR(1)+1 + IF( KMAT(2).NE.KSID(2) ) KSUR(2)= KSUR(2)+1 + ENDIF + IF( KSUR(1).NE.0 )THEN + KMAT(1)= MATTYP( NUMTYP(KSUR(1),KTYP(1)) ) + ELSE + KMAT(1)= KSID(1) + ENDIF + IF( KSUR(2).NE.0 )THEN + KMAT(2)= MATTYP( NUMTYP(KSUR(2),KTYP(2)) ) + ELSE + KMAT(2)= KSID(2) + ENDIF + GO TO 101 + 109 IF( KSUR(1).NE.0 .OR. KSUR(2).NE.0 )THEN + WRITE(IOUT,'(1H ,I8,4H OF ,I8,5H <=> ,I8,4H OF ,I8)') + > KSUR(1), NO(1), KSUR(2), NO(2) + SWKILL=.TRUE. + ENDIF + 110 CONTINUE + 111 CONTINUE + 112 CONTINUE + ELSEIF( NDIM.EQ.2 )THEN + DO 215 IP1= 1, MAXGRI(NP1) + ILO(NP1,1)= IP1 + ILO(NP1,2)= IP1 + DO 210 IP0= 1, MAXGRI(N)-1 + ILO(N ,1)= IP0 + ILO(N ,2)= IP0 + 1 + DO 200 JC= 1, 2 + NO(JC)= MAXGRI(1) * (ILO(2,JC) - 1) + ILO(1,JC) + KTYP(JC)= KEYTYP( NO(JC) ) + IF( KTYP(JC).EQ.0 ) GO TO 210 + IGEO = KEYGEO( KTYP(JC) ) +* SEARCH FROM THE END + KSUR(JC)= NSURO(IGEO) + KMAT(JC)= MATTYP( NUMTYP(KSUR(JC),KTYP(JC)) ) + 200 CONTINUE +* +* ORDERING INTERFACING OF THE TWO BLOCKS. + 201 CONTINUE + IF( KMAT(1).EQ.KSID(1).AND.KMAT(2).EQ.KSID(2) )THEN + IF( KSUR(1).EQ.0 .OR. KSUR(2).EQ.0 ) GO TO 209 + KABSO(1)= NUMBLK( KSUR(1),NO(1) ) + KABSO(2)= NUMBLK( KSUR(2),NO(2) ) + KEYINT( KABSO(1) )= KABSO(2) + KEYINT( KABSO(2) )= KABSO(1) + KSUR(1)= KSUR(1)+1 + KSUR(2)= KSUR(2)+1 + ELSE + IF( KMAT(1).NE.KSID(1) ) KSUR(1)= KSUR(1)+1 + IF( KMAT(2).NE.KSID(2) ) KSUR(2)= KSUR(2)+1 + ENDIF + IF( KSUR(1).NE.0 )THEN + KMAT(1)= MATTYP( NUMTYP(KSUR(1),KTYP(1)) ) + ELSE + KMAT(1)= KSID(1) + ENDIF + IF( KSUR(2).NE.0 )THEN + KMAT(2)= MATTYP( NUMTYP(KSUR(2),KTYP(2)) ) + ELSE + KMAT(2)= KSID(2) + ENDIF + GO TO 201 + 209 IF( KSUR(1).NE.0 .OR. KSUR(2).NE.0 )THEN + WRITE(IOUT,'(1H ,I8,4H OF ,I8,5H <=> ,I8,4H OF ,I8)') + > KSUR(1), NO(1), KSUR(2), NO(2) + SWKILL=.TRUE. + ENDIF + 210 CONTINUE + 215 CONTINUE + ELSE + CALL LCMLIB(IPGEOM) + CALL XABORT( 'XELBIN: *** FALSE NDIM VALUE') + ENDIF + 220 CONTINUE +* + IF( IPRT.GE.100 .OR. SWKILL )THEN + IUNK= 0 + WRITE(IOUT,'(/40H KEYINT COUPLE MATERIAL )') + DO 250 IBLK= 1, NBLOCK + ITYP= KEYTYP(IBLK) + IGEO= KEYGEO(ITYP) + NVOX= NVOLO(IGEO) + NSUX= NSURO(IGEO) + DO 240 ISUX= NSUX, NVOX + IUNK= IUNK+1 + IMYT= MATTYP( NUMTYP(ISUX,ITYP) ) + IF( ISUX.LT.0 )THEN + WRITE(IOUT, + > '(5H SUR(,I8,5H) => ,I8,4H OF , I8)') + > IUNK, KEYINT(IUNK), IMYT + ELSEIF( ISUX.GT.0 )THEN + IMYG= MATGEO( NUMGEO(ISUX,IGEO) ) + WRITE(IOUT, + > '(5H VOL(,I8,5H) => ,I8,4H OF , I8,1H(,I8,1H))') + > IUNK, KEYINT(IUNK), IMYT, IMYG + ENDIF + 240 CONTINUE + WRITE(IOUT,'(/1X)') + 250 CONTINUE + ENDIF + IF( SWKILL ) CALL XABORT( 'XELBIN: IMPOSSIBLE TO INTERFACE') +* + RETURN + END diff --git a/Dragon/src/XELCMP.f b/Dragon/src/XELCMP.f new file mode 100644 index 0000000..adfbaa2 --- /dev/null +++ b/Dragon/src/XELCMP.f @@ -0,0 +1,131 @@ +*DECK XELCMP + SUBROUTINE XELCMP( NS, NV, VOLIN, MATIN, MRGIN, + > NSOUT, NVOUT, VOLOUT, MATOUT, ITGEO, ICODE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Merge volumes and surfaces and recompute the number of surfaces +* and volumes. +* +*Copyright: +* Copyright (C) 1991 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* NS number of surfaces before merging. +* NV number of zones before merging. +* VOLIN volumes and surfaces before merging. +* MATIN numbering of sufaces and zones before merging. +* MRGIN merging index. +* ITGEO kind of geometry(0,1,2,3). +* ICODE index of boundary conditions. +* +*Parameters: output +* NSOUT number of surfaces after merging. +* NVOUT number of zones after merging. +* VOLOUT volumes and surfaces after merging. +* MATOUT numbering of sufaces and zones after merging. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +* + INTEGER NS,NV,NSOUT,NVOUT,ITGEO,IVS,IMR,ICNT,I0,IOUT, + > IR,JR,MATMRG,LESOIR, + > MATIN(-NS:NV),MRGIN(-NS:NV),MATOUT(*),ICODE(6) + REAL VOLIN(-NS:NV),VOLOUT(*),ZERO + CHARACTER*4 CORIEN(0:3,-6:0) + PARAMETER ( ZERO= 0.0, IOUT=6 ) + DATA ((CORIEN(JR,IR),IR=-6,0),JR=0,3) + > / ' O6 ',' O5 ',' O4 ',' O3 ',' O2 ',' O1 ',' ', + > ' Z+ ',' Z- ','****','****',' R+ ','****',' ', + > ' Z+ ',' Z- ','****','****','****','HBC ',' ', + > ' Z+ ',' Z- ',' Y+ ',' Y- ',' X+ ',' X- ',' '/ +* +* FIND NSOUT AND NVOUT & INITIALIZE VOLOUT AND MATOUT + NSOUT= 0 + NVOUT= 0 + DO 10 IVS= -NS, NV + VOLOUT(IVS+NS+1)= ZERO + MATOUT(IVS+NS+1)= 0 + IF( IVS.GT.0 )THEN + IF( MRGIN(IVS).LT.0 )THEN + CALL XABORT( 'XELCMP: 1.INCOMPATIBLE MERGE INDEX' ) + ENDIF + ELSEIF( IVS.LT.0 )THEN + IF( MRGIN(IVS).GT.0 )THEN + CALL XABORT( 'XELCMP: 2.INCOMPATIBLE MERGE INDEX' ) + ENDIF + ELSE + IF( MRGIN(IVS).NE.0 )THEN + WRITE(IOUT,*) 'XELCMP: *KEYMRG* VECTOR IS:', MRGIN + CALL XABORT( 'XELCMP: 3.INCOMPATIBLE MERGE INDEX' ) + ENDIF + IF( VOLIN(IVS).NE.0.0 )THEN + WRITE(IOUT,*) 'XELCMP: *VOLSUR* VECTOR IS:', VOLIN + CALL XABORT( 'XELCMP: 4. VOLSUR(0).NE.0 ON TRACK-FILE' ) + ENDIF + IF( MATIN(IVS).NE.0 )THEN + WRITE(IOUT,*) 'XELCMP: *MATALB* VECTOR IS:', MATIN + CALL XABORT( 'XELCMP: 5. MATALB(0).NE.0 ON TRACK-FILE' ) + ENDIF + ENDIF + NSOUT= MIN(NSOUT,MRGIN(IVS)) + NVOUT= MAX(NVOUT,MRGIN(IVS)) + 10 CONTINUE + NSOUT= -NSOUT +* +* ALL VALUES MUST BE PRESENT BETWEEN -NSOUT AND NVOUT IN MRGIN(*) +* BUT WITH THE SAME MATIN(*) NUMBER FOR MERGED ZONES. +* NEW(97/11): 0 MEANS REGION IS REMOVED + DO 30 IMR= -NSOUT, NVOUT + ICNT= 0 + DO 20 IVS= -NS, NV + IF( ICNT.EQ.0 ) MATMRG= MATIN(IVS) + IF( MRGIN(IVS).EQ.IMR )THEN + ICNT= ICNT+1 + IF( MATMRG.NE.MATIN(IVS) )THEN + LESOIR= MATIN(IVS) + IF( IVS.GE.0 )THEN +* +* FOR MERGING ZONES, ABORT IF NOT SAME *MATALB* + WRITE(IOUT,*) '*** ABORT *** ATTEMPT TO MERGE '// + > 'MIX ',MATMRG,' WITH MIX ', + > LESOIR,' IN ZONE #',IVS + CALL XABORT( 'XELCMP: 6.INCOMPATIBLE MERGE INDEX' ) + ELSE +* +* FOR MERGING FACES, ABORT IF NOT SAME *ICODE* + IF( ICODE(-MATMRG).NE.ICODE(-LESOIR) )THEN + WRITE(IOUT,*) '*** ABORT *** ATTEMPT TO MERGE ', + > ' FACE ',-IVS, + > '( ',CORIEN(ITGEO,MATMRG),',ICODE=', + > ICODE(-MATMRG),') WITH A FACE ', + > '( ',CORIEN(ITGEO,LESOIR),',ICODE=', + > ICODE(-LESOIR),'). ' + CALL XABORT( 'XELCMP: 7.INCOMPATIBLE MERGE INDEX' ) + ENDIF + ENDIF + ENDIF + ENDIF + 20 CONTINUE + IF( ICNT.EQ.0 )THEN + CALL XABORT( 'XELCMP: 8.MISSING VALUES IN THE MERGE INDEX' ) + ENDIF + 30 CONTINUE +* +* COMPUTE VOLOUT AND MATOUT VALUES + I0= 1 + NSOUT + DO 40 IVS= -NS, NV + VOLOUT(I0+MRGIN(IVS))= VOLOUT(I0+MRGIN(IVS))+VOLIN(IVS) + MATOUT(I0+MRGIN(IVS))= MATIN(IVS) + 40 CONTINUE +* + RETURN + END diff --git a/Dragon/src/XELCOP.f b/Dragon/src/XELCOP.f new file mode 100644 index 0000000..1da89d8 --- /dev/null +++ b/Dragon/src/XELCOP.f @@ -0,0 +1,118 @@ +*DECK XELCOP + SUBROUTINE XELCOP( IFILE1, IFILE2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Copy the DRAGON tracking file IFILE1 over IFILE2. +* +*Copyright: +* Copyright (C) 1991 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IFILE1 first tracking file number (AT INPUT). +* IFILE2 second tracking file number (AT OUTPUT). +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +C + DOUBLE PRECISION WEIGHT + INTEGER IFILE1,IFILE2,NCOMNT,NTRK,IFMT,IREC,IC,IR,NDIM, + > ISPEC,NV,NS,NALBG,NCOR,NANGL,MXSUB,MXSEG,NSUB, + > LINE,NUNKNO + CHARACTER CTRK*4, COMENT*80 + INTEGER IOUT + PARAMETER ( IOUT=6 ) +C---- +C ALLOCATABLE ARRAYS +C---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MATALB,ICODE,NRSEG,KANGL + REAL, ALLOCATABLE, DIMENSION(:) :: VOLSUR,ALBEDO + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: ANGLES,DENSTY + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SEGLEN +C +C.1) READ AND COPY FIRST RECORDS (HEADER, COMMENTS) ------------------ +C + IREC= 1 + READ (IFILE1,ERR=991) CTRK,NCOMNT,NTRK,IFMT + WRITE(IFILE2,ERR=992) CTRK,NCOMNT,NTRK,IFMT + DO 10 IC= 1, NCOMNT + IREC= IREC+1 + READ (IFILE1,ERR=991) COMENT + WRITE(IFILE2,ERR=992) COMENT + 10 CONTINUE +C +C.2) READ AND COPY MAIN RECORD AND GET USEFUL DIMENSIONS ------------- +C + IREC= IREC+1 + READ (IFILE1,ERR=991) NDIM,ISPEC,NV,NS,NALBG,NCOR,NANGL,MXSUB, + > MXSEG + WRITE(IFILE2,ERR=992) NDIM,ISPEC,NV,NS,NALBG,NCOR,NANGL,MXSUB, + > MXSEG + NUNKNO= NV+NS+1 +C +C.2.1) ALLOCATE SPACE TO COPY SUBSEQUENT RECORDS + ALLOCATE(MATALB(NUNKNO),ICODE(NALBG),NRSEG(MXSEG),KANGL(MXSUB)) + ALLOCATE(VOLSUR(NUNKNO),ALBEDO(NALBG),ANGLES(NDIM*NANGL), + > DENSTY(NANGL),SEGLEN(MXSEG)) +C +C.2.2) COPY ALL RECORDS BEFORE TRACKS + IREC= IREC+1 + READ (IFILE1,ERR=991) (VOLSUR(IR),IR=1,NUNKNO) + WRITE(IFILE2,ERR=992) (VOLSUR(IR),IR=1,NUNKNO) + IREC= IREC+1 + READ (IFILE1,ERR=991) (MATALB(IR),IR=1,NUNKNO) + WRITE(IFILE2,ERR=992) (MATALB(IR),IR=1,NUNKNO) + IREC= IREC+1 + READ (IFILE1,ERR=991) (ICODE(IR),IR=1,NALBG) + WRITE(IFILE2,ERR=992) (ICODE(IR),IR=1,NALBG) + IREC= IREC+1 + READ (IFILE1,ERR=991) (ALBEDO(IR),IR=1,NALBG) + WRITE(IFILE2,ERR=992) (ALBEDO(IR),IR=1,NALBG) + IREC= IREC+1 + READ (IFILE1,ERR=991) (ANGLES(IR),IR=1,NDIM*NANGL) + WRITE(IFILE2,ERR=992) (ANGLES(IR),IR=1,NDIM*NANGL) + IREC= IREC+1 + READ (IFILE1,ERR=991) (DENSTY(IR),IR=1,NANGL) + WRITE(IFILE2,ERR=992) (DENSTY(IR),IR=1,NANGL) +C +C.3) NOW, COPY ALL TRACKS ------------------------------------------- +C + 20 CONTINUE + IREC= IREC + 1 + READ (IFILE1,END=40,ERR=991) NSUB,LINE,WEIGHT, + > (KANGL(IR),IR=1,NSUB), + > (NRSEG(IR),IR=1,LINE),(SEGLEN(IR),IR=1,LINE) + IF(NSUB.GT.MXSUB) CALL XABORT('XELCOP: MXSUB OVERFLOW.') + WRITE(IFILE2, ERR=992) NSUB,LINE,WEIGHT, + > (KANGL(IR),IR=1,NSUB), + > (NRSEG(IR),IR=1,LINE),(SEGLEN(IR),IR=1,LINE) + GO TO 20 +C + 40 CONTINUE +C +C.4) RELEASE TEMPORARY SPACE AND REWIND BOTH FILES ------------------ +C + DEALLOCATE(KANGL,SEGLEN,DENSTY,ANGLES,ALBEDO,VOLSUR) + DEALLOCATE(NRSEG,ICODE,MATALB) + REWIND IFILE1 + REWIND IFILE2 + RETURN +C + 991 WRITE(IOUT,'(30H ERROR= RECORD DESTROYED... )') + WRITE(IOUT,'(31H ERROR= UNABLE TO READ RECORD ,I10)') IREC + WRITE(IOUT,'(31H ERROR= ON FILE FT,I2.2)') IFILE1 + CALL XABORT( 'XELCOP: --- READ TRACKING FILE FAILED' ) + 992 WRITE(IOUT,'(30H ERROR= NOT ENOUGH SPACE... )') + WRITE(IOUT,'(31H ERROR= UNABLE TO WRITE RECORD ,I8.8)') IREC + WRITE(IOUT,'(31H ERROR= ON FILE FT,I2.2)') IFILE1 + CALL XABORT( 'XELCOP: --- WRITE TRACKING FILE FAILED' ) +C + END diff --git a/Dragon/src/XELCOR.f b/Dragon/src/XELCOR.f new file mode 100644 index 0000000..2d5079d --- /dev/null +++ b/Dragon/src/XELCOR.f @@ -0,0 +1,183 @@ +*DECK XELCOR + SUBROUTINE XELCOR(IFILE1,IFILE2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Produce an equivalent tracking with NCOR=1. +* +*Copyright: +* Copyright (C) 2009 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IFILE1 input tracking file. +* IFILE2 output tracking file. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IFILE1,IFILE2 +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION WEIGHT,WEIGHT2 + INTEGER NCOMNT,NTRK,IFMT,IREC,IC,IR,NDIM,ISPEC,NV,NS, + > NALBG,NCOR,NANGL,MXSUB,MXSEG,NSUB, LINE,NUNKNO + CHARACTER CTRK*4, COMENT*80 + INTEGER IOUT + PARAMETER ( IOUT=6 ) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MATALB,ICODE,NRSEG,KANGL + REAL, ALLOCATABLE, DIMENSION(:) :: VOLSUR,ALBEDO + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: ANGLES,DENSTY + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SEGLEN +*---- +* SET NCOMNT, NUNKNO, NDIM, NALBG, NCOR ,NANGL AND MXSEG +*---- + READ (IFILE1,ERR=991) CTRK,NCOMNT,NTRK,IFMT + DO 10 IC= 1, NCOMNT + READ (IFILE1,ERR=991) + 10 CONTINUE + READ (IFILE1,ERR=991) NDIM,ISPEC,NV,NS,NALBG,NCOR,NANGL,MXSUB, + > MXSEG + DO 20 IC= 1, 6 + READ (IFILE1,ERR=991) + 20 CONTINUE +*---- +* ALLOCATE SPACE TO COPY SUBSEQUENT RECORDS +*---- + NUNKNO= NV+NS+1 + ALLOCATE(MATALB(NUNKNO),ICODE(NALBG),NRSEG(MXSEG),KANGL(MXSUB)) + ALLOCATE(VOLSUR(NUNKNO),ALBEDO(NALBG),ANGLES(NDIM*NANGL), + > DENSTY(NANGL),SEGLEN(MXSEG)) +*---- +* COMPUTE THE NUMBER OF TRACKS +*---- + NTRK2=0 + 30 CONTINUE + READ (IFILE1,END=40,ERR=991) NSUB,LINE,WEIGHT, + > (KANGL(IR),IR=1,NSUB), + > (NRSEG(IR+1),IR=0,LINE-1), + > (SEGLEN(IR+1),IR=0,LINE-1) + IF(NSUB.GT.MXSUB) CALL XABORT('XELCOR: MXSUB OVERFLOW.') + IF(NCOR.EQ.1) THEN + NTRK2=NTRK2+1 + ELSE + I1=1 + DO IR=2,NCOR + IF(NRSEG(IR).NE.NRSEG(1)) I1=NCOR + ENDDO + I2=1 + DO IR=2,NCOR + IF(NRSEG(LINE-NCOR+IR).NE.NRSEG(LINE-NCOR+1)) I2=NCOR + ENDDO + NTRK2=NTRK2+I1*I2 + ENDIF + GO TO 30 + 40 CONTINUE +*---- +* READ AND COPY FIRST RECORDS (HEADER, COMMENTS) +*---- + REWIND IFILE1 + IREC= 1 + READ (IFILE1,ERR=991) CTRK,NCOMNT,NTRK,IFMT + WRITE(IFILE2,ERR=992) CTRK,NCOMNT,NTRK2,IFMT + DO 50 IC= 1, NCOMNT + IREC= IREC+1 + READ (IFILE1,ERR=991) COMENT + WRITE(IFILE2,ERR=992) COMENT + 50 CONTINUE +*---- +* READ AND COPY MAIN RECORD AND GET USEFUL DIMENSIONS +*---- + IREC= IREC+1 + READ (IFILE1,ERR=991) NDIM,ISPEC,NV,NS,NALBG,NCOR,NANGL,MXSUB, + > MXSEG + WRITE(IFILE2,ERR=992) NDIM,ISPEC,NV,NS,NALBG,1,NANGL,MXSUB,MXSEG + NUNKNO= NV+NS+1 +*---- +* COPY ALL RECORDS BEFORE TRACKS +*---- + IREC= IREC+1 + READ (IFILE1,ERR=991) (VOLSUR(IR),IR=1,NUNKNO) + WRITE(IFILE2,ERR=992) (VOLSUR(IR),IR=1,NUNKNO) + IREC= IREC+1 + READ (IFILE1,ERR=991) (MATALB(IR),IR=1,NUNKNO) + WRITE(IFILE2,ERR=992) (MATALB(IR),IR=1,NUNKNO) + IREC= IREC+1 + READ (IFILE1,ERR=991) (ICODE(IR),IR=1,NALBG) + WRITE(IFILE2,ERR=992) (ICODE(IR),IR=1,NALBG) + IREC= IREC+1 + READ (IFILE1,ERR=991) (ALBEDO(IR),IR=1,NALBG) + WRITE(IFILE2,ERR=992) (ALBEDO(IR),IR=1,NALBG) + IREC= IREC+1 + READ (IFILE1,ERR=991) (ANGLES(IR),IR=1,NDIM*NANGL) + WRITE(IFILE2,ERR=992) (ANGLES(IR),IR=1,NDIM*NANGL) + IREC= IREC+1 + READ (IFILE1,ERR=991) (DENSTY(IR),IR=1,NANGL) + WRITE(IFILE2,ERR=992) (DENSTY(IR),IR=1,NANGL) +*---- +* NOW, COPY ALL TRACKS +*---- + 60 CONTINUE + IREC= IREC + 1 + READ (IFILE1,END=70,ERR=991) NSUB,LINE,WEIGHT, + > (KANGL(IR),IR=1,NSUB), + > (NRSEG(IR),IR=1,LINE),(SEGLEN(IR),IR=1,LINE) + IF(NCOR.EQ.1) THEN + WRITE(IFILE2,ERR=992) NSUB,LINE,WEIGHT, + > (KANGL(IR),IR=1,NSUB), + > (NRSEG(IR),IR=1,LINE),(SEGLEN(IR),IR=1,LINE) + ELSE + I1=1 + DO IR=2,NCOR + IF(NRSEG(IR).NE.NRSEG(1)) I1=NCOR + ENDDO + I2=1 + DO IR=2,NCOR + IF(NRSEG(LINE-NCOR+IR).NE.NRSEG(LINE-NCOR+1)) I2=NCOR + ENDDO + DO IS=1,I1 + DO JS=1,I2 + WEIGHT2=WEIGHT + IF(I1.GT.1) WEIGHT2=SEGLEN(IS)*WEIGHT2 + IF(I2.GT.1) WEIGHT2=SEGLEN(LINE-NCOR+JS)*WEIGHT2 + ISURF=NRSEG(IS) + JSURF=NRSEG(LINE-NCOR+JS) + WRITE(IFILE2,ERR=992) NSUB,LINE-2*NCOR+2,WEIGHT2, + > (KANGL(IR),IR=1,NSUB), + > ISURF,(NRSEG(IR+1),IR=NCOR,LINE-NCOR-1),JSURF, + > 1.0D0,(SEGLEN(IR+1),IR=NCOR,LINE-NCOR-1),1.0D0 + ENDDO + ENDDO + ENDIF + GO TO 60 + 70 CONTINUE +*---- +* RELEASE TEMPORARY SPACE AND REWIND BOTH FILES +*---- + DEALLOCATE(KANGL,SEGLEN,DENSTY,ANGLES,ALBEDO,VOLSUR) + DEALLOCATE(NRSEG,ICODE,MATALB) + REWIND IFILE1 + REWIND IFILE2 + RETURN +* + 991 WRITE(IOUT,'(30H ERROR= RECORD DESTROYED... )') + WRITE(IOUT,'(31H ERROR= UNABLE TO READ RECORD ,I10)') IREC + WRITE(IOUT,'(31H ERROR= ON FILE FT,I2.2)') IFILE1 + CALL XABORT( 'XELCOR: --- READ TRACKING FILE FAILED' ) + 992 WRITE(IOUT,'(30H ERROR= NOT ENOUGH SPACE... )') + WRITE(IOUT,'(31H ERROR= UNABLE TO WRITE RECORD ,I10)') IREC + WRITE(IOUT,'(31H ERROR= ON FILE FT,I2.2)') IFILE1 + CALL XABORT( 'XELCOR: --- WRITE TRACKING FILE FAILED' ) + END diff --git a/Dragon/src/XELCRN.f b/Dragon/src/XELCRN.f new file mode 100644 index 0000000..0c7fa54 --- /dev/null +++ b/Dragon/src/XELCRN.f @@ -0,0 +1,251 @@ +*DECK XELCRN + SUBROUTINE XELCRN(IPRINT,RANN2,NRSPX,NRSPY,SPAT,AREAI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find 2-D surface of intersection between annular region and +* Cartesian plane. +* +*Copyright: +* Copyright (C) 1997 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* IPRINT print level (active if >=10). +* RANN2 annular region radius**2. +* NRSPX number of mesh in x- direction. +* NRSPY number of mesh in x- direction. +* SPAT spatial mesh x-direction: +* SPAT(1,1) = lower X - position; +* SPAT(NRSPX+1,1) = upper X - position; +* SPAT(1,2) = lower Y - position; +* SPAT(NRSPY+1,2) = upper Y - position. +* +*Parameters: output +* AREAI area of intersection. +* +*-------------------------- XELCRN ------------------------------- +* + IMPLICIT NONE + INTEGER IPRINT,NRSPX,NRSPY + DOUBLE PRECISION RANN2,SPAT(NRSPX+1,NRSPY+1), + > AREAI(NRSPX,NRSPY) +*---- +* INTERNAL PARAMETERS +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='XELCRN') + DOUBLE PRECISION PI,DZERO + PARAMETER (PI=3.14159265358979323846D0,DZERO=0.0D0) +*---- +* LOCAL VARIABLES +*---- + INTEGER IRP(2,2),IX,NMX,IY,NMY + DOUBLE PRECISION XELPSC,XELPSI,XYPOS(2,2),XYPOS2(2,2), + > SPXY(2,2),SIXY(2,2),RANN,SURANN +*---- +* COMPUTE GENERAL ANNULAR REGION INFORMATIONS +* RANN = ANNULAR REGION RADIUS +* SURANN = ANNULAR SURFACE +* COMPUTE CARTESIAN PARAMETERS +* NMX =NRSPX+1 +* NMY =NRSPY+1 +* INITIALIZE AREAI TO 0.0D0 +*---- + RANN=SQRT(RANN2) + SURANN=PI*RANN2 + NMX=NRSPX+1 + NMY=NRSPY+1 + AREAI(:NRSPX,:NRSPY)=DZERO + IRP(:2,:2)=0 +*---- +* PRINT INITIAL MESH IF REQUIRED +*----- + IF(IPRINT .GE. 10) THEN + WRITE(IOUT,6000) + WRITE(IOUT,6002) 'ANNULAR RADIUS ' + WRITE(IOUT,6003) RANN + WRITE(IOUT,6002) 'ANNULAR SURFACE ' + WRITE(IOUT,6003) SURANN + WRITE(IOUT,6002) 'X-DIRECTED MESH ' + WRITE(IOUT,6003) (SPAT(IX,1),IX=1,NRSPX+1) + WRITE(IOUT,6002) 'Y-DIRECTED MESH ' + WRITE(IOUT,6003) (SPAT(IY,2),IY=1,NRSPY+1) + WRITE(IOUT,6002) 'X-Y SURFACES ' + WRITE(IOUT,6003) (( (SPAT(IX+1,1)-SPAT(IX,1)) + > *(SPAT(IY+1,2)-SPAT(IY,2)), + > IX=1,NRSPX),IY=1,NRSPY) + ENDIF +*---- +* CYCLE OVER CARTESIAN Y-DIRECTIONS STARTING FROM THE END +* AND LOCATE Y-MESH POSITION WITH RESPECT TO ANNULUS CENTER +*---- + SPXY(2,2)=DZERO + DO 110 IY=NMY,1,-1 + XYPOS(2,1)=SPAT(IY,2) + XYPOS2(2,1)=XYPOS(2,1)*XYPOS(2,1) +*---- +* FIND IF ANNULUS ABOVE, BELOW OR INTERSECT CURRENT Y-PLANE +* AND COMPUTE +* SPXY = ANNULAR SURFACE BELOW CURRENT PLANE +* IF ANNULUS BELOW CURRENT PLANE (XYPOS(2,1)>= RANN) +* IRPY(2,1)=-1 +* SPXY(2,1)=SURANN +* IF ANNULUS ABOVE CURRENT PLANE (XYPOS(2,1)<= -RANN) +* IRPY(2,1)= 1 +* SPXY(2,1)=0.0 +* IF ANNULUS INTERSECT CURRENT ( -RANN < XYPOS(2,1) < RANN) +* IRPY(2,1)= 0 +* SPXY=XELPSC(RANN,XYPOS(2,1)) +*---- + IF(XYPOS(2,1) .GE. RANN) THEN + IRP(2,1)=-1 + SPXY(2,1)=SURANN + ELSE IF(XYPOS(2,1) .LE. -RANN) THEN + IRP(2,1)=1 + SPXY(2,1)=DZERO + ELSE + IRP(2,1)=0 + SPXY(2,1)=XELPSC(RANN,XYPOS(2,1)) + ENDIF +*---- +* FOR LAST PLANE IN Y DIRECTION OR +* Y-PLANE ABOVE ANNULAR VOLUME +* GO TO LABEL 111 +*---- + IF(IY .EQ. NMY .OR. IRP(2,1) .EQ. -1) GO TO 111 +*---- +* CYCLE OVER CARTESIAN X-DIRECTIONS STARTING FROM THE END +* AND LOCATE X-MESH POSITION WITH RESPECT TO ANN CENTER +*---- + SPXY(1,2)=DZERO + SIXY(2,1)=DZERO + SIXY(2,2)=DZERO + DO 120 IX=NMX,1,-1 + XYPOS(1,1)=SPAT(IX,1) + XYPOS2(1,1)=XYPOS(1,1)*XYPOS(1,1) +*---- +* FIND IF ANNULUS LEFT, RIGHT OR INTERSECT CURRENT X-PLANE +* AND COMPUTE +* SPXY THE ANNULAR SURFACE LEFT OF CURRENT PLANE +* SIXY(1,1) THE INTERSECTION BETWEEN THE PART OF THE ANNULUS +* THE LEFT OF X-PLANE +* AND THE PART OF THE ANNULUS AT +* THE BOTTOM OF CURRENT Y-PLANE +* SIXY(1,2) THE INTERSECTION BETWEEN THE PART OF THE ANNULUS +* THE LEFT OF X-PLANE +* AND THE PART OF THE ANNULUS AT +* THE TOP OF PREVIOUS Y-PLANE +* IF ANNULUS TO THE LEFT OF CURRENT PLANE (XYPOS(1,1)>= RANN) +* IRPY(1,1)=-1 +* SPXY(1,1)=SURANN +* SIXY(1,1)=SPXY(2,1) +* SIXY(1,2)=SPXY(2,2) +* IF ANNULUS TO THE RIGHT OF CURRENT (XYPOS(1,1)<= -RANN) +* IRPY(1,1)= 1 +* SPXY(1,1)=0.0 +* SIXY(1,1)=0.0 +* SIXY(1,2)=0.0 +* IF ANNULUS INTERSECT CURRENT PLANE ( -RANN < XYPOS(1,1) < RANN) +* IRPY(1,1)= 0 +* SPXY=XELPSC(RANN,XYPOS(1,1)) +* SIXY(1,1)=GEOPSI(1,RANN2,XYPOS,XYPOS2,SPXY) +* SIXY(1,2)=GEOPSI(2,RANN2,XYPOS,XYPOS2,SPXY) +*---- + SPXY(1,1)=DZERO + SIXY(1,1)=DZERO + SIXY(1,2)=DZERO + IF(XYPOS(1,1) .GE. RANN) THEN + IRP(1,1)=-1 + SPXY(1,1)=SURANN + SIXY(1,1)=SPXY(2,1) + SIXY(1,2)=SPXY(2,2) + ELSE IF(XYPOS(1,1) .LE. -RANN) THEN + IRP(1,1)=1 + ELSE + IRP(1,1)=0 + SPXY(1,1)=XELPSC(RANN,XYPOS(1,1)) + IF(IRP(2,1) .EQ. 0) + > SIXY(1,1)=XELPSI(1,RANN2,XYPOS,XYPOS2,SPXY) + IF(IRP(2,2) .EQ. 0) + > SIXY(1,2)=XELPSI(2,RANN2,XYPOS,XYPOS2,SPXY) + ENDIF +*---- +* FOR LAST PLANE IN X DIRECTION OR +* X-PLANE TO THE RIGHT OF ANNULAR VOLUME +* GO TO LABEL 121 +*---- + IF(IX .EQ. NMX .OR. IRP(1,1) .EQ. -1) GO TO 121 +*---- +* GET SURFACE INTERSECTION BETWEEN ANNULUS AND CARTESIAN REGION +* LOCATED BETWEEN X-PLANES (IX-> IX+1) AND Y-PLANES (IX -> IY+1) +* AND STORE IN AREAI(IX,IY) +*---- + AREAI(IX,IY)=SURANN + > -SPXY(1,1)-SPXY(1,2)-SPXY(2,1)-SPXY(2,2) + > +SIXY(1,1)+SIXY(2,1)+SIXY(1,2)+SIXY(2,2) +*---- +* WHEN ANNULUS ALL LOCATED TO THE RIGHT OF CURRENT X-PLANE +* EXIT FROM IX LOOP BY GOING TO LABLE 122 +*--- + IF(IRP(1,1) .EQ. 1) GO TO 122 + 121 CONTINUE +*---- +* RESET IN LOCATION 2 VALUES COMPUTED WITH LOCATION 1 +* WITH ADEQUATE CHANGE OF SIGN FOR SURFACE DIRECTION +* NAMELY SURFACES LOCATED ON THE LEFT OF X-PLANE BECOME SURFACES +* LOCATED ON THE RIGHT OF X-PLANE +*---- + SIXY(2,1)=SPXY(2,1)-SIXY(1,1) + SIXY(2,2)=SPXY(2,2)-SIXY(1,2) + XYPOS(1,2)=XYPOS(1,1) + XYPOS2(1,2)=XYPOS2(1,1) + IRP(1,2)=-IRP(1,1) + SPXY(1,2)=SURANN-SPXY(1,1) + 120 CONTINUE + 122 CONTINUE +*---- +* WHEN ANNULUS ALL LOCATED ABOVE CURRENT Y-PLANE +* EXIT FROM IY LOOP BY GOING TO LABLE 112 +*--- + IF(IRP(2,1) .EQ. 1) GO TO 112 + 111 CONTINUE +*---- +* RESET IN LOCATION 2 VALUES COMPUTED WITH LOCATION 1 +* WITH ADEQUATE CHANGE OF SIGN FOR SURFACE DIRECTION +* NAMELY SURFACES LOCATED ON THE BELOW Y-PLANE BECOME SURFACES +* LOCATED ABOVE Y-PLANE +*---- + XYPOS(2,2)=XYPOS(2,1) + XYPOS2(2,2)=XYPOS2(2,1) + IRP(2,2)=-IRP(2,1) + SPXY(2,2)=SURANN-SPXY(2,1) + 110 CONTINUE + 112 CONTINUE +*---- +* PRINT SURFACE INTERSECTIONS IF REQUIRED +*----- + IF(IPRINT.GE.10) THEN + WRITE(IOUT,6002) 'CART-ANN AREA ' + WRITE(IOUT,6003) ((AREAI(IX,IY),IX=1,NRSPX),IY=1,NRSPY) + WRITE(IOUT,6001) + ENDIF +*---- +* RETURN +*---- + RETURN +*---- +* PRINT FORMAT +*---- + 6000 FORMAT(/5X,'------ OUTPUT FROM XELCRN ------ ') + 6001 FORMAT(5X,' -------------------------------- '/) + 6002 FORMAT(5X,A16) + 6003 FORMAT(1P,5E16.6) + END diff --git a/Dragon/src/XELCTR.f b/Dragon/src/XELCTR.f new file mode 100644 index 0000000..12cd250 --- /dev/null +++ b/Dragon/src/XELCTR.f @@ -0,0 +1,154 @@ +*DECK XELCTR + SUBROUTINE XELCTR(IFOLD,IFTRK,MXSUBO,MXSEGO,CUTOFX,ALBEDO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* EXCELL prismatic tracking. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IFOLD unnormalized tracking file number (at input). +* IFTRK normalized tracking file number (at output). +* MXSUBO undefined. +* MXSEGO undefined. +* CUTOFX cutoff factor. +* ALBEDO geometric albedos on external faces. +* +*----------------------------------------------------------------------- +* + + + IMPLICIT NONE + + INTEGER IFOLD,IFTRK,MXSUBO,MXSEGO + REAL CUTOFX,ALBEDO(6) + + INTEGER NCOMNT,NSCRP,NDIM,ISPEC,NREG,NSOUT,NALBG,NCOR,NANGL,NRS, + 1 ICODE(6),II,JJ,NBTRK,MXSUB,MXSEG,NSUB,LINE,ITRAK,NOLDS,NNEWS, + 2 NCSEG + REAL VOLMIN,ASCRP + DOUBLE PRECISION WEIGHT,RCUT,DASCRP + CHARACTER CTRK*4,COMENT*80 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MATALB,NRSEG,KANGL + REAL, ALLOCATABLE, DIMENSION(:) :: VOLSUR + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: ANGLE,DENSTY + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SEGLEN +*--- +* Read Old Tracking File +*--- + READ (IFOLD) CTRK,NCOMNT,NSCRP,NSCRP + DO II=1,NCOMNT + READ(IFOLD) COMENT + ENDDO + READ (IFOLD) NDIM,ISPEC,NREG,NSOUT,NALBG,NCOR,NANGL,NSCRP,NSCRP + IF(NALBG.LE.0.OR.NALBG.GT.6)THEN + CALL XABORT('XELCTR: NALBG.GT.6.OR.NALBG.LE.0'// + 1 ' ON TRACKING FILE') + ENDIF + NRS=NREG+NSOUT+1 + ALLOCATE(MATALB(NRS),NRSEG(MXSEGO),KANGL(MXSUBO)) + ALLOCATE(VOLSUR(NRS),ANGLE(NDIM*NANGL),DENSTY(NANGL), + 1 SEGLEN(MXSEGO)) + READ (IFOLD) (VOLSUR(II),II=1,NRS) + READ (IFOLD) (MATALB(II),II=1,NRS) + READ (IFOLD) (ICODE(II),II=1,NALBG) + READ (IFOLD) (ALBEDO(II),II=1,NALBG) + READ (IFOLD) ((ANGLE((JJ-1)*NDIM+II),II=1,NDIM),JJ=1,NANGL) + READ (IFOLD) (DENSTY(II),II=1,NANGL) + VOLMIN=VOLSUR(NSOUT+2) + DO II= NSOUT+2,NSOUT+NREG + VOLMIN=MIN(VOLMIN,VOLSUR(II+1)) + ENDDO + RCUT=VOLMIN*CUTOFX + NBTRK= 0 + MXSUB= 0 + MXSEG= 0 + 20 CONTINUE + READ(IFOLD,END=40) NSUB,LINE,WEIGHT,(KANGL(II),II=1,NSUB), + 1 (NRSEG(II),II=1,LINE),(SEGLEN(II),II=1,LINE) + MXSUB=MAX(MXSUB,NSUB) + MXSEG=MAX(MXSEG,LINE) + NBTRK=NBTRK+1 + GOTO 20 + 40 CONTINUE +*--- +* Construct New Tracking File +*--- + REWIND IFOLD + READ (IFOLD) CTRK,NSCRP,NSCRP,NSCRP + WRITE(IFTRK) CTRK,NCOMNT,NBTRK,0 + DO II=1,NCOMNT + READ (IFOLD) COMENT + WRITE(IFTRK) COMENT + ENDDO + READ (IFOLD) (NSCRP,II=1,8) + WRITE(IFTRK) NDIM,ISPEC,NREG,NSOUT,NALBG,NCOR,NANGL,MXSUB,MXSEG + READ (IFOLD) (ASCRP,II=-NSOUT,NREG) + WRITE(IFTRK) (VOLSUR(II),II=1,NRS) + READ (IFOLD) (NSCRP,II=-NSOUT,NREG) + WRITE(IFTRK) (MATALB(II),II=1,NRS) + READ (IFOLD) (NSCRP,II=1,NALBG) + WRITE(IFTRK) (ICODE(II),II=1,NALBG) + READ (IFOLD) (ASCRP,II=1,NALBG) + WRITE(IFTRK) (ALBEDO(II),II=1,NALBG) + READ (IFOLD) ((DASCRP,II=1,NDIM),JJ=1,NANGL) + WRITE(IFTRK) ((ANGLE((JJ-1)*NDIM+II),II=1,NDIM),JJ=1,NANGL) + READ (IFOLD) (DASCRP,II=1,NANGL) + WRITE(IFTRK) (DENSTY(II),II=1,NANGL) + DO ITRAK=1, NBTRK + READ(IFOLD) NSUB,LINE,WEIGHT,(KANGL(II),II=1,NSUB), + 1 (NRSEG(II),II=1,LINE),(SEGLEN(II),II=1,LINE) + IF (RCUT.GT.0.0)THEN + II=0 + 23 CONTINUE + IF (II.EQ.LINE) GO TO 25 + II=II+1 + IF (SEGLEN(II).LT.RCUT) THEN + IF (II.NE.LINE) THEN + DO JJ= II+1, LINE + NRSEG(JJ-1)=NRSEG(JJ) + SEGLEN(JJ-1)=SEGLEN(JJ) + ENDDO + ELSE + LINE=LINE-1 + GOTO 25 + ENDIF + LINE=LINE-1 + II=II-1 + ENDIF + GOTO 23 + 25 CONTINUE + ENDIF + NOLDS=NRSEG(1) + NCSEG=1 + DO II=2,LINE + NNEWS=NRSEG(II) + IF ((NNEWS.LT.0).OR.(NNEWS.NE.NOLDS)) THEN + NOLDS=NNEWS + NCSEG=NCSEG+1 + NRSEG(NCSEG)=NRSEG(II) + SEGLEN(NCSEG)=SEGLEN(II) + ELSEIF (NNEWS.EQ.NOLDS) THEN + SEGLEN(NCSEG)=SEGLEN(NCSEG)+SEGLEN(II) + ENDIF + ENDDO + WRITE(IFTRK) NSUB,NCSEG,WEIGHT,(KANGL(II),II=1,NSUB), + 1 (NRSEG(II),II=1,NCSEG),(SEGLEN(II),II=1,NCSEG) + ENDDO + DEALLOCATE(SEGLEN,DENSTY,ANGLE,VOLSUR) + DEALLOCATE(KANGL,NRSEG,MATALB) +* + RETURN + END diff --git a/Dragon/src/XELDCL.f b/Dragon/src/XELDCL.f new file mode 100644 index 0000000..882ba37 --- /dev/null +++ b/Dragon/src/XELDCL.f @@ -0,0 +1,603 @@ +*DECK XELDCL + SUBROUTINE XELDCL( IPGEOM, GEONAM, NDIM, MAXGRI, LCLSYM, NBLOCK, + > NTYPO, LL1, LL2, IPRT, NTOTCO, MAXRO , + > NGEOME, NTYP, NGIDL, NTIDL, NUNKO, CELLG, + > NSURO, NVOLO, IDLDIM, IDLGEO, KEYTRN, KEYGEO, + > IDLTYP, KEYTYP, MRGCEL, IDLBLK) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Associate all blocks of a problem to their block types and generate +* almost all useful integer values that will describe the problem. +* +*Copyright: +* Copyright (C) 1987 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPGEOM pointer to the geometry (l_geom). +* GEONAM geometry name. +* NDIM number of dimensions. +* MAXGRI number of grid cell in X/Y/Z directions. +* LCLSYM symmetry flags (0: no,-1/+1: syme,,-2/+2: ssym). +* NBLOCK number of blocks. +* NTYPO old number of types. +* LL1 upper diag switch. +* LL2 lower diag switch. +* IPRT intermediate printing level for output. +* +*Parameters: output +* NTOTCO tot number of cylinders in all geometries. +* MAXRO max number of words to stock meshes. +* NGEOME number of geometries. +* NTYP new number of types. +* NGIDL lenght of geometric numbering. +* NTIDL lenght of type numbering. +* NUNKO old number of unknowns. +* CELLG to keep cell geometry names. +* NSURO number of surfaces of each geometry. +* NVOLO number of zones of each geometry. +* IDLDIM position of each geoemtry in cylinders numbering. +* IDLGEO position of each geometry in the +* geometry numbering scheme. +* KEYTRN turn key for each block. +* KEYGEO geometric key for each type. +* IDLTYP position of each type in numbering scheme. +* KEYTYP type key for each block. +* MRGCEL merging key of each block. +* IDLBLK position of each block in numbering scheme. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPGEOM + INTEGER NDIM, NBLOCK, NTYPO, IPRT, NTOTCO, MAXRO, + > NGEOME, NTYP, NGIDL, NTIDL, NUNKO + CHARACTER GEONAM*12 + INTEGER MAXGRI(3),LCLSYM(3),CELLG(3*NBLOCK), + > NSURO(NBLOCK),NVOLO(NBLOCK),IDLDIM(NBLOCK), + > IDLGEO(NBLOCK),KEYTRN(NBLOCK),KEYGEO(NBLOCK), + > IDLTYP(NBLOCK),KEYTYP(NBLOCK),MRGCEL(NBLOCK), + > IDLBLK(NBLOCK) + LOGICAL LL1, LL2 +*---- +* EXTERNAL FUNCTIONS +*---- + CHARACTER*2 AXGTRN +*---- +* LOCAL VARIABLES +*---- + INTEGER IOUT,NSTATE,MAXTUR + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NSTATE=40,MAXTUR=12,NAMSBR='XELDCL') +*---- +* LOCAL PARAMETERS +*---- + CHARACTER GEOC1*12,GEOC2*12,BLANC*8,CPLAN*8,GEOCV*12 + INTEGER MINGRI(3),MEDGRI(3),ISTATE(NSTATE) + LOGICAL LLSYM + INTEGER IKG + INTEGER IBLK, I3, ISUB2, ITYP, JTYP, IX, IY, IZ, + > NMERG1, NMERG2, NMERG3, IOFF, IOF1, IOF2, + > IMERG1, NNCYL, NNSUR, NNVOL, NXC, NXM, IGEO, + > IB1, IB2, IC1, IC2, IT1, IT2, IR, NLINP, + > NTYP2, IOLTYP, NPROB, IDLPRB, IP, MAXREM + INTEGER KMESH,NXYZ,ITC + INTEGER IOT1,IOT2 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ITGEOM,CELLT +*---- +* DATA STATEMENTS +*---- + DATA BLANC / ' ' / +*---- +* SCRATCH STORAGE ALLOCATION +* ITGEOM: turn by cell types +* CELLT : cell type names +*---- + ALLOCATE(ITGEOM(NBLOCK),CELLT(3*NTYPO)) +*---- +* INITIALIZE BLOCK INFORMATION +*---- + DO 10 IBLK= 1, NBLOCK + NSURO(IBLK)= 0 + NVOLO(IBLK)= 0 + IDLGEO(IBLK)= 0 + KEYGEO(IBLK)= 0 + IDLTYP(IBLK)= 0 + KEYTYP(IBLK)= 0 + ITGEOM(IBLK)= 0 + KEYTRN(IBLK)= 0 + IDLBLK(IBLK)= 0 + 10 CONTINUE + LLSYM=.FALSE. + DO 20 I3= 1, 3 + MINGRI(I3)= MAXGRI(I3) + MEDGRI(I3)= 0 + IF( ABS(LCLSYM(I3)) .EQ. 1 )THEN + MINGRI(I3)= (MAXGRI(I3)+1)/2 + LLSYM=.TRUE. + IF( LCLSYM(I3).EQ.-1 )THEN + MEDGRI(I3)= MINGRI(I3)-1 + ENDIF + ELSE IF(ABS(LCLSYM(I3)) .EQ. 2 ) THEN + MINGRI(I3)= MAXGRI(I3)/2 + LLSYM=.TRUE. + IF( LCLSYM(I3).EQ.-2 )THEN + MEDGRI(I3)= MINGRI(I3) + ENDIF + ELSE IF(LCLSYM(I3) .NE. 0) THEN + WRITE(IOUT,'(1H0,A8,4H -->,3(I8,1X))') 'LCLSYM', LCLSYM + CALL XABORT(NAMSBR//': LCLSYM NOT WELL DEFINED' ) + ENDIF + 20 CONTINUE + ISTATE(:NSTATE)=0 + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) + NXYZ=MAX(ISTATE(3),ISTATE(4),ISTATE(5)) + ISUB2= ISTATE(9) + KMESH=ISTATE(6) + MAXRO = 0 + NTOTCO= 0 + IF( ISUB2.GT.0 )THEN + CALL LCMGET(IPGEOM,'CELL',CELLT) + CALL LCMLEN(IPGEOM,'MIX', NMERG1, ITYP) + CALL LCMGET(IPGEOM,'MIX', KEYTYP) + DO 30 IMERG1=1,NMERG1 + IF( KEYTYP(IMERG1).GT.0 )CALL XABORT(NAMSBR//': GENERATING ' + > //'CELLS EXPECTED') + KEYTYP(IMERG1)=-KEYTYP(IMERG1) + IKG=KEYTYP(IMERG1) + WRITE(GEOCV,'(3A4)') + > CELLT(3*IKG-2),CELLT(3*IKG-1),CELLT(3*IKG) + CALL LCMSIX(IPGEOM,GEOCV,1) + ISTATE(:NSTATE)=0 + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) + NXYZ=MAX(NXYZ,ISTATE(3),ISTATE(4),ISTATE(5)) + CALL LCMSIX(IPGEOM,GEOCV,2) + 30 CONTINUE + CALL LCMLEN(IPGEOM,'MERGE', NMERG2, ITYP) + IF( NMERG2.EQ.0 )THEN + DO 100 IMERG1= 1, NMERG1 + MRGCEL(IMERG1)= IMERG1 + 100 CONTINUE + ELSEIF( NMERG2.EQ.NMERG1 )THEN + CALL LCMGET(IPGEOM,'MERGE', MRGCEL) + ELSE + CALL XABORT(NAMSBR//': MERGES ARE INCOMPATIBLE' ) + ENDIF +* + CALL LCMLEN(IPGEOM,'TURN', NMERG3, ITYP) + IF( NMERG3.EQ.0 )THEN + DO 110 IMERG1= 1, NMERG1 + ITGEOM(IMERG1)= 1 + 110 CONTINUE + ELSEIF( NMERG3.EQ.NMERG1 )THEN + CALL LCMGET(IPGEOM,'TURN', ITGEOM) + DO 120 IMERG1= 1, NMERG3 + IF( MOD(ITGEOM(IMERG1),MAXTUR).EQ.0.OR. + > MOD(ITGEOM(IMERG1),MAXTUR).GT.8 ) + > CALL XABORT(NAMSBR//': INVALID TURNS (NO HEX CODES)' ) + 120 CONTINUE + ELSE + CALL XABORT(NAMSBR//': TURNS ARE INCOMPATIBLE' ) + ENDIF + IF(LL1 .OR. LL2) THEN +*---- +* Process diagonal symmetries +*---- + CALL AXGDIA( IPGEOM, IPRT, NBLOCK, NTYPO, NXYZ, KMESH , + > GEONAM, LL1, LL2, MINGRI, CELLT, KEYTYP, + > ITGEOM) + ENDIF + IF( LLSYM )THEN +*---- +* process x-x, y-y and z-z symmetry +* 1) Unfold geometry +* 2) Analyse symmetry +*---- + DO 300 IZ=MINGRI(3),1,-1 + IOF1=(IZ-1)*MINGRI(1)*MINGRI(2) + IOF2=(IZ+MEDGRI(3)-1)*MAXGRI(1)*MAXGRI(2) + DO 310 IY=MINGRI(2),1,-1 + DO 320 IX=MINGRI(1),1,-1 + IOT2=IOF2+(IY+MEDGRI(2)-1)*MAXGRI(1)+IX+MEDGRI(1) + IOT1=IOF1+(IY-1)*MINGRI(1)+IX + IF(IOT2 .NE. IOT1) THEN + IF(KEYTYP(IOT2) .NE. 0)THEN + CALL XABORT(NAMSBR//': PROBLEMS TO UNFOLD') + ELSE + KEYTYP(IOT2)=KEYTYP(IOT1) + KEYTYP(IOT1)= 0 + ITGEOM(IOT2)=ITGEOM(IOT1) + ITGEOM(IOT1)= 0 + ENDIF + ENDIF + 320 CONTINUE + 310 CONTINUE + 300 CONTINUE + CALL AXGSYM( IPGEOM, IPRT, NBLOCK, NTYPO, NXYZ, + > GEONAM, LCLSYM, MINGRI, MAXGRI, CELLT, + > KEYTYP, ITGEOM) + ENDIF +*---- +* FIND ALL DIFFERENT GEOMETRIES +*---- + IF( IPRT.GT.1 )THEN + WRITE(IOUT,'(1H )') + NXC= 1 + WRITE(IOUT,'(25H ===> CELL TYPES ARE: /)') + DO 400 IP= 1, (9+ISUB2)/10 + NXM= MIN( ISUB2, NXC+9 ) + WRITE(IOUT,'(1H ,10(I8.8,4X))') + > (IB1,IB1=NXC,NXM) + WRITE(IOUT,'(1H ,30A4)') + > (CELLT(3*IB1-2),CELLT(3*IB1-1),CELLT(3*IB1),IB1=NXC,NXM) + NXC= NXC + 10 + 400 CONTINUE +* +* PRINTING ASSEMBLY MAP + CPLAN= BLANC + NLINP= 3+(MAXGRI(2)+1)*((9+MAXGRI(1))/10+1) + DO 410 IZ=1,MAXGRI(3) + WRITE(IOUT,'(1H )') + IF(NDIM.EQ.3)THEN + WRITE(CPLAN,'(4H (Z=,I3,1H))') IZ + ENDIF + WRITE(IOUT,'(/32H UNFOLD TYPE CELL MAP FOR PLANE ,A8)') + > CPLAN + NXC= 1 + DO 415 IP = 1, (9 + MAXGRI(1)) / 10 + NXM= MIN( MAXGRI(1), NXC+9 ) + WRITE(IOUT,'(1X,A8,1X,10(A4,I3,A4))') + > CPLAN, (' X= ',IR,' ROT',IR=NXC,NXM) + NXC = NXC + 10 + 415 CONTINUE + WRITE(IOUT,'(1H )') + DO 420 IY=1,MAXGRI(2) + IOFF=((IZ-1)*MAXGRI(2)+(IY-1))*MAXGRI(1) + NXC= 1 + DO 425 IP = 1, (9 + MAXGRI(1)) / 10 + NXM= MIN( MAXGRI(1), NXC+9 ) + WRITE(IOUT,'(1X,A4,I3,2H=>,10(I7,1X,A2,1X))') + > ' Y= ',IY,(KEYTYP(IOFF+IR), + > AXGTRN(ITGEOM(IOFF+IR)),IR=NXC,NXM) + NXC = NXC + 10 + 425 CONTINUE + WRITE(IOUT,'(1H )') + 420 CONTINUE + 410 CONTINUE + ENDIF + NGEOME= 0 + DO 40 IB1= 1, NBLOCK + IC1= KEYTYP(IB1) + IT1= ITGEOM(IB1) + IF(IC1.LE.0.OR.IC1.GT.ISUB2 )THEN + CALL XABORT(NAMSBR//': INVALID TYPE #') + ENDIF + NGEOME= NGEOME + 1 + CELLG(3*NGEOME-2)= CELLT(3*IC1-2) + CELLG(3*NGEOME-1)= CELLT(3*IC1-1) + CELLG(3*NGEOME )= CELLT(3*IC1 ) + KEYTRN(NGEOME)= IT1 + WRITE( GEOC1(1: 4),'(A4)') CELLT(3*IC1-2) + WRITE( GEOC1(5: 8),'(A4)') CELLT(3*IC1-1) + WRITE( GEOC1(9:12),'(A4)') CELLT(3*IC1 ) +* SEARCH FOR SIMILAR GEOMETRIES IN PREVIOUS ONES + IF( IB1.NE.1 )THEN + DO 41 IB2= 1, IB1-1 + IC2= KEYTYP(IB2) + IT2= ITGEOM(IB2) + IF( IT1.NE.IT2 ) GO TO 41 + WRITE( GEOC2(1: 4),'(A4)') CELLT( 3*IC2-2 ) + WRITE( GEOC2(5: 8),'(A4)') CELLT( 3*IC2-1 ) + WRITE( GEOC2(9:12),'(A4)') CELLT( 3*IC2 ) + IF( GEOC1.EQ.GEOC2 )THEN + KEYGEO(IB1)= KEYGEO(IB2) + NGEOME= NGEOME-1 + GO TO 40 + ENDIF + 41 CONTINUE + ENDIF +*---- +* ANALYSE NEW GEOMETRY +*---- + CALL LCMSIX(IPGEOM,GEOC1,1) + CALL XELPRC(IPGEOM,GEOC1,NDIM,NNCYL,NNSUR,NNVOL,MAXREM) + IF( NNVOL.NE.0 )THEN + NSURO(NGEOME)= -NNSUR + NVOLO(NGEOME)= NNVOL + IDLDIM(NGEOME)= NTOTCO + NTOTCO= NTOTCO + NNCYL + 3 + MAXRO= MAXRO + MAXREM + IGEO= NGEOME + ELSE + NGEOME= NGEOME-1 + IGEO= -1 + ENDIF + KEYGEO(IB1)= IGEO + CALL LCMSIX(IPGEOM,' ',2) + 40 CONTINUE + IF( IPRT.GT.1 )THEN + WRITE(IOUT,'(1H )') + NXC= 1 + WRITE(IOUT,'(25H ===> PHYSICAL CELLS ARE: /)') + DO 42 IP= 1, (9+NGEOME)/10 + NXM= MIN( NGEOME, NXC+9 ) + WRITE(IOUT,'(1H ,10(I8.8,4X))') + > (IB1,IB1=NXC,NXM) + WRITE(IOUT,'(1H ,30A4)') (CELLG(3*IB1-2), + > CELLG(3*IB1-1),CELLG(3*IB1),IB1=NXC,NXM) + WRITE(IOUT,'(1H ,10(A7,5X))') + > ('TURN '//AXGTRN(KEYTRN(IB1)),IB1=NXC,NXM) + NXC= NXC + 10 + 42 CONTINUE + ENDIF +*---- +* RESTORE *KEYTYP* AND *KEYGEO* VALUES +*---- + NTYP2= NGEOME + DO 43 IB1= 1, NBLOCK + KEYTYP(IB1)= KEYGEO(IB1) + 43 CONTINUE + DO 44 IC1= 1, NTYP2 + IF( KEYGEO(IC1).NE.-1 ) KEYGEO(IC1)= IC1 + 44 CONTINUE +*---- +* DELETE ALL VIRTUAL CELLS +*---- + NTYP= 0 + DO 45 ITYP= 1, NTYP2 + IGEO= KEYGEO(NTYP+1) + IF( IGEO.EQ.-1 )THEN + DO 46 IBLK= 1, NBLOCK + IOLTYP= KEYTYP(IBLK) + IF( IOLTYP.EQ.NTYP+1 )THEN + KEYTYP(IBLK)= 0 + ELSEIF( IOLTYP.GT.NTYP+1 )THEN + KEYTYP(IBLK)= KEYTYP(IBLK)-1 + ENDIF + 46 CONTINUE + DO 47 JTYP= NTYP+2, NTYP2 + CELLG(3*JTYP-5)= CELLG(3*JTYP-2) + CELLG(3*JTYP-4)= CELLG(3*JTYP-1) + CELLG(3*JTYP-3)= CELLG(3*JTYP ) + KEYTRN(JTYP-1)= KEYTRN(JTYP) + KEYGEO(JTYP-1)= KEYGEO(JTYP) + 47 CONTINUE + ELSE + NTYP= NTYP+1 + ENDIF + 45 CONTINUE + ELSE +*---- +* NO CELL IN THE GEOMETRY +*---- + GEOCV=' ' + READ(GEOCV,'(3A4)') CELLT(1),CELLT(2),CELLT(3) + IF( NTYPO.NE.1 ) + > CALL XABORT(NAMSBR//': INVALID GEOMETRY TYPE '//GEONAM) + NGEOME= 1 + NTYP= NTYPO + READ(GEONAM,'(3A4)') (CELLG(3*NGEOME+ITC),ITC=-2,0) + KEYGEO(1)= 1 + KEYTYP(1)= 1 + MRGCEL(1)= 1 + ITGEOM(1)= 1 + KEYTRN(1)= 1 + IF( LLSYM )THEN +*---- +* process x-x, y-y and z-z symmetry +* 1) Unfold geometry +* 2) Analyse symmetry +*---- + DO 330 IZ=MINGRI(3),1,-1 + IOF1=(IZ-1)*MINGRI(1)*MINGRI(2) + IOF2=(IZ+MEDGRI(3)-1)*MAXGRI(1)*MAXGRI(2) + DO 340 IY=MINGRI(2),1,-1 + DO 350 IX=MINGRI(1),1,-1 + IOT2=IOF2+(IY+MEDGRI(2)-1)*MAXGRI(1)+IX+MEDGRI(1) + IOT1=IOF1+(IY-1)*MINGRI(1)+IX + IF(IOT2 .NE. IOT1) THEN + IF(KEYTYP(IOT2) .NE. 0)THEN + CALL XABORT(NAMSBR//': PROBLEMS TO UNFOLD') + ELSE + KEYTYP(IOT2)=KEYTYP(IOT1) + KEYTYP(IOT1)= 0 + ITGEOM(IOT2)=ITGEOM(IOT1) + ITGEOM(IOT1)= 0 + ENDIF + ENDIF + 350 CONTINUE + 340 CONTINUE + 330 CONTINUE + CALL AXGSYM( IPGEOM, IPRT, NBLOCK, NTYPO, NXYZ, + > GEONAM, LCLSYM, + > MINGRI, MAXGRI, CELLT, + > KEYTYP, ITGEOM) + ENDIF + IF( IPRT.GT.1 )THEN + IB1=1 + WRITE(IOUT,'(A32/)') ' ===> REFERENCE GEOMETRY IS: ' + WRITE(IOUT,'(1X,A8/1X,A12)') '00000001',GEONAM +*---- +* PRINTING ASSEMBLY MAP +*---- + CPLAN= BLANC + NLINP= 3+(MAXGRI(2)+1)*((9+MAXGRI(1))/10+1) + DO 430 IZ=1,MAXGRI(3) + WRITE(IOUT,'(1H )') + IF(NDIM.EQ.3)THEN + WRITE(CPLAN,'(4H (Z=,I3,1H))') IZ + ENDIF + WRITE(IOUT,'(/32H UNFOLD TYPE CELL MAP FOR PLANE ,A8)') + > CPLAN + NXC= 1 + DO 435 IP = 1, (9 + MAXGRI(1)) / 10 + NXM= MIN( MAXGRI(1), NXC+9 ) + WRITE(IOUT,'(1X,A8,1X,10(A4,I3,A4))') + > CPLAN, (' X= ',IR,' ROT',IR=NXC,NXM) + NXC = NXC + 10 + 435 CONTINUE + WRITE(IOUT,'(1H )') + DO 440 IY=1,MAXGRI(2) + IOFF=((IZ-1)*MAXGRI(2)+(IY-1))*MAXGRI(1) + NXC= 1 + DO 445 IP = 1, (9 + MAXGRI(1)) / 10 + NXM= MIN( MAXGRI(1), NXC+9 ) + WRITE(IOUT,'(1X,A4,I3,2H=>,10(I7,1X,A2,1X))') + > ' Y= ',IY,(KEYTYP(IOFF+IR), + > AXGTRN(ITGEOM(IOFF+IR)),IR=NXC,NXM) + NXC = NXC + 10 + 445 CONTINUE + WRITE(IOUT,'(1H )') + 440 CONTINUE + 430 CONTINUE + ENDIF + NGEOME= 0 + DO 50 IB1= 1, NBLOCK + IC1= KEYTYP(IB1) + IT1= ITGEOM(IB1) + IF(IC1 .LE. 0) THEN + CALL XABORT(NAMSBR//': INVALID TYPE #') + ENDIF + NGEOME= NGEOME + 1 + READ(GEONAM,'(3A4)') (CELLG(3*NGEOME+ITC),ITC=-2,0) + KEYTRN(NGEOME)= IT1 + IF( IB1.NE.1 )THEN + DO 51 IB2= 1, IB1-1 + IC2= KEYTYP(IB2) + IT2= ITGEOM(IB2) + IF( IT1.NE.IT2 ) GO TO 51 + KEYGEO(IB1)= KEYGEO(IB2) + NGEOME= NGEOME-1 + GO TO 50 + 51 CONTINUE + ENDIF +* ANALYSE GEOMETRY + CALL XELPRC(IPGEOM,GEONAM,NDIM,NNCYL,NNSUR,NNVOL,MAXREM) + IF( NNVOL.NE.0 )THEN + NSURO(NGEOME)= -NNSUR + NVOLO(NGEOME)= NNVOL + IDLDIM(NGEOME)= NTOTCO + NTOTCO= NTOTCO + NNCYL + 3 + MAXRO= MAXRO + MAXREM + IGEO= NGEOME + ELSE + NGEOME= NGEOME-1 + IGEO= -1 + ENDIF + KEYGEO(IB1)= IGEO + 50 CONTINUE + IF( IPRT.GT.1 )THEN + WRITE(IOUT,'(1H )') + NXC= 1 + WRITE(IOUT,'(25H ===> PHYSICAL CELLS ARE: /)') + DO 52 IP= 1, (9+NGEOME)/10 + NXM= MIN( NGEOME, NXC+9 ) + WRITE(IOUT,'(1H ,10(I8.8,4X))') + > (IB1,IB1=NXC,NXM) + WRITE(IOUT,'(1H ,30A4)') + > ((CELLG(3*IB1+ITC),ITC=-2,0),IB1=NXC,NXM) + WRITE(IOUT,'(1H ,10(A7,5X))') + > ('TURN '//AXGTRN(KEYTRN(IB1)),IB1=NXC,NXM) + NXC= NXC + 10 + 52 CONTINUE + ENDIF +*---- +* RESTORE *KEYTYP* AND *KEYGEO* VALUES +*---- + NTYP= NGEOME + DO 53 IB1= 1, NBLOCK + KEYTYP(IB1)= KEYGEO(IB1) + 53 CONTINUE + DO 54 IC1= 1, NTYP + KEYGEO(IC1)= IC1 + 54 CONTINUE + ENDIF + IF( IPRT.GT.1 )THEN + WRITE(IOUT,'(/35H ONE TRACKING FILE TO BE ATTACHED /'// + > '1H ,12X,14H UNDER NAME : ,A12 )') GEONAM + ENDIF +*---- +* DEFINITION OF INDEX VALUES, TO LOOK AT THE DOMAIN +*---- + NGIDL= 0 + DO 210 IGEO= 1, NGEOME + IF( NSURO(IGEO).GE.0 ) + > CALL XABORT(NAMSBR//': GEOMETRY NOT FOUND') + IF( NVOLO(IGEO).LE.0 ) + > CALL XABORT(NAMSBR//': GEOMETRY NOT FOUND') + IDLGEO(IGEO)= NGIDL - NSURO(IGEO) + 1 + NGIDL= NVOLO(IGEO) + IDLGEO(IGEO) + 210 CONTINUE + NTIDL = 0 + NPROB = 0 + DO 220 ITYP= 1, NTYP + IGEO= KEYGEO(ITYP) + IF( IGEO.LE.0 ) + > CALL XABORT(NAMSBR//': BLOC NOT FOUND') + IDLTYP(ITYP)= NTIDL - NSURO(IGEO) + 1 + IDLPRB= NPROB + (1-NSURO(IGEO))*(2-NSURO(IGEO))/2 + NTIDL = NVOLO(IGEO) + IDLTYP(ITYP) + NPROB = NVOLO(IGEO)*(NVOLO(IGEO)-2*NSURO(IGEO)+3)/2+IDLPRB + 220 CONTINUE + NUNKO= 0 + DO 230 IBLK= 1, NBLOCK + ITYP= KEYTYP(IBLK) + IF( ITYP.LT.0 ) + > CALL XABORT(NAMSBR//': CELL NOT FOUND') + IF( ITYP.EQ.0 )GO TO 230 + IGEO= KEYGEO(ITYP) + IDLBLK(IBLK)= NUNKO - NSURO(IGEO) + 1 + NUNKO= NVOLO(IGEO) + IDLBLK(IBLK) + 230 CONTINUE + IF( IPRT.GT.10 )THEN +*---- +* PRINTING INDEX VECTORS +*---- + WRITE(IOUT,'(1H )') + WRITE(IOUT,'(1H0,A6,4H -->,I8)') 'MAXRO', MAXRO + WRITE(IOUT,'(1H0,A6,4H -->,I8)') 'NTOTCO', NTOTCO + WRITE(IOUT,'(1H0,A6,4H -->,3(I8,1X))') 'LCLSYM', LCLSYM + WRITE(IOUT,'(1H0,A8,4H ,5(A8,2X))') ' GEOM #', + > ' NSURO', ' NVOLO', ' IDLGEO', ' IDLDIM', ' KEYTRN' + DO 250 IGEO= 1, NGEOME + WRITE(IOUT,'(1H ,I8,4H -->,5(I8,2X))') IGEO, + > NSURO(IGEO),NVOLO(IGEO),IDLGEO(IGEO),IDLDIM(IGEO),KEYTRN(IGEO) + 250 CONTINUE + WRITE(IOUT,'(1H )') + WRITE(IOUT,'(1H0,A8,4H ,2(A8,2X))') ' BLOC #', + > ' KEYGEO', ' IDLTYP' + DO 260 ITYP= 1, NTYP + WRITE(IOUT,'(1H ,I8,4H -->,2(I8,2X))') ITYP, + > KEYGEO(ITYP), IDLTYP(ITYP) + 260 CONTINUE + WRITE(IOUT,'(1H )') + WRITE(IOUT,'(1H0,A8,4H ,3(A8,2X))') ' CELL #', + > ' KEYTYP', ' ITGEOM', ' IDLBLK' + DO 270 IBLK= 1, NBLOCK + WRITE(IOUT,'(1H ,I8,4H -->,3(I8,2X))') IBLK, + > KEYTYP(IBLK), ITGEOM(IBLK), IDLBLK(IBLK) + 270 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(CELLT,ITGEOM) +*---- +* RETURN +*---- + RETURN + END diff --git a/Dragon/src/XELDRV.f b/Dragon/src/XELDRV.f new file mode 100644 index 0000000..118c1d6 --- /dev/null +++ b/Dragon/src/XELDRV.f @@ -0,0 +1,620 @@ +*DECK XELDRV + SUBROUTINE XELDRV(IPTRK ,IPGEOM,IPRT ,MAXPTS,NANIS ,NORE , + > LMERG ,KSPEC ,KTOPT ,TITREC,CUTOFX,CFTRAK, + > IFTRAK,IDISP ,ISYMM ,LCACT ,NMU ,INSB , + > NBATCH,LBIHET,LPRISM,IZ,DELU,FRTM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read a Dragon tracking file to compute pij, normalize a tracking +* file to Dragon format and produce a new tracking file in Dragon +* format. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPTRK pointer to the excell tracking (L_TRACK). +* IPGEOM pointer to the geometry (L_GEOM). +* IPRT tracking print level. +* MAXPTS number of zones according to user. +* NANIS anisotropy of the solution. +* NORE track normalization flag (<=0: yes; =1: no). +* LMERG type of volume normalization. +* KSPEC kind of pij integration (=0: isotr.; =1: spec.). +* KTOPT tracking type option. +* TITREC title for this case. +* CUTOFX mfp cutoff for specular integration. +* CFTRAK name of the sequential binary tracking file. +* IFTRAK unit of the sequential binary tracking file. +* IDISP mode of the sequential binary tracking file. +* LCACT type of polar integration for the method of characteristics. +* NMU number of polar angles for the method of characteristics. +* ISYMM symmetry factor. +* INSB type of vectorization for the calculation of CP matrices. +* NBATCH number of tracks assigned to each OpenMP core. +* LBIHET activation flag for the double heterogeneity option. +* LPRISM flag for 3D prismatic geometry. +* IZ projection axis for 3D prismatic geometry. +* DELU user defined track spacing for 3D prismatic tracking. +* FRTM minimum volume fraction of the grain in the representative +* volume for She-Liu-Shi model. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER TITREC*72,CFTRAK*12 + TYPE(C_PTR) IPTRK,IPGEOM + INTEGER IPRT,MAXPTS,NANIS,NORE,LMERG,KSPEC,KTOPT,IFTRAK, + > IDISP,ISYMM,LCACT,NMU,INSB,NBATCH,IZ + REAL CUTOFX,DELU,FRTM + LOGICAL LPRISM,LBIHET +*---- +* LOCAL VARIABLES +*---- + INTEGER NSTATE + PARAMETER (NSTATE=40) + INTEGER NREG,NUNKNO,IUTYPE,ISTATE(NSTATE),IFTEMP,IFILE, + > ITYPE,ITOPT,ITROP,NCOMNT,NTRK,IREC,IC,IR,JR,IUNK, + > NSOUT,IDISPO,NDIM,NV,NS,NALBGO,NCOR,NANGL,MXSEG, + > NPRISM,NDIMO,NSO,NVO,NUNOLD,KDROPN,KDRCLS,NUNKNX, + > IOUT,ITGEO,IUSED(6),ICMAX,ICODE(6),ICOLD(6), + > NANGLO,MXSUB,MXSUBO,MXSEGO,ILONG,IFMT,I + LOGICAL LEAKSW, LELCHK, SWNOGE, SWCONS, EMPTY, LCM + REAL ALBEDO(6),ALBOLD(6),EXTKOP(NSTATE), + > ZERO,ONE,DENS,PCORN + DOUBLE PRECISION DASCRP + CHARACTER GEONAM*12,CORIEN(0:3,6)*4,CUSED(0:1)*6,TEXT12*12, + > COMENT*80,CTRK*4 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MATCOD,KEYFLX,MATOLD,MATALB, + > KEYMRG,MATMRG + REAL, ALLOCATABLE, DIMENSION(:) :: VOLUME,VOLOLD,VOLSUR,VOLMRG +* + PARAMETER ( IUTYPE=2, IOUT=6, ZERO=0.0, ONE=1.0 ) +* + DATA (( CORIEN(JR,IR),IR=1,6),JR=0,3) + > / ' 1 ',' 2 ',' 3 ',' 4 ',' 5 ',' 6 ', + > '****',' R+ ','****','****',' Z- ',' Z+ ', + > 'HBC ','****','****','****',' Z- ',' Z+ ', + > ' X- ',' X+ ',' Y- ',' Y+ ',' Z- ',' Z+ '/ + DATA ( CUSED(JR),JR=0,1 ) / 'UNUSED',' USED' / +*---- +* SCRATCH STORAGE ALLOCATION +* MATCOD material numbers for zones in the supercell. +* VOLUME volumes of zones in the supercell. +* KEYFLX zone key for the unknown vectors (fluxes...). +*---- + ALLOCATE(MATCOD(MAXPTS),KEYFLX(MAXPTS)) + ALLOCATE(VOLUME(MAXPTS)) +* + NPRISM=0 + IF( IPRT.GT.0 ) WRITE(IOUT,'(1X,A72//)') TITREC + SWNOGE= .NOT.C_ASSOCIATED(IPGEOM) + IF(SWNOGE) THEN + GEONAM=' ' + IF(INSB.EQ.2) CALL XABORT('XELDRV: GEOMETRY REQUESTED') + ELSE + CALL LCMINF(IPGEOM,GEONAM,TEXT12,EMPTY,ILONG,LCM) + ENDIF + NTRK = 0 +* + IF( IPRT.GT.0 )THEN + WRITE(IOUT,'(1H )') + IF( SWNOGE )THEN + WRITE(IOUT,'(27H ECHO = >>> NO GEOMETRY )') + ELSE + WRITE(IOUT,'(27H ECHO = >>> GEOMETRY NAME: ,A8)') GEONAM + ENDIF + WRITE(IOUT,'(27H ECHO = >>> TRACKING FILE: ,A8)') CFTRAK + IF( IDISP.EQ.-1 )THEN + WRITE(IOUT,'(27H ECHO = >>> DISP: ,A4)') 'MODT' + ELSEIF( IDISP.EQ. 0 )THEN + WRITE(IOUT,'(27H ECHO = >>> DISP: ,A4)') 'OLDT' + ELSEIF( IDISP.EQ.+1 )THEN + WRITE(IOUT,'(27H ECHO = >>> DISP: ,A4)') 'NEWT' + ENDIF + IF( NORE.EQ.-1 )THEN + WRITE(IOUT,'(36H ECHO = >>> NORMALIZED-BY ANGLE )') + ELSEIF( NORE.EQ. 0 )THEN + WRITE(IOUT,'(36H ECHO = >>> NORMALIZED-GLOBAL )') + ELSEIF( NORE.EQ.+1 )THEN + WRITE(IOUT,'(36H ECHO = >>> NOT NORMALIZED )') + ENDIF + ENDIF +*---- +* 1) REWIND TRACKING FILE -------------------------------------------- +*---- + IF((IFTRAK.EQ.0).AND.(INSB.NE.2)) THEN + CALL XABORT('XELDRV: NO SEQUENTIAL BINARY TRACKING FILE YET D' + > //'EFINED') + ELSE IF((IFTRAK.NE.0).AND.(INSB.EQ.2)) THEN + CALL XABORT('XELDRV: NO SEQUENTIAL BINARY TRACKING FILE EXPEC' + > //'TED WITH OPTION XCLL') + ENDIF + IF(INSB.NE.2) REWIND IFTRAK +*---- +* 1.2) GET HEADER INFORMATIONS FROM *OLDT*/*MODT* FILES +*---- + NUNOLD= 0 + IFMT= 0 + IF( IDISP.LE.0 )THEN + IREC= 1 + READ(IFTRAK,ERR=997) CTRK,NCOMNT,NTRK,IFMT + DO 10 IC= 1, NCOMNT + IREC= IREC+1 + READ (IFTRAK,ERR=997) COMENT + 10 CONTINUE + IREC= IREC+1 + READ (IFTRAK,ERR=997) NDIMO,ITOPT,NVO,NSO,NALBGO, + > NCOR,NANGL,MXSUB,MXSEG + IF( NALBGO.LE.0.OR.NALBGO.GT.6 )THEN + CALL XABORT('XELDRV: NALBG.GT.6.OR.NALBG.LE.0'// + > ' ON TRACKING FILE') + ENDIF + NUNOLD= NVO+NSO+1 + ALLOCATE(VOLOLD(NUNOLD),MATOLD(NUNOLD)) + IREC= IREC+1 + READ (IFTRAK,ERR=997) (VOLOLD(IR),IR=1,NUNOLD) + IREC= IREC+1 + READ (IFTRAK,ERR=997) (MATOLD(IR),IR=1,NUNOLD) + IREC= IREC+1 + READ (IFTRAK,ERR=997) ( ICOLD(IR),IR=1,NALBGO) + IREC= IREC+1 + READ (IFTRAK,ERR=997) (ALBOLD(IR),IR=1,NALBGO) + IREC= IREC+1 + READ (IFTRAK,ERR=997) (DASCRP,IR=0,NDIMO*NANGL-1) + IREC= IREC+1 + READ (IFTRAK,ERR=997) (DASCRP,IR=0,NANGL-1) + REWIND IFTRAK + ENDIF +*---- +* 1.3) OPEN TEMP TRACKING FILE FOR *MODT*/*NEWT* FILES +*---- + ITROP = 0 + IF((IDISP.NE.0).AND.(INSB.NE.2)) THEN + IFILE= KDROPN('DUMMYSQ',0,IUTYPE,0) + IF( IFILE.LE.0 ) GO TO 998 + IF( IFILE.EQ.IFTRAK ) CALL XABORT('XELDRV: BAD TRACKING UNIT') + IFTEMP = IFILE + REWIND IFTEMP + IF( IDISP.LT.0 )THEN +* +* FOR *MODT* FILES, MAIN TRACKING IS COPIED ON TEMPORARY + CALL XELCOP( IFTRAK, IFTEMP ) + ENDIF + ENDIF +*---- +* 2) GET GEOMETRIC INFORMATIONS AND TRACK IF NECESSARY---------------- +*---- + IF( SWNOGE )THEN +*---- +* 2.1) NO GEOMETRY, GET INFORMATIONS FROM *OLDT*/*MODT* FILE +*---- + IF(IDISP.GT.0) CALL XABORT('XELDRV: A RHS BINARY TRACKING FIL' + > //'E OR A RHS GEOMETRY MUST BE DEFINED.') + NDIM= NDIMO + NSOUT= NSO + NREG= NVO + NS= NSO + NV= NVO + NUNKNX= NUNOLD + IF( NREG.GT.MAXPTS ) THEN + WRITE(IOUT,'(28H ****** XELDRV ERROR ******,/ + > 28H NUMBER OF REGION COMPUTED =,I10/ + > 28H MAXIMUM NUMBER OF REGION =,I10)') NREG,MAXPTS + CALL XABORT('XELDRV: MAXR TOO SMALL') + ENDIF + ALLOCATE(VOLSUR(NUNKNX),MATALB(NUNKNX),KEYMRG(NUNKNX)) + IUNK= 0 + DO 20 IR= -NS, NV + VOLSUR(IUNK+1)= VOLOLD(IUNK+1) + MATALB(IUNK+1)= MATOLD(IUNK+1) + KEYMRG(IUNK+1)= IR + IUNK= IUNK+1 + 20 CONTINUE + ALLOCATE(VOLMRG(NUNKNX),MATMRG(NUNKNX)) + DO 21 IUNK=1,NUNKNX + VOLMRG(IUNK)= VOLOLD(IUNK) + MATMRG(IUNK)= MATOLD(IUNK) + 21 CONTINUE + DEALLOCATE(MATOLD,VOLOLD) + DO 25 IR= 1, NALBGO + ICODE(IR)= ICOLD(IR) + 25 CONTINUE + ITGEO= 0 + ELSE +*---- +* 2.2) THERE IS A GEOMETRY, GO TO EXCELL MODULES TO ANALYZE IT +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) + ITYPE= ISTATE(1) + IF( ITYPE.EQ.3.OR.ITYPE.EQ.6 )THEN + ITGEO= 1 + ELSEIF( ITYPE.EQ. 8 .OR. ITYPE.EQ. 9 .OR. + > ITYPE.EQ.24 .OR. ITYPE.EQ.25 )THEN + ITGEO= 2 + ELSEIF( ITYPE.EQ. 5 .OR. ITYPE.EQ. 7 .OR. ITYPE.EQ.20 .OR. + > ITYPE.EQ.21 .OR. ITYPE.EQ.22 .OR. ITYPE.EQ.23 )THEN + ITGEO= 3 + ELSE + ITGEO= 0 + ENDIF + IDISPO= IDISP + NANGLO= NANGL + MXSUBO= MXSUB + MXSEGO= MXSEG + IF((INSB.EQ.2).AND.(ITGEO.NE.3)) THEN + CALL XABORT('XELDRV: XCELL TRACKING NOT AVAILABLE.') + ENDIF + IF( ISTATE(13).GE.1 )THEN + IF( ITYPE.EQ.3.OR.ITYPE.EQ.20.OR.ITYPE.EQ.24 )THEN +*---- +* 2.2.1.1) EXCELL DRIVER FOR CLUSTER SINGLE CELLS +*---- + CALL XCWTRK(IPTRK ,IPGEOM,GEONAM,IDISP ,IFTEMP, + > IPRT ,NDIM ,ITOPT ,NV ,NS ,NANGL , + > ISYMM ,DENS ,PCORN ,MXSUB ,MXSEG ,ICODE , + > TITREC) + ITROP=3 + ELSE + CALL XABORT('XELDRV: ONLY ONE-CELL TUBE/CARCEL/HEXCEL'// + > ' CLUSTERS ARE AVAILABLE') + ENDIF + ELSEIF( ITGEO.EQ.2 )THEN +*---- +* 2.2.1.2) EXCELL DRIVER FOR HEXAGONAL 2D/3D ASSEMBLIES +*---- + CALL XHXTRK(IPTRK ,IPGEOM,GEONAM,IDISP,IFTEMP, + > IPRT ,NDIM ,ITOPT ,NV ,NS ,NANGL , + > ISYMM ,DENS ,PCORN ,MXSEG,ICODE ,TITREC) + MXSUB=1 + ITROP=2 + ELSEIF( ITGEO.EQ.3 )THEN +*---- +* 2.2.1.3) EXCELL DRIVER FOR CARTESIAN 2D/3D ASSEMBLIES +*---- + CALL XELTRK(IPTRK ,IPGEOM,GEONAM,IDISP ,IFTEMP, + > IPRT ,NDIM ,ITOPT ,NV ,NS ,NANGL , + > ISYMM ,DENS ,PCORN ,MXSUB ,MXSEG ,ICODE , + > TITREC,INSB ,IZ ,LPRISM,NPRISM) + ITROP=1 +*---- +* For case with intrinsic symmetry +* tracking performed on unfolded geometry assuming angular and spatial +* symmetry +* Normalization must be on global volume since only this option +* makes sense. +*---- + IF((ISYMM .GT. 1).AND.(LMERG .EQ. 0)) LMERG=1 + ELSE + CALL XABORT('XELDRV: INVALID TYPE OF GEOMETRY') + ENDIF + IF((INSB.EQ.2).AND.(NDIM.NE.3)) THEN + CALL XABORT('XELDRV: XCELL OPTION LIMITED TO 3D GEOMETRY.') + ENDIF +*---- +* 2.2.1.4) RECOVER KEYMRG, MATALB AND VOLSUR +*---- + NUNKNX= NV+NS+1 + CALL LCMSIX(IPTRK,'EXCELL ',1) + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + IF(NUNKNX.NE.ISTATE(6)) CALL XABORT('XELDRV: INVALID NUNKNX.') + ALLOCATE(VOLSUR(NUNKNX),MATALB(NUNKNX),KEYMRG(NUNKNX)) + CALL LCMGET(IPTRK,'KEYMRG ',KEYMRG) + CALL LCMGET(IPTRK,'MATALB ',MATALB) + CALL LCMGET(IPTRK,'VOLSUR ',VOLSUR) + CALL LCMSIX(IPTRK,'EXCELL ',2) +*---- +* 2.2.2) MERGE SURFACES AND ZONES FOR THIS GEOMETRY +*---- + ALLOCATE(VOLMRG(NUNKNX),MATMRG(NUNKNX)) + CALL XELCMP( NS, NV, VOLSUR, MATALB, KEYMRG, + > NSOUT, NREG, VOLMRG, MATMRG, ITGEO, ICODE) + IF( NREG.GT.MAXPTS ) THEN + WRITE(IOUT,'(28H ****** XELDRV ERROR ******,/ + > 28H NUMBER OF REGION COMPUTED =,I10/ + > 28H MAXIMUM NUMBER OF REGION =,I10)') NREG,MAXPTS + CALL XABORT('XELDRV: MAXR TOO SMALL') + ENDIF + IF((IPRT.GE.1).AND.(INSB.NE.2)) THEN + WRITE(IOUT,6002) NANGL,ISYMM,CUTOFX,DENS,PCORN + ENDIF + IF(INSB.EQ.2) THEN + IF(IDISP.NE.99) CALL XABORT('XELDRV: INCONSISTENT IDISP') + CALL LCMGET(IPTRK,'ALBEDO',ALBOLD) + ENDIF +* + IF( IDISP.NE.IDISPO )THEN + CALL XABORT('XELDRV: *HALT* OPTION REQUESTED '// + > ' NO FURTHER CALCULATION IS POSSIBLE') + ELSEIF( IDISP.GT.0 )THEN + IF(INSB.NE.2) REWIND IFTEMP + ELSE + IF( NANGL.NE.NANGLO )THEN + CALL XABORT('XELDRV: NOT POSSIBLE TO CHANGE '// + > ' *NANGL* PARAMETER OF TRACKING FILE') + ENDIF + IF( MXSEG.NE.MXSEGO )THEN + CALL XABORT('XELDRV: NOT POSSIBLE TO CHANGE '// + > ' *MXSEG* PARAMETER OF TRACKING FILE') + ENDIF + IF( MXSUB.NE.MXSUBO )THEN + CALL XABORT('XELDRV: NOT POSSIBLE TO CHANGE '// + > ' *MXSUB* PARAMETER OF TRACKING FILE') + ENDIF + ENDIF +*---- +* 2.2.3) CHECK CONSISTENCY BETWEEN *MODT* FILE AND GEOMETRY BEFORE +* MERGE +*---- + SWCONS=.FALSE. + IF( IDISP.LT.0 )THEN + SWCONS= LELCHK(NSO ,NVO ,VOLOLD,MATOLD,ICOLD, + > NS ,NV ,VOLSUR,MATALB,ICODE, 0) + IF( IPRT.GT.0 )THEN + WRITE(IOUT,'(1H )') + IF( SWCONS )THEN + WRITE(IOUT,'(70H ECHO = >>> CONSISTENCY BETWEEN '// + > 'TRACKING FILE AND UNMERGED GEOMETRY /)') + ELSE + WRITE(IOUT,'(70H ECHO = >>> INCONSISTENCY BETWEEN '// + > 'TRACKING FILE AND UNMERGED GEOMETRY /)') + ENDIF + ENDIF + ENDIF +*---- +* 2.2.4) CHECK CONSISTENCY BETWEEN *OLDT*/*MODT* FILE AND GEOMETRY +* AFTER MERGE +*---- + IF( IDISP.EQ.0.OR.(IDISP.LT.0.AND.(.NOT.SWCONS)) )THEN + IF( NDIMO.NE.NDIM )THEN + CALL XABORT('XELDRV: DIMENSION (2-D/3-D) INCONSISTENCY') + ENDIF + SWCONS= LELCHK(NSO ,NVO ,VOLOLD,MATOLD,ICOLD, + > NSOUT,NREG,VOLMRG,MATMRG,ICODE,IPRT) + IF( SWCONS )THEN + IF( IPRT.GT.0 )THEN + WRITE(IOUT,'(1H )') + WRITE(IOUT,'(70H ECHO = >>> CONSISTENCY BETWEEN '// + > 'TRACKING FILE AND MERGED GEOMETRY /)') + ENDIF + ELSE + WRITE(IOUT,'(70H ECHO = >>> INCONSISTENCY BETWEEN '// + > 'TRACKING FILE AND MERGED GEOMETRY /)') + CALL XABORT('XELDRV: INCONSISTENCY OF MERGED GEOMETRY '// + > 'WITH OLD TRACKING FILE ' ) + ENDIF +* +* CONSISTENCY WITH MERGED GEOMETRY +* COPY MERGED VOLUMES INTO VOLSUR ARRAY SINCE MERGE WAS DONE + NS= NSOUT + NV= NREG + IUNK= 0 + DO 50 IR= -NS, NV + VOLSUR(IUNK+1)= VOLOLD(IUNK+1) + MATALB(IUNK+1)= MATOLD(IUNK+1) + KEYMRG(IUNK+1)= IR + IUNK= IUNK+1 + 50 CONTINUE + ENDIF + ENDIF +*---- +* 3) NORMALIZE TEMPORARY FILE FOR *MODT*/*NEWT* FILES ---------------- +*---- + IF((IDISP.NE.0).AND.(INSB.NE.2))THEN +*---- +* 3.1) WARNING IF THE FILE HAS *NTRK*.NE.0 +*---- + IF( NTRK.NE.0 )THEN + WRITE(IOUT,'(1H )') + WRITE(IOUT,'(60H ECHO = >>> WARNING: TRACKING FILE'// + > ' MAY ALREADY BE NORMALIZED /)') + ENDIF + IF (LPRISM) THEN + CALL XELCTR(IFTEMP,IFTRAK,MXSUB,MXSEG,CUTOFX,ALBOLD) + ELSE + CALL XELNTR( NDIM, IFTEMP, IFTRAK, NORE, LMERG, + > IPRT, NS, NV, VOLSUR, MATALB, KEYMRG, + > NSOUT, NREG, VOLMRG, MATMRG, CUTOFX, + > ITGEO, ICODE, ALBOLD, NANGL, MXSUB, + > MXSEG) + ENDIF + IFILE= IFTEMP + IFTEMP= KDRCLS(IFTEMP,2) + IF( IFTEMP.LT.0 ) GO TO 999 + ENDIF +*---- +* 4) CHARGE GEOMETRIC ALBEDOS & GET PHYSICAL ALBEDOS IF NECESSARY ---- +*---- + ICMAX= 0 + DO 60 IR= 1, 6 + ALBEDO(IR)= ONE + IUSED(IR)= 0 + ICMAX= MAX(ICMAX,ICODE(IR)) + IF( ICODE(IR).LT.0 ) ALBEDO(IR)= ALBOLD(-ICODE(IR)) + 60 CONTINUE + IF( ICMAX.GT.0 )THEN + CALL XABORT('XELDRV: PHYSICAL ALBEDOS NOT IMPLEMENTED') + ENDIF + IF( KTOPT .EQ. -1) THEN + KTOPT= ITOPT + ENDIF + IF(KSPEC .EQ. -1 ) THEN + KSPEC= KTOPT + ELSE + KSPEC=MIN(KSPEC,KTOPT) + ENDIF +*---- +* 5) STOCK INFORMATION (OUTPUT TO DRAGON DRIVER) --------------------- +*---- + DO 70 IR= 1, NREG + KEYFLX(IR)= IR + VOLUME(IR)= VOLMRG(IR+NSOUT+1) + MATCOD(IR)= MATMRG(IR+NSOUT+1) + 70 CONTINUE +* +* COMPUTE LEAKAGE SWITCH + LEAKSW=.TRUE. + DO 80 IR= -NSOUT, -1 + IUSED(-MATMRG(IR+NSOUT+1))= 1 + LEAKSW= LEAKSW .AND. ALBEDO(-MATMRG(IR+NSOUT+1)).EQ.ONE + 80 CONTINUE + LEAKSW=.NOT.LEAKSW + DEALLOCATE(MATMRG,VOLMRG) + IF( (IDISP.LE.0).AND.(.NOT.SWNOGE) )THEN + DEALLOCATE(MATOLD,VOLOLD) + ENDIF +* + IF( IPRT.GT.0 )THEN + IF( IPRT.GT.1 )THEN + WRITE(IOUT,'(8H SIDE ,2X,6(7X,A4))') + > (CORIEN(ITGEO,IR),IR=1,6) + WRITE(IOUT,'(8H GEOM #,2X,6(7X,I4.0))') + > (MAX(0,-ICODE(IR)),IR=1,6) + WRITE(IOUT,'(8H PHYS #,2X,6(7X,I4.0))') + > (MAX(0,ICODE(IR)),IR=1,6) + WRITE(IOUT,'(8H ALBEDO,2X,1P,6E11.4)') + > (ALBEDO(IR),IR=1,6) + WRITE(IOUT,'(8H ,2X,6(5X,A6))') + > (CUSED(IUSED(IR)),IR=1,6) + WRITE(IOUT,'(1H )') + ENDIF + WRITE(IOUT,'(1H )') + IF( KSPEC.EQ.0 )THEN + WRITE(IOUT,'(40H ECHO = >>> ISOTROPIC CP CALCULATION )') + ELSEIF( KSPEC.EQ.1 )THEN + WRITE(IOUT,'(40H ECHO = >>> SPECULAR CP CALCULATION )') + IF( CUTOFX.EQ.ZERO )THEN + WRITE(IOUT,'(27H ECHO = >>> NO CUT-OFF )') + ELSE + WRITE(IOUT,'(27H ECHO = >>> MFP. CUT-OFF: ,1P,E11.4 )') + > CUTOFX + ENDIF + ENDIF + WRITE(IOUT,'(28H ECHO = >>> NB. OF REGIONS: ,I5)') NREG + ENDIF +*---- +* 5.2) RELEASE SPACE ACCORDING TO INVERSE ORDER OF ALLOCATIONS +*---- + DEALLOCATE(KEYMRG,MATALB,VOLSUR) +* +* SAVE GENERAL TRACKING INFORMATION. + IF(NANIS.EQ.1) THEN + NUNKNO= NREG + ELSE + IF( NDIM.EQ.1 )THEN + NUNKNO= NANIS*NREG + ELSE IF( NDIM.EQ.2 )THEN + NUNKNO= ((NANIS*(NANIS+1))/2)*NREG + ELSE + NUNKNO= NANIS*NANIS*NREG + ENDIF + ENDIF + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + ISTATE(1)=NREG + ISTATE(2)=NUNKNO + IF(LEAKSW) THEN + ISTATE(3)=0 + ELSE + ISTATE(3)=1 + ENDIF + IR=0 + DO 100 I=1,NREG + IR=MAX(IR,MATCOD(I)) + 100 CONTINUE + ISTATE(4)=IR + ISTATE(5)=NSOUT + ISTATE(6)=NANIS + ISTATE(7)=ITROP + ISTATE(8)=NORE + ISTATE(9)=KTOPT + ISTATE(10)=KSPEC + ISTATE(13)=LCACT + ISTATE(14)=NMU + ISTATE(16)=NDIM + ISTATE(22)=INSB + ISTATE(27)=NBATCH + ISTATE(39)=NPRISM + IF(LBIHET) ISTATE(40)=1 + CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMPUT(IPTRK,'MATCOD',NREG,1,MATCOD) + CALL LCMPUT(IPTRK,'VOLUME',NREG,2,VOLUME) + CALL LCMPUT(IPTRK,'KEYFLX',NREG,1,KEYFLX) + CALL LCMPUT(IPTRK,'ICODE',6,1,ICODE) + CALL LCMPUT(IPTRK,'ALBEDO',6,2,ALBEDO) + CALL LCMGET(IPTRK,'EXCELTRACKOP',EXTKOP) + EXTKOP(39)=FRTM + EXTKOP(40)=DELU + CALL LCMPUT(IPTRK,'EXCELTRACKOP',NSTATE,2,EXTKOP) + IF(IPRT.GE.1) THEN + WRITE(IOUT,6000) IPRT,(ISTATE(IR),IR=1,12),ISTATE(22), + > ISTATE(16),ISTATE(27),ISTATE(39),ISTATE(40) + WRITE(IOUT,6001)(EXTKOP(IR),IR=1,3) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(VOLUME) + DEALLOCATE(KEYFLX,MATCOD) + RETURN +* + 6000 FORMAT(' EXCELT PRINT LEVEL =',I8/ + > ' TRACK STATE-VECTOR'/' ------------------'/ + > ' NREG =',I8,' (NUMBER OF REGIONS)'/ + > ' NUNKNO =',I8,' (NUMBER OF UNKNOWNS IN SYSTEM)'/ + > ' ILEAK =',I8,' (LEAKAGE FLAG:0=PRESENT/1=ABSENT)'/ + > ' MAXMIX =',I8,' (NUMBER OF MIXTURES)'/ + > ' NSOUT =',I8,' (NUMBER OF OUTER SURFACES)'/ + > ' NANIS =',I8,' (FLUX ANISOTROPY ORDER)'/ + > ' ITROP =',I8,' (GEOMETRY TYPE)'/ + > ' NORE =',I8,' (TRACK NORMALIZATION OPTION)'/ + > ' KTOPT =',I8,' (TYPE OF TRACKING:0=TISO/1=TSPC)'/ + > ' KSPEC =',I8,' (TYPE OF BOUNDARY CONDITION)'/ + > ' NANGL =',I8,' (USER-SUPPLIED NUMBER OF TRACKING ANGLES)'/ + > ' ISYMM =',I8,' (USER-SUPPLIED TRACKING SYMMETRY FACTOR)'/ + > ' INSB =',I8,' (TYPE OF VECTORIZATION:0=ONEG/1=ALLG/2=XCLL)'/ + > ' NDIM =',I8,' (NUMBER OF GEOMETRIC DIMENSIONS)'/ + > ' NBATCH =',I8,' (NUMBER OF TRACKS IN EACH OPENMP CORE)'/ + > ' NPRISM =',I8,' (NUMBER OF PLANS IN 3D PRISMATIC GEOMETRIES)'/ + > ' IBIHET =',I8,' (0/1=DOUBLE HETEROGENEITY IS NOT/IS ACTIVE)'/ + > ' -----------------'/) + 6001 FORMAT( + > ' EXCELL TRACK OPTIONS '/ + > ' CUTOFX =',F20.8,' (CUTOFF FOR TRACK LENGTH)'/ + > ' DENS =',F20.8,' (TRACK DENSITY)'/ + > ' PCORN =',F20.8,' (CORNER DUPLICATION DISTANCE)'/ + > ' -----------------'/) + 6002 FORMAT( + > ' RECOMPUTED PARAMETERS '/ + > ' NANGL =',I10 ,' (NUMBER OF TRACKING ANGLES)'/ + > ' ISYMM =',I10 ,' (TRACKING SYMMETRY FACTOR)'/ + > ' CUTOFX =',F10.5,' (CUTOFF FOR TRACK LENGTH)'/ + > ' DENS =',F10.5,' (TRACK DENSITY)'/ + > ' PCORN =',F10.5,' (CORNER DUPLICATION DISTANCE)'/ + > ' -----------------'/) +* + 997 WRITE(IOUT,'(31H ERROR= RECORD DESTROYED... )') + WRITE(IOUT,'(31H ERROR= UNABLE TO READ RECORD ,I10)') IREC + WRITE(IOUT,'(31H ERROR= ON FILE FT,I2.2)') IFILE + CALL XABORT('XELDRV: READ TRACKING FILE FAILED' ) + 998 WRITE(IOUT,'(31H ECHO = UNABLE TO OPEN FILE FT,I4)') IFILE + CALL XABORT('XELDRV: OPEN FAILED') + 999 WRITE(IOUT,'(31H ECHO = UNABLE TO CLOSE FILE FT,I4)') IFILE + CALL XABORT('XELDRV: CLOSE FAILED') +* + END diff --git a/Dragon/src/XELEDC.f b/Dragon/src/XELEDC.f new file mode 100644 index 0000000..cb30ac6 --- /dev/null +++ b/Dragon/src/XELEDC.f @@ -0,0 +1,172 @@ +*DECK XELEDC + SUBROUTINE XELEDC( NDIM, MAXGRI, NGEOME, NTOTCO, NTYPES, + > NBLOCK, NUNKO, + > NSURO, NVOLO, MINDO, MAXDO, + > ICORDO, IDLDIM, KEYGEO, + > KEYTYP, IDLBLK, KEYINT, + > NTOTCL, MAXR, NSUR, NVOL, KEYCYL ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Associate all blocks of a problem to only one geometry and generate +* the 4 useful integer values that will describe the problem +* in its exact geometric description. +* +*Copyright: +* Copyright (C) 1990 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* NDIM number of dimensions. +* MAXGRI number of grid cell in x/y/z directions. +* NGEOME number of geometries. +* NTOTCO tot number of cylinders in all geometries. +* NTYPES number of types. +* NBLOCK number of blocks. +* NUNKO number of unknowns. +* NSURO number of surfaces of each geometry. +* NVOLO number of zones of each geometry. +* MINDO min index in the remesh array. +* MAXDO min index in the remesh array. +* ICORDO coordinate for remesh array. +* IDLDIM position of each geoemtry in cylinders numbering. +* KEYGEO geometric key for each type. +* KEYTYP type key for each block. +* IDLBLK position of each block in numbering scheme. +* KEYINT numbering of cell interfaces. +* +*Parameters: input +* NTOTCL tot number of cylinders in exact geometry. +* MAXR lenght to stock real abscissae. +* NSUR number of surfaces of exact geometry (negative). +* NVOL number of zones of exact geometry. +* KEYCYL index of cylinders by block. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +* + INTEGER NDIM, NGEOME, NTOTCO, NTYPES, NBLOCK, NUNKO, + > NTOTCL, MAXR, NSUR, NVOL + INTEGER MAXGRI(3), NSURO(NTYPES), NVOLO(NTYPES), + > MINDO(NTOTCO), MAXDO(NTOTCO), ICORDO(NTOTCO), + > IDLDIM(NTYPES), KEYGEO(NTYPES), + > KEYTYP(NBLOCK), IDLBLK(NBLOCK), KEYCYL(NBLOCK), + > KEYINT( NUNKO) +* + INTEGER ICUR(3), IBLK, N, ICX, ITYP, IGEO, IDLD, MDMIN, + > NP1, NP2, IP1, IP2, IP3, NC, NSUX, NVOX, IVX + INTEGER NUMBLK, I, K +* + NUMBLK(I,K)= I + IDLBLK(K) +* + DO 5 IBLK= 1, NBLOCK + KEYCYL(IBLK)= 0 + 5 CONTINUE +* +* DETERMINE: NTOTCL & MAXR +*.1) RECONSTRUCT CARTESIAN MESH + MAXR= 0 + NTOTCL= 3 + ICUR(1)= 1 + ICUR(2)= 1 + ICUR(3)= 1 + DO 30 N= 1, 3 +* +* SCANNING CELLS ON THE AXIS #N + DO 20 ICX= 1, MAXGRI(N) + ICUR(N)= ICX + IF( NDIM.EQ.2 )THEN + IBLK= MAXGRI(1) * (ICUR(2) - 1) + ICUR(1) + ELSE + IBLK= MAXGRI(1)*(MAXGRI(2)*ICUR(3)+ICUR(2)- + > MAXGRI(2))+ICUR(1)-MAXGRI(1) + ENDIF + ITYP= KEYTYP(IBLK) + IF( ITYP.EQ.0 ) GO TO 20 + IGEO= KEYGEO(ITYP) + IDLD= IDLDIM(IGEO) + MAXR= MAXR + (MAXDO(IDLD+N)-MINDO(IDLD+N)) + 20 CONTINUE + ICUR(N)= 1 + MAXR= MAXR+1 + 30 CONTINUE +* +*.2) RECONSTRUCT INFORMATIONS FOR CYLINDRICAL MESH + IF( NDIM.EQ.2 )THEN + MDMIN= 3 + ELSE + MDMIN= 1 + ENDIF + DO 130 N= MDMIN, 3 + ICUR(N)= 1 + NP1= MOD(N ,3) + 1 + NP2= MOD(N+1,3) + 1 + DO 120 IP2= 1, MAXGRI(NP2) + DO 110 IP1= 1, MAXGRI(NP1) + ICUR(NP1)= IP1 + ICUR(NP2)= IP2 + IF( NDIM.EQ.2 )THEN + IBLK= MAXGRI(1) * (ICUR(2) - 1) + ICUR(1) + ELSE + IBLK= MAXGRI(1)*(MAXGRI(2)*ICUR(3)+ICUR(2)- + > MAXGRI(2))+ICUR(1)-MAXGRI(1) + ENDIF + ITYP= KEYTYP(IBLK) + IF( ITYP.EQ.0 ) GO TO 110 + IGEO= KEYGEO(ITYP) + IDLD= IDLDIM(IGEO) + IF( IGEO.NE.NGEOME )THEN + NC= IDLDIM(IGEO+1)-IDLD-3 + ELSE + NC= NTOTCO-IDLD-3 + ENDIF + IF( NC.EQ.1 )THEN + IF( ICORDO(IDLD+4).EQ.N )THEN + NTOTCL= NTOTCL+1 + MAXR= MAXR + 3 + (MAXDO(IDLD+4)-MINDO(IDLD+4)) + DO 105 IP3= 1, MAXGRI(N) + ICUR(N)= IP3 + IF( NDIM.EQ.2 )THEN + IBLK= MAXGRI(1) * (ICUR(2) - 1) + ICUR(1) + ELSE + IBLK= MAXGRI(1)*(MAXGRI(2)*ICUR(3)+ICUR(2)- + > MAXGRI(2))+ICUR(1)-MAXGRI(1) + ENDIF + KEYCYL(IBLK)= NTOTCL + 105 CONTINUE + ICUR(N)= 1 + ENDIF + ENDIF + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE +* +* DETERMINE: NSUR & NVOL + NSUR= 0 + NVOL= 0 + DO 230 IBLK= 1,NBLOCK + ITYP= KEYTYP(IBLK) + IF( ITYP.EQ.0 ) THEN + CALL XABORT( '*** XELEDC: EXACT VOID CELL NOT ALLOWED') + ENDIF + IGEO= KEYGEO(ITYP) + NSUX= NSURO(IGEO) + NVOX= NVOLO(IGEO) + DO 220 IVX= NSUX, NVOX + IF( IVX.LT.0 )THEN + IF( KEYINT(NUMBLK(IVX,IBLK)).EQ.0 ) NSUR= NSUR-1 + ELSEIF( IVX.GT.0 )THEN + NVOL= NVOL + 1 + ENDIF + 220 CONTINUE + 230 CONTINUE +* + RETURN + END diff --git a/Dragon/src/XELEQN.f b/Dragon/src/XELEQN.f new file mode 100644 index 0000000..be67375 --- /dev/null +++ b/Dragon/src/XELEQN.f @@ -0,0 +1,262 @@ +*DECK XELEQN + SUBROUTINE XELEQN( NDIM, NANGLE, ANGEQN ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Copy generated angles according to the EQN standard. +* +*Copyright: +* Copyright (C) 1989 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* NDIM number of dimensions (2 or 3). +* NANGLE number of angles. +* +*Parameters: output +* ANGEQN basis for angles in 2D or 3D. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +* + INTEGER NDIM, NANGLE +* + REAL SN2 ( 1), SN4 ( 2), SN6 ( 4), SN8 ( 6), SN10( 8), + > SN12(11), SN14(14), SN16(17), SNT (63), + > ANGEQN( NDIM, NDIM), THETA, DTHETA + INTEGER MU2 ( 1), MU4 ( 3), MU6 ( 6), MU8 (10), MU10(15), + > MU12(21), MU14(28), MU16(36), MUT(120), + > ET2 ( 1), ET4 ( 3), ET6 ( 6), ET8 (10), ET10(15), + > ET12(21), ET14(28), ET16(36), ETT(120), + > XH2 ( 1), XH4 ( 3), XH6 ( 6), XH8 (10), XH10(15), + > XH12(21), XH14(28), XH16(36), XHT(120), + > INSN( 9), JNMU( 9) + EQUIVALENCE (SNT( 1), SN2), (SNT( 2), SN4), (SNT( 4), SN6), + > (SNT( 8), SN8), (SNT(14),SN10), (SNT(22),SN12), + > (SNT(33),SN14), (SNT(47),SN16) + EQUIVALENCE (MUT( 1), MU2), (MUT( 2), MU4), (MUT( 5), MU6), + > (MUT(11), MU8), (MUT(21),MU10), (MUT(36),MU12), + > (MUT(57),MU14), (MUT(85),MU16) + EQUIVALENCE (ETT( 1), ET2), (ETT( 2), ET4), (ETT( 5), ET6), + > (ETT(11), ET8), (ETT(21),ET10), (ETT(36),ET12), + > (ETT(57),ET14), (ETT(85),ET16) + EQUIVALENCE (XHT( 1), XH2), (XHT( 2), XH4), (XHT( 5), XH6), + > (XHT(11), XH8), (XHT(21),XH10), (XHT(36),XH12), + > (XHT(57),XH14), (XHT(85),XH16) + INTEGER NANG, NO2LIM, INDEL, NO2, ICUR, IPOS, IEND + REAL XPOS, YPOS, ZPOS, X, Y, Z, SUPX, SUPY, SUPZ, + > OOSUPX, OOSUPY, OOSUPZ, XOSUPX, YOSUPY, ZOSUPZ + REAL PI + PARAMETER ( PI = 3.1415926535 ) + SAVE +* + DATA NANG, NO2LIM / -1, 8 / + DATA INSN/ 0, 1, 3, 7, 13, 21, 32, 46, 63/ + DATA JNMU/ 0, 1, 4, 10, 20, 35, 56, 84,120/ +* + DATA SN2 / .577350269/ + DATA SN4 / .350021174, .868890300/ + DATA SN6 / .2561429 , .9320846 , + > .2663443 , .6815646 / + DATA SN8 / .1971380 , .9603506 , + > .2133981 , .5512958 , .8065570 , + > .5773503 / + DATA SN10/ .1631408 , .9730212 , + > .1755273 , .6961286 , + > .4567576 , .8721024 , + > .4897749 , .7212773 / + DATA SN12/ .1370611 , .9810344 , + > .1497456 , .3911744 , .9080522 , + > .6040252 , .7827706 , + > .4213515 , .8030727 , + > .4249785 , .6400755 / + DATA SN14/ .1196230 , .9855865 , + > .1301510 , .3399238 , .9314035 , + > .5326134 , .8362916 , + > .7010923 , + > .3700559 , .8521252 , + > .3736108 , .5691823 , .7324250 , + > .577350269/ + DATA SN16/ .1050159 , .9889102 , + > .1152880 , .3016701 , .9464163 , + > .4743525 , .8727534 , + > .6327389 , .7657351 , + > .3284315 , .8855877 , + > .3332906 , .5107319 , .7925089 , + > .6666774 , + > .5215431 , .6752671 / +* + DATA MU2 / 1/ + DATA MU4 / 1, 1, 2/ + DATA MU6 / 1, 3, 1, 4, 4, 2/ + DATA MU8 / 1, 3, 3, 1, 4, 6, 4, 5, 5, 2/ + DATA MU10/ 1, 3, 3, 3, 1, 5, 7, 7, 5, 4, + > 8, 4, 6, 6, 2/ + DATA MU12/ 1, 3, 3, 3, 3, 1, 4, 8, 10, 8, + > 4, 6, 11, 11, 6, 7, 9, 7, 5, 5, + > 2/ + DATA MU14/ 1, 3, 3, 3, 3, 3, 1, 4, 9, 11, + > 11, 9, 4, 6, 12, 14, 12, 6, 8, 13, + > 13, 8, 7, 10, 7, 5, 5, 2/ + DATA MU16/ 1, 3, 3, 3, 3, 3, 3, 1, 4, 10, + > 12, 12, 12, 10, 4, 6, 13, 16, 16, 13, + > 6, 8, 15, 17, 15, 8, 9, 14, 14, 9, + > 7, 11, 7, 5, 5, 2/ +* + DATA ET2 / 1/ + DATA ET4 / 1, 2, 1/ + DATA ET6 / 1, 4, 2, 3, 4, 1/ + DATA ET8 / 1, 4, 5, 2, 3, 6, 5, 3, 4, 1/ + DATA ET10/ 1, 5, 4, 6, 2, 3, 7, 8, 6, 3, + > 7, 4, 3, 5, 1/ + DATA ET12/ 1, 4, 6, 7, 5, 2, 3, 8, 11, 9, + > 5, 3, 10, 11, 7, 3, 8, 6, 3, 4, + > 1/ + DATA ET14/ 1, 4, 6, 8, 7, 5, 2, 3, 9, 12, + > 13, 10, 5, 3, 11, 14, 13, 7, 3, 11, + > 12, 8, 3, 9, 6, 3, 4, 1/ + DATA ET16/ 1, 4, 6, 8, 9, 7, 5, 2, 3, 10, + > 13, 15, 14, 11, 5, 3, 12, 16, 17, 14, + > 7, 3, 12, 16, 15, 9, 3, 12, 13, 8, + > 3, 10, 6, 3, 4, 1/ +* + DATA XH2 / 1/ + DATA XH4 / 2, 1, 1/ + DATA XH6 / 2, 4, 1, 4, 3, 1/ + DATA XH8 / 2, 5, 4, 1, 5, 6, 3, 4, 3, 1/ + DATA XH10/ 2, 6, 4, 5, 1, 6, 8, 7, 3, 4, + > 7, 3, 5, 3, 1/ + DATA XH12/ 2, 5, 7, 6, 4, 1, 5, 9, 11, 8, + > 3, 7, 11, 10, 3, 6, 8, 3, 4, 3, + > 1/ + DATA XH14/ 2, 5, 7, 8, 6, 4, 1, 5, 10, 13, + > 12, 9, 3, 7, 13, 14, 11, 3, 8, 12, + > 11, 3, 6, 9, 3, 4, 3, 1/ + DATA XH16/ 2, 5, 7, 9, 8, 6, 4, 1, 5, 11, + > 14, 15, 13, 10, 3, 7, 14, 17, 16, 12, + > 3, 9, 15, 16, 12, 3, 8, 13, 12, 3, + > 6, 10, 3, 4, 3, 1/ +* + IF( NDIM.EQ.3 )THEN + IF( NANGLE.NE.NANG )THEN + NANG = NANGLE + INDEL = 0 + NO2 = NANGLE/2 + IF( NO2.EQ.0 )RETURN + IF( NO2.LT.1 .OR. NO2.GT.NO2LIM ) + > CALL XABORT('XELEQN: TOO MANY ANGLES ') + IPOS = INSN( NO2 ) + ICUR = JNMU( NO2 ) + IEND = JNMU( NO2 + 1) + ENDIF + INDEL = INDEL + 1 + IF ( MOD(INDEL, 3).EQ.1 )THEN + IF ( MOD(INDEL, 4).EQ.1 )THEN + ICUR = ICUR + 1 + IF( ICUR.GT.IEND ) + > CALL XABORT('XELEQN: NO MORE ANGLES ') + XPOS = SNT( MUT(ICUR) + IPOS ) + YPOS = SNT( ETT(ICUR) + IPOS ) + ZPOS = SNT( XHT(ICUR) + IPOS ) + X = XPOS + Y = YPOS + Z = ZPOS + SUPX = SQRT( 1.0 - X * X ) + SUPY = SQRT( 1.0 - Y * Y ) + SUPZ = SQRT( 1.0 - Z * Z ) + OOSUPX= 1.0 / SUPX + OOSUPY= 1.0 / SUPY + OOSUPZ= 1.0 / SUPZ + ELSEIF( MOD(INDEL, 4).EQ.2 )THEN + X = -XPOS + Y = YPOS + ELSEIF( MOD(INDEL, 4).EQ.3 )THEN + X = XPOS + Y = -YPOS + ELSE + X = -XPOS + Y = -YPOS + ENDIF + XOSUPX= X / SUPX + YOSUPY= Y / SUPY + ZOSUPZ= Z / SUPZ +* +* SOLID ANGLE DIRECTION + ANGEQN( 1, 1 )= X + ANGEQN( 2, 1 )= Y + ANGEQN( 3, 1 )= Z +* +* DIRECTIONS PERPENDICULAR TO THIS SOLID ANGLE + ANGEQN( 1, 2 )= -Y * OOSUPZ + ANGEQN( 2, 2 )= X * OOSUPZ + ANGEQN( 3, 2 )= 0.0 +* + ANGEQN( 1, 3 )= X * ZOSUPZ + ANGEQN( 2, 3 )= Y * ZOSUPZ + ANGEQN( 3, 3 )= - SUPZ + ELSEIF( MOD(INDEL, 3).EQ.2 )THEN +* +* SOLID ANGLE DIRECTION + ANGEQN( 1, 1 )= X + ANGEQN( 2, 1 )= Y + ANGEQN( 3, 1 )= Z +* +* DIRECTIONS PERPENDICULAR TO THIS SOLID ANGLE + ANGEQN( 1, 2 )= -Z * OOSUPY + ANGEQN( 2, 2 )= 0.0 + ANGEQN( 3, 2 )= X * OOSUPY +* + ANGEQN( 1, 3 )= X * YOSUPY + ANGEQN( 2, 3 )= - SUPY + ANGEQN( 3, 3 )= Z * YOSUPY + ELSE +* +* SOLID ANGLE DIRECTION + ANGEQN( 1, 1 )= X + ANGEQN( 2, 1 )= Y + ANGEQN( 3, 1 )= Z +* +* DIRECTIONS PERPENDICULAR TO THIS SOLID ANGLE + ANGEQN( 1, 2 )= 0.0 + ANGEQN( 2, 2 )= -Z * OOSUPX + ANGEQN( 3, 2 )= Y * OOSUPX +* + ANGEQN( 1, 3 )= - SUPX + ANGEQN( 2, 3 )= Y * XOSUPX + ANGEQN( 3, 3 )= Z * XOSUPX + ENDIF + ELSEIF( NDIM.EQ.2 )THEN + IF( NANGLE.NE.NANG )THEN + NANG = NANGLE + IF( NANG.EQ.0 )RETURN + DTHETA = PI / NANG + IF( NANG.GT.0 )THEN + THETA = -0.5 * DTHETA + ELSE + THETA = 0.5 * DTHETA + ENDIF + INDEL = 0 + ENDIF + INDEL = INDEL + 1 + IF( INDEL.GT.NANG ) CALL XABORT( 'XELEQN: NO MORE ANGLES ' ) + THETA = THETA + DTHETA +* +* SOLID ANGLE DIRECTION + ANGEQN( 1, 1 )= COS(THETA) + ANGEQN( 2, 1 )= SIN(THETA) +* +* DIRECTIONS PERPENDICULAR TO THIS SOLID ANGLE + ANGEQN( 1, 2 )= -SIN(THETA) + ANGEQN( 2, 2 )= COS(THETA) + ELSE + CALL XABORT( 'XELEQN: *** FALSE NDIM VALUE') + ENDIF + RETURN + END diff --git a/Dragon/src/XELETR.f b/Dragon/src/XELETR.f new file mode 100644 index 0000000..cf57de0 --- /dev/null +++ b/Dragon/src/XELETR.f @@ -0,0 +1,458 @@ +*DECK XELETR + SUBROUTINE XELETR( IPRT, NDIM, MAXGRI, NGEOME, NTOTCO, NTYPES, + > NTIDL, NBLOCK, NSUR, NVOL, NTOTCL, NUNKO, + > NSURO, NVOLO, MINDO, MAXDO, ICORDO, IDLDIM, + > IDLGEO, KEYGEO, IDLTYP, KEYTYP, IDLBLK, KEYCYL, + > RMESHO, IDLREM, INDEXO, VOLSO, MATGEO, KEYINT, + > MATTYP, REMESH, MINDIM, MAXDIM, ICORD, VOLSUR, + > KEYMRG, INDEX, INCELL, MATALB, NSURC, NVOLC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Prepare tracking by producing the required numbering and recalculate +* mesh for an exact geometry treatment. +* +*Copyright: +* Copyright (C) 1990 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPRT intermediate printing level for output. +* NDIM number of dimensions (2 or 3). +* MAXGRI number of blocks in X/Y/Z directions. +* NGEOME number of geometries. +* NTOTCO tot number of cylinders in all geometries. +* NTYPES number of cell types. +* NTIDL lenght of type numbering. +* NBLOCK number of blocks. +* NSUR number of surfaces. +* NVOL number of zones. +* NTOTCL tot number of cylinders in exact geometry. +* NUNKO old number of unknowns. +* NSURO number of surfaces of each geometry. +* NVOLO number of zones of each geometry. +* MINDO min index values for all axes (rect/cyl). +* MAXDO max index values for all axes (rect/cyl). +* ICORDO principal axes direction (X/Y/Z) for meshes. +* IDLDIM position of each geometry in cylinder numbering. +* IDLGEO position of each geometry in the +* geometry numbering scheme. +* KEYGEO geometric key for each type. +* IDLTYP position of each type in numbering scheme. +* KEYTYP type key for each block. +* IDLBLK position of each block in numbering scheme. +* KEYCYL index of cylinders by block. +* RMESHO real mesh values (rect/cyl). +* IDLREM position of mesh values per geometry. +* INDEXO index for search in 'rmesho'. +* VOLSO volumes and surfaces for each geometry. +* MATGEO material numbers corresponding to geometries. +* KEYINT interface key (giving the connected surface). +* MATTYP material numbers for zones of every type. +* +*Parameters: output +* REMESH real mesh values (rect/cyl). +* MINDIM min index values for all axes (rect/cyl). +* MAXDIM max index values for all axes (rect/cyl). +* ICORD principal axes direction (X/Y/Z) for meshes. +* VOLSUR volume-surface vector of exact geometry. +* KEYMRG merging vector of exact geometry. +* INDEX numbering of surfaces and zones. +* INCELL block numbering. +* MATALB material types. +* NSURC number of compressed surfaces. +* NVOLC number of compressed zones. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +* + INTEGER IPRT, NDIM, NGEOME, NTOTCO, NTYPES, + > NTIDL, NBLOCK, NSUR, NVOL, NTOTCL, NUNKO, + > NSURC, NVOLC + INTEGER MAXGRI(3), + > MAXDO(NTOTCO), MINDO(NTOTCO), ICORDO(NTOTCO), + > NSURO(NGEOME), NVOLO(NGEOME), IDLDIM(NGEOME), + > IDLGEO(NGEOME), IDLREM(NGEOME), KEYGEO(NTYPES), + > IDLTYP(NTYPES), + > KEYTYP(NBLOCK), IDLBLK(NBLOCK), KEYCYL(NBLOCK), + > INDEXO(4,*), MATGEO(*), + > KEYINT(NUNKO), MATTYP(NTIDL), + > MINDIM(NTOTCL), MAXDIM(NTOTCL), ICORD(NTOTCL), + > INDEX(4,*), KEYMRG(*), MATALB(*), INCELL(*) + REAL RMESHO(*), REMESH(*), VOLSO(*), VOLSUR(*) +* + INTEGER ICUR(4) + INTEGER NUNK, IDLGE2, IG2, I4, N, ICX, IREM, I, J, K, + > IBLK, ITYP, IGEO, IDLD, IDLR, MINABS, MAXABS, + > J1, NTOTCX, MDMIN, NP1, NP2, IP1, IP2, IP3, + > IOLD, ISU2, IVO2, ICREM, MINP1, MINP2, MINC, + > ICYL, IDLTYX, IDLGEX, NO, NC, IMYG, IVSN, + > IVS, IKREM + REAL RSTART, RMINUS, XP1, XP2 + CHARACTER TEMESH(4)*8 + INTEGER IOUT + PARAMETER ( IOUT=6 ) + INTEGER NUMBLK, KL + DATA TEMESH / 'X', 'Y', 'Z', 'C' / +* + NUMBLK(I,K)= I + IDLBLK(K) +* +* INITIALIZE: NO INTERFACE & PUT INDEXES TO 0. + NUNK = NVOL + 1 - NSUR + IDLGE2= 1 - NSUR + DO 5 IG2= 1, NUNK + VOLSUR(IG2)= 0.0 + KEYMRG(IG2)= 0 + MATALB(IG2)= 0 + INCELL(IG2)= 0 + DO 4 I4= 1,4 + INDEX(I4,IG2)= 0 + 4 CONTINUE + 5 CONTINUE +* + IF( IPRT.GE.1 )THEN + WRITE(IOUT,'(1H )') + WRITE(IOUT,'(/24H ====> GLOBAL MESHING )') + ENDIF +* +* RECONSTRUCT CARTESIAN MESH + J= 0 + ICUR(1)= 1 + ICUR(2)= 1 + ICUR(3)= 1 + IDLD=0 + DO 30 N= 1, 3 + RSTART= 0.0 + ICORD(N)= N + MINDIM(N)= J+1 +* +* SCANNING CELLS ON THE AXIS #N + DO 20 ICX= 1, MAXGRI(N) + ICUR(N)= ICX + IF( NDIM.EQ.2 )THEN + IBLK= MAXGRI(1) * (ICUR(2) - 1) + ICUR(1) + ELSE + IBLK= MAXGRI(1)*(MAXGRI(2)*ICUR(3)+ICUR(2)- + > MAXGRI(2))+ICUR(1)-MAXGRI(1) + ENDIF + ITYP= KEYTYP(IBLK) + IGEO= KEYGEO(ITYP) + IDLD= IDLDIM(IGEO) + IDLR= IDLREM(IGEO) + MINABS= MINDO(IDLD+N) + MAXABS= MAXDO(IDLD+N) + RMINUS= RSTART - RMESHO(IDLR+MINABS) + DO 10 IREM= MINABS, MAXABS-1 + J= J+1 + REMESH(J)= RMESHO(IDLR+IREM)+RMINUS + 10 CONTINUE + ICUR(N)= 1 + RSTART= RMESHO(IDLR+MAXABS)+RMINUS + 20 CONTINUE + J= J+1 + REMESH(J)= RSTART + MAXDIM(N)= J + IF( IPRT.GE.1.AND.N.LE.NDIM )THEN + WRITE(IOUT,'(8X,A1,14H-COORDINATES: /(9X,5(1X,F13.6)))') + > TEMESH(N), (REMESH(J1),J1=MINDIM(N),MAXDIM(N)) + ENDIF + 30 CONTINUE + NTOTCX= 3 +* +* RECONSTRUCT CYLINDRICAL MESH + IF( NDIM.EQ.2 )THEN + MDMIN= 3 + ELSE + MDMIN= 1 + ENDIF + DO 130 N= MDMIN, 3 + ICUR(N)= 1 + NP1= MOD(N ,3) + 1 + NP2= MOD(N+1,3) + 1 +* +* (XP1,XP2) ARE COORDINATES AT BEGINNING OF BLOCK (IP1,IP2) + XP2= 0.0 + DO 120 IP2= 1, MAXGRI(NP2) + XP1= 0.0 + DO 110 IP1= 1, MAXGRI(NP1) + ICUR(NP1)= IP1 + ICUR(NP2)= IP2 + IF( NDIM.EQ.2 )THEN + IBLK= MAXGRI(1) * (ICUR(2) - 1) + ICUR(1) + ELSE + IBLK= MAXGRI(1)*(MAXGRI(2)*ICUR(3)+ICUR(2)- + > MAXGRI(2))+ICUR(1)-MAXGRI(1) + ENDIF + ITYP= KEYTYP(IBLK) + IF( ITYP.EQ.0 ) GO TO 105 + IGEO= KEYGEO(ITYP) + IDLD= IDLDIM(IGEO) + IDLR= IDLREM(IGEO) + IF( IGEO.NE.NGEOME )THEN + NC= IDLDIM(IGEO+1)-IDLD-3 + ELSE + NC= NTOTCO-IDLD-3 + ENDIF + IF( NC.EQ.1 )THEN + IF( ICORDO(IDLD+4).EQ.N )THEN + NTOTCX= NTOTCX+1 + IF( NTOTCX.GT.NTOTCL ) + > CALL XABORT( '** XELETR: TOO MANY CYLINDERS' ) + MINP1 = MINDO(IDLD+NP1) + MINP2 = MINDO(IDLD+NP2) + MINC = MINDO(IDLD+4) + ICORD(NTOTCX)= ICORDO(IDLD+4) +* +* RECENTER CYLINDERS + REMESH(J+1)= RMESHO(IDLR+MINC-2)-RMESHO(IDLR+MINP1)+XP1 + REMESH(J+2)= RMESHO(IDLR+MINC-1)-RMESHO(IDLR+MINP2)+XP2 + J= J+2 + MINDIM(NTOTCX)= J+1 + DO 95 IREM= MINC, MAXDO(IDLD+4) + J=J+1 + REMESH(J)= RMESHO(IDLR+IREM) + 95 CONTINUE + MAXDIM(NTOTCX)= J + IF( IPRT.GE.1 )THEN + WRITE(IOUT,'(13H CELL(,I8,1H,,I8,1H,,I8,1H), + > 3H (,A1,1H,,A1,10H)- CENTRE: , + > 2H (,2(1X,F13.6),1H) )') + > ICUR(1), ICUR(2), ICUR(3), + > TEMESH(MOD(ICORD(NTOTCX) ,3)+1), + > TEMESH(MOD(ICORD(NTOTCX)+1,3)+1), + > REMESH(MINDIM(NTOTCX)-2), + > REMESH(MINDIM(NTOTCX)-1) + IF( NDIM.EQ.3 )THEN + WRITE(IOUT,'(24X,A1,8H-RADII: /(25X,5(1X,F13.6)))') + > TEMESH(ICORD(NTOTCX)), + > (SQRT(REMESH(J1)),J1=MINDIM(NTOTCX),MAXDIM(NTOTCX)) + ELSE + WRITE(IOUT,'(26X,7HRADII: /(26X,5(1X,F13.6)))') + > (SQRT(REMESH(J1)),J1=MINDIM(NTOTCX),MAXDIM(NTOTCX)) + ENDIF + ENDIF + ENDIF + ENDIF + 105 CONTINUE + IOLD= ICUR(NP2) + ICUR(NP2)= 1 + IF( NDIM.EQ.2 )THEN + IBLK= MAXGRI(1) * (ICUR(2) - 1) + ICUR(1) + ELSE + IBLK= MAXGRI(1)*(MAXGRI(2)*ICUR(3)+ICUR(2)- + > MAXGRI(2))+ICUR(1)-MAXGRI(1) + ENDIF + ITYP= KEYTYP(IBLK) + IGEO= KEYGEO(ITYP) + IDLD= IDLDIM(IGEO) + IDLR= IDLREM(IGEO) + MINABS= MINDO(IDLD+NP1) + MAXABS= MAXDO(IDLD+NP1) + XP1= XP1 + (RMESHO(IDLR+MAXABS)-RMESHO(IDLR+MINABS)) + ICUR(NP2)= IOLD + 110 CONTINUE + ICUR(NP1)= 1 + IF( NDIM.EQ.2 )THEN + IBLK= MAXGRI(1) * (ICUR(2) - 1) + ICUR(1) + ELSE + IBLK= MAXGRI(1)*(MAXGRI(2)*ICUR(3)+ICUR(2)- + > MAXGRI(2))+ICUR(1)-MAXGRI(1) + ENDIF + ITYP= KEYTYP(IBLK) + IGEO= KEYGEO(ITYP) + IDLD= IDLDIM(IGEO) + IDLR= IDLREM(IGEO) + MINABS= MINDO(IDLD+NP2) + MAXABS= MAXDO(IDLD+NP2) + XP2= XP2 + (RMESHO(IDLR+MAXABS)-RMESHO(IDLR+MINABS)) + 120 CONTINUE + 130 CONTINUE +* +* REESTABLISH INDEXING OF ALL UNKNOWNS +* NOW, *ICUR()* IS THE INCREMENT FOR CARTESIAN CELL MESHING + ISU2= 0 + IVO2= 0 + ICREM = 0 + ICUR(3)= 0 + DO 230 IP3= 1,MAXGRI(3) + ICUR(2)= 0 + DO 220 IP2= 1,MAXGRI(2) + ICUR(1)= 0 + DO 210 IP1= 1,MAXGRI(1) + IF( NDIM.EQ.2 )THEN + IBLK= MAXGRI(1)*(IP2-1)+IP1 + ELSE + IBLK= MAXGRI(1)*(MAXGRI(2)*IP3+IP2-MAXGRI(2))+IP1-MAXGRI(1) + ENDIF + ITYP= KEYTYP(IBLK) + ICYL= KEYCYL(IBLK) + IGEO= KEYGEO(ITYP) + IDLTYX= IDLTYP(ITYP) + IDLD= IDLDIM(IGEO) + IDLGEX= IDLGEO(IGEO) + IKREM = ICREM + DO 200 IVS= 1, NVOLO(IGEO) + NO= NUMBLK(IVS, IBLK) + IMYG=0 + IF( KEYINT(NO).NE.0 ) GO TO 200 + IMYG=MATGEO(IDLGEX+IVS) + IVO2= IVO2 + 1 + IVSN= IVO2 + IF( IMYG.GE.0 )THEN + IF( IVO2.GT.NVOL ) + > CALL XABORT( '** XELETR: TOO MANY ZONES' ) + KEYMRG( IDLGE2+IVSN)= IMYG+ICREM + VOLSUR( IDLGE2+IVSN)= VOLSO( IDLGEX+IVS) + MATALB( IDLGE2+IVSN)= MATTYP( IDLTYX+IVS) + INDEX(1,IDLGE2+IVSN)= INDEXO(1,IDLGEX+IVS)+ICUR(1) + > + (MINDIM(1)-MINDO(IDLD+1)) + INDEX(2,IDLGE2+IVSN)= INDEXO(2,IDLGEX+IVS)+ICUR(2) + > + (MINDIM(2)-MINDO(IDLD+2)) + INDEX(3,IDLGE2+IVSN)= INDEXO(3,IDLGEX+IVS)+ICUR(3) + > + (MINDIM(3)-MINDO(IDLD+3)) + INDEX(4,IDLGE2+IVSN)= 0 + INCELL( IDLGE2+IVSN)= IBLK + IF( ICYL.NE.0 )THEN + IF( INDEXO(4,IDLGEX+IVS).NE.MAXDO(IDLD+4) )THEN +* IF WE ARE INSIDE THE CYLINDER: + INDEX(4,IDLGE2+IVSN)= INDEXO(4,IDLGEX+IVS) + > + (MINDIM(ICYL)-MINDO(IDLD+4)) + ENDIF + ENDIF + IKREM=IKREM+1 + ELSE + KEYMRG( IDLGE2+IVSN)= 0 + INCELL( IDLGE2+IVSN)= IBLK + ENDIF + 200 CONTINUE + ICREM=IKREM + DO 400 IVS= -1,NSURO(IGEO),-1 + NO= NUMBLK(IVS, IBLK) + IMYG=0 + IF( KEYINT(NO).NE.0 ) GO TO 400 + IMYG=MATGEO(IDLGEX+IVS) + IF( IMYG.LT.0 )THEN + ISU2= ISU2 - 1 + IVSN= ISU2 + IF( ISU2.LT. NSUR ) + > CALL XABORT( '** XELETR: TOO MANY SURFACES' ) + KEYMRG( IDLGE2+IVSN)= IVSN + VOLSUR( IDLGE2+IVSN)= VOLSO( IDLGEX+IVS) + MATALB( IDLGE2+IVSN)= MATTYP( IDLTYX+IVS) + INDEX(1,IDLGE2+IVSN)= INDEXO(1,IDLGEX+IVS)+ICUR(1) + > + (MINDIM(1)-MINDO(IDLD+1)) + INDEX(2,IDLGE2+IVSN)= INDEXO(2,IDLGEX+IVS)+ICUR(2) + > + (MINDIM(2)-MINDO(IDLD+2)) + INDEX(3,IDLGE2+IVSN)= INDEXO(3,IDLGEX+IVS)+ICUR(3) + > + (MINDIM(3)-MINDO(IDLD+3)) + INDEX(4,IDLGE2+IVSN)= 0 + INCELL( IDLGE2+IVSN)= IBLK + IF( ICYL.NE.0 )THEN + IF( INDEXO(4,IDLGEX+IVS).NE.MAXDO(IDLD+4) )THEN +* IF WE ARE INSIDE THE CYLINDER: + INDEX(4,IDLGE2+IVSN)= INDEXO(4,IDLGEX+IVS) + > + (MINDIM(ICYL)-MINDO(IDLD+4)) + ENDIF + ENDIF + ENDIF + 400 CONTINUE + ICUR(1)= ICUR(1) + (MAXDO(IDLD+1)-MINDO(IDLD+1)) + 210 CONTINUE + ICUR(2)= ICUR(2) + (MAXDO(IDLD+2)-MINDO(IDLD+2)) + 220 CONTINUE + ICUR(3)= ICUR(3) + (MAXDO(IDLD+3)-MINDO(IDLD+3)) + 230 CONTINUE +*---- +* REMOVE ZONES AND SURFACES WITH VANISHING VOLSUR +*---- + IVS=0 + DO 410 ISU2=NSUR,-1 + IF(VOLSUR(ISU2-NSUR+1) .GT. 0.0) THEN + IVS=IVS+1 + VOLSUR(IVS)=VOLSUR(ISU2-NSUR+1) + MATALB(IVS)=MATALB(ISU2-NSUR+1) + KEYMRG(IVS)=KEYMRG(ISU2-NSUR+1) + INCELL(IVS)=INCELL(ISU2-NSUR+1) + DO 411 J1=1,4 + INDEX(J1,IVS)=INDEX(J1,ISU2-NSUR+1) + 411 CONTINUE + ENDIF + 410 CONTINUE + NSURC=-IVS + IVS=IVS+1 + VOLSUR(IVS)=0.0 + MATALB(IVS)=0 + KEYMRG(IVS)=0 + INCELL(IVS)=0 + DO 420 J1=1,4 + INDEX(J1,IVS)=0 + 420 CONTINUE + DO 430 IVO2=1,NVOL + IF(VOLSUR(IVO2-NSUR+1) .GT. 0.0) THEN + IVS=IVS+1 + VOLSUR(IVS)=VOLSUR(IVO2-NSUR+1) + MATALB(IVS)=MATALB(IVO2-NSUR+1) + KEYMRG(IVS)=KEYMRG(IVO2-NSUR+1) + INCELL(IVS)=INCELL(IVO2-NSUR+1) + DO 431 J1=1,4 + INDEX(J1,IVS)=INDEX(J1,IVO2-NSUR+1) + 431 CONTINUE + ENDIF + 430 CONTINUE + NVOLC=IVS+NSURC-1 + KL=1-NSURC + IF( IPRT.GE.5 )THEN + WRITE(IOUT,'(1H )') + WRITE(IOUT,'(/13H RENUMBERING ,I8,13H VOLUMES AND ,'// + > 'I8,10H SURFACES.)') NVOL,-NSUR + WRITE(IOUT,'(20H CARTESIAN MESH ,7HMINDIM=,3I8)') + > (MINDIM(J1),J1=1,3) + WRITE(IOUT,'(20X ,7HMAXDIM=,3I8)') + > (MAXDIM(J1),J1=1,3) + IF( NTOTCL.GT.3 )THEN + DO 540 J1= 4, NTOTCL + WRITE(IOUT,'(10H CYLINDER ,I8,6X ,7HMINDIM=,15X,I8)') + > J1-3,MINDIM(J1) + WRITE(IOUT,'(20X ,7HMAXDIM=,15X,I8)') + > MAXDIM(J1) + 540 CONTINUE + ENDIF + DO 550 IVS= NSURC, NVOLC + IF( IVS.LT.0 )THEN + IF( KEYMRG(IVS+KL) .EQ. 0 )THEN + WRITE(IOUT,'(8H KEYMRG(,I8,2H)=,I8, + > 7H INDEX=,4I8,7H BLOCK=,I8,9H SURFACE=,F20.7, + > 17H ABSENT FROM CELL)') + > IVS,KEYMRG(IVS+KL),(INDEX(J1,IVS+KL),J1=1,4), + > INCELL(IVS+KL),4.*VOLSUR(IVS+KL) + ELSE + WRITE(IOUT,'(8H KEYMRG(,I8,2H)=,I8, + > 7H INDEX=,4I8,7H BLOCK=,I8,9H SURFACE=,F20.7)') + > IVS,KEYMRG(IVS+KL),(INDEX(J1,IVS+KL),J1=1,4), + > INCELL(IVS+KL),4.*VOLSUR(IVS+KL) + ENDIF + ELSE + IF( KEYMRG(IVS+KL) .EQ. 0 )THEN + WRITE(IOUT,'(8H KEYMRG(,I8,2H)=,I8, + > 7H INDEX=,4I8,7H BLOCK=,I8,9H VOLUME= ,F20.7, + > 17H ABSENT FROM CELL)') + > IVS,KEYMRG(IVS+KL),(INDEX(J1,IVS+KL),J1=1,4), + > INCELL(IVS+KL),VOLSUR(IVS+KL) + ELSE + WRITE(IOUT,'(8H KEYMRG(,I8,2H)=,I8, + > 7H INDEX=,4I8,7H BLOCK=,I8,9H VOLUME= ,F20.7)') + > IVS,KEYMRG(IVS+KL),(INDEX(J1,IVS+KL),J1=1,4), + > INCELL(IVS+KL),VOLSUR(IVS+KL) + ENDIF + ENDIF + 550 CONTINUE + ENDIF + RETURN + END diff --git a/Dragon/src/XELGPR.f b/Dragon/src/XELGPR.f new file mode 100644 index 0000000..eb83e21 --- /dev/null +++ b/Dragon/src/XELGPR.f @@ -0,0 +1,303 @@ +*DECK XELGPR + SUBROUTINE XELGPR( NDIM, NTX, NTY, NTZ, NTR,ISYMM, + > NSUR, NVOL,NTOTCL,MINDIM,MAXDIM, + > KEYMRG, INDEX,MATALB) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Prints a semi-graphical representation of the geometry +* compute annular surface. +* +*Copyright: +* Copyright (C) 1997 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* NDIM number of dimensions. +* NTX number of X-mesh. +* NTY number of Y-mesh. +* NTZ number of Z-mesh. +* NTR number of R-mesh. +* ISYMM flag for intrinsic symmetry: +* 2 reflection plane normal to X axis; +* 4 reflection plane normal to Y axis; +* 8 reflection plane normal to X and Y axis; +* 16 reflection plane normal to Z axis; +* 18 reflection plane normal to X and Z axis; +* 20 reflection plane normal to Y and Z axis; +* 24 reflection plane normal to X, Y and Z axis. +* NSUR number of surfaces. +* NVOL number of zones. +* NTOTCL tot number of cylinders in exact geometry. +* MINDIM min index values for all axes (rect/cyl). +* MAXDIM max index values for all axes (rect/cyl). +* KEYMRG merging vector of exact geometry. +* INDEX numbering of surfaces and zones. +* MATALB material/albedo. +* +*-------------------------- XELGPR ------------------------------- +* + IMPLICIT NONE +* + INTEGER NDIM, NTX, NTY, NTZ, NTR,ISYMM, + > NSUR, NVOL,NTOTCL, + > MINDIM(NTOTCL), + > MAXDIM(NTOTCL), + > KEYMRG(NSUR:NVOL), + > INDEX(4,NSUR:NVOL), + > MATALB(NSUR:NVOL), + > NTC,IOUT + PARAMETER ( NTC=4,IOUT=6 ) + CHARACTER CABS*16,CNON*16,CNAM*16 + CHARACTER FMTB*24,FMTVS*24,FMTE*24 +* + INTEGER MAXZ, MINZ, MAXY, MINY, MAXX, MINX, LNFMT, + > ITRZ, NTRZ, IZ, IY, IX, ISURZ, ISURY, ISURX, + > ISURG, ITC, IVS, ICL, IR + INTEGER IPX,IPY,IPZ,IPPZ + INTEGER, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: NAMNUM +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NAMNUM(4,NTR+1,0:NTX+1,0:NTY+1,0:NTZ+1)) +* + CABS=' ABSENT' + CNON=' ' +*---- +* COMPUTE MEMORY SIZE REQUIRED +*---- + MAXZ=MAXDIM(3) + MINZ=MINDIM(3)-1 + MAXY=MAXDIM(2) + MINY=MINDIM(2)-1 + MAXX=MAXDIM(1) + MINX=MINDIM(1)-1 + LNFMT=MAXX-MINX+1 + WRITE(FMTB ,5000) LNFMT*18-2 + WRITE(FMTVS,5001) LNFMT + WRITE(FMTE ,5002) LNFMT*18-2 + ITRZ=0 + NTRZ=NTZ+1 + IF(NDIM .EQ. 2) THEN + ITRZ=1 + NTRZ=1 + ENDIF +*---- +* INITIALIZE NAMNUM +*---- + DO 100 IZ=ITRZ,NTRZ + IF(IZ .EQ. 0 .OR. IZ .EQ. NTZ+1) THEN + ISURZ=1 + ELSE + ISURZ=0 + ENDIF + DO 101 IY=0,NTY+1 + IF(IY .EQ. 0 .OR. IY .EQ. NTY+1) THEN + ISURY=1 + ELSE + ISURY=0 + ENDIF + DO 102 IX=0,NTX+1 + IF(IX .EQ. 0 .OR. IX .EQ. NTX+1) THEN + ISURX=1 + ELSE + ISURX=0 + ENDIF +*---- +* DETERMINE IF SURFACE REPRESENTS A LINE OR CORNER +* FOR SURFACE +*---- + ISURG=ISURX*ISURY+ISURX*ISURZ+ISURY*ISURZ + DO 103 IR=1,NTR+1 + IF(ISURG.EQ.0) THEN +*---- +* REGION REQUIRED +* INITIALIZED TO ABSENT +*---- + READ(CABS,5010) (NAMNUM(ITC,IR,IX,IY,IZ),ITC=1,NTC) + ELSE +*---- +* REGION NOT REQUIRED +* INITIALIZE TO BLANK +*---- + READ(CNON,5010) (NAMNUM(ITC,IR,IX,IY,IZ),ITC=1,NTC) + ENDIF + 103 CONTINUE + 102 CONTINUE + 101 CONTINUE + 100 CONTINUE +*---- +* SCAN ALL SURFACE AND REGIONS AND LOCATE POSITION +* STORE ADEQUATE REGION NUMVER IN NAMNUM +*---- + DO 110 IVS=NSUR,NVOL + IF(KEYMRG(IVS) .NE. 0) THEN +*---- +* POSITION IN X, Y AND Z LOCATED +*---- + IX=INDEX(1,IVS)-MINX + IY=INDEX(2,IVS)-MINY + IZ=INDEX(3,IVS)-MINZ + IF(INDEX(4,IVS) .EQ. 0) THEN +*---- +* CARTESIAN POSITION +* STORE AT LOCATION NTR+1 +*---- + IR=NTR+1 + WRITE(CNAM,5011) MATALB(IVS),KEYMRG(IVS) + READ(CNAM,5010) + > (NAMNUM(ITC,IR,IX,IY,IZ),ITC=1,NTC) + ELSE +*---- +* ANNULAR POSITION +* DETERMINE WHICH ANNULUS +*---- + DO 111 ICL=4,NTOTCL + IF( INDEX(4,IVS) .GE. MINDIM(ICL)-1 .AND. + > INDEX(4,IVS) .LT. MAXDIM(ICL) ) THEN + IR=INDEX(4,IVS)-MINDIM(ICL)+2 +*---- +* ANNULAR POSITION +* STORE AT LOCATION IR +*---- + WRITE(CNAM,5011) MATALB(IVS),KEYMRG(IVS) + READ(CNAM,5010) + > (NAMNUM(ITC,IR,IX,IY,IZ),ITC=1,NTC) + GO TO 115 + ENDIF + 111 CONTINUE + 115 CONTINUE + ENDIF + ENDIF + 110 CONTINUE +*---- +* PRINT HEADER +*---- + WRITE(IOUT,6000) +*---- +* PRINT NAMNUM MATRIX +*---- + IPZ=NTRZ + IPY=0 + IPX=0 + IF(ISYMM .GE. 16) THEN +*---- +* Z SYMMETRY +*---- + IPZ=(NTZ+1)/2 + WRITE(IOUT,6010) + ENDIF + IF(ISYMM .EQ. 8 .OR. ISYMM .EQ. 24) THEN +*---- +* X AND Y SYMMETRY +*---- + IPX=NTX/2+1 + IPY=NTY/2+1 + WRITE(IOUT,6011) + ELSE IF(ISYMM .EQ. 4 .OR. ISYMM .EQ. 20) THEN +*---- +* Y SYMMETRY +*---- + IPY=NTY/2+1 + WRITE(IOUT,6012) + ELSE IF(ISYMM .EQ. 2 .OR. ISYMM .EQ. 18) THEN +*---- +* X SYMMETRY +*---- + IPX=NTX/2+1 + WRITE(IOUT,6013) + ENDIF +*---- +* Start test print +* write(IOUT,7000) isymm,ntx,ipx,nty,ipy,ntz,ipz +* 7000 format(1x,'Test print:'/ +* > 1x,'Symmetry factor = ',i10/ +* > 1x,'ntx,ipx =',2i10/ +* > 1x,'nty,ipy =',2i10/ +* > 1x,'ntz,ipz =',2i10/ +* > 1x,'keymrg follows') +* write(IOUT,7001) (ir,keymrg(ir),ir=-1,nsur,-1) +* write(IOUT,7001) (ir,keymrg(ir),ir=1,nvol) +* 7001 format(10i10) +* Finish test print +*---- + DO 140 IZ=NTRZ,ITRZ,-1 + IPPZ=1 + IF(NDIM .EQ. 3) THEN + IF(IZ .LE. IPZ) THEN + IF(IZ .EQ. 0) THEN + WRITE(IOUT,6001) + ELSE IF(IZ .EQ. NTZ+1) THEN + WRITE(IOUT,6002) + ELSE + WRITE(IOUT,6003) IZ + ENDIF + ELSE + IPPZ=0 + ENDIF + ELSE + WRITE(IOUT,6004) + ENDIF + IF(IPPZ .EQ. 1) THEN + DO 141 IY=NTY+1,0,-1 + IF(IY .GE. IPY) THEN + WRITE(IOUT,FMTB) + DO 142 IR=NTR+1,1,-1 + WRITE(IOUT,FMTVS) + < ((NAMNUM(ITC,IR,IX,IY,IZ),ITC=1,NTC),IX=IPX,NTX+1) + 142 CONTINUE + ENDIF + 141 CONTINUE + ENDIF + WRITE(IOUT,FMTE) + 140 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(NAMNUM) + RETURN +*---- +* FORMATS TO CREATE FORMATS +*---- + 5000 FORMAT('(2X,',I10,'(1H-) ) ') + 5001 FORMAT('( ',I10,'(2X,4A4)) ') + 5002 FORMAT('(2X,',I10,'(1H-)/) ') + 5010 FORMAT(4A4) + 5011 FORMAT('(',I6,') ',I7) +*---- +* OTHER PRINT FORMATS +*---- + 6000 FORMAT(//' PRINTING GEOMETRY DESCRIPTION BY PLANES '/ + > ' ---- NOTATION USED:'/ + >10X,'NEGATIVE INTEGERS REPRESENT SURFACES'/ + >10X,'POSITIVE INTEGERS REPRESENT REGIONS'/ + >10X,'ABSENT MEANS THAT THE REGION OR SURFACE DOES NOT EXIST'/ + >10X,'FIRST LINE REPRESENTS REGION OR VOLUME IN CARTESIAN MESH'/ + >10X,'ADDITIONAL LINES REPRESENT REGION OR SURFACE IN ', + > 'RADIAL MESH (OUTER TO INNER)'/ + >10X,'FOR 3-D MODEL, START WITH TOP Z-SURFACE ', + > 'THEN GO DOWN ALONG Z-AXIS AND FINISH BY BOTTOM Z-SURFACE'/ + >10X,'FOR 2-D X-Y PLANE FIRST LINE IS FOR TOP Y-SURFACE ', + > 'THEN GO DOWN ALONG Y-AXIS AND FINISH BY BOTTOM Y-SURFACE'/ + >10X,'FOR A LINE FIRST POINT IS FOR LEFT X-SURFACE ', + > 'THEN INCREASE ALONG X-AXIS AND FINISH BY RIGHT X-SURFACE'/ + >10X,'MATERIAL AND ABLEDO NUMBERS ARE IN PARENTHESIS'/) + 6001 FORMAT(/' X-Y MESH ON BOTTOM Z-SURFACE') + 6002 FORMAT(/' X-Y MESH ON TOP Z-SURFACE') + 6003 FORMAT(/' X-Y MESH IN Z-PLANE = ',I10) + 6004 FORMAT(/' X-Y MESH') + 6010 FORMAT(/' GEOMETRY HAS CENTRAL Z SYMMETRY '/ + > ' ONLY BOTTOM-Z PLANES PRINTED') + 6011 FORMAT(/' GEOMETRY HAS CENTRAL X AND Y SYMMETRY '/ + > ' ONLY TOP-Y RIGHT-X REGIONS PRINTED') + 6012 FORMAT(/' GEOMETRY HAS CENTRAL Y SYMMETRY '/ + > ' ONLY TOP-Y REGIONS PRINTED') + 6013 FORMAT(/' GEOMETRY HAS CENTRAL X SYMMETRY '/ + > ' ONLY RIGHT-X REGIONS PRINTED') + END diff --git a/Dragon/src/XELGRD.f b/Dragon/src/XELGRD.f new file mode 100644 index 0000000..e50f0b1 --- /dev/null +++ b/Dragon/src/XELGRD.f @@ -0,0 +1,288 @@ +*DECK XELGRD + SUBROUTINE XELGRD( IPGEOM, IPRT, NDIM, NEXTGE, ITURN, DMESHO, + > MAXC, RMESHO, MINDO, MAXDO, ICORDO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read the geometric input for a specific type of cell. +* +*Copyright: +* Copyright (C) 1987 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPGEOM pointer to the geometry (L_GEOM). +* IPRT intermediate printing level for output. +* NDIM number of dimensions. +* NEXTGE rectangular(0)/circular(1) boundary. +* ITURN turn index for the geometry (from 1 to 16). +* DMESHO dimension of array RMESHO. +* +*Parameters: output +* MAXC number of real meshes to stock in RMESHO. +* RMESHO real mesh values (rect/cyl). +* MINDO min index values for all axes (rect/cyl). +* MAXDO max index values for all axes (rect/cyl). +* ICORDO principal axes direction (X/Y/Z) for meshes. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +* +* DECLARE DUMMY ARGUMENTS + TYPE(C_PTR) IPGEOM + INTEGER IPRT, NDIM, NEXTGE, ITURN, DMESHO, MAXC + REAL RMESHO(DMESHO) + INTEGER MAXDO(*),MINDO(*),ICORDO(*) +* +* DECLARE LOCAL VARIABLES + INTEGER NSTATE, IOUT, MAXTUR + PARAMETER ( NSTATE=40, IOUT=6, MAXTUR=12 ) + REAL RGAR,CENTER(3),DCENT,RMAX + INTEGER ISTATE(NSTATE),ITMIX(2*MAXTUR,3), + > ITXYZ(2*MAXTUR,3),IDCEN,IROT + DOUBLE PRECISION GAR,DEL + CHARACTER TEDATA*12, TEMESH(4)*1, HSMG*131 + INTEGER ILEN, ILE2, ITYLCM, IBEGIN, INEW, IOLD, + > I, J, K, ISS, ITYPE, ICI, IDIMEN, ICTYPE + DOUBLE PRECISION PI,PIO2,FACT + PARAMETER ( PI = 3.14159265358979323846D0, PIO2= 0.5D0*PI) +* +* ALLOCATABLE ARRAYS + INTEGER, ALLOCATABLE, DIMENSION(:) :: ISPLT +* +* DATA STATEMENTS + SAVE TEMESH,ITMIX,ITXYZ + DATA TEMESH / 'X','Y','Z','C' / +* 'X'-AXIS AND ITS SIGN + DATA ITMIX / 1,-2,-1, 2,-1, 2, 1,-2, 0, 0, 0, 0, + > 1,-2,-1, 2,-1, 2, 1,-2, 0, 0, 0, 0, +* 'Y'-AXIS AND ITS SIGN + > 2, 1,-2,-1, 2, 1,-2,-1, 0, 0, 0, 0, + > 2, 1,-2,-1, 2, 1,-2,-1, 0, 0, 0, 0, +* 'Z'-AXIS AND ITS SIGN + > 3, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, + > -3,-3,-3,-3,-3,-3,-3,-3, 0, 0, 0, 0 / +* + DATA ITXYZ / 1, 2,-1,-2,-1, 2, 1,-2, 0, 0, 0, 0, + > 1, 2,-1,-2,-1, 2, 1,-2, 0, 0, 0, 0, +* 'Y'-AXIS AND ITS SIGN + > 2,-1,-2, 1, 2, 1,-2,-1, 0, 0, 0, 0, + > 2,-1,-2, 1, 2, 1,-2,-1, 0, 0, 0, 0, +* 'Z'-AXIS AND ITS SIGN + > 3, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, + > -3,-3,-3,-3,-3,-3,-3,-3, 0, 0, 0, 0 / +* + IF( IPRT.GT.1 )THEN + WRITE(IOUT,'(1H )') + WRITE(IOUT,'(/24H CELL MESHING )') + ENDIF + IF((ITURN.LE.0).OR.(ITURN.GT.24)) THEN + WRITE(HSMG,'(24H XELGRD: INVALID ITURN (,I6,2H).)') ITURN + CALL XABORT(HSMG) + ENDIF + ISTATE(:NSTATE)=0 + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) + ITYPE= ISTATE(1) + RMAX= 0.0 + IF( ITYPE.EQ.3 .OR. ITYPE.EQ.6 )THEN + IF( NEXTGE.NE.1 ) CALL XABORT( 'XELGRD: TYPE IS NOT '// + > 'COMPATIBLE WITH CIRCULAR B.C.' ) +* GET MAXIMUM RADIUS & +* INSCRIBE CIRCULAR REGION IN A SQUARE MESH WITH VOLUME=SURFACE + TEDATA= 'RADIUS' + CALL LCMLEN(IPGEOM,TEDATA, ILEN, ITYLCM) + IF(ILEN.GT.0) THEN + CALL LCMGET(IPGEOM,TEDATA,RMESHO) + RMAX= RMESHO(ILEN) + ENDIF + ENDIF + IBEGIN = 1 + DO 10 I= 1, 3 + ICORDO(I)=ITMIX(ITURN,I) + ICI= ABS(ITXYZ(ITURN,I)) + MINDO(I)= IBEGIN + IF( NEXTGE.EQ.1.AND.I.LE.2 )THEN + ILEN= 2 + FACT= 0.5D0 * DSQRT(PI+PIO2*PIO2) + RMESHO(IBEGIN)= -REAL(FACT)*RMAX + RMESHO(IBEGIN+1)= REAL(FACT)*RMAX + IDIMEN= IBEGIN + 1 + ELSE + IF( I.LE.NDIM )THEN + TEDATA= 'MESH'//TEMESH(ICI) + CALL LCMLEN(IPGEOM,TEDATA, ILEN, ITYLCM) + CALL LCMGET(IPGEOM,TEDATA,RMESHO(IBEGIN)) + IDIMEN= IBEGIN + ILEN - 1 + TEDATA= 'SPLIT'//TEMESH(ICI) + CALL LCMLEN(IPGEOM,TEDATA, ILE2, ITYLCM) + IF( ILE2.NE.0 )THEN + IF( ILE2.NE.ILEN-1 )THEN + CALL XABORT( 'XELGRD: '//TEDATA//' IS INVALID') + ELSE + ALLOCATE(ISPLT(ILE2)) + CALL LCMGET(IPGEOM,TEDATA,ISPLT) + INEW=0 + DO 5 IOLD= 1,ILE2 + INEW= INEW+ ISPLT(IOLD) + 5 CONTINUE + K= INEW+1 + GAR= DBLE(RMESHO(IDIMEN)) + DO 7 IOLD= ILE2,1,-1 + DEL= (GAR-DBLE(RMESHO(IBEGIN+IOLD-1))) + > /DBLE(ISPLT(IOLD)) + GAR= DBLE(RMESHO(IBEGIN+IOLD-1)) + DO 6 ISS= ISPLT(IOLD),1,-1 + RMESHO(IBEGIN+K-1)= REAL(GAR+DEL*REAL(ISS)) + K=K-1 + 6 CONTINUE + 7 CONTINUE + IDIMEN= IBEGIN + INEW + ILEN= INEW + 1 + DEALLOCATE(ISPLT) + ENDIF + ENDIF + IF( ITXYZ(ITURN,I).LT.0 )THEN + DO 3 IOLD= 1,ILEN/2 + RGAR= -RMESHO(IBEGIN+IOLD-1) + RMESHO(IBEGIN+IOLD-1)= -RMESHO(IBEGIN+ILEN-IOLD) + RMESHO(IBEGIN+ILEN-IOLD)= RGAR + 3 CONTINUE + IF( 2*(ILEN/2).NE.ILEN )THEN + RMESHO(IBEGIN+ILEN/2)= -RMESHO(IBEGIN+ILEN/2) + ENDIF + ENDIF + IF( IPRT.GT.2 )THEN + WRITE(IOUT,'(1H )') + WRITE(IOUT,'(8X,A1,13H-COORDINATES:/(9X,5(1x,F13.6)))') + > TEMESH(I), (RMESHO(J),J=IBEGIN,IDIMEN) + ENDIF + ELSE + ILEN= 2 + RMESHO(IBEGIN)= 0.0 + RMESHO(IBEGIN+1)= 1.0 + IDIMEN= IBEGIN + 1 + ENDIF + ENDIF + MAXDO(I)= IDIMEN + IBEGIN= IDIMEN + 1 + 10 CONTINUE +* +* DETERMINATE COORDINATES OF CENTER + IF( ITYPE.GE.20.OR.NEXTGE.EQ.1 )THEN + IF( NEXTGE.EQ.1 )THEN + ICTYPE= 3 + ELSE + ICTYPE= ITYPE-20 + IF( ICTYPE.EQ.0 ) ICTYPE= 3 + ENDIF +* +* GET OFFCENTER VARIATION + TEDATA= 'OFFCENTER' + CALL LCMLEN(IPGEOM,TEDATA, ILEN, ITYLCM) + IF( ILEN .EQ. 0 )THEN + CENTER(1)=0.0 + CENTER(2)=0.0 + CENTER(3)=0.0 + ELSE + CALL LCMGET(IPGEOM,TEDATA,CENTER) + ENDIF +* +* GET RADIUS, THE FIRST ONE MUST BE 0.0 + TEDATA= 'RADIUS' + CALL LCMLEN(IPGEOM,TEDATA, ILEN, ITYLCM) + IF(ILEN.EQ.0) THEN + ILEN=1 + RMESHO(IBEGIN+1)=0.0 + ELSE + CALL LCMGET(IPGEOM,TEDATA,RMESHO(IBEGIN+1)) + ENDIF + IDIMEN= IBEGIN + ILEN + TEDATA= 'SPLITR' + CALL LCMLEN(IPGEOM,TEDATA, ILE2, ITYLCM) + IF( ILE2.NE.0 )THEN + IF( ILE2.NE.ILEN-1 )THEN + CALL XABORT( 'XELGRD: '//TEDATA//' IS INVALID') + ELSE + ALLOCATE(ISPLT(ILE2)) + CALL LCMGET(IPGEOM,TEDATA,ISPLT) + INEW=0 + DO 15 IOLD= 1,ILE2 + INEW= INEW+ ABS(ISPLT(IOLD)) + 15 CONTINUE + K= INEW+1 + GAR= DBLE(RMESHO(IDIMEN)) + DO 17 IOLD= ILE2,1,-1 + DEL= (GAR-DBLE(RMESHO(IBEGIN+IOLD))) + > /DBLE(ABS(ISPLT(IOLD))) + IF(ISPLT(IOLD).LT.0)THEN + DEL= DEL*(GAR+RMESHO(IBEGIN+IOLD)) + ENDIF + GAR= DBLE(RMESHO(IBEGIN+IOLD)) + DO 16 ISS= ABS(ISPLT(IOLD)),1,-1 + IF( ISPLT(IOLD).GT.0 )THEN + RMESHO(IBEGIN+K)= REAL(GAR+DEL*REAL(ISS)) + ELSE + RMESHO(IBEGIN+K)= SQRT(REAL(GAR*GAR+DEL*REAL(ISS))) + ENDIF + K=K-1 + 16 CONTINUE + 17 CONTINUE + IDIMEN= IBEGIN + INEW + 1 + DEALLOCATE(ISPLT) + ENDIF + ENDIF + IF( RMESHO(IBEGIN+1).NE.0.0 )THEN + WRITE(IOUT,'(11H ,17HRADII OF ANNULI: / + > (11X,5(1X,F13.6)))') + > (RMESHO(J),J=IBEGIN+1,IDIMEN) + CALL XABORT( 'XELGRD: FIRST RADIUS MUST BE 0.0') + ENDIF + ICORDO(4)= ICTYPE + DO 20 I= 0, 1 + IDCEN=MOD(ICTYPE+I,3)+1 + IROT=ITXYZ(ITURN,IDCEN) + DCENT=CENTER(ABS(IROT)) + IF( IROT .LT. 0 )THEN + DCENT=-DCENT + ENDIF + RMESHO(IBEGIN+I)= 0.5*(RMESHO(MINDO(IDCEN)) + > +RMESHO(MAXDO(IDCEN)))+DCENT + 20 CONTINUE + MINDO(4)= IBEGIN+2 + MAXDO(4)= IDIMEN + IF( IPRT.GT.2 )THEN + WRITE(IOUT,'(1H )') + IF( NEXTGE.EQ.0 )THEN + WRITE(IOUT,'(9H (,A1,1H,,A1,10H)- CENTRE: , + > 2H (,2(1X,F13.6),1H) )') + > TEMESH(MOD(ICTYPE ,3)+1), + > TEMESH(MOD(ICTYPE+1,3)+1), + > RMESHO(IBEGIN),RMESHO(IBEGIN+1) + ENDIF + IF( NDIM.EQ.3 )THEN + WRITE(IOUT,'(14H ,A1,7H-RADII:/ + > (15X,5(1X,F13.6)))') + > TEMESH(ICTYPE), + > (RMESHO(J),J=IBEGIN+2,IDIMEN) + ELSE + WRITE(IOUT,'(24H RADII: / + > (15X,5(1X,F13.6)))') + > (RMESHO(J),J=IBEGIN+2,IDIMEN) + ENDIF + ENDIF + DO 40 J = IBEGIN+2, IDIMEN + RMESHO(J)= RMESHO(J) * RMESHO(J) + 40 CONTINUE + ENDIF + MAXC= IDIMEN +* + RETURN + END diff --git a/Dragon/src/XELLIN.f b/Dragon/src/XELLIN.f new file mode 100644 index 0000000..328bb67 --- /dev/null +++ b/Dragon/src/XELLIN.f @@ -0,0 +1,211 @@ +*DECK XELLIN + SUBROUTINE XELLIN(NDIM,NCP,MAXREM,REMESH, + > NSUR,NVOL,INDEL,MINDIM,MAXDIM, + > ICOORD,ICUR,INCR,TRKBEG,TRKEND,TRKDIR, + > PROJC2,TOTLEN, + > CONV,LINMAX,LENGHT,NUMERO,LINE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Construct one tracking line which consists of two vectors. +* +*Copyright: +* Copyright (C) 1987 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* NDIM number of dimension (2 or 3). +* NCP number of cylindres of a type + 3 (< nc3max). +* MAXREM max number of real mesh values in REMESH. +* REMESH real mesh values (rect/cyl). +* NSUR number of surfaces. +* NVOL number of zones. +* INDEL numbering of surfaces & zones. +* MINDIM min index values for all axes (rect/cyl). +* MAXDIM max index values for all axes (rect/cyl). +* ICOORD principal axes direction (X/Y/Z) for meshes. +* ICUR current zonal location for a track segment. +* INCR increment direction for next track segment. +* TRKBEG position where a track begins. +* TRKEND position where a track ends. +* TRKDIR direction of a track in all axes. +* PROJC2 projections of TRKDIR along tracked angles. +* TOTLEN total lenght of the track. +* CONV segments of tracks. +* LINMAX max. number of track segments in a single track. +* +*Parameters: output +* LENGHT relative lenght of each segment in a track. +* NUMERO region identification of each track segment. +* LINE lenght of the track. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +* + INTEGER NDIM, NCP, MAXREM, NSUR, NVOL, LINMAX, LINE + REAL TRKBEG(NCP), TRKDIR(NCP), CONV(NCP), + > REMESH(MAXREM), TRKEND(*), PROJC2(*), TOTLEN + DOUBLE PRECISION LENGHT(LINMAX) + INTEGER MINDIM(NCP), MAXDIM(NCP), ICUR(NCP), + > ICOORD(NCP), INCR(NCP), INDEL(4,*), + > NUMERO(LINMAX) +* + INTEGER IORD(4), N, NP1, NP2, IBEGIN, IEND, KELVOL + REAL TKBEG1, TKBEG2, TKEND1, TKEND2, R2BEG, R2END + DOUBLE PRECISION CONVOK, PAT0, PAT1 + LOGICAL BETWEN + INTEGER NEXT, NUM, I, J + REAL ANORM2, CENTRE, A, B +* + ANORM2(A,B)= A*A + B*B + CENTRE(I,J)= REMESH( MAXDIM(I-1) + J ) + NEXT(J)= ICUR(J) + MAX( 0, INCR(J) ) + NUM(J)= J + 1 - NSUR +* +* IF THERE ARE NO CYLINDER AT ALL + IEND=0 + DO 90 I = 1, NDIM + N = ICOORD(I) +* +* FIND BEGINNING VOLUME # + ICUR(I)= MINDIM(I) + DO 80 J = MINDIM(I), MAXDIM(I)-1 + IF(TRKBEG(N).GE.REMESH(J)) ICUR(I)= J + IF(TRKEND(N).GE.REMESH(J)) IEND= J + 80 CONTINUE + IF( ICUR(I).EQ.IEND )THEN + CONV(I)= TOTLEN + ELSE + IF( INCR(N).EQ.0 )THEN + CONV(I)= TOTLEN + ELSE + CONV(I)=(REMESH(NEXT(I))-TRKBEG(N))/TRKDIR(N) + ENDIF + ENDIF + 90 CONTINUE +* + IBEGIN= MAXDIM(3) + 3 + DO 110 I = 4, NCP + N = ICOORD(I) + NP1 = MOD(N ,3) + 1 + NP2 = MOD(N+1,3) + 1 + TKBEG1= CENTRE(I,1) - TRKBEG(NP1) + TKEND1= CENTRE(I,1) - TRKEND(NP1) + TKBEG2= CENTRE(I,2) - TRKBEG(NP2) + TKEND2= CENTRE(I,2) - TRKEND(NP2) + R2BEG = ANORM2(TKBEG1,TKBEG2) + R2END = ANORM2(TKEND1,TKEND2) + TRKBEG(I)= (TKBEG1*TRKDIR(NP1)+TKBEG2*TRKDIR(NP2))/PROJC2(N) + BETWEN = 0.0 .LT. TRKBEG(I) .AND. TRKBEG(I) .LT. TOTLEN + TRKDIR(I)= R2BEG - TRKBEG(I) * TRKBEG(I) * PROJC2(N) + ICUR(I) = IBEGIN - 1 + MINDIM(I)= IBEGIN - 1 + IEND = IBEGIN - 1 + DO 100 J = IBEGIN, MAXDIM(I) + IF( R2BEG .GE. REMESH(J) )ICUR(I)= J + IF( TRKDIR(I).GE. REMESH(J) )MINDIM(I)= J + IF( R2END .GE. REMESH(J) )IEND = J + 100 CONTINUE + IBEGIN= MAXDIM(I) + 3 + IF( ICUR(I).EQ.MINDIM(I) .AND. + > IEND .EQ.MINDIM(I) )THEN + CONV(I)=TOTLEN + ELSE + IF( (BETWEN .AND. ICUR(I).NE.MINDIM(I)) .OR. + > ICUR(I).GT.IEND )THEN + INCR(I)=-1 + ELSE + INCR(I)=+1 + ENDIF + IF( NEXT(I).GT.MAXDIM(I) )THEN + CONV(I)=TOTLEN + ELSE + CONV(I)= TRKBEG(I) + INCR(I) * + > SQRT((REMESH(NEXT(I))-TRKDIR(I)) + > / PROJC2(ICOORD(I))) + ENDIF + ENDIF + 110 CONTINUE +* +* VOLUME TRACKED + LINE = 0 + 120 LINE = LINE + 1 +* +* LOOKING FOR THE MINIMUM VALUE IN "CONVOK" + CONVOK= TOTLEN + DO 130 I= 1, NCP + IF( CONV(I) .LT. CONVOK ) CONVOK= CONV(I) + 130 CONTINUE + DO 135 I= 1, NCP + IORD(MIN(4,I))= ICUR(I) + IF(I.GT.3.AND.ICUR(I).LT.MAXDIM(I)) GOTO 136 + 135 CONTINUE + IORD(4)= 0 + 136 CONTINUE + KELVOL= NVOL + INDEL(1,NUM(0))= IORD(1) + INDEL(2,NUM(0))= IORD(2) + INDEL(3,NUM(0))= IORD(3) + INDEL(4,NUM(0))= IORD(4) + 885 CONTINUE + IF( IORD(1).EQ.INDEL(1,NUM(KELVOL)).AND. + > IORD(2).EQ.INDEL(2,NUM(KELVOL)).AND. + > IORD(3).EQ.INDEL(3,NUM(KELVOL)).AND. + > IORD(4).EQ.INDEL(4,NUM(KELVOL)) ) GO TO 895 + KELVOL= KELVOL - 1 + GO TO 885 + 895 IF(KELVOL.EQ.0) CALL XABORT('XELLIN: TRACKING FAILURE.') + NUMERO(LINE)= KELVOL + LENGHT(LINE)= CONVOK +* +* IF "CONVOK" IS "TOTLEN" THE TRACKING IS FINISHED + IF( CONVOK.EQ.TOTLEN ) GO TO 160 +* +* UPDATE WHERE THE MINIMUM VALUE "CONVOK" IS OBTAINED + DO 140 I = 1, NDIM + IF( CONV(I) .NE. CONVOK ) GO TO 140 + ICUR(I)= ICUR(I) + INCR(I) + IF( NEXT(I).GT.MAXDIM(I) .OR. + > NEXT(I).LT.MINDIM(I) ) GO TO 160 + N = ICOORD(I) + CONV(I)= ( REMESH(NEXT(I)) - TRKBEG(N) ) / TRKDIR(N) + 140 CONTINUE + DO 150 I = 4, NCP + IF( CONV(I) .NE. CONVOK ) GO TO 150 + ICUR(I)= ICUR(I) + INCR(I) + IF( ICUR(I) .EQ. MINDIM(I) .AND. + > INCR(I) .EQ. -1 )THEN + INCR(I)= +1 + ENDIF + IF( NEXT(I) .GT. MAXDIM(I) .OR. + > NEXT(I) .LT. MINDIM(I) )THEN + CONV(I)= TOTLEN + ELSE + N = ICOORD(I) + CONV(I)= TRKBEG(I) + INCR(I) * + > SQRT( (REMESH(NEXT(I))-TRKDIR(I))/PROJC2(N) ) + ENDIF + 150 CONTINUE +* +* GO TO NEXT COORDINATE + IF( LINE .NE. LINMAX ) GO TO 120 + CALL XABORT('XELLIN: TOO MANY TRACKS') + 160 CONTINUE +* +* TRANSFORM LOCAL COORDINATES TO PATH LENGTHS + PAT0= 0.0D0 + DO 170 I= 1, LINE + PAT1= LENGHT(I) + LENGHT(I)= PAT1-PAT0 + PAT0= PAT1 + 170 CONTINUE +* + RETURN + END diff --git a/Dragon/src/XELLSR.f b/Dragon/src/XELLSR.f new file mode 100644 index 0000000..d757853 --- /dev/null +++ b/Dragon/src/XELLSR.f @@ -0,0 +1,187 @@ +*DECK XELLSR + SUBROUTINE XELLSR( NDIM, NCP, NSUR, MAXREM, REMESH, + > INDEL, MINDIM, MAXDIM, ICOORD, ICUR, INCR, + > TRKORI, TRKDIR, TRKCUT, NSCUT, NCROS, + > TOTLEN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find the beginning and ending surfaces crossed by a track. +* +*Copyright: +* Copyright (C) 1990 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* NDIM number of dimension (2 or 3). +* NCP number of cylindres of a type + 3. +* NSUR number of surfaces. +* MAXREM max number of real mesh values in REMESH. +* REMESH real mesh values (rect/cyl). +* INDEL numbering of surfaces and zones. +* MINDIM min index values for all axes (rect/cyl). +* MAXDIM max index values for all axes (rect/cyl). +* ICOORD principal axes direction (X/Y/Z) for meshes. +* ICUR current zonal location for a track segment. +* INCR increment direction for next track segment. +* TRKORI origin of a track. +* TRKDIR direction of a track in all axes. +* +*Parameters: output +* TRKCUT points where track cut the domain. +* NSCUT surface where the track begins/ends. +* NCROS number of surface crossing. +* TOTLEN total length of the track. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +* + INTEGER NDIM, NCP, NSUR, MAXREM, NCROS + REAL TRKCUT(3,2), REMESH(MAXREM), TRKDIR(3), TRKORI(3), TOTLEN, + > TKBEG1, TKBEG2, R2BEG + INTEGER MINDIM(NCP), MAXDIM(NCP), ICUR(NCP), INCR(NCP), + > ICOORD(NCP), IFACUT(2), ISFCUT(2), + > IORD(4), NSCUT(2), INDEL(4,*) + INTEGER IOUT + PARAMETER ( IOUT=6 ) + REAL ANORM2, CENTRE, A, B, XYZP2, CONBEG, CONEND, CON, + > XYZP1 + INTEGER I, J, NUM, NCRBEG, NCREND, NP1, NUMP1, NP2, NUMP2, + > N, NUMP0, K, IBEGIN, KELSUR, KWW, IDM +* + ANORM2(A,B)= A*A + B*B + CENTRE(I,J)= REMESH( MAXDIM(I-1) + J ) + NUM(J)= J + 1 - NSUR + NUMP2= 0 + IFACUT(:2)=0 + ISFCUT(:2)=0 +* + IF( NDIM.EQ.2 )THEN + NP2= 3 + NUMP2 = ICOORD(NP2) + XYZP2= 0.0 + ENDIF +* +* IF THERE ARE NO CYLINDER AT ALL + NSCUT(1)= 0 + NSCUT(2)= 0 + NCRBEG= 0 + NCREND= 0 + CONBEG=+1.0E+36 + CONEND=-1.0E+36 +* +* FING BEGINNING AND ENDING POINTS OF THE TRACK + DO 75 N = 1, NDIM + NUMP0 = ICOORD(N ) + IF( INCR(NUMP0).EQ.0 ) GO TO 75 + NP1 = MOD(N ,NDIM)+1 + NUMP1 = ICOORD(NP1) + IF( NDIM.EQ.3 )THEN + NP2 = MOD(N+1 ,NDIM)+1 + NUMP2 = ICOORD(NP2) + ENDIF + DO 70 IDM = MINDIM(N), MAXDIM(N), MAXDIM(N)-MINDIM(N) + CON = (REMESH(IDM) - TRKORI(NUMP0)) / TRKDIR(NUMP0) + XYZP1 = TRKORI(NUMP1) + CON * TRKDIR(NUMP1) + IF( XYZP1.LT.REMESH(MINDIM(NP1)).OR. + > XYZP1.GT.REMESH(MAXDIM(NP1))) GO TO 70 + IF( NDIM.EQ.3 )THEN + XYZP2 = TRKORI(NUMP2) + CON * TRKDIR(NUMP2) + IF( XYZP2.LT.REMESH(MINDIM(NP2)).OR. + > XYZP2.GT.REMESH(MAXDIM(NP2))) GO TO 70 + ENDIF + IF( CON.LT.CONBEG )THEN + NCRBEG=1 + NCREND=MAX(1,NCREND) + IFACUT(1)= NUMP0 + ISFCUT(1)= IDM + IF( IDM.EQ.MINDIM(N) ) ISFCUT(1)= ISFCUT(1)-1 + CONBEG=CON + TRKCUT(NUMP0,1)= REMESH(IDM) + TRKCUT(NUMP1,1)= XYZP1 + TRKCUT(NUMP2,1)= XYZP2 + ENDIF + IF( CON.GT.CONEND )THEN + NCREND=2 + NCRBEG=MIN(2,NCRBEG) + IFACUT(2)= NUMP0 + ISFCUT(2)= IDM + IF( IDM.EQ.MINDIM(N) ) ISFCUT(2)= ISFCUT(2)-1 + CONEND=CON + TRKCUT(NUMP0,2)= REMESH(IDM) + TRKCUT(NUMP1,2)= XYZP1 + TRKCUT(NUMP2,2)= XYZP2 + ENDIF + 70 CONTINUE + 75 CONTINUE + NCROS = NCREND + NCRBEG + TOTLEN= CONEND - CONBEG + IF( NCROS.EQ.0 ) GO TO 1000 + NCROS = NCREND + 1 - NCRBEG +* +* FIND BEGINNING AND ENDING SURFACE NUMBERS + DO 900 K= NCRBEG, NCREND + DO 90 I = 1, NDIM + N = ICOORD(I) + ICUR(I)= MINDIM(I) + DO 80 J = MINDIM(I), MAXDIM(I)-1 + IF(TRKCUT(N,K).GE.REMESH(J)) ICUR(I)= J + 80 CONTINUE + 90 CONTINUE + ICUR(IFACUT(K))= ISFCUT(K) + IBEGIN= MAXDIM(3) + 3 + DO 110 I = 4, NCP + N = ICOORD(I) + NP1 = MOD(N ,3) + 1 + NP2 = MOD(N+1,3) + 1 + TKBEG1= CENTRE(I,1) - TRKCUT(NP1,K) + TKBEG2= CENTRE(I,2) - TRKCUT(NP2,K) + R2BEG = ANORM2(TKBEG1,TKBEG2) + ICUR(I) = IBEGIN - 1 + DO 100 J = IBEGIN, MAXDIM(I) + IF( R2BEG .GE. REMESH(J) )ICUR(I)= J + 100 CONTINUE + IBEGIN= MAXDIM(I) + 3 + 110 CONTINUE +* +* FIND IORD(4) FOR LOCATION IN THE INDEX VECTOR + DO 115 I= 1,NCP + IORD(MIN(4,I))= ICUR(I) + IF( I.GT.3.AND.ICUR(I).LT.MAXDIM(I)) GOTO 116 + 115 CONTINUE + IORD(4)= 0 + 116 CONTINUE +* +* FIND NSCUT=BEGINNING/ENDING SURFACE #S + KELSUR= NSUR + INDEL(1,NUM(0))= IORD(1) + INDEL(2,NUM(0))= IORD(2) + INDEL(3,NUM(0))= IORD(3) + INDEL(4,NUM(0))= IORD(4) + 880 CONTINUE + IF( IORD(1).EQ.INDEL(1,NUM(KELSUR)).AND. + > IORD(2).EQ.INDEL(2,NUM(KELSUR)).AND. + > IORD(3).EQ.INDEL(3,NUM(KELSUR)).AND. + > IORD(4).EQ.INDEL(4,NUM(KELSUR)) ) GO TO 890 + KELSUR= KELSUR + 1 + GO TO 880 + 890 NSCUT(K)= KELSUR + IF( KELSUR.EQ.0 )THEN + WRITE(IOUT,*) ' BAD SURFACE IDENTIFICATION' + WRITE(IOUT,*) ' NSCUT=', NSCUT(K) + WRITE(IOUT,*) 'TRKCUT=', (TRKCUT(KWW,K),KWW=1,3) + WRITE(IOUT,*) ' IORD=', IORD + WRITE(IOUT,*) ' ICUR=', (ICUR(KWW),KWW=1,NCP) + CALL XABORT('XELLSR: BAD SURFACE IDENTIFICATION') + ENDIF + 900 CONTINUE +* + 1000 RETURN + END diff --git a/Dragon/src/XELMRG.f b/Dragon/src/XELMRG.f new file mode 100644 index 0000000..06134f2 --- /dev/null +++ b/Dragon/src/XELMRG.f @@ -0,0 +1,502 @@ +*DECK XELMRG + SUBROUTINE XELMRG ( IPRT, NSUR, NVOL, NSBC, NTOTCL, INDEX, + > MINDIM, MAXDIM, LCLSYM, LCLTRA, LL1, LL2, + > MRGCEL, MATALB, KEYMRG, INCELL, MATRT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Construct keymrg according to implicit merging imposed by the +* boundary conditions. +* +*Copyright: +* Copyright (C) 1990 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPRT printing level. +* NSUR number of surfaces. +* NVOL number of zones. +* NSBC number of surfaces with independent BC. +* NTOTCL number of cylindres+3. +* INDEX numbering of surfaces and zones. +* MINDIM minimum index values for all axes (rect/cyl). +* MAXDIM maximum index values for all axes (rect/cyl). +* LCLSYM symmetry flags (0: no; -1/+1: syme; -2/+2: ssym). +* LCLTRA translation flags (0: no; -1/+1: tra). +* LL1 diagonal symmetry (2,3). +* LL2 diagonal symmetry (1,4). +* MRGCEL merging cell numbering. +* MATALB material types. +* +*Parameters: input/output +* KEYMRG initial numbering at input, merged at output. +* INCELL block numbering at input, merged at output. +* +*Parameters: output +* MATRT reflection/transmission vector. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +* + INTEGER IPRT, NSUR, NVOL, NSBC, NTOTCL + INTEGER LCLSYM(3), LCLTRA(3), IORD(4), INDEX(4,*), KEYMRG(*), + > MATALB(*), MINDIM(NTOTCL), MAXDIM(NTOTCL), INCELL(*), + > MRGCEL(*), MATRT(-NSUR,2) + LOGICAL LL1, LL2 +* + LOGICAL SWOK, SWSUR, SWSTOP + INTEGER NUM, I, ISUR, ITRA, IVS1, IVS2, ISYM, IORD4, ICC1, + > INDEX4, INCR, NO1, NO2, IB1, IB2, NZSU, NZVO, NZABS, + > NMBLK, IBLK, NZBLK, IMRG, MINV, MAXV, NVOLM, NSURM, + > ICMP1, ICMP2, ITRAC1, NSURC, IP, IR, NVOLC, NMVO + CHARACTER*4 CORIEN(-6:0) + INTEGER IOUT + PARAMETER ( IOUT=6 ) +* + DATA CORIEN + > / ' Z+ ',' Z- ',' Y+ ',' Y- ',' X+ ',' X- ',' ' / +* + NUM(I)= I + 1 - NSUR +* +* INITIALIZE MATRT TO REFLECTION FOR ORIGINAL SURFACES + NVOLM=0 + DO 300 ISUR=1, -NSUR + MATRT(ISUR,1)=0 + MATRT(ISUR,2)=ISUR + 300 CONTINUE +* +* 0) TREAT TRANSLATION SYMMETRIES ************************************* + DO 310 ITRA =1,3 + IF( LCLTRA(ITRA) .EQ. 1) THEN + DO 320 IVS1 = NSUR, -1 + IF( (KEYMRG(NUM(IVS1)) .NE. 0 ) .AND. + > (MATRT(-IVS1,2) .EQ. -IVS1) ) THEN +* +* LOCATE SURFACE IN X, Y, Z AND R + IORD(1)= INDEX(1,NUM(IVS1)) + IORD(2)= INDEX(2,NUM(IVS1)) + IORD(3)= INDEX(3,NUM(IVS1)) + IORD(4)= INDEX(4,NUM(IVS1)) +* +* LOCATE TRANSLATED SURFACE IN X, Y, Z AND R + IF( (IORD(ITRA) .GE. MINDIM(ITRA)) .AND. + > (IORD(ITRA) .LT. MAXDIM(ITRA)) ) GO TO 345 + IORD(ITRA)= (MAXDIM(ITRA)+MINDIM(ITRA))-(IORD(ITRA)+1) +* INDEX(1,NUM(0))= IORD(1) +* INDEX(2,NUM(0))= IORD(2) +* INDEX(3,NUM(0))= IORD(3) +* INDEX(4,NUM(0))= IORD(4) +* +* FOR CYLINDERS, *IORD4* IS ABSOLUTE. + IORD4 = IORD(4) + IF(IORD(4) .NE. 0 )THEN + DO 330 ICC1= NTOTCL, 4, -1 + IF( IORD(4) .LT. MAXDIM(ICC1) )THEN + IORD4 = IORD(4)-MINDIM(ICC1) + ENDIF + 330 CONTINUE + ENDIF + DO 340 IVS2=NSUR,-1 + IF( IORD(1) .EQ. INDEX(1,NUM(IVS2)).AND. + > IORD(2) .EQ. INDEX(2,NUM(IVS2)).AND. + > IORD(3) .EQ. INDEX(3,NUM(IVS2)) ) THEN + INDEX4= INDEX(4,NUM(IVS2)) + IF( IORD(4).NE.0 )THEN + DO 350 ICC1= NTOTCL, 4, -1 + IF( INDEX(4,NUM(IVS2)).LT.MAXDIM(ICC1) )THEN + INDEX4= INDEX(4,NUM(IVS2))-MINDIM(ICC1) + ENDIF + 350 CONTINUE + ENDIF +* +* SYMMETRIC SURFACE LOCATED FOR TRANSMISSION BC +* STORE SURFACES IDENTIFIER IN MATRT AND +* EXIT TO 345 + IF( INDEX4.EQ.IORD4) THEN + MATRT(-IVS1,2)=-IVS2 + MATRT(-IVS2,2)=-IVS1 + GO TO 345 + ENDIF + ENDIF + 340 CONTINUE + CALL XABORT( 'XELMRG: TRANSLATED SURFACE NO FOUND.' ) + ENDIF + 345 CONTINUE + 320 CONTINUE + ENDIF + 310 CONTINUE +* +* 1) TREAT AXIAL SYMMETRIES ****************************************** + DO 20 ISYM= 1, 3 + IF( LCLSYM(ISYM).NE.0 )THEN + DO 10 IVS1= NSUR, NVOL +* +* FOR REGIONS ABSENT FROM FINAL CELL +* DO NOT BOTHER TO SYMMETRIZE + IF( IVS1 .EQ. 0 .OR. KEYMRG(NUM(IVS1)) .EQ. 0) GO TO 10 + IORD(1)= INDEX(1,NUM(IVS1)) + IORD(2)= INDEX(2,NUM(IVS1)) + IORD(3)= INDEX(3,NUM(IVS1)) + IORD(4)= INDEX(4,NUM(IVS1)) +* +* 1.1) RECOMPOSE *ISYM* VALUE TO GET THE SYMMETRIC COORDINATE + IORD(ISYM)= (MAXDIM(ISYM)+MINDIM(ISYM))-(IORD(ISYM)+1) + IF( IVS1.GT.0 )THEN + IVS2= NVOL + INCR= -1 + ELSE + IVS2= NSUR + INCR= +1 + ENDIF +* INDEX(1,NUM(0))= IORD(1) +* INDEX(2,NUM(0))= IORD(2) +* INDEX(3,NUM(0))= IORD(3) +* INDEX(4,NUM(0))= IORD(4) +* +* 1.2) TO SEARCH FOR THE GOOD CYLINDER, *IORD4* IS ABSOLUTE. + IORD4 = IORD(4) + IF( IORD(4).NE.0 )THEN + DO 110 ICC1= NTOTCL, 4, -1 + IF( IORD(4).LT.MAXDIM(ICC1) )THEN + IORD4 = IORD(4)-MINDIM(ICC1) + ENDIF + 110 CONTINUE + ENDIF + 11 CONTINUE + IF( IORD(1).EQ.INDEX(1,NUM(IVS2)).AND. + > IORD(2).EQ.INDEX(2,NUM(IVS2)).AND. + > IORD(3).EQ.INDEX(3,NUM(IVS2)) )THEN + INDEX4= INDEX(4,NUM(IVS2)) + IF( IORD(4).NE.0 )THEN + DO 112 ICC1= NTOTCL, 4, -1 + IF( INDEX(4,NUM(IVS2)).LT.MAXDIM(ICC1) )THEN + INDEX4= INDEX(4,NUM(IVS2))-MINDIM(ICC1) + ENDIF + 112 CONTINUE + ENDIF + IF( INDEX4.EQ.IORD4) GO TO 12 + ENDIF + IVS2= IVS2 + INCR + GO TO 11 + 12 IF( IVS2.EQ.0 )THEN + CALL XABORT( 'XELMRG: RARE AXIAL SYMMETRY PROBLEM.' ) + ENDIF + NO1= KEYMRG(NUM(IVS1)) + NO2= KEYMRG(NUM(IVS2)) + IB1= INCELL(NUM(IVS1)) + IB2= INCELL(NUM(IVS2)) +* +* 1.3) SELECT THE MAX OR MIN VALUE TO CORRECTLY # ZONES + IF( LCLSYM(ISYM).GT.0 )THEN + KEYMRG(NUM(IVS1))= MIN(NO1,NO2) + KEYMRG(NUM(IVS2))= MIN(NO1,NO2) + INCELL(NUM(IVS1))= MIN(IB1,IB2) + INCELL(NUM(IVS2))= MIN(IB1,IB2) + ELSE + KEYMRG(NUM(IVS1))= MAX(NO1,NO2) + KEYMRG(NUM(IVS2))= MAX(NO1,NO2) + INCELL(NUM(IVS1))= MAX(IB1,IB2) + INCELL(NUM(IVS2))= MAX(IB1,IB2) + ENDIF + 10 CONTINUE + ENDIF + 20 CONTINUE +* +* 2) TREAT DIAGONAL SYMMETRIES *************************************** +* (SIDE #3) +* (SIDE #1) GEOM (SIDE #2) +* (SIDE #4) +* + IF( LL1.OR.LL2 )THEN + DO 30 IVS1= NSUR, NVOL +* +* FOR REGIONS ABSENT FROM FINAL CELL +* DO NOT BOTHER TO SYMMETRIZE + IF( IVS1 .EQ. 0 .OR. KEYMRG(NUM(IVS1)) .EQ. 0 ) GO TO 30 +* +* 2.1) FOR (SIDE #1).EQ.(SIDE #4) +* AND (SIDE #2).EQ.(SIDE #3) *** DIAGONAL SYMMETRY (\) *** +* NOTE: ***NOT*** ACCEPTED IN DRAGON. +*** IORD(1)= (MAXDIM(2)+MINDIM(1)) - (INDEX(2,NUM(IVS1))+1) +*** IORD(2)= (MAXDIM(1)+MINDIM(2)) - (INDEX(1,NUM(IVS1))+1) +* 2.2) FOR (SIDE #2).EQ.(SIDE #4) +* AND (SIDE #1).EQ.(SIDE #3) *** DIAGONAL SYMMETRY (/) *** + IORD(1)= INDEX(2,NUM(IVS1)) + MINDIM(1) - MINDIM(2) + IORD(2)= INDEX(1,NUM(IVS1)) + MINDIM(2) - MINDIM(1) + IORD(3)= INDEX(3,NUM(IVS1)) + IORD(4)= INDEX(4,NUM(IVS1)) + IF( IVS1.GT.0 )THEN + IVS2= NVOL + INCR= -1 + ELSE + IVS2= NSUR + INCR= +1 + ENDIF +* INDEX(1,NUM(0))= IORD(1) +* INDEX(2,NUM(0))= IORD(2) +* INDEX(3,NUM(0))= IORD(3) +* INDEX(4,NUM(0))= IORD(4) + IORD4 = IORD(4) + IF( IORD(4).NE.0 )THEN + DO 33 ICC1= NTOTCL, 4, -1 + IF( IORD(4).LT.MAXDIM(ICC1) )THEN + IORD4 = IORD(4)-MINDIM(ICC1) + ENDIF + 33 CONTINUE + ENDIF + 31 CONTINUE + IF( IORD(1).EQ.INDEX(1,NUM(IVS2)).AND. + > IORD(2).EQ.INDEX(2,NUM(IVS2)).AND. + > IORD(3).EQ.INDEX(3,NUM(IVS2)) )THEN + INDEX4= INDEX(4,NUM(IVS2)) + IF( IORD(4).NE.0 )THEN + DO 34 ICC1= NTOTCL, 4, -1 + IF( INDEX(4,NUM(IVS2)).LT.MAXDIM(ICC1) )THEN + INDEX4= INDEX(4,NUM(IVS2))-MINDIM(ICC1) + ENDIF + 34 CONTINUE + ENDIF + IF( INDEX4.EQ.IORD4) GO TO 32 + ENDIF + IVS2= IVS2 + INCR + GO TO 31 + 32 IF( IVS2.EQ.0 )THEN + CALL XABORT( 'XELMRG: RARE DIAGONAL SYMMETRY PROBLEM.' ) + ENDIF + NO1= KEYMRG(NUM(IVS1)) + NO2= KEYMRG(NUM(IVS2)) + IB1= INCELL(NUM(IVS1)) + IB2= INCELL(NUM(IVS2)) +* +* 2.3) SELECT THE MAX OR MIN VALUE TO CORRECTLY # ZONES + IF( LL2 )THEN + KEYMRG(NUM(IVS1))= MIN(NO1,NO2) + KEYMRG(NUM(IVS2))= MIN(NO1,NO2) + INCELL(NUM(IVS1))= MIN(IB1,IB2) + INCELL(NUM(IVS2))= MIN(IB1,IB2) + ELSE + KEYMRG(NUM(IVS1))= MAX(NO1,NO2) + KEYMRG(NUM(IVS2))= MAX(NO1,NO2) + INCELL(NUM(IVS1))= MAX(IB1,IB2) + INCELL(NUM(IVS2))= MAX(IB1,IB2) + ENDIF + 30 CONTINUE + ENDIF +* +* 3) NOW, STOCK NEW INCREASING VALUES IN *KEYMRG* AND *INCELL* ******** + NZSU= 0 + DO 40 IVS1= -1, NSUR,-1 + DO 41 IVS2= -1, NSUR, -1 +* +* 3.1.1) COUNT THE NUMBER OF SURFACES. + IF( KEYMRG(NUM(IVS2)).EQ.IVS1 )THEN + NZSU= NZSU-1 + GO TO 40 + ENDIF + 41 CONTINUE + 40 CONTINUE + NZVO=0 + DO 42 IVS1= 1, NVOL + DO 43 IVS2= 1, NVOL +* +* 3.1.2) COUNT THE NUMBER OF VOLUMES. + IF( KEYMRG(NUM(IVS2)).EQ.IVS1 )THEN + NZVO= NZVO+1 + GO TO 42 + ENDIF + 43 CONTINUE + 42 CONTINUE + NZABS= -1 + DO 50 IVS1= -1, NSUR, -1 + SWOK= .FALSE. + DO 51 IVS2= -1, NSUR, -1 +* +* 3.2.1) RENUMBER SURFACES. + IF( KEYMRG(NUM(IVS2)).EQ.IVS1 )THEN + SWOK= .TRUE. + KEYMRG(NUM(IVS2))= NZABS + ENDIF + 51 CONTINUE + IF( SWOK )THEN + NZABS= NZABS - 1 + ENDIF + 50 CONTINUE + IF( NZABS.NE.NZSU-1 )THEN + CALL XABORT( 'XELMRG: PROBLEMS TO MERGE SURFACES' ) + ENDIF + KEYMRG(NUM(0))= 0 + NZABS= 1 + DO 52 IVS1= 1, NVOL + SWOK= .FALSE. + DO 53 IVS2= 1, NVOL +* +* 3.2.2) RENUMBER VOLUMES. + IF( KEYMRG(NUM(IVS2)).EQ.IVS1 )THEN + SWOK= .TRUE. + KEYMRG(NUM(IVS2))= NZABS + ENDIF + 53 CONTINUE + IF( SWOK )THEN + NZABS= NZABS + 1 + ENDIF + 52 CONTINUE + IF( NZABS.NE.NZVO+1 )THEN + CALL XABORT( 'XELMRG: PROBLEMS TO MERGE VOLUMES' ) + ENDIF + NMBLK= 0 + DO 60 IVS2= NSUR, NVOL +* +* 3.3) COUNT NUMBER OF BLOCKS. + IF( KEYMRG(NUM(IVS2)).NE.0 )THEN + IBLK=INCELL(NUM(IVS2)) + IF( IBLK.NE.0 )THEN + NMBLK=MAX(NMBLK,IBLK) + ENDIF + ENDIF + 60 CONTINUE + NZBLK= 1 + DO 70 IBLK= 1, NMBLK + SWOK= .FALSE. + DO 71 IVS2= NSUR, NVOL +* +* 3.4) RENUMBER BLOCKS. + IF( KEYMRG(NUM(IVS2)).NE.0 )THEN + IF( INCELL(NUM(IVS2)).EQ.IBLK )THEN + SWOK= .TRUE. + INCELL(NUM(IVS2))= NZBLK + ENDIF + ENDIF + 71 CONTINUE + IF( SWOK )THEN + NZBLK= NZBLK + 1 + ENDIF + 70 CONTINUE + NZBLK= NZBLK-1 + IF( NZBLK .LE. 0 .OR. NZBLK .GT. NMBLK)THEN + CALL XABORT( 'XELMRG: PROBLEMS TO MERGE BLOCKS' ) + ENDIF +* +* 3.5) RENUMBER CELL BLOCKS ACCORDING TO THE MERGE INDEX *MRGCEL* +* *** THIS WILL RENUMBER VOLUMES, BUT NOT SURFACES. *** + NMVO = 0 + NMBLK= 1 + SWSTOP= .FALSE. + DO 290 IMRG= 1, NZBLK + SWOK= .FALSE. + DO 280 IBLK=1, NZBLK + IF( MRGCEL(IBLK).EQ.IMRG )THEN + IF( IMRG.NE.NMBLK ) + > CALL XABORT('XELMRG: INCREASING MERGE #ING REQUIRED') + MINV= +100000000 + MAXV= 0 + SWSUR=.FALSE. + DO 210 IVS1= 1, NVOL + IF(KEYMRG(NUM(IVS1)).GT.0) THEN + IF( INCELL(NUM(IVS1)).EQ.IBLK )THEN + MINV= MIN(MINV,KEYMRG(NUM(IVS1))) + MAXV= MAX(MAXV,KEYMRG(NUM(IVS1))) + ENDIF + ENDIF + 210 CONTINUE + IF( SWOK )THEN + SWSTOP= SWSTOP.OR.(NVOLM.NE.MAXV+1-MINV) + ELSE + NVOLM = MAXV+1-MINV + ENDIF + MINV= MINV-NMVO + DO 220 IVS1= 1, NVOL + IF(KEYMRG(NUM(IVS1)).GT.0) THEN + IF( INCELL(NUM(IVS1)).EQ.IBLK )THEN + KEYMRG(NUM(IVS1))= KEYMRG(NUM(IVS1))-(MINV-1) + ENDIF + ENDIF + 220 CONTINUE + SWOK= .TRUE. + ENDIF + 280 CONTINUE + IF( SWOK )THEN + NMVO= NMVO+NVOLM + NMBLK= NMBLK+1 + ENDIF + 290 CONTINUE + NMBLK= NMBLK-1 + NSBC=-NZSU +* +* 4) RESET *MATRT* FOR MERGED SURFACES INSTEAD OF ORIGINAL SURFACES *** + NZSU=0 + DO 360 IVS1=-1,NSUR,-1 + ICMP1=KEYMRG(NUM(IVS1)) + IVS2=-MATRT(-IVS1,2) + ICMP2=KEYMRG(NUM(IVS2)) + IF( (ICMP1 .LT. 0) .AND. (ICMP2 .LT. 0) ) THEN + ITRAC1=MATRT(-ICMP1,1) + IF(ITRAC1 .EQ. 0) THEN + MATRT(-ICMP1,1)=-ICMP2 + MATRT(-ICMP2,1)=-ICMP1 + ENDIF + ENDIF + 360 CONTINUE +* +* 5) PRINTING ********************************************************* + IF( IPRT.GT.2 )THEN + NSURC = -1 + WRITE(IOUT,'(1H )') + WRITE(IOUT,'(/40H SURFACE #ING ( BEFORE CELL MERGE ) )') + DO 580 IP = 1, (9 - NSUR) / 10 + NSURM= MAX( NSUR, NSURC-9 ) + WRITE(IOUT,'(10X,10(A5,I7))') + > (' SUR ',-IR,IR= NSURC, NSURM, -1) + WRITE(IOUT,'(8H ORIENT ,2X,10A12)') + > (CORIEN(MATALB(NUM(IR))),IR=NSURC,NSURM,-1) + WRITE(IOUT,'(8H CELL # ,2X,10I12)') + > (INCELL(NUM(IR)),IR=NSURC,NSURM,-1) + WRITE(IOUT,'(9H MERGE TO ,1X,10(A5,I7))') + > (' SUR ',-KEYMRG(NUM(IR)),IR=NSURC,NSURM,-1) + WRITE(IOUT,'(1H )') + NSURC = NSURC - 10 + 580 CONTINUE + NVOLC= 1 + WRITE(IOUT,'(1H )') + WRITE(IOUT,'( 40H VOLUME #ING ( BEFORE CELL MERGE ) )') + DO 590 IP = 1, (9 + NVOL) / 10 + NVOLM= MIN( NVOL, NVOLC+9 ) + WRITE(IOUT,'(10X,10(A5,I7))') + > (' VOL ',IR,IR=NVOLC,NVOLM, 1) + WRITE(IOUT,'(8H CELL # ,2X,10I12)') + > (INCELL(NUM(IR)),IR=NVOLC,NVOLM, 1) + WRITE(IOUT,'(9H MERGE TO ,1X,10(A5,I7))') + > (' VOL ', KEYMRG(NUM(IR)),IR=NVOLC,NVOLM, 1) + WRITE(IOUT,'(8H MIX ,2X,10I12)') + > (MATALB(NUM(IR)),IR=NVOLC,NVOLM, 1) + WRITE(IOUT,'(9H ,1X,10(A5,I7))') + > (' CELL',MRGCEL(INCELL(NUM(IR))),IR=NVOLC,NVOLM, 1) + WRITE(IOUT,'(1H )') + NVOLC = NVOLC + 10 + 590 CONTINUE + WRITE(IOUT,'( 40H BC MATRIX (BEFORE MERGE) )') + WRITE(IOUT,'(8(5X,I10,I10))') (IR,MATRT(IR,2),IR=1,-NSUR) + WRITE(IOUT,'( 40H BC MATRIX (AFTER MERGE) )') + WRITE(IOUT,'(8(5X,I10,I10))') (IR,MATRT(IR,1),IR=1,NSBC) + ELSEIF( IPRT.GT.1 )THEN + WRITE(IOUT,'(1H )') + WRITE(IOUT,'(32H # OF SURFACES AFTER SYMMETRIES: ,I8)') -NZSU + WRITE(IOUT,'(32H # OF ZONES AFTER SYMMETRIES: ,I8)') NZVO + WRITE(IOUT,'(32H # OF CELLS AFTER SYMMETRIES: ,I8)') NZBLK + WRITE(IOUT,'(1H )') + WRITE(IOUT,'(32H # OF ZONES AFTER MERGING : ,I8)') NMVO + WRITE(IOUT,'(32H # OF CELLS AFTER MERGING : ,I8)') NMBLK + WRITE(IOUT,'(1H )') + ENDIF + IF( SWSTOP )THEN + CALL XABORT('XELMRG: MERGE CELL ONLY WITH SAME # OF ZONES') + ENDIF +* + RETURN + END diff --git a/Dragon/src/XELNTR.f b/Dragon/src/XELNTR.f new file mode 100644 index 0000000..af747b5 --- /dev/null +++ b/Dragon/src/XELNTR.f @@ -0,0 +1,609 @@ +*DECK XELNTR + SUBROUTINE XELNTR( NDIM, IFOLD, IFTRAK, NORE, LMERG, + > IPRT, NS, NV, VOLIN, MATIN, + > MRGIN, NSOUT, NVOUT, VOLOUT, MATOUT, + > CUTOFX, ITGEO, ICODE, ALBEDO, NANGL, + > KIN, LIN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute renormalized tracks to obtain true volume values. The file +* IFOLD contains the old tracks while the file IFTRAK will contain the +* normalized tracks. +* +*Copyright: +* Copyright (C) 1991 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* NDIM number of dimensions. +* IFOLD unnormalized tracking file number (at input). +* IFTRAK normalized tracking file number (at output). +* NORE integer flag for normalization: +* -1 normalize to volume (angle dependent); +* 0 normalize to volume (angle independent); +* 1 do not normalize. +* LMERG second integer flag for normalization: +* 0 preserve volumes of fine regions; +* 1 preserve volumes of merged regions . +* IPRT intermediate printing level for prinout. +* NS number of surfaces before merging. +* NV number of zones before merging. +* VOLIN volumes and surfaces before merging. +* MATIN material numbers before merging. +* MRGIN merging index. +* NSOUT number of surfaces after merging. +* NVOUT number of zones after merging. +* VOLOUT volumes and surfaces after merging. +* MATOUT material numbers before merging. +* CUTOFX cutoff factor. +* ITGEO kind of geometry. +* ICODE index of boundary conditions. +* NANGL number of angles to renormalize tracks by angle. +* KIN max. number of subtracks in a single track. +* LIN max. number of track segments in a single track. +* +*Parameters: output +* ALBEDO geometric albedos on external faces. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +* + INTEGER NDIM,IFOLD,IFTRAK,NORE,LMERG,IPRT,NS,NV, + > MATIN(-NS:NV),MRGIN(-NS:NV),NSOUT,NVOUT, + > MATOUT(-NSOUT:NVOUT),ITGEO,ICODE(6),NANGL, + > KIN,LIN + INTEGER IANG,IC,IL,IP,IR,ISPEC,ITRAK,IVS,IVSC,JR, + > LINE,MNSUR,MXSUB,MXSEG,MXVOL,NANG2,NBTRK, + > NCOMNT,IOUT,JL,NALBG,NCOR,NSCRP,NSURC,NSURM, + > NVOLC,NVOLM,NTMP,NSREN,NVREN,IPREN,NCSEG, + > NOLDS,NNEWS,IFMT,II,NSUB,IND,IREG,IVSMAX(2) + REAL ERRCUR + REAL VOLIN(-NS:NV),VOLOUT(-NSOUT:NVOUT), + > ASCRP,ALBEDO(6),ERRSUR,ERRVOL,CUTOFX,VOLMIN, + > TMPERR(10),ERRVM,ERRSM + DOUBLE PRECISION APRSUR,APRVOL,TOTVOL,TOTSUR,ZERO,ONE,TWO, + > FOUR,HALF,QUART,HUND,PI,FACVOL,FACSUR,VOLREF, + > AVGREN,WEIGHT,RCUT,DASCRP + LOGICAL LNEW + CHARACTER CTRK*4, COMENT*80, CORIEN(0:3,-6:0)*4 + PARAMETER ( PI=3.14159265358979323846D0, IOUT=6, + > ZERO=0.D0, ONE=1.D0, TWO=2.D0, FOUR=4.D0, + > HUND=1.D2, HALF=0.5D0, QUART=0.25D0 ) + INTEGER, ALLOCATABLE, DIMENSION(:) :: NRSEG,KANGL + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DENSTY + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: PATH + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: ANGLES + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: VOLTRK + DATA ((CORIEN(JR,IR),IR=-6,0),JR=0,3) + > / ' 6 ',' 5 ',' 4 ',' 3 ',' 2 ',' 1 ',' ', + > ' Z+ ',' Z- ','****','****',' R+ ','****',' ', + > ' Z+ ',' Z- ','****','****','****','HBC ',' ', + > ' Z+ ',' Z- ',' Y+ ',' Y- ',' X+ ',' X- ',' '/ +*---- +* SCRATCH STORAGE ALLOCATION +* VOLTRK: volumes & surfaces as computed by tracking. +* ANGLES: x,y,z components of angles. +* DENSTY: weights by angle. +* PATH : relative path of each segment in a track. +* NRSEG : material identification in a track. +*---- + ALLOCATE(KANGL(KIN),NRSEG(LIN)) + ALLOCATE(ANGLES(3,NANGL),DENSTY(NANGL),PATH(LIN)) + ALLOCATE(VOLTRK(-NS:NV,0:NANGL)) +* +* READ FIRST RECORDS OF THE TRACKING FILE + READ (IFOLD ) CTRK,NCOMNT,NSCRP,NSCRP + DO 5 IC= 1, NCOMNT + READ (IFOLD ) COMENT + 5 CONTINUE + READ (IFOLD ) NSCRP,ISPEC,NSCRP,NSCRP,NALBG,NCOR,NSCRP,NSCRP,NSCRP + IF( NALBG.LE.0.OR.NALBG.GT.6 )THEN + CALL XABORT('XELNTR: NALBG.GT.6.OR.NALBG.LE.0'// + > ' ON TRACKING FILE') + ENDIF + READ (IFOLD ) (ASCRP,IR=-NS,NV) + READ (IFOLD ) (NSCRP,IR=-NS,NV) + READ (IFOLD ) (NSCRP, IR=1,NALBG) + READ (IFOLD ) (ALBEDO(IR),IR=1,NALBG) + READ (IFOLD ) ((ANGLES(IR,JR),IR=1,NDIM),JR=1,NANGL) + READ (IFOLD ) (DENSTY(JR),JR=1,NANGL) +* + FACSUR= 0.0D0 + FACVOL= TWO + IF( ISPEC.EQ.0 )THEN + IF( NDIM.EQ.2 )THEN + FACSUR= QUART*PI + ELSEIF( NDIM.EQ.3 )THEN + FACSUR= ONE + ENDIF + ELSEIF( ISPEC.EQ.1 )THEN + IF( NDIM.EQ.2 )THEN + FACSUR= HALF*PI + ELSEIF( NDIM.EQ.3 )THEN + FACSUR= ONE + ENDIF + ENDIF +* +* INITIALIZE NORMALIZED FACTORS +* NORE = -1 -> ANGLE DEPENDENT NORMALIZATION +* = 0 -> ANGLE INDEPENDENT NORMALIZATION +* = 1 -> NO NORMALIZE BUT FIND TRACK ERROR ON MERGED VOLUME +* LMERG = 0 -> NORMALIZATION PRESERVE FINE VOLUMES +* = 1 -> NORMALIZATION PRESERVE MERGED VOLUMES FROM KEYMRG + NSREN=NSOUT + NVREN=NVOUT + IF(LMERG.EQ.0) THEN + NSREN=NS + NVREN=NV + ENDIF + DO 10 IVS= -NSREN, NVREN + DO 11 IANG= 0, NANGL + VOLTRK(IVS,IANG)= ZERO + 11 CONTINUE + 10 CONTINUE +* +* COMPUTE CUTOFF FOR LINE RELATIVE TO MERGED VOLUME + VOLMIN=VOLOUT(1) + DO 12 IVS= 2, NVOUT + VOLMIN= MIN(VOLMIN,VOLOUT(IVS)) + 12 CONTINUE + RCUT= VOLMIN*CUTOFX + IF( IPRT.GE.999 )THEN + WRITE(IOUT,'(11X,A32,F20.15)') + > 'CUTOFF FACTOR FOR LINES = ',RCUT + ENDIF +* +* LOOP OVER TRACKING (UNNORMALIZED TRACKS) +* AND COMPUTE VOLUME OF TRACK + NBTRK= 0 + MXSUB= 0 + MXSEG= 0 + IF( IPRT .GE. 999 ) THEN + WRITE(IOUT,'(A22)') 'INITIAL line segments ' + ENDIF + 20 CONTINUE + READ(IFOLD,END=40) NSUB,LINE,WEIGHT, + > (KANGL(II),II=1,NSUB), + > (NRSEG(IL),IL=1,LINE), + > (PATH(IL),IL=1,LINE) + IF( NSUB.GT.KIN )THEN + WRITE(IOUT,'(11X,A32,I20)') + > 'NUMBER OF SUBTRACKS IN LINE = ',NSUB + WRITE(IOUT,'(11X,A32,I20)') + > 'MAXIMUM NUMBER OF SUBTRACKS = ',KIN + CALL XABORT( 'XELNTR: TRACKING FILE CORRUPTED' ) + ELSE IF( LINE.GT.LIN )THEN + WRITE(IOUT,'(11X,A32,I20)') + > 'NUMBER OF ELEMENTS IN LINE = ',LINE + WRITE(IOUT,'(11X,A32,I20)') + > 'MAXIMUM NUMBER OF ELEMENTS = ',LIN + CALL XABORT( 'XELNTR: TRACKING FILE CORRUPTED' ) + ENDIF + MXSUB= MAX(MXSUB,NSUB) + MXSEG= MAX(MXSEG,LINE) + IF(ISPEC.EQ.1) THEN +* ANGULAR-DEPENDENT INTEGRATION OF A CYCLIC MULTI-TRACK + IND=0 + LNEW=.TRUE. + DO 31 IL=1,LINE + IREG=NRSEG(IL) + IF(LMERG.EQ.0) THEN + IPREN=IREG + ELSE + IPREN=MRGIN(IREG) + ENDIF + IF(IREG.GT.0) THEN + IF(LNEW) THEN + IND=IND+1 + IF(IND.GT.NSUB) CALL XABORT('XELNTR: NSUB OVERFLOW') + LNEW=.FALSE. + ENDIF + IANG=KANGL(1) + VOLTRK(IPREN,IANG)= VOLTRK(IPREN,IANG) + WEIGHT*PATH(IL) + ELSE + LNEW=.TRUE. + IANG=KANGL(1) + VOLTRK(IPREN,IANG)= VOLTRK(IPREN,IANG) + WEIGHT*PATH(IL) + ENDIF + 31 CONTINUE + IF(IND.NE.NSUB) CALL XABORT('XELNTR: ALGORITHM FAILURE') + ELSE + DO 32 IL = 1, LINE + IF(LMERG.EQ.0) THEN + IPREN=NRSEG(IL) + ELSE + IPREN=MRGIN(NRSEG(IL)) + ENDIF + IANG=KANGL(1) + VOLTRK(IPREN,IANG)= VOLTRK(IPREN,IANG) + WEIGHT*PATH(IL) + 32 CONTINUE + ENDIF + NBTRK= NBTRK + 1 + IF( IPRT .GE. 999 ) THEN + WRITE(IOUT,6100) NBTRK,IANG,LINE,WEIGHT,WEIGHT/DENSTY(IANG) + WRITE(IOUT,6101) + > (PATH(JL),NRSEG(JL),MRGIN(NRSEG(JL)),JL=1,LINE) + ENDIF + GO TO 20 +* +* COMPUTE TRACK NORMALIZATION FACTOR + 40 CONTINUE + DO 47 IVS= -NSREN, NVREN + IF(LMERG.EQ.0) THEN + VOLREF=DBLE(VOLIN(IVS)) + ELSE + VOLREF=DBLE(VOLOUT(IVS)) + ENDIF + DO 46 IANG= 1, NANGL + VOLTRK(IVS,0)= VOLTRK(IVS,0) + VOLTRK(IVS,IANG) + VOLTRK(IVS,IANG)= VOLTRK(IVS,IANG)*DENSTY(IANG) + IF( VOLTRK(IVS,IANG).NE.ZERO )THEN + VOLTRK(IVS,IANG)= VOLREF/VOLTRK(IVS,IANG) + ELSE + VOLTRK(IVS,IANG)= ONE + ENDIF + 46 CONTINUE + 47 CONTINUE + IF(NORE .EQ. 0) THEN + DO 48 IVS= 1, NVREN + AVGREN=DBLE(VOLOUT(IVS))/(VOLTRK(IVS,0)*FACVOL) + DO 44 IANG= 1, NANGL + VOLTRK(IVS,IANG)=AVGREN + 44 CONTINUE + 48 CONTINUE + ENDIF +* +* COMPUTE ERRORS ON VOLUMES + TOTSUR=ZERO + APRSUR=ZERO + TOTVOL=ZERO + APRVOL=ZERO + ERRSM=0.0 + ERRVM=0.0 + IVSMAX(1)=0 + IVSMAX(2)=0 + IVSC=0 + DO 50 IVS= -NSREN, NVREN + IF( LMERG.EQ.0 )THEN + VOLREF=DBLE(VOLIN(IVS)) + ELSE + VOLREF=DBLE(VOLOUT(IVS)) + ENDIF + IF( VOLTRK(IVS,0).EQ.ZERO .AND. VOLREF.GT.ZERO )THEN + IF( IVS.LT.0 )THEN + IF( LMERG.EQ.0 )THEN + WRITE(IOUT,9010) IVS + ELSE + WRITE(IOUT,9011) IVS + ENDIF + ELSEIF( IVS.GT.0 )THEN + IF( LMERG.EQ.0 )THEN + WRITE(IOUT,9000) IVS + ELSE + WRITE(IOUT,9001) IVS + ENDIF + ENDIF + IVSC=IVS + ENDIF + IF( IVS.LT.0 )THEN + VOLTRK(IVS,0)= FACSUR*VOLTRK(IVS,0) + IF( VOLIN(IVS).NE.0.0 )THEN + ERRCUR=REAL(100.0*ABS(1.0-VOLTRK(IVS,0)/VOLREF)) + IF(ERRCUR .GT. ERRSM) THEN + IVSMAX(1)=IVS + ERRSM=ERRCUR + ENDIF + ENDIF + TOTSUR=TOTSUR+VOLREF + APRSUR=APRSUR+VOLTRK(IVS,0) + ELSEIF( IVS.GT.0 )THEN + VOLTRK(IVS,0)= FACVOL*VOLTRK(IVS,0) + TOTVOL=TOTVOL+VOLREF + APRVOL=APRVOL+VOLTRK(IVS,0) + IF( VOLREF.NE.ZERO )THEN + ERRCUR=REAL(100.0*ABS(1.0-VOLTRK(IVS,0)/VOLREF)) + IF(ERRCUR .GT. ERRVM) THEN + IVSMAX(2)=IVS + ERRVM=ERRCUR + ENDIF + ENDIF + ENDIF + 50 CONTINUE + ERRSUR=100.*(1.0-REAL(APRSUR/TOTSUR)) + ERRVOL=100.*(1.0-REAL(APRVOL/TOTVOL)) +* +* CONSTRUCT THE NEW TRACKING FILE + REWIND IFOLD + READ (IFOLD ) CTRK,NSCRP,NSCRP,IFMT + WRITE(IFTRAK) CTRK,NCOMNT,NBTRK,IFMT + DO 55 IC= 1, NCOMNT + READ (IFOLD ) COMENT + WRITE(IFTRAK) COMENT + 55 CONTINUE + READ (IFOLD ) (NSCRP,IR=1,9) + WRITE(IFTRAK) NDIM,ISPEC,NVOUT,NSOUT,NALBG,NCOR,NANGL,MXSUB,MXSEG + READ (IFOLD ) (ASCRP, IR=-NS,NV) + WRITE(IFTRAK) (VOLOUT(IR),IR=-NSOUT,NVOUT) + READ (IFOLD ) (NSCRP, IR=-NS,NV) + WRITE(IFTRAK) (MATOUT(IR),IR=-NSOUT,NVOUT) + READ (IFOLD ) (NSCRP, IR=1,NALBG) + WRITE(IFTRAK) ( ICODE(IR),IR=1,NALBG) + READ (IFOLD ) (ASCRP, IR=1,NALBG) + WRITE(IFTRAK) (ALBEDO(IR),IR=1,NALBG) + READ (IFOLD ) ((DASCRP, IR=1,NDIM ),JR=1,NANGL) + WRITE(IFTRAK) ((ANGLES(IR,JR),IR=1,NDIM),JR=1,NANGL) + READ (IFOLD ) (DASCRP, JR=1,NANGL) + WRITE(IFTRAK) (DENSTY(JR),JR=1,NANGL) + IF( IPRT .GE. 999 ) THEN + WRITE(IOUT,'(A22)') 'FINAL line segments ' + ENDIF + DO 70 ITRAK=1, NBTRK + READ(IFOLD) NSUB,LINE,WEIGHT, + > (KANGL(II),II=1,NSUB), + > (NRSEG(IL),IL=1,LINE), + > (PATH(IL),IL=1,LINE) + IF(NSUB.GT.MXSUB) CALL XABORT('XELNTR: MXSUB overflow.') + IF(RCUT .GT. 0.0)THEN + IL= 0 + 23 CONTINUE + IF(IL.EQ.LINE) GO TO 25 + IL= IL+1 + IF(PATH(IL).LT.RCUT)THEN + IF(IL.NE.LINE)THEN + DO 24 JL= IL+1, LINE + NRSEG(JL-1)= NRSEG(JL) + PATH(JL-1)= PATH(JL) + 24 CONTINUE + ELSE + LINE= LINE-1 + GO TO 25 + ENDIF + LINE= LINE-1 + IL= IL-1 + ENDIF + GO TO 23 + 25 CONTINUE + ENDIF +* +* RENORMALIZE TRACK LENGHTS + IF((NORE.EQ.-1) .AND. (NSUB.GT.1) ) THEN +* ANGULAR-DEPENDENT NORMALIZATION OF A CYCLIC MULTI-TRACK + IND=0 + LNEW=.TRUE. + DO 56 IL=1,LINE + IREG=NRSEG(IL) + IF(LMERG.EQ.0) THEN + IPREN=IREG + ELSE + IPREN=MRGIN(IREG) + ENDIF + IF(IREG.GT.0) THEN + IF(LNEW) THEN + IND=IND+1 + IF(IND.GT.NSUB) CALL XABORT('XELNTR: NSUB overflow') + LNEW=.FALSE. + ENDIF + IANG=KANGL(1) + PATH(IL)= VOLTRK(IPREN,IANG) * PATH(IL) + ELSE + LNEW=.TRUE. + ENDIF + 56 CONTINUE + IF(IND.NE.NSUB) CALL XABORT('XELNTR: Algorithm failure') + ELSE IF(NORE.LT.1 ) THEN + DO 60 IL = 1, LINE + IF( NRSEG(IL).GT.0 )THEN + IF(LMERG.EQ.0) THEN + IPREN=NRSEG(IL) + ELSE + IPREN=MRGIN(NRSEG(IL)) + ENDIF + IANG=KANGL(1) + PATH(IL)= VOLTRK(IPREN,IANG) * PATH(IL) + ENDIF + 60 CONTINUE + ENDIF +* +* CHANGE #ING ACCORDING TO MERGES + DO 65 IL = 1, LINE + NRSEG(IL)= MRGIN(NRSEG(IL)) + 65 CONTINUE +* +* START MODIFICATIONS 98/06/02 +* COMPRESS TRACKING FILE FOR SUCCESSIVE IDENTICAL REGIONS + NOLDS=NRSEG(1) + NCSEG=1 + DO 66 IL = 2, LINE + NNEWS=NRSEG(IL) + IF( NNEWS.LT.0 .OR. NNEWS.NE.NOLDS )THEN + NOLDS=NNEWS + NCSEG=NCSEG+1 + NRSEG(NCSEG)=NRSEG(IL) + PATH(NCSEG)=PATH(IL) + ELSEIF( NNEWS.EQ.NOLDS )THEN + PATH(NCSEG)=PATH(NCSEG)+PATH(IL) + ENDIF + 66 CONTINUE + WRITE(IFTRAK) NSUB,NCSEG,WEIGHT, + > (KANGL(II),II=1,NSUB), + > (NRSEG(IL),IL=1,NCSEG), + > (PATH(IL),IL=1,NCSEG) + IF( IPRT.GE.999 ) THEN + WRITE(IOUT,'(2H #,I8,12H WRITE IANG=,I8,5H LEN=,I8)') + > ITRAK, IANG, NCSEG + WRITE(IOUT,'(1P,(1X,E15.6,1X,I8))' ) + > (PATH(JL),NRSEG(JL),JL=1,NCSEG) + ENDIF +* END MODIFICATIONS 98/06/02 +* + 70 CONTINUE + IF(IPRT .GE. 5) THEN + MNSUR = -NSREN + MXVOL = NVREN + NSURC = -1 + WRITE(IOUT,'(1H )') + WRITE(IOUT,7000) ERRSUR,ERRSM + WRITE(IOUT,7005) -IVSMAX(1),4.0*VOLTRK(IVSMAX(1),0) + DO 80 IP = 1, (9 - MNSUR) / 10 + NSURM= MAX( MNSUR, NSURC-9 ) + WRITE(IOUT,7100)(' FACE',-IR,IR=NSURC,NSURM,-1) + IF(LMERG.EQ.0) THEN + WRITE(IOUT,7110) + > (4.*VOLIN(IR),IR=NSURC,NSURM,-1) + WRITE(IOUT,7111) + > (CORIEN(ITGEO,MATIN(IR)),IR=NSURC,NSURM,-1) + ELSE + WRITE(IOUT,7110) + > (4.*VOLOUT(IR),IR=NSURC,NSURM,-1) + WRITE(IOUT,7111) + > (CORIEN(ITGEO,MATOUT(IR)),IR=NSURC,NSURM,-1) + ENDIF + WRITE(IOUT,7101) (FOUR*VOLTRK(IR,0),IR=NSURC,NSURM,-1) + NTMP=0 + DO 81 IR=NSURC,NSURM,-1 + IF(LMERG.EQ.0) THEN + VOLREF=DBLE(VOLIN(IR)) + ELSE + VOLREF=DBLE(VOLOUT(IR)) + ENDIF + NTMP=NTMP+1 + IF(VOLREF.NE.ZERO) THEN + TMPERR(NTMP)=REAL(HUND-HUND*VOLTRK(IR,0)/VOLREF) + ELSE + TMPERR(NTMP)=0.0 + ENDIF + 81 CONTINUE + WRITE(IOUT,7102) (TMPERR(IR),IR=1,NTMP) + IF(LMERG.EQ.0) THEN + WRITE(IOUT,7103) (' FACE',-MRGIN(IR),IR=NSURC,NSURM,-1) + ENDIF + WRITE(IOUT,7104) + NSURC = NSURC - 10 + 80 CONTINUE + NVOLC= 1 + WRITE(IOUT,'(1H )') + WRITE(IOUT,7001) ERRVOL,ERRVM + WRITE(IOUT,7006) IVSMAX(2),VOLTRK(IVSMAX(2),0) + DO 90 IP = 1, (9 + MXVOL) / 10 + NVOLM= MIN( MXVOL, NVOLC+9 ) + WRITE(IOUT,7100) (' ZONE',IR,IR=NVOLC,NVOLM) + IF(LMERG.EQ.0) THEN + WRITE(IOUT,7120) + > (VOLIN(IR),IR=NVOLC,NVOLM) + WRITE(IOUT,7121) + > (' MIX ', MATIN(IR),IR=NVOLC,NVOLM) + ELSE + WRITE(IOUT,7120) + > (VOLOUT(IR),IR=NVOLC,NVOLM) + WRITE(IOUT,7121) + > (' MIX ', MATOUT(IR),IR=NVOLC,NVOLM) + ENDIF + WRITE(IOUT,7101) (VOLTRK(IR,0),IR=NVOLC,NVOLM) + NTMP=0 + DO 91 IR= NVOLC,NVOLM + IF(LMERG.EQ.0) THEN + VOLREF=DBLE(VOLIN(IR)) + ELSE + VOLREF=DBLE(VOLOUT(IR)) + ENDIF + NTMP=NTMP+1 + IF(VOLREF.NE.ZERO) THEN + TMPERR(NTMP)=REAL(HUND-HUND*VOLTRK(IR,0)/VOLREF) + ELSE + TMPERR(NTMP)=0.0 + ENDIF + 91 CONTINUE + WRITE(IOUT,7102) (TMPERR(IR),IR=1,NTMP) + IF(LMERG.EQ.0) THEN + WRITE(IOUT,7103) (' ZONE',MRGIN(IR),IR=NVOLC,NVOLM) + ENDIF + WRITE(IOUT,7104) + NVOLC = NVOLC + 10 + 90 CONTINUE + IF(IPRT .GT. 5)THEN + NVOLC= 1 + NANG2= NANGL+2 + WRITE(IOUT,'(1H )') + IF( NORE.EQ.0 )THEN + WRITE(IOUT,7004) + ELSEIF(NORE.EQ.-1) THEN + WRITE(IOUT,7002) + ELSEIF(NORE.EQ.1) THEN + WRITE(IOUT,7003) + ENDIF + DO 110 IP = 1, (9 + MXVOL) / 10 + NVOLM= MIN( MXVOL, NVOLC+9 ) + WRITE(IOUT,7100) (' VOL ',IR,IR=NVOLC,NVOLM) + IF(NORE .EQ. -2 ) THEN + IANG=1 + WRITE(IOUT,7131) + > (VOLTRK(IR,IANG),IR=NVOLC,NVOLM) + ELSE + DO 100 IANG= 1, NANGL + WRITE(IOUT,7130) IANG, + > (VOLTRK(IR,IANG),IR=NVOLC,NVOLM) + 100 CONTINUE + ENDIF + WRITE(IOUT,7104) + NVOLC = NVOLC + 10 + 110 CONTINUE + ENDIF + ELSE IF(IPRT .GE. 1) THEN + WRITE(IOUT,'(1H )') + WRITE(IOUT,7000) ERRSUR,ERRSM + WRITE(IOUT,7005) -IVSMAX(1),4.0*VOLTRK(IVSMAX(1),0) + WRITE(IOUT,'(1H )') + WRITE(IOUT,7001) ERRVOL,ERRVM + WRITE(IOUT,7006) IVSMAX(2),VOLTRK(IVSMAX(2),0) + ENDIF + IF( IVSC.NE.0 )THEN + WRITE(IOUT,9020) + CALL XABORT( 'XELNTR: CHECK NUMBERING OR USE FINER TRACKING') + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(VOLTRK,NRSEG,KANGL,PATH,DENSTY,ANGLES) + RETURN +*---- +* Formats +*---- + 6100 FORMAT(1X,'TRACK # ',I8,3X,'ANGLE ',I8, + > 1X,'WITH ',I8,1X,'SEGMENTS', + > 3X,'TOTAL WEIGHT =',1P,E15.6,3X,'VOLUME WEIGHT =',E15.6) + 6101 FORMAT(1P,(1X,E15.6,1X,2I8)) + 7000 FORMAT(/' TRACKING ERRORS ON SURFACE AVERAGE ERROR: ',F10.4, + > ' % ',5X,'MAXIMUM ERROR: ',F10.4,' % ') + 7001 FORMAT( ' TRACKING ERRORS ON VOLUME AVERAGE ERROR: ',F10.4, + > ' % ',5X,'MAXIMUM ERROR: ',F10.4,' % ') + 7002 FORMAT(/' ANGLE-BY-ANGLE RENORMALIZATION FACTORS: '/) + 7003 FORMAT(/' ANGLE-BY-ANGLE RENORMALIZATION FACTORS (NOT USED): '/) + 7004 FORMAT(/' GLOBAL RENORMALIZATION FACTORS: '/) + 7005 FORMAT(' MAXIMUM ERROR ON SURFACE=',I8,' WITH AREA =',1P,E11.4) + 7006 FORMAT(' MAXIMUM ERROR IN REGION =',I8,' WITH VOLUME=',1P,E11.4) + 7100 FORMAT(10X,10(A5,I7)) + 7101 FORMAT(' APPROX ',1P,10E12.4) + 7102 FORMAT(' ERR(%) ',10F12.5) + 7103 FORMAT(' MERGE TO ',10(A5,I7)) + 7104 FORMAT(' ') + 7110 FORMAT(' SURFACE ',1P,10E12.4) + 7111 FORMAT(' SIDE ',10(A4,8X)) + 7120 FORMAT(' VOLUME ',1P,10E12.4) + 7121 FORMAT(' MIXTURE ',10(A4,1X,I7)) + 7130 FORMAT(' ANG ',I4,1X,1P,10E12.4) + 7131 FORMAT(10X,1P,10E12.4) +* + 9000 FORMAT(' *** WARNING - ORIGINAL VOLUME # ',I10,' NOT TRACKED ') + 9001 FORMAT(' *** WARNING - MERGED VOLUME # ',I10,' NOT TRACKED ') + 9010 FORMAT(' *** WARNING - ORIGINAL SURFACE # ',I10,' NOT TRACKED ') + 9011 FORMAT(' *** WARNING - MERGED SURFACE # ',I10,' NOT TRACKED ') + 9020 FORMAT(' *** ERROR - ONE MERGED VOLUME OR SURFACE NOT TRACKED') + END diff --git a/Dragon/src/XELPR3.f b/Dragon/src/XELPR3.f new file mode 100644 index 0000000..95f25f9 --- /dev/null +++ b/Dragon/src/XELPR3.f @@ -0,0 +1,164 @@ +*DECK XELPR3 + SUBROUTINE XELPR3(IPTRK,IZ,NZP) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Create 2D projection (EXCELT geometry analysis) of a 3D prismatic +* geometry. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IPTRK pointer to the excell tracking (L_TRACK). +* IZ projection axis. +* +*Parameters: output +* NZP number of IZ-plans. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER IZ,NZP +*---- +* LOCAL VARIABLES +*---- + INTEGER NSTATE,IOUT + PARAMETER(NSTATE=40,IOUT=6) + INTEGER GSTATE(NSTATE),ESTATE(NSTATE),ICODE(6),NCODE(6),KSIGN(3), + 1 KTYPE(3),LCLSYM(3) + INTEGER IX,IY,NDIM,N3MS,N3MR,LDIM,LMESH,N3RS,I,N2MS,N2MR, + 1 N2RS,N3R,N3S,NFI + REAL ALBEDO(6) + INTEGER, ALLOCATABLE, DIMENSION(:) :: MINDIM,MAXDIM,ICORD,MATALB, + 1 KEYMRG,INDEX,MIN2,MAX2,ICOR2,MAT2,KEY2,IND2,IND2T3,MATMRG + REAL, ALLOCATABLE, DIMENSION(:) :: REMESH,VOLSUR,REM2,VOL2,ZCOR, + 1 VOLMRG +*--- + IF (IZ.EQ.3) THEN + IX=1 + IY=2 + ELSEIF (IZ.EQ.2) THEN + IX=3 + IY=1 + ELSEIF (IZ.EQ.1) THEN + IX=2 + IY=3 + ELSE + CALL XABORT('XELPR3: ILLEGAL PROJECTION AXIS') + ENDIF +*--- +* RECOVER INFORMATION FROM EXCELL 3D GEOMETRY ANALYSIS +*--- + CALL LCMGET(IPTRK,'SIGNATURE',KSIGN) + CALL LCMGET(IPTRK,'TRACK-TYPE',KTYPE) + GSTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,'STATE-VECTOR',GSTATE) + CALL LCMGET(IPTRK,'ICODE',ICODE) + CALL LCMGET(IPTRK,'NCODE',NCODE) + CALL LCMPUT(IPTRK,'NCODE',6,1,NCODE) + CALL LCMGET(IPTRK,'ALBEDO',ALBEDO) + CALL LCMSIX(IPTRK,'EXCELL',1) + ESTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,'STATE-VECTOR',ESTATE) + NDIM=ESTATE(1) + IF (NDIM.NE.3) + 1 CALL XABORT('XELPR3: NON 3D GEOMETRY') + N3MS=ESTATE(2) + N3MR=ESTATE(3) + LDIM=ESTATE(4) + LMESH=ESTATE(5) + N3RS=ESTATE(6) + LCLSYM(1)=ESTATE(8) + LCLSYM(2)=ESTATE(9) + LCLSYM(3)=ESTATE(10) + ALLOCATE(MINDIM(LDIM),MAXDIM(LDIM),ICORD(LDIM),MATALB(N3RS), + 1 KEYMRG(N3RS),INDEX(4*N3RS)) + ALLOCATE(REMESH(LMESH),VOLSUR(N3RS)) + CALL LCMGET(IPTRK,'MINDIM',MINDIM) + CALL LCMGET(IPTRK,'MAXDIM',MAXDIM) + CALL LCMGET(IPTRK,'ICORD',ICORD) + CALL LCMGET(IPTRK,'REMESH',REMESH) + CALL LCMGET(IPTRK,'VOLSUR',VOLSUR) + CALL LCMGET(IPTRK,'MATALB',MATALB) + CALL LCMGET(IPTRK,'KEYMRG',KEYMRG) + CALL LCMGET(IPTRK,'INDEX',INDEX) + CALL LCMSIX(IPTRK,' ',2) +*--- +* CHECK FOR CYLINDER ORIENTATION +*--- + IF (LDIM.GT.3) THEN + DO I=3,LDIM-1 + IF (ICORD(I+1).NE.IZ) + 1 CALL XABORT('XELPR3: NON Z-PRISMATIC GEOMETRY') + ENDDO + ENDIF +*--- +* CONSTRUCT 2D GEOMETRY ANALYSIS AND (2D,Z)->3D INDEX +*--- + CALL LCMSIX(IPTRK,'PROJECTION',1) + CALL LCMPUT(IPTRK,'SIGNATURE',3,3,KSIGN) + CALL LCMPUT(IPTRK,'TRACK-TYPE',3,3,KTYPE) + NZP=MAXDIM(IZ)-MINDIM(IZ) + N2MR=N3MR/NZP + N2MS=(N3MS-2*N2MR)/NZP + N2RS=N2MR+N2MS+1 + GSTATE(1)=N2MR + GSTATE(2)=N2MR + GSTATE(5)=N2MS + GSTATE(7)=1 + GSTATE(8)=1 + CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,GSTATE) + CALL LCMPUT(IPTRK,'ICODE',6,1,ICODE) + CALL LCMPUT(IPTRK,'NCODE',6,1,NCODE) + CALL LCMPUT(IPTRK,'ALBEDO',6,2,ALBEDO) + CALL LCMSIX(IPTRK,'EXCELL',1) + ALLOCATE(MIN2(LDIM),MAX2(LDIM),ICOR2(LDIM),MAT2(N2RS),KEY2(N2RS), + 1 IND2(4*N2RS),IND2T3(N2RS*(NZP+2)),MATMRG(N3RS)) + ALLOCATE(REM2(LMESH),VOL2(N2RS),ZCOR(NZP+1),VOLMRG(N3RS)) + CALL XEL3T2(IX,IY,IZ,LDIM,N3MS,N3MR,N3RS,LMESH,NZP,N2MS,N2MR, + 1 N3S,N3R,NFI,MINDIM,MAXDIM,REMESH,VOLSUR,MATALB,KEYMRG, + 2 INDEX,MAX2,MIN2,ICOR2,REM2,VOL2,MAT2,KEY2,IND2,IND2T3, + 3 MATMRG,VOLMRG,ZCOR) + ESTATE(1)=2 + ESTATE(2)=N2MS + ESTATE(3)=N2MR + ESTATE(6)=N2RS + ESTATE(8)=LCLSYM(IX) + ESTATE(9)=LCLSYM(IY) + ESTATE(10)=LCLSYM(IZ) + CALL LCMPUT(IPTRK,'MINDIM',LDIM,1,MIN2) + CALL LCMPUT(IPTRK,'MAXDIM',LDIM,1,MAX2) + CALL LCMPUT(IPTRK,'ICORD',LDIM,1,ICOR2) + CALL LCMPUT(IPTRK,'INDEX',4*N2RS,1,IND2) + CALL LCMPUT(IPTRK,'REMESH',LMESH,2,REM2) + CALL LCMPUT(IPTRK,'KEYMRG',N2RS,1,KEY2) + CALL LCMPUT(IPTRK,'MATALB',N2RS,1,MAT2) + CALL LCMPUT(IPTRK,'VOLSUR',N2RS,2,VOL2) + CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,ESTATE) + CALL LCMSIX(IPTRK,' ',2) + CALL LCMPUT(IPTRK,'MATALB',NFI,1,MATMRG) + CALL LCMPUT(IPTRK,'VOLSUR',NFI,2,VOLMRG) + CALL LCMPUT(IPTRK,'ZCOORD',NZP+1,2,ZCOR) + CALL LCMPUT(IPTRK,'IND2T3',N2RS*(NZP+2),1,IND2T3) + CALL LCMSIX(IPTRK,' ',2) + DEALLOCATE(VOLMRG,ZCOR,VOL2,REM2) + DEALLOCATE(MATMRG,IND2T3,IND2,KEY2,MAT2,ICOR2,MAX2,MIN2) +* + DEALLOCATE(VOLSUR,REMESH) + DEALLOCATE(INDEX,KEYMRG,MATALB,ICORD,MAXDIM,MINDIM) +* + RETURN + END diff --git a/Dragon/src/XELPRC.f b/Dragon/src/XELPRC.f new file mode 100644 index 0000000..0fc52bf --- /dev/null +++ b/Dragon/src/XELPRC.f @@ -0,0 +1,233 @@ +*DECK XELPRC + SUBROUTINE XELPRC (IPGEOM,GEONAM,NDIM,NNCYL,NNSUR,NNVOL,NAXREM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Reads a cell geometry and check if acceptable for EXCELL. +* +*Copyright: +* Copyright (C) 1989 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPGEOM pointer to the geometry (L_GEOM). +* GEONAM geometry name. +* NDIM number of dimensions (2 or 3). +* +*Parameters: output +* NNCYL number of cylinders in the geometry. +* NNSUR number of surfaces. +* NNVOL number of volumes. +* NAXREM max number of coordinates to specify that cell. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +* +* DECLARE DUMMY ARGUMENTS + TYPE(C_PTR) IPGEOM + INTEGER NDIM, NNCYL, NNSUR, NNVOL, NAXREM + CHARACTER*12 GEONAM +* +* DECLARE LOCAL VARIABLES + INTEGER NLCM, NIXS, NIST, NSTATE, MAXSPL + PARAMETER ( NLCM=26, NIXS=11, NIST=2, NSTATE=40, MAXSPL=100 ) + CHARACTER*12 LCMNM(NLCM) + INTEGER LNLCM(NLCM),INVLCM(NIXS),INVSTA(NIST), + > ISTATE(NSTATE),ISPLT(MAXSPL) + INTEGER ILCM, IIXS, IIST, ITYPE, LR, LX, LY, LZ, ISPLIT, + > JX, JY, JZ, JR, JL, ILEN, ITYLCM +* + DATA INVLCM/ 6, 11, 12, 14, 16, 17, 18, 19, + > 20, 21, 22 / + DATA INVSTA/ 8, 12 / + DATA LCMNM / 'MIX', 'MESHX', 'MESHY', 'MESHZ', 'RADIUS', + > 'SIDE', 'SPLITX', 'SPLITY', 'SPLITZ', 'SPLITR', + > 'CELL', 'COORD', 'MERGE', 'TURN', 'CLUSTER', + > 'NPIN', 'RPIN', 'APIN', 'BIHET', 'POURCE', + > 'PROCEL', 'IHEX', 'NCODE', 'ZCODE', 'ICODE', + > 'CENTER'/ +* + DO 10 ILCM= 1, NLCM + CALL LCMLEN(IPGEOM,LCMNM(ILCM),LNLCM(ILCM),ITYLCM) + 10 CONTINUE +* +* ELIMINATES THE INVALID OPTIONS + DO 20 IIXS= 1, NIXS + IF( LNLCM(INVLCM(IIXS)).NE.0 ) + > CALL XABORT( 'XELPRC:*'//GEONAM//'* IS '// + > 'NOT A VALID CELL GEOMETRY FOR EXCELL'// + > ' (LCM BLOCK *'//LCMNM(INVLCM(IIXS))//'*)') + 20 CONTINUE + CALL LCMLEN(IPGEOM,'STATE-VECTOR',ILEN,ITYLCM) + IF(ILEN .LT. 1 .OR. ILEN .GT. NSTATE ) + > CALL XABORT( 'XELPRC: GEOMETRY HAS INVALID STATE VECTOR') + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) + DO 30 IIST= 1, NIST + IF( ISTATE(INVSTA(IIST)).NE.0 ) + > CALL XABORT( 'XELPRC: INVALID GEOMETRY FOR EXCELL') + 30 CONTINUE +* + ITYPE= ISTATE(1) + LR= ISTATE(2) + LX= MAX(1,ISTATE(3)) + LY= MAX(1,ISTATE(4)) + LZ= MAX(1,ISTATE(5)) + NNVOL= ISTATE(6) + ISPLIT= ISTATE(11) +* +* GET THE SPLITTING INFORMATION, AND COMPUTE JR, JX, JY, JZ VALUES + IF( ISPLIT.GT.0 )THEN + JR= 0 + JX= 0 + JY= 0 + JZ= 0 + CALL LCMLEN(IPGEOM,'SPLITR',ILEN,ITYLCM) + IF( ILEN.GT.MAXSPL )THEN + CALL XABORT('XELPRC: SPLITR OVERFLOW') + ELSEIF( ILEN.EQ.0 )THEN + JR= LR + ELSEIF( ILEN.NE.LR )THEN + CALL XABORT( 'XELPRC: R-SPLITTING NOT ACCEPTED' ) + ELSE + CALL LCMGET(IPGEOM,'SPLITR',ISPLT) + JR= 0 + DO 15 JL= 1, ILEN + JR= JR + ABS(ISPLT(JL)) + 15 CONTINUE + ENDIF + CALL LCMLEN(IPGEOM,'SPLITX',ILEN,ITYLCM) + IF( ILEN.GT.MAXSPL )THEN + CALL XABORT('XELPRC: SPLITX OVERFLOW') + ELSEIF( ILEN.EQ.0 )THEN + JX= LX + ELSEIF( ILEN.NE.LX )THEN + CALL XABORT( 'XELPRC: X-SPLITTING NOT ACCEPTED' ) + ELSE + CALL LCMGET(IPGEOM,'SPLITX',ISPLT) + JX= 0 + DO 25 JL= 1, ILEN + JX= JX + ISPLT(JL) + 25 CONTINUE + ENDIF + CALL LCMLEN(IPGEOM,'SPLITY',ILEN,ITYLCM) + IF( ILEN.GT.MAXSPL )THEN + CALL XABORT('XELPRC: SPLITY OVERFLOW') + ELSEIF( ILEN.EQ.0 )THEN + JY= LY + ELSEIF( ILEN.NE.LY )THEN + CALL XABORT( 'XELPRC: Y-SPLITTING NOT ACCEPTED' ) + ELSE + CALL LCMGET(IPGEOM,'SPLITY',ISPLT) + JY= 0 + DO 35 JL= 1, ILEN + JY= JY + ISPLT(JL) + 35 CONTINUE + ENDIF + CALL LCMLEN(IPGEOM,'SPLITZ',ILEN,ITYLCM) + IF(ILEN.GT.MAXSPL) CALL XABORT('XELPRC: SPLITZ OVERFLOW') + IF( ILEN.EQ.0 )THEN + JZ= LZ + ELSEIF( ILEN.NE.LZ )THEN + CALL XABORT( 'XELPRC: Z-SPLITTING NOT ACCEPTED' ) + ELSE + JZ= 0 + CALL LCMGET(IPGEOM,'SPLITZ',ISPLT) + DO 45 JL= 1, ILEN + JZ= JZ + ISPLT(JL) + 45 CONTINUE + ENDIF + ELSE + JR= LR + JX= LX + JY= LY + JZ= LZ + ENDIF +* + IF( ITYPE.EQ.0 )THEN +* +* VIRTUAL ELEMENT + NNVOL= 0 + NNCYL= 0 + NNSUR= 0 + NAXREM= 0 + ELSE + IF( NDIM.EQ.2 )THEN + NNSUR= 2 * (JX+JY) + NNVOL= JX*JY + IF( ITYPE.EQ.5 )THEN +* FOR *CAR2D* GEOMETRY +* + NNCYL= 0 +* +* X-AXIS:JX+1, Y-AXIS:JY+1, Z-AXIS:2 + NAXREM= JX+JY+4 + ELSEIF( ITYPE.EQ.3 )THEN +* FOR *TUBE* GEOMETRY +* + NNCYL= 1 + IF( JX.NE.1 .OR. JY.NE.1 )THEN + CALL XABORT( 'XELPRC: FOR TUBE, PLEASE NO XY SPLIT') + ENDIF + NNVOL= NNVOL+JX*JY*JR +* +* X-AXIS:JX+1, Y-AXIS:JY+1, Z-AXIS:2, R-AXIS:JR+3 + NAXREM= JX+JY+JR+7 + ELSEIF( ITYPE.EQ.20 )THEN +* FOR *CARCEL* GEOMETRY +* + NNCYL= 1 + NNVOL= NNVOL+JX*JY*JR +* +* X-AXIS:JX+1, Y-AXIS:JY+1, Z-AXIS:2, R-AXIS:JR+3 + NAXREM= JX+JY+JR+7 + ELSE + CALL XABORT('XELPRC: INVALID CELL GEOMETRY FOR EXCELL=>' + > //GEONAM(1:12) ) + ENDIF + ELSE + NNSUR= 2 * (JX*JY+JX*JZ+JY*JZ ) + NNVOL= JX*JY*JZ + IF( ITYPE.EQ.7 )THEN +* FOR *CAR3D* GEOMETRY +* + NNCYL= 0 +* +* X-AXIS:JX+1, Y-AXIS:JY+1, Z-AXIS:JZ+1 + NAXREM= JX+JY+JZ+3 + ELSEIF( ITYPE.EQ. 6 .OR. ITYPE.EQ.21 .OR. + > ITYPE.EQ.22 .OR. ITYPE.EQ.23 )THEN +* FOR *TUBEZ*, *CARCELX*, *CARCELY* OR *CARCELZ* GEOMETRY +* + NNCYL= 1 + IF( ITYPE.EQ.6 )THEN + IF( JX.NE.1 .OR. JY.NE.1 ) THEN + CALL XABORT('XELPRC: FOR TUBEZ, PLEASE NO XY SPLIT') + ENDIF + ELSEIF( ITYPE.EQ.23 )THEN + NNSUR= NNSUR+2*JR*JX*JY + ELSEIF( ITYPE.EQ.22 )THEN + NNSUR= NNSUR+2*JR*JX*JZ + ELSEIF( ITYPE.EQ.21 )THEN + NNSUR= NNSUR+2*JR*JY*JZ + ENDIF + NNVOL= NNVOL+JR*JX*JY*JZ +* +* X-AXIS:JX+1, Y-AXIS:JY+1, Z-AXIS:JZ+1, R-AXIS:JR+3 + NAXREM= JX+JY+JZ+JR+6 + ELSE + CALL XABORT( 'XELPRC: INVALID CELL GEOMETRY FOR EXCELL=>'// + > GEONAM(1:12) ) + ENDIF + ENDIF + ENDIF +* + RETURN + END diff --git a/Dragon/src/XELPRP.f b/Dragon/src/XELPRP.f new file mode 100644 index 0000000..c8d945d --- /dev/null +++ b/Dragon/src/XELPRP.f @@ -0,0 +1,364 @@ +*DECK XELPRP + SUBROUTINE XELPRP(IPGEOM, GEONAM, NDIM, NTYPO, NBLOCK, NBMIX, + > MAXGRI, ALBEDO, ICODE, NCODE, LCLSYM, LCLTRA, + > MRGSUR, LEAKSW, LL1, LL2, L1CELL, NEXTGE, + > IFCSYM, IPRT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Reads the geometry and check if the geometry +* is acceptable for EXCELL. +* +*Copyright: +* Copyright (C) 1989 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPGEOM pointer to the geometry (L_GEOM). +* GEONAM geometry name. +* IPRT printing level. +* +*Parameters: output +* NDIM number of dimensions. +* NTYPO number of types. +* NBLOCK number of blocks. +* NBMIX number of mixtures. +* MAXGRI grid dimensions (NX*NY*NZ). +* ALBEDO geometric albedos on the six faces. +* ICODE index for boundary conditions. +* NCODE type of boundary conditions. +* LCLSYM symmetry flags (0: no; -1/+1: syme; -2/+2: ssym). +* LCLTRA translation flags (0: no; +1: tra). +* MRGSUR similarity between faces. +* LEAKSW leakage switch. +* LL1 diagonal symmetry (2,3). +* LL2 diagonal symmetry (1,4). +* L1CELL to indicate that there is only 1 cell. +* NEXTGE rectangular(0)/circular(1) boundary. +* IFCSYM number of symmetry in full assembly (1,2,3,4,5). +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +* + TYPE(C_PTR) IPGEOM + INTEGER NDIM, NTYPO, NBLOCK, NBMIX, NEXTGE, IFCSYM, IPRT + INTEGER MAXGRI(3),LCLSYM(3),LCLTRA(3), + > NCODE(6),ICODE(6),MRGSUR(-6:-1) + LOGICAL LEAKSW,LL1,LL2,L1CELL + REAL ALBEDO(6) +* + INTEGER NLCM, NIXS, NSTATE, IOUT + PARAMETER ( NLCM=26, NIXS=8, NSTATE=40, IOUT=6 ) + INTEGER LNLCM(NLCM),INVLCM(NIXS), + > ISTATE(NSTATE),JCODE(6) + REAL ZCODE(6) + LOGICAL SWALBE(6) + CHARACTER LCMNM(NLCM)*12, GEONAM*12, CORIEN(-6:0)*4 + INTEGER ILCM, IDIR, IIXS, ILONG, ITPLCM, ISUR, ITYPE, + > LREG, ISUB1, ISUB2, ISPLIT, ITRAN, I2, IAL +* + DATA CORIEN + > / ' Z+ ',' Z- ',' Y+ ',' Y- ',' X+ ',' X- ',' ' / + DATA INVLCM/ 6, 12, 16, 17, 18, 20, 21, 22 / + DATA LCMNM / 'MIX', 'MESHX', 'MESHY', 'MESHZ', 'RADIUS', + > 'SIDE', 'SPLITX', 'SPLITY', 'SPLITZ', 'SPLITR', + > 'CELL', 'COORD', 'MERGE', 'TURN', 'CLUSTER', + > 'NPIN', 'RPIN', 'APIN', 'BIHET', 'POURCE', + > 'PROCEL', 'IHEX', 'NCODE', 'ZCODE', 'ICODE', + > 'CENTER'/ +* + IFCSYM= 1 + DO 10 ILCM= 1, NLCM + CALL LCMLEN(IPGEOM, LCMNM(ILCM), LNLCM(ILCM), ITPLCM ) + 10 CONTINUE + IFCSYM= 1 + DO 11 IDIR=1,3 + LCLSYM(IDIR)=0 + LCLTRA(IDIR)=0 + 11 CONTINUE +* +* ELIMINATES THE INVALID OPTIONS + DO 20 IIXS= 1, NIXS + IF( LNLCM(INVLCM(IIXS)).NE.0 ) + > CALL XABORT( 'XELPRP:*'//GEONAM//'* IS '// + > 'NOT A VALID GEOMETRY FOR EXCELL'// + > ' (LCM BLOCK *'//LCMNM(INVLCM(IIXS))//'*)') + 20 CONTINUE + CALL LCMLEN(IPGEOM,'STATE-VECTOR',ILONG,ITPLCM) + IF( ILONG.LE.0 .OR. ILONG .GT. NSTATE ) + > CALL XABORT( 'XELPRP: GEOMETRY HAS INVALID STATE VECTOR') + ISTATE(:NSTATE)=0 + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) + DO 35 ISUR= 1, 6 + SWALBE( ISUR)= .FALSE. + ALBEDO( ISUR)= 1.0 + MRGSUR(-ISUR)= -ISUR + ICODE ( ISUR)= -ISUR + 35 CONTINUE +* + ITYPE= ISTATE(1) + LREG= ISTATE(6) + NBMIX= ISTATE(7) + ISUB1= ISTATE(8) + ISUB2= ISTATE(9) + ISPLIT= ISTATE(11) + NEXTGE= 0 +* + IF( ISUB1.NE.0 )THEN +* +* MANY CELLS + L1CELL= .FALSE. + MAXGRI(1)= MAX(1,ISTATE(3)) + MAXGRI(2)= MAX(1,ISTATE(4)) + MAXGRI(3)= MAX(1,ISTATE(5)) + NTYPO= ISUB2 + IF( ITYPE.EQ.5 )THEN + NDIM= 2 + SWALBE(1)=.TRUE. + SWALBE(2)=.TRUE. + SWALBE(3)=.TRUE. + SWALBE(4)=.TRUE. + ICODE (5)= 0 + ICODE (6)= 0 + ELSEIF( ITYPE.EQ.7 )THEN + NDIM= 3 + SWALBE(1)=.TRUE. + SWALBE(2)=.TRUE. + SWALBE(3)=.TRUE. + SWALBE(4)=.TRUE. + SWALBE(5)=.TRUE. + SWALBE(6)=.TRUE. + ELSE + CALL XABORT( 'XELPRP: INVALID GEOMETRY FOR EXCELL') + ENDIF + ELSE +* +* JUST ONE CELL + L1CELL= .TRUE. + MAXGRI(1)= 1 + MAXGRI(2)= 1 + MAXGRI(3)= 1 + NTYPO= 1 + IF( ITYPE.EQ. 3 .OR. ITYPE.EQ. 5 .OR. + > ITYPE.EQ.20 )THEN + NDIM= 2 + IF( ITYPE.EQ.3 )THEN + NEXTGE= 1 + ICODE (1)= 0 + SWALBE(2)=.TRUE. + ICODE (3)= 0 + ICODE (4)= 0 + ICODE (5)= 0 + ICODE (6)= 0 + ELSE + SWALBE(1)=.TRUE. + SWALBE(2)=.TRUE. + SWALBE(3)=.TRUE. + SWALBE(4)=.TRUE. + ICODE (5)= 0 + ICODE (6)= 0 + ENDIF + ELSEIF( ITYPE.EQ. 6 .OR. ITYPE.EQ. 7 .OR. + > ITYPE.EQ.21 .OR. ITYPE.EQ.22 .OR. ITYPE.EQ.23 )THEN + NDIM= 3 + IF( ITYPE.EQ.6 )THEN + NEXTGE= 1 + ICODE (1)= 0 + SWALBE(2)=.TRUE. + ICODE (3)= 0 + ICODE (4)= 0 + SWALBE(5)=.TRUE. + SWALBE(6)=.TRUE. + ELSE + SWALBE(1)=.TRUE. + SWALBE(2)=.TRUE. + SWALBE(3)=.TRUE. + SWALBE(4)=.TRUE. + SWALBE(5)=.TRUE. + SWALBE(6)=.TRUE. + ENDIF + ELSE + CALL XABORT( 'XELPRP: INVALID GEOMETRY FOR EXCELL') + ENDIF + ENDIF +* +* RECOVERS B.C. + CALL LCMGET(IPGEOM,'NCODE',NCODE) + CALL LCMGET(IPGEOM,'ZCODE',ZCODE) + CALL LCMGET(IPGEOM,'ICODE',JCODE) +* +* TREATMENT OF DIAGONAL B.C. + LL1= .FALSE. + LL2= .FALSE. + ITRAN=0 + I2=0 + DO 50 IAL=1, 6 + IF( .NOT.SWALBE(IAL) ) GO TO 50 + IF( JCODE(IAL).NE.0 )THEN + IF( ICODE(IAL).EQ.0 )THEN + CALL XABORT('XELPRP: INVALID BOUNDARY CONDITION.') + ENDIF + ICODE(IAL)= JCODE(IAL) + ZCODE(IAL)= 1.0 + ELSEIF( NCODE(IAL).EQ.0 )THEN + CALL XABORT('XELPRP: A BOUNDARY CONDITION IS MISSING.') + ENDIF + IF( NCODE(IAL).EQ.2 )THEN + ZCODE(IAL)= 1.0 + ELSEIF( NCODE(IAL).EQ.3 )THEN + I2=I2+1 + ELSEIF( NCODE(IAL).EQ.4 )THEN + ITRAN=ITRAN+1 + ZCODE(IAL)= 1.0 + ELSEIF( NCODE(IAL).EQ.6 )THEN + NCODE(IAL)= 1 + ELSEIF( NCODE(IAL) .EQ. 7 .OR. + > NCODE(IAL) .EQ. 8 .OR. + > NCODE(IAL) .EQ. 9 .OR. + > NCODE(IAL) .GE. 11 )THEN + CALL XABORT('XELPRP: INVALID B.C. FOR EXCELL') + ENDIF + 50 CONTINUE +* +* DIAGONAL B.C. + IF( I2.GT.0 )THEN + IF( I2.NE.2 ) + > CALL XABORT('XELPRP: NO MORE THAN 2 DIAGONAL CONDITIONS') + IF( MAXGRI(1).NE.MAXGRI(2)) + > CALL XABORT('XELPRP: LX=LY WITH A DIAGONAL SYMMETRY.') + LL1=((NCODE(2).EQ.3).AND.(NCODE(3).EQ.3)) + LL2=((NCODE(1).EQ.3).AND.(NCODE(4).EQ.3)) + IFCSYM= IFCSYM+1 + IF( LL1 )THEN + NCODE(2)= NCODE(4) + NCODE(3)= NCODE(1) + ICODE(2)= ICODE(4) + ICODE(3)= ICODE(1) + MRGSUR(-2)= -4 + MRGSUR(-3)= -1 + ZCODE(2)= ZCODE(4) + ZCODE(3)= ZCODE(1) + ELSEIF( LL2 )THEN + NCODE(1)= NCODE(3) + NCODE(4)= NCODE(2) + ICODE(1)= ICODE(3) + ICODE(4)= ICODE(2) + MRGSUR(-1)= -3 + MRGSUR(-4)= -2 + ZCODE(1)= ZCODE(3) + ZCODE(4)= ZCODE(2) + ELSE + CALL XABORT('XELPRP: THE DIAGONAL CONDITIONS '// + > 'X+: DIAG Y-: DIAG AND '// + > 'X-: DIAG Y+: DIAG ARE THE ONLY PERMITTED.') + ENDIF + ENDIF +* +* TRANSLATION BC (PERIODIC CELL) +* ONLY PAIRS PERMITTED: +* 1) X- TRAN X+ TRAN +* 2) Y- TRAN Y+ TRAN +* 3) Z- TRAN Z+ TRAN + IF( ITRAN.GT.0 )THEN + IF( MOD(ITRAN,2).EQ.1 )THEN + CALL XABORT('XELPRP: TRANSLATION SYMETRIES COME IN PAIRS') + ENDIF + DO 45 IAL=1,6,2 + IF(SWALBE(IAL)) THEN + IF( NCODE(IAL).EQ.4 .AND. NCODE(IAL+1).EQ.4 )THEN + LCLTRA((IAL+1)/2)=1 + MRGSUR(-IAL )=-IAL-1 + MRGSUR(-IAL-1)=-IAL + ITRAN=ITRAN-2 + ENDIF + ENDIF + 45 CONTINUE + IF( ITRAN.NE.0 )THEN + CALL XABORT('XELPRP: WRONG PAIRS OF TRANSLATION SYMETRIES') + ENDIF + ENDIF +* +* SYMMETRIC B.C. + DO 40 IAL= 1, 6 + IF( .NOT.SWALBE(IAL) ) GO TO 40 + ALBEDO( IAL)= ZCODE(IAL) + IF( NCODE(IAL).EQ.5 )THEN + MAXGRI((IAL+1)/2)= 2*MAXGRI((IAL+1)/2)-1 + IF( LCLSYM((IAL+1)/2).NE.0 )THEN + CALL XABORT('XELPRP: 2 SYMMETRIES ON SAME FACE') + ELSE + IFCSYM= IFCSYM+1 + IF( MOD(IAL,2).EQ.0 )THEN + LCLSYM((IAL+1)/2)= +1 + MRGSUR(-IAL)= MRGSUR(-IAL+1) + ALBEDO( IAL)= ZCODE(IAL-1) + ICODE ( IAL)= ICODE(IAL-1) + ELSE + LCLSYM((IAL+1)/2)= -1 + MRGSUR(-IAL)= MRGSUR(-IAL-1) + ALBEDO( IAL)= ZCODE(IAL+1) + ICODE ( IAL)= ICODE(IAL+1) + ENDIF + ENDIF + ELSE IF( NCODE(IAL).EQ.10 )THEN + MAXGRI((IAL+1)/2)= 2*MAXGRI((IAL+1)/2) + IF( LCLSYM((IAL+1)/2).NE.0 )THEN + CALL XABORT('XELPRP: 2 SYMMETRIES ON SAME FACE') + ELSE + IFCSYM= IFCSYM+1 + IF( MOD(IAL,2).EQ.0 )THEN + LCLSYM((IAL+1)/2)= +2 + MRGSUR(-IAL)= MRGSUR(-IAL+1) + ALBEDO( IAL)= ZCODE(IAL-1) + ICODE ( IAL)= ICODE(IAL-1) + ELSE + LCLSYM((IAL+1)/2)= -2 + MRGSUR(-IAL)= MRGSUR(-IAL-1) + ALBEDO( IAL)= ZCODE(IAL+1) + ICODE ( IAL)= ICODE(IAL+1) + ENDIF + ENDIF + ENDIF + 40 CONTINUE +* + NBLOCK= MAXGRI(1)*MAXGRI(2)*MAXGRI(3) + LEAKSW= .TRUE. + DO 60 ISUR= 1, 6 + LEAKSW= LEAKSW .AND. ALBEDO( ISUR).EQ.1.0 + 60 CONTINUE + LEAKSW= .NOT. LEAKSW + IF( IPRT.GT.2 )THEN + IF( LEAKSW )THEN + WRITE(IOUT,6000) + > (100.*(1.0-ALBEDO(IAL)), IAL= 1,6) + ELSE + WRITE(IOUT,6001) + ENDIF + WRITE(IOUT,6100) + > (CORIEN(MRGSUR(IAL)), IAL=-1,-6,-1) + ENDIF + IF( NEXTGE.NE.0 )THEN + CALL XABORT( 'XELPRP:*'//GEONAM//'* IS '// + > 'A TUBE/TUBEZ GEOMETRY (NOT AVAILABLE)') + ENDIF +* + RETURN + 6000 FORMAT(/1X,'*** ONLY FOR GEOMETRIC ALBEDOS ***' + > /1X,'PERCENT LEAKAGE X-: ',F5.1,'% X+: ',F5.1,'%' + > /1X,'(FULL UNFOLD Y-: ',F5.1,'% Y+: ',F5.1,'%' + > /1X,' ASSEMBLY) Z-: ',F5.1,'% Z+: ',F5.1,'%'//) + 6001 FORMAT(/1X,'*** ONLY FOR GEOMETRIC ALBEDOS ***' + > /1X,'*** NO LEAKAGE ON THE ASSEMBLY ***'//) + 6100 FORMAT(/1X,'SIMILAR FACES X-: ',A5,2X,'X+: ',A5 + > /1X,'(FULL UNFOLD Y-: ',A5,2X,'Y+: ',A5 + > /1X,' ASSEMBLY) Z-: ',A5,2X,'Z+: ',A5//) + + END diff --git a/Dragon/src/XELPSC.f b/Dragon/src/XELPSC.f new file mode 100644 index 0000000..7a30c6b --- /dev/null +++ b/Dragon/src/XELPSC.f @@ -0,0 +1,49 @@ +*DECK XELPSC + FUNCTION XELPSC(RANN,PLANE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute annular surface below Cartesian plane. +* +*Copyright: +* Copyright (C) 1997 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s):G. Marleau +* +*Parameters: input +* RANN annular radius. +* PLANE Cartesian plane location. +* +*Parameters: output +* XELPSC annular surface below plane. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE + DOUBLE PRECISION XELPSC,RANN,PLANE +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION RANN2,PLANE2,ALPHA +*---- +* METHOD +* 1) FIND HALF-ANGLE COVERED BY THE TWO INTERSECTION POINTS +* BETWEEN PLANE AND ANNULAR REGION +* -- ALPHA=ACOS(-PLANE/RANN) +* 2) COMPUTED ANNULAR SURFACE COVERED BY THIS HALF-ANGLE +* -- 0.5*RANN2*ALPHA +* 3) ADD SURFACE COVERED BY INTERNAL RECTANGLE IN THIS HALF-ANGLE +* -- 0.5*PLANE*SQRT(RANN2-PLANE2) +* 4) DOULBLE SURFACE FOR FULL ANGLE +*---- + RANN2=RANN*RANN + PLANE2=PLANE*PLANE + ALPHA=ACOS(-PLANE/RANN) + XELPSC=RANN2*ALPHA+PLANE*SQRT(RANN2-PLANE2) + RETURN + END diff --git a/Dragon/src/XELPSI.f b/Dragon/src/XELPSI.f new file mode 100644 index 0000000..d69ed50 --- /dev/null +++ b/Dragon/src/XELPSI.f @@ -0,0 +1,93 @@ +*DECK XELPSI + FUNCTION XELPSI(ITYP,RANN2,XYPOS,XYPOS2,SPXY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute intersection surface between part of annular region to the +* left of X-plane and either the part of the annular region above +* Y-plane or the part below the Y-plane. +* +*Copyright: +* Copyright (C) 1997 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): G. Marleau +* +*Parameters: input +* ITYP type of calculation: +* =1 above y-plane; +* =2 below y-plane. +* RANN2 pin radius squared. +* XYPOS cartesian plane location: +* (1,1) left x-plane; +* (1,2) right x-plane; +* (2,1) bottom y-plane; +* (2,2) top y-plane. +* XYPOS2 cartesian mesh squared with same notation as for XYPOS. +* SPXY annular surface outside of planes with same notation +* as for XYPOS. +* +*Parameters: output +* XELPSI intersection surface. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE + INTEGER ITYP + DOUBLE PRECISION XELPSI,RANN2,XYPOS(2,2),XYPOS2(2,2),SPXY(2,2) +*---- +* LOCAL PARAMETERS +*---- + DOUBLE PRECISION PI,DZERO + PARAMETER (PI=3.14159265358979323846D0,DZERO=0.0D0) + DOUBLE PRECISION SQANN,YFC,XFC +*---- +* TEST IF POINT OF INTEREST IS LOCATED INSIDE +* ANNULAR REGION +*---- + XELPSI=0.0D0 + IF(XYPOS2(2,ITYP)+XYPOS2(1,1).LT.RANN2) THEN +*---- +* FOR POINT INSIDE ANNULAR REGION +* 1) (SUM OF ANNULAR INTERSECTION SURFACES)/2 +* -INTERSECTION SURFACE +* +(INTERNAL REGION CARTESIAN SURFACE)/4 +* =(ANNULAR SURFACE)/4 +*---- + SQANN=0.25D0*PI*RANN2 + YFC=-XYPOS(2,ITYP) + IF(ITYP.EQ.1) THEN + XFC=-XYPOS(1,1) + ELSE + XFC=XYPOS(1,1) + ENDIF + XELPSI=0.5D0*(SPXY(1,1)+SPXY(2,ITYP))+XFC*YFC-SQANN + ELSE + IF(ITYP.EQ.1) THEN + IF(XYPOS(2,ITYP).LT.DZERO.AND.XYPOS(1,1).LT.DZERO) THEN + XELPSI=DZERO + ELSE IF(XYPOS(2,ITYP).GT.DZERO.AND.XYPOS(1,1).GT.DZERO) THEN + XELPSI=SPXY(2,ITYP)+SPXY(1,1)-PI*RANN2 + ELSE IF(XYPOS(2,ITYP).GT.DZERO.AND.XYPOS(1,1).LT.DZERO) THEN + XELPSI=SPXY(1,1) + ELSE IF(XYPOS(2,ITYP).LT.DZERO.AND.XYPOS(1,1).GT.DZERO) THEN + XELPSI=SPXY(2,ITYP) + ENDIF + ELSE + IF(XYPOS(2,ITYP).LT.DZERO.AND.XYPOS(1,1).LT.DZERO) THEN + XELPSI=SPXY(1,1) + ELSE IF(XYPOS(2,ITYP).GT.DZERO.AND.XYPOS(1,1).GT.DZERO) THEN + XELPSI=SPXY(2,ITYP) + ELSE IF(XYPOS(2,ITYP).GT.DZERO.AND.XYPOS(1,1).LT.DZERO) THEN + XELPSI=DZERO + ELSE IF(XYPOS(2,ITYP).LT.DZERO.AND.XYPOS(1,1).GT.DZERO) THEN + XELPSI=SPXY(2,ITYP)+SPXY(1,1)-PI*RANN2 + ENDIF + ENDIF + ENDIF + RETURN + END diff --git a/Dragon/src/XELTCW.f b/Dragon/src/XELTCW.f new file mode 100644 index 0000000..4d2d6e1 --- /dev/null +++ b/Dragon/src/XELTCW.f @@ -0,0 +1,63 @@ +*DECK XELTCW + SUBROUTINE XELTCW(NANGLE,PTSANG,WGTANG) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the integration weights for cyclic tracking. +* +*Copyright: +* Copyright (C) 1994 Ecole Polytechnique de Montreal. +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NANGLE number of angles. +* PTSANG integration points. +* +*Parameters: output +* WGTANG integration weights. +* +*Reference: +* M.J.Halsall, Cactus, a characteritics solution to the neutron +* transport equations in complicated geometries, UK Atomic Energy +* Authority, 1980. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + INTEGER NANGLE + DOUBLE PRECISION PTSANG(NANGLE),WGTANG(NANGLE) +*---- +* Local variables +*---- + INTEGER LL + DOUBLE PRECISION XDRCST,PI + DOUBLE PRECISION ACCUW +*---- +* Computes weights associated with azimuthal angles (PTSANG) +*---- + PI=XDRCST('Pi',' ') + IF(NANGLE>1) THEN + WGTANG(1)=1.0D0-(ACOS(PTSANG(2))+ACOS(PTSANG(1)))/PI + ACCUW=WGTANG(1) + DO LL=2,NANGLE-1 +* WGTANG(LL)=(PTSANG(LL+1)+PTSANG(LL))/PI +* -(PTSANG(LL)+PTSANG(LL-1))/PI + WGTANG(LL)=(ACOS(PTSANG(LL-1))-ACOS(PTSANG(LL+1)))/PI + ACCUW=ACCUW+WGTANG(LL) + ENDDO + WGTANG(NANGLE)=(ACOS(PTSANG(NANGLE))+ACOS(PTSANG(NANGLE-1)))/PI + ACCUW=ACCUW+WGTANG(NANGLE) + ELSE + WGTANG(1)=1.0D0 + ENDIF + RETURN + END diff --git a/Dragon/src/XELTI2.f b/Dragon/src/XELTI2.f new file mode 100644 index 0000000..0d7700e --- /dev/null +++ b/Dragon/src/XELTI2.f @@ -0,0 +1,350 @@ +*DECK XELTI2 + SUBROUTINE XELTI2( IPRT,IFTEMP,NANGLE,DENUSR,ISYMM,ANGLES,DENSTY, + > NTOTCL,MAXR,REMESH,LINMAX,RCUTOF, + > NSUR,NVOL,INDEL,MINDIM, + > MAXDIM,ICOORD,INCR,ICUR,TRKBEG,CONV,TRKDIR, + > LENGHT,NUMERO,DDENWT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Construct the sequential tape that will contain tracks for +* isotropic BC for 2-D calculation. +* +*Copyright: +* Copyright (C) 1989 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPRT intermediate printing level for output. +* IFTEMP tracking file number. +* NANGLE number of angles used in the tracking process. +* DENUSR density of tracks in the plane perpendicular +* to the tracking angles. +* ISYMM flag for symetry: +* = 2 reflection plane normal to X axis; +* = 4 reflection plane normal to Y axis; +* = 8 reflection plane normal to X and Y axis. +* ANGLES 3D angle values. +* DENSTY density of tracks angle by angle. +* NTOTCL number of cylindres of a type + 2. +* MAXR max number of real mesh values in REMESH. +* REMESH real mesh values (rect/cyl). +* LINMAX max. number of track segments in a single track. +* RCUTOF cutof for corner tracking. +* NSUR number of surfaces. +* NVOL number of zones. +* INDEL numbering of surfaces & zones. +* MINDIM min index values for all axes (rect/cyl). +* MAXDIM max index values for all axes (rect/cyl). +* ICOORD principal axes direction (X/Y/Z) for meshes. +* ICUR current zonal location for a track segment. +* INCR increment direction for next track segment. +* TRKBEG position where a track begins. +* CONV segments of tracks. +* TRKDIR direction of a track in all axes. +* LENGHT relative lenght of each segment in a track. +* NUMERO material identification of each track segment. +* DDENWT density of tracks angle by angle. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +* +* DECLARE DUMMY ARGUMENTS + INTEGER IPRT,IFTEMP,NANGLE,NTOTCL,MAXR,LINMAX + REAL TRKBEG(NTOTCL), TRKDIR(NTOTCL), CONV(NTOTCL), + > REMESH(MAXR),DENUSR + DOUBLE PRECISION DENSTY(NANGLE),ANGLES(2,NANGLE),LENGHT(LINMAX), + > DDENWT(NANGLE) + INTEGER MINDIM(NTOTCL), MAXDIM(NTOTCL), ICUR(NTOTCL), + > ICOORD(NTOTCL), INCR(NTOTCL), NUMERO(LINMAX), + > INDEL(4,*) +* +* DECLARE LOCAL VARIABLES + REAL TRKEND(3), TRKORI(3), BARY(2), PROJC2(3), RCUTOF, + > ANGEQN(2,2), ANGLE2(2), TRKCUT(3,2), + > TCUTOF(2,2), TORIC(3), DENLIN, R2CIRC, RCIRC, DP, + > ODDNXT, SURTOT, VOLTOT, DDENST, ANN, TOTLEN, TOTXXX + DOUBLE PRECISION WEIGHT,WTA,WTD + INTEGER NSBEG(4), NSEND(4), NSCUT(2), NDIM, I, NPOINT, + > NPO2, NCUTOF, NOTRAK, IANGL, IDIM, NANGLS, NESTIM, + > NSOLMX, IREF1, IZZ, IANG, NTTRK, NDEBS, I2, J, + > NSUR, NVOL, NCROS, K, K3, LINE, ISB, ISE, JC + INTEGER ISYMM + REAL WGA,WLA,WGD,WLD + EQUIVALENCE ( ANGEQN(1,2), ANGLE2 ) + INTEGER IOUT + PARAMETER ( IOUT=6 ) + CHARACTER TEDATA*13 +* +* ONE WEIGHT FOR ALL TRACKS +* DENLIN= # OF TRACKS / CM + DENLIN= DENUSR + NDIM= 2 + PROJC2(1)= 0.0 + PROJC2(2)= 0.0 + PROJC2(3)= 1.0 + TRKBEG(3)= 0.0 + TRKDIR(3)= 0.0 + TRKEND(3)= 0.0 +* +* COMPUTE THE CIRCUMSCRIBED RADIUS +* THE COORDINATE FOR THE TRUE CENTER OF THE CELL + R2CIRC= 0.0 + DO 10 I = 1, 2 + BARY(I)= 0.5 * (REMESH(MAXDIM(I)) + REMESH(MINDIM(I))) + R2CIRC= R2CIRC + > + (REMESH(MAXDIM(I)) - REMESH(MINDIM(I)))**2 + 10 CONTINUE + R2CIRC= 0.25 * R2CIRC + RCIRC = SQRT(R2CIRC) +* +* NPOINT= # OF TRACKS ALONG THE PERPENDICULAR AXIS + NPOINT= INT( 2. * RCIRC * DENLIN ) +****** BEWARE ***** BEWARE ***** BEWARE ***** BEWARE ***** BEWARE ***** +****** CHANGE THIS "NPOINT" PARAMETER HAS TREMENDOUS EFFECTS ON TRACKING +****** BEWARE ***** BEWARE ***** BEWARE ***** BEWARE ***** BEWARE ***** +* +* POSSIBLE OTHER CHOICES (EXPLORED WITHOUT SUCCESS) ARE ==> +*1-) NPOINT= INT( 2. * RCIRC * DENLIN ) + 1 +*2-) NPOINT= NINT( 2. * RCIRC * DENLIN ) +*3-) NPOINT= NINT( 2. * RCIRC * DENLIN ) + 1 +* +* KEEP "NPOINT" ODD & CORRECT DENSITY + NPO2 = NPOINT / 2 + NPOINT= 2 * NPO2 + 1 + DP = 2. * RCIRC / NPOINT + DENLIN= 1. / DP + DENUSR= DENLIN + ODDNXT= (2*NPO2+3) / (2.*RCIRC) + IF( RCUTOF.EQ.0.0 )THEN + NCUTOF= 1 + ELSE + NCUTOF= 2 + ENDIF +* + NOTRAK= 0 + SURTOT= 0.0 + VOLTOT= 0.0 + DDENST= 1.0 / DENUSR + WEIGHT= 0.5*DDENST/DBLE(NANGLE) + CALL XELEQN( 2, 0, ANGEQN ) + DO 15 IANGL= 1, NANGLE + CALL XELEQN( 2, NANGLE, ANGEQN ) + DENSTY(IANGL)= REAL(2*NANGLE) + ANGLES(1,IANGL)= ANGEQN(1,1) + ANGLES(2,IANGL)= ANGEQN(2,1) + DDENWT(IANGL)=WEIGHT + 15 CONTINUE +*---- +* Optimize tracking by taking into account +* symmetry of geometry +* 1) Do not track symmetric lines +* 2) Nodify weight as required for tracks droped +*---- + WGA=1.0 + WLA=1.0 + WGD=1.0 + WLD=1.0 + NANGLS= NANGLE + IF(ISYMM .EQ. 2 .OR. + > ISYMM .EQ. 4 .OR. + > ISYMM .EQ. 8 ) THEN + NANGLS= (NANGLE+1)/2 + WGA=2.0 + DO 200 IANGL=1,NANGLS-1 + DENSTY(IANGL)=0.5*DENSTY(IANGL) + 200 CONTINUE + IF(2*NANGLS .EQ. NANGLE) THEN + WLA=WGA + DENSTY(NANGLS)=0.5*DENSTY(NANGLS) + ENDIF + ENDIF + IF(ISYMM .EQ. 8 ) THEN + WGD=2.0 + NPOINT=(NPOINT+1)/2 + ENDIF +* +* COPY ANGLES AND DENSITIES ON TEMPORARY TRACKING FILE + WRITE(IFTEMP) ((ANGLES(IDIM,IANGL),IDIM=1,NDIM),IANGL=1,NANGLS) + WRITE(IFTEMP) (DENSTY(IANGL) ,IANGL=1,NANGLS) +* +* TO REINITIATE THE EQN ANGLES ROUTINE + CALL XELEQN( 2, 0, ANGEQN ) +* + NSOLMX= 0 + NDEBS= 0 + IF( IPRT.GT.1 )THEN +* +* PREPARE & PRINT THE ESTIMATED NUMBER OF TRACKS + NESTIM= NPOINT * NANGLS + WRITE(IOUT,'(1H )') + WRITE(IOUT,'( 8H ECHO = ,I8,15H TRACKS/ANGLE )') + > NPOINT + WRITE(IOUT,'(30H ECHO = NEXT ODD DENSITY > ,F15.7,3H/CM )') + > ODDNXT + WRITE(IOUT,'( 8H ECHO = ,28H ESTIMATED NUMBER OF TRACKS= ,I8)') + > NESTIM +* +* PREPARE PRINTING WITH VARIABLE FORMAT + WRITE(IOUT,'(1H )') + WRITE(IOUT,6003) NANGLE + IF(NANGLS .NE. NANGLE) THEN + WRITE(IOUT,6004) NANGLS + ENDIF + NSOLMX= MIN(9, NANGLS/10) + IREF1=0 + WRITE(IOUT,'( 1H0,10(I1,9X))') (IREF1, IZZ=0,NSOLMX) + WRITE(IOUT,'( 1H ,10(I1,9X))') (MOD(IZZ,10), IZZ=0,NSOLMX) + WRITE(IOUT,'( 2H 0)') + TEDATA= '(1H+,TXXX,I1)' + ENDIF + IANG=0 + NTTRK=0 + DO 290 IANGL= 1, NANGLS + IANG=IANG+1 + WTA=WGA + IF(IANGL .EQ. NANGLS) THEN + WTA=WLA + ENDIF + IF( IPRT.GT.1 )THEN + IF( MOD(IANG,100) .EQ. 0 )THEN + IREF1=IREF1+1 + NDEBS= NSOLMX+1 + NSOLMX=MIN(NDEBS+9, NANGLS/10) + WRITE(IOUT,'( 1H0,10(I1,9X))')(IREF1,IZZ=NDEBS,NSOLMX) + WRITE(IOUT,'( 1H ,10(I1,9X))') + > (MOD(IZZ,10),IZZ=NDEBS,NSOLMX) + WRITE(IOUT,'( 2H 0)') + ELSE + IF( IPRT.GT.10000.AND.MOD(IANG,100).NE.0 )THEN + WRITE(IOUT,'( 1H ,10(I1,9X))')(IREF1,IZZ=NDEBS,NSOLMX) + WRITE(IOUT,'( 1H ,10(I1,9X))') + > (MOD(IZZ,10),IZZ=NDEBS,NSOLMX) + WRITE(IOUT,'( 2H )') + ENDIF + WRITE(TEDATA(7:9),'(I3.3)') MOD(IANG,100) + 2 + WRITE(IOUT,TEDATA) MOD(IANG,10) + ENDIF + ENDIF + CALL XELEQN( 2, NANGLE, ANGEQN ) +* + DO 40 I = 1, 2 + TRKDIR(I)= ANGEQN(I,1) +* +* DETERMINE THE DIRECTION OF INCREASE FOR TRKDIR + INCR(I)= +1 + IF( TRKDIR(I) .LT. 0.0 ) INCR(I)= -1 +* +* MODIFY PERPENDICULAR ANGLES TO TAKE INTO ACCOUNT DP + ANGLE2(I)= DP * ANGLE2(I) + IF( NCUTOF.NE.1 )THEN + TCUTOF(I,1)= RCUTOF*ANGLE2(I) + TCUTOF(I,2)= -TCUTOF(I,1) + ENDIF +* +* DETERMINE THE ORIGINE OF ALL TRACKS + TRKORI(I)= BARY(I) - (NPO2+1) * ANGLE2(I) + 40 CONTINUE + DO 180 I2 = 1, NPOINT + WTD=WGD + IF(I2 .EQ. NPOINT) THEN + WTD=WLD + ENDIF + ANN = 0.0 + DO 50 J = 1, 2 + TRKORI(J)= TRKORI(J) + ANGLE2(J) + ANN= ANN + (TRKORI(J)-BARY(J))**2 + 50 CONTINUE +* +* ELIMINATE TRACKS OUTSIDE CIRCUMSCRIBED CIRCLE + IF( ANN.GT.R2CIRC ) GO TO 180 +*---- +* Start test print +* +* WRITE(IOUT,7002) I2,I3,(TRKORI(JJ),JJ=1,3) +*7002 FORMAT(' ORIGINE MESH:',I10,5X,I10,5X,3(F11.5)) +* Finish test print +*---- +* +* WHICH EXTERNAL SURFACES DO THIS TRACK CROSS ? + NTTRK=NTTRK+1 + CALL XELLSR( NDIM, NTOTCL, NSUR, MAXR, REMESH, + > INDEL, MINDIM, MAXDIM, ICOORD, ICUR, INCR, + > TRKORI, TRKDIR, TRKCUT, NSCUT, NCROS, + > TOTLEN) +* +* WHEN NOT SURFACES ARE CROSSED, ELIMINATE THE TRACK + IF( NCROS.LT.2 ) GO TO 180 + DO 70 K= 1, NDIM + TRKBEG(K)= TRKCUT(K,1) + TRKEND(K)= TRKCUT(K,2) + 70 CONTINUE + DO 75 K= 1, 4 + NSBEG(K)= NSCUT(1) + NSEND(K)= NSCUT(2) + 75 CONTINUE + IF( NCUTOF.NE.1 )THEN + DO 77 K= 1, 2 + DO 76 K3= 1, 2 + TORIC(K3)= TRKORI(K3)+TCUTOF(K3,K) + 76 CONTINUE + CALL XELLSR( NDIM, NTOTCL, NSUR, MAXR, REMESH, + > INDEL, MINDIM, MAXDIM, ICOORD, ICUR, INCR, + > TORIC, TRKDIR, TRKCUT, NSCUT, NCROS, + > TOTXXX) + IF(NSCUT(1).NE.0) NSBEG(K)= NSCUT(1) + IF(NSCUT(2).NE.0) NSEND(K)= NSCUT(2) + 77 CONTINUE + ENDIF + CALL XELLIN( NDIM, NTOTCL, MAXR, REMESH, + > NSUR, NVOL, INDEL, MINDIM, MAXDIM, + > ICOORD, ICUR, INCR, TRKBEG, TRKEND, TRKDIR, + > PROJC2, TOTLEN, + > CONV, LINMAX, LENGHT, NUMERO, LINE) + NOTRAK= NOTRAK+1 +* + WRITE(IFTEMP) 1,LINE+2*NCUTOF,WEIGHT*WTA*WTD,IANG, + > (NSBEG(ISB),ISB=1,NCUTOF), + > (NUMERO(I),I=1,LINE), + > (NSEND(ISE),ISE=1,NCUTOF), + > ( DBLE(1.0/NCUTOF),ISB=1,NCUTOF), + > (LENGHT(I),I=1,LINE), + > ( DBLE(1.0/NCUTOF),ISE=1,NCUTOF) + IF( IPRT.GT.10000)THEN + WRITE(IOUT,6001) NOTRAK, + > NCUTOF,(TRKBEG(JC),JC=1,3), + > NCUTOF,(TRKEND(JC),JC=1,3), + > (TRKDIR(JC),JC=1,3) + WRITE(IOUT,6002) (1.0/NCUTOF,NSBEG(ISB),ISB=1,NCUTOF), + > (LENGHT(I), NUMERO(I),I=1,LINE), + > (1.0/NCUTOF,NSEND(ISE),ISE=1,NCUTOF) + ENDIF + 180 CONTINUE + 290 CONTINUE + IF( IPRT.GT.1 )THEN + WRITE(IOUT,'(1H )') + WRITE(IOUT,'(27H0ECHO = TRACKING PROPERTIES )') + WRITE(IOUT,'( 8H0ECHO = ,I3,20H ANGLES AND DENSITY:, + > F9.3,4H/CM )') + > NANGLS, DENUSR + WRITE(IOUT,'( 8H0ECHO = ,I10,3H / ,I10, + > 23H TRACKS STORED ON TAPE ,I2/)') + > NOTRAK,NTTRK,IFTEMP + ENDIF + RETURN +* + 6001 FORMAT(' #',I8,1P,' B',I1,'(',2(E10.2,','),E10.2,')', + > ' E',I1,'(',2(E10.2,','),E10.2,')', + > ' D(',2(E10.2,','),E10.2,')' ) + 6002 FORMAT(1P,5(1X,E15.7,1X,I6)) + 6003 FORMAT(' '/ + > ' ECHO = ',I3,' ANGLES TO BE TRACKED IN RANGE 0 TO PI') + 6004 FORMAT(' ',I3,' ANGLES IN RANGE 0 TO PI/2 AFTER SYMMETRY') + END diff --git a/Dragon/src/XELTI3.f b/Dragon/src/XELTI3.f new file mode 100644 index 0000000..9618bed --- /dev/null +++ b/Dragon/src/XELTI3.f @@ -0,0 +1,433 @@ +*DECK XELTI3 + SUBROUTINE XELTI3( IPRT,IFTEMP,NANGLE,DENUSR,ISYMM,ANGLES,DENSTY, + > NTOTCL,NEXTGE,MAXR,REMESH,LINMAX,RCUTOF, + > NSUR,NVOL,INDEL,MINDIM, + > MAXDIM,ICOORD,INCR,ICUR,TRKBEG,CONV,TRKDIR, + > LENGHT,NUMERO,DDENWT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Construct the sequential tape that will contain tracks for +* isotropic BC in 3-D calculation. +* +*Copyright: +* Copyright (C) 1989 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPRT intermediate printing level for output. +* IFTEMP tracking file number. +* NANGLE number of angles used in the tracking process. +* DENUSR density of tracks in the plane perpendicular +* to the tracking angles. +* ISYMM flag for symetry (1/0 for on/off): +* 2 reflection plane normal to X axis; +* 4 reflection plane normal to Y axis; +* 8 reflection plane normal to X and Y axis; +* 16 reflection plane normal to Z axis; +* 18 reflection plane normal to X and Z axis; +* 20 reflection plane normal to Y and Z axis; +* 24 reflection plane normal to X, Y and Z axis. +* ANGLES 3d angle values. +* DENSTY density of tracks angle by angle. +* NTOTCL number of cylindres of a type + 3. +* NEXTGE for tubez, nextge=1 +* MAXR max number of real mesh values in REMESH. +* REMESH real mesh values (rect/cyl). +* LINMAX max. number of track segments in a single track. +* RCUTOF cutof for corner tracking( 0.25 suggested ) +* NSUR number of surfaces. +* NVOL number of zones. +* INDEL numbering of surfaces & zones. +* MINDIM min index values for all axes (rect/cyl). +* MAXDIM max index values for all axes (rect/cyl). +* ICOORD principal axes direction (X/Y/Z) for meshes. +* ICUR current zonal location for a track segment. +* INCR increment direction for next track segment. +* TRKBEG position where a track begins. +* CONV segments of tracks. +* TRKDIR direction of a track in all axes. +* LENGHT relative lenght of each segment in a track. +* NUMERO material identification of each track segment. +* DDENWT density of tracks angle by angle. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +* +* DECLARE DUMMY ARGUMENTS + INTEGER IPRT,IFTEMP,NANGLE,NTOTCL,NEXTGE,MAXR,LINMAX, + > NSUR,NVOL + INTEGER MINDIM(NTOTCL), MAXDIM(NTOTCL), ICUR(NTOTCL), + > ICOORD(NTOTCL), INCR(NTOTCL), NUMERO(LINMAX), + > INDEL(4,*) + REAL DENUSR,REMESH(MAXR),TRKBEG(NTOTCL),TRKDIR(NTOTCL), + > CONV(NTOTCL),RCUTOF + DOUBLE PRECISION ANGLES(3,*),DENSTY(*),LENGHT(LINMAX), + > DDENWT(NANGLE) + INTEGER ISYMM + INTEGER IQUART(4) +* +* DECLARE LOCAL VARIABLES + REAL TRKEND(3), TRKORI(3), TRKOR2(3), PROJC2(3), + > ANGEQN(3,3), ANGLE2(3), ANGLE3(3), BARY(3), + > TRKCUT(3,2), TCUTOF(3,4), TORIC(3) + INTEGER NSBEG(4), NSEND(4), NSCUT(2) + LOGICAL LANGLE + EQUIVALENCE ( ANGEQN(1,2), ANGLE2 ), ( ANGEQN(1,3), ANGLE3 ) + CHARACTER TEDATA*13 + INTEGER NPAN, IOUT + PARAMETER ( NPAN=3, IOUT=6 ) +* + INTEGER NDIM, I, J, NPOINT, NPO2, NCUTOF, + > NOTRAK, NSOLAN, IANG, ISB, + > NANGLS, IPAN, NESTIM, JANG, IX, IY, IREF1, I2, I3, + > NSOLMX, NTTRK, IANG0, NDEBS, N, IZZ, IANGL, K, K3, + > NCROS, LINE, JC, ISE, IDIM + REAL ANORM2, A, B, DENLIN, RCIRC, R2CIRC, DP, + > SURTOT, VOLTOT, DEPART, X, Y, ANN, ODDNXT, + > TOTLEN, TOTXXX, DDENST + REAL DZ,ZMAX + DOUBLE PRECISION WEIGHT, WZ +* + ANORM2( A, B ) = A*A + B*B + NDIM= 3 +* +* ONE WEIGHT FOR ALL TRACKS +* DENLIN= # OF TRACKS / CM + DENLIN= SQRT(DENUSR) +* +* COMPUTE THE CIRCUMSCRIBED RADIUS AND +* THE COORDINATES FOR THE TRUE CENTER OF THE CELL + R2CIRC= 0.0 + DO 10 I = 1, 3 + BARY(I)= 0.5 * (REMESH(MAXDIM(I)) + REMESH(MINDIM(I))) + IF( NEXTGE.EQ.1 )THEN + CALL XABORT('XELTI3: TUBEZ NOT SUPPORTED') + ELSE + R2CIRC = R2CIRC + > + (REMESH(MAXDIM(I)) - REMESH(MINDIM(I)))**2 + ENDIF + 10 CONTINUE + ZMAX=MAX(ABS(REMESH(MAXDIM(3))),ABS(REMESH(MINDIM(3)))) + R2CIRC= 0.25 * R2CIRC + RCIRC = SQRT(R2CIRC) +* +* NPOINT= # OF TRACKS ALONG ONE PERPENDICULAR AXIS + NPOINT= INT( 2. * RCIRC * DENLIN ) +***** BEWARE ***** BEWARE ***** BEWARE ***** BEWARE ***** BEWARE ***** +***** CHANGE THIS "NPOINT" PARAMETER HAS TREMENDOUS EFFECTS ON TRACKING +***** BEWARE ***** BEWARE ***** BEWARE ***** BEWARE ***** BEWARE ***** +* +* OTHER POSSIBLE CHOICES (EXPLORED WITHOUT SUCCESS) ARE ==> +*1-) NPOINT= INT( 2. * RCIRC * DENLIN ) + 1 +*2-) NPOINT= NINT( 2. * RCIRC * DENLIN ) +*3-) NPOINT= NINT( 2. * RCIRC * DENLIN ) + 1 +* +* KEEP "NPOINT" ODD & CORRECT DENSITY + NPO2 = NPOINT / 2 + NPOINT= 2 * NPO2 + 1 + DP = 2. * RCIRC / NPOINT + DENLIN= 1. / DP + DENUSR= DENLIN**2 + ODDNXT= (2*NPO2+3) / (2.*RCIRC) + IF( RCUTOF.EQ.0.0 )THEN + NCUTOF= 1 + ELSE + NCUTOF= 4 + ENDIF + NOTRAK= 0 + SURTOT= 0.0 + VOLTOT= 0.0 + IQUART(1)=1 + IQUART(2)=1 + IQUART(3)=1 + IQUART(4)=1 + IF(NEXTGE .EQ. 1) THEN + IQUART(2)=0 + IQUART(3)=0 + IQUART(4)=0 + NSOLAN= (NANGLE * (NANGLE + 2)) / 2 + ELSE + IF( ISYMM .EQ. 8 .OR. ISYMM .EQ. 24 )THEN + NSOLAN= (NANGLE * (NANGLE + 2)) / 8 + IQUART(2)=0 + IQUART(3)=0 + IQUART(4)=0 + ELSE IF( ISYMM .EQ. 4 .OR. ISYMM .EQ. 20 )THEN + NSOLAN= (NANGLE * (NANGLE + 2)) / 4 + IQUART(2)=0 + IQUART(4)=0 + ELSE IF( ISYMM .EQ. 2 .OR. ISYMM .EQ. 18 )THEN + NSOLAN= (NANGLE * (NANGLE + 2)) / 4 + IQUART(3)=0 + IQUART(4)=0 + ELSE + NSOLAN= (NANGLE * (NANGLE + 2)) / 2 + ENDIF + ENDIF + DDENST= 1.0/(NPAN*DENUSR) + NANGLS= (NANGLE * (NANGLE + 2)) / 2 + CALL XELEQN( 3, 0, ANGEQN ) + IANG= 0 + DO 15 JANG= 1, NANGLS + DO 16 IPAN= 1, NPAN + CALL XELEQN( 3, NANGLE, ANGEQN ) + 16 CONTINUE + IF(IQUART(MOD(JANG-1,4)+1).NE.1 ) GO TO 15 + IANG= IANG+1 + DENSTY(IANG)= REAL(2*NSOLAN) + ANGLES(1,IANG)= ANGEQN(1,1) + ANGLES(2,IANG)= ANGEQN(2,1) + ANGLES(3,IANG)= ANGEQN(3,1) + 15 CONTINUE +* +* COPY ANGLES AND DENSITIES ON TEMPORARY TRACKING FILE + WRITE(IFTEMP) ((ANGLES(IDIM,IANG),IDIM=1,NDIM),IANG=1,NSOLAN) + WRITE(IFTEMP) (DENSTY(IANG) ,IANG=1,NSOLAN) +* +* TO REINITIATE THE EQN ANGLES + CALL XELEQN( 3, 0, ANGEQN ) + IF( NEXTGE.EQ.1 )THEN + DDENST= 12.0*DDENST + ENDIF + WEIGHT= 0.5*DDENST/DBLE(NSOLAN) + DO IANG= 1, NSOLAN + DDENWT(IANG)=WEIGHT + ENDDO + NSOLMX= 0 + NDEBS= 0 + IF( IPRT.GT.1 )THEN +* +* PREPARE & PRINT THE ESTIMATED NUMBER OF TRACKS + NESTIM= 0 + DEPART= - (NPO2+1) * DP + X = DEPART + DO 25 IX = 1, NPOINT + X = X + DP + Y = DEPART + DO 20 IY = 1, NPOINT + Y = Y + DP + IF( ANORM2( X, Y ) .LE. R2CIRC ) NESTIM= NESTIM + 1 + 20 CONTINUE + 25 CONTINUE + WRITE(IOUT,'(1H )') + WRITE(IOUT,'( 8H0ECHO = ,I8,20H TRACKS/AXIS/ANGLE )') + > NPOINT + WRITE(IOUT,'( 8H ECHO = ,I8,25H TRACKS/CIRCLE/ANGLE )') + > NESTIM + NESTIM= NESTIM * NPAN * NSOLAN + WRITE(IOUT,'(30H ECHO = NEXT ODD DENSITY > ,F15.7,4H/CM2)') + > ODDNXT**2 + WRITE(IOUT,'( 8H ECHO = ,28H ESTIMATED NUMBER OF TRACKS= ,I8 )') + > NESTIM +* +* PREPARE PRINTING WITH VARIABLE FORMAT + WRITE(IOUT,'(1H )') + WRITE(IOUT,'( 8H0ECHO = ,I3,27H SOLID ANGLES TO BE TRACKED )') + > NANGLS + NSOLMX= MIN(9, NANGLS/10) + IREF1 = 0 + WRITE(IOUT,'( 1H0,10(I1,9X))') (IREF1, IZZ=0,NSOLMX) + WRITE(IOUT,'( 1H ,10(I1,9X))') (MOD(IZZ,10), IZZ=0,NSOLMX) + WRITE(IOUT,'( 2H 0)') + TEDATA= '(1H+,TXXX,I1)' + ENDIF + IANG = 0 + IANG0 = 0 + NTTRK = 0 + DO 290 IANGL= 1, NANGLS + IANG=IANG+1 + IF(IQUART(MOD(IANG-1,4)+1).NE.1)THEN +*---- +* Do not track this angle because of the problem symmetry +*---- + LANGLE= .FALSE. + ELSE +*---- +* Track this angle +*---- + IANG0= IANG0+1 + LANGLE=.TRUE. + ENDIF + IF( IPRT.GT.1) THEN + IF( MOD(IANGL,100) .EQ. 0 )THEN + IREF1=IREF1+1 + NDEBS= NSOLMX+1 + NSOLMX=MIN(NDEBS+9, NANGLS/10) + WRITE(IOUT,'( 1H0,10(I1,9X))')(IREF1,IZZ=NDEBS,NSOLMX) + WRITE(IOUT,'( 1H ,10(I1,9X))') + > (MOD(IZZ,10),IZZ=NDEBS,NSOLMX) + WRITE(IOUT,'( 2H 0)') + ELSE + IF( IPRT.GT.10000.AND.MOD(IANGL,100).NE.0 )THEN + WRITE(IOUT,'( 1H ,10(I1,9X))')(IREF1,IZZ=NDEBS,NSOLMX) + WRITE(IOUT,'( 1H ,10(I1,9X))') + > (MOD(IZZ,10),IZZ=NDEBS,NSOLMX) + WRITE(IOUT,'( 2H )') + ENDIF + WRITE(TEDATA(7:9),'(I3.3)') MOD(IANGL,100) + 2 + WRITE(IOUT,TEDATA) MOD(IANGL,10) + ENDIF + ENDIF +* +* NPAN AXES DESCRIPTION (X=0.0, Y=0.0 & Z=0.0) + DO 250 IPAN= 1, NPAN +*---- +* Start tesp print +* WRITE(IOUT,7001) IANGL,IPAN +* 7001 FORMAT(' ANGLE = ',I8,5X,'PLAN =',I3) +* Finish test print +*---- + CALL XELEQN( 3, NANGLE, ANGEQN ) + IF(.NOT.LANGLE) GO TO 250 + IF( NEXTGE.EQ.1 )THEN + IF( IPAN.NE.2 ) GO TO 250 + ENDIF + DO 30 I = 1, 3 + N = ICOORD(I) + TRKDIR(N)= ANGEQN(N,1) + INCR(I)= +1 + IF( TRKDIR(N) .LT. 0.0 ) INCR(I)= -1 +* +* MODIFY ANGLES TO TAKE INTO ACCOUNT DP + ANGLE2(I)= DP * ANGLE2(I) + ANGLE3(I)= DP * ANGLE3(I) + IF( NCUTOF.NE.1 )THEN + TCUTOF(I,1)= RCUTOF*( ANGLE2(I)+ ANGLE3(I) ) + TCUTOF(I,2)= RCUTOF*( ANGLE2(I)- ANGLE3(I) ) + TCUTOF(I,3)= -TCUTOF(I,2) + TCUTOF(I,4)= -TCUTOF(I,1) + ENDIF +* +* DETERMINE THE ORIGIN OF ALL TRACKS + TRKOR2(I)= BARY(I) - (NPO2+1)*(ANGLE2(I)+ANGLE3(I)) + 30 CONTINUE + DO 45 I = 1, 3 + PROJC2(I)= 0.0 + DO 40 J = 1, 3 + IF( I.EQ.J ) GO TO 40 + PROJC2(I)= PROJC2(I) + TRKDIR(J) * TRKDIR(J) + 40 CONTINUE + 45 CONTINUE +* +* SCAN ALL TRACKS IN THE PERPENDICULAR PLANE + DO 180 I2 = 1, NPOINT + DO 50 J = 1, 3 + TRKOR2(J)= TRKOR2(J) + ANGLE2(J) + TRKORI(J)= TRKOR2(J) + 50 CONTINUE + DO 170 I3 = 1, NPOINT + ANN = 0.0 + DO 60 J = 1, 3 + TRKORI(J)= TRKORI(J) + ANGLE3(J) + ANN= ANN + (TRKORI(J)-BARY(J))**2 + 60 CONTINUE +*---- +* Start tesp print +* WRITE(IOUT,7002) I2,I3,(TRKORI(K)-BARY(K),K=1,NDIM) +*7002 FORMAT(' ORIGINE MESH:',I10,5X,I10,5X,3(F11.5)) +* Finish test print +*---- + WZ=1.0D0 + DZ=(TRKORI(3)-BARY(3))/ZMAX +*---- +* Start Z reflection symmetry +* +* IF(ISYMM .GE. 16) THEN +* IF (ABS(DZ) .LT. 1.0E-6) THEN +* WRITE(IOUT,'(A10)') 'ZERO Z ' +* ELSE IF(DZ .LT. 0.0) THEN +* WRITE(IOUT,'(A10)') 'NEGATIVE Z' +* GO TO 170 +* ELSE +* WRITE(IOUT,'(A10)') 'POSITIVE Z' +* WZ=2.0 +* ENDIF +* ENDIF +* Finish Z reflection symmetry +*---- +* +* ELIMINATE TRACKS OUTSIDE CIRCUMSCRIBED CIRCLE + IF( ANN.GT.R2CIRC ) GO TO 170 +* +* WHICH EXTERNAL SURFACES DO THIS TRACK CROSS ? + NTTRK=NTTRK+1 + CALL XELLSR( NDIM, NTOTCL, NSUR, MAXR, REMESH, + > INDEL, MINDIM, MAXDIM, ICOORD, ICUR, INCR, + > TRKORI, TRKDIR, TRKCUT, NSCUT, NCROS, + > TOTLEN) +* +* WHEN NOT SURFACES ARE CROSSED, ELIMINATE THE TRACK + IF(NCROS.LT.2) GO TO 170 + DO 70 K= 1, NDIM + TRKBEG(K)= TRKCUT(K,1) + TRKEND(K)= TRKCUT(K,2) + 70 CONTINUE + DO 75 K= 1, 4 + NSBEG(K)= NSCUT(1) + NSEND(K)= NSCUT(2) + 75 CONTINUE + IF( NCUTOF.NE.1 )THEN + DO 77 K= 1, 4 + DO 76 K3= 1, 3 + TORIC(K3)= TRKORI(K3)+TCUTOF(K3,K) + 76 CONTINUE + CALL XELLSR( NDIM, NTOTCL, NSUR, MAXR, REMESH, + > INDEL, MINDIM, MAXDIM, ICOORD, ICUR, INCR, + > TORIC, TRKDIR, TRKCUT, NSCUT, NCROS, + > TOTXXX) + IF(NSCUT(1).NE.0) NSBEG(K)= NSCUT(1) + IF(NSCUT(2).NE.0) NSEND(K)= NSCUT(2) + 77 CONTINUE + ENDIF + CALL XELLIN( NDIM, NTOTCL, MAXR, REMESH, + > NSUR, NVOL, INDEL, MINDIM, MAXDIM, + > ICOORD, ICUR, INCR, TRKBEG, TRKEND, TRKDIR, + > PROJC2, TOTLEN, + > CONV, LINMAX, LENGHT, NUMERO, LINE) + NOTRAK= NOTRAK+1 +* + WRITE(IFTEMP) 1,LINE+2*NCUTOF,WEIGHT*WZ,IANG0, + > (NSBEG(ISB),ISB=1,NCUTOF), + > (NUMERO(I),I=1,LINE), + > (NSEND(ISE),ISE=1,NCUTOF), + > ( DBLE(1.0/NCUTOF),ISB=1,NCUTOF), + > (LENGHT(I),I=1,LINE), + > ( DBLE(1.0/NCUTOF),ISE=1,NCUTOF) + IF( IPRT.GT.10000)THEN + WRITE(IOUT,6001) NOTRAK, + > NCUTOF,(TRKBEG(JC),JC=1,3), + > NCUTOF,(TRKEND(JC),JC=1,3), + > (TRKDIR(JC),JC=1,3) + WRITE(IOUT,6002) (1.0/NCUTOF,NSBEG(ISB),ISB=1,NCUTOF), + > (LENGHT(I), NUMERO(I),I=1,LINE), + > (1.0/NCUTOF,NSEND(ISE),ISE=1,NCUTOF) + ENDIF + 170 CONTINUE + 180 CONTINUE + 250 CONTINUE + 290 CONTINUE + IF( IPRT.GT.1 )THEN + WRITE(IOUT,'(1H )') + WRITE(IOUT,'(27H0ECHO = TRACKING PROPERTIES )') + WRITE(IOUT,'( 8H0ECHO = ,I3,20H ANGLES AND DENSITY:, + > F9.3,4H/CM2)') + > NANGLE, DENUSR + WRITE(IOUT,'( 8H0ECHO = ,I10,3H / ,I10, + > 23H TRACKS STORED ON TAPE ,I2/)') + > NOTRAK,NTTRK,IFTEMP + ENDIF +* + RETURN + 6001 FORMAT(' #',I8,1P,' B',I1,'(',2(E10.2,','),E10.2,')', + > ' E',I1,'(',2(E10.2,','),E10.2,')', + > ' D(',2(E10.2,','),E10.2,')' ) + 6002 FORMAT(1P,5(1X,E15.7,1X,I6)) + END diff --git a/Dragon/src/XELTRK.f b/Dragon/src/XELTRK.f new file mode 100644 index 0000000..4f36c62 --- /dev/null +++ b/Dragon/src/XELTRK.f @@ -0,0 +1,541 @@ +*DECK XELTRK + SUBROUTINE XELTRK(IPTRK ,IPGEOM,GEONAM,IDISP ,IFTEMP, + > IPRT ,NDIM ,ITOPT ,NV ,NS ,NANGL , + > ISYMM ,DENUSR,RCUTOF,MXSUB ,MXSEG ,ICODE , + > TITREC,INSB ,IZ ,LPRISM,NPRISM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Treat Cartesian assemblies of cells using a two-step process: +* 1) study the geometry to get volumes and materials; +* 2) produce temporary tracking file if necessary. +* +*Copyright: +* Copyright (C) 1993 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPTRK pointer to the tracking (l_track). +* IPGEOM pointer to the geometry (l_geom). +* GEONAM geometry name. +* IFTEMP unit number allocated to temporary file. +* IPRT geometry print level. +* NDIM number of dimensions (2.or.3). +* RCUTOF cutof for corner tracking(0.25 suggested). +* TITREC title for this case. +* INSB control on vectorization. +* IZ projection axis for 3d prismatic geometry. +* LPRISM flag for 3d prismatic geometry. +* +*Parameters: input/output +* ITOPT kind of tracking (0: isotropic; 1: specular). +* IDISP status of tracking file (>0 means new file) +* ISYMM symmetry factor. +* DENUSR density of tracks in the plane perpendicular +* to the tracking angles. +* +*Parameters: output +* NV number of zones in the assembly. +* NS number of surfaces in the assembly. +* NANGL number of angles used in temporary tracking file. +* MXSUB maximum number of subtracks in a single track. +* MXSEG maximum number of segments in a single track. +* ICODE index for boundary conditions. +* NPRISM numer of plans for a 3d prismatic geometry. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE + TYPE(C_PTR) IPTRK ,IPGEOM + INTEGER IDISP ,IFTEMP,IPRT ,NDIM ,ITOPT ,NV ,NS , + > NANGL ,ISYMM ,MXSUB ,MXSEG ,INSB ,IZ ,NPRISM + LOGICAL LPRISM + REAL DENUSR,RCUTOF + CHARACTER GEONAM*12, TITREC*72 + INTEGER ICODE(6) +* + INTEGER NSTATE, IOUT + PARAMETER ( NSTATE=40, IOUT=6) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KEYMRG,MATALB,MINDIM,MAXDIM, + > ICORD,INDEX,ICUR,INCR,NUMERO + REAL, ALLOCATABLE, DIMENSION(:) :: VOLSUR,REMESH,CONV,TRKBEG, + > TRKDIR + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: ANGLES,DENSTY, + > LENGHT,DDENWT +*---- +* LOCAL PARAMETERS +*---- + INTEGER LTRK ,NANGLE,SUBMAX,LINMAX + INTEGER NSUR ,NVOL ,NTOTCL,MAXR ,NUNK ,NEXTGE + INTEGER NTX ,NTY ,NTZ ,NTR ,ICL ,NC , + > NALBG ,JJ ,INDLEC,ITYLCM,ILENGT,INDATA, + > NCOR + INTEGER NCODE(6), LCLSYM(3), ISTATE(NSTATE) + LOGICAL SWZERO + REAL ALBEDO(6), EXTKOP(NSTATE), CUTOFX, REDATA + DOUBLE PRECISION DBLINP + CHARACTER CTISO*8, CTSPC*8, CCORN*8, CSYMM*8, CMEDI*8, + > CHALT*8, CBLAN*8, TEDATA*8, CTRK*4, COMENT*80 + INTEGER MXANGL +* + SAVE CTISO, CTSPC, CCORN, CHALT, CSYMM, CMEDI, CBLAN + DATA CTISO, CTSPC, CCORN, CHALT, CSYMM, CMEDI, CBLAN + > / 'TISO','TSPC','CORN','HALT','SYMM','MEDI',' ' / +* + SWZERO=.TRUE. + ISTATE(:NSTATE)=0 + EXTKOP(:NSTATE)=0.0 + CALL LCMLEN(IPTRK,'STATE-VECTOR',ILENGT,ITYLCM) + IF(ILENGT .LE. 0 .OR. ILENGT .GT. NSTATE) THEN + LTRK = 0 + NANGLE= 0 + ISYMM=1 + DENUSR= 0.0 + RCUTOF= 0.0 + ELSE + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + CALL LCMGET(IPTRK,'EXCELTRACKOP',EXTKOP) + LTRK=ISTATE(9)+1 + NANGLE=ISTATE(11) + ISYMM=ISTATE(12) + DENUSR=EXTKOP(2) + RCUTOF=EXTKOP(3) + ENDIF + CUTOFX= 0.0 +* +*. 1) READ ALL USER INPUT. +* +* READ TRACKING PARAMETERS LTRK= 1 : ISOTROPIC TRACKING (TISO) +* LTRK= 2 : SPECULAR TRACKING (TSPC) + TEDATA= CBLAN + IF( IDISP.GT.0 )THEN + CALL REDGET( INDLEC, NANGLE, DENUSR, TEDATA,DBLINP) + IF( ILENGT.NE.0 )THEN + IF( INDLEC.EQ.3.AND.TEDATA(1:4).EQ.';' )THEN + GO TO 10 + ENDIF + ENDIF + IF( TEDATA(1:4).EQ.CCORN(1:4) ) THEN + CALL REDGET( INDLEC, INDATA, RCUTOF, TEDATA,DBLINP) + CALL REDGET( INDLEC, NANGLE, DENUSR, TEDATA,DBLINP) + ENDIF + IF( INDLEC.NE.3 )THEN + LTRK = 1 + CALL REDGET( INDLEC, NANGLE, DENUSR, TEDATA,DBLINP) + IF( INDLEC.EQ.3 )THEN + CALL XABORT('XELTRK: *TISO* ASSUMED, PUT NANGLE & DENSTY' ) + ENDIF + CALL REDGET( INDLEC, INDATA, REDATA, TEDATA,DBLINP) + ELSE + IF( TEDATA(1:4).EQ.CTISO(1:4) )THEN + LTRK = 1 + ELSEIF( TEDATA(1:4).EQ.CTSPC(1:4) )THEN + LTRK = 2 + ENDIF + IF( LTRK.GT.0 )THEN + CALL REDGET( INDLEC, NANGLE, DENUSR, TEDATA,DBLINP) + IF( LTRK.EQ.2.AND.TEDATA(1:4).EQ.CMEDI(1:4) )THEN + SWZERO= .FALSE. + CALL REDGET( INDLEC, NANGLE, DENUSR, TEDATA,DBLINP) + ENDIF + CALL REDGET( INDLEC, NANGLE, DENUSR, TEDATA,DBLINP) + CALL REDGET( INDLEC, INDATA, REDATA, TEDATA,DBLINP) + ELSE + IF( TEDATA(1:4).EQ.CHALT(1:4) )THEN + CALL REDGET( INDLEC, INDATA, REDATA, TEDATA,DBLINP) + IDISP = -2 + ELSE + CALL XABORT( 'XELTRK: *TISO*,*TSPC*,*HALT* HERE') + ENDIF + ENDIF + ENDIF + IF( INDLEC.NE.3 )THEN + CALL XABORT( 'XELTRK: ; SYMM or NOSYMM PERMITTED' ) + ELSEIF( TEDATA(1:4) .EQ. 'NOSY' )THEN + ISYMM=0 + CALL REDGET( INDLEC, INDATA, REDATA, TEDATA,DBLINP) + ELSEIF( TEDATA(1:4).EQ.CSYMM(1:4) )THEN + CALL REDGET( INDLEC, INDATA, REDATA, TEDATA,DBLINP) + IF(INDLEC.NE.1) CALL XABORT('XELTRK: INTEGER DATA EXPECTED') + ISYMM=INDATA + CALL REDGET( INDLEC, INDATA, REDATA, TEDATA,DBLINP) + ENDIF + IF( INDLEC.NE.3.OR.TEDATA(1:4).NE.';' )THEN + CALL XABORT( 'XELTRK: ; IS SUPPOSED TO BE HERE' ) + ENDIF + IF( LTRK.GT.0.AND.NANGLE.LE.1 )THEN + CALL XABORT( 'XELTRK: INVALID NUMBER OF ANGLES (NANGLE < 2)' ) + ENDIF + IF( LTRK.GT.0.AND.DENUSR.LE.0.0 )THEN + CALL XABORT( 'XELTRK: INVALID DENSITY (DENSTY < 0.0) ' ) + ENDIF + ENDIF + 10 CONTINUE +*---- +* PROCESS THE GEOMETRY +*---- + CALL AXGXEL(IPGEOM,IPTRK ,IPRT ,GEONAM) + IF(IPRT .GE. 1)THEN + WRITE(IOUT,'(1H )') + WRITE(IOUT,'(26H >>> GEOMETRY TREATED: ,A12)') GEONAM + WRITE(IOUT,'(26H >>> EXCELL TREATMENT <<< )') + WRITE(IOUT,'(1H )') + ENDIF +*---- +* SAVE EXCELL SPECIFIC TRACKING INFORMATION. +*---- + ISTATE(9)=LTRK-1 + ISTATE(11)=NANGLE + ISTATE(12)=ISYMM + CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,ISTATE) + EXTKOP(1)=CUTOFX + EXTKOP(2)=DENUSR + EXTKOP(3)=RCUTOF + CALL LCMPUT(IPTRK,'EXCELTRACKOP',NSTATE,2,EXTKOP) +*---- +* IF A PRISMATIC 3D TRACKING IS REQUESTED, +* CREATE 2D PROJECTED GEOMETRY ANALYSIS +*---- + IF (LPRISM) THEN + CALL XELPR3(IPTRK,IZ,NPRISM) + CALL LCMSIX(IPTRK,'PROJECTION ',1) + CALL LCMSIX(IPTRK,'EXCELL ',1) + ELSE + CALL LCMSIX(IPTRK,'EXCELL ',1) + ENDIF +*---- +* ALLOCATE GEOMETRIC STRUCTURES (SEE COMMON CEXGEO) +* KEYMRG : INTEGER MERGE VECTOR +* VOLSUR : REAL VOLUME-SURFACE VECTOR +* MATALB : INTEGER MATERIAL-FACE VECTOR +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + NDIM =ISTATE(1) + NSUR =-ISTATE(2) + NVOL =ISTATE(3) + NTOTCL =ISTATE(4) + MAXR =ISTATE(5) + NUNK =ISTATE(6) + NEXTGE =ISTATE(7) + ALLOCATE(KEYMRG(NUNK),MATALB(NUNK),VOLSUR(NUNK)) + CALL LCMGET(IPTRK,'KEYMRG ',KEYMRG) + CALL LCMGET(IPTRK,'MATALB ',MATALB) + CALL LCMGET(IPTRK,'VOLSUR ',VOLSUR) + CALL LCMSIX(IPTRK,'EXCELL ',2) + CALL LCMGET(IPTRK,'ICODE ',ICODE ) + CALL LCMGET(IPTRK,'NCODE ',NCODE ) + CALL LCMGET(IPTRK,'ALBEDO ',ALBEDO) + NV= NVOL + NS= -NSUR + ITOPT=LTRK-1 + NANGL=0 +*---- +* EXCELL-TYPE VECTORIZATION - THE TRACKING FILE IS NOT COMPUTED +*---- + IF(INSB.EQ.2) RETURN +*---- +* Intrinsic symmetries used in geometry +* Use these to simplify tracking unless +* NOSYMM tracking option activated +*---- + LCLSYM(1) =ISTATE(8) + LCLSYM(2) =ISTATE(9) + LCLSYM(3) =ISTATE(10) + IF(ISYMM .NE. 0) THEN + ISYMM=0 + IF(NDIM .EQ. 2) THEN + IF(LCLSYM(1) .NE. 0) THEN +*---- +* X SYMMETRY +*---- + ISYMM=2 + ENDIF + IF(LCLSYM(2) .NE. 0) THEN + IF(ISYMM .EQ. 0) THEN +*---- +* Y SYMMETRY +*---- + ISYMM=4 + ELSE +*---- +* X AND Y SYMMETRY +*---- + ISYMM=8 + ENDIF + ENDIF +*C IF(ISTATE(11) .NE. 0) THEN +*CC---- +*CC X-Y DIAGONAL SYMMETRY +*CC---- +*C IF(ISYMM .EQ. 0) THEN +*C ISYMM=10 +*C ELSE +*C ISYMM=12 +*C ENDIF +*C ENDIF + ELSE + IF(LCLSYM(1) .NE. 0) THEN +*---- +* X SYMMETRY +*---- + ISYMM=2 + ENDIF + IF(LCLSYM(2) .NE. 0) THEN + IF(ISYMM .EQ. 0) THEN +*---- +* Y SYMMETRY +*---- + ISYMM=4 + ELSE +*---- +* X AND Y SYMMETRY +*---- + ISYMM=8 + ENDIF + ENDIF + IF(LCLSYM(3) .NE. 0) THEN +*---- +* Z SYMMETRY +*---- + ISYMM=ISYMM+16 + ENDIF + ENDIF + IF(ISYMM .EQ. 0) ISYMM=1 + ENDIF +*---- +* READ THE GEOMETRY INFORMATION STORED ON IPTRK +*---- + SUBMAX= 0 + LINMAX= 0 + CALL LCMSIX(IPTRK,'EXCELL ',1) + ALLOCATE(MINDIM(NTOTCL),MAXDIM(NTOTCL),ICORD(NTOTCL), + > INDEX(4*NUNK)) + ALLOCATE(REMESH(MAXR)) + CALL LCMGET(IPTRK,'MINDIM ',MINDIM) + CALL LCMGET(IPTRK,'MAXDIM ',MAXDIM) + CALL LCMGET(IPTRK,'ICORD ',ICORD ) + CALL LCMGET(IPTRK,'INDEX ',INDEX ) + CALL LCMGET(IPTRK,'REMESH ',REMESH) + CALL LCMSIX(IPTRK,'EXCELL ',2) + IF (LPRISM) CALL LCMSIX(IPTRK,'PROJECTION ',2) +*---- +* VERIFY SYMMETRY AND +* STUDY TRACKING PARAMETERS. ARE THEY BASICALLY POSSIBLE ? +*---- + MXANGL=0 + IF(LTRK .EQ. 1)THEN + NCOR= 1 + IF(NDIM .EQ. 2) THEN + MXANGL=NANGLE +*C IF(ISYMM .EQ. 12) THEN +*C NANGL = NANGLE/4 + IF(ISYMM .GE. 2) THEN + NANGL = (NANGLE+1)/2 + ELSE + NANGL = NANGLE + ENDIF + IF( RCUTOF.GT.0.0 ) NCOR= 2 + ELSE IF(NDIM .EQ. 3) THEN + IF(MOD(NANGLE,2) .EQ. 1)THEN + NANGLE=NANGLE+1 + WRITE(IOUT,'(/31H MESS = ONLY EVEN # EQN ANGLES )') + ENDIF + IF(NANGLE .GT. 16)THEN + NANGLE=16 + WRITE(IOUT,'(/31H MESS = 16 IS MAX # EQN ANGLES )') + ENDIF + MXANGL=(NANGLE * (NANGLE+2)) / 2 + IF(NEXTGE .EQ. 1) THEN + NANGL = (NANGLE * (NANGLE+2)) / 8 + ELSE + IF(ISYMM .EQ. 8 .OR. ISYMM .EQ. 24) THEN + NANGL = (NANGLE * (NANGLE+2)) / 8 + ELSE IF(ISYMM .EQ. 2 .OR. ISYMM .EQ. 4 .OR. + > ISYMM .EQ. 18 .OR. ISYMM .EQ. 20 ) THEN + NANGL = (NANGLE * (NANGLE+2)) / 4 + ELSE + NANGL = (NANGLE * (NANGLE+2)) / 2 + ENDIF + ENDIF + IF(RCUTOF .GT. 0.0) NCOR= 4 + ENDIF + ELSEIF( LTRK.EQ.2 )THEN + NCOR = 1 + IF(NANGLE .GT. 24) THEN + NANGLE=30 + ELSE IF(NANGLE .GT. 20) THEN + NANGLE=24 + ELSE IF(NANGLE .GT. 18) THEN + NANGLE=20 + ELSE IF(NANGLE .GT. 14) THEN + NANGLE=18 + ELSE IF(NANGLE .GT. 12) THEN + NANGLE=14 + ELSE IF(NANGLE .GT. 8) THEN + NANGLE=12 + ELSE + NANGLE=8 + ENDIF + MXANGL=4*NANGLE + ISTATE(11)=NANGLE + CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,ISTATE) + IF( NDIM.EQ.2 )THEN + NANGL = 4*NANGLE + ELSEIF( NDIM.EQ.3 )THEN + CALL XABORT('XELTRK: *TSPC* NOT AVAILABLE FOR 3-D GEOMETRY') + ENDIF + CUTOFX= RCUTOF + ENDIF + IF(IPRT .GT. 1 .AND. NEXTGE .EQ. 0)THEN +*---- +* IF PRINT REQUIRED AND OVERALL CARTESIAN GEOMETRY +* PRINT CARTESIAN REGION MAP +*---- + NTX= MAXDIM(1)-MINDIM(1) + NTY= MAXDIM(2)-MINDIM(2) + NTZ= MAXDIM(3)-MINDIM(3) + NTR=0 + DO 103 ICL=3,NTOTCL-1 + NTR= MAX(NTR,MAXDIM(ICL+1)-MINDIM(ICL+1)+1) + 103 CONTINUE + CALL XELGPR(NDIM,NTX,NTY,NTZ,NTR,ISYMM,NSUR,NVOL,NTOTCL, + > MINDIM,MAXDIM,KEYMRG,INDEX,MATALB) + ENDIF +* +*. 3) DO THE TRACKING OF THE EXACT GEOMETRY FOR *NEWT* OPTION. + IF( IDISP.GT.0.AND.LTRK.NE.0 )THEN + NC= NTOTCL - 3 + IF( IPRT.GE.1 )THEN + WRITE(IOUT,'(1H )') + IF ( NC.EQ.0 )THEN + WRITE(IOUT,'(/21H NOW, TRACKING >>> ,A12, + > 13H GEOMETRY <<<, + > 13H (WITH NO,11H CYLINDER ) /)') + > GEONAM + ELSEIF( NC.EQ.1 )THEN + WRITE(IOUT,'(/21H NOW, TRACKING >>> ,A12, + > 13H GEOMETRY <<<, + > 13H (WITH ONE,11H CYLINDER ) /)') + > GEONAM + ELSE + WRITE(IOUT,'(/21H NOW, TRACKING >>> ,A12, + > 13H GEOMETRY <<<, + > 10H (WITH ,I3,11H CYLINDERS) /)') + > GEONAM, NC + ENDIF + ENDIF + ALLOCATE(ICUR(NTOTCL),INCR(NTOTCL)) + ALLOCATE(CONV(NTOTCL),TRKBEG(NTOTCL),TRKDIR(NTOTCL)) +* +* 3.0) WRITE FIRST RECORDS OF THE UNNORMALIZED TRACKING FILE + IF( LTRK.EQ.1 )THEN + SUBMAX= 1 + LINMAX= 2*NVOL + 10 + ELSE +* +* REQUIRED CHANGE LINMAX FROM 2*NANGL*(2*NVOL + 8) +* TO 2*NANGL*(2*NVOL + 16) +* TO TAKE INTO ACCOUNT INITIAL AND FINAL SURFACE +* FOR PERIODIC BC + SUBMAX= NANGL + LINMAX= 2*NANGL*(2*NVOL + 16) + ENDIF + CTRK = '$TRK' + NALBG = 6 + WRITE(IFTEMP) CTRK,5,0,0 + COMENT='CREATOR : DRAGON' + WRITE(IFTEMP) COMENT + COMENT='MODULE : XELTRK' + WRITE(IFTEMP) COMENT + COMENT='TYPE : CARTESIAN' + WRITE(IFTEMP) COMENT + COMENT='GEOMETRY : '//GEONAM + WRITE(IFTEMP) COMENT + COMENT=TITREC + WRITE(IFTEMP) COMENT + WRITE(IFTEMP) NDIM,ITOPT,NV,NS,NALBG,NCOR,NANGL,SUBMAX,LINMAX + WRITE(IFTEMP) (VOLSUR(JJ),JJ=1,NUNK) + WRITE(IFTEMP) (MATALB(JJ),JJ=1,NUNK) + WRITE(IFTEMP) ( ICODE(JJ),JJ=1,NALBG) + WRITE(IFTEMP) (ALBEDO(JJ),JJ=1,NALBG) + ALLOCATE(NUMERO(LINMAX)) + ALLOCATE(LENGHT(LINMAX),ANGLES(3*MXANGL),DENSTY(MXANGL), + > DDENWT(MXANGL)) + MXSUB= SUBMAX + MXSEG= LINMAX + IF( LTRK.EQ.1 )THEN +* +* 3.1) THE REGULAR TRACKING + IF( NDIM.EQ.3 )THEN + CALL XELTI3( IPRT,IFTEMP,NANGLE,DENUSR, ISYMM,ANGLES, + > DENSTY,NTOTCL,NEXTGE, MAXR,REMESH,LINMAX, + > RCUTOF, NSUR, NVOL, INDEX,MINDIM,MAXDIM, + > ICORD, INCR, ICUR,TRKBEG, CONV,TRKDIR, + > LENGHT, NUMERO ,DDENWT) + CALL LCMPUT(IPTRK,'TrackingDirc',2*NDIM*NANGLE,4,ANGLES) + CALL LCMPUT(IPTRK,'TrackingTrkW',2*NANGLE,4,DDENWT) + CALL LCMPUT(IPTRK,'TrackingSpaD',2*NANGLE,4,DENSTY) + ELSEIF( NDIM.EQ.2 )THEN + ICUR(3)= MINDIM(3) + CONV(3)= 1.0E+36 + CALL XELTI2( IPRT,IFTEMP,NANGLE,DENUSR, ISYMM,ANGLES, + > DENSTY,NTOTCL, MAXR,REMESH,LINMAX,RCUTOF, + > NSUR, NVOL, INDEX,MINDIM,MAXDIM, ICORD, + > INCR,ICUR, TRKBEG, CONV,TRKDIR,LENGHT, + > NUMERO,DDENWT) + CALL LCMPUT(IPTRK,'TrackingDirc',2*NDIM*NANGLE,4,ANGLES) + CALL LCMPUT(IPTRK,'TrackingTrkW',2*NANGLE,4,DDENWT) + CALL LCMPUT(IPTRK,'TrackingSpaD',2*NANGLE,4,DENSTY) + ENDIF + ELSEIF( LTRK.EQ.2 )THEN +* +* 3.2) THE CYCLIC TRACKING. + ICUR(3)= MINDIM(3) + CONV(3)= 1.0E+36 + CALL XELTS2( IPRT, IFTEMP, NANGLE, DENUSR, NCODE,ANGLES, + > DENSTY, SWZERO, NTOTCL, MAXR,REMESH,SUBMAX, + > LINMAX, NSUR, NVOL, MATALB, INDEX,MINDIM, + > MAXDIM, ICORD, INCR, ICUR,TRKBEG, CONV, + > TRKDIR, LENGHT, NUMERO,DDENWT) + CALL LCMPUT(IPTRK,'TrackingDirc',2*NDIM*NANGLE,4,ANGLES) + CALL LCMPUT(IPTRK,'TrackingTrkW',2*NANGLE,4,DDENWT) + CALL LCMPUT(IPTRK,'TrackingSpaD',2*NANGLE,4,DENSTY) + ENDIF + DEALLOCATE(DENSTY,ANGLES,LENGHT,NUMERO,TRKDIR,TRKBEG,CONV,INCR, + > ICUR,DDENWT) + ENDIF + DEALLOCATE(REMESH,INDEX,ICORD,MAXDIM,MINDIM) +*--- +* IF A PRISMATIC 3D TRACKING IS REQUESTED, +* ALLOCATE GEOMETRIC STRUCTURES (SEE COMMON CEXGEO) CORRESPONDING TO +* THE 3D INITIAL GEOMETRY +*--- + IF (LPRISM) THEN + CALL LCMSIX(IPTRK,'EXCELL ',1) + ISTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + NDIM =ISTATE(1) + NSUR =-ISTATE(2) + NVOL =ISTATE(3) + CALL LCMSIX(IPTRK,'EXCELL ',2) + CALL LCMGET(IPTRK,'ICODE ',ICODE ) + CALL LCMGET(IPTRK,'NCODE ',NCODE ) + CALL LCMGET(IPTRK,'ALBEDO ',ALBEDO) + NV= NVOL + NS= -NSUR + ENDIF + DEALLOCATE(VOLSUR,MATALB,KEYMRG) +* + RETURN + END diff --git a/Dragon/src/XELTRP.f b/Dragon/src/XELTRP.f new file mode 100644 index 0000000..ae1f6ff --- /dev/null +++ b/Dragon/src/XELTRP.f @@ -0,0 +1,171 @@ +*DECK XELTRP + SUBROUTINE XELTRP( IPGEOM, NGIDL, NDIM, NGEOME, L1CELL, + > NTOTCO, NEXTGE, MAXRO, IPRT, CELLG, + > NSURO, NVOLO, IDLDIM, IDLGEO, KEYTRN, + > MAXDO, MINDO, ICORDO, RMESHO, IDLREM, + > INDEXO, VOLSO, MATGEO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Prepare tracking by producing the required numbering and calculate +* volumes and surfaces. +* +*Copyright: +* Copyright (C) 1987 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPGEOM pointer to the geometry (l_geom). +* NGIDL lenght of geometric numbering. +* NDIM number of dimensions (2 or 3). +* NGEOME number of geometries. +* L1CELL to indicate if there is just 1 cell. +* NEXTGE rectangular(0)/circular(1) boundary. +* NTOTCO tot number of cylinders in all geometries. +* MAXRO max number of real mesh values in RMESHO. +* IPRT intermediate printing level for output. +* CELLG to keep geomety names. +* NSURO number of surfaces of each geometry. +* NVOLO number of zones of each geometry. +* IDLDIM position of each geometry in cylinder numbering. +* IDLGEO position of each geometry in the +* geometry numbering scheme. +* KEYTRN turn number of each geometry. +* +*Parameters: input +* MAXDO max index values for all axes (rect/cyl). +* MINDO min index values for all axes (rect/cyl). +* ICORDO principal axes direction (X/Y/Z) for meshes. +* RMESHO real mesh values (rect/cyl). +* IDLREM position of mesh values per geometry. +* INDEXO index for search in RMESHO. +* VOLSO volumes & surfaces for each geometry. +* MATGEO material numbers corresponding to geometries. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +* + TYPE(C_PTR) IPGEOM + INTEGER NGIDL, NDIM, NGEOME, NTOTCO, NEXTGE, MAXRO, IPRT + INTEGER MAXDO(NTOTCO), MINDO(NTOTCO), ICORDO(NTOTCO), + > MATGEO(NGIDL), CELLG(3*NGEOME), + > NSURO(NGEOME), NVOLO(NGEOME), IDLDIM(NGEOME), + > IDLGEO(NGEOME), IDLREM(NGEOME), KEYTRN(NGEOME), + > INDEXO(4,NGIDL) + REAL RMESHO(MAXRO), VOLSO(NGIDL) +* + INTEGER NSTATE, IOUT, MAXTUR + PARAMETER ( NSTATE=40, IOUT=6, MAXTUR=12 ) + INTEGER ISTATE(NSTATE) + INTEGER NTOTRM, NGEO, NTC, ITURN, NC, NCPC, NVSP1, + > NO, NSYM, MAXC, KELRNG, KELMRG, KELSYM + LOGICAL L1CELL + CHARACTER CNAMEG*12, CTURN(2*MAXTUR)*2 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KEYSYM +*---- +* DATA STATEMENTS +*---- + DATA CTURN / ' A',' B',' C',' D',' E',' F',' G',' H', + > ' I',' J',' K',' L', + > '-A','-B','-C','-D','-E','-F','-G','-H', + > '-I','-J','-K','-L' / +*---- +* SCRATCH STORAGE ALLOCATION +* KEYSYM: symmetry key giving the symmetric surface +*---- + ALLOCATE(KEYSYM(NGIDL)) +* +* LOOP OVER ALL GEOMETRIES + NTOTRM= 0 + DO 90 NGEO= 1, NGEOME + NTC= IDLDIM(NGEO)+1 + ITURN= KEYTRN(NGEO) + WRITE( CNAMEG( 1: 4),'(A4)') CELLG(3*NGEO-2) + WRITE( CNAMEG( 5: 8),'(A4)') CELLG(3*NGEO-1) + WRITE( CNAMEG( 9:12),'(A4)') CELLG(3*NGEO ) + IF( .NOT.L1CELL ) CALL LCMSIX(IPGEOM, CNAMEG, 1) + ISTATE(:NSTATE)=0 + CALL LCMGET(IPGEOM, 'STATE-VECTOR', ISTATE) + IF( ISTATE(1).GE.20.OR.ISTATE(1).EQ.3.OR.ISTATE(1).EQ.6 )THEN + NC= 1 + ELSE + NC= 0 + ENDIF + IF( IPRT.GT.1 )THEN + WRITE(IOUT,'(1H )') + IF ( NC.EQ.0 )THEN + WRITE(IOUT,'(/27H NUMBERING PHYSICAL CELL # ,I8/6H >>> , + > A12,6H /ROT ,A2,13H GEOMETRY <<<, + > 13H (WITH NO,11H CYLINDER ) )') + > NGEO, CNAMEG,CTURN(ITURN) + ELSEIF( NC.EQ.1 )THEN + WRITE(IOUT,'(/27H NUMBERING PHYSICAL CELL # ,I8/6H >>> , + > A12,6H /ROT ,A2,13H GEOMETRY <<<, + > 13H (WITH ONE,11H CYLINDER ) )') + > NGEO, CNAMEG,CTURN(ITURN) + ELSE + WRITE(IOUT,'(/27H NUMBERING PHYSICAL CELL # ,I8/6H >>> , + > A12,6H /ROT ,A2,13H GEOMETRY <<<, + > 10H (WITH ,I3,11H CYLINDERS) )') + > NGEO, CNAMEG, CTURN(ITURN), NC + ENDIF + ENDIF + NCPC = NC + 3 + NVSP1 = NVOLO(NGEO) - NSURO(NGEO) + 1 +* +* LOOKING TO THE GEOMETRY + CALL XELGRD( IPGEOM, IPRT, NDIM, NEXTGE, ITURN, + > MAXRO-NTOTRM, MAXC, RMESHO(NTOTRM+1), + > MINDO(NTC), MAXDO(NTC), ICORDO(NTC)) +* +* RENUMBER + NO= KELRNG(IPRT, NDIM, NEXTGE, NCPC, + > MINDO(NTC), MAXDO(NTC), ICORDO(NTC), + > NSURO(NGEO), NVOLO(NGEO), IDLGEO(NGEO), + > MAXC, RMESHO(NTOTRM+1), MATGEO, VOLSO, INDEXO) +* +* MERGE + NO= KELMRG(IPGEOM,NSURO(NGEO),NVOLO(NGEO),IDLGEO(NGEO),MATGEO) + IF( NO.NE.NVSP1 )THEN + IF( IPRT.GT.1 )THEN + WRITE(IOUT,'(1H )') + WRITE(IOUT,'(22H MERGE INTO >>> ,I8, + > 13H ZONES <<<)') + > NO+NSURO(NGEO)-1 + ENDIF + ENDIF +* +* ESTABLISH NECESSARY SYMMETRIES + NSYM= KELSYM( IPRT, NDIM, MAXDO(NTC), NSURO(NGEO), NVOLO(NGEO), + > IDLGEO(NGEO), INDEXO, MATGEO,KEYSYM) +* +* COMPUTE VOLUMES + CALL XELVOL( IPRT, NDIM, NEXTGE, NCPC, + > MINDO(NTC), MAXDO(NTC), ICORDO(NTC), + > NSURO(NGEO), NVOLO(NGEO), IDLGEO(NGEO),INDEXO, + > MAXC, RMESHO(NTOTRM+1), MATGEO, VOLSO ) + IDLREM(NGEO)= NTOTRM + NTOTRM= NTOTRM + MAXC + IF( .NOT.L1CELL ) CALL LCMSIX(IPGEOM, ' ', 2 ) + 90 CONTINUE + IF( NTOTRM.GT.MAXRO )THEN + CALL XABORT( 'XELTRP : INCREASE MAXREM => SEE DEVELOPPER') + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(KEYSYM) +* + RETURN + END diff --git a/Dragon/src/XELTS2.f b/Dragon/src/XELTS2.f new file mode 100644 index 0000000..9997187 --- /dev/null +++ b/Dragon/src/XELTS2.f @@ -0,0 +1,575 @@ +*DECK XELTS2 + SUBROUTINE XELTS2( IPRT, IFTEMP,NANGLE,DENUSR,NCODE, + > ANGLES,DENSTY,SWZERO, + > NTOTCL,MAXREM,REMESH,SUBMAX,LINMAX, + > NSUR,NVOL,MATALB,INDEX,MINDIM, + > MAXDIM,ICOORD,INCR,ICUR,TRKBEG,CONV,TRKDIR, + > LENGHT,NUMERO,DDENWT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Construct the sequential tape that will contain tracks +* or specular BC in 2-D using cyclic tracking. +* +*Copyright: +* Copyright (C) 1990 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPRT intermediate printing level for output. +* IFTEMP tracking file number. +* NANGLE number of angles used in the tracking process. +* DENUSR density of tracks in the plane perpendicular +* to the tracking angles. +* NCODE type of boundary conditions. +* ANGLES 3d angle values. +* DENSTY density of tracks angle by angle. +* SWZERO logical value (if .TRUE., use 0 and $\\pi$/2 angles). +* NTOTCL number of cylindres of a type + 2. +* MAXREM max number of real mesh values in REMESH. +* REMESH real mesh values (rect/cyl). +* SUBMAX max. number of subtracks in a single track. +* LINMAX max. number of track segments in a single track. +* NSUR number of surfaces. +* NVOL number of zones. +* MATALB material types (faces for surfaces). +* INDEX numbering of surfaces & zones. +* MINDIM min index values for all axes (rect/cyl). +* MAXDIM max index values for all axes (rect/cyl). +* ICOORD principal axes direction (X/Y/Z) for meshes. +* ICUR current zonal location for a track segment. +* INCR increment direction for next track segment. +* TRKBEG position where a track begins. +* CONV segments of tracks. +* TRKDIR direction of a track in all axes. +* LENGHT relative lenght of each segment in a track. +* NUMERO material identification of each track segment. +* DDENWT density of tracks angle by angle. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +* + INTEGER IPRT, IFTEMP, NANGLE, NTOTCL, MAXREM, SUBMAX, + > LINMAX, NSUR, NVOL + REAL TRKBEG(NTOTCL), TRKDIR(NTOTCL), CONV(NTOTCL), + > REMESH(MAXREM),DENUSR + DOUBLE PRECISION DENSTY(4*NANGLE),ANGLES(2,4*NANGLE), + > LENGHT(LINMAX),DDENWT(NANGLE) + INTEGER MINDIM(NTOTCL),MAXDIM(NTOTCL),ICUR(NTOTCL), + > ICOORD(NTOTCL),INCR(NTOTCL),NUMERO(LINMAX), + > NCODE(6),MATALB(NSUR:NVOL),INDEX(4,*) +* + REAL TRKEND(2), PROJC2(3), TRKCUT(3,2), + > TRKPTS(3), OLDBEG(2), OLDDIR(2), + > EPS, TOTLEN, ZERO, ONE + DOUBLE PRECISION WEIGHT, ANGTSA(2,2), ANGLE2(2), ABSC(2), DENS, + > DP, RCIRC, PROJ, PMAX, PMIN, DEPART, DENLIN, + > DRKORI(2), RONEPS + INTEGER IOUT, NSCUT(2),INDC(2),IPER(2),IREFL(2) + INTEGER NDIM, IPERG, IDEB, ISUM, ISTRID, IANG, ITX, ITY, + > IDIM, NOTRAK, NANGLS, NSOLMX, IREF1, ITG, + > NSCAN, ISCAN, NTRAC, NPOINT, + > NDEBS, IX, IY, I2, NSGANG, NTTRK, LINACT, + > LINNUS, LINUSD, NCROS, JINT, KINT, II, IZZ, + > NUMANG, I, J, K, LINE, NSUB, ITYPBC + LOGICAL SWZERO, SWZDIR(3), SWBNEW + CHARACTER TEDATA*13 + PARAMETER ( EPS=1.E-5, ZERO= 0.0E0, ONE=1.0E0, IOUT=6 ) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KANGL + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: PTSANG,WGTANG, + > DNSANG +*---- +* SCRATCH STORAGE ALLOCATION +* PTSANG: cosines of angles +* WGTANG: weights of angles +* DNSANG: densities of each angle +*---- + ALLOCATE(PTSANG(NANGLE),WGTANG(NANGLE),DNSANG(NANGLE)) +* + NDIM= 2 +* +* SET FLAG FOR SURFACE CROSSING +* IPER(1) = X-PERIOD +* IPER(2) = Y-PERIOD +* VALUES ARE +* IPER(I) = 1 FOR PERIODIC BC +* IPER(I) = 2 FOR OTHER BC + IPER(1)=2 + IPER(2)=2 + IF( NCODE(1).EQ.4 .AND. NCODE(2).EQ.4 ) THEN + IPER(1)=1 + ENDIF + IF( NCODE(3).EQ.4 .AND. NCODE(4).EQ.4 ) THEN + IPER(2)=1 + ENDIF + IPERG= MIN(IPER(1)*IPER(2),2) + ABSC(1)= DBLE(REMESH(MAXDIM(1)))-DBLE(REMESH(MINDIM(1))) + ABSC(2)= DBLE(REMESH(MAXDIM(2)))-DBLE(REMESH(MINDIM(2))) + RCIRC= SQRT(ABSC(1)**2 + ABSC(2)**2) + ABSC(1)= ABSC(1)/RCIRC + ABSC(2)= ABSC(2)/RCIRC +* +* SET ITX THE NUMBER OF X CROSSING +* SET ITY THE NUMBER OF Y CROSSING +* FOR STANDARD TRACKING INCLUDING POINTS AT 0.0 AND PI/2 +* SWZERO =.TRUE. +* SCAN ITX FROM 0 TO NANGLE-1 +* SCAN ITY FROM 0 TO NANGLE-1 +* ONLY VALID VALUE IS ITX+ITY = NANGLE +* FOR MEDI TRACKING EXCLUDING POINT AT O.O AND PI/2 +* SWZERO = .FALSE. +* SCAN ITX FROM 1 TO 2+NANGLE BY STEPS OF 2 +* SCAN ITY FROM 1 TO 2*NANGLE BY STEPS OF 2 +* ONLY VALID VALUES IS ITX+ITY=2*NANGLE + IF( SWZERO )THEN + ISUM= NANGLE-1 + IDEB= 0 + ISTRID=1 + ELSE + ISUM= 2*NANGLE + IDEB= 1 + ISTRID=2 + ENDIF + ALLOCATE(KANGL(SUBMAX)) +* +* FIRST ANGLE INITIALIZATION FOR STORING ON TRACKING FILE +* ANGTSA(1,1)= COS(THETA) WRT X-DIRECTION +* ANGTSA(1,2)= SIN(THETA) WRT X-DIRECTION +* ANGTSA(2,1)= SIN(THETA) WRT X-DIRECTION +* = COS(PI/2-THETA) WRT Y-DIRECTION +* ANGTSA(2,2)= -COS(THETA) WRT Y-DIRECTION +* = SIN(PI/2-THETA) WRT Y-DIRECTION +* 1) GET SUCCESSIVE ANGLES COSINE USING XELTSA +* RANGE 0 <= THETA <= PI/2 +* CAN BE EXTENDED TO 0 <= THETA <= PI +* USING CHANGE OF SIGN FOR ANGTSA(1,1) +* 2) COMPUTE ALL ANGULAR INTEGRATION WEIGHTS USING XELTSW +* 3) STORE ON TRACKING FILE + IANG= 0 + DO 80 ITX= IDEB, ISUM, ISTRID + INDC(1)= ITX + ITY=ISUM-ITX + INDC(2)= ITY +* +* READ ANGLE BY ANGLE + ITYPBC=0 ! Cartesian boundary + CALL XELTSA( NDIM, ITYPBC, ABSC, INDC, DENS, ANGTSA) + IANG= IANG+1 + DENLIN= DENS / RCIRC +* +* FOR HORIZONTAL & VERTICAL ANGLES +* TRAK DENSITY = ORIGINAL DENSITY +* OTHERWISE +* FIND RATIO BETWEEN ORIGINAL DENSITY AND MINIMUM DENSITY +* TRACK DENSITY = CLOSEST MULTIPLE OF MINIMUM TRACK DENSITY + IF( ITX.EQ.0 .OR. ITY.EQ.0 )THEN + DENLIN= DBLE(DENUSR) + DNSANG(IANG)= DENLIN + ELSE + NTRAC= MAX(1,INT(DBLE(DENUSR)/DENLIN+0.5D0)) + DNSANG(IANG)= DBLE(NTRAC) * DENLIN + ENDIF + PTSANG(IANG)= REAL(ANGTSA(1,1)) + ANGLES(1,IANG)= REAL(ANGTSA(1,1)) + ANGLES(2,IANG)= REAL(ANGTSA(2,1)) + 80 CONTINUE +* +* COMPUTE ALL ANGULAR INTEGRATION WEIGHTS + CALL XELTSW( ABSC, NANGLE, PTSANG, WGTANG) + DO 90 IANG= 1, NANGLE + DENSTY(IANG)= 2.0/REAL(WGTANG(IANG)) + IF( IPRT.GT.2 )THEN + WRITE(IOUT,1000) IANG, PTSANG(IANG), WGTANG(IANG), + > DNSANG(IANG), WGTANG(IANG)/DNSANG(IANG) + ENDIF + 90 CONTINUE + DO 100 IANG=1,NANGLE + ANGLES(1,2*NANGLE-IANG+1)=-ANGLES(1,IANG) + ANGLES(2,2*NANGLE-IANG+1)=ANGLES(2,IANG) + DENSTY(2*NANGLE-IANG+1)=DENSTY(IANG) + DDENWT(2*NANGLE-IANG+1)=0.25D0*DBLE(WGTANG(IANG)/DNSANG(IANG)) + 100 CONTINUE + DO 110 IANG=1,2*NANGLE + ANGLES(1,4*NANGLE-IANG+1)=ANGLES(1,IANG) + ANGLES(2,4*NANGLE-IANG+1)=-ANGLES(2,IANG) + DENSTY(4*NANGLE-IANG+1)=DENSTY(IANG) + DDENWT(4*NANGLE-IANG+1)=0.25D0*DBLE(WGTANG(IANG)/DNSANG(IANG)) + 110 CONTINUE +* +* COPY ANGLES AND DENSITIES ON TEMPORARY TRACKING FILE + WRITE(IFTEMP) ((ANGLES(IDIM,IANG),IDIM=1,NDIM),IANG=1,4*NANGLE) + WRITE(IFTEMP) (DENSTY(IANG) ,IANG=1,4*NANGLE) +* +* PREPARE FOR TRACKING + PROJC2(1)= ZERO + PROJC2(2)= ZERO + PROJC2(3)= ONE + TRKBEG(3)= ZERO + TRKDIR(3)= ZERO + NOTRAK= 0 + NANGLS=NANGLE + NSOLMX= 0 + IF( IPRT.GT.1 )THEN + WRITE(IOUT,'(1H )') + WRITE(IOUT,1001) NANGLE + NSOLMX= MIN(9, NANGLE/10) + IREF1=0 + WRITE(IOUT,1002) (IREF1, IZZ=0,NSOLMX) + WRITE(IOUT,1002) (MOD(IZZ,10), IZZ=0,NSOLMX) + TEDATA= '(1H+,TXXX,I1)' + ENDIF +* +* READ SUCCESSIVE ANGLES COSINE USING XELTSA FOR TRACKING + IANG= 0 + DO 120 ITX= IDEB, ISUM, ISTRID + INDC(1)= ITX + ITY=ISUM-ITX + INDC(2)= ITY +* +* READ ANGLE BY ANGLE + ITYPBC= 0 ! Cartesian boundary + CALL XELTSA( NDIM, ITYPBC, ABSC, INDC, DENS, ANGTSA) + IANG= IANG+1 +* +* COMPUTE NUMBER OF SEGMENTS OF THE ANGLE +* ITX = ISUM -> ANGLE = 0 +* ITY = ISUM -> ANGLE = PI/2 + NUMANG=1 + NSCAN = IPERG + IF( ITX.EQ.ISUM )THEN + NSCAN = IPER(1) + ELSEIF( ITY.EQ.ISUM )THEN + NSCAN = IPER(2) + ELSE + NUMANG= ISUM + DO 130 ITG= MIN(ITX,ITY), 2, -1 + IF( (ITX .EQ. (ITX/ITG)*ITG) .AND. + > (ITY .EQ. (ITY/ITG)*ITG) )THEN + NUMANG=NUMANG/ITG + GO TO 135 + ENDIF + 130 CONTINUE + ENDIF + 135 CONTINUE + NUMANG=NUMANG*NSCAN +* +* IF NSCAN = 2 +* 0 TO PI/2 AND PI/2 TO PI ARE SCANNED SIMULTANEOUSLY +* IF NSCAN= 1 +* FIRST TREAT 0 TO PI/2 +* THEN TREAT PI/2 TO PI + DO 140 ISCAN=2,NSCAN,-1 +* +* ZEROS ON THE COMPONENT OF THE DIRECTION + SWZDIR(1)= ITX.EQ.0 + SWZDIR(2)= ITY.EQ.0 + DENLIN = DNSANG(IANG) + DP = 1.D0 / DENLIN + NDEBS= 0 + IF( (IPRT .GT. 1) .AND. (ISCAN .EQ. 2) ) THEN + IF( MOD(IANG,100) .EQ. 0 )THEN + IREF1=IREF1+1 + NDEBS= NSOLMX+1 + NSOLMX=MIN(NDEBS+9, NANGLE/10) + WRITE(IOUT,1002)(IREF1,IZZ=NDEBS,NSOLMX) + WRITE(IOUT,1002)(MOD(IZZ,10),IZZ=NDEBS,NSOLMX) + ELSE + IF( (IPRT.GT.10000) .AND. (MOD(IANG,100).NE.0) )THEN + WRITE(IOUT,1002) (IREF1,IZZ=NDEBS,NSOLMX) + WRITE(IOUT,1002) (MOD(IZZ,10),IZZ=NDEBS,NSOLMX) + ENDIF + WRITE(TEDATA(7:9),'(I3.3)') MOD(IANG,100) + 2 + WRITE(IOUT,TEDATA) MOD(IANG,10) + ENDIF + ENDIF + DO 150 I = 1, 2 + TRKDIR(I)= REAL(ANGTSA(I,1)) + INCR(I) = 1 + IF( SWZDIR(I) ) INCR(I)= 0 + 150 CONTINUE +* +* CUT LENGHT FOR UNIT PLANE VECTORS +* PROJECT THE 4 CORNERS ON THE PLANE +* +* DIRECTION OF TRACK IS IN O TO PI/2 REPRESENTS ROTATED +X-AXIS +* DIRECTION TRACK NORMAL IS IN -PI/2 TO 0 REPRESENTED +Y-AXIS +* PMIN IS LOWEST POINT FROM PROJECTING CARTESIAN CELL +* IN THIS FRAME OF REFERENCE OF TRACKING LINE +* PMAX IS HIGHEST POINT FROM PROJECTING CARTESIAN CELL +* IN THIS FRAME OF REFERENCE OF TRACKING LINE +* STARTING POINT IN THIS FRAME OF REFERENCE OF TRACKING LINE I +* PMIN-0.5*(MESH SPACING DP) +* STARTING POINT IN ORIGINAL FRAME OF REFERENCE IS +* X=PMIN*ANGTSA(1,2) +* Y=PMIN*ANGTSA(2,2) +* MESH SPACING IN THE ORIGINAL FRAME OF REFERENCE IS +* DX=DP*ANGTSA(1,2) +* DY=DP*ANGTSA(2,2) + PMIN = +1.0D+50 + PMAX = -1.0D+50 + DO 160 IX =MINDIM(1),MAXDIM(1),MAXDIM(1)-MINDIM(1) + DO 161 IY =MINDIM(2),MAXDIM(2),MAXDIM(2)-MINDIM(2) + PROJ = DBLE(REMESH(IX)) * ANGTSA(1,2) + > + DBLE(REMESH(IY)) * ANGTSA(2,2) + PMIN=MIN(PMIN,PROJ) + PMAX=MAX(PMAX,PROJ) + 161 CONTINUE + 160 CONTINUE +* +* NEAREST INTEGER -1 OR +1 FOR SECURITY + NPOINT =NINT((PMAX-PMIN)*DENLIN)+1 + DEPART =PMIN - 0.5D0 * DP + DO 170 J = 1, 2 + DRKORI(J)= DEPART * ANGTSA(J,2) + ANGLE2(J)= DP * ANGTSA(J,2) + 170 CONTINUE + IF(ISCAN .EQ. 1) THEN + IF(ITX .EQ. 0) THEN + TRKDIR(2)=-TRKDIR(2) + INCR(2) =-1 + ELSE IF(ITY.EQ.0) THEN + TRKDIR(1)=-TRKDIR(1) + INCR(1) =-1 + ENDIF + ELSE + ENDIF + SWBNEW= .TRUE. + NSGANG= 0 + IREFL(1)=1 + IREFL(2)=1 + LINACT= 0 + DO 180 I2 = 1,NSCAN*NPOINT + IF( SWBNEW )THEN + NSUB=0 + NTTRK=NOTRAK+1 + LINACT= 1 + LINNUS= LINMAX + IF(NSGANG .EQ. 0) THEN + DO 190 J = 1, 2 + DRKORI(J)= DRKORI(J) + ANGLE2(J) + TRKPTS(J)= REAL(DRKORI(J)) + 190 CONTINUE + ENDIF + IF(ISCAN .EQ. 1 .AND. ITX*ITY .NE. 0) THEN +* +* LOCATE STARTUP POSITION ON SURFACES +* IDENTICAL TO CASE WITH ISCAN=2 + TRKDIR(1)= REAL(ANGTSA(1,1)) + TRKDIR(2)= REAL(ANGTSA(2,1)) + CALL XELLSR( NDIM, NTOTCL, NSUR, MAXREM, REMESH, + > INDEX, MINDIM, MAXDIM, ICOORD, ICUR, + > INCR, TRKPTS, TRKDIR, TRKCUT, NSCUT, + > NCROS, TOTLEN) + IF( NCROS .LT. 2 ) GO TO 185 + TRKPTS(1)=TRKCUT(1,1) + TRKPTS(2)=TRKCUT(2,1) + JINT = (1-MATALB(NSCUT(1)))/2 + TRKDIR(JINT)= -REAL(ANGTSA(JINT,1)) + INCR(JINT) = -1 + ENDIF + ENDIF +* +* LOCATE EXTERNAL SURFACES CROSSED BY THIS TRACK + CALL XELLSR( NDIM, NTOTCL, NSUR, MAXREM, REMESH, + > INDEX, MINDIM, MAXDIM, ICOORD, ICUR, INCR, + > TRKPTS, TRKDIR, TRKCUT, NSCUT, NCROS, + > TOTLEN) +* +* VALID TRACK ONLY IF 2 SURFACES ARE CROSSED +* OTHERWISE DO NOT CONSIDER TRACK + IF( NCROS .LT. 2 ) GO TO 185 + NSGANG= NSGANG+1 + DO 200 K= 1, NDIM + TRKBEG(K)= TRKCUT(K,1) + TRKEND(K)= TRKCUT(K,2) + 200 CONTINUE + IF( SWBNEW )THEN + DO 210 J= 1, 2 + OLDBEG(J)= TRKBEG(J) + OLDDIR(J)= TRKDIR(J) + 210 CONTINUE + ENDIF +* +* SAVE INITIAL SURFACE CROSSED BY TRACK +* SINCE THE INITIAL IS DOUBLED SET +* LENGTH TO 0.5 TO TAKE THIS EFFECT INTO ACCOUNT + LENGHT(LINACT)= 0.5D0 + NUMERO(LINACT)= NSCUT(1) + LINACT= LINACT + 1 +* +* LOCATE ALL REGIONS CROSSED BY LINE + NSUB=NSUB+1 + IF(NSUB.GT.SUBMAX) CALL XABORT('XELTS2: SUBMAX OVERFLOW.') + KANGL(NSUB)=0 + DO II=1,4*NANGLE + IF((DBLE(TRKDIR(1)).EQ.ANGLES(1,II)).AND. + > (DBLE(TRKDIR(2)).EQ.ANGLES(2,II))) THEN + KANGL(NSUB)=II + GO TO 215 + ENDIF + ENDDO + CALL XABORT('XELTS2: UNABLE TO FIND AN ANGULAR INDEX FOR A' + > //' SUBTRACK') + 215 CALL XELLIN( NDIM, NTOTCL, MAXREM, REMESH, + > NSUR, NVOL, INDEX, MINDIM, MAXDIM, + > ICOORD, ICUR, INCR, TRKBEG, TRKEND, TRKDIR, + > PROJC2, TOTLEN, + > CONV, LINNUS, LENGHT(LINACT), NUMERO(LINACT), + > LINUSD) + LINACT= LINACT + LINUSD + LINNUS= LINNUS - LINUSD +* +* SAVE FINAL SURFACE CROSSED BY TRACK +* SINCE THE FINAL SURFACES IS DOUBLED SET +* LENGTH TO 0.5 TO TAKE THIS EFFECT INTO ACCOUNT + LENGHT(LINACT)= 0.5D0 + NUMERO(LINACT)= NSCUT(2) + LINACT= LINACT + 1 + LINNUS= LINNUS - 1 +* +* FIND INTERSECTION DIRECTION + JINT = (1-MATALB(NSCUT(2)))/2 + KINT = MOD(JINT,2) +1 +* +* IF NCODE(J)=4 +* -> TRANSLATION FOR THE FACE +* FOR LOWER FACE (TRKBEG(J)=REMESH(MINDIM(J))) +* TRKBEG -> REMESH(MAXDIM(J)) +* FOR UPPER FACE (TRKBEG(J)=REMESH(MAXDIM(J))) +* TRKBEG -> REMESH(MINDIM(J)) +* OTHERWISE +* -> SPECULAR REFLECTION FOR THE FACE +* TRKDIR(J)= -TRKDIR(J) +* INCR(J)=-INCR(J) + IF( IPER(JINT).EQ.1 )THEN + IF( TRKEND(JINT).EQ.REMESH(MAXDIM(JINT)) )THEN + TRKEND(JINT)= REMESH(MINDIM(JINT)) + ELSEIF( TRKEND(JINT).EQ.REMESH(MINDIM(JINT)) )THEN + TRKEND(JINT)= REMESH(MAXDIM(JINT)) + ELSE + CALL XABORT('XELTS2: TRANSLATION ERROR') + ENDIF + ELSE + TRKDIR(JINT)= -TRKDIR(JINT) + INCR(JINT)= -INCR(JINT) + ENDIF + RONEPS= ZERO + DO 220 J= 1, 2 + TRKBEG(J)= TRKEND(J) + RONEPS= RONEPS + (TRKBEG(J)-OLDBEG(J))**2 + > + (TRKDIR(J)-OLDDIR(J))**2 + TRKPTS(J)= TRKBEG(J) + 220 CONTINUE + RONEPS=RONEPS/(RCIRC*RCIRC) + SWBNEW= NSGANG.EQ.NUMANG + IF(SWBNEW) THEN + NSGANG=0 + IF(RONEPS .GT. EPS) THEN + WRITE(IOUT,9000) (OLDBEG(J),J=1,2),(TRKBEG(J),J=1,2), + > (OLDDIR(J),J=1,2),(TRKDIR(J),J=1,2), + > 100.0*SQRT(RONEPS) + CALL XABORT + > ('XELTS2: ERROR ON FINAL POSITION OR DIRECTION') + ENDIF +* +* RESET ORIGINAL ANGLES IF ROTATION CONSIDERED + DO 230 II=1,2 + TRKDIR(II)= IREFL(II)*TRKDIR(II) + INCR(II) = IREFL(II)*INCR(II) + IREFL(II) = 1 + 230 CONTINUE + ELSE IF(NSCAN .EQ. 2) THEN + IF(RONEPS .LE. EPS) THEN + IF(IPER(JINT) .EQ. 1) THEN +* +* ROTATE ANGLE IF STARTUP SURFACE PERIODIC + TRKDIR(JINT)= -TRKDIR(JINT) + INCR(JINT)= -INCR(JINT) + IREFL(JINT)=-IREFL(JINT) + SWBNEW= .TRUE. + ELSE IF(IPER(KINT) .EQ. 1) THEN +* +* IF NORMAL SURFACE IS PERIODIC +* LOCATE FIRST NORMAL SURFACE REACHED AND ROTATE ANGLE + DO 240 II=1,NSCAN*NPOINT + CALL XELLSR( NDIM, NTOTCL, NSUR, MAXREM, REMESH, + > INDEX, MINDIM, MAXDIM, ICOORD, ICUR, + > INCR, TRKPTS, TRKDIR, TRKCUT, NSCUT, + > NCROS, TOTLEN) + JINT = (1-MATALB(NSCUT(2)))/2 + IF(JINT.EQ.KINT) GO TO 245 + 240 CONTINUE + CALL XABORT + > ('XELTS2: CANNOT FIND AN INITIAL PERIODIC SURFACE') + 245 CONTINUE + TRKPTS(1)=TRKCUT(1,2) + TRKPTS(2)=TRKCUT(2,2) + TRKDIR(JINT)= -TRKDIR(JINT) + INCR(JINT) = -INCR(JINT) + IREFL(JINT)=-IREFL(JINT) + SWBNEW= .TRUE. + ENDIF + ENDIF + ENDIF + IF( SWBNEW )THEN +* +* NOW, WRITE THE TRACK + NOTRAK= NOTRAK + 1 + NTTRK = NOTRAK + LINE= LINACT-1 + WEIGHT= 0.25D0*DBLE(WGTANG(IANG)/DNSANG(IANG)) + WRITE(IFTEMP) NSUB, LINE, WEIGHT, + > (KANGL(II),II=1,NSUB), + > (NUMERO(I),I=1,LINE), + > (LENGHT(I),I=1,LINE) + IF( IPRT.GT. 1000 ) THEN + WRITE(IOUT,1010) NOTRAK,IANG,LINE + WRITE(IOUT,1011) (LENGHT(I),NUMERO(I),I=1,LINE) + ENDIF + ENDIF + 185 CONTINUE + 180 CONTINUE + 140 CONTINUE + 120 CONTINUE +* + IF( IPRT.GT.1 )THEN + WRITE(IOUT,'(1H )') + WRITE(IOUT,1020) IFTEMP,NANGLE, DENUSR,NOTRAK + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(KANGL,PTSANG,WGTANG,DNSANG) + RETURN +* + 1000 FORMAT(1X,I4,': COS=',F15.10,' WGT=',F15.10,' DNS=',F15.10, + > ' WGT/DEN=',F15.10) + 1001 FORMAT(1X,'ECHO = ',I10,' SOLID ANGLES TO BE TRACKED ') + 1002 FORMAT(1X,10(I1,9X)) + 1010 FORMAT(1X,'#',I10,' IANG=',I10,' LEN=',I10) + 1011 FORMAT(1P,(1X,E15.3,1X,I10)) + 1020 FORMAT(1X,'ECHO OF TRACKING PROPERTIES FOR TAPE ',I2/ + > 10X,'NUMBER OF ANGLES =',I10/ + > 10X,' TRACK DENSITY =',F10.3,' LINES/CM'/ + > 10X,'NUMBER OF TRACK STORED =',I10) +* + 9000 FORMAT(1X,'FINAL TRACK POSITION EXPECTED = (', + > F15.10,',',F15.10,')'/ + > 1X,'FINAL TRACK POSITION FOUND = (', + > F15.10,',',F15.10,')'/ + > 1X,'FINAL TRACK DIRECTION EXPECTED = (', + > F15.10,',',F15.10,')'/ + > 1X,'FINAL TRACK DIRECTION FOUND = (', + > F15.10,',',F15.10,')'/ + > 1X,'RMS ERROR = ',F15.10,' %') + END diff --git a/Dragon/src/XELTSA.f b/Dragon/src/XELTSA.f new file mode 100644 index 0000000..d3e32af --- /dev/null +++ b/Dragon/src/XELTSA.f @@ -0,0 +1,89 @@ +*DECK XELTSA + SUBROUTINE XELTSA(NDIM,ITYPBC,ABSC,INDC,DENS,ANGTSA) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To compute the integration points and periodic density +* for cyclic tracking. +* +*Copyright: +* Copyright (C) 1994 Ecole Polytechnique de Montreal. +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* NDIM number of dimensions for the problem. +* ITYPBC type of boundary condition (=0/2: Cartesian/hexagonal). +* ABSC multidimensional width of the cell. +* INDC index of each coordinate of the angles. +* +*Parameters: output +* DENS effective periodic density. +* ANGTSA tracking direction and its normal. +* +*Reference: +* R. Roy, G. Marleau, A. Hebert and D. Rozon, +* A Cyclic Tracking Procedure for Collision Probability Calculations +* in 2-D Lattice', Advances in Mathematics, Computations and +* Reactor Physics, Pittsburgh, PA, April 28 - May 2 (1991). +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NDIM,ITYPBC + DOUBLE PRECISION ABSC(2) + INTEGER INDC(NDIM) + DOUBLE PRECISION DENS + DOUBLE PRECISION ANGTSA(NDIM,NDIM) +*---- +* LOCAL PARAMETERS +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='XELTSA') +*---- +* LOCAL VARIABLES +*---- + INTEGER IDIM + IF(NDIM .NE. 2) CALL XABORT(NAMSBR// + >': Only 2-D problems permitted yet') + DENS=0.0D0 + DO 10 IDIM= 1,NDIM + IF(ITYPBC.EQ.0) THEN + ! Cartesian boundary + ANGTSA(IDIM,1)= REAL(INDC(IDIM))/ABSC(NDIM+1-IDIM) + ELSE + ! hexagonal boundary + IF(IDIM.EQ.1) THEN + ANGTSA(IDIM,1)= REAL(INDC(IDIM))*SQRT(3.D0) + ELSE + ANGTSA(IDIM,1)= REAL(INDC(IDIM)) + ENDIF + ENDIF + DENS= DENS + ANGTSA(IDIM,1)*ANGTSA(IDIM,1) + 10 CONTINUE + DENS= SQRT(DENS) +*---- +* ANGTSA(*,1) is the track direction +*---- + DO 20 IDIM= 1,NDIM + ANGTSA(IDIM,1)= ANGTSA(IDIM,1)/DENS + 20 CONTINUE +*---- +* ANGTSA(*,2) is a normal to track direction +*---- + ANGTSA(2,2)= -ANGTSA(1,1) + ANGTSA(1,2)= ANGTSA(2,1) +*---- +* Processing finished, return +*---- + RETURN + END diff --git a/Dragon/src/XELTSW.f b/Dragon/src/XELTSW.f new file mode 100644 index 0000000..49f49af --- /dev/null +++ b/Dragon/src/XELTSW.f @@ -0,0 +1,130 @@ +*DECK XELTSW + SUBROUTINE XELTSW(ABSC,NANGLE,PTSANG,WGTANG) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To compute the integration weights for cyclic tracking. +* +*Copyright: +* Copyright (C) 1994 Ecole Polytechnique de Montreal. +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* ABSC multidimensional width of the cell. +* NANGLE number of angles. +* PTSANG integration points. +* +*Parameters: output +* WGTANG integration weights. +* +*Reference: +* R. Roy, G. Marleau, A. Hebert and D. Rozon, +* A Cyclic Tracking Procedure for Collision Probability Calculations +* in 2-D Lattices, Advances in Mathematics, Computations and +* Reactor Physics, Pittsburgh, PA, April 28 - May 2 (1991). +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + DOUBLE PRECISION ABSC(2) + INTEGER NANGLE + DOUBLE PRECISION PTSANG(NANGLE) + DOUBLE PRECISION WGTANG(NANGLE) +*---- +* LOCAL PARAMETERS +*---- + INTEGER IOUT,MXANGL + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,MXANGL=30,NAMSBR='XELTSW') + DOUBLE PRECISION XDRCST,PI +*---- +* LOCAL VARIABLES +*---- + INTEGER I,K,N,P + DOUBLE PRECISION X(0:MXANGL-1),W(0:MXANGL-1),ACCUW,A,B + INTEGER INEGW + DOUBLE PRECISION AC0,AC1,AC2,AC3 +*---- +* Test for validity of NANGLE +*---- + PI=XDRCST('Pi',' ') + IF(NANGLE.GT. MXANGL) CALL XABORT(NAMSBR// + >': Number of specular azimuthal points too large') + A= ABSC(1) + B= ABSC(2) + P= NANGLE-1 + ACCUW= 1.D0 + DO 10 I= 0, P + X(I)= PTSANG(NANGLE-I)*PTSANG(NANGLE-I) + W(I)= ACCUW + ACCUW= ACCUW*DBLE(2*I+1)/DBLE(2*(I+1)) + 10 CONTINUE + N= NANGLE-1 + DO 30 K= 0, N-1 + DO 20 I= N, K+1, -1 + W(I)= W(I) - W(I-1) * X(K) + 20 CONTINUE + 30 CONTINUE + DO 60 K= N-1, 0, -1 + DO 40 I= K+1, N + W(I)= W(I) / ( X(I) - X(I-K-1) ) + 40 CONTINUE + DO 50 I= K, N-1 + W(I)= W(I) - W(I+1) + 50 CONTINUE + 60 CONTINUE + INEGW=0 + DO 70 I= 0, P + WGTANG(NANGLE-I)= W(I) + IF(WGTANG(NANGLE-I) .LT. 0.0D0) INEGW=INEGW+1 + 70 CONTINUE +*---- +* If some weights are negative write warning +* and use Sanchez weighting +* R. Sanchez, L. Mao, S. Santandrea +* Nucl. Sci. Eng. 140, 23-50 (2002). +*---- + IF(INEGW .GT. 0) THEN + WRITE(IOUT,7000) NAMSBR + I=1 + AC0=PI + AC1=ACOS(PTSANG(I)) + AC2=ACOS(PTSANG(I+1)) + WGTANG(I)=ABS(AC2-AC1)/AC0 + ACCUW=WGTANG(1) + AC3=0 + DO 80 I=2,NANGLE-1 + AC3=ACOS(PTSANG(I+1)) + WGTANG(I)=ABS(AC3-AC1)/AC0 + ACCUW=ACCUW+WGTANG(I) + AC1=AC2 + AC2=AC3 + 80 CONTINUE + I=NANGLE + WGTANG(I)=ABS(AC3-AC1)/AC0 + ACCUW=ACCUW+WGTANG(I) + DO 90 I=1,NANGLE + WGTANG(I)=WGTANG(I)/ACCUW + 90 CONTINUE + ENDIF +*---- +* Processing finished, return +*---- + RETURN +*---- +* FORMATS +*---- + 7000 FORMAT(' ****** WARNING in : ',A6,' *****'/ + >10X,'Some of the integration weights are negative'/ + >10X,'this may result in invalid integration of CP'/ + >10X,'Use Sanchez instead of Roy weighting') + END diff --git a/Dragon/src/XELVOL.f b/Dragon/src/XELVOL.f new file mode 100644 index 0000000..1b1e0f4 --- /dev/null +++ b/Dragon/src/XELVOL.f @@ -0,0 +1,228 @@ +*DECK XELVOL + SUBROUTINE XELVOL( IPRT, NDIM, NEXTGE, NCPC, MINDO, MAXDO, + > ICORDO, NSURO, NVOLO, IDLGEO, INDEXO, + > MAXC, REMESH, MATGEO, VOLSO ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute volumes and surfaces. +* +*Copyright: +* Copyright (C) 1987 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPRT intermediate printing level for output. +* NDIM number of dimensions (2 or 3). +* NEXTGE rectangular(0)/circular(1) boundary. +* NCPC dimension for MINDO. +* MINDO min index values for all axes (rect/cyl). +* MAXDO max index values for all axes (rect/cyl). +* ICORDO principal axis directions (X/Y/Z) for meshes. +* NSURO number of surface of the geometry. +* NVOLO max. number of track segments in a single track. +* IDLGEO relative index of geometry in VOLSO. +* INDEXO to retrieve zones in geometry. +* MAXC dimension of REMESH. +* REMESH real meshes values (rect/cyl). +* MATGEO material numbers used in the geometry. +* +*Parameters: output +* VOLSO volumes and surfaces for each geometry. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +* + INTEGER IPRT,NDIM,NEXTGE,NCPC,NSURO,NVOLO,IDLGEO,MAXC + REAL VOLSO(*),REMESH(MAXC) + INTEGER MINDO(NCPC), MAXDO(NCPC), ICORDO(NCPC), + > INDEXO(4,*), MATGEO(*) +* + DOUBLE PRECISION PI, PIO2 + PARAMETER ( PI=3.14159265358979323846D0,PIO2= 0.5D0*PI) + INTEGER IOUT + PARAMETER ( IOUT=6 ) + INTEGER ICUR(4), IND, I, KSUR, JX, JY, JZ, JCY, JRAY, + > IVO, IXYZ, ICT, ICX, ICY, IVO1, IVO2, IP, IR, + > NESUR, NSUNN, NSURC, NSURM, + > NEVOL, NVONN, NVOLC, NVOLM + INTEGER NVOL0 + DOUBLE PRECISION CENTEC(2),RAYONC(2),DXX(2),DYY(2),DZZ, + > XYPOS(2,2),DELTA(3),PRODUC,VOLARE,SURF2,AREAI + LOGICAL LELCRN, SWZCYL + CHARACTER*4 CORIEN(-6:0) + SAVE CORIEN +* + DATA CORIEN + > / ' Z+ ',' Z- ',' Y+ ',' Y- ',' X+ ',' X- ',' ' / +* + IND(I)= IDLGEO + I +* +* VOL & SURF CALCULATION (CARTESIAN MESHES) + RAYONC(1)= 0.0D0 + KSUR= MOD(NDIM+1,3) + DO 50 JX = MINDO(1)-1, MAXDO(1) + ICUR(1)= JX + IF( JX.EQ.MINDO(1)-1 .OR. JX.EQ.MAXDO(1) )THEN + DELTA(1) = 0.25D0 + ELSE + DELTA(1)= DBLE(REMESH(JX+1))- DBLE(REMESH(JX)) + ENDIF + DO 40 JY = MINDO(2)-1, MAXDO(2) + ICUR(2)= JY + IF( JY.EQ.MINDO(2)-1 .OR. JY.EQ.MAXDO(2) )THEN + DELTA(2) = 0.25D0 + ELSE + DELTA(2)= DBLE(REMESH(JY+1))-DBLE(REMESH(JY)) + ENDIF + DO 30 JZ = MINDO(3)-KSUR, MAXDO(3)+KSUR-1 + ICUR(3)= JZ + IF( JZ.EQ.MINDO(3)-1 .OR. JZ.EQ.MAXDO(3) )THEN + DELTA(3) = 0.25D0 + ELSE + DELTA(3)= DBLE(REMESH(JZ+1))-DBLE(REMESH(JZ)) + ENDIF + PRODUC= DELTA(1)*DELTA(2)*DELTA(3) + DO 20 IVO = NSURO, NVOLO + DO 10 IXYZ= 1, 3 + IF(INDEXO(IXYZ,IND(IVO)).NE.ICUR(IXYZ))GO TO 20 + 10 CONTINUE + VOLSO(IND(IVO))= REAL(PRODUC) + 20 CONTINUE + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + NVOL0=0 + DO 130 JCY= 4, NCPC + ICT= ICORDO(JCY) + ICX= MOD(ICT , 3) + 1 + ICY= MOD(ICT+1, 3) + 1 + CENTEC(1)= DBLE(REMESH(MINDO(JCY)-2)) + CENTEC(2)= DBLE(REMESH(MINDO(JCY)-1)) + DO 120 JRAY= MAXDO(JCY), MINDO(JCY), -1 + RAYONC(2)= DBLE(REMESH(JRAY)) + DO 110 JX = MINDO(ICX), MAXDO(ICX)-1 + ICUR(ICX)= JX + DXX(1) = DBLE(REMESH(JX)) + DXX(2) = DBLE(REMESH(JX+1)) + XYPOS(1,1) = DXX(1)-CENTEC(1) + XYPOS(2,1) = DXX(2)-CENTEC(1) + DO 100 JY = MINDO(ICY), MAXDO(ICY)-1 + ICUR(ICY)= JY + DYY(1) = DBLE(REMESH(JY)) + DYY(2) = DBLE(REMESH(JY+1)) + XYPOS(1,2) = DYY(1)-CENTEC(2) + XYPOS(2,2) = DYY(2)-CENTEC(2) + IF( .NOT.LELCRN(CENTEC,RAYONC,DXX,DYY )) + > GO TO 100 + CALL XELCRN(IPRT,RAYONC(2),1,1,XYPOS,AREAI) + DO 90 JZ = MINDO(ICT)-KSUR, MAXDO(ICT)+KSUR-1 + ICUR(ICT)= JZ + IF( JZ.EQ.MINDO(ICT)-1 .OR. JZ.EQ.MAXDO(ICT) )THEN + DZZ = 0.25D0 + ELSE + DZZ = DBLE(REMESH(JZ+1)) - DBLE(REMESH(JZ)) + ENDIF + VOLARE= AREAI * DZZ + DO 85 IVO1= NSURO, NVOLO + ICUR(4)= JRAY-1 + DO 70 IXYZ= 1, 4 + IF(INDEXO(IXYZ,IND(IVO1)).NE.ICUR(IXYZ)) GO TO 85 + 70 CONTINUE + ICUR(4)= JRAY + DO 80 IVO2= NSURO, NVOLO + DO 75 IXYZ= 1, 4 + IF(INDEXO(IXYZ,IND(IVO2)).NE.ICUR(IXYZ)) GO TO 80 + 75 CONTINUE + IF(VOLARE .LE. 0.0D0) THEN + IF(NVOL0 .EQ. 0) WRITE(IOUT,8000) + NVOL0=NVOL0+1 + VOLARE=0.0D0 + ELSE IF(VOLSO(IND(IVO2))-VOLARE .LE. 0.0) THEN + IF(NVOL0 .EQ. 0) WRITE(IOUT,8000) + NVOL0=NVOL0+1 + VOLARE=DBLE(VOLSO(IND(IVO2))) + ENDIF + VOLSO(IND(IVO1))= REAL(VOLARE) + VOLSO(IND(IVO2))= VOLSO(IND(IVO2)) - REAL(VOLARE) + GO TO 85 + 80 CONTINUE + 85 CONTINUE + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + NESUR= 0 + NEVOL= 0 + SWZCYL=.TRUE. + IF( NEXTGE.EQ.1 )THEN + DO 700 IVO1= NSURO, NVOLO + IF( IVO1.LT.0.AND.MATGEO(IND(IVO1)).EQ.0 ) NESUR= NESUR-1 + IF( IVO1.GT.0.AND.MATGEO(IND(IVO1)).LT.0 ) NEVOL= NEVOL+1 + 700 CONTINUE + JRAY = MAXDO(4) + SURF2= PIO2 * SQRT(DBLE(REMESH(JRAY))) + ICT= ICORDO(4) + DO 720 JZ = MINDO(ICT), MAXDO(ICT)-1 + DZZ = DBLE(REMESH(JZ+1)) - DBLE(REMESH(JZ)) + DO 710 IVO1= 1, NVOLO + IF( INDEXO(ICT,IND(IVO1)).NE.JZ ) GO TO 710 + IF( INDEXO( 4,IND(IVO1)).NE.JRAY ) GO TO 710 + SWZCYL= SWZCYL.AND.(MATGEO(IND(IVO1)).LT.0) + VOLSO(IND(MATGEO(IND(IVO1))))= REAL(DZZ*SURF2) + 710 CONTINUE + 720 CONTINUE + ENDIF +* + IF( IPRT.GT.1 )THEN + NSUNN = NSURO-NESUR-NEVOL + NSURC = -1 + WRITE(IOUT,'(1H )') + WRITE(IOUT,'(/35H CELL SURFACES BEFORE ASSEMBLING )') + DO 180 IP = 1, (9 - NSUNN) / 10 + NSURM= MAX( NSUNN, NSURC-9 ) + WRITE(IOUT,'(10X,10(A5,I7))') + > (' SUR ',-IR,IR= NSURC, NSURM, -1) + WRITE(IOUT,'(8H VALUE ,2X,1P,10E12.4)') + > (4.*VOLSO(IND(IR)),IR=NSURC,NSURM,-1) + WRITE(IOUT,'(8H ORIENT ,2X,10A12)') + > (CORIEN(MATGEO(IND(IR))),IR=NSURC,NSURM,-1) + WRITE(IOUT,'(1H )') + NSURC = NSURC - 10 + 180 CONTINUE + NVONN= NVOLO-NEVOL + NVOLC= 1 + WRITE(IOUT,'(1H )') + WRITE(IOUT,'( 35H CELL VOLUMES BEFORE ASSEMBLING )') + DO 190 IP = 1, (9 + NVONN) / 10 + NVOLM= MIN( NVONN, NVOLC+9 ) + WRITE(IOUT,'(10X,10(A5,I7))') + > (' VOL ',IR,IR=NVOLC,NVOLM, 1) + WRITE(IOUT,'(8H VALUE ,2X,1P,10E12.4)') + > (VOLSO(IND(IR)),IR=NVOLC,NVOLM, 1) + WRITE(IOUT,'(8H MERGE ,2X,10I12)') + > (MATGEO(IND(IR)),IR=NVOLC,NVOLM, 1) + WRITE(IOUT,'(1H )') + NVOLC = NVOLC + 10 + 190 CONTINUE + IF( .NOT.SWZCYL ) + > CALL XABORT( 'XELVOL: '// + > 'CIRCULAR ZONES INCORRECTLY DEFINED' ) + ENDIF +* + RETURN +*---- +* Formats +*---- + 8000 FORMAT(1X,'****** WARNING IN XELVOL ******'/ + > 1X,'AT LEAST ONE REGION WITH NEGATIVE VOLUME'/ + > 1X,'THIS VOLUME IS RESET TO 0.0') + END diff --git a/Dragon/src/XHX2D0.f b/Dragon/src/XHX2D0.f new file mode 100644 index 0000000..844d015 --- /dev/null +++ b/Dragon/src/XHX2D0.f @@ -0,0 +1,207 @@ +*DECK XHX2D0 + SUBROUTINE XHX2D0 (NGPT,ZGAUS,WGAUS,COTE,SIGT,TRONC,PII,PIS,PSS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute DP0 collision, leakage and transmission probabilities for +* hexagonal 2D geometries. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): M. Ouisloumen +* +*Parameters: input +* NGPT number of Gauss integration points. +* COTE length of one of sides of the hexagon. +* SIGT total cross section. +* TRONC voided block cutoff criterion. +* ZGAUS Gauss-Legendre integration points. +* WGAUS Gauss-Legendre integration weights. +* +*Parameters: output +* PII volume to volume reduced probability. +* PIS leakage probability (PIS(i) volume to side i). +* PSS transmission probability (PSS(i,j) side i to side j). +* +*Comments: +* Faces identification for hexagon +* side 4 +* xxxxxxxx +* x x +* side 5 x x side 3 +* x x +* x x +* x x +* side 6 x x side 2 +* x x +* xxxxxxxx +* side 1 +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NGPT + REAL ZGAUS(NGPT),WGAUS(NGPT),COTE,SIGT,TRONC,PII,PIS(6), + + PSS(6,6) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MKI3=600,MKI4=600,MKI5=600) + PARAMETER (PI=3.141592653589793,SQRT3=1.732050807568877, + + SQRT2=1.414213562373095,ALOG2=.693147180559945, + + ALOG3=1.0986122886681097,ALOGX=.7676517525907618) +* + REAL TAU(3),FKI3(3),FKI4(3),FKI5(3),FKI6(3) + INTEGER IROT(6,6) + DOUBLE PRECISION P(3),PIS10 +*---- +* ASSUME THAT BICKLEY KI TABLES HAVE THE SAME TABULATION POINTS AND +* THE SAME TRUNCATION LIMIT +*---- + COMMON /BICKL3/BI3(0:MKI3),BI31(0:MKI3),BI32(0:MKI3),PAS3,XLIM3,L3 + COMMON /BICKL4/BI4(0:MKI4),BI41(0:MKI4),BI42(0:MKI4),PAS4,XLIM4,L4 + COMMON /BICKL5/BI5(0:MKI5),BI51(0:MKI5),BI52(0:MKI5),PAS5,XLIM5,L5 +* + SAVE IROT + DATA IROT / + + 0, 1, 2, 3, 2, 1, + + 1, 0, 1, 2, 3, 2, + + 2, 1, 0, 1, 2, 3, + + 3, 2, 1, 0, 1, 2, + + 2, 3, 2, 1, 0, 1, + + 1, 2, 3, 2, 1, 0/ +* + FUNC3(X,K)=BI3(K)+X*(BI31(K)+X*BI32(K)) + FUNC4(X,K)=BI4(K)+X*(BI41(K)+X*BI42(K)) + FUNC5(X,K)=BI5(K)+X*(BI51(K)+X*BI52(K)) +*---- +* INITIALIZATION OF COLLISION PROBABILITIES +*---- + P(3)=0. + P(2)=0. + P(1)=0. +*---- +* COMPUTE CORDE =4*V*SIGMA/S=SQRT(3)*COTE*SIGMA (AVERAGE CORDE) +*---- + CORDE=SQRT3*COTE*SIGT + IF (CORDE.LE.TRONC) GO TO 300 +*---- +* CONSIDER EXPLICIT INTEGRATION OF F PSS +*---- + PI12=PI/12. +* +* CONSIDER TWO CASES 1) IF ZGAUS(I)<0 => 1/COSFI>1/SINA>1/COSA +* 2) IF ZGAUS(I)>0 => 1/COSFI>1/COSA>1/SINA +* + NGPT2=IFIX(FLOAT(NGPT)/2.) + DO 50 I=1,NGPT + FI=PI12*(1.+ZGAUS(I)) + COSFI=COS(FI) + SINFI=SIN(FI) + COSA=SQRT3*COSFI-SINFI + AUX=SQRT3*SINFI + SINA=AUX+COSFI + SINB=COSFI-AUX +*---- +* OPTICAL LENGHTS +*---- + TAU(1)=CORDE/COSFI + IAUX1=2 + IAUX2=3 + IF(I.GT.NGPT2) THEN + IAUX1=3 + IAUX2=2 + ENDIF + TAU(IAUX1)=CORDE/SINA + TAU(IAUX2)=CORDE/COSA +* + LB=4 + IF(TAU(1).LT.XLIM3) THEN + LB=1 + ELSEIF(TAU(2).LT.XLIM3) THEN + LB=2 + ELSEIF(TAU(3).LT.XLIM3) THEN + LB=3 + ENDIF +* + DO 10 J=LB,3 + K1=NINT(PAS3*TAU(J)) + FKI3(J)=FUNC3(TAU(J),K1) + FKI4(J)=FUNC4(TAU(J),K1) + FKI5(J)=FUNC5(TAU(J),K1) + FKI6(J)=.8*FKI4(J)+.2*TAU(J)*(FKI3(J)-FKI5(J)) + 10 CONTINUE +* + WEIGHT=0.0 + GO TO (20,25,30,50),LB +*---- +* PSS CALCULATION +*---- + 20 WEIGHT=WGAUS(I) + P(3)=P(3)+WEIGHT*SINB*FKI3(1) + P(2)=P(2)+WEIGHT*COSFI*SINA*(FKI4(IAUX1)-FKI4(1)) + GO TO 30 +* + 25 WEIGHT=WGAUS(I) + P(2)=P(2)+WEIGHT*COSFI*SINA*FKI4(IAUX1) + 30 P(1)=P(1)+WEIGHT*SINFI*COSA*(BI4(0)-FKI4(IAUX2)) + 50 CONTINUE +*---- +* NORMALIZATION +*---- + X1=1./(3.*CORDE) + P(1)=X1*P(1) + P(2)=X1*P(2) + P(3)=P(3)/3. + PIS10=(1.-2.*(P(1)+P(2))-P(3))/(6.*CORDE) + PII=(1.-6.*REAL(PIS10))/SIGT +* + GO TO 350 +*---- +* USE SERIES EXPANSION FOR CORDE->0: TAYLOR SERIES OF KI FUNCTIONS +*---- + 300 TAU0=CORDE*.5 + TAU02=TAU0*TAU0 + AUX=SQRT3/PI + AUX0=1.-.5*SQRT3 + AUX1=AUX*ALOG3-.33333333333333333 + AUX2=2./SQRT3-(2.+ALOGX)/3. + P(1)=AUX0-.5*(TAU0*AUX1-TAU02*AUX2) + AUX1=AUX*(2.5*ALOG3-4.*ALOG2)-.5 + AUX2=5.*SQRT3-9.-2.*ALOG3+.5*ALOGX + P(2)=SQRT3-1.5+TAU0*AUX1-TAU02*AUX2/3. + AUX0=2.*AUX0 + AUX1=AUX*(.5*ALOG3-ALOG2) + P(3)=AUX0-8.*(1./6.+AUX1)*TAU0-4.*TAU02*(AUX0-.5*ALOG3) + PII=COTE*SQRT3*(4.*SQRT3-8.-2.*ALOGX+10.*ALOG3)/12. + PIS10=(1.-SIGT*PII)/6. +* + 350 CONTINUE +*---- +* TRANSMISSION MATRIX +*---- + DO 59 I=1,6 + DO 58 J=1,6 + IB=IROT(J,I) + IF(IB.GT.0) THEN + PSS(I,J)=REAL(P(IB)) + ELSE + PSS(I,J)=0. + ENDIF + 58 CONTINUE + 59 CONTINUE +*---- +* LEAKAGE PRABABILITIES MATRIX +*---- + DO 56 I=1,6 + PIS(I)=REAL(PIS10) + 56 CONTINUE +* + RETURN + END diff --git a/Dragon/src/XHX2D1.f b/Dragon/src/XHX2D1.f new file mode 100644 index 0000000..065e1c1 --- /dev/null +++ b/Dragon/src/XHX2D1.f @@ -0,0 +1,322 @@ +*DECK XHX2D1 + SUBROUTINE XHX2D1 (NGPT,ZGAUS,WGAUS,COTE,SIGT,TRONC,PII,PIS,PSS, + + P) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute DP1 collision, leakage and transmission probabilities for +* hexagonal 2D geometries. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): M. Ouisloumen +* +*Parameters: input +* NGPT number of Gauss integration points. +* COTE length of one of sides of the hexagon. +* SIGT total cross section. +* TRONC voided block cutoff criterion. +* ZGAUS Gauss-Legendre integration points. +* WGAUS Gauss-Legendre integration weights. +* +*Parameters: output +* PII volume to volume reduced probability. +* PIS leakage probability (PIS(i) volume to side i). +* PSS transmission probability (PSS(i,j) side i to side j). +* +*Parameters: scratch +* P undefined. +* +*Comments: +* Faces identification for hexagon +* side a,b,c +* side 4,5,6 dir a -> isotropic +* xxxxxxxx dir c -> tangent to surface +* x x dir b -> normal to surface +* side 7,8,9 x x side 1,2,3 +* x x +* x x +* x x +* side 10,11,12 x x side 16,17,18 +* x x +* xxxxxxxx +* side 13,14,15 +* +*---- +* SUBROUTINE ARGUMENTS +*---- + REAL FUNC3,FUNC4,FUNC5,X + INTEGER NGPT + REAL ZGAUS(NGPT),WGAUS(NGPT),COTE,SIGT,TRONC,PII,PIS(18), + + PSS(18,18) + DOUBLE PRECISION P(16) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MKI3=600,MKI4=600,MKI5=600) + PARAMETER (PI=3.141592653589793,SQRT3=1.732050807568877, + + SQRT2=1.414213562373095,ALOG2=.693147180559945, + + ALOG3=1.0986122886681097,ALOGX=.7676517525907618) +* + REAL TAU(3),FKI3(3),FKI4(3),FKI5(3),FKI6(3) + INTEGER IROT(18,18) + DOUBLE PRECISION PIS10,PIS11 +*---- +* ASSUME THAT BICKLEY KI TABLES HAVE THE SAME TABULATION POINTS AND +* THE SAME TRUNCATION LIMIT. +*---- + COMMON /BICKL3/BI3(0:MKI3),BI31(0:MKI3),BI32(0:MKI3),PAS3,XLIM3,L3 + COMMON /BICKL4/BI4(0:MKI4),BI41(0:MKI4),BI42(0:MKI4),PAS4,XLIM4,L4 + COMMON /BICKL5/BI5(0:MKI5),BI51(0:MKI5),BI52(0:MKI5),PAS5,XLIM5,L5 +* + SAVE IROT + DATA IROT / + + 0, 0, 0, 1, 2,-3, 7, 8,-9,13,14, 0, 7, 8, 9, 1, 2, 3, + + 0, 0, 0, 2, 4, 5, 8,10,11,14,15, 0, 8,10,-11, 2, 4,-5, + + 0, 0, 0, 3,-5, 6, 9,-11,12,0, 0,16,-9,11,12,-3, 5,6, + + 1, 2, 3, 0, 0, 0, 1, 2,-3, 7, 8,-9,13,14, 0, 7, 8, 9, + + 2, 4,-5, 0, 0, 0, 2, 4, 5, 8,10,11,14,15, 0, 8,10,-11, + + -3, 5, 6, 0, 0, 0, 3,-5, 6, 9,-11,12,0, 0,16,-9,11,12, + + 7, 8, 9, 1, 2, 3, 0, 0, 0, 1, 2,-3, 7, 8,-9,13,14, 0, + + 8,10,-11, 2, 4,-5, 0, 0, 0, 2, 4, 5, 8,10,11,14,15, 0, + + -9,11,12,-3, 5, 6, 0, 0, 0, 3,-5, 6, 9,-11,12,0, 0,16, + + 13,14, 0, 7, 8, 9, 1, 2, 3, 0, 0, 0, 1, 2,-3, 7, 8,-9, + + 14,15, 0, 8,10,-11, 2, 4,-5, 0, 0, 0, 2, 4, 5, 8,10,11, + + 0, 0,16,-9,11,12,-3, 5, 6, 0, 0, 0, 3,-5, 6, 9,-11,12, + + 7, 8,-9, 13,14, 0, 7, 8, 9, 1, 2, 3, 0, 0, 0, 1, 2,-3, + + 8,10,11,14,15, 0, 8,10,-11, 2, 4,-5, 0, 0, 0, 2, 4, 5, + + 9,-11,12, 0, 0,16,-9,11,12,-3, 5, 6, 0, 0, 0, 3,-5, 6, + + 1, 2,-3, 7, 8,-9, 13,14, 0, 7, 8, 9, 1, 2, 3, 0, 0, 0, + + 2, 4, 5, 8,10,11,14,15, 0, 8,10,-11, 2, 4,-5, 0, 0, 0, + + 3,-5, 6, 9,-11,12, 0, 0,16,-9,11,12,-3, 5, 6, 0, 0, 0/ +* + FUNC3(X,K)=BI3(K)+X*(BI31(K)+X*BI32(K)) + FUNC4(X,K)=BI4(K)+X*(BI41(K)+X*BI42(K)) + FUNC5(X,K)=BI5(K)+X*(BI51(K)+X*BI52(K)) +*---- +* INITIALIZATION OF COLLISION PROBABILITIES +*---- + P(:16)=0.0D0 +*---- +* COMPUTE CORDE =4*V*SIGMA/S=SQRT(3)*COTE*SIGMA (AVERAGE CORDE) +*---- + S2S3=SQRT2*SQRT3 + S3DS2=SQRT3/SQRT2 + CAUX=SQRT3*COTE + CORDE=CAUX*SIGT + IF (CORDE.LE.TRONC) GO TO 300 +*---- +* CONSIDER EXPLICIT INTEGRATION OF F PSS +*---- + PI12=PI/12. +* +* CONSIDER TWO CASES 1) IF ZGAUS(I)<0 => 1/COSFI>1/SINA>1/COSA +* 2) IF ZGAUS(I)>0 => 1/COSFI>1/COSA>1/SINA +* + NGPT2=IFIX(FLOAT(NGPT)/2.) + DO 50 I=1,NGPT + FI=PI12*(1.+ZGAUS(I)) + COSFI=COS(FI) + SINFI=SIN(FI) + AUX=SQRT3*COSFI + COSA=AUX-SINFI + COSB=AUX+SINFI + AUX=SQRT3*SINFI + SINA=AUX+COSFI + SINB=COSFI-AUX +*---- +* WEIGHTS TIMES BICKLEY NAYLOR FUNCTIONS +*---- + W006=SINFI*COSA + W106=W006*COSB + W005=COSFI*SINA + W105=W005*COSB + W204=COSFI*SINB + W114=SINFI*SINFI*SINB + W224=COSFI*W204 +*---- +* OPTICAL LENGHTS +*---- + TAU(1)=CORDE/COSFI + IAUX1=2 + IAUX2=3 + IF(I.GT.NGPT2) THEN + IAUX1=3 + IAUX2=2 + ENDIF + TAU(IAUX1)=CORDE/SINA + TAU(IAUX2)=CORDE/COSA +* + LB=4 + IF(TAU(1).LT.XLIM3) THEN + LB=1 + ELSEIF(TAU(2).LT.XLIM3) THEN + LB=2 + ELSEIF(TAU(3).LT.XLIM3) THEN + LB=3 + ENDIF +* + DO 10 J=LB,3 + K1=NINT(PAS3*TAU(J)) + FKI3(J)=FUNC3(TAU(J),K1) + FKI4(J)=FUNC4(TAU(J),K1) + FKI5(J)=FUNC5(TAU(J),K1) + FKI6(J)=.8*FKI4(J)+.2*TAU(J)*(FKI3(J)-FKI5(J)) + 10 CONTINUE + WEIGHT=0.0 + GO TO (20,25,30,50),LB +*---- +* PSS CALCULATION +*---- + 20 WEIGHT=WGAUS(I) + P(13)=P(13)+WEIGHT*SINB*FKI3(1) + P(14)=P(14)+WEIGHT*W204*FKI4(1) + P(16)=P(16)+WEIGHT*W114*FKI5(1) + P(15)=P(15)+WEIGHT*W224*FKI5(1) + AUX5=WEIGHT*W005 + P(7)=P(7)+AUX5*(FKI4(IAUX1)-FKI4(1)) + P(9)=P(9)+WEIGHT*W105*(FKI5(IAUX1)-FKI5(1)) + AUX=AUX5*(FKI6(IAUX1)-FKI6(1)) + P(11)=P(11)+AUX + P(10)=P(10)+W005*AUX + GO TO 30 +* + 25 WEIGHT=WGAUS(I) + AUX5=WEIGHT*W005 + P(7)=P(7)+AUX5*FKI4(IAUX1) + P(9)=P(9)+WEIGHT*W105*FKI5(IAUX1) + AUX=AUX5*FKI6(IAUX1) + P(11)=P(11)+AUX + P(10)=P(10)+W005*AUX + 30 P(1)=P(1)+WEIGHT*W006*(BI4(0)-FKI4(IAUX2)) + P(3)=P(3)+WEIGHT*W106*(BI5(0)-FKI5(IAUX2)) + AUX=W006*WEIGHT*(.533333333333333-FKI6(IAUX2)) + P(5)=P(5)+AUX + P(4)=P(4)+AUX*W006 + 50 CONTINUE +*---- +* NORMALIZATION +*---- + CORDI=1./CORDE + X1=CORDI/3. + X2=CORDI*SQRT3 + X3=3.*CORDI + X4=X2/SQRT2 + P(1)=X1*P(1) + P(3)=X2*P(3)/6. + P(5)=-X4*P(5) + P(4)=X3*P(4) + P(7)=X1*P(7) + P(9)=X1*P(9)*.5 + P(11)=-X4*P(11) + P(10)=X3*P(10) + P(13)=P(13)/3. + P(14)=SQRT2*P(14) + P(16)=4.*P(16)/3. + P(15)=6.*P(15) + AUX=2.*SQRT2 + P(2)=S3DS2*P(3)-AUX*P(1) + P(8)=3.*S3DS2*P(9)-AUX*P(7) + P(14)=P(14)-AUX*P(13) + COEF=1./(6.*CORDE) + PIS10=(1.-2.*(P(1)+P(7))-P(13))*COEF + PIS(1)=REAL(PIS10) + PIS11=-(2.*(P(2)+P(8))+P(14))*COEF + PIS(2)=REAL(PIS11) + PII=(1.-6.*PIS(1))/SIGT +* + GO TO 350 +*---- +* USE SERIES EXPANSION FOR CORDE->0: TAYLOR SERIES OF KI FUNCTIONS +*---- + 300 TAU0=CORDE*.5 + TAU02=TAU0*TAU0 + AUX=SQRT3/PI + AUX0=1.-.5*SQRT3 + AUX1=AUX*ALOG3-.33333333333333333 + AUX2=2./SQRT3-(2.+ALOGX)/3. + P(1)=AUX0-.5*(TAU0*AUX1-TAU02*AUX2) + P(5)=-S2S3*(1.125*AUX0-.5*TAU0*AUX1+.375*TAU02*AUX2) + P(3)=(-(1.5*ALOGX+1.-SQRT3)*TAU0*.25+(1.-TAU02)/9+ + + AUX*TAU02/3.)*SQRT3 + P(4)=2.25*(1.25*SQRT3-2.)-TAU0*(2.-3.*AUX)+TAU02* + + (2.25*ALOGX-1.5) + XAUX=5.*SQRT3-9. + XAUX0=SQRT3-1.5 + AUX1=AUX*(2.5*ALOG3-4.*ALOG2)-.5 + AUX2=XAUX-2.*ALOG3+.5*ALOGX + P(7)=XAUX0+TAU0*AUX1-TAU02*AUX2/3. + P(11)=-S2S3*(1.125*XAUX0+TAU0*AUX1-.25*AUX2*TAU02) + P(9)=SQRT3/9.+.25*(XAUX-.5*SQRT3*(2.*ALOG3-ALOGX))*TAU0- + + (9.*ALOG3-16.*ALOG2-3.)*TAU02/(3.*PI) + P(10)=2.25*(SQRT3-.75)+TAU0*(3.*AUX-6.)-1.5*TAU02* + + (9.*(2.-SQRT3)+1.5*ALOGX-6.*ALOG3) + AUX0=2.*AUX0 + AUX1=AUX*(.5*ALOG3-ALOG2) + P(13)=AUX0-8.*(1./6.+AUX1)*TAU0-4.*TAU02*(AUX0-.5*ALOG3) + P(15)=4.5*(2.5-SQRT3)-8.*TAU0+36.*TAU02*AUX0 + AUX2=XAUX-2.*ALOG3+.5*ALOGX + P(16)=3.5-2.*SQRT3-64.*TAU0*(AUX1+1./12.)/3.+8.*TAU02* + + (.5*ALOG3-2.*AUX0) + PSQ3=SQRT3/PI + P(14)=SQRT2*(2./3.-6.*TAU0*AUX0+TAU02*(4.+24.*PSQ3* + + (.5*ALOG3-ALOG2))) + PII=COTE*SQRT3*(4.*SQRT3-8.-2.*ALOGX+10.*ALOG3)/12. + PIS(1)=(1.-SIGT*PII)/6. + PIS(2)=-SQRT2*(2.5-2.25*ALOG3+TAU0*(9.+PSQ3*(4.-8.*ALOG2+ + + 3.*ALOG3)-8./SQRT3-(20.*ALOG3-4.*ALOGX)/3.))/12. + AUX=2.*SQRT2 + P(2)=S3DS2*P(3)-AUX*P(1) + P(8)=3.*S3DS2*P(9)-AUX*P(7) + P(14)=P(14)-AUX*P(13) +* + 350 CONTINUE +*---- +* COMPUTE REMAINING PROBABILITIES +*---- + P(4)=P(4)-4.*SQRT3*P(3)+8.*P(1) + P(5)=P(5)+AUX*P(3) + P(6)=(S2S3*P(5)+8.*(-SQRT3*P(3)+P(1))-P(4))*2./9. + P(10)=P(10)-4.*SQRT2*P(8)-8.*P(7) + P(11)=P(11)+AUX*P(9) + P(12)=(8.*(P(7)-SQRT3*P(9))-S2S3*P(11)-P(10))*2./9. + P(15)=P(15)-4.*SQRT2*P(14)-8.*P(13) + P(3)=-P(3) + P(5)=-P(5) + P(9)=-P(9) + P(11)=-P(11) +*---- +* TRANSMISSION MATRIX +*---- + DO 59 I=1,18 + DO 58 J=1,18 + IB=IROT(J,I) + IF(IB.LT.0) THEN + PSS(I,J)=-REAL(P(-IB)) + ELSEIF(IB.GT.0) THEN + PSS(I,J)=REAL(P(IB)) + ELSE + PSS(I,J)=0. + ENDIF + 58 CONTINUE + 59 CONTINUE +*---- +* LEAKAGE PRABABILITIES MATRIX +*---- + PIS(3)=0. + K=3 + DO 56 I=1,5 + K=K+3 + PIS(K-2)=PIS(1) + PIS(K-1)=PIS(2) + PIS(K)=0. + 56 CONTINUE +* + RETURN + END diff --git a/Dragon/src/XHXTRK.f b/Dragon/src/XHXTRK.f new file mode 100644 index 0000000..7f6f8ac --- /dev/null +++ b/Dragon/src/XHXTRK.f @@ -0,0 +1,646 @@ +*DECK XHXTRK + SUBROUTINE XHXTRK(IPTRK ,IPGEOM,GEONAM,IDISP ,IFTEMP, + > IPRT ,NDIM ,ITOPT ,NV ,NS ,NANGL , + > ISYMM ,DENS ,PCORN ,MXSEG ,ICODE ,TITREC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Call all routines for the production of tracks for the +* hexagonal geometry. +* +*Copyright: +* Copyright (C) 1991 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): M. Ouisloumen +* +*Parameters: input +* IPTRK pointer to the excell tracking. +* IPGEOM pointer to the geometry. +* GEONAM geometry name. +* IFTEMP temporary tracking file. +* IPRT print option. +* TITREC title for execution. +* +*Parameters: input/output +* IDISP tracking file disposition: +* = -2 no traking - only analyse geometry +* then abort (option halt); +* = -1 modify tracking file; +* = 0 old tracking file; +* = 1 new tracking file. +* +*Parameters: output +* NDIM number of physical dimensions. +* ITOPT tracking option: +* = 0 finite; = 1 cyclic. +* NV number of physical regions. +* NS number of outer surface. +* NANGL number of angles. +* ISYMM symmetry factor. +* DENS track density. +* PCORN corner proximity. +* MXSEG maximum segment length. +* ICODE albedo associated with face. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE + INTEGER IOUT,NSTATE + CHARACTER*6 NAMSBR + DOUBLE PRECISION PI + PARAMETER (IOUT=6,NSTATE=40,PI=3.141592653589793D0, + > NAMSBR='XHXTRK') +*---- +* ROUTINE PARAMETERS +*---- + TYPE(C_PTR) IPTRK,IPGEOM + INTEGER IDISP,IFTEMP,IPRT,NDIM,MXSEG,ITOPT,NV,NS,NANGL, + > ISYMM,ICODE(6) + CHARACTER GEONAM*12,TITREC*72 + REAL DENS,PCORN +*---- +* LOCAL VARIABLES +*---- + INTEGER KDROPN,KDRCLS + INTEGER IFILE,IER + INTEGER ISTATE(NSTATE),NCODE(6),IPARAM(NSTATE) + INTEGER NEIGHB + LOGICAL SECTOR + REAL ALBEDO(6),DENUSR,DENUSZ,EXTKOP(NSTATE) + DOUBLE PRECISION DBLINP,AUX,SINT,SINF,COST,COSF, + > SINT1,SINF1,COST1,COSF1 + DOUBLE PRECISION COS1,COS2,COS3,PASY,PASZ,PPASY,PPASZ, + > RAYON,POIDS,DZMIN,DZMAX,DSIDE + INTEGER NSOUT,ILNLCM,ITPLCM,NSMIN,NSMAX,NCELA,MVOLUM, + > MMESH,LINMAX,LTRK,NANGLE,INDLEC,NGLE,NPHI,NTETA, + > IQUAD,INDATA,IHEX,LEVEL,NCL,NCOUR,IPLANZ,NCPHY, + > NREGIO,LXI,MCODE,IPLANI,NCELAP,IDIM1,IDIM2, + > IAUX,IA,KGAUS,IG,JG,JAUX,MAXCYL,I,J,MAXSEC,MMAXS, + > NALBG,NSURF,MACP,MTT,MT0,NBLINE,KANG,ICC,ICC1, + > ICORN,IFCC1,IXX,IYY,IYY0,NCEL2,IVV,II,IAUXS, + > IAUXX,IANG,ISS,ISUR + REAL POIDSH,RCUTOF,CUTOFX,DEN,REDATA,SIDE,ZMIN,SQRT3 + CHARACTER TEDATA*8,COMENT*80 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: KEYMRG,MATALB,LATV,ICEL, + + IPLAN,IFACB,IFFV,ISURB,IVSYM,ISSYM,IMAT,KCORN,IVOIS,MATRT,SURL, + + IV0 + REAL, ALLOCATABLE, DIMENSION(:) :: VOLSUR,MESH,XGS,WGS,XGS1, + + WGS1,WW,A1,A2,A3,T0,T1,RAUX + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: ANGLES,DENSTY,POP +*---- +* DATA AND COMMONS +*---- + CHARACTER CSTOP*8,CTISO*8, CTSPC*8,CNOTR*8, CBLAN*8, + > CGAUS*8, CEQW*8 + SAVE CSTOP,CTISO,CTSPC,CNOTR,CBLAN,CGAUS,CEQW + DATA CSTOP,CTISO,CTSPC,CNOTR,CBLAN,CGAUS,CEQW + > / 'STOP','TISO','TSPC', 'NOTR',' ' , + > 'GAUS','EQW' / + PCORN=0.0 + DENS=0.0 + ISYMM=1 +* +** 2.1) TAKE THE ORIGINAL GEOMETRY. + ISTATE(:NSTATE)=0 + CALL LCMLEN(IPGEOM,'STATE-VECTOR',ILNLCM,ITPLCM) + IF (ILNLCM .GT. 0 .AND. ILNLCM .LE. NSTATE) THEN + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) + ELSE + CALL XABORT('XHXTRK: INVALID STATE VECTOR IN GEOMETRY') + ENDIF + CALL LCMGET(IPGEOM,'NCODE',NCODE) + NDIM=2 + IF(ISTATE(5).GT.0) NDIM=3 +* + NSMIN = 0 + NSMAX = 0 + NCELA = 0 + MVOLUM= 0 + MMESH = 0 + LINMAX= 0 + LTRK = 0 + NANGLE= 0 + DENUSR=10.0 + DENUSZ=10.0 + RCUTOF= 0.0 + CUTOFX= 0.0 + TEDATA= CBLAN + IQUAD=0 +* +** 1) READ ALL USER INPUT. +* +* READ TRACKING PARAMETERS LTRK= 0 : NO TRACKING +* LTRK= 1 : ISOTROPIC TRACKING (TISO) +* LTRK= 2 : SPECULAR TRACKING (TSPC) + IF( IDISP.GT.0 )THEN + CALL REDGET( INDLEC, NGLE, DEN, TEDATA, DBLINP) + IF( INDLEC.NE.3 ) THEN + CALL XABORT('XHXTRK: TYPE OF INTEGRATION NOT SPECIFIED ') + ENDIF + LTRK=1 + IF( TEDATA(1:4).EQ.CSTOP(1:4) ) THEN +* +* INITIALISATION PAR DEFAUT +* + NPHI=5 + NTETA=5 + IQUAD=1 + GOTO 55 + ELSEIF( TEDATA(1:4).EQ.CTISO(1:4) ) THEN + LTRK=1 + IQUAD=2 + NTETA=1 + CALL REDGET( INDLEC, NPHI , DEN, TEDATA, DBLINP) + IF( INDLEC .EQ. 3 ) THEN + IF(TEDATA(1:4) .EQ. CGAUS(1:4)) THEN + IQUAD=1 + ELSE IF(TEDATA(1:3) .NE. CEQW(1:3)) THEN + CALL XABORT('XHXTRK: INVALID INTEGRATION TYPE') + ENDIF + CALL REDGET( INDLEC, NPHI , DEN, TEDATA, DBLINP) + ELSE IF( INDLEC.EQ.2 ) THEN + CALL XABORT('XHXTRK: INVALID DATA FOLLOWING TISO ') + ENDIF + IF(NDIM .EQ. 3) THEN + IF(INDLEC .NE. 1) + > CALL XABORT('XHXTRK: NTETA MUST BE INTEGER') + IF(NPHI .LE. 1) CALL XABORT('XHXTRK: NTETA < 2 ') + NTETA=NPHI + CALL REDGET( INDLEC, NPHI , DENUSR, TEDATA, DBLINP) + ENDIF + IF(INDLEC .NE. 1) + > CALL XABORT('XHXTRK: NPHI MUST BE INTEGER') + IF(NPHI .LE. 1) CALL XABORT('XHXTRK: NPHI < 2 ') + CALL REDGET( INDLEC, NPHI , DENUSR, TEDATA, DBLINP) + IF (INDLEC .NE. 2) + > CALL XABORT('XHXTRK: DENSITY MUST BE REAL') + IF(DENUSR .LE. 0.0) CALL XABORT('XHXTRK: DENSITY < 0.0 ') + IF(NDIM .EQ. 3) THEN + CALL REDGET( INDLEC, NGLE , DENUSZ, TEDATA, DBLINP) + IF(INDLEC .NE. 2) + > CALL XABORT('XHXTRK: DENSITY MUST BE REAL') + IF(DENUSZ .LE. 0.0) CALL XABORT('XHXTRK: DENSITY < 0 ') + ENDIF + IF(IQUAD .EQ. 1) THEN + IF(NTETA .GT. 64 .OR. NPHI .GT. 64) THEN + CALL XABORT('XHXTRK: NANGLE IS GREATER THAN 64.') + ENDIF + ENDIF + IF(NDIM .EQ. 2)THEN + NANGLE=NTETA*NPHI*2 + ELSE + NANGLE=NTETA*NPHI*4 + ENDIF + ELSEIF( TEDATA(1:4).EQ.CTSPC(1:4) ) THEN + LTRK = 2 + CALL XABORT('XHXTRK: *TSPC* NOT AVAILABLE FOR HEXAGONE' ) + ELSEIF( TEDATA(1:4).EQ.CNOTR(1:4) )THEN + LTRK=0 + GOTO 54 + ELSEIF( TEDATA(1:4).NE.CGAUS(1:4) + + .OR.TEDATA(1:4).NE.CEQW(1:4) ) THEN + CALL XABORT('XHXTRK: CHARACTER EXPECTED ') + ENDIF + 54 CALL REDGET( INDLEC, INDATA, REDATA, TEDATA, DBLINP) + IF( INDLEC.NE.3.OR.TEDATA(1:1).NE.';' )THEN + CALL XABORT( 'XHXTRK: ; IS SUPPOSED TO BE HERE' ) + ENDIF + 55 CONTINUE + ENDIF +** EVERYTHING IS NOW READ. +*---- +* SAVE EXCELL SPECIFIC TRACKING INFORMATION. +*---- + ISTATE(:NSTATE)=0 + EXTKOP(:NSTATE)=0.0 + ISTATE(9)=LTRK-1 + ISTATE(11)=NANGLE + ISTATE(12)=ISYMM + CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,ISTATE) + EXTKOP(2)=DENUSR + CALL LCMPUT(IPTRK,'EXCELTRACKOP',NSTATE,2,EXTKOP) +* +** 2) PROCEED TO THE EXACT GEOMETRY TREATMENT. +* +* +* STUDY TRACKING PARAMETERS. ARE THEY BASICALLY POSSIBLE ? + IF( IPRT.GT.0 )THEN + WRITE(IOUT,6000) GEONAM + ENDIF +* -------------*************************************-------------------- +* / / +* / TRAITEMENT DE LA GEOMETRIE HEXAGONALE / +* / / +*--------------*************************************-------------------- +* +* DUPLICATE AND UNFOLD THE GEOMETRY. +* + CALL LCMGET(IPGEOM,'IHEX',IHEX) + LEVEL= 1 + IF(IHEX.EQ.9) THEN + IF(NCODE(5) .EQ. 5 .OR. NCODE(6) .EQ. 5 .OR. + > NCODE(5) .EQ. 10 .OR. NCODE(6) .EQ. 10) THEN + NCL=ISTATE(3) + NCOUR=NINT( (4.+SQRT(1.+4.*FLOAT(NCL-1)/3.) + + +SQRT(1.+4.*FLOAT(NCL-2)/3.))*.25) + ALLOCATE(LATV(2*NCOUR)) + ENDIF + ENDIF + CALL LHXUNH(IPTRK,IPGEOM,GEONAM,MMESH,NCELA,IPLANZ,NCPHY,ICODE, + + ALBEDO,NV,NREGIO,NS,SIDE,ISTATE,NSMIN,NSMAX,MVOLUM, + + IHEX,LXI,MCODE,IPLANI,LATV) + CALL LCMSIX(IPTRK,'DATA_DUP',1) + CALL LCMLEN(IPTRK,'SURL_HEX',ISUR,ITPLCM) + ALLOCATE(SURL(MAX(1,ISUR))) + IF(ISUR.GT.0) CALL LCMGET(IPTRK,'SURL_HEX',SURL) + CALL LCMSIX(IPTRK,' ',2) +* + NCELAP=NCELA/IPLANZ + IDIM1=2*NCELA+MVOLUM + IDIM2=2*IPLANZ + IAUX=NV+NS+1 + ALLOCATE(MESH(MMESH),ICEL(IDIM1),IPLAN(IDIM2)) + ALLOCATE(VOLSUR(IAUX),MATALB(IAUX),KEYMRG(IAUX)) + IF(IQUAD.EQ.1.OR.IQUAD.EQ.2) THEN + ALLOCATE(XGS(NPHI),WGS(NPHI)) + IF(NDIM.EQ.3) THEN + ALLOCATE(XGS1(NTETA),WGS1(NTETA)) + ENDIF + ENDIF + ALLOCATE(WW(NANGLE),A1(NANGLE),A2(NANGLE)) + IF(NDIM.EQ.3)ALLOCATE(A3(NANGLE)) + IF(IQUAD.EQ.1) THEN +* +* GAUSS-LEGENDRE INTEGRATION POINTS +* + CALL ALGPT(NPHI,-1.,1.,XGS,WGS) + IF(NDIM.EQ.3) + > CALL ALGPT(NTETA,-1.,1.,XGS1,WGS1) + ELSEIF(IQUAD.EQ.2) THEN +* +* EQUAL WEIGHT INTEGRATION POINTS. +* + DO 51 IA=1,NPHI + XGS(IA)=(2.0*REAL(IA)-1.0)/REAL(NPHI)-1.0 + WGS(IA)=2.0/REAL(NPHI) + 51 CONTINUE + IF(NDIM.EQ.3) THEN + DO 61 IA=1,NTETA + XGS1(IA)=(2.0*REAL(IA)-1.0)/REAL(NTETA)-1.0 + WGS1(IA)=2.0/REAL(NTETA) + 61 CONTINUE + ENDIF +* + ENDIF + IF(IQUAD.EQ.1.OR.IQUAD.EQ.2) THEN + KGAUS=-1 + IF(NDIM.EQ.3) THEN + AUX=PI*0.125D0*0.125D0 + DO 445 IG=0,NTETA-1 +* +* INTEGRATION OVER (0,PI/2) (COLATITUDE) +* + SINT=SIN(0.25D0*PI*(DBLE(XGS1(IG+1))+1.0D0)) + COST=COS(0.25D0*PI*(DBLE(XGS1(IG+1))+1.0D0)) +* INTEGRATION OVER (PI/2,PI) (COLATITUDE) + SINT1=SIN(0.25D0*PI*(DBLE(XGS1(IG+1))+3.0D0)) + COST1=COS(0.25D0*PI*(DBLE(XGS1(IG+1))+3.0D0)) + DO 444 JG=0,NPHI-1 +* INTEGRATION OVER (0,PI/2) (LATITUDE) + SINF=SIN(0.25D0*PI*(DBLE(XGS(JG+1))+1.0D0)) + COSF=COS(0.25D0*PI*(DBLE(XGS(JG+1))+1.0D0)) + KGAUS=KGAUS+1 + WW(KGAUS+1)=REAL(AUX*WGS1(IG+1)*WGS(JG+1)*SINT) + A1(KGAUS+1)=REAL(SINT*COSF) + A2(KGAUS+1)=REAL(SINT*SINF) + A3(KGAUS+1)=REAL(COST) + KGAUS=KGAUS+1 + WW(KGAUS+1)=REAL(AUX*WGS1(IG+1)*WGS(JG+1)*SINT1) + A1(KGAUS+1)=REAL(SINT1*COSF) + A2(KGAUS+1)=REAL(SINT1*SINF) + A3(KGAUS+1)=REAL(COST1) +* INTEGRATION OVER (PI/2,PI) + SINF1=SIN(0.25D0*PI*(DBLE(XGS(JG+1))+3.0D0)) + COSF1=COS(0.25D0*PI*(DBLE(XGS(JG+1))+3.0D0)) + KGAUS=KGAUS+1 + WW(KGAUS+1)=REAL(AUX*WGS1(IG+1)*WGS(JG+1)*SINT) + A1(KGAUS+1)=REAL(SINT*COSF1) + A2(KGAUS+1)=REAL(SINT*SINF1) + A3(KGAUS+1)=REAL(COST) + KGAUS=KGAUS+1 + WW(KGAUS+1)=REAL(AUX*WGS1(IG+1)*WGS(JG+1)*SINT1) + A1(KGAUS+1)=REAL(SINT1*COSF1) + A2(KGAUS+1)=REAL(SINT1*SINF1) + A3(KGAUS+1)=REAL(COST1) + 444 CONTINUE + 445 CONTINUE + DEALLOCATE(XGS1,WGS1) + ELSE + AUX=0.125D0 + DO 544 JG=0,NPHI-1 +* INTEGRATION OVER (0,PI/2) + SINF=SIN(0.25D0*PI*(DBLE(XGS(JG+1))+1.0D0)) + COSF=COS(0.25D0*PI*(DBLE(XGS(JG+1))+1.0D0)) + KGAUS=KGAUS+1 + WW(KGAUS+1)=REAL(AUX*WGS(JG+1)) + A1(KGAUS+1)=REAL(COSF) + A2(KGAUS+1)=REAL(SINF) +* INTEGRATION OVER (PI/2,PI) + SINF=SIN(0.25*PI*(DBLE(XGS(JG+1))+3.0D0)) + COSF=COS(0.25*PI*(DBLE(XGS(JG+1))+3.0D0)) + KGAUS=KGAUS+1 + WW(KGAUS+1)=REAL(AUX*WGS(JG+1)) + A1(KGAUS+1)=REAL(COSF) + A2(KGAUS+1)=REAL(SINF) + 544 CONTINUE + ENDIF + DEALLOCATE(WGS,XGS) + ENDIF + NANGL= NANGLE + ALLOCATE(ANGLES(3*NANGL),DENSTY(NANGL)) + DO 21 IANG=1,NANGL + ANGLES((IANG-1)*NDIM+1)=A1(IANG) + ANGLES((IANG-1)*NDIM+2)=A2(IANG) + IF(NDIM.EQ.3) ANGLES((IANG-1)*NDIM+3)=0.0 + DENSTY(IANG)=1.0/WW(IANG) + 21 CONTINUE + IF(NDIM.EQ.3)ALLOCATE(IFACB(2*NCELAP)) + ALLOCATE(IFFV(NCELA),ISURB(NS-NSMIN-NSMAX),IVSYM(NV),ISSYM(NS)) + CALL MESHST(IPTRK,IPGEOM,MESH,ICEL,IPLAN, + + IPLAN(IPLANZ+1),NCELA,IPLANZ,ISTATE, + + ICEL(NCELA+1),ICEL(2*NCELA+1),NCPHY, + + VOLSUR,MATALB,SIDE,NCOUR, + + NSMIN,NSMAX,NS,IFACB,IFFV, + + ISURB,IVSYM,ISSYM,IHEX,LXI, + + NV,MCODE,SURL,IPLANI,LATV,ZMIN) + CALL LCMSIX(IPGEOM,' ',0) +*d - + IF(IHEX.EQ.9) THEN + IF(MCODE.GT.0) DEALLOCATE(LATV) + ENDIF + DEALLOCATE(SURL) +*---- +* SET ARRAY MERGE CONTAINING MERGED VOLUMES AND SURFACES +*---- + NSOUT=0 + JAUX=0 + DO 20 J=NS-1, 0,-1 + KEYMRG(JAUX+1)=-ISSYM(J+1) + NSOUT=MAX(NSOUT,ISSYM(J+1)) + JAUX= JAUX+1 + 20 CONTINUE + KEYMRG(JAUX+1)=0 + JAUX= JAUX+1 + DO 29 J=0,NV-1 + KEYMRG(JAUX+1)=IVSYM(J+1) + JAUX= JAUX+1 + 29 CONTINUE + DEALLOCATE(IVSYM,ISSYM) +* +* OPENING THE TRACK FILE +* + IFILE=KDROPN('DUMMYSQ2',0,2,0) + IF( IFILE.LE.0 ) GO TO 998 + IF( IFILE.EQ.IFTEMP ) CALL XABORT('XHXTRK: BAD TRACKING UNIT') + IF( LTRK.NE.0 )THEN + MAXCYL=1 + DO 140 I=0,NCELA-1 + MAXCYL=MAX(MAXCYL,ICEL(NCELA+I+1)) + 140 CONTINUE + MAXSEC=1 + SECTOR=.FALSE. + DO 141 I=0,MVOLUM-1 + MMAXS=ICEL(2*NCELA+I+1) + IF(MMAXS.GT.1) SECTOR=.TRUE. + MAXSEC=MAX(MAXSEC,MMAXS) + 141 CONTINUE + ITOPT= LTRK-1 + NALBG= 6 + NSURF=2 + IF(NDIM.EQ.3) NSURF=4 + MXSEG= 2*NV+2*NSURF + WRITE(IFILE) '$TRK',5,0,0 + COMENT='CREATOR : DRAGON' + WRITE(IFILE) COMENT + COMENT='MODULE : XHXTRK' + WRITE(IFILE) COMENT + COMENT='TYPE : HEXAGONALE' + WRITE(IFILE) COMENT + COMENT='GEOMETRY : '//GEONAM + WRITE(IFILE) COMENT + COMENT=TITREC + WRITE(IFILE) COMENT + WRITE(IFILE) NDIM,ITOPT,NV,NS,NALBG,NSURF,NANGL,1,MXSEG + WRITE(IFILE) (VOLSUR(J),J=1,IAUX) + WRITE(IFILE) (MATALB(J),J=1,IAUX) + WRITE(IFILE) (ICODE(J),J=1,NALBG) + WRITE(IFILE) (ALBEDO(J),J=1,NALBG) + WRITE(IFILE) (ANGLES(J),J=1,NDIM*NANGL) + WRITE(IFILE) (DENSTY(J),J=1,NANGL) + DEALLOCATE(DENSTY,ANGLES) + MACP=(MAXCYL+1)*2*NCELA*(1+6*(MAXSEC-1)) + ALLOCATE(POP(MACP),IMAT(MACP*2)) + MTT=2*(MAXCYL+1) + MT0=2*MTT*(1+6*(MAXSEC-1)) + ALLOCATE(T0(2*MT0),T1(2*MT0),IV0(MT0)) +* +* RAYON DU CYLINDRE ENGLOBANT LA GEOMETRIE ET VALEURES EXTREMES DE Z +* + DSIDE=DBLE(SIDE) + RAYON=0.5D0*DSIDE*SQRT(1.0D0+3.0D0*(DBLE(2*NCOUR-1))**2) +* +* FIND ODD NUMBER OF TRACKS THAT ENSURES MINIMUM REQUIRED +* DENSITY IS RESPECTED +* + NBLINE=INT(RAYON*DENUSR+0.5D0) + IF(MOD(NBLINE,2) .EQ. 0) NBLINE=NBLINE+1 + PASY=1.D0/DBLE(NBLINE) + PASZ=PASY + IF(NDIM.EQ.3) THEN + NBLINE=INT(RAYON*DENUSZ+0.5D0) + IF(MOD(NBLINE,2) .EQ. 0) NBLINE=NBLINE+1 + PASZ=1.D0/DBLE(NBLINE) + ENDIF + KANG=0 + ICC=1 + ICC1=1 + IF(NCELA.GT.1) THEN + ICC=2+(NCOUR-1)*(1+3*(NCOUR-2)) + ICC1=2+(NCOUR-1)*(3*(NCOUR-2)) + ENDIF + DZMIN=DBLE(ZMIN) + IF(NDIM.EQ.3) THEN + DZMAX=DBLE(MESH(3*NCELA)) + ELSE + DZMAX=DZMIN + ENDIF +* + SQRT3=SQRT(3.) + ALLOCATE(RAUX(2*MAXCYL)) +* +*--CREATION DU VECTEUR CORN NECESSAIRE POUR LE STOCKAGE DES CELLULES +*--PERIPHERIQUES UTILISEES DANS TRKHEX +* + IF(NDIM.EQ.3) THEN + ICORN=IPLAN(1) + IF(IPLANZ.GT.1) ICORN=ICORN+IPLAN(1) + IF(IPLANZ.GT.2) ICORN=ICORN+(IPLANZ-2)*6*(NCOUR-1) + ELSE + ICORN=1 + IF(NCOUR.GT.1)ICORN=6*(NCOUR-1) + ENDIF + ALLOCATE(KCORN(ICORN)) + IFCC1=2+(NCOUR-1)*(3*(NCOUR-2)) + IF(NCELA.EQ.1) IFCC1=1 + IXX=0 + IF(NDIM.EQ.3) THEN + DO 147 I=1,IPLAN(1) + KCORN(IXX+1)=I + IXX=IXX+1 + 147 CONTINUE + IF(IPLANZ.GT.1) THEN + IAUX=IPLAN(1)+IFCC1 + DO 149 I=2,IPLANZ-1 + DO 148 J=IFCC1,IPLAN(1) + KCORN(IXX+1)=IAUX + IAUX=IAUX+1 + IXX=IXX+1 + 148 CONTINUE + IAUX=IPLAN(I)+IFCC1 + 149 CONTINUE + IYY=IPLANZ*IPLAN(1) + IYY0=(IPLANZ-1)*IPLAN(1)+1 + DO 146 I=IYY0,IYY + KCORN(IXX+1)=I + IXX=IXX+1 + 146 CONTINUE + ENDIF + ELSE + DO 145 J=IFCC1,NCELA + KCORN(IXX+1)=J + IXX=IXX+1 + 145 CONTINUE + ENDIF +* +* LES CELLULES VOISINES A CHAQUE VOLUME SONT STOCKEES. +* + NCEL2=NCELA/IPLANZ + ALLOCATE(IVOIS(6*NCEL2)) + IVV=-1 + DO 165 I=1,NCEL2 + DO 160 J=1,6 + IVV=IVV+1 + IVOIS(IVV+1)=NEIGHB(I,J,9,NCEL2,POIDSH) + 160 CONTINUE + 165 CONTINUE + IF(IPRT .GE. 100) THEN + IF(NDIM .EQ. 3) THEN + WRITE(IOUT,6300) NAMSBR,NCELA + WRITE(IOUT,6301) (MESH(II+1),MESH(II+NCELA), + > MESH(II+2*NCELA),II=1,NCELA) + ELSE + WRITE(IOUT,6200) NAMSBR,NCELA + WRITE(IOUT,6201) (MESH(II),MESH(II+NCELA),II=1,NCELA) + ENDIF + ENDIF +*---- +* SAVE EXCELL TRACKING FOR HEXAGONAL GEOMETRY +*---- + CALL LCMSIX(IPTRK,'EXCELL ',1) + IPARAM(:NSTATE)=0 + IAUX=NV+NS+1 + IAUXS=NS-NSMIN-NSMAX + IAUXX=2*NCELAP + IPARAM(1)=NDIM + IPARAM(2)=NS + IPARAM(3)=NV + IPARAM(4)=NCELA + IPARAM(5)=MMESH + IPARAM(6)=IAUX + IPARAM(7)=MAXCYL + IPARAM(8)=MAXSEC + IPARAM(9)=IPLANZ + IPARAM(10)=IDIM1 + IPARAM(11)=IDIM2 + IPARAM(12)=IAUXS + IPARAM(13)=IAUXX + CALL LCMPUT(IPTRK,'ICEL ',IDIM1 ,1,ICEL ) + CALL LCMPUT(IPTRK,'IPLAN ',IDIM2 ,1,IPLAN) + IF(NDIM.EQ.3) + >CALL LCMPUT(IPTRK,'IFACB ',IAUXX ,1,IFACB) + CALL LCMPUT(IPTRK,'IFFV ',NCELA ,1,IFFV ) + IF(IAUXS.GT.0) + >CALL LCMPUT(IPTRK,'ISURB ',IAUXS ,1,ISURB) + CALL LCMPUT(IPTRK,'REMESH ',MMESH ,2,MESH ) + CALL LCMPUT(IPTRK,'KEYMRG ',IAUX ,1,KEYMRG ) + CALL LCMPUT(IPTRK,'MATALB ',IAUX ,1,MATALB ) + CALL LCMPUT(IPTRK,'VOLSUR ',IAUX ,2,VOLSUR ) + CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,IPARAM ) + CALL LCMSIX(IPTRK,'EXCELL ',2) + DO 150 IANG=1,NANGLE + KANG=IANG + COS1=A1(IANG) + COS2=A2(IANG) + COS3=0.0 + IF(NDIM.EQ.3) COS3=A3(IANG) + PPASY=PASY + PPASZ=PASZ + POIDS=WW(IANG) + IF(IPRT .GE. 500) WRITE(IOUT,6400) IANG + CALL TRKHEX(IPRT,NCELA,ICEL,MESH,MMESH,PPASY, + + DSIDE,COS1,COS2,COS3,POP,IPLAN, + + IPLANZ,IPLAN(IPLANZ+1),NDIM, + + ICEL(NCELA+1),IMAT,IFILE,KANG,POIDS, + + IMAT(MACP+1),ICEL(2*NCELA+1),T0, + + T1,IV0,IV0(MTT+1),PPASZ,RAYON,DZMIN, + + DZMAX,IFACB,IFFV,SECTOR,NSMIN+1,ISURB,RAUX, + + NSURF,KCORN,ICORN,IVOIS,NCEL2,NS) + ZMIN=REAL(DZMIN) + 150 CONTINUE + DEALLOCATE(IVOIS,KCORN,IMAT,ISURB,RAUX,POP,T0,T1,IV0,WW,A1,A2, + + IFFV) + IF(NDIM.EQ.3) DEALLOCATE(IFACB,A3) + ENDIF + DEALLOCATE(MESH,ICEL,IPLAN) +*---- +* SET BC MATRIX +*---- + ALLOCATE(MATRT(NSOUT)) + DO 200 ISS=1,NSOUT + MATRT(ISS)=ISS + 200 CONTINUE + CALL LCMPUT(IPTRK,'BC-REFL+TRAN',NSOUT,1,MATRT) + DEALLOCATE(MATRT) +*---- +* SET NCOR=1 +*---- + REWIND IFILE + CALL XELCOR(IFILE,IFTEMP) + IER=KDRCLS(IFILE,2) + IF(IER.LT.0) GO TO 999 + DEALLOCATE(KEYMRG,MATALB,VOLSUR) + RETURN +* + 998 WRITE(IOUT,'(31H ECHO = UNABLE TO OPEN FILE FT,I4)') IFILE + CALL XABORT('XHXTRK: OPEN FAILED') + 999 WRITE(IOUT,'(31H ECHO = UNABLE TO CLOSE FILE FT,I4)') IFILE + CALL XABORT('XHXTRK: CLOSE FAILED') + 6000 FORMAT(' >>> GLOBAL GEOMETRY NAME TREATED: ',A12/ + > ' >>> EXACT EXCELL *CP* TREATMENT <<'/) + 6200 FORMAT(' ---> OUTPUT FROM ',A6,': NUMBER OF CELLS = ',I10/ + > 9X,'X-MESH',9X,'Y-MESH') + 6201 FORMAT(1P,2E15.6) + 6300 FORMAT(' ---> OUTPUT FROM ',A6,': NUMBER OF CELLS = ',I10/ + > 9X,'X-MESH',9X,'Y-MESH',9X,'Z-MESH') + 6301 FORMAT(1P,3E15.6) + 6400 FORMAT(' INTEGRATION DIRECTION = ',I10) + END diff --git a/Dragon/src/XL3NTR.f b/Dragon/src/XL3NTR.f new file mode 100644 index 0000000..2e6b5c3 --- /dev/null +++ b/Dragon/src/XL3NTR.f @@ -0,0 +1,216 @@ +*DECK XL3NTR + SUBROUTINE XL3NTR( IPRT, NDIM, ISPEC, NS, NV, NORE, + > VOLIN, MRGIN, MATIN, + > NANGL, VOLTRK, DENSTY ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute renormalized tracks to obtain true volume values. The file +* IFOLD contains the old tracks while the file IFTRAK will +* contain the normalized tracks. +* +*Copyright: +* Copyright (C) 1991 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPRT intermediate printing level for prinout. +* NDIM number of dimensions (2d or 3d). +* ISPEC kind of tracking (0 isotropic; 1 specular) . +* NS number of surfaces before merging. +* NV number of zones before merging. +* NORE track normalization (-1 yes; 1 no) +* VOLIN volumes and surfaces before merging. +* MRGIN merging index. +* MATIN material numbers before merging. +* NANGL number of angles to renormalize tracks by angle. +* DENSTY weights by angle. +* VOLTRK volumes and surfaces as computed by tracking. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +* + INTEGER NDIM,NS,NV,NANGL,IPRT,IANG,IP,IR,ISPEC,ITGEO, + > IVS,IVSC,MNSUR,MXVOL,NANG2,IOUT,NORE, + > NSURC,NSURM,NVOLC,NVOLM,MRGIN(-NS:NV), + > MATIN(-NS:NV),NTMP,JR + REAL VOLIN(-NS:NV), + > DENSTY(NANGL), + > ERRSUR,ERRVOL,ERRVM,ERRSM,TMPERR(10) + DOUBLE PRECISION VOLTRK(-NS:NV,0:NANGL),APRSUR,APRVOL, + > TOTVOL,TOTSUR,ZERO,ONE,TWO,FOUR,HALF,QUART, + > HUND,PI,FACVOL,FACSUR + CHARACTER CORIEN(0:3,-6:-1)*4 + PARAMETER ( PI=3.14159265358979323846D0, IOUT=6, + > ZERO=0.D0, ONE=1.D0, TWO=2.D0, FOUR=4.D0, + > HUND=1.D2, HALF=0.5D0, QUART=0.25D0, ITGEO=3 ) + DATA ((CORIEN(JR,IR),IR=-6,-1),JR=0,3) + > / ' 6 ',' 5 ',' 4 ',' 3 ',' 2 ',' 1 ', + > ' Z+ ',' Z- ','****','****',' R+ ','****', + > ' Z+ ',' Z- ','****','****','****','HBC ', + > ' Z+ ',' Z- ',' Y+ ',' Y- ',' X+ ',' X- ' / +* + FACVOL= TWO + FACSUR= ONE + IF( ISPEC.EQ.0 )THEN + IF( NDIM.EQ.2 )THEN + FACSUR= QUART*PI + ELSEIF( NDIM.EQ.3 )THEN + FACSUR= ONE + ENDIF + ELSEIF( ISPEC.EQ.1 )THEN + IF( NDIM.EQ.2 )THEN + FACSUR= HALF*PI + ELSEIF( NDIM.EQ.3 )THEN + FACSUR= ONE + ENDIF + ENDIF + DO 47 IVS= -NS, NV + DO 46 IANG= 1, NANGL + VOLTRK(IVS,0)= VOLTRK(IVS,0) + VOLTRK(IVS,IANG) + VOLTRK(IVS,IANG)= VOLTRK(IVS,IANG)*DENSTY(IANG) + IF( VOLTRK(IVS,IANG).NE.ZERO )THEN +* +* CONVERT INTO NORMALIZATION FACTORS + VOLTRK(IVS,IANG)= VOLIN(IVS)/VOLTRK(IVS,IANG) + ELSE + VOLTRK(IVS,IANG)= ONE + ENDIF + 46 CONTINUE + 47 CONTINUE +* +* COMPUTE ERRORS FOR CONSERVATION LAWS + TOTSUR=ZERO + APRSUR=ZERO + TOTVOL=ZERO + APRVOL=ZERO + ERRSM=0.0 + ERRVM=0.0 + IVSC=0 + DO 50 IVS= -NS, NV + IF( VOLTRK(IVS,0).EQ.ZERO.AND.VOLIN(IVS).GT.0.0)THEN + IVSC= IVS + ENDIF + IF( IVS.LT.0 )THEN + VOLTRK(IVS,0)= REAL(FACSUR)*VOLTRK(IVS,0) + IF(VOLIN(IVS).NE.0.0) THEN + ERRSM=MAX(ERRSM, + > REAL(100.0*ABS(1.0-VOLTRK(IVS,0)/VOLIN(IVS)))) + ENDIF + TOTSUR=TOTSUR+VOLIN(IVS) + APRSUR=APRSUR+VOLTRK(IVS,0) + ELSEIF( IVS.GT.0 )THEN + VOLTRK(IVS,0)= FACVOL*VOLTRK(IVS,0) + TOTVOL=TOTVOL+VOLIN(IVS) + APRVOL=APRVOL+VOLTRK(IVS,0) + IF(VOLIN(IVS).NE.0.0) THEN + ERRVM=MAX(ERRVM, + > REAL(100.0*ABS(1.0-VOLTRK(IVS,0)/VOLIN(IVS)))) + ENDIF + ENDIF + 50 CONTINUE + ERRSUR=100.*REAL(1.0-APRSUR/TOTSUR) + ERRVOL=100.*REAL(1.0-APRVOL/TOTVOL) + IF( IPRT.GT.1 )THEN + MNSUR = -NS + MXVOL = NV + NSURC = -1 + WRITE(IOUT,'(1H )') + WRITE(IOUT,7000) ERRSUR,ERRSM + DO 80 IP = 1, (9 - MNSUR) / 10 + NSURM= MAX( MNSUR, NSURC-9 ) + WRITE(IOUT,'(10X,10(A5,I6))')(' FACE',-IR,IR=NSURC,NSURM,-1) + WRITE(IOUT,'(8H SURFACE,2X,1P,10E11.4)') + > (4.*VOLIN(IR),IR=NSURC,NSURM,-1) + WRITE(IOUT,'(8H SIDE ,2X,10(A4,7X))') + > (CORIEN(ITGEO,MATIN(IR)),IR=NSURC,NSURM,-1) + WRITE(IOUT,'(8H APPROX ,2X,1P,10E11.4)') + > (FOUR*VOLTRK(IR,0),IR=NSURC,NSURM,-1) + NTMP=0 + DO 81 IR=NSURC,NSURM,-1 + NTMP=NTMP+1 + IF(VOLIN(IR).NE.0.0) THEN + TMPERR(NTMP)=REAL(HUND-HUND*VOLTRK(IR,0)/VOLIN(IR)) + ELSE + TMPERR(NTMP)=0.0 + ENDIF + 81 CONTINUE + WRITE(IOUT,'(8H ERR(%) ,2X,10F11.5)') + > (TMPERR(IR),IR=1,NTMP) + WRITE(IOUT,'(9H MERGE TO,1X,10(A5,I6))') + > (' FACE',-MRGIN(IR),IR=NSURC,NSURM,-1) + WRITE(IOUT,'(1H )') + NSURC = NSURC - 10 + 80 CONTINUE + NVOLC= 1 + WRITE(IOUT,'(1H )') + WRITE(IOUT,7001) ERRVOL,ERRVM + DO 90 IP = 1, (9 + MXVOL) / 10 + NVOLM= MIN( MXVOL, NVOLC+9 ) + WRITE(IOUT,'(10X,10(A5,I6))') (' ZONE',IR,IR=NVOLC,NVOLM) + WRITE(IOUT,'(8H VOLUME ,2X,1P,10E11.4)') + > (VOLIN(IR),IR=NVOLC,NVOLM) + WRITE(IOUT,'(9H MIXTURE ,1X,10(A5,I6))') + > (' MIX ', MATIN(IR),IR=NVOLC,NVOLM) + WRITE(IOUT,'(8H APPROX ,2X,1P,10E11.4)') + > (VOLTRK(IR,0),IR=NVOLC,NVOLM) + NTMP=0 + DO 91 IR= NVOLC,NVOLM + NTMP=NTMP+1 + IF(VOLIN(IR).NE.0.0) THEN + TMPERR(NTMP)=REAL(HUND-HUND*VOLTRK(IR,0)/VOLIN(IR)) + ELSE + TMPERR(NTMP)=0.0 + ENDIF + 91 CONTINUE + WRITE(IOUT,'(8H ERR(%) ,2X,10F11.5)') + > (TMPERR(IR),IR=1,NTMP) + WRITE(IOUT,'(9H MERGE TO,1X,10(A5,I6))') + > (' ZONE',MRGIN(IR),IR=NVOLC,NVOLM) + WRITE(IOUT,'(1H )') + NVOLC = NVOLC + 10 + 90 CONTINUE + IF( IPRT.GT.5 )THEN + NVOLC= 1 + NANG2= NANGL+2 + WRITE(IOUT,'(1H )') + IF( NORE.EQ.-1 )THEN + WRITE(IOUT,7002) + ELSE IF( NORE.EQ.1 )THEN + WRITE(IOUT,7003) + ELSE + CALL XABORT('XL3NTR: INVALID NORMALIZATION OPTION.') + ENDIF + DO 110 IP = 1, (9 + MXVOL) / 10 + NVOLM= MIN( MXVOL, NVOLC+9 ) + WRITE(IOUT,'(10X,10(A5,I6))') (' VOL ',IR,IR=NVOLC,NVOLM) + DO 100 IANG= 1, NANGL + WRITE(IOUT,'(4H ANG,I4 ,2X,1P,10E11.4)') + > IANG, (VOLTRK(IR,IANG),IR=NVOLC,NVOLM) + 100 CONTINUE + WRITE(IOUT,'(1H )') + NVOLC = NVOLC + 10 + 110 CONTINUE + ENDIF + ENDIF + IF( IVSC.NE.0 )THEN + WRITE(IOUT,*) ' VOLUME # ',IVSC,' NOT TRACKED' + WRITE(IOUT,*) ' USE FINER TRACKING' + CALL XABORT( 'XL3NTR: CHECK NUMBERING OR USE FINER TRACKING') + ENDIF +* + RETURN + 7000 FORMAT(/' TRACKING ERRORS ON SURFACE AVERAGE ERROR: ',F10.4, + > ' % ',5X,'MAXIMUM ERROR: ',F10.4,' % (BEFORE MERGE)') + 7001 FORMAT( ' TRACKING ERRORS ON VOLUME AVERAGE ERROR: ',F10.4, + > ' % ',5X,'MAXIMUM ERROR: ',F10.4,' % (BEFORE MERGE)') + 7002 FORMAT(/' ANGLE-BY-ANGLE RENORMALIZATION FACTORS: '/) + 7003 FORMAT(/' ANGLE-BY-ANGLE RENORMALIZATION FACTORS(**NOT USED): '/) + END diff --git a/Dragon/src/XL3SIG.f b/Dragon/src/XL3SIG.f new file mode 100644 index 0000000..5a1a098 --- /dev/null +++ b/Dragon/src/XL3SIG.f @@ -0,0 +1,82 @@ +*DECK XL3SIG + SUBROUTINE XL3SIG( NGRT, NBMIX, XSSIGT,ALBEDO, NPSYS, + > NGRP, NS, NR, MATALB, VOL, + > SIGTAL, SIGVOL, SWVOID, SWNZBC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Unfold cross-section data which becomes available by subset of groups. +* +*Copyright: +* Copyright (C) 1996 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* NGRT total number of groups. +* NBMIX number of mixtures in the MACROLIB. +* XSSIGT total XS for mixtures in the MACROLIB. +* ALBEDO geometric albedos. +* NPSYS group masks. +* NGRP number of groups. +* NS number of surfaces in the assembly. +* NR number of zones in the assembly. +* MATALB material numbers for zones in the supercell. +* VOL volumes. +* +*Parameters: output +* SIGTAL total XS and albedos by region & surface. +* SIGVOL volume times total XS by region. +* SWVOID logical switch (.TRUE. if void regions). +* SWNZBC logical switch (.TRUE. if non-zero BC). +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +* + INTEGER NGRT,NBMIX,NGRP,NS,NR,NPSYS(NGRP) + REAL XSSIGT(0:NBMIX,NGRT),VOL(NR),SIGTAL(NS:NR,NGRP), + > SIGVOL(NR,NGRP),ALBEDO(6) + INTEGER MATALB(NS:NR) + INTEGER IUN,JG,I + LOGICAL SWVOID,SWNZBC + REAL ZERO + INTEGER IOUT + PARAMETER (ZERO=0.0,IOUT=6) +* + SWVOID= .FALSE. + SWNZBC= .FALSE. +* + IF( NS.GT.0 ) CALL XABORT('XL3SIG: # OF SURFACES IS > 0') + IF( NR.LT.0 ) CALL XABORT('XL3SIG: # OF REGIONS IS < 0') +* + DO 10 IUN= NS, NR + DO 20 JG= 1, NGRP + IF(NPSYS(JG).EQ.0) GO TO 20 + IF( IUN.LT.0 )THEN + SIGTAL(IUN,JG)= ALBEDO(-MATALB(IUN)) + SWNZBC=SWNZBC.OR.(ALBEDO(-MATALB(IUN)).NE.ZERO) + ELSEIF( IUN.EQ.0 )THEN + SIGTAL(IUN,JG)= ZERO + ELSE + IF( MATALB(IUN).LT.0.OR.MATALB(IUN).GT.NBMIX)THEN + WRITE(IOUT,*) 'NBMIX=',NBMIX + WRITE(IOUT,*) 'IG/NGRT=',JG,NGRT + WRITE(IOUT,*) 'XSSIGT=',(XSSIGT(I,JG),I=0,NBMIX) + WRITE(IOUT,*) 'MATALB<=0 =',(MATALB(I),I=NS,0) + WRITE(IOUT,*) 'MATALB >0 =',(MATALB(I),I=1,NR) + CALL XABORT('XL3SIG: INVALID NUMBER OF MIXTURES') + ENDIF + SIGTAL(IUN,JG)= XSSIGT(MATALB(IUN),JG) + SIGVOL(IUN,JG)= SIGTAL(IUN,JG)*VOL(IUN) + ENDIF + 20 CONTINUE + 10 CONTINUE +* + RETURN + END diff --git a/Dragon/src/XL3TI3.f b/Dragon/src/XL3TI3.f new file mode 100644 index 0000000..534b13c --- /dev/null +++ b/Dragon/src/XL3TI3.f @@ -0,0 +1,464 @@ +*DECK XL3TI3 + SUBROUTINE XL3TI3( IPRT,NANGLE,DENUSR,ISYMM,ANGLES,DENSTY, + > NTOTCL,NEXTGE,MAXR,REMESH,LINMAX,RCUTOF, + > NSUR,NVOL,INDEL,MINDIM, + > MAXDIM,ICOORD,INCR,ICUR,TRKBEG,CONV,TRKDIR, + > LENGHT,NUMERO,NPIJ,NGRP,SIGTAL,SWVOID,NORE, + > NRMV,VOLTRK,KEYMRG,NSOUT,NREG,NPSYS,DBLPIJ ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Construct the sequential tape that will contain tracks for +* isotropic BC 3-D calculations. +* +*Copyright: +* Copyright (C) 1996 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IPRT intermediate printing level for output. +* NANGLE number of angles used in the tracking process. +* DENUSR density of tracks in the plane perpendicular +* to the tracking angles. +* ISYMM flag for symetry (1/0 for on/off): +* = 2 reflection plane normal to X axis; +* = 4 reflection plane normal to Y axis; +* = 8 reflection plane normal to X and Y axis; +* =16 reflection plane normal to Z axis; +* =18 reflection plane normal to X and Z axis; +* =20 reflection plane normal to Y and Z axis; +* =24 reflection plane normal to X, Y and Z axis. +* ANGLES 3D angle values. +* DENSTY density of tracks angle by angle. +* NTOTCL number of cylindres of a type + 3. +* NEXTGE for tubez, nextge=1 +* MAXR max number of real mesh values in REMESH. +* REMESH real mesh values (rect/cyl). +* LINMAX max. number of track segments in a single track. +* RCUTOF cutof for corner tracking(0.25 suggested). +* NSUR number of surfaces. +* NVOL number of zones. +* INDEL numbering of surfaces and zones. +* MINDIM min index values for all axes (rect/cyl). +* MAXDIM max index values for all axes (rect/cyl). +* ICOORD principal axes direction (X/Y/Z) for meshes. +* ICUR current zonal location for a track segment. +* INCR increment direction for next track segment. +* TRKBEG position where a track begins. +* CONV s egments of tracks. +* TRKDIR direction of a track in all axes. +* LENGHT relative lenght of each segment in a track. +* NUMERO material identification of each track segment. +* NPIJ number of probabilities in one group +* NORE track normalization (-1 yes; 1 no). +* NRMV volume factors only (0 no; 1 yes). +* NGRP number of groups. +* SIGTAL total XS. +* SWVOID flag for void regions. +* KEYMRG merge keys. +* NSOUT number of outer surfaces. +* NREG number of regions. +* NPSYS undefined. +* DBLPIJ collision probabilities. +* +*Parameters: output +* VOLTRK volume factors. +* +*Reference: +* R.Roy, A. Hebert and G. Marleau +* A transport method for treating 3-d lattices of heterogeneous cells, +* Nuclear Science and Engineering, 101, 217 (1989). +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +* + INTEGER IPRT,NANGLE,NTOTCL,NEXTGE,MAXR,LINMAX, + > NSUR,NVOL,NPIJ,NGRP,NORE,NRMV,NSOUT,NREG + REAL DENUSR +* + REAL TRKBEG(NTOTCL), TRKDIR(NTOTCL), CONV(NTOTCL), + > REMESH(MAXR), DENSTY(*), RCUTOF, TRKEND(3), + > TRKORI(3), TRKOR2(3), PROJC2(3), ANGEQN(3,3), + > ANGLE2(3), ANGLE3(3), BARY(3), TRKCUT(3,2), + > TCUTOF(3,4), TORIC(3), ANGLES(3,*), + > SIGTAL(NSOUT:NREG,NGRP) + DOUBLE PRECISION LENGHT(LINMAX) + DOUBLE PRECISION VOLTRK(NSUR:NVOL,0:*),DBLPIJ(NPIJ,NGRP) + INTEGER MINDIM(NTOTCL), MAXDIM(NTOTCL), ICUR(NTOTCL), + > ICOORD(NTOTCL), INCR(NTOTCL), NUMERO(LINMAX), + > INDEL(4,*), NSBEG(4), NSEND(4), NSCUT(2), + > KEYMRG(NSUR:NVOL), NCSEG, NOLDS, NNEWS, NPSYS(NGRP) + INTEGER ISYMM + INTEGER IQUART(4) + LOGICAL LANGLE, SWVOID + EQUIVALENCE ( ANGEQN(1,2), ANGLE2 ), ( ANGEQN(1,3), ANGLE3 ) + CHARACTER TEDATA*13 + INTEGER NPAN, IOUT + DOUBLE PRECISION DZERO + PARAMETER ( NPAN=3, IOUT=6, DZERO=0.0D0 ) +* + INTEGER NDIM, NSOUTM, I, J, NPOINT, NPO2, NCUTOF, LINM2, + > NOTRAK, NSOLAN, IVS, IANG, IGRP, ISB, + > NANGLS, IPAN, NESTIM, JANG, IX, IY, IREF1, I2, I3, + > NSOLMX, NTTRK, IANG0, NDEBS, N, IZZ, IANGL, K, K3, + > NCROS, LINE, JC, IL + REAL ANORM2, A, B, DENLIN, RCIRC, R2CIRC, DP, SURTOT, + > VOLTOT, WEIGHT, DEPART, X, Y, ANN, ODDNXT, TOTLEN, + > TOTXXX, DDENST + DOUBLE PRECISION FCUTOF +* +* + ANORM2( A, B ) = A*A + B*B + NDIM= 3 + NSOUTM= -NSOUT + NSOLMX= 0 +* +* ONE WEIGHT FOR ALL TRACKS +* DENLIN= # OF TRACKS / CM + DENLIN= SQRT(DENUSR) +* +* COMPUTE THE CIRCUMSCRIBED RADIUS AND +* THE COORDINATES FOR THE TRUE CENTER OF THE CELL + R2CIRC= 0.0 + DO 10 I = 1, 3 + BARY(I)= 0.5 * (REMESH(MAXDIM(I)) + REMESH(MINDIM(I))) + IF( NEXTGE.EQ.1 )THEN + CALL XABORT('XL3TI3: TUBEZ NOT SUPPORTED') + ELSE + R2CIRC = R2CIRC + > + (REMESH(MAXDIM(I)) - REMESH(MINDIM(I)))**2 + ENDIF + 10 CONTINUE + R2CIRC= 0.25 * R2CIRC + RCIRC = SQRT(R2CIRC) +* +* NPOINT= # OF TRACKS ALONG ONE PERPENDICULAR AXIS + NPOINT= INT( 2. * RCIRC * DENLIN ) +***** BEWARE ***** BEWARE ***** BEWARE ***** BEWARE ***** BEWARE ***** +***** CHANGE THIS "NPOINT" PARAMETER HAS TREMENDOUS EFFECTS ON TRACKING +***** BEWARE ***** BEWARE ***** BEWARE ***** BEWARE ***** BEWARE ***** +* +* OTHER POSSIBLE CHOICES (EXPLORED WITHOUT SUCCESS) ARE ==> +*1-) NPOINT= INT( 2. * RCIRC * DENLIN ) + 1 +*2-) NPOINT= NINT( 2. * RCIRC * DENLIN ) +*3-) NPOINT= NINT( 2. * RCIRC * DENLIN ) + 1 +* +* KEEP "NPOINT" ODD & CORRECT DENSITY + NPO2 = NPOINT / 2 + NPOINT= 2 * NPO2 + 1 + DP = 2. * RCIRC / NPOINT + DENLIN= 1. / DP + DENUSR= DENLIN**2 + ODDNXT= (2*NPO2+3) / (2.*RCIRC) + IF( RCUTOF.EQ.0.0 )THEN + NCUTOF= 1 + ELSE + NCUTOF= 4 + ENDIF + LINM2= LINMAX-2*NCUTOF + FCUTOF= 1.0/DBLE(NCUTOF) + NOTRAK= 0 + SURTOT= 0.0 + VOLTOT= 0.0 + IQUART(1)=1 + IQUART(2)=1 + IQUART(3)=1 + IQUART(4)=1 + IF(NEXTGE .EQ. 1) THEN + IQUART(2)=0 + IQUART(3)=0 + IQUART(4)=0 + NSOLAN= (NANGLE * (NANGLE + 2)) / 2 + ELSE + IF( ISYMM .EQ. 8 .OR. ISYMM .EQ. 24 )THEN + NSOLAN= (NANGLE * (NANGLE + 2)) / 8 + IQUART(2)=0 + IQUART(3)=0 + IQUART(4)=0 + ELSE IF( ISYMM .EQ. 4 .OR. ISYMM .EQ. 20 )THEN + NSOLAN= (NANGLE * (NANGLE + 2)) / 4 + IQUART(2)=0 + IQUART(4)=0 + ELSE IF( ISYMM .EQ. 2 .OR. ISYMM .EQ. 18 )THEN + NSOLAN= (NANGLE * (NANGLE + 2)) / 4 + IQUART(3)=0 + IQUART(4)=0 + ELSE + NSOLAN= (NANGLE * (NANGLE + 2)) / 2 + ENDIF + ENDIF +* +* INITIALIZE NORMALIZED FACTORS + IF( NRMV.EQ.1 )THEN + DO 12 IVS= NSUR, NVOL + DO 11 IANG= 0, NSOLAN + VOLTRK(IVS,IANG)= DZERO + 11 CONTINUE + 12 CONTINUE + ELSE + DO 23 IGRP= 1, NGRP + DO 21 IVS= 1,NPIJ + DBLPIJ(IVS,IGRP)= DZERO + 21 CONTINUE + 23 CONTINUE + ENDIF + DDENST= 1.0/(NPAN*DENUSR) + NANGLS= (NANGLE * (NANGLE + 2)) / 2 + CALL XELEQN( 3, 0, ANGEQN ) + IANG= 0 + DO 15 JANG= 1, NANGLS + DO 16 IPAN= 1, NPAN + CALL XELEQN( 3, NANGLE, ANGEQN ) + 16 CONTINUE + IF(IQUART(MOD(JANG-1,4)+1).NE.1 ) GO TO 15 + IANG= IANG+1 + DENSTY(IANG)= REAL(2*NSOLAN) + ANGLES(1,IANG)= ANGEQN(1,1) + ANGLES(2,IANG)= ANGEQN(2,1) + ANGLES(3,IANG)= ANGEQN(3,1) + 15 CONTINUE +* +* TO REINITIATE THE EQN ANGLES + CALL XELEQN( 3, 0, ANGEQN ) + IF( NEXTGE.EQ.1 )THEN + DDENST= 12.0*DDENST + ENDIF + WEIGHT= 0.5*DDENST/REAL(NSOLAN) + IF( IPRT.GT.1 )THEN +* +* PREPARE & PRINT THE ESTIMATED NUMBER OF TRACKS + NESTIM= 0 + DEPART= - (NPO2+1) * DP + X = DEPART + DO 25 IX = 1, NPOINT + X = X + DP + Y = DEPART + DO 20 IY = 1, NPOINT + Y = Y + DP + IF( ANORM2( X, Y ) .LE. R2CIRC ) NESTIM= NESTIM + 1 + 20 CONTINUE + 25 CONTINUE + WRITE(IOUT,'(1H )') + WRITE(IOUT,'( 8H0ECHO = ,I8,20H TRACKS/AXIS/ANGLE )') + > NPOINT + WRITE(IOUT,'( 8H ECHO = ,I8,25H TRACKS/CIRCLE/ANGLE )') + > NESTIM + NESTIM= NESTIM * NPAN * NSOLAN + WRITE(IOUT,'(30H ECHO = NEXT ODD DENSITY > ,F15.7,4H/CM2)') + > ODDNXT**2 + WRITE(IOUT,'( 8H ECHO = ,28H ESTIMATED NUMBER OF TRACKS= ,I8 )') + > NESTIM +* +* PREPARE PRINTING WITH VARIABLE FORMAT + WRITE(IOUT,'(1H )') + WRITE(IOUT,'( 8H0ECHO = ,I3,27H SOLID ANGLES TO BE TRACKED )') + > NSOLAN + NSOLMX= MIN(9, NSOLAN/10) + IREF1 = 0 + WRITE(IOUT,'( 1H0,10(I1,9X))') (IREF1, IZZ=0,NSOLMX) + WRITE(IOUT,'( 1H ,10(I1,9X))') (MOD(IZZ,10), IZZ=0,NSOLMX) + WRITE(IOUT,'( 2H 0)') + TEDATA= '(1H+,TXXX,I1)' + ENDIF + IANG = 0 + IANG0 = 0 + NTTRK = 0 + DO 290 IANGL= 1, NANGLS + IANG=IANG+1 + LANGLE= .FALSE. + IF(IQUART(MOD(IANG-1,4)+1).NE.1)THEN +*---- +* Do not track this angle because of the problem symmetry +*---- + LANGLE= .FALSE. + ELSE +*---- +* Track this angle +*---- + IANG0= IANG0+1 + LANGLE=.TRUE. + ENDIF + IF(( IPRT.GT.1).AND.( MOD(IANGL,100) .EQ. 0 ))THEN + IREF1=IREF1+1 + NDEBS= NSOLMX+1 + NSOLMX=MIN(NDEBS+9, NANGLS/10) + WRITE(IOUT,'( 1H0,10(I1,9X))')(IREF1,IZZ=NDEBS,NSOLMX) + WRITE(IOUT,'( 1H ,10(I1,9X))') + > (MOD(IZZ,10),IZZ=NDEBS,NSOLMX) + WRITE(IOUT,'( 2H 0)') + ENDIF +* +* NPAN AXES DESCRIPTION (X=0.0, Y=0.0 & Z=0.0) + DO 250 IPAN= 1, NPAN + CALL XELEQN( 3, NANGLE, ANGEQN ) + IF(.NOT.LANGLE) GO TO 250 + IF( NEXTGE.EQ.1 )THEN + IF( IPAN.NE.2 ) GO TO 250 + ENDIF + DO 30 I = 1, 3 + N = ICOORD(I) + TRKDIR(N)= ANGEQN(N,1) + INCR(I)= +1 + IF( TRKDIR(N) .LT. 0.0 ) INCR(I)= -1 +* +* MODIFY ANGLES TO TAKE INTO ACCOUNT DP + ANGLE2(I)= DP * ANGLE2(I) + ANGLE3(I)= DP * ANGLE3(I) + IF( NCUTOF.NE.1 )THEN + TCUTOF(I,1)= RCUTOF*( ANGLE2(I)+ ANGLE3(I) ) + TCUTOF(I,2)= RCUTOF*( ANGLE2(I)- ANGLE3(I) ) + TCUTOF(I,3)= -TCUTOF(I,2) + TCUTOF(I,4)= -TCUTOF(I,1) + ENDIF +* +* DETERMINE THE ORIGIN OF ALL TRACKS + TRKOR2(I)= BARY(I) - (NPO2+1)*(ANGLE2(I)+ANGLE3(I)) + 30 CONTINUE + DO 45 I = 1, 3 + PROJC2(I)= 0.0 + DO 40 J = 1, 3 + IF( I.EQ.J ) GO TO 40 + PROJC2(I)= PROJC2(I) + TRKDIR(J) * TRKDIR(J) + 40 CONTINUE + 45 CONTINUE +* +* SCAN ALL TRACKS IN THE PERPENDICULAR PLANE + DO 180 I2 = 1, NPOINT + DO 50 J = 1, 3 + TRKOR2(J)= TRKOR2(J) + ANGLE2(J) + TRKORI(J)= TRKOR2(J) + 50 CONTINUE + DO 170 I3 = 1, NPOINT + ANN = 0.0 + DO 60 J = 1, 3 + TRKORI(J)= TRKORI(J) + ANGLE3(J) + ANN= ANN + (TRKORI(J)-BARY(J))**2 + 60 CONTINUE +* +* ELIMINATE TRACKS OUTSIDE CIRCUMSCRIBED CIRCLE + IF( ANN.GT.R2CIRC ) GO TO 170 +* +* WRITE(IOUT,7002) I2,I3,(TRKORI(JJ),JJ=1,3) +*7002 FORMAT(' ORIGINE MESH:',I10,5X,I10,5X,3(F11.5)) +* +* WHICH EXTERNAL SURFACES DO THIS TRACK CROSS ? + NTTRK=NTTRK+1 + CALL XELLSR( NDIM, NTOTCL, NSUR, MAXR, REMESH, + > INDEL, MINDIM, MAXDIM, ICOORD, ICUR, INCR, + > TRKORI, TRKDIR, TRKCUT, NSCUT, NCROS, + > TOTLEN) +* +* WHEN NOT SURFACES ARE CROSSED, ELIMINATE THE TRACK + IF(NCROS.LT.2) GO TO 170 + DO 70 K= 1, NDIM + TRKBEG(K)= TRKCUT(K,1) + TRKEND(K)= TRKCUT(K,2) + 70 CONTINUE + DO 75 K= 1, 4 + NSBEG(K)= NSCUT(1) + NSEND(K)= NSCUT(2) + 75 CONTINUE + IF( NCUTOF.NE.1 )THEN + DO 77 K= 1, 4 + DO 76 K3= 1, 3 + TORIC(K3)= TRKORI(K3)+TCUTOF(K3,K) + 76 CONTINUE + CALL XELLSR( NDIM, NTOTCL, NSUR, MAXR, REMESH, + > INDEL, MINDIM, MAXDIM, ICOORD, ICUR, INCR, + > TORIC, TRKDIR, TRKCUT, NSCUT, NCROS, + > TOTXXX) + IF(NSCUT(1).NE.0) NSBEG(K)= NSCUT(1) + IF(NSCUT(2).NE.0) NSEND(K)= NSCUT(2) + 77 CONTINUE + ENDIF + CALL XELLIN( NDIM, NTOTCL, MAXR, REMESH, + > NSUR, NVOL, INDEL, MINDIM, MAXDIM, + > ICOORD, ICUR, INCR, TRKBEG, TRKEND, TRKDIR, + > PROJC2, TOTLEN, CONV, LINM2, + > LENGHT(NCUTOF+1), NUMERO(NCUTOF+1), LINE) + NOTRAK= NOTRAK+1 +* + DO 78 ISB=1,NCUTOF + NUMERO(ISB)= NSBEG(ISB) + LENGHT(ISB)= FCUTOF + NUMERO(NCUTOF+LINE+ISB)= NSEND(ISB) + LENGHT(NCUTOF+LINE+ISB)= FCUTOF + 78 CONTINUE + LINE= LINE+2*NCUTOF + IF( IPRT.GT.10000)THEN + WRITE(IOUT,6001) NOTRAK, + > NCUTOF,(TRKBEG(JC),JC=1,3), + > NCUTOF,(TRKEND(JC),JC=1,3), + > (TRKDIR(JC),JC=1,3) + WRITE(IOUT,6002) (LENGHT(I),NUMERO(I),I=1,LINE) + ENDIF + IF( NRMV.EQ.1 )THEN + DO 301 I= 1, LINE + VOLTRK(NUMERO(I),IANG0)= VOLTRK(NUMERO(I),IANG0) + > + DBLE(WEIGHT) * LENGHT(I) + 301 CONTINUE + ELSE + IF( NORE.EQ.-1 )THEN + DO 302 I= 1, LINE + IF( NUMERO(I).GT.0 )THEN + LENGHT(I) = LENGHT(I) * + > SNGL(VOLTRK(NUMERO(I),IANG0)) + ENDIF + 302 CONTINUE + ENDIF + DO 303 I= 1, LINE + NUMERO(I)= KEYMRG(NUMERO(I)) + 303 CONTINUE +* +* START MODIFICATIONS 98/06 (G.M.) +* COMPRESS TRACKING FILE FOR +* SUCCESSIVE IDENTICAL REGIONS + NOLDS=NUMERO(1) + NCSEG=1 + DO 304 IL = 2, LINE + NNEWS=NUMERO(IL) + IF( NNEWS.LT.0 .OR. NNEWS.NE.NOLDS )THEN + NOLDS=NNEWS + NCSEG=NCSEG+1 + NUMERO(NCSEG)=NUMERO(IL) + LENGHT(NCSEG)=LENGHT(IL) + ELSEIF( NNEWS.EQ.NOLDS )THEN + LENGHT(NCSEG)=LENGHT(NCSEG)+LENGHT(IL) + ENDIF + 304 CONTINUE + CALL QIJI3D(NREG,NSOUTM,NPIJ,NGRP,LINMAX,NCUTOF, + > SWVOID,NCSEG,WEIGHT,NUMERO,LENGHT, + > SIGTAL,NPSYS,DBLPIJ) +* END MODIFICATIONS 98/06 (G.M.) +* + ENDIF + 170 CONTINUE + 180 CONTINUE + 250 CONTINUE + 290 CONTINUE +* + IF( IPRT.GT.1 )THEN + WRITE(IOUT,'(1H )') + WRITE(IOUT,'(27H0ECHO = TRACKING PROPERTIES )') + WRITE(IOUT,'( 8H0ECHO = ,I3,20H ANGLES AND DENSITY:, + > F9.6,4H/CM2)') + > NANGLE, DENUSR + WRITE(IOUT,'( 8H0ECHO = ,I10,3H / ,I10, + > 27H TRACKS NOT STORED ON TAPE /)') + > NOTRAK,NTTRK + ENDIF +* + RETURN +* + 6001 FORMAT(' #',I8,1P,' B',I1,'(',2(E10.2,','),E10.2,')', + > ' E',I1,'(',2(E10.2,','),E10.2,')', + > ' D(',2(E10.2,','),E10.2,')' ) + 6002 FORMAT(1P,5(1X,E15.7,1X,I6)) + END diff --git a/Dragon/src/dramod.f90 b/Dragon/src/dramod.f90 new file mode 100644 index 0000000..1341aeb --- /dev/null +++ b/Dragon/src/dramod.f90 @@ -0,0 +1,90 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Dispatch to a calculation module in DRAGON. ANSI-C interoperable. +! +!Copyright: +! Copyright (C) 2009 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): A. Hebert +! +!----------------------------------------------------------------------- +! +integer(c_int) function dramod(cmodul, nentry, hentry, ientry, jentry, & + kentry, hparam_c) bind(c) +! + use GANLIB + implicit none +!---- +! subroutine arguments +!---- + character(kind=c_char), dimension(*) :: cmodul + integer(c_int), value :: nentry + character(kind=c_char), dimension(13,*) :: hentry + integer(c_int), dimension(nentry) :: ientry, jentry + type(c_ptr), dimension(nentry) :: kentry + character(kind=c_char), dimension(73,*) :: hparam_c +!---- +! local variables +!---- + integer :: i, ier + character :: hmodul*12, hsmg*131, hparam*72 + character(len=12), allocatable :: hentry_f(:) + type FIL_file_array + type(FIL_file), pointer :: my_file + end type FIL_file_array + type(FIL_file_array), pointer :: my_file_array(:) + integer, external :: KDRDRV +! + allocate(hentry_f(nentry),my_file_array(nentry)) + call STRFIL(hmodul, cmodul) + do i=1,nentry + call STRFIL(hentry_f(i), hentry(1,i)) + if((ientry(i) >= 3).and.(ientry(i) <= 5)) then +! open a Fortran file. + call STRFIL(hparam, hparam_c(1,i)) + my_file_array(i)%my_file=>FILOPN(hparam,jentry(i),ientry(i)-1,0) + if(.not.associated(my_file_array(i)%my_file)) then + write(hsmg,'(29hdramod: unable to open file '',a12,2h''.)') hentry_f(i) + call XABORT(hsmg) + endif + kentry(i)=c_loc(my_file_array(i)%my_file) + endif + enddo +! ---------------------------------------------------------- + dramod=KDRDRV(hmodul,nentry,hentry_f,ientry,jentry,kentry) +! ---------------------------------------------------------- + do i=1,nentry + if(jentry(i) == -2) then +! destroy a LCM object or a Fortran file. + if(ientry(i) <= 2) then + call LCMCL(kentry(i),2) + kentry(i)=c_null_ptr + else if((ientry(i) >= 3).and.(ientry(i) <= 5)) then + ier=FILCLS(my_file_array(i)%my_file,2) + if(ier < 0) then + write(hsmg,'(32hdramod: unable to destroy file '',a12,2h''.)') hentry_f(i) + call XABORT(hsmg) + endif + kentry(i)=c_null_ptr + endif + else +! close a Fortran file. + if((ientry(i) >= 3).and.(ientry(i) <= 5)) then + ier=FILCLS(my_file_array(i)%my_file,1) + if(ier < 0) then + write(hsmg,'(30hdramod: unable to close file '',a12,2h''.)') hentry_f(i) + call XABORT(hsmg) + endif + endif + endif + enddo + deallocate(my_file_array,hentry_f) + flush(6) + return +end function dramod diff --git a/Dragon/src/g2s_boundCond.f90 b/Dragon/src/g2s_boundCond.f90 new file mode 100644 index 0000000..a7223c7 --- /dev/null +++ b/Dragon/src/g2s_boundCond.f90 @@ -0,0 +1,1738 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Process data relative to boundary conditions. +! +!Copyright: +! Copyright (C) 2001 Ecole Polytechnique de Montreal. +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): +! G. Civario (CS-SI) +! +!Comments: +! Deux structures differentes ont ete definies en variables globales: +! - bCData : pour stocker les donnees en entree du code +! - SALbCData : pour stocker les donnees correspondantes a fournir dans +! le jeux de donnees SAL genere +! Le fonction definies sont +! - appliBoundariConditions : calcule les valeurs des champs des structures +! en appelant les fonctions specifiques a chaque +! type de geometrie +! \\\\ +! - initializebCData : mise a zero des stuctures +! - destroybCData : liberation de la memoire +! - appliBoundariConditionsForXXX : fonction specifique au type XXX avec +! XXX = Rec, Hex, Tri ou Tub +! - setBoundSide : applique une condition limite de contact aux elements +! - setBoundCut : applique une condition limite avec reduction du domaine +! aux elements +! - prepareSALBCData : prepare les donnees de conditions limites pour SAL +! +!----------------------------------------------------------------------- +! +module boundCond + use cellulePlaced + use constType + use constUtiles + use GANLIB + use segArc + + implicit none + + type t_bCData + double precision,dimension(2) :: sidexy !longueur en xy de la gigogne + !ext (pour rec et tri ST60 ou COMPLETE), ou cote d'un hexagone et cote + !de l'assemblage (pour hexa et tri S30 et SA60) + double precision,dimension(4) :: minmaxXY + integer,dimension(6) :: bc + double precision,dimension(6) :: albedo + integer,dimension(6) :: albInd + double precision,dimension(2) :: toOrig_xy !vecteur de translation du + !centre vers le coins inferieur gauche + integer :: iHex !type de geo si hexagone + integer :: iTri !type de geo si triangle + end type t_bCData + + type(t_bCData),save :: bCData + + type t_SALbCData + integer :: sunsetType + integer :: SALtype + integer :: nber + integer,dimension(:),allocatable :: elemNb + real :: albedo + real :: tx,ty + real :: cx,cy,angle + end type t_SALbCData + + type(t_SALbCData),dimension(6),save :: SALbCDataTab + +contains + + subroutine initializebCData() + SALbCDataTab(:6)%nber = 0 + end subroutine initializebCData + + subroutine destroybCData() + integer :: i + do i = 1,6 + if (allocated(SALbCDataTab(i)%elemNb)) then + deallocate(SALbCDataTab(i)%elemNb) + end if + end do + end subroutine destroybCData + + subroutine appliBoundariConditions(ip,szSA,nbCLP) + type(c_ptr),intent(in):: ip + integer,intent(inout) :: szSA + integer,intent(out) :: nbCLP + + select case(geomTyp) + case(RecTyp) + ! write(*,*) 'entering appliBoundariConditionsForRec' + call appliBoundariConditionsForRec(ip,szSA,nbCLP) + case(HexTyp) + ! write(*,*) 'entering appliBoundariConditionsForHex' + call appliBoundariConditionsForHex(ip,szSA,nbCLP) + case(TriaTyp) + ! write(*,*) 'entering appliBoundariConditionsForTri' + call appliBoundariConditionsForTri(ip,szSA,nbCLP) + case(TubeTyp) + ! write(*,*) 'entering appliBoundariConditionsForTub' + call appliBoundariConditionsForTub(ip,nbCLP) + end select + end subroutine appliBoundariConditions + + subroutine appliBoundariConditionsForRec(geoIp,szSA,nbCLP) + type(c_ptr),intent(in) :: geoIp + integer,intent(inout) :: szSA + integer,intent(out) :: nbCLP + + double precision :: rminx,rminy,rmaxx,rmaxy + double precision,dimension(4) :: x,y,xx,yy,cx,cy,cxx,cyy + type(c_ptr) :: ip + integer :: i,nbCut + real,dimension(2) :: tmpTab2 + real,dimension(4) :: tmpTab4 + real,dimension(6) :: tmpTab6 + type(t_segArc) :: sg + + ! programmation defensive + integer :: dimTabSegArc + + dimTabSegArc = size(tabSegArc) + + ip = geoIp + !recuperations des donnees sur les conditions aux limites + call LCMGET(ip,'NCODE ',bCData%bc) + call LCMGET(ip,'ZCODE ',tmpTab6) ; bCData%albedo=tmpTab6 + call LCMGET(ip,'ICODE ',bCData%albInd) + ! write(*,*) 'NCODE :',bCData%bc + ! write(*,*) 'ZCODE :',bCData%albedo + ! write(*,*) 'ICODE :',bCData%albInd + call LCMSIX(ip,'NEW-DATA ',1) + call LCMSIX(ip,'BOUND-DATA ',1) + call LCMGET(ip,'SIDEXY ',tmpTab2) ; bCData%sidexy=tmpTab2 + call LCMGET(ip,'MINMAXXY ',tmpTab4) ; bCData%minmaxXY=tmpTab4 + call LCMSIX(ip,'BOUND-DATA ',2) + call LCMSIX(ip,'NEW-DATA ',2) + + !exploitation des donnees + rmaxx = 0.5d0*bCData%sidexy(1) ; rminx = -rmaxx + rmaxy = 0.5d0*bCData%sidexy(2) ; rminy = -rmaxy + x(1) = rminx ; y(1) = rmaxy ; xx(1) = rminx ; yy(1) = rminy + x(2) = rmaxx ; y(2) = rminy ; xx(2) = rmaxx ; yy(2) = rmaxy + x(3) = rminx ; y(3) = rminy ; xx(3) = rmaxx ; yy(3) = rminy + x(4) = rmaxx ; y(4) = rmaxy ; xx(4) = rminx ; yy(4) = rmaxy + cx(1) = bCData%minmaxXY(1) ; cy(1) = rmaxy + cxx(1) = bCData%minmaxXY(1) ; cyy(1) = rminy + cx(2) = bCData%minmaxXY(3) ; cy(2) = rminy + cxx(2) = bCData%minmaxXY(3) ; cyy(2) = rmaxy + cx(3) = rminx ; cy(3) = bCData%minmaxXY(2) + cxx(3) = rmaxx ; cyy(3) = bCData%minmaxXY(2) + cx(4) = rmaxx ; cy(4) = bCData%minmaxXY(4) + cxx(4) = rminx ; cyy(4) = bCData%minmaxXY(4) + + !creation des conditions aux limites (pour une geometrie carre) + !lorsqu'on coupe, on garde le cote gauche (sens trigo) + nbCLP=0 + nbCut=0 + do i = 1,4 + select case(bCData%bc(i)) + case(B_Void,B_Refl,B_Ssym,B_Albe,B_Zero,B_Tran,B_Pi_2,B_Pi) + !write(*,*) 'reflective boundary condition ',i + if (bCData%bc(i)/=B_Void) nbCLP=nbCLP+1 + call setBoundSide(x(i),y(i),xx(i),yy(i),bCData%bc(i)+100*i,szSA) + case(B_Diag) + !write(*,*) 'diagonal symmetry ',i,"seg ",szsa+1 + if (i>=3) cycle + nbCut=nbCut+1 ; nbCLP=nbCLP+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc) call XABORT("G2S: memory problem in routine & + &appliBoundaryConditionsForRec (1)") + if (i==1) then + sg=createSeg(x(4),y(4),x(3),y(3),fooMix,-(bCData%bc(i)+100*i)) + else + sg=createSeg(x(3),y(3),x(4),y(4),fooMix,-(bCData%bc(i)+100*i)) + end if + tabSegArc(szSA)=sg + case(B_Syme) + !write(*,*) 'syme ', i,"seg ",szsa+1 + nbCut=nbCut+1 ; nbCLP=nbCLP+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc) call XABORT("G2S: memory problem in routine & + &appliBoundaryConditionsForRec (1)") + sg=createSeg(cx(i),cy(i),cxx(i),cyy(i),fooMix,-(bCData%bc(i)+100*i)) + tabSegArc(szSA)=sg + end select + end do + if (nbCut/=0) call setBoundCut_V2(nbCut,szSA) + end subroutine appliBoundariConditionsForRec + + subroutine setBoundSide(x,y,xx,yy,nbCL,szSA) + double precision,intent(in) :: x,y,xx,yy + integer,intent(in) :: nbCL,szSA + + type(t_segArc) :: sa + integer :: i + + do i = 1,szSA + sa = tabSegArc(i) + if (sa%typ/=tseg) cycle + if (.not. ( estColi(xx-x,yy-y,sa%dx-sa%x,sa%dy-sa%y) .and. & + & pointsAlignes(x,y,xx,yy,sa%x,sa%y) ) ) cycle + if (sa%mixd==fooMix) then + tabSegArc(i)%mixd=-nbCL + else if (sa%mixg==fooMix) then + tabSegArc(i)%mixg=-nbCL + end if + end do + end subroutine setBoundSide + + subroutine setBoundCut_V2(nbCut,szSA) + integer, intent(in) :: nbCut + integer, intent(inout) :: szSA + + ! segments management + integer :: iSA, iSC, iStr, thisSA, thisOtherSA, szSC + type(t_SegArc) :: SA, SA1, SA2, SA3, SC, SC1, SC2, SC3 + double precision :: interangle, interAngle2, RefAngle, RefOtherAngle + double precision :: thisAngle, thisOtherAngle, angle1,angle2 + ! follow up for intersections + logical :: L_Inter, test1, test2, test3, test4 + type(t_point) :: P1, P2, P3, P4 + integer :: n1, n2 + double precision :: aox,aoy,afx,afy + ! sort + ! find minimal angle + double precision :: SCAngle, SA_x,SA_y,SA_dx,SA_dy + + ! Part 1 : Backup of cutting straights & updating + allocate(tabStrCut(nbCut), tabSegCut(szSA),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: setBoundCut_V2 => allocation pb") + tabStrCut(1:nbCut) = tabSegArc(szSA-nbCut+1:szSA) + szSA = szSA - nbCut + ! + ! Part2 : Adaptation for cutting Straights + B_A1: do iStr = 1, nbCut + SC = tabStrCut(iStr) + B_B1: do iSA = iStr+1, nbCut + SA = tabStrCut(iSA) + L_Inter = InterSgSg_V2(SC,SA,n1,n2,P1,P2) + if (L_Inter.and.n2==0) then + SA1 = copySegExceptEnd(P1%x,P1%y,SA) + if (estAGauche(SC%x,SC%y,SC%dx,SC%dy,SA1%x,SA1%y)) then + tabStrCut(iSA) = SA1 + else + SA1 = copySegExceptOrigin(P1%x,P1%y,SA) + tabStrCut(iSA) = SA1 + endif + end if + enddo B_B1 + enddo B_A1 + + ! Part 3 : process for the current straight + B_A2: do iStr = 1, nbCut + szSC = 1 + tabSegCut(szSC) = tabStrCut(iStr) + iSC = szSC + + B_B2: do + if (iSC > szSC) exit B_B2 + SC = tabSegCut(iSC) + iSA = 1 + B_C2: do + if (iSA > szSA) exit B_C2 + SA = tabSegArc(iSA) + if (SA%typ == tseg) then + ! SA is a segment + L_Inter = InterSgSg_V2(SC,SA,n1,n2,P1,P2) + if (.not.L_Inter) then + ! no intersection + if (estAGauche(SC%x,SC%y,SC%dx,SC%dy,SA%x,SA%y).or.& + estAGauche(SC%x,SC%y,SC%dx,SC%dy,SA%dx,SA%dy)) then + iSA = iSA + 1 + else + call SlideSA(iSA,szSA) + endif + cycle B_C2 + elseif (L_Inter.and.(n2==0)) then + ! only one intersection point + if (n1 == 22) then + SC1 = createSeg(SC%x,SC%y,P1%x,P1%y,SC%mixg,SC%mixd) + SC2 = createSeg(P1%x,P1%y,SC%dx,SC%dy,SC%mixg,SC%mixd) + SC = ReplaceSC(SC1,iSC) + call AddSC(SC2,szSC) + SA1 = copySegExceptEnd(P1%x,P1%y,SA) + if (.not.estAGauche(SC%x,SC%y,SC%dx,SC%dy,SA1%x,SA1%y)) & + SA1 = copySegExceptOrigin(P1%x,P1%y,SA) + SA = ReplaceSA(SA1,iSA) ; iSA = iSA + 1 + + elseif ((n1 == 21).or.(n1 == 23)) then + ! the intersection point + SA1 = copySegExceptEnd(P1%x,P1%y,SA) + if (.not.estAGauche(SC%x,SC%y,SC%dx,SC%dy,SA1%x,SA1%y))& + SA1 = copySegExceptOrigin(P1%x,P1%y,SA) + SA = ReplaceSA(SA1,iSA) ; iSA = iSA + 1 + + elseif ((n1==11).or.(n1==13).or.(n1==31).or.(n1==33)) then + if ( ((n1==11).and.& + estAGAuche(SC%x,SC%y,SC%dx,SC%dy,SA%dx,SA%dy)) .or. & + ((n1==13).and.& + estAGauche(SC%x,SC%y,SC%dx,SC%dy,SA%dx,SA%dy)) .or. & + ((n1==31).and.& + estAGauche(SC%x,SC%y,SC%dx,SC%dy,SA%x,SA%y )) .or. & + ((n1==33).and.& + estAGauche(SC%x,SC%y,SC%dx,SC%dy,SA%x, SA%y ))) then + iSA = iSA + 1 + else + call SlideSA(iSA,szSA) + endif + + elseif ((n1 == 12).or.(n1 == 32)) then + SC1 = createSeg(SC%x,SC%y,P1%x,P1%y,SC%mixg,SC%mixd) + SC2 = createSeg(P1%x,P1%y,SC%dx,SC%dy,SC%mixg,SC%mixd) + SC = ReplaceSC(SC1,iSC) + call AddSC(SC2,szSC) + if (estAGauche(SC%x,SC%y,SC%dx,SC%dy,SA%x,SA%y)) then + iSA = iSA + 1 + else + call SlideSA(iSA,szSA) + endif + else + call XABORT("SetBoundCut_V2 : inconsistency") + endif + cycle B_C2 + + else ! (L_Inter.and.n2 /= 0 ) + call OverlaidSegmentsManagement(n1,n2,iSC,szSC,SC,iSA,szSA,SA) + cycle B_C2 + endif + else + ! Sa is an arc or a circle + L_Inter = interSgAr_V2(SC,SA,n1,n2,P1,P2) + if (SA%typ == tarc) then + call giveOrigine(SA,Aox,Aoy) ; call giveExtremite(SA,Afx,Afy) + endif + if (.not.L_Inter) then + if (SA%typ /= tcer) then + if (estAGauche(SC%x,SC%y,SC%dx,SC%dy,aox,aoy).or. & + estAGauche(SC%x,SC%y,SC%dx,SC%dy,afx,afy)) then + iSA = iSA + 1 + else + call SlideSA(iSA,szSA) + endif + else + ! SA is a circle + call giveFourPointsOnCircle(SA,P1,P2,P3,P4) + test1 = estAGauche(SC%x,SC%y,SC%dx,SC%dy,P1%x,P1%y) + test2 = estAGauche(SC%x,SC%y,SC%dx,SC%dy,P2%x,P2%y) + test3 = estAGauche(SC%x,SC%y,SC%dx,SC%dy,P3%x,P3%y) + test4 = estAGauche(SC%x,SC%y,SC%dx,SC%dy,P4%x,P4%y) + if (test1.or.test2.or.test3.or.test4) then + ! circle will be cut by another SC + iSA = iSA + 1 + else + call SlideSA(iSA,szSA) + endif + endif + cycle B_C2 + elseif (n2 == 0) then + if (n1>100) then + ! one intersection point which is a tangency point + if (estAGauche(SC%x,SC%y,SC%dx,SC%dy,aox,aoy)) then + SC1 = createSeg(SC%x,SC%y,P1%x,P1%y,SC%mixg,SC%mixd) + SC2 = createSeg(P1%x,P1%y,SC%x,SC%y,SC%mixg,SC%mixd) + SC = ReplaceSC(SC1,iSC) + call AddSC(SC2,szSC) + interAngle = calculeAngle(SA%x,SA%y,P1%x,P1%y) + if (SA%typ == tarc) then + SA1 = copyArcExceptEnd(interAngle,SA) + SA2 = copyArcExceptOrigin(interAngle,SA) + SA = ReplaceSA(SA1,iSA) + call AddSA(SA2,szSA) + else + interangle2 = anglenormal(interangle+pi_c) + SA1 = createArcFromCircle(interAngle,interAngle2,SA) + SA2 = createArcFromCircle(interAngle2,interAngle,SA) + SA = ReplaceSA(SA1,iSA) + call AddSA(SA2,szSA) + end if + iSA = iSA + 1 + else + call SlideSA(iSA,szSA) + end if + elseif (n1<100) then + ! one intersection point P1 + if (mod(n1,10) == 2) then + ! P1 is inside segment + SC1 = createSeg(SC%x,SC%y,P1%x,P1%y,SC%mixg,SC%mixd) + SC2 = createSeg(P1%x,P1%y,SC%dx,SC%dy,SC%mixg,SC%mixd) + SC = ReplaceSC(SC1,iSC) + call AddSC(SC2,szSC) + interAngle = calculeAngle(SA%x,SA%y,P1%x,P1%y) + if (n1/10 == 2) then + if (SA%typ == tarc) then + SA1 = copyArcExceptEnd(interAngle,SA) + if (.not.estAGauche & + (SC%x,SC%y,SC%dx,SC%dy,aox,aoy)) & + SA1 = copyArcExceptOrigin(interAngle,SA) + SA = ReplaceSA(SA1,iSA) + else + interangle2 = anglenormal(interangle+pi_c) + SA1 = createArcFromCircle & + (interAngle,interAngle2,SA) + call MediumPointOnArc(SA1,P1) + if (.not.estAGauche & + (SC%x,SC%y,SC%dx,SC%dy,P1%x,P1%y)) & + SA1 = createArcFromCircle & + (interAngle2,interAngle,SA) + SA = ReplaceSA(SA1,iSA) + endif + endif + else + ! P1 is the begin or the end of SC + if (n1/10 == 2) then + ! P1 is inside SA + interAngle = calculeAngle(SA%x,SA%y,P1%x,P1%y) + if (SA%typ == tarc) then + SA1 = copyArcExceptEnd(interAngle,SA) + if (.not.estAGauche & + (SC%x,SC%y,SC%dx,SC%dy,aox,aoy)) & + SA1 = copyArcExceptOrigin(interAngle,SA) + else + interangle2 = anglenormal(interangle+pi_c) + SA1 = createArcFromCircle & + (interAngle,interAngle2,SA) + call MediumPointOnArc(SA1,P1) + if (.not.estAGauche & + (SC%x,SC%y,SC%dx,SC%dy,P1%x,P1%y)) & + SA1 = createArcFromCircle & + (interAngle2,interAngle,SA) + endif + SA = ReplaceSA(SA1,iSA) + SC = ReplaceSC(SC1,iSC) + iSA = iSA + 1 + else + ! P1 is at the begin or the end of SA + if (((n1/10==1).and. & + estAGauche(SC%x,SC%y,SC%dx,SC%dy,afx,afy)) & + .or. & + ((n1/10==3).and. & + estAGauche(SC%x,SC%y,SC%dx,SC%dy,aox,aoy))) then + iSA =iSA + 1 + else + call SlideSA(iSA,szSA) + endif + endif + endif + endif + else + ! two points of intersection + if ((n1==21.and.n2==23) .or.(n1==23.and.n2==21)) then + ! the intersection points are the extremities of SA + interangle = calculeAngle(SA%x,SA%y,P1%x,P1%y) + interangle2 = calculeAngle(SA%x,SA%y,P2%x,P2%y) + angle1 = min(interangle,interangle2) + angle2 = max(interangle,interangle2) + if (SA%a > SA%b) then + SA1 = CopyArcExceptEnd(angle1,SA) + SA2 = CopyArcWithNewAngles(angle1,angle2,SA) + SA3 = CopyArcExceptOrigin(angle2,SA) + else + SA1 = CopyArcExceptEnd(angle2,SA) + SA2 = CopyArcWithNewAngles(angle2,angle1,SA) + SA3 = CopyArcExceptOrigin(angle1,SA) + endif + call MediumPointOnArc(SA2,P1) + if (estAGauche(SC%x,SC%y,SC%dx,SC%dy,P1%x,P1%y)) then + SA = ReplaceSA(SA2,iSA) + else + SA = ReplaceSA(SA1,iSA) + call AddSA(SA3,szSA) + end if + iSA = iSA + 1 + elseif((n1==12.and.n2==32).or.(n1==32.and.n2==12)) then + SC1 = createSeg(SC%x,SC%y,P1%x,P1%y,SC%mixg,SC%mixd) + SC2 = createSeg(P1%x,P1%y,P2%x,P2%y,SC%mixg,SC%mixd) + SC3 = createSeg(P2%x,P2%y,SC%dx,SC%dy,SC%mixg,SC%mixd) + SC = ReplaceSC(SC1,iSC) + call Add2SC(SC2,SC3,szSC) + iSA = iSA + 1 + elseif ((n1==11.and.n2==33).or. & + (n1==31.and.n2==13).or. & + (n1==13.and.n2==31)) then + ! P1 and P2 are at the begin or the end of SA and SC + ! nothing to do + iSA = iSA + 1 + else + SC1 = createSeg(SC%x,SC%y,P1%x,P1%y,SC%mixg,SC%mixd) + SC2 = createSeg(P1%x,P1%y,P2%x,P2%y,SC%mixg,SC%mixd) + SC3 = createSeg(P2%x,P2%y,SC%dx,SC%dy,SC%mixg,SC%mixd) + if (SA%typ == tarc) then + interAngle = calculeAngle(SA%x,SA%y,P1%x,P1%y) + SA1 = copyArcExceptEnd(interAngle,SA) + interAngle = calculeAngle(SA%x,SA%y,P2%x,P2%y) + SA2 = copyArcWithNewAngles(SA1%b,interAngle,SA) + SA3 = copyArcExceptOrigin(SA2%a,SA) + ! if SA1 is on left side, SA3 is on left side too + ! if SA1 isn't on left side, SA2 is on left side + call giveOrigine(SA1,aox,aoy) + if (estAGauche(SC%x,SC%y,SC%dx,SC%dy,aox,aoy)) then + SA = ReplaceSA(SA1,iSA) + call AddSA(SA3,szSA) + else + SA = ReplaceSA(SA2,iSA) + endif + else + interAngle = calculeAngle(SA%x,SA%y,P1%x,P1%y) + interAngle2 = calculeAngle(SA%x,SA%y,P2%x,P2%y) + SA1 = createArcFromCircle(interAngle2,interAngle,SA) + call MediumPointOnArc(SA1,P3) + if (.not.estAGauche(SC%x,SC%y,SC%dx,SC%dy,P3%x,P3%y)) & + SA1 = createArcFromCircle & + (interAngle,interAngle2,SA) + SA = ReplaceSA(SA1,iSA) + endif + SC = ReplaceSC(SC1,iSC) + call Add2SC(SC2,SC3,szSC) + iSA = iSA + 1 + endif + endif + cycle B_C2 + endif + enddo B_C2 + iSC = iSC + 1 + enddo B_B2 + +!!$ ! Part 3 : Sort +!!$ B_B3:do iSC = 1,szSC-1 +!!$ P1%x = tabSegCut(iSC)%dx ; P1%y = tabSegCut(iSC)%dy +!!$ B_C3:do jSC = iSC+1,szSC +!!$ if (tabSegCut(jSC)%x == P1%x .and.tabSegCut(jSC)%y == P1%y) then +!!$ if(jSC==iSC+1) then ; cycle B_B3 +!!$ else +!!$ SCBuffer = tabSegCut(iSC+1) +!!$ tabSegCut(iSC+1) = tabSegCut(jSC) +!!$ tabSegCut(jSC) = SCBuffer +!!$ endif +!!$ end if +!!$ end do B_C3 +!!$ end do B_B3 + + ! Part 4 : search for neighbourhood informations + B_B4: do iSC = 1, szSC + SC = tabSegCut(iSC) + thisSA = 0 ; thisOtherSA = 0 + RefAngle = infinity ; RefOtherAngle = infinity + SCAngle = calculeAngle(SC%x,SC%y,SC%dx,SC%dy) + ! Mix awarding + B_C4: do iSA = 1, szSA + SA = tabSegArc(iSA) + if (SA%typ == tseg) then + if (IsEqualConst(SC%x,SA%x).and.IsEqualConst(SC%y,SA%y)) then + thisAngle = calculeAngle(SA%x,SA%y,SA%dx,SA%dy) - SCAngle + if (thisAngle < RefAngle) then + thisSA = iSA ; RefAngle = thisAngle + endif + elseif (IsEqualConst(SC%x,SA%dx).and.IsEqualConst(SC%y,SA%dy)) then + thisAngle = calculeAngle(SA%x,SA%y,SA%dx,SA%dy) + SCAngle + if (thisAngle < RefAngle) then + thisSA = iSA ; RefAngle = thisAngle + endif + endif + else if (SA%typ == tarc) then + call giveOrigine(SA,SA_x,SA_y) + call giveExtremite(SA,SA_dx,SA_dy) + if (IsEqualConst(SC%x,SA_x) .and. IsEqualConst(SC%y,SA_y)) then + thisAngle = SA%a + pi_2_c - SCAngle + if (thisAngle < RefAngle) then + thisSA = iSA ; RefAngle = thisAngle + endif + elseif (IsEqualConst(SC%x,SA_dx).and.IsEqualConst(SC%y,SA_dy)) then + thisAngle = SA%b - pi_2_c + SCAngle + if (thisAngle < RefAngle) then + thisSA = iSA ; RefAngle = thisAngle + endif + endif + endif + enddo B_C4 + if (thisSA == 0) then + call XABORT('unable to find element thisSA') + endif + if (tabSegArc(thisSA)%typ == tseg) then + if (isEqualConst(tabSegArc(ThisSA)%x,SC%x).and. & + isEqualConst(tabSegArc(ThisSA)%y,SC%y)) then + SC%mixg = tabSegArc(thisSA)%mixd + SC%nodeg = tabSegArc(thisSA)%noded + SC%IndCellPg = tabSegArc(thisSA)%indCellPd + elseif(isEqualConst(tabSegArc(ThisSA)%dx,SC%x).and. & + isEqualConst(tabSegArc(ThisSA)%dy,SC%y)) then + SC%mixg = tabSegArc(thisSA)%mixg + SC%nodeg = tabSegArc(thisSA)%nodeg + SC%IndCellPg = tabSegArc(thisSA)%indCellPg + else + call XABORT("SetBoundCut_V2 : mix error (1)") + endif + else + call giveOrigine(tabSegArc(thisSA),SA_x,SA_y) + call giveExtremite(tabSegArc(thisSA),SA_dx,SA_dy) + if (isEqualConst(SA_x,SC%x).and.isEqualConst(SA_y,SC%y)) then + SC%mixg = tabSegArc(thisSA)%mixd + SC%nodeg = tabSegArc(thisSA)%noded + SC%IndCellPg = tabSegArc(thisSA)%indCellPd + elseif (isEqualConst(SA_dx,SC%x).and.isEqualConst(SA_dy,SC%y)) then + SC%mixg = tabSegArc(thisSA)%mixg + SC%nodeg = tabSegArc(thisSA)%nodeg + SC%IndCellPg = tabSegArc(thisSA)%indCellPg + else + call XABORT("SetBoundCut_V2 : mix error (2)") + endif + endif + + ! Mix control + SCAngle = calculeAngle(SC%dx,SC%dy,SC%x,SC%y) + B_C5: do iSA = 1,szSA + SA = tabSegArc(iSA) + if (SA%typ == tseg) then + if (IsEqualConst(SC%dx,SA%dx).and.IsEqualConst(SC%dy,SA%dy)) then + thisOtherAngle = calculeAngle(SA%x,SA%y,SA%dx,SA%dy) + SCAngle + if (thisOtherAngle < RefOtherAngle) then + thisOtherSA = iSA ; RefOtherAngle = thisOtherAngle + endif + elseif (IsEqualConst(SC%dx,SA%x).and.IsEqualConst(SC%dy,SA%y)) then + thisOtherAngle = calculeAngle(SA%x,SA%y,SA%dx,SA%dy) - SCAngle + if (thisOtherAngle < RefOtherAngle) then + thisOtherSA = iSA ; RefOtherAngle = thisOtherAngle + endif + endif + elseif (SA%typ == tarc) then + call giveOrigine(SA,SA_x,SA_y) + call giveExtremite(SA,SA_dx,SA_dy) + if (IsEqualConst(SC%dx,SA_dx).and.IsEqualConst(SC%dy,SA_dy)) then + thisOtherAngle = SA%B + pi_2_c - SCAngle + if (thisOtherAngle < RefOtherAngle) then + thisOtherSA = iSA ; RefOtherAngle = thisOtherAngle + endif + elseif (IsEqualConst(SC%dx,SA_x).and.IsEqualConst(SC%dy,SA_y)) then + thisOtherAngle = SA%a - pi_2_c + SCAngle + if (thisOtherAngle < RefOtherAngle) then + thisOtherSA = iSA ; RefOtherAngle = thisOtherAngle + endif + endif + endif + enddo B_C5 + if (thisOtherSA == 0) then + ! we do not find a neigbour for SC + call XABORT("SetBoundCut_V2 : incredible situation too") + endif + if (tabSegArc(thisOtherSA)%typ == tseg) then + if (IsEqualConst(SC%dx,tabSegArc(thisOtherSA)%x).and. & + IsEqualConst(SC%dy,tabSegArc(thisOtherSA)%y)) then + if (SC%mixg /= tabSegArc(thisOtherSA)%mixg) then + call XABORT("SetBoundCut_V2 : mix error (3)") + endif + elseif (IsEqualConst(SC%dx,tabSegArc(thisOtherSA)%dx).and. & + IsEqualConst(SC%dy,tabSegArc(thisOtherSA)%dy)) then + if (SC%mixg /= tabSegArc(thisOtherSA)%mixd) then + call XABORT("SetBoundCut_V2 : mix error (4)") + end if + else + call XABORT("SetBoundCut_V2 : mix error (5)") + endif + else + call giveOrigine(tabSegArc(thisOtherSA),SA_x,SA_y) + call giveExtremite(tabSegArc(thisOtherSA),SA_dx,SA_dy) + if (isEqualConst(SC%dx,SA_x).and.isEqualConst(SC%dy,SA_y)) then + if (SC%mixg /= tabSegArc(thisOtherSA)%mixg) then + call XABORT("SetBoundCut_V2 : mix error (6)") + end if + elseif(isEqualCOnst(SC%dx,SA_dx).and. & + isEqualConst(SC%dy,SA_dy)) then + if (SC%mixg /= tabSegArc(thisOtherSA)%mixd) then + call XABORT("SetBoundCut_V2 : mix error (7)") + endif + else + call XABORT("SetBoundCut_V2 : mix error (8)") + endif + endif + tabSegCut(iSC) = SC + enddo B_B4 + if (szSA+szSC > size(TabSegArc)) call XABORT("InterSgSg_V2 : memory problem (1)") + ! Transfer + tabSegArc(szSA+1:szSA+szSC) = tabSegCut(1:szSC) + szSA = szSA + szSC + szSC = 0 + enddo B_A2 + + deallocate(tabSegCut, tabStrCut) + end subroutine setBoundCut_V2 + + subroutine setBoundCut(nbCut,szSA) + integer,intent(in) :: nbCut + integer,intent(inout) :: szSA + + type(t_segArc) :: sa,sgi,sg,ar + type(segArcArrayTer),dimension(:),allocatable :: tmpTab + double precision :: intx,inty,pt1x,pt1y,pt2x,pt2y,angl + integer :: i,j,sizeTmp,nbPtInter,sztmp + logical :: oInSa,eInSa,oInSgi,eInSgi + + ! programmation defensive + integer :: taille_table_tmpTab + + !on coupe le domaine de maniere symetrique + ! et on garde les elements a gauche de l'axe de coupe + !copie dans un tableau temporaire des segments + !et nettoyage du tableau global + + sztmp = szSA*10 + ! programmation defensive + taille_table_tmpTab = sztmp + allocate(tmpTab(sztmp),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: setBoundCut(1) => allocation pb") + do i = 1,nbCut + tmpTab(i)%sa=tabSegArc(szSA-nbCut+i) + tmpTab(i)%keep=.true. ; tmpTab(i)%cl=.true. + end do + do i = 1,szSA-nbCut + tmpTab(i+nbCut)%sa=tabSegArc(i) + tmpTab(i+nbCut)%keep=.true. ; tmpTab(i+nbCut)%cl=.false. + end do + sizeTmp=szSA + + !coupage des segments + j=0 + do + j = j+1 + if (j>sizeTmp) exit + if (.not. tmpTab(j)%cl .or. .not. tmpTab(j)%keep) cycle + sa = tmpTab(j)%sa + if (isEqualConst(sa%x,sa%dx).and.isEqualConst(sa%y,sa%dy)) then + tmpTab(j)%keep=.false. + cycle + end if + i=0 + do + i = i+1 + if (i>sizeTmp) exit + if ((.not. tmpTab(i)%keep) .or. i==j) cycle + if (tmpTab(i)%sa%typ/=tseg) cycle + sgi=tmpTab(i)%sa + !cas ou les segments de coupe rencontrent d'autres segments sans les + ! couper. exemple: les coins des carres pour une symetrie diagonnale + oInSa=pointsAlignes(sgi%x,sgi%y,sa%x,sa%y,sa%dx,sa%dy).and. & + & (isIn(sgi%x,sgi%y,sa)==2) + eInSa=pointsAlignes(sgi%dx,sgi%dy,sa%x,sa%y,sa%dx,sa%dy).and. & + & (isIn(sgi%dx,sgi%dy,sa)==2) + if (oInSa.and.(.not.eInSa)) then + tmpTab(j)%keep=.false. + sizeTmp=sizeTmp+1 + ! programmation defensive + if (sizeTmp > taille_table_tmpTab) & + call XABORT("G2S : memory problem in routine SetBoundCut") + tmpTab(sizeTmp)%sa=sa ; tmpTab(sizeTmp)%cl=.true. + tmpTab(sizeTmp)%keep=.true. + if (estAGauche(sa%x,sa%y,sa%dx,sa%dy,sgi%dx,sgi%dy)) then + if (sgi%mixd/=fooMix) tmpTab(sizeTmp)%sa%mixg = sgi%mixd + else + if (sgi%mixg/=fooMix) tmpTab(sizeTmp)%sa%mixg = sgi%mixg + end if + tmpTab(sizeTmp)%sa%x = sgi%x ; tmpTab(sizeTmp)%sa%y = sgi%y + sizeTmp=sizeTmp+1 + ! programmation defensive + if (sizeTmp > taille_table_tmpTab) & + call XABORT("G2S : memory problem in routine SetBoundCut") + tmpTab(sizeTmp)%sa=sa ; tmpTab(sizeTmp)%cl=.true. + tmpTab(sizeTmp)%keep=.true. + if (estAGauche(sa%x,sa%y,sa%dx,sa%dy,sgi%dx,sgi%dy)) then + if (sgi%mixg/=fooMix) tmpTab(sizeTmp)%sa%mixg = sgi%mixg + else + if (sgi%mixd/=fooMix) tmpTab(sizeTmp)%sa%mixg = sgi%mixd + end if + tmpTab(sizeTmp)%sa%dx = sgi%x ; tmpTab(sizeTmp)%sa%dy = sgi%y + exit + else if ((.not.oInSa).and.eInSa) then + tmpTab(j)%keep=.false. + sizeTmp=sizeTmp+1 + ! programmation defensive + if (sizeTmp > taille_table_tmpTab) & + call XABORT("G2S : memory problem in routine SetBoundCut") + tmpTab(sizeTmp)%sa=sa ; tmpTab(sizeTmp)%cl=.true. + tmpTab(sizeTmp)%keep=.true. + if (estAGauche(sa%x,sa%y,sa%dx,sa%dy,sgi%x,sgi%y)) then + !write(*,*) "zaza sbc 5", i, j, sizetmp, sgi%mixG + if (sgi%mixg/=fooMix) tmpTab(sizeTmp)%sa%mixg = sgi%mixg + else + !write(*,*) "zaza sbc 6" ,i, j, sizetmp, sgi%mixd + if (sgi%mixd/=fooMix) tmpTab(sizeTmp)%sa%mixg = sgi%mixd + end if + tmpTab(sizeTmp)%sa%x = sgi%dx ; tmpTab(sizeTmp)%sa%y = sgi%dy + sizeTmp=sizeTmp+1 + ! programmation defensive + if (sizeTmp > taille_table_tmpTab) & + call XABORT("G2S : memory problem in routine SetBoundCut") + tmpTab(sizeTmp)%sa=sa ; tmpTab(sizeTmp)%cl=.true. + tmpTab(sizeTmp)%keep=.true. + if (estAGauche(sa%x,sa%y,sa%dx,sa%dy,sgi%x,sgi%y)) then + !write(*,*) "zaza sbc 7", i, j, sizetmp, sgi%mixd + if (sgi%mixd/=fooMix) tmpTab(sizeTmp)%sa%mixg = sgi%mixd + else + !write(*,*) "zaza sbc 8", i, j, sizetmp, sgi%mixG + if (sgi%mixg/=fooMix) tmpTab(sizeTmp)%sa%mixg = sgi%mixg + end if + tmpTab(sizeTmp)%sa%dx = sgi%dx ; tmpTab(sizeTmp)%sa%dy = sgi%dy + exit + end if + !cas ou les segments a couper interceptent le segment de coupe a + ! une de ses extremites. Exemple: bord du domaine pour la symetrie + ! non diagonale sur un carre + ! Remarque: pas d'exit , mais un cycle a la fin pour que le segment + ! de coupe puisse etre encore utilise + oInSgi=pointsAlignes(sa%x,sa%y,sgi%x,sgi%y,sgi%dx,sgi%dy).and. & + & (isIn(sa%x,sa%y,sgi)==2) + eInSgi=pointsAlignes(sa%dx,sa%dy,sgi%x,sgi%y,sgi%dx,sgi%dy).and. & + & (isIn(sa%dx,sa%dy,sgi)==2) + if (oInSgi.and.(.not.eInSgi)) then + tmpTab(i)%keep=.false. + sizeTmp=sizeTmp+1 + ! programmation defensive + if (sizeTmp > taille_table_tmpTab) call XABORT("G2S : memory problem in routine SetBoundCut") + tmpTab(sizeTmp)%sa=sgi ; tmpTab(sizeTmp)%cl=tmpTab(i)%cl + if (estAGauche(sa%x,sa%y,sa%dx,sa%dy,sgi%x,sgi%y)) then + tmpTab(sizeTmp)%sa%dx=sa%x ; tmpTab(sizeTmp)%sa%dy=sa%y + !write(*,*) "zaza sbc 9", i, j, sizetmp, sgi%mixg + if (sgi%mixg/=fooMix) tmpTab(j)%sa%mixg=sgi%mixg + else + tmpTab(sizeTmp)%sa%x=sa%x ; tmpTab(sizeTmp)%sa%y=sa%y + !write(*,*) "zaza sbc 10", i, j, sizetmp, sgi%mixd + if (sgi%mixd/=fooMix) tmpTab(j)%sa%mixg=sgi%mixd + end if + tmpTab(sizeTmp)%keep=.true. + cycle + else if (eInSgi.and.(.not.oInSgi)) then + tmpTab(i)%keep=.false. + sizeTmp=sizeTmp+1 + ! programmation defensive + if (sizeTmp > taille_table_tmpTab) & + call XABORT("G2S : memory problem in routine SetBoundCut") + tmpTab(sizeTmp)%sa=sgi ; tmpTab(sizeTmp)%cl=tmpTab(i)%cl + if (estAGauche(sa%x,sa%y,sa%dx,sa%dy,sgi%x,sgi%y)) then + tmpTab(sizeTmp)%sa%dx=sa%dx ; tmpTab(sizeTmp)%sa%dy=sa%dy + !write(*,*) "zaza sbc 11", i, j, sizetmp, sgi%mixd + if (sgi%mixd/=fooMix) tmpTab(j)%sa%mixg=sgi%mixd + else + tmpTab(sizeTmp)%sa%x=sa%dx ; tmpTab(sizeTmp)%sa%y=sa%dy + !write(*,*) "zaza sbc 12", i, j, sizetmp, sgi%mixg + if (sgi%mixg/=fooMix) tmpTab(j)%sa%mixg=sgi%mixg + end if + tmpTab(sizeTmp)%keep=.true. + cycle + end if + !cas ou on coupe vraiment + if ( interSgSg(sa,sgi,intx,inty)) then + tmpTab(j)%keep=.false. ; tmpTab(i)%keep=.false. + sizeTmp=sizeTmp+1 ; + tmpTab(sizeTmp)%sa=sgi ; tmpTab(sizeTmp)%cl=tmpTab(i)%cl + tmpTab(sizeTmp)%sa%x=intx ; tmpTab(sizeTmp)%sa%y=inty + sizeTmp=sizeTmp+1 + ! programmation defensive + if (sizeTmp > taille_table_tmpTab) & + call XABORT("G2S : memory problem in routine SetBoundCut") + + tmpTab(sizeTmp)%sa=sgi ; tmpTab(sizeTmp)%cl=tmpTab(i)%cl + tmpTab(sizeTmp)%sa%dx=intx ; tmpTab(sizeTmp)%sa%dy=inty + tmpTab(sizeTmp-1)%keep = estAGauche(sa%x,sa%y,sa%dx,sa%dy, & + & sgi%dx,sgi%dy) + tmpTab(sizeTmp)%keep = .not.tmpTab(sizeTmp-1)%keep + sizeTmp=sizeTmp+1 + ! programmation defensive + if (sizeTmp > taille_table_tmpTab) & + call XABORT("G2S : memory problem in routine SetBoundCut") + tmpTab(sizeTmp)%sa=sa ; tmpTab(sizeTmp)%keep=.true. + tmpTab(sizeTmp)%cl=.true. + tmpTab(sizeTmp)%sa%x=intx ; tmpTab(sizeTmp)%sa%y=inty + sizeTmp=sizeTmp+1 + ! programmation defensive + if (sizeTmp > taille_table_tmpTab) & + call XABORT("G2S : memory problem in routine SetBoundCut") + + tmpTab(sizeTmp)%sa=sa ; tmpTab(sizeTmp)%keep=.true. + tmpTab(sizeTmp)%cl=.true. + tmpTab(sizeTmp)%sa%dx=intx ; tmpTab(sizeTmp)%sa%dy=inty + if (tmpTab(sizeTmp-2)%keep) then + tmpTab(sizeTmp)%sa%mixg=sgi%mixd + tmpTab(sizeTmp-1)%sa%mixg=sgi%mixg + !write(*,*) "zaza sbc 13", i, j, sizetmp, sgi%mixd,sgi%mixg + else + tmpTab(sizeTmp)%sa%mixg=sgi%mixg + tmpTab(sizeTmp-1)%sa%mixg=sgi%mixd + !write(*,*) "zaza sbc 14" ,i, j, sizetmp, sgi%mixd,sgi%mixg + end if + exit + end if + end do + end do + do j = 1,nbCut + sa = tmpTab(j)%sa + do i = nbCut+1,sizeTmp + if (.not. tmpTab(i)%keep) cycle + sgi=tmpTab(i)%sa + if (sgi%typ/=tseg) then + !elimination des arcs et cercles du mauvais cote + ! le centre de l'arc est a droite du segment de coupe + ! => on l'elimine + tmpTab(i)%keep=.not.estADroiteStrict(sa%x,sa%y,sa%dx,sa%dy, & + & sgi%x,sgi%y) + else !elimination des segments du mauvais cote + tmpTab(i)%keep=.not.(estADroiteStrict(sa%x,sa%y,sa%dx,sa%dy, & + & sgi%x,sgi%y) .or. & + & estADroiteStrict(sa%x,sa%y,sa%dx,sa%dy,sgi%dx,sgi%dy) ) + end if + end do + end do + !coupage des arcs + j=0 + do + j = j+1 + if (j>sizeTmp) exit + if ((.not. tmpTab(j)%cl).or.(.not. tmpTab(j)%keep)) cycle + sg = tmpTab(j)%sa + if (isEqual(tmpTab(j)%sa%x,tmpTab(j)%sa%dx) .and. & + & isEqual(tmpTab(j)%sa%y,tmpTab(j)%sa%dy)) then + tmpTab(j)%keep=.false. + cycle + end if + i=0 + do + i = i+1 + if (i>sizeTmp) exit + if (.not. tmpTab(i)%keep) cycle + if (tmpTab(i)%sa%typ==tseg) cycle + ar=tmpTab(i)%sa + nbPtInter = abs(interSgAr(sg,ar,pt1x,pt1y,pt2x,pt2y)) + if (nbPtInter==2) then + !on coupe le segment en trois morceaux + tmpTab(j)%keep=.false. + sizeTmp=sizeTmp+1 + ! programmation defensive + if (sizeTmp > taille_table_tmpTab) & + call XABORT("G2S : memory problem in routine SetBoundCut") + !morceau 1 + tmpTab(sizeTmp)%sa=sg ; tmpTab(sizeTmp)%cl=.true. + tmpTab(sizeTmp)%keep=.true. + tmpTab(sizeTmp)%sa%dx=pt1x ; tmpTab(sizeTmp)%sa%dy=pt1y + tmpTab(sizeTmp)%sa%mixg=ar%mixd + sizeTmp=sizeTmp+1 + ! programmation defensive + if (sizeTmp > taille_table_tmpTab) & + call XABORT("G2S : memory problem in routine SetBoundCut") + !morceau 2 + tmpTab(sizeTmp)%sa=sg ; tmpTab(sizeTmp)%cl=.true. + tmpTab(sizeTmp)%keep=.true. + tmpTab(sizeTmp)%sa%x=pt1x ; tmpTab(sizeTmp)%sa%y=pt1y + tmpTab(sizeTmp)%sa%dx=pt2x ; tmpTab(sizeTmp)%sa%dy=pt2y + tmpTab(sizeTmp)%sa%mixg=ar%mixg + sizeTmp=sizeTmp+1 + ! programmation defensive + if (sizeTmp > taille_table_tmpTab) & + call XABORT("G2S : memory problem in routine SetBoundCut") + !morceau 3 + tmpTab(sizeTmp)%sa=sg ; tmpTab(sizeTmp)%cl=.true. + tmpTab(sizeTmp)%keep=.true. + tmpTab(sizeTmp)%sa%x=pt2x ; tmpTab(sizeTmp)%sa%y=pt2y + tmpTab(sizeTmp)%sa%mixg=ar%mixd + !on coupe l'arc en 2 morceaux et on n'en garde qu'un + tmpTab(i)%keep=.false. + if (ar%typ==tcer) then + sizeTmp=sizeTmp+1 + tmpTab(sizeTmp)%sa=ar ; tmpTab(sizeTmp)%cl=.false. + tmpTab(sizeTmp)%keep=.true. + tmpTab(sizeTmp)%sa%typ=tarc + tmpTab(sizeTmp)%sa%a=calculeAngle(ar%x,ar%y,pt2x,pt2y) + tmpTab(sizeTmp)%sa%b=calculeAngle(ar%x,ar%y,pt1x,pt1y) + else + ! il s'agit ici d'un arc centre sur le segment et le coupant 2 + ! fois, dans une geometrie symetrique... => a priori, + ! cela ne doit jamais arriver + call XABORT("G2S : Error, not symetrical geometry") + end if + exit + else if (nbPtInter==1) then + !on coupe le segment en deux morceaux + tmpTab(j)%keep=.false. + sizeTmp=sizeTmp+1 + ! programmation defensive + if (sizeTmp > taille_table_tmpTab) & + call XABORT("G2S : memory problem in routine SetBoundCut") + !morceau 1 + tmpTab(sizeTmp)%sa=sg ; tmpTab(sizeTmp)%cl=.true. + tmpTab(sizeTmp)%keep=.true. + tmpTab(sizeTmp)%sa%dx=pt1x ; tmpTab(sizeTmp)%sa%dy=pt1y + sizeTmp=sizeTmp+1 + ! programmation defensive + if (sizeTmp > taille_table_tmpTab) & + call XABORT("G2S : memory problem in routine SetBoundCut") + !morceau 2 + tmpTab(sizeTmp)%sa=sg ; tmpTab(sizeTmp)%cl=.true. + tmpTab(sizeTmp)%keep=.true. + tmpTab(sizeTmp)%sa%x=pt1x ; tmpTab(sizeTmp)%sa%y=pt1y + !determination des milieux pour les segments selon l'ordre + !relatif des points Osg, InterSgAr, Car... + !(en fait selon le sens relatif des segments OI et CI) + if (((pt1x-sg%x)*(pt1x-ar%x)+(pt1y-sg%y)*(pt1y-ar%y))>0.) then + !dans le meme sens => premier segment a l'interieur + tmpTab(sizeTmp-1)%sa%mixg=ar%mixg + tmpTab(sizeTmp)%sa%mixg=ar%mixd + else !=> premier segment a l'exterieur + tmpTab(sizeTmp-1)%sa%mixg=ar%mixd + tmpTab(sizeTmp)%sa%mixg=ar%mixg + end if + !on coupe l'arc en 1 ou 2 morceaux et on n'en garde qu'un + tmpTab(i)%keep=.false. + if (ar%typ==tcer) then + sizeTmp=sizeTmp+1 + ! programmation defensive + if (sizeTmp > taille_table_tmpTab) & + call XABORT("G2S : memory problem in routine SetBoundCut") + tmpTab(sizeTmp)%sa=ar ; tmpTab(sizeTmp)%cl=.false. + tmpTab(sizeTmp)%keep=.true. + tmpTab(sizeTmp)%sa%typ=tarc + angl=calculeAngle(ar%x,ar%y,pt1x,pt1y) + if (isPI(angl)) then + tmpTab(sizeTmp)%sa%a=-pi_c + tmpTab(sizeTmp)%sa%b=pi_c + else + tmpTab(sizeTmp)%sa%a=angl + tmpTab(sizeTmp)%sa%b=angl + end if + else + sizeTmp=sizeTmp+1 + tmpTab(sizeTmp)%sa=ar ; tmpTab(sizeTmp)%cl=.false. + tmpTab(sizeTmp)%keep=.true. + !pour savoir quelle partie on garde, on se sert du meme test + !que pour les milieux + if (((pt1x-sg%x)*(pt1x-ar%x)+(pt1y-sg%y)*(pt1y-ar%y))>0.) then + !dans le meme sens => on garde la deuxieme moitie de l'arc + tmpTab(sizeTmp)%sa%a=calculeAngle(ar%x,ar%y,pt1x,pt1y) + else !=> on garde la premiere moitie de l'arc + tmpTab(sizeTmp)%sa%b=calculeAngle(ar%x,ar%y,pt1x,pt1y) + end if + end if + exit + else !pas d'intersection mais l'arc est peut-etre a eliminer + if (ar%typ/=tarc) cycle + call extremitesArc(ar,pt1x,pt1y,pt2x,pt2y) + if ( ( estADroiteStrict(sg%x,sg%y,sg%dx,sg%dy,pt1x,pt1y) .or. & + & estADroiteStrict(sg%x,sg%y,sg%dx,sg%dy,pt2x,pt2y) ) & + & .and. .not. & + & ( estAGaucheStrict(sg%x,sg%y,sg%dx,sg%dy,pt1x,pt1y) .or. & + & estAGaucheStrict(sg%x,sg%y,sg%dx,sg%dy,pt2x,pt2y) ) ) & + & tmpTab(i)%keep=.false. + end if + end do + end do + !elimination des segments nuls eventuellement restants + do i = 1,sizeTmp + sa = tmpTab(i)%sa + if (sa%typ==tseg) tmpTab(i)%keep=tmpTab(i)%keep .and. & + & .not.(isEqual(tmpTab(i)%sa%x,tmpTab(i)%sa%dx) .and.& + & isEqual(tmpTab(i)%sa%y,tmpTab(i)%sa%dy)) + end do + !elimination des segments non de coupe se trouvant sur les segments de + ! coupe (ca arrive pour les sectorisations) + do j = 1,sizeTmp + if (.not.(tmpTab(j)%cl .and. tmpTab(j)%keep)) cycle + sa = tmpTab(j)%sa + if (sa%typ/=tseg) cycle + do i = 1,sizeTmp + if (.not. tmpTab(i)%keep .or. tmpTab(i)%cl ) cycle + sgi=tmpTab(i)%sa + if (sgi%typ/=tseg) cycle + if (.not. estColineaire(sa,sgi)) cycle + if (.not. pointsAlignes(sa%x,sa%y,sa%dx,sa%dy,sgi%x,sgi%y)) cycle + !on renverse le sens de sgi si besoin + if (.not. isSameWay(sa,sgi)) sgi=turnBackSide(tmpTab(i)%sa) + if (isEqualConst(sa%x,sgi%x).and.isEqualConst(sa%dx,sgi%dx).and. & + & isEqualConst(sa%y,sgi%y).and.isEqualConst(sa%dy,sgi%dy)) then + tmpTab(j)%sa%mixg=sgi%mixg + tmpTab(i)%keep=.false. + exit + end if + end do + end do + !recopie dans le tableau global des elements a conserver + szSA=0 + ! programmation defensive + if (sizeTmp > size(tabSegArc)) & + call XABORT("G2S : memory problem in routine SetBoundCut (2)") + do i = 1,sizeTmp + if (tmpTab(i)%keep) then + szSA=szSA+1 + tabSegArc(szSA)=tmpTab(i)%sa + end if + end do + deallocate(tmpTab) + end subroutine setBoundCut + + subroutine prepareSALBCData(szSA,nbCLP) + integer,intent(in) :: szSA,nbCLP + + integer :: i,j,k,sunsetType,tmpTabSize,indice + logical :: newBC + double precision :: basex + type(t_segArc) :: sa + integer,dimension(:),allocatable :: tmpTabElemNb + + !enregistrement des numeros des differentes conditions limites + do i = 1,nbCLP + SALbCDataTab(i)%sunsetType = -1 + sunsetType = 0 + do j = 1,szSA + sa = tabSegArc(j) + if (sa%mixg==fooMix .or. sa%mixd==fooMix) then + cycle + else if (sa%mixg<0) then + sunsetType = -sa%mixg + else if (sa%mixd<0) then + sunsetType = -sa%mixd + else + cycle + end if + newBC = .true. + do k = 1,i + newBC = (newBC .and. (sunsetType /= SALbCDataTab(k)%sunsetType) & + & .and. (mod(sunsetType,100) /= B_Void) ) + end do + if (.not. newBC) cycle + !on a un type de condition limite non encore pris en compte + SALbCDataTab(i)%sunsetType = sunsetType + exit + end do + end do + !creation des donnees SAL pour chaque CL + do i = 1,nbCLP + SALbCDataTab(i)%nber = 0 + sunsetType = mod(SALbCDataTab(i)%sunsetType,100) + indice = SALbCDataTab(i)%sunsetType / 100 + select case(geomTyp) + case(RecTyp) + select case(sunsetType) + case(B_Refl,B_Ssym) + SALbCDataTab(i)%albedo = 1. + !SALbCDataTab(i)%SALtype = 1 !ne marche pas pour le moment + ! => on passe par une symetrie, mais exterieure + SALbCDataTab(i)%SALtype = 4 + select case(indice) + case(1) + SALbCDataTab(i)%cx = 0. + SALbCDataTab(i)%cy = 0. + SALbCDataTab(i)%angle = 90. + case(2) + SALbCDataTab(i)%cx = real(0.5*bCData%sidexy(1)-bCData%toOrig_xy(1)) + SALbCDataTab(i)%cy = 0. + SALbCDataTab(i)%angle = 90. + case(3) + SALbCDataTab(i)%cx = 0. + SALbCDataTab(i)%cy = 0. + SALbCDataTab(i)%angle = 0. + case(4) + SALbCDataTab(i)%cx = 0. + SALbCDataTab(i)%cy = real(0.5*bCData%sidexy(2)-bCData%toOrig_xy(2)) + SALbCDataTab(i)%angle = 0. + end select + case(B_Tran) + SALbCDataTab(i)%SALtype = 2 + select case(indice) + case(1) + SALbCDataTab(i)%tx = real(bCData%sidexy(1)) + SALbCDataTab(i)%ty = 0. + case(2) + SALbCDataTab(i)%tx = real(-bCData%sidexy(1)) + SALbCDataTab(i)%ty = 0. + case(3) + SALbCDataTab(i)%tx = 0. + SALbCDataTab(i)%ty = real(bCData%sidexy(2)) + case(4) + SALbCDataTab(i)%tx = 0. + SALbCDataTab(i)%ty = real(-bCData%sidexy(2)) + end select + case(B_Diag) + SALbCDataTab(i)%SALtype = 4 + SALbCDataTab(i)%cx = 0. + SALbCDataTab(i)%cy = 0. + SALbCDataTab(i)%angle = 45. + case(B_Syme) + SALbCDataTab(i)%SALtype = 4 + select case(indice) + case(1) + SALbCDataTab(i)%cx = 0. + SALbCDataTab(i)%cy = 0. + SALbCDataTab(i)%angle = 90. + case(2) + SALbCDataTab(i)%cx = real(bCData%minmaxXY(3)-bCData%toOrig_xy(1)) + SALbCDataTab(i)%cy = 0. + SALbCDataTab(i)%angle = 90. + case(3) + SALbCDataTab(i)%cx = 0. + SALbCDataTab(i)%cy = 0. + SALbCDataTab(i)%angle = 0. + case(4) + SALbCDataTab(i)%cx = 0. + SALbCDataTab(i)%cy = real(bCData%minmaxXY(4)-bCData%toOrig_xy(2)) + SALbCDataTab(i)%angle = 0. + end select + case(B_Albe) + SALbCDataTab(i)%SALtype = 0 + SALbCDataTab(i)%albedo = real(bCData%albedo(indice)) + case(B_Zero) + SALbCDataTab(i)%SALtype = 0 + SALbCDataTab(i)%albedo = 0. + case(B_Pi_2) + SALbCDataTab(i)%SALtype = 3 + SALbCDataTab(i)%cx = 0. + SALbCDataTab(i)%cy = 0. + if (indice==1) then + SALbCDataTab(i)%angle = -90. + else if (indice==3) then + SALbCDataTab(i)%angle = 90. + end if + case(B_Pi) + SALbCDataTab(i)%SALtype = 3 + SALbCDataTab(i)%cx = real(-bCData%toOrig_xy(1)) + SALbCDataTab(i)%cy = real(-bCData%toOrig_xy(2)) + SALbCDataTab(i)%angle = 180. + end select + case(HexTyp) + SALbCDataTab(i)%SALtype = 4 + if (bCData%iHex==H_Complete) SALbCDataTab(i)%SALtype = 2 + basex = 0.5d0*bCData%sidexy(1) + select case(indice) + case(1) + if (bCData%iHex==H_S30) then + SALbCDataTab(i)%cx = 0. + SALbCDataTab(i)%cy = 0. + SALbCDataTab(i)%angle = 0. + else if (bCData%iHex==H_SA60) then + SALbCDataTab(i)%cx = real(-bCData%toOrig_xy(1)) + SALbCDataTab(i)%cy = real(-bCData%toOrig_xy(2)) + SALbCDataTab(i)%angle = -30. + else if (bCData%iHex==H_Complete) then + SALbCDataTab(i)%tx = 0.0 + SALbCDataTab(i)%ty = real(2.0d0*sqrt(0.75d0)*basex) + SALbCDataTab(i)%angle = 0.0 + else + call XABORT("G2S: internal error in prepareSALBCData(1)") + end if + case(2) + SALbCDataTab(i)%angle = 30. + if (bCData%iHex==H_S30) then + SALbCDataTab(i)%cx = real(0.5d0*basex) + SALbCDataTab(i)%cy = 0. + else if (bCData%iHex==H_SA60) then + SALbCDataTab(i)%cx = real(-bCData%toOrig_xy(1)) + SALbCDataTab(i)%cy = real(-bCData%toOrig_xy(2)) + else if (bCData%iHex==H_Complete) then + SALbCDataTab(i)%tx = real(1.5d0*basex) + SALbCDataTab(i)%ty = real(sqrt(0.75d0)*basex) + SALbCDataTab(i)%angle = -60.0 + else + call XABORT("G2S: internal error in prepareSALBCData(2)") + end if + case(3) + SALbCDataTab(i)%cy = 0. + SALbCDataTab(i)%angle = 90. + if (bCData%iHex==H_S30) then + SALbCDataTab(i)%cx = real(.5*sqrt(3.)*bCData%sidexy(2)) + else if (bCData%iHex==H_SA60) then + SALbCDataTab(i)%cx = real(.5*sqrt(3.)*bCData%sidexy(2) & + -bCData%toOrig_xy(1)) + else if (bCData%iHex==H_Complete) then + SALbCDataTab(i)%tx = real(1.5d0*basex) + SALbCDataTab(i)%ty = real(-sqrt(0.75d0)*basex) + SALbCDataTab(i)%angle = -120.0 + else + call XABORT("G2S: internal error in prepareSALBCData(3)") + end if + case(4) + if (bCData%iHex==H_Complete) then + SALbCDataTab(i)%tx = 0.0 + SALbCDataTab(i)%ty = real(-2.0d0*sqrt(0.75d0)*basex) + SALbCDataTab(i)%angle = 180.0 + else + call XABORT("G2S: internal error in prepareSALBCData(4)") + end if + case(5) + if (bCData%iHex==H_Complete) then + SALbCDataTab(i)%tx = real(-1.5d0*basex) + SALbCDataTab(i)%ty = real(-sqrt(0.75d0)*basex) + SALbCDataTab(i)%angle = 120.0 + else + call XABORT("G2S: internal error in prepareSALBCData(5)") + end if + case(6) + if (bCData%iHex==H_Complete) then + SALbCDataTab(i)%tx = real(-1.5d0*basex) + SALbCDataTab(i)%ty = real(sqrt(0.75d0)*basex) + SALbCDataTab(i)%angle = 60.0 + else + call XABORT("G2S: internal error in prepareSALBCData(6)") + end if + end select + case(TriaTyp) + select case(sunsetType) + case(B_Refl) + SALbCDataTab(i)%SALtype = 1 + SALbCDataTab(i)%albedo = 1. + case(B_Albe) + SALbCDataTab(i)%SALtype = 0 + SALbCDataTab(i)%albedo = real(bCData%albedo(indice)) + case(B_Zero) + SALbCDataTab(i)%SALtype = 0 + SALbCDataTab(i)%albedo = 0. + case(B_Syme) + SALbCDataTab(i)%SALtype = 4 + select case(indice) + case(1) + if (bCData%iTri==T_S30) then + SALbCDataTab(i)%cx = 0. + SALbCDataTab(i)%cy = 0. + SALbCDataTab(i)%angle = 0. + else if (bCData%iTri==T_SA60) then + SALbCDataTab(i)%cx = real(-bCData%toOrig_xy(1)) + SALbCDataTab(i)%cy = real(-bCData%toOrig_xy(2)) + SALbCDataTab(i)%angle = -30. + else + call XABORT("G2S: internal error in prepareSALBCData(7)") + end if + case(2) + if (bCData%iTri==T_S30) then + SALbCDataTab(i)%cx = 0. + SALbCDataTab(i)%cy = 0. + SALbCDataTab(i)%angle = 30. + else if (bCData%iTri==T_SA60) then + SALbCDataTab(i)%cx = real(-bCData%toOrig_xy(1)) + SALbCDataTab(i)%cy = real(-bCData%toOrig_xy(2)) + SALbCDataTab(i)%angle = 30. + else + call XABORT("G2S: internal error in prepareSALBCData(8)") + end if + case(3) + SALbCDataTab(i)%cx = real(bCData%minmaxXY(3)-bCData%toOrig_xy(1)) + SALbCDataTab(i)%cy = 0. + SALbCDataTab(i)%angle = 90. + end select + end select + end select + end do + !remplissage du tableau des indices des segArc concernes par la condition + do i = 1,nbCLP + sunsetType = SALbCDataTab(i)%sunsetType + allocate(tmpTabElemNb(szSA),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: prepareSALBCData(1) => allocation pb") + tmpTabSize = 0 + do j = 1,szSA + sa = tabSegArc(j) + if (sa%mixg==-sunsetType .or. sa%mixd==-sunsetType) then + tmpTabSize = tmpTabSize + 1 + tmpTabElemNb(tmpTabSize) = j + end if + end do + SALbCDataTab(i)%nber = tmpTabSize + allocate(SALbCDataTab(i)%elemNb(tmpTabSize),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: prepareSALBCData(2) => allocation pb") + do j = 1,tmpTabSize + SALbCDataTab(i)%elemNb(j) = tmpTabElemNb(j) + end do + deallocate(tmpTabElemNb) + end do + end subroutine prepareSALBCData + + subroutine appliBoundariConditionsForHex(geoIp,szSA,nbCLP) + type(c_ptr),intent(in):: geoIp + integer,intent(inout) :: szSA + integer,intent(out) :: nbCLP + + real,dimension(2) :: tmpTab2 + real,dimension(6) :: tmpTab6 + type(c_ptr) :: ip + integer :: i,nbCut + double precision :: fx,fy,tx,ty,sqrt3_2,x,y,xx,yy,basex + double precision :: rayIntCell,rayIntCore,rayExtCell,rayExtCore + type(t_segArc) :: sg + + ! programmation defensive + integer :: dimTabSegArc + ! + dimTabSegArc = size(tabSegArc) + + ip = geoIp + call LCMGET(ip,'NCODE ',bCData%bc) + call LCMGET(ip,'ZCODE ',tmpTab6) ; bCData%albedo=tmpTab6 + call LCMGET(ip,'ICODE ',bCData%albInd) + call LCMGET(ip,'IHEX ',bCData%iHex) + bCData%sidexy(:)=0.0d0 + sqrt3_2 = 5.d-1*sqrt(3.d0) + nbCut = 0 ; nbCLP = 0 + rayExtCell = bCData%sidexy(1) + rayIntCell = sqrt3_2*rayExtCell + rayExtCore = bCData%sidexy(2) + rayIntCore = sqrt3_2*rayExtCore + select case(bCData%iHex) + case(H_S30) + !1 + nbCut=nbCut+1 ; nbCLP=nbCLP+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc) call XABORT("G2S: memory problem in routine & + &appliBoundaryConditionsForHex") + fx = -rayExtCell ; fy = 0.d0 + tx = rayIntCore+rayExtCell ; ty = 0.d0 + sg = createSeg(fx,fy,tx,ty,fooMix,-100-B_Syme) + tabSegArc(szSA) = sg + !2 + nbCut=nbCut+1 ; nbCLP=nbCLP+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc) call XABORT("G2S: memory problem in routine & + &appliBoundaryConditionsForHex") + fx = rayIntCore+sqrt3_2*rayIntCell + fy = 5.d-1*(rayExtCore+rayIntCell) + tx = 0.d0 ; ty = 0.d0 + sg = createSeg(fx,fy,tx,ty,fooMix,-200-B_Syme) + tabSegArc(szSA) = sg + if (bCData%bc(1)==B_Syme) then + !3 + nbCut=nbCut+1 ; nbCLP=nbCLP+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc) call XABORT("G2S: memory problem in routine & + &appliBoundaryConditionsForHex") + fx = rayIntCore ; fy = 0.d0 + tx = fx ; ty = 5.d-1*rayExtCore + sg = createSeg(fx,fy,tx,ty,fooMix,-300-bCData%bc(1)) + tabSegArc(szSA) = sg + end if + case(H_SA60) + !1 + nbCut=nbCut+1 ; nbCLP=nbCLP+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc) call XABORT("G2S: memory problem in routine & + &appliBoundaryConditionsForHex") + fx = -sqrt3_2*rayIntCell + fy = 5.d-1*rayIntCell + tx = rayIntCore+sqrt3_2*rayIntCell + ty = -5.d-1*(rayExtCore+rayIntCell) + sg = createSeg(fx,fy,tx,ty,fooMix,-100-B_Syme) + tabSegArc(szSA) = sg + !2 + nbCut=nbCut+1 ; nbCLP=nbCLP+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc) call XABORT("G2S: memory problem in routine & + &appliBoundaryConditionsForHex") + fx = rayIntCore+sqrt3_2*rayIntCell + fy = 5.d-1*(rayExtCore+rayIntCell) + tx = 0.d0 ; ty = 0.d0 + sg = createSeg(fx,fy,tx,ty,fooMix,-200-B_Syme) + tabSegArc(szSA) = sg + if (bCData%bc(1)==B_Syme) then + !3 + nbCut=nbCut+1 ; nbCLP=nbCLP+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc) call XABORT("G2S: memory problem in routine & + &appliBoundaryConditionsForHex") + fx = rayIntCore ; fy = -5.d-1*rayExtCore + tx = fx ; ty = -fy + sg = createSeg(fx,fy,tx,ty,fooMix,-300-bCData%bc(1)) + tabSegArc(szSA) = sg + end if + case(H_SB60) + !1 + nbCut=nbCut+1 ; nbCLP=nbCLP+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc) call XABORT("G2S: memory problem in routine & + &appliBoundaryConditionsForHex") + fx = -rayExtCell ; fy = 0.d0 + tx = rayIntCore+rayExtCell ; ty = 0.d0 + sg = createSeg(fx,fy,tx,ty,fooMix,-100-B_Syme) + tabSegArc(szSA) = sg + !2 + nbCut=nbCut+1 ; nbCLP=nbCLP+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc) call XABORT("G2S: memory problem in routine & + &appliBoundaryConditionsForHex") + fx = 5.d-1*(rayIntCore+rayExtCell) + fy = sqrt3_2*(rayIntCore+rayExtCell) + tx = 0.d0 ; ty = 0.d0 + sg = createSeg(fx,fy,tx,ty,fooMix,-200-B_Syme) + tabSegArc(szSA) = sg + case(H_S90) + !1 + nbCut=nbCut+1 ; nbCLP=nbCLP+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc) call XABORT("G2S: memory problem in routine & + &appliBoundaryConditionsForHex") + fx = -rayExtCell ; fy = 0.d0 + tx = rayIntCore+rayExtCell ; ty = 0.d0 + sg = createSeg(fx,fy,tx,ty,fooMix,-100-B_Syme) + tabSegArc(szSA) = sg + !2 + nbCut=nbCut+1 ; nbCLP=nbCLP+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc) call XABORT("G2S: memory problem in routine & + &appliBoundaryConditionsForHex") + fx = 0.d0 ; fy = rayExtCore+rayIntCell + tx = 0.d0 ; ty = 0.d0 + sg = createSeg(fx,fy,tx,ty,fooMix,-200-B_Syme) + tabSegArc(szSA) = sg + case(H_R120) + !!!appliquer les rotations adequat (pas simple) + case(H_R180) + !!!idem mais plus simple + case(H_SA180) + !1 + nbCut=nbCut+1 ; nbCLP=nbCLP+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc) call XABORT("G2S: memory problem in routine & + &appliBoundaryConditionsForHex") + fx = 0.d0 ; fy = rayExtCore+rayIntCell + tx = 0.d0 ; ty = -fy + sg = createSeg(fx,fy,tx,ty,fooMix,-100-B_Syme) + tabSegArc(szSA) = sg + case(H_SB180) + !1 + nbCut=nbCut+1 ; nbCLP=nbCLP+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc) call XABORT("G2S: memory problem in routine & + &appliBoundaryConditionsForHex") + fx = -rayExtCore-rayIntCell ; fy = 0.d0 + tx = -fx ; ty = 0.d0 + sg = createSeg(fx,fy,tx,ty,fooMix,-100-B_Syme) + tabSegArc(szSA) = sg + case(H_Complete) + do i=1,6 + if (bCData%bc(1) == B_Tran) then + nbCLP=nbCLP+1 + call LCMGET(ip,'SIDEXY ',tmpTab2) ; bCData%sidexy=tmpTab2 + y=0.0d0 ; yy=0.0d0 + basex = 0.5d0*bCData%sidexy(1) + select case(i) + case(1) + x = -0.5d0*basex + y = -sqrt(0.75d0)*basex + xx = 0.5d0*basex + yy = y + case(2) + x = -basex + xx = -0.5d0*basex + yy = -sqrt(0.75d0)*basex + case(3) + x = -0.5d0*basex + y = sqrt(0.75d0)*basex + xx = -basex + case(4) + x = 0.5d0*basex + y = sqrt(0.75d0)*basex + xx = -0.5d0*basex + yy = y + case(5) + x = basex + xx = 0.5d0*basex + yy = sqrt(0.75d0)*basex + case(6) + x = 0.5d0*basex + y = -sqrt(0.75d0)*basex + xx = basex + end select + call setBoundSide(x,y,xx,yy,100*i+B_Tran,szSA) + endif + enddo + end select + if (nbCut/=0) call setBoundCut(nbCut,szSA) + end subroutine appliBoundariConditionsForHex + + subroutine appliBoundariConditionsForTri(geoIp,szSA,nbCLP) + type(c_ptr),intent(in):: geoIp + integer,intent(inout) :: szSA + integer,intent(out) :: nbCLP + + real,dimension(2) :: tmpTab2 + real,dimension(4) :: tmpTab4 + real,dimension(6) :: tmpTab6 + type(c_ptr) :: ip + integer :: nbCut,i + double precision :: dy + type(t_segArc) :: sg + integer,dimension(40) :: sv + double precision,dimension(4) :: x,y + + ! programmation defensive + integer :: dimTabSegArc + dimTabSegArc = size(tabSegArc) + + ip = geoIp + call LCMGET(ip,'STATE-VECTOR',sv) + call LCMGET(ip,'NCODE ',bCData%bc) + call LCMGET(ip,'ZCODE ',tmpTab6) ; bCData%albedo=tmpTab6 + call LCMGET(ip,'ICODE ',bCData%albInd) + call LCMGET(ip,'ITRI ',bCData%iTri) + call LCMSIX(ip,'NEW-DATA ',1) + call LCMSIX(ip,'BOUND-DATA ',1) + call LCMGET(ip,'SIDEXY ',tmpTab2) ; bCData%sidexy=tmpTab2 + call LCMGET(ip,'MINMAXXY ',tmpTab4) ; bCData%minmaxXY=tmpTab4 + + nbCut = 0 + nbCLP = 0 + select case(bCData%iTri) + case(T_S30) + !1 (on ne coupe pas car inutile) + nbCLP=nbCLP+1 + call setBoundSide(0.d0,0.d0,bCData%sidexy(2),0.d0,100+B_Syme,szSA) + !2 + nbCut=nbCut+1 ; nbCLP=nbCLP+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc) call XABORT("G2S: memory problem in routine & + &appliBoundaryConditionsForTri") + dy = bCData%sidexy(1) * sqrt3_2d + if (estPaire(sv(4))) then + x(1) = bCData%sidexy(2) + y(1) = dy * sv(4) + else + x(1) = bCData%sidexy(2) - 2.5d-1*bCData%sidexy(1) + y(1) = dy * (sv(4) - 5.d-1) + end if + sg = createSeg(x(1),y(1),0.d0,0.d0,fooMix,-200-B_Syme) + tabSegArc(szSA) = sg + if (bCData%bc(1)==B_Syme) then + !3 + nbCut=nbCut+1 ; nbCLP=nbCLP+1 + szSA=szSA+1 ! programmation defensive + if (szSA > dimTabSegArc) call XABORT("G2S: memory problem in routine & + &appliBoundaryConditionsForTri") + + if (estPaire(sv(4))) then + x(2) = bCData%sidexy(2) + y(2) = dy * sv(4) + else + x(2) = bCData%sidexy(2) - 5.d-1*bCData%sidexy(1) + y(2) = dy * (sv(4) - 2.d0/3) + end if + bCData%minmaxXY(3)=x(2) !stockage de l'abscisse de l'axe de coupe + sg = createSeg(x(2),0.d0,x(2),y(2),fooMix,-300-B_Syme) + tabSegArc(szSA) = sg + end if + case(T_SA60) + !1 + nbCut=nbCut+1 ; nbCLP=nbCLP+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc) call XABORT("G2S: memory problem in routine & + &appliBoundaryConditionsForTri") + dy = bCData%sidexy(1) * sqrt3_2d + if (estPaire(sv(4))) then + x(1) = bCData%sidexy(2) + y(1) = -dy * sv(4) + else + x(1) = bCData%sidexy(2) - 2.5d-1*bCData%sidexy(1) + y(1) = -dy * (sv(4) - 5.d-1) + end if + sg = createSeg(0.d0,0.d0,x(1),y(1),fooMix,-100-B_Syme) + tabSegArc(szSA) = sg + !2 + nbCut=nbCut+1 ; nbCLP=nbCLP+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc) call XABORT("G2S: memory problem in routine & + &appliBoundaryConditionsForTri") + sg = createSeg(x(1),-y(1),0.d0,0.d0,fooMix,-200-B_Syme) + tabSegArc(szSA) = sg + if (bCData%bc(1)==B_Syme) then + !3 + nbCut=nbCut+1 ; nbCLP=nbCLP+1 + szSA=szSA+1 ! programmation defensive + if (szSA > dimTabSegArc) call XABORT("G2S: memory problem in routine & + &appliBoundaryConditionsForTri") + if (estPaire(sv(4))) then + x(2) = bCData%sidexy(2) + y(2) = dy * sv(4) + else + x(2) = bCData%sidexy(2) - 5.d-1*bCData%sidexy(1) + y(2) = dy * (sv(4) - 2.d0/3) + end if + bCData%minmaxXY(3)=x(2) !stockage de l'abscisse de l'axe de coupe + sg = createSeg(x(2),-y(2),x(2),y(2),fooMix,-300-B_Syme) + tabSegArc(szSA) = sg + end if + case(T_ST60) + x(1) = -5.d-1*bCData%sidexy(1) ; x(2) = 0. ; x(3) = -x(1) ; x(4) = x(1) + y(1) = sqrt3_2d*x(1) ; y(2) = -y(1) ; y(3) = y(1) ; y(4) = y(1) + do i = 1,3 + if (bCData%bc(i)/= B_Void) nbCLP=nbCLP+1 + call setBoundSide(x(i+1),y(i+1),x(i),y(i),bCData%bc(i)+100*i,szSA) + end do + case(T_Complete) + y(1) = -5.d-1*bCData%sidexy(2) ; y(2) = y(1) + y(3) = -y(1) ; y(4) = y(1) + x(1) = -5.d-1*bCData%sidexy(1) ; x(2) = -x(1) + x(3) = x(2) + y(3) ; x(4) = x(1) + y(3) + call setBoundSide(x(4),y(4),x(1),y(1),bCData%bc(1)+100,szSA) + call setBoundSide(x(2),y(2),x(3),y(3),bCData%bc(2)+200,szSA) + call setBoundSide(x(1),y(1),x(2),y(2),bCData%bc(3)+300,szSA) + call setBoundSide(x(3),y(3),x(4),y(4),bCData%bc(4)+400,szSA) + case default + call XABORT("G2S: internal error in subroutine & + &appliBoundariConditionsForTri") + end select + if (nbCut/=0) call setBoundCut(nbCut,szSA) + end subroutine appliBoundariConditionsForTri + + subroutine appliBoundariConditionsForTub(geoIp,nbCLP) + type(c_ptr),intent(in):: geoIp + integer,intent(out) :: nbCLP + + real,dimension(6) :: tmpTab6 + + nbCLP = 0 + call LCMGET(geoIp,'NCODE ',bCData%bc) + call LCMGET(geoIp,'ZCODE ',tmpTab6) ; bCData%albedo=tmpTab6 + call LCMGET(geoIp,'ICODE ',bCData%albInd) + end subroutine appliBoundariConditionsForTub + +end module boundCond diff --git a/Dragon/src/g2s_cast.f90 b/Dragon/src/g2s_cast.f90 new file mode 100644 index 0000000..92b6ffd --- /dev/null +++ b/Dragon/src/g2s_cast.f90 @@ -0,0 +1,63 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Perform character to integer and integer to character conversion. +! +!Copyright: +! Copyright (C) 2001 Ecole Polytechnique de Montreal. +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): +! G. Civario (CS-SI) +! +!Comments: +! - c2i : transforme un caractere en chiffre +! - s2i : transforme une chaine de caracteres en nombre +! - i2s : transforme un nombre en chaine de caracteres +!----------------------------------------------------------------------- +! +module cast + implicit none + + integer,parameter :: izero=ichar('0') + +contains + + function c2i(c) + character,intent(in) :: c + integer :: c2i + + c2i = ichar(c) - izero + if (c2i<0 .or. c2i>9) & + & call XABORT("G2S: internal error, bad cast from string to integer") + end function c2i + + function s2i(s) + character(len=*),intent(in) :: s + integer :: s2i + integer :: i,l,n + + s2i = 0 + l = len_trim(s) + do i = 1,l + n = c2i(s(i:i)) + s2i = s2i + n*10**(l-i) + end do + end function s2i + + function i2s(i) + integer,intent(in) :: i + character*12 :: i2s + + character*12 :: tmp + + tmp = ' ' + write(tmp,'(i12)') i + i2s = adjustl(tmp) + end function i2s + +end module cast diff --git a/Dragon/src/g2s_celluleBase.f90 b/Dragon/src/g2s_celluleBase.f90 new file mode 100644 index 0000000..e5b89d0 --- /dev/null +++ b/Dragon/src/g2s_celluleBase.f90 @@ -0,0 +1,679 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Creation of an array of type(t_celluleBase) structures. +! +!Copyright: +! Copyright (C) 2001 Ecole Polytechnique de Montreal. +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): +! G. Civario (CS-SI) +! +!Comments: +! Il s'agit de toutes les cellules terminales de la geometrie (=celles qui +! ne comportent pas de sous-cellules). +! La creation se fait a l'aide de la routine recursive buildCellsBase. +! Elle explore toute l'arboressence de l'objet PyLCM donne en entree, et appelle +! a chaque niveau la routine writeCellBase. +! Celle-ci teste si la cellule est terminale, et cree une entree dans le tableau +! des cellules de base si c'est le cas. +! La cellule creee est ensuite completee si besoin, et sa coherence est +! verifiee +! \\\\ +! variable globale +! - tabCelluleBase : tableau des cellules de base +! \\\\ +! fonctions du module +! - initializeTabCelluleBase : mise a zero du tableau +! - destoyTabCelluleBase : liberation de la memoire +! - decale : decale les valeurs d'un tableau pour les faire demarer a 0 +! - createCB : constructeur d'une cellule de base +! - destroyCB : destructeur d'une cellule de base +! - createCluster : constructeur d'un cluster +! - sortClusterTab : trie un tableau de clusters +! - verrifieCB : verification de la coherence d'une cellule de base +! - exploiteSplit : exploitation de la donnee split dans la cellule +! - buildCellsBase : fonction recursive de creation du tableau de cellules +! - writeCellBase : creation d'une cellule +! +!----------------------------------------------------------------------- +! +module celluleBase + + use constType + use GANLIB + use segArc, only : alloc_ok + + implicit none + + !cluster + type t_cluster + character*12 :: name !nom + integer :: nbrPin !nombre de crayons + double precision :: radiusOfPin !rayon de la couronne + double precision :: angleOfPin !angle du 1er crayon + double precision,dimension(:),pointer :: radius !rayons des anneaux + integer,dimension(:),pointer :: mix !milieux des crayons + end type t_cluster + + !cellule generique de plus bas niveau hierarchique dans les gigognes + type t_celluleBase + character*12 :: name !nom + integer,dimension(40) :: sv !state vector + integer,dimension(:),allocatable :: mix !milieux + integer,dimension(:),allocatable :: merge !regroupements + double precision,dimension(:),allocatable :: radius !rayons + double precision,dimension(3) :: offcenter !x , y et z + double precision,dimension(:),allocatable :: meshx !en commancant a 0.0 + double precision,dimension(:),allocatable :: meshy !en commancant a 0.0 + double precision :: side !pour tri et hex + integer,dimension(:),allocatable :: splitr !>0 rayon; <0 surface + integer,dimension(:),allocatable :: splitx !>0 + integer,dimension(:),allocatable :: splity !>0 + type(t_cluster),dimension(:),pointer :: cluster !les clusters + !tableau de bool qui donne la presence ou non de chacun des 10 champs + !avec en plus l'indice 0 disant si la cellule est viable (complete) + logical,dimension(0:12) :: ok + end type t_celluleBase + + !parametres pour le vecteur ok + integer,parameter :: n_sv=1 , n_mix=2 , n_radius=3 , n_offcenter=4 , & + & n_meshx=5 , n_meshy=6 , n_side=7 , n_splitr=8 , & + & n_splitx=9 , n_splity=10 , n_cluster=11 , n_merge=12 , & + & n_tot=0 + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! declaration d'une variable tableau globale + !! + type(t_celluleBase),dimension(:),allocatable :: tabCelluleBase + !! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +contains + + subroutine initializeTabCelluleBase(dimTabCelluleBase) + integer,intent(in) :: dimTabCelluleBase + + allocate(tabCelluleBase(dimTabCelluleBase),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: initializeTabCelluleBase(1) => allocation pb") + end subroutine initializeTabCelluleBase + + subroutine destroyTabCelluleBase(szB) + integer,intent(in) :: szB + integer :: i + + do i = 1,szB + call destroyCB(tabCelluleBase(i)) + end do + deallocate(tabCelluleBase) + end subroutine destroyTabCelluleBase + + !fait demarer un tableau de reels a 0.0 + subroutine decale(tab) +! double precision,dimension(:),pointer :: tab + double precision,dimension(:) :: tab + integer :: i, lg + + lg = size(tab) + do i = lg,1,-1 + tab(i) = tab(i) - tab(1) + end do + end subroutine decale + + !remplisage d'une cellule de base + subroutine createCB(cell,name,ip) + type(t_celluleBase),intent(out) :: cell + character*12,intent(in) :: name + type(c_ptr),intent(in) :: ip + + integer :: lg,typ,i,lgm + real,dimension(:),allocatable :: tmpTabReal + character*12,dimension(:),allocatable :: clusterName + + cell%name = name + + call LCMGET(ip,'STATE-VECTOR',cell%sv) + cell%ok(n_sv) = .true. + + call LCMLEN(ip,'MIX ',lgm,typ) + cell%ok(n_mix) = (lgm/=0) + if(cell%ok(n_mix)) then + allocate(cell%mix(lgm),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: createCB(1) => allocation pb") + call LCMGET(ip,'MIX ',cell%mix) + else + call XABORT("G2S: no mix in the cellule " // name) + end if + + call LCMLEN(ip,'MERGE ',lg,typ) + cell%ok(n_merge) = (lg/=0) + if(cell%ok(n_merge)) then + if(lg/=lgm) call XABORT("G2S: bad dimension for merge in the & + &cellule " // name) + allocate(cell%merge(lg),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: createCB(2) => allocation pb") + call LCMGET(ip,'MERGE ',cell%merge) + else + allocate(cell%merge(lgm),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: createCB(3) => allocation pb") + cell%merge(:lgm) = (/(i,i=1,lgm)/) + end if + + call LCMLEN(ip,'RADIUS ',lg,typ) + cell%ok(n_radius) = (lg/=0) + if(cell%ok(n_radius)) then + allocate(cell%radius(lg),tmpTabReal(lg),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: createCB(4) => allocation pb") + call LCMGET(ip,'RADIUS ',tmpTabReal) + cell%radius(:lg)=tmpTabReal(:lg) + deallocate(tmpTabReal) + else if(cell%sv(1)==G_Carcel.or.cell%sv(1)==G_Hexcel) then + !cas carcel 0 ou hexcel 0 + allocate(cell%radius(1)) + cell%radius(1)=0.d0 + else + !nullify(cell%radius) + end if + + call LCMLEN(ip,'OFFCENTER ',lg,typ) + cell%ok(n_offcenter) = (lg/=0) + if(cell%ok(n_offcenter)) then + allocate(tmpTabReal(lg),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: createCB(5) => allocation pb") + call LCMGET(ip,'OFFCENTER ',tmpTabReal) + cell%offcenter=tmpTabReal + deallocate(tmpTabReal) + else + cell%offcenter=0.d0 + end if + + call LCMLEN(ip,'MESHX ',lg,typ) + cell%ok(n_meshx) = (lg/=0) + if(cell%ok(n_meshx)) then + allocate(cell%meshx(lg),tmpTabReal(lg),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: createCB(6) => allocation pb") + call LCMGET(ip,'MESHX ',tmpTabReal) + cell%meshx(:lg)=tmpTabReal(:lg) + deallocate(tmpTabReal) + call decale(cell%meshx) !decalage pour demarer a 0.0 + else + !nullify(cell%meshx) + end if + + call LCMLEN(ip,'MESHY ',lg,typ) + cell%ok(n_meshy) = (lg/=0) + if(cell%ok(n_meshy)) then + allocate(cell%meshy(lg),tmpTabReal(lg),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: createCB(7) => allocation pb") + call LCMGET(ip,'MESHY ',tmpTabReal) + cell%meshy(:lg)=tmpTabReal(:lg) + deallocate(tmpTabReal) + call decale(cell%meshy) !decalage pour demarer a 0.0 + else + !nullify(cell%meshy) + end if + + call LCMLEN(ip,'SIDE ',lg,typ) + cell%ok(n_side) = (lg/=0) + if(cell%ok(n_side)) then + allocate(tmpTabReal(lg),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: createCB(8) => allocation pb") + call LCMGET(ip,'SIDE ',tmpTabReal) + cell%side=tmpTabReal(1) + deallocate(tmpTabReal) + else + cell%side=0.d0 + end if + + call LCMLEN(ip,'SPLITR ',lg,typ) + cell%ok(n_splitr) = (lg/=0) + if(cell%ok(n_splitr)) then + allocate(cell%splitr(lg),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: createCB(9) => allocation pb") + call LCMGET(ip,'SPLITR ',cell%splitr) + else + !nullify(cell%splitr) + end if + + call LCMLEN(ip,'SPLITX ',lg,typ) + cell%ok(n_splitx) = (lg/=0) + if(cell%ok(n_splitx)) then + allocate(cell%splitx(lg),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: createCB(10) => allocation pb") + call LCMGET(ip,'SPLITX ',cell%splitx) + else if(cell%sv(1)==G_Car2d.or.cell%sv(1)==G_Carcel) then + allocate(cell%splitx(cell%sv(3)),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: createCB(11) => allocation pb") + cell%splitx = 1 + else + allocate(cell%splitx(1)) + cell%splitx(1) = 1 + end if + + call LCMLEN(ip,'SPLITY ',lg,typ) + cell%ok(n_splity) = (lg/=0) + if(cell%ok(n_splity)) then + allocate(cell%splity(lg),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: createCB(12) => allocation pb") + call LCMGET(ip,'SPLITY ',cell%splity) + else if(cell%sv(1)==G_Car2d.or.cell%sv(1)==G_Carcel) then + allocate(cell%splity(cell%sv(4)),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: createCB(13) => allocation pb") + cell%splity = 1 + else + allocate(cell%splity(1)) + cell%splity(1) = 1 + end if + + call LCMLEN(ip,'CLUSTER ',lg,typ) + cell%ok(n_cluster) = (lg/=0) + if(cell%ok(n_cluster)) then + lg = lg/3 + allocate(cell%cluster(lg),clusterName(lg),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: createCB(14) => allocation pb") + call LCMGTC(ip,'CLUSTER ',12,lg,clusterName) + do i = 1,lg + cell%cluster(i) = createCluster(ip,clusterName(i)) + end do + !on trie le tableau des cluster par rayon croissant + call sortClusterTab(cell%cluster) + deallocate(clusterName) + else + nullify(cell%cluster) + end if + + call verrifieCB(cell) + call exploiteSplit(cell) + end subroutine createCB + + subroutine destroyCB(cell) + type(t_celluleBase),intent(inout) :: cell + integer :: i + + if(allocated(cell%mix)) deallocate(cell%mix) + if(allocated(cell%merge)) deallocate(cell%merge) + if(allocated(cell%radius)) deallocate(cell%radius) + if(allocated(cell%meshx)) deallocate(cell%meshx) + if(allocated(cell%meshy)) deallocate(cell%meshy) + if(allocated(cell%splitr)) deallocate(cell%splitr) + if(allocated(cell%splitx)) deallocate(cell%splitx) + if(allocated(cell%splity)) deallocate(cell%splity) + if(associated(cell%cluster)) then + do i = 1,size(cell%cluster) + deallocate(cell%cluster(i)%mix,cell%cluster(i)%radius) + !nullify(cluster%mix,cell%cluster(i)%radius) + end do + deallocate(cell%cluster) + end if + end subroutine destroyCB + + function createCluster(cellBIp,clusterName) + type(c_ptr),intent(in) :: cellBIp + character*12,intent(in) :: clusterName + type(t_cluster) :: createCluster + + type(c_ptr) :: ip + integer :: lg,lgx,lgy,ty + real :: rpin,apin,cx,cy + real,dimension(:),allocatable :: radius + real, parameter :: pi = 3.141592653589793 + + ip = cellBIp + call LCMSIX(ip,clusterName,1) + + createCluster%name = clusterName + + call LCMLEN(ip,'CPINX ',lgx,ty) + call LCMLEN(ip,'CPINY ',lgy,ty) + if ((lgx==1).and.(lgy==1)) then + + createCluster%nbrPin = 1 + call LCMGET(ip,'CPINX ',cx) + call LCMGET(ip,'CPINY ',cy) + rpin = sqrt(cx**2+cy**2) + if((cy == 0.0).and.(cy == 0.0)) then + rpin = 0.0 + apin = 0.0 + else if(cy >= 0.0) then + apin = acos(cx/rpin) + else + apin = 2.0*pi-acos(cx/rpin) + endif + + else + + call LCMGET(ip,'NPIN ',createCluster%nbrPin) + call LCMGET(ip,'RPIN ',rpin) + call LCMGET(ip,'APIN ',apin) + + endif + createCluster%radiusOfPin = rpin + createCluster%angleOfPin = apin + + call LCMLEN(ip,'MIX ',lg,ty) + allocate(radius(lg+1),createCluster%radius(lg+1),createCluster%mix(lg),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: createCluster => allocation pb") + call LCMGET(ip,'RADIUS ',radius) + createCluster%radius(:lg+1) = radius(:lg+1) + deallocate(radius) + + call LCMGET(ip,'MIX ',createCluster%mix) + end function createCluster + + subroutine sortClusterTab(clusterPrt) + type(t_cluster),dimension(:),pointer :: clusterPrt + !trie le tableau des clusters par rayon croissant des couronnes + type(t_cluster) :: tmpCluster + integer :: sz,indMax,i + logical :: trie + + if(.not. associated(clusterPrt)) return !pas de cluster + sz = size(clusterPrt) + do indMax = sz,2,-1 + trie = .true. + do i = 1,indMax-1 + if(clusterPrt(i+1)%radiusOfPin1 ly>1 is incompatinle with SECT") + select case(sectori) + case(S_not) + nsectint=1 + nsectext=1 + case(S_X_tot,S_T_tot) + nsectint=4 + if(sectorj /= 0) nsectint=1 + nsectext=4 + case(S_TX_tot,S_TXS_tot) + nsectint=8 + if(sectorj /= 0) nsectint=1 + nsectext=8 + case(S_WM_tot) + nsectint=12 + if(sectorj /= 0) nsectint=1 + nsectext=12 + end select + case(G_Hexcel) + select case(sectori) + case(S_not) + nsectint=1 + nsectext=1 + case(S_X_tot) + nsectint=6 + if(sectorj /= 0) nsectint=1 + nsectext=6 + end select + end select + if(nx*ny.gt.1) then + longueur2=nx*ny*(longueur+1) + else + longueur2=nsectint*longueur+nsectext + endif + allocate(tmpRad(longueur+1),tmpMix(longueur2),tmpMrg(longueur2),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: exploitSplit(1) => allocation pb") + tmpRad(1)=0.d0 + k = 1 + k2= 1 + do i = 1,size(cell%splitr) + valS = cell%splitr(i) + if(valS==0) then + call XABORT("G2S : SPLITR may not be null") + else if(valS>0) then + !on coupe en sous-rayons egaux -> moyenne arthmetique des rayons + interval = (cell%radius(i+1)-cell%radius(i))/valS + do j = 1,valS + if(nx*ny.gt.1) then + do ip=1,nx*ny + tmpMix((ip-1)*(longueur+1)+k) = cell%mix((ip-1)*(size(cell%radius))+i) + tmpMrg((ip-1)*(longueur+1)+k) = (ip-1)*(longueur+1)+k + end do + else + do sect=1,nsectint + tmpMix(k2) = cell%mix(nsectint*(i-1)+sect) + !! BEFORE tmpMrg(k) = cell%merge(i) + tmpMrg(k2) = k2 + k2= k2+ 1 + end do + endif + k = k + 1 + tmpRad(k) = tmpRad(k-1) + interval + end do + else + !on coupe en sous-surfaces egales -> moyenne geometrique des rayons + valS = abs(valS) + interval = (cell%radius(i+1)**2-cell%radius(i)**2)/valS + do j = 1,valS + if(nx*ny.gt.1) then + do ip=1,nx*ny + tmpMix((ip-1)*(longueur+1)+k) = cell%mix((ip-1)*(size(cell%radius))+i) + tmpMrg(k) = (ip-1)*(longueur+1)+k + end do + else + do sect=1,nsectint + tmpMix(k2) = cell%mix(nsectint*(i-1)+sect) + !! BEFORE tmpMrg(k) = cell%merge(i) + tmpMrg(k2) = k2 + k2= k2+ 1 + end do + endif + k = k + 1 + tmpRad(k) = sqrt(tmpRad(k-1)**2 + interval) + end do + end if + end do + if(nx*ny.gt.1) then + do ip=1,nx*ny + tmpMix(ip*(longueur+1)) = cell%mix(ip*(size(cell%radius))) + tmpMrg(ip*(longueur+1)) = ip*(longueur+1) + end do + else + do sect=1,nsectext + tmpMix(k2) = cell%mix(nsectint*size(cell%splitr)+sect) + !!BEFORE tmpMrg(longueur+1) = cell%merge(size(cell%merge)) + tmpMrg(k2) = k2 + k2= k2+ 1 + end do + endif + deallocate(cell%radius) ; allocate(cell%radius(longueur+1),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: exploiteSplit(2) => allocation pb") + deallocate(cell%mix) ; allocate(cell%mix(longueur2),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: exploiteSplit(3) => allocation pb") + deallocate(cell%merge) ; allocate(cell%merge(longueur2),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: exploiteSplit(4) => allocation pb") + cell%radius(:longueur+1) = tmpRad(:longueur+1) + cell%mix(:longueur2) = tmpMix(:longueur2) ; cell%merge(:longueur2) = tmpMrg(:longueur2) + deallocate(tmpRad,tmpMix,tmpMrg) + end subroutine exploiteSplit + + recursive subroutine buildCellsBase(ip,sz,dirname) + type(c_ptr),intent(inout):: ip + integer,intent(inout) :: sz + character*12 ,intent(in) :: dirname + + character*12 :: namp, savename, subdirname + integer :: type, long + + integer,parameter :: dir=0 + + call writeCellBase(ip,sz,dirname) + namp = ' ' + call LCMNXT(ip,namp) + savename = namp + do + if(namp == ' ') exit + call LCMLEN(ip,namp,long,type) + if(type == dir) then + if(namp /= 'BIHET') then + subdirname = namp + call LCMSIX(ip,namp,1) + call buildCellsBase(ip,sz,subdirname) + call LCMSIX(ip,namp,2) + end if + end if + call LCMNXT(ip,namp) + if(namp == savename) exit + end do + end subroutine buildCellsBase + + subroutine writeCellBase(ip,sz,dirname) + type(c_ptr),intent(in) :: ip + integer,intent(inout) :: sz + character*12 ,intent(in) :: dirname + + integer,dimension(40) :: st !state vector + integer :: type, long, i + logical :: toCreate + + call LCMLEN(ip,'STATE-VECTOR',long,type) + if(long==0) then + !on est dans la partie nouvelle (donnees ajoutees par pretaitement + !python => on sort de la subroutine + return + end if + call LCMGET(ip,'STATE-VECTOR',st) + call LCMLEN(ip,'NPIN ',long,type) ! pour tester si c'est un cluster + if(st(8)==0 .and. long==0) then !pas de sous-cellules + toCreate = .true. + do i = 1,sz + if(tabCelluleBase(i)%name==dirname) toCreate = .false. + end do + if(toCreate) then + sz = sz + 1 +!!$ allocate(tabCelluleBase(sz)%p,stat=alloc_ok) +!!$ if (alloc_ok /= 0) call XABORT("G2S: writeCellBase => allocation pb") + call createCB(tabCelluleBase(sz),dirname,ip) + end if + end if + end subroutine writeCellBase + +end module celluleBase diff --git a/Dragon/src/g2s_cellulePlaced.f90 b/Dragon/src/g2s_cellulePlaced.f90 new file mode 100644 index 0000000..08dbfcb --- /dev/null +++ b/Dragon/src/g2s_cellulePlaced.f90 @@ -0,0 +1,300 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Creation of an array of type(t_cellulePlaced) structures. +! +!Copyright: +! Copyright (C) 2001 Ecole Polytechnique de Montreal. +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): +! G. Civario (CS-SI) +! +!Comments: +! Les structures definies de type "t_cellulePlaced" possedent comme champs : +! -une reference a une cellule de base (indice dans le tableau celluleBase) +! -la position (x,y) du centre de la cellule +! -l'orientation de la cellule (turn). La definition de ce turn depend du +! type de la geometrie envisagee (les turns n'ont pas la meme signification) +! Le tableau est cree par la routine chargerNewData, qui en plus complete +! les donnees des cellules de base. Pour cela, elle va lire les donnees crees +! par les routines de pretraitement. +! \\\\ +! variable globale: +! - tabCellulePlaced : tableau des cellules placees +! - geomTyp : type de la geometrie exterieure +! \\\\ +! fonctions: +! - initializeTabCellulePlaced : mise a zero du tableau +! - destroyTabCellulePlaced : liberation de la memoire +! - splitCells : eclatement des cellules en elements geometriques simples +! - chargerNewData : recuperations des donnees supplementaires crees a +! l'etape de pretraitement +! - litDonneesSup : lectures des donnees supplementaires +! +!----------------------------------------------------------------------- +! +module cellulePlaced + use cast + use celluleBase + use constType + use construire + use GANLIB + use segArc + + implicit none + + !cellule "prete a l'emploi" i.e une reference a une celluleBase + !plus la position du centre de la cellule, et son orientation + !par rapport a la celluleBase de reference + type t_cellulePlaced + integer :: indice !indice de la celluleBase dans le tableau + double precision :: xcenter !abscice du centre + double precision :: ycenter !ordonnee du centre + integer :: turn !rotation par rapport a la celluleBase + integer,dimension(:), allocatable :: gig !gigogne de la cellule + integer,dimension(:), allocatable :: mrg !gigogne equivalente de la cellule + end type t_cellulePlaced + + integer,parameter :: dimTabCellulePlaced=10000 + + !variable globale de type tableau de cellulePlaced + type(t_cellulePlaced),dimension(:), allocatable :: tabCellulePlaced + + !variable globale donnant le type de la geometrie envisagee + ! (rectangle, hexagonale, triangulaire, tubulaire) + integer,save :: geomTyp + + integer,parameter :: RecTyp=1 , HexTyp=2 , TriaTyp=3 , TubeTyp=4 + +contains + + subroutine initializeTabCellulePlaced() + + allocate(tabCellulePlaced(dimTabCellulePlaced),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: initializeTabCellulePlaced => allocation pb") + end subroutine initializeTabCellulePlaced + + subroutine destroyTabCellulePlaced(szP) + integer,intent(in) :: szP + integer :: i + + do i = 1,szP + deallocate(tabCellulePlaced(i)%gig,tabCellulePlaced(i)%mrg) + end do + deallocate(tabCellulePlaced) + end subroutine destroyTabCellulePlaced + + subroutine splitCells(szP,szSA) + integer,intent(in) :: szP + integer,intent(inout) :: szSA + + integer :: i,j,s,keepSzSA,ip,ix,iy,lmx,lmy + double precision :: sx,sy,sxt,syt,offcx,offcy,cx,cy,cxloc,cyloc,offcxt,offcyt + type(t_cellulePlaced) :: tcp + type(t_celluleBase) :: tcb + integer,dimension(:),allocatable :: mix,psplitx,psplity + + !nullify(mix) + if(szP > dimTabCellulePlaced) call XABORT('splitCells: dimTabCellulePlaced overflow.') + do i = 1,szP + tcp = tabCellulePlaced(i) + tcb = tabCelluleBase(tcp%indice) + keepSzSA = szSA + select case(tcb%sv(1)) + case(G_Car2d) + sx = tcb%meshx(size(tcb%meshx)) + sy = tcb%meshy(size(tcb%meshy)) + s = size(tcb%mix) + allocate(mix(s)) + mix = (/(j,j=1,s)/) + call construit_car2d(tcp%xcenter,tcp%ycenter,sx,sy,tcp%turn,& + & tcb%meshx/sx,tcb%meshy/sy,tcb%splitx,tcb%splity,mix,szSA) + deallocate(mix) + !nullify(mix) + case(G_Carcel) + sxt = tcb%meshx(size(tcb%meshx)) + syt = tcb%meshy(size(tcb%meshy)) + s = size(tcb%radius) + lmx = size(tcb%meshx) + lmy = size(tcb%meshy) + if ((lmx.eq.2).and.(lmy.eq.2)) then + allocate(mix(s),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: splitCells(2) => allocation pb") + mix = (/(j,j=1,s)/) + call construit_carcel(tcp%xcenter,tcp%ycenter,sxt,syt,tcp%turn,& + & tcb%radius,tcb%offcenter(1),tcb%offcenter(2),tcb%splitx,& + tcb%splity,mix,tcb%sv(14),tcb%sv(15),tcb%cluster,szSA) + deallocate(mix) + ! nullify(mix) + else +! AFTER : CARCEL lr lx ly with lx>0 ly>0 + ip = 0 + allocate(mix(s),psplitx(lmx-1),psplity(lmy-1),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: splitCells(3) => allocation pb") + do ix = 2, lmx + do iy = 2, lmy + ip = ip+1 + cxloc = 0.5D0*(tcb%meshx(ix)+tcb%meshx(ix-1)) + cyloc = 0.5D0*(tcb%meshy(iy)+tcb%meshy(iy-1)) + sx = tcb%meshx(ix)-tcb%meshx(ix-1) + sy = tcb%meshy(iy)-tcb%meshy(iy-1) + offcx = 0.5D0*sxt-cxloc + offcy = 0.5D0*syt-cyloc + cx = tcp%xcenter-offcx + cy = tcp%ycenter-offcy + offcxt = offcx+tcb%offcenter(1) + offcyt = offcy+tcb%offcenter(2) + psplitx = (/(tcb%splitx(j),j=ix-1,lmx-1)/) + psplity = (/(tcb%splity(j),j=iy-1,lmy-1)/) + mix = (/(j,j=(ip-1)*s+1,ip*s)/) + call construit_carcel(cx,cy,sx,sy,tcp%turn,& + & tcb%radius,offcxt,offcyt,psplitx,& + & psplity,mix,tcb%sv(14),tcb%sv(15),tcb%cluster,szSA) + end do + end do + deallocate(mix,psplitx,psplity) + !nullify(mix,psplitx,psplity) + endif + case(G_Hex) + call construit_hexhom(tcp%xcenter,tcp%ycenter,tcb%side,1,szSA,tcb%sv(14)) + case(G_Hexcel) + s = size(tcb%radius) + allocate(mix(s),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: splitCells(4) => allocation pb") + mix = (/(j,j=1,s)/) + call construit_hexcel(tcp%xcenter,tcp%ycenter,tcb%side,tcp%turn,& + & tcb%radius,tcb%offcenter(1),tcb%offcenter(2),mix, & + & tcb%sv(14),tcb%sv(15),tcb%cluster,szSA) + deallocate(mix) + !nullify(mix) + case(G_Tri) + allocate(mix(1)) + mix = (/1/) + call construit_tri2d(tcp%xcenter,tcp%ycenter,tcb%side,tcp%turn,& + & tcb%sv(3),mix,szSA) + deallocate(mix) + !nullify(mix) + case(G_Tube) + s = size(tcb%mix) + allocate(mix(s+1),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: splitCells(5) => allocation pb") + mix(1:s) = (/(j,j=1,s)/) + mix(s+1) = fooMix + call construit_tube(0.d0,0.d0,tcb%radius,mix,tcb%cluster,szSA) + deallocate(mix) + !nullify(mix) + case default + call XABORT("G2S: splitCells --> Type of geometry not supported") + end select + !ajout du numero de la cellulePlaced dont sont issus les segArcs + do j = keepSzSA+1,szSA + tabSegArc(j)%indCellPg = i + tabSegArc(j)%indCellPd = i + end do + end do + end subroutine splitCells + + !en sortie, toutes les cellules de base ont tous leurs + !champs remplis + subroutine chargerNewData(geoIp,szB,szP) + type(c_ptr),intent(in) :: geoIp + integer,intent(inout) :: szB,szP + + integer :: i + type(c_ptr) :: ip + + ip = geoIp + call LCMSIX(ip,'NEW-DATA ',1) + do i = 1,szB + call litDonneesSup(ip,tabCelluleBase(i),i,szP) + end do + call LCMSIX(ip,'NEW-DATA ',2) + end subroutine chargerNewData + + subroutine litDonneesSup(ip,cellB,ind,szP) + type(c_ptr),intent(inout) :: ip + integer,intent(inout) :: szP + integer,intent(in) :: ind + type(t_celluleBase),intent(inout) :: cellB + + integer :: i,lg,typ,dimGig + character*12 :: posName,number,mrgName + real,dimension(2) :: sidexy + real,dimension(:),allocatable :: cx,cy + integer,dimension(:),allocatable :: tu + + + if (cellB%name/='/ ') then + call LCMSIX(ip,cellB%name,1) !on entre dans le repertoire + !lecture des dimension de la cellule + call LCMLEN(ip,'SIDEXY ',lg,typ) + if (lg==0) then !pas de donnees supplementaires + call LCMSIX(ip,' ',2) + return + else if (lg==2) then !c'est un rectangle + call LCMGET(ip,'SIDEXY ',sidexy) + if (.not. cellB%ok(n_meshx)) then + allocate(cellB%meshx(2)) + cellB%meshx(1) = 0.d0 + cellB%meshx(2) = sidexy(1) + endif + if (.not. cellB%ok(n_meshy)) then + allocate(cellB%meshy(2)) + cellB%meshy(1) = 0.d0 + cellB%meshy(2) = sidexy(2) + endif + else !c'est un triangle ou un hexagone + if (.not. cellB%ok(n_side)) then + call LCMGET(ip,'SIDEXY ',sidexy) + cellB%side = sidexy(1) + end if + end if + + call LCMLEN(ip,'TURN ',lg,typ) + allocate(cx(lg),cy(lg),tu(lg),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: litDonneesSup(2) => allocation pb") + call LCMGET(ip,'COORDX ',cx) + call LCMGET(ip,'COORDY ',cy) + call LCMGET(ip,'TURN ',tu) + do i = 1,lg + szP = szP + 1 + tabCellulePlaced(szP)%indice = ind + tabCellulePlaced(szP)%xcenter = cx(i) + tabCellulePlaced(szP)%ycenter = cy(i) + tabCellulePlaced(szP)%turn = tu(i) + number = i2s(i) + posName = 'POS' // number(:9) + call LCMLEN(ip,posName,dimGig,typ) + allocate(tabCellulePlaced(szP)%gig(dimGig),stat=alloc_ok) + if (alloc_ok /= 0) then + write(6,*) "litDonneesSup: szP=",szP," dimGig=",dimGig + call XABORT("G2S: litDonneesSup(4) => allocation pb") + endif + call LCMGET(ip,posName,tabCellulePlaced(szP)%gig) + mrgName = 'MRG' // number(:9) + allocate(tabCellulePlaced(szP)%mrg(dimGig),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: litDonneesSup(5) => allocation pb") + call LCMGET(ip,mrgName,tabCellulePlaced(szP)%mrg) + end do + deallocate(cx,cy,tu) + !on sort du repertoire + call LCMSIX(ip,cellB%name,2) + else !une seule cellule + szP = 1 + tabCellulePlaced(szP)%indice = 1 + tabCellulePlaced(szP)%xcenter = 0.d0 + tabCellulePlaced(szP)%ycenter = 0.d0 + tabCellulePlaced(szP)%turn = 1 + allocate (tabCellulePlaced(szP)%gig(1)) + tabCellulePlaced(szP)%gig = 1 + allocate (tabCellulePlaced(szP)%mrg(1)) + tabCellulePlaced(szP)%mrg = 1 + end if + end subroutine litDonneesSup + +end module cellulePlaced diff --git a/Dragon/src/g2s_constType.f90 b/Dragon/src/g2s_constType.f90 new file mode 100644 index 0000000..b9cae25 --- /dev/null +++ b/Dragon/src/g2s_constType.f90 @@ -0,0 +1,91 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Definition of parameter types used in Dragon. +! +!Copyright: +! Copyright (C) 2001 Ecole Polytechnique de Montreal. +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): +! G. Civario (CS-SI) +! +!----------------------------------------------------------------------- +! +module constType + implicit none + + !type of geometry (ST(1)) + integer,parameter :: G_Virtual=0 + integer,parameter :: G_Homoge=1 + integer,parameter :: G_Car1d=2 + integer,parameter :: G_Tube=3 + integer,parameter :: G_Car2d=5 + integer,parameter :: G_Hex=8 + integer,parameter :: G_Tri=13 + integer,parameter :: G_Carcel=20 + integer,parameter :: G_Hexcel=24 + integer,parameter :: G_Group=30 + + !type of sectorisation (ST(14)) + integer,parameter :: S_X_tot=-1 + integer,parameter :: S_not=0 + integer,parameter :: S_T_tot=1 !"T" = "+" + integer,parameter :: S_TX_tot=2 + integer,parameter :: S_TXS_tot=3 + integer,parameter :: S_WM_tot=4 + + !type of hexagonal symetry (IHEX) + integer,parameter :: H_S30=1 + integer,parameter :: H_SA60=2 + integer,parameter :: H_SB60=3 + integer,parameter :: H_S90=4 + integer,parameter :: H_R120=5 + integer,parameter :: H_R180=6 + integer,parameter :: H_SA180=7 + integer,parameter :: H_SB180=8 + integer,parameter :: H_Complete=9 + + !type of triangular symetry (ITRI) + integer,parameter :: T_S30=1 + integer,parameter :: T_SA60=2 + integer,parameter :: T_ST60=3 + integer,parameter :: T_Complete=4 + + !type of boundary condition (NCODE) + integer,parameter :: B_NotUsed=0 + integer,parameter :: B_Void=1 + integer,parameter :: B_Refl=2 + integer,parameter :: B_Diag=3 + integer,parameter :: B_Tran=4 + integer,parameter :: B_Syme=5 + integer,parameter :: B_Albe=6 + integer,parameter :: B_Zero=7 + integer,parameter :: B_Pi_2=8 + integer,parameter :: B_Pi=9 + integer,parameter :: B_Ssym=10 + + !type of rotation (TURN) + integer,parameter :: R_A=1 + integer,parameter :: R_B=2 + integer,parameter :: R_C=3 + integer,parameter :: R_D=4 + integer,parameter :: R_E=5 + integer,parameter :: R_F=6 + integer,parameter :: R_G=7 + integer,parameter :: R_H=8 !max for cartesian + integer,parameter :: R_I=9 + integer,parameter :: R_J=10 + integer,parameter :: R_K=11 + integer,parameter :: R_L=12 !max for hex and tri + + ! + type t_point + double precision :: x + double precision :: y + end type t_point +end module constType diff --git a/Dragon/src/g2s_constUtil.f90 b/Dragon/src/g2s_constUtil.f90 new file mode 100644 index 0000000..8f8d89e --- /dev/null +++ b/Dragon/src/g2s_constUtil.f90 @@ -0,0 +1,292 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Definition of parameter types used in G2S: module. +! +!Copyright: +! Copyright (C) 2001 Ecole Polytechnique de Montreal. +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): +! G. Civario (CS-SI) +! +!Comments: +! De plus, quelques fonctions utilitaires sont aussi definies, telles que : +! - isEqual : teste l'egalite a epsilon pres de deux doubles, et les egalise +! et si leur valeur est proche, les egalise a la moyenne des deux +! - isEqualConst : teste l'egalite a epsilon pres de deux doubles +! - isEqualAngl : teste l'egalite a epsilon pres de deux angles en les +! normalisant si besoin +! - isEqualConstAngl : teste l'egalite a epsilon pres de deux angles normaux +! - angleNormal : retourne la valeur de l'angle centree entre -Pi et Pi +! - distance : calcule la distance entre un point et une droite, et calcule +! les coordonnees de la projection du point sur la droite +! - longVect : calcule la norme d'un vecteur +! - calculeAngle : calcule l'angle d'un vecteur par rapport a Ox +! - estColli : teste la colinearite de deux vecteurs +! - pointsAlignes : teste l'alignement de trois points +! - estAGauche : teste si un point est a gauche d'une droite +! - estAGaucheStrict : teste si un point est strictement a gauche d'une droite +! - estADroite : teste si un point est a droite d'une droite +! - estADroiteStrict : teste si un point est strictement a droite d'une droite +! - isPi : teste l'egalite avec Pi d'un angle +! - estPaire : teste la parite d'un entier +! - isAngleInInterval : teste l'appartenance d'un angle a un domaine angulaire +! +!----------------------------------------------------------------------- +! +module constUtiles + implicit none + + double precision,parameter :: epsilon = 1.d-4 + double precision,parameter :: muleps1 = 5.d0 + double precision,parameter :: muleps2 = 2.d0 + double precision,parameter :: pi_c = 3.14159265358979d0 + double precision,parameter :: pi_2_c = 1.57079632679490d0 + double precision,parameter :: pi_3_c = 1.04719755119660d0 + double precision,parameter :: dpi_c = 6.28318530717959d0 !=2.*pi + double precision,parameter :: rad2deg = 5.72957795130823d1 !=180./pi + double precision,parameter :: deg2rad = 1.74532925199433d-2 !=pi/180. + double precision,parameter :: infinity = 1.d99 + double precision,parameter :: sqrt3_2d = 8.66025403784439d-1 !=sqrt(3)/2 + character*10,parameter :: formatr = '(1p,e18.7)' + character*5,parameter :: formati = '(i6)' + character*21,parameter :: formath = '(3x,4hMACR,i6.6,:,2x)' + real,parameter :: gSALeps = 1e-4 + + ! Numerical Constants + double precision, parameter :: dp_0 = 0.0d0 + double precision, parameter :: dp_1 = 1.0d0 + double precision, parameter :: dp_05 = 0.5d0 + +contains + + logical function isEqual(a,b) + double precision,intent(inout) :: a,b + isEqual = (abs(b-a)pi_c) angleNormal = angleNormal - dpi_c + end function angleNormal + + logical function isEqualConst(a,b) + double precision,intent(in) :: a,b + isEqualConst = (abs(b-a)0.d0).or.pointsAlignes(ox,oy,ex,ey,ptx,pty) + end function estAGauche + + function estAGaucheStrict(ox,oy,ex,ey,ptx,pty) + double precision,intent(in) :: ox,oy,ex,ey,ptx,pty + logical :: estAGaucheStrict + + double precision :: tmp + + tmp = sin(calculeAngle(ox,oy,ptx,pty)-calculeAngle(ox,oy,ex,ey)) + estAGaucheStrict=(tmp>0.d0).and.(.not.pointsAlignes(ox,oy,ex,ey,ptx,pty)) + end function estAGaucheStrict + + function estADroite(ox,oy,ex,ey,ptx,pty) + double precision,intent(in) :: ox,oy,ex,ey,ptx,pty + logical :: estADroite + + double precision :: tmp + + tmp = sin(calculeAngle(ox,oy,ptx,pty)-calculeAngle(ox,oy,ex,ey)) + estADroite=(tmp<0.d0).or.pointsAlignes(ox,oy,ex,ey,ptx,pty) + end function estADroite + + function estADroiteStrict(ox,oy,ex,ey,ptx,pty) + double precision,intent(in) :: ox,oy,ex,ey,ptx,pty + logical :: estADroiteStrict + + double precision :: tmp + + tmp = sin(calculeAngle(ox,oy,ptx,pty)-calculeAngle(ox,oy,ex,ey)) + estADroiteStrict=(tmp<0.d0).and.(.not.pointsAlignes(ox,oy,ex,ey,ptx,pty)) + end function estADroiteStrict + + function isPi(angl) + double precision,intent(in) :: angl + logical :: isPi + + isPi=isEqualConst(abs(angl),pi_c) + end function isPi + + logical function estPaire(n) + integer,intent(in) :: n + estPaire = ((n/2)*2==n) + end function estPaire + + function isAngleInInterval(a,o,e) + double precision,intent(in) :: a,o,e + integer :: isAngleInInterval + !dit si un angle est sur sur l'interval [o,e]: + ! 0 -> pas dessus, + ! 1 -> c'est l'origine, + ! 2 -> entre les deux, + ! 3 -> c'est l'extremite + double precision :: aa,oo,ee + aa = angleNormal(a) ; oo = angleNormal(o) ; ee = angleNormal(e) + if (isEqualConstAngl(oo,aa)) then + isAngleInInterval = 1 + else if (isEqualConstAngl(ee,aa)) then + isAngleInInterval = 3 + else if (oo creation de meshx, meshy et mix a partir des + !donnees d'entree + + lgx = size(inMeshx)-1 ; lgy = size(inMeshy)-1 + ldiag=(lgx == lgy).and.(lgx*(lgx+1)/2 == size(inMix)) + tmpSzx = sum(splitx(1:lgx)) ; tmpSzy = sum(splity(1:lgy)) ; smix = tmpSzx*tmpSzy + allocate(meshx(tmpSzx+1),meshy(tmpSzy+1),mix(smix),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: construit_car2d(1) => allocation pb") + + !sur x + meshx(1) = 0.d0 + ind = 1 + do i = 1,lgx + dd = (inMeshx(i+1)-inMeshx(i)) / splitx(i) + do j = 1,splitx(i)-1 + ind = ind + 1 + meshx(ind) = meshx(ind-1) + dd + end do + ind = ind + 1 + meshx(ind) = inMeshx(i+1) + end do + !sur y + meshy(1) = 0.d0 + ind = 1 + do i = 1,lgy + dd = (inMeshy(i+1)-inMeshy(i)) / splity(i) + do j = 1,splity(i)-1 + ind = ind + 1 + meshy(ind) = meshy(ind-1) + dd + end do + ind = ind + 1 + meshy(ind) = inMeshy(i+1) + end do + !mix + ! correction of plain CAR2D bug by Alain Hebert (May 2016) + if(ldiag) then + allocate(mixDiag(lgx*lgx),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: construit_car2d(2) => allocation pb") + ind = 0 + do j = 1,lgx + do i = j,lgx + ind=ind+1 + if(ind > size(inMix)) call XABORT('overflow1') + if(i+(j-1)*lgx > lgx*lgx) call XABORT('overflow2') + if(j+(i-1)*lgx > lgx*lgx) call XABORT('overflow3') + mixDiag(i+(j-1)*lgx)=inMix(ind) + mixDiag(j+(i-1)*lgx)=inMix(ind) + end do + end do + endif + ind = 1 + do j = 1,lgy + do i = 1,lgx + if(ldiag) then + mix(ind:ind+splitx(i)-1) = mixDiag(i+(j-1)*lgx) + else + mix(ind:ind+splitx(i)-1) = inMix(i+(j-1)*lgx) + endif + ind = ind + splitx(i) + end do + do i = 2,splity(j) + mix(ind:ind+tmpSzx-1) = mix(ind-tmpSzx:ind-1) + ind = ind + tmpSzx + end do + end do + if(ldiag) deallocate(mixDiag) + + !creation des tableaux de travail pour les abscisses, les ordonnees et les + !milieux, en fonction du turn (la construction des segments se faisant + !ensuite toujours de la meme maniere que pour un turn = 1 + if(mod(turn,2) == 0) then + ssx = sy ; ssy = sx ; dimx = tmpSzy ; dimy = tmpSzx + else + ssx = sx ; ssy = sy ; dimx = tmpSzx ; dimy = tmpSzy + end if + allocate(mmeshx(dimx+1),mmeshy(dimy+1),mmix(smix),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: construit_car2d(3) => allocation pb") + select case(turn) + case(1) + mmeshx(:dimx+1) = meshx(:dimx+1) ; mmeshy(:dimy+1) = meshy(:dimy+1) + mmix(:smix) = mix(:smix) + case(2) + mmeshx(:dimx+1) = meshy(:dimx+1) + do i = 1,dimy+1 + mmeshy(i) = 1.-meshx(dimy+2-i) + end do + mmix(:smix) = (/(mix(i:i+(dimx-1)*dimy:dimy),i=dimy,1,-1)/) + case(3) + do i = 1,dimx+1 + mmeshx(i) = 1.-meshx(dimx+2-i) + end do + do i = 1,dimy+1 + mmeshy(i) = 1.-meshy(dimy+2-i) + end do + mmix(:smix) = mix(dimx*dimy:1:-1) + case(4) + do i = 1,dimx+1 + mmeshx(i) = 1.-meshy(dimx+2-i) + end do + mmeshy(:dimy+1) = meshx(:dimy+1) + mmix(:smix) = (/(mix(i:i-(dimx-1)*dimy:-dimy),i=1+(dimx-1)*dimy,dimx*dimy,1)/) + case(5) + do i = 1,dimx+1 + mmeshx(i) = 1.-meshx(dimx+2-i) + end do + mmeshy(:dimy+1) = meshy(:dimy+1) + mmix(:smix) = (/(mix(i:i-(dimx-1):-1),i=dimx,dimx*dimy,dimx)/) + case(6) + mmeshx(:dimx+1) = meshy(:dimx+1) + mmeshy(:dimy+1) = meshx(:dimy+1) + mmix(:smix) = (/(mix(i:i+(dimx-1)*dimy:dimy),i=1,dimy,1)/) + case(7) + mmeshx(:dimx+1) = meshx(:dimx+1) + do i = 1,dimy+1 + mmeshy(i) = 1.-meshy(dimy+2-i) + end do + mmix(:smix) = (/(mix(i:i+(dimx-1):1),i=1+(dimy-1)*dimx,1,-dimx)/) + case(8) + do i = 1,dimx+1 + mmeshx(i) = 1.-meshy(dimx+2-i) + end do + do i = 1,dimy+1 + mmeshy(i) = 1.-meshx(dimy+2-i) + end do + mmix(:smix) = (/(mix(i:i-(dimx-1)*dimy:-dimy),i=dimx*dimy,1+(dimx-1)*dimy,-1)/) + end select + deallocate(meshx,meshy,mix) + + !construction des segments : + !elle se fait dans l'odre suivant: ... n-1 n + ! ----> ---->----> + ! .................... + ! 1 2 ... + ! ---->----> ----> + !puis: |. : |p + ! : |p-1 + ! |2 : + ! |1 : |. + !Remarque: on distingue le cas particulier des bords, pour l'attribution + !du milieux fooMix + xmin = cx-0.5d0*ssx + xmax = xmin+ssx + ymin = cy-0.5d0*ssy + ymax = ymin+ssy + do i=1,dimx + !cas particulier j=1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine construit_car2d (1)") + sg=createSeg(xmin+mmeshx(i)*ssx, ymin, xmin+mmeshx(i+1)*ssx, ymin , & + & mmix(i) , fooMix ) + tabSegArc(szSA)=sg + do j=2,dimy + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine construit_car2d (2)") + sg=createSeg(xmin+mmeshx(i)*ssx ,ymin+mmeshy(j)*ssy, & + & xmin+mmeshx(i+1)*ssx,ymin+mmeshy(j)*ssy, & + & mmix((j-1)*dimx+i) ,mmix((j-2)*dimx+i) ) + tabSegArc(szSA)=sg + end do + !cas particulier j=dimy+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine construit_car2d (3)") + + sg=createSeg(xmin+mmeshx(i)*ssx ,ymax , & + & xmin+mmeshx(i+1)*ssx,ymax , & + & fooMix ,mmix((dimy-1)*dimx+i)) + tabSegArc(szSA)=sg + end do + do j=1,dimy + !cas particulier i=1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine construit_car2d (4)") + sg=createSeg(xmin ,ymin+mmeshy(j)*ssy , & + & xmin ,ymin+mmeshy(j+1)*ssy , & + & fooMix ,mmix((j-1)*dimx+1) ) + tabSegArc(szSA)=sg + do i=2,dimx + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine construit_car2d (5)") + sg=createSeg(xmin+mmeshx(i)*ssx ,ymin+mmeshy(j)*ssy , & + & xmin+mmeshx(i)*ssx ,ymin+mmeshy(j+1)*ssy, & + & mmix((j-1)*dimx+i-1),mmix((j-1)*dimx+i) ) + tabSegArc(szSA)=sg + end do + !cas particulier i=dimx+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine construit_car2d (6)") + sg=createSeg(xmax ,ymin+mmeshy(j)*ssy , & + & xmax ,ymin+mmeshy(j+1)*ssy, & + & mmix(j*dimx),fooMix ) + tabSegArc(szSA)=sg + end do + deallocate(mmeshx,mmeshy,mmix) + !call PrintTabSegArc(szSA) + end subroutine construit_car2d + + subroutine construit_carcel(cx,cy,sx,sy,turn,radius,offcx,offcy, & + & splitx,splity,mix,sectori,sectorj,cluster,szSA) + double precision,intent(in) :: cx,cy,sx,sy,offcx,offcy + double precision,dimension(:),intent(in) :: radius + integer,intent(in) :: turn,sectori,sectorj + integer,dimension(:),intent(in) :: splitx,splity,mix + type(t_cluster),dimension(:),pointer :: cluster + integer,intent(inout) :: szSA + + integer :: i,j,keepSz,nbseg,tmp,nb + double precision :: ccx,ccy,d,dorig,dextr,tmpx,tmpy + double precision :: tgx, tgy + double precision :: pt1x,pt1y,pt2x,pt2y,ss,ssx,ssy + double precision,dimension(8) :: coef,coef2 + integer,dimension(:),allocatable :: tmpMix + type(t_segArc) :: sg,ar,tmpSg + double precision :: dist1, dist2 + + ! programmation defensive + integer :: dimtabSegArc + dimtabSegArc = size(tabSegArc) + keepSz=szSA + select case (turn) + case(1) ; ccx=cx+offcx ; ccy=cy+offcy + case(2) ; ccx=cx+offcy ; ccy=cy-offcx + case(3) ; ccx=cx-offcx ; ccy=cy-offcy + case(4) ; ccx=cx-offcy ; ccy=cy+offcx + case(5) ; ccx=cx-offcx ; ccy=cy+offcy + case(6) ; ccx=cx+offcy ; ccy=cy+offcx + case(7) ; ccx=cx+offcx ; ccy=cy-offcy + case(8) ; ccx=cx-offcy ; ccy=cy-offcx + end select + + if(mod(turn,2)==0) then ; ssx = sy ; ssy = sx + else ; ssx = sx ; ssy = sy ; end if + + !! creation du cadre + allocate(tmpMix(1)) + tmpMix(1) = mix(size(mix)) + call construit_car2d(cx,cy,sx,sy,turn,(/0.d0,1.d0/),(/0.d0,1.d0/), & + splitx,splity,tmpMix,szSA) + deallocate(tmpMix) + nbseg = 2*splitx(1)*splity(1) + splitx(1) + splity(1) + if(nbseg/=4 .and. sectori/=S_not) call XABORT("G2S: mixing SPLIT and SECT& + & not allowed") + + !! gestion des secteurs + ss = min(sx,sy) + if(sectori==s_not) then + !! rien + else if((sectori==S_X_tot)) then + tmp = mix(size(mix)) + coef = 0.5d0 * (/1.d0,-1.d0,-1.d0, 1.d0,& + 1.d0, 1.d0,-1.d0,-1.d0/) * ss + !! 2 1 + !! X + !! 3 4 + if (sectorj==0) then + do i = 1,4 + nbseg=nbseg+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine & + &construit_carcel (1)") + tmpSg = createSeg(cx,cy,cx+coef(i),cy+coef(i+4),tmp,tmp) + tmpSg%sectg = i + tmpSg%sectd = mod(i+2,4)+1 + tabSegArc(szSA) = tmpSg + end do + else + ar = createArc(ccx,ccy,radius(sectorj+1),0.d0,0.d0,tmp,tmp) + do i = 1,4 + sg = createSeg(cx,cy,cx+coef(i),cy+coef(i+4),tmp,tmp) + nb = abs(interSgAr(sg,ar,pt1x,pt1y,pt2x,pt2y)) + if(nb==1) then + if(.not.(isEqualConst(pt1x,cx+coef(i)).and. & + isEqualConst(pt1y,cy+coef(i+4)))) then + nbseg=nbseg+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine & + &construit_carcel (1)") + tmpSg = createSeg(pt1x,pt1y,cx+coef(i),cy+coef(i+4),tmp,tmp) + tmpSg%sectg = i + tmpSg%sectd = mod(i+2,4)+1 + tabSegArc(szSA) = tmpSg + end if + else if(nb==2) then + if(.not.(isEqualConst(pt2x,cx+coef(i)).and. & + isEqualConst(pt2y,cy+coef(i+4)))) then + nbseg=nbseg+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine & + &construit_carcel (3)") + tmpSg = createSeg(pt2x,pt2y,cx+coef(i),cy+coef(i+4),tmp,tmp) + tmpSg%sectg = i + tmpSg%sectd = mod(i+2,4)+1 + tabSegArc(szSA) = tmpSg + end if + end if + end do + end if + else if(sectori==S_T_tot) then + tmp=mix(size(mix)) + coef=0.5d0*(/ ssx,0.d0,-ssx,0.d0,& + 0.d0, ssy,0.d0,-ssy/) + !! 2 + !! 3+1 + !! 4 + if (sectorj==0) then + do i = 1,4 + nbseg=nbseg+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine & + &construit_carcel (4)") + tmpSg = createSeg(cx,cy,cx+coef(i),cy+coef(i+4),tmp,tmp) + tmpSg%sectg = i + tmpSg%sectd = mod(i+2,4)+1 + tabSegArc(szSA) = tmpSg + end do + else + ar = createArc(ccx,ccy,radius(sectorj+1),0.d0,0.d0,tmp,tmp) + do i = 1,4 + sg = createSeg(cx,cy,cx+coef(i),cy+coef(i+4),tmp,tmp) + nb = abs(interSgAr(sg,ar,pt1x,pt1y,pt2x,pt2y)) + if(nb==1) then + if(.not.(isEqualConst(pt1x,cx+coef(i)).and. & + isEqualConst(pt1y,cy+coef(i+4)))) then + nbseg=nbseg+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine & + &construit_carcel (5)") + szSA=szSA+1 + tmpSg = createSeg(pt1x,pt1y,cx+coef(i),cy+coef(i+4),tmp,tmp) + tmpSg%sectg = i + tmpSg%sectd = mod(i+2,4)+1 + tabSegArc(szSA) = tmpSg + end if + else if(nb==2) then + if(.not.(isEqualConst(pt2x,cx+coef(i)).and. & + isEqualConst(pt2y,cy+coef(i+4)))) then + nbseg=nbseg+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine & + &construit_carcel (6)") + tmpSg = createSeg(pt2x,pt2y,cx+coef(i),cy+coef(i+4),tmp,tmp) + tmpSg%sectg = i + tmpSg%sectd = mod(i+2,4)+1 + tabSegArc(szSA) = tmpSg + end if + end if + end do + end if + else if(sectori==S_TX_tot) then + tmp=mix(size(mix)) + coef = 0.5d0 * (/ ssx,ss,0.d0,-ss,-ssx,-ss,0.d0, ss/) + coef2 = 0.5d0 * (/0.d0,ss, ssy, ss,0.d0,-ss,-ssy,-ss/) + !! 432 + !! 5*1 + !! 678 + if (sectorj==0) then + do i = 1,8 + nbseg=nbseg+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine & + &construit_carcel (7)") + tmpSg = createSeg(cx,cy,cx+coef(i),cy+coef2(i),tmp,tmp) + tmpSg%sectg = i + tmpSg%sectd = mod(i+6,8)+1 + tabSegArc(szSA) = tmpSg + end do + else + ar = createArc(ccx,ccy,radius(sectorj+1),0.d0,0.d0,tmp,tmp) + do i = 1,8 + sg = createSeg(cx,cy,cx+coef(i),cy+coef2(i),tmp,tmp) + nb = abs(interSgAr(sg,ar,pt1x,pt1y,pt2x,pt2y)) + if(nb==1) then + if(.not.(isEqualConst(pt1x,cx+coef(i)).and. & + isEqualConst(pt1y,cy+coef2(i)))) then + nbseg=nbseg+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine & + &construit_carcel (7)") + tmpSg = createSeg(pt1x,pt1y,cx+coef(i),cy+coef2(i),tmp,tmp) + tmpSg%sectg = i + tmpSg%sectd = mod(i+6,8)+1 + tabSegArc(szSA) = tmpSg + end if + else if(nb==2) then + if(.not.(isEqualConst(pt2x,cx+coef(i)).and. & + isEqualConst(pt2y,cy+coef2(i)))) then + nbseg=nbseg+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine & + &construit_carcel (8)") + tmpSg = createSeg(pt2x,pt2y,cx+coef(i),cy+coef2(i),tmp,tmp) + tmpSg%sectg = i + tmpSg%sectd = mod(i+6,8)+1 + tabSegArc(szSA) = tmpSg + end if + end if + end do + end if + elseif (sectori == S_TXS_tot) then + tgx = ssx * tg + tgy = ssy * tg + tmp = mix(size(mix)) + coef = 0.5d0 *(/ ssx, tgy, -tgy, -ssx, -ssx, -tgy, tgy, ssx /) + coef2 = 0.5d0 *(/ tgx, ssy, ssy, tgx, -tgx, -ssy, -ssy, -tgx /) + if (sectorj==0) then + do i = 1,8 + nbseg=nbseg+1 ! + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine & + &construit_carcel (9)") + tmpSg = createSeg(cx,cy,cx+coef(i),cy+coef2(i),tmp,tmp) + tmpSg%sectg = i + tmpSg%sectd = mod(i+6,8)+1 + tabSegArc(szSA) = tmpSg + end do + else + ar = createArc(ccx,ccy,radius(sectorj+1),0.d0,0.d0,tmp,tmp) + do i = 1,8 + sg = createSeg(cx,cy,cx+coef(i),cy+coef2(i),tmp,tmp) + nb = abs(interSgAr(sg,ar,pt1x,pt1y,pt2x,pt2y)) + if(nb==1) then + if(.not.(isEqualConst(pt1x,cx+coef(i)).and. & + isEqualConst(pt1y,cy+coef2(i)))) then + nbseg=nbseg+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine & + &construit_carcel (10)") + tmpSg = createSeg(pt1x,pt1y,cx+coef(i),cy+coef2(i),tmp,tmp) + tmpSg%sectg = i + tmpSg%sectd = mod(i+6,8)+1 + tabSegArc(szSA) = tmpSg + end if + else if(nb==2) then + if(.not.(isEqualConst(pt2x,cx+coef(i)).and. & + isEqualConst(pt2y,cy+coef2(i)))) then + nbseg=nbseg+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine& + & construit_carcel (11)") + tmpSg = createSeg(pt2x,pt2y,cx+coef(i),cy+coef2(i),tmp,tmp) + tmpSg%sectg = i + tmpSg%sectd = mod(i+6,8)+1 + tabSegArc(szSA) = tmpSg + end if + end if + end do + end if + elseif (sectori == S_WM_tot) then + tgx = ssx * tg + tgy = ssy * tg + tmp = mix(size(mix)) + coef = 0.5d0 *(/ ssx, tgy, -tgy, -ssx, -ssx, -tgy, tgy, ssx /) + coef2 = 0.5d0 *(/ tgx, ssy, ssy, tgx, -tgx, -ssy, -ssy, -tgx /) + if (sectorj==0) then + do i = 1,8 + nbseg=nbseg+1 ! + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine & + &construit_carcel (12)") + tmpSg = createSeg(cx,cy,cx+coef(i),cy+coef2(i),tmp,tmp) + tmpSg%sectg = i + tmpSg%sectd = mod(i+6,8)+1 + tabSegArc(szSA) = tmpSg + end do + do i = 1, 4 + nbseg=nbseg+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine & + &construit_carcel (13)") + tmpSg = createSeg(cx+coef(2*i-1),cy+coef2(2*i-1),cx+coef(2*i),cy+coef2(2*i),tmp,tmp) + tmpSg%sectg=i + tmpSg%sectd= mod(i+6,8)+1 + tabSegArc(szSA) = tmpSg + enddo + else + ar = createArc(ccx,ccy,radius(sectorj+1),0.d0,0.d0,tmp,tmp) + do i = 1,8 + sg = createSeg(cx,cy,cx+coef(i),cy+coef2(i),tmp,tmp) + nb = abs(interSgAr(sg,ar,pt1x,pt1y,pt2x,pt2y)) + if(nb==1) then + if(.not.(isEqualConst(pt1x,cx+coef(i)).and. & + isEqualConst(pt1y,cy+coef2(i)))) then + nbseg=nbseg+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine & + &construit_carcel (14)") + tmpSg = createSeg(pt1x,pt1y,cx+coef(i),cy+coef2(i),tmp,tmp) + tmpSg%sectg = i + tmpSg%sectd = mod(i+6,8)+1 + tabSegArc(szSA) = tmpSg + end if + else if(nb==2) then + if(.not.(isEqualConst(pt2x,cx+coef(i)).and. & + isEqualConst(pt2y,cy+coef2(i)))) then + nbseg=nbseg+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine & + &construit_carcel (15)") + tmpSg = createSeg(pt2x,pt2y,cx+coef(i),cy+coef2(i),tmp,tmp) + tmpSg%sectg = i + tmpSg%sectd = mod(i+6,8)+1 + tabSegArc(szSA) = tmpSg + end if + end if + end do + ! creation des 4 segments fermant les ailes + do i = 1, 4 + pt1x = coef(2*i-1)+cx + pt1y = coef2(2*i-1)+cy + pt2x = coef(2*i)+cx + pt2y = coef2(2*i)+cy + dist1 = (pt1x-ccx)*(pt1x-ccx)+(pt1y-ccy)*(pt1y-ccy) + dist2 = (pt2x-ccx)*(pt2x-ccx)+(pt2y-ccy)*(pt2y-ccy) + + if (sqrt(dist1)>radius(sectorj+1).and.sqrt(dist2)>radius(sectorj)) then + nbseg=nbseg+1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine & + &construit_carcel (16)") + tmpSg = createSeg(cx+coef(2*i-1),cy+coef2(2*i-1),cx+coef(2*i),cy+coef2(2*i),tmp,tmp) + !tmpSg%sectg=i + !tmpSg%sectd= mod(i+6,8)+1 + tmpSg%sectg=mod(2*i+5,8)+1 + tmpSg%sectd=2*i + tabSegArc(szSA) = tmpSg + else + call XABORT("G2S : Intersection troubles with WindMill") + endif + enddo + end if + else + call XABORT("G2S : type of sectorisation not recognised") + endif + + !prise en compte des milieux pour un segment completement a l'interieur + !d'une zone annulaire (ie non coupe) + ! CS-IV : La boucle s'applique sur les nbseg derniers segments crees + ! CS-IV : ie sur les segments que l'on vient de faire (nbseg et szSA sont + ! CS-IV : incrementes de la meme facon mais le premier part de 0 alors que + ! CS-IV : part du nombre de SA deja crees. + ! CS-IV : donc le commentaire d'origine est faux, et devrait etre : + ! CS-IV : Prise en compte des milieux pour les segments crees. + do i = 0,nbseg-1 + sg = tabSegArc(szSA-i) + d = distance(ccx,ccy,sg%x,sg%y,sg%dx,sg%dy,tmpx,tmpy) + tmpx=ccx-sg%x ; tmpy=ccy-sg%y ; dorig = sqrt((tmpx*tmpx)+(tmpy*tmpy)) + tmpx=ccx-sg%dx ; tmpy=ccy-sg%dy ; dextr = sqrt((tmpx*tmpx)+(tmpy*tmpy)) + do j = 1,size(radius)-1 + if((min(d,dorig,dextr)+epsilon>radius(j)).and. & + & (max(d,dorig,dextr)-epsilon dimTabSegArc)& + call XABORT("G2S: memory problem in routine construit_hexhom (1)") + tmpSg = createSeg(xx(i),yy(i),xx(i+1),yy(i+1),mix,fooMix) + tabSegArc(szSA) = tmpSg + end do + if(sectori==S_X_tot) then + do i = 1,6 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine construit_hexhom (2)") + tmpSg = createSeg(cx,cy,xx(i),yy(i),mix,mix) + tmpSg%sectg = sect(i+1) + tmpSg%sectd = sect(i) + tabSegArc(szSA) = tmpSg + end do + else if(sectori/=S_not) then + call XABORT("G2S : type of sectorisation not recognised for & + &homogeneous hexagonal geometry") + endif + end subroutine construit_hexhom + + subroutine construit_hex(cx,cy,sd,mix,szSA,sectori,sectorj,radius,ocx,ocy) + double precision,intent(in) :: cx,cy,sd + integer,intent(in) :: mix + integer,intent(inout) :: szSA + integer,intent(in) :: sectori,sectorj + double precision,dimension(:),intent(in) :: radius + double precision,intent(in) :: ocx,ocy + + double precision,dimension(7) :: xx,yy + double precision :: sqrt3_2S,S_2 + double precision :: pt1x,pt1y,pt2x,pt2y + integer :: i,nb + integer,parameter,dimension(7) :: sect=(/1,2,3,4,5,6,1/) + type(t_segArc) :: sg,ar,tmpSg + + ! programmation defensive + integer :: dimtabSegArc + dimtabSegArc = size(tabSegArc) + + S_2=5.d-1*sd ; sqrt3_2S=S_2*sqrt(3.d0) + xx(1) = cx + S_2 ; yy(1) = cy + sqrt3_2S + xx(2) = cx - S_2 ; yy(2) = yy(1) + xx(3) = cx - sd ; yy(3) = cy + xx(4) = xx(2) ; yy(4) = cy - sqrt3_2S + xx(5) = xx(1) ; yy(5) = yy(4) + xx(6) = cx + sd ; yy(6) = cy + xx(7) = xx(1) ; yy(7) = yy(1) + do i = 1,6 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine construit_hex (1)") + tmpSg = createSeg(xx(i),yy(i),xx(i+1),yy(i+1),mix,fooMix) + tabSegArc(szSA) = tmpSg + end do + if (sectori==S_X_tot) then + if (sectorj==0) then + do i = 1,6 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine construit_hex (2)") + tmpSg = createSeg(cx,cy,xx(i),yy(i),mix,mix) + tmpSg%sectg = sect(i+1) + tmpSg%sectd = sect(i) + tabSegArc(szSA) = tmpSg + end do + else + ! creation du + grand cercle impermeable a la sectorisation + ar = createArc(ocx,ocy,radius(sectorj+1),0.d0,0.d0,mix,mix) + do i = 1,6 + sg=createSeg(cx,cy,xx(i),yy(i),mix,mix) + nb=interSgAr(sg,ar,pt1x,pt1y,pt2x,pt2y) + select case(nb) + case(-1) + if(.not.(isEqualConst(pt1x,xx(i)).and. & + isEqualConst(pt1y,yy(i)))) then + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine & + &construit_hex (3)") + tmpSg = createSeg(pt1x,pt1y,xx(i),yy(i),mix,mix) + tmpSg%sectg = sect(i+1) + tmpSg%sectd = sect(i) + tabSegArc(szSA) = tmpSg + end if + case(0) + if(.not.(isEqualConst(cx,xx(i)).and.isEqualConst(cy,yy(i)))) then + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine & + &construit_hex (4)") + tmpSg = createSeg(cx,cy,xx(i),yy(i),mix,mix) + tmpSg%sectg = sect(i+1) + tmpSg%sectd = sect(i) + tabSegArc(szSA) = tmpSg + end if + case(1) + if(.not.(isEqualConst(cx,pt1x).and.isEqualConst(cy,pt1y))) then + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine & + &construit_hex (5)") + tmpSg = createSeg(cx,cy,pt1x,pt1y,mix,mix) + tmpSg%sectg = sect(i+1) + tmpSg%sectd = sect(i) + tabSegArc(szSA) = tmpSg + end if + case(2) + if(.not.(isEqualConst(cx,pt1x).and.isEqualConst(cy,pt1y))) then + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine & + &construit_hex (6)") + tmpSg = createSeg(cx,cy,pt1x,pt1y,mix,mix) + tmpSg%sectg = sect(i+1) + tmpSg%sectd = sect(i) + tabSegArc(szSA) = tmpSg + end if + if(.not.(isEqualConst(pt2x,xx(i)).and. & + isEqualConst(pt2y,yy(i)))) then + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine & + &construit_hex (7)") + tmpSg = createSeg(pt2x,pt2y,xx(i),yy(i),mix,mix) + tmpSg%sectg = sect(i+1) + tmpSg%sectd = sect(i) + tabSegArc(szSA) = tmpSg + end if + end select + end do + endif + else if(sectori/=S_not) then + call XABORT("G2S : type of sectorisation not recognised for & + &hexagonal pincell geometry") + endif + end subroutine construit_hex + + subroutine construit_hexcel(cx,cy,sd,turn,radius,offcx,offcy, & + & mix,secori,secorj,cluster,szSA) + double precision,intent(in) :: cx,cy,sd,offcx,offcy + double precision,dimension(:),intent(in) :: radius + integer,intent(in) :: turn,secori,secorj + integer,dimension(:) :: mix + type(t_cluster),dimension(:),pointer :: cluster + integer,intent(inout) :: szSA + + integer :: i,j,keepSz,nbseg + double precision :: tocx,tocy,tpi_3,costp,sintp + double precision :: d,tmpx,tmpy,dorig,dextr + type(t_segArc) :: sg + + keepSz=szSA + if(turn<=6) then + tpi_3=(turn-1)*pi_3_c ; costp=cos(tpi_3) ; sintp=sin(tpi_3) + tocx = cx + costp*offcx - sintp*offcy + tocy = cy + sintp*offcx + costp*offcy + else + tpi_3=(12-turn)*pi_3_c ; costp=cos(tpi_3) ; sintp=sin(tpi_3) + tocx = cx + costp*offcx - sintp*offcy + tocy = cy - sintp*offcx - costp*offcy + end if + call construit_hex(cx,cy,sd,mix(size(mix)),szSA,secori,secorj,radius,tocx,tocy) + !prise en compte des milieux pour un segement completement a l'interieur + !d'une zone annulaire (ie non coupee) + do i = 0,szSA-keepSz-1 + sg = tabSegArc(szSA-i) + d = distance(tocx,tocy,sg%x,sg%y,sg%dx,sg%dy,tmpx,tmpy) + tmpx=tocx-sg%x ; tmpy=tocy-sg%y ; dorig=sqrt((tmpx*tmpx)+(tmpy*tmpy)) + tmpx=tocx-sg%dx ; tmpy=tocy-sg%dy ; dextr=sqrt((tmpx*tmpx)+(tmpy*tmpy)) + do j = 2,size(radius)-1 + if((min(d,dorig,dextr)>radius(j)).and. & + & (max(d,dorig,dextr) dimTabSegArc)& + call XABORT("G2S: memory problem in routine construit_tri2d (1)") + sg = createSeg(xx(1),yy(1),xx(3),yy(1),mix(1),fooMix) + tabSegArc(szSA) = translateAndTurnTriSg(cx,cy,turn,sg) + if(split/=1) then + ! 2 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine construit_tri2d (2)") + sg = createSeg(xx(3),yy(1),xx(2),yy(2),mix(1),mix(2)) + tabSegArc(szSA)=translateAndTurnTriSg(cx,cy,turn,sg) + end if + ! 3 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine construit_tri2d (3)") + sg = createSeg(xx(2),yy(2),xx(1),yy(1),mix(1),fooMix) + tabSegArc(szSA)=translateAndTurnTriSg(cx,cy,turn,sg) + ! Triangles de milieu de ligne + do i = 2,split-1 + ! 1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine construit_tri2d (4)") + sg = createSeg(xx(2*i-1),yy(1),xx(2*i+1),yy(1),mix(2*i-1),fooMix) + tabSegArc(szSA)=translateAndTurnTriSg(cx,cy,turn,sg) + ! 2 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine construit_tri2d (5)") + sg = createSeg(xx(2*i+1),yy(1),xx(2*i),yy(2),mix(2*i-1),mix(2*i)) + tabSegArc(szSA) = translateAndTurnTriSg(cx,cy,turn,sg) + ! 3 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine construit_tri2d (6)") + sg = createSeg(xx(2*i),yy(2),xx(2*i-1),yy(1),mix(2*i-1),mix(2*i-2)) + tabSegArc(szSA) = translateAndTurnTriSg(cx,cy,turn,sg) + end do + ! Triangle de fin de ligne + if(split/=1) then + ! 1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine construit_tri2d (7)") + sg = createSeg(xx(dimx-2),yy(1),xx(dimx),yy(1),mix(2*split-1),fooMix) + tabSegArc(szSA)=translateAndTurnTriSg(cx,cy,turn,sg) + end if + ! 2 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine construit_tri2d (8)") + sg = createSeg(xx(dimx),yy(1),xx(dimx-1),yy(2),mix(2*split-1),fooMix) + tabSegArc(szSA)=translateAndTurnTriSg(cx,cy,turn,sg) + if(split/=1) then + ! 3 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine construit_tri2d (9)") + sg = createSeg(xx(dimx-1),yy(2),xx(dimx-2),yy(1),mix(2*split-1), & + & mix(2*split-2)) + tabSegArc(szSA)=translateAndTurnTriSg(cx,cy,turn,sg) + end if + + !Autres lignes + indMix = 2*split+1 + do j = 2,split + k = j + indMix = indMix - 1 + deltaIndMix = 2*(split-j+1) + do i = 1,dimy-j + ! 1 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine construit_tri2d (10)") + sg = createSeg(xx(k),yy(j),xx(k+2),yy(j), & + & mix(indMix),mix(indMix-deltaIndMix)) + tabSegArc(szSA)=translateAndTurnTriSg(cx,cy,turn,sg) + ! 2 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine construit_tri2d (11)") + if(i==dimy-j) then + sg = createSeg(xx(k+2),yy(j),xx(k+1),yy(j+1), & + & mix(indMix),fooMix) + else + sg = createSeg(xx(k+2),yy(j),xx(k+1),yy(j+1), & + & mix(indMix),mix(indMix+1)) + end if + tabSegArc(szSA)=translateAndTurnTriSg(cx,cy,turn,sg) + ! 3 + szSA=szSA+1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine construit_tri2d (12)") + if(i==1) then + sg = createSeg(xx(k+1),yy(j+1),xx(k),yy(j), & + & mix(indMix),fooMix) + else + sg = createSeg(xx(k+1),yy(j+1),xx(k),yy(j), & + & mix(indMix),mix(indMix-1)) + end if + tabSegArc(szSA)=translateAndTurnTriSg(cx,cy,turn,sg) + k = k + 2 + indMix = indMix + 2 + end do + end do + ! CS-IV : F_C_2 deallocate(xx,yy) + end subroutine construit_tri2d + + subroutine construit_tube(cx,cy,radius,mix,cluster,szSA) + double precision,intent(in) :: cx,cy + double precision,dimension(:),intent(in) :: radius + integer,dimension(:), intent(in) :: mix + type(t_cluster),dimension(:),pointer :: cluster + integer,intent(inout) :: szSA + + integer :: i,j,k,sr,sc,nbp,keepSize,nbRing,nbClus,merge + double precision :: ccx,ccy,alpha + type(t_segArc) :: ce + integer,dimension(:),allocatable :: lastMix + + ! programmation defensive + integer :: dimtabSegArc + dimtabSegArc = size(tabSegArc) + + keepSize = szSa + + !anneaux + sr = size(radius) + do i = 2,sr + szSa = szSa + 1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine construit_tube (1)") + ce = createArc(cx,cy,radius(i),0.d0,0.d0,mix(i-1),mix(i)) + tabSegArc(szSa) = ce + end do + + nbRing = szSa - keepSize + keepSize = szSa + + merge = size(mix) !servira a identifier les milieux dans les clusters + !clusters + if(.not. associated(cluster)) return !pas de cluster + sc = size(cluster) + if(sc==0) return !pas de cluster + ! calcul du milieux exterieur de chaque cluster + allocate(lastMix(sc)) + do i = 1,sc + lastMix(i) = fooMix + do j = 2,sr + if(cluster(i)%radiusOfPin < radius(j)) then + lastMix(i) = mix(j-1) + exit + end if + end do + end do + ! creation des clusters par rayon croissant (pour que les cercles + ! de rayon max rencontrent les anneaux en premier car la recopie + ! inverse l'ordre) + do i = 1,sc + sr = size(cluster(i)%radius) + nbp = cluster(i)%nbrPin + do j = 1,nbp + ! write(*,*) 'offset cluster ',j,' : ',cluster(i)%angleOfPin + ! alpha = deg2rad*cluster(i)%angleOfPin + (j-1)*dpi_c/nbp + alpha = cluster(i)%angleOfPin + (j-1)*dpi_c/nbp + ccx = cx + cluster(i)%radiusOfPin * cos(alpha) + ccy = cy + cluster(i)%radiusOfPin * sin(alpha) + !tous les cercles sauf le dernier + do k = 1,sr-2 + szSa = szSa + 1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine construit_tube (2)") + ce = createArc(ccx,ccy,cluster(i)%radius(k+1),0.d0,0.d0, & + merge+k,merge+k+1) + tabSegArc(szSa) = ce + end do + !cercle le plus grand + szSa = szSa + 1 + ! programmation defensive + if (szSA > dimTabSegArc)& + call XABORT("G2S: memory problem in routine construit_tube (3)") + ce = createArc(ccx,ccy,cluster(i)%radius(sr),0.d0,0.d0, & + merge+sr-1,lastMix(i)) + tabSegArc(szSa) = ce + end do + merge = merge + sr - 1 + end do + deallocate(lastMix) + + nbClus = szSa - keepSize + !coupage des anneaux par les clusters + if(nbRing>0) call cutClusters(nbRing,nbClus,szSa) + end subroutine construit_tube + +end module construire diff --git a/Dragon/src/g2s_convert.f90 b/Dragon/src/g2s_convert.f90 new file mode 100644 index 0000000..c8f1fe9 --- /dev/null +++ b/Dragon/src/g2s_convert.f90 @@ -0,0 +1,530 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Convert an Alamos surfacic file towards Salomon format. +! +!Copyright: +! Copyright (C) 2022 Ecole Polytechnique de Montreal. +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): +! A. Hebert +! +!Parameters: input +! ipAl Alamos ascii file index +! +!Parameters: output +! ipSal Salomon ascii file index +! +!----------------------------------------------------------------------- +! +subroutine g2s_convert(impx,ipAl,ipZa,ipSal) + use constUtiles + use segArc + ! typgeo type of geometry (0: TISO tracking; 5: rectangle TRAN; + ! 6: rectangle REFL; 7: eight;8: SA60; 9: hexagon; 10: RA60; + ! 11: R120) + integer,intent(in) :: impx,ipAl,ipZa,ipSal + + ! local variables + integer :: i, j, k, nbfold, defautCl, nangles, saltype, idummy + double precision :: aStart, bStart, rStart, anglStart, aEnd, bEnd, rEnd, anglEnd, & + & radius, angle, angle0, dx, dy, dx0, dy0, r_xmin, r_xmax, & + & r_ymin, r_ymax + character(len=4) :: strDCL + character(len=12) :: text12, name_geom + character(len=40) :: text40 + character(len=131) :: hsmg + integer, allocatable, dimension(:) :: nber,merg,milTab,milTab2,iper + integer, allocatable, dimension(:,:) :: bcElems,iboundary + double precision, allocatable, dimension(:) :: ccx,ccy,ttx,tty + double precision, allocatable, dimension(:,:) :: apnodes + character(len=24), allocatable, dimension(:) :: propertyNames,mixNames,mixNames2 + type(t_segArc) :: sa + double precision, allocatable, dimension(:) :: list_angles + ! + ! set angles + nangles=-99 + if(typgeo == 0) then + nangles=0 + else if((abs(typgeo) == 5).or.(abs(typgeo) == 6).or.(abs(typgeo) == 11)) then + nangles=4 + else if((abs(typgeo) == 7).or.(abs(typgeo) == 8).or.(abs(typgeo) == 10)) then + nangles=3 + else if(abs(typgeo) == 9) then + nangles=6 + else + write(hsmg,'(35hg2s_convert: invalid symmetry type=,i3,1h.)') typgeo + call XABORT(hsmg) + endif + allocate(list_angles(nangles)) + if((abs(typgeo) == 5).or.(abs(typgeo) == 6)) then + list_angles=(/ 0.0, 0.0, 90.0, 90.0 /) + else if(abs(typgeo) == 7) then + list_angles=(/ 0.0, 45.0, 90.0 /) + else if((abs(typgeo) == 8).or.(abs(typgeo) == 10)) then + list_angles=(/ 0.0, 60.0, 120.0 /) + else if(abs(typgeo) == 9) then + list_angles=(/ 0.0, 120.0, 60.0, 0.0, 120.0, 60.0 /) + else if(abs(typgeo) == 11) then + list_angles=(/ 0.0, 0.0, 60.0, 60.0 /) + endif + + ! ---------------------------------- + ! Read the Alamos surfacic file + ! ---------------------------------- + read(ipAl,'(a12,a24)',end=100) text12,name_geom + 10 read(ipAl,'(a12,a24)',end=100) text12,name_geom + if (text12 /= ' Geometrie:') go to 10 + 20 read(ipAl,'(a12)',end=100) text12 + if (text12 /= ' Milieux:') go to 20 + read(ipAl,"(i7)",advance='no') nbmil + allocate(mixNames(nbmil)) + read(ipAl,*) mixNames(:) + 30 read(ipAl,'(a12)',end=100) text12 + if (text12 /= ' Mailles:') go to 30 + read(ipAl,"(i7)") nbNode + allocate(milTab(nbNode),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT('g2s_convert: allocation problem.') + read(ipAl,'(10i7)',end=100) milTab(:) + nbFlux=nbNode + if(ipZa /= -1) then + ! ---------------------------------- + ! Read the PropertyMap file + ! ---------------------------------- + allocate(mixNames2(nbNode),milTab2(nbNode),propertyNames(nbNode),iper(nbNode),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT('g2s_convert: allocation problem.') + 40 read(ipZa,'(a12,a24)',end=110) text12 + if (text12 /= 'PropertyMap:') go to 40 + read(ipZA,*) propertyNames(:) + nbmil=0 + loop1: do i=1,nbNode + do j=1,nbmil + if(propertyNames(i) == mixNames2(j)) then + milTab2(i)=j; cycle loop1 + endif + enddo + nbmil=nbmil+1 + mixNames2(nbmil)=propertyNames(i) + milTab2(i)=nbmil + iper(nbmil)=milTab(i) + enddo loop1 + write(6,'(1x,a)') name_geom + do i=1,nbmil + write(6,'(1x,i5,2x,a,4h--> ,a)') i,mixNames2(i),mixNames(iper(i)) + enddo + deallocate(mixNames); allocate(mixNames(nbmil)) + milTab(:nbNode)=milTab2(:nbNode); mixNames(:nbmil)=mixNames2(:nbmil) + deallocate(iper,propertyNames,milTab2,mixNames2) + else + write(6,'(1x,a)') name_geom + do i=1,nbmil + write(6,'(1x,i5,2x,a)') i,mixNames(i) + enddo + endif + if(impx > 1) then + write(6,'(5h--cut,75(1h-))') + i=1 + do j=1,1+(nbmil-1)/4 + write(text40,'(15h(10h INTEGER ,,i1,12h(a,1x),2h:=,,i1,8hi5,2h ;))') & + & min(i+3,nbmil)-i+1,min(i+3,nbmil)-i+1 + write(6,text40) (trim(mixNames(k)),k=i,min(i+3,nbmil)),(k,k=i,min(i+3,nbmil)) + i=i+4 + enddo + write(6,'(5h--cut,75(1h-))') + endif + deallocate(mixNames) + + ! read surfacic elements + rewind(ipAl) + 50 read(ipAl,'(a12)',end=100) text12 + if (text12 /= ' Noeuds:') go to 50 + read(ipAl,'(i7)') nbPoints + allocate(apnodes(2,nbPoints)) + r_xmin=999.0 + r_ymin=999.0 + do i=1,nbPoints + if((abs(typgeo) == 8).or.(abs(typgeo) == 10).or.(abs(typgeo) == 11)) then + read(ipAl,*,end=100) apnodes(2,i),apnodes(1,i) + apnodes(2,i)=-apnodes(2,i) ! rotate Alamos geometry by 90 degres + else + read(ipAl,*,end=100) apnodes(1,i),apnodes(2,i) + endif + r_xmin=min(r_xmin,apnodes(1,i)) + r_ymin=min(r_ymin,apnodes(2,i)) + enddo + do i=1,nbPoints + apnodes(1,i)=apnodes(1,i)-r_xmin + apnodes(2,i)=apnodes(2,i)-r_ymin + enddo + r_xmin=999.0 + r_xmax=-999.0 + r_ymin=999.0 + r_ymax=-999.0 + do i=1,nbPoints + r_xmin=min(r_xmin,apnodes(1,i)) + r_ymin=min(r_ymin,apnodes(2,i)) + r_xmax=max(r_xmax,apnodes(1,i)) + r_ymax=max(r_ymax,apnodes(2,i)) + enddo + basex=real(r_xmax-r_xmin) + basey=real(r_ymax-r_ymin) + + ! compute boundary elements characteristics + if(abs(typgeo) > 0) then + allocate(ttx(nangles),tty(nangles),ccx(nangles),ccy(nangles)) + if(abs(typgeo) == 9) basex=basex/2.0 + if(abs(typgeo) == 11) basex=2.0*basex/3.0 + do i = 1,nangles + ccx(i)=0.0 ; ccy(i)=0.0 ; ttx(i)=0.0 ; tty(i)=0.0 + if((abs(typgeo) == 5).or.(abs(typgeo) == 6)) then + select case(i) + case(2) + ccy(i)=basey + case(4) + ccx(i)=basex + end select + else if((abs(typgeo) == 7).or.(abs(typgeo) == 8).or.(abs(typgeo) == 10)) then + select case(i) + case(3) + ccx(i)=basex + end select + else if(abs(typgeo) == 9) then + select case(i) + case(1:2) + ccx(i)=basex/2.0 + case(3) + ccy(i)=basex*sqrt(0.75) + case(4) + ccx(i)=basex/2.0 + ccy(i)=2.0*basex*sqrt(0.75) + case(5) + ccx(i)=2.0*basex + ccy(i)=basex*sqrt(0.75) + case(6) + ccx(i)=1.5*basex + end select + else if(abs(typgeo) == 11) then + select case(i) + case(2) + ccx(i)=basex/2.0 + ccy(i)=basex*sqrt(0.75) + case(4) + ccx(i)=basex + end select + endif + if(typgeo == 5) then + ! pure translation in Cartesian geometry + select case(i) + case(1) + tty(i)=basey + case(2) + tty(i)=-basey + case(3) + ttx(i)=basex + case(4) + ttx(i)=-basex + end select + else if(typgeo == 9) then + ! pure translation in hexagonal geometry + select case(i) + case(1) + tty(i)=2.0*basex*sqrt(0.75) + case(2) + ttx(i)=2.0*basex + tty(i)=basex*sqrt(0.75) + case(3) + ttx(i)=2.0*basex + tty(i)=-basex*sqrt(0.75) + case(4) + tty(i)=-2.0*basex*sqrt(0.75) + case(5) + ttx(i)=-2.0*basex + tty(i)=-basex*sqrt(0.75) + case(6) + ttx(i)=-2.0*basex + tty(i)=basex*sqrt(0.75) + end select + else + ttx(i)=ccx(i) ; tty(i)=ccy(i) + endif + end do + endif + + ! read surfacic elements + read(ipAl,'(a12)') text12 + if (text12 /= ' Aretes:') call XABORT('g2s_convert: keyword Aretes: expected.') + read(ipAl,'(i7)',end=100) iszSA + allocate(tabSegArc(iszSA),iboundary(iszSA,2)) + ibd=0 + do i=1,iszSA + read(ipAl,*,end=100) itype + backspace(ipAl) + if(itype == 0) then + ! line segment + tabSegArc(i)%typ=1 + read(ipAl,*) itype,ipt1,ipt2,nmoins,nplus + tabSegArc(i)%x=real(apnodes(1,ipt1)) + tabSegArc(i)%y=real(apnodes(2,ipt1)) + tabSegArc(i)%dx=real(apnodes(1,ipt2)) + tabSegArc(i)%dy=real(apnodes(2,ipt2)) + else if(itype == 1) then + ! full circle + tabSegArc(i)%typ=2 + read(ipAl,*) itype,ipt3,radius,nplus,nmoins + tabSegArc(i)%x=real(apnodes(1,ipt3)) + tabSegArc(i)%y=real(apnodes(2,ipt3)) + tabSegArc(i)%r=real(radius) + tabSegArc(i)%b=0.0 ; tabSegArc(i)%a=0.0 + else if(itype == 2) then + ! circular arc + tabSegArc(i)%typ=3 + read(ipAl,*) itype,ipt1,ipt2,ipt3,nplus,nmoins + aStart=real(apnodes(1,ipt1)-apnodes(1,ipt3)) + bStart=real(apnodes(2,ipt1)-apnodes(2,ipt3)) + rStart=sqrt(aStart**2+bStart**2) + if(bStart >= 0.0) then + anglStart=acos(aStart/rStart) + else + anglStart=dpi_c-acos(aStart/rStart) + endif + aEnd=real(apnodes(1,ipt2)-apnodes(1,ipt3)) + bEnd=real(apnodes(2,ipt2)-apnodes(2,ipt3)) + rEnd=sqrt(aEnd**2+bEnd**2) + if(bEnd >= 0.0) then + anglEnd=acos(aEnd/rEnd) + else + anglEnd=dpi_c-acos(aEnd/rEnd) + endif + tabSegArc(i)%x=real(apnodes(1,ipt3)) + tabSegArc(i)%y=real(apnodes(2,ipt3)) + tabSegArc(i)%r=real(0.5d0*(rStart+rEnd)) + tabSegArc(i)%b=real(anglEnd) + tabSegArc(i)%a=real(anglStart) + else + write(hsmg,'(35hg2s_convert: invalid element type=,i3,1h.)') itype + call XABORT(hsmg) + endif + tabSegArc(i)%nodeg=nplus + tabSegArc(i)%noded=nmoins + if(abs(typgeo) > 0) then + if(((nplus==0).or.(nmoins==0)).and.(itype == 0)) then + ibd=ibd+1 + if(ibd > iszSA) call XABORT('g2s_convert: boundary overflow') + iboundary(ibd,2)=0 + dx=tabSegArc(i)%x-tabSegArc(i)%dx + dy=tabSegArc(i)%y-tabSegArc(i)%dy + angle=atan(dy/dx)*rad2deg + if(angle < 0.0) angle=angle+180. + do j=1,nangles + if(abs(angle-list_angles(j)) > 0.5) cycle + if((abs(tabSegArc(i)%x-ccx(j)) < epsilon).and.(abs(tabSegArc(i)%y-ccy(j)) < epsilon)) then + iboundary(ibd,2)=j + else if((abs(tabSegArc(i)%dx-ccx(j)) < epsilon).and.(abs(tabSegArc(i)%dy-ccy(j)) < epsilon)) then + iboundary(ibd,2)=j + else + dx0=tabSegArc(i)%x-ccx(j) + dy0=tabSegArc(i)%y-ccy(j) + angle0=atan(dy0/dx0)*rad2deg + if(angle0 < 0.0) angle0=angle0+180. + if(abs(angle-angle0) <= 1.0) iboundary(ibd,2)=j ! look for 1 degree agreement + endif + enddo + iboundary(ibd,1)=i + endif + endif + enddo + if(abs(typgeo) > 0) deallocate(ccy,ccx) + + ! list boundary elements + allocate(bcElems(iszSA,nangles),nber(nangles)) + if(abs(typgeo) > 0) then + nber(:)=0 + bcElems(:,:)=-1 + do ibound=1,ibd + i1=iboundary(ibound,1) + i2=iboundary(ibound,2) + if(i2 == 0) then + write(hsmg,'(26hg2s_convert: boundary side,i7,18h is not allocated., & + & 33h Try a different value of typgeo.)') i1 + call XABORT(hsmg) + endif + if(i2 > nangles) call XABORT('g2s_convert: boundary angle overflow.') + nber(i2)=nber(i2)+1 + if(nber(i2) > iszSA) call XABORT('g2s_convert: boundary element overflow.') + bcElems(nber(i2),i2)=i1 + enddo + endif + deallocate(iboundary) + + ! read Bords data in some specific Alamos files + read(ipAl,'(a12)') text12 + if (text12 == ' Bords:') then + read(ipAl,*) nbBords + do ib=1,nbBords + read(ipAl,*) itype,ib1,ib2 + enddo + read(ipAl,'(a12)') text12 + endif + + ! skip milTab data + if (text12 /= ' Mailles:') call XABORT('g2s_convert: keyword Mailles: expected.') + read(ipAl,'(i7)') nbNode + read(ipAl,'(10i7)',end=100) (idummy, i=1,nbNode) + read(ipAl,'(a12)') text12 + if (text12 == ' ') read(ipAl,'(a12)') text12 + print *,'read=',text12 + if (text12 /= ' Fin:') call XABORT('g2s_convert: keyword Fin: expected.') + ! + ! set nbfold + nbfold=0 + if(typgeo == -5) then + typgeo=1 ; nbfold=4 + else if(typgeo == -6) then + typgeo=1 ; nbfold=4 + else if(typgeo == -7) then + typgeo=1 ; nbfold=8 + else if(typgeo == -8) then + typgeo=1 ; nbfold=6 + else if(typgeo == -9) then + typgeo=1 ; nbfold=1 + else if(typgeo == -10) then + typgeo=2 ; nbfold=6 + else if(typgeo == -11) then + typgeo=2 ; nbfold=3 + endif + ! ---------------------------------- + ! Generate the Salomon surfacic file + ! ---------------------------------- + write(ipSal,'(a5)') 'BEGIN' + + write(ipSal,'(/a24)') 'DEFINE DOMAINE' + write(ipSal,'(a24/)') '==============' + + write(ipSal,'(a28/)') '1.main dimensions:' + write(ipSal,'(a32)') '*typgeo nbfold nbNode nbelem ' + write(ipSal,'(10'//formati//')') typgeo,nbfold,nbNode,iszSA,1,nbFlux + + write(ipSal,'(/a37)') '2.impression and precision:' + write(ipSal,'(/a21)') '*index kndex prec' + write(ipSal,'(10'//formati//')') 0,0,1 + + write(ipSal,'(/a40)') '3.precision of geometry data:' + write(ipSal,'(/a4)') '*eps' + write(ipSal,'('//formatr//')') gSALeps + + write(ipSal,'(/a58)') '4.flux region number per geometry region (mesh):' + write(ipSal,'(/a6)') '*merge' + allocate(merg(nbNode)) + do i=1,nbNode + merg(i)=i + enddo + write(ipSal,'(10'//formati//')') merg(:nbNode) + deallocate(merg) + + write(ipSal,'(/a29)') '5.name of geometry:' + write(ipSal,'(/a11)') '*macro_name' + write(ipSal,'(4(3x,a12))') name_geom + + write(ipSal,'(/a46)') '6.macro order number per flux region:' + write(ipSal,'(/a14)') '*macro_indices' + write(ipSal,'(10'//formati//')') (1,i=1,nbFlux) + + write(ipSal,'(/a57)') '7.read integer and real data for each elements:' + do i=1,iszSA + sa = tabSegArc(i) + cx=real(sa%x) + cy=real(sa%y) + if(sa%typ == 1) then + ! line segment + tx= real(sa%dx-sa%x) + ty= real(sa%dy-sa%y) + delta=0. + else if(sa%typ == 2) then + ! full circle + tx=real(sa%r) + ty=0. + delta=0. + else if(sa%typ == 3) then + ! circular arc + tx=real(sa%r) + ty=real(sa%a*rad2deg) + if (sa%b>sa%a) then + delta=real((sa%b-sa%a)*rad2deg) + else + delta=real((sa%b-sa%a)*rad2deg+360.d0) + endif + endif + write(ipSal,*) + write(ipSal,*) 'elem =',i + write(ipSal,'(a22)') '*type node- node+' + write(ipSal,'(10'//formati//')') sa%typ,sa%nodeg,sa%noded + write(ipSal,'(a63)') '*cx cy ex or R & + &ey or theta1 theta2' + write(ipSal,'(5'//formatr//')') cx,cy,tx,ty,delta + enddo + deallocate(tabSegArc) + + ! write boundary elements lists + write(ipSal,'(/a63)') '8.read integer and real data for boundary conditions:' + defautCl = 0 + albedo = 0.0 + strDCL = 'VOID' + write(ipSal,'(/a40)') '*defaul nbbcda allsur divsur ndivsur' + write(ipSal,'(10'//formati//')') defautCl,nangles,0,0,0 + write(ipSal,'(/a24)') 'DEFAULT = ' // strDCL + write(ipSal,'(a24)') '==============' + write(ipSal,'(/a17)') '*albedo deltasur' + write(ipSal,'(5'//formatr//')') albedo,0.0 + if(typgeo /= 0) then + do i = 1,nangles + write(ipSal,*) + write(ipSal,*) 'particular boundary condition number',i + write(ipSal,'(/a13)') '*type nber' + if(typgeo <= 2) then + saltype = 1 ! isotropic reflexion + else if((typgeo == 5).or.(typgeo == 9)) then + saltype = 2 ! translation + else if(typgeo < 9) then + saltype = 4 ! axial symmetry (specular reflexion) + else if(typgeo == 10) then ! RA60 + if(i == 1) then + saltype = 2 ! translation + else + saltype = 3 ! rotation + endif + else if(typgeo == 11) then ! R120 + if((i == 1).or.(i == 4)) then + saltype = 2 ! translation + else + saltype = 3 ! rotation + endif + else + call XABORT('g2s_convert: unknown type of geometry.') + endif + write(ipSal,'(10'//formati//')') saltype, nber(i) + write(ipSal,'(/a14)') '*elems(1,nber)' + write(ipSal,'(10'//formati//')') bcElems(:nber(i),i) + write(ipSal,'(/a22)') '*cx cy angle' + write(ipSal,'(5'//formatr//')') ttx(i),tty(i), list_angles(i) + end do + deallocate(tty,ttx) + endif + deallocate(nber,bcElems,list_angles) + + write(ipSal,'(/a28)') '9.medium per node:' + write(ipSal,'(/a11)') '*mil(nbreg)' + write(ipSal,'(10'//formati//')') milTab(:nbNode) + deallocate(milTab) + + write(ipSal,'(/a3)') 'END' + rewind(ipSal) + return + ! + 100 call XABORT('g2s_convert: end of Alamos surfacic file encountered.') + 110 call XABORT('g2s_convert: end of PropertyMap file encountered.') + end subroutine g2s_convert diff --git a/Dragon/src/g2s_g2mc.f90 b/Dragon/src/g2s_g2mc.f90 new file mode 100644 index 0000000..4bfddfa --- /dev/null +++ b/Dragon/src/g2s_g2mc.f90 @@ -0,0 +1,225 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Generate a dataset for use in a Monte Carlo code. +! +!Copyright: +! Copyright (C) 2001 Ecole Polytechnique de Montreal. +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): +! G. Civario (CS-SI) +! +!Parameters: input/output +! NENTRY : NUMBER OF LINKED LISTS AND FILES USED BY THE MODULE. +! HENTRY : CHARACTER*12 NAME OF EACH LINKED LIST OR FILE. +! IENTRY : =1 LINKED LIST; =2 XSM FILE; =3 SEQUENTIAL BINARY FILE; +! =4 SEQUENTIAL ASCII FILE; =5 DIRECT ACCESS FILE. +! JENTRY : =0 THE LINKED LIST OR FILE IS CREATED; +! =1 THE LINKED LIST OR FILE IS OPEN FOR MODIFICATIONS; +! =2 THE LINKED LIST OR FILE IS OPEN IN READ-ONLY MODE. +! KENTRY : FILE UNIT NUMBER OR LINKED LIST ADDRESS. +! +!----------------------------------------------------------------------- +! +subroutine G2MC(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + use SALGET_FUNS_MOD + use celluleBase + use cellulePlaced + use boundCond + use ptNodes + use pretraitement + use derivedPSPLOT + use monteCarlo + use track + use segArc + use GANLIB + use generTabSegArc + + implicit none + + integer NENTRY + integer IENTRY,JENTRY + type(c_ptr) KENTRY + character*12 HENTRY + dimension IENTRY(*),JENTRY(*),KENTRY(*),HENTRY(*) + + integer,parameter :: dimTabCelluleBase = 20000 + integer,parameter :: dimTabSegArc = 100000 + + type(c_ptr) :: ipGeo,ipGeo_1 + integer :: ipMC,ipSal,ipPs,sizeB,sizeP,sizeSA,nbNode,nbCLP,nbFlux,indic, & + & nitma,impx + real :: flott + double precision :: dflott + integer :: lgMaxGig=0 + integer,dimension(10) :: datain + integer,allocatable,dimension(:) :: merg,imacro + character(len=12) :: text12 + logical :: drawNod,drawMix,lmacro + real,dimension(2) :: zoomx,zoomy + + ipGeo_1=c_null_ptr ! no geometry read + ipSal=-1 ! no Salomon file read + ipMC = FILUNIT(KENTRY(1)) ! Monte-Carlo file generated + if ((NENTRY == 2).and.(IENTRY(2) == 4)) then + !generating Monte-Carlo file from Salomon file + ipSal = FILUNIT(KENTRY(2)) ! input Salomon file (surfacic elements) + ipPs = -1 ! no postscript file + ! check that second argumnet is file to write + ! then the tracking object + if ((IENTRY(1) /= 4) .or. (JENTRY(1) /= 0)) & + call XABORT('G2MC: a new ascii file expected at LHS for containing MC info') + if ((IENTRY(2) /= 4) .or. (JENTRY(2) /= 2)) & + call XABORT('G2MC: read-only ascii file expected at RHS with surfacic elements') + else if ((NENTRY == 3).and.(IENTRY(3) == 4)) then + !generating Monte-Carlo and ps files from Salomon file + ipPs = FILUNIT(KENTRY(2)) ! output psfile + ipSal = FILUNIT(KENTRY(3)) ! input Salomon file (surfacic elements) + g_psp_isEpsFile = (index(HENTRY(2),'.eps')/=0) !is it an eps file ? + ! check argument types and permissions + if ((IENTRY(1) /= 4) .or. (JENTRY(1) /= 0)) & + call XABORT('G2MC: a new file was expected for the Monte-Carlo file') + if ((IENTRY(2) /= 4) .or. (JENTRY(2) /= 0)) & + call XABORT('G2MC: a new file was expected for the postscript file') + if ((IENTRY(3) /= 4) .or. (JENTRY(3) /= 2)) & + call XABORT('G2MC: expecting Salomon file in read-only mode') + else if ((NENTRY == 2).and.(IENTRY(2) <= 2)) then + !generating Monte-Carlo file from LCM geometry + ipPs = -1 ! no postscript file + ipGeo_1= KENTRY(2) ! input geometry + ! check argument types and permissions + if ((IENTRY(1) /= 4) .or. (JENTRY(1) /= 0)) & + call XABORT('G2MC: a new ascii file expected at LHS for containing MC info') + else if ((NENTRY == 3).and.(IENTRY(3) <= 2)) then + !generating Monte-Carlo file and ps file from LCM geometry + ipPs = FILUNIT(KENTRY(2)) ! output psfile + g_psp_isEpsFile = (index(HENTRY(2),'.eps')/=0) !is it an eps file ? + ipGeo_1= KENTRY(3) ! input geometry + ! check argument types and permissions + if ((IENTRY(1) /= 4) .or. (JENTRY(1) /= 0)) & + call XABORT('G2MC: a new ascii file expected at LHS for containing MC info') + if ((IENTRY(2) /= 4) .or. (JENTRY(2) /= 0)) & + call XABORT('G2MC: a new file was expected for the postscript file') + else + call XABORT('G2MC: you must provide 2 or 3 arguments') + end if + ! + impx=1 + drawNod = .false. + drawMix = .false. + zoomx = (/ 0.0, 1.0 /) + zoomy = (/ 0.0, 1.0 /) + typgeo=0 + lmacro=.false. + 10 call REDGET(indic,nitma,flott,text12,dflott) + if (indic == 10) go to 20 + if (indic /= 3) call XABORT('G2MC: character data expected.') + if (text12 == 'EDIT') then + ! read the print index. + call REDGET(indic,impx,flott,text12,dflott) + if (indic /= 1) call XABORT('G2MC: integer data expected.') + else if (text12 == 'DRAWNOD') then + drawNod=.true. + drawmix=.true. + else if (text12 == 'DRAWMIX') then + drawNod=.true. + drawmix=.false. + else if (text12 == 'ZOOMX') then + call REDGET(indic,nitma,zoomx(1),text12,dflott) + if (indic /= 2) call XABORT('G2S: real data expected(1).') + call REDGET(indic,nitma,zoomx(2),text12,dflott) + if (indic /= 2) call XABORT('G2S: real data expected(2).') + if ((zoomx(1).lt.0.0).or.(zoomx(2).le.zoomx(1)).or.(zoomx(2).gt.1.0)) then + call XABORT('G2S: invalid zoom factors in x.') + endif + else if (text12 == 'ZOOMY') then + call REDGET(indic,nitma,zoomy(1),text12,dflott) + if (indic /= 2) call XABORT('G2S: real data expected(3).') + call REDGET(indic,nitma,zoomy(2),text12,dflott) + if (indic /= 2) call XABORT('G2S: real data expected(4).') + if ((zoomy(1).lt.0.0).or.(zoomy(2).le.zoomy(1)).or.(zoomy(2).gt.1.0)) then + call XABORT('G2S: invalid zoom factors in y.') + endif + else if (text12 == ';') then + go to 20 + else + call XABORT('G2MC: '//text12//' is an invalid keyword.') + end if + go to 10 + + 20 sizeB = 0 !cellules de base + sizeP = 0 !cellules placees + sizeSA = 0 !elements geometriques + if (c_associated(ipGeo_1)) then + ! copy the input geometric object + call lcmop(ipGeo,'geom_copy',0,1,0) + call lcmequ(ipGeo_1,ipGeo) + + !initialisation des differents tableaux + call initializeData(dimTabCelluleBase,dimTabSegArc) + + !unfold the geometry + call g2s_unfold(ipGeo,0) + + !pretraitement des donnees lues (remplace la partie python) + !+completion des cellules de base et remplissage du tableau + !des cellules placees + call prepareData(ipGeo,sizeB,sizeP,lgMaxGig) + + !en sortie, toutes les cellules de base ont tous leurs + !champs remplis, et le tableau des cellules placees est pret + + !eclatement des cellules + call splitCells(sizeP,sizeSA) + + !creation de nouveaux segments aux interfaces des cellules + !et elimination des doublons + call addSegsAndClean(sizeSA) + + !prise en compte des conditions aux limites + call appliBoundariConditions(ipGeo,sizeSA,nbCLP) + + !calcul des nodes delimites par les elements + allocate(merg(dimTabCelluleBase),imacro(dimTabCelluleBase),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2MC: g2s_g2mc(1) => allocation pb(1)") + call createNodes(sizeSA,dimTabCelluleBase,lmacro,nbNode,merg,imacro) + if (sizeSA > dimTabSegArc) call XABORT('g2s_g2mc: sizeSA overflow') + deallocate(imacro) + else + if (JENTRY(nentry) == 0) call XABORT('G2M: an existing Salomon file is expected') + !initialisation de TabSegArc + call SALGET(datain,4,ipSal,0,'dimensions for geometry') + nbNode=datain(3) + sizeSA=datain(4) + rewind(ipSal) + allocate(tabSegArc(sizeSA)) + call initializebCData() + allocate(merg(nbNode),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2MC: g2s_g2mc => allocation pb") + call generateTabSegArc(ipSal,sizeSA,nbNode,nbCLP,nbFlux,merg,impx) + endif + deallocate(merg) + + !impression des segArc charges + if (ipPs /= -1) call drawSegArc(ipPs,sizeSA,drawMix,drawNod,zoomx,zoomy) + + !creation du fichier de commande Monte-Carlo + if (index(HENTRY(1),'.tp')/=0) then + ! generate a Tripoli4 datafile + call generateTripoliFile(ipMC,sizeSA,nbNode) + else if (index(HENTRY(1),'.sp')/=0) then + ! generate a Serpent datafile + call generateSerpentFile(ipMC,sizeSA,nbNode) + else + ! generate a MCNP datafile + call generateMCNPFile(ipMC,sizeSA,nbNode) + end if + + !liberation de la memoire allouee + call destroyData(sizeB,sizeP) +end subroutine G2MC diff --git a/Dragon/src/g2s_g2s.f90 b/Dragon/src/g2s_g2s.f90 new file mode 100644 index 0000000..19494f3 --- /dev/null +++ b/Dragon/src/g2s_g2s.f90 @@ -0,0 +1,299 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Generate a surfacic 2D geometry following the TDT specification. +! +!Copyright: +! Copyright (C) 2001 Ecole Polytechnique de Montreal. +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): +! G. Civario (CS-SI) +! +!Parameters: input/output +! NENTRY : NUMBER OF LINKED LISTS AND FILES USED BY THE MODULE. +! HENTRY : CHARACTER*12 NAME OF EACH LINKED LIST OR FILE. +! IENTRY : =1 LINKED LIST; =2 XSM FILE; =3 SEQUENTIAL BINARY FILE; +! =4 SEQUENTIAL ASCII FILE; =5 DIRECT ACCESS FILE. +! JENTRY : =0 THE LINKED LIST OR FILE IS CREATED; +! =1 THE LINKED LIST OR FILE IS OPEN FOR MODIFICATIONS; +! =2 THE LINKED LIST OR FILE IS OPEN IN READ-ONLY MODE. +! KENTRY : FILE UNIT NUMBER OR LINKED LIST ADDRESS. +! +!----------------------------------------------------------------------- +! +subroutine G2S(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + use GANLIB + use SALGET_FUNS_MOD + use celluleBase + use cellulePlaced + use boundCond + use ptNodes + use pretraitement + use derivedPSPLOT + use track + use segArc + use generTabSegArc + use generSAL + + implicit none + + integer NENTRY + integer IENTRY,JENTRY + type(c_ptr) KENTRY + character*12 HENTRY + dimension IENTRY(*),JENTRY(*),KENTRY(*),HENTRY(*) + + integer,parameter :: dimTabCelluleBase = 20000 + integer,parameter :: dimTabSegArc = 100000 + + type(c_ptr) :: ipGeo,ipGeo_1 + integer :: sizeB,sizeP,sizeSA,nbNode,nbCLP,nbFlux,nbMacro,ipSal,ipPs,ipAl, & + ipZa,indic,nitma,impx + character(len=12) :: text12 + logical :: drawNod,drawMix,lmacro + real,dimension(2) :: zoomx,zoomy + integer,allocatable,dimension(:) :: gig,merg,imacro + integer,dimension(10) :: datain + real :: flott + double precision :: dflott + integer :: lgMaxGig=0 + ! + ipAl=-1 ! no Alamos file read + ipZa=-1 ! no PropertyMap file read + ipGeo_1=c_null_ptr ! no geometry read + if ((NENTRY == 2).and.(IENTRY(2) == 4)) then + !generating ps file from Salomon file + ipPs = FILUNIT(KENTRY(1)) ! output psfile + g_psp_isEpsFile = (index(HENTRY(1),'.eps')/=0) !is it an eps file ? + ipSal = FILUNIT(KENTRY(2)) ! input Salomon/Alamos file + ! check argument types and permissions + if ((IENTRY(1) /= 4) .or. (JENTRY(1) /= 0)) & + call XABORT('G2S: a new file was expected for the postscript file') + if ((IENTRY(2) /= 4) .or. (JENTRY(2) /= 2)) & + call XABORT('G2S: expecting Salomon file in read-only mode') + else if ((NENTRY == 3).and.(IENTRY(3) == 4)) then + !generating Salomon and ps files from Alamos file + ipSal = FILUNIT(KENTRY(1)) ! output Salomon file + ipPs = FILUNIT(KENTRY(2)) ! output psfile + ipAl = FILUNIT(KENTRY(3)) ! input Alamos file + g_psp_isEpsFile = (index(HENTRY(2),'.eps')/=0) !is it an eps file ? + ! check argument types and permissions + if ((IENTRY(1) /= 4) .or. (JENTRY(1) /= 0)) & + call XABORT('G2S: a new file was expected for the Salomon file') + if ((IENTRY(2) /= 4) .or. (JENTRY(2) /= 0)) & + call XABORT('G2S: a new file was expected for the postscript file') + if ((IENTRY(3) /= 4) .or. (JENTRY(3) /= 2)) & + call XABORT('G2S: expecting Alamos file in read-only mode') + else if ((NENTRY == 4).and.(IENTRY(3) == 4).and.(IENTRY(4) == 4)) then + !generating Salomon and ps files from Alamos and PropertyMap file + ipSal = FILUNIT(KENTRY(1)) ! output Salomon file + ipPs = FILUNIT(KENTRY(2)) ! output psfile + ipAl = FILUNIT(KENTRY(3)) ! input Alamos file + ipZa = FILUNIT(KENTRY(4)) ! input PropertyMap file + g_psp_isEpsFile = (index(HENTRY(2),'.eps')/=0) !is it an eps file ? + ! check argument types and permissions + if ((IENTRY(1) /= 4) .or. (JENTRY(1) /= 0)) & + call XABORT('G2S: a new file was expected for the Salomon file') + if ((IENTRY(2) /= 4) .or. (JENTRY(2) /= 0)) & + call XABORT('G2S: a new file was expected for the postscript file') + if ((IENTRY(3) /= 4) .or. (JENTRY(3) /= 2)) & + call XABORT('G2S: expecting Alamos file in read-only mode') + if ((IENTRY(4) /= 4) .or. (JENTRY(4) /= 2)) & + call XABORT('G2S: expecting PropertyMap file in read-only mode') + else if ((NENTRY == 2).and.(IENTRY(2) <= 2)) then + !generating Salomon file from LCM geometry + ipPs = -1 ! no postscript file + ipSal = FILUNIT(KENTRY(1)) ! output Salomon file + ipGeo_1= KENTRY(2) ! geometry read + ! check argument types and permissions + if ((IENTRY(1) /= 4) .or. (JENTRY(1) /= 0)) & + call XABORT('G2S: a new ASCII file was expected for writing geometry') + if ((IENTRY(2) > 2) .or. (JENTRY(2) /= 2)) & + call XABORT('G2S: expecting LCM geometry in read-only mode(1)') + else if ((NENTRY == 3).and.(IENTRY(3) <= 2)) then + !generating Salomon file and ps file from LCM geometry + ipSal = FILUNIT(KENTRY(1)) ! output Salomon file + ipPs = FILUNIT(KENTRY(2)) ! output psfile + g_psp_isEpsFile = (index(HENTRY(2),'.eps')/=0) !is it an eps file ? + ipGeo_1= KENTRY(3) ! geometry read + ! check argument types and permissions + if ((IENTRY(1) /= 4) .or. (JENTRY(1) /= 0)) & + call XABORT('G2S: a new file was expected for writing geometry') + if ((IENTRY(2) /= 4) .or. (JENTRY(2) /= 0)) & + call XABORT('G2S: a new file was expected for the postscript file') + if ((IENTRY(3) > 2) .or. (JENTRY(3) /= 2)) & + call XABORT('G2S: expecting LCM geometry in read-only mode(2)') + else + call XABORT('G2S: you must provide 2, 3 or 4 arguments') + end if + + impx=1 + drawNod = .false. + drawMix = .false. + zoomx = (/ 0.0, 1.0 /) + zoomy = (/ 0.0, 1.0 /) + typgeo=0 + lmacro=.false. + 10 call REDGET(indic,nitma,flott,text12,dflott) + if (indic == 10) go to 20 + if (indic /= 3) call XABORT('G2S: character data expected.') + if (text12 == 'EDIT') then + ! read the print index. + call REDGET(indic,impx,flott,text12,dflott) + if (indic /= 1) call XABORT('G2S: integer data expected(1).') + else if (text12 == 'DRAWNOD') then + drawNod=.true. + drawmix=.true. + else if (text12 == 'DRAWMIX') then + drawNod=.true. + drawmix=.false. + else if (text12 == 'ZOOMX') then + call REDGET(indic,nitma,zoomx(1),text12,dflott) + if (indic /= 2) call XABORT('G2S: real data expected(1).') + call REDGET(indic,nitma,zoomx(2),text12,dflott) + if (indic /= 2) call XABORT('G2S: real data expected(2).') + if ((zoomx(1).lt.0.0).or.(zoomx(2).le.zoomx(1)).or.(zoomx(2).gt.1.0)) then + call XABORT('G2S: invalid zoom factors in x.') + endif + else if (text12 == 'ZOOMY') then + call REDGET(indic,nitma,zoomy(1),text12,dflott) + if (indic /= 2) call XABORT('G2S: real data expected(3).') + call REDGET(indic,nitma,zoomy(2),text12,dflott) + if (indic /= 2) call XABORT('G2S: real data expected(4).') + if ((zoomy(1).lt.0.0).or.(zoomy(2).le.zoomy(1)).or.(zoomy(2).gt.1.0)) then + call XABORT('G2S: invalid zoom factors in y.') + endif + else if (text12 == 'ALAMOS') then + if (NENTRY == 2) call XABORT('G2S: three entries required.') + if (ipAl == -1) call XABORT('G2S: no RHS Salomon file.') + call REDGET(indic,typgeo,flott,text12,dflott) + if (indic /= 1) call XABORT('G2S: integer data expected(2).') + else if (text12 == 'MACRO') then + lmacro=.true. + else if (text12 == ';') then + go to 20 + else + call XABORT('G2S: '//text12//' is an invalid keyword.') + end if + go to 10 + + !conversion of Alamos file into a Salomon file + 20 if (ipAl /= -1) call g2s_convert(impx,ipAl,ipZa,ipSal) + + sizeB = 0 !cellules de base + sizeP = 0 !cellules placees + sizeSA = 0 !elements geometriques + if (c_associated(ipGeo_1)) then + ! copy the input geometric object + call lcmop(ipGeo,'geom_copy',0,1,0) + call lcmequ(ipGeo_1,ipGeo) + + !initialisation des differents tableaux + call initializeData(dimTabCelluleBase,dimTabSegArc) + + !unfold the geometry + call g2s_unfold(ipGeo,impx) + + !pretraitement des donnees lues (remplace la partie python) + !+completion des cellules de base et remplissage du tableau + !des cellules placees + call prepareData(ipGeo,sizeB,sizeP,lgMaxGig) + if (impx > 0) write(*,*) 'fin : prepareData lgMaxGig=',lgMaxGig + + !en sortie, toutes les cellules de base ont tous leurs + !champs remplis, et le tableau des cellules placees est pret + + !eclatement des cellules + call splitCells(sizeP,sizeSA) + + !creation de nouveaux segements aux interfaces des cellules + !et elimination des doublons + call addSegsAndClean(sizeSA) + + !prise en compte des conditions aux limites + call appliBoundariConditions(ipGeo,sizeSA,nbCLP) + + !calcul des nodes delimites par les elements + allocate(merg(dimTabCelluleBase),imacro(dimTabCelluleBase),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: g2s_g2s(1) => allocation pb(1)") + call createNodes(sizeSA,dimTabCelluleBase,lmacro,nbNode,merg,imacro) + if (sizeSA > dimTabSegArc) call XABORT('g2s_g2s: sizeSA overflow') + + !calcul des arrays gig et merg + allocate(gig(nbNode*lgMaxGig),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: g2s_g2s(1) => allocation pb(2)") + call generateTrack(sizeP,sizeSA,nbNode,lgMaxGig,gig,merg) + nbFlux=maxval(merg(:nbNode)) + nbMacro=maxval(imacro(:nbFlux)) + else + if (JENTRY(NENTRY) == 0) call XABORT('G2S: a RHS ascii file is expected') + !initialisation de TabSegArc + call SALGET(datain,4,ipSal,0,'dimensions for geometry') + nbNode=datain(3) + sizeSA=datain(4) + rewind(ipSal) + allocate(TabSegArc(sizeSA),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: generateTabSegArc => allocation pb") + call initializebCData() + allocate(merg(nbNode),imacro(nbNode),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: g2s_g2s(2) => allocation pb") + call generateTabSegArc(ipSal,sizeSA,nbNode,nbCLP,nbFlux,merg,impx) + imacro(:nbFlux) = 1 + nbMacro=1 + endif + + !impression des segArc charges + if (ipPs /= -1) call drawSegArc(ipPs,sizeSA,drawMix,drawNod,zoomx,zoomy) + + if (c_associated(ipGeo_1)) then + !creation du fichier de commande SAL + call generateSALFile(ipSal,sizeSA,nbNode,nbCLP,nbFlux,nbMacro,merg,imacro) + deallocate(gig) + call LCMCL(ipGeo,2) + endif + deallocate(imacro,merg) + + write(6,*) " At end of G2S:" + write(6,*) " ",sizeSA,"segs or arcs" + write(6,*) " ",nbNode,"nodes" + write(6,*) " ",nbFlux,"fluxes" + write(6,*) " ",nbMacro,"macros" + write(6,*) " ",nbCLP,"boundary conditions other than default" + + !liberation de la memoire allouee + call destroyData(sizeB,sizeP) +end subroutine G2S + +subroutine initializeData(dimTabCelluleBase,dimTabSegArc) + use celluleBase + use cellulePlaced + use boundCond + use segArc + implicit none + integer,intent(in) :: dimTabCelluleBase,dimTabSegArc + + call initializeTabCelluleBase(dimTabCelluleBase) + call initializeTabCellulePlaced() + allocate(tabSegArc(dimTabSegArc)) + call initializebCData() +end subroutine initializeData + +subroutine destroyData(szB,szP) + use celluleBase + use cellulePlaced + use boundCond + use segArc + implicit none + integer,intent(in) :: szB,szP + +! if (szB /= 0) call destroyTabCelluleBase(szB) + deallocate(tabSegArc) + if (szB /= 0) deallocate(TabCelluleBase) + if (szP /= 0) call destroyTabCellulePlaced(szP) + call destroybCData() +end subroutine destroyData diff --git a/Dragon/src/g2s_generateTabSegArc.f90 b/Dragon/src/g2s_generateTabSegArc.f90 new file mode 100644 index 0000000..9684634 --- /dev/null +++ b/Dragon/src/g2s_generateTabSegArc.f90 @@ -0,0 +1,145 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Fill the TabSegArc structure with information recovered in a +! surfacic file. +! +!Copyright: +! Copyright (C) 2001 Ecole Polytechnique de Montreal. +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): +! G. Civario (CS-SI) +! +!----------------------------------------------------------------------- +! +module generTabSegArc + use constUtiles + use segArc + use boundCond + use SALGET_FUNS_MOD + use precision_and_kinds, only : pdb + implicit none + +contains + + subroutine generateTabSegArc(ipSal,sizeSA,nbNode,nbCLP,nbFlux,merg,impx) + integer,intent(inout) :: ipSal + integer,intent(in) :: nbNode,sizeSA,impx + integer,intent(out) :: nbCLP,nbFlux + integer,dimension(nbNode),intent(out) :: merg + + integer, parameter :: n_datain=25, n_datare=20 + integer, dimension (n_datain) :: datain + real, dimension (n_datare) :: datare + real(pdb), dimension (n_datare) :: datade + integer :: type,nber,prec,elem,i,nbMacro,fout0 + integer, parameter, dimension(0:4) :: read_bc_len=(/1,1,2,3,3/) + character(len=12) :: name_geom + ! internal : albedo + ! vacuum surface : albedo + ! specular reflexion : none + ! translation : tx ty (t=translation vector) + ! rotation : cx cy cos(theta) sin(theta) theta + ! (c= center,theta= axis angle) + ! axial symmetry : cx cy cos(theta) sin(theta) theta + ! (c= center,theta= axis angle) + ! central symetry : cx cy (c= center) + integer, allocatable, dimension(:) :: iflux, medium + integer,parameter :: dimTabCelluleBase = 20000 + + fout0=6 + if(impx == 0) fout0=0 + call SALGET(datain,6,ipSal,fout0,'dimensions for geometry') + if(nbNode /= datain(3)) call XABORT('g2s_generateTabSegArc: nbNode error') + if(sizeSA /= datain(4)) call XABORT('g2s_generateTabSegArc: sizeSA error') + typgeo=datain(1) + nbMacro=datain(5) + nbFlux=datain(6) + call SALGET(datain,3,ipSal,fout0,'index kndex prec') + prec=datain(3) + call SALGET(datare,1,ipSal,fout0,'eps') + call SALGET(merg,nbNode,ipSal,fout0,'flux index per node') + call SALGET(name_geom,ipSal,fout0,'names of macros') + allocate(iflux(nbFlux),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: generateTabSegArc(1) => allocation pb") + call SALGET(iflux,nbFlux,ipSal,fout0,'macro order number per flux region') + deallocate(iflux) + do elem=1,sizeSA + call SALGET(datain,3,ipSal,fout0,'integer descriptors') + type=datain(1) + tabSegArc(elem)%typ=type + if(type == 1) then + tabSegArc(elem)%noded=datain(2) + tabSegArc(elem)%nodeg=datain(3) + else + tabSegArc(elem)%nodeg=datain(2) + tabSegArc(elem)%noded=datain(3) + endif + select case (type) + case (1) + nber=4 + case (2) + nber=3 + case (3) + nber=5 + case default + write(fout0,'(1x,''==> sal126: unknown type '',i3)')type + call xabort('g2_generateTabSegArc: unknown type') + end select + call SALGET(datade,nber,ipSal,fout0,prec,'real descriptors') + tabSegArc(elem)%x=datade(1) + tabSegArc(elem)%y=datade(2) + select case (type) + case (1) + tabSegArc(elem)%dx=datade(1)+datade(3) + tabSegArc(elem)%dy=datade(2)+datade(4) + case (2) + tabSegArc(elem)%r=datade(3) + tabSegArc(elem)%a=0.0 + tabSegArc(elem)%b=0.0 + case (3) + tabSegArc(elem)%r=datade(3) + tabSegArc(elem)%a=datade(4)/rad2deg + tabSegArc(elem)%b=(datade(4)+datade(5))/rad2deg + end select + enddo + call SALGET(datain,3,ipSal,fout0,'general bc data') + nbCLP=datain(2) + call SALGET(datade(1),ipSal,fout0,prec,'general albedo') + do i=1,nbCLP + call SALGET(datain,2,ipSal,fout0,'specific bc: type nber') + type=datain(1) + nber=datain(2) + SALbCDataTab(i)%SALtype=type + SALbCDataTab(i)%nber=nber + allocate(SALbCDataTab(i)%elemNb(nber),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: generateTabSegArc(3) => allocation pb") + call SALGET(SALbCDataTab(i)%elemNb,nber,ipSal,fout0,'bc elements') + ! read bc motion + call SALGET(datade,read_bc_len(type),ipSal,fout0,prec,'data for specific bc condition') + select case(type) + case(0,1) + SALbCDataTab(i)%albedo=real(datade(1)) + case(2) + SALbCDataTab(i)%tx=real(datade(1)) + SALbCDataTab(i)%ty=real(datade(2)) + case(3,4) + SALbCDataTab(i)%cx=real(datade(1)) + SALbCDataTab(i)%cy=real(datade(2)) + SALbCDataTab(i)%angle=real(datade(3)) + end select + enddo + allocate(medium(dimTabCelluleBase)) + call SALGET(medium,nbNode,ipSal,fout0,'media per node') + do i=1,sizeSA + if(tabSegArc(i)%nodeg>0) tabSegArc(i)%neutronicMixg=medium(tabSegArc(i)%nodeg) + if(tabSegArc(i)%noded>0) tabSegArc(i)%neutronicMixd=medium(tabSegArc(i)%noded) + enddo + deallocate(medium) + end subroutine generateTabSegArc +end module generTabSegArc diff --git a/Dragon/src/g2s_generatingMC.f90 b/Dragon/src/g2s_generatingMC.f90 new file mode 100644 index 0000000..286fe2e --- /dev/null +++ b/Dragon/src/g2s_generatingMC.f90 @@ -0,0 +1,825 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Generate a dataset for a Monte Carlo code. +! +!Copyright: +! Copyright (C) 2001 Ecole Polytechnique de Montreal. +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): +! G. Civario (CS-SI) +! +!Comments: +! fonctions: +! - initMC : initialisation des tableaux +! - destroyMC : liberation des pointeurs +! - createElemGene : constructeur d'un element generique +! - isSameEG : teste l'equivalence de deux elements generiques +! - isSameWayEG : teste si deux elements generiques ont meme orientation +! - prepareMCData : preparation des donnes necessaires et remplissage +! des tableaux globaux +! - generateTripoliFile : ecriture du fichier de donnees Tripoli4 +! - generateMCNPFile : ecriture du fichier de donnees MCNP +! - generateSerpentFile : ecriture du fichier de donnees Serpent +! - putOn80col : formattage sur 80 colonnes style MCNP, d'un buffer a afficher +! - findParalleleWithTrans : trouve l'element geometrique a associer avec un +! autre, dans le cas d'une translation +! +!----------------------------------------------------------------------- +! +module monteCarlo + use boundCond + use cast + use cellulePlaced + use constType + use constUtiles + use segArc + use generSAL + + implicit none + + type t_elemGene + logical :: isPlan !plan -> true ; cylindre -> false + double precision :: x,y ! -> origine ; -> centre + double precision :: dx,dy ! -> extremite ; -> 0. + double precision :: r ! -> 0. ; -> rayon + integer :: limite ! ==Tri_XXXX + end type t_elemGene + + type(t_elemGene),dimension(:),allocatable,save :: tabEG + + type t_volume + integer :: lg !longueur des tableaux + integer :: mix !numero du milieu + integer,dimension(:), allocatable :: indElem !indice des elements generiques + !du contour + logical,dimension(:), allocatable :: side !true -> cote + ; false -> cote - + integer,dimension(:), allocatable :: typCL !condition limite de la face + end type t_volume + + type(t_volume),dimension(:),allocatable,save :: tabVolume + + integer,parameter :: Tri_Not=-1,Tri_Void=0,Tri_Refl=1,Tri_Trans=2,Tri_Cos=3 + +contains + + subroutine initMC(nbNode) + integer,intent(in) :: nbNode + + allocate(tabVolume(nbNode),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: initMC => allocation pb") + tabVolume(1:nbNode)%lg = 0 + end subroutine initMC + + subroutine destroyMC() + integer :: i + + do i = 1,size(tabVolume) + deallocate(tabVolume(i)%indElem) + deallocate(tabVolume(i)%side) + deallocate(tabVolume(i)%typCL) + end do + deallocate(tabEG,tabVolume) + end subroutine destroyMC + + function createElemGene(sa,strDCL) + type(t_segArc),intent(in) :: sa + character(len=4),intent(in) :: strDCL + type(t_elemGene) :: createElemGene + + integer :: sunsetCL + + createElemGene%isPlan = (sa%typ==tseg) + createElemGene%x = sa%x + createElemGene%y = sa%y + if (createElemGene%isPlan) then + createElemGene%dx = sa%dx + createElemGene%dy = sa%dy + createElemGene%r = 0.d0 + else + createElemGene%dx = 0.d0 + createElemGene%dy = 0.d0 + createElemGene%r = sa%r + end if + createElemGene%limite = Tri_Not + sunsetCL = minval((/sa%nodeg,sa%noded/)) + if (sunsetCL<=0) then + sunsetCL = mod(-sunsetCL,100) + select case(sunsetCL) + case(B_Void,B_Zero) + createElemGene%limite = Tri_Void + case(B_Refl,B_Ssym,B_Syme,B_Diag) + createElemGene%limite = Tri_Refl + case(B_Tran) + createElemGene%limite = Tri_Trans + case(B_Albe) + createElemGene%limite = Tri_Cos + case(-fooMix,0) + !il faut utiliser la CL par defaut + if (strDCL=='ALBE') then + createElemGene%limite = Tri_Cos + else if (strDCL=='REFL') then + createElemGene%limite = Tri_Refl + else ! => VOID + createElemGene%limite = Tri_Void + end if + case default + call XABORT("G2MC: boundary condition not allowed") + end select + end if + end function createElemGene + + function isSameEG(eg1,eg2) + type(t_elemGene),intent(in) :: eg1,eg2 + logical :: isSameEG + + if (eg1%isPlan.neqv.eg2%isPlan) then + isSameEG = .false. + else if (eg1%isPlan) then + isSameEG = pointsAlignes(eg1%x,eg1%y,eg1%dx,eg1%dy,eg2%x,eg2%y) & + .and. pointsAlignes(eg1%x,eg1%y,eg1%dx,eg1%dy,eg2%dx,eg2%dy) + else + isSameEG = isEqualConst(eg1%x,eg2%x) & + .and. isEqualConst(eg1%y,eg2%y) & + .and. isEqualConst(eg1%r,eg2%r) + end if + isSameEG = isSameEG .and. (eg1%limite==eg2%limite) + end function isSameEG + + function isSameWayEG(eg1,eg2) + type(t_elemGene),intent(in) :: eg1,eg2 + logical :: isSameWayEG + + if (eg1%isPlan .and. eg2%isPlan) then + isSameWayEG = & + (((eg1%dx-eg1%x)*(eg2%dx-eg2%x)+(eg1%dy-eg1%y)*(eg2%dy-eg2%y))>0) + else + isSameWayEG = .true. + end if + end function isSameWayEG + + subroutine prepareMCData(szSA,nbNode,szEG) + integer,intent(in) :: szSA,nbNode + integer,intent(inout) :: szEG + + integer :: i,j,volNbr,defautCl,lgMax,indFictive + logical :: found,toPut + real :: albedo + character*4 :: strDCL + double precision :: ptx,pty,rxx,ryy + type(t_elemGene) :: eg + integer,dimension(:),allocatable :: indEG,nbPoints + logical,dimension(:),allocatable :: isGoodWay,withFictiveEG,inACircle + double precision,dimension(:,:),allocatable :: xx,yy + type(t_elemGene),dimension(:),allocatable :: tmpTabEG + + !recuperation des donnees de conditions aux limites + call calculDefaultCl(defautCl,albedo,strDCL) + !preparation des donnees de remplissage des tableaux globaux + allocate(indEG(szSA),isGoodWay(szSA),tmpTabEG(szSA+nbNode),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: prepareMCData(1) => allocation pb") + do i = 1,szSA + eg = createElemGene(tabSegArc(i),strDCL) + found = .false. + do j = 1,szEG + found = isSameEG(eg,tmpTabEG(j)) + if (found) exit + end do + if (found) then + indEG(i) = j + isGoodWay(i) = isSameWayEG(eg,tmpTabEG(j)) + else + szEG = szEG + 1 + tmpTabEG(szEG) = eg + indEG(i) = szEG + isGoodWay(i) = .true. + end if + end do + !preparation des donnes permettant de savoir si un element fictif + !englobant est necessaire + allocate(inACircle(nbNode),withFictiveEG(nbNode),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: prepareMCData(2) => allocation pb") + withFictiveEG(:nbNode) = .false. ; inACircle(:nbNode) = .false. + !calcul des dimensions des pointeurs du tableau des volumes + do i = 1,szSA + !cote gauche + volNbr = tabSegArc(i)%nodeg + if (volNbr>0) then + tabVolume(volNbr)%lg = tabVolume(volNbr)%lg + 1 + if (tabSegArc(i)%typ==tcer .and. .not. inACircle(volNbr)) then + !le node est a l'interieur d'un cercle => on n'a pas besoin de + !l'englober + inACircle(volNbr) = .true. + if (withFictiveEG(volNbr)) then + !on avait commencer a englober fictivement => on laisse tomber + tabVolume(volNbr)%lg = tabVolume(volNbr)%lg - 1 + withFictiveEG(volNbr) = .false. + end if + end if + end if + !cote droit + volNbr = tabSegArc(i)%noded + if (volNbr>0) then + tabVolume(volNbr)%lg = tabVolume(volNbr)%lg + 1 + if (tabSegArc(i)%typ==tarc .and. .not. withFictiveEG(volNbr) & + .and. .not. inACircle(volNbr)) then + !le node est a l'exterieur d'un arc => on englobe si pas encore + !fait + tabVolume(volNbr)%lg = tabVolume(volNbr)%lg + 1 + withFictiveEG(volNbr) = .true. + end if + end if + end do + deallocate(inACircle) + lgMax = maxval(tabVolume(:nbNode)%lg) + !allocation des pointeurs du tableau des volumes + do i = 1,nbNode + allocate(tabVolume(i)%indElem(tabVolume(i)%lg),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: prepareMCData(3) => allocation pb") + tabVolume(i)%indElem = 0 + allocate(tabVolume(i)%side(tabVolume(i)%lg),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: prepareMCData(4) => allocation pb") + allocate(tabVolume(i)%typCL(tabVolume(i)%lg),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: prepareMCData(5) => allocation pb") + tabVolume(i)%typCL = 0 + !remise a zero du compteur, pour gerer les doublons + tabVolume(i)%lg = 0 + end do + !remplissage des pointeurs, avec elimination des doublons + allocate(xx(nbNode,lgMax),yy(nbNode,lgMax)) + allocate(nbPoints(nbNode),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: prepareMCData(6) => allocation pb") + nbPoints(:nbNode) = 0 ; xx(:nbNode,:lgMax) = 0.d0 ; yy(:nbNode,:lgMax) = 0.d0 + do i = 1,szSA + !cote gauche + volNbr = tabSegArc(i)%nodeg + if (volNbr>0) then + toPut = ( count(tabVolume(volNbr)%indElem(:)==indEG(i)) == 0 ) + if (toPut) then + tabVolume(volNbr)%mix = tabSegArc(i)%neutronicMixg + tabVolume(volNbr)%lg = tabVolume(volNbr)%lg + 1 + tabVolume(volNbr)%indElem(tabVolume(volNbr)%lg) = indEG(i) + tabVolume(volNbr)%typCL(tabVolume(volNbr)%lg) = & + tmpTabEG(indEG(i))%limite + tabVolume(volNbr)%side(tabVolume(volNbr)%lg) = .not.isGoodWay(i) + end if + !preparation du calcul des coordonnees du cercle englobant + if (withFictiveEG(volNbr).and.tabSegArc(i)%typ/=tcer) then + call giveOrigine(tabSegArc(i),ptx,pty) + nbPoints(volNbr) = nbPoints(volNbr) + 1 + xx(volNbr,nbPoints(volNbr)) = ptx + yy(volNbr,nbPoints(volNbr)) = pty + end if + end if + !cote droit + volNbr = tabSegArc(i)%noded + if (volNbr>0) then + toPut = ( count(tabVolume(volNbr)%indElem(:)==indEG(i)) == 0 ) + if (toPut) then + tabVolume(volNbr)%mix = tabSegArc(i)%neutronicMixd + tabVolume(volNbr)%lg = tabVolume(volNbr)%lg + 1 + tabVolume(volNbr)%indElem(tabVolume(volNbr)%lg) = indEG(i) + tabVolume(volNbr)%typCL(tabVolume(volNbr)%lg) = & + tmpTabEG(indEG(i))%limite + tabVolume(volNbr)%side(tabVolume(volNbr)%lg) = isGoodWay(i) + end if + !preparation du calcul des coordonnees du cercle englobant + if (withFictiveEG(volNbr).and.tabSegArc(i)%typ/=tcer) then + call giveExtremite(tabSegArc(i),ptx,pty) + nbPoints(volNbr) = nbPoints(volNbr) + 1 + xx(volNbr,nbPoints(volNbr)) = ptx + yy(volNbr,nbPoints(volNbr)) = pty + end if + end if + end do + !calcul des cercles englobants + do i = 1,nbNode + if (.not.withFictiveEG(i)) cycle + !creation du cercle + eg%isPlan = .false. + eg%x = sum(xx(i,:nbPoints(i)))/nbPoints(i) + eg%y = sum(yy(i,:nbPoints(i)))/nbPoints(i) + eg%dx = 0.d0 ; eg%dy = 0.d0 ; eg%r = 0.d0 ; eg%limite = Tri_Not + do j = 1,nbPoints(i) + rxx = xx(i,j)-eg%x ; ryy = yy(i,j)-eg%y + eg%r = max(eg%r,longVect(rxx,ryy)) + end do + !integration eventuelle dans le tableau des elements geometriques + found = .false. + do j = 1,szEG + found = isSameEG(eg,tmpTabEG(j)) + if (found) exit + end do + if (found) then + indFictive = j + else + szEG = szEG + 1 + tmpTabEG(szEG) = eg + indFictive = szEG + end if + !ajout eventuel dans la liste des elements geometriques constitutifs + !de la zone + toPut = ( count(tabVolume(i)%indElem(:)==indFictive) == 0 ) + if (toPut) then + tabVolume(i)%lg = tabVolume(i)%lg + 1 + tabVolume(i)%indElem(tabVolume(i)%lg) = indFictive + tabVolume(i)%typCL(tabVolume(i)%lg) = Tri_Not + tabVolume(i)%side(tabVolume(i)%lg) = .false. + end if + end do + deallocate(nbPoints,xx,yy,indEG,isGoodWay,withFictiveEG) + !recopie du tableau global des elements geometriques, et liberation + !du temporaire + allocate(tabEG(szEG),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: prepareMCData(7) => allocation pb") + tabEG(1:szEG) = tmpTabEG(1:szEG) + deallocate(tmpTabEG) + end subroutine prepareMCData + + subroutine generateTripoliFile(fileTripoli,szSA,nbNode) + integer,intent(in) :: fileTripoli,szSA,nbNode + + real :: a,b,c,d,xx,yy,rr + integer :: i,j,szEG,nbPlus,nbMoins,nbMix,nbCLTot,nbCL + integer,dimension(:),allocatable :: sp,sm,listMix,volmix,clList + + szEG = 0 + call initMC(nbNode) + call prepareMCData(szSA,nbNode,szEG) + + write(fileTripoli,'(/"GEOMETRY"/)') + write(fileTripoli,'("//jeu de donnees geometriques TRIPOLI")') + write(fileTripoli,'("//genere pour DRAGON par le module G2MC"/)') + write(fileTripoli,'("TITRE geometrie DRAGON pour TRIPOLI"/)') + !definition des surfaces + write(fileTripoli,'("//definition des surfaces"/)') + c = 0. + do i = 1,szEG + if (tabEG(i)%isPlan) then + a = real(tabEG(i)%dy - tabEG(i)%y) + b = real(tabEG(i)%x - tabEG(i)%dx) + d = real(tabEG(i)%y*tabEG(i)%dx - tabEG(i)%x*tabEG(i)%dy) + write(fileTripoli,*) " SURF ",i," PLAN ",a,b,c,d + else + xx = real(tabEG(i)%x) + yy = real(tabEG(i)%y) + rr = real(tabEG(i)%r) + write(fileTripoli,*) " SURF ",i," CYLZ ",xx,yy,rr + end if + end do + write(fileTripoli,*) " SURF ",szEG+1," PLANZ 0. //plan inferieur" + write(fileTripoli,*) " SURF ",szEG+2," PLANZ 30. //plan superieur" + !definition des volumes + write(fileTripoli,'(/"//definition des volumes"/)') + do i = 1,nbNode + nbPlus = count(tabVolume(i)%side(1:tabVolume(i)%lg)) + nbMoins = tabVolume(i)%lg - nbPlus + allocate(sp(nbPlus),sm(nbMoins),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: generateTripoliFile(1) => allocation pb") + sp = pack(tabVolume(i)%indElem(1:tabVolume(i)%lg), & + tabVolume(i)%side(1:tabVolume(i)%lg)) + sm = pack(tabVolume(i)%indElem(1:tabVolume(i)%lg), & + .not.tabVolume(i)%side(1:tabVolume(i)%lg)) + write(fileTripoli,*) " VOLU" + write(fileTripoli,*) " ",i + write(fileTripoli,*) " EQUA" + write(fileTripoli,*) " PLUS",nbPlus+1 + write(fileTripoli,*) " ",szEG+1,sp(:) !plan inf en premier + write(fileTripoli,*) " MOINS",nbMoins+1 + write(fileTripoli,*) " ",sm(:),szEG+2 !plan sup en dernier + write(fileTripoli,*) " FINV" + write(fileTripoli,*) + deallocate(sp,sm) + end do + write(fileTripoli,'("FINGEOM")') + + !conditions aux limites + write(fileTripoli,'(/"//conditions aux limites")') + write(fileTripoli,'("LIMIT")') + !calcul du nombre total de lignes de conditions limites particulieres + nbCLTot = 2*nbNode + do i = 1,nbNode + nbCLTot = nbCLTot & + + count(tabVolume(i)%typCL(1:tabVolume(i)%lg)==Tri_Refl) & + + count(tabVolume(i)%typCL(1:tabVolume(i)%lg)==Tri_Trans) & + + count(tabVolume(i)%typCL(1:tabVolume(i)%lg)==Tri_Cos) + end do + write(fileTripoli,*) nbCLTot + !affichage des conditions limites + do i = 1,nbNode + !Reflexions + write(fileTripoli,*) " ",i," REFLECTION ",szEG+1 + write(fileTripoli,*) " ",i," REFLECTION ",szEG+2 + nbCL = count(tabVolume(i)%typCL(1:tabVolume(i)%lg)==Tri_Refl) + if (nbCL/=0) then + allocate(clList(nbCL),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: generateTripoliFile(2) => allocation pb") + clList = pack(tabVolume(i)%indElem(1:tabVolume(i)%lg), & + tabVolume(i)%typCL(1:tabVolume(i)%lg)==Tri_Refl) + do j = 1,nbCL + write(fileTripoli,*) " ",i," REFLECTION ",clList(j) + end do + deallocate(clList) + end if + !Translations + nbCL = count(tabVolume(i)%typCL(1:tabVolume(i)%lg)==Tri_Trans) + if (nbCL/=0) then + allocate(clList(nbCL),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: generateTripoliFile(3) => allocation pb") + clList = pack(tabVolume(i)%indElem(1:tabVolume(i)%lg), & + tabVolume(i)%typCL(1:tabVolume(i)%lg)==Tri_Trans) + do j = 1,nbCL + write(fileTripoli,*) " ",i," TRANSLATION ",clList(j) + end do + deallocate(clList) + end if + !Cosinus + nbCL = count(tabVolume(i)%typCL(1:tabVolume(i)%lg)==Tri_Cos) + if (nbCL/=0) then + allocate(clList(nbCL),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: generateTripoliFile(4) => allocation pb") + clList = pack(tabVolume(i)%indElem(1:tabVolume(i)%lg), & + tabVolume(i)%typCL(1:tabVolume(i)%lg)==Tri_Cos) + do j = 1,nbCL + write(fileTripoli,*) " ",i," COSINUS ",clList(j) + end do + deallocate(clList) + end if + end do + write(fileTripoli,'("FIN_LIMIT"/)') + + ! insertion des donnees neutroniques des materiaux + ! le milieu ne correspond au materiaux nomme "MIX_n" + write(fileTripoli,'("//insertion des donnees neutroniques")') + write(fileTripoli,'("//des matreriaux")') + write(fileTripoli,'("FILE")') + write(fileTripoli,'(" mix_data"/)') !le nom est fixe, mais pourra etre + !change si besoin ###### + + !definition du milieu par volume + write(fileTripoli,'("//definition du milieu par volume")') + write(fileTripoli,'("GEOMCOMP")') + allocate(listMix(nbNode),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: generateTripoliFile(5) => allocation pb") + listMix(:nbNode) = 0 + nbMix = 0 + do i = 1,nbNode + if (count(listMix(:nbNode)==tabVolume(i)%mix)==0) then + nbMix = nbMix + 1 + listMix(nbMix) = tabVolume(i)%mix + end if + end do + do i = 1,nbMix + allocate(volMix(count(tabVolume(:)%mix==listMix(i))),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: generateTripoliFile(6) => allocation pb") + volMix = pack((/(j,j=1,nbNode)/),tabVolume(:)%mix==listMix(i)) + write(fileTripoli,*) " MIX_"//trim(i2s(listMix(i))),size(volMix) + write(fileTripoli,*) " ",volMix + deallocate(volMix) + end do + deallocate(listMix) + write(fileTripoli,'("FIN_GEOMCOMP"/)') + + call destroyMC() + end subroutine generateTripoliFile + + subroutine generateMCNPFile(fileMCNP,szSA,nbNode) + integer,intent(in) :: fileMCNP,szSA,nbNode + + integer :: i,j,k,szEG,ind,transInd,nbEGCL + real :: a,b,c,d,xx,yy,rr + character(len=1) :: sgn + character(len=5) :: nbr,mix + character(len=6) :: other,signedNbr + character(len=12) :: text12 + character(len=1000) :: buffer + integer,dimension(:),allocatable :: tabEGCL + + szEG = 0 + call initMC(nbNode) + call prepareMCData(szSA,nbNode,szEG) + + !title card + write(fileMCNP,'("Jeu de donnees geometriques MCNP genere pour DRAGON & + &par le module G2MC")') + !message en commentaire + write(fileMCNP,'("C Attention ! Les densites des milieux n''etant pas & + &disponibles dans les")') + write(fileMCNP,'("C jeux de donnees geometriques DRAGON, il faut passer & + &une moulinette pour")') + write(fileMCNP,'("C remplacer les ""DENSITE_I"" presents dans ce fichier, & + &par leur valeur."/)') + !cell card + write(fileMCNP,'("C cell card")') + do i = 1,nbNode + text12 = i2s(i) + nbr = text12(:5) + text12 = i2s(tabVolume(i)%mix) + mix = text12(:5) + buffer =nbr//" "//trim(mix)//" DENSITE_"//trim(mix) + ind = len_trim(buffer)+1 + write(buffer(ind:),*) merge(tabVolume(i)%indElem(1:tabVolume(i)%lg), & + -tabVolume(i)%indElem(1:tabVolume(i)%lg), & + tabVolume(i)%side(1:tabVolume(i)%lg)) , & + szEG+1 , -(szEG+2) + call putOn80col(fileMCNP,buffer) + end do + text12=i2s(nbNode+1) + nbr = text12(:5) + buffer = nbr//" 0" + ind = 9 + if (geomTyp==HexTyp.or.geomTyp==TriaTyp) then + !on a des risques de geometrie non convexe + ! => on prend les complementaires + do i = 1,nbNode + text12 = i2s(i) + nbr = text12(:5) + buffer(ind:) = "#"//nbr + ind = ind + len_trim(nbr) + 2 + end do + else + !la geometrie est convexe + ! on prend l'union des complementaires des cotes a condition limite + nbEGCL = count(tabEG(:)%limite/=Tri_Not) + allocate(tabEGCL(nbEGCL),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: generateTripoliFile(7) => allocation pb") + tabEGCL = pack((/(i,i=1,szEG)/),tabEG(:)%limite/=Tri_Not) + do i = 1,nbEGCL + do j = 1,nbNode + do k = 1,tabVolume(j)%lg + if (tabVolume(j)%indElem(k)==tabEGCL(i)) then + if (tabVolume(j)%side(k)) tabEGCL(i) = -tabEGCL(i) + exit + end if + end do + end do + end do + do i = 1,nbEGCL + text12 = i2s(tabEGCL(i)) + signedNbr = text12(:6) + buffer(ind:) = trim(signedNbr)//" :" + ind = ind + len_trim(signedNbr) + 3 + end do + buffer(ind:) = trim(i2s(-(szEG+1)))//" : "//i2s(szEG+2) + deallocate(tabEGCL) + end if + call putOn80col(fileMCNP,buffer) + + !surface card + write(fileMCNP,'(/"C surface card")') + c = 0. + do i = 1,szEG + text12 = i2s(i) + nbr = text12(:5) + sgn = ' ' + other = ' ' + select case(tabEG(i)%limite) + case(Tri_Refl) + sgn = '*' + case(Tri_Trans) + transInd = findParalleleWithTrans(i,szEG) + text12=i2s(transInd) + if (isSameWayEG(tabEG(i),tabEG(transInd))) then + other = '-'//text12(:6) + else + other = text12(:6) + end if + case(Tri_Cos) + sgn = '+' + end select + if (tabEG(i)%isPlan) then + a = real(tabEG(i)%dy - tabEG(i)%y) + b = real(tabEG(i)%x - tabEG(i)%dx) + d = real(tabEG(i)%y*tabEG(i)%dx - tabEG(i)%x*tabEG(i)%dy) + buffer = adjustl(sgn//nbr//trim(" "//other)//" P") + ind = len_trim(buffer) + 1 + write(buffer(ind:),*) a,b,c,d + else + xx = real(tabEG(i)%x) + yy = real(tabEG(i)%y) + rr = real(tabEG(i)%r) + buffer = adjustl(sgn//nbr//" C/Z") + ind = len_trim(buffer) + 1 + write(buffer(ind:),*) xx,yy,rr + end if + call putOn80col(fileMCNP,buffer) + end do + text12 = i2s(szEG+1) + nbr = text12(:5) + buffer = "*"//nbr//" PZ 0. $plan inferieur" + call putOn80col(fileMCNP,buffer) + text12 = i2s(szEG+2) + nbr = text12(:5) + buffer = "*"//nbr//" PZ 30. $plan superieur" + call putOn80col(fileMCNP,buffer) + + !data card + + call destroyMC() + end subroutine generateMCNPFile + + subroutine generateSerpentFile(fileSerpent,szSA,nbNode) + integer,intent(in) :: fileSerpent,szSA,nbNode + + integer :: i,j,k,szEG,ind,transInd,nbEGCL,nb2,isurf,jjj + real :: a,b,c,d,xx,yy,rr,cuboid(6) + character(len=1) :: sgn + character(len=5) :: nbr,mix + character(len=6) :: other + character(len=12) :: text12 + character(len=1000) :: buffer + integer,dimension(:),allocatable :: tabEGCL,tmpnod,tmpnod2 + logical :: lcuboid + + szEG = 0 + call initMC(nbNode) + call prepareMCData(szSA,nbNode,szEG) + + !title card + write(fileSerpent,'("% Serpent combinatorial geometry generated by module G2MC:")') + !cell card + nbEGCL = count(tabEG(:)%limite/=Tri_Not) + allocate(tabEGCL(nbEGCL),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: generateSerpentFile(1) => allocation pb") + tabEGCL = pack((/(i,i=1,szEG)/),tabEG(:)%limite/=Tri_Not) + do i = 1,nbEGCL + do j = 1,nbNode + do k = 1,tabVolume(j)%lg + if (tabVolume(j)%indElem(k)==tabEGCL(i)) then + if (tabVolume(j)%side(k)) tabEGCL(i) = -tabEGCL(i) + exit + end if + end do + end do + end do + write(fileSerpent,'("% cell cards")') + nb2=0 + cuboid=(/ 0.0, 0.0, 0.0, 0.0, -1.0E10, 1.0E10 /) + do i = 1,nbNode + allocate(tmpnod(tabVolume(i)%lg),tmpnod2(tabVolume(i)%lg),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: generateSerpentFile(2) => allocation pb") + text12 = i2s(i) + nbr = text12(:5) + text12 = i2s(tabVolume(i)%mix) + mix = text12(:5) + buffer ="cell "//nbr//" 0 MIX_"//trim(mix) + ind = len_trim(buffer)+1 + tmpnod(:tabVolume(i)%lg)=merge(-tabVolume(i)%indElem(1:tabVolume(i)%lg), & + tabVolume(i)%indElem(1:tabVolume(i)%lg), & + tabVolume(i)%side(1:tabVolume(i)%lg)) + jjj=0 + lcuboid=.true. + do j = 1,tabVolume(i)%lg + do k =1,nbEGCL + if(tmpnod(j) == tabEGCL(k)) then + isurf=abs(tabEGCL(k)) + if (.not.tabEG(isurf)%isPlan) call XABORT('g2s_generatingMC: unsupported BC') + a = real(tabEG(isurf)%dy - tabEG(isurf)%y) + b = real(tabEG(isurf)%x - tabEG(isurf)%dx) + d = real(tabEG(isurf)%y*tabEG(isurf)%dx - tabEG(isurf)%x*tabEG(isurf)%dy) + if ((a == 0.0).and.(tabEGCL(k) < 0)) then + cuboid(4)=-d/b + else if ((a == 0.0).and.(tabEGCL(k) > 0)) then + cuboid(3)=-d/b + else if ((b == 0.0).and.(tabEGCL(k) < 0)) then + cuboid(1)=-d/a + else if ((b == 0.0).and.(tabEGCL(k) > 0)) then + cuboid(2)=-d/a + endif + if(lcuboid) then + jjj=jjj+1 + tmpnod2(jjj)=-szEG-1 + lcuboid=.false. + endif + go to 10 + endif + end do + jjj=jjj+1 + tmpnod2(jjj)=-tmpnod(j) + 10 continue + end do + if(jjj.gt.0) then + write(buffer(ind:),*) tmpnod2(:jjj) + write(fileSerpent,'(a)') trim(buffer) + endif + deallocate(tmpnod2,tmpnod) + end do + if (nbEGCL > 0) then + text12 = i2s(nbNode+1) + nbr = text12(:5) + text12 = i2s(szEG+1) + buffer ="cell "//nbr//" 0 outside "//trim(text12) + write(fileSerpent,'(a)') trim(buffer) + endif + + !surface card + write(fileSerpent,'(/"% surface cards")') + c = 0. + do i = 1,szEG + do k = 1,nbEGCL + if (i == abs(tabEGCL(k))) go to 20 + end do + text12 = i2s(i) + nbr = text12(:5) + sgn = ' ' + other = ' ' + select case(tabEG(i)%limite) + case(Tri_Refl) + sgn = '*' + case(Tri_Trans) + transInd = findParalleleWithTrans(i,szEG) + text12=i2s(transInd) + if (isSameWayEG(tabEG(i),tabEG(transInd))) then + other = '-'//text12(:6) + else + other = text12(:6) + end if + case(Tri_Cos) + sgn = '+' + end select + if (tabEG(i)%isPlan) then + a = real(tabEG(i)%dy - tabEG(i)%y) + b = real(tabEG(i)%x - tabEG(i)%dx) + d = -real(tabEG(i)%y*tabEG(i)%dx - tabEG(i)%x*tabEG(i)%dy) + buffer = adjustl("surf "//sgn//nbr//trim(" "//other)//" plane") + ind = len_trim(buffer) + 1 + write(buffer(ind:),*) a,b,c,d + else + xx = real(tabEG(i)%x) + yy = real(tabEG(i)%y) + rr = real(tabEG(i)%r) + buffer = adjustl("surf "//sgn//nbr//" cyl") + ind = len_trim(buffer) + 1 + write(buffer(ind:),*) xx,yy,rr + end if + write(fileSerpent,'(a)') trim(buffer) + 20 continue + end do + if (nbEGCL > 0) then + text12 = i2s(szEG+1) + nbr = text12(:5) + buffer = adjustl("surf "//sgn//nbr//" cuboid ") + ind = len_trim(buffer) + 1 + write(buffer(ind:),*) (cuboid(i),i=1,6) + write(fileSerpent,'(a)') trim(buffer) + endif + deallocate(tabEGCL) + !data card + + call destroyMC() + end subroutine generateSerpentFile + + subroutine putOn80col(outFile,strIn) + integer,intent(in) :: outFile + character(len=*),intent(in) :: strIn + + integer :: lg,lastBlank + character(len=15) :: frm + character(len=80) :: truncStr + character(len=len(strIn)) :: str + + str = strIn + do + lg = len_trim(str) + if (lg <= 80) then + frm = "(a"//i2s(lg)//")" + write(outFile,frm) str + return + end if + truncStr = str(1:78) + do lastBlank = 78,1,-1 + if (truncStr(lastBlank:lastBlank)==' ') exit + end do + truncStr = trim(str(1:lastBlank-1))//' &' + frm = "(a"//i2s(len_trim(truncStr))//")" + write(outFile,frm) truncStr + str = ' '//adjustl(str(lastBlank:)) + end do + end subroutine putOn80col + + function findParalleleWithTrans(ind,szEG) + integer,intent(in) :: ind,szEG + integer :: findParalleleWithTrans + + integer :: i + + findParalleleWithTrans = 0 + do i = 1,szEG + if (i==ind) cycle + if (.not.tabEG(i)%isPlan) cycle + if (tabEG(i)%limite/=Tri_Trans) cycle + if (.not.estColi(tabEG(i)%dx-tabEG(i)%x,tabEG(i)%dy-tabEG(i)%y, & + tabEG(ind)%dx-tabEG(ind)%x,tabEG(ind)%dy-tabEG(ind)%y)) cycle + findParalleleWithTrans = i + return + end do + call XABORT("G2MC: error, no parallel side found for translation & + &boundary condition") + end function findParalleleWithTrans + +end module monteCarlo diff --git a/Dragon/src/g2s_generatingPS.f90 b/Dragon/src/g2s_generatingPS.f90 new file mode 100644 index 0000000..bbf12b7 --- /dev/null +++ b/Dragon/src/g2s_generatingPS.f90 @@ -0,0 +1,920 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Generate a Postscript representation of the surfacic geometry. +! +!Copyright: +! Copyright (C) 2001 Ecole Polytechnique de Montreal. +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): +! G. Civario (CS-SI) +! +!Comments: +! Ce fichier est derive de la bibliotheque PSPLOT de Kevin E. Kohler, +! developpee au Nova Southeastern University Oceanographic Center en Floride. +! Le code inital a simplement ete encapsule dans un module, pour eviter les +! eventuels conflics de noms, et ampute de toutes les routines non utilisees +! ici. +! Quelques modifications mineures ont par ailleurs ete faites, pour permettre +! la production d'un fichier eps, et assurer le centrage de la figure. +! +!----------------------------------------------------------------------- +! +module derivedPSPLOT + !!implicit none + + logical,save :: g_psp_isEpsFile !true if file is eps + real ,save :: g_psp_bBoxXmin,g_psp_bBoxYmin,g_psp_bBoxXmax,g_psp_bBoxYmax + +contains + + subroutine line(fx,fy,tx,ty) + implicit none + double precision,intent(in) :: fx,fy,tx,ty + + call PLOT(real(fx),real(fy),3) + call PLOT(real(tx),real(ty),2) + end subroutine line + + subroutine arc(xc,yc,rad,ang1,ang2) + double precision,intent(in) :: xc,yc,rad,ang1,ang2 + double precision conver,radi,xci,yci + character*132 cmdstr + common/plt1/cmdstr + common/cnvcom/conver + radi=rad*conver + xci=xc*conver + yci=yc*conver + cmdstr=' ' + write(cmdstr,'(1p,e14.6,'' '',e14.6,'' '',e14.6,'' '',2e14.6,'' arcit'')')& + & xci,yci,radi,ang1,ang2 + call filler + end subroutine arc + + subroutine filler + !nfild is the last position filled in the compressed aaa buffer array + !work is a work array used to load array aaa + character*132 cmdstr,cmdc(132)*1 + common/plt1/cmdstr + common/outcom/iunit + logical ispace + !equivalence (cmdstr,cmdc(1)) + ibslash=92 + lc=0 + lcc=lenstr(cmdstr,132) + ispace=.false. + + !itot is running total of left/right parentheses in text string + !if itot=0 then we are not in text mode, i.e. left=right + + itot=0 + icclst=-999 + do l=1,lcc + icc=ichar(cmdstr(l:l)) + if(icc.eq.32.and.ispace.and.itot.eq.0) cycle !Don't place 2 or more + ! spaces together if + ! not in text mode + if(icc.ge.32.and.icc.le.127) then + lc=lc+1 + cmdc(lc)=cmdstr(l:l) + endif + if(icc.eq.32) then + ispace=.true. + else + ispace=.false. + endif + if(icc.eq.40.and.icclst.ne.ibslash)itot=itot+1 + if(icc.eq.41.and.icclst.ne.ibslash)itot=itot-1 + icclst=icc + end do + + !Write cmdstr to output file + write(iunit,'(132a1)')(cmdc(ii),ii=1,lc) + return + end subroutine filler + + subroutine psinit(fileNbr,portrait) + !initializes plot for hp plotter + integer fileNbr + double precision conver + logical first,portrait,prtrt + character*132 cmdstr,curfnt + character*80 fileout + character tim*10,dat*8,zn*5 + integer*4 val(8) + character*1 timer(8),dater(9) + equivalence(timer(1),tim),(dater(1),dat) + common/conre1/ioffp,spval + common/plt1/cmdstr + common/cnvcom/conver + common/plt2/fac + common/io/fileout,inew + common/kkplot/szrat + common/chpcom/ientry,prtrt + common/fntcom/curfnt,ifntsz,nfont + common/outcom/iunit + common/pagcom/npage + !data ioffp,spval/0,0.0/ + ioffp=0 + spval=0.0 + + !Set conversion factor (conver=72. for inches, conver=72./25.4 for mm, etc.) + !conver + conver=72.d0 + + npage=1 + + prtrt=portrait + + first=.true. + pi=4.*abs(atan(1.)) + + !Use default name unless newdev has already been called (inew=999). + if(inew.eq.0) then + fileout='psplot.ps' + inew=1 + else if(inew.eq.999)then + inew=1 + endif + + !output file opened + iunit=fileNbr + + cmdstr='%!PS-Adobe-3.0' + if (g_psp_isEpsFile) cmdstr='%!PS-Adobe-3.0 EPSF-3.0' + call filler + + cmdstr= '%%Title: '//fileout(1:lenstr(fileout,80)) + + call filler + call date_and_time(dat,tim,zn,val) + if(timer(1).eq.' ')timer(1)='0' + if(dater(1).eq.' ')dater(1)='0' + cmdstr= '%%CreationDate: '//DAT//' '//TIM + call filler + + cmdstr= '%%Creator: PSPLOT PostScript Plotting Package' + call filler + + if (g_psp_isEpsFile) then + cmdstr='%%BoundingBox: 0 0 595 842' + call filler + end if + + cmdstr= '%%Pages: (atend)' + call filler + + cmdstr='%%EndComments' + call filler + + cmdstr='%Library Creator: Kevin E. Kohler ' + call filler + + cmdstr='%%BeginProlog' + call filler + + cmdstr='/inch {72 mul} bind def' + call filler + + cmdstr='/Ah {moveto lineto lineto stroke} def' + call filler + + cmdstr='/Ar {moveto 2 copy lineto 4 -2 roll' + call filler + cmdstr=' moveto lineto lineto stroke } def' + call filler + + cmdstr='/arcit {S /A2 exch def /A1 exch def /Rad exch def' + call filler + cmdstr=' /Yc exch def /Xc exch def' + call filler + cmdstr=' Xc Rad A1 cos mul add Yc Rad A1 sin mul add' + call filler + cmdstr=' moveto newpath' + call filler + cmdstr=' Xc Yc Rad A1 A2 arc stroke} def' + call filler + + cmdstr='/C {/Rad exch def /Yc exch def /Xc exch def' + call filler + cmdstr=' Xc Yc Rad 0 360 arc closepath' !closepath needed to + !avoid notch + call filler !with fat line width + cmdstr=' } def' + call filler + + cmdstr='/c0sf {closepath 0 setgray fill} def' + call filler + + cmdstr='/cf {closepath fill} def' + call filler + + cmdstr='/Cs {closepath stroke} def' + call filler + + cmdstr='/Cln {newpath 3 1 roll' + call filler + cmdstr=' moveto {lineto} repeat clip newpath' + call filler + cmdstr=' } def' + call filler + + cmdstr='/Cs {closepath stroke} def' + call filler + + cmdstr='/Fb {newpath moveto ' + call filler + cmdstr=' Dx 0 rlineto 0 Dy rlineto Dx neg 0 rlineto closepath' + call filler + cmdstr=' fill } def' + call filler + + cmdstr='/Fbn { newpath 3 1 roll moveto {lineto} repeat' + call filler + cmdstr=' closepath fill } def' + call filler + + cmdstr='/Fbnc { newpath 3 1 roll moveto' + call filler + cmdstr=' {lineto} repeat closepath fill } def' + call filler + + cmdstr='/L /lineto load def' + call filler + + cmdstr='/Lend {/Strlen exch stringwidth pop def} def' + call filler + + !Define stringlength slightly increased for integrand placement + cmdstr='/Lendi {/Strlen exch stringwidth pop 1.5 mul def} def' + call filler + + !Define stringlength slightly increased for summation placement + cmdstr='/Lends {/Strlen exch stringwidth pop 1.1 mul def} def' + call filler + + cmdstr='/Lenssd {/Strlenss exch stringwidth pop 3 mul 4 div def} def' + call filler + + cmdstr='/LSM {2 copy lineto stroke moveto} def' + call filler + + cmdstr='/lsm {Xp Yp lineto stroke mover} def' + call filler + + cmdstr='/M /moveto load def' + call filler + + cmdstr='/mover {Xp Yp moveto} def' + call filler + + cmdstr='/Np {newpath} def' + call filler + + cmdstr='/S /stroke load def' + call filler + + cmdstr='/Sc {setrgbcolor} def' + call filler + + cmdstr='/Sg {setgray} def' + call filler + + cmdstr='/Setf {Curfnt exch scalefont setfont} def' + call filler + + cmdstr='/SM {stroke moveto} def' + call filler + + cmdstr='/sm {stroke mover} def' + call filler + + write(cmdstr,'(''/Slw {'',f7.4,'' mul setlinewidth} def'')') conver + call filler + + cmdstr='/Slw0 {.24 setlinewidth} bind def' !Minimum line width 300 dpi + call filler + + !Add this for fun + cmdstr= '%Line Breaking Procedure' + call filler + + cmdstr='/TurnLineFL' + call filler + cmdstr=' { /T exch def /spacewidth space stringwidth pop def' + call filler + cmdstr=' /currentw 0 def /wordspace_count 0 def' + call filler + cmdstr=' /restart 0 def /remainder T def' + call filler + cmdstr=' {remainder space search' + call filler + cmdstr=' {/nextword exch def pop' + call filler + cmdstr=' /remainder exch def' + call filler + cmdstr=' /nextwordwidth nextword stringwidth pop def' + call filler + cmdstr=' currentw nextwordwidth add lw gt' + call filler + cmdstr=' {T restart wordspace_count restart sub' + call filler + cmdstr=' getinterval showline' + call filler + cmdstr=' /restart wordspace_count def' + call filler + cmdstr=' /currentw nextwordwidth spacewidth add def' + call filler + cmdstr=' }' + call filler + cmdstr=' {/currentw currentw nextwordwidth add' + call filler + cmdstr=' spacewidth add def' + call filler + cmdstr=' } ' + call filler + cmdstr=' ifelse' + call filler + cmdstr=' /wordspace_count wordspace_count' + call filler + cmdstr=' nextword length add 1 add def' + call filler + cmdstr=' }' + call filler + cmdstr=' {pop exit}' + call filler + cmdstr=' ifelse' + call filler + cmdstr=' } loop' + call filler + cmdstr=' /lrem remainder stringwidth pop def' + call filler + cmdstr=' currentw lrem add lw gt' + call filler + cmdstr=' {T restart wordspace_count restart sub ' + call filler + cmdstr=' getinterval showline remainder showline}' + call filler + cmdstr=' {/lastchar T length def' + call filler + cmdstr=' T restart lastchar restart sub getinterval ' + call filler + cmdstr=' lm y moveto show}' + call filler + cmdstr=' ifelse' + call filler + cmdstr=' } def' + call filler + + cmdstr=' /parms {/y exch def /lm exch def /rm exch def' + call filler + cmdstr=' /leading exch def /pointsize exch def' + call filler + cmdstr=' /lw rm lm sub def' + call filler + cmdstr=' findfont pointsize scalefont setfont ' + call filler + cmdstr=' /showline {lm y moveto show' + call filler + cmdstr=' /y y leading sub def} def' + call filler + cmdstr=' lm y moveto } def' + call filler + + cmdstr='/Xposd {/Xpos exch def} def' + call filler + + cmdstr='/Xposjd {/Xpos exch Xpos exch Strlen mul sub def} def' + call filler + + cmdstr='/xydef {/Xp Xpos def /Yp Ypos def} def' + call filler + + cmdstr='%/Xypd {/Yp exch def /Xp exch def} def' + call filler + + cmdstr='/Xypos0d {/Xpos0 Xpres def /Ypos0 Ypres def} def' + call filler + + cmdstr='/Xyprset {dup /Xpres exch cos Strlen mul Xpos add def' + call filler + cmdstr=' /Ypres exch sin Strlen mul Ypos add def} def' + call filler + + cmdstr='/Xyprset0 {dup /Xpres exch cos Strlen mul Xpos0 add def' + call filler + cmdstr=' /Ypres exch sin Strlen mul Ypos0 add def} def' + call filler + + cmdstr='/Yposd {/Ypos exch def} def' + call filler + + cmdstr='/Yposjd {/Ypos exch Ypos exch Strlen mul sub def} def' + call filler + + cmdstr='/space ( ) def' + call filler + + cmdstr='%%EndProlog' + call filler + + cmdstr='%%Page: 1 1' + call filler + + !Szrat is the ratio of width to height of characters. Determined empirically. + szrat=.6 + !Set initial font to helvetica, 12 point + ifntsz=12 + call setfnt(20) + !Set factor to 1 for initialization, reset later if chopit called + fac=1. + call factor(fac) + + fact=min(595./(g_psp_bBoxXmax-g_psp_bBoxXmin), & + 842./(g_psp_bBoxYmax-g_psp_bBoxYmin))/72. + write(cmdstr,'(2f8.3,a)') fact,fact,' scale' + call filler + + write(cmdstr,'(1p,2e14.6,a)') -g_psp_bBoxXmin*72., & + -g_psp_bBoxYmin*72., & + ' translate' + call filler + + !Set initial lineweight to 0 + call setlw(0.) + !Set initial grayscale to 0 + call setgry(0.) + !Set initial rgb colors to black(0) + call setcolr(0.,0.,0.) + + xsh=0. + ysh=0. + call plot(xsh,ysh,-3) + end subroutine psinit + + subroutine setcolr(red,green,blue) + !this routines sets the current color + !red, green blue are the saturation ratios between 0 and 1 + character*132 cmdstr + common/plt1/cmdstr + common/colrcom/cred,cgreen,cblue,cgry + + r=red + r=amin1(1.,r) + r=amax1(0.,r) + g=green + g=amin1(1.,g) + g=amax1(0.,g) + b=blue + b=amin1(1.,b) + b=amax1(0.,b) + + cmdstr=' ' + write(cmdstr,'(3F7.3,'' Sc'')')r,g,b + call filler + cred=r + cgreen=g + cblue=b + end subroutine setcolr + + subroutine setfnt(numfnt) + !This routines changes the typeface of the current font + character*132 cmdstr,scrc + character*132 curfnt + common/fntcom/curfnt,ifntsz,nfont + character*40 fntnam(35) + common/plt1/cmdstr + data fntnam/'AvantGarde-Book','AvantGarde-BookOblique',& + &'AvantGarde-Demi','AvantGarde-DemiOblique','Bookman-Demi',& + &'Bookman-DemiItalic','Bookman-Light','Bookman-LightItalic',& + &'Courier-Bold','Courier-BoldOblique','Courier-Oblique', 'Courier',& + &'Helvetica-Bold','Helvetica-BoldOblique', 'Helvetica-Narrow-Bold',& + &'Helvetica-Narrow-BoldOblique', 'Helvetica-Narrow-Oblique',& + &'Helvetica-Narrow', 'Helvetica-Oblique','Helvetica',& + &'NewCenturySchlbk-Bold','NewCenturySchlbk-BoldItalic',& + &'NewCenturySchlbk-Italic','NewCenturySchlbk-Roman',& + &'Palatino-Bold','Palatino-BoldItalic','Palatino-Italic',& + &'Palatino-Roman','Symbol','Times-Bold','Times-BoldItalic',& + &'Times-Italic','Times-Roman','ZapfChancery-MediumItalic',& + &'ZapfDingbats'/ + + nfont=numfnt + if(numfnt.lt.1.or.numfnt.gt.35) then + write(6,*) 'Invalid font number encountered in **setfnt**' + write(6,*) 'Using Helvetica default' + nfont=20 + endif + scrc=fntnam(nfont) + cmdstr='/Curfnt /'//scrc(1:lenstr(scrc,132))//' findfont def' + call filler + write(cmdstr,'(i3,'' Setf'')')ifntsz + call filler + end subroutine setfnt + + subroutine setgry(gry) + !This routines sets the current gray level + !Gry is set to be between 0 and 1 + character*132 cmdstr + common/plt1/cmdstr + common/colrcom/cred,cgreen,cblue,cgry + + g=gry + g=amin1(1.,g) + g=amax1(0.,g) + + cmdstr=' ' + write(cmdstr,'(F7.3,'' Sg'')')g + call filler + cgry=g + end subroutine setgry + + subroutine setlw(rlwi) + !this routines sets the current linewidth + !rlwi is linewidth in inches + character*132 cmdstr + common/plt1/cmdstr + common/lcom/curwid + + if(abs(rlwi).lt.1.e-5) then !0 + cmdstr='Slw0' + else + cmdstr=' ' + write(cmdstr,'(F7.3,'' Slw'')')rlwi + endif + call filler + curwid=rlwi + end subroutine setlw + + subroutine factor(facc) + common/plt2/fac + character*132 cmdstr + common/plt1/cmdstr + + !Unscale previous scaling + recipx=1./fac + recipy=1./fac + write(cmdstr,'(2f7.3,a)')recipx,recipy,' scale' + call filler + fac=facc + write(cmdstr(:14),'(2f7.3)')fac,fac + call filler + end subroutine factor + + subroutine plot(xcall,ycall,ip) + double precision conver + character*132 cmdstr + character*80 scr + common/plt1/cmdstr + common/cnvcom/conver + common/outcom/iunit + common/pagcom/npage + + ipp=iabs(ip) + + if(ip.eq.999) then !Terminate plot session. + cmdstr='stroke showpage' + call filler + + cmdstr='%%Trailer' + call filler + + write(scr,'(i6)')npage + call blkstp(scr,80,scr,nch) + cmdstr='%%Pages: '//scr(1:nch) + call filler + + cmdstr='%%EOF' + call filler + + return + endif + + !Moving pen + if(ipp.eq.3) then !Stroke to paint previous path, then moveto + write(cmdstr,'(1p,2e14.6,'' SM'')')xcall*conver,ycall*conver + else !Lineto + write(cmdstr,'(1p,2e14.6,'' LSM'')')xcall*conver,ycall*conver + endif + call filler + + !Reset origin if ip.lt.0 + if(ip.lt.0) then + write(cmdstr,'(1p,2e14.6,'' translate'')')xcall*conver,ycall*conver + call filler + ipen=ipp + endif + + end subroutine plot + + subroutine plotnd + call plot(0.,0.,999) + end subroutine plotnd + + subroutine circle(xc,yc,rad,fill) + double precision,intent(in) :: xc,yc,rad + logical,intent(in) :: fill + double precision conver,xci,yci,radi + character*132 cmdstr,scrc + common/plt1/cmdstr + common/cnvcom/conver + xci=xc*conver + yci=yc*conver + radi=rad*conver + scrc=' ' + write(scrc,'(1p,e14.6,'' '',e14.6,'' '',e14.6,'' C'')') xci,yci,radi + if(fill) then + cmdstr='Np '//scrc(1:lenstr(scrc,132))//' fill' + else + cmdstr='Np '//scrc(1:lenstr(scrc,132))//' stroke' + endif + call filler + end subroutine circle + + function lenstr(string,ls) + !This routine finds actual length of string by eliminating trailing blanks + character*(*) string + + do i=ls,1,-1 + is=i + if(string(i:i).ne.char(32)) goto 10 + enddo + is=0 +10 lenstr=is + end function lenstr + + subroutine blkstp(ch,ndim,a,leng) + !character*1 ch(ndim),a(ndim) + character(len=*) ch,a + !Strip out blanks only (leave in esc, etc.) + i=1 + leng=0 +10 continue + if(ichar(ch(i:i)).ne.32)then + leng=leng+1 + a(leng:leng)=ch(i:i) + endif + + if(i.eq.ndim) then + !Blankfill remainder of output array + do l=leng+1,ndim + a(l:l)=' ' + enddo + return + endif + + i=i+1 + goto 10 + end subroutine blkstp + + subroutine keknum(xp,yp,size,fpn,ang,ndec,mjus) + !Just assume that user really wants kekflt. + call kekflt(xp,yp,size,fpn,ang,ndec,mjus) + end subroutine keknum + + subroutine kekflt(xp,yp,size,fpn,ang,ndec,mjus) + dimension ichrnum(20) + + fnum=fpn + !Get number in character form + call numsym(fnum,ndec,ichrnum,ndigit,.false.) + call keksym(xp,yp,size,ichrnum,ang,ndigit,mjus) + end subroutine kekflt + + subroutine keksym(xp,yp,size,ltitle1,ang,nchar1,mjus) + double precision conver + character*132 cmdstr + character*132 curfnt,scrc + common/fntcom/curfnt,ifntsz,nfont + character*80 titlec,titleb + character*1 bslash + dimension ltitle(20),ltitle1(20) + equivalence(ititle,ltitle(1)) + common/plt1/cmdstr + common/cnvcom/conver + common/kkplot/szrat + + !Stroke previous paths before this write + cmdstr='S' + call filler + + bslash=char(92) + + pi=4*abs(atan(1.)) + + if(nchar1.eq.-999) then !octal code + do n=1,20 + ltitle(n)=ltitle1(n) + enddo + nchar=1 + else + nchar=nchar1 + write(titlec,'(20a4)')ltitle1 + if(iabs(nchar).lt.80)titlec(nchar+1:80)=' ' + read(titlec,'(20a4)')ltitle + endif + + !Choose proper font height, using current font + mchar=iabs(nchar) + !Set character size + iht=max(1,int(size*conver/.6)) !.6 FACTOR IS EMPIRICAL + + if(iht.ne.ifntsz) then + cmdstr=' ' + write(cmdstr,'(I3,'' Setf'')')iht + call filler + ifntsz=iht + endif + + if(nchar1.eq.-999) then !Octal code + write(titlec,'(A1,I10)')bslash,ititle + call blkstp(titlec,80,titlec,numc) + else + write(titlec,'(20a4)')ltitle + !Check if titlec contains ( or ) or \. These characters must be treated + !specially by preceding them with a "\". Do this to ( and ) even though + !they might be balanced, i.e. () within a string, which can be treated + !normally. + + titleb=titlec + numc=0 + do m=1,mchar + if(titleb(m:m).eq.'('.or.titleb(m:m).eq.')' .or. & + & titleb(m:m).eq.bslash) then + numc=numc+1 + titlec(numc:numc)=bslash + endif + numc=numc+1 + titlec(numc:numc)=titleb(m:m) + enddo + endif + + mchar=numc + xpos=xp + ypos=yp + if(nchar.lt.0) then + njus=0 + else + njus=mjus + endif + rsize=size + !Character space height is 2.0 x char height + !Character space width is 1.5 x char width + !Actual string length is (nc-1)*1.5*char width + char width + strlen=(rsize*szrat)*1.5*(mchar-1.)+rsize*szrat + + if(xpos.eq.999.) then + cmdstr='/Xpos Xpres def' + njus=0 + else + cmdstr=' ' + write(cmdstr,'(1p,e14.6,'' Xposd'')')xp*conver + endif + call filler + + if(ypos.eq.999.) then + cmdstr='/Ypos Ypres def' + njus=0 + else + cmdstr=' ' + write(cmdstr,'(1p,e14.6,'' Yposd'')')yp*conver + endif + call filler + + if(njus.ne.0.and.njus.ne.1.and.njus.ne.2) then + print 110, njus +110 format(1x,'incorrect justification code ',i5,'found in ',& + &'KEKSYM, zero used') + njus=0 + endif + !Strlen has already been "factored" by the choice of font height + !Since it will eventually be factored again, we must divide by + !factor now. + cmdstr='('//titlec(1:mchar)//') Lend' + arg=ang*4.*abs(atan(1.))/180. + xarg=cos(arg)*njus/2. + yarg=sin(arg)*njus/2. + + if(xarg.ne.0.) then + scrc=' ' + write(scrc,'(f7.3,'' Xposjd'')')xarg + cmdstr=cmdstr(1:lenstr(cmdstr,132))//' '// scrc(1:lenstr(scrc,132)) + endif + + if(yarg.ne.0.) then + scrc=' ' + write(scrc,'(f7.3,'' Yposjd'')')yarg + cmdstr=cmdstr(1:lenstr(cmdstr,132))//' '// scrc(1:lenstr(scrc,132)) + endif + + if (nchar.eq.-1) then !centered symbol + high=rsize + wide=high*szrat + + xpos=xpos+high/2.*sin(arg)-wide/2.*cos(arg) + ypos=ypos-high/2.*cos(arg)-wide/2.*sin(arg) + + xarg=high/2.*sin(arg)-wide/2.*cos(arg) + yarg=-high/2.*cos(arg)-wide/2.*sin(arg) + + if(xarg.ne.0.) then + scrc=' ' + write(scrc, '(''/Xpos Xpos'',1p,e14.6,'' add def'')')xarg*conver + cmdstr=cmdstr(1:lenstr(cmdstr,132))//' '// scrc(1:lenstr(scrc,132)) + endif + + if(yarg.ne.0.) then + scrc=' ' + write(scrc,'(''/Ypos Ypos'',1p,e14.6,'' add def'')')yarg*conver + cmdstr=cmdstr(1:lenstr(cmdstr,132))//' '// scrc(1:lenstr(scrc,132)) + endif + endif + + call filler + + !Move pen to proper coordinates + scrc='xydef mover' + cmdstr=scrc(1:lenstr(scrc,132)) + + !Set angle + if(ang.ne.0.) then + scrc=' ' + write(scrc,'(F7.1,'' rotate'')') ang + cmdstr=cmdstr(1:lenstr(cmdstr,132))//' '// scrc(1:lenstr(scrc,132)) + endif + + scrc='('//titlec(1:mchar)//') show' + cmdstr=cmdstr(1:lenstr(cmdstr,132))//' '// scrc(1:lenstr(scrc,132)) + + !Reset angle + if(ang.ne.0.) then + scrc=' ' + write(scrc,'(F7.1,'' rotate'')') -ang + cmdstr=cmdstr(1:lenstr(cmdstr,132))//' '// scrc(1:lenstr(scrc,132)) + endif + call filler + + !Start next char at .5 char width away + argdeg=arg*180./pi + cmdstr=' ' + write(cmdstr,'(f6.1,'' Xyprset'')')argdeg + call filler + end subroutine keksym + + subroutine numsym(fpn,ndec,itext,nchar,eform) + !eform: true for exponential format + !false for floating pt format + logical eform + dimension itext(20) + character*10 ifrmt + character*80 a + a=' ' + + !Check if ndec is valid + if(ndec.gt.15) then + print 100, ndec +100 format(1x,'In call to numsym, ndec gt 15 ',i20,' program',' abandoned') + stop + else if(eform.and.ndec.lt.0) then + print 110, ndec +110 format(1x,'in numsym, exponential format specified with ','ndec= '& + &,i3,' program abandoned') + stop + endif + + if(eform) then + write(ifrmt,'(''(1pe16.'',i2,'')'')')ndec + else if(ndec.lt.0) then + ifrmt='(f16.1)' + else + write(ifrmt,'(''(f16.'',i2,'')'')')ndec + endif + + write(a,ifrmt)fpn + + !Strip off all blanks in a + call blkstp(a,80,a,nchar) + ipos=index(a,'.') + if(eform) then + if(ndec.eq.0) then + !Delete characters between '.' and 'E' + ie=index(a,'E') + do n=ie,nchar + nind=ipos+n-ie+1 + a(nind:nind)=a(n:n) + enddo + nchar=nchar-(ie-ipos-1) + endif + else if(ndec.lt.0) then + nchar=ipos-1 + else if(ndec.eq.0) then + nchar=ipos + endif + read(a,'(20a4)')itext + end subroutine numsym + +end module derivedPSPLOT diff --git a/Dragon/src/g2s_generatingSAL.f90 b/Dragon/src/g2s_generatingSAL.f90 new file mode 100644 index 0000000..f69e566 --- /dev/null +++ b/Dragon/src/g2s_generatingSAL.f90 @@ -0,0 +1,317 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Generate the surfacic geometry ascii file. +! +!Copyright: +! Copyright (C) 2001 Ecole Polytechnique de Montreal. +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): +! G. Civario (CS-SI) +! +!Comments: +! Attention, comme SAL est toujours en phase de developpement, des +! modifications ont ete apportees a la routine "calculTypgeo" pour bien prendre +! en compte les condition limites de reflexion. En effet, celle-ci sont +! traitees comme des symetries axiales, dont l'axe est le bord de la geometrie. +! Cependant, une evolution previsible de SAL devrait rendre obsolette cette +! assimilation, et permettre une prise en compte directe des reflexion. +! \\ +! fonctions: +! - generateSALFile : creation du fichier de donnees SAL +! - calculTypgeo : determination des donnees typgeo et nbfold +! - calculDefaultCl : dertermination de la meilleur condition limite par +! defaut +! +!----------------------------------------------------------------------- +! +module generSAL + use boundCond + use cellulePlaced + use constType + use constUtiles + use segArc + + implicit none + +contains + + subroutine generateSALFile(fileNbr,szSA,nbNode,nbCLP,nbFlux,nbMacro,merg,imacro) + integer,intent(in) :: fileNbr,szSA,nbNode,nbCLP,nbFlux,nbMacro + integer,dimension(nbNode),intent(in) :: merg + integer,dimension(nbFlux),intent(in) :: imacro + + type(t_segArc) :: sa + integer :: i,j,nmoins,nplus + integer :: typgeo,nbfold,defautCl + integer,dimension(:),allocatable :: milTab + integer,dimension(:),allocatable :: tmpTab + real :: cx,cy,tx,ty,delta,albedo + character(len=4) :: strDCL + + rewind(fileNbr) + !preparer les donnees de CL pour SAL + call prepareSALBCData(szSA,nbCLP) + + write(fileNbr,'(a5)') 'BEGIN' + + write(fileNbr,'(/a24)') 'DEFINE DOMAINE' + write(fileNbr,'(a24/)') '==============' + + write(fileNbr,'(a28/)') '1.main dimensions:' + write(fileNbr,'(a48)') '*typgeo nbfold nbnode nbelem nbmacro nbflux' + call calculTypgeo(typgeo,nbfold) + write(fileNbr,'(10'//formati//')') typgeo,nbfold,nbNode,szSA,nbMacro,nbFlux + + write(fileNbr,'(/a37)') '2.impression and precision:' + write(fileNbr,'(/a21)') '*index kndex prec' + write(fileNbr,'(10'//formati//')') 0,0,1 + + write(fileNbr,'(/a39)') '3.precision of geometry data:' + write(fileNbr,'(/a4)') '*eps' + write(fileNbr,'('//formatr//')') gSALeps + + write(fileNbr,'(/a58)') '4.flux region number per geometry region (mesh):' + write(fileNbr,'(/a6)') '*merge' + write(fileNbr,'(10'//formati//')') (merg(i),i=1,nbNode) + + write(fileNbr,'(/a29)') '5.name of geometry:' + write(fileNbr,'(/a12)') '*macro_names' + write(fileNbr,'(4'//formath//')') (i,i=1,nbMacro) + + write(fileNbr,'(/a47)') '6.macro order number per flux region:' + write(fileNbr,'(/a14)') '*macro_indices' + allocate(tmpTab(nbFlux)) + tmpTab(:nbFlux) = 0 + do i = 1,nbNode + tmpTab(merg(i)) = imacro(i) + enddo + write(fileNbr,'(10'//formati//')') (tmpTab(i),i=1,nbFlux) + deallocate(tmpTab) + + write(fileNbr,'(/a57)') '7.read integer and real data for each elements:' + do i = 1,szSA + sa = tabSegArc(i) + cx = real(sa%x) + cy = real(sa%y) + if (sa%typ==tseg) then + nmoins = sa%noded + nplus = sa%nodeg + tx = real(sa%dx-sa%x) + ty = real(sa%dy-sa%y) + delta = 0. + else + nmoins = sa%nodeg + nplus = sa%noded + tx = real(sa%r) + if (sa%typ==tarc) then + ty = real(sa%a*rad2deg) + if (sa%b>sa%a) then + delta = real((sa%b-sa%a)*rad2deg) + else + delta = real((sa%b-sa%a)*rad2deg+360.d0) + end if + else + ty = 0. + delta = 0. + end if + end if + write(fileNbr,*) + write(fileNbr,*) 'elem =',i + write(fileNbr,'(a22)') '*type node- node+' + write(fileNbr,'(10'//formati//')') tabSegArc(i)%typ,nmoins,nplus + write(fileNbr,'(a63)') '*cx cy ex or R & + &ey or theta1 theta2' + write(fileNbr,'(5'//formatr//')') cx,cy,tx,ty,delta + end do + + write(fileNbr,'(/a63)') '8.read integer and real data for boundary conditions:' + !test de la condition aux limites par defaut en fonction du type de geo + call calculDefaultCl(defautCl,albedo,strDCL) + write(fileNbr,'(/a40)') '*defaul nbbcda allsur divsur ndivsur' + write(fileNbr,'(10'//formati//')') defautCl,nbCLP,0,0,0 + write(fileNbr,'(/a24)') 'DEFAULT = ' // strDCL + write(fileNbr,'(a24)') '==============' + write(fileNbr,'(/a17)') '*albedo deltasur' + write(fileNbr,'(5'//formatr//')') albedo,0.0 + do i = 1,nbCLP + write(fileNbr,*) + write(fileNbr,*) 'particular boundary condition number',i + write(fileNbr,'(/a13)') '*type nber' + write(fileNbr,'(10'//formati//')') SALbCDataTab(i)%SALtype,SALbCDataTab(i)%nber + allocate(tmpTab(SALbCDataTab(i)%nber),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: generateSALFile(1) => allocation pb") + do j = 1,SALbCDataTab(i)%nber + tmpTab(j) = SALbCDataTab(i)%elemNb(j) + end do + write(fileNbr,'(/a14)') '*elems(1,nber)' + write(fileNbr,'(10'//formati//')') tmpTab + deallocate(tmpTab) + select case(SALbCDataTab(i)%SALtype) + case(0,1) + write(fileNbr,'(/a7)') '*albedo' + write(fileNbr,'(5'//formatr//')') SALbCDataTab(i)%albedo + case(2) + write(fileNbr,'(/a11)') '*tx ty' + write(fileNbr,'(5'//formatr//')') SALbCDataTab(i)%tx,SALbCDataTab(i)%ty,0.0 + case(3,4) + write(fileNbr,'(/a22)') '*cx cy angle' + write(fileNbr,'(5'//formatr//')') SALbCDataTab(i)%cx,SALbCDataTab(i)%cy & + & ,SALbCDataTab(i)%angle + end select + end do + + allocate(milTab(nbNode),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: generateSALFile(2) => allocation pb") + do i = 1,szSA + if (tabSegArc(i)%nodeg>0) & + & milTab(tabSegArc(i)%nodeg) = tabSegArc(i)%neutronicMixg + if (tabSegArc(i)%noded>0) & + & milTab(tabSegArc(i)%noded) = tabSegArc(i)%neutronicMixd + end do + write(fileNbr,'(/a28)') '9.medium per node:' + write(fileNbr,'(/a11)') '*mil(nbreg)' + write(fileNbr,'(10'//formati//')') milTab + deallocate(milTab) + + write(fileNbr,'(/a3)') 'END' + end subroutine generateSALFile + + subroutine calculTypgeo(typgeo,nbfold) + integer,intent(out) :: typgeo,nbfold + + integer :: i + integer,dimension(4) :: bc + + ! typgeo = 0 : no information about perimeter orientation (albedo + ! information is available for each axis) + ! typgeo = 1 : information used by isotropic tracking with unfolding + ! typgeo > 1 : information used by specular tracking + typgeo = 0 ; nbfold = 0 + select case(geomTyp) + case(RecTyp) + bc=bCData%bc(1:4) + if ( (bc(1)==B_Pi_2) .and. & + (bc(2)==B_Syme .or. bc(2)==B_Refl .or. bc(2)==B_Ssym) .and. & + (bc(3)==B_Pi_2) .and. & + (bc(4)==B_Syme .or. bc(3)==B_Refl .or. bc(3)==B_Ssym)) then + typgeo = 11 + else if (all(bc==(/B_Pi_2,B_Tran,B_Pi_2,B_Tran/))) then + typgeo = 10 + else if ((bc(1)==B_Diag ) .and. & + (bc(2)==B_Syme .or. bc(2)==B_Refl .or. bc(2)==B_Ssym) .and. & + (bc(3)==B_Syme .or. bc(3)==B_Refl .or. bc(3)==B_Ssym) .and. & + (bc(4)==B_Diag )) then + typgeo = 7 + else if ((bc(1)==B_Syme .or. bc(1)==B_Refl .or. bc(1)==B_Ssym) .and. & + (bc(2)==B_Syme .or. bc(2)==B_Refl .or. bc(2)==B_Ssym) .and. & + (bc(3)==B_Syme .or. bc(3)==B_Refl .or. bc(3)==B_Ssym) .and. & + (bc(4)==B_Syme .or. bc(3)==B_Refl .or. bc(3)==B_Ssym)) then + typgeo = 6 + else if (all(bc==(/B_Tran,B_Tran,B_Tran,B_Tran/))) then + typgeo = 5 + else if (((bc(1)==B_Tran).and.(bc(2)==B_Tran)) & + & .or.((bc(3)==B_Tran).and.(bc(4)==B_Tran))) then + typgeo = 4 + else if ( ( ((bc(1)==B_Syme).or.(bc(1)==B_Refl).or.(bc(1)==B_Ssym)) & + & .and.((bc(2)==B_Syme).or.(bc(2)==B_Refl).or.(bc(2)==B_Ssym)) ) & + & .or.(((bc(3)==B_Syme).or.(bc(3)==B_Refl).or.(bc(3)==B_Ssym)) & + & .and.((bc(4)==B_Syme).or.(bc(4)==B_Refl).or.(bc(4)==B_Ssym)) ) ) then + typgeo = 3 + else if ((bc(1)==B_Pi_2).and.(bc(3)==B_Pi_2)) then + typgeo = 2 ; nbfold = 4 + else if ( ((bc(1)==B_Syme).or.(bc(1)==B_Ssym)) & + & .and.((bc(3)==B_Syme).or.(bc(3)==B_Ssym)) ) then + typgeo = 1 ; nbfold = 4 + else if ((bc(1)==B_Diag).and.((bc(3)==B_Syme).or.(bc(3)==B_Ssym)).and.(bc(4)==B_Diag)) then + typgeo = 1 ; nbfold = 8 + else if ((bc(1)==B_Diag).and.(bc(4)==B_Diag)) then + typgeo = 1 ; nbfold = 3 ! nbfold=2 is assigned below + else if ((bc(3)==B_Syme).or.(bc(3)==B_Ssym)) then + typgeo = 1 ; nbfold = 2 + end if + if (typgeo==0 .and. all((/ & + ( bc(i)==B_Refl.or.bc(i)==B_Ssym.or.bc(i)==B_Syme.or.bc(i)==B_Diag,i=1,4)/))) & + call XABORT("G2S: Type of boundary conditions not supported by SAL(1)") + case(HexTyp) + bc(1)=bCData%bc(1) + if (bCData%iHex==H_S30) then + typgeo = 1 ; nbfold = 12 + else if ((bCData%iHex==H_Complete).and.(bc(1)==B_Tran)) then + typgeo = 9 ; nbfold = 0 + end if + if (typgeo==0 .and. bCData%bc(1)==B_Refl .or. bCData%bc(1)==B_Syme) & + call XABORT("G2S: Type of boundary conditions not supported by SAL(2)") + case(TriaTyp) + if (bCData%iTri==T_S30) then + typgeo = 1 ; nbfold = 12 + end if + case(TubeTyp) + !nothing special + end select + end subroutine calculTypgeo + + subroutine calculDefaultCl(defautCl,albedo,strDCL) + integer,intent(out) :: defautCl + real,intent(out) :: albedo + character*4,intent(out) :: strDCL + + defautCl = 0 + if (bCData%bc(1) == B_Diag) THEN + albedo = 1.0 + strDCL = 'REFL' + else + albedo = 0.0 + strDCL = 'VOID' + endif + select case(geomTyp) + case(HexTyp) + select case(bCData%bc(1)) + case(B_Void,B_Syme,B_Tran) + !rien a faire + case(B_Albe) + albedo = real(bCData%albedo(1)) + strDCL = 'ALBE' + case(B_Refl) + defautCl = 1 + strDCL = 'REFL' + case default + call XABORT("G2S: Type of boundary conditions not supported by SAL(3)") + end select + case(TriaTyp) + if (bCData%iTri==T_S30 .or. bCData%iTri==T_SA60) then + select case(bCData%bc(1)) + case(B_Void,B_Syme) + !rien a faire + case(B_Albe) + albedo = real(bCData%albedo(1)) + strDCL = 'ALBE' + case(B_Refl) + defautCl = 1 + strDCL = 'REFL' + case default + call XABORT("G2S: Type of boundary conditions not supported by SAL(4)") + end select + end if + case(TubeTyp) + !ATTENTION, l'indice de la cl dans le jdd est 2 et non 1 + select case(bCData%bc(2)) + case(B_Void) + !rien a faire + case(B_Albe) + albedo = real(bCData%albedo(2)) + strDCL = 'ALBE' + case(B_Refl) + defautCl = 1 + strDCL = 'REFL' + case default + call XABORT("G2S: Type of boundary conditions not supported by SAL(5)") + end select + end select + end subroutine calculDefaultCl +end module generSAL diff --git a/Dragon/src/g2s_generatingTrack.f90 b/Dragon/src/g2s_generatingTrack.f90 new file mode 100644 index 0000000..14501ee --- /dev/null +++ b/Dragon/src/g2s_generatingTrack.f90 @@ -0,0 +1,150 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Generate data relative to gigognes originating from nodes and generate +! tracking indices assigned to them. +! +!Copyright: +! Copyright (C) 2001 Ecole Polytechnique de Montreal. +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): +! G. Civario (CS-SI) +! +!Comments: +! Ce module possede trois fonctions: +! - generateTrack : fonction d'entree du module +! - calculFinalMerge : calcul de la numerotation type dragon +! - ltVec : fonction d'ordre specifique pour des vecteurs d'entiers de tailles +! differentes +! +module track + + use cellulePlaced + use segArc + use ptNodes + implicit none + +contains + subroutine generateTrack(szP,szSa,nbNode,lgMaxGig,gig,merg) + integer,intent(in) :: szP,szSa,nbNode,lgMaxGig + integer,dimension(lgMaxGig*nbNode),intent(out) :: gig + integer,dimension(nbNode),intent(inout) :: merg + + integer :: i,lgMaxMrg,s,d,lgMaxGigTest + integer,dimension(:,:),allocatable :: mrgMat + + lgMaxGigTest = 0 + lgMaxMrg = 0 + do i = 1,szP + lgMaxGigTest = max(lgMaxGigTest,size(tabCellulePlaced(i)%gig)) + lgMaxMrg = max(lgMaxMrg,size(tabCellulePlaced(i)%mrg)) + end do + if(lgMaxGigTest /= lgMaxGig) call XABORT('g2s_generatingTrack: lgMax error') + lgMaxMrg = lgMaxMrg + 1 + allocate(mrgMat(lgMaxMrg,nbNode),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: generateTrack => allocation pb") + gig = 0 + mrgMat = 0 + do i = 1,szSa + if (tabSegArc(i)%nodeg>0.and.tabSegArc(i)%indCellPg>0) then + s = size(tabCellulePlaced(tabSegArc(i)%indCellPg)%gig) + d = (tabSegArc(i)%nodeg-1)*lgMaxGig+1 + gig(d:d+s-1) = tabCellulePlaced(tabSegArc(i)%indCellPg)%gig(1:s) + s = size(tabCellulePlaced(tabSegArc(i)%indCellPg)%mrg) + d = tabSegArc(i)%nodeg + mrgMat(1:s,d) = tabCellulePlaced(tabSegArc(i)%indCellPg)%mrg(1:s) + mrgMat(s+1,d) = merg(d) + end if + if (tabSegArc(i)%noded>0.and.tabSegArc(i)%indCellPd>0) then + s = size(tabCellulePlaced(tabSegArc(i)%indCellPd)%gig) + d = (tabSegArc(i)%noded-1)*lgMaxGig+1 + gig(d:d+s-1) = tabCellulePlaced(tabSegArc(i)%indCellPd)%gig(1:s) + s = size(tabCellulePlaced(tabSegArc(i)%indCellPd)%mrg) + d = tabSegArc(i)%noded + mrgMat(1:s,d) = tabCellulePlaced(tabSegArc(i)%indCellPd)%mrg(1:s) + mrgMat(s+1,d) = merg(d) + end if + end do + call calculFinalMerge(mrgMat,merg) + deallocate(mrgMat) + end subroutine generateTrack + + subroutine calculFinalMerge(inMat,outVec) + integer,dimension(:,:),intent(in) :: inMat + integer,dimension(:),intent(out) :: outVec + + integer :: i,j,d1,d2,maxD2 + logical :: found,sorted + integer,dimension(:),allocatable :: tmpVec + integer,dimension(:,:),allocatable :: workMat + + d1 = size(inMat,1) !profondeur max de gigogne + 1 + d2 = size(inMat,2) !nombre de nodes + maxD2 = 0 + allocate(workMat(d1,d2)) + allocate(tmpVec(d1),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: calculFinalMerge => allocation pb") + workMat(:d1,:d2) = 0 + !remplissage de workMat a l'aide d'occurences uniques de lignes de inMat + do i = 1,d2 + found = .false. + do j = 1,maxD2 + if (all(workMat(:d1,j)==inMat(:d1,i))) then + found = .true. + exit + end if + end do + if (.not. found) then + maxD2 = maxD2 + 1 + workMat(:d1,maxD2) = inMat(:d1,i) + end if + end do + !classement des lignes de workMat en ordre croissant par bubble-sort + do j = maxD2,2,-1 + sorted = .true. + do i = 1,j-1 + if (ltVec(workMat(:d1,i+1),workMat(:d1,i))) then + tmpVec(:d1) = workMat(:d1,i+1) + workMat(:d1,i+1) = workMat(:d1,i) + workMat(:d1,i) = tmpVec(:d1) + sorted = .false. + end if + end do + if (sorted) exit + end do + !remplissage de outVec en fonction de l'egalite entre les lignes de workMat + !et inMat, apres le classement + do i = 1,d2 + do j = 1,maxD2 + if (all(workMat(:d1,j)==inMat(:d1,i))) then + outVec(i) = j + exit + end if + end do + end do + + deallocate(workMat,tmpVec) + end subroutine calculFinalMerge + + function ltVec(v1,v2) + integer,dimension(:),intent(in) :: v1,v2 + logical :: ltVec + integer :: i + + do i = 1,size(v1) + if (v1(i) < v2(i)) then + ltVec = .true. + return + else if (v1(i) > v2(i)) then + ltVec = .false. + return + end if + end do + ltVec = .false. + end function ltVec +end module track diff --git a/Dragon/src/g2s_nodes.f90 b/Dragon/src/g2s_nodes.f90 new file mode 100644 index 0000000..4d3bb19 --- /dev/null +++ b/Dragon/src/g2s_nodes.f90 @@ -0,0 +1,1204 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Generate the region numerotation of the geometry. +! +!Copyright: +! Copyright (C) 2001 Ecole Polytechnique de Montreal. +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): +! G. Civario (CS-SI) +! +!Comments: +! La numerotation est utilisee pour le jeux de donnees SALOME. Il faut donner un +! numero a chaque region definie par des arcs, des segments et/ou des cercles. +! Les limites exterieures de la geometrie sont caracterisees par un indice zero +! pour le node. +! \\\\ +! Le principe de l'algorithme utilise est le suivant : +! - creation d'un tableau comportant tous les points de jonctions entre des +! elements geometriques +! - rangement des elements geometriques concernes dans le tableau, par ordre +! croissant d'angle d'incidence de leur tangente au point concerne +! - attribution arbitraire d'un numero de domaine entre les elements de ce +! tableau, avec verification de coherence, et decalage d'indice dans le +! cas de regions deja numerotees +! - prise en compte des regions annulaires (caracterisees par aucune +! intersection avec d'autre elements geometriques), et numerotation +! arbitraire de ces anneaux +! - renumerotation globale de l'ensemble des regions selon l'ordre suivant : +! ymin -> ymax ; xmin -> xmax ; amax -> amin (angle d'incidence de la +! tangente a la region au point considere). La renumerotation se fait +! suivant l'ordre des point minimaux de chacunes des regions considerees. +! \\\\ +! Finalement on obtient une numerotation de ce type : +! ________ +! | 4 | /| +! |___|2 / | +! | 1 | / 3| +! |___|/___| +! \\\\ +! variables globales: +! - tabPtNode : tableau des nodes non-annulaires +! - tabCercNode : tableau des nodes annulaires +! - tabPtMN : tableau des points minimaux de chaque node +! \\\\ +! fonctions: +! - createNodes : fonction d'entree du module +! - associatePoints : creation du tableau tabPtNode +! - addInLine : ajout d'un element dans le tableau tabPtNode +! - createPoint : construction d'un point +! - calculAngleDep : calcul l'angle d'incidence de depart ou d'arrivee d'un +! element en un point +! - isEqualPt : test de l'egalite de deux points +! - solveNodeSystem : resolution du systeme cree avec tabPtNode +! - XetNodeAY : trouve ou positionne la valeur du node avant ou apres une +! valeur d'angle d'incidence (X = g ou s ; Y = v ou p) +! - getMixAY : trouve la valeur du mix avant ou apres une valeur d'angle +! d'incidence (Y = v ou p) +! - remplaceNodeEtDecale : decalage des valeurs de node affectees dans le cas +! ou une mauvaise valeur a ete preaffectee (cf algo) +! - circularNodes : traite les nodes annulaires +! - addCircel : ajout d'un cercle dans le tableau tabCercNode +! - solveCircularNodes : resolution du systeme cree par tabCercNode +! - disproj : calcule la distance entre un point et un segment (pour +! determiner le milieux exterieur de l'anneau maximum) +! - lessThanPtNd : fonction d'ordre sur les t_ptMinNode +! - renumNodes : renumerotation des nodes dans l'ordre lexicographique +! - givePtMin : donne le point minimal d'un node +! - sortTabPtMN : trie le tableau tabPtMN +! - getGigogneData : recupere les donnees relatives a la gigogne de provenance +! du node +! - setIntIfPos : affectation d'une valeur entiere a une autre si elle est positive, +! et test de coherence si besoin est +! +!----------------------------------------------------------------------- +! +module ptNodes + use boundCond + use celluleBase + use cellulePlaced + use constUtiles + use segArc + + implicit none + + !pour les segments et les arcs + type t_ptNode + type(t_point) :: position !position + integer,dimension(:), allocatable :: listOfSA !indice dans le + !tableau des SA + logical,dimension(:), allocatable :: listOfDeparture !booleen + !correspondant + double precision,dimension(:),allocatable :: listOfDirection !angle de depart + !du SA (eventuellement decale de +/-epsilon pour les pb de tangence) + integer :: sz !taille des + !tableaux + end type t_ptNode + + type(t_ptNode),dimension(:),allocatable,save :: tabPtNode + + !pour les cercles + type t_cercNode + type(t_point) :: centre !position + logical :: withSect !dit si la cellule + !envisagee est sectorisee + integer,dimension(:),allocatable :: listOfSA !indice dans le + !tableau des SA + double precision,dimension(:),allocatable :: listOfRadius !rayons + integer :: imin !position du dernier cercle + integer :: sz !taille des tableaux + integer :: indNodeExt !numero de l'element + !donnant le node exterieur + logical :: coteGauche !dit si le node + !exterieur est celui de gauche de l'element designe par indNodeExt + end type t_cercNode + + type(t_cercNode),dimension(:),allocatable,save :: tabCercNode + + type t_ptMinNode + type(t_point) :: ptMin !point le plus bas et le plus a gauche + double precision :: alfa !angle de depart + integer :: indNode !numero du node avant renumerotation + end type t_ptMinNode + + type(t_ptMinNode),dimension(:),allocatable,save :: tabPtMN + + type t_nodeGigSect + integer :: indTabCellPlac !indice de la cellulePlaced d'origine (gig) + integer :: ring !indice de l'anneau ou se trouve le node + integer :: sect !indice du secteur angulaire du node + integer :: neutronicMix !milieux neutronique du node + integer :: merge !merge du node + integer :: dragSector !indice de type DRAGON du node + logical :: clust !.true. si le node est un cercle de cluster + integer :: imacro !TDT macro index + end type t_nodeGigSect + + type(t_nodeGigSect),dimension(:),allocatable,save :: tabNodeGigSect + +contains + + subroutine createNodes(szSA,dimTabCelluleBase,lmacro,nbNode,merg,imacro) + implicit none + integer,intent(in) :: szSA,dimTabCelluleBase + logical,intent(in) :: lmacro + integer,intent(out) :: nbNode,merg(dimTabCelluleBase),imacro(dimTabCelluleBase) + + integer :: i,nbPts,nbCers,nbNode_noclust + + !cas des Arcs et Segments du systeme : + ! preparation du tableau + + allocate(tabPtNode(szSA*2),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: createNodes(1) => allocation pb") + tabPtNode(1:szSA*2)%sz=0 + nbPts=0 + nbNode=0 + imacro(:dimTabCelluleBase)=0 + !creation d'un systeme comprenant une liste d'indices + ! d'elements geometriques decrits dans le sens trigo + ! tels que : chaque element de la liste represente + ! les elements geometriques partant ou arrivant sur un + ! point specifique (ainsi que leur sens depuis ce point : + ! .true.=>depart , .false.=>arrivee) + call associatePoints(szSA,nbPts) + + !resolution du systeme precedent + call solveNodeSystem(szSA,nbPts,nbNode) + + ! nettoyage du tableau + do i = 1,nbPts + if(allocated(tabPtNode(i)%listOfSA)) & + deallocate(tabPtNode(i)%listOfSA) + if(allocated(tabPtNode(i)%listOfDeparture)) & + deallocate(tabPtNode(i)%listOfDeparture) + if(allocated(tabPtNode(i)%listOfDirection)) & + deallocate(tabPtNode(i)%listOfDirection) + enddo + deallocate(tabPtNode) + + !prise en compte des cercles complets : + ! preparation du tableau + allocate(tabCercNode(szSA),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: createNodes(2) => allocation pb") + do i = 1,szSA + tabCercNode(i)%imin=0 + tabCercNode(i)%sz=0 + tabCercNode(i)%indNodeExt=-1 + enddo + !on classe les cercles suivant leur centre, et par rayon croissant, + ! en ajoutant dans la liste en derniere position un arc de cercle ou un + ! segment le plus proche du plus grand cercle, pour donner une reference + ! de Node + nbCers = 0 + nbNode_noclust=nbNode + call circularNodes(szSA,nbNode,nbCers) + + ! nettoyage du tableau + do i = 1,nbCers + if(allocated(tabCercNode(i)%listOfSA)) & + deallocate(tabCercNode(i)%listOfSA) + if(allocated(tabCercNode(i)%listOfRadius)) & + deallocate(tabCercNode(i)%listOfRadius) + enddo + deallocate(tabCercNode) + + !allocate tabNodeGigSect + allocate(tabNodeGigSect(nbNode),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: getGigogneData(1) => allocation pb") + !initialisation + do i = 1,nbNode + tabNodeGigSect(i)%indTabCellPlac = 0 + tabNodeGigSect(i)%ring = 0 + tabNodeGigSect(i)%sect = 0 + tabNodeGigSect(i)%neutronicMix = 0 + tabNodeGigSect(i)%merge = 0 + tabNodeGigSect(i)%dragSector = 0 + tabNodeGigSect(i)%clust = .false. + enddo + + !renumerotation des nodes dans l'ordre lexicographique + call renumNodes(szSA,nbNode,nbNode_noclust) + + !recuperation des informations sur les gigognes + call getGigogneData(szSA,nbNode,lmacro) + if(nbNode.gt.dimTabCelluleBase) call XABORT('createNodes: merg overflow.') + do i = 1,nbNode + merg(i)=tabNodeGigSect(i)%merge + imacro(i)=tabNodeGigSect(i)%imacro + enddo + deallocate(tabNodeGigSect) + + end subroutine createNodes + + subroutine associatePoints(szSA,nbPts) + implicit none + integer,intent(in) :: szSA + integer,intent(inout) :: nbPts + + type(t_point) :: pt + type(t_segArc) :: sa + integer :: i,j,k + logical :: isNewPt,dep + + !programmation defensive + integer :: taille_table_tabPtNode + + taille_table_tabPtNode = size(tabPtNode) + + !creation du tableau + do i = 1,szSA + sa = tabSegArc(i) + if(sa%typ==tcer) cycle + do k = 1,2 + dep=(k==1) + pt = createPoint(i,dep) + isNewPt = .true. + do j = 1,nbPts + isNewPt = .not.isEqualPt(pt,tabPtNode(j)%position) + if(.not.isNewPt) then + call addInLine(j,i,dep) + exit + endif + enddo + if(isNewPt) then + nbPts = nbPts+1 + if (nbPts > taille_table_tabPtNode) & + call XABORT("G2S : memory problem in routine associatePoints") + call addInLine(nbPts,i,dep) + endif + enddo + enddo + end subroutine associatePoints + + subroutine addInLine(indTab,indSA,dep) + integer,intent(in) :: indTab,indSA + logical,intent(in) :: dep + !permet d'ajouter la reference a un segArc dans le tableau des noeuds + ! (les angles des secteurs sont ordonnes croissants dans le sens trigo) + integer,dimension(tabPtNode(indTab)%sz+1) :: lSA + logical,dimension(tabPtNode(indTab)%sz+1) :: lDep + double precision,dimension(tabPtNode(indTab)%sz+1) :: lDir + integer :: sz,i,j + double precision :: angl + logical :: flag + + sz = tabPtNode(indTab)%sz + angl = calculAngleDep(indSA,dep) + if(sz/=0) then + flag = .true. + do i = 1,sz + if(angl > tabPtNode(indTab)%listOfDirection(i)) then + lSA(i) = tabPtNode(indTab)%listOfSA(i) + lDep(i) = tabPtNode(indTab)%listOfDeparture(i) + lDir(i) = tabPtNode(indTab)%listOfDirection(i) + else + lSA(i) = indSa + lDep(i) = dep + lDir(i) = angl + do j = i,sz + lSA(j+1) = tabPtNode(indTab)%listOfSA(j) + lDep(j+1) = tabPtNode(indTab)%listOfDeparture(j) + lDir(j+1) = tabPtNode(indTab)%listOfDirection(j) + enddo + flag = .false. + exit + endif + enddo + if(flag) then + lSA(sz+1) = indSa + lDep(sz+1) = dep + lDir(sz+1) = angl + endif + deallocate( tabPtNode(indTab)%listOfSA & + & , tabPtNode(indTab)%listOfDeparture & + & , tabPtNode(indTab)%listOfDirection ) + else + tabPtNode(indTab)%position = createPoint(indSA,dep) + lSA(1) = indSa + lDep(1) = dep + lDir(1) = angl + endif + allocate( tabPtNode(indTab)%listOfSA(sz+1) & + & , tabPtNode(indTab)%listOfDeparture(sz+1) & + & , tabPtNode(indTab)%listOfDirection(sz+1) ,stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: addInLine(3) => allocation pb") + tabPtNode(indTab)%listOfSA=lSA + tabPtNode(indTab)%listOfDeparture=lDep + tabPtNode(indTab)%listOfDirection=lDir + tabPtNode(indTab)%sz=sz+1 + end subroutine addInLine + + function calculAngleDep(indSA,dep) + integer,intent(in) :: indSA + logical,intent(in) :: dep + double precision :: calculAngleDep + + type(t_segArc) :: sa + + calculAngleDep = 0.d0 + sa = tabSegArc(indSA) + if(sa%typ==tseg) then + if(dep) then + calculAngleDep = calculeAngle(sa%x,sa%y,sa%dx,sa%dy) + else + calculAngleDep = calculeAngle(sa%dx,sa%dy,sa%x,sa%y) + endif + else if(sa%typ==tarc) then + !on modifie l'angle de +/- 5*epsilon pour bien prendre en compte + ! les positions relatives avec les arcs dans les cas de tangence + ! (le rapport de modification prend en compte le rayon de l'element + ! pour gerer les cas de tangence entre cercles) + if(dep) then + calculAngleDep = angleNormal(sa%a+pi_2_c+muleps1*(2-tanh(sa%r))*epsilon) + else + calculAngleDep = angleNormal(sa%b-pi_2_c-muleps1*(2-tanh(sa%r))*epsilon) + endif + else + call XABORT("G2S : internal error in function calculAngleDep") + endif + end function calculAngleDep + + function createPoint(indSA,dep) + integer,intent(in) :: indSA + logical,intent(in) :: dep + type(t_point) :: createPoint + type(t_segArc) :: sa + + createPoint%x=0.d0 ; createPoint%y=0.d0 + sa = tabSegArc(indSA) + if(sa%typ==tseg) then + if(dep) then + createPoint%x=sa%x ; createPoint%y=sa%y + else + createPoint%x=sa%dx ; createPoint%y=sa%dy + endif + else if(sa%typ==tarc) then + if(dep) then + createPoint%x=sa%x+sa%r*cos(sa%a) ; createPoint%y=sa%y+sa%r*sin(sa%a) + else + createPoint%x=sa%x+sa%r*cos(sa%b) ; createPoint%y=sa%y+sa%r*sin(sa%b) + endif + else + call XABORT("G2S : internal error in function createPoint") + endif + end function createPoint + + function isEqualPt(p1,p2) + type(t_point),intent(in) :: p1,p2 + logical :: isEqualPt + + isEqualPt = isEqualConst(p1%x,p2%x) .and. isEqualConst(p1%y,p2%y) + end function isEqualPt + + subroutine solveNodeSystem(szSA,nbPts,nbNode) + integer,intent(in) :: szSA,nbPts + integer,intent(out) :: nbNode + + integer :: i,j,indNodeAv,indNodeAp,mixAv,mixAp,sz + ! correction of plain CAR2D bug by Alain Hebert (May 2016) + integer :: nbFile + logical :: isOpen + logical,parameter :: drawMix = .true. + real,parameter,dimension(2) :: zoomx = (/ 0.0, 1.0 /) ! no x zoom on postscript plot + real,parameter,dimension(2) :: zoomy = (/ 0.0, 1.0 /) ! no y zoom on postscript plot + + nbNode = 0 + do i = 1,nbPts + sz = tabPtNode(i)%sz + do j = 1,sz + mixAv=getMixAv(i,j) ; mixAp=getMixAp(i,j) + if(mixAv<0 .or. mixAp<0) then + call setNodeAv(i,j,0) ; call setNodeAp(i,j,0) + cycle + endif +! correction of plain CAR2D bug by Alain Hebert (May 2016) + if(mixAv/=mixAp) then + nbFile = 50 + do + nbFile = nbFile + 1 + inquire(nbFile,opened=isOpen) + if(isOpen) cycle + open(nbFile,file='errorMix.ps') + exit + enddo + call drawSegArc(nbFile,szSA,.false.,drawMix,zoomx,zoomy) + close(nbFile) + write(*,*) 'i,j,mixAv,mixAp : ',i,j,mixAv,mixAp + call XABORT("G2S: internal problem for mix values. See the file & + &errorMix.ps") + endif +! CS-IV : fin de la mise en commentaires de Alain + indNodeAv=getNodeAv(i,j) ; indNodeAp=getNodeAp(i,j) + if(indNodeAv>0 .and. indNodeAp<0) then + call setNodeAp(i,j,indNodeAv) + else if(indNodeAp>0 .and. indNodeAv<0) then + call setNodeAv(i,j,indNodeAp) + else if(indNodeAp<0 .and. indNodeAv<0) then + nbNode = nbNode + 1 + call setNodeAv(i,j,nbNode) ; call setNodeAp(i,j,nbNode) + else if(indNodeAv/=indNodeAp) then + !incoherence de numerotation (possible si plus de 3 cotes a + ! un domaine par remplisage des coins opposes) => on decremente + ! le nombre de nodes, et on rend la numerotation coherente + ! (remplacement du plus grand des deux par le plus petit, et + ! decalage de -1 des numeros superieurs au plus grand) + nbNode = nbNode - 1 + call remplaceNodeEtDecale(max(indNodeAv,indNodeAp), & + & min(indNodeAv,indNodeAp),szSA) + endif + enddo + enddo + + end subroutine solveNodeSystem + + function getNodeAv(indTPN,indLSA) + integer,intent(in) :: indTPN,indLSA + integer :: getNodeAv + integer :: ind + + if(indLSA==1) then + ind = tabPtNode(indTPN)%sz + else + ind = indLSA-1 + endif + if(tabPtNode(indTPN)%listOfDeparture(ind)) then + getNodeAv=tabSegArc(tabPtNode(indTPN)%listOfSA(ind))%nodeg + else + getNodeAv=tabSegArc(tabPtNode(indTPN)%listOfSA(ind))%noded + endif + end function getNodeAv + + function getNodeAp(indTPN,indLSA) + integer,intent(in) :: indTPN,indLSA + integer :: getNodeAp + + if(tabPtNode(indTPN)%listOfDeparture(indLSA)) then + getNodeAp=tabSegArc(tabPtNode(indTPN)%listOfSA(indLSA))%noded + else + getNodeAp=tabSegArc(tabPtNode(indTPN)%listOfSA(indLSA))%nodeg + endif + end function getNodeAp + + subroutine setNodeAv(indTPN,indLSA,val) + integer,intent(in) :: indTPN,indLSA,val + + integer :: ind + + if(indLSA==1) then + ind = tabPtNode(indTPN)%sz + else + ind = indLSA-1 + endif + if(tabPtNode(indTPN)%listOfDeparture(ind)) then + tabSegArc(tabPtNode(indTPN)%listOfSA(ind))%nodeg=val + else + tabSegArc(tabPtNode(indTPN)%listOfSA(ind))%noded=val + endif + + end subroutine setNodeAv + + subroutine setNodeAp(indTPN,indLSA,val) + integer,intent(in) :: indTPN,indLSA,val + + if(tabPtNode(indTPN)%listOfDeparture(indLSA)) then + tabSegArc(tabPtNode(indTPN)%listOfSA(indLSA))%noded=val + else + tabSegArc(tabPtNode(indTPN)%listOfSA(indLSA))%nodeg=val + endif + + end subroutine setNodeAp + + function getMixAv(indTPN,indLSA) + integer,intent(in) :: indTPN,indLSA + integer :: getMixAv + + integer :: ind + + if(indLSA==1) then + ind = tabPtNode(indTPN)%sz + else + ind = indLSA-1 + endif + if(tabPtNode(indTPN)%listOfDeparture(ind)) then + getMixAv=tabSegArc(tabPtNode(indTPN)%listOfSA(ind))%mixg + else + getMixAv=tabSegArc(tabPtNode(indTPN)%listOfSA(ind))%mixd + endif + end function getMixAv + + function getMixAp(indTPN,indLSA) + integer,intent(in) :: indTPN,indLSA + integer :: getMixAp + + if(tabPtNode(indTPN)%listOfDeparture(indLSA)) then + getMixAp=tabSegArc(tabPtNode(indTPN)%listOfSA(indLSA))%mixd + else + getMixAp=tabSegArc(tabPtNode(indTPN)%listOfSA(indLSA))%mixg + endif + end function getMixAp + + subroutine remplaceNodeEtDecale(badNum,goodNum,szSA) + integer,intent(in) :: badNum,goodNum,szSA + + integer :: i + do i = 1,szSA + if(tabSegArc(i)%nodeg == badNum) tabSegArc(i)%nodeg = goodNum + if(tabSegArc(i)%noded == badNum) tabSegArc(i)%noded = goodNum + if(tabSegArc(i)%nodeg > badNum) & + & tabSegArc(i)%nodeg = tabSegArc(i)%nodeg - 1 + if(tabSegArc(i)%noded > badNum) & + & tabSegArc(i)%noded = tabSegArc(i)%noded - 1 + enddo + end subroutine remplaceNodeEtDecale + + subroutine circularNodes(szSA,nbNode,szTabCer) + integer,intent(in) :: szSA + integer,intent(inout) :: nbNode,szTabCer + + type(t_point) :: centre + integer :: i,j + logical :: isNewCentre + + !creation du systeme + do i = 1,szSA + if(tabSegArc(i)%typ == tseg) cycle + centre%x=tabSegArc(i)%x ; centre%y=tabSegArc(i)%y + isNewCentre = .true. + do j = 1,szTabCer + isNewCentre = .not.isEqualPt(centre,tabCercNode(j)%centre) + if(.not.isNewCentre) then + call addCircel(j,i) + exit + endif + enddo + if(isNewCentre) then + szTabCer = szTabCer + 1 + tabCercNode(szTabCer)%centre = centre + tabCercNode(szTabCer)%withSect = & + (tabCelluleBase(tabCellulePlaced(tabSegArc(i)%indCellPg)%indice)%sv(14) & + /= S_not) + call addCircel(szTabCer,i) + endif + enddo + !determination du node exterieur et resolution du syteme + call solveCircularNodes(szTabCer,szSA,nbNode) + end subroutine circularNodes + + subroutine addCircel(indTab,indSA) + integer,intent(in) :: indTab,indSA + + integer,dimension(:), allocatable :: lSA + double precision,dimension(:),allocatable :: lRad + integer :: sz,i,j,imin + double precision :: radius + logical :: flag + + sz = tabCercNode(indTab)%sz + imin = tabCercNode(indTab)%imin + radius = tabSegArc(indSA)%r + do i = 1,sz + if(abs(radius-tabCercNode(indTab)%listOfRadius(i)) allocation pb") + if(sz/=0) then + flag = .true. + do i = 1,sz + if(radius > tabCercNode(indTab)%listOfRadius(i)) then + lSA(i) = tabCercNode(indTab)%listOfSA(i) + lRad(i) = tabCercNode(indTab)%listOfRadius(i) + else + lSA(i) = indSa + lRad(i) = radius + do j = i,sz + lSA(j+1) = tabCercNode(indTab)%listOfSA(j) + lRad(j+1) = tabCercNode(indTab)%listOfRadius(j) + enddo + flag = .false. + exit + endif + enddo + if(flag) then + lSA(sz+1) = indSa + lRad(sz+1) = radius + endif + deallocate( tabCercNode(indTab)%listOfSA & + & , tabCercNode(indTab)%listOfRadius ) + else + lSA(1) = indSa + lRad(1) = radius + endif + allocate( tabCercNode(indTab)%listOfSA(sz+1) & + & , tabCercNode(indTab)%listOfRadius(sz+1) ,stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: addCircle1 => allocation pb") + tabCercNode(indTab)%listOfSA(:sz+1) = lSA(:sz+1) + tabCercNode(indTab)%listOfRadius(:sz+1) = lRad(:sz+1) + tabCercNode(indTab)%sz=sz+1 + tabCercNode(indTab)%imin=imin + end subroutine addCircel + + subroutine solveCircularNodes(szTabCer,szSA,nbNode) + integer,intent(in) :: szTabCer,szSA + integer,intent(inout) :: nbNode + + integer :: i,j,indCer,indNodeAv,indNodeAp + double precision :: d,dist,angl,cx,cy,radius + type(t_segArc) :: sa,cer + + do j = 1,szTabCer + indCer = 0 + do i=tabCercNode(j)%sz,1,-1 + tabCercNode(j)%imin = i + indCer = tabCercNode(j)%listOfSA(i) + radius = tabCercNode(j)%listOfRadius(i) + if(tabSegArc(indCer)%typ == tcer) go to 10 + enddo + tabCercNode(j)%imin = 0 + cycle + 10 cer = tabSegArc(indCer) + d = infinity + do i = 1,szSA + if(i==indCer) cycle + sa = tabSegArc(i) + if(sa%typ == tseg) then + dist = disproj(tabCercNode(j)%centre,sa) - radius + if((dist < 0.0).or.(dist >= d)) cycle + tabCercNode(j)%coteGauche = .not.estADroite(sa%x,sa%y,sa%dx,sa%dy,cer%x,cer%y) + else if(sa%typ == tcer) then + if(isEqualConst(sa%x,cer%x).and.isEqualConst(sa%y,cer%y)) cycle + dist = sa%r - longVect(sa%x-cer%x,sa%y-cer%y) - radius + if((dist < 0.0).or.(dist >= d)) cycle + tabCercNode(j)%coteGauche = .true. + else + if(sa%b > sa%a) then + angl=(sa%b+sa%a)*0.5 + else + angl=(sa%b+sa%a)*0.5+pi_c + endif + cx = sa%x+cos(angl)*sa%r ; cy = sa%y+sin(angl)*sa%r + dist = longVect(cer%x-cx,cer%y-cy) - radius + if((dist < 0.0).or.(dist >= d)) cycle + tabCercNode(j)%coteGauche = longVect(cer%x-sa%x,cer%y-sa%y) < sa%r + endif + d = dist + tabCercNode(j)%indNodeExt = i + enddo + enddo + !resolution du systeme + do j = 1,szTabCer + if(tabCercNode(j)%indNodeExt < 0) cycle + if(tabSegArc(tabCercNode(j)%listOfSA(1))%nodeg==fooNode) then + nbNode = nbNode + 1 + tabSegArc(tabCercNode(j)%listOfSA(1))%nodeg = nbNode + endif + if(tabCercNode(j)%imin > 0) then + if(tabCercNode(j)%coteGauche) then + tabSegArc(tabCercNode(j)%listOfSA(tabCercNode(j)%imin))%noded = & + tabSegArc(tabCercNode(j)%indNodeExt)%nodeg + else + tabSegArc(tabCercNode(j)%listOfSA(tabCercNode(j)%imin))%noded = & + tabSegArc(tabCercNode(j)%indNodeExt)%noded + endif + endif + do i = 1,tabCercNode(j)%sz-1 + if(i == tabCercNode(j)%imin) cycle + if(tabSegArc(tabCercNode(j)%listOfSA(i))%noded==fooNode .and. & + tabSegArc(tabCercNode(j)%listOfSA(i+1))%nodeg==fooNode) then + nbNode = nbNode + 1 + tabSegArc(tabCercNode(j)%listOfSA(i))%noded = nbNode + tabSegArc(tabCercNode(j)%listOfSA(i+1))%nodeg = nbNode + else if(tabSegArc(tabCercNode(j)%listOfSA(i))%noded==fooNode) then + tabSegArc(tabCercNode(j)%listOfSA(i))%noded = & + tabSegArc(tabCercNode(j)%listOfSA(i+1))%nodeg + else if(tabSegArc(tabCercNode(j)%listOfSA(i+1))%nodeg==fooNode)then + tabSegArc(tabCercNode(j)%listOfSA(i+1))%nodeg = & + tabSegArc(tabCercNode(j)%listOfSA(i))%noded + else if((tabSegArc(tabCercNode(j)%listOfSA(i))%noded /= & + tabSegArc(tabCercNode(j)%listOfSA(i+1))%nodeg)) then + !on fait le remplacement dans touts les cas si il n'y a pas + !de sectorisation de la cellule, et seulement si l'element + !geometrique est un cercle complet si il y a sectorisation + if(.not.(tabSegArc(tabCercNode(j)%listOfSA(i))%typ/=tcer)) then + nbNode = nbNode - 1 + indNodeAv = tabSegArc(tabCercNode(j)%listOfSA(i))%noded + indNodeAp = tabSegArc(tabCercNode(j)%listOfSA(i+1))%nodeg + call remplaceNodeEtDecale(max(indNodeAv,indNodeAp), & + & min(indNodeAv,indNodeAp),szSA) + endif + endif + enddo + enddo + !validation du node exterieur + do j = 1,szTabCer + if(tabSegArc(tabCercNode(j)%listOfSA(tabCercNode(j)%sz))%noded == fooNode) then + if(tabCercNode(j)%indNodeExt>0) then + if(tabCercNode(j)%coteGauche) then + tabSegArc(tabCercNode(j)%listOfSA(tabCercNode(j)%sz))%noded & + = tabSegArc(tabCercNode(j)%indNodeExt)%nodeg + else + tabSegArc(tabCercNode(j)%listOfSA(tabCercNode(j)%sz))%noded & + = tabSegArc(tabCercNode(j)%indNodeExt)%noded + endif + else + tabSegArc(tabCercNode(j)%listOfSA(tabCercNode(j)%sz))%noded = 0 + endif + endif + enddo + + end subroutine solveCircularNodes + + function disproj(pt,sg) + type(t_point),intent(in) :: pt + type(t_segArc),intent(in) :: sg + double precision :: disproj + + double precision :: prjx,prjy + + disproj = distance(pt%x,pt%y,sg%x,sg%y,sg%dx,sg%dy,prjx,prjy) + if(isIn(prjx,prjy,sg)==0) then + disproj = min(longVect(sg%x-pt%x,sg%y-pt%y),& + longVect(sg%dx-pt%x,sg%dy-pt%y)) + muleps2*epsilon + endif + !pour privilegier les arcs par rapport aux segments + disproj = disproj + muleps2*epsilon + end function disproj + + function lessThanPtNd(first,second) + type(t_ptMinNode),intent(in) :: first,second + logical :: lessThanPtNd + + if(.not.(isEqualConst(first%ptMin%y,second%ptMin%y))) then + lessThanPtNd = (first%ptMin%y < second%ptMin%y) + else if(.not.(isEqualConst(first%ptMin%x,second%ptMin%x))) then + lessThanPtNd = (first%ptMin%x < second%ptMin%x) + else + lessThanPtNd = (first%alfa > second%alfa) !ordre inverse sur les angles + endif + end function lessThanPtNd + + subroutine renumNodes(szSA,nbNode,nbNode_noclust) + integer,intent(in) :: szSA,nbNode,nbNode_noclust + + type(t_ptMinNode) :: tmpPtMN + type(t_segArc) :: sa + type(t_point) :: toOrig + integer :: i,j,numNod,numNodg,numNodd + integer,dimension(:),allocatable :: newNumNode + + allocate(tabPtMN(nbNode),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: renumNodes(1) => allocation pb") + !initialisation du tableau + do i = 1,nbNode + tabPtMN(i)%ptMin%y = infinity + tabPtMN(i)%ptMin%x = infinity + tabPtMN(i)%alfa = 0.d0 + tabPtMN(i)%indNode = i + enddo + + !remplisage du tableau + do i = 1,szSA + sa = tabSegArc(i) + tmpPtMN = givePtMin(sa) + numNod = sa%nodeg !travail sur le node gauche + do j = 1,2 + if(numNod>0) then + if(lessThanPtNd(tmpPtMN,tabPtMN(numNod))) then + tabPtMN(numNod)%ptMin = tmpPtMN%ptMin + tabPtMN(numNod)%alfa = tmpPtMN%alfa + endif + endif + numNod = sa%noded !travail sur le node droit + enddo + enddo + + !triage du tableau + call sortTabPtMN(nbNode) + + !recuperation du vecteur de translation des numeros de nodes + allocate(newNumNode(nbNode),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: renumNodes(2) => allocation pb") + do i = 1,nbNode + newNumNode(tabPtMN(i)%indNode)=i + enddo + select case(geomTyp) + case(HexTyp) + toOrig%x = 0.d0 ; toOrig%y = 0.d0 + case default + toOrig = tabPtMN(1)%ptMin + end select + + ! correction of MERGE cluster bug by Alain Hebert (May 2025) + tabNodeGigSect(:nbNode)%clust = .false. + do i = 1,szSA + sa = tabSegArc(i) + numNodg = sa%nodeg + numNodd = sa%noded + if(numNodg.gt.nbNode_noclust) then + tabNodeGigSect(newNumNode(numNodg))%clust = .true. + endif + if(numNodd.gt.nbNode_noclust) then + tabNodeGigSect(newNumNode(numNodd))%clust = .true. + endif + enddo + + !renumerotation des nodes + do i = 1,szSA + numNod = tabSegArc(i)%nodeg + if(numNod>0) then + tabSegArc(i)%nodeg = newNumNode(numNod) + tabSegArc(i)%clusg = (numNod.gt.nbNode_noclust) + endif + numNod = tabSegArc(i)%noded + if(numNod>0) then + tabSegArc(i)%noded = newNumNode(numNod) + tabSegArc(i)%clusd = (numNod.gt.nbNode_noclust) + endif + enddo + + deallocate(tabPtMN,newNumNode) + + !translation vers l'origine des elements + do i = 1,szSA + tabSegArc(i)%x=tabSegArc(i)%x - toOrig%x + tabSegArc(i)%y=tabSegArc(i)%y - toOrig%y + if(tabSegArc(i)%typ==tseg) then + tabSegArc(i)%dx=tabSegArc(i)%dx - toOrig%x + tabSegArc(i)%dy=tabSegArc(i)%dy - toOrig%y + endif + enddo + !ecriture dans les donnees de condition aux limites du vecteur de + !translation + bCData%toOrig_xy(1) = toOrig%x ; bCData%toOrig_xy(2) = toOrig%y + end subroutine renumNodes + + function givePtMin(sa) + type(t_segArc),intent(in) :: sa + type(t_ptMinNode) :: givePtMin + + double precision :: ax,ay,bx,by + + givePtMin%ptMin%x=infinity + givePtMin%ptMin%y=infinity + givePtMin%alfa=0.d0 + givePtMin%indNode=-1 !ne doit pas servir + select case(sa%typ) + case(tseg) + if(isEqualConst(sa%y,sa%dy)) then + if(sa%x0) then + call setIntIfPos(tabNodeGigSect(numNod)%indTabCellPlac,sa%indCellPg) + call setIntIfPos(tabNodeGigSect(numNod)%ring,sa%mixg) + ! correction of MERGE cluster bug by Alain Hebert (May 2025) + ! tabNodeGigSect(numNod)%clust=tabNodeGigSect(numNod)%clust.or.sa%clusg + if(sa%typ==tarc) then + !sur le node interieur, en cas de sectorisation exterieure, + !il doit apparaitre une discontinuite de sectorisation. + !=> on passe outre le test de coherence de sect + tabNodeGigSect(numNod)%sect = sa%sectg + else + call setIntIfPos(tabNodeGigSect(numNod)%sect,sa%sectg) + endif + endif + numNod = sa%noded !travail sur le node droit + if(numNod>0) then + call setIntIfPos(tabNodeGigSect(numNod)%indTabCellPlac,sa%indCellPd) + call setIntIfPos(tabNodeGigSect(numNod)%ring,sa%mixd) + ! correction of MERGE cluster bug by Alain Hebert (May 2025) + ! tabNodeGigSect(numNod)%clust=tabNodeGigSect(numNod)%clust.or.sa%clusd + call setIntIfPos(tabNodeGigSect(numNod)%sect,sa%sectd) + endif + enddo + !calcul des numeros de macros + nbMacro = maxval(tabNodeGigSect(:nbNode)%indTabCellPlac) + allocate(newMacro(nbMacro)) + newMacro(:nbMacro) = 0 + do i = 1,nbNode + newMacro(tabNodeGigSect(i)%indTabCellPlac) = 1 + enddo + j = 0 + do i = 1,nbMacro + if((newMacro(i) /= 0).and.(lmacro)) then + j = j+1 + newMacro(i) = j + else if(newMacro(i) /= 0) then + newMacro(i) = 1 + endif + enddo + !calcul des secteurs et des milieux neutroniques + do i = 1,nbNode + tcp = tabCellulePlaced(tabNodeGigSect(i)%indTabCellPlac) + tcb = tabCelluleBase(tcp%indice) + typCell = tcb%sv(1) + cluster = tcb%sv(13) + sectori = tcb%sv(14) + sectorj = tcb%sv(15) + !creation des tableaux de reference sur les milieux et les merges + !par ajout des donnees eventuelles sur les clusters + if(cluster/=0 .and. sectori/=S_not) call XABORT("G2S: CLUSTER not& + &allowed with SECT") + if(cluster==0) then + allocate(neutronicMix(size(tcb%mix)),mrg(size(tcb%merge)),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: getGigogneData(2) => allocation pb") + if((typCell == G_Hex).and.(tcb%name == '/')) then + if(size(tcb%mix) /= nbNode) call XABORT("G2S: getGigogneData=> invalid size") + neutronicMix(1) = tcb%mix(tabNodeGigSect(i)%indTabCellPlac) + else + neutronicMix(:size(tcb%mix)) = tcb%mix + endif + mrg(:size(tcb%merge)) = tcb%merge + else + lg = size(tcb%mix) + do j = 1,cluster + lg = lg + size(tcb%cluster(j)%mix) + enddo + allocate(neutronicMix(lg),mrg(lg),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: getGigogneData(3) => allocation pb") + !remplissage de neutronicMix + lg = size(tcb%mix) + neutronicMix(1:lg) = tcb%mix(1:lg) + do j = 1,cluster + szM = size(tcb%cluster(j)%mix) + neutronicMix(lg+1:lg+szM) = tcb%cluster(j)%mix(1:szM) + lg = lg + szM + enddo + !remplissage de mrg + ! remplissage par defaut pour le merge des clusters + mrg(1:lg) = (/(j,j=1,lg)/) + ! remplissage du debut avec le merge de la cellule + lg = size(tcb%merge) + mrg(1:lg) = tcb%merge(1:lg) + endif + !traitement + ds = 0 + cl = .false. + select case(typCell) + case(G_Car2d,G_Tri,G_Tube) + if(sectori/=S_not) call XABORT("G2S: no SECT allowed for CAR2D, & + &TRI2D, or TUBE") + ds = tabNodeGigSect(i)%ring + cl = cluster/=0 .and. tabNodeGigSect(i)%clust + case(G_Carcel) + select case (sectori) + case(S_not) + ds = tabNodeGigSect(i)%ring + cl = cluster/=0 .and. tabNodeGigSect(i)%clust + case(S_X_TOT, S_T_TOT) + if (tabNodeGigSect(i)%ring<= sectorj) then + ! correction of neutronicMixd/Mixg bug by Alain Hebert (May 2023) + ds = tabNodeGigSect(i)%ring + else + ds = (tabNodeGigSect(i)%ring -sectorj-1)*4 & + + sectorj & + + tabNodeGigSect(i)%sect + endif + case(S_TX_TOT, S_TXS_TOT, S_WM_TOT) + if (tabNodeGigSect(i)%ring<= sectorj) then + ds =tabNodeGigSect(i)%ring + else + ds = (tabNodeGigSect(i)%ring -sectorj-1)*8 & + + sectorj & + + tabNodeGigSect(i)%sect + endif + end select + + case(G_Hex) + if(sectori==S_not) then + ds = 1 + else + ds = tabNodeGigSect(i)%sect + endif + + case(G_Hexcel) + if(sectori==S_not) then + ds = tabNodeGigSect(i)%ring + cl = cluster/=0 .and. tabNodeGigSect(i)%clust + else if(sectori==S_X_tot) then + if (tabNodeGigSect(i)%ring<= sectorj) then + ! correction of neutronicMixd/Mixg bug by Alain Hebert (May 2023) + ds = tabNodeGigSect(i)%ring + else + ds = (tabNodeGigSect(i)%ring-sectorj-1)*6 & + + sectorj & + + tabNodeGigSect(i)%sect + endif + else + call XABORT("G2S: value for SECT not allowed") + endif + case default + call XABORT("G2S: internal error in subroutine getGigogneData") + end select + tabNodeGigSect(i)%neutronicMix = neutronicMix(ds) + ! correction of MERGE bug by Alain Hebert (January 2016) + ! tabNodeGigSect(i)%merge = mrg(ds) + ! new correction of MERGE bug for clusters by Alain Hebert (November 2019) + if(.not.cl) then + tabNodeGigSect(i)%merge = i + else + tabNodeGigSect(i)%merge = nbNode+ds + endif + tabNodeGigSect(i)%dragSector = ds + deallocate(neutronicMix,mrg) + ! define TDT macros + tabNodeGigSect(i)%imacro = newMacro(tabNodeGigSect(i)%indTabCellPlac) + enddo + deallocate(newMacro) +! CS-IV : visualisation pour debug +! call PrintTabNodeGigSect(nbNode) + + !remontage des infos + do i = 1,szSA + numNod = tabSegArc(i)%nodeg !travail sur le node gauche + if(numNod>0) & + tabSegArc(i)%neutronicMixg = tabNodeGigSect(numNod)%neutronicMix + numNod = tabSegArc(i)%noded !travail sur le node droit + if(numNod>0) & + tabSegArc(i)%neutronicMixd = tabNodeGigSect(numNod)%neutronicMix + enddo + end subroutine getGigogneData + + subroutine setIntIfPos (toModif,valToSet) + implicit none + integer,intent(inout) :: toModif + integer,intent(in) :: valToSet + + if(valToSet<=0) return !rien a faire + if(toModif<=0) then + toModif = valToSet +! correction of plain CAR2D bug by Alain Hebert (May 2016) + else if(toModif/=valToSet) then + write(6,*) " setIntIfPos: ",toModif,"/=",valToSet + call XABORT("G2S: internal error in subroutine setIntIfPos") + endif + end subroutine setIntIfPos + + subroutine PrintTabPtNode(size) + integer, intent(in) :: size + integer :: i,j + write(*,*) "Impression de TabPtNode de ",size," elements" + do i=1, size + write(*,10) i + write(*,20) TabPtNode(i)%position + write(*,30) TabPtNode(i)%sz + do j = 1, TabPtNode(i)%sz + write(*,40) TabPtNode(i)%listOfSA(j),TabPtNode(i)%listOfDeparture(j),& + TabPtNode(i)%listOfDirection(j) + end do + enddo +10 format(("**** element ****", i6)) +20 format("*----------- position = ", f13.6,";",f13.6) +30 format("*----------- size = ", i6) +40 format("*----------- SA/Depart/dir = ", i5,"/",l5,"/",F13.6) + end subroutine PrintTabPtNode + + subroutine PrintTabNodeGigSect(size) + integer, intent(in) :: size + integer :: i + + do i=1, size + write(*,10) i + write(*,20) tabNodeGigSect(i)%indtabcellplac + write(*,30) tabNodeGigSect(i)%ring + write(*,35) tabNodeGigSect(i)%clust + write(*,40) tabNodeGigSect(i)%sect + write(*,50) tabNodeGigSect(i)%neutronicmix + write(*,60) tabNodeGigSect(i)%merge + write(*,70) tabNodeGigSect(i)%dragsector + end do +10 format("**** element ****", i6) +20 format("*+++++++++++ IndTabCellPlac = ", i6) +30 format("*+++++++++++ Ring = ", i6) +35 format("*+++++++++++ Cluster ring = ", l6) +40 format("*+++++++++++ Sect = ", i6) +50 format("*+++++++++++ NeutronicMix = ", i6) +60 format("*+++++++++++ Merge = ", i6) +70 format("*+++++++++++ DragSector = ", i6) + end subroutine PrintTabNodeGigSect +end module ptNodes diff --git a/Dragon/src/g2s_pretraitement.f90 b/Dragon/src/g2s_pretraitement.f90 new file mode 100644 index 0000000..baf20ad --- /dev/null +++ b/Dragon/src/g2s_pretraitement.f90 @@ -0,0 +1,2243 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Preprocessing of geometric data recovered from a geometry LCM data +! structure. +! +!Copyright: +! Copyright (C) 2001 Ecole Polytechnique de Montreal. +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): +! G. Civario (CS-SI) +! +!Comments: +! Ce fichier regroupe toutes les actions effectuees en amont du code, pour +! verifier et completer le jeux de donnees geometriques. Il utilise de maniere +! intensive l'api de PyLCM. +! Les fonctions de ce fichier ont ete initialement developpees en python, puis +! traduite en fortran90. C'est pourquoi la forme des algorithmes peut etre +! parfois deroutante... +! \\\\ +! Le module pretraitement definit quelques constantes, dont en particulier la +! precision admise en entree du code (pour la coherence des donnees). +! De plus, les matrices "composeRotRec" et "composeRotTri" permettent +! d'effectuer la composition de deux transformations definies selon le mode +! Dragon. +! \\\\ +! Le seul pretraitement qui soit reellement delicat, est celui qui correspond +! a une geometrie de type gigogne rectangulaire. Il est effectue par la routine +! "creerEtChargerNewDataRec", et est documente dans le source de cette routine. +! +!----------------------------------------------------------------------- +! +module pretraitement + use boundcond + use cast + use celluleBase + use cellulePlaced + use constType + use GANLIB + + implicit none + + real,parameter :: geomPrec = 1.e-4 + real,parameter :: sqrt_3f = 1.732050807568 + + !composeRotXXX(t1,t2)=t2ot1 + integer,dimension(8,8),parameter :: composeRotRec = & + & reshape((/1,2,3,4,5,6,7,8, & + & 2,3,4,1,8,5,6,7, & + & 3,4,1,2,7,8,5,6, & + & 4,1,2,3,6,7,8,5, & + & 5,6,7,8,1,2,3,4, & + & 6,7,8,5,4,1,2,3, & + & 7,8,5,6,3,4,1,2, & + & 8,5,6,7,2,3,4,1/) , (/8,8/)) + + integer,dimension(12,12),parameter :: composeRotTri = & + & reshape((/ 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12, & + & 2, 3, 4, 5, 6, 1, 8, 9,10,11,12, 7, & + & 3, 4, 5, 6, 1, 2, 9,10,11,12, 7, 8, & + & 4, 5, 6, 1, 2, 3,10,11,12, 7, 8, 9, & + & 5, 6, 1, 2, 3, 4,11,12, 7, 8, 9,10, & + & 6, 1, 2, 3, 4, 5,12, 7, 8, 9,10,11, & + & 7,12,11,10, 9, 8, 1, 6, 5, 4, 3, 2, & + & 8, 7,12,11,10, 9, 2, 1, 6, 5, 4, 3, & + & 9, 8, 7,12,11,10, 3, 2, 1, 6, 5, 4, & + & 10, 9, 8, 7,12,11, 4, 3, 2, 1, 6, 5, & + & 11,10, 9, 8, 7,12, 5, 4, 3, 2, 1, 6, & + & 12,11,10, 9, 8, 7, 6, 5, 4, 3, 2, 1/) , (/12,12/)) + +contains + subroutine prepareData(geoIp,sizeB,sizeP,lgMaxGig) + type(c_ptr),intent(in):: geoIp + integer,intent(inout) :: sizeB,sizeP,lgMaxGig + + integer,dimension(40) :: st + type(c_ptr) :: ip + integer :: nbNewMix,i + + !premier completion de la structure geometrique pour transformer + !les constructions melangeant MIX et CELL, en des constructions + !uniformes de ce point de vue + + nbNewMix = 0 + call separateMixAndCell(geoIp,nbNewMix) + + ip = geoIp + !creation des cellules de bases + call buildCellsBase(ip,sizeB,'/ ') + ip = geoIp + + call LCMGET(ip,'STATE-VECTOR',st) + select case(st(1)) + case(G_Car2d,G_Carcel) + geomTyp = RecTyp + call creerEtChargerNewDataRec(ip,sizeB,sizeP) + case(G_Hex,G_Hexcel) + geomTyp = HexTyp + call creerEtChargerNewDataHex(ip,sizeB,sizeP) + case(G_Tri) + geomTyp = TriaTyp + call creerEtChargerNewDataTri(ip,sizeB,sizeP) + case(G_Tube) + geomTyp = TubeTyp + if (sizeB/=1) call XABORT("G2S: more than one cellule in a cylindrical& + & geometry") + sizeP = 1 + tabCellulePlaced(1)%indice = 1 + tabCellulePlaced(1)%xcenter = 0.d0 + tabCellulePlaced(1)%ycenter = 0.d0 + tabCellulePlaced(1)%turn = 1 + allocate (tabCellulePlaced(1)%gig(1),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: prepareData(2) => allocation pb") + tabCellulePlaced(1)%gig = 1 + allocate (tabCellulePlaced(1)%mrg(1),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: prepareData(3) => allocation pb") + tabCellulePlaced(1)%mrg = 1 + case default + call XABORT("G2S: Type of geometry not supported") + end select + + lgMaxGig = 0 + do i = 1,sizeP + lgMaxGig = max(lgMaxGig,size(tabCellulePlaced(i)%gig)) + end do + end subroutine prepareData + + recursive subroutine separateMixAndCell(ipIn,nbNewMix) + type(c_ptr),intent(in):: ipIn + integer,intent(inout) :: nbNewMix + + type(c_ptr) :: ip,jp + integer :: i,lgC,lg,ty,indOfCellToAdd,mixToPut,nbCellToAdd,lgC2 + character*12 :: newCellName,text12 + integer,dimension(40) :: sv,newSv + integer,dimension(:),allocatable :: mix + character*12,dimension(:),allocatable :: cell + + ip = ipIn + call LCMLEN(ip,'CELL ',lgC,ty) + lgC = lgC/3 + if (lgC/=0) then !il y a des sous-cellules + allocate(cell(lgC),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: separateMixAndCell(1) => allocation pb") + call LCMGTC(ip,'CELL ',12,lgC,cell) + do i = 1,lgC + !traitement recursif sur les sous cellules de la cellule courante + call LCMLEN(ip,cell(i),lg,ty) + if (ty==0) then !la sous cellule est bien definie ici + jp=LCMDID(ip,cell(i)) + call separateMixAndCell(jp,nbNewMix) + end if + end do + deallocate(cell) + !test sur la mixite de la cellule courante + call LCMLEN(ip,'MIX ',lg,ty) + allocate(mix(lg),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: prepareData(2) => allocation pb") + call LCMGET(ip,'MIX ',mix) + nbCellToAdd = count(mix(:lg)>0) + if (nbCellToAdd/=0) then !la cellule courante est mixte MIX/CELL + call LCMGET(ip,'STATE-VECTOR',sv) + newSv(:) = 0 + newSv(1) = sv(1) + newSv(2) = 0 + newSv(3) = 1 + newSv(4) = 1 + newSv(5) = 0 + newSv(6) = 1 + newSv(7) = 1 + allocate(cell(lg),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: prepareData(3) => allocation pb") + cell(:lg)=' ' + call LCMLEN(ip,'CELL ',lgC2,ty) + lgC2 = lgC2/3 + call LCMGTC(ip,'CELL ',12,lgC2,cell) + indOfCellToAdd = lgC + do i = 1,lg + if (mix(i)>0) then + !creation d'une nouvelle cellule + nbNewMix = nbNewMix+1 + indOfCellToAdd = indOfCellToAdd+1 + mixToPut = mix(i) + mix(i) = -indOfCellToAdd + text12 = i2s(nbNewMix) + newCellName = 'Nmix'//text12(:8) + cell(indOfCellToAdd) = newCellName + jp=LCMDID(ip,newCellName) + call LCMPUT(jp,'MIX ',1,1,mixToPut) + newSv(7) = mixToPut + call LCMPUT(jp,'STATE-VECTOR',40,1,newSv) + call LCMPUT(jp,'NCODE ',6,1,(/0,0,0,0,0,0/)) + call LCMPUT(jp,'ICODE ',6,1,(/0,0,0,0,0,0/)) + text12='L_GEOM' + call LCMPTC(jp,'SIGNATURE',12,text12) + call LCMPUT(jp,'ZCODE ',6,2,(/0.,0.,0.,0.,0.,0./)) + end if + end do + !modification du STATE-VECTOR, du MIX et du CELL de la + !cellule courante + sv(9) = sv(9)+nbCellToAdd + call LCMPUT(ip,'STATE-VECTOR',40,1,sv) + call LCMPUT(ip,'MIX ',lg,1,mix) + call LCMPTC(ip,'CELL ',12,lg,cell) + deallocate(cell) + end if + deallocate(mix) + end if + end subroutine separateMixAndCell + + subroutine creerEtChargerNewDataRec(geoIp,szB,szP) + type(c_ptr),intent(in):: geoIp + integer,intent(inout) :: szB,szP + + !effectue le pretraitement initialement ecrit en python. + !celui-ci utilisait intensivement les dictionnaires python. + !Ceux-ci seront donc remplaces par des objets LCM + type(c_ptr) :: ip,sidesIp,lCentreIp,lMinMaxIp,centreCalculesIp,lcIp,dicoIp + integer :: szLc + + ip = geoIp + !modification de la geometrie dans le cas diagonal, par ajout des + !cellules manquantes dans la gigogne exterieure (ceci pour permettre + !la mise en oeuvre du traitement general aux geometries rectangulaires) + call traiteConditionDiagonale(ip) + !creation de la liste des carres + call LCMOP(lcIp,'lc ',0,1,0) + call creeListeCellules(lcIp,ip,szLc) + !creation du dictionnaire de verification des donnees geometriques + call LCMOP(dicoIp,'dico ',0,1,0) + call creeDico(dicoIp,lcIp,szLc) + + !creation de la liste des longueurs des cotes et resolution du systeme + call LCMOP(sidesIp,'sides ',0,1,0) + call resoudDico(dicoIp,sidesIp) + !cree et prepare la liste des centres des cellules de base, + !avec leur gigogne d'origine + !et destruction du dictionnaire + call LCMOP(lCentreIp,'centres ',0,1,0) + call prepareCentres(lCentreIp,lcIp,sidesIp,dicoIp) + call LCMCL(dicoIp,2) + !preparation des longeurs de la gigogne exterieure, et des coordonnees + !min et max de ses sous cellules + call LCMOP(lMinMaxIp,'minAndMaxXY ',0,1,0) + call prepareMinMax(lMinMaxIp,lCentreIp) + !resolution du systeme donnant les coordonnees des centres des cellules + !de base et stockage dans une nouvelle structure + call LCMOP(centreCalculesIp,'resCentres ',0,1,0) + call calculeCentre(centreCalculesIp,lCentreIp,0) + !compilation des resultats et ajout dans la geometrie des nouvelles donnees + call compileResutats(ip,centreCalculesIp,sidesIp,lMinMaxIp) + call LCMCL(lcIp,2) + call LCMCL(centreCalculesIp,2) + call LCMCL(sidesIp,2) + call LCMCL(lMinMaxIp,2) + !utilisation des donnees (on accroche le traitement classique developpe + !pour python) + call chargerNewData(geoIp,szB,szP) + end subroutine creerEtChargerNewDataRec + + subroutine traiteConditionDiagonale(geoIp) + type(c_ptr),intent(in) :: geoIp + + integer :: i,j,k,pos,n,lgAv,lgAp,lg,ty + integer,dimension(6) :: ncode + integer,dimension(40) :: sv + integer,dimension(:),allocatable :: mixAv,mixAp,turnAv,turnAp + integer,dimension(:),allocatable :: mergeAv,mergeAp + + call LCMGET(geoIp,'NCODE ',ncode) + if ((ncode(1)/=B_Diag) .and. (ncode(2)/=B_Diag)) & + return !pas de condition DIAG + call LCMGET(geoIp,'STATE-VECTOR',sv) + if (sv(8)==0) return !pas de sous cellules + call LCMLEN(geoIp,'MIX ',lgAv,ty) + n = (nint(sqrt(1.+8.*lgAv)) - 1) / 2 + lgAp = n*n + + allocate(mixAv(lgAv),turnAv(lgAv),mergeAv(lgAv),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: traiteConditionDiagonale(1) => allocation pb") + allocate(mixAp(lgAp),turnAp(lgAp),mergeAp(lgAp),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: traiteConditionDiagonale(2) => allocation pb") + call LCMGET(geoIp,'MIX ',mixAv) + call LCMLEN(geoIp,'TURN ',lg,ty) + if (lg == 0) then + turnAv(:lgAv) = 1 + else + call LCMGET(geoIp,'TURN ',turnAv) + end if + call LCMLEN(geoIp,'MERGE ',lg,ty) + if (lg == 0) then + mergeAV(:lgAv) = (/(i,i=1,lgAv)/) + else + call LCMGET(geoIp,'MERGE ',mergeAV) + end if + + pos = 0 + if ((ncode(1)==B_Diag) .and. (ncode(4)==B_Diag)) then !triangle inf + do i = 1,n + do j = 1,i-1 + k = i + ((j-1)*(2*n-j))/2 + pos = pos + 1 + mixAp(pos) = mixAv(k) + mergeAP(pos) = mergeAV(k) + turnAp(pos) = composeRotRec(turnAv(k),6) + end do + do j = i,n + k = j + ((i-1)*(2*n-i))/2 + pos = pos + 1 + mixAp(pos) = mixAv(k) + mergeAP(pos) = mergeAV(k) + turnAp(pos) = turnAv(k) + end do + end do + else if ((ncode(2)==B_Diag) .and. (ncode(3)==B_Diag)) then !triangle sup + do i = 1,n + do j = 1,i + k = j + (i*(i-1))/2 + pos = pos + 1 + mixAp(pos) = mixAv(k) + mergeAP(pos) = mergeAV(k) + turnAp(pos) = turnAv(k) + end do + do j = i+1,n + k = i + (j*(j-1))/2 + pos = pos + 1 + mixAp(pos) = mixAv(k) + mergeAP(pos) = mergeAV(k) + turnAp(pos) = composeRotRec(turnAv(k),6) + end do + end do + else + call XABORT("G2S: internal error in routine traiteConditionDiagonale") + end if + + call LCMPUT(geoIp,'MIX ',pos,1,mixAp) + call LCMPUT(geoIp,'TURN ',pos,1,turnAp) + call LCMPUT(geoIp,'MERGE ',pos,1,mergeAp) + deallocate(mixAv,turnAv,mixAp,turnAp,mergeAv,mergeAp) + end subroutine traiteConditionDiagonale + + subroutine creeListeCellules(lcIp,geoIp,nbCarre) + type(c_ptr),intent(in) :: lcIp,geoIp + integer,intent(out) :: nbCarre + + integer :: nbAV + + nbCarre = 0 + call rempliListeCellules(lcIp,geoIp,nbCarre) + do + nbAV = nbCarre + call rempliListeCellules(lcIp,geoIp,nbCarre) + if (nbCarre==nbAV) exit + end do + end subroutine creeListeCellules + + subroutine rempliListeCellules(lcIp,geoIp,nbCarre) + type(c_ptr),intent(in):: lcIp,geoIp + integer,intent(inout) :: nbCarre + + character*12 :: subName + type(c_ptr) :: subIp,jplist + integer :: i,j,long,typ,nbCell,long2 + character*12,dimension(:),allocatable :: dataCh12 + + if (nbCarre==0) then + nbCarre = 1 + jplist=LCMDID(lcIp,'root ') + call LCMEQU(geoIp,jplist) + end if + subName = ' ' + do i = 1,nbCarre + call LCMNXT(lcIp,subName) + subIp=LCMGID(lcIp,subName) + call LCMLEN(subIp,'CELL ',long,typ) + if (long/=0) then + nbCell = long/3 + allocate(dataCh12(nbCell),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: rempliListeCellules => allocation pb") + call LCMGTC(subIp,'CELL ',12,nbCell,dataCh12) + do j = 1,nbCell + call LCMLEN(subIp,dataCh12(j),long,typ) + call LCMLEN(lcIp,dataCh12(j),long2,typ) + if (long/=0.and.long2==0) then + call LCMSIX(subIp,dataCh12(j),1) + nbCarre = nbCarre + 1 + jplist=LCMDID(lcIp,dataCh12(j)) + call LCMEQU(subIp,jplist) + call LCMSIX(subIp,dataCh12(j),2) + end if + end do + deallocate(dataCh12) + end if + end do + end subroutine rempliListeCellules + + subroutine creeDico(dicoIp,lcIp,szLc) + type(c_ptr),intent(in) :: dicoIp,lcIp + integer,intent(in) :: szLc + + character*12 :: carreName,sideName,tmpStr,arrayName,nbStr + type(c_ptr) :: cIp,dIp,dJp + integer :: i,j,k,long,typ,lenMix,ind,lignNbr,lenCell + real :: side + integer,dimension(40) :: sv + integer,dimension(:),allocatable :: mix,turn,turnStr,merg,mergStr + character*12,dimension(:),allocatable :: cell,tabCh + + !initialisation + dIp = dicoIp + carreName = ' ' + do i = 1,szLc + call LCMNXT(lcIp,carreName) + cIp=LCMGID(lcIp,carreName) + sideName = 'x' // carreName(1:11) + do j = 1,2 + call getSquareSide(cIp,j,side) + dJp=LCMDID(dIp,sideName) + call LCMPUT(dJp,'value',1,2,side) + sideName(1:1)='y' + end do + end do + !remplissage + dIp = dicoIp + carreName = ' ' + lignNbr = 0 + do k = 1,szLc + !tavail sur la kieme cellule + call LCMNXT(lcIp,carreName) + cIp=LCMGID(lcIp,carreName) + call LCMGET(cIp,'STATE-VECTOR',sv) + lenMix = sv(3)*sv(4) + if ((sv(1)/=G_Car2d).or.(sv(9)==0)) cycle !pas d'info a retirer + call LCMLEN(cIp,'CELL ',lenCell,typ) + lenCell=lenCell/3 + allocate(mix(lenMix),turn(lenMix),cell(lenCell),merg(lenMix),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: creeDico(1) => allocation pb") + call LCMLEN(cIp,'TURN ',long,typ) + if (long==0) then + turn(:lenMix) = 1 + else + call LCMGET(cIp,'TURN ',turn) + end if + call LCMLEN(cIp,'MERGE ',long,typ) + if (long==0) then + merg(:lenMix) = (/(i,i=1,lenMix)/) + else + call LCMGET(cIp,'MERGE ',merg) + end if + call LCMGET(cIp,'MIX ',mix) + !on teste si tous les milieux sont bien negatifs + do i = 1,lenMix + if (mix(i)<0) cycle + call XABORT("G2S: error, meltig MIX and CELL not supported") + end do + call LCMGTC(cIp,'CELL ',12,lenCell,cell) + !travail sur l'axe des x + allocate(tabCh(2*sv(3)-1),turnStr(sv(3)),mergStr(sv(3)),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: creeDico(2) => allocation pb") + tabCh = '+' + sideName = 'x' // carreName(1:11) + dJp=LCMDID(dIp,sideName) + do j = 1,sv(4) + do i = 1,sv(3) + ind = i+(j-1)*sv(3) + tmpStr = tourne('x',turn(ind)) // cell(-mix(ind))(1:11) + tabCh(2*i-1) = tmpStr + turnStr(i) = turn(ind) + mergStr(i) = merg(ind) + end do + lignNbr = lignNbr + 1 + nbStr = i2s(lignNbr) + arrayName = "array" // nbStr(:7) + call LCMPTC(dJp,arrayName,12,2*sv(3)-1,tabCh) + arrayName = "turns" // nbStr(:7) + call LCMPUT(dJp,arrayName,sv(3),1,turnStr) + arrayName = "merge" // nbStr(:7) + call LCMPUT(dJp,arrayName,sv(3),1,mergStr) + call exploiteStr(tabCh,cIp,sideName,dicoIp,lignNbr) + end do + deallocate(tabCh,turnStr,mergStr) + !travail sur l'axe des y + allocate(tabCh(2*sv(4)-1),turnStr(sv(4)),mergStr(sv(4)),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: creeDico(3) => allocation pb") + tabCh = '+' + sideName(1:1) = 'y' + dJp=LCMDID(dIp,sideName) + do i = 1,sv(3) + do j = 1,sv(4) + ind = i+(j-1)*sv(3) + tmpStr = tourne('y',turn(ind)) // cell(-mix(ind))(1:11) + tabCh(2*j-1) = tmpStr + turnStr(j) = turn(ind) + mergStr(j) = merg(ind) + end do + lignNbr = lignNbr + 1 + nbStr = i2s(lignNbr) + arrayName = "array" // nbStr(:7) + call LCMPTC(dJp,arrayName,12,2*sv(4)-1,tabCh) + arrayName = "turns" // nbStr(:7) + call LCMPUT(dJp,arrayName,sv(4),1,turnStr) + arrayName = "merge" // nbStr(:7) + call LCMPUT(dJp,arrayName,sv(4),1,mergStr) + call exploiteStr(tabCh,cIp,sideName,dicoIp,lignNbr) + end do + deallocate(tabCh,turnStr,mergStr) + !fin du travail sur la cellule + deallocate(mix,turn,cell,merg) + end do + end subroutine creeDico + + function tourne(axe,turn) + character,intent(in) :: axe + integer,intent(in) :: turn + character :: tourne + + tourne = axe + if (mod(turn,2)==1) return + if (axe=='x') then + tourne = 'y' + else + tourne = 'x' + end if + end function tourne + + subroutine exploiteStr(inStr,carreIp,sideName,dicoIp,lignNbr) + character*12,dimension(:),intent(in) :: inStr + type(c_ptr),intent(in) :: carreIp,dicoIp + character*12,intent(in) :: sideName + integer,intent(inout) :: lignNbr + + character*12,dimension((size(inStr)+1)/2) :: tmpStr,workStr + character*12,dimension(:),allocatable :: resStr + real,dimension(:),allocatable :: mesh + character*12 :: name2 + type(c_ptr) :: workIp + integer :: i,j,k,nbOcc,szTS,szIS,nbRest,long,typ + character*12 :: arrayName,name1,meshName,number,text12 + real :: value,res + + workIp = dicoIp + szIS = size(inStr) + szTS = (szIS+1)/2 + !on enleve les "+" dans le tableau + do i = 1,szTS + tmpStr(i)=inStr(2*i-1) + enddo + !creation a partir de r=a+b+c+b+a, de a=r-b-c-b/2, + ! b=r-a-c-a/2 et c=r-a-b-b-a + do i = 1,szTS + nbOcc = 0 + do j = 1,szTS + if (tmpStr(j)==tmpStr(i)) then + nbOcc = nbOcc + 1 + else if (j > nbOcc) then + workStr(j-nbOcc) = tmpStr(j) + end if + end do + nbRest = szTS - nbOcc + if (nbOcc==1) then + allocate(resStr(2*nbRest+1),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: exploiteStr(2) => allocation pb") + else + allocate(resStr(2*nbRest+3),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: exploiteStr(3) => allocation pb") + end if + resStr(1) = sideName + do k = 1,nbRest + resStr(2*k) = '-' + resStr(2*k+1) = workStr(k) + end do + long=2*nbRest+1 + if (nbOcc/=1) then + resStr(2*nbRest+2) = '/' + number = i2s(nbOcc) + resStr(2*nbRest+3) = number + long=2*nbRest+3 + end if + lignNbr = lignNbr + 1 + text12 = i2s(lignNbr) + arrayName = "expl" // text12(:8) + call LCMSIX(workIp,tmpStr(i),1) + call LCMPTC(workIp,arrayName,12,long,resStr) + call LCMSIX(workIp,tmpStr(i),2) + deallocate(resStr) + !exploitation orthogonale de la chaine ('xa + xb' => ya=yb) + name1 = tourne(tmpStr(i)(1:1),2) // tmpStr(i)(2:12) + do k = 1,nbRest + name2 = tourne(workStr(k)(1:1),2) // workStr(k)(2:12) + lignNbr = lignNbr + 1 + arrayName = "orth" // text12(:8) + call LCMSIX(workIp,name1,1) + call LCMPTC(workIp,arrayName,12,name2) + call LCMSIX(workIp,name1,2) + end do + end do + !exploitation eventuelle du maillage en entree + if (sideName(1:1)=='x') then + meshName = 'MESHX' + else if (sideName(1:1)=='y') then + meshName = 'MESHY' + else + call XABORT("G2S: internal error in subroutine exploiteStr") + end if + call LCMLEN(carreIp,meshName,long,typ) + if (long/=0) then + allocate(mesh(long),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: exploiteStr(4) => allocation pb") + call LCMGET(carreIp,meshName,mesh) + do i = 1,szTS + call getValueOf(tmpStr(i),workIp,value) + res = mesh(i+1)-mesh(i) + if ((value>0.) .and. (abs(value-res)>geomPrec)) then + write(6,*) " ",meshName," -> ",tmpStr(i) + call XABORT("G2S: error, incoherent geometry(1)") + endif + call setValueOf(tmpStr(i),workIp,res) + end do + deallocate(mesh) + end if + end subroutine exploiteStr + + subroutine getSquareSide(cIp,axis,side) + type(c_ptr),intent(in) :: cIp + integer,intent(in) :: axis + real,intent(out) :: side + + integer :: typ,long + real,dimension(:),allocatable :: tr + + side = -1. + if (axis==1) then !axe des x + call LCMLEN(cIp,'MESHX ',long,typ) + if (long/=0) then + allocate(tr(long),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: getSquareSide(1) => allocation pb") + call LCMGET(cIp,'MESHX ',tr) + side = tr(long) - tr(1) + deallocate(tr) + end if + else if (axis==2) then !axe des y + call LCMLEN(cIp,'MESHY ',long,typ) + if (long/=0) then + allocate(tr(long),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: getSquareSide(2) => allocation pb") + call LCMGET(cIp,'MESHY ',tr) + side = tr(long) - tr(1) + deallocate(tr) + end if + else + call XABORT("G2S: internal error in subroutine getSquareSide") + end if + end subroutine getSquareSide + + subroutine getValueOf(sideName,dicoIp,value) + character*12,intent(in) :: sideName + type(c_ptr),intent(in) :: dicoIp + real,intent(out) :: value + + type(c_ptr) :: ip,jp + character*131 :: hsmg + integer :: long,typ + + ip = dicoIp + jp = LCMGID(ip,sideName) + call LCMLEN(jp,'value',long,typ) + if(long == 0) then + write(hsmg,'(36hG2S: value key missing for sideName=,a,5h (1).)') trim(sideName) + call LCMLIB(ip) + call LCMLIB(jp) + call XABORT(hsmg) + endif + call LCMGET(jp,'value',value) + end subroutine getValueOf + + subroutine setValueOf(sideName,dicoIp,value) + character*12,intent(in) :: sideName + type(c_ptr),intent(in) :: dicoIp + real,intent(in) :: value + + type(c_ptr) :: ip,jp + + ip = dicoIp + jp = LCMDID(ip,sideName) + call LCMPUT(jp,'value',1,2,value) + end subroutine setValueOf + + subroutine resoudDico(dicoIp,resIp) + type(c_ptr),intent(in) :: dicoIp,resIp + + logical :: newVal,flag1,flag2,empty,lcm + character*12 :: sideName,saveSideName,namlcm,nammy + character*131:: hsmg + type(c_ptr) :: ip,jp + integer :: ilong,long,typ + real :: val + + !la resolution se fait en travaillant sur toutes les variables une a une + !on resout les unes apres les autres toutes les equations regissant + !chaque variable (si possible) + ! on teste a chaque passe si on a trouve une nouvelle valeur + ! si oui on continue, sinon (apres une nouvelle passe infructueuse), on + ! arrete le traitement et on teste si tous les resultats sont bons + ! oui -> on sort ; non -> on abandonne car manque de donnees + + flag1 = .true. + do + flag2 = flag1 !garde la valeur de flag1 a l'essai precedent + flag1 = .false. + sideName = ' ' + call LCMINF(dicoIp,namlcm,nammy,empty,ilong,lcm) + if (.not. empty) then + call LCMNXT(dicoIp,sideName) + saveSideName = sideName + do !boucle sur toutes les donnees du dico + newVal = evaluateEquation(dicoIp,sideName) + !test si newVal a ete vrai au moins une fois + if (newVal) flag1 = .true. + call LCMNXT(dicoIp,sideName) + if (sideName == saveSideName) exit + end do + end if + if (.not.(flag1 .or. flag2)) then + !il ne s'est rien passe au cours des 2 tentatives + !precedentes => on abandonne si une valeur est non resolue + saveSideName = sideName + do !boucle sur toutes les donnees du dico + call getValueOf(sideName,dicoIp,val) + if (val<0) then !une valeur est non resolue -> ABORT + write(6,*) "Curent values of geometry :" + saveSideName = sideName + do !boucle sur toutes les donnees du dico + call getValueOf(sideName,dicoIp,val) + write(6,*) " ",sidename," -> ",val + call LCMNXT(dicoIp,sideName) + if (sideName == saveSideName) exit + end do + call XABORT("G2S: not enought data in the geometry(1)") + end if + call LCMNXT(dicoIp,sideName) + if (sideName == saveSideName) exit + end do + exit !toutes les valeurs sont bonnes + end if + end do + !recopie des resultats + ip = dicoIp + sideName = ' ' + call LCMINF(ip,namlcm,nammy,empty,ilong,lcm) + if (empty) return + call LCMNXT(ip,sideName) + saveSideName = sideName + do + jp=LCMGID(ip,sideName) + call LCMLEN(jp,'value',long,typ) + if(long == 0) then + write(hsmg,'(36hG2S: value key missing for sideName=,a,5h (2).)') trim(sideName) + call LCMLIB(ip) + call LCMLIB(jp) + call XABORT(hsmg) + endif + call LCMGET(jp,'value',val) + call LCMPUT(resIp,sideName,1,2,val) + call LCMNXT(ip,sideName) + if (sideName == saveSideName) exit + end do + end subroutine resoudDico + + function evaluateEquation(dicoIp,sideName) + type(c_ptr),intent(in) :: dicoIp + character*12,intent(in) :: sideName + logical :: evaluateEquation + !evaluation une a une des equations de dico relatives a sideName + !retourne .true. si nouvelle affectation et .false. sinon + + real :: res,val + double precision :: dres + type(c_ptr) :: sideIp + integer :: i,long,typ,ilong + logical :: goodLine,empty,lcm + character*12 :: eqName,saveEqName,namlcm,nammy + character*12,dimension(:),allocatable :: str + + evaluateEquation = .false. + sideIp = dicoIp + call LCMSIX(sideIp,sideName,1) + eqName = ' ' + call LCMINF(sideIp,namlcm,nammy,empty,ilong,lcm) + if (empty) call XABORT("G2S: intenal error in data structure in & + &function evaluateEquation") + call LCMNXT(sideIp,eqName) + saveEqName = eqName + do !recherche de la premiere occurence d'une arrayXXX + call LCMNXT(sideIp,eqName) + if (eqName(1:5)=='array') exit + if (eqName==saveEqName) then + !pas de donnee interessante => on quitte + return + end if + end do + saveEqName = eqName + do !boucle sur toutes les equations de sideName + if (eqName(1:5)/='array') then + call LCMNXT(sideIp,eqName) + if (eqName==saveEqName) exit + cycle + end if + !on travaille sur une arrayXXX + goodLine = .true. + call LCMLEN(sideIp,eqName,long,typ) + long = long/3 + allocate(str(long),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: evaluateEquation => allocation pb") + call LCMGTC(sideIp,eqName,12,long,str) + call getValueOf(str(1),dicoIp,res) + if (res<0) then + goodLine = .false. + end if + dres = res + do i = 2,long,2 + if (str(i)=='+') then + call getValueOf(str(i+1),dicoIp,val) + if (val<0) then + goodLine = .false. + exit + end if + dres = dres + val + else if (str(i)=='-') then + call getValueOf(str(i+1),dicoIp,val) + if (val<0) then + goodLine = .false. + exit + end if + dres = dres - val + else if (str(i)=='/') then + val = s2i(str(i+1)) + dres = dres / val + else + call XABORT("G2S: internal error in function evaluateEquation") + end if + end do + res = real(dres) + !si on sort normalement de la boucle, on teste la coherence + !ou on assigne le resultat obtenu + if (goodLine) then + call getValueOf(sideName,dicoIp,val) + if (val<0) then + call setValueOf(sideName,dicoIp,res) + evaluateEquation = .true. !on a resolu une nouvelle equation + else if (abs(val-res)>geomPrec) then + call XABORT("G2S: error, incoherent geometry(2)") + end if + end if + deallocate(str) + call LCMNXT(sideIp,eqName) + if (eqName==saveEqName) exit + end do + end function evaluateEquation + + subroutine prepareCentres(lCentreIpIn,lcIp,sidesIp,dicoIpIn) + type(c_ptr),intent(in) :: lCentreIpIn,lcIp,sidesIp,dicoIpIn + + type(c_ptr) :: tmpIp,coordCentIp,ip,dicoIp,lCentreIp + integer :: i,j,lg,lgc,ty,dimValToPut,nbArray,gigNum,ilong + logical :: empty,lcm + character*12 :: namlcm,nammy + character*12 :: carreName,saveCarreName,tmpName,eqName,saveEqName + character*12 :: sideName,saveSideName,arrayName,saveArrayName + character*12 :: turnName,mergeName + real :: saveVal,val + real,dimension(:),allocatable :: valToPut,xx,yy + integer,dimension(40) :: sv + integer,dimension(:),allocatable :: turns,merg + character*12,dimension(:),allocatable :: eqStr,arrayNameStr + + lCentreIp = lCentreIpIn + dicoIp = dicoIpIn + !initialisation de la liste et creation et initialisation + !d'une liste temporaire a partir du dictionnaire utilise a + !l'etape precedente, et d'un autre temporaire appelle coordCent + call LCMOP(tmpIp,'lCtemp ',0,1,0) + carreName = ' ' + call LCMINF(lcIp,namlcm,nammy,empty,ilong,lcm) + if (empty) call XABORT("G2S: intenal error in data structure in & + &subroutine prepareCentres") + call LCMNXT(lcIp,carreName) + saveCarreName = carreName + do + !travail sur lCtemp + call LCMSIX(tmpIp,carreName,1) + tmpName = 'x' // carreName(1:11) + call LCMSIX(dicoIp,tmpName,1) + eqName = ' ' + call LCMNXT(dicoIp,eqName) + saveEqName = eqName + do + if (eqName(1:5)=='array') then !l'equation est a conserver + call putEquationIn(dicoIp,eqName,tmpIp) + end if + call LCMNXT(dicoIp,eqName) + if (eqName==saveEqName) exit + end do + call LCMSIX(dicoIp,tmpName,2) + call LCMSIX(tmpIp,carreName,2) + !travail sur lCentre + call LCMSIX(lCentreIp,carreName,1) + call LCMSIX(lCentreIp,carreName,2) + call LCMNXT(lcIp,carreName) + if (carreName==saveCarreName) exit + end do + + !creation d'un autre temporaire appelle coordCent + call LCMOP(coordCentIp,'lCoordCent ',0,1,0) + sideName = ' ' + call LCMNXT(dicoIp,sideName) + saveSideName = sideName + do + call LCMSIX(dicoIp,sideName,1) + eqName = ' ' + call LCMNXT(dicoIp,eqName) + saveEqName = eqName + do + if (eqName(1:5)=='array') then !l'equation est a exploiter + call LCMLEN(dicoIp,eqName,lg,ty) + lg = lg / 3 + dimValToPut = (lg+1) / 2 + allocate(eqStr(lg),valToPut(dimValToPut),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: prepareCentres(1) => allocation pb") + call LCMGTC(dicoIp,eqName,12,lg,eqStr) + !calcul des coordonnees des sous cellules de la cellule + !consideree et stockage de la valeur obtenu dans coordCent + call LCMGET(sidesIp,sideName,val) + valToPut(1) = -0.5 * val + call LCMGET(sidesIp,eqStr(1),val) + valToPut(1) = valToPut(1) + 0.5 * val + do i = 2,dimValToPut + saveVal = val + call LCMGET(sidesIp,eqStr(2*i-1),val) + valToPut(i) = valToPut(i-1) + 0.5 * (val+saveVal) + end do + call LCMPUT(coordCentIp,sideName,dimValToPut,2,valToPut) + deallocate(eqStr,valToPut) + exit !on sort car on n'a pas a verifier la coherence + end if + call LCMNXT(dicoIp,eqName) + if (eqName==saveEqName) exit + end do + call LCMSIX(dicoIp,sideName,2) + call LCMNXT(dicoIp,sideName) + if (sideName==saveSideName) exit + end do + + carreName = ' ' + call LCMNXT(lcIp,carreName) + saveCarreName = carreName + do + ip=LCMGID(lcIp,carreName) + call LCMGET(ip,'STATE-VECTOR',sv) + !recuperation des noms des equations utiles + call LCMSIX(tmpIp,carreName,1) + call LCMINF(tmpIp,namlcm,nammy,empty,ilong,lcm) + if (.not. empty) then + allocate(arrayNameStr(max(sv(3),sv(4)))) + nbArray = 0 + arrayName = ' ' + call LCMNXT(tmpIp,arrayName) + saveArrayName = arrayName + do + if (arrayName(1:5)/='array') then + call LCMNXT(tmpIp,arrayName) + if (arrayName == saveArrayName) exit + cycle + end if + nbArray = nbArray + 1 + arrayNameStr(nbArray) = arrayName + call LCMNXT(tmpIp,arrayName) + if (arrayName == saveArrayName) exit + end do + !trie des noms des equations + call sortTabCh12(arrayNameStr,nbArray) + !travail sur les equations + gigNum = 0 + do i = 1,nbArray + arrayName = arrayNameStr(i) + call LCMLEN(tmpIp,arrayName,lgc,ty) + lgc = lgc / 3 + allocate(eqStr(lgc)) + lg = (lgc+1) / 2 + allocate(turns(lg),merg(lg),xx(lg),yy(nbArray)) + call LCMGTC(tmpIp,arrayName,12,lgc,eqStr) + turnName = 'turns' // arrayName(6:12) + call LCMGET(tmpIp,turnName,turns) + mergeName = 'merge' // arrayName(6:12) + call LCMGET(tmpIp,mergeName,merg) + do j = 1,lg + gigNum = gigNum + 1 + sideName = 'x' // carreName(1:11) + call LCMGET(coordCentIp,sideName,xx) + sideName(1:1) = 'y' + call LCMGET(coordCentIp,sideName,yy) + sideName=eqStr(2*j-1)(2:12) + !ajout du resultat dans lCentre + call addInRes(lCentreIp,sideName,carreName, & + & xx(j),yy(i),turns(j),gigNum,merg(j)) + end do + deallocate(eqStr,turns,merg,xx,yy) + end do + deallocate(arrayNameStr) + end if + + call LCMSIX(tmpIp,carreName,2) + call LCMNXT(lcIp,carreName) + if (carreName==saveCarreName) exit + end do + !destruction du repertoire 'root' dans lCentre + call LCMDEL(lCentreIp,'root ') + !fermeture des temporaires + call LCMCL(coordCentIp,2) + call LCMCL(tmpIp,2) + end subroutine prepareCentres + + subroutine addInRes(ipIn,extName,intName,xx,yy,turn,gigNum,merg) + type(c_ptr),intent(in) :: ipIn + integer,intent(in) :: turn,gigNum,merg + character*12,intent(in) :: extName,intName + real,intent(in) :: xx,yy + + real,dimension(:),allocatable :: tabR + integer,dimension(:),allocatable :: tabI + character*12 :: reg,gigName + integer :: lg,ty + type(c_ptr) :: ip + + ip = ipIn + call LCMSIX(ip,extName,1) + call LCMSIX(ip,intName,1) + reg = 'x' + call LCMLEN(ip,reg,lg,ty) + allocate(tabR(lg+1)) + !ajout de xx + if (lg /= 0) call LCMGET(ip,reg,tabR) + tabR(lg+1) = xx + call LCMPUT(ip,reg,lg+1,2,tabR) + !ajout de yy + reg = 'y' + if (lg /= 0) call LCMGET(ip,reg,tabR) + tabR(lg+1) = yy + call LCMPUT(ip,reg,lg+1,2,tabR) + deallocate(tabR) + !ajout de turn + reg = 't' + allocate(tabI(lg+1)) + if (lg /= 0) call LCMGET(ip,reg,tabI) + tabI(lg+1) = turn + call LCMPUT(ip,reg,lg+1,1,tabI) + deallocate(tabI) + !ajout de la gigogne et du merge + gigName = i2s(lg+1) + call LCMSIX(ip,gigName,1) + reg = 'gig' + call LCMPUT(ip,reg,1,1,gigNum) + reg = 'mrg' + call LCMPUT(ip,reg,1,1,merg) + call LCMSIX(ip,gigName,2) + call LCMSIX(ip,intName,2) + call LCMSIX(ip,extName,2) + end subroutine addInRes + + subroutine sortTabCh12(tab,sz) + character*12,dimension(:),intent(inout) :: tab + integer,intent(in) :: sz + + integer :: indMax,i,s1,s2 + logical :: trie + character*12 :: tmp + + do indMax = sz,2,-1 + trie = .true. + do i = 1,indMax-1 + s1 = s2i(tab(i)(6:12)) + s2 = s2i(tab(i+1)(6:12)) + if (s2 traitement particulier + call LCMSIX(resIp,'root ',1) + call LCMSIX(resIp,'root ',1) + call LCMPUT(resIp,'x ',1,2,0.) + call LCMPUT(resIp,'y ',1,2,0.) + call LCMPUT(resIp,'t ',1,1,1) + call LCMSIX(resIp,'1 ',1) + call LCMPUT(resIp,'gig ',1,1,1) + call LCMPUT(resIp,'mrg ',1,1,1) + call LCMSIX(resIp,'1 ',2) + call LCMSIX(resIp,'root ',2) + call LCMSIX(resIp,'root ',2) + return + end if + call LCMOP(valuesIp,'temporariObj',0,1,0) + call LCMNXT(tmpLcIp,dirName) + saveDirName = dirName + nbGig = 0 + do + call LCMSIX(tmpLcIp,dirName,1) + subDirName = ' ' + call LCMINF(tmpLcIp,namlcm,nammy,empty,ilong,lcm) + if (.not. empty) then + call LCMNXT(tmpLcIp,subDirName) + saveSubDirName = subDirName + do + call LCMLEN(valuesIp,subDirName,lg,ty) + if (lg==0) then + nbGig = nbGig + 1 + call LCMSIX(valuesIp,subDirName,1) + call LCMSIX(valuesIp,subDirName,2) + end if + call LCMNXT(tmpLcIp,subDirName) + if (subDirName==saveSubDirName) exit + end do + end if + call LCMSIX(tmpLcIp,dirName,2) + call LCMNXT(tmpLcIp,dirName) + if (dirName==saveDirName) exit + end do + !test de sortie de la recurrence + if (nbGig <= 1) then + call LCMEQU(lcIp,resIp) + call LCMCL(valuesIp,2) + return + end if + !liste des cellules a garder + dirName = ' ' + call LCMNXT(lcIp,dirName) + saveDirName = dirName + do + call LCMLEN(valuesIp,dirName,lg,ty) + if (lg==0) call LCMDEL(resIp,dirName) + call LCMNXT(lcIp,dirName) + if (dirName==saveDirName) exit + end do + + dirName = ' ' + call LCMNXT(lcIp,dirName) + saveDirName = dirName + do + call LCMLEN(valuesIp,dirName,lg,ty) + if (lg==0) then + call LCMSIX(tmpLcIp,dirName,1) + subDirName = ' ' + call LCMNXT(tmpLcIp,subDirName) + saveSubDirName = subDirName + do + call LCMSIX(tmpLcIp,subDirName,1) + if (subDirName/='root') then + call LCMLEN(tmpLcIp,'t ',lg,ty) + do i = 1,lg + call LCMOP(tmpDic,'tmpDic ',0,1,0) + call translateDic(tmpDic,lcIp,dirName,subDirName,i) + call mergeDic(resIp,dirName,tmpDic) + call LCMCL(tmpDic,2) + end do + else + call LCMOP(tmpDic,'tmpDic ',0,1,0) + call LCMSIX(tmpDic,subDirName,1) + call LCMEQU(tmpLcIp,tmpDic) !copie uniquement de la branche + !interresante (lc[dirname]['root']) + call LCMSIX(tmpDic,subDirName,2) + call mergeDic(resIp,dirName,tmpDic) + call LCMCL(tmpDic,2) + end if + call LCMSIX(tmpLcIp,subDirName,2) + call LCMNXT(tmpLcIp,subDirName) + if (subDirName==saveSubDirName) exit + end do + call LCMSIX(tmpLcIp,dirName,2) + end if + call LCMNXT(lcIp,dirName) + if (dirName==saveDirName) exit + end do + !iteration + call LCMOP(cpResIp,'resCentres ',0,1,0) + call LCMEQU(resIp,cpResIp) + call calculeCentre(resIp,cpResIp,deep+1) + call LCMCL(cpResIp,2) + !elimination des cellules non terminales si deep==0 + if (deep==0) then + dirName = ' ' + call LCMNXT(valuesIp,dirName) + saveDirName = dirName + do + call LCMLEN(resIp,dirName,lg,ty) + if (lg/=0) call LCMDEL(resIp,dirName) + call LCMNXT(valuesIp,dirName) + if (dirName==saveDirName) exit + end do + end if + call LCMCL(valuesIp,2) + end subroutine calculeCentre + + subroutine translateDic(resIp,dicIp,dName,sDName,ind) + type(c_ptr),intent(in) :: resIp,dicIp + integer,intent(in) :: ind + character*12,intent(in) :: dName,sDName + !effectue la translation dans le repere de la cellule englobante + !de la liste des cellules de dicIp[sDName], suivant les vecteurs de + !dicIp[dName][sDName] (qui comprennent x(i),y(i),t(i),[`i`][gig] i=1,sz) + + character*12 :: dirName,saveDirName,gigName + type(c_ptr) :: tmpRes,tmpDic + integer :: i,lg,ty,tval,lggigI,lggigval + real :: xval,yval + integer,dimension(:),allocatable :: tt,gigI,gigval,mrgI,mrgval + real,dimension(:),allocatable :: xx,yy + + tmpRes = resIp ; tmpDic = dicIp + !recuperation des donnees de translation + call LCMSIX(tmpDic,dName,1) + call LCMSIX(tmpDic,sDName,1) + call LCMLEN(tmpDic,'t ',lg,ty) + allocate(xx(lg),yy(lg),tt(lg)) + call LCMGET(tmpDic,'t ',tt) ; tval = tt(ind) + call LCMGET(tmpDic,'x ',xx) ; xval = xx(ind) + call LCMGET(tmpDic,'y ',yy) ; yval = yy(ind) + deallocate(xx,yy,tt) + gigName = i2s(ind) + call LCMSIX(tmpDic,gigName,1) + call LCMLEN(tmpDic,'gig ',lggigval,ty) + allocate(gigval(lggigval),mrgval(lggigval)) + call LCMGET(tmpDic,'gig ',gigval) + call LCMGET(tmpDic,'mrg ',mrgval) + tmpDic = dicIp + !translation + call LCMSIX(tmpDic,sDName,1) + dirName = ' ' + call LCMNXT(tmpDic,dirName) + saveDirName = dirName + do + call LCMSIX(tmpDic,dirName,1) + call LCMSIX(tmpRes,dirName,1) + call LCMLEN(tmpDic,'t ',lg,ty) + allocate(xx(lg),yy(lg),tt(lg)) + call LCMGET(tmpDic,'t ',tt) + call LCMGET(tmpDic,'x ',xx) + call LCMGET(tmpDic,'y ',yy) + do i = 1,lg + gigName = i2s(i) + call LCMSIX(tmpDic,gigName,1) + call LCMSIX(tmpRes,gigName,1) + call LCMLEN(tmpDic,'gig ',lggigI,ty) + allocate(gigI(lggigI+lggigval),mrgI(lggigI+lggigval)) + call LCMGET(tmpDic,'gig ',gigI) + call LCMGET(tmpDic,'mrg ',mrgI) + call translateWithTurn(xx(i),yy(i),tt(i),xval,yval,tval) + gigI(lggigI+1:lggigI+lggigval) = gigval + call LCMPUT(tmpRes,'gig ',lggigI+lggigval,1,gigI) + mrgI(lggigI+1:lggigI+lggigval) = mrgval + call LCMPUT(tmpRes,'mrg ',lggigI+lggigval,1,mrgI) + deallocate(gigI,mrgI) + call LCMSIX(tmpRes,gigName,2) + call LCMSIX(tmpDic,gigName,2) + end do + call LCMPUT(tmpRes,'t ',lg,1,tt) + call LCMPUT(tmpRes,'x ',lg,2,xx) + call LCMPUT(tmpRes,'y ',lg,2,yy) + deallocate(xx,yy,tt) + call LCMSIX(tmpRes,dirName,2) + call LCMSIX(tmpDic,dirName,2) + call LCMNXT(tmpDic,dirName) + if (dirName==saveDirName) exit + end do + deallocate(gigval,mrgval) + end subroutine translateDic + + subroutine translateWithTurn(xx,yy,tt,xval,yval,tval) + real,intent(inout) :: xx,yy + integer,intent(inout) :: tt + real,intent(in) :: xval,yval + integer,intent(in) :: tval + + select case(geomTyp) + case(RecTyp) + select case (tt) + case(1) + xx=xx+xval ; yy=yy+yval + case(2) + xx=xx+yval ; yy=yy-xval + case(3) + xx=xx-xval ; yy=yy-yval + case(4) + xx=xx-yval ; yy=yy+xval + case(5) + xx=xx-xval ; yy=yy+yval + case(6) + xx=xx+yval ; yy=yy+xval + case(7) + xx=xx+xval ; yy=yy-yval + case(8) + xx=xx-yval ; yy=yy-xval + end select + tt = composeRotRec(tval,tt) + case(TriaTyp) + select case (tt) + case(1) + xx=xx+xval ; yy=yy+yval + case(2) + xx=xx+0.5*(xval-sqrt_3f*yval) + yy=yy+0.5*(yval+sqrt_3f*xval) + case(3) + xx=xx+0.5*(-xval-sqrt_3f*yval) + yy=yy+0.5*(-yval+sqrt_3f*xval) + case(4) + xx=xx-xval ; yy=yy-yval + case(5) + xx=xx+0.5*(-xval+sqrt_3f*yval) + yy=yy+0.5*(-yval-sqrt_3f*xval) + case(6) + xx=xx+0.5*(xval+sqrt_3f*yval) + yy=yy+0.5*(yval-sqrt_3f*xval) + case(7) + xx=xx+xval ; yy=yy-yval + case(8) + xx=xx+0.5*(xval-sqrt_3f*yval) + yy=yy-0.5*(yval+sqrt_3f*xval) + case(9) + xx=xx+0.5*(-xval-sqrt_3f*yval) + yy=yy-0.5*(-yval+sqrt_3f*xval) + case(10) + xx=xx-xval ; yy=yy+yval + case(11) + xx=xx+0.5*(-xval+sqrt_3f*yval) + yy=yy+0.5*(yval+sqrt_3f*xval) + case(12) + xx=xx+0.5*(xval+sqrt_3f*yval) + yy=yy-0.5*(yval-sqrt_3f*xval) + end select + tt = composeRotTri(tval,tt) + case default + call XABORT("G2S: internal error in subroutine translateWithTurn") + end select + end subroutine translateWithTurn + + subroutine mergeDic(resIp,dirName,otherDicIp) + type(c_ptr),intent(in) :: resIp,otherDicIp + character*12,intent(in) :: dirName + !concatene deux dictionnaires (res[dirName] et otherDic) + !contenants des positions (x,y,t,(1:gig),..,(size(t):gig)) + + character*12 :: sdName,nGig,namlcm,nammy + type(c_ptr) :: tmpResIp,tmpOtherIp + integer :: i,lg,ty,lgN,lgO,ilong + logical :: empty,lcm + real,dimension(:),allocatable :: nra,ora + integer,dimension(:),allocatable :: nia,oia,mrg + + tmpResIp = resIp ; tmpOtherIp = otherDicIp + call LCMSIX(tmpResIp,dirName,1) + call LCMINF(tmpOtherIp,namlcm,nammy,empty,ilong,lcm) + if (empty) return !### + sdName = ' ' + call LCMNXT(tmpOtherIp,sdName) + call LCMSIX(tmpOtherIp,sdName,1) + call LCMSIX(tmpResIp,sdName,1) + call LCMLEN(tmpResIp,'t ',lgN,ty) + if (lgN/=0) then !le repertoire existait deja => ajout de donnees + call LCMLEN(tmpOtherIp,'t ',lgO,ty) + allocate(nra(lgO+lgN),ora(lgO),nia(lgO+lgN),oia(lgO)) + !t + call LCMGET(tmpResIp,'t ',nia) + call LCMGET(tmpOtherIp,'t ',oia) + nia(lgN+1:lgO+lgN) = oia + call LCMPUT(tmpResIp,'t ',lgO+lgN,1,nia) + !x + call LCMGET(tmpResIp,'x ',nra) + call LCMGET(tmpOtherIp,'x ',ora) + nra(lgN+1:lgO+lgN) = ora + call LCMPUT(tmpResIp,'x ',lgO+lgN,2,nra) + !y + call LCMGET(tmpResIp,'y ',nra) + call LCMGET(tmpOtherIp,'y ',ora) + nra(lgN+1:lgO+lgN) = ora + call LCMPUT(tmpResIp,'y ',lgO+lgN,2,nra) + deallocate(nra,ora,nia,oia) + lg = lgO + do i = 1,lg + nGig = i2s(i) + call LCMSIX(tmpOtherIp,nGig,1) + call LCMLEN(tmpOtherIp,'gig ',lgO,ty) + allocate(oia(lgO),mrg(lgO)) + call LCMGET(tmpOtherIp,'gig ',oia) + call LCMGET(tmpOtherIp,'mrg ',mrg) + call LCMSIX(tmpOtherIp,nGig,2) + nGig = i2s(i+lgN) + call LCMSIX(tmpResIp,nGig,1) + call LCMPUT(tmpResIp,'gig ',lgO,1,oia) + call LCMPUT(tmpResIp,'mrg ',lgO,1,mrg) + call LCMSIX(tmpResIp,nGig,2) + deallocate(oia,mrg) + end do + else !le repertoire n'existait pas encore => affectation directe + !call LCMEQU(tmpOtherIp,tmpResIp) + call LCMLEN(tmpOtherIp,'t ',lg,ty) + allocate(ora(lg),oia(lg)) + !t + call LCMGET(tmpOtherIp,'t ',oia) + call LCMPUT(tmpResIp,'t ',lg,1,oia) + !x + call LCMGET(tmpOtherIp,'x ',ora) + call LCMPUT(tmpResIp,'x ',lg,2,ora) + !y + call LCMGET(tmpOtherIp,'y ',ora) + call LCMPUT(tmpResIp,'y ',lg,2,ora) + deallocate(ora,oia) + do i = 1,lg + nGig = i2s(i) + call LCMSIX(tmpOtherIp,nGig,1) + call LCMLEN(tmpOtherIp,'gig ',lgO,ty) + allocate(oia(lgO),mrg(lgO)) + call LCMGET(tmpOtherIp,'gig ',oia) + call LCMGET(tmpOtherIp,'mrg ',mrg) + call LCMSIX(tmpOtherIp,nGig,2) + call LCMSIX(tmpResIp,nGig,1) + call LCMPUT(tmpResIp,'gig ',lgO,1,oia) + call LCMPUT(tmpResIp,'mrg ',lgO,1,mrg) + call LCMSIX(tmpResIp,nGig,2) + deallocate(oia,mrg) + end do + end if + end subroutine mergeDic + + subroutine compileResutats(geoIp,lCentreIp,lSideIp,boundDataIp) + type(c_ptr),intent(in) :: geoIp,lCentreIp,lSideIp,boundDataIp + + type(c_ptr) :: geo,centres + integer :: i,lg,ty,lgG + character*12 :: carreName,saveCarreName,gigName,num,mrgName + real,dimension(2) :: sideXY + real,dimension(4) :: minmaxXY + real,dimension(:),allocatable :: xx,yy + integer,dimension(:),allocatable :: tt,gigI,mrgI + + geo = geoIp ; centres = lCentreIp + call LCMSIX(geo,'NEW-DATA ',1) + carreName = ' ' + call LCMNXT(centres,carreName) + saveCarreName = carreName + do + call LCMSIX(geo,carreName,1) + !SIDEXY + call LCMGET(lSideIp,'x'//carreName,sideXY(1)) + call LCMGET(lSideIp,'y'//carreName,sideXY(2)) + if (geomTyp==RecTyp) then + call LCMPUT(geo,'SIDEXY ',2,2,sideXY) + else + call LCMPUT(geo,'SIDEXY ',2,2,sideXY(1)) + end if + !COORDX , COORDY , TURN , POSi + call LCMSIX(centres,carreName,1) + call LCMSIX(centres,'root ',1) + call LCMLEN(centres,'t ',lg,ty) + allocate(xx(lg),yy(lg),tt(lg)) + call LCMGET(centres,'x ',xx) + call LCMPUT(geo,'COORDX ',lg,2,xx) + call LCMGET(centres,'y ',yy) + call LCMPUT(geo,'COORDY ',lg,2,yy) + call LCMGET(centres,'t ',tt) + call LCMPUT(geo,'TURN ',lg,1,tt) + do i = 1,lg + num = i2s(i) + gigName = num + call LCMSIX(centres,gigName,1) + call LCMLEN(centres,'gig ',lgG,ty) + allocate(gigI(lgG),mrgI(lgG)) + call LCMGET(centres,'gig ',gigI) + call LCMGET(centres,'mrg ',mrgI) + call LCMSIX(centres,gigName,2) + gigName = 'POS' // num(:9) + call LCMPUT(geo,gigName,lgG,1,gigI) + mrgName = 'MRG' // num(:9) + call LCMPUT(geo,mrgName,lgG,1,mrgI) + deallocate(gigI,mrgI) + end do + deallocate(xx,yy,tt) + call LCMSIX(centres,'root ',2) + call LCMSIX(centres,carreName,2) + !on cycle + call LCMSIX(geo,carreName,2) + call LCMNXT(centres,carreName) + if (carreName==saveCarreName) exit + end do + !donnes sur les CL + call LCMSIX(geo,'BOUND-DATA ',1) + !SIDEXY + call LCMGET(lSideIp,'xroot ',sideXY(1)) + call LCMGET(lSideIp,'yroot ',sideXY(2)) + call LCMPUT(geo,'SIDEXY ',2,2,sideXY) + !MINMAXXY + call LCMGET(boundDataIp,'minX ',minmaxXY(1)) + call LCMGET(boundDataIp,'minY ',minmaxXY(2)) + call LCMGET(boundDataIp,'maxX ',minmaxXY(3)) + call LCMGET(boundDataIp,'maxY ',minmaxXY(4)) + call LCMPUT(geo,'MINMAXXY ',4,2,minmaxXY) + end subroutine compileResutats + + subroutine creerEtChargerNewDataHex(geoIp,szB,szP) + type(c_ptr),intent(in) :: geoIp + integer,intent(inout) :: szB,szP + + real,dimension(:),allocatable :: txx,tyy + integer,dimension(:),allocatable :: turn,mix,merg + character*12,dimension(:),allocatable :: cells + real :: side + double precision :: sdX,sdY + integer,dimension(40) :: sv + type(c_ptr) :: ip + integer :: nbH,lg,typ,iHex,i,j,k,l + integer :: a,b,aa,bb,nbC,ind,lgSide + integer,dimension(6) :: da,db + real,dimension(4) :: fooData + + ip = geoIp + !ajout de donnees pour le cas d'une seule cellule + call LCMSIX(ip,'NEW-DATA ',1) + call LCMSIX(ip,'BOUND-DATA ',1) + fooData = 0. + call LCMPUT(ip,'MINMAXXY ',4,2,fooData) + call LCMSIX(ip,'BOUND-DATA ',2) + call LCMSIX(ip,'NEW-DATA ',2) + !placement des cellules + call LCMGET(ip,'STATE-VECTOR',sv) + nbH=sv(3) + nbC=sv(9) + if ((sv(8)==0).and.(nbH==1)) then !pas de sous-cellules + call giveSide(ip,szB,side) + fooData(1)=2.0*side + fooData(2)=2.0*sqrt(0.75)*side + call LCMPUT(ip,'SIDEXY ',4,2,fooData) + call chargerNewData(geoIp,szB,szP) + return + end if + allocate(txx(nbH),tyy(nbH),turn(nbH),mix(nbH),merg(nbH)) + call LCMGET(ip,'MIX ',mix) + call LCMLEN(ip,'TURN ',lg,typ) + if (lg/=0) then + call LCMGET(ip,'TURN ',turn) + else + turn = 1 + end if + call LCMLEN(ip,'MERGE ',lg,typ) + if (lg/=0) then + call LCMGET(ip,'MERGE ',merg) + else + merg(:nbH) = (/(i,i=1,nbH)/) + end if + call LCMGET(ip,'IHEX ',iHex) + lgSide = 0 + select case(iHex) + case(H_S30) + a = -1 ; l = 0 ; i = 0 + do + i = i + 1 + do j = 0,1 + a = a + 1 ; b = j + do k = 1,i + l = l + 1 ; txx(l) = a ; tyy(l) = b ; lgSide = 2*b ; b = b + 2 + if (l==nbH) goto 10 + end do + end do + end do + case(H_SA60) + l = 0 ; i = -1 + do + i = i + 1 ; a = i ; b = -i + do j = 0,i + l = l + 1 ; txx(l) = a ; tyy(l) = b ; lgSide = 2*b ; b = b + 2 + if (l==nbH) goto 10 + end do + end do + case(H_SB60) + a = -1 ; l = 0 ; i = 0 + do + i = i + 1 + do j = 0,1 + a = a + 1 ; b = j + do k = 0,i + l = l + 1 ; txx(l) = a ; tyy(l) = b ; lgSide = 2*b ; b = b + 2 + if (l==nbH) goto 10 + end do + aa = a ; bb = b + do k = 0,i-1 + l = l + 1 ; aa = aa - 1 ; bb = bb + 1 + txx(l) = aa ; tyy(l) = bb + if (l==nbH) goto 10 + end do + end do + end do + case(H_S90) + da = (/0,-1,0,0,0,0/) ; db = (/2,1,0,0,0,0/) ; l = 1 ; i = 0 + txx(l) = 0 ; tyy(l) = 0 + if (l==nbH) goto 10 + do + i = i + 1 ; a = i ; b = -i + do j = 1,2 + do k = 1,i + a = a + da(j) ; b = b + db(j) + if (b>=0) then + l = l + 1 ; txx(l) = a ; tyy(l) = b ; lgSide = b + if (l==nbH) goto 10 + end if + end do + end do + end do + case(H_R120) + da = (/0,-1,0,0,0,0/) ; db = (/2,1,0,0,0,0/) ; l = 1 ; i = 0 + txx(l) = 0 ; tyy(l) = 0 + if (l==nbH) goto 10 + do + i = i + 1 ; a = i ; b = -i + do j = 1,2 + do k = 1,i + a = a + da(j) ; b = b + db(j) + l = l + 1 ; txx(l) = a ; tyy(l) = b ; lgSide = b + if (l==nbH) goto 10 + end do + end do + end do + case(H_R180) + da = (/1,0,-1,0,0,0/) ; db = (/1,2,1,0,0,0/) ; l = 1 ; i = 0 + txx(l) = 0 ; tyy(l) = 0 + if (l==nbH) goto 10 + do + i = i + 1 ; a = 0 ; b = -2*i + do j = 1,3 + do k = 1,i + a = a + da(j) ; b = b + db(j) + l = l + 1 ; txx(l) = a ; tyy(l) = b ; lgSide = b + if (l==nbH) goto 10 + end do + end do + end do + case(H_SA180) + da = (/1,0,-1,0,0,0/) ; db = (/1,2,1,0,0,0/) ; l = 1 ; i = 0 + txx(l) = 0 ; tyy(l) = 0 + if (l==nbH) goto 10 + do + i = i + 1 ; a = 0 ; b = -2*i + l = l + 1 ; txx(l) = a ; tyy(l) = b + if (l==nbH) goto 10 + do j = 1,3 + do k = 1,i + a = a + da(j) ; b = b + db(j) + l = l + 1 ; txx(l) = a ; tyy(l) = b ; lgSide = b + if (l==nbH) goto 10 + end do + end do + end do + case(H_SB180) + da = (/0,-1,-1,0,0,0/) ; db = (/2,1,-1,-2,0,0/) ; l = 1 ; i = 0 + txx(l) = 0 ; tyy(l) = 0 + if (l==nbH) goto 10 + do + i = i + 1 ; a = i ; b = -i + do j = 1,4 + do k = 1,i + if (b>=0) then + l = l + 1 ; txx(l) = a ; tyy(l) = b ; lgSide = -2*a + if (l==nbH) goto 10 + end if + a = a + da(j) ; b = b + db(j) + end do + end do + end do + case(H_Complete) + da = (/-1,-1,0,1,1,0/) ; db = (/1,-1,-2,-1,1,2/) ; l = 1 ; i = 0 + txx(l) = 0 ; tyy(l) = 0 + if (l==nbH) goto 10 + do + i = i + 1 ; a = i ; b = i + do j = 1,6 + do k = 1,i + l = l + 1 ; txx(l) = a ; tyy(l) = b ; lgSide = 2*a + if (l==nbH) goto 10 + a = a + da(j) ; b = b + db(j) + end do + end do + end do + end select +10 continue !sortie de la boucle de remplissage des positions (bhaaa, un goto) + call giveSide(ip,szB,side) + sdX = side*1.5d0 ; sdY = side*0.5d0*sqrt(3.d0) + bCData%sidexy(1) = side ; bCData%sidexy(2) = lgSide * sdY + if (sv(8)==0) then !no sub-geometries + do j = 1,nbH + szP = szP + 1 + tabCellulePlaced(szP)%indice = 1 + tabCellulePlaced(szP)%xcenter = txx(j)*sdX + tabCellulePlaced(szP)%ycenter = tyy(j)*sdY + tabCellulePlaced(szP)%turn = turn(j) + allocate(tabCellulePlaced(szP)%gig(1)) + tabCellulePlaced(szP)%gig(1) = j + allocate(tabCellulePlaced(szP)%mrg(1)) + tabCellulePlaced(szP)%mrg(1) = merg(j) + enddo + else + allocate(cells(nbC)) + call LCMGTC(ip,'CELL ',12,nbC,cells) + do i = 1,szB + ind = 0 + do j = 1,szB + if (cells(i)==tabCelluleBase(j)%name) then + ind = j + exit + end if + end do + if (ind==0) call XABORT("G2S: internal error in function& + & creerEtChargerNewDataHex") + do j = 1,nbH + if (mix(j)==-i) then + !on va creer une cellule placee d'indice ind en position j + szP = szP + 1 + tabCellulePlaced(szP)%indice = ind + tabCellulePlaced(szP)%xcenter = txx(j)*sdX + tabCellulePlaced(szP)%ycenter = tyy(j)*sdY + tabCellulePlaced(szP)%turn = turn(j) + allocate(tabCellulePlaced(szP)%gig(1)) + tabCellulePlaced(szP)%gig(1) = j + allocate(tabCellulePlaced(szP)%mrg(1)) + tabCellulePlaced(szP)%mrg(1) = merg(j) + end if + end do + end do + deallocate(cells) + endif + deallocate(txx,tyy,turn,mix,merg) + end subroutine creerEtChargerNewDataHex + + subroutine giveSide(ip,szB,side) + type(c_ptr),intent(in) :: ip + integer,intent(in) :: szB + real,intent(inout) :: side + + integer :: i,lg,typ + logical :: gotIt + double precision :: dside + + gotIt = .false. + call LCMLEN(ip,'SIDE ',lg,typ) + if (lg/=0) then + call LCMGET(ip,'SIDE ',side) + gotIt = .true. + dside = side + end if + do i = 1,szB + if (tabCelluleBase(i)%ok(n_side)) then + if (gotIt) then + if (.not. isEqual(tabCelluleBase(i)%side,dside)) & + & call XABORT("G2S: Error in the value of argument SIDE& + & in the geometry") + else + gotIt = .true. + dside = tabCelluleBase(i)%side + end if + else if (gotIt) then + tabCelluleBase(i)%side = dside + end if + end do + if (.not. gotIt) then + call XABORT("G2S: Error in the value of argument SIDE in the geometry") + end if + do i = 1,szB + tabCelluleBase(i)%ok(n_side) = .true. + tabCelluleBase(i)%side = dside + end do + side = real(dside) + end subroutine giveSide + + subroutine creerEtChargerNewDataTri(geoIp,szB,szP) + type(c_ptr),intent(in):: geoIp + integer,intent(inout) :: szB,szP + + type(c_ptr) :: ip,lcIp,dicoIp,sidesIp,lCentreIp,centreCalculesIp + integer :: szLc + + ip = geoIp + !creation de la liste des triangles + call LCMOP(lcIp,'lc ',0,1,0) + call creeListeCellules(lcIp,ip,szLc) + + !creation d'une structure pour le calcul des longueurs des cotes + call LCMOP(dicoIp,'dico ',0,1,0) + call creeStructure(dicoIp,lcIp,szLc) + + !creation de la liste des longueurs des cotes et resolution du systeme + !et destruction de la structure + call LCMOP(sidesIp,'sides ',0,1,0) + call resoudStructure(dicoIp,sidesIp) + call LCMCL(dicoIp,2) + + !cree et prepare la liste des centres des cellules de base, + !avec leur gigogne d'origine + call LCMOP(lCentreIp,'centres ',0,1,0) + call prepareCentresTri(lCentreIp,lcIp,szLc,sidesIp) + + !resolution du systeme donnant les coordonnees des centres des cellules + !de base et stockage dans une nouvelle structure + call LCMOP(centreCalculesIp,'resCentres ',0,1,0) + call calculeCentre(centreCalculesIp,lCentreIp,0) + + !compilation des resultats et ajout dans la geometrie des nouvelles donnees + call compileResutatsTri(ip,lcIp,szLc,centreCalculesIp,sidesIp) + call LCMCL(lcIp,2) + call LCMCL(centreCalculesIp,2) + call LCMCL(sidesIp,2) + !utilisation des donnees (on accroche le traitement classique developpe + !pour python) + call chargerNewData(geoIp,szB,szP) + end subroutine creerEtChargerNewDataTri + + subroutine creeStructure(dicoIp,lcIp,szLc) + type(c_ptr),intent(in) :: dicoIp,lcIp + integer,intent(in) :: szLc + + character*12 :: triName + type(c_ptr) :: triIp,dIp + integer :: i,j,k,lg,ty,lenMix,lignNbr + real :: side,value + integer,dimension(40) :: sv + integer,dimension(:),allocatable :: mix + character*12,dimension(:),allocatable :: cell + + !initialisation + dIp = dicoIp + triName = ' ' + do i = 1,szLc + call LCMNXT(lcIp,triName) + triIp=LCMGID(lcIp,triName) + side = -1. + call LCMLEN(triIp,'SIDE ',lg,ty) + if (lg/=0) call LCMGET(triIp,'SIDE ',side) + call LCMSIX(dIp,triName,1) + call LCMPUT(dIp,'value',1,2,side) + call LCMSIX(dIp,triName,2) + end do + !remplissage + dIp = dicoIp + triName = ' ' + lignNbr = 0 + do k = 1,szLc + !tavail sur la kieme cellule + call LCMNXT(lcIp,triName) + triIp=LCMGID(lcIp,triName) + call LCMGET(triIp,'STATE-VECTOR',sv) + call LCMLEN(triIp,'MIX ',lenMix,ty) + if ((lenMix==1).or.(sv(9)==0)) cycle !pas d'info a retirer + allocate(mix(lenMix),cell(sv(9))) + call LCMGET(triIp,'MIX ',mix) + !on teste si tous les milieux sont bien negatifs + do i = 1,lenMix + if (mix(i)<0) cycle + call XABORT("G2S: error, meltig MIX and CELL not supported") + end do + call LCMGTC(triIp,'CELL ',12,sv(9),cell) + !on traite les donnees + !dans le triangle considere + call LCMSIX(dIp,triName,1) + value = 1.*sv(3) + do i = 1,lenMix + call LCMPUT(dIp,cell(-mix(i)),1,2,value) + end do + call LCMSIX(dIp,triName,2) + !dans les autres + value = 1./sv(3) + do i = 1,sv(9) + call LCMSIX(dIp,cell(i),1) + do j = 1,sv(9) + if (j==i) cycle + call LCMPUT(dIp,cell(j),1,2,1.) + end do + call LCMPUT(dIp,triName,1,2,value) + call LCMSIX(dIp,cell(i),2) + end do + deallocate(mix,cell) + end do + end subroutine creeStructure + + subroutine resoudStructure(dicoIp,resIp) + type(c_ptr),intent(in) :: dicoIp,resIp + + type(c_ptr) :: dIp + logical :: fini,flag1,flag2 + integer :: long,typ + character*12 :: triName,saveTriName + character*131:: hsmg + real :: val + + fini = .false. + flag1 = .true. + do + if (fini) exit + fini = .true. + flag2 = flag1 !garde la valeur de flag1 a l'essai precedent + flag1 = .false. + triName = ' ' + call LCMNXT(dicoIp,triName) + saveTriName = triName + do !boucle sur toutes les donnees du dico + fini = fini .and. evaluateLine(dicoIp,triName) + !test si fini a ete vrai au moins une fois + if (fini) flag1 = .true. + call LCMNXT(dicoIp,triName) + if (triName == saveTriName) exit + end do + if (.not.(flag1 .or. flag2)) then + !il ne s'est rien passe au cours des 2 tentatives + !precedentes => on abandonne + call XABORT("G2S: not enought data in the geometry(2)") + end if + end do + !recopie des resultats + dIp = dicoIp + triName = ' ' + call LCMNXT(dIp,triName) + saveTriName = triName + do + call LCMSIX(dIp,triName,1) + call LCMLEN(dIp,'value',long,typ) + if(long == 0) then + write(hsmg,'(36hG2S: value key missing for triName=,a,5h (3).)') trim(triName) + call LCMLIB(dIp) + call LCMLIB(dicoIp) + call XABORT(hsmg) + endif + call LCMGET(dIp,'value',val) + call LCMPUT(resIp,triName,1,2,val) + call LCMSIX(dIp,triName,2) + call LCMNXT(dIp,triName) + if (triName == saveTriName) exit + end do + end subroutine resoudStructure + + function evaluateLine(dicoIp,triName) + type(c_ptr),intent(in) :: dicoIp + character*12,intent(in) :: triName + logical :: evaluateLine + + type(c_ptr) :: triIp + integer :: long,typ + character*12 :: eqName,saveEqName + character*131:: hsmg + real :: factor,val,res + + evaluateLine = .true. + triIp = dicoIp + call LCMSIX(triIp,triName,1) + eqName = ' ' + call LCMNXT(triIp,eqName) + saveEqName = eqName + do !boucle sur toutes les equations de triName + if (eqName=='value') then + call LCMNXT(triIp,eqName) + if (eqName==saveEqName) exit + end if + call getValueOf(eqName,dicoIp,val) + if (val<0.) then + evaluateLine = .false. + else + call LCMGET(triIp,eqName,factor) + res = val * factor + call LCMLEN(triIp,'value',long,typ) + if(long == 0) then + write(hsmg,'(36hG2S: value key missing for eqName=,a,5h (4).)') trim(eqName) + call LCMLIB(triIp) + call LCMLIB(dicoIp) + call XABORT(hsmg) + endif + call LCMGET(triIp,'value',val) + if (val<0.) then + call LCMPUT(triIp,'value',1,2,res) + else if (abs(val-res)>geomPrec) then + call XABORT("G2S: error, incoherent geometry(3)") + end if + end if + call LCMNXT(triIp,eqName) + if (eqName==saveEqName) exit + end do + end function evaluateLine + + subroutine prepareCentresTri(lCentreIp,lcIp,szLc,sidesIp) + type(c_ptr),intent(in) :: lCentreIp,lcIp,sidesIp + integer,intent(in) :: szLc + + character*12 :: triName + type(c_ptr) :: triIp + integer :: i,j,k,lenMix,ind,iTri,lg,ty + real :: dsidex,dsidey,xi,yj + integer,dimension(40) :: sv + real,dimension(:),allocatable :: xx,yy + integer,dimension(:),allocatable :: mix,turn,merg + character*12,dimension(:),allocatable :: cell + + triName = ' ' + do k = 1,szLc + !tavail sur la kieme cellule + call LCMNXT(lcIp,triName) + triIp=LCMGID(lcIp,triName) + call LCMGET(triIp,'STATE-VECTOR',sv) + call LCMLEN(triIp,'MIX ',lenMix,ty) + if ((lenMix==1).or.(sv(9)==0)) cycle !pas d'info a retirer + allocate(mix(lenMix),turn(lenMix),merg(lenMix), & + xx(lenMix),yy(lenMix),cell(sv(9))) + call LCMGET(triIp,'MIX ',mix) + call LCMGET(triIp,'TURN ',turn) + call LCMLEN(triIp,'MERGE ',lg,ty) + if (lg/=0) then + call LCMGET(triIp,'MERGE ',merg) + else + merg = (/(i,i=1,lenMix)/) + end if + call LCMGTC(triIp,'CELL ',12,sv(9),cell) + call LCMGET(sidesIp,cell(1),dsidex) + dsidex = 0.5*dsidex + dsidey = sqrt_3f*dsidex + iTri = T_ST60 + if (triName=='root') call LCMGET(triIp,'ITRI ',iTri) + select case(iTri) + case(T_ST60) !triangle normal ou 'root en ST60' + ind = 0 + yj = (1-sv(4))*0.5*dsidey + do j = 1,sv(4) + xi = (j-sv(3))*dsidex + do i = 1,2*(sv(3)-j)+1 + ind = ind + 1 + xx(ind) = xi + yy(ind) = yj + xi = xi + dsidex + end do + yj = yj + dsidey + end do + case(T_S30) + ind = 0 + yj = 0.5*dsidey + do j = 1,sv(4) + xi = (3*j-2)*dsidex + do i = 1,sv(3)-3*(j-1) + ind = ind + 1 + xx(ind) = xi + yy(ind) = yj + xi = xi + dsidex + end do + yj = yj + dsidey + end do + case(T_SA60) + ind = 0 + yj = -(2*sv(4)-1)*0.5*dsidey + do j = 1,sv(4) + xi = (3*(sv(4)-j)+1)*dsidex + do i = 1,3*j-2+mod(sv(3)-1,3) + ind = ind + 1 + xx(ind) = xi + yy(ind) = yj + xi = xi + dsidex + end do + yj = yj + dsidey + end do + yj = 0.5*dsidey + do j = 1,sv(4) + xi = (3*j-2)*dsidex + do i = 1,sv(3)-3*(j-1) + ind = ind + 1 + xx(ind) = xi + yy(ind) = yj + xi = xi + dsidex + end do + yj = yj + dsidey + end do + case(T_Complete) + ind = 0 + yj = (1-sv(4))*0.5*dsidey + do j = 1,sv(4) + xi = (j-sv(3))*dsidex + do i = 1,2*sv(3) + ind = ind + 1 + xx(ind) = xi + yy(ind) = yj + xi = xi + dsidex + end do + yj = yj + dsidey + end do + end select + do i = 1,lenMix + call addInRes(lCentreIp,cell(-mix(i)),triName,xx(i), & + yy(i),turn(i),i,merg(i)) + end do + deallocate(mix,turn,merg,xx,yy,cell) + end do + end subroutine prepareCentresTri + + subroutine compileResutatsTri(geoIp,lcIp,szLc,centreCalculesIp,sidesIp) + type(c_ptr),intent(in) :: geoIp,lcIp,centreCalculesIp,sidesIp + integer,intent(in) :: szLc + + type(c_ptr) :: lMinMaxIp,sidexyIp + integer :: i,iTri + character*12 :: cellName + real :: val + integer,dimension(40) :: sv + + call LCMOP(lMinMaxIp,'minAndMaxXY ',0,1,0) + call LCMPUT(lMinMaxIp,'minX ',1,2,0.) + call LCMPUT(lMinMaxIp,'maxX ',1,2,0.) + call LCMPUT(lMinMaxIp,'minY ',1,2,0.) + call LCMPUT(lMinMaxIp,'maxY ',1,2,0.) + + call LCMOP(sidexyIp,'sidesXY ',0,1,0) + cellName = ' ' + do i = 1,szLc + call LCMNXT(lcIp,cellName) + call LCMGET(sidesIp,cellName,val) + call LCMPUT(sidexyIp,'x'//cellName(1:11),1,2,val) + call LCMPUT(sidexyIp,'y'//cellName(1:11),1,2,val) + if (cellName=='root') then !modification de xroot et yroot si besoin + call LCMGET(geoIp,'STATE-VECTOR',sv) + call LCMGET(geoIp,'ITRI ',iTri) + select case(iTri) + case(T_Complete) + val=val*sv(4)/real(sv(3)) + call LCMPUT(sidexyIp,'y'//cellName(1:11),1,2,val) + case(T_S30,T_SA60) + val=val/real(sv(3)) + call LCMPUT(sidexyIp,'x'//cellName(1:11),1,2,val) + val=val*int((sv(3)+1)/2) + call LCMPUT(sidexyIp,'y'//cellName(1:11),1,2,val) + end select + end if + end do + + call compileResutats(geoIp,centreCalculesIp,sidexyIp,lMinMaxIp) + + call LCMCL(lMinMaxIp,2) + call LCMCL(sidexyIp,2) + end subroutine compileResutatsTri + +end module pretraitement diff --git a/Dragon/src/g2s_segArc.f90 b/Dragon/src/g2s_segArc.f90 new file mode 100644 index 0000000..f323f6a --- /dev/null +++ b/Dragon/src/g2s_segArc.f90 @@ -0,0 +1,2310 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Collect processing functions related to geometric elements. +! +!Copyright: +! Copyright (C) 2001 Ecole Polytechnique de Montreal. +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): +! G. Civario (CS-SI) +! +!Comments: +! Une structure "t_segArc" est definie, avec tous les champs necessaires aux +! calculs. On stocke par ailleurs ces elements dans un tableau global de +! pointeurs "tabSegArc". +! \\\\ +! variable globale: +! - tabSegArc : le tableau de travail principal +! \\\\ +! fonctions du module: +! - initializeTabSegArc : mise a zero des tableaux +! - destroyTabSegArc : liberation de la memoire +! - createSeg : constructeur de segment +! - createArc : constructeur de cercle ou d'arc de cercle +! - giveOrigine : retourne les coordonnees de l'origine d'un segArc +! - giveExtremite : retourne les coordonnees de l'extremite d'un segArc +! - extremitesArc : determination des points extremites d'un arc +! - estColieaire : test de la colinearite de 2 segments +! - isAngleInArc : teste l'appartenance d'un angle au domaine d'un arc +! - isIn : teste l'appartenance d'un point, sur le support d'un segment ou +! d'un arc, au segment ou a l'arc +! - isSameWay : teste si deux segments alignes ont meme orientation +! - turnBackSide : retourne le segment donne en entree +! - adjustMix : ajuste les milieux a droite et a gauche d'un segment, par +! rapport a ceux d'un segment de reference le contenant +! - interSgAr : calcule les points d'intersection entre un segment et un arc +! - interSgSg : calcule les points d'intersection entre deux segments +! - interSgSg_V2 : recherche les points d'itersection entre deux segments +! (extremites inclues) +! - interArcArc : calcule les points d'intersection entre deux arcs +! - translateAndTurnTriSg : effectue une translation-rotation d'un cote +! de triangle (fonction tres specifique) +! - giveExtremalsAngles : donne les angles d'incidence des extrmites d'un +! element, par rapport a un point +! - drawSegArc : affiche le tableau des elements dans un fichier postscript +! - coupeCercle : intersecte les couronnes et les clusters +! - splitSegsForSect : coupe l'encadrement d'une cellule rectangulaire en cas +! de sectorisation +! - majSectori : met a jour la donnee sur le secteur des elements +! - addSegsAndClean : ajout de nouveaux segments lors de la mise cote a cote +! des differentes cellules, et elimination des doublons +! - cutClusters : prise en compte des intersections couronnes/cluster, et +! elimination de elements internes aux clusters +! - segWithSameCoord : true if the transmitted segments have the same coordinates +! +!----------------------------------------------------------------------- +! +module segArc + use constUtiles + use constType + use derivedPSPLOT + + implicit none + + interface printSegArc + module procedure printSegArc1, printSegArc2 + end interface printSegArc + + type t_segArc + integer :: typ !1=segment, 2=arc de cercle + double precision :: x,y !origine si 1 , centre si 2 + double precision :: dx,dy !extremite si 1 + double precision :: r !rayon si 2 + double precision :: a,b !angle debut et fin si 2 (entre -pi et pi) + integer :: mixg =0!numero de couronne a gauche ou interieur + integer :: mixd =0!numero de couronne a droite ou exterieur + integer :: nodeg =0!node a gauche ou interieur + integer :: noded =0!node a droite ou exterieur + integer :: indCellPg=0 !cellulePlaced d'origine a gauche + integer :: indCellPd=0 !cellulePlaced d'origine a droite + integer :: sectg=0 !numero du secteur a gauche dans la cellule + integer :: sectd=0 !numero du secteur a droite dans la cellule + integer :: neutronicMixg=0 !milieux neutronique a gauche + integer :: neutronicMixd=0 !milieux neutronique a droite + logical :: clusg=.false. ! circle belong to a cluster + logical :: clusd=.false. ! circle belong to a cluster + end type t_segArc + + integer,parameter :: tseg=1 , tcer=2 , tarc=3 , fooMix=-99 , fooNode=-999 , & + & tRec=1 , tHex=2 , tTri=3 + + !type of geometry + integer :: typgeo + + !variable globale de type tableau d'elements geometriques + type(t_segArc), dimension(:), pointer :: tabSegArc + + ! storage of cutting straights and segments + type(t_segArc), dimension(:), allocatable :: tabStrCut,tabSegCut + + type segArcArrayBis + type(t_segArc) :: sa + logical :: keep + end type segArcArrayBis + + type segArcArrayTer + type(t_segArc) :: sa + logical :: keep + logical :: cl !condition limite ou cluster selon les cas + end type segArcArrayTer + + ! Programmation defensive + integer :: alloc_ok + +contains + + function createSeg(ox,oy,ex,ey,mg,md) + double precision,intent(in) :: ox,oy,ex,ey + integer,intent(in) :: mg,md + type(t_segArc) :: createSeg + + createSeg%typ = tseg + createSeg%x = ox ; createSeg%y = oy + createSeg%dx = ex ; createSeg%dy = ey + createSeg%r = 0.d0 + createSeg%a = 0.d0 ; createSeg%b = 0.d0 + createSeg%mixg = mg ; createSeg%mixd = md + createSeg%nodeg = fooNode ; createSeg%noded = fooNode + createSeg%indCellPg = 0 ; createSeg%indCellPd = 0 + createSeg%sectg = 0 ; createSeg%sectd = 0 + createSeg%neutronicMixg = 0 ; createSeg%neutronicMixd = 0 + createSeg%clusg = .false. ; createSeg%clusd = .false. + end function createSeg + + function copySegExceptOrigin(ox,oy,Seg) + double precision,intent(in) :: ox,oy + type(t_segArc),intent(in) :: Seg + type(t_segArc) :: copySegExceptOrigin + if (Seg%typ /= tseg) call XABORT("copySegExceptOrigin : inconsistency") + copySegExceptOrigin = Seg + copySegExceptOrigin%x = ox ; copySegExceptOrigin%y = oy + end function copySegExceptOrigin + + function copySegExceptEnd(ex,ey,Seg) + double precision,intent(in) :: ex,ey + type(t_segArc),intent(in) :: Seg + type(t_segArc) :: copySegExceptEnd + if (Seg%typ /= tseg) call XABORT("copySegExceptEnd : inconsistency") + copySegExceptEnd = Seg + copySegExceptEnd%dx = ex ; copySegExceptEnd%dy = ey + end function copySegExceptEnd + + function copySegWithNewExtrems(ox,oy,ex,ey,seg) + double precision, intent(in) :: ox, oy, ex, ey + type(t_segArc),intent(in) :: Seg + type(t_segArc) :: copySegWithNewExtrems + if (Seg%typ /= tseg) call XABORT("copySegWithNewExtrems: inconsistency") + copySegWithNewExtrems = Seg + copySegWithNewExtrems%x = ox ; copySegWithNewExtrems%y = oy + copySegWithNewExtrems%dx = ex ; copySegWithNewExtrems%dy = ey + end function copySegWithNewExtrems + + function copyUTurnSeg(seg) + type(t_segArc), intent(in) :: seg + type(t_segArc) :: copyUTurnSeg + if (Seg%typ /= tseg) call XABORT("copyUTurnSeg : inconsistency") + copyUTurnSeg%typ = tseg + copyUTurnSeg%x = seg%dx ; copyUTurnSeg%y = seg%dy + copyUTurnSeg%dx = seg%x ; copyUTurnSeg%dy = seg%y + copyUTurnSeg%r = seg%r ; copyUTurnSeg%a = seg%a ; copyUTurnSeg%b = seg%b + copyUTurnSeg%mixg = seg%mixd ; copyUTurnSeg%mixd = seg%mixg + copyUTurnSeg%nodeg = seg%noded ; copyUTurnSeg%noded = seg%nodeg + copyUTurnSeg%indCellPg = seg%indCellPd ; copyUTurnSeg%indCellPd = seg%indCellPg + copyUTurnSeg%sectg = seg%sectd ; copyUTurnSeg%sectd = seg%sectg + copyUTurnSeg%neutronicMixg = seg%neutronicMixd + copyUTurnSeg%neutronicMixd = seg%neutronicMixg + end function copyUTurnSeg + + function createArc(cx,cy,r,a,b,mi,me) + double precision,intent(in) :: cx,cy,r,a,b + integer,intent(in) :: mi,me + type(t_segArc) :: createArc + + createArc%a = a ; createArc%b = b + if (isEqual(createArc%a,createArc%b)) then ; createArc%typ = tcer + else ; createArc%typ = tarc + end if + createArc%x = cx ; createArc%y = cy + createArc%dx = 0.d0 ; createArc%dy = 0.d0 + createArc%r = r + createArc%mixg = mi ; createArc%mixd = me + createArc%nodeg = fooNode ; createArc%noded = fooNode + createArc%indCellPg = 0 ; createArc%indCellPd = 0 + createArc%sectg = 0 ; createArc%sectd = 0 + createArc%neutronicMixg = 0 ; createArc%neutronicMixd = 0 + end function createArc + + function copyArcExceptOrigin(o,Arc) + double precision,intent(in) :: o + type(t_segArc),intent(in) :: Arc + type(t_segArc) :: copyArcExceptOrigin + if (Arc%typ /= tarc) call XABORT("copyArcExceptOrigin : inconsistency") + copyArcExceptOrigin = Arc + copyArcExceptOrigin%a = o + end function copyArcExceptOrigin + + function copyArcExceptEnd(e,Arc) + double precision,intent(in) :: e + type(t_segArc),intent(in) :: Arc + type(t_segArc) :: copyArcExceptEnd + if (Arc%typ /= tarc) call XABORT("copyArcExceptEnd : inconsistency") + copyArcExceptEnd = Arc + copyArcExceptEnd%b = e + end function copyArcExceptEnd + + function copyArcWithNewAngles(o,e,Arc) + double precision,intent(in) :: o, e + type(t_segArc),intent(in) :: Arc + type(t_segArc) :: copyArcWithNewAngles + if (Arc%typ /= tarc) call XABORT("copyArcWithNewAngles : inconsistency") + copyArcWithNewAngles = Arc + copyArcWithNewAngles%a = o + copyArcWithNewAngles%b = e + end function copyArcWithNewAngles + + function createArcFromCircle(o,e,Circ) + double precision,intent(in) :: o, e + type(t_segArc),intent(in) :: Circ + type(t_segArc) :: createArcFromCircle + if (Circ%typ /= tcer) call XABORT("createArcFromCircle : inconsistency") + createArcFromCircle = Circ + createArcFromCircle%typ = tarc + createArcFromCircle%a = o + createArcFromCircle%b = e + end function createArcFromCircle + + subroutine giveOrigine(sa,xx,yy) + type(t_segArc),intent(in) :: sa + double precision,intent(out) :: xx,yy + select case(sa%typ) + case(tseg) ; xx = sa%x ; yy = sa%y + case(tarc) ; xx = sa%x+sa%r*cos(sa%a) ; yy=sa%y+sa%r*sin(sa%a) + case(tcer) ; xx = sa%x+sa%r ; yy = sa%y + end select + end subroutine giveOrigine + + subroutine giveExtremite(sa,xx,yy) + type(t_segArc),intent(in) :: sa + double precision,intent(out) :: xx,yy + select case(sa%typ) + case(tseg) ; xx = sa%dx ; yy = sa%dy + case(tarc) ; xx = sa%x+sa%r*cos(sa%b) ; yy=sa%y+sa%r*sin(sa%b) + case(tcer) ; xx = sa%x+sa%r ; yy = sa%y + end select + end subroutine giveExtremite + + subroutine giveFourPointsOnCircle(sa,P1,P2,P3,P4) + type(t_segArc), intent(in) :: sa + type(t_point), intent(out) :: P1,P2,P3,P4 + if (sa%typ/=tcer) call XABORT("giveFourPointsOnCircle : bad use") + P1 = t_point(sa%x+sa%r,sa%y) + P2 = t_point(sa%x-sa%r,sa%y) + P3 = t_point(sa%x,sa%y+sa%r) + P4 = t_point(sa%x,sa%y-sa%r) + + end subroutine giveFourPointsOnCircle + + subroutine extremitesArc(ar,pt1x,pt1y,pt2x,pt2y) + type(t_segArc),intent(in) :: ar + double precision,intent(out) :: pt1x,pt1y,pt2x,pt2y + + pt1x=ar%x+ar%r*cos(ar%a) ; pt1y=ar%y+ar%r*sin(ar%a) + pt2x=ar%x+ar%r*cos(ar%b) ; pt2y=ar%y+ar%r*sin(ar%b) + end subroutine extremitesArc + + subroutine MediumPointOnArc(Ar,P) + type(t_segArc), intent(in) :: Ar + type(t_point), intent(out) :: P + double precision :: angle + if (Ar%a < Ar %b) then + angle = angleNormal((Ar%a + Ar%b) * 0.5) + else + angle = angleNormal((Ar%a + Ar%b ) *0.5 + pi_c) + endif + p%x = Ar%x + Ar%r * cos(angle) + p%y = Ar%y + Ar%r * sin(angle) + end subroutine MediumPointOnArc + + function estColineaire(sa1,sa2) + type(t_segArc),intent(in) :: sa1,sa2 + logical :: estColineaire + + if (sa1%typ/=tseg .or. sa2%typ/=tseg) then + estColineaire = .false. + else + estcolineaire = estcoli(sa1%dx-sa1%x,sa1%dy-sa1%y,sa2%dx-sa2%x,sa2%dy-sa2%y) + end if + end function estColineaire + + function isAngleInArc(a,arc) + double precision,intent(in) :: a + type(t_segArc),intent(in) :: arc + integer :: isAngleInArc + double precision :: angl + !dit si un angle est sur l'intervalle d'un arc : 0 -> pas dessus, + ! 1 -> c'est l'origine, 2 -> entre les deux, 3 -> c'est l'extremite + if (arc%typ==tcer) then + isAngleInArc = 2 + return + end if + + angl = angleNormal(a) + if (isEqualConst(arc%a,angl)) then ; isAngleInArc = 1 + else if (isEqualConst(arc%b,angl)) then ; isAngleInArc = 3 + else if (arc%a pas dessus, + ! 1 -> c'est l'origine, 2 -> entre les deux, 3 -> c'est l'extremite + !ATTENTION :le point doit etre deja sur la droite ou le cercle d'appui + if (sa%typ==tseg) then + if (isEqualConst(sa%x,ptx) .and. isEqualConst(sa%y,pty)) then + isIn = 1 + else if (isEqualConst(sa%dx,ptx) .and. isEqualConst(sa%dy,pty)) then + isIn = 3 + else if (((sa%x-ptx)*(sa%dx-ptx)+(sa%y-pty)*(sa%dy-pty))<0) then + isIn = 2 + else + isIn = 0 + end if + else + angl = calculeAngle(sa%x,sa%y,ptx,pty) + isIn = isAngleInArc(angl,sa) + end if + end function isIn + + function isIn_V2(ptx,pty,sa) + double precision,intent(in) :: ptx,pty + type(t_segArc),intent(in) :: sa + integer :: isIn_V2 + + double precision :: angl, tmp + + !dit si un point est sur un segment ou un arc : 0 -> pas dessus, + ! 1 -> c'est l'origine, 2 -> entre les deux, 3 -> c'est l'extremite + !ATTENTION :le point doit etre deja sur la droite ou le cercle d'appui + if (sa%typ==tseg) then + if (isEqualConst(sa%x,ptx) .and. isEqualConst(sa%y,pty)) then + isIn_V2 = 1 + else if (isEqualConst(sa%dx,ptx) .and. isEqualConst(sa%dy,pty)) then + isIn_V2 = 3 + else + tmp = (sa%x-ptx)*(sa%dx-ptx)+(sa%y-pty)*(sa%dy-pty) + if (tmp < dp_0) then + isIn_V2 = 2 + else if (isEqualConst(tmp,dp_0)) then + isIn_V2 = 4 + else + isIn_V2 = 0 + end if + end if + elseif (sa%typ == tarc) then + angl = calculeAngle(sa%x,sa%y,ptx,pty) + isIn_V2 = isAngleInArc(angl,sa) + else + tmp = sqrt((sa%x-ptx)*(sa%x-ptx)+(sa%y-pty)*(sa%y-pty)) + if (isEqualConst(tmp,sa%r)) then + isIn_V2 = 2 + else + isIn_V2 = 0 + endif + end if + end function isIn_V2 + + function isSameWay(sg1,sg2) + type(t_segArc),intent(in) :: sg1,sg2 + logical :: isSameWay + !dit si 2 segments alignes ont meme orientation + + isSameWay=(((sg1%dx-sg1%x)*(sg2%dx-sg2%x)+(sg1%dy-sg1%y)*(sg2%dy-sg2%y))>0) + end function isSameWay + + subroutine AddSA(SA,szSA) + type(t_segArc), intent(in) :: SA + integer, intent(inout) :: szSA + if (szSA == size(tabSegArc)) call XABORT("AddSA : memory problem") + szSA = szSA + 1 + tabSegArc(szSA) = SA + end subroutine AddSA + + subroutine Add2SA(SA1,SA2,szSA) + type(t_segArc), intent(in) :: SA1,SA2 + integer, intent(inout) :: szSA + if (szSA == size(tabSegArc)) call XABORT("Add2SA : memory problem") + szSA = szSA + 2 + tabSegArc(szSA-1) = SA1 + tabSegArc(szSA) = SA2 + end subroutine Add2SA + + function ReplaceSA(newSA,iSA) + type(t_segArc), intent(in) :: newSA + integer, intent(in) :: iSA + type(t_segArc) :: ReplaceSA + ReplaceSA = newSA + tabSegArc(iSA) = newSA + end function ReplaceSA + + subroutine SlideSA(iSA,szSA) + integer, intent(in) :: iSA + integer, intent(inout) :: szSA + tabSegArc(iSA:szSA-1) = tabSegArc(iSA+1:szSA) + szSA = szSA - 1 + end subroutine SlideSA + + subroutine AddSC(SC,szSC) + type(t_segArc), intent(in) :: SC + integer, intent(inout) :: szSC + if (szSC == size(tabSegCut)) then + write(6,*) szSC,size(tabSegCut) + call XABORT("AddSC : memory problem") + endif + szSC = szSC + 1 + tabSegCut(szSC) = SC + end subroutine AddSC + + subroutine Add2SC(SC1,sC2,szSC) + type(t_segArc), intent(in) :: SC1,SC2 + integer, intent(inout) :: szSC + if (szSC == size(tabSegCut)) call XABORT("Add2SC : memory problem") + szSC = szSC + 2 + tabSegCut(szSC-1) = SC1 + tabSegCut(szSC) = SC2 + end subroutine Add2SC + + function ReplaceSC(newSC,iSC) + type(t_segArc), intent(in) :: newSC + integer, intent(in) :: iSC + type(t_segArc) :: ReplaceSC + ReplaceSC = newSC + tabSegCut(iSC) = newSC + end function ReplaceSC + + subroutine OverlaidSegmentsManagement(n1, n2, iSC, szSC, SC, iSA, szSA, SA) + integer, intent(in) :: n1, n2 + integer, intent(inout) :: iSC, szSC, iSA, szSA + type(t_SegArc), intent(inout) :: SC, SA + type(t_segArc) :: SC1, SC2, SC3, SA1, SA2 + select case(n1) + case(11) ! SC and SA have same origin + select case(n2) + case(23) + SA1 = CopySegExceptOrigin(SC%dx,SC%dy,SA) + SA = ReplaceSA(SA1,iSA) + iSA = iSA + 1 + case(32) ! end of SA internal to SC + SC1 = CopySegExceptOrigin(SA%dx,SA%dy,SC) + SC2 = CopySegExceptEnd(SA%dx,SA%dy,SC) + call AddSC(SC1,szSC) + SC = ReplaceSC(SC2,iSC) + call SlideSA(iSA,szSA) + case(33) ! SC and SA have same end + call SlideSA(iSA,szSA) + case default + call XABORT("OverlaidSegmentsManagement : impossible circumstance") + end select + case(12) ! the origin of SC is internal to SA + select case (n2) + case(21) + SC1 = CopySegExceptEnd(SA%x,SA%y,SC) + SC2 = CopySegExceptOrigin(SA%x,SA%y,SC) + SA1 = CopySegExceptOrigin(SC%x,SC%y,SA) + SC = ReplaceSC(SC1,iSC) + SA = ReplaceSA(SA1,iSA) + call AddSC(SC2,szSC) + iSA = iSA + 1 + case(23) + SC1 = CopySegExceptEnd(SA%x,SA%y,SC) + SC2 = CopySegExceptOrigin(SA%x,SA%y,SC) + SC3 = CopySegWithNewExtrems(SA%x,SA%y,SA%dx,SA%dy,SC) + SA1 = CopySegExceptOrigin(SC%dx,SC%dy,SA) + SC = ReplaceSC(SC3,iSC) + SA = ReplaceSA(SA1,iSA) + call AddSC(SC2,szSC) + iSa = iSA + 1 + case(31) + SC1 = CopySegExceptOrigin(SA%x,SA%y,SC) + SC2 = CopySegWithNewExtrems(SA%dx,SA%dy,SA%x,SA%y,SC) + SC = ReplaceSC(SC2,iSC) + call AddSC(SC1,szSC) + call SlideSA(iSA,szSA) + case(32) + if (isSameWay(SC,SA)) then + SC1 = CopySegExceptEnd(SA%x,SA%y,SC) + SC2 = CopySegExceptOrigin(SA%dx,SA%dy,SC) + SC3 = CopySegWithNewExtrems(SA%x,SA%y,SA%dx,SA%dy,SC) + SC = ReplaceSC(SC3,iSC) + else + SC1 = CopySegExceptEnd(SA%dx,SA%dy,SC) + SC2 = CopySegExceptOrigin(SA%x,SA%y,SC) + SC3 = CopySegWithNewExtrems(SA%dx,SA%dy,SA%x,SA%y,SC) + SC = ReplaceSC(SC3,iSC) + endif + call Add2SC(SC1,SC2,szSC) + call SlideSA(iSA,szSA) + case(33) + SC1 = CopySegExceptEnd(SA%x,SA%y,SC) + SC2 = CopySegWithNewExtrems(SA%x,SA%y,SA%dx,SA%dy,SC) + SC = ReplaceSC(SC2,iSC) + call AddSC(SC1,szSC) + call SlideSA(iSA,szSA) + case default + call XABORT("OverlaidSegmentsManagement : impossible circumstance") + end select + case(13) ! the origin of SC is the end of SA + select case(n2) + case(21) + SA1 = CopySegExceptOrigin(SC%x,SC%y,SA) + call AddSA(SA1,szSA) + iSA = iSA + 1 + case(31) + SC1 = CopySegWithNewExtrems(SA%dx,SA%dy,SA%x,SA%y,SC) + SC = ReplaceSC(SC1,iSC) + call SlideSA(iSA,szSA) + case(32) + SC1 = CopySegExceptEnd(SA%dx,SA%dy,SC) + SC2 = CopySegExceptOrigin(SA%dx,SA%dx,SC) + SC = ReplaceSC(SC2,iSC) + call AddSC(SC1,szSC) + call SlideSA(iSa,szSA) + case default + write(6,*) "Pb n1,n2",n1,N2 + call XABORT("OverlaidSegmentsManagement : impossible circumstance") + end select + case(21) + select case(n2) + case(12) + SC1 = CopySegExceptEnd(SA%x,SA%y,SC) + SC2 = CopySegExceptOrigin(SA%x,SA%y,SC) + SA1 = CopySegExceptOrigin(SC%x,SC%y,SA) + SC = ReplaceSC(SC1,iSC) + call AddSC(SC2,szSC) + SA = ReplaceSA(SA1,iSA) + iSA = iSA + 1 + case(13) + SA1 = CopySegExceptOrigin(SC%x,SC%y,SC) + SA = ReplaceSA(SA1,iSA) + iSA = iSA + 1 + case(23) + if (isSameWay(SC,SA)) then + SA1 = CopySegExceptEnd(SC%x,SC%y,SA) + SA2 = CopySegExceptOrigin(SC%dx,SC%dy,SA) + else + SA1 = CopySegExceptEnd(SC%Dx,SC%Dy,SA) + SA2 = CopySegExceptOrigin(SC%x,SC%y,SA) + endif + SA = ReplaceSA(SA1,iSA) + call AddSC(SC2,szSC) + iSA = iSA + 1 + case(32) + SC1 = CopySegExceptEnd(SA%dx,SA%dy,SC) + SC2 = CopySegExceptOrigin(SA%dx,SA%dy,SC) + SA1 = CopySegExceptEnd(SC%x,SC%y,SA) + SC = ReplaceSC(SC1,iSC) + call AddSC(SC2,szSC) + SA = ReplaceSA(SA1,iSA) + iSA = iSA + 1 + case(33) + SA1 = CopySegExceptEnd(SC%x,SC%y,SC) + SA = ReplaceSA(SA1,iSA) + iSA = iSA + 1 + case default + write(6,*) "Pb n1,n2",n1,N2 + call XABORT("OverlaidSegmentsManagement : impossible circumstance") + end select + case(23) + select case (n2) + case(11) + SA1 = CopySegExceptOrigin(SC%dx,SC%dy,SA) + SA = ReplaceSA(SA1,iSA) + iSA = iSA + 1 + case(12) + SC1 = CopySegExceptEnd(SA%x,SA%y,SC) + SC2 = CopySegExceptOrigin(SA%x,SA%y,SC) + SC = ReplaceSC(SC1,iSC) + call AddSC(SC2,szSC) + SA1 = CopySegExceptOrigin(SC%dx,SC%dy,SA) + SA = ReplaceSA(SA1,iSA) + iSA = iSA + 1 + case(21) + if (isSameWay(SC,SA)) then + SA1 = CopySegExceptEnd(SC%x,SC%y,SA) + SA2 = CopySegExceptOrigin(SC%dx,SC%dy,SA) + else + SA1 = CopySegExceptEnd(SC%dx,SC%dy,SA) + SA2 = CopySegExceptOrigin(SC%x,SC%y,SA) + endif + SA = ReplaceSA(SA1,iSA) + call AddSA(SA2,szSA) + iSA = iSA + 1 + case(31) + SA1 = CopySegExceptEnd(SC%dx,SC%dy,SA) + SA = ReplaceSA(SA1,iSA) + iSA = iSA + 1 + case(32) + SC1 = CopySegExceptEnd(SA%dx,SA%dy,SC) + SC2 = CopySegExceptOrigin(SA%dx,SA%dy,SC) + SA1 = CopySegExceptEnd(SC%dx,SC%dy,SA) + SC = ReplaceSC(SC1,iSC) + SA = ReplaceSA(SA1,iSA) + call AddSC(SC2,szSC) + iSA = iSA + 1 + case default + write(6,*) "Pb n1,n2",n1,N2 + call XABORT("OverlaidSegmentsManagement : impossible circumstance") + end select + case(31) + select case (n2) + case(12) + SC1 = CopySegExceptEnd(SA%x,SA%y,SC) + SC2 = CopySegExceptOrigin(SA%x,SA%y,SC) + SC = ReplaceSC(SC1,iSC) + call AddSc(SC2,szSC) + call SlideSA(iSA,szSA) + case(13) + SC1 = CopySegWithNewExtrems(SA%dx,SA%dy,SA%x,SA%y,SC) + SC = ReplaceSC(SC1,iSC) + call SlideSA(iSA,szSA) + case(23) + SA1 = CopySegExceptEnd(SC%dx,SC%dy,SA) + SA = ReplaceSA(SA1,iSA) + iSA = iSA + 1 + case default + write(6,*) "Pb n1,n2",n1,N2 + call XABORT("OverlaidSegmentsManagement : impossible circumstance") + end select + case(32) + select case (n2) + case(11) + SC1 = CopySegExceptEnd(SA%dx,SA%dy,SC) + SC2 = CopySegExceptOrigin(SA%dx,SA%dy,SC) + SC = ReplaceSC(SC1,iSC) + call AddSC(SC2,szSC) + iSA = iSA + 1 + case(12) + if (isSameWay(SA,SC)) then + SC1 = CopySegExceptEnd(SA%x,SA%y,SC) + SC2 = CopySegExceptOrigin(SA%dx,SA%dy,SC) + SC3 = CopySegWithNewExtrems(SA%x,SA%y,SA%dx,SA%dy,SC) + SC = ReplaceSC(SC3,iSC) + else + SC1 = CopySegExceptEnd(SA%dx,SA%dy,SC) + SC2 = CopySegExceptOrigin(SA%x,SA%y,SC) + SC3 = CopySegWithNewExtrems(SA%dx,SA%dy,SA%x,SA%y,SC) + SC = ReplaceSC(SC3,iSC) + end if + call Add2SC(SC1,SC2,szSC) + call SlideSA(iSA,szSA) + case(13) + SC1 = CopySegExceptEnd(SA%dx,SA%dy,SC) + SC2 = CopySegExceptOrigin(SA%dx,SA%dy,SC) + SC = ReplaceSC(SC1,iSC) + call AddSC(SC2,szSC) + call SlideSA(iSA,szSA) + case(21) + SC1 = CopySegExceptEnd(SA%dx,SA%dy,SC) + SC2 = CopySegExceptOrigin(SA%dx,SA%dy,SC) + SA1 = CopySegExceptOrigin(SC%x,SC%y,SA) + SC = ReplaceSC(SC1,iSC) + SA = ReplaceSA(SA1,iSA) + call AddSC(SC2,szSC) + iSA = iSA + 1 + case(23) + SC1 = CopySegExceptEnd(SA%dx,SA%dy,SC) + SC2 = CopySegExceptOrigin(SA%dx,SA%dy,SC) + SA1 = CopySegExceptOrigin(SC%dx,SC%dy,SA) + SC = ReplaceSC(SC1,iSC) + SA = ReplaceSA(SA1,iSA) + call AddSC(SC2,szSC) + iSA = iSA + 1 + case default + write(6,*) "Pb n1,n2",n1,N2 + call XABORT("OverlaidSegmentsManagement : impossible circumstance") + end select + case(33) + select case (n2) + case(11) + SC1 = CopySegWithNewExtrems(SA%x,SA%y,SA%dx,SA%dy,SC) + SC = ReplaceSC(SC1,iSC) + call SlideSA(iSA,szSA) + case(12) + SC1 = CopySegExceptEnd(SA%x,SA%y,SC) + SC2 = CopySegWithNewExtrems(SA%x,SA%y,SA%dx,SA%dy,SC) + SC = ReplaceSC(SC2,iSC) + call AddSC(SC1,szSC) + call SlideSA(iSA,szSA) + case(21) + SA1 = CopySegExceptEnd(SC%x,SC%y,SA) + SA = ReplaceSA(SA1,iSA) + iSA = iSA + 1 + case default + write(6,*) "Pb n1,n2",n1,N2 + call XABORT("OverlaidSegmentsManagement : impossible circumstance") + end select + case default + write(6,*) "Pb n1,n2",n1,N2 + call XABORT("OverlaidSegmentsManaement : ??") + end select + end subroutine OverlaidSegmentsManagement + + function turnBackSide(sg) + type(t_segArc),intent(inout) :: sg + type(t_segArc) :: turnBackSide + !tourne le sens du segment en entree + + turnBackSide=createSeg(sg%dx,sg%dy,sg%x,sg%y,sg%mixd,sg%mixg) + turnBackSide%nodeg=sg%noded + turnBackSide%noded=sg%nodeg + turnBackSide%indCellPg=sg%indCellPd + turnBackSide%indCellPd=sg%indCellPg + turnBackSide%sectg=sg%sectd + turnBackSide%sectd=sg%sectg + turnBackSide%neutronicMixg=sg%neutronicMixd + turnBackSide%neutronicMixd=sg%neutronicMixg + sg=turnBackSide + end function turnBackSide + + subroutine adjustMix(sgToAdjust,sgOfRef) + type(t_segArc),intent(inout) :: sgToAdjust + type(t_segArc),intent(in) :: sgOfRef + !ajuste les milieux a droite et a gauche de sgToAdjust + !par rapport a ceux de sgOfRef (sgToAdjust doit etre inclus dans sgOfRef) + if (sgOfRef%mixg/=fooMix) then + sgToAdjust%mixg = sgOfRef%mixg + sgToAdjust%indCellPg = sgOfRef%indCellPg + sgToAdjust%sectg = sgOfRef%sectg + sgToAdjust%neutronicMixg = sgOfRef%neutronicMixg + end if + if (sgOfRef%mixd/=fooMix) then + sgToAdjust%mixd = sgOfRef%mixd + sgToAdjust%indCellPd = sgOfRef%indCellPd + sgToAdjust%sectd = sgOfRef%sectd + sgToAdjust%neutronicMixd = sgOfRef%neutronicMixd + end if + end subroutine adjustMix + + logical function interSgAr_V2(sg,ar, n1, n2, P1, P2) + ! Return true only if there is at least an intersection between sg and ar. + ! If there is an point of intersection or an tangency point, P1 is this point. + ! If there are two intersection points, P1 and P2 are these points. + ! N1 and n2 let us pinpoint the point of intersection on both segment and arc. + ! If there is no point of intersection, the values for n1 and n2 are 0. + type(t_segArc),intent(in) :: sg,ar + integer, intent(out):: n1, n2 + type (t_point), intent(out) :: P1, P2 + + double precision :: sox, soy, sfx, sfy, cx, cy, ray, aox, aoy + double precision :: prjx, prjy, d, u, v, norm, tmp, Ix, Iy, Jx, Jy + integer :: IinS,IinA,JinS,JinA + + ! Initialization + n1 = 0 ; n2 = 0 + P1 = t_point(dp_0,dp_0) ; P2 = t_point(dp_0,dp_0) + InterSgAr_V2 = .false. + ! Coordinates + sox = sg%x ; sfx = sg%dx ; soy = sg%y ; sfy = sg%dy + cx = ar%x ; cy = ar%y ; ray = ar%r + + ! Special case : ar is a point + if ((ar%typ == tarc.and.isEqualConst(angleNormal(ar%a),angleNormal(ar%b)))) then + call giveOrigine(ar,aox,aoy) + if (isIn(aox,aoy,sg) /= 0) then + interSgAr_V2 =.true. ; n1 = isIn(aox,aoy,sg)+10 + P1 = t_point(aox,aoy) + endif + goto 10 + endif + ! Special case : sg is a point + if (isEqualConst(sox,sfx).and.isEqualConst(soy,sfy)) then + d = sqrt((sox-cx)*(sox-cx) + (soy-cy)*(soy-cy)) + if (isEqualConst(d,ray)) then + interSgAr_V2 =.true. ; n1 = 1+isIn(sox,soy,ar)*10 + P1 = t_point(sox,soy) + endif + goto 10 + endif + ! Distance Segment-Arc + d = distance(cx,cy,sox,soy,sfx,sfy,prjx,prjy) + ! Distance analysis + if (.not. isEqualConst(d,ar%r)) then + if (d < ray) then + ! no one, one or two distinct intersection points + ! P1 before and P2 after on the straight for segment + u = sfx - sox ; v = sfy - soy ; norm = u*u + v*v + if (.not.isEqualConst(sqrt(norm),dp_0)) then + tmp = sqrt((ray*ray - d*d)/norm) + u = tmp*u ; v = tmp*v + Ix=prjx-u ; Iy=prjy-v ; IinS=isIn_V2(Ix,Iy,sg) ; IinA=isIn(Ix,Iy,ar) + Jx=prjx+u ; Jy=prjy+v ; JinS=isIn_V2(Jx,Jy,sg) ; JinA=isIn(Jx,Jy,ar) + if (IinS/=0.and.IinA/=0) then + interSgAr_V2 = .true. ; n1 = IinS + 10*IinA ; P1 = t_point(Ix,Iy) + if (JinS/=0.and.JinA/=0) then + n2 = JinS + 10*JinA ; P2 = t_point(Jx,Jy) + goto 10 + endif + else if (JinS/=0.and.JinA/=0) then + interSgAr_V2 = .true. ; n1 = JinS + 10*JinA ; P1 = t_point(Jx,Jy) + goto 10 + end if + else + call XABORT("interSgAr_V2 : seg was not detected as a point but its norm is zero") + end if + end if + else + ! Tangency point + Ix=prjx ; Iy=prjy ; IinS=isIn(Ix,Iy,sg) ; IinA=isIn(Ix,Iy,ar) + if ((IinS/=0.and.IinA/=0)) then + interSgAr_V2=.true. ; n1 = 100 + 10 * IinA + IinS ; P1 = t_point(Ix,Iy) + end if + end if + ! +10 continue + return + end function interSgAr_V2 + + + function interSgAr(sg,ar,pt1x,pt1y,pt2x,pt2y) + type(t_segArc),intent(in) :: sg,ar + double precision,intent(out) :: pt1x,pt1y,pt2x,pt2y + integer :: interSgAr + + double precision :: prjx,prjy,d + double precision :: u,v,tmp,Ix,Iy,Jx,Jy + integer :: IinS,IinA,JinS,JinA + !renvoie le nombre de points d'intersection entre sg et ar, + !et leurs coordonnees eventuelles + !Si un seul point d'intersection, renvoi 1 si pt==I et -1 si pt==J + !Si l'arc et le segment sont tangents, renvoie 2, et pt1=pt2 + + interSgAr = 0 + pt1x=0.d0 ; pt1y=0.d0 ; pt2x=1.d0 ; pt2y=1.d0 + d = distance(ar%x,ar%y,sg%x,sg%y,sg%dx,sg%dy,prjx,prjy) + if (.not. isEqualConst(d,ar%r)) then + if (d>ar%r) then + interSgAr = 0 + else + !2 points d'intersection distincts I et J avec + !I avant J sur la droite d'appui du segment + u=sg%dx-sg%x ; v=sg%dy-sg%y + tmp=sqrt((ar%r*ar%r-d*d)/(u*u+v*v)) + u=tmp*u ; v=tmp*v + Ix=prjx-u ; Iy=prjy-v ; IinS=isIn(Ix,Iy,sg) ; IinA=isIn(Ix,Iy,ar) + Jx=prjx+u ; Jy=prjy+v ; JinS=isIn(Jx,Jy,sg) ; JinA=isIn(Jx,Jy,ar) + if ((IinS/=0.and.IinA/=0).and.(IinS==2.or.IinA==2)) then + interSgAr=1 ; pt1x=Ix ; pt1y=Iy + end if + if ((JinS/=0.and.JinA/=0).and.(JinS==2.or.JinA==2)) then + if (interSgAr==1) then + interSgAr=2 ; pt2x=Jx ; pt2y=Jy + else + interSgAr=-1 ; pt1x=Jx ; pt1y=Jy + end if + end if + end if + else + Ix=prjx ; Iy=prjy ; IinS=isIn(Ix,Iy,sg) ; IinA=isIn(Ix,Iy,ar) + if ((IinS/=0.and.IinA/=0).and.(IinS==2.or.IinA==2)) then + interSgAr=2 ; pt1x=Ix ; pt1y=Iy ; pt2x=Ix ; pt2y=Iy + end if + end if + end function interSgAr + + logical function InterSgSg_V2(sg1,sg2,n1, n2, P1,P2) + type(t_segArc),intent(in) :: sg1,sg2 + integer, intent(inout) :: n1, n2 + type(t_point), intent(out) :: P1, P2 + + double precision :: xo1, xf1, xo2, xf2, yo1, yf1, yo2, yf2 + double precision :: min1, min2, max1, max2, m, prodvect + double precision :: a1, a2, b1, b2, y + + ! Initialization + n1 = 0 ; n2 = 0 + P1 = t_point(dp_0,dp_0) ; P2 = t_point(dp_0,dp_0) + InterSgSg_V2 = .false. + + ! Coordinates + xo1=sg1%x ; xf1 =sg1%dx ; yo1 = sg1%y ; yf1 = sg1%dy + xo2=sg2%x ; xf2 =sg2%dx ; yo2 = sg2%y ; yf2 = sg2%dy + + ! Very Special case : point instead of segment + min1 = sqrt((xf1-xo1)*(xf1-xo1)+(yf1-yo1)*(yf1-yo1)) + min2 = sqrt((xf2-xo2)*(xf2-xo2)+(yf2-yo2)*(yf2-yo2)) + if (isEqualConst(min1,dp_0)) then + prodvect = (xf2-xo2)*(yo1-yo2)-(yf2-yo2)*(xo1-xo2) + if (isEqualConst(prodvect,dp_0) .and. (isIn(xo1,yo1,Sg2)/=0)) then + InterSgSg_V2 = .true. ; n1 = 1 ; P1 = t_point(xo1,yo1) + endif + goto 10 + elseif(isEqualConst(min2,dp_0)) then + prodvect = (xf1-xo1)*(yo2-yo1)-(yf1-yo1)*(xo2-xo1) + if (isEqualConst(prodvect,dp_0) .and. (isIn(xo2,yo2,Sg1)/=0)) then + InterSgSg_V2 = .true. ; n1 = 1 ; P1 = t_point(xo2,yo2) + endif + goto 10 + else + + ! Special case : two vertical segments + if (IsEqualConst(xo1,xf1).and.IsEqualConst(xo2,xf2)) then + if (IsEqualConst(xo1,xo2)) then + min1 = min(yo1,yf1) ; max1 = max(yo1,yf1) + min2 = min(yo2,yf2) ; max2 = max(yo2,yf2) + if (isEqualConst(min1,max2).or.isEqualConst(min2,max1)) then + InterSgSg_V2 = .true. ; n1 = 1 + if (isEqualConst(min1,max2)) P1 = t_point(xo1,min1) + if (isEqualConst(max1,min2)) P1 = t_point(xo2,min2) + elseif (max2 < min1 .or. max1 < min2) then + InterSgSg_V2 = .false. + else + InterSgSg_V2 = .true. + n1 = 1 ; P1 = t_point(xo1,max(min1,min2)) + n2 = 1 ; P2 = t_point(xo1,min(max1,max2)) + endif + endif + else + ! Special case : only one vertical segment + if (isEqualConst(xo1,xf1).and..not.isEqualConst(xo2,xf2)) then + a2 = (yf2 - yo2) / (xf2 - xo2) ; b2 = yo2 - a2 * xo2 + if ((isEqualConst(xo1,min(xo2,xf2)).or.xo1>min(xo2,xf2)) .and.& + (isEqualConst(xo2,max(xo2,xf2)).or.xo1min(yo1,yf1)).and.& + (isEqualConst(y,max(yo1,yf1)).or.ymin(yo2,yf2)).and.& + (isEqualConst(y,max(yo2,yf2)).or.ymin(xo1,xf1) ).and.& + (isEqualConst(xo2,max(xo1,xf1)).or.xo2min(yo1,yf1)).and.& + (isEqualConst(y,max(yo1,yf1)).or.ymin(yo2,yf2)).and.& + (isEqualConst(y,max(yo2,yf2)).or.ymin1) .and. & + (isEqualConst(m,max1).or.mmin2) .and. & + (isEqualConst(m,max2).or.m(d2+rc2)).or.(rc2>(d2+rr2)) + + if (d>(maxD+epsilon).or.d<(minD-epsilon)) return !pas d'intersection + + if (isEqualConst(d,maxD).or.isEqualConst(d,minD)) then + !tangence entre les deux cercles d'appuis + aClus = calculeAngle(clus%x,clus%y,ring%x,ring%y) + if (revert) aClus = angleNormal(aClus - pi_c) + inRing = isIn(clus%x+clus%r*cos(aClus),clus%y+clus%r*sin(aClus),ring) + aRing = calculeAngle(ring%x,ring%y,clus%x,clus%y) + inClus = isIn(ring%x+ring%r*cos(aRing),ring%y+ring%r*sin(aRing),clus) + if (inRing==2 .and. inClus==2) interArcArc = 1 !dans les arcs + return + end if + + !il y a intersection reelle des deux cercles d'appuis + ! l'angle a1 adjacent a r1 est determinable a l'aide de la formule + ! cos(a1) = (d\B2+r1\B2-r2\B2)/(2*d*r1) (idem mutatis-mutandis pour a2) + aC = acos((d2+rc2-rr2)/(2*d*clus%r)) + aClus = angleNormal(calculeAngle(clus%x,clus%y,ring%x,ring%y) - aC) + bClus = angleNormal(calculeAngle(clus%x,clus%y,ring%x,ring%y) + aC) + aR = acos((d2+rr2-rc2)/(2*d*ring%r)) + aRing = angleNormal(calculeAngle(ring%x,ring%y,clus%x,clus%y) - aR) + bRing = angleNormal(calculeAngle(ring%x,ring%y,clus%x,clus%y) + aR) + aIn = (isAngleInArc(aClus,clus)==2) .and. (isAngleInArc(aRing,ring)==2) + bIn = (isAngleInArc(bClus,clus)==2) .and. (isAngleInArc(bRing,ring)==2) + if (aIn .and. bIn) then + interArcArc = 2 + else if (aIn) then + interArcArc = 1 + else if (bIn) then + interArcArc = 1 + aClus = bClus + aRing = bRing + end if + end function interArcArc + + function giveExtremalsAngles(sa,cx,cy,ao,ae) + type(t_segArc),intent(in) :: sa + double precision,intent(in) :: cx,cy + double precision,intent(out) :: ao,ae + logical :: giveExtremalsAngles + + double precision :: ox,oy,ex,ey + + select case(sa%typ) + case(tcer) + ! on sort avec une valeur false + ao = 0.d0 ; ae=0.d0 ; giveExtremalsAngles = .false. + return + case(tarc) + call extremitesArc(sa,ox,oy,ex,ey) + case(tseg) + ox = sa%x ; oy = sa%y ; ex = sa%dx ; ey = sa%dy + end select + ao = angleNormal(calculeAngle(cx,cy,ox,oy)) + ae = angleNormal(calculeAngle(cx,cy,ex,ey)) + giveExtremalsAngles = .not.( (isEqualConst(cx,ox).and.isEqualConst(cy,oy))& + .or.(isEqualConst(cx,ex).and.isEqualConst(cy,ey)) ) + end function giveExtremalsAngles + + subroutine drawSegArc(fileNbr,szSA,withNodes,drawMix,zoomx,zoomy) + integer,intent(in) :: fileNbr,szSA + logical,intent(in) :: withNodes,drawMix + real,intent(in) :: zoomx(2),zoomy(2) + + type(t_segArc) :: sa + integer :: i + real :: cx,cy,angl,lx,ly,tailleNbr,delx,dely + + g_psp_bBoxXmin = 1.e10 + g_psp_bBoxYmin = 1.e10 + g_psp_bBoxXmax = -1.e10 + g_psp_bBoxYmax = -1.e10 + !recuperation des donnees permettants le centrage + do i = 1,szSA + sa = tabSegArc(i) + if (sa%typ==tseg) then + g_psp_bBoxXmin = min(real(sa%x),real(sa%dx),g_psp_bBoxXmin) + g_psp_bBoxYmin = min(real(sa%y),real(sa%dy),g_psp_bBoxYmin) + g_psp_bBoxXmax = max(real(sa%x),real(sa%dx),g_psp_bBoxXmax) + g_psp_bBoxYmax = max(real(sa%y),real(sa%dy),g_psp_bBoxYmax) + else + g_psp_bBoxXmin = min(real(sa%x-sa%r),g_psp_bBoxXmin) + g_psp_bBoxYmin = min(real(sa%y-sa%r),g_psp_bBoxYmin) + g_psp_bBoxXmax = max(real(sa%x+sa%r),g_psp_bBoxXmax) + g_psp_bBoxYmax = max(real(sa%y+sa%r),g_psp_bBoxYmax) + end if + end do + delx = g_psp_bBoxXmax - g_psp_bBoxXmin + dely = g_psp_bBoxYmax - g_psp_bBoxYmin + g_psp_bBoxXmax = g_psp_bBoxXmin + zoomx(2)*delx + g_psp_bBoxXmin = g_psp_bBoxXmin + zoomx(1)*delx + g_psp_bBoxYmax = g_psp_bBoxYmin + zoomy(2)*dely + g_psp_bBoxYmin = g_psp_bBoxYmin + zoomy(1)*dely + lx = 0.1 * ( g_psp_bBoxXmax - g_psp_bBoxXmin ) + ly = 0.1 * ( g_psp_bBoxYmax - g_psp_bBoxYmin ) + write(*,10) g_psp_bBoxXmin,g_psp_bBoxXmax,g_psp_bBoxYmin,g_psp_bBoxYmax + 10 format(' g2s_segArc: plot domain=(',1p,e14.7,':',e14.7,',',e14.7,':',e14.7,')') + g_psp_bBoxXmin = g_psp_bBoxXmin - lx + g_psp_bBoxYmin = g_psp_bBoxYmin - ly + g_psp_bBoxXmax = g_psp_bBoxXmax + lx + g_psp_bBoxYmax = g_psp_bBoxYmax + ly + tailleNbr = min(595./(g_psp_bBoxXmax-g_psp_bBoxXmin), & + 842./(g_psp_bBoxYmax-g_psp_bBoxYmin)) + tailleNbr = 3.6 / tailleNbr + !impression + call psinit(fileNbr,.true.) + do i = 1,szSA + sa = tabSegArc(i) + if (sa%typ==tseg) then + call line(sa%x,sa%y,sa%dx,sa%dy) + cx=real((sa%dx+sa%x)*0.5d0) ; cy=real((sa%dy+sa%y)*0.5d0) + angl = real(calculeAngle(sa%x,sa%y,sa%dx,sa%dy)*rad2deg-90.d0) + if (withNodes .and. drawMix) then + call keknum(cx,cy,tailleNbr,real(sa%nodeg),angl,-1,2) + call keknum(cx,cy,tailleNbr,real(sa%noded),angl,-1,0) + else if (drawMix) then + call keknum(cx,cy,tailleNbr,real(sa%neutronicMixg),angl,-1,2) + call keknum(cx,cy,tailleNbr,real(sa%neutronicMixd),angl,-1,0) + end if + else if (sa%typ==tcer) then + call arc(sa%x,sa%y,sa%r,0.d0,180.d0) + call arc(sa%x,sa%y,sa%r,180.d0,360.d0) + cx=real(sa%x+sa%r) ; cy=real(sa%y) + if (withNodes .and. drawMix) then + call keknum(cx,cy,tailleNbr,real(sa%nodeg),0.,-1,2) + call keknum(cx,cy,tailleNbr,real(sa%noded),0.,-1,0) + else if (drawMix) then + call keknum(cx,cy,tailleNbr,real(sa%neutronicMixg),0.,-1,2) + call keknum(cx,cy,tailleNbr,real(sa%neutronicMixd),0.,-1,0) + end if + else + call arc(sa%x,sa%y,sa%r,sa%a*rad2deg,sa%b*rad2deg) + if (sa%b>sa%a) then + angl=real((sa%b+sa%a)*0.5d0) + else + angl=real((sa%b+sa%a)*0.5d0+pi_c) + end if + cx=real(sa%x+cos(angl)*sa%r) ; cy=real(sa%y+sin(angl)*sa%r) + angl=real(angl*rad2deg) + if (withNodes .and. drawMix) then + call keknum(cx,cy,tailleNbr,real(sa%nodeg),angl,-1,2) + call keknum(cx,cy,tailleNbr,real(sa%noded),angl,-1,0) + else if (drawMix) then + call keknum(cx,cy,tailleNbr,real(sa%neutronicMixg),angl,-1,2) + call keknum(cx,cy,tailleNbr,real(sa%neutronicMixd),angl,-1,0) + end if + end if + end do + call plotnd() + end subroutine drawSegArc + + subroutine coupeCercle(indDeb,szSA,nbSeg,typ) + integer,intent(in) :: indDeb,nbSeg,typ + integer,intent(inout) :: szSA + + type(t_segArc) :: sg,ar + double precision :: pt1x,pt1y,pt2x,pt2y,angl1,angl2,midx,midy,tmp + integer :: i,j,k,tailleAv,tailleAp,nbPtInter + type(segArcArrayBis),dimension(:),allocatable :: tmpTabSegArc + + ! pour programmation defensive + integer :: taille_table_temp + + !RQ: indDeb est l'indice du dernier element du tableau qui + ! ne doit pas etre pris en compte. nbSeg est le nombre + ! de segments paralleles aux axes, et typ correspond au type (3,4,6,ou...) + ! CS-IV : Correction des commentaires d'origine + ! CS-IV : indDeb : indice du dernier element a ne pas prendre en compte + ! CS-IV : (point de depart) + ! CS-IV : nbSeg : nombre de SA a prendre en charge + ! CS-IV : szSA : nombre total de SA dans le tableau + + !preparation du tableau de travail + tailleAp = szSA-indDeb + + ! CS-IV : pourquoi ce 25 ?(on considere que la decoupe ne va pas + ! CS-IV : accroitre le nombre de segments de plus de 25 fois + ! CS-IV : ce coef devrait etre reflechi et dependre du nbr de cercles et + ! CS-IV : et de segments + + ! pour programmation defensive + taille_table_temp = 25*tailleAp + allocate(tmpTabSegArc(1:taille_table_temp),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: coupeCercle (1) => allocation pb") + + !copie des segments et arcs construits dans le tableau + !temporaire + ! CS-IV : et suppression dans le tableau initial + tmpTabSegArc(1:tailleAp)%sa = tabSegArc(indDeb+1:indDeb+tailleAp) + tmpTabSegArc(1:tailleAp)%keep = .true. + + szSa = indDeb + ! on coupe tout les elements possible presents, en ne gardant pas ceux qui + ! sont a couper, mais seulement les morceaux obtenus + ! pour i->segment, pour j->arc ou cercle + do + tailleAv = tailleAp + i = 0 + do + i = i+1 + if (.not. tmpTabSegArc(i)%keep) then + if (i/=tailleAv ) cycle + exit + end if + sg = tmpTabSegArc(i)%sa + if (sg%typ/=tseg) then + if (i/=tailleAv ) cycle + exit + end if + ! CS-IV : le SA tmpTabSegArc(i) est un segment + do j = 1,tailleAv + if ((j==i).or.(.not. tmpTabSegArc(j)%keep)) cycle + ar = tmpTabSegArc(j)%sa + if (ar%typ==tseg) cycle + ! CS-IV : le SA tmpTabSegArc(j) est un arc + nbPtInter = interSgAr(sg,ar,pt1x,pt1y,pt2x,pt2y) + if (nbPtInter==2) then + !!deux points d'intersection : + ! CS-IV : on obtient 3 segments et 2 arcs + tmpTabSegArc(i)%keep=.false. ; tmpTabSegArc(j)%keep=.false. + ! => 3 segments (qui gardent les caracteristiques sect*) + do k = 1,3 + tailleAp=tailleAp+1 + ! pour programmation defensive + if (tailleAP > taille_table_temp) & + call XABORT("G2S : memory problem in routine CoupeCercle (1)") + tmpTabSegArc(tailleAp)%sa=sg + end do + tmpTabSegArc(tailleAp-2)%sa%dx=pt1x + tmpTabSegArc(tailleAp-2)%sa%dy=pt1y + tmpTabSegArc(tailleAp-1)%sa%x=pt1x + tmpTabSegArc(tailleAp-1)%sa%y=pt1y + tmpTabSegArc(tailleAp-1)%sa%dx=pt2x + tmpTabSegArc(tailleAp-1)%sa%dy=pt2y + tmpTabSegArc(tailleAp)%sa%x=pt2x + tmpTabSegArc(tailleAp)%sa%y=pt2y + tmpTabSegArc(tailleAp-2)%sa%mixg=ar%mixd + tmpTabSegArc(tailleAp-2)%sa%mixd=ar%mixd + tmpTabSegArc(tailleAp-1)%sa%mixg=ar%mixg + tmpTabSegArc(tailleAp-1)%sa%mixd=ar%mixg + tmpTabSegArc(tailleAp)%sa%mixg=ar%mixd + tmpTabSegArc(tailleAp)%sa%mixd=ar%mixd + ! elimination d'un eventuel segment nul + do k = 0,2 + tmpTabSegArc(tailleAp-k)%keep= .not. & + & ( (isEqual( tmpTabSegArc(tailleAp-k)%sa%x , & + & tmpTabSegArc(tailleAp-k)%sa%dx) ) .and. & + & (isEqual( tmpTabSegArc(tailleAp-k)%sa%y , & + & tmpTabSegArc(tailleAp-k)%sa%dy) ) ) + end do + angl1=calculeAngle(ar%x,ar%y,pt1x,pt1y) + angl2=calculeAngle(ar%x,ar%y,pt2x,pt2y) + !travail sur les arcs + if (ar%typ==tcer) then + !c'etait un cercle complet + if (isEqualAngl(angl1,angl2)) then !tangence + tailleAp=tailleAp+1 + ! pour programmation defensive + if (tailleAP > taille_table_temp) & + call XABORT("G2S : memory problem in routine CoupeCercle (2)") + tmpTabSegArc(tailleAp)%sa=ar + tmpTabSegArc(tailleAp)%keep=.true. + tmpTabSegArc(tailleAp)%sa%typ=tarc + tmpTabSegArc(tailleAp)%sa%a=angl1 + tmpTabSegArc(tailleAp)%sa%b=angl1 + !positionnement des sect* + if (estAGauche(sg%x,sg%y,sg%dx,sg%dy,ar%x,ar%y)) then + !cercle completement a gauche de sg + tmpTabSegArc(tailleAp)%sa%sectg=sg%sectg + tmpTabSegArc(tailleAp)%sa%sectd=sg%sectg + else + !cercle completement a droite de sg + tmpTabSegArc(tailleAp)%sa%sectg=sg%sectd + tmpTabSegArc(tailleAp)%sa%sectd=sg%sectd + end if + else !pas tangence + !un arc de chaque cote de sg (1\B0 a drt, 2\B0 a gch) + do k = 1,2 + tailleAp=tailleAp+1 + ! pour programmation defensive + if (tailleAP > taille_table_temp) & + call XABORT("G2S : memory problem in routine CoupeCercle (3)") + tmpTabSegArc(tailleAp)%sa=ar + tmpTabSegArc(tailleAp)%keep=.true. + tmpTabSegArc(tailleAp)%sa%typ=tarc + end do + tmpTabSegArc(tailleAp-1)%sa%a=angl1 + tmpTabSegArc(tailleAp-1)%sa%b=angl2 + tmpTabSegArc(tailleAp-1)%sa%sectg=sg%sectd + tmpTabSegArc(tailleAp-1)%sa%sectd=sg%sectd + tmpTabSegArc(tailleAp)%sa%a=angl2 + tmpTabSegArc(tailleAp)%sa%b=angl1 + tmpTabSegArc(tailleAp)%sa%sectg=sg%sectg + tmpTabSegArc(tailleAp)%sa%sectd=sg%sectg + end if + else !c'etait deja un arc de cercle + do k = 1,3 + tailleAp=tailleAp+1 + ! pour programmation defensive + if (tailleAP > taille_table_temp) & + call XABORT("G2S : memory problem in routine CoupeCercle (4)") + tmpTabSegArc(tailleAp)%sa=ar + end do + tmpTabSegArc(tailleAp-2)%sa%b=angl1 + !on test si on est bien dans le bon sens + if (isIn(pt2x,pt2y,tmpTabSegArc(tailleAp-2)%sa)==2) then + !on est a l'envers (ouverture a droite) + tmpTabSegArc(tailleAp-2)%sa%b=angl2 + tmpTabSegArc(tailleAp-1)%sa%a=angl2 + tmpTabSegArc(tailleAp-1)%sa%b=angl1 + tmpTabSegArc(tailleAp)%sa%a=angl1 + !ajustement des sect* + tmpTabSegArc(tailleAp-2)%sa%sectg=sg%sectd + tmpTabSegArc(tailleAp-2)%sa%sectd=sg%sectd + tmpTabSegArc(tailleAp-1)%sa%sectg=sg%sectg + tmpTabSegArc(tailleAp-1)%sa%sectd=sg%sectg + tmpTabSegArc(tailleAp)%sa%sectg=sg%sectd + tmpTabSegArc(tailleAp)%sa%sectd=sg%sectd + else !on est a l'endroit (ouverture a gauche) + tmpTabSegArc(tailleAp-1)%sa%a=angl1 + tmpTabSegArc(tailleAp-1)%sa%b=angl2 + tmpTabSegArc(tailleAp)%sa%a=angl2 + !ajustement des sect* + tmpTabSegArc(tailleAp-2)%sa%sectg=sg%sectg + tmpTabSegArc(tailleAp-2)%sa%sectd=sg%sectg + tmpTabSegArc(tailleAp-1)%sa%sectg=sg%sectd + tmpTabSegArc(tailleAp-1)%sa%sectd=sg%sectd + tmpTabSegArc(tailleAp)%sa%sectg=sg%sectg + tmpTabSegArc(tailleAp)%sa%sectd=sg%sectg + end if + do k = 0,2 + tmpTabSegArc(tailleAp-k)%keep=.not. & + & ( isEqualAngl( tmpTabSegArc(tailleAp-k)%sa%a , & + & tmpTabSegArc(tailleAp-k)%sa%b ) ) + end do + end if + i=0 + exit + else if (abs(nbPtInter)==1) then + !! un seul point d'intersection + ! CS-IV : on obtient 2 segments & 2 arcs + tmpTabSegArc(i)%keep=.false. + tmpTabSegArc(j)%keep=.false. + do k = 1,2 + tailleAp=tailleAp+1 + ! pour programmation defensive + if (tailleAP > taille_table_temp) & + call XABORT("G2S : memory problem in routine CoupeCercle (5)") + tmpTabSegArc(tailleAp)%sa=sg + end do + tmpTabSegArc(tailleAp-1)%sa%dx=pt1x + tmpTabSegArc(tailleAp-1)%sa%dy=pt1y + tmpTabSegArc(tailleAp)%sa%x=pt1x + tmpTabSegArc(tailleAp)%sa%y=pt1y + if (nbPtInter==1) then + !intersection en I (origne de sg a l'exterieur de ar) + tmpTabSegArc(tailleAp-1)%sa%mixg=ar%mixd + tmpTabSegArc(tailleAp-1)%sa%mixd=ar%mixd + tmpTabSegArc(tailleAp)%sa%mixg=ar%mixg + tmpTabSegArc(tailleAp)%sa%mixd=ar%mixg + else + !intersection en J (origne de sg a l'interieur de ar) + tmpTabSegArc(tailleAp-1)%sa%mixg=ar%mixg + tmpTabSegArc(tailleAp-1)%sa%mixd=ar%mixg + tmpTabSegArc(tailleAp)%sa%mixg=ar%mixd + tmpTabSegArc(tailleAp)%sa%mixd=ar%mixd + end if + do k = 0,1 + tmpTabSegArc(tailleAp-k)%keep=.not. & + & ( ( isEqual( tmpTabSegArc(tailleAp-k)%sa%x , & + & tmpTabSegArc(tailleAp-k)%sa%dx ) ) .and.& + & ( isEqual( tmpTabSegArc(tailleAp-k)%sa%y , & + & tmpTabSegArc(tailleAp-k)%sa%dy ) ) ) + end do + angl1=calculeAngle(ar%x,ar%y,pt1x,pt1y) + if (ar%typ==tcer) then + !ar etait un cercle + tailleAp=tailleAp+1 + ! pour programmation defensive + if (tailleAP > taille_table_temp) & + call XABORT("G2S : memory problem in routine CoupeCercle (6)") + tmpTabSegArc(tailleAp)%sa=ar + tmpTabSegArc(tailleAp)%sa%typ=tarc + tmpTabSegArc(tailleAp)%sa%a=angl1 + tmpTabSegArc(tailleAp)%sa%b=angl1 + tmpTabSegArc(tailleAp)%keep=.true. + !pas d'ajustement des sect*, car l'arc n'est ni d'un cote + !ni de l'autre + else + do k = 1,2 + tailleAp=tailleAp+1 + ! pour programmation defensive + if (tailleAP > taille_table_temp) & + call XABORT("G2S : memory problem in routine CoupeCercle (7)") + tmpTabSegArc(tailleAp)%sa=ar + end do + tmpTabSegArc(tailleAp-1)%sa%b=angl1 + tmpTabSegArc(tailleAp)%sa%a=angl1 + !ajustement des sect* + if (nbPtInter==1) then + !intersection en I (origne de sg a l'exterieur de ar) + tmpTabSegArc(tailleAp-1)%sa%sectg=sg%sectg + tmpTabSegArc(tailleAp-1)%sa%sectd=sg%sectg + tmpTabSegArc(tailleAp)%sa%sectg=sg%sectd + tmpTabSegArc(tailleAp)%sa%sectd=sg%sectd + else + !intersection en J (origne de sg a l'interieur de ar) + tmpTabSegArc(tailleAp-1)%sa%sectg=sg%sectd + tmpTabSegArc(tailleAp-1)%sa%sectd=sg%sectd + tmpTabSegArc(tailleAp)%sa%sectg=sg%sectg + tmpTabSegArc(tailleAp)%sa%sectd=sg%sectg + end if + do k = 0,1 + tmpTabSegArc(tailleAp-k)%keep=.not. & + & ( isEqualAngl( tmpTabSegArc(tailleAp-k)%sa%a , & + & tmpTabSegArc(tailleAp-k)%sa%b ) ) + end do + end if + i=0 + exit + end if + end do + if (i==tailleAv) exit + end do + if ((tailleAp==tailleAv) .and. (i==tailleAv)) exit + end do + + !on elimine les elements en dehors des limites de la cellule, et on remet le + !milieu exterieur a la cellule a fooMix + !Remarque : les elements tmpTabSegArc(1:nbSeg)%sa sont les segments + !initiaux paralleles aux bords du domaine. Ils peuvent etre a jeter + !(keep==.false.), mais ils servent tout de meme de reference. Pour savoir + !si ils sont au bord de la cellule, on teste si le milieu est fooMix. + !Si oui, on elimine tous les elements qui sont de ce cote. + if (typ==tRec .or. typ==tHex) then + do i = 1,nbSeg + sg = tmpTabSegArc(i)%sa + do j = 1,tailleAp + ar = tmpTabSegArc(j)%sa + if (ar%typ==tseg) then + if (.not. & + (estColi(sg%dx-sg%x,sg%dy-sg%y,ar%dx-ar%x,ar%dy-ar%y) & + .and. pointsAlignes(sg%x,sg%y,sg%dx,sg%dy,ar%x,ar%y)) & + ) cycle + if (sg%mixd==fooMix) then + tmpTabSegArc(j)%sa%mixd=fooMix + else if (sg%mixg==fooMix) then + tmpTabSegArc(j)%sa%mixg=fooMix + end if + cycle + end if + if ((j==i) .or. (.not. tmpTabSegArc(j)%keep)) cycle + if (ar%b>ar%a) then + angl1=(ar%b+ar%a)*0.5d0 + else + angl1=(ar%b+ar%a)*0.5d0+pi_c + end if + !point milieu de l'arc + midx=ar%x+ar%r*cos(angl1) + midy=ar%y+ar%r*sin(angl1) + !sinus de l'angle (OE,OM) + tmp = sin( calculeAngle(sg%x,sg%y,midx,midy) - & + & calculeAngle(sg%x,sg%y,sg%dx,sg%dy) ) + if (sg%mixd==fooMix) then !on garde a gauche + tmpTabSegArc(j)%keep=(tmp>0.).or.(isEqualAngl(ar%a,ar%b).and. & + & estAGauche(sg%x,sg%y,sg%dx,sg%dy,ar%x,ar%y)) + else if (sg%mixg==fooMix) then !on garde a droite + tmpTabSegArc(j)%keep=(tmp<0.).or.(isEqualAngl(ar%a,ar%b).and. & + & estADroite(sg%x,sg%y,sg%dx,sg%dy,ar%x,ar%y)) + end if + end do + end do + else + call XABORT("G2S : type of geometrie not supported") + end if + + !elimination des segments nuls eventuellement restants + do i = 1,tailleAp + sg = tmpTabSegArc(i)%sa + if (sg%typ==tseg) tmpTabSegArc(i)%keep=tmpTabSegArc(i)%keep .and. & + .not.(isEqual(tmpTabSegArc(i)%sa%x,tmpTabSegArc(i)%sa%dx) .and. & + isEqual(tmpTabSegArc(i)%sa%y,tmpTabSegArc(i)%sa%dy)) + end do + + !on recupere dans le tableau general les elements restants + do i = 1,tailleAp + if (.not. tmpTabSegArc(i)%keep) cycle + szSa = szSa+1 + tabSegArc(szSa) = tmpTabSegArc(i)%sa + end do + + !on nettoie le tableau temporaire + deallocate(tmpTabSegArc) + end subroutine coupeCercle + + subroutine splitSegsForSect(indDeb,szSA) + integer,intent(in) :: indDeb + integer,intent(inout) :: szSA + + type(t_segArc) :: sgi,sgj + integer :: i,j + + ! pour programmation defensive + integer :: taille_table_tabSegArc + + !! permet de spliter les segments en bordure de domaine, + !! losqu'ils sont interceptes par les segments delimitants + !! la sectorisation. Si on a intersection, c'est toujours a + !! l'interieur d'un segment de bordure, et au bout d'un segment + !! de secteur. -->^-----> <-----^<-- + !! Dans ce cas, on split ainsi: (1) i | szSA ou: (2) szSA | i + + ! pour programmation defensive + taille_table_tabSegArc = size(tabSegArc) + + i = indDeb + do + i = i + 1 + if (i>szSA) exit + sgi=tabSegArc(i) + if (sgi%typ/=tseg) cycle + do j = indDeb+1,szSA + if (j==i) cycle + sgj=tabSegArc(j) + if (sgj%typ/=tseg) cycle + if (PointsAlignes(sgi%x,sgi%y,sgi%dx,sgi%dy,sgj%dx,sgj%dy).and.& + (isIn(sgj%dx,sgj%dy,sgi)==2).and. & + .not.PointsAlignes(sgi%x,sgi%y,sgi%dx,sgi%dy,sgj%x,sgj%y)) then + szSA=szSA+1 + ! pour programmation defensive + if (szSA > taille_table_tabSegArc) & + call XABORT("G2S : memory problem in routine splitSegsForSect") + tabSegArc(szSA) = sgi + tabSegArc(i)%dx = sgj%dx ; tabSegArc(i)%dy = sgj%dy + tabSegArc(szSA)%x = sgj%dx ; tabSegArc(szSA)%y = sgj%dy + + if (estAGaucheStrict(sgj%x,sgj%y,sgj%dx,sgj%dy,sgi%x,sgi%y)) then + !! cas (1) + tabSegArc(i)%sectg = sgj%sectg + tabSegArc(i)%sectd = sgj%sectg + tabSegArc(szSA)%sectg = sgj%sectd + tabSegArc(szSA)%sectd = sgj%sectd + else + !! cas (2) + tabSegArc(i)%sectg = sgj%sectd + tabSegArc(i)%sectd = sgj%sectd + tabSegArc(szSA)%sectg = sgj%sectg + tabSegArc(szSA)%sectd = sgj%sectg + end if + sgi = tabSegArc(i) + end if + end do + end do + end subroutine splitSegsForSect + + subroutine majSectori(indDeb,szSA,sectori,typGeo,cx,cy) + double precision, parameter :: PI = 3.141592653589793d0 + integer,intent(in) :: indDeb,szSA,sectori,typGeo + double precision,intent(in) :: cx,cy + !met a jour les secteurs pour les elements + + double precision :: ao,ae !angles origine et extremite + integer :: i,j,nbSect,oIn,eIn + logical :: goodAngles + double precision,dimension(9) :: limit + + if ((typGeo/=tRec).and.(typGeo/=tHex)) & + call XABORT("G2S: internal error with typGeo in subroutine majSectori") + !creation des zones angulaires + nbSect = 0 + select case(sectori) + case(S_not) + return !rien a faire + case(S_X_tot) + if (typGeo == tRec) then + nbSect = 4 + limit(1) = pi_2_c*5.d-1 ; limit(2) = pi_2_c*1.5d0 + limit(3) = -limit(2) ; limit(4) = -limit(1) + limit(5) = limit(1) + else + nbSect = 6 + limit(1) = 0.d0 ; limit(2) = pi_3_c ; limit(3) = pi_3_c*2.d0 + limit(4) = pi_c ; limit(5) = -limit(3) ; limit(6) = -limit(2) + limit(7) = limit(1) + end if + case(S_T_tot) + nbSect = 4 + limit(1) = 0.d0 ; limit(2) = pi_2_c + limit(3) = pi_c ; limit(4) = -limit(2) + limit(5) = limit(1) + case(S_TX_tot) + nbSect = 8 + limit(1) = 0.d0 ; limit(2) = pi_2_c*5.d-1 + limit(3) = pi_2_c ; limit(4) = pi_2_c*1.5d0 + limit(5) = pi_c ; limit(6) = -limit(4) + limit(7) = -limit(3) ; limit(8) = -limit(2) + limit(9) = limit(1) + case(S_TXS_tot) + nbsect = 8 + limit(1) = PI/8. + do i=1, 7 + limit(i+1) = limit(i) + PI/4. + enddo + limit(9) = limit(1) + case(S_WM_tot) + nbsect = 8 + limit(1) = PI/8. + do i=1, 7 + limit(i+1) = limit(i) + PI/4. + enddo + limit(9) = limit(1) + case default + call XABORT("G2S: internal error with sectori in subroutine majSectori") + end select + !traitement des elements + do i = indDeb+1,szSA + if (tabSegArc(i)%typ == tcer) cycle !on ne s'interesse pas aux cercles + !on recupere les angles des bouts + goodAngles = giveExtremalsAngles(tabSegArc(i),cx,cy,ao,ae) + if (.not.goodAngles) cycle !une des extremites est le centre + ! => on ne s'en occupe pas + do j = 1,nbSect + !boucle sur les secteurs + oIn = isAngleInInterval(ao,limit(j),limit(j+1)) + eIn = isAngleInInterval(ae,limit(j),limit(j+1)) + if ((oIn==0) .or. (eIn==0)) then + !pas dans le secteur + cycle !on passe au secteur suivant + else if ((oIn==2) .or. (eIn==2)) then + !on est completement dans le secteur + tabSegArc(i)%sectg = j + tabSegArc(i)%sectd = j + exit !on sort de la boucle en j + else if (oIn/=eIn) then + !element occupant le secteur angulaire total => idem cas precedent + tabSegArc(i)%sectg = j + tabSegArc(i)%sectd = j + exit !on sort de la boucle en j + else + !les 2 extremites sont sur le meme separateur + ! => on ne s'en occupe pas + exit !on sort de la boucle en j + end if + end do + end do + end subroutine majSectori + + subroutine addSegsAndClean(sizeSA) + integer,intent(inout) :: sizeSA + + integer :: i,j,sizeTmp + integer :: oj,ej !test l'appartenance a sgi des bouts de sgj + type(t_segArc) :: sgi,sgj + type(segArcArrayBis),dimension(:),allocatable :: tmpTab + + ! pour programmation defensive + integer :: taille_table_temp, taille_table_tabSegArc + + ! copie dans un tableau temporaire des segments et nettoyage du tableau + ! global + ! pour programmation defensive + taille_table_temp = sizeSA*10 + taille_table_tabSegArc = size(tabSegArc) + + allocate(tmpTab(taille_table_temp),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: addSegsAndClean(1) => allocation pb") + tmpTab(1:sizeSA)%sa=tabSegArc(1:sizeSA) + tmpTab(1:sizeSA)%keep=.true. + + sizeTmp=sizeSA + i=0 + do + i = i+1 + if (i>sizeTmp) exit + if (.not. tmpTab(i)%keep) cycle + if (tmpTab(i)%sa%typ/=tseg) cycle + sgi=tmpTab(i)%sa !c'est bien un segment a garder pour le moment + j = 0 + do + j = j+1 + if (j>sizeTmp) exit + if (j==i) cycle + if (.not. tmpTab(j)%keep) cycle + if (tmpTab(j)%sa%typ/=tseg) cycle + sgj=tmpTab(j)%sa + if (.not. estColineaire(sgi,sgj)) cycle + if (.not. pointsAlignes(sgi%x,sgi%y,sgi%dx,sgi%dy,sgj%x,sgj%y)) cycle + !on renverse le sens de sgj si besoin + if (.not. isSameWay(sgi,sgj)) sgj=turnBackSide(tmpTab(j)%sa) + oj=isIn(sgj%x,sgj%y,sgi) ; ej=isIn(sgj%dx,sgj%dy,sgi) + select case(ej) !seuls cas 0,2,3 utiles pour ej + case(0) !seuls cas 0,1,2 utiles pour oj + select case(oj) + case(0) !si isIn(sgi%x,sgi%y,sgj)/=2 rien sinon, sgi dans sgj + if (isIn(sgi%x,sgi%y,sgj)/=2) cycle + call adjustMix(tmpTab(i)%sa,sgj) + sizeTmp=sizeTmp+1 + ! pour programmation defensive + if (sizeTmp > taille_table_temp) & + call XABORT("G2S : memory problem in addSegsAndClean (1)") + tmpTab(sizeTmp)%keep=.true. ; tmpTab(sizeTmp)%sa=sgj + tmpTab(j)%sa%dx=sgi%x ; tmpTab(j)%sa%dy=sgi%y + tmpTab(sizeTmp)%sa%x=sgi%dx ; tmpTab(sizeTmp)%sa%y=sgi%dy + case(1) !origines confondues et sgi dans sgj + call adjustMix(tmpTab(i)%sa,sgj) + tmpTab(j)%sa%x=sgi%dx ; tmpTab(j)%sa%y=sgi%dy + case(2) !sgi et sgj s'intersectent reellement (sgj au dessus) + sizeTmp=sizeTmp+1 + ! pour programmation defensive + if (sizeTmp > taille_table_temp) & + call XABORT("G2S : memory problem in addSegsAndClean (2)") + tmpTab(sizeTmp)%keep=.true. ; tmpTab(sizeTmp)%sa=sgi + tmpTab(i)%sa%dx=sgj%x ; tmpTab(i)%sa%dy=sgj%y + tmpTab(sizeTmp)%sa%x=sgj%x ; tmpTab(sizeTmp)%sa%y=sgj%y + tmpTab(sizeTmp)%sa%dx=sgi%dx ; tmpTab(sizeTmp)%sa%dy=sgi%dy + call adjustMix(tmpTab(sizeTmp)%sa,sgj) + tmpTab(j)%sa%x=sgi%dx ; tmpTab(j)%sa%y=sgi%dy + end select + case(2) !seuls cas 0,1,2 utiles pour oj + select case(oj) + case(0) !sgi et sgj s'intersectent reellement (sgj en dessous) + sizeTmp=sizeTmp+1 + ! pour programmation defensive + if (sizeTmp > taille_table_temp) & + call XABORT("G2S : memory problem in addSegsAndClean (3)") + tmpTab(sizeTmp)%keep=.true. ; tmpTab(sizeTmp)%sa=sgi + tmpTab(i)%sa%x=sgj%dx ; tmpTab(i)%sa%y=sgj%dy + tmpTab(sizeTmp)%sa%x=sgi%x ; tmpTab(sizeTmp)%sa%y=sgi%y + tmpTab(sizeTmp)%sa%dx=sgj%dx ; tmpTab(sizeTmp)%sa%dy=sgj%dy + call adjustMix(tmpTab(sizeTmp)%sa,sgj) + tmpTab(j)%sa%dx=sgi%x ; tmpTab(j)%sa%dy=sgi%y + case(1) !origines confondues et sgj dans sgi + call adjustMix(tmpTab(j)%sa,sgi) + tmpTab(i)%sa%x=sgj%dx ; tmpTab(i)%sa%y=sgj%dy + case(2) !sgj dans sgi + call adjustMix(tmpTab(j)%sa,sgi) + sizeTmp=sizeTmp+1 + ! pour programmation defensive + if (sizeTmp > taille_table_temp) & + call XABORT("G2S : memory problem in addSegsAndClean (4)") + tmpTab(sizeTmp)%keep=.true. ; tmpTab(sizeTmp)%sa=sgi + tmpTab(i)%sa%dx=sgj%x ; tmpTab(i)%sa%dy=sgj%y + tmpTab(sizeTmp)%sa%x=sgj%dx ; tmpTab(sizeTmp)%sa%y=sgj%dy + end select + case(3) !seuls cas 0,1,2 utiles pour oj + select case(oj) + case(0) !extremites confondues et sgi dans sgj + call adjustMix(tmpTab(i)%sa,sgj) + tmpTab(j)%sa%dx=sgi%x ; tmpTab(j)%sa%dy=sgi%y + case(1) !sgi et sgj confondus + call adjustMix(tmpTab(i)%sa,sgj) + tmpTab(j)%keep=.false. + case(2) !extremites confondues et sgj dans sgi + call adjustMix(tmpTab(j)%sa,sgi) + tmpTab(i)%sa%dx=sgj%x ; tmpTab(i)%sa%dy=sgj%y + end select + end select + end do + end do + + do i = 1,sizeTmp + if (tmpTab(i)%keep) then + if (tmpTab(i)%sa%typ==tseg) then + if (isEqual(tmpTab(i)%sa%x,tmpTab(i)%sa%dx).and. & + isEqual(tmpTab(i)%sa%y,tmpTab(i)%sa%dy)) tmpTab(i)%keep=.false. + end if + end if + end do + + !recopie dans le tableau global des elements a conserver + sizeSA=0 + do i = 1,sizeTmp + if (tmpTab(i)%keep) then + sizeSA=sizeSA+1 + ! pour programmation defensive + if (sizeSA > taille_table_tabSegArc) & + call XABORT("G2S : memory problem in addSegsAndClean (5)") + tabSegArc(sizeSA) = tmpTab(i)%sa + end if + end do + deallocate(tmpTab) + + end subroutine addSegsAndClean + + subroutine cutClusters(nbRing,nbClus,szSa) + integer,intent(in) :: nbRing,nbClus + integer,intent(inout) :: szSa + + integer :: i,j,szTmp,nbInter + double precision :: aClus,bClus,aRing,bRing + logical :: revert,eqA,eqB + type(t_segArc) :: ring,clus + type(segArcArrayTer),dimension(:),allocatable :: tmpTabAr + + ! pour programmation defensive + integer :: taille_table_temp + + taille_table_temp = nbRing*nbClus*4 !ca me semble suffisant (note de l'auteur ) + allocate(tmpTabAr(taille_table_temp),stat=alloc_ok) + if (alloc_ok /= 0) call XABORT("G2S: cutCluster(1) => allocation pb") + szTmp = 0 + + !initialisation du tableau temporaire + !recopie des cluster et des anneaux dans l'ordre inverse de leur + !creation => du plus grand vers le plus petit + do i = 1,nbClus + szTmp = szTmp + 1 + tmpTabAr(szTmp)%keep = .true. + tmpTabAr(szTmp)%cl = .true. + tmpTabAr(szTmp)%sa = tabSegArc(szSa) + szSa = szSa - 1 + end do + do i = 1,nbRing + szTmp = szTmp + 1 + tmpTabAr(szTmp)%keep = .true. + tmpTabAr(szTmp)%cl = .false. + tmpTabAr(szTmp)%sa = tabSegArc(szSa) + szSa = szSa - 1 + end do + + i=0 + do + i = i+1 + if (i>szTmp) exit + if (.not. (tmpTabAr(i)%keep .and. tmpTabAr(i)%cl)) cycle + clus = tmpTabAr(i)%sa + j = 0 + do + j = j+1 + if (j>szTmp) exit + if ((.not. tmpTabAr(j)%keep) .or. tmpTabAr(j)%cl) cycle + ring = tmpTabAr(j)%sa + nbInter = interArcArc(clus,ring,aClus,bClus,aRing,bRing,revert) + select case(nbInter) + case(2) + if (clus%typ==tcer) then + !demi cercle interieur + tmpTabAr(i)%sa%typ = tarc + tmpTabAr(i)%sa%mixd = ring%mixg + tmpTabAr(i)%sa%a = aClus + tmpTabAr(i)%sa%b = bClus + clus = tmpTabAr(i)%sa + !demi cercle exterieur + szTmp = szTmp + 1 + ! programmation defensive + if (sztmp > taille_table_temp) & + call XABORT("G2S : memory problem in routine cutClusters (1)") + tmpTabAr(szTmp)%keep = .true. + tmpTabAr(szTmp)%cl = .true. + tmpTabAr(szTmp)%sa = clus + tmpTabAr(szTmp)%sa%mixd = ring%mixd + tmpTabAr(szTmp)%sa%a = bClus + tmpTabAr(szTmp)%sa%b = aClus + else + eqA = isEqualAngl(clus%a,aClus) + eqB = isEqualAngl(clus%b,bClus) + !debut + if (.not.eqA) then + szTmp = szTmp + 1 + ! programmation defensive + if (sztmp > taille_table_temp) & + call XABORT("G2S : memory problem in routine cutClusters (2)") + tmpTabAr(szTmp)%keep = .true. + tmpTabAr(szTmp)%cl = .true. + tmpTabAr(szTmp)%sa = clus + tmpTabAr(szTmp)%sa%mixd = ring%mixd + tmpTabAr(szTmp)%sa%b = aClus + end if + !fin + if (.not.eqB) then + szTmp = szTmp + 1 + ! programmation defensive + if (sztmp > taille_table_temp) & + call XABORT("G2S : memory problem in routine cutClusters (3)") + tmpTabAr(szTmp)%keep = .true. + tmpTabAr(szTmp)%cl = .true. + tmpTabAr(szTmp)%sa = clus + tmpTabAr(szTmp)%sa%mixd = ring%mixd + tmpTabAr(szTmp)%sa%a = bClus + end if + !milieu + if ((.not.eqA).or.(.not.eqB)) then + tmpTabAr(i)%sa%a = aClus + tmpTabAr(i)%sa%b = bClus + tmpTabAr(i)%sa%mixd = ring%mixg + clus = tmpTabAr(i)%sa + end if + end if + if (ring%typ==tcer) then + tmpTabAr(j)%sa%typ = tarc + tmpTabAr(j)%sa%a = bRing + tmpTabAr(j)%sa%b = aRing + ring = tmpTabAr(j)%sa + else + tmpTabAr(j)%keep = .false. + eqA = isEqualAngl(ring%a,aRing) + eqB = isEqualAngl(ring%b,bRing) + !premier bout d'arc + if (.not.eqA) then + szTmp = szTmp + 1 + ! programmation defensive + if (sztmp > taille_table_temp) & + call XABORT("G2S : memory problem in routine cutClusters (4)") + tmpTabAr(szTmp)%keep = .true. + tmpTabAr(szTmp)%cl = .false. + tmpTabAr(szTmp)%sa = ring + tmpTabAr(szTmp)%sa%b = aRing + end if + !second bout d'arc + if (.not.eqB) then + szTmp = szTmp + 1 + ! programmation defensive + if (sztmp > taille_table_temp) & + call XABORT("G2S : memory problem in routine cutClusters (5)") + tmpTabAr(szTmp)%keep = .true. + tmpTabAr(szTmp)%cl = .false. + tmpTabAr(szTmp)%sa = ring + tmpTabAr(szTmp)%sa%a = bRing + end if + end if + case(1) + !a priori, tel que l'algo est fait, le cas ne se produit que si + !le cluster est tangent a un anneau + !travail sur l'anneau + if (ring%typ==tcer) then + tmpTabAr(j)%sa%typ = tarc + tmpTabAr(j)%sa%a = aRing + tmpTabAr(j)%sa%b = aRing + ring = tmpTabAr(j)%sa + else + tmpTabAr(j)%keep = .false. + eqA = isEqualAngl(ring%a,aRing) + eqB = isEqualAngl(ring%b,aRing) + !premier bout d'arc + if (.not.eqA) then + szTmp = szTmp + 1 + ! programmation defensive + if (sztmp > taille_table_temp) & + call XABORT("G2S : memory problem in routine cutClusters (6)") + tmpTabAr(szTmp)%keep = .true. + tmpTabAr(szTmp)%cl = .false. + tmpTabAr(szTmp)%sa = ring + tmpTabAr(szTmp)%sa%b = aRing + end if + !second bout d'arc + if (.not.eqB) then + szTmp = szTmp + 1 + ! programmation defensive + if (sztmp > taille_table_temp) & + call XABORT("G2S : memory problem in routine cutClusters (7)") + tmpTabAr(szTmp)%keep = .true. + tmpTabAr(szTmp)%cl = .false. + tmpTabAr(szTmp)%sa = ring + tmpTabAr(szTmp)%sa%a = aRing + end if + end if + !travail sur le cluster + if (clus%typ==tcer) then + tmpTabAr(i)%sa%typ = tarc + tmpTabAr(i)%sa%a = aClus + tmpTabAr(i)%sa%b = aClus + clus = tmpTabAr(i)%sa + if (revert) then !cluster a l'exterieur de l'anneau + tmpTabAr(i)%sa%mixd = ring%mixd + else !cluster a l'interieur de l'anneau + tmpTabAr(i)%sa%mixd = ring%mixg + end if + else ! le cluster a deja ete coupe => tangence exterieur + ! et derniere utilisation + eqA = isEqualAngl(clus%a,aClus) + eqB = isEqualAngl(clus%b,aClus) + !debut + if (.not.eqA) then + szTmp = szTmp + 1 + ! programmation defensive + if (sztmp > taille_table_temp) & + call XABORT("G2S : memory problem in routine cutClusters (8)") + tmpTabAr(szTmp)%keep = .true. + tmpTabAr(szTmp)%cl = .true. + tmpTabAr(szTmp)%sa = clus + tmpTabAr(szTmp)%sa%mixd = ring%mixd + tmpTabAr(szTmp)%sa%b = aClus + end if + !fin + if (.not.eqB) then + szTmp = szTmp + 1 + ! programmation defensive + if (sztmp > taille_table_temp) & + call XABORT("G2S : memory problem in routine cutClusters (9)") + tmpTabAr(szTmp)%sa%a = aClus + tmpTabAr(szTmp)%sa = clus + tmpTabAr(szTmp)%sa%mixd = ring%mixd + tmpTabAr(szTmp)%sa%a = aClus + end if + !milieu + if ((.not.eqA).or.(.not.eqB)) then + tmpTabAr(i)%keep = .false. + i = 0 + end if + end if + + end select + end do + end do + !recopie des resultats + do i = 1,szTmp + if (.not. tmpTabAr(i)%keep) cycle + szSa = szSa + 1 + tabSegArc(szSa) = tmpTabAr(i)%sa + end do + deallocate(tmpTabAr) + end subroutine cutClusters + + logical function segWithSameCoord(S1,S2,n) + type(t_segArc), intent(in) :: S1, S2 + integer, intent(out) :: n + + segWithSameCoord = .false. ; n=0 + if (isEqualConst(S1%x,S2%x)) then + if (isEqualConst(S1%dx,S2%dx)) then + if (isEqualConst(S1%y,S2%y)) then + if (isEqualConst(S1%dy,S2%dy)) then + segWithSameCoord = .true. ; n=1 + endif + endif + endif + elseif (isEqualConst(S1%x,S2%dx)) then + if (isEqualConst(S1%dx,S2%x)) then + if (isEqualConst(S1%y,S2%dy)) then + if (isEqualConst(S1%dy,S2%y)) then + segWithSameCoord = .true. ; n=-1 + endif + endif + endif + endif + end function segWithSameCoord + + subroutine PrintTabSegArc(szSA) + integer, intent(in) :: szSA + type(t_segArc) :: sa + integer :: i + + write(*,10) szSA + + do i = 1, szSA + sa = tabSegArc(i) + if (sa%typ == tseg) then + write(*,20) i, sa%x, sa%y, sa%dx, sa%dy + elseif (sa%typ == tarc) then + write(*,30) i, sa%x, sa%y, sa%r, sa%a, sa%b + elseif (sa%typ == tcer) then + write(*,35) i, sa%x, sa%y, sa%r + else + write(*,38) i, sa%typ, sa%x, sa%y + endif + write(*,40) sa%sectg, sa%sectd + write(*,50) sa%mixg, sa%mixd + write(*,60) sa%nodeg, sa%noded + write(*,70) sa%indcellpg, sa%indcellpd + write(*,80) sa%neutronicMixg,sa%neutronicMixd + enddo + +10 format("Number of SegArc :", i4) +20 format("N. SegArc ", i6," segment type : ",/, & + "|-> origin/extrem : (", f7.4, ";", f7.4,")/(", f7.4, ";", f7.4,")") +30 format("N. SegArc ", i6," arc type:",/, & + "|-> center/radius/angles : (", f7.4,";",f7.4,")/", f7.4,"/",f7.4,";", f7.4) +35 format("N. SegArc ", i6," circle type :",/, & + "|-> center/radius : (", f7.4,";",f7.4,")/", f7.4) +38 format("N. SegArc ", i6," unknown type :",/, & + "|-> type/origin/ : (", i6,"/",f7.4,";",f7.4,")") +40 format( "|-> sectg sectd : ", i6,2x,i6) +50 format( "|-> mixg mixd : ", i6,2x,i6) +60 format( "|-> nodeg noded : ", i6,2x,i6) +70 format( "|-> IndCellPg IndCellPd : ", i6,2x,i6) +80 format( "|-> neutronicMixg neutronicMixd : ", i6,2x,i6) + end subroutine PrintTabSegArc + + subroutine PrintSegArc1(i) + integer, intent(in) ::i + type(t_segArc) :: sa + + sa = tabSegArc(i) + if (sa%typ == tseg) then + write(*,20) i, sa%x, sa%y, sa%dx, sa%dy + elseif (sa%typ == tarc) then + write(*,30) i, sa%x, sa%y, sa%r, sa%a, sa%b + elseif (sa%typ == tcer) then + write(*,35) i, sa%x, sa%y, sa%r + else + write(*,38) i, sa%typ, sa%x, sa%y + endif + write(*,40) sa%sectg, sa%sectd + write(*,50) sa%mixg, sa%mixd + write(*,60) sa%nodeg, sa%noded + write(*,70) sa%indcellpg, sa%indcellpd + write(*,80) sa%neutronicMixg,sa%neutronicMixd + +20 format("N. SegArc ", i6," segment type : ",/, & + "|-> origin/extrem : (", f7.4, ";", f7.4,")/(", f7.4, ";", f7.4,")") +30 format("N. SegArc ", i6," arc type:",/, & + "|-> center/radius/angles : (", f7.4,";",f7.4,")/", f7.4,"/",f7.4,";", f7.4) +35 format("N. SegArc ", i6," circle type :",/, & + "|-> center/radius : (", f7.4,";",f7.4,")/", f7.4) +38 format("N. SegArc ", i6," unknown type :",/, & + "|-> type/origin/ : (", i6,"/",f7.4,";",f7.4,")") +40 format( "|-> sectg sectd : ", i6,2x,i6) +50 format( "|-> mixg mixd : ", i6,2x,i6) +60 format( "|-> nodeg noded : ", i6,2x,i6) +70 format( "|-> IndCellPg IndCellPd : ", i6,2x,i6) +80 format( "|-> neutronicMixg neutronicMixd : ", i6,2x,i6) + + end subroutine PrintSegArc1 + + subroutine PrintSegArc2(sa) + type(t_segArc), intent(in) :: sa + + if (sa%typ == tseg) then + write(*,20) sa%x, sa%y, sa%dx, sa%dy + elseif (sa%typ == tarc) then + write(*,30) sa%x, sa%y, sa%r, sa%a, sa%b + elseif (sa%typ == tcer) then + write(*,35) sa%x, sa%y, sa%r + else + write(*,38) sa%typ, sa%x, sa%y + endif + write(*,40) sa%sectg, sa%sectd + write(*,50) sa%mixg, sa%mixd + write(*,60) sa%nodeg, sa%noded + write(*,70) sa%indcellpg, sa%indcellpd + write(*,80) sa%neutronicMixg,sa%neutronicMixd + +20 format(" Segment type : ",/, & + "|-> origin/extrem : (", f7.4, ";", f7.4,")/(", f7.4, ";", f7.4,")") +30 format(" Arc type:",/, & + "|-> center/radius/angles : (", f7.4,";",f7.4,")/", f7.4,"/",f7.4,";", f7.4) +35 format("Circle type :",/, & + "|-> center/radius : (", f7.4,";",f7.4,")/", f7.4) +38 format("unknown type :",/, & + "|-> type/origin/ : (", i6,"/",f7.4,";",f7.4,")") +40 format( "|-> sectg sectd : ", i6,2x,i6) +50 format( "|-> mixg mixd : ", i6,2x,i6) +60 format( "|-> nodeg noded : ", i6,2x,i6) +70 format( "|-> IndCellPg IndCellPd : ", i6,2x,i6) +80 format( "|-> neutronicMixg neutronicMixd : ", i6,2x,i6) + + end subroutine PrintSegArc2 + + + +end module segArc diff --git a/Dragon/src/g2s_unfold.f90 b/Dragon/src/g2s_unfold.f90 new file mode 100644 index 0000000..d116bea --- /dev/null +++ b/Dragon/src/g2s_unfold.f90 @@ -0,0 +1,65 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Unfold the geometry. +! +!Copyright: +! Copyright (C) 2020 Ecole Polytechnique de Montreal. +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): +! A. Hebert +! +!----------------------------------------------------------------------- +! +subroutine g2s_unfold(geoIp,impx) + use GANLIB + use constType + type(c_ptr),intent(in) :: geoIp + integer,intent(in) :: impx + ! + integer,parameter :: nstate=40 + integer,dimension(nstate) :: st + integer,allocatable,dimension(:) :: idp,ind1,ind2 + ! + call LCMGET(geoIp,'STATE-VECTOR',st) + select case(st(1)) + case(G_Hex) + call LCMLIB(geoIp) + call LCMGET(geoIp,'IHEX ',iHex) + lxold=st(6) + if((iHex /= 9).and.(lxold > 1)) then + call LCMLEN(geoIp,'TURN ',ilong,itylcm) + if(ilong > 0) call XABORT('g2s_unfold: TURN not supported.') + ! caution: HEXCEL cells are not rotated according to symmetries in BIVALL + maxpts=12*lxold + allocate(idp(maxpts)) + call BIVALL(maxpts,iHex,lxold,lx,idp) + if(impx > 0) write(*,*) 'g2s_unfold: nb of hexagons=',lxold,'-->',lx + allocate(ind1(lxold),ind2(lx)) + call LCMGET(geoIp,'MIX ',ind1) + do i=1,lx + ind2(i)=ind1(idp(i)) + enddo + call LCMPUT(geoIp,'MIX ',lx,1,ind2) + call LCMLEN(geoIp,'MERGE ',ilong,itylcm) + if(ilong > 0) then + call LCMGET(geoIp,'MERGE ',ind1) + do i=1,lx + ind2(i)=ind1(idp(i)) + enddo + call LCMPUT(geoIp,'MERGE ',lx,1,ind2) + endif + deallocate(ind2,ind1,idp) + st(3)=lx + st(6)=lx + call LCMPUT(geoIp,'STATE-VECTOR',nstate,1,st) + iHex=9 + call LCMPUT(geoIp,'IHEX ',1,1,iHex) + endif + end select +end subroutine g2s_unfold diff --git a/Dragon/src/sdbm.c b/Dragon/src/sdbm.c new file mode 100644 index 0000000..867eee9 --- /dev/null +++ b/Dragon/src/sdbm.c @@ -0,0 +1,482 @@ +/* + * $Id: sdbm.c,v 1.10 1997/05/21 20:47:59 laughton Exp laughton $ + * + *--------------------------------------------------------------------------- + * + * Peter J. Laughton + * AECL + * Chalk River Laboratories + * Chalk River, Ontario + * CANADA K0J 1J0 + * + * Phone: (613) 584-8811, extension 4267 + * FAX: (613) 584-1108 + * + * Internet: laughtonp@crl.aecl.ca + * + *--------------------------------------------------------------------------- + * + * Revision history (as of 1995 October 25): + * + * $Log: sdbm.c,v $ + * Revision 1.11 99/03/11 17:03:56 17:03:56 laughton + * proper type-dependent calloc calls now used + * + * Revision 1.10 1997/05/21 20:47:59 laughton + * maximum number of records in one file doubled + * + * Revision 1.9 1996/12/19 19:34:56 laughton + * Intel-x86/Windows95 support added (the list sep is a ';', not a ':') + * + * Revision 1.8 1996/06/28 13:04:34 laughton + * support for NDAS file conversion started + * + * Revision 1.7 1995/12/12 22:21:27 laughton + * more GDBM updates + * + * Revision 1.6 1995/12/07 20:10:45 laughton + * minor SGI compiler warnings rectified + * + * Revision 1.5 1995/12/05 21:08:47 laughton + * emitTitle bug fixed. + * + * Revision 1.4 1995/12/04 14:46:12 laughton + * continuing development + * + * Revision 1.3 1995/12/01 21:27:19 laughton + * more error handling and identification of library titles + * + * Revision 1.2 1995/11/30 20:22:37 laughton + * continuing development + * + * Revision 1.1 1995/11/07 16:32:06 laughton + * Initial revision + * + */ + +#include +#include +#include +#include "sdbm.h" + +#define MAXKEYLENGTH 64 +#define StringTypeC 8 +#define MAKE_ARRAY(thing,number) \ + ((thing *) calloc((unsigned) (number),sizeof(thing))) + +static int magicNumber=0x198802ab; /* file-type marker */ + +typedef struct { + char key[MAXKEYLENGTH+1]; /* string of printable characters */ + int dataType; /* numeric flag indicating real, integer, etc */ + int size; /* in bytes */ + int dataOffset; /* from the beginning of the file */ +} HeaderElement; + +typedef struct { + char *filename; + FILE *filePointer; + int nValidRecords; /* > 0 means active */ + HeaderElement *header; +} SDBFile; + +#define size_HE (sizeof(HeaderElement)) + +#define MAXDBFILES 10 +#define MAXFNLENGTH 100 +static SDBFile dbFile[MAXDBFILES]; +static int dbfCount=0; + +static int initReadF=0; + +/* =============================================== */ +/* Prototypes of static functions appearing below: */ +/* =============================================== */ + +static int installDBF(char *filename); +static int compareHeaderElements(const void *h1, const void *h2); +static int searchHeader(HeaderElement *header, char *searchKey, int n); + +/* =============================================== */ + +int initRead(char *flist) { + int i; + char nbuf[MAXFNLENGTH+1]; + int fc, lc; + int retval; + char flistSep; + +#ifdef PC_TargetCPU + flistSep=';'; +#else + flistSep=':'; +#endif + + initReadF=1; + + for (i=0; i MAXFNLENGTH) + return FixedLimitExceeded; + + strncpy(nbuf, flist+fc, lc-fc); + nbuf[lc-fc]='\0'; + retval=installDBF(nbuf); + + if (retval) + return retval; /* non-zero is an error code */ + + fc=lc; + } + + emitTitles(); + return 0; /* success */ +} + +int countRecs(int *nRecs, int dbFileIndex) { + *nRecs=0; + if (dbFileIndex < 0 || dbFileIndex > MAXDBFILES-1) + return BadFile; + + *nRecs=dbFile[dbFileIndex].nValidRecords; + return 0; /* success */ +} + +static int installDBF(char *filename) { + int mn=0; + int i; + + /* Later, add a check to make sure this is not a new file. */ + + if (dbfCount >= MAXDBFILES) + return FixedLimitExceeded; + + dbFile[dbfCount].filename=strdup(filename); + if (!dbFile[dbfCount].filename) + return MemoryAllocFailure; + + dbFile[dbfCount].filePointer=fopen(filename,"rb"); + if (!dbFile[dbfCount].filePointer) + return OpenFailure; + + /* Check that the magic number is present. */ + if(fread(&mn,sizeof(int),1,dbFile[dbfCount].filePointer) < 1) goto L10; + if (mn!=magicNumber) + return BadFile; + + if(fread(&dbFile[dbfCount].nValidRecords, sizeof(int), 1, + dbFile[dbfCount].filePointer) < 1) goto L10; + + dbFile[dbfCount].header=MAKE_ARRAY(HeaderElement, + dbFile[dbfCount].nValidRecords); + if (!dbFile[dbfCount].header) + return MemoryAllocFailure; + + /* Load the header into memory (for now) */ + for (i=0; i < dbFile[dbfCount].nValidRecords; i++) + if(fread(&dbFile[dbfCount].header[i], size_HE, 1, + dbFile[dbfCount].filePointer) < 1) goto L10; + + dbfCount++; + return 0; /* success */ +L10: + printf("\n XSDB error 1: fread failure -- %s\n",filename); + fflush(stdout); + exit(1); +} + +static int compareHeaderElements(const void *h1, const void *h2) { + return strcmp(((HeaderElement *)h1)->key, ((HeaderElement *)h2)->key); +} + +void closeSDBRead() { + int i,irc; + + for (i=0; i= l) { + midPoint=(l+u)/2; /* floor results automatically */ + sign=strcmp(searchKey,header[midPoint].key); + + if (sign < 0) + u=midPoint-1; + else if (sign > 0) + l=midPoint+1; + else + return midPoint; + } + + return FAIL; +} + +datum readRecord(char *recordName) { + + int keyIndex; + datum record; + int nbytes; + int i; + int found=0; + + /* Failure is indicated if these values remain intact on exit. */ + record.dptr=0; + record.dsize=0; + + if (!initReadF) + return record; + + for (i=0; i> 2, 4); + + if (!record.dptr) + return record; + + record.dsize=nbytes; + + /* Jump to the location in the file and read the record into memory. */ + fseek(dbFile[i].filePointer, dbFile[i].header[keyIndex].dataOffset, SEEK_SET); + if(fread((char*)record.dptr, 1, nbytes, dbFile[i].filePointer) < 1) goto L10; + + return record; +L10: + printf("\n XSDB error: fread failure 2 -- %s\n",recordName); + fflush(stdout); + exit(1); +} + +datum readIndexedRecord(int keyIndex, int dbFileIndex, char *recordKey, int *dataType) { + + datum record; + int nbytes; + + /* Failure is indicated if these values remain intact on exit. */ + record.dptr=0; + record.dsize=0; + + if (dbFileIndex < 0 || dbFileIndex > MAXDBFILES-1) + return record; + + if (!initReadF) + return record; + + if (keyIndex >= dbFile[dbFileIndex].nValidRecords) + return record; + + strcpy(recordKey, dbFile[dbFileIndex].header[keyIndex].key); + *dataType=dbFile[dbFileIndex].header[keyIndex].dataType; + + nbytes=dbFile[dbFileIndex].header[keyIndex].size; + + if (*dataType == StringTypeC) + record.dptr=calloc(nbytes, 1); + else + record.dptr=calloc(nbytes >> 2, 4); + + if (!record.dptr) + return record; + + record.dsize=nbytes; + + /* Jump to the location in the file and read the record into memory. */ + fseek(dbFile[dbFileIndex].filePointer, + dbFile[dbFileIndex].header[keyIndex].dataOffset, + SEEK_SET); + + if(fread((char*)record.dptr, 1, nbytes, dbFile[dbFileIndex].filePointer) < 1) goto L10; + + return record; +L10: + printf("\n XSDB error: fread failure 3 -- %s\n",recordKey); + fflush(stdout); + exit(1); +} + +void emitTitles() { + int keyIndex; + datum record; + int i; + + for (i=0; i MAXKEYLENGTH) + return InvalidKey; + + strcat(header[writeRecordIndex].key,recordName); + header[writeRecordIndex].dataType=dataType; + header[writeRecordIndex].size=nbytes; + + header[writeRecordIndex].dataOffset=nextDataOffset; + offset=nbytes; + fseek(sdbFile,offset,SEEK_END); /* extend the file */ + fseek(sdbFile,nextDataOffset,SEEK_SET); /* position for write */ + fwrite((char*)data, 1, nbytes, sdbFile); + + writeRecordIndex++; + nextDataOffset+=offset; + + return 0; +} diff --git a/Dragon/src/sdbm.h b/Dragon/src/sdbm.h new file mode 100644 index 0000000..4c90653 --- /dev/null +++ b/Dragon/src/sdbm.h @@ -0,0 +1,80 @@ +/* + * + * $Id: sdbm.h,v 1.5 1995/12/12 22:21:27 laughton Exp laughton $ + * + *--------------------------------------------------------------------------- + * + * Peter J. Laughton + * AECL + * Chalk River Laboratories + * Chalk River, Ontario + * CANADA K0J 1J0 + * + * Phone: (613) 584-8811, extension 4267 + * FAX: (613) 584-1108 + * + * Internet: laughtonp@crl.aecl.ca + * + *--------------------------------------------------------------------------- + * + * Revision history (as of 1995 October 25): + * + * $Log: sdbm.h,v $ + * Revision 1.6 96/06/28 13:10:19 13:10:19 laughton + * support for NDAS file conversion started. + * + * Revision 1.5 1995/12/12 22:21:27 laughton + * more GDBM updates + * + * Revision 1.4 1995/12/12 19:59:38 laughton + * updated the GDBM routines + * + * Revision 1.3 1995/12/04 14:46:47 laughton + * continuing development + * + * Revision 1.2 1995/11/30 20:48:03 laughton + * merged with main trunk + * + * Revision 1.1.1.2 1995/11/30 20:31:40 laughton + * continuing development + * + * Revision 1.1.1.1 1995/11/07 16:41:01 laughton + * side-branch for experiment + * + * Revision 1.1 1995/11/07 16:32:06 laughton + * Initial revision + * + */ + +#define FAIL (-1) +#define FileFull 1 +#define InvalidKey 2 +#define OpenFailure 3 +#define BadFile 4 +#define MemoryAllocFailure 5 +#define FixedLimitExceeded 6 + +typedef struct { + char *dptr; + int dsize; +} datum; + +extern void closeSDBWrite(); + +extern void closeSDBRead(); + +extern int writeRecord(char *recordName, + void *data, int nbytes, int dataType); + +extern int initRead(char *flist); + +extern int countRecs(int *nRecs, int dbFile); + +extern int initWrite(); + +extern datum readRecord(char *recordName); + +extern datum readIndexedRecord(int keyIndex, int dbFileIndex, + char *recordKey, int *dataType); + +extern void emitTitles(); diff --git a/Dragon/src/xsdb-defs.h b/Dragon/src/xsdb-defs.h new file mode 100644 index 0000000..2260bbf --- /dev/null +++ b/Dragon/src/xsdb-defs.h @@ -0,0 +1,46 @@ +#define BickleyFunctionTablesKi3 1001 +#define BickleyFunctionTablesKi35 1002 + +#define BurnCount 5001 +#define BurnInteger 5002 +#define BurnReal 5003 +#define Absorption 5004 +#define Fission 5005 +#define NuFission 5006 +#define N2n 5007 +#define FissionSpectrum 5008 +#define PotScatSlowingDown 5009 +#define LengthsThermalP0 5010 +#define FastResTransport 5011 +#define GCLambda 5012 +#define Transport 5013 +#define LengthsScatP1 5014 +#define ScatP0 5015 +#define ScatP1 5016 +#define ThermalXSTemp 5017 +#define ThermalP1Temp 5018 +#define GroupBoundaries 5019 +#define PotScat 5020 +#define NJOYFlux 5021 +#define Hequivalence 5022 +#define HeqHeader 5023 +#define TransportCorrection 5024 + +#define NoGroup 7000 +#define Fast 7001 +#define FastRes 7002 +#define Res 7003 +#define Thermal 7004 + +#define Header 6001 +#define ResHeader 6002 + +#define NORMAL 0 +#define OPEN_FAILURE 10 +#define RECORD_NOT_FOUND 11 +#define RECORD_INDEX_OVERFLOW 90 + +#define UnknownRequest 1 +#define UnknownNuclide 2 + +#define LastNuclideAccessed (-1) diff --git a/Dragon/src/xsdbops-sdbm.c b/Dragon/src/xsdbops-sdbm.c new file mode 100644 index 0000000..bbf21a8 --- /dev/null +++ b/Dragon/src/xsdbops-sdbm.c @@ -0,0 +1,184 @@ +/* + * $Id: xsdbops-sdbm.c,v 1.4 1995/12/12 22:21:27 laughton Exp laughton $ + * + *--------------------------------------------------------------------------- + * + * Peter J. Laughton + * AECL + * Chalk River Laboratories + * Chalk River, Ontario + * CANADA K0J 1J0 + * + * Phone: (613) 584-8811, extension 4267 + * FAX: (613) 584-1108 + * + * Internet: laughtonp@crl.aecl.ca + * + *--------------------------------------------------------------------------- + * + * Revision history (as of 1995 October 25): + * + * $Log: xsdbops-sdbm.c,v $ + * Revision 1.5 96/06/28 13:04:34 13:04:34 laughton + * support for NDAS file conversion started + * + * Revision 1.4 1995/12/12 22:21:27 laughton + * more GDBM updates + * + * Revision 1.3 1995/12/04 14:46:02 laughton + * continuing development + * + * Revision 1.2 1995/11/30 20:26:36 laughton + * XSDB files now opened in this file + * + * Revision 1.1 1995/11/07 16:36:31 laughton + * Initial revision + * + */ + +#include +#include +#include +#include "xsdbops.h" +#include "sdbm.h" + +#define KEYBUFSIZE 200 +static char keybuf[KEYBUFSIZE]; + +static datum key; + +void xsdbReadInit(char *flist, int *status) { + key.dptr=keybuf; /* use the same buffer for all keys */ + *status=initRead(flist); +} + +int xsdbCountRecs(int *status, int dbFileIndex) { + int n; + *status=countRecs(&n,dbFileIndex); + return n; +} + +void xsdbWriteInit(int *status) { + key.dptr=keybuf; /* use the same buffer for all keys */ + *status=initWrite(); +} + +void xsdbCloseWrite() { + closeSDBWrite(); +} + +void formItemKey(char *itemName) { + strcpy(key.dptr,itemName); + key.dsize=strlen(key.dptr)+1; +} + +void formNuclideItemKey(char *nuclideName, char *itemName) { + strcpy(key.dptr,nuclideName); + strcat(key.dptr,"/"); + strcat(key.dptr,itemName); + key.dsize=strlen(key.dptr)+1; +} + +void formNuclideTempItemKey(char *nuclideName, char *itemName, float temp) { + int endOffset; + strcpy(key.dptr,nuclideName); + strcat(key.dptr,"/"); + strcat(key.dptr,itemName); + strcat(key.dptr,"/"); + endOffset=strlen(key.dptr); + sprintf(key.dptr+endOffset,"%.2f",temp); + key.dsize=strlen(key.dptr)+1; +} + +void formNuclideGroupItemKey(char *nuclideName, char *itemName, int g) { + int endOffset; + strcpy(key.dptr,nuclideName); + strcat(key.dptr,"/"); + strcat(key.dptr,itemName); + strcat(key.dptr,"/"); + endOffset=strlen(key.dptr); + sprintf(key.dptr+endOffset,"G%d",g); + key.dsize=strlen(key.dptr)+1; +} + + + +void xsdbStoreItem(char *itemName, void *from, + int nbytes, int dataType, int verbose) { + + int failure; + + formItemKey(itemName); + failure=writeRecord(key.dptr, from, nbytes, dataType); + if (failure) { + fprintf(stderr,"error in xsdbStoreItem()\n"); + exit(1); + } + if (verbose) + printf("Wrote SDBM record with length %6d bytes, type code %3d -- %s\n", + nbytes, dataType, key.dptr); +} + +void xsdbStoreNuclideItem(char *nuclideName, + char *itemName, void *from, int nbytes, + int dataType, int verbose) { + + formNuclideItemKey(nuclideName,itemName); + xsdbStoreItem(keybuf,from,nbytes,dataType,verbose); +} + +void xsdbStoreNuclideTempItem(char *nuclideName, + char *itemName, float temp, void *from, + int nbytes, int dataType, int verbose) { + + formNuclideTempItemKey(nuclideName,itemName,temp); + xsdbStoreItem(keybuf,from,nbytes,dataType,verbose); +} + +void xsdbStoreNuclideGroupItem(char *nuclideName, + char *itemName, int g, void *from, int nbytes, + int dataType, int verbose) { + + formNuclideGroupItemKey(nuclideName,itemName,g); + xsdbStoreItem(keybuf,from,nbytes,dataType,verbose); +} + +/* ~~~~~~~~~~~~~~~~~~ */ +/* Retrieval Routines */ +/* ~~~~~~~~~~~~~~~~~~ */ + +/* The following routines make no check as to whether a record with + the specified key data exists, and run-time failure will result if + no such record is found. */ + +void *xsdbRetrieveItem(char *itemName, int *nbytes, int verbose) { + + datum record; + + formItemKey(itemName); + record=readRecord(keybuf); + + *nbytes=record.dsize; + return record.dptr; +} + +void *xsdbRetrieveNuclideItem(char *nuclideName, + char *itemName, int *nbytes, int verbose) { + + formNuclideItemKey(nuclideName,itemName); + return xsdbRetrieveItem(keybuf,nbytes,verbose); +} + +void *xsdbRetrieveNuclideTempItem(char *nuclideName, + char *itemName, float temp, int *nbytes, int verbose) { + + formNuclideTempItemKey(nuclideName,itemName,temp); + return xsdbRetrieveItem(keybuf,nbytes,verbose); +} + +void *xsdbRetrieveNuclideGroupItem(char *nuclideName, + char *itemName, int g, int *nbytes, int verbose) { + + formNuclideGroupItemKey(nuclideName,itemName,g); + return xsdbRetrieveItem(keybuf,nbytes,verbose); +} diff --git a/Dragon/src/xsdbops.h b/Dragon/src/xsdbops.h new file mode 100644 index 0000000..0311a88 --- /dev/null +++ b/Dragon/src/xsdbops.h @@ -0,0 +1,84 @@ +/* + * $Id: xsdbops.h,v 1.6 1995/12/12 22:21:27 laughton Exp laughton $ + * + *--------------------------------------------------------------------------- + * + * Peter J. Laughton + * AECL + * Chalk River Laboratories + * Chalk River, Ontario + * CANADA K0J 1J0 + * + * Phone: (613) 584-8811, extension 4267 + * FAX: (613) 584-1108 + * + * Internet: laughtonp@crl.aecl.ca + * + *--------------------------------------------------------------------------- + * + * Revision history (as of 1995 August 9): + * + * $Log: xsdbops.h,v $ + * Revision 1.7 96/06/28 13:10:19 13:10:19 laughton + * support for NDAS file conversion started. + * + * Revision 1.6 1995/12/12 22:21:27 laughton + * more GDBM updates + * + * Revision 1.5 1995/12/12 19:59:38 laughton + * updated the GDBM routines + * + * Revision 1.4 1995/12/04 14:46:36 laughton + * continuing development + * + * Revision 1.3 1995/11/30 20:31:14 laughton + * XSDB files now opened in xsdbops files + * + * Revision 1.2 1995/10/10 18:26:19 laughton + * continuing development + * + * Revision 1.1 1995/08/24 20:27:28 laughton + * Initial revision + * + */ + +void xsdbReadInit(char *nomC, int *status); + +int xsdbCountRecs(int *status, int dbFileIndex); + +void xsdbWriteInit(int *status); + +void xsdbCloseWrite(); + +void xsdbStoreItem(char *itemName, void *from, + int nbytes, int dataType, int verbose); + +void xsdbStoreNuclideItem(char *nuclideName, + char *itemName, void *from, int nbytes, int dataType, int verbose); + +void xsdbStoreNuclideTempItem(char *nuclideName, + char *itemName, float temp, void *from, int nbytes, int dataType, int verbose); + +void xsdbStoreNuclideGroupItem(char *nuclideName, + char *itemName, int g, void *from, int nbytes, int dataType, int verbose); + + +/* ~~~~~~~~~~~~~~~~~~ */ +/* Retrieval Routines */ +/* ~~~~~~~~~~~~~~~~~~ */ + +/* The following routines make no check as to whether a record with + the specified key data exists, and run-time failure will result if + no such record is found. */ + + +void *xsdbRetrieveItem(char *itemName, int *nbytes, int verbose); + +void *xsdbRetrieveNuclideItem(char *nuclideName, + char *itemName, int *nbytes, int verbose); + +void *xsdbRetrieveNuclideTempItem(char *nuclideName, + char *itemName, float temp, int *nbytes, int verbose); + +void *xsdbRetrieveNuclideGroupItem(char *nuclideName, + char *itemName, int g, int *nbytes, int verbose); diff --git a/Dragon/src/xsdf.c b/Dragon/src/xsdf.c new file mode 100644 index 0000000..a1f759b --- /dev/null +++ b/Dragon/src/xsdf.c @@ -0,0 +1,1026 @@ + +/***************************************/ +/* Fortran bindings for the NDAS C API */ +/* Copyright: Peter J. Laughton, AECL */ +/***************************************/ + +#include +#include +#include +#include "xsdbops.h" +#include "sdbm.h" +#include "xsdb-defs.h" + +static char AbortString[132]; +static int packIndex; +typedef enum {Int, Float, Char8} PackType; +static char *packedBurnupData=0; +static char AbortString[132]; + +typedef struct { + int ib1, ib2; + float rb1, rb2; +} BurnQuad; + +typedef struct { + /* From subinx.inc: NBURN, ISOID, AW, IAN, NFISS, NTEMP, NR, + NSUBNK, NNA, NP1, NFSPEC, IENDFB */ + /* nomenclature of crnl-2866, page 3 */ + + int nburn; + int numericId; + float aw; + int iz; + int nf; + int nt; + int nr; + int ndat2; /* not in xs block on unf-seq file */ + int ndat3; /* not in xs block on unf-seq file */ + int np1; + int ns; + int iendfb; /* not in xs block on unf-seq file */ + char name[9]; + int installed; /* flagged true when all of this block has been loaded */ + BurnQuad *burnQuad; +} Nuclide; + +Nuclide *nuclide; /* array of all nuclides */ + +static int nLoadedNuclides=0; /* number actually available */ +static int lastNuclideAccessed=0; /* library index (1,...,nel) of last nuclide accessed */ + +typedef struct { + int code; + char *name; +} CodeNamePair; + +static CodeNamePair itemMap[]={ + {BickleyFunctionTablesKi3, "BickleyFunctionTablesKi3"}, + {BickleyFunctionTablesKi35, "BickleyFunctionTablesKi35"}, + {BurnCount, "BurnCount"}, + {BurnInteger, "BurnInteger"}, + {BurnReal, "BurnReal"}, + {Absorption, "Absorption"}, + {Transport, "Transport"}, + {Fission, "Fission"}, + {NuFission, "NuFission"}, + {N2n, "N2n"}, + {FissionSpectrum, "FissionSpectrum"}, + {PotScatSlowingDown, "PotScatSlowingDown"}, + {LengthsThermalP0, "LengthsThermalP0"}, + {GCLambda, "GCLambda"}, + {Header, "Header"}, + {ResHeader, "ResHeader"}, + {LengthsScatP1, "LengthsScatP1"}, + {ScatP0, "ScatP0"}, + {ScatP1, "ScatP1"}, + {ThermalXSTemp, "ThermalXSTemp"}, + {ThermalP1Temp, "ThermalP1Temp"}, + {GroupBoundaries, "GroupBoundaries"}, + {PotScat, "PotScat"}, + {NJOYFlux, "NJOYFlux"}, + {Hequivalence, "Hequivalence"}, + {HeqHeader, "HeqHeader"}, + {TransportCorrection, "TransportCorrection"} +}; + +static char *unknownMessage="--unknown--"; + +#define NITEMS (sizeof(itemMap)/sizeof(CodeNamePair)) + +char *itemName(int code) { + int i; + for (i=0; i%s<--\n",nomC); + fflush(logFile); + } + flist=strchr(nomC,':'); + if(!flist) { + fprintf(logFile,"index file missing; namfil=%s\n",nomC); + *status=OPEN_FAILURE; + return; + } + flist++; + xsdbReadInit(flist,status); + if (*status) /* non-zero means something is wrong */ + return; + + idxfn=strtok(nomC,":\n"); + + indexFile=fopen(idxfn,"r"); + if (!indexFile) { + perror(idxfn); + fprintf(logFile,"open failure for index file %s\n",idxfn); + *status=OPEN_FAILURE; + return; + } + + if(fscanf(indexFile,"%d",&nel) == EOF) goto L10; + if(fscanf(indexFile,"%d",&ng) == EOF) goto L10; + if(fscanf(indexFile,"%d",&ng0) == EOF) goto L10; + if(fscanf(indexFile,"%d",&ng1) == EOF) goto L10; + if(fscanf(indexFile,"%d",&ng2) == EOF) goto L10; + if(fscanf(indexFile,"%d",&ng3) == EOF) goto L10; + if(fscanf(indexFile,"%d",&fissileNuclideCount) == EOF) goto L10; + if(fscanf(indexFile,"%d",&nnfpd) == EOF) goto L10; + if(fscanf(indexFile,"%d",&p1NuclideCount) == EOF) goto L10; + if(fscanf(indexFile,"%d",&nresmc) == EOF) goto L10; + if(fscanf(indexFile,"%d",&n1rc) == EOF) goto L10; + if(fscanf(indexFile,"%d",&m1rc) == EOF) goto L10; + if(fscanf(indexFile,"%d",&n1m1rc) == EOF) goto L10; + if(fscanf(indexFile,"%d",&lsctfl) == EOF) goto L10; + if(fscanf(indexFile,"%d",&jp0max) == EOF) goto L10; + if(fscanf(indexFile,"%d",&jp1max) == EOF) goto L10; + + nuclide=MAKE_ARRAY(Nuclide,nel); + + if (!nuclide) { + fprintf(logFile,"error: memory allocation failure\n"); + exit(1); + } + + for (i=0; i nel) { + sprintf(AbortString,"%s: Insufficent allocation to hold isotope names",nomsub); + *status=RECORD_INDEX_OVERFLOW; + return; + } + + if (verbose) { + fprintf(logFile,"%10s %d\n",nuclide[*iset-1].name,nuclide[*iset-1].numericId); + fflush(logFile); + } + *numericId=nuclide[*iset-1].numericId; + + len=strlen(nuclide[*iset-1].name); + cp=isonam; + for (j=0; j